diff -Nru ghc-7.0.3/aclocal.m4 ghc-7.2.1/aclocal.m4 --- ghc-7.0.3/aclocal.m4 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/aclocal.m4 2011-08-07 17:10:05.000000000 +0000 @@ -78,6 +78,58 @@ GHC_CONVERT_VENDOR([$target_vendor], [TargetVendor]) GHC_CONVERT_OS([$target_os], [TargetOS]) fi + + windows=NO + exeext='' + soext='.so' + case $host in + *-unknown-cygwin32) + AC_MSG_WARN([GHC does not support the Cygwin target at the moment]) + AC_MSG_WARN([I'm assuming you wanted to build for i386-unknown-mingw32]) + exit 1 + ;; + *-unknown-mingw32) + windows=YES + exeext='.exe' + soext='.dll' + ;; + i386-apple-darwin|powerpc-apple-darwin) + soext='.dylib' + ;; + x86_64-apple-darwin) + soext='.dylib' + ;; + esac +]) + + +# FP_SETTINGS +# ---------------------------------- +# Set the variables used in the settings file +AC_DEFUN([FP_SETTINGS], +[ + if test "$windows" = YES + then + SettingsCCompilerCommand='$topdir/../mingw/bin/gcc.exe' + SettingsCCompilerFlags='' + SettingsPerlCommand='$topdir/../perl/perl.exe' + SettingsDllWrapCommand='$topdir/../mingw/bin/dllwrap.exe' + SettingsWindresCommand='$topdir/../mingw/bin/windres.exe' + SettingsTouchCommand='$topdir/touchy.exe' + else + SettingsCCompilerCommand="$WhatGccIsCalled" + SettingsCCompilerFlags="$CONF_CC_OPTS_STAGE2" + SettingsPerlCommand="$PerlCmd" + SettingsDllWrapCommand="/bin/false" + SettingsWindresCommand="/bin/false" + SettingsTouchCommand='touch' + fi + AC_SUBST(SettingsCCompilerCommand) + AC_SUBST(SettingsCCompilerFlags) + AC_SUBST(SettingsPerlCommand) + AC_SUBST(SettingsDllWrapCommand) + AC_SUBST(SettingsWindresCommand) + AC_SUBST(SettingsTouchCommand) ]) @@ -94,14 +146,10 @@ AC_MSG_CHECKING([Setting up $2, $3, $4 and $5]) case $$1 in i386-apple-darwin) - # By default, gcc on OS X will generate SSE - # instructions, which need things 16-byte aligned, - # but we don't 16-byte align things. Thus drop - # back to generic i686 compatibility. Trac #2983. - $2="$$2 -march=i686 -m32" - $3="$$3 -march=i686 -m32" + $2="$$2 -m32" + $3="$$3 -m32" $4="$$4 -arch i386" - $5="$$5 -march=i686 -m32" + $5="$$5 -m32" ;; x86_64-apple-darwin) $2="$$2 -m64" @@ -109,6 +157,21 @@ $4="$$4 -arch x86_64" $5="$$5 -m64" ;; + alpha-*) + # For now, to suppress the gcc warning "call-clobbered + # register used for global register variable", we simply + # disable all warnings altogether using the -w flag. Oh well. + $2="$$2 -w -mieee -D_REENTRANT" + $3="$$3 -w -mieee -D_REENTRANT" + $5="$$5 -w -mieee -D_REENTRANT" + ;; + hppa*) + # ___HPUX_SOURCE, not _HPUX_SOURCE, is #defined if -ansi! + # (very nice, but too bad the HP /usr/include files don't agree.) + $2="$$2 -D_HPUX_SOURCE" + $3="$$3 -D_HPUX_SOURCE" + $5="$$5 -D_HPUX_SOURCE" + ;; esac # If gcc knows about the stack protector, turn it off. @@ -123,6 +186,24 @@ ]) +# FP_VISIBILITY_HIDDEN +# ---------------------------------- +# Is the visibility hidden attribute supported? +AC_DEFUN([FP_VISIBILITY_HIDDEN], +[ + AC_MSG_CHECKING([whether __attribute__((visibility("hidden"))) is supported]) + echo '__attribute__((visibility("hidden"))) void foo(void) {}' > conftest.c + if $CC -Wall -Werror -c conftest.c > /dev/null 2>&1 + then + AC_MSG_RESULT([yes]) + AC_DEFINE(HAS_VISIBILITY_HIDDEN, 1, [Has visibility hidden]) + else + AC_MSG_RESULT([no]) + fi + rm -f conftest.c conftest.o +]) + + # FPTOOLS_FLOAT_WORD_ORDER_BIGENDIAN # ---------------------------------- # Little endian Arm on Linux with some ABIs has big endian word order @@ -167,8 +248,8 @@ # -------------------- # 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], [ @@ -466,6 +547,31 @@ ])# FP_PROG_LD_X +# FP_PROG_LD_BUILD_ID +# ------------ + +# Sets the output variable LdHasBuildId to YES if ld supports +# --build-id, or NO otherwise. +AC_DEFUN([FP_PROG_LD_BUILD_ID], +[ +AC_CACHE_CHECK([whether ld understands --build-id], [fp_cv_ld_build_id], +[echo 'foo() {}' > conftest.c +${CC-cc} -c conftest.c +if ${LdCmd} -r --build-id=none -o conftest2.o conftest.o > /dev/null 2>&1; then + fp_cv_ld_build_id=yes +else + fp_cv_ld_build_id=no +fi +rm -rf conftest*]) +if test "$fp_cv_ld_build_id" = yes; then + LdHasBuildId=YES +else + LdHasBuildId=NO +fi +AC_SUBST([LdHasBuildId]) +])# FP_PROG_LD_BUILD_ID + + # FP_PROG_LD_IS_GNU # ----------------- # Sets the output variable LdIsGNULd to YES or NO, depending on whether it is @@ -581,7 +687,7 @@ # FP_PROG_AR_NEEDS_RANLIB # ----------------------- # Sets the output variable RANLIB to "ranlib" if it is needed and found, -# to ":" otherwise. +# to "true" otherwise. AC_DEFUN([FP_PROG_AR_NEEDS_RANLIB], [AC_REQUIRE([FP_PROG_AR_IS_GNU]) AC_REQUIRE([FP_PROG_AR_ARGS]) @@ -601,38 +707,12 @@ if test $fp_cv_prog_ar_needs_ranlib = yes; then AC_PROG_RANLIB else - RANLIB=":" + RANLIB="true" AC_SUBST([RANLIB]) 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 @@ -652,38 +732,33 @@ ])]) -# 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= +GccLT34=NO +GccLT46=NO 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) + FP_COMPARE_VERSIONS([$fp_cv_gcc_version], [-lt], [4.6], GccLT46=YES) ]) -AC_SUBST([HaveGcc], [$fp_have_gcc]) AC_SUBST([GccVersion], [$fp_cv_gcc_version]) AC_SUBST(GccLT34) -])# FP_HAVE_GCC +AC_SUBST(GccLT46) +])# FP_GCC_VERSION dnl Small feature test for perl version. Assumes PerlCmd dnl contains path to perl binary. @@ -1011,18 +1086,6 @@ ])# FP_PROG_FOP -# FP_PROG_HSTAGS -# ---------------- -# Sets the output variable HstagsCmd to the full Haskell tags program path. -# HstagsCmd is empty if no such program could be found. -AC_DEFUN([FP_PROG_HSTAGS], -[AC_PATH_PROG([HstagsCmd], [hasktags]) -if test -z "$HstagsCmd"; then - AC_MSG_WARN([cannot find hasktags in your PATH, you will not be able to build the tags]) -fi -])# FP_PROG_HSTAGS - - # FP_PROG_GHC_PKG # ---------------- # Try to find a ghc-pkg matching the ghc mentioned in the environment variable @@ -1051,43 +1114,16 @@ # Determine which extra flags we need to pass gcc when we invoke it # to compile .hc code. # -# Some OSs (Mandrake Linux, in particular) configure GCC with -# -momit-leaf-frame-pointer on by default. If this is the case, we -# need to turn it off for mangling to work. The test is currently a -# bit crude, using only the version number of gcc. -# # -fwrapv is needed for gcc to emit well-behaved code in the presence of # integer wrap around. (Trac #952) # -# -fno-unit-at-a-time or -fno-toplevel-reoder is necessary to avoid gcc -# reordering things in the module and confusing the manger and/or splitter. -# (eg. Trac #1427) -# 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], [fp_cv_gcc_extra_opts="$fp_cv_gcc_extra_opts -fwrapv"], []) - case $TargetPlatform in - i386-*|x86_64-*) - FP_COMPARE_VERSIONS([$fp_cv_gcc_version], [-ge], [3.2], - [fp_cv_gcc_extra_opts="$fp_cv_gcc_extra_opts -mno-omit-leaf-frame-pointer"], - []) - FP_COMPARE_VERSIONS([$fp_cv_gcc_version], [-ge], [3.4], - [FP_COMPARE_VERSIONS([$fp_cv_gcc_version], [-ge], [4.2], - [fp_cv_gcc_extra_opts="$fp_cv_gcc_extra_opts -fno-toplevel-reorder"], - [fp_cv_gcc_extra_opts="$fp_cv_gcc_extra_opts -fno-unit-at-a-time"] - )], - []) - ;; - sparc-*-solaris2) - FP_COMPARE_VERSIONS([$fp_cv_gcc_version], [-ge], [4.2], - [fp_cv_gcc_extra_opts="$fp_cv_gcc_extra_opts -fno-toplevel-reorder"], - []) - ;; - esac ]) AC_SUBST([GccExtraViaCOpts],$fp_cv_gcc_extra_opts) ]) @@ -1104,7 +1140,7 @@ AC_MSG_RESULT(given $PACKAGE_VERSION) elif test -d .git; then changequote(, )dnl - ver_date=`git log -n 1 --date=short --pretty=format:%ci | sed "s/^.*\([0-9][0-9][0-9][0-9]\)-\([0-9][0-9]\)-\([0-9][0-9]\).*$/\1\2\3/"` + ver_date=`git log -n 1 --date=short --pretty=format:%ci | cut -d ' ' -f 1 | tr -d -` if echo $ver_date | grep '^[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9]$' 2>&1 >/dev/null; then true; else changequote([, ])dnl AC_MSG_ERROR([failed to detect version date: check that git is in your path]) @@ -1384,7 +1420,7 @@ ]) AC_DEFUN([FP_BINDIST_GHC_PWD],[ - GHC_PWD=utils/ghc-pwd/dist/build/tmp/ghc-pwd + GHC_PWD=utils/ghc-pwd/dist-install/build/tmp/ghc-pwd ]) AC_DEFUN([FP_FIND_ROOT],[ @@ -1430,7 +1466,7 @@ hppa*) $2="hppa" ;; - i386) + i386|i486|i586|i686) $2="i386" ;; ia64) @@ -1483,7 +1519,18 @@ # -------------------------------- # converts vendor from gnu to ghc naming, and assigns the result to $target_var AC_DEFUN([GHC_CONVERT_VENDOR],[ -$2="$1" + case "$1" in + pc|gentoo) # like i686-pc-linux-gnu and i686-gentoo-freebsd8 + $2="unknown" + ;; + softfloat) # like armv5tel-softfloat-linux-gnueabi + $2="unknown" + ;; + *) + #pass thru by default + $2="$1" + ;; + esac ]) # GHC_CONVERT_OS(os, target_var) @@ -1498,6 +1545,9 @@ freebsd|netbsd|openbsd|dragonfly|osf1|osf3|hpux|linuxaout|kfreebsdgnu|freebsd2|solaris2|cygwin32|mingw32|darwin|gnu|nextstep2|nextstep3|sunos4|ultrix|irix|aix|haiku) $2="$1" ;; + freebsd8) # like i686-gentoo-freebsd8 + $2="freebsd" + ;; *) echo "Unknown OS $1" exit 1 @@ -1505,13 +1555,74 @@ esac ]) -# LIBRARY_VERSION(lib) +# 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, [dir]) # -------------------------------- # Gets the version number of a library. # If $1 is ghc-prim, then we define LIBRARY_ghc_prim_VERSION as 1.2.3 +# $2 points to the directory under libraries/ AC_DEFUN([LIBRARY_VERSION],[ -LIBRARY_[]translit([$1], [-], [_])[]_VERSION=`grep -i "^version:" libraries/$1/$1.cabal | sed "s/.* //"` +dir=m4_default([$2],[$1]) +LIBRARY_[]translit([$1], [-], [_])[]_VERSION=`grep -i "^version:" libraries/${dir}/$1.cabal | sed "s/.* //"` AC_SUBST(LIBRARY_[]translit([$1], [-], [_])[]_VERSION) ]) +# XCODE_VERSION() +# -------------------------------- +# Gets the version number of XCode, if on a Mac +AC_DEFUN([XCODE_VERSION],[ + if test "$TargetOS_CPP" = "darwin" + then + AC_MSG_CHECKING(XCode version) + XCodeVersion=`xcodebuild -version | grep Xcode | sed "s/Xcode //"` + # Old XCode versions don't actually give the XCode version + if test "$XCodeVersion" = "" + then + AC_MSG_RESULT(not found (too old?)) + XCodeVersion1=0 + XCodeVersion2=0 + else + AC_MSG_RESULT($XCodeVersion) + XCodeVersion1=`echo "$XCodeVersion" | sed 's/\..*//'` + changequote(, )dnl + XCodeVersion2=`echo "$XCodeVersion" | sed 's/[^.]*\.\([^.]*\).*/\1/'` + changequote([, ])dnl + AC_MSG_NOTICE(XCode version component 1: $XCodeVersion1) + AC_MSG_NOTICE(XCode version component 2: $XCodeVersion2) + fi + fi +]) + +# FIND_GCC() +# -------------------------------- +# Finds where gcc is +AC_DEFUN([FIND_GCC],[ + if test "$TargetOS_CPP" = "darwin" && + test "$XCodeVersion1" -ge 4 + then + # From Xcode 4, use 'gcc-4.2' to force the use of the gcc legacy + # backend (instead of the LLVM backend) + FP_ARG_WITH_PATH_GNU_PROG([CC], [gcc-4.2]) + else + FP_ARG_WITH_PATH_GNU_PROG([CC], [gcc]) + fi + export CC + WhatGccIsCalled="$CC" + AC_SUBST(WhatGccIsCalled) +]) + # LocalWords: fi diff -Nru ghc-7.0.3/ANNOUNCE ghc-7.2.1/ANNOUNCE --- ghc-7.0.3/ANNOUNCE 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/ANNOUNCE 2011-08-07 17:10:05.000000000 +0000 @@ -1,15 +1,27 @@ ============================================================= - The (Interactive) Glasgow Haskell Compiler -- version 7.0.3 + The (Interactive) Glasgow Haskell Compiler -- version 7.2.1 ============================================================= -The GHC Team is pleased to announce a new patchlevel release of GHC. -This release contains a handful of bugfixes relative to 7.0.2, so we -recommend upgrading. +The GHC Team is pleased to announce a new major release of GHC, 7.2.1. -The release notes are here: +The 7.2 branch is intended to be more of a "technology preview" than +normal GHC stable branches; in particular, it supports a significantly +improved version of DPH, as well as new features such as compiler +plugins and "safe Haskell". The design of these new features may evolve +as we get more experience with them. See the release notes for more +details of what's new and what's changed. - http://www.haskell.org/ghc/docs/7.0.3/html/users_guide/release-7-0-3.html +We are also using this branch as an opportunity to work out the best +workflows to use with git. + +We expect the 7.2 branch to be short-lived, with 7.4.1 coming out +shortly after ICFP as normal. + + +Full release notes are here: + + http://www.haskell.org/ghc/docs/7.2.1/html/users_guide/release-7-2-1.html How to get it ~~~~~~~~~~~~~ diff -Nru ghc-7.0.3/bindisttest/ghc.mk ghc-7.2.1/bindisttest/ghc.mk --- ghc-7.0.3/bindisttest/ghc.mk 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/bindisttest/ghc.mk 2011-08-07 17:10:05.000000000 +0000 @@ -19,7 +19,7 @@ .PHONY: test_bindist test_bindist: "$(RM)" $(RM_OPTS_REC) bindisttest/$(BIN_DIST_INST_SUBDIR) - "$(RM)" $(RM_OPTS_REC) bindisttest/a/b/c/* + "$(RM)" $(RM_OPTS_REC) bindisttest/a "$(RM)" $(RM_OPTS) bindisttest/HelloWorld "$(RM)" $(RM_OPTS) bindisttest/HelloWorld.o "$(RM)" $(RM_OPTS) bindisttest/HelloWorld.hi @@ -30,6 +30,9 @@ # NB. tar has funny interpretation of filenames sometimes (thinking # c:/foo is a remote file), so it's safer to bzip and then pipe into # tar rather than using tar -xjf: + mkdir bindisttest/a + mkdir bindisttest/a/b + mkdir bindisttest/a/b/c cd bindisttest/a/b/c/ && $(BZIP2_CMD) -cd ../../../../$(BIN_DIST_TEST_TAR_BZ2) | $(TAR_CMD) -xf - $(SHELL) bindisttest/checkBinaries.sh $(ProjectVersion) ifeq "$(Windows)" "YES" diff -Nru ghc-7.0.3/boot ghc-7.2.1/boot --- ghc-7.0.3/boot 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/boot 2011-08-07 17:10:05.000000000 +0000 @@ -3,62 +3,232 @@ use strict; use Cwd; +use File::Path 'rmtree'; +use File::Basename; -# Create libraries/*/{ghc.mk,GNUmakefile} -system("/usr/bin/perl", "-w", "boot-pkgs") == 0 - or die "Running boot-pkgs failed: $?"; - -my $tag; -my $dir; +my %required_tag; +my $validate; my $curdir; +$required_tag{"-"} = 1; +$validate = 0; + $curdir = &cwd() or die "Can't find current directory: $!"; -# 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 ($tag eq "-") { - # We would like to just check for an _darcs directory here, - # but in an lndir tree we avoid making _darcs 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 './darcs-all get'?"; +while ($#ARGV ne -1) { + my $arg = shift @ARGV; + + if ($arg =~ /^--required-tag=(.*)/) { + $required_tag{$1} = 1; + } + elsif ($arg =~ /^--validate$/) { + $validate = 1; + } + else { + die "Bad arg: $arg"; + } +} + +sub sanity_check_line_endings { + local $/ = undef; + open FILE, "packages" or die "Couldn't open file: $!"; + binmode FILE; + my $string = ; + close FILE; + + if ($string =~ /\r/) { + print STDERR <) { + 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: $_"; + } } - else { - die "Bad line in packages file: $_"; + close PACKAGES; +} + +# 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"; + } + + 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: $!"; + } + } + } + + 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 "\$(if \$(filter ${dir},\$(PACKAGES_STAGE0)),\$(eval \$(call build-package,${package},dist-boot,0)))\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: $!"; + } } } -# Alas, darcs doesn't handle file permissions, so fix a few of them. -for my $file ("boot", "darcs-all", "validate") { - if (-f $file) { - chmod 0755, $file - or die "Can't chmod 0755 $file: $!"; +sub checkBuildMk { + 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; - 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 -Nru ghc-7.0.3/compiler/basicTypes/BasicTypes.lhs ghc-7.2.1/compiler/basicTypes/BasicTypes.lhs --- ghc-7.0.3/compiler/basicTypes/BasicTypes.lhs 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/basicTypes/BasicTypes.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -19,7 +19,9 @@ module BasicTypes( Version, bumpVersion, initialVersion, - Arity, + Arity, + + Alignment, FunctionOrData(..), @@ -45,8 +47,8 @@ TupCon(..), tupleParens, OccInfo(..), seqOccInfo, zapFragileOcc, isOneOcc, - isDeadOcc, isLoopBreaker, isNonRuleLoopBreaker, isNoOcc, - nonRuleLoopBreaker, + isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker, isNoOcc, + strongLoopBreaker, weakLoopBreaker, InsideLam, insideLam, notInsideLam, OneBranch, oneBranch, notOneBranch, @@ -72,13 +74,16 @@ inlinePragmaActivation, inlinePragmaRuleMatchInfo, setInlinePragmaActivation, setInlinePragmaRuleMatchInfo, - SuccessFlag(..), succeeded, failed, successIf + SuccessFlag(..), succeeded, failed, successIf, + + FractionalLit(..), negateFractionalLit, integralFractionalLit ) where import FastString import Outputable import Data.Data hiding (Fixity) +import Data.Function (on) \end{code} %************************************************************************ @@ -93,6 +98,16 @@ %************************************************************************ %* * +\subsection[Alignment]{Alignment} +%* * +%************************************************************************ + +\begin{code} +type Alignment = Int -- align to next N-byte boundary (N must be a power of 2). +\end{code} + +%************************************************************************ +%* * \subsection[FunctionOrData]{FunctionOrData} %* * %************************************************************************ @@ -321,38 +336,43 @@ \begin{code} data OverlapFlag - = NoOverlap -- This instance must not overlap another + -- | This instance must not overlap another + = NoOverlap { isSafeOverlap :: Bool } - | OverlapOk -- Silently ignore this instance if you find a - -- more specific one that matches the constraint - -- you are trying to resolve - -- - -- Example: constraint (Foo [Int]) - -- instances (Foo [Int]) - - -- (Foo [a]) OverlapOk - -- Since the second instance has the OverlapOk flag, - -- the first instance will be chosen (otherwise - -- its ambiguous which to choose) - - | Incoherent -- Like OverlapOk, but also ignore this instance - -- if it doesn't match the constraint you are - -- trying to resolve, but could match if the type variables - -- in the constraint were instantiated - -- - -- Example: constraint (Foo [b]) - -- instances (Foo [Int]) Incoherent - -- (Foo [a]) - -- Without the Incoherent flag, we'd complain that - -- instantiating 'b' would change which instance - -- was chosen + -- | Silently ignore this instance if you find a + -- more specific one that matches the constraint + -- you are trying to resolve + -- + -- Example: constraint (Foo [Int]) + -- instances (Foo [Int]) + -- (Foo [a]) OverlapOk + -- Since the second instance has the OverlapOk flag, + -- the first instance will be chosen (otherwise + -- its ambiguous which to choose) + | OverlapOk { isSafeOverlap :: Bool } + + -- | Like OverlapOk, but also ignore this instance + -- if it doesn't match the constraint you are + -- trying to resolve, but could match if the type variables + -- in the constraint were instantiated + -- + -- Example: constraint (Foo [b]) + -- instances (Foo [Int]) Incoherent + -- (Foo [a]) + -- Without the Incoherent flag, we'd complain that + -- instantiating 'b' would change which instance + -- was chosen + | Incoherent { isSafeOverlap :: Bool } deriving( Eq ) instance Outputable OverlapFlag where - ppr NoOverlap = empty - ppr OverlapOk = ptext (sLit "[overlap ok]") - ppr Incoherent = ptext (sLit "[incoherent]") - + ppr (NoOverlap b) = empty <+> pprSafeOverlap b + ppr (OverlapOk b) = ptext (sLit "[overlap ok]") <+> pprSafeOverlap b + ppr (Incoherent b) = ptext (sLit "[incoherent]") <+> pprSafeOverlap b + +pprSafeOverlap :: Bool -> SDoc +pprSafeOverlap True = ptext $ sLit "[safe]" +pprSafeOverlap False = empty \end{code} %************************************************************************ @@ -436,24 +456,20 @@ -- | This identifier breaks a loop of mutually recursive functions. The field -- marks whether it is only a loop breaker due to a reference in a rule | IAmALoopBreaker -- Note [LoopBreaker OccInfo] - !RulesOnly -- True <=> This is a weak or rules-only loop breaker - -- See OccurAnal Note [Weak loop breakers] + !RulesOnly type RulesOnly = Bool \end{code} Note [LoopBreaker OccInfo] ~~~~~~~~~~~~~~~~~~~~~~~~~~ -An OccInfo of (IAmLoopBreaker False) is used by the occurrence -analyser in two ways: - (a) to mark loop-breakers in a group of recursive - definitions (hence the name) - (b) to mark binders that must not be inlined in this phase - (perhaps it has a NOINLINE pragma) -Things with (IAmLoopBreaker False) do not get an unfolding -pinned on to them, so they are completely opaque. + IAmALoopBreaker True <=> A "weak" or rules-only loop breaker + Do not preInlineUnconditionally + + IAmALoopBreaker False <=> A "strong" loop breaker + Do not inline at all -See OccurAnal Note [Weak loop breakers] for (IAmLoopBreaker True). +See OccurAnal Note [Weak loop breakers] \begin{code} @@ -484,16 +500,17 @@ oneBranch = True notOneBranch = False -isLoopBreaker :: OccInfo -> Bool -isLoopBreaker (IAmALoopBreaker _) = True -isLoopBreaker _ = False - -isNonRuleLoopBreaker :: OccInfo -> Bool -isNonRuleLoopBreaker (IAmALoopBreaker False) = True -- Loop-breaker that breaks a non-rule cycle -isNonRuleLoopBreaker _ = False - -nonRuleLoopBreaker :: OccInfo -nonRuleLoopBreaker = IAmALoopBreaker False +strongLoopBreaker, weakLoopBreaker :: OccInfo +strongLoopBreaker = IAmALoopBreaker False +weakLoopBreaker = IAmALoopBreaker True + +isWeakLoopBreaker :: OccInfo -> Bool +isWeakLoopBreaker (IAmALoopBreaker _) = True +isWeakLoopBreaker _ = False + +isStrongLoopBreaker :: OccInfo -> Bool +isStrongLoopBreaker (IAmALoopBreaker False) = True -- Loop-breaker that breaks a non-rule cycle +isStrongLoopBreaker _ = False isDeadOcc :: OccInfo -> Bool isDeadOcc IAmDead = True @@ -862,3 +879,36 @@ isEarlyActive _ = False \end{code} + + +\begin{code} +-- Used (instead of Rational) to represent exactly the floating point literal that we +-- encountered in the user's source program. This allows us to pretty-print exactly what +-- the user wrote, which is important e.g. for floating point numbers that can't represented +-- as Doubles (we used to via Double for pretty-printing). See also #2245. +data FractionalLit + = FL { fl_text :: String -- How the value was written in the source + , fl_value :: Rational -- Numeric value of the literal + } + deriving (Data, Typeable, Show) + -- The Show instance is required for the derived Lexer.x:Token instance when DEBUG is on + +negateFractionalLit :: FractionalLit -> FractionalLit +negateFractionalLit (FL { fl_text = '-':text, fl_value = value }) = FL { fl_text = text, fl_value = negate value } +negateFractionalLit (FL { fl_text = text, fl_value = value }) = FL { fl_text = '-':text, fl_value = negate value } + +integralFractionalLit :: Integer -> FractionalLit +integralFractionalLit i = FL { fl_text = show i, fl_value = fromInteger i } + +-- Comparison operations are needed when grouping literals +-- for compiling pattern-matching (module MatchLit) + +instance Eq FractionalLit where + (==) = (==) `on` fl_value + +instance Ord FractionalLit where + compare = compare `on` fl_value + +instance Outputable FractionalLit where + ppr = text . fl_text +\end{code} diff -Nru ghc-7.0.3/compiler/basicTypes/DataCon.lhs ghc-7.2.1/compiler/basicTypes/DataCon.lhs --- ghc-7.0.3/compiler/basicTypes/DataCon.lhs 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/basicTypes/DataCon.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -18,7 +18,7 @@ dataConName, dataConIdentity, dataConTag, dataConTyCon, dataConOrigTyCon, dataConUserType, dataConUnivTyVars, dataConExTyVars, dataConAllTyVars, - dataConEqSpec, eqSpecPreds, dataConEqTheta, dataConDictTheta, + dataConEqSpec, eqSpecPreds, dataConTheta, dataConStupidTheta, dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy, dataConInstOrigArgTys, dataConRepArgTys, @@ -31,7 +31,7 @@ -- ** Predicates on DataCons isNullarySrcDataCon, isNullaryRepDataCon, isTupleCon, isUnboxedTupleCon, - isVanillaDataCon, classDataCon, + isVanillaDataCon, classDataCon, dataConCannotMatch, -- * Splitting product types splitProductType_maybe, splitProductType, deepSplitProductType, @@ -41,6 +41,7 @@ #include "HsVersions.h" import Type +import Unify import Coercion import TyCon import Class @@ -55,9 +56,9 @@ import Module import qualified Data.Data as Data +import qualified Data.Typeable import Data.Char import Data.Word -import Data.List ( partition ) \end{code} @@ -256,8 +257,7 @@ -- dcUnivTyVars = [a] -- dcExTyVars = [x,y] -- dcEqSpec = [a~(x,y)] - -- dcEqTheta = [x~y] - -- dcDictTheta = [Ord x] + -- dcOtherTheta = [x~y, Ord x] -- dcOrigArgTys = [a,List b] -- dcRepTyCon = T @@ -265,7 +265,7 @@ -- Its type is of form -- forall a1..an . t1 -> ... tm -> T a1..an -- No existentials, no coercions, nothing. - -- That is: dcExTyVars = dcEqSpec = dcEqTheta = dcDictTheta = [] + -- That is: dcExTyVars = dcEqSpec = dcOtherTheta = [] -- NB 1: newtypes always have a vanilla data con -- NB 2: a vanilla constructor can still be declared in GADT-style -- syntax, provided its type looks like the above. @@ -300,8 +300,8 @@ -- In GADT form, this is *exactly* what the programmer writes, even if -- the context constrains only universally quantified variables -- MkT :: forall a b. (a ~ b, Ord b) => a -> T a b - dcEqTheta :: ThetaType, -- The *equational* constraints - dcDictTheta :: ThetaType, -- The *type-class and implicit-param* constraints + dcOtherTheta :: ThetaType, -- The other constraints in the data con's type + -- other than those in the dcEqSpec dcStupidTheta :: ThetaType, -- The context of the data type declaration -- data Eq a => T a = ... @@ -338,9 +338,9 @@ -- length = 0 (if not a record) or dataConSourceArity. -- Constructor representation - dcRepArgTys :: [Type], -- Final, representation argument types, - -- after unboxing and flattening, - -- and *including* existential dictionaries + dcRepArgTys :: [Type], -- Final, representation argument types, + -- after unboxing and flattening, + -- and *including* all existential evidence args dcRepStrictness :: [StrictnessMark], -- One for each *representation* *value* argument @@ -375,6 +375,7 @@ -- Used for Template Haskell and 'deriving' only -- The actual fixity is stored elsewhere } + deriving Data.Typeable.Typeable -- | Contains the Ids of the data constructor functions data DataConIds @@ -457,9 +458,6 @@ instance Show DataCon where showsPrec p con = showsPrecSDoc p (ppr con) -instance Data.Typeable DataCon where - typeOf _ = Data.mkTyConApp (Data.mkTyCon "DataCon") [] - instance Data.Data DataCon where -- don't traverse? toConstr _ = abstractConstr "DataCon" @@ -519,8 +517,8 @@ dcVanilla = is_vanilla, dcInfix = declared_infix, dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, dcEqSpec = eq_spec, + dcOtherTheta = theta, dcStupidTheta = stupid_theta, - dcEqTheta = eq_theta, dcDictTheta = dict_theta, dcOrigArgTys = orig_arg_tys, dcOrigResTy = orig_res_ty, dcRepTyCon = rep_tycon, dcRepArgTys = rep_arg_tys, @@ -536,10 +534,9 @@ -- The 'arg_stricts' passed to mkDataCon are simply those for the -- source-language arguments. We add extra ones for the -- dictionary arguments right here. - (eq_theta,dict_theta) = partition isEqPred theta - dict_tys = mkPredTys dict_theta - real_arg_tys = dict_tys ++ orig_arg_tys - real_stricts = map mk_dict_strict_mark dict_theta ++ arg_stricts + full_theta = eqSpecPreds eq_spec ++ theta + real_arg_tys = mkPredTys full_theta ++ orig_arg_tys + real_stricts = map mk_dict_strict_mark full_theta ++ arg_stricts -- Representation arguments and demands -- To do: eliminate duplication with MkId @@ -547,11 +544,6 @@ tag = assoc "mkDataCon" (tyConDataCons rep_tycon `zip` [fIRST_TAG..]) con ty = mkForAllTys univ_tvs $ mkForAllTys ex_tvs $ - mkFunTys (mkPredTys (eqSpecPreds eq_spec)) $ - mkFunTys (mkPredTys eq_theta) $ - -- NB: the dict args are already in rep_arg_tys - -- because they might be flattened.. - -- but the equality predicates are not mkFunTys rep_arg_tys $ mkTyConApp rep_tycon (mkTyVarTys univ_tvs) @@ -611,13 +603,10 @@ dataConEqSpec :: DataCon -> [(TyVar,Type)] dataConEqSpec = dcEqSpec --- | The equational constraints on the data constructor type -dataConEqTheta :: DataCon -> ThetaType -dataConEqTheta = dcEqTheta - --- | The type class and implicit parameter contsraints on the data constructor type -dataConDictTheta :: DataCon -> ThetaType -dataConDictTheta = dcDictTheta +-- | The *full* constraints on the constructor type +dataConTheta :: DataCon -> ThetaType +dataConTheta (MkData { dcEqSpec = eq_spec, dcOtherTheta = theta }) + = eqSpecPreds eq_spec ++ theta -- | Get the Id of the 'DataCon' worker: a function that is the "actual" -- constructor and has no top level binding in the program. The type may @@ -666,10 +655,10 @@ dataConStrictMarks :: DataCon -> [HsBang] dataConStrictMarks = dcStrictMarks --- | Strictness of /existential/ arguments only +-- | Strictness of evidence arguments to the wrapper function dataConExStricts :: DataCon -> [HsBang] -- Usually empty, so we don't bother to cache this -dataConExStricts dc = map mk_dict_strict_mark $ dcDictTheta dc +dataConExStricts dc = map mk_dict_strict_mark $ (dataConTheta dc) -- | Source-level arity of the data constructor dataConSourceArity :: DataCon -> Arity @@ -705,10 +694,10 @@ -- -- 4) The /original/ result type of the 'DataCon' dataConSig :: DataCon -> ([TyVar], ThetaType, [Type], Type) -dataConSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, dcEqSpec = eq_spec, - dcEqTheta = eq_theta, dcDictTheta = dict_theta, +dataConSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, + dcEqSpec = eq_spec, dcOtherTheta = theta, dcOrigArgTys = arg_tys, dcOrigResTy = res_ty}) - = (univ_tvs ++ ex_tvs, eqSpecPreds eq_spec ++ eq_theta ++ dict_theta, arg_tys, res_ty) + = (univ_tvs ++ ex_tvs, eqSpecPreds eq_spec ++ theta, arg_tys, res_ty) -- | The \"full signature\" of the 'DataCon' returns, in order: -- @@ -725,11 +714,11 @@ -- -- 6) The original result type of the 'DataCon' dataConFullSig :: DataCon - -> ([TyVar], [TyVar], [(TyVar,Type)], ThetaType, ThetaType, [Type], Type) -dataConFullSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, dcEqSpec = eq_spec, - dcEqTheta = eq_theta, dcDictTheta = dict_theta, + -> ([TyVar], [TyVar], [(TyVar,Type)], ThetaType, [Type], Type) +dataConFullSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, + dcEqSpec = eq_spec, dcOtherTheta = theta, dcOrigArgTys = arg_tys, dcOrigResTy = res_ty}) - = (univ_tvs, ex_tvs, eq_spec, eq_theta, dict_theta, arg_tys, res_ty) + = (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty) dataConOrigResTy :: DataCon -> Type dataConOrigResTy dc = dcOrigResTy dc @@ -754,11 +743,10 @@ -- mentions the family tycon, not the internal one. dataConUserType (MkData { dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, dcEqSpec = eq_spec, - dcEqTheta = eq_theta, dcDictTheta = dict_theta, dcOrigArgTys = arg_tys, + dcOtherTheta = theta, dcOrigArgTys = arg_tys, dcOrigResTy = res_ty }) = mkForAllTys ((univ_tvs `minusList` map fst eq_spec) ++ ex_tvs) $ - mkFunTys (mkPredTys eq_theta) $ - mkFunTys (mkPredTys dict_theta) $ + mkFunTys (mkPredTys theta) $ mkFunTys arg_tys $ res_ty @@ -841,6 +829,25 @@ [] -> panic "classDataCon" \end{code} +\begin{code} +dataConCannotMatch :: [Type] -> DataCon -> Bool +-- Returns True iff the data con *definitely cannot* match a +-- scrutinee of type (T tys) +-- where T is the type constructor for the data con +-- NB: look at *all* equality constraints, not only those +-- in dataConEqSpec; see Trac #5168 +dataConCannotMatch tys con + | null theta = False -- Common + | all isTyVarTy tys = False -- Also common + | otherwise + = typesCantMatch [(Type.substTy subst ty1, Type.substTy subst ty2) + | EqPred ty1 ty2 <- theta ] + where + dc_tvs = dataConUnivTyVars con + theta = dataConTheta con + subst = zipTopTvSubst dc_tvs tys +\end{code} + %************************************************************************ %* * \subsection{Splitting products} diff -Nru ghc-7.0.3/compiler/basicTypes/IdInfo.lhs ghc-7.2.1/compiler/basicTypes/IdInfo.lhs --- ghc-7.0.3/compiler/basicTypes/IdInfo.lhs 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/basicTypes/IdInfo.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -10,7 +10,7 @@ \begin{code} module IdInfo ( -- * The IdDetails type - IdDetails(..), pprIdDetails, + IdDetails(..), pprIdDetails, coVarDetails, -- * The IdInfo type IdInfo, -- Abstract @@ -38,7 +38,7 @@ -- ** The OccInfo type OccInfo(..), - isDeadOcc, isLoopBreaker, + isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker, occInfo, setOccInfo, InsideLam, OneBranch, @@ -46,6 +46,7 @@ -- ** The SpecInfo type SpecInfo(..), + emptySpecInfo, isEmptySpecInfo, specInfoFreeVars, specInfoRules, seqSpecInfo, setSpecInfoHead, specInfo, setSpecInfo, @@ -128,18 +129,14 @@ | TickBoxOpId TickBoxOp -- ^ The 'Id' is for a HPC tick box (both traditional and binary) - | DFunId Int Bool -- ^ A dictionary function. - -- Int = the number of "silent" arguments to the dfun - -- e.g. class D a => C a where ... - -- instance C a => C [a] - -- has is_silent = 1, because the dfun - -- has type dfun :: (D a, C a) => C [a] - -- See the DFun Superclass Invariant in TcInstDcls - -- + | DFunId Bool -- ^ A dictionary function. -- Bool = True <=> the class has only one method, so may be -- implemented with a newtype, so it might be bad -- to be strict on this dictionary +coVarDetails :: IdDetails +coVarDetails = VanillaId + instance Outputable IdDetails where ppr = pprIdDetails @@ -154,8 +151,7 @@ pp (PrimOpId _) = ptext (sLit "PrimOp") pp (FCallId _) = ptext (sLit "ForeignCall") pp (TickBoxOpId _) = ptext (sLit "TickBoxOp") - pp (DFunId ns nt) = ptext (sLit "DFunId") - <> ppWhen (ns /= 0) (brackets (int ns)) + pp (DFunId nt) = ptext (sLit "DFunId") <> ppWhen nt (ptext (sLit "(nt)")) pp (RecSelId { sel_naughty = is_naughty }) = brackets $ ptext (sLit "RecSel") diff -Nru ghc-7.0.3/compiler/basicTypes/IdInfo.lhs-boot ghc-7.2.1/compiler/basicTypes/IdInfo.lhs-boot --- ghc-7.0.3/compiler/basicTypes/IdInfo.lhs-boot 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/basicTypes/IdInfo.lhs-boot 2011-08-07 17:10:05.000000000 +0000 @@ -4,5 +4,7 @@ data IdInfo data IdDetails +vanillaIdInfo :: IdInfo +coVarDetails :: IdDetails pprIdDetails :: IdDetails -> SDoc \end{code} \ No newline at end of file diff -Nru ghc-7.0.3/compiler/basicTypes/Id.lhs ghc-7.2.1/compiler/basicTypes/Id.lhs --- ghc-7.0.3/compiler/basicTypes/Id.lhs 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/basicTypes/Id.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -23,7 +23,7 @@ -- * 'Var.Var': see "Var#name_types" module Id ( -- * The main types - Id, DictId, + Var, Id, isId, -- ** Simple construction mkGlobalId, mkVanillaGlobal, mkVanillaGlobalWithInfo, @@ -34,8 +34,7 @@ -- ** Taking an Id apart idName, idType, idUnique, idInfo, idDetails, - isId, idPrimRep, - recordSelectorFieldLabel, + idPrimRep, recordSelectorFieldLabel, -- ** Modifying an Id setIdName, setIdUnique, Id.setIdType, @@ -46,10 +45,11 @@ -- ** Predicates on Ids - isImplicitId, isDeadBinder, isDictId, isStrictId, + isImplicitId, isDeadBinder, + isStrictId, isExportedId, isLocalId, isGlobalId, isRecordSelector, isNaughtyRecordSelector, - isClassOpId_maybe, isDFunId, dfunNSilent, + isClassOpId_maybe, isDFunId, isPrimOpId, isPrimOpId_maybe, isFCallId, isFCallId_maybe, isDataConWorkId, isDataConWorkId_maybe, isDataConId_maybe, idDataCon, @@ -57,6 +57,9 @@ isTickBoxOp, isTickBoxOp_maybe, hasNoBinding, + -- ** Evidence variables + DictId, isDictId, isEvVar, evVarPred, + -- ** Inline pragma stuff idInlinePragma, setInlinePragma, modifyInlinePragma, idInlineActivation, setInlineActivation, idRuleMatchInfo, @@ -95,8 +98,8 @@ import BasicTypes -- Imported and re-exported -import Var( Var, Id, DictId, - idInfo, idDetails, globaliseId, +import Var( Var, Id, DictId, EvVar, + idInfo, idDetails, globaliseId, varType, isId, isLocalId, isGlobalId, isExportedId ) import qualified Var @@ -335,11 +338,6 @@ DFunId {} -> True _ -> False -dfunNSilent :: Id -> Int -dfunNSilent id = case Var.idDetails id of - DFunId ns _ -> ns - _ -> pprTrace "dfunSilent: not a dfun:" (ppr id) 0 - isPrimOpId_maybe id = case Var.idDetails id of PrimOpId op -> Just op _ -> Nothing @@ -372,10 +370,6 @@ -- INVARIANT: @idDataCon (dataConWrapId d) = d@: remember, 'dataConWrapId' can return either the wrapper or the worker idDataCon id = isDataConId_maybe id `orElse` pprPanic "idDataCon" (ppr id) - -isDictId :: Id -> Bool -isDictId id = isDictTy (idType id) - hasNoBinding :: Id -> Bool -- ^ Returns @True@ of an 'Id' which may not have a -- binding, even though it is defined in this module. @@ -448,6 +442,26 @@ %************************************************************************ %* * + Evidence variables +%* * +%************************************************************************ + +\begin{code} +isEvVar :: Var -> Bool +isEvVar var = isPredTy (varType var) + +isDictId :: Id -> Bool +isDictId id = isDictTy (idType id) + +evVarPred :: EvVar -> PredType +evVarPred var + = case splitPredTy_maybe (varType var) of + Just pred -> pred + Nothing -> pprPanic "evVarPred" (ppr var <+> ppr (varType var)) +\end{code} + +%************************************************************************ +%* * \subsection{IdInfo stuff} %* * %************************************************************************ @@ -494,8 +508,8 @@ idUnfolding :: Id -> Unfolding -- Do not expose the unfolding of a loop breaker! idUnfolding id - | isNonRuleLoopBreaker (occInfo info) = NoUnfolding - | otherwise = unfoldingInfo info + | isStrongLoopBreaker (occInfo info) = NoUnfolding + | otherwise = unfoldingInfo info where info = idInfo id diff -Nru ghc-7.0.3/compiler/basicTypes/MkId.lhs ghc-7.2.1/compiler/basicTypes/MkId.lhs --- ghc-7.0.3/compiler/basicTypes/MkId.lhs 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/basicTypes/MkId.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -13,7 +13,7 @@ \begin{code} module MkId ( - mkDictFunId, mkDictFunTy, mkDefaultMethodId, mkDictSelId, + mkDictFunId, mkDictFunTy, mkDictSelId, mkDataConIds, mkPrimOpId, mkFCallId, mkTickBoxOpId, mkBreakPointOpId, @@ -25,13 +25,18 @@ -- And some particular Ids; see below for why they are wired in wiredInIds, ghcPrimIds, unsafeCoerceName, unsafeCoerceId, realWorldPrimId, - voidArgId, nullAddrId, seqId, lazyId, lazyIdKey + voidArgId, nullAddrId, seqId, lazyId, lazyIdKey, + coercionTokenId, + + -- Re-export error Ids + module PrelRules ) where #include "HsVersions.h" import Rules import TysPrim +import TysWiredIn ( unitTy ) import PrelRules import Type import Coercion @@ -48,7 +53,7 @@ import ForeignCall import DataCon import Id -import Var ( Var, TyVar, mkCoVar, mkExportedLocalVar ) +import Var ( mkExportedLocalVar ) import IdInfo import Demand import CoreSyn @@ -56,6 +61,7 @@ import PrelNames import BasicTypes hiding ( SuccessFlag(..) ) import Util +import Pair import Outputable import FastString import ListSetOps @@ -224,7 +230,7 @@ = DCIds Nothing wrk_id where (univ_tvs, ex_tvs, eq_spec, - eq_theta, dict_theta, orig_arg_tys, res_ty) = dataConFullSig data_con + other_theta, orig_arg_tys, res_ty) = dataConFullSig data_con tycon = dataConTyCon data_con -- The representation TyCon (not family) ----------- Worker (algebraic data types only) -------------- @@ -235,9 +241,9 @@ wkr_arity = dataConRepArity data_con wkr_info = noCafIdInfo - `setArityInfo` wkr_arity + `setArityInfo` wkr_arity `setStrictnessInfo` Just wkr_sig - `setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated, + `setUnfoldingInfo` evaldUnfolding -- Record that it's evaluated, -- even if arity = 0 wkr_sig = mkStrictSig (mkTopDmdType (replicate wkr_arity topDmd) cpr_info) @@ -270,6 +276,7 @@ nt_work_id = mkGlobalId (DataConWrapId data_con) wkr_name wrap_ty nt_work_info nt_work_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo `setArityInfo` 1 -- Arity 1 + `setInlinePragInfo` alwaysInlinePragma `setUnfoldingInfo` newtype_unf id_arg1 = mkTemplateLocal 1 (head orig_arg_tys) newtype_unf = ASSERT2( isVanillaDataCon data_con && @@ -286,12 +293,10 @@ -- extra constraints where necessary. wrap_tvs = (univ_tvs `minusList` map fst eq_spec) ++ ex_tvs res_ty_args = substTyVars (mkTopTvSubst eq_spec) univ_tvs - eq_tys = mkPredTys eq_theta - dict_tys = mkPredTys dict_theta - wrap_ty = mkForAllTys wrap_tvs $ mkFunTys eq_tys $ mkFunTys dict_tys $ - mkFunTys orig_arg_tys $ res_ty - -- NB: watch out here if you allow user-written equality - -- constraints in data constructor signatures + ev_tys = mkPredTys other_theta + wrap_ty = mkForAllTys wrap_tvs $ + mkFunTys ev_tys $ + mkFunTys orig_arg_tys $ res_ty ----------- Wrappers for algebraic data types -------------- alg_wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty alg_wrap_info @@ -304,8 +309,9 @@ `setStrictnessInfo` Just wrap_sig all_strict_marks = dataConExStricts data_con ++ dataConStrictMarks data_con - wrap_sig = mkStrictSig (mkTopDmdType arg_dmds cpr_info) - arg_dmds = map mk_dmd all_strict_marks + wrap_sig = mkStrictSig (mkTopDmdType wrap_arg_dmds cpr_info) + wrap_stricts = dropList eq_spec all_strict_marks + wrap_arg_dmds = map mk_dmd wrap_stricts mk_dmd str | isBanged str = evalDmd | otherwise = lazyDmd -- The Cpr info can be important inside INLINE rhss, where the @@ -317,32 +323,26 @@ -- ...(let w = C x in ...(w p q)...)... -- we want to see that w is strict in its two arguments - wrap_unf = mkInlineUnfolding (Just (length dict_args + length id_args)) wrap_rhs + wrap_unf = mkInlineUnfolding (Just (length ev_args + length id_args)) wrap_rhs wrap_rhs = mkLams wrap_tvs $ - mkLams eq_args $ - mkLams dict_args $ mkLams id_args $ + mkLams ev_args $ + mkLams id_args $ foldr mk_case con_app - (zip (dict_args ++ id_args) all_strict_marks) + (zip (ev_args ++ id_args) wrap_stricts) i3 [] + -- The ev_args is the evidence arguments *other than* the eq_spec + -- Because we are going to apply the eq_spec args manually in the + -- wrapper con_app _ rep_ids = wrapFamInstBody tycon res_ty_args $ Var wrk_id `mkTyApps` res_ty_args `mkVarApps` ex_tvs - -- Equality evidence: - `mkTyApps` map snd eq_spec - `mkVarApps` eq_args + `mkCoApps` map (mkReflCo . snd) eq_spec `mkVarApps` reverse rep_ids - (dict_args,i2) = mkLocals 1 dict_tys - (id_args,i3) = mkLocals i2 orig_arg_tys - wrap_arity = i3-1 - (eq_args,_) = mkCoVarLocals i3 eq_tys - - mkCoVarLocals i [] = ([],i) - mkCoVarLocals i (x:xs) = let (ys,j) = mkCoVarLocals (i+1) xs - y = mkCoVar (mkSysTvName (mkBuiltinUnique i) - (fsLit "dc_co")) x - in (y:ys,j) + (ev_args,i2) = mkLocals 1 ev_tys + (id_args,i3) = mkLocals i2 orig_arg_tys + wrap_arity = i3-1 mk_case :: (Id, HsBang) -- Arg, strictness @@ -433,19 +433,22 @@ base_info = noCafIdInfo `setArityInfo` 1 - `setStrictnessInfo` Just strict_sig + `setStrictnessInfo` Just strict_sig `setUnfoldingInfo` (if no_unf then noUnfolding - else mkImplicitUnfolding rhs) + else mkImplicitUnfolding rhs) -- In module where class op is defined, we must add -- the unfolding, even though it'll never be inlined -- becuase we use that to generate a top-level binding -- for the ClassOp - info = base_info `setSpecInfo` mkSpecInfo [rule] - `setInlinePragInfo` neverInlinePragma - -- Add a magic BuiltinRule, and never inline it - -- so that the rule is always available to fire. - -- See Note [ClassOp/DFun selection] in TcInstDcls + info | new_tycon = base_info `setInlinePragInfo` alwaysInlinePragma + -- See Note [Single-method classes] in TcInstDcls + -- for why alwaysInlinePragma + | otherwise = base_info `setSpecInfo` mkSpecInfo [rule] + `setInlinePragInfo` neverInlinePragma + -- Add a magic BuiltinRule, and never inline it + -- so that the rule is always available to fire. + -- See Note [ClassOp/DFun selection] in TcInstDcls n_ty_args = length tyvars @@ -455,7 +458,7 @@ occNameFS (getOccName name) , ru_fn = name , ru_nargs = n_ty_args + 1 - , ru_try = dictSelRule val_index n_ty_args n_eq_args } + , ru_try = dictSelRule val_index n_ty_args } -- The strictness signature is of the form U(AAAVAAAA) -> T -- where the V depends on which item we are selecting @@ -471,8 +474,6 @@ [data_con] = tyConDataCons tycon tyvars = dataConUnivTyVars data_con arg_tys = dataConRepArgTys data_con -- Includes the dictionary superclasses - eq_theta = dataConEqTheta data_con - n_eq_args = length eq_theta -- 'index' is a 0-index into the *value* arguments of the dictionary val_index = assoc "MkId.mkDictSelId" sel_index_prs name @@ -482,25 +483,25 @@ pred = mkClassPred clas (mkTyVarTys tyvars) dict_id = mkTemplateLocal 1 $ mkPredTy pred arg_ids = mkTemplateLocalsNum 2 arg_tys - eq_ids = map mkWildEvBinder eq_theta rhs = mkLams tyvars (Lam dict_id rhs_body) rhs_body | new_tycon = unwrapNewTypeBody tycon (map mkTyVarTy tyvars) (Var dict_id) | otherwise = Case (Var dict_id) dict_id (idType the_arg_id) - [(DataAlt data_con, eq_ids ++ arg_ids, Var the_arg_id)] + [(DataAlt data_con, arg_ids, varToCoreExpr the_arg_id)] + -- varToCoreExpr needed for equality superclass selectors + -- sel a b d = case x of { MkC _ (g:a~b) _ -> CO g } -dictSelRule :: Int -> Arity -> Arity +dictSelRule :: Int -> Arity -> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr -- Tries to persuade the argument to look like a constructor -- application, using exprIsConApp_maybe, and then selects -- from it -- sel_i t1..tk (D t1..tk op1 ... opm) = opi -- -dictSelRule val_index n_ty_args n_eq_args id_unf args +dictSelRule val_index n_ty_args id_unf args | (dict_arg : _) <- drop n_ty_args args , Just (_, _, con_args) <- exprIsConApp_maybe id_unf dict_arg - , let val_args = drop n_eq_args con_args - = Just (val_args !! val_index) + = Just (con_args !! val_index) | otherwise = Nothing \end{code} @@ -583,7 +584,7 @@ result_expr | isNewTyCon tycon && not (isRecursiveTyCon tycon) = wrap (mkProductBox arg_ids (newTyConInstRhs tycon tycon_args)) - | otherwise = mkConApp pack_con (map Type tycon_args ++ map Var arg_ids) + | otherwise = mkConApp pack_con (map Type tycon_args ++ varsToCoreExprs arg_ids) wrap expr = wrapNewTypeBody tycon tycon_args expr @@ -604,7 +605,7 @@ mkReboxingAlt :: [Unique] -- Uniques for the new Ids -> DataCon - -> [Var] -- Source-level args, including existential dicts + -> [Var] -- Source-level args, *including* all evidence vars -> CoreExpr -- RHS -> CoreAlt @@ -625,15 +626,14 @@ -- Type variable case go (arg:args) stricts us - | isTyCoVar arg + | isTyVar arg = let (binds, args') = go args stricts us in (binds, arg:args') -- Term variable case go (arg:args) (str:stricts) us | isMarkedUnboxed str - = - let (binds, unpacked_args') = go args stricts us' + = let (binds, unpacked_args') = go args stricts us' (us', bind_rhs, unpacked_args) = reboxProduct us (idType arg) in (NonRec arg bind_rhs : binds, unpacked_args ++ unpacked_args') @@ -671,13 +671,11 @@ -- coercion constructor of the newtype or applied by itself). wrapNewTypeBody tycon args result_expr - = wrapFamInstBody tycon args inner + = ASSERT( isNewTyCon tycon ) + wrapFamInstBody tycon args $ + mkCoerce (mkSymCo co) result_expr where - inner - | Just co_con <- newTyConCo_maybe tycon - = mkCoerce (mkSymCoercion (mkTyConApp co_con args)) result_expr - | otherwise - = result_expr + co = mkAxInstCo (newTyConCo tycon) args -- When unwrapping, we do *not* apply any family coercion, because this will -- be done via a CoPat by the type checker. We have to do it this way as @@ -686,10 +684,8 @@ unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr unwrapNewTypeBody tycon args result_expr - | Just co_con <- newTyConCo_maybe tycon - = mkCoerce (mkTyConApp co_con args) result_expr - | otherwise - = result_expr + = ASSERT( isNewTyCon tycon ) + mkCoerce (mkAxInstCo (newTyConCo tycon) args) result_expr -- If the type constructor is a representation type of a data instance, wrap -- the expression into a cast adjusting the expression type, which is an @@ -699,14 +695,14 @@ wrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr wrapFamInstBody tycon args body | Just co_con <- tyConFamilyCoercion_maybe tycon - = mkCoerce (mkSymCoercion (mkTyConApp co_con args)) body + = mkCoerce (mkSymCo (mkAxInstCo co_con args)) body | otherwise = body unwrapFamInstScrut :: TyCon -> [Type] -> CoreExpr -> CoreExpr unwrapFamInstScrut tycon args scrut | Just co_con <- tyConFamilyCoercion_maybe tycon - = mkCoerce (mkTyConApp co_con args) scrut + = mkCoerce (mkAxInstCo co_con args) scrut | otherwise = scrut \end{code} @@ -823,11 +819,6 @@ that they aren't discarded by the occurrence analyser. \begin{code} -mkDefaultMethodId :: Id -- Selector Id - -> Name -- Default method name - -> Id -- Default method Id -mkDefaultMethodId sel_id dm_name = mkExportedLocalId dm_name (idType sel_id) - mkDictFunId :: Name -- Name to use for the dict fun; -> [TyVar] -> ThetaType @@ -837,26 +828,17 @@ -- Implements the DFun Superclass Invariant (see TcInstDcls) mkDictFunId dfun_name tvs theta clas tys - = mkExportedLocalVar (DFunId n_silent is_nt) + = mkExportedLocalVar (DFunId is_nt) dfun_name dfun_ty vanillaIdInfo where is_nt = isNewTyCon (classTyCon clas) - (n_silent, dfun_ty) = mkDictFunTy tvs theta clas tys + dfun_ty = mkDictFunTy tvs theta clas tys -mkDictFunTy :: [TyVar] -> ThetaType -> Class -> [Type] -> (Int, Type) +mkDictFunTy :: [TyVar] -> ThetaType -> Class -> [Type] -> Type mkDictFunTy tvs theta clas tys - = (length silent_theta, dfun_ty) - where - dfun_ty = mkSigmaTy tvs (silent_theta ++ theta) (mkDictTy clas tys) - silent_theta = filterOut discard $ - substTheta (zipTopTvSubst (classTyVars clas) tys) - (classSCTheta clas) - -- See Note [Silent Superclass Arguments] - discard pred = isEmptyVarSet (tyVarsOfPred pred) - || any (`tcEqPred` pred) theta - -- See the DFun Superclass Invariant in TcInstDcls + = mkSigmaTy tvs theta (mkDictTy clas tys) \end{code} @@ -882,12 +864,13 @@ another gun with which to shoot yourself in the foot. \begin{code} -lazyIdName, unsafeCoerceName, nullAddrName, seqName, realWorldName :: Name -unsafeCoerceName = mkWiredInIdName gHC_PRIM (fsLit "unsafeCoerce#") unsafeCoerceIdKey unsafeCoerceId -nullAddrName = mkWiredInIdName gHC_PRIM (fsLit "nullAddr#") nullAddrIdKey nullAddrId -seqName = mkWiredInIdName gHC_PRIM (fsLit "seq") seqIdKey seqId -realWorldName = mkWiredInIdName gHC_PRIM (fsLit "realWorld#") realWorldPrimIdKey realWorldPrimId -lazyIdName = mkWiredInIdName gHC_BASE (fsLit "lazy") lazyIdKey lazyId +lazyIdName, unsafeCoerceName, nullAddrName, seqName, realWorldName, coercionTokenName :: Name +unsafeCoerceName = mkWiredInIdName gHC_PRIM (fsLit "unsafeCoerce#") unsafeCoerceIdKey unsafeCoerceId +nullAddrName = mkWiredInIdName gHC_PRIM (fsLit "nullAddr#") nullAddrIdKey nullAddrId +seqName = mkWiredInIdName gHC_PRIM (fsLit "seq") seqIdKey seqId +realWorldName = mkWiredInIdName gHC_PRIM (fsLit "realWorld#") realWorldPrimIdKey realWorldPrimId +lazyIdName = mkWiredInIdName gHC_BASE (fsLit "lazy") lazyIdKey lazyId +coercionTokenName = mkWiredInIdName gHC_PRIM (fsLit "coercionToken#") coercionTokenIdKey coercionTokenId \end{code} \begin{code} @@ -897,14 +880,15 @@ unsafeCoerceId = pcMiscPrelId unsafeCoerceName ty info where - info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs + info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma + `setUnfoldingInfo` mkCompulsoryUnfolding rhs ty = mkForAllTys [argAlphaTyVar,openBetaTyVar] (mkFunTy argAlphaTy openBetaTy) [x] = mkTemplateLocals [argAlphaTy] rhs = mkLams [argAlphaTyVar,openBetaTyVar,x] $ - Cast (Var x) (mkUnsafeCoercion argAlphaTy openBetaTy) + Cast (Var x) (mkUnsafeCo argAlphaTy openBetaTy) ------------------------------------------------ nullAddrId :: Id @@ -913,15 +897,16 @@ -- a way to write this literal in Haskell. nullAddrId = pcMiscPrelId nullAddrName addrPrimTy info where - info = noCafIdInfo `setUnfoldingInfo` - mkCompulsoryUnfolding (Lit nullAddrLit) + info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma + `setUnfoldingInfo` mkCompulsoryUnfolding (Lit nullAddrLit) ------------------------------------------------ seqId :: Id -- See Note [seqId magic] seqId = pcMiscPrelId seqName ty info where - info = noCafIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs - `setSpecInfo` mkSpecInfo [seq_cast_rule] + info = noCafIdInfo `setInlinePragInfo` alwaysInlinePragma + `setUnfoldingInfo` mkCompulsoryUnfolding rhs + `setSpecInfo` mkSpecInfo [seq_cast_rule] ty = mkForAllTys [alphaTyVar,argBetaTyVar] @@ -939,7 +924,7 @@ match_seq_of_cast :: IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr -- See Note [Built-in RULES for seq] match_seq_of_cast _ [Type _, Type res_ty, Cast scrut co, expr] - = Just (Var seqId `mkApps` [Type (fst (coercionKind co)), Type res_ty, + = Just (Var seqId `mkApps` [Type (pFst (coercionKind co)), Type res_ty, scrut, expr]) match_seq_of_cast _ _ = Nothing @@ -1049,6 +1034,12 @@ voidArgId :: Id voidArgId -- :: State# RealWorld = mkSysLocal (fsLit "void") voidArgIdKey realWorldStatePrimTy + +coercionTokenId :: Id -- :: () ~ () +coercionTokenId -- Used to replace Coercion terms when we go to STG + = pcMiscPrelId coercionTokenName + (mkTyConApp eqPredPrimTyCon [unitTy, unitTy]) + noCafIdInfo \end{code} diff -Nru ghc-7.0.3/compiler/basicTypes/Module.lhs ghc-7.2.1/compiler/basicTypes/Module.lhs --- ghc-7.0.3/compiler/basicTypes/Module.lhs 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/basicTypes/Module.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -39,7 +39,8 @@ dphSeqPackageId, dphParPackageId, mainPackageId, - + thisGhcPackageId, + -- * The Module type Module, modulePackageId, moduleName, @@ -73,7 +74,6 @@ import Config import Outputable -import qualified Pretty import Unique import UniqFM import FastString @@ -155,6 +155,7 @@ \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 @@ 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 @@ 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 @@ 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" @@ -256,9 +253,10 @@ mkModule = Module pprModule :: Module -> SDoc -pprModule mod@(Module p n) = pprPackagePrefix p mod <> pprModuleName n +pprModule mod@(Module p n) = + pprPackagePrefix p mod <> pprModuleName n -pprPackagePrefix :: PackageId -> Module -> PprStyle -> Pretty.Doc +pprPackagePrefix :: PackageId -> Module -> SDoc pprPackagePrefix p mod = getPprStyle doc where doc sty @@ -280,7 +278,7 @@ \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 +289,6 @@ 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" @@ -347,14 +343,15 @@ integerPackageId, primPackageId, basePackageId, rtsPackageId, thPackageId, dphSeqPackageId, dphParPackageId, - mainPackageId :: PackageId + mainPackageId, thisGhcPackageId :: PackageId primPackageId = fsToPackageId (fsLit "ghc-prim") integerPackageId = fsToPackageId (fsLit cIntegerLibrary) basePackageId = fsToPackageId (fsLit "base") -rtsPackageId = fsToPackageId (fsLit "rts") +rtsPackageId = fsToPackageId (fsLit "rts") thPackageId = fsToPackageId (fsLit "template-haskell") dphSeqPackageId = fsToPackageId (fsLit "dph-seq") dphParPackageId = fsToPackageId (fsLit "dph-par") +thisGhcPackageId = fsToPackageId (fsLit ("ghc-" ++ cProjectVersion)) -- | This is the package Id for the current program. It is the default -- package Id if you don't specify a package name. We don't add this prefix diff -Nru ghc-7.0.3/compiler/basicTypes/Name.lhs ghc-7.2.1/compiler/basicTypes/Name.lhs --- ghc-7.0.3/compiler/basicTypes/Name.lhs 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/basicTypes/Name.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -57,7 +57,7 @@ isValName, isVarName, isWiredInName, isBuiltInSyntax, wiredInNameTyThing_maybe, - nameIsLocalOrFrom, + nameIsLocalOrFrom, stableNameCmp, -- * Class 'NamedThing' and overloaded friends NamedThing(..), @@ -106,6 +106,7 @@ --(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 @@ -243,7 +244,10 @@ -- | Create a name which is (for now at least) local to the current module and hence -- does not need a 'Module' to disambiguate it from other 'Name's mkInternalName :: Unique -> OccName -> SrcSpan -> Name -mkInternalName uniq occ loc = Name { n_uniq = getKeyFastInt uniq, n_sort = Internal, n_occ = occ, n_loc = loc } +mkInternalName uniq occ loc = Name { n_uniq = getKeyFastInt uniq + , n_sort = Internal + , n_occ = occ + , n_loc = loc } -- NB: You might worry that after lots of huffing and -- puffing we might end up with two local names with distinct -- uniques, but the same OccName. Indeed we can, but that's ok @@ -337,6 +341,26 @@ cmpName :: Name -> Name -> Ordering cmpName n1 n2 = iBox (n_uniq n1) `compare` iBox (n_uniq n2) + +stableNameCmp :: Name -> Name -> Ordering +-- Compare lexicographically +stableNameCmp (Name { n_sort = s1, n_occ = occ1 }) + (Name { n_sort = s2, n_occ = occ2 }) + = (s1 `sort_cmp` s2) `thenCmp` (occ1 `compare` occ2) + -- The ordinary compare on OccNames is lexicogrpahic + where + -- Later constructors are bigger + sort_cmp (External m1) (External m2) = m1 `stableModuleCmp` m2 + sort_cmp (External {}) _ = LT + sort_cmp (WiredIn {}) (External {}) = GT + sort_cmp (WiredIn m1 _ _) (WiredIn m2 _ _) = m1 `stableModuleCmp` m2 + sort_cmp (WiredIn {}) _ = LT + sort_cmp Internal (External {}) = GT + sort_cmp Internal (WiredIn {}) = GT + sort_cmp Internal Internal = EQ + sort_cmp Internal System = LT + sort_cmp System System = EQ + sort_cmp System _ = GT \end{code} %************************************************************************ @@ -363,8 +387,6 @@ instance NamedThing Name where getName n = n -INSTANCE_TYPEABLE0(Name,nameTc,"Name") - instance Data Name where -- don't traverse? toConstr _ = abstractConstr "Name" @@ -481,12 +503,14 @@ -- Prints (if mod information is available) "Defined at " or -- "Defined in " information for a Name. pprNameLoc :: Name -> SDoc -pprNameLoc name - | isGoodSrcSpan loc = pprDefnLoc loc - | isInternalName name || isSystemName name - = ptext (sLit "") - | otherwise = ptext (sLit "Defined in ") <> ppr (nameModule name) - where loc = nameSrcSpan name +pprNameLoc name = case nameSrcSpan name of + RealSrcSpan s -> + pprDefnLoc s + UnhelpfulSpan _ + | isInternalName name || isSystemName name -> + ptext (sLit "") + | otherwise -> + ptext (sLit "Defined in ") <> ppr (nameModule name) \end{code} %************************************************************************ diff -Nru ghc-7.0.3/compiler/basicTypes/NameSet.lhs ghc-7.2.1/compiler/basicTypes/NameSet.lhs --- ghc-7.0.3/compiler/basicTypes/NameSet.lhs 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/basicTypes/NameSet.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -34,9 +34,6 @@ import Name import UniqSet -import Util - -import Data.Data \end{code} %************************************************************************ @@ -48,15 +45,7 @@ \begin{code} type NameSet = UniqSet Name -INSTANCE_TYPEABLE0(NameSet,nameSetTc,"NameSet") - -instance Data NameSet where - gfoldl k z s = z mkNameSet `k` nameSetToList s -- traverse abstractly - toConstr _ = abstractConstr "NameSet" - gunfold _ _ = error "gunfold" - dataTypeOf _ = mkNoRepType "NameSet" - -emptyNameSet :: NameSet +emptyNameSet :: NameSet unitNameSet :: Name -> NameSet addListToNameSet :: NameSet -> [Name] -> NameSet addOneToNameSet :: NameSet -> Name -> NameSet @@ -176,7 +165,7 @@ 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 +173,7 @@ 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 -Nru ghc-7.0.3/compiler/basicTypes/OccName.lhs ghc-7.2.1/compiler/basicTypes/OccName.lhs --- ghc-7.0.3/compiler/basicTypes/OccName.lhs 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/basicTypes/OccName.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -48,11 +48,12 @@ -- ** Derived 'OccName's isDerivedOccName, - mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, + mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkGenDefMethodOcc, mkDerivedTyConOcc, mkNewTyCoOcc, mkClassOpAuxOcc, mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc, mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2, + mkGenD, mkGenR, mkGenRCo, mkGenC, mkGenS, mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkSuperDictSelOcc, mkLocalOcc, mkMethodOcc, mkInstTyTcOcc, mkInstTyCoOcc, mkEqPredCoOcc, @@ -107,16 +108,6 @@ import Data.Data \end{code} -\begin{code} --- Unicode TODO: put isSymbol in libcompat -#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ > 604 -#else -isSymbol :: a -> Bool -isSymbol = const False -#endif - -\end{code} - %************************************************************************ %* * \subsection{Name space} @@ -219,6 +210,7 @@ { occNameSpace :: !NameSpace , occNameFS :: !FastString } + deriving Typeable \end{code} @@ -231,8 +223,6 @@ 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" @@ -550,9 +540,10 @@ \end{code} \begin{code} -mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkDerivedTyConOcc, - mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc, - mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2, +mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkGenDefMethodOcc, + mkDerivedTyConOcc, mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, + mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2, + mkGenD, mkGenR, mkGenRCo, mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkNewTyCoOcc, mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc, mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc, @@ -564,6 +555,7 @@ mkDataConWrapperOcc = mk_simple_deriv varName "$W" mkWorkerOcc = mk_simple_deriv varName "$w" mkDefaultMethodOcc = mk_simple_deriv varName "$dm" +mkGenDefMethodOcc = mk_simple_deriv varName "$gdm" mkClassOpAuxOcc = mk_simple_deriv varName "$c" mkDerivedTyConOcc = mk_simple_deriv tcName ":" -- The : prefix makes sure it classifies mkClassTyConOcc = mk_simple_deriv tcName "T:" -- as a tycon/datacon @@ -582,10 +574,23 @@ mkTag2ConOcc = mk_simple_deriv varName "$tag2con_" mkMaxTagOcc = mk_simple_deriv varName "$maxtag_" --- Generic derivable classes +-- Generic derivable classes (old) mkGenOcc1 = mk_simple_deriv varName "$gfrom" mkGenOcc2 = mk_simple_deriv varName "$gto" +-- Generic deriving mechanism (new) +mkGenD = mk_simple_deriv tcName "D1" + +mkGenC :: OccName -> Int -> OccName +mkGenC occ m = mk_deriv tcName ("C1_" ++ show m) (occNameString occ) + +mkGenS :: OccName -> Int -> Int -> OccName +mkGenS occ m n = mk_deriv tcName ("S1_" ++ show m ++ "_" ++ show n) + (occNameString occ) + +mkGenR = mk_simple_deriv tcName "Rep_" +mkGenRCo = mk_simple_deriv tcName "CoRep_" + -- data T = MkT ... deriving( Data ) needs defintions for -- $tT :: Data.Generics.Basics.DataType -- $cMkT :: Data.Generics.Basics.Constr diff -Nru ghc-7.0.3/compiler/basicTypes/RdrName.lhs ghc-7.2.1/compiler/basicTypes/RdrName.lhs --- ghc-7.0.3/compiler/basicTypes/RdrName.lhs 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/basicTypes/RdrName.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -320,7 +320,6 @@ = extendOccEnvList env [(nameOccName n, n) | n <- names] lookupLocalRdrEnv :: LocalRdrEnv -> RdrName -> Maybe Name -lookupLocalRdrEnv _ (Exact name) = Just name lookupLocalRdrEnv env (Unqual occ) = lookupOccEnv env occ lookupLocalRdrEnv _ _ = Nothing @@ -384,18 +383,6 @@ plusParent p1 p2 = ASSERT2( p1 == p2, parens (ppr p1) <+> parens (ppr p2) ) p1 -{- Why so complicated? -=chak -plusParent :: Parent -> Parent -> Parent -plusParent NoParent rel = - ASSERT2( case rel of { NoParent -> True; other -> False }, - ptext (sLit "plusParent[NoParent]: ") <+> ppr rel ) - NoParent -plusParent (ParentIs n) rel = - ASSERT2( case rel of { ParentIs m -> n==m; other -> False }, - ptext (sLit "plusParent[ParentIs]:") <+> ppr n <> comma <+> ppr rel ) - ParentIs n - -} - emptyGlobalRdrEnv :: GlobalRdrEnv emptyGlobalRdrEnv = emptyOccEnv @@ -403,7 +390,8 @@ globalRdrEnvElts env = foldOccEnv (++) [] env instance Outputable GlobalRdrElt where - ppr gre = ppr name <+> parens (ppr (gre_par gre) <+> pprNameProvenance gre) + ppr gre = hang (ppr name) + 2 (parens (ppr (gre_par gre) <+> pprNameProvenance gre)) where name = gre_name gre @@ -439,10 +427,13 @@ gre_name gre == name ] getGRE_NameQualifier_maybes :: GlobalRdrEnv -> Name -> [Maybe [ModuleName]] +-- Returns all the qualifiers by which 'x' is in scope +-- Nothing means "the unqualified version is in scope" getGRE_NameQualifier_maybes env = map qualifier_maybe . map gre_prov . lookupGRE_Name env - where qualifier_maybe LocalDef = Nothing - qualifier_maybe (Imported iss) = Just $ map (is_as . is_decl) iss + where + qualifier_maybe LocalDef = Nothing + qualifier_maybe (Imported iss) = Just $ map (is_as . is_decl) iss pickGREs :: RdrName -> [GlobalRdrElt] -> [GlobalRdrElt] -- ^ Take a list of GREs which have the right OccName @@ -579,7 +570,7 @@ -- INVARIANT: the list of 'ImportSpec' is non-empty data ImportSpec = ImpSpec { is_decl :: ImpDeclSpec, - is_item :: ImpItemSpec } + is_item :: ImpItemSpec } deriving( Eq, Ord ) -- | Describes a particular import declaration and is @@ -686,14 +677,16 @@ -- If we know the exact definition point (which we may do with GHCi) -- then show that too. But not if it's just "imported from X". ppr_defn :: SrcLoc -> SDoc -ppr_defn loc | isGoodSrcLoc loc = parens (ptext (sLit "defined at") <+> ppr loc) - | otherwise = empty +ppr_defn (RealSrcLoc loc) = parens (ptext (sLit "defined at") <+> ppr loc) +ppr_defn (UnhelpfulLoc _) = empty instance Outputable ImportSpec where ppr imp_spec = ptext (sLit "imported from") <+> ppr (importSpecModule imp_spec) - <+> if isGoodSrcSpan loc then ptext (sLit "at") <+> ppr loc - else empty + <+> pprLoc where loc = importSpecLoc imp_spec + pprLoc = case loc of + RealSrcSpan s -> ptext (sLit "at") <+> ppr s + UnhelpfulSpan _ -> empty \end{code} diff -Nru ghc-7.0.3/compiler/basicTypes/SrcLoc.lhs ghc-7.2.1/compiler/basicTypes/SrcLoc.lhs --- ghc-7.0.3/compiler/basicTypes/SrcLoc.lhs 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/basicTypes/SrcLoc.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -3,14 +3,21 @@ % \begin{code} +{-# OPTIONS_GHC -fno-omit-interface-pragmas #-} + -- Workaround for Trac #5252 crashes the bootstrap compiler without -O + -- When the earliest compiler we want to boostrap with is + -- GHC 7.2, we can make RealSrcLoc properly abstract + + -- | This module contains types that relate to the positions of things -- in source files, and allow tagging of those things with locations module SrcLoc ( -- * SrcLoc - SrcLoc, -- Abstract + RealSrcLoc, -- Abstract + SrcLoc(..), -- ** Constructing SrcLoc - mkSrcLoc, mkGeneralSrcLoc, + mkSrcLoc, mkRealSrcLoc, mkGeneralSrcLoc, noSrcLoc, -- "I'm sorry, I haven't a clue" generatedSrcLoc, -- Code generated within the compiler @@ -26,22 +33,21 @@ -- ** Misc. operations on SrcLoc pprDefnLoc, - - -- ** Predicates on SrcLoc - isGoodSrcLoc, -- * SrcSpan - SrcSpan, -- Abstract + RealSrcSpan, -- Abstract + SrcSpan(..), -- ** Constructing SrcSpan - mkGeneralSrcSpan, mkSrcSpan, + mkGeneralSrcSpan, mkSrcSpan, mkRealSrcSpan, noSrcSpan, wiredInSrcSpan, -- Something wired into the compiler - srcLocSpan, + srcLocSpan, realSrcLocSpan, combineSrcSpans, -- ** Deconstructing SrcSpan srcSpanStart, srcSpanEnd, + realSrcSpanStart, realSrcSpanEnd, srcSpanFileName_maybe, -- ** Unsafely deconstructing SrcSpan @@ -54,7 +60,9 @@ isGoodSrcSpan, isOneLineSpan, -- * Located - Located(..), + Located, + RealLocated, + GenLocated(..), -- ** Constructing Located noLoc, @@ -89,10 +97,13 @@ this is the obvious stuff: \begin{code} -- | Represents a single point within a file -data SrcLoc +data RealSrcLoc = SrcLoc FastString -- A precise location (file name) {-# UNPACK #-} !Int -- line number, begins at 1 {-# UNPACK #-} !Int -- column number, begins at 1 + +data SrcLoc + = RealSrcLoc {-# UNPACK #-}!RealSrcLoc | UnhelpfulLoc FastString -- Just a general indication \end{code} @@ -104,7 +115,10 @@ \begin{code} mkSrcLoc :: FastString -> Int -> Int -> SrcLoc -mkSrcLoc x line col = SrcLoc x line col +mkSrcLoc x line col = RealSrcLoc (mkRealSrcLoc x line col) + +mkRealSrcLoc :: FastString -> Int -> Int -> RealSrcLoc +mkRealSrcLoc x line col = SrcLoc x line col -- | Built-in "bad" 'SrcLoc' values for particular locations noSrcLoc, generatedSrcLoc, interactiveSrcLoc :: SrcLoc @@ -116,35 +130,26 @@ mkGeneralSrcLoc :: FastString -> SrcLoc mkGeneralSrcLoc = UnhelpfulLoc --- | "Good" 'SrcLoc's have precise information about their location -isGoodSrcLoc :: SrcLoc -> Bool -isGoodSrcLoc (SrcLoc _ _ _) = True -isGoodSrcLoc _other = False - --- | Gives the filename of the 'SrcLoc' if it is available, otherwise returns a dummy value -srcLocFile :: SrcLoc -> FastString +-- | Gives the filename of the 'RealSrcLoc' +srcLocFile :: RealSrcLoc -> FastString srcLocFile (SrcLoc fname _ _) = fname -srcLocFile _other = (fsLit " Int +srcLocLine :: RealSrcLoc -> Int srcLocLine (SrcLoc _ l _) = l -srcLocLine (UnhelpfulLoc s) = pprPanic "srcLocLine" (ftext s) -- | Raises an error when used on a "bad" 'SrcLoc' -srcLocCol :: SrcLoc -> Int +srcLocCol :: RealSrcLoc -> Int srcLocCol (SrcLoc _ _ c) = c -srcLocCol (UnhelpfulLoc s) = pprPanic "srcLocCol" (ftext s) -- | Move the 'SrcLoc' down by one line if the character is a newline, -- to the next 8-char tabstop if it is a tab, and across by one -- character in any other case -advanceSrcLoc :: SrcLoc -> Char -> SrcLoc +advanceSrcLoc :: RealSrcLoc -> Char -> RealSrcLoc advanceSrcLoc (SrcLoc f l _) '\n' = SrcLoc f (l + 1) 1 advanceSrcLoc (SrcLoc f l c) '\t' = SrcLoc f l (((((c - 1) `shiftR` 3) + 1) `shiftL` 3) + 1) advanceSrcLoc (SrcLoc f l c) _ = SrcLoc f l (c + 1) -advanceSrcLoc loc _ = loc -- Better than nothing \end{code} %************************************************************************ @@ -157,21 +162,31 @@ -- SrcLoc is an instance of Ord so that we can sort error messages easily instance Eq SrcLoc where loc1 == loc2 = case loc1 `cmpSrcLoc` loc2 of - EQ -> True - _other -> False + EQ -> True + _other -> False + +instance Eq RealSrcLoc where + loc1 == loc2 = case loc1 `cmpRealSrcLoc` loc2 of + EQ -> True + _other -> False instance Ord SrcLoc where compare = cmpSrcLoc - + +instance Ord RealSrcLoc where + compare = cmpRealSrcLoc + cmpSrcLoc :: SrcLoc -> SrcLoc -> Ordering cmpSrcLoc (UnhelpfulLoc s1) (UnhelpfulLoc s2) = s1 `compare` s2 -cmpSrcLoc (UnhelpfulLoc _) _other = LT +cmpSrcLoc (UnhelpfulLoc _) (RealSrcLoc _) = GT +cmpSrcLoc (RealSrcLoc _) (UnhelpfulLoc _) = LT +cmpSrcLoc (RealSrcLoc l1) (RealSrcLoc l2) = (l1 `compare` l2) -cmpSrcLoc (SrcLoc s1 l1 c1) (SrcLoc s2 l2 c2) +cmpRealSrcLoc :: RealSrcLoc -> RealSrcLoc -> Ordering +cmpRealSrcLoc (SrcLoc s1 l1 c1) (SrcLoc s2 l2 c2) = (s1 `compare` s2) `thenCmp` (l1 `compare` l2) `thenCmp` (c1 `compare` c2) -cmpSrcLoc (SrcLoc _ _ _) _other = GT -instance Outputable SrcLoc where +instance Outputable RealSrcLoc where ppr (SrcLoc src_path src_line src_col) = getPprStyle $ \ sty -> if userStyle sty || debugStyle sty then @@ -183,9 +198,15 @@ hcat [text "{-# LINE ", int src_line, space, char '\"', pprFastFilePath src_path, text " #-}"] +instance Outputable SrcLoc where + ppr (RealSrcLoc l) = ppr l ppr (UnhelpfulLoc s) = ftext s -INSTANCE_TYPEABLE0(SrcSpan,srcSpanTc,"SrcSpan") +instance Data RealSrcSpan where + -- don't traverse? + toConstr _ = abstractConstr "RealSrcSpan" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "RealSrcSpan" instance Data SrcSpan where -- don't traverse? @@ -211,7 +232,7 @@ span. That is, a span of (1,1)-(1,2) is one character long, and a span of (1,1)-(1,1) is zero characters long. -} -data SrcSpan +data RealSrcSpan = SrcSpanOneLine -- a common case: a single line { srcSpanFile :: !FastString, srcSpanLine :: {-# UNPACK #-} !Int, @@ -232,15 +253,23 @@ srcSpanLine :: {-# UNPACK #-} !Int, srcSpanCol :: {-# UNPACK #-} !Int } +#ifdef DEBUG + deriving (Eq, Typeable, Show) -- Show is used by Lexer.x, becuase we + -- derive Show for Token +#else + deriving (Eq, Typeable) +#endif +data SrcSpan = + RealSrcSpan !RealSrcSpan | UnhelpfulSpan !FastString -- Just a general indication -- 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 @@ -255,13 +284,14 @@ -- | Create a 'SrcSpan' corresponding to a single point srcLocSpan :: SrcLoc -> SrcSpan srcLocSpan (UnhelpfulLoc str) = UnhelpfulSpan str -srcLocSpan (SrcLoc file line col) = SrcSpanPoint file line col +srcLocSpan (RealSrcLoc l) = RealSrcSpan (realSrcLocSpan l) + +realSrcLocSpan :: RealSrcLoc -> RealSrcSpan +realSrcLocSpan (SrcLoc file line col) = SrcSpanPoint file line col -- | Create a 'SrcSpan' between two points in a file -mkSrcSpan :: SrcLoc -> SrcLoc -> SrcSpan -mkSrcSpan (UnhelpfulLoc str) _ = UnhelpfulSpan str -mkSrcSpan _ (UnhelpfulLoc str) = UnhelpfulSpan str -mkSrcSpan loc1 loc2 +mkRealSrcSpan :: RealSrcLoc -> RealSrcLoc -> RealSrcSpan +mkRealSrcSpan loc1 loc2 | line1 == line2 = if col1 == col2 then SrcSpanPoint file line1 col1 else SrcSpanOneLine file line1 col1 col2 @@ -273,25 +303,36 @@ col2 = srcLocCol loc2 file = srcLocFile loc1 +-- | Create a 'SrcSpan' between two points in a file +mkSrcSpan :: SrcLoc -> SrcLoc -> SrcSpan +mkSrcSpan (UnhelpfulLoc str) _ = UnhelpfulSpan str +mkSrcSpan _ (UnhelpfulLoc str) = UnhelpfulSpan str +mkSrcSpan (RealSrcLoc loc1) (RealSrcLoc loc2) + = RealSrcSpan (mkRealSrcSpan loc1 loc2) + -- | Combines two 'SrcSpan' into one that spans at least all the characters -- within both spans. Assumes the "file" part is the same in both inputs combineSrcSpans :: SrcSpan -> SrcSpan -> SrcSpan combineSrcSpans (UnhelpfulSpan _) r = r -- this seems more useful combineSrcSpans l (UnhelpfulSpan _) = l -combineSrcSpans start end - = case line1 `compare` line2 of - EQ -> case col1 `compare` col2 of - EQ -> SrcSpanPoint file line1 col1 - LT -> SrcSpanOneLine file line1 col1 col2 - GT -> SrcSpanOneLine file line1 col2 col1 - LT -> SrcSpanMultiLine file line1 col1 line2 col2 - GT -> SrcSpanMultiLine file line2 col2 line1 col1 +combineSrcSpans (RealSrcSpan span1) (RealSrcSpan span2) + = RealSrcSpan (combineRealSrcSpans span1 span2) + +-- | Combines two 'SrcSpan' into one that spans at least all the characters +-- within both spans. Assumes the "file" part is the same in both inputs +combineRealSrcSpans :: RealSrcSpan -> RealSrcSpan -> RealSrcSpan +combineRealSrcSpans span1 span2 + = if line_start == line_end + then if col_start == col_end + then SrcSpanPoint file line_start col_start + else SrcSpanOneLine file line_start col_start col_end + else SrcSpanMultiLine file line_start col_start line_end col_end where - line1 = srcSpanStartLine start - col1 = srcSpanStartCol start - line2 = srcSpanEndLine end - col2 = srcSpanEndCol end - file = srcSpanFile start + (line_start, col_start) = min (srcSpanStartLine span1, srcSpanStartCol span1) + (srcSpanStartLine span2, srcSpanStartCol span2) + (line_end, col_end) = max (srcSpanEndLine span1, srcSpanEndCol span1) + (srcSpanEndLine span2, srcSpanEndCol span2) + file = srcSpanFile span1 \end{code} %************************************************************************ @@ -303,17 +344,14 @@ \begin{code} -- | Test if a 'SrcSpan' is "good", i.e. has precise location information isGoodSrcSpan :: SrcSpan -> Bool -isGoodSrcSpan SrcSpanOneLine{} = True -isGoodSrcSpan SrcSpanMultiLine{} = True -isGoodSrcSpan SrcSpanPoint{} = True -isGoodSrcSpan _ = False +isGoodSrcSpan (RealSrcSpan _) = True +isGoodSrcSpan (UnhelpfulSpan _) = False isOneLineSpan :: SrcSpan -> Bool -- ^ True if the span is known to straddle only one line. -- For "bad" 'SrcSpan', it returns False -isOneLineSpan s - | isGoodSrcSpan s = srcSpanStartLine s == srcSpanEndLine s - | otherwise = False +isOneLineSpan (RealSrcSpan s) = srcSpanStartLine s == srcSpanEndLine s +isOneLineSpan (UnhelpfulSpan _) = False \end{code} @@ -325,34 +363,26 @@ \begin{code} --- | Raises an error when used on a "bad" 'SrcSpan' -srcSpanStartLine :: SrcSpan -> Int --- | Raises an error when used on a "bad" 'SrcSpan' -srcSpanEndLine :: SrcSpan -> Int --- | Raises an error when used on a "bad" 'SrcSpan' -srcSpanStartCol :: SrcSpan -> Int --- | Raises an error when used on a "bad" 'SrcSpan' -srcSpanEndCol :: SrcSpan -> Int +srcSpanStartLine :: RealSrcSpan -> Int +srcSpanEndLine :: RealSrcSpan -> Int +srcSpanStartCol :: RealSrcSpan -> Int +srcSpanEndCol :: RealSrcSpan -> Int srcSpanStartLine SrcSpanOneLine{ srcSpanLine=l } = l srcSpanStartLine SrcSpanMultiLine{ srcSpanSLine=l } = l srcSpanStartLine SrcSpanPoint{ srcSpanLine=l } = l -srcSpanStartLine _ = panic "SrcLoc.srcSpanStartLine" srcSpanEndLine SrcSpanOneLine{ srcSpanLine=l } = l srcSpanEndLine SrcSpanMultiLine{ srcSpanELine=l } = l srcSpanEndLine SrcSpanPoint{ srcSpanLine=l } = l -srcSpanEndLine _ = panic "SrcLoc.srcSpanEndLine" srcSpanStartCol SrcSpanOneLine{ srcSpanSCol=l } = l srcSpanStartCol SrcSpanMultiLine{ srcSpanSCol=l } = l srcSpanStartCol SrcSpanPoint{ srcSpanCol=l } = l -srcSpanStartCol _ = panic "SrcLoc.srcSpanStartCol" srcSpanEndCol SrcSpanOneLine{ srcSpanECol=c } = c srcSpanEndCol SrcSpanMultiLine{ srcSpanECol=c } = c srcSpanEndCol SrcSpanPoint{ srcSpanCol=c } = c -srcSpanEndCol _ = panic "SrcLoc.srcSpanEndCol" \end{code} @@ -366,26 +396,28 @@ -- | Returns the location at the start of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable srcSpanStart :: SrcSpan -> SrcLoc --- | Returns the location at the end of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable -srcSpanEnd :: SrcSpan -> SrcLoc - srcSpanStart (UnhelpfulSpan str) = UnhelpfulLoc str -srcSpanStart s = mkSrcLoc (srcSpanFile s) - (srcSpanStartLine s) - (srcSpanStartCol s) +srcSpanStart (RealSrcSpan s) = RealSrcLoc (realSrcSpanStart s) +-- | Returns the location at the end of the 'SrcSpan' or a "bad" 'SrcSpan' if that is unavailable +srcSpanEnd :: SrcSpan -> SrcLoc srcSpanEnd (UnhelpfulSpan str) = UnhelpfulLoc str -srcSpanEnd s = - mkSrcLoc (srcSpanFile s) - (srcSpanEndLine s) - (srcSpanEndCol s) +srcSpanEnd (RealSrcSpan s) = RealSrcLoc (realSrcSpanEnd s) + +realSrcSpanStart :: RealSrcSpan -> RealSrcLoc +realSrcSpanStart s = mkRealSrcLoc (srcSpanFile s) + (srcSpanStartLine s) + (srcSpanStartCol s) + +realSrcSpanEnd :: RealSrcSpan -> RealSrcLoc +realSrcSpanEnd s = mkRealSrcLoc (srcSpanFile s) + (srcSpanEndLine s) + (srcSpanEndCol s) -- | Obtains the filename for a 'SrcSpan' if it is "good" srcSpanFileName_maybe :: SrcSpan -> Maybe FastString -srcSpanFileName_maybe (SrcSpanOneLine { srcSpanFile = nm }) = Just nm -srcSpanFileName_maybe (SrcSpanMultiLine { srcSpanFile = nm }) = Just nm -srcSpanFileName_maybe (SrcSpanPoint { srcSpanFile = nm}) = Just nm -srcSpanFileName_maybe _ = Nothing +srcSpanFileName_maybe (RealSrcSpan s) = Just (srcSpanFile s) +srcSpanFileName_maybe (UnhelpfulSpan _) = Nothing \end{code} @@ -404,17 +436,31 @@ (srcSpanEnd a `compare` srcSpanEnd b) -instance Outputable SrcSpan where +instance Outputable RealSrcSpan where ppr span = getPprStyle $ \ sty -> if userStyle sty || debugStyle sty then - pprUserSpan True span + pprUserRealSpan True span else hcat [text "{-# LINE ", int (srcSpanStartLine span), space, char '\"', pprFastFilePath $ srcSpanFile span, text " #-}"] +instance Outputable SrcSpan where + ppr span + = getPprStyle $ \ sty -> + if userStyle sty || debugStyle sty then + pprUserSpan True span + else + case span of + UnhelpfulSpan _ -> panic "Outputable UnhelpfulSpan" + RealSrcSpan s -> ppr s + pprUserSpan :: Bool -> SrcSpan -> SDoc -pprUserSpan show_path (SrcSpanOneLine src_path line start_col end_col) +pprUserSpan _ (UnhelpfulSpan s) = ftext s +pprUserSpan show_path (RealSrcSpan s) = pprUserRealSpan show_path s + +pprUserRealSpan :: Bool -> RealSrcSpan -> SDoc +pprUserRealSpan show_path (SrcSpanOneLine src_path line start_col end_col) = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon) , int line, char ':', int start_col , ppUnless (end_col - start_col <= 1) @@ -424,7 +470,7 @@ ] -pprUserSpan show_path (SrcSpanMultiLine src_path sline scol eline ecol) +pprUserRealSpan show_path (SrcSpanMultiLine src_path sline scol eline ecol) = hcat [ ppWhen show_path (pprFastFilePath src_path <> colon) , parens (int sline <> char ',' <> int scol) , char '-' @@ -432,17 +478,13 @@ if ecol == 0 then int ecol else int (ecol-1)) ] -pprUserSpan show_path (SrcSpanPoint src_path line col) +pprUserRealSpan show_path (SrcSpanPoint src_path line col) = hcat [ ppWhen show_path $ (pprFastFilePath src_path <> colon) , int line, char ':', int col ] -pprUserSpan _ (UnhelpfulSpan s) = ftext s - -pprDefnLoc :: SrcSpan -> SDoc +pprDefnLoc :: RealSrcSpan -> SDoc -- ^ Pretty prints information about the 'SrcSpan' in the style "defined at ..." -pprDefnLoc loc - | isGoodSrcSpan loc = ptext (sLit "Defined at") <+> ppr loc - | otherwise = ppr loc +pprDefnLoc loc = ptext (sLit "Defined at") <+> ppr loc \end{code} %************************************************************************ @@ -453,13 +495,16 @@ \begin{code} -- | We attach SrcSpans to lots of things, so let's have a datatype for it. -data Located e = L SrcSpan e +data GenLocated l e = L l e deriving (Eq, Ord, Typeable, Data) -unLoc :: Located e -> e +type Located e = GenLocated SrcSpan e +type RealLocated e = GenLocated RealSrcSpan e + +unLoc :: GenLocated l e -> e unLoc (L _ e) = e -getLoc :: Located e -> SrcSpan +getLoc :: GenLocated l e -> l getLoc (L l _) = l noLoc :: e -> Located e @@ -487,12 +532,16 @@ cmpLocated :: Ord a => Located a -> Located a -> Ordering cmpLocated a b = unLoc a `compare` unLoc b -instance Functor Located where +instance Functor (GenLocated l) where fmap f (L l e) = L l (f e) -instance Outputable e => Outputable (Located e) where - ppr (L l e) = ifPprDebug (braces (pprUserSpan False l)) $$ ppr e - -- Print spans without the file name etc +instance (Outputable l, Outputable e) => Outputable (GenLocated l e) where + ppr (L l e) = -- TODO: We can't do this since Located was refactored into + -- GenLocated: + -- Print spans without the file name etc + -- ifPprDebug (braces (pprUserSpan False l)) + ifPprDebug (braces (ppr l)) + $$ ppr e \end{code} %************************************************************************ @@ -510,11 +559,11 @@ `thenCmp` (srcSpanEnd b `compare` srcSpanEnd a) - -- | Determines whether a span encloses a given line and column index spans :: SrcSpan -> (Int, Int) -> Bool -spans span (l,c) = srcSpanStart span <= loc && loc <= srcSpanEnd span - where loc = mkSrcLoc (srcSpanFile span) l c +spans (UnhelpfulSpan _) _ = panic "spans UnhelpfulSpan" +spans (RealSrcSpan span) (l,c) = realSrcSpanStart span <= loc && loc <= realSrcSpanEnd span + where loc = mkRealSrcLoc (srcSpanFile span) l c -- | Determines whether a span is enclosed by another one isSubspanOf :: SrcSpan -- ^ The span that may be enclosed by the other diff -Nru ghc-7.0.3/compiler/basicTypes/UniqSupply.lhs ghc-7.2.1/compiler/basicTypes/UniqSupply.lhs --- ghc-7.0.3/compiler/basicTypes/UniqSupply.lhs 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/basicTypes/UniqSupply.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -8,15 +8,16 @@ -- * Main data type UniqSupply, -- Abstractly - -- ** Operations on supplies + -- ** Operations on supplies uniqFromSupply, uniqsFromSupply, -- basic ops - + takeUniqFromSupply, + mkSplitUniqSupply, splitUniqSupply, listSplitUniqSupply, -- * Unique supply monad and its abstraction UniqSM, MonadUnique(..), - + -- ** Operations on the monad initUs, initUs_, lazyThenUs, lazyMapUs, @@ -28,13 +29,10 @@ import Unique import FastTypes +import GHC.IO (unsafeDupableInterleaveIO) + import MonadUtils import Control.Monad -#if __GLASGOW_HASKELL__ >= 611 -import GHC.IO (unsafeDupableInterleaveIO) -#else -import GHC.IOBase (unsafeDupableInterleaveIO) -#endif \end{code} @@ -70,6 +68,8 @@ -- ^ Obtain the 'Unique' from this particular 'UniqSupply' uniqsFromSupply :: UniqSupply -> [Unique] -- Infinite -- ^ Obtain an infinite list of 'Unique' that can be generated by constant splitting of the supply +takeUniqFromSupply :: UniqSupply -> (Unique, UniqSupply) +-- ^ Obtain the 'Unique' from this particular 'UniqSupply', and a new supply \end{code} \begin{code} @@ -98,6 +98,7 @@ \begin{code} uniqFromSupply (MkSplitUniqSupply n _ _) = mkUniqueGrimily (iBox n) uniqsFromSupply (MkSplitUniqSupply n _ s2) = mkUniqueGrimily (iBox n) : uniqsFromSupply s2 +takeUniqFromSupply (MkSplitUniqSupply n s1 _) = (mkUniqueGrimily (iBox n), s1) \end{code} %************************************************************************ diff -Nru ghc-7.0.3/compiler/basicTypes/Unique.lhs ghc-7.2.1/compiler/basicTypes/Unique.lhs --- ghc-7.0.3/compiler/basicTypes/Unique.lhs 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/basicTypes/Unique.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -16,6 +16,7 @@ Haskell). \begin{code} +{-# LANGUAGE BangPatterns #-} module Unique ( -- * Main data types Unique, Uniquable(..), diff -Nru ghc-7.0.3/compiler/basicTypes/VarEnv.lhs ghc-7.2.1/compiler/basicTypes/VarEnv.lhs --- ghc-7.0.3/compiler/basicTypes/VarEnv.lhs 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/basicTypes/VarEnv.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -6,7 +6,7 @@ \begin{code} module VarEnv ( -- * Var, Id and TyVar environments (maps) - VarEnv, IdEnv, TyVarEnv, + VarEnv, IdEnv, TyVarEnv, CoVarEnv, -- ** Manipulating these environments emptyVarEnv, unitVarEnv, mkVarEnv, @@ -29,14 +29,16 @@ emptyInScopeSet, mkInScopeSet, delInScopeSet, extendInScopeSet, extendInScopeSetList, extendInScopeSetSet, getInScopeVars, lookupInScope, lookupInScope_Directly, - unionInScope, elemInScopeSet, uniqAway, + unionInScope, elemInScopeSet, uniqAway, -- * The RnEnv2 type RnEnv2, -- ** Operations on RnEnv2s - mkRnEnv2, rnBndr2, rnBndrs2, rnOccL, rnOccR, inRnEnvL, inRnEnvR, + mkRnEnv2, rnBndr2, rnBndrs2, + rnOccL, rnOccR, inRnEnvL, inRnEnvR, rnOccL_maybe, rnOccR_maybe, rnBndrL, rnBndrR, nukeRnEnvL, nukeRnEnvR, + delBndrL, delBndrR, delBndrsL, delBndrsR, addRnInScopeSet, rnEtaL, rnEtaR, rnInScope, rnInScopeSet, lookupRnInScope, @@ -283,11 +285,24 @@ where new_b = uniqAway in_scope bR +delBndrL, delBndrR :: RnEnv2 -> Var -> RnEnv2 +delBndrL rn@(RV2 { envL = env, in_scope = in_scope }) v = rn { envL = env `delVarEnv` v, in_scope = in_scope `extendInScopeSet` v } +delBndrR rn@(RV2 { envR = env, in_scope = in_scope }) v = rn { envR = env `delVarEnv` v, in_scope = in_scope `extendInScopeSet` v } + +delBndrsL, delBndrsR :: RnEnv2 -> [Var] -> RnEnv2 +delBndrsL rn@(RV2 { envL = env, in_scope = in_scope }) v = rn { envL = env `delVarEnvList` v, in_scope = in_scope `extendInScopeSetList` v } +delBndrsR rn@(RV2 { envR = env, in_scope = in_scope }) v = rn { envR = env `delVarEnvList` v, in_scope = in_scope `extendInScopeSetList` v } + rnOccL, rnOccR :: RnEnv2 -> Var -> Var -- ^ Look up the renaming of an occurrence in the left or right term rnOccL (RV2 { envL = env }) v = lookupVarEnv env v `orElse` v rnOccR (RV2 { envR = env }) v = lookupVarEnv env v `orElse` v +rnOccL_maybe, rnOccR_maybe :: RnEnv2 -> Var -> Maybe Var +-- ^ Look up the renaming of an occurrence in the left or right term +rnOccL_maybe (RV2 { envL = env }) v = lookupVarEnv env v +rnOccR_maybe (RV2 { envR = env }) v = lookupVarEnv env v + inRnEnvL, inRnEnvR :: RnEnv2 -> Var -> Bool -- ^ Tells whether a variable is locally bound inRnEnvL (RV2 { envL = env }) v = v `elemVarEnv` env @@ -343,6 +358,7 @@ type VarEnv elt = UniqFM elt type IdEnv elt = VarEnv elt type TyVarEnv elt = VarEnv elt +type CoVarEnv elt = VarEnv elt emptyVarEnv :: VarEnv a mkVarEnv :: [(Var, a)] -> VarEnv a @@ -359,7 +375,7 @@ restrictVarEnv :: VarEnv a -> VarSet -> VarEnv a delVarEnvList :: VarEnv a -> [Var] -> VarEnv a delVarEnv :: VarEnv a -> Var -> VarEnv a -minusVarEnv :: VarEnv a -> VarEnv a -> VarEnv a +minusVarEnv :: VarEnv a -> VarEnv b -> VarEnv a intersectsVarEnv :: VarEnv a -> VarEnv a -> Bool plusVarEnv_C :: (a -> a -> a) -> VarEnv a -> VarEnv a -> VarEnv a mapVarEnv :: (a -> b) -> VarEnv a -> VarEnv b diff -Nru ghc-7.0.3/compiler/basicTypes/Var.lhs ghc-7.2.1/compiler/basicTypes/Var.lhs --- ghc-7.0.3/compiler/basicTypes/Var.lhs 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/basicTypes/Var.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -17,16 +17,22 @@ -- -- * 'Id.Id': see "Id#name_types" -- --- * 'Var.Var' is a synonym for the 'Id.Id' type but it may additionally potentially contain type variables, --- which have a 'TypeRep.Kind' rather than a 'TypeRep.Type' and only contain some extra details during typechecking. +-- * 'Var.Var' is a synonym for the 'Id.Id' type but it may additionally +-- potentially contain type variables, which have a 'TypeRep.Kind' +-- rather than a 'TypeRep.Type' and only contain some extra +-- details during typechecking. +-- -- These 'Var.Var' names may either be global or local, see "Var#globalvslocal" -- -- #globalvslocal# --- Global 'Id's and 'Var's are those that are imported or correspond to a data constructor, primitive operation, or record selectors. --- Local 'Id's and 'Var's are those bound within an expression (e.g. by a lambda) or at the top level of the module being compiled. +-- Global 'Id's and 'Var's are those that are imported or correspond +-- to a data constructor, primitive operation, or record selectors. +-- Local 'Id's and 'Var's are those bound within an expression +-- (e.g. by a lambda) or at the top level of the module being compiled. + module Var ( -- * The main data type and synonyms - Var, TyVar, CoVar, Id, DictId, DFunId, EvVar, EvId, IpId, + Var, TyVar, CoVar, TyCoVar, Id, DictId, DFunId, EvVar, EvId, IpId, -- ** Taking 'Var's apart varName, varUnique, varType, @@ -35,34 +41,25 @@ setVarName, setVarUnique, setVarType, -- ** Constructing, taking apart, modifying 'Id's - mkGlobalVar, mkLocalVar, mkExportedLocalVar, + mkGlobalVar, mkLocalVar, mkExportedLocalVar, mkCoVar, idInfo, idDetails, lazySetIdInfo, setIdDetails, globaliseId, setIdExported, setIdNotExported, -- ** Predicates - isCoVar, isId, isTyCoVar, isTyVar, isTcTyVar, + isId, isTyVar, isTcTyVar, isLocalVar, isLocalId, isGlobalId, isExportedId, mustHaveLocalBinding, -- ** Constructing 'TyVar's - mkTyVar, mkTcTyVar, mkWildCoVar, + mkTyVar, mkTcTyVar, -- ** Taking 'TyVar's apart tyVarName, tyVarKind, tcTyVarDetails, setTcTyVarDetails, -- ** Modifying 'TyVar's - setTyVarName, setTyVarUnique, setTyVarKind, - - -- ** Constructing 'CoVar's - mkCoVar, - - -- ** Taking 'CoVar's apart - coVarName, - - -- ** Modifying 'CoVar's - setCoVarUnique, setCoVarName + setTyVarName, setTyVarUnique, setTyVarKind ) where @@ -71,8 +68,7 @@ import {-# SOURCE #-} TypeRep( Type, Kind ) import {-# SOURCE #-} TcType( TcTyVarDetails, pprTcTyVarDetails ) -import {-# SOURCE #-} IdInfo( IdDetails, IdInfo, pprIdDetails ) -import {-# SOURCE #-} TypeRep( isCoercionKind ) +import {-# SOURCE #-} IdInfo( IdDetails, IdInfo, coVarDetails, vanillaIdInfo, pprIdDetails ) import Name hiding (varName) import Unique @@ -94,7 +90,7 @@ -- large number of SOURCE imports of Id.hs :-( \begin{code} -type EvVar = Var -- An evidence variable: dictionary or equality constraint +type EvVar = Var -- An evidence variable: dictionary or equality constraint -- Could be an DictId or a CoVar type Id = Var -- A term-level identifier @@ -104,9 +100,10 @@ type IpId = EvId -- A term-level implicit parameter type TyVar = Var -type CoVar = TyVar -- A coercion variable is simply a type +type CoVar = Id -- A coercion variable is simply an Id -- variable of kind @ty1 ~ ty2@. Hence its -- 'varType' is always @PredTy (EqPred t1 t2)@ +type TyCoVar = TyVar -- Something that is a type OR coercion variable. \end{code} %************************************************************************ @@ -130,8 +127,7 @@ realUnique :: FastInt, -- Key for fast comparison -- Identical to the Unique in the name, -- cached here for speed - varType :: Kind, -- ^ The type or kind of the 'Var' in question - isCoercionVar :: Bool + varType :: Kind -- ^ The type or kind of the 'Var' in question } | TcTyVar { -- Used only during type inference @@ -149,6 +145,7 @@ 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 @@ -181,9 +178,8 @@ ppr var = ppr (varName var) <+> ifPprDebug (brackets (ppr_debug var)) ppr_debug :: Var -> SDoc -ppr_debug (TyVar { isCoercionVar = False }) = ptext (sLit "tv") -ppr_debug (TyVar { isCoercionVar = True }) = ptext (sLit "co") -ppr_debug (TcTyVar {tc_tv_details = d}) = pprTcTyVarDetails d +ppr_debug (TyVar {}) = ptext (sLit "tv") +ppr_debug (TcTyVar {tc_tv_details = d}) = pprTcTyVarDetails d ppr_debug (Id { idScope = s, id_details = d }) = ppr_id_scope s <> pprIdDetails d ppr_id_scope :: IdScope -> SDoc @@ -210,8 +206,6 @@ 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" @@ -264,11 +258,9 @@ \begin{code} mkTyVar :: Name -> Kind -> TyVar -mkTyVar name kind = ASSERT( not (isCoercionKind kind ) ) - TyVar { varName = name +mkTyVar name kind = TyVar { varName = name , realUnique = getKeyFastInt (nameUnique name) , varType = kind - , isCoercionVar = False } mkTcTyVar :: Name -> Kind -> TcTyVarDetails -> TyVar @@ -290,36 +282,6 @@ %************************************************************************ %* * -\subsection{Coercion variables} -%* * -%************************************************************************ - -\begin{code} -coVarName :: CoVar -> Name -coVarName = varName - -setCoVarUnique :: CoVar -> Unique -> CoVar -setCoVarUnique = setVarUnique - -setCoVarName :: CoVar -> Name -> CoVar -setCoVarName = setVarName - -mkCoVar :: Name -> Kind -> CoVar -mkCoVar name kind = ASSERT( isCoercionKind kind ) - TyVar { varName = name - , realUnique = getKeyFastInt (nameUnique name) - , varType = kind - , isCoercionVar = True - } - -mkWildCoVar :: Kind -> TyVar --- ^ Create a type variable that is never referred to, so its unique doesn't --- matter -mkWildCoVar = mkCoVar (mkSysTvName (mkBuiltinUnique 1) (fsLit "co_wild")) -\end{code} - -%************************************************************************ -%* * \subsection{Ids} %* * %************************************************************************ @@ -343,6 +305,10 @@ mkLocalVar details name ty info = mk_id name ty (LocalId NotExported) details info +mkCoVar :: Name -> Type -> CoVar +-- Coercion variables have no IdInfo +mkCoVar name ty = mk_id name ty (LocalId NotExported) coVarDetails vanillaIdInfo + -- | Exported 'Var's will not be removed as dead code mkExportedLocalVar :: IdDetails -> Name -> Type -> IdInfo -> Id mkExportedLocalVar details name ty info @@ -388,20 +354,11 @@ %************************************************************************ \begin{code} -isTyCoVar :: Var -> Bool -- True of both type and coercion variables -isTyCoVar (TyVar {}) = True -isTyCoVar (TcTyVar {}) = True -isTyCoVar _ = False - -isTyVar :: Var -> Bool -- True of both type variables only -isTyVar v@(TyVar {}) = not (isCoercionVar v) +isTyVar :: Var -> Bool -- True of both type variables only +isTyVar (TyVar {}) = True isTyVar (TcTyVar {}) = True isTyVar _ = False -isCoVar :: Var -> Bool -- Only works after type checking (sigh) -isCoVar v@(TyVar {}) = isCoercionVar v -isCoVar _ = False - isTcTyVar :: Var -> Bool isTcTyVar (TcTyVar {}) = True isTcTyVar _ = False diff -Nru ghc-7.0.3/compiler/basicTypes/VarSet.lhs ghc-7.2.1/compiler/basicTypes/VarSet.lhs --- ghc-7.0.3/compiler/basicTypes/VarSet.lhs 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/basicTypes/VarSet.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -6,7 +6,7 @@ \begin{code} module VarSet ( -- * Var, Id and TyVar set types - VarSet, IdSet, TyVarSet, + VarSet, IdSet, TyVarSet, TyCoVarSet, CoVarSet, -- ** Manipulating these sets emptyVarSet, unitVarSet, mkVarSet, @@ -22,7 +22,7 @@ #include "HsVersions.h" -import Var ( Var, TyVar, Id ) +import Var ( Var, TyVar, CoVar, TyCoVar, Id ) import Unique import UniqSet \end{code} @@ -37,6 +37,8 @@ type VarSet = UniqSet Var type IdSet = UniqSet Id type TyVarSet = UniqSet TyVar +type TyCoVarSet = UniqSet TyCoVar +type CoVarSet = UniqSet CoVar emptyVarSet :: VarSet intersectVarSet :: VarSet -> VarSet -> VarSet diff -Nru ghc-7.0.3/compiler/cmm/BlockId.hs ghc-7.2.1/compiler/cmm/BlockId.hs --- ghc-7.0.3/compiler/cmm/BlockId.hs 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/cmm/BlockId.hs 2011-08-07 17:10:05.000000000 +0000 @@ -1,23 +1,21 @@ +{- BlockId module should probably go away completely, being superseded by Label -} module BlockId - ( BlockId(..), mkBlockId -- ToDo: BlockId should be abstract, but it isn't yet - , BlockEnv, emptyBlockEnv, elemBlockEnv, lookupBlockEnv, extendBlockEnv - , mkBlockEnv, mapBlockEnv - , eltsBlockEnv, plusBlockEnv, delFromBlockEnv, blockEnvToList, lookupWithDefaultBEnv - , isNullBEnv, sizeBEnv, foldBlockEnv, foldBlockEnv', addToBEnv_Acc - , BlockSet, emptyBlockSet, unitBlockSet, isEmptyBlockSet - , elemBlockSet, extendBlockSet, sizeBlockSet, unionBlockSets - , removeBlockSet, mkBlockSet, blockSetToList, foldBlockSet + ( BlockId, mkBlockId -- ToDo: BlockId should be abstract, but it isn't yet + , BlockSet, BlockEnv + , IsSet(..), setInsertList, setDeleteList, setUnions + , IsMap(..), mapInsertList, mapDeleteList, mapUnions + , emptyBlockSet, emptyBlockMap , blockLbl, infoTblLbl, retPtLbl ) where import CLabel import IdInfo -import Maybes import Name import Outputable -import UniqFM import Unique -import UniqSet + +import Compiler.Hoopl hiding (Unique) +import Compiler.Hoopl.GHC (uniqueToInt, uniqueToLbl, lblToUnique) ---------------------------------------------------------------- --- Block Ids, their environments, and their sets @@ -31,129 +29,40 @@ compilation unit in which it appears. -} -data BlockId = BlockId Unique - deriving (Eq,Ord) +type BlockId = Label instance Uniquable BlockId where - getUnique (BlockId id) = id + getUnique label = getUnique (uniqueToInt $ lblToUnique label) mkBlockId :: Unique -> BlockId -mkBlockId uniq = BlockId uniq - -instance Show BlockId where - show (BlockId u) = show u +mkBlockId unique = uniqueToLbl $ intToUnique $ getKey unique instance Outputable BlockId where - ppr (BlockId id) = ppr id + ppr label = ppr (getUnique label) retPtLbl :: BlockId -> CLabel -retPtLbl (BlockId id) = mkReturnPtLabel id +retPtLbl label = mkReturnPtLabel $ getUnique label blockLbl :: BlockId -> CLabel -blockLbl (BlockId id) = mkEntryLabel (mkFCallName id "block") NoCafRefs +blockLbl label = mkEntryLabel (mkFCallName (getUnique label) "block") NoCafRefs infoTblLbl :: BlockId -> CLabel -infoTblLbl (BlockId id) = mkInfoTableLabel (mkFCallName id "block") NoCafRefs +infoTblLbl label = mkInfoTableLabel (mkFCallName (getUnique label) "block") NoCafRefs -- Block environments: Id blocks -newtype BlockEnv a = BlockEnv (UniqFM {- id -} a) +type BlockEnv a = LabelMap a instance Outputable a => Outputable (BlockEnv a) where - ppr (BlockEnv env) = ppr env - --- This is pretty horrid. There must be common patterns here that can be --- abstracted into wrappers. -emptyBlockEnv :: BlockEnv a -emptyBlockEnv = BlockEnv emptyUFM - -isNullBEnv :: BlockEnv a -> Bool -isNullBEnv (BlockEnv env) = isNullUFM env - -sizeBEnv :: BlockEnv a -> Int -sizeBEnv (BlockEnv env) = sizeUFM env - -mkBlockEnv :: [(BlockId,a)] -> BlockEnv a -mkBlockEnv = foldl (uncurry . extendBlockEnv) emptyBlockEnv - -eltsBlockEnv :: BlockEnv elt -> [elt] -eltsBlockEnv (BlockEnv env) = eltsUFM env - -delFromBlockEnv :: BlockEnv elt -> BlockId -> BlockEnv elt -delFromBlockEnv (BlockEnv env) (BlockId id) = BlockEnv (delFromUFM env id) - -lookupBlockEnv :: BlockEnv a -> BlockId -> Maybe a -lookupBlockEnv (BlockEnv env) (BlockId id) = lookupUFM env id - -elemBlockEnv :: BlockEnv a -> BlockId -> Bool -elemBlockEnv (BlockEnv env) (BlockId id) = isJust $ lookupUFM env id - -lookupWithDefaultBEnv :: BlockEnv a -> a -> BlockId -> a -lookupWithDefaultBEnv env x id = lookupBlockEnv env id `orElse` x - -extendBlockEnv :: BlockEnv a -> BlockId -> a -> BlockEnv a -extendBlockEnv (BlockEnv env) (BlockId id) x = BlockEnv (addToUFM env id x) - -mapBlockEnv :: (a -> b) -> BlockEnv a -> BlockEnv b -mapBlockEnv f (BlockEnv env) = BlockEnv (mapUFM f env) - -foldBlockEnv :: (BlockId -> a -> b -> b) -> b -> BlockEnv a -> b -foldBlockEnv f b (BlockEnv env) = - foldUFM_Directly (\u x y -> f (mkBlockId u) x y) b env + ppr = ppr . mapToList -foldBlockEnv' :: (a -> b -> b) -> b -> BlockEnv a -> b -foldBlockEnv' f b (BlockEnv env) = foldUFM f b env +emptyBlockMap :: BlockEnv a +emptyBlockMap = mapEmpty -plusBlockEnv :: BlockEnv elt -> BlockEnv elt -> BlockEnv elt -plusBlockEnv (BlockEnv x) (BlockEnv y) = BlockEnv (plusUFM x y) +-- Block sets +type BlockSet = LabelSet -blockEnvToList :: BlockEnv elt -> [(BlockId, elt)] -blockEnvToList (BlockEnv env) = - map (\ (id, elt) -> (BlockId id, elt)) $ ufmToList env - -addToBEnv_Acc :: (elt -> elts -> elts) -- Add to existing - -> (elt -> elts) -- New element - -> BlockEnv elts -- old - -> BlockId -> elt -- new - -> BlockEnv elts -- result -addToBEnv_Acc add new (BlockEnv old) (BlockId k) v = - BlockEnv (addToUFM_Acc add new old k v) - -- I believe this is only used by obsolete code. - - -newtype BlockSet = BlockSet (UniqSet Unique) instance Outputable BlockSet where - ppr (BlockSet set) = ppr set - + ppr = ppr . setElems emptyBlockSet :: BlockSet -emptyBlockSet = BlockSet emptyUniqSet - -isEmptyBlockSet :: BlockSet -> Bool -isEmptyBlockSet (BlockSet s) = isEmptyUniqSet s - -unitBlockSet :: BlockId -> BlockSet -unitBlockSet = extendBlockSet emptyBlockSet - -elemBlockSet :: BlockId -> BlockSet -> Bool -elemBlockSet (BlockId id) (BlockSet set) = elementOfUniqSet id set - -extendBlockSet :: BlockSet -> BlockId -> BlockSet -extendBlockSet (BlockSet set) (BlockId id) = BlockSet (addOneToUniqSet set id) - -removeBlockSet :: BlockSet -> BlockId -> BlockSet -removeBlockSet (BlockSet set) (BlockId id) = BlockSet (delOneFromUniqSet set id) - -mkBlockSet :: [BlockId] -> BlockSet -mkBlockSet = foldl extendBlockSet emptyBlockSet - -unionBlockSets :: BlockSet -> BlockSet -> BlockSet -unionBlockSets (BlockSet s) (BlockSet s') = BlockSet (unionUniqSets s s') - -sizeBlockSet :: BlockSet -> Int -sizeBlockSet (BlockSet set) = sizeUniqSet set - -blockSetToList :: BlockSet -> [BlockId] -blockSetToList (BlockSet set) = map BlockId $ uniqSetToList set - -foldBlockSet :: (BlockId -> b -> b) -> b -> BlockSet -> b -foldBlockSet f z (BlockSet set) = foldUniqSet (f . BlockId) z set +emptyBlockSet = setEmpty diff -Nru ghc-7.0.3/compiler/cmm/CLabel.hs ghc-7.2.1/compiler/cmm/CLabel.hs --- ghc-7.0.3/compiler/cmm/CLabel.hs 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/cmm/CLabel.hs 2011-08-07 17:10:05.000000000 +0000 @@ -51,9 +51,7 @@ mkAsmTempLabel, - mkModuleInitLabel, - mkPlainModuleInitLabel, - mkModuleInitTableLabel, + mkPlainModuleInitLabel, mkSplitMarkerLabel, mkDirty_MUT_VAR_Label, @@ -67,13 +65,11 @@ mkTopTickyCtrLabel, mkCAFBlackHoleInfoTableLabel, + mkCAFBlackHoleEntryLabel, mkRtsPrimOpLabel, mkRtsSlowTickyCtrLabel, - moduleRegdLabel, - moduleRegTableLabel, - - mkSelectorInfoLabel, + mkSelectorInfoLabel, mkSelectorEntryLabel, mkCmmInfoLabel, @@ -102,10 +98,9 @@ mkDeadStripPreventer, mkHpcTicksLabel, - mkHpcModuleNameLabel, hasCAF, - infoLblToEntryLbl, entryLblToInfoLbl, cvtToClosureLbl, cvtToSRTLbl, + cvtToClosureLbl, needsCDecl, isAsmTemp, maybeAsmTemp, externallyVisibleCLabel, isMathFun, isCFunctionLabel, isGcPtrLabel, labelDynamic, @@ -202,23 +197,9 @@ | StringLitLabel {-# UNPACK #-} !Unique - | ModuleInitLabel - Module -- the module name - String -- its "way" - -- at some point we might want some kind of version number in - -- the module init label, to guard against compiling modules in - -- the wrong order. We can't use the interface file version however, - -- because we don't always recompile modules which depend on a module - -- whose version has changed. - - | PlainModuleInitLabel -- without the version & way info - Module - - | ModuleInitTableLabel -- table of imported modules to init + | PlainModuleInitLabel -- without the version & way info Module - | ModuleRegdLabel - | CC_Label CostCentre | CCS_Label CostCentreStack @@ -242,9 +223,6 @@ -- | Per-module table of tick locations | HpcTicksLabel Module - -- | Per-module name of the module for Hpc - | HpcModuleNameLabel - -- | Label of an StgLargeSRT | LargeSRTLabel {-# UNPACK #-} !Unique @@ -301,11 +279,14 @@ _ -> ppr lbl <> (parens $ text "other CLabel)") +-- True if a local IdLabel that we won't mark as exported +type IsLocal = Bool + data IdLabelInfo = Closure -- ^ Label for closure | SRT -- ^ Static reference table - | InfoTable -- ^ Info tables for closures; always read-only - | Entry -- ^ Entry point + | InfoTable IsLocal -- ^ Info tables for closures; always read-only + | Entry -- ^ Entry point | Slow -- ^ Slow entry point | RednCounts -- ^ Label of place to keep Ticky-ticky info for this Id @@ -379,12 +360,12 @@ -- These have local & (possibly) external variants: mkLocalClosureLabel name c = IdLabel name c Closure -mkLocalInfoTableLabel name c = IdLabel name c InfoTable +mkLocalInfoTableLabel name c = IdLabel name c (InfoTable True) mkLocalEntryLabel name c = IdLabel name c Entry mkLocalClosureTableLabel name c = IdLabel name c ClosureTable mkClosureLabel name c = IdLabel name c Closure -mkInfoTableLabel name c = IdLabel name c InfoTable +mkInfoTableLabel name c = IdLabel name c (InfoTable False) mkEntryLabel name c = IdLabel name c Entry mkClosureTableLabel name c = IdLabel name c ClosureTable mkLocalConInfoTableLabel c con = IdLabel con c ConInfoTable @@ -409,6 +390,7 @@ mkEMPTY_MVAR_infoLabel = CmmLabel rtsPackageId (fsLit "stg_EMPTY_MVAR") CmmInfo mkTopTickyCtrLabel = CmmLabel rtsPackageId (fsLit "top_ct") CmmData mkCAFBlackHoleInfoTableLabel = CmmLabel rtsPackageId (fsLit "stg_CAF_BLACKHOLE") CmmInfo +mkCAFBlackHoleEntryLabel = CmmLabel rtsPackageId (fsLit "stg_CAF_BLACKHOLE") CmmEntry ----- mkCmmInfoLabel, mkCmmEntryLabel, mkCmmRetInfoLabel, mkCmmRetLabel, @@ -490,7 +472,6 @@ -- Constructing Code Coverage Labels mkHpcTicksLabel = HpcTicksLabel -mkHpcModuleNameLabel = HpcModuleNameLabel -- Constructing labels used for dynamic linking @@ -515,60 +496,21 @@ mkAsmTempLabel :: Uniquable a => a -> CLabel mkAsmTempLabel a = AsmTempLabel (getUnique a) -mkModuleInitLabel :: Module -> String -> CLabel -mkModuleInitLabel mod way = ModuleInitLabel mod way - mkPlainModuleInitLabel :: Module -> CLabel mkPlainModuleInitLabel mod = PlainModuleInitLabel mod -mkModuleInitTableLabel :: Module -> CLabel -mkModuleInitTableLabel mod = ModuleInitTableLabel mod - -moduleRegdLabel = ModuleRegdLabel -moduleRegTableLabel = ModuleInitTableLabel - - -- ----------------------------------------------------------------------------- --- Converting between info labels and entry/ret labels. - -infoLblToEntryLbl :: CLabel -> CLabel -infoLblToEntryLbl (IdLabel n c InfoTable) = IdLabel n c Entry -infoLblToEntryLbl (IdLabel n c ConInfoTable) = IdLabel n c ConEntry -infoLblToEntryLbl (IdLabel n c StaticInfoTable) = IdLabel n c StaticConEntry -infoLblToEntryLbl (CaseLabel n CaseReturnInfo) = CaseLabel n CaseReturnPt -infoLblToEntryLbl (CmmLabel m str CmmInfo) = CmmLabel m str CmmEntry -infoLblToEntryLbl (CmmLabel m str CmmRetInfo) = CmmLabel m str CmmRet -infoLblToEntryLbl _ - = panic "CLabel.infoLblToEntryLbl" - - -entryLblToInfoLbl :: CLabel -> CLabel -entryLblToInfoLbl (IdLabel n c Entry) = IdLabel n c InfoTable -entryLblToInfoLbl (IdLabel n c ConEntry) = IdLabel n c ConInfoTable -entryLblToInfoLbl (IdLabel n c StaticConEntry) = IdLabel n c StaticInfoTable -entryLblToInfoLbl (CaseLabel n CaseReturnPt) = CaseLabel n CaseReturnInfo -entryLblToInfoLbl (CmmLabel m str CmmEntry) = CmmLabel m str CmmInfo -entryLblToInfoLbl (CmmLabel m str CmmRet) = CmmLabel m str CmmRetInfo -entryLblToInfoLbl l - = pprPanic "CLabel.entryLblToInfoLbl" (pprCLabel l) - +-- Brutal method of obtaining a closure label -cvtToClosureLbl (IdLabel n c InfoTable) = IdLabel n c Closure -cvtToClosureLbl (IdLabel n c Entry) = IdLabel n c Closure +cvtToClosureLbl (IdLabel n c (InfoTable _)) = IdLabel n c Closure +cvtToClosureLbl (IdLabel n c Entry) = IdLabel n c Closure cvtToClosureLbl (IdLabel n c ConEntry) = IdLabel n c Closure +cvtToClosureLbl (IdLabel n c RednCounts) = IdLabel n c Closure cvtToClosureLbl l@(IdLabel n c Closure) = l cvtToClosureLbl l = pprPanic "cvtToClosureLbl" (pprCLabel l) -cvtToSRTLbl (IdLabel n c InfoTable) = mkSRTLabel n c -cvtToSRTLbl (IdLabel n c Entry) = mkSRTLabel n c -cvtToSRTLbl (IdLabel n c ConEntry) = mkSRTLabel n c -cvtToSRTLbl l@(IdLabel n c Closure) = mkSRTLabel n c -cvtToSRTLbl l - = pprPanic "cvtToSRTLbl" (pprCLabel l) - - -- ----------------------------------------------------------------------------- -- Does a CLabel refer to a CAF? hasCAF :: CLabel -> Bool @@ -590,10 +532,7 @@ needsCDecl (LargeBitmapLabel _) = False needsCDecl (IdLabel _ _ _) = True needsCDecl (CaseLabel _ _) = True -needsCDecl (ModuleInitLabel _ _) = True -needsCDecl (PlainModuleInitLabel _) = True -needsCDecl (ModuleInitTableLabel _) = True -needsCDecl ModuleRegdLabel = False +needsCDecl (PlainModuleInitLabel _) = True needsCDecl (StringLitLabel _) = False needsCDecl (AsmTempLabel _) = False @@ -611,7 +550,6 @@ needsCDecl (CC_Label _) = True needsCDecl (CCS_Label _) = True needsCDecl (HpcTicksLabel _) = True -needsCDecl HpcModuleNameLabel = False -- | Check whether a label is a local temporary for native code generation @@ -629,7 +567,7 @@ -- | Check whether a label corresponds to a C function that has -- a prototype in a system header somehere, or is built-in --- to the C compiler. For these labels we abovoid generating our +-- to the C compiler. For these labels we avoid generating our -- own C prototypes. isMathFun :: CLabel -> Bool isMathFun (ForeignLabel fs _ _ _) = fs `elementOfUniqSet` math_funs @@ -724,22 +662,23 @@ externallyVisibleCLabel (CaseLabel _ _) = False externallyVisibleCLabel (StringLitLabel _) = False externallyVisibleCLabel (AsmTempLabel _) = False -externallyVisibleCLabel (ModuleInitLabel _ _) = True externallyVisibleCLabel (PlainModuleInitLabel _)= True -externallyVisibleCLabel (ModuleInitTableLabel _)= False -externallyVisibleCLabel ModuleRegdLabel = False -externallyVisibleCLabel (RtsLabel _) = True +externallyVisibleCLabel (RtsLabel _) = True externallyVisibleCLabel (CmmLabel _ _ _) = True externallyVisibleCLabel (ForeignLabel{}) = True -externallyVisibleCLabel (IdLabel name _ _) = isExternalName name +externallyVisibleCLabel (IdLabel name _ info) = isExternalName name && externallyVisibleIdLabel info externallyVisibleCLabel (CC_Label _) = True externallyVisibleCLabel (CCS_Label _) = True externallyVisibleCLabel (DynamicLinkerLabel _ _) = False externallyVisibleCLabel (HpcTicksLabel _) = True -externallyVisibleCLabel HpcModuleNameLabel = False -externallyVisibleCLabel (LargeBitmapLabel _) = False +externallyVisibleCLabel (LargeBitmapLabel _) = False externallyVisibleCLabel (LargeSRTLabel _) = False +externallyVisibleIdLabel :: IdLabelInfo -> Bool +externallyVisibleIdLabel SRT = False +externallyVisibleIdLabel (InfoTable lcl) = not lcl +externallyVisibleIdLabel _ = True + -- ----------------------------------------------------------------------------- -- Finding the "type" of a CLabel @@ -776,9 +715,7 @@ labelType (RtsLabel (RtsApFast _)) = CodeLabel labelType (CaseLabel _ CaseReturnInfo) = DataLabel labelType (CaseLabel _ _) = CodeLabel -labelType (ModuleInitLabel _ _) = CodeLabel labelType (PlainModuleInitLabel _) = CodeLabel -labelType (ModuleInitTableLabel _) = DataLabel labelType (LargeSRTLabel _) = DataLabel labelType (LargeBitmapLabel _) = DataLabel labelType (ForeignLabel _ _ _ IsFunction) = CodeLabel @@ -787,7 +724,7 @@ idInfoLabelType info = case info of - InfoTable -> DataLabel + InfoTable _ -> DataLabel Closure -> GcPtrLabel ConInfoTable -> DataLabel StaticInfoTable -> DataLabel @@ -836,10 +773,8 @@ CmmLabel pkg _ _ -> True #endif - ModuleInitLabel m _ -> not opt_Static && this_pkg /= (modulePackageId m) PlainModuleInitLabel m -> not opt_Static && this_pkg /= (modulePackageId m) - ModuleInitTableLabel m -> not opt_Static && this_pkg /= (modulePackageId m) - + -- Note that DynamicLinkerLabels do NOT require dynamic linking themselves. _ -> False @@ -892,11 +827,13 @@ instance Outputable CLabel where ppr = pprCLabel +instance PlatformOutputable CLabel where + pprPlatform _ = pprCLabel pprCLabel :: CLabel -> SDoc -#if ! OMIT_NATIVE_CODEGEN pprCLabel (AsmTempLabel u) + | cGhcWithNativeCodeGen == "YES" = getPprStyle $ \ sty -> if asmStyle sty then ptext asmTempLabelPrefix <> pprUnique u @@ -904,23 +841,22 @@ char '_' <> pprUnique u pprCLabel (DynamicLinkerLabel info lbl) + | cGhcWithNativeCodeGen == "YES" = pprDynamicLinkerAsmLabel info lbl pprCLabel PicBaseLabel + | cGhcWithNativeCodeGen == "YES" = ptext (sLit "1b") pprCLabel (DeadStripPreventer lbl) + | cGhcWithNativeCodeGen == "YES" = pprCLabel lbl <> ptext (sLit "_dsp") -#endif -pprCLabel lbl = -#if ! OMIT_NATIVE_CODEGEN - getPprStyle $ \ sty -> - if asmStyle sty then - maybe_underscore (pprAsmCLbl lbl) - else -#endif - pprCLbl lbl +pprCLabel lbl + = getPprStyle $ \ sty -> + if cGhcWithNativeCodeGen == "YES" && asmStyle sty + then maybe_underscore (pprAsmCLbl lbl) + else pprCLbl lbl maybe_underscore doc | underscorePrefix = pp_cSEP <> doc @@ -1007,9 +943,6 @@ pprCLbl (RtsLabel (RtsSlowTickyCtr pat)) = ptext (sLit "SLOW_CALL_") <> text pat <> ptext (sLit "_ctr") -pprCLbl ModuleRegdLabel - = ptext (sLit "_module_registered") - pprCLbl (ForeignLabel str _ _ _) = ftext str @@ -1018,28 +951,18 @@ pprCLbl (CC_Label cc) = ppr cc pprCLbl (CCS_Label ccs) = ppr ccs -pprCLbl (ModuleInitLabel mod way) - = ptext (sLit "__stginit_") <> ppr mod - <> char '_' <> text way - pprCLbl (PlainModuleInitLabel mod) = ptext (sLit "__stginit_") <> ppr mod -pprCLbl (ModuleInitTableLabel mod) - = ptext (sLit "__stginittable_") <> ppr mod - pprCLbl (HpcTicksLabel mod) = ptext (sLit "_hpc_tickboxes_") <> ppr mod <> ptext (sLit "_hpc") -pprCLbl HpcModuleNameLabel - = ptext (sLit "_hpc_module_name_str") - ppIdFlavor :: IdLabelInfo -> SDoc ppIdFlavor x = pp_cSEP <> (case x of Closure -> ptext (sLit "closure") SRT -> ptext (sLit "srt") - InfoTable -> ptext (sLit "info") + InfoTable _ -> ptext (sLit "info") Entry -> ptext (sLit "entry") Slow -> ptext (sLit "slow") RednCounts -> ptext (sLit "ct") diff -Nru ghc-7.0.3/compiler/cmm/CmmBrokenBlock.hs ghc-7.2.1/compiler/cmm/CmmBrokenBlock.hs --- ghc-7.0.3/compiler/cmm/CmmBrokenBlock.hs 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/cmm/CmmBrokenBlock.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,421 +0,0 @@ - -module CmmBrokenBlock ( - BrokenBlock(..), - BlockEntryInfo(..), - FinalStmt(..), - breakBlock, - cmmBlockFromBrokenBlock, - blocksToBlockEnv, - adaptBlockToFormat, - selectContinuations, - ContFormat, - makeContinuationEntries - ) where - -#include "HsVersions.h" - -import BlockId -import Cmm -import CmmUtils -import CLabel - -import CgUtils (callerSaveVolatileRegs) -import ClosureInfo - -import Maybes -import Data.List -import Panic -import Unique - --- This module takes a 'CmmBasicBlock' which might have 'CmmCall' --- statements in it with 'CmmSafe' set and breaks it up at each such call. --- It also collects information about the block for later use --- by the CPS algorithm. - ------------------------------------------------------------------------------ --- Data structures ------------------------------------------------------------------------------ - --- |Similar to a 'CmmBlock' with a little extra information --- to help the CPS analysis. -data BrokenBlock - = BrokenBlock { - brokenBlockId :: BlockId, -- ^ The block's label like a 'CmmBasicBlock' - brokenBlockEntry :: BlockEntryInfo, - -- ^ Ways this block can be entered - - brokenBlockStmts :: [CmmStmt], - -- ^ Body like a CmmBasicBlock - -- (but without the last statement) - - brokenBlockTargets :: [BlockId], - -- ^ Blocks that this block could - -- branch to either by conditional - -- branches or via the last statement - - brokenBlockExit :: FinalStmt - -- ^ The final statement of the block - } - --- | How a block could be entered --- See Note [An example of CPS conversion] -data BlockEntryInfo - = FunctionEntry CmmInfo CLabel CmmFormals - -- ^ Block is the beginning of a function, parameters are: - -- 1. Function header info - -- 2. The function name - -- 3. Aguments to function - -- Only the formal parameters are live - - | ContinuationEntry CmmFormals C_SRT Bool - -- ^ Return point of a function call, parameters are: - -- 1. return values (argument to continuation) - -- 2. SRT for the continuation's info table - -- 3. True <=> GC block so ignore stack size - -- Live variables, other than - -- the return values, are on the stack - - | ControlEntry - -- ^ Any other kind of block. Only entered due to control flow. - - -- TODO: Consider adding ProcPointEntry - -- no return values, but some live might end up as - -- params or possibly in the frame - -{- Note [An example of CPS conversion] - -This is NR's and SLPJ's guess about how things might work; -it may not be consistent with the actual code (particularly -in the matter of what's in parameters and what's on the stack). - -f(x,y) { - if x>2 then goto L - x = x+1 -L: if x>1 then y = g(y) - else x = x+1 ; - return( x+y ) -} - BECOMES - -f(x,y) { // FunctionEntry - if x>2 then goto L - x = x+1 -L: // ControlEntry - if x>1 then push x; push f1; jump g(y) - else x=x+1; jump f2(x, y) -} - -f1(y) { // ContinuationEntry - pop x; jump f2(x, y); -} - -f2(x, y) { // ProcPointEntry - return (z+y); -} - --} - -data ContFormat = ContFormat HintedCmmFormals C_SRT Bool - -- ^ Arguments - -- 1. return values (argument to continuation) - -- 2. SRT for the continuation's info table - -- 3. True <=> GC block so ignore stack size - deriving (Eq) - --- | Final statement in a 'BlokenBlock'. --- Constructors and arguments match those in 'Cmm', --- but are restricted to branches, returns, jumps, calls and switches -data FinalStmt - = FinalBranch BlockId - -- ^ Same as 'CmmBranch'. Target must be a ControlEntry - - | FinalReturn HintedCmmActuals - -- ^ Same as 'CmmReturn'. Parameter is the return values. - - | FinalJump CmmExpr HintedCmmActuals - -- ^ Same as 'CmmJump'. Parameters: - -- 1. The function to call, - -- 2. Arguments of the call - - | FinalCall BlockId CmmCallTarget HintedCmmFormals HintedCmmActuals - C_SRT CmmReturnInfo Bool - -- ^ Same as 'CmmCallee' followed by 'CmmGoto'. Parameters: - -- 1. Target of the 'CmmGoto' (must be a 'ContinuationEntry') - -- 2. The function to call - -- 3. Results from call (redundant with ContinuationEntry) - -- 4. Arguments to call - -- 5. SRT for the continuation's info table - -- 6. Does the function return? - -- 7. True <=> GC block so ignore stack size - - | FinalSwitch CmmExpr [Maybe BlockId] - -- ^ Same as a 'CmmSwitch'. Paremeters: - -- 1. Scrutinee (zero based) - -- 2. Targets - ------------------------------------------------------------------------------ --- Operations for broken blocks ------------------------------------------------------------------------------ - --- Naively breaking at *every* CmmCall leads to sub-optimal code. --- In particular, a CmmCall followed by a CmmBranch would result --- in a continuation that has the single CmmBranch statement in it. --- It would be better have the CmmCall directly return to the block --- that the branch jumps to. --- --- This requires the target of the branch to look like the parameter --- format that the CmmCall is expecting. If other CmmCall/CmmBranch --- sequences go to the same place they might not be expecting the --- same format. So this transformation uses the following solution. --- First the blocks are broken up but none of the blocks are marked --- as continuations yet. This is the 'breakBlock' function. --- Second, the blocks "vote" on what other blocks need to be continuations --- and how they should be layed out. Plurality wins, but other selection --- methods could be selected at a later time. --- This is the 'selectContinuations' function. --- Finally, the blocks are upgraded to 'ContEntry' continuations --- based on the results with the 'makeContinuationEntries' function, --- and the blocks that didn't get the format they wanted for their --- targets get a small adaptor block created for them by --- the 'adaptBlockToFormat' function. --- could be - -{- -UNUSED: 2008-12-29 - -breakProc :: - [BlockId] -- ^ Any GC blocks that should be special - -> [[Unique]] -- ^ An infinite list of uniques - -- to create names of the new blocks with - -> CmmInfo -- ^ Info table for the procedure - -> CLabel -- ^ Name of the procedure - -> CmmFormals -- ^ Parameters of the procedure - -> [CmmBasicBlock] -- ^ Blocks of the procecure - -- (First block is the entry block) - -> [BrokenBlock] - -breakProc gc_block_idents uniques info ident params blocks = - let - (adaptor_uniques : block_uniques) = uniques - - broken_blocks :: ([(BlockId, ContFormat)], [BrokenBlock]) - broken_blocks = - let new_blocks = - zipWith3 (breakBlock gc_block_idents) - block_uniques - blocks - (FunctionEntry info ident params : - repeat ControlEntry) - in (concatMap fst new_blocks, concatMap snd new_blocks) - - selected = selectContinuations (fst broken_blocks) - - in map (makeContinuationEntries selected) $ - concat $ - zipWith (adaptBlockToFormat selected) - adaptor_uniques - (snd broken_blocks) --} - ------------------------------------------------------------------------------ --- | Takes a 'CmmBasicBlock' and breaks it up into a list of 'BrokenBlock' --- by splitting on each 'CmmCall' in the 'CmmBasicBlock'. - -breakBlock :: - [BlockId] -- ^ Any GC blocks that should be special - -> [Unique] -- ^ An infinite list of uniques - -- to create names of the new blocks with - -> CmmBasicBlock -- ^ Input block to break apart - -> BlockEntryInfo -- ^ Info for the first created 'BrokenBlock' - -> ([(BlockId, ContFormat)], [BrokenBlock]) -breakBlock gc_block_idents uniques (BasicBlock ident stmts) entry = - breakBlock' uniques ident entry [] [] stmts - where - breakBlock' uniques current_id entry exits accum_stmts stmts = - case stmts of - [] -> panic "block doesn't end in jump, goto, return or switch" - - -- Last statement. Make the 'BrokenBlock' - [CmmJump target arguments] -> - ([], - [BrokenBlock current_id entry accum_stmts - exits - (FinalJump target arguments)]) - [CmmReturn arguments] -> - ([], - [BrokenBlock current_id entry accum_stmts - exits - (FinalReturn arguments)]) - [CmmBranch target] -> - ([], - [BrokenBlock current_id entry accum_stmts - (target:exits) - (FinalBranch target)]) - [CmmSwitch expr targets] -> - ([], - [BrokenBlock current_id entry accum_stmts - (mapMaybe id targets ++ exits) - (FinalSwitch expr targets)]) - - -- These shouldn't happen in the middle of a block. - -- They would cause dead code. - (CmmJump _ _:_) -> panic "jump in middle of block" - (CmmReturn _:_) -> panic "return in middle of block" - (CmmBranch _:_) -> panic "branch in middle of block" - (CmmSwitch _ _:_) -> panic "switch in middle of block" - - -- Detect this special case to remain an inverse of - -- 'cmmBlockFromBrokenBlock' - [CmmCall target results arguments (CmmSafe srt) ret, - CmmBranch next_id] -> - ([cont_info], [block]) - where - cont_info = (next_id, - ContFormat results srt - (ident `elem` gc_block_idents)) - block = do_call current_id entry accum_stmts exits next_id - target results arguments srt ret - - -- Break the block on safe calls (the main job of this function) - (CmmCall target results arguments (CmmSafe srt) ret : stmts) -> - (cont_info : cont_infos, block : blocks) - where - next_id = BlockId $ head uniques - block = do_call current_id entry accum_stmts exits next_id - target results arguments srt ret - - cont_info = (next_id, -- Entry convention for the - -- continuation of the call - ContFormat results srt - (ident `elem` gc_block_idents)) - - -- Break up the part after the call - (cont_infos, blocks) = breakBlock' (tail uniques) next_id - ControlEntry [] [] stmts - - -- Unsafe calls don't need a continuation - -- but they do need to be expanded - (CmmCall target results arguments CmmUnsafe ret : stmts) -> - breakBlock' remaining_uniques current_id entry exits - (accum_stmts ++ - arg_stmts ++ - caller_save ++ - [CmmCall target results new_args CmmUnsafe ret] ++ - caller_load) - stmts - where - (remaining_uniques, arg_stmts, new_args) = - loadArgsIntoTemps uniques arguments - (caller_save, caller_load) = callerSaveVolatileRegs (Just []) - - -- Default case. Just keep accumulating statements - -- and branch targets. - (s : stmts) -> - breakBlock' uniques current_id entry - (cond_branch_target s++exits) - (accum_stmts++[s]) - stmts - - do_call current_id entry accum_stmts exits next_id - target results arguments srt ret = - BrokenBlock current_id entry accum_stmts (next_id:exits) - (FinalCall next_id target results arguments srt ret - (current_id `elem` gc_block_idents)) - - cond_branch_target (CmmCondBranch _ target) = [target] - cond_branch_target _ = [] - ------------------------------------------------------------------------------ - -selectContinuations :: [(BlockId, ContFormat)] -> [(BlockId, ContFormat)] -selectContinuations needed_continuations = formats - where - formats = map select_format format_groups - format_groups = groupBy by_target needed_continuations - by_target x y = fst x == fst y - - select_format formats = winner - where - winner = head $ head $ sortBy more_votes format_votes - format_votes = groupBy by_format formats - by_format x y = snd x == snd y - more_votes x y = compare (length y) (length x) - -- sort so the most votes goes *first* - -- (thus the order of x and y is reversed) - -makeContinuationEntries :: [(BlockId, ContFormat)] - -> BrokenBlock -> BrokenBlock -makeContinuationEntries formats - block@(BrokenBlock ident _entry stmts targets exit) = - case lookup ident formats of - Nothing -> block - Just (ContFormat formals srt is_gc) -> - BrokenBlock ident (ContinuationEntry (map hintlessCmm formals) srt is_gc) - stmts targets exit - -adaptBlockToFormat :: [(BlockId, ContFormat)] - -> Unique - -> BrokenBlock - -> [BrokenBlock] -adaptBlockToFormat formats unique - block@(BrokenBlock ident entry stmts targets - (FinalCall next target formals - actuals srt ret is_gc)) = - if format_formals == formals && - format_srt == srt && - format_is_gc == is_gc - then [block] -- Woohoo! This block got the continuation format it wanted - else [adaptor_block, revised_block] - -- This block didn't get the format it wanted for the - -- continuation, so we have to build an adaptor. - where - (ContFormat format_formals format_srt format_is_gc) = - maybe unknown_block id $ lookup next formats - unknown_block = panic "unknown block in adaptBlockToFormat" - - revised_block = BrokenBlock ident entry stmts revised_targets revised_exit - revised_targets = adaptor_ident : delete next targets - revised_exit = FinalCall - adaptor_ident -- The only part that changed - target formals actuals srt ret is_gc - - adaptor_block = mk_adaptor_block adaptor_ident - (ContinuationEntry (map hintlessCmm formals) srt is_gc) next - adaptor_ident = BlockId unique - - mk_adaptor_block :: BlockId -> BlockEntryInfo -> BlockId -> BrokenBlock - mk_adaptor_block ident entry next = - BrokenBlock ident entry [] [next] exit - where - exit = FinalJump - (CmmLit (CmmLabel (mkReturnPtLabel (getUnique next)))) - (map formal_to_actual format_formals) - - formal_to_actual (CmmHinted reg hint) - = (CmmHinted (CmmReg (CmmLocal reg)) hint) - -- TODO: Check if NoHint is right. We're - -- jumping to a C-- function not a foreign one - -- so it might always be right. -adaptBlockToFormat _ _ block = [block] - ------------------------------------------------------------------------------ --- | Convert from a BrokenBlock back to an equivalent CmmBasicBlock --- Needed by liveness analysis -cmmBlockFromBrokenBlock :: BrokenBlock -> CmmBasicBlock -cmmBlockFromBrokenBlock (BrokenBlock ident _ stmts _ exit) = - BasicBlock ident (stmts++exit_stmt) - where - exit_stmt = - case exit of - FinalBranch target -> [CmmBranch target] - FinalReturn arguments -> [CmmReturn arguments] - FinalJump target arguments -> [CmmJump target arguments] - FinalSwitch expr targets -> [CmmSwitch expr targets] - FinalCall branch_target call_target results arguments srt ret _ -> - [CmmCall call_target results arguments (CmmSafe srt) ret, - CmmBranch branch_target] - ------------------------------------------------------------------------------ --- | Build a mapping so we can lookup a 'BrokenBlock' by its 'BlockId' -blocksToBlockEnv :: [BrokenBlock] -> BlockEnv BrokenBlock -blocksToBlockEnv blocks = mkBlockEnv $ map (\b -> (brokenBlockId b, b)) blocks diff -Nru ghc-7.0.3/compiler/cmm/CmmBuildInfoTables.hs ghc-7.2.1/compiler/cmm/CmmBuildInfoTables.hs --- ghc-7.0.3/compiler/cmm/CmmBuildInfoTables.hs 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/cmm/CmmBuildInfoTables.hs 2011-08-07 17:10:05.000000000 +0000 @@ -1,17 +1,17 @@ -#if __GLASGOW_HASKELL__ >= 611 -{-# OPTIONS_GHC -XNoMonoLocalBinds #-} -#endif +{-# OPTIONS_GHC -XGADTs -XNoMonoLocalBinds #-} -- Norman likes local bindings -- If this module lives on I'd like to get rid of this flag in due course +-- Todo: remove + +{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} module CmmBuildInfoTables - ( CAFSet, CAFEnv, CmmTopForInfoTables(..), cafAnal, localCAFInfo, mkTopCAFInfo + ( CAFSet, CAFEnv, cafAnal, localCAFInfo, mkTopCAFInfo , setInfoTableSRT, setInfoTableStackMap , TopSRT, emptySRT, srtToData , bundleCAFs - , finishInfoTables, lowerSafeForeignCalls - , cafTransfers, liveSlotTransfers - , extendEnvWithSafeForeignCalls, extendEnvsForSafeForeignCalls ) + , lowerSafeForeignCalls + , cafTransfers, liveSlotTransfers) where #include "HsVersions.h" @@ -19,39 +19,34 @@ import Constants import Digraph import qualified Prelude as P -import Prelude +import Prelude hiding (succ) import Util (sortLe) import BlockId import Bitmap import CLabel -import Cmm hiding (blockId) -import CmmInfo -import CmmProcPointZ +import Cmm +import CmmDecl +import CmmExpr import CmmStackLayout -import CmmTx -import DFMonad import Module import FastString import ForeignCall import IdInfo import Data.List import Maybes -import MkZipCfg -import MkZipCfgCmm hiding (CmmAGraph, CmmBlock, CmmTopZ, CmmZ, CmmGraph) +import MkGraph as M import Control.Monad import Name +import OptimizationFuel import Outputable import SMRep import StgCmmClosure import StgCmmForeign --- import StgCmmMonad import StgCmmUtils import UniqSupply -import ZipCfg hiding (zip, unzip, last) -import qualified ZipCfg as G -import ZipCfgCmmRep -import ZipDataflow + +import Compiler.Hoopl import Data.Map (Map) import qualified Data.Map as Map @@ -157,21 +152,17 @@ -- pprPanic "CallAreas must not be live across function calls" (ppr bid <+> ppr c) slots :: SubAreaSet -- The SubAreaSet for 'bid' - slots = expectJust "live_ptrs slots" $ lookupBlockEnv slotEnv bid + slots = expectJust "live_ptrs slots" $ mapLookup bid slotEnv youngByte = expectJust "live_ptrs bid_pos" $ Map.lookup (CallArea (Young bid)) areaMap --- Construct the stack maps for the given procedure. -setInfoTableStackMap :: SlotEnv -> AreaMap -> CmmTopForInfoTables -> CmmTopForInfoTables -setInfoTableStackMap _ _ t@(NoInfoTable _) = t -setInfoTableStackMap slotEnv areaMap t@(FloatingInfoTable _ bid updfr_off) = - updInfo (const (live_ptrs updfr_off slotEnv areaMap bid)) id t +-- Construct the stack maps for a procedure _if_ it needs an infotable. +-- When wouldn't a procedure need an infotable? If it is a procpoint that +-- is not the successor of a call. +setInfoTableStackMap :: SlotEnv -> AreaMap -> CmmTop -> CmmTop setInfoTableStackMap slotEnv areaMap - t@(ProcInfoTable (CmmProc (CmmInfo _ _ _) _ _ ((_, Just updfr_off), _)) procpoints) = - case blockSetToList procpoints of - [bid] -> updInfo (const (live_ptrs updfr_off slotEnv areaMap bid)) id t - _ -> panic "setInfoTableStackMap: unexpected number of procpoints" - -- until we stop splitting the graphs at procpoints in the native path -setInfoTableStackMap _ _ t = pprPanic "unexpected case for setInfoTableStackMap" (ppr t) + t@(CmmProc (TopInfo {stack_info=StackInfo {updfr_space = Just updfr_off}}) _ (CmmGraph {g_entry = eid})) = + updInfo (const (live_ptrs updfr_off slotEnv areaMap eid)) id t +setInfoTableStackMap _ _ t = t @@ -195,17 +186,15 @@ -- First, an analysis to find live CAFs. cafLattice :: DataflowLattice CAFSet -cafLattice = DataflowLattice "live cafs" Map.empty add False - where add new old = if Map.size new' > Map.size old - then aTx new' - else noTx new' - where new' = new `Map.union` old +cafLattice = DataflowLattice "live cafs" Map.empty add + where add _ (OldFact old) (NewFact new) = case old `Map.union` new of + new' -> (changeIf $ Map.size new' > Map.size old, new') -cafTransfers :: BackwardTransfers Middle Last CAFSet -cafTransfers = BackwardTransfers first middle last +cafTransfers :: BwdTransfer CmmNode CAFSet +cafTransfers = mkBTransfer3 first middle last where first _ live = live - middle m live = foldExpDeepMiddle addCaf m live - last l env = foldExpDeepLast addCaf l (joinOuts cafLattice env l) + middle m live = foldExpDeep addCaf m live + last l live = foldExpDeep addCaf l (joinOutFacts cafLattice l live) addCaf e set = case e of CmmLit (CmmLabel c) -> add c set CmmLit (CmmLabelOff c _) -> add c set @@ -213,11 +202,8 @@ _ -> set add l s = if hasCAF l then Map.insert (cvtToClosureLbl l) () s else s -type CafFix a = FuelMonad (BackwardFixedPoint Middle Last CAFSet a) -cafAnal :: LGraph Middle Last -> FuelMonad CAFEnv -cafAnal g = liftM zdfFpFacts (res :: CafFix ()) - where res = zdfSolveFromL emptyBlockEnv "live CAF analysis" cafLattice - cafTransfers (fact_bot cafLattice) g +cafAnal :: CmmGraph -> FuelUniqSM CAFEnv +cafAnal g = liftM snd $ dataflowPassBwd g [] $ analBwd cafLattice cafTransfers ----------------------------------------------------------------------- -- Building the SRTs @@ -251,8 +237,8 @@ , elt_map = Map.insert caf last (elt_map srt) } where last = next_elt srt -srtToData :: TopSRT -> CmmZ -srtToData srt = Cmm [CmmData RelocatableReadOnlyData (CmmDataLabel (lbl srt) : tbl)] +srtToData :: TopSRT -> Cmm +srtToData srt = Cmm [CmmData RelocatableReadOnlyData (Statics (lbl srt) tbl)] where tbl = map (CmmStaticLit . CmmLabel) (reverse (rev_elts srt)) -- Once we have found the CAFs, we need to do two things: @@ -264,7 +250,7 @@ -- we make sure they're all close enough to the bottom of the table that the -- bitmap will be able to cover all of them. buildSRTs :: TopSRT -> Map CLabel CAFSet -> CAFSet -> - FuelMonad (TopSRT, Maybe CmmTopZ, C_SRT) + FuelUniqSM (TopSRT, Maybe CmmTop, C_SRT) buildSRTs topSRT topCAFMap cafs = do let liftCAF lbl () z = -- get CAFs for functions without static closures case Map.lookup lbl topCAFMap of Just cafs -> z `Map.union` cafs @@ -307,7 +293,7 @@ -- Construct an SRT bitmap. -- Adapted from simpleStg/SRT.lhs, which expects Id's. procpointSRT :: CLabel -> Map CLabel Int -> [CLabel] -> - FuelMonad (Maybe CmmTopZ, C_SRT) + FuelUniqSM (Maybe CmmTop, C_SRT) procpointSRT _ _ [] = return (Nothing, NoC_SRT) procpointSRT top_srt top_table entries = @@ -325,13 +311,13 @@ maxBmpSize = widthInBits wordWidth `div` 2 -- Adapted from codeGen/StgCmmUtils, which converts from SRT to C_SRT. -to_SRT :: CLabel -> Int -> Int -> Bitmap -> FuelMonad (Maybe CmmTopZ, C_SRT) +to_SRT :: CLabel -> Int -> Int -> Bitmap -> FuelUniqSM (Maybe CmmTop, C_SRT) to_SRT top_srt off len bmp | len > maxBmpSize || bmp == [fromIntegral srt_escape] = do id <- getUniqueM let srt_desc_lbl = mkLargeSRTLabel id tbl = CmmData RelocatableReadOnlyData $ - CmmDataLabel srt_desc_lbl : map CmmStaticLit + Statics srt_desc_lbl $ map CmmStaticLit ( cmmLabelOffW top_srt off : mkWordCLit (fromIntegral len) : map mkWordCLit bmp) @@ -346,13 +332,13 @@ -- keep its CAFs live.) -- Any procedure referring to a non-static CAF c must keep live -- any CAF that is reachable from c. -localCAFInfo :: CAFEnv -> CmmTopZ -> Maybe (CLabel, CAFSet) +localCAFInfo :: CAFEnv -> CmmTop -> Maybe (CLabel, CAFSet) localCAFInfo _ (CmmData _ _) = Nothing -localCAFInfo cafEnv (CmmProc (CmmInfo _ _ infoTbl) top_l _ (_, LGraph entry _)) = - case infoTbl of - CmmInfoTable False _ _ _ -> +localCAFInfo cafEnv (CmmProc top_info top_l (CmmGraph {g_entry=entry})) = + case info_tbl top_info of + CmmInfoTable _ False _ _ _ -> Just (cvtToClosureLbl top_l, - expectJust "maybeBindCAFs" $ lookupBlockEnv cafEnv entry) + expectJust "maybeBindCAFs" $ mapLookup entry cafEnv) _ -> Nothing -- Once we have the local CAF sets for some (possibly) mutually @@ -385,109 +371,43 @@ type StackLayout = [Maybe LocalReg] -- Bundle the CAFs used at a procpoint. -bundleCAFs :: CAFEnv -> CmmTopForInfoTables -> (CAFSet, CmmTopForInfoTables) -bundleCAFs cafEnv t@(ProcInfoTable _ procpoints) = - case blockSetToList procpoints of - [bid] -> (expectJust "bundleCAFs" (lookupBlockEnv cafEnv bid), t) - _ -> panic "setInfoTableStackMap: unexpect number of procpoints" - -- until we stop splitting the graphs at procpoints in the native path -bundleCAFs cafEnv t@(FloatingInfoTable _ bid _) = - (expectJust "bundleCAFs " (lookupBlockEnv cafEnv bid), t) -bundleCAFs _ t@(NoInfoTable _) = (Map.empty, t) +bundleCAFs :: CAFEnv -> CmmTop -> (CAFSet, CmmTop) +bundleCAFs cafEnv t@(CmmProc _ _ (CmmGraph {g_entry=entry})) = + (expectJust "bundleCAFs" (mapLookup entry cafEnv), t) +bundleCAFs _ t = (Map.empty, t) -- Construct the SRTs for the given procedure. -setInfoTableSRT :: Map CLabel CAFSet -> TopSRT -> (CAFSet, CmmTopForInfoTables) -> - FuelMonad (TopSRT, [CmmTopForInfoTables]) -setInfoTableSRT topCAFMap topSRT (cafs, t@(ProcInfoTable _ procpoints)) = - case blockSetToList procpoints of - [_] -> setSRT cafs topCAFMap topSRT t - _ -> panic "setInfoTableStackMap: unexpect number of procpoints" - -- until we stop splitting the graphs at procpoints in the native path -setInfoTableSRT topCAFMap topSRT (cafs, t@(FloatingInfoTable _ _ _)) = +setInfoTableSRT :: Map CLabel CAFSet -> TopSRT -> (CAFSet, CmmTop) -> + FuelUniqSM (TopSRT, [CmmTop]) +setInfoTableSRT topCAFMap topSRT (cafs, t) = setSRT cafs topCAFMap topSRT t -setInfoTableSRT _ topSRT (_, t@(NoInfoTable _)) = return (topSRT, [t]) setSRT :: CAFSet -> Map CLabel CAFSet -> TopSRT -> - CmmTopForInfoTables -> FuelMonad (TopSRT, [CmmTopForInfoTables]) + CmmTop -> FuelUniqSM (TopSRT, [CmmTop]) setSRT cafs topCAFMap topSRT t = do (topSRT, cafTable, srt) <- buildSRTs topSRT topCAFMap cafs let t' = updInfo id (const srt) t case cafTable of - Just tbl -> return (topSRT, [t', NoInfoTable tbl]) + Just tbl -> return (topSRT, [t', tbl]) Nothing -> return (topSRT, [t']) -updInfo :: (StackLayout -> StackLayout) -> (C_SRT -> C_SRT) -> - CmmTopForInfoTables -> CmmTopForInfoTables -updInfo toVars toSrt (ProcInfoTable (CmmProc info top_l top_args g) procpoints) = - ProcInfoTable (CmmProc (updInfoTbl toVars toSrt info) top_l top_args g) procpoints -updInfo toVars toSrt (FloatingInfoTable info bid updfr_off) = - FloatingInfoTable (updInfoTbl toVars toSrt info) bid updfr_off -updInfo _ _ (NoInfoTable _) = panic "can't update NoInfoTable" -updInfo _ _ _ = panic "unexpected arg to updInfo" - -updInfoTbl :: (StackLayout -> StackLayout) -> (C_SRT -> C_SRT) -> CmmInfo -> CmmInfo -updInfoTbl toVars toSrt (CmmInfo gc upd_fr (CmmInfoTable s p t typeinfo)) - = CmmInfo gc upd_fr (CmmInfoTable s p t typeinfo') +updInfo :: (StackLayout -> StackLayout) -> (C_SRT -> C_SRT) -> CmmTop -> CmmTop +updInfo toVars toSrt (CmmProc top_info top_l g) = + CmmProc (top_info {info_tbl=updInfoTbl toVars toSrt (info_tbl top_info)}) top_l g +updInfo _ _ t = t + +updInfoTbl :: (StackLayout -> StackLayout) -> (C_SRT -> C_SRT) -> CmmInfoTable -> CmmInfoTable +updInfoTbl toVars toSrt (CmmInfoTable l s p t typeinfo) + = CmmInfoTable l s p t typeinfo' where typeinfo' = case typeinfo of t@(ConstrInfo _ _ _) -> t (FunInfo c s a d e) -> FunInfo c (toSrt s) a d e (ThunkInfo c s) -> ThunkInfo c (toSrt s) (ThunkSelectorInfo x s) -> ThunkSelectorInfo x (toSrt s) (ContInfo v s) -> ContInfo (toVars v) (toSrt s) -updInfoTbl _ _ t@(CmmInfo _ _ CmmNonInfoTable) = t +updInfoTbl _ _ t@CmmNonInfoTable = t --- Lower the CmmTopForInfoTables type down to good old CmmTopZ --- by emitting info tables as data where necessary. -finishInfoTables :: CmmTopForInfoTables -> IO [CmmTopZ] -finishInfoTables (NoInfoTable t) = return [t] -finishInfoTables (ProcInfoTable p _) = return [p] -finishInfoTables (FloatingInfoTable (CmmInfo _ _ infotbl) bid _) = - do uniq_supply <- mkSplitUniqSupply 'i' - return $ mkBareInfoTable (retPtLbl bid) (uniqFromSupply uniq_supply) infotbl - ---------------------------------------------------------------- --- Safe foreign calls: --- Our analyses capture the dataflow facts at block boundaries, but we need --- to extend the CAF and live-slot analyses to safe foreign calls as well, --- which show up as middle nodes. -extendEnvWithSafeForeignCalls :: - BackwardTransfers Middle Last a -> BlockEnv a -> CmmGraph -> BlockEnv a -extendEnvWithSafeForeignCalls transfers env g = fold_blocks block env g - where block b z = - tail (bt_last_in transfers l (lookup env)) z head - where (head, last) = goto_end (G.unzip b) - l = case last of LastOther l -> l - LastExit -> panic "extendEnvs lastExit" - tail _ z (ZFirst _) = z - tail fact env (ZHead h m@(MidForeignCall (Safe bid _) _ _ _)) = - tail (mid m fact) (extendBlockEnv env bid fact) h - tail fact env (ZHead h m) = tail (mid m fact) env h - lookup map k = expectJust "extendEnvWithSafeFCalls" $ lookupBlockEnv map k - mid = bt_middle_in transfers - - -extendEnvsForSafeForeignCalls :: CAFEnv -> SlotEnv -> CmmGraph -> (CAFEnv, SlotEnv) -extendEnvsForSafeForeignCalls cafEnv slotEnv g = - fold_blocks block (cafEnv, slotEnv) g - where block b z = - tail ( bt_last_in cafTransfers l (lookupFn cafEnv) - , bt_last_in liveSlotTransfers l (lookupFn slotEnv)) - z head - where (head, last) = goto_end (G.unzip b) - l = case last of LastOther l -> l - LastExit -> panic "extendEnvs lastExit" - tail _ z (ZFirst _) = z - tail lives@(cafs, slots) (cafEnv, slotEnv) - (ZHead h m@(MidForeignCall (Safe bid _) _ _ _)) = - let slots' = removeLiveSlotDefs slots m - slotEnv' = extendBlockEnv slotEnv bid slots' - cafEnv' = extendBlockEnv cafEnv bid cafs - in tail (upd lives m) (cafEnv', slotEnv') h - tail lives z (ZHead h m) = tail (upd lives m) z h - lookupFn map k = expectJust "extendEnvsForSafeFCalls" $ lookupBlockEnv map k - upd (cafs, slots) m = - (bt_middle_in cafTransfers m cafs, bt_middle_in liveSlotTransfers m slots) - -- Safe foreign calls: We need to insert the code that suspends and resumes -- the thread before and after a safe foreign call. -- Why do we do this so late in the pipeline? @@ -504,95 +424,72 @@ -- a procpoint. The following datatype captures the information -- needed to generate the infotables along with the Cmm data and procedures. -data CmmTopForInfoTables - = NoInfoTable CmmTopZ -- must be CmmData - | ProcInfoTable CmmTopZ BlockSet -- CmmProc; argument is its set of procpoints - | FloatingInfoTable CmmInfo BlockId UpdFrameOffset -instance Outputable CmmTopForInfoTables where - ppr (NoInfoTable t) = text "NoInfoTable: " <+> ppr t - ppr (ProcInfoTable t bids) = text "ProcInfoTable: " <+> ppr t <+> ppr bids - ppr (FloatingInfoTable info bid upd) = - text "FloatingInfoTable: " <+> ppr info <+> ppr bid <+> ppr upd - --- The `safeState' record collects the info we update while lowering the --- safe foreign calls in the graph. -data SafeState = State { s_blocks :: BlockEnv CmmBlock - , s_pps :: ProcPointSet - , s_safeCalls :: [CmmTopForInfoTables]} - -lowerSafeForeignCalls - :: [[CmmTopForInfoTables]] -> CmmTopZ -> FuelMonad [[CmmTopForInfoTables]] -lowerSafeForeignCalls rst t@(CmmData _ _) = return $ [NoInfoTable t] : rst -lowerSafeForeignCalls rst (CmmProc info l args (off, g@(LGraph entry _))) = do - let init = return $ State emptyBlockEnv emptyBlockSet [] - let block b@(Block bid _) z = do - state@(State {s_pps = ppset, s_blocks = blocks}) <- z - let ppset' = if bid == entry then extendBlockSet ppset bid else ppset - state' = state { s_pps = ppset' } - if hasSafeForeignCall b - then lowerSafeCallBlock state' b - else return (state' { s_blocks = insertBlock b blocks }) - State blocks' g_procpoints safeCalls <- fold_blocks block init g - let proc = (CmmProc info l args (off, LGraph entry blocks')) - procTable = case off of - (_, Just _) -> [ProcInfoTable proc g_procpoints] - _ -> [NoInfoTable proc] -- not a successor of a call - return $ safeCalls : procTable : rst - --- Check for foreign calls -- if none, then we can avoid copying the block. -hasSafeForeignCall :: CmmBlock -> Bool -hasSafeForeignCall (Block _ t) = tail t - where tail (ZTail (MidForeignCall (Safe _ _) _ _ _) _) = True - tail (ZTail _ t) = tail t - tail (ZLast _) = False - --- Lower each safe call in the block, update the CAF and slot environments --- to include each of those calls, and insert the new block in the blockEnv. -lowerSafeCallBlock :: SafeState-> CmmBlock -> FuelMonad SafeState -lowerSafeCallBlock state b = tail (return state) (ZBlock head (ZLast last)) - where (head, last) = goto_end (G.unzip b) - tail s b@(ZBlock (ZFirst _) _) = - do state <- s - return $ state { s_blocks = insertBlock (G.zip b) (s_blocks state) } - tail s (ZBlock (ZHead h m@(MidForeignCall (Safe bid updfr_off) _ _ _)) t) = - do state <- s - let state' = state - { s_safeCalls = FloatingInfoTable emptyContInfoTable bid updfr_off : - s_safeCalls state } - (state'', t') <- lowerSafeForeignCall state' m t - tail (return state'') (ZBlock h t') - tail s (ZBlock (ZHead h m) t) = tail s (ZBlock h (ZTail m t)) - +-- JD: Why not do this while splitting procedures? +lowerSafeForeignCalls :: AreaMap -> CmmTop -> FuelUniqSM CmmTop +lowerSafeForeignCalls _ t@(CmmData _ _) = return t +lowerSafeForeignCalls areaMap (CmmProc info l g@(CmmGraph {g_entry=entry})) = do + let block b mblocks = mblocks >>= lowerSafeCallBlock entry areaMap b + blocks <- foldGraphBlocks block (return mapEmpty) g + return $ CmmProc info l (ofBlockMap entry blocks) + +-- If the block ends with a safe call in the block, lower it to an unsafe +-- call (with appropriate saves and restores before and after). +lowerSafeCallBlock :: BlockId -> AreaMap -> CmmBlock -> BlockEnv CmmBlock + -> FuelUniqSM (BlockEnv CmmBlock) +lowerSafeCallBlock entry areaMap b blocks = + case blockToNodeList b of + (JustC (CmmEntry id), m, JustC l@(CmmForeignCall {})) -> lowerSafeForeignCall entry areaMap blocks id m l + _ -> return $ insertBlock b blocks -- Late in the code generator, we want to insert the code necessary -- to lower a safe foreign call to a sequence of unsafe calls. -lowerSafeForeignCall :: - SafeState -> Middle -> ZTail Middle Last -> FuelMonad (SafeState, ZTail Middle Last) -lowerSafeForeignCall state m@(MidForeignCall (Safe infotable _) _ _ _) tail = do - let newTemp rep = getUniqueM >>= \u -> return (LocalReg u rep) +lowerSafeForeignCall :: BlockId -> AreaMap -> BlockEnv CmmBlock -> BlockId -> [CmmNode O O] -> CmmNode O C + -> FuelUniqSM (BlockEnv CmmBlock) +lowerSafeForeignCall entry areaMap blocks bid m + (CmmForeignCall {tgt=tgt, res=rs, args=as, succ=succ, updfr = updfr_off, intrbl = intrbl}) = + do let newTemp rep = getUniqueM >>= \u -> return (LocalReg u rep) -- Both 'id' and 'new_base' are KindNonPtr because they're -- RTS-only objects and are not subject to garbage collection id <- newTemp bWord new_base <- newTemp (cmmRegType (CmmGlobal BaseReg)) - let (caller_save, caller_load) = callerSaveVolatileRegs + let (caller_save, caller_load) = callerSaveVolatileRegs load_tso <- newTemp gcWord -- TODO FIXME NOW - let suspendThread = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "suspendThread"))) - resumeThread = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "resumeThread"))) - suspend = mkStore (CmmReg spReg) (CmmLit (CmmBlock infotable)) <*> - saveThreadState <*> - caller_save <*> + load_stack <- newTemp gcWord -- TODO FIXME NOW + let (<**>) = (M.<*>) + let suspendThread = foreignLbl "suspendThread" + resumeThread = foreignLbl "resumeThread" + foreignLbl name = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit name))) + suspend = saveThreadState <**> + caller_save <**> mkUnsafeCall (ForeignTarget suspendThread - (ForeignConvention CCallConv [AddrHint] [AddrHint])) - [id] [CmmReg (CmmGlobal BaseReg)] - resume = mkUnsafeCall (ForeignTarget resumeThread - (ForeignConvention CCallConv [AddrHint] [AddrHint])) - [new_base] [CmmReg (CmmLocal id)] <*> - -- Assign the result to BaseReg: we - -- might now have a different Capability! - mkAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base)) <*> - caller_load <*> - loadThreadState load_tso - Graph tail' blocks' <- - liftUniq (graphOfAGraph (suspend <*> mkMiddle m <*> resume <*> mkZTail tail)) - return (state {s_blocks = s_blocks state `plusBlockEnv` blocks'}, tail') -lowerSafeForeignCall _ _ _ = panic "lowerSafeForeignCall was passed something else" + (ForeignConvention CCallConv [AddrHint, NoHint] [AddrHint])) + [id] [CmmReg (CmmGlobal BaseReg), CmmLit (CmmInt (fromIntegral (fromEnum intrbl)) wordWidth)] + midCall = mkUnsafeCall tgt rs as + resume = mkUnsafeCall (ForeignTarget resumeThread + (ForeignConvention CCallConv [AddrHint] [AddrHint])) + [new_base] [CmmReg (CmmLocal id)] <**> + -- Assign the result to BaseReg: we + -- might now have a different Capability! + mkAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base)) <**> + caller_load <**> + loadThreadState load_tso load_stack + -- We have to save the return value on the stack because its next use + -- may appear in a different procedure due to procpoint splitting... + saveRetVals = foldl (<**>) emptyAGraph $ map (M.mkMiddle . spill) rs + spill r = CmmStore (regSlot r) (CmmReg $ CmmLocal r) + regSlot r@(LocalReg _ _) = CmmRegOff (CmmGlobal Sp) (sp_off - offset) + where offset = w + expectJust "lowerForeign" (Map.lookup (RegSlot r) areaMap) + sp_off = wORD_SIZE + expectJust "lowerForeign" (Map.lookup (CallArea area) areaMap) + area = if succ == entry then Old else Young succ + w = widthInBytes $ typeWidth $ localRegType r + -- Note: The successor must be a procpoint, and we have already split, + -- so we use a jump, not a branch. + succLbl = CmmLit (CmmLabel (infoTblLbl succ)) + jump = CmmCall { cml_target = succLbl, cml_cont = Nothing + , cml_args = widthInBytes wordWidth ,cml_ret_args = 0 + , cml_ret_off = updfr_off} + graph' <- liftUniq $ labelAGraph bid $ catAGraphs (map M.mkMiddle m) <**> + suspend <**> midCall <**> + resume <**> saveRetVals <**> M.mkLast jump + return $ blocks `mapUnion` toBlockMap graph' +lowerSafeForeignCall _ _ _ _ _ _ = panic "lowerSafeForeignCall was passed something else" diff -Nru ghc-7.0.3/compiler/cmm/CmmCallConv.hs ghc-7.2.1/compiler/cmm/CmmCallConv.hs --- ghc-7.0.3/compiler/cmm/CmmCallConv.hs 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/cmm/CmmCallConv.hs 2011-08-07 17:10:05.000000000 +0000 @@ -1,16 +1,14 @@ module CmmCallConv ( ParamLocation(..), - ArgumentFormat, - assignArguments, - assignArgumentsPos, - argumentsSize, + assignArgumentsPos ) where #include "HsVersions.h" -import Cmm +import CmmExpr import SMRep -import ZipCfgCmmRep (Convention(..)) +import Cmm (Convention(..)) +import PprCmm () import Constants import qualified Data.List as L @@ -20,25 +18,21 @@ -- Calculate the 'GlobalReg' or stack locations for function call -- parameters as used by the Cmm calling convention. -data ParamLocation a +data ParamLocation = RegisterParam GlobalReg - | StackParam a + | StackParam ByteOff -instance (Outputable a) => Outputable (ParamLocation a) where +instance Outputable ParamLocation where ppr (RegisterParam g) = ppr g ppr (StackParam p) = ppr p -type ArgumentFormat a b = [(a, ParamLocation b)] - --- Stack parameters are returned as word offsets. -assignArguments :: (a -> CmmType) -> [a] -> ArgumentFormat a WordOff -assignArguments _ _ = panic "assignArguments only used in dead codegen" -- assignments - -- | JD: For the new stack story, I want arguments passed on the stack to manifest as -- positive offsets in a CallArea, not negative offsets from the stack pointer. -- Also, I want byte offsets, not word offsets. -assignArgumentsPos :: (Outputable a) => Convention -> (a -> CmmType) -> [a] -> - ArgumentFormat a ByteOff +assignArgumentsPos :: Convention -> (a -> CmmType) -> [a] -> + [(a, ParamLocation)] +-- Given a list of arguments, and a function that tells their types, +-- return a list showing where each argument is passed assignArgumentsPos conv arg_ty reps = assignments where -- The calling conventions (CgCallConv.hs) are complicated, to say the least regs = case (reps, conv) of @@ -46,7 +40,8 @@ (_, NativeDirectCall) -> getRegsWithoutNode ([_], NativeReturn) -> allRegs (_, NativeReturn) -> getRegsWithNode - (_, GC) -> getRegsWithNode + -- GC calling convention *must* put values in registers + (_, GC) -> allRegs (_, PrimOpCall) -> allRegs ([_], PrimOpReturn) -> allRegs (_, PrimOpReturn) -> getRegsWithNode @@ -60,6 +55,7 @@ (reg_assts, stk_args) = assign_regs [] reps regs stk_args' = case conv of NativeReturn -> part PrimOpReturn -> part + GC | length stk_args /= 0 -> panic "Failed to allocate registers for GC call" _ -> stk_args where part = uncurry (++) (L.partition (not . isGcPtrType . arg_ty) stk_args) @@ -91,14 +87,6 @@ where w = typeWidth (arg_ty r) size = (((widthInBytes w - 1) `div` wORD_SIZE) + 1) * wORD_SIZE off' = offset + size - - -argumentsSize :: (a -> CmmType) -> [a] -> WordOff -argumentsSize f reps = maximum (0 : map arg_top args) - where - args = assignArguments f reps - arg_top (_, StackParam offset) = -offset - arg_top (_, RegisterParam _) = 0 ----------------------------------------------------------------------------- -- Local information about the registers available diff -Nru ghc-7.0.3/compiler/cmm/CmmCommonBlockElim.hs ghc-7.2.1/compiler/cmm/CmmCommonBlockElim.hs --- ghc-7.0.3/compiler/cmm/CmmCommonBlockElim.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/compiler/cmm/CmmCommonBlockElim.hs 2011-08-07 17:10:05.000000000 +0000 @@ -0,0 +1,174 @@ +{-# LANGUAGE GADTs #-} +{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} +-- ToDo: remove +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} + +module CmmCommonBlockElim + ( elimCommonBlocks + ) +where + + +import BlockId +import Cmm +import CmmExpr +import Prelude hiding (iterate, succ, unzip, zip) + +import Compiler.Hoopl +import Data.Bits +import qualified Data.List as List +import Data.Word +import FastString +import Control.Monad +import Outputable +import UniqFM +import Unique + +my_trace :: String -> SDoc -> a -> a +my_trace = if False then pprTrace else \_ _ a -> a + +-- Eliminate common blocks: +-- If two blocks are identical except for the label on the first node, +-- then we can eliminate one of the blocks. To ensure that the semantics +-- of the program are preserved, we have to rewrite each predecessor of the +-- eliminated block to proceed with the block we keep. + +-- The algorithm iterates over the blocks in the graph, +-- checking whether it has seen another block that is equal modulo labels. +-- If so, then it adds an entry in a map indicating that the new block +-- is made redundant by the old block. +-- Otherwise, it is added to the useful blocks. + +-- TODO: Use optimization fuel +elimCommonBlocks :: CmmGraph -> CmmGraph +elimCommonBlocks g = + upd_graph g . snd $ iterate common_block reset hashed_blocks + (emptyUFM, mapEmpty) + where hashed_blocks = map (\b -> (hash_block b, b)) (reverse (postorderDfs g)) + reset (_, subst) = (emptyUFM, subst) + +-- Iterate over the blocks until convergence +iterate :: (t -> a -> (Bool, t)) -> (t -> t) -> [a] -> t -> t +iterate upd reset blocks state = + case foldl upd' (False, state) blocks of + (True, state') -> iterate upd reset blocks (reset state') + (False, state') -> state' + where upd' (b, s) a = let (b', s') = upd s a in (b || b', s') -- lift to track changes + +-- Try to find a block that is equal (or ``common'') to b. +type BidMap = BlockEnv BlockId +type State = (UniqFM [CmmBlock], BidMap) +common_block :: (Outputable h, Uniquable h) => State -> (h, CmmBlock) -> (Bool, State) +common_block (bmap, subst) (hash, b) = + case lookupUFM bmap hash of + Just bs -> case (List.find (eqBlockBodyWith (eqBid subst) b) bs, + mapLookup bid subst) of + (Just b', Nothing) -> addSubst b' + (Just b', Just b'') | entryLabel b' /= b'' -> addSubst b' + _ -> (False, (addToUFM bmap hash (b : bs), subst)) + Nothing -> (False, (addToUFM bmap hash [b], subst)) + where bid = entryLabel b + addSubst b' = my_trace "found new common block" (ppr (entryLabel b')) $ + (True, (bmap, mapInsert bid (entryLabel b') subst)) + +-- Given the map ``subst'' from BlockId -> BlockId, we rewrite the graph. +upd_graph :: CmmGraph -> BidMap -> CmmGraph +upd_graph g subst = mapGraphNodes (id, middle, last) g + where middle = mapExpDeep exp + last l = last' (mapExpDeep exp l) + last' :: CmmNode O C -> CmmNode O C + last' (CmmBranch bid) = CmmBranch $ sub bid + last' (CmmCondBranch p t f) = cond p (sub t) (sub f) + last' (CmmCall t (Just bid) a r o) = CmmCall t (Just $ sub bid) a r o + last' l@(CmmCall _ Nothing _ _ _) = l + last' (CmmForeignCall t r a bid u i) = CmmForeignCall t r a (sub bid) u i + last' (CmmSwitch e bs) = CmmSwitch e $ map (liftM sub) bs + cond p t f = if t == f then CmmBranch t else CmmCondBranch p t f + exp (CmmStackSlot (CallArea (Young id)) off) = + CmmStackSlot (CallArea (Young (sub id))) off + exp (CmmLit (CmmBlock id)) = CmmLit (CmmBlock (sub id)) + exp e = e + sub = lookupBid subst + +-- To speed up comparisons, we hash each basic block modulo labels. +-- The hashing is a bit arbitrary (the numbers are completely arbitrary), +-- but it should be fast and good enough. +hash_block :: CmmBlock -> Int +hash_block block = + fromIntegral (foldBlockNodesB3 (hash_fst, hash_mid, hash_lst) block (0 :: Word32) .&. (0x7fffffff :: Word32)) + -- UniqFM doesn't like negative Ints + where hash_fst _ h = h + hash_mid m h = hash_node m + h `shiftL` 1 + hash_lst m h = hash_node m + h `shiftL` 1 + + hash_node :: CmmNode O x -> Word32 + hash_node (CmmComment (FastString u _ _ _ _)) = cvt u + hash_node (CmmAssign r e) = hash_reg r + hash_e e + hash_node (CmmStore e e') = hash_e e + hash_e e' + hash_node (CmmUnsafeForeignCall t _ as) = hash_tgt t + hash_list hash_e as + hash_node (CmmBranch _) = 23 -- would be great to hash these properly + hash_node (CmmCondBranch p _ _) = hash_e p + hash_node (CmmCall e _ _ _ _) = hash_e e + hash_node (CmmForeignCall t _ _ _ _ _) = hash_tgt t + hash_node (CmmSwitch e _) = hash_e e + + hash_reg :: CmmReg -> Word32 + hash_reg (CmmLocal _) = 117 + hash_reg (CmmGlobal _) = 19 + + hash_e :: CmmExpr -> Word32 + hash_e (CmmLit l) = hash_lit l + hash_e (CmmLoad e _) = 67 + hash_e e + hash_e (CmmReg r) = hash_reg r + hash_e (CmmMachOp _ es) = hash_list hash_e es -- pessimal - no operator check + hash_e (CmmRegOff r i) = hash_reg r + cvt i + hash_e (CmmStackSlot _ _) = 13 + + hash_lit :: CmmLit -> Word32 + hash_lit (CmmInt i _) = fromInteger i + hash_lit (CmmFloat r _) = truncate r + hash_lit (CmmLabel _) = 119 -- ugh + hash_lit (CmmLabelOff _ i) = cvt $ 199 + i + hash_lit (CmmLabelDiffOff _ _ i) = cvt $ 299 + i + hash_lit (CmmBlock _) = 191 -- ugh + hash_lit (CmmHighStackMark) = cvt 313 + + hash_tgt (ForeignTarget e _) = hash_e e + hash_tgt (PrimTarget _) = 31 -- lots of these + + hash_list f = foldl (\z x -> f x + z) (0::Word32) + + cvt = fromInteger . toInteger +-- Utilities: equality and substitution on the graph. + +-- Given a map ``subst'' from BlockID -> BlockID, we define equality. +eqBid :: BidMap -> BlockId -> BlockId -> Bool +eqBid subst bid bid' = lookupBid subst bid == lookupBid subst bid' +lookupBid :: BidMap -> BlockId -> BlockId +lookupBid subst bid = case mapLookup bid subst of + Just bid -> lookupBid subst bid + Nothing -> bid + +-- Equality on the body of a block, modulo a function mapping block IDs to block IDs. +eqBlockBodyWith :: (BlockId -> BlockId -> Bool) -> CmmBlock -> CmmBlock -> Bool +eqBlockBodyWith eqBid block block' = middles == middles' && eqLastWith eqBid last last' + where (_, middles , JustC last :: MaybeC C (CmmNode O C)) = blockToNodeList block + (_, middles', JustC last' :: MaybeC C (CmmNode O C)) = blockToNodeList block' + +eqLastWith :: (BlockId -> BlockId -> Bool) -> CmmNode O C -> CmmNode O C -> Bool +eqLastWith eqBid (CmmBranch bid1) (CmmBranch bid2) = eqBid bid1 bid2 +eqLastWith eqBid (CmmCondBranch c1 t1 f1) (CmmCondBranch c2 t2 f2) = + c1 == c2 && eqBid t1 t2 && eqBid f1 f2 +eqLastWith eqBid (CmmCall t1 c1 a1 r1 u1) (CmmCall t2 c2 a2 r2 u2) = + t1 == t2 && eqMaybeWith eqBid c1 c2 && a1 == a2 && r1 == r2 && u1 == u2 +eqLastWith eqBid (CmmSwitch e1 bs1) (CmmSwitch e2 bs2) = + e1 == e2 && eqListWith (eqMaybeWith eqBid) bs1 bs2 +eqLastWith _ _ _ = False + +eqListWith :: (a -> b -> Bool) -> [a] -> [b] -> Bool +eqListWith eltEq es es' = all (uncurry eltEq) (List.zip es es') + +eqMaybeWith :: (a -> b -> Bool) -> Maybe a -> Maybe b -> Bool +eqMaybeWith eltEq (Just e) (Just e') = eltEq e e' +eqMaybeWith _ Nothing Nothing = True +eqMaybeWith _ _ _ = False diff -Nru ghc-7.0.3/compiler/cmm/CmmCommonBlockElimZ.hs ghc-7.2.1/compiler/cmm/CmmCommonBlockElimZ.hs --- ghc-7.0.3/compiler/cmm/CmmCommonBlockElimZ.hs 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/cmm/CmmCommonBlockElimZ.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,164 +0,0 @@ -module CmmCommonBlockElimZ - ( elimCommonBlocks - ) -where - - -import BlockId -import CmmExpr -import Prelude hiding (iterate, zip, unzip) -import ZipCfg -import ZipCfgCmmRep - -import Data.Bits -import qualified Data.List as List -import Data.Word -import FastString -import Control.Monad -import Outputable -import UniqFM -import Unique - -my_trace :: String -> SDoc -> a -> a -my_trace = if False then pprTrace else \_ _ a -> a - --- Eliminate common blocks: --- If two blocks are identical except for the label on the first node, --- then we can eliminate one of the blocks. To ensure that the semantics --- of the program are preserved, we have to rewrite each predecessor of the --- eliminated block to proceed with the block we keep. - --- The algorithm iterates over the blocks in the graph, --- checking whether it has seen another block that is equal modulo labels. --- If so, then it adds an entry in a map indicating that the new block --- is made redundant by the old block. --- Otherwise, it is added to the useful blocks. - --- TODO: Use optimization fuel -elimCommonBlocks :: CmmGraph -> CmmGraph -elimCommonBlocks g = - upd_graph g . snd $ iterate common_block reset hashed_blocks - (emptyUFM, emptyBlockEnv) - where hashed_blocks = map (\b -> (hash_block b, b)) (reverse (postorder_dfs g)) - reset (_, subst) = (emptyUFM, subst) - --- Iterate over the blocks until convergence -iterate :: (t -> a -> (Bool, t)) -> (t -> t) -> [a] -> t -> t -iterate upd reset blocks state = - case foldl upd' (False, state) blocks of - (True, state') -> iterate upd reset blocks (reset state') - (False, state') -> state' - where upd' (b, s) a = let (b', s') = upd s a in (b || b', s') -- lift to track changes - --- Try to find a block that is equal (or ``common'') to b. -type BidMap = BlockEnv BlockId -type State = (UniqFM [CmmBlock], BidMap) -common_block :: (Outputable h, Uniquable h) => State -> (h, CmmBlock) -> (Bool, State) -common_block (bmap, subst) (hash, b) = - case lookupUFM bmap hash of - Just bs -> case (List.find (eqBlockBodyWith (eqBid subst) b) bs, - lookupBlockEnv subst bid) of - (Just b', Nothing) -> addSubst b' - (Just b', Just b'') | blockId b' /= b'' -> addSubst b' - _ -> (False, (addToUFM bmap hash (b : bs), subst)) - Nothing -> (False, (addToUFM bmap hash [b], subst)) - where bid = blockId b - addSubst b' = my_trace "found new common block" (ppr (blockId b')) $ - (True, (bmap, extendBlockEnv subst bid (blockId b'))) - --- Given the map ``subst'' from BlockId -> BlockId, we rewrite the graph. -upd_graph :: CmmGraph -> BidMap -> CmmGraph -upd_graph g subst = map_nodes id middle last g - where middle = mapExpDeepMiddle exp - last l = last' (mapExpDeepLast exp l) - last' (LastBranch bid) = LastBranch $ sub bid - last' (LastCondBranch p t f) = cond p (sub t) (sub f) - last' (LastCall t (Just bid) args res u) = LastCall t (Just $ sub bid) args res u - last' l@(LastCall _ Nothing _ _ _) = l - last' (LastSwitch e bs) = LastSwitch e $ map (liftM sub) bs - cond p t f = if t == f then LastBranch t else LastCondBranch p t f - exp (CmmStackSlot (CallArea (Young id)) off) = - CmmStackSlot (CallArea (Young (sub id))) off - exp (CmmLit (CmmBlock id)) = CmmLit (CmmBlock (sub id)) - exp e = e - sub = lookupBid subst - --- To speed up comparisons, we hash each basic block modulo labels. --- The hashing is a bit arbitrary (the numbers are completely arbitrary), --- but it should be fast and good enough. -hash_block :: CmmBlock -> Int -hash_block (Block _ t) = - fromIntegral (hash_tail t (0 :: Word32) .&. (0x7fffffff :: Word32)) - -- UniqFM doesn't like negative Ints - where hash_mid (MidComment (FastString u _ _ _ _)) = cvt u - hash_mid (MidAssign r e) = hash_reg r + hash_e e - hash_mid (MidStore e e') = hash_e e + hash_e e' - hash_mid (MidForeignCall _ t _ as) = hash_tgt t + hash_lst hash_e as - hash_reg :: CmmReg -> Word32 - hash_reg (CmmLocal l) = hash_local l - hash_reg (CmmGlobal _) = 19 - hash_local (LocalReg _ _) = 117 - hash_e :: CmmExpr -> Word32 - hash_e (CmmLit l) = hash_lit l - hash_e (CmmLoad e _) = 67 + hash_e e - hash_e (CmmReg r) = hash_reg r - hash_e (CmmMachOp _ es) = hash_lst hash_e es -- pessimal - no operator check - hash_e (CmmRegOff r i) = hash_reg r + cvt i - hash_e (CmmStackSlot _ _) = 13 - hash_lit :: CmmLit -> Word32 - hash_lit (CmmInt i _) = fromInteger i - hash_lit (CmmFloat r _) = truncate r - hash_lit (CmmLabel _) = 119 -- ugh - hash_lit (CmmLabelOff _ i) = cvt $ 199 + i - hash_lit (CmmLabelDiffOff _ _ i) = cvt $ 299 + i - hash_lit (CmmBlock _) = 191 -- ugh - hash_lit (CmmHighStackMark) = cvt 313 - hash_tgt (ForeignTarget e _) = hash_e e - hash_tgt (PrimTarget _) = 31 -- lots of these - hash_lst f = foldl (\z x -> f x + z) (0::Word32) - hash_last (LastBranch _) = 23 -- would be great to hash these properly - hash_last (LastCondBranch p _ _) = hash_e p - hash_last (LastCall e _ _ _ _) = hash_e e - hash_last (LastSwitch e _) = hash_e e - hash_tail (ZLast LastExit) v = 29 + v `shiftL` 1 - hash_tail (ZLast (LastOther l)) v = hash_last l + (v `shiftL` 1) - hash_tail (ZTail m t) v = hash_tail t (hash_mid m + (v `shiftL` 1)) - cvt = fromInteger . toInteger --- Utilities: equality and substitution on the graph. - --- Given a map ``subst'' from BlockID -> BlockID, we define equality. -eqBid :: BidMap -> BlockId -> BlockId -> Bool -eqBid subst bid bid' = lookupBid subst bid == lookupBid subst bid' -lookupBid :: BidMap -> BlockId -> BlockId -lookupBid subst bid = case lookupBlockEnv subst bid of - Just bid -> lookupBid subst bid - Nothing -> bid - --- Equality on the body of a block, modulo a function mapping block IDs to block IDs. -eqBlockBodyWith :: (BlockId -> BlockId -> Bool) -> CmmBlock -> CmmBlock -> Bool -eqBlockBodyWith eqBid (Block _ t) (Block _ t') = eqTailWith eqBid t t' - -type CmmTail = ZTail Middle Last -eqTailWith :: (BlockId -> BlockId -> Bool) -> CmmTail -> CmmTail -> Bool -eqTailWith eqBid (ZTail m t) (ZTail m' t') = m == m' && eqTailWith eqBid t t' -eqTailWith _ (ZLast LastExit) (ZLast LastExit) = True -eqTailWith eqBid (ZLast (LastOther l)) (ZLast (LastOther l')) = eqLastWith eqBid l l' -eqTailWith _ _ _ = False - -eqLastWith :: (BlockId -> BlockId -> Bool) -> Last -> Last -> Bool -eqLastWith eqBid (LastBranch bid1) (LastBranch bid2) = eqBid bid1 bid2 -eqLastWith eqBid (LastCondBranch c1 t1 f1) (LastCondBranch c2 t2 f2) = - c1 == c2 && eqBid t1 t2 && eqBid f1 f2 -eqLastWith eqBid (LastCall t1 c1 a1 r1 u1) (LastCall t2 c2 a2 r2 u2) = - t1 == t2 && eqMaybeWith eqBid c1 c2 && a1 == a2 && r1 == r2 && u1 == u2 -eqLastWith eqBid (LastSwitch e1 bs1) (LastSwitch e2 bs2) = - e1 == e2 && eqLstWith (eqMaybeWith eqBid) bs1 bs2 -eqLastWith _ _ _ = False - -eqLstWith :: (a -> b -> Bool) -> [a] -> [b] -> Bool -eqLstWith eltEq es es' = all (uncurry eltEq) (List.zip es es') - -eqMaybeWith :: (a -> b -> Bool) -> Maybe a -> Maybe b -> Bool -eqMaybeWith eltEq (Just e) (Just e') = eltEq e e' -eqMaybeWith _ Nothing Nothing = True -eqMaybeWith _ _ _ = False diff -Nru ghc-7.0.3/compiler/cmm/CmmContFlowOpt.hs ghc-7.2.1/compiler/cmm/CmmContFlowOpt.hs --- ghc-7.0.3/compiler/cmm/CmmContFlowOpt.hs 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/cmm/CmmContFlowOpt.hs 2011-08-07 17:10:05.000000000 +0000 @@ -1,88 +1,84 @@ +{-# LANGUAGE GADTs #-} +{-# OPTIONS_GHC -fno-warn-warnings-deprecations -fno-warn-incomplete-patterns #-} module CmmContFlowOpt - ( runCmmOpts, cmmCfgOpts, cmmCfgOptsZ - , branchChainElimZ, removeUnreachableBlocksZ, predMap - , replaceLabelsZ, replaceBranches, runCmmContFlowOptsZs + ( runCmmOpts, oldCmmCfgOpts, cmmCfgOpts + , branchChainElim, removeUnreachableBlocks, predMap + , replaceLabels, replaceBranches, runCmmContFlowOpts ) where import BlockId import Cmm -import CmmTx -import qualified ZipCfg as G -import ZipCfg -import ZipCfgCmmRep +import CmmDecl +import CmmExpr +import qualified OldCmm as Old import Maybes +import Compiler.Hoopl import Control.Monad import Outputable -import Prelude hiding (unzip, zip) +import Prelude hiding (succ, unzip, zip) import Util ------------------------------------ -runCmmContFlowOptsZs :: [CmmZ] -> [CmmZ] -runCmmContFlowOptsZs prog - = [ runTx (runCmmOpts cmmCfgOptsZ) cmm_top - | cmm_top <- prog ] - -cmmCfgOpts :: Tx (ListGraph CmmStmt) -cmmCfgOptsZ :: Tx (a, CmmGraph) - -cmmCfgOpts = branchChainElim -- boring, but will get more exciting later -cmmCfgOptsZ g = - optGraph - (branchChainElimZ `seqTx` blockConcatZ `seqTx` removeUnreachableBlocksZ) g +runCmmContFlowOpts :: Cmm -> Cmm +runCmmContFlowOpts prog = runCmmOpts cmmCfgOpts prog + +oldCmmCfgOpts :: Old.ListGraph Old.CmmStmt -> Old.ListGraph Old.CmmStmt +cmmCfgOpts :: CmmGraph -> CmmGraph + +oldCmmCfgOpts = oldBranchChainElim -- boring, but will get more exciting later +cmmCfgOpts = + removeUnreachableBlocks . blockConcat . branchChainElim -- Here branchChainElim can ultimately be replaced -- with a more exciting combination of optimisations -runCmmOpts :: Tx g -> Tx (GenCmm d h g) +runCmmOpts :: (g -> g) -> GenCmm d h g -> GenCmm d h g -- Lifts a transformer on a single graph to one on the whole program runCmmOpts opt = mapProcs (optProc opt) -optProc :: Tx g -> Tx (GenCmmTop d h g) -optProc _ top@(CmmData {}) = noTx top -optProc opt (CmmProc info lbl formals g) = - fmap (CmmProc info lbl formals) (opt g) - -optGraph :: Tx g -> Tx (a, g) -optGraph opt (a, g) = fmap (\g' -> (a, g')) (opt g) +optProc :: (g -> g) -> GenCmmTop d h g -> GenCmmTop d h g +optProc _ top@(CmmData {}) = top +optProc opt (CmmProc info lbl g) = CmmProc info lbl (opt g) ------------------------------------ -mapProcs :: Tx (GenCmmTop d h s) -> Tx (GenCmm d h s) -mapProcs f (Cmm tops) = fmap Cmm (mapTx f tops) +mapProcs :: (GenCmmTop d h s -> GenCmmTop d h s) -> GenCmm d h s -> GenCmm d h s +mapProcs f (Cmm tops) = Cmm (map f tops) ---------------------------------------------------------------- -branchChainElim :: Tx (ListGraph CmmStmt) +oldBranchChainElim :: Old.ListGraph Old.CmmStmt -> Old.ListGraph Old.CmmStmt -- If L is not captured in an instruction, we can remove any -- basic block of the form L: goto L', and replace L with L' everywhere else. -- How does L get captured? In a CallArea. -branchChainElim (ListGraph blocks) +oldBranchChainElim (Old.ListGraph blocks) | null lone_branch_blocks -- No blocks to remove - = noTx (ListGraph blocks) + = Old.ListGraph blocks | otherwise - = aTx (ListGraph new_blocks) + = Old.ListGraph new_blocks where (lone_branch_blocks, others) = partitionWith isLoneBranch blocks new_blocks = map (replaceLabels env) others env = mkClosureBlockEnv lone_branch_blocks -isLoneBranch :: CmmBasicBlock -> Either (BlockId, BlockId) CmmBasicBlock -isLoneBranch (BasicBlock id [CmmBranch target]) | id /= target = Left (id, target) -isLoneBranch other_block = Right other_block - -- An infinite loop is not a link in a branch chain! - -replaceLabels :: BlockEnv BlockId -> CmmBasicBlock -> CmmBasicBlock -replaceLabels env (BasicBlock id stmts) - = BasicBlock id (map replace stmts) - where - replace (CmmBranch id) = CmmBranch (lookup id) - replace (CmmCondBranch e id) = CmmCondBranch e (lookup id) - replace (CmmSwitch e tbl) = CmmSwitch e (map (fmap lookup) tbl) - replace other_stmt = other_stmt + isLoneBranch :: Old.CmmBasicBlock -> Either (BlockId, BlockId) Old.CmmBasicBlock + isLoneBranch (Old.BasicBlock id [Old.CmmBranch target]) | id /= target = Left (id, target) + isLoneBranch other_block = Right other_block + -- An infinite loop is not a link in a branch chain! + + replaceLabels :: BlockEnv BlockId -> Old.CmmBasicBlock -> Old.CmmBasicBlock + replaceLabels env (Old.BasicBlock id stmts) + = Old.BasicBlock id (map replace stmts) + where + replace (Old.CmmBranch id) = Old.CmmBranch (lookup id) + replace (Old.CmmCondBranch e id) = Old.CmmCondBranch e (lookup id) + replace (Old.CmmSwitch e tbl) = Old.CmmSwitch e (map (fmap lookup) tbl) + replace other_stmt = other_stmt + + lookup id = mapLookup id env `orElse` id - lookup id = lookupBlockEnv env id `orElse` id ---------------------------------------------------------------- -branchChainElimZ :: Tx CmmGraph +branchChainElim :: CmmGraph -> CmmGraph -- Remove any basic block of the form L: goto L', -- and replace L with L' everywhere else, -- unless L is the successor of a call instruction and L' @@ -94,131 +90,129 @@ -- JD isn't quite sure when it's safe to share continuations for different -- function calls -- have to think about where the SP will be, -- so we'll table that problem for now by leaving all call successors alone. -branchChainElimZ g@(G.LGraph eid _) +branchChainElim g | null lone_branch_blocks -- No blocks to remove - = noTx g + = g | otherwise - = aTx $ replaceLabelsZ env $ G.of_block_list eid (self_branches ++ others) + = replaceLabels env $ ofBlockList (g_entry g) (self_branches ++ others) where - blocks = G.to_block_list g - (lone_branch_blocks, others) = partitionWith isLoneBranchZ blocks - env = mkClosureBlockEnvZ lone_branch_blocks + blocks = toBlockList g + (lone_branch_blocks, others) = partitionWith isLoneBranch blocks + env = mkClosureBlockEnv lone_branch_blocks self_branches = let loop_to (id, _) = if lookup id == id then - Just (G.Block id (G.ZLast (G.mkBranchNode id))) + Just $ blockOfNodeList (JustC (CmmEntry id), [], JustC (mkBranchNode id)) else Nothing in mapMaybe loop_to lone_branch_blocks - lookup id = lookupBlockEnv env id `orElse` id + lookup id = mapLookup id env `orElse` id call_succs = foldl add emptyBlockSet blocks - where add succs b = - case G.last (G.unzip b) of - LastOther (LastCall _ (Just k) _ _ _) -> extendBlockSet succs k - _ -> succs - isLoneBranchZ :: CmmBlock -> Either (BlockId, BlockId) CmmBlock - isLoneBranchZ (G.Block id (G.ZLast (G.LastOther (LastBranch target)))) - | id /= target && not (elemBlockSet id call_succs) = Left (id,target) - isLoneBranchZ other = Right other + where add :: BlockSet -> CmmBlock -> BlockSet + add succs b = + case lastNode b of + (CmmCall _ (Just k) _ _ _) -> setInsert k succs + (CmmForeignCall {succ=k}) -> setInsert k succs + _ -> succs + isLoneBranch :: CmmBlock -> Either (BlockId, BlockId) CmmBlock + isLoneBranch block | (JustC (CmmEntry id), [], JustC (CmmBranch target)) <- blockToNodeList block, + id /= target && not (setMember id call_succs) + = Left (id,target) + isLoneBranch other = Right other -- An infinite loop is not a link in a branch chain! -maybeReplaceLabels :: (Last -> Bool) -> BlockEnv BlockId -> CmmGraph -> CmmGraph +maybeReplaceLabels :: (CmmNode O C -> Bool) -> BlockEnv BlockId -> CmmGraph -> CmmGraph maybeReplaceLabels lpred env = - replace_eid . G.map_nodes id middle last + replace_eid . mapGraphNodes (id, middle, last) where - replace_eid (G.LGraph eid blocks) = G.LGraph (lookup eid) blocks - middle = mapExpDeepMiddle exp - last l = if lpred l then mapExpDeepLast exp (last' l) else l - last' (LastBranch bid) = LastBranch (lookup bid) - last' (LastCondBranch p t f) = LastCondBranch p (lookup t) (lookup f) - last' (LastSwitch e arms) = LastSwitch e (map (liftM lookup) arms) - last' (LastCall t k a res r) = LastCall t (liftM lookup k) a res r - exp (CmmLit (CmmBlock bid)) = CmmLit (CmmBlock (lookup bid)) - exp (CmmStackSlot (CallArea (Young id)) i) = - CmmStackSlot (CallArea (Young (lookup id))) i - exp e = e - lookup id = fmap lookup (lookupBlockEnv env id) `orElse` id - -replaceLabelsZ :: BlockEnv BlockId -> CmmGraph -> CmmGraph -replaceLabelsZ = maybeReplaceLabels (const True) - --- replaceBranchLabels :: BlockEnv BlockId -> CmmGraph -> CmmGraph --- replaceBranchLabels env g@(LGraph _ _) = maybeReplaceLabels lpred env g --- where lpred (LastBranch _) = True --- lpred _ = False + replace_eid g = g {g_entry = lookup (g_entry g)} + lookup id = fmap lookup (mapLookup id env) `orElse` id + + middle = mapExpDeep exp + last l = if lpred l then mapExpDeep exp (last' l) else l + last' :: CmmNode O C -> CmmNode O C + last' (CmmBranch bid) = CmmBranch (lookup bid) + last' (CmmCondBranch p t f) = CmmCondBranch p (lookup t) (lookup f) + last' (CmmSwitch e arms) = CmmSwitch e (map (liftM lookup) arms) + last' (CmmCall t k a res r) = CmmCall t (liftM lookup k) a res r + last' (CmmForeignCall t r a bid u i) = CmmForeignCall t r a (lookup bid) u i + + exp (CmmLit (CmmBlock bid)) = CmmLit (CmmBlock (lookup bid)) + exp (CmmStackSlot (CallArea (Young id)) i) = CmmStackSlot (CallArea (Young (lookup id))) i + exp e = e + + +replaceLabels :: BlockEnv BlockId -> CmmGraph -> CmmGraph +replaceLabels = maybeReplaceLabels (const True) replaceBranches :: BlockEnv BlockId -> CmmGraph -> CmmGraph -replaceBranches env g = map_nodes id id last g +replaceBranches env g = mapGraphNodes (id, id, last) g where - last (LastBranch id) = LastBranch (lookup id) - last (LastCondBranch e ti fi) = LastCondBranch e (lookup ti) (lookup fi) - last (LastSwitch e tbl) = LastSwitch e (map (fmap lookup) tbl) - last l@(LastCall {}) = l - lookup id = fmap lookup (lookupBlockEnv env id) `orElse` id + last :: CmmNode O C -> CmmNode O C + last (CmmBranch id) = CmmBranch (lookup id) + last (CmmCondBranch e ti fi) = CmmCondBranch e (lookup ti) (lookup fi) + last (CmmSwitch e tbl) = CmmSwitch e (map (fmap lookup) tbl) + last l@(CmmCall {}) = l + last l@(CmmForeignCall {}) = l + lookup id = fmap lookup (mapLookup id env) `orElse` id ---------------------------------------------------------------- -- Build a map from a block to its set of predecessors. Very useful. -predMap :: G.LastNode l => G.LGraph m l -> BlockEnv BlockSet -predMap g = G.fold_blocks add_preds emptyBlockEnv g -- find the back edges - where add_preds b env = foldl (add b) env (G.succs b) - add (G.Block bid _) env b' = - extendBlockEnv env b' $ - extendBlockSet (lookupBlockEnv env b' `orElse` emptyBlockSet) bid +predMap :: [CmmBlock] -> BlockEnv BlockSet +predMap blocks = foldr add_preds mapEmpty blocks -- find the back edges + where add_preds block env = foldl (add (entryLabel block)) env (successors block) + add bid env b' = + mapInsert b' (setInsert bid (mapLookup b' env `orElse` setEmpty)) env ---------------------------------------------------------------- -- If a block B branches to a label L, L is not the entry block, -- and L has no other predecessors, -- then we can splice the block starting with L onto the end of B. --- Because this optimization can be inhibited by unreachable blocks, --- we first take a pass to drops unreachable blocks. -- Order matters, so we work bottom up (reverse postorder DFS). +-- This optimization can be inhibited by unreachable blocks, but +-- the reverse postorder DFS returns only reachable blocks. -- -- To ensure correctness, we have to make sure that the BlockId of the block -- we are about to eliminate is not named in another instruction. -- -- Note: This optimization does _not_ subsume branch chain elimination. -blockConcatZ :: Tx CmmGraph -blockConcatZ = removeUnreachableBlocksZ `seqTx` blockConcatZ' -blockConcatZ' :: Tx CmmGraph -blockConcatZ' g@(G.LGraph eid blocks) = - tx $ replaceLabelsZ concatMap $ G.LGraph eid blocks' - where (changed, blocks', concatMap) = - foldr maybe_concat (False, blocks, emptyBlockEnv) $ G.postorder_dfs g - maybe_concat b@(G.Block bid _) (changed, blocks', concatMap) = - let unchanged = (changed, extendBlockEnv blocks' bid b, concatMap) - in case G.goto_end $ G.unzip b of - (h, G.LastOther (LastBranch b')) -> +blockConcat :: CmmGraph -> CmmGraph +blockConcat g@(CmmGraph {g_entry=eid}) = + replaceLabels concatMap $ ofBlockMap (g_entry g) blocks' + where blocks = postorderDfs g + (blocks', concatMap) = + foldr maybe_concat (toBlockMap g, mapEmpty) $ blocks + maybe_concat :: CmmBlock -> (LabelMap CmmBlock, LabelMap Label) -> (LabelMap CmmBlock, LabelMap Label) + maybe_concat b unchanged@(blocks', concatMap) = + let bid = entryLabel b + in case blockToNodeList b of + (JustC h, m, JustC (CmmBranch b')) -> if canConcatWith b' then - (True, extendBlockEnv blocks' bid $ splice blocks' h b', - extendBlockEnv concatMap b' bid) + (mapInsert bid (splice blocks' h m b') blocks', + mapInsert b' bid concatMap) else unchanged _ -> unchanged - num_preds bid = liftM sizeBlockSet (lookupBlockEnv backEdges bid) `orElse` 0 + num_preds bid = liftM setSize (mapLookup bid backEdges) `orElse` 0 canConcatWith b' = b' /= eid && num_preds b' == 1 - backEdges = predMap g - splice blocks' h bid' = - case lookupBlockEnv blocks' bid' of - Just (G.Block _ t) -> G.zip $ G.ZBlock h t + backEdges = predMap blocks + splice :: forall map n e x. + IsMap map => + map (Block n e x) -> n C O -> [n O O] -> KeyOf map -> Block n C x + splice blocks' h m bid' = + case mapLookup bid' blocks' of Nothing -> panic "unknown successor block" - tx = if changed then aTx else noTx + Just block | (_, m', l') <- blockToNodeList block -> blockOfNodeList (JustC h, (m ++ m'), l') ---------------------------------------------------------------- mkClosureBlockEnv :: [(BlockId, BlockId)] -> BlockEnv BlockId -mkClosureBlockEnv blocks = mkBlockEnv $ map follow blocks - where singleEnv = mkBlockEnv blocks - follow (id, next) = (id, endChain id next) - endChain orig id = case lookupBlockEnv singleEnv id of - Just id' | id /= orig -> endChain orig id' - _ -> id -mkClosureBlockEnvZ :: [(BlockId, BlockId)] -> BlockEnv BlockId -mkClosureBlockEnvZ blocks = mkBlockEnv $ map follow blocks - where singleEnv = mkBlockEnv blocks +mkClosureBlockEnv blocks = mapFromList $ map follow blocks + where singleEnv = mapFromList blocks :: BlockEnv BlockId follow (id, next) = (id, endChain id next) - endChain orig id = case lookupBlockEnv singleEnv id of + endChain orig id = case mapLookup id singleEnv of Just id' | id /= orig -> endChain orig id' _ -> id ---------------------------------------------------------------- -removeUnreachableBlocksZ :: Tx CmmGraph -removeUnreachableBlocksZ g@(G.LGraph id blocks) = - if length blocks' < sizeBEnv blocks then aTx $ G.of_block_list id blocks' - else noTx g - where blocks' = G.postorder_dfs g +removeUnreachableBlocks :: CmmGraph -> CmmGraph +removeUnreachableBlocks g = + if length blocks < mapSize (toBlockMap g) then ofBlockList (g_entry g) blocks + else g + where blocks = postorderDfs g diff -Nru ghc-7.0.3/compiler/cmm/CmmCPSGen.hs ghc-7.2.1/compiler/cmm/CmmCPSGen.hs --- ghc-7.0.3/compiler/cmm/CmmCPSGen.hs 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/cmm/CmmCPSGen.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,515 +0,0 @@ -module CmmCPSGen ( - -- | Converts continuations into full proceedures. - -- The main work of the CPS transform that everything else is setting-up. - continuationToProc, - Continuation(..), continuationLabel, - ContinuationFormat(..), -) where - -import BlockId -import Cmm -import CLabel -import CmmBrokenBlock -- Data types only -import CmmUtils -import CmmCallConv -import ClosureInfo - -import CgProf -import CgUtils -import CgInfoTbls -import SMRep -import ForeignCall - -import Module -import Constants -import StaticFlags -import Unique -import Data.Maybe -import FastString - -import Panic - --- The format for the call to a continuation --- The fst is the arguments that must be passed to the continuation --- by the continuation's caller. --- The snd is the live values that must be saved on stack. --- A Nothing indicates an ignored slot. --- The head of each list is the stack top or the first parameter. - --- The format for live values for a particular continuation --- All on stack for now. --- Head element is the top of the stack (or just under the header). --- Nothing means an empty slot. --- Future possibilities include callee save registers (i.e. passing slots in register) --- and heap memory (not sure if that's usefull at all though, but it may --- be worth exploring the design space). - -continuationLabel :: Continuation (Either C_SRT CmmInfo) -> CLabel -continuationLabel (Continuation _ l _ _ _) = l -data Continuation info = - Continuation - info -- Left <=> Continuation created by the CPS - -- Right <=> Function or Proc point - CLabel -- Used to generate both info & entry labels - CmmFormals -- Argument locals live on entry (C-- procedure params) - Bool -- True <=> GC block so ignore stack size - [BrokenBlock] -- Code, may be empty. The first block is - -- the entry point. The order is otherwise initially - -- unimportant, but at some point the code gen will - -- fix the order. - - -- the BlockId of the first block does not give rise - -- to a label. To jump to the first block in a Proc, - -- use the appropriate CLabel. - -data ContinuationFormat - = ContinuationFormat { - continuation_formals :: CmmFormals, - continuation_label :: Maybe CLabel, -- The label occupying the top slot - continuation_frame_size :: WordOff, -- Total frame size in words (not including arguments) - continuation_stack :: [Maybe LocalReg] -- local reg offsets from stack top - } - --- A block can be a continuation of a call --- A block can be a continuation of another block (w/ or w/o joins) --- A block can be an entry to a function - ------------------------------------------------------------------------------ -continuationToProc :: (WordOff, WordOff, [(CLabel, ContinuationFormat)]) - -> CmmReg - -> [[[Unique]]] - -> Continuation CmmInfo - -> CmmTop -continuationToProc (max_stack, update_frame_size, formats) stack_use uniques - (Continuation info label formals _ blocks) = - CmmProc info label formals (ListGraph blocks') - where - blocks' = concat $ zipWith3 continuationToProc' uniques blocks - (True : repeat False) - curr_format = maybe unknown_block id $ lookup label formats - unknown_block = panic "unknown BlockId in continuationToProc" - curr_stack = continuation_frame_size curr_format - arg_stack = argumentsSize localRegType formals - - param_stmts :: [CmmStmt] - param_stmts = function_entry curr_format - - gc_stmts :: [CmmStmt] - gc_stmts = - assign_gc_stack_use stack_use arg_stack (max_stack - curr_stack) - - update_stmts :: [CmmStmt] - update_stmts = - case info of - CmmInfo _ (Just (UpdateFrame target args)) _ -> - pack_frame curr_stack update_frame_size (Just target) (map Just args) ++ - adjust_sp_reg (curr_stack - update_frame_size) - CmmInfo _ Nothing _ -> [] - - continuationToProc' :: [[Unique]] - -> BrokenBlock - -> Bool - -> [CmmBasicBlock] - continuationToProc' uniques (BrokenBlock ident entry stmts _ exit) is_entry = - prefix_blocks ++ [BasicBlock ident fixed_main_stmts] ++ concat new_blocks - where - prefix_blocks = - if is_entry - then [BasicBlock - (BlockId prefix_unique) - (param_stmts ++ [CmmBranch ident])] - else [] - - (prefix_unique : call_uniques) : new_block_uniques = uniques - toCLabel = mkReturnPtLabel . getUnique - - block_for_branch :: Unique -> BlockId -> (BlockId, [CmmBasicBlock]) - block_for_branch unique next - -- branches to the current function don't have to jump - | (mkReturnPtLabel $ getUnique next) == label - = (next, []) - - -- branches to any other function have to jump - | (Just cont_format) <- lookup (toCLabel next) formats - = let - new_next = BlockId unique - cont_stack = continuation_frame_size cont_format - arguments = map formal_to_actual (continuation_formals cont_format) - in (new_next, - [BasicBlock new_next $ - pack_continuation curr_format cont_format ++ - tail_call (curr_stack - cont_stack) - (CmmLit $ CmmLabel $ toCLabel next) - arguments]) - - -- branches to blocks in the current function don't have to jump - | otherwise - = (next, []) - - -- Wrapper for block_for_branch for when the target - -- is inside a 'Maybe'. - block_for_branch' :: Unique -> Maybe BlockId -> (Maybe BlockId, [CmmBasicBlock]) - block_for_branch' _ Nothing = (Nothing, []) - block_for_branch' unique (Just next) = (Just new_next, new_blocks) - where (new_next, new_blocks) = block_for_branch unique next - - -- If the target of a switch, branch or cond branch becomes a proc point - -- then we have to make a new block what will then *jump* to the original target. - proc_point_fix unique (CmmCondBranch test target) - = (CmmCondBranch test new_target, new_blocks) - where (new_target, new_blocks) = block_for_branch (head unique) target - proc_point_fix unique (CmmSwitch test targets) - = (CmmSwitch test new_targets, concat new_blocks) - where (new_targets, new_blocks) = - unzip $ zipWith block_for_branch' unique targets - proc_point_fix unique (CmmBranch target) - = (CmmBranch new_target, new_blocks) - where (new_target, new_blocks) = block_for_branch (head unique) target - proc_point_fix _ other = (other, []) - - (fixed_main_stmts, new_blocks) = unzip $ zipWith proc_point_fix new_block_uniques main_stmts - main_stmts = - case entry of - FunctionEntry _ _ _ -> - -- The statements for an update frame must come /after/ - -- the GC check that was added at the beginning of the - -- CPS pass. So we have do edit the statements a bit. - -- This depends on the knowledge that the statements in - -- the first block are only the GC check. That's - -- fragile but it works for now. - gc_stmts ++ stmts ++ update_stmts ++ postfix_stmts - ControlEntry -> stmts ++ postfix_stmts - ContinuationEntry _ _ _ -> stmts ++ postfix_stmts - postfix_stmts = case exit of - -- Branches and switches may get modified by proc_point_fix - FinalBranch next -> [CmmBranch next] - FinalSwitch expr targets -> [CmmSwitch expr targets] - - -- A return is a tail call to the stack top - FinalReturn arguments -> - tail_call curr_stack - (entryCode (CmmLoad (CmmReg spReg) bWord)) - arguments - - -- A tail call - FinalJump target arguments -> - tail_call curr_stack target arguments - - -- A regular Cmm function call - FinalCall next (CmmCallee target CmmCallConv) - _ arguments _ _ _ -> - pack_continuation curr_format cont_format ++ - tail_call (curr_stack - cont_stack) - target arguments - where - cont_format = maybe unknown_block id $ - lookup (mkReturnPtLabel $ getUnique next) formats - cont_stack = continuation_frame_size cont_format - - -- A safe foreign call - FinalCall _ (CmmCallee target conv) - results arguments _ _ _ -> - target_stmts ++ - foreignCall call_uniques' (CmmCallee new_target conv) - results arguments - where - (call_uniques', target_stmts, new_target) = - maybeAssignTemp call_uniques target - - -- A safe prim call - FinalCall _ (CmmPrim target) - results arguments _ _ _ -> - foreignCall call_uniques (CmmPrim target) - results arguments - -formal_to_actual :: LocalReg -> CmmHinted CmmExpr -formal_to_actual reg = CmmHinted (CmmReg (CmmLocal reg)) NoHint - -foreignCall :: [Unique] -> CmmCallTarget -> HintedCmmFormals -> HintedCmmActuals -> [CmmStmt] -foreignCall uniques call results arguments = - arg_stmts ++ - saveThreadState ++ - caller_save ++ - [CmmCall (CmmCallee suspendThread CCallConv) - [ CmmHinted id AddrHint ] - [ CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint ] - CmmUnsafe - CmmMayReturn, - CmmCall call results new_args CmmUnsafe CmmMayReturn, - CmmCall (CmmCallee resumeThread CCallConv) - [ CmmHinted new_base AddrHint ] - [ CmmHinted (CmmReg (CmmLocal id)) AddrHint ] - CmmUnsafe - CmmMayReturn, - -- Assign the result to BaseReg: we - -- might now have a different Capability! - CmmAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base))] ++ - caller_load ++ - loadThreadState tso_unique ++ - [CmmJump (CmmReg spReg) (map (formal_to_actual . hintlessCmm) results)] - where - (_, arg_stmts, new_args) = - loadArgsIntoTemps argument_uniques arguments - (caller_save, caller_load) = - callerSaveVolatileRegs (Just [{-only system regs-}]) - new_base = LocalReg base_unique (cmmRegType (CmmGlobal BaseReg)) - id = LocalReg id_unique bWord - tso_unique : base_unique : id_unique : argument_uniques = uniques - --- ----------------------------------------------------------------------------- --- Save/restore the thread state in the TSO - -suspendThread, resumeThread :: CmmExpr -suspendThread = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "suspendThread"))) -resumeThread = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "resumeThread"))) - --- This stuff can't be done in suspendThread/resumeThread, because it --- refers to global registers which aren't available in the C world. - -saveThreadState :: [CmmStmt] -saveThreadState = - -- CurrentTSO->sp = Sp; - [CmmStore (cmmOffset stgCurrentTSO tso_SP) stgSp, - closeNursery] ++ - -- and save the current cost centre stack in the TSO when profiling: - if opt_SccProfilingOn - then [CmmStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS] - else [] - - -- CurrentNursery->free = Hp+1; -closeNursery :: CmmStmt -closeNursery = CmmStore nursery_bdescr_free (cmmOffsetW stgHp 1) - -loadThreadState :: Unique -> [CmmStmt] -loadThreadState tso_unique = - [ - -- tso = CurrentTSO; - CmmAssign (CmmLocal tso) stgCurrentTSO, - -- Sp = tso->sp; - CmmAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_SP) - bWord), - -- SpLim = tso->stack + RESERVED_STACK_WORDS; - CmmAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal tso)) tso_STACK) - rESERVED_STACK_WORDS) - ] ++ - openNursery ++ - -- and load the current cost centre stack from the TSO when profiling: - if opt_SccProfilingOn - then [CmmStore curCCSAddr - (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) bWord)] - else [] - where tso = LocalReg tso_unique bWord -- TODO FIXME NOW - - -openNursery :: [CmmStmt] -openNursery = [ - -- Hp = CurrentNursery->free - 1; - CmmAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free bWord) (-1)), - - -- HpLim = CurrentNursery->start + - -- CurrentNursery->blocks*BLOCK_SIZE_W - 1; - CmmAssign hpLim - (cmmOffsetExpr - (CmmLoad nursery_bdescr_start bWord) - (cmmOffset - (CmmMachOp mo_wordMul [ - CmmMachOp (MO_SS_Conv W32 wordWidth) - [CmmLoad nursery_bdescr_blocks b32], - CmmLit (mkIntCLit bLOCK_SIZE) - ]) - (-1) - ) - ) - ] - - -nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks :: CmmExpr -nursery_bdescr_free = cmmOffset stgCurrentNursery oFFSET_bdescr_free -nursery_bdescr_start = cmmOffset stgCurrentNursery oFFSET_bdescr_start -nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks - -tso_SP, tso_STACK, tso_CCCS :: ByteOff -tso_SP = tsoFieldB oFFSET_StgTSO_sp -tso_STACK = tsoFieldB oFFSET_StgTSO_stack -tso_CCCS = tsoProfFieldB oFFSET_StgTSO_CCCS - --- The TSO struct has a variable header, and an optional StgTSOProfInfo in --- the middle. The fields we're interested in are after the StgTSOProfInfo. -tsoFieldB :: ByteOff -> ByteOff -tsoFieldB off - | opt_SccProfilingOn = off + sIZEOF_StgTSOProfInfo + fixedHdrSize * wORD_SIZE - | otherwise = off + fixedHdrSize * wORD_SIZE - -tsoProfFieldB :: ByteOff -> ByteOff -tsoProfFieldB off = off + fixedHdrSize * wORD_SIZE - -stgSp, stgHp, stgCurrentTSO, stgCurrentNursery :: CmmExpr -stgSp = CmmReg sp -stgHp = CmmReg hp -stgCurrentTSO = CmmReg currentTSO -stgCurrentNursery = CmmReg currentNursery - -sp, spLim, hp, hpLim, currentTSO, currentNursery :: CmmReg -sp = CmmGlobal Sp -spLim = CmmGlobal SpLim -hp = CmmGlobal Hp -hpLim = CmmGlobal HpLim -currentTSO = CmmGlobal CurrentTSO -currentNursery = CmmGlobal CurrentNursery - ------------------------------------------------------------------------------ --- Functions that generate CmmStmt sequences --- for packing/unpacking continuations --- and entering/exiting functions - -tail_call :: WordOff -> CmmExpr -> HintedCmmActuals -> [CmmStmt] -tail_call spRel target arguments - = store_arguments ++ adjust_sp_reg spRel ++ jump where - store_arguments = - [stack_put spRel expr offset - | ((CmmHinted expr _), StackParam offset) <- argument_formats] ++ - [global_put expr global - | ((CmmHinted expr _), RegisterParam global) <- argument_formats] - jump = [CmmJump target arguments] - - argument_formats = assignArguments (cmmExprType . hintlessCmm) arguments - -adjust_sp_reg :: Int -> [CmmStmt] -adjust_sp_reg spRel = - if spRel == 0 - then [] - else [CmmAssign spReg (CmmRegOff spReg (spRel*wORD_SIZE))] - -assign_gc_stack_use :: CmmReg -> Int -> Int -> [CmmStmt] -assign_gc_stack_use stack_use arg_stack max_frame_size = - if max_frame_size > arg_stack - then [CmmAssign stack_use (CmmRegOff spReg (-max_frame_size*wORD_SIZE))] - else [CmmAssign stack_use (CmmReg spLimReg)] - -- Trick the optimizer into eliminating the branch for us - -{- -UNUSED 2008-12-29 - -gc_stack_check :: BlockId -> WordOff -> [CmmStmt] -gc_stack_check gc_block max_frame_size - = check_stack_limit where - check_stack_limit = [ - CmmCondBranch - (CmmMachOp (MO_U_Lt (typeWidth (cmmRegType spReg))) - [CmmRegOff spReg (-max_frame_size*wORD_SIZE), - CmmReg spLimReg]) - gc_block] --} - -pack_continuation :: ContinuationFormat -- ^ The current format - -> ContinuationFormat -- ^ The return point format - -> [CmmStmt] -pack_continuation (ContinuationFormat _ curr_id curr_frame_size _) - (ContinuationFormat _ cont_id cont_frame_size live_regs) - = pack_frame curr_frame_size cont_frame_size maybe_header continuation_args - where - continuation_args = map (maybe Nothing (Just . CmmReg . CmmLocal)) - live_regs - needs_header_set = - case (curr_id, cont_id) of - (Just x, Just y) -> x /= y - _ -> isJust cont_id - - maybe_header = if needs_header_set - then maybe Nothing (Just . CmmLit . CmmLabel . entryLblToInfoLbl) cont_id - else Nothing - -pack_frame :: WordOff -- ^ Current frame size - -> WordOff -- ^ Next frame size - -> Maybe CmmExpr -- ^ Next frame header if any - -> [Maybe CmmExpr] -- ^ Next frame data - -> [CmmStmt] -pack_frame curr_frame_size next_frame_size next_frame_header frame_args = - store_live_values ++ set_stack_header - where - -- TODO: only save variables when actually needed - -- (may be handled by latter pass) - store_live_values = - [stack_put spRel expr offset - | (expr, offset) <- cont_offsets] - set_stack_header = - case next_frame_header of - Nothing -> [] - Just expr -> [stack_put spRel expr 0] - - -- TODO: factor with function_entry and CmmInfo.hs(?) - cont_offsets = mkOffsets label_size frame_args - - label_size = 1 :: WordOff - - mkOffsets _ [] = [] - mkOffsets size (Nothing:exprs) = mkOffsets (size+1) exprs - mkOffsets size (Just expr:exprs) = (expr, size):mkOffsets (size + width) exprs - where - width = (widthInBytes $ typeWidth $ cmmExprType expr) `quot` wORD_SIZE - -- TODO: it would be better if we had a machRepWordWidth - - spRel = curr_frame_size - next_frame_size - - --- Lazy adjustment of stack headers assumes all blocks --- that could branch to eachother (i.e. control blocks) --- have the same stack format (this causes a problem --- only for proc-point). -function_entry :: ContinuationFormat -> [CmmStmt] -function_entry (ContinuationFormat formals _ _ live_regs) - = load_live_values ++ load_args where - -- TODO: only save variables when actually needed - -- (may be handled by latter pass) - load_live_values = - [stack_get 0 reg offset - | (reg, offset) <- curr_offsets] - load_args = - [stack_get 0 reg offset - | (reg, StackParam offset) <- argument_formats] ++ - [global_get reg global - | (reg, RegisterParam global) <- argument_formats] - - argument_formats = assignArguments (localRegType) formals - - -- TODO: eliminate copy/paste with pack_continuation - curr_offsets = mkOffsets label_size live_regs - - label_size = 1 :: WordOff - - mkOffsets _ [] = [] - mkOffsets size (Nothing:regs) = mkOffsets (size+1) regs - mkOffsets size (Just reg:regs) = (reg, size):mkOffsets (size + width) regs - where - width = (widthInBytes $ typeWidth $ localRegType reg) `quot` wORD_SIZE - -- TODO: it would be better if we had a machRepWordWidth - ------------------------------------------------------------------------------ --- Section: Stack and argument register puts and gets ------------------------------------------------------------------------------ --- TODO: document - --- |Construct a 'CmmStmt' that will save a value on the stack -stack_put :: WordOff -- ^ Offset from the real 'Sp' that 'offset' - -- is relative to (added to offset) - -> CmmExpr -- ^ What to store onto the stack - -> WordOff -- ^ Where on the stack to store it - -- (positive <=> higher addresses) - -> CmmStmt -stack_put spRel expr offset = - CmmStore (CmmRegOff spReg (wORD_SIZE*(spRel + offset))) expr - --------------------------------- --- |Construct a -stack_get :: WordOff - -> LocalReg - -> WordOff - -> CmmStmt -stack_get spRel reg offset = - CmmAssign (CmmLocal reg) - (CmmLoad (CmmRegOff spReg (wORD_SIZE*(spRel + offset))) - (localRegType reg)) -global_put :: CmmExpr -> GlobalReg -> CmmStmt -global_put expr global = CmmAssign (CmmGlobal global) expr -global_get :: LocalReg -> GlobalReg -> CmmStmt -global_get reg global = CmmAssign (CmmLocal reg) (CmmReg (CmmGlobal global)) diff -Nru ghc-7.0.3/compiler/cmm/CmmCPS.hs ghc-7.2.1/compiler/cmm/CmmCPS.hs --- ghc-7.0.3/compiler/cmm/CmmCPS.hs 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/cmm/CmmCPS.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,412 +0,0 @@ -module CmmCPS ( - -- | Converts C-- with full proceedures and parameters - -- to a CPS transformed C-- with the stack made manifest. - cmmCPS -) where - -#include "HsVersions.h" - -import BlockId -import Cmm -import CmmLint -import PprCmm - -import CmmLive -import CmmBrokenBlock -import CmmProcPoint -import CmmCallConv -import CmmCPSGen -import CmmUtils - -import ClosureInfo -import CLabel -import SMRep -import Constants - -import DynFlags -import ErrUtils -import Maybes -import Outputable -import UniqSupply -import UniqSet -import Unique - -import Control.Monad - ------------------------------------------------------------------------------ --- |Top level driver for the CPS pass ------------------------------------------------------------------------------ -cmmCPS :: DynFlags -- ^ Dynamic flags: -dcmm-lint -ddump-cps-cmm - -> [Cmm] -- ^ Input C-- with Proceedures - -> IO [Cmm] -- ^ Output CPS transformed C-- -cmmCPS dflags cmm_with_calls - = do { when (dopt Opt_DoCmmLinting dflags) $ - do showPass dflags "CmmLint" - case firstJusts $ map cmmLint cmm_with_calls of - Just err -> do printDump err - ghcExit dflags 1 - Nothing -> return () - ; showPass dflags "CPS" - - -- TODO: more lint checking - -- check for use of branches to non-existant blocks - -- check for use of Sp, SpLim, R1, R2, etc. - - ; uniqSupply <- mkSplitUniqSupply 'p' - ; let supplies = listSplitUniqSupply uniqSupply - ; let cpsd_cmm = zipWith doCpsProc supplies cmm_with_calls - - ; dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "CPS Cmm" (pprCmms cpsd_cmm) - - -- TODO: add option to dump Cmm to file - - ; return cpsd_cmm } - - ------------------------------------------------------------------------------ --- |CPS a single CmmTop (proceedure) --- Only 'CmmProc' are transformed 'CmmData' will be left alone. ------------------------------------------------------------------------------ - -doCpsProc :: UniqSupply -> Cmm -> Cmm -doCpsProc s (Cmm c) - = Cmm $ concat $ zipWith cpsProc (listSplitUniqSupply s) c - -cpsProc :: UniqSupply - -> CmmTop -- ^Input procedure - -> [CmmTop] -- ^Output procedures; - -- a single input procedure is converted to - -- multiple output procedures - --- Data blocks don't need to be CPS transformed -cpsProc _ proc@(CmmData _ _) = [proc] - --- Empty functions just don't work with the CPS algorithm, but --- they don't need the transformation anyway so just output them directly -cpsProc _ proc@(CmmProc _ _ _ (ListGraph [])) - = pprTrace "cpsProc: unexpected empty proc" (ppr proc) [proc] - --- CPS transform for those procs that actually need it --- The plan is this: --- --- * Introduce a stack-check block as the first block --- * The first blocks gets a FunctionEntry; the rest are ControlEntry --- * Now break each block into a bunch of blocks (at call sites); --- all but the first will be ContinuationEntry --- -cpsProc uniqSupply (CmmProc info ident params (ListGraph blocks)) = cps_procs - where - -- We need to be generating uniques for several things. - -- We could make this function monadic to handle that - -- but since there is no other reason to make it monadic, - -- we instead will just split them all up right here. - (uniqSupply1, uniqSupply2) = splitUniqSupply uniqSupply - uniques :: [[Unique]] - uniques = map uniqsFromSupply $ listSplitUniqSupply uniqSupply1 - (stack_check_block_unique:stack_use_unique:adaptor_uniques) : - block_uniques = uniques - proc_uniques = map (map (map uniqsFromSupply . listSplitUniqSupply) . listSplitUniqSupply) $ listSplitUniqSupply uniqSupply2 - - stack_use = CmmLocal (LocalReg stack_use_unique (cmmRegType spReg)) - stack_check_block_id = BlockId stack_check_block_unique - stack_check_block = make_stack_check stack_check_block_id info stack_use (blockId $ head blocks) - - forced_blocks = stack_check_block : blocks - - CmmInfo maybe_gc_block_id update_frame _ = info - - -- Break the block at each function call. - -- The part after the function call will have to become a continuation. - broken_blocks :: ([(BlockId, ContFormat)], [BrokenBlock]) - broken_blocks = - (\x -> (concatMap fst x, concatMap snd x)) $ - zipWith3 (breakBlock (maybeToList maybe_gc_block_id)) - block_uniques - forced_blocks - (FunctionEntry info ident params : - repeat ControlEntry) - - f' = selectContinuations (fst broken_blocks) - broken_blocks' = map (makeContinuationEntries f') $ - concat $ - zipWith (adaptBlockToFormat f') - adaptor_uniques - (snd broken_blocks) - - -- Calculate live variables for each broken block. - -- - -- Nothing can be live on entry to the first block - -- so we could take the tail, but for now we wont - -- to help future proof the code. - live :: BlockEntryLiveness - live = cmmLiveness $ map cmmBlockFromBrokenBlock broken_blocks' - - -- Calculate which blocks must be made into full fledged procedures. - proc_points :: UniqSet BlockId - proc_points = calculateProcPoints broken_blocks' - - -- Construct a map so we can lookup a broken block by its 'BlockId'. - block_env :: BlockEnv BrokenBlock - block_env = blocksToBlockEnv broken_blocks' - - -- Group the blocks into continuations based on the set of proc-points. - continuations :: [Continuation (Either C_SRT CmmInfo)] - continuations = map (gatherBlocksIntoContinuation live proc_points block_env) - (uniqSetToList proc_points) - - -- Select the stack format on entry to each continuation. - -- Return the max stack offset and an association list - -- - -- This is an association list instead of a UniqFM because - -- CLabel's don't have a 'Uniqueable' instance. - formats :: [(CLabel, -- key - (CmmFormals, -- arguments - Maybe CLabel, -- label in top slot - [Maybe LocalReg]))] -- slots - formats = selectContinuationFormat live continuations - - -- Do a little meta-processing on the stack formats such as - -- getting the individual frame sizes and the maximum frame size - formats' :: (WordOff, WordOff, [(CLabel, ContinuationFormat)]) - formats'@(_, _, format_list) = processFormats formats update_frame continuations - - -- Update the info table data on the continuations with - -- the selected stack formats. - continuations' :: [Continuation CmmInfo] - continuations' = map (applyContinuationFormat format_list) continuations - - -- Do the actual CPS transform. - cps_procs :: [CmmTop] - cps_procs = zipWith (continuationToProc formats' stack_use) proc_uniques continuations' - -make_stack_check :: BlockId -> CmmInfo -> CmmReg -> BlockId - -> GenBasicBlock CmmStmt -make_stack_check stack_check_block_id info stack_use next_block_id = - BasicBlock stack_check_block_id $ - check_stmts ++ [CmmBranch next_block_id] - where - check_stmts = - case info of - -- If we are given a stack check handler, - -- then great, well check the stack. - CmmInfo (Just gc_block) _ _ - -> [CmmCondBranch - (CmmMachOp (MO_U_Lt (typeWidth (cmmRegType spReg))) - [CmmReg stack_use, CmmReg spLimReg]) - gc_block] - -- If we aren't given a stack check handler, - -- then humph! we just won't check the stack for them. - CmmInfo Nothing _ _ - -> [] ------------------------------------------------------------------------------ - -collectNonProcPointTargets :: - UniqSet BlockId -> BlockEnv BrokenBlock - -> UniqSet BlockId -> [BlockId] -> UniqSet BlockId -collectNonProcPointTargets proc_points blocks current_targets new_blocks = - if sizeUniqSet current_targets == sizeUniqSet new_targets - then current_targets - else foldl - (collectNonProcPointTargets proc_points blocks) - new_targets - (map (:[]) targets) - where - blocks' = map (lookupWithDefaultBEnv blocks (panic "TODO")) new_blocks - targets = - -- Note the subtlety that since the extra branch after a call - -- will always be to a block that is a proc-point, - -- this subtraction will always remove that case - uniqSetToList $ (unionManyUniqSets $ map (mkUniqSet . brokenBlockTargets) blocks') - `minusUniqSet` proc_points - -- TODO: remove redundant uniqSetToList - new_targets = current_targets `unionUniqSets` (mkUniqSet targets) - --- TODO: insert proc point code here --- * Branches and switches to proc points may cause new blocks to be created --- (or proc points could leave behind phantom blocks that just jump to them) --- * Proc points might get some live variables passed as arguments - -gatherBlocksIntoContinuation :: - BlockEntryLiveness -> UniqSet BlockId -> BlockEnv BrokenBlock - -> BlockId -> Continuation (Either C_SRT CmmInfo) -gatherBlocksIntoContinuation live proc_points blocks start = - Continuation info_table clabel params is_gc_cont body - where - children = (collectNonProcPointTargets proc_points blocks (unitUniqSet start) [start]) `minusUniqSet` (unitUniqSet start) - start_block = lookupWithDefaultBEnv blocks unknown_block start - children_blocks = map (lookupWithDefaultBEnv blocks unknown_block) (uniqSetToList children) - unknown_block :: a -- Used at more than one type - unknown_block = panic "unknown block in gatherBlocksIntoContinuation" - body = start_block : children_blocks - - -- We can't properly annotate the continuation's stack parameters - -- at this point because this is before stack selection - -- but we want to keep the C_SRT around so we use 'Either'. - info_table = case start_block_entry of - FunctionEntry info _ _ -> Right info - ContinuationEntry _ srt _ -> Left srt - ControlEntry -> Right (CmmInfo Nothing Nothing CmmNonInfoTable) - - is_gc_cont = case start_block_entry of - FunctionEntry _ _ _ -> False - ContinuationEntry _ _ gc_cont -> gc_cont - ControlEntry -> False - - start_block_entry = brokenBlockEntry start_block - clabel = case start_block_entry of - FunctionEntry _ label _ -> label - _ -> mkReturnPtLabel $ getUnique start - params = case start_block_entry of - FunctionEntry _ _ args -> args - ContinuationEntry args _ _ -> args - ControlEntry -> - uniqSetToList $ - lookupWithDefaultBEnv live unknown_block start - -- it's a proc-point, pass lives in parameter registers - --------------------------------------------------------------------------------- --- For now just select the continuation orders in the order they are in the set with no gaps - -selectContinuationFormat :: BlockEnv CmmLive - -> [Continuation (Either C_SRT CmmInfo)] - -> [(CLabel, (CmmFormals, Maybe CLabel, [Maybe LocalReg]))] -selectContinuationFormat live continuations = - map (\c -> (continuationLabel c, selectContinuationFormat' c)) continuations - where - -- User written continuations - selectContinuationFormat' (Continuation - (Right (CmmInfo _ _ (CmmInfoTable _ _ _ (ContInfo format _)))) - label formals _ _) = - (formals, Just label, format) - -- Either user written non-continuation code - -- or CPS generated proc-points - selectContinuationFormat' (Continuation (Right _) _ formals _ _) = - (formals, Nothing, []) - -- CPS generated continuations - selectContinuationFormat' (Continuation (Left _) label formals _ blocks) = - -- TODO: assumes the first block is the entry block - let ident = brokenBlockId $ head blocks -- TODO: CLabel isn't a uniquable, but we need a better way than this - in (formals, - Just label, - map Just $ uniqSetToList $ - lookupWithDefaultBEnv live unknown_block ident) - - unknown_block = panic "unknown BlockId in selectContinuationFormat" - -processFormats :: [(CLabel, (CmmFormals, Maybe CLabel, [Maybe LocalReg]))] - -> Maybe UpdateFrame - -> [Continuation (Either C_SRT CmmInfo)] - -> (WordOff, WordOff, [(CLabel, ContinuationFormat)]) -processFormats formats update_frame continuations = - (max_size + update_frame_size, update_frame_size, formats') - where - max_size = maximum $ - 0 : map (continuationMaxStack formats') continuations - formats' = map make_format formats - make_format (label, (formals, top, stack)) = - (label, - ContinuationFormat { - continuation_formals = formals, - continuation_label = top, - continuation_frame_size = stack_size stack + - if isJust top - then label_size - else 0, - continuation_stack = stack }) - - update_frame_size = case update_frame of - Nothing -> 0 - (Just (UpdateFrame _ args)) - -> label_size + update_size args - - update_size [] = 0 - update_size (expr:exprs) = width + update_size exprs - where - width = (widthInBytes $ typeWidth $ cmmExprType expr) `quot` wORD_SIZE - -- TODO: it would be better if we had a machRepWordWidth - - -- TODO: get rid of "+ 1" etc. - label_size = 1 :: WordOff - - stack_size [] = 0 - stack_size (Nothing:formats) = 1 + stack_size formats -- one dead word - stack_size (Just reg:formats) = width + stack_size formats - where - width = (widthInBytes $ typeWidth $ localRegType reg) `quot` wORD_SIZE - -- TODO: it would be better if we had a machRepWordWidth - -continuationMaxStack :: [(CLabel, ContinuationFormat)] - -> Continuation a - -> WordOff -continuationMaxStack _ (Continuation _ _ _ True _) = 0 -continuationMaxStack formats (Continuation _ label _ False blocks) = - max_arg_size + continuation_frame_size stack_format - where - stack_format = maybe unknown_format id $ lookup label formats - unknown_format = panic "Unknown format in continuationMaxStack" - - max_arg_size = maximum $ 0 : map block_max_arg_size blocks - - block_max_arg_size block = - maximum (final_arg_size (brokenBlockExit block) : - map stmt_arg_size (brokenBlockStmts block)) - - final_arg_size (FinalReturn args) = - argumentsSize (cmmExprType . hintlessCmm) args - final_arg_size (FinalJump _ args) = - argumentsSize (cmmExprType . hintlessCmm) args - final_arg_size (FinalCall _ _ _ _ _ _ True) = 0 - final_arg_size (FinalCall next _ _ args _ _ False) = - -- We have to account for the stack used when we build a frame - -- for the *next* continuation from *this* continuation - argumentsSize (cmmExprType . hintlessCmm) args + - continuation_frame_size next_format - where - next_format = maybe unknown_format id $ lookup next' formats - next' = mkReturnPtLabel $ getUnique next - - final_arg_size _ = 0 - - stmt_arg_size (CmmJump _ args) = - argumentsSize (cmmExprType . hintlessCmm) args - stmt_arg_size (CmmCall _ _ _ (CmmSafe _) _) = - panic "Safe call in processFormats" - stmt_arg_size (CmmReturn _) = - panic "CmmReturn in processFormats" - stmt_arg_size _ = 0 - ------------------------------------------------------------------------------ -applyContinuationFormat :: [(CLabel, ContinuationFormat)] - -> Continuation (Either C_SRT CmmInfo) - -> Continuation CmmInfo - --- User written continuations -applyContinuationFormat formats - (Continuation (Right (CmmInfo gc update_frame - (CmmInfoTable clos prof tag (ContInfo _ srt)))) - label formals is_gc blocks) = - Continuation (CmmInfo gc update_frame (CmmInfoTable clos prof tag (ContInfo format srt))) - label formals is_gc blocks - where - format = continuation_stack $ maybe unknown_block id $ lookup label formats - unknown_block = panic "unknown BlockId in applyContinuationFormat" - --- Either user written non-continuation code or CPS generated proc-point -applyContinuationFormat _ (Continuation - (Right info) label formals is_gc blocks) = - Continuation info label formals is_gc blocks - --- CPS generated continuations -applyContinuationFormat formats (Continuation - (Left srt) label formals is_gc blocks) = - Continuation (CmmInfo gc Nothing (CmmInfoTable undefined prof tag (ContInfo (continuation_stack $ format) srt))) - label formals is_gc blocks - where - gc = Nothing -- Generated continuations never need a stack check - -- TODO prof: this is the same as the current implementation - -- but I think it could be improved - prof = ProfilingInfo zeroCLit zeroCLit - tag = rET_SMALL -- cmmToRawCmm may convert it to rET_BIG - format = maybe unknown_block id $ lookup label formats - unknown_block = panic "unknown BlockId in applyContinuationFormat" - diff -Nru ghc-7.0.3/compiler/cmm/CmmCPSZ.hs ghc-7.2.1/compiler/cmm/CmmCPSZ.hs --- ghc-7.0.3/compiler/cmm/CmmCPSZ.hs 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/cmm/CmmCPSZ.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,185 +0,0 @@ -#if __GLASGOW_HASKELL__ >= 611 -{-# OPTIONS_GHC -XNoMonoLocalBinds #-} -#endif --- Norman likes local bindings --- If this module lives on I'd like to get rid of this flag in due course - -module CmmCPSZ ( - -- | Converts C-- with full proceedures and parameters - -- to a CPS transformed C-- with the stack made manifest. - -- Well, sort of. - protoCmmCPSZ -) where - -import CLabel -import Cmm -import CmmBuildInfoTables -import CmmCommonBlockElimZ -import CmmProcPointZ -import CmmSpillReload -import CmmStackLayout -import DFMonad -import PprCmmZ() -import ZipCfgCmmRep - -import DynFlags -import ErrUtils -import HscTypes -import Data.Maybe -import Control.Monad -import Data.Map (Map) -import qualified Data.Map as Map -import Outputable -import StaticFlags - ------------------------------------------------------------------------------ --- |Top level driver for the CPS pass ------------------------------------------------------------------------------ --- There are two complications here: --- 1. We need to compile the procedures in two stages because we need --- an analysis of the procedures to tell us what CAFs they use. --- The first stage returns a map from procedure labels to CAFs, --- along with a closure that will compute SRTs and attach them to --- the compiled procedures. --- The second stage is to combine the CAF information into a top-level --- CAF environment mapping non-static closures to the CAFs they keep live, --- then pass that environment to the closures returned in the first --- stage of compilation. --- 2. We need to thread the module's SRT around when the SRT tables --- are computed for each procedure. --- The SRT needs to be threaded because it is grown lazily. -protoCmmCPSZ :: HscEnv -- Compilation env including - -- dynamic flags: -dcmm-lint -ddump-cps-cmm - -> (TopSRT, [CmmZ]) -- SRT table and accumulating list of compiled procs - -> CmmZ -- Input C-- with Procedures - -> IO (TopSRT, [CmmZ]) -- Output CPS transformed C-- -protoCmmCPSZ hsc_env (topSRT, rst) (Cmm tops) = - do let dflags = hsc_dflags hsc_env - showPass dflags "CPSZ" - (cafEnvs, tops) <- liftM unzip $ mapM (cpsTop hsc_env) tops - let topCAFEnv = mkTopCAFInfo (concat cafEnvs) - (topSRT, tops) <- foldM (toTops hsc_env topCAFEnv) (topSRT, []) tops - -- (topSRT, tops) <- foldM (\ z f -> f topCAFEnv z) (topSRT, []) toTops - let cmms = Cmm (reverse (concat tops)) - dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (ppr cmms) - return (topSRT, cmms : rst) - -{- [Note global fuel] -~~~~~~~~~~~~~~~~~~~~~ -The identity and the last pass are stored in -mutable reference cells in an 'HscEnv' and are -global to one compiler session. --} - -cpsTop :: HscEnv -> CmmTopZ -> - IO ([(CLabel, CAFSet)], - [(CAFSet, CmmTopForInfoTables)]) -cpsTop _ p@(CmmData {}) = return ([], [(Map.empty, NoInfoTable p)]) -cpsTop hsc_env (CmmProc h l args (stackInfo@(entry_off, _), g)) = - do - dump Opt_D_dump_cmmz "Pre Proc Points Added" g - let callPPs = callProcPoints g - -- Why bother doing it this early? - -- g <- dual_rewrite Opt_D_dump_cmmz "spills and reloads" - -- (dualLivenessWithInsertion callPPs) g - -- g <- run $ insertLateReloads g -- Duplicate reloads just before uses - -- g <- dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination" - -- (removeDeadAssignmentsAndReloads callPPs) g - dump Opt_D_dump_cmmz "Pre common block elimination" g - g <- return $ elimCommonBlocks g - dump Opt_D_dump_cmmz "Post common block elimination" g - - ----------- Proc points ------------------- - procPoints <- run $ minimalProcPointSet callPPs g - g <- run $ addProcPointProtocols callPPs procPoints g - dump Opt_D_dump_cmmz "Post Proc Points Added" g - - ----------- Spills and reloads ------------------- - g <- - -- pprTrace "pre Spills" (ppr g) $ - dual_rewrite Opt_D_dump_cmmz "spills and reloads" - (dualLivenessWithInsertion procPoints) g - -- Insert spills at defns; reloads at return points - g <- - -- pprTrace "pre insertLateReloads" (ppr g) $ - run $ insertLateReloads g -- Duplicate reloads just before uses - dump Opt_D_dump_cmmz "Post late reloads" g - g <- - -- pprTrace "post insertLateReloads" (ppr g) $ - dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination" - (removeDeadAssignmentsAndReloads procPoints) g - -- Remove redundant reloads (and any other redundant asst) - - ----------- Debug only: add code to put zero in dead stack slots---- - -- Debugging: stubbing slots on death can cause crashes early - g <- - -- trace "post dead-assign elim" $ - if opt_StubDeadValues then run $ stubSlotsOnDeath g else return g - - - --------------- Stack layout ---------------- - slotEnv <- run $ liveSlotAnal g - mbpprTrace "live slot analysis results: " (ppr slotEnv) $ return () - -- cafEnv <- -- trace "post liveSlotAnal" $ run $ cafAnal g - -- (cafEnv, slotEnv) <- - -- -- trace "post print cafAnal" $ - -- return $ extendEnvsForSafeForeignCalls cafEnv slotEnv g - slotEnv <- return $ extendEnvWithSafeForeignCalls liveSlotTransfers slotEnv g - mbpprTrace "slotEnv extended for safe foreign calls: " (ppr slotEnv) $ return () - let areaMap = layout procPoints slotEnv entry_off g - mbpprTrace "areaMap" (ppr areaMap) $ return () - - ------------ Manifest the the stack pointer -------- - g <- run $ manifestSP 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... - - ------------- Split into separate procedures ------------ - procPointMap <- run $ procPointAnalysis procPoints g - dump Opt_D_dump_cmmz "procpoint map" procPointMap - gs <- run $ splitAtProcPoints l callPPs procPoints procPointMap - (CmmProc h l args (stackInfo, g)) - mapM_ (dump Opt_D_dump_cmmz "after splitting") gs - - ------------- More CAFs and foreign calls ------------ - cafEnv <- run $ cafAnal g - cafEnv <- return $ extendEnvWithSafeForeignCalls cafTransfers cafEnv g - let localCAFs = catMaybes $ map (localCAFInfo cafEnv) gs - mbpprTrace "localCAFs" (ppr localCAFs) $ return () - - gs <- liftM concat $ run $ foldM lowerSafeForeignCalls [] gs - mapM_ (dump Opt_D_dump_cmmz "after lowerSafeForeignCalls") gs - - -- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES - let gs' = map (setInfoTableStackMap slotEnv areaMap) gs - mapM_ (dump Opt_D_dump_cmmz "after setInfoTableStackMap") gs' - let gs'' = map (bundleCAFs cafEnv) gs' - mapM_ (dump Opt_D_dump_cmmz "after bundleCAFs") gs'' - return (localCAFs, gs'') - where dflags = hsc_dflags hsc_env - mbpprTrace x y z = if dopt Opt_D_dump_cmmz dflags then pprTrace x y z else z - dump f txt g = dumpIfSet_dyn dflags f txt (ppr g) - - run :: FuelMonad a -> IO a - run = runFuelIO (hsc_OptFuel hsc_env) - - dual_rewrite flag txt pass g = - do dump flag ("Pre " ++ txt) g - g <- run $ pass g - dump flag ("Post " ++ txt) $ g - return g - --- This probably belongs in CmmBuildInfoTables? --- We're just finishing the job here: once we know what CAFs are defined --- in non-static closures, we can build the SRTs. -toTops :: HscEnv -> Map CLabel CAFSet -> (TopSRT, [[CmmTopZ]]) - -> [(CAFSet, CmmTopForInfoTables)] -> IO (TopSRT, [[CmmTopZ]]) - -toTops hsc_env topCAFEnv (topSRT, tops) gs = - do let setSRT (topSRT, rst) g = - do (topSRT, gs) <- setInfoTableSRT topCAFEnv topSRT g - return (topSRT, gs : rst) - (topSRT, gs') <- runFuelIO (hsc_OptFuel hsc_env) $ foldM setSRT (topSRT, []) gs - gs' <- mapM finishInfoTables (concat gs') - return (topSRT, concat gs' : tops) diff -Nru ghc-7.0.3/compiler/cmm/CmmCvt.hs ghc-7.2.1/compiler/cmm/CmmCvt.hs --- ghc-7.0.3/compiler/cmm/CmmCvt.hs 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/cmm/CmmCvt.hs 2011-08-07 17:10:05.000000000 +0000 @@ -1,4 +1,6 @@ -{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE GADTs #-} +-- ToDo: remove +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} module CmmCvt ( cmmToZgraph, cmmOfZgraph ) @@ -6,179 +8,171 @@ import BlockId import Cmm -import MkZipCfgCmm hiding (CmmGraph) -import ZipCfgCmmRep -- imported for reverse conversion -import CmmZipUtil -import PprCmm() -import qualified ZipCfg as G +import CmmDecl +import CmmExpr +import MkGraph +import qualified OldCmm as Old +import OldPprCmm () +import Platform -import FastString +import Compiler.Hoopl hiding ((<*>), mkLabel, mkBranch) import Control.Monad +import Data.Maybe +import Maybes import Outputable import UniqSupply -cmmToZgraph :: GenCmm d h (ListGraph CmmStmt) -> UniqSM (GenCmm d h (CmmStackInfo, CmmGraph)) -cmmOfZgraph :: GenCmm d h (CmmStackInfo, CmmGraph) -> GenCmm d h (ListGraph CmmStmt) +cmmToZgraph :: Platform -> Old.Cmm -> UniqSM Cmm +cmmOfZgraph :: Cmm -> Old.Cmm -cmmToZgraph (Cmm tops) = liftM Cmm $ mapM mapTop tops - where mapTop (CmmProc h l args g) = - toZgraph (showSDoc $ ppr l) args g >>= return . CmmProc h l args +cmmToZgraph platform (Cmm tops) = liftM Cmm $ mapM mapTop tops + where mapTop (CmmProc (Old.CmmInfo _ _ info_tbl) l g) = + do (stack_info, g) <- toZgraph platform (showSDoc $ ppr l) g + return $ CmmProc (TopInfo {info_tbl=info_tbl, stack_info=stack_info}) l g mapTop (CmmData s ds) = return $ CmmData s ds -cmmOfZgraph = cmmMapGraph (ofZgraph . snd) +cmmOfZgraph (Cmm tops) = Cmm $ map mapTop tops + where mapTop (CmmProc h l g) = CmmProc (Old.CmmInfo Nothing Nothing (info_tbl h)) l (ofZgraph g) + mapTop (CmmData s ds) = CmmData s ds -toZgraph :: String -> CmmFormals -> ListGraph CmmStmt -> UniqSM (CmmStackInfo, CmmGraph) -toZgraph _ _ (ListGraph []) = +toZgraph :: Platform -> String -> Old.ListGraph Old.CmmStmt -> UniqSM (CmmStackInfo, CmmGraph) +toZgraph _ _ (Old.ListGraph []) = do g <- lgraphOfAGraph emptyAGraph - return ((0, Nothing), g) -toZgraph fun_name args g@(ListGraph (BasicBlock id ss : other_blocks)) = - let (offset, entry) = mkEntry id NativeNodeCall args in + return (StackInfo {arg_space=0, updfr_space=Nothing}, g) +toZgraph platform fun_name g@(Old.ListGraph (Old.BasicBlock id ss : other_blocks)) = + let (offset, entry) = mkCallEntry NativeNodeCall [] in do g <- labelAGraph id $ entry <*> mkStmts ss <*> foldr addBlock emptyAGraph other_blocks - return ((offset, Nothing), g) - where addBlock (BasicBlock id ss) g = + return (StackInfo {arg_space = offset, updfr_space = Nothing}, g) + where addBlock (Old.BasicBlock id ss) g = mkLabel id <*> mkStmts ss <*> g updfr_sz = 0 -- panic "upd frame size lost in cmm conversion" - mkStmts (CmmNop : ss) = mkNop <*> mkStmts ss - mkStmts (CmmComment s : ss) = mkComment s <*> mkStmts ss - mkStmts (CmmAssign l r : ss) = mkAssign l r <*> mkStmts ss - mkStmts (CmmStore l r : ss) = mkStore l r <*> mkStmts ss - mkStmts (CmmCall (CmmCallee f conv) res args (CmmSafe _) CmmMayReturn : ss) = - mkCall f (conv', conv') (map hintlessCmm res) (map hintlessCmm args) updfr_sz - <*> mkStmts ss + mkStmts (Old.CmmNop : ss) = mkNop <*> mkStmts ss + mkStmts (Old.CmmComment s : ss) = mkComment s <*> mkStmts ss + mkStmts (Old.CmmAssign l r : ss) = mkAssign l r <*> mkStmts ss + mkStmts (Old.CmmStore l r : ss) = mkStore l r <*> mkStmts ss + mkStmts (Old.CmmCall (Old.CmmCallee f conv) res args (Old.CmmSafe _) Old.CmmMayReturn : ss) = + mkCall f (conv', conv') (map Old.hintlessCmm res) (map Old.hintlessCmm args) updfr_sz + <*> mkStmts ss where conv' = Foreign (ForeignConvention conv [] []) -- JD: DUBIOUS - mkStmts (CmmCall (CmmPrim {}) _ _ (CmmSafe _) _ : _) = + mkStmts (Old.CmmCall (Old.CmmPrim {}) _ _ (Old.CmmSafe _) _ : _) = panic "safe call to a primitive CmmPrim CallishMachOp" - mkStmts (CmmCall f res args CmmUnsafe CmmMayReturn : ss) = + mkStmts (Old.CmmCall f res args Old.CmmUnsafe Old.CmmMayReturn : ss) = mkUnsafeCall (convert_target f res args) - (strip_hints res) (strip_hints args) + (strip_hints res) (strip_hints args) <*> mkStmts ss - mkStmts (CmmCondBranch e l : fbranch) = + mkStmts (Old.CmmCondBranch e l : fbranch) = mkCmmIfThenElse e (mkBranch l) (mkStmts fbranch) mkStmts (last : []) = mkLast last mkStmts [] = bad "fell off end" mkStmts (_ : _ : _) = bad "last node not at end" - bad msg = pprPanic (msg ++ " in function " ++ fun_name) (ppr g) - mkLast (CmmCall (CmmCallee f conv) [] args _ CmmNeverReturns) = - mkFinalCall f conv (map hintlessCmm args) updfr_sz - mkLast (CmmCall (CmmPrim {}) _ _ _ CmmNeverReturns) = + bad msg = pprPanic (msg ++ " in function " ++ fun_name) (pprPlatform platform g) + mkLast (Old.CmmCall (Old.CmmCallee f conv) [] args _ Old.CmmNeverReturns) = + mkFinalCall f conv (map Old.hintlessCmm args) updfr_sz + mkLast (Old.CmmCall (Old.CmmPrim {}) _ _ _ Old.CmmNeverReturns) = panic "Call to CmmPrim never returns?!" - mkLast (CmmSwitch scrutinee table) = mkSwitch scrutinee table + mkLast (Old.CmmSwitch scrutinee table) = mkSwitch scrutinee table -- SURELY, THESE HINTLESS ARGS ARE WRONG AND WILL BE FIXED WHEN CALLING -- CONVENTIONS ARE HONORED? - mkLast (CmmJump tgt args) = mkJump tgt (map hintlessCmm args) updfr_sz - mkLast (CmmReturn ress) = - mkReturnSimple (map hintlessCmm ress) updfr_sz - mkLast (CmmBranch tgt) = mkBranch tgt - mkLast (CmmCall _f (_:_) _args _ CmmNeverReturns) = + mkLast (Old.CmmJump tgt args) = mkJump tgt (map Old.hintlessCmm args) updfr_sz + mkLast (Old.CmmReturn ress) = + mkReturnSimple (map Old.hintlessCmm ress) updfr_sz + mkLast (Old.CmmBranch tgt) = mkBranch tgt + mkLast (Old.CmmCall _f (_:_) _args _ Old.CmmNeverReturns) = panic "Call never returns but has results?!" mkLast _ = panic "fell off end of block" -strip_hints :: [CmmHinted a] -> [a] -strip_hints = map hintlessCmm +strip_hints :: [Old.CmmHinted a] -> [a] +strip_hints = map Old.hintlessCmm -convert_target :: CmmCallTarget -> HintedCmmFormals -> HintedCmmActuals -> MidCallTarget -convert_target (CmmCallee e cc) ress args = ForeignTarget e (ForeignConvention cc (map cmmHint args) (map cmmHint ress)) -convert_target (CmmPrim op) _ress _args = PrimTarget op +convert_target :: Old.CmmCallTarget -> [Old.HintedCmmFormal] -> [Old.HintedCmmActual] -> ForeignTarget +convert_target (Old.CmmCallee e cc) ress args = ForeignTarget e (ForeignConvention cc (map Old.cmmHint args) (map Old.cmmHint ress)) +convert_target (Old.CmmPrim op) _ress _args = PrimTarget op -add_hints :: Convention -> ValueDirection -> [a] -> [CmmHinted a] -add_hints conv vd args = zipWith CmmHinted args (get_hints conv vd) +data ValueDirection = Arguments | Results + +add_hints :: Convention -> ValueDirection -> [a] -> [Old.CmmHinted a] +add_hints conv vd args = zipWith Old.CmmHinted args (get_hints conv vd) get_hints :: Convention -> ValueDirection -> [ForeignHint] get_hints (Foreign (ForeignConvention _ hints _)) Arguments = hints get_hints (Foreign (ForeignConvention _ _ hints)) Results = hints -get_hints _other_conv _vd = repeat NoHint +get_hints _other_conv _vd = repeat NoHint -get_conv :: MidCallTarget -> Convention +get_conv :: ForeignTarget -> Convention get_conv (PrimTarget _) = NativeNodeCall -- JD: SUSPICIOUS get_conv (ForeignTarget _ fc) = Foreign fc -cmm_target :: MidCallTarget -> CmmCallTarget -cmm_target (PrimTarget op) = CmmPrim op -cmm_target (ForeignTarget e (ForeignConvention cc _ _)) = CmmCallee e cc - -ofZgraph :: CmmGraph -> ListGraph CmmStmt -ofZgraph g = ListGraph $ swallow blocks - where blocks = G.postorder_dfs g - -- | the next two functions are hooks on which to hang debugging info - extend_entry stmts = stmts - extend_block _id stmts = stmts - _extend_entry stmts = scomment showblocks : scomment cscomm : stmts - showblocks = "LGraph has " ++ show (length blocks) ++ " blocks:" ++ - concat (map (\(G.Block id _) -> " " ++ show id) blocks) - cscomm = "Call successors are" ++ - (concat $ map (\id -> " " ++ show id) $ blockSetToList call_succs) - swallow [] = [] - swallow (G.Block id t : rest) = tail id [] t rest - tail id prev' (G.ZTail m t) rest = tail id (mid m : prev') t rest - tail id prev' (G.ZLast G.LastExit) rest = exit id prev' rest - tail id prev' (G.ZLast (G.LastOther l)) rest = last id prev' l rest - mid (MidComment s) = CmmComment s - mid (MidAssign l r) = CmmAssign l r - mid (MidStore l r) = CmmStore l r - mid (MidForeignCall _ (PrimTarget MO_Touch) _ _) = CmmNop - mid (MidForeignCall _ target ress args) - = CmmCall (cmm_target target) - (add_hints conv Results ress) - (add_hints conv Arguments args) - CmmUnsafe CmmMayReturn - where - conv = get_conv target - block' id prev' - | id == G.lg_entry g = BasicBlock id $ extend_entry (reverse prev') - | otherwise = BasicBlock id $ extend_block id (reverse prev') - last id prev' l n = - let endblock stmt = block' id (stmt : prev') : swallow n in - case l of - LastBranch tgt -> - case n of - -- THIS OPT IS WRONG -- LABELS CAN SHOW UP ELSEWHERE IN THE GRAPH - --G.Block id' _ t : bs - -- | tgt == id', unique_pred id' - -- -> tail id prev' t bs -- optimize out redundant labels - _ -> endblock (CmmBranch tgt) - LastCondBranch expr tid fid -> - case n of - G.Block id' t : bs - -- It would be better to handle earlier, but we still must - -- generate correct code here. - | id' == fid, tid == fid, unique_pred id' -> - tail id prev' t bs - | id' == fid, unique_pred id' -> - tail id (CmmCondBranch expr tid : prev') t bs - | id' == tid, unique_pred id', - Just e' <- maybeInvertCmmExpr expr -> - tail id (CmmCondBranch e' fid : prev') t bs - _ -> let instrs' = CmmBranch fid : CmmCondBranch expr tid : prev' - in block' id instrs' : swallow n - LastSwitch arg ids -> endblock $ CmmSwitch arg $ ids - LastCall e _ _ _ _ -> endblock $ CmmJump e [] - exit id prev' n = -- highly irregular (assertion violation?) - let endblock stmt = block' id (stmt : prev') : swallow n in - case n of [] -> endblock (scomment "procedure falls off end") - G.Block id' t : bs -> - if unique_pred id' then - tail id (scomment "went thru exit" : prev') t bs - else - endblock (CmmBranch id') - preds = zipPreds g - single_preds = - let add b single = - let id = G.blockId b - in case lookupBlockEnv preds id of - Nothing -> single - Just s -> if sizeBlockSet s == 1 then - extendBlockSet single id - else single - in G.fold_blocks add emptyBlockSet g - unique_pred id = elemBlockSet id single_preds - call_succs = - let add b succs = - case G.last (G.unzip b) of - G.LastOther (LastCall _ (Just id) _ _ _) -> - extendBlockSet succs id - _ -> succs - in G.fold_blocks add emptyBlockSet g - _is_call_succ id = elemBlockSet id call_succs - -scomment :: String -> CmmStmt -scomment s = CmmComment $ mkFastString s +cmm_target :: ForeignTarget -> Old.CmmCallTarget +cmm_target (PrimTarget op) = Old.CmmPrim op +cmm_target (ForeignTarget e (ForeignConvention cc _ _)) = Old.CmmCallee e cc + +ofZgraph :: CmmGraph -> Old.ListGraph Old.CmmStmt +ofZgraph g = Old.ListGraph $ mapMaybe convert_block $ postorderDfs g + -- We catenated some blocks in the conversion process, + -- because of the CmmCondBranch -- the machine code does not have + -- 'jump here or there' instruction, but has 'jump if true' instruction. + -- As OldCmm has the same instruction, so we use it. + -- When we are doing this, we also catenate normal goto-s (it is for free). + + -- Exactly, we catenate blocks with nonentry labes, that are + -- a) mentioned exactly once as a successor + -- b) any of 1) are a target of a goto + -- 2) are false branch target of a conditional jump + -- 3) are true branch target of a conditional jump, and + -- the false branch target is a successor of at least 2 blocks + -- and the condition can be inverted + -- The complicated rule 3) is here because we need to assign at most one + -- catenable block to a CmmCondBranch. + where preds :: BlockEnv [CmmNode O C] + preds = mapFold add mapEmpty $ toBlockMap g + where add block env = foldr (add' $ lastNode block) env (successors block) + add' :: CmmNode O C -> BlockId -> BlockEnv [CmmNode O C] -> BlockEnv [CmmNode O C] + add' node succ env = mapInsert succ (node : (mapLookup succ env `orElse` [])) env + + to_be_catenated :: BlockId -> Bool + to_be_catenated id | id == g_entry g = False + | Just [CmmBranch _] <- mapLookup id preds = True + | Just [CmmCondBranch _ _ f] <- mapLookup id preds + , f == id = True + | Just [CmmCondBranch e t f] <- mapLookup id preds + , t == id + , Just (_:_:_) <- mapLookup f preds + , Just _ <- maybeInvertCmmExpr e = True + to_be_catenated _ = False + + convert_block block | to_be_catenated (entryLabel block) = Nothing + convert_block block = Just $ foldBlockNodesB3 (first, middle, last) block () + where first :: CmmNode C O -> [Old.CmmStmt] -> Old.CmmBasicBlock + first (CmmEntry bid) stmts = Old.BasicBlock bid stmts + + middle :: CmmNode O O -> [Old.CmmStmt] -> [Old.CmmStmt] + middle node stmts = stmt : stmts + where stmt :: Old.CmmStmt + stmt = case node of + CmmComment s -> Old.CmmComment s + CmmAssign l r -> Old.CmmAssign l r + CmmStore l r -> Old.CmmStore l r + CmmUnsafeForeignCall (PrimTarget MO_Touch) _ _ -> Old.CmmNop + CmmUnsafeForeignCall target ress args -> + Old.CmmCall (cmm_target target) + (add_hints (get_conv target) Results ress) + (add_hints (get_conv target) Arguments args) + Old.CmmUnsafe Old.CmmMayReturn + + last :: CmmNode O C -> () -> [Old.CmmStmt] + last node _ = stmts + where stmts :: [Old.CmmStmt] + stmts = case node of + CmmBranch tgt | to_be_catenated tgt -> tail_of tgt + | otherwise -> [Old.CmmBranch tgt] + CmmCondBranch expr tid fid + | to_be_catenated fid -> Old.CmmCondBranch expr tid : tail_of fid + | to_be_catenated tid + , Just expr' <- maybeInvertCmmExpr expr -> Old.CmmCondBranch expr' fid : tail_of tid + | otherwise -> [Old.CmmCondBranch expr tid, Old.CmmBranch fid] + CmmSwitch arg ids -> [Old.CmmSwitch arg ids] + CmmCall e _ _ _ _ -> [Old.CmmJump e []] + CmmForeignCall {} -> panic "ofZgraph: CmmForeignCall" + tail_of bid = case foldBlockNodesB3 (first, middle, last) block () of + Old.BasicBlock _ stmts -> stmts + where Just block = mapLookup bid $ toBlockMap g diff -Nru ghc-7.0.3/compiler/cmm/CmmDecl.hs ghc-7.2.1/compiler/cmm/CmmDecl.hs --- ghc-7.0.3/compiler/cmm/CmmDecl.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/compiler/cmm/CmmDecl.hs 2011-08-07 17:10:05.000000000 +0000 @@ -0,0 +1,139 @@ +----------------------------------------------------------------------------- +-- +-- Cmm data types +-- +-- (c) The University of Glasgow 2004-2006 +-- +----------------------------------------------------------------------------- + +module CmmDecl ( + GenCmm(..), GenCmmTop(..), + CmmInfoTable(..), HasStaticClosure, ClosureTypeInfo(..), ConstrDescription, + ProfilingInfo(..), ClosureTypeTag, + CmmActual, CmmFormal, ForeignHint(..), + CmmStatics(..), CmmStatic(..), Section(..), + ) where + +#include "HsVersions.h" + +import CmmExpr +import CLabel +import SMRep +import ClosureInfo + +import Data.Word + + +-- A [[BlockId]] is a local label. +-- Local labels must be unique within an entire compilation unit, not +-- just a single top-level item, because local labels map one-to-one +-- with assembly-language labels. + +----------------------------------------------------------------------------- +-- GenCmm, GenCmmTop +----------------------------------------------------------------------------- + +-- A file is a list of top-level chunks. These may be arbitrarily +-- re-orderd during code generation. + +-- GenCmm is abstracted over +-- d, the type of static data elements in CmmData +-- h, the static info preceding the code of a CmmProc +-- g, the control-flow graph of a CmmProc +-- +-- We expect there to be two main instances of this type: +-- (a) C--, i.e. populated with various C-- constructs +-- (Cmm and RawCmm in OldCmm.hs) +-- (b) Native code, populated with data/instructions +-- +-- A second family of instances based on Hoopl is in Cmm.hs. +-- +newtype GenCmm d h g = Cmm [GenCmmTop d h g] + +-- | A top-level chunk, abstracted over the type of the contents of +-- the basic blocks (Cmm or instructions are the likely instantiations). +data GenCmmTop d h g + = CmmProc -- A procedure + h -- Extra header such as the info table + CLabel -- Entry label + g -- Control-flow graph for the procedure's code + + | CmmData -- Static data + Section + d + + +----------------------------------------------------------------------------- +-- Info Tables +----------------------------------------------------------------------------- + +-- Info table as a haskell data type +data CmmInfoTable + = CmmInfoTable + CLabel -- Info table label + HasStaticClosure + ProfilingInfo + ClosureTypeTag -- Int + ClosureTypeInfo + | CmmNonInfoTable -- Procedure doesn't need an info table + +type HasStaticClosure = Bool + +-- TODO: The GC target shouldn't really be part of CmmInfo +-- as it doesn't appear in the resulting info table. +-- It should be factored out. + +data ClosureTypeInfo + = ConstrInfo ClosureLayout ConstrTag ConstrDescription + | FunInfo ClosureLayout C_SRT FunArity ArgDescr SlowEntry + | ThunkInfo ClosureLayout C_SRT + | ThunkSelectorInfo SelectorOffset C_SRT + | ContInfo + [Maybe LocalReg] -- Stack layout: Just x, an item x + -- Nothing: a 1-word gap + -- Start of list is the *young* end + C_SRT + +-- TODO: These types may need refinement +data ProfilingInfo = ProfilingInfo CmmLit CmmLit -- closure_type, closure_desc +type ClosureTypeTag = StgHalfWord +type ClosureLayout = (StgHalfWord, StgHalfWord) -- ptrs, nptrs +type ConstrTag = StgHalfWord +type ConstrDescription = CmmLit +type FunArity = StgHalfWord +type SlowEntry = CmmLit + -- We would like this to be a CLabel but + -- for now the parser sets this to zero on an INFO_TABLE_FUN. +type SelectorOffset = StgWord + +type CmmActual = CmmExpr +type CmmFormal = LocalReg + +data ForeignHint + = NoHint | AddrHint | SignedHint + deriving( Eq ) + -- Used to give extra per-argument or per-result + -- information needed by foreign calling conventions + +----------------------------------------------------------------------------- +-- Static Data +----------------------------------------------------------------------------- + +data Section + = Text + | Data + | ReadOnlyData + | RelocatableReadOnlyData + | UninitialisedData + | ReadOnlyData16 -- .rodata.cst16 on x86_64, 16-byte aligned + | OtherSection String + +data CmmStatic + = CmmStaticLit CmmLit + -- a literal value, size given by cmmLitRep of the literal. + | CmmUninitialised Int + -- uninitialised data, N bytes long + | CmmString [Word8] + -- string of 8-bit values only, not zero terminated. + +data CmmStatics = Statics CLabel {- Label of statics -} [CmmStatic] {- The static data itself -} diff -Nru ghc-7.0.3/compiler/cmm/CmmExpr.hs ghc-7.2.1/compiler/cmm/CmmExpr.hs --- ghc-7.0.3/compiler/cmm/CmmExpr.hs 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/cmm/CmmExpr.hs 2011-08-07 17:10:05.000000000 +0000 @@ -1,60 +1,31 @@ module CmmExpr - ( CmmType -- Abstract - , b8, b16, b32, b64, f32, f64, bWord, bHalfWord, gcWord - , cInt, cLong - , cmmBits, cmmFloat - , typeWidth, cmmEqType, cmmEqType_ignoring_ptrhood - , isFloatType, isGcPtrType, isWord32, isWord64, isFloat64, isFloat32 - - , Width(..) - , widthInBits, widthInBytes, widthInLog, widthFromBytes - , wordWidth, halfWordWidth, cIntWidth, cLongWidth - , narrowU, narrowS - - , CmmExpr(..), cmmExprType, cmmExprWidth, maybeInvertCmmExpr + ( CmmExpr(..), cmmExprType, cmmExprWidth, maybeInvertCmmExpr , CmmReg(..), cmmRegType , CmmLit(..), cmmLitType , LocalReg(..), localRegType - , GlobalReg(..), globalRegType, spReg, hpReg, spLimReg, nodeReg, node + , GlobalReg(..), globalRegType, spReg, hpReg, spLimReg, nodeReg, node, baseReg , VGcPtr(..), vgcFlag -- Temporary! , DefinerOfLocalRegs, UserOfLocalRegs, foldRegsDefd, foldRegsUsed, filterRegsUsed , DefinerOfSlots, UserOfSlots, foldSlotsDefd, foldSlotsUsed , RegSet, emptyRegSet, elemRegSet, extendRegSet, deleteFromRegSet, mkRegSet , plusRegSet, minusRegSet, timesRegSet - , regUsedIn + , regUsedIn, regSlot , Area(..), AreaId(..), SubArea, SubAreaSet, AreaMap, isStackSlotOf - - -- MachOp - , MachOp(..) - , pprMachOp, isCommutableMachOp, isAssociativeMachOp - , isComparisonMachOp, machOpResultType - , machOpArgReps, maybeInvertComparison - - -- MachOp builders - , mo_wordAdd, mo_wordSub, mo_wordEq, mo_wordNe,mo_wordMul, mo_wordSQuot - , mo_wordSRem, mo_wordSNeg, mo_wordUQuot, mo_wordURem - , mo_wordSGe, mo_wordSLe, mo_wordSGt, mo_wordSLt, mo_wordUGe - , mo_wordULe, mo_wordUGt, mo_wordULt - , mo_wordAnd, mo_wordOr, mo_wordXor, mo_wordNot, mo_wordShl, mo_wordSShr, mo_wordUShr - , mo_u_8To32, mo_s_8To32, mo_u_16To32, mo_s_16To32 - , mo_u_8ToWord, mo_s_8ToWord, mo_u_16ToWord, mo_s_16ToWord, mo_u_32ToWord, mo_s_32ToWord - , mo_32To8, mo_32To16, mo_WordTo8, mo_WordTo16, mo_WordTo32 - ) + , module CmmMachOp + , module CmmType + ) where #include "HsVersions.h" +import CmmType +import CmmMachOp import BlockId import CLabel -import Constants -import FastString -import Outputable import Unique import UniqSet -import Data.Word -import Data.Int import Data.Map (Map) ----------------------------------------------------------------------------- @@ -71,8 +42,8 @@ | CmmRegOff CmmReg Int -- CmmRegOff reg i -- ** is shorthand only, meaning ** - -- CmmMachOp (MO_S_Add rep (CmmReg reg) (CmmLit (CmmInt i rep))) - -- where rep = cmmRegType reg + -- CmmMachOp (MO_Add rep) [x, CmmLit (CmmInt (fromIntegral i) rep)] + -- where rep = typeWidth (cmmRegType reg) instance Eq CmmExpr where -- Equality ignores the types CmmLit l1 == CmmLit l2 = l1==l2 @@ -153,6 +124,8 @@ cmmExprType (CmmMachOp op args) = machOpResultType op (map cmmExprType args) cmmExprType (CmmRegOff reg _) = cmmRegType reg cmmExprType (CmmStackSlot _ _) = bWord -- an address +-- Careful though: what is stored at the stack slot may be bigger than +-- an address cmmLitType :: CmmLit -> CmmType cmmLitType (CmmInt _ width) = cmmBits width @@ -294,6 +267,9 @@ isStackSlotOf (CmmStackSlot (RegSlot r) _) r' = r == r' isStackSlotOf _ _ = False +regSlot :: LocalReg -> CmmExpr +regSlot r = CmmStackSlot (RegSlot r) (widthInBytes $ typeWidth $ localRegType r) + ----------------------------------------------------------------------------- -- Stack slot use information for expressions and other types [_$_] ----------------------------------------------------------------------------- @@ -319,6 +295,12 @@ foldSlotsUsed _ set [] = set foldSlotsUsed f set (x:xs) = foldSlotsUsed f (foldSlotsUsed f set x) xs +instance DefinerOfSlots a => DefinerOfSlots [a] where + foldSlotsDefd _ set [] = set + foldSlotsDefd f set (x:xs) = foldSlotsDefd f (foldSlotsDefd f set x) xs + +instance DefinerOfSlots SubArea where + foldSlotsDefd f z a = f z a ----------------------------------------------------------------------------- -- Global STG registers @@ -446,7 +428,8 @@ compare _ EagerBlackholeInfo = GT -- convenient aliases -spReg, hpReg, spLimReg, nodeReg :: CmmReg +baseReg, spReg, hpReg, spLimReg, nodeReg :: CmmReg +baseReg = CmmGlobal BaseReg spReg = CmmGlobal Sp hpReg = CmmGlobal Hp spLimReg = CmmGlobal SpLim @@ -464,695 +447,3 @@ globalRegType Hp = gcWord -- The initialiser for all -- dynamically allocated closures globalRegType _ = bWord - - ------------------------------------------------------------------------------ --- CmmType ------------------------------------------------------------------------------ - - -- NOTE: CmmType is an abstract type, not exported from this - -- module so you can easily change its representation - -- - -- However Width is exported in a concrete way, - -- and is used extensively in pattern-matching - -data CmmType -- The important one! - = CmmType CmmCat Width - -data CmmCat -- "Category" (not exported) - = GcPtrCat -- GC pointer - | BitsCat -- Non-pointer - | FloatCat -- Float - deriving( Eq ) - -- See Note [Signed vs unsigned] at the end - -instance Outputable CmmType where - ppr (CmmType cat wid) = ppr cat <> ppr (widthInBits wid) - -instance Outputable CmmCat where - ppr FloatCat = ptext $ sLit("F") - ppr _ = ptext $ sLit("I") --- Temp Jan 08 --- ppr FloatCat = ptext $ sLit("float") --- ppr BitsCat = ptext $ sLit("bits") --- ppr GcPtrCat = ptext $ sLit("gcptr") - --- Why is CmmType stratified? For native code generation, --- most of the time you just want to know what sort of register --- to put the thing in, and for this you need to know how --- many bits thing has and whether it goes in a floating-point --- register. By contrast, the distinction between GcPtr and --- GcNonPtr is of interest to only a few parts of the code generator. - --------- Equality on CmmType -------------- --- CmmType is *not* an instance of Eq; sometimes we care about the --- Gc/NonGc distinction, and sometimes we don't --- So we use an explicit function to force you to think about it -cmmEqType :: CmmType -> CmmType -> Bool -- Exact equality -cmmEqType (CmmType c1 w1) (CmmType c2 w2) = c1==c2 && w1==w2 - -cmmEqType_ignoring_ptrhood :: CmmType -> CmmType -> Bool - -- This equality is temporary; used in CmmLint - -- but the RTS files are not yet well-typed wrt pointers -cmmEqType_ignoring_ptrhood (CmmType c1 w1) (CmmType c2 w2) - = c1 `weak_eq` c2 && w1==w2 - where - FloatCat `weak_eq` FloatCat = True - FloatCat `weak_eq` _other = False - _other `weak_eq` FloatCat = False - _word1 `weak_eq` _word2 = True -- Ignores GcPtr - ---- Simple operations on CmmType ----- -typeWidth :: CmmType -> Width -typeWidth (CmmType _ w) = w - -cmmBits, cmmFloat :: Width -> CmmType -cmmBits = CmmType BitsCat -cmmFloat = CmmType FloatCat - --------- Common CmmTypes ------------ --- Floats and words of specific widths -b8, b16, b32, b64, f32, f64 :: CmmType -b8 = cmmBits W8 -b16 = cmmBits W16 -b32 = cmmBits W32 -b64 = cmmBits W64 -f32 = cmmFloat W32 -f64 = cmmFloat W64 - --- CmmTypes of native word widths -bWord, bHalfWord, gcWord :: CmmType -bWord = cmmBits wordWidth -bHalfWord = cmmBits halfWordWidth -gcWord = CmmType GcPtrCat wordWidth - -cInt, cLong :: CmmType -cInt = cmmBits cIntWidth -cLong = cmmBits cLongWidth - - ------------- Predicates ---------------- -isFloatType, isGcPtrType :: CmmType -> Bool -isFloatType (CmmType FloatCat _) = True -isFloatType _other = False - -isGcPtrType (CmmType GcPtrCat _) = True -isGcPtrType _other = False - -isWord32, isWord64, isFloat32, isFloat64 :: CmmType -> Bool --- isWord64 is true of 64-bit non-floats (both gc-ptrs and otherwise) --- isFloat32 and 64 are obvious - -isWord64 (CmmType BitsCat W64) = True -isWord64 (CmmType GcPtrCat W64) = True -isWord64 _other = False - -isWord32 (CmmType BitsCat W32) = True -isWord32 (CmmType GcPtrCat W32) = True -isWord32 _other = False - -isFloat32 (CmmType FloatCat W32) = True -isFloat32 _other = False - -isFloat64 (CmmType FloatCat W64) = True -isFloat64 _other = False - ------------------------------------------------------------------------------ --- Width ------------------------------------------------------------------------------ - -data Width = W8 | W16 | W32 | W64 - | W80 -- Extended double-precision float, - -- used in x86 native codegen only. - -- (we use Ord, so it'd better be in this order) - | W128 - deriving (Eq, Ord, Show) - -instance Outputable Width where - ppr rep = ptext (mrStr rep) - -mrStr :: Width -> LitString -mrStr W8 = sLit("W8") -mrStr W16 = sLit("W16") -mrStr W32 = sLit("W32") -mrStr W64 = sLit("W64") -mrStr W128 = sLit("W128") -mrStr W80 = sLit("W80") - - --------- Common Widths ------------ -wordWidth, halfWordWidth :: Width -wordWidth | wORD_SIZE == 4 = W32 - | wORD_SIZE == 8 = W64 - | otherwise = panic "MachOp.wordRep: Unknown word size" - -halfWordWidth | wORD_SIZE == 4 = W16 - | wORD_SIZE == 8 = W32 - | otherwise = panic "MachOp.halfWordRep: Unknown word size" - --- cIntRep is the Width for a C-language 'int' -cIntWidth, cLongWidth :: Width -#if SIZEOF_INT == 4 -cIntWidth = W32 -#elif SIZEOF_INT == 8 -cIntWidth = W64 -#endif - -#if SIZEOF_LONG == 4 -cLongWidth = W32 -#elif SIZEOF_LONG == 8 -cLongWidth = W64 -#endif - -widthInBits :: Width -> Int -widthInBits W8 = 8 -widthInBits W16 = 16 -widthInBits W32 = 32 -widthInBits W64 = 64 -widthInBits W128 = 128 -widthInBits W80 = 80 - -widthInBytes :: Width -> Int -widthInBytes W8 = 1 -widthInBytes W16 = 2 -widthInBytes W32 = 4 -widthInBytes W64 = 8 -widthInBytes W128 = 16 -widthInBytes W80 = 10 - -widthFromBytes :: Int -> Width -widthFromBytes 1 = W8 -widthFromBytes 2 = W16 -widthFromBytes 4 = W32 -widthFromBytes 8 = W64 -widthFromBytes 16 = W128 -widthFromBytes 10 = W80 -widthFromBytes n = pprPanic "no width for given number of bytes" (ppr n) - --- log_2 of the width in bytes, useful for generating shifts. -widthInLog :: Width -> Int -widthInLog W8 = 0 -widthInLog W16 = 1 -widthInLog W32 = 2 -widthInLog W64 = 3 -widthInLog W128 = 4 -widthInLog W80 = panic "widthInLog: F80" - --- widening / narrowing - -narrowU :: Width -> Integer -> Integer -narrowU W8 x = fromIntegral (fromIntegral x :: Word8) -narrowU W16 x = fromIntegral (fromIntegral x :: Word16) -narrowU W32 x = fromIntegral (fromIntegral x :: Word32) -narrowU W64 x = fromIntegral (fromIntegral x :: Word64) -narrowU _ _ = panic "narrowTo" - -narrowS :: Width -> Integer -> Integer -narrowS W8 x = fromIntegral (fromIntegral x :: Int8) -narrowS W16 x = fromIntegral (fromIntegral x :: Int16) -narrowS W32 x = fromIntegral (fromIntegral x :: Int32) -narrowS W64 x = fromIntegral (fromIntegral x :: Int64) -narrowS _ _ = panic "narrowTo" - ------------------------------------------------------------------------------ --- MachOp ------------------------------------------------------------------------------ - -{- -Implementation notes: - -It might suffice to keep just a width, without distinguishing between -floating and integer types. However, keeping the distinction will -help the native code generator to assign registers more easily. --} - - -{- | -Machine-level primops; ones which we can reasonably delegate to the -native code generators to handle. Basically contains C's primops -and no others. - -Nomenclature: all ops indicate width and signedness, where -appropriate. Widths: 8\/16\/32\/64 means the given size, obviously. -Nat means the operation works on STG word sized objects. -Signedness: S means signed, U means unsigned. For operations where -signedness is irrelevant or makes no difference (for example -integer add), the signedness component is omitted. - -An exception: NatP is a ptr-typed native word. From the point of -view of the native code generators this distinction is irrelevant, -but the C code generator sometimes needs this info to emit the -right casts. --} - -data MachOp - -- Integer operations (insensitive to signed/unsigned) - = MO_Add Width - | MO_Sub Width - | MO_Eq Width - | MO_Ne Width - | MO_Mul Width -- low word of multiply - - -- Signed multiply/divide - | MO_S_MulMayOflo Width -- nonzero if signed multiply overflows - | MO_S_Quot Width -- signed / (same semantics as IntQuotOp) - | MO_S_Rem Width -- signed % (same semantics as IntRemOp) - | MO_S_Neg Width -- unary - - - -- Unsigned multiply/divide - | MO_U_MulMayOflo Width -- nonzero if unsigned multiply overflows - | MO_U_Quot Width -- unsigned / (same semantics as WordQuotOp) - | MO_U_Rem Width -- unsigned % (same semantics as WordRemOp) - - -- Signed comparisons - | MO_S_Ge Width - | MO_S_Le Width - | MO_S_Gt Width - | MO_S_Lt Width - - -- Unsigned comparisons - | MO_U_Ge Width - | MO_U_Le Width - | MO_U_Gt Width - | MO_U_Lt Width - - -- Floating point arithmetic - | MO_F_Add Width - | MO_F_Sub Width - | MO_F_Neg Width -- unary - - | MO_F_Mul Width - | MO_F_Quot Width - - -- Floating point comparison - | MO_F_Eq Width - | MO_F_Ne Width - | MO_F_Ge Width - | MO_F_Le Width - | MO_F_Gt Width - | MO_F_Lt Width - - -- Bitwise operations. Not all of these may be supported - -- at all sizes, and only integral Widths are valid. - | MO_And Width - | MO_Or Width - | MO_Xor Width - | MO_Not Width - | MO_Shl Width - | MO_U_Shr Width -- unsigned shift right - | MO_S_Shr Width -- signed shift right - - -- Conversions. Some of these will be NOPs. - -- Floating-point conversions use the signed variant. - | MO_SF_Conv Width Width -- Signed int -> Float - | MO_FS_Conv Width Width -- Float -> Signed int - | MO_SS_Conv Width Width -- Signed int -> Signed int - | MO_UU_Conv Width Width -- unsigned int -> unsigned int - | MO_FF_Conv Width Width -- Float -> Float - deriving (Eq, Show) - -pprMachOp :: MachOp -> SDoc -pprMachOp mo = text (show mo) - - - --- ----------------------------------------------------------------------------- --- Some common MachReps - --- A 'wordRep' is a machine word on the target architecture --- Specifically, it is the size of an Int#, Word#, Addr# --- and the unit of allocation on the stack and the heap --- Any pointer is also guaranteed to be a wordRep. - -mo_wordAdd, mo_wordSub, mo_wordEq, mo_wordNe,mo_wordMul, mo_wordSQuot - , mo_wordSRem, mo_wordSNeg, mo_wordUQuot, mo_wordURem - , mo_wordSGe, mo_wordSLe, mo_wordSGt, mo_wordSLt, mo_wordUGe - , mo_wordULe, mo_wordUGt, mo_wordULt - , mo_wordAnd, mo_wordOr, mo_wordXor, mo_wordNot, mo_wordShl, mo_wordSShr, mo_wordUShr - , mo_u_8To32, mo_s_8To32, mo_u_16To32, mo_s_16To32 - , mo_u_8ToWord, mo_s_8ToWord, mo_u_16ToWord, mo_s_16ToWord, mo_u_32ToWord, mo_s_32ToWord - , mo_32To8, mo_32To16, mo_WordTo8, mo_WordTo16, mo_WordTo32 - :: MachOp - -mo_wordAdd = MO_Add wordWidth -mo_wordSub = MO_Sub wordWidth -mo_wordEq = MO_Eq wordWidth -mo_wordNe = MO_Ne wordWidth -mo_wordMul = MO_Mul wordWidth -mo_wordSQuot = MO_S_Quot wordWidth -mo_wordSRem = MO_S_Rem wordWidth -mo_wordSNeg = MO_S_Neg wordWidth -mo_wordUQuot = MO_U_Quot wordWidth -mo_wordURem = MO_U_Rem wordWidth - -mo_wordSGe = MO_S_Ge wordWidth -mo_wordSLe = MO_S_Le wordWidth -mo_wordSGt = MO_S_Gt wordWidth -mo_wordSLt = MO_S_Lt wordWidth - -mo_wordUGe = MO_U_Ge wordWidth -mo_wordULe = MO_U_Le wordWidth -mo_wordUGt = MO_U_Gt wordWidth -mo_wordULt = MO_U_Lt wordWidth - -mo_wordAnd = MO_And wordWidth -mo_wordOr = MO_Or wordWidth -mo_wordXor = MO_Xor wordWidth -mo_wordNot = MO_Not wordWidth -mo_wordShl = MO_Shl wordWidth -mo_wordSShr = MO_S_Shr wordWidth -mo_wordUShr = MO_U_Shr wordWidth - -mo_u_8To32 = MO_UU_Conv W8 W32 -mo_s_8To32 = MO_SS_Conv W8 W32 -mo_u_16To32 = MO_UU_Conv W16 W32 -mo_s_16To32 = MO_SS_Conv W16 W32 - -mo_u_8ToWord = MO_UU_Conv W8 wordWidth -mo_s_8ToWord = MO_SS_Conv W8 wordWidth -mo_u_16ToWord = MO_UU_Conv W16 wordWidth -mo_s_16ToWord = MO_SS_Conv W16 wordWidth -mo_s_32ToWord = MO_SS_Conv W32 wordWidth -mo_u_32ToWord = MO_UU_Conv W32 wordWidth - -mo_WordTo8 = MO_UU_Conv wordWidth W8 -mo_WordTo16 = MO_UU_Conv wordWidth W16 -mo_WordTo32 = MO_UU_Conv wordWidth W32 - -mo_32To8 = MO_UU_Conv W32 W8 -mo_32To16 = MO_UU_Conv W32 W16 - - --- ---------------------------------------------------------------------------- --- isCommutableMachOp - -{- | -Returns 'True' if the MachOp has commutable arguments. This is used -in the platform-independent Cmm optimisations. - -If in doubt, return 'False'. This generates worse code on the -native routes, but is otherwise harmless. --} -isCommutableMachOp :: MachOp -> Bool -isCommutableMachOp mop = - case mop of - MO_Add _ -> True - MO_Eq _ -> True - MO_Ne _ -> True - MO_Mul _ -> True - MO_S_MulMayOflo _ -> True - MO_U_MulMayOflo _ -> True - MO_And _ -> True - MO_Or _ -> True - MO_Xor _ -> True - _other -> False - --- ---------------------------------------------------------------------------- --- isAssociativeMachOp - -{- | -Returns 'True' if the MachOp is associative (i.e. @(x+y)+z == x+(y+z)@) -This is used in the platform-independent Cmm optimisations. - -If in doubt, return 'False'. This generates worse code on the -native routes, but is otherwise harmless. --} -isAssociativeMachOp :: MachOp -> Bool -isAssociativeMachOp mop = - case mop of - MO_Add {} -> True -- NB: does not include - MO_Mul {} -> True -- floatint point! - MO_And {} -> True - MO_Or {} -> True - MO_Xor {} -> True - _other -> False - --- ---------------------------------------------------------------------------- --- isComparisonMachOp - -{- | -Returns 'True' if the MachOp is a comparison. - -If in doubt, return False. This generates worse code on the -native routes, but is otherwise harmless. --} -isComparisonMachOp :: MachOp -> Bool -isComparisonMachOp mop = - case mop of - MO_Eq _ -> True - MO_Ne _ -> True - MO_S_Ge _ -> True - MO_S_Le _ -> True - MO_S_Gt _ -> True - MO_S_Lt _ -> True - MO_U_Ge _ -> True - MO_U_Le _ -> True - MO_U_Gt _ -> True - MO_U_Lt _ -> True - MO_F_Eq {} -> True - MO_F_Ne {} -> True - MO_F_Ge {} -> True - MO_F_Le {} -> True - MO_F_Gt {} -> True - MO_F_Lt {} -> True - _other -> False - --- ----------------------------------------------------------------------------- --- Inverting conditions - --- Sometimes it's useful to be able to invert the sense of a --- condition. Not all conditional tests are invertible: in --- particular, floating point conditionals cannot be inverted, because --- there exist floating-point values which return False for both senses --- of a condition (eg. !(NaN > NaN) && !(NaN /<= NaN)). - -maybeInvertComparison :: MachOp -> Maybe MachOp -maybeInvertComparison op - = case op of -- None of these Just cases include floating point - MO_Eq r -> Just (MO_Ne r) - MO_Ne r -> Just (MO_Eq r) - MO_U_Lt r -> Just (MO_U_Ge r) - MO_U_Gt r -> Just (MO_U_Le r) - MO_U_Le r -> Just (MO_U_Gt r) - MO_U_Ge r -> Just (MO_U_Lt r) - MO_S_Lt r -> Just (MO_S_Ge r) - MO_S_Gt r -> Just (MO_S_Le r) - MO_S_Le r -> Just (MO_S_Gt r) - MO_S_Ge r -> Just (MO_S_Lt r) - MO_F_Eq r -> Just (MO_F_Ne r) - MO_F_Ne r -> Just (MO_F_Eq r) - MO_F_Ge r -> Just (MO_F_Le r) - MO_F_Le r -> Just (MO_F_Ge r) - MO_F_Gt r -> Just (MO_F_Lt r) - MO_F_Lt r -> Just (MO_F_Gt r) - _other -> Nothing - --- ---------------------------------------------------------------------------- --- machOpResultType - -{- | -Returns the MachRep of the result of a MachOp. --} -machOpResultType :: MachOp -> [CmmType] -> CmmType -machOpResultType mop tys = - case mop of - MO_Add {} -> ty1 -- Preserve GC-ptr-hood - MO_Sub {} -> ty1 -- of first arg - MO_Mul r -> cmmBits r - MO_S_MulMayOflo r -> cmmBits r - MO_S_Quot r -> cmmBits r - MO_S_Rem r -> cmmBits r - MO_S_Neg r -> cmmBits r - MO_U_MulMayOflo r -> cmmBits r - MO_U_Quot r -> cmmBits r - MO_U_Rem r -> cmmBits r - - MO_Eq {} -> comparisonResultRep - MO_Ne {} -> comparisonResultRep - MO_S_Ge {} -> comparisonResultRep - MO_S_Le {} -> comparisonResultRep - MO_S_Gt {} -> comparisonResultRep - MO_S_Lt {} -> comparisonResultRep - - MO_U_Ge {} -> comparisonResultRep - MO_U_Le {} -> comparisonResultRep - MO_U_Gt {} -> comparisonResultRep - MO_U_Lt {} -> comparisonResultRep - - MO_F_Add r -> cmmFloat r - MO_F_Sub r -> cmmFloat r - MO_F_Mul r -> cmmFloat r - MO_F_Quot r -> cmmFloat r - MO_F_Neg r -> cmmFloat r - MO_F_Eq {} -> comparisonResultRep - MO_F_Ne {} -> comparisonResultRep - MO_F_Ge {} -> comparisonResultRep - MO_F_Le {} -> comparisonResultRep - MO_F_Gt {} -> comparisonResultRep - MO_F_Lt {} -> comparisonResultRep - - MO_And {} -> ty1 -- Used for pointer masking - MO_Or {} -> ty1 - MO_Xor {} -> ty1 - MO_Not r -> cmmBits r - MO_Shl r -> cmmBits r - MO_U_Shr r -> cmmBits r - MO_S_Shr r -> cmmBits r - - MO_SS_Conv _ to -> cmmBits to - MO_UU_Conv _ to -> cmmBits to - MO_FS_Conv _ to -> cmmBits to - MO_SF_Conv _ to -> cmmFloat to - MO_FF_Conv _ to -> cmmFloat to - where - (ty1:_) = tys - -comparisonResultRep :: CmmType -comparisonResultRep = bWord -- is it? - - --- ----------------------------------------------------------------------------- --- machOpArgReps - --- | This function is used for debugging only: we can check whether an --- application of a MachOp is "type-correct" by checking that the MachReps of --- its arguments are the same as the MachOp expects. This is used when --- linting a CmmExpr. - -machOpArgReps :: MachOp -> [Width] -machOpArgReps op = - case op of - MO_Add r -> [r,r] - MO_Sub r -> [r,r] - MO_Eq r -> [r,r] - MO_Ne r -> [r,r] - MO_Mul r -> [r,r] - MO_S_MulMayOflo r -> [r,r] - MO_S_Quot r -> [r,r] - MO_S_Rem r -> [r,r] - MO_S_Neg r -> [r] - MO_U_MulMayOflo r -> [r,r] - MO_U_Quot r -> [r,r] - MO_U_Rem r -> [r,r] - - MO_S_Ge r -> [r,r] - MO_S_Le r -> [r,r] - MO_S_Gt r -> [r,r] - MO_S_Lt r -> [r,r] - - MO_U_Ge r -> [r,r] - MO_U_Le r -> [r,r] - MO_U_Gt r -> [r,r] - MO_U_Lt r -> [r,r] - - MO_F_Add r -> [r,r] - MO_F_Sub r -> [r,r] - MO_F_Mul r -> [r,r] - MO_F_Quot r -> [r,r] - MO_F_Neg r -> [r] - MO_F_Eq r -> [r,r] - MO_F_Ne r -> [r,r] - MO_F_Ge r -> [r,r] - MO_F_Le r -> [r,r] - MO_F_Gt r -> [r,r] - MO_F_Lt r -> [r,r] - - MO_And r -> [r,r] - MO_Or r -> [r,r] - MO_Xor r -> [r,r] - MO_Not r -> [r] - MO_Shl r -> [r,wordWidth] - MO_U_Shr r -> [r,wordWidth] - MO_S_Shr r -> [r,wordWidth] - - MO_SS_Conv from _ -> [from] - MO_UU_Conv from _ -> [from] - MO_SF_Conv from _ -> [from] - MO_FS_Conv from _ -> [from] - MO_FF_Conv from _ -> [from] - - -------------------------------------------------------------------------- -{- Note [Signed vs unsigned] - ~~~~~~~~~~~~~~~~~~~~~~~~~ -Should a CmmType include a signed vs. unsigned distinction? - -This is very much like a "hint" in C-- terminology: it isn't necessary -in order to generate correct code, but it might be useful in that the -compiler can generate better code if it has access to higher-level -hints about data. This is important at call boundaries, because the -definition of a function is not visible at all of its call sites, so -the compiler cannot infer the hints. - -Here in Cmm, we're taking a slightly different approach. We include -the int vs. float hint in the MachRep, because (a) the majority of -platforms have a strong distinction between float and int registers, -and (b) we don't want to do any heavyweight hint-inference in the -native code backend in order to get good code. We're treating the -hint more like a type: our Cmm is always completely consistent with -respect to hints. All coercions between float and int are explicit. - -What about the signed vs. unsigned hint? This information might be -useful if we want to keep sub-word-sized values in word-size -registers, which we must do if we only have word-sized registers. - -On such a system, there are two straightforward conventions for -representing sub-word-sized values: - -(a) Leave the upper bits undefined. Comparison operations must - sign- or zero-extend both operands before comparing them, - depending on whether the comparison is signed or unsigned. - -(b) Always keep the values sign- or zero-extended as appropriate. - Arithmetic operations must narrow the result to the appropriate - size. - -A clever compiler might not use either (a) or (b) exclusively, instead -it would attempt to minimize the coercions by analysis: the same kind -of analysis that propagates hints around. In Cmm we don't want to -have to do this, so we plump for having richer types and keeping the -type information consistent. - -If signed/unsigned hints are missing from MachRep, then the only -choice we have is (a), because we don't know whether the result of an -operation should be sign- or zero-extended. - -Many architectures have extending load operations, which work well -with (b). To make use of them with (a), you need to know whether the -value is going to be sign- or zero-extended by an enclosing comparison -(for example), which involves knowing above the context. This is -doable but more complex. - -Further complicating the issue is foreign calls: a foreign calling -convention can specify that signed 8-bit quantities are passed as -sign-extended 32 bit quantities, for example (this is the case on the -PowerPC). So we *do* need sign information on foreign call arguments. - -Pros for adding signed vs. unsigned to MachRep: - - - It would let us use convention (b) above, and get easier - code generation for extending loads. - - - Less information required on foreign calls. - - - MachOp type would be simpler - -Cons: - - - More complexity - - - What is the MachRep for a VanillaReg? Currently it is - always wordRep, but now we have to decide whether it is - signed or unsigned. The same VanillaReg can thus have - different MachReps in different parts of the program. - - - Extra coercions cluttering up expressions. - -Currently for GHC, the foreign call point is moot, because we do our -own promotion of sub-word-sized values to word-sized values. The Int8 -type is represnted by an Int# which is kept sign-extended at all times -(this is slightly naughty, because we're making assumptions about the -C calling convention rather early on in the compiler). However, given -this, the cons outweigh the pros. - --} - diff -Nru ghc-7.0.3/compiler/cmm/Cmm.hs ghc-7.2.1/compiler/cmm/Cmm.hs --- ghc-7.0.3/compiler/cmm/Cmm.hs 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/cmm/Cmm.hs 2011-08-07 17:10:05.000000000 +0000 @@ -1,422 +1,181 @@ ------------------------------------------------------------------------------ --- --- Cmm data types --- --- (c) The University of Glasgow 2004-2006 --- ------------------------------------------------------------------------------ - -module Cmm ( - GenCmm(..), Cmm, RawCmm, - GenCmmTop(..), CmmTop, RawCmmTop, - ListGraph(..), - cmmMapGraph, cmmTopMapGraph, - cmmMapGraphM, cmmTopMapGraphM, - CmmInfo(..), UpdateFrame(..), - CmmInfoTable(..), HasStaticClosure, ClosureTypeInfo(..), ConstrDescription, - ProfilingInfo(..), ClosureTypeTag, - GenBasicBlock(..), CmmBasicBlock, blockId, blockStmts, mapBlockStmts, - CmmReturnInfo(..), - CmmStmt(..), CmmActual, CmmActuals, CmmFormal, CmmFormals, - HintedCmmFormal, HintedCmmFormals, HintedCmmActual, HintedCmmActuals, - CmmSafety(..), - CmmCallTarget(..), CallishMachOp(..), pprCallishMachOp, - ForeignHint(..), CmmHinted(..), - CmmStatic(..), Section(..), - module CmmExpr, - ) where - -#include "HsVersions.h" +-- Cmm representations using Hoopl's Graph CmmNode e x. +{-# LANGUAGE GADTs #-} +{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} + +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} +#if __GLASGOW_HASKELL__ >= 701 +-- GHC 7.0.1 improved incomplete pattern warnings with GADTs +{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} +#endif + +module Cmm + ( CmmGraph, GenCmmGraph(..), CmmBlock + , CmmStackInfo(..), CmmTopInfo(..), Cmm, CmmTop + , CmmReplGraph, GenCmmReplGraph, CmmFwdRewrite, CmmBwdRewrite + + , modifyGraph + , lastNode, replaceLastNode, insertBetween + , ofBlockMap, toBlockMap, insertBlock + , ofBlockList, toBlockList, bodyToBlockList + , foldGraphBlocks, mapGraphNodes, postorderDfs + + , analFwd, analBwd, analRewFwd, analRewBwd + , dataflowPassFwd, dataflowPassBwd + , module CmmNode + ) +where import BlockId -import CmmExpr -import CLabel -import ForeignCall +import CmmDecl +import CmmNode +import OptimizationFuel as F import SMRep +import UniqSupply + +import Compiler.Hoopl +import Control.Monad +import Data.Maybe +import Panic + +#include "HsVersions.h" -import ClosureInfo -import Outputable -import FastString - -import Data.Word - - --- A [[BlockId]] is a local label. --- Local labels must be unique within an entire compilation unit, not --- just a single top-level item, because local labels map one-to-one --- with assembly-language labels. - ------------------------------------------------------------------------------ --- Cmm, CmmTop, CmmBasicBlock ------------------------------------------------------------------------------ - --- A file is a list of top-level chunks. These may be arbitrarily --- re-orderd during code generation. - --- GenCmm is abstracted over --- d, the type of static data elements in CmmData --- h, the static info preceding the code of a CmmProc --- g, the control-flow graph of a CmmProc --- --- We expect there to be two main instances of this type: --- (a) C--, i.e. populated with various C-- constructs --- (Cmm and RawCmm below) --- (b) Native code, populated with data/instructions --- --- A second family of instances based on ZipCfg is work in progress. --- -newtype GenCmm d h g = Cmm [GenCmmTop d h g] - --- | A top-level chunk, abstracted over the type of the contents of --- the basic blocks (Cmm or instructions are the likely instantiations). -data GenCmmTop d h g - = CmmProc -- A procedure - h -- Extra header such as the info table - CLabel -- Used to generate both info & entry labels - CmmFormals -- Argument locals live on entry (C-- procedure params) - -- XXX Odd that there are no kinds, but there you are ---NR - g -- Control-flow graph for the procedure's code - - | CmmData -- Static data - Section - [d] - --- | A control-flow graph represented as a list of extended basic blocks. -newtype ListGraph i = ListGraph [GenBasicBlock i] - -- ^ Code, may be empty. The first block is the entry point. The - -- order is otherwise initially unimportant, but at some point the - -- code gen will fix the order. - - -- BlockIds must be unique across an entire compilation unit, since - -- they are translated to assembly-language labels, which scope - -- across a whole compilation unit. - --- | Cmm with the info table as a data type -type Cmm = GenCmm CmmStatic CmmInfo (ListGraph CmmStmt) -type CmmTop = GenCmmTop CmmStatic CmmInfo (ListGraph CmmStmt) - --- | Cmm with the info tables converted to a list of 'CmmStatic' -type RawCmm = GenCmm CmmStatic [CmmStatic] (ListGraph CmmStmt) -type RawCmmTop = GenCmmTop CmmStatic [CmmStatic] (ListGraph CmmStmt) - - --- A basic block containing a single label, at the beginning. --- The list of basic blocks in a top-level code block may be re-ordered. --- Fall-through is not allowed: there must be an explicit jump at the --- end of each basic block, but the code generator might rearrange basic --- blocks in order to turn some jumps into fallthroughs. - -data GenBasicBlock i = BasicBlock BlockId [i] -type CmmBasicBlock = GenBasicBlock CmmStmt - -instance UserOfLocalRegs i => UserOfLocalRegs (GenBasicBlock i) where - foldRegsUsed f set (BasicBlock _ l) = foldRegsUsed f set l - -blockId :: GenBasicBlock i -> BlockId --- The branch block id is that of the first block in --- the branch, which is that branch's entry point -blockId (BasicBlock blk_id _ ) = blk_id - -blockStmts :: GenBasicBlock i -> [i] -blockStmts (BasicBlock _ stmts) = stmts - - -mapBlockStmts :: (i -> i') -> GenBasicBlock i -> GenBasicBlock i' -mapBlockStmts f (BasicBlock id bs) = BasicBlock id (map f bs) ----------------------------------------------------------------- --- graph maps ----------------------------------------------------------------- - -cmmMapGraph :: (g -> g') -> GenCmm d h g -> GenCmm d h g' -cmmTopMapGraph :: (g -> g') -> GenCmmTop d h g -> GenCmmTop d h g' - -cmmMapGraphM :: Monad m => (String -> g -> m g') -> GenCmm d h g -> m (GenCmm d h g') -cmmTopMapGraphM :: Monad m => (String -> g -> m g') -> GenCmmTop d h g -> m (GenCmmTop d h g') - -cmmMapGraph f (Cmm tops) = Cmm $ map (cmmTopMapGraph f) tops -cmmTopMapGraph f (CmmProc h l args g) = CmmProc h l args (f g) -cmmTopMapGraph _ (CmmData s ds) = CmmData s ds - -cmmMapGraphM f (Cmm tops) = mapM (cmmTopMapGraphM f) tops >>= return . Cmm -cmmTopMapGraphM f (CmmProc h l args g) = - f (showSDoc $ ppr l) g >>= return . CmmProc h l args -cmmTopMapGraphM _ (CmmData s ds) = return $ CmmData s ds - ------------------------------------------------------------------------------ --- Info Tables ------------------------------------------------------------------------------ - -data CmmInfo - = CmmInfo - (Maybe BlockId) -- GC target. Nothing <=> CPS won't do stack check - -- JD: NOT USED BY NEW CODE GEN - (Maybe UpdateFrame) -- Update frame - CmmInfoTable -- Info table - --- Info table as a haskell data type -data CmmInfoTable - = CmmInfoTable - HasStaticClosure - ProfilingInfo - ClosureTypeTag -- Int - ClosureTypeInfo - | CmmNonInfoTable -- Procedure doesn't need an info table - -type HasStaticClosure = Bool - --- TODO: The GC target shouldn't really be part of CmmInfo --- as it doesn't appear in the resulting info table. --- It should be factored out. - -data ClosureTypeInfo - = ConstrInfo ClosureLayout ConstrTag ConstrDescription - | FunInfo ClosureLayout C_SRT FunArity ArgDescr SlowEntry - | ThunkInfo ClosureLayout C_SRT - | ThunkSelectorInfo SelectorOffset C_SRT - | ContInfo - [Maybe LocalReg] -- Stack layout: Just x, an item x - -- Nothing: a 1-word gap - -- Start of list is the *young* end - C_SRT - -data CmmReturnInfo = CmmMayReturn - | CmmNeverReturns - deriving ( Eq ) - --- TODO: These types may need refinement -data ProfilingInfo = ProfilingInfo CmmLit CmmLit -- closure_type, closure_desc -type ClosureTypeTag = StgHalfWord -type ClosureLayout = (StgHalfWord, StgHalfWord) -- ptrs, nptrs -type ConstrTag = StgHalfWord -type ConstrDescription = CmmLit -type FunArity = StgHalfWord -type SlowEntry = CmmLit - -- We would like this to be a CLabel but - -- for now the parser sets this to zero on an INFO_TABLE_FUN. -type SelectorOffset = StgWord - --- | A frame that is to be pushed before entry to the function. --- Used to handle 'update' frames. -data UpdateFrame = - UpdateFrame - CmmExpr -- Frame header. Behaves like the target of a 'jump'. - [CmmExpr] -- Frame remainder. Behaves like the arguments of a 'jump'. - ------------------------------------------------------------------------------ --- CmmStmt --- A "statement". Note that all branches are explicit: there are no --- control transfers to computed addresses, except when transfering --- control to a new function. ------------------------------------------------------------------------------ - -data CmmStmt -- Old-style - = CmmNop - | CmmComment FastString - - | CmmAssign CmmReg CmmExpr -- Assign to register - - | CmmStore CmmExpr CmmExpr -- Assign to memory location. Size is - -- given by cmmExprType of the rhs. - - | CmmCall -- A call (forign, native or primitive), with - CmmCallTarget - HintedCmmFormals -- zero or more results - HintedCmmActuals -- zero or more arguments - CmmSafety -- whether to build a continuation - CmmReturnInfo - - | CmmBranch BlockId -- branch to another BB in this fn - - | CmmCondBranch CmmExpr BlockId -- conditional branch - - | CmmSwitch CmmExpr [Maybe BlockId] -- Table branch - -- The scrutinee is zero-based; - -- zero -> first block - -- one -> second block etc - -- Undefined outside range, and when there's a Nothing - - | CmmJump CmmExpr -- Jump to another C-- function, - HintedCmmActuals -- with these parameters. (parameters never used) - - | CmmReturn -- Return from a native C-- function, - HintedCmmActuals -- with these return values. (parameters never used) - -type CmmActual = CmmExpr -type CmmFormal = LocalReg -type CmmActuals = [CmmActual] -type CmmFormals = [CmmFormal] - -data CmmHinted a = CmmHinted { hintlessCmm :: a, cmmHint :: ForeignHint } - deriving( Eq ) - -type HintedCmmActuals = [HintedCmmActual] -type HintedCmmFormals = [HintedCmmFormal] -type HintedCmmFormal = CmmHinted CmmFormal -type HintedCmmActual = CmmHinted CmmActual - -data CmmSafety = CmmUnsafe | CmmSafe C_SRT - --- | enable us to fold used registers over 'CmmActuals' and 'CmmFormals' -instance UserOfLocalRegs CmmStmt where - foldRegsUsed f (set::b) s = stmt s set - where - stmt :: CmmStmt -> b -> b - stmt (CmmNop) = id - stmt (CmmComment {}) = id - stmt (CmmAssign _ e) = gen e - stmt (CmmStore e1 e2) = gen e1 . gen e2 - stmt (CmmCall target _ es _ _) = gen target . gen es - stmt (CmmBranch _) = id - stmt (CmmCondBranch e _) = gen e - stmt (CmmSwitch e _) = gen e - stmt (CmmJump e es) = gen e . gen es - stmt (CmmReturn es) = gen es - - gen :: UserOfLocalRegs a => a -> b -> b - gen a set = foldRegsUsed f set a - -instance UserOfLocalRegs CmmCallTarget where - foldRegsUsed f set (CmmCallee e _) = foldRegsUsed f set e - foldRegsUsed _ set (CmmPrim {}) = set - -instance UserOfSlots CmmCallTarget where - foldSlotsUsed f set (CmmCallee e _) = foldSlotsUsed f set e - foldSlotsUsed _ set (CmmPrim {}) = set - -instance UserOfLocalRegs a => UserOfLocalRegs (CmmHinted a) where - foldRegsUsed f set a = foldRegsUsed f set (hintlessCmm a) - -instance UserOfSlots a => UserOfSlots (CmmHinted a) where - foldSlotsUsed f set a = foldSlotsUsed f set (hintlessCmm a) - -instance DefinerOfLocalRegs a => DefinerOfLocalRegs (CmmHinted a) where - foldRegsDefd f set a = foldRegsDefd f set (hintlessCmm a) - -{- -Discussion -~~~~~~~~~~ - -One possible problem with the above type is that the only way to do a -non-local conditional jump is to encode it as a branch to a block that -contains a single jump. This leads to inefficient code in the back end. - -[N.B. This problem will go away when we make the transition to the -'zipper' form of control-flow graph, in which both targets of a -conditional jump are explicit. ---NR] - -One possible way to fix this would be: - -data CmmStat = - ... - | CmmJump CmmBranchDest - | CmmCondJump CmmExpr CmmBranchDest - ... - -data CmmBranchDest - = Local BlockId - | NonLocal CmmExpr [LocalReg] - -In favour: - -+ one fewer constructors in CmmStmt -+ allows both cond branch and switch to jump to non-local destinations - -Against: - -- not strictly necessary: can already encode as branch+jump -- not always possible to implement any better in the back end -- could do the optimisation in the back end (but then plat-specific?) -- C-- doesn't have it -- back-end optimisation might be more general (jump shortcutting) - -So we'll stick with the way it is, and add the optimisation to the NCG. --} - ------------------------------------------------------------------------------ --- CmmCallTarget --- --- The target of a CmmCall. ------------------------------------------------------------------------------ - -data CmmCallTarget - = CmmCallee -- Call a function (foreign or native) - CmmExpr -- literal label <=> static call - -- other expression <=> dynamic call - CCallConv -- The calling convention - - | CmmPrim -- Call a "primitive" (eg. sin, cos) - CallishMachOp -- These might be implemented as inline - -- code by the backend. - deriving Eq - - -data ForeignHint - = NoHint | AddrHint | SignedHint - deriving( Eq ) - -- Used to give extra per-argument or per-result - -- information needed by foreign calling conventions - - --- CallishMachOps tend to be implemented by foreign calls in some backends, --- so we separate them out. In Cmm, these can only occur in a --- statement position, in contrast to an ordinary MachOp which can occur --- anywhere in an expression. -data CallishMachOp - = MO_F64_Pwr - | MO_F64_Sin - | MO_F64_Cos - | MO_F64_Tan - | MO_F64_Sinh - | MO_F64_Cosh - | MO_F64_Tanh - | MO_F64_Asin - | MO_F64_Acos - | MO_F64_Atan - | MO_F64_Log - | MO_F64_Exp - | MO_F64_Sqrt - | MO_F32_Pwr - | MO_F32_Sin - | MO_F32_Cos - | MO_F32_Tan - | MO_F32_Sinh - | MO_F32_Cosh - | MO_F32_Tanh - | MO_F32_Asin - | MO_F32_Acos - | MO_F32_Atan - | MO_F32_Log - | MO_F32_Exp - | MO_F32_Sqrt - | MO_WriteBarrier - | MO_Touch -- Keep variables live (when using interior pointers) - deriving (Eq, Show) - -pprCallishMachOp :: CallishMachOp -> SDoc -pprCallishMachOp mo = text (show mo) - ------------------------------------------------------------------------------ --- Static Data ------------------------------------------------------------------------------ - -data Section - = Text - | Data - | ReadOnlyData - | RelocatableReadOnlyData - | UninitialisedData - | ReadOnlyData16 -- .rodata.cst16 on x86_64, 16-byte aligned - | OtherSection String - -data CmmStatic - = CmmStaticLit CmmLit - -- a literal value, size given by cmmLitRep of the literal. - | CmmUninitialised Int - -- uninitialised data, N bytes long - | CmmAlign Int - -- align to next N-byte boundary (N must be a power of 2). - | CmmDataLabel CLabel - -- label the current position in this section. - | CmmString [Word8] - -- string of 8-bit values only, not zero terminated. +------------------------------------------------- +-- CmmBlock, CmmGraph and Cmm +type CmmGraph = GenCmmGraph CmmNode +data GenCmmGraph n = CmmGraph { g_entry :: BlockId, g_graph :: Graph n C C } +type CmmBlock = Block CmmNode C C + +type CmmReplGraph e x = GenCmmReplGraph CmmNode e x +type GenCmmReplGraph n e x = FuelUniqSM (Maybe (Graph n e x)) +type CmmFwdRewrite f = FwdRewrite FuelUniqSM CmmNode f +type CmmBwdRewrite f = BwdRewrite FuelUniqSM CmmNode f + +data CmmStackInfo = StackInfo {arg_space :: ByteOff, updfr_space :: Maybe ByteOff} +data CmmTopInfo = TopInfo {info_tbl :: CmmInfoTable, stack_info :: CmmStackInfo} +type Cmm = GenCmm CmmStatics CmmTopInfo CmmGraph +type CmmTop = GenCmmTop CmmStatics CmmTopInfo CmmGraph + +------------------------------------------------- +-- Manipulating CmmGraphs + +modifyGraph :: (Graph n C C -> Graph n' C C) -> GenCmmGraph n -> GenCmmGraph n' +modifyGraph f g = CmmGraph {g_entry=g_entry g, g_graph=f (g_graph g)} + +toBlockMap :: CmmGraph -> LabelMap CmmBlock +toBlockMap (CmmGraph {g_graph=GMany NothingO body NothingO}) = body + +ofBlockMap :: BlockId -> LabelMap CmmBlock -> CmmGraph +ofBlockMap entry bodyMap = CmmGraph {g_entry=entry, g_graph=GMany NothingO bodyMap NothingO} + +insertBlock :: CmmBlock -> LabelMap CmmBlock -> LabelMap CmmBlock +insertBlock block map = + ASSERT (isNothing $ mapLookup id map) + mapInsert id block map + where id = entryLabel block + +toBlockList :: CmmGraph -> [CmmBlock] +toBlockList g = mapElems $ toBlockMap g + +ofBlockList :: BlockId -> [CmmBlock] -> CmmGraph +ofBlockList entry blocks = CmmGraph {g_entry=entry, g_graph=GMany NothingO body NothingO} + where body = foldr addBlock emptyBody blocks + +bodyToBlockList :: Body CmmNode -> [CmmBlock] +bodyToBlockList body = mapElems body + +mapGraphNodes :: ( CmmNode C O -> CmmNode C O + , CmmNode O O -> CmmNode O O + , CmmNode O C -> CmmNode O C) + -> CmmGraph -> CmmGraph +mapGraphNodes funs@(mf,_,_) g = + ofBlockMap (entryLabel $ mf $ CmmEntry $ g_entry g) $ mapMap (blockMapNodes3 funs) $ toBlockMap g + +foldGraphBlocks :: (CmmBlock -> a -> a) -> a -> CmmGraph -> a +foldGraphBlocks k z g = mapFold k z $ toBlockMap g + +postorderDfs :: CmmGraph -> [CmmBlock] +postorderDfs g = postorder_dfs_from (toBlockMap g) (g_entry g) + +------------------------------------------------- +-- Manipulating CmmBlocks + +lastNode :: CmmBlock -> CmmNode O C +lastNode block = foldBlockNodesF3 (nothing, nothing, const) block () + where nothing :: a -> b -> () + nothing _ _ = () + +replaceLastNode :: Block CmmNode e C -> CmmNode O C -> Block CmmNode e C +replaceLastNode block last = blockOfNodeList (first, middle, JustC last) + where (first, middle, _) = blockToNodeList block + +---------------------------------------------------------------------- +----- Splicing between blocks +-- Given a middle node, a block, and a successor BlockId, +-- we can insert the middle node between the block and the successor. +-- We return the updated block and a list of new blocks that must be added +-- to the graph. +-- The semantics is a bit tricky. We consider cases on the last node: +-- o For a branch, we can just insert before the branch, +-- but sometimes the optimizer does better if we actually insert +-- a fresh basic block, enabling some common blockification. +-- o For a conditional branch, switch statement, or call, we must insert +-- a new basic block. +-- o For a jump or return, this operation is impossible. + +insertBetween :: MonadUnique m => CmmBlock -> [CmmNode O O] -> BlockId -> m (CmmBlock, [CmmBlock]) +insertBetween b ms succId = insert $ lastNode b + where insert :: MonadUnique m => CmmNode O C -> m (CmmBlock, [CmmBlock]) + insert (CmmBranch bid) = + if bid == succId then + do (bid', bs) <- newBlocks + return (replaceLastNode b (CmmBranch bid'), bs) + else panic "tried invalid block insertBetween" + insert (CmmCondBranch c t f) = + do (t', tbs) <- if t == succId then newBlocks else return $ (t, []) + (f', fbs) <- if f == succId then newBlocks else return $ (f, []) + return (replaceLastNode b (CmmCondBranch c t' f'), tbs ++ fbs) + insert (CmmSwitch e ks) = + do (ids, bs) <- mapAndUnzipM mbNewBlocks ks + return (replaceLastNode b (CmmSwitch e ids), join bs) + insert (CmmCall {}) = + panic "unimp: insertBetween after a call -- probably not a good idea" + insert (CmmForeignCall {}) = + panic "unimp: insertBetween after a foreign call -- probably not a good idea" + + newBlocks :: MonadUnique m => m (BlockId, [CmmBlock]) + newBlocks = do id <- liftM mkBlockId $ getUniqueM + return $ (id, [blockOfNodeList (JustC (CmmEntry id), ms, JustC (CmmBranch succId))]) + mbNewBlocks :: MonadUnique m => Maybe BlockId -> m (Maybe BlockId, [CmmBlock]) + mbNewBlocks (Just k) = if k == succId then liftM fstJust newBlocks + else return (Just k, []) + mbNewBlocks Nothing = return (Nothing, []) + fstJust (id, bs) = (Just id, bs) + +------------------------------------------------- +-- Running dataflow analysis and/or rewrites + +-- Constructing forward and backward analysis-only pass +analFwd :: Monad m => DataflowLattice f -> FwdTransfer n f -> FwdPass m n f +analBwd :: Monad m => DataflowLattice f -> BwdTransfer n f -> BwdPass m n f + +analFwd lat xfer = analRewFwd lat xfer noFwdRewrite +analBwd lat xfer = analRewBwd lat xfer noBwdRewrite + +-- Constructing forward and backward analysis + rewrite pass +analRewFwd :: Monad m => DataflowLattice f -> FwdTransfer n f -> FwdRewrite m n f -> FwdPass m n f +analRewBwd :: Monad m => DataflowLattice f -> BwdTransfer n f -> BwdRewrite m n f -> BwdPass m n f + +analRewFwd lat xfer rew = FwdPass {fp_lattice = lat, fp_transfer = xfer, fp_rewrite = rew} +analRewBwd lat xfer rew = BwdPass {bp_lattice = lat, bp_transfer = xfer, bp_rewrite = rew} + +-- Running forward and backward dataflow analysis + optional rewrite +dataflowPassFwd :: NonLocal n => GenCmmGraph n -> [(BlockId, f)] -> FwdPass FuelUniqSM n f -> FuelUniqSM (GenCmmGraph n, BlockEnv f) +dataflowPassFwd (CmmGraph {g_entry=entry, g_graph=graph}) facts fwd = do + (graph, facts, NothingO) <- analyzeAndRewriteFwd fwd (JustC [entry]) graph (mkFactBase (fp_lattice fwd) facts) + return (CmmGraph {g_entry=entry, g_graph=graph}, facts) + +dataflowPassBwd :: NonLocal n => GenCmmGraph n -> [(BlockId, f)] -> BwdPass FuelUniqSM n f -> FuelUniqSM (GenCmmGraph n, BlockEnv f) +dataflowPassBwd (CmmGraph {g_entry=entry, g_graph=graph}) facts bwd = do + (graph, facts, NothingO) <- analyzeAndRewriteBwd bwd (JustC [entry]) graph (mkFactBase (bp_lattice bwd) facts) + return (CmmGraph {g_entry=entry, g_graph=graph}, facts) diff -Nru ghc-7.0.3/compiler/cmm/CmmInfo.hs ghc-7.2.1/compiler/cmm/CmmInfo.hs --- ghc-7.0.3/compiler/cmm/CmmInfo.hs 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/cmm/CmmInfo.hs 2011-08-07 17:10:05.000000000 +0000 @@ -1,13 +1,12 @@ module CmmInfo ( - emptyContInfoTable, + mkEmptyContInfoTable, cmmToRawCmm, mkInfoTable, - mkBareInfoTable ) where #include "HsVersions.h" -import Cmm +import OldCmm import CmmUtils import CLabel @@ -18,7 +17,6 @@ import CgCallConv import CgUtils import SMRep -import ZipCfgCmmRep import Constants import Panic @@ -29,10 +27,9 @@ import Data.Bits -- When we split at proc points, we need an empty info table. -emptyContInfoTable :: CmmInfo -emptyContInfoTable = - CmmInfo Nothing Nothing (CmmInfoTable False (ProfilingInfo zero zero) rET_SMALL - (ContInfo [] NoC_SRT)) +mkEmptyContInfoTable :: CLabel -> CmmInfoTable +mkEmptyContInfoTable info_lbl = CmmInfoTable info_lbl False (ProfilingInfo zero zero) rET_SMALL + (ContInfo [] NoC_SRT) where zero = CmmInt 0 wordWidth cmmToRawCmm :: [Cmm] -> IO [RawCmm] @@ -78,20 +75,19 @@ mkInfoTable :: Unique -> CmmTop -> [RawCmmTop] mkInfoTable _ (CmmData sec dat) = [CmmData sec dat] -mkInfoTable uniq (CmmProc (CmmInfo _ _ info) entry_label arguments blocks) = +mkInfoTable uniq (CmmProc (CmmInfo _ _ info) entry_label blocks) = case info of -- Code without an info table. Easy. - CmmNonInfoTable -> [CmmProc [] entry_label arguments blocks] + CmmNonInfoTable -> [CmmProc Nothing entry_label blocks] - CmmInfoTable _ (ProfilingInfo ty_prof cl_prof) type_tag type_info -> - let info_label = entryLblToInfoLbl entry_label - ty_prof' = makeRelativeRefTo info_label ty_prof + CmmInfoTable info_label _ (ProfilingInfo ty_prof cl_prof) type_tag type_info -> + let ty_prof' = makeRelativeRefTo info_label ty_prof cl_prof' = makeRelativeRefTo info_label cl_prof in case type_info of -- A function entry point. FunInfo (ptrs, nptrs) srt fun_arity pap_bitmap slow_entry -> mkInfoTableAndCode info_label std_info fun_extra_bits entry_label - arguments blocks + blocks where fun_type = argDescrType pap_bitmap fun_extra_bits = @@ -110,7 +106,7 @@ -- A constructor. ConstrInfo (ptrs, nptrs) con_tag descr -> mkInfoTableAndCode info_label std_info [con_name] entry_label - arguments blocks + blocks where std_info = mkStdInfoTable ty_prof' cl_prof' type_tag con_tag layout con_name = makeRelativeRefTo info_label descr @@ -118,7 +114,7 @@ -- A thunk. ThunkInfo (ptrs, nptrs) srt -> mkInfoTableAndCode info_label std_info srt_label entry_label - arguments blocks + blocks where std_info = mkStdInfoTable ty_prof' cl_prof' type_tag srt_bitmap layout (srt_label, srt_bitmap) = mkSRTLit info_label srt @@ -127,7 +123,7 @@ -- A selector thunk. ThunkSelectorInfo offset _srt -> mkInfoTableAndCode info_label std_info [{- no SRT -}] entry_label - arguments blocks + blocks where std_info = mkStdInfoTable ty_prof' cl_prof' type_tag 0 (mkWordCLit offset) @@ -135,7 +131,7 @@ ContInfo stack_layout srt -> liveness_data ++ mkInfoTableAndCode info_label std_info srt_label entry_label - arguments blocks + blocks where std_info = mkStdInfoTable ty_prof' cl_prof' maybe_big_type_tag srt_bitmap (makeRelativeRefTo info_label liveness_lit) @@ -146,30 +142,18 @@ else type_tag (srt_label, srt_bitmap) = mkSRTLit info_label srt --- Generate a bare info table, not attached to any procedure. -mkBareInfoTable :: CLabel -> Unique -> CmmInfoTable -> [CmmTopZ] -mkBareInfoTable lbl uniq info = - case mkInfoTable uniq (CmmProc (CmmInfo Nothing Nothing info) lbl [] (ListGraph [])) of - [CmmProc d _ _ _] -> - ASSERT (tablesNextToCode) - [CmmData Data (d ++ [CmmDataLabel (entryLblToInfoLbl lbl)])] - [CmmData d s] -> [CmmData d s] - _ -> panic "mkBareInfoTable expected to produce only data" - - -- Handle the differences between tables-next-to-code -- and not tables-next-to-code mkInfoTableAndCode :: CLabel -> [CmmLit] -> [CmmLit] -> CLabel - -> CmmFormals -> ListGraph CmmStmt -> [RawCmmTop] -mkInfoTableAndCode info_lbl std_info extra_bits entry_lbl args blocks +mkInfoTableAndCode info_lbl std_info extra_bits entry_lbl blocks | tablesNextToCode -- Reverse the extra_bits; and emit the top-level proc - = [CmmProc (map CmmStaticLit (reverse extra_bits ++ std_info)) - entry_lbl args blocks] + = [CmmProc (Just (Statics info_lbl $ map CmmStaticLit (reverse extra_bits ++ std_info))) + entry_lbl blocks] | ListGraph [] <- blocks -- No code; only the info table is significant = -- Use a zero place-holder in place of the @@ -178,7 +162,7 @@ | otherwise -- Separately emit info table (with the function entry = -- point as first entry) and the entry code - [CmmProc [] entry_lbl args blocks, + [CmmProc Nothing entry_lbl blocks, mkDataLits info_lbl (CmmLabel entry_lbl : std_info ++ extra_bits)] mkSRTLit :: CLabel @@ -245,7 +229,7 @@ small_bitmap = case bitmap of [] -> 0 - [b] -> fromIntegral b + [b] -> b _ -> panic "mkLiveness" small_liveness = fromIntegral (length bits) .|. (small_bitmap `shiftL` bITMAP_BITS_SHIFT) diff -Nru ghc-7.0.3/compiler/cmm/CmmLex.hs ghc-7.2.1/compiler/cmm/CmmLex.hs --- ghc-7.0.3/compiler/cmm/CmmLex.hs 2011-03-26 20:51:08.000000000 +0000 +++ ghc-7.2.1/compiler/cmm/CmmLex.hs 2011-08-07 20:09:18.000000000 +0000 @@ -1,6 +1,7 @@ {-# OPTIONS -fglasgow-exts -cpp #-} {-# LINE 13 "compiler/cmm/CmmLex.x" #-} +{-# LANGUAGE BangPatterns #-} {-# OPTIONS -Wwarn -w #-} -- The above -Wwarn supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and fix @@ -12,7 +13,7 @@ CmmToken(..), cmmlex, ) where -import Cmm +import OldCmm import Lexer import SrcLoc @@ -54,7 +55,7 @@ alex_deflt = AlexA# "\x6a\x00\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\x24\x00\xff\xff\x0a\x00\x0b\x00\x0a\x00\x0b\x00\xff\xff\x24\x00\xff\xff\x24\x00\xff\xff\x24\x00\xff\xff\x24\x00\xff\xff\x24\x00\xff\xff\x24\x00\xff\xff\x24\x00\xff\xff\x24\x00\xff\xff\x24\x00\xff\xff\x24\x00\xff\xff\xff\xff\x23\x00\x23\x00\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6b\x00\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# alex_accept = listArray (0::Int,130) [[],[],[],[(AlexAcc (alex_action_5))],[],[(AlexAccSkip)],[(AlexAccSkip)],[(AlexAccSkipPred (alexPrevCharIs '\n'))],[],[(AlexAcc (alex_action_5))],[],[(AlexAcc (alex_action_5))],[],[(AlexAcc (alex_action_5))],[],[(AlexAcc (alex_action_5))],[],[(AlexAcc (alex_action_5))],[],[(AlexAcc (alex_action_5))],[],[(AlexAcc (alex_action_5))],[(AlexAccPred (alex_action_2) (alexPrevCharIs '\n'))],[(AlexAccPred (alex_action_2) (alexPrevCharIs '\n')),(AlexAcc (alex_action_5))],[(AlexAccPred (alex_action_2) (alexPrevCharIs '\n'))],[(AlexAccPred (alex_action_2) (alexPrevCharIs '\n')),(AlexAcc (alex_action_5))],[],[(AlexAcc (alex_action_5))],[],[(AlexAcc (alex_action_5))],[],[(AlexAcc (alex_action_5))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_4))],[],[],[(AlexAcc (alex_action_5))],[(AlexAccSkip)],[(AlexAcc (alex_action_7))],[(AlexAcc (alex_action_7))],[(AlexAcc (alex_action_7))],[(AlexAcc (alex_action_7))],[(AlexAcc (alex_action_7))],[(AlexAcc (alex_action_7))],[(AlexAcc (alex_action_7))],[(AlexAcc (alex_action_7))],[(AlexAcc (alex_action_8))],[(AlexAcc (alex_action_31))],[(AlexAcc (alex_action_9))],[(AlexAcc (alex_action_10))],[(AlexAcc (alex_action_11))],[(AlexAcc (alex_action_12))],[(AlexAcc (alex_action_13))],[(AlexAcc (alex_action_14))],[(AlexAcc (alex_action_15))],[(AlexAcc (alex_action_16))],[(AlexAcc (alex_action_17))],[(AlexAcc (alex_action_18))],[(AlexAcc (alex_action_31))],[(AlexAcc (alex_action_19))],[(AlexAcc (alex_action_31))],[(AlexAcc (alex_action_20))],[(AlexAcc (alex_action_31))],[(AlexAcc (alex_action_21))],[(AlexAcc (alex_action_31))],[(AlexAcc (alex_action_22))],[(AlexAcc (alex_action_31))],[(AlexAcc (alex_action_23))],[(AlexAcc (alex_action_31))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_31))],[(AlexAcc (alex_action_31))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_31))],[(AlexAcc (alex_action_26))],[(AlexAcc (alex_action_31))],[(AlexAcc (alex_action_31))],[(AlexAcc (alex_action_27))],[(AlexAcc (alex_action_31))],[(AlexAcc (alex_action_31))],[(AlexAcc (alex_action_31))],[(AlexAcc (alex_action_31))],[(AlexAcc (alex_action_31))],[(AlexAcc (alex_action_31))],[(AlexAcc (alex_action_31))],[(AlexAcc (alex_action_31))],[(AlexAcc (alex_action_31))],[(AlexAcc (alex_action_28))],[(AlexAcc (alex_action_31))],[(AlexAcc (alex_action_31))],[(AlexAcc (alex_action_31))],[(AlexAcc (alex_action_31))],[(AlexAcc (alex_action_31))],[(AlexAcc (alex_action_31))],[(AlexAcc (alex_action_29))],[(AlexAcc (alex_action_31))],[(AlexAcc (alex_action_31))],[(AlexAcc (alex_action_31))],[(AlexAcc (alex_action_31))],[(AlexAcc (alex_action_30))],[(AlexAcc (alex_action_31))],[(AlexAcc (alex_action_31))],[(AlexAcc (alex_action_31))],[(AlexAcc (alex_action_31))],[(AlexAcc (alex_action_31))],[(AlexAcc (alex_action_31))],[(AlexAcc (alex_action_31))],[(AlexAcc (alex_action_31))],[(AlexAcc (alex_action_32))],[(AlexAcc (alex_action_33))],[(AlexAcc (alex_action_33))],[(AlexAcc (alex_action_34))],[],[(AlexAcc (alex_action_35))],[(AlexAcc (alex_action_35))],[(AlexAcc (alex_action_35))],[],[],[],[],[],[(AlexAcc (alex_action_36))],[],[],[],[],[],[],[],[],[]] -{-# LINE 120 "compiler/cmm/CmmLex.x" #-} +{-# LINE 121 "compiler/cmm/CmmLex.x" #-} data CmmToken = CmmT_SpecChar Char @@ -110,7 +111,7 @@ -- ----------------------------------------------------------------------------- -- Lexer actions -type Action = SrcSpan -> StringBuffer -> Int -> P (Located CmmToken) +type Action = RealSrcSpan -> StringBuffer -> Int -> P (RealLocated CmmToken) begin :: Int -> Action begin code _span _str _len = do pushLexState code; lexToken @@ -205,7 +206,7 @@ setLine :: Int -> Action setLine code span buf len = do let line = parseUnsignedInteger buf len 10 octDecDigit - setSrcLoc (mkSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1) + setSrcLoc (mkRealSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1) -- subtract one: the line number refers to the *following* line -- trace ("setLine " ++ show line) $ do popLexState @@ -215,7 +216,7 @@ setFile :: Int -> Action setFile code span buf len = do let file = lexemeToFastString (stepOn buf) (len-2) - setSrcLoc (mkSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span)) + setSrcLoc (mkRealSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span)) popLexState pushLexState code lexToken @@ -226,16 +227,16 @@ cmmlex :: (Located CmmToken -> P a) -> P a cmmlex cont = do - tok@(L _ tok__) <- lexToken - --trace ("token: " ++ show tok__) $ do - cont tok + (L span tok) <- lexToken + --trace ("token: " ++ show tok) $ do + cont (L (RealSrcSpan span) tok) -lexToken :: P (Located CmmToken) +lexToken :: P (RealLocated CmmToken) lexToken = do inp@(loc1,buf) <- getInput sc <- getLexState case alexScan inp sc of - AlexEOF -> do let span = mkSrcSpan loc1 loc1 + AlexEOF -> do let span = mkRealSrcSpan loc1 loc1 setLastToken span 0 return (L span CmmT_EOF) AlexError (loc2,_) -> do failLocMsgP loc1 loc2 "lexical error" @@ -244,7 +245,7 @@ lexToken AlexToken inp2@(end,buf2) len t -> do setInput inp2 - let span = mkSrcSpan loc1 end + let span = mkRealSrcSpan loc1 end span `seq` setLastToken span len t span buf len @@ -252,7 +253,7 @@ -- Monad stuff -- Stuff that Alex needs to know about our input type: -type AlexInput = (SrcLoc,StringBuffer) +type AlexInput = (RealSrcLoc,StringBuffer) alexInputPrevChar :: AlexInput -> Char alexInputPrevChar (_,s) = prevChar s '\n' diff -Nru ghc-7.0.3/compiler/cmm/CmmLex.x.source ghc-7.2.1/compiler/cmm/CmmLex.x.source --- ghc-7.0.3/compiler/cmm/CmmLex.x.source 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/cmm/CmmLex.x.source 2011-08-07 17:10:05.000000000 +0000 @@ -11,6 +11,7 @@ ----------------------------------------------------------------------------- { +{-# LANGUAGE BangPatterns #-} {-# OPTIONS -Wwarn -w #-} -- The above -Wwarn supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and fix @@ -22,7 +23,7 @@ CmmToken(..), cmmlex, ) where -import Cmm +import OldCmm import Lexer import SrcLoc @@ -172,7 +173,7 @@ -- ----------------------------------------------------------------------------- -- Lexer actions -type Action = SrcSpan -> StringBuffer -> Int -> P (Located CmmToken) +type Action = RealSrcSpan -> StringBuffer -> Int -> P (RealLocated CmmToken) begin :: Int -> Action begin code _span _str _len = do pushLexState code; lexToken @@ -267,7 +268,7 @@ setLine :: Int -> Action setLine code span buf len = do let line = parseUnsignedInteger buf len 10 octDecDigit - setSrcLoc (mkSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1) + setSrcLoc (mkRealSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1) -- subtract one: the line number refers to the *following* line -- trace ("setLine " ++ show line) $ do popLexState @@ -277,7 +278,7 @@ setFile :: Int -> Action setFile code span buf len = do let file = lexemeToFastString (stepOn buf) (len-2) - setSrcLoc (mkSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span)) + setSrcLoc (mkRealSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span)) popLexState pushLexState code lexToken @@ -288,16 +289,16 @@ cmmlex :: (Located CmmToken -> P a) -> P a cmmlex cont = do - tok@(L _ tok__) <- lexToken - --trace ("token: " ++ show tok__) $ do - cont tok + (L span tok) <- lexToken + --trace ("token: " ++ show tok) $ do + cont (L (RealSrcSpan span) tok) -lexToken :: P (Located CmmToken) +lexToken :: P (RealLocated CmmToken) lexToken = do inp@(loc1,buf) <- getInput sc <- getLexState case alexScan inp sc of - AlexEOF -> do let span = mkSrcSpan loc1 loc1 + AlexEOF -> do let span = mkRealSrcSpan loc1 loc1 setLastToken span 0 return (L span CmmT_EOF) AlexError (loc2,_) -> do failLocMsgP loc1 loc2 "lexical error" @@ -306,7 +307,7 @@ lexToken AlexToken inp2@(end,buf2) len t -> do setInput inp2 - let span = mkSrcSpan loc1 end + let span = mkRealSrcSpan loc1 end span `seq` setLastToken span len t span buf len @@ -314,7 +315,7 @@ -- Monad stuff -- Stuff that Alex needs to know about our input type: -type AlexInput = (SrcLoc,StringBuffer) +type AlexInput = (RealSrcLoc,StringBuffer) alexInputPrevChar :: AlexInput -> Char alexInputPrevChar (_,s) = prevChar s '\n' diff -Nru ghc-7.0.3/compiler/cmm/CmmLint.hs ghc-7.2.1/compiler/cmm/CmmLint.hs --- ghc-7.0.3/compiler/cmm/CmmLint.hs 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/cmm/CmmLint.hs 2011-08-07 17:10:05.000000000 +0000 @@ -17,40 +17,41 @@ ) where import BlockId -import Cmm +import OldCmm import CLabel import Outputable -import PprCmm +import OldPprCmm() import Constants import FastString +import Platform -import Control.Monad import Data.Maybe -- ----------------------------------------------------------------------------- -- Exported entry points: cmmLint :: (Outputable d, Outputable h) - => GenCmm d h (ListGraph CmmStmt) -> Maybe SDoc -cmmLint (Cmm tops) = runCmmLint (mapM_ lintCmmTop) tops + => Platform -> GenCmm d h (ListGraph CmmStmt) -> Maybe SDoc +cmmLint platform (Cmm tops) = runCmmLint platform (mapM_ lintCmmTop) tops cmmLintTop :: (Outputable d, Outputable h) - => GenCmmTop d h (ListGraph CmmStmt) -> Maybe SDoc -cmmLintTop top = runCmmLint lintCmmTop top + => Platform -> GenCmmTop d h (ListGraph CmmStmt) -> Maybe SDoc +cmmLintTop platform top = runCmmLint platform lintCmmTop top -runCmmLint :: Outputable a => (a -> CmmLint b) -> a -> Maybe SDoc -runCmmLint l p = +runCmmLint :: PlatformOutputable a + => Platform -> (a -> CmmLint b) -> a -> Maybe SDoc +runCmmLint platform l p = case unCL (l p) of - Left err -> Just (vcat [ptext $ sLit ("Cmm lint error:"), - nest 2 err, - ptext $ sLit ("Program was:"), - nest 2 (ppr p)]) - Right _ -> Nothing + Left err -> Just (vcat [ptext $ sLit ("Cmm lint error:"), + nest 2 err, + ptext $ sLit ("Program was:"), + nest 2 (pprPlatform platform p)]) + Right _ -> Nothing lintCmmTop :: (GenCmmTop h i (ListGraph CmmStmt)) -> CmmLint () -lintCmmTop (CmmProc _ lbl _ (ListGraph blocks)) +lintCmmTop (CmmProc _ lbl (ListGraph blocks)) = addLintInfo (text "in proc " <> pprCLabel lbl) $ - let labels = foldl (\s b -> extendBlockSet s (blockId b)) emptyBlockSet blocks + let labels = foldl (\s b -> setInsert (blockId b) s) setEmpty blocks in mapM_ (lintCmmBlock labels) blocks lintCmmTop (CmmData {}) @@ -70,8 +71,10 @@ lintCmmExpr :: CmmExpr -> CmmLint CmmType lintCmmExpr (CmmLoad expr rep) = do _ <- lintCmmExpr expr - when (widthInBytes (typeWidth rep) >= wORD_SIZE) $ - cmmCheckWordAddress expr + -- Disabled, if we have the inlining phase before the lint phase, + -- we can have funny offsets due to pointer tagging. -- EZY + -- when (widthInBytes (typeWidth rep) >= wORD_SIZE) $ + -- cmmCheckWordAddress expr return rep lintCmmExpr expr@(CmmMachOp op args) = do tys <- mapM lintCmmExpr args @@ -99,14 +102,14 @@ -- This expression should be an address from which a word can be loaded: -- check for funny-looking sub-word offsets. -cmmCheckWordAddress :: CmmExpr -> CmmLint () -cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)]) +_cmmCheckWordAddress :: CmmExpr -> CmmLint () +_cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)]) | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0 = cmmLintDubiousWordOffset e -cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg]) +_cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg]) | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral wORD_SIZE /= 0 = cmmLintDubiousWordOffset e -cmmCheckWordAddress _ +_cmmCheckWordAddress _ = return () -- No warnings for unaligned arithmetic with the node register, @@ -142,7 +145,7 @@ lint (CmmJump e args) = lintCmmExpr e >> mapM_ (lintCmmExpr . hintlessCmm) args lint (CmmReturn ress) = mapM_ (lintCmmExpr . hintlessCmm) ress lint (CmmBranch id) = checkTarget id - checkTarget id = if elemBlockSet id labels then return () + checkTarget id = if setMember id labels then return () else cmmLintErr (text "Branch to nonexistent id" <+> ppr id) lintTarget :: CmmCallTarget -> CmmLint () @@ -152,6 +155,7 @@ 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)) @@ -180,14 +184,14 @@ cmmLintMachOpErr :: CmmExpr -> [CmmType] -> [Width] -> CmmLint a cmmLintMachOpErr expr argsRep opExpectsRep = cmmLintErr (text "in MachOp application: " $$ - nest 2 (pprExpr expr) $$ + nest 2 (ppr expr) $$ (text "op is expecting: " <+> ppr opExpectsRep) $$ (text "arguments provide: " <+> ppr argsRep)) cmmLintAssignErr :: CmmStmt -> CmmType -> CmmType -> CmmLint a cmmLintAssignErr stmt e_ty r_ty = cmmLintErr (text "in assignment: " $$ - nest 2 (vcat [pprStmt stmt, + nest 2 (vcat [ppr stmt, text "Reg ty:" <+> ppr r_ty, text "Rhs ty:" <+> ppr e_ty])) @@ -196,4 +200,4 @@ cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a cmmLintDubiousWordOffset expr = cmmLintErr (text "offset is not a multiple of words: " $$ - nest 2 (pprExpr expr)) + nest 2 (ppr expr)) diff -Nru ghc-7.0.3/compiler/cmm/CmmLive.hs ghc-7.2.1/compiler/cmm/CmmLive.hs --- ghc-7.0.3/compiler/cmm/CmmLive.hs 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/cmm/CmmLive.hs 2011-08-07 17:10:05.000000000 +0000 @@ -1,18 +1,26 @@ -module CmmLive ( - CmmLive, - BlockEntryLiveness, - cmmLiveness, - cmmFormalsToLiveLocals, - ) where +{-# LANGUAGE GADTs #-} -#include "HsVersions.h" +{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} + +module CmmLive + ( CmmLive + , cmmLiveness + , liveLattice + , noLiveOnEntry, xferLive, gen, kill, gen_kill + , removeDeadAssignments + ) +where import BlockId import Cmm -import Dataflow +import CmmExpr +import Control.Monad +import OptimizationFuel +import PprCmmExpr () +import Compiler.Hoopl import Maybes -import Panic +import Outputable import UniqSet ----------------------------------------------------------------------------- @@ -20,193 +28,75 @@ ----------------------------------------------------------------------------- -- | The variables live on entry to a block -type CmmLive = UniqSet LocalReg +type CmmLive = RegSet + +-- | The dataflow lattice +liveLattice :: DataflowLattice CmmLive +liveLattice = DataflowLattice "live LocalReg's" emptyRegSet add + where add _ (OldFact old) (NewFact new) = case unionUniqSets old new of + join -> (changeIf $ sizeUniqSet join > sizeUniqSet old, join) -- | A mapping from block labels to the variables live on entry type BlockEntryLiveness = BlockEnv CmmLive --- | A mapping from block labels to the blocks that target it -type BlockSources = BlockEnv (UniqSet BlockId) - --- | A mapping from block labels to the statements in the block -type BlockStmts = BlockEnv [CmmStmt] - ----------------------------------------------------------------------------- --- | Calculated liveness info for a list of 'CmmBasicBlock' +-- | Calculated liveness info for a CmmGraph ----------------------------------------------------------------------------- -cmmLiveness :: [CmmBasicBlock] -> BlockEntryLiveness -cmmLiveness blocks = - fixedpoint (cmmBlockDependants sources) - (cmmBlockUpdate blocks') - (map blockId blocks) - (mkBlockEnv [(blockId b, emptyUniqSet) | b <- blocks]) - where - sources :: BlockSources - sources = cmmBlockSources blocks - - blocks' :: BlockStmts - blocks' = mkBlockEnv $ map block_name blocks - - block_name :: CmmBasicBlock -> (BlockId, [CmmStmt]) - block_name b = (blockId b, blockStmts b) - -{- --- For debugging, annotate each block with a comment indicating --- the calculated live variables -cmmLivenessComment :: - BlockEnv (UniqSet LocalReg) -> CmmBasicBlock -> CmmBasicBlock -cmmLivenessComment live (BasicBlock ident stmts) = - BasicBlock ident stmts' where - stmts' = (CmmComment $ mkFastString $ showSDoc $ ppr $ live'):stmts - live' = map CmmLocal $ uniqSetToList $ lookupWithDefaultUFM live emptyUniqSet ident --} - - ------------------------------------------------------------------------------ --- | Calculates a table of where one can lookup the blocks that might --- need updating after a given block is updated in the liveness analysis ------------------------------------------------------------------------------ -cmmBlockSources :: [CmmBasicBlock] -> BlockSources -cmmBlockSources blocks = foldr aux emptyBlockEnv blocks - where - aux :: CmmBasicBlock - -> BlockSources - -> BlockSources - aux block sourcesUFM = - foldUniqSet (add_source_edges $ blockId block) - sourcesUFM - (branch_targets $ blockStmts block) - - add_source_edges :: BlockId -> BlockId - -> BlockSources - -> BlockSources - add_source_edges source target ufm = - addToBEnv_Acc (flip addOneToUniqSet) unitUniqSet ufm target source - - branch_targets :: [CmmStmt] -> UniqSet BlockId - branch_targets stmts = - mkUniqSet $ concatMap target stmts where - target (CmmBranch ident) = [ident] - target (CmmCondBranch _ ident) = [ident] - target (CmmSwitch _ blocks) = mapMaybe id blocks - target _ = [] - ------------------------------------------------------------------------------ --- | Given the table calculated by 'cmmBlockSources', list all blocks --- that depend on the result of a particular block. --- --- Used by the call to 'fixedpoint'. ------------------------------------------------------------------------------ -cmmBlockDependants :: BlockSources -> BlockId -> [BlockId] -cmmBlockDependants sources ident = - uniqSetToList $ lookupWithDefaultBEnv sources emptyUniqSet ident - ------------------------------------------------------------------------------ --- | Given the table of type 'BlockStmts' and a block that was updated, --- calculate an updated BlockEntryLiveness ------------------------------------------------------------------------------ -cmmBlockUpdate :: - BlockStmts - -> BlockId - -> Maybe BlockId - -> BlockEntryLiveness - -> Maybe BlockEntryLiveness -cmmBlockUpdate blocks node _ state = - if (sizeUniqSet old_live) == (sizeUniqSet new_live) - then Nothing - else Just $ extendBlockEnv state node new_live - where - new_live, old_live :: CmmLive - new_live = cmmStmtListLive state block_stmts - old_live = lookupWithDefaultBEnv state missing_live node - - block_stmts :: [CmmStmt] - block_stmts = lookupWithDefaultBEnv blocks missing_block node - - missing_live = panic "unknown block id during liveness analysis" - missing_block = panic "unknown block id during liveness analysis" - ------------------------------------------------------------------------------ --- Section: ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ --- CmmBlockLive, cmmStmtListLive and helpers ------------------------------------------------------------------------------ - --- Calculate the live registers for a local block (list of statements) - -cmmStmtListLive :: BlockEntryLiveness -> [CmmStmt] -> CmmLive -cmmStmtListLive other_live stmts = - foldr ((.) . (cmmStmtLive other_live)) id stmts emptyUniqSet - ------------------------------------------------------------------------------ --- This code is written in the style of a state monad, --- but since Control.Monad.State is not in the core --- we can't use it in GHC, so we'll fake one here. --- We don't need a return value so well leave it out. --- Thus 'bind' reduces to function composition. - -type CmmLivenessTransformer = CmmLive -> CmmLive - --- Helpers for the "Monad" -addLive, addKilled :: CmmLive -> CmmLivenessTransformer -addLive new_live live = live `unionUniqSets` new_live -addKilled new_killed live = live `minusUniqSet` new_killed - --------------------------------- --- Liveness of a CmmStmt --------------------------------- -cmmFormalsToLiveLocals :: HintedCmmFormals -> [LocalReg] -cmmFormalsToLiveLocals formals = map hintlessCmm formals - -cmmStmtLive :: BlockEntryLiveness -> CmmStmt -> CmmLivenessTransformer -cmmStmtLive _ (CmmNop) = id -cmmStmtLive _ (CmmComment _) = id -cmmStmtLive _ (CmmAssign reg expr) = - cmmExprLive expr . reg_liveness where - reg_liveness = - case reg of - (CmmLocal reg') -> addKilled $ unitUniqSet reg' - (CmmGlobal _) -> id -cmmStmtLive _ (CmmStore expr1 expr2) = - cmmExprLive expr2 . cmmExprLive expr1 -cmmStmtLive _ (CmmCall target results arguments _ _) = - target_liveness . - foldr ((.) . cmmExprLive) id (map hintlessCmm arguments) . - addKilled (mkUniqSet $ cmmFormalsToLiveLocals results) where - target_liveness = - case target of - (CmmCallee target _) -> cmmExprLive target - (CmmPrim _) -> id -cmmStmtLive other_live (CmmBranch target) = - addLive (lookupWithDefaultBEnv other_live emptyUniqSet target) -cmmStmtLive other_live (CmmCondBranch expr target) = - cmmExprLive expr . - addLive (lookupWithDefaultBEnv other_live emptyUniqSet target) -cmmStmtLive other_live (CmmSwitch expr targets) = - cmmExprLive expr . - (foldr ((.) . (addLive . - lookupWithDefaultBEnv other_live emptyUniqSet)) - id - (mapCatMaybes id targets)) -cmmStmtLive _ (CmmJump expr params) = - const (cmmExprLive expr $ foldr ((.) . cmmExprLive) id (map hintlessCmm params) $ emptyUniqSet) -cmmStmtLive _ (CmmReturn params) = - const (foldr ((.) . cmmExprLive) id (map hintlessCmm params) $ emptyUniqSet) - --------------------------------- --- Liveness of a CmmExpr --------------------------------- -cmmExprLive :: CmmExpr -> CmmLivenessTransformer -cmmExprLive expr = addLive (mkUniqSet $ expr_liveness expr) where - expr_liveness :: CmmExpr -> [LocalReg] - expr_liveness (CmmLit _) = [] - expr_liveness (CmmLoad expr _) = expr_liveness expr - expr_liveness (CmmReg reg) = reg_liveness reg - expr_liveness (CmmMachOp _ exprs) = concatMap expr_liveness exprs - expr_liveness (CmmRegOff reg _) = reg_liveness reg - expr_liveness (CmmStackSlot _ _) = panic "cmmExprLive CmmStackSlot" - - reg_liveness :: CmmReg -> [LocalReg] - reg_liveness (CmmLocal reg) = [reg] - reg_liveness (CmmGlobal _) = [] + +cmmLiveness :: CmmGraph -> FuelUniqSM BlockEntryLiveness +cmmLiveness graph = + liftM check $ liftM snd $ dataflowPassBwd graph [] $ analBwd liveLattice xferLive + where entry = g_entry graph + check facts = noLiveOnEntry entry (expectJust "check" $ mapLookup entry facts) facts + +-- | On entry to the procedure, there had better not be any LocalReg's live-in. +noLiveOnEntry :: BlockId -> CmmLive -> a -> a +noLiveOnEntry bid in_fact x = + if isEmptyUniqSet in_fact then x + else pprPanic "LocalReg's live-in to graph" (ppr bid <+> ppr in_fact) + +-- | The transfer equations use the traditional 'gen' and 'kill' +-- notations, which should be familiar from the Dragon Book. +gen :: UserOfLocalRegs a => a -> RegSet -> RegSet +gen a live = foldRegsUsed extendRegSet live a +kill :: DefinerOfLocalRegs a => a -> RegSet -> RegSet +kill a live = foldRegsDefd delOneFromUniqSet live a + +gen_kill :: (DefinerOfLocalRegs a, UserOfLocalRegs a) => a -> CmmLive -> CmmLive +gen_kill a = gen a . kill a + +-- | The transfer function +-- EZY: Bits of this analysis are duplicated in CmmSpillReload, though +-- it's not really easy to efficiently reuse all of this. Keep in mind +-- if you need to update this analysis. +xferLive :: BwdTransfer CmmNode CmmLive +xferLive = mkBTransfer3 fst mid lst + where fst _ f = f + mid :: CmmNode O O -> CmmLive -> CmmLive + mid n f = gen_kill n f + lst :: CmmNode O C -> FactBase CmmLive -> CmmLive + -- slightly inefficient: kill is unnecessary for emptyRegSet + lst n f = gen_kill n + $ case n of CmmCall{} -> emptyRegSet + CmmForeignCall{} -> emptyRegSet + _ -> joinOutFacts liveLattice n f + +----------------------------------------------------------------------------- +-- Removing assignments to dead variables +----------------------------------------------------------------------------- + +removeDeadAssignments :: CmmGraph -> FuelUniqSM CmmGraph +removeDeadAssignments g = + liftM fst $ dataflowPassBwd g [] $ analRewBwd liveLattice xferLive rewrites + where rewrites = deepBwdRw3 nothing middle nothing + -- Beware: deepBwdRw with one polymorphic function seems more reasonable here, + -- but GHC panics while compiling, see bug #4045. + middle :: CmmNode O O -> Fact O CmmLive -> CmmReplGraph O O + middle (CmmAssign (CmmLocal reg') _) live | not (reg' `elemRegSet` live) = return $ Just emptyGraph + -- XXX maybe this should be somewhere else... + middle (CmmAssign lhs (CmmReg rhs)) _ | lhs == rhs = return $ Just emptyGraph + middle (CmmStore lhs (CmmLoad rhs _)) _ | lhs == rhs = return $ Just emptyGraph + middle _ _ = return Nothing + + nothing :: CmmNode e x -> Fact x CmmLive -> CmmReplGraph e x + nothing _ _ = return Nothing diff -Nru ghc-7.0.3/compiler/cmm/CmmLiveZ.hs ghc-7.2.1/compiler/cmm/CmmLiveZ.hs --- ghc-7.0.3/compiler/cmm/CmmLiveZ.hs 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/cmm/CmmLiveZ.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,84 +0,0 @@ - -module CmmLiveZ - ( CmmLive - , cmmLivenessZ - , liveLattice - , middleLiveness, noLiveOnEntry - ) -where - -import BlockId -import CmmExpr -import CmmTx -import DFMonad -import Control.Monad -import PprCmm() -import PprCmmZ() -import ZipCfg -import ZipDataflow -import ZipCfgCmmRep - -import Maybes -import Outputable -import UniqSet - ------------------------------------------------------------------------------ --- Calculating what variables are live on entry to a basic block ------------------------------------------------------------------------------ - --- | The variables live on entry to a block -type CmmLive = RegSet - --- | The dataflow lattice -liveLattice :: DataflowLattice CmmLive -liveLattice = DataflowLattice "live LocalReg's" emptyUniqSet add False - where add new old = - let join = unionUniqSets new old in - (if sizeUniqSet join > sizeUniqSet old then aTx else noTx) join - --- | A mapping from block labels to the variables live on entry -type BlockEntryLiveness = BlockEnv CmmLive - ------------------------------------------------------------------------------ --- | Calculated liveness info for a CmmGraph ------------------------------------------------------------------------------ -cmmLivenessZ :: CmmGraph -> FuelMonad BlockEntryLiveness -cmmLivenessZ g@(LGraph entry _) = - liftM (check . zdfFpFacts) (res :: FuelMonad (CmmBackwardFixedPoint CmmLive)) - where res = zdfSolveFrom emptyBlockEnv "liveness analysis" liveLattice transfers - emptyUniqSet (graphOfLGraph g) - transfers = BackwardTransfers (flip const) mid last - mid m = gen_kill m . midLive m - last l = gen_kill l . lastLive l - check facts = - noLiveOnEntry entry (expectJust "check" $ lookupBlockEnv facts entry) facts - -gen_kill :: (DefinerOfLocalRegs a, UserOfLocalRegs a) => a -> CmmLive -> CmmLive -gen_kill a = gen a . kill a - -middleLiveness :: Middle -> CmmLive -> CmmLive -middleLiveness = gen_kill - --- | On entry to the procedure, there had better not be any LocalReg's live-in. -noLiveOnEntry :: BlockId -> CmmLive -> a -> a -noLiveOnEntry bid in_fact x = - if isEmptyUniqSet in_fact then x - else pprPanic "LocalReg's live-in to graph" (ppr bid <+> ppr in_fact) - --- | The transfer equations use the traditional 'gen' and 'kill' --- notations, which should be familiar from the dragon book. -gen :: UserOfLocalRegs a => a -> RegSet -> RegSet -gen a live = foldRegsUsed extendRegSet live a -kill :: DefinerOfLocalRegs a => a -> RegSet -> RegSet -kill a live = foldRegsDefd delOneFromUniqSet live a - -midLive :: Middle -> CmmLive -> CmmLive -midLive (MidForeignCall {}) _ = emptyUniqSet -midLive _ live = live - -lastLive :: Last -> (BlockId -> CmmLive) -> CmmLive -lastLive l env = last l - where last (LastBranch id) = env id - last (LastCall _ _ _ _ _) = emptyUniqSet - last (LastCondBranch _ t f) = unionUniqSets (env t) (env f) - last (LastSwitch _ tbl) = unionManyUniqSets $ map env (catMaybes tbl) diff -Nru ghc-7.0.3/compiler/cmm/CmmMachOp.hs ghc-7.2.1/compiler/cmm/CmmMachOp.hs --- ghc-7.0.3/compiler/cmm/CmmMachOp.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/compiler/cmm/CmmMachOp.hs 2011-08-07 17:10:05.000000000 +0000 @@ -0,0 +1,455 @@ + +module CmmMachOp + ( MachOp(..) + , pprMachOp, isCommutableMachOp, isAssociativeMachOp + , isComparisonMachOp, machOpResultType + , machOpArgReps, maybeInvertComparison + + -- MachOp builders + , mo_wordAdd, mo_wordSub, mo_wordEq, mo_wordNe,mo_wordMul, mo_wordSQuot + , mo_wordSRem, mo_wordSNeg, mo_wordUQuot, mo_wordURem + , mo_wordSGe, mo_wordSLe, mo_wordSGt, mo_wordSLt, mo_wordUGe + , mo_wordULe, mo_wordUGt, mo_wordULt + , mo_wordAnd, mo_wordOr, mo_wordXor, mo_wordNot, mo_wordShl, mo_wordSShr, mo_wordUShr + , mo_u_8To32, mo_s_8To32, mo_u_16To32, mo_s_16To32 + , mo_u_8ToWord, mo_s_8ToWord, mo_u_16ToWord, mo_s_16ToWord, mo_u_32ToWord, mo_s_32ToWord + , mo_32To8, mo_32To16, mo_WordTo8, mo_WordTo16, mo_WordTo32 + + -- CallishMachOp + , CallishMachOp(..) + , pprCallishMachOp + ) +where + +#include "HsVersions.h" + +import CmmType +import Outputable + +----------------------------------------------------------------------------- +-- MachOp +----------------------------------------------------------------------------- + +{- | +Machine-level primops; ones which we can reasonably delegate to the +native code generators to handle. + +Most operations are parameterised by the 'Width' that they operate on. +Some operations have separate signed and unsigned versions, and float +and integer versions. +-} + +data MachOp + -- Integer operations (insensitive to signed/unsigned) + = MO_Add Width + | MO_Sub Width + | MO_Eq Width + | MO_Ne Width + | MO_Mul Width -- low word of multiply + + -- Signed multiply/divide + | MO_S_MulMayOflo Width -- nonzero if signed multiply overflows + | MO_S_Quot Width -- signed / (same semantics as IntQuotOp) + | MO_S_Rem Width -- signed % (same semantics as IntRemOp) + | MO_S_Neg Width -- unary - + + -- Unsigned multiply/divide + | MO_U_MulMayOflo Width -- nonzero if unsigned multiply overflows + | MO_U_Quot Width -- unsigned / (same semantics as WordQuotOp) + | MO_U_Rem Width -- unsigned % (same semantics as WordRemOp) + + -- Signed comparisons + | MO_S_Ge Width + | MO_S_Le Width + | MO_S_Gt Width + | MO_S_Lt Width + + -- Unsigned comparisons + | MO_U_Ge Width + | MO_U_Le Width + | MO_U_Gt Width + | MO_U_Lt Width + + -- Floating point arithmetic + | MO_F_Add Width + | MO_F_Sub Width + | MO_F_Neg Width -- unary - + | MO_F_Mul Width + | MO_F_Quot Width + + -- Floating point comparison + | MO_F_Eq Width + | MO_F_Ne Width + | MO_F_Ge Width + | MO_F_Le Width + | MO_F_Gt Width + | MO_F_Lt Width + + -- Bitwise operations. Not all of these may be supported + -- at all sizes, and only integral Widths are valid. + | MO_And Width + | MO_Or Width + | MO_Xor Width + | MO_Not Width + | MO_Shl Width + | MO_U_Shr Width -- unsigned shift right + | MO_S_Shr Width -- signed shift right + + -- Conversions. Some of these will be NOPs. + -- Floating-point conversions use the signed variant. + | MO_SF_Conv Width Width -- Signed int -> Float + | MO_FS_Conv Width Width -- Float -> Signed int + | MO_SS_Conv Width Width -- Signed int -> Signed int + | MO_UU_Conv Width Width -- unsigned int -> unsigned int + | MO_FF_Conv Width Width -- Float -> Float + deriving (Eq, Show) + +pprMachOp :: MachOp -> SDoc +pprMachOp mo = text (show mo) + + + +-- ----------------------------------------------------------------------------- +-- Some common MachReps + +-- A 'wordRep' is a machine word on the target architecture +-- Specifically, it is the size of an Int#, Word#, Addr# +-- and the unit of allocation on the stack and the heap +-- Any pointer is also guaranteed to be a wordRep. + +mo_wordAdd, mo_wordSub, mo_wordEq, mo_wordNe,mo_wordMul, mo_wordSQuot + , mo_wordSRem, mo_wordSNeg, mo_wordUQuot, mo_wordURem + , mo_wordSGe, mo_wordSLe, mo_wordSGt, mo_wordSLt, mo_wordUGe + , mo_wordULe, mo_wordUGt, mo_wordULt + , mo_wordAnd, mo_wordOr, mo_wordXor, mo_wordNot, mo_wordShl, mo_wordSShr, mo_wordUShr + , mo_u_8To32, mo_s_8To32, mo_u_16To32, mo_s_16To32 + , mo_u_8ToWord, mo_s_8ToWord, mo_u_16ToWord, mo_s_16ToWord, mo_u_32ToWord, mo_s_32ToWord + , mo_32To8, mo_32To16, mo_WordTo8, mo_WordTo16, mo_WordTo32 + :: MachOp + +mo_wordAdd = MO_Add wordWidth +mo_wordSub = MO_Sub wordWidth +mo_wordEq = MO_Eq wordWidth +mo_wordNe = MO_Ne wordWidth +mo_wordMul = MO_Mul wordWidth +mo_wordSQuot = MO_S_Quot wordWidth +mo_wordSRem = MO_S_Rem wordWidth +mo_wordSNeg = MO_S_Neg wordWidth +mo_wordUQuot = MO_U_Quot wordWidth +mo_wordURem = MO_U_Rem wordWidth + +mo_wordSGe = MO_S_Ge wordWidth +mo_wordSLe = MO_S_Le wordWidth +mo_wordSGt = MO_S_Gt wordWidth +mo_wordSLt = MO_S_Lt wordWidth + +mo_wordUGe = MO_U_Ge wordWidth +mo_wordULe = MO_U_Le wordWidth +mo_wordUGt = MO_U_Gt wordWidth +mo_wordULt = MO_U_Lt wordWidth + +mo_wordAnd = MO_And wordWidth +mo_wordOr = MO_Or wordWidth +mo_wordXor = MO_Xor wordWidth +mo_wordNot = MO_Not wordWidth +mo_wordShl = MO_Shl wordWidth +mo_wordSShr = MO_S_Shr wordWidth +mo_wordUShr = MO_U_Shr wordWidth + +mo_u_8To32 = MO_UU_Conv W8 W32 +mo_s_8To32 = MO_SS_Conv W8 W32 +mo_u_16To32 = MO_UU_Conv W16 W32 +mo_s_16To32 = MO_SS_Conv W16 W32 + +mo_u_8ToWord = MO_UU_Conv W8 wordWidth +mo_s_8ToWord = MO_SS_Conv W8 wordWidth +mo_u_16ToWord = MO_UU_Conv W16 wordWidth +mo_s_16ToWord = MO_SS_Conv W16 wordWidth +mo_s_32ToWord = MO_SS_Conv W32 wordWidth +mo_u_32ToWord = MO_UU_Conv W32 wordWidth + +mo_WordTo8 = MO_UU_Conv wordWidth W8 +mo_WordTo16 = MO_UU_Conv wordWidth W16 +mo_WordTo32 = MO_UU_Conv wordWidth W32 + +mo_32To8 = MO_UU_Conv W32 W8 +mo_32To16 = MO_UU_Conv W32 W16 + + +-- ---------------------------------------------------------------------------- +-- isCommutableMachOp + +{- | +Returns 'True' if the MachOp has commutable arguments. This is used +in the platform-independent Cmm optimisations. + +If in doubt, return 'False'. This generates worse code on the +native routes, but is otherwise harmless. +-} +isCommutableMachOp :: MachOp -> Bool +isCommutableMachOp mop = + case mop of + MO_Add _ -> True + MO_Eq _ -> True + MO_Ne _ -> True + MO_Mul _ -> True + MO_S_MulMayOflo _ -> True + MO_U_MulMayOflo _ -> True + MO_And _ -> True + MO_Or _ -> True + MO_Xor _ -> True + _other -> False + +-- ---------------------------------------------------------------------------- +-- isAssociativeMachOp + +{- | +Returns 'True' if the MachOp is associative (i.e. @(x+y)+z == x+(y+z)@) +This is used in the platform-independent Cmm optimisations. + +If in doubt, return 'False'. This generates worse code on the +native routes, but is otherwise harmless. +-} +isAssociativeMachOp :: MachOp -> Bool +isAssociativeMachOp mop = + case mop of + MO_Add {} -> True -- NB: does not include + MO_Mul {} -> True -- floatint point! + MO_And {} -> True + MO_Or {} -> True + MO_Xor {} -> True + _other -> False + +-- ---------------------------------------------------------------------------- +-- isComparisonMachOp + +{- | +Returns 'True' if the MachOp is a comparison. + +If in doubt, return False. This generates worse code on the +native routes, but is otherwise harmless. +-} +isComparisonMachOp :: MachOp -> Bool +isComparisonMachOp mop = + case mop of + MO_Eq _ -> True + MO_Ne _ -> True + MO_S_Ge _ -> True + MO_S_Le _ -> True + MO_S_Gt _ -> True + MO_S_Lt _ -> True + MO_U_Ge _ -> True + MO_U_Le _ -> True + MO_U_Gt _ -> True + MO_U_Lt _ -> True + MO_F_Eq {} -> True + MO_F_Ne {} -> True + MO_F_Ge {} -> True + MO_F_Le {} -> True + MO_F_Gt {} -> True + MO_F_Lt {} -> True + _other -> False + +-- ----------------------------------------------------------------------------- +-- Inverting conditions + +-- Sometimes it's useful to be able to invert the sense of a +-- condition. Not all conditional tests are invertible: in +-- particular, floating point conditionals cannot be inverted, because +-- there exist floating-point values which return False for both senses +-- of a condition (eg. !(NaN > NaN) && !(NaN /<= NaN)). + +maybeInvertComparison :: MachOp -> Maybe MachOp +maybeInvertComparison op + = case op of -- None of these Just cases include floating point + MO_Eq r -> Just (MO_Ne r) + MO_Ne r -> Just (MO_Eq r) + MO_U_Lt r -> Just (MO_U_Ge r) + MO_U_Gt r -> Just (MO_U_Le r) + MO_U_Le r -> Just (MO_U_Gt r) + MO_U_Ge r -> Just (MO_U_Lt r) + MO_S_Lt r -> Just (MO_S_Ge r) + MO_S_Gt r -> Just (MO_S_Le r) + MO_S_Le r -> Just (MO_S_Gt r) + MO_S_Ge r -> Just (MO_S_Lt r) + MO_F_Eq r -> Just (MO_F_Ne r) + MO_F_Ne r -> Just (MO_F_Eq r) + MO_F_Ge r -> Just (MO_F_Le r) + MO_F_Le r -> Just (MO_F_Ge r) + MO_F_Gt r -> Just (MO_F_Lt r) + MO_F_Lt r -> Just (MO_F_Gt r) + _other -> Nothing + +-- ---------------------------------------------------------------------------- +-- machOpResultType + +{- | +Returns the MachRep of the result of a MachOp. +-} +machOpResultType :: MachOp -> [CmmType] -> CmmType +machOpResultType mop tys = + case mop of + MO_Add {} -> ty1 -- Preserve GC-ptr-hood + MO_Sub {} -> ty1 -- of first arg + MO_Mul r -> cmmBits r + MO_S_MulMayOflo r -> cmmBits r + MO_S_Quot r -> cmmBits r + MO_S_Rem r -> cmmBits r + MO_S_Neg r -> cmmBits r + MO_U_MulMayOflo r -> cmmBits r + MO_U_Quot r -> cmmBits r + MO_U_Rem r -> cmmBits r + + MO_Eq {} -> comparisonResultRep + MO_Ne {} -> comparisonResultRep + MO_S_Ge {} -> comparisonResultRep + MO_S_Le {} -> comparisonResultRep + MO_S_Gt {} -> comparisonResultRep + MO_S_Lt {} -> comparisonResultRep + + MO_U_Ge {} -> comparisonResultRep + MO_U_Le {} -> comparisonResultRep + MO_U_Gt {} -> comparisonResultRep + MO_U_Lt {} -> comparisonResultRep + + MO_F_Add r -> cmmFloat r + MO_F_Sub r -> cmmFloat r + MO_F_Mul r -> cmmFloat r + MO_F_Quot r -> cmmFloat r + MO_F_Neg r -> cmmFloat r + MO_F_Eq {} -> comparisonResultRep + MO_F_Ne {} -> comparisonResultRep + MO_F_Ge {} -> comparisonResultRep + MO_F_Le {} -> comparisonResultRep + MO_F_Gt {} -> comparisonResultRep + MO_F_Lt {} -> comparisonResultRep + + MO_And {} -> ty1 -- Used for pointer masking + MO_Or {} -> ty1 + MO_Xor {} -> ty1 + MO_Not r -> cmmBits r + MO_Shl r -> cmmBits r + MO_U_Shr r -> cmmBits r + MO_S_Shr r -> cmmBits r + + MO_SS_Conv _ to -> cmmBits to + MO_UU_Conv _ to -> cmmBits to + MO_FS_Conv _ to -> cmmBits to + MO_SF_Conv _ to -> cmmFloat to + MO_FF_Conv _ to -> cmmFloat to + where + (ty1:_) = tys + +comparisonResultRep :: CmmType +comparisonResultRep = bWord -- is it? + + +-- ----------------------------------------------------------------------------- +-- machOpArgReps + +-- | This function is used for debugging only: we can check whether an +-- application of a MachOp is "type-correct" by checking that the MachReps of +-- its arguments are the same as the MachOp expects. This is used when +-- linting a CmmExpr. + +machOpArgReps :: MachOp -> [Width] +machOpArgReps op = + case op of + MO_Add r -> [r,r] + MO_Sub r -> [r,r] + MO_Eq r -> [r,r] + MO_Ne r -> [r,r] + MO_Mul r -> [r,r] + MO_S_MulMayOflo r -> [r,r] + MO_S_Quot r -> [r,r] + MO_S_Rem r -> [r,r] + MO_S_Neg r -> [r] + MO_U_MulMayOflo r -> [r,r] + MO_U_Quot r -> [r,r] + MO_U_Rem r -> [r,r] + + MO_S_Ge r -> [r,r] + MO_S_Le r -> [r,r] + MO_S_Gt r -> [r,r] + MO_S_Lt r -> [r,r] + + MO_U_Ge r -> [r,r] + MO_U_Le r -> [r,r] + MO_U_Gt r -> [r,r] + MO_U_Lt r -> [r,r] + + MO_F_Add r -> [r,r] + MO_F_Sub r -> [r,r] + MO_F_Mul r -> [r,r] + MO_F_Quot r -> [r,r] + MO_F_Neg r -> [r] + MO_F_Eq r -> [r,r] + MO_F_Ne r -> [r,r] + MO_F_Ge r -> [r,r] + MO_F_Le r -> [r,r] + MO_F_Gt r -> [r,r] + MO_F_Lt r -> [r,r] + + MO_And r -> [r,r] + MO_Or r -> [r,r] + MO_Xor r -> [r,r] + MO_Not r -> [r] + MO_Shl r -> [r,wordWidth] + MO_U_Shr r -> [r,wordWidth] + MO_S_Shr r -> [r,wordWidth] + + MO_SS_Conv from _ -> [from] + MO_UU_Conv from _ -> [from] + MO_SF_Conv from _ -> [from] + MO_FS_Conv from _ -> [from] + MO_FF_Conv from _ -> [from] + +----------------------------------------------------------------------------- +-- CallishMachOp +----------------------------------------------------------------------------- + +-- CallishMachOps tend to be implemented by foreign calls in some backends, +-- so we separate them out. In Cmm, these can only occur in a +-- statement position, in contrast to an ordinary MachOp which can occur +-- anywhere in an expression. +data CallishMachOp + = MO_F64_Pwr + | MO_F64_Sin + | MO_F64_Cos + | MO_F64_Tan + | MO_F64_Sinh + | MO_F64_Cosh + | MO_F64_Tanh + | MO_F64_Asin + | MO_F64_Acos + | MO_F64_Atan + | MO_F64_Log + | MO_F64_Exp + | MO_F64_Sqrt + | MO_F32_Pwr + | MO_F32_Sin + | MO_F32_Cos + | MO_F32_Tan + | MO_F32_Sinh + | MO_F32_Cosh + | MO_F32_Tanh + | MO_F32_Asin + | MO_F32_Acos + | MO_F32_Atan + | MO_F32_Log + | MO_F32_Exp + | MO_F32_Sqrt + | MO_WriteBarrier + | MO_Touch -- Keep variables live (when using interior pointers) + + -- Note that these three MachOps all take 1 extra parameter than the + -- standard C lib versions. The extra (last) parameter contains + -- alignment of the pointers. Used for optimisation in backends. + | MO_Memcpy + | MO_Memset + | MO_Memmove + deriving (Eq, Show) + +pprCallishMachOp :: CallishMachOp -> SDoc +pprCallishMachOp mo = text (show mo) + diff -Nru ghc-7.0.3/compiler/cmm/CmmNode.hs ghc-7.2.1/compiler/cmm/CmmNode.hs --- ghc-7.0.3/compiler/cmm/CmmNode.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/compiler/cmm/CmmNode.hs 2011-08-07 17:10:05.000000000 +0000 @@ -0,0 +1,405 @@ +-- CmmNode type for representation using Hoopl graphs. +{-# LANGUAGE GADTs #-} + +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} +#if __GLASGOW_HASKELL__ >= 701 +-- GHC 7.0.1 improved incomplete pattern warnings with GADTs +{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} +#endif + +module CmmNode + ( CmmNode(..) + , UpdFrameOffset, Convention(..), ForeignConvention(..), ForeignTarget(..) + , mapExp, mapExpDeep, wrapRecExp, foldExp, foldExpDeep, wrapRecExpf + , mapExpM, mapExpDeepM, wrapRecExpM + ) +where + +import CmmExpr +import CmmDecl +import FastString +import ForeignCall +import SMRep + +import Compiler.Hoopl +import Data.Maybe +import Data.List (tails) +import Prelude hiding (succ) + + +------------------------ +-- CmmNode + +data CmmNode e x where + CmmEntry :: Label -> CmmNode C O + + CmmComment :: FastString -> CmmNode O O + + CmmAssign :: CmmReg -> CmmExpr -> CmmNode O O + -- Assign to register + + CmmStore :: CmmExpr -> CmmExpr -> CmmNode O O + -- Assign to memory location. Size is + -- given by cmmExprType of the rhs. + + CmmUnsafeForeignCall :: -- An unsafe foreign call; + -- see Note [Foreign calls] + -- Like a "fat machine instruction"; can occur + -- in the middle of a block + ForeignTarget -> -- call target + [CmmFormal] -> -- zero or more results + [CmmActual] -> -- zero or more arguments + CmmNode O O + -- Semantics: kills only result regs; all other regs (both GlobalReg + -- and LocalReg) are preserved. But there is a current + -- bug for what can be put in arguments, see + -- Note [Register Parameter Passing] + + CmmBranch :: Label -> CmmNode O C -- Goto another block in the same procedure + + CmmCondBranch :: { -- conditional branch + cml_pred :: CmmExpr, + cml_true, cml_false :: Label + } -> CmmNode O C + + CmmSwitch :: CmmExpr -> [Maybe Label] -> CmmNode O C -- Table branch + -- The scrutinee is zero-based; + -- zero -> first block + -- one -> second block etc + -- Undefined outside range, and when there's a Nothing + + CmmCall :: { -- A native call or tail call + cml_target :: CmmExpr, -- never a CmmPrim to a CallishMachOp! + + cml_cont :: Maybe Label, + -- Label of continuation (Nothing for return or tail call) + +-- ToDO: add this: +-- cml_args_regs :: [GlobalReg], +-- It says which GlobalRegs are live for the parameters at the +-- moment of the call. Later stages can use this to give liveness +-- everywhere, which in turn guides register allocation. +-- It is the companion of cml_args; cml_args says which stack words +-- hold parameters, while cml_arg_regs says which global regs hold parameters. +-- But do note [Register parameter passing] + + cml_args :: ByteOff, + -- Byte offset, from the *old* end of the Area associated with + -- the Label (if cml_cont = Nothing, then Old area), of + -- youngest outgoing arg. Set the stack pointer to this before + -- transferring control. + -- (NB: an update frame might also have been stored in the Old + -- area, but it'll be in an older part than the args.) + + cml_ret_args :: ByteOff, + -- For calls *only*, the byte offset for youngest returned value + -- This is really needed at the *return* point rather than here + -- at the call, but in practice it's convenient to record it here. + + cml_ret_off :: ByteOff + -- For calls *only*, the byte offset of the base of the frame that + -- must be described by the info table for the return point. + -- The older words are an update frames, which have their own + -- info-table and layout information + + -- From a liveness point of view, the stack words older than + -- cml_ret_off are treated as live, even if the sequel of + -- the call goes into a loop. + } -> CmmNode O C + + CmmForeignCall :: { -- A safe foreign call; see Note [Foreign calls] + -- Always the last node of a block + tgt :: ForeignTarget, -- call target and convention + res :: [CmmFormal], -- zero or more results + args :: [CmmActual], -- zero or more arguments; see Note [Register parameter passing] + succ :: Label, -- Label of continuation + updfr :: UpdFrameOffset, -- where the update frame is (for building infotable) + intrbl:: Bool -- whether or not the call is interruptible + } -> CmmNode O C + +{- Note [Foreign calls] +~~~~~~~~~~~~~~~~~~~~~~~ +A CmmUnsafeForeignCall is used for *unsafe* foreign calls; +a CmmForeignCall call is used for *safe* foreign calls. + +Unsafe ones are mostly easy: think of them as a "fat machine +instruction". In particular, they do *not* kill all live registers, +just the registers they return to (there was a bit of code in GHC that +conservatively assumed otherwise.) However, see [Register parameter passing]. + +Safe ones are trickier. A safe foreign call + r = f(x) +ultimately expands to + push "return address" -- Never used to return to; + -- just points an info table + save registers into TSO + call suspendThread + r = f(x) -- Make the call + call resumeThread + restore registers + pop "return address" +We cannot "lower" a safe foreign call to this sequence of Cmms, because +after we've saved Sp all the Cmm optimiser's assumptions are broken. +Furthermore, currently the smart Cmm constructors know the calling +conventions for Haskell, the garbage collector, etc, and "lower" them +so that a LastCall passes no parameters or results. But the smart +constructors do *not* (currently) know the foreign call conventions. + +Note that a safe foreign call needs an info table. +-} + +{- Note [Register parameter passing] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +On certain architectures, some registers are utilized for parameter +passing in the C calling convention. For example, in x86-64 Linux +convention, rdi, rsi, rdx and rcx (as well as r8 and r9) may be used for +argument passing. These are registers R3-R6, which our generated +code may also be using; as a result, it's necessary to save these +values before doing a foreign call. This is done during initial +code generation in callerSaveVolatileRegs in StgCmmUtils.hs. However, +one result of doing this is that the contents of these registers +may mysteriously change if referenced inside the arguments. This +is dangerous, so you'll need to disable inlining much in the same +way is done in cmm/CmmOpt.hs currently. We should fix this! +-} + +--------------------------------------------- +-- Eq instance of CmmNode +-- It is a shame GHC cannot infer it by itself :( + +instance Eq (CmmNode e x) where + (CmmEntry a) == (CmmEntry a') = a==a' + (CmmComment a) == (CmmComment a') = a==a' + (CmmAssign a b) == (CmmAssign a' b') = a==a' && b==b' + (CmmStore a b) == (CmmStore a' b') = a==a' && b==b' + (CmmUnsafeForeignCall a b c) == (CmmUnsafeForeignCall a' b' c') = a==a' && b==b' && c==c' + (CmmBranch a) == (CmmBranch a') = a==a' + (CmmCondBranch a b c) == (CmmCondBranch a' b' c') = a==a' && b==b' && c==c' + (CmmSwitch a b) == (CmmSwitch a' b') = a==a' && b==b' + (CmmCall a b c d e) == (CmmCall a' b' c' d' e') = a==a' && b==b' && c==c' && d==d' && e==e' + (CmmForeignCall a b c d e f) == (CmmForeignCall a' b' c' d' e' f') = a==a' && b==b' && c==c' && d==d' && e==e' && f==f' + _ == _ = False + +---------------------------------------------- +-- Hoopl instances of CmmNode + +instance NonLocal CmmNode where + entryLabel (CmmEntry l) = l + + successors (CmmBranch l) = [l] + successors (CmmCondBranch {cml_true=t, cml_false=f}) = [f, t] -- meets layout constraint + successors (CmmSwitch _ ls) = catMaybes ls + successors (CmmCall {cml_cont=l}) = maybeToList l + successors (CmmForeignCall {succ=l}) = [l] + + +instance HooplNode CmmNode where + mkBranchNode label = CmmBranch label + mkLabelNode label = CmmEntry label + +-------------------------------------------------- +-- Various helper types + +type UpdFrameOffset = ByteOff + +data Convention + = NativeDirectCall -- Native C-- call skipping the node (closure) argument + | NativeNodeCall -- Native C-- call including the node argument + | NativeReturn -- Native C-- return + | Slow -- Slow entry points: all args pushed on the stack + | GC -- Entry to the garbage collector: uses the node reg! + | PrimOpCall -- Calling prim ops + | PrimOpReturn -- Returning from prim ops + | Foreign -- Foreign call/return + ForeignConvention + | Private + -- Used for control transfers within a (pre-CPS) procedure All + -- jump sites known, never pushed on the stack (hence no SRT) + -- You can choose whatever calling convention you please + -- (provided you make sure all the call sites agree)! + -- This data type eventually to be extended to record the convention. + deriving( Eq ) + +data ForeignConvention + = ForeignConvention + CCallConv -- Which foreign-call convention + [ForeignHint] -- Extra info about the args + [ForeignHint] -- Extra info about the result + deriving Eq + +data ForeignTarget -- The target of a foreign call + = ForeignTarget -- A foreign procedure + CmmExpr -- Its address + ForeignConvention -- Its calling convention + | PrimTarget -- A possibly-side-effecting machine operation + CallishMachOp -- Which one + deriving Eq + +-------------------------------------------------- +-- Instances of register and slot users / definers + +instance UserOfLocalRegs (CmmNode e x) where + foldRegsUsed f z n = case n of + CmmAssign _ expr -> fold f z expr + CmmStore addr rval -> fold f (fold f z addr) rval + CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args + CmmCondBranch expr _ _ -> fold f z expr + CmmSwitch expr _ -> fold f z expr + CmmCall {cml_target=tgt} -> fold f z tgt + CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args + _ -> z + where fold :: forall a b. + UserOfLocalRegs a => + (b -> LocalReg -> b) -> b -> a -> b + fold f z n = foldRegsUsed f z n + +instance UserOfLocalRegs ForeignTarget where + foldRegsUsed _f z (PrimTarget _) = z + foldRegsUsed f z (ForeignTarget e _) = foldRegsUsed f z e + +instance DefinerOfLocalRegs (CmmNode e x) where + foldRegsDefd f z n = case n of + CmmAssign lhs _ -> fold f z lhs + CmmUnsafeForeignCall _ fs _ -> fold f z fs + CmmForeignCall {res=res} -> fold f z res + _ -> z + where fold :: forall a b. + DefinerOfLocalRegs a => + (b -> LocalReg -> b) -> b -> a -> b + fold f z n = foldRegsDefd f z n + + +instance UserOfSlots (CmmNode e x) where + foldSlotsUsed f z n = case n of + CmmAssign _ expr -> fold f z expr + CmmStore addr rval -> fold f (fold f z addr) rval + CmmUnsafeForeignCall _ _ args -> fold f z args + CmmCondBranch expr _ _ -> fold f z expr + CmmSwitch expr _ -> fold f z expr + CmmCall {cml_target=tgt} -> fold f z tgt + CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args + _ -> z + where fold :: forall a b. + UserOfSlots a => + (b -> SubArea -> b) -> b -> a -> b + fold f z n = foldSlotsUsed f z n + +instance UserOfSlots ForeignTarget where + foldSlotsUsed f z (ForeignTarget e _) = foldSlotsUsed f z e + foldSlotsUsed _f z (PrimTarget _) = z + +instance DefinerOfSlots (CmmNode e x) where + foldSlotsDefd f z n = case n of + CmmStore (CmmStackSlot a i) expr -> f z (a, i, widthInBytes $ typeWidth $ cmmExprType expr) + CmmForeignCall {res=res} -> fold f z $ map foreign_call_slot res + _ -> z + where + fold :: forall a b. + DefinerOfSlots a => + (b -> SubArea -> b) -> b -> a -> b + fold f z n = foldSlotsDefd f z n + foreign_call_slot r = case widthInBytes $ typeWidth $ localRegType r of w -> (RegSlot r, w, w) + +----------------------------------- +-- mapping Expr in CmmNode + +mapForeignTarget :: (CmmExpr -> CmmExpr) -> ForeignTarget -> ForeignTarget +mapForeignTarget exp (ForeignTarget e c) = ForeignTarget (exp e) c +mapForeignTarget _ m@(PrimTarget _) = m + +-- Take a transformer on expressions and apply it recursively. +wrapRecExp :: (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr +wrapRecExp f (CmmMachOp op es) = f (CmmMachOp op $ map (wrapRecExp f) es) +wrapRecExp f (CmmLoad addr ty) = f (CmmLoad (wrapRecExp f addr) ty) +wrapRecExp f e = f e + +mapExp :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x +mapExp _ f@(CmmEntry _) = f +mapExp _ m@(CmmComment _) = m +mapExp f (CmmAssign r e) = CmmAssign r (f e) +mapExp f (CmmStore addr e) = CmmStore (f addr) (f e) +mapExp f (CmmUnsafeForeignCall tgt fs as) = CmmUnsafeForeignCall (mapForeignTarget f tgt) fs (map f as) +mapExp _ l@(CmmBranch _) = l +mapExp f (CmmCondBranch e ti fi) = CmmCondBranch (f e) ti fi +mapExp f (CmmSwitch e tbl) = CmmSwitch (f e) tbl +mapExp f (CmmCall tgt mb_id o i s) = CmmCall (f tgt) mb_id o i s +mapExp f (CmmForeignCall tgt fs as succ updfr intrbl) = CmmForeignCall (mapForeignTarget f tgt) fs (map f as) succ updfr intrbl + +mapExpDeep :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x +mapExpDeep f = mapExp $ wrapRecExp f + +------------------------------------------------------------------------ +-- mapping Expr in CmmNode, but not performing allocation if no changes + +mapForeignTargetM :: (CmmExpr -> Maybe CmmExpr) -> ForeignTarget -> Maybe ForeignTarget +mapForeignTargetM f (ForeignTarget e c) = (\x -> ForeignTarget x c) `fmap` f e +mapForeignTargetM _ (PrimTarget _) = Nothing + +wrapRecExpM :: (CmmExpr -> Maybe CmmExpr) -> (CmmExpr -> Maybe CmmExpr) +wrapRecExpM f n@(CmmMachOp op es) = maybe (f n) (f . CmmMachOp op) (mapListM (wrapRecExpM f) es) +wrapRecExpM f n@(CmmLoad addr ty) = maybe (f n) (f . flip CmmLoad ty) (wrapRecExpM f addr) +wrapRecExpM f e = f e + +mapExpM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x) +mapExpM _ (CmmEntry _) = Nothing +mapExpM _ (CmmComment _) = Nothing +mapExpM f (CmmAssign r e) = CmmAssign r `fmap` f e +mapExpM f (CmmStore addr e) = (\[addr', e'] -> CmmStore addr' e') `fmap` mapListM f [addr, e] +mapExpM _ (CmmBranch _) = Nothing +mapExpM f (CmmCondBranch e ti fi) = (\x -> CmmCondBranch x ti fi) `fmap` f e +mapExpM f (CmmSwitch e tbl) = (\x -> CmmSwitch x tbl) `fmap` f e +mapExpM f (CmmCall tgt mb_id o i s) = (\x -> CmmCall x mb_id o i s) `fmap` f tgt +mapExpM f (CmmUnsafeForeignCall tgt fs as) + = case mapForeignTargetM f tgt of + Just tgt' -> Just (CmmUnsafeForeignCall tgt' fs (mapListJ f as)) + Nothing -> (\xs -> CmmUnsafeForeignCall tgt fs xs) `fmap` mapListM f as +mapExpM f (CmmForeignCall tgt fs as succ updfr intrbl) + = case mapForeignTargetM f tgt of + Just tgt' -> Just (CmmForeignCall tgt' fs (mapListJ f as) succ updfr intrbl) + Nothing -> (\xs -> CmmForeignCall tgt fs xs succ updfr intrbl) `fmap` mapListM f as + +-- share as much as possible +mapListM :: (a -> Maybe a) -> [a] -> Maybe [a] +mapListM f xs = let (b, r) = mapListT f xs + in if b then Just r else Nothing + +mapListJ :: (a -> Maybe a) -> [a] -> [a] +mapListJ f xs = snd (mapListT f xs) + +mapListT :: (a -> Maybe a) -> [a] -> (Bool, [a]) +mapListT f xs = foldr g (False, []) (zip3 (tails xs) xs (map f xs)) + where g (_, y, Nothing) (True, ys) = (True, y:ys) + g (_, _, Just y) (True, ys) = (True, y:ys) + g (ys', _, Nothing) (False, _) = (False, ys') + g (_, _, Just y) (False, ys) = (True, y:ys) + +mapExpDeepM :: (CmmExpr -> Maybe CmmExpr) -> CmmNode e x -> Maybe (CmmNode e x) +mapExpDeepM f = mapExpM $ wrapRecExpM f + +----------------------------------- +-- folding Expr in CmmNode + +foldExpForeignTarget :: (CmmExpr -> z -> z) -> ForeignTarget -> z -> z +foldExpForeignTarget exp (ForeignTarget e _) z = exp e z +foldExpForeignTarget _ (PrimTarget _) z = z + +-- Take a folder on expressions and apply it recursively. +wrapRecExpf :: (CmmExpr -> z -> z) -> CmmExpr -> z -> z +wrapRecExpf f e@(CmmMachOp _ es) z = foldr (wrapRecExpf f) (f e z) es +wrapRecExpf f e@(CmmLoad addr _) z = wrapRecExpf f addr (f e z) +wrapRecExpf f e z = f e z + +foldExp :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z +foldExp _ (CmmEntry {}) z = z +foldExp _ (CmmComment {}) z = z +foldExp f (CmmAssign _ e) z = f e z +foldExp f (CmmStore addr e) z = f addr $ f e z +foldExp f (CmmUnsafeForeignCall t _ as) z = foldr f (foldExpForeignTarget f t z) as +foldExp _ (CmmBranch _) z = z +foldExp f (CmmCondBranch e _ _) z = f e z +foldExp f (CmmSwitch e _) z = f e z +foldExp f (CmmCall {cml_target=tgt}) z = f tgt z +foldExp f (CmmForeignCall {tgt=tgt, args=args}) z = foldr f (foldExpForeignTarget f tgt z) args + +foldExpDeep :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z +foldExpDeep f = foldExp $ wrapRecExpf f diff -Nru ghc-7.0.3/compiler/cmm/cmm-notes ghc-7.2.1/compiler/cmm/cmm-notes --- ghc-7.0.3/compiler/cmm/cmm-notes 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/cmm/cmm-notes 2011-08-07 17:10:05.000000000 +0000 @@ -1,35 +1,126 @@ -Notes on new codegen (Sept 09) +More notes (June 11) +~~~~~~~~~~~~~~~~~~~~ +* Possible refactoring: Nuke AGraph in favour of + mkIfThenElse :: Expr -> Graph -> Graph -> FCode Graph + or even + mkIfThenElse :: HasUniques m => Expr -> Graph -> Graph -> m Graph + (Remmber that the .cmm file parser must use this function) + + or parameterise FCode over its envt; the CgState part seem useful for both + +* "Remove redundant reloads" in CmmSpillReload should be redundant; since + insertLateReloads is now gone, every reload is reloading a live variable. + Test and nuke. + +* Stack layout is very like register assignment: find non-conflicting assigments. + In particular we can use colouring or linear scan (etc). + + We'd fine-grain interference (on a word by word basis) to get maximum overlap. + But that may make very big interference graphs. So linear scan might be + more attactive. + + NB: linear scan does on-the-fly live range splitting. + +* When stubbing dead slots be careful not to write into an area that + overlaps with an area that's in use. So stubbing needs to *follow* + stack layout. + + +More notes (May 11) +~~~~~~~~~~~~~~~~~~~ +In CmmNode, consider spliting CmmCall into two: call and jump + +Notes on new codegen (Aug 10) ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Things to do: + - We insert spills for variables before the stack check! This is the reason for + some fishy code in StgCmmHeap.entryHeapCheck where we are doing some strange + things to fix up the stack pointer before GC calls/jumps. - - SDM (2010-02-26) can we remove the Foreign constructor from Convention? - Reason: we never generate code for a function with the Foreign - calling convention, and the code for calling foreign calls is generated + The reason spills are inserted before the sp check is that at the entry to a + function we always store the parameters passed in registers to local variables. + The spill pass simply inserts spills at variable definitions. We instead should + sink the spills so that we can avoid spilling them on branches that never + reload them. + + 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. + + EZY: I don't understand this comment. David Terei, can you clarify? - - All dataflow analyses are in the FuelMonad, even though they - are guarnteed to consume no fuel. This seems silly + - 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. - - CmmContFlowOpt.runCmmContFlowOptZs is not called! - - Why is runCmmOpts called from HscMain? Seems too "high up". - In fact HscMain calls (runCmmOpts cmmCfgOptsZ) which is what - runCmmContFlowOptZs does. Tidy up! + - 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 + convert a CmmInfoTable to [CmmStatic]. + - The MkGraph currenty uses a different semantics for <*> than Hoopl. Maybe + we could convert codeGen/StgCmm* clients to the Hoopl's semantics? + It's all deeply unsatisfactory. + + - 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) + is at http://fox.auryn.cz/msrc/0517_hoopl/32bit.oldghcoldgen.oldghchoopl.txt + - the code produced is 10.9% slower, the compilation is +118% slower! + + The same comparison with ghc-head with zip representation is at + http://fox.auryn.cz/msrc/0517_hoopl/32bit.oldghcoldgen.oldghczip.txt + - the code produced is 11.7% slower, the compilation is +78% slower. + + When compiling nofib, ghc-cmm + libraries compiled with -fnew-codegen + is 23.7% slower (http://fox.auryn.cz/msrc/0517_hoopl/32bit.oldghcoldgen.hooplghcoldgen.txt). + When compiling nofib, ghc-head + libraries compiled with -fnew-codegen + is 31.4% slower (http://fox.auryn.cz/msrc/0517_hoopl/32bit.oldghcoldgen.zipghcoldgen.txt). + + 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? + + In the CmmContFlowOpt.blockConcat, using Dataflow seems too clumsy. Still, + a block catenation function would be probably nicer than blockToNodeList + / blockOfNodeList combo. + + - 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 + also slow for CmmSwitch nodes O(block_nodes * switch_statements). + Maybe rewrite manifestSP to use Dataflow? + + - Sort out Label, LabelMap, LabelSet versus BlockId, BlockEnv, BlockSet + dichotomy. Mostly this means global replace, but we also need to make + Label an instance of Outputable (probably in the Outputable module). + + EZY: We should use Label, since that's the terminology Hoopl uses. + + - NB that CmmProcPoint line 283 has a hack that works around a GADT-related + bug in 6.10. + + - SDM (2010-02-26) can we remove the Foreign constructor from Convention? + Reason: we never generate code for a function with the Foreign + 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 elimiator (shortCutBranches); + - AsmCodeGen has post-native-cg branch eliminator (shortCutBranches); we ultimately want to share this with the Cmm branch eliminator. - At the moment, references to global registers like Hp are "lowered" - late (in AsmCodeGen.fixAssignTop and cmmToCmm). We should do this - early, in the new native codegen, much in the way that we lower - calling conventions. Might need to be a bit sophisticated about - aliasing. - - - Refactor Cmm so that it contains only shared stuff - Add a module MoribundCmm which contains stuff from - Cmm for old code gen path + late (in CgUtils.fixStgRegisters). We should do this early, in the + new native codegen, much in the way that we lower calling conventions. + Might need to be a bit sophisticated about aliasing. - Question: currently we lift procpoints to become separate CmmProcs. Do we still want to do this? @@ -58,22 +149,8 @@ - See "CAFs" below; we want to totally refactor the way SRTs are calculated - - Change - type CmmZ = GenCmm CmmStatic CmmInfo (CmmStackInfo, CmmGraph) - to - type CmmZ = GenCmm CmmStatic (CmmInfo, CmmStackInfo) CmmGraph - -- And perhaps take opportunity to prune CmmInfo? - - - Clarify which fields of CmmInfo are still used - - Maybe get rid of CmmFormals arg of CmmProc in all versions? - - - We aren't sure whether cmmToRawCmm is actively used by the new pipeline; check - And what does CmmBuildInfoTables do?! - - - Nuke CmmZipUtil, move zipPreds into ZipCfg - - 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 @@ -83,6 +160,9 @@ -- rET_SMALL etc ==> CmmInfo Check that there are no other imports from codeGen in cmm/ + - If you eliminate a label by branch chain elimination, + what happens if there's an Area associated with that label? + - Think about a non-flattened representation? - LastCall: @@ -105,7 +185,7 @@ http://hackage.haskell.org/trac/ghc/wiki/Commentary/Compiler/NewCodeGenPipeline - - We believe that all of CmmProcPointZ.addProcPointProtocols is dead. What + - We believe that all of CmmProcPoint.addProcPointProtocols is dead. What goes wrong if we simply never call it? - Something fishy in CmmStackLayout.hs @@ -150,75 +230,57 @@ move the whole splitting game into the C back end *only* (guided by the procpoint set) - ---------------------------------------------------- Modules in cmm/ ---------------------------------------------------- --------- Dead stuff ------------ -CmmProcPoint Dead: Michael Adams -CmmCPS Dead: Michael Adams -CmmCPSGen.hs Dead: Michael Adams -CmmBrokenBlock.hs Dead: Michael Adams -CmmLive.hs Dead: Michael Adams -CmmProcPoint.hs Dead: Michael Adams -Dataflow.hs Dead: Michael Adams -StackColor.hs Norman? -StackPlacements.hs Norman? - +-------- Testing stuff ------------ HscMain.optionallyConvertAndOrCPS testCmmConversion -DynFlags: -fconvert-to-zipper-and-back, -frun-cps, -frun-cpsz +DynFlags: -fconvert-to-zipper-and-back, -frun-cpsz -------- Moribund stuff ------------ +OldCmm.hs Definition of flowgraph of old representation +OldCmmUtil.hs Utilites that operates mostly on on CmmStmt +OldPprCmm.hs Pretty print for CmmStmt, GenBasicBlock and ListGraph CmmCvt.hs Conversion between old and new Cmm reps CmmOpt.hs Hopefully-redundant optimiser -CmmZipUtil.hs Only one function; move elsewhere -------- Stuff to keep ------------ -CmmCPSZ.hs Driver for new pipeline +CmmPipeline.hs Driver for new pipeline -CmmLiveZ.hs Liveness analysis, dead code elim -CmmProcPointZ.hs Identifying and splitting out proc-points +CmmLive.hs Liveness analysis, dead code elim +CmmProcPoint.hs Identifying and splitting out proc-points CmmSpillReload.hs Save and restore across calls -CmmCommonBlockElimZ.hs Common block elim +CmmCommonBlockElim.hs Common block elim CmmContFlowOpt.hs Other optimisations (branch-chain, merging) CmmBuildInfoTables.hs New info-table CmmStackLayout.hs and stack layout CmmCallConv.hs -CmmInfo.hs Defn of InfoTables, and conversion to exact layout +CmmInfo.hs Defn of InfoTables, and conversion to exact byte layout ---------- Cmm data types -------------- -ZipCfgCmmRep.hs Cmm instantiations of dataflow graph framework -MkZipCfgCmm.hs Cmm instantiations of dataflow graph framework +Cmm.hs Cmm instantiations of dataflow graph framework +MkGraph.hs Interface for building Cmm for codeGen/Stg*.hs modules + +CmmDecl.hs Shared Cmm types of both representations +CmmExpr.hs Type of Cmm expression +CmmType.hs Type of Cmm types and their widths +CmmMachOp.hs MachOp type and accompanying utilities -Cmm.hs Key module; a mix of old and new stuff - so needs tidying up in due course -CmmExpr.hs CmmUtils.hs CmmLint.hs PprC.hs Pretty print Cmm in C syntax -PprCmm.hs Pretty printer for Cmm -PprCmmZ.hs Additional stuff for zipper rep - -CLabel.hs CLabel - ----------- Dataflow modules -------------- - Goal: separate library; for now, separate directory - -MkZipCfg.hs -ZipCfg.hs -ZipCfgExtras.hs -ZipDataflow.hs -CmmTx.hs Transactions -OptimizationFuel.hs Fuel -BlockId.hs BlockId, BlockEnv, BlockSet -DFMonad.hs +PprCmm.hs Pretty printer for CmmGraph. +PprCmmDecl.hs Pretty printer for common Cmm types. +PprCmmExpr.hs Pretty printer for Cmm expressions. +CLabel.hs CLabel +BlockId.hs BlockId, BlockEnv, BlockSet ---------------------------------------------------- Top-level structure @@ -232,34 +294,34 @@ type RawCmm = GenCmm CmmStatic [CmmStatic] (ListGraph CmmStmt) * HscMain.tryNewCodeGen - - STG->Cmm: StgCmm.codeGen (new codegen) - - Optimise: CmmContFlowOpt (simple optimisations, very self contained) - - Cps convert: CmmCPSZ.protoCmmCPSZ - - Optimise: CmmContFlowOpt again - - Convert: CmmCvt.cmmOfZgraph (convert to old rep) very self contained + - STG->Cmm: StgCmm.codeGen (new codegen) + - Optimize and CPS: CmmPipeline.cmmPipeline + - Convert: CmmCvt.cmmOfZgraph (convert to old rep) very self contained * StgCmm.hs The new STG -> Cmm conversion code generator Lots of modules StgCmmXXX ---------------------------------------------------- - CmmCPSZ.protoCmmCPSZ The new pipeline + CmmPipeline.cmmPipeline The new pipeline ---------------------------------------------------- -CmmCPSZprotoCmmCPSZ: - 1. Do cpsTop for each procedures separately - 2. Build SRT representation; this spans multiple procedures - (unless split-objs) +CmmPipeline.cmmPipeline: + 1. Do control flow optimization + 2. Do cpsTop for each procedures separately + 3. Build SRT representation; this spans multiple procedures + (unless split-objs) + 4. Do control flow optimization on all resulting procedures cpsTop: - * CmmCommonBlockElimZ.elimCommonBlocks: + * CmmCommonBlockElim.elimCommonBlocks: eliminate common blocks - * CmmProcPointZ.minimalProcPointSet + * CmmProcPoint.minimalProcPointSet identify proc-points no change to graph - * CmmProcPointZ.addProcPointProtocols + * CmmProcPoint.addProcPointProtocols something to do with the MA optimisation probably entirely unnecessary @@ -268,8 +330,8 @@ 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 @@ -289,11 +351,11 @@ Manifest the stack pointer * Split into separate procedures - - CmmProcPointZ.procPointAnalysis + - CmmProcPoint.procPointAnalysis Given set of proc points, which blocks are reachable from each Claim: too few proc-points => code duplication, but program still works?? - - CmmProcPointZ.splitAtProcPoints + - CmmProcPoint.splitAtProcPoints Using this info, split into separate procedures - CmmBuildInfoTables.setInfoTableStackMap @@ -319,7 +381,7 @@ 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 @@ -334,7 +396,7 @@ Figuring out proc-points ~~~~~~~~~~~~~~~~~~~~~~~~ Proc-points are identified by -CmmProcPointZ.minimalProcPointSet/extendPPSet Although there isn't +CmmProcPoint.minimalProcPointSet/extendPPSet Although there isn't that much code, JD thinks that it could be done much more nicely using a dominator analysis, using the Dataflow Engine. @@ -387,7 +449,7 @@ f's keep-alive refs to include h1. * The SRT info is the C_SRT field of Cmm.ClosureTypeInfo in a - CmmInfoTable attached to each CmmProc. CmmCPSZ.toTops actually does + CmmInfoTable attached to each CmmProc. CmmPipeline.toTops actually does the attaching, right at the end of the pipeline. The C_SRT part gives offsets within a single, shared table of closure pointers. @@ -398,7 +460,7 @@ Foreign calls ---------------------------------------------------- -See Note [Foreign calls] in ZipCfgCmmRep! This explains that a safe +See Note [Foreign calls] in CmmNode! This explains that a safe foreign call must do this: save thread state push info table (on thread stack) to describe frame @@ -433,7 +495,7 @@ Cmm representations ---------------------------------------------------- -* Cmm.hs +* CmmDecl.hs The type [GenCmm d h g] represents a whole module, ** one list element per .o file ** Without SplitObjs, the list has exactly one element @@ -448,7 +510,7 @@ ------------- -OLD BACK END representations (Cmm.hs): +OLD BACK END representations (OldCmm.hs): type Cmm = GenCmm CmmStatic CmmInfo (ListGraph CmmStmt) -- A whole module newtype ListGraph i = ListGraph [GenBasicBlock i] @@ -463,49 +525,47 @@ ------------- NEW BACK END representations -* Not Cmm-specific at all - ZipCfg.hs defines Graph, LGraph, FGraph, - ZHead, ZTail, ZBlock ... - - classes LastNode, HavingSuccessors - - MkZipCfg.hs: AGraph: building graphs - -* ZipCfgCmmRep: instantiates ZipCfg for Cmm - data Middle = ...CmmExpr... - data Last = ...CmmExpr... - type CmmGraph = Graph Middle Last - - type CmmZ = GenCmm CmmStatic CmmInfo (CmmStackInfo, CmmGraph) - type CmmStackInfo = (ByteOff, Maybe ByteOff) - -- (SP offset on entry, update frame space = SP offset on exit) - -- The new codegen produces CmmZ, but once the stack is - -- manifested we can drop that in favour of - -- GenCmm CmmStatic CmmInfo CmmGraph - - Inside a CmmProc: - - CLabel: used - - CmmInfo: partly used by NEW - - CmmFormals: not used at all PERHAPS NOT EVEN BY OLD PIPELINE! - -* MkZipCfgCmm.hs: smart constructors for ZipCfgCmmRep - Depends on (a) MkZipCfg (Cmm-independent) - (b) ZipCfgCmmRep (Cmm-specific) +* Uses Hoopl library, a zero-boot package +* CmmNode defines a node of a flow graph. +* Cmm defines CmmGraph, CmmTop, Cmm + - CmmGraph is a closed/closed graph + an entry node. -------------- -* SHARED stuff - CmmExpr.hs defines the Cmm expression types - - CmmExpr, CmmReg, Width, CmmLit, LocalReg, GlobalReg - - CmmType, Width etc (saparate module?) - - MachOp (separate module?) - - Area, AreaId etc (separate module?) + data CmmGraph = CmmGraph { g_entry :: BlockId + , g_graph :: Graph CmmNode C C } - BlockId.hs defines BlockId, BlockEnv, BlockSet + - CmmTop is a top level chunk, specialization of GenCmmTop from CmmDecl.hs + with CmmGraph as a flow graph. + - Cmm is a collection of CmmTops. -------------- + type Cmm = GenCmm CmmStatic CmmTopInfo CmmGraph + type CmmTop = GenCmmTop CmmStatic CmmTopInfo CmmGraph + + - CmmTop uses CmmTopInfo, which is a CmmInfoTable and CmmStackInfo + + data CmmTopInfo = TopInfo {info_tbl :: CmmInfoTable, stack_info :: CmmStackInfo} + + - CmmStackInfo + + data CmmStackInfo = StackInfo {arg_space :: ByteOff, updfr_space :: Maybe ByteOff} + * arg_space = SP offset on entry + * updfr_space space = SP offset on exit + Once the staci is manifested, we could drom CmmStackInfo, ie. get + GenCmm CmmStatic CmmInfoTable CmmGraph, but we do not do that currently. + +* MkGraph.hs: smart constructors for Cmm.hs + Beware, the CmmAGraph defined here does not use AGraph from Hoopl, + as CmmAGraph can be opened or closed at exit, See the notes in that module. + +------------- +* SHARED stuff + CmmDecl.hs - GenCmm and GenCmmTop types + CmmExpr.hs - defines the Cmm expression types + - CmmExpr, CmmReg, CmmLit, LocalReg, GlobalReg + - Area, AreaId etc (separate module?) + CmmType.hs - CmmType, Width etc (saparate module?) + CmmMachOp.hs - MachOp and CallishMachOp types + + BlockId.hs defines BlockId, BlockEnv, BlockSet ------------- -* Transactions indicate whether or not the result changes: CmmTx - type Tx a = a -> TxRes a - data TxRes a = TxRes ChangeFlag a diff -Nru ghc-7.0.3/compiler/cmm/CmmOpt.hs ghc-7.2.1/compiler/cmm/CmmOpt.hs --- ghc-7.0.3/compiler/cmm/CmmOpt.hs 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/cmm/CmmOpt.hs 2011-08-07 17:10:05.000000000 +0000 @@ -14,15 +14,17 @@ ----------------------------------------------------------------------------- module CmmOpt ( - cmmMiniInline, - cmmMachOpFold, - cmmLoopifyForC, + cmmEliminateDeadBlocks, + cmmMiniInline, + cmmMachOpFold, + cmmMachOpFoldM, + cmmLoopifyForC, ) where #include "HsVersions.h" -import Cmm -import CmmExpr +import OldCmm +import CmmNode (wrapRecExp) import CmmUtils import CLabel import StaticFlags @@ -31,20 +33,81 @@ import Unique import FastTypes import Outputable +import BlockId import Data.Bits import Data.Word import Data.Int +import Data.Maybe +import Data.List + +import Compiler.Hoopl hiding (Unique) + +-- ----------------------------------------------------------------------------- +-- Eliminates dead blocks + +{- +We repeatedly expand the set of reachable blocks until we hit a +fixpoint, and then prune any blocks that were not in this set. This is +actually a required optimization, as dead blocks can cause problems +for invariants in the linear register allocator (and possibly other +places.) +-} + +-- Deep fold over statements could probably be abstracted out, but it +-- might not be worth the effort since OldCmm is moribund +cmmEliminateDeadBlocks :: [CmmBasicBlock] -> [CmmBasicBlock] +cmmEliminateDeadBlocks [] = [] +cmmEliminateDeadBlocks blocks@(BasicBlock base_id _:_) = + let -- Calculate what's reachable from what block + reachableMap = foldl' f emptyUFM blocks -- lazy in values + where f m (BasicBlock block_id stmts) = addToUFM m block_id (reachableFrom stmts) + reachableFrom stmts = foldl stmt [] stmts + where + stmt m CmmNop = m + stmt m (CmmComment _) = m + stmt m (CmmAssign _ e) = expr m e + stmt m (CmmStore e1 e2) = expr (expr m e1) e2 + stmt m (CmmCall c _ as _ _) = f (actuals m as) c + where f m (CmmCallee e _) = expr m e + f m (CmmPrim _) = m + stmt m (CmmBranch b) = b:m + stmt m (CmmCondBranch e b) = b:(expr m e) + stmt m (CmmSwitch e bs) = catMaybes bs ++ expr m e + stmt m (CmmJump e as) = expr (actuals m as) e + stmt m (CmmReturn as) = actuals m as + actuals m as = foldl' (\m h -> expr m (hintlessCmm h)) m as + -- We have to do a deep fold into CmmExpr because + -- there may be a BlockId in the CmmBlock literal. + expr m (CmmLit l) = lit m l + expr m (CmmLoad e _) = expr m e + expr m (CmmReg _) = m + expr m (CmmMachOp _ es) = foldl' expr m es + expr m (CmmStackSlot _ _) = m + expr m (CmmRegOff _ _) = m + lit m (CmmBlock b) = b:m + lit m _ = m + -- go todo done + reachable = go [base_id] (setEmpty :: BlockSet) + where go [] m = m + go (x:xs) m + | setMember x m = go xs m + | otherwise = go (add ++ xs) (setInsert x m) + where add = fromMaybe (panic "cmmEliminateDeadBlocks: unknown block") + (lookupUFM reachableMap x) + in filter (\(BasicBlock block_id _) -> setMember block_id reachable) blocks -- ----------------------------------------------------------------------------- -- The mini-inliner {- -This pass inlines assignments to temporaries that are used just -once. It works as follows: +This pass inlines assignments to temporaries. Temporaries that are +only used once are unconditionally inlined. Temporaries that are used +two or more times are only inlined if they are assigned a literal. It +works as follows: - count uses of each temporary - - for each temporary that occurs just once: + - for each temporary: - attempt to push it forward to the statement that uses it - only push forward past assignments to other temporaries (assumes that temporaries are single-assignment) @@ -100,11 +163,36 @@ cmmMiniInlineStmts :: UniqFM Int -> [CmmStmt] -> [CmmStmt] cmmMiniInlineStmts uses [] = [] cmmMiniInlineStmts uses (stmt@(CmmAssign (CmmLocal (LocalReg u _)) expr) : stmts) - -- not used at all: just discard this assignment + -- not used: just discard this assignment | Nothing <- lookupUFM uses u = cmmMiniInlineStmts uses stmts - -- used once: try to inline at the use site + -- used (literal): try to inline at all the use sites + | Just n <- lookupUFM uses u, isLit expr + = +#ifdef NCG_DEBUG + trace ("nativeGen: inlining " ++ showSDoc (pprStmt stmt)) $ +#endif + case lookForInlineLit u expr stmts of + (m, stmts') + | n == m -> cmmMiniInlineStmts (delFromUFM uses u) stmts' + | otherwise -> + stmt : cmmMiniInlineStmts (adjustUFM (\x -> x - m) uses u) stmts' + + -- used (foldable to literal): try to inline at all the use sites + | Just n <- lookupUFM uses u, + e@(CmmLit _) <- wrapRecExp foldExp expr + = +#ifdef NCG_DEBUG + trace ("nativeGen: inlining " ++ showSDoc (pprStmt stmt)) $ +#endif + case lookForInlineLit u e stmts of + (m, stmts') + | n == m -> cmmMiniInlineStmts (delFromUFM uses u) stmts' + | otherwise -> + stmt : cmmMiniInlineStmts (adjustUFM (\x -> x - m) uses u) stmts' + + -- used once (non-literal): try to inline at the use site | Just 1 <- lookupUFM uses u, Just stmts' <- lookForInline u expr stmts = @@ -112,16 +200,47 @@ trace ("nativeGen: inlining " ++ showSDoc (pprStmt stmt)) $ #endif cmmMiniInlineStmts uses stmts' + where + foldExp (CmmMachOp op args) = cmmMachOpFold op args + foldExp e = e cmmMiniInlineStmts uses (stmt:stmts) = stmt : cmmMiniInlineStmts uses stmts -lookForInline u expr (stmt : rest) +-- | Takes a register, a 'CmmLit' expression assigned to that +-- register, and a list of statements. Inlines the expression at all +-- use sites of the register. Returns the number of substituations +-- made and the, possibly modified, list of statements. +lookForInlineLit :: Unique -> CmmExpr -> [CmmStmt] -> (Int, [CmmStmt]) +lookForInlineLit _ _ [] = (0, []) +lookForInlineLit u expr stmts@(stmt : rest) + | Just n <- lookupUFM (countUses stmt) u + = case lookForInlineLit u expr rest of + (m, stmts) -> let z = n + m + in z `seq` (z, inlineStmt u expr stmt : stmts) + + | ok_to_skip + = case lookForInlineLit u expr rest of + (n, stmts) -> (n, stmt : stmts) + + | otherwise + = (0, stmts) + where + -- We skip over assignments to registers, unless the register + -- being assigned to is the one we're inlining. + ok_to_skip = case stmt of + CmmAssign (CmmLocal r@(LocalReg u' _)) _ | u' == u -> False + _other -> True + +lookForInline u expr stmts = lookForInline' u expr regset stmts + where regset = foldRegsUsed extendRegSet emptyRegSet expr + +lookForInline' u expr regset (stmt : rest) | Just 1 <- lookupUFM (countUses stmt) u, ok_to_inline = Just (inlineStmt u expr stmt : rest) | ok_to_skip - = case lookForInline u expr rest of + = case lookForInline' u expr regset rest of Nothing -> Nothing Just stmts -> Just (stmt:stmts) @@ -138,12 +257,18 @@ CmmCall{} -> hasNoGlobalRegs expr _ -> True - -- We can skip over assignments to other tempoararies, because we - -- know that expressions aren't side-effecting and temporaries are - -- single-assignment. + -- Expressions aren't side-effecting. Temporaries may or may not + -- be single-assignment depending on the source (the old code + -- generator creates single-assignment code, but hand-written Cmm + -- and Cmm from the new code generator is not single-assignment.) + -- So we do an extra check to make sure that the register being + -- changed is not one we were relying on. I don't know how much of a + -- performance hit this is (we have to create a regset for every + -- instruction.) -- EZY ok_to_skip = case stmt of CmmNop -> True - CmmAssign (CmmLocal (LocalReg u' _)) rhs | u' /= u -> True + CmmComment{} -> True + CmmAssign (CmmLocal r@(LocalReg u' _)) rhs | u' /= u && not (r `elemRegSet` regset) -> True CmmAssign g@(CmmGlobal _) rhs -> not (g `regUsedIn` expr) _other -> False @@ -181,114 +306,123 @@ -- been optimized and folded. cmmMachOpFold - :: MachOp -- The operation from an CmmMachOp - -> [CmmExpr] -- The optimized arguments + :: MachOp -- The operation from an CmmMachOp + -> [CmmExpr] -- The optimized arguments -> CmmExpr -cmmMachOpFold op arg@[CmmLit (CmmInt x rep)] - = case op of +cmmMachOpFold op args = fromMaybe (CmmMachOp op args) (cmmMachOpFoldM op args) + +-- Returns Nothing if no changes, useful for Hoopl, also reduces +-- allocation! +cmmMachOpFoldM + :: MachOp + -> [CmmExpr] + -> Maybe CmmExpr + +cmmMachOpFoldM op arg@[CmmLit (CmmInt x rep)] + = Just $ case op of MO_S_Neg r -> CmmLit (CmmInt (-x) rep) MO_Not r -> CmmLit (CmmInt (complement x) rep) - -- these are interesting: we must first narrow to the - -- "from" type, in order to truncate to the correct size. - -- The final narrow/widen to the destination type - -- is implicit in the CmmLit. + -- these are interesting: we must first narrow to the + -- "from" type, in order to truncate to the correct size. + -- The final narrow/widen to the destination type + -- is implicit in the CmmLit. MO_SF_Conv from to -> CmmLit (CmmFloat (fromInteger x) to) MO_SS_Conv from to -> CmmLit (CmmInt (narrowS from x) to) MO_UU_Conv from to -> CmmLit (CmmInt (narrowU from x) to) - _ -> panic "cmmMachOpFold: unknown unary op" + _ -> panic "cmmMachOpFoldM: unknown unary op" -- Eliminate conversion NOPs -cmmMachOpFold (MO_SS_Conv rep1 rep2) [x] | rep1 == rep2 = x -cmmMachOpFold (MO_UU_Conv rep1 rep2) [x] | rep1 == rep2 = x +cmmMachOpFoldM (MO_SS_Conv rep1 rep2) [x] | rep1 == rep2 = Just x +cmmMachOpFoldM (MO_UU_Conv rep1 rep2) [x] | rep1 == rep2 = Just x -- Eliminate nested conversions where possible -cmmMachOpFold conv_outer args@[CmmMachOp conv_inner [x]] +cmmMachOpFoldM conv_outer args@[CmmMachOp conv_inner [x]] | Just (rep1,rep2,signed1) <- isIntConversion conv_inner, Just (_, rep3,signed2) <- isIntConversion conv_outer = case () of - -- widen then narrow to the same size is a nop - _ | rep1 < rep2 && rep1 == rep3 -> x - -- Widen then narrow to different size: collapse to single conversion - -- but remember to use the signedness from the widening, just in case - -- the final conversion is a widen. - | rep1 < rep2 && rep2 > rep3 -> - cmmMachOpFold (intconv signed1 rep1 rep3) [x] - -- Nested widenings: collapse if the signedness is the same - | rep1 < rep2 && rep2 < rep3 && signed1 == signed2 -> - cmmMachOpFold (intconv signed1 rep1 rep3) [x] - -- Nested narrowings: collapse - | rep1 > rep2 && rep2 > rep3 -> - cmmMachOpFold (MO_UU_Conv rep1 rep3) [x] - | otherwise -> - CmmMachOp conv_outer args + -- widen then narrow to the same size is a nop + _ | rep1 < rep2 && rep1 == rep3 -> Just x + -- Widen then narrow to different size: collapse to single conversion + -- but remember to use the signedness from the widening, just in case + -- the final conversion is a widen. + | rep1 < rep2 && rep2 > rep3 -> + Just $ cmmMachOpFold (intconv signed1 rep1 rep3) [x] + -- Nested widenings: collapse if the signedness is the same + | rep1 < rep2 && rep2 < rep3 && signed1 == signed2 -> + Just $ cmmMachOpFold (intconv signed1 rep1 rep3) [x] + -- Nested narrowings: collapse + | rep1 > rep2 && rep2 > rep3 -> + Just $ cmmMachOpFold (MO_UU_Conv rep1 rep3) [x] + | otherwise -> + Nothing where - isIntConversion (MO_UU_Conv rep1 rep2) - = Just (rep1,rep2,False) - isIntConversion (MO_SS_Conv rep1 rep2) - = Just (rep1,rep2,True) - isIntConversion _ = Nothing + isIntConversion (MO_UU_Conv rep1 rep2) + = Just (rep1,rep2,False) + isIntConversion (MO_SS_Conv rep1 rep2) + = Just (rep1,rep2,True) + isIntConversion _ = Nothing - intconv True = MO_SS_Conv - intconv False = MO_UU_Conv + intconv True = MO_SS_Conv + intconv False = MO_UU_Conv -- ToDo: a narrow of a load can be collapsed into a narrow load, right? -- but what if the architecture only supports word-sized loads, should -- we do the transformation anyway? -cmmMachOpFold mop args@[CmmLit (CmmInt x xrep), CmmLit (CmmInt y _)] +cmmMachOpFoldM mop args@[CmmLit (CmmInt x xrep), CmmLit (CmmInt y _)] = case mop of - -- for comparisons: don't forget to narrow the arguments before - -- comparing, since they might be out of range. - MO_Eq r -> CmmLit (CmmInt (if x_u == y_u then 1 else 0) wordWidth) - MO_Ne r -> CmmLit (CmmInt (if x_u /= y_u then 1 else 0) wordWidth) - - MO_U_Gt r -> CmmLit (CmmInt (if x_u > y_u then 1 else 0) wordWidth) - MO_U_Ge r -> CmmLit (CmmInt (if x_u >= y_u then 1 else 0) wordWidth) - MO_U_Lt r -> CmmLit (CmmInt (if x_u < y_u then 1 else 0) wordWidth) - MO_U_Le r -> CmmLit (CmmInt (if x_u <= y_u then 1 else 0) wordWidth) - - MO_S_Gt r -> CmmLit (CmmInt (if x_s > y_s then 1 else 0) wordWidth) - MO_S_Ge r -> CmmLit (CmmInt (if x_s >= y_s then 1 else 0) wordWidth) - MO_S_Lt r -> CmmLit (CmmInt (if x_s < y_s then 1 else 0) wordWidth) - MO_S_Le r -> CmmLit (CmmInt (if x_s <= y_s then 1 else 0) wordWidth) - - MO_Add r -> CmmLit (CmmInt (x + y) r) - MO_Sub r -> CmmLit (CmmInt (x - y) r) - MO_Mul r -> CmmLit (CmmInt (x * y) r) - MO_U_Quot r | y /= 0 -> CmmLit (CmmInt (x_u `quot` y_u) r) - MO_U_Rem r | y /= 0 -> CmmLit (CmmInt (x_u `rem` y_u) r) - MO_S_Quot r | y /= 0 -> CmmLit (CmmInt (x `quot` y) r) - MO_S_Rem r | y /= 0 -> CmmLit (CmmInt (x `rem` y) r) - - MO_And r -> CmmLit (CmmInt (x .&. y) r) - MO_Or r -> CmmLit (CmmInt (x .|. y) r) - MO_Xor r -> CmmLit (CmmInt (x `xor` y) r) - - MO_Shl r -> CmmLit (CmmInt (x `shiftL` fromIntegral y) r) - MO_U_Shr r -> CmmLit (CmmInt (x_u `shiftR` fromIntegral y) r) - MO_S_Shr r -> CmmLit (CmmInt (x `shiftR` fromIntegral y) r) + -- for comparisons: don't forget to narrow the arguments before + -- comparing, since they might be out of range. + MO_Eq r -> Just $ CmmLit (CmmInt (if x_u == y_u then 1 else 0) wordWidth) + MO_Ne r -> Just $ CmmLit (CmmInt (if x_u /= y_u then 1 else 0) wordWidth) + + MO_U_Gt r -> Just $ CmmLit (CmmInt (if x_u > y_u then 1 else 0) wordWidth) + MO_U_Ge r -> Just $ CmmLit (CmmInt (if x_u >= y_u then 1 else 0) wordWidth) + MO_U_Lt r -> Just $ CmmLit (CmmInt (if x_u < y_u then 1 else 0) wordWidth) + MO_U_Le r -> Just $ CmmLit (CmmInt (if x_u <= y_u then 1 else 0) wordWidth) + + MO_S_Gt r -> Just $ CmmLit (CmmInt (if x_s > y_s then 1 else 0) wordWidth) + MO_S_Ge r -> Just $ CmmLit (CmmInt (if x_s >= y_s then 1 else 0) wordWidth) + MO_S_Lt r -> Just $ CmmLit (CmmInt (if x_s < y_s then 1 else 0) wordWidth) + MO_S_Le r -> Just $ CmmLit (CmmInt (if x_s <= y_s then 1 else 0) wordWidth) + + MO_Add r -> Just $ CmmLit (CmmInt (x + y) r) + MO_Sub r -> Just $ CmmLit (CmmInt (x - y) r) + MO_Mul r -> Just $ CmmLit (CmmInt (x * y) r) + MO_U_Quot r | y /= 0 -> Just $ CmmLit (CmmInt (x_u `quot` y_u) r) + MO_U_Rem r | y /= 0 -> Just $ CmmLit (CmmInt (x_u `rem` y_u) r) + MO_S_Quot r | y /= 0 -> Just $ CmmLit (CmmInt (x `quot` y) r) + MO_S_Rem r | y /= 0 -> Just $ CmmLit (CmmInt (x `rem` y) r) + + MO_And r -> Just $ CmmLit (CmmInt (x .&. y) r) + MO_Or r -> Just $ CmmLit (CmmInt (x .|. y) r) + MO_Xor r -> Just $ CmmLit (CmmInt (x `xor` y) r) + + MO_Shl r -> Just $ CmmLit (CmmInt (x `shiftL` fromIntegral y) r) + MO_U_Shr r -> Just $ CmmLit (CmmInt (x_u `shiftR` fromIntegral y) r) + MO_S_Shr r -> Just $ CmmLit (CmmInt (x `shiftR` fromIntegral y) r) - other -> CmmMachOp mop args + other -> Nothing where - x_u = narrowU xrep x - y_u = narrowU xrep y - x_s = narrowS xrep x - y_s = narrowS xrep y - + x_u = narrowU xrep x + y_u = narrowU xrep y + x_s = narrowS xrep x + y_s = narrowS xrep y + -- When possible, shift the constants to the right-hand side, so that we -- can match for strength reductions. Note that the code generator will -- also assume that constants have been shifted to the right when -- possible. -cmmMachOpFold op [x@(CmmLit _), y] - | not (isLit y) && isCommutableMachOp op - = cmmMachOpFold op [y, x] +cmmMachOpFoldM op [x@(CmmLit _), y] + | not (isLit y) && isCommutableMachOp op + = Just (cmmMachOpFold op [y, x]) -- Turn (a+b)+c into a+(b+c) where possible. Because literals are -- moved to the right, it is more likely that we will find @@ -306,29 +440,38 @@ -- Also don't do it if arg1 is PicBaseReg, so that we don't separate the -- PicBaseReg from the corresponding label (or label difference). -- -cmmMachOpFold mop1 [CmmMachOp mop2 [arg1,arg2], arg3] - | mop1 == mop2 && isAssociativeMachOp mop1 +cmmMachOpFoldM mop1 [CmmMachOp mop2 [arg1,arg2], arg3] + | mop2 `associates_with` mop1 && not (isLit arg1) && not (isPicReg arg1) - = cmmMachOpFold mop1 [arg1, cmmMachOpFold mop2 [arg2,arg3]] + = Just (cmmMachOpFold mop2 [arg1, cmmMachOpFold mop1 [arg2,arg3]]) + where + MO_Add{} `associates_with` MO_Sub{} = True + mop1 `associates_with` mop2 = + mop1 == mop2 && isAssociativeMachOp mop1 + +-- special case: (a - b) + c ==> a + (c - b) +cmmMachOpFoldM mop1@(MO_Add{}) [CmmMachOp mop2@(MO_Sub{}) [arg1,arg2], arg3] + | not (isLit arg1) && not (isPicReg arg1) + = Just (cmmMachOpFold mop1 [arg1, cmmMachOpFold mop2 [arg3,arg2]]) -- Make a RegOff if we can -cmmMachOpFold (MO_Add _) [CmmReg reg, CmmLit (CmmInt n rep)] - = CmmRegOff reg (fromIntegral (narrowS rep n)) -cmmMachOpFold (MO_Add _) [CmmRegOff reg off, CmmLit (CmmInt n rep)] - = CmmRegOff reg (off + fromIntegral (narrowS rep n)) -cmmMachOpFold (MO_Sub _) [CmmReg reg, CmmLit (CmmInt n rep)] - = CmmRegOff reg (- fromIntegral (narrowS rep n)) -cmmMachOpFold (MO_Sub _) [CmmRegOff reg off, CmmLit (CmmInt n rep)] - = CmmRegOff reg (off - fromIntegral (narrowS rep n)) +cmmMachOpFoldM (MO_Add _) [CmmReg reg, CmmLit (CmmInt n rep)] + = Just $ CmmRegOff reg (fromIntegral (narrowS rep n)) +cmmMachOpFoldM (MO_Add _) [CmmRegOff reg off, CmmLit (CmmInt n rep)] + = Just $ CmmRegOff reg (off + fromIntegral (narrowS rep n)) +cmmMachOpFoldM (MO_Sub _) [CmmReg reg, CmmLit (CmmInt n rep)] + = Just $ CmmRegOff reg (- fromIntegral (narrowS rep n)) +cmmMachOpFoldM (MO_Sub _) [CmmRegOff reg off, CmmLit (CmmInt n rep)] + = Just $ CmmRegOff reg (off - fromIntegral (narrowS rep n)) -- Fold label(+/-)offset into a CmmLit where possible -cmmMachOpFold (MO_Add _) [CmmLit (CmmLabel lbl), CmmLit (CmmInt i rep)] - = CmmLit (CmmLabelOff lbl (fromIntegral (narrowU rep i))) -cmmMachOpFold (MO_Add _) [CmmLit (CmmInt i rep), CmmLit (CmmLabel lbl)] - = CmmLit (CmmLabelOff lbl (fromIntegral (narrowU rep i))) -cmmMachOpFold (MO_Sub _) [CmmLit (CmmLabel lbl), CmmLit (CmmInt i rep)] - = CmmLit (CmmLabelOff lbl (fromIntegral (negate (narrowU rep i)))) +cmmMachOpFoldM (MO_Add _) [CmmLit (CmmLabel lbl), CmmLit (CmmInt i rep)] + = Just $ CmmLit (CmmLabelOff lbl (fromIntegral (narrowU rep i))) +cmmMachOpFoldM (MO_Add _) [CmmLit (CmmInt i rep), CmmLit (CmmLabel lbl)] + = Just $ CmmLit (CmmLabelOff lbl (fromIntegral (narrowU rep i))) +cmmMachOpFoldM (MO_Sub _) [CmmLit (CmmLabel lbl), CmmLit (CmmInt i rep)] + = Just $ CmmLit (CmmLabelOff lbl (fromIntegral (negate (narrowU rep i)))) -- Comparison of literal with widened operand: perform the comparison @@ -341,7 +484,7 @@ #if i386_TARGET_ARCH || x86_64_TARGET_ARCH -- powerPC NCG has a TODO for I8/I16 comparisons, so don't try -cmmMachOpFold cmp [CmmMachOp conv [x], CmmLit (CmmInt i _)] +cmmMachOpFoldM cmp [CmmMachOp conv [x], CmmLit (CmmInt i _)] | -- if the operand is widened: Just (rep, signed, narrow_fn) <- maybe_conversion conv, -- and this is a comparison operation: @@ -349,7 +492,7 @@ -- and the literal fits in the smaller size: i == narrow_fn rep i -- then we can do the comparison at the smaller size - = cmmMachOpFold narrow_cmp [x, CmmLit (CmmInt i rep)] + = Just (cmmMachOpFold narrow_cmp [x, CmmLit (CmmInt i rep)]) where maybe_conversion (MO_UU_Conv from to) | to > from @@ -361,7 +504,7 @@ -- don't attempt to apply this optimisation when the source -- is a float; see #1916 maybe_conversion _ = Nothing - + -- careful (#2080): if the original comparison was signed, but -- we were doing an unsigned widen, then we must do an -- unsigned comparison at the smaller size. @@ -384,94 +527,92 @@ -- We can often do something with constants of 0 and 1 ... -cmmMachOpFold mop args@[x, y@(CmmLit (CmmInt 0 _))] +cmmMachOpFoldM mop args@[x, y@(CmmLit (CmmInt 0 _))] = case mop of - MO_Add r -> x - MO_Sub r -> x - MO_Mul r -> y - MO_And r -> y - MO_Or r -> x - MO_Xor r -> x - MO_Shl r -> x - MO_S_Shr r -> x - MO_U_Shr r -> x - MO_Ne r | isComparisonExpr x -> x - MO_Eq r | Just x' <- maybeInvertCmmExpr x -> x' - MO_U_Gt r | isComparisonExpr x -> x - MO_S_Gt r | isComparisonExpr x -> x - MO_U_Lt r | isComparisonExpr x -> CmmLit (CmmInt 0 wordWidth) - MO_S_Lt r | isComparisonExpr x -> CmmLit (CmmInt 0 wordWidth) - MO_U_Ge r | isComparisonExpr x -> CmmLit (CmmInt 1 wordWidth) - MO_S_Ge r | isComparisonExpr x -> CmmLit (CmmInt 1 wordWidth) - MO_U_Le r | Just x' <- maybeInvertCmmExpr x -> x' - MO_S_Le r | Just x' <- maybeInvertCmmExpr x -> x' - other -> CmmMachOp mop args + MO_Add r -> Just x + MO_Sub r -> Just x + MO_Mul r -> Just y + MO_And r -> Just y + MO_Or r -> Just x + MO_Xor r -> Just x + MO_Shl r -> Just x + MO_S_Shr r -> Just x + MO_U_Shr r -> Just x + MO_Ne r | isComparisonExpr x -> Just x + MO_Eq r | Just x' <- maybeInvertCmmExpr x -> Just x' + MO_U_Gt r | isComparisonExpr x -> Just x + MO_S_Gt r | isComparisonExpr x -> Just x + MO_U_Lt r | isComparisonExpr x -> Just $ CmmLit (CmmInt 0 wordWidth) + MO_S_Lt r | isComparisonExpr x -> Just $ CmmLit (CmmInt 0 wordWidth) + MO_U_Ge r | isComparisonExpr x -> Just $ CmmLit (CmmInt 1 wordWidth) + MO_S_Ge r | isComparisonExpr x -> Just $ CmmLit (CmmInt 1 wordWidth) + MO_U_Le r | Just x' <- maybeInvertCmmExpr x -> Just x' + MO_S_Le r | Just x' <- maybeInvertCmmExpr x -> Just x' + other -> Nothing -cmmMachOpFold mop args@[x, y@(CmmLit (CmmInt 1 rep))] +cmmMachOpFoldM mop args@[x, y@(CmmLit (CmmInt 1 rep))] = case mop of - MO_Mul r -> x - MO_S_Quot r -> x - MO_U_Quot r -> x - MO_S_Rem r -> CmmLit (CmmInt 0 rep) - MO_U_Rem r -> CmmLit (CmmInt 0 rep) - MO_Ne r | Just x' <- maybeInvertCmmExpr x -> x' - MO_Eq r | isComparisonExpr x -> x - MO_U_Lt r | Just x' <- maybeInvertCmmExpr x -> x' - MO_S_Lt r | Just x' <- maybeInvertCmmExpr x -> x' - MO_U_Gt r | isComparisonExpr x -> CmmLit (CmmInt 0 wordWidth) - MO_S_Gt r | isComparisonExpr x -> CmmLit (CmmInt 0 wordWidth) - MO_U_Le r | isComparisonExpr x -> CmmLit (CmmInt 1 wordWidth) - MO_S_Le r | isComparisonExpr x -> CmmLit (CmmInt 1 wordWidth) - MO_U_Ge r | isComparisonExpr x -> x - MO_S_Ge r | isComparisonExpr x -> x - other -> CmmMachOp mop args + MO_Mul r -> Just x + MO_S_Quot r -> Just x + MO_U_Quot r -> Just x + MO_S_Rem r -> Just $ CmmLit (CmmInt 0 rep) + MO_U_Rem r -> Just $ CmmLit (CmmInt 0 rep) + MO_Ne r | Just x' <- maybeInvertCmmExpr x -> Just x' + MO_Eq r | isComparisonExpr x -> Just x + MO_U_Lt r | Just x' <- maybeInvertCmmExpr x -> Just x' + MO_S_Lt r | Just x' <- maybeInvertCmmExpr x -> Just x' + MO_U_Gt r | isComparisonExpr x -> Just $ CmmLit (CmmInt 0 wordWidth) + MO_S_Gt r | isComparisonExpr x -> Just $ CmmLit (CmmInt 0 wordWidth) + MO_U_Le r | isComparisonExpr x -> Just $ CmmLit (CmmInt 1 wordWidth) + MO_S_Le r | isComparisonExpr x -> Just $ CmmLit (CmmInt 1 wordWidth) + MO_U_Ge r | isComparisonExpr x -> Just x + MO_S_Ge r | isComparisonExpr x -> Just x + other -> Nothing -- Now look for multiplication/division by powers of 2 (integers). -cmmMachOpFold mop args@[x, y@(CmmLit (CmmInt n _))] +cmmMachOpFoldM mop args@[x, y@(CmmLit (CmmInt n _))] = case mop of - MO_Mul rep - | Just p <- exactLog2 n -> - CmmMachOp (MO_Shl rep) [x, CmmLit (CmmInt p rep)] - MO_U_Quot rep - | Just p <- exactLog2 n -> - CmmMachOp (MO_U_Shr rep) [x, CmmLit (CmmInt p rep)] - MO_S_Quot rep - | Just p <- exactLog2 n, - CmmReg _ <- x -> -- We duplicate x below, hence require - -- it is a reg. FIXME: remove this restriction. - -- shift right is not the same as quot, because it rounds - -- to minus infinity, whereasq quot rounds toward zero. - -- To fix this up, we add one less than the divisor to the - -- dividend if it is a negative number. - -- - -- to avoid a test/jump, we use the following sequence: - -- x1 = x >> word_size-1 (all 1s if -ve, all 0s if +ve) - -- x2 = y & (divisor-1) - -- result = (x+x2) >>= log2(divisor) - -- this could be done a bit more simply using conditional moves, - -- but we're processor independent here. - -- - -- we optimise the divide by 2 case slightly, generating - -- x1 = x >> word_size-1 (unsigned) - -- return = (x + x1) >>= log2(divisor) - let - bits = fromIntegral (widthInBits rep) - 1 - shr = if p == 1 then MO_U_Shr rep else MO_S_Shr rep - x1 = CmmMachOp shr [x, CmmLit (CmmInt bits rep)] - x2 = if p == 1 then x1 else - CmmMachOp (MO_And rep) [x1, CmmLit (CmmInt (n-1) rep)] - x3 = CmmMachOp (MO_Add rep) [x, x2] - in - CmmMachOp (MO_S_Shr rep) [x3, CmmLit (CmmInt p rep)] - other - -> unchanged - where - unchanged = CmmMachOp mop args + MO_Mul rep + | Just p <- exactLog2 n -> + Just (cmmMachOpFold (MO_Shl rep) [x, CmmLit (CmmInt p rep)]) + MO_U_Quot rep + | Just p <- exactLog2 n -> + Just (cmmMachOpFold (MO_U_Shr rep) [x, CmmLit (CmmInt p rep)]) + MO_S_Quot rep + | Just p <- exactLog2 n, + CmmReg _ <- x -> -- We duplicate x below, hence require + -- it is a reg. FIXME: remove this restriction. + -- shift right is not the same as quot, because it rounds + -- to minus infinity, whereasq quot rounds toward zero. + -- To fix this up, we add one less than the divisor to the + -- dividend if it is a negative number. + -- + -- to avoid a test/jump, we use the following sequence: + -- x1 = x >> word_size-1 (all 1s if -ve, all 0s if +ve) + -- x2 = y & (divisor-1) + -- result = (x+x2) >>= log2(divisor) + -- this could be done a bit more simply using conditional moves, + -- but we're processor independent here. + -- + -- we optimise the divide by 2 case slightly, generating + -- x1 = x >> word_size-1 (unsigned) + -- return = (x + x1) >>= log2(divisor) + let + bits = fromIntegral (widthInBits rep) - 1 + shr = if p == 1 then MO_U_Shr rep else MO_S_Shr rep + x1 = CmmMachOp shr [x, CmmLit (CmmInt bits rep)] + x2 = if p == 1 then x1 else + CmmMachOp (MO_And rep) [x1, CmmLit (CmmInt (n-1) rep)] + x3 = CmmMachOp (MO_Add rep) [x, x2] + in + Just (cmmMachOpFold (MO_S_Shr rep) [x3, CmmLit (CmmInt p rep)]) + other + -> Nothing -- Anything else is just too hard. -cmmMachOpFold mop args = CmmMachOp mop args +cmmMachOpFoldM _ _ = Nothing -- ----------------------------------------------------------------------------- -- exactLog2 @@ -532,12 +673,11 @@ -} cmmLoopifyForC :: RawCmmTop -> RawCmmTop -cmmLoopifyForC p@(CmmProc info entry_lbl [] - (ListGraph blocks@(BasicBlock top_id _ : _))) - | null info = p -- only if there's an info table, ignore case alts - | otherwise = +cmmLoopifyForC p@(CmmProc Nothing _ _) = p -- only if there's an info table, ignore case alts +cmmLoopifyForC p@(CmmProc (Just info@(Statics info_lbl _)) entry_lbl + (ListGraph blocks@(BasicBlock top_id _ : _))) = -- pprTrace "jump_lbl" (ppr jump_lbl <+> ppr entry_lbl) $ - CmmProc info entry_lbl [] (ListGraph blocks') + CmmProc (Just info) entry_lbl (ListGraph blocks') where blocks' = [ BasicBlock id (map do_stmt stmts) | BasicBlock id stmts <- blocks ] @@ -545,7 +685,7 @@ = CmmBranch top_id do_stmt stmt = stmt - jump_lbl | tablesNextToCode = entryLblToInfoLbl entry_lbl + jump_lbl | tablesNextToCode = info_lbl | otherwise = entry_lbl cmmLoopifyForC top = top diff -Nru ghc-7.0.3/compiler/cmm/CmmParse.hs ghc-7.2.1/compiler/cmm/CmmParse.hs --- ghc-7.0.3/compiler/cmm/CmmParse.hs 2011-03-26 20:51:08.000000000 +0000 +++ ghc-7.2.1/compiler/cmm/CmmParse.hs 2011-08-07 20:09:18.000000000 +0000 @@ -1,14 +1,7 @@ {-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} {-# OPTIONS -fglasgow-exts -cpp #-} -{-# OPTIONS -Wwarn -w -XNoMonomorphismRestriction #-} --- The NoMonomorphismRestriction deals with a Happy infelicity --- With OutsideIn's more conservativ monomorphism restriction --- we aren't generalising --- notHappyAtAll = error "urk" --- which is terrible. Switching off the restriction allows --- the generalisation. Better would be to make Happy generate --- an appropriate signature. --- +{-# LANGUAGE BangPatterns #-} -- required for versions of Happy before 1.18.6 +{-# OPTIONS -Wwarn -w #-} -- 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 @@ -33,8 +26,8 @@ import CostCentre import BlockId -import Cmm -import PprCmm +import OldCmm +import OldPprCmm() import CmmUtils import CmmLex import CLabel @@ -102,40 +95,40 @@ happyOut6 :: (HappyAbsSyn ) -> (ExtCode) happyOut6 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut6 #-} -happyIn7 :: ([ExtFCode [CmmStatic]]) -> (HappyAbsSyn ) +happyIn7 :: (ExtFCode CLabel) -> (HappyAbsSyn ) happyIn7 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn7 #-} -happyOut7 :: (HappyAbsSyn ) -> ([ExtFCode [CmmStatic]]) +happyOut7 :: (HappyAbsSyn ) -> (ExtFCode CLabel) happyOut7 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut7 #-} -happyIn8 :: (ExtFCode [CmmStatic]) -> (HappyAbsSyn ) +happyIn8 :: ([ExtFCode [CmmStatic]]) -> (HappyAbsSyn ) happyIn8 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn8 #-} -happyOut8 :: (HappyAbsSyn ) -> (ExtFCode [CmmStatic]) +happyOut8 :: (HappyAbsSyn ) -> ([ExtFCode [CmmStatic]]) happyOut8 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut8 #-} -happyIn9 :: ([ExtFCode CmmExpr]) -> (HappyAbsSyn ) +happyIn9 :: (ExtFCode [CmmStatic]) -> (HappyAbsSyn ) happyIn9 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn9 #-} -happyOut9 :: (HappyAbsSyn ) -> ([ExtFCode CmmExpr]) +happyOut9 :: (HappyAbsSyn ) -> (ExtFCode [CmmStatic]) happyOut9 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut9 #-} -happyIn10 :: (ExtCode) -> (HappyAbsSyn ) +happyIn10 :: ([ExtFCode CmmExpr]) -> (HappyAbsSyn ) happyIn10 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn10 #-} -happyOut10 :: (HappyAbsSyn ) -> (ExtCode) +happyOut10 :: (HappyAbsSyn ) -> ([ExtFCode CmmExpr]) happyOut10 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut10 #-} -happyIn11 :: (ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg])) -> (HappyAbsSyn ) +happyIn11 :: (ExtCode) -> (HappyAbsSyn ) happyIn11 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn11 #-} -happyOut11 :: (HappyAbsSyn ) -> (ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg])) +happyOut11 :: (HappyAbsSyn ) -> (ExtCode) happyOut11 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut11 #-} -happyIn12 :: (ExtCode) -> (HappyAbsSyn ) +happyIn12 :: (ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg])) -> (HappyAbsSyn ) happyIn12 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn12 #-} -happyOut12 :: (HappyAbsSyn ) -> (ExtCode) +happyOut12 :: (HappyAbsSyn ) -> (ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg])) happyOut12 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut12 #-} happyIn13 :: (ExtCode) -> (HappyAbsSyn ) @@ -144,40 +137,40 @@ happyOut13 :: (HappyAbsSyn ) -> (ExtCode) happyOut13 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut13 #-} -happyIn14 :: ([(FastString, CLabel)]) -> (HappyAbsSyn ) +happyIn14 :: (ExtCode) -> (HappyAbsSyn ) happyIn14 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn14 #-} -happyOut14 :: (HappyAbsSyn ) -> ([(FastString, CLabel)]) +happyOut14 :: (HappyAbsSyn ) -> (ExtCode) happyOut14 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut14 #-} -happyIn15 :: ((FastString, CLabel)) -> (HappyAbsSyn ) +happyIn15 :: ([(FastString, CLabel)]) -> (HappyAbsSyn ) happyIn15 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn15 #-} -happyOut15 :: (HappyAbsSyn ) -> ((FastString, CLabel)) +happyOut15 :: (HappyAbsSyn ) -> ([(FastString, CLabel)]) happyOut15 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut15 #-} -happyIn16 :: ([FastString]) -> (HappyAbsSyn ) +happyIn16 :: ((FastString, CLabel)) -> (HappyAbsSyn ) happyIn16 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn16 #-} -happyOut16 :: (HappyAbsSyn ) -> ([FastString]) +happyOut16 :: (HappyAbsSyn ) -> ((FastString, CLabel)) happyOut16 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut16 #-} -happyIn17 :: (ExtCode) -> (HappyAbsSyn ) +happyIn17 :: ([FastString]) -> (HappyAbsSyn ) happyIn17 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn17 #-} -happyOut17 :: (HappyAbsSyn ) -> (ExtCode) +happyOut17 :: (HappyAbsSyn ) -> ([FastString]) happyOut17 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut17 #-} -happyIn18 :: (CmmReturnInfo) -> (HappyAbsSyn ) +happyIn18 :: (ExtCode) -> (HappyAbsSyn ) happyIn18 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn18 #-} -happyOut18 :: (HappyAbsSyn ) -> (CmmReturnInfo) +happyOut18 :: (HappyAbsSyn ) -> (ExtCode) happyOut18 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut18 #-} -happyIn19 :: (ExtFCode BoolExpr) -> (HappyAbsSyn ) +happyIn19 :: (CmmReturnInfo) -> (HappyAbsSyn ) happyIn19 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn19 #-} -happyOut19 :: (HappyAbsSyn ) -> (ExtFCode BoolExpr) +happyOut19 :: (HappyAbsSyn ) -> (CmmReturnInfo) happyOut19 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut19 #-} happyIn20 :: (ExtFCode BoolExpr) -> (HappyAbsSyn ) @@ -186,88 +179,88 @@ happyOut20 :: (HappyAbsSyn ) -> (ExtFCode BoolExpr) happyOut20 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut20 #-} -happyIn21 :: (CmmSafety) -> (HappyAbsSyn ) +happyIn21 :: (ExtFCode BoolExpr) -> (HappyAbsSyn ) happyIn21 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn21 #-} -happyOut21 :: (HappyAbsSyn ) -> (CmmSafety) +happyOut21 :: (HappyAbsSyn ) -> (ExtFCode BoolExpr) happyOut21 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut21 #-} -happyIn22 :: (Maybe [GlobalReg]) -> (HappyAbsSyn ) +happyIn22 :: (CmmSafety) -> (HappyAbsSyn ) happyIn22 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn22 #-} -happyOut22 :: (HappyAbsSyn ) -> (Maybe [GlobalReg]) +happyOut22 :: (HappyAbsSyn ) -> (CmmSafety) happyOut22 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut22 #-} -happyIn23 :: ([GlobalReg]) -> (HappyAbsSyn ) +happyIn23 :: (Maybe [GlobalReg]) -> (HappyAbsSyn ) happyIn23 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn23 #-} -happyOut23 :: (HappyAbsSyn ) -> ([GlobalReg]) +happyOut23 :: (HappyAbsSyn ) -> (Maybe [GlobalReg]) happyOut23 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut23 #-} -happyIn24 :: (Maybe (Int,Int)) -> (HappyAbsSyn ) +happyIn24 :: ([GlobalReg]) -> (HappyAbsSyn ) happyIn24 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn24 #-} -happyOut24 :: (HappyAbsSyn ) -> (Maybe (Int,Int)) +happyOut24 :: (HappyAbsSyn ) -> ([GlobalReg]) happyOut24 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut24 #-} -happyIn25 :: ([([Int],ExtCode)]) -> (HappyAbsSyn ) +happyIn25 :: (Maybe (Int,Int)) -> (HappyAbsSyn ) happyIn25 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn25 #-} -happyOut25 :: (HappyAbsSyn ) -> ([([Int],ExtCode)]) +happyOut25 :: (HappyAbsSyn ) -> (Maybe (Int,Int)) happyOut25 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut25 #-} -happyIn26 :: (([Int],ExtCode)) -> (HappyAbsSyn ) +happyIn26 :: ([ExtFCode ([Int],Either BlockId ExtCode)]) -> (HappyAbsSyn ) happyIn26 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn26 #-} -happyOut26 :: (HappyAbsSyn ) -> (([Int],ExtCode)) +happyOut26 :: (HappyAbsSyn ) -> ([ExtFCode ([Int],Either BlockId ExtCode)]) happyOut26 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut26 #-} -happyIn27 :: ([Int]) -> (HappyAbsSyn ) +happyIn27 :: (ExtFCode ([Int],Either BlockId ExtCode)) -> (HappyAbsSyn ) happyIn27 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn27 #-} -happyOut27 :: (HappyAbsSyn ) -> ([Int]) +happyOut27 :: (HappyAbsSyn ) -> (ExtFCode ([Int],Either BlockId ExtCode)) happyOut27 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut27 #-} -happyIn28 :: (Maybe ExtCode) -> (HappyAbsSyn ) +happyIn28 :: (ExtFCode (Either BlockId ExtCode)) -> (HappyAbsSyn ) happyIn28 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn28 #-} -happyOut28 :: (HappyAbsSyn ) -> (Maybe ExtCode) +happyOut28 :: (HappyAbsSyn ) -> (ExtFCode (Either BlockId ExtCode)) happyOut28 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut28 #-} -happyIn29 :: (ExtCode) -> (HappyAbsSyn ) +happyIn29 :: ([Int]) -> (HappyAbsSyn ) happyIn29 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn29 #-} -happyOut29 :: (HappyAbsSyn ) -> (ExtCode) +happyOut29 :: (HappyAbsSyn ) -> ([Int]) happyOut29 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut29 #-} -happyIn30 :: (ExtFCode CmmExpr) -> (HappyAbsSyn ) +happyIn30 :: (Maybe ExtCode) -> (HappyAbsSyn ) happyIn30 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn30 #-} -happyOut30 :: (HappyAbsSyn ) -> (ExtFCode CmmExpr) +happyOut30 :: (HappyAbsSyn ) -> (Maybe ExtCode) happyOut30 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut30 #-} -happyIn31 :: (ExtFCode CmmExpr) -> (HappyAbsSyn ) +happyIn31 :: (ExtCode) -> (HappyAbsSyn ) happyIn31 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn31 #-} -happyOut31 :: (HappyAbsSyn ) -> (ExtFCode CmmExpr) +happyOut31 :: (HappyAbsSyn ) -> (ExtCode) happyOut31 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut31 #-} -happyIn32 :: (CmmType) -> (HappyAbsSyn ) +happyIn32 :: (ExtFCode CmmExpr) -> (HappyAbsSyn ) happyIn32 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn32 #-} -happyOut32 :: (HappyAbsSyn ) -> (CmmType) +happyOut32 :: (HappyAbsSyn ) -> (ExtFCode CmmExpr) happyOut32 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut32 #-} -happyIn33 :: ([ExtFCode HintedCmmActual]) -> (HappyAbsSyn ) +happyIn33 :: (ExtFCode CmmExpr) -> (HappyAbsSyn ) happyIn33 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn33 #-} -happyOut33 :: (HappyAbsSyn ) -> ([ExtFCode HintedCmmActual]) +happyOut33 :: (HappyAbsSyn ) -> (ExtFCode CmmExpr) happyOut33 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut33 #-} -happyIn34 :: ([ExtFCode HintedCmmActual]) -> (HappyAbsSyn ) +happyIn34 :: (CmmType) -> (HappyAbsSyn ) happyIn34 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn34 #-} -happyOut34 :: (HappyAbsSyn ) -> ([ExtFCode HintedCmmActual]) +happyOut34 :: (HappyAbsSyn ) -> (CmmType) happyOut34 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut34 #-} happyIn35 :: ([ExtFCode HintedCmmActual]) -> (HappyAbsSyn ) @@ -276,70 +269,70 @@ happyOut35 :: (HappyAbsSyn ) -> ([ExtFCode HintedCmmActual]) happyOut35 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut35 #-} -happyIn36 :: (ExtFCode HintedCmmActual) -> (HappyAbsSyn ) +happyIn36 :: ([ExtFCode HintedCmmActual]) -> (HappyAbsSyn ) happyIn36 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn36 #-} -happyOut36 :: (HappyAbsSyn ) -> (ExtFCode HintedCmmActual) +happyOut36 :: (HappyAbsSyn ) -> ([ExtFCode HintedCmmActual]) happyOut36 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut36 #-} -happyIn37 :: ([ExtFCode CmmExpr]) -> (HappyAbsSyn ) +happyIn37 :: ([ExtFCode HintedCmmActual]) -> (HappyAbsSyn ) happyIn37 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn37 #-} -happyOut37 :: (HappyAbsSyn ) -> ([ExtFCode CmmExpr]) +happyOut37 :: (HappyAbsSyn ) -> ([ExtFCode HintedCmmActual]) happyOut37 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut37 #-} -happyIn38 :: ([ExtFCode CmmExpr]) -> (HappyAbsSyn ) +happyIn38 :: (ExtFCode HintedCmmActual) -> (HappyAbsSyn ) happyIn38 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn38 #-} -happyOut38 :: (HappyAbsSyn ) -> ([ExtFCode CmmExpr]) +happyOut38 :: (HappyAbsSyn ) -> (ExtFCode HintedCmmActual) happyOut38 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut38 #-} -happyIn39 :: (ExtFCode CmmExpr) -> (HappyAbsSyn ) +happyIn39 :: ([ExtFCode CmmExpr]) -> (HappyAbsSyn ) happyIn39 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn39 #-} -happyOut39 :: (HappyAbsSyn ) -> (ExtFCode CmmExpr) +happyOut39 :: (HappyAbsSyn ) -> ([ExtFCode CmmExpr]) happyOut39 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut39 #-} -happyIn40 :: ([ExtFCode HintedCmmFormal]) -> (HappyAbsSyn ) +happyIn40 :: ([ExtFCode CmmExpr]) -> (HappyAbsSyn ) happyIn40 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn40 #-} -happyOut40 :: (HappyAbsSyn ) -> ([ExtFCode HintedCmmFormal]) +happyOut40 :: (HappyAbsSyn ) -> ([ExtFCode CmmExpr]) happyOut40 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut40 #-} -happyIn41 :: ([ExtFCode HintedCmmFormal]) -> (HappyAbsSyn ) +happyIn41 :: (ExtFCode CmmExpr) -> (HappyAbsSyn ) happyIn41 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn41 #-} -happyOut41 :: (HappyAbsSyn ) -> ([ExtFCode HintedCmmFormal]) +happyOut41 :: (HappyAbsSyn ) -> (ExtFCode CmmExpr) happyOut41 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut41 #-} -happyIn42 :: (ExtFCode HintedCmmFormal) -> (HappyAbsSyn ) +happyIn42 :: ([ExtFCode HintedCmmFormal]) -> (HappyAbsSyn ) happyIn42 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn42 #-} -happyOut42 :: (HappyAbsSyn ) -> (ExtFCode HintedCmmFormal) +happyOut42 :: (HappyAbsSyn ) -> ([ExtFCode HintedCmmFormal]) happyOut42 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut42 #-} -happyIn43 :: (ExtFCode LocalReg) -> (HappyAbsSyn ) +happyIn43 :: ([ExtFCode HintedCmmFormal]) -> (HappyAbsSyn ) happyIn43 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn43 #-} -happyOut43 :: (HappyAbsSyn ) -> (ExtFCode LocalReg) +happyOut43 :: (HappyAbsSyn ) -> ([ExtFCode HintedCmmFormal]) happyOut43 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut43 #-} -happyIn44 :: (ExtFCode CmmReg) -> (HappyAbsSyn ) +happyIn44 :: (ExtFCode HintedCmmFormal) -> (HappyAbsSyn ) happyIn44 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn44 #-} -happyOut44 :: (HappyAbsSyn ) -> (ExtFCode CmmReg) +happyOut44 :: (HappyAbsSyn ) -> (ExtFCode HintedCmmFormal) happyOut44 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut44 #-} -happyIn45 :: ([ExtFCode LocalReg]) -> (HappyAbsSyn ) +happyIn45 :: (ExtFCode LocalReg) -> (HappyAbsSyn ) happyIn45 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn45 #-} -happyOut45 :: (HappyAbsSyn ) -> ([ExtFCode LocalReg]) +happyOut45 :: (HappyAbsSyn ) -> (ExtFCode LocalReg) happyOut45 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut45 #-} -happyIn46 :: ([ExtFCode LocalReg]) -> (HappyAbsSyn ) +happyIn46 :: (ExtFCode CmmReg) -> (HappyAbsSyn ) happyIn46 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn46 #-} -happyOut46 :: (HappyAbsSyn ) -> ([ExtFCode LocalReg]) +happyOut46 :: (HappyAbsSyn ) -> (ExtFCode CmmReg) happyOut46 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut46 #-} happyIn47 :: ([ExtFCode LocalReg]) -> (HappyAbsSyn ) @@ -348,36 +341,48 @@ happyOut47 :: (HappyAbsSyn ) -> ([ExtFCode LocalReg]) happyOut47 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut47 #-} -happyIn48 :: (ExtFCode LocalReg) -> (HappyAbsSyn ) +happyIn48 :: ([ExtFCode LocalReg]) -> (HappyAbsSyn ) happyIn48 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn48 #-} -happyOut48 :: (HappyAbsSyn ) -> (ExtFCode LocalReg) +happyOut48 :: (HappyAbsSyn ) -> ([ExtFCode LocalReg]) happyOut48 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut48 #-} -happyIn49 :: (ExtFCode (Maybe UpdateFrame)) -> (HappyAbsSyn ) +happyIn49 :: ([ExtFCode LocalReg]) -> (HappyAbsSyn ) happyIn49 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn49 #-} -happyOut49 :: (HappyAbsSyn ) -> (ExtFCode (Maybe UpdateFrame)) +happyOut49 :: (HappyAbsSyn ) -> ([ExtFCode LocalReg]) happyOut49 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut49 #-} -happyIn50 :: (ExtFCode (Maybe BlockId)) -> (HappyAbsSyn ) +happyIn50 :: (ExtFCode LocalReg) -> (HappyAbsSyn ) happyIn50 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn50 #-} -happyOut50 :: (HappyAbsSyn ) -> (ExtFCode (Maybe BlockId)) +happyOut50 :: (HappyAbsSyn ) -> (ExtFCode LocalReg) happyOut50 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut50 #-} -happyIn51 :: (CmmType) -> (HappyAbsSyn ) +happyIn51 :: (ExtFCode (Maybe UpdateFrame)) -> (HappyAbsSyn ) happyIn51 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn51 #-} -happyOut51 :: (HappyAbsSyn ) -> (CmmType) +happyOut51 :: (HappyAbsSyn ) -> (ExtFCode (Maybe UpdateFrame)) happyOut51 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut51 #-} -happyIn52 :: (CmmType) -> (HappyAbsSyn ) +happyIn52 :: (ExtFCode (Maybe BlockId)) -> (HappyAbsSyn ) happyIn52 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn52 #-} -happyOut52 :: (HappyAbsSyn ) -> (CmmType) +happyOut52 :: (HappyAbsSyn ) -> (ExtFCode (Maybe BlockId)) happyOut52 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut52 #-} +happyIn53 :: (CmmType) -> (HappyAbsSyn ) +happyIn53 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn53 #-} +happyOut53 :: (HappyAbsSyn ) -> (CmmType) +happyOut53 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut53 #-} +happyIn54 :: (CmmType) -> (HappyAbsSyn ) +happyIn54 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn54 #-} +happyOut54 :: (HappyAbsSyn ) -> (CmmType) +happyOut54 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut54 #-} happyInTok :: (Located CmmToken) -> (HappyAbsSyn ) happyInTok x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyInTok #-} @@ -387,21 +392,21 @@ happyActOffsets :: HappyAddr -happyActOffsets = HappyA# "\x33\x01\x00\x00\x57\x03\x33\x01\x00\x00\x00\x00\x92\x03\x00\x00\x47\x03\x00\x00\x71\x03\x70\x03\x6f\x03\x6c\x03\x66\x03\x65\x03\x29\x03\x31\x03\x05\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x60\x03\x2b\x03\x3c\x01\x4a\x03\x32\x03\x00\x00\x26\x03\x46\x03\x38\x03\x30\x03\x23\x03\x21\x03\x1d\x03\x1c\x03\x1b\x03\x0b\x03\x28\x03\x09\x00\x00\x00\xf8\x02\x00\x00\x0a\x03\x00\x00\x2c\x03\x2a\x03\x25\x03\x1a\x03\x17\x03\x16\x03\xeb\x02\x00\x00\x47\x01\x00\x00\x05\x01\x00\x00\x10\x03\x00\x00\x0c\x03\xe8\x02\xed\x02\x08\x03\x61\x00\x00\x00\x3c\x01\x00\x00\x00\x00\x0d\x03\x47\x01\xff\xff\x07\x03\x09\x03\xd0\x02\x05\x03\xfa\x02\x00\x00\xc6\x02\xc4\x02\xb8\x02\xb5\x02\xb3\x02\xa9\x02\x00\x00\xe2\x02\x1a\x00\xde\x02\xdb\x02\x12\x00\xd9\x02\xd5\x02\xd4\x02\x00\x00\x02\x00\xd8\x02\x99\x02\x95\x02\xa4\x01\xce\x02\x00\x00\xcf\x02\x00\x00\x61\x00\x61\x00\x96\x02\x61\x00\x00\x00\x00\x00\x00\x00\xb7\x02\xb7\x02\x00\x00\x00\x00\x00\x00\x37\x02\x1a\x00\xca\x02\x1a\x00\x1a\x00\xa7\x00\xc0\x02\x0d\x00\x00\x00\xf8\x00\x88\x02\x54\x00\x61\x00\xb9\x02\xb6\x02\x00\x00\x1c\x00\x61\x00\x61\x00\x61\x00\x61\x00\x61\x00\x61\x00\x61\x00\x61\x00\x61\x00\x61\x00\x61\x00\x61\x00\x61\x00\x61\x00\x61\x00\x61\x00\x61\x00\x00\x00\x3c\x01\x00\x00\x02\x01\xa1\x02\x00\x00\x4f\x02\x61\x00\x78\x02\x00\x00\xb4\x02\xa3\x02\x00\x00\x59\x02\xa5\x02\x74\x02\x5b\x02\x53\x02\x00\x00\x3c\x01\x4d\x02\x86\x02\x61\x00\x7f\x02\x00\x00\x82\x03\x8b\x02\x6a\x02\x75\x02\x69\x02\x68\x02\x66\x02\x79\x02\x77\x02\x60\x02\x65\x02\x5c\x02\xec\x01\x00\x00\x61\x00\x00\x00\xaa\x03\xaa\x03\xaa\x03\xaa\x03\x7b\x00\x7b\x00\xaa\x03\xaa\x03\xbe\x03\xc5\x03\xf9\x00\x02\x01\x02\x01\x00\x00\x00\x00\x00\x00\x6e\x03\x5d\x02\x00\x00\x00\x00\x61\x00\x61\x00\x17\x02\x58\x02\x61\x00\x1e\x02\x4d\x00\x00\x00\x96\x03\x54\x00\x54\x00\x56\x02\x45\x02\x3a\x02\x00\x00\x00\x00\x0f\x02\x61\x00\x61\x00\x0d\x02\x34\x02\x00\x00\x00\x00\x00\x00\x01\x02\x61\x00\x90\x01\xd2\x01\x00\x00\xf8\x00\x36\x02\x00\x00\x00\x00\x00\x01\x38\x02\x4f\x02\x1a\x00\x54\x00\x54\x00\x35\x02\x99\x00\x2e\x02\x00\x00\x10\x02\x00\x00\xf7\x01\xb8\x01\x2d\x02\x00\x00\x61\x00\x2c\x02\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe8\x01\xe6\x01\xe5\x01\x00\x00\xd9\x01\x00\x00\x00\x00\x08\x02\x07\x02\x06\x02\xfa\x01\x00\x00\x00\x00\x00\x00\x0c\x02\xd7\x01\xc3\x01\x61\x00\x00\x00\x00\x00\x00\x00\x00\x01\xe4\x01\xff\x01\x00\x00\x00\x00\x00\x00\xf9\x01\x00\x00\x05\x02\xf0\x01\x61\x00\x61\x00\x61\x00\xce\x01\x00\x00\xef\x01\xbd\x01\xb3\x01\xb1\x01\x00\x00\xaa\x01\xa8\x01\xa7\x01\x9c\x01\xc6\x01\xc5\x01\xc4\x01\xd1\x01\xcf\x01\xbb\x01\x00\x00\xcb\x01\xcd\x01\x00\x00\x00\x00\xba\x01\x7c\x01\xb4\x01\x9f\x01\x68\x01\x68\x01\x00\x00\x1a\x00\xa5\x01\x00\x00\x78\x01\x92\x01\x00\x00\x53\x01\x52\x01\x45\x01\x74\x01\x67\x01\x65\x01\x1a\x00\x00\x00\x1a\x00\x66\x01\x63\x01\x00\x00\x63\x01\x64\x01\x06\x00\x35\x01\x00\x00\x60\x01\x5e\x01\x22\x01\x19\x01\x00\x00\x11\x00\x4b\x01\x00\x00\x00\x00\x4d\x01\x15\x01\x41\x01\x00\x00\x38\x01\x00\x00\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x01\x32\x01\x00\x00\x00\x00\x00\x00"# +happyActOffsets = HappyA# "\x37\x01\x00\x00\x42\x03\x37\x01\x00\x00\x00\x00\x76\x03\x00\x00\x38\x03\x00\x00\x70\x03\x6f\x03\x6e\x03\x6c\x03\x66\x03\x60\x03\x28\x03\x25\x03\x22\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x03\x39\x03\x94\x00\x5b\x03\x41\x03\x00\x00\x18\x03\x53\x03\x45\x03\x37\x03\x15\x03\x13\x03\x08\x03\x06\x03\x05\x03\x03\x03\x31\x03\x05\x00\x00\x00\xfa\x02\x00\x00\xf5\x02\x00\x00\x27\x03\x22\x03\x21\x03\x20\x03\x17\x03\x11\x03\xe6\x02\x00\x00\xe5\x02\x00\x00\x22\x01\x00\x00\x1b\x03\x00\x00\x07\x03\xd5\x02\xea\x02\x14\x03\x61\x00\x00\x00\x94\x00\x00\x00\x00\x00\x3c\x00\x12\x03\x00\x00\xc5\x02\xc3\x02\xc1\x02\xb6\x02\xb5\x02\xb3\x02\x00\x00\xf3\x02\x1a\x00\x00\x03\xf7\x02\x18\x00\xf2\x02\xf0\x02\xe7\x02\x00\x00\xf1\x02\x3c\x00\xff\xff\xe8\x02\xe1\x02\xe2\x02\x00\x00\x27\x02\xdc\x02\x00\x00\xe0\x02\x61\x00\x61\x00\x98\x02\x61\x00\x00\x00\x00\x00\x00\x00\xca\x02\xca\x02\x1a\x00\xd3\x02\x1a\x00\x1a\x00\xe7\xff\xd4\x02\x0d\x00\x00\x00\x0b\x01\x96\x02\x54\x00\x61\x00\xce\x02\xc8\x02\x00\x00\x14\x00\x00\x00\x94\x00\x00\x00\xd2\x00\xbe\x02\x00\x00\x3f\x02\x61\x00\x93\x02\x61\x00\x61\x00\x61\x00\x61\x00\x61\x00\x61\x00\x61\x00\x61\x00\x61\x00\x61\x00\x61\x00\x61\x00\x61\x00\x61\x00\x61\x00\x61\x00\x61\x00\x02\x00\x88\x02\x85\x02\x94\x01\x00\x00\x00\x00\x00\x00\x84\x02\x81\x02\x73\x02\x00\x00\x94\x00\x65\x02\xab\x02\x61\x00\xa9\x02\x00\x00\x9a\x03\xa3\x02\xa7\x02\x9e\x02\xa2\x02\xa1\x02\xa0\x02\x00\x00\x97\x02\x92\x02\x57\x02\x90\x02\xc2\x03\xc2\x03\xc2\x03\xc2\x03\x7b\x00\x7b\x00\xc2\x03\xc2\x03\xd6\x03\xfc\x00\xdd\x03\xd2\x00\xd2\x00\x00\x00\x00\x00\x00\x00\x86\x03\x87\x02\x00\x00\x7b\x02\xdc\x01\x00\x00\x61\x00\x00\x00\x00\x00\x61\x00\x61\x00\x55\x02\x91\x02\x61\x00\x0e\x02\x08\x00\x00\x00\xae\x03\x54\x00\x54\x00\x8a\x02\x83\x02\x6e\x02\x00\x00\x00\x00\x37\x02\x61\x00\x61\x00\x39\x02\x62\x02\x00\x00\x00\x00\x00\x00\x29\x02\x61\x00\x80\x01\xc2\x01\x00\x00\x0b\x01\x59\x02\x00\x00\x00\x00\x0d\x01\x4f\x02\x3f\x02\x1a\x00\x54\x00\x54\x00\x21\x02\x54\x02\x99\x00\x4d\x02\x00\x00\x42\x02\x00\x00\x32\x02\xa8\x01\x41\x02\x40\x02\x00\x00\x43\x00\x00\x00\x61\x00\x3e\x02\x3d\x02\x36\x02\x22\x02\xfc\x01\xf0\x01\xef\x01\x00\x00\xee\x01\x00\x00\x00\x00\x19\x02\x11\x02\x10\x02\x0f\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x02\xe2\x01\xd5\x01\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x01\xf6\x01\x0a\x02\x00\x00\x00\x00\x00\x00\x04\x02\x00\x00\xf5\x01\x05\x02\x61\x00\x61\x00\x61\x00\xe3\x01\x00\x00\xf9\x01\xc9\x01\xc8\x01\xbb\x01\x00\x00\xb2\x01\xb3\x01\xb1\x01\xa5\x01\xde\x01\xd1\x01\xce\x01\xdd\x01\xda\x01\xcd\x01\x00\x00\xd6\x01\xd8\x01\x00\x00\x00\x00\xc7\x01\x6c\x01\xd0\x01\xc5\x01\x8b\x01\x8b\x01\x00\x00\x1a\x00\xbe\x01\x00\x00\x89\x01\x24\x00\x00\x00\x88\x01\x7f\x01\x7e\x01\xb6\x01\x97\x01\x96\x01\x00\x00\x1a\x00\x59\x01\x00\x00\x1a\x00\xa6\x01\x93\x01\x00\x00\x93\x01\x95\x01\x06\x00\x54\x01\x00\x00\x81\x01\x74\x01\x4f\x01\x42\x01\x28\x01\x00\x00\x0c\x00\x5e\x01\x00\x00\x00\x00\x00\x00\x4b\x01\x2c\x01\x35\x01\x00\x00\x38\x01\x00\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\x01\x36\x01\x00\x00\x00\x00\x00\x00"# happyGotoOffsets :: HappyAddr -happyGotoOffsets = HappyA# "\xb9\x00\x00\x00\x00\x00\x2d\x00\x00\x00\x00\x00\x0e\x01\x00\x00\x29\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x01\x00\x00\x0d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x01\x01\x01\xb2\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xee\x00\x00\x00\xed\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x01\x00\x00\xac\x00\x00\x00\xdc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd6\x00\x00\x00\x56\x03\x00\x00\xa0\x00\x00\x00\x00\x00\x00\x00\x01\x00\x45\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x01\xf3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3f\x03\x3b\x03\x00\x00\x35\x03\x00\x00\x00\x00\x00\x00\xe5\x00\xd5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf7\x00\x00\x00\xf5\x00\xcc\x00\x00\x00\x00\x00\xe3\x00\x00\x00\xd0\x00\x00\x00\x31\x01\x24\x03\xc7\x00\xdf\x00\x00\x00\x00\x00\x81\x02\x22\x03\x1e\x03\x14\x03\x06\x03\x04\x03\x02\x03\xf4\x02\xea\x02\xe6\x02\xe4\x02\xd3\x02\xcd\x02\xc9\x02\xc3\x02\xb2\x02\xb0\x02\x00\x00\x9e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xac\x02\x00\x00\x00\x00\x00\x00\xdd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x48\x00\x00\x00\x00\x00\xa2\x02\x00\x00\x00\x00\xdb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x71\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x67\x02\x94\x02\x00\x00\x00\x00\x55\x02\xaa\x00\x00\x00\x00\x00\x00\x00\x2f\x01\x21\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9a\x00\x92\x02\x8f\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x02\x00\x00\x00\x00\x00\x00\x97\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xca\x00\x13\x01\xfb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x76\x02\x00\x00\x00\x00\xae\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\x00\x00\x00\x57\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x46\x00\xf5\xff\xfc\xff\x58\x00\x00\x00\x00\x00\x80\x00\x64\x00\x47\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x56\x00\x00\x00\xbd\x00\x00\x00\x00\x00\x1b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbb\x00\x00\x00\xfa\xff\x00\x00\x14\x00\x00\x00\x0e\x00\x00\x00\x08\x00\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf6\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# +happyGotoOffsets = HappyA# "\xb9\x00\x00\x00\x00\x00\x2b\x00\x00\x00\x00\x00\x0e\x01\x00\x00\x1a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x01\x00\x00\x10\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf5\x00\xff\x00\x3b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf2\x00\x00\x00\xe4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x11\x01\x00\x00\x12\x01\x00\x00\xed\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd7\x00\x00\x00\x5f\x03\x00\x00\x40\x00\x00\x00\x00\x00\xab\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x06\x01\xf4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfe\xff\x5d\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4f\x03\x4d\x03\x00\x00\x3f\x03\x00\x00\x00\x00\x00\x00\xf3\x00\xe6\x00\xf9\x00\x00\x00\xf7\x00\xe8\x00\x00\x00\x00\x00\xf0\x00\x00\x00\x95\x00\x00\x00\x33\x01\x3d\x03\xd6\x00\xd1\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2f\x03\x00\x00\x7d\x02\x2d\x03\x1f\x03\x1d\x03\x0f\x03\x0d\x03\xff\x02\xfd\x02\xef\x02\xed\x02\xdf\x02\xdd\x02\xcf\x02\xcd\x02\xbf\x02\xbd\x02\xaf\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\x00\x00\xad\x02\x00\x00\x00\x00\xde\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x02\x00\x00\x00\x00\x63\x02\x9f\x02\x00\x00\x00\x00\x51\x02\xba\x00\x00\x00\x00\x00\x00\x00\x25\x01\x23\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xac\x00\x9d\x02\x8f\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8d\x02\x00\x00\x00\x00\x00\x00\xf6\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcd\x00\x15\x01\xf4\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf2\xff\x00\x00\x7f\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x00\x00\x00\x5c\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x02\x43\x02\x20\x01\xaf\x00\x00\x00\x00\x00\xae\x00\x4a\x00\xa9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x00\x86\x00\x00\x00\xca\x00\x00\x00\x00\x00\x5a\x00\x4f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbd\x00\x00\x00\x00\x00\xbb\x00\x00\x00\x23\x00\x00\x00\x07\x00\x00\x00\x16\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf5\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# happyDefActions :: HappyAddr -happyDefActions = HappyA# "\xfe\xff\x00\x00\x00\x00\xfe\xff\xfb\xff\xfc\xff\x7a\xff\xfa\xff\x00\x00\x6d\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\xff\x6c\xff\x6b\xff\x6a\xff\x69\xff\x68\xff\x67\xff\x7a\xff\x70\xff\x78\xff\x00\x00\xdb\xff\xd9\xff\x00\x00\x00\x00\x00\x00\xd7\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\xff\xfd\xff\x72\xff\xea\xff\x00\x00\xde\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdc\xff\xf7\xff\xd8\xff\x00\x00\xdd\xff\x00\x00\x77\xff\x75\xff\x00\x00\x72\xff\x00\x00\x00\x00\x73\xff\x76\xff\x79\xff\xda\xff\x00\x00\xf7\xff\x00\x00\x6d\xff\x00\x00\x00\x00\x6e\xff\x00\x00\xd6\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\xff\x00\x00\xe1\xff\xed\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf5\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9c\xff\x98\xff\x00\x00\xf3\xff\x00\x00\x00\x00\x00\x00\x00\x00\x85\xff\x86\xff\x99\xff\x94\xff\x94\xff\xf6\xff\xf8\xff\x74\xff\x00\x00\xe1\xff\x00\x00\xe1\xff\xe1\xff\x00\x00\x00\x00\x00\x00\xd5\xff\x00\x00\x00\x00\x00\x00\x00\x00\x92\xff\xb9\xff\x7b\xff\x7c\xff\x8a\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9a\xff\x00\x00\x9b\xff\x9e\xff\x00\x00\x9f\xff\x00\x00\x00\x00\x00\x00\xf4\xff\x00\x00\xed\xff\xef\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\xff\x78\xff\x00\x00\x00\x00\x00\x00\x00\x00\xeb\xff\xed\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x95\xff\x8a\xff\x93\xff\xa1\xff\xa0\xff\xa3\xff\xa5\xff\xa9\xff\xaa\xff\xa2\xff\xa4\xff\xa6\xff\xa7\xff\xa8\xff\xab\xff\xac\xff\xad\xff\xae\xff\xaf\xff\x88\xff\x00\x00\x89\xff\xd4\xff\x8a\xff\x00\x00\x00\x00\x00\x00\x90\xff\x92\xff\x00\x00\xc7\xff\xc6\xff\x00\x00\x00\x00\x00\x00\x00\x00\x82\xff\x7f\xff\x7d\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdf\xff\xe0\xff\xe9\xff\x00\x00\x00\x00\x00\x00\x00\x00\x7e\xff\x81\xff\x00\x00\xcd\xff\xc3\xff\x00\x00\xc7\xff\xc6\xff\xe1\xff\x00\x00\x00\x00\x00\x00\x8c\xff\x00\x00\x8f\xff\x8e\xff\xcb\xff\x00\x00\x00\x00\x00\x00\x71\xff\x00\x00\x00\x00\x97\xff\x00\x00\xf0\xff\xee\xff\xf2\xff\xf1\xff\x00\x00\x00\x00\x00\x00\xe2\xff\x00\x00\xf9\xff\xec\xff\x00\x00\x00\x00\x00\x00\x00\x00\x9d\xff\x96\xff\x87\xff\x00\x00\xb8\xff\x00\x00\x00\x00\x91\xff\x8b\xff\xcc\xff\xc4\xff\xc5\xff\x00\x00\xc2\xff\x83\xff\x80\xff\x00\x00\xd3\xff\x00\x00\x00\x00\x90\xff\x90\xff\x00\x00\xb1\xff\x8d\xff\x00\x00\xb2\xff\xb8\xff\x00\x00\xcf\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb5\xff\xb7\xff\x00\x00\x00\x00\xba\xff\xca\xff\x00\x00\x00\x00\x00\x00\x00\x00\xc1\xff\xc1\xff\xd2\xff\xe1\xff\x00\x00\xce\xff\x00\x00\x00\x00\xe4\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe1\xff\xb4\xff\xe1\xff\x00\x00\xbf\xff\xc0\xff\xbf\xff\x00\x00\x00\x00\xc9\xff\xb0\xff\x00\x00\x00\x00\x00\x00\x00\x00\xe8\xff\x00\x00\x00\x00\xb6\xff\xb3\xff\x00\x00\x00\x00\x00\x00\xbe\xff\xbc\xff\xd0\xff\x00\x00\xbd\xff\xc8\xff\xd1\xff\xe5\xff\xe7\xff\x00\x00\x00\x00\xbb\xff\xe6\xff"# +happyDefActions = HappyA# "\xfe\xff\x00\x00\x00\x00\xfe\xff\xfb\xff\xfc\xff\x78\xff\xfa\xff\x00\x00\x6b\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\xff\x6a\xff\x69\xff\x68\xff\x67\xff\x66\xff\x65\xff\x78\xff\x6e\xff\x76\xff\x00\x00\xdc\xff\xda\xff\x00\x00\x00\x00\x00\x00\xd8\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\xff\xfd\xff\x70\xff\xeb\xff\x00\x00\xdf\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\xff\x00\x00\xd9\xff\x00\x00\xde\xff\x00\x00\x75\xff\x73\xff\x00\x00\x70\xff\x00\x00\x00\x00\x71\xff\x74\xff\x77\xff\xdb\xff\xf6\xff\x00\x00\xd7\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\xff\x00\x00\xe2\xff\xee\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf7\xff\x00\x00\xf6\xff\x00\x00\x6b\xff\x00\x00\x6c\xff\x72\xff\x00\x00\x9a\xff\x96\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\xff\x84\xff\x97\xff\x92\xff\x92\xff\xe2\xff\x00\x00\xe2\xff\xe2\xff\x00\x00\x00\x00\x00\x00\xd6\xff\x00\x00\x00\x00\x00\x00\x00\x00\x90\xff\xb9\xff\x79\xff\x7a\xff\x98\xff\x00\x00\x99\xff\x9c\xff\x00\x00\x9d\xff\x00\x00\x00\x00\x00\x00\x88\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf3\xff\xf5\xff\xf8\xff\x00\x00\x00\x00\x00\x00\xe4\xff\x76\xff\x00\x00\x00\x00\x00\x00\x00\x00\xec\xff\xee\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf4\xff\x00\x00\xee\xff\x00\x00\x00\x00\x9f\xff\x9e\xff\xa1\xff\xa3\xff\xa7\xff\xa8\xff\xa0\xff\xa2\xff\xa4\xff\xa5\xff\xa6\xff\xa9\xff\xaa\xff\xab\xff\xac\xff\xad\xff\x86\xff\x00\x00\x87\xff\x00\x00\x00\x00\x93\xff\x88\xff\x91\xff\xd5\xff\x88\xff\x00\x00\x00\x00\x00\x00\x8e\xff\x90\xff\x00\x00\xc7\xff\xc6\xff\x00\x00\x00\x00\x00\x00\x00\x00\x80\xff\x7d\xff\x7b\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\xff\xe1\xff\xea\xff\x00\x00\x00\x00\x00\x00\x00\x00\x7c\xff\x7f\xff\x00\x00\xce\xff\xc3\xff\x00\x00\xc7\xff\xc6\xff\xe2\xff\x00\x00\x00\x00\x00\x00\x00\x00\x8a\xff\x00\x00\x8d\xff\x8c\xff\xcc\xff\x00\x00\x00\x00\x00\x00\x00\x00\x95\xff\x00\x00\x6f\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\xff\x00\x00\xf9\xff\xed\xff\x00\x00\x00\x00\x00\x00\x00\x00\xf0\xff\xef\xff\xf2\xff\xf1\xff\x85\xff\x9b\xff\x94\xff\x00\x00\xb8\xff\x00\x00\x00\x00\x8f\xff\x89\xff\xcd\xff\xcb\xff\xc4\xff\xc5\xff\x00\x00\xc2\xff\x81\xff\x7e\xff\x00\x00\xd4\xff\x00\x00\x00\x00\x8e\xff\x8e\xff\x00\x00\xaf\xff\x8b\xff\x00\x00\xb0\xff\xb8\xff\x00\x00\xd0\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\xff\xb7\xff\x00\x00\x00\x00\xba\xff\xca\xff\x00\x00\x00\x00\x00\x00\x00\x00\xc1\xff\xc1\xff\xd3\xff\xe2\xff\x00\x00\xcf\xff\x00\x00\x00\x00\xe5\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\xff\xe2\xff\x00\x00\xb2\xff\xe2\xff\x00\x00\xbf\xff\xc0\xff\xbf\xff\x00\x00\x00\x00\xc9\xff\xae\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe9\xff\x00\x00\x00\x00\xb5\xff\xb4\xff\xb1\xff\x00\x00\x00\x00\x00\x00\xbe\xff\xbc\xff\xd1\xff\x00\x00\xbd\xff\xc8\xff\xd2\xff\xe6\xff\xe8\xff\x00\x00\x00\x00\xbb\xff\xe7\xff"# happyCheck :: HappyAddr -happyCheck = HappyA# "\xff\xff\x02\x00\x08\x00\x09\x00\x03\x00\x04\x00\x07\x00\x0d\x00\x06\x00\x13\x00\x0b\x00\x02\x00\x06\x00\x0e\x00\x0f\x00\x1a\x00\x1b\x00\x0e\x00\x05\x00\x1e\x00\x1f\x00\x20\x00\x1a\x00\x1b\x00\x23\x00\x08\x00\x08\x00\x13\x00\x02\x00\x01\x00\x24\x00\x23\x00\x12\x00\x07\x00\x28\x00\x07\x00\x2f\x00\x30\x00\x12\x00\x16\x00\x16\x00\x2f\x00\x30\x00\x2f\x00\x30\x00\x00\x00\x01\x00\x02\x00\x2f\x00\x30\x00\x17\x00\x06\x00\x07\x00\x2c\x00\x09\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x29\x00\x42\x00\x3f\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x07\x00\x31\x00\x32\x00\x40\x00\x34\x00\x35\x00\x03\x00\x0e\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x07\x00\x2f\x00\x30\x00\x17\x00\x0b\x00\x1a\x00\x1b\x00\x0e\x00\x0f\x00\x1e\x00\x1f\x00\x20\x00\x11\x00\x07\x00\x23\x00\x11\x00\x17\x00\x0b\x00\x20\x00\x21\x00\x0e\x00\x0f\x00\x19\x00\x2a\x00\x2b\x00\x2c\x00\x2f\x00\x30\x00\x2f\x00\x30\x00\x15\x00\x16\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x18\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x03\x00\x04\x00\x15\x00\x16\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x00\x00\x01\x00\x02\x00\x25\x00\x26\x00\x27\x00\x06\x00\x07\x00\x27\x00\x09\x00\x08\x00\x09\x00\x08\x00\x09\x00\x1d\x00\x0d\x00\x1b\x00\x0d\x00\x2b\x00\x2c\x00\x2f\x00\x30\x00\x2f\x00\x30\x00\x23\x00\x08\x00\x09\x00\x08\x00\x09\x00\x2f\x00\x0d\x00\x31\x00\x0d\x00\x41\x00\x2f\x00\x30\x00\x2f\x00\x30\x00\x24\x00\x05\x00\x24\x00\x05\x00\x28\x00\x1d\x00\x28\x00\x0a\x00\x0b\x00\x2f\x00\x30\x00\x2f\x00\x30\x00\x2f\x00\x30\x00\x24\x00\x0c\x00\x24\x00\x1c\x00\x28\x00\x14\x00\x28\x00\x25\x00\x26\x00\x27\x00\x05\x00\x2f\x00\x30\x00\x2f\x00\x30\x00\x08\x00\x09\x00\x08\x00\x09\x00\x1c\x00\x0d\x00\x2d\x00\x0d\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x0f\x00\x10\x00\x08\x00\x09\x00\x0c\x00\x0d\x00\x0e\x00\x0d\x00\x0c\x00\x1a\x00\x1b\x00\x1a\x00\x1b\x00\x0a\x00\x0b\x00\x24\x00\x2d\x00\x24\x00\x2e\x00\x28\x00\x23\x00\x28\x00\x20\x00\x21\x00\x0f\x00\x10\x00\x2f\x00\x30\x00\x2f\x00\x30\x00\x24\x00\x0c\x00\x2f\x00\x30\x00\x28\x00\x1a\x00\x1b\x00\x2e\x00\x0f\x00\x10\x00\x29\x00\x2f\x00\x30\x00\x0c\x00\x23\x00\x29\x00\x40\x00\x41\x00\x08\x00\x1a\x00\x1b\x00\x3f\x00\x0f\x00\x10\x00\x0f\x00\x10\x00\x2f\x00\x30\x00\x23\x00\x40\x00\x41\x00\x06\x00\x33\x00\x1a\x00\x1b\x00\x1a\x00\x1b\x00\x42\x00\x16\x00\x02\x00\x2f\x00\x30\x00\x23\x00\x08\x00\x23\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x42\x00\x29\x00\x2a\x00\x2f\x00\x30\x00\x2f\x00\x30\x00\x04\x00\x41\x00\x04\x00\x30\x00\x02\x00\x34\x00\x05\x00\x22\x00\x04\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x2b\x00\x40\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x16\x00\x08\x00\x16\x00\x02\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x41\x00\x40\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x02\x00\x41\x00\x41\x00\x03\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x02\x00\x08\x00\x03\x00\x41\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x42\x00\x03\x00\x08\x00\x03\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x01\x00\x04\x00\x01\x00\x16\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x06\x00\x08\x00\x16\x00\x16\x00\x16\x00\x41\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x41\x00\x36\x00\x42\x00\x41\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x06\x00\x42\x00\x37\x00\x06\x00\x28\x00\x07\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x09\x00\x04\x00\x20\x00\x42\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x07\x00\x36\x00\x02\x00\x18\x00\x16\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x42\x00\x16\x00\x16\x00\x16\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x07\x00\x16\x00\x42\x00\x42\x00\x41\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x08\x00\x08\x00\x08\x00\x02\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x07\x00\x09\x00\x08\x00\x40\x00\x0e\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x08\x00\x41\x00\x40\x00\x16\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x08\x00\x02\x00\x42\x00\x02\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x08\x00\x0a\x00\x02\x00\x08\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x1a\x00\x1b\x00\x1a\x00\x1b\x00\x1e\x00\x1f\x00\x20\x00\x1f\x00\x20\x00\x23\x00\x02\x00\x23\x00\x02\x00\x16\x00\x08\x00\x16\x00\x16\x00\x16\x00\x1a\x00\x1b\x00\x04\x00\x2f\x00\x30\x00\x2f\x00\x30\x00\x21\x00\x22\x00\x23\x00\x1a\x00\x1b\x00\x02\x00\x08\x00\x42\x00\x1a\x00\x1b\x00\x21\x00\x22\x00\x23\x00\x42\x00\x2f\x00\x30\x00\x22\x00\x23\x00\x41\x00\x1a\x00\x1b\x00\x42\x00\x1a\x00\x1b\x00\x2f\x00\x30\x00\x21\x00\x22\x00\x23\x00\x2f\x00\x30\x00\x23\x00\x07\x00\x1a\x00\x1b\x00\x06\x00\x1a\x00\x1b\x00\x1a\x00\x1b\x00\x2f\x00\x30\x00\x23\x00\x2f\x00\x30\x00\x23\x00\x42\x00\x23\x00\x40\x00\x16\x00\x06\x00\x05\x00\x1a\x00\x1b\x00\x2f\x00\x30\x00\x07\x00\x2f\x00\x30\x00\x2f\x00\x30\x00\x23\x00\x1a\x00\x1b\x00\x40\x00\x09\x00\x1a\x00\x1b\x00\x1a\x00\x1b\x00\x04\x00\x23\x00\x19\x00\x2f\x00\x30\x00\x23\x00\x05\x00\x23\x00\x40\x00\x42\x00\x0a\x00\x40\x00\x02\x00\x2f\x00\x30\x00\x1a\x00\x1b\x00\x2f\x00\x30\x00\x2f\x00\x30\x00\x1a\x00\x1b\x00\x03\x00\x23\x00\x1a\x00\x1b\x00\x40\x00\x16\x00\x16\x00\x23\x00\x1a\x00\x1b\x00\x16\x00\x23\x00\x16\x00\x2f\x00\x30\x00\x16\x00\x42\x00\x23\x00\x42\x00\x2f\x00\x30\x00\x42\x00\x01\x00\x2f\x00\x30\x00\x1a\x00\x1b\x00\x1a\x00\x1b\x00\x2f\x00\x30\x00\x1a\x00\x1b\x00\x42\x00\x23\x00\x42\x00\x23\x00\x05\x00\x03\x00\x05\x00\x23\x00\x1a\x00\x1b\x00\x07\x00\x04\x00\x42\x00\x2f\x00\x30\x00\x2f\x00\x30\x00\x23\x00\x08\x00\x2f\x00\x30\x00\x2e\x00\x1a\x00\x1b\x00\x1a\x00\x1b\x00\x1a\x00\x1b\x00\x16\x00\x2f\x00\x30\x00\x23\x00\x2e\x00\x23\x00\x40\x00\x23\x00\x02\x00\x40\x00\x16\x00\x16\x00\x1a\x00\x1b\x00\x16\x00\x2f\x00\x30\x00\x2f\x00\x30\x00\x2f\x00\x30\x00\x23\x00\x1a\x00\x1b\x00\x02\x00\x16\x00\x1a\x00\x1b\x00\x1a\x00\x1b\x00\x16\x00\x23\x00\x16\x00\x2f\x00\x30\x00\x23\x00\x16\x00\x23\x00\x16\x00\x03\x00\x40\x00\x40\x00\x02\x00\x2f\x00\x30\x00\x1a\x00\x1b\x00\x2f\x00\x30\x00\x2f\x00\x30\x00\x1a\x00\x1b\x00\x2c\x00\x23\x00\x1a\x00\x1b\x00\x40\x00\x40\x00\x40\x00\x23\x00\x1a\x00\x1b\x00\x40\x00\x23\x00\x40\x00\x2f\x00\x30\x00\x40\x00\x07\x00\x23\x00\x40\x00\x2f\x00\x30\x00\x07\x00\x07\x00\x2f\x00\x30\x00\x1a\x00\x1b\x00\x41\x00\x07\x00\x2f\x00\x30\x00\x07\x00\x07\x00\x07\x00\x23\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x2f\x00\x30\x00\x40\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\x07\x00\xff\xff\x44\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\xff\xff\x1a\x00\x1b\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\x2c\x00\x1a\x00\x1b\x00\x2f\x00\x30\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# +happyCheck = HappyA# "\xff\xff\x02\x00\x04\x00\x05\x00\x10\x00\x11\x00\x07\x00\x02\x00\x06\x00\x14\x00\x0b\x00\x03\x00\x06\x00\x0e\x00\x0f\x00\x1d\x00\x1c\x00\x1d\x00\x05\x00\x0f\x00\x08\x00\x01\x00\x2f\x00\x25\x00\x31\x00\x25\x00\x13\x00\x07\x00\x02\x00\x27\x00\x28\x00\x29\x00\x08\x00\x07\x00\x16\x00\x31\x00\x32\x00\x31\x00\x32\x00\x03\x00\x20\x00\x21\x00\x14\x00\x00\x00\x01\x00\x02\x00\x16\x00\x31\x00\x32\x00\x2c\x00\x07\x00\x08\x00\x2c\x00\x0a\x00\x13\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x29\x00\x42\x00\x3f\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x07\x00\x31\x00\x32\x00\x40\x00\x34\x00\x35\x00\x2c\x00\x0e\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x07\x00\x31\x00\x32\x00\x22\x00\x0b\x00\x16\x00\x17\x00\x0e\x00\x0f\x00\x2c\x00\x2d\x00\x2e\x00\x18\x00\x07\x00\x31\x00\x32\x00\x17\x00\x0b\x00\x2d\x00\x2e\x00\x0e\x00\x0f\x00\x31\x00\x32\x00\x19\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x12\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x04\x00\x05\x00\x16\x00\x17\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x00\x00\x01\x00\x02\x00\x27\x00\x28\x00\x29\x00\x12\x00\x07\x00\x08\x00\x19\x00\x0a\x00\x09\x00\x0a\x00\x09\x00\x0a\x00\x1a\x00\x0e\x00\x1b\x00\x0e\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x09\x00\x0a\x00\x29\x00\x09\x00\x0a\x00\x0e\x00\x1f\x00\x41\x00\x0e\x00\x31\x00\x32\x00\x0c\x00\x0d\x00\x0e\x00\x26\x00\x06\x00\x26\x00\x06\x00\x2a\x00\x15\x00\x2a\x00\x31\x00\x32\x00\x31\x00\x32\x00\x31\x00\x32\x00\x31\x00\x32\x00\x26\x00\x09\x00\x0a\x00\x26\x00\x2a\x00\x1f\x00\x0e\x00\x2a\x00\x0b\x00\x0c\x00\x06\x00\x31\x00\x32\x00\x0d\x00\x31\x00\x32\x00\x09\x00\x0a\x00\x09\x00\x0a\x00\x1e\x00\x0e\x00\x2f\x00\x0e\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x26\x00\x09\x00\x0a\x00\x1e\x00\x2a\x00\x2f\x00\x0e\x00\x03\x00\x1a\x00\x1b\x00\x3f\x00\x31\x00\x32\x00\x0b\x00\x0c\x00\x26\x00\x0d\x00\x26\x00\x2b\x00\x2a\x00\x30\x00\x2a\x00\x0d\x00\x10\x00\x11\x00\x0d\x00\x31\x00\x32\x00\x31\x00\x32\x00\x26\x00\x20\x00\x21\x00\x30\x00\x2a\x00\x1c\x00\x1d\x00\x10\x00\x11\x00\x10\x00\x11\x00\x31\x00\x32\x00\x2b\x00\x25\x00\x06\x00\x1c\x00\x1d\x00\x08\x00\x1c\x00\x1d\x00\x1c\x00\x1d\x00\x10\x00\x11\x00\x25\x00\x31\x00\x32\x00\x25\x00\x42\x00\x25\x00\x40\x00\x41\x00\x02\x00\x16\x00\x1c\x00\x1d\x00\x31\x00\x32\x00\x04\x00\x31\x00\x32\x00\x31\x00\x32\x00\x25\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x33\x00\x29\x00\x2a\x00\x40\x00\x41\x00\x31\x00\x32\x00\x08\x00\x2c\x00\x2d\x00\x2e\x00\x42\x00\x34\x00\x31\x00\x32\x00\x02\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x02\x00\x40\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x02\x00\x41\x00\x30\x00\x04\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x02\x00\x02\x00\x05\x00\x40\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x04\x00\x03\x00\x16\x00\x16\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x08\x00\x41\x00\x41\x00\x03\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x06\x00\x41\x00\x03\x00\x42\x00\x41\x00\x08\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x08\x00\x01\x00\x04\x00\x01\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x06\x00\x16\x00\x16\x00\x08\x00\x41\x00\x16\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x41\x00\x41\x00\x16\x00\x42\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x07\x00\x42\x00\x36\x00\x06\x00\x37\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x28\x00\x07\x00\x09\x00\x04\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x07\x00\x20\x00\x42\x00\x36\x00\x02\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x02\x00\x16\x00\x16\x00\x16\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x07\x00\x16\x00\x42\x00\x42\x00\x42\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x41\x00\x08\x00\x02\x00\x02\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x08\x00\x08\x00\x08\x00\x18\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x08\x00\x02\x00\x08\x00\x16\x00\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x1c\x00\x1d\x00\x40\x00\x09\x00\x20\x00\x21\x00\x22\x00\x1c\x00\x1d\x00\x25\x00\x40\x00\x20\x00\x21\x00\x22\x00\x1c\x00\x1d\x00\x25\x00\x0e\x00\x20\x00\x21\x00\x22\x00\x31\x00\x32\x00\x25\x00\x40\x00\x1c\x00\x1d\x00\x41\x00\x31\x00\x32\x00\x21\x00\x22\x00\x1c\x00\x1d\x00\x25\x00\x31\x00\x32\x00\x16\x00\x0a\x00\x23\x00\x24\x00\x25\x00\x1c\x00\x1d\x00\x08\x00\x02\x00\x31\x00\x32\x00\x08\x00\x23\x00\x24\x00\x25\x00\x02\x00\x31\x00\x32\x00\x06\x00\x42\x00\x41\x00\x1c\x00\x1d\x00\x1c\x00\x1d\x00\x06\x00\x31\x00\x32\x00\x23\x00\x24\x00\x25\x00\x24\x00\x25\x00\x02\x00\x08\x00\x42\x00\x16\x00\x1c\x00\x1d\x00\x1c\x00\x1d\x00\x04\x00\x31\x00\x32\x00\x31\x00\x32\x00\x25\x00\x08\x00\x25\x00\x42\x00\x16\x00\x16\x00\x16\x00\x1c\x00\x1d\x00\x1c\x00\x1d\x00\x16\x00\x31\x00\x32\x00\x31\x00\x32\x00\x25\x00\x42\x00\x25\x00\x07\x00\x42\x00\x42\x00\x40\x00\x1c\x00\x1d\x00\x1c\x00\x1d\x00\x05\x00\x31\x00\x32\x00\x31\x00\x32\x00\x25\x00\x40\x00\x25\x00\x07\x00\x40\x00\x04\x00\x40\x00\x1c\x00\x1d\x00\x1c\x00\x1d\x00\x09\x00\x31\x00\x32\x00\x31\x00\x32\x00\x25\x00\x19\x00\x25\x00\x05\x00\x0a\x00\x05\x00\x07\x00\x1c\x00\x1d\x00\x1c\x00\x1d\x00\x05\x00\x31\x00\x32\x00\x31\x00\x32\x00\x25\x00\x40\x00\x25\x00\x04\x00\x03\x00\x42\x00\x42\x00\x1c\x00\x1d\x00\x1c\x00\x1d\x00\x16\x00\x31\x00\x32\x00\x31\x00\x32\x00\x25\x00\x42\x00\x25\x00\x42\x00\x16\x00\x42\x00\x16\x00\x1c\x00\x1d\x00\x1c\x00\x1d\x00\x16\x00\x31\x00\x32\x00\x31\x00\x32\x00\x25\x00\x01\x00\x25\x00\x40\x00\x16\x00\x03\x00\x2e\x00\x1c\x00\x1d\x00\x1c\x00\x1d\x00\x16\x00\x31\x00\x32\x00\x31\x00\x32\x00\x25\x00\x08\x00\x25\x00\x40\x00\x40\x00\x16\x00\x2e\x00\x1c\x00\x1d\x00\x1c\x00\x1d\x00\x16\x00\x31\x00\x32\x00\x31\x00\x32\x00\x25\x00\x02\x00\x25\x00\x40\x00\x16\x00\x16\x00\x16\x00\x1c\x00\x1d\x00\x1c\x00\x1d\x00\x16\x00\x31\x00\x32\x00\x31\x00\x32\x00\x25\x00\x40\x00\x25\x00\x40\x00\x40\x00\x02\x00\x40\x00\x1c\x00\x1d\x00\x1c\x00\x1d\x00\x16\x00\x31\x00\x32\x00\x31\x00\x32\x00\x25\x00\x40\x00\x25\x00\x40\x00\x03\x00\x16\x00\x40\x00\x1c\x00\x1d\x00\x1c\x00\x1d\x00\x02\x00\x31\x00\x32\x00\x31\x00\x32\x00\x25\x00\x07\x00\x25\x00\x2c\x00\x41\x00\x07\x00\x40\x00\x1c\x00\x1d\x00\x1c\x00\x1d\x00\x07\x00\x31\x00\x32\x00\x31\x00\x32\x00\x25\x00\x07\x00\x25\x00\x07\x00\x07\x00\x07\x00\x40\x00\x1c\x00\x1d\x00\x1c\x00\x1d\x00\x07\x00\x31\x00\x32\x00\x31\x00\x32\x00\x25\x00\xff\xff\x25\x00\xff\xff\x44\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x31\x00\x32\x00\x31\x00\x32\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x15\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\xff\xff\xff\xff\x1a\x00\x1b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# happyTable :: HappyAddr -happyTable = HappyA# "\x00\x00\x6a\x00\x64\x01\x79\x00\x73\x00\x49\x00\x6b\x00\x7a\x00\xa6\x00\x7b\x01\x6c\x00\x2f\x00\x71\x01\x6d\x00\x6e\x00\xfd\x00\x66\x00\x6d\x01\xe7\x00\x48\x01\xff\x00\x00\x01\x47\x01\x66\x00\x67\x00\x79\x01\xab\x00\x6f\x01\x7f\x00\xd5\x00\x7b\x00\x67\x00\x60\x01\x80\x00\x7c\x00\xd6\x00\x68\x00\x09\x00\x62\x01\x7a\x01\xac\x00\x7d\x00\x09\x00\x68\x00\x09\x00\x2c\x00\x03\x00\x04\x00\x4a\x00\x4b\x00\x5a\x01\x05\x00\x06\x00\x30\x00\x07\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x11\x00\xa7\x00\x72\x01\x81\x00\x82\x00\x83\x00\x84\xff\x6b\x00\x84\xff\x84\x00\x24\x00\x13\x00\x85\x00\xfa\x00\x6d\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x86\x00\x87\x00\xdf\x00\x08\x00\x09\x00\x3f\x01\x6c\x00\xfd\x00\x66\x00\x6d\x00\x6e\x00\x49\x01\xff\x00\x00\x01\x5d\x01\x6b\x00\x67\x00\x5f\x01\xe0\x00\x6c\x00\xfb\x00\xfc\x00\x6d\x00\x6e\x00\x45\x01\xb4\x00\x3e\x00\x3f\x00\x68\x00\x09\x00\x40\x00\x09\x00\x41\x01\x34\x01\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x42\x01\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x48\x00\x49\x00\x33\x01\x34\x01\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x02\x00\x03\x00\x04\x00\x28\x01\xe2\x00\xe3\x00\x05\x00\x06\x00\xf1\x00\x07\x00\x65\x01\x79\x00\x5c\x01\x79\x00\xfc\x00\x7a\x00\x19\x01\x7a\x00\x75\x00\x3f\x00\xc0\x00\x09\x00\x40\x00\x09\x00\x67\x00\x25\x01\x79\x00\xea\x00\x79\x00\xe9\x00\x7a\x00\xea\x00\x7a\x00\x22\x01\x4a\x00\x4b\x00\x68\x00\x09\x00\x7b\x00\x14\x01\x7b\x00\xba\x00\x7c\x00\xd8\x00\x7c\x00\x47\x00\x1e\x00\x08\x00\x09\x00\x7d\x00\x09\x00\x7d\x00\x09\x00\x7b\x00\x2a\x00\x7b\x00\x98\x00\x7c\x00\xd6\x00\x7c\x00\xe1\x00\xe2\x00\xe3\x00\xad\x00\x7d\x00\x09\x00\x7d\x00\x09\x00\xeb\x00\x79\x00\x78\x00\x79\x00\x9a\x00\x7a\x00\x42\x00\x7a\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x23\x01\xdc\x00\xaf\x00\x79\x00\x89\x00\x8a\x00\x8b\x00\x7a\x00\x50\x00\x93\x00\x94\x00\xdd\x00\x66\x00\x1d\x00\x1e\x00\x7b\x00\x58\x00\x7b\x00\x2d\x00\x7c\x00\x67\x00\x7c\x00\xfb\x00\xfc\x00\x24\x01\xdc\x00\x7d\x00\x09\x00\x7d\x00\x09\x00\x7b\x00\x22\x00\x68\x00\x09\x00\x7c\x00\xdd\x00\x66\x00\x41\x00\xf5\x00\xdc\x00\x1b\x00\x7d\x00\x09\x00\x2a\x00\x67\x00\x2b\x00\xe5\x00\xe6\x00\x7d\x01\xdd\x00\x66\x00\x72\x01\xf6\x00\xf7\x00\xdb\x00\xdc\x00\x68\x00\x09\x00\x67\x00\x20\x00\x21\x00\x75\x01\x76\x01\xf8\x00\x66\x00\xdd\x00\x66\x00\x7b\x01\x74\x01\x77\x01\x68\x00\x09\x00\x67\x00\x78\x01\x67\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x6a\x01\x11\x00\x12\x00\x68\x00\x09\x00\x68\x00\x09\x00\x6c\x01\x6b\x01\x6d\x01\x6f\x01\x73\x01\x13\x00\x62\x01\x4d\x00\x64\x01\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x4e\x00\x1b\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x67\x01\x69\x01\x68\x01\x4d\x01\x4f\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x57\x01\x50\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x2b\x01\x58\x01\x59\x01\x5a\x01\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\xa2\x00\x4b\x01\x5c\x01\x5f\x01\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x41\x01\x1e\x01\x4c\x01\x4e\x01\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x4f\x01\x50\x01\x52\x01\x51\x01\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x2a\x01\x53\x01\x54\x01\x55\x01\x56\x01\x3c\x01\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x3d\x01\x36\x01\x3e\x01\x3f\x01\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x09\x01\x41\x01\x44\x01\x45\x01\x47\x01\x2e\x01\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x30\x01\x31\x01\xfb\x00\x33\x01\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x2f\x01\x36\x01\x37\x01\x1f\x01\x38\x01\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x16\x01\x39\x01\x3a\x01\x3b\x01\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xda\x00\x20\x01\x17\x01\x18\x01\x19\x01\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x1b\x01\x1d\x01\x21\x01\x23\x01\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x88\x00\x28\x01\x27\x01\x2d\x01\xee\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\xf4\x00\xef\x00\xe5\x00\xf3\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xbf\x00\xf5\x00\x03\x01\x02\x01\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x06\x01\x0a\x01\x0b\x01\x0c\x01\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\xfd\x00\x66\x00\xfd\x00\x66\x00\xfe\x00\xff\x00\x00\x01\x31\x01\x00\x01\x67\x00\x0d\x01\x67\x00\x0e\x01\x0f\x01\x12\x01\x10\x01\x11\x01\x13\x01\xd1\x00\x66\x00\xb1\x00\x68\x00\x09\x00\x68\x00\x09\x00\x04\x01\xd3\x00\x67\x00\xd1\x00\x66\x00\x14\x01\xb3\x00\xb4\x00\xd1\x00\x66\x00\x07\x01\xd3\x00\x67\x00\xb6\x00\x68\x00\x09\x00\x1b\x01\x67\x00\xba\x00\xd1\x00\x66\x00\xb7\x00\x2b\x01\x66\x00\x68\x00\x09\x00\xd2\x00\xd3\x00\x67\x00\x68\x00\x09\x00\x67\x00\xc0\x00\xef\x00\x66\x00\xb9\x00\xf0\x00\x66\x00\x03\x01\x66\x00\x68\x00\x09\x00\x67\x00\x68\x00\x09\x00\x67\x00\xb8\x00\x67\x00\xbd\x00\xaf\x00\xbc\x00\xd8\x00\xb1\x00\x66\x00\x68\x00\x09\x00\xda\x00\x68\x00\x09\x00\x68\x00\x09\x00\x67\x00\xbd\x00\x66\x00\xe1\x00\xe8\x00\xc1\x00\x66\x00\xc2\x00\x66\x00\xed\x00\x67\x00\x9a\x00\x68\x00\x09\x00\x67\x00\xa0\x00\x67\x00\x9d\x00\xa3\x00\xa1\x00\xa4\x00\xa5\x00\x68\x00\x09\x00\xc3\x00\x66\x00\x68\x00\x09\x00\x68\x00\x09\x00\xc4\x00\x66\x00\x5a\x00\x67\x00\xc5\x00\x66\x00\x5b\x00\xa8\x00\xa9\x00\x67\x00\xc6\x00\x66\x00\xaa\x00\x67\x00\xad\x00\x68\x00\x09\x00\xaf\x00\x5c\x00\x67\x00\x5d\x00\x68\x00\x09\x00\x5e\x00\x61\x00\x68\x00\x09\x00\xc7\x00\x66\x00\xc8\x00\x66\x00\x68\x00\x09\x00\xc9\x00\x66\x00\x5f\x00\x67\x00\x60\x00\x67\x00\x62\x00\x78\x00\x65\x00\x67\x00\xca\x00\x66\x00\x64\x00\x75\x00\x63\x00\x68\x00\x09\x00\x68\x00\x09\x00\x67\x00\x47\x00\x68\x00\x09\x00\x44\x00\xcb\x00\x66\x00\xcc\x00\x66\x00\xcd\x00\x66\x00\x46\x00\x68\x00\x09\x00\x67\x00\x44\x00\x67\x00\x45\x00\x67\x00\x31\x00\x24\x00\x52\x00\x53\x00\xce\x00\x66\x00\x54\x00\x68\x00\x09\x00\x68\x00\x09\x00\x68\x00\x09\x00\x67\x00\xcf\x00\x66\x00\x39\x00\x55\x00\xd0\x00\x66\x00\xda\x00\x66\x00\x56\x00\x67\x00\x57\x00\x68\x00\x09\x00\x67\x00\x38\x00\x67\x00\x3c\x00\x3a\x00\x58\x00\x32\x00\x3d\x00\x68\x00\x09\x00\x9b\x00\x66\x00\x68\x00\x09\x00\x68\x00\x09\x00\x9d\x00\x66\x00\x30\x00\x67\x00\x9e\x00\x66\x00\x33\x00\x34\x00\x35\x00\x67\x00\x65\x00\x66\x00\x36\x00\x67\x00\x37\x00\x68\x00\x09\x00\x3b\x00\x1d\x00\x67\x00\x24\x00\x68\x00\x09\x00\x25\x00\x26\x00\x68\x00\x09\x00\x76\x00\x66\x00\x22\x00\x27\x00\x68\x00\x09\x00\x28\x00\x29\x00\x2a\x00\x67\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x07\x01\x68\x00\x09\x00\x24\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\xaf\x00\x1d\x00\x00\x00\xff\xff\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x00\x00\x00\x00\x00\x00\x00\x00\x93\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x93\x00\x94\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x89\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x00\x00\x93\x00\x94\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x3f\x00\x93\x00\x94\x00\x40\x00\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# +happyTable = HappyA# "\x00\x00\x9e\x00\x9e\x00\x5c\x00\x23\x01\xd6\x00\x67\x00\x2f\x00\xb5\x00\x7f\x01\x68\x00\xf4\x00\x75\x01\x69\x00\x6a\x00\x19\x01\xd7\x00\x63\x00\xe1\x00\x71\x01\x7d\x01\xcf\x00\xe3\x00\x64\x00\xe4\x00\x64\x00\x62\x01\xd0\x00\x77\x00\x28\x01\xdc\x00\xdd\x00\xa4\x00\x78\x00\x7e\x01\x65\x00\x09\x00\x65\x00\x09\x00\x5b\x01\xf5\x00\xf6\x00\x73\x01\x2c\x00\x03\x00\x04\x00\xa5\x00\x5d\x00\x5e\x00\x30\x00\x05\x00\x06\x00\xf7\x00\x07\x00\x64\x01\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x11\x00\xb6\x00\x76\x01\x79\x00\x7a\x00\x7b\x00\x82\xff\x67\x00\x82\xff\x7c\x00\x24\x00\x13\x00\x7d\x00\x5c\x01\x69\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x7e\x00\x7f\x00\xd9\x00\x08\x00\x09\x00\x60\x00\x68\x00\x41\x01\x34\x01\x69\x00\x6a\x00\xad\x00\x3e\x00\x3f\x00\x59\x01\x67\x00\x40\x00\x09\x00\xda\x00\x68\x00\x61\x00\x3f\x00\x69\x00\x6a\x00\x40\x00\x09\x00\x5c\x01\x61\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x5f\x01\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x5b\x00\x5c\x00\x33\x01\x34\x01\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x02\x00\x03\x00\x04\x00\xdb\x00\xdc\x00\xdd\x00\x61\x01\x05\x00\x06\x00\x3f\x01\x07\x00\x66\x01\x71\x00\x68\x01\x71\x00\x42\x01\x72\x00\x45\x01\x72\x00\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x5e\x01\x71\x00\xeb\x00\x25\x01\x71\x00\x72\x00\xf7\x00\x21\x01\x72\x00\x5d\x00\x5e\x00\x8a\x00\x8b\x00\x8c\x00\x73\x00\x07\x01\x73\x00\x0f\x01\x74\x00\xd0\x00\x74\x00\xcd\x00\x09\x00\x08\x00\x09\x00\x75\x00\x09\x00\x75\x00\x09\x00\x73\x00\xe4\x00\x71\x00\x73\x00\x74\x00\xd2\x00\x72\x00\x74\x00\x47\x00\x1e\x00\xa6\x00\x75\x00\x09\x00\x2a\x00\x75\x00\x09\x00\xe5\x00\x71\x00\x70\x00\x71\x00\x7f\x00\x72\x00\x42\x00\x72\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x73\x00\xa8\x00\x71\x00\x81\x00\x74\x00\x52\x00\x72\x00\x48\x00\x94\x00\x95\x00\x76\x01\x75\x00\x09\x00\x1d\x00\x1e\x00\x73\x00\x4a\x00\x73\x00\x1b\x00\x74\x00\x2d\x00\x74\x00\x22\x00\x24\x01\xd6\x00\x2a\x00\x75\x00\x09\x00\x75\x00\x09\x00\x73\x00\xf5\x00\xf6\x00\x41\x00\x74\x00\xd7\x00\x63\x00\xef\x00\xd6\x00\xf0\x00\xf1\x00\x75\x00\x09\x00\x2b\x00\x64\x00\x79\x01\x47\x01\x63\x00\x81\x01\xd7\x00\x63\x00\xf2\x00\x63\x00\xd5\x00\xd6\x00\x64\x00\x65\x00\x09\x00\x64\x00\x7f\x01\x64\x00\xdf\x00\xe0\x00\x7b\x01\x78\x01\xd7\x00\x63\x00\x65\x00\x09\x00\x6f\x01\x65\x00\x09\x00\x65\x00\x09\x00\x64\x00\x0b\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x7a\x01\x11\x00\x12\x00\x20\x00\x21\x00\x65\x00\x09\x00\x7c\x01\x3d\x00\x3e\x00\x3f\x00\x6d\x01\x13\x00\x40\x00\x09\x00\x4d\x01\x14\x00\x15\x00\x16\x00\x17\x00\x18\x00\x19\x00\x1a\x00\x70\x01\x1b\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x2b\x01\x6e\x01\x73\x01\x71\x01\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\xb2\x00\x77\x01\x64\x01\x68\x01\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x66\x01\x1d\x01\x6a\x01\x6b\x01\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x6c\x01\x57\x01\x58\x01\x5e\x01\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x2a\x01\x59\x01\x4e\x01\x41\x01\x61\x01\x4b\x01\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x4c\x01\x4f\x01\x50\x01\x52\x01\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x02\x01\x51\x01\x54\x01\x53\x01\x3c\x01\x55\x01\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x3d\x01\x3f\x01\x56\x01\x3e\x01\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x2f\x01\x41\x01\x36\x01\x45\x01\x44\x01\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x47\x01\x2e\x01\x30\x01\x31\x01\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\xd4\x00\xf5\x00\x33\x01\x36\x01\x37\x01\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x15\x01\x38\x01\x39\x01\x3a\x01\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x89\x00\x3b\x01\x11\x01\x12\x01\x13\x01\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x14\x01\x16\x01\x17\x01\x18\x01\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\xcc\x00\x1b\x01\x1c\x01\x1e\x01\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x20\x01\x22\x01\x27\x01\x1f\x01\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\xf8\x00\x63\x00\x23\x01\x28\x01\x48\x01\xfa\x00\xfb\x00\xf8\x00\x63\x00\x64\x00\x2d\x01\x49\x01\xfa\x00\xfb\x00\xf8\x00\x63\x00\x64\x00\xe8\x00\xf9\x00\xfa\x00\xfb\x00\x65\x00\x09\x00\x64\x00\xdf\x00\xf8\x00\x63\x00\xe9\x00\x65\x00\x09\x00\x31\x01\xfb\x00\xc6\x00\x63\x00\x64\x00\x65\x00\x09\x00\xed\x00\x03\x01\xff\x00\xc8\x00\x64\x00\xc6\x00\x63\x00\xee\x00\xef\x00\x65\x00\x09\x00\x04\x01\x00\x01\xc8\x00\x64\x00\xfd\x00\x65\x00\x09\x00\x06\x01\xfe\x00\x07\x01\xc6\x00\x63\x00\xc6\x00\x63\x00\x09\x01\x65\x00\x09\x00\xc7\x00\xc8\x00\x64\x00\x18\x01\x64\x00\x0f\x01\x0d\x01\xad\x00\xa8\x00\x2b\x01\x63\x00\xe9\x00\x63\x00\xaa\x00\x65\x00\x09\x00\x65\x00\x09\x00\x64\x00\xac\x00\x64\x00\xaf\x00\x0a\x01\x0b\x01\x0c\x01\xea\x00\x63\x00\xfe\x00\x63\x00\x0e\x01\x65\x00\x09\x00\x65\x00\x09\x00\x64\x00\xb0\x00\x64\x00\xcd\x00\xb1\x00\xb3\x00\xb4\x00\xaa\x00\x63\x00\xb6\x00\x63\x00\xd2\x00\x65\x00\x09\x00\x65\x00\x09\x00\x64\x00\xca\x00\x64\x00\xd4\x00\xdb\x00\xe7\x00\x84\x00\xb7\x00\x63\x00\xb8\x00\x63\x00\xe2\x00\x65\x00\x09\x00\x65\x00\x09\x00\x64\x00\x81\x00\x64\x00\x87\x00\x88\x00\x9a\x00\x9b\x00\xb9\x00\x63\x00\xba\x00\x63\x00\x9c\x00\x65\x00\x09\x00\x65\x00\x09\x00\x64\x00\x55\x00\x64\x00\xa0\x00\x54\x00\x56\x00\x57\x00\xbb\x00\x63\x00\xbc\x00\x63\x00\xa1\x00\x65\x00\x09\x00\x65\x00\x09\x00\x64\x00\x58\x00\x64\x00\x59\x00\xa2\x00\x5a\x00\xa3\x00\xbd\x00\x63\x00\xbe\x00\x63\x00\xa6\x00\x65\x00\x09\x00\x65\x00\x09\x00\x64\x00\x5b\x00\x64\x00\x45\x00\xa8\x00\x70\x00\x44\x00\xbf\x00\x63\x00\xc0\x00\x63\x00\x46\x00\x65\x00\x09\x00\x65\x00\x09\x00\x64\x00\x47\x00\x64\x00\x4a\x00\x24\x00\x4c\x00\x44\x00\xc1\x00\x63\x00\xc2\x00\x63\x00\x4d\x00\x65\x00\x09\x00\x65\x00\x09\x00\x64\x00\x31\x00\x64\x00\x52\x00\x4e\x00\x4f\x00\x50\x00\xc3\x00\x63\x00\xc4\x00\x63\x00\x51\x00\x65\x00\x09\x00\x65\x00\x09\x00\x64\x00\x32\x00\x64\x00\x33\x00\x34\x00\x39\x00\x35\x00\xc5\x00\x63\x00\xca\x00\x63\x00\x38\x00\x65\x00\x09\x00\x65\x00\x09\x00\x64\x00\x36\x00\x64\x00\x37\x00\x3a\x00\x3c\x00\x3b\x00\xd4\x00\x63\x00\x82\x00\x63\x00\x3d\x00\x65\x00\x09\x00\x65\x00\x09\x00\x64\x00\x1d\x00\x64\x00\x30\x00\x22\x00\x25\x00\x24\x00\x84\x00\x63\x00\x85\x00\x63\x00\x26\x00\x65\x00\x09\x00\x65\x00\x09\x00\x64\x00\x27\x00\x64\x00\x28\x00\x29\x00\x2a\x00\x24\x00\x9c\x00\x63\x00\x62\x00\x63\x00\x1d\x00\x65\x00\x09\x00\x65\x00\x09\x00\x64\x00\x00\x00\x64\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x65\x00\x09\x00\x65\x00\x09\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x05\x01\x00\x00\x00\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x95\x00\x96\x00\x97\x00\x98\x00\x99\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x95\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\x8e\x00\x00\x00\x00\x00\x94\x00\x95\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x95\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# -happyReduceArr = Happy_Data_Array.array (1, 152) [ +happyReduceArr = Happy_Data_Array.array (1, 154) [ (1 , happyReduce_1), (2 , happyReduce_2), (3 , happyReduce_3), @@ -553,11 +558,13 @@ (149 , happyReduce_149), (150 , happyReduce_150), (151 , happyReduce_151), - (152 , happyReduce_152) + (152 , happyReduce_152), + (153 , happyReduce_153), + (154 , happyReduce_154) ] happy_n_terms = 69 :: Int -happy_n_nonterms = 49 :: Int +happy_n_nonterms = 51 :: Int happyReduce_1 = happySpecReduce_0 0# happyReduction_1 happyReduction_1 = happyIn4 @@ -575,7 +582,7 @@ happyReduce_3 = happySpecReduce_1 1# happyReduction_3 happyReduction_3 happy_x_1 - = case happyOut10 happy_x_1 of { happy_var_1 -> + = case happyOut11 happy_x_1 of { happy_var_1 -> happyIn5 (happy_var_1 )} @@ -589,7 +596,7 @@ happyReduce_5 = happySpecReduce_1 1# happyReduction_5 happyReduction_5 happy_x_1 - = case happyOut13 happy_x_1 of { happy_var_1 -> + = case happyOut14 happy_x_1 of { happy_var_1 -> happyIn5 (happy_var_1 )} @@ -606,14 +613,15 @@ happyRest) tk = happyThen (case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> case happyOutTok happy_x_5 of { (L _ (CmmT_Name happy_var_5)) -> - case happyOut9 happy_x_6 of { happy_var_6 -> + case happyOut10 happy_x_6 of { happy_var_6 -> ( withThisPackage $ \pkg -> do lits <- sequence happy_var_6; staticClosure pkg happy_var_3 happy_var_5 (map getLit lits))}}} ) (\r -> happyReturn (happyIn5 r)) -happyReduce_7 = happyReduce 5# 2# happyReduction_7 -happyReduction_7 (happy_x_5 `HappyStk` +happyReduce_7 = happyReduce 6# 2# happyReduction_7 +happyReduction_7 (happy_x_6 `HappyStk` + happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` @@ -621,54 +629,56 @@ happyRest) = case happyOutTok happy_x_2 of { (L _ (CmmT_String happy_var_2)) -> case happyOut7 happy_x_4 of { happy_var_4 -> + case happyOut8 happy_x_5 of { happy_var_5 -> happyIn6 - (do ss <- sequence happy_var_4; - code (emitData (section happy_var_2) (concat ss)) - ) `HappyStk` happyRest}} + (do lbl <- happy_var_4; + ss <- sequence happy_var_5; + code (emitData (section happy_var_2) (Statics lbl $ concat ss)) + ) `HappyStk` happyRest}}} + +happyReduce_8 = happyMonadReduce 2# 3# happyReduction_8 +happyReduction_8 (happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> + ( withThisPackage $ \pkg -> + return (mkCmmDataLabel pkg happy_var_1))} + ) (\r -> happyReturn (happyIn7 r)) -happyReduce_8 = happySpecReduce_0 3# happyReduction_8 -happyReduction_8 = happyIn7 +happyReduce_9 = happySpecReduce_0 4# happyReduction_9 +happyReduction_9 = happyIn8 ([] ) -happyReduce_9 = happySpecReduce_2 3# happyReduction_9 -happyReduction_9 happy_x_2 +happyReduce_10 = happySpecReduce_2 4# happyReduction_10 +happyReduction_10 happy_x_2 happy_x_1 - = case happyOut8 happy_x_1 of { happy_var_1 -> - case happyOut7 happy_x_2 of { happy_var_2 -> - happyIn7 + = case happyOut9 happy_x_1 of { happy_var_1 -> + case happyOut8 happy_x_2 of { happy_var_2 -> + happyIn8 (happy_var_1 : happy_var_2 )}} -happyReduce_10 = happyMonadReduce 2# 4# happyReduction_10 -happyReduction_10 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen (case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> - ( withThisPackage $ \pkg -> - return [CmmDataLabel (mkCmmDataLabel pkg happy_var_1)])} - ) (\r -> happyReturn (happyIn8 r)) - -happyReduce_11 = happySpecReduce_3 4# happyReduction_11 +happyReduce_11 = happySpecReduce_3 5# happyReduction_11 happyReduction_11 happy_x_3 happy_x_2 happy_x_1 - = case happyOut30 happy_x_2 of { happy_var_2 -> - happyIn8 + = case happyOut32 happy_x_2 of { happy_var_2 -> + happyIn9 (do e <- happy_var_2; return [CmmStaticLit (getLit e)] )} -happyReduce_12 = happySpecReduce_2 4# happyReduction_12 +happyReduce_12 = happySpecReduce_2 5# happyReduction_12 happyReduction_12 happy_x_2 happy_x_1 - = case happyOut51 happy_x_1 of { happy_var_1 -> - happyIn8 + = case happyOut53 happy_x_1 of { happy_var_1 -> + happyIn9 (return [CmmUninitialised (widthInBytes (typeWidth happy_var_1))] )} -happyReduce_13 = happyReduce 5# 4# happyReduction_13 +happyReduce_13 = happyReduce 5# 5# happyReduction_13 happyReduction_13 (happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` @@ -676,11 +686,11 @@ happy_x_1 `HappyStk` happyRest) = case happyOutTok happy_x_4 of { (L _ (CmmT_String happy_var_4)) -> - happyIn8 + happyIn9 (return [mkString happy_var_4] ) `HappyStk` happyRest} -happyReduce_14 = happyReduce 5# 4# happyReduction_14 +happyReduce_14 = happyReduce 5# 5# happyReduction_14 happyReduction_14 (happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` @@ -688,45 +698,36 @@ happy_x_1 `HappyStk` happyRest) = case happyOutTok happy_x_3 of { (L _ (CmmT_Int happy_var_3)) -> - happyIn8 + happyIn9 (return [CmmUninitialised (fromIntegral happy_var_3)] ) `HappyStk` happyRest} -happyReduce_15 = happyReduce 5# 4# happyReduction_15 +happyReduce_15 = happyReduce 5# 5# happyReduction_15 happyReduction_15 (happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) - = case happyOut52 happy_x_1 of { happy_var_1 -> + = case happyOut54 happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_3 of { (L _ (CmmT_Int happy_var_3)) -> - happyIn8 + happyIn9 (return [CmmUninitialised (widthInBytes (typeWidth happy_var_1) * fromIntegral happy_var_3)] ) `HappyStk` happyRest}} -happyReduce_16 = happySpecReduce_3 4# happyReduction_16 -happyReduction_16 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOutTok happy_x_2 of { (L _ (CmmT_Int happy_var_2)) -> - happyIn8 - (return [CmmAlign (fromIntegral happy_var_2)] - )} - -happyReduce_17 = happyReduce 5# 4# happyReduction_17 -happyReduction_17 (happy_x_5 `HappyStk` +happyReduce_16 = happyReduce 5# 5# happyReduction_16 +happyReduction_16 (happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) = case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> - case happyOut9 happy_x_4 of { happy_var_4 -> - happyIn8 + case happyOut10 happy_x_4 of { happy_var_4 -> + happyIn9 (do lits <- sequence happy_var_4; return $ map CmmStaticLit $ mkStaticClosure (mkForeignLabel happy_var_3 Nothing ForeignLabelInExternalPackage IsData) @@ -735,23 +736,23 @@ dontCareCCS (map getLit lits) [] [] [] ) `HappyStk` happyRest}} -happyReduce_18 = happySpecReduce_0 5# happyReduction_18 -happyReduction_18 = happyIn9 +happyReduce_17 = happySpecReduce_0 6# happyReduction_17 +happyReduction_17 = happyIn10 ([] ) -happyReduce_19 = happySpecReduce_3 5# happyReduction_19 -happyReduction_19 happy_x_3 +happyReduce_18 = happySpecReduce_3 6# happyReduction_18 +happyReduction_18 happy_x_3 happy_x_2 happy_x_1 - = case happyOut30 happy_x_2 of { happy_var_2 -> - case happyOut9 happy_x_3 of { happy_var_3 -> - happyIn9 + = case happyOut32 happy_x_2 of { happy_var_2 -> + case happyOut10 happy_x_3 of { happy_var_3 -> + happyIn10 (happy_var_2 : happy_var_3 )}} -happyReduce_20 = happyReduce 7# 6# happyReduction_20 -happyReduction_20 (happy_x_7 `HappyStk` +happyReduce_19 = happyReduce 7# 7# happyReduction_19 +happyReduction_19 (happy_x_7 `HappyStk` happy_x_6 `HappyStk` happy_x_5 `HappyStk` happy_x_4 `HappyStk` @@ -759,12 +760,12 @@ happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) - = case happyOut11 happy_x_1 of { happy_var_1 -> - case happyOut45 happy_x_2 of { happy_var_2 -> - case happyOut50 happy_x_3 of { happy_var_3 -> - case happyOut49 happy_x_4 of { happy_var_4 -> - case happyOut12 happy_x_6 of { happy_var_6 -> - happyIn10 + = case happyOut12 happy_x_1 of { happy_var_1 -> + case happyOut47 happy_x_2 of { happy_var_2 -> + case happyOut52 happy_x_3 of { happy_var_3 -> + case happyOut51 happy_x_4 of { happy_var_4 -> + case happyOut13 happy_x_6 of { happy_var_6 -> + happyIn11 (do ((entry_ret_label, info, live, formals, gc_block, frame), stmts) <- getCgStmtsEC' $ loopDecls $ do { (entry_ret_label, info, live) <- happy_var_1; @@ -777,20 +778,20 @@ code (emitInfoTableAndCode entry_ret_label (CmmInfo gc_block frame info) formals blks) ) `HappyStk` happyRest}}}}} -happyReduce_21 = happySpecReduce_3 6# happyReduction_21 -happyReduction_21 happy_x_3 +happyReduce_20 = happySpecReduce_3 7# happyReduction_20 +happyReduction_20 happy_x_3 happy_x_2 happy_x_1 - = case happyOut11 happy_x_1 of { happy_var_1 -> - case happyOut45 happy_x_2 of { happy_var_2 -> - happyIn10 + = case happyOut12 happy_x_1 of { happy_var_1 -> + case happyOut47 happy_x_2 of { happy_var_2 -> + happyIn11 (do (entry_ret_label, info, live) <- happy_var_1; formals <- sequence happy_var_2; code (emitInfoTableAndCode entry_ret_label (CmmInfo Nothing Nothing info) formals []) )}} -happyReduce_22 = happyMonadReduce 7# 6# happyReduction_22 -happyReduction_22 (happy_x_7 `HappyStk` +happyReduce_21 = happyMonadReduce 7# 7# happyReduction_21 +happyReduction_21 (happy_x_7 `HappyStk` happy_x_6 `HappyStk` happy_x_5 `HappyStk` happy_x_4 `HappyStk` @@ -799,10 +800,10 @@ happy_x_1 `HappyStk` happyRest) tk = happyThen (case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> - case happyOut45 happy_x_2 of { happy_var_2 -> - case happyOut50 happy_x_3 of { happy_var_3 -> - case happyOut49 happy_x_4 of { happy_var_4 -> - case happyOut12 happy_x_6 of { happy_var_6 -> + case happyOut47 happy_x_2 of { happy_var_2 -> + case happyOut52 happy_x_3 of { happy_var_3 -> + case happyOut51 happy_x_4 of { happy_var_4 -> + case happyOut13 happy_x_6 of { happy_var_6 -> ( withThisPackage $ \pkg -> do newFunctionName happy_var_1 pkg ((formals, gc_block, frame), stmts) <- @@ -814,10 +815,10 @@ return (formals, gc_block, frame) } blks <- code (cgStmtsToBlocks stmts) code (emitProc (CmmInfo gc_block frame CmmNonInfoTable) (mkCmmCodeLabel pkg happy_var_1) formals blks))}}}}} - ) (\r -> happyReturn (happyIn10 r)) + ) (\r -> happyReturn (happyIn11 r)) -happyReduce_23 = happyMonadReduce 14# 7# happyReduction_23 -happyReduction_23 (happy_x_14 `HappyStk` +happyReduce_22 = happyMonadReduce 14# 8# happyReduction_22 +happyReduction_22 (happy_x_14 `HappyStk` happy_x_13 `HappyStk` happy_x_12 `HappyStk` happy_x_11 `HappyStk` @@ -841,13 +842,13 @@ ( withThisPackage $ \pkg -> do prof <- profilingInfo happy_var_11 happy_var_13 return (mkCmmEntryLabel pkg happy_var_3, - CmmInfoTable False prof (fromIntegral happy_var_9) + CmmInfoTable (mkCmmInfoLabel pkg happy_var_3) False prof (fromIntegral happy_var_9) (ThunkInfo (fromIntegral happy_var_5, fromIntegral happy_var_7) NoC_SRT), []))}}}}}} - ) (\r -> happyReturn (happyIn11 r)) + ) (\r -> happyReturn (happyIn12 r)) -happyReduce_24 = happyMonadReduce 16# 7# happyReduction_24 -happyReduction_24 (happy_x_16 `HappyStk` +happyReduce_23 = happyMonadReduce 16# 8# happyReduction_23 +happyReduction_23 (happy_x_16 `HappyStk` happy_x_15 `HappyStk` happy_x_14 `HappyStk` happy_x_13 `HappyStk` @@ -874,16 +875,16 @@ ( withThisPackage $ \pkg -> do prof <- profilingInfo happy_var_11 happy_var_13 return (mkCmmEntryLabel pkg happy_var_3, - CmmInfoTable False prof (fromIntegral happy_var_9) + CmmInfoTable (mkCmmInfoLabel pkg happy_var_3) False prof (fromIntegral happy_var_9) (FunInfo (fromIntegral happy_var_5, fromIntegral happy_var_7) NoC_SRT 0 -- Arity zero (ArgSpec (fromIntegral happy_var_15)) zeroCLit), []))}}}}}}} - ) (\r -> happyReturn (happyIn11 r)) + ) (\r -> happyReturn (happyIn12 r)) -happyReduce_25 = happyMonadReduce 18# 7# happyReduction_25 -happyReduction_25 (happy_x_18 `HappyStk` +happyReduce_24 = happyMonadReduce 18# 8# happyReduction_24 +happyReduction_24 (happy_x_18 `HappyStk` happy_x_17 `HappyStk` happy_x_16 `HappyStk` happy_x_15 `HappyStk` @@ -913,15 +914,15 @@ ( withThisPackage $ \pkg -> do prof <- profilingInfo happy_var_11 happy_var_13 return (mkCmmEntryLabel pkg happy_var_3, - CmmInfoTable False prof (fromIntegral happy_var_9) + CmmInfoTable (mkCmmInfoLabel pkg happy_var_3) False prof (fromIntegral happy_var_9) (FunInfo (fromIntegral happy_var_5, fromIntegral happy_var_7) NoC_SRT (fromIntegral happy_var_17) (ArgSpec (fromIntegral happy_var_15)) zeroCLit), []))}}}}}}}} - ) (\r -> happyReturn (happyIn11 r)) + ) (\r -> happyReturn (happyIn12 r)) -happyReduce_26 = happyMonadReduce 16# 7# happyReduction_26 -happyReduction_26 (happy_x_16 `HappyStk` +happyReduce_25 = happyMonadReduce 16# 8# happyReduction_25 +happyReduction_25 (happy_x_16 `HappyStk` happy_x_15 `HappyStk` happy_x_14 `HappyStk` happy_x_13 `HappyStk` @@ -951,13 +952,13 @@ -- but that's the way the old code did it we can fix it some other time. desc_lit <- code $ mkStringCLit happy_var_13 return (mkCmmEntryLabel pkg happy_var_3, - CmmInfoTable False prof (fromIntegral happy_var_11) + CmmInfoTable (mkCmmInfoLabel pkg happy_var_3) False prof (fromIntegral happy_var_11) (ConstrInfo (fromIntegral happy_var_5, fromIntegral happy_var_7) (fromIntegral happy_var_9) desc_lit), []))}}}}}}} - ) (\r -> happyReturn (happyIn11 r)) + ) (\r -> happyReturn (happyIn12 r)) -happyReduce_27 = happyMonadReduce 12# 7# happyReduction_27 -happyReduction_27 (happy_x_12 `HappyStk` +happyReduce_26 = happyMonadReduce 12# 8# happyReduction_26 +happyReduction_26 (happy_x_12 `HappyStk` happy_x_11 `HappyStk` happy_x_10 `HappyStk` happy_x_9 `HappyStk` @@ -978,13 +979,13 @@ ( withThisPackage $ \pkg -> do prof <- profilingInfo happy_var_9 happy_var_11 return (mkCmmEntryLabel pkg happy_var_3, - CmmInfoTable False prof (fromIntegral happy_var_7) + CmmInfoTable (mkCmmInfoLabel pkg happy_var_3) False prof (fromIntegral happy_var_7) (ThunkSelectorInfo (fromIntegral happy_var_5) NoC_SRT), []))}}}}} - ) (\r -> happyReturn (happyIn11 r)) + ) (\r -> happyReturn (happyIn12 r)) -happyReduce_28 = happyMonadReduce 6# 7# happyReduction_28 -happyReduction_28 (happy_x_6 `HappyStk` +happyReduce_27 = happyMonadReduce 6# 8# happyReduction_27 +happyReduction_27 (happy_x_6 `HappyStk` happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` @@ -996,13 +997,13 @@ ( withThisPackage $ \pkg -> do let infoLabel = mkCmmInfoLabel pkg happy_var_3 return (mkCmmRetLabel pkg happy_var_3, - CmmInfoTable False (ProfilingInfo zeroCLit zeroCLit) (fromIntegral happy_var_5) + CmmInfoTable (mkCmmInfoLabel pkg happy_var_3) False (ProfilingInfo zeroCLit zeroCLit) (fromIntegral happy_var_5) (ContInfo [] NoC_SRT), []))}} - ) (\r -> happyReturn (happyIn11 r)) + ) (\r -> happyReturn (happyIn12 r)) -happyReduce_29 = happyMonadReduce 8# 7# happyReduction_29 -happyReduction_29 (happy_x_8 `HappyStk` +happyReduce_28 = happyMonadReduce 8# 8# happyReduction_28 +happyReduction_28 (happy_x_8 `HappyStk` happy_x_7 `HappyStk` happy_x_6 `HappyStk` happy_x_5 `HappyStk` @@ -1013,143 +1014,143 @@ happyRest) tk = happyThen (case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> case happyOutTok happy_x_5 of { (L _ (CmmT_Int happy_var_5)) -> - case happyOut46 happy_x_7 of { happy_var_7 -> + case happyOut48 happy_x_7 of { happy_var_7 -> ( withThisPackage $ \pkg -> do live <- sequence (map (liftM Just) happy_var_7) return (mkCmmRetLabel pkg happy_var_3, - CmmInfoTable False (ProfilingInfo zeroCLit zeroCLit) (fromIntegral happy_var_5) + CmmInfoTable (mkCmmInfoLabel pkg happy_var_3) False (ProfilingInfo zeroCLit zeroCLit) (fromIntegral happy_var_5) (ContInfo live NoC_SRT), live))}}} - ) (\r -> happyReturn (happyIn11 r)) + ) (\r -> happyReturn (happyIn12 r)) -happyReduce_30 = happySpecReduce_0 8# happyReduction_30 -happyReduction_30 = happyIn12 +happyReduce_29 = happySpecReduce_0 9# happyReduction_29 +happyReduction_29 = happyIn13 (return () ) -happyReduce_31 = happySpecReduce_2 8# happyReduction_31 -happyReduction_31 happy_x_2 +happyReduce_30 = happySpecReduce_2 9# happyReduction_30 +happyReduction_30 happy_x_2 happy_x_1 - = case happyOut13 happy_x_1 of { happy_var_1 -> - case happyOut12 happy_x_2 of { happy_var_2 -> - happyIn12 + = case happyOut14 happy_x_1 of { happy_var_1 -> + case happyOut13 happy_x_2 of { happy_var_2 -> + happyIn13 (do happy_var_1; happy_var_2 )}} -happyReduce_32 = happySpecReduce_2 8# happyReduction_32 -happyReduction_32 happy_x_2 +happyReduce_31 = happySpecReduce_2 9# happyReduction_31 +happyReduction_31 happy_x_2 happy_x_1 - = case happyOut17 happy_x_1 of { happy_var_1 -> - case happyOut12 happy_x_2 of { happy_var_2 -> - happyIn12 + = case happyOut18 happy_x_1 of { happy_var_1 -> + case happyOut13 happy_x_2 of { happy_var_2 -> + happyIn13 (do happy_var_1; happy_var_2 )}} -happyReduce_33 = happySpecReduce_3 9# happyReduction_33 -happyReduction_33 happy_x_3 +happyReduce_32 = happySpecReduce_3 10# happyReduction_32 +happyReduction_32 happy_x_3 happy_x_2 happy_x_1 - = case happyOut51 happy_x_1 of { happy_var_1 -> - case happyOut16 happy_x_2 of { happy_var_2 -> - happyIn13 + = case happyOut53 happy_x_1 of { happy_var_1 -> + case happyOut17 happy_x_2 of { happy_var_2 -> + happyIn14 (mapM_ (newLocal happy_var_1) happy_var_2 )}} -happyReduce_34 = happySpecReduce_3 9# happyReduction_34 -happyReduction_34 happy_x_3 +happyReduce_33 = happySpecReduce_3 10# happyReduction_33 +happyReduction_33 happy_x_3 happy_x_2 happy_x_1 - = case happyOut14 happy_x_2 of { happy_var_2 -> - happyIn13 + = case happyOut15 happy_x_2 of { happy_var_2 -> + happyIn14 (mapM_ newImport happy_var_2 )} -happyReduce_35 = happySpecReduce_3 9# happyReduction_35 -happyReduction_35 happy_x_3 +happyReduce_34 = happySpecReduce_3 10# happyReduction_34 +happyReduction_34 happy_x_3 happy_x_2 happy_x_1 - = happyIn13 + = happyIn14 (return () ) -happyReduce_36 = happySpecReduce_1 10# happyReduction_36 -happyReduction_36 happy_x_1 - = case happyOut15 happy_x_1 of { happy_var_1 -> - happyIn14 +happyReduce_35 = happySpecReduce_1 11# happyReduction_35 +happyReduction_35 happy_x_1 + = case happyOut16 happy_x_1 of { happy_var_1 -> + happyIn15 ([happy_var_1] )} -happyReduce_37 = happySpecReduce_3 10# happyReduction_37 -happyReduction_37 happy_x_3 +happyReduce_36 = happySpecReduce_3 11# happyReduction_36 +happyReduction_36 happy_x_3 happy_x_2 happy_x_1 - = case happyOut15 happy_x_1 of { happy_var_1 -> - case happyOut14 happy_x_3 of { happy_var_3 -> - happyIn14 + = case happyOut16 happy_x_1 of { happy_var_1 -> + case happyOut15 happy_x_3 of { happy_var_3 -> + happyIn15 (happy_var_1 : happy_var_3 )}} -happyReduce_38 = happySpecReduce_1 11# happyReduction_38 -happyReduction_38 happy_x_1 +happyReduce_37 = happySpecReduce_1 12# happyReduction_37 +happyReduction_37 happy_x_1 = case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> - happyIn15 + happyIn16 ((happy_var_1, mkForeignLabel happy_var_1 Nothing ForeignLabelInExternalPackage IsFunction) )} -happyReduce_39 = happySpecReduce_2 11# happyReduction_39 -happyReduction_39 happy_x_2 +happyReduce_38 = happySpecReduce_2 12# happyReduction_38 +happyReduction_38 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { (L _ (CmmT_String happy_var_1)) -> case happyOutTok happy_x_2 of { (L _ (CmmT_Name happy_var_2)) -> - happyIn15 + happyIn16 ((happy_var_2, mkCmmCodeLabel (fsToPackageId (mkFastString happy_var_1)) happy_var_2) )}} -happyReduce_40 = happySpecReduce_1 12# happyReduction_40 -happyReduction_40 happy_x_1 +happyReduce_39 = happySpecReduce_1 13# happyReduction_39 +happyReduction_39 happy_x_1 = case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> - happyIn16 + happyIn17 ([happy_var_1] )} -happyReduce_41 = happySpecReduce_3 12# happyReduction_41 -happyReduction_41 happy_x_3 +happyReduce_40 = happySpecReduce_3 13# happyReduction_40 +happyReduction_40 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> - case happyOut16 happy_x_3 of { happy_var_3 -> - happyIn16 + case happyOut17 happy_x_3 of { happy_var_3 -> + happyIn17 (happy_var_1 : happy_var_3 )}} -happyReduce_42 = happySpecReduce_1 13# happyReduction_42 -happyReduction_42 happy_x_1 - = happyIn17 +happyReduce_41 = happySpecReduce_1 14# happyReduction_41 +happyReduction_41 happy_x_1 + = happyIn18 (nopEC ) -happyReduce_43 = happySpecReduce_2 13# happyReduction_43 -happyReduction_43 happy_x_2 +happyReduce_42 = happySpecReduce_2 14# happyReduction_42 +happyReduction_42 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> - happyIn17 + happyIn18 (do l <- newLabel happy_var_1; code (labelC l) )} -happyReduce_44 = happyReduce 4# 13# happyReduction_44 -happyReduction_44 (happy_x_4 `HappyStk` +happyReduce_43 = happyReduce 4# 14# happyReduction_43 +happyReduction_43 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) - = case happyOut44 happy_x_1 of { happy_var_1 -> - case happyOut30 happy_x_3 of { happy_var_3 -> - happyIn17 + = case happyOut46 happy_x_1 of { happy_var_1 -> + case happyOut32 happy_x_3 of { happy_var_3 -> + happyIn18 (do reg <- happy_var_1; e <- happy_var_3; stmtEC (CmmAssign reg e) ) `HappyStk` happyRest}} -happyReduce_45 = happyReduce 7# 13# happyReduction_45 -happyReduction_45 (happy_x_7 `HappyStk` +happyReduce_44 = happyReduce 7# 14# happyReduction_44 +happyReduction_44 (happy_x_7 `HappyStk` happy_x_6 `HappyStk` happy_x_5 `HappyStk` happy_x_4 `HappyStk` @@ -1157,15 +1158,15 @@ happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) - = case happyOut51 happy_x_1 of { happy_var_1 -> - case happyOut30 happy_x_3 of { happy_var_3 -> - case happyOut30 happy_x_6 of { happy_var_6 -> - happyIn17 + = case happyOut53 happy_x_1 of { happy_var_1 -> + case happyOut32 happy_x_3 of { happy_var_3 -> + case happyOut32 happy_x_6 of { happy_var_6 -> + happyIn18 (doStore happy_var_1 happy_var_3 happy_var_6 ) `HappyStk` happyRest}}} -happyReduce_46 = happyMonadReduce 11# 13# happyReduction_46 -happyReduction_46 (happy_x_11 `HappyStk` +happyReduce_45 = happyMonadReduce 11# 14# happyReduction_45 +happyReduction_45 (happy_x_11 `HappyStk` happy_x_10 `HappyStk` happy_x_9 `HappyStk` happy_x_8 `HappyStk` @@ -1177,18 +1178,18 @@ happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk - = happyThen (case happyOut40 happy_x_1 of { happy_var_1 -> + = happyThen (case happyOut42 happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_3 of { (L _ (CmmT_String happy_var_3)) -> - case happyOut30 happy_x_4 of { happy_var_4 -> - case happyOut34 happy_x_6 of { happy_var_6 -> - case happyOut21 happy_x_8 of { happy_var_8 -> - case happyOut22 happy_x_9 of { happy_var_9 -> - case happyOut18 happy_x_10 of { happy_var_10 -> + case happyOut32 happy_x_4 of { happy_var_4 -> + case happyOut36 happy_x_6 of { happy_var_6 -> + case happyOut22 happy_x_8 of { happy_var_8 -> + case happyOut23 happy_x_9 of { happy_var_9 -> + case happyOut19 happy_x_10 of { happy_var_10 -> ( foreignCall happy_var_3 happy_var_1 happy_var_4 happy_var_6 happy_var_9 happy_var_8 happy_var_10)}}}}}}} - ) (\r -> happyReturn (happyIn17 r)) + ) (\r -> happyReturn (happyIn18 r)) -happyReduce_47 = happyMonadReduce 10# 13# happyReduction_47 -happyReduction_47 (happy_x_10 `HappyStk` +happyReduce_46 = happyMonadReduce 10# 14# happyReduction_46 +happyReduction_46 (happy_x_10 `HappyStk` happy_x_9 `HappyStk` happy_x_8 `HappyStk` happy_x_7 `HappyStk` @@ -1199,28 +1200,28 @@ happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk - = happyThen (case happyOut40 happy_x_1 of { happy_var_1 -> + = happyThen (case happyOut42 happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_4 of { (L _ (CmmT_Name happy_var_4)) -> - case happyOut34 happy_x_6 of { happy_var_6 -> - case happyOut21 happy_x_8 of { happy_var_8 -> - case happyOut22 happy_x_9 of { happy_var_9 -> + case happyOut36 happy_x_6 of { happy_var_6 -> + case happyOut22 happy_x_8 of { happy_var_8 -> + case happyOut23 happy_x_9 of { happy_var_9 -> ( primCall happy_var_1 happy_var_4 happy_var_6 happy_var_9 happy_var_8)}}}}} - ) (\r -> happyReturn (happyIn17 r)) + ) (\r -> happyReturn (happyIn18 r)) -happyReduce_48 = happyMonadReduce 5# 13# happyReduction_48 -happyReduction_48 (happy_x_5 `HappyStk` +happyReduce_47 = happyMonadReduce 5# 14# happyReduction_47 +happyReduction_47 (happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen (case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> - case happyOut37 happy_x_3 of { happy_var_3 -> + case happyOut39 happy_x_3 of { happy_var_3 -> ( stmtMacro happy_var_1 happy_var_3)}} - ) (\r -> happyReturn (happyIn17 r)) + ) (\r -> happyReturn (happyIn18 r)) -happyReduce_49 = happyReduce 7# 13# happyReduction_49 -happyReduction_49 (happy_x_7 `HappyStk` +happyReduce_48 = happyReduce 7# 14# happyReduction_48 +happyReduction_48 (happy_x_7 `HappyStk` happy_x_6 `HappyStk` happy_x_5 `HappyStk` happy_x_4 `HappyStk` @@ -1228,45 +1229,57 @@ happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) - = case happyOut24 happy_x_2 of { happy_var_2 -> - case happyOut30 happy_x_3 of { happy_var_3 -> - case happyOut25 happy_x_5 of { happy_var_5 -> - case happyOut28 happy_x_6 of { happy_var_6 -> - happyIn17 - (doSwitch happy_var_2 happy_var_3 happy_var_5 happy_var_6 + = case happyOut25 happy_x_2 of { happy_var_2 -> + case happyOut32 happy_x_3 of { happy_var_3 -> + case happyOut26 happy_x_5 of { happy_var_5 -> + case happyOut30 happy_x_6 of { happy_var_6 -> + happyIn18 + (do as <- sequence happy_var_5; doSwitch happy_var_2 happy_var_3 as happy_var_6 ) `HappyStk` happyRest}}}} -happyReduce_50 = happySpecReduce_3 13# happyReduction_50 -happyReduction_50 happy_x_3 +happyReduce_49 = happySpecReduce_3 14# happyReduction_49 +happyReduction_49 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_2 of { (L _ (CmmT_Name happy_var_2)) -> - happyIn17 + happyIn18 (do l <- lookupLabel happy_var_2; stmtEC (CmmBranch l) )} -happyReduce_51 = happyReduce 4# 13# happyReduction_51 -happyReduction_51 (happy_x_4 `HappyStk` +happyReduce_50 = happyReduce 4# 14# happyReduction_50 +happyReduction_50 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) - = case happyOut30 happy_x_2 of { happy_var_2 -> - case happyOut33 happy_x_3 of { happy_var_3 -> - happyIn17 + = case happyOut32 happy_x_2 of { happy_var_2 -> + case happyOut35 happy_x_3 of { happy_var_3 -> + happyIn18 (do e1 <- happy_var_2; e2 <- sequence happy_var_3; stmtEC (CmmJump e1 e2) ) `HappyStk` happyRest}} -happyReduce_52 = happySpecReduce_3 13# happyReduction_52 -happyReduction_52 happy_x_3 +happyReduce_51 = happySpecReduce_3 14# happyReduction_51 +happyReduction_51 happy_x_3 happy_x_2 happy_x_1 - = case happyOut33 happy_x_2 of { happy_var_2 -> - happyIn17 + = case happyOut35 happy_x_2 of { happy_var_2 -> + happyIn18 (do e <- sequence happy_var_2; stmtEC (CmmReturn e) )} -happyReduce_53 = happyReduce 6# 13# happyReduction_53 +happyReduce_52 = happyReduce 4# 14# happyReduction_52 +happyReduction_52 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOut20 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_4 of { (L _ (CmmT_Name happy_var_4)) -> + happyIn18 + (do l <- lookupLabel happy_var_4; cmmRawIf happy_var_2 l + ) `HappyStk` happyRest}} + +happyReduce_53 = happyReduce 6# 14# happyReduction_53 happyReduction_53 (happy_x_6 `HappyStk` happy_x_5 `HappyStk` happy_x_4 `HappyStk` @@ -1274,129 +1287,129 @@ happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) - = case happyOut19 happy_x_2 of { happy_var_2 -> - case happyOut12 happy_x_4 of { happy_var_4 -> - case happyOut29 happy_x_6 of { happy_var_6 -> - happyIn17 + = case happyOut20 happy_x_2 of { happy_var_2 -> + case happyOut13 happy_x_4 of { happy_var_4 -> + case happyOut31 happy_x_6 of { happy_var_6 -> + happyIn18 (cmmIfThenElse happy_var_2 happy_var_4 happy_var_6 ) `HappyStk` happyRest}}} -happyReduce_54 = happySpecReduce_0 14# happyReduction_54 -happyReduction_54 = happyIn18 +happyReduce_54 = happySpecReduce_0 15# happyReduction_54 +happyReduction_54 = happyIn19 (CmmMayReturn ) -happyReduce_55 = happySpecReduce_2 14# happyReduction_55 +happyReduce_55 = happySpecReduce_2 15# happyReduction_55 happyReduction_55 happy_x_2 happy_x_1 - = happyIn18 + = happyIn19 (CmmNeverReturns ) -happyReduce_56 = happySpecReduce_1 15# happyReduction_56 +happyReduce_56 = happySpecReduce_1 16# happyReduction_56 happyReduction_56 happy_x_1 - = case happyOut20 happy_x_1 of { happy_var_1 -> - happyIn19 + = case happyOut21 happy_x_1 of { happy_var_1 -> + happyIn20 (happy_var_1 )} -happyReduce_57 = happySpecReduce_1 15# happyReduction_57 +happyReduce_57 = happySpecReduce_1 16# happyReduction_57 happyReduction_57 happy_x_1 - = case happyOut30 happy_x_1 of { happy_var_1 -> - happyIn19 + = case happyOut32 happy_x_1 of { happy_var_1 -> + happyIn20 (do e <- happy_var_1; return (BoolTest e) )} -happyReduce_58 = happySpecReduce_3 16# happyReduction_58 +happyReduce_58 = happySpecReduce_3 17# happyReduction_58 happyReduction_58 happy_x_3 happy_x_2 happy_x_1 - = case happyOut19 happy_x_1 of { happy_var_1 -> - case happyOut19 happy_x_3 of { happy_var_3 -> - happyIn20 + = case happyOut20 happy_x_1 of { happy_var_1 -> + case happyOut20 happy_x_3 of { happy_var_3 -> + happyIn21 (do e1 <- happy_var_1; e2 <- happy_var_3; return (BoolAnd e1 e2) )}} -happyReduce_59 = happySpecReduce_3 16# happyReduction_59 +happyReduce_59 = happySpecReduce_3 17# happyReduction_59 happyReduction_59 happy_x_3 happy_x_2 happy_x_1 - = case happyOut19 happy_x_1 of { happy_var_1 -> - case happyOut19 happy_x_3 of { happy_var_3 -> - happyIn20 + = case happyOut20 happy_x_1 of { happy_var_1 -> + case happyOut20 happy_x_3 of { happy_var_3 -> + happyIn21 (do e1 <- happy_var_1; e2 <- happy_var_3; return (BoolOr e1 e2) )}} -happyReduce_60 = happySpecReduce_2 16# happyReduction_60 +happyReduce_60 = happySpecReduce_2 17# happyReduction_60 happyReduction_60 happy_x_2 happy_x_1 - = case happyOut19 happy_x_2 of { happy_var_2 -> - happyIn20 + = case happyOut20 happy_x_2 of { happy_var_2 -> + happyIn21 (do e <- happy_var_2; return (BoolNot e) )} -happyReduce_61 = happySpecReduce_3 16# happyReduction_61 +happyReduce_61 = happySpecReduce_3 17# happyReduction_61 happyReduction_61 happy_x_3 happy_x_2 happy_x_1 - = case happyOut20 happy_x_2 of { happy_var_2 -> - happyIn20 + = case happyOut21 happy_x_2 of { happy_var_2 -> + happyIn21 (happy_var_2 )} -happyReduce_62 = happySpecReduce_0 17# happyReduction_62 -happyReduction_62 = happyIn21 +happyReduce_62 = happySpecReduce_0 18# happyReduction_62 +happyReduction_62 = happyIn22 (CmmUnsafe ) -happyReduce_63 = happyMonadReduce 1# 17# happyReduction_63 +happyReduce_63 = happyMonadReduce 1# 18# happyReduction_63 happyReduction_63 (happy_x_1 `HappyStk` happyRest) tk = happyThen (case happyOutTok happy_x_1 of { (L _ (CmmT_String happy_var_1)) -> ( parseSafety happy_var_1)} - ) (\r -> happyReturn (happyIn21 r)) + ) (\r -> happyReturn (happyIn22 r)) -happyReduce_64 = happySpecReduce_0 18# happyReduction_64 -happyReduction_64 = happyIn22 +happyReduce_64 = happySpecReduce_0 19# happyReduction_64 +happyReduction_64 = happyIn23 (Nothing ) -happyReduce_65 = happySpecReduce_2 18# happyReduction_65 +happyReduce_65 = happySpecReduce_2 19# happyReduction_65 happyReduction_65 happy_x_2 happy_x_1 - = happyIn22 + = happyIn23 (Just [] ) -happyReduce_66 = happySpecReduce_3 18# happyReduction_66 +happyReduce_66 = happySpecReduce_3 19# happyReduction_66 happyReduction_66 happy_x_3 happy_x_2 happy_x_1 - = case happyOut23 happy_x_2 of { happy_var_2 -> - happyIn22 + = case happyOut24 happy_x_2 of { happy_var_2 -> + happyIn23 (Just happy_var_2 )} -happyReduce_67 = happySpecReduce_1 19# happyReduction_67 +happyReduce_67 = happySpecReduce_1 20# happyReduction_67 happyReduction_67 happy_x_1 = case happyOutTok happy_x_1 of { (L _ (CmmT_GlobalReg happy_var_1)) -> - happyIn23 + happyIn24 ([happy_var_1] )} -happyReduce_68 = happySpecReduce_3 19# happyReduction_68 +happyReduce_68 = happySpecReduce_3 20# happyReduction_68 happyReduction_68 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { (L _ (CmmT_GlobalReg happy_var_1)) -> - case happyOut23 happy_x_3 of { happy_var_3 -> - happyIn23 + case happyOut24 happy_x_3 of { happy_var_3 -> + happyIn24 (happy_var_1 : happy_var_3 )}} -happyReduce_69 = happyReduce 5# 20# happyReduction_69 +happyReduce_69 = happyReduce 5# 21# happyReduction_69 happyReduction_69 (happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` @@ -1405,536 +1418,552 @@ happyRest) = case happyOutTok happy_x_2 of { (L _ (CmmT_Int happy_var_2)) -> case happyOutTok happy_x_4 of { (L _ (CmmT_Int happy_var_4)) -> - happyIn24 + happyIn25 (Just (fromIntegral happy_var_2, fromIntegral happy_var_4) ) `HappyStk` happyRest}} -happyReduce_70 = happySpecReduce_0 20# happyReduction_70 -happyReduction_70 = happyIn24 +happyReduce_70 = happySpecReduce_0 21# happyReduction_70 +happyReduction_70 = happyIn25 (Nothing ) -happyReduce_71 = happySpecReduce_0 21# happyReduction_71 -happyReduction_71 = happyIn25 +happyReduce_71 = happySpecReduce_0 22# happyReduction_71 +happyReduction_71 = happyIn26 ([] ) -happyReduce_72 = happySpecReduce_2 21# happyReduction_72 +happyReduce_72 = happySpecReduce_2 22# happyReduction_72 happyReduction_72 happy_x_2 happy_x_1 - = case happyOut26 happy_x_1 of { happy_var_1 -> - case happyOut25 happy_x_2 of { happy_var_2 -> - happyIn25 + = case happyOut27 happy_x_1 of { happy_var_1 -> + case happyOut26 happy_x_2 of { happy_var_2 -> + happyIn26 (happy_var_1 : happy_var_2 )}} -happyReduce_73 = happyReduce 6# 22# happyReduction_73 -happyReduction_73 (happy_x_6 `HappyStk` - happy_x_5 `HappyStk` - happy_x_4 `HappyStk` +happyReduce_73 = happyReduce 4# 23# happyReduction_73 +happyReduction_73 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) - = case happyOut27 happy_x_2 of { happy_var_2 -> - case happyOut12 happy_x_5 of { happy_var_5 -> - happyIn26 - ((happy_var_2, happy_var_5) + = case happyOut29 happy_x_2 of { happy_var_2 -> + case happyOut28 happy_x_4 of { happy_var_4 -> + happyIn27 + (do b <- happy_var_4; return (happy_var_2, b) ) `HappyStk` happyRest}} -happyReduce_74 = happySpecReduce_1 23# happyReduction_74 -happyReduction_74 happy_x_1 +happyReduce_74 = happySpecReduce_3 24# happyReduction_74 +happyReduction_74 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut13 happy_x_2 of { happy_var_2 -> + happyIn28 + (return (Right happy_var_2) + )} + +happyReduce_75 = happySpecReduce_3 24# happyReduction_75 +happyReduction_75 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_2 of { (L _ (CmmT_Name happy_var_2)) -> + happyIn28 + (do l <- lookupLabel happy_var_2; return (Left l) + )} + +happyReduce_76 = happySpecReduce_1 25# happyReduction_76 +happyReduction_76 happy_x_1 = case happyOutTok happy_x_1 of { (L _ (CmmT_Int happy_var_1)) -> - happyIn27 + happyIn29 ([ fromIntegral happy_var_1 ] )} -happyReduce_75 = happySpecReduce_3 23# happyReduction_75 -happyReduction_75 happy_x_3 +happyReduce_77 = happySpecReduce_3 25# happyReduction_77 +happyReduction_77 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { (L _ (CmmT_Int happy_var_1)) -> - case happyOut27 happy_x_3 of { happy_var_3 -> - happyIn27 + case happyOut29 happy_x_3 of { happy_var_3 -> + happyIn29 (fromIntegral happy_var_1 : happy_var_3 )}} -happyReduce_76 = happyReduce 5# 24# happyReduction_76 -happyReduction_76 (happy_x_5 `HappyStk` +happyReduce_78 = happyReduce 5# 26# happyReduction_78 +happyReduction_78 (happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) - = case happyOut12 happy_x_4 of { happy_var_4 -> - happyIn28 + = case happyOut13 happy_x_4 of { happy_var_4 -> + happyIn30 (Just happy_var_4 ) `HappyStk` happyRest} -happyReduce_77 = happySpecReduce_0 24# happyReduction_77 -happyReduction_77 = happyIn28 +happyReduce_79 = happySpecReduce_0 26# happyReduction_79 +happyReduction_79 = happyIn30 (Nothing ) -happyReduce_78 = happySpecReduce_0 25# happyReduction_78 -happyReduction_78 = happyIn29 +happyReduce_80 = happySpecReduce_0 27# happyReduction_80 +happyReduction_80 = happyIn31 (nopEC ) -happyReduce_79 = happyReduce 4# 25# happyReduction_79 -happyReduction_79 (happy_x_4 `HappyStk` +happyReduce_81 = happyReduce 4# 27# happyReduction_81 +happyReduction_81 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) - = case happyOut12 happy_x_3 of { happy_var_3 -> - happyIn29 + = case happyOut13 happy_x_3 of { happy_var_3 -> + happyIn31 (happy_var_3 ) `HappyStk` happyRest} -happyReduce_80 = happySpecReduce_3 26# happyReduction_80 -happyReduction_80 happy_x_3 +happyReduce_82 = happySpecReduce_3 28# happyReduction_82 +happyReduction_82 happy_x_3 happy_x_2 happy_x_1 - = case happyOut30 happy_x_1 of { happy_var_1 -> - case happyOut30 happy_x_3 of { happy_var_3 -> - happyIn30 + = case happyOut32 happy_x_1 of { happy_var_1 -> + case happyOut32 happy_x_3 of { happy_var_3 -> + happyIn32 (mkMachOp MO_U_Quot [happy_var_1,happy_var_3] )}} -happyReduce_81 = happySpecReduce_3 26# happyReduction_81 -happyReduction_81 happy_x_3 +happyReduce_83 = happySpecReduce_3 28# happyReduction_83 +happyReduction_83 happy_x_3 happy_x_2 happy_x_1 - = case happyOut30 happy_x_1 of { happy_var_1 -> - case happyOut30 happy_x_3 of { happy_var_3 -> - happyIn30 + = case happyOut32 happy_x_1 of { happy_var_1 -> + case happyOut32 happy_x_3 of { happy_var_3 -> + happyIn32 (mkMachOp MO_Mul [happy_var_1,happy_var_3] )}} -happyReduce_82 = happySpecReduce_3 26# happyReduction_82 -happyReduction_82 happy_x_3 +happyReduce_84 = happySpecReduce_3 28# happyReduction_84 +happyReduction_84 happy_x_3 happy_x_2 happy_x_1 - = case happyOut30 happy_x_1 of { happy_var_1 -> - case happyOut30 happy_x_3 of { happy_var_3 -> - happyIn30 + = case happyOut32 happy_x_1 of { happy_var_1 -> + case happyOut32 happy_x_3 of { happy_var_3 -> + happyIn32 (mkMachOp MO_U_Rem [happy_var_1,happy_var_3] )}} -happyReduce_83 = happySpecReduce_3 26# happyReduction_83 -happyReduction_83 happy_x_3 +happyReduce_85 = happySpecReduce_3 28# happyReduction_85 +happyReduction_85 happy_x_3 happy_x_2 happy_x_1 - = case happyOut30 happy_x_1 of { happy_var_1 -> - case happyOut30 happy_x_3 of { happy_var_3 -> - happyIn30 + = case happyOut32 happy_x_1 of { happy_var_1 -> + case happyOut32 happy_x_3 of { happy_var_3 -> + happyIn32 (mkMachOp MO_Sub [happy_var_1,happy_var_3] )}} -happyReduce_84 = happySpecReduce_3 26# happyReduction_84 -happyReduction_84 happy_x_3 +happyReduce_86 = happySpecReduce_3 28# happyReduction_86 +happyReduction_86 happy_x_3 happy_x_2 happy_x_1 - = case happyOut30 happy_x_1 of { happy_var_1 -> - case happyOut30 happy_x_3 of { happy_var_3 -> - happyIn30 + = case happyOut32 happy_x_1 of { happy_var_1 -> + case happyOut32 happy_x_3 of { happy_var_3 -> + happyIn32 (mkMachOp MO_Add [happy_var_1,happy_var_3] )}} -happyReduce_85 = happySpecReduce_3 26# happyReduction_85 -happyReduction_85 happy_x_3 +happyReduce_87 = happySpecReduce_3 28# happyReduction_87 +happyReduction_87 happy_x_3 happy_x_2 happy_x_1 - = case happyOut30 happy_x_1 of { happy_var_1 -> - case happyOut30 happy_x_3 of { happy_var_3 -> - happyIn30 + = case happyOut32 happy_x_1 of { happy_var_1 -> + case happyOut32 happy_x_3 of { happy_var_3 -> + happyIn32 (mkMachOp MO_U_Shr [happy_var_1,happy_var_3] )}} -happyReduce_86 = happySpecReduce_3 26# happyReduction_86 -happyReduction_86 happy_x_3 +happyReduce_88 = happySpecReduce_3 28# happyReduction_88 +happyReduction_88 happy_x_3 happy_x_2 happy_x_1 - = case happyOut30 happy_x_1 of { happy_var_1 -> - case happyOut30 happy_x_3 of { happy_var_3 -> - happyIn30 + = case happyOut32 happy_x_1 of { happy_var_1 -> + case happyOut32 happy_x_3 of { happy_var_3 -> + happyIn32 (mkMachOp MO_Shl [happy_var_1,happy_var_3] )}} -happyReduce_87 = happySpecReduce_3 26# happyReduction_87 -happyReduction_87 happy_x_3 +happyReduce_89 = happySpecReduce_3 28# happyReduction_89 +happyReduction_89 happy_x_3 happy_x_2 happy_x_1 - = case happyOut30 happy_x_1 of { happy_var_1 -> - case happyOut30 happy_x_3 of { happy_var_3 -> - happyIn30 + = case happyOut32 happy_x_1 of { happy_var_1 -> + case happyOut32 happy_x_3 of { happy_var_3 -> + happyIn32 (mkMachOp MO_And [happy_var_1,happy_var_3] )}} -happyReduce_88 = happySpecReduce_3 26# happyReduction_88 -happyReduction_88 happy_x_3 +happyReduce_90 = happySpecReduce_3 28# happyReduction_90 +happyReduction_90 happy_x_3 happy_x_2 happy_x_1 - = case happyOut30 happy_x_1 of { happy_var_1 -> - case happyOut30 happy_x_3 of { happy_var_3 -> - happyIn30 + = case happyOut32 happy_x_1 of { happy_var_1 -> + case happyOut32 happy_x_3 of { happy_var_3 -> + happyIn32 (mkMachOp MO_Xor [happy_var_1,happy_var_3] )}} -happyReduce_89 = happySpecReduce_3 26# happyReduction_89 -happyReduction_89 happy_x_3 +happyReduce_91 = happySpecReduce_3 28# happyReduction_91 +happyReduction_91 happy_x_3 happy_x_2 happy_x_1 - = case happyOut30 happy_x_1 of { happy_var_1 -> - case happyOut30 happy_x_3 of { happy_var_3 -> - happyIn30 + = case happyOut32 happy_x_1 of { happy_var_1 -> + case happyOut32 happy_x_3 of { happy_var_3 -> + happyIn32 (mkMachOp MO_Or [happy_var_1,happy_var_3] )}} -happyReduce_90 = happySpecReduce_3 26# happyReduction_90 -happyReduction_90 happy_x_3 +happyReduce_92 = happySpecReduce_3 28# happyReduction_92 +happyReduction_92 happy_x_3 happy_x_2 happy_x_1 - = case happyOut30 happy_x_1 of { happy_var_1 -> - case happyOut30 happy_x_3 of { happy_var_3 -> - happyIn30 + = case happyOut32 happy_x_1 of { happy_var_1 -> + case happyOut32 happy_x_3 of { happy_var_3 -> + happyIn32 (mkMachOp MO_U_Ge [happy_var_1,happy_var_3] )}} -happyReduce_91 = happySpecReduce_3 26# happyReduction_91 -happyReduction_91 happy_x_3 +happyReduce_93 = happySpecReduce_3 28# happyReduction_93 +happyReduction_93 happy_x_3 happy_x_2 happy_x_1 - = case happyOut30 happy_x_1 of { happy_var_1 -> - case happyOut30 happy_x_3 of { happy_var_3 -> - happyIn30 + = case happyOut32 happy_x_1 of { happy_var_1 -> + case happyOut32 happy_x_3 of { happy_var_3 -> + happyIn32 (mkMachOp MO_U_Gt [happy_var_1,happy_var_3] )}} -happyReduce_92 = happySpecReduce_3 26# happyReduction_92 -happyReduction_92 happy_x_3 +happyReduce_94 = happySpecReduce_3 28# happyReduction_94 +happyReduction_94 happy_x_3 happy_x_2 happy_x_1 - = case happyOut30 happy_x_1 of { happy_var_1 -> - case happyOut30 happy_x_3 of { happy_var_3 -> - happyIn30 + = case happyOut32 happy_x_1 of { happy_var_1 -> + case happyOut32 happy_x_3 of { happy_var_3 -> + happyIn32 (mkMachOp MO_U_Le [happy_var_1,happy_var_3] )}} -happyReduce_93 = happySpecReduce_3 26# happyReduction_93 -happyReduction_93 happy_x_3 +happyReduce_95 = happySpecReduce_3 28# happyReduction_95 +happyReduction_95 happy_x_3 happy_x_2 happy_x_1 - = case happyOut30 happy_x_1 of { happy_var_1 -> - case happyOut30 happy_x_3 of { happy_var_3 -> - happyIn30 + = case happyOut32 happy_x_1 of { happy_var_1 -> + case happyOut32 happy_x_3 of { happy_var_3 -> + happyIn32 (mkMachOp MO_U_Lt [happy_var_1,happy_var_3] )}} -happyReduce_94 = happySpecReduce_3 26# happyReduction_94 -happyReduction_94 happy_x_3 +happyReduce_96 = happySpecReduce_3 28# happyReduction_96 +happyReduction_96 happy_x_3 happy_x_2 happy_x_1 - = case happyOut30 happy_x_1 of { happy_var_1 -> - case happyOut30 happy_x_3 of { happy_var_3 -> - happyIn30 + = case happyOut32 happy_x_1 of { happy_var_1 -> + case happyOut32 happy_x_3 of { happy_var_3 -> + happyIn32 (mkMachOp MO_Ne [happy_var_1,happy_var_3] )}} -happyReduce_95 = happySpecReduce_3 26# happyReduction_95 -happyReduction_95 happy_x_3 +happyReduce_97 = happySpecReduce_3 28# happyReduction_97 +happyReduction_97 happy_x_3 happy_x_2 happy_x_1 - = case happyOut30 happy_x_1 of { happy_var_1 -> - case happyOut30 happy_x_3 of { happy_var_3 -> - happyIn30 + = case happyOut32 happy_x_1 of { happy_var_1 -> + case happyOut32 happy_x_3 of { happy_var_3 -> + happyIn32 (mkMachOp MO_Eq [happy_var_1,happy_var_3] )}} -happyReduce_96 = happySpecReduce_2 26# happyReduction_96 -happyReduction_96 happy_x_2 +happyReduce_98 = happySpecReduce_2 28# happyReduction_98 +happyReduction_98 happy_x_2 happy_x_1 - = case happyOut30 happy_x_2 of { happy_var_2 -> - happyIn30 + = case happyOut32 happy_x_2 of { happy_var_2 -> + happyIn32 (mkMachOp MO_Not [happy_var_2] )} -happyReduce_97 = happySpecReduce_2 26# happyReduction_97 -happyReduction_97 happy_x_2 +happyReduce_99 = happySpecReduce_2 28# happyReduction_99 +happyReduction_99 happy_x_2 happy_x_1 - = case happyOut30 happy_x_2 of { happy_var_2 -> - happyIn30 + = case happyOut32 happy_x_2 of { happy_var_2 -> + happyIn32 (mkMachOp MO_S_Neg [happy_var_2] )} -happyReduce_98 = happyMonadReduce 5# 26# happyReduction_98 -happyReduction_98 (happy_x_5 `HappyStk` +happyReduce_100 = happyMonadReduce 5# 28# happyReduction_100 +happyReduction_100 (happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk - = happyThen (case happyOut31 happy_x_1 of { happy_var_1 -> + = happyThen (case happyOut33 happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_3 of { (L _ (CmmT_Name happy_var_3)) -> - case happyOut31 happy_x_5 of { happy_var_5 -> + case happyOut33 happy_x_5 of { happy_var_5 -> ( do { mo <- nameToMachOp happy_var_3 ; return (mkMachOp mo [happy_var_1,happy_var_5]) })}}} - ) (\r -> happyReturn (happyIn30 r)) + ) (\r -> happyReturn (happyIn32 r)) -happyReduce_99 = happySpecReduce_1 26# happyReduction_99 -happyReduction_99 happy_x_1 - = case happyOut31 happy_x_1 of { happy_var_1 -> - happyIn30 +happyReduce_101 = happySpecReduce_1 28# happyReduction_101 +happyReduction_101 happy_x_1 + = case happyOut33 happy_x_1 of { happy_var_1 -> + happyIn32 (happy_var_1 )} -happyReduce_100 = happySpecReduce_2 27# happyReduction_100 -happyReduction_100 happy_x_2 +happyReduce_102 = happySpecReduce_2 29# happyReduction_102 +happyReduction_102 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { (L _ (CmmT_Int happy_var_1)) -> - case happyOut32 happy_x_2 of { happy_var_2 -> - happyIn31 + case happyOut34 happy_x_2 of { happy_var_2 -> + happyIn33 (return (CmmLit (CmmInt happy_var_1 (typeWidth happy_var_2))) )}} -happyReduce_101 = happySpecReduce_2 27# happyReduction_101 -happyReduction_101 happy_x_2 +happyReduce_103 = happySpecReduce_2 29# happyReduction_103 +happyReduction_103 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { (L _ (CmmT_Float happy_var_1)) -> - case happyOut32 happy_x_2 of { happy_var_2 -> - happyIn31 + case happyOut34 happy_x_2 of { happy_var_2 -> + happyIn33 (return (CmmLit (CmmFloat happy_var_1 (typeWidth happy_var_2))) )}} -happyReduce_102 = happySpecReduce_1 27# happyReduction_102 -happyReduction_102 happy_x_1 +happyReduce_104 = happySpecReduce_1 29# happyReduction_104 +happyReduction_104 happy_x_1 = case happyOutTok happy_x_1 of { (L _ (CmmT_String happy_var_1)) -> - happyIn31 + happyIn33 (do s <- code (mkStringCLit happy_var_1); return (CmmLit s) )} -happyReduce_103 = happySpecReduce_1 27# happyReduction_103 -happyReduction_103 happy_x_1 - = case happyOut39 happy_x_1 of { happy_var_1 -> - happyIn31 +happyReduce_105 = happySpecReduce_1 29# happyReduction_105 +happyReduction_105 happy_x_1 + = case happyOut41 happy_x_1 of { happy_var_1 -> + happyIn33 (happy_var_1 )} -happyReduce_104 = happyReduce 4# 27# happyReduction_104 -happyReduction_104 (happy_x_4 `HappyStk` +happyReduce_106 = happyReduce 4# 29# happyReduction_106 +happyReduction_106 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) - = case happyOut51 happy_x_1 of { happy_var_1 -> - case happyOut30 happy_x_3 of { happy_var_3 -> - happyIn31 + = case happyOut53 happy_x_1 of { happy_var_1 -> + case happyOut32 happy_x_3 of { happy_var_3 -> + happyIn33 (do e <- happy_var_3; return (CmmLoad e happy_var_1) ) `HappyStk` happyRest}} -happyReduce_105 = happyMonadReduce 5# 27# happyReduction_105 -happyReduction_105 (happy_x_5 `HappyStk` +happyReduce_107 = happyMonadReduce 5# 29# happyReduction_107 +happyReduction_107 (happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen (case happyOutTok happy_x_2 of { (L _ (CmmT_Name happy_var_2)) -> - case happyOut37 happy_x_4 of { happy_var_4 -> + case happyOut39 happy_x_4 of { happy_var_4 -> ( exprOp happy_var_2 happy_var_4)}} - ) (\r -> happyReturn (happyIn31 r)) + ) (\r -> happyReturn (happyIn33 r)) -happyReduce_106 = happySpecReduce_3 27# happyReduction_106 -happyReduction_106 happy_x_3 +happyReduce_108 = happySpecReduce_3 29# happyReduction_108 +happyReduction_108 happy_x_3 happy_x_2 happy_x_1 - = case happyOut30 happy_x_2 of { happy_var_2 -> - happyIn31 + = case happyOut32 happy_x_2 of { happy_var_2 -> + happyIn33 (happy_var_2 )} -happyReduce_107 = happySpecReduce_0 28# happyReduction_107 -happyReduction_107 = happyIn32 +happyReduce_109 = happySpecReduce_0 30# happyReduction_109 +happyReduction_109 = happyIn34 (bWord ) -happyReduce_108 = happySpecReduce_2 28# happyReduction_108 -happyReduction_108 happy_x_2 +happyReduce_110 = happySpecReduce_2 30# happyReduction_110 +happyReduction_110 happy_x_2 happy_x_1 - = case happyOut51 happy_x_2 of { happy_var_2 -> - happyIn32 + = case happyOut53 happy_x_2 of { happy_var_2 -> + happyIn34 (happy_var_2 )} -happyReduce_109 = happySpecReduce_0 29# happyReduction_109 -happyReduction_109 = happyIn33 +happyReduce_111 = happySpecReduce_0 31# happyReduction_111 +happyReduction_111 = happyIn35 ([] ) -happyReduce_110 = happySpecReduce_3 29# happyReduction_110 -happyReduction_110 happy_x_3 +happyReduce_112 = happySpecReduce_3 31# happyReduction_112 +happyReduction_112 happy_x_3 happy_x_2 happy_x_1 - = case happyOut34 happy_x_2 of { happy_var_2 -> - happyIn33 + = case happyOut36 happy_x_2 of { happy_var_2 -> + happyIn35 (happy_var_2 )} -happyReduce_111 = happySpecReduce_0 30# happyReduction_111 -happyReduction_111 = happyIn34 +happyReduce_113 = happySpecReduce_0 32# happyReduction_113 +happyReduction_113 = happyIn36 ([] ) -happyReduce_112 = happySpecReduce_1 30# happyReduction_112 -happyReduction_112 happy_x_1 - = case happyOut35 happy_x_1 of { happy_var_1 -> - happyIn34 +happyReduce_114 = happySpecReduce_1 32# happyReduction_114 +happyReduction_114 happy_x_1 + = case happyOut37 happy_x_1 of { happy_var_1 -> + happyIn36 (happy_var_1 )} -happyReduce_113 = happySpecReduce_1 31# happyReduction_113 -happyReduction_113 happy_x_1 - = case happyOut36 happy_x_1 of { happy_var_1 -> - happyIn35 +happyReduce_115 = happySpecReduce_1 33# happyReduction_115 +happyReduction_115 happy_x_1 + = case happyOut38 happy_x_1 of { happy_var_1 -> + happyIn37 ([happy_var_1] )} -happyReduce_114 = happySpecReduce_3 31# happyReduction_114 -happyReduction_114 happy_x_3 +happyReduce_116 = happySpecReduce_3 33# happyReduction_116 +happyReduction_116 happy_x_3 happy_x_2 happy_x_1 - = case happyOut36 happy_x_1 of { happy_var_1 -> - case happyOut35 happy_x_3 of { happy_var_3 -> - happyIn35 + = case happyOut38 happy_x_1 of { happy_var_1 -> + case happyOut37 happy_x_3 of { happy_var_3 -> + happyIn37 (happy_var_1 : happy_var_3 )}} -happyReduce_115 = happySpecReduce_1 32# happyReduction_115 -happyReduction_115 happy_x_1 - = case happyOut30 happy_x_1 of { happy_var_1 -> - happyIn36 +happyReduce_117 = happySpecReduce_1 34# happyReduction_117 +happyReduction_117 happy_x_1 + = case happyOut32 happy_x_1 of { happy_var_1 -> + happyIn38 (do e <- happy_var_1; return (CmmHinted e (inferCmmHint e)) )} -happyReduce_116 = happyMonadReduce 2# 32# happyReduction_116 -happyReduction_116 (happy_x_2 `HappyStk` +happyReduce_118 = happyMonadReduce 2# 34# happyReduction_118 +happyReduction_118 (happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk - = happyThen (case happyOut30 happy_x_1 of { happy_var_1 -> + = happyThen (case happyOut32 happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { (L _ (CmmT_String happy_var_2)) -> ( do h <- parseCmmHint happy_var_2; return $ do e <- happy_var_1; return (CmmHinted e h))}} - ) (\r -> happyReturn (happyIn36 r)) + ) (\r -> happyReturn (happyIn38 r)) -happyReduce_117 = happySpecReduce_0 33# happyReduction_117 -happyReduction_117 = happyIn37 +happyReduce_119 = happySpecReduce_0 35# happyReduction_119 +happyReduction_119 = happyIn39 ([] ) -happyReduce_118 = happySpecReduce_1 33# happyReduction_118 -happyReduction_118 happy_x_1 - = case happyOut38 happy_x_1 of { happy_var_1 -> - happyIn37 +happyReduce_120 = happySpecReduce_1 35# happyReduction_120 +happyReduction_120 happy_x_1 + = case happyOut40 happy_x_1 of { happy_var_1 -> + happyIn39 (happy_var_1 )} -happyReduce_119 = happySpecReduce_1 34# happyReduction_119 -happyReduction_119 happy_x_1 - = case happyOut30 happy_x_1 of { happy_var_1 -> - happyIn38 +happyReduce_121 = happySpecReduce_1 36# happyReduction_121 +happyReduction_121 happy_x_1 + = case happyOut32 happy_x_1 of { happy_var_1 -> + happyIn40 ([ happy_var_1 ] )} -happyReduce_120 = happySpecReduce_3 34# happyReduction_120 -happyReduction_120 happy_x_3 +happyReduce_122 = happySpecReduce_3 36# happyReduction_122 +happyReduction_122 happy_x_3 happy_x_2 happy_x_1 - = case happyOut30 happy_x_1 of { happy_var_1 -> - case happyOut38 happy_x_3 of { happy_var_3 -> - happyIn38 + = case happyOut32 happy_x_1 of { happy_var_1 -> + case happyOut40 happy_x_3 of { happy_var_3 -> + happyIn40 (happy_var_1 : happy_var_3 )}} -happyReduce_121 = happySpecReduce_1 35# happyReduction_121 -happyReduction_121 happy_x_1 +happyReduce_123 = happySpecReduce_1 37# happyReduction_123 +happyReduction_123 happy_x_1 = case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> - happyIn39 + happyIn41 (lookupName happy_var_1 )} -happyReduce_122 = happySpecReduce_1 35# happyReduction_122 -happyReduction_122 happy_x_1 +happyReduce_124 = happySpecReduce_1 37# happyReduction_124 +happyReduction_124 happy_x_1 = case happyOutTok happy_x_1 of { (L _ (CmmT_GlobalReg happy_var_1)) -> - happyIn39 + happyIn41 (return (CmmReg (CmmGlobal happy_var_1)) )} -happyReduce_123 = happySpecReduce_0 36# happyReduction_123 -happyReduction_123 = happyIn40 +happyReduce_125 = happySpecReduce_0 38# happyReduction_125 +happyReduction_125 = happyIn42 ([] ) -happyReduce_124 = happyReduce 4# 36# happyReduction_124 -happyReduction_124 (happy_x_4 `HappyStk` +happyReduce_126 = happyReduce 4# 38# happyReduction_126 +happyReduction_126 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) - = case happyOut41 happy_x_2 of { happy_var_2 -> - happyIn40 + = case happyOut43 happy_x_2 of { happy_var_2 -> + happyIn42 (happy_var_2 ) `HappyStk` happyRest} -happyReduce_125 = happySpecReduce_1 37# happyReduction_125 -happyReduction_125 happy_x_1 - = case happyOut42 happy_x_1 of { happy_var_1 -> - happyIn41 +happyReduce_127 = happySpecReduce_1 39# happyReduction_127 +happyReduction_127 happy_x_1 + = case happyOut44 happy_x_1 of { happy_var_1 -> + happyIn43 ([happy_var_1] )} -happyReduce_126 = happySpecReduce_2 37# happyReduction_126 -happyReduction_126 happy_x_2 +happyReduce_128 = happySpecReduce_2 39# happyReduction_128 +happyReduction_128 happy_x_2 happy_x_1 - = case happyOut42 happy_x_1 of { happy_var_1 -> - happyIn41 + = case happyOut44 happy_x_1 of { happy_var_1 -> + happyIn43 ([happy_var_1] )} -happyReduce_127 = happySpecReduce_3 37# happyReduction_127 -happyReduction_127 happy_x_3 +happyReduce_129 = happySpecReduce_3 39# happyReduction_129 +happyReduction_129 happy_x_3 happy_x_2 happy_x_1 - = case happyOut42 happy_x_1 of { happy_var_1 -> - case happyOut41 happy_x_3 of { happy_var_3 -> - happyIn41 + = case happyOut44 happy_x_1 of { happy_var_1 -> + case happyOut43 happy_x_3 of { happy_var_3 -> + happyIn43 (happy_var_1 : happy_var_3 )}} -happyReduce_128 = happySpecReduce_1 38# happyReduction_128 -happyReduction_128 happy_x_1 - = case happyOut43 happy_x_1 of { happy_var_1 -> - happyIn42 +happyReduce_130 = happySpecReduce_1 40# happyReduction_130 +happyReduction_130 happy_x_1 + = case happyOut45 happy_x_1 of { happy_var_1 -> + happyIn44 (do e <- happy_var_1; return (CmmHinted e (inferCmmHint (CmmReg (CmmLocal e)))) )} -happyReduce_129 = happyMonadReduce 2# 38# happyReduction_129 -happyReduction_129 (happy_x_2 `HappyStk` +happyReduce_131 = happyMonadReduce 2# 40# happyReduction_131 +happyReduction_131 (happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen (case happyOutTok happy_x_1 of { (L _ (CmmT_String happy_var_1)) -> - case happyOut43 happy_x_2 of { happy_var_2 -> + case happyOut45 happy_x_2 of { happy_var_2 -> ( do h <- parseCmmHint happy_var_1; return $ do e <- happy_var_2; return (CmmHinted e h))}} - ) (\r -> happyReturn (happyIn42 r)) + ) (\r -> happyReturn (happyIn44 r)) -happyReduce_130 = happySpecReduce_1 39# happyReduction_130 -happyReduction_130 happy_x_1 +happyReduce_132 = happySpecReduce_1 41# happyReduction_132 +happyReduction_132 happy_x_1 = case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> - happyIn43 + happyIn45 (do e <- lookupName happy_var_1; return $ case e of @@ -1942,10 +1971,10 @@ other -> pprPanic "CmmParse:" (ftext happy_var_1 <> text " not a local register") )} -happyReduce_131 = happySpecReduce_1 40# happyReduction_131 -happyReduction_131 happy_x_1 +happyReduce_133 = happySpecReduce_1 42# happyReduction_133 +happyReduction_133 happy_x_1 = case happyOutTok happy_x_1 of { (L _ (CmmT_Name happy_var_1)) -> - happyIn44 + happyIn46 (do e <- lookupName happy_var_1; return $ case e of @@ -1953,152 +1982,152 @@ other -> pprPanic "CmmParse:" (ftext happy_var_1 <> text " not a register") )} -happyReduce_132 = happySpecReduce_1 40# happyReduction_132 -happyReduction_132 happy_x_1 +happyReduce_134 = happySpecReduce_1 42# happyReduction_134 +happyReduction_134 happy_x_1 = case happyOutTok happy_x_1 of { (L _ (CmmT_GlobalReg happy_var_1)) -> - happyIn44 + happyIn46 (return (CmmGlobal happy_var_1) )} -happyReduce_133 = happySpecReduce_0 41# happyReduction_133 -happyReduction_133 = happyIn45 +happyReduce_135 = happySpecReduce_0 43# happyReduction_135 +happyReduction_135 = happyIn47 ([] ) -happyReduce_134 = happySpecReduce_3 41# happyReduction_134 -happyReduction_134 happy_x_3 +happyReduce_136 = happySpecReduce_3 43# happyReduction_136 +happyReduction_136 happy_x_3 happy_x_2 happy_x_1 - = case happyOut46 happy_x_2 of { happy_var_2 -> - happyIn45 + = case happyOut48 happy_x_2 of { happy_var_2 -> + happyIn47 (happy_var_2 )} -happyReduce_135 = happySpecReduce_0 42# happyReduction_135 -happyReduction_135 = happyIn46 +happyReduce_137 = happySpecReduce_0 44# happyReduction_137 +happyReduction_137 = happyIn48 ([] ) -happyReduce_136 = happySpecReduce_1 42# happyReduction_136 -happyReduction_136 happy_x_1 - = case happyOut47 happy_x_1 of { happy_var_1 -> - happyIn46 +happyReduce_138 = happySpecReduce_1 44# happyReduction_138 +happyReduction_138 happy_x_1 + = case happyOut49 happy_x_1 of { happy_var_1 -> + happyIn48 (happy_var_1 )} -happyReduce_137 = happySpecReduce_2 43# happyReduction_137 -happyReduction_137 happy_x_2 +happyReduce_139 = happySpecReduce_2 45# happyReduction_139 +happyReduction_139 happy_x_2 happy_x_1 - = case happyOut48 happy_x_1 of { happy_var_1 -> - happyIn47 + = case happyOut50 happy_x_1 of { happy_var_1 -> + happyIn49 ([happy_var_1] )} -happyReduce_138 = happySpecReduce_1 43# happyReduction_138 -happyReduction_138 happy_x_1 - = case happyOut48 happy_x_1 of { happy_var_1 -> - happyIn47 +happyReduce_140 = happySpecReduce_1 45# happyReduction_140 +happyReduction_140 happy_x_1 + = case happyOut50 happy_x_1 of { happy_var_1 -> + happyIn49 ([happy_var_1] )} -happyReduce_139 = happySpecReduce_3 43# happyReduction_139 -happyReduction_139 happy_x_3 +happyReduce_141 = happySpecReduce_3 45# happyReduction_141 +happyReduction_141 happy_x_3 happy_x_2 happy_x_1 - = case happyOut48 happy_x_1 of { happy_var_1 -> - case happyOut47 happy_x_3 of { happy_var_3 -> - happyIn47 + = case happyOut50 happy_x_1 of { happy_var_1 -> + case happyOut49 happy_x_3 of { happy_var_3 -> + happyIn49 (happy_var_1 : happy_var_3 )}} -happyReduce_140 = happySpecReduce_2 44# happyReduction_140 -happyReduction_140 happy_x_2 +happyReduce_142 = happySpecReduce_2 46# happyReduction_142 +happyReduction_142 happy_x_2 happy_x_1 - = case happyOut51 happy_x_1 of { happy_var_1 -> + = case happyOut53 happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { (L _ (CmmT_Name happy_var_2)) -> - happyIn48 + happyIn50 (newLocal happy_var_1 happy_var_2 )}} -happyReduce_141 = happySpecReduce_0 45# happyReduction_141 -happyReduction_141 = happyIn49 +happyReduce_143 = happySpecReduce_0 47# happyReduction_143 +happyReduction_143 = happyIn51 (return Nothing ) -happyReduce_142 = happyReduce 5# 45# happyReduction_142 -happyReduction_142 (happy_x_5 `HappyStk` +happyReduce_144 = happyReduce 5# 47# happyReduction_144 +happyReduction_144 (happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) - = case happyOut30 happy_x_2 of { happy_var_2 -> - case happyOut37 happy_x_4 of { happy_var_4 -> - happyIn49 + = case happyOut32 happy_x_2 of { happy_var_2 -> + case happyOut39 happy_x_4 of { happy_var_4 -> + happyIn51 (do { target <- happy_var_2; args <- sequence happy_var_4; return $ Just (UpdateFrame target args) } ) `HappyStk` happyRest}} -happyReduce_143 = happySpecReduce_0 46# happyReduction_143 -happyReduction_143 = happyIn50 +happyReduce_145 = happySpecReduce_0 48# happyReduction_145 +happyReduction_145 = happyIn52 (return Nothing ) -happyReduce_144 = happySpecReduce_2 46# happyReduction_144 -happyReduction_144 happy_x_2 +happyReduce_146 = happySpecReduce_2 48# happyReduction_146 +happyReduction_146 happy_x_2 happy_x_1 = case happyOutTok happy_x_2 of { (L _ (CmmT_Name happy_var_2)) -> - happyIn50 + happyIn52 (do l <- lookupLabel happy_var_2; return (Just l) )} -happyReduce_145 = happySpecReduce_1 47# happyReduction_145 -happyReduction_145 happy_x_1 - = happyIn51 +happyReduce_147 = happySpecReduce_1 49# happyReduction_147 +happyReduction_147 happy_x_1 + = happyIn53 (b8 ) -happyReduce_146 = happySpecReduce_1 47# happyReduction_146 -happyReduction_146 happy_x_1 - = case happyOut52 happy_x_1 of { happy_var_1 -> - happyIn51 +happyReduce_148 = happySpecReduce_1 49# happyReduction_148 +happyReduction_148 happy_x_1 + = case happyOut54 happy_x_1 of { happy_var_1 -> + happyIn53 (happy_var_1 )} -happyReduce_147 = happySpecReduce_1 48# happyReduction_147 -happyReduction_147 happy_x_1 - = happyIn52 +happyReduce_149 = happySpecReduce_1 50# happyReduction_149 +happyReduction_149 happy_x_1 + = happyIn54 (b16 ) -happyReduce_148 = happySpecReduce_1 48# happyReduction_148 -happyReduction_148 happy_x_1 - = happyIn52 +happyReduce_150 = happySpecReduce_1 50# happyReduction_150 +happyReduction_150 happy_x_1 + = happyIn54 (b32 ) -happyReduce_149 = happySpecReduce_1 48# happyReduction_149 -happyReduction_149 happy_x_1 - = happyIn52 +happyReduce_151 = happySpecReduce_1 50# happyReduction_151 +happyReduction_151 happy_x_1 + = happyIn54 (b64 ) -happyReduce_150 = happySpecReduce_1 48# happyReduction_150 -happyReduction_150 happy_x_1 - = happyIn52 +happyReduce_152 = happySpecReduce_1 50# happyReduction_152 +happyReduction_152 happy_x_1 + = happyIn54 (f32 ) -happyReduce_151 = happySpecReduce_1 48# happyReduction_151 -happyReduction_151 happy_x_1 - = happyIn52 +happyReduce_153 = happySpecReduce_1 50# happyReduction_153 +happyReduction_153 happy_x_1 + = happyIn54 (f64 ) -happyReduce_152 = happySpecReduce_1 48# happyReduction_152 -happyReduction_152 happy_x_1 - = happyIn52 +happyReduce_154 = happySpecReduce_1 50# happyReduction_154 +happyReduction_154 happy_x_1 + = happyIn54 (gcWord ) @@ -2274,15 +2303,7 @@ ( "gtu", MO_U_Gt ), ( "ltu", MO_U_Lt ), - ( "flt", MO_S_Lt ), - ( "fle", MO_S_Le ), - ( "feq", MO_Eq ), - ( "fne", MO_Ne ), - ( "fgt", MO_S_Gt ), - ( "fge", MO_S_Ge ), - ( "fneg", MO_S_Neg ), - - ( "and", MO_And ), + ( "and", MO_And ), ( "or", MO_Or ), ( "xor", MO_Xor ), ( "com", MO_Not ), @@ -2290,7 +2311,20 @@ ( "shrl", MO_U_Shr ), ( "shra", MO_S_Shr ), - ( "lobits8", flip MO_UU_Conv W8 ), + ( "fadd", MO_F_Add ), + ( "fsub", MO_F_Sub ), + ( "fneg", MO_F_Neg ), + ( "fmul", MO_F_Mul ), + ( "fquot", MO_F_Quot ), + + ( "feq", MO_F_Eq ), + ( "fne", MO_F_Ne ), + ( "fge", MO_F_Ge ), + ( "fle", MO_F_Le ), + ( "fgt", MO_F_Gt ), + ( "flt", MO_F_Lt ), + + ( "lobits8", flip MO_UU_Conv W8 ), ( "lobits16", flip MO_UU_Conv W16 ), ( "lobits32", flip MO_UU_Conv W32 ), ( "lobits64", flip MO_UU_Conv W64 ), @@ -2315,13 +2349,17 @@ callishMachOps = listToUFM $ map (\(x, y) -> (mkFastString x, y)) [ - ( "write_barrier", MO_WriteBarrier ) + ( "write_barrier", MO_WriteBarrier ), + ( "memcpy", MO_Memcpy ), + ( "memset", MO_Memset ), + ( "memmove", MO_Memmove ) -- ToDo: the rest, maybe ] parseSafety :: String -> P CmmSafety parseSafety "safe" = return (CmmSafe NoC_SRT) parseSafety "unsafe" = return CmmUnsafe +parseSafety "interruptible" = return CmmInterruptible parseSafety str = fail ("unrecognised safety: " ++ str) parseCmmHint :: String -> P ForeignHint @@ -2449,9 +2487,11 @@ code (emitForeignCall' PlayRisky results (CmmCallee expr' convention) args vols NoC_SRT ret) CmmSafe srt -> - code (emitForeignCall' (PlaySafe unused) results + code (emitForeignCall' PlaySafe results (CmmCallee expr' convention) args vols NoC_SRT ret) where - unused = panic "not used by emitForeignCall'" + CmmInterruptible -> + code (emitForeignCall' PlayInterruptible results + (CmmCallee expr' convention) args vols NoC_SRT ret) adjCallTarget :: CCallConv -> CmmExpr -> [CmmHinted CmmExpr] -> CmmExpr #ifdef mingw32_TARGET_OS @@ -2483,9 +2523,11 @@ code (emitForeignCall' PlayRisky results (CmmPrim p) args vols NoC_SRT CmmMayReturn) CmmSafe srt -> - code (emitForeignCall' (PlaySafe unused) results + code (emitForeignCall' PlaySafe results (CmmPrim p) args vols NoC_SRT CmmMayReturn) where - unused = panic "not used by emitForeignCall'" + CmmInterruptible -> + code (emitForeignCall' PlayInterruptible results + (CmmPrim p) args vols NoC_SRT CmmMayReturn) doStore :: CmmType -> ExtFCode CmmExpr -> ExtFCode CmmExpr -> ExtCode doStore rep addr_code val_code @@ -2538,6 +2580,10 @@ -- 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 @@ -2577,7 +2623,7 @@ -- 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 @@ -2604,12 +2650,12 @@ -- 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 @@ -2628,7 +2674,7 @@ showPass dflags "ParseCmm" buf <- hGetStringBuffer filename let - init_loc = mkSrcLoc (mkFastString filename) 1 1 + init_loc = mkRealSrcLoc (mkFastString filename) 1 1 init_state = (mkPState dflags buf init_loc) { lex_state = [0] } -- reset the lex_state: the Lexer monad leaves some stuff -- in there we don't want. @@ -2642,7 +2688,7 @@ if (errorsFound dflags ms) then return (ms, Nothing) else do - dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (ppr cmm) + dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprPlatform (targetPlatform dflags) cmm) return (ms, Just cmm) where no_module = panic "parseCmmFile: no module" diff -Nru ghc-7.0.3/compiler/cmm/CmmParse.y.source ghc-7.2.1/compiler/cmm/CmmParse.y.source --- ghc-7.0.3/compiler/cmm/CmmParse.y.source 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/cmm/CmmParse.y.source 2011-08-07 17:10:05.000000000 +0000 @@ -8,16 +8,11 @@ -- ----------------------------------------------------------------------------- +-- TODO: Add support for interruptible/uninterruptible foreign call specification + { -{-# OPTIONS -Wwarn -w -XNoMonomorphismRestriction #-} --- The NoMonomorphismRestriction deals with a Happy infelicity --- With OutsideIn's more conservativ monomorphism restriction --- we aren't generalising --- notHappyAtAll = error "urk" --- which is terrible. Switching off the restriction allows --- the generalisation. Better would be to make Happy generate --- an appropriate signature. --- +{-# LANGUAGE BangPatterns #-} -- required for versions of Happy before 1.18.6 +{-# OPTIONS -Wwarn -w #-} -- 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 @@ -42,8 +37,8 @@ import CostCentre import BlockId -import Cmm -import PprCmm +import OldCmm +import OldPprCmm() import CmmUtils import CmmLex import CLabel @@ -193,22 +188,24 @@ -- * we can derive closure and info table labels from a single NAME cmmdata :: { ExtCode } - : 'section' STRING '{' statics '}' - { do ss <- sequence $4; - code (emitData (section $2) (concat ss)) } + : 'section' STRING '{' data_label statics '}' + { do lbl <- $4; + ss <- sequence $5; + code (emitData (section $2) (Statics lbl $ concat ss)) } + +data_label :: { ExtFCode CLabel } + : NAME ':' + {% withThisPackage $ \pkg -> + return (mkCmmDataLabel pkg $1) } statics :: { [ExtFCode [CmmStatic]] } : {- empty -} { [] } | static statics { $1 : $2 } - + -- Strings aren't used much in the RTS HC code, so it doesn't seem -- worth allowing inline strings. C-- doesn't allow them anyway. static :: { ExtFCode [CmmStatic] } - : NAME ':' - {% withThisPackage $ \pkg -> - return [CmmDataLabel (mkCmmDataLabel pkg $1)] } - - | type expr ';' { do e <- $2; + : type expr ';' { do e <- $2; return [CmmStaticLit (getLit e)] } | type ';' { return [CmmUninitialised (widthInBytes (typeWidth $1))] } @@ -218,7 +215,6 @@ | typenot8 '[' INT ']' ';' { return [CmmUninitialised (widthInBytes (typeWidth $1) * fromIntegral $3)] } - | 'align' INT ';' { return [CmmAlign (fromIntegral $2)] } | 'CLOSURE' '(' NAME lits ')' { do lits <- sequence $4; return $ map CmmStaticLit $ @@ -270,7 +266,7 @@ {% withThisPackage $ \pkg -> do prof <- profilingInfo $11 $13 return (mkCmmEntryLabel pkg $3, - CmmInfoTable False prof (fromIntegral $9) + CmmInfoTable (mkCmmInfoLabel pkg $3) False prof (fromIntegral $9) (ThunkInfo (fromIntegral $5, fromIntegral $7) NoC_SRT), []) } @@ -279,7 +275,7 @@ {% withThisPackage $ \pkg -> do prof <- profilingInfo $11 $13 return (mkCmmEntryLabel pkg $3, - CmmInfoTable False prof (fromIntegral $9) + CmmInfoTable (mkCmmInfoLabel pkg $3) False prof (fromIntegral $9) (FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT 0 -- Arity zero (ArgSpec (fromIntegral $15)) @@ -294,7 +290,7 @@ {% withThisPackage $ \pkg -> do prof <- profilingInfo $11 $13 return (mkCmmEntryLabel pkg $3, - CmmInfoTable False prof (fromIntegral $9) + CmmInfoTable (mkCmmInfoLabel pkg $3) False prof (fromIntegral $9) (FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT (fromIntegral $17) (ArgSpec (fromIntegral $15)) zeroCLit), @@ -310,7 +306,7 @@ -- but that's the way the old code did it we can fix it some other time. desc_lit <- code $ mkStringCLit $13 return (mkCmmEntryLabel pkg $3, - CmmInfoTable False prof (fromIntegral $11) + CmmInfoTable (mkCmmInfoLabel pkg $3) False prof (fromIntegral $11) (ConstrInfo (fromIntegral $5, fromIntegral $7) (fromIntegral $9) desc_lit), []) } @@ -319,7 +315,7 @@ {% withThisPackage $ \pkg -> do prof <- profilingInfo $9 $11 return (mkCmmEntryLabel pkg $3, - CmmInfoTable False prof (fromIntegral $7) + CmmInfoTable (mkCmmInfoLabel pkg $3) False prof (fromIntegral $7) (ThunkSelectorInfo (fromIntegral $5) NoC_SRT), []) } @@ -328,7 +324,7 @@ {% withThisPackage $ \pkg -> do let infoLabel = mkCmmInfoLabel pkg $3 return (mkCmmRetLabel pkg $3, - CmmInfoTable False (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5) + CmmInfoTable (mkCmmInfoLabel pkg $3) False (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5) (ContInfo [] NoC_SRT), []) } @@ -337,7 +333,7 @@ {% withThisPackage $ \pkg -> do live <- sequence (map (liftM Just) $7) return (mkCmmRetLabel pkg $3, - CmmInfoTable False (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5) + CmmInfoTable (mkCmmInfoLabel pkg $3) False (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5) (ContInfo live NoC_SRT), live) } @@ -401,13 +397,15 @@ | 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 } @@ -446,12 +444,16 @@ : '[' 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 ] } @@ -463,6 +465,8 @@ -- 'default' branches | {- empty -} { Nothing } +-- Note: OldCmm doesn't support a first class 'else' statement, though +-- CmmNode does. else :: { ExtCode } : {- empty -} { nopEC } | 'else' '{' body '}' { $3 } @@ -686,15 +690,7 @@ ( "gtu", MO_U_Gt ), ( "ltu", MO_U_Lt ), - ( "flt", MO_S_Lt ), - ( "fle", MO_S_Le ), - ( "feq", MO_Eq ), - ( "fne", MO_Ne ), - ( "fgt", MO_S_Gt ), - ( "fge", MO_S_Ge ), - ( "fneg", MO_S_Neg ), - - ( "and", MO_And ), + ( "and", MO_And ), ( "or", MO_Or ), ( "xor", MO_Xor ), ( "com", MO_Not ), @@ -702,7 +698,20 @@ ( "shrl", MO_U_Shr ), ( "shra", MO_S_Shr ), - ( "lobits8", flip MO_UU_Conv W8 ), + ( "fadd", MO_F_Add ), + ( "fsub", MO_F_Sub ), + ( "fneg", MO_F_Neg ), + ( "fmul", MO_F_Mul ), + ( "fquot", MO_F_Quot ), + + ( "feq", MO_F_Eq ), + ( "fne", MO_F_Ne ), + ( "fge", MO_F_Ge ), + ( "fle", MO_F_Le ), + ( "fgt", MO_F_Gt ), + ( "flt", MO_F_Lt ), + + ( "lobits8", flip MO_UU_Conv W8 ), ( "lobits16", flip MO_UU_Conv W16 ), ( "lobits32", flip MO_UU_Conv W32 ), ( "lobits64", flip MO_UU_Conv W64 ), @@ -727,13 +736,17 @@ callishMachOps = listToUFM $ map (\(x, y) -> (mkFastString x, y)) [ - ( "write_barrier", MO_WriteBarrier ) + ( "write_barrier", MO_WriteBarrier ), + ( "memcpy", MO_Memcpy ), + ( "memset", MO_Memset ), + ( "memmove", MO_Memmove ) -- ToDo: the rest, maybe ] parseSafety :: String -> P CmmSafety parseSafety "safe" = return (CmmSafe NoC_SRT) parseSafety "unsafe" = return CmmUnsafe +parseSafety "interruptible" = return CmmInterruptible parseSafety str = fail ("unrecognised safety: " ++ str) parseCmmHint :: String -> P ForeignHint @@ -861,9 +874,11 @@ code (emitForeignCall' PlayRisky results (CmmCallee expr' convention) args vols NoC_SRT ret) CmmSafe srt -> - code (emitForeignCall' (PlaySafe unused) results + code (emitForeignCall' PlaySafe results (CmmCallee expr' convention) args vols NoC_SRT ret) where - unused = panic "not used by emitForeignCall'" + CmmInterruptible -> + code (emitForeignCall' PlayInterruptible results + (CmmCallee expr' convention) args vols NoC_SRT ret) adjCallTarget :: CCallConv -> CmmExpr -> [CmmHinted CmmExpr] -> CmmExpr #ifdef mingw32_TARGET_OS @@ -895,9 +910,11 @@ code (emitForeignCall' PlayRisky results (CmmPrim p) args vols NoC_SRT CmmMayReturn) CmmSafe srt -> - code (emitForeignCall' (PlaySafe unused) results + code (emitForeignCall' PlaySafe results (CmmPrim p) args vols NoC_SRT CmmMayReturn) where - unused = panic "not used by emitForeignCall'" + CmmInterruptible -> + code (emitForeignCall' PlayInterruptible results + (CmmPrim p) args vols NoC_SRT CmmMayReturn) doStore :: CmmType -> ExtFCode CmmExpr -> ExtFCode CmmExpr -> ExtCode doStore rep addr_code val_code @@ -950,6 +967,10 @@ -- 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 @@ -989,7 +1010,7 @@ -- 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 @@ -1016,12 +1037,12 @@ -- 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 @@ -1040,7 +1061,7 @@ showPass dflags "ParseCmm" buf <- hGetStringBuffer filename let - init_loc = mkSrcLoc (mkFastString filename) 1 1 + init_loc = mkRealSrcLoc (mkFastString filename) 1 1 init_state = (mkPState dflags buf init_loc) { lex_state = [0] } -- reset the lex_state: the Lexer monad leaves some stuff -- in there we don't want. @@ -1054,7 +1075,7 @@ if (errorsFound dflags ms) then return (ms, Nothing) else do - dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (ppr cmm) + dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprPlatform (targetPlatform dflags) cmm) return (ms, Just cmm) where no_module = panic "parseCmmFile: no module" diff -Nru ghc-7.0.3/compiler/cmm/CmmPipeline.hs ghc-7.2.1/compiler/cmm/CmmPipeline.hs --- ghc-7.0.3/compiler/cmm/CmmPipeline.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/compiler/cmm/CmmPipeline.hs 2011-08-07 17:10:05.000000000 +0000 @@ -0,0 +1,183 @@ +{-# OPTIONS_GHC -XNoMonoLocalBinds #-} +-- Norman likes local bindings +-- If this module lives on I'd like to get rid of this flag in due course + +module CmmPipeline ( + -- | Converts C-- with an implicit stack and native C-- calls into + -- optimized, CPS converted and native-call-less C--. The latter + -- C-- can be used to generate assembly. + cmmPipeline +) where + +import CLabel +import Cmm +import CmmDecl +import CmmLive +import CmmBuildInfoTables +import CmmCommonBlockElim +import CmmProcPoint +import CmmSpillReload +import CmmRewriteAssignments +import CmmStackLayout +import CmmContFlowOpt +import OptimizationFuel + +import DynFlags +import ErrUtils +import HscTypes +import Data.Maybe +import Control.Monad +import Data.Map (Map) +import qualified Data.Map as Map +import Outputable +import StaticFlags + +----------------------------------------------------------------------------- +-- | Top level driver for C-- pipeline +----------------------------------------------------------------------------- +-- There are two complications here: +-- 1. We need to compile the procedures in two stages because we need +-- an analysis of the procedures to tell us what CAFs they use. +-- The first stage returns a map from procedure labels to CAFs, +-- along with a closure that will compute SRTs and attach them to +-- the compiled procedures. +-- The second stage is to combine the CAF information into a top-level +-- CAF environment mapping non-static closures to the CAFs they keep live, +-- then pass that environment to the closures returned in the first +-- stage of compilation. +-- 2. We need to thread the module's SRT around when the SRT tables +-- are computed for each procedure. +-- The SRT needs to be threaded because it is grown lazily. +-- 3. We run control flow optimizations twice, once before any pipeline +-- work is done, and once again at the very end on all of the +-- resulting C-- blocks. EZY: It's unclear whether or not whether +-- we actually need to do the initial pass. +cmmPipeline :: HscEnv -- Compilation env including + -- dynamic flags: -dcmm-lint -ddump-cps-cmm + -> (TopSRT, [Cmm]) -- SRT table and accumulating list of compiled procs + -> Cmm -- Input C-- with Procedures + -> IO (TopSRT, [Cmm]) -- Output CPS transformed C-- +cmmPipeline hsc_env (topSRT, rst) prog = + do let dflags = hsc_dflags hsc_env + (Cmm tops) = runCmmContFlowOpts prog + showPass dflags "CPSZ" + (cafEnvs, tops) <- liftM unzip $ mapM (cpsTop hsc_env) tops + let topCAFEnv = mkTopCAFInfo (concat cafEnvs) + (topSRT, tops) <- foldM (toTops hsc_env topCAFEnv) (topSRT, []) tops + let cmms = Cmm (reverse (concat tops)) + dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (pprPlatform (targetPlatform dflags) cmms) + -- SRT is not affected by control flow optimization pass + let prog' = map runCmmContFlowOpts (cmms : rst) + return (topSRT, prog') + +{- [Note global fuel] +~~~~~~~~~~~~~~~~~~~~~ +The identity and the last pass are stored in +mutable reference cells in an 'HscEnv' and are +global to one compiler session. +-} + +-- EZY: It might be helpful to have an easy way of dumping the "pre" +-- input for any given phase, besides just turning it all on with +-- -ddump-cmmz + +cpsTop :: HscEnv -> CmmTop -> IO ([(CLabel, CAFSet)], [(CAFSet, CmmTop)]) +cpsTop _ p@(CmmData {}) = return ([], [(Map.empty, p)]) +cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) l g) = + do + -- Why bother doing these early: dualLivenessWithInsertion, + -- insertLateReloads, rewriteAssignments? + + ----------- Eliminate common blocks ------------------- + g <- return $ elimCommonBlocks g + dumpPlatform platform Opt_D_dump_cmmz_cbe "Post common block elimination" g + -- Any work storing block Labels must be performed _after_ elimCommonBlocks + + ----------- Proc points ------------------- + let callPPs = callProcPoints g + procPoints <- run $ minimalProcPointSet (targetPlatform dflags) callPPs g + g <- run $ addProcPointProtocols callPPs procPoints g + dumpPlatform platform Opt_D_dump_cmmz_proc "Post Proc Points Added" g + + ----------- Spills and reloads ------------------- + g <- run $ dualLivenessWithInsertion procPoints g + dumpPlatform platform Opt_D_dump_cmmz_spills "Post spills and reloads" g + + ----------- Sink and inline assignments ------------------- + g <- runOptimization $ rewriteAssignments g + dumpPlatform platform Opt_D_dump_cmmz_rewrite "Post rewrite assignments" g + + ----------- Eliminate dead assignments ------------------- + g <- runOptimization $ removeDeadAssignments g + dumpPlatform platform Opt_D_dump_cmmz_dead "Post remove dead assignments" g + + ----------- Zero dead stack slots (Debug only) --------------- + -- Debugging: stubbing slots on death can cause crashes early + g <- if opt_StubDeadValues + then run $ stubSlotsOnDeath g + else return g + dumpPlatform platform Opt_D_dump_cmmz_stub "Post stub dead stack slots" g + + --------------- Stack layout ---------------- + slotEnv <- run $ liveSlotAnal g + let spEntryMap = getSpEntryMap entry_off g + mbpprTrace "live slot analysis results: " (ppr slotEnv) $ return () + let areaMap = layout procPoints spEntryMap slotEnv entry_off g + mbpprTrace "areaMap" (ppr areaMap) $ return () + + ------------ Manifest the stack pointer -------- + g <- run $ manifestSP spEntryMap areaMap entry_off g + dumpPlatform platform Opt_D_dump_cmmz_sp "Post manifestSP" g + -- UGH... manifestSP can require updates to the procPointMap. + -- We can probably do something quicker here for the update... + + ------------- Split into separate procedures ------------ + procPointMap <- run $ procPointAnalysis procPoints g + dump Opt_D_dump_cmmz_procmap "procpoint map" procPointMap + gs <- run $ splitAtProcPoints l callPPs procPoints procPointMap + (CmmProc h l g) + mapM_ (dumpPlatform platform Opt_D_dump_cmmz_split "Post splitting") gs + + ------------- More CAFs and foreign calls ------------ + cafEnv <- run $ cafAnal g + let localCAFs = catMaybes $ map (localCAFInfo cafEnv) gs + mbpprTrace "localCAFs" (ppr localCAFs) $ return () + + gs <- run $ mapM (lowerSafeForeignCalls areaMap) gs + mapM_ (dumpPlatform platform Opt_D_dump_cmmz_lower "Post lowerSafeForeignCalls") gs + + -- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES + gs <- return $ map (setInfoTableStackMap slotEnv areaMap) gs + mapM_ (dumpPlatform platform Opt_D_dump_cmmz_info "after setInfoTableStackMap") gs + gs <- return $ map (bundleCAFs cafEnv) gs + mapM_ (dumpPlatform platform Opt_D_dump_cmmz_cafs "after bundleCAFs") gs + return (localCAFs, gs) + where dflags = hsc_dflags hsc_env + platform = targetPlatform dflags + mbpprTrace x y z = if dopt Opt_D_dump_cmmz dflags then pprTrace x y z else z + dump f = dumpWith ppr f + dumpPlatform platform = dumpWith (pprPlatform platform) + dumpWith pprFun f txt g = do + -- ToDo: No easy way of say "dump all the cmmz, *and* split + -- them into files." Also, -ddump-cmmz doesn't play nicely + -- with -ddump-to-file, since the headers get omitted. + dumpIfSet_dyn dflags f txt (pprFun g) + when (not (dopt f dflags)) $ + dumpIfSet_dyn dflags Opt_D_dump_cmmz txt (pprFun g) + -- Runs a required transformation/analysis + run = runInfiniteFuelIO (hsc_OptFuel hsc_env) + -- Runs an optional transformation/analysis (and should + -- thus be subject to optimization fuel) + runOptimization = runFuelIO (hsc_OptFuel hsc_env) + +-- This probably belongs in CmmBuildInfoTables? +-- We're just finishing the job here: once we know what CAFs are defined +-- in non-static closures, we can build the SRTs. +toTops :: HscEnv -> Map CLabel CAFSet -> (TopSRT, [[CmmTop]]) + -> [(CAFSet, CmmTop)] -> IO (TopSRT, [[CmmTop]]) +toTops hsc_env topCAFEnv (topSRT, tops) gs = + do let setSRT (topSRT, rst) g = + do (topSRT, gs) <- setInfoTableSRT topCAFEnv topSRT g + return (topSRT, gs : rst) + (topSRT, gs') <- runFuelIO (hsc_OptFuel hsc_env) $ foldM setSRT (topSRT, []) gs + return (topSRT, concat gs' : tops) diff -Nru ghc-7.0.3/compiler/cmm/CmmProcPoint.hs ghc-7.2.1/compiler/cmm/CmmProcPoint.hs --- ghc-7.0.3/compiler/cmm/CmmProcPoint.hs 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/cmm/CmmProcPoint.hs 2011-08-07 17:10:05.000000000 +0000 @@ -1,119 +1,568 @@ -module CmmProcPoint ( - calculateProcPoints - ) where +{-# LANGUAGE GADTs, DisambiguateRecordFields #-} +{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -#include "HsVersions.h" +module CmmProcPoint + ( ProcPointSet, Status(..) + , callProcPoints, minimalProcPointSet + , addProcPointProtocols, splitAtProcPoints, procPointAnalysis + ) +where -import BlockId -import CmmBrokenBlock -import Dataflow +import Prelude hiding (last, unzip, succ, zip) +import BlockId +import CLabel +import Cmm +import CmmDecl +import CmmExpr +import CmmContFlowOpt +import CmmInfo +import CmmLive +import Constants +import Data.List (sortBy) +import Maybes +import MkGraph +import Control.Monad +import OptimizationFuel +import Outputable +import Platform import UniqSet -import Panic +import UniqSupply + +import Compiler.Hoopl + +import qualified Data.Map as Map + +-- Compute a minimal set of proc points for a control-flow graph. --- Determine the proc points for a set of basic blocks. --- --- A proc point is any basic block that must start a new function. --- The entry block of the original function is a proc point. --- The continuation of a function call is also a proc point. --- The third kind of proc point arises when there is a joint point --- in the control flow. Suppose we have code like the following: --- --- if (...) { ...; call foo(); ...} --- else { ...; call bar(); ...} --- x = y; --- --- That last statement "x = y" must be a proc point because --- it can be reached by blocks owned by different proc points --- (the two branches of the conditional). --- --- We calculate these proc points by starting with the minimal set --- and finding blocks that are reachable from more proc points than --- one of their parents. (This ensures we don't choose a block --- simply beause it is reachable from another block that is reachable --- from multiple proc points.) These new blocks are added to the --- set of proc points and the process is repeated until there --- are no more proc points to be found. - -calculateProcPoints :: [BrokenBlock] -> UniqSet BlockId -calculateProcPoints blocks = - calculateProcPoints' init_proc_points blocks - where - init_proc_points = mkUniqSet $ - map brokenBlockId $ - filter always_proc_point blocks - always_proc_point BrokenBlock { - brokenBlockEntry = FunctionEntry _ _ _ } = True - always_proc_point BrokenBlock { - brokenBlockEntry = ContinuationEntry _ _ _ } = True - always_proc_point _ = False - -calculateProcPoints' :: UniqSet BlockId -> [BrokenBlock] -> UniqSet BlockId -calculateProcPoints' old_proc_points blocks = - if sizeUniqSet old_proc_points == sizeUniqSet new_proc_points - then old_proc_points - else calculateProcPoints' new_proc_points blocks - where - blocks_ufm :: BlockEnv BrokenBlock - blocks_ufm = blocksToBlockEnv blocks - - owners = calculateOwnership blocks_ufm old_proc_points blocks - new_proc_points = - unionManyUniqSets - (old_proc_points: - map (calculateNewProcPoints owners) blocks) - -calculateNewProcPoints :: BlockEnv (UniqSet BlockId) - -> BrokenBlock - -> UniqSet BlockId -calculateNewProcPoints owners block = - unionManyUniqSets (map (maybe_proc_point parent_id) child_ids) - where - parent_id = brokenBlockId block - child_ids = brokenBlockTargets block - maybe_proc_point parent_id child_id = - if needs_proc_point - then unitUniqSet child_id - else emptyUniqSet - where - parent_owners = lookupWithDefaultBEnv owners emptyUniqSet parent_id - child_owners = lookupWithDefaultBEnv owners emptyUniqSet child_id - needs_proc_point = - -- only if parent isn't dead - (not $ isEmptyUniqSet parent_owners) && - -- and only if child has more owners than parent - (not $ isEmptyUniqSet $ - child_owners `minusUniqSet` parent_owners) - -calculateOwnership :: BlockEnv BrokenBlock - -> UniqSet BlockId - -> [BrokenBlock] - -> BlockEnv (UniqSet BlockId) -calculateOwnership blocks_ufm proc_points blocks = - fixedpoint dependants update (map brokenBlockId blocks) emptyBlockEnv - where - dependants :: BlockId -> [BlockId] - dependants ident = - brokenBlockTargets $ lookupWithDefaultBEnv - blocks_ufm unknown_block ident - - update :: BlockId - -> Maybe BlockId - -> BlockEnv (UniqSet BlockId) - -> Maybe (BlockEnv (UniqSet BlockId)) - update ident cause owners = - case (cause, ident `elementOfUniqSet` proc_points) of - (Nothing, True) -> - Just $ extendBlockEnv owners ident (unitUniqSet ident) - (Nothing, False) -> Nothing - (Just _, True) -> Nothing - (Just cause', False) -> - if (sizeUniqSet old) == (sizeUniqSet new) - then Nothing - else Just $ extendBlockEnv owners ident new - where - old = lookupWithDefaultBEnv owners emptyUniqSet ident - new = old `unionUniqSets` - lookupWithDefaultBEnv owners emptyUniqSet cause' +-- Determine a protocol for each proc point (which live variables will +-- be passed as arguments and which will be on the stack). + +{- +A proc point is a basic block that, after CPS transformation, will +start a new function. The entry block of the original function is a +proc point, as is the continuation of each function call. +A third kind of proc point arises if we want to avoid copying code. +Suppose we have code like the following: + + f() { + if (...) { ..1..; call foo(); ..2..} + else { ..3..; call bar(); ..4..} + x = y + z; + return x; + } + +The statement 'x = y + z' can be reached from two different proc +points: the continuations of foo() and bar(). We would prefer not to +put a copy in each continuation; instead we would like 'x = y + z' to +be the start of a new procedure to which the continuations can jump: + + f_cps () { + if (...) { ..1..; push k_foo; jump foo_cps(); } + else { ..3..; push k_bar; jump bar_cps(); } + } + k_foo() { ..2..; jump k_join(y, z); } + k_bar() { ..4..; jump k_join(y, z); } + k_join(y, z) { x = y + z; return x; } + +You might think then that a criterion to make a node a proc point is +that it is directly reached by two distinct proc points. (Note +[Direct reachability].) But this criterion is a bit too simple; for +example, 'return x' is also reached by two proc points, yet there is +no point in pulling it out of k_join. A good criterion would be to +say that a node should be made a proc point if it is reached by a set +of proc points that is different than its immediate dominator. NR +believes this criterion can be shown to produce a minimum set of proc +points, and given a dominator tree, the proc points can be chosen in +time linear in the number of blocks. Lacking a dominator analysis, +however, we turn instead to an iterative solution, starting with no +proc points and adding them according to these rules: + + 1. The entry block is a proc point. + 2. The continuation of a call is a proc point. + 3. A node is a proc point if it is directly reached by more proc + points than one of its predecessors. + +Because we don't understand the problem very well, we apply rule 3 at +most once per iteration, then recompute the reachability information. +(See Note [No simple dataflow].) The choice of the new proc point is +arbitrary, and I don't know if the choice affects the final solution, +so I don't know if the number of proc points chosen is the +minimum---but the set will be minimal. +-} + +type ProcPointSet = BlockSet + +data Status + = ReachedBy ProcPointSet -- set of proc points that directly reach the block + | ProcPoint -- this block is itself a proc point + +instance Outputable Status where + ppr (ReachedBy ps) + | setNull ps = text "" + | otherwise = text "reached by" <+> + (hsep $ punctuate comma $ map ppr $ setElems ps) + ppr ProcPoint = text "" + +lattice :: DataflowLattice Status +lattice = DataflowLattice "direct proc-point reachability" unreached add_to + where unreached = ReachedBy setEmpty + add_to _ (OldFact ProcPoint) _ = (NoChange, ProcPoint) + add_to _ _ (NewFact ProcPoint) = (SomeChange, ProcPoint) -- because of previous case + add_to _ (OldFact (ReachedBy p)) (NewFact (ReachedBy p')) = + let union = setUnion p' p + in if setSize union > setSize p then (SomeChange, ReachedBy union) + else (NoChange, ReachedBy p) +-------------------------------------------------- +-- transfer equations + +forward :: FwdTransfer CmmNode Status +forward = mkFTransfer3 first middle ((mkFactBase lattice . ) . last) + where first :: CmmNode C O -> Status -> Status + first (CmmEntry id) ProcPoint = ReachedBy $ setSingleton id + first _ x = x + + middle _ x = x + + last :: CmmNode O C -> Status -> [(Label, Status)] + last (CmmCall {cml_cont = Just k}) _ = [(k, ProcPoint)] + last (CmmForeignCall {succ = k}) _ = [(k, ProcPoint)] + last l x = map (\id -> (id, x)) (successors l) + +-- It is worth distinguishing two sets of proc points: +-- those that are induced by calls in the original graph +-- and those that are introduced because they're reachable from multiple proc points. +callProcPoints :: CmmGraph -> ProcPointSet +callProcPoints g = foldGraphBlocks add (setSingleton (g_entry g)) g + where add :: CmmBlock -> BlockSet -> BlockSet + add b set = case lastNode b of + CmmCall {cml_cont = Just k} -> setInsert k set + CmmForeignCall {succ=k} -> setInsert k set + _ -> set + +minimalProcPointSet :: Platform -> ProcPointSet -> CmmGraph -> FuelUniqSM ProcPointSet +-- Given the set of successors of calls (which must be proc-points) +-- figure out the minimal set of necessary proc-points +minimalProcPointSet platform callProcPoints g = extendPPSet platform g (postorderDfs g) callProcPoints + +procPointAnalysis :: ProcPointSet -> CmmGraph -> FuelUniqSM (BlockEnv Status) +-- Once you know what the proc-points are, figure out +-- what proc-points each block is reachable from +procPointAnalysis procPoints g = + liftM snd $ dataflowPassFwd g initProcPoints $ analFwd lattice forward + where initProcPoints = [(id, ProcPoint) | id <- setElems procPoints] + +extendPPSet :: Platform -> CmmGraph -> [CmmBlock] -> ProcPointSet -> FuelUniqSM ProcPointSet +extendPPSet platform g blocks procPoints = + do env <- procPointAnalysis procPoints g + let add block pps = let id = entryLabel block + in case mapLookup id env of + Just ProcPoint -> setInsert id pps + _ -> pps + procPoints' = foldGraphBlocks add setEmpty g + newPoints = mapMaybe ppSuccessor blocks + newPoint = listToMaybe newPoints + ppSuccessor b = + let nreached id = case mapLookup id env `orElse` + pprPanic "no ppt" (ppr id <+> pprPlatform platform b) of + ProcPoint -> 1 + ReachedBy ps -> setSize ps + block_procpoints = nreached (entryLabel b) + -- | Looking for a successor of b that is reached by + -- more proc points than b and is not already a proc + -- point. If found, it can become a proc point. + newId succ_id = not (setMember succ_id procPoints') && + nreached succ_id > block_procpoints + in listToMaybe $ filter newId $ successors b +{- + case newPoints of + [] -> return procPoints' + pps -> extendPPSet g blocks + (foldl extendBlockSet procPoints' pps) +-} + case newPoint of Just id -> + if setMember id procPoints' then panic "added old proc pt" + else extendPPSet platform g blocks (setInsert id procPoints') + Nothing -> return procPoints' + + +------------------------------------------------------------------------ +-- Computing Proc-Point Protocols -- +------------------------------------------------------------------------ + +{- + +There is one major trick, discovered by Michael Adams, which is that +we want to choose protocols in a way that enables us to optimize away +some continuations. The optimization is very much like branch-chain +elimination, except that it involves passing results as well as +control. The idea is that if a call's continuation k does nothing but +CopyIn its results and then goto proc point P, the call's continuation +may be changed to P, *provided* P's protocol is identical to the +protocol for the CopyIn. We choose protocols to make this so. + +Here's an explanatory example; we begin with the source code (lines +separate basic blocks): + + ..1..; + x, y = g(); + goto P; + ------- + P: ..2..; + +Zipperization converts this code as follows: + + ..1..; + call g() returns to k; + ------- + k: CopyIn(x, y); + goto P; + ------- + P: ..2..; + +What we'd like to do is assign P the same CopyIn protocol as k, so we +can eliminate k: + + ..1..; + call g() returns to P; + ------- + P: CopyIn(x, y); ..2..; + +Of course, P may be the target of more than one continuation, and +different continuations may have different protocols. Michael Adams +implemented a voting mechanism, but he thinks a simple greedy +algorithm would be just as good, so that's what we do. + +-} + +data Protocol = Protocol Convention [CmmFormal] Area + deriving Eq +instance Outputable Protocol where + ppr (Protocol c fs a) = text "Protocol" <+> ppr c <+> ppr fs <+> ppr a + +-- | Function 'optimize_calls' chooses protocols only for those proc +-- points that are relevant to the optimization explained above. +-- The others are assigned by 'add_unassigned', which is not yet clever. + +addProcPointProtocols :: ProcPointSet -> ProcPointSet -> CmmGraph -> FuelUniqSM CmmGraph +addProcPointProtocols callPPs procPoints g = + do liveness <- cmmLiveness g + (protos, g') <- optimize_calls liveness g + blocks'' <- add_CopyOuts protos procPoints g' + return $ ofBlockMap (g_entry g) blocks'' + where optimize_calls liveness g = -- see Note [Separate Adams optimization] + do let (protos, blocks') = + foldGraphBlocks maybe_add_call (mapEmpty, mapEmpty) g + protos' = add_unassigned liveness procPoints protos + let g' = ofBlockMap (g_entry g) (add_CopyIns callPPs protos' blocks') + return (protos', removeUnreachableBlocks g') + maybe_add_call :: CmmBlock -> (BlockEnv Protocol, BlockEnv CmmBlock) + -> (BlockEnv Protocol, BlockEnv CmmBlock) + -- ^ If the block is a call whose continuation goes to a proc point + -- whose protocol either matches the continuation's or is not yet set, + -- redirect the call (cf 'newblock') and set the protocol if necessary + maybe_add_call block (protos, blocks) = + case lastNode block of + CmmCall tgt (Just k) args res s + | Just proto <- mapLookup k protos, + Just pee <- branchesToProcPoint k + -> let newblock = replaceLastNode block (CmmCall tgt (Just pee) + args res s) + changed_blocks = insertBlock newblock blocks + unchanged_blocks = insertBlock block blocks + in case mapLookup pee protos of + Nothing -> (mapInsert pee proto protos, changed_blocks) + Just proto' -> + if proto == proto' then (protos, changed_blocks) + else (protos, unchanged_blocks) + _ -> (protos, insertBlock block blocks) + + branchesToProcPoint :: BlockId -> Maybe BlockId + -- ^ Tells whether the named block is just a branch to a proc point + branchesToProcPoint id = + let block = mapLookup id (toBlockMap g) `orElse` + panic "branch out of graph" + in case blockToNodeList block of +-- MS: There is an ugly bug in ghc-6.10, which rejects following valid code. +-- After trying several tricks, the NOINLINE on getItOut worked. Uffff. +#if __GLASGOW_HASKELL__ >= 612 + (_, [], JustC (CmmBranch pee)) | setMember pee procPoints -> Just pee + _ -> Nothing +#else + (_, [], exit) | CmmBranch pee <- getItOut exit + , setMember pee procPoints -> Just pee + _ -> Nothing + where {-# NOINLINE getItOut #-} + getItOut :: MaybeC C a -> a + getItOut (JustC a) = a +#endif + +-- | For now, following a suggestion by Ben Lippmeier, we pass all +-- live variables as arguments, hoping that a clever register +-- allocator might help. + +add_unassigned :: BlockEnv CmmLive -> ProcPointSet -> BlockEnv Protocol -> + BlockEnv Protocol +add_unassigned = pass_live_vars_as_args + +pass_live_vars_as_args :: BlockEnv CmmLive -> ProcPointSet -> + BlockEnv Protocol -> BlockEnv Protocol +pass_live_vars_as_args _liveness procPoints protos = protos' + where protos' = setFold addLiveVars protos procPoints + addLiveVars :: BlockId -> BlockEnv Protocol -> BlockEnv Protocol + addLiveVars id protos = + case mapLookup id protos of + Just _ -> protos + Nothing -> let live = emptyRegSet + --lookupBlockEnv _liveness id `orElse` + --panic ("no liveness at block " ++ show id) + formals = uniqSetToList live + prot = Protocol Private formals $ CallArea $ Young id + in mapInsert id prot protos + + +-- | Add copy-in instructions to each proc point that did not arise from a call +-- instruction. (Proc-points that arise from calls already have their copy-in instructions.) + +add_CopyIns :: ProcPointSet -> BlockEnv Protocol -> BlockEnv CmmBlock -> BlockEnv CmmBlock +add_CopyIns callPPs protos blocks = mapFold maybe_insert_CopyIns mapEmpty blocks + where maybe_insert_CopyIns block blocks + | not $ setMember bid callPPs + , Just (Protocol c fs _area) <- mapLookup bid protos + = let nodes = copyInSlot c fs + (h, m, l) = blockToNodeList block + in insertBlock (blockOfNodeList (h, nodes ++ m, l)) blocks + | otherwise = insertBlock block blocks + where bid = entryLabel block + + +-- | Add a CopyOut node before each procpoint. +-- If the predecessor is a call, then the copy outs should already be done by the callee. +-- Note: If we need to add copy-out instructions, they may require stack space, +-- so we accumulate a map from the successors to the necessary stack space, +-- then update the successors after we have finished inserting the copy-outs. + +add_CopyOuts :: BlockEnv Protocol -> ProcPointSet -> CmmGraph -> + FuelUniqSM (BlockEnv CmmBlock) +add_CopyOuts protos procPoints g = foldGraphBlocks mb_copy_out (return mapEmpty) g + where mb_copy_out :: CmmBlock -> FuelUniqSM (BlockEnv CmmBlock) -> + FuelUniqSM (BlockEnv CmmBlock) + mb_copy_out b z | entryLabel b == g_entry g = skip b z + mb_copy_out b z = + case lastNode b of + CmmCall {} -> skip b z -- copy out done by callee + CmmForeignCall {} -> skip b z -- copy out done by callee + _ -> copy_out b z + copy_out b z = foldr trySucc init (successors b) >>= finish + where init = (\bmap -> (b, bmap)) `liftM` z + trySucc succId z = + if setMember succId procPoints then + case mapLookup succId protos of + Nothing -> z + Just (Protocol c fs _area) -> insert z succId $ copyOutSlot c fs + else z + insert z succId m = + do (b, bmap) <- z + (b, bs) <- insertBetween b m succId + -- pprTrace "insert for succ" (ppr succId <> ppr m) $ do + return $ (b, foldl (flip insertBlock) bmap bs) + finish (b, bmap) = return $ insertBlock b bmap + skip b bs = insertBlock b `liftM` bs + +-- At this point, we have found a set of procpoints, each of which should be +-- the entry point of a procedure. +-- Now, we create the procedure for each proc point, +-- which requires that we: +-- 1. build a map from proc points to the blocks reachable from the proc point +-- 2. turn each branch to a proc point into a jump +-- 3. turn calls and returns into jumps +-- 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 + (CmmProc (TopInfo {info_tbl=info_tbl, + stack_info=stack_info}) + top_l g@(CmmGraph {g_entry=entry})) = + do -- Build a map from procpoints to the blocks they reach + let addBlock b graphEnv = + case mapLookup bid procMap of + Just ProcPoint -> add graphEnv bid bid b + Just (ReachedBy set) -> + case setElems set of + [] -> graphEnv + [id] -> add graphEnv id bid b + _ -> panic "Each block should be reachable from only one ProcPoint" + Nothing -> pprPanic "block not reached by a proc point?" (ppr bid) + where bid = entryLabel b + add graphEnv procId bid b = mapInsert procId graph' graphEnv + where graph = mapLookup procId graphEnv `orElse` mapEmpty + graph' = mapInsert bid b graph + graphEnv <- return $ foldGraphBlocks addBlock emptyBlockMap g + -- Build a map from proc point BlockId to pairs of: + -- * Labels for their new procedures + -- * Labels for the info tables of their new procedures (only if the proc point is a callPP) + -- Due to common blockification, we may overestimate the set of procpoints. + let add_label map pp = Map.insert pp lbls map + where lbls | pp == entry = (entry_label, Just entry_info_lbl) + | otherwise = (blockLbl pp, guard (setMember pp callPPs) >> Just (infoTblLbl pp)) + entry_info_lbl = case info_tbl of + CmmInfoTable entry_info_label _ _ _ _ -> entry_info_label + CmmNonInfoTable -> pprPanic "splitAtProcPoints: looked at info label for entry without info table" (ppr pp) + procLabels = foldl add_label Map.empty + (filter (flip mapMember (toBlockMap g)) (setElems procPoints)) + -- For each procpoint, we need to know the SP offset on entry. + -- If the procpoint is: + -- - continuation of a call, the SP offset is in the call + -- - otherwise, 0 (and left out of the spEntryMap) + let add_sp_off :: CmmBlock -> BlockEnv CmmStackInfo -> BlockEnv CmmStackInfo + add_sp_off b env = + case lastNode b of + CmmCall {cml_cont = Just succ, cml_ret_args = off, cml_ret_off = updfr_off} -> + mapInsert succ (StackInfo { arg_space = off, updfr_space = Just updfr_off}) env + CmmForeignCall {succ = succ, updfr = updfr_off} -> + mapInsert succ (StackInfo { arg_space = wORD_SIZE, updfr_space = Just updfr_off}) env + _ -> env + spEntryMap = foldGraphBlocks add_sp_off (mapInsert entry stack_info emptyBlockMap) g + getStackInfo id = mapLookup id spEntryMap `orElse` StackInfo {arg_space = 0, updfr_space = Nothing} + -- In each new graph, add blocks jumping off to the new procedures, + -- and replace branches to procpoints with branches to the jump-off blocks + let add_jump_block (env, bs) (pp, l) = + do bid <- liftM mkBlockId getUniqueM + let b = blockOfNodeList (JustC (CmmEntry bid), [], JustC jump) + StackInfo {arg_space = argSpace, updfr_space = off} = getStackInfo pp + jump = CmmCall (CmmLit (CmmLabel l)) Nothing argSpace 0 + (off `orElse` 0) -- Jump's shouldn't need the offset... + return (mapInsert pp bid env, b : bs) + add_jumps (newGraphEnv) (ppId, blockEnv) = + do let needed_jumps = -- find which procpoints we currently branch to + mapFold add_if_branch_to_pp [] blockEnv + add_if_branch_to_pp :: CmmBlock -> [(BlockId, CLabel)] -> [(BlockId, CLabel)] + add_if_branch_to_pp block rst = + case lastNode block of + CmmBranch id -> add_if_pp id rst + CmmCondBranch _ ti fi -> add_if_pp ti (add_if_pp fi rst) + CmmSwitch _ tbl -> foldr add_if_pp rst (catMaybes tbl) + _ -> rst + add_if_pp id rst = case Map.lookup id procLabels of + Just (lbl, mb_info_lbl) -> (id, mb_info_lbl `orElse` lbl) : rst + Nothing -> rst + (jumpEnv, jumpBlocks) <- + foldM add_jump_block (mapEmpty, []) needed_jumps + -- update the entry block + let b = expectJust "block in env" $ mapLookup ppId blockEnv + off = getStackInfo ppId + blockEnv' = mapInsert ppId b blockEnv + -- replace branches to procpoints with branches to jumps + blockEnv'' = toBlockMap $ replaceBranches jumpEnv $ ofBlockMap ppId blockEnv' + -- add the jump blocks to the graph + blockEnv''' = foldl (flip insertBlock) blockEnv'' jumpBlocks + let g' = (off, ofBlockMap ppId blockEnv''') + -- pprTrace "g' pre jumps" (ppr g') $ do + return (mapInsert ppId g' newGraphEnv) + graphEnv <- foldM add_jumps emptyBlockMap $ mapToList graphEnv + let to_proc (bid, (stack_info, g)) = case expectJust "pp label" $ Map.lookup bid procLabels of + (lbl, Just info_lbl) + | bid == entry + -> CmmProc (TopInfo {info_tbl=info_tbl, stack_info=stack_info}) + top_l (replacePPIds g) + | otherwise + -> CmmProc (TopInfo {info_tbl=mkEmptyContInfoTable info_lbl, stack_info=stack_info}) + lbl (replacePPIds g) + (lbl, Nothing) + -> CmmProc (TopInfo {info_tbl=CmmNonInfoTable, stack_info=stack_info}) + lbl (replacePPIds g) + -- References to procpoint IDs can now be replaced with the infotable's label + replacePPIds g = mapGraphNodes (id, mapExp repl, mapExp repl) g + where repl e@(CmmLit (CmmBlock bid)) = + case Map.lookup bid procLabels of + Just (_, Just info_lbl) -> CmmLit (CmmLabel info_lbl) + _ -> e + repl e = e + -- The C back end expects to see return continuations before the call sites. + -- Here, we sort them in reverse order -- it gets reversed later. + let (_, block_order) = foldl add_block_num (0::Int, emptyBlockMap) (postorderDfs g) + add_block_num (i, map) block = (i+1, mapInsert (entryLabel block) i map) + sort_fn (bid, _) (bid', _) = + compare (expectJust "block_order" $ mapLookup bid block_order) + (expectJust "block_order" $ mapLookup bid' block_order) + procs <- return $ map to_proc $ sortBy sort_fn $ mapToList graphEnv + return -- pprTrace "procLabels" (ppr procLabels) + -- pprTrace "splitting graphs" (ppr procs) + procs +splitAtProcPoints _ _ _ _ t@(CmmData _ _) = return [t] + +---------------------------------------------------------------- + +{- +Note [Direct reachability] + +Block B is directly reachable from proc point P iff control can flow +from P to B without passing through an intervening proc point. +-} + +---------------------------------------------------------------- + +{- +Note [No simple dataflow] + +Sadly, it seems impossible to compute the proc points using a single +dataflow pass. One might attempt to use this simple lattice: + + data Location = Unknown + | InProc BlockId -- node is in procedure headed by the named proc point + | ProcPoint -- node is itself a proc point + +At a join, a node in two different blocks becomes a proc point. +The difficulty is that the change of information during iterative +computation may promote a node prematurely. Here's a program that +illustrates the difficulty: + + f () { + entry: + .... + L1: + if (...) { ... } + else { ... } + + L2: if (...) { g(); goto L1; } + return x + y; + } + +The only proc-point needed (besides the entry) is L1. But in an +iterative analysis, consider what happens to L2. On the first pass +through, it rises from Unknown to 'InProc entry', but when L1 is +promoted to a proc point (because it's the successor of g()), L1's +successors will be promoted to 'InProc L1'. The problem hits when the +new fact 'InProc L1' flows into L2 which is already bound to 'InProc entry'. +The join operation makes it a proc point when in fact it needn't be, +because its immediate dominator L1 is already a proc point and there +are no other proc points that directly reach L2. +-} + + + +{- Note [Separate Adams optimization] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It may be worthwhile to attempt the Adams optimization by rewriting +the graph before the assignment of proc-point protocols. Here are a +couple of rules: + + g() returns to k; g() returns to L; + k: CopyIn c ress; goto L: + ... ==> ... + L: // no CopyIn node here L: CopyIn c ress; + + +And when c == c' and ress == ress', this also: + + g() returns to k; g() returns to L; + k: CopyIn c ress; goto L: + ... ==> ... + L: CopyIn c' ress' L: CopyIn c' ress' ; - unknown_block = panic "unknown BlockId in calculateOwnership" +In both cases the goal is to eliminate k. +-} diff -Nru ghc-7.0.3/compiler/cmm/CmmProcPointZ.hs ghc-7.2.1/compiler/cmm/CmmProcPointZ.hs --- ghc-7.0.3/compiler/cmm/CmmProcPointZ.hs 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/cmm/CmmProcPointZ.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,554 +0,0 @@ -module CmmProcPointZ - ( ProcPointSet, Status(..) - , callProcPoints, minimalProcPointSet - , addProcPointProtocols, splitAtProcPoints, procPointAnalysis - ) -where - -import Prelude hiding (zip, unzip, last) - -import BlockId -import CLabel -import Cmm hiding (blockId) -import CmmContFlowOpt -import CmmInfo -import CmmLiveZ -import CmmTx -import DFMonad -import Data.List (sortBy) -import Maybes -import MkZipCfg -import MkZipCfgCmm hiding (CmmBlock, CmmGraph, CmmTopZ) -import Control.Monad -import Outputable -import UniqSet -import UniqSupply -import ZipCfg -import ZipCfgCmmRep -import ZipDataflow - -import qualified Data.Map as Map - --- Compute a minimal set of proc points for a control-flow graph. - --- Determine a protocol for each proc point (which live variables will --- be passed as arguments and which will be on the stack). - -{- -A proc point is a basic block that, after CPS transformation, will -start a new function. The entry block of the original function is a -proc point, as is the continuation of each function call. -A third kind of proc point arises if we want to avoid copying code. -Suppose we have code like the following: - - f() { - if (...) { ..1..; call foo(); ..2..} - else { ..3..; call bar(); ..4..} - x = y + z; - return x; - } - -The statement 'x = y + z' can be reached from two different proc -points: the continuations of foo() and bar(). We would prefer not to -put a copy in each continuation; instead we would like 'x = y + z' to -be the start of a new procedure to which the continuations can jump: - - f_cps () { - if (...) { ..1..; push k_foo; jump foo_cps(); } - else { ..3..; push k_bar; jump bar_cps(); } - } - k_foo() { ..2..; jump k_join(y, z); } - k_bar() { ..4..; jump k_join(y, z); } - k_join(y, z) { x = y + z; return x; } - -You might think then that a criterion to make a node a proc point is -that it is directly reached by two distinct proc points. (Note -[Direct reachability].) But this criterion is a bit too simple; for -example, 'return x' is also reached by two proc points, yet there is -no point in pulling it out of k_join. A good criterion would be to -say that a node should be made a proc point if it is reached by a set -of proc points that is different than its immediate dominator. NR -believes this criterion can be shown to produce a minimum set of proc -points, and given a dominator tree, the proc points can be chosen in -time linear in the number of blocks. Lacking a dominator analysis, -however, we turn instead to an iterative solution, starting with no -proc points and adding them according to these rules: - - 1. The entry block is a proc point. - 2. The continuation of a call is a proc point. - 3. A node is a proc point if it is directly reached by more proc - points than one of its predecessors. - -Because we don't understand the problem very well, we apply rule 3 at -most once per iteration, then recompute the reachability information. -(See Note [No simple dataflow].) The choice of the new proc point is -arbitrary, and I don't know if the choice affects the final solution, -so I don't know if the number of proc points chosen is the -minimum---but the set will be minimal. --} - -type ProcPointSet = BlockSet - -data Status - = ReachedBy ProcPointSet -- set of proc points that directly reach the block - | ProcPoint -- this block is itself a proc point - -instance Outputable Status where - ppr (ReachedBy ps) - | isEmptyBlockSet ps = text "" - | otherwise = text "reached by" <+> - (hsep $ punctuate comma $ map ppr $ blockSetToList ps) - ppr ProcPoint = text "" - - -lattice :: DataflowLattice Status -lattice = DataflowLattice "direct proc-point reachability" unreached add_to False - where unreached = ReachedBy emptyBlockSet - add_to _ ProcPoint = noTx ProcPoint - add_to ProcPoint _ = aTx ProcPoint -- aTx because of previous case again - add_to (ReachedBy p) (ReachedBy p') = - let union = unionBlockSets p p' - in if sizeBlockSet union > sizeBlockSet p' then - aTx (ReachedBy union) - else - noTx (ReachedBy p') --------------------------------------------------- --- transfer equations - -forward :: ForwardTransfers Middle Last Status -forward = ForwardTransfers first middle last exit - where first id ProcPoint = ReachedBy $ unitBlockSet id - first _ x = x - middle _ x = x - last (LastCall _ (Just id) _ _ _) _ = LastOutFacts [(id, ProcPoint)] - last l x = LastOutFacts $ map (\id -> (id, x)) (succs l) - exit x = x - --- It is worth distinguishing two sets of proc points: --- those that are induced by calls in the original graph --- and those that are introduced because they're reachable from multiple proc points. -callProcPoints :: CmmGraph -> ProcPointSet -callProcPoints g = fold_blocks add (unitBlockSet (lg_entry g)) g - where add b set = case last $ unzip b of - LastOther (LastCall _ (Just k) _ _ _) -> extendBlockSet set k - _ -> set - -minimalProcPointSet :: ProcPointSet -> CmmGraph -> FuelMonad ProcPointSet --- Given the set of successors of calls (which must be proc-points) --- figure ou the minimal set of necessary proc-points -minimalProcPointSet callProcPoints g = extendPPSet g (postorder_dfs g) callProcPoints - -type PPFix = FuelMonad (ForwardFixedPoint Middle Last Status ()) - -procPointAnalysis :: ProcPointSet -> CmmGraph -> FuelMonad (BlockEnv Status) --- Once you know what the proc-points are, figure out --- what proc-points each block is reachable from -procPointAnalysis procPoints g = - let addPP env id = extendBlockEnv env id ProcPoint - initProcPoints = foldl addPP emptyBlockEnv (blockSetToList procPoints) - in liftM zdfFpFacts $ - (zdfSolveFrom initProcPoints "proc-point reachability" lattice - forward (fact_bot lattice) $ graphOfLGraph g :: PPFix) - -extendPPSet :: CmmGraph -> [CmmBlock] -> ProcPointSet -> FuelMonad ProcPointSet -extendPPSet g blocks procPoints = - do env <- procPointAnalysis procPoints g - let add block pps = let id = blockId block - in case lookupBlockEnv env id of - Just ProcPoint -> extendBlockSet pps id - _ -> pps - procPoints' = fold_blocks add emptyBlockSet g - newPoints = mapMaybe ppSuccessor blocks - newPoint = listToMaybe newPoints - ppSuccessor b@(Block bid _) = - let nreached id = case lookupBlockEnv env id `orElse` - pprPanic "no ppt" (ppr id <+> ppr b) of - ProcPoint -> 1 - ReachedBy ps -> sizeBlockSet ps - block_procpoints = nreached bid - -- | Looking for a successor of b that is reached by - -- more proc points than b and is not already a proc - -- point. If found, it can become a proc point. - newId succ_id = not (elemBlockSet succ_id procPoints') && - nreached succ_id > block_procpoints - in listToMaybe $ filter newId $ succs b -{- - case newPoints of - [] -> return procPoints' - pps -> extendPPSet g blocks - (foldl extendBlockSet procPoints' pps) --} - case newPoint of Just id -> - if elemBlockSet id procPoints' then panic "added old proc pt" - else extendPPSet g blocks (extendBlockSet procPoints' id) - Nothing -> return procPoints' - - ------------------------------------------------------------------------- --- Computing Proc-Point Protocols -- ------------------------------------------------------------------------- - -{- - -There is one major trick, discovered by Michael Adams, which is that -we want to choose protocols in a way that enables us to optimize away -some continuations. The optimization is very much like branch-chain -elimination, except that it involves passing results as well as -control. The idea is that if a call's continuation k does nothing but -CopyIn its results and then goto proc point P, the call's continuation -may be changed to P, *provided* P's protocol is identical to the -protocol for the CopyIn. We choose protocols to make this so. - -Here's an explanatory example; we begin with the source code (lines -separate basic blocks): - - ..1..; - x, y = g(); - goto P; - ------- - P: ..2..; - -Zipperization converts this code as follows: - - ..1..; - call g() returns to k; - ------- - k: CopyIn(x, y); - goto P; - ------- - P: ..2..; - -What we'd like to do is assign P the same CopyIn protocol as k, so we -can eliminate k: - - ..1..; - call g() returns to P; - ------- - P: CopyIn(x, y); ..2..; - -Of course, P may be the target of more than one continuation, and -different continuations may have different protocols. Michael Adams -implemented a voting mechanism, but he thinks a simple greedy -algorithm would be just as good, so that's what we do. - --} - -data Protocol = Protocol Convention CmmFormals Area - deriving Eq -instance Outputable Protocol where - ppr (Protocol c fs a) = text "Protocol" <+> ppr c <+> ppr fs <+> ppr a - --- | Function 'optimize_calls' chooses protocols only for those proc --- points that are relevant to the optimization explained above. --- The others are assigned by 'add_unassigned', which is not yet clever. - -addProcPointProtocols :: ProcPointSet -> ProcPointSet -> CmmGraph -> FuelMonad CmmGraph -addProcPointProtocols callPPs procPoints g = - do liveness <- cmmLivenessZ g - (protos, g') <- optimize_calls liveness g - blocks'' <- add_CopyOuts protos procPoints g' - return $ LGraph (lg_entry g) blocks'' - where optimize_calls liveness g = -- see Note [Separate Adams optimization] - do let (protos, blocks') = - fold_blocks maybe_add_call (init_protocols, emptyBlockEnv) g - protos' = add_unassigned liveness procPoints protos - blocks <- add_CopyIns callPPs protos' blocks' - let g' = LGraph (lg_entry g) (mkBlockEnv (map withKey (concat blocks))) - withKey b@(Block bid _) = (bid, b) - return (protos', runTx removeUnreachableBlocksZ g') - maybe_add_call :: CmmBlock -> (BlockEnv Protocol, BlockEnv CmmBlock) - -> (BlockEnv Protocol, BlockEnv CmmBlock) - -- ^ If the block is a call whose continuation goes to a proc point - -- whose protocol either matches the continuation's or is not yet set, - -- redirect the call (cf 'newblock') and set the protocol if necessary - maybe_add_call block (protos, blocks) = - case goto_end $ unzip block of - (h, LastOther (LastCall tgt (Just k) args res s)) - | Just proto <- lookupBlockEnv protos k, - Just pee <- branchesToProcPoint k - -> let newblock = zipht h (tailOfLast (LastCall tgt (Just pee) - args res s)) - changed_blocks = insertBlock newblock blocks - unchanged_blocks = insertBlock block blocks - in case lookupBlockEnv protos pee of - Nothing -> (extendBlockEnv protos pee proto,changed_blocks) - Just proto' -> - if proto == proto' then (protos, changed_blocks) - else (protos, unchanged_blocks) - _ -> (protos, insertBlock block blocks) - - branchesToProcPoint :: BlockId -> Maybe BlockId - -- ^ Tells whether the named block is just a branch to a proc point - branchesToProcPoint id = - let (Block _ t) = lookupBlockEnv (lg_blocks g) id `orElse` - panic "branch out of graph" - in case t of - ZLast (LastOther (LastBranch pee)) - | elemBlockSet pee procPoints -> Just pee - _ -> Nothing - init_protocols = fold_blocks maybe_add_proto emptyBlockEnv g - maybe_add_proto :: CmmBlock -> BlockEnv Protocol -> BlockEnv Protocol - --maybe_add_proto (Block id (ZTail (CopyIn c _ fs _srt) _)) env = - -- extendBlockEnv env id (Protocol c fs $ toArea id fs) - maybe_add_proto _ env = env - -- JD: Is this proto stuff even necessary, now that we have - -- common blockification? - --- | For now, following a suggestion by Ben Lippmeier, we pass all --- live variables as arguments, hoping that a clever register --- allocator might help. - -add_unassigned :: BlockEnv CmmLive -> ProcPointSet -> BlockEnv Protocol -> - BlockEnv Protocol -add_unassigned = pass_live_vars_as_args - -pass_live_vars_as_args :: BlockEnv CmmLive -> ProcPointSet -> - BlockEnv Protocol -> BlockEnv Protocol -pass_live_vars_as_args _liveness procPoints protos = protos' - where protos' = foldBlockSet addLiveVars protos procPoints - addLiveVars :: BlockId -> BlockEnv Protocol -> BlockEnv Protocol - addLiveVars id protos = - case lookupBlockEnv protos id of - Just _ -> protos - Nothing -> let live = emptyRegSet - --lookupBlockEnv _liveness id `orElse` - --panic ("no liveness at block " ++ show id) - formals = uniqSetToList live - prot = Protocol Private formals $ CallArea $ Young id - in extendBlockEnv protos id prot - - --- | Add copy-in instructions to each proc point that did not arise from a call --- instruction. (Proc-points that arise from calls already have their copy-in instructions.) - -add_CopyIns :: ProcPointSet -> BlockEnv Protocol -> BlockEnv CmmBlock -> - FuelMonad [[CmmBlock]] -add_CopyIns callPPs protos blocks = - liftUniq $ mapM maybe_insert_CopyIns (blockEnvToList blocks) - where maybe_insert_CopyIns (_, b@(Block id t)) - | not $ elemBlockSet id callPPs - = case lookupBlockEnv protos id of - Just (Protocol c fs _area) -> - do LGraph _ blocks <- - lgraphOfAGraph (mkLabel id <*> copyInSlot c fs <*> mkZTail t) - return (map snd $ blockEnvToList blocks) - Nothing -> return [b] - | otherwise = return [b] - --- | Add a CopyOut node before each procpoint. --- If the predecessor is a call, then the copy outs should already be done by the callee. --- Note: If we need to add copy-out instructions, they may require stack space, --- so we accumulate a map from the successors to the necessary stack space, --- then update the successors after we have finished inserting the copy-outs. - -add_CopyOuts :: BlockEnv Protocol -> ProcPointSet -> CmmGraph -> - FuelMonad (BlockEnv CmmBlock) -add_CopyOuts protos procPoints g = fold_blocks mb_copy_out (return emptyBlockEnv) g - where mb_copy_out :: CmmBlock -> FuelMonad (BlockEnv CmmBlock) -> - FuelMonad (BlockEnv CmmBlock) - mb_copy_out b@(Block bid _) z | bid == lg_entry g = skip b z - mb_copy_out b z = - case last $ unzip b of - LastOther (LastCall _ _ _ _ _) -> skip b z -- copy out done by callee - _ -> copy_out b z - copy_out b z = fold_succs trySucc b init >>= finish - where init = z >>= (\bmap -> return (b, bmap)) - trySucc succId z = - if elemBlockSet succId procPoints then - case lookupBlockEnv protos succId of - Nothing -> z - Just (Protocol c fs _area) -> insert z succId $ copyOutSlot c fs - else z - insert z succId m = - do (b, bmap) <- z - (b, bs) <- insertBetween b m succId - -- pprTrace "insert for succ" (ppr succId <> ppr m) $ do - return $ (b, foldl (flip insertBlock) bmap bs) - finish (b@(Block bid _), bmap) = - return $ (extendBlockEnv bmap bid b) - skip b@(Block bid _) bs = - bs >>= (\bmap -> return (extendBlockEnv bmap bid b)) - --- At this point, we have found a set of procpoints, each of which should be --- the entry point of a procedure. --- Now, we create the procedure for each proc point, --- which requires that we: --- 1. build a map from proc points to the blocks reachable from the proc point --- 2. turn each branch to a proc point into a jump --- 3. turn calls and returns into jumps --- 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. -splitAtProcPoints :: CLabel -> ProcPointSet-> ProcPointSet -> BlockEnv Status -> - CmmTopZ -> FuelMonad [CmmTopZ] -splitAtProcPoints entry_label callPPs procPoints procMap - (CmmProc (CmmInfo gc upd_fr info_tbl) top_l top_args - (stackInfo, g@(LGraph entry blocks))) = - do -- Build a map from procpoints to the blocks they reach - let addBlock b@(Block bid _) graphEnv = - case lookupBlockEnv procMap bid of - Just ProcPoint -> add graphEnv bid bid b - Just (ReachedBy set) -> - case blockSetToList set of - [] -> graphEnv - [id] -> add graphEnv id bid b - _ -> panic "Each block should be reachable from only one ProcPoint" - Nothing -> pprPanic "block not reached by a proc point?" (ppr bid) - add graphEnv procId bid b = extendBlockEnv graphEnv procId graph' - where graph = lookupBlockEnv graphEnv procId `orElse` emptyBlockEnv - graph' = extendBlockEnv graph bid b - graphEnv <- return $ fold_blocks addBlock emptyBlockEnv g - -- Build a map from proc point BlockId to labels for their new procedures - -- Due to common blockification, we may overestimate the set of procpoints. - let add_label map pp = return $ Map.insert pp lbl map - where lbl = if pp == entry then entry_label else blockLbl pp - procLabels <- foldM add_label Map.empty - (filter (elemBlockEnv blocks) (blockSetToList procPoints)) - -- For each procpoint, we need to know the SP offset on entry. - -- If the procpoint is: - -- - continuation of a call, the SP offset is in the call - -- - otherwise, 0 -- no overflow for passing those variables - let add_sp_off b env = - case last (unzip b) of - LastOther (LastCall {cml_cont = Just succ, cml_ret_args = off, - cml_ret_off = updfr_off}) -> - extendBlockEnv env succ (off, updfr_off) - _ -> env - spEntryMap = fold_blocks add_sp_off (mkBlockEnv [(entry, stackInfo)]) g - getStackInfo id = lookupBlockEnv spEntryMap id `orElse` (0, Nothing) - -- In each new graph, add blocks jumping off to the new procedures, - -- and replace branches to procpoints with branches to the jump-off blocks - let add_jump_block (env, bs) (pp, l) = - do bid <- liftM mkBlockId getUniqueM - let b = Block bid (ZLast (LastOther jump)) - (argSpace, _) = getStackInfo pp - jump = LastCall (CmmLit (CmmLabel l')) Nothing argSpace 0 Nothing - l' = if elemBlockSet pp callPPs then entryLblToInfoLbl l else l - return (extendBlockEnv env pp bid, b : bs) - add_jumps (newGraphEnv) (ppId, blockEnv) = - do let needed_jumps = -- find which procpoints we currently branch to - foldBlockEnv' add_if_branch_to_pp [] blockEnv - add_if_branch_to_pp block rst = - case last (unzip block) of - LastOther (LastBranch id) -> add_if_pp id rst - LastOther (LastCondBranch _ ti fi) -> - add_if_pp ti (add_if_pp fi rst) - LastOther (LastSwitch _ tbl) -> foldr add_if_pp rst (catMaybes tbl) - _ -> rst - add_if_pp id rst = case Map.lookup id procLabels of - Just x -> (id, x) : rst - Nothing -> rst - (jumpEnv, jumpBlocks) <- - foldM add_jump_block (emptyBlockEnv, []) needed_jumps - -- update the entry block - let b = expectJust "block in env" $ lookupBlockEnv blockEnv ppId - off = getStackInfo ppId - blockEnv' = extendBlockEnv blockEnv ppId b - -- replace branches to procpoints with branches to jumps - LGraph _ blockEnv'' = replaceBranches jumpEnv $ LGraph ppId blockEnv' - -- add the jump blocks to the graph - blockEnv''' = foldl (flip insertBlock) blockEnv'' jumpBlocks - let g' = (off, LGraph ppId blockEnv''') - -- pprTrace "g' pre jumps" (ppr g') $ do - return (extendBlockEnv newGraphEnv ppId g') - graphEnv <- foldM add_jumps emptyBlockEnv $ blockEnvToList graphEnv - let to_proc (bid, g) | elemBlockSet bid callPPs = - if bid == entry then - CmmProc (CmmInfo gc upd_fr info_tbl) top_l top_args (replacePPIds g) - else - CmmProc emptyContInfoTable lbl [] (replacePPIds g) - where lbl = expectJust "pp label" $ Map.lookup bid procLabels - to_proc (bid, g) = - CmmProc (CmmInfo Nothing Nothing CmmNonInfoTable) lbl [] (replacePPIds g) - where lbl = expectJust "pp label" $ Map.lookup bid procLabels - -- References to procpoint IDs can now be replaced with the infotable's label - replacePPIds (x, g) = (x, map_nodes id (mapExpMiddle repl) (mapExpLast repl) g) - where repl e@(CmmLit (CmmBlock bid)) = - case Map.lookup bid procLabels of - Just l -> CmmLit (CmmLabel (entryLblToInfoLbl l)) - Nothing -> e - repl e = e - -- The C back end expects to see return continuations before the call sites. - -- Here, we sort them in reverse order -- it gets reversed later. - let (_, block_order) = foldl add_block_num (0::Int, emptyBlockEnv) (postorder_dfs g) - add_block_num (i, map) (Block bid _) = (i+1, extendBlockEnv map bid i) - sort_fn (bid, _) (bid', _) = - compare (expectJust "block_order" $ lookupBlockEnv block_order bid) - (expectJust "block_order" $ lookupBlockEnv block_order bid') - procs <- return $ map to_proc $ sortBy sort_fn $ blockEnvToList graphEnv - return -- pprTrace "procLabels" (ppr procLabels) - -- pprTrace "splitting graphs" (ppr procs) - procs -splitAtProcPoints _ _ _ _ t@(CmmData _ _) = return [t] - ----------------------------------------------------------------- - -{- -Note [Direct reachability] - -Block B is directly reachable from proc point P iff control can flow -from P to B without passing through an intervening proc point. --} - ----------------------------------------------------------------- - -{- -Note [No simple dataflow] - -Sadly, it seems impossible to compute the proc points using a single -dataflow pass. One might attempt to use this simple lattice: - - data Location = Unknown - | InProc BlockId -- node is in procedure headed by the named proc point - | ProcPoint -- node is itself a proc point - -At a join, a node in two different blocks becomes a proc point. -The difficulty is that the change of information during iterative -computation may promote a node prematurely. Here's a program that -illustrates the difficulty: - - f () { - entry: - .... - L1: - if (...) { ... } - else { ... } - - L2: if (...) { g(); goto L1; } - return x + y; - } - -The only proc-point needed (besides the entry) is L1. But in an -iterative analysis, consider what happens to L2. On the first pass -through, it rises from Unknown to 'InProc entry', but when L1 is -promoted to a proc point (because it's the successor of g()), L1's -successors will be promoted to 'InProc L1'. The problem hits when the -new fact 'InProc L1' flows into L2 which is already bound to 'InProc entry'. -The join operation makes it a proc point when in fact it needn't be, -because its immediate dominator L1 is already a proc point and there -are no other proc points that directly reach L2. --} - - - -{- Note [Separate Adams optimization] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -It may be worthwhile to attempt the Adams optimization by rewriting -the graph before the assignment of proc-point protocols. Here are a -couple of rules: - - g() returns to k; g() returns to L; - k: CopyIn c ress; goto L: - ... ==> ... - L: // no CopyIn node here L: CopyIn c ress; - - -And when c == c' and ress == ress', this also: - - g() returns to k; g() returns to L; - k: CopyIn c ress; goto L: - ... ==> ... - L: CopyIn c' ress' L: CopyIn c' ress' ; - -In both cases the goal is to eliminate k. --} diff -Nru ghc-7.0.3/compiler/cmm/CmmRewriteAssignments.hs ghc-7.2.1/compiler/cmm/CmmRewriteAssignments.hs --- ghc-7.0.3/compiler/cmm/CmmRewriteAssignments.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/compiler/cmm/CmmRewriteAssignments.hs 2011-08-07 17:10:05.000000000 +0000 @@ -0,0 +1,628 @@ +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE FlexibleContexts #-} + +{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} + +-- TODO: Get rid of this flag: +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} + +-- This module implements generalized code motion for assignments to +-- local registers, inlining and sinking when possible. It also does +-- some amount of rewriting for stores to register slots, which are +-- effectively equivalent to local registers. +module CmmRewriteAssignments + ( rewriteAssignments + ) where + +import Cmm +import CmmExpr +import CmmOpt +import OptimizationFuel +import StgCmmUtils + +import Control.Monad +import UniqFM +import Unique +import BlockId + +import Compiler.Hoopl hiding (Unique) +import Data.Maybe +import Prelude hiding (succ, zip) + +---------------------------------------------------------------- +--- Main function + +rewriteAssignments :: CmmGraph -> FuelUniqSM CmmGraph +rewriteAssignments g = do + -- Because we need to act on forwards and backwards information, we + -- first perform usage analysis and bake this information into the + -- graph (backwards transform), and then do a forwards transform + -- to actually perform inlining and sinking. + g' <- annotateUsage g + g'' <- liftM fst $ dataflowPassFwd g' [(g_entry g, fact_bot assignmentLattice)] $ + analRewFwd assignmentLattice + assignmentTransfer + (assignmentRewrite `thenFwdRw` machOpFoldRewrite) + return (modifyGraph eraseRegUsage g'') + +---------------------------------------------------------------- +--- Usage information + +-- We decorate all register assignments with approximate usage +-- information, that is, the maximum number of times the register is +-- referenced while it is live along all outgoing control paths. +-- This analysis provides a precise upper bound for usage, so if a +-- register is never referenced, we can remove it, as that assignment is +-- dead. +-- +-- This analysis is very similar to liveness analysis; we just keep a +-- little extra info. (Maybe we should move it to CmmLive, and subsume +-- the old liveness analysis.) +-- +-- There are a few subtleties here: +-- +-- - If a register goes dead, and then becomes live again, the usages +-- of the disjoint live range don't count towards the original range. +-- +-- a = 1; // used once +-- b = a; +-- a = 2; // used once +-- c = a; +-- +-- - A register may be used multiple times, but these all reside in +-- different control paths, such that any given execution only uses +-- it once. In that case, the usage count may still be 1. +-- +-- a = 1; // used once +-- if (b) { +-- c = a + 3; +-- } else { +-- c = a + 1; +-- } +-- +-- This policy corresponds to an inlining strategy that does not +-- duplicate computation but may increase binary size. +-- +-- - If we naively implement a usage count, we have a counting to +-- infinity problem across joins. Furthermore, knowing that +-- something is used 2 or more times in one runtime execution isn't +-- particularly useful for optimizations (inlining may be beneficial, +-- but there's no way of knowing that without register pressure +-- information.) +-- +-- while (...) { +-- // first iteration, b used once +-- // second iteration, b used twice +-- // third iteration ... +-- a = b; +-- } +-- // b used zero times +-- +-- There is an orthogonal question, which is that for every runtime +-- execution, the register may be used only once, but if we inline it +-- in every conditional path, the binary size might increase a lot. +-- But tracking this information would be tricky, because it violates +-- the finite lattice restriction Hoopl requires for termination; +-- we'd thus need to supply an alternate proof, which is probably +-- something we should defer until we actually have an optimization +-- that would take advantage of this. (This might also interact +-- strangely with liveness information.) +-- +-- a = ...; +-- // a is used one time, but in X different paths +-- case (b) of +-- 1 -> ... a ... +-- 2 -> ... a ... +-- 3 -> ... a ... +-- ... +-- +-- - Memory stores to local register slots (CmmStore (CmmStackSlot +-- (LocalReg _) 0) _) have similar behavior to local registers, +-- in that these locations are all disjoint from each other. Thus, +-- we attempt to inline them too. Note that because these are only +-- generated as part of the spilling process, most of the time this +-- will refer to a local register and the assignment will immediately +-- die on the subsequent call. However, if we manage to replace that +-- local register with a memory location, it means that we've managed +-- to preserve a value on the stack without having to move it to +-- another memory location again! We collect usage information just +-- to be safe in case extra computation is involved. + +data RegUsage = SingleUse | ManyUse + deriving (Ord, Eq, Show) +-- Absence in map = ZeroUse + +{- +-- minBound is bottom, maxBound is top, least-upper-bound is max +-- ToDo: Put this in Hoopl. Note that this isn't as useful as I +-- originally hoped, because you usually want to leave out the bottom +-- element when you have things like this put in maps. Maybe f is +-- useful on its own as a combining function. +boundedOrdLattice :: (Bounded a, Ord a) => String -> DataflowLattice a +boundedOrdLattice n = DataflowLattice n minBound f + where f _ (OldFact x) (NewFact y) + | x >= y = (NoChange, x) + | otherwise = (SomeChange, y) +-} + +-- Custom node type we'll rewrite to. CmmAssign nodes to local +-- registers are replaced with AssignLocal nodes. +data WithRegUsage n e x where + -- Plain will not contain CmmAssign nodes immediately after + -- transformation, but as we rewrite assignments, we may have + -- assignments here: these are assignments that should not be + -- rewritten! + Plain :: n e x -> WithRegUsage n e x + AssignLocal :: LocalReg -> CmmExpr -> RegUsage -> WithRegUsage n O O + +instance UserOfLocalRegs (n e x) => UserOfLocalRegs (WithRegUsage n e x) where + foldRegsUsed f z (Plain n) = foldRegsUsed f z n + foldRegsUsed f z (AssignLocal _ e _) = foldRegsUsed f z e + +instance DefinerOfLocalRegs (n e x) => DefinerOfLocalRegs (WithRegUsage n e x) where + foldRegsDefd f z (Plain n) = foldRegsDefd f z n + foldRegsDefd f z (AssignLocal r _ _) = foldRegsDefd f z r + +instance NonLocal n => NonLocal (WithRegUsage n) where + entryLabel (Plain n) = entryLabel n + successors (Plain n) = successors n + +liftRegUsage :: Graph n e x -> Graph (WithRegUsage n) e x +liftRegUsage = mapGraph Plain + +eraseRegUsage :: Graph (WithRegUsage CmmNode) e x -> Graph CmmNode e x +eraseRegUsage = mapGraph f + where f :: WithRegUsage CmmNode e x -> CmmNode e x + f (AssignLocal l e _) = CmmAssign (CmmLocal l) e + f (Plain n) = n + +type UsageMap = UniqFM RegUsage + +usageLattice :: DataflowLattice UsageMap +usageLattice = DataflowLattice "usage counts for registers" emptyUFM (joinUFM f) + where f _ (OldFact x) (NewFact y) + | x >= y = (NoChange, x) + | otherwise = (SomeChange, y) + +-- We reuse the names 'gen' and 'kill', although we're doing something +-- slightly different from the Dragon Book +usageTransfer :: BwdTransfer (WithRegUsage CmmNode) UsageMap +usageTransfer = mkBTransfer3 first middle last + where first _ f = f + middle :: WithRegUsage CmmNode O O -> UsageMap -> UsageMap + middle n f = gen_kill n f + last :: WithRegUsage CmmNode O C -> FactBase UsageMap -> UsageMap + -- Checking for CmmCall/CmmForeignCall is unnecessary, because + -- spills/reloads have already occurred by the time we do this + -- analysis. + -- XXX Deprecated warning is puzzling: what label are we + -- supposed to use? + -- ToDo: With a bit more cleverness here, we can avoid + -- disappointment and heartbreak associated with the inability + -- to inline into CmmCall and CmmForeignCall by + -- over-estimating the usage to be ManyUse. + last n f = gen_kill n (joinOutFacts usageLattice n f) + gen_kill :: WithRegUsage CmmNode e x -> UsageMap -> UsageMap + gen_kill a = gen a . kill a + gen :: WithRegUsage CmmNode e x -> UsageMap -> UsageMap + gen a f = foldRegsUsed increaseUsage f a + kill :: WithRegUsage CmmNode e x -> UsageMap -> UsageMap + kill a f = foldRegsDefd delFromUFM f a + increaseUsage f r = addToUFM_C combine f r SingleUse + where combine _ _ = ManyUse + +usageRewrite :: BwdRewrite FuelUniqSM (WithRegUsage CmmNode) UsageMap +usageRewrite = mkBRewrite3 first middle last + where first _ _ = return Nothing + middle :: Monad m => WithRegUsage CmmNode O O -> UsageMap -> m (Maybe (Graph (WithRegUsage CmmNode) O O)) + middle (Plain (CmmAssign (CmmLocal l) e)) f + = return . Just + $ case lookupUFM f l of + Nothing -> emptyGraph + Just usage -> mkMiddle (AssignLocal l e usage) + middle _ _ = return Nothing + last _ _ = return Nothing + +type CmmGraphWithRegUsage = GenCmmGraph (WithRegUsage CmmNode) +annotateUsage :: CmmGraph -> FuelUniqSM (CmmGraphWithRegUsage) +annotateUsage vanilla_g = + let g = modifyGraph liftRegUsage vanilla_g + in liftM fst $ dataflowPassBwd g [(g_entry g, fact_bot usageLattice)] $ + analRewBwd usageLattice usageTransfer usageRewrite + +---------------------------------------------------------------- +--- Assignment tracking + +-- The idea is to maintain a map of local registers do expressions, +-- such that the value of that register is the same as the value of that +-- expression at any given time. We can then do several things, +-- as described by Assignment. + +-- Assignment describes the various optimizations that are valid +-- at a given point in the program. +data Assignment = +-- This assignment can always be inlined. It is cheap or single-use. + AlwaysInline CmmExpr +-- This assignment should be sunk down to its first use. (This will +-- increase code size if the register is used in multiple control flow +-- paths, but won't increase execution time, and the reduction of +-- register pressure is worth it, I think.) + | AlwaysSink CmmExpr +-- We cannot safely optimize occurrences of this local register. (This +-- corresponds to top in the lattice structure.) + | NeverOptimize + +-- Extract the expression that is being assigned to +xassign :: Assignment -> Maybe CmmExpr +xassign (AlwaysInline e) = Just e +xassign (AlwaysSink e) = Just e +xassign NeverOptimize = Nothing + +-- Extracts the expression, but only if they're the same constructor +xassign2 :: (Assignment, Assignment) -> Maybe (CmmExpr, CmmExpr) +xassign2 (AlwaysInline e, AlwaysInline e') = Just (e, e') +xassign2 (AlwaysSink e, AlwaysSink e') = Just (e, e') +xassign2 _ = Nothing + +-- Note: We'd like to make decisions about "not optimizing" as soon as +-- possible, because this will make running the transfer function more +-- efficient. +type AssignmentMap = UniqFM Assignment + +assignmentLattice :: DataflowLattice AssignmentMap +assignmentLattice = DataflowLattice "assignments for registers" emptyUFM (joinUFM add) + where add _ (OldFact old) (NewFact new) + = case (old, new) of + (NeverOptimize, _) -> (NoChange, NeverOptimize) + (_, NeverOptimize) -> (SomeChange, NeverOptimize) + (xassign2 -> Just (e, e')) + | e == e' -> (NoChange, old) + | otherwise -> (SomeChange, NeverOptimize) + _ -> (SomeChange, NeverOptimize) + +-- Deletes sinks from assignment map, because /this/ is the place +-- where it will be sunk to. +deleteSinks :: UserOfLocalRegs n => n -> AssignmentMap -> AssignmentMap +deleteSinks n m = foldRegsUsed (adjustUFM f) m n + where f (AlwaysSink _) = NeverOptimize + f old = old + +-- Invalidates any expressions that use a register. +invalidateUsersOf :: CmmReg -> AssignmentMap -> AssignmentMap +-- foldUFM_Directly :: (Unique -> elt -> a -> a) -> a -> UniqFM elt -> a +invalidateUsersOf reg m = foldUFM_Directly f m m -- [foldUFM performance] + where f u (xassign -> Just e) m | reg `regUsedIn` e = addToUFM_Directly m u NeverOptimize + f _ _ m = m +{- This requires the entire spine of the map to be continually rebuilt, + - which causes crazy memory usage! +invalidateUsersOf reg = mapUFM (invalidateUsers' reg) + where invalidateUsers' reg (xassign -> Just e) | reg `regUsedIn` e = NeverOptimize + invalidateUsers' _ old = old +-} + +-- Note [foldUFM performance] +-- These calls to fold UFM no longer leak memory, but they do cause +-- pretty killer amounts of allocation. So they'll be something to +-- optimize; we need an algorithmic change to prevent us from having to +-- traverse the /entire/ map continually. + +middleAssignment :: WithRegUsage CmmNode O O -> AssignmentMap -> AssignmentMap + +-- Algorithm for annotated assignments: +-- 1. Delete any sinking assignments that were used by this instruction +-- 2. Add the assignment to our list of valid local assignments with +-- the correct optimization policy. +-- 3. Look for all assignments that reference that register and +-- invalidate them. +middleAssignment n@(AssignLocal r e usage) assign + = invalidateUsersOf (CmmLocal r) . add . deleteSinks n $ assign + where add m = addToUFM m r + $ case usage of + SingleUse -> AlwaysInline e + ManyUse -> decide e + decide CmmLit{} = AlwaysInline e + decide CmmReg{} = AlwaysInline e + decide CmmLoad{} = AlwaysSink e + decide CmmStackSlot{} = AlwaysSink e + decide CmmMachOp{} = AlwaysSink e + -- We'll always inline simple operations on the global + -- registers, to reduce register pressure: Sp - 4 or Hp - 8 + -- EZY: Justify this optimization more carefully. + decide CmmRegOff{} = AlwaysInline e + +-- Algorithm for unannotated assignments of global registers: +-- 1. Delete any sinking assignments that were used by this instruction +-- 2. Look for all assignments that reference this register and +-- invalidate them. +middleAssignment (Plain n@(CmmAssign reg@(CmmGlobal _) _)) assign + = invalidateUsersOf reg . deleteSinks n $ assign + +-- Algorithm for unannotated assignments of *local* registers: do +-- nothing (it's a reload, so no state should have changed) +middleAssignment (Plain (CmmAssign (CmmLocal _) _)) assign = assign + +-- Algorithm for stores: +-- 1. Delete any sinking assignments that were used by this instruction +-- 2. Look for all assignments that load from memory locations that +-- were clobbered by this store and invalidate them. +middleAssignment (Plain n@(CmmStore lhs rhs)) assign + = let m = deleteSinks n assign + in foldUFM_Directly f m m -- [foldUFM performance] + where f u (xassign -> Just x) m | (lhs, rhs) `clobbers` (u, x) = addToUFM_Directly m u NeverOptimize + f _ _ m = m +{- Also leaky + = mapUFM_Directly p . deleteSinks n $ assign + -- ToDo: There's a missed opportunity here: even if a memory + -- access we're attempting to sink gets clobbered at some + -- location, it's still /better/ to sink it to right before the + -- point where it gets clobbered. How might we do this? + -- Unfortunately, it's too late to change the assignment... + where p r (xassign -> Just x) | (lhs, rhs) `clobbers` (r, x) = NeverOptimize + p _ old = old +-} + +-- Assumption: Unsafe foreign calls don't clobber memory +-- Since foreign calls clobber caller saved registers, we need +-- invalidate any assignments that reference those global registers. +-- This is kind of expensive. (One way to optimize this might be to +-- store extra information about expressions that allow this and other +-- checks to be done cheaply.) +middleAssignment (Plain n@(CmmUnsafeForeignCall{})) assign + = deleteCallerSaves (foldRegsDefd (\m r -> addToUFM m r NeverOptimize) (deleteSinks n assign) n) + where deleteCallerSaves m = foldUFM_Directly f m m + f u (xassign -> Just x) m | wrapRecExpf g x False = addToUFM_Directly m u NeverOptimize + f _ _ m = m + g (CmmReg (CmmGlobal r)) _ | callerSaves r = True + g (CmmRegOff (CmmGlobal r) _) _ | callerSaves r = True + g _ b = b + +middleAssignment (Plain (CmmComment {})) assign + = assign + +-- Assumptions: +-- * Writes using Hp do not overlap with any other memory locations +-- (An important invariant being relied on here is that we only ever +-- use Hp to allocate values on the heap, which appears to be the +-- case given hpReg usage, and that our heap writing code doesn't +-- do anything stupid like overlapping writes.) +-- * Stack slots do not overlap with any other memory locations +-- * Stack slots for different areas do not overlap +-- * Stack slots within the same area and different offsets may +-- overlap; we need to do a size check (see 'overlaps'). +-- * Register slots only overlap with themselves. (But this shouldn't +-- happen in practice, because we'll fail to inline a reload across +-- the next spill.) +-- * Non stack-slot stores always conflict with each other. (This is +-- not always the case; we could probably do something special for Hp) +clobbers :: (CmmExpr, CmmExpr) -- (lhs, rhs) of clobbering CmmStore + -> (Unique, CmmExpr) -- (register, expression) that may be clobbered + -> Bool +clobbers (CmmRegOff (CmmGlobal Hp) _, _) (_, _) = False +clobbers (CmmReg (CmmGlobal Hp), _) (_, _) = False +-- ToDo: Also catch MachOp case +clobbers (ss@CmmStackSlot{}, CmmReg (CmmLocal r)) (u, CmmLoad (ss'@CmmStackSlot{}) _) + | getUnique r == u, ss == ss' = False -- No-op on the stack slot (XXX: Do we need this special case?) +clobbers (CmmStackSlot (CallArea a) o, rhs) (_, expr) = f expr + where f (CmmLoad (CmmStackSlot (CallArea a') o') t) + = (a, o, widthInBytes (cmmExprWidth rhs)) `overlaps` (a', o', widthInBytes (typeWidth t)) + f (CmmLoad e _) = containsStackSlot e + f (CmmMachOp _ es) = or (map f es) + f _ = False + -- Maybe there's an invariant broken if this actually ever + -- returns True + containsStackSlot (CmmLoad{}) = True -- load of a load, all bets off + containsStackSlot (CmmMachOp _ es) = or (map containsStackSlot es) + containsStackSlot (CmmStackSlot{}) = True + containsStackSlot _ = False +clobbers (CmmStackSlot (RegSlot l) _, _) (_, expr) = f expr + where f (CmmLoad (CmmStackSlot (RegSlot l') _) _) = l == l' + f _ = False +clobbers _ (_, e) = f e + where f (CmmLoad (CmmStackSlot _ _) _) = False + f (CmmLoad{}) = True -- conservative + f (CmmMachOp _ es) = or (map f es) + f _ = False + +-- Check for memory overlapping. +-- Diagram: +-- 4 8 12 +-- s -w- o +-- [ I32 ] +-- [ F64 ] +-- s' -w'- o' +type CallSubArea = (AreaId, Int, Int) -- area, offset, width +overlaps :: CallSubArea -> CallSubArea -> Bool +overlaps (a, _, _) (a', _, _) | a /= a' = False +overlaps (_, o, w) (_, o', w') = + let s = o - w + s' = o' - w' + in (s' < o) && (s < o) -- Not LTE, because [ I32 ][ I32 ] is OK + +lastAssignment :: WithRegUsage CmmNode O C -> AssignmentMap -> [(Label, AssignmentMap)] +lastAssignment (Plain (CmmCall _ (Just k) _ _ _)) assign = [(k, invalidateVolatile k assign)] +lastAssignment (Plain (CmmForeignCall {succ=k})) assign = [(k, invalidateVolatile k assign)] +lastAssignment l assign = map (\id -> (id, deleteSinks l assign)) $ successors l + +-- Invalidates any expressions that have volatile contents: essentially, +-- all terminals volatile except for literals and loads of stack slots +-- that do not correspond to the call area for 'k' (the current call +-- area is volatile because overflow return parameters may be written +-- there.) +-- Note: mapUFM could be expensive, but hopefully block boundaries +-- aren't too common. If it is a problem, replace with something more +-- clever. +invalidateVolatile :: BlockId -> AssignmentMap -> AssignmentMap +invalidateVolatile k m = mapUFM p m + where p (AlwaysInline e) = if exp e then AlwaysInline e else NeverOptimize + where exp CmmLit{} = True + exp (CmmLoad (CmmStackSlot (CallArea (Young k')) _) _) + | k' == k = False + exp (CmmLoad (CmmStackSlot _ _) _) = True + exp (CmmMachOp _ es) = and (map exp es) + exp _ = False + p _ = NeverOptimize -- probably shouldn't happen with AlwaysSink + +assignmentTransfer :: FwdTransfer (WithRegUsage CmmNode) AssignmentMap +assignmentTransfer = mkFTransfer3 (flip const) middleAssignment ((mkFactBase assignmentLattice .) . lastAssignment) + +-- Note [Soundness of inlining] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- In the Hoopl paper, the soundness condition on rewrite functions is +-- described as follows: +-- +-- "If it replaces a node n by a replacement graph g, then g must +-- be observationally equivalent to n under the assumptions +-- expressed by the incoming dataflow fact f. Moreover, analysis of +-- g must produce output fact(s) that are at least as informative +-- as the fact(s) produced by applying the transfer function to n." +-- +-- We consider the second condition in more detail here. It says given +-- the rewrite R(n, f) = g, then for any incoming fact f' consistent +-- with f (f' >= f), then running the transfer function T(f', n) <= T(f', g). +-- For inlining this is not necessarily the case: +-- +-- n = "x = a + 2" +-- f = f' = {a = y} +-- g = "x = y + 2" +-- T(f', n) = {x = a + 2, a = y} +-- T(f', g) = {x = y + 2, a = y} +-- +-- y + 2 and a + 2 are not obviously comparable, and a naive +-- implementation of the lattice would say they are incomparable. +-- At best, this means we may be over-conservative, at worst, it means +-- we may not terminate. +-- +-- However, in the original Lerner-Grove-Chambers paper, soundness and +-- termination are separated, and only equivalence of facts is required +-- for soundness. Monotonicity of the transfer function is not required +-- for termination (as the calculation of least-upper-bound prevents +-- this from being a problem), but it means we won't necessarily find +-- the least-fixed point. + +-- Note [Coherency of annotations] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Is it possible for our usage annotations to become invalid after we +-- start performing transformations? As the usage info only provides +-- an upper bound, we only need to consider cases where the usages of +-- a register may increase due to transformations--e.g. any reference +-- to a local register in an AlwaysInline or AlwaysSink instruction, whose +-- originating assignment was single use (we don't care about the +-- many use case, because it is the top of the lattice). But such a +-- case is not possible, because we always inline any single use +-- register. QED. +-- +-- TODO: A useful lint option would be to check this invariant that +-- there is never a local register in the assignment map that is +-- single-use. + +-- Note [Soundness of store rewriting] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Its soundness depends on the invariant that no assignment is made to +-- the local register before its store is accessed. This is clearly +-- true with unoptimized spill-reload code, and as the store will always +-- be rewritten first (if possible), there is no chance of it being +-- propagated down before getting written (possibly with incorrect +-- values from the assignment map, due to reassignment of the local +-- register.) This is probably not locally sound. + +assignmentRewrite :: FwdRewrite FuelUniqSM (WithRegUsage CmmNode) AssignmentMap +assignmentRewrite = mkFRewrite3 first middle last + where + first _ _ = return Nothing + middle :: WithRegUsage CmmNode O O -> AssignmentMap -> GenCmmReplGraph (WithRegUsage CmmNode) O O + middle (Plain m) assign = return $ rewrite assign (precompute assign m) mkMiddle m + middle (AssignLocal l e u) assign = return $ rewriteLocal assign (precompute assign (CmmAssign (CmmLocal l) e)) l e u + last (Plain l) assign = return $ rewrite assign (precompute assign l) mkLast l + -- Tuple is (inline?, reloads for sinks) + precompute :: AssignmentMap -> CmmNode O x -> (Bool, [WithRegUsage CmmNode O O]) + precompute assign n = foldRegsUsed f (False, []) n -- duplicates are harmless + where f (i, l) r = case lookupUFM assign r of + Just (AlwaysSink e) -> (i, (Plain (CmmAssign (CmmLocal r) e)):l) + Just (AlwaysInline _) -> (True, l) + Just NeverOptimize -> (i, l) + -- This case can show up when we have + -- limited optimization fuel. + Nothing -> (i, l) + rewrite :: AssignmentMap + -> (Bool, [WithRegUsage CmmNode O O]) + -> (WithRegUsage CmmNode O x -> Graph (WithRegUsage CmmNode) O x) + -> CmmNode O x + -> Maybe (Graph (WithRegUsage CmmNode) O x) + rewrite _ (False, []) _ _ = Nothing + -- Note [CmmCall Inline Hack] + -- Conservative hack: don't do any inlining on what will + -- be translated into an OldCmm CmmCalls, since the code + -- produced here tends to be unproblematic and I need to write + -- lint passes to ensure that we don't put anything in the + -- arguments that could be construed as a global register by + -- some later translation pass. (For example, slots will turn + -- into dereferences of Sp). See [Register parameter passing]. + -- ToDo: Fix this up to only bug out if all inlines were for + -- CmmExprs with global registers (we can't use the + -- straightforward mapExpDeep call, in this case.) ToDo: We miss + -- an opportunity here, where all possible inlinings should + -- instead be sunk. + rewrite _ (True, []) _ n | not (inlinable n) = Nothing -- see [CmmCall Inline Hack] + rewrite assign (i, xs) mk n = Just $ mkMiddles xs <*> mk (Plain (inline i assign n)) + + rewriteLocal :: AssignmentMap + -> (Bool, [WithRegUsage CmmNode O O]) + -> LocalReg -> CmmExpr -> RegUsage + -> Maybe (Graph (WithRegUsage CmmNode) O O) + rewriteLocal _ (False, []) _ _ _ = Nothing + rewriteLocal assign (i, xs) l e u = Just $ mkMiddles xs <*> mkMiddle n' + where n' = AssignLocal l e' u + e' = if i then wrapRecExp (inlineExp assign) e else e + -- inlinable check omitted, since we can always inline into + -- assignments. + + inline :: Bool -> AssignmentMap -> CmmNode e x -> CmmNode e x + inline False _ n = n + inline True _ n | not (inlinable n) = n -- see [CmmCall Inline Hack] + inline True assign n = mapExpDeep (inlineExp assign) n + + inlineExp assign old@(CmmReg (CmmLocal r)) + = case lookupUFM assign r of + Just (AlwaysInline x) -> x + _ -> old + inlineExp assign old@(CmmRegOff (CmmLocal r) i) + = case lookupUFM assign r of + Just (AlwaysInline x) -> + case x of + (CmmRegOff r' i') -> CmmRegOff r' (i + i') + _ -> CmmMachOp (MO_Add rep) [x, CmmLit (CmmInt (fromIntegral i) rep)] + where rep = typeWidth (localRegType r) + _ -> old + -- See Note [Soundness of store rewriting] + inlineExp assign old@(CmmLoad (CmmStackSlot (RegSlot r) _) _) + = case lookupUFM assign r of + Just (AlwaysInline x) -> x + _ -> old + inlineExp _ old = old + + inlinable :: CmmNode e x -> Bool + inlinable (CmmCall{}) = False + inlinable (CmmForeignCall{}) = False + inlinable (CmmUnsafeForeignCall{}) = False + inlinable _ = True + +-- Need to interleave this with inlining, because machop folding results +-- in literals, which we can inline more aggressively, and inlining +-- gives us opportunities for more folding. However, we don't need any +-- facts to do MachOp folding. +machOpFoldRewrite :: FwdRewrite FuelUniqSM (WithRegUsage CmmNode) a +machOpFoldRewrite = mkFRewrite3 first middle last + where first _ _ = return Nothing + middle :: WithRegUsage CmmNode O O -> a -> GenCmmReplGraph (WithRegUsage CmmNode) O O + middle (Plain m) _ = return (fmap (mkMiddle . Plain) (foldNode m)) + middle (AssignLocal l e r) _ = return (fmap f (wrapRecExpM foldExp e)) + where f e' = mkMiddle (AssignLocal l e' r) + last :: WithRegUsage CmmNode O C -> a -> GenCmmReplGraph (WithRegUsage CmmNode) O C + last (Plain l) _ = return (fmap (mkLast . Plain) (foldNode l)) + foldNode :: CmmNode e x -> Maybe (CmmNode e x) + foldNode n = mapExpDeepM foldExp n + foldExp (CmmMachOp op args) = cmmMachOpFoldM op args + foldExp _ = Nothing + +-- ToDo: Outputable instance for UsageMap and AssignmentMap diff -Nru ghc-7.0.3/compiler/cmm/CmmSpillReload.hs ghc-7.2.1/compiler/cmm/CmmSpillReload.hs --- ghc-7.0.3/compiler/cmm/CmmSpillReload.hs 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/cmm/CmmSpillReload.hs 2011-08-07 17:10:05.000000000 +0000 @@ -1,297 +1,152 @@ -#if __GLASGOW_HASKELL__ >= 611 -{-# OPTIONS_GHC -XNoMonoLocalBinds #-} -#endif +{-# LANGUAGE GADTs, NoMonoLocalBinds, FlexibleContexts #-} -- Norman likes local bindings -- If this module lives on I'd like to get rid of this flag in due course +{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} + +-- TODO: Get rid of this flag: +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} + module CmmSpillReload - ( DualLive(..) - , dualLiveLattice, dualLiveTransfers, dualLiveness - --, insertSpillsAndReloads --- XXX todo check live-in at entry against formals - , dualLivenessWithInsertion - - , availRegsLattice - , cmmAvailableReloads - , insertLateReloads - , removeDeadAssignmentsAndReloads + ( dualLivenessWithInsertion ) where import BlockId +import Cmm import CmmExpr -import CmmTx -import CmmLiveZ -import DFMonad -import MkZipCfg -import PprCmm() -import ZipCfg -import ZipCfgCmmRep -import ZipDataflow +import CmmLive +import OptimizationFuel import Control.Monad import Outputable hiding (empty) import qualified Outputable as PP import UniqSet +import Compiler.Hoopl hiding (Unique) import Data.Maybe -import Prelude hiding (zip) +import Prelude hiding (succ, zip) {- Note [Overview of spill/reload] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The point of this module is to insert spills and reloads to -establish the invariant that at a call (or at any proc point with -an established protocol) all live variables not expected in -registers are sitting on the stack. We use a backward analysis to -insert spills and reloads. It should be followed by a -forward transformation to sink reloads as deeply as possible, so as -to reduce register pressure. +The point of this module is to insert spills and reloads to establish +the invariant that at a call or any proc point with an established +protocol all live variables not expected in registers are sitting on the +stack. We use a backward dual liveness analysis (both traditional +register liveness as well as register slot liveness on the stack) to +insert spills and reloads. It should be followed by a forward +transformation to sink reloads as deeply as possible, so as to reduce +register pressure: this transformation is performed by +CmmRewriteAssignments. A variable can be expected to be live in a register, live on the stack, or both. This analysis ensures that spills and reloads are inserted as needed to make sure that every live variable needed -after a call is available on the stack. Spills are pushed back to -their reaching definitions, but reloads are dropped wherever needed -and will have to be sunk by a later forward transformation. +after a call is available on the stack. Spills are placed immediately +after their reaching definitions, but reloads are placed immediately +after a return from a call (the entry point.) + +Note that we offer no guarantees about the consistency of the value +in memory and the value in the register, except that they are +equal across calls/procpoints. If the variable is changed, this +mapping breaks: but as the original value of the register may still +be useful in a different context, the memory location is not updated. -} data DualLive = DualLive { on_stack :: RegSet, in_regs :: RegSet } -dualUnion :: DualLive -> DualLive -> DualLive -dualUnion (DualLive s r) (DualLive s' r') = - DualLive (s `unionUniqSets` s') (r `unionUniqSets` r') - -dualUnionList :: [DualLive] -> DualLive -dualUnionList ls = DualLive ss rs - where ss = unionManyUniqSets $ map on_stack ls - rs = unionManyUniqSets $ map in_regs ls - changeStack, changeRegs :: (RegSet -> RegSet) -> DualLive -> DualLive changeStack f live = live { on_stack = f (on_stack live) } changeRegs f live = live { in_regs = f (in_regs live) } - dualLiveLattice :: DataflowLattice DualLive -dualLiveLattice = - DataflowLattice "variables live in registers and on stack" empty add False +dualLiveLattice = DataflowLattice "variables live in registers and on stack" empty add where empty = DualLive emptyRegSet emptyRegSet - -- | compute in the Tx monad to track whether anything has changed - add new old = do stack <- add1 (on_stack new) (on_stack old) - regs <- add1 (in_regs new) (in_regs old) - return $ DualLive stack regs - add1 = fact_add_to liveLattice - -type LiveReloadFix a = FuelMonad (BackwardFixedPoint Middle Last DualLive a) - -dualLivenessWithInsertion :: BlockSet -> (LGraph Middle Last) -> FuelMonad (LGraph Middle Last) -dualLivenessWithInsertion procPoints g@(LGraph entry _) = - liftM zdfFpContents $ (res :: LiveReloadFix (LGraph Middle Last)) - where res = zdfBRewriteFromL RewriteDeep emptyBlockEnv "dual liveness with insertion" - dualLiveLattice (dualLiveTransfers entry procPoints) - (insertSpillAndReloadRewrites entry procPoints) empty g - empty = fact_bot dualLiveLattice - -dualLiveness :: BlockSet -> LGraph Middle Last -> FuelMonad (BlockEnv DualLive) -dualLiveness procPoints g@(LGraph entry _) = - liftM zdfFpFacts $ (res :: LiveReloadFix ()) - where res = zdfSolveFromL emptyBlockEnv "dual liveness" dualLiveLattice - (dualLiveTransfers entry procPoints) empty g - empty = fact_bot dualLiveLattice - -dualLiveTransfers :: BlockId -> BlockSet -> BackwardTransfers Middle Last DualLive -dualLiveTransfers entry procPoints = BackwardTransfers first middle last - where last = lastDualLiveness - middle = middleDualLiveness - first id live = check live id $ -- live at procPoint => spill - if id /= entry && elemBlockSet id procPoints then - DualLive { on_stack = on_stack live `plusRegSet` in_regs live - , in_regs = emptyRegSet } - else live - check live id x = if id == entry then noLiveOnEntry id (in_regs live) x else x - -middleDualLiveness :: Middle -> DualLive -> DualLive -middleDualLiveness m live = - changeStack updSlots $ changeRegs (middleLiveness m) (changeRegs regs_in live) - where regs_in live = case m of MidForeignCall {} -> emptyRegSet - _ -> live - updSlots live = foldSlotsUsed reload (foldSlotsDefd spill live m) m - spill live s@(RegSlot r, _, _) = check s $ deleteFromRegSet live r - spill live _ = live - reload live s@(RegSlot r, _, _) = check s $ extendRegSet live r - reload live _ = live - check (RegSlot (LocalReg _ ty), o, w) x - | o == w && w == widthInBytes (typeWidth ty) = x - check _ _ = panic "middleDualLiveness unsupported: slices" - -lastDualLiveness :: Last -> (BlockId -> DualLive) -> DualLive -lastDualLiveness l env = last l - where last (LastBranch id) = env id - last l@(LastCall _ Nothing _ _ _) = changeRegs (gen l . kill l) empty - last l@(LastCall _ (Just k) _ _ _) = - -- nothing can be live in registers at this point, unless safe foreign call - let live = env k - live_in = DualLive (on_stack live) (gen l emptyRegSet) - in if isEmptyUniqSet (in_regs live) then live_in - else pprTrace "Offending party:" (ppr k <+> ppr live) $ - panic "live values in registers at call continuation" - last l@(LastCondBranch _ t f) = - changeRegs (gen l . kill l) $ dualUnion (env t) (env f) - last l@(LastSwitch _ tbl) = changeRegs (gen l . kill l) $ dualUnionList $ - map env (catMaybes tbl) - empty = fact_bot dualLiveLattice - -gen :: UserOfLocalRegs a => a -> RegSet -> RegSet -gen a live = foldRegsUsed extendRegSet live a -kill :: DefinerOfLocalRegs a => a -> RegSet -> RegSet -kill a live = foldRegsDefd deleteFromRegSet live a - -insertSpillAndReloadRewrites :: - BlockId -> BlockSet -> BackwardRewrites Middle Last DualLive -insertSpillAndReloadRewrites entry procPoints = - BackwardRewrites first middle last exit - where middle = middleInsertSpillsAndReloads - last _ _ = Nothing - exit = Nothing - first id live = - if id /= entry && elemBlockSet id procPoints then + add _ (OldFact old) (NewFact new) = (changeIf $ change1 || change2, DualLive stack regs) + where (change1, stack) = add1 (on_stack old) (on_stack new) + (change2, regs) = add1 (in_regs old) (in_regs new) + add1 old new = if sizeUniqSet join > sizeUniqSet old then (True, join) else (False, old) + where join = unionUniqSets old new + +dualLivenessWithInsertion :: BlockSet -> CmmGraph -> FuelUniqSM CmmGraph +dualLivenessWithInsertion procPoints g = + liftM fst $ dataflowPassBwd g [] $ analRewBwd dualLiveLattice + (dualLiveTransfers (g_entry g) procPoints) + (insertSpillsAndReloads g procPoints) + +-- Note [Live registers on entry to procpoints] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Remember that the transfer function is only ever run on the rewritten +-- version of a graph, and the rewrite function for spills and reloads +-- enforces the invariant that no local registers are live on entry to +-- a procpoint. Accordingly, we check for this invariant here. An old +-- version of this code incorrectly claimed that any live registers were +-- live on the stack before entering the function: this is wrong, but +-- didn't cause bugs because it never actually was invoked. + +dualLiveTransfers :: BlockId -> BlockSet -> (BwdTransfer CmmNode DualLive) +dualLiveTransfers entry procPoints = mkBTransfer3 first middle last + where first :: CmmNode C O -> DualLive -> DualLive + first (CmmEntry id) live -- See Note [Live registers on entry to procpoints] + | id == entry || setMember id procPoints = noLiveOnEntry id (in_regs live) live + | otherwise = live + + middle :: CmmNode O O -> DualLive -> DualLive + middle m = changeStack updSlots + . changeRegs updRegs + where -- Reuse middle of liveness analysis from CmmLive + updRegs = case getBTransfer3 xferLive of (_, middle, _) -> middle m + + updSlots live = foldSlotsUsed reload (foldSlotsDefd spill live m) m + spill live s@(RegSlot r, _, _) = check s $ deleteFromRegSet live r + spill live _ = live + reload live s@(RegSlot r, _, _) = check s $ extendRegSet live r + reload live _ = live + -- Ensure the assignment refers to the entirety of the + -- register slot (and not just a slice). + check (RegSlot (LocalReg _ ty), o, w) x + | o == w && w == widthInBytes (typeWidth ty) = x + check _ _ = panic "dualLiveTransfers: slices unsupported" + + -- Register analysis is identical to liveness analysis from CmmLive. + last :: CmmNode O C -> FactBase DualLive -> DualLive + last l fb = changeRegs (gen_kill l) $ case l of + CmmCall {cml_cont=Nothing} -> empty + CmmCall {cml_cont=Just k} -> keep_stack_only k + CmmForeignCall {succ=k} -> keep_stack_only k + _ -> joinOutFacts dualLiveLattice l fb + where empty = fact_bot dualLiveLattice + lkp k = fromMaybe empty (lookupFact k fb) + keep_stack_only k = DualLive (on_stack (lkp k)) emptyRegSet + +insertSpillsAndReloads :: CmmGraph -> BlockSet -> CmmBwdRewrite DualLive +insertSpillsAndReloads graph procPoints = deepBwdRw3 first middle nothing + -- Beware: deepBwdRw with one polymorphic function seems more reasonable here, + -- but GHC miscompiles it, see bug #4044. + where first :: CmmNode C O -> Fact O DualLive -> CmmReplGraph C O + first e@(CmmEntry id) live = return $ + if id /= (g_entry graph) && setMember id procPoints then case map reload (uniqSetToList (in_regs live)) of [] -> Nothing - is -> Just (mkMiddles is) + is -> Just $ mkFirst e <*> mkMiddles is else Nothing - -middleInsertSpillsAndReloads :: Middle -> DualLive -> Maybe (AGraph Middle Last) -middleInsertSpillsAndReloads m live = middle m - where middle (MidAssign (CmmLocal reg) (CmmLoad (CmmStackSlot (RegSlot reg') _) _)) - | reg == reg' = Nothing - middle (MidAssign (CmmLocal reg) _) = - if reg `elemRegSet` on_stack live then -- must spill - my_trace "Spilling" (f4sep [text "spill" <+> ppr reg, - text "after", ppr m]) $ - Just $ mkMiddles $ [m, spill reg] - else Nothing - middle (MidForeignCall _ _ fs _) = - case map spill (filter (flip elemRegSet (on_stack live)) fs) ++ - map reload (uniqSetToList (kill fs (in_regs live))) of - [] -> Nothing - reloads -> Just (mkMiddles (m : reloads)) - middle _ = Nothing - --- Generating spill and reload code -regSlot :: LocalReg -> CmmExpr -regSlot r = CmmStackSlot (RegSlot r) (widthInBytes $ typeWidth $ localRegType r) - -spill, reload :: LocalReg -> Middle -spill r = MidStore (regSlot r) (CmmReg $ CmmLocal r) -reload r = MidAssign (CmmLocal r) (CmmLoad (regSlot r) $ localRegType r) - ----------------------------------------------------------------- ---- sinking reloads - --- The idea is to compute at each point the set of registers such that --- on every path to the point, the register is defined by a Reload --- instruction. Then, if a use appears at such a point, we can safely --- insert a Reload right before the use. Finally, we can eliminate --- the early reloads along with other dead assignments. - -data AvailRegs = UniverseMinus RegSet - | AvailRegs RegSet - - -availRegsLattice :: DataflowLattice AvailRegs -availRegsLattice = DataflowLattice "register gotten from reloads" empty add False - where empty = UniverseMinus emptyRegSet - -- | compute in the Tx monad to track whether anything has changed - add new old = - let join = interAvail new old in - if join `smallerAvail` old then aTx join else noTx join - - -interAvail :: AvailRegs -> AvailRegs -> AvailRegs -interAvail (UniverseMinus s) (UniverseMinus s') = UniverseMinus (s `plusRegSet` s') -interAvail (AvailRegs s) (AvailRegs s') = AvailRegs (s `timesRegSet` s') -interAvail (AvailRegs s) (UniverseMinus s') = AvailRegs (s `minusRegSet` s') -interAvail (UniverseMinus s) (AvailRegs s') = AvailRegs (s' `minusRegSet` s ) - -smallerAvail :: AvailRegs -> AvailRegs -> Bool -smallerAvail (AvailRegs _) (UniverseMinus _) = True -smallerAvail (UniverseMinus _) (AvailRegs _) = False -smallerAvail (AvailRegs s) (AvailRegs s') = sizeUniqSet s < sizeUniqSet s' -smallerAvail (UniverseMinus s) (UniverseMinus s') = sizeUniqSet s > sizeUniqSet s' - -extendAvail :: AvailRegs -> LocalReg -> AvailRegs -extendAvail (UniverseMinus s) r = UniverseMinus (deleteFromRegSet s r) -extendAvail (AvailRegs s) r = AvailRegs (extendRegSet s r) - -delFromAvail :: AvailRegs -> LocalReg -> AvailRegs -delFromAvail (UniverseMinus s) r = UniverseMinus (extendRegSet s r) -delFromAvail (AvailRegs s) r = AvailRegs (deleteFromRegSet s r) - -elemAvail :: AvailRegs -> LocalReg -> Bool -elemAvail (UniverseMinus s) r = not $ elemRegSet r s -elemAvail (AvailRegs s) r = elemRegSet r s - -type AvailFix = FuelMonad (ForwardFixedPoint Middle Last AvailRegs ()) - -cmmAvailableReloads :: LGraph Middle Last -> FuelMonad (BlockEnv AvailRegs) -cmmAvailableReloads g = liftM zdfFpFacts $ (res :: AvailFix) - where res = zdfSolveFromL emptyBlockEnv "available reloads" availRegsLattice - avail_reloads_transfer empty g - empty = fact_bot availRegsLattice - -avail_reloads_transfer :: ForwardTransfers Middle Last AvailRegs -avail_reloads_transfer = ForwardTransfers (flip const) middleAvail lastAvail id - -middleAvail :: Middle -> AvailRegs -> AvailRegs -middleAvail (MidAssign (CmmLocal r) (CmmLoad l _)) avail - | l `isStackSlotOf` r = extendAvail avail r -middleAvail (MidAssign lhs _) avail = foldRegsDefd delFromAvail avail lhs -middleAvail (MidStore l (CmmReg (CmmLocal r))) avail - | l `isStackSlotOf` r = avail -middleAvail (MidStore (CmmStackSlot (RegSlot r) _) _) avail = delFromAvail avail r -middleAvail (MidStore {}) avail = avail -middleAvail (MidForeignCall {}) _ = AvailRegs emptyRegSet -middleAvail (MidComment {}) avail = avail - -lastAvail :: Last -> AvailRegs -> LastOutFacts AvailRegs -lastAvail (LastCall _ (Just k) _ _ _) _ = LastOutFacts [(k, AvailRegs emptyRegSet)] -lastAvail l avail = LastOutFacts $ map (\id -> (id, avail)) $ succs l - -type LateReloadFix = FuelMonad (ForwardFixedPoint Middle Last AvailRegs CmmGraph) - -availRewrites :: ForwardRewrites Middle Last AvailRegs -availRewrites = ForwardRewrites first middle last exit - where first _ _ = Nothing - middle m avail = maybe_reload_before avail m (mkMiddle m) - last l avail = maybe_reload_before avail l (mkLast l) - exit _ = Nothing - maybe_reload_before avail node tail = - let used = filterRegsUsed (elemAvail avail) node - in if isEmptyUniqSet used then Nothing - else Just $ reloadTail used tail - reloadTail regset t = foldl rel t $ uniqSetToList regset - where rel t r = mkMiddle (reload r) <*> t - - -insertLateReloads :: (LGraph Middle Last) -> FuelMonad (LGraph Middle Last) -insertLateReloads g = liftM zdfFpContents $ (res :: LateReloadFix) - where res = zdfFRewriteFromL RewriteShallow emptyBlockEnv "insert late reloads" - availRegsLattice avail_reloads_transfer availRewrites bot g - bot = fact_bot availRegsLattice - -removeDeadAssignmentsAndReloads :: BlockSet -> (LGraph Middle Last) -> FuelMonad (LGraph Middle Last) -removeDeadAssignmentsAndReloads procPoints g@(LGraph entry _) = - liftM zdfFpContents $ (res :: LiveReloadFix (LGraph Middle Last)) - where res = zdfBRewriteFromL RewriteDeep emptyBlockEnv "dead-assignment & -reload elim" - dualLiveLattice (dualLiveTransfers entry procPoints) - rewrites (fact_bot dualLiveLattice) g - rewrites = BackwardRewrites nothing middleRemoveDeads nothing Nothing - nothing _ _ = Nothing - -middleRemoveDeads :: Middle -> DualLive -> Maybe (AGraph Middle Last) -middleRemoveDeads (MidAssign (CmmLocal reg') _) live - | not (reg' `elemRegSet` in_regs live) = Just emptyAGraph -middleRemoveDeads _ _ = Nothing - - + -- EZY: There was some dead code for handling the case where + -- we were not splitting procedures. Check Git history if + -- you're interested (circa e26ea0f41). + + middle :: CmmNode O O -> Fact O DualLive -> CmmReplGraph O O + -- Don't add spills next to reloads. + middle (CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot (RegSlot reg') _) _)) _ | reg == reg' = return Nothing + -- Spill if register is live on stack. + middle m@(CmmAssign (CmmLocal reg) _) live + | reg `elemRegSet` on_stack live = return (Just (mkMiddles [m, spill reg])) + middle _ _ = return Nothing + + nothing _ _ = return Nothing + +spill, reload :: LocalReg -> CmmNode O O +spill r = CmmStore (regSlot r) (CmmReg $ CmmLocal r) +reload r = CmmAssign (CmmLocal r) (CmmLoad (regSlot r) $ localRegType r) --------------------- -- prettyprinting @@ -309,16 +164,3 @@ else (ppr_regs "live in regs =" regs), if isEmptyUniqSet stack then PP.empty else (ppr_regs "live on stack =" stack)] - -instance Outputable AvailRegs where - ppr (UniverseMinus s) = if isEmptyUniqSet s then text "" - else ppr_regs "available = all but" s - ppr (AvailRegs s) = if isEmptyUniqSet s then text "" - else ppr_regs "available = " s - -my_trace :: String -> SDoc -> a -> a -my_trace = if False then pprTrace else \_ _ a -> a - -f4sep :: [SDoc] -> SDoc -f4sep [] = fsep [] -f4sep (d:ds) = fsep (d : map (nest 4) ds) diff -Nru ghc-7.0.3/compiler/cmm/CmmStackLayout.hs ghc-7.2.1/compiler/cmm/CmmStackLayout.hs --- ghc-7.0.3/compiler/cmm/CmmStackLayout.hs 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/cmm/CmmStackLayout.hs 2011-08-07 17:10:05.000000000 +0000 @@ -1,33 +1,37 @@ -#if __GLASGOW_HASKELL__ >= 611 -{-# OPTIONS_GHC -XNoMonoLocalBinds #-} -#endif +{-# OPTIONS_GHC -XGADTs -XNoMonoLocalBinds #-} -- Norman likes local bindings -- If this module lives on I'd like to get rid of this flag in due course +-- Todo: remove +{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} + +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} +#if __GLASGOW_HASKELL__ >= 701 +-- GHC 7.0.1 improved incomplete pattern warnings with GADTs +{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} +#endif + module CmmStackLayout ( SlotEnv, liveSlotAnal, liveSlotTransfers, removeLiveSlotDefs - , layout, manifestSP, igraph, areaBuilder + , getSpEntryMap, layout, manifestSP, igraph, areaBuilder , stubSlotsOnDeath ) -- to help crash early during debugging where import Constants -import Prelude hiding (zip, unzip, last) +import Prelude hiding (succ, zip, unzip, last) import BlockId +import Cmm import CmmExpr -import CmmProcPointZ -import CmmTx -import DFMonad +import CmmProcPoint import Maybes -import MkZipCfg -import MkZipCfgCmm hiding (CmmBlock, CmmGraph) +import MkGraph (stackStubExpr) import Control.Monad +import OptimizationFuel import Outputable import SMRep (ByteOff) -import ZipCfg -import ZipCfg as Z -import ZipCfgCmmRep -import ZipDataflow + +import Compiler.Hoopl import Data.Map (Map) import qualified Data.Map as Map @@ -66,24 +70,23 @@ -- a single slot, on insertion. slotLattice :: DataflowLattice SubAreaSet -slotLattice = DataflowLattice "live slots" Map.empty add False - where add new old = case Map.foldRightWithKey addArea (False, old) new of - (True, x) -> aTx x - (False, x) -> noTx x +slotLattice = DataflowLattice "live slots" Map.empty add + where add _ (OldFact old) (NewFact new) = case Map.foldRightWithKey addArea (False, old) new of + (change, x) -> (changeIf change, x) addArea a newSlots z = foldr (addSlot a) z newSlots addSlot a slot (changed, map) = let (c, live) = liveGen slot $ Map.findWithDefault [] a map in (c || changed, Map.insert a live map) +slotLatticeJoin :: [SubAreaSet] -> SubAreaSet +slotLatticeJoin facts = foldr extend (fact_bot slotLattice) facts + where extend fact res = snd $ fact_join slotLattice undefined (OldFact fact) (NewFact res) + type SlotEnv = BlockEnv SubAreaSet -- The sub-areas live on entry to the block -type SlotFix a = FuelMonad (BackwardFixedPoint Middle Last SubAreaSet a) - -liveSlotAnal :: LGraph Middle Last -> FuelMonad SlotEnv -liveSlotAnal g = liftM zdfFpFacts (res :: SlotFix ()) - where res = zdfSolveFromL emptyBlockEnv "live slot analysis" slotLattice - liveSlotTransfers (fact_bot slotLattice) g +liveSlotAnal :: CmmGraph -> FuelUniqSM SlotEnv +liveSlotAnal g = liftM snd $ dataflowPassBwd g [] $ analBwd slotLattice liveSlotTransfers -- Add the subarea s to the subareas in the list-set (possibly coalescing it with -- adjacent subareas), and also return whether s was a new addition. @@ -122,10 +125,22 @@ -- considered live in to the block -- we treat the first node as a definition site. -- BEWARE?: Am I being a little careless here in failing to check for the -- entry Id (which would use the CallArea Old). -liveSlotTransfers :: BackwardTransfers Middle Last SubAreaSet -liveSlotTransfers = - BackwardTransfers first liveInSlots liveLastIn - where first id live = Map.delete (CallArea (Young id)) live +liveSlotTransfers :: BwdTransfer CmmNode SubAreaSet +liveSlotTransfers = mkBTransfer3 frt mid lst + where frt :: CmmNode C O -> SubAreaSet -> SubAreaSet + frt (CmmEntry l) f = Map.delete (CallArea (Young l)) f + + mid :: CmmNode O O -> SubAreaSet -> SubAreaSet + mid n f = foldSlotsUsed addSlot (removeLiveSlotDefs f n) n + lst :: CmmNode O C -> FactBase SubAreaSet -> SubAreaSet + lst n f = liveInSlots n $ case n of + CmmCall {cml_cont=Nothing, cml_args=args} -> add_area (CallArea Old) args out + CmmCall {cml_cont=Just k, cml_args=args} -> add_area (CallArea Old) args (add_area (CallArea (Young k)) args out) + CmmForeignCall {succ=k, updfr=oldend} -> add_area (CallArea Old) oldend (add_area (CallArea (Young k)) wORD_SIZE out) + _ -> out + where out = joinOutFacts slotLattice n f + add_area _ n live | n == 0 = live + add_area a n live = Map.insert a (snd $ liveGen (a, n, n) $ Map.findWithDefault [] a live) live -- Slot sets: adding slots, removing slots, and checking for membership. liftToArea :: Area -> ([SubArea] -> [SubArea]) -> SubAreaSet -> SubAreaSet @@ -143,7 +158,7 @@ liveInSlots :: (DefinerOfSlots s, UserOfSlots s) => s -> SubAreaSet -> SubAreaSet liveInSlots x live = foldSlotsUsed addSlot (removeLiveSlotDefs live x) x -liveLastIn :: Last -> (BlockId -> SubAreaSet) -> SubAreaSet +liveLastIn :: CmmNode O C -> (BlockId -> SubAreaSet) -> SubAreaSet liveLastIn l env = liveInSlots l (liveLastOut env l) -- Don't forget to keep the outgoing parameters in the CallArea live, @@ -153,17 +168,17 @@ -- be a return to keep the update frame live. We'd still better keep the -- info pointer in the update frame live at any call site; -- otherwise we could screw up the garbage collector. -liveLastOut :: (BlockId -> SubAreaSet) -> Last -> SubAreaSet +liveLastOut :: (BlockId -> SubAreaSet) -> CmmNode O C -> SubAreaSet liveLastOut env l = case l of - LastCall _ Nothing n _ _ -> + CmmCall _ Nothing n _ _ -> add_area (CallArea Old) n out -- add outgoing args (includes upd frame) - LastCall _ (Just k) n _ (Just _) -> + CmmCall _ (Just k) n _ _ -> add_area (CallArea Old) n (add_area (CallArea (Young k)) n out) - LastCall _ (Just k) n _ Nothing -> - add_area (CallArea (Young k)) n out + CmmForeignCall { succ = k, updfr = oldend } -> + add_area (CallArea Old) oldend (add_area (CallArea (Young k)) wORD_SIZE out) _ -> out - where out = joinOuts slotLattice env l + where out = slotLatticeJoin $ map env $ successors l add_area _ n live | n == 0 = live add_area a n live = Map.insert a (snd $ liveGen (a, n, n) $ Map.findWithDefault [] a live) live @@ -180,7 +195,7 @@ 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 @@ -189,7 +204,7 @@ words areaSize areaMap a = case Map.lookup a areaMap of Just addr -> [addr .. addr + (Map.lookup a areaSize `orElse` - pprPanic "wordsOccupied: unknown area" (ppr a))] + pprPanic "wordsOccupied: unknown area" (ppr areaSize <+> ppr a))] Nothing -> [] --slotBuilder :: IGraphBuilder (Area, Int) @@ -200,48 +215,52 @@ -- definitions. type IGraph x = Map x (Set x) type IGPair x = (IGraph x, IGraphBuilder x) -igraph :: (Ord x) => IGraphBuilder x -> SlotEnv -> LGraph Middle Last -> IGraph x -igraph builder env g = foldr interfere Map.empty (postorder_dfs g) +igraph :: (Ord x) => IGraphBuilder x -> SlotEnv -> CmmGraph -> IGraph x +igraph builder env g = foldr interfere Map.empty (postorderDfs g) where foldN = foldNodes builder - interfere block igraph = - let (h, l) = goto_end (unzip block) - --heads :: ZHead Middle -> (IGraph x, SubAreaSet) -> IGraph x - heads (ZFirst _) (igraph, _) = igraph - heads (ZHead h m) (igraph, liveOut) = - heads h (addEdges igraph m liveOut, liveInSlots m liveOut) - -- add edges between a def and the other defs and liveouts - addEdges igraph i out = fst $ foldSlotsDefd addDef (igraph, out) i - addDef (igraph, out) def@(a, _, _) = - (foldN def (addDefN out) igraph, - Map.insert a (snd $ liveGen def (Map.findWithDefault [] a out)) out) - addDefN out n igraph = - let addEdgeNO o igraph = foldN o addEdgeNN igraph - addEdgeNN n' igraph = addEdgeNN' n n' $ addEdgeNN' n' n igraph - addEdgeNN' n n' igraph = Map.insert n (Map.insert n' () set) igraph - where set = Map.findWithDefault Map.empty n igraph - in Map.foldRightWithKey (\ _ os igraph -> foldr addEdgeNO igraph os) igraph out - env' bid = lookupBlockEnv env bid `orElse` panic "unknown blockId in igraph" - in heads h $ case l of LastExit -> (igraph, Map.empty) - LastOther l -> (addEdges igraph l $ liveLastOut env' l, - liveLastIn l env') + interfere block igraph = foldBlockNodesB3 (first, middle, last) block igraph + where first _ (igraph, _) = igraph + middle node (igraph, liveOut) = + (addEdges igraph node liveOut, liveInSlots node liveOut) + last node igraph = + (addEdges igraph node $ liveLastOut env' node, liveLastIn node env') + + -- add edges between a def and the other defs and liveouts + addEdges igraph i out = fst $ foldSlotsDefd addDef (igraph, out) i + addDef (igraph, out) def@(a, _, _) = + (foldN def (addDefN out) igraph, + Map.insert a (snd $ liveGen def (Map.findWithDefault [] a out)) out) + addDefN out n igraph = + let addEdgeNO o igraph = foldN o addEdgeNN igraph + addEdgeNN n' igraph = addEdgeNN' n n' $ addEdgeNN' n' n igraph + addEdgeNN' n n' igraph = Map.insert n (Map.insert n' () set) igraph + where set = Map.findWithDefault Map.empty n igraph + in Map.foldRightWithKey (\ _ os igraph -> foldr addEdgeNO igraph os) igraph out + env' bid = mapLookup bid env `orElse` panic "unknown blockId in igraph" -- Before allocating stack slots, we need to collect one more piece of information: -- what's the highest offset (in bytes) used in each Area? -- We'll need to allocate that much space for each Area. -getAreaSize :: ByteOff -> LGraph Middle Last -> AreaMap + +-- 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 -> AreaSizeMap -- The domain of the returned mapping consists only of Areas - -- used for (a) variable spill slots, and (b) parameter passing ares for calls -getAreaSize entry_off g@(LGraph _ _) = - fold_blocks (fold_fwd_block first add_regslots last) + -- 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 where first _ z = z - last l@(LastOther (LastCall _ Nothing args res _)) z = - add_regslots l (add (add z area args) area res) + last :: CmmNode O C -> Map Area Int -> Map Area Int + last l@(CmmCall _ Nothing args res _) z = add_regslots l (add (add z area args) area res) where area = CallArea Old - last l@(LastOther (LastCall _ (Just k) args res _)) z = - add_regslots l (add (add z area args) area res) + last l@(CmmCall _ (Just k) args res _) z = add_regslots l (add (add z area args) area res) where area = CallArea (Young k) - last l z = add_regslots l z + last l@(CmmForeignCall {succ = k}) z = add_regslots l (add z area wORD_SIZE) + where area = CallArea (Young k) + last l z = add_regslots l z add_regslots i z = foldSlotsUsed addSlot (foldSlotsDefd addSlot z i) i addSlot z (a@(RegSlot (LocalReg _ ty)), _, _) = add z a $ widthInBytes $ typeWidth ty @@ -250,10 +269,11 @@ -- 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 @@ -262,10 +282,10 @@ 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) @@ -283,11 +303,24 @@ 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. @@ -310,19 +343,19 @@ -- 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 -> LGraph Middle Last -> 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 = lookupBlockEnv env bid `orElse` panic "unknown blockId in igraph" + env' bid = mapLookup bid env `orElse` panic "unknown blockId in igraph" areaSize = getAreaSize entry_off g - -- Find the slots that are live-in to a block tail - live_in (ZTail m l) = liveInSlots m (live_in l) - live_in (ZLast (LastOther l)) = liveLastIn l env' - live_in (ZLast LastExit) = Map.empty -- Find the youngest live stack slot that has already been allocated youngest_live :: AreaMap -- Already allocated @@ -340,10 +373,10 @@ -- Update the successor's incoming SP. setSuccSPs inSp bid areaMap = - case (Map.lookup area areaMap, lookupBlockEnv (lg_blocks g) bid) of + case (Map.lookup area areaMap , mapLookup bid (toBlockMap g)) of (Just _, _) -> areaMap -- succ already knows incoming SP - (Nothing, Just (Block _ _)) -> - if elemBlockSet bid procPoints then + (Nothing, Just _) -> + if setMember bid procPoints then let young = youngest_live areaMap $ env' bid -- start = case returnOff stackInfo of Just b -> max b young -- Nothing -> young @@ -354,34 +387,91 @@ (_, Nothing) -> panic "Block not found in cfg" where area = CallArea (Young bid) - allocLast (Block id _) areaMap l = - fold_succs (setSuccSPs inSp) l areaMap - where inSp = expectJust "sp in" $ Map.lookup (CallArea (Young id)) areaMap - - allocMidCall m@(MidForeignCall (Safe bid _) _ _ _) t areaMap = - let young = youngest_live areaMap $ removeLiveSlotDefs (live_in t) m - area = CallArea (Young bid) - areaSize' = Map.insert area (widthInBytes (typeWidth gcWord)) areaSize - in allocSlotFrom ig areaSize' young areaMap area - allocMidCall _ _ areaMap = areaMap - - alloc m t areaMap = - foldSlotsDefd alloc' (foldSlotsUsed alloc' (allocMidCall m t areaMap) m) m - where alloc' areaMap (a@(RegSlot _), _, _) = allocVarSlot areaMap a - alloc' areaMap _ = areaMap - - layoutAreas areaMap b@(Block _ t) = layout areaMap t - where layout areaMap (ZTail m t) = layout (alloc m t areaMap) t - layout areaMap (ZLast l) = allocLast b areaMap l - initMap = Map.insert (CallArea (Young (lg_entry g))) 0 - (Map.insert (CallArea Old) 0 Map.empty) - areaMap = foldl layoutAreas initMap (postorder_dfs g) + layoutAreas areaMap block = foldBlockNodesF3 (flip const, allocMid, allocLast (entryLabel block)) block areaMap + allocMid m areaMap = foldSlotsDefd alloc' (foldSlotsUsed alloc' areaMap m) m + allocLast bid l areaMap = + foldr (setSuccSPs inSp) areaMap' (successors l) + 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 + + 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. @@ -391,9 +481,9 @@ -- 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 -> LGraph Middle Last -> FuelMonad (LGraph Middle Last) -manifestSP areaMap entry_off g@(LGraph entry _blocks) = - liftM (LGraph entry) $ foldl replB (return emptyBlockEnv) (postorder_dfs g) +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" slot' (Just id) = slot $ CallArea (Young id) @@ -401,68 +491,73 @@ sp_high = maxSlot slot g proc_entry_sp = slot (CallArea Old) + entry_off - add_sp_off b env = - case Z.last (unzip b) of - LastOther (LastCall {cml_cont = Just succ, cml_ret_args = off}) -> - extendBlockEnv env succ off - _ -> env - spEntryMap = fold_blocks add_sp_off (mkBlockEnv [(entry, entry_off)]) g - spOffset id = lookupBlockEnv spEntryMap id `orElse` 0 + spOffset id = mapLookup id spEntryMap `orElse` 0 sp_on_entry id | id == entry = proc_entry_sp sp_on_entry id = slot' (Just id) + spOffset id -- On entry to procpoints, the stack pointer is conventional; -- otherwise, we check the SP set by predecessors. - replB :: FuelMonad (BlockEnv CmmBlock) -> CmmBlock -> FuelMonad (BlockEnv CmmBlock) - replB blocks (Block id t) = - do bs <- replTail (Block id) spIn t - -- pprTrace "spIn" (ppr id <+> ppr spIn) $ do - liftM (flip (foldr insertBlock) bs) blocks - where spIn = sp_on_entry id - replTail :: (ZTail Middle Last -> CmmBlock) -> Int -> (ZTail Middle Last) -> - FuelMonad ([CmmBlock]) - replTail h spOff (ZTail m@(MidForeignCall (Safe bid _) _ _ _) t) = - replTail (\t' -> h (setSp spOff spOff' (ZTail (middle spOff m) t'))) spOff' t - where spOff' = slot' (Just bid) + widthInBytes (typeWidth gcWord) - replTail h spOff (ZTail m t) = replTail (h . ZTail (middle spOff m)) spOff t - replTail h spOff (ZLast (LastOther l)) = fixSp h spOff l - replTail h _ l@(ZLast LastExit) = return [h l] - middle spOff m = mapExpDeepMiddle (replSlot spOff) m - last spOff l = mapExpDeepLast (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)) - replSlot _ e = e - -- The block must establish the SP expected at each successsor. - fixSp :: (ZTail Middle Last -> CmmBlock) -> Int -> Last -> FuelMonad ([CmmBlock]) - fixSp h spOff l@(LastCall _ k n _ _) = updSp h spOff (slot' k + n) l - fixSp h spOff l@(LastBranch k) = - let succSp = sp_on_entry k in - if succSp /= spOff then - -- pprTrace "updSp" (ppr k <> ppr spOff <> ppr (sp_on_entry k)) $ - updSp h spOff succSp l - else return $ [h (ZLast (LastOther (last spOff l)))] - fixSp h spOff l = liftM (uncurry (:)) $ fold_succs succ l $ return (b, []) - where b = h (ZLast (LastOther (last spOff l))) - succ succId z = - let succSp = sp_on_entry succId in - if succSp /= spOff then - do (b, bs) <- z - (b', bs') <- insertBetween b [setSpMid spOff succSp] succId - return (b', bs ++ bs') - else z - updSp h old new l = return [h $ setSp old new $ ZLast $ LastOther (last new l)] - setSpMid sp sp' = MidAssign (CmmGlobal Sp) e - where e = CmmMachOp (MO_Add wordWidth) [CmmReg (CmmGlobal Sp), off] - off = CmmLit $ CmmInt (toInteger $ sp - sp') wordWidth - setSp sp sp' t = if sp == sp' then t else ZTail (setSpMid sp sp') t + replB :: FuelUniqSM (BlockEnv CmmBlock) -> CmmBlock -> FuelUniqSM (BlockEnv CmmBlock) + replB blocks block = + do let (head, middles, JustC tail :: MaybeC C (CmmNode O C)) = blockToNodeList block + middles' = map (middle spIn) middles + bs <- replLast head middles' tail + flip (foldr insertBlock) bs `liftM` blocks + 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] + replLast h m l@(CmmCall _ k n _ _) = updSp (slot' k + n) h m l + -- JD: LastForeignCall probably ought to have an outgoing + -- arg size, just like LastCall + replLast h m l@(CmmForeignCall {succ=k}) = updSp (slot' (Just k) + wORD_SIZE) h m l + replLast h m l@(CmmBranch k) = updSp (sp_on_entry k) h m l + replLast h m l = uncurry (:) `liftM` foldr succ (return (b, [])) (successors l) + where b :: CmmBlock + b = updSp' spIn h m l + succ succId z = + let succSp = sp_on_entry succId in + if succSp /= spIn then + do (b, bs) <- z + (b', bs') <- insertBetween b (adjustSp succSp) succId + return (b', bs' ++ bs) + else z + + updSp sp h m l = return [updSp' sp h m l] + updSp' sp h m l | sp == spIn = blockOfNodeList (h, m, JustC $ last sp l) + | otherwise = blockOfNodeList (h, m ++ adjustSp sp, JustC $ last sp l) + adjustSp sp = [CmmAssign (CmmGlobal Sp) e] + where e = CmmMachOp (MO_Add wordWidth) [CmmReg (CmmGlobal Sp), off] + off = CmmLit $ CmmInt (toInteger $ spIn - sp) wordWidth -- To compute the stack high-water mark, we fold over the graph and -- compute the highest slot offset. maxSlot :: (Area -> Int) -> CmmGraph -> Int -maxSlot slotOff g = fold_blocks (fold_fwd_block (\ _ x -> x) highSlot highSlot) 0 g +maxSlot slotOff g = foldGraphBlocks (foldBlockNodesF3 (flip const, highSlot, highSlot)) 0 g where highSlot i z = foldSlotsUsed add (foldSlotsDefd add z i) i add z (a, i, _) = max z (slotOff a + i) @@ -472,19 +567,17 @@ -- This will miss stack slots that are last used in a Last node, -- but it should do pretty well... -type StubPtrFix = FuelMonad (BackwardFixedPoint Middle Last SubAreaSet CmmGraph) - -stubSlotsOnDeath :: (LGraph Middle Last) -> FuelMonad (LGraph Middle Last) -stubSlotsOnDeath g = liftM zdfFpContents $ (res :: StubPtrFix) - where res = zdfBRewriteFromL RewriteShallow emptyBlockEnv "stub ptrs" slotLattice - liveSlotTransfers rewrites (fact_bot slotLattice) g - rewrites = BackwardRewrites first middle last Nothing - first _ _ = Nothing - last _ _ = Nothing - middle m liveSlots = foldSlotsUsed (stub liveSlots m) Nothing m +stubSlotsOnDeath :: CmmGraph -> FuelUniqSM CmmGraph +stubSlotsOnDeath g = liftM fst $ dataflowPassBwd g [] $ analRewBwd slotLattice + liveSlotTransfers + rewrites + where rewrites = mkBRewrite3 frt mid lst + frt _ _ = return Nothing + mid m liveSlots = return $ foldSlotsUsed (stub liveSlots m) Nothing m + lst _ _ = return Nothing stub liveSlots m rst subarea@(a, off, w) = if elemSlot liveSlots subarea then rst - else let store = mkStore (CmmStackSlot a off) - (stackStubExpr (widthFromBytes w)) + else let store = mkMiddle $ CmmStore (CmmStackSlot a off) + (stackStubExpr (widthFromBytes w)) in case rst of Nothing -> Just (mkMiddle m <*> store) Just g -> Just (g <*> store) diff -Nru ghc-7.0.3/compiler/cmm/CmmTx.hs ghc-7.2.1/compiler/cmm/CmmTx.hs --- ghc-7.0.3/compiler/cmm/CmmTx.hs 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/cmm/CmmTx.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,58 +0,0 @@ -module CmmTx where - -data ChangeFlag = NoChange | SomeChange - -type Tx a = a -> TxRes a -data TxRes a = TxRes ChangeFlag a - -seqTx :: Tx a -> Tx a -> Tx a -iterateTx :: Tx a -> Tx a -runTx :: Tx a -> a -> a - -noTx, aTx :: a -> TxRes a -noTx x = TxRes NoChange x -aTx x = TxRes SomeChange x - -replaceTx :: a -> TxRes b -> TxRes a -replaceTx a (TxRes change _) = TxRes change a - -txVal :: TxRes a -> a -txVal (TxRes _ a) = a - -txHasChanged :: TxRes a -> Bool -txHasChanged (TxRes NoChange _) = False -txHasChanged (TxRes SomeChange _) = True - -plusTx :: (a -> b -> c) -> TxRes a -> TxRes b -> TxRes c -plusTx f (TxRes c1 a) (TxRes c2 b) = TxRes (c1 `orChange` c2) (f a b) - -mapTx :: Tx a -> Tx [a] -mapTx _ [] = noTx [] -mapTx f (x:xs) = plusTx (:) (f x) (mapTx f xs) - -runTx f = txVal . f - -seqTx f1 f2 a = - let TxRes c1 a1 = f1 a - TxRes c2 a2 = f2 a1 - in TxRes (c1 `orChange` c2) a2 - -iterateTx f a - = case f a of - TxRes NoChange a' -> TxRes NoChange a' - TxRes SomeChange a' -> let TxRes _ a'' = iterateTx f a' - in TxRes SomeChange a'' - -orChange :: ChangeFlag -> ChangeFlag -> ChangeFlag -orChange NoChange c = c -orChange SomeChange _ = SomeChange - - - -instance Functor TxRes where - fmap f (TxRes ch a) = TxRes ch (f a) - -instance Monad TxRes where - return = TxRes NoChange - (TxRes NoChange a) >>= k = k a - (TxRes SomeChange a) >>= k = let (TxRes _ a') = k a in TxRes SomeChange a' diff -Nru ghc-7.0.3/compiler/cmm/CmmType.hs ghc-7.2.1/compiler/cmm/CmmType.hs --- ghc-7.0.3/compiler/cmm/CmmType.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/compiler/cmm/CmmType.hs 2011-08-07 17:10:05.000000000 +0000 @@ -0,0 +1,314 @@ + +module CmmType + ( CmmType -- Abstract + , b8, b16, b32, b64, f32, f64, bWord, bHalfWord, gcWord + , cInt, cLong + , cmmBits, cmmFloat + , typeWidth, cmmEqType, cmmEqType_ignoring_ptrhood + , isFloatType, isGcPtrType, isWord32, isWord64, isFloat64, isFloat32 + + , Width(..) + , widthInBits, widthInBytes, widthInLog, widthFromBytes + , wordWidth, halfWordWidth, cIntWidth, cLongWidth + , narrowU, narrowS + ) +where + +#include "HsVersions.h" + +import Constants +import FastString +import Outputable + +import Data.Word +import Data.Int + +----------------------------------------------------------------------------- +-- CmmType +----------------------------------------------------------------------------- + + -- NOTE: CmmType is an abstract type, not exported from this + -- module so you can easily change its representation + -- + -- However Width is exported in a concrete way, + -- and is used extensively in pattern-matching + +data CmmType -- The important one! + = CmmType CmmCat Width + +data CmmCat -- "Category" (not exported) + = GcPtrCat -- GC pointer + | BitsCat -- Non-pointer + | FloatCat -- Float + deriving( Eq ) + -- See Note [Signed vs unsigned] at the end + +instance Outputable CmmType where + ppr (CmmType cat wid) = ppr cat <> ppr (widthInBits wid) + +instance Outputable CmmCat where + ppr FloatCat = ptext $ sLit("F") + ppr _ = ptext $ sLit("I") + +-- Why is CmmType stratified? For native code generation, +-- most of the time you just want to know what sort of register +-- to put the thing in, and for this you need to know how +-- many bits thing has and whether it goes in a floating-point +-- register. By contrast, the distinction between GcPtr and +-- GcNonPtr is of interest to only a few parts of the code generator. + +-------- Equality on CmmType -------------- +-- CmmType is *not* an instance of Eq; sometimes we care about the +-- Gc/NonGc distinction, and sometimes we don't +-- So we use an explicit function to force you to think about it +cmmEqType :: CmmType -> CmmType -> Bool -- Exact equality +cmmEqType (CmmType c1 w1) (CmmType c2 w2) = c1==c2 && w1==w2 + +cmmEqType_ignoring_ptrhood :: CmmType -> CmmType -> Bool + -- This equality is temporary; used in CmmLint + -- but the RTS files are not yet well-typed wrt pointers +cmmEqType_ignoring_ptrhood (CmmType c1 w1) (CmmType c2 w2) + = c1 `weak_eq` c2 && w1==w2 + where + FloatCat `weak_eq` FloatCat = True + FloatCat `weak_eq` _other = False + _other `weak_eq` FloatCat = False + _word1 `weak_eq` _word2 = True -- Ignores GcPtr + +--- Simple operations on CmmType ----- +typeWidth :: CmmType -> Width +typeWidth (CmmType _ w) = w + +cmmBits, cmmFloat :: Width -> CmmType +cmmBits = CmmType BitsCat +cmmFloat = CmmType FloatCat + +-------- Common CmmTypes ------------ +-- Floats and words of specific widths +b8, b16, b32, b64, f32, f64 :: CmmType +b8 = cmmBits W8 +b16 = cmmBits W16 +b32 = cmmBits W32 +b64 = cmmBits W64 +f32 = cmmFloat W32 +f64 = cmmFloat W64 + +-- CmmTypes of native word widths +bWord, bHalfWord, gcWord :: CmmType +bWord = cmmBits wordWidth +bHalfWord = cmmBits halfWordWidth +gcWord = CmmType GcPtrCat wordWidth + +cInt, cLong :: CmmType +cInt = cmmBits cIntWidth +cLong = cmmBits cLongWidth + + +------------ Predicates ---------------- +isFloatType, isGcPtrType :: CmmType -> Bool +isFloatType (CmmType FloatCat _) = True +isFloatType _other = False + +isGcPtrType (CmmType GcPtrCat _) = True +isGcPtrType _other = False + +isWord32, isWord64, isFloat32, isFloat64 :: CmmType -> Bool +-- isWord64 is true of 64-bit non-floats (both gc-ptrs and otherwise) +-- isFloat32 and 64 are obvious + +isWord64 (CmmType BitsCat W64) = True +isWord64 (CmmType GcPtrCat W64) = True +isWord64 _other = False + +isWord32 (CmmType BitsCat W32) = True +isWord32 (CmmType GcPtrCat W32) = True +isWord32 _other = False + +isFloat32 (CmmType FloatCat W32) = True +isFloat32 _other = False + +isFloat64 (CmmType FloatCat W64) = True +isFloat64 _other = False + +----------------------------------------------------------------------------- +-- Width +----------------------------------------------------------------------------- + +data Width = W8 | W16 | W32 | W64 + | W80 -- Extended double-precision float, + -- used in x86 native codegen only. + -- (we use Ord, so it'd better be in this order) + | W128 + deriving (Eq, Ord, Show) + +instance Outputable Width where + ppr rep = ptext (mrStr rep) + +mrStr :: Width -> LitString +mrStr W8 = sLit("W8") +mrStr W16 = sLit("W16") +mrStr W32 = sLit("W32") +mrStr W64 = sLit("W64") +mrStr W128 = sLit("W128") +mrStr W80 = sLit("W80") + + +-------- Common Widths ------------ +wordWidth, halfWordWidth :: Width +wordWidth | wORD_SIZE == 4 = W32 + | wORD_SIZE == 8 = W64 + | otherwise = panic "MachOp.wordRep: Unknown word size" + +halfWordWidth | wORD_SIZE == 4 = W16 + | wORD_SIZE == 8 = W32 + | otherwise = panic "MachOp.halfWordRep: Unknown word size" + +-- cIntRep is the Width for a C-language 'int' +cIntWidth, cLongWidth :: Width +#if SIZEOF_INT == 4 +cIntWidth = W32 +#elif SIZEOF_INT == 8 +cIntWidth = W64 +#endif + +#if SIZEOF_LONG == 4 +cLongWidth = W32 +#elif SIZEOF_LONG == 8 +cLongWidth = W64 +#endif + +widthInBits :: Width -> Int +widthInBits W8 = 8 +widthInBits W16 = 16 +widthInBits W32 = 32 +widthInBits W64 = 64 +widthInBits W128 = 128 +widthInBits W80 = 80 + +widthInBytes :: Width -> Int +widthInBytes W8 = 1 +widthInBytes W16 = 2 +widthInBytes W32 = 4 +widthInBytes W64 = 8 +widthInBytes W128 = 16 +widthInBytes W80 = 10 + +widthFromBytes :: Int -> Width +widthFromBytes 1 = W8 +widthFromBytes 2 = W16 +widthFromBytes 4 = W32 +widthFromBytes 8 = W64 +widthFromBytes 16 = W128 +widthFromBytes 10 = W80 +widthFromBytes n = pprPanic "no width for given number of bytes" (ppr n) + +-- log_2 of the width in bytes, useful for generating shifts. +widthInLog :: Width -> Int +widthInLog W8 = 0 +widthInLog W16 = 1 +widthInLog W32 = 2 +widthInLog W64 = 3 +widthInLog W128 = 4 +widthInLog W80 = panic "widthInLog: F80" + +-- widening / narrowing + +narrowU :: Width -> Integer -> Integer +narrowU W8 x = fromIntegral (fromIntegral x :: Word8) +narrowU W16 x = fromIntegral (fromIntegral x :: Word16) +narrowU W32 x = fromIntegral (fromIntegral x :: Word32) +narrowU W64 x = fromIntegral (fromIntegral x :: Word64) +narrowU _ _ = panic "narrowTo" + +narrowS :: Width -> Integer -> Integer +narrowS W8 x = fromIntegral (fromIntegral x :: Int8) +narrowS W16 x = fromIntegral (fromIntegral x :: Int16) +narrowS W32 x = fromIntegral (fromIntegral x :: Int32) +narrowS W64 x = fromIntegral (fromIntegral x :: Int64) +narrowS _ _ = panic "narrowTo" + +------------------------------------------------------------------------- +{- Note [Signed vs unsigned] + ~~~~~~~~~~~~~~~~~~~~~~~~~ +Should a CmmType include a signed vs. unsigned distinction? + +This is very much like a "hint" in C-- terminology: it isn't necessary +in order to generate correct code, but it might be useful in that the +compiler can generate better code if it has access to higher-level +hints about data. This is important at call boundaries, because the +definition of a function is not visible at all of its call sites, so +the compiler cannot infer the hints. + +Here in Cmm, we're taking a slightly different approach. We include +the int vs. float hint in the CmmType, because (a) the majority of +platforms have a strong distinction between float and int registers, +and (b) we don't want to do any heavyweight hint-inference in the +native code backend in order to get good code. We're treating the +hint more like a type: our Cmm is always completely consistent with +respect to hints. All coercions between float and int are explicit. + +What about the signed vs. unsigned hint? This information might be +useful if we want to keep sub-word-sized values in word-size +registers, which we must do if we only have word-sized registers. + +On such a system, there are two straightforward conventions for +representing sub-word-sized values: + +(a) Leave the upper bits undefined. Comparison operations must + sign- or zero-extend both operands before comparing them, + depending on whether the comparison is signed or unsigned. + +(b) Always keep the values sign- or zero-extended as appropriate. + Arithmetic operations must narrow the result to the appropriate + size. + +A clever compiler might not use either (a) or (b) exclusively, instead +it would attempt to minimize the coercions by analysis: the same kind +of analysis that propagates hints around. In Cmm we don't want to +have to do this, so we plump for having richer types and keeping the +type information consistent. + +If signed/unsigned hints are missing from CmmType, then the only +choice we have is (a), because we don't know whether the result of an +operation should be sign- or zero-extended. + +Many architectures have extending load operations, which work well +with (b). To make use of them with (a), you need to know whether the +value is going to be sign- or zero-extended by an enclosing comparison +(for example), which involves knowing above the context. This is +doable but more complex. + +Further complicating the issue is foreign calls: a foreign calling +convention can specify that signed 8-bit quantities are passed as +sign-extended 32 bit quantities, for example (this is the case on the +PowerPC). So we *do* need sign information on foreign call arguments. + +Pros for adding signed vs. unsigned to CmmType: + + - It would let us use convention (b) above, and get easier + code generation for extending loads. + + - Less information required on foreign calls. + + - MachOp type would be simpler + +Cons: + + - More complexity + + - What is the CmmType for a VanillaReg? Currently it is + always wordRep, but now we have to decide whether it is + signed or unsigned. The same VanillaReg can thus have + different CmmType in different parts of the program. + + - Extra coercions cluttering up expressions. + +Currently for GHC, the foreign call point is moot, because we do our +own promotion of sub-word-sized values to word-sized values. The Int8 +type is represnted by an Int# which is kept sign-extended at all times +(this is slightly naughty, because we're making assumptions about the +C calling convention rather early on in the compiler). However, given +this, the cons outweigh the pros. + +-} + diff -Nru ghc-7.0.3/compiler/cmm/CmmUtils.hs ghc-7.2.1/compiler/cmm/CmmUtils.hs --- ghc-7.0.3/compiler/cmm/CmmUtils.hs 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/cmm/CmmUtils.hs 2011-08-07 17:10:05.000000000 +0000 @@ -6,10 +6,7 @@ -- ----------------------------------------------------------------------------- -module CmmUtils( - CmmStmts, noStmts, oneStmt, mkStmts, plusStmts, stmtList, - isNopStmt, - +module CmmUtils( primRepCmmType, primRepForeignHint, typeCmmType, typeForeignHint, @@ -21,8 +18,6 @@ mkIntCLit, zeroCLit, mkLblExpr, - - maybeAssignTemp, loadArgsIntoTemps ) where #include "HsVersions.h" @@ -31,10 +26,9 @@ import Type ( Type, typePrimRep ) import CLabel -import Cmm -import OrdList +import CmmDecl +import CmmExpr import Outputable -import Unique --------------------------------------------------- -- @@ -73,55 +67,6 @@ --------------------------------------------------- -- --- CmmStmts --- ---------------------------------------------------- - -type CmmStmts = OrdList CmmStmt - -noStmts :: CmmStmts -noStmts = nilOL - -oneStmt :: CmmStmt -> CmmStmts -oneStmt = unitOL - -mkStmts :: [CmmStmt] -> CmmStmts -mkStmts = toOL - -plusStmts :: CmmStmts -> CmmStmts -> CmmStmts -plusStmts = appOL - -stmtList :: CmmStmts -> [CmmStmt] -stmtList = fromOL - - ---------------------------------------------------- --- --- CmmStmt --- ---------------------------------------------------- - -isNopStmt :: CmmStmt -> Bool --- If isNopStmt returns True, the stmt is definitely a no-op; --- but it might be a no-op even if isNopStmt returns False -isNopStmt CmmNop = True -isNopStmt (CmmAssign r e) = cheapEqReg r e -isNopStmt (CmmStore e1 (CmmLoad e2 _)) = cheapEqExpr e1 e2 -isNopStmt _ = False - -cheapEqExpr :: CmmExpr -> CmmExpr -> Bool -cheapEqExpr (CmmReg r) e = cheapEqReg r e -cheapEqExpr (CmmRegOff r 0) e = cheapEqReg r e -cheapEqExpr (CmmRegOff r n) (CmmRegOff r' n') = r==r' && n==n' -cheapEqExpr _ _ = False - -cheapEqReg :: CmmReg -> CmmExpr -> Bool -cheapEqReg r (CmmReg r') = r==r' -cheapEqReg r (CmmRegOff r' 0) = r==r' -cheapEqReg _ _ = False - ---------------------------------------------------- --- -- CmmExpr -- --------------------------------------------------- @@ -225,29 +170,3 @@ mkLblExpr :: CLabel -> CmmExpr mkLblExpr lbl = CmmLit (CmmLabel lbl) - ---------------------------------------------------- --- --- Helpers for foreign call arguments --- ---------------------------------------------------- - -loadArgsIntoTemps :: [Unique] - -> HintedCmmActuals - -> ([Unique], [CmmStmt], HintedCmmActuals) -loadArgsIntoTemps uniques [] = (uniques, [], []) -loadArgsIntoTemps uniques ((CmmHinted e hint):args) = - (uniques'', - new_stmts ++ remaining_stmts, - (CmmHinted new_e hint) : remaining_e) - where - (uniques', new_stmts, new_e) = maybeAssignTemp uniques e - (uniques'', remaining_stmts, remaining_e) = - loadArgsIntoTemps uniques' args - - -maybeAssignTemp :: [Unique] -> CmmExpr -> ([Unique], [CmmStmt], CmmExpr) -maybeAssignTemp uniques e - | hasNoGlobalRegs e = (uniques, [], e) - | otherwise = (tail uniques, [CmmAssign local e], CmmReg local) - where local = CmmLocal (LocalReg (head uniques) (cmmExprType e)) diff -Nru ghc-7.0.3/compiler/cmm/CmmZipUtil.hs ghc-7.2.1/compiler/cmm/CmmZipUtil.hs --- ghc-7.0.3/compiler/cmm/CmmZipUtil.hs 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/cmm/CmmZipUtil.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,39 +0,0 @@ - -module CmmZipUtil - ( zipPreds - , givesUniquePredecessorTo - ) -where -import BlockId -import Prelude hiding (last, unzip) -import ZipCfg - -import Maybes - --- | Compute the predecessors of each /reachable/ block -zipPreds :: LastNode l => LGraph m l -> BlockEnv BlockSet -zipPreds g = foldl add emptyBlockEnv (postorder_dfs g) - where add env block@(Block id _) = - foldl (\env sid -> - let preds = lookupBlockEnv env sid `orElse` emptyBlockSet - in extendBlockEnv env sid (extendBlockSet preds id)) - env (succs block) - --- | Tell if a graph gives a block a unique predecessor. For --- efficiency, this function is designed to be partially applied. - -givesUniquePredecessorTo :: LastNode l => LGraph m l -> BlockId -> Bool -givesUniquePredecessorTo g = \id -> elemBlockSet id singlePreds - -- accumulates a pair of sets: the set of all blocks containing a single - -- predecessor, and the set of all blocks containing at least two predecessors - where (singlePreds, _) = fold_blocks add (emptyBlockSet, emptyBlockSet) g - add b (single, multi) = foldl add_pred (single, multi) (succs b) - add_pred pair@(single, multi) id = - if elemBlockSet id multi then pair - else if elemBlockSet id single then - (removeBlockSet single id, extendBlockSet multi id) - else - (extendBlockSet single id, multi) - - - diff -Nru ghc-7.0.3/compiler/cmm/Dataflow.hs ghc-7.2.1/compiler/cmm/Dataflow.hs --- ghc-7.0.3/compiler/cmm/Dataflow.hs 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/cmm/Dataflow.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,55 +0,0 @@ -{-# OPTIONS -Wall -fno-warn-name-shadowing #-} - -module Dataflow ( - fixedpoint - ) where - ------------------------------------------------------------------------------ --- | Solve the fixed-point of a dataflow problem. --- --- Complexity: O(N+H*E) calls to the update function where: --- N = number of nodes, --- E = number of edges, --- H = maximum height of the lattice for any particular node. --- --- Sketch for proof of complexity: --- Note that the state is threaded through the entire execution. --- Also note that the height of the latice at any particular node --- is the number of times 'update' can return non-Nothing for a --- particular node. Every call (except for the top level one) --- must be caused by a non-Nothing result and each non-Nothing --- result causes as many calls as it has out-going edges. --- Thus any particular node, n, may cause in total at --- most H*out(n) further calls. When summed over all nodes, --- that is H*E. The N term of the complexity is from the initial call --- when 'update' will be passed 'Nothing'. -fixedpoint :: - (node -> [node]) -- map from nodes to those who's - -- value depend on the argument node - -> (node -> Maybe node -> s -> Maybe s) - -- Given the node which needs to be - -- updated, and which node caused that node - -- to need to be updated, update the state. - -- - -- The causing node will be 'Nothing' if - -- this is the initial/bootstrapping update. - -- - -- Must return 'Nothing' if no change, - -- otherwise returrn 'Just' of the new state. - - -> [node] -- Nodes that should initially be updated - - -> s -- Initial state - -- (usually a map from node to - -- the value for that node) - - -> s -- Final state -fixedpoint dependants update nodes state = - foldr (fixedpoint' Nothing) state nodes where - -- Use a depth first traversal of nodes based on the update graph. - -- Terminate the traversal when the update doesn't change anything. - fixedpoint' cause node state = - case update node cause state of - Nothing -> state - Just state' -> - foldr (fixedpoint' (Just node)) state' (dependants node) diff -Nru ghc-7.0.3/compiler/cmm/DFMonad.hs ghc-7.2.1/compiler/cmm/DFMonad.hs --- ghc-7.0.3/compiler/cmm/DFMonad.hs 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/cmm/DFMonad.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,223 +0,0 @@ -module DFMonad - ( DataflowLattice(..) , DataflowAnalysis - , markFactsUnchanged, factsStatus, getFact, setFact, getExitFact, setExitFact - , forgetFact, botFact, setAllFacts, getAllFacts, factsEnv - , addLastOutFact, bareLastOutFacts, forgetLastOutFacts, checkFactMatch - , subAnalysis - - , DFM, runDFM, liftToDFM - , markGraphRewritten, graphWasRewritten - , module OptimizationFuel - ) -where - -import BlockId -import CmmTx -import PprCmm() -import OptimizationFuel - -import Maybes -import Outputable -import UniqSupply - -{- - -A dataflow monad maintains a mapping from BlockIds to dataflow facts, -where a dataflow fact is a value of type [[a]]. Values of type [[a]] -must form a lattice, as described by type [[Fact a]]. - -The dataflow engine uses the lattice structure to compute a least -solution to a set of dataflow equations. To compute a greatest -solution, flip the lattice over. - -The engine works by starting at the bottom and iterating to a fixed -point, so in principle we require the bottom element, a join (least -upper bound) operation, and a comparison to find out if a value has -changed (grown). In practice, the comparison is only ever used in -conjunction with the join, so we have [[fact_add_to]]: - - fact_add_to new old = - let j = join new old in - if j <= old then noTx old -- nothing changed - else aTx j -- the fact changed - --} - -data DataflowLattice a = DataflowLattice { - fact_name :: String, -- documentation - fact_bot :: a, -- lattice bottom element - fact_add_to :: a -> a -> TxRes a, -- lattice join and compare - -- ^ compute join of two args; something changed iff join is greater than 2nd arg - fact_do_logging :: Bool -- log changes -} - - --- DFM is the monad of combined analysis and transformation, --- which needs a UniqSupply and may consume optimization fuel --- DFM is defined using a monad transformer, DFM', which is the general --- case of DFM, parameterized over any monad. --- In practice, we apply DFM' to the FuelMonad, which provides optimization fuel and --- the unique supply. -data DFState f = DFState { df_rewritten :: !ChangeFlag - , df_facts :: !(BlockEnv f) - , df_exit_fact :: !f - , df_last_outs :: ![(BlockId, f)] - , df_facts_change :: !ChangeFlag - } - -newtype DFM' m fact a = DFM' (DataflowLattice fact -> DFState fact - -> m (a, DFState fact)) -type DFM fact a = DFM' FuelMonad fact a - - -runDFM :: Monad m => DataflowLattice f -> DFM' m f a -> m a -runDFM lattice (DFM' f) = - (f lattice $ DFState NoChange emptyBlockEnv (fact_bot lattice) [] NoChange) - >>= return . fst - -class DataflowAnalysis m where - markFactsUnchanged :: m f () -- ^ Useful for starting a new iteration - factsStatus :: m f ChangeFlag - subAnalysis :: m f a -> m f a -- ^ Do a new analysis and then throw away - -- /all/ the related state. - - getFact :: BlockId -> m f f - setFact :: Outputable f => BlockId -> f -> m f () - getExitFact :: m f f - setExitFact :: Outputable f => f -> m f () - checkFactMatch :: Outputable f => - BlockId -> f -> m f () -- ^ assert fact already at this val - botFact :: m f f - forgetFact :: BlockId -> m f () - -- | It might be surprising these next two are needed in a pure analysis, - -- but for some problems we do a 'shallow' rewriting in which a rewritten - -- graph is not itself considered for further rewriting but merely undergoes - -- an analysis. In this case the results of a forward analysis might produce - -- new facts that go on BlockId's that reside outside the graph being analyzed. - -- Thus these 'lastOutFacts' need to be available even in a pure analysis. - addLastOutFact :: (BlockId, f) -> m f () - bareLastOutFacts :: m f [(BlockId, f)] - forgetLastOutFacts :: m f () - getAllFacts :: m f (BlockEnv f) - setAllFacts :: BlockEnv f -> m f () - factsEnv :: Monad (m f) => m f (BlockId -> f) - - lattice :: m f (DataflowLattice f) - factsEnv = do { map <- getAllFacts - ; bot <- botFact - ; return $ \id -> lookupBlockEnv map id `orElse` bot } - -instance Monad m => DataflowAnalysis (DFM' m) where - markFactsUnchanged = DFM' f - where f _ s = return ((), s {df_facts_change = NoChange}) - factsStatus = DFM' f' - where f' _ s = return (df_facts_change s, s) - subAnalysis (DFM' f) = DFM' f' - where f' l s = do (a, _) <- f l (subAnalysisState s) - return (a, s) - getFact id = DFM' get - where get lattice s = - return (lookupBlockEnv (df_facts s) id `orElse` fact_bot lattice, s) - setFact id a = DFM' set - where set (DataflowLattice name bot add_fact log) s = - case add_fact a old of - TxRes NoChange _ -> if initialized then return ((), s) else update old old - TxRes SomeChange join -> update join old - where (old, initialized) = - case lookupBlockEnv (df_facts s) id of - Just f -> (f, True) - Nothing -> (bot, False) - update join old = - let facts' = extendBlockEnv (df_facts s) id join - debug = if log then pprTrace else \_ _ a -> a - in debug name (pprSetFact id old a join) $ - return ((), s { df_facts = facts', df_facts_change = SomeChange }) - getExitFact = DFM' get - where get _ s = return (df_exit_fact s, s) - setExitFact a = - do DataflowLattice { fact_name = name, fact_do_logging = log} <- lattice - DFM' $ \_ s -> - let debug = if log then pprTrace else \_ _ a -> a - in debug name (pprSetFact "exit" a a a) $ - return ((), s { df_exit_fact = a }) - getAllFacts = DFM' f - where f _ s = return (df_facts s, s) - setAllFacts env = DFM' f - where f _ s = return ((), s { df_facts = env}) - botFact = DFM' f - where f lattice s = return (fact_bot lattice, s) - forgetFact id = DFM' f - where f _ s = return ((), s { df_facts = delFromBlockEnv (df_facts s) id }) - addLastOutFact pair = DFM' f - where f _ s = return ((), s { df_last_outs = pair : df_last_outs s }) - bareLastOutFacts = DFM' f - where f _ s = return (df_last_outs s, s) - forgetLastOutFacts = DFM' f - where f _ s = return ((), s { df_last_outs = [] }) - checkFactMatch id a = - do { fact <- lattice - ; old_a <- getFact id - ; case fact_add_to fact a old_a of - TxRes NoChange _ -> return () - TxRes SomeChange new -> - do { facts <- getAllFacts - ; pprPanic "checkFactMatch" - (f4sep [text (fact_name fact), text "at id" <+> ppr id, - text "changed from", nest 4 (ppr old_a), text "to", - nest 4 (ppr new), - text "after supposedly reaching fixed point;", - text "env is", pprFacts facts]) } - } - where pprFacts env = vcat (map pprFact (blockEnvToList env)) - pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a) - - lattice = DFM' f - where f l s = return (l, s) - -subAnalysisState :: DFState f -> DFState f -subAnalysisState s = s {df_facts_change = NoChange} - - -markGraphRewritten :: Monad m => DFM' m f () -markGraphRewritten = DFM' f - where f _ s = return ((), s {df_rewritten = SomeChange}) - -graphWasRewritten :: DFM f ChangeFlag -graphWasRewritten = DFM' f - where f _ s = return (df_rewritten s, s) - -instance Monad m => Monad (DFM' m f) where - DFM' f >>= k = DFM' (\l s -> do (a, s') <- f l s - s' `seq` case k a of DFM' f' -> f' l s') - return a = DFM' (\_ s -> return (a, s)) - -- The `seq` is essential to ensure that entire passes of the dataflow engine - -- aren't postponed in a thunk. By making the sequence strict in the state, - -- we ensure that each action in the monad is executed immediately, preventing - -- stack overflows that previously occurred when finally forcing the old state thunks. - -instance FuelUsingMonad (DFM' FuelMonad f) where - fuelRemaining = liftToDFM' fuelRemaining - lastFuelPass = liftToDFM' lastFuelPass - fuelExhausted = liftToDFM' fuelExhausted - fuelDecrement p f f' = liftToDFM' (fuelDecrement p f f') - fuelDec1 = liftToDFM' fuelDec1 -instance MonadUnique (DFM' FuelMonad f) where - getUniqueSupplyM = liftToDFM' getUniqueSupplyM - getUniqueM = liftToDFM' getUniqueM - getUniquesM = liftToDFM' getUniquesM - -liftToDFM' :: Monad m => m x -> DFM' m f x -liftToDFM' m = DFM' (\ _ s -> m >>= (\a -> return (a, s))) -liftToDFM :: FuelMonad x -> DFM f x -liftToDFM m = DFM' (\ _ s -> m >>= (\a -> return (a, s))) - - -pprSetFact :: (Show a, Outputable f) => a -> f -> f -> f -> SDoc -pprSetFact id old a join = - f4sep [text "at" <+> text (show id), - text "added" <+> ppr a, text "to" <+> ppr old, - text "yielding" <+> ppr join] - -f4sep :: [SDoc] -> SDoc -f4sep [] = fsep [] -f4sep (d:ds) = fsep (d : map (nest 4) ds) diff -Nru ghc-7.0.3/compiler/cmm/MkGraph.hs ghc-7.2.1/compiler/cmm/MkGraph.hs --- ghc-7.0.3/compiler/cmm/MkGraph.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/compiler/cmm/MkGraph.hs 2011-08-07 17:10:05.000000000 +0000 @@ -0,0 +1,418 @@ +{-# LANGUAGE GADTs #-} +{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} +-- ToDo: remove +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} + +-- Module for building CmmAGraphs. + +-- As the CmmAGraph is a wrapper over Graph CmmNode O x, it is different +-- from Hoopl's AGraph. The current clients expect functions with the +-- same names Hoopl uses, so this module cannot be in the same namespace +-- as Compiler.Hoopl. + +module MkGraph + ( CmmAGraph + , emptyAGraph, (<*>), catAGraphs, outOfLine + , mkLabel, mkMiddle, mkLast + , withFreshLabel, withUnique, lgraphOfAGraph, labelAGraph + + , stackStubExpr + , mkNop, mkAssign, mkStore, mkCall, mkCmmCall, mkSafeCall, mkUnsafeCall, mkFinalCall + , mkJump, mkDirectJump, mkForeignJump, mkJumpGC, mkCbranch, mkSwitch + , mkReturn, mkReturnSimple, mkComment, mkCallEntry + , mkBranch, mkCmmIfThenElse, mkCmmIfThen, mkCmmWhileDo + , copyInOflow, copyInSlot, copyOutOflow, copyOutSlot + -- Reexport of needed Cmm stuff + , Convention(..), ForeignConvention(..), ForeignTarget(..) + , CmmStackInfo(..), CmmTopInfo(..), CmmGraph, GenCmmGraph(..) + , Cmm, CmmTop + ) +where + +import BlockId +import Cmm +import CmmDecl +import CmmExpr +import CmmCallConv (assignArgumentsPos, ParamLocation(..)) + +import Compiler.Hoopl hiding (Unique, (<*>), mkFirst, mkMiddle, mkLast, mkLabel, mkBranch, Shape(..)) +import qualified Compiler.Hoopl as H +import Compiler.Hoopl.GHC (uniqueToLbl) +import FastString +import ForeignCall +import Outputable +import Prelude hiding (succ) +import SMRep (ByteOff) +import StaticFlags +import Unique +import UniqSupply + +#include "HsVersions.h" + +{- +A 'CmmAGraph' is an abstract version of a 'Graph CmmNode O x' from module +'Cmm'. The difference is that the 'CmmAGraph' can be eigher open of closed at +exit and it can supply fresh Labels and Uniques. + +It also supports a splicing operation <*>, which is different from the Hoopl's +<*>, because it splices two CmmAGraphs. Specifically, it can splice Graph +O C and Graph O x. In this case, the open beginning of the second graph is +thrown away. In the debug mode this sequence is checked to be empty or +containing a branch (see note [Branch follows branch]). + +When an CmmAGraph open at exit is being converted to a CmmGraph, the output +exit sequence is considered unreachable. If the graph consist of one block +only, if it not the case and we crash. Otherwise we just throw the exit +sequence away (and in debug mode we test that it really was unreachable). +-} + +{- +Node [Branch follows branch] +============================ +Why do we say it's ok for a Branch to follow a Branch? +Because the standard constructor mkLabel has fall-through +semantics. So if you do a mkLabel, you finish the current block, +giving it a label, and start a new one that branches to that label. +Emitting a Branch at this point is fine: + goto L1; L2: ...stuff... +-} + +data CmmGraphOC = Opened (Graph CmmNode O O) + | Closed (Graph CmmNode O C) +type CmmAGraph = UniqSM CmmGraphOC -- Graph open at entry + +{- +MS: I began with + newtype CmmAGraph = forall x. AG (UniqSM (Graph CmmNode O x)) +but that does not work well, because we cannot take the graph +out of the monad -- we do not know the type of what we would take +out and pattern matching does not help, as we cannot pattern match +on a graph inside the monad. +-} + +data Transfer = Call | Jump | Ret deriving Eq + +---------- AGraph manipulation + +emptyAGraph :: CmmAGraph +(<*>) :: CmmAGraph -> CmmAGraph -> CmmAGraph +catAGraphs :: [CmmAGraph] -> CmmAGraph + +mkLabel :: BlockId -> CmmAGraph -- created a sequence "goto id; id:" as an AGraph +mkMiddle :: CmmNode O O -> CmmAGraph -- creates an open AGraph from a given node +mkLast :: CmmNode O C -> CmmAGraph -- created a closed AGraph from a given node + +withFreshLabel :: String -> (BlockId -> CmmAGraph) -> CmmAGraph +withUnique :: (Unique -> CmmAGraph) -> CmmAGraph + +lgraphOfAGraph :: CmmAGraph -> UniqSM CmmGraph + -- ^ allocate a fresh label for the entry point +labelAGraph :: BlockId -> CmmAGraph -> UniqSM CmmGraph + -- ^ use the given BlockId as the label of the entry point + +---------- No-ops +mkNop :: CmmAGraph +mkComment :: FastString -> CmmAGraph + +---------- Assignment and store +mkAssign :: CmmReg -> CmmExpr -> CmmAGraph +mkStore :: CmmExpr -> CmmExpr -> CmmAGraph + +---------- Calls +mkCall :: CmmExpr -> (Convention, Convention) -> [CmmFormal] -> [CmmActual] -> + UpdFrameOffset -> CmmAGraph +mkCmmCall :: CmmExpr -> [CmmFormal] -> [CmmActual] -> + UpdFrameOffset -> CmmAGraph + -- Native C-- calling convention +mkSafeCall :: ForeignTarget -> [CmmFormal] -> [CmmActual] -> UpdFrameOffset -> Bool -> CmmAGraph +mkUnsafeCall :: ForeignTarget -> [CmmFormal] -> [CmmActual] -> CmmAGraph +mkFinalCall :: CmmExpr -> CCallConv -> [CmmActual] -> UpdFrameOffset -> CmmAGraph + -- Never returns; like exit() or barf() + +---------- Control transfer +mkJump :: CmmExpr -> [CmmActual] -> UpdFrameOffset -> CmmAGraph +mkDirectJump :: CmmExpr -> [CmmActual] -> UpdFrameOffset -> CmmAGraph +mkJumpGC :: CmmExpr -> [CmmActual] -> UpdFrameOffset -> CmmAGraph +mkForeignJump :: Convention -> CmmExpr -> [CmmActual] -> UpdFrameOffset -> CmmAGraph +mkCbranch :: CmmExpr -> BlockId -> BlockId -> CmmAGraph +mkSwitch :: CmmExpr -> [Maybe BlockId] -> CmmAGraph +mkReturn :: CmmExpr -> [CmmActual] -> UpdFrameOffset -> CmmAGraph +mkReturnSimple :: [CmmActual] -> UpdFrameOffset -> CmmAGraph + +mkBranch :: BlockId -> CmmAGraph +mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> CmmAGraph +mkCmmIfThen :: CmmExpr -> CmmAGraph -> CmmAGraph +mkCmmWhileDo :: CmmExpr -> CmmAGraph -> CmmAGraph + +outOfLine :: CmmAGraph -> CmmAGraph +-- ^ The argument is an CmmAGraph that must have an +-- empty entry sequence and be closed at the end. +-- The result is a new CmmAGraph that is open at the +-- end and goes directly from entry to exit, with the +-- original graph sitting to the side out-of-line. +-- +-- Example: mkMiddle (x = 3) +-- <*> outOfLine (mkLabel L <*> ...stuff...) +-- <*> mkMiddle (y = x) +-- Control will flow directly from x=3 to y=x; +-- the block starting with L is "on the side". +-- +-- N.B. algebraically forall g g' : g <*> outOfLine g' == outOfLine g' <*> g + +-------------------------------------------------------------------------- + +-- ================ IMPLEMENTATION ================-- + +-------------------------------------------------- +-- Raw CmmAGraph handling + +emptyAGraph = return $ Opened emptyGraph +ag <*> ah = do g <- ag + h <- ah + return (case (g, h) of + (Opened g, Opened h) -> Opened $ g H.<*> h + (Opened g, Closed h) -> Closed $ g H.<*> h + (Closed g, Opened GNil) -> Closed g + (Closed g, Opened (GUnit e)) -> note_unreachable e $ Closed g + (Closed g, Opened (GMany (JustO e) b x)) -> note_unreachable e $ Opened $ g H.|*><*| GMany NothingO b x + (Closed g, Closed (GMany (JustO e) b x)) -> note_unreachable e $ Closed $ g H.|*><*| GMany NothingO b x + :: CmmGraphOC) +catAGraphs = foldl (<*>) emptyAGraph + +outOfLine ag = withFreshLabel "outOfLine" $ \l -> + do g <- ag + return (case g of + Closed (GMany (JustO e) b _) -> note_unreachable e $ Opened $ + GMany (JustO $ BLast $ CmmBranch l) b (JustO $ BFirst $ CmmEntry l) + _ -> panic "outOfLine" + :: CmmGraphOC) + +note_unreachable :: Block CmmNode O x -> a -> a +note_unreachable block graph = + ASSERT (block_is_empty_or_label) -- Note [Branch follows branch] + graph + where block_is_empty_or_label :: Bool + block_is_empty_or_label = case blockToNodeList block of + (NothingC, [], NothingC) -> True + (NothingC, [], JustC (CmmBranch _)) -> True + _ -> False + +mkLabel bid = return $ Opened $ H.mkLast (CmmBranch bid) |*><*| H.mkFirst (CmmEntry bid) +mkMiddle middle = return $ Opened $ H.mkMiddle middle +mkLast last = return $ Closed $ H.mkLast last + +withUnique f = getUniqueM >>= f +withFreshLabel _name f = getUniqueM >>= f . uniqueToLbl . intToUnique . getKey + +lgraphOfAGraph g = do u <- getUniqueM + labelAGraph (mkBlockId u) g + +labelAGraph lbl ag = do g <- ag + return $ CmmGraph {g_entry=lbl, g_graph=H.mkFirst (CmmEntry lbl) H.<*> closed g} + where closed :: CmmGraphOC -> Graph CmmNode O C + closed (Closed g) = g + closed (Opened g@(GMany entry body (JustO exit))) = + ASSERT (entryLabel exit `notElem` map entryLabel (postorder_dfs g)) + GMany entry body NothingO + closed (Opened _) = panic "labelAGraph" + +-------------------------------------------------- +-- CmmAGraph constructions + +mkNop = emptyAGraph +mkComment fs = mkMiddle $ CmmComment fs +mkStore l r = mkMiddle $ CmmStore l r + +-- NEED A COMPILER-DEBUGGING FLAG HERE +-- Sanity check: any value assigned to a pointer must be non-zero. +-- If it's 0, cause a crash immediately. +mkAssign l r = if opt_StubDeadValues then assign l r <*> check l else assign l r + where assign l r = mkMiddle (CmmAssign l r) + check (CmmGlobal _) = mkNop + check l@(CmmLocal reg) = -- if a ptr arg is NULL, cause a crash! + if isGcPtrType ty then + mkCmmIfThen (CmmMachOp (MO_Eq w) [r, stackStubExpr w]) + (assign l (CmmLoad (CmmLit (CmmInt 0 w)) ty)) + else mkNop + where ty = localRegType reg + w = typeWidth ty + r = CmmReg l + + +-- Why are we inserting extra blocks that simply branch to the successors? +-- Because in addition to the branch instruction, @mkBranch@ will insert +-- a necessary adjustment to the stack pointer. +mkCbranch pred ifso ifnot = mkLast (CmmCondBranch pred ifso ifnot) +mkSwitch e tbl = mkLast $ CmmSwitch e tbl + +mkSafeCall t fs as upd i = withFreshLabel "safe call" $ body + where + body k = + ( mkStore (CmmStackSlot (CallArea (Young k)) (widthInBytes wordWidth)) + (CmmLit (CmmBlock k)) + <*> mkLast (CmmForeignCall {tgt=t, res=fs, args=as, succ=k, updfr=upd, intrbl=i}) + <*> mkLabel k) +mkUnsafeCall t fs as = mkMiddle $ CmmUnsafeForeignCall t fs as + +mkBranch bid = mkLast (CmmBranch bid) + +mkCmmIfThenElse e tbranch fbranch = + withFreshLabel "end of if" $ \endif -> + withFreshLabel "start of then" $ \tid -> + withFreshLabel "start of else" $ \fid -> + mkCbranch e tid fid <*> + mkLabel tid <*> tbranch <*> mkBranch endif <*> + mkLabel fid <*> fbranch <*> mkLabel endif + +mkCmmIfThen e tbranch + = withFreshLabel "end of if" $ \endif -> + withFreshLabel "start of then" $ \tid -> + mkCbranch e tid endif <*> + mkLabel tid <*> tbranch <*> mkLabel endif + +mkCmmWhileDo e body = + withFreshLabel "loop test" $ \test -> + withFreshLabel "loop head" $ \head -> + withFreshLabel "end while" $ \endwhile -> + -- Forrest Baskett's while-loop layout + mkBranch test <*> mkLabel head <*> body + <*> mkLabel test <*> mkCbranch e head endwhile + <*> mkLabel endwhile + +-- For debugging purposes, we can stub out dead stack slots: +stackStubExpr :: Width -> CmmExpr +stackStubExpr w = CmmLit (CmmInt 0 w) + +-- When we copy in parameters, we usually want to put overflow +-- parameters on the stack, but sometimes we want to pass +-- the variables in their spill slots. +-- Therefore, for copying arguments and results, we provide different +-- functions to pass the arguments in an overflow area and to pass them in spill slots. +copyInOflow :: Convention -> Area -> [CmmFormal] -> (Int, CmmAGraph) +copyInSlot :: Convention -> [CmmFormal] -> [CmmNode O O] +copyOutSlot :: Convention -> [LocalReg] -> [CmmNode O O] + +copyInOflow conv area formals = (offset, catAGraphs $ map mkMiddle nodes) + where (offset, nodes) = copyIn oneCopyOflowI conv area formals +copyInSlot c f = snd $ copyIn oneCopySlotI c (panic "no area for copying to slots") f + +type SlotCopier = Area -> (LocalReg, ByteOff) -> (ByteOff, [CmmNode O O]) -> + (ByteOff, [CmmNode O O]) +type CopyIn = SlotCopier -> Convention -> Area -> [CmmFormal] -> (ByteOff, [CmmNode O O]) + +-- Return the number of bytes used for copying arguments, as well as the +-- instructions to copy the arguments. +copyIn :: CopyIn +copyIn oflow conv area formals = + foldr ci (init_offset, []) args' + where ci (reg, RegisterParam r) (n, ms) = + (n, CmmAssign (CmmLocal reg) (CmmReg $ CmmGlobal r) : ms) + ci (r, StackParam off) (n, ms) = oflow area (r, off) (n, ms) + init_offset = widthInBytes wordWidth -- infotable + args = assignArgumentsPos conv localRegType formals + args' = foldl adjust [] args + where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst + adjust rst x@(_, RegisterParam _) = x : rst + +-- Copy-in one arg, using overflow space if needed. +oneCopyOflowI, oneCopySlotI :: SlotCopier +oneCopyOflowI area (reg, off) (n, ms) = + (max n off, CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty) : ms) + where ty = localRegType reg + +-- Copy-in one arg, using spill slots if needed -- used for calling conventions at +-- a procpoint that is not a return point. The offset is irrelevant here... +oneCopySlotI _ (reg, _) (n, ms) = + (n, CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot (RegSlot reg) w) ty) : ms) + where ty = localRegType reg + w = widthInBytes (typeWidth ty) + + +-- Factoring out the common parts of the copyout functions yielded something +-- more complicated: + +copyOutOflow :: Convention -> Transfer -> Area -> [CmmActual] -> UpdFrameOffset -> + (Int, CmmAGraph) +-- Generate code to move the actual parameters into the locations +-- required by the calling convention. This includes a store for the return address. +-- +-- The argument layout function ignores the pointer to the info table, so we slot that +-- in here. When copying-out to a young area, we set the info table for return +-- and adjust the offsets of the other parameters. +-- If this is a call instruction, we adjust the offsets of the other parameters. +copyOutOflow conv transfer area@(CallArea a) actuals updfr_off + = foldr co (init_offset, emptyAGraph) args' + where + co (v, RegisterParam r) (n, ms) = (n, mkAssign (CmmGlobal r) v <*> ms) + co (v, StackParam off) (n, ms) = (max n off, mkStore (CmmStackSlot area off) v <*> ms) + + (setRA, init_offset) = + case a of Young id -> id `seq` -- Generate a store instruction for + -- the return address if making a call + if transfer == Call then + ([(CmmLit (CmmBlock id), StackParam init_offset)], + widthInBytes wordWidth) + else ([], 0) + Old -> ([], updfr_off) + + args :: [(CmmExpr, ParamLocation)] -- The argument and where to put it + args = assignArgumentsPos conv cmmExprType actuals + + args' = foldl adjust setRA args + where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst + adjust rst x@(_, RegisterParam _) = x : rst + +copyOutOflow _ _ (RegSlot _) _ _ = panic "cannot copy arguments into a register slot" + +-- Args passed only in registers and stack slots; no overflow space. +-- No return address may apply! +copyOutSlot conv actuals = foldr co [] args + where co (v, RegisterParam r) ms = CmmAssign (CmmGlobal r) (toExp v) : ms + co (v, StackParam off) ms = CmmStore (CmmStackSlot (RegSlot v) off) (toExp v) : ms + toExp r = CmmReg (CmmLocal r) + args = assignArgumentsPos conv localRegType actuals + +mkCallEntry :: Convention -> [CmmFormal] -> (Int, CmmAGraph) +mkCallEntry conv formals = copyInOflow conv (CallArea Old) formals + +lastWithArgs :: Transfer -> Area -> Convention -> [CmmActual] -> UpdFrameOffset -> + (ByteOff -> CmmAGraph) -> CmmAGraph +lastWithArgs transfer area conv actuals updfr_off last = + let (outArgs, copies) = copyOutOflow conv transfer area actuals updfr_off in + copies <*> last outArgs + +-- The area created for the jump and return arguments is the same area as the +-- procedure entry. +old :: Area +old = CallArea Old +toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff -> ByteOff -> CmmAGraph +toCall e cont updfr_off res_space arg_space = + mkLast $ CmmCall e cont arg_space res_space updfr_off +mkJump e actuals updfr_off = + lastWithArgs Jump old NativeNodeCall actuals updfr_off $ toCall e Nothing updfr_off 0 +mkDirectJump e actuals updfr_off = + lastWithArgs Jump old NativeDirectCall actuals updfr_off $ toCall e Nothing updfr_off 0 +mkJumpGC e actuals updfr_off = + lastWithArgs Jump old GC actuals updfr_off $ toCall e Nothing updfr_off 0 +mkForeignJump conv e actuals updfr_off = + lastWithArgs Jump old conv actuals updfr_off $ toCall e Nothing updfr_off 0 +mkReturn e actuals updfr_off = + lastWithArgs Ret old NativeReturn actuals updfr_off $ toCall e Nothing updfr_off 0 + -- where e = CmmLoad (CmmStackSlot (CallArea Old) updfr_off) gcWord +mkReturnSimple actuals updfr_off = + lastWithArgs Ret old NativeReturn actuals updfr_off $ toCall e Nothing updfr_off 0 + where e = CmmLoad (CmmStackSlot (CallArea Old) updfr_off) gcWord + +mkFinalCall f _ actuals updfr_off = + lastWithArgs Call old NativeDirectCall actuals updfr_off $ toCall f Nothing updfr_off 0 + +mkCmmCall f results actuals = mkCall f (NativeDirectCall, NativeReturn) results actuals + +-- I'm dropping the SRT, but that should be okay: we plan to reconstruct it later. +mkCall f (callConv, retConv) results actuals updfr_off = + withFreshLabel "call successor" $ \k -> + let area = CallArea $ Young k + (off, copyin) = copyInOflow retConv area results + copyout = lastWithArgs Call area callConv actuals updfr_off + (toCall f (Just k) updfr_off off) + in (copyout <*> mkLabel k <*> copyin) diff -Nru ghc-7.0.3/compiler/cmm/MkZipCfgCmm.hs ghc-7.2.1/compiler/cmm/MkZipCfgCmm.hs --- ghc-7.0.3/compiler/cmm/MkZipCfgCmm.hs 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/cmm/MkZipCfgCmm.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,269 +0,0 @@ -{-# OPTIONS -Wall -fno-warn-name-shadowing #-} - --- This is the module to import to be able to build C-- programs. --- It should not be necessary to import MkZipCfg or ZipCfgCmmRep. --- If you find it necessary to import these other modules, please --- complain to Norman Ramsey. - -module MkZipCfgCmm - ( mkNop, mkAssign, mkStore, mkCall, mkCmmCall, mkSafeCall, mkUnsafeCall, mkFinalCall - , mkJump, mkForeignJump, mkJumpGC, mkCbranch, mkSwitch, mkReturn - , mkReturnSimple, mkComment, copyInOflow, copyInSlot, copyOutOflow, copyOutSlot - , mkEntry, mkCmmIfThenElse, mkCmmIfThen, mkCmmWhileDo - , (<*>), catAGraphs, mkLabel, mkBranch - , emptyAGraph, withFreshLabel, withUnique, outOfLine - , lgraphOfAGraph, graphOfAGraph, labelAGraph - , CmmZ, CmmTopZ, CmmGraph, CmmBlock, CmmAGraph, CmmStackInfo - , Middle, Last, Convention(..), ForeignConvention(..), MidCallTarget(..), Transfer(..) - , stackStubExpr, pprAGraph - ) -where - -#include "HsVersions.h" - -import BlockId -import CmmExpr -import Cmm ( GenCmm(..), GenCmmTop(..), CmmStatic, CmmInfo - , CmmActuals, CmmFormals - ) -import CmmCallConv (assignArgumentsPos, ParamLocation(..)) -import ZipCfgCmmRep hiding (CmmGraph, CmmAGraph, CmmBlock, CmmZ, CmmTopZ) - -- to make this module more self-contained, the above definitions are - -- duplicated below -import PprCmm() - -import FastString -import ForeignCall -import MkZipCfg -import Panic -import SMRep (ByteOff) -import StaticFlags -import ZipCfg - -type CmmGraph = LGraph Middle Last -type CmmAGraph = AGraph Middle Last -type CmmBlock = Block Middle Last -type CmmStackInfo = (ByteOff, Maybe ByteOff) - -- probably want a record; (SP offset on entry, update frame space) -type CmmZ = GenCmm CmmStatic CmmInfo (CmmStackInfo, CmmGraph) -type CmmTopZ = GenCmmTop CmmStatic CmmInfo (CmmStackInfo, CmmGraph) - -data Transfer = Call | Jump | Ret deriving Eq - ----------- No-ops -mkNop :: CmmAGraph -mkComment :: FastString -> CmmAGraph - ----------- Assignment and store -mkAssign :: CmmReg -> CmmExpr -> CmmAGraph -mkStore :: CmmExpr -> CmmExpr -> CmmAGraph - ----------- Calls -mkCall :: CmmExpr -> (Convention, Convention) -> CmmFormals -> CmmActuals -> - UpdFrameOffset -> CmmAGraph -mkCmmCall :: CmmExpr -> CmmFormals -> CmmActuals -> - UpdFrameOffset -> CmmAGraph - -- Native C-- calling convention -mkSafeCall :: MidCallTarget -> CmmFormals -> CmmActuals -> UpdFrameOffset -> CmmAGraph -mkUnsafeCall :: MidCallTarget -> CmmFormals -> CmmActuals -> CmmAGraph -mkFinalCall :: CmmExpr -> CCallConv -> CmmActuals -> UpdFrameOffset -> CmmAGraph - -- Never returns; like exit() or barf() - ----------- Control transfer -mkJump :: CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph -mkJumpGC :: CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph -mkForeignJump :: Convention -> CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph -mkCbranch :: CmmExpr -> BlockId -> BlockId -> CmmAGraph -mkSwitch :: CmmExpr -> [Maybe BlockId] -> CmmAGraph -mkReturn :: CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph -mkReturnSimple :: CmmActuals -> UpdFrameOffset -> CmmAGraph - -mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> CmmAGraph -mkCmmIfThen :: CmmExpr -> CmmAGraph -> CmmAGraph -mkCmmWhileDo :: CmmExpr -> CmmAGraph -> CmmAGraph - --- Not to be forgotten, but exported by MkZipCfg: --- mkBranch :: BlockId -> CmmAGraph --- mkLabel :: BlockId -> Maybe Int -> CmmAGraph --- outOfLine :: CmmAGraph -> CmmAGraph --- withUnique :: (Unique -> CmmAGraph) -> CmmAGraph --- withFreshLabel :: String -> (BlockId -> CmmAGraph) -> CmmAGraph - --------------------------------------------------------------------------- - -mkCmmWhileDo e = mkWhileDo (mkCbranch e) -mkCmmIfThenElse e = mkIfThenElse (mkCbranch e) - -mkCmmIfThen e tbranch - = withFreshLabel "end of if" $ \endif -> - withFreshLabel "start of then" $ \tid -> - mkCbranch e tid endif <*> - mkLabel tid <*> tbranch <*> mkBranch endif <*> - mkLabel endif - - - --- ================ IMPLEMENTATION ================-- - -mkNop = emptyAGraph -mkComment fs = mkMiddle $ MidComment fs -mkStore l r = mkMiddle $ MidStore l r - --- NEED A COMPILER-DEBUGGING FLAG HERE --- Sanity check: any value assigned to a pointer must be non-zero. --- If it's 0, cause a crash immediately. -mkAssign l r = if opt_StubDeadValues then assign l r <*> check l else assign l r - where assign l r = mkMiddle (MidAssign l r) - check (CmmGlobal _) = mkNop - check l@(CmmLocal reg) = -- if a ptr arg is NULL, cause a crash! - if isGcPtrType ty then - mkCmmIfThen (CmmMachOp (MO_Eq w) [r, stackStubExpr w]) - (assign l (CmmLoad (CmmLit (CmmInt 0 w)) ty)) - else mkNop - where ty = localRegType reg - w = typeWidth ty - r = CmmReg l - - --- Why are we inserting extra blocks that simply branch to the successors? --- Because in addition to the branch instruction, @mkBranch@ will insert --- a necessary adjustment to the stack pointer. -mkCbranch pred ifso ifnot = mkLast (LastCondBranch pred ifso ifnot) -mkSwitch e tbl = mkLast $ LastSwitch e tbl - -mkSafeCall t fs as upd = - withFreshLabel "safe call" $ \k -> - mkMiddle $ MidForeignCall (Safe k upd) t fs as -mkUnsafeCall t fs as = mkMiddle $ MidForeignCall Unsafe t fs as - --- For debugging purposes, we can stub out dead stack slots: -stackStubExpr :: Width -> CmmExpr -stackStubExpr w = CmmLit (CmmInt 0 w) - --- When we copy in parameters, we usually want to put overflow --- parameters on the stack, but sometimes we want to pass --- the variables in their spill slots. --- Therefore, for copying arguments and results, we provide different --- functions to pass the arguments in an overflow area and to pass them in spill slots. -copyInOflow :: Convention -> Area -> CmmFormals -> (Int, CmmAGraph) -copyInSlot :: Convention -> CmmFormals -> CmmAGraph -copyOutOflow :: Convention -> Transfer -> Area -> CmmActuals -> UpdFrameOffset -> - (Int, [Middle]) -copyOutSlot :: Convention -> [LocalReg] -> [Middle] - -- why a list of middles here instead of an AGraph? - -copyInOflow = copyIn oneCopyOflowI -copyInSlot c f = snd $ copyIn oneCopySlotI c (panic "no area for copying to slots") f - -type SlotCopier = Area -> (LocalReg, ByteOff) -> (ByteOff, CmmAGraph) -> - (ByteOff, CmmAGraph) -type CopyIn = SlotCopier -> Convention -> Area -> CmmFormals -> (ByteOff, CmmAGraph) - --- Return the number of bytes used for copying arguments, as well as the --- instructions to copy the arguments. -copyIn :: CopyIn -copyIn oflow conv area formals = - foldr ci (init_offset, mkNop) args' - where ci (reg, RegisterParam r) (n, ms) = - (n, mkAssign (CmmLocal reg) (CmmReg $ CmmGlobal r) <*> ms) - ci (r, StackParam off) (n, ms) = oflow area (r, off) (n, ms) - init_offset = widthInBytes wordWidth -- infotable - args = assignArgumentsPos conv localRegType formals - args' = foldl adjust [] args - where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst - adjust rst x@(_, RegisterParam _) = x : rst - --- Copy-in one arg, using overflow space if needed. -oneCopyOflowI, oneCopySlotI :: SlotCopier -oneCopyOflowI area (reg, off) (n, ms) = - (max n off, mkAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty) <*> ms) - where ty = localRegType reg - --- Copy-in one arg, using spill slots if needed -- used for calling conventions at --- a procpoint that is not a return point. The offset is irrelevant here... -oneCopySlotI _ (reg, _) (n, ms) = - (n, mkAssign (CmmLocal reg) (CmmLoad (CmmStackSlot (RegSlot reg) w) ty) <*> ms) - where ty = localRegType reg - w = widthInBytes (typeWidth ty) - - --- Factoring out the common parts of the copyout functions yielded something --- more complicated: - --- The argument layout function ignores the pointer to the info table, so we slot that --- in here. When copying-out to a young area, we set the info table for return --- and adjust the offsets of the other parameters. --- If this is a call instruction, we adjust the offsets of the other parameters. -copyOutOflow conv transfer area@(CallArea a) actuals updfr_off = - foldr co (init_offset, []) args' - where co (v, RegisterParam r) (n, ms) = (n, MidAssign (CmmGlobal r) v : ms) - co (v, StackParam off) (n, ms) = - (max n off, MidStore (CmmStackSlot area off) v : ms) - (setRA, init_offset) = - case a of Young id@(BlockId _) -> -- set RA if making a call - if transfer == Call then - ([(CmmLit (CmmBlock id), StackParam init_offset)], - widthInBytes wordWidth) - else ([], 0) - Old -> ([], updfr_off) - args = assignArgumentsPos conv cmmExprType actuals - args' = foldl adjust setRA args - where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst - adjust rst x@(_, RegisterParam _) = x : rst -copyOutOflow _ _ (RegSlot _) _ _ = panic "cannot copy arguments into a register slot" - --- Args passed only in registers and stack slots; no overflow space. --- No return address may apply! -copyOutSlot conv actuals = foldr co [] args - where co (v, RegisterParam r) ms = MidAssign (CmmGlobal r) (toExp v) : ms - co (v, StackParam off) ms = - MidStore (CmmStackSlot (RegSlot v) off) (toExp v) : ms - toExp r = CmmReg (CmmLocal r) - args = assignArgumentsPos conv localRegType actuals - --- oneCopySlotO _ (reg, _) (n, ms) = --- (n, MidStore (CmmStackSlot (RegSlot reg) w) reg : ms) --- where w = widthInBytes (typeWidth (localRegType reg)) - -mkEntry :: BlockId -> Convention -> CmmFormals -> (Int, CmmAGraph) -mkEntry _ conv formals = copyInOflow conv (CallArea Old) formals - -lastWithArgs :: Transfer -> Area -> Convention -> CmmActuals -> UpdFrameOffset -> - (ByteOff -> Last) -> CmmAGraph -lastWithArgs transfer area conv actuals updfr_off last = - let (outArgs, copies) = copyOutOflow conv transfer area actuals updfr_off in - mkMiddles copies <*> mkLast (last outArgs) - --- The area created for the jump and return arguments is the same area as the --- procedure entry. -old :: Area -old = CallArea Old -toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff -> ByteOff -> Last -toCall e cont updfr_off res_space arg_space = - LastCall e cont arg_space res_space (Just updfr_off) -mkJump e actuals updfr_off = - lastWithArgs Jump old NativeNodeCall actuals updfr_off $ toCall e Nothing updfr_off 0 -mkJumpGC e actuals updfr_off = - lastWithArgs Jump old GC actuals updfr_off $ toCall e Nothing updfr_off 0 -mkForeignJump conv e actuals updfr_off = - lastWithArgs Jump old conv actuals updfr_off $ toCall e Nothing updfr_off 0 -mkReturn e actuals updfr_off = - lastWithArgs Ret old NativeReturn actuals updfr_off $ toCall e Nothing updfr_off 0 - -- where e = CmmLoad (CmmStackSlot (CallArea Old) updfr_off) gcWord -mkReturnSimple actuals updfr_off = - lastWithArgs Ret old NativeReturn actuals updfr_off $ toCall e Nothing updfr_off 0 - where e = CmmLoad (CmmStackSlot (CallArea Old) updfr_off) gcWord - -mkFinalCall f _ actuals updfr_off = - lastWithArgs Call old NativeDirectCall actuals updfr_off $ toCall f Nothing updfr_off 0 - -mkCmmCall f results actuals = mkCall f (NativeDirectCall, NativeReturn) results actuals - --- I'm dropping the SRT, but that should be okay: we plan to reconstruct it later. -mkCall f (callConv, retConv) results actuals updfr_off = - withFreshLabel "call successor" $ \k -> - let area = CallArea $ Young k - (off, copyin) = copyInOflow retConv area results - copyout = lastWithArgs Call area callConv actuals updfr_off - (toCall f (Just k) updfr_off off) - in (copyout <*> mkLabel k <*> copyin) diff -Nru ghc-7.0.3/compiler/cmm/MkZipCfg.hs ghc-7.2.1/compiler/cmm/MkZipCfg.hs --- ghc-7.0.3/compiler/cmm/MkZipCfg.hs 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/cmm/MkZipCfg.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,371 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} -module MkZipCfg - ( AGraph, (<*>), catAGraphs - , freshBlockId - , emptyAGraph, withFreshLabel, withUnique - , mkMiddle, mkMiddles, mkLast, mkZTail, mkBranch, mkLabel, mkIfThenElse, mkWhileDo - , outOfLine - , emptyGraph, graphOfMiddles, graphOfZTail - , lgraphOfAGraph, graphOfAGraph, labelAGraph, pprAGraph - ) -where - -import BlockId (BlockId(..), emptyBlockEnv, plusBlockEnv) -import ZipCfg - -import Outputable -import Unique -import UniqSupply -import Util - -import Prelude hiding (zip, unzip, last) - -#include "HsVersions.h" - -------------------------------------------------------------------------- --- GENERIC ZIPPER-BASED CONTROL-FLOW GRAPH (CONSTRUCTOR VIEW) -- -------------------------------------------------------------------------- - -{- - -You can think of an AGraph like this: it is the program built by -composing in sequence three kinds of nodes: - * Label nodes (e.g. L2:) - * Middle nodes (e.g. x = y*3) - * Last nodes (e.g. if b then goto L1 else goto L2) - -The constructors mkLabel, mkMiddle, and mkLast build single-node -AGraphs of the indicated type. The composition operator <*> glues -AGraphs together in sequence (in constant time). - -For example: - x = 0 - L1: - x = x+1 - if x<10 then goto L1 else goto L2 - L2: - y = y*x - x = 0 - -Notice that the AGraph may begin without a label, and may end without -a control transfer. Control *always* falls through a label and middle -node, and *never* falls through a Last node. - -A 'AGraph m l' is simply an abstract version of a 'Graph m l' from -module 'ZipCfg'. The only difference is that the 'AGraph m l' -supports a constant-time splicing operation, written infix <*>. -That splicing operation, together with the constructor functions in -this module (and with 'labelAGraph'), is the recommended way to build -large graphs. Each construction or splice has constant cost, and to -turn an AGraph into a Graph requires time linear in the number of -nodes and N log N in the number of basic blocks. - -The splicing operation warrants careful explanation. Like a Graph, an -AGraph is a control-flow graph which begins with a distinguished, -unlabelled sequence of middle nodes called the *entry*. An unlabelled -graph may also end with a sequence of middle nodes called the *exit*. -The entry may fall straight through to the exit, or it may fall into -the rest of the graph, which may include arbitrary control flow. - -Using ASCII art, here are examples of the two kinds of graph. On the -left, the entry and exit sequences are labelled A and B, where the -control flow in the middle is labelled X. On the right, there is no -exit sequence: - - | | - | A | C - | | - / \ / \ - / \ / \ - | X | | Y | - \ / \ / - \ / \_/ - | - | B - | - - -The AGraph has these properties: - - * A AGraph is opaque; nothing about its structure can be observed. - - * A AGraph may be turned into a LGraph in time linear in the number - of nodes and O(N log N) in the number of basic blocks. - - * Two AGraphs may be spliced in constant time by writing g1 <*> g2 - -There are two rules for splicing, depending on whether the left-hand -graph falls through. If it does, the rule is as follows: - - | | | - | A | C | A - | | | - / \ / \ / \ - / \ / \ / \ - | X | <*> | Y | = | X | - \ / \ / \ / - \ / \_/ \ / - | | | - | B | D | B - | | | - | - | C - | - / \ - / \ - | Y | - \ / - \ / - | - | D - | - -And in the case where the left-hand graph does not fall through, the -rule is - - - | | | - | A | C | A - | | | - / \ / \ / \ - / \ / \ / \ - | X | <*> | Y | = | X | - \ / \ / \ / - \_/ \_/ \_/ - | - | D _ - | / \ - / \ - | Y | - \ / - \ / - | - | D - | - -In this case C will become unreachable and is lost; when such a graph -is converted into a data structure, the system will bleat about -unreachable code. Also it must be assumed that there are branches -from somewhere in X to labelled blocks in Y; otherwise Y and D are -unreachable as well. (However, it may be the case that X branches -into some third AGraph, which in turn branches into D; the -representation is agnostic on this point.) - --} - -infixr 3 <*> -(<*>) :: AGraph m l -> AGraph m l -> AGraph m l - -catAGraphs :: [AGraph m l] -> AGraph m l - --- | A graph is built up by splicing together graphs each containing a --- single node (where a label is considered a 'first' node. The empty --- graph is a left and right unit for splicing. All of the AGraph --- constructors (even complex ones like 'mkIfThenElse', as well as the --- splicing operation <*>, are constant-time operations. - -emptyAGraph :: AGraph m l -mkLabel :: (LastNode l) => BlockId -> AGraph m l -- graph contains the label -mkMiddle :: m -> AGraph m l -- graph contains the node -mkLast :: (Outputable m, Outputable l, LastNode l) => - l -> AGraph m l -- graph contains the node - --- | This function provides access to fresh labels without requiring --- clients to be programmed monadically. -withFreshLabel :: String -> (BlockId -> AGraph m l) -> AGraph m l -withUnique :: (Unique -> AGraph m l) -> AGraph m l - - -outOfLine :: (LastNode l, Outputable m, Outputable l) - => AGraph m l -> AGraph m l --- ^ The argument is an AGraph that has an --- empty entry sequence and no exit sequence. --- The result is a new AGraph that has an empty entry sequence --- connected to an empty exit sequence, with the original graph --- sitting to the side out-of-line. --- --- Example: mkMiddle (x = 3) --- <*> outOfLine (mkLabel L <*> ...stuff...) --- <*> mkMiddle (y = x) --- Control will flow directly from x=3 to y=x; --- the block starting with L is "on the side". --- --- N.B. algebraically forall g g' : g <*> outOfLine g' == outOfLine g' <*> g - - - --- below for convenience -mkMiddles :: [m] -> AGraph m l -mkZTail :: (Outputable m, Outputable l, LastNode l) => - ZTail m l -> AGraph m l -mkBranch :: (Outputable m, Outputable l, LastNode l) => - BlockId -> AGraph m l - --- | For the structured control-flow constructs, a condition is --- represented as a function that takes as arguments the labels to --- goto on truth or falsehood. --- --- mkIfThenElse mk_cond then else --- = (mk_cond L1 L2) <*> L1: then <*> goto J --- <*> L2: else <*> goto J --- <*> J: --- --- where L1, L2, J are fresh - -mkIfThenElse :: (Outputable m, Outputable l, LastNode l) - => (BlockId -> BlockId -> AGraph m l) -- branch condition - -> AGraph m l -- code in the 'then' branch - -> AGraph m l -- code in the 'else' branch - -> AGraph m l -- resulting if-then-else construct - -mkWhileDo :: (Outputable m, Outputable l, LastNode l) - => (BlockId -> BlockId -> AGraph m l) -- loop condition - -> AGraph m l -- body of the bloop - -> AGraph m l -- the final while loop - --- | Converting an abstract graph to a concrete form is expensive: the --- cost is linear in the number of nodes in the answer, plus N log N --- in the number of basic blocks. The conversion is also monadic --- because it may require the allocation of fresh, unique labels. - -graphOfAGraph :: AGraph m l -> UniqSM (Graph m l) -lgraphOfAGraph :: AGraph m l -> UniqSM (LGraph m l) - -- ^ allocate a fresh label for the entry point -labelAGraph :: BlockId -> AGraph m l -> UniqSM (LGraph m l) - -- ^ use the given BlockId as the label of the entry point - - --- | The functions below build Graphs directly; for convenience, they --- are included here with the rest of the constructor functions. - -emptyGraph :: Graph m l -graphOfMiddles :: [m] -> Graph m l -graphOfZTail :: ZTail m l -> Graph m l - - --- ================================================================ --- IMPLEMENTATION --- ================================================================ - -newtype AGraph m l = AGraph (Graph m l -> UniqSM (Graph m l)) - -- an AGraph is a monadic function from a successor Graph to a new Graph - -AGraph f1 <*> AGraph f2 = AGraph f - where f g = f2 g >>= f1 -- note right associativity - -catAGraphs = foldr (<*>) emptyAGraph - -emptyAGraph = AGraph return - -graphOfAGraph (AGraph f) = f emptyGraph -emptyGraph = Graph (ZLast LastExit) emptyBlockEnv - -labelAGraph id g = - do Graph tail blocks <- graphOfAGraph g - return $ LGraph id $ insertBlock (Block id tail) blocks - -lgraphOfAGraph g = do id <- freshBlockId "graph entry" - labelAGraph id g - -------------------------------------- --- constructors - -mkLabel id = AGraph f - where f (Graph tail blocks) = - return $ Graph (ZLast (mkBranchNode id)) - (insertBlock (Block id tail) blocks) - -mkBranch target = mkLast $ mkBranchNode target - -mkMiddle m = AGraph f - where f (Graph tail blocks) = return $ Graph (ZTail m tail) blocks - -mkMiddles ms = AGraph f - where f (Graph tail blocks) = return $ Graph (foldr ZTail tail ms) blocks - -graphOfMiddles ms = Graph (foldr ZTail (ZLast LastExit) ms) emptyBlockEnv -graphOfZTail t = Graph t emptyBlockEnv - - -mkLast l = AGraph f - where f (Graph tail blocks) = - do note_this_code_becomes_unreachable "mkLast" (ppr l <+> ppr blocks) tail - return $ Graph (ZLast (LastOther l)) blocks - -mkZTail tail = AGraph f - where f (Graph utail blocks) = - do note_this_code_becomes_unreachable "mkZTail" (ppr tail) utail - return $ Graph tail blocks - -withFreshLabel name ofId = AGraph f - where f g = do id <- freshBlockId name - let AGraph f' = ofId id - f' g - -withUnique ofU = AGraph f - where f g = do u <- getUniqueM - let AGraph f' = ofU u - f' g - -outOfLine (AGraph f) = AGraph f' - where f' (Graph tail' blocks') = - do Graph emptyEntrance blocks <- f emptyGraph - note_this_code_becomes_unreachable "outOfLine" (ppr tail') emptyEntrance - return $ Graph tail' (blocks `plusBlockEnv` blocks') - -mkIfThenElse cbranch tbranch fbranch = - withFreshLabel "end of if" $ \endif -> - withFreshLabel "start of then" $ \tid -> - withFreshLabel "start of else" $ \fid -> - cbranch tid fid <*> - mkLabel tid <*> tbranch <*> mkBranch endif <*> - mkLabel fid <*> fbranch <*> - mkLabel endif - -mkWhileDo cbranch body = - withFreshLabel "loop test" $ \test -> - withFreshLabel "loop head" $ \head -> - withFreshLabel "end while" $ \endwhile -> - -- Forrest Baskett's while-loop layout - mkBranch test <*> mkLabel head <*> body - <*> mkLabel test <*> cbranch head endwhile - <*> mkLabel endwhile - --- | Bleat if the insertion of a last node will create unreachable code -note_this_code_becomes_unreachable :: - (Monad m, LastNode l, Outputable middle, Outputable l) => - String -> SDoc -> ZTail middle l -> m () - -note_this_code_becomes_unreachable str old = if debugIsOn then u else \_ -> return () - where u (ZLast LastExit) = return () - u (ZLast (LastOther l)) | isBranchNode l = return () - -- Note [Branch follows branch] - u tail = fail ("unreachable code in " ++ str ++ ": " ++ - (showSDoc ((ppr tail) <+> old))) - --- | The string argument to 'freshBlockId' was originally helpful in debugging --- the Quick C-- compiler, so I have kept it here even though at present it is --- thrown away at this spot---there's no reason a BlockId couldn't one day carry --- a string. - -freshBlockId :: MonadUnique m => String -> m BlockId -freshBlockId _s = getUniqueM >>= return . BlockId - -------------------------------------- --- Debugging - -pprAGraph :: (Outputable m, LastNode l, Outputable l) => AGraph m l -> UniqSM SDoc -pprAGraph g = graphOfAGraph g >>= return . ppr - -{- -Note [Branch follows branch] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Why do we say it's ok for a Branch to follow a Branch? -Because the standard constructor mkLabel-- has fall-through -semantics. So if you do a mkLabel, you finish the current block, -giving it a label, and start a new one that branches to that label. -Emitting a Branch at this point is fine: - goto L1; L2: ...stuff... --} - - diff -Nru ghc-7.0.3/compiler/cmm/OldCmm.hs ghc-7.2.1/compiler/cmm/OldCmm.hs --- ghc-7.0.3/compiler/cmm/OldCmm.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/compiler/cmm/OldCmm.hs 2011-08-07 17:10:05.000000000 +0000 @@ -0,0 +1,274 @@ +----------------------------------------------------------------------------- +-- +-- Old-style Cmm data types +-- +-- (c) The University of Glasgow 2004-2006 +-- +----------------------------------------------------------------------------- + +module OldCmm ( + Cmm, RawCmm, CmmTop, RawCmmTop, + ListGraph(..), + CmmInfo(..), UpdateFrame(..), + cmmMapGraph, cmmTopMapGraph, + cmmMapGraphM, cmmTopMapGraphM, + GenBasicBlock(..), CmmBasicBlock, blockId, blockStmts, mapBlockStmts, + CmmStmt(..), CmmReturnInfo(..), CmmHinted(..), + HintedCmmFormal, HintedCmmActual, + CmmSafety(..), CmmCallTarget(..), + module CmmDecl, + module CmmExpr, + ) where + +#include "HsVersions.h" + +import BlockId +import CmmDecl +import CmmExpr +import ForeignCall + +import ClosureInfo +import Outputable +import FastString + + +-- A [[BlockId]] is a local label. +-- Local labels must be unique within an entire compilation unit, not +-- just a single top-level item, because local labels map one-to-one +-- with assembly-language labels. + +----------------------------------------------------------------------------- +-- Info Tables +----------------------------------------------------------------------------- + +data CmmInfo + = CmmInfo + (Maybe BlockId) -- GC target. Nothing <=> CPS won't do stack check + -- JD: NOT USED BY NEW CODE GEN + (Maybe UpdateFrame) -- Update frame + CmmInfoTable -- Info table + +-- | A frame that is to be pushed before entry to the function. +-- Used to handle 'update' frames. +data UpdateFrame = + UpdateFrame + CmmExpr -- Frame header. Behaves like the target of a 'jump'. + [CmmExpr] -- Frame remainder. Behaves like the arguments of a 'jump'. + +----------------------------------------------------------------------------- +-- Cmm, CmmTop, CmmBasicBlock +----------------------------------------------------------------------------- + +-- A file is a list of top-level chunks. These may be arbitrarily +-- re-orderd during code generation. + +-- | A control-flow graph represented as a list of extended basic blocks. +newtype ListGraph i = ListGraph [GenBasicBlock i] + -- ^ Code, may be empty. The first block is the entry point. The + -- order is otherwise initially unimportant, but at some point the + -- code gen will fix the order. + + -- BlockIds must be unique across an entire compilation unit, since + -- they are translated to assembly-language labels, which scope + -- across a whole compilation unit. + +-- | Cmm with the info table as a data type +type Cmm = GenCmm CmmStatics CmmInfo (ListGraph CmmStmt) +type CmmTop = GenCmmTop CmmStatics CmmInfo (ListGraph CmmStmt) + +-- | Cmm with the info tables converted to a list of 'CmmStatic' along with the info +-- table label. If we are building without tables-next-to-code there will be no statics +-- +-- INVARIANT: if there is an info table, it has at least one CmmStatic +type RawCmm = GenCmm CmmStatics (Maybe CmmStatics) (ListGraph CmmStmt) +type RawCmmTop = GenCmmTop CmmStatics (Maybe CmmStatics) (ListGraph CmmStmt) + + +-- A basic block containing a single label, at the beginning. +-- The list of basic blocks in a top-level code block may be re-ordered. +-- Fall-through is not allowed: there must be an explicit jump at the +-- end of each basic block, but the code generator might rearrange basic +-- blocks in order to turn some jumps into fallthroughs. + +data GenBasicBlock i = BasicBlock BlockId [i] +type CmmBasicBlock = GenBasicBlock CmmStmt + +instance UserOfLocalRegs i => UserOfLocalRegs (GenBasicBlock i) where + foldRegsUsed f set (BasicBlock _ l) = foldRegsUsed f set l + +blockId :: GenBasicBlock i -> BlockId +-- The branch block id is that of the first block in +-- the branch, which is that branch's entry point +blockId (BasicBlock blk_id _ ) = blk_id + +blockStmts :: GenBasicBlock i -> [i] +blockStmts (BasicBlock _ stmts) = stmts + + +mapBlockStmts :: (i -> i') -> GenBasicBlock i -> GenBasicBlock i' +mapBlockStmts f (BasicBlock id bs) = BasicBlock id (map f bs) +---------------------------------------------------------------- +-- graph maps +---------------------------------------------------------------- + +cmmMapGraph :: (g -> g') -> GenCmm d h g -> GenCmm d h g' +cmmTopMapGraph :: (g -> g') -> GenCmmTop d h g -> GenCmmTop d h g' + +cmmMapGraphM :: Monad m => (String -> g -> m g') -> GenCmm d h g -> m (GenCmm d h g') +cmmTopMapGraphM :: Monad m => (String -> g -> m g') -> GenCmmTop d h g -> m (GenCmmTop d h g') + +cmmMapGraph f (Cmm tops) = Cmm $ map (cmmTopMapGraph f) tops +cmmTopMapGraph f (CmmProc h l g) = CmmProc h l (f g) +cmmTopMapGraph _ (CmmData s ds) = CmmData s ds + +cmmMapGraphM f (Cmm tops) = mapM (cmmTopMapGraphM f) tops >>= return . Cmm +cmmTopMapGraphM f (CmmProc h l g) = + f (showSDoc $ ppr l) g >>= return . CmmProc h l +cmmTopMapGraphM _ (CmmData s ds) = return $ CmmData s ds + + +data CmmReturnInfo = CmmMayReturn + | CmmNeverReturns + deriving ( Eq ) + +----------------------------------------------------------------------------- +-- CmmStmt +-- A "statement". Note that all branches are explicit: there are no +-- control transfers to computed addresses, except when transfering +-- control to a new function. +----------------------------------------------------------------------------- + +data CmmStmt -- Old-style + = CmmNop + | CmmComment FastString + + | CmmAssign CmmReg CmmExpr -- Assign to register + + | CmmStore CmmExpr CmmExpr -- Assign to memory location. Size is + -- given by cmmExprType of the rhs. + + | CmmCall -- A call (foreign, native or primitive), with + CmmCallTarget + [HintedCmmFormal] -- zero or more results + [HintedCmmActual] -- zero or more arguments + CmmSafety -- whether to build a continuation + CmmReturnInfo + -- Some care is necessary when handling the arguments of these, see + -- [Register parameter passing] and the hack in cmm/CmmOpt.hs + + | CmmBranch BlockId -- branch to another BB in this fn + + | CmmCondBranch CmmExpr BlockId -- conditional branch + + | CmmSwitch CmmExpr [Maybe BlockId] -- Table branch + -- The scrutinee is zero-based; + -- zero -> first block + -- one -> second block etc + -- Undefined outside range, and when there's a Nothing + + | CmmJump CmmExpr -- Jump to another C-- function, + [HintedCmmActual] -- with these parameters. (parameters never used) + + | CmmReturn -- Return from a native C-- function, + [HintedCmmActual] -- with these return values. (parameters never used) + +data CmmHinted a = CmmHinted { hintlessCmm :: a, cmmHint :: ForeignHint } + deriving( Eq ) + +type HintedCmmFormal = CmmHinted CmmFormal +type HintedCmmActual = CmmHinted CmmActual + +data CmmSafety = CmmUnsafe | CmmSafe C_SRT | CmmInterruptible + +-- | enable us to fold used registers over '[CmmActual]' and '[CmmFormal]' +instance UserOfLocalRegs CmmStmt where + foldRegsUsed f (set::b) s = stmt s set + where + stmt :: CmmStmt -> b -> b + stmt (CmmNop) = id + stmt (CmmComment {}) = id + stmt (CmmAssign _ e) = gen e + stmt (CmmStore e1 e2) = gen e1 . gen e2 + stmt (CmmCall target _ es _ _) = gen target . gen es + stmt (CmmBranch _) = id + stmt (CmmCondBranch e _) = gen e + stmt (CmmSwitch e _) = gen e + stmt (CmmJump e es) = gen e . gen es + stmt (CmmReturn es) = gen es + + gen :: UserOfLocalRegs a => a -> b -> b + gen a set = foldRegsUsed f set a + +instance UserOfLocalRegs CmmCallTarget where + foldRegsUsed f set (CmmCallee e _) = foldRegsUsed f set e + foldRegsUsed _ set (CmmPrim {}) = set + +instance UserOfSlots CmmCallTarget where + foldSlotsUsed f set (CmmCallee e _) = foldSlotsUsed f set e + foldSlotsUsed _ set (CmmPrim {}) = set + +instance UserOfLocalRegs a => UserOfLocalRegs (CmmHinted a) where + foldRegsUsed f set a = foldRegsUsed f set (hintlessCmm a) + +instance UserOfSlots a => UserOfSlots (CmmHinted a) where + foldSlotsUsed f set a = foldSlotsUsed f set (hintlessCmm a) + +instance DefinerOfLocalRegs a => DefinerOfLocalRegs (CmmHinted a) where + foldRegsDefd f set a = foldRegsDefd f set (hintlessCmm a) + +{- +Discussion +~~~~~~~~~~ + +One possible problem with the above type is that the only way to do a +non-local conditional jump is to encode it as a branch to a block that +contains a single jump. This leads to inefficient code in the back end. + +[N.B. This problem will go away when we make the transition to the +'zipper' form of control-flow graph, in which both targets of a +conditional jump are explicit. ---NR] + +One possible way to fix this would be: + +data CmmStat = + ... + | CmmJump CmmBranchDest + | CmmCondJump CmmExpr CmmBranchDest + ... + +data CmmBranchDest + = Local BlockId + | NonLocal CmmExpr [LocalReg] + +In favour: + ++ one fewer constructors in CmmStmt ++ allows both cond branch and switch to jump to non-local destinations + +Against: + +- not strictly necessary: can already encode as branch+jump +- not always possible to implement any better in the back end +- could do the optimisation in the back end (but then plat-specific?) +- C-- doesn't have it +- back-end optimisation might be more general (jump shortcutting) + +So we'll stick with the way it is, and add the optimisation to the NCG. +-} + +----------------------------------------------------------------------------- +-- CmmCallTarget +-- +-- The target of a CmmCall. +----------------------------------------------------------------------------- + +data CmmCallTarget + = CmmCallee -- Call a function (foreign or native) + CmmExpr -- literal label <=> static call + -- other expression <=> dynamic call + CCallConv -- The calling convention + + | CmmPrim -- Call a "primitive" (eg. sin, cos) + CallishMachOp -- These might be implemented as inline + -- code by the backend. + deriving Eq diff -Nru ghc-7.0.3/compiler/cmm/OldCmmUtils.hs ghc-7.2.1/compiler/cmm/OldCmmUtils.hs --- ghc-7.0.3/compiler/cmm/OldCmmUtils.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/compiler/cmm/OldCmmUtils.hs 2011-08-07 17:10:05.000000000 +0000 @@ -0,0 +1,98 @@ +----------------------------------------------------------------------------- +-- +-- Old-style Cmm utilities. +-- +-- (c) The University of Glasgow 2004-2006 +-- +----------------------------------------------------------------------------- + +module OldCmmUtils( + CmmStmts, noStmts, oneStmt, mkStmts, plusStmts, stmtList, + isNopStmt, + + maybeAssignTemp, loadArgsIntoTemps, + + module CmmUtils, + ) where + +#include "HsVersions.h" + +import OldCmm +import CmmUtils +import OrdList +import Unique + +--------------------------------------------------- +-- +-- CmmStmts +-- +--------------------------------------------------- + +type CmmStmts = OrdList CmmStmt + +noStmts :: CmmStmts +noStmts = nilOL + +oneStmt :: CmmStmt -> CmmStmts +oneStmt = unitOL + +mkStmts :: [CmmStmt] -> CmmStmts +mkStmts = toOL + +plusStmts :: CmmStmts -> CmmStmts -> CmmStmts +plusStmts = appOL + +stmtList :: CmmStmts -> [CmmStmt] +stmtList = fromOL + + +--------------------------------------------------- +-- +-- CmmStmt +-- +--------------------------------------------------- + +isNopStmt :: CmmStmt -> Bool +-- If isNopStmt returns True, the stmt is definitely a no-op; +-- but it might be a no-op even if isNopStmt returns False +isNopStmt CmmNop = True +isNopStmt (CmmAssign r e) = cheapEqReg r e +isNopStmt (CmmStore e1 (CmmLoad e2 _)) = cheapEqExpr e1 e2 +isNopStmt _ = False + +cheapEqExpr :: CmmExpr -> CmmExpr -> Bool +cheapEqExpr (CmmReg r) e = cheapEqReg r e +cheapEqExpr (CmmRegOff r 0) e = cheapEqReg r e +cheapEqExpr (CmmRegOff r n) (CmmRegOff r' n') = r==r' && n==n' +cheapEqExpr _ _ = False + +cheapEqReg :: CmmReg -> CmmExpr -> Bool +cheapEqReg r (CmmReg r') = r==r' +cheapEqReg r (CmmRegOff r' 0) = r==r' +cheapEqReg _ _ = False + +--------------------------------------------------- +-- +-- Helpers for foreign call arguments +-- +--------------------------------------------------- + +loadArgsIntoTemps :: [Unique] + -> [HintedCmmActual] + -> ([Unique], [CmmStmt], [HintedCmmActual]) +loadArgsIntoTemps uniques [] = (uniques, [], []) +loadArgsIntoTemps uniques ((CmmHinted e hint):args) = + (uniques'', + new_stmts ++ remaining_stmts, + (CmmHinted new_e hint) : remaining_e) + where + (uniques', new_stmts, new_e) = maybeAssignTemp uniques e + (uniques'', remaining_stmts, remaining_e) = + loadArgsIntoTemps uniques' args + + +maybeAssignTemp :: [Unique] -> CmmExpr -> ([Unique], [CmmStmt], CmmExpr) +maybeAssignTemp uniques e + | hasNoGlobalRegs e = (uniques, [], e) + | otherwise = (tail uniques, [CmmAssign local e], CmmReg local) + where local = CmmLocal (LocalReg (head uniques) (cmmExprType e)) diff -Nru ghc-7.0.3/compiler/cmm/OldPprCmm.hs ghc-7.2.1/compiler/cmm/OldPprCmm.hs --- ghc-7.0.3/compiler/cmm/OldPprCmm.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/compiler/cmm/OldPprCmm.hs 2011-08-07 17:10:05.000000000 +0000 @@ -0,0 +1,276 @@ +---------------------------------------------------------------------------- +-- +-- Pretty-printing of old-style Cmm as (a superset of) C-- +-- +-- (c) The University of Glasgow 2004-2006 +-- +----------------------------------------------------------------------------- + +-- +-- This is where we walk over Cmm emitting an external representation, +-- suitable for parsing, in a syntax strongly reminiscent of C--. This +-- is the "External Core" for the Cmm layer. +-- +-- As such, this should be a well-defined syntax: we want it to look nice. +-- Thus, we try wherever possible to use syntax defined in [1], +-- "The C-- Reference Manual", http://www.cminusminus.org/. We differ +-- slightly, in some cases. For one, we use I8 .. I64 for types, rather +-- than C--'s bits8 .. bits64. +-- +-- We try to ensure that all information available in the abstract +-- syntax is reproduced, or reproducible, in the concrete syntax. +-- Data that is not in printed out can be reconstructed according to +-- conventions used in the pretty printer. There are at least two such +-- cases: +-- 1) if a value has wordRep type, the type is not appended in the +-- output. +-- 2) MachOps that operate over wordRep type are printed in a +-- C-style, rather than as their internal MachRep name. +-- +-- These conventions produce much more readable Cmm output. +-- +-- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs +-- + +module OldPprCmm + ( pprStmt + , module PprCmmDecl + , module PprCmmExpr + ) +where + +import BlockId +import CLabel +import CmmUtils +import OldCmm +import PprCmmDecl +import PprCmmExpr + + +import BasicTypes +import ForeignCall +import Outputable +import Platform +import FastString + +import Data.List + +----------------------------------------------------------------------------- + +instance PlatformOutputable instr => PlatformOutputable (ListGraph instr) where + pprPlatform platform (ListGraph blocks) = vcat (map (pprPlatform platform) blocks) + +instance PlatformOutputable instr => PlatformOutputable (GenBasicBlock instr) where + pprPlatform platform b = pprBBlock platform b + +instance Outputable CmmStmt where + ppr s = pprStmt s +instance PlatformOutputable CmmStmt where + pprPlatform _ = ppr + +instance Outputable CmmInfo where + ppr e = pprInfo e + + +-- -------------------------------------------------------------------------- +instance Outputable CmmSafety where + ppr CmmUnsafe = ptext (sLit "_unsafe_call_") + ppr CmmInterruptible = ptext (sLit "_interruptible_call_") + ppr (CmmSafe srt) = ppr srt + +-- -------------------------------------------------------------------------- +-- Info tables. The current pretty printer needs refinement +-- but will work for now. +-- +-- For ideas on how to refine it, they used to be printed in the +-- style of C--'s 'stackdata' declaration, just inside the proc body, +-- and were labelled with the procedure name ++ "_info". +pprInfo :: CmmInfo -> SDoc +pprInfo (CmmInfo _gc_target update_frame CmmNonInfoTable) = + vcat [{-ptext (sLit "gc_target: ") <> + maybe (ptext (sLit "")) ppr gc_target,-} + ptext (sLit "update_frame: ") <> + maybe (ptext (sLit "")) pprUpdateFrame update_frame] +pprInfo (CmmInfo _gc_target update_frame info_table@(CmmInfoTable _ _ _ _ _)) = + vcat [{-ptext (sLit "gc_target: ") <> + maybe (ptext (sLit "")) ppr gc_target,-} + ptext (sLit "update_frame: ") <> + maybe (ptext (sLit "")) pprUpdateFrame update_frame, + ppr info_table] + + +-- -------------------------------------------------------------------------- +-- Basic blocks look like assembly blocks. +-- lbl: stmt ; stmt ; .. +pprBBlock :: PlatformOutputable stmt => Platform -> GenBasicBlock stmt -> SDoc +pprBBlock platform (BasicBlock ident stmts) = + hang (ppr ident <> colon) 4 (vcat (map (pprPlatform platform) stmts)) + +-- -------------------------------------------------------------------------- +-- Statements. C-- usually, exceptions to this should be obvious. +-- +pprStmt :: CmmStmt -> SDoc +pprStmt stmt = case stmt of + + -- ; + CmmNop -> semi + + -- // text + CmmComment s -> text "//" <+> ftext s + + -- reg = expr; + CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi + + -- rep[lv] = expr; + CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi + where + rep = ppr ( cmmExprType expr ) + + -- call "ccall" foo(x, y)[r1, r2]; + -- ToDo ppr volatile + CmmCall (CmmCallee fn cconv) results args safety ret -> + sep [ pp_lhs <+> pp_conv + , nest 2 (pprExpr9 fn <> + parens (commafy (map ppr_ar args))) + <> brackets (ppr safety) + , case ret of CmmMayReturn -> empty + CmmNeverReturns -> ptext $ sLit (" never returns") + ] <> semi + where + pp_lhs | null results = empty + | otherwise = commafy (map ppr_ar results) <+> equals + -- Don't print the hints on a native C-- call + ppr_ar (CmmHinted ar k) = case cconv of + CmmCallConv -> ppr ar + _ -> ppr (ar,k) + pp_conv = case cconv of + CmmCallConv -> empty + _ -> ptext (sLit("foreign")) <+> doubleQuotes (ppr cconv) + + -- Call a CallishMachOp, like sin or cos that might be implemented as a library call. + CmmCall (CmmPrim op) results args safety ret -> + pprStmt (CmmCall (CmmCallee (CmmLit lbl) CCallConv) + results args safety ret) + where + -- HACK: A CallishMachOp doesn't really correspond to a ForeignLabel, but we + -- use one to get the label printed. + lbl = CmmLabel (mkForeignLabel + (mkFastString (show op)) + Nothing ForeignLabelInThisPackage IsFunction) + + CmmBranch ident -> genBranch ident + CmmCondBranch expr ident -> genCondBranch expr ident + CmmJump expr params -> genJump expr params + CmmReturn params -> genReturn params + CmmSwitch arg ids -> genSwitch arg ids + +-- Just look like a tuple, since it was a tuple before +-- ... is that a good idea? --Isaac Dupree +instance (Outputable a) => Outputable (CmmHinted a) where + ppr (CmmHinted a k) = ppr (a, k) + +pprUpdateFrame :: UpdateFrame -> SDoc +pprUpdateFrame (UpdateFrame expr args) = + hcat [ ptext (sLit "jump") + , space + , if isTrivialCmmExpr expr + then pprExpr expr + else case expr of + CmmLoad (CmmReg _) _ -> pprExpr expr + _ -> parens (pprExpr expr) + , space + , parens ( commafy $ map ppr args ) ] + + +-- -------------------------------------------------------------------------- +-- goto local label. [1], section 6.6 +-- +-- goto lbl; +-- +genBranch :: BlockId -> SDoc +genBranch ident = + ptext (sLit "goto") <+> ppr ident <> semi + +-- -------------------------------------------------------------------------- +-- Conditional. [1], section 6.4 +-- +-- if (expr) { goto lbl; } +-- +genCondBranch :: CmmExpr -> BlockId -> SDoc +genCondBranch expr ident = + hsep [ ptext (sLit "if") + , parens(ppr expr) + , ptext (sLit "goto") + , ppr ident <> semi ] + +-- -------------------------------------------------------------------------- +-- A tail call. [1], Section 6.9 +-- +-- jump foo(a, b, c); +-- +genJump :: CmmExpr -> [CmmHinted CmmExpr] -> SDoc +genJump expr args = + hcat [ ptext (sLit "jump") + , space + , if isTrivialCmmExpr expr + then pprExpr expr + else case expr of + CmmLoad (CmmReg _) _ -> pprExpr expr + _ -> parens (pprExpr expr) + , space + , parens ( commafy $ map ppr args ) + , semi ] + + +-- -------------------------------------------------------------------------- +-- Return from a function. [1], Section 6.8.2 of version 1.128 +-- +-- return (a, b, c); +-- +genReturn :: [CmmHinted CmmExpr] -> SDoc +genReturn args = + hcat [ ptext (sLit "return") + , space + , parens ( commafy $ map ppr args ) + , semi ] + +-- -------------------------------------------------------------------------- +-- Tabled jump to local label +-- +-- The syntax is from [1], section 6.5 +-- +-- switch [0 .. n] (expr) { case ... ; } +-- +genSwitch :: CmmExpr -> [Maybe BlockId] -> SDoc +genSwitch expr maybe_ids + + = let pairs = groupBy snds (zip [0 .. ] maybe_ids ) + + in hang (hcat [ ptext (sLit "switch [0 .. ") + , int (length maybe_ids - 1) + , ptext (sLit "] ") + , if isTrivialCmmExpr expr + then pprExpr expr + else parens (pprExpr expr) + , ptext (sLit " {") + ]) + 4 (vcat ( map caseify pairs )) $$ rbrace + + where + snds a b = (snd a) == (snd b) + + caseify :: [(Int,Maybe BlockId)] -> SDoc + caseify ixs@((_,Nothing):_) + = ptext (sLit "/* impossible: ") <> hcat (intersperse comma (map (int.fst) ixs)) + <> ptext (sLit " */") + caseify as + = let (is,ids) = unzip as + in hsep [ ptext (sLit "case") + , hcat (punctuate comma (map int is)) + , ptext (sLit ": goto") + , ppr (head [ id | Just id <- ids]) <> semi ] + +----------------------------------------------------------------------------- + +commafy :: [SDoc] -> SDoc +commafy xs = fsep $ punctuate comma xs diff -Nru ghc-7.0.3/compiler/cmm/OptimizationFuel.hs ghc-7.2.1/compiler/cmm/OptimizationFuel.hs --- ghc-7.0.3/compiler/cmm/OptimizationFuel.hs 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/cmm/OptimizationFuel.hs 2011-08-07 17:10:05.000000000 +0000 @@ -1,3 +1,4 @@ +{-# LANGUAGE TypeFamilies #-} -- | Optimisation fuel is used to control the amount of work the optimiser does. -- -- Every optimisation step consumes a certain amount of fuel and stops when @@ -5,27 +6,25 @@ -- the optimiser with varying amount of fuel to find out the exact number of -- steps where a bug is introduced in the output. module OptimizationFuel - ( OptimizationFuel, canRewriteWithFuel, maybeRewriteWithFuel, oneLessFuel - , OptFuelState, initOptFuelState --, setTotalFuel - , tankFilledTo, diffFuel - , FuelConsumer - , FuelUsingMonad, FuelState - , lastFuelPass, fuelExhausted, fuelRemaining, fuelDecrement, fuelDec1 - , runFuelIO, fuelConsumingPass - , FuelMonad + ( OptimizationFuel, amountOfFuel, tankFilledTo, unlimitedFuel, anyFuelLeft, oneLessFuel + , OptFuelState, initOptFuelState + , FuelConsumer, FuelUsingMonad, FuelState + , fuelGet, fuelSet, lastFuelPass, setFuelPass + , fuelExhausted, fuelDec1, tryWithFuel + , runFuelIO, runInfiniteFuelIO, fuelConsumingPass + , FuelUniqSM , liftUniq - , lGraphOfGraph -- needs to be able to create a unique ID... ) where -import BlockId -import ZipCfg ---import GHC.Exts (State#) -import Panic import Data.IORef import Control.Monad import StaticFlags (opt_Fuel) import UniqSupply +import Panic + +import Compiler.Hoopl +import Compiler.Hoopl.GHC (getFuel, setFuel) #include "HsVersions.h" @@ -45,45 +44,35 @@ type FuelConsumer a = OptimizationFuel -> (a, OptimizationFuel) -canRewriteWithFuel :: OptimizationFuel -> Bool -oneLessFuel :: OptimizationFuel -> OptimizationFuel -maybeRewriteWithFuel :: OptimizationFuel -> Maybe a -> Maybe a -diffFuel :: OptimizationFuel -> OptimizationFuel -> Int - -- to measure consumption during compilation tankFilledTo :: Int -> OptimizationFuel +amountOfFuel :: OptimizationFuel -> Int + +anyFuelLeft :: OptimizationFuel -> Bool +oneLessFuel :: OptimizationFuel -> OptimizationFuel +unlimitedFuel :: OptimizationFuel -#ifdef DEBUG newtype OptimizationFuel = OptimizationFuel Int deriving Show tankFilledTo = OptimizationFuel -canRewriteWithFuel (OptimizationFuel f) = f > 0 -maybeRewriteWithFuel fuel ma = if canRewriteWithFuel fuel then ma else Nothing +amountOfFuel (OptimizationFuel f) = f + +anyFuelLeft (OptimizationFuel f) = f > 0 oneLessFuel (OptimizationFuel f) = ASSERT (f > 0) (OptimizationFuel (f - 1)) -diffFuel (OptimizationFuel f) (OptimizationFuel f') = f - f' -#else --- type OptimizationFuel = State# () -- would like this, but it won't work -data OptimizationFuel = OptimizationFuel - deriving Show -tankFilledTo _ = panic "tankFilledTo" -- should be impossible to evaluate - -- realWorld# might come in handy, too... -canRewriteWithFuel OptimizationFuel = True -maybeRewriteWithFuel _ ma = ma -oneLessFuel f = f -diffFuel _ _ = 0 -#endif +unlimitedFuel = OptimizationFuel infiniteFuel -data FuelState = FuelState { fs_fuellimit :: OptimizationFuel, fs_lastpass :: String } -newtype FuelMonad a = FuelMonad (FuelState -> UniqSM (a, FuelState)) +data FuelState = FuelState { fs_fuel :: OptimizationFuel, fs_lastpass :: String } +newtype FuelUniqSM a = FUSM { unFUSM :: FuelState -> UniqSM (a, FuelState) } -fuelConsumingPass :: String -> FuelConsumer a -> FuelMonad a -fuelConsumingPass name f = do fuel <- fuelRemaining +fuelConsumingPass :: String -> FuelConsumer a -> FuelUniqSM a +fuelConsumingPass name f = do setFuelPass name + fuel <- fuelGet let (a, fuel') = f fuel - fuelDecrement name fuel fuel' + fuelSet fuel' return a -runFuelIO :: OptFuelState -> FuelMonad a -> IO a -runFuelIO fs (FuelMonad f) = +runFuelIO :: OptFuelState -> FuelUniqSM a -> IO a +runFuelIO fs (FUSM f) = do pass <- readIORef (pass_ref fs) fuel <- readIORef (fuel_ref fs) u <- mkSplitUniqSupply 'u' @@ -92,49 +81,61 @@ writeIORef (fuel_ref fs) fuel' return a -instance Monad FuelMonad where - FuelMonad f >>= k = FuelMonad (\s -> do (a, s') <- f s - let FuelMonad f' = k a in (f' s')) - return a = FuelMonad (\s -> return (a, s)) +-- ToDo: Do we need the pass_ref when we are doing infinite fueld +-- transformations? +runInfiniteFuelIO :: OptFuelState -> FuelUniqSM a -> IO a +runInfiniteFuelIO fs (FUSM f) = + do pass <- readIORef (pass_ref fs) + u <- mkSplitUniqSupply 'u' + let (a, FuelState _ pass') = initUs_ u $ f (FuelState unlimitedFuel pass) + writeIORef (pass_ref fs) pass' + return a -instance MonadUnique FuelMonad where +instance Monad FuelUniqSM where + FUSM f >>= k = FUSM (\s -> f s >>= \(a, s') -> unFUSM (k a) s') + return a = FUSM (\s -> return (a, s)) + +instance MonadUnique FuelUniqSM where getUniqueSupplyM = liftUniq getUniqueSupplyM getUniqueM = liftUniq getUniqueM getUniquesM = liftUniq getUniquesM -liftUniq :: UniqSM x -> FuelMonad x -liftUniq x = FuelMonad (\s -> x >>= (\u -> return (u, s))) + +liftUniq :: UniqSM x -> FuelUniqSM x +liftUniq x = FUSM (\s -> x >>= (\u -> return (u, s))) class Monad m => FuelUsingMonad m where - fuelRemaining :: m OptimizationFuel - fuelDecrement :: String -> OptimizationFuel -> OptimizationFuel -> m () - fuelDec1 :: m () - fuelExhausted :: m Bool - lastFuelPass :: m String - -instance FuelUsingMonad FuelMonad where - fuelRemaining = extract fs_fuellimit - lastFuelPass = extract fs_lastpass - fuelExhausted = extract $ not . canRewriteWithFuel . fs_fuellimit - fuelDecrement p f f' = FuelMonad (\s -> return ((), fuelDecrementState p f f' s)) - fuelDec1 = FuelMonad f - where f s = if canRewriteWithFuel (fs_fuellimit s) then - return ((), s { fs_fuellimit = oneLessFuel (fs_fuellimit s) }) - else panic "Tried to use exhausted fuel supply" - -extract :: (FuelState -> a) -> FuelMonad a -extract f = FuelMonad (\s -> return (f s, s)) - -fuelDecrementState - :: String -> OptimizationFuel -> OptimizationFuel -> FuelState -> FuelState -fuelDecrementState new_optimizer old new s = - FuelState { fs_fuellimit = lim, fs_lastpass = optimizer } - where lim = if diffFuel old (fs_fuellimit s) == 0 then new - else panic $ - concat ["lost track of ", new_optimizer, "'s transactions"] - optimizer = if diffFuel old new > 0 then new_optimizer else fs_lastpass s - --- lGraphOfGraph is here because we need uniques to implement it. -lGraphOfGraph :: Graph m l -> FuelMonad (LGraph m l) -lGraphOfGraph (Graph tail blocks) = - do entry <- liftM BlockId $ getUniqueM - return $ LGraph entry (insertBlock (Block entry tail) blocks) + fuelGet :: m OptimizationFuel + fuelSet :: OptimizationFuel -> m () + lastFuelPass :: m String + setFuelPass :: String -> m () + +fuelExhausted :: FuelUsingMonad m => m Bool +fuelExhausted = fuelGet >>= return . anyFuelLeft + +fuelDec1 :: FuelUsingMonad m => m () +fuelDec1 = fuelGet >>= fuelSet . oneLessFuel + +tryWithFuel :: FuelUsingMonad m => a -> m (Maybe a) +tryWithFuel r = do f <- fuelGet + if anyFuelLeft f then fuelSet (oneLessFuel f) >> return (Just r) + else return Nothing + +instance FuelUsingMonad FuelUniqSM where + fuelGet = extract fs_fuel + lastFuelPass = extract fs_lastpass + fuelSet fuel = FUSM (\s -> return ((), s { fs_fuel = fuel })) + setFuelPass pass = FUSM (\s -> return ((), s { fs_lastpass = pass })) + +extract :: (FuelState -> a) -> FuelUniqSM a +extract f = FUSM (\s -> return (f s, s)) + +instance FuelMonad FuelUniqSM where + getFuel = liftM amountOfFuel fuelGet + setFuel = fuelSet . tankFilledTo + +-- Don't bother to checkpoint the unique supply; it doesn't matter +instance CheckpointMonad FuelUniqSM where + type Checkpoint FuelUniqSM = FuelState + checkpoint = FUSM $ \fuel -> return (fuel, fuel) + restart fuel = FUSM $ \_ -> return ((), fuel) + diff -Nru ghc-7.0.3/compiler/cmm/PprC.hs ghc-7.2.1/compiler/cmm/PprC.hs --- ghc-7.0.3/compiler/cmm/PprC.hs 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/cmm/PprC.hs 2011-08-07 17:10:05.000000000 +0000 @@ -1,10 +1,3 @@ -{-# OPTIONS -w #-} --- 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 - ----------------------------------------------------------------------------- -- -- Pretty-printing of Cmm as C, suitable for feeding gcc @@ -23,8 +16,6 @@ -- disappeared from the data type. -- --- ToDo: save/restore volatile registers around calls. - module PprC ( writeCs, pprStringInCStyle @@ -34,22 +25,19 @@ -- Cmm stuff import BlockId -import Cmm -import PprCmm () -- Instances only +import OldCmm +import OldPprCmm () import CLabel import ForeignCall -import ClosureInfo -- Utils import DynFlags import Unique import UniqSet -import UniqFM import FastString import Outputable import Constants -import BasicTypes -import CLabel +import Util -- The rest import Data.List @@ -63,10 +51,6 @@ import Data.Array.ST import Control.Monad.ST -#if x86_64_TARGET_ARCH -import StaticFlags ( opt_Unregisterised ) -#endif - #if defined(alpha_TARGET_ARCH) || defined(mips_TARGET_ARCH) || defined(mipsel_TARGET_ARCH) || defined(arm_TARGET_ARCH) #define BEWARE_LOAD_STORE_ALIGNMENT #endif @@ -80,7 +64,7 @@ where split_marker | dopt Opt_SplitObjs dflags = ptext (sLit "__STG_SPLIT_MARKER") - | otherwise = empty + | otherwise = empty writeCs :: DynFlags -> Handle -> [RawCmm] -> IO () writeCs dflags handle cmms @@ -99,59 +83,50 @@ -- top level procs -- pprTop :: RawCmmTop -> SDoc -pprTop (CmmProc info clbl _params (ListGraph blocks)) = - (if not (null info) - then pprDataExterns info $$ - pprWordArray (entryLblToInfoLbl clbl) info - else empty) $$ - (case blocks of - [] -> empty - -- the first block doesn't get a label: - (BasicBlock _ stmts : rest) -> vcat [ - blankLine, - extern_decls, +pprTop (CmmProc mb_info clbl (ListGraph blocks)) = + (case mb_info of + Nothing -> empty + Just (Statics info_clbl info_dat) -> pprDataExterns info_dat $$ + pprWordArray info_clbl info_dat) $$ + (vcat [ + blankLine, + extern_decls, (if (externallyVisibleCLabel clbl) then mkFN_ else mkIF_) (pprCLabel clbl) <+> lbrace, nest 8 temp_decls, nest 8 mkFB_, - nest 8 (vcat (map pprStmt stmts)) $$ - vcat (map pprBBlock rest), + case blocks of + [] -> empty + -- the first block doesn't get a label: + (BasicBlock _ stmts : rest) -> + nest 8 (vcat (map pprStmt stmts)) $$ + vcat (map pprBBlock rest), nest 8 mkFE_, rbrace ] ) where - (temp_decls, extern_decls) = pprTempAndExternDecls blocks + (temp_decls, extern_decls) = pprTempAndExternDecls blocks -- Chunks of static data. -- We only handle (a) arrays of word-sized things and (b) strings. -pprTop (CmmData _section _ds@[CmmDataLabel lbl, CmmString str]) = +pprTop (CmmData _section (Statics lbl [CmmString str])) = hcat [ pprLocalness lbl, ptext (sLit "char "), pprCLabel lbl, ptext (sLit "[] = "), pprStringInCStyle str, semi ] -pprTop (CmmData _section _ds@[CmmDataLabel lbl, CmmUninitialised size]) = +pprTop (CmmData _section (Statics lbl [CmmUninitialised size])) = hcat [ pprLocalness lbl, ptext (sLit "char "), pprCLabel lbl, brackets (int size), semi ] -pprTop top@(CmmData _section (CmmDataLabel lbl : lits)) = +pprTop (CmmData _section (Statics lbl lits)) = pprDataExterns lits $$ - pprWordArray lbl lits - --- Floating info table for safe a foreign call. -pprTop top@(CmmData _section d@(_ : _)) - | CmmDataLabel lbl : lits <- reverse d = - let lits' = reverse lits - in pprDataExterns lits' $$ - pprWordArray lbl lits' - --- these shouldn't appear? -pprTop (CmmData _ _) = panic "PprC.pprTop: can't handle this data" + pprWordArray lbl lits -- -------------------------------------------------------------------------- -- BasicBlocks are self-contained entities: they always end in a jump. @@ -194,8 +169,9 @@ pprStmt :: CmmStmt -> SDoc pprStmt stmt = case stmt of + CmmReturn _ -> panic "pprStmt: return statement should have been cps'd away" CmmNop -> empty - CmmComment s -> empty -- (hang (ptext (sLit "/*")) 3 (ftext s)) $$ ptext (sLit "*/") + CmmComment _ -> empty -- (hang (ptext (sLit "/*")) 3 (ftext s)) $$ ptext (sLit "*/") -- XXX if the string contains "*/", we need to fix it -- XXX we probably want to emit these comments when -- some debugging option is on. They can get quite @@ -259,16 +235,20 @@ -- for a dynamic call, no declaration is necessary. CmmCall (CmmPrim op) results args safety _ret -> - pprCall ppr_fn CCallConv results args safety + pprCall ppr_fn CCallConv results args' safety where ppr_fn = pprCallishMachOp_for_C op + -- The mem primops carry an extra alignment arg, must drop it. + -- We could maybe emit an alignment directive using this info. + args' | op == MO_Memcpy || op == MO_Memset || op == MO_Memmove = init args + | otherwise = args CmmBranch ident -> pprBranch ident CmmCondBranch expr ident -> pprCondBranch expr ident CmmJump lbl _params -> mkJMP_(pprExpr lbl) <> semi CmmSwitch arg ids -> pprSwitch arg ids -pprCFunType :: SDoc -> CCallConv -> HintedCmmFormals -> HintedCmmActuals -> SDoc +pprCFunType :: SDoc -> CCallConv -> [HintedCmmFormal] -> [HintedCmmActual] -> SDoc pprCFunType ppr_fn cconv ress args = res_type ress <+> parens (text (ccallConvAttribute cconv) <> ppr_fn) <> @@ -276,6 +256,7 @@ where res_type [] = ptext (sLit "void") res_type [CmmHinted one hint] = machRepHintCType (localRegType one) hint + res_type _ = panic "pprCFunType: only void or 1 return value supported" arg_type (CmmHinted expr hint) = machRepHintCType (cmmExprType expr) hint @@ -325,6 +306,8 @@ hsep [ ptext (sLit "case") , pprHexVal ix wordWidth <> colon , ptext (sLit "goto") , (pprBlockId ident) <> semi ] + caseify (_ , _ ) = panic "pprSwtich: swtich with no cases!" + -- --------------------------------------------------------------------- -- Expressions. -- @@ -356,6 +339,8 @@ CmmMachOp mop args -> pprMachOpApp mop args + CmmStackSlot _ _ -> panic "pprExpr: CmmStackSlot not supported!" + pprLoad :: CmmExpr -> CmmType -> SDoc pprLoad e ty @@ -413,6 +398,7 @@ | isComparisonMachOp mop = Just mkW_ | otherwise = Nothing +pprMachOpApp' :: MachOp -> [CmmExpr] -> SDoc pprMachOpApp' mop args = case args of -- dyadic @@ -454,7 +440,7 @@ CmmHighStackMark -> panic "PprC printing high stack mark" CmmLabel clbl -> mkW_ <> pprCLabelAddr clbl CmmLabelOff clbl i -> mkW_ <> pprCLabelAddr clbl <> char '+' <> int i - CmmLabelDiffOff clbl1 clbl2 i + CmmLabelDiffOff clbl1 _ i -- WARNING: -- * the lit must occur in the info table clbl2 -- * clbl1 must be an SRT, a slow entry point or a large bitmap @@ -463,7 +449,8 @@ -- from an info table to an offset. -> mkW_ <> pprCLabelAddr clbl1 <> char '+' <> int i -pprCLabelAddr lbl = char '&' <> pprCLabel lbl + where + pprCLabelAddr lbl = char '&' <> pprCLabel lbl pprLit1 :: CmmLit -> SDoc pprLit1 lit@(CmmLabelOff _ _) = parens (pprLit lit) @@ -483,7 +470,9 @@ | wORD_SIZE == 4 = pprLit1 (floatToWord f) : pprStatics rest | otherwise - = pprPanic "pprStatics: float" (vcat (map (\(CmmStaticLit l) -> ppr (cmmLitType l)) rest)) + = pprPanic "pprStatics: float" (vcat (map ppr' rest)) + where ppr' (CmmStaticLit l) = ppr (cmmLitType l) + ppr' _other = ptext (sLit "bad static!") pprStatics (CmmStaticLit (CmmFloat f W64) : rest) = map pprLit1 (doubleToWords f) ++ pprStatics rest pprStatics (CmmStaticLit (CmmInt i W64) : rest) @@ -497,20 +486,18 @@ #endif where r = i .&. 0xffffffff q = i `shiftR` 32 -pprStatics (CmmStaticLit (CmmInt i w) : rest) +pprStatics (CmmStaticLit (CmmInt _ w) : _) | w /= wordWidth = panic "pprStatics: cannot emit a non-word-sized static literal" pprStatics (CmmStaticLit lit : rest) = pprLit1 lit : pprStatics rest -pprStatics (other : rest) +pprStatics (other : _) = pprPanic "pprWord" (pprStatic other) pprStatic :: CmmStatic -> SDoc pprStatic s = case s of CmmStaticLit lit -> nest 4 (pprLit lit) - CmmAlign i -> nest 4 (ptext (sLit "/* align */") <+> int i) - CmmDataLabel clbl -> pprCLabel clbl <> colon CmmUninitialised i -> nest 4 (mkC_ <> brackets (int i)) -- these should be inlined, like the old .hc @@ -661,7 +648,12 @@ MO_F32_Log -> ptext (sLit "logf") MO_F32_Exp -> ptext (sLit "expf") MO_F32_Sqrt -> ptext (sLit "sqrtf") - MO_WriteBarrier -> ptext (sLit "write_barrier") + MO_WriteBarrier -> ptext (sLit "write_barrier") + MO_Memcpy -> ptext (sLit "memcpy") + MO_Memset -> ptext (sLit "memset") + MO_Memmove -> ptext (sLit "memmove") + a -> panic $ "pprCallishMachOp_for_C: Unknown callish op! (" + ++ show a ++ ")" -- --------------------------------------------------------------------- -- Useful #defines @@ -723,6 +715,7 @@ -- --------------------------------------------------------------------- -- Registers +pprCastReg :: CmmReg -> SDoc pprCastReg reg | isStrangeTypeReg reg = mkW_ <> pprReg reg | otherwise = pprReg reg @@ -739,18 +732,18 @@ -- THE GARBAGE WITH THE VNonGcPtr HELPS MATCH THE OLD CODE GENERATOR'S OUTPUT; -- I'M NOT SURE IF IT SHOULD REALLY STAY THAT WAY. isPtrReg :: CmmReg -> Bool -isPtrReg (CmmLocal _) = False -isPtrReg (CmmGlobal (VanillaReg n VGcPtr)) = True -- if we print via pprAsPtrReg -isPtrReg (CmmGlobal (VanillaReg n VNonGcPtr)) = False --if we print via pprAsPtrReg -isPtrReg (CmmGlobal reg) = isFixedPtrGlobalReg reg +isPtrReg (CmmLocal _) = False +isPtrReg (CmmGlobal (VanillaReg _ VGcPtr)) = True -- if we print via pprAsPtrReg +isPtrReg (CmmGlobal (VanillaReg _ VNonGcPtr)) = False -- if we print via pprAsPtrReg +isPtrReg (CmmGlobal reg) = isFixedPtrGlobalReg reg -- True if this global reg has type StgPtr isFixedPtrGlobalReg :: GlobalReg -> Bool -isFixedPtrGlobalReg Sp = True -isFixedPtrGlobalReg Hp = True -isFixedPtrGlobalReg HpLim = True -isFixedPtrGlobalReg SpLim = True -isFixedPtrGlobalReg _ = False +isFixedPtrGlobalReg Sp = True +isFixedPtrGlobalReg Hp = True +isFixedPtrGlobalReg HpLim = True +isFixedPtrGlobalReg SpLim = True +isFixedPtrGlobalReg _ = False -- True if in C this register doesn't have the type given by -- (machRepCType (cmmRegType reg)), so it has to be cast. @@ -802,6 +795,7 @@ EagerBlackholeInfo -> ptext (sLit "stg_EAGER_BLACKHOLE_info") GCEnter1 -> ptext (sLit "stg_gc_enter_1") GCFun -> ptext (sLit "stg_gc_fun") + other -> panic $ "pprGlobalReg: Unsupported register: " ++ show other pprLocalReg :: LocalReg -> SDoc pprLocalReg (LocalReg uniq _) = char '_' <> ppr uniq @@ -809,26 +803,15 @@ -- ----------------------------------------------------------------------------- -- Foreign Calls -pprCall :: SDoc -> CCallConv -> HintedCmmFormals -> HintedCmmActuals -> CmmSafety +pprCall :: SDoc -> CCallConv -> [HintedCmmFormal] -> [HintedCmmActual] -> CmmSafety -> SDoc pprCall ppr_fn cconv results args _ - | not (is_cish cconv) - = panic "pprCall: unknown calling convention" + | not (is_cishCC cconv) + = panic $ "pprCall: unknown calling convention" | otherwise = -#if x86_64_TARGET_ARCH - -- HACK around gcc optimisations. - -- x86_64 needs a __DISCARD__() here, to create a barrier between - -- putting the arguments into temporaries and passing the arguments - -- to the callee, because the argument expressions may refer to - -- machine registers that are also used for passing arguments in the - -- C calling convention. - (if (not opt_Unregisterised) - then ptext (sLit "__DISCARD__();") - else empty) $$ -#endif ppr_assign results (ppr_fn <> parens (commafy (map pprArg args))) <> semi where ppr_assign [] rhs = rhs @@ -849,15 +832,13 @@ pprUnHint SignedHint rep = parens (machRepCType rep) pprUnHint _ _ = empty -pprGlobalRegName :: GlobalReg -> SDoc -pprGlobalRegName gr = case gr of - VanillaReg n _ -> char 'R' <> int n -- without the .w suffix - _ -> pprGlobalReg gr - -- Currently we only have these two calling conventions, but this might -- change in the future... -is_cish CCallConv = True -is_cish StdCallConv = True +is_cishCC :: CCallConv -> Bool +is_cishCC CCallConv = True +is_cishCC StdCallConv = True +is_cishCC CmmCallConv = False +is_cishCC PrimCallConv = False -- --------------------------------------------------------------------- -- Find and print local and external declarations for a list of @@ -879,7 +860,7 @@ = hcat [ machRepCType rep, space, pprLocalReg l, semi ] pprExternDecl :: Bool -> CLabel -> SDoc -pprExternDecl in_srt lbl +pprExternDecl _in_srt lbl -- do not print anything for "known external" things | not (needsCDecl lbl) = empty | Just sz <- foreignLabelStdcallInfo lbl = stdcall_decl sz @@ -928,7 +909,7 @@ te_Lit :: CmmLit -> TE () te_Lit (CmmLabel l) = te_lbl l te_Lit (CmmLabelOff l _) = te_lbl l -te_Lit (CmmLabelDiffOff l1 l2 _) = te_lbl l1 +te_Lit (CmmLabelDiffOff l1 _ _) = te_lbl l1 te_Lit _ = return () te_Stmt :: CmmStmt -> TE () @@ -947,6 +928,7 @@ te_Expr (CmmReg r) = te_Reg r te_Expr (CmmMachOp _ es) = mapM_ te_Expr es te_Expr (CmmRegOff r _) = te_Reg r +te_Expr (CmmStackSlot _ _) = panic "te_Expr: CmmStackSlot not supported!" te_Reg :: CmmReg -> TE () te_Reg (CmmLocal l) = te_temp l @@ -980,7 +962,7 @@ -- argument, we always cast the argument to (void *), to avoid warnings from -- the C compiler. machRepHintCType :: CmmType -> ForeignHint -> SDoc -machRepHintCType rep AddrHint = ptext (sLit "void *") +machRepHintCType _ AddrHint = ptext (sLit "void *") machRepHintCType rep SignedHint = machRep_S_CType (typeWidth rep) machRepHintCType rep _other = machRepCType rep @@ -1022,18 +1004,6 @@ pprStringInCStyle :: [Word8] -> SDoc pprStringInCStyle s = doubleQuotes (text (concatMap charToC s)) -charToC :: Word8 -> String -charToC w = - case chr (fromIntegral w) of - '\"' -> "\\\"" - '\'' -> "\\\'" - '\\' -> "\\\\" - c | c >= ' ' && c <= '~' -> [c] - | otherwise -> ['\\', - chr (ord '0' + ord c `div` 64), - chr (ord '0' + ord c `div` 8 `mod` 8), - chr (ord '0' + ord c `mod` 8)] - -- --------------------------------------------------------------------------- -- Initialising static objects with floating-point numbers. We can't -- just emit the floating point number, because C will cast it to an int @@ -1042,6 +1012,7 @@ -- This is a hack to turn the floating point numbers into ints that we -- can safely initialise to static locations. +big_doubles :: Bool big_doubles | widthInBytes W64 == 2 * wORD_SIZE = True | widthInBytes W64 == wORD_SIZE = False diff -Nru ghc-7.0.3/compiler/cmm/PprCmmDecl.hs ghc-7.2.1/compiler/cmm/PprCmmDecl.hs --- ghc-7.0.3/compiler/cmm/PprCmmDecl.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/compiler/cmm/PprCmmDecl.hs 2011-08-07 17:10:05.000000000 +0000 @@ -0,0 +1,206 @@ +---------------------------------------------------------------------------- +-- +-- Pretty-printing of common Cmm types +-- +-- (c) The University of Glasgow 2004-2006 +-- +----------------------------------------------------------------------------- + +-- +-- This is where we walk over Cmm emitting an external representation, +-- suitable for parsing, in a syntax strongly reminiscent of C--. This +-- is the "External Core" for the Cmm layer. +-- +-- As such, this should be a well-defined syntax: we want it to look nice. +-- Thus, we try wherever possible to use syntax defined in [1], +-- "The C-- Reference Manual", http://www.cminusminus.org/. We differ +-- slightly, in some cases. For one, we use I8 .. I64 for types, rather +-- than C--'s bits8 .. bits64. +-- +-- We try to ensure that all information available in the abstract +-- syntax is reproduced, or reproducible, in the concrete syntax. +-- Data that is not in printed out can be reconstructed according to +-- conventions used in the pretty printer. There are at least two such +-- cases: +-- 1) if a value has wordRep type, the type is not appended in the +-- output. +-- 2) MachOps that operate over wordRep type are printed in a +-- C-style, rather than as their internal MachRep name. +-- +-- These conventions produce much more readable Cmm output. +-- +-- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs +-- + +module PprCmmDecl + ( writeCmms, pprCmms, pprCmm, pprSection, pprStatic + ) +where + +import CmmDecl +import CLabel +import PprCmmExpr + + +import Outputable +import Platform +import FastString + +import Data.List +import System.IO + +-- Temp Jan08 +import SMRep +import ClosureInfo +#include "../includes/rts/storage/FunTypes.h" + + +pprCmms :: (Outputable info, PlatformOutputable g) + => Platform -> [GenCmm CmmStatics info g] -> SDoc +pprCmms platform cmms = pprCode CStyle (vcat (intersperse separator $ map (pprPlatform platform) cmms)) + where + separator = space $$ ptext (sLit "-------------------") $$ space + +writeCmms :: (Outputable info, PlatformOutputable g) + => Platform -> Handle -> [GenCmm CmmStatics info g] -> IO () +writeCmms platform handle cmms = printForC handle (pprCmms platform cmms) + +----------------------------------------------------------------------------- + +instance (Outputable d, Outputable info, PlatformOutputable g) + => PlatformOutputable (GenCmm d info g) where + pprPlatform platform c = pprCmm platform c + +instance (Outputable d, Outputable info, PlatformOutputable i) + => PlatformOutputable (GenCmmTop d info i) where + pprPlatform platform t = pprTop platform t + +instance Outputable CmmStatics where + ppr e = pprStatics e + +instance Outputable CmmStatic where + ppr e = pprStatic e + +instance Outputable CmmInfoTable where + ppr e = pprInfoTable e + + +----------------------------------------------------------------------------- + +pprCmm :: (Outputable d, Outputable info, PlatformOutputable g) + => Platform -> GenCmm d info g -> SDoc +pprCmm platform (Cmm tops) + = vcat $ intersperse blankLine $ map (pprTop platform) tops + +-- -------------------------------------------------------------------------- +-- Top level `procedure' blocks. +-- +pprTop :: (Outputable d, Outputable info, PlatformOutputable i) + => Platform -> GenCmmTop d info i -> SDoc + +pprTop platform (CmmProc info lbl graph) + + = vcat [ pprCLabel lbl <> lparen <> rparen + , nest 8 $ lbrace <+> ppr info $$ rbrace + , nest 4 $ pprPlatform platform graph + , rbrace ] + +-- -------------------------------------------------------------------------- +-- We follow [1], 4.5 +-- +-- section "data" { ... } +-- +pprTop _ (CmmData section ds) = + (hang (pprSection section <+> lbrace) 4 (ppr ds)) + $$ rbrace + +-- -------------------------------------------------------------------------- +-- Info tables. + +pprInfoTable :: CmmInfoTable -> SDoc +pprInfoTable CmmNonInfoTable = empty +pprInfoTable (CmmInfoTable is_local stat_clos (ProfilingInfo closure_type closure_desc) tag info) = + vcat [ptext (sLit "is local: ") <> ppr is_local <+> + ptext (sLit "has static closure: ") <> ppr stat_clos <+> + ptext (sLit "type: ") <> pprLit closure_type, + ptext (sLit "desc: ") <> pprLit closure_desc, + ptext (sLit "tag: ") <> integer (toInteger tag), + pprTypeInfo info] + +pprTypeInfo :: ClosureTypeInfo -> SDoc +pprTypeInfo (ConstrInfo layout constr descr) = + vcat [ptext (sLit "ptrs: ") <> integer (toInteger (fst layout)), + ptext (sLit "nptrs: ") <> integer (toInteger (snd layout)), + ptext (sLit "constructor: ") <> integer (toInteger constr), + pprLit descr] +pprTypeInfo (FunInfo layout srt arity _args slow_entry) = + vcat [ptext (sLit "ptrs: ") <> integer (toInteger (fst layout)), + ptext (sLit "nptrs: ") <> integer (toInteger (snd layout)), + ptext (sLit "srt: ") <> ppr srt, +-- Temp Jan08 + ptext (sLit ("fun_type: ")) <> integer (toInteger (argDescrType _args)), + + ptext (sLit "arity: ") <> integer (toInteger arity), + --ptext (sLit "args: ") <> ppr args, -- TODO: needs to be printed + ptext (sLit "slow: ") <> pprLit slow_entry + ] +pprTypeInfo (ThunkInfo layout srt) = + vcat [ptext (sLit "ptrs: ") <> integer (toInteger (fst layout)), + ptext (sLit "nptrs: ") <> integer (toInteger (snd layout)), + ptext (sLit "srt: ") <> ppr srt] +pprTypeInfo (ThunkSelectorInfo offset srt) = + vcat [ptext (sLit "ptrs: ") <> integer (toInteger offset), + ptext (sLit "srt: ") <> ppr srt] +pprTypeInfo (ContInfo stack srt) = + vcat [ptext (sLit "stack: ") <> ppr stack, + ptext (sLit "srt: ") <> ppr srt] + +-- Temp Jan08 +argDescrType :: ArgDescr -> StgHalfWord +-- The "argument type" RTS field type +argDescrType (ArgSpec n) = n +argDescrType (ArgGen liveness) + | isBigLiveness liveness = ARG_GEN_BIG + | otherwise = ARG_GEN + +-- Temp Jan08 +isBigLiveness :: Liveness -> Bool +isBigLiveness (BigLiveness _) = True +isBigLiveness (SmallLiveness _) = False + +instance Outputable ForeignHint where + ppr NoHint = empty + ppr SignedHint = quotes(text "signed") +-- ppr AddrHint = quotes(text "address") +-- Temp Jan08 + ppr AddrHint = (text "PtrHint") + +-- -------------------------------------------------------------------------- +-- Static data. +-- Strings are printed as C strings, and we print them as I8[], +-- following C-- +-- +pprStatics :: CmmStatics -> SDoc +pprStatics (Statics lbl ds) = vcat ((pprCLabel lbl <> colon) : map ppr ds) + +pprStatic :: CmmStatic -> SDoc +pprStatic s = case s of + CmmStaticLit lit -> nest 4 $ ptext (sLit "const") <+> pprLit lit <> semi + CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i) + CmmString s' -> nest 4 $ text "I8[]" <+> text (show s') + +-- -------------------------------------------------------------------------- +-- data sections +-- +pprSection :: Section -> SDoc +pprSection s = case s of + Text -> section <+> doubleQuotes (ptext (sLit "text")) + Data -> section <+> doubleQuotes (ptext (sLit "data")) + ReadOnlyData -> section <+> doubleQuotes (ptext (sLit "readonly")) + ReadOnlyData16 -> section <+> doubleQuotes (ptext (sLit "readonly16")) + RelocatableReadOnlyData + -> section <+> doubleQuotes (ptext (sLit "relreadonly")) + UninitialisedData -> section <+> doubleQuotes (ptext (sLit "uninitialised")) + OtherSection s' -> section <+> doubleQuotes (text s') + where + section = ptext (sLit "section") diff -Nru ghc-7.0.3/compiler/cmm/PprCmmExpr.hs ghc-7.2.1/compiler/cmm/PprCmmExpr.hs --- ghc-7.0.3/compiler/cmm/PprCmmExpr.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/compiler/cmm/PprCmmExpr.hs 2011-08-07 17:10:05.000000000 +0000 @@ -0,0 +1,275 @@ +---------------------------------------------------------------------------- +-- +-- Pretty-printing of common Cmm types +-- +-- (c) The University of Glasgow 2004-2006 +-- +----------------------------------------------------------------------------- + +-- +-- This is where we walk over Cmm emitting an external representation, +-- suitable for parsing, in a syntax strongly reminiscent of C--. This +-- is the "External Core" for the Cmm layer. +-- +-- As such, this should be a well-defined syntax: we want it to look nice. +-- Thus, we try wherever possible to use syntax defined in [1], +-- "The C-- Reference Manual", http://www.cminusminus.org/. We differ +-- slightly, in some cases. For one, we use I8 .. I64 for types, rather +-- than C--'s bits8 .. bits64. +-- +-- We try to ensure that all information available in the abstract +-- syntax is reproduced, or reproducible, in the concrete syntax. +-- Data that is not in printed out can be reconstructed according to +-- conventions used in the pretty printer. There are at least two such +-- cases: +-- 1) if a value has wordRep type, the type is not appended in the +-- output. +-- 2) MachOps that operate over wordRep type are printed in a +-- C-style, rather than as their internal MachRep name. +-- +-- These conventions produce much more readable Cmm output. +-- +-- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs +-- + +module PprCmmExpr + ( pprExpr, pprLit + , pprExpr9 {-only to import in OldPprCmm. When it dies, remove the export -} + ) +where + +import CmmExpr +import CLabel + +import Outputable +import FastString + +import Data.Maybe + +----------------------------------------------------------------------------- + +instance Outputable CmmExpr where + ppr e = pprExpr e + +instance Outputable CmmReg where + ppr e = pprReg e + +instance Outputable CmmLit where + ppr l = pprLit l + +instance Outputable LocalReg where + ppr e = pprLocalReg e + +instance Outputable Area where + ppr e = pprArea e + +instance Outputable GlobalReg where + ppr e = pprGlobalReg e + +-- -------------------------------------------------------------------------- +-- Expressions +-- + +pprExpr :: CmmExpr -> SDoc +pprExpr e + = case e of + CmmRegOff reg i -> + pprExpr (CmmMachOp (MO_Add rep) + [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)]) + where rep = typeWidth (cmmRegType reg) + CmmLit lit -> pprLit lit + _other -> pprExpr1 e + +-- Here's the precedence table from CmmParse.y: +-- %nonassoc '>=' '>' '<=' '<' '!=' '==' +-- %left '|' +-- %left '^' +-- %left '&' +-- %left '>>' '<<' +-- %left '-' '+' +-- %left '/' '*' '%' +-- %right '~' + +-- We just cope with the common operators for now, the rest will get +-- a default conservative behaviour. + +-- %nonassoc '>=' '>' '<=' '<' '!=' '==' +pprExpr1, pprExpr7, pprExpr8 :: CmmExpr -> SDoc +pprExpr1 (CmmMachOp op [x,y]) | Just doc <- infixMachOp1 op + = pprExpr7 x <+> doc <+> pprExpr7 y +pprExpr1 e = pprExpr7 e + +infixMachOp1, infixMachOp7, infixMachOp8 :: MachOp -> Maybe SDoc + +infixMachOp1 (MO_Eq _) = Just (ptext (sLit "==")) +infixMachOp1 (MO_Ne _) = Just (ptext (sLit "!=")) +infixMachOp1 (MO_Shl _) = Just (ptext (sLit "<<")) +infixMachOp1 (MO_U_Shr _) = Just (ptext (sLit ">>")) +infixMachOp1 (MO_U_Ge _) = Just (ptext (sLit ">=")) +infixMachOp1 (MO_U_Le _) = Just (ptext (sLit "<=")) +infixMachOp1 (MO_U_Gt _) = Just (char '>') +infixMachOp1 (MO_U_Lt _) = Just (char '<') +infixMachOp1 _ = Nothing + +-- %left '-' '+' +pprExpr7 (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0 + = pprExpr7 (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)]) +pprExpr7 (CmmMachOp op [x,y]) | Just doc <- infixMachOp7 op + = pprExpr7 x <+> doc <+> pprExpr8 y +pprExpr7 e = pprExpr8 e + +infixMachOp7 (MO_Add _) = Just (char '+') +infixMachOp7 (MO_Sub _) = Just (char '-') +infixMachOp7 _ = Nothing + +-- %left '/' '*' '%' +pprExpr8 (CmmMachOp op [x,y]) | Just doc <- infixMachOp8 op + = pprExpr8 x <+> doc <+> pprExpr9 y +pprExpr8 e = pprExpr9 e + +infixMachOp8 (MO_U_Quot _) = Just (char '/') +infixMachOp8 (MO_Mul _) = Just (char '*') +infixMachOp8 (MO_U_Rem _) = Just (char '%') +infixMachOp8 _ = Nothing + +pprExpr9 :: CmmExpr -> SDoc +pprExpr9 e = + case e of + CmmLit lit -> pprLit1 lit + CmmLoad expr rep -> ppr rep <> brackets( ppr expr ) + CmmReg reg -> ppr reg + CmmRegOff reg off -> parens (ppr reg <+> char '+' <+> int off) + CmmStackSlot a off -> parens (ppr a <+> char '+' <+> int off) + CmmMachOp mop args -> genMachOp mop args + +genMachOp :: MachOp -> [CmmExpr] -> SDoc +genMachOp mop args + | Just doc <- infixMachOp mop = case args of + -- dyadic + [x,y] -> pprExpr9 x <+> doc <+> pprExpr9 y + + -- unary + [x] -> doc <> pprExpr9 x + + _ -> pprTrace "PprCmm.genMachOp: machop with strange number of args" + (pprMachOp mop <+> + parens (hcat $ punctuate comma (map pprExpr args))) + empty + + | isJust (infixMachOp1 mop) + || isJust (infixMachOp7 mop) + || isJust (infixMachOp8 mop) = parens (pprExpr (CmmMachOp mop args)) + + | otherwise = char '%' <> ppr_op <> parens (commafy (map pprExpr args)) + where ppr_op = text (map (\c -> if c == ' ' then '_' else c) + (show mop)) + -- replace spaces in (show mop) with underscores, + +-- +-- Unsigned ops on the word size of the machine get nice symbols. +-- All else get dumped in their ugly format. +-- +infixMachOp :: MachOp -> Maybe SDoc +infixMachOp mop + = case mop of + MO_And _ -> Just $ char '&' + MO_Or _ -> Just $ char '|' + MO_Xor _ -> Just $ char '^' + MO_Not _ -> Just $ char '~' + MO_S_Neg _ -> Just $ char '-' -- there is no unsigned neg :) + _ -> Nothing + +-- -------------------------------------------------------------------------- +-- Literals. +-- To minimise line noise we adopt the convention that if the literal +-- has the natural machine word size, we do not append the type +-- +pprLit :: CmmLit -> SDoc +pprLit lit = case lit of + CmmInt i rep -> + hcat [ (if i < 0 then parens else id)(integer i) + , ppUnless (rep == wordWidth) $ + space <> dcolon <+> ppr rep ] + + CmmFloat f rep -> hsep [ rational f, dcolon, ppr rep ] + CmmLabel clbl -> pprCLabel clbl + CmmLabelOff clbl i -> pprCLabel clbl <> ppr_offset i + CmmLabelDiffOff clbl1 clbl2 i -> pprCLabel clbl1 <> char '-' + <> pprCLabel clbl2 <> ppr_offset i + CmmBlock id -> ppr id + CmmHighStackMark -> text "" + +pprLit1 :: CmmLit -> SDoc +pprLit1 lit@(CmmLabelOff {}) = parens (pprLit lit) +pprLit1 lit = pprLit lit + +ppr_offset :: Int -> SDoc +ppr_offset i + | i==0 = empty + | i>=0 = char '+' <> int i + | otherwise = char '-' <> int (-i) + +-- -------------------------------------------------------------------------- +-- Registers, whether local (temps) or global +-- +pprReg :: CmmReg -> SDoc +pprReg r + = case r of + CmmLocal local -> pprLocalReg local + CmmGlobal global -> pprGlobalReg global + +-- +-- We only print the type of the local reg if it isn't wordRep +-- +pprLocalReg :: LocalReg -> SDoc +pprLocalReg (LocalReg uniq rep) +-- = ppr rep <> char '_' <> ppr uniq +-- Temp Jan08 + = char '_' <> ppr uniq <> + (if isWord32 rep -- && not (isGcPtrType rep) -- Temp Jan08 -- sigh + then dcolon <> ptr <> ppr rep + else dcolon <> ptr <> ppr rep) + where + ptr = empty + --if isGcPtrType rep + -- then doubleQuotes (text "ptr") + -- else empty + +-- Stack areas +pprArea :: Area -> SDoc +pprArea (RegSlot r) = hcat [ text "slot<", ppr r, text ">" ] +pprArea (CallArea id) = pprAreaId id + +pprAreaId :: AreaId -> SDoc +pprAreaId Old = text "old" +pprAreaId (Young id) = hcat [ text "young<", ppr id, text ">" ] + +-- needs to be kept in syn with CmmExpr.hs.GlobalReg +-- +pprGlobalReg :: GlobalReg -> SDoc +pprGlobalReg gr + = case gr of + VanillaReg n _ -> char 'R' <> int n +-- Temp Jan08 +-- VanillaReg n VNonGcPtr -> char 'R' <> int n +-- VanillaReg n VGcPtr -> char 'P' <> int n + FloatReg n -> char 'F' <> int n + DoubleReg n -> char 'D' <> int n + LongReg n -> char 'L' <> int n + Sp -> ptext (sLit "Sp") + SpLim -> ptext (sLit "SpLim") + Hp -> ptext (sLit "Hp") + HpLim -> ptext (sLit "HpLim") + CurrentTSO -> ptext (sLit "CurrentTSO") + CurrentNursery -> ptext (sLit "CurrentNursery") + HpAlloc -> ptext (sLit "HpAlloc") + EagerBlackholeInfo -> ptext (sLit "stg_EAGER_BLACKHOLE_info") + GCEnter1 -> ptext (sLit "stg_gc_enter_1") + GCFun -> ptext (sLit "stg_gc_fun") + BaseReg -> ptext (sLit "BaseReg") + PicBaseReg -> ptext (sLit "PicBaseReg") + +----------------------------------------------------------------------------- + +commafy :: [SDoc] -> SDoc +commafy xs = fsep $ punctuate comma xs diff -Nru ghc-7.0.3/compiler/cmm/PprCmm.hs ghc-7.2.1/compiler/cmm/PprCmm.hs --- ghc-7.0.3/compiler/cmm/PprCmm.hs 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/cmm/PprCmm.hs 2011-08-07 17:10:05.000000000 +0000 @@ -5,9 +5,8 @@ -- (c) The University of Glasgow 2004-2006 -- ----------------------------------------------------------------------------- - -- --- This is where we walk over Cmm emitting an external representation, +-- This is where we walk over CmmNode emitting an external representation, -- suitable for parsing, in a syntax strongly reminiscent of C--. This -- is the "External Core" for the Cmm layer. -- @@ -30,600 +29,237 @@ -- These conventions produce much more readable Cmm output. -- -- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs --- +{-# LANGUAGE GADTs, TypeFamilies, FlexibleContexts #-} module PprCmm - ( writeCmms, pprCmms, pprCmm, pprStmt, pprExpr, - pprSection, pprStatic, pprLit - ) + ( module PprCmmDecl + , module PprCmmExpr + ) where -import BlockId -import Cmm -import CmmUtils +import BlockId () import CLabel -import BasicTypes - - -import ForeignCall -import Outputable +import Cmm +import CmmExpr +import CmmUtils (isTrivialCmmExpr) import FastString +import Outputable +import PprCmmDecl +import PprCmmExpr +import Util +import BasicTypes +import Platform +import Compiler.Hoopl import Data.List -import System.IO -import Data.Maybe - --- Temp Jan08 -import SMRep -import ClosureInfo -#include "../includes/rts/storage/FunTypes.h" - - -pprCmms :: (Outputable info, Outputable g) => [GenCmm CmmStatic info g] -> SDoc -pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms)) - where - separator = space $$ ptext (sLit "-------------------") $$ space - -writeCmms :: Handle -> [Cmm] -> IO () -writeCmms handle cmms = printForC handle (pprCmms cmms) - ------------------------------------------------------------------------------ - -instance (Outputable d, Outputable info, Outputable g) - => Outputable (GenCmm d info g) where - ppr c = pprCmm c - -instance (Outputable d, Outputable info, Outputable i) - => Outputable (GenCmmTop d info i) where - ppr t = pprTop t - -instance (Outputable instr) => Outputable (ListGraph instr) where - ppr (ListGraph blocks) = vcat (map ppr blocks) - -instance (Outputable instr) => Outputable (GenBasicBlock instr) where - ppr b = pprBBlock b - -instance Outputable CmmStmt where - ppr s = pprStmt s - -instance Outputable CmmExpr where - ppr e = pprExpr e - -instance Outputable CmmReg where - ppr e = pprReg e - -instance Outputable CmmLit where - ppr l = pprLit l - -instance Outputable LocalReg where - ppr e = pprLocalReg e - -instance Outputable Area where - ppr e = pprArea e - -instance Outputable GlobalReg where - ppr e = pprGlobalReg e - -instance Outputable CmmStatic where - ppr e = pprStatic e - -instance Outputable CmmInfo where - ppr e = pprInfo e - - - ------------------------------------------------------------------------------ - -pprCmm :: (Outputable d, Outputable info, Outputable g) => GenCmm d info g -> SDoc -pprCmm (Cmm tops) = vcat $ intersperse blankLine $ map pprTop tops - --- -------------------------------------------------------------------------- --- Top level `procedure' blocks. --- -pprTop :: (Outputable d, Outputable info, Outputable i) - => GenCmmTop d info i -> SDoc - -pprTop (CmmProc info lbl params graph ) - - = vcat [ pprCLabel lbl <> parens (commafy $ map ppr params) - , nest 8 $ lbrace <+> ppr info $$ rbrace - , nest 4 $ ppr graph - , rbrace ] - --- -------------------------------------------------------------------------- --- We follow [1], 4.5 --- --- section "data" { ... } --- -pprTop (CmmData section ds) = - (hang (pprSection section <+> lbrace) 4 (vcat (map ppr ds))) - $$ rbrace - --- -------------------------------------------------------------------------- -instance Outputable CmmSafety where - ppr CmmUnsafe = ptext (sLit "_unsafe_call_") - ppr (CmmSafe srt) = ppr srt - --- -------------------------------------------------------------------------- --- Info tables. The current pretty printer needs refinement --- but will work for now. --- --- For ideas on how to refine it, they used to be printed in the --- style of C--'s 'stackdata' declaration, just inside the proc body, --- and were labelled with the procedure name ++ "_info". -pprInfo :: CmmInfo -> SDoc -pprInfo (CmmInfo _gc_target update_frame CmmNonInfoTable) = - vcat [{-ptext (sLit "gc_target: ") <> - maybe (ptext (sLit "")) ppr gc_target,-} - ptext (sLit "update_frame: ") <> - maybe (ptext (sLit "")) pprUpdateFrame update_frame] -pprInfo (CmmInfo _gc_target update_frame - (CmmInfoTable stat_clos (ProfilingInfo closure_type closure_desc) tag info)) = - vcat [{-ptext (sLit "gc_target: ") <> - maybe (ptext (sLit "")) ppr gc_target,-} - ptext (sLit "has static closure: ") <> ppr stat_clos <+> - ptext (sLit "update_frame: ") <> - maybe (ptext (sLit "")) pprUpdateFrame update_frame, - ptext (sLit "type: ") <> pprLit closure_type, - ptext (sLit "desc: ") <> pprLit closure_desc, - ptext (sLit "tag: ") <> integer (toInteger tag), - pprTypeInfo info] - -pprTypeInfo :: ClosureTypeInfo -> SDoc -pprTypeInfo (ConstrInfo layout constr descr) = - vcat [ptext (sLit "ptrs: ") <> integer (toInteger (fst layout)), - ptext (sLit "nptrs: ") <> integer (toInteger (snd layout)), - ptext (sLit "constructor: ") <> integer (toInteger constr), - pprLit descr] -pprTypeInfo (FunInfo layout srt arity _args slow_entry) = - vcat [ptext (sLit "ptrs: ") <> integer (toInteger (fst layout)), - ptext (sLit "nptrs: ") <> integer (toInteger (snd layout)), - ptext (sLit "srt: ") <> ppr srt, --- Temp Jan08 - ptext (sLit ("fun_type: ")) <> integer (toInteger (argDescrType _args)), - - ptext (sLit "arity: ") <> integer (toInteger arity), - --ptext (sLit "args: ") <> ppr args, -- TODO: needs to be printed - ptext (sLit "slow: ") <> pprLit slow_entry - ] -pprTypeInfo (ThunkInfo layout srt) = - vcat [ptext (sLit "ptrs: ") <> integer (toInteger (fst layout)), - ptext (sLit "nptrs: ") <> integer (toInteger (snd layout)), - ptext (sLit "srt: ") <> ppr srt] -pprTypeInfo (ThunkSelectorInfo offset srt) = - vcat [ptext (sLit "ptrs: ") <> integer (toInteger offset), - ptext (sLit "srt: ") <> ppr srt] -pprTypeInfo (ContInfo stack srt) = - vcat [ptext (sLit "stack: ") <> ppr stack, - ptext (sLit "srt: ") <> ppr srt] - --- Temp Jan08 -argDescrType :: ArgDescr -> StgHalfWord --- The "argument type" RTS field type -argDescrType (ArgSpec n) = n -argDescrType (ArgGen liveness) - | isBigLiveness liveness = ARG_GEN_BIG - | otherwise = ARG_GEN - --- Temp Jan08 -isBigLiveness :: Liveness -> Bool -isBigLiveness (BigLiveness _) = True -isBigLiveness (SmallLiveness _) = False - - -pprUpdateFrame :: UpdateFrame -> SDoc -pprUpdateFrame (UpdateFrame expr args) = - hcat [ ptext (sLit "jump") - , space - , if isTrivialCmmExpr expr - then pprExpr expr - else case expr of - CmmLoad (CmmReg _) _ -> pprExpr expr - _ -> parens (pprExpr expr) - , space - , parens ( commafy $ map ppr args ) ] - - --- -------------------------------------------------------------------------- --- Basic blocks look like assembly blocks. --- lbl: stmt ; stmt ; .. -pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc -pprBBlock (BasicBlock ident stmts) = - hang (ppr ident <> colon) 4 (vcat (map ppr stmts)) +import Prelude hiding (succ) --- -------------------------------------------------------------------------- --- Statements. C-- usually, exceptions to this should be obvious. --- -pprStmt :: CmmStmt -> SDoc -pprStmt stmt = case stmt of - - -- ; - CmmNop -> semi - - -- // text - CmmComment s -> text "//" <+> ftext s - - -- reg = expr; - CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi - - -- rep[lv] = expr; - CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi - where - rep = ppr ( cmmExprType expr ) - - -- call "ccall" foo(x, y)[r1, r2]; - -- ToDo ppr volatile - CmmCall (CmmCallee fn cconv) results args safety ret -> - sep [ pp_lhs <+> pp_conv - , nest 2 (pprExpr9 fn <> - parens (commafy (map ppr_ar args))) - <> brackets (ppr safety) - , case ret of CmmMayReturn -> empty - CmmNeverReturns -> ptext $ sLit (" never returns") - ] <> semi - where - pp_lhs | null results = empty - | otherwise = commafy (map ppr_ar results) <+> equals - -- Don't print the hints on a native C-- call - - ppr_ar :: Outputable a => CmmHinted a -> SDoc - ppr_ar (CmmHinted ar k) = case cconv of - CmmCallConv -> ppr ar - _ -> ppr (ar,k) - pp_conv = case cconv of - CmmCallConv -> empty - _ -> ptext (sLit("foreign")) <+> doubleQuotes (ppr cconv) - - -- Call a CallishMachOp, like sin or cos that might be implemented as a library call. - CmmCall (CmmPrim op) results args safety ret -> - pprStmt (CmmCall (CmmCallee (CmmLit lbl) CCallConv) - results args safety ret) - where - -- HACK: A CallishMachOp doesn't really correspond to a ForeignLabel, but we - -- use one to get the label printed. - lbl = CmmLabel (mkForeignLabel - (mkFastString (show op)) - Nothing ForeignLabelInThisPackage IsFunction) - - CmmBranch ident -> genBranch ident - CmmCondBranch expr ident -> genCondBranch expr ident - CmmJump expr params -> genJump expr params - CmmReturn params -> genReturn params - CmmSwitch arg ids -> genSwitch arg ids - -instance Outputable ForeignHint where - ppr NoHint = empty - ppr SignedHint = quotes(text "signed") --- ppr AddrHint = quotes(text "address") --- Temp Jan08 - ppr AddrHint = (text "PtrHint") - --- Just look like a tuple, since it was a tuple before --- ... is that a good idea? --Isaac Dupree -instance (Outputable a) => Outputable (CmmHinted a) where - ppr (CmmHinted a k) = ppr (a, k) - --- -------------------------------------------------------------------------- --- goto local label. [1], section 6.6 --- --- goto lbl; --- -genBranch :: BlockId -> SDoc -genBranch ident = - ptext (sLit "goto") <+> ppr ident <> semi - --- -------------------------------------------------------------------------- --- Conditional. [1], section 6.4 --- --- if (expr) { goto lbl; } --- -genCondBranch :: CmmExpr -> BlockId -> SDoc -genCondBranch expr ident = - hsep [ ptext (sLit "if") - , parens(ppr expr) - , ptext (sLit "goto") - , ppr ident <> semi ] - --- -------------------------------------------------------------------------- --- A tail call. [1], Section 6.9 --- --- jump foo(a, b, c); --- -genJump :: CmmExpr -> [CmmHinted CmmExpr] -> SDoc -genJump expr args = - hcat [ ptext (sLit "jump") - , space - , if isTrivialCmmExpr expr - then pprExpr expr - else case expr of - CmmLoad (CmmReg _) _ -> pprExpr expr - _ -> parens (pprExpr expr) - , space - , parens ( commafy $ map ppr args ) - , semi ] - - --- -------------------------------------------------------------------------- --- Return from a function. [1], Section 6.8.2 of version 1.128 --- --- return (a, b, c); --- -genReturn :: [CmmHinted CmmExpr] -> SDoc -genReturn args = - hcat [ ptext (sLit "return") - , space - , parens ( commafy $ map ppr args ) - , semi ] - --- -------------------------------------------------------------------------- --- Tabled jump to local label --- --- The syntax is from [1], section 6.5 --- --- switch [0 .. n] (expr) { case ... ; } --- -genSwitch :: CmmExpr -> [Maybe BlockId] -> SDoc -genSwitch expr maybe_ids - - = let pairs = groupBy snds (zip [0 .. ] maybe_ids ) - - in hang (hcat [ ptext (sLit "switch [0 .. ") - , int (length maybe_ids - 1) - , ptext (sLit "] ") - , if isTrivialCmmExpr expr - then pprExpr expr - else parens (pprExpr expr) - , ptext (sLit " {") - ]) - 4 (vcat ( map caseify pairs )) $$ rbrace - - where - snds a b = (snd a) == (snd b) - - caseify :: [(Int,Maybe BlockId)] -> SDoc - caseify ixs@((_,Nothing):_) - = ptext (sLit "/* impossible: ") <> hcat (intersperse comma (map (int.fst) ixs)) - <> ptext (sLit " */") - caseify as - = let (is,ids) = unzip as - in hsep [ ptext (sLit "case") - , hcat (punctuate comma (map int is)) - , ptext (sLit ": goto") - , ppr (head [ id | Just id <- ids]) <> semi ] - --- -------------------------------------------------------------------------- --- Expressions --- - -pprExpr :: CmmExpr -> SDoc -pprExpr e - = case e of - CmmRegOff reg i -> - pprExpr (CmmMachOp (MO_Add rep) - [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)]) - where rep = typeWidth (cmmRegType reg) - CmmLit lit -> pprLit lit - _other -> pprExpr1 e - --- Here's the precedence table from CmmParse.y: --- %nonassoc '>=' '>' '<=' '<' '!=' '==' --- %left '|' --- %left '^' --- %left '&' --- %left '>>' '<<' --- %left '-' '+' --- %left '/' '*' '%' --- %right '~' - --- We just cope with the common operators for now, the rest will get --- a default conservative behaviour. - --- %nonassoc '>=' '>' '<=' '<' '!=' '==' -pprExpr1, pprExpr7, pprExpr8 :: CmmExpr -> SDoc -pprExpr1 (CmmMachOp op [x,y]) | Just doc <- infixMachOp1 op - = pprExpr7 x <+> doc <+> pprExpr7 y -pprExpr1 e = pprExpr7 e - -infixMachOp1, infixMachOp7, infixMachOp8 :: MachOp -> Maybe SDoc - -infixMachOp1 (MO_Eq _) = Just (ptext (sLit "==")) -infixMachOp1 (MO_Ne _) = Just (ptext (sLit "!=")) -infixMachOp1 (MO_Shl _) = Just (ptext (sLit "<<")) -infixMachOp1 (MO_U_Shr _) = Just (ptext (sLit ">>")) -infixMachOp1 (MO_U_Ge _) = Just (ptext (sLit ">=")) -infixMachOp1 (MO_U_Le _) = Just (ptext (sLit "<=")) -infixMachOp1 (MO_U_Gt _) = Just (char '>') -infixMachOp1 (MO_U_Lt _) = Just (char '<') -infixMachOp1 _ = Nothing - --- %left '-' '+' -pprExpr7 (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0 - = pprExpr7 (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)]) -pprExpr7 (CmmMachOp op [x,y]) | Just doc <- infixMachOp7 op - = pprExpr7 x <+> doc <+> pprExpr8 y -pprExpr7 e = pprExpr8 e - -infixMachOp7 (MO_Add _) = Just (char '+') -infixMachOp7 (MO_Sub _) = Just (char '-') -infixMachOp7 _ = Nothing - --- %left '/' '*' '%' -pprExpr8 (CmmMachOp op [x,y]) | Just doc <- infixMachOp8 op - = pprExpr8 x <+> doc <+> pprExpr9 y -pprExpr8 e = pprExpr9 e - -infixMachOp8 (MO_U_Quot _) = Just (char '/') -infixMachOp8 (MO_Mul _) = Just (char '*') -infixMachOp8 (MO_U_Rem _) = Just (char '%') -infixMachOp8 _ = Nothing - -pprExpr9 :: CmmExpr -> SDoc -pprExpr9 e = - case e of - CmmLit lit -> pprLit1 lit - CmmLoad expr rep -> ppr rep <> brackets( ppr expr ) - CmmReg reg -> ppr reg - CmmRegOff reg off -> parens (ppr reg <+> char '+' <+> int off) - CmmStackSlot a off -> parens (ppr a <+> char '+' <+> int off) - CmmMachOp mop args -> genMachOp mop args - -genMachOp :: MachOp -> [CmmExpr] -> SDoc -genMachOp mop args - | Just doc <- infixMachOp mop = case args of - -- dyadic - [x,y] -> pprExpr9 x <+> doc <+> pprExpr9 y - - -- unary - [x] -> doc <> pprExpr9 x - - _ -> pprTrace "PprCmm.genMachOp: machop with strange number of args" - (pprMachOp mop <+> - parens (hcat $ punctuate comma (map pprExpr args))) - empty - - | isJust (infixMachOp1 mop) - || isJust (infixMachOp7 mop) - || isJust (infixMachOp8 mop) = parens (pprExpr (CmmMachOp mop args)) - - | otherwise = char '%' <> ppr_op <> parens (commafy (map pprExpr args)) - where ppr_op = text (map (\c -> if c == ' ' then '_' else c) - (show mop)) - -- replace spaces in (show mop) with underscores, - --- --- Unsigned ops on the word size of the machine get nice symbols. --- All else get dumped in their ugly format. --- -infixMachOp :: MachOp -> Maybe SDoc -infixMachOp mop - = case mop of - MO_And _ -> Just $ char '&' - MO_Or _ -> Just $ char '|' - MO_Xor _ -> Just $ char '^' - MO_Not _ -> Just $ char '~' - MO_S_Neg _ -> Just $ char '-' -- there is no unsigned neg :) - _ -> Nothing - --- -------------------------------------------------------------------------- --- Literals. --- To minimise line noise we adopt the convention that if the literal --- has the natural machine word size, we do not append the type --- -pprLit :: CmmLit -> SDoc -pprLit lit = case lit of - CmmInt i rep -> - hcat [ (if i < 0 then parens else id)(integer i) - , ppUnless (rep == wordWidth) $ - space <> dcolon <+> ppr rep ] - - CmmFloat f rep -> hsep [ rational f, dcolon, ppr rep ] - CmmLabel clbl -> pprCLabel clbl - CmmLabelOff clbl i -> pprCLabel clbl <> ppr_offset i - CmmLabelDiffOff clbl1 clbl2 i -> pprCLabel clbl1 <> char '-' - <> pprCLabel clbl2 <> ppr_offset i - CmmBlock id -> ppr id - CmmHighStackMark -> text "" - -pprLit1 :: CmmLit -> SDoc -pprLit1 lit@(CmmLabelOff {}) = parens (pprLit lit) -pprLit1 lit = pprLit lit - -ppr_offset :: Int -> SDoc -ppr_offset i - | i==0 = empty - | i>=0 = char '+' <> int i - | otherwise = char '-' <> int (-i) - --- -------------------------------------------------------------------------- --- Static data. --- Strings are printed as C strings, and we print them as I8[], --- following C-- --- -pprStatic :: CmmStatic -> SDoc -pprStatic s = case s of - CmmStaticLit lit -> nest 4 $ ptext (sLit "const") <+> pprLit lit <> semi - CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i) - CmmAlign i -> nest 4 $ text "align" <+> int i - CmmDataLabel clbl -> pprCLabel clbl <> colon - CmmString s' -> nest 4 $ text "I8[]" <+> text (show s') - --- -------------------------------------------------------------------------- --- Registers, whether local (temps) or global --- -pprReg :: CmmReg -> SDoc -pprReg r - = case r of - CmmLocal local -> pprLocalReg local - CmmGlobal global -> pprGlobalReg global - --- --- We only print the type of the local reg if it isn't wordRep --- -pprLocalReg :: LocalReg -> SDoc -pprLocalReg (LocalReg uniq rep) --- = ppr rep <> char '_' <> ppr uniq --- Temp Jan08 - = char '_' <> ppr uniq <> - (if isWord32 rep -- && not (isGcPtrType rep) -- Temp Jan08 -- sigh - then dcolon <> ptr <> ppr rep - else dcolon <> ptr <> ppr rep) - where - ptr = empty - --if isGcPtrType rep - -- then doubleQuotes (text "ptr") - -- else empty - --- Stack areas -pprArea :: Area -> SDoc -pprArea (RegSlot r) = hcat [ text "slot<", ppr r, text ">" ] -pprArea (CallArea id) = pprAreaId id - -pprAreaId :: AreaId -> SDoc -pprAreaId Old = text "old" -pprAreaId (Young id) = hcat [ text "young<", ppr id, text ">" ] +------------------------------------------------- +-- Outputable instances --- needs to be kept in syn with Cmm.hs.GlobalReg --- -pprGlobalReg :: GlobalReg -> SDoc -pprGlobalReg gr - = case gr of - VanillaReg n _ -> char 'R' <> int n --- Temp Jan08 --- VanillaReg n VNonGcPtr -> char 'R' <> int n --- VanillaReg n VGcPtr -> char 'P' <> int n - FloatReg n -> char 'F' <> int n - DoubleReg n -> char 'D' <> int n - LongReg n -> char 'L' <> int n - Sp -> ptext (sLit "Sp") - SpLim -> ptext (sLit "SpLim") - Hp -> ptext (sLit "Hp") - HpLim -> ptext (sLit "HpLim") - CurrentTSO -> ptext (sLit "CurrentTSO") - CurrentNursery -> ptext (sLit "CurrentNursery") - HpAlloc -> ptext (sLit "HpAlloc") - EagerBlackholeInfo -> ptext (sLit "stg_EAGER_BLACKHOLE_info") - GCEnter1 -> ptext (sLit "stg_gc_enter_1") - GCFun -> ptext (sLit "stg_gc_fun") - BaseReg -> ptext (sLit "BaseReg") - PicBaseReg -> ptext (sLit "PicBaseReg") +instance Outputable CmmStackInfo where + ppr = pprStackInfo --- -------------------------------------------------------------------------- --- data sections --- -pprSection :: Section -> SDoc -pprSection s = case s of - Text -> section <+> doubleQuotes (ptext (sLit "text")) - Data -> section <+> doubleQuotes (ptext (sLit "data")) - ReadOnlyData -> section <+> doubleQuotes (ptext (sLit "readonly")) - ReadOnlyData16 -> section <+> doubleQuotes (ptext (sLit "readonly16")) - RelocatableReadOnlyData - -> section <+> doubleQuotes (ptext (sLit "relreadonly")) - UninitialisedData -> section <+> doubleQuotes (ptext (sLit "uninitialised")) - OtherSection s' -> section <+> doubleQuotes (text s') - where - section = ptext (sLit "section") - ------------------------------------------------------------------------------ +instance Outputable CmmTopInfo where + ppr = pprTopInfo + + +instance Outputable (CmmNode e x) where + ppr = pprNode + +instance Outputable Convention where + ppr = pprConvention + +instance Outputable ForeignConvention where + ppr = pprForeignConvention + +instance Outputable ForeignTarget where + ppr = pprForeignTarget + + +instance PlatformOutputable (Block CmmNode C C) where + pprPlatform _ = pprBlock +instance PlatformOutputable (Block CmmNode C O) where + pprPlatform _ = pprBlock +instance PlatformOutputable (Block CmmNode O C) where + pprPlatform _ = pprBlock +instance PlatformOutputable (Block CmmNode O O) where + pprPlatform _ = pprBlock + +instance PlatformOutputable (Graph CmmNode e x) where + pprPlatform = pprGraph + +instance PlatformOutputable CmmGraph where + pprPlatform platform = pprCmmGraph platform + +---------------------------------------------------------- +-- Outputting types Cmm contains + +pprStackInfo :: CmmStackInfo -> SDoc +pprStackInfo (StackInfo {arg_space=arg_space, updfr_space=updfr_space}) = + ptext (sLit "arg_space: ") <> ppr arg_space <+> + ptext (sLit "updfr_space: ") <> ppr updfr_space + +pprTopInfo :: CmmTopInfo -> SDoc +pprTopInfo (TopInfo {info_tbl=info_tbl, stack_info=stack_info}) = + vcat [ptext (sLit "info_tbl: ") <> ppr info_tbl, + ptext (sLit "stack_info: ") <> ppr stack_info] + +---------------------------------------------------------- +-- Outputting blocks and graphs + +pprBlock :: IndexedCO x SDoc SDoc ~ SDoc + => Block CmmNode e x -> IndexedCO e SDoc SDoc +pprBlock block = foldBlockNodesB3 ( ($$) . ppr + , ($$) . (nest 4) . ppr + , ($$) . (nest 4) . ppr + ) + block + empty + +pprGraph :: Platform -> Graph CmmNode e x -> SDoc +pprGraph _ GNil = empty +pprGraph platform (GUnit block) = pprPlatform platform block +pprGraph platform (GMany entry body exit) + = text "{" + $$ nest 2 (pprMaybeO entry $$ (vcat $ map (pprPlatform platform) $ bodyToBlockList body) $$ pprMaybeO exit) + $$ text "}" + where pprMaybeO :: PlatformOutputable (Block CmmNode e x) + => MaybeO ex (Block CmmNode e x) -> SDoc + pprMaybeO NothingO = empty + pprMaybeO (JustO block) = pprPlatform platform block + +pprCmmGraph :: Platform -> CmmGraph -> SDoc +pprCmmGraph platform g + = text "{" <> text "offset" + $$ nest 2 (vcat $ map (pprPlatform platform) blocks) + $$ text "}" + where blocks = postorderDfs g + +--------------------------------------------- +-- Outputting CmmNode and types which it contains + +pprConvention :: Convention -> SDoc +pprConvention (NativeNodeCall {}) = text "" +pprConvention (NativeDirectCall {}) = text "" +pprConvention (NativeReturn {}) = text "" +pprConvention Slow = text "" +pprConvention GC = text "" +pprConvention PrimOpCall = text "" +pprConvention PrimOpReturn = text "" +pprConvention (Foreign c) = ppr c +pprConvention (Private {}) = text "" + +pprForeignConvention :: ForeignConvention -> SDoc +pprForeignConvention (ForeignConvention c as rs) = ppr c <> ppr as <> ppr rs + +pprForeignTarget :: ForeignTarget -> SDoc +pprForeignTarget (ForeignTarget fn c) = ppr_fc c <+> ppr_target fn + where ppr_fc :: ForeignConvention -> SDoc + ppr_fc (ForeignConvention c args res) = + doubleQuotes (ppr c) <+> text "arg hints: " <+> ppr args <+> text " result hints: " <+> ppr res + ppr_target :: CmmExpr -> SDoc + ppr_target t@(CmmLit _) = ppr t + ppr_target fn' = parens (ppr fn') + +pprForeignTarget (PrimTarget op) + -- HACK: We're just using a ForeignLabel to get this printed, the label + -- might not really be foreign. + = ppr (CmmLabel (mkForeignLabel + (mkFastString (show op)) + Nothing ForeignLabelInThisPackage IsFunction)) +pprNode :: CmmNode e x -> SDoc +pprNode node = pp_node <+> pp_debug + where + pp_node :: SDoc + pp_node = case node of + -- label: + CmmEntry id -> ppr id <> colon + + -- // text + CmmComment s -> text "//" <+> ftext s + + -- reg = expr; + CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi + + -- rep[lv] = expr; + CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi + where + rep = ppr ( cmmExprType expr ) + + -- call "ccall" foo(x, y)[r1, r2]; + -- ToDo ppr volatile + CmmUnsafeForeignCall target results args -> + hsep [ ppUnless (null results) $ + parens (commafy $ map ppr results) <+> equals, + ptext $ sLit "call", + ppr target <> parens (commafy $ map ppr args) <> semi] + + -- goto label; + CmmBranch ident -> ptext (sLit "goto") <+> ppr ident <> semi + + -- if (expr) goto t; else goto f; + CmmCondBranch expr t f -> + hsep [ ptext (sLit "if") + , parens(ppr expr) + , ptext (sLit "goto") + , ppr t <> semi + , ptext (sLit "else goto") + , ppr f <> semi + ] + + CmmSwitch expr maybe_ids -> + hang (hcat [ ptext (sLit "switch [0 .. ") + , int (length maybe_ids - 1) + , ptext (sLit "] ") + , if isTrivialCmmExpr expr then ppr expr else parens (ppr expr) + , ptext (sLit " {") + ]) + 4 (vcat ( map caseify pairs )) $$ rbrace + where pairs = groupBy snds (zip [0 .. ] maybe_ids ) + snds a b = (snd a) == (snd b) + caseify ixs@((_,Nothing):_) = ptext (sLit "/* impossible: ") + <> hcat (intersperse comma (map (int.fst) ixs)) <> ptext (sLit " */") + caseify as = let (is,ids) = unzip as + in hsep [ ptext (sLit "case") + , hcat (punctuate comma (map int is)) + , ptext (sLit ": goto") + , ppr (head [ id | Just id <- ids]) <> semi ] + + CmmCall tgt k out res updfr_off -> + hcat [ ptext (sLit "call"), space + , pprFun tgt, ptext (sLit "(...)"), space + , ptext (sLit "returns to") <+> ppr k <+> parens (ppr out) + <+> parens (ppr res) + , ptext (sLit " with update frame") <+> ppr updfr_off + , semi ] + where pprFun f@(CmmLit _) = ppr f + pprFun f = parens (ppr f) + + CmmForeignCall {tgt=t, res=rs, args=as, succ=s, updfr=u, intrbl=i} -> + hcat $ if i then [ptext (sLit "interruptible"), space] else [] ++ + [ ptext (sLit "foreign call"), space + , ppr t, ptext (sLit "(...)"), space + , ptext (sLit "returns to") <+> ppr s + <+> ptext (sLit "args:") <+> parens (ppr as) + <+> ptext (sLit "ress:") <+> parens (ppr rs) + , ptext (sLit " with update frame") <+> ppr u + , semi ] + + pp_debug :: SDoc + pp_debug = + if not debugIsOn then empty + else case node of + CmmEntry {} -> empty -- Looks terrible with text " // CmmEntry" + CmmComment {} -> empty -- Looks also terrible with text " // CmmComment" + CmmAssign {} -> text " // CmmAssign" + CmmStore {} -> text " // CmmStore" + CmmUnsafeForeignCall {} -> text " // CmmUnsafeForeignCall" + CmmBranch {} -> text " // CmmBranch" + CmmCondBranch {} -> text " // CmmCondBranch" + CmmSwitch {} -> text " // CmmSwitch" + CmmCall {} -> text " // CmmCall" + CmmForeignCall {} -> text " // CmmForeignCall" -commafy :: [SDoc] -> SDoc -commafy xs = fsep $ punctuate comma xs + commafy :: [SDoc] -> SDoc + commafy xs = hsep $ punctuate comma xs diff -Nru ghc-7.0.3/compiler/cmm/PprCmmZ.hs ghc-7.2.1/compiler/cmm/PprCmmZ.hs --- ghc-7.0.3/compiler/cmm/PprCmmZ.hs 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/cmm/PprCmmZ.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,88 +0,0 @@ - -module PprCmmZ - ( pprCmmGraphLikeCmm - ) -where - -import BlockId -import Cmm -import PprCmm -import Outputable -import qualified ZipCfgCmmRep as G -import qualified ZipCfg as Z -import CmmZipUtil - -import Data.Maybe -import FastString - ----------------------------------------------------------------- --- | The purpose of this function is to print a Cmm zipper graph "as if it were" --- a Cmm program. The objective is dodgy, so it's unsurprising parts of the --- code are dodgy as well. - -pprCmmGraphLikeCmm :: G.CmmGraph -> SDoc -pprCmmGraphLikeCmm g = vcat (swallow blocks) - where blocks = Z.postorder_dfs g - swallow :: [G.CmmBlock] -> [SDoc] - swallow [] = [] - swallow (Z.Block id t : rest) = tail id [] Nothing t rest - tail id prev' out (Z.ZTail m t) rest = tail id (mid m : prev') out t rest - tail id prev' out (Z.ZLast (Z.LastOther l)) rest = last id prev' out l rest - tail id prev' _ (Z.ZLast Z.LastExit) rest = exit id prev' rest - mid m = ppr m - block' id prev' - | id == Z.lg_entry g, entry_has_no_pred = - vcat (text "" : reverse prev') - | otherwise = hang (ppr id <> colon) 4 (vcat (reverse prev')) - last id prev' out l n = - let endblock stmt = block' id (stmt : prev') : swallow n in - case l of - G.LastBranch tgt -> - case n of - Z.Block id' t : bs - | tgt == id', unique_pred id' - -> tail id prev' out t bs -- optimize out redundant labels - _ -> endblock (ppr $ CmmBranch tgt) - l@(G.LastCondBranch expr tid fid) -> - let ft id = text "// fall through to " <> ppr id in - case n of - Z.Block id' t : bs - | id' == fid, isNothing out -> - tail id (ft fid : ppr (CmmCondBranch expr tid) : prev') Nothing t bs - | id' == tid, Just e' <- maybeInvertCmmExpr expr, isNothing out-> - tail id (ft tid : ppr (CmmCondBranch e' fid) : prev') Nothing t bs - _ -> endblock $ with_out out l - l@(G.LastSwitch {}) -> endblock $ with_out out l - l@(G.LastCall _ _ _ _ _) -> endblock $ with_out out l - exit id prev' n = -- highly irregular (assertion violation?) - let endblock stmt = block' id (stmt : prev') : swallow n in - endblock (text "// ") - preds = zipPreds g - entry_has_no_pred = case lookupBlockEnv preds (Z.lg_entry g) of - Nothing -> True - Just s -> isEmptyBlockSet s - single_preds = - let add b single = - let id = Z.blockId b - in case lookupBlockEnv preds id of - Nothing -> single - Just s -> if sizeBlockSet s == 1 then - extendBlockSet single id - else single - in Z.fold_blocks add emptyBlockSet g - unique_pred id = elemBlockSet id single_preds - -with_out :: Maybe (G.Convention, CmmActuals) -> G.Last -> SDoc -with_out Nothing l = ptext (sLit "??no-arguments??") <+> ppr l -with_out (Just (conv, args)) l = last l - where last (G.LastCall e k _ _ _) = - hcat [ptext (sLit "... = foreign "), - doubleQuotes(ppr conv), space, - ppr_target e, parens ( commafy $ map ppr args ), - ptext (sLit " \"safe\""), - text " returns to " <+> ppr k, - semi ] - last l = ppr l - ppr_target (CmmLit lit) = pprLit lit - ppr_target fn' = parens (ppr fn') - commafy xs = hsep $ punctuate comma xs diff -Nru ghc-7.0.3/compiler/cmm/README ghc-7.2.1/compiler/cmm/README --- ghc-7.0.3/compiler/cmm/README 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/cmm/README 1970-01-01 00:00:00.000000000 +0000 @@ -1,94 +0,0 @@ -Sketch of the new arrivals: - - MkZipCfg Constructor functions for control-flow graphs. - Not understandable in its entirety without reference - to ZipCfg, but nevertheless a worthy starting point, - as it is a good deal simpler than full ZipCfg. - MkZipCfg is polymorphic in the types of middle and last - nodes. - - ZipCfg Describes a zipper-like representation for true basic-block - control-flow graphs. A block has a single entry point, - which is a always a label, followed by zero or mode 'middle - nodes', each of which represents an uninterruptible - single-entry, single-exit computation, then finally a 'last - node', which may have zero or more successors. A special - 'exit node' is used for splicing together graphs. - - In addition to three representations of flow graphs, the - module provides a surfeit of functions for observing and - modifying graphs and related data: - - Block IDs, sets and environments thereof - - supply of fresh block IDS (as String -> UniqSM BlockId) - - myriad functions for splicing graphs - - postorder_dfs layout of blocks - - folding, mapping, and translation functions - - ZipCFG is polymorphic in the type of middle and last nodes. - - CmmExpr Code for C-- expressions, which is shared among old and new - representations of flow graphs. Of primary interest is the - type class UserOfLocalRegs and its method foldRegsUsed, - which is sufficiently overloaded to be used against - expressions, statements, formals, hinted formals, and so - on. This overloading greatly clarifies the computation of - liveness as well as some other analyses. - - ZipCfgCmm Types to instantiate ZipCfg for C--: middle and last nodes, - and a bunch of abbreviations of types in ZipCfg and Cmm. - Also provides suitable constructor functions for building - graphs from Cmm statements. - - CmmLiveZ A good example of a very simple dataflow analysis. It - computes the set of live local registers at each point. - - DFMonad Support for dataflow analysis and dataflow-based - transformation. This module needs work. Includes - DataflowLattice - for tracking dataflow facts (good) - DFM - monad for iterative dataflow analysis and rewriting (OK) - DFTx - monad to track Whalley/Davidson transactions (ugly) - type class DataflowAnalysis - operations common to DFA, DFM - Some dodgy bits are - subAnalysis, which may not be right - - ZipDataflow Iteratively solve forward and backward dataflow problems over - flow graphs. Polymorphic in the type of graph and in the - lattice of dataflow facts. Supports the incremental - rewriting technique described by Lerner, Grove, and Chambers - in POPL 2002. The code is a mess and is still being - sorted out. - - - CmmTx A simple monad for tracking when a transformation has - occurred (something has changed). - - CmmCvt Converts between Cmm and ZipCfgCmm representations. - - CmmProcPointZ One module that performs three analyses and - transformations: - - 1. Using Michael Adams's iterative algorithm, computes a - minimal set of proc points that enable code to be - generated without copying any basic blocks. - - 2. Assigns a protocol to each proc point. The assigner - is rigged to enable the 'Adams optimization' whereby - we attempt to eliminate return continuations by - making procedures return directly to join points. - Arguably this could be done by a separate rewriting - pass to perform earlier. - - 3. Insert CopyIn and CopyOut nodes where needed - according to the protocols. - - CmmSpillReload Inserts spills and reloads to establish the invariant that - at a safe call, there are no live variables in registers. - - CmmCPSZ The CPS transformation so far. - - CmmContFlowOpt Branch-chain elimination and elimination of unreachable code. - - CmmOpt Changed optimization to use 'foldRegsUsed'; eliminated - significant duplication of code. - - PprCmmZ Prettyprinting functions related to ZipCfg and ZipCfgCmm diff -Nru ghc-7.0.3/compiler/cmm/StackColor.hs ghc-7.2.1/compiler/cmm/StackColor.hs --- ghc-7.0.3/compiler/cmm/StackColor.hs 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/cmm/StackColor.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,133 +0,0 @@ - -module StackColor where - -import BlockId -import StackPlacements -import qualified GraphColor as Color -import CmmExpr -import CmmSpillReload -import DFMonad -import qualified GraphOps -import ZipCfg -import ZipCfgCmmRep -import ZipDataflow - -import Maybes -import Panic -import UniqSet - --- import Data.List - -fold_edge_facts_b :: - LastNode l => (DualLive -> a -> a) -> BackwardTransfers m l DualLive -> LGraph m l - -> (BlockId -> DualLive) -> a -> a -fold_edge_facts_b f comp graph env z = - foldl fold_block_facts z (postorder_dfs graph) - where - fold_block_facts z b = - let (h, l) = goto_end (ZipCfg.unzip b) - last_in _ LastExit = fact_bot dualLiveLattice - last_in env (LastOther l) = bt_last_in comp l env - in head_fold h (last_in env l) z - head_fold (ZHead h m) out z = head_fold h (bt_middle_in comp m out) (f out z) - head_fold (ZFirst id) out z = f (bt_first_in comp id out) (f out z) - -foldConflicts :: (RegSet -> a -> a) -> a -> LGraph Middle Last -> FuelMonad a -foldConflicts f z g@(LGraph entry _) = - do env <- dualLiveness emptyBlockSet g - let lookup id = lookupBlockEnv env id `orElse` fact_bot dualLiveLattice - f' dual z = f (on_stack dual) z - return $ fold_edge_facts_b f' (dualLiveTransfers entry emptyBlockSet) g lookup z - --let env = runDFA dualLiveLattice (run_b_anal dualLiveness g >> getAllFacts) - -- lookup id = lookupBlockEnv env id `orElse` fact_bot dualLiveLattice - -- f' dual z = f (on_stack dual) z - --in fold_edge_facts_b f' dualLiveness g lookup z - - -type IGraph = Color.Graph LocalReg SlotClass StackPlacement -type ClassCount = [(SlotClass, Int)] - -buildIGraphAndCounts :: LGraph Middle Last -> FuelMonad (IGraph, ClassCount) -buildIGraphAndCounts g = igraph_and_counts - where igraph_and_counts = foldConflicts add (Color.initGraph, zero) g - zero = map (\c -> (c, 0)) allSlotClasses - add live (igraph, counts) = (graphAddConflictSet live igraph, - addSimulCounts (classCounts live) counts) - addSimulCounts = - zipWith (\(c, n) (c', n') -> if c == c' then (c, max n n') - else panic "slot classes out of order") - classCounts regs = foldUniqSet addReg zero regs - addReg reg counts = - let cls = slotClass reg in - map (\(c, n) -> (c, if c == cls then n + 1 else n)) counts - - --- | Add some conflict edges to the graph. --- Conflicts between virtual and real regs are recorded as exclusions. --- - -graphAddConflictSet :: RegSet -> IGraph -> IGraph -graphAddConflictSet set graph = GraphOps.addConflicts set slotClass graph - -slotClass :: LocalReg -> SlotClass -slotClass (LocalReg _ ty) = - case typeWidth ty of -- the horror, the horror - W8 -> SlotClass32 - W16 -> SlotClass32 - W32 -> SlotClass32 - W64 -> SlotClass64 - W128 -> SlotClass128 - W80 -> SlotClass64 - -{- -colorMe :: (IGraph, ClassCount) -> (IGraph, UniqSet LocalReg) -colorMe (igraph, counts) = Color.colorGraph starter_colors triv spill_max_degree igraph - where starter_colors = allocate [] counts allStackSlots - allocate prev [] colors = insert prev colors - allocate prev ((c, n) : counts) colors = - let go prev 0 colors = allocate prev counts colors - go prev n colors = let (p, colors') = getStackSlot c colors in - go (p:prev) (n-1) colors' - in go prev n colors - insert :: [StackPlacement] -> SlotSet -> SlotSet - insert [] colors = colors - insert (p:ps) colors = insert ps (extendSlotSet colors p) - triv :: Color.Triv LocalReg SlotClass StackPlacement - triv = trivColorable (mkSizeOf counts) - -spill_max_degree :: IGraph -> LocalReg -spill_max_degree igraph = Color.nodeId node - where node = maximumBy (\n1 n2 -> compare - (sizeUniqSet $ Color.nodeConflicts n1) - (sizeUniqSet $ Color.nodeConflicts n2)) $ - eltsUFM $ Color.graphMap igraph - - -type Worst = SlotClass -> (Int, Int, Int) -> Int - -trivColorable :: (SlotClass -> Int) -> - SlotClass -> UniqSet LocalReg -> UniqSet StackPlacement -> Bool -trivColorable sizeOf classN conflicts exclusions = squeeze < sizeOf classN - where squeeze = worst classN counts - counts = if isEmptyUniqSet exclusions then foldUniqSet acc zero conflicts - else panic "exclusions in stack slots?!" - zero = (0, 0, 0) - acc r (word, dbl, quad) = - case slotClass r of - SlotClass32 -> (word+1, dbl, quad) - SlotClass64 -> (word, dbl+1, quad) - SlotClass128 -> (word, dbl, quad+1) - worst SlotClass128 (_, _, q) = q - worst SlotClass64 (_, d, q) = d + 2 * q - worst SlotClass32 (w, d, q) = w + 2 * d + 4 * q --} - --- | number of placements available is from class and all larger classes -mkSizeOf :: ClassCount -> (SlotClass -> Int) -mkSizeOf counts = sizeOf - where sizeOf SlotClass32 = n32 - sizeOf SlotClass64 = n64 - sizeOf SlotClass128 = n128 - n128 = (lookup SlotClass128 counts `orElse` 0) - n64 = (lookup SlotClass64 counts `orElse` 0) + 2 * n128 - n32 = (lookup SlotClass32 counts `orElse` 0) + 2 * n32 diff -Nru ghc-7.0.3/compiler/cmm/StackPlacements.hs ghc-7.2.1/compiler/cmm/StackPlacements.hs --- ghc-7.0.3/compiler/cmm/StackPlacements.hs 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/cmm/StackPlacements.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,248 +0,0 @@ - -module StackPlacements - ( SlotSet, allStackSlots -- the infinite set of stack slots - , SlotClass(..), slotClassBits, stackSlot32, stackSlot64, stackSlot128 - , allSlotClasses - , getStackSlot, extendSlotSet, deleteFromSlotSet, elemSlotSet, chooseSlot - , StackPlacement(..) - ) -where - -import Maybes -import Outputable -import Unique - -import Prelude hiding (pi) -import Data.List - -{- - -The goal here is to provide placements on the stack that will allow, -for example, two 32-bit words to spill to a slot previously used by a -64-bit floating-point value. I use a simple buddy-system allocator -that splits large slots in half as needed; this will work fine until -the day when somebody wants to spill an 80-bit Intel floating-point -register into the Intel standard 96-bit stack slot. - --} - -data SlotClass = SlotClass32 | SlotClass64 | SlotClass128 - deriving (Eq) - -instance Uniquable SlotClass where - getUnique = getUnique . slotClassBits - -instance Outputable SlotClass where - ppr cls = text "class of" <+> int (slotClassBits cls) <> text "-bit stack slots" - -slotClassBits :: SlotClass -> Int -slotClassBits SlotClass32 = 32 -slotClassBits SlotClass64 = 64 -slotClassBits SlotClass128 = 128 - -data StackPlacement = FullSlot SlotClass Int - | YoungHalf StackPlacement - | OldHalf StackPlacement - deriving (Eq) - -data OneSize = OneSize { full_slots :: [StackPlacement], fragments :: [StackPlacement] } - -- ^ Always used for slots that have been previously used - -data SlotSet = SlotSet { s32, s64, s128 :: OneSize, next_unused :: Int } - -allStackSlots :: SlotSet -allStackSlots = SlotSet empty empty empty 0 - where empty = OneSize [] [] - - -psize :: StackPlacement -> Int -psize (FullSlot cls _) = slotClassBits cls -psize (YoungHalf p) = psize p `div` 2 -psize (OldHalf p) = psize p `div` 2 - - - - --- | Get a slot no matter what -get32, get64, get128 :: SlotSet -> (StackPlacement, SlotSet) - --- | Get a previously used slot if one exists -getu32, getu64, getu128 :: SlotSet -> Maybe (StackPlacement, SlotSet) - --- | Only supported slot classes - -stackSlot32, stackSlot64, stackSlot128 :: SlotClass -stackSlot32 = SlotClass32 -stackSlot64 = SlotClass64 -stackSlot128 = SlotClass128 - -allSlotClasses :: [SlotClass] -allSlotClasses = [stackSlot32, stackSlot64, stackSlot128] - --- | Get a fresh slot, never before used -getFull :: SlotClass -> SlotSet -> (StackPlacement, SlotSet) - -infixr 4 ||| - -(|||) :: (SlotSet -> Maybe (StackPlacement, SlotSet)) -> - (SlotSet -> (StackPlacement, SlotSet)) -> - (SlotSet -> (StackPlacement, SlotSet)) - -f1 ||| f2 = \slots -> f1 slots `orElse` f2 slots - -getFull cls slots = (FullSlot cls n, slots { next_unused = n + 1 }) - where n = next_unused slots - -get32 = getu32 ||| (fmap split64 . getu64) ||| getFull stackSlot32 -get64 = getu64 ||| (fmap split128 . getu128) ||| getFull stackSlot64 -get128 = getu128 ||| getFull stackSlot128 - -type SizeGetter = SlotSet -> OneSize -type SizeSetter = OneSize -> SlotSet -> SlotSet - -upd32, upd64, upd128 :: SizeSetter -upd32 this_size slots = slots { s32 = this_size } -upd64 this_size slots = slots { s64 = this_size } -upd128 this_size slots = slots { s128 = this_size } - -with_size :: Int -> (SizeGetter -> SizeSetter -> a) -> a -with_size 32 = with_32 -with_size 64 = with_64 -with_size 128 = with_128 -with_size _ = panic "non-standard slot size -- error in size computation?" - -with_32, with_64, with_128 :: (SizeGetter -> SizeSetter -> a) -> a -with_32 f = f s32 upd32 -with_64 f = f s64 upd64 -with_128 f = f s128 upd128 - -getu32 = with_32 getUsed -getu64 = with_64 getUsed -getu128 = with_128 getUsed - -getUsed :: SizeGetter -> SizeSetter -> SlotSet -> Maybe (StackPlacement, SlotSet) -getUsed get set slots = - let this_size = get slots in - case full_slots this_size of - p : ps -> Just (p, set (this_size { full_slots = ps }) slots) - [] -> case fragments this_size of - p : ps -> Just (p, set (this_size { fragments = ps }) slots) - [] -> Nothing - --- | When splitting, allocate the old half first in case it makes the --- stack smaller at a call site. -split64, split128 :: (StackPlacement, SlotSet) -> (StackPlacement, SlotSet) -split64 (p, slots) = (OldHalf p, slots { s32 = cons_frag (YoungHalf p) (s32 slots) }) -split128 (p, slots) = (OldHalf p, slots { s64 = cons_frag (YoungHalf p) (s64 slots) }) - -cons_frag :: StackPlacement -> OneSize -> OneSize -cons_frag p this_size = this_size { fragments = p : fragments this_size } - - ----------------------------- -instance Outputable StackPlacement where - ppr (FullSlot cls n) = int (slotClassBits cls) <> text "-bit slot " <> int n - ppr (YoungHalf p) = text "young half of" <+> ppr p - ppr (OldHalf p) = text "old half of" <+> ppr p - -instance Outputable SlotSet where - ppr slots = fsep $ punctuate comma - (pprSlots (s32 slots) ++ pprSlots (s64 slots) ++ pprSlots (s128 slots) ++ - [text "and slots numbered" <+> int (next_unused slots) - <+> text "and up"]) - where pprSlots (OneSize w fs) = map ppr w ++ map ppr fs - -{- -instance ColorSet SlotSet SlotClass StackPlacement where - emptyColorSet = panic "The set of stack slots is never empty" - deleteFromColorSet = deleteFromSlotSet - extendColorSet slots (cls, p@(FullSlot {})) = - with_size (slotClassBits cls) add_full p (pi slots) - extendColorSet slots (cls, p) = with_size (slotClassBits cls) add_frag p (pi slots) - chooseColor = chooseSlot --} - -deleteFromSlotSet :: StackPlacement -> SlotSet -> SlotSet -deleteFromSlotSet p@(FullSlot {}) slots = with_size (psize p) remove_full p (pi slots) -deleteFromSlotSet p slots = with_size (psize p) remove_frag p (pi slots) - -extendSlotSet :: SlotSet -> StackPlacement -> SlotSet -extendSlotSet slots p@(FullSlot {}) = with_size (psize p) add_full p (pi slots) -extendSlotSet slots p = with_size (psize p) add_frag p (pi slots) - -elemSlotSet :: StackPlacement -> SlotSet -> Bool -elemSlotSet p@(FullSlot {}) slots = with_size (psize p) elem_full p slots -elemSlotSet p slots = with_size (psize p) elem_frag p slots - -remove_full, remove_frag, add_full, add_frag - :: SizeGetter -> SizeSetter -> StackPlacement -> SlotSet -> SlotSet - -remove_full get set p slots = set p' slots - where this_size = get slots - p' = this_size { full_slots = delete p $ full_slots this_size } - -remove_frag get set p slots = set p' slots - where this_size = get slots - p' = this_size { full_slots = delete p $ full_slots this_size } - -add_full get set p slots = set p' slots - where this_size = get slots - p' = this_size { full_slots = add p $ full_slots this_size } - -add_frag get set p slots = set p' slots - where this_size = get slots - p' = this_size { full_slots = add p $ full_slots this_size } - -add :: Eq a => a -> [a] -> [a] -add x xs = if notElem x xs then x : xs else xs - -elem_full, elem_frag :: SizeGetter -> SizeSetter -> StackPlacement -> SlotSet -> Bool -elem_full get _set p slots = elem p (full_slots $ get slots) -elem_frag get _set p slots = elem p (fragments $ get slots) - - - - -getStackSlot :: SlotClass -> SlotSet -> (StackPlacement, SlotSet) -getStackSlot cls slots = - case cls of - SlotClass32 -> get32 (pi slots) - SlotClass64 -> get64 (pi slots) - SlotClass128 -> get128 (pi slots) - - -chooseSlot :: SlotClass -> [StackPlacement] -> SlotSet -> Maybe (StackPlacement, SlotSet) -chooseSlot cls prefs slots = - case filter (flip elemSlotSet slots) prefs of - placement : _ -> Just (placement, deleteFromSlotSet placement (pi slots)) - [] -> Just (getStackSlot cls slots) - -check_invariant :: Bool -check_invariant = True - -pi :: SlotSet -> SlotSet -pi = if check_invariant then panic_on_invariant_violation else id - -panic_on_invariant_violation :: SlotSet -> SlotSet -panic_on_invariant_violation slots = - check 32 (s32 slots) $ check 64 (s64 slots) $ check 128 (s128 slots) $ slots - where n = next_unused slots - check bits this_size = (check_full bits $ full_slots this_size) . - (check_frag bits $ fragments this_size) - check_full _ [] = id - check_full bits (FullSlot cls k : ps) = - if slotClassBits cls /= bits then panic "slot in bin of wrong size" - else if k >= n then panic "slot number is unreasonably fresh" - else check_full bits ps - check_full _ _ = panic "a fragment is in a bin reserved for full slots" - check_frag _ [] = id - check_frag _ (FullSlot {} : _) = - panic "a full slot is in a bin reserved for fragments" - check_frag bits (p : ps) = - if bits /= psize p then panic "slot in bin of wrong size" - else if pnumber p >= n then panic "slot number is unreasonably fresh" - else check_frag bits ps - pnumber (FullSlot _ k) = k - pnumber (YoungHalf p) = pnumber p - pnumber (OldHalf p) = pnumber p - diff -Nru ghc-7.0.3/compiler/cmm/ZipCfgCmmRep.hs ghc-7.2.1/compiler/cmm/ZipCfgCmmRep.hs --- ghc-7.0.3/compiler/cmm/ZipCfgCmmRep.hs 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/cmm/ZipCfgCmmRep.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,562 +0,0 @@ -#if __GLASGOW_HASKELL__ >= 611 -{-# OPTIONS_GHC -XNoMonoLocalBinds #-} -#endif --- Norman likes local bindings - --- This module is pure representation and should be imported only by --- clients that need to manipulate representation and know what --- they're doing. Clients that need to create flow graphs should --- instead import MkZipCfgCmm. - -module ZipCfgCmmRep - ( CmmZ, CmmTopZ, CmmGraph, CmmBlock, CmmAGraph - , Middle(..), Last(..), MidCallTarget(..), UpdFrameOffset - , Convention(..), ForeignConvention(..), ForeignSafety(..) - , ValueDirection(..), ForeignHint(..) - , CmmBackwardFixedPoint, CmmForwardFixedPoint, pprHinted - , insertBetween, mapExpMiddle, mapExpLast, mapExpDeepMiddle, mapExpDeepLast - , foldExpMiddle, foldExpLast, foldExpDeepMiddle, foldExpDeepLast, joinOuts - ) -where - -import BlockId -import CmmExpr -import Cmm ( GenCmm(..), GenCmmTop(..), CmmStatic, CmmInfo - , CallishMachOp(..), ForeignHint(..) - , CmmActuals, CmmFormals, CmmHinted(..) - , CmmStmt(..) -- imported in order to call ppr on Switch and to - -- implement pprCmmGraphLikeCmm - ) -import DFMonad -import PprCmm() -import CmmTx - -import CLabel -import FastString -import ForeignCall -import qualified ZipDataflow as DF -import ZipCfg -import MkZipCfg -import Util - -import BasicTypes -import Maybes -import Control.Monad -import Outputable -import Prelude hiding (zip, unzip, last) -import SMRep (ByteOff) -import UniqSupply - ----------------------------------------------------------------------- ------ Type synonyms and definitions - -type CmmGraph = LGraph Middle Last -type CmmAGraph = AGraph Middle Last -type CmmBlock = Block Middle Last -type CmmStackInfo = (ByteOff, Maybe ByteOff) - -- probably want a record; (SP offset on entry, update frame space) -type CmmZ = GenCmm CmmStatic CmmInfo (CmmStackInfo, CmmGraph) -type CmmTopZ = GenCmmTop CmmStatic CmmInfo (CmmStackInfo, CmmGraph) -type CmmBackwardFixedPoint a = DF.BackwardFixedPoint Middle Last a () -type CmmForwardFixedPoint a = DF.ForwardFixedPoint Middle Last a () - -type UpdFrameOffset = ByteOff - -data Middle - = MidComment FastString - - | MidAssign CmmReg CmmExpr -- Assign to register - - | MidStore CmmExpr CmmExpr -- Assign to memory location. Size is - -- given by cmmExprType of the rhs. - - | MidForeignCall -- A foreign call; see Note [Foreign calls] - ForeignSafety -- Is it a safe or unsafe call? - MidCallTarget -- call target and convention - CmmFormals -- zero or more results - CmmActuals -- zero or more arguments - deriving Eq - -data Last - = LastBranch BlockId -- Goto another block in the same procedure - - | LastCondBranch { -- conditional branch - cml_pred :: CmmExpr, - cml_true, cml_false :: BlockId - } - | LastSwitch CmmExpr [Maybe BlockId] -- Table branch - -- The scrutinee is zero-based; - -- zero -> first block - -- one -> second block etc - -- Undefined outside range, and when there's a Nothing - | LastCall { -- A call (native or safe foreign) - cml_target :: CmmExpr, -- never a CmmPrim to a CallishMachOp! - - cml_cont :: Maybe BlockId, - -- BlockId of continuation (Nothing for return or tail call) - - cml_args :: ByteOff, - -- Byte offset, from the *old* end of the Area associated with - -- the BlockId (if cml_cont = Nothing, then Old area), of - -- youngest outgoing arg. Set the stack pointer to this before - -- transferring control. - -- (NB: an update frame might also have been stored in the Old - -- area, but it'll be in an older part than the args.) - - cml_ret_args :: ByteOff, - -- For calls *only*, the byte offset for youngest returned value - -- This is really needed at the *return* point rather than here - -- at the call, but in practice it's convenient to record it here. - - cml_ret_off :: Maybe ByteOff - -- For calls *only*, the byte offset of the base of the frame that - -- must be described by the info table for the return point. - -- The older words are an update frames, which have their own - -- info-table and layout information - - -- From a liveness point of view, the stack words older than - -- cml_ret_off are treated as live, even if the sequel of - -- the call goes into a loop. - } - -data MidCallTarget -- The target of a MidUnsafeCall - = ForeignTarget -- A foreign procedure - CmmExpr -- Its address - ForeignConvention -- Its calling convention - - | PrimTarget -- A possibly-side-effecting machine operation - CallishMachOp -- Which one - deriving Eq - -data Convention - = NativeDirectCall -- Native C-- call skipping the node (closure) argument - - | NativeNodeCall -- Native C-- call including the node argument - - | NativeReturn -- Native C-- return - - | Slow -- Slow entry points: all args pushed on the stack - - | GC -- Entry to the garbage collector: uses the node reg! - - | PrimOpCall -- Calling prim ops - - | PrimOpReturn -- Returning from prim ops - - | Foreign -- Foreign call/return - ForeignConvention - - | Private - -- Used for control transfers within a (pre-CPS) procedure All - -- jump sites known, never pushed on the stack (hence no SRT) - -- You can choose whatever calling convention you please - -- (provided you make sure all the call sites agree)! - -- This data type eventually to be extended to record the convention. - deriving( Eq ) - -data ForeignConvention - = ForeignConvention - CCallConv -- Which foreign-call convention - [ForeignHint] -- Extra info about the args - [ForeignHint] -- Extra info about the result - deriving Eq - -data ForeignSafety - = Unsafe -- unsafe call - | Safe BlockId -- making infotable requires: 1. label - UpdFrameOffset -- 2. where the upd frame is - deriving Eq - -data ValueDirection = Arguments | Results - -- Arguments go with procedure definitions, jumps, and arguments to calls - -- Results go with returns and with results of calls. - deriving Eq - -{- Note [Foreign calls] -~~~~~~~~~~~~~~~~~~~~~~~ -A MidForeign call is used *all* foreign calls, both *unsafe* and *safe*. -Unsafe ones are easy: think of them as a "fat machine instruction". - -Safe ones are trickier. A safe foreign call - r = f(x) -ultimately expands to - push "return address" -- Never used to return to; - -- just points an info table - save registers into TSO - call suspendThread - r = f(x) -- Make the call - call resumeThread - restore registers - pop "return address" -We cannot "lower" a safe foreign call to this sequence of Cmms, because -after we've saved Sp all the Cmm optimiser's assumptions are broken. -Furthermore, currently the smart Cmm constructors know the calling -conventions for Haskell, the garbage collector, etc, and "lower" them -so that a LastCall passes no parameters or results. But the smart -constructors do *not* (currently) know the foreign call conventions. - -For these reasons use MidForeignCall for all calls. The only annoying thing -is that a safe foreign call needs an info table. --} - ----------------------------------------------------------------------- ------ Splicing between blocks --- Given a middle node, a block, and a successor BlockId, --- we can insert the middle node between the block and the successor. --- We return the updated block and a list of new blocks that must be added --- to the graph. --- The semantics is a bit tricky. We consider cases on the last node: --- o For a branch, we can just insert before the branch, --- but sometimes the optimizer does better if we actually insert --- a fresh basic block, enabling some common blockification. --- o For a conditional branch, switch statement, or call, we must insert --- a new basic block. --- o For a jump or return, this operation is impossible. - -insertBetween :: MonadUnique m => CmmBlock -> [Middle] -> BlockId -> m (CmmBlock, [CmmBlock]) -insertBetween b ms succId = insert $ goto_end $ unzip b - where insert (h, LastOther (LastBranch bid)) = - if bid == succId then - do (bid', bs) <- newBlocks - return (zipht h (ZLast (LastOther (LastBranch bid'))), bs) - else panic "tried invalid block insertBetween" - insert (h, LastOther (LastCondBranch c t f)) = - do (t', tbs) <- if t == succId then newBlocks else return $ (t, []) - (f', fbs) <- if f == succId then newBlocks else return $ (f, []) - return (zipht h $ ZLast $ LastOther (LastCondBranch c t' f'), tbs ++ fbs) - insert (h, LastOther (LastSwitch e ks)) = - do (ids, bs) <- mapAndUnzipM mbNewBlocks ks - return (zipht h $ ZLast $ LastOther (LastSwitch e ids), join bs) - insert (_, LastOther (LastCall {})) = - panic "unimp: insertBetween after a call -- probably not a good idea" - insert (_, LastExit) = panic "cannot insert after exit" - newBlocks = do id <- liftM BlockId $ getUniqueM - return $ (id, [Block id $ - foldr ZTail (ZLast (LastOther (LastBranch succId))) ms]) - mbNewBlocks (Just k) = if k == succId then liftM lift newBlocks - else return (Just k, []) - mbNewBlocks Nothing = return (Nothing, []) - lift (id, bs) = (Just id, bs) - ----------------------------------------------------------------------- ------ Instance declarations for control flow - -instance HavingSuccessors Last where - succs = cmmSuccs - fold_succs = fold_cmm_succs - -instance LastNode Last where - mkBranchNode id = LastBranch id - isBranchNode (LastBranch _) = True - isBranchNode _ = False - branchNodeTarget (LastBranch id) = id - branchNodeTarget _ = panic "asked for target of non-branch" - -cmmSuccs :: Last -> [BlockId] -cmmSuccs (LastBranch id) = [id] -cmmSuccs (LastCall _ Nothing _ _ _) = [] -cmmSuccs (LastCall _ (Just id) _ _ _) = [id] -cmmSuccs (LastCondBranch _ t f) = [f, t] -- meets layout constraint -cmmSuccs (LastSwitch _ edges) = catMaybes edges - -fold_cmm_succs :: (BlockId -> a -> a) -> Last -> a -> a -fold_cmm_succs f (LastBranch id) z = f id z -fold_cmm_succs _ (LastCall _ Nothing _ _ _) z = z -fold_cmm_succs f (LastCall _ (Just id) _ _ _) z = f id z -fold_cmm_succs f (LastCondBranch _ te fe) z = f te (f fe z) -fold_cmm_succs f (LastSwitch _ edges) z = foldl (flip f) z $ catMaybes edges - ----------------------------------------------------------------------- ------ Instance declarations for register use - -instance UserOfLocalRegs Middle where - foldRegsUsed f z m = middle m - where middle (MidComment {}) = z - middle (MidAssign _lhs expr) = fold f z expr - middle (MidStore addr rval) = fold f (fold f z addr) rval - middle (MidForeignCall _ tgt _ args) = fold f (fold f z tgt) args - fold f z m = foldRegsUsed f z m -- avoid monomorphism restriction - -instance UserOfLocalRegs MidCallTarget where - foldRegsUsed _f z (PrimTarget _) = z - foldRegsUsed f z (ForeignTarget e _) = foldRegsUsed f z e - -instance UserOfSlots MidCallTarget where - foldSlotsUsed f z (ForeignTarget e _) = foldSlotsUsed f z e - foldSlotsUsed _f z (PrimTarget _) = z - -instance (UserOfLocalRegs a) => UserOfLocalRegs (Maybe a) where - foldRegsUsed f z (Just x) = foldRegsUsed f z x - foldRegsUsed _ z Nothing = z - -instance (UserOfSlots a) => UserOfSlots (Maybe a) where - foldSlotsUsed f z (Just x) = foldSlotsUsed f z x - foldSlotsUsed _ z Nothing = z - -instance UserOfLocalRegs Last where - foldRegsUsed f z l = last l - where last (LastBranch _id) = z - last (LastCall tgt _ _ _ _) = foldRegsUsed f z tgt - last (LastCondBranch e _ _) = foldRegsUsed f z e - last (LastSwitch e _tbl) = foldRegsUsed f z e - -instance DefinerOfLocalRegs Middle where - foldRegsDefd f z m = middle m - where middle (MidComment {}) = z - middle (MidAssign lhs _) = fold f z lhs - middle (MidStore _ _) = z - middle (MidForeignCall _ _ fs _) = fold f z fs - fold f z m = foldRegsDefd f z m -- avoid monomorphism restriction - -instance DefinerOfLocalRegs Last where - foldRegsDefd _ z _ = z - - ----------------------------------------------------------------------- ------ Instance declarations for stack slot use - -instance UserOfSlots Middle where - foldSlotsUsed f z m = middle m - where middle (MidComment {}) = z - middle (MidAssign _lhs expr) = fold f z expr - middle (MidStore addr rval) = fold f (fold f z addr) rval - middle (MidForeignCall _ tgt _ress args) = fold f (fold f z tgt) args - fold f z e = foldSlotsUsed f z e -- avoid monomorphism restriction - -instance UserOfSlots Last where - foldSlotsUsed f z l = last l - where last (LastBranch _id) = z - last (LastCall tgt _ _ _ _) = foldSlotsUsed f z tgt - last (LastCondBranch e _ _) = foldSlotsUsed f z e - last (LastSwitch e _tbl) = foldSlotsUsed f z e - -instance UserOfSlots l => UserOfSlots (ZLast l) where - foldSlotsUsed f z (LastOther l) = foldSlotsUsed f z l - foldSlotsUsed _ z LastExit = z - -instance DefinerOfSlots Middle where - foldSlotsDefd f z m = middle m - where middle (MidComment {}) = z - middle (MidAssign _ _) = z - middle (MidForeignCall {}) = z - middle (MidStore (CmmStackSlot a i) e) = - f z (a, i, widthInBytes $ typeWidth $ cmmExprType e) - middle (MidStore _ _) = z - -instance DefinerOfSlots Last where - foldSlotsDefd _ z _ = z - -instance DefinerOfSlots l => DefinerOfSlots (ZLast l) where - foldSlotsDefd f z (LastOther l) = foldSlotsDefd f z l - foldSlotsDefd _ z LastExit = z - ----------------------------------------------------------------------- ------ Code for manipulating Middle and Last nodes - -mapExpMiddle :: (CmmExpr -> CmmExpr) -> Middle -> Middle -mapExpMiddle _ m@(MidComment _) = m -mapExpMiddle exp (MidAssign r e) = MidAssign r (exp e) -mapExpMiddle exp (MidStore addr e) = MidStore (exp addr) (exp e) -mapExpMiddle exp (MidForeignCall s tgt fs as) = - MidForeignCall s (mapExpMidcall exp tgt) fs (map exp as) - -foldExpMiddle :: (CmmExpr -> z -> z) -> Middle -> z -> z -foldExpMiddle _ (MidComment _) z = z -foldExpMiddle exp (MidAssign _ e) z = exp e z -foldExpMiddle exp (MidStore addr e) z = exp addr $ exp e z -foldExpMiddle exp (MidForeignCall _ tgt _ as) z = foldExpMidcall exp tgt $ foldr exp z as - -mapExpLast :: (CmmExpr -> CmmExpr) -> Last -> Last -mapExpLast _ l@(LastBranch _) = l -mapExpLast exp (LastCondBranch e ti fi) = LastCondBranch (exp e) ti fi -mapExpLast exp (LastSwitch e tbl) = LastSwitch (exp e) tbl -mapExpLast exp (LastCall tgt mb_id o i s) = LastCall (exp tgt) mb_id o i s - -foldExpLast :: (CmmExpr -> z -> z) -> Last -> z -> z -foldExpLast _ (LastBranch _) z = z -foldExpLast exp (LastCondBranch e _ _) z = exp e z -foldExpLast exp (LastSwitch e _) z = exp e z -foldExpLast exp (LastCall tgt _ _ _ _) z = exp tgt z - -mapExpMidcall :: (CmmExpr -> CmmExpr) -> MidCallTarget -> MidCallTarget -mapExpMidcall exp (ForeignTarget e c) = ForeignTarget (exp e) c -mapExpMidcall _ m@(PrimTarget _) = m - -foldExpMidcall :: (CmmExpr -> z -> z) -> MidCallTarget -> z -> z -foldExpMidcall exp (ForeignTarget e _) z = exp e z -foldExpMidcall _ (PrimTarget _) z = z - --- Take a transformer on expressions and apply it recursively. -wrapRecExp :: (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr -wrapRecExp f (CmmMachOp op es) = f (CmmMachOp op $ map (wrapRecExp f) es) -wrapRecExp f (CmmLoad addr ty) = f (CmmLoad (wrapRecExp f addr) ty) -wrapRecExp f e = f e - -mapExpDeepMiddle :: (CmmExpr -> CmmExpr) -> Middle -> Middle -mapExpDeepLast :: (CmmExpr -> CmmExpr) -> Last -> Last -mapExpDeepMiddle f = mapExpMiddle $ wrapRecExp f -mapExpDeepLast f = mapExpLast $ wrapRecExp f - --- Take a folder on expressions and apply it recursively. -wrapRecExpf :: (CmmExpr -> z -> z) -> CmmExpr -> z -> z -wrapRecExpf f e@(CmmMachOp _ es) z = foldr (wrapRecExpf f) (f e z) es -wrapRecExpf f e@(CmmLoad addr _) z = wrapRecExpf f addr (f e z) -wrapRecExpf f e z = f e z - -foldExpDeepMiddle :: (CmmExpr -> z -> z) -> Middle -> z -> z -foldExpDeepLast :: (CmmExpr -> z -> z) -> Last -> z -> z -foldExpDeepMiddle f = foldExpMiddle $ wrapRecExpf f -foldExpDeepLast f = foldExpLast $ wrapRecExpf f - ----------------------------------------------------------------------- --- Compute the join of facts live out of a Last node. Useful for most backward --- analyses. -joinOuts :: DataflowLattice a -> (BlockId -> a) -> Last -> a -joinOuts lattice env l = - let bot = fact_bot lattice - join x y = txVal $ fact_add_to lattice x y - in case l of - (LastBranch id) -> env id - (LastCall _ Nothing _ _ _) -> bot - (LastCall _ (Just k) _ _ _) -> env k - (LastCondBranch _ t f) -> join (env t) (env f) - (LastSwitch _ tbl) -> foldr join bot (map env $ catMaybes tbl) - ----------------------------------------------------------------------- ------ Instance declarations for prettyprinting (avoids recursive imports) - -instance Outputable Middle where - ppr s = pprMiddle s - -instance Outputable Last where - ppr s = pprLast s - -instance Outputable Convention where - ppr = pprConvention - -instance Outputable ForeignConvention where - ppr = pprForeignConvention - -instance Outputable ValueDirection where - ppr Arguments = ptext $ sLit "args" - ppr Results = ptext $ sLit "results" - -instance DF.DebugNodes Middle Last - -debugPpr :: Bool -debugPpr = debugIsOn - -pprMiddle :: Middle -> SDoc -pprMiddle stmt = pp_stmt <+> pp_debug - where - pp_stmt = case stmt of - -- // text - MidComment s -> text "//" <+> ftext s - - -- reg = expr; - MidAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi - - -- rep[lv] = expr; - MidStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi - where - rep = ppr ( cmmExprType expr ) - - -- call "ccall" foo(x, y)[r1, r2]; - -- ToDo ppr volatile - MidForeignCall safety target results args -> - hsep [ ppUnless (null results) $ - parens (commafy $ map ppr results) <+> equals, - ppr_safety safety, - ptext $ sLit "call", - ppr_call_target target <> parens (commafy $ map ppr args) <> semi] - - pp_debug = - if not debugPpr then empty - else text " //" <+> - case stmt of - MidComment {} -> text "MidComment" - MidAssign {} -> text "MidAssign" - MidStore {} -> text "MidStore" - MidForeignCall {} -> text "MidForeignCall" - -ppr_fc :: ForeignConvention -> SDoc -ppr_fc (ForeignConvention c args res) = - doubleQuotes (ppr c) <+> text "args: " <+> ppr args <+> text " results: " <+> ppr res - -ppr_safety :: ForeignSafety -> SDoc -ppr_safety (Safe bid upd) = text "safe<" <> ppr bid <> text ", " <> ppr upd <> text ">" -ppr_safety Unsafe = text "unsafe" - -ppr_call_target :: MidCallTarget -> SDoc -ppr_call_target (ForeignTarget fn c) = ppr_fc c <+> ppr_target fn -ppr_call_target (PrimTarget op) - -- HACK: We're just using a ForeignLabel to get this printed, the label - -- might not really be foreign. - = ppr (CmmLabel (mkForeignLabel - (mkFastString (show op)) - Nothing ForeignLabelInThisPackage IsFunction)) - -ppr_target :: CmmExpr -> SDoc -ppr_target t@(CmmLit _) = ppr t -ppr_target fn' = parens (ppr fn') - -pprHinted :: Outputable a => CmmHinted a -> SDoc -pprHinted (CmmHinted a NoHint) = ppr a -pprHinted (CmmHinted a AddrHint) = doubleQuotes (text "address") <+> ppr a -pprHinted (CmmHinted a SignedHint) = doubleQuotes (text "signed") <+> ppr a - -pprLast :: Last -> SDoc -pprLast stmt = pp_stmt <+> pp_debug - where - pp_stmt = case stmt of - LastBranch ident -> ptext (sLit "goto") <+> ppr ident <> semi - LastCondBranch expr t f -> genFullCondBranch expr t f - LastSwitch arg ids -> ppr $ CmmSwitch arg ids - LastCall tgt k out res updfr_off -> genBareCall tgt k out res updfr_off - - pp_debug = text " //" <+> case stmt of - LastBranch {} -> text "LastBranch" - LastCondBranch {} -> text "LastCondBranch" - LastSwitch {} -> text "LastSwitch" - LastCall {} -> text "LastCall" - -genBareCall :: CmmExpr -> Maybe BlockId -> ByteOff -> ByteOff -> - Maybe UpdFrameOffset -> SDoc -genBareCall fn k out res updfr_off = - hcat [ ptext (sLit "call"), space - , pprFun fn, ptext (sLit "(...)"), space - , ptext (sLit "returns to") <+> ppr k <+> parens (ppr out) - <+> parens (ppr res) - , ptext (sLit " with update frame") <+> ppr updfr_off - , semi ] - -pprFun :: CmmExpr -> SDoc -pprFun f@(CmmLit _) = ppr f -pprFun f = parens (ppr f) - -genFullCondBranch :: Outputable id => CmmExpr -> id -> id -> SDoc -genFullCondBranch expr t f = - hsep [ ptext (sLit "if") - , parens(ppr expr) - , ptext (sLit "goto") - , ppr t <> semi - , ptext (sLit "else goto") - , ppr f <> semi - ] - -pprConvention :: Convention -> SDoc -pprConvention (NativeNodeCall {}) = text "" -pprConvention (NativeDirectCall {}) = text "" -pprConvention (NativeReturn {}) = text "" -pprConvention Slow = text "" -pprConvention GC = text "" -pprConvention PrimOpCall = text "" -pprConvention PrimOpReturn = text "" -pprConvention (Foreign c) = ppr c -pprConvention (Private {}) = text "" - -pprForeignConvention :: ForeignConvention -> SDoc -pprForeignConvention (ForeignConvention c as rs) = ppr c <> ppr as <> ppr rs - -commafy :: [SDoc] -> SDoc -commafy xs = hsep $ punctuate comma xs diff -Nru ghc-7.0.3/compiler/cmm/ZipCfgExtras.hs ghc-7.2.1/compiler/cmm/ZipCfgExtras.hs --- ghc-7.0.3/compiler/cmm/ZipCfgExtras.hs 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/cmm/ZipCfgExtras.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,76 +0,0 @@ -{-# OPTIONS -Wall -fno-warn-name-shadowing #-} - --- This module contains code related to the zipcfg representation. --- The code either has been used or has been thought to be useful --- within the Quick C-- compiler, but as yet no use has been found for --- it within GHC. This module should therefore be considered to be --- full of code that need not be maintained. Should a function in --- this module prove useful, it should not be exported, but rather --- should be migrated back into ZipCfg (or possibly ZipCfgUtil), where --- it can be maintained. - -module ZipCfgExtras - () -where -import BlockId -import Maybes -import Panic -import ZipCfg - -import Prelude hiding (zip, unzip, last) - - -exit :: LGraph m l -> FGraph m l -- focus on edge into default exit node - -- (fails if there isn't one) -focusp :: (Block m l -> Bool) -> LGraph m l -> Maybe (FGraph m l) - -- focus on start of block satisfying predicate --- unfocus :: FGraph m l -> LGraph m l -- lose focus - --- | We can insert a single-entry, single-exit subgraph at --- the current focus. --- The new focus can be at either the entry edge or the exit edge. - -{- -splice_focus_entry :: FGraph m l -> LGraph m l -> FGraph m l -splice_focus_exit :: FGraph m l -> LGraph m l -> FGraph m l --} - -_unused :: () -_unused = all `seq` () - where all = ( exit, focusp --, unfocus {- , splice_focus_entry, splice_focus_exit -} - , foldM_fwd_block (\_ a -> Just a) - ) - ---unfocus (FGraph e bz bs) = LGraph e (insertBlock (zip bz) bs) - -focusp p (LGraph entry blocks) = - fmap (\(b, bs) -> FGraph entry (unzip b) bs) (splitp_blocks p blocks) - -exit g@(LGraph eid _) = FGraph eid (ZBlock h (ZLast l)) others - where FGraph _ b others = focusp is_exit g `orElse` panic "no exit in flow graph" - (h, l) = goto_end b - - -{- -splice_focus_entry (FGraph eid (ZBlock head tail) blocks) g = - let (tail', g') = splice_tail g tail in - FGraph eid (ZBlock head tail') (plusUFM (lg_blocks g') blocks) - -splice_focus_exit (FGraph eid (ZBlock head tail) blocks) g = - let (g', head') = splice_head head g in - FGraph eid (ZBlock head' tail) (plusUFM (lg_blocks g') blocks) --} - --- | iterate from first to last -foldM_fwd_block :: - Monad m => (BlockId -> a -> m a) -> (mid -> a -> m a) -> (ZLast l -> a -> m a) -> - Block mid l -> a -> m a -foldM_fwd_block first middle last (Block id t) z = do { z <- first id z; tail t z } - where tail (ZTail m t) z = do { z <- middle m z; tail t z } - tail (ZLast l) z = last l z - -splitp_blocks :: (Block m l -> Bool) -> BlockEnv (Block m l) -> - Maybe (Block m l, BlockEnv (Block m l)) -splitp_blocks = panic "splitp_blocks" -- implemented in ZipCfg but not exported -is_exit :: Block m l -> Bool -is_exit = panic "is_exit" -- implemented in ZipCfg but not exported diff -Nru ghc-7.0.3/compiler/cmm/ZipCfg.hs ghc-7.2.1/compiler/cmm/ZipCfg.hs --- ghc-7.0.3/compiler/cmm/ZipCfg.hs 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/cmm/ZipCfg.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,705 +0,0 @@ -module ZipCfg - ( -- These data types and names are carefully thought out - Graph(..), LGraph(..), FGraph(..) - , Block(..), ZBlock(..), ZHead(..), ZTail(..), ZLast(..) - , insertBlock - , HavingSuccessors, succs, fold_succs - , LastNode, mkBranchNode, isBranchNode, branchNodeTarget - - -- Observers and transformers - -- (open to renaming suggestions here) - , blockId, zip, unzip, last, goto_end, zipht, tailOfLast - , splice_tail, splice_head, splice_head_only', splice_head' - , of_block_list, to_block_list - , graphOfLGraph - , map_blocks, map_one_block, map_nodes, mapM_blocks - , postorder_dfs, postorder_dfs_from, postorder_dfs_from_except - , fold_layout - , fold_blocks, fold_fwd_block - , translate - - , pprLgraph, pprGraph - - , entry -- exported for the convenience of ZipDataflow0, at least for now - - {- - -- the following functions might one day be useful and can be found - -- either below or in ZipCfgExtras: - , entry, exit, focus, focusp, unfocus - , ht_to_block, ht_to_last, - , splice_focus_entry, splice_focus_exit - , foldM_fwd_block - -} - - ) -where - -#include "HsVersions.h" - -import BlockId ( BlockId, BlockEnv, emptyBlockEnv, lookupBlockEnv, extendBlockEnv - , BlockSet, emptyBlockSet, unitBlockSet, elemBlockSet, extendBlockSet - , delFromBlockEnv, foldBlockEnv', mapBlockEnv - , eltsBlockEnv, isNullBEnv, plusBlockEnv) -import CmmExpr ( UserOfLocalRegs(..) ) -import PprCmm() - -import Outputable hiding (empty) - -import Data.Maybe -import Prelude hiding (zip, unzip, last) - -------------------------------------------------------------------------- --- GENERIC ZIPPER-BASED CONTROL-FLOW GRAPH -- -------------------------------------------------------------------------- -{- - -This module defines datatypes used to represent control-flow graphs, -along with some functions for analyzing and splicing graphs. -Functions for building graphs are found in a separate module 'MkZipCfg'. - -Every graph has a distinguished entry point. A graph has at least one -exit; most exits are instructions (or statements) like 'jump' or -'return', which transfer control to other procedures, but a graph may -have up to one 'fall through' exit. (A graph that represents an -entire Haskell or C-- procedure does not have a 'fall through' exit.) - -A graph is a collection of basic blocks. A basic block begins with a -label (unique id; see Note [Unique BlockId]) which is followed by a -sequence of zero or more 'middle' nodes; the basic block ends with a -'last' node. Each 'middle' node is a single-entry, single-exit, -uninterruptible computation. A 'last' node is a single-entry, -multiple-exit computation. A last node may have zero or more successors, -which are identified by their unique ids. - -A special case of last node is the ``default exit,'' which represents -'falling off the end' of the graph. Such a node is always represented by -the data constructor 'LastExit'. A graph may contain at most one -'LastExit' node, and a graph representing a full procedure should not -contain any 'LastExit' nodes. 'LastExit' nodes are used only to splice -graphs together, either during graph construction (see module 'MkZipCfg') -or during optimization (see module 'ZipDataflow'). - -A graph is parameterized over the types of middle and last nodes. Each of -these types will typically be instantiated with a subset of C-- statements -(see module 'ZipCfgCmmRep') or a subset of machine instructions (yet to be -implemented as of August 2007). - - -Note [Kinds of Graphs] -~~~~~~~~~~~~~~~~~~~~~~ -This module exposes three representations of graphs. In order of -increasing complexity, they are: - - Graph m l The basic graph with its distinguished entry point - - LGraph m l A graph with a *labelled* entry point - - FGraph m l A labelled graph with the *focus* on a particular edge - -There are three types because each type offers a slightly different -invariant or cost model. - - * The distinguished entry of a Graph has no label. Because labels must be - unique, acquiring one requires a supply of Unique labels (BlockId's). - The primary advantage of the Graph representation is that we can build a - small Graph purely functionally, without needing a fresh BlockId or - Unique. For example, during optimization we can easily rewrite a single - middle node into a Graph containing a sequence of two middle nodes - followed by LastExit. - - * In an LGraph, every basic block is labelled. The primary advantage of - this representation is its simplicity: each basic block can be treated - like any other. This representation is used for mapping, folding, and - translation, as well as layout. - - Like any graph, an LGraph still has a distinguished entry point, - which you can discover using 'lg_entry'. - - * An FGraph is an LGraph with the *focus* on one particular edge. The - primary advantage of this representation is that it provides - constant-time access to the nodes connected by that edge, and it also - allows constant-time, functional *replacement* of those nodes---in the - style of Huet's 'zipper'. - -None of these representations is ideally suited to the incremental -construction of large graphs. A separate module, 'MkZipCfg', provides a -fourth representation that is asymptotically optimal for such construction. - --} - ---------------- Representation -------------------- - --- | A basic block is a 'first' node, followed by zero or more 'middle' --- nodes, followed by a 'last' node. - --- eventually this module should probably replace the original Cmm, but for --- now we leave it to dynamic invariants what can be found where - -data ZLast l - = LastExit -- fall through; used for the block that has no last node - -- LastExit is a device used only for graphs under - -- construction, or framgments of graph under optimisation, - -- so we don't want to pollute the 'l' type parameter with it - | LastOther l - ---So that we don't have orphan instances, this goes here or in CmmExpr. ---At least UserOfLocalRegs (ZLast Last) is needed (Last defined elsewhere), ---but there's no need for non-Haskell98 instances for that. -instance UserOfLocalRegs a => UserOfLocalRegs (ZLast a) where - foldRegsUsed f z (LastOther l) = foldRegsUsed f z l - foldRegsUsed _f z LastExit = z - - -data ZHead m = ZFirst BlockId - | ZHead (ZHead m) m - -- ZHead is a (reversed) sequence of middle nodes labeled by a BlockId -data ZTail m l = ZLast (ZLast l) | ZTail m (ZTail m l) - -- ZTail is a sequence of middle nodes followed by a last node - --- | Blocks and flow graphs; see Note [Kinds of graphs] - -data Block m l = Block { bid :: BlockId - , tail :: ZTail m l } - -data Graph m l = Graph { g_entry :: (ZTail m l), g_blocks :: (BlockEnv (Block m l)) } - -data LGraph m l = LGraph { lg_entry :: BlockId - , lg_blocks :: BlockEnv (Block m l)} - -- Invariant: lg_entry is in domain( lg_blocks ) - --- | And now the zipper. The focus is between the head and tail. --- We cannot ever focus on an inter-block edge. -data ZBlock m l = ZBlock (ZHead m) (ZTail m l) -data FGraph m l = FGraph { fg_entry :: BlockId - , fg_focus :: ZBlock m l - , fg_others :: BlockEnv (Block m l) } - -- Invariant: the block represented by 'fg_focus' is *not* - -- in the map 'fg_others' - ----- Utility functions --- - -blockId :: Block m l -> BlockId -zip :: ZBlock m l -> Block m l -unzip :: Block m l -> ZBlock m l - -last :: ZBlock m l -> ZLast l -goto_end :: ZBlock m l -> (ZHead m, ZLast l) - -tailOfLast :: l -> ZTail m l - --- | Take a head and tail and go to beginning or end. The asymmetry --- in the types and names is a bit unfortunate, but 'Block m l' is --- effectively '(BlockId, ZTail m l)' and is accepted in many more places. - -ht_to_block, zipht :: ZHead m -> ZTail m l -> Block m l -ht_to_last :: ZHead m -> ZTail m l -> (ZHead m, ZLast l) - --- | We can splice a single-entry, single-exit LGraph onto a head or a tail. --- For a head, we have a head 'h' followed by a LGraph 'g'. --- The entry node of 'g' gets joined to 'h', forming the entry into --- the new LGraph. The exit of 'g' becomes the new head. --- For both arguments and results, the order of values is the order of --- control flow: before splicing, the head flows into the LGraph; after --- splicing, the LGraph flows into the head. --- Splicing a tail is the dual operation. --- (In order to maintain the order-means-control-flow convention, the --- orders are reversed.) --- --- For example, assume --- head = [L: x:=0] --- grph = (M, [M: , --- , --- N: y:=x; LastExit]) --- tail = [return (y,x)] --- --- Then splice_head head grph --- = ((L, [L: x:=0; goto M, --- M: , --- ]) --- , N: y:=x) --- --- Then splice_tail grph tail --- = ( --- , (???, [, --- N: y:=x; return (y,x)]) - -splice_head :: ZHead m -> LGraph m l -> (LGraph m l, ZHead m) -splice_head' :: ZHead m -> Graph m l -> (BlockEnv (Block m l), ZHead m) -splice_tail :: Graph m l -> ZTail m l -> Graph m l - --- | We can also splice a single-entry, no-exit Graph into a head. -splice_head_only :: ZHead m -> LGraph m l -> LGraph m l -splice_head_only' :: ZHead m -> Graph m l -> LGraph m l - - --- | A safe operation - --- | Conversion to and from the environment form is convenient. For --- layout or dataflow, however, one will want to use 'postorder_dfs' --- in order to get the blocks in an order that relates to the control --- flow in the procedure. -of_block_list :: BlockId -> [Block m l] -> LGraph m l -- N log N -to_block_list :: LGraph m l -> [Block m l] -- N log N - --- | Conversion from LGraph to Graph -graphOfLGraph :: LastNode l => LGraph m l -> Graph m l -graphOfLGraph (LGraph eid blocks) = Graph (ZLast $ mkBranchNode eid) blocks - - --- | Traversal: 'postorder_dfs' returns a list of blocks reachable --- from the entry node. This list has the following property: --- --- Say a "back reference" exists if one of a block's --- control-flow successors precedes it in the output list --- --- Then there are as few back references as possible --- --- The output is suitable for use in --- a forward dataflow problem. For a backward problem, simply reverse --- the list. ('postorder_dfs' is sufficiently tricky to implement that --- one doesn't want to try and maintain both forward and backward --- versions.) - -postorder_dfs :: LastNode l => LGraph m l -> [Block m l] - --- | For layout, we fold over pairs of 'Block m l' and 'Maybe BlockId' --- in layout order. The 'Maybe BlockId', if present, identifies the --- block that will be the layout successor of the current block. This --- may be useful to help an emitter omit the final 'goto' of a block --- that flows directly to its layout successor. --- --- For example: fold_layout f z [ L1:B1, L2:B2, L3:B3 ] --- = z <$> f (L1:B1) (Just L2) --- <$> f (L2:B2) (Just L3) --- <$> f (L3:B3) Nothing --- where a <$> f = f a -fold_layout :: - LastNode l => (Block m l -> Maybe BlockId -> a -> a) -> a -> LGraph m l-> a - --- | We can also fold over blocks in an unspecified order. The --- 'ZipCfgExtras' module provides a monadic version, which we --- haven't needed (else it would be here). -fold_blocks :: (Block m l -> a -> a) -> a -> LGraph m l -> a - --- | Fold from first to last -fold_fwd_block :: (BlockId -> a -> a) -> (m -> a -> a) -> - (ZLast l -> a -> a) -> Block m l -> a -> a - -map_one_block :: (BlockId -> BlockId) -> (m -> m') -> (l -> l') -> Block m l -> Block m' l' - -map_nodes :: (BlockId -> BlockId) -> (m -> m') -> (l -> l') -> LGraph m l -> LGraph m' l' - -- mapping includes the entry id! - -map_blocks :: (Block m l -> Block m' l') -> LGraph m l -> LGraph m' l' -mapM_blocks :: Monad mm - => (Block m l -> mm (Block m' l')) -> LGraph m l -> mm (LGraph m' l') - --- | These translation functions are speculative. I hope eventually --- they will be used in the native-code back ends ---NR -translate :: Monad tm => - (m -> tm (LGraph m' l')) -> - (l -> tm (LGraph m' l')) -> - (LGraph m l -> tm (LGraph m' l')) - -{- --- | It's possible that another form of translation would be more suitable: -translateA :: (m -> Agraph m' l') -> (l -> AGraph m' l') -> LGraph m l -> LGraph m' l' --} - -------------------- Last nodes - --- | We can't make a graph out of just any old 'last node' type. A last node --- has to be able to find its successors, and we need to be able to create and --- identify unconditional branches. We put these capabilities in a type class. --- Moreover, the property of having successors is also shared by 'Block's and --- 'ZTails', so it is useful to have that property in a type class of its own. - -class HavingSuccessors b where - succs :: b -> [BlockId] - fold_succs :: (BlockId -> a -> a) -> b -> a -> a - - fold_succs add l z = foldr add z $ succs l - -class HavingSuccessors l => LastNode l where - mkBranchNode :: BlockId -> l - isBranchNode :: l -> Bool - branchNodeTarget :: l -> BlockId -- panics if not branch node - -- ^ N.B. This interface seems to make for more congenial clients than a - -- single function of type 'l -> Maybe BlockId' - -instance HavingSuccessors l => HavingSuccessors (ZLast l) where - succs LastExit = [] - succs (LastOther l) = succs l - fold_succs _ LastExit z = z - fold_succs f (LastOther l) z = fold_succs f l z - -instance LastNode l => LastNode (ZLast l) where - mkBranchNode id = LastOther $ mkBranchNode id - isBranchNode LastExit = False - isBranchNode (LastOther l) = isBranchNode l - branchNodeTarget LastExit = panic "branchNodeTarget LastExit" - branchNodeTarget (LastOther l) = branchNodeTarget l - -instance LastNode l => HavingSuccessors (ZBlock m l) where - succs b = succs (last b) - -instance LastNode l => HavingSuccessors (Block m l) where - succs b = succs (unzip b) - -instance LastNode l => HavingSuccessors (ZTail m l) where - succs b = succs (lastTail b) - - - --- ================ IMPLEMENTATION ================-- - ------ block manipulations - -blockId (Block id _) = id - --- | Convert block between forms. --- These functions are tail-recursive, so we can go as deep as we like --- without fear of stack overflow. - -ht_to_block head tail = case head of - ZFirst id -> Block id tail - ZHead h m -> ht_to_block h (ZTail m tail) - -ht_to_last head (ZLast l) = (head, l) -ht_to_last head (ZTail m t) = ht_to_last (ZHead head m) t - -zipht h t = ht_to_block h t -zip (ZBlock h t) = ht_to_block h t -goto_end (ZBlock h t) = ht_to_last h t - -unzip (Block id t) = ZBlock (ZFirst id) t - -head_id :: ZHead m -> BlockId -head_id (ZFirst id) = id -head_id (ZHead h _) = head_id h - -last (ZBlock _ t) = lastTail t - -lastTail :: ZTail m l -> ZLast l -lastTail (ZLast l) = l -lastTail (ZTail _ t) = lastTail t - -tailOfLast l = ZLast (LastOther l) -- tedious to write in every client - - ------------------- simple graph manipulations - -focus :: BlockId -> LGraph m l -> FGraph m l -- focus on edge out of node with id -focus id (LGraph entry blocks) = - case lookupBlockEnv blocks id of - Just b -> FGraph entry (unzip b) (delFromBlockEnv blocks id) - Nothing -> panic "asked for nonexistent block in flow graph" - -entry :: LGraph m l -> FGraph m l -- focus on edge out of entry node -entry g@(LGraph eid _) = focus eid g - --- | pull out a block satisfying the predicate, if any -splitp_blocks :: (Block m l -> Bool) -> BlockEnv (Block m l) -> - Maybe (Block m l, BlockEnv (Block m l)) -splitp_blocks p blocks = lift $ foldBlockEnv' scan (Nothing, emptyBlockEnv) blocks - where scan b (yes, no) = - case yes of - Nothing | p b -> (Just b, no) - | otherwise -> (yes, insertBlock b no) - Just _ -> (yes, insertBlock b no) - lift (Nothing, _) = Nothing - lift (Just b, bs) = Just (b, bs) - --- | 'insertBlock' should not be used to /replace/ an existing block --- but only to insert a new one -insertBlock :: Block m l -> BlockEnv (Block m l) -> BlockEnv (Block m l) -insertBlock b bs = - ASSERT (isNothing $ lookupBlockEnv bs id) - extendBlockEnv bs id b - where id = blockId b - --- | Used in assertions; tells if a graph has exactly one exit -single_exit :: LGraph l m -> Bool -single_exit g = foldBlockEnv' check 0 (lg_blocks g) == 1 - where check block count = case last (unzip block) of - LastExit -> count + (1 :: Int) - _ -> count - --- | Used in assertions; tells if a graph has exactly one exit -single_exitg :: Graph l m -> Bool -single_exitg (Graph tail blocks) = foldBlockEnv' add (exit_count (lastTail tail)) blocks == 1 - where add block count = count + exit_count (last (unzip block)) - exit_count LastExit = 1 :: Int - exit_count _ = 0 - ------------------- graph traversals - --- | This is the most important traversal over this data structure. It drops --- unreachable code and puts blocks in an order that is good for solving forward --- dataflow problems quickly. The reverse order is good for solving backward --- dataflow problems quickly. The forward order is also reasonably good for --- emitting instructions, except that it will not usually exploit Forrest --- Baskett's trick of eliminating the unconditional branch from a loop. For --- that you would need a more serious analysis, probably based on dominators, to --- identify loop headers. --- --- The ubiquity of 'postorder_dfs' is one reason for the ubiquity of the 'LGraph' --- representation, when for most purposes the plain 'Graph' representation is --- more mathematically elegant (but results in more complicated code). --- --- Here's an easy way to go wrong! Consider --- @ --- A -> [B,C] --- B -> D --- C -> D --- @ --- Then ordinary dfs would give [A,B,D,C] which has a back ref from C to D. --- Better to get [A,B,C,D] - - -postorder_dfs g@(LGraph _ blockenv) = - let FGraph id eblock _ = entry g in - zip eblock : postorder_dfs_from_except blockenv eblock (unitBlockSet id) - -postorder_dfs_from_except :: forall m b l. (HavingSuccessors b, LastNode l) - => BlockEnv (Block m l) -> b -> BlockSet -> [Block m l] -postorder_dfs_from_except blocks b visited - = vchildren (get_children b) (\acc _visited -> acc) [] visited - where - vnode :: Block m l -> ([Block m l] -> BlockSet -> a) - -> [Block m l] -> BlockSet -> a - vnode block@(Block id _) cont acc visited = - if elemBlockSet id visited then - cont acc visited - else - let cont' acc visited = cont (block:acc) visited in - vchildren (get_children block) cont' acc (extendBlockSet visited id) - - vchildren :: [Block m l] -> ([Block m l] -> BlockSet -> a) - -> [Block m l] -> BlockSet -> a - vchildren bs cont acc visited = - let next children acc visited = - case children of [] -> cont acc visited - (b:bs) -> vnode b (next bs) acc visited - in next bs acc visited - - get_children :: HavingSuccessors c => c -> [Block m l] - get_children block = foldl add_id [] (succs block) - - add_id :: [Block m l] -> BlockId -> [Block m l] - add_id rst id = case lookupBlockEnv blocks id of - Just b -> b : rst - Nothing -> rst - -postorder_dfs_from - :: (HavingSuccessors b, LastNode l) => BlockEnv (Block m l) -> b -> [Block m l] -postorder_dfs_from blocks b = postorder_dfs_from_except blocks b emptyBlockSet - - - --- | Slightly more complicated than the usual fold because we want to tell block --- 'b1' what its inline successor is going to be, so that if 'b1' ends with --- 'goto b2', the goto can be omitted. - -fold_layout f z g@(LGraph eid _) = fold (postorder_dfs g) z - where fold blocks z = - case blocks of [] -> z - [b] -> f b Nothing z - b1 : b2 : bs -> fold (b2 : bs) (f b1 (nextlabel b2) z) - nextlabel (Block id _) = - if id == eid then panic "entry as successor" - else Just id - --- | The rest of the traversals are straightforward - -map_blocks f (LGraph eid blocks) = LGraph eid (mapBlockEnv f blocks) - -map_nodes idm middle last (LGraph eid blocks) = - LGraph (idm eid) (mapBlockEnv (map_one_block idm middle last) blocks) - -map_one_block idm middle last (Block id t) = Block (idm id) (tail t) - where tail (ZTail m t) = ZTail (middle m) (tail t) - tail (ZLast LastExit) = ZLast LastExit - tail (ZLast (LastOther l)) = ZLast (LastOther (last l)) - - -mapM_blocks f (LGraph eid blocks) = blocks' >>= return . LGraph eid - where blocks' = - foldBlockEnv' (\b mblocks -> do { blocks <- mblocks - ; b <- f b - ; return $ insertBlock b blocks }) - (return emptyBlockEnv) blocks - -fold_blocks f z (LGraph _ blocks) = foldBlockEnv' f z blocks -fold_fwd_block first middle last (Block id t) z = tail t (first id z) - where tail (ZTail m t) z = tail t (middle m z) - tail (ZLast l) z = last l z - -of_block_list e blocks = LGraph e $ foldr insertBlock emptyBlockEnv blocks -to_block_list (LGraph _ blocks) = eltsBlockEnv blocks - - --- We want to be able to scrutinize a single-entry, single-exit 'LGraph' for --- splicing purposes. There are two useful cases: the 'LGraph' is a single block --- or it isn't. We use continuation-passing style. - -prepare_for_splicing :: - LGraph m l -> (ZTail m l -> a) -> (ZTail m l -> ZHead m -> BlockEnv (Block m l) -> a) - -> a -prepare_for_splicing g single multi = - let FGraph _ gentry gblocks = entry g - ZBlock _ etail = gentry - in if isNullBEnv gblocks then - case last gentry of - LastExit -> single etail - _ -> panic "bad single block" - else - case splitp_blocks is_exit gblocks of - Nothing -> panic "Can't find an exit block" - Just (gexit, gblocks) -> - let (gh, gl) = goto_end $ unzip gexit in - case gl of LastExit -> multi etail gh gblocks - _ -> panic "exit is not exit?!" - -prepare_for_splicing' :: - Graph m l -> (ZTail m l -> a) -> (ZTail m l -> ZHead m -> BlockEnv (Block m l) -> a) - -> a -prepare_for_splicing' (Graph etail gblocks) single multi = - if isNullBEnv gblocks then - case lastTail etail of - LastExit -> single etail - _ -> panic "bad single block" - else - case splitp_blocks is_exit gblocks of - Nothing -> panic "Can't find an exit block" - Just (gexit, gblocks) -> - let (gh, gl) = goto_end $ unzip gexit in - case gl of LastExit -> multi etail gh gblocks - _ -> panic "exit is not exit?!" - -is_exit :: Block m l -> Bool -is_exit b = case last (unzip b) of { LastExit -> True; _ -> False } - -splice_head head g@(LGraph _ _) = - ASSERT (single_exit g) prepare_for_splicing g splice_one_block splice_many_blocks - where eid = head_id head - splice_one_block tail' = - case ht_to_last head tail' of - (head, LastExit) -> (LGraph eid emptyBlockEnv, head) - _ -> panic "spliced LGraph without exit" - splice_many_blocks entry exit others = - (LGraph eid (insertBlock (zipht head entry) others), exit) - -splice_head' head g = - ASSERT (single_exitg g) prepare_for_splicing' g splice_one_block splice_many_blocks - where splice_one_block tail' = - case ht_to_last head tail' of - (head, LastExit) -> (emptyBlockEnv, head) - _ -> panic "spliced LGraph without exit" - splice_many_blocks entry exit others = - (insertBlock (zipht head entry) others, exit) - --- splice_tail :: Graph m l -> ZTail m l -> Graph m l -splice_tail g tail = - ASSERT (single_exitg g) prepare_for_splicing' g splice_one_block splice_many_blocks - where splice_one_block tail' = Graph (tail' `append_tails` tail) emptyBlockEnv - append_tails (ZLast LastExit) tail = tail - append_tails (ZLast _) _ = panic "spliced single block without LastExit" - append_tails (ZTail m t) tail = ZTail m (append_tails t tail) - splice_many_blocks entry exit others = - Graph entry (insertBlock (zipht exit tail) others) - -{- -splice_tail g tail = - AS SERT (single_exit g) prepare_for_splicing g splice_one_block splice_many_blocks - where splice_one_block tail' = -- return tail' .. tail - case ht_to_last (ZFirst (lg_entry g)) tail' of - (head', LastExit) -> - case ht_to_block head' tail of - Block id t | id == lg_entry g -> (t, LGraph id emptyBlockEnv) - _ -> panic "entry in; garbage out" - _ -> panic "spliced single block without Exit" - splice_many_blocks entry exit others = - (entry, LGraph (lg_entry g) (insertBlock (zipht exit tail) others)) --} - -splice_head_only head g = - let FGraph eid gentry gblocks = entry g - in case gentry of - ZBlock (ZFirst _) tail -> - LGraph eid (insertBlock (zipht head tail) gblocks) - _ -> panic "entry not at start of block?!" - -splice_head_only' head (Graph tail gblocks) = - let eblock = zipht head tail in - LGraph (blockId eblock) (insertBlock eblock gblocks) - -- the offset probably should never be used, but well, it's correct for this LGraph - - ---- Translation - -translate txm txl (LGraph eid blocks) = - do blocks' <- foldBlockEnv' txblock (return emptyBlockEnv) blocks - return $ LGraph eid blocks' - where - -- txblock :: - -- Block m l -> tm (BlockEnv (Block m' l')) -> tm (BlockEnv (Block m' l')) - txblock (Block id t) expanded = - do blocks' <- expanded - txtail (ZFirst id) t blocks' - -- txtail :: ZHead m' -> ZTail m l -> BlockEnv (Block m' l') -> - -- tm (BlockEnv (Block m' l')) - txtail h (ZTail m t) blocks' = - do m' <- txm m - let (g, h') = splice_head h m' - txtail h' t (plusBlockEnv (lg_blocks g) blocks') - txtail h (ZLast (LastOther l)) blocks' = - do l' <- txl l - return $ plusBlockEnv (lg_blocks (splice_head_only h l')) blocks' - txtail h (ZLast LastExit) blocks' = - return $ insertBlock (zipht h (ZLast LastExit)) blocks' - ----------------------------------------------------------------- ----- Prettyprinting ----------------------------------------------------------------- - --- putting this code in PprCmmZ leads to circular imports :-( - -instance (Outputable m, Outputable l) => Outputable (ZTail m l) where - ppr = pprTail - -instance (Outputable m, Outputable l, LastNode l) => Outputable (Graph m l) where - ppr = pprGraph - -instance (Outputable m, Outputable l, LastNode l) => Outputable (LGraph m l) where - ppr = pprLgraph - -instance (Outputable m, Outputable l, LastNode l) => Outputable (Block m l) where - ppr = pprBlock - -instance (Outputable l) => Outputable (ZLast l) where - ppr = pprLast - -pprTail :: (Outputable m, Outputable l) => ZTail m l -> SDoc -pprTail (ZTail m t) = ppr m $$ ppr t -pprTail (ZLast l) = ppr l - -pprLast :: (Outputable l) => ZLast l -> SDoc -pprLast LastExit = text "" -pprLast (LastOther l) = ppr l - -pprBlock :: (Outputable m, Outputable l, LastNode l) => Block m l -> SDoc -pprBlock (Block id tail) = - ppr id <> colon - $$ (nest 3 (ppr tail)) - -pprLgraph :: (Outputable m, Outputable l, LastNode l) => LGraph m l -> SDoc -pprLgraph g = text "{" <> text "offset" $$ - nest 2 (vcat $ map ppr blocks) $$ text "}" - where blocks = postorder_dfs g - -pprGraph :: (Outputable m, Outputable l, LastNode l) => Graph m l -> SDoc -pprGraph (Graph tail blockenv) = - text "{" $$ nest 2 (ppr tail $$ (vcat $ map ppr blocks)) $$ text "}" - where blocks = postorder_dfs_from blockenv tail - diff -Nru ghc-7.0.3/compiler/cmm/ZipDataflow.hs ghc-7.2.1/compiler/cmm/ZipDataflow.hs --- ghc-7.0.3/compiler/cmm/ZipDataflow.hs 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/cmm/ZipDataflow.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,1064 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables, KindSignatures, - FlexibleContexts #-} - -module ZipDataflow - ( DebugNodes(), RewritingDepth(..), LastOutFacts(..) - , zdfSolveFrom, zdfRewriteFrom - , zdfSolveFromL - , ForwardTransfers(..), BackwardTransfers(..) - , ForwardRewrites(..), BackwardRewrites(..) - , ForwardFixedPoint, BackwardFixedPoint - , zdfFpFacts - , zdfFpOutputFact - , zdfGraphChanged - , zdfDecoratedGraph -- not yet implemented - , zdfFpContents - , zdfFpLastOuts - , zdfBRewriteFromL, zdfFRewriteFromL - ) -where - -import BlockId -import CmmTx -import DFMonad -import OptimizationFuel as F -import MkZipCfg -import ZipCfg -import qualified ZipCfg as G - -import Maybes -import Outputable - -import Control.Monad - -{- - -This module implements two useful tools: - - 1. An iterative solver for dataflow problems - - 2. The combined dataflow-analysis-and-transformation framework - described by Lerner, Grove, and Chambers in their excellent - 2002 POPL paper (http://tinyurl.com/3zycbr or - http://tinyurl.com/3pnscd). - -Each tool comes in two flavors: one for forward dataflow problems -and one for backward dataflow problems. - -We quote the paper above: - - Dataflow analyses can have mutually beneficial interactions. - Previous efforts to exploit these interactions have either - (1) iteratively performed each individual analysis until no - further improvements are discovered or (2) developed "super- - analyses" that manually combine conceptually separate anal- - yses. We have devised a new approach that allows anal- - yses to be defined independently while still enabling them - to be combined automatically and profitably. Our approach - avoids the loss of precision associated with iterating indi- - vidual analyses and the implementation difficulties of man- - ually writing a super-analysis. - -The key idea is to provide at each CFG node not only a dataflow -transfer function but also a rewriting function that has the option to -replace the node with a new (possibly empty) graph. The rewriting -function takes a dataflow fact as input, and the fact is used to -justify any rewriting. For example, in a backward problem, the fact -that variable x is dead can be used to justify rewriting node - x := e -to the empty graph. In a forward problem, the fact that x == 7 can -be used to justify rewriting node - y := x + 1 -to - y := 8 -which in turn will be analyzed and produce a new fact: -x == 7 and y == 8. - -In its most general form, this module takes as input graph, transfer -equations, rewrites, and an initial set of dataflow facts, and -iteratively computes a new graph and a new set of dataflow facts such -that - * The set of facts is a fixed point of the transfer equations - * The graph has been rewritten as much as is consistent with - the given facts and requested rewriting depth (see below) -N.B. 'A set of facts' is shorthand for 'A finite map from CFG label to fact'. - -The types of transfer equations, rewrites, and fixed points are -different for forward and backward problems. To avoid cluttering the -name space with two versions of every name, other names such as -zdfSolveFrom are overloaded to work in both forward or backward -directions. This design decision is based on experience with the -predecessor module, which has been mercifully deleted. - - -This module is deliberately very abstract. It is a completely general -framework and well-nigh impossible to understand in isolation. The -cautious reader will begin with some concrete examples in the form of -clients. NR recommends - - CmmLiveZ A simple liveness analysis - - CmmSpillReload.removeDeadAssignmentsAndReloads - A piece of spaghetti to pull on, which leads to - - a two-part liveness analysis that tracks - variables live in registers and live on the stack - - elimination of assignments to dead variables - - elimination of redundant reloads - -Even hearty souls should avoid the CmmProcPointZ client, at least for -the time being. - --} - - -{- ============ TRANSFER FUNCTIONS AND REWRITES =========== -} - --- | For a backward transfer, you're given the fact on a node's --- outedge and you compute the fact on the inedge. Facts have type 'a'. --- A last node may have multiple outedges, each pointing to a labelled --- block, so instead of a fact it is given a mapping from BlockId to fact. - -data BackwardTransfers middle last a = BackwardTransfers - { bt_first_in :: BlockId -> a -> a - , bt_middle_in :: middle -> a -> a - , bt_last_in :: last -> (BlockId -> a) -> a - } - --- | For a forward transfer, you're given the fact on a node's --- inedge and you compute the fact on the outedge. Because a last node --- may have multiple outedges, each pointing to a labelled --- block, so instead of a fact it produces a list of (BlockId, fact) pairs. - -data ForwardTransfers middle last a = ForwardTransfers - { ft_first_out :: BlockId -> a -> a - , ft_middle_out :: middle -> a -> a - , ft_last_outs :: last -> a -> LastOutFacts a - , ft_exit_out :: a -> a - } - -newtype LastOutFacts a = LastOutFacts [(BlockId, a)] - -- ^ These are facts flowing out of a last node to the node's successors. - -- They are either to be set (if they pertain to the graph currently - -- under analysis) or propagated out of a sub-analysis - - --- | A backward rewrite takes the same inputs as a backward transfer, --- but instead of producing a fact, it produces a replacement graph or Nothing. - -data BackwardRewrites middle last a = BackwardRewrites - { br_first :: BlockId -> a -> Maybe (AGraph middle last) - , br_middle :: middle -> a -> Maybe (AGraph middle last) - , br_last :: last -> (BlockId -> a) -> Maybe (AGraph middle last) - , br_exit :: Maybe (AGraph middle last) - } - --- | A forward rewrite takes the same inputs as a forward transfer, --- but instead of producing a fact, it produces a replacement graph or Nothing. - -data ForwardRewrites middle last a = ForwardRewrites - { fr_first :: BlockId -> a -> Maybe (AGraph middle last) - , fr_middle :: middle -> a -> Maybe (AGraph middle last) - , fr_last :: last -> a -> Maybe (AGraph middle last) - , fr_exit :: a -> Maybe (AGraph middle last) - } - -{- ===================== FIXED POINTS =================== -} - --- | The result of combined analysis and transformation is a --- solution to the set of dataflow equations together with a 'contained value'. --- This solution is a member of type class 'FixedPoint', which is parameterized by --- * middle and last nodes 'm' and 'l' --- * data flow fact 'fact' --- * the type 'a' of the contained value --- --- In practice, the contained value 'zdfFpContents' is either a --- rewritten graph, when rewriting, or (), when solving without --- rewriting. A function 'zdfFpMap' allows a client to change --- the contents without changing other values. --- --- To save space, we provide the solution 'zdfFpFacts' as a mapping --- from BlockId to fact; if necessary, facts on edges can be --- reconstructed using the transfer functions; this functionality is --- intended to be included as the 'zdfDecoratedGraph', but the code --- has not yet been implemented. --- --- The solution may also includes a fact 'zdfFpOuputFact', which is --- not associated with any label: --- * for a backward problem, this is the fact at entry --- * for a forward problem, this is the fact at the distinguished exit node, --- if such a node is present --- --- For a forward problem only, the solution includes 'zdfFpLastOuts', --- which is the set of facts on edges leaving the graph. --- --- The flag 'zdfGraphChanged' tells whether the engine did any rewriting. - -class FixedPoint fp where - zdfFpContents :: fp m l fact a -> a - zdfFpFacts :: fp m l fact a -> BlockEnv fact - zdfFpOutputFact :: fp m l fact a -> fact -- entry for backward; exit for forward - zdfDecoratedGraph :: fp m l fact a -> Graph (fact, m) (fact, l) - zdfGraphChanged :: fp m l fact a -> ChangeFlag - zdfFpMap :: (a -> b) -> (fp m l fact a -> fp m l fact b) - --- | The class 'FixedPoint' has two instances: one for forward problems and --- one for backward problems. The 'CommonFixedPoint' defines all fields --- common to both. (The instance declarations are uninteresting and appear below.) - -data CommonFixedPoint m l fact a = FP - { fp_facts :: BlockEnv fact - , fp_out :: fact -- entry for backward; exit for forward - , fp_changed :: ChangeFlag - , fp_dec_graph :: Graph (fact, m) (fact, l) - , fp_contents :: a - } - --- | The common fixed point is sufficient for a backward problem. -type BackwardFixedPoint = CommonFixedPoint - --- | A forward problem needs the common fields, plus the facts on the outedges. -data ForwardFixedPoint m l fact a = FFP - { ffp_common :: CommonFixedPoint m l fact a - , zdfFpLastOuts :: LastOutFacts fact - } - - -{- ============== SOLVING AND REWRITING ============== -} - -type PassName = String - --- | 'zdfSolveFrom' is an overloaded name that resolves to a pure --- analysis with no rewriting. It has only two instances: forward and --- backward. Since it needs no rewrites, the type parameters of the --- class are transfer functions and the fixed point. --- --- --- An iterative solver normally starts with the bottom fact at every --- node, but it can be useful in other contexts as well. For this --- reason the initial set of facts (at labelled blocks only) is a --- parameter to the solver. --- --- The constraints on the type signature exist purely for debugging; --- they make it possible to prettyprint nodes and facts. The parameter of --- type 'PassName' is also used just for debugging. --- --- Note that the result is a fixed point with no contents, that is, --- the contents have type (). --- --- The intent of the rest of the type signature should be obvious. --- If not, place a skype call to norman-ramsey or complain bitterly --- to . - -class DataflowSolverDirection transfers fixedpt where - zdfSolveFrom :: (DebugNodes m l, Outputable a) - => BlockEnv a -- ^ Initial facts (unbound == bottom) - -> PassName - -> DataflowLattice a -- ^ Lattice - -> transfers m l a -- ^ Dataflow transfer functions - -> a -- ^ Fact flowing in (at entry or exit) - -> Graph m l -- ^ Graph to be analyzed - -> FuelMonad (fixedpt m l a ()) -- ^ Answers - zdfSolveFromL :: (DebugNodes m l, Outputable a) - => BlockEnv a -- Initial facts (unbound == bottom) - -> PassName - -> DataflowLattice a -- Lattice - -> transfers m l a -- Dataflow transfer functions - -> a -- Fact flowing in (at entry or exit) - -> LGraph m l -- Graph to be analyzed - -> FuelMonad (fixedpt m l a ()) -- Answers - zdfSolveFromL b p l t a g = zdfSolveFrom b p l t a $ quickGraph g - --- There are exactly two instances: forward and backward -instance DataflowSolverDirection ForwardTransfers ForwardFixedPoint - where zdfSolveFrom = solve_f - -instance DataflowSolverDirection BackwardTransfers BackwardFixedPoint - where zdfSolveFrom = solve_b - - --- | zdfRewriteFrom is an overloaded name that resolves to an --- interleaved analysis and transformation. It too is instantiated in --- forward and backward directions. --- --- The type parameters of the class include not only transfer --- functions and the fixed point but also rewrites. --- --- The type signature of 'zdfRewriteFrom' is that of 'zdfSolveFrom' --- with the rewrites and a rewriting depth as additional parameters, --- as well as a different result, which contains a rewritten graph. - -class DataflowSolverDirection transfers fixedpt => - DataflowDirection transfers fixedpt rewrites where - zdfRewriteFrom :: (DebugNodes m l, Outputable a) - => RewritingDepth -- whether to rewrite a rewritten graph - -> BlockEnv a -- initial facts (unbound == bottom) - -> PassName - -> DataflowLattice a - -> transfers m l a - -> rewrites m l a - -> a -- fact flowing in (at entry or exit) - -> Graph m l - -> FuelMonad (fixedpt m l a (Graph m l)) - --- Temporarily lifting from Graph to LGraph -- an experiment to see how we --- can eliminate some hysteresis between Graph and LGraph. --- Perhaps Graph should be confined to dataflow code. --- Trading space for time -quickGraph :: LastNode l => LGraph m l -> Graph m l -quickGraph g = Graph (ZLast $ mkBranchNode $ lg_entry g) $ lg_blocks g - -quickLGraph :: LastNode l => Graph m l -> FuelMonad (LGraph m l) -quickLGraph (Graph (ZLast (LastOther l)) blockenv) - | isBranchNode l = return $ LGraph (branchNodeTarget l) blockenv -quickLGraph g = F.lGraphOfGraph g - -fixptWithLGraph :: LastNode l => CommonFixedPoint m l fact (Graph m l) -> - FuelMonad (CommonFixedPoint m l fact (LGraph m l)) -fixptWithLGraph cfp = - do fp_c <- quickLGraph $ fp_contents cfp - return $ cfp {fp_contents = fp_c} - -ffixptWithLGraph :: LastNode l => ForwardFixedPoint m l fact (Graph m l) -> - FuelMonad (ForwardFixedPoint m l fact (LGraph m l)) -ffixptWithLGraph fp = - do common <- fixptWithLGraph $ ffp_common fp - return $ fp {ffp_common = common} - -zdfFRewriteFromL :: (DebugNodes m l, Outputable a) - => RewritingDepth -- whether to rewrite a rewritten graph - -> BlockEnv a -- initial facts (unbound == bottom) - -> PassName - -> DataflowLattice a - -> ForwardTransfers m l a - -> ForwardRewrites m l a - -> a -- fact flowing in (at entry or exit) - -> LGraph m l - -> FuelMonad (ForwardFixedPoint m l a (LGraph m l)) -zdfFRewriteFromL d b p l t r a g@(LGraph _ _) = - do fp <- zdfRewriteFrom d b p l t r a $ quickGraph g - ffixptWithLGraph fp - -zdfBRewriteFromL :: (DebugNodes m l, Outputable a) - => RewritingDepth -- whether to rewrite a rewritten graph - -> BlockEnv a -- initial facts (unbound == bottom) - -> PassName - -> DataflowLattice a - -> BackwardTransfers m l a - -> BackwardRewrites m l a - -> a -- fact flowing in (at entry or exit) - -> LGraph m l - -> FuelMonad (BackwardFixedPoint m l a (LGraph m l)) -zdfBRewriteFromL d b p l t r a g@(LGraph _ _) = - do fp <- zdfRewriteFrom d b p l t r a $ quickGraph g - fixptWithLGraph fp - - -data RewritingDepth = RewriteShallow | RewriteDeep --- When a transformation proposes to rewrite a node, --- you can either ask the system to --- * "shallow": accept the new graph, analyse it without further rewriting --- * "deep": recursively analyse-and-rewrite the new graph - - --- There are currently four instances, but there could be more --- forward, backward (instantiates transfers, fixedpt, rewrites) --- Graph, AGraph (instantiates graph) - -instance DataflowDirection ForwardTransfers ForwardFixedPoint ForwardRewrites - where zdfRewriteFrom = rewrite_f_agraph - -instance DataflowDirection BackwardTransfers BackwardFixedPoint BackwardRewrites - where zdfRewriteFrom = rewrite_b_agraph - - -{- =================== IMPLEMENTATIONS ===================== -} - - ------------------------------------------------------------ --- solve_f: forward, pure - -solve_f :: (DebugNodes m l, Outputable a) - => BlockEnv a -- initial facts (unbound == bottom) - -> PassName - -> DataflowLattice a -- lattice - -> ForwardTransfers m l a -- dataflow transfer functions - -> a - -> Graph m l -- graph to be analyzed - -> FuelMonad (ForwardFixedPoint m l a ()) -- answers -solve_f env name lattice transfers in_fact g = - runDFM lattice $ fwd_pure_anal name env transfers in_fact g - -rewrite_f_agraph :: (DebugNodes m l, Outputable a) - => RewritingDepth - -> BlockEnv a - -> PassName - -> DataflowLattice a - -> ForwardTransfers m l a - -> ForwardRewrites m l a - -> a -- fact flowing in (at entry or exit) - -> Graph m l - -> FuelMonad (ForwardFixedPoint m l a (Graph m l)) -rewrite_f_agraph depth start_facts name lattice transfers rewrites in_fact g = - runDFM lattice $ - do fuel <- fuelRemaining - (fp, fuel') <- forward_rew maybeRewriteWithFuel depth start_facts name - transfers rewrites in_fact g fuel - fuelDecrement name fuel fuel' - return fp - -areturn :: AGraph m l -> DFM a (Graph m l) -areturn g = liftToDFM $ liftUniq $ graphOfAGraph g - --- | Here we prefer not simply to slap on 'goto eid' because this --- introduces an unnecessary basic block at each rewrite, and we don't --- want to stress out the finite map more than necessary -lgraphToGraph :: LastNode l => LGraph m l -> Graph m l -lgraphToGraph (LGraph eid blocks) = - if flip any (eltsBlockEnv blocks) $ \block -> any (== eid) (succs block) then - Graph (ZLast (mkBranchNode eid)) blocks - else -- common case: entry is not a branch target - let Block _ entry = lookupBlockEnv blocks eid `orElse` panic "missing entry!" - in Graph entry (delFromBlockEnv blocks eid) - - -class (Outputable m, Outputable l, LastNode l, Outputable (LGraph m l)) => DebugNodes m l - -fwd_pure_anal :: (DebugNodes m l, LastNode l, Outputable a) - => PassName - -> BlockEnv a - -> ForwardTransfers m l a - -> a - -> Graph m l - -> DFM a (ForwardFixedPoint m l a ()) - -fwd_pure_anal name env transfers in_fact g = - do (fp, _) <- anal_f name env transfers panic_rewrites in_fact g panic_fuel - return fp - where -- definitely a case of "I love lazy evaluation" - anal_f = forward_sol (\_ _ -> Nothing) panic_depth - panic_rewrites = panic "pure analysis asked for a rewrite function" - panic_fuel = panic "pure analysis asked for fuel" - panic_depth = panic "pure analysis asked for a rewrite depth" - ------------------------------------------------------------------------ --- --- Here beginneth the super-general functions --- --- Think of them as (typechecked) macros --- * They are not exported --- --- * They are called by the specialised wrappers --- above, and always inlined into their callers --- --- There are four functions, one for each combination of: --- Forward, Backward --- Solver, Rewriter --- --- A "solver" produces a (DFM f (f, Fuel)), --- where f is the fact at entry(Bwd)/exit(Fwd) --- and from the DFM you can extract --- the BlockId->f --- the change-flag --- and more besides --- --- A "rewriter" produces a rewritten *Graph* as well --- --- Both constrain their rewrites by --- a) Fuel --- b) RewritingDepth: shallow/deep - ------------------------------------------------------------------------ - -type Fuel = OptimizationFuel - -forward_sol - :: forall m l a . - (DebugNodes m l, LastNode l, Outputable a) - => (forall a . Fuel -> Maybe a -> Maybe a) - -- Squashes proposed rewrites if there is - -- no more fuel; OR if we are doing a pure - -- analysis, so totally ignore the rewrite - -- ie. For pure-analysis the fn is (\_ _ -> Nothing) - -> RewritingDepth -- Shallow/deep - -> PassName - -> BlockEnv a -- Initial set of facts - -> ForwardTransfers m l a - -> ForwardRewrites m l a - -> a -- Entry fact - -> Graph m l - -> Fuel - -> DFM a (ForwardFixedPoint m l a (), Fuel) -forward_sol check_maybe = forw - where - forw :: RewritingDepth - -> PassName - -> BlockEnv a - -> ForwardTransfers m l a - -> ForwardRewrites m l a - -> a - -> Graph m l - -> Fuel - -> DFM a (ForwardFixedPoint m l a (), Fuel) - forw rewrite name start_facts transfers rewrites = - let anal_f :: DFM a b -> a -> Graph m l -> DFM a b - anal_f finish in' g = - do { _ <- fwd_pure_anal name emptyBlockEnv transfers in' g; finish } - - solve :: DFM a b -> a -> Graph m l -> Fuel -> DFM a (b, Fuel) - solve finish in_fact (Graph entry blockenv) fuel = - let blocks = G.postorder_dfs_from blockenv entry - set_or_save = mk_set_or_save (isJust . lookupBlockEnv blockenv) - set_successor_facts (Block id tail) fuel = - do { idfact <- getFact id - ; (last_outs, fuel) <- rec_rewrite (fr_first rewrites id idfact) - (ft_first_out transfers id idfact) - getExitFact (solve_tail tail) - (solve_tail tail) idfact fuel - ; set_or_save last_outs - ; return fuel } - in do { (last_outs, fuel) <- solve_tail entry in_fact fuel - -- last_outs contains a mix of internal facts, which - -- are inputs to 'run', and external facts, which - -- are going to be forgotten by 'run' - ; set_or_save last_outs - ; fuel <- run "forward" name set_successor_facts blocks fuel - ; set_or_save last_outs - -- Re-set facts that may have been forgotten by run - ; b <- finish - ; return (b, fuel) - } - - -- The need for both k1 and k2 suggests that maybe there's an opportunity - -- for improvement here -- in most cases, they're the same... - rec_rewrite :: forall t bI bW. - Maybe (AGraph m l) -> t -> DFM a bW - -> (t -> Fuel -> DFM a bI) - -> (bW -> Fuel -> DFM a bI) - -> a -> Fuel -> DFM a bI - rec_rewrite rewritten analyzed finish k1 k2 in' fuel = - case check_maybe fuel rewritten of -- fr_first rewrites id idfact of - Nothing -> k1 analyzed fuel - Just g -> do g <- areturn g - (a, fuel) <- subAnalysis' $ - case rewrite of - RewriteDeep -> solve finish in' g (oneLessFuel fuel) - RewriteShallow -> do { a <- anal_f finish in' g - ; return (a, oneLessFuel fuel) } - k2 a fuel - solve_tail (G.ZTail m t) in' fuel = - rec_rewrite (fr_middle rewrites m in') (ft_middle_out transfers m in') - getExitFact (solve_tail t) (solve_tail t) in' fuel - solve_tail (G.ZLast (LastOther l)) in' fuel = - rec_rewrite (fr_last rewrites l in') (ft_last_outs transfers l in') - lastOutFacts k k in' fuel - where k a b = return (a, b) - solve_tail (G.ZLast LastExit) in' fuel = - rec_rewrite (fr_exit rewrites in') (ft_exit_out transfers in') - lastOutFacts k (\a b -> return (a, b)) in' fuel - where k a fuel = do { setExitFact a ; return (LastOutFacts [], fuel) } - - fixed_point in_fact g fuel = - do { setAllFacts start_facts - ; (a, fuel) <- solve getExitFact in_fact g fuel - ; facts <- getAllFacts - ; last_outs <- lastOutFacts - ; let cfp = FP facts a NoChange (panic "no decoration?!") () - ; let fp = FFP cfp last_outs - ; return (fp, fuel) - } - in fixed_point - - - - -mk_set_or_save :: (DataflowAnalysis df, Monad (df a), Outputable a) => - (BlockId -> Bool) -> LastOutFacts a -> df a () -mk_set_or_save is_local (LastOutFacts l) = mapM_ set_or_save_one l - where set_or_save_one (id, a) = - if is_local id then setFact id a else addLastOutFact (id, a) - - - -forward_rew - :: forall m l a . - (DebugNodes m l, LastNode l, Outputable a) - => (forall a . Fuel -> Maybe a -> Maybe a) - -> RewritingDepth - -> BlockEnv a - -> PassName - -> ForwardTransfers m l a - -> ForwardRewrites m l a - -> a - -> Graph m l - -> Fuel - -> DFM a (ForwardFixedPoint m l a (Graph m l), Fuel) -forward_rew check_maybe = forw - where - forw :: RewritingDepth - -> BlockEnv a - -> PassName - -> ForwardTransfers m l a - -> ForwardRewrites m l a - -> a - -> Graph m l - -> Fuel - -> DFM a (ForwardFixedPoint m l a (Graph m l), Fuel) - forw depth xstart_facts name transfers rewrites in_factx gx fuelx = - let rewrite :: BlockEnv a -> DFM a b - -> a -> Graph m l -> Fuel - -> DFM a (b, Graph m l, Fuel) - rewrite start finish in_fact g fuel = - in_fact `seq` g `seq` - let Graph entry blockenv = g - blocks = G.postorder_dfs_from blockenv entry - in do { _ <- forward_sol check_maybe depth name start - transfers rewrites in_fact g fuel - ; eid <- freshBlockId "temporary entry id" - ; (rewritten, fuel) <- - rew_tail (ZFirst eid) in_fact entry emptyBlockEnv fuel - ; (rewritten, fuel) <- rewrite_blocks blocks rewritten fuel - ; a <- finish - ; return (a, lgraphToGraph (LGraph eid rewritten), fuel) - } - - don't_rewrite :: forall t. - BlockEnv a -> DFM a t -> a - -> Graph m l -> Fuel - -> DFM a (t, Graph m l, Fuel) - don't_rewrite facts finish in_fact g fuel = - do { _ <- forward_sol check_maybe depth name facts - transfers rewrites in_fact g fuel - ; a <- finish - ; return (a, g, fuel) - } - - inner_rew :: DFM a f -> a -> Graph m l -> Fuel -> DFM a (f, Graph m l, Fuel) - inner_rew f i g fu = getAllFacts >>= \facts -> inner_rew' facts f i g fu - where inner_rew' = case depth of RewriteShallow -> don't_rewrite - RewriteDeep -> rewrite - fixed_pt_and_fuel = - do { (a, g, fuel) <- rewrite xstart_facts getExitFact in_factx gx fuelx - ; facts <- getAllFacts - ; changed <- graphWasRewritten - ; last_outs <- lastOutFacts - ; let cfp = FP facts a changed (panic "no decoration?!") g - ; let fp = FFP cfp last_outs - ; return (fp, fuel) - } - --- JD: WHY AREN'T WE TAKING ANY FUEL HERE? - rewrite_blocks :: [Block m l] -> (BlockEnv (Block m l)) - -> Fuel -> DFM a (BlockEnv (Block m l), Fuel) - rewrite_blocks [] rewritten fuel = return (rewritten, fuel) - rewrite_blocks (G.Block id t : bs) rewritten fuel = - do let h = ZFirst id - a <- getFact id - case check_maybe fuel $ fr_first rewrites id a of - Nothing -> do { (rewritten, fuel) <- - rew_tail h (ft_first_out transfers id a) - t rewritten fuel - ; rewrite_blocks bs rewritten fuel } - Just g -> do { markGraphRewritten - ; g <- areturn g - ; (outfact, g, fuel) <- inner_rew getExitFact a g fuel - ; let (blocks, h) = splice_head' h g - ; (rewritten, fuel) <- - rew_tail h outfact t (blocks `plusBlockEnv` rewritten) fuel - ; rewrite_blocks bs rewritten fuel } - - rew_tail head in' (G.ZTail m t) rewritten fuel = - in' `seq` rewritten `seq` - my_trace "Rewriting middle node" (ppr m) $ - case check_maybe fuel $ fr_middle rewrites m in' of - Nothing -> rew_tail (G.ZHead head m) (ft_middle_out transfers m in') t - rewritten fuel - Just g -> do { markGraphRewritten - ; g <- areturn g - ; (a, g, fuel) <- inner_rew getExitFact in' g fuel - ; let (blocks, h) = G.splice_head' head g - ; rew_tail h a t (blocks `plusBlockEnv` rewritten) fuel - } - rew_tail h in' (G.ZLast l) rewritten fuel = - in' `seq` rewritten `seq` - my_trace "Rewriting last node" (ppr l) $ - case check_maybe fuel $ either_last rewrites in' l of - Nothing -> do check_facts in' l - return (insertBlock (zipht h (G.ZLast l)) rewritten, fuel) - Just g -> do { markGraphRewritten - ; g <- areturn g - ; ((), g, fuel) <- - my_trace "Just" (ppr g) $ inner_rew (return ()) in' g fuel - ; let g' = G.splice_head_only' h g - ; return (G.lg_blocks g' `plusBlockEnv` rewritten, fuel) - } - either_last rewrites in' (LastExit) = fr_exit rewrites in' - either_last rewrites in' (LastOther l) = fr_last rewrites l in' - check_facts in' (LastOther l) = - let LastOutFacts last_outs = ft_last_outs transfers l in' - in mapM_ (uncurry checkFactMatch) last_outs - check_facts _ LastExit = return () - in fixed_pt_and_fuel - -lastOutFacts :: DFM f (LastOutFacts f) -lastOutFacts = bareLastOutFacts >>= return . LastOutFacts - -{- ================================================================ -} - -solve_b :: (DebugNodes m l, Outputable a) - => BlockEnv a -- initial facts (unbound == bottom) - -> PassName - -> DataflowLattice a -- lattice - -> BackwardTransfers m l a -- dataflow transfer functions - -> a -- exit fact - -> Graph m l -- graph to be analyzed - -> FuelMonad (BackwardFixedPoint m l a ()) -- answers -solve_b env name lattice transfers exit_fact g = - runDFM lattice $ bwd_pure_anal name env transfers g exit_fact - - -rewrite_b_agraph :: (DebugNodes m l, Outputable a) - => RewritingDepth - -> BlockEnv a - -> PassName - -> DataflowLattice a - -> BackwardTransfers m l a - -> BackwardRewrites m l a - -> a -- fact flowing in at exit - -> Graph m l - -> FuelMonad (BackwardFixedPoint m l a (Graph m l)) -rewrite_b_agraph depth start_facts name lattice transfers rewrites exit_fact g = - runDFM lattice $ - do fuel <- fuelRemaining - (fp, fuel') <- backward_rew maybeRewriteWithFuel depth start_facts name - transfers rewrites g exit_fact fuel - fuelDecrement name fuel fuel' - return fp - - - -backward_sol - :: forall m l a . - (DebugNodes m l, LastNode l, Outputable a) - => (forall a . Fuel -> Maybe a -> Maybe a) - -> RewritingDepth - -> PassName - -> BlockEnv a - -> BackwardTransfers m l a - -> BackwardRewrites m l a - -> Graph m l - -> a - -> Fuel - -> DFM a (BackwardFixedPoint m l a (), Fuel) -backward_sol check_maybe = back - where - back :: RewritingDepth - -> PassName - -> BlockEnv a - -> BackwardTransfers m l a - -> BackwardRewrites m l a - -> Graph m l - -> a - -> Fuel - -> DFM a (BackwardFixedPoint m l a (), Fuel) - back rewrite name start_facts transfers rewrites = - let anal_b :: Graph m l -> a -> DFM a a - anal_b g out = - do { fp <- bwd_pure_anal name emptyBlockEnv transfers g out - ; return $ zdfFpOutputFact fp } - - subsolve :: AGraph m l -> a -> Fuel -> DFM a (a, Fuel) - subsolve = - case rewrite of - RewriteDeep -> \g a fuel -> - subAnalysis' $ do { g <- areturn g; solve g a (oneLessFuel fuel) } - RewriteShallow -> \g a fuel -> - subAnalysis' $ do { g <- areturn g; a <- anal_b g a - ; return (a, oneLessFuel fuel) } - - solve :: Graph m l -> a -> Fuel -> DFM a (a, Fuel) - solve (Graph entry blockenv) exit_fact fuel = - let blocks = reverse $ G.postorder_dfs_from blockenv entry - last_in _env (LastExit) = exit_fact - last_in env (LastOther l) = bt_last_in transfers l env - last_rew _env (LastExit) = br_exit rewrites - last_rew env (LastOther l) = br_last rewrites l env - set_block_fact block fuel = - let (h, l) = G.goto_end (G.unzip block) in - do { env <- factsEnv - ; (a, fuel) <- - case check_maybe fuel $ last_rew env l of - Nothing -> return (last_in env l, fuel) - Just g -> do g' <- areturn g - my_trace "analysis rewrites last node" - (ppr l <+> pprGraph g') $ - subsolve g exit_fact fuel - ; _ <- set_head_fact h a fuel - ; return fuel } - - in do { fuel <- run "backward" name set_block_fact blocks fuel - ; eid <- freshBlockId "temporary entry id" - ; fuel <- set_block_fact (Block eid entry) fuel - ; a <- getFact eid - ; forgetFact eid - ; return (a, fuel) - } - - set_head_fact (G.ZFirst id) a fuel = - case check_maybe fuel $ br_first rewrites id a of - Nothing -> do { my_trace "set_head_fact" (ppr id <+> text "=" <+> - ppr (bt_first_in transfers id a)) $ - setFact id $ bt_first_in transfers id a - ; return fuel } - Just g -> do { g' <- areturn g - ; (a, fuel) <- my_trace "analysis rewrites first node" - (ppr id <+> pprGraph g') $ - subsolve g a fuel - ; setFact id $ bt_first_in transfers id a - ; return fuel - } - set_head_fact (G.ZHead h m) a fuel = - case check_maybe fuel $ br_middle rewrites m a of - Nothing -> set_head_fact h (bt_middle_in transfers m a) fuel - Just g -> do { g' <- areturn g - ; (a, fuel) <- my_trace "analysis rewrites middle node" - (ppr m <+> pprGraph g') $ - subsolve g a fuel - ; set_head_fact h a fuel } - - fixed_point g exit_fact fuel = - do { setAllFacts start_facts - ; (a, fuel) <- solve g exit_fact fuel - ; facts <- getAllFacts - ; let cfp = FP facts a NoChange (panic "no decoration?!") () - ; return (cfp, fuel) - } - in fixed_point - -bwd_pure_anal :: (DebugNodes m l, LastNode l, Outputable a) - => PassName - -> BlockEnv a - -> BackwardTransfers m l a - -> Graph m l - -> a - -> DFM a (BackwardFixedPoint m l a ()) - -bwd_pure_anal name env transfers g exit_fact = - do (fp, _) <- anal_b name env transfers panic_rewrites g exit_fact panic_fuel - return fp - where -- another case of "I love lazy evaluation" - anal_b = backward_sol (\_ _ -> Nothing) panic_depth - panic_rewrites = panic "pure analysis asked for a rewrite function" - panic_fuel = panic "pure analysis asked for fuel" - panic_depth = panic "pure analysis asked for a rewrite depth" - - -{- ================================================================ -} - -backward_rew - :: forall m l a . - (DebugNodes m l, LastNode l, Outputable a) - => (forall a . Fuel -> Maybe a -> Maybe a) - -> RewritingDepth - -> BlockEnv a - -> PassName - -> BackwardTransfers m l a - -> BackwardRewrites m l a - -> Graph m l - -> a - -> Fuel - -> DFM a (BackwardFixedPoint m l a (Graph m l), Fuel) -backward_rew check_maybe = back - where - solve = backward_sol check_maybe - back :: RewritingDepth - -> BlockEnv a - -> PassName - -> BackwardTransfers m l a - -> BackwardRewrites m l a - -> Graph m l - -> a - -> Fuel - -> DFM a (BackwardFixedPoint m l a (Graph m l), Fuel) - back depth xstart_facts name transfers rewrites gx exit_fact fuelx = - let rewrite :: BlockEnv a - -> Graph m l -> a -> Fuel - -> DFM a (a, Graph m l, Fuel) - rewrite start g exit_fact fuel = - let Graph entry blockenv = g - blocks = reverse $ G.postorder_dfs_from blockenv entry - in do { (FP _ in_fact _ _ _, _) <- -- don't drop the entry fact! - solve depth name start transfers rewrites g exit_fact fuel - --; env <- getAllFacts - -- ; my_trace "facts after solving" (ppr env) $ return () - ; eid <- freshBlockId "temporary entry id" - ; (rewritten, fuel) <- rewrite_blocks True blocks emptyBlockEnv fuel - -- We can't have the fact check fail on the bogus entry, which _may_ change - ; (rewritten, fuel) <- - rewrite_blocks False [Block eid entry] rewritten fuel - ; my_trace "eid" (ppr eid) $ return () - ; my_trace "exit_fact" (ppr exit_fact) $ return () - ; my_trace "in_fact" (ppr in_fact) $ return () - ; return (in_fact, lgraphToGraph (LGraph eid rewritten), fuel) - } -- Remember: the entry fact computed by @solve@ accounts for rewriting - don't_rewrite facts g exit_fact fuel = - do { (fp, _) <- - solve depth name facts transfers rewrites g exit_fact fuel - ; return (zdfFpOutputFact fp, g, fuel) } - inner_rew :: Graph m l -> a -> Fuel -> DFM a (a, Graph m l, Fuel) - inner_rew g a f = getAllFacts >>= \facts -> inner_rew' facts g a f - where inner_rew' = case depth of RewriteShallow -> don't_rewrite - RewriteDeep -> rewrite - fixed_pt_and_fuel = - do { (a, g, fuel) <- rewrite xstart_facts gx exit_fact fuelx - ; facts <- getAllFacts - ; changed <- graphWasRewritten - ; let fp = FP facts a changed (panic "no decoration?!") g - ; return (fp, fuel) - } - rewrite_blocks :: Bool -> [Block m l] -> (BlockEnv (Block m l)) - -> Fuel -> DFM a (BlockEnv (Block m l), Fuel) - rewrite_blocks check bs rewritten fuel = - do { env <- factsEnv - ; let rew [] r f = return (r, f) - rew (b : bs) r f = - do { (r, f) <- rewrite_block check env b r f; rew bs r f } - ; rew bs rewritten fuel } - rewrite_block check env b rewritten fuel = - let (h, l) = G.goto_end (G.unzip b) in - case maybeRewriteWithFuel fuel $ either_last env l of - Nothing -> propagate check fuel h (last_in env l) (ZLast l) rewritten - Just g -> - do { markGraphRewritten - ; g <- areturn g - ; (a, g, fuel) <- inner_rew g exit_fact fuel - ; let G.Graph t new_blocks = g - ; let rewritten' = new_blocks `plusBlockEnv` rewritten - ; propagate check fuel h a t rewritten' -- continue at entry of g - } - either_last _env (LastExit) = br_exit rewrites - either_last env (LastOther l) = br_last rewrites l env - last_in _env (LastExit) = exit_fact - last_in env (LastOther l) = bt_last_in transfers l env - propagate check fuel (ZHead h m) a tail rewritten = - case maybeRewriteWithFuel fuel $ br_middle rewrites m a of - Nothing -> - propagate check fuel h (bt_middle_in transfers m a) (ZTail m tail) rewritten - Just g -> - do { markGraphRewritten - ; g <- areturn g - ; my_trace "With Facts" (ppr a) $ return () - ; my_trace " Rewrote middle node" - (f4sep [ppr m, text "to", pprGraph g]) $ - return () - ; (a, g, fuel) <- inner_rew g a fuel - ; let Graph t newblocks = G.splice_tail g tail - ; my_trace "propagating facts" (ppr a) $ - propagate check fuel h a t (newblocks `plusBlockEnv` rewritten) } - propagate check fuel (ZFirst id) a tail rewritten = - case maybeRewriteWithFuel fuel $ br_first rewrites id a of - Nothing -> do { if check then - checkFactMatch id $ bt_first_in transfers id a - else return () - ; return (insertBlock (Block id tail) rewritten, fuel) } - Just g -> - do { markGraphRewritten - ; g <- areturn g - ; my_trace "Rewrote first node" - (f4sep [ppr id <> colon, text "to", pprGraph g]) $ return () - ; (a, g, fuel) <- inner_rew g a fuel - ; if check then checkFactMatch id (bt_first_in transfers id a) - else return () - ; let Graph t newblocks = G.splice_tail g tail - ; let r = insertBlock (Block id t) (newblocks `plusBlockEnv` rewritten) - ; return (r, fuel) } - in fixed_pt_and_fuel - -{- ================================================================ -} - -instance FixedPoint CommonFixedPoint where - zdfFpFacts = fp_facts - zdfFpOutputFact = fp_out - zdfGraphChanged = fp_changed - zdfDecoratedGraph = fp_dec_graph - zdfFpContents = fp_contents - zdfFpMap f (FP fs out ch dg a) = FP fs out ch dg (f a) - -instance FixedPoint ForwardFixedPoint where - zdfFpFacts = fp_facts . ffp_common - zdfFpOutputFact = fp_out . ffp_common - zdfGraphChanged = fp_changed . ffp_common - zdfDecoratedGraph = fp_dec_graph . ffp_common - zdfFpContents = fp_contents . ffp_common - zdfFpMap f (FFP fp los) = FFP (zdfFpMap f fp) los - - -dump_things :: Bool -dump_things = False - -my_trace :: String -> SDoc -> a -> a -my_trace = if dump_things then pprTrace else \_ _ a -> a - - --- | Here's a function to run an action on blocks until we reach a fixed point. -run :: (Outputable a, DebugNodes m l) => - String -> String -> (Block m l -> b -> DFM a b) -> [Block m l] -> b -> DFM a b -run dir name do_block blocks b = - do { show_blocks $ iterate (1::Int) } - where - -- N.B. Each iteration starts with the same transaction limit; - -- only the rewrites in the final iteration actually count - trace_block (b, cnt) block = - do b' <- my_trace "about to do" (text name <+> text "on" <+> - ppr (blockId block) <+> ppr cnt) $ - do_block block b - return (b', cnt + 1) - iterate n = - do { forgetLastOutFacts - ; markFactsUnchanged - ; (b, _) <- foldM trace_block (b, 0 :: Int) blocks - ; changed <- factsStatus - ; facts <- getAllFacts - ; let depth = 0 -- was nesting depth - ; ppIter depth n $ - case changed of - NoChange -> unchanged depth $ return b - SomeChange -> - pprFacts depth n facts $ - if n < 1000 then iterate (n+1) - else panic $ msg n - } - msg n = concat [name, " didn't converge in ", show n, " " , dir, - " iterations"] - my_nest depth sdoc = my_trace "" $ nest (3*depth) sdoc - ppIter depth n = my_nest depth (empty $$ text "*************** iteration" <+> pp_i n) - pp_i n = int n <+> text "of" <+> text name <+> text "on" <+> graphId - unchanged depth = - my_nest depth (text "facts for" <+> graphId <+> text "are unchanged") - - graphId = case blocks of { Block id _ : _ -> ppr id ; [] -> text "" } - show_blocks = my_trace "Blocks:" (vcat (map pprBlock blocks)) - pprBlock (Block id t) = nest 2 (pprFact (id, t)) - pprFacts depth n env = - my_nest depth (text "facts for iteration" <+> pp_i n <+> text "are:" $$ - (nest 2 $ vcat $ map pprFact $ blockEnvToList env)) - -pprFact :: (Outputable a, Outputable b) => (a,b) -> SDoc -pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a) - -f4sep :: [SDoc] -> SDoc -f4sep [] = fsep [] -f4sep (d:ds) = fsep (d : map (nest 4) ds) - - -subAnalysis' :: (Monad (m f), DataflowAnalysis m, Outputable f) => - m f a -> m f a -subAnalysis' m = - do { a <- subAnalysis $ - do { a <- m; -- facts <- getAllFacts - ; -- my_trace "after sub-analysis facts are" (pprFacts facts) $ - return a } - -- ; facts <- getAllFacts - ; -- my_trace "in parent analysis facts are" (pprFacts facts) $ - return a } - -- where pprFacts env = nest 2 $ vcat $ map pprFact $ blockEnvToList env - -- pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a) diff -Nru ghc-7.0.3/compiler/codeGen/CgBindery.lhs ghc-7.2.1/compiler/codeGen/CgBindery.lhs --- ghc-7.0.3/compiler/codeGen/CgBindery.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/codeGen/CgBindery.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -39,7 +39,7 @@ import ClosureInfo import Constants -import Cmm +import OldCmm import PprCmm ( {- instance Outputable -} ) import SMRep import Id @@ -317,14 +317,14 @@ cgLookupPanic id = do static_binds <- getStaticBinds local_binds <- getBinds - srt <- getSRTLabel - pprPanic "cgPanic" +-- srt <- getSRTLabel + pprPanic "cgLookupPanic (probably invalid Core; try -dcore-lint)" (vcat [ppr id, ptext (sLit "static binds for:"), vcat [ ppr (cg_id info) | info <- varEnvElts static_binds ], ptext (sLit "local binds for:"), - vcat [ ppr (cg_id info) | info <- varEnvElts local_binds ], - ptext (sLit "SRT label") <+> pprCLabel srt + vcat [ ppr (cg_id info) | info <- varEnvElts local_binds ] +-- ptext (sLit "SRT label") <+> pprCLabel srt ]) \end{code} diff -Nru ghc-7.0.3/compiler/codeGen/CgCallConv.hs ghc-7.2.1/compiler/codeGen/CgCallConv.hs --- ghc-7.0.3/compiler/codeGen/CgCallConv.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/codeGen/CgCallConv.hs 2011-08-07 17:10:05.000000000 +0000 @@ -32,13 +32,13 @@ import CgMonad import SMRep -import Cmm +import OldCmm import CLabel import Constants import ClosureInfo import CgStackery -import CmmUtils +import OldCmmUtils import Maybes import Id import Name @@ -150,7 +150,7 @@ = let small_bits = case bits of [] -> 0 - [b] -> fromIntegral b + [b] -> b _ -> panic "livenessToAddrMode" in return (smallLiveness size small_bits) diff -Nru ghc-7.0.3/compiler/codeGen/CgCase.lhs ghc-7.2.1/compiler/codeGen/CgCase.lhs --- ghc-7.0.3/compiler/codeGen/CgCase.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/codeGen/CgCase.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -27,8 +27,8 @@ import ClosureInfo import SMRep -import CmmUtils -import Cmm +import OldCmmUtils +import OldCmm import StgSyn import StaticFlags @@ -157,6 +157,25 @@ reps_compatible = idCgRep v == idCgRep bndr \end{code} +Special case #2.5; seq# + + case seq# a s of v + (# s', a' #) -> e + + ==> + + case a of v + (# s', a' #) -> e + + (taking advantage of the fact that the return convention for (# State#, a #) + is the same as the return convention for just 'a') + +\begin{code} +cgCase (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _) + live_in_whole_case live_in_alts bndr alt_type alts + = cgCase (StgApp a []) live_in_whole_case live_in_alts bndr alt_type alts +\end{code} + Special case #3: inline PrimOps and foreign calls. \begin{code} diff -Nru ghc-7.0.3/compiler/codeGen/CgClosure.lhs ghc-7.2.1/compiler/codeGen/CgClosure.lhs --- ghc-7.0.3/compiler/codeGen/CgClosure.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/codeGen/CgClosure.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -31,8 +31,8 @@ import CgUtils import ClosureInfo import SMRep -import Cmm -import CmmUtils +import OldCmm +import OldCmmUtils import CLabel import StgSyn import CostCentre @@ -250,7 +250,6 @@ -- in update frame CAF/DICT functions will be -- subsumed by this enclosing cc { enterCostCentre cl_info cc body - ; stmtsC [CmmComment $ mkFastString $ showSDoc $ ppr body] ; cgExpr body } } diff -Nru ghc-7.0.3/compiler/codeGen/CgCon.lhs ghc-7.2.1/compiler/codeGen/CgCon.lhs --- ghc-7.0.3/compiler/codeGen/CgCon.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/codeGen/CgCon.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -32,8 +32,8 @@ import CgInfoTbls import CLabel import ClosureInfo -import CmmUtils -import Cmm +import OldCmmUtils +import OldCmm import SMRep import CostCentre import Constants diff -Nru ghc-7.0.3/compiler/codeGen/CgExpr.lhs ghc-7.2.1/compiler/codeGen/CgExpr.lhs --- ghc-7.0.3/compiler/codeGen/CgExpr.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/codeGen/CgExpr.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -29,8 +29,8 @@ import CgHpc import CgUtils import ClosureInfo -import Cmm -import CmmUtils +import OldCmm +import OldCmmUtils import VarSet import Literal import PrimOp @@ -151,6 +151,13 @@ tycon = tyConAppTyCon res_ty +cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) + = cgTailCall a [] + -- seq# :: a -> State# -> (# State# , a #) + -- but the return convention for (# State#, a #) is exactly the same as + -- for just a, so we can implment seq# by + -- seq# a s ==> a + cgExpr (StgOpApp (StgPrimOp primop) args res_ty) | primOpOutOfLine primop = tailCallPrimOp primop args diff -Nru ghc-7.0.3/compiler/codeGen/CgExtCode.hs ghc-7.2.1/compiler/codeGen/CgExtCode.hs --- ghc-7.0.3/compiler/codeGen/CgExtCode.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/codeGen/CgExtCode.hs 2011-08-07 17:10:05.000000000 +0000 @@ -39,7 +39,7 @@ import CgMonad import CLabel -import Cmm +import OldCmm -- import BasicTypes import BlockId @@ -128,8 +128,8 @@ newLabel :: FastString -> ExtFCode BlockId newLabel name = do u <- code newUnique - addLabel name (BlockId u) - return (BlockId u) + addLabel name (mkBlockId u) + return (mkBlockId u) -- | Add add a local function to the environment. @@ -162,7 +162,7 @@ return $ case lookupUFM env name of Just (Label l) -> l - _other -> BlockId (newTagUnique (getUnique name) 'L') + _other -> mkBlockId (newTagUnique (getUnique name) 'L') -- | Lookup the location of a named variable. diff -Nru ghc-7.0.3/compiler/codeGen/CgForeignCall.hs ghc-7.2.1/compiler/codeGen/CgForeignCall.hs --- ghc-7.0.3/compiler/codeGen/CgForeignCall.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/codeGen/CgForeignCall.hs 2011-08-07 17:10:05.000000000 +0000 @@ -25,8 +25,8 @@ import Type import TysPrim import CLabel -import Cmm -import CmmUtils +import OldCmm +import OldCmmUtils import SMRep import ForeignCall import ClosureInfo @@ -43,7 +43,7 @@ -- Code generation for Foreign Calls cgForeignCall - :: HintedCmmFormals -- where to put the results + :: [HintedCmmFormal] -- where to put the results -> ForeignCall -- the op -> [StgArg] -- arguments -> StgLiveVars -- live vars, in case we need to save them @@ -64,7 +64,7 @@ emitForeignCall - :: HintedCmmFormals -- where to put the results + :: [HintedCmmFormal] -- where to put the results -> ForeignCall -- the op -> [CmmHinted CmmExpr] -- arguments -> StgLiveVars -- live vars, in case we need to save them @@ -109,9 +109,12 @@ -- alternative entry point, used by CmmParse +-- the new code generator has utility function emitCCall and emitPrimCall +-- which should be used instead of this (the equivalent emitForeignCall +-- is not presently exported.) emitForeignCall' :: Safety - -> HintedCmmFormals -- where to put the results + -> [HintedCmmFormal] -- where to put the results -> CmmCallTarget -- the op -> [CmmHinted CmmExpr] -- arguments -> Maybe [GlobalReg] -- live vars, in case we need to save them @@ -144,7 +147,8 @@ -- to this sequence of three CmmUnsafe calls. stmtC (CmmCall (CmmCallee suspendThread CCallConv) [ CmmHinted id AddrHint ] - [ CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint ] + [ CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint + , CmmHinted (CmmLit (CmmInt (fromIntegral (fromEnum (playInterruptible safety))) wordWidth)) NoHint] CmmUnsafe ret) stmtC (CmmCall temp_target results temp_args CmmUnsafe ret) stmtC (CmmCall (CmmCallee resumeThread CCallConv) @@ -201,8 +205,9 @@ emitSaveThreadState :: Code emitSaveThreadState = do - -- CurrentTSO->sp = Sp; - stmtC $ CmmStore (cmmOffset stgCurrentTSO tso_SP) stgSp + -- CurrentTSO->stackobj->sp = Sp; + stmtC $ CmmStore (cmmOffset (CmmLoad (cmmOffset stgCurrentTSO tso_stackobj) bWord) + stack_SP) stgSp emitCloseNursery -- and save the current cost centre stack in the TSO when profiling: when opt_SccProfilingOn $ @@ -215,14 +220,17 @@ emitLoadThreadState :: Code emitLoadThreadState = do tso <- newTemp bWord -- TODO FIXME NOW + stack <- newTemp bWord -- TODO FIXME NOW stmtsC [ - -- tso = CurrentTSO; - CmmAssign (CmmLocal tso) stgCurrentTSO, - -- Sp = tso->sp; - CmmAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_SP) - bWord), - -- SpLim = tso->stack + RESERVED_STACK_WORDS; - CmmAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal tso)) tso_STACK) + -- tso = CurrentTSO + CmmAssign (CmmLocal tso) stgCurrentTSO, + -- stack = tso->stackobj + CmmAssign (CmmLocal stack) (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_stackobj) bWord), + -- Sp = stack->sp; + CmmAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal stack)) stack_SP) + bWord), + -- SpLim = stack->stack + RESERVED_STACK_WORDS; + CmmAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal stack)) stack_STACK) rESERVED_STACK_WORDS), -- HpAlloc = 0; -- HpAlloc is assumed to be set to non-zero only by a failed @@ -233,7 +241,7 @@ -- and load the current cost centre stack from the TSO when profiling: when opt_SccProfilingOn $ stmtC (CmmStore curCCSAddr - (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) bWord)) + (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) bWord)) emitOpenNursery :: Code emitOpenNursery = stmtsC [ @@ -261,20 +269,14 @@ nursery_bdescr_start = cmmOffset stgCurrentNursery oFFSET_bdescr_start nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks -tso_SP, tso_STACK, tso_CCCS :: ByteOff -tso_SP = tsoFieldB oFFSET_StgTSO_sp -tso_STACK = tsoFieldB oFFSET_StgTSO_stack -tso_CCCS = tsoProfFieldB oFFSET_StgTSO_CCCS - --- The TSO struct has a variable header, and an optional StgTSOProfInfo in --- the middle. The fields we're interested in are after the StgTSOProfInfo. -tsoFieldB :: ByteOff -> ByteOff -tsoFieldB off - | opt_SccProfilingOn = off + sIZEOF_StgTSOProfInfo + fixedHdrSize * wORD_SIZE - | otherwise = off + fixedHdrSize * wORD_SIZE +tso_stackobj, tso_CCCS, stack_STACK, stack_SP :: ByteOff +tso_stackobj = closureField oFFSET_StgTSO_stackobj +tso_CCCS = closureField oFFSET_StgTSO_CCCS +stack_STACK = closureField oFFSET_StgStack_stack +stack_SP = closureField oFFSET_StgStack_sp -tsoProfFieldB :: ByteOff -> ByteOff -tsoProfFieldB off = off + fixedHdrSize * wORD_SIZE +closureField :: ByteOff -> ByteOff +closureField off = off + fixedHdrSize * wORD_SIZE stgSp, stgHp, stgCurrentTSO, stgCurrentNursery :: CmmExpr stgSp = CmmReg sp diff -Nru ghc-7.0.3/compiler/codeGen/CgHeapery.lhs ghc-7.2.1/compiler/codeGen/CgHeapery.lhs --- ghc-7.0.3/compiler/codeGen/CgHeapery.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/codeGen/CgHeapery.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -34,8 +34,8 @@ import ClosureInfo import SMRep -import Cmm -import CmmUtils +import OldCmm +import OldCmmUtils import Id import DataCon import TyCon @@ -185,7 +185,7 @@ = mkStaticClosure info_lbl ccs payload padding_wds static_link_field saved_info_field where - info_lbl = infoTableLabelFromCI cl_info $ clHasCafRefs cl_info + info_lbl = infoTableLabelFromCI cl_info -- CAFs must have consistent layout, regardless of whether they -- are actually updatable or not. The layout of a CAF is: @@ -302,7 +302,7 @@ -- Strictly speaking, we should tag node here. But if -- node doesn't point to the closure, the code for the closure -- cannot depend on the value of R1 anyway, so we're safe. - closure_lbl = closureLabelFromCI cl_info (clHasCafRefs cl_info) + closure_lbl = closureLabelFromCI cl_info full_save_code = node_asst `plusStmts` reg_save_code @@ -570,8 +570,7 @@ -- Remember, virtHp points to last allocated word, -- ie 1 *before* the info-ptr word of new object. - info_ptr = CmmLit (CmmLabel (infoTableLabelFromCI cl_info - (clHasCafRefs cl_info))) + info_ptr = CmmLit (CmmLabel (infoTableLabelFromCI cl_info)) hdr_w_offsets = initDynHdr info_ptr use_cc `zip` [0..] -- SAY WHAT WE ARE ABOUT TO DO diff -Nru ghc-7.0.3/compiler/codeGen/CgHpc.hs ghc-7.2.1/compiler/codeGen/CgHpc.hs --- ghc-7.0.3/compiler/codeGen/CgHpc.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/codeGen/CgHpc.hs 2011-08-07 17:10:05.000000000 +0000 @@ -6,30 +6,21 @@ -- ----------------------------------------------------------------------------- -module CgHpc (cgTickBox, initHpc, hpcTable) where +module CgHpc (cgTickBox, hpcTable) where -import Cmm +import OldCmm import CLabel import Module -import CmmUtils +import OldCmmUtils import CgUtils import CgMonad -import CgForeignCall -import ForeignCall -import ClosureInfo -import FastString import HscTypes -import Panic -import BasicTypes - -import Data.Char -import Data.Word cgTickBox :: Module -> Int -> Code cgTickBox mod n = do let tick_box = (cmmIndex W64 (CmmLit $ CmmLabel $ mkHpcTicksLabel $ mod) - (fromIntegral n) + n ) stmtsC [ CmmStore tick_box (CmmMachOp (MO_Add W64) @@ -40,47 +31,9 @@ hpcTable :: Module -> HpcInfo -> Code hpcTable this_mod (HpcInfo hpc_tickCount _) = do - emitData ReadOnlyData - [ CmmDataLabel mkHpcModuleNameLabel - , CmmString $ map (fromIntegral . ord) - (full_name_str) - ++ [0] - ] - emitData Data $ [ CmmDataLabel (mkHpcTicksLabel this_mod) - ] ++ - [ CmmStaticLit (CmmInt 0 W64) + emitDataLits (mkHpcTicksLabel this_mod) $ + [ CmmInt 0 W64 | _ <- take hpc_tickCount [0::Int ..] ] - where - module_name_str = moduleNameString (Module.moduleName this_mod) - full_name_str = if modulePackageId this_mod == mainPackageId - then module_name_str - else packageIdString (modulePackageId this_mod) ++ "/" ++ - module_name_str hpcTable _ (NoHpcInfo {}) = error "TODO: impossible" - -initHpc :: Module -> HpcInfo -> Code -initHpc this_mod (HpcInfo tickCount hashNo) - = do { id <- newTemp bWord - ; emitForeignCall' - PlayRisky - [CmmHinted id NoHint] - (CmmCallee - (CmmLit $ CmmLabel $ mkForeignLabel mod_alloc Nothing ForeignLabelInThisPackage IsFunction) - CCallConv - ) - [ CmmHinted (mkLblExpr mkHpcModuleNameLabel) AddrHint - , CmmHinted (word32 tickCount) NoHint - , CmmHinted (word32 hashNo) NoHint - , CmmHinted (CmmLit $ CmmLabel $ mkHpcTicksLabel $ this_mod) AddrHint - ] - (Just []) - NoC_SRT -- No SRT b/c we PlayRisky - CmmMayReturn - } - where - word32 i = CmmLit (CmmInt (fromIntegral (fromIntegral i :: Word32)) W32) - mod_alloc = mkFastString "hs_hpc_module" -initHpc _ (NoHpcInfo {}) = panic "initHpc: NoHpcInfo" - diff -Nru ghc-7.0.3/compiler/codeGen/CgInfoTbls.hs ghc-7.2.1/compiler/codeGen/CgInfoTbls.hs --- ghc-7.0.3/compiler/codeGen/CgInfoTbls.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/codeGen/CgInfoTbls.hs 2011-08-07 17:10:05.000000000 +0000 @@ -31,8 +31,8 @@ import CgUtils import CgMonad -import CmmUtils -import Cmm +import OldCmmUtils +import OldCmm import CLabel import Name import DataCon @@ -53,13 +53,11 @@ -- representation as a list of 'CmmAddr' is handled later -- in the pipeline by 'cmmToRawCmm'. -emitClosureCodeAndInfoTable :: ClosureInfo -> CmmFormals -> CgStmts -> Code +emitClosureCodeAndInfoTable :: ClosureInfo -> [CmmFormal] -> CgStmts -> Code emitClosureCodeAndInfoTable cl_info args body = do { blks <- cgStmtsToBlocks body ; info <- mkCmmInfo cl_info - ; emitInfoTableAndCode (infoLblToEntryLbl info_lbl) info args blks } - where - info_lbl = infoTableLabelFromCI cl_info $ clHasCafRefs cl_info + ; emitInfoTableAndCode (entryLabelFromCI cl_info) info args blks } -- We keep the *zero-indexed* tag in the srt_len field of the info -- table of a data constructor. @@ -84,12 +82,12 @@ info = ConstrInfo (ptrs, nptrs) (fromIntegral (dataConTagZ con)) conName - return $ CmmInfo gc_target Nothing (CmmInfoTable False prof cl_type info) + return $ CmmInfo gc_target Nothing (CmmInfoTable (infoTableLabelFromCI cl_info) False prof cl_type info) ClosureInfo { closureName = name, closureLFInfo = lf_info, closureSRT = srt } -> - return $ CmmInfo gc_target Nothing (CmmInfoTable False prof cl_type info) + return $ CmmInfo gc_target Nothing (CmmInfoTable (infoTableLabelFromCI cl_info) False prof cl_type info) where info = case lf_info of @@ -105,7 +103,7 @@ ThunkInfo (ptrs, nptrs) srt _ -> panic "unexpected lambda form in mkCmmInfo" where - info_lbl = infoTableLabelFromCI cl_info has_caf_refs + info_lbl = infoTableLabelFromCI cl_info has_caf_refs = clHasCafRefs cl_info cl_type = smRepClosureTypeInt (closureSMRep cl_info) @@ -142,16 +140,17 @@ ; let info = CmmInfo gc_target Nothing - (CmmInfoTable False + (CmmInfoTable info_lbl False (ProfilingInfo zeroCLit zeroCLit) rET_SMALL -- cmmToRawCmm may convert it to rET_BIG (ContInfo frame srt_info)) - ; emitInfoTableAndCode (infoLblToEntryLbl info_lbl) info args blks + ; emitInfoTableAndCode entry_lbl info args blks ; return info_lbl } where args = {- trace "emitReturnTarget: missing args" -} [] uniq = getUnique name info_lbl = mkReturnInfoLabel uniq + entry_lbl = mkReturnPtLabel uniq -- The gc_target is to inform the CPS pass when it inserts a stack check. -- Since that pass isn't used yet we'll punt for now. @@ -412,7 +411,7 @@ emitInfoTableAndCode :: CLabel -- Label of entry or ret -> CmmInfo -- ...the info table - -> CmmFormals -- ...args + -> [CmmFormal] -- ...args -> [CmmBasicBlock] -- ...and body -> Code diff -Nru ghc-7.0.3/compiler/codeGen/CgLetNoEscape.lhs ghc-7.2.1/compiler/codeGen/CgLetNoEscape.lhs --- ghc-7.0.3/compiler/codeGen/CgLetNoEscape.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/codeGen/CgLetNoEscape.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -24,8 +24,8 @@ import CgHeapery import CgInfoTbls import CgStackery -import Cmm -import CmmUtils +import OldCmm +import OldCmmUtils import CLabel import ClosureInfo import CostCentre diff -Nru ghc-7.0.3/compiler/codeGen/CgMonad.lhs ghc-7.2.1/compiler/codeGen/CgMonad.lhs --- ghc-7.0.3/compiler/codeGen/CgMonad.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/codeGen/CgMonad.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -63,8 +63,8 @@ import DynFlags import BlockId -import Cmm -import CmmUtils +import OldCmm +import OldCmmUtils import CLabel import StgSyn (SRT) import SMRep @@ -73,9 +73,7 @@ import VarEnv import OrdList import Unique -import Util() import UniqSupply -import FastString() import Outputable import Control.Monad @@ -703,6 +701,8 @@ whenC True code = code whenC False _ = nopC +-- Corresponds to 'emit' in new code generator with a smart constructor +-- from cmm/MkGraph.hs stmtC :: CmmStmt -> Code stmtC stmt = emitCgStmt (CgStmt stmt) @@ -711,7 +711,7 @@ newLabelC :: FCode BlockId newLabelC = do { u <- newUnique - ; return $ BlockId u } + ; return $ mkBlockId u } checkedAbsC :: CmmStmt -> Code -- Emit code, eliminating no-ops @@ -736,18 +736,19 @@ ; setState $ state { cgs_stmts = cgs_stmts state `snocOL` stmt } } -emitData :: Section -> [CmmStatic] -> Code +emitData :: Section -> CmmStatics -> Code emitData sect lits = do { state <- getState ; setState $ state { cgs_tops = cgs_tops state `snocOL` data_block } } where data_block = CmmData sect lits -emitProc :: CmmInfo -> CLabel -> CmmFormals -> [CmmBasicBlock] -> Code -emitProc info lbl args blocks - = do { let proc_block = CmmProc info lbl args (ListGraph blocks) +emitProc :: CmmInfo -> CLabel -> [CmmFormal] -> [CmmBasicBlock] -> Code +emitProc info lbl [] blocks + = do { let proc_block = CmmProc info lbl (ListGraph blocks) ; state <- getState ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } } +emitProc _ _ (_:_) _ = panic "emitProc called with nonempty args" emitSimpleProc :: CLabel -> Code -> Code -- Emit a procedure whose body is the specified code; no info table diff -Nru ghc-7.0.3/compiler/codeGen/CgParallel.hs ghc-7.2.1/compiler/codeGen/CgParallel.hs --- ghc-7.0.3/compiler/codeGen/CgParallel.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/codeGen/CgParallel.hs 2011-08-07 17:10:05.000000000 +0000 @@ -17,7 +17,7 @@ import CgMonad import CgCallConv import Id -import Cmm +import OldCmm import StaticFlags import Outputable import SMRep diff -Nru ghc-7.0.3/compiler/codeGen/CgPrimOp.hs ghc-7.2.1/compiler/codeGen/CgPrimOp.hs --- ghc-7.0.3/compiler/codeGen/CgPrimOp.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/codeGen/CgPrimOp.hs 2011-08-07 17:10:05.000000000 +0000 @@ -10,17 +10,21 @@ cgPrimOp ) where +import BasicTypes import ForeignCall import ClosureInfo import StgSyn import CgForeignCall import CgBindery import CgMonad +import CgHeapery import CgInfoTbls +import CgTicky +import CgProf import CgUtils -import Cmm +import OldCmm import CLabel -import CmmUtils +import OldCmmUtils import PrimOp import SMRep import Module @@ -31,7 +35,7 @@ -- --------------------------------------------------------------------------- -- Code generation for PrimOps -cgPrimOp :: CmmFormals -- where to put the results +cgPrimOp :: [CmmFormal] -- where to put the results -> PrimOp -- the op -> [StgArg] -- arguments -> StgLiveVars -- live vars, in case we need to save them @@ -43,7 +47,7 @@ emitPrimOp results op non_void_args live -emitPrimOp :: CmmFormals -- where to put the results +emitPrimOp :: [CmmFormal] -- where to put the results -> PrimOp -- the op -> [CmmExpr] -- arguments -> StgLiveVars -- live vars, in case we need to save them @@ -123,8 +127,28 @@ NoC_SRT -- No SRT b/c we do PlayRisky CmmMayReturn where + newspark = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "newSpark"))) + +emitPrimOp [res] SparkOp [arg] live = do + -- returns the value of arg in res. We're going to therefore + -- refer to arg twice (once to pass to newSpark(), and once to + -- assign to res), so put it in a temporary. + tmp <- newTemp bWord + stmtC (CmmAssign (CmmLocal tmp) arg) + + vols <- getVolatileRegs live + emitForeignCall' PlayRisky [] + (CmmCallee newspark CCallConv) + [ (CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint) + , (CmmHinted arg AddrHint) ] + (Just vols) + NoC_SRT -- No SRT b/c we do PlayRisky + CmmMayReturn + stmtC (CmmAssign (CmmLocal res) (CmmReg (CmmLocal tmp))) + where newspark = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "newSpark"))) + emitPrimOp [res] ReadMutVarOp [mutv] _ = stmtC (CmmAssign (CmmLocal res) (cmmLoadIndexW mutv fixedHdrSize gcWord)) @@ -205,12 +229,30 @@ emitPrimOp [res] UnsafeFreezeByteArrayOp [arg] _ = stmtC (CmmAssign (CmmLocal res) arg) +emitPrimOp [] CopyArrayOp [src,src_off,dst,dst_off,n] live = + doCopyArrayOp src src_off dst dst_off n live +emitPrimOp [] CopyMutableArrayOp [src,src_off,dst,dst_off,n] live = + doCopyMutableArrayOp src src_off dst dst_off n live +emitPrimOp [res] CloneArrayOp [src,src_off,n] live = + emitCloneArray mkMAP_FROZEN_infoLabel res src src_off n live +emitPrimOp [res] CloneMutableArrayOp [src,src_off,n] live = + emitCloneArray mkMAP_DIRTY_infoLabel res src src_off n live +emitPrimOp [res] FreezeArrayOp [src,src_off,n] live = + emitCloneArray mkMAP_FROZEN_infoLabel res src src_off n live +emitPrimOp [res] ThawArrayOp [src,src_off,n] live = + emitCloneArray mkMAP_DIRTY_infoLabel res src src_off n live + -- Reading/writing pointer arrays emitPrimOp [r] ReadArrayOp [obj,ix] _ = doReadPtrArrayOp r obj ix emitPrimOp [r] IndexArrayOp [obj,ix] _ = doReadPtrArrayOp r obj ix emitPrimOp [] WriteArrayOp [obj,ix,v] _ = doWritePtrArrayOp obj ix v +emitPrimOp [res] SizeofArrayOp [arg] _ + = stmtC $ CmmAssign (CmmLocal res) (cmmLoadIndexW arg (fixedHdrSize + oFFSET_StgMutArrPtrs_ptrs) bWord) +emitPrimOp [res] SizeofMutableArrayOp [arg] live + = emitPrimOp [res] SizeofArrayOp [arg] live + -- IndexXXXoffAddr emitPrimOp res IndexOffAddrOp_Char args _ = doIndexOffAddrOp (Just mo_u_8ToWord) b8 res args @@ -325,6 +367,13 @@ emitPrimOp res WriteByteArrayOp_Word32 args _ = doWriteByteArrayOp (Just mo_WordTo32) b32 res args emitPrimOp res WriteByteArrayOp_Word64 args _ = doWriteByteArrayOp Nothing b64 res args +-- Copying byte arrays + +emitPrimOp [] CopyByteArrayOp [src,src_off,dst,dst_off,n] live = + doCopyByteArrayOp src src_off dst dst_off n live +emitPrimOp [] CopyMutableByteArrayOp [src,src_off,dst,dst_off,n] live = + doCopyMutableByteArrayOp src src_off dst dst_off n live + -- The rest just translate straightforwardly emitPrimOp [res] op [arg] _ @@ -613,3 +662,249 @@ setInfo :: CmmExpr -> CmmExpr -> CmmStmt setInfo closure_ptr info_ptr = CmmStore closure_ptr info_ptr +-- ---------------------------------------------------------------------------- +-- Copying byte arrays + +-- | Takes a source 'ByteArray#', an offset in the source array, a +-- destination 'MutableByteArray#', an offset into the destination +-- array, and the number of bytes to copy. Copies the given number of +-- bytes from the source array to the destination array. +doCopyByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> StgLiveVars -> Code +doCopyByteArrayOp = emitCopyByteArray copy + where + -- Copy data (we assume the arrays aren't overlapping since + -- they're of different types) + copy _src _dst dst_p src_p bytes live = + emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit 1)) live + +-- | Takes a source 'MutableByteArray#', an offset in the source +-- array, a destination 'MutableByteArray#', an offset into the +-- destination array, and the number of bytes to copy. Copies the +-- given number of bytes from the source array to the destination +-- array. +doCopyMutableByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> StgLiveVars -> Code +doCopyMutableByteArrayOp = emitCopyByteArray copy + where + -- The only time the memory might overlap is when the two arrays + -- we were provided are the same array! + -- TODO: Optimize branch for common case of no aliasing. + copy src dst dst_p src_p bytes live = + emitIfThenElse (cmmEqWord src dst) + (emitMemmoveCall dst_p src_p bytes (CmmLit (mkIntCLit 1)) live) + (emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit 1)) live) + +emitCopyByteArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> StgLiveVars -> Code) + -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> StgLiveVars + -> Code +emitCopyByteArray copy src src_off dst dst_off n live = do + dst_p <- assignTemp $ cmmOffsetExpr (cmmOffsetB dst arrWordsHdrSize) dst_off + src_p <- assignTemp $ cmmOffsetExpr (cmmOffsetB src arrWordsHdrSize) src_off + copy src dst dst_p src_p n live + +-- ---------------------------------------------------------------------------- +-- Copying pointer arrays + +-- EZY: This code has an unusually high amount of assignTemp calls, seen +-- nowhere else in the code generator. This is mostly because these +-- "primitive" ops result in a surprisingly large amount of code. It +-- will likely be worthwhile to optimize what is emitted here, so that +-- our optimization passes don't waste time repeatedly optimizing the +-- same bits of code. + +-- | Takes a source 'Array#', an offset in the source array, a +-- destination 'MutableArray#', an offset into the destination array, +-- and the number of elements to copy. Copies the given number of +-- elements from the source array to the destination array. +doCopyArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> StgLiveVars -> Code +doCopyArrayOp = emitCopyArray copy + where + -- Copy data (we assume the arrays aren't overlapping since + -- they're of different types) + copy _src _dst dst_p src_p bytes live = + emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit wORD_SIZE)) live + +-- | Takes a source 'MutableArray#', an offset in the source array, a +-- destination 'MutableArray#', an offset into the destination array, +-- and the number of elements to copy. Copies the given number of +-- elements from the source array to the destination array. +doCopyMutableArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> StgLiveVars -> Code +doCopyMutableArrayOp = emitCopyArray copy + where + -- The only time the memory might overlap is when the two arrays + -- we were provided are the same array! + -- TODO: Optimize branch for common case of no aliasing. + copy src dst dst_p src_p bytes live = + emitIfThenElse (cmmEqWord src dst) + (emitMemmoveCall dst_p src_p bytes (CmmLit (mkIntCLit wORD_SIZE)) live) + (emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit wORD_SIZE)) live) + +emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> StgLiveVars -> Code) + -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> StgLiveVars + -> Code +emitCopyArray copy src0 src_off0 dst0 dst_off0 n0 live = do + -- Assign the arguments to temporaries so the code generator can + -- calculate liveness for us. + src <- assignTemp_ src0 + src_off <- assignTemp_ src_off0 + dst <- assignTemp_ dst0 + dst_off <- assignTemp_ dst_off0 + n <- assignTemp_ n0 + + -- Set the dirty bit in the header. + stmtC (setInfo dst (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel))) + + dst_elems_p <- assignTemp $ cmmOffsetB dst arrPtrsHdrSize + dst_p <- assignTemp $ cmmOffsetExprW dst_elems_p dst_off + src_p <- assignTemp $ cmmOffsetExprW (cmmOffsetB src arrPtrsHdrSize) src_off + bytes <- assignTemp $ cmmMulWord n (CmmLit (mkIntCLit wORD_SIZE)) + + copy src dst dst_p src_p bytes live + + -- The base address of the destination card table + dst_cards_p <- assignTemp $ cmmOffsetExprW dst_elems_p (loadArrPtrsSize dst) + + emitSetCards dst_off dst_cards_p n live + +-- | Takes an info table label, a register to return the newly +-- allocated array in, a source array, an offset in the source array, +-- and the number of elements to copy. Allocates a new array and +-- initializes it form the source array. +emitCloneArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> CmmExpr + -> StgLiveVars -> Code +emitCloneArray info_p res_r src0 src_off0 n0 live = do + -- Assign the arguments to temporaries so the code generator can + -- calculate liveness for us. + src <- assignTemp_ src0 + src_off <- assignTemp_ src_off0 + n <- assignTemp_ n0 + + card_words <- assignTemp $ (n `cmmUShrWord` + (CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS))) + `cmmAddWord` CmmLit (mkIntCLit 1) + size <- assignTemp $ n `cmmAddWord` card_words + words <- assignTemp $ arrPtrsHdrSizeW `cmmAddWord` size + + arr_r <- newTemp bWord + emitAllocateCall arr_r myCapability words live + tickyAllocPrim (CmmLit (mkIntCLit arrPtrsHdrSize)) (n `cmmMulWord` wordSize) + (CmmLit $ mkIntCLit 0) + + let arr = CmmReg (CmmLocal arr_r) + emitSetDynHdr arr (CmmLit (CmmLabel info_p)) curCCSAddr + stmtC $ CmmStore (cmmOffsetB arr (fixedHdrSize * wORD_SIZE + + oFFSET_StgMutArrPtrs_ptrs)) n + stmtC $ CmmStore (cmmOffsetB arr (fixedHdrSize * wORD_SIZE + + oFFSET_StgMutArrPtrs_size)) size + + dst_p <- assignTemp $ cmmOffsetB arr arrPtrsHdrSize + src_p <- assignTemp $ cmmOffsetExprW (cmmOffsetB src arrPtrsHdrSize) + src_off + + emitMemcpyCall dst_p src_p (n `cmmMulWord` wordSize) + (CmmLit (mkIntCLit wORD_SIZE)) live + + emitMemsetCall (cmmOffsetExprW dst_p n) + (CmmLit (mkIntCLit 1)) + (card_words `cmmMulWord` wordSize) + (CmmLit (mkIntCLit wORD_SIZE)) + live + stmtC $ CmmAssign (CmmLocal res_r) arr + where + arrPtrsHdrSizeW = CmmLit $ mkIntCLit $ fixedHdrSize + + (sIZEOF_StgMutArrPtrs_NoHdr `div` wORD_SIZE) + wordSize = CmmLit (mkIntCLit wORD_SIZE) + myCapability = CmmReg baseReg `cmmSubWord` + CmmLit (mkIntCLit oFFSET_Capability_r) + +-- | Takes and offset in the destination array, the base address of +-- the card table, and the number of elements affected (*not* the +-- number of cards). Marks the relevant cards as dirty. +emitSetCards :: CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars -> Code +emitSetCards dst_start dst_cards_start n live = do + start_card <- assignTemp $ card dst_start + emitMemsetCall (dst_cards_start `cmmAddWord` start_card) + (CmmLit (mkIntCLit 1)) + ((card (dst_start `cmmAddWord` n) `cmmSubWord` start_card) + `cmmAddWord` CmmLit (mkIntCLit 1)) + (CmmLit (mkIntCLit wORD_SIZE)) + live + where + -- Convert an element index to a card index + card i = i `cmmUShrWord` (CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS)) + +-- | Emit a call to @memcpy@. +emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars + -> Code +emitMemcpyCall dst src n align live = do + vols <- getVolatileRegs live + emitForeignCall' PlayRisky + [{-no results-}] + (CmmPrim MO_Memcpy) + [ (CmmHinted dst AddrHint) + , (CmmHinted src AddrHint) + , (CmmHinted n NoHint) + , (CmmHinted align NoHint) + ] + (Just vols) + NoC_SRT -- No SRT b/c we do PlayRisky + CmmMayReturn + +-- | Emit a call to @memmove@. +emitMemmoveCall :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars + -> Code +emitMemmoveCall dst src n align live = do + vols <- getVolatileRegs live + emitForeignCall' PlayRisky + [{-no results-}] + (CmmPrim MO_Memmove) + [ (CmmHinted dst AddrHint) + , (CmmHinted src AddrHint) + , (CmmHinted n NoHint) + , (CmmHinted align NoHint) + ] + (Just vols) + NoC_SRT -- No SRT b/c we do PlayRisky + CmmMayReturn + +-- | Emit a call to @memset@. The second argument must be a word but +-- its value must fit inside an unsigned char. +emitMemsetCall :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> StgLiveVars + -> Code +emitMemsetCall dst c n align live = do + vols <- getVolatileRegs live + emitForeignCall' PlayRisky + [{-no results-}] + (CmmPrim MO_Memset) + [ (CmmHinted dst AddrHint) + , (CmmHinted c NoHint) + , (CmmHinted n NoHint) + , (CmmHinted align NoHint) + ] + (Just vols) + NoC_SRT -- No SRT b/c we do PlayRisky + CmmMayReturn + +-- | Emit a call to @allocate@. +emitAllocateCall :: LocalReg -> CmmExpr -> CmmExpr -> StgLiveVars -> Code +emitAllocateCall res cap n live = do + vols <- getVolatileRegs live + emitForeignCall' PlayRisky + [CmmHinted res AddrHint] + (CmmCallee allocate CCallConv) + [ (CmmHinted cap AddrHint) + , (CmmHinted n NoHint) + ] + (Just vols) + NoC_SRT -- No SRT b/c we do PlayRisky + CmmMayReturn + where + allocate = CmmLit (CmmLabel (mkForeignLabel (fsLit "allocate") Nothing + ForeignLabelInExternalPackage IsFunction)) diff -Nru ghc-7.0.3/compiler/codeGen/CgProf.hs ghc-7.2.1/compiler/codeGen/CgProf.hs --- ghc-7.0.3/compiler/codeGen/CgProf.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/codeGen/CgProf.hs 2011-08-07 17:10:05.000000000 +0000 @@ -16,8 +16,7 @@ costCentreFrom, curCCS, curCCSAddr, emitCostCentreDecl, emitCostCentreStackDecl, - emitRegisterCC, emitRegisterCCS, - emitSetCCC, emitCCS, + emitSetCCC, emitCCS, -- Lag/drag/void stuff ldvEnter, ldvEnterClosure, ldvRecordCreate @@ -37,8 +36,8 @@ import CgMonad import SMRep -import Cmm -import CmmUtils +import OldCmm +import OldCmmUtils import CLabel import Id @@ -348,56 +347,6 @@ (ws,ms) = SIZEOF_CostCentreStack `divMod` wORD_SIZE -- --------------------------------------------------------------------------- --- Registering CCs and CCSs - --- (cc)->link = CC_LIST; --- CC_LIST = (cc); --- (cc)->ccID = CC_ID++; - -emitRegisterCC :: CostCentre -> Code -emitRegisterCC cc = do - { tmp <- newTemp cInt - ; stmtsC [ - CmmStore (cmmOffsetB cc_lit oFFSET_CostCentre_link) - (CmmLoad cC_LIST bWord), - CmmStore cC_LIST cc_lit, - CmmAssign (CmmLocal tmp) (CmmLoad cC_ID cInt), - CmmStore (cmmOffsetB cc_lit oFFSET_CostCentre_ccID) (CmmReg (CmmLocal tmp)), - CmmStore cC_ID (cmmRegOffB (CmmLocal tmp) 1) - ] - } - where - cc_lit = CmmLit (CmmLabel (mkCCLabel cc)) - --- (ccs)->prevStack = CCS_LIST; --- CCS_LIST = (ccs); --- (ccs)->ccsID = CCS_ID++; - -emitRegisterCCS :: CostCentreStack -> Code -emitRegisterCCS ccs = do - { tmp <- newTemp cInt - ; stmtsC [ - CmmStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_prevStack) - (CmmLoad cCS_LIST bWord), - CmmStore cCS_LIST ccs_lit, - CmmAssign (CmmLocal tmp) (CmmLoad cCS_ID cInt), - CmmStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_ccsID) (CmmReg (CmmLocal tmp)), - CmmStore cCS_ID (cmmRegOffB (CmmLocal tmp) 1) - ] - } - where - ccs_lit = CmmLit (CmmLabel (mkCCSLabel ccs)) - - -cC_LIST, cC_ID :: CmmExpr -cC_LIST = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CC_LIST"))) -cC_ID = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CC_ID"))) - -cCS_LIST, cCS_ID :: CmmExpr -cCS_LIST = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CCS_LIST"))) -cCS_ID = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CCS_ID"))) - --- --------------------------------------------------------------------------- -- Set the current cost centre stack emitSetCCC :: CostCentre -> Code diff -Nru ghc-7.0.3/compiler/codeGen/CgStackery.lhs ghc-7.2.1/compiler/codeGen/CgStackery.lhs --- ghc-7.0.3/compiler/codeGen/CgStackery.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/codeGen/CgStackery.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -26,8 +26,8 @@ import CgUtils import CgProf import SMRep -import Cmm -import CmmUtils +import OldCmm +import OldCmmUtils import CLabel import Constants import Util diff -Nru ghc-7.0.3/compiler/codeGen/CgTailCall.lhs ghc-7.2.1/compiler/codeGen/CgTailCall.lhs --- ghc-7.0.3/compiler/codeGen/CgTailCall.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/codeGen/CgTailCall.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -28,8 +28,8 @@ import CgTicky import ClosureInfo import SMRep -import Cmm -import CmmUtils +import OldCmm +import OldCmmUtils import CLabel import Type import Id diff -Nru ghc-7.0.3/compiler/codeGen/CgTicky.hs ghc-7.2.1/compiler/codeGen/CgTicky.hs --- ghc-7.0.3/compiler/codeGen/CgTicky.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/codeGen/CgTicky.hs 2011-08-07 17:10:05.000000000 +0000 @@ -44,8 +44,8 @@ import CgMonad import SMRep -import Cmm -import CmmUtils +import OldCmm +import OldCmmUtils import CLabel import Name diff -Nru ghc-7.0.3/compiler/codeGen/CgUtils.hs ghc-7.2.1/compiler/codeGen/CgUtils.hs --- ghc-7.0.3/compiler/codeGen/CgUtils.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/codeGen/CgUtils.hs 2011-08-07 17:10:05.000000000 +0000 @@ -20,7 +20,7 @@ emitRODataLits, mkRODataLits, emitIf, emitIfThenElse, emitRtsCall, emitRtsCallWithVols, emitRtsCallWithResult, - assignTemp, newTemp, + assignTemp, assignTemp_, newTemp, emitSimultaneously, emitSwitch, emitLitSwitch, tagToClosure, @@ -29,7 +29,7 @@ activeStgRegs, fixStgRegisters, cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord, - cmmUGtWord, + cmmUGtWord, cmmSubWord, cmmMulWord, cmmAddWord, cmmUShrWord, cmmOffsetExprW, cmmOffsetExprB, cmmRegOffW, cmmRegOffB, cmmLabelOffW, cmmLabelOffB, @@ -47,7 +47,7 @@ packHalfWordsCLit, blankWord, - getSRTInfo, clHasCafRefs + getSRTInfo ) where #include "HsVersions.h" @@ -61,10 +61,9 @@ import IdInfo import Constants import SMRep -import PprCmm ( {- instances -} ) -import Cmm +import OldCmm +import OldCmmUtils import CLabel -import CmmUtils import ForeignCall import ClosureInfo import StgSyn (SRT(..)) @@ -181,8 +180,10 @@ cmmUGeWord e1 e2 = CmmMachOp mo_wordUGe [e1, e2] cmmUGtWord e1 e2 = CmmMachOp mo_wordUGt [e1, e2] --cmmShlWord e1 e2 = CmmMachOp mo_wordShl [e1, e2] ---cmmUShrWord e1 e2 = CmmMachOp mo_wordUShr [e1, e2] +cmmUShrWord e1 e2 = CmmMachOp mo_wordUShr [e1, e2] +cmmAddWord e1 e2 = CmmMachOp mo_wordAdd [e1, e2] cmmSubWord e1 e2 = CmmMachOp mo_wordSub [e1, e2] +cmmMulWord e1 e2 = CmmMachOp mo_wordMul [e1, e2] cmmNegate :: CmmExpr -> CmmExpr cmmNegate (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep) @@ -544,26 +545,26 @@ emitDataLits :: CLabel -> [CmmLit] -> Code -- Emit a data-segment data block emitDataLits lbl lits - = emitData Data (CmmDataLabel lbl : map CmmStaticLit lits) + = emitData Data (Statics lbl $ map CmmStaticLit lits) -mkDataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info graph +mkDataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatics info graph -- Emit a data-segment data block mkDataLits lbl lits - = CmmData Data (CmmDataLabel lbl : map CmmStaticLit lits) + = CmmData Data (Statics lbl $ map CmmStaticLit lits) emitRODataLits :: String -> CLabel -> [CmmLit] -> Code -- Emit a read-only data block emitRODataLits caller lbl lits - = emitData section (CmmDataLabel lbl : map CmmStaticLit lits) + = emitData section (Statics lbl $ map CmmStaticLit lits) where section | any needsRelocation lits = RelocatableReadOnlyData | otherwise = ReadOnlyData needsRelocation (CmmLabel _) = True needsRelocation (CmmLabelOff _ _) = True needsRelocation _ = False -mkRODataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info graph +mkRODataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatics info graph mkRODataLits lbl lits - = CmmData section (CmmDataLabel lbl : map CmmStaticLit lits) + = CmmData section (Statics lbl $ map CmmStaticLit lits) where section | any needsRelocation lits = RelocatableReadOnlyData | otherwise = ReadOnlyData needsRelocation (CmmLabel _) = True @@ -579,7 +580,7 @@ mkByteStringCLit bytes = do { uniq <- newUnique ; let lbl = mkStringLitLabel uniq - ; emitData ReadOnlyData [CmmDataLabel lbl, CmmString bytes] + ; emitData ReadOnlyData $ Statics lbl [CmmString bytes] ; return (CmmLabel lbl) } ------------------------------------------------------------------------- @@ -588,6 +589,9 @@ -- ------------------------------------------------------------------------- +-- | If the expression is trivial, return it. Otherwise, assign the +-- expression to a temporary register and return an expression +-- referring to this register. assignTemp :: CmmExpr -> FCode CmmExpr -- For a non-trivial expression, e, create a local -- variable and assign the expression to it @@ -597,6 +601,18 @@ ; stmtC (CmmAssign (CmmLocal reg) e) ; return (CmmReg (CmmLocal reg)) } +-- | If the expression is trivial and doesn't refer to a global +-- register, return it. Otherwise, assign the expression to a +-- temporary register and return an expression referring to this +-- register. +assignTemp_ :: CmmExpr -> FCode CmmExpr +assignTemp_ e + | isTrivialCmmExpr e && hasNoGlobalRegs e = return e + | otherwise = do + reg <- newTemp (cmmExprType e) + stmtC (CmmAssign (CmmLocal reg) e) + return (CmmReg (CmmLocal reg)) + newTemp :: CmmType -> FCode LocalReg newTemp rep = do { uniq <- newUnique; return (LocalReg uniq rep) } @@ -979,12 +995,6 @@ srt_escape = (-1) :: StgHalfWord -clHasCafRefs :: ClosureInfo -> CafInfo -clHasCafRefs (ClosureInfo {closureSRT = srt}) = - case srt of NoC_SRT -> NoCafRefs - _ -> MayHaveCafRefs -clHasCafRefs (ConInfo {}) = NoCafRefs - -- ----------------------------------------------------------------------------- -- -- STG/Cmm GlobalReg @@ -1081,9 +1091,9 @@ fixStgRegisters :: RawCmmTop -> RawCmmTop fixStgRegisters top@(CmmData _ _) = top -fixStgRegisters (CmmProc info lbl params (ListGraph blocks)) = +fixStgRegisters (CmmProc info lbl (ListGraph blocks)) = let blocks' = map fixStgRegBlock blocks - in CmmProc info lbl params $ ListGraph blocks' + in CmmProc info lbl $ ListGraph blocks' fixStgRegBlock :: CmmBasicBlock -> CmmBasicBlock fixStgRegBlock (BasicBlock id stmts) = diff -Nru ghc-7.0.3/compiler/codeGen/ClosureInfo.lhs ghc-7.2.1/compiler/codeGen/ClosureInfo.lhs --- ghc-7.0.3/compiler/codeGen/ClosureInfo.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/codeGen/ClosureInfo.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -29,13 +29,13 @@ closureGoodStuffSize, closurePtrsSize, slopSize, - infoTableLabelFromCI, + infoTableLabelFromCI, entryLabelFromCI, closureLabelFromCI, isLFThunk, closureUpdReqd, closureNeedsUpdSpace, closureIsThunk, closureSingleEntry, closureReEntrant, isConstrClosure_maybe, closureFunInfo, isStandardFormThunk, isKnownFun, - funTag, funTagLFInfo, tagForArity, + funTag, funTagLFInfo, tagForArity, clHasCafRefs, enterIdLabel, enterLocalIdLabel, enterReturnPtLabel, @@ -59,7 +59,6 @@ #include "../includes/MachDeps.h" #include "HsVersions.h" ---import CgUtils import StgSyn import SMRep @@ -111,7 +110,8 @@ closureSMRep :: !SMRep, -- representation used by storage mgr closureSRT :: !C_SRT, -- What SRT applies to this closure closureType :: !Type, -- Type of closure (ToDo: remove) - closureDescr :: !String -- closure description (for profiling) + closureDescr :: !String, -- closure description (for profiling) + closureInfLcl :: Bool -- can the info pointer be a local symbol? } -- Constructor closures don't have a unique info table label (they use @@ -184,7 +184,6 @@ | LFBlackHole -- Used for the closures allocated to hold the result -- of a CAF. We want the target of the update frame to -- be in the heap, so we make a black hole to hold it. - CLabel -- Flavour (info label, eg CAF_BLACKHOLE_info). ------------------------- @@ -314,7 +313,7 @@ \begin{code} isLFThunk :: LambdaFormInfo -> Bool isLFThunk (LFThunk _ _ _ _ _) = True -isLFThunk (LFBlackHole _) = True +isLFThunk LFBlackHole = True -- return True for a blackhole: this function is used to determine -- whether to use the thunk header in SMP mode, and a blackhole -- must have one. @@ -341,7 +340,12 @@ closureSMRep = sm_rep, closureSRT = srt_info, closureType = idType id, - closureDescr = descr } + closureDescr = descr, + closureInfLcl = isDataConWorkId id } + -- Make the _info pointer for the implicit datacon worker binding + -- local. The reason we can do this is that importing code always + -- either uses the _closure or _con_info. By the invariants in CorePrep + -- anything else gets eta expanded. where name = idName id sm_rep = chooseSMRep is_static lf_info tot_wds ptr_wds @@ -524,7 +528,7 @@ = True -- Node must point to any standard-form thunk nodeMustPointToIt (LFUnknown _) = True -nodeMustPointToIt (LFBlackHole _) = True -- BH entry may require Node to point +nodeMustPointToIt LFBlackHole = True -- BH entry may require Node to point nodeMustPointToIt (LFLetNoEscape _) = False \end{code} @@ -642,7 +646,7 @@ | otherwise = EnterIt -- Not a function -getCallMethod _ _ _ (LFBlackHole _) _ +getCallMethod _ _ _ LFBlackHole _ = SlowCall -- Presumably the black hole has by now -- been updated, but we don't know with -- what, so we slow call it @@ -842,7 +846,6 @@ %************************************************************************ \begin{code} - isStaticClosure :: ClosureInfo -> Bool isStaticClosure cl_info = isStaticRep (closureSMRep cl_info) @@ -852,7 +855,7 @@ lfUpdatable :: LambdaFormInfo -> Bool lfUpdatable (LFThunk _ _ upd _ _) = upd -lfUpdatable (LFBlackHole _) = True +lfUpdatable LFBlackHole = True -- Black-hole closures are allocated to receive the results of an -- alg case with a named default... so they need to be updated. lfUpdatable _ = False @@ -900,6 +903,12 @@ tagForArity :: Int -> Maybe Int tagForArity i | i <= mAX_PTR_TAG = Just i | otherwise = Nothing + +clHasCafRefs :: ClosureInfo -> CafInfo +clHasCafRefs (ClosureInfo {closureSRT = srt}) = + case srt of NoC_SRT -> NoCafRefs + _ -> MayHaveCafRefs +clHasCafRefs (ConInfo {}) = NoCafRefs \end{code} \begin{code} @@ -915,35 +924,46 @@ Label generation. \begin{code} -infoTableLabelFromCI :: ClosureInfo -> CafInfo -> CLabel -infoTableLabelFromCI (ClosureInfo { closureName = name, - closureLFInfo = lf_info }) caf +infoTableLabelFromCI :: ClosureInfo -> CLabel +infoTableLabelFromCI = fst . labelsFromCI + +entryLabelFromCI :: ClosureInfo -> CLabel +entryLabelFromCI = snd . labelsFromCI + +labelsFromCI :: ClosureInfo -> (CLabel, CLabel) -- (Info, Entry) +labelsFromCI cl@(ClosureInfo { closureName = name, + closureLFInfo = lf_info, + closureInfLcl = is_lcl }) = case lf_info of - LFBlackHole info -> info + LFBlackHole -> (mkCAFBlackHoleInfoTableLabel, mkCAFBlackHoleEntryLabel) LFThunk _ _ upd_flag (SelectorThunk offset) _ -> - mkSelectorInfoLabel upd_flag offset + bothL (mkSelectorInfoLabel, mkSelectorEntryLabel) upd_flag offset LFThunk _ _ upd_flag (ApThunk arity) _ -> - mkApInfoTableLabel upd_flag arity + bothL (mkApInfoTableLabel, mkApEntryLabel) upd_flag arity - LFThunk{} -> mkLocalInfoTableLabel name caf + LFThunk{} -> bothL std_mk_lbls name $ clHasCafRefs cl - LFReEntrant _ _ _ _ -> mkLocalInfoTableLabel name caf + LFReEntrant _ _ _ _ -> bothL std_mk_lbls name $ clHasCafRefs cl - _ -> panic "infoTableLabelFromCI" + _ -> panic "labelsFromCI" + where std_mk_lbls = if is_lcl then (mkLocalInfoTableLabel, mkLocalEntryLabel) else (mkInfoTableLabel, mkEntryLabel) -infoTableLabelFromCI (ConInfo { closureCon = con, - closureSMRep = rep }) caf - | isStaticRep rep = mkStaticInfoTableLabel name caf - | otherwise = mkConInfoTableLabel name caf +labelsFromCI cl@(ConInfo { closureCon = con, + closureSMRep = rep }) + | isStaticRep rep = bothL (mkStaticInfoTableLabel, mkStaticConEntryLabel) name $ clHasCafRefs cl + | otherwise = bothL (mkConInfoTableLabel, mkConEntryLabel) name $ clHasCafRefs cl where name = dataConName con +bothL :: (a -> b -> c, a -> b -> c) -> a -> b -> (c, c) +bothL (f, g) x y = (f x y, g x y) + -- ClosureInfo for a closure (as opposed to a constructor) is always local -closureLabelFromCI :: ClosureInfo -> CafInfo -> CLabel -closureLabelFromCI (ClosureInfo { closureName = nm }) caf = mkLocalClosureLabel nm caf -closureLabelFromCI _ _ = panic "closureLabelFromCI" +closureLabelFromCI :: ClosureInfo -> CLabel +closureLabelFromCI cl@(ClosureInfo { closureName = nm }) = mkLocalClosureLabel nm $ clHasCafRefs cl +closureLabelFromCI _ = panic "closureLabelFromCI" -- thunkEntryLabel is a local help function, not exported. It's used from both -- entryLabelFromCI and getCallMethod. @@ -999,11 +1019,12 @@ cafBlackHoleClosureInfo (ClosureInfo { closureName = nm, closureType = ty }) = ClosureInfo { closureName = nm, - closureLFInfo = LFBlackHole mkCAFBlackHoleInfoTableLabel, + closureLFInfo = LFBlackHole, closureSMRep = BlackHoleRep, closureSRT = NoC_SRT, closureType = ty, - closureDescr = "" } + closureDescr = "", + closureInfLcl = False } cafBlackHoleClosureInfo _ = panic "cafBlackHoleClosureInfo" \end{code} @@ -1052,5 +1073,5 @@ getPredTyDescription :: PredType -> String getPredTyDescription (ClassP cl _) = getOccString cl getPredTyDescription (IParam ip _) = getOccString (ipNameName ip) -getPredTyDescription (EqPred _ _) = panic "getPredTyDescription EqPred" +getPredTyDescription (EqPred _ _) = "Type equality" \end{code} diff -Nru ghc-7.0.3/compiler/codeGen/CodeGen.lhs ghc-7.2.1/compiler/codeGen/CodeGen.lhs --- ghc-7.0.3/compiler/codeGen/CodeGen.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/codeGen/CodeGen.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -28,9 +28,8 @@ import CgHpc import CLabel -import Cmm -import CmmUtils -import PprCmm +import OldCmm +import OldPprCmm import StgSyn import PrelNames @@ -51,8 +50,7 @@ codeGen :: DynFlags -> Module -> [TyCon] - -> [Module] -- directly-imported modules - -> CollectedCCs -- (Local/global) cost-centres needing declaring/registering. + -> CollectedCCs -- (Local/global) cost-centres needing declaring/registering. -> [(StgBinding,[(Id,[Id])])] -- Bindings to convert, with SRTs -> HpcInfo -> IO [Cmm] -- Output @@ -61,8 +59,7 @@ -- possible for object splitting to split up the -- pieces later. -codeGen dflags this_mod data_tycons imported_mods - cost_centre_info stg_binds hpc_info +codeGen dflags this_mod data_tycons cost_centre_info stg_binds hpc_info = do { showPass dflags "CodeGen" @@ -73,167 +70,46 @@ { cmm_binds <- mapM (getCmm . cgTopBinding dflags) stg_binds ; cmm_tycons <- mapM cgTyCon data_tycons ; cmm_init <- getCmm (mkModuleInit dflags cost_centre_info - this_mod imported_mods hpc_info) - ; return (cmm_binds ++ concat cmm_tycons ++ [cmm_init]) + this_mod hpc_info) + ; return (cmm_init : cmm_binds ++ concat cmm_tycons) } -- Put datatype_stuff after code_stuff, because the -- datatype closure table (for enumeration types) to -- (say) PrelBase_True_closure, which is defined in -- code_stuff - ; dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms code_stuff) + -- Note [codegen-split-init] the cmm_init block must + -- come FIRST. This is because when -split-objs is on + -- we need to combine this block with its + -- initialisation routines; see Note + -- [pipeline-split-init]. - ; return code_stuff } -\end{code} - -%************************************************************************ -%* * -\subsection[codegen-init]{Module initialisation code} -%* * -%************************************************************************ - -/* ----------------------------------------------------------------------------- - Module initialisation - - The module initialisation code looks like this, roughly: - - FN(__stginit_Foo) { - JMP_(__stginit_Foo_1_p) - } - - FN(__stginit_Foo_1_p) { - ... - } - - We have one version of the init code with a module version and the - 'way' attached to it. The version number helps to catch cases - where modules are not compiled in dependency order before being - linked: if a module has been compiled since any modules which depend on - it, then the latter modules will refer to a different version in their - init blocks and a link error will ensue. - - The 'way' suffix helps to catch cases where modules compiled in different - ways are linked together (eg. profiled and non-profiled). - - We provide a plain, unadorned, version of the module init code - which just jumps to the version with the label and way attached. The - reason for this is that when using foreign exports, the caller of - startupHaskell() must supply the name of the init function for the "top" - module in the program, and we don't want to require that this name - has the version and way info appended to it. - -------------------------------------------------------------------------- */ - -We initialise the module tree by keeping a work-stack, - * pointed to by Sp - * that grows downward - * Sp points to the last occupied slot + ; dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms (targetPlatform dflags) code_stuff) + ; return code_stuff } -\begin{code} -mkModuleInit +mkModuleInit :: DynFlags -> CollectedCCs -- cost centre info -> Module - -> [Module] - -> HpcInfo + -> HpcInfo -> Code -mkModuleInit dflags cost_centre_info this_mod imported_mods hpc_info - = do { -- Allocate the static boolean that records if this - -- module has been registered already - emitData Data [CmmDataLabel moduleRegdLabel, - CmmStaticLit zeroCLit] +mkModuleInit dflags cost_centre_info this_mod hpc_info + = do { -- Allocate the static boolean that records if this ; whenC (opt_Hpc) $ hpcTable this_mod hpc_info - -- we emit a recursive descent module search for all modules - -- and *choose* to chase it in :Main, below. - -- In this way, Hpc enabled modules can interact seamlessly with - -- not Hpc enabled moduled, provided Main is compiled with Hpc. - - ; emitSimpleProc real_init_lbl $ do - { ret_blk <- forkLabelledCode ret_code - - ; init_blk <- forkLabelledCode $ do - { mod_init_code; stmtC (CmmBranch ret_blk) } - - ; stmtC (CmmCondBranch (cmmNeWord (CmmLit zeroCLit) mod_reg_val) - ret_blk) - ; stmtC (CmmBranch init_blk) - } - - -- Make the "plain" procedure jump to the "real" init procedure - ; emitSimpleProc plain_init_lbl jump_to_init - - -- When compiling the module in which the 'main' function lives, - -- (that is, this_mod == main_mod) - -- we inject an extra stg_init procedure for stg_init_ZCMain, for the - -- RTS to invoke. We must consult the -main-is flag in case the - -- user specified a different function to Main.main - - -- Notice that the recursive descent is optional, depending on what options - -- are enabled. - - ; whenC (this_mod == main_mod) - (emitSimpleProc plain_main_init_lbl rec_descent_init) - } - where - -- The way string we attach to the __stginit label to catch - -- accidental linking of modules compiled in different ways. We - -- omit "dyn" from this way, because we want to be able to load - -- both dynamic and non-dynamic modules into a dynamic GHC. - way = mkBuildTag (filter want_way (ways dflags)) - want_way w = not (wayRTSOnly w) && wayName w /= WayDyn - - main_mod = mainModIs dflags - - plain_init_lbl = mkPlainModuleInitLabel this_mod - real_init_lbl = mkModuleInitLabel this_mod way - plain_main_init_lbl = mkPlainModuleInitLabel rOOT_MAIN - - jump_to_init = stmtC (CmmJump (mkLblExpr real_init_lbl) []) - - mod_reg_val = CmmLoad (mkLblExpr moduleRegdLabel) bWord - - -- Main refers to GHC.TopHandler.runIO, so make sure we call the - -- init function for GHC.TopHandler. - extra_imported_mods - | this_mod == main_mod = [gHC_TOP_HANDLER] - | otherwise = [] - - mod_init_code = do - { -- Set mod_reg to 1 to record that we've been here - stmtC (CmmStore (mkLblExpr moduleRegdLabel) (CmmLit (mkIntCLit 1))) - ; whenC (opt_SccProfilingOn) $ do initCostCentres cost_centre_info - ; whenC (opt_Hpc) $ - initHpc this_mod hpc_info - - ; mapCs (registerModuleImport way) - (imported_mods++extra_imported_mods) - - } - - -- The return-code pops the work stack by - -- incrementing Sp, and then jumpd to the popped item - ret_code = stmtsC [ CmmAssign spReg (cmmRegOffW spReg 1) - , CmmJump (CmmLoad (cmmRegOffW spReg (-1)) bWord) [] ] - - - rec_descent_init = if opt_SccProfilingOn || isHpcUsed hpc_info - then jump_to_init - else ret_code - ------------------------ -registerModuleImport :: String -> Module -> Code -registerModuleImport way mod - | mod == gHC_PRIM - = nopC - | otherwise -- Push the init procedure onto the work stack - = stmtsC [ CmmAssign spReg (cmmRegOffW spReg (-1)) - , CmmStore (CmmReg spReg) (mkLblExpr (mkModuleInitLabel mod way)) ] + -- For backwards compatibility: user code may refer to this + -- label for calling hs_add_root(). + ; emitData Data $ Statics (mkPlainModuleInitLabel this_mod) [] + + ; whenC (this_mod == mainModIs dflags) $ + emitSimpleProc (mkPlainModuleInitLabel rOOT_MAIN) $ return () + } \end{code} @@ -252,9 +128,7 @@ | otherwise = do { mapM_ emitCostCentreDecl local_CCs ; mapM_ emitCostCentreStackDecl singleton_CCSs - ; mapM_ emitRegisterCC local_CCs - ; mapM_ emitRegisterCCS singleton_CCSs - } + } \end{code} %************************************************************************ diff -Nru ghc-7.0.3/compiler/codeGen/SMRep.lhs ghc-7.2.1/compiler/codeGen/SMRep.lhs --- ghc-7.0.3/compiler/codeGen/SMRep.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/codeGen/SMRep.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -39,7 +39,7 @@ #include "../includes/MachDeps.h" -import CmmExpr -- CmmType and friends +import CmmType import Id import Type import TyCon diff -Nru ghc-7.0.3/compiler/codeGen/StgCmmBind.hs ghc-7.2.1/compiler/codeGen/StgCmmBind.hs --- ghc-7.0.3/compiler/codeGen/StgCmmBind.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/codeGen/StgCmmBind.hs 2011-08-07 17:10:05.000000000 +0000 @@ -6,8 +6,8 @@ -- ----------------------------------------------------------------------------- -module StgCmmBind ( - cgTopRhsClosure, +module StgCmmBind ( + cgTopRhsClosure, cgBind, emitBlackHoleCode, pushUpdateFrame @@ -26,15 +26,17 @@ import StgCmmLayout import StgCmmUtils import StgCmmClosure +import StgCmmForeign (emitPrimCall) -import MkZipCfgCmm +import MkGraph import CoreSyn ( AltCon(..) ) import SMRep -import Cmm +import CmmDecl +import CmmExpr import CmmUtils import CLabel import StgSyn -import CostCentre +import CostCentre import Id import Control.Monad import Name @@ -78,7 +80,7 @@ -- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY) ; emitDataLits closure_label closure_rep ; let fv_details :: [(NonVoid Id, VirtualHpOffset)] - (_, _, fv_details) = mkVirtHeapOffsets (isLFThunk lf_info) + (_, _, fv_details) = mkVirtHeapOffsets (isLFThunk lf_info) (addIdReps []) -- Don't drop the non-void args until the closure info has been made ; forkClosureBody (closureCodeBody True id closure_info ccs @@ -97,7 +99,7 @@ ; emit (init <*> body) } cgBind (StgRec pairs) - = do { ((new_binds, inits), body) <- getCodeR $ fixC (\ new_binds_inits -> + = do { ((new_binds, inits), body) <- getCodeR $ fixC (\ new_binds_inits -> do { addBindsC $ fst new_binds_inits -- avoid premature deconstruction ; liftM unzip $ listFCs [ cgRhs b e | (b,e) <- pairs ] }) ; addBindsC new_binds @@ -125,7 +127,7 @@ m[hp-40] = y_info; // allocate and initialize z ... - + For each closure, we must generate not only the code to allocate and initialize the closure itself, but also some Initialization Code that sets a variable holding the closure pointer. @@ -239,9 +241,9 @@ body@(StgApp fun_id args) | args `lengthIs` (arity-1) - && all isFollowableArg (map (idCgRep . stripNV) fvs) + && all isFollowableArg (map (idCgRep . stripNV) fvs) && isUpdatable upd_flag - && arity <= mAX_SPEC_AP_SIZE + && arity <= mAX_SPEC_AP_SIZE -- Ha! an Ap thunk = cgStdThunk bndr cc bi body lf_info payload @@ -268,7 +270,7 @@ reduced_fvs | bndr_is_a_fv = fvs `minusList` [NonVoid bndr] | otherwise = fvs - + -- MAKE CLOSURE INFO FOR THIS CLOSURE ; lf_info <- mkClosureLFInfo bndr NotTopLevel fvs upd_flag args ; mod_name <- getModuleName @@ -276,8 +278,8 @@ ; let name = idName bndr descr = closureDescription mod_name name fv_details :: [(NonVoid Id, VirtualHpOffset)] - (tot_wds, ptr_wds, fv_details) - = mkVirtHeapOffsets (isLFThunk lf_info) + (tot_wds, ptr_wds, fv_details) + = mkVirtHeapOffsets (isLFThunk lf_info) (addIdReps (map stripNV reduced_fvs)) closure_info = mkClosureInfo False -- Not static bndr lf_info tot_wds ptr_wds @@ -295,11 +297,11 @@ ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body ; emit (mkComment $ mkFastString "calling allocDynClosure") ; let toVarArg (NonVoid a, off) = (NonVoid (StgVarArg a), off) - ; (tmp, init) <- allocDynClosure closure_info use_cc blame_cc + ; (tmp, init) <- allocDynClosure closure_info use_cc blame_cc (map toVarArg fv_details) - + -- RETURN - ; return $ (regIdInfo bndr lf_info tmp, init) } + ; regIdInfo bndr lf_info tmp init } -- Use with care; if used inappropriately, it could break invariants. stripNV :: NonVoid a -> a @@ -319,12 +321,12 @@ = do -- AHA! A STANDARD-FORM THUNK { -- LAY OUT THE OBJECT mod_name <- getModuleName - ; let (tot_wds, ptr_wds, payload_w_offsets) + ; let (tot_wds, ptr_wds, payload_w_offsets) = mkVirtHeapOffsets (isLFThunk lf_info) (addArgReps payload) descr = closureDescription mod_name (idName bndr) closure_info = mkClosureInfo False -- Not static - bndr lf_info tot_wds ptr_wds + bndr lf_info tot_wds ptr_wds NoC_SRT -- No SRT for a std-form closure descr @@ -334,7 +336,7 @@ ; (tmp, init) <- allocDynClosure closure_info use_cc blame_cc payload_w_offsets -- RETURN - ; returnFC $ (regIdInfo bndr lf_info tmp, init) } + ; regIdInfo bndr lf_info tmp init } mkClosureLFInfo :: Id -- The binder -> TopLevelFlag -- True of top level @@ -359,10 +361,10 @@ -> [NonVoid Id] -- incoming args to the closure -> Int -- arity, including void args -> StgExpr - -> [(NonVoid Id, VirtualHpOffset)] -- the closure's free variables + -> [(NonVoid Id, VirtualHpOffset)] -- the closure's free vars -> FCode () -{- There are two main cases for the code for closures. +{- There are two main cases for the code for closures. * If there are *no arguments*, then the closure is a thunk, and not in normal form. So it should set up an update frame (if it is @@ -372,42 +374,46 @@ normal form, so there is no need to set up an update frame. The Macros for GrAnSim are produced at the beginning of the - argSatisfactionCheck (by calling fetchAndReschedule). + argSatisfactionCheck (by calling fetchAndReschedule). There info if Node points to closure is available. -- HWL -} closureCodeBody top_lvl bndr cl_info cc args arity body fv_details | length args == 0 -- No args i.e. thunk = emitClosureProcAndInfoTable top_lvl bndr cl_info [] $ - (\ (node, _) -> thunkCode cl_info fv_details cc node arity body) + \(_, node, _) -> thunkCode cl_info fv_details cc node arity body closureCodeBody top_lvl bndr cl_info cc args arity body fv_details = ASSERT( length args > 0 ) - do { -- Allocate the global ticky counter, - -- and establish the ticky-counter - -- label for this block - let ticky_ctr_lbl = mkRednCountsLabel (closureName cl_info) $ clHasCafRefs cl_info - ; emitTickyCounter cl_info (map stripNV args) - ; setTickyCtrLabel ticky_ctr_lbl $ do - - -- Emit the main entry code - ; emitClosureProcAndInfoTable top_lvl bndr cl_info args $ \(node, arg_regs) -> do - -- Emit the slow-entry code (for entering a closure through a PAP) + do { -- Allocate the global ticky counter, + -- and establish the ticky-counter + -- label for this block + let ticky_ctr_lbl = mkRednCountsLabel (closureName cl_info) $ + clHasCafRefs cl_info + ; emitTickyCounter cl_info (map stripNV args) + ; setTickyCtrLabel ticky_ctr_lbl $ do + + -- Emit the main entry code + ; emitClosureProcAndInfoTable top_lvl bndr cl_info args $ + \(offset, node, arg_regs) -> do + -- Emit slow-entry code (for entering a closure through a PAP) { mkSlowEntryCode cl_info arg_regs ; let lf_info = closureLFInfo cl_info node_points = nodeMustPointToIt lf_info + node' = if node_points then Just node else Nothing ; tickyEnterFun cl_info ; whenC node_points (ldvEnterClosure cl_info) ; granYield arg_regs node_points - -- Main payload - ; entryHeapCheck (if node_points then Just node else Nothing) arity arg_regs $ do + -- Main payload + ; entryHeapCheck cl_info offset node' arity arg_regs $ do { enterCostCentre cl_info cc body ; fv_bindings <- mapM bind_fv fv_details -- Load free vars out of closure *after* - ; if node_points then load_fvs node lf_info fv_bindings else return () - ; cgExpr body }} -- heap check, to reduce live vars over check - + -- heap check, to reduce live vars over check + ; if node_points then load_fvs node lf_info fv_bindings + else return () + ; cgExpr body }} } -- A function closure pointer may be tagged, so we @@ -426,55 +432,56 @@ -- according to the calling convention, and jumps to the function's -- normal entry point. The function's closure is assumed to be in -- R1/node. --- --- The slow entry point is used for unknown calls: eg. stg_PAP_entry +-- +-- The slow entry point is used for unknown calls: eg. stg_PAP_entry mkSlowEntryCode :: ClosureInfo -> [LocalReg] -> FCode () -- If this function doesn't have a specialised ArgDescr, we need -- to generate the function's arg bitmap and slow-entry code. -- Here, we emit the slow-entry code. -mkSlowEntryCode cl_info (_ : arg_regs) -- first arg should already be in `Node' +mkSlowEntryCode _ [] = panic "entering a closure with no arguments?" +mkSlowEntryCode cl_info arg_regs -- function closure is already in `Node' | Just (_, ArgGen _) <- closureFunInfo cl_info - = emitProcWithConvention Slow (CmmInfo Nothing Nothing CmmNonInfoTable) slow_lbl - arg_regs jump + = emitProcWithConvention Slow CmmNonInfoTable slow_lbl arg_regs jump | otherwise = return () where caf_refs = clHasCafRefs cl_info name = closureName cl_info slow_lbl = mkSlowEntryLabel name caf_refs fast_lbl = enterLocalIdLabel name caf_refs - jump = mkJump (mkLblExpr fast_lbl) (map (CmmReg . CmmLocal) arg_regs) - initUpdFrameOff -mkSlowEntryCode _ [] = panic "entering a closure with no arguments?" + -- mkDirectJump does not clobber `Node' containing function closure + jump = mkDirectJump (mkLblExpr fast_lbl) (map (CmmReg . CmmLocal) arg_regs) + initUpdFrameOff ----------------------------------------- -thunkCode :: ClosureInfo -> [(NonVoid Id, VirtualHpOffset)] -> CostCentreStack -> - LocalReg -> Int -> StgExpr -> FCode () -thunkCode cl_info fv_details cc node arity body - = do { let node_points = nodeMustPointToIt (closureLFInfo cl_info) - ; tickyEnterThunk cl_info - ; ldvEnterClosure cl_info -- NB: Node always points when profiling - ; granThunk node_points +thunkCode :: ClosureInfo -> [(NonVoid Id, VirtualHpOffset)] -> CostCentreStack + -> LocalReg -> Int -> StgExpr -> FCode () +thunkCode cl_info fv_details cc node arity body + = do { let node_points = nodeMustPointToIt (closureLFInfo cl_info) + node' = if node_points then Just node else Nothing + ; tickyEnterThunk cl_info + ; ldvEnterClosure cl_info -- NB: Node always points when profiling + ; granThunk node_points -- Heap overflow check - ; entryHeapCheck (if node_points then Just node else Nothing) arity [] $ do - { -- Overwrite with black hole if necessary - -- but *after* the heap-overflow check - dflags <- getDynFlags - ; whenC (blackHoleOnEntry dflags cl_info && node_points) - (blackHoleIt cl_info) - - -- Push update frame - ; setupUpdate cl_info node $ - -- We only enter cc after setting up update so - -- that cc of enclosing scope will be recorded - -- in update frame CAF/DICT functions will be - -- subsumed by this enclosing cc + ; entryHeapCheck cl_info 0 node' arity [] $ do + { -- Overwrite with black hole if necessary + -- but *after* the heap-overflow check + dflags <- getDynFlags + ; whenC (blackHoleOnEntry dflags cl_info && node_points) + (blackHoleIt cl_info) + + -- Push update frame + ; setupUpdate cl_info node $ + -- We only enter cc after setting up update so + -- that cc of enclosing scope will be recorded + -- in update frame CAF/DICT functions will be + -- subsumed by this enclosing cc do { enterCostCentre cl_info cc body ; let lf_info = closureLFInfo cl_info ; fv_bindings <- mapM bind_fv fv_details ; load_fvs node lf_info fv_bindings - ; cgExpr body }}} + ; cgExpr body }}} ------------------------------------------------------------------------ @@ -487,11 +494,13 @@ blackHoleIt closure_info = emitBlackHoleCode (closureSingleEntry closure_info) emitBlackHoleCode :: Bool -> FCode () -emitBlackHoleCode is_single_entry - | eager_blackholing = do +emitBlackHoleCode is_single_entry + | eager_blackholing = do tickyBlackHole (not is_single_entry) + emit (mkStore (cmmOffsetW (CmmReg nodeReg) fixedHdrSize) (CmmReg (CmmGlobal CurrentTSO))) + emitPrimCall [] MO_WriteBarrier [] emit (mkStore (CmmReg nodeReg) (CmmLit (CmmLabel bh_lbl))) - | otherwise = + | otherwise = nopC where bh_lbl | is_single_entry = mkCmmDataLabel rtsPackageId (fsLit "stg_SE_BLACKHOLE_info") @@ -507,11 +516,11 @@ -- currently eager blackholing doesn't work with profiling. -- -- Previously, eager blackholing was enabled when ticky-ticky - -- was on. But it didn't work, and it wasn't strictly necessary - -- to bring back minimal ticky-ticky, so now EAGER_BLACKHOLING + -- was on. But it didn't work, and it wasn't strictly necessary + -- to bring back minimal ticky-ticky, so now EAGER_BLACKHOLING -- is unconditionally disabled. -- krc 1/2007 - eager_blackholing = False + eager_blackholing = False setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode () -- Nota Bene: this function does not change Node (even if it's a CAF), @@ -522,12 +531,17 @@ = body | not (isStaticClosure closure_info) - = if closureUpdReqd closure_info - then do { tickyPushUpdateFrame; - ; pushUpdateFrame [CmmReg (CmmLocal node), - mkLblExpr mkUpdInfoLabel] body } - else do { tickyUpdateFrameOmitted; body} - + = if not (closureUpdReqd closure_info) + then do tickyUpdateFrameOmitted; body + else do + tickyPushUpdateFrame + --dflags <- getDynFlags + let es = [CmmReg (CmmLocal node), mkLblExpr mkUpdInfoLabel] + --if not opt_SccProfilingOn && dopt Opt_EagerBlackHoling dflags + -- then pushUpdateFrame es body -- XXX black hole + -- else pushUpdateFrame es body + pushUpdateFrame es body + | otherwise -- A static closure = do { tickyUpdateBhCaf closure_info @@ -535,16 +549,20 @@ then do -- Blackhole the (updatable) CAF: { upd_closure <- link_caf closure_info True ; pushUpdateFrame [CmmReg (CmmLocal upd_closure), - mkLblExpr mkUpdInfoLabel] body } + mkLblExpr mkUpdInfoLabel] body } -- XXX black hole else do {tickyUpdateFrameOmitted; body} } +----------------------------------------------------------------------------- +-- Setting up update frames + -- Push the update frame on the stack in the Entry area, -- leaving room for the return address that is already -- at the old end of the area. pushUpdateFrame :: [CmmExpr] -> FCode () -> FCode () pushUpdateFrame es body - = do updfr <- getUpdFrameOff + = do -- [EZY] I'm not sure if we need to special-case for BH too + updfr <- getUpdFrameOff offset <- foldM push updfr es withUpdFrameOff offset body where push off e = @@ -563,7 +581,7 @@ -- allocated black hole to be empty. -- -- Why do we make a black hole in the heap when we enter a CAF? --- +-- -- - for a generational garbage collector, which needs a fast -- test for whether an updatee is in an old generation or not -- @@ -581,7 +599,7 @@ -- ToDo [Feb 04] This entire link_caf nonsense could all be moved -- into the "newCAF" RTS procedure, which we call anyway, including -- the allocation of the black-hole indirection closure. --- That way, code size would fall, the CAF-handling code would +-- That way, code size would fall, the CAF-handling code would -- be closer together, and the compiler wouldn't need to know -- about off_indirectee etc. @@ -598,12 +616,14 @@ { -- Alloc black hole specifying CC_HDR(Node) as the cost centre ; let use_cc = costCentreFrom (CmmReg nodeReg) blame_cc = use_cc - ; (hp_rel, init) <- allocDynClosure bh_cl_info use_cc blame_cc [] + tso = CmmReg (CmmGlobal CurrentTSO) + -- XXX ezyang: FIXME + ; (hp_rel, init) <- allocDynClosureCmm bh_cl_info use_cc blame_cc [(tso,fixedHdrSize)] ; emit init -- Call the RTS function newCAF to add the CAF to the CafList -- so that the garbage collector can find them - -- This must be done *before* the info table pointer is overwritten, + -- This must be done *before* the info table pointer is overwritten, -- because the old info table ptr is needed for reversion ; emitRtsCallWithVols rtsPackageId (fsLit "newCAF") [ (CmmReg (CmmGlobal BaseReg), AddrHint), @@ -611,7 +631,7 @@ [node] False -- node is live, so save it. - -- Overwrite the closure with a (static) indirection + -- Overwrite the closure with a (static) indirection -- to the newly-allocated black hole ; emit (mkStore (cmmRegOffW nodeReg off_indirectee) (CmmReg (CmmLocal hp_rel)) <*> mkStore (CmmReg nodeReg) ind_static_info) @@ -629,7 +649,7 @@ ------------------------------------------------------------------------ --- Profiling +-- Profiling ------------------------------------------------------------------------ -- For "global" data constructors the description is simply occurrence @@ -648,4 +668,4 @@ else pprModule mod_name <> char '.' <> ppr name) <> char '>') -- showSDocDump, because we want to see the unique on the Name. - + diff -Nru ghc-7.0.3/compiler/codeGen/StgCmmClosure.hs ghc-7.2.1/compiler/codeGen/StgCmmClosure.hs --- ghc-7.0.3/compiler/codeGen/StgCmmClosure.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/codeGen/StgCmmClosure.hs 2011-08-07 17:10:05.000000000 +0000 @@ -11,7 +11,6 @@ -- ----------------------------------------------------------------------------- - module StgCmmClosure ( SMRep, DynTag, tagForCon, isSmallFamily, @@ -36,7 +35,7 @@ closureGoodStuffSize, closurePtrsSize, slopSize, - closureName, infoTableLabelFromCI, + closureName, infoTableLabelFromCI, entryLabelFromCI, closureLabelFromCI, closureTypeInfo, closureLFInfo, isLFThunk,closureSMRep, closureUpdReqd, @@ -73,7 +72,7 @@ import StgSyn import SMRep -import Cmm ( ClosureTypeInfo(..), ConstrDescription ) +import CmmDecl ( ClosureTypeInfo(..), ConstrDescription ) import CmmExpr import CLabel @@ -158,7 +157,6 @@ | LFBlackHole -- Used for the closures allocated to hold the result -- of a CAF. We want the target of the update frame to -- be in the heap, so we make a black hole to hold it. - CLabel -- Flavour (info label, eg CAF_BLACKHOLE_info). ------------------------- @@ -305,13 +303,15 @@ {- Note [Data constructor dynamic tags] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The family size of a data type (the number of constructors) -can be either: +The family size of a data type (the number of constructors +or the arity of a function) can be either: * small, if the family size < 2**tag_bits * big, otherwise. Small families can have the constructor tag in the tag bits. -Big families only use the tag value 1 to represent evaluatedness. -} +Big families only use the tag value 1 to represent evaluatedness. +We don't have very many tag bits: for example, we have 2 bits on +x86-32 and 3 bits on x86-64. -} isSmallFamily :: Int -> Bool isSmallFamily fam_size = fam_size <= mAX_PTR_TAG @@ -353,7 +353,7 @@ ------------ isLFThunk :: LambdaFormInfo -> Bool isLFThunk (LFThunk _ _ _ _ _) = True -isLFThunk (LFBlackHole _) = True +isLFThunk LFBlackHole = True -- return True for a blackhole: this function is used to determine -- whether to use the thunk header in SMP mode, and a blackhole -- must have one. @@ -439,7 +439,7 @@ nodeMustPointToIt (LFUnknown _) = True nodeMustPointToIt LFUnLifted = False -nodeMustPointToIt (LFBlackHole _) = True -- BH entry may require Node to point +nodeMustPointToIt LFBlackHole = True -- BH entry may require Node to point nodeMustPointToIt LFLetNoEscape = False ----------------------------------------------------------------------------- @@ -547,7 +547,7 @@ = ASSERT2 ( n_args == 0, ppr name <+> ppr n_args ) EnterIt -- Not a function -getCallMethod _ _name _ (LFBlackHole _) _n_args +getCallMethod _ _name _ LFBlackHole _n_args = SlowCall -- Presumably the black hole has by now -- been updated, but we don't know with -- what, so we slow call it @@ -678,7 +678,8 @@ closureSRT :: !C_SRT, -- What SRT applies to this closure closureType :: !Type, -- Type of closure (ToDo: remove) closureDescr :: !String, -- closure description (for profiling) - closureCafs :: !CafInfo -- whether the closure may have CAFs + closureCafs :: !CafInfo, -- whether the closure may have CAFs + closureInfLcl :: Bool -- can the info pointer be a local symbol? } -- Constructor closures don't have a unique info table label (they use @@ -724,7 +725,12 @@ closureSRT = srt_info, closureType = idType id, closureDescr = descr, - closureCafs = idCafInfo id } + closureCafs = idCafInfo id, + closureInfLcl = isDataConWorkId id } + -- Make the _info pointer for the implicit datacon worker binding + -- local. The reason we can do this is that importing code always + -- either uses the _closure or _con_info. By the invariants in CorePrep + -- anything else gets eta expanded. where name = idName id sm_rep = chooseSMRep is_static lf_info tot_wds ptr_wds @@ -750,12 +756,13 @@ closureType = ty, closureCafs = cafs }) = ClosureInfo { closureName = nm, - closureLFInfo = LFBlackHole mkCAFBlackHoleInfoTableLabel, + closureLFInfo = LFBlackHole, closureSMRep = BlackHoleRep, closureSRT = NoC_SRT, closureType = ty, closureDescr = "", - closureCafs = cafs } + closureCafs = cafs, + closureInfLcl = False } cafBlackHoleClosureInfo _ = panic "cafBlackHoleClosureInfo" @@ -939,7 +946,7 @@ lfUpdatable :: LambdaFormInfo -> Bool lfUpdatable (LFThunk _ _ upd _ _) = upd -lfUpdatable (LFBlackHole _) = True +lfUpdatable LFBlackHole = True -- Black-hole closures are allocated to receive the results of an -- alg case with a named default... so they need to be updated. lfUpdatable _ = False @@ -985,29 +992,40 @@ -------------------------------------- infoTableLabelFromCI :: ClosureInfo -> CLabel -infoTableLabelFromCI cl@(ClosureInfo { closureName = name, - closureLFInfo = lf_info }) +infoTableLabelFromCI = fst . labelsFromCI + +entryLabelFromCI :: ClosureInfo -> CLabel +entryLabelFromCI = snd . labelsFromCI + +labelsFromCI :: ClosureInfo -> (CLabel, CLabel) -- (Info, Entry) +labelsFromCI cl@(ClosureInfo { closureName = name, + closureLFInfo = lf_info, + closureInfLcl = is_lcl }) = case lf_info of - LFBlackHole info -> info + LFBlackHole -> (mkCAFBlackHoleInfoTableLabel, mkCAFBlackHoleEntryLabel) LFThunk _ _ upd_flag (SelectorThunk offset) _ -> - mkSelectorInfoLabel upd_flag offset + bothL (mkSelectorInfoLabel, mkSelectorEntryLabel) upd_flag offset LFThunk _ _ upd_flag (ApThunk arity) _ -> - mkApInfoTableLabel upd_flag arity + bothL (mkApInfoTableLabel, mkApEntryLabel) upd_flag arity - LFThunk{} -> mkLocalInfoTableLabel name $ clHasCafRefs cl + LFThunk{} -> bothL std_mk_lbls name $ clHasCafRefs cl - LFReEntrant _ _ _ _ -> mkLocalInfoTableLabel name $ clHasCafRefs cl + LFReEntrant _ _ _ _ -> bothL std_mk_lbls name $ clHasCafRefs cl - _other -> panic "infoTableLabelFromCI" + _other -> panic "labelsFromCI" + where std_mk_lbls = if is_lcl then (mkLocalInfoTableLabel, mkLocalEntryLabel) else (mkInfoTableLabel, mkEntryLabel) -infoTableLabelFromCI cl@(ConInfo { closureCon = con, closureSMRep = rep }) - | isStaticRep rep = mkStaticInfoTableLabel name $ clHasCafRefs cl - | otherwise = mkConInfoTableLabel name $ clHasCafRefs cl +labelsFromCI cl@(ConInfo { closureCon = con, closureSMRep = rep }) + | isStaticRep rep = bothL (mkStaticInfoTableLabel, mkStaticConEntryLabel) name $ clHasCafRefs cl + | otherwise = bothL (mkConInfoTableLabel, mkConEntryLabel) name $ clHasCafRefs cl where name = dataConName con +bothL :: (a -> b -> c, a -> b -> c) -> a -> b -> (c, c) +bothL (f, g) x y = (f x y, g x y) + -- ClosureInfo for a closure (as opposed to a constructor) is always local closureLabelFromCI :: ClosureInfo -> CLabel closureLabelFromCI cl@(ClosureInfo { closureName = nm }) = @@ -1085,10 +1103,9 @@ fun_result other = getTyDescription other getPredTyDescription :: PredType -> String -getPredTyDescription (ClassP cl _) = getOccString cl -getPredTyDescription (IParam ip _) = getOccString (ipNameName ip) -getPredTyDescription (EqPred ty1 _ty2) = getTyDescription ty1 -- Urk? - +getPredTyDescription (ClassP cl _) = getOccString cl +getPredTyDescription (IParam ip _) = getOccString (ipNameName ip) +getPredTyDescription (EqPred {}) = "Type equality" -------------------------------------- -- SRTs/CAFs diff -Nru ghc-7.0.3/compiler/codeGen/StgCmmCon.hs ghc-7.2.1/compiler/codeGen/StgCmmCon.hs --- ghc-7.0.3/compiler/codeGen/StgCmmCon.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/codeGen/StgCmmCon.hs 2011-08-07 17:10:05.000000000 +0000 @@ -25,9 +25,9 @@ import StgCmmClosure import StgCmmProf -import Cmm +import CmmExpr import CLabel -import MkZipCfgCmm (CmmAGraph, mkNop) +import MkGraph import SMRep import CostCentre import Module @@ -193,7 +193,7 @@ = do { let (cl_info, args_w_offsets) = layOutDynConstr con (addArgReps args) -- No void args in args_w_offsets ; (tmp, init) <- allocDynClosure cl_info use_cc blame_cc args_w_offsets - ; return (regIdInfo binder lf_info tmp, init) } + ; regIdInfo binder lf_info tmp init } where lf_info = mkConLFInfo con diff -Nru ghc-7.0.3/compiler/codeGen/StgCmmEnv.hs ghc-7.2.1/compiler/codeGen/StgCmmEnv.hs --- ghc-7.0.3/compiler/codeGen/StgCmmEnv.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/codeGen/StgCmmEnv.hs 2011-08-07 17:10:05.000000000 +0000 @@ -35,10 +35,10 @@ import CLabel import BlockId -import Cmm +import CmmExpr import CmmUtils +import MkGraph (CmmAGraph, mkAssign, (<*>)) import FastString -import PprCmm ( {- instance Outputable -} ) import Id import VarEnv import Control.Monad @@ -87,9 +87,16 @@ litIdInfo id lf_info lit = --mkCgIdInfo id lf_info (CmmLit lit) mkCgIdInfo id lf_info (addDynTag (CmmLit lit) (lfDynTag lf_info)) -regIdInfo :: Id -> LambdaFormInfo -> LocalReg -> CgIdInfo -regIdInfo id lf_info reg = - mkCgIdInfo id lf_info (addDynTag (CmmReg (CmmLocal reg)) (lfDynTag lf_info)) +-- Because the register may be spilled to the stack in untagged form, we +-- modify the initialization code 'init' to immediately tag the +-- register, and store a plain register in the CgIdInfo. We allocate +-- a new register in order to keep single-assignment and help out the +-- inliner. -- EZY +regIdInfo :: Id -> LambdaFormInfo -> LocalReg -> CmmAGraph -> FCode (CgIdInfo, CmmAGraph) +regIdInfo id lf_info reg init = do + reg' <- newTemp (localRegType reg) + let init' = init <*> mkAssign (CmmLocal reg') (addDynTag (CmmReg (CmmLocal reg)) (lfDynTag lf_info)) + return (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg')), init') idInfoToAmode :: CgIdInfo -> CmmExpr -- Returns a CmmExpr for the *tagged* pointer diff -Nru ghc-7.0.3/compiler/codeGen/StgCmmExpr.hs ghc-7.2.1/compiler/codeGen/StgCmmExpr.hs --- ghc-7.0.3/compiler/codeGen/StgCmmExpr.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/codeGen/StgCmmExpr.hs 2011-08-07 17:10:05.000000000 +0000 @@ -27,9 +27,8 @@ import StgSyn -import MkZipCfgCmm +import MkGraph import BlockId -import Cmm() import CmmExpr import CoreSyn import DataCon @@ -54,6 +53,11 @@ cgExpr :: StgExpr -> FCode () cgExpr (StgApp fun args) = cgIdApp fun args + +{- seq# a s ==> a -} +cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) = + cgIdApp a [] + cgExpr (StgOpApp op args ty) = cgOpApp op args ty cgExpr (StgConApp con args) = cgConApp con args cgExpr (StgSCC cc expr) = do { emitSetCCC cc; cgExpr expr } @@ -323,6 +327,22 @@ ; emit $ mkComment $ mkFastString "should be unreachable code" ; emit $ withFreshLabel "l" (\l -> mkLabel l <*> mkBranch l)} +{- +case seq# a s of v + (# s', a' #) -> e + +==> + +case a of v + (# s', a' #) -> e + +(taking advantage of the fact that the return convention for (# State#, a #) +is the same as the return convention for just 'a') +-} +cgCase (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _) bndr srt alt_type alts + = -- handle seq#, same return convention as vanilla 'a'. + cgCase (StgApp a []) bndr srt alt_type alts + cgCase scrut bndr srt alt_type alts = -- the general case do { up_hp_usg <- getVirtHp -- Upstream heap usage @@ -456,10 +476,8 @@ ; return con } maybeAltHeapCheck :: GcPlan -> FCode a -> FCode a -maybeAltHeapCheck NoGcInAlts code - = code -maybeAltHeapCheck (GcInAlts regs _) code - = altHeapCheck regs code +maybeAltHeapCheck NoGcInAlts code = code +maybeAltHeapCheck (GcInAlts regs _) code = altHeapCheck regs code ----------------------------------------------------------------------------- -- Tail calls @@ -550,8 +568,8 @@ The following example illustrates how badly the code turns out: STG: case <=## [ww_s7Hx y_s7HD] of wild2_sbH8 { - GHC.Bool.False -> // sbH8 dead - GHC.Bool.True -> // sbH8 dead + GHC.Types.False -> // sbH8 dead + GHC.Types.True -> // sbH8 dead }; Cmm: _s7HD::F64 = F64[_sbH7::I64 + 7]; // MidAssign @@ -611,3 +629,4 @@ L2: -} + diff -Nru ghc-7.0.3/compiler/codeGen/StgCmmForeign.hs ghc-7.2.1/compiler/codeGen/StgCmmForeign.hs --- ghc-7.0.3/compiler/codeGen/StgCmmForeign.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/codeGen/StgCmmForeign.hs 2011-08-07 17:10:05.000000000 +0000 @@ -24,9 +24,11 @@ import StgCmmClosure import BlockId -import Cmm +import CmmDecl +import CmmExpr import CmmUtils -import MkZipCfgCmm hiding (CmmAGraph) +import OldCmm ( CmmReturnInfo(..) ) +import MkGraph import Type import TysPrim import CLabel @@ -36,7 +38,6 @@ import StaticFlags import Maybes import Outputable -import ZipCfgCmmRep import BasicTypes import Control.Monad @@ -103,20 +104,20 @@ fc = ForeignConvention CCallConv arg_hints result_hints -emitPrimCall :: CmmFormals -> CallishMachOp -> CmmActuals -> FCode () +emitPrimCall :: [CmmFormal] -> CallishMachOp -> [CmmActual] -> FCode () emitPrimCall res op args = emitForeignCall PlayRisky res (PrimTarget op) args NoC_SRT CmmMayReturn -- alternative entry point, used by CmmParse emitForeignCall - :: Safety - -> CmmFormals -- where to put the results - -> MidCallTarget -- the op - -> CmmActuals -- arguments + :: Safety + -> [CmmFormal] -- where to put the results + -> ForeignTarget -- the op + -> [CmmActual] -- arguments -> C_SRT -- the SRT of the calls continuation - -> CmmReturnInfo -- This can say "never returns" - -- only RTS procedures do this - -> FCode () + -> CmmReturnInfo -- This can say "never returns" + -- only RTS procedures do this + -> FCode () emitForeignCall safety results target args _srt _ret | not (playSafe safety) = do let (caller_save, caller_load) = callerSaveVolatileRegs @@ -127,7 +128,7 @@ | otherwise = do updfr_off <- getUpdFrameOff temp_target <- load_target_into_temp target - emit $ mkSafeCall temp_target results args updfr_off + emit $ mkSafeCall temp_target results args updfr_off (playInterruptible safety) {- @@ -145,7 +146,7 @@ return (tmp,hint) -} -load_target_into_temp :: MidCallTarget -> FCode MidCallTarget +load_target_into_temp :: ForeignTarget -> FCode ForeignTarget load_target_into_temp (ForeignTarget expr conv) = do tmp <- maybe_assign_temp expr return (ForeignTarget tmp conv) @@ -171,8 +172,8 @@ saveThreadState :: CmmAGraph saveThreadState = - -- CurrentTSO->sp = Sp; - mkStore (cmmOffset stgCurrentTSO tso_SP) stgSp + -- CurrentTSO->stackobj->sp = Sp; + mkStore (cmmOffset (CmmLoad (cmmOffset stgCurrentTSO tso_stackobj) bWord) stack_SP) stgSp <*> closeNursery -- and save the current cost centre stack in the TSO when profiling: <*> if opt_SccProfilingOn then @@ -181,8 +182,8 @@ emitSaveThreadState :: BlockId -> FCode () emitSaveThreadState bid = do - -- CurrentTSO->sp = Sp; - emit $ mkStore (cmmOffset stgCurrentTSO tso_SP) + -- CurrentTSO->stackobj->sp = Sp; + emit $ mkStore (cmmOffset (CmmLoad (cmmOffset stgCurrentTSO tso_stackobj) bWord) stack_SP) (CmmStackSlot (CallArea (Young bid)) (widthInBytes (typeWidth gcWord))) emit closeNursery -- and save the current cost centre stack in the TSO when profiling: @@ -193,17 +194,19 @@ closeNursery :: CmmAGraph closeNursery = mkStore nursery_bdescr_free (cmmOffsetW stgHp 1) -loadThreadState :: LocalReg -> CmmAGraph -loadThreadState tso = do +loadThreadState :: LocalReg -> LocalReg -> CmmAGraph +loadThreadState tso stack = do -- tso <- newTemp gcWord -- TODO FIXME NOW + -- stack <- newTemp gcWord -- TODO FIXME NOW catAGraphs [ -- tso = CurrentTSO; mkAssign (CmmLocal tso) stgCurrentTSO, - -- Sp = tso->sp; - mkAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_SP) - bWord), - -- SpLim = tso->stack + RESERVED_STACK_WORDS; - mkAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal tso)) tso_STACK) + -- stack = tso->stackobj; + mkAssign (CmmLocal stack) (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_stackobj) bWord), + -- Sp = stack->sp; + mkAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal stack)) stack_SP) bWord), + -- SpLim = stack->stack + RESERVED_STACK_WORDS; + mkAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal stack)) stack_STACK) rESERVED_STACK_WORDS), openNursery, -- and load the current cost centre stack from the TSO when profiling: @@ -211,8 +214,8 @@ mkStore curCCSAddr (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) ccsType) else mkNop] -emitLoadThreadState :: LocalReg -> FCode () -emitLoadThreadState tso = emit $ loadThreadState tso +emitLoadThreadState :: LocalReg -> LocalReg -> FCode () +emitLoadThreadState tso stack = emit $ loadThreadState tso stack openNursery :: CmmAGraph openNursery = catAGraphs [ @@ -242,20 +245,15 @@ nursery_bdescr_start = cmmOffset stgCurrentNursery oFFSET_bdescr_start nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks -tso_SP, tso_STACK, tso_CCCS :: ByteOff -tso_SP = tsoFieldB oFFSET_StgTSO_sp -tso_STACK = tsoFieldB oFFSET_StgTSO_stack -tso_CCCS = tsoProfFieldB oFFSET_StgTSO_CCCS - --- The TSO struct has a variable header, and an optional StgTSOProfInfo in --- the middle. The fields we're interested in are after the StgTSOProfInfo. -tsoFieldB :: ByteOff -> ByteOff -tsoFieldB off - | opt_SccProfilingOn = off + sIZEOF_StgTSOProfInfo + fixedHdrSize * wORD_SIZE - | otherwise = off + fixedHdrSize * wORD_SIZE +tso_stackobj, tso_CCCS, stack_STACK, stack_SP :: ByteOff +tso_stackobj = closureField oFFSET_StgTSO_stackobj +tso_CCCS = closureField oFFSET_StgTSO_CCCS +stack_STACK = closureField oFFSET_StgStack_stack +stack_SP = closureField oFFSET_StgStack_sp -tsoProfFieldB :: ByteOff -> ByteOff -tsoProfFieldB off = off + fixedHdrSize * wORD_SIZE + +closureField :: ByteOff -> ByteOff +closureField off = off + fixedHdrSize * wORD_SIZE stgSp, stgHp, stgCurrentTSO, stgCurrentNursery :: CmmExpr stgSp = CmmReg sp diff -Nru ghc-7.0.3/compiler/codeGen/StgCmmGran.hs ghc-7.2.1/compiler/codeGen/StgCmmGran.hs --- ghc-7.0.3/compiler/codeGen/StgCmmGran.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/codeGen/StgCmmGran.hs 2011-08-07 17:10:05.000000000 +0000 @@ -19,7 +19,7 @@ -- I've left the calls, though, in case anyone wants to resurrect it import StgCmmMonad -import Cmm +import CmmExpr staticGranHdr :: [CmmLit] staticGranHdr = [] diff -Nru ghc-7.0.3/compiler/codeGen/StgCmmHeap.hs ghc-7.2.1/compiler/codeGen/StgCmmHeap.hs --- ghc-7.0.3/compiler/codeGen/StgCmmHeap.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/codeGen/StgCmmHeap.hs 2011-08-07 17:10:05.000000000 +0000 @@ -7,19 +7,20 @@ ----------------------------------------------------------------------------- module StgCmmHeap ( - getVirtHp, setVirtHp, setRealHp, - getHpRelOffset, hpRel, + getVirtHp, setVirtHp, setRealHp, + getHpRelOffset, hpRel, - entryHeapCheck, altHeapCheck, + entryHeapCheck, altHeapCheck, - layOutDynConstr, layOutStaticConstr, - mkVirtHeapOffsets, mkStaticClosureFields, mkStaticClosure, + layOutDynConstr, layOutStaticConstr, + mkVirtHeapOffsets, mkStaticClosureFields, mkStaticClosure, - allocDynClosure, emitSetDynHdr + allocDynClosure, allocDynClosureCmm, emitSetDynHdr ) where #include "HsVersions.h" +import CmmType import StgSyn import CLabel import StgCmmLayout @@ -31,7 +32,7 @@ import StgCmmClosure import StgCmmEnv -import MkZipCfgCmm +import MkGraph import SMRep import CmmExpr @@ -41,49 +42,53 @@ import CostCentre import Outputable import Module -import FastString( mkFastString, FastString, fsLit ) +import FastString( mkFastString, fsLit ) import Constants - ----------------------------------------------------------- --- Layout of heap objects +-- Layout of heap objects ----------------------------------------------------------- layOutDynConstr, layOutStaticConstr - :: DataCon -> [(PrimRep, a)] - -> (ClosureInfo, [(NonVoid a, VirtualHpOffset)]) --- No Void arguments in result + :: DataCon -> [(PrimRep, a)] + -> (ClosureInfo, [(NonVoid a, VirtualHpOffset)]) + -- No Void arguments in result layOutDynConstr = layOutConstr False layOutStaticConstr = layOutConstr True layOutConstr :: Bool -> DataCon -> [(PrimRep, a)] - -> (ClosureInfo, [(NonVoid a, VirtualHpOffset)]) + -> (ClosureInfo, [(NonVoid a, VirtualHpOffset)]) layOutConstr is_static data_con args = (mkConInfo is_static data_con tot_wds ptr_wds, things_w_offsets) where - (tot_wds, -- #ptr_wds + #nonptr_wds - ptr_wds, -- #ptr_wds + (tot_wds, -- #ptr_wds + #nonptr_wds + ptr_wds, -- #ptr_wds things_w_offsets) = mkVirtHeapOffsets False{-not a thunk-} args ----------------------------------------------------------- --- Initialise dynamic heap objects +-- Initialise dynamic heap objects ----------------------------------------------------------- allocDynClosure - :: ClosureInfo - -> CmmExpr -- Cost Centre to stick in the object - -> CmmExpr -- Cost Centre to blame for this alloc - -- (usually the same; sometimes "OVERHEAD") - - -> [(NonVoid StgArg, VirtualHpOffset)] -- Offsets from start of the object - -- ie Info ptr has offset zero. - -- No void args in here - -> FCode (LocalReg, CmmAGraph) + :: ClosureInfo + -> CmmExpr -- Cost Centre to stick in the object + -> CmmExpr -- Cost Centre to blame for this alloc + -- (usually the same; sometimes "OVERHEAD") + + -> [(NonVoid StgArg, VirtualHpOffset)] -- Offsets from start of object + -- ie Info ptr has offset zero. + -- No void args in here + -> FCode (LocalReg, CmmAGraph) + +allocDynClosureCmm + :: ClosureInfo -> CmmExpr -> CmmExpr + -> [(CmmExpr, VirtualHpOffset)] + -> FCode (LocalReg, CmmAGraph) --- allocDynClosure allocates the thing in the heap, +-- allocDynClosure allocates the thing in the heap, -- and modifies the virtual Hp to account for this. -- The second return value is the graph that sets the value of the -- returned LocalReg, which should point to the closure after executing @@ -93,84 +98,89 @@ -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- allocDynClosure returns a LocalReg, not a (Hp+8) CmmExpr. -- Reason: --- ...allocate object... --- obj = Hp + 8 --- y = f(z) --- ...here obj is still valid, --- but Hp+8 means something quite different... +-- ...allocate object... +-- obj = Hp + 8 +-- y = f(z) +-- ...here obj is still valid, +-- but Hp+8 means something quite different... allocDynClosure cl_info use_cc _blame_cc args_w_offsets - = do { virt_hp <- getVirtHp - - -- SAY WHAT WE ARE ABOUT TO DO - ; tickyDynAlloc cl_info - ; profDynAlloc cl_info use_cc - -- ToDo: This is almost certainly wrong - -- We're ignoring blame_cc. But until we've - -- fixed the boxing hack in chooseDynCostCentres etc, - -- we're worried about making things worse by "fixing" - -- this part to use blame_cc! - - -- FIND THE OFFSET OF THE INFO-PTR WORD - ; let info_offset = virt_hp + 1 - -- info_offset is the VirtualHpOffset of the first - -- word of the new object - -- Remember, virtHp points to last allocated word, - -- ie 1 *before* the info-ptr word of new object. + = do { let (args, offsets) = unzip args_w_offsets + ; cmm_args <- mapM getArgAmode args -- No void args + ; allocDynClosureCmm cl_info use_cc _blame_cc (zip cmm_args offsets) + } + +allocDynClosureCmm cl_info use_cc _blame_cc amodes_w_offsets + = do { virt_hp <- getVirtHp + + -- SAY WHAT WE ARE ABOUT TO DO + ; tickyDynAlloc cl_info + ; profDynAlloc cl_info use_cc + -- ToDo: This is almost certainly wrong + -- We're ignoring blame_cc. But until we've + -- fixed the boxing hack in chooseDynCostCentres etc, + -- we're worried about making things worse by "fixing" + -- this part to use blame_cc! + + -- FIND THE OFFSET OF THE INFO-PTR WORD + ; let info_offset = virt_hp + 1 + -- info_offset is the VirtualHpOffset of the first + -- word of the new object + -- Remember, virtHp points to last allocated word, + -- ie 1 *before* the info-ptr word of new object. - info_ptr = CmmLit (CmmLabel (infoTableLabelFromCI cl_info)) + info_ptr = CmmLit (CmmLabel (infoTableLabelFromCI cl_info)) - -- ALLOCATE THE OBJECT - ; base <- getHpRelOffset info_offset + -- ALLOCATE THE OBJECT + ; base <- getHpRelOffset info_offset ; emit (mkComment $ mkFastString "allocDynClosure") - ; emitSetDynHdr base info_ptr use_cc - ; let (args, offsets) = unzip args_w_offsets - ; cmm_args <- mapM getArgAmode args -- No void args - ; hpStore base cmm_args offsets - - -- BUMP THE VIRTUAL HEAP POINTER - ; setVirtHp (virt_hp + closureSize cl_info) - - -- Assign to a temporary and return - -- Note [Return a LocalReg] - ; hp_rel <- getHpRelOffset info_offset - ; getCodeR $ assignTemp hp_rel } + ; emitSetDynHdr base info_ptr use_cc + ; let (cmm_args, offsets) = unzip amodes_w_offsets + ; hpStore base cmm_args offsets + + -- BUMP THE VIRTUAL HEAP POINTER + ; setVirtHp (virt_hp + closureSize cl_info) + + -- Assign to a temporary and return + -- Note [Return a LocalReg] + ; hp_rel <- getHpRelOffset info_offset + ; getCodeR $ assignTemp hp_rel } emitSetDynHdr :: CmmExpr -> CmmExpr -> CmmExpr -> FCode () -emitSetDynHdr base info_ptr ccs +emitSetDynHdr base info_ptr ccs = hpStore base header [0..] where header :: [CmmExpr] header = [info_ptr] ++ dynProfHdr ccs - -- ToDo: Gransim stuff - -- ToDo: Parallel stuff - -- No ticky header + -- ToDo: Gransim stuff + -- ToDo: Parallel stuff + -- No ticky header hpStore :: CmmExpr -> [CmmExpr] -> [VirtualHpOffset] -> FCode () -- Store the item (expr,off) in base[off] hpStore base vals offs = emit (catAGraphs (zipWith mk_store vals offs)) where - mk_store val off = mkStore (cmmOffsetW base off) val + mk_store val off = mkStore (cmmOffsetW base off) val ----------------------------------------------------------- --- Layout of static closures +-- Layout of static closures ----------------------------------------------------------- -- Make a static closure, adding on any extra padding needed for CAFs, -- and adding a static link field if necessary. -mkStaticClosureFields - :: ClosureInfo - -> CostCentreStack - -> Bool -- Has CAF refs - -> [CmmLit] -- Payload - -> [CmmLit] -- The full closure +mkStaticClosureFields + :: ClosureInfo + -> CostCentreStack + -> Bool -- Has CAF refs + -> [CmmLit] -- Payload + -> [CmmLit] -- The full closure mkStaticClosureFields cl_info ccs caf_refs payload - = mkStaticClosure info_lbl ccs payload padding_wds - static_link_field saved_info_field + = mkStaticClosure info_lbl ccs payload padding + static_link_field saved_info_field where info_lbl = infoTableLabelFromCI cl_info @@ -188,44 +198,44 @@ is_caf = closureNeedsUpdSpace cl_info - padding_wds - | not is_caf = [] - | otherwise = ASSERT(null payload) [mkIntCLit 0] + padding + | not is_caf = [] + | otherwise = ASSERT(null payload) [mkIntCLit 0] static_link_field - | is_caf || staticClosureNeedsLink cl_info = [static_link_value] - | otherwise = [] + | is_caf || staticClosureNeedsLink cl_info = [static_link_value] + | otherwise = [] saved_info_field - | is_caf = [mkIntCLit 0] - | otherwise = [] + | is_caf = [mkIntCLit 0] + | otherwise = [] - -- for a static constructor which has NoCafRefs, we set the - -- static link field to a non-zero value so the garbage - -- collector will ignore it. + -- for a static constructor which has NoCafRefs, we set the + -- static link field to a non-zero value so the garbage + -- collector will ignore it. static_link_value - | caf_refs = mkIntCLit 0 - | otherwise = mkIntCLit 1 + | caf_refs = mkIntCLit 0 + | otherwise = mkIntCLit 1 mkStaticClosure :: CLabel -> CostCentreStack -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit] -mkStaticClosure info_lbl ccs payload padding_wds static_link_field saved_info_field +mkStaticClosure info_lbl ccs payload padding static_link_field saved_info_field = [CmmLabel info_lbl] ++ variable_header_words ++ concatMap padLitToWord payload - ++ padding_wds + ++ padding ++ static_link_field ++ saved_info_field where variable_header_words - = staticGranHdr - ++ staticParHdr - ++ staticProfHdr ccs - ++ staticTickyHdr + = staticGranHdr + ++ staticParHdr + ++ staticProfHdr ccs + ++ staticTickyHdr --- JD: Simon had ellided this padding, but without it the C back end asserts failure. --- Maybe it's a bad assertion, and this padding is indeed unnecessary? +-- JD: Simon had ellided this padding, but without it the C back end asserts +-- failure. Maybe it's a bad assertion, and this padding is indeed unnecessary? padLitToWord :: CmmLit -> [CmmLit] padLitToWord lit = lit : padding pad_length where width = typeWidth (cmmLitType lit) @@ -238,7 +248,7 @@ | otherwise = CmmInt 0 W64 : padding (n-8) ----------------------------------------------------------- --- Heap overflow checking +-- Heap overflow checking ----------------------------------------------------------- {- Note [Heap checks] @@ -251,12 +261,12 @@ nothing to its caller * A series of canned entry points like - r = gc_1p( r ) + r = gc_1p( r ) where r is a pointer. This performs gc, and then returns its argument r to its caller. - + * A series of canned entry points like - gcfun_2p( f, x, y ) + gcfun_2p( f, x, y ) where f is a function closure of arity 2 This performs garbage collection, keeping alive the three argument ptrs, and then tail-calls f(x,y) @@ -266,213 +276,251 @@ * entryHeapCheck: Function entry (a) With a canned GC entry sequence f( f_clo, x:ptr, y:ptr ) { - Hp = Hp+8 - if Hp > HpLim goto L - ... + Hp = Hp+8 + if Hp > HpLim goto L + ... L: HpAlloc = 8 jump gcfun_2p( f_clo, x, y ) } Note the tail call to the garbage collector; - it should do no register shuffling + it should do no register shuffling (b) No canned sequence f( f_clo, x:ptr, y:ptr, ...etc... ) { - T: Hp = Hp+8 - if Hp > HpLim goto L - ... + T: Hp = Hp+8 + if Hp > HpLim goto L + ... L: HpAlloc = 8 - call gc() -- Needs an info table - goto T } + call gc() -- Needs an info table + goto T } * altHeapCheck: Immediately following an eval - Started as - case f x y of r { (p,q) -> rhs } + Started as + case f x y of r { (p,q) -> rhs } (a) With a canned sequence for the results of f (which is the very common case since all boxed cases return just one pointer - ... - r = f( x, y ) - K: -- K needs an info table - Hp = Hp+8 - if Hp > HpLim goto L - ...code for rhs... - - L: r = gc_1p( r ) - goto K } - - Here, the info table needed by the call - to gc_1p should be the *same* as the - one for the call to f; the C-- optimiser - spots this sharing opportunity) + ... + r = f( x, y ) + K: -- K needs an info table + Hp = Hp+8 + if Hp > HpLim goto L + ...code for rhs... + + L: r = gc_1p( r ) + goto K } + + Here, the info table needed by the call + to gc_1p should be the *same* as the + one for the call to f; the C-- optimiser + spots this sharing opportunity) (b) No canned sequence for results of f Note second info table - ... - (r1,r2,r3) = call f( x, y ) - K: - Hp = Hp+8 - if Hp > HpLim goto L - ...code for rhs... + ... + (r1,r2,r3) = call f( x, y ) + K: + Hp = Hp+8 + if Hp > HpLim goto L + ...code for rhs... - L: call gc() -- Extra info table here - goto K + L: call gc() -- Extra info table here + goto K * generalHeapCheck: Anywhere else e.g. entry to thunk - case branch *not* following eval, + case branch *not* following eval, or let-no-escape Exactly the same as the previous case: - K: -- K needs an info table - Hp = Hp+8 - if Hp > HpLim goto L - ... + K: -- K needs an info table + Hp = Hp+8 + if Hp > HpLim goto L + ... - L: call gc() - goto K + L: call gc() + goto K -} -------------------------------------------------------------- -- A heap/stack check at a function or thunk entry point. -entryHeapCheck :: Maybe LocalReg -- Function (closure environment) - -> Int -- Arity -- not same as length args b/c of voids - -> [LocalReg] -- Non-void args (empty for thunk) - -> FCode () - -> FCode () +entryHeapCheck :: ClosureInfo + -> Int -- Arg Offset + -> Maybe LocalReg -- Function (closure environment) + -> Int -- Arity -- not same as len args b/c of voids + -> [LocalReg] -- Non-void args (empty for thunk) + -> FCode () + -> FCode () -entryHeapCheck fun arity args code +entryHeapCheck cl_info offset nodeSet arity args code = do updfr_sz <- getUpdFrameOff - heapCheck True (gc_call updfr_sz) code -- The 'fun' keeps relevant CAFs alive + heapCheck True (gc_call updfr_sz) code + where + is_thunk = arity == 0 + is_fastf = case closureFunInfo cl_info of + Just (_, ArgGen _) -> False + _otherwise -> True + + args' = map (CmmReg . CmmLocal) args + setN = case nodeSet of + Just n -> mkAssign nodeReg (CmmReg $ CmmLocal n) + Nothing -> mkAssign nodeReg $ + CmmLit (CmmLabel $ closureLabelFromCI cl_info) + + {- Thunks: Set R1 = node, jump GCEnter1 + Function (fast): Set R1 = node, jump GCFun + Function (slow): Set R1 = node, call generic_gc -} + gc_call upd = setN <*> gc_lbl upd + gc_lbl upd + | is_thunk = mkDirectJump (CmmReg $ CmmGlobal GCEnter1) [] sp + | is_fastf = mkDirectJump (CmmReg $ CmmGlobal GCFun) [] sp + | otherwise = mkForeignJump Slow (CmmReg $ CmmGlobal GCFun) args' upd + where sp = max offset upd + {- DT (12/08/10) This is a little fishy, mainly the sp fix up amount. + - This is since the ncg inserts spills before the stack/heap check. + - This should be fixed up and then we won't need to fix up the Sp on + - GC calls, but until then this fishy code works -} + +{- + -- This code is slightly outdated now and we could easily keep the above + -- GC methods. However, there may be some performance gains to be made by + -- using more specialised GC entry points. Since the semi generic GCFun + -- entry needs to check the node and figure out what registers to save... + -- if we provided and used more specialised GC entry points then these + -- runtime decisions could be turned into compile time decisions. + args' = case fun of Just f -> f : args Nothing -> args arg_exprs = map (CmmReg . CmmLocal) args' gc_call updfr_sz | arity == 0 = mkJumpGC (CmmReg (CmmGlobal GCEnter1)) arg_exprs updfr_sz - | otherwise = case gc_lbl args' of - Just _lbl -> panic "StgCmmHeap.entryHeapCheck: gc_lbl not finished" - -- mkJumpGC (CmmLit (CmmLabel (mkRtsCodeLabel lbl))) - -- arg_exprs updfr_sz - Nothing -> mkCall generic_gc (GC, GC) [] [] updfr_sz + | otherwise = + case gc_lbl args' of + Just _lbl -> panic "StgCmmHeap.entryHeapCheck: not finished" + -- mkJumpGC (CmmLit (CmmLabel (mkRtsCodeLabel lbl))) + -- arg_exprs updfr_sz + Nothing -> mkCall generic_gc (GC, GC) [] [] updfr_sz gc_lbl :: [LocalReg] -> Maybe FastString -{- gc_lbl [reg] - | isGcPtrType ty = Just (sLit "stg_gc_unpt_r1") -- "stg_gc_fun_1p" - | isFloatType ty = case width of - W32 -> Just (sLit "stg_gc_f1") -- "stg_gc_fun_f1" - W64 -> Just (sLit "stg_gc_d1") -- "stg_gc_fun_d1" - _other -> Nothing - | otherwise = case width of - W32 -> Just (sLit "stg_gc_unbx_r1") -- "stg_gc_fun_unbx_r1" - W64 -> Just (sLit "stg_gc_l1") -- "stg_gc_fun_unbx_l1" - _other -> Nothing -- Narrow cases - where - ty = localRegType reg - width = typeWidth ty --} + | isGcPtrType ty = Just (sLit "stg_gc_unpt_r1") -- "stg_gc_fun_1p" + | isFloatType ty = case width of + W32 -> Just (sLit "stg_gc_f1") + W64 -> Just (sLit "stg_gc_d1") + _other -> Nothing + | width == wordWidth = Just (mkGcLabel "stg_gc_unbx_r1") + | width == W64 = Just (mkGcLabel "stg_gc_l1") + | otherwise = Nothing + where + ty = localRegType reg + width = typeWidth ty gc_lbl regs = gc_lbl_ptrs (map (isGcPtrType . localRegType) regs) gc_lbl_ptrs :: [Bool] -> Maybe FastString - -- JD: TEMPORARY -- UNTIL THOSE FUNCTIONS EXIST... + -- JD: TEMPORARY -- UNTIL THESE FUNCTIONS EXIST... --gc_lbl_ptrs [True,True] = Just (sLit "stg_gc_fun_2p") --gc_lbl_ptrs [True,True,True] = Just (sLit "stg_gc_fun_3p") gc_lbl_ptrs _ = Nothing - +-} + + +-------------------------------------------------------------- +-- A heap/stack check at in a case alternative altHeapCheck :: [LocalReg] -> FCode a -> FCode a altHeapCheck regs code = do updfr_sz <- getUpdFrameOff heapCheck False (gc_call updfr_sz) code - where - gc_call updfr_sz - | null regs = mkCall generic_gc (GC, GC) [] [] updfr_sz - | Just _gc_lbl <- rts_label regs -- Canned call - = panic "StgCmmHeap.altHeapCheck: rts_label not finished" - -- mkCall (CmmLit (CmmLabel (mkRtsCodeLabel gc_lbl))) (GC, GC) - -- regs (map (CmmReg . CmmLocal) regs) updfr_sz - | otherwise -- No canned call, and non-empty live vars - = mkCall generic_gc (GC, GC) [] [] updfr_sz + where + reg_exprs = map (CmmReg . CmmLocal) regs -{- - rts_label [reg] - | isGcPtrType ty = Just (sLit "stg_gc_unpt_r1") - | isFloatType ty = case width of - W32 -> Just (sLit "stg_gc_f1") - W64 -> Just (sLit "stg_gc_d1") - _other -> Nothing - | otherwise = case width of - W32 -> Just (sLit "stg_gc_unbx_r1") - W64 -> Just (sLit "stg_gc_l1") -- "stg_gc_fun_unbx_l1" - _other -> Nothing -- Narrow cases - where - ty = localRegType reg - width = typeWidth ty --} + gc_call sp = + case rts_label regs of + Just gc -> mkCall (CmmLit gc) (GC, GC) regs reg_exprs sp + Nothing -> mkCall generic_gc (GC, GC) [] [] sp + + rts_label [reg] + | isGcPtrType ty = Just (mkGcLabel "stg_gc_unpt_r1") + | isFloatType ty = case width of + W32 -> Just (mkGcLabel "stg_gc_f1") + W64 -> Just (mkGcLabel "stg_gc_d1") + _ -> Nothing + + | width == wordWidth = Just (mkGcLabel "stg_gc_unbx_r1") + | width == W64 = Just (mkGcLabel "stg_gc_l1") + | otherwise = Nothing + where + ty = localRegType reg + width = typeWidth ty rts_label _ = Nothing -generic_gc :: CmmExpr -- The generic GC procedure; no params, no resuls -generic_gc = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_noregs"))) --- JD: TEMPORARY -- UNTIL THOSE FUNCTIONS EXIST... --- generic_gc = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "stg_gc_fun"))) +-- | The generic GC procedure; no params, no results +generic_gc :: CmmExpr +generic_gc = CmmLit $ mkGcLabel "stg_gc_noregs" + +-- | Create a CLabel for calling a garbage collector entry point +mkGcLabel :: String -> CmmLit +mkGcLabel = (CmmLabel . (mkCmmCodeLabel rtsPackageId) . fsLit) ------------------------------- heapCheck :: Bool -> CmmAGraph -> FCode a -> FCode a heapCheck checkStack do_gc code = getHeapUsage $ \ hpHw -> - do { emit $ do_checks checkStack hpHw do_gc - -- Emit heap checks, but be sure to do it lazily so - -- that the conditionals on hpHw don't cause a black hole - ; tickyAllocHeap hpHw - ; doGranAllocate hpHw - ; setRealHp hpHw - ; code } + -- Emit heap checks, but be sure to do it lazily so + -- that the conditionals on hpHw don't cause a black hole + do { emit $ do_checks checkStack hpHw do_gc + ; tickyAllocHeap hpHw + ; doGranAllocate hpHw + ; setRealHp hpHw + ; code } do_checks :: Bool -- Should we check the stack? - -> WordOff -- Heap headroom - -> CmmAGraph -- What to do on failure + -> WordOff -- Heap headroom + -> CmmAGraph -- What to do on failure -> CmmAGraph do_checks checkStack alloc do_gc = withFreshLabel "gc" $ \ loop_id -> withFreshLabel "gc" $ \ gc_id -> - mkLabel loop_id + mkLabel loop_id <*> (let hpCheck = if alloc == 0 then mkNop else mkAssign hpReg bump_hp <*> - mkCmmIfThen hp_oflo (save_alloc <*> mkBranch gc_id) - in if checkStack then - mkCmmIfThenElse sp_oflo (mkBranch gc_id) hpCheck - else hpCheck) + mkCmmIfThen hp_oflo (alloc_n <*> mkBranch gc_id) + in if checkStack + then mkCmmIfThenElse sp_oflo (mkBranch gc_id) hpCheck + else hpCheck) <*> mkComment (mkFastString "outOfLine should follow:") - <*> outOfLine (mkLabel gc_id + <*> outOfLine (mkLabel gc_id <*> mkComment (mkFastString "outOfLine here") <*> do_gc <*> mkBranch loop_id) - -- Test for stack pointer exhaustion, then - -- bump heap pointer, and test for heap exhaustion - -- Note that we don't move the heap pointer unless the - -- stack check succeeds. Otherwise we might end up - -- with slop at the end of the current block, which can - -- confuse the LDV profiler. + -- Test for stack pointer exhaustion, then + -- bump heap pointer, and test for heap exhaustion + -- Note that we don't move the heap pointer unless the + -- stack check succeeds. Otherwise we might end up + -- with slop at the end of the current block, which can + -- confuse the LDV profiler. where - alloc_lit = CmmLit (mkIntCLit (alloc*wORD_SIZE)) -- Bytes + alloc_lit = CmmLit (mkIntCLit (alloc*wORD_SIZE)) -- Bytes bump_hp = cmmOffsetExprB (CmmReg hpReg) alloc_lit - -- Sp overflow if (Sp - CmmHighStack < SpLim) - sp_oflo = CmmMachOp mo_wordULt - [CmmMachOp (MO_Sub (typeWidth (cmmRegType spReg))) + -- Sp overflow if (Sp - CmmHighStack < SpLim) + sp_oflo = CmmMachOp mo_wordULt + [CmmMachOp (MO_Sub (typeWidth (cmmRegType spReg))) [CmmReg spReg, CmmLit CmmHighStackMark], CmmReg spLimReg] - -- Hp overflow if (Hp > HpLim) - -- (Hp has been incremented by now) - -- HpLim points to the LAST WORD of valid allocation space. - hp_oflo = CmmMachOp mo_wordUGt - [CmmReg hpReg, CmmReg (CmmGlobal HpLim)] - save_alloc = mkAssign (CmmGlobal HpAlloc) alloc_lit + -- Hp overflow if (Hp > HpLim) + -- (Hp has been incremented by now) + -- HpLim points to the LAST WORD of valid allocation space. + hp_oflo = CmmMachOp mo_wordUGt + [CmmReg hpReg, CmmReg (CmmGlobal HpLim)] + + alloc_n = mkAssign (CmmGlobal HpAlloc) alloc_lit {- @@ -483,34 +531,34 @@ always organise the stack-resident fields into pointers & non-pointers, and pass the number of each to the heap check code. -} -unbxTupleHeapCheck - :: [(Id, GlobalReg)] -- Live registers - -> WordOff -- no. of stack slots containing ptrs - -> WordOff -- no. of stack slots containing nonptrs - -> CmmAGraph -- code to insert in the failure path - -> FCode () - -> FCode () +unbxTupleHeapCheck + :: [(Id, GlobalReg)] -- Live registers + -> WordOff -- no. of stack slots containing ptrs + -> WordOff -- no. of stack slots containing nonptrs + -> CmmAGraph -- code to insert in the failure path + -> FCode () + -> FCode () unbxTupleHeapCheck regs ptrs nptrs fail_code code - -- We can't manage more than 255 pointers/non-pointers + -- We can't manage more than 255 pointers/non-pointers -- in a generic heap check. | ptrs > 255 || nptrs > 255 = panic "altHeapCheck" - | otherwise + | otherwise = initHeapUsage $ \ hpHw -> do - { codeOnly $ do { do_checks 0 {- no stack check -} hpHw - full_fail_code rts_label - ; tickyAllocHeap hpHw } - ; setRealHp hpHw - ; code } + { codeOnly $ do { do_checks 0 {- no stack check -} hpHw + full_fail_code rts_label + ; tickyAllocHeap hpHw } + ; setRealHp hpHw + ; code } where full_fail_code = fail_code `plusStmts` oneStmt assign_liveness - assign_liveness = CmmAssign (CmmGlobal (VanillaReg 9)) -- Ho ho ho! - (CmmLit (mkWordCLit liveness)) - liveness = mkRegLiveness regs ptrs nptrs - rts_label = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "stg_gc_ut"))) + assign_liveness = CmmAssign (CmmGlobal (VanillaReg 9)) -- Ho ho ho! + (CmmLit (mkWordCLit liveness)) + liveness = mkRegLiveness regs ptrs nptrs + rts_label = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "stg_gc_ut"))) -{- Old Gransim comment -- I have no idea whether it still makes sense (SLPJ Sep07) +{- Old Gransim com -- I have no idea whether it still makes sense (SLPJ Sep07) For GrAnSim the code for doing a heap check and doing a context switch has been separated. Especially, the HEAP_CHK macro only performs a heap check. THREAD_CONTEXT_SWITCH should be used for doing a context @@ -530,9 +578,9 @@ in the meantime. %************************************************************************ -%* * +%* * Generic Heap/Stack Checks - used in the RTS -%* * +%* * %************************************************************************ \begin{code} @@ -541,9 +589,9 @@ = do_checks' bytes True assigns stg_gc_gen where assigns = mkStmts [ - CmmAssign (CmmGlobal (VanillaReg 9)) liveness, - CmmAssign (CmmGlobal (VanillaReg 10)) reentry - ] + CmmAssign (CmmGlobal (VanillaReg 9)) liveness, + CmmAssign (CmmGlobal (VanillaReg 10)) reentry + ] -- a heap check where R1 points to the closure to enter on return, and -- we want to assign to Sp[0] on failure (used in AutoApply.cmm:BUILD_PAP). diff -Nru ghc-7.0.3/compiler/codeGen/StgCmmHpc.hs ghc-7.2.1/compiler/codeGen/StgCmmHpc.hs --- ghc-7.0.3/compiler/codeGen/StgCmmHpc.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/codeGen/StgCmmHpc.hs 2011-08-07 17:10:05.000000000 +0000 @@ -8,20 +8,16 @@ module StgCmmHpc ( initHpc, mkTickBox ) where -import StgCmmUtils import StgCmmMonad -import StgCmmForeign -import MkZipCfgCmm -import Cmm +import MkGraph +import CmmExpr import CLabel import Module import CmmUtils -import FastString +import StgCmmUtils import HscTypes -import Data.Char import StaticFlags -import BasicTypes mkTickBox :: Module -> Int -> CmmAGraph mkTickBox mod n @@ -32,43 +28,16 @@ where tick_box = cmmIndex W64 (CmmLit $ CmmLabel $ mkHpcTicksLabel $ mod) - (fromIntegral n) + n -initHpc :: Module -> HpcInfo -> FCode CmmAGraph +initHpc :: Module -> HpcInfo -> FCode () -- Emit top-level tables for HPC and return code to initialise initHpc _ (NoHpcInfo {}) - = return mkNop -initHpc this_mod (HpcInfo tickCount hashNo) - = getCode $ whenC opt_Hpc $ - do { emitData ReadOnlyData - [ CmmDataLabel mkHpcModuleNameLabel - , CmmString $ map (fromIntegral . ord) - (full_name_str) - ++ [0] - ] - ; emitData Data $ [ CmmDataLabel (mkHpcTicksLabel this_mod) - ] ++ - [ CmmStaticLit (CmmInt 0 W64) - | _ <- take tickCount [0::Int ..] - ] - - ; id <- newTemp bWord -- TODO FIXME NOW - ; emitCCall - [(id,NoHint)] - (CmmLit $ CmmLabel $ mkForeignLabel mod_alloc Nothing ForeignLabelInThisPackage IsFunction) - [ (mkLblExpr mkHpcModuleNameLabel,AddrHint) - , (CmmLit $ mkIntCLit tickCount,NoHint) - , (CmmLit $ mkIntCLit hashNo,NoHint) - , (CmmLit $ CmmLabel $ mkHpcTicksLabel $ this_mod,AddrHint) - ] + = return () +initHpc this_mod (HpcInfo tickCount _hashNo) + = whenC opt_Hpc $ + do { emitDataLits (mkHpcTicksLabel this_mod) + [ (CmmInt 0 W64) + | _ <- take tickCount [0::Int ..] + ] } - where - mod_alloc = mkFastString "hs_hpc_module" - module_name_str = moduleNameString (Module.moduleName this_mod) - full_name_str = if modulePackageId this_mod == mainPackageId - then module_name_str - else packageIdString (modulePackageId this_mod) ++ "/" ++ - module_name_str - - - diff -Nru ghc-7.0.3/compiler/codeGen/StgCmm.hs ghc-7.2.1/compiler/codeGen/StgCmm.hs --- ghc-7.0.3/compiler/codeGen/StgCmm.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/codeGen/StgCmm.hs 2011-08-07 17:10:05.000000000 +0000 @@ -23,16 +23,14 @@ import StgCmmHpc import StgCmmTicky -import MkZipCfgCmm -import Cmm -import CmmUtils +import MkGraph +import CmmExpr +import CmmDecl import CLabel import PprCmm import StgSyn -import PrelNames import DynFlags -import StaticFlags import HscTypes import CostCentre @@ -49,17 +47,14 @@ codeGen :: DynFlags -> Module -> [TyCon] - -> [Module] -- Directly-imported modules - -> CollectedCCs -- (Local/global) cost-centres needing declaring/registering. + -> CollectedCCs -- (Local/global) cost-centres needing declaring/registering. -> [(StgBinding,[(Id,[Id])])] -- Bindings to convert, with SRTs -> HpcInfo - -> IO [CmmZ] -- Output + -> IO [Cmm] -- Output -codeGen dflags this_mod data_tycons imported_mods +codeGen dflags this_mod data_tycons cost_centre_info stg_binds hpc_info = do { showPass dflags "New CodeGen" - ; let way = buildTag dflags - main_mod = mainModIs dflags -- Why? -- ; mapM_ (\x -> seq x (return ())) data_tycons @@ -67,10 +62,9 @@ ; code_stuff <- initC dflags this_mod $ do { cmm_binds <- mapM (getCmm . cgTopBinding dflags) stg_binds ; cmm_tycons <- mapM cgTyCon data_tycons - ; cmm_init <- getCmm (mkModuleInit way cost_centre_info - this_mod main_mod - imported_mods hpc_info) - ; return (cmm_binds ++ concat cmm_tycons ++ [cmm_init]) + ; cmm_init <- getCmm (mkModuleInit cost_centre_info + this_mod hpc_info) + ; return (cmm_init : cmm_binds ++ concat cmm_tycons) } -- Put datatype_stuff after code_stuff, because the -- datatype closure table (for enumeration types) to @@ -81,7 +75,13 @@ -- possible for object splitting to split up the -- pieces later. - ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "New Cmm" (pprCmms code_stuff) + -- Note [codegen-split-init] the cmm_init block must + -- come FIRST. This is because when -split-objs is on + -- we need to combine this block with its + -- initialisation routines; see Note + -- [pipeline-split-init]. + + ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "New Cmm" (pprCmms (targetPlatform dflags) code_stuff) ; return code_stuff } @@ -172,89 +172,18 @@ -} mkModuleInit - :: String -- the "way" - -> CollectedCCs -- cost centre info + :: CollectedCCs -- cost centre info -> Module - -> Module -- name of the Main module - -> [Module] - -> HpcInfo + -> HpcInfo -> FCode () -mkModuleInit way cost_centre_info this_mod main_mod imported_mods hpc_info - = do { -- Allocate the static boolean that records if this - -- module has been registered already - emitData Data [CmmDataLabel moduleRegdLabel, - CmmStaticLit zeroCLit] - - ; init_hpc <- initHpc this_mod hpc_info - ; init_prof <- initCostCentres cost_centre_info - - -- We emit a recursive descent module search for all modules - -- and *choose* to chase it in :Main, below. - -- In this way, Hpc enabled modules can interact seamlessly with - -- not Hpc enabled moduled, provided Main is compiled with Hpc. - - ; updfr_sz <- getUpdFrameOff - ; tail <- getCode (pushUpdateFrame imports - (do updfr_sz' <- getUpdFrameOff - emit $ mkReturn (ret_e updfr_sz') [] (pop_ret_loc updfr_sz'))) - ; emitSimpleProc real_init_lbl $ (withFreshLabel "ret_block" $ \retId -> catAGraphs - [ check_already_done retId updfr_sz - , init_prof - , init_hpc - , tail]) - -- Make the "plain" procedure jump to the "real" init procedure - ; emitSimpleProc plain_init_lbl (jump_to_init updfr_sz) - - -- When compiling the module in which the 'main' function lives, - -- (that is, this_mod == main_mod) - -- we inject an extra stg_init procedure for stg_init_ZCMain, for the - -- RTS to invoke. We must consult the -main-is flag in case the - -- user specified a different function to Main.main - - -- Notice that the recursive descent is optional, depending on what options - -- are enabled. - - - ; whenC (this_mod == main_mod) - (emitSimpleProc plain_main_init_lbl (rec_descent_init updfr_sz)) - } - where - plain_init_lbl = mkPlainModuleInitLabel this_mod - real_init_lbl = mkModuleInitLabel this_mod way - plain_main_init_lbl = mkPlainModuleInitLabel rOOT_MAIN - - jump_to_init updfr_sz = mkJump (mkLblExpr real_init_lbl) [] updfr_sz - - - -- Main refers to GHC.TopHandler.runIO, so make sure we call the - -- init function for GHC.TopHandler. - extra_imported_mods - | this_mod == main_mod = [gHC_TOP_HANDLER] - | otherwise = [] - all_imported_mods = imported_mods ++ extra_imported_mods - imports = map (\mod -> mkLblExpr (mkModuleInitLabel mod way)) - (filter (gHC_PRIM /=) all_imported_mods) - - mod_reg_val = CmmLoad (mkLblExpr moduleRegdLabel) bWord - check_already_done retId updfr_sz - = mkCmmIfThenElse (cmmNeWord (CmmLit zeroCLit) mod_reg_val) - (mkLabel retId <*> mkReturn (ret_e updfr_sz) [] (pop_ret_loc updfr_sz)) mkNop - <*> -- Set mod_reg to 1 to record that we've been here - mkStore (mkLblExpr moduleRegdLabel) (CmmLit (mkIntCLit 1)) - - -- The return-code pops the work stack by - -- incrementing Sp, and then jumps to the popped item - ret_e updfr_sz = CmmLoad (CmmStackSlot (CallArea Old) updfr_sz) gcWord - ret_code updfr_sz = mkJump (ret_e updfr_sz) [] (pop_ret_loc updfr_sz) - -- mkAssign spReg (cmmRegOffW spReg 1) <*> - -- mkJump (CmmLoad (cmmRegOffW spReg (-1)) bWord) [] updfr_sz - - pop_ret_loc updfr_sz = updfr_sz - widthInBytes (typeWidth bWord) - - rec_descent_init updfr_sz = - if opt_SccProfilingOn || isHpcUsed hpc_info - then jump_to_init updfr_sz - else ret_code updfr_sz + +mkModuleInit cost_centre_info this_mod hpc_info + = do { initHpc this_mod hpc_info + ; initCostCentres cost_centre_info + -- For backwards compatibility: user code may refer to this + -- label for calling hs_add_root(). + ; emitData Data $ Statics (mkPlainModuleInitLabel this_mod) [] + } --------------------------------------------------------------- -- Generating static stuff for algebraic data types @@ -287,7 +216,7 @@ closures predeclared. -} -cgTyCon :: TyCon -> FCode [CmmZ] -- All constructors merged together +cgTyCon :: TyCon -> FCode [Cmm] -- All constructors merged together cgTyCon tycon = do { constrs <- mapM (getCmm . cgDataCon) (tyConDataCons tycon) @@ -304,7 +233,7 @@ ; return (extra ++ constrs) } -cgEnumerationTyCon :: TyCon -> FCode [CmmZ] +cgEnumerationTyCon :: TyCon -> FCode [Cmm] cgEnumerationTyCon tycon | isEnumerationTyCon tycon = do { tbl <- getCmm $ diff -Nru ghc-7.0.3/compiler/codeGen/StgCmmLayout.hs ghc-7.2.1/compiler/codeGen/StgCmmLayout.hs --- ghc-7.0.3/compiler/codeGen/StgCmmLayout.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/codeGen/StgCmmLayout.hs 2011-08-07 17:10:05.000000000 +0000 @@ -6,13 +6,6 @@ -- ----------------------------------------------------------------------------- -{-# OPTIONS #-} --- 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 - module StgCmmLayout ( mkArgDescr, emitCall, emitReturn, @@ -42,10 +35,11 @@ import StgCmmUtils import StgCmmMonad -import MkZipCfgCmm +import MkGraph import SMRep +import CmmDecl +import CmmExpr import CmmUtils -import Cmm import CLabel import StgSyn import DataCon @@ -400,7 +394,7 @@ = let small_bits = case bits of [] -> 0 - [b] -> fromIntegral b + [b] -> b _ -> panic "livenessToAddrMode" in return (smallLiveness size small_bits) @@ -462,7 +456,7 @@ -> Id -- name of the closure -> ClosureInfo -- lots of info abt the closure -> [NonVoid Id] -- incoming arguments - -> ((LocalReg, [LocalReg]) -> FCode ()) -- function body + -> ((Int, LocalReg, [LocalReg]) -> FCode ()) -- function body -> FCode () emitClosureProcAndInfoTable top_lvl bndr cl_info args body = do { let lf_info = closureLFInfo cl_info @@ -474,9 +468,10 @@ ; let node_points = nodeMustPointToIt lf_info ; arg_regs <- bindArgsToRegs args ; let args' = if node_points then (node : arg_regs) else arg_regs - conv = if nodeMustPointToIt lf_info - then NativeNodeCall else NativeDirectCall - ; emitClosureAndInfoTable cl_info conv args' $ body (node, arg_regs) + conv = if nodeMustPointToIt lf_info then NativeNodeCall + else NativeDirectCall + (offset, _) = mkCallEntry conv args' + ; emitClosureAndInfoTable cl_info conv args' $ body (offset, node, arg_regs) } -- Data constructors need closures, but not with all the argument handling @@ -486,14 +481,12 @@ emitClosureAndInfoTable cl_info conv args body = do { info <- mkCmmInfo cl_info ; blks <- getCode body - ; emitProcWithConvention conv info (infoLblToEntryLbl info_lbl) args blks + ; emitProcWithConvention conv info (entryLabelFromCI cl_info) args blks } - where - info_lbl = infoTableLabelFromCI cl_info --- Convert from 'ClosureInfo' to 'CmmInfo'. +-- Convert from 'ClosureInfo' to 'CmmInfoTable'. -- Not used for return points. (The 'smRepClosureTypeInt' call would panic.) -mkCmmInfo :: ClosureInfo -> FCode CmmInfo +mkCmmInfo :: ClosureInfo -> FCode CmmInfoTable mkCmmInfo cl_info = do { info <- closureTypeInfo cl_info k_with_con_name return ; prof <- if opt_SccProfilingOn then @@ -501,25 +494,13 @@ ad_lit <- mkStringCLit (closureValDescr cl_info) return $ ProfilingInfo fd_lit ad_lit else return $ ProfilingInfo (mkIntCLit 0) (mkIntCLit 0) - ; return (CmmInfo gc_target Nothing - (CmmInfoTable (isStaticClosure cl_info) prof cl_type info)) } + ; return (CmmInfoTable (infoTableLabelFromCI cl_info) (isStaticClosure cl_info) prof cl_type info) } where k_with_con_name con_info con info_lbl = do cstr <- mkByteStringCLit $ dataConIdentity con return $ con_info $ makeRelativeRefTo info_lbl cstr cl_type = smRepClosureTypeInt (closureSMRep cl_info) - -- The gc_target is to inform the CPS pass when it inserts a stack check. - -- Since that pass isn't used yet we'll punt for now. - -- When the CPS pass is fully integrated, this should - -- be replaced by the label that any heap check jumped to, - -- so that branch can be shared by both the heap (from codeGen) - -- and stack checks (from the CPS pass). - -- JD: Actually, we've decided to go a different route here: - -- the code generator is now responsible for producing the - -- stack limit check explicitly, so this field is now obsolete. - gc_target = Nothing - ----------------------------------------------------------------------------- -- -- Info table offsets diff -Nru ghc-7.0.3/compiler/codeGen/StgCmmMonad.hs ghc-7.2.1/compiler/codeGen/StgCmmMonad.hs --- ghc-7.0.3/compiler/codeGen/StgCmmMonad.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/codeGen/StgCmmMonad.hs 2011-08-07 17:10:05.000000000 +0000 @@ -51,10 +51,11 @@ import StgCmmClosure import DynFlags -import MkZipCfgCmm -import ZipCfgCmmRep (UpdFrameOffset) +import MkGraph import BlockId -import Cmm +import CmmDecl +import CmmExpr +import CmmNode (UpdFrameOffset) import CLabel import TyCon ( PrimRep ) import SMRep @@ -63,7 +64,6 @@ import VarEnv import OrdList import Unique -import Util() import UniqSupply import FastString(sLit) import Outputable @@ -244,7 +244,7 @@ = MkCgState { cgs_stmts :: CmmAGraph, -- Current procedure - cgs_tops :: OrdList CmmTopZ, + cgs_tops :: OrdList CmmTop, -- Other procedures and data blocks in this compilation unit -- Both are ordered only so that we can -- reduce forward references, when it's easy to do so @@ -537,22 +537,22 @@ -- that the virtual Hp is moved on to the worst virtual Hp for the branches forkAlts branch_fcodes - = do { info_down <- getInfoDown - ; us <- newUniqSupply - ; state <- getState - ; let compile us branch - = (us2, doFCode branch info_down branch_state) - where - (us1,us2) = splitUniqSupply us - branch_state = (initCgState us1) { - cgs_binds = cgs_binds state, - cgs_hp_usg = cgs_hp_usg state } - - (_us, results) = mapAccumL compile us branch_fcodes - (branch_results, branch_out_states) = unzip results - ; setState $ foldl stateIncUsage state branch_out_states - -- NB foldl. state is the *left* argument to stateIncUsage - ; return branch_results } + = do { info_down <- getInfoDown + ; us <- newUniqSupply + ; state <- getState + ; let compile us branch + = (us2, doFCode branch info_down branch_state) + where + (us1,us2) = splitUniqSupply us + branch_state = (initCgState us1) { + cgs_binds = cgs_binds state, + cgs_hp_usg = cgs_hp_usg state } + + (_us, results) = mapAccumL compile us branch_fcodes + (branch_results, branch_out_states) = unzip results + ; setState $ foldl stateIncUsage state branch_out_states + -- NB foldl. state is the *left* argument to stateIncUsage + ; return branch_results } -- collect the code emitted by an FCode computation getCodeR :: FCode a -> FCode (a, CmmAGraph) @@ -593,31 +593,32 @@ = do { state <- getState ; setState $ state { cgs_stmts = cgs_stmts state <*> ag } } -emitData :: Section -> [CmmStatic] -> FCode () +emitData :: Section -> CmmStatics -> FCode () emitData sect lits = do { state <- getState ; setState $ state { cgs_tops = cgs_tops state `snocOL` data_block } } where data_block = CmmData sect lits -emitProcWithConvention :: Convention -> CmmInfo -> CLabel -> CmmFormals -> +emitProcWithConvention :: Convention -> CmmInfoTable -> CLabel -> [CmmFormal] -> CmmAGraph -> FCode () emitProcWithConvention conv info lbl args blocks = do { us <- newUniqSupply - ; let (offset, entry) = mkEntry (mkBlockId $ uniqFromSupply us) conv args + ; let (offset, entry) = mkCallEntry conv args blks = initUs_ us $ lgraphOfAGraph $ entry <*> blocks - ; let proc_block = CmmProc info lbl args ((offset, Just initUpdFrameOff), blks) + ; let sinfo = StackInfo {arg_space = offset, updfr_space = Just initUpdFrameOff} + proc_block = CmmProc (TopInfo {info_tbl=info, stack_info=sinfo}) lbl blks ; state <- getState ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } } -emitProc :: CmmInfo -> CLabel -> CmmFormals -> CmmAGraph -> FCode () +emitProc :: CmmInfoTable -> CLabel -> [CmmFormal] -> CmmAGraph -> FCode () emitProc = emitProcWithConvention NativeNodeCall emitSimpleProc :: CLabel -> CmmAGraph -> FCode () emitSimpleProc lbl code = - emitProc (CmmInfo Nothing Nothing CmmNonInfoTable) lbl [] code + emitProc CmmNonInfoTable lbl [] code -getCmm :: FCode () -> FCode CmmZ +getCmm :: FCode () -> FCode Cmm -- Get all the CmmTops (there should be no stmts) -- Return a single Cmm which may be split from other Cmms by -- object splitting (at a later stage) diff -Nru ghc-7.0.3/compiler/codeGen/StgCmmPrim.hs ghc-7.2.1/compiler/codeGen/StgCmmPrim.hs --- ghc-7.0.3/compiler/codeGen/StgCmmPrim.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/codeGen/StgCmmPrim.hs 2011-08-07 17:10:05.000000000 +0000 @@ -17,10 +17,15 @@ import StgCmmEnv import StgCmmMonad import StgCmmUtils +import StgCmmTicky +import StgCmmHeap +import StgCmmProf -import MkZipCfgCmm +import BasicTypes +import MkGraph import StgSyn -import Cmm +import CmmDecl +import CmmExpr import Type ( Type, tyConAppTyCon ) import TyCon import CLabel @@ -205,6 +210,18 @@ (CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "newSpark")))) [(CmmReg (CmmGlobal BaseReg), AddrHint), (arg,AddrHint)] +emitPrimOp [res] SparkOp [arg] + = do + -- returns the value of arg in res. We're going to therefore + -- refer to arg twice (once to pass to newSpark(), and once to + -- assign to res), so put it in a temporary. + tmp <- assignTemp arg + emitCCall + [] + (CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "newSpark")))) + [(CmmReg (CmmGlobal BaseReg), AddrHint), ((CmmReg (CmmLocal tmp)), AddrHint)] + emit (mkAssign (CmmLocal res) (CmmReg (CmmLocal tmp))) + emitPrimOp [res] ReadMutVarOp [mutv] = emit (mkAssign (CmmLocal res) (cmmLoadIndexW mutv fixedHdrSize gcWord)) @@ -280,12 +297,32 @@ emitPrimOp [res] UnsafeFreezeByteArrayOp [arg] = emit (mkAssign (CmmLocal res) arg) +-- Copying pointer arrays + +emitPrimOp [] CopyArrayOp [src,src_off,dst,dst_off,n] = + doCopyArrayOp src src_off dst dst_off n +emitPrimOp [] CopyMutableArrayOp [src,src_off,dst,dst_off,n] = + doCopyMutableArrayOp src src_off dst dst_off n +emitPrimOp [res] CloneArrayOp [src,src_off,n] = + emitCloneArray mkMAP_FROZEN_infoLabel res src src_off n +emitPrimOp [res] CloneMutableArrayOp [src,src_off,n] = + emitCloneArray mkMAP_DIRTY_infoLabel res src src_off n +emitPrimOp [res] FreezeArrayOp [src,src_off,n] = + emitCloneArray mkMAP_FROZEN_infoLabel res src src_off n +emitPrimOp [res] ThawArrayOp [src,src_off,n] = + emitCloneArray mkMAP_DIRTY_infoLabel res src src_off n + -- Reading/writing pointer arrays emitPrimOp [r] ReadArrayOp [obj,ix] = doReadPtrArrayOp r obj ix emitPrimOp [r] IndexArrayOp [obj,ix] = doReadPtrArrayOp r obj ix emitPrimOp [] WriteArrayOp [obj,ix,v] = doWritePtrArrayOp obj ix v +emitPrimOp [res] SizeofArrayOp [arg] + = emit $ mkAssign (CmmLocal res) (cmmLoadIndexW arg (fixedHdrSize + oFFSET_StgMutArrPtrs_ptrs) bWord) +emitPrimOp [res] SizeofMutableArrayOp [arg] + = emitPrimOp [res] SizeofArrayOp [arg] + -- IndexXXXoffAddr emitPrimOp res IndexOffAddrOp_Char args = doIndexOffAddrOp (Just mo_u_8ToWord) b8 res args @@ -400,6 +437,11 @@ emitPrimOp res WriteByteArrayOp_Word32 args = doWriteByteArrayOp (Just mo_WordTo32) res args emitPrimOp res WriteByteArrayOp_Word64 args = doWriteByteArrayOp Nothing res args +-- Copying byte arrays +emitPrimOp [] CopyByteArrayOp [src,src_off,dst,dst_off,n] = + doCopyByteArrayOp src src_off dst dst_off n +emitPrimOp [] CopyMutableByteArrayOp [src,src_off,dst,dst_off,n] = + doCopyMutableByteArrayOp src src_off dst dst_off n -- The rest just translate straightforwardly emitPrimOp [res] op [arg] @@ -678,3 +720,223 @@ setInfo :: CmmExpr -> CmmExpr -> CmmAGraph setInfo closure_ptr info_ptr = mkStore closure_ptr info_ptr +-- ---------------------------------------------------------------------------- +-- Copying byte arrays + +-- | Takes a source 'ByteArray#', an offset in the source array, a +-- destination 'MutableByteArray#', an offset into the destination +-- array, and the number of bytes to copy. Copies the given number of +-- bytes from the source array to the destination array. +doCopyByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> FCode () +doCopyByteArrayOp = emitCopyByteArray copy + where + -- Copy data (we assume the arrays aren't overlapping since + -- they're of different types) + copy _src _dst dst_p src_p bytes = + emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit 1)) + +-- | Takes a source 'MutableByteArray#', an offset in the source +-- array, a destination 'MutableByteArray#', an offset into the +-- destination array, and the number of bytes to copy. Copies the +-- given number of bytes from the source array to the destination +-- array. +doCopyMutableByteArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> FCode () +doCopyMutableByteArrayOp = emitCopyByteArray copy + where + -- The only time the memory might overlap is when the two arrays + -- we were provided are the same array! + -- TODO: Optimize branch for common case of no aliasing. + copy src dst dst_p src_p bytes = do + [moveCall, cpyCall] <- forkAlts [ + getCode $ emitMemmoveCall dst_p src_p bytes (CmmLit (mkIntCLit 1)), + getCode $ emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit 1)) + ] + emit $ mkCmmIfThenElse (cmmEqWord src dst) moveCall cpyCall + +emitCopyByteArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> FCode ()) + -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> FCode () +emitCopyByteArray copy src src_off dst dst_off n = do + dst_p <- assignTempE $ cmmOffsetExpr (cmmOffsetB dst arrWordsHdrSize) dst_off + src_p <- assignTempE $ cmmOffsetExpr (cmmOffsetB src arrWordsHdrSize) src_off + copy src dst dst_p src_p n + +-- ---------------------------------------------------------------------------- +-- Copying pointer arrays + +-- EZY: This code has an unusually high amount of assignTemp calls, seen +-- nowhere else in the code generator. This is mostly because these +-- "primitive" ops result in a surprisingly large amount of code. It +-- will likely be worthwhile to optimize what is emitted here, so that +-- our optimization passes don't waste time repeatedly optimizing the +-- same bits of code. + +-- More closely imitates 'assignTemp' from the old code generator, which +-- returns a CmmExpr rather than a LocalReg. +assignTempE :: CmmExpr -> FCode CmmExpr +assignTempE e = do + t <- assignTemp e + return (CmmReg (CmmLocal t)) + +-- | Takes a source 'Array#', an offset in the source array, a +-- destination 'MutableArray#', an offset into the destination array, +-- and the number of elements to copy. Copies the given number of +-- elements from the source array to the destination array. +doCopyArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> FCode () +doCopyArrayOp = emitCopyArray copy + where + -- Copy data (we assume the arrays aren't overlapping since + -- they're of different types) + copy _src _dst dst_p src_p bytes = + emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit wORD_SIZE)) + + +-- | Takes a source 'MutableArray#', an offset in the source array, a +-- destination 'MutableArray#', an offset into the destination array, +-- and the number of elements to copy. Copies the given number of +-- elements from the source array to the destination array. +doCopyMutableArrayOp :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> FCode () +doCopyMutableArrayOp = emitCopyArray copy + where + -- The only time the memory might overlap is when the two arrays + -- we were provided are the same array! + -- TODO: Optimize branch for common case of no aliasing. + copy src dst dst_p src_p bytes = do + [moveCall, cpyCall] <- forkAlts [ + getCode $ emitMemmoveCall dst_p src_p bytes (CmmLit (mkIntCLit wORD_SIZE)), + getCode $ emitMemcpyCall dst_p src_p bytes (CmmLit (mkIntCLit wORD_SIZE)) + ] + emit $ mkCmmIfThenElse (cmmEqWord src dst) moveCall cpyCall + +emitCopyArray :: (CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> FCode ()) + -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr + -> FCode () +emitCopyArray copy src0 src_off0 dst0 dst_off0 n0 = do + -- Passed as arguments (be careful) + src <- assignTempE src0 + src_off <- assignTempE src_off0 + dst <- assignTempE dst0 + dst_off <- assignTempE dst_off0 + n <- assignTempE n0 + + -- Set the dirty bit in the header. + emit (setInfo dst (CmmLit (CmmLabel mkMAP_DIRTY_infoLabel))) + + dst_elems_p <- assignTempE $ cmmOffsetB dst arrPtrsHdrSize + dst_p <- assignTempE $ cmmOffsetExprW dst_elems_p dst_off + src_p <- assignTempE $ cmmOffsetExprW (cmmOffsetB src arrPtrsHdrSize) src_off + bytes <- assignTempE $ cmmMulWord n (CmmLit (mkIntCLit wORD_SIZE)) + + copy src dst dst_p src_p bytes + + -- The base address of the destination card table + dst_cards_p <- assignTempE $ cmmOffsetExprW dst_elems_p (loadArrPtrsSize dst) + + emitSetCards dst_off dst_cards_p n + +-- | Takes an info table label, a register to return the newly +-- allocated array in, a source array, an offset in the source array, +-- and the number of elements to copy. Allocates a new array and +-- initializes it form the source array. +emitCloneArray :: CLabel -> CmmFormal -> CmmExpr -> CmmExpr -> CmmExpr + -> FCode () +emitCloneArray info_p res_r src0 src_off0 n0 = do + -- Passed as arguments (be careful) + src <- assignTempE src0 + src_off <- assignTempE src_off0 + n <- assignTempE n0 + + card_words <- assignTempE $ (n `cmmUShrWord` + (CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS))) + `cmmAddWord` CmmLit (mkIntCLit 1) + size <- assignTempE $ n `cmmAddWord` card_words + words <- assignTempE $ arrPtrsHdrSizeW `cmmAddWord` size + + arr_r <- newTemp bWord + emitAllocateCall arr_r myCapability words + tickyAllocPrim (CmmLit (mkIntCLit arrPtrsHdrSize)) (n `cmmMulWord` wordSize) + (CmmLit $ mkIntCLit 0) + + let arr = CmmReg (CmmLocal arr_r) + emitSetDynHdr arr (CmmLit (CmmLabel info_p)) curCCSAddr + emit $ mkStore (cmmOffsetB arr (fixedHdrSize * wORD_SIZE + + oFFSET_StgMutArrPtrs_ptrs)) n + emit $ mkStore (cmmOffsetB arr (fixedHdrSize * wORD_SIZE + + oFFSET_StgMutArrPtrs_size)) size + + dst_p <- assignTempE $ cmmOffsetB arr arrPtrsHdrSize + src_p <- assignTempE $ cmmOffsetExprW (cmmOffsetB src arrPtrsHdrSize) + src_off + + emitMemcpyCall dst_p src_p (n `cmmMulWord` wordSize) (CmmLit (mkIntCLit wORD_SIZE)) + + emitMemsetCall (cmmOffsetExprW dst_p n) + (CmmLit (mkIntCLit 1)) + (card_words `cmmMulWord` wordSize) + (CmmLit (mkIntCLit wORD_SIZE)) + emit $ mkAssign (CmmLocal res_r) arr + where + arrPtrsHdrSizeW = CmmLit $ mkIntCLit $ fixedHdrSize + + (sIZEOF_StgMutArrPtrs_NoHdr `div` wORD_SIZE) + wordSize = CmmLit (mkIntCLit wORD_SIZE) + myCapability = CmmReg baseReg `cmmSubWord` + CmmLit (mkIntCLit oFFSET_Capability_r) + +-- | Takes and offset in the destination array, the base address of +-- the card table, and the number of elements affected (*not* the +-- number of cards). Marks the relevant cards as dirty. +emitSetCards :: CmmExpr -> CmmExpr -> CmmExpr -> FCode () +emitSetCards dst_start dst_cards_start n = do + start_card <- assignTempE $ card dst_start + emitMemsetCall (dst_cards_start `cmmAddWord` start_card) + (CmmLit (mkIntCLit 1)) + ((card (dst_start `cmmAddWord` n) `cmmSubWord` start_card) + `cmmAddWord` CmmLit (mkIntCLit 1)) + (CmmLit (mkIntCLit wORD_SIZE)) + where + -- Convert an element index to a card index + card i = i `cmmUShrWord` (CmmLit (mkIntCLit mUT_ARR_PTRS_CARD_BITS)) + +-- | Emit a call to @memcpy@. +emitMemcpyCall :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () +emitMemcpyCall dst src n align = do + emitPrimCall + [ {-no results-} ] + MO_Memcpy + [ dst, src, n, align ] + +-- | Emit a call to @memmove@. +emitMemmoveCall :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () +emitMemmoveCall dst src n align = do + emitPrimCall + [ {- no results -} ] + MO_Memmove + [ dst, src, n, align ] + +-- | Emit a call to @memset@. The second argument must fit inside an +-- unsigned char. +emitMemsetCall :: CmmExpr -> CmmExpr -> CmmExpr -> CmmExpr -> FCode () +emitMemsetCall dst c n align = do + emitPrimCall + [ {- no results -} ] + MO_Memset + [ dst, c, n, align ] + +-- | Emit a call to @allocate@. +emitAllocateCall :: LocalReg -> CmmExpr -> CmmExpr -> FCode () +emitAllocateCall res cap n = do + emitCCall + [ (res, AddrHint) ] + allocate + [ (cap, AddrHint) + , (n, NoHint) + ] + where + allocate = CmmLit (CmmLabel (mkForeignLabel (fsLit "allocate") Nothing + ForeignLabelInExternalPackage IsFunction)) diff -Nru ghc-7.0.3/compiler/codeGen/StgCmmProf.hs ghc-7.2.1/compiler/codeGen/StgCmmProf.hs --- ghc-7.0.3/compiler/codeGen/StgCmmProf.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/codeGen/StgCmmProf.hs 2011-08-07 17:10:05.000000000 +0000 @@ -38,8 +38,9 @@ import StgCmmMonad import SMRep -import MkZipCfgCmm -import Cmm +import MkGraph +import CmmExpr +import CmmDecl import CmmUtils import CLabel @@ -347,14 +348,12 @@ -- Initialising Cost Centres & CCSs --------------------------------------------------------------- -initCostCentres :: CollectedCCs -> FCode CmmAGraph --- Emit the declarations, and return code to register them +initCostCentres :: CollectedCCs -> FCode () +-- Emit the declarations initCostCentres (local_CCs, ___extern_CCs, singleton_CCSs) - = getCode $ whenC opt_SccProfilingOn $ + = whenC opt_SccProfilingOn $ do { mapM_ emitCostCentreDecl local_CCs - ; mapM_ emitCostCentreStackDecl singleton_CCSs - ; emit $ catAGraphs $ map mkRegisterCC local_CCs - ; emit $ catAGraphs $ map mkRegisterCCS singleton_CCSs } + ; mapM_ emitCostCentreStackDecl singleton_CCSs } emitCostCentreDecl :: CostCentre -> FCode () @@ -408,54 +407,6 @@ (ws,ms) = SIZEOF_CostCentreStack `divMod` wORD_SIZE -- --------------------------------------------------------------------------- --- Registering CCs and CCSs - --- (cc)->link = CC_LIST; --- CC_LIST = (cc); --- (cc)->ccID = CC_ID++; - -mkRegisterCC :: CostCentre -> CmmAGraph -mkRegisterCC cc - = withTemp cInt $ \tmp -> - catAGraphs [ - mkStore (cmmOffsetB cc_lit oFFSET_CostCentre_link) - (CmmLoad cC_LIST bWord), - mkStore cC_LIST cc_lit, - mkAssign (CmmLocal tmp) (CmmLoad cC_ID cInt), - mkStore (cmmOffsetB cc_lit oFFSET_CostCentre_ccID) (CmmReg (CmmLocal tmp)), - mkStore cC_ID (cmmRegOffB (CmmLocal tmp) 1) - ] - where - cc_lit = CmmLit (CmmLabel (mkCCLabel cc)) - --- (ccs)->prevStack = CCS_LIST; --- CCS_LIST = (ccs); --- (ccs)->ccsID = CCS_ID++; - -mkRegisterCCS :: CostCentreStack -> CmmAGraph -mkRegisterCCS ccs - = withTemp cInt $ \ tmp -> - catAGraphs [ - mkStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_prevStack) - (CmmLoad cCS_LIST bWord), - mkStore cCS_LIST ccs_lit, - mkAssign (CmmLocal tmp) (CmmLoad cCS_ID cInt), - mkStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_ccsID) (CmmReg (CmmLocal tmp)), - mkStore cCS_ID (cmmRegOffB (CmmLocal tmp) 1) - ] - where - ccs_lit = CmmLit (CmmLabel (mkCCSLabel ccs)) - - -cC_LIST, cC_ID :: CmmExpr -cC_LIST = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CC_LIST"))) -cC_ID = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CC_ID"))) - -cCS_LIST, cCS_ID :: CmmExpr -cCS_LIST = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CCS_LIST"))) -cCS_ID = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CCS_ID"))) - --- --------------------------------------------------------------------------- -- Set the current cost centre stack emitSetCCC :: CostCentre -> FCode () diff -Nru ghc-7.0.3/compiler/codeGen/StgCmmTicky.hs ghc-7.2.1/compiler/codeGen/StgCmmTicky.hs --- ghc-7.0.3/compiler/codeGen/StgCmmTicky.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/codeGen/StgCmmTicky.hs 2011-08-07 17:10:05.000000000 +0000 @@ -48,8 +48,8 @@ import SMRep import StgSyn -import Cmm -import MkZipCfgCmm +import CmmExpr +import MkGraph import CmmUtils import CLabel diff -Nru ghc-7.0.3/compiler/codeGen/StgCmmUtils.hs ghc-7.2.1/compiler/codeGen/StgCmmUtils.hs --- ghc-7.0.3/compiler/codeGen/StgCmmUtils.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/codeGen/StgCmmUtils.hs 2011-08-07 17:10:05.000000000 +0000 @@ -20,10 +20,10 @@ tagToClosure, mkTaggedObjectLoad, - callerSaveVolatileRegs, get_GlobalReg_addr, + callerSaves, callerSaveVolatileRegs, get_GlobalReg_addr, cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord, - cmmUGtWord, + cmmUGtWord, cmmSubWord, cmmMulWord, cmmAddWord, cmmUShrWord, cmmOffsetExprW, cmmOffsetExprB, cmmRegOffW, cmmRegOffB, cmmLabelOffW, cmmLabelOffB, @@ -49,11 +49,11 @@ import StgCmmMonad import StgCmmClosure import BlockId -import Cmm hiding (regUsedIn) -import MkZipCfgCmm +import CmmDecl +import CmmExpr hiding (regUsedIn) +import MkGraph import CLabel import CmmUtils -import PprCmm ( {- instances -} ) import ForeignCall import IdInfo @@ -160,7 +160,8 @@ ----------------------- cmmULtWord, cmmUGeWord, cmmUGtWord, cmmSubWord, - cmmNeWord, cmmEqWord, cmmOrWord, cmmAndWord + cmmNeWord, cmmEqWord, cmmOrWord, cmmAndWord, + cmmUShrWord, cmmAddWord, cmmMulWord :: CmmExpr -> CmmExpr -> CmmExpr cmmOrWord e1 e2 = CmmMachOp mo_wordOr [e1, e2] cmmAndWord e1 e2 = CmmMachOp mo_wordAnd [e1, e2] @@ -170,8 +171,10 @@ cmmUGeWord e1 e2 = CmmMachOp mo_wordUGe [e1, e2] cmmUGtWord e1 e2 = CmmMachOp mo_wordUGt [e1, e2] --cmmShlWord e1 e2 = CmmMachOp mo_wordShl [e1, e2] ---cmmUShrWord e1 e2 = CmmMachOp mo_wordUShr [e1, e2] +cmmUShrWord e1 e2 = CmmMachOp mo_wordUShr [e1, e2] +cmmAddWord e1 e2 = CmmMachOp mo_wordAdd [e1, e2] cmmSubWord e1 e2 = CmmMachOp mo_wordSub [e1, e2] +cmmMulWord e1 e2 = CmmMachOp mo_wordMul [e1, e2] cmmNegate :: CmmExpr -> CmmExpr cmmNegate (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep) @@ -340,6 +343,23 @@ -- * Regs.h claims that BaseReg should be saved last and loaded first -- * This might not have been tickled before since BaseReg is callee save -- * Regs.h saves SparkHd, ParkT1, SparkBase and SparkLim +-- +-- This code isn't actually used right now, because callerSaves +-- only ever returns true in the current universe for registers NOT in +-- system_regs (just do a grep for CALLER_SAVES in +-- includes/stg/MachRegs.h). It's all one giant no-op, and for +-- good reason: having to save system registers on every foreign call +-- would be very expensive, so we avoid assigning them to those +-- registers when we add support for an architecture. +-- +-- Note that the old code generator actually does more work here: it +-- also saves other global registers. We can't (nor want) to do that +-- here, as we don't have liveness information. And really, we +-- shouldn't be doing the workaround at this point in the pipeline, see +-- Note [Register parameter passing] and the ToDo on CmmCall in +-- cmm/CmmNode.hs. Right now the workaround is to avoid inlining across +-- unsafe foreign calls in rewriteAssignments, but this is strictly +-- temporary. callerSaveVolatileRegs :: (CmmAGraph, CmmAGraph) callerSaveVolatileRegs = (caller_save, caller_load) where @@ -396,6 +416,51 @@ #ifdef CALLER_SAVES_Base callerSaves BaseReg = True #endif +#ifdef CALLER_SAVES_R1 +callerSaves (VanillaReg 1 _) = True +#endif +#ifdef CALLER_SAVES_R2 +callerSaves (VanillaReg 2 _) = True +#endif +#ifdef CALLER_SAVES_R3 +callerSaves (VanillaReg 3 _) = True +#endif +#ifdef CALLER_SAVES_R4 +callerSaves (VanillaReg 4 _) = True +#endif +#ifdef CALLER_SAVES_R5 +callerSaves (VanillaReg 5 _) = True +#endif +#ifdef CALLER_SAVES_R6 +callerSaves (VanillaReg 6 _) = True +#endif +#ifdef CALLER_SAVES_R7 +callerSaves (VanillaReg 7 _) = True +#endif +#ifdef CALLER_SAVES_R8 +callerSaves (VanillaReg 8 _) = True +#endif +#ifdef CALLER_SAVES_F1 +callerSaves (FloatReg 1) = True +#endif +#ifdef CALLER_SAVES_F2 +callerSaves (FloatReg 2) = True +#endif +#ifdef CALLER_SAVES_F3 +callerSaves (FloatReg 3) = True +#endif +#ifdef CALLER_SAVES_F4 +callerSaves (FloatReg 4) = True +#endif +#ifdef CALLER_SAVES_D1 +callerSaves (DoubleReg 1) = True +#endif +#ifdef CALLER_SAVES_D2 +callerSaves (DoubleReg 2) = True +#endif +#ifdef CALLER_SAVES_L1 +callerSaves (LongReg 1) = True +#endif #ifdef CALLER_SAVES_Sp callerSaves Sp = True #endif @@ -443,26 +508,26 @@ emitDataLits :: CLabel -> [CmmLit] -> FCode () -- Emit a data-segment data block emitDataLits lbl lits - = emitData Data (CmmDataLabel lbl : map CmmStaticLit lits) + = emitData Data (Statics lbl $ map CmmStaticLit lits) -mkDataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info stmt +mkDataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatics info stmt -- Emit a data-segment data block mkDataLits lbl lits - = CmmData Data (CmmDataLabel lbl : map CmmStaticLit lits) + = CmmData Data (Statics lbl $ map CmmStaticLit lits) emitRODataLits :: CLabel -> [CmmLit] -> FCode () -- Emit a read-only data block emitRODataLits lbl lits - = emitData section (CmmDataLabel lbl : map CmmStaticLit lits) + = emitData section (Statics lbl $ map CmmStaticLit lits) where section | any needsRelocation lits = RelocatableReadOnlyData | otherwise = ReadOnlyData needsRelocation (CmmLabel _) = True needsRelocation (CmmLabelOff _ _) = True needsRelocation _ = False -mkRODataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info stmt +mkRODataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatics info stmt mkRODataLits lbl lits - = CmmData section (CmmDataLabel lbl : map CmmStaticLit lits) + = CmmData section (Statics lbl $ map CmmStaticLit lits) where section | any needsRelocation lits = RelocatableReadOnlyData | otherwise = ReadOnlyData needsRelocation (CmmLabel _) = True @@ -478,7 +543,7 @@ mkByteStringCLit bytes = do { uniq <- newUnique ; let lbl = mkStringLitLabel uniq - ; emitData ReadOnlyData [CmmDataLabel lbl, CmmString bytes] + ; emitData ReadOnlyData $ Statics lbl [CmmString bytes] ; return (CmmLabel lbl) } ------------------------------------------------------------------------- @@ -488,7 +553,13 @@ ------------------------------------------------------------------------- assignTemp :: CmmExpr -> FCode LocalReg --- Make sure the argument is in a local register +-- Make sure the argument is in a local register. +-- We don't bother being particularly aggressive with avoiding +-- unnecessary local registers, since we can rely on a later +-- optimization pass to inline as necessary (and skipping out +-- on things like global registers can be a little dangerous +-- due to them being trashed on foreign calls--though it means +-- the optimization pass doesn't have to do as much work) assignTemp (CmmReg (CmmLocal reg)) = return reg assignTemp e = do { uniq <- newUnique ; let reg = LocalReg uniq (cmmExprType e) diff -Nru ghc-7.0.3/compiler/coreSyn/CoreArity.lhs ghc-7.2.1/compiler/coreSyn/CoreArity.lhs --- ghc-7.0.3/compiler/coreSyn/CoreArity.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/coreSyn/CoreArity.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -29,6 +29,7 @@ import Unique import Outputable import FastString +import Pair \end{code} %************************************************************************ @@ -79,11 +80,13 @@ go (Lam x e) | isId x = go e + 1 | otherwise = go e go (Note n e) | notSccNote n = go e - go (Cast e co) = go e `min` length (typeArity (snd (coercionKind co))) - -- Note [exprArity invariant] + go (Cast e co) = go e `min` length (typeArity (pSnd (coercionKind co))) + -- Note [exprArity invariant] go (App e (Type _)) = go e go (App f a) | exprIsTrivial a = (go f - 1) `max` 0 -- See Note [exprArity for applications] + -- NB: coercions count as a value argument + go _ = 0 @@ -549,7 +552,7 @@ | isId x = arityLam x (arityType cheap_fn e) | otherwise = arityType cheap_fn e - -- Applications; decrease arity + -- Applications; decrease arity, except for types arityType cheap_fn (App fun (Type _)) = arityType cheap_fn fun arityType cheap_fn (App fun arg ) @@ -663,14 +666,14 @@ -- Strip off existing lambdas and casts -- Note [Eta expansion and SCCs] go 0 expr = expr - go n (Lam v body) | isTyCoVar v = Lam v (go n body) - | otherwise = Lam v (go (n-1) body) + go n (Lam v body) | isTyVar v = Lam v (go n body) + | otherwise = Lam v (go (n-1) body) go n (Cast expr co) = Cast (go n expr) co go n expr = -- pprTrace "ee" (vcat [ppr orig_expr, ppr expr, ppr etas]) $ etaInfoAbs etas (etaInfoApp subst' expr etas) where in_scope = mkInScopeSet (exprFreeVars expr) - (in_scope', etas) = mkEtaWW n in_scope (exprType expr) + (in_scope', etas) = mkEtaWW n orig_expr in_scope (exprType expr) subst' = mkEmptySubst in_scope' -- Wrapper Unwrapper @@ -685,10 +688,10 @@ pushCoercion :: Coercion -> [EtaInfo] -> [EtaInfo] pushCoercion co1 (EtaCo co2 : eis) - | isIdentityCoercion co = eis - | otherwise = EtaCo co : eis + | isReflCo co = eis + | otherwise = EtaCo co : eis where - co = co1 `mkTransCoercion` co2 + co = co1 `mkTransCo` co2 pushCoercion co eis = EtaCo co : eis @@ -696,7 +699,7 @@ etaInfoAbs :: [EtaInfo] -> CoreExpr -> CoreExpr etaInfoAbs [] expr = expr etaInfoAbs (EtaVar v : eis) expr = Lam v (etaInfoAbs eis expr) -etaInfoAbs (EtaCo co : eis) expr = Cast (etaInfoAbs eis expr) (mkSymCoercion co) +etaInfoAbs (EtaCo co : eis) expr = Cast (etaInfoAbs eis expr) (mkSymCo co) -------------- etaInfoApp :: Subst -> CoreExpr -> [EtaInfo] -> CoreExpr @@ -704,15 +707,12 @@ -- ((substExpr s e) `appliedto` eis) etaInfoApp subst (Lam v1 e) (EtaVar v2 : eis) - = etaInfoApp subst' e eis - where - subst' | isTyCoVar v1 = CoreSubst.extendTvSubst subst v1 (mkTyVarTy v2) - | otherwise = CoreSubst.extendIdSubst subst v1 (Var v2) + = etaInfoApp (CoreSubst.extendSubstWithVar subst v1 v2) e eis etaInfoApp subst (Cast e co1) eis = etaInfoApp subst e (pushCoercion co' eis) where - co' = CoreSubst.substTy subst co1 + co' = CoreSubst.substCo subst co1 etaInfoApp subst (Case e b _ alts) eis = Case (subst_expr subst e) b1 (coreAltsType alts') alts' @@ -739,24 +739,24 @@ go e (EtaCo co : eis) = go (Cast e co) eis -------------- -mkEtaWW :: Arity -> InScopeSet -> Type +mkEtaWW :: Arity -> CoreExpr -> InScopeSet -> Type -> (InScopeSet, [EtaInfo]) -- EtaInfo contains fresh variables, -- not free in the incoming CoreExpr -- Outgoing InScopeSet includes the EtaInfo vars -- and the original free vars -mkEtaWW orig_n in_scope orig_ty +mkEtaWW orig_n orig_expr in_scope orig_ty = go orig_n empty_subst orig_ty [] where - empty_subst = mkTvSubst in_scope emptyTvSubstEnv + empty_subst = TvSubst in_scope emptyTvSubstEnv go n subst ty eis -- See Note [exprArity invariant] | n == 0 = (getTvInScope subst, reverse eis) | Just (tv,ty') <- splitForAllTy_maybe ty - , let (subst', tv') = substTyVarBndr subst tv + , let (subst', tv') = Type.substTyVarBndr subst tv -- Avoid free vars of the original expression = go n subst' ty' (EtaVar tv' : eis) @@ -772,11 +772,11 @@ -- eta_expand 1 e T -- We want to get -- coerce T (\x::[T] -> (coerce ([T]->Int) e) x) - go n subst ty' (EtaCo (Type.substTy subst co) : eis) + go n subst ty' (EtaCo co : eis) | otherwise -- We have an expression of arity > 0, -- but its type isn't a function. - = WARN( True, ppr orig_n <+> ppr orig_ty ) + = WARN( True, (ppr orig_n <+> ppr orig_ty) $$ ppr orig_expr ) (getTvInScope subst, reverse eis) -- This *can* legitmately happen: -- e.g. coerce Int (\x. x) Essentially the programmer is diff -Nru ghc-7.0.3/compiler/coreSyn/CoreFVs.lhs ghc-7.2.1/compiler/coreSyn/CoreFVs.lhs --- ghc-7.0.3/compiler/coreSyn/CoreFVs.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/coreSyn/CoreFVs.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -15,27 +15,28 @@ -- | A module concerned with finding the free variables of an expression. module CoreFVs ( -- * Free variables of expressions and binding groups - exprFreeVars, -- CoreExpr -> VarSet -- Find all locally-defined free Ids or tyvars - exprFreeIds, -- CoreExpr -> IdSet -- Find all locally-defined free Ids - exprsFreeVars, -- [CoreExpr] -> VarSet - bindFreeVars, -- CoreBind -> VarSet + exprFreeVars, -- CoreExpr -> VarSet -- Find all locally-defined free Ids or tyvars + exprFreeIds, -- CoreExpr -> IdSet -- Find all locally-defined free Ids + exprsFreeVars, -- [CoreExpr] -> VarSet + bindFreeVars, -- CoreBind -> VarSet -- * Selective free variables of expressions InterestingVarFun, - exprSomeFreeVars, exprsSomeFreeVars, + exprSomeFreeVars, exprsSomeFreeVars, -- * Free variables of Rules, Vars and Ids varTypeTyVars, varTypeTcTyVars, - idUnfoldingVars, idFreeVars, idRuleAndUnfoldingVars, + idUnfoldingVars, idFreeVars, idRuleAndUnfoldingVars, idRuleVars, idRuleRhsVars, stableUnfoldingVars, - ruleRhsFreeVars, rulesFreeVars, - ruleLhsOrphNames, ruleLhsFreeIds, + ruleRhsFreeVars, rulesFreeVars, + ruleLhsOrphNames, ruleLhsFreeIds, + vectsFreeVars, -- * Core syntax tree annotation with free variables - CoreExprWithFVs, -- = AnnExpr Id VarSet - CoreBindWithFVs, -- = AnnBind Id VarSet - freeVars, -- CoreExpr -> CoreExprWithFVs - freeVarsOf -- CoreExprWithFVs -> IdSet + CoreExprWithFVs, -- = AnnExpr Id VarSet + CoreBindWithFVs, -- = AnnBind Id VarSet + freeVars, -- CoreExpr -> CoreExprWithFVs + freeVarsOf -- CoreExprWithFVs -> IdSet ) where #include "HsVersions.h" @@ -49,6 +50,8 @@ import VarSet import Var import TcType +import Coercion +import Maybes( orElse ) import Util import BasicTypes( Activation ) import Outputable @@ -179,12 +182,13 @@ expr_fvs :: CoreExpr -> FV expr_fvs (Type ty) = someVars (tyVarsOfType ty) +expr_fvs (Coercion co) = someVars (tyCoVarsOfCo co) expr_fvs (Var var) = oneVar var expr_fvs (Lit _) = noVars expr_fvs (Note _ expr) = expr_fvs expr expr_fvs (App fun arg) = expr_fvs fun `union` expr_fvs arg expr_fvs (Lam bndr body) = addBndr bndr (expr_fvs body) -expr_fvs (Cast expr co) = expr_fvs expr `union` someVars (tyVarsOfType co) +expr_fvs (Cast expr co) = expr_fvs expr `union` someVars (tyCoVarsOfCo co) expr_fvs (Case scrut bndr ty alts) = expr_fvs scrut `union` someVars (tyVarsOfType ty) `union` addBndr bndr @@ -248,10 +252,11 @@ where n = idName v go (Lit _) = emptyNameSet go (Type ty) = orphNamesOfType ty -- Don't need free tyvars + go (Coercion co) = orphNamesOfCo co go (App e1 e2) = go e1 `unionNameSets` go e2 go (Lam v e) = go e `delFromNameSet` idName v go (Note _ e) = go e - go (Cast e co) = go e `unionNameSets` orphNamesOfType co + go (Cast e co) = go e `unionNameSets` orphNamesOfCo co go (Let (NonRec _ r) e) = go e `unionNameSets` go r go (Let (Rec prs) e) = exprsOrphNames (map snd prs) `unionNameSets` go e go (Case e _ ty as) = go e `unionNameSets` orphNamesOfType ty @@ -265,27 +270,25 @@ \end{code} %************************************************************************ -%* * +%* * \section[freevars-everywhere]{Attaching free variables to every sub-expression} -%* * +%* * %************************************************************************ \begin{code} -- | Those variables free in the right hand side of a rule ruleRhsFreeVars :: CoreRule -> VarSet ruleRhsFreeVars (BuiltinRule {}) = noFVs -ruleRhsFreeVars (Rule { ru_fn = fn, ru_bndrs = bndrs, ru_rhs = rhs }) - = delFromUFM fvs fn -- Note [Rule free var hack] - where - fvs = addBndrs bndrs (expr_fvs rhs) isLocalVar emptyVarSet +ruleRhsFreeVars (Rule { ru_fn = _, ru_bndrs = bndrs, ru_rhs = rhs }) + = addBndrs bndrs (expr_fvs rhs) isLocalVar emptyVarSet + -- See Note [Rule free var hack] -- | Those variables free in the both the left right hand sides of a rule ruleFreeVars :: CoreRule -> VarSet ruleFreeVars (BuiltinRule {}) = noFVs -ruleFreeVars (Rule { ru_fn = fn, ru_bndrs = bndrs, ru_rhs = rhs, ru_args = args }) - = delFromUFM fvs fn -- Note [Rule free var hack] - where - fvs = addBndrs bndrs (exprs_fvs (rhs:args)) isLocalVar emptyVarSet +ruleFreeVars (Rule { ru_fn = _, ru_bndrs = bndrs, ru_rhs = rhs, ru_args = args }) + = addBndrs bndrs (exprs_fvs (rhs:args)) isLocalVar emptyVarSet + -- See Note [Rule free var hack] idRuleRhsVars :: (Activation -> Bool) -> Id -> VarSet -- Just the variables free on the *rhs* of a rule @@ -295,8 +298,8 @@ get_fvs (Rule { ru_fn = fn, ru_bndrs = bndrs , ru_rhs = rhs, ru_act = act }) | is_active act - -- See Note [Finding rule RHS free vars] in OccAnal.lhs - = delFromUFM fvs fn -- Note [Rule free var hack] + -- See Note [Finding rule RHS free vars] in OccAnal.lhs + = delFromUFM fvs fn -- Note [Rule free var hack] where fvs = addBndrs bndrs (expr_fvs rhs) isLocalVar emptyVarSet get_fvs _ = noFVs @@ -312,19 +315,32 @@ = addBndrs bndrs (exprs_fvs args) isLocalId emptyVarSet \end{code} -Note [Rule free var hack] +Note [Rule free var hack] (Not a hack any more) ~~~~~~~~~~~~~~~~~~~~~~~~~ -Don't include the Id in its own rhs free-var set. -Otherwise the occurrence analyser makes bindings recursive -that shoudn't be. E.g. - RULE: f (f x y) z ==> f x (f y z) +We used not to include the Id in its own rhs free-var set. +Otherwise the occurrence analyser makes bindings recursive: + f x y = x+y + RULE: f (f x y) z ==> f x (f y z) +However, the occurrence analyser distinguishes "non-rule loop breakers" +from "rule-only loop breakers" (see BasicTypes.OccInfo). So it will +put this 'f' in a Rec block, but will mark the binding as a non-rule loop +breaker, which is perfectly inlinable. + +\begin{code} +-- |Free variables of a vectorisation declaration +vectsFreeVars :: [CoreVect] -> VarSet +vectsFreeVars = foldr (unionVarSet . vectFreeVars) emptyVarSet + where + vectFreeVars (Vect _ Nothing) = noFVs + vectFreeVars (Vect _ (Just rhs)) = expr_fvs rhs isLocalId emptyVarSet + vectFreeVars (NoVect _) = noFVs +\end{code} -Also since rule_fn is a Name, not a Var, we have to use the grungy delUFM. %************************************************************************ -%* * +%* * \section[freevars-everywhere]{Attaching free variables to every sub-expression} -%* * +%* * %************************************************************************ The free variable pass annotates every node in the expression with its @@ -392,15 +408,15 @@ -- Find the type variables free in the type of the variable -- Remember, coercion variables can mention type variables... varTypeTyVars var - | isLocalId var || isCoVar var = tyVarsOfType (idType var) - | otherwise = emptyVarSet -- Global Ids and non-coercion TyVars + | isLocalId var = tyVarsOfType (idType var) + | otherwise = emptyVarSet -- Global Ids and non-coercion TyVars varTypeTcTyVars :: Var -> TyVarSet -- Find the type variables free in the type of the variable -- Remember, coercion variables can mention type variables... varTypeTcTyVars var - | isLocalId var || isCoVar var = tcTyVarsOfType (idType var) - | otherwise = emptyVarSet -- Global Ids and non-coercion TyVars + | isLocalId var = tcTyVarsOfType (idType var) + | otherwise = emptyVarSet -- Global Ids and non-coercion TyVars idFreeVars :: Id -> VarSet -- Type variables, rule variables, and inline variables @@ -411,7 +427,7 @@ bndrRuleAndUnfoldingVars ::Var -> VarSet -- A 'let' can bind a type variable, and idRuleVars assumes -- it's seeing an Id. This function tests first. -bndrRuleAndUnfoldingVars v | isTyCoVar v = emptyVarSet +bndrRuleAndUnfoldingVars v | isTyVar v = emptyVarSet | otherwise = idRuleAndUnfoldingVars v idRuleAndUnfoldingVars :: Id -> VarSet @@ -428,13 +444,15 @@ -- and we'll get exponential behaviour if we look at both unf and rhs! -- But do look at the *real* unfolding, even for loop breakers, else -- we might get out-of-scope variables -idUnfoldingVars id = stableUnfoldingVars (realIdUnfolding id) +idUnfoldingVars id = stableUnfoldingVars isLocalId (realIdUnfolding id) `orElse` emptyVarSet -stableUnfoldingVars :: Unfolding -> VarSet -stableUnfoldingVars (CoreUnfolding { uf_tmpl = rhs, uf_src = src }) - | isStableSource src = exprFreeVars rhs -stableUnfoldingVars (DFunUnfolding _ _ args) = exprsFreeVars (dfunArgExprs args) -stableUnfoldingVars _ = emptyVarSet +stableUnfoldingVars :: InterestingVarFun -> Unfolding -> Maybe VarSet +stableUnfoldingVars fv_cand unf + = case unf of + CoreUnfolding { uf_tmpl = rhs, uf_src = src } + | isStableSource src -> Just (exprSomeFreeVars fv_cand rhs) + DFunUnfolding _ _ args -> Just (exprsSomeFreeVars fv_cand args) + _other -> Nothing \end{code} @@ -510,12 +528,11 @@ body2 = freeVars body body_fvs = freeVarsOf body2 - freeVars (Cast expr co) - = (freeVarsOf expr2 `unionFVs` cfvs, AnnCast expr2 co) + = (freeVarsOf expr2 `unionFVs` cfvs, AnnCast expr2 (cfvs, co)) where expr2 = freeVars expr - cfvs = tyVarsOfType co + cfvs = tyCoVarsOfCo co freeVars (Note other_note expr) = (freeVarsOf expr2, AnnNote other_note expr2) @@ -523,5 +540,7 @@ expr2 = freeVars expr freeVars (Type ty) = (tyVarsOfType ty, AnnType ty) + +freeVars (Coercion co) = (tyCoVarsOfCo co, AnnCoercion co) \end{code} diff -Nru ghc-7.0.3/compiler/coreSyn/CoreLint.lhs ghc-7.2.1/compiler/coreSyn/CoreLint.lhs --- ghc-7.0.3/compiler/coreSyn/CoreLint.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/coreSyn/CoreLint.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -15,6 +15,7 @@ import CoreSyn import CoreFVs import CoreUtils +import Pair import Bag import Literal import DataCon @@ -27,6 +28,7 @@ import PprCore import ErrUtils import SrcLoc +import Kind import Type import TypeRep import Coercion @@ -41,6 +43,7 @@ import Util import Control.Monad import Data.Maybe +import Data.Traversable (traverse) \end{code} %************************************************************************ @@ -166,7 +169,7 @@ -- Check the rhs do { ty <- lintCoreExpr rhs ; lintBinder binder -- Check match to RHS type - ; binder_ty <- applySubst binder_ty + ; binder_ty <- applySubstTy binder_ty ; checkTys binder_ty ty (mkRhsMsg binder ty) -- Check (not isUnLiftedType) (also checks for bogus unboxed tuples) ; checkL (not (isUnLiftedType binder_ty) @@ -179,7 +182,7 @@ -- Check whether binder's specialisations contain any out-of-scope variables ; mapM_ (checkBndrIdInScope binder) bndr_vars - ; when (isNonRuleLoopBreaker (idOccInfo binder) && isInlinePragma (idInlinePragma binder)) + ; when (isStrongLoopBreaker (idOccInfo binder) && isInlinePragma (idInlinePragma binder)) (addWarnL (ptext (sLit "INLINE binder is (non-rule) loop breaker:") <+> ppr binder)) -- Only non-rule loop breakers inhibit inlining @@ -207,14 +210,15 @@ %************************************************************************ \begin{code} -type InType = Type -- Substitution not yet applied -type InVar = Var -type InTyVar = TyVar - -type OutType = Type -- Substitution has been applied to this -type OutVar = Var -type OutTyVar = TyVar -type OutCoVar = CoVar +type InType = Type -- Substitution not yet applied +type InCoercion = Coercion +type InVar = Var +type InTyVar = TyVar + +type OutType = Type -- Substitution has been applied to this +type OutCoercion = Coercion +type OutVar = Var +type OutTyVar = TyVar lintCoreExpr :: CoreExpr -> LintM OutType -- The returned type has the substitution from the monad @@ -227,7 +231,10 @@ = do { checkL (not (var == oneTupleDataConId)) (ptext (sLit "Illegal one-tuple")) - ; checkDeadIdOcc var + ; checkL (isId var && not (isCoVar var)) + (ptext (sLit "Non term variable") <+> ppr var) + + ; checkDeadIdOcc var ; var' <- lookupIdInScope var ; return (idType var') } @@ -236,7 +243,7 @@ lintCoreExpr (Cast expr co) = do { expr_ty <- lintCoreExpr expr - ; co' <- applySubst co + ; co' <- applySubstCo co ; (from_ty, to_ty) <- lintCoercion co' ; checkTys from_ty expr_ty (mkCastErr from_ty expr_ty) ; return to_ty } @@ -251,29 +258,20 @@ ; lintTyBndr tv $ \ tv' -> addLoc (BodyOfLetRec [tv]) $ extendSubstL tv' ty' $ do - { checkKinds tv' ty' + { checkTyKind tv' ty' -- Now extend the substitution so we -- take advantage of it in the body ; lintCoreExpr body } } - | isCoVar tv - = do { co <- applySubst ty - ; (s1,s2) <- addLoc (RhsOf tv) $ lintCoercion co - ; lintTyBndr tv $ \ tv' -> - addLoc (BodyOfLetRec [tv]) $ do - { let (t1,t2) = coVarKind tv' - ; checkTys s1 t1 (mkTyVarLetErr tv ty) - ; checkTys s2 t2 (mkTyVarLetErr tv ty) - ; lintCoreExpr body } } - - | otherwise - = failWithL (mkTyVarLetErr tv ty) -- Not quite accurate - lintCoreExpr (Let (NonRec bndr rhs) body) + | isId bndr = do { lintSingleBinding NotTopLevel NonRecursive (bndr,rhs) - ; addLoc (BodyOfLetRec [bndr]) + ; addLoc (BodyOfLetRec [bndr]) (lintAndScopeId bndr $ \_ -> (lintCoreExpr body)) } + | otherwise + = failWithL (mkLetErr bndr rhs) -- Not quite accurate + lintCoreExpr (Let (Rec pairs) body) = lintAndScopeIds bndrs $ \_ -> do { checkL (null dups) (dupVars dups) @@ -298,7 +296,7 @@ else return (mkForAllTy var' body_ty) } - -- The applySubst is needed to apply the subst to var + -- The applySubstTy is needed to apply the subst to var lintCoreExpr e@(Case scrut var alt_ty alts) = -- Check the scrutinee @@ -338,6 +336,11 @@ lintCoreExpr (Type ty) = do { ty' <- lintInTy ty ; return (typeKind ty') } + +lintCoreExpr (Coercion co) + = do { co' <- lintInCo co + ; let Pair ty1 ty2 = coercionKind co' + ; return (mkPredTy $ EqPred ty1 ty2) } \end{code} %************************************************************************ @@ -352,12 +355,12 @@ \begin{code} lintCoreArg :: OutType -> CoreArg -> LintM OutType lintCoreArg fun_ty (Type arg_ty) - = do { arg_ty' <- applySubst arg_ty - ; lintTyApp fun_ty arg_ty' } + = do { arg_ty' <- applySubstTy arg_ty + ; lintTyApp fun_ty arg_ty' } lintCoreArg fun_ty arg - = do { arg_ty <- lintCoreExpr arg - ; lintValApp arg fun_ty arg_ty } + = do { arg_ty <- lintCoreExpr arg + ; lintValApp arg fun_ty arg_ty } ----------------- lintAltBinders :: OutType -- Scrutinee type @@ -367,7 +370,7 @@ lintAltBinders scrut_ty con_ty [] = checkTys con_ty scrut_ty (mkBadPatMsg con_ty scrut_ty) lintAltBinders scrut_ty con_ty (bndr:bndrs) - | isTyCoVar bndr + | isTyVar bndr = do { con_ty' <- lintTyApp con_ty (mkTyVarTy bndr) ; lintAltBinders scrut_ty con_ty' bndrs } | otherwise @@ -378,11 +381,10 @@ lintTyApp :: OutType -> OutType -> LintM OutType lintTyApp fun_ty arg_ty | Just (tyvar,body_ty) <- splitForAllTy_maybe fun_ty - = do { checkKinds tyvar arg_ty - ; if isCoVar tyvar then - return body_ty -- Co-vars don't appear in body_ty! - else - return (substTyWith [tyvar] [arg_ty] body_ty) } + , isTyVar tyvar + = do { checkTyKind tyvar arg_ty + ; return (substTyWith [tyvar] [arg_ty] body_ty) } + | otherwise = failWithL (mkTyAppMsg fun_ty arg_ty) @@ -400,22 +402,34 @@ \end{code} \begin{code} -checkKinds :: OutVar -> OutType -> LintM () +checkTyKind :: OutTyVar -> OutType -> LintM () -- Both args have had substitution applied -checkKinds tyvar arg_ty +checkTyKind tyvar arg_ty -- Arg type might be boxed for a function with an uncommitted -- tyvar; notably this is used so that we can give -- error :: forall a:*. String -> a -- and then apply it to both boxed and unboxed types. - | isCoVar tyvar = do { (s2,t2) <- lintCoercion arg_ty - ; unless (s1 `coreEqType` s2 && t1 `coreEqType` t2) - (addErrL (mkCoAppErrMsg tyvar arg_ty)) } - | otherwise = do { arg_kind <- lintType arg_ty - ; unless (arg_kind `isSubKind` tyvar_kind) - (addErrL (mkKindErrMsg tyvar arg_ty)) } + = do { arg_kind <- lintType arg_ty + ; unless (arg_kind `isSubKind` tyvar_kind) + (addErrL (mkKindErrMsg tyvar arg_ty)) } where tyvar_kind = tyVarKind tyvar - (s1,t1) = coVarKind tyvar + +-- Check that the kinds of a type variable and a coercion match, that +-- is, if tv :: k then co :: t1 ~ t2 where t1 :: k and t2 :: k. +checkTyCoKind :: TyVar -> OutCoercion -> LintM (OutType, OutType) +checkTyCoKind tv co + = do { (t1,t2) <- lintCoercion co + ; k1 <- lintType t1 + ; k2 <- lintType t2 + ; unless ((k1 `isSubKind` tyvar_kind) && (k2 `isSubKind` tyvar_kind)) + (addErrL (mkTyCoAppErrMsg tv co)) + ; return (t1,t2) } + where + tyvar_kind = tyVarKind tv + +checkTyCoKinds :: [TyVar] -> [OutCoercion] -> LintM [(OutType, OutType)] +checkTyCoKinds = zipWithM checkTyCoKind checkDeadIdOcc :: Id -> LintM () -- Occurrences of an Id should never be dead.... @@ -536,7 +550,7 @@ lintTyBndr :: InTyVar -> (OutTyVar -> LintM a) -> LintM a lintTyBndr tv thing_inside = do { subst <- getTvSubst - ; let (subst', tv') = substTyVarBndr subst tv + ; let (subst', tv') = Type.substTyVarBndr subst tv ; lintTyBndrKind tv' ; updateTvSubst subst' (thing_inside tv') } @@ -581,10 +595,19 @@ -- ToDo: check the kind structure of the type lintInTy ty = addLoc (InType ty) $ - do { ty' <- applySubst ty + do { ty' <- applySubstTy ty ; _ <- lintType ty' ; return ty' } +lintInCo :: InCoercion -> LintM OutCoercion +-- Check the coercion, and apply the substitution to it +-- See Note [Linting type lets] +lintInCo co + = addLoc (InCo co) $ + do { co' <- applySubstCo co + ; _ <- lintCoercion co' + ; return co' } + ------------------- lintKind :: Kind -> LintM () -- Check well-formedness of kinds: *, *->*, etc @@ -598,124 +621,71 @@ ------------------- lintTyBndrKind :: OutTyVar -> LintM () -lintTyBndrKind tv - | isCoVar tv = lintCoVarKind tv - | otherwise = lintKind (tyVarKind tv) - -------------------- -lintCoVarKind :: OutCoVar -> LintM () --- Check the kind of a coercion binder -lintCoVarKind tv - = do { (ty1,ty2) <- lintSplitCoVar tv - ; k1 <- lintType ty1 - ; k2 <- lintType ty2 - ; unless (k1 `eqKind` k2) - (addErrL (sep [ ptext (sLit "Kind mis-match in coercion kind of:") - , nest 2 (quotes (ppr tv)) - , ppr [k1,k2] ])) } - -------------------- -lintSplitCoVar :: CoVar -> LintM (Type,Type) -lintSplitCoVar cv - = case coVarKind_maybe cv of - Just ts -> return ts - Nothing -> failWithL (sep [ ptext (sLit "Coercion variable with non-equality kind:") - , nest 2 (ppr cv <+> dcolon <+> ppr (tyVarKind cv))]) +lintTyBndrKind tv = lintKind (tyVarKind tv) ------------------- -lintCoercion, lintCoercion' :: OutType -> LintM (OutType, OutType) +lintCoercion :: OutCoercion -> LintM (OutType, OutType) -- Check the kind of a coercion term, returning the kind -lintCoercion co - = addLoc (InCoercion co) $ lintCoercion' co +lintCoercion (Refl ty) + = do { ty' <- lintInTy ty + ; return (ty', ty') } -lintCoercion' ty@(TyVarTy tv) - = do { checkTyVarInScope tv - ; if isCoVar tv then return (coVarKind tv) - else return (ty, ty) } - -lintCoercion' ty@(AppTy ty1 ty2) - = do { (s1,t1) <- lintCoercion ty1 - ; (s2,t2) <- lintCoercion ty2 - ; check_co_app ty (typeKind s1) [s2] +lintCoercion co@(TyConAppCo tc cos) + = do { (ss,ts) <- mapAndUnzipM lintCoercion cos + ; check_co_app co (tyConKind tc) ss + ; return (mkTyConApp tc ss, mkTyConApp tc ts) } + +lintCoercion co@(AppCo co1 co2) + = do { (s1,t1) <- lintCoercion co1 + ; (s2,t2) <- lintCoercion co2 + ; check_co_app co (typeKind s1) [s2] ; return (mkAppTy s1 s2, mkAppTy t1 t2) } -lintCoercion' ty@(FunTy ty1 ty2) - = do { (s1,t1) <- lintCoercion ty1 - ; (s2,t2) <- lintCoercion ty2 - ; check_co_app ty (tyConKind funTyCon) [s1, s2] - ; return (FunTy s1 s2, FunTy t1 t2) } - -lintCoercion' ty@(TyConApp tc tys) - | Just (ar, desc) <- isCoercionTyCon_maybe tc - = do { unless (tys `lengthAtLeast` ar) (badCo ty) - ; (s,t) <- lintCoTyConApp ty desc (take ar tys) - ; (ss,ts) <- mapAndUnzipM lintCoercion (drop ar tys) - ; check_co_app ty (typeKind s) ss - ; return (mkAppTys s ss, mkAppTys t ts) } - - | not (tyConHasKind tc) -- Just something bizarre like SuperKindTyCon - = badCo ty - - | otherwise - = do { (ss,ts) <- mapAndUnzipM lintCoercion tys - ; check_co_app ty (tyConKind tc) ss - ; return (TyConApp tc ss, TyConApp tc ts) } - -lintCoercion' ty@(PredTy (ClassP cls tys)) - = do { (ss,ts) <- mapAndUnzipM lintCoercion tys - ; check_co_app ty (tyConKind (classTyCon cls)) ss - ; return (PredTy (ClassP cls ss), PredTy (ClassP cls ts)) } - -lintCoercion' (PredTy (IParam n p_ty)) - = do { (s,t) <- lintCoercion p_ty - ; return (PredTy (IParam n s), PredTy (IParam n t)) } - -lintCoercion' ty@(PredTy (EqPred {})) - = failWithL (badEq ty) - -lintCoercion' (ForAllTy tv ty) - | isCoVar tv - = do { (co1, co2) <- lintSplitCoVar tv - ; (s1,t1) <- lintCoercion co1 - ; (s2,t2) <- lintCoercion co2 - ; (sr,tr) <- lintCoercion ty - ; return (mkCoPredTy s1 s2 sr, mkCoPredTy t1 t2 tr) } +lintCoercion (ForAllCo v co) + = do { lintKind (tyVarKind v) + ; (s,t) <- addInScopeVar v (lintCoercion co) + ; return (ForAllTy v s, ForAllTy v t) } + +lintCoercion (CoVarCo cv) + = do { checkTyCoVarInScope cv + ; return (coVarKind cv) } + +lintCoercion (AxiomInstCo (CoAxiom { co_ax_tvs = tvs + , co_ax_lhs = lhs + , co_ax_rhs = rhs }) + cos) + = do { (tys1, tys2) <- liftM unzip (checkTyCoKinds tvs cos) + ; return (substTyWith tvs tys1 lhs, + substTyWith tvs tys2 rhs) } + +lintCoercion (UnsafeCo ty1 ty2) + = do { ty1' <- lintInTy ty1 + ; ty2' <- lintInTy ty2 + ; return (ty1', ty2') } + +lintCoercion (SymCo co) + = do { (ty1, ty2) <- lintCoercion co + ; return (ty2, ty1) } - | otherwise - = do { lintKind (tyVarKind tv) - ; (s,t) <- addInScopeVar tv (lintCoercion ty) - ; return (ForAllTy tv s, ForAllTy tv t) } - -badCo :: Coercion -> LintM a -badCo co = failWithL (hang (ptext (sLit "Ill-kinded coercion term:")) 2 (ppr co)) - ---------------- -lintCoTyConApp :: Coercion -> CoTyConDesc -> [Coercion] -> LintM (Type,Type) --- Always called with correct number of coercion arguments --- First arg is just for error message -lintCoTyConApp _ CoLeft (co:_) = lintLR fst co -lintCoTyConApp _ CoRight (co:_) = lintLR snd co -lintCoTyConApp _ CoCsel1 (co:_) = lintCsel fstOf3 co -lintCoTyConApp _ CoCsel2 (co:_) = lintCsel sndOf3 co -lintCoTyConApp _ CoCselR (co:_) = lintCsel thirdOf3 co - -lintCoTyConApp _ CoSym (co:_) - = do { (ty1,ty2) <- lintCoercion co - ; return (ty2,ty1) } - -lintCoTyConApp co CoTrans (co1:co2:_) +lintCoercion co@(TransCo co1 co2) = do { (ty1a, ty1b) <- lintCoercion co1 ; (ty2a, ty2b) <- lintCoercion co2 - ; checkL (ty1b `coreEqType` ty2a) + ; checkL (ty1b `eqType` ty2a) (hang (ptext (sLit "Trans coercion mis-match:") <+> ppr co) 2 (vcat [ppr ty1a, ppr ty1b, ppr ty2a, ppr ty2b])) ; return (ty1a, ty2b) } -lintCoTyConApp _ CoInst (co:arg_ty:_) - = do { co_tys <- lintCoercion co +lintCoercion the_co@(NthCo d co) + = do { (s,t) <- lintCoercion co + ; sn <- checkTcApp the_co d s + ; tn <- checkTcApp the_co d t + ; return (sn, tn) } + +lintCoercion (InstCo co arg_ty) + = do { co_tys <- lintCoercion co ; arg_kind <- lintType arg_ty - ; case decompInst_maybe co_tys of - Just ((tv1,tv2), (ty1,ty2)) + ; case splitForAllTy_maybe `traverse` toPair co_tys of + Just (Pair (tv1,ty1) (tv2,ty2)) | arg_kind `isSubKind` tyVarKind tv1 -> return (substTyWith [tv1] [arg_ty] ty1, substTyWith [tv2] [arg_ty] ty2) @@ -723,40 +693,20 @@ -> failWithL (ptext (sLit "Kind mis-match in inst coercion")) Nothing -> failWithL (ptext (sLit "Bad argument of inst")) } -lintCoTyConApp _ (CoAxiom { co_ax_tvs = tvs - , co_ax_lhs = lhs_ty, co_ax_rhs = rhs_ty }) cos - = do { (tys1, tys2) <- mapAndUnzipM lintCoercion cos - ; sequence_ (zipWith checkKinds tvs tys1) - ; return (substTyWith tvs tys1 lhs_ty, - substTyWith tvs tys2 rhs_ty) } - -lintCoTyConApp _ CoUnsafe (ty1:ty2:_) - = do { _ <- lintType ty1 - ; _ <- lintType ty2 -- Ignore kinds; it's unsafe! - ; return (ty1,ty2) } - -lintCoTyConApp _ _ _ = panic "lintCoTyConApp" -- Called with wrong number of coercion args - ---------- -lintLR :: (forall a. (a,a)->a) -> Coercion -> LintM (Type,Type) -lintLR sel co - = do { (ty1,ty2) <- lintCoercion co - ; case decompLR_maybe (ty1,ty2) of - Just res -> return (sel res) - Nothing -> failWithL (ptext (sLit "Bad argument of left/right")) } - ----------- -lintCsel :: (forall a. (a,a,a)->a) -> Coercion -> LintM (Type,Type) -lintCsel sel co - = do { (ty1,ty2) <- lintCoercion co - ; case decompCsel_maybe (ty1,ty2) of - Just res -> return (sel res) - Nothing -> failWithL (ptext (sLit "Bad argument of csel")) } +checkTcApp :: Coercion -> Int -> Type -> LintM Type +checkTcApp co n ty + | Just (_, tys) <- splitTyConApp_maybe ty + , n < length tys + = return (tys !! n) + | otherwise + = failWithL (hang (ptext (sLit "Bad getNth:") <+> ppr co) + 2 (ptext (sLit "Offending type:") <+> ppr ty)) ------------------- lintType :: OutType -> LintM Kind lintType (TyVarTy tv) - = do { checkTyVarInScope tv + = do { checkTyCoVarInScope tv ; return (tyVarKind tv) } lintType ty@(AppTy t1 t2) @@ -767,6 +717,8 @@ = lint_ty_app ty (tyConKind funTyCon) [t1,t2] lintType ty@(TyConApp tc tys) + | tc `hasKey` eqPredPrimTyConKey -- See Note [The (~) TyCon] in TysPrim + = lint_eq_pred ty tys | tyConHasKind tc = lint_ty_app ty (tyConKind tc) tys | otherwise @@ -782,15 +734,31 @@ lintType (PredTy (IParam _ p_ty)) = lintType p_ty -lintType ty@(PredTy (EqPred {})) - = failWithL (badEq ty) +lintType ty@(PredTy (EqPred t1 t2)) + = do { k1 <- lintType t1 + ; k2 <- lintType t2 + ; unless (k1 `eqKind` k2) + (addErrL (sep [ ptext (sLit "Kind mis-match in equality predicate:") + , nest 2 (ppr ty) ])) + ; return unliftedTypeKind } ---------------- lint_ty_app :: Type -> Kind -> [OutType] -> LintM Kind lint_ty_app ty k tys = do { ks <- mapM lintType tys ; lint_kind_app (ptext (sLit "type") <+> quotes (ppr ty)) k ks } - + +lint_eq_pred :: Type -> [OutType] -> LintM Kind +lint_eq_pred ty arg_tys + | [ty1,ty2] <- arg_tys + = do { k1 <- lintType ty1 + ; k2 <- lintType ty2 + ; checkL (k1 `eqKind` k2) + (ptext (sLit "Mismatched arg kinds:") <+> ppr ty) + ; return unliftedTypeKind } + | otherwise + = failWithL (ptext (sLit "Unsaturated (~) type") <+> ppr ty) + ---------------- check_co_app :: Coercion -> Kind -> [OutType] -> LintM () check_co_app ty k tys @@ -812,10 +780,6 @@ Just (kfa, kfb) -> do { unless (k `isSubKind` kfa) (addErrL fail_msg) ; go kfb ks } --------------- -badEq :: Type -> SDoc -badEq ty = hang (ptext (sLit "Unexpected equality predicate:")) - 1 (quotes (ppr ty)) \end{code} %************************************************************************ @@ -870,7 +834,7 @@ | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which) | TopLevelBindings | InType Type -- Inside a type - | InCoercion Coercion -- Inside a type + | InCo Coercion -- Inside a coercion \end{code} @@ -936,12 +900,15 @@ getTvSubst :: LintM TvSubst getTvSubst = LintM (\ _ subst errs -> (Just subst, errs)) -applySubst :: Type -> LintM Type -applySubst ty = do { subst <- getTvSubst; return (substTy subst ty) } +applySubstTy :: Type -> LintM Type +applySubstTy ty = do { subst <- getTvSubst; return (Type.substTy subst ty) } + +applySubstCo :: Coercion -> LintM Coercion +applySubstCo co = do { subst <- getTvSubst; return (substCo (tvCvSubst subst) co) } extendSubstL :: TyVar -> Type -> LintM a -> LintM a extendSubstL tv ty m - = LintM (\ loc subst errs -> unLintM m loc (extendTvSubst subst tv ty) errs) + = LintM (\ loc subst errs -> unLintM m loc (Type.extendTvSubst subst tv ty) errs) \end{code} \begin{code} @@ -969,8 +936,8 @@ msg = ptext (sLit "is out of scope inside info for") <+> ppr binder -checkTyVarInScope :: TyVar -> LintM () -checkTyVarInScope tv = checkInScope (ptext (sLit "is out of scope")) tv +checkTyCoVarInScope :: TyCoVar -> LintM () +checkTyCoVarInScope v = checkInScope (ptext (sLit "is out of scope")) v checkInScope :: SDoc -> Var -> LintM () checkInScope loc_msg var = @@ -982,7 +949,7 @@ -- check ty2 is subtype of ty1 (ie, has same structure but usage -- annotations need only be consistent, not equal) -- Assumes ty1,ty2 are have alrady had the substitution applied -checkTys ty1 ty2 msg = checkL (ty1 `coreEqType` ty2) msg +checkTys ty1 ty2 msg = checkL (ty1 `eqType` ty2) msg \end{code} %************************************************************************ @@ -1021,8 +988,8 @@ = (noSrcLoc, empty) dumpLoc (InType ty) = (noSrcLoc, text "In the type" <+> quotes (ppr ty)) -dumpLoc (InCoercion ty) - = (noSrcLoc, text "In the coercion" <+> quotes (ppr ty)) +dumpLoc (InCo co) + = (noSrcLoc, text "In the coercion" <+> quotes (ppr co)) pp_binders :: [Var] -> SDoc pp_binders bs = sep (punctuate comma (map pp_binder bs)) @@ -1114,29 +1081,21 @@ hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty), hang (ptext (sLit "Arg:")) 4 (ppr arg)] -mkTyVarLetErr :: TyVar -> Type -> Message -mkTyVarLetErr tyvar ty - = vcat [ptext (sLit "Bad `let' binding for type or coercion variable:"), - hang (ptext (sLit "Type/coercion variable:")) - 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)), - hang (ptext (sLit "Arg type/coercion:")) - 4 (ppr ty)] - -mkKindErrMsg :: TyVar -> Type -> Message -mkKindErrMsg tyvar arg_ty - = vcat [ptext (sLit "Kinds don't match in type application:"), - hang (ptext (sLit "Type variable:")) - 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)), - hang (ptext (sLit "Arg type:")) - 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] - -mkCoAppErrMsg :: TyVar -> Type -> Message -mkCoAppErrMsg tyvar arg_ty - = vcat [ptext (sLit "Kinds don't match in coercion application:"), - hang (ptext (sLit "Coercion variable:")) +mkLetErr :: TyVar -> CoreExpr -> Message +mkLetErr bndr rhs + = vcat [ptext (sLit "Bad `let' binding:"), + hang (ptext (sLit "Variable:")) + 4 (ppr bndr <+> dcolon <+> ppr (varType bndr)), + hang (ptext (sLit "Rhs:")) + 4 (ppr rhs)] + +mkTyCoAppErrMsg :: TyVar -> Coercion -> Message +mkTyCoAppErrMsg tyvar arg_co + = vcat [ptext (sLit "Kinds don't match in lifted coercion application:"), + hang (ptext (sLit "Type variable:")) 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)), hang (ptext (sLit "Arg coercion:")) - 4 (ppr arg_ty <+> dcolon <+> pprEqPred (coercionKind arg_ty))] + 4 (ppr arg_co <+> dcolon <+> pprEqPred (coercionKind arg_co))] mkTyAppMsg :: Type -> Type -> Message mkTyAppMsg ty arg_ty @@ -1168,6 +1127,15 @@ hsep [ptext (sLit "Binder's demand info:"), ppr (idDemandInfo binder)] ] + +mkKindErrMsg :: TyVar -> Type -> Message +mkKindErrMsg tyvar arg_ty + = vcat [ptext (sLit "Kinds don't match in type application:"), + hang (ptext (sLit "Type variable:")) + 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)), + hang (ptext (sLit "Arg type:")) + 4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))] + mkArityMsg :: Id -> Message mkArityMsg binder = vcat [hsep [ptext (sLit "Demand type has "), @@ -1203,3 +1171,56 @@ = hang (ptext (sLit "Duplicate top-level variables with the same qualified name")) 2 (ppr vars) \end{code} + +-------------- DEAD CODE ------------------- + +------------------- +checkCoKind :: CoVar -> OutCoercion -> LintM () +-- Both args have had substitution applied +checkCoKind covar arg_co + = do { (s2,t2) <- lintCoercion arg_co + ; unless (s1 `eqType` s2 && t1 `coreEqType` t2) + (addErrL (mkCoAppErrMsg covar arg_co)) } + where + (s1,t1) = coVarKind covar + +lintCoVarKind :: OutCoVar -> LintM () +-- Check the kind of a coercion binder +lintCoVarKind tv + = do { (ty1,ty2) <- lintSplitCoVar tv + ; lintEqType ty1 ty2 + + +------------------- +lintSplitCoVar :: CoVar -> LintM (Type,Type) +lintSplitCoVar cv + = case coVarKind_maybe cv of + Just ts -> return ts + Nothing -> failWithL (sep [ ptext (sLit "Coercion variable with non-equality kind:") + , nest 2 (ppr cv <+> dcolon <+> ppr (tyVarKind cv))]) + +mkCoVarLetErr :: CoVar -> Coercion -> Message +mkCoVarLetErr covar co + = vcat [ptext (sLit "Bad `let' binding for coercion variable:"), + hang (ptext (sLit "Coercion variable:")) + 4 (ppr covar <+> dcolon <+> ppr (coVarKind covar)), + hang (ptext (sLit "Arg coercion:")) + 4 (ppr co)] + +mkCoAppErrMsg :: CoVar -> Coercion -> Message +mkCoAppErrMsg covar arg_co + = vcat [ptext (sLit "Kinds don't match in coercion application:"), + hang (ptext (sLit "Coercion variable:")) + 4 (ppr covar <+> dcolon <+> ppr (coVarKind covar)), + hang (ptext (sLit "Arg coercion:")) + 4 (ppr arg_co <+> dcolon <+> pprEqPred (coercionKind arg_co))] + + +mkCoAppMsg :: Type -> Coercion -> Message +mkCoAppMsg ty arg_co + = vcat [text "Illegal type application:", + hang (ptext (sLit "exp type:")) + 4 (ppr ty <+> dcolon <+> ppr (typeKind ty)), + hang (ptext (sLit "arg type:")) + 4 (ppr arg_co <+> dcolon <+> ppr (coercionKind arg_co))] + diff -Nru ghc-7.0.3/compiler/coreSyn/CorePrep.lhs ghc-7.2.1/compiler/coreSyn/CorePrep.lhs --- ghc-7.0.3/compiler/coreSyn/CorePrep.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/coreSyn/CorePrep.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -18,6 +18,7 @@ import CoreMonad ( endPass, CoreToDo(..) ) import CoreSyn import CoreSubst +import OccurAnal ( occurAnalyseExpr ) import Type import Coercion import TyCon @@ -36,6 +37,7 @@ import ErrUtils import DynFlags import Util +import Pair import Outputable import MonadUtils import FastString @@ -77,9 +79,9 @@ weaker guarantee of no clashes which the simplifier provides. And that is what the code generator needs. - We don't clone TyVars. The code gen doesn't need that, + We don't clone TyVars or CoVars. The code gen doesn't need that, and doing so would be tiresome because then we'd need - to substitute in types. + to substitute in types and coercions. 7. Give each dynamic CCall occurrence a fresh unique; this is @@ -103,19 +105,21 @@ Here is the syntax of the Core produced by CorePrep: Trivial expressions - triv ::= lit | var | triv ty | /\a. triv | triv |> co + triv ::= lit | var + | triv ty | /\a. triv + | truv co | /\c. triv | triv |> co Applications - app ::= lit | var | app triv | app ty | app |> co + app ::= lit | var | app triv | app ty | app co | app |> co Expressions body ::= app | let(rec) x = rhs in body -- Boxed only | case body of pat -> body - | /\a. body + | /\a. body | /\c. body | body |> co - Right hand sides (only place where lambdas can occur) + Right hand sides (only place where value lambdas can occur) rhs ::= /\a.rhs | \x.rhs | body We define a synonym for each of these non-terminals. Functions @@ -248,6 +252,61 @@ partial applications. But it's easier to let them through. +Note [Dead code in CorePrep] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Imagine that we got an input program like this: + + f :: Show b => Int -> (Int, b -> Maybe Int -> Int) + f x = (g True (Just x) + g () (Just x), g) + where + g :: Show a => a -> Maybe Int -> Int + g _ Nothing = x + g y (Just z) = if z > 100 then g y (Just (z + length (show y))) else g y unknown + +After specialisation and SpecConstr, we would get something like this: + + f :: Show b => Int -> (Int, b -> Maybe Int -> Int) + f x = (g$Bool_True_Just x + g$Unit_Unit_Just x, g) + where + {-# RULES g $dBool = g$Bool + g $dUnit = g$Unit #-} + g = ... + {-# RULES forall x. g$Bool True (Just x) = g$Bool_True_Just x #-} + g$Bool = ... + {-# RULES forall x. g$Unit () (Just x) = g$Unit_Unit_Just x #-} + g$Unit = ... + g$Bool_True_Just = ... + g$Unit_Unit_Just = ... + +Note that the g$Bool and g$Unit functions are actually dead code: they are only kept +alive by the occurrence analyser because they are referred to by the rules of g, +which is being kept alive by the fact that it is used (unspecialised) in the returned pair. + +However, at the CorePrep stage there is no way that the rules for g will ever fire, +and it really seems like a shame to produce an output program that goes to the trouble +of allocating a closure for the unreachable g$Bool and g$Unit functions. + +The way we fix this is to: + * In cloneBndr, drop all unfoldings/rules + * In deFloatTop, run the occurrence analyser on each top-level RHS to drop + the dead local bindings + +The reason we don't just OccAnal the whole output of CorePrep is that the tidier +ensures that all top-level binders are GlobalIds, so they don't show up in the free +variables any longer. So if you run the occurrence analyser on the output of CoreTidy +(or later) you e.g. turn this program: + + Rec { + f = ... f ... + } + +Into this one: + + f = ... f ... + +(Since f is not considered to be free in its own RHS.) + + %************************************************************************ %* * The main code @@ -259,7 +318,7 @@ -> CorePrepEnv -> CoreBind -> UniqSM (CorePrepEnv, Floats) cpeBind top_lvl env (NonRec bndr rhs) - = do { (_, bndr1) <- cloneBndr env bndr + = do { (_, bndr1) <- cpCloneBndr env bndr ; let is_strict = isStrictDmd (idDemandInfo bndr) is_unlifted = isUnLiftedType (idType bndr) ; (floats, bndr2, rhs2) <- cpePair top_lvl NonRecursive @@ -274,7 +333,7 @@ cpeBind top_lvl env (Rec pairs) = do { let (bndrs,rhss) = unzip pairs - ; (env', bndrs1) <- cloneBndrs env (map fst pairs) + ; (env', bndrs1) <- cpCloneBndrs env (map fst pairs) ; stuff <- zipWithM (cpePair top_lvl Recursive False env') bndrs1 rhss ; let (floats_s, bndrs2, rhss2) = unzip3 stuff @@ -384,9 +443,10 @@ -- For example -- f (g x) ===> ([v = g x], f v) -cpeRhsE _env expr@(Type _) = return (emptyFloats, expr) -cpeRhsE _env expr@(Lit _) = return (emptyFloats, expr) -cpeRhsE env expr@(Var {}) = cpeApp env expr +cpeRhsE _env expr@(Type {}) = return (emptyFloats, expr) +cpeRhsE _env expr@(Coercion {}) = return (emptyFloats, expr) +cpeRhsE _env expr@(Lit {}) = return (emptyFloats, expr) +cpeRhsE env expr@(Var {}) = cpeApp env expr cpeRhsE env (Var f `App` _ `App` arg) | f `hasKey` lazyIdKey -- Replace (lazy a) by a @@ -412,7 +472,7 @@ cpeRhsE env expr@(Lam {}) = do { let (bndrs,body) = collectBinders expr - ; (env', bndrs') <- cloneBndrs env bndrs + ; (env', bndrs') <- cpCloneBndrs env bndrs ; body' <- cpeBodyNF env' body ; return (emptyFloats, mkLams bndrs' body') } @@ -425,12 +485,12 @@ = do { (floats, scrut') <- cpeBody env scrut ; let bndr1 = bndr `setIdUnfolding` evaldUnfolding -- Record that the case binder is evaluated in the alternatives - ; (env', bndr2) <- cloneBndr env bndr1 + ; (env', bndr2) <- cpCloneBndr env bndr1 ; alts' <- mapM (sat_alt env') alts ; return (floats, Case scrut' bndr2 ty alts') } where sat_alt env (con, bs, rhs) - = do { (env2, bs') <- cloneBndrs env bs + = do { (env2, bs') <- cpCloneBndrs env bs ; rhs' <- cpeBodyNF env2 rhs ; return (con, bs', rhs') } @@ -472,7 +532,7 @@ rhsToBody expr@(Lam {}) | Just no_lam_result <- tryEtaReducePrep bndrs body = return (emptyFloats, no_lam_result) - | all isTyCoVar bndrs -- Type lambdas are ok + | all isTyVar bndrs -- Type lambdas are ok = return (emptyFloats, expr) | otherwise -- Some value lambdas = do { fn <- newVar (exprType expr) @@ -523,6 +583,10 @@ = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun depth ; return (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss) } + collect_args (App fun arg@(Coercion arg_co)) depth + = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun depth + ; return (App fun' arg, hd, applyCo fun_ty arg_co, floats, ss) } + collect_args (App fun arg) depth = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun (depth+1) ; let @@ -552,7 +616,7 @@ -- partial application might be seq'd collect_args (Cast fun co) depth - = do { let (_ty1,ty2) = coercionKind co + = do { let Pair _ty1 ty2 = coercionKind co ; (fun', hd, _, floats, ss) <- collect_args fun depth ; return (Cast fun' co, hd, ty2, floats, ss) } @@ -577,10 +641,7 @@ cpeArg :: CorePrepEnv -> RhsDemand -> CoreArg -> Type -> UniqSM (Floats, CpeTriv) cpeArg env is_strict arg arg_ty - | cpe_ExprIsTrivial arg -- Do not eta expand etc a trivial argument - = cpeBody env arg -- Must still do substitution though - | otherwise - = do { (floats1, arg1) <- cpeRhsE env arg -- arg1 can be a lambda + = do { (floats1, arg1) <- cpeRhsE env arg -- arg1 can be a lambda ; (floats2, arg2) <- if want_float floats1 arg1 then return (floats1, arg1) else do { body1 <- rhsToBodyNF arg1 @@ -588,10 +649,13 @@ -- Else case: arg1 might have lambdas, and we can't -- put them inside a wrapBinds - ; v <- newVar arg_ty + ; if cpe_ExprIsTrivial arg2 -- Do not eta expand a trivial argument + then return (floats2, arg2) + else do + { v <- newVar arg_ty ; let arg3 = cpeEtaExpand (exprArity arg2) arg2 arg_float = mkFloat is_strict is_unlifted v arg3 - ; return (addFloat floats2 arg_float, Var v) } + ; return (addFloat floats2 arg_float, Var v) } } where is_unlifted = isUnLiftedType arg_ty want_float = wantFloatNested NonRecursive (is_strict || is_unlifted) @@ -637,9 +701,7 @@ ------------- saturateDataToTag :: CpeApp -> UniqSM CpeApp --- Horrid: ensure that the arg of data2TagOp is evaluated --- (data2tag x) --> (case x of y -> data2tag y) --- (yuk yuk) take into account the lambdas we've now introduced +-- See Note [dataToTag magic] saturateDataToTag sat_expr = do { let (eta_bndrs, eta_body) = collectBinders sat_expr ; eta_body' <- eval_data2tag_arg eta_body @@ -663,7 +725,14 @@ = pprPanic "eval_data2tag" (ppr other) \end{code} +Note [dataToTag magic] +~~~~~~~~~~~~~~~~~~~~~~ +Horrid: we must ensure that the arg of data2TagOp is evaluated + (data2tag x) --> (case x of y -> data2tag y) +(yuk yuk) take into account the lambdas we've now introduced +How might it not be evaluated? Well, we might have floated it out +of the scope of a `seq`, or dropped the `seq` altogether. %************************************************************************ @@ -690,11 +759,12 @@ -- Version that doesn't consider an scc annotation to be trivial. cpe_ExprIsTrivial (Var _) = True cpe_ExprIsTrivial (Type _) = True +cpe_ExprIsTrivial (Coercion _) = True cpe_ExprIsTrivial (Lit _) = True cpe_ExprIsTrivial (App e arg) = isTypeArg arg && cpe_ExprIsTrivial e cpe_ExprIsTrivial (Note n e) = notSccNote n && cpe_ExprIsTrivial e cpe_ExprIsTrivial (Cast e _) = cpe_ExprIsTrivial e -cpe_ExprIsTrivial (Lam b body) | isTyCoVar b = cpe_ExprIsTrivial body +cpe_ExprIsTrivial (Lam b body) | isTyVar b = cpe_ExprIsTrivial body cpe_ExprIsTrivial _ = False \end{code} @@ -896,8 +966,12 @@ deFloatTop (Floats _ floats) = foldrOL get [] floats where - get (FloatLet b) bs = b:bs + get (FloatLet b) bs = occurAnalyseRHSs b : bs get b _ = pprPanic "corePrepPgm" (ppr b) + + -- See Note [Dead code in CorePrep] + occurAnalyseRHSs (NonRec x e) = NonRec x (occurAnalyseExpr e) + occurAnalyseRHSs (Rec xes) = Rec [(x, occurAnalyseExpr e) | (x, e) <- xes] ------------------------------------------- canFloatFromNoCaf :: Floats -> CpeRhs -> Maybe (Floats, CpeRhs) @@ -1000,18 +1074,24 @@ -- Cloning binders -- --------------------------------------------------------------------------- -cloneBndrs :: CorePrepEnv -> [Var] -> UniqSM (CorePrepEnv, [Var]) -cloneBndrs env bs = mapAccumLM cloneBndr env bs +cpCloneBndrs :: CorePrepEnv -> [Var] -> UniqSM (CorePrepEnv, [Var]) +cpCloneBndrs env bs = mapAccumLM cpCloneBndr env bs -cloneBndr :: CorePrepEnv -> Var -> UniqSM (CorePrepEnv, Var) -cloneBndr env bndr - | isLocalId bndr +cpCloneBndr :: CorePrepEnv -> Var -> UniqSM (CorePrepEnv, Var) +cpCloneBndr env bndr + | isLocalId bndr, not (isCoVar bndr) = do bndr' <- setVarUnique bndr <$> getUniqueM - return (extendCorePrepEnv env bndr bndr', bndr') + + -- We are going to OccAnal soon, so drop (now-useless) rules/unfoldings + -- so that we can drop more stuff as dead code. + -- See also Note [Dead code in CorePrep] + let bndr'' = bndr' `setIdUnfolding` noUnfolding + `setIdSpecialisation` emptySpecInfo + return (extendCorePrepEnv env bndr bndr'', bndr'') | otherwise -- Top level things, which we don't want -- to clone, have become GlobalIds by now - -- And we don't clone tyvars + -- And we don't clone tyvars, or coercion variables = return (env, bndr) diff -Nru ghc-7.0.3/compiler/coreSyn/CoreSubst.lhs ghc-7.2.1/compiler/coreSyn/CoreSubst.lhs --- ghc-7.0.3/compiler/coreSyn/CoreSubst.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/coreSyn/CoreSubst.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -8,25 +8,27 @@ \begin{code} module CoreSubst ( -- * Main data types - Subst, TvSubstEnv, IdSubstEnv, InScopeSet, + Subst(..), -- Implementation exported for supercompiler's Renaming.hs only + TvSubstEnv, IdSubstEnv, InScopeSet, -- ** Substituting into expressions and related types deShadowBinds, substSpec, substRulesForImportedIds, - substTy, substExpr, substExprSC, substBind, substBindSC, + substTy, substCo, substExpr, substExprSC, substBind, substBindSC, substUnfolding, substUnfoldingSC, - substUnfoldingSource, lookupIdSubst, lookupTvSubst, substIdOcc, + substUnfoldingSource, lookupIdSubst, lookupTvSubst, lookupCvSubst, substIdOcc, -- ** Operations on substitutions emptySubst, mkEmptySubst, mkSubst, mkOpenSubst, substInScope, isEmptySubst, extendIdSubst, extendIdSubstList, extendTvSubst, extendTvSubstList, - extendSubst, extendSubstList, zapSubstEnv, + extendCvSubst, extendCvSubstList, + extendSubst, extendSubstList, extendSubstWithVar, zapSubstEnv, addInScopeSet, extendInScope, extendInScopeList, extendInScopeIds, isInScope, setInScope, delBndr, delBndrs, -- ** Substituting and cloning binders substBndr, substBndrs, substRecBndrs, - cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs, + cloneBndrs, cloneIdBndr, cloneIdBndrs, cloneRecIdBndrs, -- ** Simple expression optimiser simpleOptPgm, simpleOptExpr, simpleOptExprWith @@ -37,18 +39,24 @@ import CoreSyn import CoreFVs import CoreUtils -import PprCore import OccurAnal( occurAnalyseExpr, occurAnalysePgm ) import qualified Type -import Type ( Type, TvSubst(..), TvSubstEnv ) -import Coercion ( isIdentityCoercion ) +import qualified Coercion + + -- We are defining local versions +import Type hiding ( substTy, extendTvSubst, extendTvSubstList + , isInScope, substTyVarBndr, cloneTyVarBndr ) +import Coercion hiding ( substTy, substCo, extendTvSubst, substTyVarBndr, substCoVarBndr ) + import OptCoercion ( optCoercion ) +import PprCore ( pprCoreBindings ) +import Module ( Module ) import VarSet import VarEnv import Id import Name ( Name ) -import Var ( Var, TyVar, setVarUnique ) +import Var import IdInfo import Unique import UniqSupply @@ -92,7 +100,8 @@ = Subst InScopeSet -- Variables in in scope (both Ids and TyVars) /after/ -- applying the substitution IdSubstEnv -- Substitution for Ids - TvSubstEnv -- Substitution for TyVars + TvSubstEnv -- Substitution from TyVars to Types + CvSubstEnv -- Substitution from TyCoVars to Coercions -- INVARIANT 1: See #in_scope_invariant# -- This is what lets us deal with name capture properly @@ -126,6 +135,11 @@ * In substIdBndr, we extend the IdSubstEnv only when the unique changes +* If the CvSubstEnv, TvSubstEnv and IdSubstEnv are all empty, + substExpr does nothing (Note that the above rule for substIdBndr + maintains this property. If the incoming envts are both empty, then + substituting the type and IdInfo can't change anything.) + * In lookupIdSubst, we *must* look up the Id in the in-scope set, because it may contain non-trivial changes. Example: (/\a. \x:a. ...x...) Int @@ -140,7 +154,8 @@ * (However, we don't need to do so for expressions found in the IdSubst itself, whose range is assumed to be correct wrt the in-scope set.) -Why do we make a different choice for the IdSubstEnv than the TvSubstEnv? +Why do we make a different choice for the IdSubstEnv than the +TvSubstEnv and CvSubstEnv? * For Ids, we change the IdInfo all the time (e.g. deleting the unfolding), and adding it back later, so using the TyVar convention @@ -158,91 +173,108 @@ ---------------------------- isEmptySubst :: Subst -> Bool -isEmptySubst (Subst _ id_env tv_env) = isEmptyVarEnv id_env && isEmptyVarEnv tv_env +isEmptySubst (Subst _ id_env tv_env cv_env) + = isEmptyVarEnv id_env && isEmptyVarEnv tv_env && isEmptyVarEnv cv_env emptySubst :: Subst -emptySubst = Subst emptyInScopeSet emptyVarEnv emptyVarEnv +emptySubst = Subst emptyInScopeSet emptyVarEnv emptyVarEnv emptyVarEnv mkEmptySubst :: InScopeSet -> Subst -mkEmptySubst in_scope = Subst in_scope emptyVarEnv emptyVarEnv - -mkSubst :: InScopeSet -> TvSubstEnv -> IdSubstEnv -> Subst -mkSubst in_scope tvs ids = Subst in_scope ids tvs +mkEmptySubst in_scope = Subst in_scope emptyVarEnv emptyVarEnv emptyVarEnv --- getTvSubst :: Subst -> TvSubst --- getTvSubst (Subst in_scope _ tv_env) = TvSubst in_scope tv_env - --- getTvSubstEnv :: Subst -> TvSubstEnv --- getTvSubstEnv (Subst _ _ tv_env) = tv_env --- --- setTvSubstEnv :: Subst -> TvSubstEnv -> Subst --- setTvSubstEnv (Subst in_scope ids _) tvs = Subst in_scope ids tvs +mkSubst :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> IdSubstEnv -> Subst +mkSubst in_scope tvs cvs ids = Subst in_scope ids tvs cvs -- | Find the in-scope set: see "CoreSubst#in_scope_invariant" substInScope :: Subst -> InScopeSet -substInScope (Subst in_scope _ _) = in_scope +substInScope (Subst in_scope _ _ _) = in_scope -- | Remove all substitutions for 'Id's and 'Var's that might have been built up -- while preserving the in-scope set zapSubstEnv :: Subst -> Subst -zapSubstEnv (Subst in_scope _ _) = Subst in_scope emptyVarEnv emptyVarEnv +zapSubstEnv (Subst in_scope _ _ _) = Subst in_scope emptyVarEnv emptyVarEnv emptyVarEnv -- | Add a substitution for an 'Id' to the 'Subst': you must ensure that the in-scope set is -- such that the "CoreSubst#in_scope_invariant" is true after extending the substitution like this extendIdSubst :: Subst -> Id -> CoreExpr -> Subst -- ToDo: add an ASSERT that fvs(subst-result) is already in the in-scope set -extendIdSubst (Subst in_scope ids tvs) v r = Subst in_scope (extendVarEnv ids v r) tvs +extendIdSubst (Subst in_scope ids tvs cvs) v r = Subst in_scope (extendVarEnv ids v r) tvs cvs -- | Adds multiple 'Id' substitutions to the 'Subst': see also 'extendIdSubst' extendIdSubstList :: Subst -> [(Id, CoreExpr)] -> Subst -extendIdSubstList (Subst in_scope ids tvs) prs = Subst in_scope (extendVarEnvList ids prs) tvs +extendIdSubstList (Subst in_scope ids tvs cvs) prs = Subst in_scope (extendVarEnvList ids prs) tvs cvs -- | Add a substitution for a 'TyVar' to the 'Subst': you must ensure that the in-scope set is -- such that the "CoreSubst#in_scope_invariant" is true after extending the substitution like this extendTvSubst :: Subst -> TyVar -> Type -> Subst -extendTvSubst (Subst in_scope ids tvs) v r = Subst in_scope ids (extendVarEnv tvs v r) +extendTvSubst (Subst in_scope ids tvs cvs) v r = Subst in_scope ids (extendVarEnv tvs v r) cvs -- | Adds multiple 'TyVar' substitutions to the 'Subst': see also 'extendTvSubst' extendTvSubstList :: Subst -> [(TyVar,Type)] -> Subst -extendTvSubstList (Subst in_scope ids tvs) prs = Subst in_scope ids (extendVarEnvList tvs prs) +extendTvSubstList (Subst in_scope ids tvs cvs) prs = Subst in_scope ids (extendVarEnvList tvs prs) cvs --- | Add a substitution for a 'TyVar' or 'Id' as appropriate to the 'Var' being added. See also --- 'extendIdSubst' and 'extendTvSubst' -extendSubst :: Subst -> Var -> CoreArg -> Subst -extendSubst (Subst in_scope ids tvs) tv (Type ty) - = ASSERT( isTyCoVar tv ) Subst in_scope ids (extendVarEnv tvs tv ty) -extendSubst (Subst in_scope ids tvs) id expr - = ASSERT( isId id ) Subst in_scope (extendVarEnv ids id expr) tvs +-- | Add a substitution from a 'TyCoVar' to a 'Coercion' to the 'Subst': you must ensure that the in-scope set is +-- such that the "CoreSubst#in_scope_invariant" is true after extending the substitution like this +extendCvSubst :: Subst -> TyCoVar -> Coercion -> Subst +extendCvSubst (Subst in_scope ids tvs cvs) v r = Subst in_scope ids tvs (extendVarEnv cvs v r) --- | Add a substitution for a 'TyVar' or 'Id' as appropriate to all the 'Var's being added. See also 'extendSubst' +-- | Adds multiple 'TyCoVar' -> 'Coercion' substitutions to the +-- 'Subst': see also 'extendCvSubst' +extendCvSubstList :: Subst -> [(TyCoVar,Coercion)] -> Subst +extendCvSubstList (Subst in_scope ids tvs cvs) prs = Subst in_scope ids tvs (extendVarEnvList cvs prs) + +-- | Add a substitution appropriate to the thing being substituted +-- (whether an expression, type, or coercion). See also +-- 'extendIdSubst', 'extendTvSubst', and 'extendCvSubst'. +extendSubst :: Subst -> Var -> CoreArg -> Subst +extendSubst subst var arg + = case arg of + Type ty -> ASSERT( isTyVar var ) extendTvSubst subst var ty + Coercion co -> ASSERT( isCoVar var ) extendCvSubst subst var co + _ -> ASSERT( isId var ) extendIdSubst subst var arg + +extendSubstWithVar :: Subst -> Var -> Var -> Subst +extendSubstWithVar subst v1 v2 + | isTyVar v1 = ASSERT( isTyVar v2 ) extendTvSubst subst v1 (mkTyVarTy v2) + | isCoVar v1 = ASSERT( isCoVar v2 ) extendCvSubst subst v1 (mkCoVarCo v2) + | otherwise = ASSERT( isId v2 ) extendIdSubst subst v1 (Var v2) + +-- | Add a substitution as appropriate to each of the terms being +-- substituted (whether expressions, types, or coercions). See also +-- 'extendSubst'. extendSubstList :: Subst -> [(Var,CoreArg)] -> Subst extendSubstList subst [] = subst extendSubstList subst ((var,rhs):prs) = extendSubstList (extendSubst subst var rhs) prs -- | Find the substitution for an 'Id' in the 'Subst' lookupIdSubst :: SDoc -> Subst -> Id -> CoreExpr -lookupIdSubst doc (Subst in_scope ids _) v +lookupIdSubst doc (Subst in_scope ids _ _) v | not (isLocalId v) = Var v | Just e <- lookupVarEnv ids v = e | Just v' <- lookupInScope in_scope v = Var v' -- Vital! See Note [Extending the Subst] - | otherwise = WARN( True, ptext (sLit "CoreSubst.lookupIdSubst") <+> ppr v $$ ppr in_scope $$ doc) + | otherwise = WARN( True, ptext (sLit "CoreSubst.lookupIdSubst") <+> doc <+> ppr v + $$ ppr in_scope) Var v -- | Find the substitution for a 'TyVar' in the 'Subst' lookupTvSubst :: Subst -> TyVar -> Type -lookupTvSubst (Subst _ _ tvs) v = lookupVarEnv tvs v `orElse` Type.mkTyVarTy v +lookupTvSubst (Subst _ _ tvs _) v = ASSERT( isTyVar v) lookupVarEnv tvs v `orElse` Type.mkTyVarTy v + +-- | Find the coercion substitution for a 'TyCoVar' in the 'Subst' +lookupCvSubst :: Subst -> CoVar -> Coercion +lookupCvSubst (Subst _ _ _ cvs) v = ASSERT( isCoVar v ) lookupVarEnv cvs v `orElse` mkCoVarCo v delBndr :: Subst -> Var -> Subst -delBndr (Subst in_scope tvs ids) v - | isId v = Subst in_scope tvs (delVarEnv ids v) - | otherwise = Subst in_scope (delVarEnv tvs v) ids +delBndr (Subst in_scope ids tvs cvs) v + | isCoVar v = Subst in_scope ids tvs (delVarEnv cvs v) + | isTyVar v = Subst in_scope ids (delVarEnv tvs v) cvs + | otherwise = Subst in_scope (delVarEnv ids v) tvs cvs delBndrs :: Subst -> [Var] -> Subst -delBndrs (Subst in_scope tvs ids) vs - = Subst in_scope (delVarEnvList tvs vs_tv) (delVarEnvList ids vs_id) - where - (vs_id, vs_tv) = partition isId vs +delBndrs (Subst in_scope ids tvs cvs) vs + = Subst in_scope (delVarEnvList ids vs) (delVarEnvList tvs vs) (delVarEnvList cvs vs) + -- Easist thing is just delete all from all! -- | Simultaneously substitute for a bunch of variables -- No left-right shadowing @@ -252,49 +284,51 @@ mkOpenSubst in_scope pairs = Subst in_scope (mkVarEnv [(id,e) | (id, e) <- pairs, isId id]) (mkVarEnv [(tv,ty) | (tv, Type ty) <- pairs]) + (mkVarEnv [(v,co) | (v, Coercion co) <- pairs]) ------------------------------ isInScope :: Var -> Subst -> Bool -isInScope v (Subst in_scope _ _) = v `elemInScopeSet` in_scope +isInScope v (Subst in_scope _ _ _) = v `elemInScopeSet` in_scope -- | Add the 'Var' to the in-scope set, but do not remove -- any existing substitutions for it addInScopeSet :: Subst -> VarSet -> Subst -addInScopeSet (Subst in_scope ids tvs) vs - = Subst (in_scope `extendInScopeSetSet` vs) ids tvs +addInScopeSet (Subst in_scope ids tvs cvs) vs + = Subst (in_scope `extendInScopeSetSet` vs) ids tvs cvs -- | Add the 'Var' to the in-scope set: as a side effect, -- and remove any existing substitutions for it extendInScope :: Subst -> Var -> Subst -extendInScope (Subst in_scope ids tvs) v +extendInScope (Subst in_scope ids tvs cvs) v = Subst (in_scope `extendInScopeSet` v) - (ids `delVarEnv` v) (tvs `delVarEnv` v) + (ids `delVarEnv` v) (tvs `delVarEnv` v) (cvs `delVarEnv` v) -- | Add the 'Var's to the in-scope set: see also 'extendInScope' extendInScopeList :: Subst -> [Var] -> Subst -extendInScopeList (Subst in_scope ids tvs) vs +extendInScopeList (Subst in_scope ids tvs cvs) vs = Subst (in_scope `extendInScopeSetList` vs) - (ids `delVarEnvList` vs) (tvs `delVarEnvList` vs) + (ids `delVarEnvList` vs) (tvs `delVarEnvList` vs) (cvs `delVarEnvList` vs) -- | Optimized version of 'extendInScopeList' that can be used if you are certain --- all the things being added are 'Id's and hence none are 'TyVar's +-- all the things being added are 'Id's and hence none are 'TyVar's or 'CoVar's extendInScopeIds :: Subst -> [Id] -> Subst -extendInScopeIds (Subst in_scope ids tvs) vs +extendInScopeIds (Subst in_scope ids tvs cvs) vs = Subst (in_scope `extendInScopeSetList` vs) - (ids `delVarEnvList` vs) tvs + (ids `delVarEnvList` vs) tvs cvs setInScope :: Subst -> InScopeSet -> Subst -setInScope (Subst _ ids tvs) in_scope = Subst in_scope ids tvs +setInScope (Subst _ ids tvs cvs) in_scope = Subst in_scope ids tvs cvs \end{code} Pretty printing, for debugging only \begin{code} instance Outputable Subst where - ppr (Subst in_scope ids tvs) + ppr (Subst in_scope ids tvs cvs) = ptext (sLit " braces (fsep (map ppr (varEnvElts (getInScopeVars in_scope)))) $$ ptext (sLit " IdSubst =") <+> ppr ids $$ ptext (sLit " TvSubst =") <+> ppr tvs + $$ ptext (sLit " CvSubst =") <+> ppr cvs <> char '>' \end{code} @@ -326,10 +360,11 @@ where go (Var v) = lookupIdSubst (text "subst_expr") subst v go (Type ty) = Type (substTy subst ty) + go (Coercion co) = Coercion (substCo subst co) go (Lit lit) = Lit lit go (App fun arg) = App (go fun) (go arg) go (Note note e) = Note (go_note note) (go e) - go (Cast e co) = Cast (go e) (optCoercion (getTvSubst subst) co) + go (Cast e co) = Cast (go e) (substCo subst co) -- Do not optimise even identity coercions -- Reason: substitution applies to the LHS of RULES, and -- if you "optimise" an identity coercion, you may @@ -416,8 +451,9 @@ -- 'IdInfo' is preserved by this process, although it is substituted into appropriately. substBndr :: Subst -> Var -> (Subst, Var) substBndr subst bndr - | isTyCoVar bndr = substTyVarBndr subst bndr - | otherwise = substIdBndr (text "var-bndr") subst subst bndr + | isTyVar bndr = substTyVarBndr subst bndr + | isCoVar bndr = substCoVarBndr subst bndr + | otherwise = substIdBndr (text "var-bndr") subst subst bndr -- | Applies 'substBndr' to a number of 'Var's, accumulating a new 'Subst' left-to-right substBndrs :: Subst -> [Var] -> (Subst, [Var]) @@ -439,9 +475,9 @@ -> (Subst, Id) -- ^ Transformed pair -- NB: unfolding may be zapped -substIdBndr _doc rec_subst subst@(Subst in_scope env tvs) old_id +substIdBndr _doc rec_subst subst@(Subst in_scope env tvs cvs) old_id = -- pprTrace "substIdBndr" (doc $$ ppr old_id $$ ppr in_scope) $ - (Subst (in_scope `extendInScopeSet` new_id) new_env tvs, new_id) + (Subst (in_scope `extendInScopeSet` new_id) new_env tvs cvs, new_id) where id1 = uniqAway in_scope old_id -- id1 is cloned if necessary id2 | no_type_change = id1 @@ -484,6 +520,16 @@ cloneIdBndrs subst us ids = mapAccumL (clone_id subst) subst (ids `zip` uniqsFromSupply us) +cloneBndrs :: Subst -> UniqSupply -> [Var] -> (Subst, [Var]) +-- Works for all kinds of variables (typically case binders) +-- not just Ids +cloneBndrs subst us vs + = mapAccumL clone subst (vs `zip` uniqsFromSupply us) + where + clone subst (v,uniq) + | isTyVar v = cloneTyVarBndr subst v uniq + | otherwise = clone_id subst subst (v,uniq) -- Works for coercion variables too + -- | Clone a mutually recursive group of 'Id's cloneRecIdBndrs :: Subst -> UniqSupply -> [Id] -> (Subst, [Id]) cloneRecIdBndrs subst us ids @@ -498,8 +544,8 @@ -> Subst -> (Id, Unique) -- Substitition and Id to transform -> (Subst, Id) -- Transformed pair -clone_id rec_subst subst@(Subst in_scope env tvs) (old_id, uniq) - = (Subst (in_scope `extendInScopeSet` new_id) new_env tvs, new_id) +clone_id rec_subst subst@(Subst in_scope env tvs cvs) (old_id, uniq) + = (Subst (in_scope `extendInScopeSet` new_id) new_env tvs cvs, new_id) where id1 = setVarUnique old_id uniq id2 = substIdType subst id1 @@ -510,26 +556,46 @@ %************************************************************************ %* * - Types + Types and Coercions %* * %************************************************************************ -For types we just call the corresponding function in Type, but we have -to repackage the substitution, from a Subst to a TvSubst +For types and coercions we just call the corresponding functions in +Type and Coercion, but we have to repackage the substitution, from a +Subst to a TvSubst. \begin{code} substTyVarBndr :: Subst -> TyVar -> (Subst, TyVar) -substTyVarBndr (Subst in_scope id_env tv_env) tv +substTyVarBndr (Subst in_scope id_env tv_env cv_env) tv = case Type.substTyVarBndr (TvSubst in_scope tv_env) tv of (TvSubst in_scope' tv_env', tv') - -> (Subst in_scope' id_env tv_env', tv') + -> (Subst in_scope' id_env tv_env' cv_env, tv') + +cloneTyVarBndr :: Subst -> TyVar -> Unique -> (Subst, TyVar) +cloneTyVarBndr (Subst in_scope id_env tv_env cv_env) tv uniq + = case Type.cloneTyVarBndr (TvSubst in_scope tv_env) tv uniq of + (TvSubst in_scope' tv_env', tv') + -> (Subst in_scope' id_env tv_env' cv_env, tv') + +substCoVarBndr :: Subst -> TyVar -> (Subst, TyVar) +substCoVarBndr (Subst in_scope id_env tv_env cv_env) cv + = case Coercion.substCoVarBndr (CvSubst in_scope tv_env cv_env) cv of + (CvSubst in_scope' tv_env' cv_env', cv') + -> (Subst in_scope' id_env tv_env' cv_env', cv') -- | See 'Type.substTy' substTy :: Subst -> Type -> Type substTy subst ty = Type.substTy (getTvSubst subst) ty getTvSubst :: Subst -> TvSubst -getTvSubst (Subst in_scope _id_env tv_env) = TvSubst in_scope tv_env +getTvSubst (Subst in_scope _ tenv _) = TvSubst in_scope tenv + +getCvSubst :: Subst -> CvSubst +getCvSubst (Subst in_scope _ tenv cenv) = CvSubst in_scope tenv cenv + +-- | See 'Coercion.substCo' +substCo :: Subst -> Coercion -> Coercion +substCo subst co = Coercion.substCo (getCvSubst subst) co \end{code} @@ -541,8 +607,8 @@ \begin{code} substIdType :: Subst -> Id -> Id -substIdType subst@(Subst _ _ tv_env) id - | isEmptyVarEnv tv_env || isEmptyVarSet (Type.tyVarsOfType old_ty) = id +substIdType subst@(Subst _ _ tv_env cv_env) id + | (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env) || isEmptyVarSet (Type.tyVarsOfType old_ty) = id | otherwise = setIdType id (substTy subst old_ty) -- The tyVarsOfType is cheaper than it looks -- because we cache the free tyvars of the type @@ -555,7 +621,7 @@ substIdInfo :: Subst -> Id -> IdInfo -> Maybe IdInfo substIdInfo subst new_id info | nothing_to_do = Nothing - | otherwise = Just (info `setSpecInfo` substSpec subst new_id old_rules + | otherwise = Just (info `setSpecInfo` substSpec subst new_id old_rules `setUnfoldingInfo` substUnfolding subst old_unf) where old_rules = specInfo info @@ -576,7 +642,7 @@ substUnfolding subst (DFunUnfolding ar con args) = DFunUnfolding ar con (map subst_arg args) where - subst_arg = fmap (substExpr (text "dfun-unf") subst) + subst_arg = substExpr (text "dfun-unf") subst substUnfolding subst unf@(CoreUnfolding { uf_tmpl = tmpl, uf_src = src }) -- Retain an InlineRule! @@ -594,7 +660,7 @@ ------------------- substUnfoldingSource :: Subst -> UnfoldingSource -> UnfoldingSource -substUnfoldingSource (Subst in_scope ids _) (InlineWrapper wkr) +substUnfoldingSource (Subst in_scope ids _ _) (InlineWrapper wkr) | Just wkr_expr <- lookupVarEnv ids wkr = case wkr_expr of Var w1 -> InlineWrapper w1 @@ -628,7 +694,7 @@ where subst_ru_fn = const (idName new_id) new_spec = SpecInfo (map (substRule subst subst_ru_fn) rules) - (substVarSet subst rhs_fvs) + (substVarSet subst rhs_fvs) ------------------ substRulesForImportedIds :: Subst -> [CoreRule] -> [CoreRule] @@ -645,17 +711,16 @@ -- - Rules for *imported* Ids never change ru_fn -- - Rules for *local* Ids are in the IdInfo for that Id, -- and the ru_fn field is simply replaced by the new name --- of the Id - +-- of the Id substRule _ _ rule@(BuiltinRule {}) = rule substRule subst subst_ru_fn rule@(Rule { ru_bndrs = bndrs, ru_args = args , ru_fn = fn_name, ru_rhs = rhs , ru_local = is_local }) = rule { ru_bndrs = bndrs', - ru_fn = if is_local - then subst_ru_fn fn_name - else fn_name, - ru_args = map (substExpr (text "subst-rule" <+> ppr fn_name) subst') args, + ru_fn = if is_local + then subst_ru_fn fn_name + else fn_name, + ru_args = map (substExpr (text "subst-rule" <+> ppr fn_name) subst') args, ru_rhs = simpleOptExprWith subst' rhs } -- Do simple optimisation on RHS, in case substitution lets -- you improve it. The real simplifier never gets to look at it. @@ -663,13 +728,23 @@ (subst', bndrs') = substBndrs subst bndrs ------------------ +substVects :: Subst -> [CoreVect] -> [CoreVect] +substVects subst = map (substVect subst) + +------------------ +substVect :: Subst -> CoreVect -> CoreVect +substVect _subst (Vect v Nothing) = Vect v Nothing +substVect subst (Vect v (Just rhs)) = Vect v (Just (simpleOptExprWith subst rhs)) +substVect _subst (NoVect v) = NoVect v + +------------------ substVarSet :: Subst -> VarSet -> VarSet -substVarSet subst fvs +substVarSet subst fvs = foldVarSet (unionVarSet . subst_fv subst) emptyVarSet fvs where subst_fv subst fv - | isId fv = exprFreeVars (lookupIdSubst (text "substVarSet") subst fv) - | otherwise = Type.tyVarsOfType (lookupTvSubst subst fv) + | isId fv = exprFreeVars (lookupIdSubst (text "substVarSet") subst fv) + | otherwise = Type.tyVarsOfType (lookupTvSubst subst fv) \end{code} Note [Worker inlining] @@ -713,22 +788,24 @@ -- won't *be* substituting for x if it occurs inside a -- lambda. -- - -- It's a bit painful to call exprFreeVars, because it makes + -- It's a bit painful to call exprFreeVars, because it makes -- three passes instead of two (occ-anal, and go) simpleOptExprWith :: Subst -> InExpr -> OutExpr simpleOptExprWith subst expr = simple_opt_expr subst (occurAnalyseExpr expr) ---------------------- -simpleOptPgm :: DynFlags -> [CoreBind] -> [CoreRule] -> IO ([CoreBind], [CoreRule]) -simpleOptPgm dflags binds rules +simpleOptPgm :: DynFlags -> Module + -> [CoreBind] -> [CoreRule] -> [CoreVect] + -> IO ([CoreBind], [CoreRule], [CoreVect]) +simpleOptPgm dflags this_mod binds rules vects = do { dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis" - (pprCoreBindings occ_anald_binds); + (pprCoreBindings occ_anald_binds); - ; return (reverse binds', substRulesForImportedIds subst' rules) } + ; return (reverse binds', substRulesForImportedIds subst' rules, substVects subst' vects) } where - occ_anald_binds = occurAnalysePgm Nothing {- No rules active -} - rules binds + occ_anald_binds = occurAnalysePgm this_mod (\_ -> False) {- No rules active -} + rules vects binds (subst', binds') = foldl do_one (emptySubst, []) occ_anald_binds do_one (subst, binds') bind @@ -747,19 +824,22 @@ -- In these functions the substitution maps InVar -> OutExpr ---------------------- -simple_opt_expr :: Subst -> InExpr -> OutExpr -simple_opt_expr subst expr +simple_opt_expr, simple_opt_expr' :: Subst -> InExpr -> OutExpr +simple_opt_expr s e = simple_opt_expr' s e + +simple_opt_expr' subst expr = go expr where go (Var v) = lookupIdSubst (text "simpleOptExpr") subst v go (App e1 e2) = simple_app subst e1 [go e2] - go (Type ty) = Type (substTy subst ty) + go (Type ty) = Type (substTy subst ty) + go (Coercion co) = Coercion (optCoercion (getCvSubst subst) co) go (Lit lit) = Lit lit go (Note note e) = Note note (go e) - go (Cast e co) | isIdentityCoercion co' = go e - | otherwise = Cast (go e) co' + go (Cast e co) | isReflCo co' = go e + | otherwise = Cast (go e) co' where - co' = substTy subst co + co' = optCoercion (getCvSubst subst) co go (Let bind body) = case simple_opt_bind subst bind of (subst', Nothing) -> simple_opt_expr subst' body @@ -806,21 +886,25 @@ = foldl App (simple_opt_expr subst e) as ---------------------- -simple_opt_bind :: Subst -> CoreBind -> (Subst, Maybe CoreBind) -simple_opt_bind subst (Rec prs) - = (subst'', Just (Rec (reverse rev_prs'))) +simple_opt_bind,simple_opt_bind' :: Subst -> CoreBind -> (Subst, Maybe CoreBind) +simple_opt_bind s b -- Can add trace stuff here + = simple_opt_bind' s b + +simple_opt_bind' subst (Rec prs) + = (subst'', res_bind) where + res_bind = Just (Rec (reverse rev_prs')) (subst', bndrs') = subst_opt_bndrs subst (map fst prs) (subst'', rev_prs') = foldl do_pr (subst', []) (prs `zip` bndrs') do_pr (subst, prs) ((b,r), b') = case maybe_substitute subst b r2 of Just subst' -> (subst', prs) - Nothing -> (subst, (b2,r2):prs) + Nothing -> (subst, (b2,r2):prs) where b2 = add_info subst b b' r2 = simple_opt_expr subst r -simple_opt_bind subst (NonRec b r) +simple_opt_bind' subst (NonRec b r) = case maybe_substitute subst b r' of Just ext_subst -> (ext_subst, Nothing) Nothing -> (subst', Just (NonRec b2 r')) @@ -836,10 +920,14 @@ -- or returns Nothing maybe_substitute subst b r | Type ty <- r -- let a::* = TYPE ty in - = ASSERT( isTyCoVar b ) + = ASSERT( isTyVar b ) Just (extendTvSubst subst b ty) - | isId b -- let x = e in + | Coercion co <- r + = ASSERT( isCoVar b ) + Just (extendCvSubst subst b co) + + | isId b -- let x = e in , safe_to_inline (idOccInfo b) , isAlwaysActive (idInlineActivation b) -- Note [Inline prag in simplOpt] , not (isStableUnfolding (idUnfolding b)) @@ -859,19 +947,20 @@ ---------------------- subst_opt_bndr :: Subst -> InVar -> (Subst, OutVar) subst_opt_bndr subst bndr - | isTyCoVar bndr = substTyVarBndr subst bndr - | otherwise = subst_opt_id_bndr subst bndr + | isTyVar bndr = substTyVarBndr subst bndr + | isCoVar bndr = substCoVarBndr subst bndr + | otherwise = subst_opt_id_bndr subst bndr subst_opt_id_bndr :: Subst -> InId -> (Subst, OutId) -- Nuke all fragile IdInfo, unfolding, and RULES; -- it gets added back later by add_info -- Rather like SimplEnv.substIdBndr -- --- It's important to zap fragile OccInfo (which CoreSubst.SubstIdBndr +-- It's important to zap fragile OccInfo (which CoreSubst.substIdBndr -- carefully does not do) because simplOptExpr invalidates it -subst_opt_id_bndr subst@(Subst in_scope id_subst tv_subst) old_id - = (Subst new_in_scope new_id_subst tv_subst, new_id) +subst_opt_id_bndr subst@(Subst in_scope id_subst tv_subst cv_subst) old_id + = (Subst new_in_scope new_id_subst tv_subst cv_subst, new_id) where id1 = uniqAway in_scope old_id id2 = setIdType id1 (substTy subst (idType old_id)) @@ -894,9 +983,9 @@ ---------------------- add_info :: Subst -> InVar -> OutVar -> OutVar -add_info subst old_bndr new_bndr - | isTyCoVar old_bndr = new_bndr - | otherwise = maybeModifyIdInfo mb_new_info new_bndr +add_info subst old_bndr new_bndr + | isTyVar old_bndr = new_bndr + | otherwise = maybeModifyIdInfo mb_new_info new_bndr where mb_new_info = substIdInfo subst new_bndr (idInfo old_bndr) \end{code} @@ -920,3 +1009,4 @@ When inlining 'foo' in 'bar' we want the let-binding for 'inner' to remain visible until Phase 1 + diff -Nru ghc-7.0.3/compiler/coreSyn/CoreSyn.lhs ghc-7.2.1/compiler/coreSyn/CoreSyn.lhs --- ghc-7.0.3/compiler/coreSyn/CoreSyn.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/coreSyn/CoreSyn.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -4,7 +4,7 @@ % \begin{code} -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveDataTypeable, DeriveFunctor #-} -- | CoreSyn holds all the main data types for use by for the Glasgow Haskell Compiler midsection module CoreSyn ( @@ -15,7 +15,7 @@ -- ** 'Expr' construction mkLets, mkLams, - mkApps, mkTyApps, mkVarApps, + mkApps, mkTyApps, mkCoApps, mkVarApps, mkIntLit, mkIntLitInt, mkWordLit, mkWordLitWord, @@ -23,22 +23,22 @@ mkFloatLit, mkFloatLitFloat, mkDoubleLit, mkDoubleLitDouble, - mkConApp, mkTyBind, + mkConApp, mkTyBind, mkCoBind, varToCoreExpr, varsToCoreExprs, - isTyCoVar, isId, cmpAltCon, cmpAlt, ltAlt, + isId, cmpAltCon, cmpAlt, ltAlt, -- ** Simple 'Expr' access functions and predicates bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders, collectArgs, coreExprCc, flattenBinds, - isValArg, isTypeArg, valArgCount, valBndrCount, isRuntimeArg, isRuntimeVar, - notSccNote, + isValArg, isTypeArg, isTyCoArg, valArgCount, valBndrCount, + isRuntimeArg, isRuntimeVar, + notSccNote, -- * Unfolding data types Unfolding(..), UnfoldingGuidance(..), UnfoldingSource(..), - DFunArg(..), dfunArgExprs, -- ** Constructing 'Unfolding's noUnfolding, evaldUnfolding, mkOtherCon, @@ -72,7 +72,10 @@ -- ** Operations on 'CoreRule's seqRules, ruleArity, ruleName, ruleIdName, ruleActivation, setRuleIdName, - isBuiltinRule, isLocalRule + isBuiltinRule, isLocalRule, + + -- * Core vectorisation declarations data type + CoreVect(..) ) where #include "HsVersions.h" @@ -92,7 +95,7 @@ import Data.Data import Data.Word -infixl 4 `mkApps`, `mkTyApps`, `mkVarApps`, `App` +infixl 4 `mkApps`, `mkTyApps`, `mkVarApps`, `App`, `mkCoApps` -- Left associative, so that we can say (f `mkTyApps` xs `mkVarApps` ys) \end{code} @@ -236,6 +239,8 @@ | Type Type -- ^ A type: this should only show up at the top -- level of an Arg + + | Coercion Coercion -- ^ A coercion deriving (Data, Typeable) -- | Type synonym for expressions that occur in function argument positions. @@ -402,9 +407,25 @@ %************************************************************************ -%* * - Unfoldings -%* * +%* * +\subsection{Vectorisation declarations} +%* * +%************************************************************************ + +Representation of desugared vectorisation declarations that are fed to the vectoriser (via +'ModGuts'). + +\begin{code} +data CoreVect = Vect Id (Maybe CoreExpr) + | NoVect Id + +\end{code} + + +%************************************************************************ +%* * + Unfoldings +%* * %************************************************************************ The @Unfolding@ type is declared here to avoid numerous loops @@ -437,7 +458,7 @@ DataCon -- The dictionary data constructor (possibly a newtype datacon) - [DFunArg CoreExpr] -- Specification of superclasses and methods, in positional order + [CoreExpr] -- Specification of superclasses and methods, in positional order | CoreUnfolding { -- An unfolding for an Id with no pragma, -- or perhaps a NOINLINE pragma @@ -475,34 +496,13 @@ -- uf_guidance: Tells us about the /size/ of the unfolding template ------------------------------------------------ -data DFunArg e -- Given (df a b d1 d2 d3) - = DFunPolyArg e -- Arg is (e a b d1 d2 d3) - | DFunConstArg e -- Arg is e, which is constant - | DFunLamArg Int -- Arg is one of [a,b,d1,d2,d3], zero indexed - -instance Functor DFunArg where - fmap f (DFunPolyArg x) = DFunPolyArg (f x) - fmap f (DFunConstArg x) = DFunConstArg (f x) - fmap _ (DFunLamArg i) = (DFunLamArg i) - - -- 'e' is often CoreExpr, which are usually variables, but can - -- be trivial expressions instead (e.g. a type application). - -dfunArgExprs :: [DFunArg e] -> [e] -dfunArgExprs [] = [] -dfunArgExprs (DFunPolyArg e : as) = e : dfunArgExprs as -dfunArgExprs (DFunConstArg e : as) = e : dfunArgExprs as -dfunArgExprs (DFunLamArg {} : as) = dfunArgExprs as - - ------------------------------------------------- data UnfoldingSource = InlineRhs -- The current rhs of the function -- Replace uf_tmpl each time around | InlineStable -- From an INLINE or INLINABLE pragma -- INLINE if guidance is UnfWhen - -- INLINABLE if guidance is UnfIfGoodArgs + -- INLINABLE if guidance is UnfIfGoodArgs/UnfoldNever -- (well, technically an INLINABLE might be made -- UnfWhen if it was small enough, and then -- it will behave like INLINE outside the current @@ -865,6 +865,8 @@ mkApps :: Expr b -> [Arg b] -> Expr b -- | Apply a list of type argument expressions to a function expression in a nested fashion mkTyApps :: Expr b -> [Type] -> Expr b +-- | Apply a list of coercion argument expressions to a function expression in a nested fashion +mkCoApps :: Expr b -> [Coercion] -> Expr b -- | Apply a list of type or value variables to a function expression in a nested fashion mkVarApps :: Expr b -> [Var] -> Expr b -- | Apply a list of argument expressions to a data constructor in a nested fashion. Prefer to @@ -873,6 +875,7 @@ mkApps f args = foldl App f args mkTyApps f args = foldl (\ e a -> App e (Type a)) f args +mkCoApps f args = foldl (\ e a -> App e (Coercion a)) f args mkVarApps f vars = foldl (\ e a -> App e (varToCoreExpr a)) f vars mkConApp con args = mkApps (Var (dataConWorkId con)) args @@ -943,10 +946,16 @@ mkTyBind :: TyVar -> Type -> CoreBind mkTyBind tv ty = NonRec tv (Type ty) +-- | Create a binding group where a type variable is bound to a type. Per "CoreSyn#type_let", +-- this can only be used to bind something in a non-recursive @let@ expression +mkCoBind :: CoVar -> Coercion -> CoreBind +mkCoBind cv co = NonRec cv (Coercion co) + -- | Convert a binder into either a 'Var' or 'Type' 'Expr' appropriately varToCoreExpr :: CoreBndr -> Expr b -varToCoreExpr v | isId v = Var v - | otherwise = Type (mkTyVarTy v) +varToCoreExpr v | isTyVar v = Type (mkTyVarTy v) + | isCoVar v = Coercion (mkCoVarCo v) + | otherwise = ASSERT( isId v ) Var v varsToCoreExprs :: [CoreBndr] -> [Expr b] varsToCoreExprs vs = map varToCoreExpr vs @@ -1012,7 +1021,7 @@ collectTyBinders expr = go [] expr where - go tvs (Lam b e) | isTyCoVar b = go (b:tvs) e + go tvs (Lam b e) | isTyVar b = go (b:tvs) e go tvs e = (reverse tvs, e) collectValBinders expr @@ -1063,15 +1072,23 @@ isRuntimeArg :: CoreExpr -> Bool isRuntimeArg = isValArg --- | Returns @False@ iff the expression is a 'Type' expression at its top level +-- | Returns @False@ iff the expression is a 'Type' or 'Coercion' +-- expression at its top level isValArg :: Expr b -> Bool -isValArg (Type _) = False -isValArg _ = True +isValArg e = not (isTypeArg e) + +-- | Returns @True@ iff the expression is a 'Type' or 'Coercion' +-- expression at its top level +isTyCoArg :: Expr b -> Bool +isTyCoArg (Type {}) = True +isTyCoArg (Coercion {}) = True +isTyCoArg _ = False --- | Returns @True@ iff the expression is a 'Type' expression at its top level +-- | Returns @True@ iff the expression is a 'Type' expression at its +-- top level. Note this does NOT include 'Coercion's. isTypeArg :: Expr b -> Bool -isTypeArg (Type _) = True -isTypeArg _ = False +isTypeArg (Type {}) = True +isTypeArg _ = False -- | The number of binders that bind values rather than types valBndrCount :: [CoreBndr] -> Int @@ -1101,9 +1118,10 @@ seqExpr (Lam b e) = seqBndr b `seq` seqExpr e seqExpr (Let b e) = seqBind b `seq` seqExpr e seqExpr (Case e b t as) = seqExpr e `seq` seqBndr b `seq` seqType t `seq` seqAlts as -seqExpr (Cast e co) = seqExpr e `seq` seqType co +seqExpr (Cast e co) = seqExpr e `seq` seqCo co seqExpr (Note n e) = seqNote n `seq` seqExpr e -seqExpr (Type t) = seqType t +seqExpr (Type t) = seqType t +seqExpr (Coercion co) = seqCo co seqExprs :: [CoreExpr] -> () seqExprs [] = () @@ -1157,9 +1175,11 @@ | AnnApp (AnnExpr bndr annot) (AnnExpr bndr annot) | AnnCase (AnnExpr bndr annot) bndr Type [AnnAlt bndr annot] | AnnLet (AnnBind bndr annot) (AnnExpr bndr annot) - | AnnCast (AnnExpr bndr annot) Coercion + | AnnCast (AnnExpr bndr annot) (annot, Coercion) + -- Put an annotation on the (root of) the coercion | AnnNote Note (AnnExpr bndr annot) | AnnType Type + | AnnCoercion Coercion -- | A clone of the 'Alt' type but allowing annotation at every tree node type AnnAlt bndr annot = (AltCon, [bndr], AnnExpr bndr annot) @@ -1186,12 +1206,13 @@ deAnnotate (_, e) = deAnnotate' e deAnnotate' :: AnnExpr' bndr annot -> Expr bndr -deAnnotate' (AnnType t) = Type t +deAnnotate' (AnnType t) = Type t +deAnnotate' (AnnCoercion co) = Coercion co deAnnotate' (AnnVar v) = Var v deAnnotate' (AnnLit lit) = Lit lit deAnnotate' (AnnLam binder body) = Lam binder (deAnnotate body) deAnnotate' (AnnApp fun arg) = App (deAnnotate fun) (deAnnotate arg) -deAnnotate' (AnnCast e co) = Cast (deAnnotate e) co +deAnnotate' (AnnCast e (_,co)) = Cast (deAnnotate e) co deAnnotate' (AnnNote note body) = Note note (deAnnotate body) deAnnotate' (AnnLet bind body) diff -Nru ghc-7.0.3/compiler/coreSyn/CoreTidy.lhs ghc-7.2.1/compiler/coreSyn/CoreTidy.lhs --- ghc-7.0.3/compiler/coreSyn/CoreTidy.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/coreSyn/CoreTidy.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -17,7 +17,7 @@ import CoreArity import Id import IdInfo -import TcType( tidyType, tidyTyVarBndr ) +import TcType( tidyType, tidyCo, tidyTyVarBndr ) import Var import VarEnv import UniqFM @@ -55,11 +55,12 @@ ------------ Expressions -------------- tidyExpr :: TidyEnv -> CoreExpr -> CoreExpr tidyExpr env (Var v) = Var (tidyVarOcc env v) -tidyExpr env (Type ty) = Type (tidyType env ty) +tidyExpr env (Type ty) = Type (tidyType env ty) +tidyExpr env (Coercion co) = Coercion (tidyCo env co) tidyExpr _ (Lit lit) = Lit lit tidyExpr env (App f a) = App (tidyExpr env f) (tidyExpr env a) tidyExpr env (Note n e) = Note (tidyNote env n) (tidyExpr env e) -tidyExpr env (Cast e co) = Cast (tidyExpr env e) (tidyType env co) +tidyExpr env (Cast e co) = Cast (tidyExpr env e) (tidyCo env co) tidyExpr env (Let b e) = tidyBind env b =: \ (env', b') -> @@ -125,7 +126,7 @@ -- tidyBndr is used for lambda and case binders tidyBndr :: TidyEnv -> Var -> (TidyEnv, Var) tidyBndr env var - | isTyCoVar var = tidyTyVarBndr env var + | isTyVar var = tidyTyVarBndr env var | otherwise = tidyIdBndr env var tidyBndrs :: TidyEnv -> [Var] -> (TidyEnv, [Var]) @@ -197,7 +198,7 @@ ------------ Unfolding -------------- tidyUnfolding :: TidyEnv -> Unfolding -> Unfolding -> Unfolding tidyUnfolding tidy_env (DFunUnfolding ar con ids) _ - = DFunUnfolding ar con (map (fmap (tidyExpr tidy_env)) ids) + = DFunUnfolding ar con (map (tidyExpr tidy_env) ids) tidyUnfolding tidy_env unf@(CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src }) unf_from_rhs diff -Nru ghc-7.0.3/compiler/coreSyn/CoreUnfold.lhs ghc-7.2.1/compiler/coreSyn/CoreUnfold.lhs --- ghc-7.0.3/compiler/coreSyn/CoreUnfold.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/coreSyn/CoreUnfold.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -26,7 +26,7 @@ interestingArg, ArgSummary(..), - couldBeSmallEnoughToInline, + couldBeSmallEnoughToInline, inlineBoringOk, certainlyWillInline, smallEnoughToInline, callSiteInline, CallCtxt(..), @@ -41,8 +41,8 @@ import DynFlags import CoreSyn import PprCore () -- Instances -import TcType ( tcSplitSigmaTy, tcSplitDFunHead ) -import OccurAnal +import TcType ( tcSplitDFunTy ) +import OccurAnal ( occurAnalyseExpr ) import CoreSubst hiding( substTy ) import CoreFVs ( exprFreeVars ) import CoreArity ( manifestArity, exprBotStrictness_maybe ) @@ -54,16 +54,18 @@ import PrimOp import IdInfo import BasicTypes ( Arity ) -import TcType ( tcSplitDFunTy ) -import Type +import Type import Coercion import PrelNames import VarEnv ( mkInScopeSet ) import Bag import Util +import Pair import FastTypes import FastString import Outputable +import ForeignCall + import Data.Maybe \end{code} @@ -91,15 +93,12 @@ mkSimpleUnfolding :: CoreExpr -> Unfolding mkSimpleUnfolding = mkUnfolding InlineRhs False False -mkDFunUnfolding :: Type -> [DFunArg CoreExpr] -> Unfolding +mkDFunUnfolding :: Type -> [CoreExpr] -> Unfolding mkDFunUnfolding dfun_ty ops = DFunUnfolding dfun_nargs data_con ops where - (tvs, theta, head_ty) = tcSplitSigmaTy dfun_ty - -- NB: tcSplitSigmaTy: do not look through a newtype - -- when the dictionary type is a newtype - (cls, _) = tcSplitDFunHead head_ty - dfun_nargs = length tvs + length theta + (tvs, n_theta, cls, _) = tcSplitDFunTy dfun_ty + dfun_nargs = length tvs + n_theta data_con = classDataCon cls mkWwInlineRule :: Id -> CoreExpr -> Arity -> Unfolding @@ -111,7 +110,7 @@ mkCompulsoryUnfolding :: CoreExpr -> Unfolding mkCompulsoryUnfolding expr -- Used for things that absolutely must be unfolded = mkCoreUnfolding InlineCompulsory True - expr 0 -- Arity of unfolding doesn't matter + (simpleOptExpr expr) 0 -- Arity of unfolding doesn't matter (UnfWhen unSaturatedOk boringCxtOk) mkInlineUnfolding :: Maybe Arity -> CoreExpr -> Unfolding @@ -126,12 +125,7 @@ Nothing -> (unSaturatedOk, manifestArity expr') Just ar -> (needSaturated, ar) - boring_ok = case calcUnfoldingGuidance True -- Treat as cheap - False -- But not bottoming - (arity+1) expr' of - (_, UnfWhen _ boring_ok) -> boring_ok - _other -> boringCxtNotOk - -- See Note [INLINE for small functions] + boring_ok = inlineBoringOk expr' mkInlinableUnfolding :: CoreExpr -> Unfolding mkInlinableUnfolding expr @@ -162,6 +156,10 @@ -- Calculates unfolding guidance -- Occurrence-analyses the expression before capturing it mkUnfolding src top_lvl is_bottoming expr + | top_lvl && is_bottoming + , not (exprIsTrivial expr) + = NoUnfolding -- See Note [Do not inline top-level bottoming functions] + | otherwise = CoreUnfolding { uf_tmpl = occurAnalyseExpr expr, uf_src = src, uf_arity = arity, @@ -173,7 +171,7 @@ uf_guidance = guidance } where is_cheap = exprIsCheap expr - (arity, guidance) = calcUnfoldingGuidance is_cheap (top_lvl && is_bottoming) + (arity, guidance) = calcUnfoldingGuidance is_cheap opt_UF_CreationThreshold expr -- Sometimes during simplification, there's a large let-bound thing -- which has been substituted, and so is now dead; so 'expr' contains @@ -193,15 +191,35 @@ %************************************************************************ \begin{code} +inlineBoringOk :: CoreExpr -> Bool +-- See Note [INLINE for small functions] +-- True => the result of inlining the expression is +-- no bigger than the expression itself +-- eg (\x y -> f y x) +-- This is a quick and dirty version. It doesn't attempt +-- to deal with (\x y z -> x (y z)) +-- The really important one is (x `cast` c) +inlineBoringOk e + = go 0 e + where + go :: Int -> CoreExpr -> Bool + go credit (Lam x e) | isId x = go (credit+1) e + | otherwise = go credit e + go credit (App f (Type {})) = go credit f + go credit (App f a) | credit > 0 + , exprIsTrivial a = go (credit-1) f + go credit (Note _ e) = go credit e + go credit (Cast e _) = go credit e + go _ (Var {}) = boringCxtOk + go _ _ = boringCxtNotOk + calcUnfoldingGuidance :: Bool -- True <=> the rhs is cheap, or we want to treat it -- as cheap (INLINE things) - -> Bool -- True <=> this is a top-level unfolding for a - -- diverging function; don't inline this -> Int -- Bomb out if size gets bigger than this -> CoreExpr -- Expression to look at -> (Arity, UnfoldingGuidance) -calcUnfoldingGuidance expr_is_cheap top_bot bOMB_OUT_SIZE expr +calcUnfoldingGuidance expr_is_cheap bOMB_OUT_SIZE expr = case collectBinders expr of { (bndrs, body) -> let val_bndrs = filter isId bndrs @@ -214,9 +232,6 @@ | uncondInline n_val_bndrs (iBox size) , expr_is_cheap -> UnfWhen unSaturatedOk boringCxtOk -- Note [INLINE for small functions] - | top_bot -- See Note [Do not inline top-level bottoming functions] - -> UnfNever - | otherwise -> UnfIfGoodArgs { ug_args = map (discount cased_bndrs) val_bndrs , ug_size = iBox size @@ -260,6 +275,9 @@ a function call to account for. Notice also that constructor applications are very cheap, because exposing them to a caller is so valuable. +[25/5/11] All sizes are now multiplied by 10, except for primops. +This makes primops look cheap, and seems to be almost unversally +beneficial. Done partly as a result of #4978. Note [Do not inline top-level bottoming functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -317,7 +335,7 @@ -- See Note [INLINE for small functions] uncondInline arity size | arity == 0 = size == 0 - | otherwise = size <= arity + 1 + | otherwise = size <= 10 * (arity + 1) \end{code} @@ -336,27 +354,29 @@ size_up (Cast e _) = size_up e size_up (Note _ e) = size_up e size_up (Type _) = sizeZero -- Types cost nothing + size_up (Coercion _) = sizeZero size_up (Lit lit) = sizeN (litSize lit) size_up (Var f) = size_up_call f [] -- Make sure we get constructor -- discounts even on nullary constructors size_up (App fun (Type _)) = size_up fun + size_up (App fun (Coercion _)) = size_up fun size_up (App fun arg) = size_up arg `addSizeNSD` size_up_app fun [arg] - size_up (Lam b e) | isId b = lamScrutDiscount (size_up e `addSizeN` 1) + size_up (Lam b e) | isId b = lamScrutDiscount (size_up e `addSizeN` 10) | otherwise = size_up e size_up (Let (NonRec binder rhs) body) = size_up rhs `addSizeNSD` size_up body `addSizeN` - (if isUnLiftedType (idType binder) then 0 else 1) + (if isUnLiftedType (idType binder) then 0 else 10) -- For the allocation -- If the binder has an unlifted type there is no allocation size_up (Let (Rec pairs) body) = foldr (addSizeNSD . size_up . snd) - (size_up body `addSizeN` length pairs) -- (length pairs) for the allocation + (size_up body `addSizeN` (10 * length pairs)) -- (length pairs) for the allocation pairs size_up (Case (Var v) _ _ alts) @@ -373,7 +393,7 @@ -- the case when we are scrutinising an argument variable alts_size (SizeIs tot tot_disc tot_scrut) -- Size of all alternatives (SizeIs max _ _) -- Size of biggest alternative - = SizeIs tot (unitBag (v, iBox (_ILIT(2) +# tot -# max)) `unionBags` tot_disc) tot_scrut + = SizeIs tot (unitBag (v, iBox (_ILIT(20) +# tot -# max)) `unionBags` tot_disc) tot_scrut -- If the variable is known, we produce a discount that -- will take us back to 'max', the size of the largest alternative -- The 1+ is a little discount for reduced allocation in the caller @@ -383,20 +403,46 @@ alts_size tot_size _ = tot_size - size_up (Case e _ _ alts) = size_up e `addSizeNSD` - foldr (addAltSize . size_up_alt) sizeZero alts - -- We don't charge for the case itself - -- It's a strict thing, and the price of the call - -- is paid by scrut. Also consider - -- case f x of DEFAULT -> e - -- This is just ';'! Don't charge for it. - -- - -- Moreover, we charge one per alternative. + size_up (Case e _ _ alts) = size_up e `addSizeNSD` + foldr (addAltSize . size_up_alt) case_size alts + where + case_size + | is_inline_scrut e, not (lengthExceeds alts 1) = sizeN (-10) + | otherwise = sizeZero + -- Normally we don't charge for the case itself, but + -- we charge one per alternative (see size_up_alt, + -- below) to account for the cost of the info table + -- and comparisons. + -- + -- However, in certain cases (see is_inline_scrut + -- below), no code is generated for the case unless + -- there are multiple alts. In these cases we + -- subtract one, making the first alt free. + -- e.g. case x# +# y# of _ -> ... should cost 1 + -- case touch# x# of _ -> ... should cost 0 + -- (see #4978) + -- + -- I would like to not have the "not (lengthExceeds alts 1)" + -- condition above, but without that some programs got worse + -- (spectral/hartel/event and spectral/para). I don't fully + -- understand why. (SDM 24/5/11) + + -- unboxed variables, inline primops and unsafe foreign calls + -- are all "inline" things: + is_inline_scrut (Var v) = isUnLiftedType (idType v) + is_inline_scrut scrut + | (Var f, _) <- collectArgs scrut + = case idDetails f of + FCallId fc -> not (isSafeForeignCall fc) + PrimOpId op -> not (primOpOutOfLine op) + _other -> False + | otherwise + = False ------------ -- size_up_app is used when there's ONE OR MORE value args size_up_app (App fun arg) args - | isTypeArg arg = size_up_app fun args + | isTyCoArg arg = size_up_app fun args | otherwise = size_up arg `addSizeNSD` size_up_app fun (arg:args) size_up_app (Var fun) args = size_up_call fun args @@ -406,14 +452,14 @@ size_up_call :: Id -> [CoreExpr] -> ExprSize size_up_call fun val_args = case idDetails fun of - FCallId _ -> sizeN opt_UF_DearOp + FCallId _ -> sizeN (10 * (1 + length val_args)) DataConWorkId dc -> conSize dc (length val_args) PrimOpId op -> primOpSize op (length val_args) ClassOpId _ -> classOpSize top_args val_args _ -> funSize top_args fun (length val_args) ------------ - size_up_alt (_con, _bndrs, rhs) = size_up rhs `addSizeN` 1 + size_up_alt (_con, _bndrs, rhs) = size_up rhs `addSizeN` 10 -- Don't charge for args, so that wrappers look cheap -- (See comments about wrappers with Case) -- @@ -449,7 +495,7 @@ -- | Finds a nominal size of a string literal. litSize :: Literal -> Int -- Used by CoreUnfold.sizeExpr -litSize (MachStr str) = 1 + ((lengthFS str + 3) `div` 4) +litSize (MachStr str) = 10 + 10 * ((lengthFS str + 3) `div` 4) -- If size could be 0 then @f "x"@ might be too small -- [Sept03: make literal strings a bit bigger to avoid fruitless -- duplication of little strings] @@ -464,7 +510,7 @@ classOpSize top_args (arg1 : other_args) = SizeIs (iUnbox size) arg_discount (_ILIT(0)) where - size = 2 + length other_args + size = 20 + (10 * length other_args) -- If the class op is scrutinising a lambda bound dictionary then -- give it a discount, to encourage the inlining of this function -- The actual discount is rather arbitrarily chosen @@ -492,8 +538,7 @@ res_discount | idArity fun > n_val_args = opt_UF_FunAppDiscount | otherwise = 0 -- If the function is partially applied, show a result discount - - size | some_val_args = 1 + n_val_args + size | some_val_args = 10 * (1 + n_val_args) | otherwise = 0 -- The 1+ is for the function itself -- Add 1 for each non-trivial arg; @@ -502,16 +547,17 @@ conSize :: DataCon -> Int -> ExprSize conSize dc n_val_args - | n_val_args == 0 = SizeIs (_ILIT(0)) emptyBag (_ILIT(1)) -- Like variables - --- See Note [Constructor size] - | isUnboxedTupleCon dc = SizeIs (_ILIT(0)) emptyBag (iUnbox n_val_args +# _ILIT(1)) + | n_val_args == 0 = SizeIs (_ILIT(0)) emptyBag (_ILIT(10)) -- Like variables -- See Note [Unboxed tuple result discount] --- | isUnboxedTupleCon dc = SizeIs (_ILIT(0)) emptyBag (_ILIT(0)) + | isUnboxedTupleCon dc = SizeIs (_ILIT(0)) emptyBag (iUnbox (10 * (1 + n_val_args))) -- See Note [Constructor size] - | otherwise = SizeIs (_ILIT(1)) emptyBag (iUnbox n_val_args +# _ILIT(1)) + | otherwise = SizeIs (_ILIT(10)) emptyBag (iUnbox (10 * (10 + n_val_args))) + -- discont was (10 * (1 + n_val_args)), but it turns out that + -- adding a bigger constant here is an unambiguous win. We + -- REALLY like unfolding constructors that get scrutinised. + -- [SDM, 25/5/11] \end{code} Note [Constructor size] @@ -542,23 +588,15 @@ \begin{code} primOpSize :: PrimOp -> Int -> ExprSize primOpSize op n_val_args - | not (primOpIsDupable op) = sizeN opt_UF_DearOp - | not (primOpOutOfLine op) = sizeN 1 - -- Be very keen to inline simple primops. - -- We give a discount of 1 for each arg so that (op# x y z) costs 2. - -- We can't make it cost 1, else we'll inline let v = (op# x y z) - -- at every use of v, which is excessive. - -- - -- A good example is: - -- let x = +# p q in C {x} - -- Even though x get's an occurrence of 'many', its RHS looks cheap, - -- and there's a good chance it'll get inlined back into C's RHS. Urgh! - - | otherwise = sizeN n_val_args + = if primOpOutOfLine op + then sizeN (op_size + n_val_args) + else sizeN op_size + where + op_size = primOpCodeSize op buildSize :: ExprSize -buildSize = SizeIs (_ILIT(0)) emptyBag (_ILIT(4)) +buildSize = SizeIs (_ILIT(0)) emptyBag (_ILIT(40)) -- We really want to inline applications of build -- build t (\cn -> e) should cost only the cost of e (because build will be inlined later) -- Indeed, we should add a result_discount becuause build is @@ -567,7 +605,7 @@ -- The "4" is rather arbitrary. augmentSize :: ExprSize -augmentSize = SizeIs (_ILIT(0)) emptyBag (_ILIT(4)) +augmentSize = SizeIs (_ILIT(0)) emptyBag (_ILIT(40)) -- Ditto (augment t (\cn -> e) ys) should cost only the cost of -- e plus ys. The -2 accounts for the \cn @@ -699,7 +737,7 @@ UnfNever -> False UnfWhen {} -> True UnfIfGoodArgs { ug_size = size} - -> is_cheap && size - (n_vals +1) <= opt_UF_UseThreshold + -> is_cheap && size - (10 * (n_vals +1)) <= opt_UF_UseThreshold certainlyWillInline _ = False @@ -771,21 +809,23 @@ -- be a loop breaker (maybe the knot is not yet untied) CoreUnfolding { uf_tmpl = unf_template, uf_is_top = is_top , uf_is_cheap = is_cheap, uf_arity = uf_arity - , uf_guidance = guidance } + , uf_guidance = guidance, uf_expandable = is_exp } | active_unfolding -> tryUnfolding dflags id lone_variable arg_infos cont_info unf_template is_top - is_cheap uf_arity guidance - | otherwise -> Nothing + is_cheap is_exp uf_arity guidance + | dopt Opt_D_dump_inlinings dflags && dopt Opt_D_verbose_core2core dflags + -> pprTrace "Inactive unfolding:" (ppr id) Nothing + | otherwise -> Nothing NoUnfolding -> Nothing OtherCon {} -> Nothing DFunUnfolding {} -> Nothing -- Never unfold a DFun tryUnfolding :: DynFlags -> Id -> Bool -> [ArgSummary] -> CallCtxt - -> CoreExpr -> Bool -> Bool -> Arity -> UnfoldingGuidance + -> CoreExpr -> Bool -> Bool -> Bool -> Arity -> UnfoldingGuidance -> Maybe CoreExpr tryUnfolding dflags id lone_variable arg_infos cont_info unf_template is_top - is_cheap uf_arity guidance + is_cheap is_exp uf_arity guidance -- uf_arity will typically be equal to (idArity id), -- but may be less for InlineRules | dopt Opt_D_dump_inlinings dflags && dopt Opt_D_verbose_core2core dflags @@ -794,6 +834,7 @@ text "uf arity" <+> ppr uf_arity, text "interesting continuation" <+> ppr cont_info, text "some_benefit" <+> ppr some_benefit, + text "is exp:" <+> ppr is_exp, text "is cheap:" <+> ppr is_cheap, text "guidance" <+> ppr guidance, extra_doc, @@ -827,10 +868,10 @@ interesting_saturated_call = case cont_info of - BoringCtxt -> not is_top && uf_arity > 0 -- Note [Nested functions] + BoringCtxt -> not is_top && uf_arity > 0 -- Note [Nested functions] CaseCtxt -> not (lone_variable && is_cheap) -- Note [Lone variables] - ArgCtxt {} -> uf_arity > 0 -- Note [Inlining in ArgCtxt] - ValAppCtxt -> True -- Note [Cast then apply] + ArgCtxt {} -> uf_arity > 0 -- Note [Inlining in ArgCtxt] + ValAppCtxt -> True -- Note [Cast then apply] (yes_or_no, extra_doc) = case guidance of @@ -882,7 +923,7 @@ {- Arity: 3, HasNoCafRefs, Strictness: SLL, Unfolding: (\ @ a $dOrd :: GHC.Classes.Ord a x :: a y :: a -> case @ a GHC.Classes.<= @ a $dOrd x y of wild { - GHC.Bool.False -> y GHC.Bool.True -> x }) -} + GHC.Types.False -> y GHC.Types.True -> x }) -} We *really* want to inline $dmmin, even though it has arity 3, in order to unravel the recursion. @@ -1046,10 +1087,10 @@ -- *efficiency* to be gained (e.g. beta reductions, case reductions) -- by inlining. - = 1 -- Discount of 1 because the result replaces the call + = 10 -- Discount of 1 because the result replaces the call -- so we count 1 for the function itself - + length (take n_vals_wanted arg_infos) + + 10 * length (take n_vals_wanted arg_infos) -- Discount of (un-scaled) 1 for each arg supplied, -- because the result replaces the call @@ -1059,13 +1100,13 @@ arg_discount = sum (zipWith mk_arg_discount arg_discounts arg_infos) mk_arg_discount _ TrivArg = 0 - mk_arg_discount _ NonTrivArg = 1 + mk_arg_discount _ NonTrivArg = 10 mk_arg_discount discount ValueArg = discount res_discount' = case cont_info of BoringCtxt -> 0 CaseCtxt -> res_discount - _other -> 4 `min` res_discount + _other -> 40 `min` res_discount -- res_discount can be very large when a function returns -- constructors; but we only want to invoke that large discount -- when there's a case continuation. @@ -1134,12 +1175,14 @@ conlike_unfolding = isConLikeUnfolding (idUnfolding v) go (Type _) _ = TrivArg - go (App fn (Type _)) n = go fn n + go (Coercion _) _ = TrivArg + go (App fn (Type _)) n = go fn n + go (App fn (Coercion _)) n = go fn n go (App fn _) n = go fn (n+1) go (Note _ a) n = go a n go (Cast e _) n = go e n go (Lam v e) n - | isTyCoVar v = go e n + | isTyVar v = go e n | n>0 = go e (n-1) | otherwise = ValueArg go (Let _ e) n = case go e n of { ValueArg -> ValueArg; _ -> NonTrivArg } @@ -1195,7 +1238,7 @@ Nothing -> Nothing ; Just (dc, _dc_univ_args, dc_args) -> - let (_from_ty, to_ty) = coercionKind co + let Pair _from_ty to_ty = coercionKind co dc_tc = dataConTyCon dc in case splitTyConApp_maybe to_ty of { @@ -1215,41 +1258,28 @@ dc_ex_tyvars = dataConExTyVars dc arg_tys = dataConRepArgTys dc - dc_eqs :: [(Type,Type)] -- All equalities from the DataCon - dc_eqs = [(mkTyVarTy tv, ty) | (tv,ty) <- dataConEqSpec dc] ++ - [getEqPredTys eq_pred | eq_pred <- dataConEqTheta dc] - - (ex_args, rest1) = splitAtList dc_ex_tyvars dc_args - (co_args, val_args) = splitAtList dc_eqs rest1 + (ex_args, val_args) = splitAtList dc_ex_tyvars dc_args -- Make the "theta" from Fig 3 of the paper gammas = decomposeCo tc_arity co - theta = zipOpenTvSubst (dc_univ_tyvars ++ dc_ex_tyvars) - (gammas ++ stripTypeArgs ex_args) + theta = zipOpenCvSubst (dc_univ_tyvars ++ dc_ex_tyvars) + (gammas ++ map mkReflCo (stripTypeArgs ex_args)) - -- Cast the existential coercion arguments - cast_co (ty1, ty2) (Type co) - = Type $ mkSymCoercion (substTy theta ty1) - `mkTransCoercion` co - `mkTransCoercion` (substTy theta ty2) - cast_co _ other_arg = pprPanic "cast_co" (ppr other_arg) - new_co_args = zipWith cast_co dc_eqs co_args - -- Cast the value arguments (which include dictionaries) new_val_args = zipWith cast_arg arg_tys val_args - cast_arg arg_ty arg = mkCoerce (substTy theta arg_ty) arg + cast_arg arg_ty arg = mkCoerce (liftCoSubst theta arg_ty) arg in #ifdef DEBUG let dump_doc = vcat [ppr dc, ppr dc_univ_tyvars, ppr dc_ex_tyvars, ppr arg_tys, ppr dc_args, ppr _dc_univ_args, ppr ex_args, ppr val_args] in - ASSERT2( coreEqType _from_ty (mkTyConApp dc_tc _dc_univ_args), dump_doc ) - ASSERT2( all isTypeArg (ex_args ++ co_args), dump_doc ) + ASSERT2( eqType _from_ty (mkTyConApp dc_tc _dc_univ_args), dump_doc ) + ASSERT2( all isTypeArg ex_args, dump_doc ) ASSERT2( equalLength val_args arg_tys, dump_doc ) #endif - Just (dc, to_tc_arg_tys, ex_args ++ new_co_args ++ new_val_args) + Just (dc, to_tc_arg_tys, ex_args ++ new_val_args) }} exprIsConApp_maybe id_unf expr @@ -1269,11 +1299,9 @@ , let sat = length args == dfun_nargs -- See Note [DFun arity check] in if sat then True else pprTrace "Unsaturated dfun" (ppr fun <+> int dfun_nargs $$ ppr args) False - , let (dfun_tvs, _cls, dfun_res_tys) = tcSplitDFunTy (idType fun) + , let (dfun_tvs, _n_theta, _cls, dfun_res_tys) = tcSplitDFunTy (idType fun) subst = zipOpenTvSubst dfun_tvs (stripTypeArgs (takeList dfun_tvs args)) - mk_arg (DFunConstArg e) = e - mk_arg (DFunLamArg i) = args !! i - mk_arg (DFunPolyArg e) = mkApps e args + mk_arg e = mkApps e args = Just (con, substTys subst dfun_res_tys, map mk_arg ops) -- Look through unfoldings, but only cheap ones, because @@ -1288,7 +1316,7 @@ ----------- beta (Lam v body) pairs (arg : args) - | isTypeArg arg + | isTyCoArg arg = beta body ((v,arg):pairs) args beta (Lam {}) _ _ -- Un-saturated, or not a type lambda @@ -1300,10 +1328,10 @@ subst = mkOpenSubst (mkInScopeSet (exprFreeVars fun)) pairs -- doc = vcat [ppr fun, ppr expr, ppr pairs, ppr args] - stripTypeArgs :: [CoreExpr] -> [Type] stripTypeArgs args = ASSERT2( all isTypeArg args, ppr args ) [ty | Type ty <- args] + -- We really do want isTypeArg here, not isTyCoArg! \end{code} Note [Unfolding DFuns] diff -Nru ghc-7.0.3/compiler/coreSyn/CoreUtils.lhs ghc-7.2.1/compiler/coreSyn/CoreUtils.lhs --- ghc-7.0.3/compiler/coreSyn/CoreUtils.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/coreSyn/CoreUtils.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -16,7 +16,7 @@ -- | Commonly useful utilites for manipulating the Core language module CoreUtils ( -- * Constructing expressions - mkSCC, mkCoerce, mkCoerceI, + mkSCC, mkCoerce, bindNonRec, needsCaseBinding, mkAltExpr, mkPiType, mkPiTypes, @@ -25,13 +25,14 @@ -- * Properties of expressions exprType, coreAltType, coreAltsType, - exprIsDupable, exprIsTrivial, + exprIsDupable, exprIsTrivial, exprIsBottom, exprIsCheap, exprIsExpandable, exprIsCheap', CheapAppFun, exprIsHNF, exprOkForSpeculation, exprIsBig, exprIsConLike, rhsIsStatic, isCheapApp, isExpandableApp, -- * Expression and bindings size coreBindsSize, exprSize, + CoreStats(..), coreBindsStats, -- * Hashing hashExpr, @@ -44,7 +45,7 @@ -- * Manipulating data constructors and types applyTypeToArgs, applyTypeToArg, - dataConOrigInstPat, dataConRepInstPat, dataConRepFSInstPat + dataConRepInstPat, dataConRepFSInstPat ) where #include "HsVersions.h" @@ -56,15 +57,11 @@ import VarEnv import VarSet import Name -#if mingw32_TARGET_OS -import Packages -#endif import Literal import DataCon import PrimOp import Id import IdInfo -import TcType ( isPredTy ) import Type import Coercion import TyCon @@ -72,10 +69,10 @@ import Unique import Outputable import TysPrim -import PrelNames( absentErrorIdKey ) import FastString import Maybes import Util +import Pair import Data.Word import Data.Bits \end{code} @@ -94,9 +91,10 @@ -- really be said to have a type exprType (Var var) = idType var exprType (Lit lit) = literalType lit +exprType (Coercion co) = coercionType co exprType (Let _ body) = exprType body exprType (Case _ _ ty _) = ty -exprType (Cast _ co) = snd (coercionKind co) +exprType (Cast _ co) = pSnd (coercionKind co) exprType (Note _ e) = exprType e exprType (Lam binder expr) = mkPiType binder (exprType expr) exprType e@(App _ _) @@ -113,7 +111,7 @@ where ty = exprType rhs free_tvs = tyVarsOfType ty - bad_binder b = isTyCoVar b && b `elemVarSet` free_tvs + bad_binder b = isTyVar b && b `elemVarSet` free_tvs coreAltsType :: [CoreAlt] -> Type -- ^ Returns the type of the first alternative, which should be the same as for all alternatives @@ -146,10 +144,10 @@ we are doing here. It's not too expensive, I think. \begin{code} -mkPiType :: EvVar -> Type -> Type +mkPiType :: Var -> Type -> Type -- ^ Makes a @(->)@ type or a forall type, depending -- on whether it is given a type variable or a term variable. -mkPiTypes :: [EvVar] -> Type -> Type +mkPiTypes :: [Var] -> Type -> Type -- ^ 'mkPiType' for multiple type or value arguments mkPiType v ty @@ -175,11 +173,11 @@ go [ty] args where go rev_tys (Type ty : args) = go (ty:rev_tys) args - go rev_tys rest_args = applyTypeToArgs e op_ty' rest_args - where - op_ty' = applyTysD msg op_ty (reverse rev_tys) - msg = ptext (sLit "applyTypeToArgs") <+> - panic_msg e op_ty + go rev_tys rest_args = applyTypeToArgs e op_ty' rest_args + where + op_ty' = applyTysD msg op_ty (reverse rev_tys) + msg = ptext (sLit "applyTypeToArgs") <+> + panic_msg e op_ty applyTypeToArgs e op_ty (_ : args) = case (splitFunTy_maybe op_ty) of @@ -197,25 +195,22 @@ %************************************************************************ \begin{code} --- | Wrap the given expression in the coercion, dropping identity coercions and coalescing nested coercions -mkCoerceI :: CoercionI -> CoreExpr -> CoreExpr -mkCoerceI (IdCo _) e = e -mkCoerceI (ACo co) e = mkCoerce co e - --- | Wrap the given expression in the coercion safely, coalescing nested coercions +-- | Wrap the given expression in the coercion safely, dropping +-- identity coercions and coalescing nested coercions mkCoerce :: Coercion -> CoreExpr -> CoreExpr +mkCoerce co e | isReflCo co = e mkCoerce co (Cast expr co2) - = ASSERT(let { (from_ty, _to_ty) = coercionKind co; - (_from_ty2, to_ty2) = coercionKind co2} in - from_ty `coreEqType` to_ty2 ) - mkCoerce (mkTransCoercion co2 co) expr + = ASSERT(let { Pair from_ty _to_ty = coercionKind co; + Pair _from_ty2 to_ty2 = coercionKind co2} in + from_ty `eqType` to_ty2 ) + mkCoerce (mkTransCo co2 co) expr mkCoerce co expr - = let (from_ty, _to_ty) = coercionKind co in --- if to_ty `coreEqType` from_ty + = let Pair from_ty _to_ty = coercionKind co in +-- if to_ty `eqType` from_ty -- then expr -- else - WARN(not (from_ty `coreEqType` exprType expr), text "Trying to coerce" <+> text "(" <> ppr expr $$ text "::" <+> ppr (exprType expr) <> text ")" $$ ppr co $$ pprEqPred (coercionKind co)) + WARN(not (from_ty `eqType` exprType expr), text "Trying to coerce" <+> text "(" <> ppr expr $$ text "::" <+> ppr (exprType expr) <> text ")" $$ ppr co $$ pprEqPred (coercionKind co)) (Cast expr co) \end{code} @@ -418,7 +413,8 @@ \begin{code} exprIsTrivial :: CoreExpr -> Bool exprIsTrivial (Var _) = True -- See Note [Variables are trivial] -exprIsTrivial (Type _) = True +exprIsTrivial (Type _) = True +exprIsTrivial (Coercion _) = True exprIsTrivial (Lit lit) = litIsTrivial lit exprIsTrivial (App e arg) = not (isRuntimeArg arg) && exprIsTrivial e exprIsTrivial (Note _ e) = exprIsTrivial e -- See Note [SCCs are trivial] @@ -427,6 +423,25 @@ exprIsTrivial _ = False \end{code} +exprIsBottom is a very cheap and cheerful function; it may return +False for bottoming expressions, but it never costs much to ask. +See also CoreArity.exprBotStrictness_maybe, but that's a bit more +expensive. + +\begin{code} +exprIsBottom :: CoreExpr -> Bool +exprIsBottom e + = go 0 e + where + go n (Var v) = isBottomingId v && n >= idArity v + go n (App e a) | isTypeArg a = go n e + | otherwise = go (n+1) e + go n (Note _ e) = go n e + go n (Cast e _) = go n e + go n (Let _ e) = go n e + go _ _ = False +\end{code} + %************************************************************************ %* * @@ -449,22 +464,28 @@ \begin{code} exprIsDupable :: CoreExpr -> Bool -exprIsDupable (Type _) = True -exprIsDupable (Var _) = True -exprIsDupable (Lit lit) = litIsDupable lit -exprIsDupable (Note _ e) = exprIsDupable e -exprIsDupable (Cast e _) = exprIsDupable e -exprIsDupable expr - = go expr 0 +exprIsDupable e + = isJust (go dupAppSize e) where - go (Var _) _ = True - go (App f a) n_args = n_args < dupAppSize - && exprIsDupable a - && go f (n_args+1) - go _ _ = False + go :: Int -> CoreExpr -> Maybe Int + go n (Type {}) = Just n + go n (Coercion {}) = Just n + go n (Var {}) = decrement n + go n (Note _ e) = go n e + go n (Cast e _) = go n e + go n (App f a) | Just n' <- go n a = go n' f + go n (Lit lit) | litIsDupable lit = decrement n + go _ _ = Nothing + + decrement :: Int -> Maybe Int + decrement 0 = Nothing + decrement n = Just (n-1) dupAppSize :: Int -dupAppSize = 4 -- Size of application we are prepared to duplicate +dupAppSize = 8 -- Size of term we are prepared to duplicate + -- This is *just* big enough to make test MethSharing + -- inline enough join points. Really it should be + -- smaller, and could be if we fixed Trac #4960. \end{code} %************************************************************************ @@ -519,13 +540,14 @@ type CheapAppFun = Id -> Int -> Bool exprIsCheap' :: CheapAppFun -> CoreExpr -> Bool -exprIsCheap' _ (Lit _) = True -exprIsCheap' _ (Type _) = True -exprIsCheap' _ (Var _) = True -exprIsCheap' good_app (Note _ e) = exprIsCheap' good_app e -exprIsCheap' good_app (Cast e _) = exprIsCheap' good_app e -exprIsCheap' good_app (Lam x e) = isRuntimeVar x - || exprIsCheap' good_app e +exprIsCheap' _ (Lit _) = True +exprIsCheap' _ (Type _) = True +exprIsCheap' _ (Coercion _) = True +exprIsCheap' _ (Var _) = True +exprIsCheap' good_app (Note _ e) = exprIsCheap' good_app e +exprIsCheap' good_app (Cast e _) = exprIsCheap' good_app e +exprIsCheap' good_app (Lam x e) = isRuntimeVar x + || exprIsCheap' good_app e exprIsCheap' good_app (Case e _ _ alts) = exprIsCheap' good_app e && and [exprIsCheap' good_app rhs | (_,_,rhs) <- alts] @@ -553,7 +575,7 @@ go (Var _) [] = True -- Just a type application of a variable -- (f t1 t2 t3) counts as WHNF go (Var f) args - = case idDetails f of + = case idDetails f of RecSelId {} -> go_sel args ClassOpId {} -> go_sel args PrimOpId op -> go_primop op args @@ -567,12 +589,16 @@ go _ _ = False -------------- - go_pap args = all exprIsTrivial args - -- For constructor applications and primops, check that all - -- the args are trivial. We don't want to treat as cheap, say, - -- (1:2:3:4:5:[]) - -- We'll put up with one constructor application, but not dozens - + go_pap args = all (exprIsCheap' good_app) args + -- Used to be "all exprIsTrivial args" due to concerns about + -- duplicating nested constructor applications, but see #4978. + -- The principle here is that + -- let x = a +# b in c *# x + -- should behave equivalently to + -- c *# (a +# b) + -- Since lets with cheap RHSs are accepted, + -- so should paps with cheap arguments + -------------- go_primop op args = primOpIsCheap op && all (exprIsCheap' good_app) args -- In principle we should worry about primops @@ -635,6 +661,11 @@ -- -- * Safe /not/ to evaluate even if normal order would do so -- +-- It is usually called on arguments of unlifted type, but not always +-- In particular, Simplify.rebuildCase calls it on lifted types +-- when a 'case' is a plain 'seq'. See the example in +-- Note [exprOkForSpeculation: case expressions] below +-- -- Precisely, it returns @True@ iff: -- -- * The expression guarantees to terminate, @@ -658,11 +689,17 @@ -- We can only do this if the @y + 1@ is ok for speculation: it has no -- side effects, and can't diverge or raise an exception. exprOkForSpeculation :: CoreExpr -> Bool -exprOkForSpeculation (Lit _) = True -exprOkForSpeculation (Type _) = True - -- Tick boxes are *not* suitable for speculation -exprOkForSpeculation (Var v) = isUnLiftedType (idType v) - && not (isTickBoxOp v) +exprOkForSpeculation (Lit _) = True +exprOkForSpeculation (Type _) = True +exprOkForSpeculation (Coercion _) = True + +exprOkForSpeculation (Var v) + | isTickBoxOp v = False -- Tick boxes are *not* suitable for speculation + | otherwise = isUnLiftedType (idType v) -- c.f. the Var case of exprIsHNF + || isDataConWorkId v -- Nullary constructors + || idArity v > 0 -- Functions + || isEvaldUnfolding (idUnfolding v) -- Let-bound values + exprOkForSpeculation (Note _ e) = exprOkForSpeculation e exprOkForSpeculation (Cast e _) = exprOkForSpeculation e @@ -672,10 +709,7 @@ exprOkForSpeculation other_expr = case collectArgs other_expr of - (Var f, args) | f `hasKey` absentErrorIdKey -- Note [Absent error Id] - -> all exprOkForSpeculation args -- in WwLib - | otherwise - -> spec_ok (idDetails f) args + (Var f, args) -> spec_ok (idDetails f) args _ -> False where @@ -691,13 +725,16 @@ -- Often there is a literal divisor, and this -- can get rid of a thunk in an inner looop + | DataToTagOp <- op -- See Note [dataToTag speculation] + = True + | otherwise = primOpOkForSpeculation op && all exprOkForSpeculation args -- A bit conservative: we don't really need -- to care about lazy arguments, but this is easy - spec_ok (DFunId _ new_type) _ = not new_type + spec_ok (DFunId new_type) _ = not new_type -- DFuns terminate, unless the dict is implemented with a newtype -- in which case they may not @@ -719,7 +756,6 @@ Note [exprOkForSpeculation: case expressions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - It's always sound for exprOkForSpeculation to return False, and we don't want it to take too long, so it bales out on complicated-looking terms. Notably lets, which can be stacked very deeply; and in any @@ -727,7 +763,7 @@ so any lets will have been floated away. However, we keep going on case-expressions. An example like this one -showed up in DPH code: +showed up in DPH code (Trac #3717): foo :: Int -> Int foo 0 = 0 foo n = (if n < 5 then 1 else 2) `seq` foo (n-1) @@ -737,8 +773,8 @@ \ (ww :: GHC.Prim.Int#) -> case ww of ds { __DEFAULT -> case (case <# ds 5 of _ { - GHC.Bool.False -> lvl1; - GHC.Bool.True -> lvl}) + GHC.Types.False -> lvl1; + GHC.Types.True -> lvl}) of _ { __DEFAULT -> T.$wfoo (GHC.Prim.-# ds_XkE 1) }; 0 -> 0 @@ -746,6 +782,27 @@ The inner case is redundant, and should be nuked. +Note [dataToTag speculation] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Is this OK? + f x = let v::Int# = dataToTag# x + in ... +We say "yes", even though 'x' may not be evaluated. Reasons + + * dataToTag#'s strictness means that its argument often will be + evaluated, but FloatOut makes that temporarily untrue + case x of y -> let v = dataToTag# y in ... + --> + case x of y -> let v = dataToTag# x in ... + Note that we look at 'x' instead of 'y' (this is to improve + floating in FloatOut). So Lint complains. + + Moreover, it really *might* improve floating to let the + v-binding float out + + * CorePrep makes sure dataToTag#'s argument is evaluated, just + before code gen. Until then, it's not guaranteed + %************************************************************************ %* * @@ -814,12 +871,14 @@ -- we could get an infinite loop is_hnf_like (Lit _) = True - is_hnf_like (Type _) = True -- Types are honorary Values; + is_hnf_like (Type _) = True -- Types are honorary Values; -- we don't mind copying them + is_hnf_like (Coercion _) = True -- Same for coercions is_hnf_like (Lam b e) = isRuntimeVar b || is_hnf_like e is_hnf_like (Note _ e) = is_hnf_like e is_hnf_like (Cast e _) = is_hnf_like e - is_hnf_like (App e (Type _)) = is_hnf_like e + is_hnf_like (App e (Type _)) = is_hnf_like e + is_hnf_like (App e (Coercion _)) = is_hnf_like e is_hnf_like (App e a) = app_is_value e [a] is_hnf_like (Let _ e) = is_hnf_like e -- Lazy let(rec)s don't affect us is_hnf_like _ = False @@ -845,36 +904,26 @@ These InstPat functions go here to avoid circularity between DataCon and Id \begin{code} -dataConRepInstPat, dataConOrigInstPat :: [Unique] -> DataCon -> [Type] -> ([TyVar], [CoVar], [Id]) -dataConRepFSInstPat :: [FastString] -> [Unique] -> DataCon -> [Type] -> ([TyVar], [CoVar], [Id]) +dataConRepInstPat :: [Unique] -> DataCon -> [Type] -> ([TyVar], [Id]) +dataConRepFSInstPat :: [FastString] -> [Unique] -> DataCon -> [Type] -> ([TyVar], [Id]) -dataConRepInstPat = dataConInstPat dataConRepArgTys (repeat ((fsLit "ipv"))) -dataConRepFSInstPat = dataConInstPat dataConRepArgTys -dataConOrigInstPat = dataConInstPat dc_arg_tys (repeat ((fsLit "ipv"))) - where - dc_arg_tys dc = map mkPredTy (dataConEqTheta dc) ++ map mkPredTy (dataConDictTheta dc) ++ dataConOrigArgTys dc - -- Remember to include the existential dictionaries +dataConRepInstPat = dataConInstPat (repeat ((fsLit "ipv"))) +dataConRepFSInstPat = dataConInstPat -dataConInstPat :: (DataCon -> [Type]) -- function used to find arg tys - -> [FastString] -- A long enough list of FSs to use for names - -> [Unique] -- An equally long list of uniques, at least one for each binder - -> DataCon - -> [Type] -- Types to instantiate the universally quantified tyvars - -> ([TyVar], [CoVar], [Id]) -- Return instantiated variables +dataConInstPat :: [FastString] -- A long enough list of FSs to use for names + -> [Unique] -- An equally long list of uniques, at least one for each binder + -> DataCon + -> [Type] -- Types to instantiate the universally quantified tyvars + -> ([TyVar], [Id]) -- Return instantiated variables -- dataConInstPat arg_fun fss us con inst_tys returns a triple --- (ex_tvs, co_tvs, arg_ids), +-- (ex_tvs, arg_ids), -- -- ex_tvs are intended to be used as binders for existential type args -- --- co_tvs are intended to be used as binders for coercion args and the kinds --- of these vars have been instantiated by the inst_tys and the ex_tys --- The co_tvs include both GADT equalities (dcEqSpec) and --- programmer-specified equalities (dcEqTheta) --- -- arg_ids are indended to be used as binders for value arguments, -- and their types have been instantiated with inst_tys and ex_tys --- The arg_ids include both dicts (dcDictTheta) and --- programmer-specified arguments (after rep-ing) (deRepArgTys) +-- The arg_ids include both evidence and +-- programmer-specified arguments (both after rep-ing) -- -- Example. -- The following constructor T1 @@ -889,29 +938,22 @@ -- -- dataConInstPat fss us T1 (a1',b') will return -- --- ([a1'', b''], [c :: (a1', b')~(a1'', b'')], [x :: Int, y :: b'']) +-- ([a1'', b''], [c :: (a1', b')~(a1'', b''), x :: Int, y :: b'']) -- -- where the double-primed variables are created with the FastStrings and -- Uniques given as fss and us -dataConInstPat arg_fun fss uniqs con inst_tys - = (ex_bndrs, co_bndrs, arg_ids) +dataConInstPat fss uniqs con inst_tys + = (ex_bndrs, arg_ids) where univ_tvs = dataConUnivTyVars con ex_tvs = dataConExTyVars con - arg_tys = arg_fun con - eq_spec = dataConEqSpec con - eq_theta = dataConEqTheta con - eq_preds = eqSpecPreds eq_spec ++ eq_theta + arg_tys = dataConRepArgTys con n_ex = length ex_tvs - n_co = length eq_preds -- split the Uniques and FastStrings - (ex_uniqs, uniqs') = splitAt n_ex uniqs - (co_uniqs, id_uniqs) = splitAt n_co uniqs' - - (ex_fss, fss') = splitAt n_ex fss - (co_fss, id_fss) = splitAt n_co fss' + (ex_uniqs, id_uniqs) = splitAt n_ex uniqs + (ex_fss, id_fss) = splitAt n_ex fss -- Make existential type variables ex_bndrs = zipWith3 mk_ex_var ex_uniqs ex_fss ex_tvs @@ -923,17 +965,9 @@ -- Make the instantiating substitution subst = zipOpenTvSubst (univ_tvs ++ ex_tvs) (inst_tys ++ map mkTyVarTy ex_bndrs) - -- Make new coercion vars, instantiating kind - co_bndrs = zipWith3 mk_co_var co_uniqs co_fss eq_preds - mk_co_var uniq fs eq_pred = mkCoVar new_name co_kind - where - new_name = mkSysTvName uniq fs - co_kind = substTy subst (mkPredTy eq_pred) - - -- make value vars, instantiating types - mk_id_var uniq fs ty = mkUserLocal (mkVarOccFS fs) uniq (substTy subst ty) noSrcSpan + -- Make value vars, instantiating types + mk_id_var uniq fs ty = mkUserLocal (mkVarOccFS fs) uniq (Type.substTy subst ty) noSrcSpan arg_ids = zipWith3 mk_id_var id_uniqs id_fss arg_tys - \end{code} %************************************************************************ @@ -952,7 +986,8 @@ cheapEqExpr (Var v1) (Var v2) = v1==v2 cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2 -cheapEqExpr (Type t1) (Type t2) = t1 `coreEqType` t2 +cheapEqExpr (Type t1) (Type t2) = t1 `eqType` t2 +cheapEqExpr (Coercion c1) (Coercion c2) = c1 `coreEqCoercion` c2 cheapEqExpr (App f1 a1) (App f2 a2) = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2 @@ -968,7 +1003,8 @@ -- ^ Returns @True@ of expressions that are too big to be compared by 'cheapEqExpr' exprIsBig (Lit _) = False exprIsBig (Var _) = False -exprIsBig (Type _) = False +exprIsBig (Type _) = False +exprIsBig (Coercion _) = False exprIsBig (Lam _ e) = exprIsBig e exprIsBig (App f a) = exprIsBig f || exprIsBig a exprIsBig (Cast e _) = exprIsBig e -- Hopefully coercions are not too big! @@ -1010,14 +1046,15 @@ , Just e2' <- expandUnfolding_maybe (id_unfolding_fun (lookupRnInScope env v2)) = go (nukeRnEnvR env) e1 e2' - go _ (Lit lit1) (Lit lit2) = lit1 == lit2 - go env (Type t1) (Type t2) = tcEqTypeX env t1 t2 - go env (Cast e1 co1) (Cast e2 co2) = tcEqTypeX env co1 co2 && go env e1 e2 + go _ (Lit lit1) (Lit lit2) = lit1 == lit2 + go env (Type t1) (Type t2) = eqTypeX env t1 t2 + go env (Coercion co1) (Coercion co2) = coreEqCoercion2 env co1 co2 + go env (Cast e1 co1) (Cast e2 co2) = coreEqCoercion2 env co1 co2 && go env e1 e2 go env (App f1 a1) (App f2 a2) = go env f1 f2 && go env a1 a2 go env (Note n1 e1) (Note n2 e2) = go_note n1 n2 && go env e1 e2 go env (Lam b1 e1) (Lam b2 e2) - = tcEqTypeX env (varType b1) (varType b2) -- False for Id/TyVar combination + = eqTypeX env (varType b1) (varType b2) -- False for Id/TyVar combination && go (rnBndr2 env b1 b2) e1 e2 go env (Let (NonRec v1 r1) e1) (Let (NonRec v2 r2) e2) @@ -1033,7 +1070,7 @@ go env (Case e1 b1 _ a1) (Case e2 b2 _ a2) = go env e1 e2 - && tcEqTypeX env (idType b1) (idType b2) + && eqTypeX env (idType b1) (idType b2) && all2 (go_alt (rnBndr2 env b1 b2)) a1 a2 go _ _ _ = False @@ -1070,22 +1107,24 @@ exprSize :: CoreExpr -> Int -- ^ A measure of the size of the expressions, strictly greater than 0 -- It also forces the expression pretty drastically as a side effect +-- Counts *leaves*, not internal nodes. Types and coercions are not counted. exprSize (Var v) = v `seq` 1 exprSize (Lit lit) = lit `seq` 1 exprSize (App f a) = exprSize f + exprSize a exprSize (Lam b e) = varSize b + exprSize e exprSize (Let b e) = bindSize b + exprSize e exprSize (Case e b t as) = seqType t `seq` exprSize e + varSize b + 1 + foldr ((+) . altSize) 0 as -exprSize (Cast e co) = (seqType co `seq` 1) + exprSize e +exprSize (Cast e co) = (seqCo co `seq` 1) + exprSize e exprSize (Note n e) = noteSize n + exprSize e -exprSize (Type t) = seqType t `seq` 1 +exprSize (Type t) = seqType t `seq` 1 +exprSize (Coercion co) = seqCo co `seq` 1 noteSize :: Note -> Int noteSize (SCC cc) = cc `seq` 1 noteSize (CoreNote s) = s `seq` 1 -- hdaume: core annotations varSize :: Var -> Int -varSize b | isTyCoVar b = 1 +varSize b | isTyVar b = 1 | otherwise = seqType (idType b) `seq` megaSeqIdInfo (idInfo b) `seq` 1 @@ -1104,6 +1143,55 @@ altSize (c,bs,e) = c `seq` varsSize bs + exprSize e \end{code} +\begin{code} +data CoreStats = CS { cs_tm, cs_ty, cs_co :: Int } + +plusCS :: CoreStats -> CoreStats -> CoreStats +plusCS (CS { cs_tm = p1, cs_ty = q1, cs_co = r1 }) + (CS { cs_tm = p2, cs_ty = q2, cs_co = r2 }) + = CS { cs_tm = p1+p2, cs_ty = q1+q2, cs_co = r1+r2 } + +zeroCS, oneTM :: CoreStats +zeroCS = CS { cs_tm = 0, cs_ty = 0, cs_co = 0 } +oneTM = zeroCS { cs_tm = 1 } + +sumCS :: (a -> CoreStats) -> [a] -> CoreStats +sumCS f = foldr (plusCS . f) zeroCS + +coreBindsStats :: [CoreBind] -> CoreStats +coreBindsStats = sumCS bindStats + +bindStats :: CoreBind -> CoreStats +bindStats (NonRec v r) = bindingStats v r +bindStats (Rec prs) = sumCS (\(v,r) -> bindingStats v r) prs + +bindingStats :: Var -> CoreExpr -> CoreStats +bindingStats v r = bndrStats v `plusCS` exprStats r + +bndrStats :: Var -> CoreStats +bndrStats v = oneTM `plusCS` tyStats (varType v) + +exprStats :: CoreExpr -> CoreStats +exprStats (Var {}) = oneTM +exprStats (Lit {}) = oneTM +exprStats (Type t) = tyStats t +exprStats (Coercion c) = coStats c +exprStats (App f a) = exprStats f `plusCS` exprStats a +exprStats (Lam b e) = bndrStats b `plusCS` exprStats e +exprStats (Let b e) = bindStats b `plusCS` exprStats e +exprStats (Case e b _ as) = exprStats e `plusCS` bndrStats b `plusCS` sumCS altStats as +exprStats (Cast e co) = coStats co `plusCS` exprStats e +exprStats (Note _ e) = exprStats e + +altStats :: CoreAlt -> CoreStats +altStats (_, bs, r) = sumCS bndrStats bs `plusCS` exprStats r + +tyStats :: Type -> CoreStats +tyStats ty = zeroCS { cs_ty = typeSize ty } + +coStats :: Coercion -> CoreStats +coStats co = zeroCS { cs_co = coercionSize co } +\end{code} %************************************************************************ %* * @@ -1144,15 +1232,17 @@ hash_expr _ (Type _) = WARN(True, text "hash_expr: type") 1 -- Shouldn't happen. Better to use WARN than trace, because trace -- prevents the CPR optimisation kicking in for hash_expr. +hash_expr _ (Coercion _) = WARN(True, text "hash_expr: coercion") 1 fast_hash_expr :: HashEnv -> CoreExpr -> Word32 -fast_hash_expr env (Var v) = hashVar env v -fast_hash_expr env (Type t) = fast_hash_type env t -fast_hash_expr _ (Lit lit) = fromIntegral (hashLiteral lit) -fast_hash_expr env (Cast e _) = fast_hash_expr env e -fast_hash_expr env (Note _ e) = fast_hash_expr env e -fast_hash_expr env (App _ a) = fast_hash_expr env a -- A bit idiosyncratic ('a' not 'f')! -fast_hash_expr _ _ = 1 +fast_hash_expr env (Var v) = hashVar env v +fast_hash_expr env (Type t) = fast_hash_type env t +fast_hash_expr env (Coercion co) = fast_hash_co env co +fast_hash_expr _ (Lit lit) = fromIntegral (hashLiteral lit) +fast_hash_expr env (Cast e _) = fast_hash_expr env e +fast_hash_expr env (Note _ e) = fast_hash_expr env e +fast_hash_expr env (App _ a) = fast_hash_expr env a -- A bit idiosyncratic ('a' not 'f')! +fast_hash_expr _ _ = 1 fast_hash_type :: HashEnv -> Type -> Word32 fast_hash_type env ty @@ -1161,6 +1251,13 @@ in foldr (\t n -> fast_hash_type env t + n) hash_tc tys | otherwise = 1 +fast_hash_co :: HashEnv -> Coercion -> Word32 +fast_hash_co env co + | Just cv <- getCoVar_maybe co = hashVar env cv + | Just (tc,cos) <- splitTyConAppCo_maybe co = let hash_tc = fromIntegral (hashName (tyConName tc)) + in foldr (\c n -> fast_hash_co env c + n) hash_tc cos + | otherwise = 1 + extend_env :: HashEnv -> Var -> (Int, VarEnv Int) extend_env (n,env) b = (n+1, extendVarEnv env b n) @@ -1260,18 +1357,18 @@ \begin{code} tryEtaReduce :: [Var] -> CoreExpr -> Maybe CoreExpr tryEtaReduce bndrs body - = go (reverse bndrs) body (IdCo (exprType body)) + = go (reverse bndrs) body (mkReflCo (exprType body)) where incoming_arity = count isId bndrs go :: [Var] -- Binders, innermost first, types [a3,a2,a1] -> CoreExpr -- Of type tr - -> CoercionI -- Of type tr ~ ts + -> Coercion -- Of type tr ~ ts -> Maybe CoreExpr -- Of type a1 -> a2 -> a3 -> ts -- See Note [Eta reduction with casted arguments] -- for why we have an accumulating coercion go [] fun co - | ok_fun fun = Just (mkCoerceI co fun) + | ok_fun fun = Just (mkCoerce co fun) go (b : bs) (App fun arg) co | Just co' <- ok_arg b arg co @@ -1282,7 +1379,7 @@ --------------- -- Note [Eta reduction conditions] ok_fun (App fun (Type ty)) - | not (any (`elemVarSet` tyVarsOfType ty) bndrs) + | not (any (`elemVarSet` tyVarsOfType ty) bndrs) = ok_fun fun ok_fun (Var fun_id) = not (fun_id `elem` bndrs) @@ -1294,26 +1391,26 @@ --------------- fun_arity fun -- See Note [Arity care] - | isLocalId fun && isLoopBreaker (idOccInfo fun) = 0 + | isLocalId fun && isStrongLoopBreaker (idOccInfo fun) = 0 | otherwise = idArity fun --------------- - ok_lam v = isTyCoVar v || isDictId v + ok_lam v = isTyVar v || isEvVar v --------------- - ok_arg :: Var -- Of type bndr_t - -> CoreExpr -- Of type arg_t - -> CoercionI -- Of kind (t1~t2) - -> Maybe CoercionI -- Of type (arg_t -> t1 ~ bndr_t -> t2) - -- (and similarly for tyvars, coercion args) + ok_arg :: Var -- Of type bndr_t + -> CoreExpr -- Of type arg_t + -> Coercion -- Of kind (t1~t2) + -> Maybe Coercion -- Of type (arg_t -> t1 ~ bndr_t -> t2) + -- (and similarly for tyvars, coercion args) -- See Note [Eta reduction with casted arguments] ok_arg bndr (Type ty) co | Just tv <- getTyVar_maybe ty - , bndr == tv = Just (mkForAllTyCoI tv co) + , bndr == tv = Just (mkForAllCo tv co) ok_arg bndr (Var v) co - | bndr == v = Just (mkFunTyCoI (IdCo (idType bndr)) co) + | bndr == v = Just (mkFunCo (mkReflCo (idType bndr)) co) ok_arg bndr (Cast (Var v) co_arg) co - | bndr == v = Just (mkFunTyCoI (ACo (mkSymCoercion co_arg)) co) + | bndr == v = Just (mkFunCo (mkSymCo co_arg) co) -- The simplifier combines multiple casts into one, -- so we can have a simple-minded pattern match here ok_arg _ _ _ = Nothing @@ -1396,16 +1493,14 @@ rhsIsStatic _is_dynamic_name rhs = is_static False rhs where is_static :: Bool -- True <=> in a constructor argument; must be atomic - -> CoreExpr -> Bool - - is_static False (Lam b e) = isRuntimeVar b || is_static False e - is_static in_arg (Note n e) = notSccNote n && is_static in_arg e - is_static in_arg (Cast e _) = is_static in_arg e + -> CoreExpr -> Bool - is_static _ (Lit lit) - = case lit of - MachLabel _ _ _ -> False - _ -> True + is_static False (Lam b e) = isRuntimeVar b || is_static False e + is_static in_arg (Note n e) = notSccNote n && is_static in_arg e + is_static in_arg (Cast e _) = is_static in_arg e + is_static _ (Coercion {}) = True -- Behaves just like a literal + is_static _ (Lit (MachLabel {})) = False + is_static _ (Lit _) = True -- A MachLabel (foreign import "&foo") in an argument -- prevents a constructor application from being static. The -- reason is that it might give rise to unresolvable symbols diff -Nru ghc-7.0.3/compiler/coreSyn/ExternalCore.lhs ghc-7.2.1/compiler/coreSyn/ExternalCore.lhs --- ghc-7.0.3/compiler/coreSyn/ExternalCore.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/coreSyn/ExternalCore.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -4,7 +4,6 @@ \begin{code} module ExternalCore where - data Module = Module Mname [Tdef] [Vdefg] @@ -51,21 +50,21 @@ type Vbind = (Var,Ty) type Tbind = (Tvar,Kind) +-- Internally, we represent types and coercions separately; but for +-- the purposes of external core (at least for now) it's still +-- convenient to collapse them into a single type. data Ty = Tvar Tvar | Tcon (Qual Tcon) | Tapp Ty Ty | Tforall Tbind Ty --- We distinguish primitive coercions --- (represented in GHC by wired-in names), because --- External Core treats them specially, so we have --- to print them out with special syntax. +-- We distinguish primitive coercions because External Core treats +-- them specially, so we have to print them out with special syntax. | TransCoercion Ty Ty | SymCoercion Ty | UnsafeCoercion Ty Ty | InstCoercion Ty Ty - | LeftCoercion Ty - | RightCoercion Ty + | NthCoercion Int Ty data Kind = Klifted diff -Nru ghc-7.0.3/compiler/coreSyn/MkCore.lhs ghc-7.2.1/compiler/coreSyn/MkCore.lhs --- ghc-7.0.3/compiler/coreSyn/MkCore.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/coreSyn/MkCore.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -45,8 +45,7 @@ #include "HsVersions.h" import Id -import IdInfo -import Var ( EvVar, mkWildCoVar, setTyVarUnique ) +import Var ( EvVar, setTyVarUnique ) import CoreSyn import CoreUtils ( exprType, needsCaseBinding, bindNonRec ) @@ -58,14 +57,15 @@ import TcType ( mkSigmaTy ) import Type +import Coercion import TysPrim import DataCon ( DataCon, dataConWorkId ) +import IdInfo ( vanillaIdInfo, setStrictnessInfo, setArityInfo ) import Demand import Name import Outputable import FastString import UniqSupply -import Unique ( mkBuiltinUnique ) import BasicTypes import Util ( notNull, zipEqual ) import Constants @@ -103,6 +103,7 @@ -- Check the invariant that the arg of an App is ok-for-speculation if unlifted -- See CoreSyn Note [CoreSyn let/app invariant] mkCoreApp fun (Type ty) = App fun (Type ty) +mkCoreApp fun (Coercion co) = App fun (Coercion co) mkCoreApp fun arg = ASSERT2( isFunTy fun_ty, ppr fun $$ ppr arg ) mk_val_app fun arg arg_ty res_ty where @@ -118,6 +119,7 @@ where go fun _ [] = fun go fun fun_ty (Type ty : args) = go (App fun (Type ty)) (applyTy fun_ty ty) args + go fun fun_ty (Coercion co : args) = go (App fun (Coercion co)) (applyCo fun_ty co) args go fun fun_ty (arg : args) = ASSERT2( isFunTy fun_ty, ppr fun_ty $$ ppr orig_fun $$ ppr orig_args ) go (mk_val_app fun arg arg_ty res_ty) res_ty args where @@ -149,15 +151,15 @@ -- fragmet of it as the fun part of a 'mk_val_app'. mkWildEvBinder :: PredType -> EvVar -mkWildEvBinder pred@(EqPred {}) = mkWildCoVar (mkPredTy pred) -mkWildEvBinder pred = mkWildValBinder (mkPredTy pred) +mkWildEvBinder pred = mkWildValBinder (mkPredTy pred) -- | Make a /wildcard binder/. This is typically used when you need a binder -- that you expect to use only at a *binding* site. Do not use it at -- occurrence sites because it has a single, fixed unique, and it's very -- easy to get into difficulties with shadowing. That's why it is used so little. +-- See Note [WildCard binders] in SimplEnv mkWildValBinder :: Type -> Id -mkWildValBinder ty = mkSysLocal (fsLit "wild") (mkBuiltinUnique 1) ty +mkWildValBinder ty = mkLocalId wildCardName ty mkWildCase :: CoreExpr -> Type -> Type -> [CoreAlt] -> CoreExpr -- Make a case expression whose case binder is unused @@ -478,11 +480,11 @@ in mk_tuple_case us' (chunkify vars') body' one_tuple_case chunk_vars (us, vs, body) - = let (us1, us2) = splitUniqSupply us - scrut_var = mkSysLocal (fsLit "ds") (uniqFromSupply us1) + = let (uniq, us') = takeUniqFromSupply us + scrut_var = mkSysLocal (fsLit "ds") uniq (mkBoxedTupleTy (map idType chunk_vars)) body' = mkSmallTupleCase chunk_vars body scrut_var (Var scrut_var) - in (us2, scrut_var:vs, body') + in (us', scrut_var:vs, body') \end{code} \begin{code} @@ -648,6 +650,7 @@ rEC_SEL_ERROR_ID, rUNTIME_ERROR_ID, iRREFUT_PAT_ERROR_ID, rEC_CON_ERROR_ID :: Id pAT_ERROR_ID, nO_METHOD_BINDING_ERROR_ID, nON_EXHAUSTIVE_GUARDS_ERROR_ID :: Id +aBSENT_ERROR_ID :: Id rEC_SEL_ERROR_ID = mkRuntimeErrorId recSelErrorName rUNTIME_ERROR_ID = mkRuntimeErrorId runtimeErrorName iRREFUT_PAT_ERROR_ID = mkRuntimeErrorId irrefutPatErrorName @@ -655,10 +658,7 @@ pAT_ERROR_ID = mkRuntimeErrorId patErrorName nO_METHOD_BINDING_ERROR_ID = mkRuntimeErrorId noMethodBindingErrorName nON_EXHAUSTIVE_GUARDS_ERROR_ID = mkRuntimeErrorId nonExhaustiveGuardsErrorName - -aBSENT_ERROR_ID :: Id --- Not bottoming; no unfolding! See Note [Absent error Id] in WwLib -aBSENT_ERROR_ID = mkVanillaGlobal absentErrorName runtimeErrorTy +aBSENT_ERROR_ID = mkRuntimeErrorId absentErrorName mkRuntimeErrorId :: Name -> Id mkRuntimeErrorId name = pc_bottoming_Id name runtimeErrorTy diff -Nru ghc-7.0.3/compiler/coreSyn/MkExternalCore.lhs ghc-7.2.1/compiler/coreSyn/MkExternalCore.lhs --- ghc-7.0.3/compiler/coreSyn/MkExternalCore.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/coreSyn/MkExternalCore.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -13,6 +13,8 @@ import CoreSyn import HscTypes import TyCon +-- import Class +-- import TysPrim( eqPredPrimTyCon ) import TypeRep import Type import PprExternalCore () -- Instances @@ -27,6 +29,7 @@ import ForeignCall import DynFlags import FastString +import Exception import Data.Char import System.IO @@ -35,10 +38,10 @@ emitExternalCore dflags cg_guts | dopt Opt_EmitExternalCore dflags = (do handle <- openFile corename WriteMode - hPutStrLn handle (show (mkExternalCore cg_guts)) + hPutStrLn handle (show (mkExternalCore cg_guts)) hClose handle) - `catch` (\_ -> pprPanic "Failed to open or write external core output file" - (text corename)) + `catchIO` (\_ -> pprPanic "Failed to open or write external core output file" + (text corename)) where corename = extCoreName dflags emitExternalCore _ _ | otherwise @@ -77,10 +80,7 @@ where tdef | isNewTyCon tcon = C.Newtype (qtc tcon) - (case newTyConCo_maybe tcon of - Just co -> qtc co - Nothing -> pprPanic ("MkExternalCore: newtype tcon\ - should have a coercion: ") (ppr tcon)) + (qcc (newTyConCo tcon)) (map make_tbind tyvars) (make_ty (snd (newTyConRhs tcon))) | otherwise = @@ -93,6 +93,8 @@ qtc :: TyCon -> C.Qual C.Tcon qtc = make_con_qid . tyConName +qcc :: CoAxiom -> C.Qual C.Tcon +qcc = make_con_qid . co_ax_name make_cdef :: DataCon -> C.Cdef make_cdef dcon = C.Constr dcon_name existentials tys @@ -141,15 +143,16 @@ make_exp (Lit (MachLabel s _ _)) = return $ C.Label (unpackFS s) make_exp (Lit l) = return $ C.Lit (make_lit l) make_exp (App e (Type t)) = make_exp e >>= (\ b -> return $ C.Appt b (make_ty t)) +make_exp (App _e (Coercion _co)) = error "make_exp (App _ (Coercion _))" -- TODO make_exp (App e1 e2) = do rator <- make_exp e1 rand <- make_exp e2 return $ C.App rator rand -make_exp (Lam v e) | isTyCoVar v = make_exp e >>= (\ b -> +make_exp (Lam v e) | isTyVar v = make_exp e >>= (\ b -> return $ C.Lam (C.Tb (make_tbind v)) b) make_exp (Lam v e) | otherwise = make_exp e >>= (\ b -> return $ C.Lam (C.Vb (make_vbind v)) b) -make_exp (Cast e co) = make_exp e >>= (\ b -> return $ C.Cast b (make_ty co)) +make_exp (Cast e co) = make_exp e >>= (\ b -> return $ C.Cast b (make_co co)) make_exp (Let b e) = do vd <- make_vdef False b body <- make_exp e @@ -169,7 +172,7 @@ (map make_tbind tbs) (map make_vbind vbs) newE - where (tbs,vbs) = span isTyCoVar vs + where (tbs,vbs) = span isTyVar vs make_alt (LitAlt l,_,e) = make_exp e >>= (return . (C.Alit (make_lit l))) make_alt (DEFAULT,[],e) = make_exp e >>= (return . C.Adefault) -- This should never happen, as the DEFAULT alternative binds no variables, @@ -228,29 +231,12 @@ make_ty' (PredTy p) = make_ty (predTypeRep p) make_tyConApp :: TyCon -> [Type] -> C.Ty -make_tyConApp tc [t1, t2] | tc == transCoercionTyCon = - C.TransCoercion (make_ty t1) (make_ty t2) -make_tyConApp tc [t] | tc == symCoercionTyCon = - C.SymCoercion (make_ty t) -make_tyConApp tc [t1, t2] | tc == unsafeCoercionTyCon = - C.UnsafeCoercion (make_ty t1) (make_ty t2) -make_tyConApp tc [t] | tc == leftCoercionTyCon = - C.LeftCoercion (make_ty t) -make_tyConApp tc [t] | tc == rightCoercionTyCon = - C.RightCoercion (make_ty t) -make_tyConApp tc [t1, t2] | tc == instCoercionTyCon = - C.InstCoercion (make_ty t1) (make_ty t2) --- this fails silently if we have an application --- of a wired-in coercion tycon to the wrong number of args. --- Not great... make_tyConApp tc ts = foldl C.Tapp (C.Tcon (qtc tc)) (map make_ty ts) - make_kind :: Kind -> C.Kind -make_kind (PredTy p) | isEqPred p = C.Keq (make_ty t1) (make_ty t2) - where (t1, t2) = getEqPredTys p +make_kind (PredTy (EqPred t1 t2)) = C.Keq (make_ty t1) (make_ty t2) make_kind (FunTy k1 k2) = C.Karrow (make_kind k1) (make_kind k2) make_kind k | isLiftedTypeKind k = C.Klifted @@ -298,6 +284,25 @@ make_con_qid :: Name -> C.Qual C.Id make_con_qid = make_qid False False +make_co :: Coercion -> C.Ty +make_co (Refl ty) = make_ty ty +make_co (TyConAppCo tc cos) = make_conAppCo (qtc tc) cos +make_co (AppCo c1 c2) = C.Tapp (make_co c1) (make_co c2) +make_co (ForAllCo tv co) = C.Tforall (make_tbind tv) (make_co co) +make_co (CoVarCo cv) = C.Tvar (make_var_id (coVarName cv)) +make_co (AxiomInstCo cc cos) = make_conAppCo (qcc cc) cos +make_co (UnsafeCo t1 t2) = C.UnsafeCoercion (make_ty t1) (make_ty t2) +make_co (SymCo co) = C.SymCoercion (make_co co) +make_co (TransCo c1 c2) = C.TransCoercion (make_co c1) (make_co c2) +make_co (NthCo d co) = C.NthCoercion d (make_co co) +make_co (InstCo co ty) = C.InstCoercion (make_co co) (make_ty ty) + +-- Used for both tycon app coercions and axiom instantiations. +make_conAppCo :: C.Qual C.Tcon -> [Coercion] -> C.Ty +make_conAppCo con cos = + foldl C.Tapp (C.Tcon con) + (map make_co cos) + ------- isALocal :: Name -> CoreM Bool isALocal vName = do diff -Nru ghc-7.0.3/compiler/coreSyn/PprCore.lhs ghc-7.2.1/compiler/coreSyn/PprCore.lhs --- ghc-7.0.3/compiler/coreSyn/PprCore.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/coreSyn/PprCore.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -106,7 +106,9 @@ -- The function adds parens in context that need -- an atomic value (e.g. function args) -ppr_expr add_par (Type ty) = add_par (ptext (sLit "TYPE") <+> ppr ty) -- Wierd +ppr_expr add_par (Type ty) = add_par (ptext (sLit "TYPE") <+> ppr ty) -- Wierd + +ppr_expr add_par (Coercion co) = add_par (ptext (sLit "CO") <+> ppr co) ppr_expr _ (Var name) = ppr name ppr_expr _ (Lit lit) = ppr lit @@ -152,11 +154,27 @@ } ppr_expr add_par (Case expr var ty [(con,args,rhs)]) + | opt_PprCaseAsLet + = add_par $ + sep [sep [ ptext (sLit "let") + <+> char '{' + <+> ppr_case_pat con args + <+> ptext (sLit "~") + <+> ppr_bndr var + , ptext (sLit "<-") + <+> ppr_expr id expr + , char '}' + <+> ptext (sLit "in") + ] + , pprCoreExpr rhs + ] + + | otherwise = add_par $ sep [sep [ptext (sLit "case") <+> pprCoreExpr expr, ifPprDebug (braces (ppr ty)), sep [ptext (sLit "of") <+> ppr_bndr var, - char '{' <+> ppr_case_pat con args] + char '{' <+> ppr_case_pat con args <+> arrow] ], pprCoreExpr rhs, char '}' @@ -170,7 +188,7 @@ <+> pprCoreExpr expr <+> ifPprDebug (braces (ppr ty)), ptext (sLit "of") <+> ppr_bndr var <+> char '{'], - nest 2 (sep (punctuate semi (map pprCoreAlt alts))), + nest 2 (vcat (punctuate semi (map pprCoreAlt alts))), char '}' ] where @@ -218,24 +236,29 @@ pprCoreAlt :: OutputableBndr a => (AltCon, [a] , Expr a) -> SDoc pprCoreAlt (con, args, rhs) - = hang (ppr_case_pat con args) 2 (pprCoreExpr rhs) + = hang (ppr_case_pat con args <+> arrow) 2 (pprCoreExpr rhs) ppr_case_pat :: OutputableBndr a => AltCon -> [a] -> SDoc ppr_case_pat (DataAlt dc) args | isTupleTyCon tc - = tupleParens (tupleTyConBoxity tc) (hsep (punctuate comma (map ppr_bndr args))) <+> arrow + = tupleParens (tupleTyConBoxity tc) (hsep (punctuate comma (map ppr_bndr args))) where ppr_bndr = pprBndr CaseBind tc = dataConTyCon dc ppr_case_pat con args - = ppr con <+> sep (map ppr_bndr args) <+> arrow + = ppr con <+> sep (map ppr_bndr args) where ppr_bndr = pprBndr CaseBind + +-- | Pretty print the argument in a function application. pprArg :: OutputableBndr a => Expr a -> SDoc -pprArg (Type ty) = ptext (sLit "@") <+> pprParendType ty -pprArg expr = pprParendExpr expr +pprArg (Type ty) + | opt_SuppressTypeApplications = empty + | otherwise = ptext (sLit "@") <+> pprParendType ty +pprArg (Coercion co) = ptext (sLit "@~") <+> pprParendCo co +pprArg expr = pprParendExpr expr \end{code} Other printing bits-and-bobs used with the general @pprCoreBinding@ @@ -247,38 +270,40 @@ pprCoreBinder :: BindingSite -> Var -> SDoc pprCoreBinder LetBind binder - | isTyCoVar binder = pprKindedTyVarBndr binder - | otherwise = pprTypedBinder binder $$ + | isTyVar binder = pprKindedTyVarBndr binder + | otherwise = pprTypedLetBinder binder $$ ppIdInfo binder (idInfo binder) -- Lambda bound type variables are preceded by "@" pprCoreBinder bind_site bndr = getPprStyle $ \ sty -> - pprTypedLCBinder bind_site (debugStyle sty) bndr + pprTypedLamBinder bind_site (debugStyle sty) bndr pprUntypedBinder :: Var -> SDoc pprUntypedBinder binder - | isTyCoVar binder = ptext (sLit "@") <+> ppr binder -- NB: don't print kind + | isTyVar binder = ptext (sLit "@") <+> ppr binder -- NB: don't print kind | otherwise = pprIdBndr binder -pprTypedLCBinder :: BindingSite -> Bool -> Var -> SDoc +pprTypedLamBinder :: BindingSite -> Bool -> Var -> SDoc -- For lambda and case binders, show the unfolding info (usually none) -pprTypedLCBinder bind_site debug_on var +pprTypedLamBinder bind_site debug_on var | not debug_on && isDeadBinder var = char '_' | not debug_on, CaseBind <- bind_site = pprUntypedBinder var -- No parens, no kind info - | isTyCoVar var = parens (pprKindedTyVarBndr var) + | opt_SuppressAll = pprUntypedBinder var -- Suppress the signature + | isTyVar var = parens (pprKindedTyVarBndr var) | otherwise = parens (hang (pprIdBndr var) 2 (vcat [ dcolon <+> pprType (idType var), pp_unf])) - where - unf_info = unfoldingInfo (idInfo var) - pp_unf | hasSomeUnfolding unf_info = ptext (sLit "Unf=") <> ppr unf_info - | otherwise = empty + where + unf_info = unfoldingInfo (idInfo var) + pp_unf | hasSomeUnfolding unf_info = ptext (sLit "Unf=") <> ppr unf_info + | otherwise = empty -pprTypedBinder :: Var -> SDoc +pprTypedLetBinder :: Var -> SDoc -- Print binder with a type or kind signature (not paren'd) -pprTypedBinder binder - | isTyCoVar binder = pprKindedTyVarBndr binder - | otherwise = hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder)) +pprTypedLetBinder binder + | isTyVar binder = pprKindedTyVarBndr binder + | opt_SuppressTypeSignatures = pprIdBndr binder + | otherwise = hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder)) pprKindedTyVarBndr :: TyVar -> SDoc -- Print a type variable binder with its kind (but not if *) @@ -297,6 +322,8 @@ pprIdBndrInfo :: IdInfo -> SDoc pprIdBndrInfo info + | opt_SuppressIdInfo = empty + | otherwise = megaSeqIdInfo info `seq` doc -- The seq is useful for poking on black holes where prag_info = inlinePragInfo info @@ -325,6 +352,8 @@ \begin{code} ppIdInfo :: Id -> IdInfo -> SDoc ppIdInfo id info + | opt_SuppressIdInfo = empty + | otherwise = showAttributes [ (True, pp_scope <> ppr (idDetails id)) , (has_arity, ptext (sLit "Arity=") <> int arity) @@ -410,15 +439,10 @@ | otherwise = empty -- Don't print the RHS or we get a quadratic -- blowup in the size of the printout! - -instance Outputable e => Outputable (DFunArg e) where - ppr (DFunPolyArg e) = braces (ppr e) - ppr (DFunConstArg e) = ppr e - ppr (DFunLamArg i) = char '<' <> int i <> char '>' \end{code} ----------------------------------------------------- --- Rules +-- Rules ----------------------------------------------------- \begin{code} @@ -433,11 +457,24 @@ = ptext (sLit "Built in rule for") <+> ppr fn <> colon <+> doubleQuotes (ftext name) pprRule (Rule { ru_name = name, ru_act = act, ru_fn = fn, - ru_bndrs = tpl_vars, ru_args = tpl_args, - ru_rhs = rhs }) + ru_bndrs = tpl_vars, ru_args = tpl_args, + ru_rhs = rhs }) = hang (doubleQuotes (ftext name) <+> ppr act) - 4 (sep [ptext (sLit "forall") <+> braces (sep (map pprTypedBinder tpl_vars)), - nest 2 (ppr fn <+> sep (map pprArg tpl_args)), - nest 2 (ptext (sLit "=") <+> pprCoreExpr rhs) - ]) + 4 (sep [ptext (sLit "forall") <+> + sep (map (pprCoreBinder LambdaBind) tpl_vars) <> dot, + nest 2 (ppr fn <+> sep (map pprArg tpl_args)), + nest 2 (ptext (sLit "=") <+> pprCoreExpr rhs) + ]) +\end{code} + +----------------------------------------------------- +-- Vectorisation declarations +----------------------------------------------------- + +\begin{code} +instance Outputable CoreVect where + ppr (Vect var Nothing) = ptext (sLit "VECTORISE SCALAR") <+> ppr var + ppr (Vect var (Just e)) = hang (ptext (sLit "VECTORISE") <+> ppr var <+> char '=') + 4 (pprCoreExpr e) + ppr (NoVect var) = ptext (sLit "NOVECTORISE") <+> ppr var \end{code} diff -Nru ghc-7.0.3/compiler/coreSyn/PprExternalCore.lhs ghc-7.2.1/compiler/coreSyn/PprExternalCore.lhs --- ghc-7.0.3/compiler/coreSyn/PprExternalCore.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/coreSyn/PprExternalCore.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -106,10 +106,8 @@ sep [text "%sym", paty t] pty (UnsafeCoercion t1 t2) = sep [text "%unsafe", paty t1, paty t2] -pty (LeftCoercion t) = - sep [text "%left", paty t] -pty (RightCoercion t) = - sep [text "%right", paty t] +pty (NthCoercion n t) = + sep [text "%nth", int n, paty t] pty (InstCoercion t1 t2) = sep [text "%inst", paty t1, paty t2] pty t = pbty t diff -Nru ghc-7.0.3/compiler/deSugar/Check.lhs ghc-7.2.1/compiler/deSugar/Check.lhs --- ghc-7.0.3/compiler/deSugar/Check.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/deSugar/Check.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -27,10 +27,10 @@ import PrelNames import TyCon import Type -import Unify( dataConCannotMatch ) import SrcLoc import UniqSet import Util +import BasicTypes import Outputable import FastString \end{code} @@ -112,7 +112,8 @@ -- if there are view patterns, just give up - don't know what the function is check qs = (untidy_warns, shadowed_eqns) where - (warns, used_nos) = check' ([1..] `zip` map tidy_eqn qs) + tidy_qs = map tidy_eqn qs + (warns, used_nos) = check' ([1..] `zip` tidy_qs) untidy_warns = map untidy_exhaustive warns shadowed_eqns = [eqn | (eqn,i) <- qs `zip` [1..], not (i `elementOfUniqSet` used_nos)] @@ -436,14 +437,14 @@ -- It doesn't matter which one, because they will only be compared -- with other HsLits gotten in the same way get_lit (LitPat lit) = Just lit -get_lit (NPat (OverLit { ol_val = HsIntegral i}) mb _) = Just (HsIntPrim (mb_neg mb i)) -get_lit (NPat (OverLit { ol_val = HsFractional f }) mb _) = Just (HsFloatPrim (mb_neg mb f)) +get_lit (NPat (OverLit { ol_val = HsIntegral i}) mb _) = Just (HsIntPrim (mb_neg negate mb i)) +get_lit (NPat (OverLit { ol_val = HsFractional f }) mb _) = Just (HsFloatPrim (mb_neg negateFractionalLit mb f)) get_lit (NPat (OverLit { ol_val = HsIsString s }) _ _) = Just (HsStringPrim s) get_lit _ = Nothing -mb_neg :: Num a => Maybe b -> a -> a -mb_neg Nothing v = v -mb_neg (Just _) v = -v +mb_neg :: (a -> a) -> Maybe b -> a -> a +mb_neg _ Nothing v = v +mb_neg negate (Just _) v = negate v get_unused_cons :: [Pat Id] -> [DataCon] get_unused_cons used_cons = ASSERT( not (null used_cons) ) unused_cons @@ -643,7 +644,7 @@ -- Finally the ones that are sure to succeed, or which are covered by the checking algorithm might_fail_pat (LazyPat _) = False -- Always succeeds -might_fail_pat _ = False -- VarPat, VarPatOut, WildPat, LitPat, NPat, TypePat +might_fail_pat _ = False -- VarPat, WildPat, LitPat, NPat -------------- might_fail_lpat :: LPat Id -> Bool @@ -657,7 +658,6 @@ tidy_pat :: Pat Id -> Pat Id tidy_pat pat@(WildPat _) = pat tidy_pat (VarPat id) = WildPat (idType id) -tidy_pat (VarPatOut id _) = WildPat (idType id) -- Ignore the bindings tidy_pat (ParPat p) = tidy_pat (unLoc p) tidy_pat (LazyPat p) = WildPat (hsLPatType p) -- For overlap and exhaustiveness checking -- purposes, a ~pat is like a wildcard @@ -672,8 +672,6 @@ tidy_pat (NPlusKPat id _ _ _) = WildPat (idType (unLoc id)) tidy_pat (ViewPat _ _ ty) = WildPat ty -tidy_pat (NPat lit mb_neg eq) = tidyNPat lit mb_neg eq - tidy_pat pat@(ConPatOut { pat_con = L _ id, pat_args = ps }) = pat { pat_args = tidy_con id ps } @@ -697,16 +695,18 @@ where arity = length ps --- Unpack string patterns fully, so we can see when they overlap with --- each other, or even explicit lists of Chars. -tidy_pat (LitPat lit) +tidy_pat (NPat lit mb_neg eq) = tidyNPat tidy_lit_pat lit mb_neg eq +tidy_pat (LitPat lit) = tidy_lit_pat lit + +tidy_lit_pat :: HsLit -> Pat Id +-- Unpack string patterns fully, so we can see when they +-- overlap with each other, or even explicit lists of Chars. +tidy_lit_pat lit | HsString s <- lit - = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mk_char_lit c, pat] stringTy) + = unLoc $ foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c, pat] stringTy) (mkPrefixConPat nilDataCon [] stringTy) (unpackFS s) | otherwise = tidyLitPat lit - where - mk_char_lit c = mkPrefixConPat charDataCon [nlLitPat (HsCharPrim c)] charTy ----------------- tidy_con :: DataCon -> HsConPatDetails Id -> HsConPatDetails Id diff -Nru ghc-7.0.3/compiler/deSugar/Coverage.lhs ghc-7.2.1/compiler/deSugar/Coverage.lhs --- ghc-7.0.3/compiler/deSugar/Coverage.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/deSugar/Coverage.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -5,7 +5,7 @@ \section[Coverage]{@coverage@: the main function} \begin{code} -module Coverage (addCoverageTicksToBinds) where +module Coverage (addCoverageTicksToBinds, hpcInitCode) where import HsSyn import Module @@ -25,6 +25,8 @@ import TyCon import MonadUtils import Maybes +import CLabel +import Util import Data.Array import System.Directory ( createDirectoryIfMissing ) @@ -99,7 +101,7 @@ createDirectoryIfMissing True hpc_mod_dir modTime <- getModificationTime orig_file2 let entries' = [ (hpcPos, box) - | (span,_,box) <- entries, hpcPos <- [mkHpcPos span] ] + | (span,_,_,box) <- entries, hpcPos <- [mkHpcPos span] ] when (length entries' /= tickBoxCount st) $ do panic "the number of .mix entries are inconsistent" let hashNo = mixHash orig_file2 modTime tabStop entries' @@ -113,13 +115,16 @@ breakArray <- newBreakArray $ length entries let locsTicks = listArray (0,tickBoxCount st-1) - [ span | (span,_,_) <- entries ] + [ span | (span,_,_,_) <- entries ] varsTicks = listArray (0,tickBoxCount st-1) - [ vars | (_,vars,_) <- entries ] + [ vars | (_,_,vars,_) <- entries ] + declsTicks= listArray (0,tickBoxCount st-1) + [ decls | (_,decls,_,_) <- entries ] modBreaks = emptyModBreaks { modBreaks_flags = breakArray , modBreaks_locs = locsTicks , modBreaks_vars = varsTicks + , modBreaks_decls = declsTicks } doIfSet_dyn dflags Opt_D_dump_hpc $ do @@ -296,10 +301,9 @@ liftM2 HsLet (addTickHsLocalBinds binds) -- to think about: !patterns. (addTickLHsExprNeverOrAlways e) -addTickHsExpr (HsDo cxt stmts last_exp srcloc) = do - (stmts', last_exp') <- addTickLStmts' forQual stmts - (addTickLHsExpr last_exp) - return (HsDo cxt stmts' last_exp' srcloc) +addTickHsExpr (HsDo cxt stmts srcloc) + = do { (stmts', _) <- addTickLStmts' forQual stmts (return ()) + ; return (HsDo cxt stmts' srcloc) } where forQual = case cxt of ListComp -> Just $ BinBox QualBinBox @@ -405,55 +409,58 @@ addTickLStmts' :: (Maybe (Bool -> BoxLabel)) -> [LStmt Id] -> TM a -> TM ([LStmt Id], a) addTickLStmts' isGuard lstmts res - = bindLocals binders $ do - lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts - a <- res - return (lstmts', a) - where - binders = collectLStmtsBinders lstmts + = bindLocals (collectLStmtsBinders lstmts) $ + do { lstmts' <- mapM (liftL (addTickStmt isGuard)) lstmts + ; a <- res + ; return (lstmts', a) } addTickStmt :: (Maybe (Bool -> BoxLabel)) -> Stmt Id -> TM (Stmt Id) +addTickStmt _isGuard (LastStmt e ret) = do + liftM2 LastStmt + (addTickLHsExpr e) + (addTickSyntaxExpr hpcSrcSpan ret) addTickStmt _isGuard (BindStmt pat e bind fail) = do liftM4 BindStmt (addTickLPat pat) (addTickLHsExprAlways e) (addTickSyntaxExpr hpcSrcSpan bind) (addTickSyntaxExpr hpcSrcSpan fail) -addTickStmt isGuard (ExprStmt e bind' ty) = do - liftM3 ExprStmt +addTickStmt isGuard (ExprStmt e bind' guard' ty) = do + liftM4 ExprStmt (addTick isGuard e) (addTickSyntaxExpr hpcSrcSpan bind') + (addTickSyntaxExpr hpcSrcSpan guard') (return ty) addTickStmt _isGuard (LetStmt binds) = do liftM LetStmt (addTickHsLocalBinds binds) -addTickStmt isGuard (ParStmt pairs) = do - liftM ParStmt +addTickStmt isGuard (ParStmt pairs mzipExpr bindExpr returnExpr) = do + liftM4 ParStmt (mapM (addTickStmtAndBinders isGuard) pairs) - -addTickStmt isGuard (TransformStmt stmts ids usingExpr maybeByExpr) = do - liftM4 TransformStmt - (addTickLStmts isGuard stmts) - (return ids) - (addTickLHsExprAlways usingExpr) - (addTickMaybeByLHsExpr maybeByExpr) - -addTickStmt isGuard (GroupStmt stmts binderMap by using) = do - liftM4 GroupStmt - (addTickLStmts isGuard stmts) - (return binderMap) - (fmapMaybeM addTickLHsExprAlways by) - (fmapEitherM addTickLHsExprAlways (addTickSyntaxExpr hpcSrcSpan) using) + (addTickSyntaxExpr hpcSrcSpan mzipExpr) + (addTickSyntaxExpr hpcSrcSpan bindExpr) + (addTickSyntaxExpr hpcSrcSpan returnExpr) + +addTickStmt isGuard stmt@(TransStmt { trS_stmts = stmts + , trS_by = by, trS_using = using + , trS_ret = returnExpr, trS_bind = bindExpr + , trS_fmap = liftMExpr }) = do + t_s <- addTickLStmts isGuard stmts + t_y <- fmapMaybeM addTickLHsExprAlways by + t_u <- addTickLHsExprAlways using + t_f <- addTickSyntaxExpr hpcSrcSpan returnExpr + t_b <- addTickSyntaxExpr hpcSrcSpan bindExpr + t_m <- addTickSyntaxExpr hpcSrcSpan liftMExpr + return $ stmt { trS_stmts = t_s, trS_by = t_y, trS_using = t_u + , trS_ret = t_f, trS_bind = t_b, trS_fmap = t_m } addTickStmt isGuard stmt@(RecStmt {}) = do { stmts' <- addTickLStmts isGuard (recS_stmts stmt) ; ret' <- addTickSyntaxExpr hpcSrcSpan (recS_ret_fn stmt) ; mfix' <- addTickSyntaxExpr hpcSrcSpan (recS_mfix_fn stmt) ; bind' <- addTickSyntaxExpr hpcSrcSpan (recS_bind_fn stmt) - ; dicts' <- addTickEvBinds (recS_dicts stmt) ; return (stmt { recS_stmts = stmts', recS_ret_fn = ret' - , recS_mfix_fn = mfix', recS_bind_fn = bind' - , recS_dicts = dicts' }) } + , recS_mfix_fn = mfix', recS_bind_fn = bind' }) } addTick :: Maybe (Bool -> BoxLabel) -> LHsExpr Id -> TM (LHsExpr Id) addTick isGuard e | Just fn <- isGuard = addBinTickLHsExpr fn e @@ -466,12 +473,6 @@ (addTickLStmts isGuard stmts) (return ids) -addTickMaybeByLHsExpr :: Maybe (LHsExpr Id) -> TM (Maybe (LHsExpr Id)) -addTickMaybeByLHsExpr maybeByExpr = - case maybeByExpr of - Nothing -> return Nothing - Just byExpr -> addTickLHsExprAlways byExpr >>= (return . Just) - addTickHsLocalBinds :: HsLocalBinds Id -> TM (HsLocalBinds Id) addTickHsLocalBinds (HsValBinds binds) = liftM HsValBinds @@ -529,8 +530,8 @@ addTickHsCmd :: HsCmd Id -> TM (HsCmd Id) addTickHsCmd (HsLam matchgroup) = liftM HsLam (addTickCmdMatchGroup matchgroup) -addTickHsCmd (HsApp e1 e2) = - liftM2 HsApp (addTickLHsExprNever e1) (addTickLHsExpr e2) +addTickHsCmd (HsApp c e) = + liftM2 HsApp (addTickLHsCmd c) (addTickLHsExpr e) addTickHsCmd (OpApp e1 c2 fix c3) = liftM4 OpApp (addTickLHsExpr e1) @@ -552,10 +553,10 @@ liftM2 HsLet (addTickHsLocalBinds binds) -- to think about: !patterns. (addTickLHsCmd c) -addTickHsCmd (HsDo cxt stmts last_exp srcloc) = do - (stmts', last_exp') <- addTickLCmdStmts' stmts (addTickLHsCmd last_exp) - return (HsDo cxt stmts' last_exp' srcloc) - where +addTickHsCmd (HsDo cxt stmts srcloc) + = do { (stmts', _) <- addTickLCmdStmts' stmts (return ()) + ; return (HsDo cxt stmts' srcloc) } + addTickHsCmd (HsArrApp e1 e2 ty1 arr_ty lr) = liftM5 HsArrApp (addTickLHsExpr e1) @@ -593,9 +594,12 @@ binders = collectLocalBinders local_binds addTickCmdGRHS :: GRHS Id -> TM (GRHS Id) -addTickCmdGRHS (GRHS stmts cmd) = do - (stmts',expr') <- addTickLCmdStmts' stmts (addTickLHsCmd cmd) - return $ GRHS stmts' expr' +-- The *guards* are *not* Cmds, although the body is +-- C.f. addTickGRHS for the BinBox stuff +addTickCmdGRHS (GRHS stmts cmd) + = do { (stmts',expr') <- addTickLStmts' (Just $ BinBox $ GuardBinBox) + stmts (addTickLHsCmd cmd) + ; return $ GRHS stmts' expr' } addTickLCmdStmts :: [LStmt Id] -> TM [LStmt Id] addTickLCmdStmts stmts = do @@ -618,10 +622,15 @@ (addTickLHsCmd c) (return bind) (return fail) -addTickCmdStmt (ExprStmt c bind' ty) = do - liftM3 ExprStmt +addTickCmdStmt (LastStmt c ret) = do + liftM2 LastStmt (addTickLHsCmd c) - (return bind') + (addTickSyntaxExpr hpcSrcSpan ret) +addTickCmdStmt (ExprStmt c bind' guard' ty) = do + liftM4 ExprStmt + (addTickLHsCmd c) + (addTickSyntaxExpr hpcSrcSpan bind') + (addTickSyntaxExpr hpcSrcSpan guard') (return ty) addTickCmdStmt (LetStmt binds) = do liftM LetStmt @@ -637,9 +646,6 @@ -- Others should never happen in a command context. addTickCmdStmt stmt = pprPanic "addTickHsCmd" (ppr stmt) -addTickEvBinds :: TcEvBinds -> TM TcEvBinds -addTickEvBinds x = return x -- No coverage testing for dictionary binding - addTickHsRecordBinds :: HsRecordBinds Id -> TM (HsRecordBinds Id) addTickHsRecordBinds (HsRecFields fields dd) = do { fields' <- mapM process fields @@ -771,11 +777,11 @@ sameFileName pos (do e <- m; return (L pos e)) $ do (fvs, e) <- getFreeVars m - TM $ \ _env st -> + TM $ \ env st -> let c = tickBoxCount st ids = occEnvElts fvs mes = mixEntries st - me = (pos, map (nameOccName.idName) ids, boxLabel) + me = (pos, declPath env, map (nameOccName.idName) ids, boxLabel) in ( L pos (HsTick c ids (L pos e)) , fvs @@ -788,8 +794,11 @@ allocATickBox :: BoxLabel -> SrcSpan -> FreeVars -> TM (Maybe (Int,[Id])) allocATickBox boxLabel pos fvs | isGoodSrcSpan' pos = sameFileName pos - (return Nothing) $ TM $ \ _env st -> - let me = (pos, map (nameOccName.idName) ids, boxLabel) + (return Nothing) $ TM $ \ env st -> + let mydecl_path + | null (declPath env), TopLevelBox x <- boxLabel = x + | otherwise = declPath env + me = (pos, mydecl_path, map (nameOccName.idName) ids, boxLabel) c = tickBoxCount st mes = mixEntries st ids = occEnvElts fvs @@ -806,10 +815,10 @@ | isGoodSrcSpan' pos = do e <- m - TM $ \ _env st -> - let meT = (pos,[],boxLabel True) - meF = (pos,[],boxLabel False) - meE = (pos,[],ExpBox False) + TM $ \ env st -> + let meT = (pos,declPath env, [],boxLabel True) + meF = (pos,declPath env, [],boxLabel False) + meE = (pos,declPath env, [],ExpBox False) c = tickBoxCount st mes = mixEntries st in @@ -823,26 +832,21 @@ allocBinTickBox _boxLabel pos m = do e <- m; return (L pos e) isGoodSrcSpan' :: SrcSpan -> Bool -isGoodSrcSpan' pos - | not (isGoodSrcSpan pos) = False - | start == end = False - | otherwise = True - where - start = srcSpanStart pos - end = srcSpanEnd pos +isGoodSrcSpan' pos@(RealSrcSpan _) = srcSpanStart pos /= srcSpanEnd pos +isGoodSrcSpan' (UnhelpfulSpan _) = False mkHpcPos :: SrcSpan -> HpcPos -mkHpcPos pos - | not (isGoodSrcSpan' pos) = panic "bad source span; expected such spans to be filtered out" - | otherwise = hpcPos - where - start = srcSpanStart pos - end = srcSpanEnd pos - hpcPos = toHpcPos ( srcLocLine start - , srcLocCol start - , srcLocLine end - , srcLocCol end - 1 - ) +mkHpcPos pos@(RealSrcSpan s) + | isGoodSrcSpan' pos = toHpcPos (srcSpanStartLine s, + srcSpanStartCol s, + srcSpanEndLine s, + srcSpanEndCol s - 1) + -- the end column of a SrcSpan is one + -- greater than the last column of the + -- span (see SrcLoc), whereas HPC + -- expects to the column range to be + -- inclusive, hence we subtract one above. +mkHpcPos _ = panic "bad source span; expected such spans to be filtered out" hpcSrcSpan :: SrcSpan hpcSrcSpan = mkGeneralSrcSpan (fsLit "Haskell Program Coverage internals") @@ -858,7 +862,7 @@ \begin{code} -type MixEntry_ = (SrcSpan, [OccName], BoxLabel) +type MixEntry_ = (SrcSpan, [String], [OccName], BoxLabel) -- For the hash value, we hash everything: the file name, -- the timestamp of the original source file, the tab stop, @@ -870,3 +874,56 @@ mixHash file tm tabstop entries = fromIntegral $ hashString (show $ Mix file tm 0 tabstop entries) \end{code} + +%************************************************************************ +%* * +%* initialisation +%* * +%************************************************************************ + +Each module compiled with -fhpc declares an initialisation function of +the form `hpc_init_()`, which is emitted into the _stub.c file +and annotated with __attribute__((constructor)) so that it gets +executed at startup time. + +The function's purpose is to call hs_hpc_module to register this +module with the RTS, and it looks something like this: + +static void hpc_init_Main(void) __attribute__((constructor)); +static void hpc_init_Main(void) +{extern StgWord64 _hpc_tickboxes_Main_hpc[]; + hs_hpc_module("Main",8,1150288664,_hpc_tickboxes_Main_hpc);} + +\begin{code} +hpcInitCode :: Module -> HpcInfo -> SDoc +hpcInitCode _ (NoHpcInfo {}) = empty +hpcInitCode this_mod (HpcInfo tickCount hashNo) + = vcat + [ text "static void hpc_init_" <> ppr this_mod + <> text "(void) __attribute__((constructor));" + , text "static void hpc_init_" <> ppr this_mod <> text "(void)" + , braces (vcat [ + ptext (sLit "extern StgWord64 ") <> tickboxes <> + ptext (sLit "[]") <> semi, + ptext (sLit "hs_hpc_module") <> + parens (hcat (punctuate comma [ + doubleQuotes full_name_str, + int tickCount, -- really StgWord32 + int hashNo, -- really StgWord32 + tickboxes + ])) <> semi + ]) + ] + where + tickboxes = pprCLabel (mkHpcTicksLabel $ this_mod) + + module_name = hcat (map (text.charToC) $ + bytesFS (moduleNameFS (Module.moduleName this_mod))) + package_name = hcat (map (text.charToC) $ + bytesFS (packageIdFS (modulePackageId this_mod))) + full_name_str + | modulePackageId this_mod == mainPackageId + = module_name + | otherwise + = package_name <> char '/' <> module_name +\end{code} diff -Nru ghc-7.0.3/compiler/deSugar/Desugar.lhs ghc-7.2.1/compiler/deSugar/Desugar.lhs --- ghc-7.0.3/compiler/deSugar/Desugar.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/deSugar/Desugar.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -61,7 +61,8 @@ tcg_imports = imports, tcg_exports = exports, tcg_keep = keep_var, - tcg_rdr_env = rdr_env, + tcg_th_splice_used = tc_splice_used, + tcg_rdr_env = rdr_env, tcg_fix_env = fix_env, tcg_inst_env = inst_env, tcg_fam_inst_env = fam_inst_env, @@ -69,12 +70,13 @@ tcg_anns = anns, tcg_binds = binds, tcg_imp_specs = imp_specs, - tcg_ev_binds = ev_binds, - tcg_fords = fords, - tcg_rules = rules, - tcg_insts = insts, - tcg_fam_insts = fam_insts, - tcg_hpc = other_hpc_info }) + tcg_ev_binds = ev_binds, + tcg_fords = fords, + tcg_rules = rules, + tcg_vects = vects, + tcg_insts = insts, + tcg_fam_insts = fam_insts, + tcg_hpc = other_hpc_info }) = do { let dflags = hsc_dflags hsc_env ; showPass dflags "Desugar" @@ -88,7 +90,7 @@ <- case target of HscNothing -> return (emptyMessages, - Just ([], nilOL, [], NoStubs, hpcInfo, emptyModBreaks)) + Just ([], nilOL, [], [], NoStubs, hpcInfo, emptyModBreaks)) _ -> do (binds_cvr,ds_hpc_info, modBreaks) <- if (opt_Hpc @@ -98,55 +100,64 @@ (typeEnvTyCons type_env) binds else return (binds, hpcInfo, emptyModBreaks) initDs hsc_env mod rdr_env type_env $ do - do { ds_ev_binds <- dsEvBinds ev_binds - ; core_prs <- dsTopLHsBinds auto_scc binds_cvr + do { ds_ev_binds <- dsEvBinds ev_binds + ; core_prs <- dsTopLHsBinds auto_scc binds_cvr ; (spec_prs, spec_rules) <- dsImpSpecs imp_specs - ; (ds_fords, foreign_prs) <- dsForeigns fords - ; rules <- mapMaybeM dsRule rules - ; return ( ds_ev_binds + ; (ds_fords, foreign_prs) <- dsForeigns fords + ; ds_rules <- mapMaybeM dsRule rules + ; ds_vects <- mapM dsVect vects + ; let hpc_init + | opt_Hpc = hpcInitCode mod ds_hpc_info + | otherwise = empty + ; return ( ds_ev_binds , foreign_prs `appOL` core_prs `appOL` spec_prs - , spec_rules ++ rules - , ds_fords, ds_hpc_info, modBreaks) } - - ; case mb_res of { - Nothing -> return (msgs, Nothing) ; - Just (ds_ev_binds, all_prs, all_rules, ds_fords,ds_hpc_info, modBreaks) -> do - - { -- Add export flags to bindings - keep_alive <- readIORef keep_var - ; let (rules_for_locals, rules_for_imps) + , spec_rules ++ ds_rules, ds_vects + , ds_fords `appendStubC` hpc_init + , ds_hpc_info, modBreaks) } + + ; case mb_res of { + Nothing -> return (msgs, Nothing) ; + Just (ds_ev_binds, all_prs, all_rules, vects0, ds_fords, ds_hpc_info, modBreaks) -> do + + { -- Add export flags to bindings + keep_alive <- readIORef keep_var + ; let (rules_for_locals, rules_for_imps) = partition isLocalRule all_rules final_prs = addExportFlagsAndRules target - export_set keep_alive rules_for_locals (fromOL all_prs) + export_set keep_alive rules_for_locals (fromOL all_prs) final_pgm = combineEvBinds ds_ev_binds final_prs - -- Notice that we put the whole lot in a big Rec, even the foreign binds - -- When compiling PrelFloat, which defines data Float = F# Float# - -- we want F# to be in scope in the foreign marshalling code! - -- You might think it doesn't matter, but the simplifier brings all top-level - -- things into the in-scope set before simplifying; so we get no unfolding for F#! + -- Notice that we put the whole lot in a big Rec, even the foreign binds + -- When compiling PrelFloat, which defines data Float = F# Float# + -- we want F# to be in scope in the foreign marshalling code! + -- You might think it doesn't matter, but the simplifier brings all top-level + -- things into the in-scope set before simplifying; so we get no unfolding for F#! - -- Lint result if necessary, and print + -- Lint result if necessary, and print ; dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared, before opt" $ (vcat [ pprCoreBindings final_pgm , pprRules rules_for_imps ]) - ; (ds_binds, ds_rules_for_imps) <- simpleOptPgm dflags final_pgm rules_for_imps - -- The simpleOptPgm gets rid of type - -- bindings plus any stupid dead code + ; (ds_binds, ds_rules_for_imps, ds_vects) + <- simpleOptPgm dflags mod final_pgm rules_for_imps vects0 + -- The simpleOptPgm gets rid of type + -- bindings plus any stupid dead code - ; endPass dflags CoreDesugar ds_binds ds_rules_for_imps + ; endPass dflags CoreDesugar ds_binds ds_rules_for_imps ; let used_names = mkUsedNames tcg_env - ; deps <- mkDependencies tcg_env + ; deps <- mkDependencies tcg_env + + ; used_th <- readIORef tc_splice_used - ; let mod_guts = ModGuts { + ; let mod_guts = ModGuts { mg_module = mod, mg_boot = isHsBoot hsc_src, mg_exports = exports, mg_deps = deps, mg_used_names = used_names, - mg_dir_imps = imp_mods imports, + mg_used_th = used_th, + mg_dir_imps = imp_mods imports, mg_rdr_env = rdr_env, mg_fix_env = fix_env, mg_warns = warns, @@ -161,7 +172,9 @@ mg_foreign = ds_fords, mg_hpc_info = ds_hpc_info, mg_modBreaks = modBreaks, - mg_vect_info = noVectInfo + mg_vect_decls = ds_vects, + mg_vect_info = noVectInfo, + mg_trust_pkg = imp_trust_own_pkg imports } ; return (msgs, Just mod_guts) }}} @@ -337,8 +350,9 @@ = putSrcSpanDs loc $ do { let bndrs' = [var | RuleBndr (L _ var) <- vars] - ; lhs' <- unsetOptM Opt_EnableRewriteRules $ - dsLExpr lhs -- Note [Desugaring RULE left hand sides] + ; lhs' <- unsetDOptM Opt_EnableRewriteRules $ + unsetWOptM Opt_WarnIdentities $ + dsLExpr lhs -- Note [Desugaring RULE left hand sides] ; rhs' <- dsLExpr rhs @@ -359,6 +373,7 @@ ; return (Just rule) } } } \end{code} + Note [Desugaring RULE left hand sides] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ For the LHS of a RULE we do *not* want to desugar @@ -370,3 +385,25 @@ That keeps the desugaring of list comprehensions simple too. + +Nor do we want to warn of conversion identities on the LHS; +the rule is precisly to optimise them: + {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-} + + +%************************************************************************ +%* * +%* Desugaring vectorisation declarations +%* * +%************************************************************************ + +\begin{code} +dsVect :: LVectDecl Id -> DsM CoreVect +dsVect (L loc (HsVect (L _ v) rhs)) + = putSrcSpanDs loc $ + do { rhs' <- fmapMaybeM dsLExpr rhs + ; return $ Vect v rhs' + } +dsVect (L _loc (HsNoVect (L _ v))) + = return $ NoVect v +\end{code} diff -Nru ghc-7.0.3/compiler/deSugar/DsArrows.lhs ghc-7.2.1/compiler/deSugar/DsArrows.lhs --- ghc-7.0.3/compiler/deSugar/DsArrows.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/deSugar/DsArrows.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -541,8 +541,8 @@ core_body, exprFreeVars core_binds `intersectVarSet` local_vars) -dsCmd ids local_vars env_ids [] res_ty (HsDo _ctxt stmts body _) - = dsCmdDo ids local_vars env_ids res_ty stmts body +dsCmd ids local_vars env_ids [] res_ty (HsDo _ctxt stmts _) + = dsCmdDo ids local_vars env_ids res_ty stmts -- A |- e :: forall e. a1 (e*ts1) t1 -> ... an (e*tsn) tn -> a (e*ts) t -- A | xs |- ci :: [tsi] ti @@ -618,7 +618,6 @@ -- so don't pull on it too early -> Type -- return type of the statement -> [LStmt Id] -- statements to desugar - -> LHsExpr Id -- body -> DsM (CoreExpr, -- desugared expression IdSet) -- set of local vars that occur free @@ -626,15 +625,17 @@ -- -------------------------- -- A | xs |- do { c } :: [] t -dsCmdDo ids local_vars env_ids res_ty [] body +dsCmdDo _ _ _ _ [] = panic "dsCmdDo" + +dsCmdDo ids local_vars env_ids res_ty [L _ (LastStmt body _)] = dsLCmd ids local_vars env_ids [] res_ty body -dsCmdDo ids local_vars env_ids res_ty (stmt:stmts) body = do +dsCmdDo ids local_vars env_ids res_ty (stmt:stmts) = do let bound_vars = mkVarSet (collectLStmtBinders stmt) local_vars' = local_vars `unionVarSet` bound_vars (core_stmts, _, env_ids') <- fixDs (\ ~(_,_,env_ids') -> do - (core_stmts, fv_stmts) <- dsCmdDo ids local_vars' env_ids' res_ty stmts body + (core_stmts, fv_stmts) <- dsCmdDo ids local_vars' env_ids' res_ty stmts return (core_stmts, fv_stmts, varSetElems fv_stmts)) (core_stmt, fv_stmt) <- dsCmdLStmt ids local_vars env_ids env_ids' stmt return (do_compose ids @@ -674,7 +675,7 @@ -- ---> arr (\ (xs) -> ((xs1),(xs'))) >>> first c >>> -- arr snd >>> ss -dsCmdStmt ids local_vars env_ids out_ids (ExprStmt cmd _ c_ty) = do +dsCmdStmt ids local_vars env_ids out_ids (ExprStmt cmd _ _ c_ty) = do (core_cmd, fv_cmd, env_ids1) <- dsfixCmd ids local_vars [] c_ty cmd core_mux <- matchEnvStack env_ids [] (mkCorePairExpr (mkBigCoreVarTup env_ids1) (mkBigCoreVarTup out_ids)) @@ -779,8 +780,8 @@ dsCmdStmt ids local_vars env_ids out_ids (RecStmt { recS_stmts = stmts, recS_later_ids = later_ids, recS_rec_ids = rec_ids - , recS_rec_rets = rhss, recS_dicts = _binds }) = do - let -- ToDo: ****** binds not desugared; ROSS PLEASE FIX ******** + , recS_rec_rets = rhss }) = do + let env2_id_set = mkVarSet out_ids `minusVarSet` mkVarSet later_ids env2_ids = varSetElems env2_id_set env2_ty = mkBigCoreVarTupTy env2_ids @@ -1041,8 +1042,6 @@ = go pat where go (VarPat var) = var : bndrs - go (VarPatOut var bs) = var : collectEvBinders bs - ++ bndrs go (WildPat _) = bndrs go (LazyPat pat) = collectl pat bndrs go (BangPat pat) = collectl pat bndrs @@ -1063,7 +1062,6 @@ go (SigPatIn pat _) = collectl pat bndrs go (SigPatOut pat _) = collectl pat bndrs - go (TypePat _) = bndrs go (CoPat _ pat _) = collectl (noLoc pat) bndrs go (ViewPat _ pat _) = collectl pat bndrs go p@(QuasiQuotePat {}) = pprPanic "collectl/go" (ppr p) diff -Nru ghc-7.0.3/compiler/deSugar/DsBinds.lhs ghc-7.2.1/compiler/deSugar/DsBinds.lhs --- ghc-7.0.3/compiler/deSugar/DsBinds.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/deSugar/DsBinds.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -11,7 +11,7 @@ \begin{code} module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec, - dsHsWrapper, dsTcEvBinds, dsEvBinds, wrapDsEvBinds, + dsHsWrapper, dsTcEvBinds, dsEvBinds, wrapDsEvBinds, DsEvBind(..), AutoScc(..) ) where @@ -36,6 +36,7 @@ import TcType import Type +import Coercion import TysPrim ( anyTypeOfKind ) import CostCentre import Module @@ -56,7 +57,6 @@ import Bag import BasicTypes hiding ( TopLevel ) import FastString --- import StaticFlags ( opt_DsMultiTyVar ) import Util import MonadUtils @@ -98,7 +98,7 @@ ; let var' | inline_regardless = var `setIdUnfolding` mkCompulsoryUnfolding core_expr' | otherwise = var - ; return (unitOL (var', core_expr')) } + ; return (unitOL (makeCorePair var' False 0 core_expr')) } dsHsBind auto_scc (FunBind { fun_id = L _ fun, fun_matches = matches , fun_co_fn = co_fn, fun_tick = tick @@ -231,8 +231,8 @@ free_vars_of :: EvTerm -> [EvVar] free_vars_of (EvId v) = [v] - free_vars_of (EvCast v co) = v : varSetElems (tyVarsOfType co) - free_vars_of (EvCoercion co) = varSetElems (tyVarsOfType co) + free_vars_of (EvCast v co) = v : varSetElems (tyCoVarsOfCo co) + free_vars_of (EvCoercion co) = varSetElems (tyCoVarsOfCo co) free_vars_of (EvDFunApp _ _ vs) = vs free_vars_of (EvSuperClass d _) = [d] @@ -248,7 +248,7 @@ (arg_tys, _) = splitFunTys rho bndrs = ex_tvs ++ map mk_wild_pred (theta `zip` [0..]) ++ map mkWildValBinder arg_tys - mk_wild_pred (p, i) | i==n = ASSERT( p `tcEqPred` (coVarPred co_var)) + mk_wild_pred (p, i) | i==n = ASSERT( p `eqPred` (coVarPred co_var)) co_var | otherwise = mkWildEvBinder p @@ -264,7 +264,7 @@ dsEvTerm (EvId v) = Var v dsEvTerm (EvCast v co) = Cast (Var v) co dsEvTerm (EvDFunApp df tys vars) = Var df `mkTyApps` tys `mkVarApps` vars -dsEvTerm (EvCoercion co) = Type co +dsEvTerm (EvCoercion co) = Coercion co dsEvTerm (EvSuperClass d n) = ASSERT( isClassPred (classSCTheta cls !! n) ) -- We can only select *dictionary* superclasses @@ -493,6 +493,15 @@ -> Located TcSpecPrag -> DsM (Maybe (OrdList (Id,CoreExpr), CoreRule)) dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl)) + | isJust (isClassOpId_maybe poly_id) + = putSrcSpanDs loc $ + do { warnDs (ptext (sLit "Ignoring useless SPECIALISE pragma for class method selector") + <+> quotes (ppr poly_id)) + ; return Nothing } -- There is no point in trying to specialise a class op + -- Moreover, classops don't (currently) have an inl_sat arity set + -- (it would be Just 0) and that in turn makes makeCorePair bleat + + | otherwise = putSrcSpanDs loc $ do { let poly_name = idName poly_id ; spec_name <- newLocalName poly_name @@ -508,8 +517,11 @@ ; let spec_id = mkLocalId spec_name spec_ty `setInlinePragma` inl_prag `setIdUnfolding` spec_unf - inl_prag | isDefaultInlinePragma spec_inl = idInlinePragma poly_id - | otherwise = spec_inl + inl_prag | not (isDefaultInlinePragma spec_inl) = spec_inl + | not is_local_id -- See Note [Specialising imported functions] + -- in OccurAnal + , isStrongLoopBreaker (idOccInfo poly_id) = neverInlinePragma + | otherwise = idInlinePragma poly_id -- Get the INLINE pragma from SPECIALISE declaration, or, -- failing that, from the original Id @@ -598,17 +610,13 @@ bad_shape_msg = hang (ptext (sLit "RULE left-hand side too complicated to desugar")) 2 (ppr opt_lhs) - dead_msg bndr = hang (ptext (sLit "Forall'd") <+> pp_bndr bndr - <+> ptext (sLit "is not bound in RULE lhs")) + dead_msg bndr = hang (sep [ ptext (sLit "Forall'd") <+> pp_bndr bndr + , ptext (sLit "is not bound in RULE lhs")]) 2 (ppr opt_lhs) pp_bndr bndr - | isTyVar bndr = ptext (sLit "type variable") <+> ppr bndr - | isCoVar bndr = ptext (sLit "coercion variable") <+> ppr bndr - | isDictId bndr = ptext (sLit "constraint") <+> ppr (get_pred bndr) - | otherwise = ptext (sLit "variable") <+> ppr bndr - - get_pred b = ASSERT( isId b ) expectJust "decomposeRuleLhs" - (tcSplitPredTy_maybe (idType b)) + | isTyVar bndr = ptext (sLit "type variable") <+> quotes (ppr bndr) + | isEvVar bndr = ptext (sLit "constraint") <+> quotes (ppr (evVarPred bndr)) + | otherwise = ptext (sLit "variable") <+> quotes (ppr bndr) \end{code} Note [Simplifying the left-hand side of a RULE] @@ -635,7 +643,6 @@ NB: tcSimplifyRuleLhs is very careful not to generate complicated dictionary expressions that we might have to match - Note [Matching seqId] ~~~~~~~~~~~~~~~~~~~ The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack diff -Nru ghc-7.0.3/compiler/deSugar/DsCCall.lhs ghc-7.2.1/compiler/deSugar/DsCCall.lhs --- ghc-7.0.3/compiler/deSugar/DsCCall.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/deSugar/DsCCall.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -273,7 +273,7 @@ ; let io_data_con = head (tyConDataCons io_tycon) toIOCon = dataConWrapId io_data_con - wrap the_call = mkCoerceI (mkSymCoI co) $ + wrap the_call = mkCoerce (mkSymCo co) $ mkApps (Var toIOCon) [ Type io_res_ty, Lam state_id $ @@ -372,7 +372,7 @@ -- Recursive newtypes | Just (rep_ty, co) <- splitNewTypeRepCo_maybe result_ty = do (maybe_ty, wrapper) <- resultWrapper rep_ty - return (maybe_ty, \e -> mkCoerce (mkSymCoercion co) (wrapper e)) + return (maybe_ty, \e -> mkCoerce (mkSymCo co) (wrapper e)) -- The type might contain foralls (eg. for dummy type arguments, -- referring to 'Ptr a' is legal). diff -Nru ghc-7.0.3/compiler/deSugar/DsExpr.lhs ghc-7.2.1/compiler/deSugar/DsExpr.lhs --- ghc-7.0.3/compiler/deSugar/DsExpr.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/deSugar/DsExpr.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -34,7 +34,6 @@ #endif import HsSyn -import TcHsSyn -- NB: The desugarer, which straddles the source and Core worlds, sometimes -- needs to see source types @@ -50,8 +49,8 @@ import StaticFlags import CostCentre import Id -import Var import VarSet +import VarEnv import DataCon import TysWiredIn import BasicTypes @@ -218,13 +217,17 @@ dsExpr :: HsExpr Id -> DsM CoreExpr dsExpr (HsPar e) = dsLExpr e dsExpr (ExprWithTySigOut e _) = dsLExpr e -dsExpr (HsVar var) = return (Var var) +dsExpr (HsVar var) = return (varToCoreExpr var) -- See Note [Desugaring vars] dsExpr (HsIPVar ip) = return (Var (ipNameName ip)) dsExpr (HsLit lit) = dsLit lit dsExpr (HsOverLit lit) = dsOverLit lit -dsExpr (HsWrap co_fn e) = do { co_fn' <- dsHsWrapper co_fn - ; e' <- dsExpr e - ; return (co_fn' e') } + +dsExpr (HsWrap co_fn e) + = do { co_fn' <- dsHsWrapper co_fn + ; e' <- dsExpr e + ; warn_id <- woptDs Opt_WarnIdentities + ; when warn_id $ warnAboutIdentities e' co_fn' + ; return (co_fn' e') } dsExpr (NegApp expr neg_expr) = App <$> dsExpr neg_expr <*> dsLExpr expr @@ -236,6 +239,22 @@ = mkCoreAppDs <$> dsLExpr fun <*> dsLExpr arg \end{code} +Note [Desugaring vars] +~~~~~~~~~~~~~~~~~~~~~~ +In one situation we can get a *coercion* variable in a HsVar, namely +the support method for an equality superclass: + class (a~b) => C a b where ... + instance (blah) => C (T a) (T b) where .. +Then we get + $dfCT :: forall ab. blah => C (T a) (T b) + $dfCT ab blah = MkC ($c$p1C a blah) ($cop a blah) + + $c$p1C :: forall ab. blah => (T a ~ T b) + $c$p1C ab blah = let ...; g :: T a ~ T b = ... } in g + +That 'g' in the 'in' part is an evidence variable, and when +converting to core it must become a CO. + Operator sections. At first it looks as if we can convert \begin{verbatim} (expr op) @@ -322,28 +341,12 @@ -- We need the `ListComp' form to use `deListComp' (rather than the "do" form) -- because the interpretation of `stmts' depends on what sort of thing it is. -- -dsExpr (HsDo ListComp stmts body result_ty) - = -- Special case for list comprehensions - dsListComp stmts body elt_ty - where - [elt_ty] = tcTyConAppArgs result_ty - -dsExpr (HsDo DoExpr stmts body result_ty) - = dsDo stmts body result_ty - -dsExpr (HsDo GhciStmt stmts body result_ty) - = dsDo stmts body result_ty - -dsExpr (HsDo ctxt@(MDoExpr tbl) stmts body result_ty) - = do { (meth_binds, tbl') <- dsSyntaxTable tbl - ; core_expr <- dsMDo ctxt tbl' stmts body result_ty - ; return (mkLets meth_binds core_expr) } - -dsExpr (HsDo PArrComp stmts body result_ty) - = -- Special case for array comprehensions - dsPArrComp (map unLoc stmts) body elt_ty - where - [elt_ty] = tcTyConAppArgs result_ty +dsExpr (HsDo ListComp stmts res_ty) = dsListComp stmts res_ty +dsExpr (HsDo PArrComp stmts _) = dsPArrComp (map unLoc stmts) +dsExpr (HsDo DoExpr stmts _) = dsDo stmts +dsExpr (HsDo GhciStmt stmts _) = dsDo stmts +dsExpr (HsDo MDoExpr stmts _) = dsDo stmts +dsExpr (HsDo MonadComp stmts _) = dsMonadComp stmts dsExpr (HsIf mb_fun guard_expr then_expr else_expr) = do { pred <- dsLExpr guard_expr @@ -367,11 +370,11 @@ -- singletonP x1 +:+ ... +:+ singletonP xn -- dsExpr (ExplicitPArr ty []) = do - emptyP <- dsLookupGlobalId emptyPName + emptyP <- dsLookupDPHId emptyPName return (Var emptyP `App` Type ty) dsExpr (ExplicitPArr ty xs) = do - singletonP <- dsLookupGlobalId singletonPName - appP <- dsLookupGlobalId appPName + singletonP <- dsLookupDPHId singletonPName + appP <- dsLookupDPHId appPName xs' <- mapM dsLExpr xs return . foldr1 (binary appP) $ map (unary singletonP) xs' where @@ -526,12 +529,12 @@ mk_alt upd_fld_env con = do { let (univ_tvs, ex_tvs, eq_spec, - eq_theta, dict_theta, arg_tys, _) = dataConFullSig con + theta, arg_tys, _) = dataConFullSig con subst = mkTopTvSubst (univ_tvs `zip` in_inst_tys) -- I'm not bothering to clone the ex_tvs ; eqs_vars <- mapM newPredVarDs (substTheta subst (eqSpecPreds eq_spec)) - ; theta_vars <- mapM newPredVarDs (substTheta subst (eq_theta ++ dict_theta)) + ; theta_vars <- mapM newPredVarDs (substTheta subst theta) ; arg_ids <- newSysLocalsDs (substTys subst arg_tys) ; let val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg (dataConFieldLabels con) arg_ids @@ -542,21 +545,21 @@ wrap = mkWpEvVarApps theta_vars `WpCompose` mkWpTyApps (mkTyVarTys ex_tvs) `WpCompose` mkWpTyApps [ty | (tv, ty) <- univ_tvs `zip` out_inst_tys - , isNothing (lookupTyVar wrap_subst tv) ] + , not (tv `elemVarEnv` wrap_subst) ] rhs = foldl (\a b -> nlHsApp a b) inst_con val_args -- Tediously wrap the application in a cast -- Note [Update for GADTs] wrapped_rhs | null eq_spec = rhs | otherwise = mkLHsWrap (WpCast wrap_co) rhs - wrap_co = mkTyConApp tycon [ lookup tv ty - | (tv,ty) <- univ_tvs `zip` out_inst_tys] - lookup univ_tv ty = case lookupTyVar wrap_subst univ_tv of - Just ty' -> ty' - Nothing -> ty - wrap_subst = mkTopTvSubst [ (tv,mkSymCoercion (mkTyVarTy co_var)) - | ((tv,_),co_var) <- eq_spec `zip` eqs_vars ] - + wrap_co = mkTyConAppCo tycon [ lookup tv ty + | (tv,ty) <- univ_tvs `zip` out_inst_tys] + lookup univ_tv ty = case lookupVarEnv wrap_subst univ_tv of + Just co' -> co' + Nothing -> mkReflCo ty + wrap_subst = mkVarEnv [ (tv, mkSymCo (mkCoVarCo co_var)) + | ((tv,_),co_var) <- eq_spec `zip` eqs_vars ] + pat = noLoc $ ConPatOut { pat_con = noLoc con, pat_tvs = ex_tvs , pat_dicts = eqs_vars ++ theta_vars , pat_binds = emptyTcEvBinds @@ -596,7 +599,7 @@ dsExpr (HsBinTick ixT ixF e) = do e2 <- dsLExpr e - do { ASSERT(exprType e2 `coreEqType` boolTy) + do { ASSERT(exprType e2 `eqType` boolTy) mkBinaryTickBox ixT ixF e2 } \end{code} @@ -707,25 +710,20 @@ Haskell 98 report: \begin{code} -dsDo :: [LStmt Id] - -> LHsExpr Id - -> Type -- Type of the whole expression - -> DsM CoreExpr - -dsDo stmts body result_ty +dsDo :: [LStmt Id] -> DsM CoreExpr +dsDo stmts = goL stmts where - -- result_ty must be of the form (m b) - (m_ty, _b_ty) = tcSplitAppTy result_ty - - goL [] = dsLExpr body - goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts) + goL [] = panic "dsDo" + goL (L loc stmt:lstmts) = putSrcSpanDs loc (go loc stmt lstmts) - go _ (ExprStmt rhs then_expr _) stmts + go _ (LastStmt body _) stmts + = ASSERT( null stmts ) dsLExpr body + -- The 'return' op isn't used for 'do' expressions + + go _ (ExprStmt rhs then_expr _ _) stmts = do { rhs2 <- dsLExpr rhs - ; case tcSplitAppTy_maybe (exprType rhs2) of - Just (container_ty, returning_ty) -> warnDiscardedDoBindings rhs container_ty returning_ty - _ -> return () + ; warnDiscardedDoBindings rhs (exprType rhs2) ; then_expr2 <- dsExpr then_expr ; rest <- goL stmts ; return (mkApps then_expr2 [rhs2, rest]) } @@ -749,146 +747,77 @@ go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids , recS_rec_ids = rec_ids, recS_ret_fn = return_op , recS_mfix_fn = mfix_op, recS_bind_fn = bind_op - , recS_rec_rets = rec_rets, recS_dicts = _ev_binds }) stmts + , recS_rec_rets = rec_rets, recS_ret_ty = body_ty }) stmts = ASSERT( length rec_ids > 0 ) - ASSERT( isEmptyTcEvBinds _ev_binds ) -- No method binds goL (new_bind_stmt : stmts) where - -- returnE <- dsExpr return_id - -- mfixE <- dsExpr mfix_id - new_bind_stmt = L loc $ BindStmt (mkLHsPatTup later_pats) mfix_app - bind_op - noSyntaxExpr -- Tuple cannot fail + new_bind_stmt = L loc $ BindStmt (mkLHsPatTup later_pats) + mfix_app bind_op + noSyntaxExpr -- Tuple cannot fail tup_ids = rec_ids ++ filterOut (`elem` rec_ids) later_ids + tup_ty = mkBoxedTupleTy (map idType tup_ids) -- Deals with singleton case rec_tup_pats = map nlVarPat tup_ids later_pats = rec_tup_pats rets = map noLoc rec_rets + mfix_app = nlHsApp (noLoc mfix_op) mfix_arg + mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body] + (mkFunTy tup_ty body_ty)) + mfix_pat = noLoc $ LazyPat $ mkLHsPatTup rec_tup_pats + body = noLoc $ HsDo DoExpr (rec_stmts ++ [ret_stmt]) body_ty + ret_app = nlHsApp (noLoc return_op) (mkLHsTupleExpr rets) + ret_stmt = noLoc $ mkLastStmt ret_app + -- This LastStmt will be desugared with dsDo, + -- which ignores the return_op in the LastStmt, + -- so we must apply the return_op explicitly - mfix_app = nlHsApp (noLoc mfix_op) mfix_arg - mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body] - (mkFunTy tup_ty body_ty)) - mfix_pat = noLoc $ LazyPat $ mkLHsPatTup rec_tup_pats - body = noLoc $ HsDo DoExpr rec_stmts return_app body_ty - return_app = nlHsApp (noLoc return_op) (mkLHsTupleExpr rets) - body_ty = mkAppTy m_ty tup_ty - tup_ty = mkBoxedTupleTy (map idType tup_ids) -- Deals with singleton case - +handle_failure :: LPat Id -> MatchResult -> SyntaxExpr Id -> DsM CoreExpr -- In a do expression, pattern-match failure just calls -- the monadic 'fail' rather than throwing an exception - handle_failure pat match fail_op - | matchCanFail match - = do { fail_op' <- dsExpr fail_op - ; fail_msg <- mkStringExpr (mk_fail_msg pat) - ; extractMatchResult match (App fail_op' fail_msg) } - | otherwise - = extractMatchResult match (error "It can't fail") +handle_failure pat match fail_op + | matchCanFail match + = do { fail_op' <- dsExpr fail_op + ; fail_msg <- mkStringExpr (mk_fail_msg pat) + ; extractMatchResult match (App fail_op' fail_msg) } + | otherwise + = extractMatchResult match (error "It can't fail") mk_fail_msg :: Located e -> String mk_fail_msg pat = "Pattern match failure in do expression at " ++ showSDoc (ppr (getLoc pat)) \end{code} -Translation for RecStmt's: ------------------------------ -We turn (RecStmt [v1,..vn] stmts) into: - - (v1,..,vn) <- mfix (\~(v1,..vn). do stmts - return (v1,..vn)) - -\begin{code} -dsMDo :: HsStmtContext Name - -> [(Name,Id)] - -> [LStmt Id] - -> LHsExpr Id - -> Type -- Type of the whole expression - -> DsM CoreExpr - -dsMDo ctxt tbl stmts body result_ty - = goL stmts - where - goL [] = dsLExpr body - goL ((L loc stmt):lstmts) = putSrcSpanDs loc (go loc stmt lstmts) - - (m_ty, b_ty) = tcSplitAppTy result_ty -- result_ty must be of the form (m b) - mfix_id = lookupEvidence tbl mfixName - return_id = lookupEvidence tbl returnMName - bind_id = lookupEvidence tbl bindMName - then_id = lookupEvidence tbl thenMName - fail_id = lookupEvidence tbl failMName - go _ (LetStmt binds) stmts - = do { rest <- goL stmts - ; dsLocalBinds binds rest } +%************************************************************************ +%* * + Warning about identities +%* * +%************************************************************************ - go _ (ExprStmt rhs _ rhs_ty) stmts - = do { rhs2 <- dsLExpr rhs - ; warnDiscardedDoBindings rhs m_ty rhs_ty - ; rest <- goL stmts - ; return (mkApps (Var then_id) [Type rhs_ty, Type b_ty, rhs2, rest]) } - - go _ (BindStmt pat rhs _ _) stmts - = do { body <- goL stmts - ; var <- selectSimpleMatchVarL pat - ; match <- matchSinglePat (Var var) (StmtCtxt ctxt) pat - result_ty (cantFailMatchResult body) - ; fail_msg <- mkStringExpr (mk_fail_msg pat) - ; let fail_expr = mkApps (Var fail_id) [Type b_ty, fail_msg] - ; match_code <- extractMatchResult match fail_expr - - ; rhs' <- dsLExpr rhs - ; return (mkApps (Var bind_id) [Type (hsLPatType pat), Type b_ty, - rhs', Lam var match_code]) } - - go loc (RecStmt { recS_stmts = rec_stmts, recS_later_ids = later_ids - , recS_rec_ids = rec_ids, recS_rec_rets = rec_rets - , recS_dicts = _ev_binds }) stmts - = ASSERT( length rec_ids > 0 ) - ASSERT( length rec_ids == length rec_rets ) - ASSERT( isEmptyTcEvBinds _ev_binds ) - pprTrace "dsMDo" (ppr later_ids) $ - goL (new_bind_stmt : stmts) - where - new_bind_stmt = L loc $ mkBindStmt (mk_tup_pat later_pats) mfix_app - - -- Remove the later_ids that appear (without fancy coercions) - -- in rec_rets, because there's no need to knot-tie them separately - -- See Note [RecStmt] in HsExpr - later_ids' = filter (`notElem` mono_rec_ids) later_ids - mono_rec_ids = [ id | HsVar id <- rec_rets ] - - mfix_app = nlHsApp (nlHsTyApp mfix_id [tup_ty]) mfix_arg - mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body] - (mkFunTy tup_ty body_ty)) - - -- The rec_tup_pat must bind the rec_ids only; remember that the - -- trimmed_laters may share the same Names - -- Meanwhile, the later_pats must bind the later_vars - rec_tup_pats = map mk_wild_pat later_ids' ++ map nlVarPat rec_ids - later_pats = map nlVarPat later_ids' ++ map mk_later_pat rec_ids - rets = map nlHsVar later_ids' ++ map noLoc rec_rets - - mfix_pat = noLoc $ LazyPat $ mk_tup_pat rec_tup_pats - body = noLoc $ HsDo ctxt rec_stmts return_app body_ty - body_ty = mkAppTy m_ty tup_ty - tup_ty = mkBoxedTupleTy (map idType (later_ids' ++ rec_ids)) -- Deals with singleton case - - return_app = nlHsApp (nlHsTyApp return_id [tup_ty]) - (mkLHsTupleExpr rets) - - mk_wild_pat :: Id -> LPat Id - mk_wild_pat v = noLoc $ WildPat $ idType v - - mk_later_pat :: Id -> LPat Id - mk_later_pat v | v `elem` later_ids' = mk_wild_pat v - | otherwise = nlVarPat v - - mk_tup_pat :: [LPat Id] -> LPat Id - mk_tup_pat [p] = p - mk_tup_pat ps = noLoc $ mkVanillaTuplePat ps Boxed +Warn about functions that convert between one type and another +when the to- and from- types are the same. Then it's probably +(albeit not definitely) the identity +\begin{code} +warnAboutIdentities :: CoreExpr -> (CoreExpr -> CoreExpr) -> DsM () +warnAboutIdentities (Var v) co_fn + | idName v `elem` conversionNames + , let fun_ty = exprType (co_fn (Var v)) + , Just (arg_ty, res_ty) <- splitFunTy_maybe fun_ty + , arg_ty `eqType` res_ty -- So we are converting ty -> ty + = warnDs (vcat [ ptext (sLit "Call of") <+> ppr v <+> dcolon <+> ppr fun_ty + , nest 2 $ ptext (sLit "can probably be omitted") + , parens (ptext (sLit "Use -fno-warn-identities to suppress this messsage)")) + ]) +warnAboutIdentities _ _ = return () + +conversionNames :: [Name] +conversionNames + = [ toIntegerName, toRationalName + , fromIntegralName, realToFracName ] + -- We can't easily add fromIntegerName, fromRationalName, + -- becuase they are generated by literals \end{code} - %************************************************************************ %* * \subsection{Errors and contexts} @@ -897,30 +826,34 @@ \begin{code} -- Warn about certain types of values discarded in monadic bindings (#3263) -warnDiscardedDoBindings :: LHsExpr Id -> Type -> Type -> DsM () -warnDiscardedDoBindings rhs container_ty returning_ty = do { - -- Warn about discarding non-() things in 'monadic' binding - ; warn_unused <- doptDs Opt_WarnUnusedDoBind - ; if warn_unused && not (returning_ty `tcEqType` unitTy) - then warnDs (unusedMonadBind rhs returning_ty) - else do { - -- Warn about discarding m a things in 'monadic' binding of the same type, - -- but only if we didn't already warn due to Opt_WarnUnusedDoBind - ; warn_wrong <- doptDs Opt_WarnWrongDoBind - ; case tcSplitAppTy_maybe returning_ty of - Just (returning_container_ty, _) -> when (warn_wrong && container_ty `tcEqType` returning_container_ty) $ - warnDs (wrongMonadBind rhs returning_ty) - _ -> return () } } +warnDiscardedDoBindings :: LHsExpr Id -> Type -> DsM () +warnDiscardedDoBindings rhs rhs_ty + | Just (m_ty, elt_ty) <- tcSplitAppTy_maybe rhs_ty + = do { -- Warn about discarding non-() things in 'monadic' binding + ; warn_unused <- woptDs Opt_WarnUnusedDoBind + ; if warn_unused && not (isUnitTy elt_ty) + then warnDs (unusedMonadBind rhs elt_ty) + else + -- Warn about discarding m a things in 'monadic' binding of the same type, + -- but only if we didn't already warn due to Opt_WarnUnusedDoBind + do { warn_wrong <- woptDs Opt_WarnWrongDoBind + ; case tcSplitAppTy_maybe elt_ty of + Just (elt_m_ty, _) | warn_wrong, m_ty `eqType` elt_m_ty + -> warnDs (wrongMonadBind rhs elt_ty) + _ -> return () } } + + | otherwise -- RHS does have type of form (m ty), which is wierd + = return () -- but at lesat this warning is irrelevant unusedMonadBind :: LHsExpr Id -> Type -> SDoc -unusedMonadBind rhs returning_ty - = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr returning_ty <> dot $$ +unusedMonadBind rhs elt_ty + = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr elt_ty <> dot $$ ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$ ptext (sLit "or by using the flag -fno-warn-unused-do-bind") wrongMonadBind :: LHsExpr Id -> Type -> SDoc -wrongMonadBind rhs returning_ty - = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr returning_ty <> dot $$ +wrongMonadBind rhs elt_ty + = ptext (sLit "A do-notation statement discarded a result of type") <+> ppr elt_ty <> dot $$ ptext (sLit "Suppress this warning by saying \"_ <- ") <> ppr rhs <> ptext (sLit "\",") $$ ptext (sLit "or by using the flag -fno-warn-wrong-do-bind") \end{code} diff -Nru ghc-7.0.3/compiler/deSugar/DsForeign.lhs ghc-7.2.1/compiler/deSugar/DsForeign.lhs --- ghc-7.0.3/compiler/deSugar/DsForeign.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/deSugar/DsForeign.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -28,7 +28,6 @@ import TyCon import Coercion import TcType -import Var import CmmExpr import CmmUtils @@ -41,6 +40,8 @@ import SrcLoc import Outputable import FastString +import DynFlags +import Platform import Config import Constants import OrdList @@ -140,7 +141,7 @@ IsFunction _ -> IsData (resTy, foRhs) <- resultWrapper ty - ASSERT(fromJust resTy `coreEqType` addrPrimTy) -- typechecker ensures this + ASSERT(fromJust resTy `eqType` addrPrimTy) -- typechecker ensures this let rhs = foRhs (Lit (MachLabel cid stdcall_info fod)) stdcall_info = fun_type_arg_stdcall_info cconv ty @@ -299,8 +300,9 @@ Nothing -> return (orig_res_ty, False) -- The function returns t + dflags <- getDOpts return $ - mkFExportCBits ext_name + mkFExportCBits dflags ext_name (if isDyn then Nothing else Just fn_id) fe_arg_tys res_ty is_IO_res_ty cconv \end{code} @@ -382,9 +384,9 @@ ccall_adj <- dsCCall adjustor adj_args PlayRisky (mkTyConApp io_tc [res_ty]) -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback - let io_app = mkLams tvs $ - Lam cback $ - mkCoerceI (mkSymCoI co) $ + let io_app = mkLams tvs $ + Lam cback $ + mkCoerce (mkSymCo co) $ mkApps (Var bindIOId) [ Type stable_ptr_ty , Type res_ty @@ -421,7 +423,8 @@ using the hugs/ghc rts invocation API. \begin{code} -mkFExportCBits :: FastString +mkFExportCBits :: DynFlags + -> FastString -> Maybe Id -- Just==static, Nothing==dynamic -> [Type] -> Type @@ -432,7 +435,7 @@ String, -- the argument reps Int -- total size of arguments ) -mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc +mkFExportCBits dflags c_nm maybe_target arg_htys res_hty is_IO_res_ty cc = (header_bits, c_bits, type_string, sum [ widthInBytes (typeWidth rep) | (_,_,_,rep) <- aug_arg_info] -- all the args -- NB. the calculation here isn't strictly speaking correct. @@ -475,7 +478,7 @@ -- add some auxiliary args; the stable ptr in the wrapper case, and -- a slot for the dummy return address in the wrapper + ccall case aug_arg_info - | isNothing maybe_target = stable_ptr_arg : insertRetAddr cc arg_info + | isNothing maybe_target = stable_ptr_arg : insertRetAddr dflags cc arg_info | otherwise = arg_info stable_ptr_arg = @@ -483,7 +486,7 @@ typeCmmType (mkStablePtrPrimTy alphaTy)) -- stuff to do with the return type of the C function - res_hty_is_unit = res_hty `coreEqType` unitTy -- Look through any newtypes + res_hty_is_unit = res_hty `eqType` unitTy -- Look through any newtypes cResType | res_hty_is_unit = text "void" | otherwise = showStgType res_hty @@ -628,26 +631,27 @@ Just (tc,_) -> tc Nothing -> pprPanic "DsForeign.typeTyCon" (ppr ty) -insertRetAddr :: CCallConv -> [(SDoc, SDoc, Type, CmmType)] - -> [(SDoc, SDoc, Type, CmmType)] -#if !defined(x86_64_TARGET_ARCH) -insertRetAddr CCallConv args = ret_addr_arg : args -insertRetAddr _ args = args -#else --- On x86_64 we insert the return address after the 6th --- integer argument, because this is the point at which we --- need to flush a register argument to the stack (See rts/Adjustor.c for --- details). -insertRetAddr CCallConv args = go 0 args - where go :: Int -> [(SDoc, SDoc, Type, CmmType)] - -> [(SDoc, SDoc, Type, CmmType)] - go 6 args = ret_addr_arg : args - go n (arg@(_,_,_,rep):args) - | cmmEqType_ignoring_ptrhood rep b64 = arg : go (n+1) args - | otherwise = arg : go n args - go _ [] = [] -insertRetAddr _ args = args -#endif +insertRetAddr :: DynFlags -> CCallConv + -> [(SDoc, SDoc, Type, CmmType)] + -> [(SDoc, SDoc, Type, CmmType)] +insertRetAddr dflags CCallConv args + = case platformArch (targetPlatform dflags) of + ArchX86_64 -> + -- On x86_64 we insert the return address after the 6th + -- integer argument, because this is the point at which we + -- need to flush a register argument to the stack (See + -- rts/Adjustor.c for details). + let go :: Int -> [(SDoc, SDoc, Type, CmmType)] + -> [(SDoc, SDoc, Type, CmmType)] + go 6 args = ret_addr_arg : args + go n (arg@(_,_,_,rep):args) + | cmmEqType_ignoring_ptrhood rep b64 = arg : go (n+1) args + | otherwise = arg : go n args + go _ [] = [] + in go 0 args + _ -> + ret_addr_arg : args +insertRetAddr _ _ args = args ret_addr_arg :: (SDoc, SDoc, Type, CmmType) ret_addr_arg = (text "original_return_addr", text "void*", undefined, @@ -675,7 +679,7 @@ -- e.g. 'W' is a signed 32-bit integer. primTyDescChar :: Type -> Char primTyDescChar ty - | ty `coreEqType` unitTy = 'v' + | ty `eqType` unitTy = 'v' | otherwise = case typePrimRep (getPrimTyOf ty) of IntRep -> signed_word diff -Nru ghc-7.0.3/compiler/deSugar/DsGRHSs.lhs ghc-7.2.1/compiler/deSugar/DsGRHSs.lhs --- ghc-7.0.3/compiler/deSugar/DsGRHSs.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/deSugar/DsGRHSs.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -75,7 +75,7 @@ dsGRHS :: HsMatchContext Name -> [Pat Id] -> Type -> LGRHS Id -> DsM MatchResult dsGRHS hs_ctx _ rhs_ty (L _ (GRHS guards rhs)) - = matchGuards (map unLoc guards) hs_ctx rhs rhs_ty + = matchGuards (map unLoc guards) (PatGuard hs_ctx) rhs rhs_ty \end{code} @@ -87,7 +87,7 @@ \begin{code} matchGuards :: [Stmt Id] -- Guard - -> HsMatchContext Name -- Context + -> HsStmtContext Name -- Context -> LHsExpr Id -- RHS -> Type -- Type of RHS of guard -> DsM MatchResult @@ -106,11 +106,11 @@ -- NB: The success of this clause depends on the typechecker not -- wrapping the 'otherwise' in empty HsTyApp or HsWrap constructors -- If it does, you'll get bogus overlap warnings -matchGuards (ExprStmt e _ _ : stmts) ctx rhs rhs_ty +matchGuards (ExprStmt e _ _ _ : stmts) ctx rhs rhs_ty | Just addTicks <- isTrueLHsExpr e = do match_result <- matchGuards stmts ctx rhs rhs_ty return (adjustMatchResultDs addTicks match_result) -matchGuards (ExprStmt expr _ _ : stmts) ctx rhs rhs_ty = do +matchGuards (ExprStmt expr _ _ _ : stmts) ctx rhs rhs_ty = do match_result <- matchGuards stmts ctx rhs rhs_ty pred_expr <- dsLExpr expr return (mkGuardedMatchResult pred_expr match_result) @@ -126,7 +126,7 @@ matchGuards (BindStmt pat bind_rhs _ _ : stmts) ctx rhs rhs_ty = do match_result <- matchGuards stmts ctx rhs rhs_ty core_rhs <- dsLExpr bind_rhs - matchSinglePat core_rhs ctx pat rhs_ty match_result + matchSinglePat core_rhs (StmtCtxt ctx) pat rhs_ty match_result isTrueLHsExpr :: LHsExpr Id -> Maybe (CoreExpr -> DsM CoreExpr) diff -Nru ghc-7.0.3/compiler/deSugar/DsListComp.lhs ghc-7.2.1/compiler/deSugar/DsListComp.lhs --- ghc-7.0.3/compiler/deSugar/DsListComp.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/deSugar/DsListComp.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -3,9 +3,10 @@ % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -Desugaring list comprehensions and array comprehensions +Desugaring list comprehensions, monad comprehensions and array comprehensions \begin{code} +{-# LANGUAGE NamedFieldPuns #-} {-# 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 @@ -13,11 +14,11 @@ -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings -- for details -module DsListComp ( dsListComp, dsPArrComp ) where +module DsListComp ( dsListComp, dsPArrComp, dsMonadComp ) where #include "HsVersions.h" -import {-# SOURCE #-} DsExpr ( dsLExpr, dsLocalBinds ) +import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLocalBinds ) import HsSyn import TcHsSyn @@ -37,6 +38,7 @@ import SrcLoc import Outputable import FastString +import TcType \end{code} List comprehensions may be desugared in one of two ways: ``ordinary'' @@ -47,12 +49,14 @@ \begin{code} dsListComp :: [LStmt Id] - -> LHsExpr Id - -> Type -- Type of list elements + -> Type -- Type of entire list -> DsM CoreExpr -dsListComp lquals body elt_ty = do +dsListComp lquals res_ty = do dflags <- getDOptsDs let quals = map unLoc lquals + elt_ty = case tcTyConAppArgs res_ty of + [elt_ty] -> elt_ty + _ -> pprPanic "dsListComp" (ppr res_ty $$ ppr lquals) if not (dopt Opt_EnableRewriteRules dflags) || dopt Opt_IgnoreInterfacePragmas dflags -- Either rules are switched off, or we are ignoring what there are; @@ -60,8 +64,8 @@ -- Wadler-style desugaring || isParallelComp quals -- Foldr-style desugaring can't handle parallel list comprehensions - then deListComp quals body (mkNilExpr elt_ty) - else mkBuildExpr elt_ty (\(c, _) (n, _) -> dfListComp c n quals body) + then deListComp quals (mkNilExpr elt_ty) + else mkBuildExpr elt_ty (\(c, _) (n, _) -> dfListComp c n quals) -- Foldr/build should be enabled, so desugar -- into foldrs and builds @@ -72,92 +76,69 @@ -- mix of possibly a single element in length, so we do this to leave the possibility open isParallelComp = any isParallelStmt - isParallelStmt (ParStmt _) = True - isParallelStmt _ = False + isParallelStmt (ParStmt _ _ _ _) = True + isParallelStmt _ = False -- This function lets you desugar a inner list comprehension and a list of the binders -- of that comprehension that we need in the outer comprehension into such an expression -- and the type of the elements that it outputs (tuples of binders) dsInnerListComp :: ([LStmt Id], [Id]) -> DsM (CoreExpr, Type) -dsInnerListComp (stmts, bndrs) = do - expr <- dsListComp stmts (mkBigLHsVarTup bndrs) bndrs_tuple_type - return (expr, bndrs_tuple_type) - where - bndrs_types = map idType bndrs - bndrs_tuple_type = mkBigCoreTupTy bndrs_types - +dsInnerListComp (stmts, bndrs) + = do { expr <- dsListComp (stmts ++ [noLoc $ mkLastStmt (mkBigLHsVarTup bndrs)]) + (mkListTy bndrs_tuple_type) + ; return (expr, bndrs_tuple_type) } + where + bndrs_tuple_type = mkBigCoreVarTupTy bndrs --- This function factors out commonality between the desugaring strategies for TransformStmt. --- Given such a statement it gives you back an expression representing how to compute the transformed --- list and the tuple that you need to bind from that list in order to proceed with your desugaring -dsTransformStmt :: Stmt Id -> DsM (CoreExpr, LPat Id) -dsTransformStmt (TransformStmt stmts binders usingExpr maybeByExpr) - = do { (expr, binders_tuple_type) <- dsInnerListComp (stmts, binders) - ; usingExpr' <- dsLExpr usingExpr - - ; using_args <- - case maybeByExpr of - Nothing -> return [expr] - Just byExpr -> do - byExpr' <- dsLExpr byExpr - - us <- newUniqueSupply - [tuple_binder] <- newSysLocalsDs [binders_tuple_type] - let byExprWrapper = mkTupleCase us binders byExpr' tuple_binder (Var tuple_binder) - - return [Lam tuple_binder byExprWrapper, expr] - - ; let inner_list_expr = mkApps usingExpr' ((Type binders_tuple_type) : using_args) - pat = mkBigLHsVarPatTup binders - ; return (inner_list_expr, pat) } - -- This function factors out commonality between the desugaring strategies for GroupStmt. -- Given such a statement it gives you back an expression representing how to compute the transformed -- list and the tuple that you need to bind from that list in order to proceed with your desugaring -dsGroupStmt :: Stmt Id -> DsM (CoreExpr, LPat Id) -dsGroupStmt (GroupStmt stmts binderMap by using) = do - let (fromBinders, toBinders) = unzip binderMap - - fromBindersTypes = map idType fromBinders - toBindersTypes = map idType toBinders - - toBindersTupleType = mkBigCoreTupTy toBindersTypes +dsTransStmt :: Stmt Id -> DsM (CoreExpr, LPat Id) +dsTransStmt (TransStmt { trS_form = form, trS_stmts = stmts, trS_bndrs = binderMap + , trS_by = by, trS_using = using }) = do + let (from_bndrs, to_bndrs) = unzip binderMap + from_bndrs_tys = map idType from_bndrs + to_bndrs_tys = map idType to_bndrs + to_bndrs_tup_ty = mkBigCoreTupTy to_bndrs_tys -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders - (expr, from_tup_ty) <- dsInnerListComp (stmts, fromBinders) + (expr, from_tup_ty) <- dsInnerListComp (stmts, from_bndrs) -- Work out what arguments should be supplied to that expression: i.e. is an extraction -- function required? If so, create that desugared function and add to arguments - usingExpr' <- dsLExpr (either id noLoc using) + usingExpr' <- dsLExpr using usingArgs <- case by of Nothing -> return [expr] Just by_e -> do { by_e' <- dsLExpr by_e - ; us <- newUniqueSupply - ; [from_tup_id] <- newSysLocalsDs [from_tup_ty] - ; let by_wrap = mkTupleCase us fromBinders by_e' - from_tup_id (Var from_tup_id) - ; return [Lam from_tup_id by_wrap, expr] } + ; lam <- matchTuple from_bndrs by_e' + ; return [lam, expr] } -- Create an unzip function for the appropriate arity and element types and find "map" - (unzip_fn, unzip_rhs) <- mkUnzipBind fromBindersTypes + unzip_stuff <- mkUnzipBind form from_bndrs_tys map_id <- dsLookupGlobalId mapName -- Generate the expressions to build the grouped list let -- First we apply the grouping function to the inner list - inner_list_expr = mkApps usingExpr' ((Type from_tup_ty) : usingArgs) + inner_list_expr = mkApps usingExpr' usingArgs -- Then we map our "unzip" across it to turn the lists of tuples into tuples of lists -- We make sure we instantiate the type variable "a" to be a list of "from" tuples and -- the "b" to be a tuple of "to" lists! - unzipped_inner_list_expr = mkApps (Var map_id) - [Type (mkListTy from_tup_ty), Type toBindersTupleType, Var unzip_fn, inner_list_expr] -- Then finally we bind the unzip function around that expression - bound_unzipped_inner_list_expr = Let (Rec [(unzip_fn, unzip_rhs)]) unzipped_inner_list_expr - - -- Build a pattern that ensures the consumer binds into the NEW binders, which hold lists rather than single values - let pat = mkBigLHsVarPatTup toBinders + bound_unzipped_inner_list_expr + = case unzip_stuff of + Nothing -> inner_list_expr + Just (unzip_fn, unzip_rhs) -> Let (Rec [(unzip_fn, unzip_rhs)]) $ + mkApps (Var map_id) $ + [ Type (mkListTy from_tup_ty) + , Type to_bndrs_tup_ty + , Var unzip_fn + , inner_list_expr] + + -- Build a pattern that ensures the consumer binds into the NEW binders, + -- which hold lists rather than single values + let pat = mkBigLHsVarPatTup to_bndrs return (bound_unzipped_inner_list_expr, pat) - \end{code} %************************************************************************ @@ -226,53 +207,50 @@ \begin{code} -deListComp :: [Stmt Id] -> LHsExpr Id -> CoreExpr -> DsM CoreExpr +deListComp :: [Stmt Id] -> CoreExpr -> DsM CoreExpr -deListComp (ParStmt stmtss_w_bndrs : quals) body list - = do - exps_and_qual_tys <- mapM dsInnerListComp stmtss_w_bndrs - let (exps, qual_tys) = unzip exps_and_qual_tys - - (zip_fn, zip_rhs) <- mkZipBind qual_tys +deListComp [] _ = panic "deListComp" - -- Deal with [e | pat <- zip l1 .. ln] in example above - deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps)) - quals body list - - where - bndrs_s = map snd stmtss_w_bndrs - - -- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above - pat = mkBigLHsPatTup pats - pats = map mkBigLHsVarPatTup bndrs_s - - -- Last: the one to return -deListComp [] body list = do -- Figure 7.4, SLPJ, p 135, rule C above - core_body <- dsLExpr body - return (mkConsExpr (exprType core_body) core_body list) +deListComp (LastStmt body _ : quals) list + = -- Figure 7.4, SLPJ, p 135, rule C above + ASSERT( null quals ) + do { core_body <- dsLExpr body + ; return (mkConsExpr (exprType core_body) core_body list) } -- Non-last: must be a guard -deListComp (ExprStmt guard _ _ : quals) body list = do -- rule B above +deListComp (ExprStmt guard _ _ _ : quals) list = do -- rule B above core_guard <- dsLExpr guard - core_rest <- deListComp quals body list + core_rest <- deListComp quals list return (mkIfThenElse core_guard core_rest list) -- [e | let B, qs] = let B in [e | qs] -deListComp (LetStmt binds : quals) body list = do - core_rest <- deListComp quals body list +deListComp (LetStmt binds : quals) list = do + core_rest <- deListComp quals list dsLocalBinds binds core_rest -deListComp (stmt@(TransformStmt {}) : quals) body list = do - (inner_list_expr, pat) <- dsTransformStmt stmt - deBindComp pat inner_list_expr quals body list - -deListComp (stmt@(GroupStmt {}) : quals) body list = do - (inner_list_expr, pat) <- dsGroupStmt stmt - deBindComp pat inner_list_expr quals body list +deListComp (stmt@(TransStmt {}) : quals) list = do + (inner_list_expr, pat) <- dsTransStmt stmt + deBindComp pat inner_list_expr quals list -deListComp (BindStmt pat list1 _ _ : quals) body core_list2 = do -- rule A' above +deListComp (BindStmt pat list1 _ _ : quals) core_list2 = do -- rule A' above core_list1 <- dsLExpr list1 - deBindComp pat core_list1 quals body core_list2 + deBindComp pat core_list1 quals core_list2 + +deListComp (ParStmt stmtss_w_bndrs _ _ _ : quals) list + = do { exps_and_qual_tys <- mapM dsInnerListComp stmtss_w_bndrs + ; let (exps, qual_tys) = unzip exps_and_qual_tys + + ; (zip_fn, zip_rhs) <- mkZipBind qual_tys + + -- Deal with [e | pat <- zip l1 .. ln] in example above + ; deBindComp pat (Let (Rec [(zip_fn, zip_rhs)]) (mkApps (Var zip_fn) exps)) + quals list } + where + bndrs_s = map snd stmtss_w_bndrs + + -- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above + pat = mkBigLHsPatTup pats + pats = map mkBigLHsVarPatTup bndrs_s \end{code} @@ -280,10 +258,9 @@ deBindComp :: OutPat Id -> CoreExpr -> [Stmt Id] - -> LHsExpr Id -> CoreExpr -> DsM (Expr Id) -deBindComp pat core_list1 quals body core_list2 = do +deBindComp pat core_list1 quals core_list2 = do let u3_ty@u1_ty = exprType core_list1 -- two names, same thing @@ -300,7 +277,7 @@ core_fail = App (Var h) (Var u3) letrec_body = App (Var h) core_list1 - rest_expr <- deListComp quals body core_fail + rest_expr <- deListComp quals core_fail core_match <- matchSimply (Var u2) (StmtCtxt ListComp) pat rest_expr core_fail let @@ -335,48 +312,43 @@ \begin{code} dfListComp :: Id -> Id -- 'c' and 'n' -> [Stmt Id] -- the rest of the qual's - -> LHsExpr Id -> DsM CoreExpr - -- Last: the one to return -dfListComp c_id n_id [] body = do - core_body <- dsLExpr body - return (mkApps (Var c_id) [core_body, Var n_id]) +dfListComp _ _ [] = panic "dfListComp" + +dfListComp c_id n_id (LastStmt body _ : quals) + = ASSERT( null quals ) + do { core_body <- dsLExpr body + ; return (mkApps (Var c_id) [core_body, Var n_id]) } -- Non-last: must be a guard -dfListComp c_id n_id (ExprStmt guard _ _ : quals) body = do +dfListComp c_id n_id (ExprStmt guard _ _ _ : quals) = do core_guard <- dsLExpr guard - core_rest <- dfListComp c_id n_id quals body + core_rest <- dfListComp c_id n_id quals return (mkIfThenElse core_guard core_rest (Var n_id)) -dfListComp c_id n_id (LetStmt binds : quals) body = do +dfListComp c_id n_id (LetStmt binds : quals) = do -- new in 1.3, local bindings - core_rest <- dfListComp c_id n_id quals body + core_rest <- dfListComp c_id n_id quals dsLocalBinds binds core_rest -dfListComp c_id n_id (stmt@(TransformStmt {}) : quals) body = do - (inner_list_expr, pat) <- dsTransformStmt stmt - -- Anyway, we bind the newly transformed list via the generic binding function - dfBindComp c_id n_id (pat, inner_list_expr) quals body - -dfListComp c_id n_id (stmt@(GroupStmt {}) : quals) body = do - (inner_list_expr, pat) <- dsGroupStmt stmt +dfListComp c_id n_id (stmt@(TransStmt {}) : quals) = do + (inner_list_expr, pat) <- dsTransStmt stmt -- Anyway, we bind the newly grouped list via the generic binding function - dfBindComp c_id n_id (pat, inner_list_expr) quals body + dfBindComp c_id n_id (pat, inner_list_expr) quals -dfListComp c_id n_id (BindStmt pat list1 _ _ : quals) body = do +dfListComp c_id n_id (BindStmt pat list1 _ _ : quals) = do -- evaluate the two lists core_list1 <- dsLExpr list1 -- Do the rest of the work in the generic binding builder - dfBindComp c_id n_id (pat, core_list1) quals body + dfBindComp c_id n_id (pat, core_list1) quals dfBindComp :: Id -> Id -- 'c' and 'n' -> (LPat Id, CoreExpr) -> [Stmt Id] -- the rest of the qual's - -> LHsExpr Id -> DsM CoreExpr -dfBindComp c_id n_id (pat, core_list1) quals body = do +dfBindComp c_id n_id (pat, core_list1) quals = do -- find the required type let x_ty = hsLPatType pat b_ty = idType n_id @@ -385,7 +357,7 @@ [b, x] <- newSysLocalsDs [b_ty, x_ty] -- build rest of the comprehesion - core_rest <- dfListComp c_id b quals body + core_rest <- dfListComp c_id b quals -- build the pattern match core_expr <- matchSimply (Var x) (StmtCtxt ListComp) @@ -439,7 +411,7 @@ -- Increasing order of tag -mkUnzipBind :: [Type] -> DsM (Id, CoreExpr) +mkUnzipBind :: TransForm -> [Type] -> DsM (Maybe (Id, CoreExpr)) -- mkUnzipBind [t1, t2] -- = (unzip, \ys :: [(t1, t2)] -> foldr (\ax :: (t1, t2) axs :: ([t1], [t2]) -- -> case ax of @@ -449,28 +421,29 @@ -- ys) -- -- We use foldr here in all cases, even if rules are turned off, because we may as well! -mkUnzipBind elt_tys = do - ax <- newSysLocalDs elt_tuple_ty - axs <- newSysLocalDs elt_list_tuple_ty - ys <- newSysLocalDs elt_tuple_list_ty - xs <- mapM newSysLocalDs elt_tys - xss <- mapM newSysLocalDs elt_list_tys - - unzip_fn <- newSysLocalDs unzip_fn_ty - - [us1, us2] <- sequence [newUniqueSupply, newUniqueSupply] - - let nil_tuple = mkBigCoreTup (map mkNilExpr elt_tys) - - concat_expressions = map mkConcatExpression (zip3 elt_tys (map Var xs) (map Var xss)) - tupled_concat_expression = mkBigCoreTup concat_expressions - - folder_body_inner_case = mkTupleCase us1 xss tupled_concat_expression axs (Var axs) - folder_body_outer_case = mkTupleCase us2 xs folder_body_inner_case ax (Var ax) - folder_body = mkLams [ax, axs] folder_body_outer_case - - unzip_body <- mkFoldrExpr elt_tuple_ty elt_list_tuple_ty folder_body nil_tuple (Var ys) - return (unzip_fn, mkLams [ys] unzip_body) +mkUnzipBind ThenForm _ + = return Nothing -- No unzipping for ThenForm +mkUnzipBind _ elt_tys + = do { ax <- newSysLocalDs elt_tuple_ty + ; axs <- newSysLocalDs elt_list_tuple_ty + ; ys <- newSysLocalDs elt_tuple_list_ty + ; xs <- mapM newSysLocalDs elt_tys + ; xss <- mapM newSysLocalDs elt_list_tys + + ; unzip_fn <- newSysLocalDs unzip_fn_ty + + ; [us1, us2] <- sequence [newUniqueSupply, newUniqueSupply] + + ; let nil_tuple = mkBigCoreTup (map mkNilExpr elt_tys) + concat_expressions = map mkConcatExpression (zip3 elt_tys (map Var xs) (map Var xss)) + tupled_concat_expression = mkBigCoreTup concat_expressions + + folder_body_inner_case = mkTupleCase us1 xss tupled_concat_expression axs (Var axs) + folder_body_outer_case = mkTupleCase us2 xs folder_body_inner_case ax (Var ax) + folder_body = mkLams [ax, axs] folder_body_outer_case + + ; unzip_body <- mkFoldrExpr elt_tuple_ty elt_list_tuple_ty folder_body nil_tuple (Var ys) + ; return (Just (unzip_fn, mkLams [ys] unzip_body)) } where elt_tuple_ty = mkBigCoreTupTy elt_tys elt_tuple_list_ty = mkListTy elt_tuple_ty @@ -480,9 +453,6 @@ unzip_fn_ty = elt_tuple_list_ty `mkFunTy` elt_list_tuple_ty mkConcatExpression (list_element_ty, head, tail) = mkConsExpr list_element_ty head tail - - - \end{code} %************************************************************************ @@ -498,11 +468,10 @@ -- [:e | qss:] = <<[:e | qss:]>> () [:():] -- dsPArrComp :: [Stmt Id] - -> LHsExpr Id - -> Type -- Don't use; called with `undefined' below -> DsM CoreExpr -dsPArrComp [ParStmt qss] body _ = -- parallel comprehension - dePArrParComp qss body + +-- Special case for parallel comprehension +dsPArrComp (ParStmt qss _ _ _ : quals) = dePArrParComp qss quals -- Special case for simple generators: -- @@ -513,8 +482,8 @@ -- <<[:e' | p <- e, qs:]>> = -- <<[:e' | qs:]>> p (filterP (\x -> case x of {p -> True; _ -> False}) e) -- -dsPArrComp (BindStmt p e _ _ : qs) body _ = do - filterP <- dsLookupGlobalId filterPName +dsPArrComp (BindStmt p e _ _ : qs) = do + filterP <- dsLookupDPHId filterPName ce <- dsLExpr e let ety'ce = parrElemType ce false = Var falseDataConId @@ -523,38 +492,41 @@ pred <- matchSimply (Var v) (StmtCtxt PArrComp) p true false let gen | isIrrefutableHsPat p = ce | otherwise = mkApps (Var filterP) [Type ety'ce, mkLams [v] pred, ce] - dePArrComp qs body p gen + dePArrComp qs p gen -dsPArrComp qs body _ = do -- no ParStmt in `qs' - sglP <- dsLookupGlobalId singletonPName +dsPArrComp qs = do -- no ParStmt in `qs' + sglP <- dsLookupDPHId singletonPName let unitArray = mkApps (Var sglP) [Type unitTy, mkCoreTup []] - dePArrComp qs body (noLoc $ WildPat unitTy) unitArray + dePArrComp qs (noLoc $ WildPat unitTy) unitArray -- the work horse -- dePArrComp :: [Stmt Id] - -> LHsExpr Id -> LPat Id -- the current generator pattern -> CoreExpr -- the current generator expression -> DsM CoreExpr + +dePArrComp [] _ _ = panic "dePArrComp" + -- -- <<[:e' | :]>> pa ea = mapP (\pa -> e') ea -- -dePArrComp [] e' pa cea = do - mapP <- dsLookupGlobalId mapPName - let ty = parrElemType cea - (clam, ty'e') <- deLambda ty pa e' - return $ mkApps (Var mapP) [Type ty, Type ty'e', clam, cea] +dePArrComp (LastStmt e' _ : quals) pa cea + = ASSERT( null quals ) + do { mapP <- dsLookupDPHId mapPName + ; let ty = parrElemType cea + ; (clam, ty'e') <- deLambda ty pa e' + ; return $ mkApps (Var mapP) [Type ty, Type ty'e', clam, cea] } -- -- <<[:e' | b, qs:]>> pa ea = <<[:e' | qs:]>> pa (filterP (\pa -> b) ea) -- -dePArrComp (ExprStmt b _ _ : qs) body pa cea = do - filterP <- dsLookupGlobalId filterPName +dePArrComp (ExprStmt b _ _ _ : qs) pa cea = do + filterP <- dsLookupDPHId filterPName let ty = parrElemType cea (clam,_) <- deLambda ty pa b - dePArrComp qs body pa (mkApps (Var filterP) [Type ty, clam, cea]) + dePArrComp qs pa (mkApps (Var filterP) [Type ty, clam, cea]) -- -- <<[:e' | p <- e, qs:]>> pa ea = @@ -569,9 +541,9 @@ -- in -- <<[:e' | qs:]>> (pa, p) (crossMapP ea ef) -- -dePArrComp (BindStmt p e _ _ : qs) body pa cea = do - filterP <- dsLookupGlobalId filterPName - crossMapP <- dsLookupGlobalId crossMapPName +dePArrComp (BindStmt p e _ _ : qs) pa cea = do + filterP <- dsLookupDPHId filterPName + crossMapP <- dsLookupDPHId crossMapPName ce <- dsLExpr e let ety'cea = parrElemType cea ety'ce = parrElemType ce @@ -585,7 +557,7 @@ let ety'cef = ety'ce -- filter doesn't change the element type pa' = mkLHsPatTup [pa, p] - dePArrComp qs body pa' (mkApps (Var crossMapP) + dePArrComp qs pa' (mkApps (Var crossMapP) [Type ety'cea, Type ety'cef, cea, clam]) -- -- <<[:e' | let ds, qs:]>> pa ea = @@ -594,8 +566,8 @@ -- where -- {x_1, ..., x_n} = DV (ds) -- Defined Variables -- -dePArrComp (LetStmt ds : qs) body pa cea = do - mapP <- dsLookupGlobalId mapPName +dePArrComp (LetStmt ds : qs) pa cea = do + mapP <- dsLookupDPHId mapPName let xs = collectLocalBinders ds ty'cea = parrElemType cea v <- newSysLocalDs ty'cea @@ -609,14 +581,14 @@ ccase <- matchSimply (Var v) (StmtCtxt PArrComp) pa projBody cerr let pa' = mkLHsPatTup [pa, mkLHsPatTup (map nlVarPat xs)] proj = mkLams [v] ccase - dePArrComp qs body pa' (mkApps (Var mapP) + dePArrComp qs pa' (mkApps (Var mapP) [Type ty'cea, Type errTy, proj, cea]) -- -- The parser guarantees that parallel comprehensions can only appear as -- singeltons qualifier lists, which we already special case in the caller. -- So, encountering one here is a bug. -- -dePArrComp (ParStmt _ : _) _ _ _ = +dePArrComp (ParStmt _ _ _ _ : _) _ _ = panic "DsListComp.dePArrComp: malformed comprehension AST" -- <<[:e' | qs | qss:]>> pa ea = @@ -625,26 +597,26 @@ -- where -- {x_1, ..., x_n} = DV (qs) -- -dePArrParComp :: [([LStmt Id], [Id])] -> LHsExpr Id -> DsM CoreExpr -dePArrParComp qss body = do +dePArrParComp :: [([LStmt Id], [Id])] -> [Stmt Id] -> DsM CoreExpr +dePArrParComp qss quals = do (pQss, ceQss) <- deParStmt qss - dePArrComp [] body pQss ceQss + dePArrComp quals pQss ceQss where deParStmt [] = -- empty parallel statement lists have no source representation panic "DsListComp.dePArrComp: Empty parallel list comprehension" deParStmt ((qs, xs):qss) = do -- first statement let res_expr = mkLHsVarTuple xs - cqs <- dsPArrComp (map unLoc qs) res_expr undefined + cqs <- dsPArrComp (map unLoc qs ++ [mkLastStmt res_expr]) parStmts qss (mkLHsVarPatTup xs) cqs --- parStmts [] pa cea = return (pa, cea) parStmts ((qs, xs):qss) pa cea = do -- subsequent statements (zip'ed) - zipP <- dsLookupGlobalId zipPName + zipP <- dsLookupDPHId zipPName let pa' = mkLHsPatTup [pa, mkLHsVarPatTup xs] ty'cea = parrElemType cea res_expr = mkLHsVarTuple xs - cqs <- dsPArrComp (map unLoc qs) res_expr undefined + cqs <- dsPArrComp (map unLoc qs ++ [mkLastStmt res_expr]) let ty'cqs = parrElemType cqs cea' = mkApps (Var zipP) [Type ty'cea, Type ty'cqs, cea, cqs] parStmts qss pa' cea' @@ -682,3 +654,222 @@ _ -> panic "DsListComp.parrElemType: not a parallel array type" \end{code} + +Translation for monad comprehensions + +\begin{code} +-- Entry point for monad comprehension desugaring +dsMonadComp :: [LStmt Id] -> DsM CoreExpr +dsMonadComp stmts = dsMcStmts stmts + +dsMcStmts :: [LStmt Id] -> DsM CoreExpr +dsMcStmts [] = panic "dsMcStmts" +dsMcStmts (L loc stmt : lstmts) = putSrcSpanDs loc (dsMcStmt stmt lstmts) + +--------------- +dsMcStmt :: Stmt Id -> [LStmt Id] -> DsM CoreExpr + +dsMcStmt (LastStmt body ret_op) stmts + = ASSERT( null stmts ) + do { body' <- dsLExpr body + ; ret_op' <- dsExpr ret_op + ; return (App ret_op' body') } + +-- [ .. | let binds, stmts ] +dsMcStmt (LetStmt binds) stmts + = do { rest <- dsMcStmts stmts + ; dsLocalBinds binds rest } + +-- [ .. | a <- m, stmts ] +dsMcStmt (BindStmt pat rhs bind_op fail_op) stmts + = do { rhs' <- dsLExpr rhs + ; dsMcBindStmt pat rhs' bind_op fail_op stmts } + +-- Apply `guard` to the `exp` expression +-- +-- [ .. | exp, stmts ] +-- +dsMcStmt (ExprStmt exp then_exp guard_exp _) stmts + = do { exp' <- dsLExpr exp + ; guard_exp' <- dsExpr guard_exp + ; then_exp' <- dsExpr then_exp + ; rest <- dsMcStmts stmts + ; return $ mkApps then_exp' [ mkApps guard_exp' [exp'] + , rest ] } + +-- Group statements desugar like this: +-- +-- [| (q, then group by e using f); rest |] +-- ---> f {qt} (\qv -> e) [| q; return qv |] >>= \ n_tup -> +-- case unzip n_tup of qv' -> [| rest |] +-- +-- where variables (v1:t1, ..., vk:tk) are bound by q +-- qv = (v1, ..., vk) +-- qt = (t1, ..., tk) +-- (>>=) :: m2 a -> (a -> m3 b) -> m3 b +-- f :: forall a. (a -> t) -> m1 a -> m2 (n a) +-- n_tup :: n qt +-- unzip :: n qt -> (n t1, ..., n tk) (needs Functor n) + +dsMcStmt (TransStmt { trS_stmts = stmts, trS_bndrs = bndrs + , trS_by = by, trS_using = using + , trS_ret = return_op, trS_bind = bind_op + , trS_fmap = fmap_op, trS_form = form }) stmts_rest + = do { let (from_bndrs, to_bndrs) = unzip bndrs + from_bndr_tys = map idType from_bndrs -- Types ty + + -- Desugar an inner comprehension which outputs a list of tuples of the "from" binders + ; expr <- dsInnerMonadComp stmts from_bndrs return_op + + -- Work out what arguments should be supplied to that expression: i.e. is an extraction + -- function required? If so, create that desugared function and add to arguments + ; usingExpr' <- dsLExpr using + ; usingArgs <- case by of + Nothing -> return [expr] + Just by_e -> do { by_e' <- dsLExpr by_e + ; lam <- matchTuple from_bndrs by_e' + ; return [lam, expr] } + + -- Generate the expressions to build the grouped list + -- Build a pattern that ensures the consumer binds into the NEW binders, + -- which hold monads rather than single values + ; bind_op' <- dsExpr bind_op + ; let bind_ty = exprType bind_op' -- m2 (n (a,b,c)) -> (n (a,b,c) -> r1) -> r2 + n_tup_ty = funArgTy $ funArgTy $ funResultTy bind_ty -- n (a,b,c) + tup_n_ty = mkBigCoreVarTupTy to_bndrs + + ; body <- dsMcStmts stmts_rest + ; n_tup_var <- newSysLocalDs n_tup_ty + ; tup_n_var <- newSysLocalDs tup_n_ty + ; tup_n_expr <- mkMcUnzipM form fmap_op n_tup_var from_bndr_tys + ; us <- newUniqueSupply + ; let rhs' = mkApps usingExpr' usingArgs + body' = mkTupleCase us to_bndrs body tup_n_var tup_n_expr + + ; return (mkApps bind_op' [rhs', Lam n_tup_var body']) } + +-- Parallel statements. Use `Control.Monad.Zip.mzip` to zip parallel +-- statements, for example: +-- +-- [ body | qs1 | qs2 | qs3 ] +-- -> [ body | (bndrs1, (bndrs2, bndrs3)) +-- <- [bndrs1 | qs1] `mzip` ([bndrs2 | qs2] `mzip` [bndrs3 | qs3]) ] +-- +-- where `mzip` has type +-- mzip :: forall a b. m a -> m b -> m (a,b) +-- NB: we need a polymorphic mzip because we call it several times + +dsMcStmt (ParStmt pairs mzip_op bind_op return_op) stmts_rest + = do { exps_w_tys <- mapM ds_inner pairs -- Pairs (exp :: m ty, ty) + ; mzip_op' <- dsExpr mzip_op + + ; let -- The pattern variables + pats = map (mkBigLHsVarPatTup . snd) pairs + -- Pattern with tuples of variables + -- [v1,v2,v3] => (v1, (v2, v3)) + pat = foldr1 (\p1 p2 -> mkLHsPatTup [p1, p2]) pats + (rhs, _) = foldr1 (\(e1,t1) (e2,t2) -> + (mkApps mzip_op' [Type t1, Type t2, e1, e2], + mkBoxedTupleTy [t1,t2])) + exps_w_tys + + ; dsMcBindStmt pat rhs bind_op noSyntaxExpr stmts_rest } + where + ds_inner (stmts, bndrs) = do { exp <- dsInnerMonadComp stmts bndrs mono_ret_op + ; return (exp, tup_ty) } + where + mono_ret_op = HsWrap (WpTyApp tup_ty) return_op + tup_ty = mkBigCoreVarTupTy bndrs + +dsMcStmt stmt _ = pprPanic "dsMcStmt: unexpected stmt" (ppr stmt) + + +matchTuple :: [Id] -> CoreExpr -> DsM CoreExpr +-- (matchTuple [a,b,c] body) +-- returns the Core term +-- \x. case x of (a,b,c) -> body +matchTuple ids body + = do { us <- newUniqueSupply + ; tup_id <- newSysLocalDs (mkBigCoreVarTupTy ids) + ; return (Lam tup_id $ mkTupleCase us ids body tup_id (Var tup_id)) } + +-- general `rhs' >>= \pat -> stmts` desugaring where `rhs'` is already a +-- desugared `CoreExpr` +dsMcBindStmt :: LPat Id + -> CoreExpr -- ^ the desugared rhs of the bind statement + -> SyntaxExpr Id + -> SyntaxExpr Id + -> [LStmt Id] + -> DsM CoreExpr +dsMcBindStmt pat rhs' bind_op fail_op stmts + = do { body <- dsMcStmts stmts + ; bind_op' <- dsExpr bind_op + ; var <- selectSimpleMatchVarL pat + ; let bind_ty = exprType bind_op' -- rhs -> (pat -> res1) -> res2 + res1_ty = funResultTy (funArgTy (funResultTy bind_ty)) + ; match <- matchSinglePat (Var var) (StmtCtxt DoExpr) pat + res1_ty (cantFailMatchResult body) + ; match_code <- handle_failure pat match fail_op + ; return (mkApps bind_op' [rhs', Lam var match_code]) } + + where + -- In a monad comprehension expression, pattern-match failure just calls + -- the monadic `fail` rather than throwing an exception + handle_failure pat match fail_op + | matchCanFail match + = do { fail_op' <- dsExpr fail_op + ; fail_msg <- mkStringExpr (mk_fail_msg pat) + ; extractMatchResult match (App fail_op' fail_msg) } + | otherwise + = extractMatchResult match (error "It can't fail") + + mk_fail_msg :: Located e -> String + mk_fail_msg pat = "Pattern match failure in monad comprehension at " ++ + showSDoc (ppr (getLoc pat)) + +-- Desugar nested monad comprehensions, for example in `then..` constructs +-- dsInnerMonadComp quals [a,b,c] ret_op +-- returns the desugaring of +-- [ (a,b,c) | quals ] + +dsInnerMonadComp :: [LStmt Id] + -> [Id] -- Return a tuple of these variables + -> HsExpr Id -- The monomorphic "return" operator + -> DsM CoreExpr +dsInnerMonadComp stmts bndrs ret_op + = dsMcStmts (stmts ++ [noLoc (LastStmt (mkBigLHsVarTup bndrs) ret_op)]) + +-- The `unzip` function for `GroupStmt` in a monad comprehensions +-- +-- unzip :: m (a,b,..) -> (m a,m b,..) +-- unzip m_tuple = ( liftM selN1 m_tuple +-- , liftM selN2 m_tuple +-- , .. ) +-- +-- mkMcUnzipM fmap ys [t1, t2] +-- = ( fmap (selN1 :: (t1, t2) -> t1) ys +-- , fmap (selN2 :: (t1, t2) -> t2) ys ) + +mkMcUnzipM :: TransForm + -> SyntaxExpr TcId -- fmap + -> Id -- Of type n (a,b,c) + -> [Type] -- [a,b,c] + -> DsM CoreExpr -- Of type (n a, n b, n c) +mkMcUnzipM ThenForm _ ys _ + = return (Var ys) -- No unzipping to do + +mkMcUnzipM _ fmap_op ys elt_tys + = do { fmap_op' <- dsExpr fmap_op + ; xs <- mapM newSysLocalDs elt_tys + ; let tup_ty = mkBigCoreTupTy elt_tys + ; tup_xs <- newSysLocalDs tup_ty + + ; let mk_elt i = mkApps fmap_op' -- fmap :: forall a b. (a -> b) -> n a -> n b + [ Type tup_ty, Type (elt_tys !! i) + , mk_sel i, Var ys] + + mk_sel n = Lam tup_xs $ + mkTupleSelector xs (xs !! n) tup_xs (Var tup_xs) + + ; return (mkBigCoreTup (map mk_elt [0..length elt_tys - 1])) } +\end{code} diff -Nru ghc-7.0.3/compiler/deSugar/DsMeta.hs ghc-7.2.1/compiler/deSugar/DsMeta.hs --- ghc-7.0.3/compiler/deSugar/DsMeta.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/deSugar/DsMeta.hs 2011-08-07 17:10:05.000000000 +0000 @@ -57,6 +57,7 @@ import FastString import ForeignCall import MonadUtils +import Util( equalLength ) import Data.Maybe import Control.Monad @@ -102,7 +103,7 @@ repTopP :: LPat Name -> DsM (Core TH.PatQ) repTopP pat = do { ss <- mkGenSyms (collectPatBinders pat) ; pat' <- addBinds ss (repLP pat) - ; wrapNongenSyms ss pat' } + ; wrapGenSyms ss pat' } repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec])) repTopDs group @@ -131,8 +132,7 @@ dec_ty <- lookupType decTyConName ; q_decs <- repSequenceQ dec_ty core_list ; - wrapNongenSyms ss q_decs - -- Do *not* gensym top-level binders + wrapGenSyms ss q_decs } @@ -173,7 +173,7 @@ do { cxt1 <- repLContext cxt ; opt_tys1 <- maybeMapM repLTys opt_tys -- only for family insts ; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1 - ; cons1 <- mapM repC cons + ; cons1 <- mapM (repC (hsLTyVarNames tvs)) cons ; cons2 <- coreList conQTyConName cons1 ; derivs1 <- repDerivs mb_derivs ; bndrs1 <- coreList tyVarBndrTyConName bndrs @@ -190,7 +190,7 @@ do { cxt1 <- repLContext cxt ; opt_tys1 <- maybeMapM repLTys opt_tys -- only for family insts ; opt_tys2 <- maybeMapM (coreList typeQTyConName) opt_tys1 - ; con1 <- repC con + ; con1 <- repC (hsLTyVarNames tvs) con ; derivs1 <- repDerivs mb_derivs ; bndrs1 <- coreList tyVarBndrTyConName bndrs ; repNewtype cxt1 tc1 bndrs1 opt_tys2 con1 derivs1 @@ -310,11 +310,9 @@ ; ss <- mkGenSyms (collectHsBindsBinders binds) ; binds1 <- addBinds ss (rep_binds binds) ; ats1 <- repLAssocFamInst ats - ; decls1 <- coreList decQTyConName (ats1 ++ binds1) - ; decls2 <- wrapNongenSyms ss decls1 - -- wrapNongenSyms: do not clone the class op names! - -- They must be called 'op' etc, not 'op34' - ; repInst cxt1 inst_ty1 (decls2) + ; decls <- coreList decQTyConName (ats1 ++ binds1) + ; inst_decl <- repInst cxt1 inst_ty1 decls + ; wrapGenSyms ss inst_decl } ; return (loc, i)} where @@ -349,8 +347,8 @@ repSafety :: Safety -> DsM (Core TH.Safety) repSafety PlayRisky = rep2 unsafeName [] -repSafety (PlaySafe False) = rep2 safeName [] -repSafety (PlaySafe True) = rep2 threadsafeName [] +repSafety PlayInterruptible = rep2 interruptibleName [] +repSafety PlaySafe = rep2 safeName [] ds_msg :: SDoc ds_msg = ptext (sLit "Cannot desugar this Template Haskell declaration:") @@ -359,23 +357,73 @@ -- Constructors ------------------------------------------------------- -repC :: LConDecl Name -> DsM (Core TH.ConQ) -repC (L _ (ConDecl { con_name = con, con_qvars = [], con_cxt = L _ [] - , con_details = details, con_res = ResTyH98 })) +repC :: [Name] -> LConDecl Name -> DsM (Core TH.ConQ) +repC _ (L _ (ConDecl { con_name = con, con_qvars = [], con_cxt = L _ [] + , con_details = details, con_res = ResTyH98 })) = do { con1 <- lookupLOcc con -- See note [Binders and occurrences] - ; repConstr con1 details - } -repC (L loc con_decl@(ConDecl { con_qvars = tvs, con_cxt = L cloc ctxt, con_res = ResTyH98 })) - = addTyVarBinds tvs $ \bndrs -> - do { c' <- repC (L loc (con_decl { con_qvars = [], con_cxt = L cloc [] })) - ; ctxt' <- repContext ctxt - ; bndrs' <- coreList tyVarBndrTyConName bndrs - ; rep2 forallCName [unC bndrs', unC ctxt', unC c'] - } -repC (L loc con_decl) -- GADTs - = putSrcSpanDs loc $ - notHandled "GADT declaration" (ppr con_decl) + ; repConstr con1 details } +repC tvs (L _ (ConDecl { con_name = con + , con_qvars = con_tvs, con_cxt = L _ ctxt + , con_details = details + , con_res = res_ty })) + = do { (eq_ctxt, con_tv_subst) <- mkGadtCtxt tvs res_ty + ; let ex_tvs = [ tv | tv <- con_tvs, not (hsLTyVarName tv `in_subst` con_tv_subst)] + ; binds <- mapM dupBinder con_tv_subst + ; dsExtendMetaEnv (mkNameEnv binds) $ -- Binds some of the con_tvs + addTyVarBinds ex_tvs $ \ ex_bndrs -> -- Binds the remaining con_tvs + do { con1 <- lookupLOcc con -- See note [Binders and occurrences] + ; c' <- repConstr con1 details + ; ctxt' <- repContext (eq_ctxt ++ ctxt) + ; ex_bndrs' <- coreList tyVarBndrTyConName ex_bndrs + ; rep2 forallCName [unC ex_bndrs', unC ctxt', unC c'] } } + +in_subst :: Name -> [(Name,Name)] -> Bool +in_subst _ [] = False +in_subst n ((n',_):ns) = n==n' || in_subst n ns + +mkGadtCtxt :: [Name] -- Tyvars of the data type + -> ResType Name + -> DsM (HsContext Name, [(Name,Name)]) +-- Given a data type in GADT syntax, figure out the equality +-- context, so that we can represent it with an explicit +-- equality context, because that is the only way to express +-- the GADT in TH syntax +-- +-- Example: +-- data T a b c where { MkT :: forall d e. d -> e -> T d [e] e +-- mkGadtCtxt [a,b,c] [d,e] (T d [e] e) +-- returns +-- (b~[e], c~e), [d->a] +-- +-- This function is fiddly, but not really hard +mkGadtCtxt _ ResTyH98 + = return ([], []) +mkGadtCtxt data_tvs (ResTyGADT res_ty) + | let (head_ty, tys) = splitHsAppTys res_ty [] + , Just _ <- is_hs_tyvar head_ty + , data_tvs `equalLength` tys + = return (go [] [] (data_tvs `zip` tys)) + + | otherwise + = failWithDs (ptext (sLit "Malformed constructor result type") <+> ppr res_ty) + where + go cxt subst [] = (cxt, subst) + go cxt subst ((data_tv, ty) : rest) + | Just con_tv <- is_hs_tyvar ty + , isTyVarName con_tv + , not (in_subst con_tv subst) + = go cxt ((con_tv, data_tv) : subst) rest + | otherwise + = go (eq_pred : cxt) subst rest + where + loc = getLoc ty + eq_pred = L loc (HsEqualP (L loc (HsTyVar data_tv)) ty) + + is_hs_tyvar (L _ (HsTyVar n)) = Just n -- Type variables *and* tycons + is_hs_tyvar (L _ (HsParTy ty)) = is_hs_tyvar ty + is_hs_tyvar _ = Nothing + repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ)) repBangTy ty= do MkC s <- rep2 str [] @@ -418,19 +466,25 @@ rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)] -- Singleton => Ok -- Empty => Too hard, signature ignored -rep_sig (L loc (TypeSig nm ty)) = rep_proto nm ty loc +rep_sig (L loc (TypeSig nms ty)) = rep_proto nms ty loc +rep_sig (L _ (GenericSig nm _)) = failWithDs msg + where msg = vcat [ ptext (sLit "Illegal default signature for") <+> quotes (ppr nm) + , ptext (sLit "Default signatures are not supported by Template Haskell") ] + rep_sig (L loc (InlineSig nm ispec)) = rep_inline nm ispec loc rep_sig (L loc (SpecSig nm ty ispec)) = rep_specialise nm ty ispec loc rep_sig _ = return [] -rep_proto :: Located Name -> LHsType Name -> SrcSpan +rep_proto :: [Located Name] -> LHsType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)] -rep_proto nm ty loc - = do { nm1 <- lookupLOcc nm - ; ty1 <- repLTy ty - ; sig <- repProto nm1 ty1 - ; return [(loc, sig)] - } +rep_proto nms ty loc + = mapM f nms + where + f nm = do { nm1 <- lookupLOcc nm + ; ty1 <- repLTy ty + ; sig <- repProto nm1 ty1 + ; return (loc, sig) + } rep_inline :: Located Name -> InlinePragma -- Never defaultInlinePragma @@ -501,16 +555,14 @@ -- meta environment and gets the *new* names on Core-level as an argument -- addTyVarBinds :: ProcessTyVarBinds a -addTyVarBinds tvs m = - do - let names = hsLTyVarNames tvs - mkWithKinds = map repTyVarBndrWithKind tvs - freshNames <- mkGenSyms names - term <- addBinds freshNames $ do - bndrs <- mapM lookupBinder names - kindedBndrs <- zipWithM ($) mkWithKinds bndrs - m kindedBndrs - wrapGenSyms freshNames term +addTyVarBinds tvs m + = do { freshNames <- mkGenSyms (hsLTyVarNames tvs) + ; term <- addBinds freshNames $ + do { kindedBndrs <- mapM mk_tv_bndr (tvs `zip` freshNames) + ; m kindedBndrs } + ; wrapGenSyms freshNames term } + where + mk_tv_bndr (tv, (_,v)) = repTyVarBndrWithKind tv (coreVar v) -- Look up a list of type variables; the computations passed as the second -- argument gets the *new* names on Core-level as an argument @@ -613,10 +665,14 @@ t1 <- repLTy t tcon <- repTy (HsTyVar (tyConName parrTyCon)) repTapp tcon t1 -repTy (HsTupleTy _ tys) = do +repTy (HsTupleTy Boxed tys) = do tys1 <- repLTys tys tcon <- repTupleTyCon (length tys) repTapps tcon tys1 +repTy (HsTupleTy Unboxed tys) = do + tys1 <- repLTys tys + tcon <- repUnboxedTupleTyCon (length tys) + repTapps tcon tys1 repTy (HsOpTy ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1) `nlHsAppTy` ty2) repTy (HsParTy t) = repLTy t @@ -626,7 +682,6 @@ k1 <- repKind k repTSig t1 k1 repTy (HsSpliceTy splice _ _) = repSplice splice -repTy ty@(HsNumTy _) = notHandled "Number types (for generics)" (ppr ty) repTy ty = notHandled "Exotic form of type" (ppr ty) -- represent a kind @@ -716,30 +771,26 @@ ; wrapGenSyms ss z } -- FIXME: I haven't got the types here right yet -repE e@(HsDo ctxt sts body _) +repE e@(HsDo ctxt sts _) | case ctxt of { DoExpr -> True; GhciStmt -> True; _ -> False } = do { (ss,zs) <- repLSts sts; - body' <- addBinds ss $ repLE body; - ret <- repNoBindSt body'; - e' <- repDoE (nonEmptyCoreList (zs ++ [ret])); + e' <- repDoE (nonEmptyCoreList zs); wrapGenSyms ss e' } | ListComp <- ctxt = do { (ss,zs) <- repLSts sts; - body' <- addBinds ss $ repLE body; - ret <- repNoBindSt body'; - e' <- repComp (nonEmptyCoreList (zs ++ [ret])); + e' <- repComp (nonEmptyCoreList zs); wrapGenSyms ss e' } | otherwise - = notHandled "mdo and [: :]" (ppr e) + = notHandled "mdo, monad comprehension and [: :]" (ppr e) repE (ExplicitList _ es) = do { xs <- repLEs es; repListExp xs } repE e@(ExplicitPArr _ _) = notHandled "Parallel arrays" (ppr e) repE e@(ExplicitTuple es boxed) - | not (isBoxed boxed) = notHandled "Unboxed tuples" (ppr e) | not (all tupArgPresent es) = notHandled "Tuple sections" (ppr e) - | otherwise = do { xs <- repLEs [e | Present e <- es]; repTup xs } + | isBoxed boxed = do { xs <- repLEs [e | Present e <- es]; repTup xs } + | otherwise = do { xs <- repLEs [e | Present e <- es]; repUnboxedTup xs } repE (RecordCon c _ flds) = do { x <- lookupLOcc c; @@ -812,7 +863,7 @@ wrapGenSyms (concat xs) gd } where process :: LGRHS Name -> DsM ([GenSymBind], (Core (TH.Q (TH.Guard, TH.Exp)))) - process (L _ (GRHS [L _ (ExprStmt e1 _ _)] e2)) + process (L _ (GRHS [L _ (ExprStmt e1 _ _ _)] e2)) = do { x <- repLNormalGE e1 e2; return ([], x) } process (L _ (GRHS ss rhs)) @@ -871,11 +922,15 @@ ; z <- repLetSt ds ; (ss2,zs) <- addBinds ss1 (repSts ss) ; return (ss1++ss2, z : zs) } -repSts (ExprStmt e _ _ : ss) = +repSts (ExprStmt e _ _ _ : ss) = do { e2 <- repLE e ; z <- repNoBindSt e2 ; (ss2,zs) <- repSts ss ; return (ss2, z : zs) } +repSts [LastStmt e _] + = do { e2 <- repLE e + ; z <- repNoBindSt e2 + ; return ([], [z]) } repSts [] = return ([],[]) repSts other = notHandled "Exotic statement" (ppr other) @@ -958,7 +1013,7 @@ ; ans <- repVal patcore x empty_decls ; return (srcLocSpan (getSrcLoc v), ans) } -rep_bind (L _ (AbsBinds {})) = panic "rep_bind: AbsBinds" +rep_bind (L _ (AbsBinds {})) = panic "rep_bind: AbsBinds" ----------------------------------------------------------------------------- -- Since everything in a Bind is mutually recursive we need rename all @@ -1019,9 +1074,9 @@ repP (AsPat x p) = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 } repP (ParPat p) = repLP p repP (ListPat ps _) = do { qs <- repLPs ps; repPlist qs } -repP p@(TuplePat ps boxed _) - | not (isBoxed boxed) = notHandled "Unboxed tuples" (ppr p) - | otherwise = do { qs <- repLPs ps; repPtup qs } +repP (TuplePat ps boxed _) + | isBoxed boxed = do { qs <- repLPs ps; repPtup qs } + | otherwise = do { qs <- repLPs ps; repPunboxedTup qs } repP (ConPatIn dc details) = do { con_str <- lookupLOcc dc ; case details of @@ -1104,6 +1159,13 @@ where msg = ptext (sLit "DsMeta: failed binder lookup when desugaring a TH bracket:") <+> ppr n +dupBinder :: (Name, Name) -> DsM (Name, DsMetaVal) +dupBinder (new, old) + = do { mb_val <- dsLookupMetaEnv old + ; case mb_val of + Just val -> return (new, val) + Nothing -> pprPanic "dupBinder" (ppr old) } + -- Look up a name that is either locally bound or a global name -- -- * If it is a global name, generate the "original name" representation (ie, @@ -1189,21 +1251,6 @@ ; repBindQ var_ty elt_ty gensym_app (MkC (Lam id body')) } --- Just like wrapGenSym, but don't actually do the gensym --- Instead use the existing name: --- let x = "x" in ... --- Only used for [Decl], and for the class ops in class --- and instance decls -wrapNongenSyms :: [GenSymBind] -> Core a -> DsM (Core a) -wrapNongenSyms binds (MkC body) - = do { binds' <- mapM do_one binds ; - return (MkC (mkLets binds' body)) } - where - do_one (name,id) - = do { MkC lit_str <- occNameLit name - ; MkC var <- rep2 mkNameName [lit_str] - ; return (NonRec id var) } - occNameLit :: Name -> DsM (Core String) occNameLit n = coreStringLit (occNameString (nameOccName n)) @@ -1246,6 +1293,9 @@ repPtup :: Core [TH.PatQ] -> DsM (Core TH.PatQ) repPtup (MkC ps) = rep2 tupPName [ps] +repPunboxedTup :: Core [TH.PatQ] -> DsM (Core TH.PatQ) +repPunboxedTup (MkC ps) = rep2 unboxedTupPName [ps] + repPcon :: Core TH.Name -> Core [TH.PatQ] -> DsM (Core TH.PatQ) repPcon (MkC s) (MkC ps) = rep2 conPName [s, ps] @@ -1296,6 +1346,9 @@ repTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ) repTup (MkC es) = rep2 tupEName [es] +repUnboxedTup :: Core [TH.ExpQ] -> DsM (Core TH.ExpQ) +repUnboxedTup (MkC es) = rep2 unboxedTupEName [es] + repCond :: Core TH.ExpQ -> Core TH.ExpQ -> Core TH.ExpQ -> DsM (Core TH.ExpQ) repCond (MkC x) (MkC y) (MkC z) = rep2 condEName [x,y,z] @@ -1517,6 +1570,10 @@ -- Note: not Core Int; it's easier to be direct here repTupleTyCon i = rep2 tupleTName [mkIntExprInt i] +repUnboxedTupleTyCon :: Int -> DsM (Core TH.TypeQ) +-- Note: not Core Int; it's easier to be direct here +repUnboxedTupleTyCon i = rep2 unboxedTupleTName [mkIntExprInt i] + repArrowTyCon :: DsM (Core TH.TypeQ) repArrowTyCon = rep2 arrowTName [] @@ -1569,7 +1626,7 @@ mk_integer :: Integer -> DsM HsLit mk_integer i = do integer_ty <- lookupType integerTyConName return $ HsInteger i integer_ty -mk_rational :: Rational -> DsM HsLit +mk_rational :: FractionalLit -> DsM HsLit mk_rational r = do rat_ty <- lookupType rationalTyConName return $ HsRat r rat_ty mk_string :: FastString -> DsM HsLit @@ -1667,7 +1724,8 @@ charLName, stringLName, integerLName, intPrimLName, wordPrimLName, floatPrimLName, doublePrimLName, rationalLName, -- Pat - litPName, varPName, tupPName, conPName, tildePName, bangPName, infixPName, + litPName, varPName, tupPName, unboxedTupPName, + conPName, tildePName, bangPName, infixPName, asPName, wildPName, recPName, listPName, sigPName, viewPName, -- FieldPat fieldPatName, @@ -1677,7 +1735,8 @@ clauseName, -- Exp varEName, conEName, litEName, appEName, infixEName, - infixAppName, sectionLName, sectionRName, lamEName, tupEName, + infixAppName, sectionLName, sectionRName, lamEName, + tupEName, unboxedTupEName, condEName, letEName, caseEName, doEName, compEName, fromEName, fromThenEName, fromToEName, fromThenToEName, listEName, sigEName, recConEName, recUpdEName, @@ -1709,7 +1768,7 @@ varStrictTypeName, -- Type forallTName, varTName, conTName, appTName, - tupleTName, arrowTName, listTName, sigTName, + tupleTName, unboxedTupleTName, arrowTName, listTName, sigTName, -- TyVarBndr plainTVName, kindedTVName, -- Kind @@ -1719,7 +1778,7 @@ -- Safety unsafeName, safeName, - threadsafeName, + interruptibleName, -- InlineSpec inlineSpecNoPhaseName, inlineSpecPhaseName, -- FunDep @@ -1803,11 +1862,12 @@ rationalLName = libFun (fsLit "rationalL") rationalLIdKey -- data Pat = ... -litPName, varPName, tupPName, conPName, infixPName, tildePName, bangPName, +litPName, varPName, tupPName, unboxedTupPName, conPName, infixPName, tildePName, bangPName, asPName, wildPName, recPName, listPName, sigPName, viewPName :: Name litPName = libFun (fsLit "litP") litPIdKey varPName = libFun (fsLit "varP") varPIdKey tupPName = libFun (fsLit "tupP") tupPIdKey +unboxedTupPName = libFun (fsLit "unboxedTupP") unboxedTupPIdKey conPName = libFun (fsLit "conP") conPIdKey infixPName = libFun (fsLit "infixP") infixPIdKey tildePName = libFun (fsLit "tildeP") tildePIdKey @@ -1833,7 +1893,7 @@ -- data Exp = ... varEName, conEName, litEName, appEName, infixEName, infixAppName, - sectionLName, sectionRName, lamEName, tupEName, condEName, + sectionLName, sectionRName, lamEName, tupEName, unboxedTupEName, condEName, letEName, caseEName, doEName, compEName :: Name varEName = libFun (fsLit "varE") varEIdKey conEName = libFun (fsLit "conE") conEIdKey @@ -1845,6 +1905,7 @@ sectionRName = libFun (fsLit "sectionR") sectionRIdKey lamEName = libFun (fsLit "lamE") lamEIdKey tupEName = libFun (fsLit "tupE") tupEIdKey +unboxedTupEName = libFun (fsLit "unboxedTupE") unboxedTupEIdKey condEName = libFun (fsLit "condE") condEIdKey letEName = libFun (fsLit "letE") letEIdKey caseEName = libFun (fsLit "caseE") caseEIdKey @@ -1937,12 +1998,13 @@ varStrictTypeName = libFun (fsLit "varStrictType") varStrictTKey -- data Type = ... -forallTName, varTName, conTName, tupleTName, arrowTName, +forallTName, varTName, conTName, tupleTName, unboxedTupleTName, arrowTName, listTName, appTName, sigTName :: Name forallTName = libFun (fsLit "forallT") forallTIdKey varTName = libFun (fsLit "varT") varTIdKey conTName = libFun (fsLit "conT") conTIdKey tupleTName = libFun (fsLit "tupleT") tupleTIdKey +unboxedTupleTName = libFun (fsLit "unboxedTupleT") unboxedTupleTIdKey arrowTName = libFun (fsLit "arrowT") arrowTIdKey listTName = libFun (fsLit "listT") listTIdKey appTName = libFun (fsLit "appT") appTIdKey @@ -1964,10 +2026,10 @@ stdCallName = libFun (fsLit "stdCall") stdCallIdKey -- data Safety = ... -unsafeName, safeName, threadsafeName :: Name +unsafeName, safeName, interruptibleName :: Name unsafeName = libFun (fsLit "unsafe") unsafeIdKey safeName = libFun (fsLit "safe") safeIdKey -threadsafeName = libFun (fsLit "threadsafe") threadsafeIdKey +interruptibleName = libFun (fsLit "interruptible") interruptibleIdKey -- data InlineSpec = ... inlineSpecNoPhaseName, inlineSpecPhaseName :: Name @@ -2009,7 +2071,7 @@ quoteDecName = qqFun (fsLit "quoteDec") quoteDecKey quoteTypeName = qqFun (fsLit "quoteType") quoteTypeKey --- TyConUniques available: 100-129 +-- TyConUniques available: 200-299 -- Check in PrelNames if you want to change this expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey, @@ -2019,33 +2081,33 @@ fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey, fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey, predQTyConKey, decsQTyConKey :: Unique -expTyConKey = mkPreludeTyConUnique 100 -matchTyConKey = mkPreludeTyConUnique 101 -clauseTyConKey = mkPreludeTyConUnique 102 -qTyConKey = mkPreludeTyConUnique 103 -expQTyConKey = mkPreludeTyConUnique 104 -decQTyConKey = mkPreludeTyConUnique 105 -patTyConKey = mkPreludeTyConUnique 106 -matchQTyConKey = mkPreludeTyConUnique 107 -clauseQTyConKey = mkPreludeTyConUnique 108 -stmtQTyConKey = mkPreludeTyConUnique 109 -conQTyConKey = mkPreludeTyConUnique 110 -typeQTyConKey = mkPreludeTyConUnique 111 -typeTyConKey = mkPreludeTyConUnique 112 -decTyConKey = mkPreludeTyConUnique 113 -varStrictTypeQTyConKey = mkPreludeTyConUnique 114 -strictTypeQTyConKey = mkPreludeTyConUnique 115 -fieldExpTyConKey = mkPreludeTyConUnique 116 -fieldPatTyConKey = mkPreludeTyConUnique 117 -nameTyConKey = mkPreludeTyConUnique 118 -patQTyConKey = mkPreludeTyConUnique 119 -fieldPatQTyConKey = mkPreludeTyConUnique 120 -fieldExpQTyConKey = mkPreludeTyConUnique 121 -funDepTyConKey = mkPreludeTyConUnique 122 -predTyConKey = mkPreludeTyConUnique 123 -predQTyConKey = mkPreludeTyConUnique 124 -tyVarBndrTyConKey = mkPreludeTyConUnique 125 -decsQTyConKey = mkPreludeTyConUnique 126 +expTyConKey = mkPreludeTyConUnique 200 +matchTyConKey = mkPreludeTyConUnique 201 +clauseTyConKey = mkPreludeTyConUnique 202 +qTyConKey = mkPreludeTyConUnique 203 +expQTyConKey = mkPreludeTyConUnique 204 +decQTyConKey = mkPreludeTyConUnique 205 +patTyConKey = mkPreludeTyConUnique 206 +matchQTyConKey = mkPreludeTyConUnique 207 +clauseQTyConKey = mkPreludeTyConUnique 208 +stmtQTyConKey = mkPreludeTyConUnique 209 +conQTyConKey = mkPreludeTyConUnique 210 +typeQTyConKey = mkPreludeTyConUnique 211 +typeTyConKey = mkPreludeTyConUnique 212 +decTyConKey = mkPreludeTyConUnique 213 +varStrictTypeQTyConKey = mkPreludeTyConUnique 214 +strictTypeQTyConKey = mkPreludeTyConUnique 215 +fieldExpTyConKey = mkPreludeTyConUnique 216 +fieldPatTyConKey = mkPreludeTyConUnique 217 +nameTyConKey = mkPreludeTyConUnique 218 +patQTyConKey = mkPreludeTyConUnique 219 +fieldPatQTyConKey = mkPreludeTyConUnique 220 +fieldExpQTyConKey = mkPreludeTyConUnique 221 +funDepTyConKey = mkPreludeTyConUnique 222 +predTyConKey = mkPreludeTyConUnique 223 +predQTyConKey = mkPreludeTyConUnique 224 +tyVarBndrTyConKey = mkPreludeTyConUnique 225 +decsQTyConKey = mkPreludeTyConUnique 226 -- IdUniques available: 200-399 -- If you want to change this, make sure you check in PrelNames @@ -2068,201 +2130,205 @@ -- data Lit = ... charLIdKey, stringLIdKey, integerLIdKey, intPrimLIdKey, wordPrimLIdKey, floatPrimLIdKey, doublePrimLIdKey, rationalLIdKey :: Unique -charLIdKey = mkPreludeMiscIdUnique 210 -stringLIdKey = mkPreludeMiscIdUnique 211 -integerLIdKey = mkPreludeMiscIdUnique 212 -intPrimLIdKey = mkPreludeMiscIdUnique 213 -wordPrimLIdKey = mkPreludeMiscIdUnique 214 -floatPrimLIdKey = mkPreludeMiscIdUnique 215 -doublePrimLIdKey = mkPreludeMiscIdUnique 216 -rationalLIdKey = mkPreludeMiscIdUnique 217 +charLIdKey = mkPreludeMiscIdUnique 220 +stringLIdKey = mkPreludeMiscIdUnique 221 +integerLIdKey = mkPreludeMiscIdUnique 222 +intPrimLIdKey = mkPreludeMiscIdUnique 223 +wordPrimLIdKey = mkPreludeMiscIdUnique 224 +floatPrimLIdKey = mkPreludeMiscIdUnique 225 +doublePrimLIdKey = mkPreludeMiscIdUnique 226 +rationalLIdKey = mkPreludeMiscIdUnique 227 liftStringIdKey :: Unique -liftStringIdKey = mkPreludeMiscIdUnique 218 +liftStringIdKey = mkPreludeMiscIdUnique 228 -- data Pat = ... -litPIdKey, varPIdKey, tupPIdKey, conPIdKey, infixPIdKey, tildePIdKey, bangPIdKey, +litPIdKey, varPIdKey, tupPIdKey, unboxedTupPIdKey, conPIdKey, infixPIdKey, tildePIdKey, bangPIdKey, asPIdKey, wildPIdKey, recPIdKey, listPIdKey, sigPIdKey, viewPIdKey :: Unique -litPIdKey = mkPreludeMiscIdUnique 220 -varPIdKey = mkPreludeMiscIdUnique 221 -tupPIdKey = mkPreludeMiscIdUnique 222 -conPIdKey = mkPreludeMiscIdUnique 223 -infixPIdKey = mkPreludeMiscIdUnique 312 -tildePIdKey = mkPreludeMiscIdUnique 224 -bangPIdKey = mkPreludeMiscIdUnique 359 -asPIdKey = mkPreludeMiscIdUnique 225 -wildPIdKey = mkPreludeMiscIdUnique 226 -recPIdKey = mkPreludeMiscIdUnique 227 -listPIdKey = mkPreludeMiscIdUnique 228 -sigPIdKey = mkPreludeMiscIdUnique 229 -viewPIdKey = mkPreludeMiscIdUnique 360 +litPIdKey = mkPreludeMiscIdUnique 240 +varPIdKey = mkPreludeMiscIdUnique 241 +tupPIdKey = mkPreludeMiscIdUnique 242 +unboxedTupPIdKey = mkPreludeMiscIdUnique 243 +conPIdKey = mkPreludeMiscIdUnique 244 +infixPIdKey = mkPreludeMiscIdUnique 245 +tildePIdKey = mkPreludeMiscIdUnique 246 +bangPIdKey = mkPreludeMiscIdUnique 247 +asPIdKey = mkPreludeMiscIdUnique 248 +wildPIdKey = mkPreludeMiscIdUnique 249 +recPIdKey = mkPreludeMiscIdUnique 250 +listPIdKey = mkPreludeMiscIdUnique 251 +sigPIdKey = mkPreludeMiscIdUnique 252 +viewPIdKey = mkPreludeMiscIdUnique 253 -- type FieldPat = ... fieldPatIdKey :: Unique -fieldPatIdKey = mkPreludeMiscIdUnique 230 +fieldPatIdKey = mkPreludeMiscIdUnique 260 -- data Match = ... matchIdKey :: Unique -matchIdKey = mkPreludeMiscIdUnique 231 +matchIdKey = mkPreludeMiscIdUnique 261 -- data Clause = ... clauseIdKey :: Unique -clauseIdKey = mkPreludeMiscIdUnique 232 +clauseIdKey = mkPreludeMiscIdUnique 262 -- data Exp = ... varEIdKey, conEIdKey, litEIdKey, appEIdKey, infixEIdKey, infixAppIdKey, - sectionLIdKey, sectionRIdKey, lamEIdKey, tupEIdKey, condEIdKey, + sectionLIdKey, sectionRIdKey, lamEIdKey, tupEIdKey, unboxedTupEIdKey, + condEIdKey, letEIdKey, caseEIdKey, doEIdKey, compEIdKey, fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey, listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey :: Unique -varEIdKey = mkPreludeMiscIdUnique 240 -conEIdKey = mkPreludeMiscIdUnique 241 -litEIdKey = mkPreludeMiscIdUnique 242 -appEIdKey = mkPreludeMiscIdUnique 243 -infixEIdKey = mkPreludeMiscIdUnique 244 -infixAppIdKey = mkPreludeMiscIdUnique 245 -sectionLIdKey = mkPreludeMiscIdUnique 246 -sectionRIdKey = mkPreludeMiscIdUnique 247 -lamEIdKey = mkPreludeMiscIdUnique 248 -tupEIdKey = mkPreludeMiscIdUnique 249 -condEIdKey = mkPreludeMiscIdUnique 250 -letEIdKey = mkPreludeMiscIdUnique 251 -caseEIdKey = mkPreludeMiscIdUnique 252 -doEIdKey = mkPreludeMiscIdUnique 253 -compEIdKey = mkPreludeMiscIdUnique 254 -fromEIdKey = mkPreludeMiscIdUnique 255 -fromThenEIdKey = mkPreludeMiscIdUnique 256 -fromToEIdKey = mkPreludeMiscIdUnique 257 -fromThenToEIdKey = mkPreludeMiscIdUnique 258 -listEIdKey = mkPreludeMiscIdUnique 259 -sigEIdKey = mkPreludeMiscIdUnique 260 -recConEIdKey = mkPreludeMiscIdUnique 261 -recUpdEIdKey = mkPreludeMiscIdUnique 262 +varEIdKey = mkPreludeMiscIdUnique 270 +conEIdKey = mkPreludeMiscIdUnique 271 +litEIdKey = mkPreludeMiscIdUnique 272 +appEIdKey = mkPreludeMiscIdUnique 273 +infixEIdKey = mkPreludeMiscIdUnique 274 +infixAppIdKey = mkPreludeMiscIdUnique 275 +sectionLIdKey = mkPreludeMiscIdUnique 276 +sectionRIdKey = mkPreludeMiscIdUnique 277 +lamEIdKey = mkPreludeMiscIdUnique 278 +tupEIdKey = mkPreludeMiscIdUnique 279 +unboxedTupEIdKey = mkPreludeMiscIdUnique 280 +condEIdKey = mkPreludeMiscIdUnique 281 +letEIdKey = mkPreludeMiscIdUnique 282 +caseEIdKey = mkPreludeMiscIdUnique 283 +doEIdKey = mkPreludeMiscIdUnique 284 +compEIdKey = mkPreludeMiscIdUnique 285 +fromEIdKey = mkPreludeMiscIdUnique 286 +fromThenEIdKey = mkPreludeMiscIdUnique 287 +fromToEIdKey = mkPreludeMiscIdUnique 288 +fromThenToEIdKey = mkPreludeMiscIdUnique 289 +listEIdKey = mkPreludeMiscIdUnique 290 +sigEIdKey = mkPreludeMiscIdUnique 291 +recConEIdKey = mkPreludeMiscIdUnique 292 +recUpdEIdKey = mkPreludeMiscIdUnique 293 -- type FieldExp = ... fieldExpIdKey :: Unique -fieldExpIdKey = mkPreludeMiscIdUnique 265 +fieldExpIdKey = mkPreludeMiscIdUnique 310 -- data Body = ... guardedBIdKey, normalBIdKey :: Unique -guardedBIdKey = mkPreludeMiscIdUnique 266 -normalBIdKey = mkPreludeMiscIdUnique 267 +guardedBIdKey = mkPreludeMiscIdUnique 311 +normalBIdKey = mkPreludeMiscIdUnique 312 -- data Guard = ... normalGEIdKey, patGEIdKey :: Unique -normalGEIdKey = mkPreludeMiscIdUnique 310 -patGEIdKey = mkPreludeMiscIdUnique 311 +normalGEIdKey = mkPreludeMiscIdUnique 313 +patGEIdKey = mkPreludeMiscIdUnique 314 -- data Stmt = ... bindSIdKey, letSIdKey, noBindSIdKey, parSIdKey :: Unique -bindSIdKey = mkPreludeMiscIdUnique 268 -letSIdKey = mkPreludeMiscIdUnique 269 -noBindSIdKey = mkPreludeMiscIdUnique 270 -parSIdKey = mkPreludeMiscIdUnique 271 +bindSIdKey = mkPreludeMiscIdUnique 320 +letSIdKey = mkPreludeMiscIdUnique 321 +noBindSIdKey = mkPreludeMiscIdUnique 322 +parSIdKey = mkPreludeMiscIdUnique 323 -- data Dec = ... funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, classDIdKey, instanceDIdKey, sigDIdKey, forImpDIdKey, pragInlDIdKey, pragSpecDIdKey, pragSpecInlDIdKey, familyNoKindDIdKey, familyKindDIdKey, dataInstDIdKey, newtypeInstDIdKey, tySynInstDIdKey :: Unique -funDIdKey = mkPreludeMiscIdUnique 272 -valDIdKey = mkPreludeMiscIdUnique 273 -dataDIdKey = mkPreludeMiscIdUnique 274 -newtypeDIdKey = mkPreludeMiscIdUnique 275 -tySynDIdKey = mkPreludeMiscIdUnique 276 -classDIdKey = mkPreludeMiscIdUnique 277 -instanceDIdKey = mkPreludeMiscIdUnique 278 -sigDIdKey = mkPreludeMiscIdUnique 279 -forImpDIdKey = mkPreludeMiscIdUnique 297 -pragInlDIdKey = mkPreludeMiscIdUnique 348 -pragSpecDIdKey = mkPreludeMiscIdUnique 349 -pragSpecInlDIdKey = mkPreludeMiscIdUnique 352 -familyNoKindDIdKey= mkPreludeMiscIdUnique 340 -familyKindDIdKey = mkPreludeMiscIdUnique 353 -dataInstDIdKey = mkPreludeMiscIdUnique 341 -newtypeInstDIdKey = mkPreludeMiscIdUnique 342 -tySynInstDIdKey = mkPreludeMiscIdUnique 343 +funDIdKey = mkPreludeMiscIdUnique 330 +valDIdKey = mkPreludeMiscIdUnique 331 +dataDIdKey = mkPreludeMiscIdUnique 332 +newtypeDIdKey = mkPreludeMiscIdUnique 333 +tySynDIdKey = mkPreludeMiscIdUnique 334 +classDIdKey = mkPreludeMiscIdUnique 335 +instanceDIdKey = mkPreludeMiscIdUnique 336 +sigDIdKey = mkPreludeMiscIdUnique 337 +forImpDIdKey = mkPreludeMiscIdUnique 338 +pragInlDIdKey = mkPreludeMiscIdUnique 339 +pragSpecDIdKey = mkPreludeMiscIdUnique 340 +pragSpecInlDIdKey = mkPreludeMiscIdUnique 341 +familyNoKindDIdKey = mkPreludeMiscIdUnique 342 +familyKindDIdKey = mkPreludeMiscIdUnique 343 +dataInstDIdKey = mkPreludeMiscIdUnique 344 +newtypeInstDIdKey = mkPreludeMiscIdUnique 345 +tySynInstDIdKey = mkPreludeMiscIdUnique 346 -- type Cxt = ... cxtIdKey :: Unique -cxtIdKey = mkPreludeMiscIdUnique 280 +cxtIdKey = mkPreludeMiscIdUnique 360 -- data Pred = ... classPIdKey, equalPIdKey :: Unique -classPIdKey = mkPreludeMiscIdUnique 346 -equalPIdKey = mkPreludeMiscIdUnique 347 +classPIdKey = mkPreludeMiscIdUnique 361 +equalPIdKey = mkPreludeMiscIdUnique 362 -- data Strict = ... isStrictKey, notStrictKey :: Unique -isStrictKey = mkPreludeMiscIdUnique 281 -notStrictKey = mkPreludeMiscIdUnique 282 +isStrictKey = mkPreludeMiscIdUnique 363 +notStrictKey = mkPreludeMiscIdUnique 364 -- data Con = ... normalCIdKey, recCIdKey, infixCIdKey, forallCIdKey :: Unique -normalCIdKey = mkPreludeMiscIdUnique 283 -recCIdKey = mkPreludeMiscIdUnique 284 -infixCIdKey = mkPreludeMiscIdUnique 285 -forallCIdKey = mkPreludeMiscIdUnique 288 +normalCIdKey = mkPreludeMiscIdUnique 370 +recCIdKey = mkPreludeMiscIdUnique 371 +infixCIdKey = mkPreludeMiscIdUnique 372 +forallCIdKey = mkPreludeMiscIdUnique 373 -- type StrictType = ... strictTKey :: Unique -strictTKey = mkPreludeMiscIdUnique 286 +strictTKey = mkPreludeMiscIdUnique 374 -- type VarStrictType = ... varStrictTKey :: Unique -varStrictTKey = mkPreludeMiscIdUnique 287 +varStrictTKey = mkPreludeMiscIdUnique 375 -- data Type = ... -forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, arrowTIdKey, +forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, unboxedTupleTIdKey, arrowTIdKey, listTIdKey, appTIdKey, sigTIdKey :: Unique -forallTIdKey = mkPreludeMiscIdUnique 290 -varTIdKey = mkPreludeMiscIdUnique 291 -conTIdKey = mkPreludeMiscIdUnique 292 -tupleTIdKey = mkPreludeMiscIdUnique 294 -arrowTIdKey = mkPreludeMiscIdUnique 295 -listTIdKey = mkPreludeMiscIdUnique 296 -appTIdKey = mkPreludeMiscIdUnique 293 -sigTIdKey = mkPreludeMiscIdUnique 358 +forallTIdKey = mkPreludeMiscIdUnique 380 +varTIdKey = mkPreludeMiscIdUnique 381 +conTIdKey = mkPreludeMiscIdUnique 382 +tupleTIdKey = mkPreludeMiscIdUnique 383 +unboxedTupleTIdKey = mkPreludeMiscIdUnique 384 +arrowTIdKey = mkPreludeMiscIdUnique 385 +listTIdKey = mkPreludeMiscIdUnique 386 +appTIdKey = mkPreludeMiscIdUnique 387 +sigTIdKey = mkPreludeMiscIdUnique 388 -- data TyVarBndr = ... plainTVIdKey, kindedTVIdKey :: Unique -plainTVIdKey = mkPreludeMiscIdUnique 354 -kindedTVIdKey = mkPreludeMiscIdUnique 355 +plainTVIdKey = mkPreludeMiscIdUnique 390 +kindedTVIdKey = mkPreludeMiscIdUnique 391 -- data Kind = ... starKIdKey, arrowKIdKey :: Unique -starKIdKey = mkPreludeMiscIdUnique 356 -arrowKIdKey = mkPreludeMiscIdUnique 357 +starKIdKey = mkPreludeMiscIdUnique 392 +arrowKIdKey = mkPreludeMiscIdUnique 393 -- data Callconv = ... cCallIdKey, stdCallIdKey :: Unique -cCallIdKey = mkPreludeMiscIdUnique 300 -stdCallIdKey = mkPreludeMiscIdUnique 301 +cCallIdKey = mkPreludeMiscIdUnique 394 +stdCallIdKey = mkPreludeMiscIdUnique 395 -- data Safety = ... -unsafeIdKey, safeIdKey, threadsafeIdKey :: Unique -unsafeIdKey = mkPreludeMiscIdUnique 305 -safeIdKey = mkPreludeMiscIdUnique 306 -threadsafeIdKey = mkPreludeMiscIdUnique 307 +unsafeIdKey, safeIdKey, interruptibleIdKey :: Unique +unsafeIdKey = mkPreludeMiscIdUnique 400 +safeIdKey = mkPreludeMiscIdUnique 401 +interruptibleIdKey = mkPreludeMiscIdUnique 403 -- data InlineSpec = inlineSpecNoPhaseIdKey, inlineSpecPhaseIdKey :: Unique -inlineSpecNoPhaseIdKey = mkPreludeMiscIdUnique 350 -inlineSpecPhaseIdKey = mkPreludeMiscIdUnique 351 +inlineSpecNoPhaseIdKey = mkPreludeMiscIdUnique 404 +inlineSpecPhaseIdKey = mkPreludeMiscIdUnique 405 -- data FunDep = ... funDepIdKey :: Unique -funDepIdKey = mkPreludeMiscIdUnique 320 +funDepIdKey = mkPreludeMiscIdUnique 406 -- data FamFlavour = ... typeFamIdKey, dataFamIdKey :: Unique -typeFamIdKey = mkPreludeMiscIdUnique 344 -dataFamIdKey = mkPreludeMiscIdUnique 345 +typeFamIdKey = mkPreludeMiscIdUnique 407 +dataFamIdKey = mkPreludeMiscIdUnique 408 -- quasiquoting quoteExpKey, quotePatKey, quoteDecKey, quoteTypeKey :: Unique -quoteExpKey = mkPreludeMiscIdUnique 321 -quotePatKey = mkPreludeMiscIdUnique 322 -quoteDecKey = mkPreludeMiscIdUnique 323 -quoteTypeKey = mkPreludeMiscIdUnique 324 +quoteExpKey = mkPreludeMiscIdUnique 410 +quotePatKey = mkPreludeMiscIdUnique 411 +quoteDecKey = mkPreludeMiscIdUnique 412 +quoteTypeKey = mkPreludeMiscIdUnique 413 diff -Nru ghc-7.0.3/compiler/deSugar/DsMonad.lhs ghc-7.2.1/compiler/deSugar/DsMonad.lhs --- ghc-7.0.3/compiler/deSugar/DsMonad.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/deSugar/DsMonad.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -9,18 +9,19 @@ module DsMonad ( DsM, mapM, mapAndUnzipM, initDs, initDsTc, fixDs, - foldlM, foldrM, ifDOptM, unsetOptM, + foldlM, foldrM, ifDOptM, unsetDOptM, unsetWOptM, Applicative(..),(<$>), - newLocalName, - duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId, - newFailLocalDs, newPredVarDs, - getSrcSpanDs, putSrcSpanDs, - getModuleDs, - newUnique, - UniqSupply, newUniqueSupply, - getDOptsDs, getGhcModeDs, doptDs, - dsLookupGlobal, dsLookupGlobalId, dsLookupTyCon, dsLookupDataCon, + newLocalName, + duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId, + newFailLocalDs, newPredVarDs, + getSrcSpanDs, putSrcSpanDs, + getModuleDs, + mkPrintUnqualifiedDs, + newUnique, + UniqSupply, newUniqueSupply, + getDOptsDs, getGhcModeDs, doptDs, woptDs, + dsLookupGlobal, dsLookupGlobalId, dsLookupDPHId, dsLookupTyCon, dsLookupDataCon, dsLookupClass, DsMetaEnv, DsMetaVal(..), dsLookupMetaEnv, dsExtendMetaEnv, @@ -256,6 +257,9 @@ doptDs :: DynFlag -> TcRnIf gbl lcl Bool doptDs = doptM +woptDs :: WarningFlag -> TcRnIf gbl lcl Bool +woptDs = woptM + getGhcModeDs :: DsM GhcMode getGhcModeDs = getDOptsDs >>= return . ghcMode @@ -282,6 +286,9 @@ ; let msg = mkErrMsg loc (ds_unqual env) err ; updMutVar (ds_msgs env) (\ (w,e) -> (w, e `snocBag` msg)) ; failM } + +mkPrintUnqualifiedDs :: DsM PrintUnqualified +mkPrintUnqualifiedDs = ds_unqual <$> getGblEnv \end{code} \begin{code} @@ -299,6 +306,19 @@ dsLookupGlobalId name = tyThingId <$> dsLookupGlobal name +-- Looking up a global DPH 'Id' is like 'dsLookupGlobalId', but the package, in which the looked +-- up name is located, varies with the active DPH backend. +-- +dsLookupDPHId :: (PackageId -> Name) -> DsM Id +dsLookupDPHId nameInPkg + = do { dflags <- getDOpts + ; case dphPackageMaybe dflags of + Just pkg -> tyThingId <$> dsLookupGlobal (nameInPkg pkg) + Nothing -> failWithDs $ ptext err + } + where + err = sLit "To use -XParallelArrays select a DPH backend with -fdph-par or -fdph-seq" + dsLookupTyCon :: Name -> DsM TyCon dsLookupTyCon name = tyThingTyCon <$> dsLookupGlobal name diff -Nru ghc-7.0.3/compiler/deSugar/DsUtils.lhs ghc-7.2.1/compiler/deSugar/DsUtils.lhs --- ghc-7.0.3/compiler/deSugar/DsUtils.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/deSugar/DsUtils.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -53,7 +53,6 @@ import MkCore import MkId import Id -import Var import Name import Literal import TyCon @@ -75,7 +74,6 @@ \end{code} - %************************************************************************ %* * Rebindable syntax @@ -256,10 +254,9 @@ wrapBinds ((new,old):prs) e = wrapBind new old (wrapBinds prs e) wrapBind :: Var -> Var -> CoreExpr -> CoreExpr -wrapBind new old body -- Can deal with term variables *or* type variables - | new==old = body - | isTyCoVar new = Let (mkTyBind new (mkTyVarTy old)) body - | otherwise = Let (NonRec new (Var old)) body +wrapBind new old body -- NB: this function must deal with term + | new==old = body -- variables, type variables or coercion variables + | otherwise = Let (NonRec new (varToCoreExpr old)) body seqVar :: Var -> CoreExpr -> CoreExpr seqVar var body = Case (Var var) var (exprType body) @@ -299,10 +296,11 @@ return (LitAlt lit, [], body) -mkCoAlgCaseMatchResult :: Id -- Scrutinee - -> Type -- Type of exp - -> [(DataCon, [CoreBndr], MatchResult)] -- Alternatives - -> MatchResult +mkCoAlgCaseMatchResult + :: Id -- Scrutinee + -> Type -- Type of exp + -> [(DataCon, [CoreBndr], MatchResult)] -- Alternatives (bndrs *include* tyvars, dicts) + -> MatchResult mkCoAlgCaseMatchResult var ty match_alts | isNewTyCon tycon -- Newtype case; use a let = ASSERT( null (tail match_alts) && null (tail arg_ids1) ) @@ -383,7 +381,7 @@ isPArrFakeAlts [] = panic "DsUtils: unexpectedly found an empty list of PArr fake alternatives" -- mk_parrCase fail = do - lengthP <- dsLookupGlobalId lengthPName + lengthP <- dsLookupDPHId lengthPName alt <- unboxAlt return (mkWildCase (len lengthP) intTy ty [alt]) where @@ -395,7 +393,7 @@ -- unboxAlt = do l <- newSysLocalDs intPrimTy - indexP <- dsLookupGlobalId indexPName + indexP <- dsLookupDPHId indexPName alts <- mapM (mkAlt indexP) sorted_alts return (DataAlt intDataCon, [l], mkWildCase (Var l) intPrimTy ty (dft : alts)) where @@ -605,7 +603,7 @@ return (bndr_var, rhs_expr) where error_expr = mkCoerce co (Var err_var) - co = mkUnsafeCoercion (exprType (Var err_var)) (idType bndr_var) + co = mkUnsafeCo (exprType (Var err_var)) (idType bndr_var) is_simple_lpat p = is_simple_pat (unLoc p) diff -Nru ghc-7.0.3/compiler/deSugar/MatchCon.lhs ghc-7.2.1/compiler/deSugar/MatchCon.lhs --- ghc-7.0.3/compiler/deSugar/MatchCon.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/deSugar/MatchCon.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -28,7 +28,6 @@ import Util ( all2, takeList, zipEqual ) import ListSetOps ( runs ) import Id -import Var ( Var ) import NameEnv import SrcLoc import Outputable diff -Nru ghc-7.0.3/compiler/deSugar/Match.lhs ghc-7.2.1/compiler/deSugar/Match.lhs --- ghc-7.0.3/compiler/deSugar/Match.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/deSugar/Match.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -29,6 +29,7 @@ import MatchCon import MatchLit import Type +import Coercion import TysWiredIn import ListSetOps import SrcLoc @@ -38,6 +39,7 @@ import Outputable import FastString +import Control.Monad( when ) import qualified Data.Map as Map \end{code} @@ -55,9 +57,9 @@ -> [EquationInfo] -- Info about patterns, etc. (type synonym below) -> DsM MatchResult -- Desugared result! -matchCheck ctx vars ty qs = do - dflags <- getDOptsDs - matchCheck_really dflags ctx vars ty qs +matchCheck ctx vars ty qs + = do { dflags <- getDOptsDs + ; matchCheck_really dflags ctx vars ty qs } matchCheck_really :: DynFlags -> DsMatchContext @@ -65,28 +67,31 @@ -> Type -> [EquationInfo] -> DsM MatchResult -matchCheck_really dflags ctx vars ty qs - | incomplete && shadow = do - dsShadowWarn ctx eqns_shadow - dsIncompleteWarn ctx pats - match vars ty qs - | incomplete = do - dsIncompleteWarn ctx pats - match vars ty qs - | shadow = do - dsShadowWarn ctx eqns_shadow - match vars ty qs - | otherwise = - match vars ty qs - where (pats, eqns_shadow) = check qs - incomplete = want_incomplete && (notNull pats) - want_incomplete = case ctx of - DsMatchContext RecUpd _ -> - dopt Opt_WarnIncompletePatternsRecUpd dflags - _ -> - dopt Opt_WarnIncompletePatterns dflags - shadow = dopt Opt_WarnOverlappingPatterns dflags - && not (null eqns_shadow) +matchCheck_really dflags ctx@(DsMatchContext hs_ctx _) vars ty qs + = do { when shadow (dsShadowWarn ctx eqns_shadow) + ; when incomplete (dsIncompleteWarn ctx pats) + ; match vars ty qs } + where + (pats, eqns_shadow) = check qs + incomplete = incomplete_flag hs_ctx && (notNull pats) + shadow = wopt Opt_WarnOverlappingPatterns dflags + && notNull eqns_shadow + + incomplete_flag :: HsMatchContext id -> Bool + incomplete_flag (FunRhs {}) = wopt Opt_WarnIncompletePatterns dflags + incomplete_flag CaseAlt = wopt Opt_WarnIncompletePatterns dflags + + incomplete_flag LambdaExpr = wopt Opt_WarnIncompleteUniPatterns dflags + incomplete_flag PatBindRhs = wopt Opt_WarnIncompleteUniPatterns dflags + incomplete_flag ProcExpr = wopt Opt_WarnIncompleteUniPatterns dflags + + incomplete_flag RecUpd = wopt Opt_WarnIncompletePatternsRecUpd dflags + + incomplete_flag ThPatQuote = False + incomplete_flag (StmtCtxt {}) = False -- Don't warn about incomplete patterns + -- in list comprehensions, pattern guards + -- etc. They are often *supposed* to be + -- incomplete \end{code} This variable shows the maximum number of lines of output generated for warnings. @@ -280,13 +285,13 @@ = ASSERT( not (null eqns ) ) do { -- Tidy the first pattern, generating -- auxiliary bindings if necessary - (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns + (aux_binds, tidy_eqns) <- mapAndUnzipM (tidyEqnInfo v) eqns -- Group the equations and match each group in turn - ; let grouped = groupEquations tidy_eqns + ; let grouped = groupEquations tidy_eqns -- print the view patterns that are commoned up to help debug - ; ifDOptM Opt_D_dump_view_pattern_commoning (debug grouped) + ; ifDOptM Opt_D_dump_view_pattern_commoning (debug grouped) ; match_results <- mapM match_group grouped ; return (adjustMatchResult (foldr1 (.) aux_binds) $ @@ -468,11 +473,6 @@ tidy1 v (VarPat var) = return (wrapBind var v, WildPat (idType var)) -tidy1 v (VarPatOut var binds) - = do { ds_ev_binds <- dsTcEvBinds binds - ; return (wrapBind var v . wrapDsEvBinds ds_ev_binds, - WildPat (idType var)) } - -- case v of { x@p -> mr[] } -- = case v of { p -> let x=v in mr[] } tidy1 v (AsPat (L _ var) pat) @@ -523,14 +523,13 @@ -- NPats: we *might* be able to replace these w/ a simpler form tidy1 _ (NPat lit mb_neg eq) - = return (idDsWrapper, tidyNPat lit mb_neg eq) + = return (idDsWrapper, tidyNPat tidyLitPat lit mb_neg eq) -- BangPatterns: Pattern matching is already strict in constructors, -- tuples etc, so the last case strips off the bang for thoses patterns. tidy1 v (BangPat (L _ (LazyPat p))) = tidy1 v (BangPat p) tidy1 v (BangPat (L _ (ParPat p))) = tidy1 v (BangPat p) tidy1 _ p@(BangPat (L _(VarPat _))) = return (idDsWrapper, p) -tidy1 _ p@(BangPat (L _(VarPatOut _ _))) = return (idDsWrapper, p) tidy1 _ p@(BangPat (L _ (WildPat _))) = return (idDsWrapper, p) tidy1 _ p@(BangPat (L _ (CoPat _ _ _))) = return (idDsWrapper, p) tidy1 _ p@(BangPat (L _ (SigPatIn _ _))) = return (idDsWrapper, p) @@ -741,19 +740,21 @@ match_result' <- matchSinglePat scrut hs_ctx pat rhs_ty match_result extractMatchResult match_result' fail_expr - matchSinglePat :: CoreExpr -> HsMatchContext Name -> LPat Id -> Type -> MatchResult -> DsM MatchResult -- Do not warn about incomplete patterns -- Used for things like [ e | pat <- stuff ], where -- incomplete patterns are just fine -matchSinglePat (Var var) _ (L _ pat) ty match_result - = match [var] ty [EqnInfo { eqn_pats = [pat], eqn_rhs = match_result }] - -matchSinglePat scrut hs_ctx pat ty match_result = do - var <- selectSimpleMatchVarL pat - match_result' <- matchSinglePat (Var var) hs_ctx pat ty match_result - return (adjustMatchResult (bindNonRec var scrut) match_result') +matchSinglePat (Var var) ctx (L _ pat) ty match_result + = do { locn <- getSrcSpanDs + ; matchCheck (DsMatchContext ctx locn) + [var] ty + [EqnInfo { eqn_pats = [pat], eqn_rhs = match_result }] } + +matchSinglePat scrut hs_ctx pat ty match_result + = do { var <- selectSimpleMatchVarL pat + ; match_result' <- matchSinglePat (Var var) hs_ctx pat ty match_result + ; return (adjustMatchResult (bindNonRec var scrut) match_result') } \end{code} @@ -825,7 +826,7 @@ sameGroup (PgLit _) (PgLit _) = True -- One case expression sameGroup (PgN l1) (PgN l2) = l1==l2 -- Order is significant sameGroup (PgNpK l1) (PgNpK l2) = l1==l2 -- See Note [Grouping overloaded literal patterns] -sameGroup (PgCo t1) (PgCo t2) = t1 `coreEqType` t2 +sameGroup (PgCo t1) (PgCo t2) = t1 `eqType` t2 -- CoPats are in the same goup only if the type of the -- enclosed pattern is the same. The patterns outside the CoPat -- always have the same type, so this boils down to saying that @@ -873,7 +874,7 @@ -- which resolve the overloading (e.g., fromInteger 1), -- because these expressions get written as a bunch of different variables -- (presumably to improve sharing) - tcEqType (overLitType l) (overLitType l') && l == l' + eqType (overLitType l) (overLitType l') && l == l' exp (HsApp e1 e2) (HsApp e1' e2') = lexp e1 e1' && lexp e2 e2' -- the fixities have been straightened out by now, so it's safe -- to ignore them? @@ -897,7 +898,7 @@ --------- tup_arg (Present e1) (Present e2) = lexp e1 e2 - tup_arg (Missing t1) (Missing t2) = tcEqType t1 t2 + tup_arg (Missing t1) (Missing t2) = eqType t1 t2 tup_arg _ _ = False --------- @@ -910,9 +911,9 @@ -- equating different ways of writing a coercion) wrap WpHole WpHole = True wrap (WpCompose w1 w2) (WpCompose w1' w2') = wrap w1 w1' && wrap w2 w2' - wrap (WpCast c) (WpCast c') = tcEqType c c' + wrap (WpCast c) (WpCast c') = coreEqCoercion c c' wrap (WpEvApp et1) (WpEvApp et2) = ev_term et1 et2 - wrap (WpTyApp t) (WpTyApp t') = tcEqType t t' + wrap (WpTyApp t) (WpTyApp t') = eqType t t' -- Enhancement: could implement equality for more wrappers -- if it seems useful (lams and lets) wrap _ _ = False @@ -920,7 +921,7 @@ --------- ev_term :: EvTerm -> EvTerm -> Bool ev_term (EvId a) (EvId b) = a==b - ev_term (EvCoercion a) (EvCoercion b) = tcEqType a b + ev_term (EvCoercion a) (EvCoercion b) = coreEqCoercion a b ev_term _ _ = False --------- @@ -959,3 +960,4 @@ cannot jump to the third equation! Because the same argument might match '2'! Hence we don't regard 1 and 2, or (n+1) and (n+2), as part of the same group. + diff -Nru ghc-7.0.3/compiler/deSugar/MatchLit.lhs ghc-7.2.1/compiler/deSugar/MatchLit.lhs --- ghc-7.0.3/compiler/deSugar/MatchLit.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/deSugar/MatchLit.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -33,6 +33,7 @@ import SrcLoc import Data.Ratio import Outputable +import BasicTypes import Util import FastString \end{code} @@ -64,8 +65,10 @@ dsLit (HsCharPrim c) = return (Lit (MachChar c)) dsLit (HsIntPrim i) = return (Lit (MachInt i)) dsLit (HsWordPrim w) = return (Lit (MachWord w)) -dsLit (HsFloatPrim f) = return (Lit (MachFloat f)) -dsLit (HsDoublePrim d) = return (Lit (MachDouble d)) +dsLit (HsInt64Prim i) = return (Lit (MachInt64 i)) +dsLit (HsWord64Prim w) = return (Lit (MachWord64 w)) +dsLit (HsFloatPrim f) = return (Lit (MachFloat (fl_value f))) +dsLit (HsDoublePrim d) = return (Lit (MachDouble (fl_value d))) dsLit (HsChar c) = return (mkCharExpr c) dsLit (HsString str) = mkStringExprFS str @@ -73,8 +76,8 @@ dsLit (HsInt i) = return (mkIntExpr i) dsLit (HsRat r ty) = do - num <- mkIntegerExpr (numerator r) - denom <- mkIntegerExpr (denominator r) + num <- mkIntegerExpr (numerator (fl_value r)) + denom <- mkIntegerExpr (denominator (fl_value r)) return (mkConApp ratio_data_con [Type integer_ty, num, denom]) where (ratio_data_con, integer_ty) @@ -110,10 +113,12 @@ -- others have been removed by tidy hsLitKey (HsIntPrim i) = mkMachInt i hsLitKey (HsWordPrim w) = mkMachWord w +hsLitKey (HsInt64Prim i) = mkMachInt64 i +hsLitKey (HsWord64Prim w) = mkMachWord64 w hsLitKey (HsCharPrim c) = MachChar c hsLitKey (HsStringPrim s) = MachStr s -hsLitKey (HsFloatPrim f) = MachFloat f -hsLitKey (HsDoublePrim d) = MachDouble d +hsLitKey (HsFloatPrim f) = MachFloat (fl_value f) +hsLitKey (HsDoublePrim d) = MachDouble (fl_value d) hsLitKey (HsString s) = MachStr s hsLitKey l = pprPanic "hsLitKey" (ppr l) @@ -124,8 +129,8 @@ litValKey :: OverLitVal -> Bool -> Literal litValKey (HsIntegral i) False = MachInt i litValKey (HsIntegral i) True = MachInt (-i) -litValKey (HsFractional r) False = MachFloat r -litValKey (HsFractional r) True = MachFloat (-r) +litValKey (HsFractional r) False = MachFloat (fl_value r) +litValKey (HsFractional r) True = MachFloat (negate (fl_value r)) litValKey (HsIsString s) neg = ASSERT( not neg) MachStr s \end{code} @@ -152,8 +157,14 @@ tidyLitPat lit = LitPat lit ---------------- -tidyNPat :: HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id -> Pat Id -tidyNPat (OverLit val False _ ty) mb_neg _ +tidyNPat :: (HsLit -> Pat Id) -- How to tidy a LitPat + -- We need this argument because tidyNPat is called + -- both by Match and by Check, but they tidy LitPats + -- slightly differently; and we must desugar + -- literals consistently (see Trac #5117) + -> HsOverLit Id -> Maybe (SyntaxExpr Id) -> SyntaxExpr Id + -> Pat Id +tidyNPat tidy_lit_pat (OverLit val False _ ty) mb_neg _ -- False: Take short cuts only if the literal is not using rebindable syntax -- -- Once that is settled, look for cases where the type of the @@ -169,7 +180,7 @@ | isWordTy ty, Just int_lit <- mb_int_lit = mk_con_pat wordDataCon (HsWordPrim int_lit) | isFloatTy ty, Just rat_lit <- mb_rat_lit = mk_con_pat floatDataCon (HsFloatPrim rat_lit) | isDoubleTy ty, Just rat_lit <- mb_rat_lit = mk_con_pat doubleDataCon (HsDoublePrim rat_lit) - | isStringTy ty, Just str_lit <- mb_str_lit = tidyLitPat (HsString str_lit) + | isStringTy ty, Just str_lit <- mb_str_lit = tidy_lit_pat (HsString str_lit) where mk_con_pat :: DataCon -> HsLit -> Pat Id mk_con_pat con lit = unLoc (mkPrefixConPat con [noLoc $ LitPat lit] ty) @@ -180,12 +191,12 @@ (Just _, HsIntegral i) -> Just (-i) _ -> Nothing - mb_rat_lit :: Maybe Rational + mb_rat_lit :: Maybe FractionalLit mb_rat_lit = case (mb_neg, val) of - (Nothing, HsIntegral i) -> Just (fromInteger i) - (Just _, HsIntegral i) -> Just (fromInteger (-i)) + (Nothing, HsIntegral i) -> Just (integralFractionalLit (fromInteger i)) + (Just _, HsIntegral i) -> Just (integralFractionalLit (fromInteger (-i))) (Nothing, HsFractional f) -> Just f - (Just _, HsFractional f) -> Just (-f) + (Just _, HsFractional f) -> Just (negateFractionalLit f) _ -> Nothing mb_str_lit :: Maybe FastString @@ -193,7 +204,7 @@ (Nothing, HsIsString s) -> Just s _ -> Nothing -tidyNPat over_lit mb_neg eq +tidyNPat _ over_lit mb_neg eq = NPat over_lit mb_neg eq \end{code} diff -Nru ghc-7.0.3/compiler/ghc.cabal.in ghc-7.2.1/compiler/ghc.cabal.in --- ghc-7.0.3/compiler/ghc.cabal.in 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/ghc.cabal.in 2011-08-07 17:10:05.000000000 +0000 @@ -36,22 +36,20 @@ Default: False Manual: True -Flag ncg - Description: Build the NCG. - Default: False - Manual: True - Flag stage1 Description: Is this stage 1? Default: False + Manual: True Flag stage2 Description: Is this stage 2? Default: False + Manual: True Flag stage3 Description: Is this stage 3? Default: False + Manual: True Library Exposed: False @@ -65,7 +63,7 @@ if flag(base3) || flag(base4) Build-Depends: directory >= 1 && < 1.2, - process >= 1 && < 1.1, + process >= 1 && < 1.2, bytestring >= 0.9 && < 0.10, old-time >= 1 && < 1.1, containers >= 0.1 && < 0.5, @@ -85,10 +83,8 @@ CPP-Options: -DGHCI Include-Dirs: ../libffi/build/include - if !flag(ncg) - CPP-Options: -DOMIT_NATIVE_CODEGEN - Build-Depends: bin-package-db + Build-Depends: hoopl -- GHC 6.4.2 needs to be able to find WCsubst.c, which needs to be -- able to find WCsubst.h @@ -99,6 +95,8 @@ TypeSynonymInstances, MultiParamTypeClasses, FlexibleInstances, Rank2Types, ScopedTypeVariables, DeriveDataTypeable + if impl(ghc >= 7.1) + Extensions: NondecreasingIndentation Include-Dirs: . parser utils @@ -152,6 +150,7 @@ DataCon Demand Exception + GhcMonad Id IdInfo Literal @@ -182,45 +181,38 @@ BlockId CLabel Cmm - CmmBrokenBlock CmmBuildInfoTables - CmmCPS - CmmCPSGen - CmmCPSZ + CmmPipeline CmmCallConv - CmmCommonBlockElimZ + CmmCommonBlockElim CmmContFlowOpt CmmCvt + CmmDecl CmmExpr CmmInfo CmmLex CmmLint CmmLive - CmmLiveZ + CmmMachOp + CmmNode CmmOpt CmmParse CmmProcPoint - CmmProcPointZ CmmSpillReload + CmmRewriteAssignments CmmStackLayout - CmmTx + CmmType CmmUtils - CmmZipUtil - DFMonad - Dataflow - MkZipCfg - MkZipCfgCmm + MkGraph + OldCmm + OldCmmUtils + OldPprCmm OptimizationFuel PprBase PprC PprCmm - PprCmmZ - StackColor - StackPlacements - ZipCfg - ZipCfgCmmRep - ZipCfgExtras - ZipDataflow + PprCmmDecl + PprCmmExpr Bitmap CgBindery CgCallConv @@ -321,6 +313,9 @@ ErrUtils Finder GHC + GhcMake + GhcPlugins + DynamicLoading HeaderInfo HscMain HscStats @@ -350,6 +345,7 @@ TysPrim TysWiredIn CostCentre + ProfInit SCCfinal RnBinds RnEnv @@ -423,6 +419,7 @@ Generics InstEnv TyCon + Kind Type TypeRep Unify @@ -449,6 +446,7 @@ MonadUtils OrdList Outputable + Pair Panic Pretty Serialized @@ -460,7 +458,6 @@ Vectorise.Builtins.Base Vectorise.Builtins.Initialise Vectorise.Builtins.Modules - Vectorise.Builtins.Prelude Vectorise.Builtins Vectorise.Monad.Base Vectorise.Monad.Naming @@ -472,7 +469,6 @@ Vectorise.Utils.Closure Vectorise.Utils.Hoisting Vectorise.Utils.PADict - Vectorise.Utils.PRDict Vectorise.Utils.Poly Vectorise.Utils Vectorise.Type.Env @@ -480,7 +476,6 @@ Vectorise.Type.PData Vectorise.Type.PRepr Vectorise.Type.PADict - Vectorise.Type.PRDict Vectorise.Type.Type Vectorise.Type.TyConDecl Vectorise.Type.Classify @@ -491,10 +486,7 @@ Vectorise.Exp Vectorise - -- We only need to expose more modules as some of the ncg code is used - -- by the LLVM backend so its always included - if flag(ncg) - Exposed-Modules: + Exposed-Modules: AsmCodeGen TargetReg NCGMonad @@ -504,10 +496,6 @@ RegClass PIC Platform - Alpha.Regs - Alpha.RegInfo - Alpha.Instr - Alpha.CodeGen X86.Regs X86.RegInfo X86.Instr @@ -566,7 +554,6 @@ TcSplice Convert ByteCodeAsm - ByteCodeFFI ByteCodeGen ByteCodeInstr ByteCodeItbls diff -Nru ghc-7.0.3/compiler/ghci/ByteCodeAsm.lhs ghc-7.2.1/compiler/ghci/ByteCodeAsm.lhs --- ghc-7.0.3/compiler/ghci/ByteCodeAsm.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/ghci/ByteCodeAsm.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -6,6 +6,7 @@ \begin{code} {-# OPTIONS -optc-DNON_POSIX_SOURCE #-} +{-# LANGUAGE BangPatterns #-} module ByteCodeAsm ( assembleBCOs, assembleBCO, @@ -29,7 +30,9 @@ import Constants import FastString import SMRep +import DynFlags import Outputable +import Platform import Control.Monad ( foldM ) import Control.Monad.ST ( runST ) @@ -112,14 +115,14 @@ -- bytecode address in this BCO. -- Top level assembler fn. -assembleBCOs :: [ProtoBCO Name] -> [TyCon] -> IO CompiledByteCode -assembleBCOs proto_bcos tycons +assembleBCOs :: DynFlags -> [ProtoBCO Name] -> [TyCon] -> IO CompiledByteCode +assembleBCOs dflags proto_bcos tycons = do itblenv <- mkITbls tycons - bcos <- mapM assembleBCO proto_bcos + bcos <- mapM (assembleBCO dflags) proto_bcos return (ByteCode bcos itblenv) -assembleBCO :: ProtoBCO Name -> IO UnlinkedBCO -assembleBCO (ProtoBCO nm instrs bitmap bsize arity _origin _malloced) +assembleBCO :: DynFlags -> ProtoBCO Name -> IO UnlinkedBCO +assembleBCO dflags (ProtoBCO nm instrs bitmap bsize arity _origin _malloced) = let -- pass 1: collect up the offsets of the local labels. -- Remember that the first insn starts at offset @@ -151,7 +154,7 @@ ptrs <- return emptySS :: IO (SizedSeq BCOPtr) let init_asm_state = (insns,lits,ptrs) (final_insns, final_lits, final_ptrs) - <- mkBits findLabel init_asm_state instrs + <- mkBits dflags findLabel init_asm_state instrs let asm_insns = ssElts final_insns n_insns = sizeSS final_insns @@ -227,12 +230,13 @@ | otherwise = error "wORD_SIZE_IN_BITS not 32 or 64?" -- This is where all the action is (pass 2 of the assembler) -mkBits :: (Word16 -> Word) -- label finder +mkBits :: DynFlags + -> (Word16 -> Word) -- label finder -> AsmState -> [BCInstr] -- instructions (in) -> IO AsmState -mkBits findLabel st proto_insns +mkBits dflags findLabel st proto_insns = foldM doInstr st proto_insns where doInstr :: AsmState -> BCInstr -> IO AsmState @@ -246,14 +250,14 @@ instr2 st2 bci_PUSH_G p PUSH_PRIMOP op -> do (p, st2) <- ptr st (BCOPtrPrimOp op) instr2 st2 bci_PUSH_G p - PUSH_BCO proto -> do ul_bco <- assembleBCO proto + PUSH_BCO proto -> do ul_bco <- assembleBCO dflags proto (p, st2) <- ptr st (BCOPtrBCO ul_bco) instr2 st2 bci_PUSH_G p - PUSH_ALTS proto -> do ul_bco <- assembleBCO proto + PUSH_ALTS proto -> do ul_bco <- assembleBCO dflags proto (p, st2) <- ptr st (BCOPtrBCO ul_bco) instr2 st2 bci_PUSH_ALTS p PUSH_ALTS_UNLIFTED proto pk -> do - ul_bco <- assembleBCO proto + ul_bco <- assembleBCO dflags proto (p, st2) <- ptr st (BCOPtrBCO ul_bco) instr2 st2 (push_alts pk) p PUSH_UBX (Left lit) nws @@ -309,8 +313,8 @@ ENTER -> instr1 st bci_ENTER RETURN -> instr1 st bci_RETURN RETURN_UBX rep -> instr1 st (return_ubx rep) - CCALL off m_addr -> do (np, st2) <- addr st m_addr - instr3 st2 bci_CCALL off np + CCALL off m_addr int -> do (np, st2) <- addr st m_addr + instr4 st2 bci_CCALL off np int BRK_FUN array index info -> do (p1, st2) <- ptr st (BCOPtrArray array) (p2, st3) <- ptr st2 (BCOPtrBreakInfo info) @@ -394,12 +398,11 @@ = do st_l1 <- addToSS st_l0 (BCONPtrItbl (getName dcon)) return (sizeSS16 st_l0, (st_i0,st_l1,st_p0)) -#ifdef mingw32_TARGET_OS literal st (MachLabel fs (Just sz) _) + | platformOS (targetPlatform dflags) == OSMinGW32 = litlabel st (appendFS fs (mkFastString ('@':show sz))) -- On Windows, stdcall labels have a suffix indicating the no. of -- arg words, e.g. foo@8. testcase: ffi012(ghci) -#endif literal st (MachLabel fs _ _) = litlabel st fs literal st (MachWord w) = int st (fromIntegral w) literal st (MachInt j) = int st (fromIntegral j) @@ -478,7 +481,7 @@ ENTER{} -> 1 RETURN{} -> 1 RETURN_UBX{} -> 1 - CCALL{} -> 3 + CCALL{} -> 4 SWIZZLE{} -> 3 BRK_FUN{} -> 4 diff -Nru ghc-7.0.3/compiler/ghci/ByteCodeFFI.lhs ghc-7.2.1/compiler/ghci/ByteCodeFFI.lhs --- ghc-7.0.3/compiler/ghci/ByteCodeFFI.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/ghci/ByteCodeFFI.lhs 1970-01-01 00:00:00.000000000 +0000 @@ -1,28 +0,0 @@ -% -% (c) The University of Glasgow 2001-2008 -% - -ByteCodeGen: Generate machine-code sequences for foreign import - -\begin{code} -module ByteCodeFFI ( moan64 ) where - -import Outputable -import System.IO -import System.IO.Unsafe - -moan64 :: String -> SDoc -> a -moan64 msg pp_rep - = unsafePerformIO ( - hPutStrLn stderr ( - "\nGHCi's bytecode generation machinery can't handle 64-bit\n" ++ - "code properly yet. You can work around this for the time being\n" ++ - "by compiling this module and all those it imports to object code,\n" ++ - "and re-starting your GHCi session. The panic below contains information,\n" ++ - "intended for the GHC implementors, about the exact place where GHC gave up.\n" - ) - ) - `seq` - pprPanic msg pp_rep -\end{code} - diff -Nru ghc-7.0.3/compiler/ghci/ByteCodeGen.lhs ghc-7.2.1/compiler/ghci/ByteCodeGen.lhs --- ghc-7.0.3/compiler/ghci/ByteCodeGen.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/ghci/ByteCodeGen.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -30,10 +30,7 @@ import Type import DataCon import TyCon --- import Type import Util --- import DataCon -import Var import VarSet import TysPrim import DynFlags @@ -50,38 +47,36 @@ import Foreign import Foreign.C --- import GHC.Exts ( Int(..) ) - -import Control.Monad ( when ) +import Control.Monad import Data.Char import UniqSupply import BreakArray import Data.Maybe -import Module -import IdInfo +import Module +import IdInfo import Data.Map (Map) import qualified Data.Map as Map import qualified FiniteMap as Map -- ----------------------------------------------------------------------------- --- Generating byte code for a complete module +-- Generating byte code for a complete module byteCodeGen :: DynFlags -> [CoreBind] - -> [TyCon] - -> ModBreaks + -> [TyCon] + -> ModBreaks -> IO CompiledByteCode -byteCodeGen dflags binds tycs modBreaks +byteCodeGen dflags binds tycs modBreaks = do showPass dflags "ByteCodeGen" - let flatBinds = [ (bndr, freeVars rhs) - | (bndr, rhs) <- flattenBinds binds] + let flatBinds = [ (bndr, freeVars rhs) + | (bndr, rhs) <- flattenBinds binds] - us <- mkSplitUniqSupply 'y' - (BcM_State _us _final_ctr mallocd _, proto_bcos) - <- runBc us modBreaks (mapM schemeTopBind flatBinds) + us <- mkSplitUniqSupply 'y' + (BcM_State _us _final_ctr mallocd _, proto_bcos) + <- runBc us modBreaks (mapM schemeTopBind flatBinds) when (notNull mallocd) (panic "ByteCodeGen.byteCodeGen: missing final emitBc?") @@ -89,15 +84,15 @@ dumpIfSet_dyn dflags Opt_D_dump_BCOs "Proto-BCOs" (vcat (intersperse (char ' ') (map ppr proto_bcos))) - assembleBCOs proto_bcos tycs - + assembleBCOs dflags proto_bcos tycs + -- ----------------------------------------------------------------------------- -- Generating byte code for an expression --- Returns: (the root BCO for this expression, +-- Returns: (the root BCO for this expression, -- a list of auxilary BCOs resulting from compiling closures) coreExprToBCOs :: DynFlags - -> CoreExpr + -> CoreExpr -> IO UnlinkedBCO coreExprToBCOs dflags expr = do showPass dflags "ByteCodeGen" @@ -106,11 +101,11 @@ -- should be harmless, since it's never used for anything let invented_name = mkSystemVarName (mkPseudoUniqueE 0) (fsLit "ExprTopLevel") invented_id = Id.mkLocalId invented_name (panic "invented_id's type") - + -- the uniques are needed to generate fresh variables when we introduce new -- let bindings for ticked expressions us <- mkSplitUniqSupply 'y' - (BcM_State _us _final_ctr mallocd _ , proto_bco) + (BcM_State _us _final_ctr mallocd _ , proto_bco) <- runBc us emptyModBreaks (schemeTopBind (invented_id, freeVars expr)) when (notNull mallocd) @@ -118,7 +113,7 @@ dumpIfSet_dyn dflags Opt_D_dump_BCOs "Proto-BCOs" (ppr proto_bco) - assembleBCO proto_bco + assembleBCO dflags proto_bco -- ----------------------------------------------------------------------------- @@ -152,18 +147,18 @@ -> Int -> Word16 -> [StgWord] - -> Bool -- True <=> is a return point, rather than a function + -> Bool -- True <=> is a return point, rather than a function -> [BcPtr] -> ProtoBCO name -mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap is_ret mallocd_blocks +mkProtoBCO nm instrs_ordlist origin arity bitmap_size bitmap is_ret mallocd_blocks = ProtoBCO { - protoBCOName = nm, - protoBCOInstrs = maybe_with_stack_check, - protoBCOBitmap = bitmap, - protoBCOBitmapSize = bitmap_size, - protoBCOArity = arity, - protoBCOExpr = origin, - protoBCOPtrs = mallocd_blocks + protoBCOName = nm, + protoBCOInstrs = maybe_with_stack_check, + protoBCOBitmap = bitmap, + protoBCOBitmapSize = bitmap_size, + protoBCOArity = arity, + protoBCOExpr = origin, + protoBCOPtrs = mallocd_blocks } where -- Overestimate the stack usage (in words) of this BCO, @@ -174,17 +169,17 @@ -- (hopefully rare) cases when the (overestimated) stack use -- exceeds iNTERP_STACK_CHECK_THRESH. maybe_with_stack_check - | is_ret && stack_usage < fromIntegral aP_STACK_SPLIM = peep_d - -- don't do stack checks at return points, - -- everything is aggregated up to the top BCO - -- (which must be a function). + | is_ret && stack_usage < fromIntegral aP_STACK_SPLIM = peep_d + -- don't do stack checks at return points, + -- everything is aggregated up to the top BCO + -- (which must be a function). -- That is, unless the stack usage is >= AP_STACK_SPLIM, -- see bug #1466. | stack_usage >= fromIntegral iNTERP_STACK_CHECK_THRESH = STKCHECK stack_usage : peep_d | otherwise - = peep_d -- the supposedly common case - + = peep_d -- the supposedly common case + -- We assume that this sum doesn't wrap stack_usage = sum (map bciStackUse peep_d) @@ -214,19 +209,19 @@ schemeTopBind :: (Id, AnnExpr Id VarSet) -> BcM (ProtoBCO Name) -schemeTopBind (id, rhs) +schemeTopBind (id, rhs) | Just data_con <- isDataConWorkId_maybe id, isNullaryRepDataCon data_con = do - -- Special case for the worker of a nullary data con. - -- It'll look like this: Nil = /\a -> Nil a - -- If we feed it into schemeR, we'll get - -- Nil = Nil - -- because mkConAppCode treats nullary constructor applications - -- by just re-using the single top-level definition. So - -- for the worker itself, we must allocate it directly. + -- Special case for the worker of a nullary data con. + -- It'll look like this: Nil = /\a -> Nil a + -- If we feed it into schemeR, we'll get + -- Nil = Nil + -- because mkConAppCode treats nullary constructor applications + -- by just re-using the single top-level definition. So + -- for the worker itself, we must allocate it directly. -- ioToBc (putStrLn $ "top level BCO") emitBc (mkProtoBCO (getName id) (toOL [PACK data_con 0, ENTER]) - (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-}) + (Right rhs) 0 0 [{-no bitmap-}] False{-not alts-}) | otherwise = schemeR [{- No free variables -}] (id, rhs) @@ -242,18 +237,18 @@ -- -- Park the resulting BCO in the monad. Also requires the -- variable to which this value was bound, so as to give the --- resulting BCO a name. +-- resulting BCO a name. -schemeR :: [Id] -- Free vars of the RHS, ordered as they - -- will appear in the thunk. Empty for - -- top-level things, which have no free vars. - -> (Id, AnnExpr Id VarSet) - -> BcM (ProtoBCO Name) +schemeR :: [Id] -- Free vars of the RHS, ordered as they + -- will appear in the thunk. Empty for + -- top-level things, which have no free vars. + -> (Id, AnnExpr Id VarSet) + -> BcM (ProtoBCO Name) schemeR fvs (nm, rhs) {- | trace (showSDoc ( (char ' ' - $$ (ppr.filter (not.isTyCoVar).varSetElems.fst) rhs + $$ (ppr.filter (not.isTyVar).varSetElems.fst) rhs $$ pprCoreExpr (deAnnotate rhs) $$ char ' ' ))) False @@ -269,40 +264,40 @@ go xs (AnnLam x (_,e)) = go (x:xs) e go xs not_lambda = (reverse xs, not_lambda) -schemeR_wrk :: [Id] -> Id -> AnnExpr Id VarSet -> ([Var], AnnExpr' Var VarSet) -> BcM (ProtoBCO Name) +schemeR_wrk :: [Id] -> Id -> AnnExpr Id VarSet -> ([Var], AnnExpr' Var VarSet) -> BcM (ProtoBCO Name) schemeR_wrk fvs nm original_body (args, body) - = let - all_args = reverse args ++ fvs - arity = length all_args - -- all_args are the args in reverse order. We're compiling a function - -- \fv1..fvn x1..xn -> e - -- i.e. the fvs come first + = let + all_args = reverse args ++ fvs + arity = length all_args + -- all_args are the args in reverse order. We're compiling a function + -- \fv1..fvn x1..xn -> e + -- i.e. the fvs come first szsw_args = map (fromIntegral . idSizeW) all_args szw_args = sum szsw_args p_init = Map.fromList (zip all_args (mkStackOffsets 0 szsw_args)) - -- make the arg bitmap - bits = argBits (reverse (map idCgRep all_args)) - bitmap_size = genericLength bits - bitmap = mkBitmap bits + -- make the arg bitmap + bits = argBits (reverse (map idCgRep all_args)) + bitmap_size = genericLength bits + bitmap = mkBitmap bits in do - body_code <- schemeER_wrk szw_args p_init body - + body_code <- schemeER_wrk szw_args p_init body + emitBc (mkProtoBCO (getName nm) body_code (Right original_body) - arity bitmap_size bitmap False{-not alts-}) + arity bitmap_size bitmap False{-not alts-}) -- introduce break instructions for ticked expressions schemeER_wrk :: Word16 -> BCEnv -> AnnExpr' Id VarSet -> BcM BCInstrList schemeER_wrk d p rhs - | Just (tickInfo, (_annot, newRhs)) <- isTickedExp' rhs = do - code <- schemeE d 0 p newRhs - arr <- getBreakArray - let idOffSets = getVarOffSets (fromIntegral d) p tickInfo + | Just (tickInfo, (_annot, newRhs)) <- isTickedExp' rhs = do + code <- schemeE d 0 p newRhs + arr <- getBreakArray + let idOffSets = getVarOffSets d p tickInfo let tickNumber = tickInfo_number tickInfo - let breakInfo = BreakInfo + let breakInfo = BreakInfo { breakInfo_module = tickInfo_module tickInfo - , breakInfo_number = tickNumber + , breakInfo_number = tickNumber , breakInfo_vars = idOffSets , breakInfo_resty = exprType (deAnnotate' newRhs) } @@ -310,15 +305,15 @@ BA arr# -> BRK_FUN arr# (fromIntegral tickNumber) breakInfo return $ breakInstr `consOL` code - | otherwise = schemeE d 0 p rhs + | otherwise = schemeE d 0 p rhs getVarOffSets :: Word16 -> BCEnv -> TickInfo -> [(Id, Word16)] -getVarOffSets d p = catMaybes . map (getOffSet d p) . tickInfo_locals +getVarOffSets d p = catMaybes . map (getOffSet d p) . tickInfo_locals getOffSet :: Word16 -> BCEnv -> Id -> Maybe (Id, Word16) -getOffSet d env id +getOffSet d env id = case lookupBCEnv_maybe id env of - Nothing -> Nothing + Nothing -> Nothing Just offset -> Just (id, d - offset) fvsToEnv :: BCEnv -> VarSet -> [Id] @@ -330,25 +325,36 @@ -- -- The code that constructs the thunk, and the code that executes -- it, have to agree about this layout -fvsToEnv p fvs = [v | v <- varSetElems fvs, - isId v, -- Could be a type variable - v `Map.member` p] +fvsToEnv p fvs = [v | v <- varSetElems fvs, + isId v, -- Could be a type variable + v `Map.member` p] -- ----------------------------------------------------------------------------- -- schemeE -data TickInfo - = TickInfo +data TickInfo + = TickInfo { tickInfo_number :: Int -- the (module) unique number of the tick - , tickInfo_module :: Module -- the origin of the ticked expression + , tickInfo_module :: Module -- the origin of the ticked expression , tickInfo_locals :: [Id] -- the local vars in scope at the ticked expression - } + } instance Outputable TickInfo where - ppr info = text "TickInfo" <+> + ppr info = text "TickInfo" <+> parens (int (tickInfo_number info) <+> ppr (tickInfo_module info) <+> ppr (tickInfo_locals info)) +returnUnboxedAtom :: Word16 -> Sequel -> BCEnv + -> AnnExpr' Id VarSet -> CgRep + -> BcM BCInstrList +-- Returning an unlifted value. +-- Heave it on the stack, SLIDE, and RETURN. +returnUnboxedAtom d s p e e_rep + = do (push, szw) <- pushAtom d p e + return (push -- value onto stack + `appOL` mkSLIDE szw (d-s) -- clear to sequel + `snocOL` RETURN_UBX e_rep) -- go + -- Compile code to apply the given expression to the remaining args -- on the stack, returning a HNF. schemeE :: Word16 -> Sequel -> BCEnv -> AnnExpr' Id VarSet -> BcM BCInstrList @@ -358,39 +364,24 @@ = schemeE d s p e' -- Delegate tail-calls to schemeT. -schemeE d s p e@(AnnApp _ _) - = schemeT d s p e +schemeE d s p e@(AnnApp _ _) = schemeT d s p e -schemeE d s p e@(AnnVar v) - | not (isUnLiftedType v_type) - = -- Lifted-type thing; push it in the normal way - schemeT d s p e +schemeE d s p e@(AnnLit lit) = returnUnboxedAtom d s p e (typeCgRep (literalType lit)) +schemeE d s p e@(AnnCoercion {}) = returnUnboxedAtom d s p e VoidArg - | otherwise - = do -- Returning an unlifted value. - -- Heave it on the stack, SLIDE, and RETURN. - (push, szw) <- pushAtom d p (AnnVar v) - return (push -- value onto stack - `appOL` mkSLIDE szw (d-s) -- clear to sequel - `snocOL` RETURN_UBX v_rep) -- go +schemeE d s p e@(AnnVar v) + | isUnLiftedType v_type = returnUnboxedAtom d s p e (typeCgRep v_type) + | otherwise = schemeT d s p e where - v_type = idType v - v_rep = typeCgRep v_type - -schemeE d s p (AnnLit literal) - = do (push, szw) <- pushAtom d p (AnnLit literal) - let l_rep = typeCgRep (literalType literal) - return (push -- value onto stack - `appOL` mkSLIDE szw (d-s) -- clear to sequel - `snocOL` RETURN_UBX l_rep) -- go + v_type = idType v schemeE d s p (AnnLet (AnnNonRec x (_,rhs)) (_,body)) | (AnnVar v, args_r_to_l) <- splitApp rhs, Just data_con <- isDataConWorkId_maybe v, dataConRepArity data_con == length args_r_to_l - = do -- Special case for a non-recursive let whose RHS is a - -- saturatred constructor application. - -- Just allocate the constructor and carry on + = do -- Special case for a non-recursive let whose RHS is a + -- saturatred constructor application. + -- Just allocate the constructor and carry on alloc_code <- mkConAppCode d s p data_con args_r_to_l body_code <- schemeE (d+1) s (Map.insert x d p) body return (alloc_code `appOL` body_code) @@ -407,8 +398,8 @@ -- Sizes of free vars sizes = map (\rhs_fvs -> sum (map (fromIntegral . idSizeW) rhs_fvs)) fvss - -- the arity of each rhs - arities = map (genericLength . fst . collect) rhss + -- the arity of each rhs + arities = map (genericLength . fst . collect) rhss -- This p', d' defn is safe because all the items being pushed -- are ptrs, so all have size 1. d' and p' reflect the stack @@ -421,33 +412,33 @@ -- ToDo: don't build thunks for things with no free variables build_thunk _ [] size bco off arity = return (PUSH_BCO bco `consOL` unitOL (mkap (off+size) size)) - where - mkap | arity == 0 = MKAP - | otherwise = MKPAP + where + mkap | arity == 0 = MKAP + | otherwise = MKPAP build_thunk dd (fv:fvs) size bco off arity = do - (push_code, pushed_szw) <- pushAtom dd p' (AnnVar fv) + (push_code, pushed_szw) <- pushAtom dd p' (AnnVar fv) more_push_code <- build_thunk (dd+pushed_szw) fvs size bco off arity return (push_code `appOL` more_push_code) alloc_code = toOL (zipWith mkAlloc sizes arities) - where mkAlloc sz 0 + where mkAlloc sz 0 | is_tick = ALLOC_AP_NOUPD sz | otherwise = ALLOC_AP sz - mkAlloc sz arity = ALLOC_PAP arity sz + mkAlloc sz arity = ALLOC_PAP arity sz - is_tick = case binds of + is_tick = case binds of AnnNonRec id _ -> occNameFS (getOccName id) == tickFS _other -> False - compile_bind d' fvs x rhs size arity off = do - bco <- schemeR fvs (x,rhs) - build_thunk d' fvs size bco off arity - - compile_binds = - [ compile_bind d' fvs x rhs size arity n - | (fvs, x, rhs, size, arity, n) <- - zip6 fvss xs rhss sizes arities [n_binds, n_binds-1 .. 1] - ] + compile_bind d' fvs x rhs size arity off = do + bco <- schemeR fvs (x,rhs) + build_thunk d' fvs size bco off arity + + compile_binds = + [ compile_bind d' fvs x rhs size arity n + | (fvs, x, rhs, size, arity, n) <- + zip6 fvss xs rhss sizes arities [n_binds, n_binds-1 .. 1] + ] in do body_code <- schemeE d' s p' body thunk_codes <- sequence compile_binds @@ -464,7 +455,7 @@ = if isUnLiftedType ty then do -- If the result type is unlifted, then we must generate - -- let f = \s . case tick# of _ -> e + -- let f = \s . case tick# of _ -> e -- in f realWorld# -- When we stop at the breakpoint, _result will have an unlifted -- type and hence won't be bound in the environment, but the @@ -472,7 +463,7 @@ id <- newId (mkFunTy realWorldStatePrimTy ty) st <- newId realWorldStatePrimTy let letExp = AnnLet (AnnNonRec id (fvs, AnnLam st (emptyVarSet, exp))) - (emptyVarSet, (AnnApp (emptyVarSet, AnnVar id) + (emptyVarSet, (AnnApp (emptyVarSet, AnnVar id) (emptyVarSet, AnnVar realWorldPrimId))) schemeE d s p letExp else do @@ -486,42 +477,42 @@ schemeE d s p (AnnCase scrut _ _ [(DataAlt dc, [bind1, bind2], rhs)]) | isUnboxedTupleCon dc, VoidArg <- typeCgRep (idType bind1) - -- Convert - -- case .... of x { (# VoidArg'd-thing, a #) -> ... } - -- to - -- case .... of a { DEFAULT -> ... } - -- becuse the return convention for both are identical. - -- - -- Note that it does not matter losing the void-rep thing from the - -- envt (it won't be bound now) because we never look such things up. + -- Convert + -- case .... of x { (# VoidArg'd-thing, a #) -> ... } + -- to + -- case .... of a { DEFAULT -> ... } + -- becuse the return convention for both are identical. + -- + -- Note that it does not matter losing the void-rep thing from the + -- envt (it won't be bound now) because we never look such things up. = --trace "automagic mashing of case alts (# VoidArg, a #)" $ - doCase d s p scrut bind2 [(DEFAULT, [], rhs)] True{-unboxed tuple-} + doCase d s p scrut bind2 [(DEFAULT, [], rhs)] True{-unboxed tuple-} | isUnboxedTupleCon dc, VoidArg <- typeCgRep (idType bind2) = --trace "automagic mashing of case alts (# a, VoidArg #)" $ - doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-} + doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-} schemeE d s p (AnnCase scrut _ _ [(DataAlt dc, [bind1], rhs)]) | isUnboxedTupleCon dc - -- Similarly, convert - -- case .... of x { (# a #) -> ... } - -- to - -- case .... of a { DEFAULT -> ... } + -- Similarly, convert + -- case .... of x { (# a #) -> ... } + -- to + -- case .... of a { DEFAULT -> ... } = --trace "automagic mashing of case alts (# a #)" $ - doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-} + doCase d s p scrut bind1 [(DEFAULT, [], rhs)] True{-unboxed tuple-} schemeE d s p (AnnCase scrut bndr _ alts) - = doCase d s p scrut bndr alts False{-not an unboxed tuple-} + = doCase d s p scrut bndr alts False{-not an unboxed tuple-} schemeE _ _ _ expr - = pprPanic "ByteCodeGen.schemeE: unhandled case" + = pprPanic "ByteCodeGen.schemeE: unhandled case" (pprCoreExpr (deAnnotate' expr)) -{- +{- Ticked Expressions ------------------ - + A ticked expression looks like this: case tick var1 ... varN of DEFAULT -> e @@ -535,7 +526,7 @@ otherwise we return Nothing. - The idea is that the "case tick ..." is really just an annotation on + The idea is that the "case tick ..." is really just an annotation on the code. When we find such a thing, we pull out the useful information, and then compile the code as if it was just the expression "e". @@ -544,10 +535,10 @@ isTickedExp' :: AnnExpr' Id a -> Maybe (TickInfo, AnnExpr Id a) isTickedExp' (AnnCase scrut _bndr _type alts) | Just tickInfo <- isTickedScrut scrut, - [(DEFAULT, _bndr, rhs)] <- alts + [(DEFAULT, _bndr, rhs)] <- alts = Just (tickInfo, rhs) where - isTickedScrut :: (AnnExpr Id a) -> Maybe TickInfo + isTickedScrut :: (AnnExpr Id a) -> Maybe TickInfo isTickedScrut expr | Var id <- f, Just (TickBox modName tickNumber) <- isTickBoxOp_maybe id @@ -559,7 +550,7 @@ where (f, args) = collectArgs $ deAnnotate expr idsOfArgs :: [Expr Id] -> [Id] - idsOfArgs = catMaybes . map exprId + idsOfArgs = catMaybes . map exprId exprId :: Expr Id -> Maybe Id exprId (Var id) = Just id exprId _ = Nothing @@ -583,16 +574,16 @@ -- (# b #) and treat it as b. -- -- 3. Application of a constructor, by defn saturated. --- Split the args into ptrs and non-ptrs, and push the nonptrs, +-- Split the args into ptrs and non-ptrs, and push the nonptrs, -- then the ptrs, and then do PACK and RETURN. -- -- 4. Otherwise, it must be a function call. Push the args -- right to left, SLIDE and ENTER. schemeT :: Word16 -- Stack depth - -> Sequel -- Sequel depth - -> BCEnv -- stack env - -> AnnExpr' Id VarSet + -> Sequel -- Sequel depth + -> BCEnv -- stack env + -> AnnExpr' Id VarSet -> BcM BCInstrList schemeT d s p app @@ -601,13 +592,13 @@ -- = panic "schemeT ?!?!" -- | trace ("\nschemeT\n" ++ showSDoc (pprCoreExpr (deAnnotate' app)) ++ "\n") False --- = error "?!?!" +-- = error "?!?!" -- Case 0 | Just (arg, constr_names) <- maybe_is_tagToEnum_call = do (push, arg_words) <- pushAtom d p arg tagToId_sequence <- implement_tagToId constr_names - return (push `appOL` tagToId_sequence + return (push `appOL` tagToId_sequence `appOL` mkSLIDE 1 (d+arg_words-s) `snocOL` ENTER) @@ -619,20 +610,20 @@ | Just con <- maybe_saturated_dcon, isUnboxedTupleCon con = case args_r_to_l of - [arg1,arg2] | isVoidArgAtom arg1 -> - unboxedTupleReturn d s p arg2 - [arg1,arg2] | isVoidArgAtom arg2 -> - unboxedTupleReturn d s p arg1 - _other -> unboxedTupleException + [arg1,arg2] | isVoidArgAtom arg1 -> + unboxedTupleReturn d s p arg2 + [arg1,arg2] | isVoidArgAtom arg2 -> + unboxedTupleReturn d s p arg1 + _other -> unboxedTupleException -- Case 3: Ordinary data constructor | Just con <- maybe_saturated_dcon = do alloc_con <- mkConAppCode d s p con args_r_to_l - return (alloc_con `appOL` - mkSLIDE 1 (d - s) `snocOL` - ENTER) + return (alloc_con `appOL` + mkSLIDE 1 (d - s) `snocOL` + ENTER) - -- Case 4: Tail call of function + -- Case 4: Tail call of function | otherwise = doTailCall d s p fn args_r_to_l @@ -641,54 +632,54 @@ maybe_is_tagToEnum_call = let extract_constr_Names ty | Just (tyc, _) <- splitTyConApp_maybe (repType ty), - isDataTyCon tyc - = map (getName . dataConWorkId) (tyConDataCons tyc) - -- NOTE: use the worker name, not the source name of - -- the DataCon. See DataCon.lhs for details. - | otherwise + isDataTyCon tyc + = map (getName . dataConWorkId) (tyConDataCons tyc) + -- NOTE: use the worker name, not the source name of + -- the DataCon. See DataCon.lhs for details. + | otherwise = pprPanic "maybe_is_tagToEnum_call.extract_constr_Ids" (ppr ty) in case app of (AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType t)) arg) -> case isPrimOpId_maybe v of Just TagToEnumOp -> Just (snd arg, extract_constr_Names t) - _ -> Nothing + _ -> Nothing _ -> Nothing - -- Extract the args (R->L) and fn - -- The function will necessarily be a variable, - -- because we are compiling a tail call + -- Extract the args (R->L) and fn + -- The function will necessarily be a variable, + -- because we are compiling a tail call (AnnVar fn, args_r_to_l) = splitApp app -- Only consider this to be a constructor application iff it is -- saturated. Otherwise, we'll call the constructor wrapper. n_args = length args_r_to_l - maybe_saturated_dcon - = case isDataConWorkId_maybe fn of - Just con | dataConRepArity con == n_args -> Just con - _ -> Nothing + maybe_saturated_dcon + = case isDataConWorkId_maybe fn of + Just con | dataConRepArity con == n_args -> Just con + _ -> Nothing -- ----------------------------------------------------------------------------- --- Generate code to build a constructor application, +-- Generate code to build a constructor application, -- leaving it on top of the stack mkConAppCode :: Word16 -> Sequel -> BCEnv - -> DataCon -- The data constructor - -> [AnnExpr' Id VarSet] -- Args, in *reverse* order - -> BcM BCInstrList + -> DataCon -- The data constructor + -> [AnnExpr' Id VarSet] -- Args, in *reverse* order + -> BcM BCInstrList -mkConAppCode _ _ _ con [] -- Nullary constructor +mkConAppCode _ _ _ con [] -- Nullary constructor = ASSERT( isNullaryRepDataCon con ) return (unitOL (PUSH_G (getName (dataConWorkId con)))) - -- Instead of doing a PACK, which would allocate a fresh - -- copy of this constructor, use the single shared version. + -- Instead of doing a PACK, which would allocate a fresh + -- copy of this constructor, use the single shared version. -mkConAppCode orig_d _ p con args_r_to_l +mkConAppCode orig_d _ p con args_r_to_l = ASSERT( dataConRepArity con == length args_r_to_l ) do_pushery orig_d (non_ptr_args ++ ptr_args) where - -- The args are already in reverse order, which is the way PACK - -- expects them to be. We must push the non-ptrs after the ptrs. + -- The args are already in reverse order, which is the way PACK + -- expects them to be. We must push the non-ptrs after the ptrs. (ptr_args, non_ptr_args) = partition isPtrAtom args_r_to_l do_pushery d (arg:args) @@ -697,8 +688,8 @@ return (push `appOL` more_push_code) do_pushery d [] = return (unitOL (PACK con n_arg_words)) - where - n_arg_words = d - orig_d + where + n_arg_words = d - orig_d -- ----------------------------------------------------------------------------- @@ -709,42 +700,42 @@ -- returned, even if it is a pointed type. We always just return. unboxedTupleReturn - :: Word16 -> Sequel -> BCEnv - -> AnnExpr' Id VarSet -> BcM BCInstrList + :: Word16 -> Sequel -> BCEnv + -> AnnExpr' Id VarSet -> BcM BCInstrList unboxedTupleReturn d s p arg = do (push, sz) <- pushAtom d p arg - return (push `appOL` - mkSLIDE sz (d-s) `snocOL` - RETURN_UBX (atomRep arg)) + return (push `appOL` + mkSLIDE sz (d-s) `snocOL` + RETURN_UBX (atomRep arg)) -- ----------------------------------------------------------------------------- -- Generate code for a tail-call doTailCall - :: Word16 -> Sequel -> BCEnv - -> Id -> [AnnExpr' Id VarSet] - -> BcM BCInstrList + :: Word16 -> Sequel -> BCEnv + -> Id -> [AnnExpr' Id VarSet] + -> BcM BCInstrList doTailCall init_d s p fn args = do_pushes init_d args (map atomRep args) where do_pushes d [] reps = do - ASSERT( null reps ) return () + ASSERT( null reps ) return () (push_fn, sz) <- pushAtom d p (AnnVar fn) - ASSERT( sz == 1 ) return () - return (push_fn `appOL` ( - mkSLIDE ((d-init_d) + 1) (init_d - s) `appOL` - unitOL ENTER)) + ASSERT( sz == 1 ) return () + return (push_fn `appOL` ( + mkSLIDE ((d-init_d) + 1) (init_d - s) `appOL` + unitOL ENTER)) do_pushes d args reps = do let (push_apply, n, rest_of_reps) = findPushSeq reps - (these_args, rest_of_args) = splitAt n args + (these_args, rest_of_args) = splitAt n args (next_d, push_code) <- push_seq d these_args - instrs <- do_pushes (next_d + 1) rest_of_args rest_of_reps - -- ^^^ for the PUSH_APPLY_ instruction + instrs <- do_pushes (next_d + 1) rest_of_args rest_of_reps + -- ^^^ for the PUSH_APPLY_ instruction return (push_code `appOL` (push_apply `consOL` instrs)) push_seq d [] = return (d, nilOL) push_seq d (arg:args) = do - (push_code, sz) <- pushAtom d p arg + (push_code, sz) <- pushAtom d p arg (final_d, more_push_code) <- push_seq (d+sz) args return (final_d, push_code `appOL` more_push_code) @@ -779,10 +770,10 @@ -- Case expressions doCase :: Word16 -> Sequel -> BCEnv - -> AnnExpr Id VarSet -> Id -> [AnnAlt Id VarSet] - -> Bool -- True <=> is an unboxed tuple case, don't enter the result - -> BcM BCInstrList -doCase d s p (_,scrut) bndr alts is_unboxed_tuple + -> AnnExpr Id VarSet -> Id -> [AnnAlt Id VarSet] + -> Bool -- True <=> is an unboxed tuple case, don't enter the result + -> BcM BCInstrList +doCase d s p (_,scrut) bndr alts is_unboxed_tuple = let -- Top of stack is the return itbl, as usual. -- underneath it is the pointer to the alt_code BCO. @@ -790,58 +781,58 @@ -- on top of the itbl. ret_frame_sizeW = 2 - -- An unlifted value gets an extra info table pushed on top - -- when it is returned. - unlifted_itbl_sizeW | isAlgCase = 0 - | otherwise = 1 - - -- depth of stack after the return value has been pushed - d_bndr = d + ret_frame_sizeW + fromIntegral (idSizeW bndr) - - -- depth of stack after the extra info table for an unboxed return - -- has been pushed, if any. This is the stack depth at the - -- continuation. + -- An unlifted value gets an extra info table pushed on top + -- when it is returned. + unlifted_itbl_sizeW | isAlgCase = 0 + | otherwise = 1 + + -- depth of stack after the return value has been pushed + d_bndr = d + ret_frame_sizeW + fromIntegral (idSizeW bndr) + + -- depth of stack after the extra info table for an unboxed return + -- has been pushed, if any. This is the stack depth at the + -- continuation. d_alts = d_bndr + unlifted_itbl_sizeW -- Env in which to compile the alts, not including -- any vars bound by the alts themselves p_alts = Map.insert bndr (d_bndr - 1) p - bndr_ty = idType bndr + bndr_ty = idType bndr isAlgCase = not (isUnLiftedType bndr_ty) && not is_unboxed_tuple -- given an alt, return a discr and code for it. - codeAlt (DEFAULT, _, (_,rhs)) - = do rhs_code <- schemeE d_alts s p_alts rhs - return (NoDiscr, rhs_code) + codeAlt (DEFAULT, _, (_,rhs)) + = do rhs_code <- schemeE d_alts s p_alts rhs + return (NoDiscr, rhs_code) codeAlt alt@(_, bndrs, (_,rhs)) - -- primitive or nullary constructor alt: no need to UNPACK - | null real_bndrs = do - rhs_code <- schemeE d_alts s p_alts rhs + -- primitive or nullary constructor alt: no need to UNPACK + | null real_bndrs = do + rhs_code <- schemeE d_alts s p_alts rhs return (my_discr alt, rhs_code) - -- algebraic alt with some binders + -- algebraic alt with some binders | otherwise = let - (ptrs,nptrs) = partition (isFollowableArg.idCgRep) real_bndrs - ptr_sizes = map (fromIntegral . idSizeW) ptrs - nptrs_sizes = map (fromIntegral . idSizeW) nptrs - bind_sizes = ptr_sizes ++ nptrs_sizes - size = sum ptr_sizes + sum nptrs_sizes - -- the UNPACK instruction unpacks in reverse order... - p' = Map.insertList - (zip (reverse (ptrs ++ nptrs)) - (mkStackOffsets d_alts (reverse bind_sizes))) - p_alts - in do + (ptrs,nptrs) = partition (isFollowableArg.idCgRep) real_bndrs + ptr_sizes = map (fromIntegral . idSizeW) ptrs + nptrs_sizes = map (fromIntegral . idSizeW) nptrs + bind_sizes = ptr_sizes ++ nptrs_sizes + size = sum ptr_sizes + sum nptrs_sizes + -- the UNPACK instruction unpacks in reverse order... + p' = Map.insertList + (zip (reverse (ptrs ++ nptrs)) + (mkStackOffsets d_alts (reverse bind_sizes))) + p_alts + in do MASSERT(isAlgCase) - rhs_code <- schemeE (d_alts+size) s p' rhs + rhs_code <- schemeE (d_alts+size) s p' rhs return (my_discr alt, unitOL (UNPACK size) `appOL` rhs_code) where - real_bndrs = filter (not.isTyCoVar) bndrs + real_bndrs = filterOut isTyVar bndrs my_discr (DEFAULT, _, _) = NoDiscr {-shouldn't really happen-} - my_discr (DataAlt dc, _, _) + my_discr (DataAlt dc, _, _) | isUnboxedTupleCon dc = unboxedTupleException | otherwise @@ -854,20 +845,20 @@ MachChar i -> DiscrI (ord i) _ -> pprPanic "schemeE(AnnCase).my_discr" (ppr l) - maybe_ncons + maybe_ncons | not isAlgCase = Nothing - | otherwise + | otherwise = case [dc | (DataAlt dc, _, _) <- alts] of [] -> Nothing (dc:_) -> Just (tyConFamilySize (dataConTyCon dc)) - -- the bitmap is relative to stack depth d, i.e. before the - -- BCO, info table and return value are pushed on. - -- This bit of code is v. similar to buildLivenessMask in CgBindery, - -- except that here we build the bitmap from the known bindings of - -- things that are pointers, whereas in CgBindery the code builds the - -- bitmap from the free slots and unboxed bindings. - -- (ToDo: merge?) + -- the bitmap is relative to stack depth d, i.e. before the + -- BCO, info table and return value are pushed on. + -- This bit of code is v. similar to buildLivenessMask in CgBindery, + -- except that here we build the bitmap from the known bindings of + -- things that are pointers, whereas in CgBindery the code builds the + -- bitmap from the free slots and unboxed bindings. + -- (ToDo: merge?) -- -- NOTE [7/12/2006] bug #1013, testcase ghci/should_run/ghci002. -- The bitmap must cover the portion of the stack up to the sequel only. @@ -878,32 +869,32 @@ bitmap_size = d-s bitmap_size' :: Int bitmap_size' = fromIntegral bitmap_size - bitmap = intsToReverseBitmap bitmap_size'{-size-} + bitmap = intsToReverseBitmap bitmap_size'{-size-} (sortLe (<=) (filter (< bitmap_size') rel_slots)) - where - binds = Map.toList p - rel_slots = map fromIntegral $ concat (map spread binds) - spread (id, offset) - | isFollowableArg (idCgRep id) = [ rel_offset ] - | otherwise = [] - where rel_offset = d - offset - 1 + where + binds = Map.toList p + rel_slots = map fromIntegral $ concat (map spread binds) + spread (id, offset) + | isFollowableArg (idCgRep id) = [ rel_offset ] + | otherwise = [] + where rel_offset = d - offset - 1 in do alt_stuff <- mapM codeAlt alts alt_final <- mkMultiBranch maybe_ncons alt_stuff - let + let alt_bco_name = getName bndr alt_bco = mkProtoBCO alt_bco_name alt_final (Left alts) - 0{-no arity-} bitmap_size bitmap True{-is alts-} + 0{-no arity-} bitmap_size bitmap True{-is alts-} -- in -- trace ("case: bndr = " ++ showSDocDebug (ppr bndr) ++ "\ndepth = " ++ show d ++ "\nenv = \n" ++ showSDocDebug (ppBCEnv p) ++ --- "\n bitmap = " ++ show bitmap) $ do +-- "\n bitmap = " ++ show bitmap) $ do scrut_code <- schemeE (d + ret_frame_sizeW) (d + ret_frame_sizeW) p scrut alt_bco' <- emitBc alt_bco let push_alts - | isAlgCase = PUSH_ALTS alt_bco' - | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typeCgRep bndr_ty) + | isAlgCase = PUSH_ALTS alt_bco' + | otherwise = PUSH_ALTS_UNLIFTED alt_bco' (typeCgRep bndr_ty) return (push_alts `consOL` scrut_code) @@ -914,17 +905,17 @@ -- deferencing ForeignObj#s and adjusting addrs to point to -- payloads in Ptr/Byte arrays. Then, generate the marshalling -- (machine) code for the ccall, and create bytecodes to call that and --- then return in the right way. +-- then return in the right way. -generateCCall :: Word16 -> Sequel -- stack and sequel depths +generateCCall :: Word16 -> Sequel -- stack and sequel depths -> BCEnv - -> CCallSpec -- where to call - -> Id -- of target, for type info - -> [AnnExpr' Id VarSet] -- args (atoms) + -> CCallSpec -- where to call + -> Id -- of target, for type info + -> [AnnExpr' Id VarSet] -- args (atoms) -> BcM BCInstrList -generateCCall d0 s p (CCallSpec target cconv _) fn args_r_to_l - = let +generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l + = let -- useful constants addr_sizeW :: Word16 addr_sizeW = fromIntegral (cgRepSizeW NonPtrArg) @@ -935,19 +926,19 @@ -- CgRep of what was actually pushed. pargs _ [] = return [] - pargs d (a:az) + pargs d (a:az) = let arg_ty = repType (exprType (deAnnotate' a)) in case splitTyConApp_maybe arg_ty of -- Don't push the FO; instead push the Addr# it -- contains. - Just (t, _) - | t == arrayPrimTyCon || t == mutableArrayPrimTyCon + Just (t, _) + | t == arrayPrimTyCon || t == mutableArrayPrimTyCon -> do rest <- pargs (d + addr_sizeW) az code <- parg_ArrayishRep (fromIntegral arrPtrsHdrSize) d p a return ((code,AddrRep):rest) - | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon + | t == byteArrayPrimTyCon || t == mutableByteArrayPrimTyCon -> do rest <- pargs (d + addr_sizeW) az code <- parg_ArrayishRep (fromIntegral arrWordsHdrSize) d p a return ((code,AddrRep):rest) @@ -991,18 +982,18 @@ (returns_void, r_rep) = case maybe_getCCallReturnRep (idType fn) of Nothing -> (True, VoidRep) - Just rr -> (False, rr) + Just rr -> (False, rr) {- - Because the Haskell stack grows down, the a_reps refer to + Because the Haskell stack grows down, the a_reps refer to lowest to highest addresses in that order. The args for the call are on the stack. Now push an unboxed Addr# indicating - the C function to call. Then push a dummy placeholder for the - result. Finally, emit a CCALL insn with an offset pointing to the + the C function to call. Then push a dummy placeholder for the + result. Finally, emit a CCALL insn with an offset pointing to the Addr# just pushed, and a literal field holding the mallocville address of the piece of marshalling code we generate. - So, just prior to the CCALL insn, the stack looks like this + So, just prior to the CCALL insn, the stack looks like this (growing down, as usual): - + ... @@ -1010,7 +1001,7 @@ (must be an unboxed type) The interpreter then calls the marshall code mentioned - in the CCALL insn, passing it (& ), + in the CCALL insn, passing it (& ), that is, the addr of the topmost word in the stack. When this returns, the placeholder will have been filled in. The placeholder is slid down to the sequel @@ -1053,7 +1044,7 @@ -- Get the arg reps, zapping the leading Addr# in the dynamic case a_reps -- | trace (showSDoc (ppr a_reps_pushed_RAW)) False = error "???" | is_static = a_reps_pushed_RAW - | otherwise = if null a_reps_pushed_RAW + | otherwise = if null a_reps_pushed_RAW then panic "ByteCodeGen.generateCCall: dyn with no args" else tail a_reps_pushed_RAW @@ -1062,7 +1053,7 @@ | is_static = (toOL [PUSH_UBX (Right static_target_addr) addr_sizeW], d_after_args + addr_sizeW) - | otherwise -- is already on the stack + | otherwise -- is already on the stack = (nilOL, d_after_args) -- Push the return placeholder. For a call returning nothing, @@ -1070,17 +1061,17 @@ r_sizeW = fromIntegral (primRepSizeW r_rep) d_after_r = d_after_Addr + r_sizeW r_lit = mkDummyLiteral r_rep - push_r = (if returns_void - then nilOL + push_r = (if returns_void + then nilOL else unitOL (PUSH_UBX (Left r_lit) r_sizeW)) -- generate the marshalling code we're going to call - -- Offset of the next stack frame down the stack. The CCALL - -- instruction needs to describe the chunk of stack containing - -- the ccall args to the GC, so it needs to know how large it - -- is. See comment in Interpreter.c with the CCALL instruction. - stk_offset = d_after_r - s + -- Offset of the next stack frame down the stack. The CCALL + -- instruction needs to describe the chunk of stack containing + -- the ccall args to the GC, so it needs to know how large it + -- is. See comment in Interpreter.c with the CCALL instruction. + stk_offset = d_after_r - s -- in -- the only difference in libffi mode is that we prepare a cif @@ -1092,7 +1083,8 @@ recordItblMallocBc (ItblPtr (castFunPtrToPtr addr_of_marshaller)) let -- do the call - do_call = unitOL (CCALL stk_offset (castFunPtrToPtr addr_of_marshaller)) + do_call = unitOL (CCALL stk_offset (castFunPtrToPtr addr_of_marshaller) + (fromIntegral (fromEnum (playInterruptible safety)))) -- slide and return wrapup = mkSLIDE r_sizeW (d_after_r - r_sizeW - s) `snocOL` RETURN_UBX (primRepToCgRep r_rep) @@ -1118,7 +1110,7 @@ _ -> panic "mkDummyLiteral" --- Convert (eg) +-- Convert (eg) -- GHC.Prim.Char# -> GHC.Prim.State# GHC.Prim.RealWorld -- -> (# GHC.Prim.State# GHC.Prim.RealWorld, GHC.Prim.Int# #) -- @@ -1135,9 +1127,9 @@ maybe_getCCallReturnRep :: Type -> Maybe PrimRep maybe_getCCallReturnRep fn_ty = let (_a_tys, r_ty) = splitFunTys (dropForAlls fn_ty) - maybe_r_rep_to_go + maybe_r_rep_to_go = if isSingleton r_reps then Nothing else Just (r_reps !! 1) - (r_tycon, r_reps) + (r_tycon, r_reps) = case splitTyConApp_maybe (repType r_ty) of (Just (tyc, tys)) -> (tyc, map typePrimRep tys) Nothing -> blargh @@ -1147,19 +1139,19 @@ && case maybe_r_rep_to_go of Nothing -> True Just r_rep -> r_rep /= PtrRep - -- if it was, it would be impossible - -- to create a valid return value + -- if it was, it would be impossible + -- to create a valid return value -- placeholder on the stack blargh :: a -- Used at more than one type - blargh = pprPanic "maybe_getCCallReturn: can't handle:" + blargh = pprPanic "maybe_getCCallReturn: can't handle:" (pprType fn_ty) - in + in --trace (showSDoc (ppr (a_reps, r_reps))) $ if ok then maybe_r_rep_to_go else blargh -- Compile code which expects an unboxed Int on the top of stack, --- (call it i), and pushes the i'th closure in the supplied list +-- (call it i), and pushes the i'th closure in the supplied list -- as a consequence. implement_tagToId :: [Name] -> BcM BCInstrList implement_tagToId names @@ -1171,13 +1163,13 @@ [0 ..] names steps = map (mkStep label_exit) infos return (concatOL steps - `appOL` + `appOL` toOL [LABEL label_fail, CASEFAIL, LABEL label_exit]) where mkStep l_exit (my_label, next_label, n, name_for_n) - = toOL [LABEL my_label, - TESTEQ_I n next_label, - PUSH_G name_for_n, + = toOL [LABEL my_label, + TESTEQ_I n next_label, + PUSH_G name_for_n, JMP l_exit] @@ -1196,10 +1188,13 @@ pushAtom :: Word16 -> BCEnv -> AnnExpr' Id VarSet -> BcM (BCInstrList, Word16) -pushAtom d p e - | Just e' <- bcView e +pushAtom d p e + | Just e' <- bcView e = pushAtom d p e' +pushAtom _ _ (AnnCoercion {}) -- Coercions are zero-width things, + = return (nilOL, 0) -- treated just like a variable VoidArg + pushAtom d p (AnnVar v) | idCgRep v == VoidArg = return (nilOL, 0) @@ -1213,19 +1208,19 @@ | Just d_v <- lookupBCEnv_maybe v p -- v is a local variable = let l = d - d_v + sz - 2 in return (toOL (genericReplicate sz (PUSH_L l)), sz) - -- d - d_v the number of words between the TOS - -- and the 1st slot of the object - -- - -- d - d_v - 1 the offset from the TOS of the 1st slot - -- - -- d - d_v - 1 + sz - 1 the offset from the TOS of the last slot - -- of the object. - -- - -- Having found the last slot, we proceed to copy the right number of - -- slots on to the top of the stack. + -- d - d_v the number of words between the TOS + -- and the 1st slot of the object + -- + -- d - d_v - 1 the offset from the TOS of the 1st slot + -- + -- d - d_v - 1 + sz - 1 the offset from the TOS of the last slot + -- of the object. + -- + -- Having found the last slot, we proceed to copy the right number of + -- slots on to the top of the stack. | otherwise -- v must be a global variable - = ASSERT(sz == 1) + = ASSERT(sz == 1) return (unitOL (PUSH_G (getName v)), sz) where @@ -1237,35 +1232,36 @@ = case lit of MachLabel _ _ _ -> code NonPtrArg MachWord _ -> code NonPtrArg - MachInt _ -> code PtrArg + MachInt _ -> code NonPtrArg + MachWord64 _ -> code LongArg + MachInt64 _ -> code LongArg MachFloat _ -> code FloatArg MachDouble _ -> code DoubleArg MachChar _ -> code NonPtrArg - MachNullAddr -> code NonPtrArg + MachNullAddr -> code NonPtrArg MachStr s -> pushStr s - l -> pprPanic "pushAtom" (ppr l) where code rep = let size_host_words = fromIntegral (cgRepSizeW rep) - in return (unitOL (PUSH_UBX (Left lit) size_host_words), + in return (unitOL (PUSH_UBX (Left lit) size_host_words), size_host_words) - pushStr s + pushStr s = let getMallocvilleAddr = case s of - FastString _ n _ fp _ -> - -- we could grab the Ptr from the ForeignPtr, - -- but then we have no way to control its lifetime. - -- In reality it'll probably stay alive long enoungh - -- by virtue of the global FastString table, but - -- to be on the safe side we copy the string into - -- a malloc'd area of memory. + FastString _ n _ fp _ -> + -- we could grab the Ptr from the ForeignPtr, + -- but then we have no way to control its lifetime. + -- In reality it'll probably stay alive long enoungh + -- by virtue of the global FastString table, but + -- to be on the safe side we copy the string into + -- a malloc'd area of memory. do ptr <- ioToBc (mallocBytes (n+1)) recordMallocBc ptr ioToBc ( withForeignPtr fp $ \p -> do - memcpy ptr p (fromIntegral n) - pokeByteOff ptr n (fromIntegral (ord '\0') :: Word8) + memcpy ptr p (fromIntegral n) + pokeByteOff ptr n (fromIntegral (ord '\0') :: Word8) return ptr ) in do @@ -1273,11 +1269,8 @@ -- Get the addr on the stack, untaggedly return (unitOL (PUSH_UBX (Right addr) 1), 1) -pushAtom d p (AnnCast e _) - = pushAtom d p (snd e) - pushAtom _ _ expr - = pprPanic "ByteCodeGen.pushAtom" + = pprPanic "ByteCodeGen.pushAtom" (pprCoreExpr (deAnnotate (undefined, expr))) foreign import ccall unsafe "memcpy" @@ -1289,14 +1282,14 @@ -- of making a multiway branch using a switch tree. -- What a load of hassle! -mkMultiBranch :: Maybe Int -- # datacons in tycon, if alg alt - -- a hint; generates better code - -- Nothing is always safe - -> [(Discr, BCInstrList)] +mkMultiBranch :: Maybe Int -- # datacons in tycon, if alg alt + -- a hint; generates better code + -- Nothing is always safe + -> [(Discr, BCInstrList)] -> BcM BCInstrList mkMultiBranch maybe_ncons raw_ways = let d_way = filter (isNoDiscr.fst) raw_ways - notd_ways = sortLe + notd_ways = sortLe (\w1 w2 -> leAlt (fst w1) (fst w2)) (filter (not.isNoDiscr.fst) raw_ways) @@ -1304,14 +1297,14 @@ mkTree [] _range_lo _range_hi = return the_default mkTree [val] range_lo range_hi - | range_lo `eqAlt` range_hi + | range_lo `eqAlt` range_hi = return (snd val) | otherwise = do label_neq <- getLabelBc - return (testEQ (fst val) label_neq - `consOL` (snd val - `appOL` unitOL (LABEL label_neq) - `appOL` the_default)) + return (testEQ (fst val) label_neq + `consOL` (snd val + `appOL` unitOL (LABEL label_neq) + `appOL` the_default)) mkTree vals range_lo range_hi = let n = length vals `div` 2 @@ -1323,11 +1316,11 @@ code_lo <- mkTree vals_lo range_lo (dec v_mid) code_hi <- mkTree vals_hi v_mid range_hi return (testLT v_mid label_geq - `consOL` (code_lo - `appOL` unitOL (LABEL label_geq) - `appOL` code_hi)) - - the_default + `consOL` (code_lo + `appOL` unitOL (LABEL label_geq) + `appOL` code_hi)) + + the_default = case d_way of [] -> unitOL CASEFAIL [(_, def)] -> def _ -> panic "mkMultiBranch/the_default" @@ -1352,12 +1345,12 @@ = panic "mkMultiBranch: awesome foursome" | otherwise = case fst (head notd_ways) of - DiscrI _ -> ( DiscrI minBound, DiscrI maxBound ) - DiscrW _ -> ( DiscrW minBound, DiscrW maxBound ) - DiscrF _ -> ( DiscrF minF, DiscrF maxF ) - DiscrD _ -> ( DiscrD minD, DiscrD maxD ) - DiscrP _ -> ( DiscrP algMinBound, DiscrP algMaxBound ) - NoDiscr -> panic "mkMultiBranch NoDiscr" + DiscrI _ -> ( DiscrI minBound, DiscrI maxBound ) + DiscrW _ -> ( DiscrW minBound, DiscrW maxBound ) + DiscrF _ -> ( DiscrF minF, DiscrF maxF ) + DiscrD _ -> ( DiscrD minD, DiscrD maxD ) + DiscrP _ -> ( DiscrP algMinBound, DiscrP algMaxBound ) + NoDiscr -> panic "mkMultiBranch NoDiscr" (algMinBound, algMaxBound) = case maybe_ncons of @@ -1387,8 +1380,8 @@ dec (DiscrI i) = DiscrI (i-1) dec (DiscrW w) = DiscrW (w-1) dec (DiscrP i) = DiscrP (i-1) - dec other = other -- not really right, but if you - -- do cases on floating values, you'll get what you deserve + dec other = other -- not really right, but if you + -- do cases on floating values, you'll get what you deserve -- same snotty comment applies to the following minF, maxF :: Float @@ -1405,7 +1398,7 @@ -- Supporting junk for the compilation schemes -- Describes case alts -data Discr +data Discr = DiscrI Int | DiscrW Word | DiscrF Float @@ -1430,9 +1423,9 @@ -- See bug #1257 unboxedTupleException :: a -unboxedTupleException - = ghcError - (ProgramError +unboxedTupleException + = ghcError + (ProgramError ("Error: bytecode compiler can't handle unboxed tuples.\n"++ " Possibly due to foreign import/export decls in source.\n"++ " Workaround: use -fobject-code, or compile this module to .o separately.")) @@ -1442,11 +1435,11 @@ mkSLIDE n d = if d == 0 then nilOL else unitOL (SLIDE n d) splitApp :: AnnExpr' Var ann -> (AnnExpr' Var ann, [AnnExpr' Var ann]) - -- The arguments are returned in *right-to-left* order + -- The arguments are returned in *right-to-left* order splitApp e | Just e' <- bcView e = splitApp e' -splitApp (AnnApp (_,f) (_,a)) = case splitApp f of - (f', as) -> (f', a:as) -splitApp e = (e, []) +splitApp (AnnApp (_,f) (_,a)) = case splitApp f of + (f', as) -> (f', a:as) +splitApp e = (e, []) bcView :: AnnExpr' Var ann -> Maybe (AnnExpr' Var ann) @@ -1455,23 +1448,25 @@ -- b) type applications -- c) casts -- d) notes --- Type lambdas *can* occur in random expressions, +-- Type lambdas *can* occur in random expressions, -- whereas value lambdas cannot; that is why they are nuked here bcView (AnnNote _ (_,e)) = Just e bcView (AnnCast (_,e) _) = Just e -bcView (AnnLam v (_,e)) | isTyCoVar v = Just e +bcView (AnnLam v (_,e)) | isTyVar v = Just e bcView (AnnApp (_,e) (_, AnnType _)) = Just e bcView _ = Nothing isVoidArgAtom :: AnnExpr' Var ann -> Bool isVoidArgAtom e | Just e' <- bcView e = isVoidArgAtom e' isVoidArgAtom (AnnVar v) = typePrimRep (idType v) == VoidRep +isVoidArgAtom (AnnCoercion {}) = True isVoidArgAtom _ = False atomPrimRep :: AnnExpr' Id ann -> PrimRep atomPrimRep e | Just e' <- bcView e = atomPrimRep e' atomPrimRep (AnnVar v) = typePrimRep (idType v) atomPrimRep (AnnLit l) = typePrimRep (literalType l) +atomPrimRep (AnnCoercion {}) = VoidRep atomPrimRep other = pprPanic "atomPrimRep" (ppr (deAnnotate (undefined,other))) atomRep :: AnnExpr' Id ann -> CgRep @@ -1492,32 +1487,32 @@ type BcPtr = Either ItblPtr (Ptr ()) -data BcM_State - = BcM_State { +data BcM_State + = BcM_State { uniqSupply :: UniqSupply, -- for generating fresh variable names - nextlabel :: Word16, -- for generating local labels - malloced :: [BcPtr], -- thunks malloced for current BCO - -- Should be free()d when it is GCd - breakArray :: BreakArray -- array of breakpoint flags + nextlabel :: Word16, -- for generating local labels + malloced :: [BcPtr], -- thunks malloced for current BCO + -- Should be free()d when it is GCd + breakArray :: BreakArray -- array of breakpoint flags } newtype BcM r = BcM (BcM_State -> IO (BcM_State, r)) ioToBc :: IO a -> BcM a -ioToBc io = BcM $ \st -> do - x <- io +ioToBc io = BcM $ \st -> do + x <- io return (st, x) runBc :: UniqSupply -> ModBreaks -> BcM r -> IO (BcM_State, r) -runBc us modBreaks (BcM m) - = m (BcM_State us 0 [] breakArray) +runBc us modBreaks (BcM m) + = m (BcM_State us 0 [] breakArray) where breakArray = modBreaks_flags modBreaks thenBc :: BcM a -> (a -> BcM b) -> BcM b thenBc (BcM expr) cont = BcM $ \st0 -> do (st1, q) <- expr st0 - let BcM k = cont q + let BcM k = cont q (st2, r) <- k st1 return (st2, r) @@ -1556,20 +1551,20 @@ getLabelsBc :: Word16 -> BcM [Word16] getLabelsBc n - = BcM $ \st -> let ctr = nextlabel st - in return (st{nextlabel = ctr+n}, [ctr .. ctr+n-1]) + = BcM $ \st -> let ctr = nextlabel st + in return (st{nextlabel = ctr+n}, [ctr .. ctr+n-1]) -getBreakArray :: BcM BreakArray +getBreakArray :: BcM BreakArray getBreakArray = BcM $ \st -> return (st, breakArray st) newUnique :: BcM Unique newUnique = BcM $ - \st -> case splitUniqSupply (uniqSupply st) of - (us1, us2) -> let newState = st { uniqSupply = us2 } - in return (newState, uniqFromSupply us1) + \st -> case takeUniqFromSupply (uniqSupply st) of + (uniq, us) -> let newState = st { uniqSupply = us } + in return (newState, uniq) newId :: Type -> BcM Id -newId ty = do +newId ty = do uniq <- newUnique return $ mkSysLocal tickFS uniq ty diff -Nru ghc-7.0.3/compiler/ghci/ByteCodeInstr.lhs ghc-7.2.1/compiler/ghci/ByteCodeInstr.lhs --- ghc-7.0.3/compiler/ghci/ByteCodeInstr.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/ghci/ByteCodeInstr.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -124,9 +124,12 @@ | CASEFAIL | JMP LocalLabel - -- For doing calls to C (via glue code generated by ByteCodeFFI, or libffi) + -- For doing calls to C (via glue code generated by libffi) | CCALL Word16 -- stack frame size (Ptr ()) -- addr of the glue code + Word16 -- whether or not the call is interruptible + -- (XXX: inefficient, but I don't know + -- what the alignment constraints are.) -- For doing magic ByteArray passing to foreign calls | SWIZZLE Word16 -- to the ptr N words down the stack, @@ -217,9 +220,12 @@ ppr (TESTEQ_P i lab) = text "TESTEQ_P" <+> ppr i <+> text "__" <> ppr lab ppr CASEFAIL = text "CASEFAIL" ppr (JMP lab) = text "JMP" <+> ppr lab - ppr (CCALL off marshall_addr) = text "CCALL " <+> ppr off + ppr (CCALL off marshall_addr int) = text "CCALL " <+> ppr off <+> text "marshall code at" <+> text (show marshall_addr) + <+> (if int == 1 + then text "(interruptible)" + else empty) ppr (SWIZZLE stkoff n) = text "SWIZZLE " <+> text "stkoff" <+> ppr stkoff <+> text "by" <+> ppr n ppr ENTER = text "ENTER" diff -Nru ghc-7.0.3/compiler/ghci/ByteCodeItbls.lhs ghc-7.2.1/compiler/ghci/ByteCodeItbls.lhs --- ghc-7.0.3/compiler/ghci/ByteCodeItbls.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/ghci/ByteCodeItbls.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -36,7 +36,7 @@ import Data.Bits ( Bits(..), shiftR ) import GHC.Exts ( Int(I#), addr2Int# ) -import GHC.Ptr ( Ptr(..) ) +import GHC.Ptr ( Ptr(..) ) import Debug.Trace import Text.Printf diff -Nru ghc-7.0.3/compiler/ghci/ByteCodeLink.lhs ghc-7.2.1/compiler/ghci/ByteCodeLink.lhs --- ghc-7.0.3/compiler/ghci/ByteCodeLink.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/ghci/ByteCodeLink.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -4,6 +4,7 @@ ByteCodeLink: Bytecode assembler and linker \begin{code} +{-# LANGUAGE BangPatterns #-} {-# OPTIONS -optc-DNON_POSIX_SOURCE #-} {-# OPTIONS -w #-} @@ -37,19 +38,18 @@ import Outputable -- Standard libraries -import GHC.Word ( Word(..) ) import Data.Array.Base -import GHC.Arr ( STArray(..) ) import Control.Monad ( zipWithM ) import Control.Monad.ST ( stToIO ) -import GHC.Exts -import GHC.Arr ( Array(..) ) +import GHC.Arr ( Array(..), STArray(..) ) +import GHC.Base ( writeArray#, RealWorld, Int(..), Word# ) import GHC.IOBase ( IO(..) ) +import GHC.Exts import GHC.Ptr ( Ptr(..), castPtr ) -import GHC.Base ( writeArray#, RealWorld, Int(..), Word# ) +import GHC.Word ( Word(..) ) import Data.Word \end{code} diff -Nru ghc-7.0.3/compiler/ghci/Debugger.hs ghc-7.2.1/compiler/ghci/Debugger.hs --- ghc-7.0.3/compiler/ghci/Debugger.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/ghci/Debugger.hs 2011-08-07 17:10:05.000000000 +0000 @@ -15,23 +15,19 @@ import Linker import RtClosureInspect +import GhcMonad import HscTypes import Id import Name import Var hiding ( varName ) import VarSet --- import Name import UniqSupply import TcType import GHC --- import DynFlags -import InteractiveEval import Outputable --- import SrcLoc import PprTyThing import MonadUtils --- import Exception import Control.Monad import Data.List import Data.Maybe diff -Nru ghc-7.0.3/compiler/ghci/Linker.lhs ghc-7.2.1/compiler/ghci/Linker.lhs --- ghc-7.0.3/compiler/ghci/Linker.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/ghci/Linker.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -15,8 +15,11 @@ linkExpr, unload, withExtendedLinkEnv, extendLinkEnv, deleteFromLinkEnv, extendLoadedPkgs, - linkPackages,initDynLinker, - dataConInfoPtrToName + linkPackages,initDynLinker,linkModule, + dataConInfoPtrToName, lessUnsafeCoerce, + + -- Saving/restoring globals + PersistentLinkerState, saveLinkerGlobals, restoreLinkerGlobals ) where #include "HsVersions.h" @@ -55,6 +58,8 @@ import FastString import Config +import GHC.Exts (unsafeCoerce#) + -- Standard libraries import Control.Monad @@ -84,14 +89,23 @@ The persistent linker state *must* match the actual state of the C dynamic linker at all times, so we keep it in a private global variable. +The global IORef used for PersistentLinkerState actually contains another MVar. +The reason for this is that we want to allow another loaded copy of the GHC +library to side-effect the PLS and for those changes to be reflected here. The PersistentLinkerState maps Names to actual closures (for interpreted code only), for use during linking. \begin{code} -GLOBAL_MVAR(v_PersistentLinkerState, panic "Dynamic linker not initialised", PersistentLinkerState) +GLOBAL_VAR_M(v_PersistentLinkerState, newMVar (panic "Dynamic linker not initialised"), MVar PersistentLinkerState) GLOBAL_VAR(v_InitLinkerDone, False, Bool) -- Set True when dynamic linker is initialised +modifyPLS_ :: (PersistentLinkerState -> IO PersistentLinkerState) -> IO () +modifyPLS_ f = readIORef v_PersistentLinkerState >>= flip modifyMVar_ f + +modifyPLS :: (PersistentLinkerState -> IO (PersistentLinkerState, a)) -> IO a +modifyPLS f = readIORef v_PersistentLinkerState >>= flip modifyMVar f + data PersistentLinkerState = PersistentLinkerState { @@ -136,19 +150,19 @@ \begin{code} extendLoadedPkgs :: [PackageId] -> IO () extendLoadedPkgs pkgs = - modifyMVar_ v_PersistentLinkerState $ \s -> + modifyPLS_ $ \s -> return s{ pkgs_loaded = pkgs ++ pkgs_loaded s } extendLinkEnv :: [(Name,HValue)] -> IO () -- Automatically discards shadowed bindings extendLinkEnv new_bindings = - modifyMVar_ v_PersistentLinkerState $ \pls -> + modifyPLS_ $ \pls -> let new_closure_env = extendClosureEnv (closure_env pls) new_bindings in return pls{ closure_env = new_closure_env } deleteFromLinkEnv :: [Name] -> IO () deleteFromLinkEnv to_remove = - modifyMVar_ v_PersistentLinkerState $ \pls -> + modifyPLS_ $ \pls -> let new_closure_env = delListFromNameEnv (closure_env pls) to_remove in return pls{ closure_env = new_closure_env } @@ -245,11 +259,18 @@ where (modWords, occWord) = ASSERT (length rest1 > 0) (parseModOcc [] (tail rest1)) parseModOcc :: [[Word8]] -> [Word8] -> ([[Word8]], [Word8]) - parseModOcc acc str + -- We only look for dots if str could start with a module name, + -- i.e. if it starts with an upper case character. + -- Otherwise we might think that "X.:->" is the module name in + -- "X.:->.+", whereas actually "X" is the module name and + -- ":->.+" is a constructor name. + parseModOcc acc str@(c : _) + | isUpper $ chr $ fromIntegral c = case break (== dot) str of (top, []) -> (acc, top) - (top, _:bot) -> parseModOcc (top : acc) bot - + (top, _ : bot) -> parseModOcc (top : acc) bot + parseModOcc acc str = (acc, str) + -- | Get the 'HValue' associated with the given name. -- -- May cause loading the module that contains the name. @@ -257,7 +278,8 @@ -- Throws a 'ProgramError' if loading fails or the name cannot be found. getHValue :: HscEnv -> Name -> IO HValue getHValue hsc_env name = do - pls <- modifyMVar v_PersistentLinkerState $ \pls -> do + initDynLinker (hsc_dflags hsc_env) + pls <- modifyPLS $ \pls -> do if (isExternalName name) then do (pls', ok) <- linkDependencies hsc_env pls noSrcSpan [nameModule name] if (failed ok) then ghcError (ProgramError "") @@ -270,6 +292,7 @@ -> SrcSpan -> [Module] -> IO (PersistentLinkerState, SuccessFlag) linkDependencies hsc_env pls span needed_mods = do +-- initDynLinker (hsc_dflags hsc_env) let hpt = hsc_HPT hsc_env dflags = hsc_dflags hsc_env -- The interpreter and dynamic linker can only handle object code built @@ -302,7 +325,7 @@ -- package), so the reset action only removes the names we -- added earlier. reset_old_env = liftIO $ do - modifyMVar_ v_PersistentLinkerState $ \pls -> + modifyPLS_ $ \pls -> let cur = closure_env pls new = delListFromNameEnv cur (map fst new_env) in return pls{ closure_env = new } @@ -326,7 +349,7 @@ -- | Display the persistent linker state. showLinkerState :: IO () showLinkerState - = do pls <- readMVar v_PersistentLinkerState + = do pls <- readIORef v_PersistentLinkerState >>= readMVar printDump (vcat [text "----- Linker state -----", text "Pkgs:" <+> ppr (pkgs_loaded pls), text "Objs:" <+> ppr (objs_loaded pls), @@ -363,7 +386,7 @@ -- initDynLinker :: DynFlags -> IO () initDynLinker dflags = - modifyMVar_ v_PersistentLinkerState $ \pls0 -> do + modifyPLS_ $ \pls0 -> do done <- readIORef v_InitLinkerDone if done then return pls0 else do writeIORef v_InitLinkerDone True @@ -501,7 +524,7 @@ ; initDynLinker dflags -- Take lock for the actual work. - ; modifyMVar v_PersistentLinkerState $ \pls0 -> do { + ; modifyPLS $ \pls0 -> do { -- Link the packages and modules required ; (pls, ok) <- linkDependencies hsc_env pls0 span needed_mods @@ -626,7 +649,7 @@ boot_deps' = filter (not . (`elementOfUniqSet` acc_mods)) boot_deps acc_mods' = addListToUniqSet acc_mods (moduleName mod : mod_deps) - acc_pkgs' = addListToUniqSet acc_pkgs pkg_deps + acc_pkgs' = addListToUniqSet acc_pkgs $ map fst pkg_deps -- if pkg /= this_pkg then follow_deps mods acc_mods (addOneToUniqSet acc_pkgs' pkg) @@ -689,6 +712,38 @@ adjust_ul _ _ = panic "adjust_ul" \end{code} +%************************************************************************ +%* * + Loading a single module +%* * +%************************************************************************ +\begin{code} + +-- | Link a single module +linkModule :: HscEnv -> Module -> IO () +linkModule hsc_env mod = do + initDynLinker (hsc_dflags hsc_env) + modifyPLS_ $ \pls -> do + (pls', ok) <- linkDependencies hsc_env pls noSrcSpan [mod] + if (failed ok) then ghcError (ProgramError "could not link module") + else return pls' + +-- | Coerce a value as usual, but: +-- +-- 1) Evaluate it immediately to get a segfault early if the coercion was wrong +-- +-- 2) Wrap it in some debug messages at verbosity 3 or higher so we can see what happened +-- if it /does/ segfault +lessUnsafeCoerce :: DynFlags -> String -> a -> IO b +lessUnsafeCoerce dflags context what = do + debugTraceMsg dflags 3 $ (ptext $ sLit "Coercing a value in") <+> (text context) <> (ptext $ sLit "...") + output <- evaluate (unsafeCoerce# what) + debugTraceMsg dflags 3 $ ptext $ sLit "Successfully evaluated coercion" + return output + + + +\end{code} %************************************************************************ %* * @@ -878,7 +933,7 @@ initDynLinker dflags new_pls - <- modifyMVar v_PersistentLinkerState $ \pls -> do + <- modifyPLS $ \pls -> do pls1 <- unload_wkr dflags linkables pls return (pls1, pls1) @@ -990,7 +1045,8 @@ linkPackages dflags new_pkgs = do -- It's probably not safe to try to load packages concurrently, so we take -- a lock. - modifyMVar_ v_PersistentLinkerState $ \pls -> do + initDynLinker dflags + modifyPLS_ $ \pls -> do linkPackages' dflags new_pkgs pls linkPackages' :: DynFlags -> [PackageId] -> PersistentLinkerState @@ -1049,26 +1105,18 @@ classifieds <- mapM (locateOneObj dirs) libs' -- Complication: all the .so's must be loaded before any of the .o's. - let dlls = [ dll | DLL dll <- classifieds ] - objs = [ obj | Object obj <- classifieds ] - archs = [ arch | Archive arch <- classifieds ] + let known_dlls = [ dll | DLLPath dll <- classifieds ] + dlls = [ dll | DLL dll <- classifieds ] + objs = [ obj | Object obj <- classifieds ] + archs = [ arch | Archive arch <- classifieds ] maybePutStr dflags ("Loading package " ++ display (sourcePackageId pkg) ++ " ... ") -- See comments with partOfGHCi when (packageName pkg `notElem` partOfGHCi) $ do loadFrameworks pkg - -- When a library A needs symbols from a library B, the order in - -- extra_libraries/extra_ld_opts is "-lA -lB", because that's the - -- way ld expects it for static linking. Dynamic linking is a - -- different story: When A has no dependency information for B, - -- dlopen-ing A with RTLD_NOW (see addDLL in Linker.c) will fail - -- when B has not been loaded before. In a nutshell: Reverse the - -- order of DLLs for dynamic linking. - -- This fixes a problem with the HOpenGL package (see "Compiling - -- HOpenGL under recent versions of GHC" on the HOpenGL list). - mapM_ (load_dyn dirs) (reverse dlls) - + mapM_ load_dyn (known_dlls ++ map mkSOName dlls) + -- After loading all the DLLs, we can load the static objects. -- Ordering isn't important here, because we do one final link -- step to resolve everything. @@ -1080,12 +1128,17 @@ if succeeded ok then maybePutStrLn dflags "done." else ghcError (InstallationError ("unable to load package `" ++ display (sourcePackageId pkg) ++ "'")) -load_dyn :: [FilePath] -> FilePath -> IO () -load_dyn dirs dll = do r <- loadDynamic dirs dll - case r of - Nothing -> return () - Just err -> ghcError (CmdLineError ("can't load .so/.DLL for: " - ++ dll ++ " (" ++ err ++ ")" )) +-- we have already searched the filesystem; the strings passed to load_dyn +-- can be passed directly to loadDLL. They are either fully-qualified +-- ("/usr/lib/libfoo.so"), or unqualified ("libfoo.so"). In the latter case, +-- loadDLL is going to search the system paths to find the library. +-- +load_dyn :: FilePath -> IO () +load_dyn dll = do r <- loadDLL dll + case r of + Nothing -> return () + Just err -> ghcError (CmdLineError ("can't load .so/.DLL for: " + ++ dll ++ " (" ++ err ++ ")" )) loadFrameworks :: InstalledPackageInfo_ ModuleName -> IO () loadFrameworks pkg @@ -1124,7 +1177,7 @@ mk_dyn_lib_path dir = dir mkSOName dyn_lib_name findObject = liftM (fmap Object) $ findFile mk_obj_path dirs findArchive = liftM (fmap Archive) $ findFile mk_arch_path dirs - findDll = liftM (fmap DLL) $ findFile mk_dyn_lib_path dirs + findDll = liftM (fmap DLLPath) $ findFile mk_dyn_lib_path dirs assumeDll = return (DLL lib) infixr `orElse` f `orElse` g = do m <- f @@ -1207,3 +1260,19 @@ maybePutStrLn dflags s | verbosity dflags > 0 = putStrLn s | otherwise = return () \end{code} + +%************************************************************************ +%* * + Tunneling global variables into new instance of GHC library +%* * +%************************************************************************ + +\begin{code} +saveLinkerGlobals :: IO (MVar PersistentLinkerState, Bool) +saveLinkerGlobals = liftM2 (,) (readIORef v_PersistentLinkerState) (readIORef v_InitLinkerDone) + +restoreLinkerGlobals :: (MVar PersistentLinkerState, Bool) -> IO () +restoreLinkerGlobals (pls, ild) = do + writeIORef v_PersistentLinkerState pls + writeIORef v_InitLinkerDone ild +\end{code} \ No newline at end of file diff -Nru ghc-7.0.3/compiler/ghci/ObjLink.lhs ghc-7.2.1/compiler/ghci/ObjLink.lhs --- ghc-7.0.3/compiler/ghci/ObjLink.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/ghci/ObjLink.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -28,6 +28,8 @@ import Foreign.C import Foreign ( nullPtr ) import GHC.Exts ( Ptr(..) ) +import GHC.IO.Encoding ( fileSystemEncoding ) +import qualified GHC.Foreign as GHC @@ -35,17 +37,21 @@ -- RTS Linker Interface -- --------------------------------------------------------------------------- +-- UNICODE FIXME: Unicode object/archive/DLL file names on Windows will only work in the right code page +withFileCString :: FilePath -> (CString -> IO a) -> IO a +withFileCString = GHC.withCString fileSystemEncoding + insertSymbol :: String -> String -> Ptr a -> IO () insertSymbol obj_name key symbol = let str = prefixUnderscore key - in withCString obj_name $ \c_obj_name -> - withCString str $ \c_str -> + in withFileCString obj_name $ \c_obj_name -> + withCAString str $ \c_str -> c_insertSymbol c_obj_name c_str symbol lookupSymbol :: String -> IO (Maybe (Ptr a)) lookupSymbol str_in = do let str = prefixUnderscore str_in - withCString str $ \c_str -> do + withCAString str $ \c_str -> do addr <- c_lookupSymbol c_str if addr == nullPtr then return Nothing @@ -60,7 +66,7 @@ -- Nothing => success -- Just err_msg => failure loadDLL str = do - maybe_errmsg <- withCString str $ \dll -> c_addDLL dll + maybe_errmsg <- withFileCString str $ \dll -> c_addDLL dll if maybe_errmsg == nullPtr then return Nothing else do str <- peekCString maybe_errmsg @@ -68,19 +74,19 @@ loadArchive :: String -> IO () loadArchive str = do - withCString str $ \c_str -> do + withFileCString str $ \c_str -> do r <- c_loadArchive c_str when (r == 0) (panic ("loadArchive " ++ show str ++ ": failed")) loadObj :: String -> IO () loadObj str = do - withCString str $ \c_str -> do + withFileCString str $ \c_str -> do r <- c_loadObj c_str when (r == 0) (panic ("loadObj " ++ show str ++ ": failed")) unloadObj :: String -> IO () unloadObj str = - withCString str $ \c_str -> do + withFileCString str $ \c_str -> do r <- c_unloadObj c_str when (r == 0) (panic ("unloadObj " ++ show str ++ ": failed")) diff -Nru ghc-7.0.3/compiler/ghci/RtClosureInspect.hs ghc-7.2.1/compiler/ghci/RtClosureInspect.hs --- ghc-7.0.3/compiler/ghci/RtClosureInspect.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/ghci/RtClosureInspect.hs 2011-08-07 17:10:05.000000000 +0000 @@ -45,27 +45,19 @@ import Name import VarEnv import Util -import ListSetOps import VarSet import TysPrim import PrelNames import TysWiredIn import DynFlags -import Outputable +import Outputable as Ppr import FastString --- import Panic - import Constants ( wORD_SIZE ) - import GHC.Arr ( Array(..) ) import GHC.Exts - -#if __GLASGOW_HASKELL__ >= 611 import GHC.IO ( IO(..) ) -#else -import GHC.IOBase ( IO(..) ) -#endif +import StaticFlags( opt_PprStyle_Debug ) import Control.Monad import Data.Maybe import Data.Array.Base @@ -74,7 +66,7 @@ import qualified Data.Sequence as Seq import Data.Monoid import Data.Sequence (viewl, ViewL(..)) -import Foreign hiding (unsafePerformIO) +import Foreign.Safe import System.IO.Unsafe --------------------------------------------- @@ -191,7 +183,7 @@ elems = fromIntegral (BCI.ptrs itbl) ptrsList = Array 0 (elems - 1) elems ptrs nptrs_data = [W# (indexWordArray# nptrs i) - | I# i <- [0.. fromIntegral (BCI.nptrs itbl)] ] + | I# i <- [0.. fromIntegral (BCI.nptrs itbl)-1] ] ASSERT(elems >= 0) return () ptrsList `seq` return (Closure tipe (Ptr iptr) itbl ptrsList nptrs_data) @@ -351,10 +343,17 @@ = parens (ppr_term1 True t1 <+> ppr dc <+> ppr_term1 True ppr t2) <+> hsep (map (ppr_term1 True) tt) -} -- TODO Printing infix constructors properly - | null tt = return$ ppr dc - | otherwise = do - tt_docs <- mapM (y app_prec) tt - return$ cparen (p >= app_prec) (ppr dc <+> pprDeeperList fsep tt_docs) + | null sub_terms_to_show + = return (ppr dc) + | otherwise + = do { tt_docs <- mapM (y app_prec) sub_terms_to_show + ; return $ cparen (p >= app_prec) $ + sep [ppr dc, nest 2 (pprDeeperList fsep tt_docs)] } + where + sub_terms_to_show -- Don't show the dictionary arguments to + -- constructors unless -dppr-debug is on + | opt_PprStyle_Debug = tt + | otherwise = dropList (dataConTheta dc) tt ppr_termM y p t@NewtypeWrap{} = pprNewtypeWrap y p t ppr_termM y p RefWrap{wrapped_term=t} = do @@ -419,55 +418,70 @@ firstJustM [] = return Nothing -- Default set of custom printers. Note that the recursion knot is explicit -cPprTermBase :: Monad m => CustomTermPrinter m +cPprTermBase :: forall m. Monad m => CustomTermPrinter m cPprTermBase y = [ ifTerm (isTupleTy.ty) (\_p -> liftM (parens . hcat . punctuate comma) . mapM (y (-1)) . subTerms) , ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2) - (\ p t -> doList p t) - , ifTerm (isTyCon intTyCon . ty) (coerceShow$ \(a::Int)->a) - , ifTerm (isTyCon charTyCon . ty) (coerceShow$ \(a::Char)->a) - , ifTerm (isTyCon floatTyCon . ty) (coerceShow$ \(a::Float)->a) - , ifTerm (isTyCon doubleTyCon . ty) (coerceShow$ \(a::Double)->a) - , ifTerm (isIntegerTy . ty) (coerceShow$ \(a::Integer)->a) + ppr_list + , ifTerm (isTyCon intTyCon . ty) ppr_int + , ifTerm (isTyCon charTyCon . ty) ppr_char + , ifTerm (isTyCon floatTyCon . ty) ppr_float + , ifTerm (isTyCon doubleTyCon . ty) ppr_double + , ifTerm (isIntegerTy . ty) ppr_integer ] - where ifTerm pred f prec t@Term{} - | pred t = Just `liftM` f prec t - ifTerm _ _ _ _ = return Nothing - - isTupleTy ty = fromMaybe False $ do - (tc,_) <- tcSplitTyConApp_maybe ty - return (isBoxedTupleTyCon tc) - - isTyCon a_tc ty = fromMaybe False $ do - (tc,_) <- tcSplitTyConApp_maybe ty - return (a_tc == tc) - - isIntegerTy ty = fromMaybe False $ do - (tc,_) <- tcSplitTyConApp_maybe ty - return (tyConName tc == integerTyConName) - - coerceShow f _p = return . text . show . f . unsafeCoerce# . val - - --Note pprinting of list terms is not lazy - doList p (Term{subTerms=[h,t]}) = do - let elems = h : getListTerms t - isConsLast = not(termType(last elems) `coreEqType` termType h) - print_elems <- mapM (y cons_prec) elems - return$ if isConsLast - then cparen (p >= cons_prec) - . pprDeeperList fsep - . punctuate (space<>colon) - $ print_elems - else brackets (pprDeeperList fcat$ - punctuate comma print_elems) - - where getListTerms Term{subTerms=[h,t]} = h : getListTerms t - getListTerms Term{subTerms=[]} = [] - getListTerms t@Suspension{} = [t] - getListTerms t = pprPanic "getListTerms" (ppr t) - doList _ _ = panic "doList" + where + ifTerm :: (Term -> Bool) + -> (Precedence -> Term -> m SDoc) + -> Precedence -> Term -> m (Maybe SDoc) + ifTerm pred f prec t@Term{} + | pred t = Just `liftM` f prec t + ifTerm _ _ _ _ = return Nothing + + isTupleTy ty = fromMaybe False $ do + (tc,_) <- tcSplitTyConApp_maybe ty + return (isBoxedTupleTyCon tc) + + isTyCon a_tc ty = fromMaybe False $ do + (tc,_) <- tcSplitTyConApp_maybe ty + return (a_tc == tc) + + isIntegerTy ty = fromMaybe False $ do + (tc,_) <- tcSplitTyConApp_maybe ty + return (tyConName tc == integerTyConName) + + ppr_int, ppr_char, ppr_float, ppr_double, ppr_integer + :: Precedence -> Term -> m SDoc + ppr_int _ v = return (Ppr.int (unsafeCoerce# (val v))) + ppr_char _ v = return (Ppr.char '\'' <> Ppr.char (unsafeCoerce# (val v)) <> Ppr.char '\'') + ppr_float _ v = return (Ppr.float (unsafeCoerce# (val v))) + ppr_double _ v = return (Ppr.double (unsafeCoerce# (val v))) + ppr_integer _ v = return (Ppr.integer (unsafeCoerce# (val v))) + + --Note pprinting of list terms is not lazy + ppr_list :: Precedence -> Term -> m SDoc + ppr_list p (Term{subTerms=[h,t]}) = do + let elems = h : getListTerms t + isConsLast = not(termType(last elems) `eqType` termType h) + is_string = all (isCharTy . ty) elems + + print_elems <- mapM (y cons_prec) elems + if is_string + then return (Ppr.doubleQuotes (Ppr.text (unsafeCoerce# (map val elems)))) + else if isConsLast + then return $ cparen (p >= cons_prec) + $ pprDeeperList fsep + $ punctuate (space<>colon) print_elems + else return $ brackets + $ pprDeeperList fcat + $ punctuate comma print_elems + + where getListTerms Term{subTerms=[h,t]} = h : getListTerms t + getListTerms Term{subTerms=[]} = [] + getListTerms t@Suspension{} = [t] + getListTerms t = pprPanic "getListTerms" (ppr t) + ppr_list _ _ = panic "doList" repPrim :: TyCon -> [Word] -> String @@ -571,13 +585,18 @@ newVar :: Kind -> TR TcType newVar = liftTcM . newFlexiTyVarTy +instTyVars :: [TyVar] -> TR ([TcTyVar], [TcType], TvSubst) +-- Instantiate fresh mutable type variables from some TyVars +-- This function preserves the print-name, which helps error messages +instTyVars = liftTcM . tcInstTyVars + type RttiInstantiation = [(TcTyVar, TyVar)] -- Associates the typechecker-world meta type variables -- (which are mutable and may be refined), to their - -- debugger-world RuntimeUnkSkol counterparts. + -- debugger-world RuntimeUnk counterparts. -- If the TcTyVar has not been refined by the runtime type -- elaboration, then we want to turn it back into the - -- original RuntimeUnkSkol + -- original RuntimeUnk -- | Returns the instantiated type scheme ty', and the -- mapping from new (instantiated) -to- old (skolem) type variables @@ -663,7 +682,10 @@ text "Type obtained: " <> ppr (termType term)) return term where + go :: Int -> Type -> Type -> HValue -> TcM Term + -- [SPJ May 11] I don't understand the difference between my_ty and old_ty + go max_depth _ _ _ | seq max_depth False = undefined go 0 my_ty _old_ty a = do traceTR (text "Gave up reconstructing a term after" <> @@ -709,7 +731,7 @@ traceTR (text "entering a constructor " <> if monomorphic then parens (text "already monomorphic: " <> ppr my_ty) - else Outputable.empty) + else Ppr.empty) Right dcname <- dataConInfoPtrToName (infoPtr clos) (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname) case mb_dc of @@ -718,59 +740,34 @@ -- In such case, we return a best approximation: -- ignore the unpointed args, and recover the pointeds -- This preserves laziness, and should be safe. + traceTR (text "Nothing" <+> ppr dcname) let tag = showSDoc (ppr dcname) vars <- replicateM (length$ elems$ ptrs clos) - (newVar (liftedTypeKind)) + (newVar liftedTypeKind) subTerms <- sequence [appArr (go (pred max_depth) tv tv) (ptrs clos) i | (i, tv) <- zip [0..] vars] return (Term my_ty (Left ('<' : tag ++ ">")) a subTerms) Just dc -> do - let subTtypes = matchSubTypes dc old_ty - subTermTvs <- mapMif (not . isMonomorphic) - (\t -> newVar (typeKind t)) - subTtypes - let (subTermsP, subTermsNP) = partition (\(ty,_) -> isLifted ty - || isRefType ty) - (zip subTtypes subTermTvs) - (subTtypesP, subTermTvsP ) = unzip subTermsP - (subTtypesNP, _subTermTvsNP) = unzip subTermsNP - - -- When we already have all the information, avoid solving - -- unnecessary constraints. Propagation of type information - -- to subterms is already being done via matching. - when (not monomorphic) $ do - let myType = mkFunTys subTermTvs my_ty - (signatureType,_) <- instScheme (mydataConType dc) - -- It is vital for newtype reconstruction that the unification step - -- is done right here, _before_ the subterms are RTTI reconstructed - addConstraint myType signatureType + traceTR (text "Just" <+> ppr dc) + subTtypes <- getDataConArgTys dc my_ty + let (subTtypesP, subTtypesNP) = partition isPtrType subTtypes subTermsP <- sequence - [ appArr (go (pred max_depth) tv t) (ptrs clos) i - | (i,tv,t) <- zip3 [0..] subTermTvsP subTtypesP] + [ appArr (go (pred max_depth) ty ty) (ptrs clos) i + | (i,ty) <- zip [0..] subTtypesP] let unboxeds = extractUnboxed subTtypesNP clos - subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds) + subTermsNP = zipWith Prim subTtypesNP unboxeds subTerms = reOrderTerms subTermsP subTermsNP subTtypes return (Term my_ty (Right dc) a subTerms) + -- The otherwise case: can be a Thunk,AP,PAP,etc. tipe_clos -> return (Suspension tipe_clos my_ty a Nothing) - matchSubTypes dc ty - | ty' <- repType ty -- look through newtypes - , Just (tc,ty_args) <- tcSplitTyConApp_maybe ty' - , dc `elem` tyConDataCons tc - -- It is necessary to check that dc is actually a constructor for tycon tc, - -- because it may be the case that tc is a recursive newtype and tcSplitTyConApp - -- has not removed it. In that case, we happily give up and don't match - = myDataConInstArgTys dc ty_args - | otherwise = dataConRepArgTys dc - -- put together pointed and nonpointed subterms in the -- correct order. reOrderTerms _ _ [] = [] reOrderTerms pointed unpointed (ty:tys) - | isLifted ty || isRefType ty - = ASSERT2(not(null pointed) + | isPtrType ty = ASSERT2(not(null pointed) , ptext (sLit "reOrderTerms") $$ (ppr pointed $$ ppr unpointed)) let (t:tt) = pointed in t : reOrderTerms tt unpointed tys @@ -840,6 +837,7 @@ -- returns unification tasks,since we are going to want a breadth-first search go :: Type -> HValue -> TR [(Type, HValue)] go my_ty a = do + traceTR (text "go" <+> ppr my_ty) clos <- trIO $ getClosureData a case tipe clos of Blackhole -> appArr (go my_ty) (ptrs clos) 0 -- carefully, don't eval the TSO @@ -852,6 +850,7 @@ return [(tv', contents)] Constr -> do Right dcname <- dataConInfoPtrToName (infoPtr clos) + traceTR (text "Constr1" <+> ppr dcname) (_,mb_dc) <- tryTcErrs (tcLookupDataCon dcname) case mb_dc of Nothing-> do @@ -861,17 +860,10 @@ return$ appArr (\e->(tv,e)) (ptrs clos) i Just dc -> do - subTtypes <- mapMif (not . isMonomorphic) - (\t -> newVar (typeKind t)) - (dataConRepArgTys dc) - - -- It is vital for newtype reconstruction that the unification step - -- is done right here, _before_ the subterms are RTTI reconstructed - let myType = mkFunTys subTtypes my_ty - (signatureType,_) <- instScheme (mydataConType dc) - addConstraint myType signatureType - return $ [ appArr (\e->(t,e)) (ptrs clos) i - | (i,t) <- zip [0..] (filter (isLifted |.| isRefType) subTtypes)] + arg_tys <- getDataConArgTys dc my_ty + traceTR (text "Constr2" <+> ppr dcname <+> ppr arg_tys) + return $ [ appArr (\e-> (ty,e)) (ptrs clos) i + | (i,ty) <- zip [0..] (filter isPtrType arg_tys)] _ -> return [] -- Compute the difference between a base type and the type found by RTTI @@ -882,36 +874,36 @@ improveRTTIType _ base_ty new_ty = U.tcUnifyTys (const U.BindMe) [base_ty] [new_ty] -myDataConInstArgTys :: DataCon -> [Type] -> [Type] -myDataConInstArgTys dc args - | null (dataConExTyVars dc) && null (dataConEqTheta dc) = dataConInstArgTys dc args - | otherwise = dataConRepArgTys dc - -mydataConType :: DataCon -> QuantifiedType --- ^ Custom version of DataCon.dataConUserType where we --- - remove the equality constraints --- - use the representation types for arguments, including dictionaries --- - keep the original result type -mydataConType dc - = ( (univ_tvs `minusList` map fst eq_spec) ++ ex_tvs - , mkFunTys arg_tys res_ty ) - where univ_tvs = dataConUnivTyVars dc - ex_tvs = dataConExTyVars dc - eq_spec = dataConEqSpec dc - arg_tys = [case a of - PredTy p -> predTypeRep p - _ -> a - | a <- dataConRepArgTys dc] - res_ty = dataConOrigResTy dc - -isRefType :: Type -> Bool -isRefType ty - | Just (tc, _) <- tcSplitTyConApp_maybe ty' = isRefTyCon tc - | otherwise = False - where ty'= repType ty +getDataConArgTys :: DataCon -> Type -> TR [Type] +-- Given the result type ty of a constructor application (D a b c :: ty) +-- return the types of the arguments. This is RTTI-land, so 'ty' might +-- not be fully known. Moreover, the arg types might involve existentials; +-- if so, make up fresh RTTI type variables for them +getDataConArgTys dc con_app_ty + = do { (_, ex_tys, _) <- instTyVars ex_tvs + ; let rep_con_app_ty = repType con_app_ty + ; ty_args <- case tcSplitTyConApp_maybe rep_con_app_ty of + Just (tc, ty_args) | dataConTyCon dc == tc + -> ASSERT( univ_tvs `equalLength` ty_args) + return ty_args + _ -> do { (_, ty_args, subst) <- instTyVars univ_tvs + ; let res_ty = substTy subst (dataConOrigResTy dc) + ; addConstraint rep_con_app_ty res_ty + ; return ty_args } + -- It is necessary to check dataConTyCon dc == tc + -- because it may be the case that tc is a recursive + -- newtype and tcSplitTyConApp has not removed it. In + -- that case, we happily give up and don't match + ; let subst = zipTopTvSubst (univ_tvs ++ ex_tvs) (ty_args ++ ex_tys) + ; return (substTys subst (dataConRepArgTys dc)) } + where + univ_tvs = dataConUnivTyVars dc + ex_tvs = dataConExTyVars dc -isRefTyCon :: TyCon -> Bool -isRefTyCon tc = tc `elem` [mutVarPrimTyCon, mVarPrimTyCon, tVarPrimTyCon] +isPtrType :: Type -> Bool +isPtrType ty = case typePrimRep ty of + PtrRep -> True + _ -> False -- Soundness checks -------------------- @@ -1108,7 +1100,7 @@ | otherwise = do traceTR (text "(Upgrade) upgraded " <> ppr ty <> text " in presence of newtype evidence " <> ppr new_tycon) - vars <- mapM (newVar . tyVarKind) (tyConTyVars new_tycon) + (_, vars, _) <- instTyVars (tyConTyVars new_tycon) let ty' = mkTyConApp new_tycon vars _ <- liftTcM (unifyType ty (repType ty')) -- assumes that reptype doesn't ^^^^ touch tyconApp args @@ -1135,9 +1127,9 @@ zonk_unbound_meta tv = ASSERT( isTcTyVar tv ) do { tv' <- skolemiseUnboundMetaTyVar tv RuntimeUnk - -- This is where RuntimeUnkSkols are born: + -- This is where RuntimeUnks are born: -- otherwise-unconstrained unification variables are - -- turned into RuntimeUnkSkols as they leave the + -- turned into RuntimeUnks as they leave the -- typechecker's monad ; return (mkTyVarTy tv') } @@ -1188,12 +1180,6 @@ -- Generalize the type: find all free tyvars and wrap in the appropiate ForAll. quantifyType ty = (varSetElems (tyVarsOfType ty), ty) -mapMif :: Monad m => (a -> Bool) -> (a -> m a) -> [a] -> m [a] -mapMif pred f xx = sequence $ mapMif_ pred f xx - where - mapMif_ _ _ [] = [] - mapMif_ pred f (x:xx) = (if pred x then f x else return x) : mapMif_ pred f xx - unlessM :: Monad m => m Bool -> m () -> m () unlessM condM acc = condM >>= \c -> unless c acc @@ -1210,24 +1196,10 @@ where g (I# i#) = case indexArray# arr# i# of (# e #) -> f e - -isLifted :: Type -> Bool -isLifted = not . isUnLiftedType - extractUnboxed :: [Type] -> Closure -> [[Word]] extractUnboxed tt clos = go tt (nonPtrs clos) - where sizeofType t - | Just (tycon,_) <- tcSplitTyConApp_maybe t - = ASSERT (isPrimTyCon tycon) sizeofTyCon tycon - | otherwise = pprPanic "Expected a TcTyCon" (ppr t) + where sizeofType t = primRepSizeW (typePrimRep t) go [] _ = [] go (t:tt) xx | (x, rest) <- splitAt (sizeofType t) xx = x : go tt rest - -sizeofTyCon :: TyCon -> Int -- in *words* -sizeofTyCon = primRepSizeW . tyConPrimRep - - -(|.|) :: (a -> Bool) -> (a -> Bool) -> a -> Bool -(f |.| g) x = f x || g x diff -Nru ghc-7.0.3/compiler/ghc.mk ghc-7.2.1/compiler/ghc.mk --- ghc-7.0.3/compiler/ghc.mk 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/ghc.mk 2011-08-07 17:10:05.000000000 +0000 @@ -51,12 +51,12 @@ @echo >> $@ @echo '#include "ghc_boot_platform.h"' >> $@ @echo >> $@ - @echo 'cBuildPlatform :: String' >> $@ - @echo 'cBuildPlatform = BuildPlatform_NAME' >> $@ - @echo 'cHostPlatform :: String' >> $@ - @echo 'cHostPlatform = HostPlatform_NAME' >> $@ - @echo 'cTargetPlatform :: String' >> $@ - @echo 'cTargetPlatform = TargetPlatform_NAME' >> $@ + @echo 'cBuildPlatformString :: String' >> $@ + @echo 'cBuildPlatformString = BuildPlatform_NAME' >> $@ + @echo 'cHostPlatformString :: String' >> $@ + @echo 'cHostPlatformString = HostPlatform_NAME' >> $@ + @echo 'cTargetPlatformString :: String' >> $@ + @echo 'cTargetPlatformString = TargetPlatform_NAME' >> $@ @echo >> $@ @echo 'cProjectName :: String' >> $@ @echo 'cProjectName = "$(ProjectName)"' >> $@ @@ -70,22 +70,18 @@ @echo 'cBooterVersion = "$(GhcVersion)"' >> $@ @echo 'cStage :: String' >> $@ @echo 'cStage = show (STAGE :: Int)' >> $@ - @echo 'cCcOpts :: [String]' >> $@ - @echo 'cCcOpts = words "$(CONF_CC_OPTS_STAGE$*)"' >> $@ @echo 'cGccLinkerOpts :: [String]' >> $@ @echo 'cGccLinkerOpts = words "$(CONF_GCC_LINKER_OPTS_STAGE$*)"' >> $@ @echo 'cLdLinkerOpts :: [String]' >> $@ @echo 'cLdLinkerOpts = words "$(CONF_LD_LINKER_OPTS_STAGE$*)"' >> $@ @echo 'cIntegerLibrary :: String' >> $@ @echo 'cIntegerLibrary = "$(INTEGER_LIBRARY)"' >> $@ - @echo 'cSplitObjs :: String' >> $@ - @echo 'cSplitObjs = "$(SupportsSplitObjs)"' >> $@ + @echo 'cSupportsSplitObjs :: String' >> $@ + @echo 'cSupportsSplitObjs = "$(SupportsSplitObjs)"' >> $@ @echo 'cGhcWithInterpreter :: String' >> $@ @echo 'cGhcWithInterpreter = "$(GhcWithInterpreter)"' >> $@ @echo 'cGhcWithNativeCodeGen :: String' >> $@ @echo 'cGhcWithNativeCodeGen = "$(GhcWithNativeCodeGen)"' >> $@ - @echo 'cGhcWithLlvmCodeGen :: String' >> $@ - @echo 'cGhcWithLlvmCodeGen = "YES"' >> $@ @echo 'cGhcWithSMP :: String' >> $@ @echo 'cGhcWithSMP = "$(GhcWithSMP)"' >> $@ @echo 'cGhcRTSWays :: String' >> $@ @@ -98,28 +94,18 @@ @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' >> $@ @echo 'cLdIsGNULd = "$(LdIsGNULd)"' >> $@ + @echo 'cLdHasBuildId :: String' >> $@ + @echo 'cLdHasBuildId = "$(LdHasBuildId)"' >> $@ @echo 'cLD_X :: String' >> $@ @echo 'cLD_X = "$(LD_X)"' >> $@ @echo 'cGHC_DRIVER_DIR :: String' >> $@ @echo 'cGHC_DRIVER_DIR = "$(GHC_DRIVER_DIR)"' >> $@ - @echo 'cGHC_TOUCHY_PGM :: String' >> $@ - @echo 'cGHC_TOUCHY_PGM = "$(GHC_TOUCHY_PGM)"' >> $@ - @echo 'cGHC_TOUCHY_DIR :: String' >> $@ - @echo 'cGHC_TOUCHY_DIR = "$(GHC_TOUCHY_DIR)"' >> $@ @echo 'cGHC_UNLIT_PGM :: String' >> $@ @echo 'cGHC_UNLIT_PGM = "$(GHC_UNLIT_PGM)"' >> $@ @echo 'cGHC_UNLIT_DIR :: String' >> $@ @echo 'cGHC_UNLIT_DIR = "$(GHC_UNLIT_DIR)"' >> $@ - @echo 'cGHC_MANGLER_PGM :: String' >> $@ - @echo 'cGHC_MANGLER_PGM = "$(GHC_MANGLER_PGM)"' >> $@ - @echo 'cGHC_MANGLER_DIR :: String' >> $@ - @echo 'cGHC_MANGLER_DIR = "$(GHC_MANGLER_DIR)"' >> $@ @echo 'cGHC_SPLIT_PGM :: String' >> $@ @echo 'cGHC_SPLIT_PGM = "$(GHC_SPLIT_PGM)"' >> $@ @echo 'cGHC_SPLIT_DIR :: String' >> $@ @@ -128,8 +114,6 @@ @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' >> $@ @@ -262,7 +246,7 @@ compiler/primop-has-side-effects.hs-incl \ compiler/primop-out-of-line.hs-incl \ compiler/primop-commutable.hs-incl \ - compiler/primop-needs-wrapper.hs-incl \ + compiler/primop-code-size.hs-incl \ compiler/primop-can-fail.hs-incl \ compiler/primop-strictness.hs-incl \ compiler/primop-primop-info.hs-incl @@ -288,8 +272,8 @@ "$(GENPRIMOP_INPLACE)" --out-of-line < $< > $@ compiler/primop-commutable.hs-incl: $(PRIMOPS_TXT) $(GENPRIMOP_INPLACE) "$(GENPRIMOP_INPLACE)" --commutable < $< > $@ -compiler/primop-needs-wrapper.hs-incl: $(PRIMOPS_TXT) $(GENPRIMOP_INPLACE) - "$(GENPRIMOP_INPLACE)" --needs-wrapper < $< > $@ +compiler/primop-code-size.hs-incl: $(PRIMOPS_TXT) $(GENPRIMOP_INPLACE) + "$(GENPRIMOP_INPLACE)" --code-size < $< > $@ compiler/primop-can-fail.hs-incl: $(PRIMOPS_TXT) $(GENPRIMOP_INPLACE) "$(GENPRIMOP_INPLACE)" --can-fail < $< > $@ compiler/primop-strictness.hs-incl: $(PRIMOPS_TXT) $(GENPRIMOP_INPLACE) @@ -343,12 +327,6 @@ endif -ifeq "$(GhcWithNativeCodeGen)" "NO" -# XXX This should logically be a CPP option, but there doesn't seem to -# be a flag for that -compiler_CONFIGURE_OPTS += --ghc-option=-DOMIT_NATIVE_CODEGEN -endif - ifeq "$(TargetOS_CPP)" "openbsd" compiler_CONFIGURE_OPTS += --ld-options=-E endif @@ -373,28 +351,6 @@ compiler_stage2_CONFIGURE_OPTS += --ghc-pkg-option=--force endif -ifeq "$(HOSTPLATFORM)" "i386-unknown-mingw32" -# The #include is vital for the via-C route with older compilers, else the C -# compiler doesn't realise that the stcall foreign imports are indeed -# stdcall, and doesn't generate the Foo@8 name for them -# It's only important for older compilers, and in fact newer compilers -# will give a warning if the -#include flag is used. We therefore only -# do it for stage1, and only for < 6.11. -ifeq "$(ghc_ge_611)" "NO" -compiler_stage1_CONFIGURE_OPTS += --ghc-option='-\#include' \ - --ghc-option='""' \ - --ghc-option='-\#include' \ - --ghc-option='""' -endif -endif - -# ghc_strlen percolates through so many modules that it is easier to get its -# prototype via a global option instead of a myriad of per-file OPTIONS. -# Again, this is only done for older compilers. -ifeq "$(ghc_ge_611)" "NO" -compiler_stage1_CONFIGURE_OPTS += --ghc-options='-\#include "cutils.h"' -endif - compiler_stage3_CONFIGURE_OPTS := $(compiler_stage2_CONFIGURE_OPTS) compiler_stage1_CONFIGURE_OPTS += --ghc-option=-DSTAGE=1 @@ -481,6 +437,18 @@ compiler_stage2_HC_OPTS += $(GhcStage2HcOpts) compiler_stage3_HC_OPTS += $(GhcStage3HcOpts) +ifeq "$(GhcStage1DefaultNewCodegen)" "YES" +compiler_stage1_HC_OPTS += -DGHC_DEFAULT_NEW_CODEGEN +endif + +ifeq "$(GhcStage2DefaultNewCodegen)" "YES" +compiler_stage2_HC_OPTS += -DGHC_DEFAULT_NEW_CODEGEN +endif + +ifeq "$(GhcStage3DefaultNewCodegen)" "YES" +compiler_stage3_HC_OPTS += -DGHC_DEFAULT_NEW_CODEGEN +endif + ifneq "$(BINDIST)" "YES" compiler_stage2_TAGS_HC_OPTS = -package ghc @@ -523,7 +491,9 @@ < $< > $@ "$(compiler_stage1_GHC_PKG)" update --force $(compiler_stage1_GHC_PKG_OPTS) $@ -$(compiler_stage1_v_LIB) : compiler/stage1/inplace-pkg-config-munged +# We need to make sure the munged config is in the database before we +# try to configure ghc-bin +ghc/stage1/package-data.mk : compiler/stage1/inplace-pkg-config-munged endif endif diff -Nru ghc-7.0.3/compiler/hsSyn/Convert.lhs ghc-7.2.1/compiler/hsSyn/Convert.lhs --- ghc-7.0.3/compiler/hsSyn/Convert.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/hsSyn/Convert.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -143,7 +143,7 @@ cvtDec (TH.SigD nm typ) = do { nm' <- vNameL nm ; ty' <- cvtType typ - ; returnL $ Hs.SigD (TypeSig nm' ty') } + ; returnL $ Hs.SigD (TypeSig [nm'] ty') } cvtDec (PragmaD prag) = do { prag' <- cvtPragmaD prag @@ -268,6 +268,7 @@ collect (VarT tv) = return [PlainTV tv] collect (ConT _) = return [] collect (TupleT _) = return [] + collect (UnboxedTupleT _) = return [] collect ArrowT = return [] collect ListT = return [] collect (AppT t1 t2) @@ -373,8 +374,8 @@ where safety' = case safety of Unsafe -> PlayRisky - Safe -> PlaySafe False - Threadsafe -> PlaySafe True + Safe -> PlaySafe + Interruptible -> PlayInterruptible cvtForD (ExportF callconv as nm ty) = do { nm' <- vNameL nm @@ -463,6 +464,7 @@ ; return $ HsLam (mkMatchGroup [mkSimpleMatch ps' e']) } cvt (TupE [e]) = cvt e -- Singleton tuples treated like nothing (just parens) cvt (TupE es) = do { es' <- mapM cvtl es; return $ ExplicitTuple (map Present es') Boxed } + cvt (UnboxedTupE es) = do { es' <- mapM cvtl es; return $ ExplicitTuple (map Present es') Unboxed } cvt (CondE x y z) = do { x' <- cvtl x; y' <- cvtl y; z' <- cvtl z; ; return $ HsIf (Just noSyntaxExpr) x' y' z' } cvt (LetE ds e) = do { ds' <- cvtLocalDecs (ptext (sLit "a let expression")) ds @@ -518,12 +520,15 @@ | null stmts = failWith (ptext (sLit "Empty stmt list in do-block")) | otherwise = do { stmts' <- cvtStmts stmts - ; body <- case last stmts' of - L _ (ExprStmt body _ _) -> return body - stmt' -> failWith (bad_last stmt') - ; return $ HsDo do_or_lc (init stmts') body void } + ; let Just (stmts'', last') = snocView stmts' + + ; last'' <- case last' of + L loc (ExprStmt body _ _ _) -> return (L loc (mkLastStmt body)) + _ -> failWith (bad_last last') + + ; return $ HsDo do_or_lc (stmts'' ++ [last'']) void } where - bad_last stmt = vcat [ ptext (sLit "Illegal last statement of") <+> pprStmtContext do_or_lc <> colon + bad_last stmt = vcat [ ptext (sLit "Illegal last statement of") <+> pprAStmtContext do_or_lc <> colon , nest 2 $ Outputable.ppr stmt , ptext (sLit "(It should be an expression.)") ] @@ -535,7 +540,7 @@ cvtStmt (TH.BindS p e) = do { p' <- cvtPat p; e' <- cvtl e; returnL $ mkBindStmt p' e' } cvtStmt (TH.LetS ds) = do { ds' <- cvtLocalDecs (ptext (sLit "a let binding")) ds ; returnL $ LetStmt ds' } -cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' } +cvtStmt (TH.ParS dss) = do { dss' <- mapM cvt_one dss; returnL $ ParStmt dss' noSyntaxExpr noSyntaxExpr noSyntaxExpr } where cvt_one ds = do { ds' <- cvtStmts ds; return (ds', undefined) } @@ -561,7 +566,7 @@ cvtOverLit (IntegerL i) = do { force i; return $ mkHsIntegral i placeHolderType} cvtOverLit (RationalL r) - = do { force r; return $ mkHsFractional r placeHolderType} + = do { force r; return $ mkHsFractional (cvtFractionalLit r) placeHolderType} cvtOverLit (StringL s) = do { let { s' = mkFastString s } ; force s' @@ -595,8 +600,8 @@ cvtLit :: Lit -> CvtM HsLit cvtLit (IntPrimL i) = do { force i; return $ HsIntPrim i } cvtLit (WordPrimL w) = do { force w; return $ HsWordPrim w } -cvtLit (FloatPrimL f) = do { force f; return $ HsFloatPrim f } -cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim f } +cvtLit (FloatPrimL f) = do { force f; return $ HsFloatPrim (cvtFractionalLit f) } +cvtLit (DoublePrimL f) = do { force f; return $ HsDoublePrim (cvtFractionalLit f) } cvtLit (CharL c) = do { force c; return $ HsChar c } cvtLit (StringL s) = do { let { s' = mkFastString s } ; force s' @@ -625,6 +630,7 @@ cvtp (TH.VarP s) = do { s' <- vName s; return $ Hs.VarPat s' } cvtp (TupP [p]) = cvtp p cvtp (TupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Boxed void } +cvtp (UnboxedTupP ps) = do { ps' <- cvtPats ps; return $ TuplePat ps' Unboxed void } cvtp (ConP s ps) = do { s' <- cNameL s; ps' <- cvtPats ps; return $ ConPatIn s' (PrefixCon ps') } cvtp (InfixP p1 s p2) = do { s' <- cNameL s; p1' <- cvtPat p1; p2' <- cvtPat p2 ; return $ ConPatIn s' (InfixCon p1' p2') } @@ -696,6 +702,13 @@ -> failWith (ptext (sLit "Illegal 1-tuple type constructor")) | otherwise -> mk_apps (HsTyVar (getRdrName (tupleTyCon Boxed n))) tys' + UnboxedTupleT n + | length tys' == n -- Saturated + -> if n==1 then return (head tys') -- Singleton tuples treated + -- like nothing (ie just parens) + else returnL (HsTupleTy Unboxed tys') + | otherwise + -> mk_apps (HsTyVar (getRdrName (tupleTyCon Unboxed n))) tys' ArrowT | [x',y'] <- tys' -> returnL (HsFunTy x' y') | otherwise -> mk_apps (HsTyVar (getRdrName funTyCon)) tys' @@ -750,6 +763,9 @@ void :: Type.Type void = placeHolderType +cvtFractionalLit :: Rational -> FractionalLit +cvtFractionalLit r = FL { fl_text = show (fromRational r :: Double), fl_value = r } + -------------------------------------------------------------------- -- Turning Name back into RdrName -------------------------------------------------------------------- @@ -800,7 +816,8 @@ <+> ptext (sLit "name:") <+> quotes (text occ) thRdrName :: OccName.NameSpace -> String -> TH.NameFlavour -> RdrName --- This turns a Name into a RdrName +-- This turns a TH Name into a RdrName; used for both binders and occurrences +-- See Note [Binders in Template Haskell] -- The passed-in name space tells what the context is expecting; -- use it unless the TH name knows what name-space it comes -- from, in which case use the latter @@ -810,13 +827,17 @@ -- which will give confusing error messages later -- -- The strict applications ensure that any buried exceptions get forced -thRdrName _ occ (TH.NameG th_ns pkg mod) = thOrigRdrName occ th_ns pkg mod -thRdrName ctxt_ns occ (TH.NameL uniq) = nameRdrName $! (((Name.mkInternalName $! (mk_uniq uniq)) $! (mk_occ ctxt_ns occ)) noSrcSpan) -thRdrName ctxt_ns occ (TH.NameQ mod) = (mkRdrQual $! (mk_mod mod)) $! (mk_occ ctxt_ns occ) -thRdrName ctxt_ns occ (TH.NameU uniq) = mkRdrUnqual $! (mk_uniq_occ ctxt_ns occ uniq) -thRdrName ctxt_ns occ TH.NameS - | Just name <- isBuiltInOcc ctxt_ns occ = nameRdrName $! name - | otherwise = mkRdrUnqual $! (mk_occ ctxt_ns occ) +thRdrName ctxt_ns th_occ th_name + = case th_name of + TH.NameG th_ns pkg mod -> thOrigRdrName th_occ th_ns pkg mod + TH.NameQ mod -> (mkRdrQual $! mk_mod mod) $! occ + TH.NameL uniq -> nameRdrName $! (((Name.mkInternalName $! mk_uniq uniq) $! occ) noSrcSpan) + TH.NameU uniq -> nameRdrName $! (((Name.mkSystemName $! mk_uniq uniq) $! occ)) + TH.NameS | Just name <- isBuiltInOcc ctxt_ns th_occ -> nameRdrName $! name + | otherwise -> mkRdrUnqual $! occ + where + occ :: OccName.OccName + occ = mk_occ ctxt_ns th_occ thOrigRdrName :: String -> TH.NameSpace -> PkgName -> ModName -> RdrName thOrigRdrName occ th_ns pkg mod = (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! (mk_occ (mk_ghc_ns th_ns) occ) @@ -852,14 +873,9 @@ | OccName.isTcClsNameSpace ctxt_ns = Name.getName (tupleTyCon Boxed n) | otherwise = Name.getName (tupleCon Boxed n) -mk_uniq_occ :: OccName.NameSpace -> String -> Int# -> OccName.OccName -mk_uniq_occ ns occ uniq - = OccName.mkOccName ns (occ ++ '[' : shows (mk_uniq uniq) "]") - -- See Note [Unique OccNames from Template Haskell] - -- The packing and unpacking is rather turgid :-( mk_occ :: OccName.NameSpace -> String -> OccName.OccName -mk_occ ns occ = OccName.mkOccNameFS ns (mkFastString occ) +mk_occ ns occ = OccName.mkOccName ns occ mk_ghc_ns :: TH.NameSpace -> OccName.NameSpace mk_ghc_ns TH.DataName = OccName.dataName @@ -876,17 +892,64 @@ mk_uniq u = mkUniqueGrimily (I# u) \end{code} -Note [Unique OccNames from Template Haskell] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The idea here is to make a name that - a) the user could not possibly write (it has a "[" - and letters or digits from the unique) - b) cannot clash with another NameU -Previously I generated an Exact RdrName with mkInternalName. This -works fine for local binders, but does not work at all for top-level -binders, which must have External Names, since they are rapidly baked -into data constructors and the like. Baling out and generating an -unqualified RdrName here is the simple solution - -See also Note [Suppressing uniques in OccNames] in OccName, which -suppresses the unique when opt_SuppressUniques is on. +Note [Binders in Template Haskell] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this TH term construction: + do { x1 <- TH.newName "x" -- newName :: String -> Q TH.Name + ; x2 <- TH.newName "x" -- Builds a NameU + ; x3 <- TH.newName "x" + + ; let x = mkName "x" -- mkName :: String -> TH.Name + -- Builds a NameL + + ; return (LamE (..pattern [x1,x2]..) $ + LamE (VarPat x3) $ + ..tuple (x1,x2,x3,x)) } + +It represents the term \[x1,x2]. \x3. (x1,x2,x3,x) + +a) We don't want to complain about "x" being bound twice in + the pattern [x1,x2] +b) We don't want x3 to shadow the x1,x2 +c) We *do* want 'x' (dynamically bound with mkName) to bind + to the innermost binding of "x", namely x3. +d) When pretty printing, we want to print a unique with x1,x2 + etc, else they'll all print as "x" which isn't very helpful + +When we convert all this to HsSyn, the TH.Names are converted with +thRdrName. To achieve (b) we want the binders to be Exact RdrNames. +Achieving (a) is a bit awkward, because + - We must check for duplicate and shadowed names on Names, + not RdrNames, *after* renaming. + See Note [Collect binders only after renaming] in HsUtils + + - But to achieve (a) we must distinguish between the Exact + RdrNames arising from TH and the Unqual RdrNames that would + come from a user writing \[x,x] -> blah + +So in Convert.thRdrName we translate + TH Name RdrName + -------------------------------------------------------- + NameU (arising from newName) --> Exact (Name{ System }) + NameS (arising from mkName) --> Unqual + +Notice that the NameUs generate *System* Names. Then, when +figuring out shadowing and duplicates, we can filter out +System Names. + +This use of System Names fits with other uses of System Names, eg for +temporary variables "a". Since there are lots of things called "a" we +usually want to print the name with the unique, and that is indeed +the way System Names are printed. + +There's a small complication of course. For data types and +classes we'll now have system Names in the binding positions +for constructors, TyCons etc. For example + [d| data T = MkT Int |] +when we splice in and Convert to HsSyn RdrName, we'll get + data (Exact (system Name "T")) = (Exact (system Name "MkT")) ... +So RnEnv.newGlobalBinder we spot Exact RdrNames that wrap a +non-External Name, and make an External name for. (Remember, +constructors and the like need External Names.) Oddly, the +*occurrences* will continue to be that (non-External) System Name, +but the first sweep of the optimiser will fix that. diff -Nru ghc-7.0.3/compiler/hsSyn/HsBinds.lhs ghc-7.2.1/compiler/hsSyn/HsBinds.lhs --- ghc-7.0.3/compiler/hsSyn/HsBinds.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/hsSyn/HsBinds.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -69,23 +69,23 @@ type HsValBinds id = HsValBindsLR id id data HsValBindsLR idL idR -- Value bindings (not implicit parameters) - = ValBindsIn -- Before renaming + = ValBindsIn -- Before renaming RHS; idR is always RdrName (LHsBindsLR idL idR) [LSig idR] -- Not dependency analysed -- Recursive by default - | ValBindsOut -- After renaming + | ValBindsOut -- After renaming RHS; idR can be Name or Id [(RecFlag, LHsBinds idL)] -- Dependency analysed, later bindings -- in the list may depend on earlier -- ones. [LSig Name] deriving (Data, Typeable) -type LHsBinds id = Bag (LHsBind id) -type LHsBind id = Located (HsBind id) -type HsBind id = HsBindLR id id +type LHsBind id = LHsBindLR id id +type LHsBinds id = LHsBindsLR id id +type HsBind id = HsBindLR id id -type LHsBindLR idL idR = Located (HsBindLR idL idR) type LHsBindsLR idL idR = Bag (LHsBindLR idL idR) +type LHsBindLR idL idR = Located (HsBindLR idL idR) data HsBindLR idL idR = -- | FunBind is used for both functions @f x = e@ @@ -148,13 +148,14 @@ abs_ev_vars :: [EvVar], -- Includes equality constraints -- AbsBinds only gets used when idL = idR after renaming, - -- but these need to be idL's for the collect... code in HsUtil to have - -- the right type + -- but these need to be idL's for the collect... code in HsUtil + -- to have the right type abs_exports :: [([TyVar], idL, idL, TcSpecPrags)], -- (tvs, poly_id, mono_id, prags) abs_ev_binds :: TcEvBinds, -- Evidence bindings abs_binds :: LHsBinds idL -- Typechecked user bindings } + deriving (Data, Typeable) -- Consider (AbsBinds tvs ds [(ftvs, poly_f, mono_f) binds] -- @@ -251,7 +252,7 @@ getTypeSigNames (ValBindsIn {}) = panic "getTypeSigNames" getTypeSigNames (ValBindsOut _ sigs) - = mkNameSet [unLoc n | L _ (TypeSig n _) <- sigs] + = mkNameSet [unLoc n | L _ (TypeSig names _) <- sigs, n <- names] \end{code} What AbsBinds means @@ -295,11 +296,12 @@ = pprTicks empty (case tick of Nothing -> empty Just t -> text "-- tick id = " <> ppr t) + $$ ifPprDebug (pprBndr LetBind (unLoc fun)) $$ pprFunBind (unLoc fun) inf matches $$ ifPprDebug (ppr wrap) -ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars - , abs_exports = exports, abs_binds = val_binds +ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars + , abs_exports = exports, abs_binds = val_binds , abs_ev_binds = ev_binds }) = sep [ptext (sLit "AbsBinds"), brackets (interpp'SP tyvars), @@ -355,7 +357,7 @@ instance (OutputableBndr id) => Outputable (HsIPBinds id) where ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs) - $$ ifPprDebug (ppr ds) + $$ ifPprDebug (ppr ds) instance (OutputableBndr id) => Outputable (IPBind id) where ppr (IPBind id rhs) = pprBndr LetBind id <+> equals <+> pprExpr (unLoc rhs) @@ -376,7 +378,7 @@ = WpHole -- The identity coercion | WpCompose HsWrapper HsWrapper - -- (wrap1 `WpCompse` wrap2)[e] = wrap1[ wrap2[ e ]] + -- (wrap1 `WpCompose` wrap2)[e] = wrap1[ wrap2[ e ]] -- -- Hence (\a. []) `WpCompose` (\b. []) = (\a b. []) -- But ([] a) `WpCompose` ([] b) = ([] b a) @@ -455,7 +457,7 @@ deriving( Data, Typeable) evVarTerm :: EvVar -> EvTerm -evVarTerm v | isCoVar v = EvCoercion (mkCoVarCoercion v) +evVarTerm v | isCoVar v = EvCoercion (mkCoVarCo v) | otherwise = EvId v \end{code} @@ -544,7 +546,7 @@ help it WpHole = it help it (WpCompose f1 f2) = help (help it f2) f1 help it (WpCast co) = add_parens $ sep [it False, nest 2 (ptext (sLit "|>") - <+> pprParendType co)] + <+> pprParendCo co)] help it (WpEvApp id) = no_parens $ sep [it True, nest 2 (ppr id)] help it (WpTyApp ty) = no_parens $ sep [it True, ptext (sLit "@") <+> pprParendType ty] help it (WpEvLam id) = add_parens $ sep [ ptext (sLit "\\") <> pp_bndr id, it False] @@ -570,8 +572,8 @@ instance Outputable EvTerm where ppr (EvId v) = ppr v - ppr (EvCast v co) = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendType co - ppr (EvCoercion co) = ppr co + ppr (EvCast v co) = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendCo co + ppr (EvCoercion co) = ptext (sLit "CO") <+> ppr co ppr (EvSuperClass d n) = ptext (sLit "sc") <> parens (ppr (d,n)) ppr (EvDFunApp df tys ts) = ppr df <+> sep [ char '@' <> ppr tys, ppr ts ] \end{code} @@ -593,7 +595,11 @@ data Sig name -- Signatures and pragmas = -- An ordinary type signature -- f :: Num a => a -> a - TypeSig (Located name) (LHsType name) + TypeSig [Located name] (LHsType name) + + -- A type signature for a default method inside a class + -- default eq :: (Representable0 a, GEq (Rep0 a)) => a -> a -> Bool + | GenericSig [Located name] (LHsType name) -- A type signature in generated code, notably the code -- generated for record selectors. We simply record @@ -619,10 +625,10 @@ -- If it's just defaultInlinePragma, then we said -- SPECIALISE, not SPECIALISE_INLINE - -- A specialisation pragma for instance declarations only - -- {-# SPECIALISE instance Eq [Int] #-} - | SpecInstSig (LHsType name) -- (Class tys); should be a specialisation of the - -- current instance decl + -- A specialisation pragma for instance declarations only + -- {-# SPECIALISE instance Eq [Int] #-} + | SpecInstSig (LHsType name) -- (Class tys); should be a specialisation of the + -- current instance decl deriving (Data, Typeable) @@ -664,34 +670,20 @@ okBindSig _ = True okHsBootSig :: Sig a -> Bool -okHsBootSig (TypeSig _ _) = True -okHsBootSig (FixSig _) = True -okHsBootSig _ = False +okHsBootSig (TypeSig _ _) = True +okHsBootSig (GenericSig _ _) = False +okHsBootSig (FixSig _) = True +okHsBootSig _ = False okClsDclSig :: Sig a -> Bool okClsDclSig (SpecInstSig _) = False okClsDclSig _ = True -- All others OK okInstDclSig :: Sig a -> Bool -okInstDclSig (TypeSig _ _) = False -okInstDclSig (FixSig _) = False -okInstDclSig _ = True - -sigForThisGroup :: NameSet -> LSig Name -> Bool -sigForThisGroup ns sig - = case sigName sig of - Nothing -> False - Just n -> n `elemNameSet` ns - -sigName :: LSig name -> Maybe name -sigName (L _ sig) = sigNameNoLoc sig - -sigNameNoLoc :: Sig name -> Maybe name -sigNameNoLoc (TypeSig n _) = Just (unLoc n) -sigNameNoLoc (SpecSig n _ _) = Just (unLoc n) -sigNameNoLoc (InlineSig n _) = Just (unLoc n) -sigNameNoLoc (FixSig (FixitySig n _)) = Just (unLoc n) -sigNameNoLoc _ = Nothing +okInstDclSig (TypeSig _ _) = False +okInstDclSig (GenericSig _ _) = False +okInstDclSig (FixSig _) = False +okInstDclSig _ = True isFixityLSig :: LSig name -> Bool isFixityLSig (L _ (FixSig {})) = True @@ -704,9 +696,10 @@ isVanillaLSig _ = False isTypeLSig :: LSig name -> Bool -- Type signatures -isTypeLSig (L _(TypeSig {})) = True -isTypeLSig (L _(IdSig {})) = True -isTypeLSig _ = False +isTypeLSig (L _(TypeSig {})) = True +isTypeLSig (L _(GenericSig {})) = True +isTypeLSig (L _(IdSig {})) = True +isTypeLSig _ = False isSpecLSig :: LSig name -> Bool isSpecLSig (L _(SpecSig {})) = True @@ -729,6 +722,7 @@ hsSigDoc :: Sig name -> SDoc hsSigDoc (TypeSig {}) = ptext (sLit "type signature") +hsSigDoc (GenericSig {}) = ptext (sLit "default type signature") hsSigDoc (IdSig {}) = ptext (sLit "id signature") hsSigDoc (SpecSig {}) = ptext (sLit "SPECIALISE pragma") hsSigDoc (InlineSig {}) = ptext (sLit "INLINE pragma") @@ -742,7 +736,8 @@ eqHsSig :: Eq a => LSig a -> LSig a -> Bool eqHsSig (L _ (FixSig (FixitySig n1 _))) (L _ (FixSig (FixitySig n2 _))) = unLoc n1 == unLoc n2 eqHsSig (L _ (IdSig n1)) (L _ (IdSig n2)) = n1 == n2 -eqHsSig (L _ (TypeSig n1 _)) (L _ (TypeSig n2 _)) = unLoc n1 == unLoc n2 +eqHsSig (L _ (TypeSig ns1 _)) (L _ (TypeSig ns2 _)) = map unLoc ns1 == map unLoc ns2 +eqHsSig (L _ (GenericSig ns1 _)) (L _ (GenericSig ns2 _)) = map unLoc ns1 == map unLoc ns2 eqHsSig (L _ (InlineSig n1 _)) (L _ (InlineSig n2 _)) = unLoc n1 == unLoc n2 -- For specialisations, we don't have equality over -- HsType, so it's not convenient to spot duplicate @@ -755,8 +750,9 @@ ppr sig = ppr_sig sig ppr_sig :: OutputableBndr name => Sig name -> SDoc -ppr_sig (TypeSig var ty) = pprVarSig (unLoc var) (ppr ty) -ppr_sig (IdSig id) = pprVarSig id (ppr (varType id)) +ppr_sig (TypeSig vars ty) = pprVarSig (map unLoc vars) (ppr ty) +ppr_sig (GenericSig vars ty) = ptext (sLit "default") <+> pprVarSig (map unLoc vars) (ppr ty) +ppr_sig (IdSig id) = pprVarSig [id] (ppr (varType id)) ppr_sig (FixSig fix_sig) = ppr fix_sig ppr_sig (SpecSig var ty inl) = pragBrackets (pprSpec var (ppr ty) inl) ppr_sig (InlineSig var inl) = pragBrackets (ppr inl <+> ppr var) @@ -768,11 +764,13 @@ pragBrackets :: SDoc -> SDoc pragBrackets doc = ptext (sLit "{-#") <+> doc <+> ptext (sLit "#-}") -pprVarSig :: (Outputable id) => id -> SDoc -> SDoc -pprVarSig var pp_ty = sep [ppr var <+> dcolon, nest 2 pp_ty] +pprVarSig :: (Outputable id) => [id] -> SDoc -> SDoc +pprVarSig vars pp_ty = sep [pprvars <+> dcolon, nest 2 pp_ty] + where + pprvars = hsep $ punctuate comma (map ppr vars) pprSpec :: (Outputable id) => id -> SDoc -> InlinePragma -> SDoc -pprSpec var pp_ty inl = ptext (sLit "SPECIALIZE") <+> pp_inl <+> pprVarSig var pp_ty +pprSpec var pp_ty inl = ptext (sLit "SPECIALIZE") <+> pp_inl <+> pprVarSig [var] pp_ty where pp_inl | isDefaultInlinePragma inl = empty | otherwise = ppr inl diff -Nru ghc-7.0.3/compiler/hsSyn/HsDecls.lhs ghc-7.2.1/compiler/hsSyn/HsDecls.lhs --- ghc-7.0.3/compiler/hsSyn/HsDecls.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/hsSyn/HsDecls.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -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. @@ -34,6 +26,9 @@ -- ** @RULE@ declarations RuleDecl(..), LRuleDecl, RuleBndr(..), collectRuleBndrSigTys, + -- ** @VECTORISE@ declarations + VectDecl(..), LVectDecl, + lvectDeclName, -- ** @default@ declarations DefaultDecl(..), LDefaultDecl, -- ** Top-level template haskell splice @@ -57,7 +52,7 @@ ) where -- friends: -import {-# SOURCE #-} HsExpr( HsExpr, pprExpr ) +import {-# SOURCE #-} HsExpr( LHsExpr, HsExpr, pprExpr ) -- Because Expr imports Decls via HsBracket import HsBinds @@ -102,6 +97,7 @@ | WarningD (WarnDecl id) | AnnD (AnnDecl id) | RuleD (RuleDecl id) + | VectD (VectDecl id) | SpliceD (SpliceDecl id) | DocD (DocDecl) | QuasiQuoteD (HsQuasiQuote id) @@ -139,13 +135,14 @@ -- Snaffled out of both top-level fixity signatures, -- and those in class declarations - hs_defds :: [LDefaultDecl id], - hs_fords :: [LForeignDecl id], - hs_warnds :: [LWarnDecl id], - hs_annds :: [LAnnDecl id], - hs_ruleds :: [LRuleDecl id], + hs_defds :: [LDefaultDecl id], + hs_fords :: [LForeignDecl id], + hs_warnds :: [LWarnDecl id], + hs_annds :: [LAnnDecl id], + hs_ruleds :: [LRuleDecl id], + hs_vects :: [LVectDecl id], - hs_docs :: [LDocDecl] + hs_docs :: [LDocDecl] } deriving (Data, Typeable) emptyGroup, emptyRdrGroup, emptyRnGroup :: HsGroup a @@ -154,49 +151,52 @@ emptyGroup = HsGroup { hs_tyclds = [], hs_instds = [], hs_derivds = [], hs_fixds = [], hs_defds = [], hs_annds = [], - hs_fords = [], hs_warnds = [], hs_ruleds = [], + hs_fords = [], hs_warnds = [], hs_ruleds = [], hs_vects = [], hs_valds = error "emptyGroup hs_valds: Can't happen", hs_docs = [] } appendGroups :: HsGroup a -> HsGroup a -> HsGroup a appendGroups HsGroup { - hs_valds = val_groups1, - hs_tyclds = tyclds1, - hs_instds = instds1, + hs_valds = val_groups1, + hs_tyclds = tyclds1, + hs_instds = instds1, hs_derivds = derivds1, - hs_fixds = fixds1, - hs_defds = defds1, - hs_annds = annds1, - hs_fords = fords1, - hs_warnds = warnds1, - hs_ruleds = rulds1, + hs_fixds = fixds1, + hs_defds = defds1, + hs_annds = annds1, + hs_fords = fords1, + hs_warnds = warnds1, + hs_ruleds = rulds1, + hs_vects = vects1, hs_docs = docs1 } HsGroup { - hs_valds = val_groups2, - hs_tyclds = tyclds2, - hs_instds = instds2, + hs_valds = val_groups2, + hs_tyclds = tyclds2, + hs_instds = instds2, hs_derivds = derivds2, - hs_fixds = fixds2, - hs_defds = defds2, - hs_annds = annds2, - hs_fords = fords2, - hs_warnds = warnds2, - hs_ruleds = rulds2, - hs_docs = docs2 } + hs_fixds = fixds2, + hs_defds = defds2, + hs_annds = annds2, + hs_fords = fords2, + hs_warnds = warnds2, + hs_ruleds = rulds2, + hs_vects = vects2, + hs_docs = docs2 } = HsGroup { - hs_valds = val_groups1 `plusHsValBinds` val_groups2, - hs_tyclds = tyclds1 ++ tyclds2, - hs_instds = instds1 ++ instds2, + hs_valds = val_groups1 `plusHsValBinds` val_groups2, + hs_tyclds = tyclds1 ++ tyclds2, + hs_instds = instds1 ++ instds2, hs_derivds = derivds1 ++ derivds2, - hs_fixds = fixds1 ++ fixds2, - hs_annds = annds1 ++ annds2, - hs_defds = defds1 ++ defds2, - hs_fords = fords1 ++ fords2, - hs_warnds = warnds1 ++ warnds2, - hs_ruleds = rulds1 ++ rulds2, - hs_docs = docs1 ++ docs2 } + hs_fixds = fixds1 ++ fixds2, + hs_annds = annds1 ++ annds2, + hs_defds = defds1 ++ defds2, + hs_fords = fords1 ++ fords2, + hs_warnds = warnds1 ++ warnds2, + hs_ruleds = rulds1 ++ rulds2, + hs_vects = vects1 ++ vects2, + hs_docs = docs1 ++ docs2 } \end{code} \begin{code} @@ -209,6 +209,7 @@ ppr (ForD fd) = ppr fd ppr (SigD sd) = ppr sd ppr (RuleD rd) = ppr rd + ppr (VectD vect) = ppr vect ppr (WarningD wd) = ppr wd ppr (AnnD ad) = ppr ad ppr (SpliceD dd) = ppr dd @@ -225,11 +226,13 @@ hs_annds = ann_decls, hs_fords = foreign_decls, hs_defds = default_decls, - hs_ruleds = rule_decls }) + hs_ruleds = rule_decls, + hs_vects = vect_decls }) = vcat_mb empty [ppr_ds fix_decls, ppr_ds default_decls, ppr_ds deprec_decls, ppr_ds ann_decls, ppr_ds rule_decls, + ppr_ds vect_decls, if isEmptyValBinds val_decls then Nothing else Just (ppr val_decls), @@ -620,15 +623,15 @@ (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 @@ -713,10 +716,13 @@ , con_qvars :: [LHsTyVarBndr name] -- ^ Type variables. Depending on 'con_res' this describes the - -- follewing entities + -- following entities -- -- - ResTyH98: the constructor's *existential* type variables -- - ResTyGADT: *all* the constructor's quantified type variables + -- + -- If con_explicit is Implicit, then con_qvars is irrelevant + -- until after renaming. , con_cxt :: LHsContext name -- ^ The context. This /does not/ include the \"stupid theta\" which @@ -763,14 +769,14 @@ 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 @@ -792,7 +798,7 @@ %************************************************************************ %* * -\subsection[InstDecl]{An instance declaration +\subsection[InstDecl]{An instance declaration} %* * %************************************************************************ @@ -825,14 +831,14 @@ %************************************************************************ %* * -\subsection[DerivDecl]{A stand-alone instance deriving declaration +\subsection[DerivDecl]{A stand-alone instance deriving declaration} %* * %************************************************************************ \begin{code} type LDerivDecl name = Located (DerivDecl name) -data DerivDecl name = DerivDecl (LHsType name) +data DerivDecl name = DerivDecl { deriv_type :: LHsType name } deriving (Data, Typeable) instance (OutputableBndr name) => Outputable (DerivDecl name) where @@ -903,7 +909,7 @@ -- * `Safety' is irrelevant for `CLabel' and `CWrapper' -- CImport CCallConv -- ccall or stdcall - Safety -- safe or unsafe + Safety -- interruptible, safe or unsafe FastString -- name of C header CImportSpec -- details of the C entity deriving (Data, Typeable) @@ -996,6 +1002,57 @@ ppr (RuleBndrSig name ty) = ppr name <> dcolon <> ppr ty \end{code} + +%************************************************************************ +%* * +\subsection{Vectorisation declarations} +%* * +%************************************************************************ + +A vectorisation pragma, one of + + {-# VECTORISE f = closure1 g (scalar_map g) #-} + {-# VECTORISE SCALAR f #-} + {-# NOVECTORISE f #-} + +Note [Typechecked vectorisation pragmas] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In case of the first variant of vectorisation pragmas (with an explicit expression), +we need to infer the type of that expression during type checking and then keep that type +around until vectorisation, so that it can be checked against the *vectorised* type of 'f'. +(We cannot determine vectorised types during type checking due to internal information of +the vectoriser being needed.) + +To this end, we annotate the 'Id' of 'f' (the variable mentioned in the PRAGMA) with the +inferred type of the expression. This is slightly dodgy, as this is really the type of +'$v_f' (the name of the vectorised function). + +\begin{code} +type LVectDecl name = Located (VectDecl name) + +data VectDecl name + = HsVect + (Located name) + (Maybe (LHsExpr name)) -- 'Nothing' => SCALAR declaration + | HsNoVect + (Located name) + deriving (Data, Typeable) + +lvectDeclName :: LVectDecl name -> name +lvectDeclName (L _ (HsVect (L _ name) _)) = name +lvectDeclName (L _ (HsNoVect (L _ name))) = name + +instance OutputableBndr name => Outputable (VectDecl name) where + ppr (HsVect v Nothing) + = sep [text "{-# VECTORISE SCALAR" <+> ppr v <+> text "#-}" ] + ppr (HsVect v (Just rhs)) + = sep [text "{-# VECTORISE" <+> ppr v, + nest 4 $ + pprExpr (unLoc rhs) <+> text "#-}" ] + ppr (HsNoVect v) + = sep [text "{-# NOVECTORISE" <+> ppr v <+> text "#-}" ] +\end{code} + %************************************************************************ %* * \subsection[DocDecl]{Document comments} diff -Nru ghc-7.0.3/compiler/hsSyn/HsExpr.lhs ghc-7.2.1/compiler/hsSyn/HsExpr.lhs --- ghc-7.0.3/compiler/hsSyn/HsExpr.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/hsSyn/HsExpr.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -23,6 +23,8 @@ import BasicTypes import DataCon import SrcLoc +import Util( dropTail ) +import StaticFlags( opt_PprStyle_Debug ) import Outputable import FastString @@ -146,8 +148,6 @@ -- because in this context we never use -- the PatGuard or ParStmt variant [LStmt id] -- "do":one or more stmts - (LHsExpr id) -- The body; the last expression in the - -- 'do' of [ body | ... ] in a list comp PostTcType -- Type of the whole expression | ExplicitList -- syntactic list @@ -376,7 +376,7 @@ = hang (ppr op) 2 (sep [pp_e1, pp_e2]) pp_infixly v - = sep [nest 2 pp_e1, pprHsInfix v, nest 2 pp_e2] + = sep [pp_e1, sep [pprHsInfix v, nest 2 pp_e2]] ppr_expr (NegApp e _) = char '-' <+> pprDebugParendExpr e @@ -439,7 +439,7 @@ = sep [hang (ptext (sLit "let")) 2 (pprBinds binds), hang (ptext (sLit "in")) 2 (ppr expr)] -ppr_expr (HsDo do_or_list_comp stmts body _) = pprDo do_or_list_comp stmts body +ppr_expr (HsDo do_or_list_comp stmts _) = pprDo do_or_list_comp stmts ppr_expr (ExplicitList _ exprs) = brackets (pprDeeperList fsep (punctuate comma (map ppr_lexpr exprs))) @@ -575,7 +575,7 @@ HsPar {} -> pp_as_was HsBracket {} -> pp_as_was HsBracketOut _ [] -> pp_as_was - HsDo sc _ _ _ + HsDo sc _ _ | isListCompExpr sc -> pp_as_was _ -> parens pp_as_was @@ -672,7 +672,6 @@ \end{code} - %************************************************************************ %* * \subsection{@Match@, @GRHSs@, and @GRHS@ datatypes} @@ -830,51 +829,59 @@ type Stmt id = StmtLR id id --- The SyntaxExprs in here are used *only* for do-notation, which --- has rebindable syntax. Otherwise they are unused. +-- The SyntaxExprs in here are used *only* for do-notation and monad +-- comprehensions, which have rebindable syntax. Otherwise they are unused. data StmtLR idL idR - = BindStmt (LPat idL) + = LastStmt -- Always the last Stmt in ListComp, MonadComp, PArrComp, + -- and (after the renamer) DoExpr, MDoExpr + -- Not used for GhciStmt, PatGuard, which scope over other stuff + (LHsExpr idR) + (SyntaxExpr idR) -- The return operator, used only for MonadComp + -- For ListComp, PArrComp, we use the baked-in 'return' + -- For DoExpr, MDoExpr, we don't appply a 'return' at all + -- See Note [Monad Comprehensions] + | BindStmt (LPat idL) (LHsExpr idR) - (SyntaxExpr idR) -- The (>>=) operator + (SyntaxExpr idR) -- The (>>=) operator; see Note [The type of bind] (SyntaxExpr idR) -- The fail operator -- The fail operator is noSyntaxExpr -- if the pattern match can't fail | ExprStmt (LHsExpr idR) -- See Note [ExprStmt] (SyntaxExpr idR) -- The (>>) operator + (SyntaxExpr idR) -- The `guard` operator; used only in MonadComp + -- See notes [Monad Comprehensions] PostTcType -- Element type of the RHS (used for arrows) | LetStmt (HsLocalBindsLR idL idR) - -- ParStmts only occur in a list comprehension + -- ParStmts only occur in a list/monad comprehension | ParStmt [([LStmt idL], [idR])] - -- After renaming, the ids are the binders bound by the stmts and used - -- after them - - -- "qs, then f by e" ==> TransformStmt qs binders f (Just e) - -- "qs, then f" ==> TransformStmt qs binders f Nothing - | TransformStmt - [LStmt idL] -- Stmts are the ones to the left of the 'then' - - [idR] -- After renaming, the IDs are the binders occurring - -- within this transform statement that are used after it - - (LHsExpr idR) -- "then f" + (SyntaxExpr idR) -- Polymorphic `mzip` for monad comprehensions + (SyntaxExpr idR) -- The `>>=` operator + (SyntaxExpr idR) -- Polymorphic `return` operator + -- with type (forall a. a -> m a) + -- See notes [Monad Comprehensions] + -- After renaming, the ids are the binders + -- bound by the stmts and used after themp + + | TransStmt { + trS_form :: TransForm, + trS_stmts :: [LStmt idL], -- Stmts to the *left* of the 'group' + -- which generates the tuples to be grouped - (Maybe (LHsExpr idR)) -- "by e" (optional) - - | GroupStmt - [LStmt idL] -- Stmts to the *left* of the 'group' - -- which generates the tuples to be grouped - - [(idR, idR)] -- See Note [GroupStmt binder map] + trS_bndrs :: [(idR, idR)], -- See Note [TransStmt binder map] - (Maybe (LHsExpr idR)) -- "by e" (optional) - - (Either -- "using f" - (LHsExpr idR) -- Left f => explicit "using f" - (SyntaxExpr idR)) -- Right f => implicit; filled in with 'groupWith' - + trS_using :: LHsExpr idR, + trS_by :: Maybe (LHsExpr idR), -- "by e" (optional) + -- Invariant: if trS_form = GroupBy, then grp_by = Just e + + trS_ret :: SyntaxExpr idR, -- The monomorphic 'return' function for + -- the inner monad comprehensions + trS_bind :: SyntaxExpr idR, -- The '(>>=)' operator + trS_fmap :: SyntaxExpr idR -- The polymorphic 'fmap' function for desugaring + -- Only for 'group' forms + } -- See Note [Monad Comprehensions] -- Recursive statement (see Note [How RecStmt works] below) | RecStmt @@ -906,22 +913,43 @@ -- the returned thing has to be *monomorphic*, -- so they may be type applications - , recS_dicts :: TcEvBinds -- Method bindings of Ids bound by the - -- RecStmt, and used afterwards + , recS_ret_ty :: PostTcType -- The type of of do { stmts; return (a,b,c) } + -- With rebindable syntax the type might not + -- be quite as simple as (m (tya, tyb, tyc)). } deriving (Data, Typeable) + +data TransForm -- The 'f' below is the 'using' function, 'e' is the by function + = ThenForm -- then f or then f by e (depending on trS_by) + | GroupFormU -- group using f or group using f by e (depending on trS_by) + | GroupFormB -- group by e + -- In the GroupByFormB, trS_using is filled in with + -- 'groupWith' (list comprehensions) or + -- 'groupM' (monad comprehensions) + deriving (Data, Typeable) \end{code} -Note [GroupStmt binder map] +Note [The type of bind in Stmts] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Some Stmts, notably BindStmt, keep the (>>=) bind operator. +We do NOT assume that it has type + (>>=) :: m a -> (a -> m b) -> m b +In some cases (see Trac #303, #1537) it might have a more +exotic type, such as + (>>=) :: m i j a -> (a -> m j k b) -> m i k b +So we must be careful not to make assumptions about the type. +In particular, the monad may not be uniform throughout. + +Note [TransStmt binder map] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ -The [(idR,idR)] in a GroupStmt behaves as follows: +The [(idR,idR)] in a TransStmt behaves as follows: * Before renaming: [] * After renaming: [ (x27,x27), ..., (z35,z35) ] These are the variables - bound by the stmts to the left of the 'group' + bound by the stmts to the left of the 'group' and used either in the 'by' clause, or in the stmts following the 'group' Each item is a pair of identical variables. @@ -955,7 +983,13 @@ E :: Bool Translation: if E then fail else ... -Array comprehensions are handled like list comprehensions -=chak + A monad comprehension of type (m res_ty) + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + * ExprStmt E Bool: [ .. | .... E ] + E :: Bool + Translation: guard E >> ... + +Array comprehensions are handled like list comprehensions. Note [How RecStmt works] ~~~~~~~~~~~~~~~~~~~~~~~~ @@ -996,23 +1030,60 @@ where v1..vn are the later_ids r1..rm are the rec_ids +Note [Monad Comprehensions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Monad comprehensions require separate functions like 'return' and +'>>=' for desugaring. These functions are stored in the statements +used in monad comprehensions. For example, the 'return' of the 'LastStmt' +expression is used to lift the body of the monad comprehension: + + [ body | stmts ] + => + stmts >>= \bndrs -> return body + +In transform and grouping statements ('then ..' and 'then group ..') the +'return' function is required for nested monad comprehensions, for example: + + [ body | stmts, then f, rest ] + => + f [ env | stmts ] >>= \bndrs -> [ body | rest ] + +ExprStmts require the 'Control.Monad.guard' function for boolean +expressions: + + [ body | exp, stmts ] + => + guard exp >> [ body | stmts ] + +Grouping/parallel statements require the 'Control.Monad.Group.groupM' and +'Control.Monad.Zip.mzip' functions: + + [ body | stmts, then group by e, rest] + => + groupM [ body | stmts ] >>= \bndrs -> [ body | rest ] + + [ body | stmts1 | stmts2 | .. ] + => + mzip stmts1 (mzip stmts2 (..)) >>= \(bndrs1, (bndrs2, ..)) -> return body + +In any other context than 'MonadComp', the fields for most of these +'SyntaxExpr's stay bottom. + \begin{code} instance (OutputableBndr idL, OutputableBndr idR) => Outputable (StmtLR idL idR) where ppr stmt = pprStmt stmt pprStmt :: (OutputableBndr idL, OutputableBndr idR) => (StmtLR idL idR) -> SDoc +pprStmt (LastStmt expr _) = ifPprDebug (ptext (sLit "[last]")) <+> ppr expr pprStmt (BindStmt pat expr _ _) = hsep [ppr pat, ptext (sLit "<-"), ppr expr] pprStmt (LetStmt binds) = hsep [ptext (sLit "let"), pprBinds binds] -pprStmt (ExprStmt expr _ _) = ppr expr -pprStmt (ParStmt stmtss) = hsep (map doStmts stmtss) +pprStmt (ExprStmt expr _ _ _) = ppr expr +pprStmt (ParStmt stmtss _ _ _) = hsep (map doStmts stmtss) where doStmts stmts = ptext (sLit "| ") <> ppr stmts -pprStmt (TransformStmt stmts bndrs using by) - = sep (ppr_lc_stmts stmts ++ [pprTransformStmt bndrs using by]) - -pprStmt (GroupStmt stmts _ by using) - = sep (ppr_lc_stmts stmts ++ [pprGroupStmt by using]) +pprStmt (TransStmt { trS_stmts = stmts, trS_by = by, trS_using = using, trS_form = form }) + = sep (ppr_lc_stmts stmts ++ [pprTransStmt by using form]) pprStmt (RecStmt { recS_stmts = segment, recS_rec_ids = rec_ids , recS_later_ids = later_ids }) @@ -1027,40 +1098,47 @@ , nest 2 (ppr using) , nest 2 (pprBy by)] -pprGroupStmt :: OutputableBndr id => Maybe (LHsExpr id) - -> Either (LHsExpr id) (SyntaxExpr is) +pprTransStmt :: OutputableBndr id => Maybe (LHsExpr id) + -> LHsExpr id -> TransForm -> SDoc -pprGroupStmt by using - = sep [ ptext (sLit "then group"), nest 2 (pprBy by), nest 2 (ppr_using using)] - where - ppr_using (Right _) = empty - ppr_using (Left e) = ptext (sLit "using") <+> ppr e +pprTransStmt by using ThenForm + = sep [ ptext (sLit "then"), nest 2 (ppr using), nest 2 (pprBy by)] +pprTransStmt by _ GroupFormB + = sep [ ptext (sLit "then group"), nest 2 (pprBy by) ] +pprTransStmt by using GroupFormU + = sep [ ptext (sLit "then group"), nest 2 (pprBy by), nest 2 (ptext (sLit "using") <+> ppr using)] pprBy :: OutputableBndr id => Maybe (LHsExpr id) -> SDoc pprBy Nothing = empty pprBy (Just e) = ptext (sLit "by") <+> ppr e -pprDo :: OutputableBndr id => HsStmtContext any -> [LStmt id] -> LHsExpr id -> SDoc -pprDo DoExpr stmts body = ptext (sLit "do") <+> ppr_do_stmts stmts body -pprDo GhciStmt stmts body = ptext (sLit "do") <+> ppr_do_stmts stmts body -pprDo (MDoExpr _) stmts body = ptext (sLit "mdo") <+> ppr_do_stmts stmts body -pprDo ListComp stmts body = brackets $ pprComp stmts body -pprDo PArrComp stmts body = pa_brackets $ pprComp stmts body -pprDo _ _ _ = panic "pprDo" -- PatGuard, ParStmtCxt +pprDo :: OutputableBndr id => HsStmtContext any -> [LStmt id] -> SDoc +pprDo DoExpr stmts = ptext (sLit "do") <+> ppr_do_stmts stmts +pprDo GhciStmt stmts = ptext (sLit "do") <+> ppr_do_stmts stmts +pprDo ArrowExpr stmts = ptext (sLit "do") <+> ppr_do_stmts stmts +pprDo MDoExpr stmts = ptext (sLit "mdo") <+> ppr_do_stmts stmts +pprDo ListComp stmts = brackets $ pprComp stmts +pprDo PArrComp stmts = pa_brackets $ pprComp stmts +pprDo MonadComp stmts = brackets $ pprComp stmts +pprDo _ _ = panic "pprDo" -- PatGuard, ParStmtCxt -ppr_do_stmts :: OutputableBndr id => [LStmt id] -> LHsExpr id -> SDoc +ppr_do_stmts :: OutputableBndr id => [LStmt id] -> SDoc -- Print a bunch of do stmts, with explicit braces and semicolons, -- so that we are not vulnerable to layout bugs -ppr_do_stmts stmts body - = lbrace <+> pprDeeperList vcat ([ppr s <> semi | s <- stmts] ++ [ppr body]) +ppr_do_stmts stmts + = lbrace <+> pprDeeperList vcat (punctuate semi (map ppr stmts)) <+> rbrace ppr_lc_stmts :: OutputableBndr id => [LStmt id] -> [SDoc] ppr_lc_stmts stmts = [ppr s <> comma | s <- stmts] -pprComp :: OutputableBndr id => [LStmt id] -> LHsExpr id -> SDoc -pprComp quals body -- Prints: body | qual1, ..., qualn - = hang (ppr body <+> char '|') 2 (interpp'SP quals) +pprComp :: OutputableBndr id => [LStmt id] -> SDoc +pprComp quals -- Prints: body | qual1, ..., qualn + | not (null quals) + , L _ (LastStmt body _) <- last quals + = hang (ppr body <+> char '|') 2 (interpp'SP (dropTail 1 quals)) + | otherwise + = pprPanic "pprComp" (interpp'SP quals) \end{code} %************************************************************************ @@ -1164,38 +1242,49 @@ | LambdaExpr -- Patterns of a lambda | CaseAlt -- Patterns and guards on a case alternative | ProcExpr -- Patterns of a proc - | PatBindRhs -- Patterns in the *guards* of a pattern binding + | PatBindRhs -- A pattern binding eg [y] <- e = e + | RecUpd -- Record update [used only in DsExpr to -- tell matchWrapper what sort of -- runtime error message to generate] - | StmtCtxt (HsStmtContext id) -- Pattern of a do-stmt or list comprehension + + | StmtCtxt (HsStmtContext id) -- Pattern of a do-stmt, list comprehension, + -- pattern guard, etc + | ThPatQuote -- A Template Haskell pattern quotation [p| (a,b) |] deriving (Data, Typeable) data HsStmtContext id = ListComp - | DoExpr - | GhciStmt -- A command-line Stmt in GHCi pat <- rhs - | MDoExpr PostTcTable -- Recursive do-expression - -- (tiresomely, it needs table - -- of its return/bind ops) + | MonadComp | PArrComp -- Parallel array comprehension + + | DoExpr -- do { ... } + | MDoExpr -- mdo { ... } ie recursive do-expression + | ArrowExpr -- do-notation in an arrow-command context + + | GhciStmt -- A command-line Stmt in GHCi pat <- rhs | PatGuard (HsMatchContext id) -- Pattern guard for specified thing | ParStmtCtxt (HsStmtContext id) -- A branch of a parallel stmt - | TransformStmtCtxt (HsStmtContext id) -- A branch of a transform stmt + | TransStmtCtxt (HsStmtContext id) -- A branch of a transform stmt deriving (Data, Typeable) \end{code} \begin{code} -isDoExpr :: HsStmtContext id -> Bool -isDoExpr DoExpr = True -isDoExpr (MDoExpr _) = True -isDoExpr _ = False - isListCompExpr :: HsStmtContext id -> Bool -isListCompExpr ListComp = True -isListCompExpr PArrComp = True -isListCompExpr _ = False +-- Uses syntax [ e | quals ] +isListCompExpr ListComp = True +isListCompExpr PArrComp = True +isListCompExpr MonadComp = True +isListCompExpr (ParStmtCtxt c) = isListCompExpr c +isListCompExpr (TransStmtCtxt c) = isListCompExpr c +isListCompExpr _ = False + +isMonadCompExpr :: HsStmtContext id -> Bool +isMonadCompExpr MonadComp = True +isMonadCompExpr (ParStmtCtxt ctxt) = isMonadCompExpr ctxt +isMonadCompExpr (TransStmtCtxt ctxt) = isMonadCompExpr ctxt +isMonadCompExpr _ = False \end{code} \begin{code} @@ -1232,33 +1321,41 @@ pprMatchContextNoun (StmtCtxt ctxt) = ptext (sLit "pattern binding in") $$ pprStmtContext ctxt -pprStmtContext :: Outputable id => HsStmtContext id -> SDoc +----------------- +pprAStmtContext, pprStmtContext :: Outputable id => HsStmtContext id -> SDoc +pprAStmtContext ctxt = article <+> pprStmtContext ctxt + where + pp_an = ptext (sLit "an") + pp_a = ptext (sLit "a") + article = case ctxt of + MDoExpr -> pp_an + PArrComp -> pp_an + GhciStmt -> pp_an + _ -> pp_a + + +----------------- +pprStmtContext GhciStmt = ptext (sLit "interactive GHCi command") +pprStmtContext DoExpr = ptext (sLit "'do' block") +pprStmtContext MDoExpr = ptext (sLit "'mdo' block") +pprStmtContext ArrowExpr = ptext (sLit "'do' block in an arrow command") +pprStmtContext ListComp = ptext (sLit "list comprehension") +pprStmtContext MonadComp = ptext (sLit "monad comprehension") +pprStmtContext PArrComp = ptext (sLit "array comprehension") +pprStmtContext (PatGuard ctxt) = ptext (sLit "pattern guard for") $$ pprMatchContext ctxt + +-- Drop the inner contexts when reporting errors, else we get +-- Unexpected transform statement +-- in a transformed branch of +-- transformed branch of +-- transformed branch of monad comprehension pprStmtContext (ParStmtCtxt c) - = sep [ptext (sLit "a parallel branch of"), pprStmtContext c] -pprStmtContext (TransformStmtCtxt c) - = sep [ptext (sLit "a transformed branch of"), pprStmtContext c] -pprStmtContext (PatGuard ctxt) - = ptext (sLit "a pattern guard for") $$ pprMatchContext ctxt -pprStmtContext GhciStmt = ptext (sLit "an interactive GHCi command") -pprStmtContext DoExpr = ptext (sLit "a 'do' expression") -pprStmtContext (MDoExpr _) = ptext (sLit "an 'mdo' expression") -pprStmtContext ListComp = ptext (sLit "a list comprehension") -pprStmtContext PArrComp = ptext (sLit "an array comprehension") - -{- -pprMatchRhsContext (FunRhs fun) = ptext (sLit "a right-hand side of function") <+> quotes (ppr fun) -pprMatchRhsContext CaseAlt = ptext (sLit "the body of a case alternative") -pprMatchRhsContext PatBindRhs = ptext (sLit "the right-hand side of a pattern binding") -pprMatchRhsContext LambdaExpr = ptext (sLit "the body of a lambda") -pprMatchRhsContext ProcExpr = ptext (sLit "the body of a proc") -pprMatchRhsContext other = panic "pprMatchRhsContext" -- RecUpd, StmtCtxt - --- Used for the result statement of comprehension --- e.g. the 'e' in [ e | ... ] --- or the 'r' in f x = r -pprStmtResultContext (PatGuard ctxt) = pprMatchRhsContext ctxt -pprStmtResultContext other = ptext (sLit "the result of") <+> pprStmtContext other --} + | opt_PprStyle_Debug = sep [ptext (sLit "parallel branch of"), pprAStmtContext c] + | otherwise = pprStmtContext c +pprStmtContext (TransStmtCtxt c) + | opt_PprStyle_Debug = sep [ptext (sLit "transformed branch of"), pprAStmtContext c] + | otherwise = pprStmtContext c + -- Used to generate the string for a *runtime* error message matchContextErrString :: Outputable id => HsMatchContext id -> SDoc @@ -1269,14 +1366,16 @@ matchContextErrString LambdaExpr = ptext (sLit "lambda") matchContextErrString ProcExpr = ptext (sLit "proc") matchContextErrString ThPatQuote = panic "matchContextErrString" -- Not used at runtime -matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c) -matchContextErrString (StmtCtxt (TransformStmtCtxt c)) = matchContextErrString (StmtCtxt c) -matchContextErrString (StmtCtxt (PatGuard _)) = ptext (sLit "pattern guard") -matchContextErrString (StmtCtxt GhciStmt) = ptext (sLit "interactive GHCi command") -matchContextErrString (StmtCtxt DoExpr) = ptext (sLit "'do' expression") -matchContextErrString (StmtCtxt (MDoExpr _)) = ptext (sLit "'mdo' expression") -matchContextErrString (StmtCtxt ListComp) = ptext (sLit "list comprehension") -matchContextErrString (StmtCtxt PArrComp) = ptext (sLit "array comprehension") +matchContextErrString (StmtCtxt (ParStmtCtxt c)) = matchContextErrString (StmtCtxt c) +matchContextErrString (StmtCtxt (TransStmtCtxt c)) = matchContextErrString (StmtCtxt c) +matchContextErrString (StmtCtxt (PatGuard _)) = ptext (sLit "pattern guard") +matchContextErrString (StmtCtxt GhciStmt) = ptext (sLit "interactive GHCi command") +matchContextErrString (StmtCtxt DoExpr) = ptext (sLit "'do' block") +matchContextErrString (StmtCtxt ArrowExpr) = ptext (sLit "'do' block") +matchContextErrString (StmtCtxt MDoExpr) = ptext (sLit "'mdo' block") +matchContextErrString (StmtCtxt ListComp) = ptext (sLit "list comprehension") +matchContextErrString (StmtCtxt MonadComp) = ptext (sLit "monad comprehension") +matchContextErrString (StmtCtxt PArrComp) = ptext (sLit "array comprehension") \end{code} \begin{code} @@ -1287,11 +1386,16 @@ pprStmtInCtxt :: (OutputableBndr idL, OutputableBndr idR) => HsStmtContext idL -> StmtLR idL idR -> SDoc -pprStmtInCtxt ctxt stmt = hang (ptext (sLit "In a stmt of") <+> pprStmtContext ctxt <> colon) - 4 (ppr_stmt stmt) +pprStmtInCtxt ctxt (LastStmt e _) + | isListCompExpr ctxt -- For [ e | .. ], do not mutter about "stmts" + = hang (ptext (sLit "In the expression:")) 2 (ppr e) + +pprStmtInCtxt ctxt stmt + = hang (ptext (sLit "In a stmt of") <+> pprAStmtContext ctxt <> colon) + 2 (ppr_stmt stmt) where -- For Group and Transform Stmts, don't print the nested stmts! - ppr_stmt (GroupStmt _ _ by using) = pprGroupStmt by using - ppr_stmt (TransformStmt _ bndrs using by) = pprTransformStmt bndrs using by - ppr_stmt stmt = pprStmt stmt + ppr_stmt (TransStmt { trS_by = by, trS_using = using + , trS_form = form }) = pprTransStmt by using form + ppr_stmt stmt = pprStmt stmt \end{code} diff -Nru ghc-7.0.3/compiler/hsSyn/HsImpExp.lhs ghc-7.2.1/compiler/hsSyn/HsImpExp.lhs --- ghc-7.0.3/compiler/hsSyn/HsImpExp.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/hsSyn/HsImpExp.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -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 @@ -21,7 +15,7 @@ import Outputable import FastString -import SrcLoc ( Located(..) ) +import SrcLoc import Data.Data \end{code} @@ -42,17 +36,29 @@ ideclName :: Located ModuleName, -- ^ Module name. ideclPkgQual :: Maybe FastString, -- ^ Package qualifier. ideclSource :: Bool, -- ^ True <=> {-# SOURCE #-} import + ideclSafe :: Bool, -- ^ True => safe import ideclQualified :: Bool, -- ^ True => qualified ideclAs :: Maybe ModuleName, -- ^ as Module ideclHiding :: Maybe (Bool, [LIE name]) -- ^ (True => hiding, names) } deriving (Data, Typeable) + +simpleImportDecl :: ModuleName -> ImportDecl name +simpleImportDecl mn = ImportDecl { + ideclName = noLoc mn, + ideclPkgQual = Nothing, + ideclSource = False, + ideclSafe = True, + ideclQualified = False, + ideclAs = Nothing, + ideclHiding = Nothing + } \end{code} \begin{code} instance (Outputable name) => Outputable (ImportDecl name) where - ppr (ImportDecl mod pkg from qual as spec) - = hang (hsep [ptext (sLit "import"), ppr_imp from, - pp_qual qual, pp_pkg pkg, ppr mod, pp_as as]) + ppr (ImportDecl mod' pkg from safe qual as spec) + = hang (hsep [ptext (sLit "import"), ppr_imp from, pp_safe safe, + pp_qual qual, pp_pkg pkg, ppr mod', pp_as as]) 4 (pp_spec spec) where pp_pkg Nothing = empty @@ -61,6 +67,9 @@ pp_qual False = empty pp_qual True = ptext (sLit "qualified") + pp_safe False = empty + pp_safe True = ptext (sLit "safe") + pp_as Nothing = empty pp_as (Just a) = ptext (sLit "as") <+> ppr a @@ -103,6 +112,7 @@ 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 +132,8 @@ 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 -Nru ghc-7.0.3/compiler/hsSyn/HsLit.lhs ghc-7.2.1/compiler/hsSyn/HsLit.lhs --- ghc-7.0.3/compiler/hsSyn/HsLit.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/hsSyn/HsLit.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -12,7 +12,8 @@ #include "HsVersions.h" import {-# SOURCE #-} HsExpr( SyntaxExpr, pprExpr ) -import HsTypes (PostTcType) +import BasicTypes ( FractionalLit(..) ) +import HsTypes ( PostTcType ) import Type ( Type ) import Outputable import FastString @@ -36,14 +37,16 @@ | HsStringPrim FastString -- Packed string | HsInt Integer -- Genuinely an Int; arises from TcGenDeriv, -- and from TRANSLATION - | HsIntPrim Integer -- Unboxed Int - | HsWordPrim Integer -- Unboxed Word + | HsIntPrim Integer -- literal Int# + | HsWordPrim Integer -- literal Word# + | HsInt64Prim Integer -- literal Int64# + | HsWord64Prim Integer -- literal Word64# | HsInteger Integer Type -- Genuinely an integer; arises only from TRANSLATION -- (overloaded literals are done with HsOverLit) - | HsRat Rational Type -- Genuinely a rational; arises only from TRANSLATION + | HsRat FractionalLit Type -- Genuinely a rational; arises only from TRANSLATION -- (overloaded literals are done with HsOverLit) - | HsFloatPrim Rational -- Unboxed Float - | HsDoublePrim Rational -- Unboxed Double + | HsFloatPrim FractionalLit -- Unboxed Float + | HsDoublePrim FractionalLit -- Unboxed Double deriving (Data, Typeable) instance Eq HsLit where @@ -54,6 +57,8 @@ (HsInt x1) == (HsInt x2) = x1==x2 (HsIntPrim x1) == (HsIntPrim x2) = x1==x2 (HsWordPrim x1) == (HsWordPrim x2) = x1==x2 + (HsInt64Prim x1) == (HsInt64Prim x2) = x1==x2 + (HsWord64Prim x1) == (HsWord64Prim x2) = x1==x2 (HsInteger x1 _) == (HsInteger x2 _) = x1==x2 (HsRat x1 _) == (HsRat x2 _) = x1==x2 (HsFloatPrim x1) == (HsFloatPrim x2) = x1==x2 @@ -63,15 +68,14 @@ data HsOverLit id -- An overloaded literal = OverLit { ol_val :: OverLitVal, - ol_rebindable :: Bool, -- True <=> rebindable syntax - -- False <=> standard syntax + ol_rebindable :: Bool, -- Note [ol_rebindable] ol_witness :: SyntaxExpr id, -- Note [Overloaded literal witnesses] ol_type :: PostTcType } deriving (Data, Typeable) data OverLitVal = HsIntegral !Integer -- Integer-looking literals; - | HsFractional !Rational -- Frac-looking literals + | HsFractional !FractionalLit -- Frac-looking literals | HsIsString !FastString -- String-looking literals deriving (Data, Typeable) @@ -79,6 +83,19 @@ overLitType = ol_type \end{code} +Note [ol_rebindable] +~~~~~~~~~~~~~~~~~~~~ +The ol_rebindable field is True if this literal is actually +using rebindable syntax. Specifically: + + False iff ol_witness is the standard one + True iff ol_witness is non-standard + +Equivalently it's True if + a) RebindableSyntax is on + b) the witness for fromInteger/fromRational/fromString + that happens to be in scope isn't the standard one + Note [Overloaded literal witnesses] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ *Before* type checking, the SyntaxExpr in an HsOverLit is the @@ -89,7 +106,7 @@ This dual role is unusual, because we're replacing 'fromInteger' with a call to fromInteger. Reason: it allows commoning up of the fromInteger -calls, which wouldn't be possible if the desguarar made the application +calls, which wouldn't be possible if the desguarar made the application. The PostTcType in each branch records the type the overload literal is found to have. @@ -130,11 +147,13 @@ ppr (HsStringPrim s) = pprHsString s <> char '#' ppr (HsInt i) = integer i ppr (HsInteger i _) = integer i - ppr (HsRat f _) = rational f - ppr (HsFloatPrim f) = rational f <> char '#' - ppr (HsDoublePrim d) = rational d <> text "##" + ppr (HsRat f _) = ppr f + ppr (HsFloatPrim f) = ppr f <> char '#' + ppr (HsDoublePrim d) = ppr d <> text "##" ppr (HsIntPrim i) = integer i <> char '#' ppr (HsWordPrim w) = integer w <> text "##" + ppr (HsInt64Prim i) = integer i <> text "L#" + ppr (HsWord64Prim w) = integer w <> text "L##" -- in debug mode, print the expression that it's resolved to, too instance OutputableBndr id => Outputable (HsOverLit id) where @@ -143,6 +162,6 @@ instance Outputable OverLitVal where ppr (HsIntegral i) = integer i - ppr (HsFractional f) = rational f + ppr (HsFractional f) = ppr f ppr (HsIsString s) = pprHsString s \end{code} diff -Nru ghc-7.0.3/compiler/hsSyn/HsPat.lhs ghc-7.2.1/compiler/hsSyn/HsPat.lhs --- ghc-7.0.3/compiler/hsSyn/HsPat.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/hsSyn/HsPat.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -22,8 +22,9 @@ mkPrefixConPat, mkCharLitPat, mkNilPat, - isBangHsBind, isBangLPat, hsPatNeedsParens, - isIrrefutableHsPat, + isBangHsBind, isLiftedPatBind, + isBangLPat, hsPatNeedsParens, + isIrrefutableHsPat, pprParendLPat ) where @@ -64,9 +65,7 @@ -- support hsPatType :: Pat Id -> Type | VarPat id -- Variable - | VarPatOut id TcEvBinds -- Used only for overloaded Ids; the - -- bindings give its overloaded instances - | LazyPat (LPat id) -- Lazy pattern + | LazyPat (LPat id) -- Lazy pattern | AsPat (Located id) (LPat id) -- As pattern | ParPat (LPat id) -- Parenthesised pattern | BangPat (LPat id) -- Bang pattern @@ -123,7 +122,9 @@ | LitPat HsLit -- Used for *non-overloaded* literal patterns: -- Int#, Char#, Int, Char, String, etc. - | NPat (HsOverLit id) -- ALWAYS positive + | NPat -- Used for all overloaded literals, + -- including overloaded strings with -XOverloadedStrings + (HsOverLit id) -- ALWAYS positive (Maybe (SyntaxExpr id)) -- Just (Name of 'negate') for negative -- patterns, Nothing otherwise (SyntaxExpr id) -- Equality checker, of type t->t->Bool @@ -133,12 +134,6 @@ (SyntaxExpr id) -- (>=) function, of type t->t->Bool (SyntaxExpr id) -- Name of '-' (see RnEnv.lookupSyntaxName) - ------------ Generics --------------- - | TypePat (LHsType id) -- Type pattern for generic definitions - -- e.g f{| a+b |} = ... - -- These show up only in class declarations, - -- and should be a top-level pattern - ------------ Pattern type signatures --------------- | SigPatIn (LPat id) -- Pattern with a type signature (LHsType id) @@ -257,7 +252,6 @@ pprPat :: (OutputableBndr name) => Pat name -> SDoc pprPat (VarPat var) = pprPatBndr var -pprPat (VarPatOut var bs) = pprPatBndr var <+> braces (ppr bs) pprPat (WildPat _) = char '_' pprPat (LazyPat pat) = char '~' <> pprParendLPat pat pprPat (BangPat pat) = char '!' <> pprParendLPat pat @@ -283,7 +277,6 @@ pprPat (NPat l (Just _) _) = char '-' <> ppr l pprPat (NPlusKPat n k _ _) = hcat [ppr n, char '+', ppr k] pprPat (QuasiQuotePat qq) = ppr qq -pprPat (TypePat ty) = ptext (sLit "{|") <> ppr ty <> ptext (sLit "|}") pprPat (CoPat co pat _) = pprHsWrapper (ppr pat) co pprPat (SigPatIn pat ty) = ppr pat <+> dcolon <+> ppr ty pprPat (SigPatOut pat ty) = ppr pat <+> dcolon <+> ppr ty @@ -377,10 +370,29 @@ isBangLPat _ = False isBangHsBind :: HsBind id -> Bool --- In this module because HsPat is above HsBinds in the import graph +-- A pattern binding with an outermost bang +-- Defined in this module because HsPat is above HsBinds in the import graph isBangHsBind (PatBind { pat_lhs = p }) = isBangLPat p isBangHsBind _ = False +isLiftedPatBind :: HsBind id -> Bool +-- A pattern binding with a compound pattern, not just a variable +-- (I# x) yes +-- (# a, b #) no, even if a::Int# +-- x no, even if x::Int# +-- We want to warn about a missing bang-pattern on the yes's +isLiftedPatBind (PatBind { pat_lhs = p }) = isLiftedLPat p +isLiftedPatBind _ = False + +isLiftedLPat :: LPat id -> Bool +isLiftedLPat (L _ (ParPat p)) = isLiftedLPat p +isLiftedLPat (L _ (BangPat p)) = isLiftedLPat p +isLiftedLPat (L _ (AsPat _ p)) = isLiftedLPat p +isLiftedLPat (L _ (TuplePat _ Unboxed _)) = False +isLiftedLPat (L _ (VarPat {})) = False +isLiftedLPat (L _ (WildPat {})) = False +isLiftedLPat _ = True + isIrrefutableHsPat :: OutputableBndr id => LPat id -> Bool -- (isIrrefutableHsPat p) is true if matching against p cannot fail, -- in the sense of falling through to the next pattern. @@ -397,7 +409,6 @@ go1 (WildPat {}) = True go1 (VarPat {}) = True - go1 (VarPatOut {}) = True go1 (LazyPat {}) = True go1 (BangPat pat) = go pat go1 (CoPat _ pat _) = go1 pat @@ -423,14 +434,12 @@ go1 (QuasiQuotePat {}) = urk pat -- Gotten rid of by renamer, before -- isIrrefutablePat is called - go1 (TypePat {}) = urk pat urk pat = pprPanic "isIrrefutableHsPat:" (ppr pat) hsPatNeedsParens :: Pat a -> Bool hsPatNeedsParens (WildPat {}) = False hsPatNeedsParens (VarPat {}) = False -hsPatNeedsParens (VarPatOut {}) = True hsPatNeedsParens (LazyPat {}) = False hsPatNeedsParens (BangPat {}) = False hsPatNeedsParens (CoPat {}) = True @@ -448,7 +457,6 @@ hsPatNeedsParens (NPat {}) = False hsPatNeedsParens (NPlusKPat {}) = True hsPatNeedsParens (QuasiQuotePat {}) = True -hsPatNeedsParens (TypePat {}) = False conPatNeedsParens :: HsConDetails a b -> Bool conPatNeedsParens (PrefixCon args) = not (null args) diff -Nru ghc-7.0.3/compiler/hsSyn/HsSyn.lhs ghc-7.2.1/compiler/hsSyn/HsSyn.lhs --- ghc-7.0.3/compiler/hsSyn/HsSyn.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/hsSyn/HsSyn.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -41,7 +41,7 @@ -- others: import IfaceSyn ( IfaceBinding ) import Outputable -import SrcLoc ( Located(..) ) +import SrcLoc import Module ( Module, ModuleName ) import FastString diff -Nru ghc-7.0.3/compiler/hsSyn/HsTypes.lhs ghc-7.2.1/compiler/hsSyn/HsTypes.lhs --- ghc-7.0.3/compiler/hsSyn/HsTypes.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/hsSyn/HsTypes.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -26,6 +26,7 @@ hsTyVarKind, hsTyVarNameKind, hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames, splitHsInstDeclTy, splitHsFunType, + splitHsAppTys, mkHsAppTys, -- Type place holder PostTcType, placeHolderType, PostTcKind, placeHolderKind, @@ -168,8 +169,6 @@ -- interface files smaller), so when printing a HsType we may need to -- add parens. - | HsNumTy Integer -- Generics only - | HsPredTy (HsPred name) -- Only used in the type of an instance -- declaration, eg. Eq [a] -> Eq a -- ^^^^ @@ -294,6 +293,19 @@ \begin{code} +splitHsAppTys :: LHsType n -> [LHsType n] -> (LHsType n, [LHsType n]) +splitHsAppTys (L _ (HsAppTy f a)) as = splitHsAppTys f (a:as) +splitHsAppTys f as = (f,as) + +mkHsAppTys :: OutputableBndr n => LHsType n -> [LHsType n] -> HsType n +mkHsAppTys fun_ty [] = pprPanic "mkHsAppTys" (ppr fun_ty) +mkHsAppTys fun_ty (arg_ty:arg_tys) + = foldl mk_app (HsAppTy fun_ty arg_ty) arg_tys + where + mk_app fun arg = HsAppTy (noLoc fun) arg + -- Add noLocs for inner nodes of the application; + -- they are never used + splitHsInstDeclTy :: OutputableBndr name => HsType name @@ -440,7 +452,6 @@ ppr_mono_ty _ (HsListTy ty) = brackets (ppr_mono_lty pREC_TOP ty) ppr_mono_ty _ (HsPArrTy ty) = pabrackets (ppr_mono_lty pREC_TOP ty) ppr_mono_ty _ (HsPredTy pred) = ppr pred -ppr_mono_ty _ (HsNumTy n) = integer n -- generics only ppr_mono_ty _ (HsSpliceTy s _ _) = pprSplice s ppr_mono_ty _ (HsCoreTy ty) = ppr ty diff -Nru ghc-7.0.3/compiler/hsSyn/HsUtils.lhs ghc-7.2.1/compiler/hsSyn/HsUtils.lhs --- ghc-7.0.3/compiler/hsSyn/HsUtils.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/hsSyn/HsUtils.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -19,15 +19,15 @@ mkHsPar, mkHsApp, mkHsConApp, mkSimpleHsAlt, mkSimpleMatch, unguardedGRHSs, unguardedRHS, mkMatchGroup, mkMatch, mkHsLam, mkHsIf, - mkHsWrap, mkLHsWrap, mkHsWrapCoI, mkLHsWrapCoI, - coiToHsWrapper, mkHsDictLet, - mkHsOpApp, mkHsDo, mkHsWrapPat, mkHsWrapPatCoI, + mkHsWrap, mkLHsWrap, mkHsWrapCo, mkLHsWrapCo, + coToHsWrapper, mkHsDictLet, mkHsLams, + mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo, nlHsTyApp, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps, nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList, mkLHsTupleExpr, mkLHsVarTuple, missingTupArg, - -- Bindigns + -- Bindings mkFunBind, mkVarBind, mkHsVarBind, mk_easy_FunBind, -- Literals @@ -42,8 +42,8 @@ nlHsAppTy, nlHsTyVar, nlHsFunTy, nlHsTyConApp, -- Stmts - mkTransformStmt, mkTransformByStmt, mkExprStmt, mkBindStmt, - mkGroupUsingStmt, mkGroupByStmt, mkGroupByUsingStmt, + mkTransformStmt, mkTransformByStmt, mkExprStmt, mkBindStmt, mkLastStmt, + emptyTransStmt, mkGroupUsingStmt, mkGroupByStmt, mkGroupByUsingStmt, emptyRecStmt, mkRecStmt, -- Template Haskell @@ -61,7 +61,10 @@ collectSigTysFromPats, collectSigTysFromPat, hsTyClDeclBinders, hsTyClDeclsBinders, - hsForeignDeclsBinders, hsGroupBinders + hsForeignDeclsBinders, hsGroupBinders, + + -- Collecting implicit binders + lStmtsImplicits, hsValBindsImplicits, lPatImplicits ) where import HsDecls @@ -74,7 +77,7 @@ import RdrName import Var import Coercion -import Type +import TypeRep import DataCon import Name import NameSet @@ -83,6 +86,9 @@ import FastString import Util import Bag + +import Data.Either +import Data.Maybe \end{code} @@ -131,25 +137,25 @@ mkHsWrap co_fn e | isIdHsWrapper co_fn = e | otherwise = HsWrap co_fn e -mkHsWrapCoI :: CoercionI -> HsExpr id -> HsExpr id -mkHsWrapCoI (IdCo _) e = e -mkHsWrapCoI (ACo co) e = mkHsWrap (WpCast co) e - -mkLHsWrapCoI :: CoercionI -> LHsExpr id -> LHsExpr id -mkLHsWrapCoI (IdCo _) e = e -mkLHsWrapCoI (ACo co) (L loc e) = L loc (mkHsWrap (WpCast co) e) - -coiToHsWrapper :: CoercionI -> HsWrapper -coiToHsWrapper (IdCo _) = idHsWrapper -coiToHsWrapper (ACo co) = WpCast co +mkHsWrapCo :: Coercion -> HsExpr id -> HsExpr id +mkHsWrapCo (Refl _) e = e +mkHsWrapCo co e = mkHsWrap (WpCast co) e + +mkLHsWrapCo :: Coercion -> LHsExpr id -> LHsExpr id +mkLHsWrapCo (Refl _) e = e +mkLHsWrapCo co (L loc e) = L loc (mkHsWrap (WpCast co) e) + +coToHsWrapper :: Coercion -> HsWrapper +coToHsWrapper (Refl _) = idHsWrapper +coToHsWrapper co = WpCast co mkHsWrapPat :: HsWrapper -> Pat id -> Type -> Pat id mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p | otherwise = CoPat co_fn p ty -mkHsWrapPatCoI :: CoercionI -> Pat id -> Type -> Pat id -mkHsWrapPatCoI (IdCo _) pat _ = pat -mkHsWrapPatCoI (ACo co) pat ty = CoPat (WpCast co) pat ty +mkHsWrapPatCo :: Coercion -> Pat id -> Type -> Pat id +mkHsWrapPatCo (Refl _) pat _ = pat +mkHsWrapPatCo co pat ty = CoPat (WpCast co) pat ty mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches)) @@ -159,8 +165,11 @@ mkMatchGroup :: [LMatch id] -> MatchGroup id mkMatchGroup matches = MatchGroup matches placeHolderType +mkHsLams :: [TyVar] -> [EvVar] -> LHsExpr Id -> LHsExpr Id +mkHsLams tyvars dicts expr = mkLHsWrap (mkWpTyLams tyvars <.> mkWpLams dicts) expr + mkHsDictLet :: TcEvBinds -> LHsExpr Id -> LHsExpr Id -mkHsDictLet ev_binds expr = mkLHsWrap (WpLet ev_binds) expr +mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr mkHsConApp :: DataCon -> [Type] -> [HsExpr Id] -> LHsExpr Id -- Used for constructing dictionary terms etc, so no locations @@ -179,16 +188,15 @@ -- See RnEnv.lookupSyntaxName mkHsIntegral :: Integer -> PostTcType -> HsOverLit id -mkHsFractional :: Rational -> PostTcType -> HsOverLit id +mkHsFractional :: FractionalLit -> PostTcType -> HsOverLit id mkHsIsString :: FastString -> PostTcType -> HsOverLit id -mkHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> HsExpr id +mkHsDo :: HsStmtContext Name -> [LStmt id] -> HsExpr id +mkHsComp :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> HsExpr id mkNPat :: HsOverLit id -> Maybe (SyntaxExpr id) -> Pat id mkNPlusKPat :: Located id -> HsOverLit id -> Pat id -mkTransformStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL idR -mkTransformByStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR - +mkLastStmt :: LHsExpr idR -> StmtLR idL idR mkExprStmt :: LHsExpr idR -> StmtLR idL idR mkBindStmt :: LPat idL -> LHsExpr idR -> StmtLR idL idR @@ -203,7 +211,10 @@ noRebindableInfo :: Bool noRebindableInfo = error "noRebindableInfo" -- Just another placeholder; -mkHsDo ctxt stmts body = HsDo ctxt stmts body placeHolderType +mkHsDo ctxt stmts = HsDo ctxt stmts placeHolderType +mkHsComp ctxt stmts expr = mkHsDo ctxt (stmts ++ [last_stmt]) + where + last_stmt = L (getLoc expr) $ mkLastStmt expr mkHsIf :: LHsExpr id -> LHsExpr id -> LHsExpr id -> HsExpr id mkHsIf c a b = HsIf (Just noSyntaxExpr) c a b @@ -211,24 +222,32 @@ mkNPat lit neg = NPat lit neg noSyntaxExpr mkNPlusKPat id lit = NPlusKPat id lit noSyntaxExpr noSyntaxExpr -mkTransformStmt stmts usingExpr = TransformStmt stmts [] usingExpr Nothing -mkTransformByStmt stmts usingExpr byExpr = TransformStmt stmts [] usingExpr (Just byExpr) - +mkTransformStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL idR +mkTransformByStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR mkGroupUsingStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL idR mkGroupByStmt :: [LStmt idL] -> LHsExpr idR -> StmtLR idL idR mkGroupByUsingStmt :: [LStmt idL] -> LHsExpr idR -> LHsExpr idR -> StmtLR idL idR -mkGroupUsingStmt stmts usingExpr = GroupStmt stmts [] Nothing (Left usingExpr) -mkGroupByStmt stmts byExpr = GroupStmt stmts [] (Just byExpr) (Right noSyntaxExpr) -mkGroupByUsingStmt stmts byExpr usingExpr = GroupStmt stmts [] (Just byExpr) (Left usingExpr) +emptyTransStmt :: StmtLR idL idR +emptyTransStmt = TransStmt { trS_form = undefined, trS_stmts = [], trS_bndrs = [] + , trS_by = Nothing, trS_using = noLoc noSyntaxExpr + , trS_ret = noSyntaxExpr, trS_bind = noSyntaxExpr + , trS_fmap = noSyntaxExpr } +mkTransformStmt ss u = emptyTransStmt { trS_form = ThenForm, trS_stmts = ss, trS_using = u } +mkTransformByStmt ss u b = emptyTransStmt { trS_form = ThenForm, trS_stmts = ss, trS_using = u, trS_by = Just b } +mkGroupByStmt ss b = emptyTransStmt { trS_form = GroupFormB, trS_stmts = ss, trS_by = Just b } +mkGroupUsingStmt ss u = emptyTransStmt { trS_form = GroupFormU, trS_stmts = ss, trS_using = u } +mkGroupByUsingStmt ss b u = emptyTransStmt { trS_form = GroupFormU, trS_stmts = ss + , trS_by = Just b, trS_using = u } -mkExprStmt expr = ExprStmt expr noSyntaxExpr placeHolderType +mkLastStmt expr = LastStmt expr noSyntaxExpr +mkExprStmt expr = ExprStmt expr noSyntaxExpr noSyntaxExpr placeHolderType mkBindStmt pat expr = BindStmt pat expr noSyntaxExpr noSyntaxExpr emptyRecStmt = RecStmt { recS_stmts = [], recS_later_ids = [], recS_rec_ids = [] , recS_ret_fn = noSyntaxExpr, recS_mfix_fn = noSyntaxExpr , recS_bind_fn = noSyntaxExpr - , recS_rec_rets = [], recS_dicts = emptyTcEvBinds } + , recS_rec_rets = [], recS_ret_ty = placeHolderType } mkRecStmt stmts = emptyRecStmt { recS_stmts = stmts } @@ -318,8 +337,8 @@ nlWildPat :: LPat id nlWildPat = noLoc (WildPat placeHolderType) -- Pre-typechecking -nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id -> LHsExpr id -nlHsDo ctxt stmts body = noLoc (mkHsDo ctxt stmts body) +nlHsDo :: HsStmtContext Name -> [LStmt id] -> LHsExpr id +nlHsDo ctxt stmts = noLoc (mkHsDo ctxt stmts) nlHsOpApp :: LHsExpr id -> id -> LHsExpr id -> LHsExpr id nlHsOpApp e1 op e2 = noLoc (mkHsOpApp e1 op e2) @@ -487,12 +506,12 @@ -- Id Binders for a Stmt... [but what about pattern-sig type vars]? collectStmtBinders (BindStmt pat _ _ _) = collectPatBinders pat collectStmtBinders (LetStmt binds) = collectLocalBinders binds -collectStmtBinders (ExprStmt _ _ _) = [] -collectStmtBinders (ParStmt xs) = collectLStmtsBinders +collectStmtBinders (ExprStmt {}) = [] +collectStmtBinders (LastStmt {}) = [] +collectStmtBinders (ParStmt xs _ _ _) = collectLStmtsBinders $ concatMap fst xs -collectStmtBinders (TransformStmt stmts _ _ _) = collectLStmtsBinders stmts -collectStmtBinders (GroupStmt stmts _ _ _) = collectLStmtsBinders stmts -collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss +collectStmtBinders (TransStmt { trS_stmts = stmts }) = collectLStmtsBinders stmts +collectStmtBinders (RecStmt { recS_stmts = ss }) = collectLStmtsBinders ss ----------------- Patterns -------------------------- @@ -508,8 +527,6 @@ = go pat where go (VarPat var) = var : bndrs - go (VarPatOut var _) = var : bndrs - -- See Note [Dictionary binders in ConPatOut] go (WildPat _) = bndrs go (LazyPat pat) = collect_lpat pat bndrs go (BangPat pat) = collect_lpat pat bndrs @@ -531,7 +548,6 @@ go (SigPatIn pat _) = collect_lpat pat bndrs go (SigPatOut pat _) = collect_lpat pat bndrs go (QuasiQuotePat _) = bndrs - go (TypePat _) = bndrs go (CoPat _ pat _) = go pat \end{code} @@ -586,15 +602,21 @@ -- occurence. We use the equality to filter out duplicate field names hsTyClDeclBinders (L _ (TyFamily {tcdLName = name})) = [name] -hsTyClDeclBinders (L _ (TySynonym {tcdLName = name})) = [name] hsTyClDeclBinders (L _ (ForeignType {tcdLName = name})) = [name] hsTyClDeclBinders (L _ (ClassDecl {tcdLName = cls_name, tcdSigs = sigs, tcdATs = ats})) = cls_name : - concatMap hsTyClDeclBinders ats ++ [n | L _ (TypeSig n _) <- sigs] + concatMap hsTyClDeclBinders ats ++ [n | L _ (TypeSig ns _) <- sigs, n <- ns] -hsTyClDeclBinders (L _ (TyData {tcdLName = tc_name, tcdCons = cons})) - = tc_name : hsConDeclsBinders cons +hsTyClDeclBinders (L _ (TySynonym {tcdLName = name, tcdTyPats = mb_pats })) + | isJust mb_pats = [] + | otherwise = [name] + -- See Note [Binders in family instances] + +hsTyClDeclBinders (L _ (TyData {tcdLName = tc_name, tcdCons = cons, tcdTyPats = mb_pats })) + | isJust mb_pats = hsConDeclsBinders cons + | otherwise = tc_name : hsConDeclsBinders cons + -- See Note [Binders in family instances] hsConDeclsBinders :: (Eq name) => [LConDecl name] -> [Located name] -- See hsTyClDeclBinders for what this does @@ -613,6 +635,92 @@ = (flds_seen, lname:acc) \end{code} +Note [Binders in family instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +In a type or data family instance declaration, the type +constructor is an *occurrence* not a binding site + type instance T Int = Int -> Int -- No binders + data instance S Bool = S1 | S2 -- Binders are S1,S2 + + +%************************************************************************ +%* * + Collecting binders the user did not write +%* * +%************************************************************************ + +The job of this family of functions is to run through binding sites and find the set of all Names +that were defined "implicitly", without being explicitly written by the user. + +The main purpose is to find names introduced by record wildcards so that we can avoid +warning the user when they don't use those names (#4404) + +\begin{code} +lStmtsImplicits :: [LStmtLR Name idR] -> NameSet +lStmtsImplicits = hs_lstmts + where + hs_lstmts :: [LStmtLR Name idR] -> NameSet + hs_lstmts = foldr (\stmt rest -> unionNameSets (hs_stmt (unLoc stmt)) rest) emptyNameSet + + hs_stmt (BindStmt pat _ _ _) = lPatImplicits pat + hs_stmt (LetStmt binds) = hs_local_binds binds + hs_stmt (ExprStmt {}) = emptyNameSet + hs_stmt (LastStmt {}) = emptyNameSet + hs_stmt (ParStmt xs _ _ _) = hs_lstmts $ concatMap fst xs + + hs_stmt (TransStmt { trS_stmts = stmts }) = hs_lstmts stmts + hs_stmt (RecStmt { recS_stmts = ss }) = hs_lstmts ss + + hs_local_binds (HsValBinds val_binds) = hsValBindsImplicits val_binds + hs_local_binds (HsIPBinds _) = emptyNameSet + hs_local_binds EmptyLocalBinds = emptyNameSet + +hsValBindsImplicits :: HsValBindsLR Name idR -> NameSet +hsValBindsImplicits (ValBindsOut binds _) + = foldr (unionNameSets . lhsBindsImplicits . snd) emptyNameSet binds +hsValBindsImplicits (ValBindsIn binds _) + = lhsBindsImplicits binds + +lhsBindsImplicits :: LHsBindsLR Name idR -> NameSet +lhsBindsImplicits = foldBag unionNameSets lhs_bind emptyNameSet + where + lhs_bind (L _ (PatBind { pat_lhs = lpat })) = lPatImplicits lpat + lhs_bind _ = emptyNameSet + +lPatImplicits :: LPat Name -> NameSet +lPatImplicits = hs_lpat + where + hs_lpat (L _ pat) = hs_pat pat + + hs_lpats = foldr (\pat rest -> hs_lpat pat `unionNameSets` rest) emptyNameSet + + hs_pat (LazyPat pat) = hs_lpat pat + hs_pat (BangPat pat) = hs_lpat pat + hs_pat (AsPat _ pat) = hs_lpat pat + hs_pat (ViewPat _ pat _) = hs_lpat pat + hs_pat (ParPat pat) = hs_lpat pat + hs_pat (ListPat pats _) = hs_lpats pats + hs_pat (PArrPat pats _) = hs_lpats pats + hs_pat (TuplePat pats _ _) = hs_lpats pats + + hs_pat (SigPatIn pat _) = hs_lpat pat + hs_pat (SigPatOut pat _) = hs_lpat pat + hs_pat (CoPat _ pat _) = hs_pat pat + + hs_pat (ConPatIn _ ps) = details ps + hs_pat (ConPatOut {pat_args=ps}) = details ps + + hs_pat _ = emptyNameSet + + details (PrefixCon ps) = hs_lpats ps + details (RecCon fs) = hs_lpats explicit `unionNameSets` mkNameSet (collectPatsBinders implicit) + where (explicit, implicit) = partitionEithers [if pat_explicit then Left pat else Right pat + | (i, fld) <- [0..] `zip` rec_flds fs + , let pat = hsRecFieldArg fld + pat_explicit = maybe True (i<) (rec_dotdot fs)] + details (InfixCon p1 p2) = hs_lpat p1 `unionNameSets` hs_lpat p2 +\end{code} + %************************************************************************ %* * @@ -632,7 +740,6 @@ collect_sig_pat :: Pat name -> [LHsType name] -> [LHsType name] collect_sig_pat (SigPatIn pat ty) acc = collect_sig_lpat pat (ty:acc) -collect_sig_pat (TypePat ty) acc = ty:acc collect_sig_pat (LazyPat pat) acc = collect_sig_lpat pat acc collect_sig_pat (BangPat pat) acc = collect_sig_lpat pat acc diff -Nru ghc-7.0.3/compiler/HsVersions.h ghc-7.2.1/compiler/HsVersions.h --- ghc-7.0.3/compiler/HsVersions.h 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/HsVersions.h 2011-08-07 17:10:05.000000000 +0000 @@ -36,19 +36,19 @@ name :: IORef (ty); \ name = Util.global (value); -#define GLOBAL_MVAR(name,value,ty) \ -{-# NOINLINE name #-}; \ -name :: MVar (ty); \ -name = Util.globalMVar (value); +#define GLOBAL_VAR_M(name,value,ty) \ +{-# NOINLINE name #-}; \ +name :: IORef (ty); \ +name = Util.globalM (value); #endif #else /* __HADDOCK__ */ #define GLOBAL_VAR(name,value,ty) \ name :: IORef (ty); \ name = Util.global (value); -#define GLOBAL_MVAR(name,value,ty) \ -name :: MVar (ty); \ -name = Util.globalMVar (value); +#define GLOBAL_VAR_M(name,value,ty) \ +name :: IORef (ty); \ +name = Util.globalM (value); #endif #define COMMA , diff -Nru ghc-7.0.3/compiler/iface/BinIface.hs ghc-7.2.1/compiler/iface/BinIface.hs --- ghc-7.0.3/compiler/iface/BinIface.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/iface/BinIface.hs 2011-08-07 17:10:05.000000000 +0000 @@ -1,4 +1,3 @@ - {-# OPTIONS_GHC -O #-} -- We always optimise this, otherwise performance of a non-optimised -- compiler is severely affected @@ -19,7 +18,6 @@ import BasicTypes import Demand import Annotations -import CoreSyn import IfaceSyn import Module import Name @@ -257,22 +255,20 @@ -> OnDiskName -> (NameCache, Name) fromOnDiskName _ nc (pid, mod_name, occ) = - let + let mod = mkModule pid mod_name cache = nsNames nc in case lookupOrigNameCache cache mod occ of Just name -> (nc, name) - Nothing -> - let - us = nsUniqs nc - uniq = uniqFromSupply us + Nothing -> + case takeUniqFromSupply (nsUniqs nc) of + (uniq, us) -> + let name = mkExternalName uniq mod occ noSrcSpan new_cache = extendNameCache cache mod occ name - in - case splitUniqSupply us of { (us',_) -> - ( nc{ nsUniqs = us', nsNames = new_cache }, name ) - } + in + ( nc{ nsUniqs = us, nsNames = new_cache }, name ) serialiseName :: BinHandle -> Name -> UniqFM (Int,Name) -> IO () serialiseName bh name _ = do @@ -384,7 +380,8 @@ mi_usages = usages, mi_exports = exports, mi_exp_hash = exp_hash, - mi_fixities = fixities, + mi_used_th = used_th, + mi_fixities = fixities, mi_warns = warns, mi_anns = anns, mi_decls = decls, @@ -393,7 +390,9 @@ mi_rules = rules, mi_orphan_hash = orphan_hash, mi_vect_info = vect_info, - mi_hpc = hpc_info }) = do + mi_hpc = hpc_info, + mi_trust = trust, + mi_trust_pkg = trust_pkg }) = do put_ bh mod put_ bh is_boot put_ bh iface_hash @@ -404,7 +403,8 @@ lazyPut bh usages put_ bh exports put_ bh exp_hash - put_ bh fixities + put_ bh used_th + put_ bh fixities lazyPut bh warns lazyPut bh anns put_ bh decls @@ -414,6 +414,8 @@ put_ bh orphan_hash put_ bh vect_info put_ bh hpc_info + put_ bh trust + put_ bh trust_pkg get bh = do mod_name <- get bh @@ -426,7 +428,8 @@ usages <- {-# SCC "bin_usages" #-} lazyGet bh exports <- {-# SCC "bin_exports" #-} get bh exp_hash <- get bh - fixities <- {-# SCC "bin_fixities" #-} get bh + used_th <- get bh + fixities <- {-# SCC "bin_fixities" #-} get bh warns <- {-# SCC "bin_warns" #-} lazyGet bh anns <- {-# SCC "bin_anns" #-} lazyGet bh decls <- {-# SCC "bin_tycldecls" #-} get bh @@ -436,6 +439,8 @@ orphan_hash <- get bh vect_info <- get bh hpc_info <- get bh + trust <- get bh + trust_pkg <- get bh return (ModIface { mi_module = mod_name, mi_boot = is_boot, @@ -446,8 +451,9 @@ mi_deps = deps, mi_usages = usages, mi_exports = exports, - mi_exp_hash = exp_hash, - mi_anns = anns, + mi_exp_hash = exp_hash, + mi_used_th = used_th, + mi_anns = anns, mi_fixities = fixities, mi_warns = warns, mi_decls = decls, @@ -458,6 +464,8 @@ mi_orphan_hash = orphan_hash, mi_vect_info = vect_info, mi_hpc = hpc_info, + mi_trust = trust, + mi_trust_pkg = trust_pkg, -- And build the cached values mi_warn_fn = mkIfaceWarnCache warns, mi_fix_fn = mkIfaceFixCache fixities, @@ -488,7 +496,7 @@ return (Deps { dep_mods = ms, dep_pkgs = ps, dep_orphs = os, dep_finsts = fis }) -instance (Binary name) => Binary (GenAvailInfo name) where +instance Binary AvailInfo where put_ bh (Avail aa) = do putByte bh 0 put_ bh aa @@ -510,12 +518,14 @@ putByte bh 0 put_ bh (usg_mod usg) put_ bh (usg_mod_hash usg) + put_ bh (usg_safe usg) put_ bh usg@UsageHomeModule{} = do putByte bh 1 put_ bh (usg_mod_name usg) put_ bh (usg_mod_hash usg) put_ bh (usg_exports usg) put_ bh (usg_entities usg) + put_ bh (usg_safe usg) get bh = do h <- getByte bh @@ -523,14 +533,16 @@ 0 -> do nm <- get bh mod <- get bh - return UsagePackageModule { usg_mod = nm, usg_mod_hash = mod } + safe <- get bh + return UsagePackageModule { usg_mod = nm, usg_mod_hash = mod, usg_safe = safe } _ -> do nm <- get bh mod <- get bh exps <- get bh ents <- get bh + safe <- get bh return UsageHomeModule { usg_mod_name = nm, usg_mod_hash = mod, - usg_exports = exps, usg_entities = ents } + usg_exports = exps, usg_entities = ents, usg_safe = safe } instance Binary Warnings where put_ bh NoWarnings = putByte bh 0 @@ -905,10 +917,11 @@ put_ bh (IfaceTyConApp (IfaceAnyTc k) []) = do { putByte bh 17; put_ bh k } -- Generic cases - put_ bh (IfaceTyConApp (IfaceTc tc) tys) = do { putByte bh 18; put_ bh tc; put_ bh tys } put_ bh (IfaceTyConApp tc tys) = do { putByte bh 19; put_ bh tc; put_ bh tys } + put_ bh (IfaceCoConApp cc tys) = do { putByte bh 20; put_ bh cc; put_ bh tys } + get bh = do h <- getByte bh case h of @@ -941,11 +954,11 @@ 17 -> do { k <- get bh; return (IfaceTyConApp (IfaceAnyTc k) []) } 18 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) } - _ -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) } + 19 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) } + _ -> do { cc <- get bh; tys <- get bh; return (IfaceCoConApp cc tys) } instance Binary IfaceTyCon where -- Int,Char,Bool can't show up here because they can't not be saturated - put_ bh IfaceIntTc = putByte bh 1 put_ bh IfaceBoolTc = putByte bh 2 put_ bh IfaceCharTc = putByte bh 3 @@ -956,9 +969,9 @@ put_ bh IfaceUnliftedTypeKindTc = putByte bh 8 put_ bh IfaceUbxTupleKindTc = putByte bh 9 put_ bh IfaceArgTypeKindTc = putByte bh 10 - put_ bh (IfaceTupTc bx ar) = do { putByte bh 11; put_ bh bx; put_ bh ar } - put_ bh (IfaceTc ext) = do { putByte bh 12; put_ bh ext } - put_ bh (IfaceAnyTc k) = do { putByte bh 13; put_ bh k } + put_ bh (IfaceTupTc bx ar) = do { putByte bh 11; put_ bh bx; put_ bh ar } + put_ bh (IfaceTc ext) = do { putByte bh 12; put_ bh ext } + put_ bh (IfaceAnyTc k) = do { putByte bh 13; put_ bh k } get bh = do h <- getByte bh @@ -975,7 +988,27 @@ 10 -> return IfaceArgTypeKindTc 11 -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) } 12 -> do { ext <- get bh; return (IfaceTc ext) } - _ -> do { k <- get bh; return (IfaceAnyTc k) } + _ -> do { k <- get bh; return (IfaceAnyTc k) } + +instance Binary IfaceCoCon where + put_ bh (IfaceCoAx n) = do { putByte bh 0; put_ bh n } + put_ bh IfaceReflCo = putByte bh 1 + put_ bh IfaceUnsafeCo = putByte bh 2 + put_ bh IfaceSymCo = putByte bh 3 + put_ bh IfaceTransCo = putByte bh 4 + put_ bh IfaceInstCo = putByte bh 5 + put_ bh (IfaceNthCo d) = do { putByte bh 6; put_ bh d } + + get bh = do + h <- getByte bh + case h of + 0 -> do { n <- get bh; return (IfaceCoAx n) } + 1 -> return IfaceReflCo + 2 -> return IfaceUnsafeCo + 3 -> return IfaceSymCo + 4 -> return IfaceTransCo + 5 -> return IfaceInstCo + _ -> do { d <- get bh; return (IfaceNthCo d) } instance Binary IfacePredType where put_ bh (IfaceClassP aa ab) = do @@ -1015,50 +1048,50 @@ put_ bh (IfaceType ab) = do putByte bh 1 put_ bh ab - put_ bh (IfaceTuple ac ad) = do + put_ bh (IfaceCo ab) = do putByte bh 2 + put_ bh ab + put_ bh (IfaceTuple ac ad) = do + putByte bh 3 put_ bh ac put_ bh ad put_ bh (IfaceLam ae af) = do - putByte bh 3 + putByte bh 4 put_ bh ae put_ bh af put_ bh (IfaceApp ag ah) = do - putByte bh 4 + putByte bh 5 put_ bh ag put_ bh ah --- gaw 2004 - put_ bh (IfaceCase ai aj al ak) = do - putByte bh 5 + put_ bh (IfaceCase ai aj ak) = do + putByte bh 6 put_ bh ai put_ bh aj --- gaw 2004 - put_ bh al put_ bh ak put_ bh (IfaceLet al am) = do - putByte bh 6 + putByte bh 7 put_ bh al put_ bh am put_ bh (IfaceNote an ao) = do - putByte bh 7 + putByte bh 8 put_ bh an put_ bh ao put_ bh (IfaceLit ap) = do - putByte bh 8 + putByte bh 9 put_ bh ap put_ bh (IfaceFCall as at) = do - putByte bh 9 + putByte bh 10 put_ bh as put_ bh at put_ bh (IfaceExt aa) = do - putByte bh 10 + putByte bh 11 put_ bh aa put_ bh (IfaceCast ie ico) = do - putByte bh 11 + putByte bh 12 put_ bh ie put_ bh ico put_ bh (IfaceTick m ix) = do - putByte bh 12 + putByte bh 13 put_ bh m put_ bh ix get bh = do @@ -1068,39 +1101,38 @@ return (IfaceLcl aa) 1 -> do ab <- get bh return (IfaceType ab) - 2 -> do ac <- get bh + 2 -> do ab <- get bh + return (IfaceCo ab) + 3 -> do ac <- get bh ad <- get bh return (IfaceTuple ac ad) - 3 -> do ae <- get bh + 4 -> do ae <- get bh af <- get bh return (IfaceLam ae af) - 4 -> do ag <- get bh + 5 -> do ag <- get bh ah <- get bh return (IfaceApp ag ah) - 5 -> do ai <- get bh + 6 -> do ai <- get bh aj <- get bh --- gaw 2004 - al <- get bh ak <- get bh --- gaw 2004 - return (IfaceCase ai aj al ak) - 6 -> do al <- get bh + return (IfaceCase ai aj ak) + 7 -> do al <- get bh am <- get bh return (IfaceLet al am) - 7 -> do an <- get bh + 8 -> do an <- get bh ao <- get bh return (IfaceNote an ao) - 8 -> do ap <- get bh + 9 -> do ap <- get bh return (IfaceLit ap) - 9 -> do as <- get bh - at <- get bh - return (IfaceFCall as at) - 10 -> do aa <- get bh + 10 -> do as <- get bh + at <- get bh + return (IfaceFCall as at) + 11 -> do aa <- get bh return (IfaceExt aa) - 11 -> do ie <- get bh + 12 -> do ie <- get bh ico <- get bh return (IfaceCast ie ico) - 12 -> do m <- get bh + 13 -> do m <- get bh ix <- get bh return (IfaceTick m ix) _ -> panic ("get IfaceExpr " ++ show h) @@ -1148,7 +1180,7 @@ instance Binary IfaceIdDetails where put_ bh IfVanillaId = putByte bh 0 put_ bh (IfRecSelId a b) = do { putByte bh 1; put_ bh a; put_ bh b } - put_ bh (IfDFunId n) = do { putByte bh 2; put_ bh n } + put_ bh IfDFunId = putByte bh 2 get bh = do h <- getByte bh case h of @@ -1156,7 +1188,7 @@ 1 -> do a <- get bh b <- get bh return (IfRecSelId a b) - _ -> do { n <- get bh; return (IfDFunId n) } + _ -> return IfDFunId instance Binary IfaceIdInfo where put_ bh NoInfo = putByte bh 0 @@ -1248,16 +1280,6 @@ _ -> do e <- get bh return (IfCompulsory e) -instance Binary (DFunArg IfaceExpr) where - put_ bh (DFunPolyArg e) = putByte bh 0 >> put_ bh e - put_ bh (DFunConstArg e) = putByte bh 1 >> put_ bh e - put_ bh (DFunLamArg i) = putByte bh 2 >> put_ bh i - get bh = do { h <- getByte bh - ; case h of - 0 -> do { a <- get bh; return (DFunPolyArg a) } - 1 -> do { a <- get bh; return (DFunConstArg a) } - _ -> do { a <- get bh; return (DFunLamArg a) } } - instance Binary IfaceNote where put_ bh (IfaceSCC aa) = do putByte bh 0 @@ -1293,7 +1315,7 @@ put_ bh idinfo put_ _ (IfaceForeign _ _) = error "Binary.put_(IfaceDecl): IfaceForeign" - put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7 a8) = do + put_ bh (IfaceData a1 a2 a3 a4 a5 a6 a7) = do putByte bh 2 put_ bh (occNameFS a1) put_ bh a2 @@ -1302,7 +1324,6 @@ put_ bh a5 put_ bh a6 put_ bh a7 - put_ bh a8 put_ bh (IfaceSyn a1 a2 a3 a4 a5) = do putByte bh 3 put_ bh (occNameFS a1) @@ -1337,9 +1358,8 @@ a5 <- get bh a6 <- get bh a7 <- get bh - a8 <- get bh occ <- return $! mkOccNameFS tcName a1 - return (IfaceData occ a2 a3 a4 a5 a6 a7 a8) + return (IfaceData occ a2 a3 a4 a5 a6 a7) 3 -> do a1 <- get bh a2 <- get bh @@ -1384,14 +1404,15 @@ return (IfaceFamInst fam tys tycon) instance Binary OverlapFlag where - put_ bh NoOverlap = putByte bh 0 - put_ bh OverlapOk = putByte bh 1 - put_ bh Incoherent = putByte bh 2 + put_ bh (NoOverlap b) = putByte bh 0 >> put_ bh b + put_ bh (OverlapOk b) = putByte bh 1 >> put_ bh b + put_ bh (Incoherent b) = putByte bh 2 >> put_ bh b get bh = do h <- getByte bh + b <- get bh case h of - 0 -> return NoOverlap - 1 -> return OverlapOk - 2 -> return Incoherent + 0 -> return $ NoOverlap b + 1 -> return $ OverlapOk b + 2 -> return $ Incoherent b _ -> panic ("get OverlapFlag " ++ show h) instance Binary IfaceConDecls where @@ -1493,14 +1514,21 @@ return (ModuleTarget a) instance Binary IfaceVectInfo where - put_ bh (IfaceVectInfo a1 a2 a3) = do + put_ bh (IfaceVectInfo a1 a2 a3 a4 a5) = do put_ bh a1 put_ bh a2 put_ bh a3 + put_ bh a4 + put_ bh a5 get bh = do a1 <- get bh a2 <- get bh a3 <- get bh - return (IfaceVectInfo a1 a2 a3) + a4 <- get bh + a5 <- get bh + return (IfaceVectInfo a1 a2 a3 a4 a5) +instance Binary IfaceTrustInfo where + put_ bh iftrust = putByte bh $ trustInfoToNum iftrust + get bh = getByte bh >>= (return . numToTrustInfo) diff -Nru ghc-7.0.3/compiler/iface/BuildTyCl.lhs ghc-7.2.1/compiler/iface/BuildTyCl.lhs --- ghc-7.0.3/compiler/iface/BuildTyCl.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/iface/BuildTyCl.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -10,7 +10,8 @@ buildDataCon, TcMethInfo, buildClass, mkAbstractTyConRhs, - mkNewTyConRhs, mkDataTyConRhs + mkNewTyConRhs, mkDataTyConRhs, + newImplicitBinder ) where #include "HsVersions.h" @@ -29,7 +30,7 @@ import Coercion import TcRnMonad -import Data.List ( partition ) +import Util ( isSingleton ) import Outputable \end{code} @@ -59,13 +60,12 @@ -> ThetaType -- ^ Stupid theta -> AlgTyConRhs -> RecFlag - -> Bool -- ^ True <=> want generics functions -> Bool -- ^ True <=> was declared in GADT syntax -> TyConParent -> Maybe (TyCon, [Type]) -- ^ family instance if applicable -> TcRnIf m n TyCon -buildAlgTyCon tc_name tvs stupid_theta rhs is_rec want_generics gadt_syn +buildAlgTyCon tc_name tvs stupid_theta rhs is_rec gadt_syn parent mb_family | Just fam_inst_info <- mb_family = -- We need to tie a knot as the coercion of a data instance depends @@ -74,11 +74,11 @@ fixM $ \ tycon_rec -> do { fam_parent <- mkFamInstParentInfo tc_name tvs fam_inst_info tycon_rec ; return (mkAlgTyCon tc_name kind tvs stupid_theta rhs - fam_parent is_rec want_generics gadt_syn) } + fam_parent is_rec gadt_syn) } | otherwise = return (mkAlgTyCon tc_name kind tvs stupid_theta rhs - parent is_rec want_generics gadt_syn) + parent is_rec gadt_syn) where kind = mkArrowKinds (map tyVarKind tvs) liftedTypeKind @@ -100,8 +100,8 @@ mkFamInstParentInfo tc_name tvs (family, instTys) rep_tycon = do { -- Create the coercion ; co_tycon_name <- newImplicitBinder tc_name mkInstTyCoOcc - ; let co_tycon = mkFamInstCoercion co_tycon_name tvs - family instTys rep_tycon + ; let co_tycon = mkFamInstCo co_tycon_name tvs + family instTys rep_tycon ; return $ FamInstTyCon family instTys co_tycon } ------------------------------------------------------ @@ -127,23 +127,15 @@ -- because the latter is part of a knot, whereas the former is not. mkNewTyConRhs tycon_name tycon con = do { co_tycon_name <- newImplicitBinder tycon_name mkNewTyCoOcc - ; let co_tycon = mkNewTypeCoercion co_tycon_name tycon etad_tvs etad_rhs - cocon_maybe | all_coercions || isRecursiveTyCon tycon - = Just co_tycon - | otherwise - = Nothing - ; traceIf (text "mkNewTyConRhs" <+> ppr cocon_maybe) + ; let co_tycon = mkNewTypeCo co_tycon_name tycon etad_tvs etad_rhs + ; traceIf (text "mkNewTyConRhs" <+> ppr co_tycon) ; return (NewTyCon { data_con = con, nt_rhs = rhs_ty, nt_etad_rhs = (etad_tvs, etad_rhs), - nt_co = cocon_maybe } ) } + nt_co = co_tycon } ) } -- Coreview looks through newtypes with a Nothing -- for nt_co, or uses explicit coercions otherwise where - -- If all_coercions is True then we use coercions for all newtypes - -- otherwise we use coercions for recursive newtypes and look through - -- non-recursive newtypes - all_coercions = True tvs = tyConTyVars tycon inst_con_ty = applyTys (dataConUserType con) (mkTyVarTys tvs) rhs_ty = ASSERT( isFunTy inst_con_ty ) funArgTy inst_con_ty @@ -156,7 +148,7 @@ -- has a single argument (Foo a) that is a *type class*, so -- dataConInstOrigArgTys returns []. - etad_tvs :: [TyVar] -- Matched lazily, so that mkNewTypeCoercion can + etad_tvs :: [TyVar] -- Matched lazily, so that mkNewTypeCo can etad_rhs :: Type -- return a TyCon without pulling on rhs_ty -- See Note [Tricky iface loop] in LoadIface (etad_tvs, etad_rhs) = eta_reduce (reverse tvs) rhs_ty @@ -229,8 +221,9 @@ ------------------------------------------------------ \begin{code} -type TcMethInfo = (Name, DefMethSpec, Type) -- A temporary intermediate, to communicate - -- between tcClassSigs and buildClass +type TcMethInfo = (Name, DefMethSpec, Type) + -- A temporary intermediate, to communicate between + -- tcClassSigs and buildClass. buildClass :: Bool -- True <=> do not include unfoldings -- on dict selectors @@ -255,12 +248,9 @@ ; op_items <- mapM (mk_op_item rec_clas) sig_stuff -- Build the selector id and default method id - ; let (eq_theta, dict_theta) = partition isEqPred sc_theta - - -- We only make selectors for the *value* superclasses, - -- not equality predicates + -- Make selectors for the superclasses ; sc_sel_names <- mapM (newImplicitBinder class_name . mkSuperDictSelOcc) - [1..length dict_theta] + [1..length sc_theta] ; let sc_sel_ids = [ mkDictSelId no_unf sc_name rec_clas | sc_name <- sc_sel_names] -- We number off the Dict superclass selectors, 1, 2, 3 etc so that we @@ -271,22 +261,23 @@ -- (We used to call them D_C, but now we can have two different -- superclasses both called C!) - ; let use_newtype = null eq_theta && (length dict_theta + length sig_stuff == 1) - -- Use a newtype if the data constructor has - -- (a) exactly one value field - -- (b) no existential or equality-predicate fields - -- i.e. exactly one operation or superclass taken together + ; let use_newtype = isSingleton arg_tys && not (any isEqPred sc_theta) + -- Use a newtype if the data constructor + -- (a) has exactly one value field + -- i.e. exactly one operation or superclass taken together + -- (b) it's of lifted type + -- (NB: for (b) don't look at the classes in sc_theta, because + -- they are part of the knot! Hence isEqPred.) -- See note [Class newtypes and equality predicates] - -- We play a bit fast and loose by treating the dictionary - -- superclasses as ordinary arguments. That means that in - -- the case of + -- We treat the dictionary superclasses as ordinary arguments. + -- That means that in the case of -- class C a => D a -- we don't get a newtype with no arguments! args = sc_sel_names ++ op_names op_tys = [ty | (_,_,ty) <- sig_stuff] op_names = [op | (op,_,_) <- sig_stuff] - arg_tys = map mkPredTy dict_theta ++ op_tys + arg_tys = map mkPredTy sc_theta ++ op_tys rec_tycon = classTyCon rec_clas ; dict_con <- buildDataCon datacon_name @@ -295,7 +286,7 @@ [{- No fields -}] tvs [{- no existentials -}] [{- No GADT equalities -}] - eq_theta + [{- No theta -}] arg_tys (mkTyConApp rec_tycon (mkTyVarTys tvs)) rec_tycon @@ -319,9 +310,7 @@ ; atTyCons = [tycon | ATyCon tycon <- ats] ; result = mkClass class_name tvs fds - (eq_theta ++ dict_theta) -- Equalities first - (length eq_theta) -- Number of equalities - sc_sel_ids atTyCons + sc_theta sc_sel_ids atTyCons op_items tycon } ; traceIf (text "buildClass" <+> ppr tycon) @@ -332,7 +321,8 @@ mk_op_item rec_clas (op_name, dm_spec, _) = do { dm_info <- case dm_spec of NoDM -> return NoDefMeth - GenericDM -> return GenDefMeth + GenericDM -> do { dm_name <- newImplicitBinder op_name mkGenDefMethodOcc + ; return (GenDefMeth dm_name) } VanillaDM -> do { dm_name <- newImplicitBinder op_name mkDefaultMethodOcc ; return (DefMeth dm_name) } ; return (mkDictSelId no_unf op_name rec_clas, dm_info) } @@ -345,12 +335,12 @@ op :: a -> b We cannot represent this by a newtype, even though it's not -existential, and there's only one value field, because we do -capture an equality predicate: - - data C a b where - MkC :: forall a b. (a ~ F b) => (a->b) -> C a b +existential, because there are two value fields (the equality +predicate and op. See Trac #2238 -We need to access this equality predicate when we get passes a C -dictionary. See Trac #2238 +Moreover, + class (a ~ F b) => C a b where {} +Here we can't use a newtype either, even though there is only +one field, because equality predicates are unboxed, and classes +are boxed. diff -Nru ghc-7.0.3/compiler/iface/IfaceEnv.lhs ghc-7.2.1/compiler/iface/IfaceEnv.lhs --- ghc-7.0.3/compiler/iface/IfaceEnv.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/iface/IfaceEnv.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -13,7 +13,7 @@ ifaceExportNames, -- Name-cache stuff - allocateGlobalBinder, initNameCache, + allocateGlobalBinder, initNameCache, updNameCache, getNameCache, mkNameCacheUpdater, NameCacheUpdater ) where @@ -98,8 +98,7 @@ -- Build a completely new Name, and put it in the cache Nothing -> (new_name_supply, name) where - (us', us1) = splitUniqSupply (nsUniqs name_supply) - uniq = uniqFromSupply us1 + (uniq, us') = takeUniqFromSupply (nsUniqs name_supply) name = mkExternalName uniq mod occ loc new_cache = extendNameCache (nsNames name_supply) mod occ name new_name_supply = name_supply {nsUniqs = us', nsNames = new_cache} @@ -124,25 +123,7 @@ loc = nameSrcSpan base_name ifaceExportNames :: [IfaceExport] -> TcRnIf gbl lcl [AvailInfo] -ifaceExportNames exports = do - mod_avails <- mapM (\(mod,avails) -> mapM (lookupAvail mod) avails) exports - return (concat mod_avails) - --- Convert OccNames in GenAvailInfo to Names. -lookupAvail :: Module -> GenAvailInfo OccName -> TcRnIf a b AvailInfo -lookupAvail mod (Avail n) = do - n' <- lookupOrig mod n - return (Avail n') -lookupAvail mod (AvailTC p_occ occs) = do - p_name <- lookupOrig mod p_occ - let lookup_sub occ | occ == p_occ = return p_name - | otherwise = lookupOrig mod occ - subs <- mapM lookup_sub occs - return (AvailTC p_name subs) - -- Remember that 'occs' is all the exported things, including - -- the parent. It's possible to export just class ops without - -- the class, which shows up as C( op ) here. If the class was - -- exported too we'd have C( C, op ) +ifaceExportNames exports = return exports lookupOrig :: Module -> OccName -> TcRnIf a b Name lookupOrig mod occ @@ -159,14 +140,12 @@ case lookupOrigNameCache (nsNames name_cache) mod occ of { Just name -> (name_cache, name); Nothing -> - let - us = nsUniqs name_cache - uniq = uniqFromSupply us - name = mkExternalName uniq mod occ noSrcSpan - new_cache = extendNameCache (nsNames name_cache) mod occ name - in - case splitUniqSupply us of { (us',_) -> do - (name_cache{ nsUniqs = us', nsNames = new_cache }, name) + case takeUniqFromSupply (nsUniqs name_cache) of { + (uniq, us) -> + let + name = mkExternalName uniq mod occ noSrcSpan + new_cache = extendNameCache (nsNames name_cache) mod occ name + in (name_cache{ nsUniqs = us, nsNames = new_cache }, name) }}} newIPName :: IPName OccName -> TcRnIf m n (IPName Name) @@ -180,8 +159,7 @@ Just name_ip -> (name_cache, name_ip) Nothing -> (new_ns, name_ip) where - (us', us1) = splitUniqSupply (nsUniqs name_cache) - uniq = uniqFromSupply us1 + (uniq, us') = takeUniqFromSupply (nsUniqs name_cache) name_ip = mapIPName (mkIPName uniq) occ_name_ip new_ipcache = Map.insert key name_ip ipcache new_ns = name_cache {nsUniqs = us', nsIPs = new_ipcache} diff -Nru ghc-7.0.3/compiler/iface/IfaceSyn.lhs ghc-7.2.1/compiler/iface/IfaceSyn.lhs --- ghc-7.0.3/compiler/iface/IfaceSyn.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/iface/IfaceSyn.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -5,34 +5,32 @@ \begin{code} module IfaceSyn ( - module IfaceType, -- Re-export all this + module IfaceType, - IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..), - IfaceExpr(..), IfaceAlt, IfaceNote(..), IfaceLetBndr(..), - IfaceBinding(..), IfaceConAlt(..), - IfaceIdInfo(..), IfaceIdDetails(..), IfaceUnfolding(..), - IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget, - IfaceInst(..), IfaceFamInst(..), + IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceConDecls(..), + IfaceExpr(..), IfaceAlt, IfaceNote(..), IfaceLetBndr(..), + IfaceBinding(..), IfaceConAlt(..), + IfaceIdInfo(..), IfaceIdDetails(..), IfaceUnfolding(..), + IfaceInfoItem(..), IfaceRule(..), IfaceAnnotation(..), IfaceAnnTarget, + IfaceInst(..), IfaceFamInst(..), - -- Misc + -- Misc ifaceDeclSubBndrs, visibleIfConDecls, -- Free Names freeNamesIfDecl, freeNamesIfRule, - -- Pretty printing - pprIfaceExpr, pprIfaceDeclHead + -- Pretty printing + pprIfaceExpr, pprIfaceDeclHead ) where #include "HsVersions.h" import IfaceType -import CoreSyn( DFunArg, dfunArgExprs ) -import PprCore() -- Printing DFunArgs import Demand import Annotations import Class -import NameSet +import NameSet import Name import CostCentre import Literal @@ -48,74 +46,67 @@ %************************************************************************ -%* * - Data type declarations -%* * +%* * + Data type declarations +%* * %************************************************************************ \begin{code} -data IfaceDecl - = IfaceId { ifName :: OccName, - ifType :: IfaceType, - ifIdDetails :: IfaceIdDetails, - ifIdInfo :: IfaceIdInfo } - - | IfaceData { ifName :: OccName, -- Type constructor - ifTyVars :: [IfaceTvBndr], -- Type variables - ifCtxt :: IfaceContext, -- The "stupid theta" - ifCons :: IfaceConDecls, -- Includes new/data info - ifRec :: RecFlag, -- Recursive or not? - ifGadtSyntax :: Bool, -- True <=> declared using - -- GADT syntax - ifGeneric :: Bool, -- True <=> generic converter - -- functions available - -- We need this for imported - -- data decls, since the - -- imported modules may have - -- been compiled with - -- different flags to the - -- current compilation unit +data IfaceDecl + = IfaceId { ifName :: OccName, + ifType :: IfaceType, + ifIdDetails :: IfaceIdDetails, + ifIdInfo :: IfaceIdInfo } + + | IfaceData { ifName :: OccName, -- Type constructor + ifTyVars :: [IfaceTvBndr], -- Type variables + ifCtxt :: IfaceContext, -- The "stupid theta" + ifCons :: IfaceConDecls, -- Includes new/data info + ifRec :: RecFlag, -- Recursive or not? + ifGadtSyntax :: Bool, -- True <=> declared using + -- GADT syntax ifFamInst :: Maybe (IfaceTyCon, [IfaceType]) -- Just <=> instance of family - -- Invariant: + -- Invariant: -- ifCons /= IfOpenDataTyCon -- for family instances } - | IfaceSyn { ifName :: OccName, -- Type constructor - ifTyVars :: [IfaceTvBndr], -- Type variables - ifSynKind :: IfaceKind, -- Kind of the *rhs* (not of the tycon) - ifSynRhs :: Maybe IfaceType, -- Just rhs for an ordinary synonyn - -- Nothing for an open family + | IfaceSyn { ifName :: OccName, -- Type constructor + ifTyVars :: [IfaceTvBndr], -- Type variables + ifSynKind :: IfaceKind, -- Kind of the *rhs* (not of the tycon) + ifSynRhs :: Maybe IfaceType, -- Just rhs for an ordinary synonyn + -- Nothing for an open family ifFamInst :: Maybe (IfaceTyCon, [IfaceType]) -- Just <=> instance of family -- Invariant: ifOpenSyn == False -- for family instances } - | IfaceClass { ifCtxt :: IfaceContext, -- Context... - ifName :: OccName, -- Name of the class - ifTyVars :: [IfaceTvBndr], -- Type variables - ifFDs :: [FunDep FastString], -- Functional dependencies - ifATs :: [IfaceDecl], -- Associated type families - ifSigs :: [IfaceClassOp], -- Method signatures - ifRec :: RecFlag -- Is newtype/datatype associated with the class recursive? + | IfaceClass { ifCtxt :: IfaceContext, -- Context... + ifName :: OccName, -- Name of the class + ifTyVars :: [IfaceTvBndr], -- Type variables + ifFDs :: [FunDep FastString], -- Functional dependencies + ifATs :: [IfaceDecl], -- Associated type families + ifSigs :: [IfaceClassOp], -- Method signatures + ifRec :: RecFlag -- Is newtype/datatype associated + -- with the class recursive? } | IfaceForeign { ifName :: OccName, -- Needs expanding when we move -- beyond .NET - ifExtName :: Maybe FastString } + ifExtName :: Maybe FastString } data IfaceClassOp = IfaceClassOp OccName DefMethSpec IfaceType - -- Nothing => no default method - -- Just False => ordinary polymorphic default method - -- Just True => generic default method + -- Nothing => no default method + -- Just False => ordinary polymorphic default method + -- Just True => generic default method data IfaceConDecls - = IfAbstractTyCon -- No info - | IfOpenDataTyCon -- Open data family - | IfDataTyCon [IfaceConDecl] -- data type decls - | IfNewTyCon IfaceConDecl -- newtype decls + = IfAbstractTyCon -- No info + | IfOpenDataTyCon -- Open data family + | IfDataTyCon [IfaceConDecl] -- data type decls + | IfNewTyCon IfaceConDecl -- newtype decls visibleIfConDecls :: IfaceConDecls -> [IfaceConDecl] visibleIfConDecls IfAbstractTyCon = [] @@ -123,49 +114,49 @@ visibleIfConDecls (IfDataTyCon cs) = cs visibleIfConDecls (IfNewTyCon c) = [c] -data IfaceConDecl +data IfaceConDecl = IfCon { - ifConOcc :: OccName, -- Constructor name - ifConWrapper :: Bool, -- True <=> has a wrapper - ifConInfix :: Bool, -- True <=> declared infix - ifConUnivTvs :: [IfaceTvBndr], -- Universal tyvars - ifConExTvs :: [IfaceTvBndr], -- Existential tyvars - ifConEqSpec :: [(OccName,IfaceType)], -- Equality contraints - ifConCtxt :: IfaceContext, -- Non-stupid context - ifConArgTys :: [IfaceType], -- Arg types - ifConFields :: [OccName], -- ...ditto... (field labels) - ifConStricts :: [HsBang]} -- Empty (meaning all lazy), - -- or 1-1 corresp with arg tys - -data IfaceInst - = IfaceInst { ifInstCls :: IfExtName, -- See comments with - ifInstTys :: [Maybe IfaceTyCon], -- the defn of Instance - ifDFun :: IfExtName, -- The dfun - ifOFlag :: OverlapFlag, -- Overlap flag - ifInstOrph :: Maybe OccName } -- See Note [Orphans] - -- There's always a separate IfaceDecl for the DFun, which gives - -- its IdInfo with its full type and version number. - -- The instance declarations taken together have a version number, - -- and we don't want that to wobble gratuitously - -- If this instance decl is *used*, we'll record a usage on the dfun; - -- and if the head does not change it won't be used if it wasn't before + ifConOcc :: OccName, -- Constructor name + ifConWrapper :: Bool, -- True <=> has a wrapper + ifConInfix :: Bool, -- True <=> declared infix + ifConUnivTvs :: [IfaceTvBndr], -- Universal tyvars + ifConExTvs :: [IfaceTvBndr], -- Existential tyvars + ifConEqSpec :: [(OccName,IfaceType)], -- Equality contraints + ifConCtxt :: IfaceContext, -- Non-stupid context + ifConArgTys :: [IfaceType], -- Arg types + ifConFields :: [OccName], -- ...ditto... (field labels) + ifConStricts :: [HsBang]} -- Empty (meaning all lazy), + -- or 1-1 corresp with arg tys + +data IfaceInst + = IfaceInst { ifInstCls :: IfExtName, -- See comments with + ifInstTys :: [Maybe IfaceTyCon], -- the defn of Instance + ifDFun :: IfExtName, -- The dfun + ifOFlag :: OverlapFlag, -- Overlap flag + ifInstOrph :: Maybe OccName } -- See Note [Orphans] + -- There's always a separate IfaceDecl for the DFun, which gives + -- its IdInfo with its full type and version number. + -- The instance declarations taken together have a version number, + -- and we don't want that to wobble gratuitously + -- If this instance decl is *used*, we'll record a usage on the dfun; + -- and if the head does not change it won't be used if it wasn't before data IfaceFamInst = IfaceFamInst { ifFamInstFam :: IfExtName -- Family tycon - , ifFamInstTys :: [Maybe IfaceTyCon] -- Rough match types - , ifFamInstTyCon :: IfaceTyCon -- Instance decl - } + , ifFamInstTys :: [Maybe IfaceTyCon] -- Rough match types + , ifFamInstTyCon :: IfaceTyCon -- Instance decl + } data IfaceRule - = IfaceRule { - ifRuleName :: RuleName, - ifActivation :: Activation, - ifRuleBndrs :: [IfaceBndr], -- Tyvars and term vars - ifRuleHead :: IfExtName, -- Head of lhs - ifRuleArgs :: [IfaceExpr], -- Args of LHS - ifRuleRhs :: IfaceExpr, - ifRuleAuto :: Bool, - ifRuleOrph :: Maybe OccName -- Just like IfaceInst + = IfaceRule { + ifRuleName :: RuleName, + ifActivation :: Activation, + ifRuleBndrs :: [IfaceBndr], -- Tyvars and term vars + ifRuleHead :: IfExtName, -- Head of lhs + ifRuleArgs :: [IfaceExpr], -- Args of LHS + ifRuleRhs :: IfaceExpr, + ifRuleAuto :: Bool, + ifRuleOrph :: Maybe OccName -- Just like IfaceInst } data IfaceAnnotation @@ -184,83 +175,84 @@ data IfaceIdDetails = IfVanillaId | IfRecSelId IfaceTyCon Bool - | IfDFunId Int -- Number of silent args + | IfDFunId data IfaceIdInfo - = NoInfo -- When writing interface file without -O - | HasInfo [IfaceInfoItem] -- Has info, and here it is + = NoInfo -- When writing interface file without -O + | HasInfo [IfaceInfoItem] -- Has info, and here it is -- Here's a tricky case: -- * Compile with -O module A, and B which imports A.f -- * Change function f in A, and recompile without -O -- * When we read in old A.hi we read in its IdInfo (as a thunk) --- (In earlier GHCs we used to drop IdInfo immediately on reading, --- but we do not do that now. Instead it's discarded when the --- ModIface is read into the various decl pools.) +-- (In earlier GHCs we used to drop IdInfo immediately on reading, +-- but we do not do that now. Instead it's discarded when the +-- ModIface is read into the various decl pools.) -- * The version comparsion sees that new (=NoInfo) differs from old (=HasInfo *) --- and so gives a new version. +-- and so gives a new version. data IfaceInfoItem - = HsArity Arity + = HsArity Arity | HsStrictness StrictSig | HsInline InlinePragma - | HsUnfold Bool -- True <=> isNonRuleLoopBreaker is true - IfaceUnfolding -- See Note [Expose recursive functions] + | HsUnfold Bool -- True <=> isStrongLoopBreaker is true + IfaceUnfolding -- See Note [Expose recursive functions] | HsNoCafRefs -- NB: Specialisations and rules come in separately and are -- only later attached to the Id. Partial reason: some are orphans. -data IfaceUnfolding +data IfaceUnfolding = IfCoreUnfold Bool IfaceExpr -- True <=> INLINABLE, False <=> regular unfolding -- Possibly could eliminate the Bool here, the information -- is also in the InlinePragma. - | IfCompulsory IfaceExpr -- Only used for default methods, in fact + | IfCompulsory IfaceExpr -- Only used for default methods, in fact | IfInlineRule Arity -- INLINE pragmas - Bool -- OK to inline even if *un*-saturated - Bool -- OK to inline even if context is boring - IfaceExpr - - | IfExtWrapper Arity IfExtName -- NB: sometimes we need a IfExtName (not just IfLclName) - | IfLclWrapper Arity IfLclName -- because the worker can simplify to a function in - -- another module. + Bool -- OK to inline even if *un*-saturated + Bool -- OK to inline even if context is boring + IfaceExpr + + | IfExtWrapper Arity IfExtName -- NB: sometimes we need a IfExtName (not just IfLclName) + | IfLclWrapper Arity IfLclName -- because the worker can simplify to a function in + -- another module. - | IfDFunUnfold [DFunArg IfaceExpr] + | IfDFunUnfold [IfaceExpr] -------------------------------- data IfaceExpr - = IfaceLcl IfLclName + = IfaceLcl IfLclName | IfaceExt IfExtName | IfaceType IfaceType - | IfaceTuple Boxity [IfaceExpr] -- Saturated; type arguments omitted + | IfaceCo IfaceType -- We re-use IfaceType for coercions + | IfaceTuple Boxity [IfaceExpr] -- Saturated; type arguments omitted | IfaceLam IfaceBndr IfaceExpr | IfaceApp IfaceExpr IfaceExpr - | IfaceCase IfaceExpr IfLclName IfaceType [IfaceAlt] + | IfaceCase IfaceExpr IfLclName [IfaceAlt] | IfaceLet IfaceBinding IfaceExpr | IfaceNote IfaceNote IfaceExpr | IfaceCast IfaceExpr IfaceCoercion - | IfaceLit Literal - | IfaceFCall ForeignCall IfaceType + | IfaceLit Literal + | IfaceFCall ForeignCall IfaceType | IfaceTick Module Int data IfaceNote = IfaceSCC CostCentre | IfaceCoreNote String type IfaceAlt = (IfaceConAlt, [IfLclName], IfaceExpr) - -- Note: IfLclName, not IfaceBndr (and same with the case binder) - -- We reconstruct the kind/type of the thing from the context - -- thus saving bulk in interface files + -- Note: IfLclName, not IfaceBndr (and same with the case binder) + -- We reconstruct the kind/type of the thing from the context + -- thus saving bulk in interface files data IfaceConAlt = IfaceDefault - | IfaceDataAlt IfExtName - | IfaceTupleAlt Boxity - | IfaceLitAlt Literal + | IfaceDataAlt IfExtName + | IfaceTupleAlt Boxity + | IfaceLitAlt Literal data IfaceBinding - = IfaceNonRec IfaceLetBndr IfaceExpr - | IfaceRec [(IfaceLetBndr, IfaceExpr)] + = IfaceNonRec IfaceLetBndr IfaceExpr + | IfaceRec [(IfaceLetBndr, IfaceExpr)] -- IfaceLetBndr is like IfaceIdBndr, but has IdInfo too -- It's used for *non-top-level* let/rec binders @@ -288,7 +280,15 @@ Note [Orphans]: the ifInstOrph and ifRuleOrph fields ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If a module contains any "orphans", then its interface file is read -regardless, so that its instances are not missed. +regardless, so that its instances are not missed. + + - If an instance is an orphan its ifInstOprh field is Nothing + Otherwise ifInstOrph is (Just n) where n is the Name of a + local class or tycon that witnesses its non-orphan-hood. + This computation is done by MkIface.instanceToIfaceInst + + - Similarly for ifRuleOrph + The computation is done by MkIface.coreRuleToIfaceRule Roughly speaking, an instance is an orphan if its head (after the =>) mentions nothing defined in this module. Functional dependencies @@ -299,9 +299,9 @@ and suppose we are compiling module X: module X where - import M - data T = ... - instance C Int T where ... + import M + data T = ... + instance C Int T where ... This instance is an orphan, because when compiling a third module Y we might get a constraint (C Int v), and we'd want to improve v to T. So @@ -315,50 +315,14 @@ If there are fundeps, then for every fundep, at least one of the names free in a *non-determined* part of the instance head is - defined in this module. + defined in this module. (Note that these conditions hold trivially if the class is locally defined.) Note [Versioning of instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Now consider versioning. If we *use* an instance decl in one compilation, -we'll depend on the dfun id for that instance, so we'll recompile if it changes. -But suppose we *don't* (currently) use an instance! We must recompile if -the instance is changed in such a way that it becomes important. (This would -only matter with overlapping instances, else the importing module wouldn't have -compiled before and the recompilation check is irrelevant.) - -The is_orph field is set to (Just n) if the instance is not an orphan. -The 'n' is *any* of the locally-defined names mentioned anywhere in the -instance head. This name is used for versioning; the instance decl is -considered part of the defn of this 'n'. - -I'm worried about whether this works right if we pick a name from -a functionally-dependent part of the instance decl. E.g. - - module M where { class C a b | a -> b } - -and suppose we are compiling module X: - - module X where - import M - data S = ... - data T = ... - instance C S T where ... - -If we base the instance verion on T, I'm worried that changing S to S' -would change T's version, but not S or S'. But an importing module might -not depend on T, and so might not be recompiled even though the new instance -(C S' T) might be relevant. I have not been able to make a concrete example, -and it seems deeply obscure, so I'm going to leave it for now. - - -Note [Versioning of rules] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -A rule that is not an orphan has an ifRuleOrph field of (Just n), where -n appears on the LHS of the rule; any change in the rule changes the version of n. - +See [http://hackage.haskell.org/trac/ghc/wiki/Commentary/Compiler/RecompilationAvoidance#Instances] \begin{code} -- ----------------------------------------------------------------------------- @@ -380,7 +344,7 @@ ifaceDeclSubBndrs (IfaceData {ifName = tc_occ, ifCons = IfNewTyCon ( IfCon { ifConOcc = con_occ }), - ifFamInst = famInst}) + ifFamInst = famInst}) = -- implicit coerion and (possibly) family instance coercion (mkNewTyCoOcc tc_occ) : (famInstCo famInst tc_occ) ++ -- data constructor and worker (newtypes don't have a wrapper) @@ -388,8 +352,8 @@ ifaceDeclSubBndrs (IfaceData {ifName = tc_occ, - ifCons = IfDataTyCon cons, - ifFamInst = famInst}) + ifCons = IfDataTyCon cons, + ifFamInst = famInst}) = -- (possibly) family instance coercion; -- there is no implicit coercion for non-newtypes famInstCo famInst tc_occ @@ -398,20 +362,20 @@ ++ concatMap dc_occs cons where dc_occs con_decl - | has_wrapper = [con_occ, work_occ, wrap_occ] - | otherwise = [con_occ, work_occ] - where - con_occ = ifConOcc con_decl -- DataCon namespace - wrap_occ = mkDataConWrapperOcc con_occ -- Id namespace - work_occ = mkDataConWorkerOcc con_occ -- Id namespace - has_wrapper = ifConWrapper con_decl -- This is the reason for - -- having the ifConWrapper field! + | has_wrapper = [con_occ, work_occ, wrap_occ] + | otherwise = [con_occ, work_occ] + where + con_occ = ifConOcc con_decl -- DataCon namespace + wrap_occ = mkDataConWrapperOcc con_occ -- Id namespace + work_occ = mkDataConWorkerOcc con_occ -- Id namespace + has_wrapper = ifConWrapper con_decl -- This is the reason for + -- having the ifConWrapper field! -ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ, - ifSigs = sigs, ifATs = ats }) +ifaceDeclSubBndrs (IfaceClass {ifCtxt = sc_ctxt, ifName = cls_occ, + ifSigs = sigs, ifATs = ats }) = -- dictionary datatype: -- type constructor - tc_occ : + tc_occ : -- (possibly) newtype coercion co_occs ++ -- data constructor (DataCon namespace) @@ -428,14 +392,14 @@ n_ctxt = length sc_ctxt n_sigs = length sigs tc_occ = mkClassTyConOcc cls_occ - dc_occ = mkClassDataConOcc cls_occ + dc_occ = mkClassDataConOcc cls_occ co_occs | is_newtype = [mkNewTyCoOcc tc_occ] - | otherwise = [] + | otherwise = [] dcww_occ = mkDataConWorkerOcc dc_occ - is_newtype = n_sigs + n_ctxt == 1 -- Sigh + is_newtype = n_sigs + n_ctxt == 1 -- Sigh ifaceDeclSubBndrs (IfaceSyn {ifName = tc_occ, - ifFamInst = famInst}) + ifFamInst = famInst}) = famInstCo famInst tc_occ ifaceDeclSubBndrs _ = [] @@ -451,54 +415,50 @@ ppr = pprIfaceDecl pprIfaceDecl :: IfaceDecl -> SDoc -pprIfaceDecl (IfaceId {ifName = var, ifType = ty, +pprIfaceDecl (IfaceId {ifName = var, ifType = ty, ifIdDetails = details, ifIdInfo = info}) - = sep [ ppr var <+> dcolon <+> ppr ty, - nest 2 (ppr details), - nest 2 (ppr info) ] + = sep [ ppr var <+> dcolon <+> ppr ty, + nest 2 (ppr details), + nest 2 (ppr info) ] pprIfaceDecl (IfaceForeign {ifName = tycon}) = hsep [ptext (sLit "foreign import type dotnet"), ppr tycon] -pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, - ifSynRhs = Just mono_ty, +pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, + ifSynRhs = Just mono_ty, ifFamInst = mbFamInst}) = hang (ptext (sLit "type") <+> pprIfaceDeclHead [] tycon tyvars) 4 (vcat [equals <+> ppr mono_ty, pprFamily mbFamInst]) -pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, - ifSynRhs = Nothing, ifSynKind = kind }) +pprIfaceDecl (IfaceSyn {ifName = tycon, ifTyVars = tyvars, + ifSynRhs = Nothing, ifSynKind = kind }) = hang (ptext (sLit "type family") <+> pprIfaceDeclHead [] tycon tyvars) 4 (dcolon <+> ppr kind) -pprIfaceDecl (IfaceData {ifName = tycon, ifGeneric = gen, ifCtxt = context, - ifTyVars = tyvars, ifCons = condecls, - ifRec = isrec, ifFamInst = mbFamInst}) +pprIfaceDecl (IfaceData {ifName = tycon, ifCtxt = context, + ifTyVars = tyvars, ifCons = condecls, + ifRec = isrec, ifFamInst = mbFamInst}) = hang (pp_nd <+> pprIfaceDeclHead context tycon tyvars) - 4 (vcat [pprRec isrec, pprGen gen, pp_condecls tycon condecls, - pprFamily mbFamInst]) + 4 (vcat [pprRec isrec, pp_condecls tycon condecls, + pprFamily mbFamInst]) where pp_nd = case condecls of - IfAbstractTyCon -> ptext (sLit "data") - IfOpenDataTyCon -> ptext (sLit "data family") - IfDataTyCon _ -> ptext (sLit "data") - IfNewTyCon _ -> ptext (sLit "newtype") - -pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars, - ifFDs = fds, ifATs = ats, ifSigs = sigs, - ifRec = isrec}) + IfAbstractTyCon -> ptext (sLit "data") + IfOpenDataTyCon -> ptext (sLit "data family") + IfDataTyCon _ -> ptext (sLit "data") + IfNewTyCon _ -> ptext (sLit "newtype") + +pprIfaceDecl (IfaceClass {ifCtxt = context, ifName = clas, ifTyVars = tyvars, + ifFDs = fds, ifATs = ats, ifSigs = sigs, + ifRec = isrec}) = hang (ptext (sLit "class") <+> pprIfaceDeclHead context clas tyvars <+> pprFundeps fds) 4 (vcat [pprRec isrec, - sep (map ppr ats), - sep (map ppr sigs)]) + sep (map ppr ats), + sep (map ppr sigs)]) pprRec :: RecFlag -> SDoc pprRec isrec = ptext (sLit "RecFlag") <+> ppr isrec -pprGen :: Bool -> SDoc -pprGen True = ptext (sLit "Generics: yes") -pprGen False = ptext (sLit "Generics: no") - pprFamily :: Maybe (IfaceTyCon, [IfaceType]) -> SDoc pprFamily Nothing = ptext (sLit "FamilyInstance: none") pprFamily (Just famInst) = ptext (sLit "FamilyInstance:") <+> ppr famInst @@ -508,68 +468,68 @@ pprIfaceDeclHead :: IfaceContext -> OccName -> [IfaceTvBndr] -> SDoc pprIfaceDeclHead context thing tyvars - = hsep [pprIfaceContext context, parenSymOcc thing (ppr thing), - pprIfaceTvBndrs tyvars] + = hsep [pprIfaceContext context, parenSymOcc thing (ppr thing), + pprIfaceTvBndrs tyvars] pp_condecls :: OccName -> IfaceConDecls -> SDoc pp_condecls _ IfAbstractTyCon = ptext (sLit "{- abstract -}") pp_condecls tc (IfNewTyCon c) = equals <+> pprIfaceConDecl tc c pp_condecls _ IfOpenDataTyCon = empty pp_condecls tc (IfDataTyCon cs) = equals <+> sep (punctuate (ptext (sLit " |")) - (map (pprIfaceConDecl tc) cs)) + (map (pprIfaceConDecl tc) cs)) pprIfaceConDecl :: OccName -> IfaceConDecl -> SDoc pprIfaceConDecl tc - (IfCon { ifConOcc = name, ifConInfix = is_infix, ifConWrapper = has_wrap, - ifConUnivTvs = univ_tvs, ifConExTvs = ex_tvs, - ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys, - ifConStricts = strs, ifConFields = fields }) + (IfCon { ifConOcc = name, ifConInfix = is_infix, ifConWrapper = has_wrap, + ifConUnivTvs = univ_tvs, ifConExTvs = ex_tvs, + ifConEqSpec = eq_spec, ifConCtxt = ctxt, ifConArgTys = arg_tys, + ifConStricts = strs, ifConFields = fields }) = sep [main_payload, - if is_infix then ptext (sLit "Infix") else empty, - if has_wrap then ptext (sLit "HasWrapper") else empty, - ppUnless (null strs) $ - nest 4 (ptext (sLit "Stricts:") <+> hsep (map ppr_bang strs)), - ppUnless (null fields) $ - nest 4 (ptext (sLit "Fields:") <+> hsep (map ppr fields))] + if is_infix then ptext (sLit "Infix") else empty, + if has_wrap then ptext (sLit "HasWrapper") else empty, + ppUnless (null strs) $ + nest 4 (ptext (sLit "Stricts:") <+> hsep (map ppr_bang strs)), + ppUnless (null fields) $ + nest 4 (ptext (sLit "Fields:") <+> hsep (map ppr fields))] where - ppr_bang HsNoBang = char '_' -- Want to see these + ppr_bang HsNoBang = char '_' -- Want to see these ppr_bang bang = ppr bang - - main_payload = ppr name <+> dcolon <+> - pprIfaceForAllPart (univ_tvs ++ ex_tvs) (eq_ctxt ++ ctxt) pp_tau - eq_ctxt = [(IfaceEqPred (IfaceTyVar (occNameFS tv)) ty) - | (tv,ty) <- eq_spec] + main_payload = ppr name <+> dcolon <+> + pprIfaceForAllPart (univ_tvs ++ ex_tvs) (eq_ctxt ++ ctxt) pp_tau + + eq_ctxt = [(IfaceEqPred (IfaceTyVar (occNameFS tv)) ty) + | (tv,ty) <- eq_spec] - -- A bit gruesome this, but we can't form the full con_tau, and ppr it, - -- because we don't have a Name for the tycon, only an OccName + -- A bit gruesome this, but we can't form the full con_tau, and ppr it, + -- because we don't have a Name for the tycon, only an OccName pp_tau = case map pprParendIfaceType arg_tys ++ [pp_res_ty] of - (t:ts) -> fsep (t : map (arrow <+>) ts) - [] -> panic "pp_con_taus" + (t:ts) -> fsep (t : map (arrow <+>) ts) + [] -> panic "pp_con_taus" pp_res_ty = ppr tc <+> fsep [ppr tv | (tv,_) <- univ_tvs] instance Outputable IfaceRule where ppr (IfaceRule { ifRuleName = name, ifActivation = act, ifRuleBndrs = bndrs, - ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs }) + ifRuleHead = fn, ifRuleArgs = args, ifRuleRhs = rhs }) = sep [hsep [doubleQuotes (ftext name), ppr act, - ptext (sLit "forall") <+> pprIfaceBndrs bndrs], - nest 2 (sep [ppr fn <+> sep (map pprParendIfaceExpr args), - ptext (sLit "=") <+> ppr rhs]) + ptext (sLit "forall") <+> pprIfaceBndrs bndrs], + nest 2 (sep [ppr fn <+> sep (map pprParendIfaceExpr args), + ptext (sLit "=") <+> ppr rhs]) ] instance Outputable IfaceInst where - ppr (IfaceInst {ifDFun = dfun_id, ifOFlag = flag, - ifInstCls = cls, ifInstTys = mb_tcs}) - = hang (ptext (sLit "instance") <+> ppr flag - <+> ppr cls <+> brackets (pprWithCommas ppr_rough mb_tcs)) + ppr (IfaceInst {ifDFun = dfun_id, ifOFlag = flag, + ifInstCls = cls, ifInstTys = mb_tcs}) + = hang (ptext (sLit "instance") <+> ppr flag + <+> ppr cls <+> brackets (pprWithCommas ppr_rough mb_tcs)) 2 (equals <+> ppr dfun_id) instance Outputable IfaceFamInst where ppr (IfaceFamInst {ifFamInstFam = fam, ifFamInstTys = mb_tcs, - ifFamInstTyCon = tycon_id}) - = hang (ptext (sLit "family instance") <+> - ppr fam <+> brackets (pprWithCommas ppr_rough mb_tcs)) + ifFamInstTyCon = tycon_id}) + = hang (ptext (sLit "family instance") <+> + ppr fam <+> brackets (pprWithCommas ppr_rough mb_tcs)) 2 (equals <+> ppr tycon_id) ppr_rough :: Maybe IfaceTyCon -> SDoc @@ -587,9 +547,11 @@ pprParendIfaceExpr :: IfaceExpr -> SDoc pprParendIfaceExpr = pprIfaceExpr parens +-- | Pretty Print an IfaceExpre +-- +-- The first argument should be a function that adds parens in context that need +-- an atomic value (e.g. function args) pprIfaceExpr :: (SDoc -> SDoc) -> IfaceExpr -> SDoc - -- The function adds parens in context that need - -- an atomic value (e.g. function args) pprIfaceExpr _ (IfaceLcl v) = ppr v pprIfaceExpr _ (IfaceExt v) = ppr v @@ -597,104 +559,112 @@ pprIfaceExpr _ (IfaceFCall cc ty) = braces (ppr cc <+> ppr ty) pprIfaceExpr _ (IfaceTick m ix) = braces (text "tick" <+> ppr m <+> ppr ix) pprIfaceExpr _ (IfaceType ty) = char '@' <+> pprParendIfaceType ty +pprIfaceExpr _ (IfaceCo co) = text "@~" <+> pprParendIfaceType co pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app []) pprIfaceExpr _ (IfaceTuple c as) = tupleParens c (interpp'SP as) -pprIfaceExpr add_par e@(IfaceLam _ _) +pprIfaceExpr add_par i@(IfaceLam _ _) = add_par (sep [char '\\' <+> sep (map ppr bndrs) <+> arrow, - pprIfaceExpr noParens body]) - where - (bndrs,body) = collect [] e + pprIfaceExpr noParens body]) + where + (bndrs,body) = collect [] i collect bs (IfaceLam b e) = collect (b:bs) e collect bs e = (reverse bs, e) -pprIfaceExpr add_par (IfaceCase scrut bndr ty [(con, bs, rhs)]) - = add_par (sep [ptext (sLit "case") <+> char '@' <+> pprParendIfaceType ty +pprIfaceExpr add_par (IfaceCase scrut bndr [(con, bs, rhs)]) + = add_par (sep [ptext (sLit "case") <+> pprIfaceExpr noParens scrut <+> ptext (sLit "of") <+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow, pprIfaceExpr noParens rhs <+> char '}']) -pprIfaceExpr add_par (IfaceCase scrut bndr ty alts) - = add_par (sep [ptext (sLit "case") <+> char '@' <+> pprParendIfaceType ty +pprIfaceExpr add_par (IfaceCase scrut bndr alts) + = add_par (sep [ptext (sLit "case") <+> pprIfaceExpr noParens scrut <+> ptext (sLit "of") <+> ppr bndr <+> char '{', nest 2 (sep (map ppr_alt alts)) <+> char '}']) pprIfaceExpr _ (IfaceCast expr co) = sep [pprParendIfaceExpr expr, - nest 2 (ptext (sLit "`cast`")), - pprParendIfaceType co] + nest 2 (ptext (sLit "`cast`")), + pprParendIfaceType co] pprIfaceExpr add_par (IfaceLet (IfaceNonRec b rhs) body) - = add_par (sep [ptext (sLit "let {"), - nest 2 (ppr_bind (b, rhs)), - ptext (sLit "} in"), - pprIfaceExpr noParens body]) + = add_par (sep [ptext (sLit "let {"), + nest 2 (ppr_bind (b, rhs)), + ptext (sLit "} in"), + pprIfaceExpr noParens body]) pprIfaceExpr add_par (IfaceLet (IfaceRec pairs) body) = add_par (sep [ptext (sLit "letrec {"), - nest 2 (sep (map ppr_bind pairs)), - ptext (sLit "} in"), - pprIfaceExpr noParens body]) + nest 2 (sep (map ppr_bind pairs)), + ptext (sLit "} in"), + pprIfaceExpr noParens body]) -pprIfaceExpr add_par (IfaceNote note body) = add_par (ppr note <+> pprParendIfaceExpr body) +pprIfaceExpr add_par (IfaceNote note body) = add_par $ ppr note + <+> pprParendIfaceExpr body ppr_alt :: (IfaceConAlt, [IfLclName], IfaceExpr) -> SDoc -ppr_alt (con, bs, rhs) = sep [ppr_con_bs con bs, - arrow <+> pprIfaceExpr noParens rhs] +ppr_alt (con, bs, rhs) = sep [ppr_con_bs con bs, + arrow <+> pprIfaceExpr noParens rhs] ppr_con_bs :: IfaceConAlt -> [IfLclName] -> SDoc ppr_con_bs (IfaceTupleAlt tup_con) bs = tupleParens tup_con (interpp'SP bs) -ppr_con_bs con bs = ppr con <+> hsep (map ppr bs) - +ppr_con_bs con bs = ppr con <+> hsep (map ppr bs) + ppr_bind :: (IfaceLetBndr, IfaceExpr) -> SDoc -ppr_bind (IfLetBndr b ty info, rhs) +ppr_bind (IfLetBndr b ty info, rhs) = sep [hang (ppr b <+> dcolon <+> ppr ty) 2 (ppr info), - equals <+> pprIfaceExpr noParens rhs] + equals <+> pprIfaceExpr noParens rhs] ------------------ pprIfaceApp :: IfaceExpr -> [SDoc] -> SDoc -pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun (nest 2 (pprParendIfaceExpr arg) : args) -pprIfaceApp fun args = sep (pprParendIfaceExpr fun : args) +pprIfaceApp (IfaceApp fun arg) args = pprIfaceApp fun $ + nest 2 (pprParendIfaceExpr arg) : args +pprIfaceApp fun args = sep (pprParendIfaceExpr fun : args) ------------------ instance Outputable IfaceNote where ppr (IfaceSCC cc) = pprCostCentreCore cc - ppr (IfaceCoreNote s) = ptext (sLit "__core_note") <+> pprHsString (mkFastString s) + ppr (IfaceCoreNote s) = ptext (sLit "__core_note") + <+> pprHsString (mkFastString s) instance Outputable IfaceConAlt where ppr IfaceDefault = text "DEFAULT" ppr (IfaceLitAlt l) = ppr l ppr (IfaceDataAlt d) = ppr d - ppr (IfaceTupleAlt _) = panic "ppr IfaceConAlt" + ppr (IfaceTupleAlt _) = panic "ppr IfaceConAlt" -- IfaceTupleAlt is handled by the case-alternative printer ------------------ instance Outputable IfaceIdDetails where - ppr IfVanillaId = empty + ppr IfVanillaId = empty ppr (IfRecSelId tc b) = ptext (sLit "RecSel") <+> ppr tc - <+> if b then ptext (sLit "") else empty - ppr (IfDFunId ns) = ptext (sLit "DFunId") <> brackets (int ns) + <+> if b then ptext (sLit "") else empty + ppr IfDFunId = ptext (sLit "DFunId") instance Outputable IfaceIdInfo where ppr NoInfo = empty - ppr (HasInfo is) = ptext (sLit "{-") <+> pprWithCommas ppr is <+> ptext (sLit "-}") + ppr (HasInfo is) = ptext (sLit "{-") <+> pprWithCommas ppr is + <+> ptext (sLit "-}") instance Outputable IfaceInfoItem where - ppr (HsUnfold lb unf) = ptext (sLit "Unfolding") <> ppWhen lb (ptext (sLit "(loop-breaker)")) + ppr (HsUnfold lb unf) = ptext (sLit "Unfolding") + <> ppWhen lb (ptext (sLit "(loop-breaker)")) <> colon <+> ppr unf ppr (HsInline prag) = ptext (sLit "Inline:") <+> ppr prag ppr (HsArity arity) = ptext (sLit "Arity:") <+> int arity ppr (HsStrictness str) = ptext (sLit "Strictness:") <+> pprIfaceStrictSig str - ppr HsNoCafRefs = ptext (sLit "HasNoCafRefs") + ppr HsNoCafRefs = ptext (sLit "HasNoCafRefs") instance Outputable IfaceUnfolding where ppr (IfCompulsory e) = ptext (sLit "") <+> parens (ppr e) - ppr (IfCoreUnfold s e) = (if s then ptext (sLit "") else empty) <+> parens (ppr e) - ppr (IfInlineRule a uok bok e) = sep [ptext (sLit "InlineRule") <+> ppr (a,uok,bok), - pprParendIfaceExpr e] + ppr (IfCoreUnfold s e) = (if s then ptext (sLit "") else empty) + <+> parens (ppr e) + ppr (IfInlineRule a uok bok e) = sep [ptext (sLit "InlineRule") + <+> ppr (a,uok,bok), + pprParendIfaceExpr e] ppr (IfLclWrapper a wkr) = ptext (sLit "Worker(lcl):") <+> ppr wkr <+> parens (ptext (sLit "arity") <+> int a) ppr (IfExtWrapper a wkr) = ptext (sLit "Worker(ext0:") <+> ppr wkr @@ -703,7 +673,7 @@ <+> brackets (pprWithCommas ppr ns) -- ----------------------------------------------------------------------------- --- Finding the Names in IfaceSyn +-- | Finding the Names in IfaceSyn -- This is used for dependency analysis in MkIface, so that we -- fingerprint a declaration before the things that depend on it. It @@ -713,11 +683,11 @@ -- fingerprinting the instance, so DFuns are not dependencies. freeNamesIfDecl :: IfaceDecl -> NameSet -freeNamesIfDecl (IfaceId _s t d i) = +freeNamesIfDecl (IfaceId _s t d i) = freeNamesIfType t &&& freeNamesIfIdInfo i &&& freeNamesIfIdDetails d -freeNamesIfDecl IfaceForeign{} = +freeNamesIfDecl IfaceForeign{} = emptyNameSet freeNamesIfDecl d@IfaceData{} = freeNamesIfTvBndrs (ifTyVars d) &&& @@ -744,7 +714,7 @@ freeNamesIfSynRhs Nothing = emptyNameSet freeNamesIfTcFam :: Maybe (IfaceTyCon, [IfaceType]) -> NameSet -freeNamesIfTcFam (Just (tc,tys)) = +freeNamesIfTcFam (Just (tc,tys)) = freeNamesIfTc tc &&& fnList freeNamesIfType tys freeNamesIfTcFam Nothing = emptyNameSet @@ -764,15 +734,15 @@ freeNamesIfConDecls _ = emptyNameSet freeNamesIfConDecl :: IfaceConDecl -> NameSet -freeNamesIfConDecl c = +freeNamesIfConDecl c = freeNamesIfTvBndrs (ifConUnivTvs c) &&& freeNamesIfTvBndrs (ifConExTvs c) &&& - freeNamesIfContext (ifConCtxt c) &&& + freeNamesIfContext (ifConCtxt c) &&& fnList freeNamesIfType (ifConArgTys c) &&& fnList freeNamesIfType (map snd (ifConEqSpec c)) -- equality constraints freeNamesIfPredType :: IfacePredType -> NameSet -freeNamesIfPredType (IfaceClassP cl tys) = +freeNamesIfPredType (IfaceClassP cl tys) = unitNameSet cl &&& fnList freeNamesIfType tys freeNamesIfPredType (IfaceIParam _n ty) = freeNamesIfType ty @@ -783,11 +753,13 @@ freeNamesIfType (IfaceTyVar _) = emptyNameSet freeNamesIfType (IfaceAppTy s t) = freeNamesIfType s &&& freeNamesIfType t freeNamesIfType (IfacePredTy st) = freeNamesIfPredType st -freeNamesIfType (IfaceTyConApp tc ts) = +freeNamesIfType (IfaceTyConApp tc ts) = freeNamesIfTc tc &&& fnList freeNamesIfType ts freeNamesIfType (IfaceForAllTy tv t) = freeNamesIfTvBndr tv &&& freeNamesIfType t freeNamesIfType (IfaceFunTy s t) = freeNamesIfType s &&& freeNamesIfType t +freeNamesIfType (IfaceCoConApp tc ts) = + freeNamesIfCo tc &&& fnList freeNamesIfType ts freeNamesIfTvBndrs :: [IfaceTvBndr] -> NameSet freeNamesIfTvBndrs = fnList freeNamesIfTvBndr @@ -798,7 +770,7 @@ freeNamesIfLetBndr :: IfaceLetBndr -> NameSet -- Remember IfaceLetBndr is used only for *nested* bindings --- The IdInfo can contain an unfolding (in the case of +-- The IdInfo can contain an unfolding (in the case of -- local INLINE pragmas), so look there too freeNamesIfLetBndr (IfLetBndr _name ty info) = freeNamesIfType ty &&& freeNamesIfIdInfo info @@ -811,7 +783,7 @@ freeNamesIfIdBndr = freeNamesIfTvBndr freeNamesIfIdInfo :: IfaceIdInfo -> NameSet -freeNamesIfIdInfo NoInfo = emptyNameSet +freeNamesIfIdInfo NoInfo = emptyNameSet freeNamesIfIdInfo (HasInfo i) = fnList freeNamesItem i freeNamesItem :: IfaceInfoItem -> NameSet @@ -824,31 +796,31 @@ freeNamesIfUnfold (IfInlineRule _ _ _ e) = freeNamesIfExpr e freeNamesIfUnfold (IfExtWrapper _ v) = unitNameSet v freeNamesIfUnfold (IfLclWrapper {}) = emptyNameSet -freeNamesIfUnfold (IfDFunUnfold vs) = fnList freeNamesIfExpr (dfunArgExprs vs) +freeNamesIfUnfold (IfDFunUnfold vs) = fnList freeNamesIfExpr vs freeNamesIfExpr :: IfaceExpr -> NameSet -freeNamesIfExpr (IfaceExt v) = unitNameSet v +freeNamesIfExpr (IfaceExt v) = unitNameSet v freeNamesIfExpr (IfaceFCall _ ty) = freeNamesIfType ty freeNamesIfExpr (IfaceType ty) = freeNamesIfType ty +freeNamesIfExpr (IfaceCo co) = freeNamesIfType co freeNamesIfExpr (IfaceTuple _ as) = fnList freeNamesIfExpr as freeNamesIfExpr (IfaceLam b body) = freeNamesIfBndr b &&& freeNamesIfExpr body freeNamesIfExpr (IfaceApp f a) = freeNamesIfExpr f &&& freeNamesIfExpr a freeNamesIfExpr (IfaceCast e co) = freeNamesIfExpr e &&& freeNamesIfType co -freeNamesIfExpr (IfaceNote _n r) = freeNamesIfExpr r +freeNamesIfExpr (IfaceNote _n r) = freeNamesIfExpr r -freeNamesIfExpr (IfaceCase s _ ty alts) +freeNamesIfExpr (IfaceCase s _ alts) = freeNamesIfExpr s &&& fnList fn_alt alts &&& fn_cons alts - &&& freeNamesIfType ty where fn_alt (_con,_bs,r) = freeNamesIfExpr r -- Depend on the data constructors. Just one will do! -- Note [Tracking data constructors] - fn_cons [] = emptyNameSet - fn_cons ((IfaceDefault ,_,_) : alts) = fn_cons alts - fn_cons ((IfaceDataAlt con,_,_) : _ ) = unitNameSet con - fn_cons (_ : _ ) = emptyNameSet + fn_cons [] = emptyNameSet + fn_cons ((IfaceDefault ,_,_) : xs) = fn_cons xs + fn_cons ((IfaceDataAlt con,_,_) : _ ) = unitNameSet con + fn_cons (_ : _ ) = emptyNameSet freeNamesIfExpr (IfaceLet (IfaceNonRec bndr rhs) body) = freeNamesIfLetBndr bndr &&& freeNamesIfExpr rhs &&& freeNamesIfExpr body @@ -865,6 +837,10 @@ -- ToDo: shouldn't we include IfaceIntTc & co.? freeNamesIfTc _ = emptyNameSet +freeNamesIfCo :: IfaceCoCon -> NameSet +freeNamesIfCo (IfaceCoAx tc) = unitNameSet tc +freeNamesIfCo _ = emptyNameSet + freeNamesIfRule :: IfaceRule -> NameSet freeNamesIfRule (IfaceRule { ifRuleBndrs = bs, ifRuleHead = f , ifRuleArgs = es, ifRuleRhs = rhs }) @@ -883,18 +859,18 @@ Note [Tracking data constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In a case expression +In a case expression case e of { C a -> ...; ... } You might think that we don't need to include the datacon C -in the free names, because its type will probably show up in +in the free names, because its type will probably show up in the free names of 'e'. But in rare circumstances this may not happen. Here's the one that bit me: - module DynFlags where + module DynFlags where import {-# SOURCE #-} Packages( PackageState ) data DynFlags = DF ... PackageState ... - module Packages where + module Packages where import DynFlags data PackageState = PS ... lookupModule (df :: DynFlags) @@ -905,3 +881,4 @@ Now, lookupModule depends on DynFlags, but the transitive dependency on the *locally-defined* type PackageState is not visible. We need to take account of the use of the data constructor PS in the pattern match. + diff -Nru ghc-7.0.3/compiler/iface/IfaceType.lhs ghc-7.2.1/compiler/iface/IfaceType.lhs --- ghc-7.0.3/compiler/iface/IfaceType.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/iface/IfaceType.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -9,15 +9,18 @@ module IfaceType ( IfExtName, IfLclName, - IfaceType(..), IfaceKind, IfacePredType(..), IfaceTyCon(..), + IfaceType(..), IfaceKind, IfacePredType(..), IfaceTyCon(..), IfaceCoCon(..), IfaceContext, IfaceBndr(..), IfaceTvBndr, IfaceIdBndr, IfaceCoercion, ifaceTyConName, -- Conversion from Type -> IfaceType - toIfaceType, toIfacePred, toIfaceContext, + toIfaceType, toIfaceContext, toIfaceBndr, toIfaceIdBndr, toIfaceTvBndrs, toIfaceTyCon, toIfaceTyCon_name, + -- Conversion from Coercion -> IfaceType + coToIfaceType, + -- Printing pprIfaceType, pprParendIfaceType, pprIfaceContext, pprIfaceIdBndr, pprIfaceTvBndr, pprIfaceTvBndrs, pprIfaceBndrs, @@ -25,11 +28,13 @@ ) where -import TypeRep +import Coercion +import TypeRep hiding( maybeParen ) import TyCon import Id import Var import TysWiredIn +import TysPrim import Name import BasicTypes import Outputable @@ -59,14 +64,15 @@ type IfaceKind = IfaceType type IfaceCoercion = IfaceType -data IfaceType - = IfaceTyVar IfLclName -- Type variable only, not tycon +data IfaceType -- A kind of universal type, used for types, kinds, and coercions + = IfaceTyVar IfLclName -- Type/coercion variable only, not tycon | IfaceAppTy IfaceType IfaceType + | IfaceFunTy IfaceType IfaceType | IfaceForAllTy IfaceTvBndr IfaceType | IfacePredTy IfacePredType - | IfaceTyConApp IfaceTyCon [IfaceType] -- Not necessarily saturated - -- Includes newtypes, synonyms, tuples - | IfaceFunTy IfaceType IfaceType + | IfaceTyConApp IfaceTyCon [IfaceType] -- Not necessarily saturated + -- Includes newtypes, synonyms, tuples + | IfaceCoConApp IfaceCoCon [IfaceType] -- Always saturated data IfacePredType -- NewTypes are handled as ordinary TyConApps = IfaceClassP IfExtName [IfaceType] @@ -75,18 +81,28 @@ type IfaceContext = [IfacePredType] -data IfaceTyCon -- Abbreviations for common tycons with known names +data IfaceTyCon -- Encodes type consructors, kind constructors + -- coercion constructors, the lot = IfaceTc IfExtName -- The common case | IfaceIntTc | IfaceBoolTc | IfaceCharTc | IfaceListTc | IfacePArrTc | IfaceTupTc Boxity Arity | IfaceAnyTc IfaceKind -- Used for AnyTyCon (see Note [Any Types] in TysPrim) -- other than 'Any :: *' itself + + -- Kind constructors | IfaceLiftedTypeKindTc | IfaceOpenTypeKindTc | IfaceUnliftedTypeKindTc | IfaceUbxTupleKindTc | IfaceArgTypeKindTc -ifaceTyConName :: IfaceTyCon -> IfExtName -ifaceTyConName IfaceIntTc = intTyConName + -- Coercion constructors +data IfaceCoCon + = IfaceCoAx IfExtName + | IfaceReflCo | IfaceUnsafeCo | IfaceSymCo + | IfaceTransCo | IfaceInstCo + | IfaceNthCo Int + +ifaceTyConName :: IfaceTyCon -> Name +ifaceTyConName IfaceIntTc = intTyConName ifaceTyConName IfaceBoolTc = boolTyConName ifaceTyConName IfaceCharTc = charTyConName ifaceTyConName IfaceListTc = listTyConName @@ -208,6 +224,10 @@ ppr_ty ctxt_prec (IfaceTyConApp tc tys) = ppr_tc_app ctxt_prec tc tys ppr_ty _ (IfacePredTy st) = ppr st +ppr_ty ctxt_prec (IfaceCoConApp tc tys) + = maybeParen ctxt_prec tYCON_PREC + (sep [ppr tc, nest 4 (sep (map pprParendIfaceType tys))]) + -- Function types ppr_ty ctxt_prec (IfaceFunTy ty1 ty2) = -- We don't want to lose synonyms, so we mustn't use splitFunTys here. @@ -268,6 +288,15 @@ -- so we fake it. It's only for debug printing! ppr other_tc = ppr (ifaceTyConName other_tc) +instance Outputable IfaceCoCon where + ppr (IfaceCoAx n) = ppr n + ppr IfaceReflCo = ptext (sLit "Refl") + ppr IfaceUnsafeCo = ptext (sLit "Unsafe") + ppr IfaceSymCo = ptext (sLit "Sym") + ppr IfaceTransCo = ptext (sLit "Trans") + ppr IfaceInstCo = ptext (sLit "Inst") + ppr (IfaceNthCo d) = ptext (sLit "Nth:") <> int d + ------------------- pprIfaceContext :: IfaceContext -> SDoc -- Prints "(C a, D b) =>", including the arrow @@ -309,18 +338,15 @@ --------------------- toIfaceType :: Type -> IfaceType -- Synonyms are retained in the interface type -toIfaceType (TyVarTy tv) = - IfaceTyVar (occNameFS (getOccName tv)) -toIfaceType (AppTy t1 t2) = - IfaceAppTy (toIfaceType t1) (toIfaceType t2) -toIfaceType (FunTy t1 t2) = - IfaceFunTy (toIfaceType t1) (toIfaceType t2) -toIfaceType (TyConApp tc tys) = - IfaceTyConApp (toIfaceTyCon tc) (toIfaceTypes tys) -toIfaceType (ForAllTy tv t) = - IfaceForAllTy (toIfaceTvBndr tv) (toIfaceType t) -toIfaceType (PredTy st) = - IfacePredTy (toIfacePred st) +toIfaceType (TyVarTy tv) = IfaceTyVar (toIfaceTyCoVar tv) +toIfaceType (AppTy t1 t2) = IfaceAppTy (toIfaceType t1) (toIfaceType t2) +toIfaceType (FunTy t1 t2) = IfaceFunTy (toIfaceType t1) (toIfaceType t2) +toIfaceType (TyConApp tc tys) = IfaceTyConApp (toIfaceTyCon tc) (toIfaceTypes tys) +toIfaceType (ForAllTy tv t) = IfaceForAllTy (toIfaceTvBndr tv) (toIfaceType t) +toIfaceType (PredTy st) = IfacePredTy (toIfacePred toIfaceType st) + +toIfaceTyCoVar :: TyCoVar -> FastString +toIfaceTyCoVar = occNameFS . getOccName ---------------- -- A little bit of (perhaps optional) trickiness here. When @@ -364,16 +390,39 @@ toIfaceTypes ts = map toIfaceType ts ---------------- -toIfacePred :: PredType -> IfacePredType -toIfacePred (ClassP cls ts) = - IfaceClassP (getName cls) (toIfaceTypes ts) -toIfacePred (IParam ip t) = - IfaceIParam (mapIPName getOccName ip) (toIfaceType t) -toIfacePred (EqPred ty1 ty2) = - IfaceEqPred (toIfaceType ty1) (toIfaceType ty2) +toIfacePred :: (a -> IfaceType) -> Pred a -> IfacePredType +toIfacePred to (ClassP cls ts) = IfaceClassP (getName cls) (map to ts) +toIfacePred to (IParam ip t) = IfaceIParam (mapIPName getOccName ip) (to t) +toIfacePred to (EqPred ty1 ty2) = IfaceEqPred (to ty1) (to ty2) ---------------- toIfaceContext :: ThetaType -> IfaceContext -toIfaceContext cs = map toIfacePred cs +toIfaceContext cs = map (toIfacePred toIfaceType) cs + +---------------- +coToIfaceType :: Coercion -> IfaceType +coToIfaceType (Refl ty) = IfaceCoConApp IfaceReflCo [toIfaceType ty] +coToIfaceType (TyConAppCo tc cos) = IfaceTyConApp (toIfaceTyCon tc) + (map coToIfaceType cos) +coToIfaceType (AppCo co1 co2) = IfaceAppTy (coToIfaceType co1) + (coToIfaceType co2) +coToIfaceType (ForAllCo v co) = IfaceForAllTy (toIfaceTvBndr v) + (coToIfaceType co) +coToIfaceType (CoVarCo cv) = IfaceTyVar (toIfaceTyCoVar cv) +coToIfaceType (AxiomInstCo con cos) = IfaceCoConApp (IfaceCoAx (coAxiomName con)) + (map coToIfaceType cos) +coToIfaceType (UnsafeCo ty1 ty2) = IfaceCoConApp IfaceUnsafeCo + [ toIfaceType ty1 + , toIfaceType ty2 ] +coToIfaceType (SymCo co) = IfaceCoConApp IfaceSymCo + [ coToIfaceType co ] +coToIfaceType (TransCo co1 co2) = IfaceCoConApp IfaceTransCo + [ coToIfaceType co1 + , coToIfaceType co2 ] +coToIfaceType (NthCo d co) = IfaceCoConApp (IfaceNthCo d) + [ coToIfaceType co ] +coToIfaceType (InstCo co ty) = IfaceCoConApp IfaceInstCo + [ coToIfaceType co + , toIfaceType ty ] \end{code} diff -Nru ghc-7.0.3/compiler/iface/LoadIface.lhs ghc-7.2.1/compiler/iface/LoadIface.lhs --- ghc-7.0.3/compiler/iface/LoadIface.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/iface/LoadIface.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -590,7 +590,7 @@ ghcPrimIface :: ModIface ghcPrimIface = (emptyModIface gHC_PRIM) { - mi_exports = [(gHC_PRIM, ghcPrimExports)], + mi_exports = ghcPrimExports, mi_decls = [], mi_fixities = fixities, mi_fix_fn = mkIfaceFixCache fixities @@ -655,8 +655,10 @@ , nest 2 (text "ABI hash:" <+> ppr (mi_mod_hash iface)) , nest 2 (text "export-list hash:" <+> ppr (mi_exp_hash iface)) , nest 2 (text "orphan hash:" <+> ppr (mi_orphan_hash iface)) + , nest 2 (text "used TH splices:" <+> ppr (mi_used_th iface)) , nest 2 (ptext (sLit "where")) - , vcat (map pprExport (mi_exports iface)) + , ptext (sLit "exports:") + , nest 2 (vcat (map pprExport (mi_exports iface))) , pprDeps (mi_deps iface) , vcat (map pprUsage (mi_usages iface)) , vcat (map pprIfaceAnnotation (mi_anns iface)) @@ -666,7 +668,10 @@ , vcat (map ppr (mi_fam_insts iface)) , vcat (map ppr (mi_rules iface)) , pprVectInfo (mi_vect_info iface) + , pprVectInfo (mi_vect_info iface) , ppr (mi_warns iface) + , pprTrustInfo (mi_trust iface) + , pprTrustPkg (mi_trust_pkg iface) ] where pp_boot | mi_boot iface = ptext (sLit "[boot]") @@ -680,41 +685,45 @@ \begin{code} pprExport :: IfaceExport -> SDoc -pprExport (mod, items) - = hsep [ ptext (sLit "export"), ppr mod, hsep (map pp_avail items) ] - where - pp_avail :: GenAvailInfo OccName -> SDoc - pp_avail (Avail occ) = ppr occ - pp_avail (AvailTC _ []) = empty - pp_avail (AvailTC n (n':ns)) - | n==n' = ppr n <> pp_export ns - | otherwise = ppr n <> char '|' <> pp_export (n':ns) - +pprExport (Avail n) = ppr n +pprExport (AvailTC _ []) = empty +pprExport (AvailTC n (n':ns)) + | n==n' = ppr n <> pp_export ns + | otherwise = ppr n <> char '|' <> pp_export (n':ns) + where pp_export [] = empty pp_export names = braces (hsep (map ppr names)) pprUsage :: Usage -> SDoc pprUsage usage@UsagePackageModule{} - = hsep [ptext (sLit "import"), ppr (usg_mod usage), - ppr (usg_mod_hash usage)] + = pprUsageImport usage usg_mod pprUsage usage@UsageHomeModule{} - = hsep [ptext (sLit "import"), ppr (usg_mod_name usage), - ppr (usg_mod_hash usage)] $$ + = pprUsageImport usage usg_mod_name $$ nest 2 ( maybe empty (\v -> text "exports: " <> ppr v) (usg_exports usage) $$ vcat [ ppr n <+> ppr v | (n,v) <- usg_entities usage ] ) +pprUsageImport :: Outputable a => Usage -> (Usage -> a) -> SDoc +pprUsageImport usage usg_mod' + = hsep [ptext (sLit "import"), safe, ppr (usg_mod' usage), + ppr (usg_mod_hash usage)] + where + safe | usg_safe usage = ptext $ sLit "safe" + | otherwise = ptext $ sLit " -/ " + pprDeps :: Dependencies -> SDoc pprDeps (Deps { dep_mods = mods, dep_pkgs = pkgs, dep_orphs = orphs, dep_finsts = finsts }) = vcat [ptext (sLit "module dependencies:") <+> fsep (map ppr_mod mods), - ptext (sLit "package dependencies:") <+> fsep (map ppr pkgs), + ptext (sLit "package dependencies:") <+> fsep (map ppr_pkg pkgs), ptext (sLit "orphans:") <+> fsep (map ppr orphs), ptext (sLit "family instance modules:") <+> fsep (map ppr finsts) ] where ppr_mod (mod_name, boot) = ppr mod_name <+> ppr_boot boot + ppr_pkg (pkg,trust_req) = ppr pkg <> + (if trust_req then text "*" else empty) ppr_boot True = text "[boot]" ppr_boot False = empty @@ -729,16 +738,26 @@ pprFix (occ,fix) = ppr fix <+> ppr occ pprVectInfo :: IfaceVectInfo -> SDoc -pprVectInfo (IfaceVectInfo { ifaceVectInfoVar = vars - , ifaceVectInfoTyCon = tycons - , ifaceVectInfoTyConReuse = tyconsReuse +pprVectInfo (IfaceVectInfo { ifaceVectInfoVar = vars + , ifaceVectInfoTyCon = tycons + , ifaceVectInfoTyConReuse = tyconsReuse + , ifaceVectInfoScalarVars = scalarVars + , ifaceVectInfoScalarTyCons = scalarTyCons }) = vcat [ ptext (sLit "vectorised variables:") <+> hsep (map ppr vars) , ptext (sLit "vectorised tycons:") <+> hsep (map ppr tycons) , ptext (sLit "vectorised reused tycons:") <+> hsep (map ppr tyconsReuse) + , ptext (sLit "scalar variables:") <+> hsep (map ppr scalarVars) + , ptext (sLit "scalar tycons:") <+> hsep (map ppr scalarTyCons) ] +pprTrustInfo :: IfaceTrustInfo -> SDoc +pprTrustInfo trust = ptext (sLit "trusted:") <+> ppr trust + +pprTrustPkg :: Bool -> SDoc +pprTrustPkg tpkg = ptext (sLit "require own pkg trusted:") <+> ppr tpkg + instance Outputable Warnings where ppr = pprWarns diff -Nru ghc-7.0.3/compiler/iface/MkIface.lhs ghc-7.2.1/compiler/iface/MkIface.lhs --- ghc-7.0.3/compiler/iface/MkIface.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/iface/MkIface.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -7,23 +7,23 @@ module MkIface ( mkUsedNames, mkDependencies, - mkIface, -- Build a ModIface from a ModGuts, - -- including computing version information + mkIface, -- Build a ModIface from a ModGuts, + -- including computing version information mkIfaceTc, - writeIfaceFile, -- Write the interface file + writeIfaceFile, -- Write the interface file - checkOldIface, -- See if recompilation is required, by - -- comparing version information + checkOldIface, -- See if recompilation is required, by + -- comparing version information tyThingToIfaceDecl -- Converting things to their Iface equivalents ) where \end{code} - ----------------------------------------------- - Recompilation checking - ----------------------------------------------- + ----------------------------------------------- + Recompilation checking + ----------------------------------------------- A complete description of how recompilation checking works can be found in the wiki commentary: @@ -59,10 +59,10 @@ import CoreSyn import CoreFVs import Class +import Kind import TyCon import DataCon import Type -import Coercion import TcType import InstEnv import FamInstEnv @@ -72,6 +72,7 @@ import Finder import DynFlags import VarEnv +import VarSet import Var import Name import RdrName @@ -105,35 +106,37 @@ %************************************************************************ -%* * +%* * \subsection{Completing an interface} -%* * +%* * %************************************************************************ \begin{code} mkIface :: HscEnv - -> Maybe Fingerprint -- The old fingerprint, if we have it - -> ModDetails -- The trimmed, tidied interface - -> ModGuts -- Usages, deprecations, etc - -> IO (Messages, + -> Maybe Fingerprint -- The old fingerprint, if we have it + -> ModDetails -- The trimmed, tidied interface + -> ModGuts -- Usages, deprecations, etc + -> IO (Messages, Maybe (ModIface, -- The new one - Bool)) -- True <=> there was an old Iface, and the + Bool)) -- True <=> there was an old Iface, and the -- new one is identical, so no need -- to write it mkIface hsc_env maybe_old_fingerprint mod_details - ModGuts{ mg_module = this_mod, - mg_boot = is_boot, - mg_used_names = used_names, - mg_deps = deps, - mg_dir_imps = dir_imp_mods, - mg_rdr_env = rdr_env, - mg_fix_env = fix_env, - mg_warns = warns, - mg_hpc_info = hpc_info } + ModGuts{ mg_module = this_mod, + mg_boot = is_boot, + mg_used_names = used_names, + mg_used_th = used_th, + mg_deps = deps, + mg_dir_imps = dir_imp_mods, + mg_rdr_env = rdr_env, + mg_fix_env = fix_env, + mg_warns = warns, + mg_hpc_info = hpc_info, + mg_trust_pkg = self_trust } = mkIface_ hsc_env maybe_old_fingerprint - this_mod is_boot used_names deps rdr_env - fix_env warns hpc_info dir_imp_mods mod_details + this_mod is_boot used_names used_th deps rdr_env fix_env + warns hpc_info dir_imp_mods self_trust mod_details -- | make an interface from the results of typechecking only. Useful -- for non-optimising compilation, or where we aren't generating any @@ -150,20 +153,25 @@ tcg_rdr_env = rdr_env, tcg_fix_env = fix_env, tcg_warns = warns, - tcg_hpc = other_hpc_info + tcg_hpc = other_hpc_info, + tcg_th_splice_used = tc_splice_used } = do let used_names = mkUsedNames tc_result deps <- mkDependencies tc_result let hpc_info = emptyHpcInfo other_hpc_info + used_th <- readIORef tc_splice_used mkIface_ hsc_env maybe_old_fingerprint - this_mod (isHsBoot hsc_src) used_names deps rdr_env - fix_env warns hpc_info (imp_mods imports) mod_details + this_mod (isHsBoot hsc_src) used_names used_th deps rdr_env + fix_env warns hpc_info (imp_mods imports) + (imp_trust_own_pkg imports) mod_details mkUsedNames :: TcGblEnv -> NameSet mkUsedNames TcGblEnv{ tcg_dus = dus } = allUses dus +-- | Extract information from the rename and typecheck phases to produce +-- a dependencies information for the module being compiled. mkDependencies :: TcGblEnv -> IO Dependencies mkDependencies TcGblEnv{ tcg_mod = mod, @@ -171,9 +179,9 @@ tcg_th_used = th_var } = do - th_used <- readIORef th_var -- Whether TH is used - let - dep_mods = eltsUFM (delFromUFM (imp_dep_mods imports) (moduleName mod)) + -- Template Haskell used? + th_used <- readIORef th_var + let dep_mods = eltsUFM (delFromUFM (imp_dep_mods imports) (moduleName mod)) -- M.hi-boot can be in the imp_dep_mods, but we must remove -- it before recording the modules on which this one depends! -- (We want to retain M.hi-boot in imp_dep_mods so that @@ -181,25 +189,31 @@ -- on M.hi-boot, and hence that we should do the hi-boot consistency -- check.) - pkgs | th_used = insertList thPackageId (imp_dep_pkgs imports) - | otherwise = imp_dep_pkgs imports + pkgs | th_used = insertList thPackageId (imp_dep_pkgs imports) + | otherwise = imp_dep_pkgs imports + + -- Set the packages required to be Safe according to Safe Haskell. + -- See Note [RnNames . Tracking Trust Transitively] + sorted_pkgs = sortBy stablePackageIdCmp pkgs + trust_pkgs = imp_trust_pkgs imports + dep_pkgs' = map (\x -> (x, x `elem` trust_pkgs)) sorted_pkgs return Deps { dep_mods = sortBy (stableModuleNameCmp `on` fst) dep_mods, - dep_pkgs = sortBy stablePackageIdCmp pkgs, + dep_pkgs = dep_pkgs', dep_orphs = sortBy stableModuleCmp (imp_orphs imports), dep_finsts = sortBy stableModuleCmp (imp_finsts imports) } - -- sort to get into canonical order - -- NB. remember to use lexicographic ordering + -- sort to get into canonical order + -- NB. remember to use lexicographic ordering mkIface_ :: HscEnv -> Maybe Fingerprint -> Module -> IsBootInterface - -> NameSet -> Dependencies -> GlobalRdrEnv + -> NameSet -> Bool -> Dependencies -> GlobalRdrEnv -> NameEnv FixItem -> Warnings -> HpcInfo - -> ImportedMods + -> ImportedMods -> Bool -> ModDetails - -> IO (Messages, Maybe (ModIface, Bool)) + -> IO (Messages, Maybe (ModIface, Bool)) mkIface_ hsc_env maybe_old_fingerprint - this_mod is_boot used_names deps rdr_env fix_env src_warns hpc_info - dir_imp_mods + this_mod is_boot used_names used_th deps rdr_env fix_env src_warns + hpc_info dir_imp_mods pkg_trust_req ModDetails{ md_insts = insts, md_fam_insts = fam_insts, md_rules = rules, @@ -226,11 +240,12 @@ -- Sigh: see Note [Root-main Id] in TcRnDriver ; fixities = [(occ,fix) | FixItem occ fix <- nameEnvElts fix_env] - ; warns = src_warns + ; warns = src_warns ; iface_rules = map (coreRuleToIfaceRule this_mod) rules ; iface_insts = map instanceToIfaceInst insts ; iface_fam_insts = map famInstToIfaceFamInst fam_insts ; iface_vect_info = flattenVectInfo vect_info + ; trust_info = (setSafeMode . safeHaskell) dflags ; intermediate_iface = ModIface { mi_module = this_mod, @@ -256,13 +271,16 @@ mi_iface_hash = fingerprint0, mi_mod_hash = fingerprint0, mi_exp_hash = fingerprint0, - mi_orphan_hash = fingerprint0, + mi_used_th = used_th, + mi_orphan_hash = fingerprint0, mi_orphan = False, -- Always set by addVersionInfo, but -- it's a strict field, so we can't omit it. mi_finsts = False, -- Ditto mi_decls = deliberatelyOmitted "decls", mi_hash_fn = deliberatelyOmitted "hash_fn", mi_hpc = isHpcUsed hpc_info, + mi_trust = trust_info, + mi_trust_pkg = pkg_trust_req, -- And build the cached values mi_warn_fn = mkIfaceWarnCache warns, @@ -275,8 +293,8 @@ intermediate_iface decls -- Warn about orphans - ; let warn_orphs = dopt Opt_WarnOrphans dflags - warn_auto_orphs = dopt Opt_WarnAutoOrphans dflags + ; let warn_orphs = wopt Opt_WarnOrphans dflags + warn_auto_orphs = wopt Opt_WarnAutoOrphans dflags orph_warnings --- Laziness means no work done unless -fwarn-orphans | warn_orphs || warn_auto_orphs = rule_warns `unionBags` inst_warns | otherwise = emptyBag @@ -295,8 +313,6 @@ then return ( errs_and_warns, Nothing ) else do { --- XXX ; when (dopt Opt_D_dump_hi_diffs dflags) (printDump pp_diffs) - -- Debug printing ; dumpIfSet_dyn dflags Opt_D_dump_hi "FINAL INTERFACE" (pprModIface new_iface) @@ -325,18 +341,17 @@ ifFamInstTcName = ifaceTyConName . ifFamInstTyCon - flattenVectInfo (VectInfo { vectInfoVar = vVar - , vectInfoTyCon = vTyCon + flattenVectInfo (VectInfo { vectInfoVar = vVar + , vectInfoTyCon = vTyCon + , vectInfoScalarVars = vScalarVars + , vectInfoScalarTyCons = vScalarTyCons }) = - IfaceVectInfo { - ifaceVectInfoVar = [ Var.varName v - | (v, _) <- varEnvElts vVar], - ifaceVectInfoTyCon = [ tyConName t - | (t, t_v) <- nameEnvElts vTyCon - , t /= t_v], - ifaceVectInfoTyConReuse = [ tyConName t - | (t, t_v) <- nameEnvElts vTyCon - , t == t_v] + IfaceVectInfo + { ifaceVectInfoVar = [Var.varName v | (v, _ ) <- varEnvElts vVar] + , ifaceVectInfoTyCon = [tyConName t | (t, t_v) <- nameEnvElts vTyCon, t /= t_v] + , ifaceVectInfoTyConReuse = [tyConName t | (t, t_v) <- nameEnvElts vTyCon, t == t_v] + , ifaceVectInfoScalarVars = [Var.varName v | v <- varSetElems vScalarVars] + , ifaceVectInfoScalarTyCons = nameSetToList vScalarTyCons } ----------------------------- @@ -463,7 +478,7 @@ = do let hash_fn = mk_put_name local_env decl = abiDecl abi -- pprTrace "fingerprinting" (ppr (ifName decl) ) $ do - hash <- computeFingerprint dflags hash_fn abi + hash <- computeFingerprint hash_fn abi return (extend_hash_env (hash,decl) local_env, (hash,decl) : decls_w_hashes) @@ -475,7 +490,7 @@ -- pprTrace "fingerprinting" (ppr (map ifName decls) ) $ do let stable_abis = sortBy cmp_abiNames abis -- put the cycle in a canonical order - hash <- computeFingerprint dflags hash_fn stable_abis + hash <- computeFingerprint hash_fn stable_abis let pairs = zip (repeat hash) decls return (foldr extend_hash_env local_env pairs, pairs ++ decls_w_hashes) @@ -509,18 +524,20 @@ $ dep_orphs sorted_deps dep_orphan_hashes <- getOrphanHashes hsc_env orph_mods - orphan_hash <- computeFingerprint dflags (mk_put_name local_env) + orphan_hash <- computeFingerprint (mk_put_name local_env) (map ifDFun orph_insts, orph_rules, fam_insts) -- the export list hash doesn't depend on the fingerprints of -- the Names it mentions, only the Names themselves, hence putNameLiterally. - export_hash <- computeFingerprint dflags putNameLiterally + export_hash <- computeFingerprint putNameLiterally (mi_exports iface0, orphan_hash, dep_orphan_hashes, - dep_pkgs (mi_deps iface0)) + dep_pkgs (mi_deps iface0), -- dep_pkgs: see "Package Version Changes" on -- wiki/Commentary/Compiler/RecompilationAvoidance + mi_trust iface0) + -- Make sure change of Safe Haskell mode causes recomp. -- put the declarations in a canonical order, sorted by OccName let sorted_decls = Map.elems $ Map.fromList $ @@ -532,7 +549,7 @@ -- - orphans -- - deprecations -- - XXX vect info? - mod_hash <- computeFingerprint dflags putNameLiterally + mod_hash <- computeFingerprint putNameLiterally (map fst sorted_decls, export_hash, orphan_hash, @@ -543,7 +560,7 @@ -- - usages -- - deps -- - hpc - iface_hash <- computeFingerprint dflags putNameLiterally + iface_hash <- computeFingerprint putNameLiterally (mod_hash, mi_usages iface0, sorted_deps, @@ -594,7 +611,7 @@ sortDependencies :: Dependencies -> Dependencies sortDependencies d = Deps { dep_mods = sortBy (compare `on` (moduleNameFS.fst)) (dep_mods d), - dep_pkgs = sortBy (compare `on` packageIdFS) (dep_pkgs d), + dep_pkgs = sortBy (stablePackageIdCmp `on` fst) (dep_pkgs d), dep_orphs = sortBy stableModuleCmp (dep_orphs d), dep_finsts = sortBy stableModuleCmp (dep_finsts d) } \end{code} @@ -633,9 +650,22 @@ data IfaceDeclExtras = IfaceIdExtras Fixity [IfaceRule] - | IfaceDataExtras Fixity [IfaceInstABI] [(Fixity,[IfaceRule])] - | IfaceClassExtras Fixity [IfaceInstABI] [(Fixity,[IfaceRule])] + + | IfaceDataExtras + Fixity -- Fixity of the tycon itself + [IfaceInstABI] -- Local instances of this tycon + -- See Note [Orphans] in IfaceSyn + [(Fixity,[IfaceRule])] -- For each construcotr, fixity and RULES + + | IfaceClassExtras + Fixity -- Fixity of the class itself + [IfaceInstABI] -- Local instances of this class *or* + -- of its associated data types + -- See Note [Orphans] in IfaceSyn + [(Fixity,[IfaceRule])] -- For each class method, fixity and RULES + | IfaceSynExtras Fixity + | IfaceOtherDeclExtras abiDecl :: IfaceDeclABI -> IfaceDecl @@ -710,9 +740,12 @@ IfaceDataExtras (fix_fn n) (map ifDFun $ lookupOccEnvL inst_env n) (map (id_extras . ifConOcc) (visibleIfConDecls cons)) - IfaceClass{ifSigs=sigs} -> + IfaceClass{ifSigs=sigs, ifATs=ats} -> IfaceClassExtras (fix_fn n) - (map ifDFun $ lookupOccEnvL inst_env n) + (map ifDFun $ (concatMap (lookupOccEnvL inst_env . ifName) ats) + ++ lookupOccEnvL inst_env n) + -- Include instances of the associated types + -- as well as instances of the class (Trac #5147) [id_extras op | IfaceClassOp op _ _ <- sigs] IfaceSyn{} -> IfaceSynExtras (fix_fn n) _other -> IfaceOtherDeclExtras @@ -736,19 +769,6 @@ do { put_ bh $! nameModule name ; put_ bh $! nameOccName name } -computeFingerprint :: Binary a - => DynFlags - -> (BinHandle -> Name -> IO ()) - -> a - -> IO Fingerprint - -computeFingerprint _dflags put_name a = do - bh <- openBinMem (3*1024) -- just less than a block - ud <- newWriteState put_name putFS - bh <- return $ setUserData bh ud - put_ bh a - fingerprintBinMem bh - {- -- for testing: use the md5sum command to generate fingerprints and -- compare the results against our built-in version. @@ -835,7 +855,7 @@ this_pkg = thisPackage dflags used_mods = moduleEnvKeys ent_map - dir_imp_mods = (moduleEnvKeys direct_imports) + dir_imp_mods = moduleEnvKeys direct_imports all_mods = used_mods ++ filter (`notElem` used_mods) dir_imp_mods usage_mods = sortBy stableModuleCmp all_mods -- canonical order is imported, to avoid interface-file @@ -850,12 +870,14 @@ | isWiredInName name = mv_map -- ignore wired-in names | otherwise = case nameModule_maybe name of - Nothing -> pprPanic "mkUsageInfo: internal name?" (ppr name) + Nothing -> ASSERT2( isSystemName name, ppr name ) mv_map + -- See Note [Internal used_names] + Just mod -> -- This lambda function is really just a -- specialised (++); originally came about to -- avoid quadratic behaviour (trac #2680) extendModuleEnvWith (\_ xs -> occ:xs) mv_map mod [occ] - where occ = nameOccName name + where occ = nameOccName name -- We want to create a Usage for a home module if -- a) we used something from it; has something in used_names @@ -871,7 +893,8 @@ | modulePackageId mod /= this_pkg = Just UsagePackageModule{ usg_mod = mod, - usg_mod_hash = mod_hash } + usg_mod_hash = mod_hash, + usg_safe = imp_safe } -- for package modules, we record the module hash only | (null used_occs @@ -886,22 +909,29 @@ | otherwise = Just UsageHomeModule { usg_mod_name = moduleName mod, - usg_mod_hash = mod_hash, - usg_exports = export_hash, - usg_entities = Map.toList ent_hashs } + usg_mod_hash = mod_hash, + usg_exports = export_hash, + usg_entities = Map.toList ent_hashs, + usg_safe = imp_safe } where - maybe_iface = lookupIfaceByModule dflags hpt pit mod - -- In one-shot mode, the interfaces for home-package - -- modules accumulate in the PIT not HPT. Sigh. - - is_direct_import = mod `elemModuleEnv` direct_imports + maybe_iface = lookupIfaceByModule dflags hpt pit mod + -- In one-shot mode, the interfaces for home-package + -- modules accumulate in the PIT not HPT. Sigh. Just iface = maybe_iface 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 + + (is_direct_import, imp_safe) + = case lookupModuleEnv direct_imports mod of + Just ((_,_,_,safe):_xs) -> (True, safe) + Just _ -> pprPanic "mkUsage: empty direct import" empty + Nothing -> (False, safeImplicitImpsReq dflags) + -- Nothing case is for implicit imports like 'System.IO' when 'putStrLn' + -- is used in the source code. We require them to be safe in Safe Haskell used_occs = lookupModuleEnv ent_map mod `orElse` [] @@ -918,21 +948,21 @@ 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} @@ -947,54 +977,17 @@ \end{code} \begin{code} -mkIfaceExports :: [AvailInfo] - -> [(Module, [GenAvailInfo OccName])] - -- Group by module and sort by occurrence +mkIfaceExports :: [AvailInfo] -> [IfaceExport] -- Sort to make canonical mkIfaceExports exports - = [ (mod, Map.elems avails) - | (mod, avails) <- sortBy (stableModuleCmp `on` fst) - (moduleEnvToList groupFM) - -- NB. the Map.toList is in a random order, - -- because Ord Module is not a predictable - -- ordering. Hence we perform a final sort - -- using the stable Module ordering. - ] + = sortBy stableAvailCmp (map sort_subs exports) where - -- Group by the module where the exported entities are defined - -- (which may not be the same for all Names in an Avail) - -- Deliberately use Map rather than UniqFM so we - -- get a canonical ordering - groupFM :: ModuleEnv (Map FastString (GenAvailInfo OccName)) - groupFM = foldl add emptyModuleEnv exports - - add_one :: ModuleEnv (Map FastString (GenAvailInfo OccName)) - -> Module -> GenAvailInfo OccName - -> ModuleEnv (Map FastString (GenAvailInfo OccName)) - add_one env mod avail - -- XXX Is there a need to flip Map.union here? - = extendModuleEnvWith (flip Map.union) env mod - (Map.singleton (occNameFS (availName avail)) avail) - - -- NB: we should not get T(X) and T(Y) in the export list - -- else the Map.union will simply discard one! They - -- should have been combined by now. - add env (Avail n) - = ASSERT( isExternalName n ) - add_one env (nameModule n) (Avail (nameOccName n)) - - add env (AvailTC tc ns) - = ASSERT( all isExternalName ns ) - foldl add_for_mod env mods - where - tc_occ = nameOccName tc - mods = nub (map nameModule ns) - -- Usually just one, but see Note [Original module] - - add_for_mod env mod - = add_one env mod (AvailTC tc_occ (sort names_from_mod)) - -- NB. sort the children, we need a canonical order - where - names_from_mod = [nameOccName n | n <- ns, nameModule n == mod] + sort_subs :: AvailInfo -> AvailInfo + sort_subs (Avail n) = Avail n + sort_subs (AvailTC n []) = AvailTC n [] + sort_subs (AvailTC n (m:ms)) + | n==m = AvailTC n (m:sortBy stableNameCmp ms) + | otherwise = AvailTC n (sortBy stableNameCmp (m:ms)) + -- Maintain the AvailTC Invariant \end{code} Note [Orignal module] @@ -1012,6 +1005,15 @@ In the result of MkIfaceExports, the names are grouped by defining module, so we may need to split up a single Avail into multiple ones. +Note [Internal used_names] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Most of the used_names are External Names, but we can have Internal +Names too: see Note [Binders in Template Haskell] in Convert, and +Trac #5362 for an example. Such Names are always + - Such Names are always for locally-defined things, for which we + don't gather usage info, so we can just ignore them in ent_map + - They are always System Names, hence the assert, just as a double check. + %************************************************************************ %* * @@ -1024,58 +1026,65 @@ \begin{code} checkOldIface :: HscEnv -> ModSummary - -> Bool -- Source unchanged + -> SourceModified -> Maybe ModIface -- Old interface from compilation manager, if any -> IO (RecompileRequired, Maybe ModIface) -checkOldIface hsc_env mod_summary source_unchanged maybe_iface - = do { showPass (hsc_dflags hsc_env) - ("Checking old interface for " ++ - showSDoc (ppr (ms_mod mod_summary))) ; - - ; initIfaceCheck hsc_env $ - check_old_iface hsc_env mod_summary source_unchanged maybe_iface - } +checkOldIface hsc_env mod_summary source_modified maybe_iface + = do showPass (hsc_dflags hsc_env) $ + "Checking old interface for " ++ (showSDoc $ ppr $ ms_mod mod_summary) + initIfaceCheck hsc_env $ + check_old_iface hsc_env mod_summary source_modified maybe_iface -check_old_iface :: HscEnv -> ModSummary -> Bool -> Maybe ModIface +check_old_iface :: HscEnv -> ModSummary -> SourceModified -> Maybe ModIface -> IfG (Bool, Maybe ModIface) -check_old_iface hsc_env mod_summary source_unchanged maybe_iface - = do -- CHECK WHETHER THE SOURCE HAS CHANGED - { when (not source_unchanged) - (traceHiDiffs (nest 4 (text "Source file changed or recompilation check turned off"))) - - -- If the source has changed and we're in interactive mode, avoid reading - -- an interface; just return the one we might have been supplied with. - ; let dflags = hsc_dflags hsc_env - ; if not (isObjectTarget (hscTarget dflags)) && not source_unchanged then - return (outOfDate, maybe_iface) - else - case maybe_iface of { - Just old_iface -> do -- Use the one we already have - { traceIf (text "We already have the old interface for" <+> ppr (ms_mod mod_summary)) - ; recomp <- checkVersions hsc_env source_unchanged mod_summary old_iface - ; return (recomp, Just old_iface) } - - ; Nothing -> do - - -- Try and read the old interface for the current module - -- from the .hi file left from the last time we compiled it - { let iface_path = msHiFilePath mod_summary - ; read_result <- readIface (ms_mod mod_summary) iface_path False - ; case read_result of { - Failed err -> do -- Old interface file not found, or garbled; give up - { traceIf (text "FYI: cannot read old interface file:" - $$ nest 4 err) - ; return (outOfDate, Nothing) } - - ; Succeeded iface -> do - - -- We have got the old iface; check its versions - { traceIf (text "Read the interface file" <+> text iface_path) - ; recomp <- checkVersions hsc_env source_unchanged mod_summary iface - ; return (recomp, Just iface) - }}}}} - +check_old_iface hsc_env mod_summary src_modified maybe_iface + = let dflags = hsc_dflags hsc_env + getIface = + case maybe_iface of + Just _ -> do + traceIf (text "We already have the old interface for" <+> ppr (ms_mod mod_summary)) + return maybe_iface + Nothing -> do + let iface_path = msHiFilePath mod_summary + read_result <- readIface (ms_mod mod_summary) iface_path False + case read_result of + Failed err -> do + traceIf (text "FYI: cannont read old interface file:" $$ nest 4 err) + return Nothing + Succeeded iface -> do + traceIf (text "Read the interface file" <+> text iface_path) + return $ Just iface + + in do + let src_changed + | dopt Opt_ForceRecomp (hsc_dflags hsc_env) = True + | SourceModified <- src_modified = True + | otherwise = False + + when src_changed + (traceHiDiffs (nest 4 (text "Source file changed or recompilation check turned off"))) + + -- If the source has changed and we're in interactive mode, + -- avoid reading an interface; just return the one we might + -- have been supplied with. + if not (isObjectTarget $ hscTarget dflags) && src_changed + then return (outOfDate, maybe_iface) + else do + -- Try and read the old interface for the current module + -- from the .hi file left from the last time we compiled it + maybe_iface' <- getIface + if src_changed + then return (outOfDate, maybe_iface') + else do + case maybe_iface' of + Nothing -> return (outOfDate, maybe_iface') + Just iface -> + -- We have got the old iface; check its versions + -- even in the SourceUnmodifiedAndStable case we + -- should check versions because some packages + -- might have changed or gone away. + checkVersions hsc_env mod_summary iface \end{code} @recompileRequired@ is called from the HscMain. It checks whether @@ -1089,41 +1098,45 @@ upToDate = False -- Recompile not required outOfDate = True -- Recompile required +-- | Check the safe haskell flags haven't changed +-- (e.g different flag on command line now) +safeHsChanged :: HscEnv -> ModIface -> Bool +safeHsChanged hsc_env iface + = (getSafeMode $ mi_trust iface) /= (safeHaskell $ hsc_dflags hsc_env) + checkVersions :: HscEnv - -> Bool -- True <=> source unchanged -> ModSummary -> ModIface -- Old interface - -> IfG RecompileRequired -checkVersions hsc_env source_unchanged mod_summary iface - | not source_unchanged - = return outOfDate - | otherwise - = do { traceHiDiffs (text "Considering whether compilation is required for" <+> - ppr (mi_module iface) <> colon) - - ; recomp <- checkDependencies hsc_env mod_summary iface - ; if recomp then return outOfDate else do { - - -- Source code unchanged and no errors yet... carry on - -- - -- First put the dependent-module info, read from the old - -- interface, into the envt, so that when we look for - -- interfaces we look for the right one (.hi or .hi-boot) - -- - -- It's just temporary because either the usage check will succeed - -- (in which case we are done with this module) or it'll fail (in which - -- case we'll compile the module from scratch anyhow). - -- - -- We do this regardless of compilation mode, although in --make mode - -- all the dependent modules should be in the HPT already, so it's - -- quite redundant - updateEps_ $ \eps -> eps { eps_is_boot = mod_deps } - - ; let this_pkg = thisPackage (hsc_dflags hsc_env) - ; checkList [checkModUsage this_pkg u | u <- mi_usages iface] - }} + -> IfG (RecompileRequired, Maybe ModIface) +checkVersions hsc_env mod_summary iface + = do { traceHiDiffs (text "Considering whether compilation is required for" <+> + ppr (mi_module iface) <> colon) + + ; recomp <- checkDependencies hsc_env mod_summary iface + ; if recomp then return (outOfDate, Just iface) else do { + ; if trust_dif then return (outOfDate, Nothing) else do { + + -- Source code unchanged and no errors yet... carry on + -- + -- First put the dependent-module info, read from the old + -- interface, into the envt, so that when we look for + -- interfaces we look for the right one (.hi or .hi-boot) + -- + -- It's just temporary because either the usage check will succeed + -- (in which case we are done with this module) or it'll fail (in which + -- case we'll compile the module from scratch anyhow). + -- + -- We do this regardless of compilation mode, although in --make mode + -- all the dependent modules should be in the HPT already, so it's + -- quite redundant + ; updateEps_ $ \eps -> eps { eps_is_boot = mod_deps } + ; recomp <- checkList [checkModUsage this_pkg u | u <- mi_usages iface] + ; return (recomp, Just iface) + }}} where - -- This is a bit of a hack really + this_pkg = thisPackage (hsc_dflags hsc_env) + trust_dif = safeHsChanged hsc_env iface + -- This is a bit of a hack really mod_deps :: ModuleNameEnv (ModuleName, IsBootInterface) mod_deps = mkModDeps (dep_mods (mi_deps iface)) @@ -1150,7 +1163,7 @@ orM = foldr f (return False) where f m rest = do b <- m; if b then return True else rest - dep_missing (L _ (ImportDecl (L _ mod) pkg _ _ _ _)) = do + dep_missing (L _ (ImportDecl (L _ mod) pkg _ _ _ _ _)) = do find_res <- liftIO $ findImportedModule hsc_env mod pkg case find_res of Found _ mod @@ -1163,7 +1176,7 @@ else return upToDate | otherwise - -> if pkg `notElem` prev_dep_pkgs + -> if pkg `notElem` (map fst prev_dep_pkgs) then do traceHiDiffs $ text "imported module " <> quotes (ppr mod) <> text " is from package " <> quotes (ppr pkg) <> @@ -1335,9 +1348,9 @@ (sel_tyvars, rho_ty) = splitForAllTys (idType sel_id) op_ty = funResultTy rho_ty - toDmSpec NoDefMeth = NoDM - toDmSpec GenDefMeth = GenericDM - toDmSpec (DefMeth _) = VanillaDM + toDmSpec NoDefMeth = NoDM + toDmSpec (GenDefMeth _) = GenericDM + toDmSpec (DefMeth _) = VanillaDM toIfaceFD (tvs1, tvs2) = (map getFS tvs1, map getFS tvs2) @@ -1357,7 +1370,6 @@ ifCons = ifaceConDecls (algTyConRhs tycon), ifRec = boolToRecFlag (isRecursiveTyCon tycon), ifGadtSyntax = isGadtSyntaxTyCon tycon, - ifGeneric = tyConHasGenerics tycon, ifFamInst = famInstToIface (tyConFamInst_maybe tycon)} | isForeignTyCon tycon @@ -1387,14 +1399,16 @@ = IfCon { ifConOcc = getOccName (dataConName data_con), ifConInfix = dataConIsInfix data_con, ifConWrapper = isJust (dataConWrapId_maybe data_con), - ifConUnivTvs = toIfaceTvBndrs (dataConUnivTyVars data_con), - ifConExTvs = toIfaceTvBndrs (dataConExTyVars data_con), - ifConEqSpec = to_eq_spec (dataConEqSpec data_con), - ifConCtxt = toIfaceContext (dataConEqTheta data_con ++ dataConDictTheta data_con), - ifConArgTys = map toIfaceType (dataConOrigArgTys data_con), + ifConUnivTvs = toIfaceTvBndrs univ_tvs, + ifConExTvs = toIfaceTvBndrs ex_tvs, + ifConEqSpec = to_eq_spec eq_spec, + ifConCtxt = toIfaceContext theta, + ifConArgTys = map toIfaceType arg_tys, ifConFields = map getOccName (dataConFieldLabels data_con), ifConStricts = dataConStrictMarks data_con } + where + (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) = dataConFullSig data_con to_eq_spec spec = [(getOccName tv, toIfaceType ty) | (tv,ty) <- spec] @@ -1402,6 +1416,8 @@ famInstToIface (Just (famTyCon, instTys)) = Just (toIfaceTyCon famTyCon, map toIfaceType instTys) +tyThingToIfaceDecl c@(ACoAxiom _) = pprPanic "tyThingToIfaceDecl (ACoCon _)" (ppr c) + tyThingToIfaceDecl (ADataCon dc) = pprPanic "toIfaceDecl" (ppr dc) -- Should be trimmed out earlier @@ -1428,7 +1444,7 @@ is_local name = nameIsLocalOrFrom mod name -- Compute orphanhood. See Note [Orphans] in IfaceSyn - (_, cls, tys) = tcSplitDFunTy (idType dfun_id) + (_, _, cls, tys) = tcSplitDFunTy (idType dfun_id) -- Slightly awkward: we need the Class to get the fundeps (tvs, fds) = classTvsFds cls arg_names = [filterNameSet is_local (orphNamesOfType ty) | ty <- tys] @@ -1471,7 +1487,7 @@ -------------------------- toIfaceIdDetails :: IdDetails -> IfaceIdDetails toIfaceIdDetails VanillaId = IfVanillaId -toIfaceIdDetails (DFunId ns _) = IfDFunId ns +toIfaceIdDetails (DFunId {}) = IfDFunId toIfaceIdDetails (RecSelId { sel_naughty = n , sel_tycon = tc }) = IfRecSelId (toIfaceTyCon tc) n toIfaceIdDetails other = pprTrace "toIfaceIdDetails" (ppr other) @@ -1505,7 +1521,7 @@ ------------ Unfolding -------------- unfold_hsinfo = toIfUnfolding loop_breaker (unfoldingInfo id_info) - loop_breaker = isNonRuleLoopBreaker (occInfo id_info) + loop_breaker = isStrongLoopBreaker (occInfo id_info) ------------ Inline prag -------------- inline_prag = inlinePragInfo id_info @@ -1536,7 +1552,7 @@ if_rhs = toIfaceExpr rhs toIfUnfolding lb (DFunUnfolding _ar _con ops) - = Just (HsUnfold lb (IfDFunUnfold (map (fmap toIfaceExpr) ops))) + = Just (HsUnfold lb (IfDFunUnfold (map toIfaceExpr ops))) -- No need to serialise the data constructor; -- we can recover it from the type of the dfun @@ -1566,6 +1582,8 @@ -- construct the same ru_rough field as we have right now; -- see tcIfaceRule do_arg (Type ty) = IfaceType (toIfaceType (deNoteType ty)) + do_arg (Coercion co) = IfaceType (coToIfaceType co) + do_arg arg = toIfaceExpr arg -- Compute orphanhood. See Note [Orphans] in IfaceSyn @@ -1585,15 +1603,16 @@ --------------------- toIfaceExpr :: CoreExpr -> IfaceExpr -toIfaceExpr (Var v) = toIfaceVar v -toIfaceExpr (Lit l) = IfaceLit l -toIfaceExpr (Type ty) = IfaceType (toIfaceType ty) -toIfaceExpr (Lam x b) = IfaceLam (toIfaceBndr x) (toIfaceExpr b) -toIfaceExpr (App f a) = toIfaceApp f [a] -toIfaceExpr (Case s x ty as) = IfaceCase (toIfaceExpr s) (getFS x) (toIfaceType ty) (map toIfaceAlt as) -toIfaceExpr (Let b e) = IfaceLet (toIfaceBind b) (toIfaceExpr e) -toIfaceExpr (Cast e co) = IfaceCast (toIfaceExpr e) (toIfaceType co) -toIfaceExpr (Note n e) = IfaceNote (toIfaceNote n) (toIfaceExpr e) +toIfaceExpr (Var v) = toIfaceVar v +toIfaceExpr (Lit l) = IfaceLit l +toIfaceExpr (Type ty) = IfaceType (toIfaceType ty) +toIfaceExpr (Coercion co) = IfaceCo (coToIfaceType co) +toIfaceExpr (Lam x b) = IfaceLam (toIfaceBndr x) (toIfaceExpr b) +toIfaceExpr (App f a) = toIfaceApp f [a] +toIfaceExpr (Case s x _ as) = IfaceCase (toIfaceExpr s) (getFS x) (map toIfaceAlt as) +toIfaceExpr (Let b e) = IfaceLet (toIfaceBind b) (toIfaceExpr e) +toIfaceExpr (Cast e co) = IfaceCast (toIfaceExpr e) (coToIfaceType co) +toIfaceExpr (Note n e) = IfaceNote (toIfaceNote n) (toIfaceExpr e) --------------------- toIfaceNote :: Note -> IfaceNote diff -Nru ghc-7.0.3/compiler/iface/TcIface.lhs ghc-7.2.1/compiler/iface/TcIface.lhs --- ghc-7.0.3/compiler/iface/TcIface.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/iface/TcIface.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -21,6 +21,7 @@ import TcRnMonad import TcType import Type +import Coercion import TypeRep import HscTypes import Annotations @@ -38,15 +39,16 @@ import TyCon import DataCon import TysWiredIn -import TysPrim ( anyTyConOfKind ) -import Var ( Var, TyVar ) -import BasicTypes ( Arity, nonRuleLoopBreaker ) +import TysPrim ( anyTyConOfKind ) +import BasicTypes ( Arity, strongLoopBreaker ) import qualified Var import VarEnv +import VarSet import Name import NameEnv -import OccurAnal ( occurAnalyseExpr ) -import Demand ( isBottomingSig ) +import NameSet +import OccurAnal ( occurAnalyseExpr ) +import Demand ( isBottomingSig ) import Module import UniqFM import UniqSupply @@ -263,10 +265,10 @@ ; writeMutVar tc_env_var type_env -- Now do those rules, instances and annotations - ; insts <- mapM tcIfaceInst (mi_insts iface) + ; insts <- mapM tcIfaceInst (mi_insts iface) ; fam_insts <- mapM tcIfaceFamInst (mi_fam_insts iface) ; rules <- tcIfaceRules ignore_prags (mi_rules iface) - ; anns <- tcIfaceAnnotations (mi_anns iface) + ; anns <- tcIfaceAnnotations (mi_anns iface) -- Vectorisation information ; vect_info <- tcIfaceVectInfo (mi_module iface) type_env @@ -433,7 +435,6 @@ ifCtxt = ctxt, ifGadtSyntax = gadt_syn, ifCons = rdr_cons, ifRec = is_rec, - ifGeneric = want_generic, ifFamInst = mb_family }) = bindIfaceTyVars_AT tv_bndrs $ \ tyvars -> do { tc_name <- lookupIfaceTop occ_name @@ -442,7 +443,7 @@ ; cons <- tcIfaceDataCons tc_name tycon tyvars rdr_cons ; mb_fam_inst <- tcFamInst mb_family ; buildAlgTyCon tc_name tyvars stupid_theta cons is_rec - want_generic gadt_syn parent mb_fam_inst + gadt_syn parent mb_fam_inst }) ; traceIf (text "tcIfaceDecl4" <+> ppr tycon) ; return (ATyCon tycon) } @@ -589,11 +590,11 @@ \begin{code} tcIfaceInst :: IfaceInst -> IfL Instance tcIfaceInst (IfaceInst { ifDFun = dfun_occ, ifOFlag = oflag, - ifInstCls = cls, ifInstTys = mb_tcs }) - = do { dfun <- forkM (ptext (sLit "Dict fun") <+> ppr dfun_occ) $ - tcIfaceExtId dfun_occ - ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs - ; return (mkImportedInstance cls mb_tcs' dfun oflag) } + ifInstCls = cls, ifInstTys = mb_tcs }) + = do { dfun <- forkM (ptext (sLit "Dict fun") <+> ppr dfun_occ) $ + tcIfaceExtId dfun_occ + ; let mb_tcs' = map (fmap ifaceTyConName) mb_tcs + ; return (mkImportedInstance cls mb_tcs' dfun oflag) } tcIfaceFamInst :: IfaceFamInst -> IfL FamInst tcIfaceFamInst (IfaceFamInst { ifFamInstTyCon = tycon, @@ -690,28 +691,32 @@ %************************************************************************ -%* * - Vectorisation information -%* * +%* * + Vectorisation information +%* * %************************************************************************ \begin{code} tcIfaceVectInfo :: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo tcIfaceVectInfo mod typeEnv (IfaceVectInfo - { ifaceVectInfoVar = vars - , ifaceVectInfoTyCon = tycons - , ifaceVectInfoTyConReuse = tyconsReuse + { ifaceVectInfoVar = vars + , ifaceVectInfoTyCon = tycons + , ifaceVectInfoTyConReuse = tyconsReuse + , ifaceVectInfoScalarVars = scalarVars + , ifaceVectInfoScalarTyCons = scalarTyCons }) = do { vVars <- mapM vectVarMapping vars ; tyConRes1 <- mapM vectTyConMapping tycons ; tyConRes2 <- mapM vectTyConReuseMapping tyconsReuse ; let (vTyCons, vDataCons, vPAs, vIsos) = unzip4 (tyConRes1 ++ tyConRes2) ; return $ VectInfo - { vectInfoVar = mkVarEnv vVars - , vectInfoTyCon = mkNameEnv vTyCons - , vectInfoDataCon = mkNameEnv (concat vDataCons) - , vectInfoPADFun = mkNameEnv vPAs - , vectInfoIso = mkNameEnv vIsos + { vectInfoVar = mkVarEnv vVars + , vectInfoTyCon = mkNameEnv vTyCons + , vectInfoDataCon = mkNameEnv (concat vDataCons) + , vectInfoPADFun = mkNameEnv vPAs + , vectInfoIso = mkNameEnv vIsos + , vectInfoScalarVars = mkVarSet (map lookupVar scalarVars) + , vectInfoScalarTyCons = mkNameSet scalarTyCons } } where @@ -779,9 +784,9 @@ \end{code} %************************************************************************ -%* * - Types -%* * +%* * + Types +%* * %************************************************************************ \begin{code} @@ -791,20 +796,56 @@ tcIfaceType (IfaceFunTy t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (FunTy t1' t2') } tcIfaceType (IfaceTyConApp tc ts) = do { tc' <- tcIfaceTyCon tc; ts' <- tcIfaceTypes ts; return (mkTyConApp tc' ts') } tcIfaceType (IfaceForAllTy tv t) = bindIfaceTyVar tv $ \ tv' -> do { t' <- tcIfaceType t; return (ForAllTy tv' t') } -tcIfaceType (IfacePredTy st) = do { st' <- tcIfacePredType st; return (PredTy st') } +tcIfaceType (IfacePredTy st) = do { st' <- tcIfacePred tcIfaceType st; return (PredTy st') } +tcIfaceType t@(IfaceCoConApp {}) = pprPanic "tcIfaceType" (ppr t) tcIfaceTypes :: [IfaceType] -> IfL [Type] tcIfaceTypes tys = mapM tcIfaceType tys ----------------------------------------- -tcIfacePredType :: IfacePredType -> IfL PredType -tcIfacePredType (IfaceClassP cls ts) = do { cls' <- tcIfaceClass cls; ts' <- tcIfaceTypes ts; return (ClassP cls' ts') } -tcIfacePredType (IfaceIParam ip t) = do { ip' <- newIPName ip; t' <- tcIfaceType t; return (IParam ip' t') } -tcIfacePredType (IfaceEqPred t1 t2) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (EqPred t1' t2') } +tcIfacePred :: (IfaceType -> IfL a) -> IfacePredType -> IfL (Pred a) +tcIfacePred tc (IfaceClassP cls ts) + = do { cls' <- tcIfaceClass cls; ts' <- mapM tc ts; return (ClassP cls' ts') } +tcIfacePred tc (IfaceIParam ip t) + = do { ip' <- newIPName ip; t' <- tc t; return (IParam ip' t') } +tcIfacePred tc (IfaceEqPred t1 t2) + = do { t1' <- tc t1; t2' <- tc t2; return (EqPred t1' t2') } ----------------------------------------- tcIfaceCtxt :: IfaceContext -> IfL ThetaType -tcIfaceCtxt sts = mapM tcIfacePredType sts +tcIfaceCtxt sts = mapM (tcIfacePred tcIfaceType) sts +\end{code} + +%************************************************************************ +%* * + Coercions +%* * +%************************************************************************ + +\begin{code} +tcIfaceCo :: IfaceType -> IfL Coercion +tcIfaceCo (IfaceTyVar n) = mkCoVarCo <$> tcIfaceCoVar n +tcIfaceCo (IfaceAppTy t1 t2) = mkAppCo <$> tcIfaceCo t1 <*> tcIfaceCo t2 +tcIfaceCo (IfaceFunTy t1 t2) = mkFunCo <$> tcIfaceCo t1 <*> tcIfaceCo t2 +tcIfaceCo (IfaceTyConApp tc ts) = mkTyConAppCo <$> tcIfaceTyCon tc <*> mapM tcIfaceCo ts +tcIfaceCo (IfaceCoConApp tc ts) = tcIfaceCoApp tc ts +tcIfaceCo (IfaceForAllTy tv t) = bindIfaceTyVar tv $ \ tv' -> + mkForAllCo tv' <$> tcIfaceCo t +-- tcIfaceCo (IfacePredTy co) = mkPredCo <$> tcIfacePred tcIfaceCo co +tcIfaceCo (IfacePredTy _) = panic "tcIfaceCo" + +tcIfaceCoApp :: IfaceCoCon -> [IfaceType] -> IfL Coercion +tcIfaceCoApp IfaceReflCo [t] = Refl <$> tcIfaceType t +tcIfaceCoApp (IfaceCoAx n) ts = AxiomInstCo <$> tcIfaceCoAxiom n <*> mapM tcIfaceCo ts +tcIfaceCoApp IfaceUnsafeCo [t1,t2] = UnsafeCo <$> tcIfaceType t1 <*> tcIfaceType t2 +tcIfaceCoApp IfaceSymCo [t] = SymCo <$> tcIfaceCo t +tcIfaceCoApp IfaceTransCo [t1,t2] = TransCo <$> tcIfaceCo t1 <*> tcIfaceCo t2 +tcIfaceCoApp IfaceInstCo [t1,t2] = InstCo <$> tcIfaceCo t1 <*> tcIfaceType t2 +tcIfaceCoApp (IfaceNthCo d) [t] = NthCo d <$> tcIfaceCo t +tcIfaceCoApp cc ts = pprPanic "toIfaceCoApp" (ppr cc <+> ppr ts) + +tcIfaceCoVar :: FastString -> IfL CoVar +tcIfaceCoVar = tcIfaceLclId \end{code} @@ -819,6 +860,12 @@ tcIfaceExpr (IfaceType ty) = Type <$> tcIfaceType ty +tcIfaceExpr (IfaceCo co) + = Coercion <$> tcIfaceCo co + +tcIfaceExpr (IfaceCast expr co) + = Cast <$> tcIfaceExpr expr <*> tcIfaceCo co + tcIfaceExpr (IfaceLcl name) = Var <$> tcIfaceLclId name @@ -853,7 +900,7 @@ tcIfaceExpr (IfaceApp fun arg) = App <$> tcIfaceExpr fun <*> tcIfaceExpr arg -tcIfaceExpr (IfaceCase scrut case_bndr ty alts) = do +tcIfaceExpr (IfaceCase scrut case_bndr alts) = do scrut' <- tcIfaceExpr scrut case_bndr_name <- newIfaceName (mkVarOccFS case_bndr) let @@ -868,8 +915,7 @@ extendIfaceIdEnv [case_bndr'] $ do alts' <- mapM (tcIfaceAlt scrut' tc_app) alts - ty' <- tcIfaceType ty - return (Case scrut' case_bndr' ty' alts') + return (Case scrut' case_bndr' (coreAltsType alts') alts') tcIfaceExpr (IfaceLet (IfaceNonRec (IfLetBndr fs ty info) rhs) body) = do { name <- newIfaceName (mkVarOccFS fs) @@ -898,11 +944,6 @@ (idName id) (idType id) info ; return (setIdInfo id id_info, rhs') } -tcIfaceExpr (IfaceCast expr co) = do - expr' <- tcIfaceExpr expr - co' <- tcIfaceType co - return (Cast expr' co') - tcIfaceExpr (IfaceNote note expr) = do expr' <- tcIfaceExpr expr case note of @@ -942,14 +983,13 @@ tcIfaceDataAlt con inst_tys arg_strs rhs = do { us <- newUniqueSupply ; let uniqs = uniqsFromSupply us - ; let (ex_tvs, co_tvs, arg_ids) + ; let (ex_tvs, arg_ids) = dataConRepFSInstPat arg_strs uniqs con inst_tys - all_tvs = ex_tvs ++ co_tvs - ; rhs' <- extendIfaceTyVarEnv all_tvs $ + ; rhs' <- extendIfaceTyVarEnv ex_tvs $ extendIfaceIdEnv arg_ids $ tcIfaceExpr rhs - ; return (DataAlt con, all_tvs ++ arg_ids, rhs') } + ; return (DataAlt con, ex_tvs ++ arg_ids, rhs') } \end{code} @@ -986,10 +1026,10 @@ \begin{code} tcIdDetails :: Type -> IfaceIdDetails -> IfL IdDetails tcIdDetails _ IfVanillaId = return VanillaId -tcIdDetails ty (IfDFunId ns) - = return (DFunId ns (isNewTyCon (classTyCon cls))) +tcIdDetails ty IfDFunId + = return (DFunId (isNewTyCon (classTyCon cls))) where - (_, cls, _) = tcSplitDFunTy ty + (_, _, cls, _) = tcSplitDFunTy ty tcIdDetails _ (IfRecSelId tc naughty) = do { tc' <- tcIfaceTyCon tc @@ -1015,7 +1055,7 @@ -- The next two are lazy, so they don't transitively suck stuff in tcPrag info (HsUnfold lb if_unf) = do { unf <- tcUnfolding name ty info if_unf - ; let info1 | lb = info `setOccInfo` nonRuleLoopBreaker + ; let info1 | lb = info `setOccInfo` strongLoopBreaker | otherwise = info ; return (info1 `setUnfoldingInfoLazily` unf) } \end{code} @@ -1051,15 +1091,12 @@ } tcUnfolding name dfun_ty _ (IfDFunUnfold ops) - = do { mb_ops1 <- forkM_maybe doc $ mapM tc_arg ops + = do { mb_ops1 <- forkM_maybe doc $ mapM tcIfaceExpr ops ; return (case mb_ops1 of Nothing -> noUnfolding Just ops1 -> mkDFunUnfolding dfun_ty ops1) } where doc = text "Class ops for dfun" <+> ppr name - tc_arg (DFunPolyArg e) = do { e' <- tcIfaceExpr e; return (DFunPolyArg e') } - tc_arg (DFunConstArg e) = do { e' <- tcIfaceExpr e; return (DFunConstArg e') } - tc_arg (DFunLamArg i) = return (DFunLamArg i) tcUnfolding name ty info (IfExtWrapper arity wkr) = tcIfaceWrapper name ty info arity (tcIfaceExtId wkr) @@ -1217,6 +1254,10 @@ tcIfaceClass name = do { thing <- tcIfaceGlobal name ; return (tyThingClass thing) } +tcIfaceCoAxiom :: Name -> IfL CoAxiom +tcIfaceCoAxiom name = do { thing <- tcIfaceGlobal name + ; return (tyThingCoAxiom thing) } + tcIfaceDataCon :: Name -> IfL DataCon tcIfaceDataCon name = do { thing <- tcIfaceGlobal name ; case thing of diff -Nru ghc-7.0.3/compiler/iface/TcIface.lhs-boot ghc-7.2.1/compiler/iface/TcIface.lhs-boot --- ghc-7.0.3/compiler/iface/TcIface.lhs-boot 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/iface/TcIface.lhs-boot 2011-08-07 17:10:05.000000000 +0000 @@ -1,20 +1,21 @@ \begin{code} module TcIface where -import IfaceSyn ( IfaceDecl, IfaceInst, IfaceFamInst, IfaceRule, IfaceAnnotation ) -import TypeRep ( TyThing ) -import TcRnTypes ( IfL ) -import InstEnv ( Instance ) -import FamInstEnv ( FamInst ) -import CoreSyn ( CoreRule ) -import HscTypes ( TypeEnv, VectInfo, IfaceVectInfo ) -import Module ( Module ) + +import IfaceSyn ( IfaceDecl, IfaceInst, IfaceFamInst, IfaceRule, IfaceAnnotation ) +import TypeRep ( TyThing ) +import TcRnTypes ( IfL ) +import InstEnv ( Instance ) +import FamInstEnv ( FamInst ) +import CoreSyn ( CoreRule ) +import HscTypes ( TypeEnv, VectInfo, IfaceVectInfo ) +import Module ( Module ) import Annotations ( Annotation ) -tcIfaceDecl :: Bool -> IfaceDecl -> IfL TyThing -tcIfaceRules :: Bool -> [IfaceRule] -> IfL [CoreRule] -tcIfaceVectInfo:: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo -tcIfaceInst :: IfaceInst -> IfL Instance -tcIfaceFamInst :: IfaceFamInst -> IfL FamInst +tcIfaceDecl :: Bool -> IfaceDecl -> IfL TyThing +tcIfaceRules :: Bool -> [IfaceRule] -> IfL [CoreRule] +tcIfaceVectInfo :: Module -> TypeEnv -> IfaceVectInfo -> IfL VectInfo +tcIfaceInst :: IfaceInst -> IfL Instance +tcIfaceFamInst :: IfaceFamInst -> IfL FamInst tcIfaceAnnotations :: [IfaceAnnotation] -> IfL [Annotation] \end{code} diff -Nru ghc-7.0.3/compiler/llvmGen/Llvm/AbsSyn.hs ghc-7.2.1/compiler/llvmGen/Llvm/AbsSyn.hs --- ghc-7.0.3/compiler/llvmGen/Llvm/AbsSyn.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/llvmGen/Llvm/AbsSyn.hs 2011-08-07 17:10:05.000000000 +0000 @@ -132,6 +132,12 @@ -} | Expr LlvmExpression + {- | + A nop LLVM statement. Useful as its often more efficient to use this + then to wrap LLvmStatement in a Just or []. + -} + | Nop + deriving (Show, Eq) diff -Nru ghc-7.0.3/compiler/llvmGen/Llvm/PpLlvm.hs ghc-7.2.1/compiler/llvmGen/Llvm/PpLlvm.hs --- ghc-7.0.3/compiler/llvmGen/Llvm/PpLlvm.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/llvmGen/Llvm/PpLlvm.hs 2011-08-07 17:10:05.000000000 +0000 @@ -113,15 +113,18 @@ -- | Print out a function defenition header. ppLlvmFunctionHeader :: LlvmFunctionDecl -> [LMString] -> Doc ppLlvmFunctionHeader (LlvmFunctionDecl n l c r varg p a) args - = let varg' = if varg == VarArgs then text ", ..." else empty + = let varg' = case varg of + VarArgs | null p -> text "..." + | otherwise -> text ", ..." + _otherwise -> empty align = case a of - Just a' -> space <> text "align" <+> texts a' + Just a' -> text " align" <+> texts a' Nothing -> empty args' = map (\((ty,p),n) -> texts ty <+> ppSpaceJoin p <+> text "%" <> ftext n) (zip p args) in texts l <+> texts c <+> texts r <+> text "@" <> ftext n <> lparen <> - (hcat $ intersperse comma args') <> varg' <> rparen <> align + (hcat $ intersperse (comma <> space) args') <> varg' <> rparen <> align -- | Print out a list of function declaration. @@ -132,7 +135,18 @@ -- Declarations define the function type but don't define the actual body of -- the function. ppLlvmFunctionDecl :: LlvmFunctionDecl -> Doc -ppLlvmFunctionDecl dec = text "declare" <+> texts dec +ppLlvmFunctionDecl (LlvmFunctionDecl n l c r varg p a) + = let varg' = case varg of + VarArgs | null p -> text "..." + | otherwise -> text ", ..." + _otherwise -> empty + align = case a of + Just a' -> text " align" <+> texts a' + Nothing -> empty + args = hcat $ intersperse (comma <> space) $ + map (\(t,a) -> texts t <+> ppSpaceJoin a) p + in text "declare" <+> texts l <+> texts c <+> texts r <+> text "@" <> + ftext n <> lparen <> args <> varg' <> rparen <> align -- | Print out a list of LLVM blocks. @@ -161,6 +175,7 @@ Return result -> ppReturn result Expr expr -> ppLlvmExpression expr Unreachable -> text "unreachable" + Nop -> empty -- | Print out an LLVM expression. @@ -203,7 +218,7 @@ ppCall' (LlvmFunctionDecl _ _ cc ret argTy params _) = let tc = if ct == TailCall then text "tail " else empty ppValues = ppCommaJoin vals - ppParams = map (\(ty,p) -> texts ty <+> ppSpaceJoin p) params + ppParams = map (texts . fst) params ppArgTy = (hcat $ intersperse comma ppParams) <> (case argTy of VarArgs -> text ", ..." @@ -316,15 +331,14 @@ -- * Misc functions -------------------------------------------------------------------------------- ppCommaJoin :: (Show a) => [a] -> Doc -ppCommaJoin strs = hcat $ intersperse comma (map texts strs) +ppCommaJoin strs = hcat $ intersperse (comma <> space) (map texts strs) ppSpaceJoin :: (Show a) => [a] -> Doc ppSpaceJoin strs = hcat $ intersperse space (map texts strs) -- | Convert SDoc to Doc llvmSDoc :: Out.SDoc -> Doc -llvmSDoc d - = Out.withPprStyleDoc (Out.mkCodeStyle Out.CStyle) d +llvmSDoc d = Out.withPprStyleDoc (Out.mkCodeStyle Out.CStyle) d -- | Showable to Doc texts :: (Show a) => a -> Doc diff -Nru ghc-7.0.3/compiler/llvmGen/Llvm/Types.hs ghc-7.2.1/compiler/llvmGen/Llvm/Types.hs --- ghc-7.0.3/compiler/llvmGen/Llvm/Types.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/llvmGen/Llvm/Types.hs 2011-08-07 17:10:05.000000000 +0000 @@ -7,6 +7,7 @@ #include "HsVersions.h" import Data.Char +import Data.List (intercalate) import Numeric import Constants @@ -59,12 +60,12 @@ show (LMStruct tys ) = "<{" ++ (commaCat tys) ++ "}>" show (LMFunction (LlvmFunctionDecl _ _ _ r varg p _)) - = let args = ((drop 1).concat) $ -- use drop since it can handle empty lists - map (\(t,a) -> "," ++ show t ++ " " ++ spaceCat a) p - varg' = case varg of - VarArgs | not (null args) -> ", ..." - | otherwise -> "..." - _otherwise -> "" + = let varg' = case varg of + VarArgs | null args -> "..." + | otherwise -> ", ..." + _otherwise -> "" + -- by default we don't print param attributes + args = intercalate ", " $ map (show . fst) p in show r ++ " (" ++ args ++ varg' ++ ")" show (LMAlias (s,_)) = "%" ++ unpackFS s @@ -135,29 +136,13 @@ show (LMStaticLit l ) = show l show (LMUninitType t) = show t ++ " undef" show (LMStaticStr s t) = show t ++ " c\"" ++ unpackFS s ++ "\\00\"" - - show (LMStaticArray d t) - = let struc = case d of - [] -> "[]" - ts -> "[" ++ show (head ts) ++ - concat (map (\x -> "," ++ show x) (tail ts)) ++ "]" - in show t ++ " " ++ struc - - show (LMStaticStruc d t) - = let struc = case d of - [] -> "<{}>" - ts -> "<{" ++ show (head ts) ++ - concat (map (\x -> "," ++ show x) (tail ts)) ++ "}>" - in show t ++ " " ++ struc - + show (LMStaticArray d t) = show t ++ " [" ++ commaCat d ++ "]" + show (LMStaticStruc d t) = show t ++ "<{" ++ commaCat d ++ "}>" show (LMStaticPointer v) = show v - show (LMBitc v t) = show t ++ " bitcast (" ++ show v ++ " to " ++ show t ++ ")" - show (LMPtoI v t) = show t ++ " ptrtoint (" ++ show v ++ " to " ++ show t ++ ")" - show (LMAdd s1 s2) = let ty1 = getStatType s1 op = if isFloat ty1 then " fadd (" else " add (" @@ -176,13 +161,7 @@ -- | Concatenate an array together, separated by commas commaCat :: Show a => [a] -> String -commaCat [] = "" -commaCat x = show (head x) ++ (concat $ map (\y -> "," ++ show y) (tail x)) - --- | Concatenate an array together, separated by commas -spaceCat :: Show a => [a] -> String -spaceCat [] = "" -spaceCat x = show (head x) ++ (concat $ map (\y -> " " ++ show y) (tail x)) +commaCat xs = intercalate ", " $ map show xs -- ----------------------------------------------------------------------------- -- ** Operations on LLVM Basic Types and Variables @@ -207,12 +186,12 @@ -- | Print a literal value. No type. getLit :: LlvmLit -> String -getLit (LMIntLit i _) = show ((fromInteger i)::Int) +getLit (LMIntLit i _ ) = show ((fromInteger i)::Int) getLit (LMFloatLit r LMFloat ) = fToStr $ realToFrac r getLit (LMFloatLit r LMDouble) = dToStr r getLit f@(LMFloatLit _ _) = error $ "Can't print this float literal!" ++ show f -getLit (LMNullLit _) = "null" -getLit (LMUndefLit _) = "undef" +getLit (LMNullLit _ ) = "null" +getLit (LMUndefLit _ ) = "undef" -- | Return the 'LlvmType' of the 'LlvmVar' getVarType :: LlvmVar -> LlvmType @@ -366,15 +345,15 @@ instance Show LlvmFunctionDecl where show (LlvmFunctionDecl n l c r varg p a) - = let args = ((drop 1).concat) $ -- use drop since it can handle empty lists - map (\(t,a) -> "," ++ show t ++ " " ++ spaceCat a) p - varg' = case varg of - VarArgs | not (null args) -> ", ..." - | otherwise -> "..." - _otherwise -> "" + = let varg' = case varg of + VarArgs | null args -> "..." + | otherwise -> ", ..." + _otherwise -> "" align = case a of Just a' -> " align " ++ show a' Nothing -> "" + -- by default we don't print param attributes + args = intercalate ", " $ map (show . fst) p in show l ++ " " ++ show c ++ " " ++ show r ++ " @" ++ unpackFS n ++ "(" ++ args ++ varg' ++ ")" ++ align diff -Nru ghc-7.0.3/compiler/llvmGen/LlvmCodeGen/Base.hs ghc-7.2.1/compiler/llvmGen/LlvmCodeGen/Base.hs --- ghc-7.0.3/compiler/llvmGen/LlvmCodeGen/Base.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/llvmGen/LlvmCodeGen/Base.hs 2011-08-07 17:10:05.000000000 +0000 @@ -9,8 +9,10 @@ LlvmCmmTop, LlvmBasicBlock, LlvmUnresData, LlvmData, UnresLabel, UnresStatic, + LlvmVersion, defaultLlvmVersion, + LlvmEnv, initLlvmEnv, clearVars, varLookup, varInsert, - funLookup, funInsert, + funLookup, funInsert, getLlvmVer, setLlvmVer, cmmToLlvmType, widthToLlvmFloat, widthToLlvmInt, llvmFunTy, llvmFunSig, llvmStdFunAttrs, llvmFunAlign, llvmInfAlign, @@ -27,9 +29,10 @@ import CLabel import CgUtils ( activeStgRegs ) -import Cmm +import Config import Constants import FastString +import OldCmm import qualified Outputable as Outp import UniqFM import Unique @@ -38,7 +41,7 @@ -- * Some Data Types -- -type LlvmCmmTop = GenCmmTop LlvmData [CmmStatic] (ListGraph LlvmStatement) +type LlvmCmmTop = GenCmmTop [LlvmData] (Maybe CmmStatics) (ListGraph LlvmStatement) type LlvmBasicBlock = GenBasicBlock LlvmStatement -- | Unresolved code. @@ -78,7 +81,8 @@ -- | GHC Call Convention for LLVM llvmGhcCC :: LlvmCallConvention -llvmGhcCC = CC_Ncc 10 +llvmGhcCC | cGhcUnregisterised == "NO" = CC_Ncc 10 + | otherwise = CC_Ccc -- | Llvm Function type for Cmm function llvmFunTy :: LlvmType @@ -128,33 +132,50 @@ llvmPtrBits :: Int llvmPtrBits = widthInBits $ typeWidth gcWord +-- ---------------------------------------------------------------------------- +-- * Llvm Version +-- + +-- | LLVM Version Number +type LlvmVersion = Int + +-- | The LLVM Version we assume if we don't know +defaultLlvmVersion :: LlvmVersion +defaultLlvmVersion = 28 -- ---------------------------------------------------------------------------- -- * Environment Handling -- -type LlvmEnvMap = UniqFM LlvmType -- two maps, one for functions and one for local vars. -type LlvmEnv = (LlvmEnvMap, LlvmEnvMap) +newtype LlvmEnv = LlvmEnv (LlvmEnvMap, LlvmEnvMap, LlvmVersion) +type LlvmEnvMap = UniqFM LlvmType -- | Get initial Llvm environment. initLlvmEnv :: LlvmEnv -initLlvmEnv = (emptyUFM, emptyUFM) +initLlvmEnv = LlvmEnv (emptyUFM, emptyUFM, defaultLlvmVersion) -- | Clear variables from the environment. clearVars :: LlvmEnv -> LlvmEnv -clearVars (e1, _) = (e1, emptyUFM) +clearVars (LlvmEnv (e1, _, n)) = LlvmEnv (e1, emptyUFM, n) -- | Insert functions into the environment. varInsert, funInsert :: Uniquable key => key -> LlvmType -> LlvmEnv -> LlvmEnv -varInsert s t (e1, e2) = (e1, addToUFM e2 s t) -funInsert s t (e1, e2) = (addToUFM e1 s t, e2) +varInsert s t (LlvmEnv (e1, e2, n)) = LlvmEnv (e1, addToUFM e2 s t, n) +funInsert s t (LlvmEnv (e1, e2, n)) = LlvmEnv (addToUFM e1 s t, e2, n) -- | Lookup functions in the environment. varLookup, funLookup :: Uniquable key => key -> LlvmEnv -> Maybe LlvmType -varLookup s (_, e2) = lookupUFM e2 s -funLookup s (e1, _) = lookupUFM e1 s +varLookup s (LlvmEnv (_, e2, _)) = lookupUFM e2 s +funLookup s (LlvmEnv (e1, _, _)) = lookupUFM e1 s +-- | Get the LLVM version we are generating code for +getLlvmVer :: LlvmEnv -> LlvmVersion +getLlvmVer (LlvmEnv (_, _, n)) = n + +-- | Set the LLVM version we are generating code for +setLlvmVer :: LlvmVersion -> LlvmEnv -> LlvmEnv +setLlvmVer n (LlvmEnv (e1, e2, _)) = LlvmEnv (e1, e2, n) -- ---------------------------------------------------------------------------- -- * Label handling diff -Nru ghc-7.0.3/compiler/llvmGen/LlvmCodeGen/CodeGen.hs ghc-7.2.1/compiler/llvmGen/LlvmCodeGen/CodeGen.hs --- ghc-7.0.3/compiler/llvmGen/LlvmCodeGen/CodeGen.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/llvmGen/LlvmCodeGen/CodeGen.hs 2011-08-07 17:10:05.000000000 +0000 @@ -1,3 +1,4 @@ +{-# OPTIONS -fno-warn-type-defaults #-} -- ---------------------------------------------------------------------------- -- | Handle conversion of CmmProc to LLVM code. -- @@ -13,11 +14,10 @@ import BlockId import CgUtils ( activeStgRegs, callerSaves ) import CLabel -import Cmm -import qualified PprCmm +import OldCmm +import qualified OldPprCmm as PprCmm import OrdList -import BasicTypes import FastString import ForeignCall import Outputable hiding ( panic, pprPanic ) @@ -29,28 +29,19 @@ import Data.List ( partition ) import Control.Monad ( liftM ) -type LlvmStatements = OrdList LlvmStatement +type LlvmStatements = OrdList LlvmStatement -- ----------------------------------------------------------------------------- -- | Top-level of the LLVM proc Code generator -- genLlvmProc :: LlvmEnv -> RawCmmTop -> UniqSM (LlvmEnv, [LlvmCmmTop]) -genLlvmProc env (CmmData _ _) - = return (env, []) - -genLlvmProc env (CmmProc _ _ _ (ListGraph [])) - = return (env, []) - -genLlvmProc env (CmmProc info lbl params (ListGraph blocks)) - = do - (env', lmblocks, lmdata) <- basicBlocksCodeGen env blocks ([], []) - - let proc = CmmProc info lbl params (ListGraph lmblocks) - let tops = lmdata ++ [proc] - - return (env', tops) +genLlvmProc env (CmmProc info lbl (ListGraph blocks)) = do + (env', lmblocks, lmdata) <- basicBlocksCodeGen env blocks ([], []) + let proc = CmmProc info lbl (ListGraph lmblocks) + return (env', proc:lmdata) +genLlvmProc _ _ = panic "genLlvmProc: case that shouldn't reach here!" -- ----------------------------------------------------------------------------- -- * Block code generation @@ -147,7 +138,7 @@ -- | Foreign Calls -genCall :: LlvmEnv -> CmmCallTarget -> HintedCmmFormals -> HintedCmmActuals +genCall :: LlvmEnv -> CmmCallTarget -> [HintedCmmFormal] -> [HintedCmmActual] -> CmmReturnInfo -> UniqSM StmtData -- Write barrier needs to be handled specially as it is implemented as an LLVM @@ -175,9 +166,31 @@ where lmTrue :: LlvmVar - lmTrue = LMLitVar $ LMIntLit (-1) i1 + lmTrue = mkIntLit i1 (-1) #endif +-- Handle memcpy function specifically since llvm's intrinsic version takes +-- some extra parameters. +genCall env t@(CmmPrim op) [] args CmmMayReturn | op == MO_Memcpy || + op == MO_Memset || + op == MO_Memmove = do + let (isVolTy, isVolVal) = if getLlvmVer env >= 28 + then ([i1], [mkIntLit i1 0]) else ([], []) + argTy | op == MO_Memset = [i8Ptr, i8, llvmWord, i32] ++ isVolTy + | otherwise = [i8Ptr, i8Ptr, llvmWord, i32] ++ isVolTy + funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible + CC_Ccc LMVoid FixedArgs (tysToParams argTy) Nothing + + (env1, argVars, stmts1, top1) <- arg_vars env args ([], nilOL, []) + (env2, fptr, stmts2, top2) <- getFunPtr env1 funTy t + (argVars', stmts3) <- castVars $ zip argVars argTy + + let arguments = argVars' ++ isVolVal + call = Expr $ Call StdCall fptr arguments [] + stmts = stmts1 `appOL` stmts2 `appOL` stmts3 + `appOL` trashStmts `snocOL` call + return (env2, stmts, top1 ++ top2) + -- Handle all other foreign calls and prim ops. genCall env target res args ret = do @@ -225,91 +238,17 @@ let ccTy = StdCall -- tail calls should be done through CmmJump let retTy = ret_type res let argTy = tysToParams $ map arg_type args - let funTy name = LMFunction $ LlvmFunctionDecl name ExternallyVisible - lmconv retTy FixedArgs argTy llvmFunAlign - - -- get parameter values - (env1, argVars, stmts1, top1) <- arg_vars env args ([], nilOL, []) + let funTy = \name -> LMFunction $ LlvmFunctionDecl name ExternallyVisible + lmconv retTy FixedArgs argTy llvmFunAlign - -- get the return register - let ret_reg ([CmmHinted reg hint]) = (reg, hint) - ret_reg t = panic $ "genCall: Bad number of registers! Can only handle" - ++ " 1, given " ++ show (length t) ++ "." - - -- deal with call types - let getFunPtr :: CmmCallTarget -> UniqSM ExprData - getFunPtr targ = case targ of - CmmCallee (CmmLit (CmmLabel lbl)) _ -> do - let name = strCLabel_llvm lbl - case funLookup name env1 of - Just ty'@(LMFunction sig) -> do - -- Function in module in right form - let fun = LMGlobalVar name ty' (funcLinkage sig) - Nothing Nothing False - return (env1, fun, nilOL, []) - - Just ty' -> do - -- label in module but not function pointer, convert - let fty@(LMFunction sig) = funTy name - let fun = LMGlobalVar name (pLift ty') (funcLinkage sig) - Nothing Nothing False - (v1, s1) <- doExpr (pLift fty) - $ Cast LM_Bitcast fun (pLift fty) - return (env1, v1, unitOL s1, []) - - Nothing -> do - -- label not in module, create external reference - let fty@(LMFunction sig) = funTy name - let fun = LMGlobalVar name fty (funcLinkage sig) - Nothing Nothing False - let top = CmmData Data [([],[fty])] - let env' = funInsert name fty env1 - return (env', fun, nilOL, [top]) - - CmmCallee expr _ -> do - (env', v1, stmts, top) <- exprToVar env1 expr - let fty = funTy $ fsLit "dynamic" - let cast = case getVarType v1 of - ty | isPointer ty -> LM_Bitcast - ty | isInt ty -> LM_Inttoptr - - ty -> panic $ "genCall: Expr is of bad type for function" - ++ " call! (" ++ show (ty) ++ ")" - - (v2,s1) <- doExpr (pLift fty) $ Cast cast v1 (pLift fty) - return (env', v2, stmts `snocOL` s1, top) - - CmmPrim mop -> do - let name = cmmPrimOpFunctions mop - let lbl = mkForeignLabel name Nothing - ForeignLabelInExternalPackage IsFunction - getFunPtr $ CmmCallee (CmmLit (CmmLabel lbl)) CCallConv - (env2, fptr, stmts2, top2) <- getFunPtr target + (env1, argVars, stmts1, top1) <- arg_vars env args ([], nilOL, []) + (env2, fptr, stmts2, top2) <- getFunPtr env1 funTy target let retStmt | ccTy == TailCall = unitOL $ Return Nothing | ret == CmmNeverReturns = unitOL $ Unreachable | otherwise = nilOL - {- In LLVM we pass the STG registers around everywhere in function calls. - So this means LLVM considers them live across the entire function, when - in reality they usually aren't. For Caller save registers across C calls - the saving and restoring of them is done by the Cmm code generator, - using Cmm local vars. So to stop LLVM saving them as well (and saving - all of them since it thinks they're always live, we trash them just - before the call by assigning the 'undef' value to them. The ones we - need are restored from the Cmm local var and the ones we don't need - are fine to be trashed. - -} - let trashStmts = concatOL $ map trashReg activeStgRegs - where trashReg r = - let reg = lmGlobalRegVar r - ty = (pLower . getVarType) reg - trash = unitOL $ Store (LMLitVar $ LMUndefLit ty) reg - in case callerSaves r of - True -> trash - False -> nilOL - let stmts = stmts1 `appOL` stmts2 `appOL` trashStmts -- make the actual call @@ -321,6 +260,10 @@ _ -> do (v1, s1) <- doExpr retTy $ Call ccTy fptr argVars fnAttrs + -- get the return register + let ret_reg ([CmmHinted reg hint]) = (reg, hint) + ret_reg t = panic $ "genCall: Bad number of registers! Can only handle" + ++ " 1, given " ++ show (length t) ++ "." let (creg, _) = ret_reg res let (env3, vreg, stmts3, top3) = getCmmReg env2 (CmmLocal creg) let allStmts = stmts `snocOL` s1 `appOL` stmts3 @@ -344,9 +287,58 @@ `appOL` retStmt, top1 ++ top2 ++ top3) +-- | Create a function pointer from a target. +getFunPtr :: LlvmEnv -> (LMString -> LlvmType) -> CmmCallTarget + -> UniqSM ExprData +getFunPtr env funTy targ = case targ of + CmmCallee (CmmLit (CmmLabel lbl)) _ -> litCase $ strCLabel_llvm lbl + + CmmCallee expr _ -> do + (env', v1, stmts, top) <- exprToVar env expr + let fty = funTy $ fsLit "dynamic" + cast = case getVarType v1 of + ty | isPointer ty -> LM_Bitcast + ty | isInt ty -> LM_Inttoptr + + ty -> panic $ "genCall: Expr is of bad type for function" + ++ " call! (" ++ show (ty) ++ ")" + + (v2,s1) <- doExpr (pLift fty) $ Cast cast v1 (pLift fty) + return (env', v2, stmts `snocOL` s1, top) + + CmmPrim mop -> litCase $ cmmPrimOpFunctions env mop + + where + litCase name = do + case funLookup name env of + Just ty'@(LMFunction sig) -> do + -- Function in module in right form + let fun = LMGlobalVar name ty' (funcLinkage sig) + Nothing Nothing False + return (env, fun, nilOL, []) + + Just ty' -> do + -- label in module but not function pointer, convert + let fty@(LMFunction sig) = funTy name + fun = LMGlobalVar name (pLift ty') (funcLinkage sig) + Nothing Nothing False + (v1, s1) <- doExpr (pLift fty) + $ Cast LM_Bitcast fun (pLift fty) + return (env, v1, unitOL s1, []) + + Nothing -> do + -- label not in module, create external reference + let fty@(LMFunction sig) = funTy name + fun = LMGlobalVar name fty (funcLinkage sig) + Nothing Nothing False + top = [CmmData Data [([],[fty])]] + env' = funInsert name fty env + return (env', fun, nilOL, top) + + -- | Conversion of call arguments. arg_vars :: LlvmEnv - -> HintedCmmActuals + -> [HintedCmmActual] -> ([LlvmVar], LlvmStatements, [LlvmCmmTop]) -> UniqSM (LlvmEnv, [LlvmVar], LlvmStatements, [LlvmCmmTop]) @@ -370,9 +362,41 @@ = do (env', v1, stmts', top') <- exprToVar env e arg_vars env' rest (vars ++ [v1], stmts `appOL` stmts', tops ++ top') + +-- | Cast a collection of LLVM variables to specific types. +castVars :: [(LlvmVar, LlvmType)] + -> UniqSM ([LlvmVar], LlvmStatements) +castVars vars = do + done <- mapM (uncurry castVar) vars + let (vars', stmts) = unzip done + return (vars', toOL stmts) + +-- | Cast an LLVM variable to a specific type, panicing if it can't be done. +castVar :: LlvmVar -> LlvmType -> UniqSM (LlvmVar, LlvmStatement) +castVar v t | getVarType v == t + = return (v, Nop) + + | otherwise + = let op = case (getVarType v, t) of + (LMInt n, LMInt m) + -> if n < m then LM_Sext else LM_Trunc + (vt, _) | isFloat vt && isFloat t + -> if llvmWidthInBits vt < llvmWidthInBits t + then LM_Fpext else LM_Fptrunc + (vt, _) | isInt vt && isFloat t -> LM_Sitofp + (vt, _) | isFloat vt && isInt t -> LM_Fptosi + (vt, _) | isInt vt && isPointer t -> LM_Inttoptr + (vt, _) | isPointer vt && isInt t -> LM_Ptrtoint + (vt, _) | isPointer vt && isPointer t -> LM_Bitcast + + (vt, _) -> panic $ "castVars: Can't cast this type (" + ++ show vt ++ ") to (" ++ show t ++ ")" + in doExpr t $ Cast op v t + + -- | Decide what C function to use to implement a CallishMachOp -cmmPrimOpFunctions :: CallishMachOp -> FastString -cmmPrimOpFunctions mop +cmmPrimOpFunctions :: LlvmEnv -> CallishMachOp -> LMString +cmmPrimOpFunctions env mop = case mop of MO_F32_Exp -> fsLit "expf" MO_F32_Log -> fsLit "logf" @@ -408,8 +432,18 @@ MO_F64_Cosh -> fsLit "cosh" MO_F64_Tanh -> fsLit "tanh" + MO_Memcpy -> fsLit $ "llvm.memcpy." ++ intrinTy1 + MO_Memmove -> fsLit $ "llvm.memmove." ++ intrinTy1 + MO_Memset -> fsLit $ "llvm.memset." ++ intrinTy2 + a -> panic $ "cmmPrimOpFunctions: Unknown callish op! (" ++ show a ++ ")" + where + intrinTy1 = (if getLlvmVer env >= 28 + then "p0i8.p0i8." else "") ++ show llvmWord + intrinTy2 = (if getLlvmVer env >= 28 + then "p0i8." else "") ++ show llvmWord + -- | Tail function calls genJump :: LlvmEnv -> CmmExpr -> UniqSM StmtData @@ -594,7 +628,7 @@ (env', vc, stmts, top) <- exprToVar env cond let ty = getVarType vc - let pairs = [ (ix, id) | (ix,Just id) <- zip ([0..]::[Integer]) maybe_ids ] + let pairs = [ (ix, id) | (ix,Just id) <- zip [0..] maybe_ids ] let labels = map (\(ix, b) -> (mkIntLit ty ix, blockIdToLlvm b)) pairs -- out of range is undefied, so lets just branch to first label let (_, defLbl) = head labels @@ -675,11 +709,11 @@ genMachOp env _ op [x] = case op of MO_Not w -> - let all1 = mkIntLit (widthToLlvmInt w) (-1::Int) + let all1 = mkIntLit (widthToLlvmInt w) (-1) in negate (widthToLlvmInt w) all1 LM_MO_Xor MO_S_Neg w -> - let all0 = mkIntLit (widthToLlvmInt w) (0::Int) + let all0 = mkIntLit (widthToLlvmInt w) 0 in negate (widthToLlvmInt w) all0 LM_MO_Sub MO_F_Neg w -> @@ -1107,6 +1141,28 @@ return (vars, concatOL stmts) +-- | A serries of statements to trash all the STG registers. +-- +-- In LLVM we pass the STG registers around everywhere in function calls. +-- So this means LLVM considers them live across the entire function, when +-- in reality they usually aren't. For Caller save registers across C calls +-- the saving and restoring of them is done by the Cmm code generator, +-- using Cmm local vars. So to stop LLVM saving them as well (and saving +-- all of them since it thinks they're always live, we trash them just +-- before the call by assigning the 'undef' value to them. The ones we +-- need are restored from the Cmm local var and the ones we don't need +-- are fine to be trashed. +trashStmts :: LlvmStatements +trashStmts = concatOL $ map trashReg activeStgRegs + where trashReg r = + let reg = lmGlobalRegVar r + ty = (pLower . getVarType) reg + trash = unitOL $ Store (LMLitVar $ LMUndefLit ty) reg + in case callerSaves r of + True -> trash + False -> nilOL + + -- | Get a function pointer to the CLabel specified. -- -- This is for Haskell functions, function type is assumed, so doesn't work diff -Nru ghc-7.0.3/compiler/llvmGen/LlvmCodeGen/Data.hs ghc-7.2.1/compiler/llvmGen/LlvmCodeGen/Data.hs --- ghc-7.0.3/compiler/llvmGen/LlvmCodeGen/Data.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/llvmGen/LlvmCodeGen/Data.hs 2011-08-07 17:10:05.000000000 +0000 @@ -13,7 +13,7 @@ import BlockId import CLabel -import Cmm +import OldCmm import FastString import qualified Outputable @@ -37,8 +37,8 @@ -- complete this completely though as we need to pass all CmmStatic -- sections before all references can be resolved. This last step is -- done by 'resolveLlvmData'. -genLlvmData :: (Section, [CmmStatic]) -> LlvmUnresData -genLlvmData (sec, CmmDataLabel lbl:xs) = +genLlvmData :: (Section, CmmStatics) -> LlvmUnresData +genLlvmData (sec, Statics lbl xs) = let static = map genData xs label = strCLabel_llvm lbl @@ -50,8 +50,6 @@ alias = LMAlias ((label `appendFS` structStr), strucTy) in (lbl, sec, alias, static) -genLlvmData _ = panic "genLlvmData: CmmData section doesn't start with label!" - resolveLlvmDatas :: LlvmEnv -> [LlvmUnresData] -> [LlvmData] -> (LlvmEnv, [LlvmData]) @@ -150,7 +148,6 @@ -- -- | Handle static data --- Don't handle 'CmmAlign' or a 'CmmDataLabel'. genData :: CmmStatic -> UnresStatic genData (CmmString str) = @@ -164,12 +161,6 @@ genData (CmmStaticLit lit) = genStaticLit lit -genData (CmmAlign _) - = panic "genData: Can't handle CmmAlign!" - -genData (CmmDataLabel _) - = panic "genData: Can't handle data labels not at top of data!" - -- | Generate Llvm code for a static literal. -- diff -Nru ghc-7.0.3/compiler/llvmGen/LlvmCodeGen/Ppr.hs ghc-7.2.1/compiler/llvmGen/LlvmCodeGen/Ppr.hs --- ghc-7.0.3/compiler/llvmGen/LlvmCodeGen/Ppr.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/llvmGen/LlvmCodeGen/Ppr.hs 2011-08-07 17:10:05.000000000 +0000 @@ -13,7 +13,7 @@ import LlvmCodeGen.Data import CLabel -import Cmm +import OldCmm import FastString import qualified Outputable @@ -82,16 +82,16 @@ pprLlvmCmmTop _ _ (CmmData _ lmdata) = (vcat $ map pprLlvmData lmdata, []) -pprLlvmCmmTop env count (CmmProc info lbl _ (ListGraph blks)) - = let static = CmmDataLabel lbl : info - (idoc, ivar) = if not (null info) - then pprInfoTable env count lbl static - else (empty, []) +pprLlvmCmmTop env count (CmmProc mb_info entry_lbl (ListGraph blks)) + = let (idoc, ivar) = case mb_info of + Nothing -> (empty, []) + Just (Statics info_lbl dat) + -> pprInfoTable env count info_lbl (Statics entry_lbl dat) in (idoc $+$ ( let sec = mkLayoutSection (count + 1) - (lbl',sec') = if not (null info) - then (entryLblToInfoLbl lbl, sec) - else (lbl, Nothing) + (lbl',sec') = case mb_info of + Nothing -> (entry_lbl, Nothing) + Just (Statics info_lbl _) -> (info_lbl, sec) link = if externallyVisibleCLabel lbl' then ExternallyVisible else Internal @@ -103,14 +103,14 @@ -- | Pretty print CmmStatic -pprInfoTable :: LlvmEnv -> Int -> CLabel -> [CmmStatic] -> (Doc, [LlvmVar]) -pprInfoTable env count lbl stat +pprInfoTable :: LlvmEnv -> Int -> CLabel -> CmmStatics -> (Doc, [LlvmVar]) +pprInfoTable env count info_lbl stat = let unres = genLlvmData (Text, stat) (_, (ldata, ltypes)) = resolveLlvmData env unres setSection ((LMGlobalVar _ ty l _ _ c), d) = let sec = mkLayoutSection count - ilabel = strCLabel_llvm (entryLblToInfoLbl lbl) + ilabel = strCLabel_llvm info_lbl `appendFS` fsLit iTableSuf gv = LMGlobalVar ilabel ty l sec llvmInfAlign c v = if l == Internal then [gv] else [] @@ -122,34 +122,25 @@ then Outputable.panic "LlvmCodeGen.Ppr: invalid info table!" else (pprLlvmData ([ldata'], ltypes), llvmUsed) + -- | We generate labels for info tables by converting them to the same label -- as for the entry code but adding this string as a suffix. iTableSuf :: String iTableSuf = "_itable" --- | Create an appropriate section declaration for subsection of text --- WARNING: This technique could fail as gas documentation says it only --- supports up to 8192 subsections per section. Inspection of the source --- code and some test programs seem to suggest it supports more than this --- so we are hoping it does. +-- | Create a specially crafted section declaration that encodes the order this +-- section should be in the final object code. +-- +-- The LlvmMangler.llvmFixupAsm pass over the assembly produced by LLVM uses +-- this section declaration to do its processing. mkLayoutSection :: Int -> LMSection mkLayoutSection n - -- On OSX we can't use the GNU Assembler, we must use the OSX assembler, which - -- doesn't support subsections. So we post process the assembly code, this - -- section specifier will be replaced with '.text' by the mangler. - = Just (fsLit $ infoSection ++ show n -#if darwin_TARGET_OS - ) -#else - ++ "#") -#endif + = Just (fsLit $ infoSection ++ show n) --- | The section we are putting info tables and their entry code into + +-- | The section we are putting info tables and their entry code into, should +-- be unique since we process the assembly pattern matching this. infoSection :: String -#if darwin_TARGET_OS -infoSection = "__STRIP,__me" -#else -infoSection = ".text; .text " -#endif +infoSection = "X98A__STRIP,__me" diff -Nru ghc-7.0.3/compiler/llvmGen/LlvmCodeGen/Regs.hs ghc-7.2.1/compiler/llvmGen/LlvmCodeGen/Regs.hs --- ghc-7.0.3/compiler/llvmGen/LlvmCodeGen/Regs.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/llvmGen/LlvmCodeGen/Regs.hs 2011-08-07 17:10:05.000000000 +0000 @@ -38,6 +38,8 @@ VanillaReg 4 _ -> wordGlobal $ "R4" ++ suf VanillaReg 5 _ -> wordGlobal $ "R5" ++ suf VanillaReg 6 _ -> wordGlobal $ "R6" ++ suf + VanillaReg 7 _ -> wordGlobal $ "R7" ++ suf + VanillaReg 8 _ -> wordGlobal $ "R8" ++ suf SpLim -> wordGlobal $ "SpLim" ++ suf FloatReg 1 -> floatGlobal $"F1" ++ suf FloatReg 2 -> floatGlobal $"F2" ++ suf diff -Nru ghc-7.0.3/compiler/llvmGen/LlvmCodeGen.hs ghc-7.2.1/compiler/llvmGen/LlvmCodeGen.hs --- ghc-7.0.3/compiler/llvmGen/LlvmCodeGen.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/llvmGen/LlvmCodeGen.hs 2011-08-07 17:10:05.000000000 +0000 @@ -7,18 +7,15 @@ #include "HsVersions.h" import Llvm - import LlvmCodeGen.Base import LlvmCodeGen.CodeGen import LlvmCodeGen.Data import LlvmCodeGen.Ppr - import LlvmMangler -import CLabel -import Cmm import CgUtils ( fixStgRegisters ) -import PprCmm +import OldCmm +import OldPprCmm import BufWrite import DynFlags @@ -28,7 +25,9 @@ import qualified Pretty as Prt import UniqSupply import Util +import SysTools ( figureLlvmVersion ) +import Data.Maybe ( fromMaybe ) import System.IO -- ----------------------------------------------------------------------------- @@ -38,20 +37,19 @@ llvmCodeGen dflags h us cmms = let cmm = concat $ map (\(Cmm top) -> top) cmms (cdata,env) = foldr split ([],initLlvmEnv) cmm - split (CmmData s d' ) (d,e) = ((s,d'):d,e) - split (CmmProc i l _ _) (d,e) = - let lbl = strCLabel_llvm $ if not (null i) - then entryLblToInfoLbl l - else l + split (CmmData s d' ) (d,e) = ((s,d'):d,e) + split (CmmProc i l _) (d,e) = + let lbl = strCLabel_llvm $ case i of + Nothing -> l + Just (Statics info_lbl _) -> info_lbl env' = funInsert lbl llvmFunTy e in (d,env') in do bufh <- newBufHandle h Prt.bufLeftRender bufh $ pprLlvmHeader - - env' <- cmmDataLlvmGens dflags bufh env cdata [] + ver <- (fromMaybe defaultLlvmVersion) `fmap` figureLlvmVersion dflags + env' <- cmmDataLlvmGens dflags bufh (setLlvmVer ver env) cdata [] cmmProcLlvmGens dflags bufh us env' cmm 1 [] - bFlush bufh return () @@ -59,7 +57,7 @@ -- ----------------------------------------------------------------------------- -- | Do LLVM code generation on all these Cmms data sections. -- -cmmDataLlvmGens :: DynFlags -> BufHandle -> LlvmEnv -> [(Section,[CmmStatic])] +cmmDataLlvmGens :: DynFlags -> BufHandle -> LlvmEnv -> [(Section,CmmStatics)] -> [LlvmUnresData] -> IO ( LlvmEnv ) cmmDataLlvmGens dflags h env [] lmdata @@ -80,41 +78,44 @@ -- | Do LLVM code generation on all these Cmms procs. -- cmmProcLlvmGens :: DynFlags -> BufHandle -> UniqSupply -> LlvmEnv -> [RawCmmTop] - -> Int -- ^ count, used for generating unique subsections - -> [LlvmVar] -- ^ info tables that need to be marked as 'used' + -> Int -- ^ count, used for generating unique subsections + -> [[LlvmVar]] -- ^ info tables that need to be marked as 'used' -> IO () cmmProcLlvmGens _ _ _ _ [] _ [] = return () cmmProcLlvmGens _ h _ _ [] _ ivars - = let cast x = LMBitc (LMStaticPointer (pVarLift x)) i8Ptr - ty = (LMArray (length ivars) i8Ptr) - usedArray = LMStaticArray (map cast ivars) ty + = let ivars' = concat ivars + cast x = LMBitc (LMStaticPointer (pVarLift x)) i8Ptr + ty = (LMArray (length ivars') i8Ptr) + usedArray = LMStaticArray (map cast ivars') ty lmUsed = (LMGlobalVar (fsLit "llvm.used") ty Appending (Just $ fsLit "llvm.metadata") Nothing False, Just usedArray) in Prt.bufLeftRender h $ pprLlvmData ([lmUsed], []) -cmmProcLlvmGens dflags h us env (cmm : cmms) count ivars - = do - (us', env', llvm) <- cmmLlvmGen dflags us (clearVars env) cmm +cmmProcLlvmGens dflags h us env ((CmmData _ _) : cmms) count ivars + = cmmProcLlvmGens dflags h us env cmms count ivars + +cmmProcLlvmGens dflags h us env ((CmmProc _ _ (ListGraph [])) : cmms) count ivars + = cmmProcLlvmGens dflags h us env cmms count ivars +cmmProcLlvmGens dflags h us env (cmm : cmms) count ivars = do + (us', env', llvm) <- cmmLlvmGen dflags us (clearVars env) cmm let (docs, ivar) = mapAndUnzip (pprLlvmCmmTop env' count) llvm Prt.bufLeftRender h $ Prt.vcat docs - - cmmProcLlvmGens dflags h us' env' cmms (count + 2) (concat ivar ++ ivars) + cmmProcLlvmGens dflags h us' env' cmms (count + 2) (ivar ++ ivars) -- | Complete LLVM code generation phase for a single top-level chunk of Cmm. cmmLlvmGen :: DynFlags -> UniqSupply -> LlvmEnv -> RawCmmTop -> IO ( UniqSupply, LlvmEnv, [LlvmCmmTop] ) -cmmLlvmGen dflags us env cmm - = do +cmmLlvmGen dflags us env cmm = do -- rewrite assignments to global regs let fixed_cmm = fixStgRegisters cmm dumpIfSet_dyn dflags Opt_D_dump_opt_cmm "Optimised Cmm" - (pprCmm $ Cmm [fixed_cmm]) + (pprCmm (targetPlatform dflags) $ Cmm [fixed_cmm]) -- generate llvm code from cmm let ((env', llvmBC), usGen) = initUs us $ genLlvmProc env fixed_cmm diff -Nru ghc-7.0.3/compiler/llvmGen/LlvmMangler.hs ghc-7.2.1/compiler/llvmGen/LlvmMangler.hs --- ghc-7.0.3/compiler/llvmGen/LlvmMangler.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/llvmGen/LlvmMangler.hs 2011-08-07 17:10:05.000000000 +0000 @@ -1,35 +1,50 @@ +{-# OPTIONS -fno-warn-unused-binds #-} -- ----------------------------------------------------------------------------- -- | GHC LLVM Mangler -- -- This script processes the assembly produced by LLVM, rearranging the code --- so that an info table appears before its corresponding function. We also --- use it to fix up the stack alignment, which needs to be 16 byte aligned --- but always ends up off by 4 bytes because GHC sets it to the 'wrong' --- starting value in the RTS. +-- so that an info table appears before its corresponding function. -- --- We only need this for Mac OS X, other targets don't use it. +-- On OSX we also use it to fix up the stack alignment, which needs to be 16 +-- byte aligned but always ends up off by word bytes because GHC sets it to +-- the 'wrong' starting value in the RTS. -- module LlvmMangler ( llvmFixupAsm ) where +#include "HsVersions.h" + +import LlvmCodeGen.Ppr ( infoSection ) + import Control.Exception +import Control.Monad ( when ) import qualified Data.ByteString.Char8 as B import Data.Char -import qualified Data.IntMap as I import System.IO +import Data.List ( sortBy ) +import Data.Function ( on ) + -- Magic Strings -infoSec, newInfoSec, newLine, spInst, jmpInst :: B.ByteString -infoSec = B.pack "\t.section\t__STRIP,__me" -newInfoSec = B.pack "\n\t.text" +secStmt, infoSec, newLine, spInst, jmpInst, textStmt, dataStmt :: B.ByteString +secStmt = B.pack "\t.section\t" +infoSec = B.pack infoSection newLine = B.pack "\n" -spInst = B.pack ", %esp\n" jmpInst = B.pack "\n\tjmp" +textStmt = B.pack "\t.text" +dataStmt = B.pack "\t.data" -infoLen, spFix, labelStart :: Int -infoLen = B.length infoSec -spFix = 4 -labelStart = B.length jmpInst + 1 +infoLen, labelStart, spFix :: Int +infoLen = B.length infoSec +labelStart = B.length jmpInst + +#if x86_64_TARGET_ARCH +spInst = B.pack ", %rsp\n" +spFix = 8 +#else +spInst = B.pack ", %esp\n" +spFix = 4 +#endif -- Search Predicates eolPred, dollarPred, commaPred :: Char -> Bool @@ -42,53 +57,84 @@ llvmFixupAsm f1 f2 = do r <- openBinaryFile f1 ReadMode w <- openBinaryFile f2 WriteMode - fixTables r w I.empty - B.hPut w (B.pack "\n\n") + ss <- readSections r w hClose r + let fixed = fixTables ss + mapM_ (writeSection w) fixed hClose w return () -{- | - Here we process the assembly file one function and data - defenition at a time. When a function is encountered that - should have a info table we store it in a map. Otherwise - we print it. When an info table is found we retrieve its - function from the map and print them both. - - For all functions we fix up the stack alignment. We also - fix up the section defenition for functions and info tables. --} -fixTables :: Handle -> Handle -> I.IntMap B.ByteString -> IO () -fixTables r w m = do - f <- getFun r B.empty - if B.null f - then return () - else let fun = fixupStack f B.empty - (a,b) = B.breakSubstring infoSec fun - (x,c) = B.break eolPred b - fun' = a `B.append` newInfoSec `B.append` c - n = readInt $ B.drop infoLen x - (bs, m') | B.null b = ([fun], m) - | even n = ([], I.insert n fun' m) - | otherwise = case I.lookup (n+1) m of - Just xf' -> ([fun',xf'], m) - Nothing -> ([fun'], m) - in mapM_ (B.hPut w) bs >> fixTables r w m' - --- | Read in the next function/data defenition -getFun :: Handle -> B.ByteString -> IO B.ByteString -getFun r f = do - l <- (try (B.hGetLine r))::IO (Either IOError B.ByteString) - case l of - Right l' | B.null l' -> return f - | otherwise -> getFun r (f `B.append` newLine `B.append` l') - Left _ -> return B.empty +type Section = (B.ByteString, B.ByteString) +-- | Splits the file contents into its sections. Each is returned as a +-- pair of the form (header line, contents lines) +readSections :: Handle -> Handle -> IO [Section] +readSections r w = go B.empty [] [] + where + go hdr ss ls = do + e_l <- (try (B.hGetLine r))::IO (Either IOError B.ByteString) + + -- Note that ".type" directives at the end of a section refer to + -- the first directive of the *next* section, therefore we take + -- it over to that section. + let (tys, ls') = span isType ls + isType = B.isPrefixOf (B.pack "\t.type") + cts = B.intercalate newLine $ reverse ls' + + -- Decide whether to directly output the section or append it + -- to the list for resorting. + let finishSection + | infoSec `B.isInfixOf` hdr = + cts `seq` return $ (hdr, cts):ss + | otherwise = + writeSection w (hdr, fixupStack cts B.empty) >> return ss + + case e_l of + Right l | any (`B.isPrefixOf` l) [secStmt, textStmt, dataStmt] + -> finishSection >>= \ss' -> go l ss' tys + | otherwise + -> go hdr ss (l:ls) + Left _ -> finishSection >>= \ss' -> return (reverse ss') + +-- | Writes sections back +writeSection :: Handle -> Section -> IO () +writeSection w (hdr, cts) = do + when (not $ B.null hdr) $ + B.hPutStrLn w hdr + B.hPutStrLn w cts + +-- | Reorder and convert sections so info tables end up next to the +-- code. Also does stack fixups. +fixTables :: [Section] -> [Section] +fixTables ss = fixed + where + -- Resort sections: We only assign a non-zero number to all + -- sections having the "STRIP ME" marker. As sortBy is stable, + -- this will cause all these sections to be appended to the end of + -- the file in the order given by the indexes. + extractIx hdr + | B.null a = 0 + | otherwise = 1 + readInt (B.takeWhile isDigit $ B.drop infoLen a) + where (_,a) = B.breakSubstring infoSec hdr + indexed = zip (map (extractIx . fst) ss) ss + sorted = map snd $ sortBy (compare `on` fst) indexed + + -- Turn all the "STRIP ME" sections into normal text sections, as + -- they are in the right place now. + strip (hdr, cts) + | infoSec `B.isInfixOf` hdr = (textStmt, cts) + | otherwise = (hdr, cts) + stripped = map strip sorted + + -- Do stack fixup + fix (hdr, cts) = (hdr, fixupStack cts B.empty) + fixed = map fix stripped + {-| Mac OS X requires that the stack be 16 byte aligned when making a function call (only really required though when making a call that will pass through the dynamic linker). The alignment isn't correctly generated by LLVM as - LLVM rightly assumes that the stack wil be aligned to 16n + 12 on entry + LLVM rightly assumes that the stack will be aligned to 16n + 12 on entry (since the function call was 16 byte aligned and the return address should have been pushed, so sub 4). GHC though since it always uses jumps keeps the stack 16 byte aligned on both function calls and function entry. @@ -96,6 +142,11 @@ We correct the alignment here. -} fixupStack :: B.ByteString -> B.ByteString -> B.ByteString + +#if !darwin_TARGET_OS +fixupStack = const + +#else fixupStack f f' | B.null f' = let -- fixup sub op (a, c) = B.breakSubstring spInst f @@ -114,18 +165,21 @@ (a', n) = B.breakEnd dollarPred a (n', x) = B.break commaPred n num = B.pack $ show $ readInt n' + spFix + -- We need to avoid processing jumps to labels, they are of the form: + -- jmp\tL..., jmp\t_f..., jmpl\t_f..., jmpl\t*%eax..., jmpl *L... + targ = B.dropWhile ((==)'*') $ B.drop 1 $ B.dropWhile ((/=)'\t') $ + B.drop labelStart c in if B.null c then f' `B.append` f - -- We need to avoid processing jumps to labels, they are of the form: - -- jmp\tL..., jmp\t_f..., jmpl\t_f..., jmpl\t*%eax... - else if B.index c labelStart == 'L' + else if B.head targ == 'L' then fixupStack b $ f' `B.append` a `B.append` l else fixupStack b $ f' `B.append` a' `B.append` num `B.append` x `B.append` l +#endif --- | read an int or error +-- | Read an int or error readInt :: B.ByteString -> Int readInt str | B.all isDigit str = (read . B.unpack) str - | otherwise = error $ "LLvmMangler Cannot read" ++ show str - ++ "as it's not an Int" + | otherwise = error $ "LLvmMangler Cannot read " ++ show str + ++ " as it's not an Int" diff -Nru ghc-7.0.3/compiler/main/BreakArray.hs ghc-7.2.1/compiler/main/BreakArray.hs --- ghc-7.0.3/compiler/main/BreakArray.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/main/BreakArray.hs 2011-08-07 17:10:05.000000000 +0000 @@ -26,11 +26,7 @@ ) where #ifdef GHCI import GHC.Exts -#if __GLASGOW_HASKELL__ >= 611 import GHC.IO ( IO(..) ) -#else -import GHC.IOBase ( IO(..) ) -#endif import Constants data BreakArray = BA (MutableByteArray# RealWorld) diff -Nru ghc-7.0.3/compiler/main/CmdLineParser.hs ghc-7.2.1/compiler/main/CmdLineParser.hs --- ghc-7.0.3/compiler/main/CmdLineParser.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/main/CmdLineParser.hs 2011-08-07 17:10:05.000000000 +0000 @@ -12,8 +12,8 @@ module CmdLineParser ( processArgs, OptKind(..), CmdLineP(..), getCmdLineState, putCmdLineState, - Flag(..), - errorsToGhcException, + Flag(..), FlagSafety(..), flagA, flagR, flagC, flagN, + errorsToGhcException, determineSafeLevel, EwM, addErr, addWarn, getArg, liftEwM, deprecate ) where @@ -34,9 +34,36 @@ data Flag m = Flag { flagName :: String, -- Flag, without the leading "-" + flagSafety :: FlagSafety, -- Flag safety level (Safe Haskell) flagOptKind :: OptKind m -- What to do if we see it } +-- | This determines how a flag should behave when Safe Haskell +-- mode is on. +data FlagSafety + = EnablesSafe -- ^ This flag is a little bit of a hack. We give + -- the safe haskell flags (-XSafe and -XSafeLanguage) + -- this safety type so we can easily detect when safe + -- haskell mode has been enable in a module pragma + -- as this changes how the rest of the parsing should + -- happen. + + | AlwaysAllowed -- ^ Flag is always allowed + | RestrictedFunction -- ^ Flag is allowed but functions in a reduced way + | CmdLineOnly -- ^ Flag is only allowed on command line, not in pragma + | NeverAllowed -- ^ Flag isn't allowed at all + deriving ( Eq, Ord ) + +determineSafeLevel :: Bool -> FlagSafety +determineSafeLevel False = RestrictedFunction +determineSafeLevel True = CmdLineOnly + +flagA, flagR, flagC, flagN :: String -> OptKind m -> Flag m +flagA n o = Flag n AlwaysAllowed o +flagR n o = Flag n RestrictedFunction o +flagC n o = Flag n CmdLineOnly o +flagN n o = Flag n NeverAllowed o + ------------------------------- data OptKind m -- Suppose the flag is -f = NoArg (EwM m ()) -- -f all by itself @@ -64,22 +91,32 @@ -- EwM (short for "errors and warnings monad") is a -- monad transformer for m that adds an (err, warn) state newtype EwM m a = EwM { unEwM :: Located String -- Current arg + -> FlagSafety -- arg safety level + -> FlagSafety -- global safety level -> Errs -> Warns -> m (Errs, Warns, a) } instance Monad m => Monad (EwM m) where - (EwM f) >>= k = EwM (\l e w -> do { (e', w', r) <- f l e w - ; unEwM (k r) l e' w' }) - return v = EwM (\_ e w -> return (e, w, v)) - -setArg :: Located String -> EwM m a -> EwM m a -setArg l (EwM f) = EwM (\_ es ws -> f l es ws) + (EwM f) >>= k = EwM (\l s c e w -> do { (e', w', r) <- f l s c e w + ; unEwM (k r) l s c e' w' }) + return v = EwM (\_ _ _ e w -> return (e, w, v)) + +setArg :: Monad m => Located String -> FlagSafety -> EwM m () -> EwM m () +setArg l s (EwM f) = EwM (\_ _ c es ws -> + let check | s <= c = f l s c es ws + | otherwise = err l es ws + err (L loc ('-' : arg)) es ws = + let msg = "Warning: " ++ arg ++ " is not allowed in " + ++ "Safe Haskell; ignoring " ++ arg + in return (es, ws `snocBag` L loc msg, ()) + err _ _ _ = error "Bad pattern match in setArg" + in check) addErr :: Monad m => String -> EwM m () -addErr e = EwM (\(L loc _) es ws -> return (es `snocBag` L loc e, ws, ())) +addErr e = EwM (\(L loc _) _ _ es ws -> return (es `snocBag` L loc e, ws, ())) addWarn :: Monad m => String -> EwM m () -addWarn msg = EwM (\(L loc _) es ws -> return (es, ws `snocBag` L loc w, ())) +addWarn msg = EwM (\(L loc _) _ _ es ws -> return (es, ws `snocBag` L loc w, ())) where w = "Warning: " ++ msg @@ -89,10 +126,10 @@ ; addWarn (arg ++ " is deprecated: " ++ s) } getArg :: Monad m => EwM m String -getArg = EwM (\(L _ arg) es ws -> return (es, ws, arg)) +getArg = EwM (\(L _ arg) _ _ es ws -> return (es, ws, arg)) liftEwM :: Monad m => m a -> EwM m a -liftEwM action = EwM (\_ es ws -> do { r <- action; return (es, ws, r) }) +liftEwM action = EwM (\_ _ _ es ws -> do { r <- action; return (es, ws, r) }) -- ----------------------------------------------------------------------------- -- A state monad for use in the command-line parser @@ -119,31 +156,41 @@ processArgs :: Monad m => [Flag m] -- cmdline parser spec -> [Located String] -- args + -> FlagSafety -- flag clearance lvl + -> Bool -> m ( [Located String], -- spare args [Located String], -- errors [Located String] -- warnings ) -processArgs spec args - = do { (errs, warns, spare) <- unEwM (process args []) - (panic "processArgs: no arg yet") - emptyBag emptyBag - ; return (spare, bagToList errs, bagToList warns) } +processArgs spec args clvl0 cmdline + = let (clvl1, action) = process clvl0 args [] + in do { (errs, warns, spare) <- unEwM action (panic "processArgs: no arg yet") + AlwaysAllowed clvl1 emptyBag emptyBag + ; return (spare, bagToList errs, bagToList warns) } where - -- process :: [Located String] -> [Located String] -> EwM m [Located String] - process [] spare = return (reverse spare) + -- process :: FlagSafety -> [Located String] -> [Located String] -> (FlagSafety, EwM m [Located String]) + -- + process clvl [] spare = (clvl, return (reverse spare)) - process (locArg@(L _ ('-' : arg)) : args) spare = + process clvl (locArg@(L _ ('-' : arg)) : args) spare = case findArg spec arg of - Just (rest, opt_kind) -> - case processOneArg opt_kind rest arg args of - Left err -> do { setArg locArg $ addErr err - ; process args spare } - Right (action,rest) -> do { setArg locArg $ action - ; process rest spare } - Nothing -> process args (locArg : spare) + Just (rest, opt_kind, fsafe) -> + let clvl1 = if fsafe == EnablesSafe then determineSafeLevel cmdline else clvl + in case processOneArg opt_kind rest arg args of + Left err -> + let (clvl2,b) = process clvl1 args spare + clvl3 = min clvl1 clvl2 + in (clvl3, (setArg locArg fsafe $ addErr err) >> b) + + Right (action,rest) -> + let (clvl2,b) = process clvl1 rest spare + clvl3 = min clvl1 clvl2 + in (clvl3, (setArg locArg fsafe $ action) >> b) + + Nothing -> process clvl args (locArg : spare) - process (arg : args) spare = process args (arg : spare) + process clvl (arg : args) spare = process clvl args (arg : spare) processOneArg :: OptKind m -> String -> String -> [Located String] @@ -184,11 +231,12 @@ AnySuffixPred _ f -> Right (f dash_arg, args) -findArg :: [Flag m] -> String -> Maybe (String, OptKind m) +findArg :: [Flag m] -> String -> Maybe (String, OptKind m, FlagSafety) findArg spec arg - = case [ (removeSpaces rest, optKind) + = case [ (removeSpaces rest, optKind, flagSafe) | flag <- spec, - let optKind = flagOptKind flag, + let optKind = flagOptKind flag, + let flagSafe = flagSafety flag, Just rest <- [stripPrefix (flagName flag) arg], arg_ok optKind rest arg ] of @@ -233,5 +281,5 @@ errorsToGhcException :: [Located String] -> GhcException errorsToGhcException errs = let errors = vcat [ ppr l <> text ": " <> text e | L l e <- errs ] - in UsageError (showSDoc $ withPprStyle cmdlineParserStyle errors) + in UsageError (renderWithStyle errors cmdlineParserStyle) diff -Nru ghc-7.0.3/compiler/main/CodeOutput.lhs ghc-7.2.1/compiler/main/CodeOutput.lhs --- ghc-7.0.3/compiler/main/CodeOutput.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/main/CodeOutput.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -8,28 +8,21 @@ #include "HsVersions.h" -#ifndef OMIT_NATIVE_CODEGEN -import AsmCodeGen ( nativeCodeGen ) -#endif +import AsmCodeGen ( nativeCodeGen ) import LlvmCodeGen ( llvmCodeGen ) import UniqSupply ( mkSplitUniqSupply ) -#ifdef JAVA -import JavaGen ( javaGen ) -import qualified PrintJava -import OccurAnal ( occurAnalyseBinds ) -#endif - import Finder ( mkStubPaths ) import PprC ( writeCs ) import CmmLint ( cmmLint ) import Packages import Util -import Cmm ( RawCmm ) +import OldCmm ( RawCmm ) import HscTypes import DynFlags import Config +import SysTools import ErrUtils ( dumpIfSet_dyn, showPass, ghcExit ) import Outputable @@ -56,7 +49,7 @@ -> ForeignStubs -> [PackageId] -> [RawCmm] -- Compiled C-- - -> IO (Bool{-stub_h_exists-}, Bool{-stub_c_exists-}) + -> IO (Bool{-stub_h_exists-}, Maybe FilePath{-stub_c_exists-}) codeOutput dflags this_mod location foreign_stubs pkg_deps flat_abstractC = @@ -68,7 +61,7 @@ do { when (dopt Opt_DoCmmLinting dflags) $ do { showPass dflags "CmmLint" - ; let lints = map cmmLint flat_abstractC + ; let lints = map (cmmLint (targetPlatform dflags)) flat_abstractC ; case firstJusts lints of Just err -> do { printDump err ; ghcExit dflags 1 @@ -84,12 +77,6 @@ HscAsm -> outputAsm dflags filenm flat_abstractC; HscC -> outputC dflags filenm flat_abstractC pkg_deps; HscLlvm -> outputLlvm dflags filenm flat_abstractC; - HscJava -> -#ifdef JAVA - outputJava dflags filenm mod_name tycons core_binds; -#else - panic "Java support not compiled into this ghc"; -#endif HscNothing -> panic "codeOutput: HscNothing" } ; return stubs_exist @@ -148,24 +135,16 @@ \begin{code} outputAsm :: DynFlags -> FilePath -> [RawCmm] -> IO () - -#ifndef OMIT_NATIVE_CODEGEN - outputAsm dflags filenm flat_absC + | cGhcWithNativeCodeGen == "YES" = do ncg_uniqs <- mkSplitUniqSupply 'n' {-# SCC "OutputAsm" #-} doOutput filenm $ - \f -> {-# SCC "NativeCodeGen" #-} - nativeCodeGen dflags f ncg_uniqs flat_absC - where - -#else /* OMIT_NATIVE_CODEGEN */ + \f -> {-# SCC "NativeCodeGen" #-} + nativeCodeGen dflags f ncg_uniqs flat_absC -outputAsm _ _ _ - = pprPanic "This compiler was built without a native code generator" - (text "Use -fvia-C instead") - -#endif + | otherwise + = panic "This compiler was built without a native code generator" \end{code} @@ -185,26 +164,6 @@ %************************************************************************ %* * -\subsection{Java} -%* * -%************************************************************************ - -\begin{code} -#ifdef JAVA -outputJava dflags filenm mod tycons core_binds - = doOutput filenm (\ f -> printForUser f alwaysQualify pp_java) - -- User style printing for now to keep indentation - where - occ_anal_binds = occurAnalyseBinds core_binds - -- Make sure we have up to date dead-var information - java_code = javaGen mod [{- Should be imports-}] tycons occ_anal_binds - pp_java = PrintJava.compilationUnit java_code -#endif -\end{code} - - -%************************************************************************ -%* * \subsection{Foreign import/export} %* * %************************************************************************ @@ -212,18 +171,21 @@ \begin{code} outputForeignStubs :: DynFlags -> Module -> ModLocation -> ForeignStubs -> IO (Bool, -- Header file created - Bool) -- C file created + Maybe FilePath) -- C file created outputForeignStubs dflags mod location stubs - = case stubs of - NoStubs -> do + = do + let stub_h = mkStubPaths dflags (moduleName mod) location + stub_c <- newTempName dflags "c" + + case stubs of + NoStubs -> do -- When compiling External Core files, may need to use stub -- files from a previous compilation - stub_c_exists <- doesFileExist stub_c - stub_h_exists <- doesFileExist stub_h - return (stub_h_exists, stub_c_exists) + stub_h_exists <- doesFileExist stub_h + return (stub_h_exists, Nothing) - ForeignStubs h_code c_code -> do - let + ForeignStubs h_code c_code -> do + let stub_c_output_d = pprCode CStyle c_code stub_c_output_w = showSDoc stub_c_output_d @@ -232,7 +194,7 @@ stub_h_output_w = showSDoc stub_h_output_d -- in - createDirectoryHierarchy (takeDirectory stub_c) + createDirectoryHierarchy (takeDirectory stub_h) dumpIfSet_dyn dflags Opt_D_dump_foreign "Foreign export header file" stub_h_output_d @@ -266,10 +228,10 @@ -- isn't really HC code, so we need to define IN_STG_CODE==0 to -- avoid the register variables etc. being enabled. - return (stub_h_file_exists, stub_c_file_exists) - where - (stub_c, stub_h, _) = mkStubPaths dflags (moduleName mod) location - + return (stub_h_file_exists, if stub_c_file_exists + then Just stub_c + else Nothing ) + where cplusplus_hdr = "#ifdef __cplusplus\nextern \"C\" {\n#endif\n" cplusplus_ftr = "#ifdef __cplusplus\n}\n#endif\n" diff -Nru ghc-7.0.3/compiler/main/DriverMkDepend.hs ghc-7.2.1/compiler/main/DriverMkDepend.hs --- ghc-7.0.3/compiler/main/DriverMkDepend.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/main/DriverMkDepend.hs 2011-08-07 17:10:05.000000000 +0000 @@ -16,7 +16,7 @@ #include "HsVersions.h" import qualified GHC --- import GHC ( ModSummary(..), GhcMonad ) +import GhcMonad import HsSyn ( ImportDecl(..) ) import DynFlags import Util @@ -34,7 +34,6 @@ import Exception import ErrUtils --- import MonadUtils ( liftIO ) import System.Directory import System.FilePath diff -Nru ghc-7.0.3/compiler/main/DriverPhases.hs ghc-7.2.1/compiler/main/DriverPhases.hs --- ghc-7.0.3/compiler/main/DriverPhases.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/main/DriverPhases.hs 2011-08-07 17:10:05.000000000 +0000 @@ -75,8 +75,8 @@ | Hsc HscSource | Ccpp | Cc + | Cobjc | HCc -- Haskellised C (as opposed to vanilla C) compilation - | Mangle -- assembly mangling, now done by a separate script. | SplitMangle -- after mangler if splitting | SplitAs | As @@ -85,6 +85,7 @@ | LlvmMangle -- Fix up TNTC by processing assembly produced by LLVM | CmmCpp -- pre-process Cmm source | Cmm -- parse & compile Cmm code + | MergeStub -- merge in the stub object file -- The final phase is a pseudo-phase that tells the pipeline to stop. -- There is no runPhase case for it. @@ -110,8 +111,8 @@ eqPhase (Hsc _) (Hsc _) = True eqPhase Ccpp Ccpp = True eqPhase Cc Cc = True +eqPhase Cobjc Cobjc = True eqPhase HCc HCc = True -eqPhase Mangle Mangle = True eqPhase SplitMangle SplitMangle = True eqPhase SplitAs SplitAs = True eqPhase As As = True @@ -120,6 +121,7 @@ eqPhase LlvmMangle LlvmMangle = True eqPhase CmmCpp CmmCpp = True eqPhase Cmm Cmm = True +eqPhase MergeStub MergeStub = True eqPhase StopLn StopLn = True eqPhase _ _ = False @@ -133,27 +135,24 @@ after_x = nextPhase x nextPhase :: Phase -> Phase --- A conservative approximation the next phase, used in happensBefore +-- A conservative approximation to the next phase, used in happensBefore nextPhase (Unlit sf) = Cpp sf nextPhase (Cpp sf) = HsPp sf nextPhase (HsPp sf) = Hsc sf nextPhase (Hsc _) = HCc -nextPhase HCc = Mangle -nextPhase Mangle = SplitMangle nextPhase SplitMangle = As nextPhase As = SplitAs nextPhase LlvmOpt = LlvmLlc -#if darwin_TARGET_OS nextPhase LlvmLlc = LlvmMangle -#else -nextPhase LlvmLlc = As -#endif nextPhase LlvmMangle = As -nextPhase SplitAs = StopLn +nextPhase SplitAs = MergeStub nextPhase Ccpp = As nextPhase Cc = As +nextPhase Cobjc = As nextPhase CmmCpp = Cmm nextPhase Cmm = HCc +nextPhase HCc = As +nextPhase MergeStub = StopLn nextPhase StopLn = panic "nextPhase: nothing after StopLn" -- the first compilation phase for a given file is determined @@ -170,9 +169,9 @@ startPhase "c" = Cc startPhase "cpp" = Ccpp startPhase "C" = Cc +startPhase "m" = Cobjc startPhase "cc" = Ccpp startPhase "cxx" = Ccpp -startPhase "raw_s" = Mangle startPhase "split_s" = SplitMangle startPhase "s" = As startPhase "S" = As @@ -199,8 +198,8 @@ -- output filename. That could be fixed, but watch out. phaseInputExt HCc = "hc" phaseInputExt Ccpp = "cpp" +phaseInputExt Cobjc = "m" phaseInputExt Cc = "c" -phaseInputExt Mangle = "raw_s" phaseInputExt SplitMangle = "split_s" -- not really generated phaseInputExt As = "s" phaseInputExt LlvmOpt = "ll" @@ -209,6 +208,7 @@ phaseInputExt SplitAs = "split_s" -- not really generated phaseInputExt CmmCpp = "cmm" phaseInputExt Cmm = "cmmcpp" +phaseInputExt MergeStub = "o" phaseInputExt StopLn = "o" haskellish_src_suffixes, haskellish_suffixes, cish_suffixes, @@ -217,7 +217,7 @@ haskellish_src_suffixes = haskellish_user_src_suffixes ++ [ "hspp", "hscpp", "hcr", "cmm", "cmmcpp" ] haskellish_suffixes = haskellish_src_suffixes ++ ["hc", "raw_s"] -cish_suffixes = [ "c", "cpp", "C", "cc", "cxx", "s", "S", "ll", "bc" ] +cish_suffixes = [ "c", "cpp", "C", "cc", "cxx", "s", "S", "ll", "bc", "m" ] extcoreish_suffixes = [ "hcr" ] -- Will not be deleted as temp files: haskellish_user_src_suffixes = [ "hs", "lhs", "hs-boot", "lhs-boot" ] diff -Nru ghc-7.0.3/compiler/main/DriverPipeline.hs ghc-7.2.1/compiler/main/DriverPipeline.hs --- ghc-7.0.3/compiler/main/DriverPipeline.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/main/DriverPipeline.hs 2011-08-07 17:10:05.000000000 +0000 @@ -1,4 +1,5 @@ {-# OPTIONS -fno-cse #-} +{-# LANGUAGE NamedFieldPuns #-} -- -fno-cse is needed for GLOBAL_VAR's to behave properly ----------------------------------------------------------------------------- @@ -49,20 +50,19 @@ import SrcLoc import FastString import LlvmCodeGen ( llvmFixupAsm ) --- import MonadUtils +import MonadUtils +import Platform --- import Data.Either import Exception import Data.IORef ( readIORef ) --- import GHC.Exts ( Int(..) ) import System.Directory import System.FilePath import System.IO -import System.IO.Error as IO import Control.Monad import Data.List ( isSuffixOf ) import Data.Maybe import System.Environment +import Data.Char -- --------------------------------------------------------------------------- -- Pre-process @@ -73,14 +73,13 @@ -- We return the augmented DynFlags, because they contain the result -- of slurping in the OPTIONS pragmas -preprocess :: GhcMonad m => - HscEnv +preprocess :: HscEnv -> (FilePath, Maybe Phase) -- ^ filename and starting phase - -> m (DynFlags, FilePath) + -> IO (DynFlags, FilePath) preprocess hsc_env (filename, mb_phase) = ASSERT2(isJust mb_phase || isHaskellSrcFilename filename, text filename) runPipeline anyHsc hsc_env (filename, mb_phase) - Nothing Temporary Nothing{-no ModLocation-} + Nothing Temporary Nothing{-no ModLocation-} Nothing{-no stub-} -- --------------------------------------------------------------------------- @@ -90,40 +89,39 @@ -- -- This is the interface between the compilation manager and the -- compiler proper (hsc), where we deal with tedious details like --- reading the OPTIONS pragma from the source file, and passing the --- output of hsc through the C compiler. +-- reading the OPTIONS pragma from the source file, converting the +-- C or assembly that GHC produces into an object file, and compiling +-- FFI stub files. -- -- NB. No old interface can also mean that the source has changed. -compile :: GhcMonad m => - HscEnv +compile :: HscEnv -> ModSummary -- ^ summary for module being compiled -> Int -- ^ module N ... -> Int -- ^ ... of M -> Maybe ModIface -- ^ old interface, if we have one -> Maybe Linkable -- ^ old linkable, if we have one - -> m HomeModInfo -- ^ the complete HomeModInfo, if successful + -> SourceModified + -> IO HomeModInfo -- ^ the complete HomeModInfo, if successful compile = compile' (hscCompileNothing, hscCompileInteractive, hscCompileBatch) -type Compiler m a = HscEnv -> ModSummary -> Bool - -> Maybe ModIface -> Maybe (Int, Int) - -> m a - -compile' :: GhcMonad m => - (Compiler m (HscStatus, ModIface, ModDetails), - Compiler m (InteractiveStatus, ModIface, ModDetails), - Compiler m (HscStatus, ModIface, ModDetails)) +compile' :: + (Compiler (HscStatus, ModIface, ModDetails), + Compiler (InteractiveStatus, ModIface, ModDetails), + Compiler (HscStatus, ModIface, ModDetails)) -> HscEnv -> ModSummary -- ^ summary for module being compiled -> Int -- ^ module N ... -> Int -- ^ ... of M -> Maybe ModIface -- ^ old interface, if we have one -> Maybe Linkable -- ^ old linkable, if we have one - -> m HomeModInfo -- ^ the complete HomeModInfo, if successful + -> SourceModified + -> IO HomeModInfo -- ^ the complete HomeModInfo, if successful compile' (nothingCompiler, interactiveCompiler, batchCompiler) hsc_env0 summary mod_index nmods mb_old_iface maybe_old_linkable + source_modified0 = do let dflags0 = ms_hspp_opts summary this_mod = ms_mod summary @@ -132,7 +130,7 @@ input_fn = expectJust "compile:hs" (ml_hs_file location) input_fnpp = ms_hspp_file summary - liftIO $ debugTraceMsg dflags0 2 (text "compile: input file" <+> text input_fnpp) + debugTraceMsg dflags0 2 (text "compile: input file" <+> text input_fnpp) let basename = dropExtension input_fn @@ -147,11 +145,11 @@ hsc_env = hsc_env0 {hsc_dflags = dflags} -- Figure out what lang we're generating - let hsc_lang = hscMaybeAdjustTarget dflags StopLn src_flavour (hscTarget dflags) + let hsc_lang = hscTarget dflags -- ... and what the next phase should be let next_phase = hscNextPhase dflags src_flavour hsc_lang -- ... and what file to generate the output into - output_fn <- liftIO $ getOutputFilename next_phase + output_fn <- getOutputFilename next_phase Temporary basename dflags next_phase (Just location) let dflags' = dflags { hscTarget = hsc_lang, @@ -161,15 +159,12 @@ -- -fforce-recomp should also work with --make let force_recomp = dopt Opt_ForceRecomp dflags - source_unchanged = isJust maybe_old_linkable && not force_recomp + source_modified + | force_recomp || isNothing maybe_old_linkable = SourceModified + | otherwise = source_modified0 object_filename = ml_obj_file location - let getStubLinkable False = return [] - getStubLinkable True - = do stub_o <- compileStub hsc_env' this_mod location - return [ DotO stub_o ] - - handleBatch HscNoRecomp + let handleBatch HscNoRecomp = ASSERT (isJust maybe_old_linkable) return maybe_old_linkable @@ -181,22 +176,27 @@ return maybe_old_linkable | otherwise - = do stub_unlinked <- getStubLinkable hasStub - (hs_unlinked, unlinked_time) <- + = do (hs_unlinked, unlinked_time) <- case hsc_lang of - HscNothing - -> return ([], ms_hs_date summary) + HscNothing -> + return ([], ms_hs_date summary) -- We're in --make mode: finish the compilation pipeline. - _other - -> do _ <- runPipeline StopLn hsc_env' (output_fn,Nothing) + _other -> do + maybe_stub_o <- case hasStub of + Nothing -> return Nothing + Just stub_c -> do + stub_o <- compileStub hsc_env' stub_c + return (Just stub_o) + _ <- runPipeline StopLn hsc_env' (output_fn,Nothing) (Just basename) Persistent (Just location) + maybe_stub_o -- The object filename comes from the ModLocation - o_time <- liftIO $ getModificationTime object_filename - return ([DotO object_filename], o_time) - let linkable = LM unlinked_time this_mod - (hs_unlinked ++ stub_unlinked) + o_time <- getModificationTime object_filename + return ([DotO object_filename], o_time) + + let linkable = LM unlinked_time this_mod hs_unlinked return (Just linkable) handleInterpreted HscNoRecomp @@ -206,7 +206,12 @@ = ASSERT (isHsBoot src_flavour) return maybe_old_linkable handleInterpreted (HscRecomp hasStub (Just (comp_bc, modBreaks))) - = do stub_unlinked <- getStubLinkable hasStub + = do stub_o <- case hasStub of + Nothing -> return [] + Just stub_c -> do + stub_o <- compileStub hsc_env' stub_c + return [DotO stub_o] + let hs_unlinked = [BCOs comp_bc modBreaks] unlinked_time = ms_hs_date summary -- Why do we use the timestamp of the source file here, @@ -216,14 +221,14 @@ -- if the source is modified, then the linkable will -- be out of date. let linkable = LM unlinked_time this_mod - (hs_unlinked ++ stub_unlinked) + (hs_unlinked ++ stub_o) return (Just linkable) let -- runCompiler :: Compiler result -> (result -> Maybe Linkable) -- -> m HomeModInfo runCompiler compiler handle = do (result, iface, details) - <- compiler hsc_env' summary source_unchanged mb_old_iface + <- compiler hsc_env' summary source_modified mb_old_iface (Just (mod_index, nmods)) linkable <- handle result return (HomeModInfo{ hm_details = details, @@ -231,13 +236,9 @@ hm_linkable = linkable }) -- run the compiler case hsc_lang of - HscInterpreted -> - runCompiler interactiveCompiler handleInterpreted - HscNothing -> - runCompiler nothingCompiler handleBatch - _other -> - runCompiler batchCompiler handleBatch - + HscInterpreted -> runCompiler interactiveCompiler handleInterpreted + HscNothing -> runCompiler nothingCompiler handleBatch + _other -> runCompiler batchCompiler handleBatch ----------------------------------------------------------------------------- -- stub .h and .c files (for foreign export support) @@ -245,32 +246,17 @@ -- The _stub.c file is derived from the haskell source file, possibly taking -- into account the -stubdir option. -- --- Consequently, we derive the _stub.o filename from the haskell object --- filename. --- --- This isn't necessarily the same as the object filename we --- would get if we just compiled the _stub.c file using the pipeline. --- For example: --- --- ghc src/A.hs -odir obj --- --- results in obj/A.o, and src/A_stub.c. If we compile src/A_stub.c with --- -odir obj, we would get obj/src/A_stub.o, which is wrong; we want --- obj/A_stub.o. - -compileStub :: GhcMonad m => HscEnv -> Module -> ModLocation - -> m FilePath -compileStub hsc_env mod location = do - -- compile the _stub.c file w/ gcc - let (stub_c,_,stub_o) = mkStubPaths (hsc_dflags hsc_env) - (moduleName mod) location - - _ <- runPipeline StopLn hsc_env (stub_c,Nothing) Nothing - (SpecificFile stub_o) Nothing{-no ModLocation-} +-- The object file created by compiling the _stub.c file is put into a +-- temporary file, which will be later combined with the main .o file +-- (see the MergeStubs phase). + +compileStub :: HscEnv -> FilePath -> IO FilePath +compileStub hsc_env stub_c = do + (_, stub_o) <- runPipeline StopLn hsc_env (stub_c,Nothing) Nothing + Temporary Nothing{-no ModLocation-} Nothing return stub_o - -- --------------------------------------------------------------------------- -- Link @@ -287,11 +273,11 @@ -- exports main, i.e., we have good reason to believe that linking -- will succeed. -#ifdef GHCI link LinkInMemory _ _ _ - = do -- Not Linking...(demand linker will do the job) - return Succeeded -#endif + = if cGhcWithInterpreter == "YES" + then -- Not Linking...(demand linker will do the job) + return Succeeded + else panicBadLink LinkInMemory link NoLink _ _ _ = return Succeeded @@ -302,11 +288,6 @@ link LinkDynLib dflags batch_attempt_linking hpt = link' dflags batch_attempt_linking hpt -#ifndef GHCI --- warning suppression -link other _ _ _ = panicBadLink other -#endif - panicBadLink :: GhcLink -> a panicBadLink other = panic ("link: GHC not built to link this way: " ++ show other) @@ -323,7 +304,7 @@ home_mod_infos = eltsUFM hpt -- the packages we depend on - pkg_deps = concatMap (dep_pkgs . mi_deps . hm_iface) home_mod_infos + pkg_deps = concatMap (map fst . dep_pkgs . mi_deps . hm_iface) home_mod_infos -- the linkables to link linkables = map (expectJust "link".hm_linkable) home_mod_infos @@ -375,13 +356,13 @@ -- modification times on all of the objects and libraries, then omit -- linking (unless the -fforce-recomp flag was given). let exe_file = exeFileName dflags - e_exe_time <- IO.try $ getModificationTime exe_file + e_exe_time <- tryIO $ getModificationTime exe_file case e_exe_time of Left _ -> return True Right t -> do -- first check object files and extra_ld_inputs extra_ld_inputs <- readIORef v_Ld_inputs - e_extra_times <- mapM (IO.try . getModificationTime) extra_ld_inputs + e_extra_times <- mapM (tryIO . getModificationTime) extra_ld_inputs let (errs,extra_times) = splitEithers e_extra_times let obj_times = map linkableTime linkables ++ extra_times if not (null errs) || any (t <) obj_times @@ -397,12 +378,35 @@ pkg_libfiles <- mapM (uncurry findHSLib) pkg_hslibs if any isNothing pkg_libfiles then return True else do - e_lib_times <- mapM (IO.try . getModificationTime) + e_lib_times <- mapM (tryIO . getModificationTime) (catMaybes pkg_libfiles) let (lib_errs,lib_times) = splitEithers e_lib_times if not (null lib_errs) || any (t <) lib_times then return True - else return False + else checkLinkInfo dflags pkg_deps exe_file + +-- Returns 'False' if it was, and we can avoid linking, because the +-- previous binary was linked with "the same options". +checkLinkInfo :: DynFlags -> [PackageId] -> FilePath -> IO Bool +checkLinkInfo dflags pkg_deps exe_file + | isWindowsTarget || isDarwinTarget + -- ToDo: Windows and OS X do not use the ELF binary format, so + -- readelf does not work there. We need to find another way to do + -- this. + = return False -- conservatively we should return True, but not + -- linking in this case was the behaviour for a long + -- time so we leave it as-is. + | otherwise + = do + link_info <- getLinkInfo dflags pkg_deps + debugTraceMsg dflags 3 $ text ("Link info: " ++ link_info) + m_exe_link_info <- readElfSection dflags ghcLinkInfoSectionName exe_file + debugTraceMsg dflags 3 $ text ("Exe link info: " ++ show m_exe_link_info) + return (Just link_info /= m_exe_link_info) + +ghcLinkInfoSectionName :: String +ghcLinkInfoSectionName = ".debug-ghc-link-info" + -- if we use the ".debug" prefix, then strip will strip it by default findHSLib :: [String] -> String -> IO (Maybe FilePath) findHSLib dirs lib = do @@ -415,16 +419,14 @@ -- ----------------------------------------------------------------------------- -- Compile files in one-shot mode. -oneShot :: GhcMonad m => - HscEnv -> Phase -> [(String, Maybe Phase)] -> m () +oneShot :: HscEnv -> Phase -> [(String, Maybe Phase)] -> IO () oneShot hsc_env stop_phase srcs = do o_files <- mapM (compileFile hsc_env stop_phase) srcs - liftIO $ doLink (hsc_dflags hsc_env) stop_phase o_files + doLink (hsc_dflags hsc_env) stop_phase o_files -compileFile :: GhcMonad m => - HscEnv -> Phase -> (FilePath, Maybe Phase) -> m FilePath +compileFile :: HscEnv -> Phase -> (FilePath, Maybe Phase) -> IO FilePath compileFile hsc_env stop_phase (src, mb_phase) = do - exists <- liftIO $ doesFileExist src + exists <- doesFileExist src when (not exists) $ ghcError (CmdLineError ("does not exist: " ++ src)) @@ -449,7 +451,7 @@ ( _, out_file) <- runPipeline stop_phase' hsc_env (src, mb_phase) Nothing output - Nothing{-no ModLocation-} + Nothing{-no ModLocation-} Nothing return out_file @@ -489,16 +491,17 @@ -- OPTIONS_GHC pragmas), and the changes affect later phases in the -- pipeline. runPipeline - :: GhcMonad m => - Phase -- ^ When to stop + :: Phase -- ^ When to stop -> HscEnv -- ^ Compilation environment -> (FilePath,Maybe Phase) -- ^ Input filename (and maybe -x suffix) -> Maybe FilePath -- ^ original basename (if different from ^^^) -> PipelineOutput -- ^ Output filename -> Maybe ModLocation -- ^ A ModLocation, if this is a Haskell module - -> m (DynFlags, FilePath) -- ^ (final flags, output filename) + -> Maybe FilePath -- ^ stub object, if we have one + -> IO (DynFlags, FilePath) -- ^ (final flags, output filename) -runPipeline stop_phase hsc_env0 (input_fn, mb_phase) mb_basename output maybe_loc +runPipeline stop_phase hsc_env0 (input_fn, mb_phase) + mb_basename output maybe_loc maybe_stub_o = do let dflags0 = hsc_dflags hsc_env0 (input_basename, suffix) = splitExtension input_fn @@ -530,9 +533,17 @@ let get_output_fn = getOutputFilename stop_phase output basename -- Execute the pipeline... - (dflags', output_fn, maybe_loc) <- - pipeLoop hsc_env start_phase stop_phase input_fn - basename suffix' get_output_fn maybe_loc + let env = PipeEnv{ stop_phase, + src_basename = basename, + src_suffix = suffix', + output_spec = output } + + state = PipeState{ hsc_env, maybe_loc, maybe_stub_o = maybe_stub_o } + + (state', output_fn) <- unP (pipeLoop start_phase input_fn) env state + + let PipeState{ hsc_env=hsc_env', maybe_loc } = state' + dflags' = hsc_dflags hsc_env' -- Sometimes, a compilation phase doesn't actually generate any output -- (eg. the CPP phase when -fcpp is not turned on). If we end on this @@ -542,7 +553,7 @@ case output of Temporary -> return (dflags', output_fn) - _other -> liftIO $ + _other -> do final_fn <- get_output_fn dflags' stop_phase maybe_loc when (final_fn /= output_fn) $ do let msg = ("Copying `" ++ output_fn ++"' to `" ++ final_fn ++ "'") @@ -550,39 +561,102 @@ copyWithHeader dflags msg line_prag output_fn final_fn return (dflags', final_fn) +-- ----------------------------------------------------------------------------- +-- The pipeline uses a monad to carry around various bits of information +-- PipeEnv: invariant information passed down +data PipeEnv = PipeEnv { + stop_phase :: Phase, -- ^ Stop just before this phase + src_basename :: String, -- ^ basename of original input source + src_suffix :: String, -- ^ its extension + output_spec :: PipelineOutput -- ^ says where to put the pipeline output + } + +-- PipeState: information that might change during a pipeline run +data PipeState = PipeState { + hsc_env :: HscEnv, + -- ^ only the DynFlags change in the HscEnv. The DynFlags change + -- at various points, for example when we read the OPTIONS_GHC + -- pragmas in the Cpp phase. + maybe_loc :: Maybe ModLocation, + -- ^ the ModLocation. This is discovered during compilation, + -- in the Hsc phase where we read the module header. + maybe_stub_o :: Maybe FilePath + -- ^ the stub object. This is set by the Hsc phase if a stub + -- object was created. The stub object will be joined with + -- the main compilation object using "ld -r" at the end. + } + +getPipeEnv :: CompPipeline PipeEnv +getPipeEnv = P $ \env state -> return (state, env) + +getPipeState :: CompPipeline PipeState +getPipeState = P $ \_env state -> return (state, state) + +getDynFlags :: CompPipeline DynFlags +getDynFlags = P $ \_env state -> return (state, hsc_dflags (hsc_env state)) + +setDynFlags :: DynFlags -> CompPipeline () +setDynFlags dflags = P $ \_env state -> + return (state{hsc_env= (hsc_env state){ hsc_dflags = dflags }}, ()) + +setModLocation :: ModLocation -> CompPipeline () +setModLocation loc = P $ \_env state -> + return (state{ maybe_loc = Just loc }, ()) + +setStubO :: FilePath -> CompPipeline () +setStubO stub_o = P $ \_env state -> + return (state{ maybe_stub_o = Just stub_o }, ()) + +newtype CompPipeline a = P { unP :: PipeEnv -> PipeState -> IO (PipeState, a) } + +instance Monad CompPipeline where + return a = P $ \_env state -> return (state, a) + P m >>= k = P $ \env state -> do (state',a) <- m env state + unP (k a) env state' + +io :: IO a -> CompPipeline a +io m = P $ \_env state -> do a <- m; return (state, a) + +phaseOutputFilename :: Phase{-next phase-} -> CompPipeline FilePath +phaseOutputFilename next_phase = do + PipeEnv{stop_phase, src_basename, output_spec} <- getPipeEnv + PipeState{maybe_loc, hsc_env} <- getPipeState + let dflags = hsc_dflags hsc_env + io $ getOutputFilename stop_phase output_spec + src_basename dflags next_phase maybe_loc -pipeLoop :: GhcMonad m => - HscEnv -> Phase -> Phase - -> FilePath -> String -> Suffix - -> (DynFlags -> Phase -> Maybe ModLocation -> IO FilePath) - -> Maybe ModLocation - -> m (DynFlags, FilePath, Maybe ModLocation) - -pipeLoop hsc_env phase stop_phase - input_fn orig_basename orig_suff - orig_get_output_fn maybe_loc +-- --------------------------------------------------------------------------- +-- outer pipeline loop - | phase `eqPhase` stop_phase -- All done - = return (hsc_dflags hsc_env, input_fn, maybe_loc) +-- | pipeLoop runs phases until we reach the stop phase +pipeLoop :: Phase -> FilePath -> CompPipeline FilePath +pipeLoop phase input_fn = do + PipeEnv{stop_phase} <- getPipeEnv + PipeState{hsc_env} <- getPipeState + case () of + _ | phase `eqPhase` stop_phase -- All done + -> return input_fn - | not (phase `happensBefore` stop_phase) + | not (phase `happensBefore` stop_phase) -- Something has gone wrong. We'll try to cover all the cases when -- this could happen, so if we reach here it is a panic. -- eg. it might happen if the -C flag is used on a source file that -- has {-# OPTIONS -fasm #-}. - = panic ("pipeLoop: at phase " ++ show phase ++ + -> panic ("pipeLoop: at phase " ++ show phase ++ " but I wanted to stop at phase " ++ show stop_phase) - | otherwise - = do liftIO $ debugTraceMsg (hsc_dflags hsc_env) 4 - (ptext (sLit "Running phase") <+> ppr phase) - (next_phase, dflags', maybe_loc, output_fn) - <- runPhase phase stop_phase hsc_env orig_basename - orig_suff input_fn orig_get_output_fn maybe_loc - let hsc_env' = hsc_env {hsc_dflags = dflags'} - pipeLoop hsc_env' next_phase stop_phase output_fn - orig_basename orig_suff orig_get_output_fn maybe_loc + | otherwise + -> do io $ debugTraceMsg (hsc_dflags hsc_env) 4 + (ptext (sLit "Running phase") <+> ppr phase) + dflags <- getDynFlags + (next_phase, output_fn) <- runPhase phase input_fn dflags + pipeLoop next_phase output_fn + +-- ----------------------------------------------------------------------------- +-- In each phase, we need to know into what filename to generate the +-- output. All the logic about which filenames we generate output +-- into is embodied in the following function. getOutputFilename :: Phase -> PipelineOutput -> String @@ -600,21 +674,19 @@ odir = objectDir dflags osuf = objectSuf dflags keep_hc = dopt Opt_KeepHcFiles dflags - keep_raw_s = dopt Opt_KeepRawSFiles dflags keep_s = dopt Opt_KeepSFiles dflags keep_bc = dopt Opt_KeepLlvmFiles dflags - myPhaseInputExt HCc = hcsuf - myPhaseInputExt StopLn = osuf - myPhaseInputExt other = phaseInputExt other + myPhaseInputExt HCc = hcsuf + myPhaseInputExt MergeStub = osuf + myPhaseInputExt StopLn = osuf + myPhaseInputExt other = phaseInputExt other is_last_phase = next_phase `eqPhase` stop_phase -- sometimes, we keep output from intermediate stages keep_this_output = case next_phase of - StopLn -> True - Mangle | keep_raw_s -> True As | keep_s -> True LlvmOpt | keep_bc -> True HCc | keep_hc -> True @@ -645,32 +717,23 @@ -- of a source file can change the latter stages of the pipeline from -- taking the via-C route to using the native code generator. -- -runPhase :: GhcMonad m => - Phase -- ^ Do this phase first - -> Phase -- ^ Stop just before this phase - -> HscEnv - -> String -- ^ basename of original input source - -> String -- ^ its extension - -> FilePath -- ^ name of file which contains the input to this phase. - -> (DynFlags -> Phase -> Maybe ModLocation -> IO FilePath) - -- ^ how to calculate the output filename - -> Maybe ModLocation -- ^ the ModLocation, if we have one - -> m (Phase, -- next phase - DynFlags, -- new dynamic flags - Maybe ModLocation, -- the ModLocation, if we have one - FilePath) -- output filename +runPhase :: Phase -- ^ Run this phase + -> FilePath -- ^ name of the input file + -> DynFlags -- ^ for convenience, we pass the current dflags in + -> CompPipeline (Phase, -- next phase to run + FilePath) -- output filename -- Invariant: the output filename always contains the output -- Interesting case: Hsc when there is no recompilation to do -- Then the output filename is still a .o file + ------------------------------------------------------------------------------- -- Unlit phase -runPhase (Unlit sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc +runPhase (Unlit sf) input_fn dflags = do - let dflags = hsc_dflags hsc_env - output_fn <- liftIO $ get_output_fn dflags (Cpp sf) maybe_loc + output_fn <- phaseOutputFilename (Cpp sf) let unlit_flags = getOpts dflags opt_L flags = map SysTools.Option unlit_flags ++ @@ -684,56 +747,60 @@ , SysTools.FileOption "" output_fn ] - liftIO $ SysTools.runUnlit dflags flags + io $ SysTools.runUnlit dflags flags - return (Cpp sf, dflags, maybe_loc, output_fn) + return (Cpp sf, output_fn) ------------------------------------------------------------------------------- -- Cpp phase : (a) gets OPTIONS out of file -- (b) runs cpp if necessary -runPhase (Cpp sf) _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc - = do let dflags0 = hsc_dflags hsc_env - src_opts <- liftIO $ getOptionsFromFile dflags0 input_fn +runPhase (Cpp sf) input_fn dflags0 + = do + src_opts <- io $ getOptionsFromFile dflags0 input_fn (dflags1, unhandled_flags, warns) - <- liftIO $ parseDynamicNoPackageFlags dflags0 src_opts - checkProcessArgsResult unhandled_flags + <- io $ parseDynamicFilePragma dflags0 src_opts + setDynFlags dflags1 + io $ checkProcessArgsResult unhandled_flags if not (xopt Opt_Cpp dflags1) then do -- we have to be careful to emit warnings only once. - unless (dopt Opt_Pp dflags1) $ handleFlagWarnings dflags1 warns + unless (dopt Opt_Pp dflags1) $ io $ handleFlagWarnings dflags1 warns -- no need to preprocess CPP, just pass input file along -- to the next phase of the pipeline. - return (HsPp sf, dflags1, maybe_loc, input_fn) + return (HsPp sf, input_fn) else do - output_fn <- liftIO $ get_output_fn dflags1 (HsPp sf) maybe_loc - liftIO $ doCpp dflags1 True{-raw-} False{-no CC opts-} input_fn output_fn + output_fn <- phaseOutputFilename (HsPp sf) + io $ doCpp dflags1 True{-raw-} False{-no CC opts-} input_fn output_fn -- re-read the pragmas now that we've preprocessed the file -- See #2464,#3457 - src_opts <- liftIO $ getOptionsFromFile dflags0 output_fn + src_opts <- io $ getOptionsFromFile dflags0 output_fn (dflags2, unhandled_flags, warns) - <- liftIO $ parseDynamicNoPackageFlags dflags0 src_opts - unless (dopt Opt_Pp dflags2) $ handleFlagWarnings dflags2 warns + <- io $ parseDynamicFilePragma dflags0 src_opts + io $ checkProcessArgsResult unhandled_flags + unless (dopt Opt_Pp dflags2) $ io $ handleFlagWarnings dflags2 warns -- the HsPp pass below will emit warnings - checkProcessArgsResult unhandled_flags - return (HsPp sf, dflags2, maybe_loc, output_fn) + setDynFlags dflags2 + + return (HsPp sf, output_fn) ------------------------------------------------------------------------------- -- HsPp phase -runPhase (HsPp sf) _stop hsc_env basename suff input_fn get_output_fn maybe_loc - = do let dflags = hsc_dflags hsc_env +runPhase (HsPp sf) input_fn dflags + = do if not (dopt Opt_Pp dflags) then -- no need to preprocess, just pass input file along -- to the next phase of the pipeline. - return (Hsc sf, dflags, maybe_loc, input_fn) + return (Hsc sf, input_fn) else do let hspp_opts = getOpts dflags opt_F - let orig_fn = basename <.> suff - output_fn <- liftIO $ get_output_fn dflags (Hsc sf) maybe_loc - liftIO $ SysTools.runPp dflags + PipeEnv{src_basename, src_suffix} <- getPipeEnv + let orig_fn = src_basename <.> src_suffix + output_fn <- phaseOutputFilename (Hsc sf) + io $ SysTools.runPp dflags ( [ SysTools.Option orig_fn , SysTools.Option input_fn , SysTools.FileOption "" output_fn @@ -742,22 +809,26 @@ ) -- re-read pragmas now that we've parsed the file (see #3674) - src_opts <- liftIO $ getOptionsFromFile dflags output_fn + src_opts <- io $ getOptionsFromFile dflags output_fn (dflags1, unhandled_flags, warns) - <- liftIO $ parseDynamicNoPackageFlags dflags src_opts - handleFlagWarnings dflags1 warns - checkProcessArgsResult unhandled_flags + <- io $ parseDynamicFilePragma dflags src_opts + setDynFlags dflags1 + io $ checkProcessArgsResult unhandled_flags + io $ handleFlagWarnings dflags1 warns - return (Hsc sf, dflags1, maybe_loc, output_fn) + return (Hsc sf, output_fn) ----------------------------------------------------------------------------- -- Hsc phase -- Compilation of a single module, in "legacy" mode (_not_ under -- the direction of the compilation manager). -runPhase (Hsc src_flavour) stop hsc_env basename suff input_fn get_output_fn _maybe_loc +runPhase (Hsc src_flavour) input_fn dflags0 = do -- normal Hsc mode, not mkdependHS - let dflags0 = hsc_dflags hsc_env + + PipeEnv{ stop_phase=stop, + src_basename=basename, + src_suffix=suff } <- getPipeEnv -- we add the current directory (i.e. the directory in which -- the .hs files resides) to the include path, since this is @@ -769,15 +840,17 @@ paths = includePaths dflags0 dflags = dflags0 { includePaths = current_dir : paths } + setDynFlags dflags + -- gather the imports and module name - (hspp_buf,mod_name,imps,src_imps) <- + (hspp_buf,mod_name,imps,src_imps) <- io $ case src_flavour of ExtCoreFile -> do -- no explicit imports in ExtCore input. - m <- liftIO $ getCoreModuleName input_fn + m <- getCoreModuleName input_fn return (Nothing, mkModuleName m, [], []) _ -> do - buf <- liftIO $ hGetStringBuffer input_fn + buf <- hGetStringBuffer input_fn (src_imps,imps,L _ mod_name) <- getImports dflags buf input_fn (basename <.> suff) return (Just buf, mod_name, imps, src_imps) @@ -787,7 +860,7 @@ -- the .hi and .o filenames, and this is as good a way -- as any to generate them, and better than most. (e.g. takes -- into accout the -osuf flags) - location1 <- liftIO $ mkHomeModLocation2 dflags mod_name basename suff + location1 <- io $ mkHomeModLocation2 dflags mod_name basename suff -- Boot-ify it if necessary let location2 | isHsBoot src_flavour = addBootSuffixLocn location1 @@ -814,6 +887,7 @@ o_file = ml_obj_file location4 -- The real object file + setModLocation location4 -- Figure out if the source has changed, for recompilation avoidance. -- @@ -822,37 +896,37 @@ -- changed (which the compiler itself figures out). -- Setting source_unchanged to False tells the compiler that M.o is out of -- date wrt M.hs (or M.o doesn't exist) so we must recompile regardless. - src_timestamp <- liftIO $ getModificationTime (basename <.> suff) + src_timestamp <- io $ getModificationTime (basename <.> suff) - let force_recomp = dopt Opt_ForceRecomp dflags - hsc_lang = hscMaybeAdjustTarget dflags stop src_flavour (hscTarget dflags) - source_unchanged <- - if force_recomp || not (isStopLn stop) - -- Set source_unchanged to False unconditionally if + let hsc_lang = hscTarget dflags + source_unchanged <- io $ + if not (isStopLn stop) + -- SourceModified unconditionally if -- (a) recompilation checker is off, or -- (b) we aren't going all the way to .o file (e.g. ghc -S) - then return False + then return SourceModified -- Otherwise look at file modification dates - else do o_file_exists <- liftIO $ doesFileExist o_file + else do o_file_exists <- doesFileExist o_file if not o_file_exists - then return False -- Need to recompile - else do t2 <- liftIO $ getModificationTime o_file + then return SourceModified -- Need to recompile + else do t2 <- getModificationTime o_file if t2 > src_timestamp - then return True - else return False + then return SourceUnmodified + else return SourceModified -- get the DynFlags let next_phase = hscNextPhase dflags src_flavour hsc_lang - output_fn <- liftIO $ get_output_fn dflags next_phase (Just location4) + output_fn <- phaseOutputFilename next_phase let dflags' = dflags { hscTarget = hsc_lang, hscOutName = output_fn, extCoreName = basename ++ ".hcr" } - let hsc_env' = hsc_env {hsc_dflags = dflags'} + setDynFlags dflags' + PipeState{hsc_env=hsc_env'} <- getPipeState -- Tell the finder cache about this module - mod <- liftIO $ addHomeModuleToFinder hsc_env' mod_name location4 + mod <- io $ addHomeModuleToFinder hsc_env' mod_name location4 -- Make the ModSummary to hand to hscMain let @@ -864,62 +938,68 @@ ms_location = location4, ms_hs_date = src_timestamp, ms_obj_date = Nothing, - ms_imps = imps, - ms_srcimps = src_imps } + ms_textual_imps = imps, + ms_srcimps = src_imps } -- run the compiler! - result <- hscCompileOneShot hsc_env' + result <- io $ hscCompileOneShot hsc_env' mod_summary source_unchanged Nothing -- No iface Nothing -- No "module i of n" progress info case result of HscNoRecomp - -> do liftIO $ SysTools.touch dflags' "Touching object file" o_file + -> do io $ SysTools.touch dflags' "Touching object file" o_file -- The .o file must have a later modification date -- than the source file (else we wouldn't be in HscNoRecomp) -- but we touch it anyway, to keep 'make' happy (we think). - return (StopLn, dflags', Just location4, o_file) + return (StopLn, o_file) (HscRecomp hasStub _) - -> do when hasStub $ - do stub_o <- compileStub hsc_env' mod location4 - liftIO $ consIORef v_Ld_inputs stub_o + -> do case hasStub of + Nothing -> return () + Just stub_c -> + do stub_o <- io $ compileStub hsc_env' stub_c + setStubO stub_o -- In the case of hs-boot files, generate a dummy .o-boot -- stamp file for the benefit of Make when (isHsBoot src_flavour) $ - liftIO $ SysTools.touch dflags' "Touching object file" o_file - return (next_phase, dflags', Just location4, output_fn) + io $ SysTools.touch dflags' "Touching object file" o_file + return (next_phase, output_fn) ----------------------------------------------------------------------------- -- Cmm phase -runPhase CmmCpp _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc +runPhase CmmCpp input_fn dflags = do - let dflags = hsc_dflags hsc_env - output_fn <- liftIO $ get_output_fn dflags Cmm maybe_loc - liftIO $ doCpp dflags False{-not raw-} True{-include CC opts-} input_fn output_fn - return (Cmm, dflags, maybe_loc, output_fn) + output_fn <- phaseOutputFilename Cmm + io $ doCpp dflags False{-not raw-} True{-include CC opts-} + input_fn output_fn + return (Cmm, output_fn) -runPhase Cmm stop hsc_env basename _ input_fn get_output_fn maybe_loc +runPhase Cmm input_fn dflags = do - let dflags = hsc_dflags hsc_env - let hsc_lang = hscMaybeAdjustTarget dflags stop HsSrcFile (hscTarget dflags) + PipeEnv{src_basename} <- getPipeEnv + let hsc_lang = hscTarget dflags + let next_phase = hscNextPhase dflags HsSrcFile hsc_lang - output_fn <- liftIO $ get_output_fn dflags next_phase maybe_loc + + output_fn <- phaseOutputFilename next_phase let dflags' = dflags { hscTarget = hsc_lang, hscOutName = output_fn, - extCoreName = basename ++ ".hcr" } - let hsc_env' = hsc_env {hsc_dflags = dflags'} + extCoreName = src_basename ++ ".hcr" } - hscCmmFile hsc_env' input_fn + setDynFlags dflags' + PipeState{hsc_env} <- getPipeState + + io $ hscCompileCmmFile hsc_env input_fn -- XXX: catch errors above and convert them into ghcError? Original -- code was: -- --when (not ok) $ ghcError (PhaseFailed "cmm" (ExitFailure 1)) - return (next_phase, dflags, maybe_loc, output_fn) + return (next_phase, output_fn) ----------------------------------------------------------------------------- -- Cc phase @@ -927,40 +1007,39 @@ -- we don't support preprocessing .c files (with -E) now. Doing so introduces -- way too many hacks, and I can't say I've ever used it anyway. -runPhase cc_phase _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc - | cc_phase `eqPhase` Cc || cc_phase `eqPhase` Ccpp || cc_phase `eqPhase` HCc - = do let dflags = hsc_dflags hsc_env +runPhase cc_phase input_fn dflags + | cc_phase `eqPhase` Cc || cc_phase `eqPhase` Ccpp || cc_phase `eqPhase` HCc || cc_phase `eqPhase` Cobjc + = do let cc_opts = getOpts dflags opt_c hcc = cc_phase `eqPhase` HCc let cmdline_include_paths = includePaths dflags -- HC files have the dependent packages stamped into them - pkgs <- if hcc then liftIO (getHCFilePackages input_fn) else return [] + pkgs <- if hcc then io $ getHCFilePackages input_fn else return [] -- add package include paths even if we're just compiling .c -- files; this is the Value Add(TM) that using ghc instead of -- gcc gives you :) - pkg_include_dirs <- liftIO $ getPackageIncludePath dflags pkgs + pkg_include_dirs <- io $ getPackageIncludePath dflags pkgs let include_paths = foldr (\ x xs -> "-I" : x : xs) [] (cmdline_include_paths ++ pkg_include_dirs) - let (md_c_flags, md_regd_c_flags) = machdepCCOpts dflags - gcc_extra_viac_flags <- liftIO $ getExtraViaCOpts dflags + let gcc_extra_viac_flags = extraGccViaCFlags dflags let pic_c_flags = picCCOpts dflags - let verb = getVerbFlag dflags + let verbFlags = getVerbFlags dflags -- cc-options are not passed when compiling .hc files. Our -- hc code doesn't not #include any header files anyway, so these -- options aren't necessary. - pkg_extra_cc_opts <- + pkg_extra_cc_opts <- io $ if cc_phase `eqPhase` HCc then return [] - else liftIO $ getPackageExtraCcOpts dflags pkgs + else getPackageExtraCcOpts dflags pkgs #ifdef darwin_TARGET_OS - pkg_framework_paths <- liftIO $ getPackageFrameworkPath dflags pkgs + pkg_framework_paths <- io $ getPackageFrameworkPath dflags pkgs let cmdline_framework_paths = frameworkPaths dflags let framework_paths = map ("-F"++) (cmdline_framework_paths ++ pkg_framework_paths) @@ -975,23 +1054,19 @@ -- Decide next phase - let mangle = dopt Opt_DoAsmMangling dflags - next_phase - | hcc && mangle = Mangle - | otherwise = As - output_fn <- liftIO $ get_output_fn dflags next_phase maybe_loc + let next_phase = As + output_fn <- phaseOutputFilename next_phase let more_hcc_opts = -#if i386_TARGET_ARCH -- on x86 the floating point regs have greater precision -- than a double, which leads to unpredictable results. -- By default, we turn this off with -ffloat-store unless -- the user specified -fexcess-precision. - (if dopt Opt_ExcessPrecision dflags - then [] - else [ "-ffloat-store" ]) ++ -#endif + (if platformArch (targetPlatform dflags) == ArchX86 && + not (dopt Opt_ExcessPrecision dflags) + then [ "-ffloat-store" ] + else []) ++ -- gcc's -fstrict-aliasing allows two accesses to memory -- to be considered non-aliasing if they have different types. @@ -999,56 +1074,47 @@ -- very weakly typed, being derived from C--. ["-fno-strict-aliasing"] - liftIO $ SysTools.runCc dflags ( + let gcc_lang_opt | cc_phase `eqPhase` Ccpp = "c++" + | cc_phase `eqPhase` Cobjc = "objective-c" + | otherwise = "c" + io $ SysTools.runCc dflags ( -- force the C compiler to interpret this file as C when -- compiling .hc files, by adding the -x c option. -- Also useful for plain .c files, just in case GHC saw a -- -x c option. - [ SysTools.Option "-x", if cc_phase `eqPhase` Ccpp - then SysTools.Option "c++" - else SysTools.Option "c"] ++ - [ SysTools.FileOption "" input_fn + [ SysTools.Option "-x", SysTools.Option gcc_lang_opt + , SysTools.FileOption "" input_fn , SysTools.Option "-o" , SysTools.FileOption "" output_fn ] ++ map SysTools.Option ( - md_c_flags - ++ pic_c_flags + pic_c_flags -#if defined(mingw32_TARGET_OS) -- Stub files generated for foreign exports references the runIO_closure -- and runNonIO_closure symbols, which are defined in the base package. -- These symbols are imported into the stub.c file via RtsAPI.h, and the -- way we do the import depends on whether we're currently compiling -- the base package or not. - ++ (if thisPackage dflags == basePackageId + ++ (if platformOS (targetPlatform dflags) == OSMinGW32 && + thisPackage dflags == basePackageId then [ "-DCOMPILING_BASE_PACKAGE" ] else []) -#endif -#ifdef sparc_TARGET_ARCH -- We only support SparcV9 and better because V8 lacks an atomic CAS -- instruction. Note that the user can still override this -- (e.g., -mcpu=ultrasparc) as GCC picks the "best" -mcpu flag -- regardless of the ordering. -- -- This is a temporary hack. - ++ ["-mcpu=v9"] -#endif - ++ (if hcc && mangle - then md_regd_c_flags - else []) - ++ (if hcc - then if mangle - then gcc_extra_viac_flags - else filter (=="-fwrapv") - gcc_extra_viac_flags - -- still want -fwrapv even for unreg'd - else []) + ++ (if platformArch (targetPlatform dflags) == ArchSPARC + then ["-mcpu=v9"] + else []) + ++ (if hcc - then more_hcc_opts + then gcc_extra_viac_flags ++ more_hcc_opts else []) - ++ [ verb, "-S", "-Wimplicit", cc_opt ] + ++ verbFlags + ++ [ "-S", "-Wimplicit", cc_opt ] ++ [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ] #ifdef darwin_TARGET_OS ++ framework_paths @@ -1059,86 +1125,58 @@ ++ pkg_extra_cc_opts )) - return (next_phase, dflags, maybe_loc, output_fn) + return (next_phase, output_fn) -- ToDo: postprocess the output from gcc ----------------------------------------------------------------------------- --- Mangle phase - -runPhase Mangle _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc - = do let dflags = hsc_dflags hsc_env - let mangler_opts = getOpts dflags opt_m - -#if i386_TARGET_ARCH - machdep_opts <- return [ show (stolen_x86_regs dflags) ] -#else - machdep_opts <- return [] -#endif - - let split = dopt Opt_SplitObjs dflags - next_phase - | split = SplitMangle - | otherwise = As - output_fn <- liftIO $ get_output_fn dflags next_phase maybe_loc - - liftIO $ SysTools.runMangle dflags (map SysTools.Option mangler_opts - ++ [ SysTools.FileOption "" input_fn - , SysTools.FileOption "" output_fn - ] - ++ map SysTools.Option machdep_opts) - - return (next_phase, dflags, maybe_loc, output_fn) - ------------------------------------------------------------------------------ -- Splitting phase -runPhase SplitMangle _stop hsc_env _basename _suff input_fn _get_output_fn maybe_loc - = liftIO $ - do -- tmp_pfx is the prefix used for the split .s files - -- We also use it as the file to contain the no. of split .s files (sigh) - let dflags = hsc_dflags hsc_env - split_s_prefix <- SysTools.newTempName dflags "split" +runPhase SplitMangle input_fn dflags + = do -- tmp_pfx is the prefix used for the split .s files + + split_s_prefix <- io $ SysTools.newTempName dflags "split" let n_files_fn = split_s_prefix - SysTools.runSplit dflags + io $ SysTools.runSplit dflags [ SysTools.FileOption "" input_fn , SysTools.FileOption "" split_s_prefix , SysTools.FileOption "" n_files_fn ] -- Save the number of split files for future references - s <- readFile n_files_fn + s <- io $ readFile n_files_fn let n_files = read s :: Int dflags' = dflags { splitInfo = Just (split_s_prefix, n_files) } + setDynFlags dflags' + -- Remember to delete all these files - addFilesToClean dflags' [ split_s_prefix ++ "__" ++ show n ++ ".s" - | n <- [1..n_files]] + io $ addFilesToClean dflags' [ split_s_prefix ++ "__" ++ show n ++ ".s" + | n <- [1..n_files]] - return (SplitAs, dflags', maybe_loc, "**splitmangle**") + return (SplitAs, "**splitmangle**") -- we don't use the filename ----------------------------------------------------------------------------- -- As phase -runPhase As _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc - = liftIO $ - do let dflags = hsc_dflags hsc_env +runPhase As input_fn dflags + = do let as_opts = getOpts dflags opt_a let cmdline_include_paths = includePaths dflags - output_fn <- get_output_fn dflags StopLn maybe_loc + next_phase <- maybeMergeStub + output_fn <- phaseOutputFilename next_phase -- we create directories for the object file, because it -- might be a hierarchical module. - createDirectoryHierarchy (takeDirectory output_fn) + io $ createDirectoryHierarchy (takeDirectory output_fn) - let (md_c_flags, _) = machdepCCOpts dflags - SysTools.runAs dflags + io $ SysTools.runAs dflags (map SysTools.Option as_opts ++ [ SysTools.Option ("-I" ++ p) | p <- cmdline_include_paths ] -#ifdef sparc_TARGET_ARCH + -- We only support SparcV9 and better because V8 lacks an atomic CAS -- instruction so we have to make sure that the assembler accepts the -- instruction set. Note that the user can still override this @@ -1146,33 +1184,37 @@ -- regardless of the ordering. -- -- This is a temporary hack. - ++ [ SysTools.Option "-mcpu=v9" ] -#endif + ++ (if platformArch (targetPlatform dflags) == ArchSPARC + then [SysTools.Option "-mcpu=v9"] + else []) + ++ [ SysTools.Option "-c" , SysTools.FileOption "" input_fn , SysTools.Option "-o" , SysTools.FileOption "" output_fn - ] - ++ map SysTools.Option md_c_flags) + ]) - return (StopLn, dflags, maybe_loc, output_fn) + return (next_phase, output_fn) -runPhase SplitAs _stop hsc_env _basename _suff _input_fn get_output_fn maybe_loc - = liftIO $ do - let dflags = hsc_dflags hsc_env - output_fn <- get_output_fn dflags StopLn maybe_loc +runPhase SplitAs _input_fn dflags + = do + -- we'll handle the stub_o file in this phase, so don't MergeStub, + -- just jump straight to StopLn afterwards. + let next_phase = StopLn + output_fn <- phaseOutputFilename next_phase let base_o = dropExtension output_fn osuf = objectSuf dflags split_odir = base_o ++ "_" ++ osuf ++ "_split" - createDirectoryHierarchy split_odir + io $ createDirectoryHierarchy split_odir -- remove M_split/ *.o, because we're going to archive M_split/ *.o -- later and we don't want to pick up any old objects. - fs <- getDirectoryContents split_odir - mapM_ removeFile $ map (split_odir ) $ filter (osuf `isSuffixOf`) fs + fs <- io $ getDirectoryContents split_odir + io $ mapM_ removeFile $ + map (split_odir ) $ filter (osuf `isSuffixOf`) fs let as_opts = getOpts dflags opt_a @@ -1181,14 +1223,15 @@ Just x -> x let split_s n = split_s_prefix ++ "__" ++ show n <.> "s" + + split_obj :: Int -> FilePath split_obj n = split_odir takeFileName base_o ++ "__" ++ show n <.> osuf - let (md_c_flags, _) = machdepCCOpts dflags let assemble_file n = SysTools.runAs dflags (map SysTools.Option as_opts ++ -#ifdef sparc_TARGET_ARCH + -- We only support SparcV9 and better because V8 lacks an atomic CAS -- instruction so we have to make sure that the assembler accepts the -- instruction set. Note that the user can still override this @@ -1196,48 +1239,51 @@ -- regardless of the ordering. -- -- This is a temporary hack. - [ SysTools.Option "-mcpu=v9" ] ++ -#endif + (if platformArch (targetPlatform dflags) == ArchSPARC + then [SysTools.Option "-mcpu=v9"] + else []) ++ + [ SysTools.Option "-c" , SysTools.Option "-o" , SysTools.FileOption "" (split_obj n) , SysTools.FileOption "" (split_s n) - ] - ++ map SysTools.Option md_c_flags) - - mapM_ assemble_file [1..n] + ]) - -- and join the split objects into a single object file: - let ld_r args = SysTools.runLink dflags ([ - SysTools.Option "-nostdlib", - SysTools.Option "-nodefaultlibs", - SysTools.Option "-Wl,-r", - SysTools.Option ld_x_flag, - SysTools.Option "-o", - SysTools.FileOption "" output_fn ] - ++ map SysTools.Option md_c_flags - ++ args) - ld_x_flag | null cLD_X = "" - | otherwise = "-Wl,-x" + io $ mapM_ assemble_file [1..n] - if cLdIsGNULd == "YES" - then do - let script = split_odir "ld.script" - writeFile script $ - "INPUT(" ++ unwords (map split_obj [1..n]) ++ ")" - ld_r [SysTools.FileOption "" script] - else do - ld_r (map (SysTools.FileOption "" . split_obj) [1..n]) + -- Note [pipeline-split-init] + -- If we have a stub file, it may contain constructor + -- functions for initialisation of this module. We can't + -- simply leave the stub as a separate object file, because it + -- will never be linked in: nothing refers to it. We need to + -- ensure that if we ever refer to the data in this module + -- that needs initialisation, then we also pull in the + -- initialisation routine. + -- + -- To that end, we make a DANGEROUS ASSUMPTION here: the data + -- that needs to be initialised is all in the FIRST split + -- object. See Note [codegen-split-init]. + + PipeState{maybe_stub_o} <- getPipeState + case maybe_stub_o of + Nothing -> return () + Just stub_o -> io $ do + tmp_split_1 <- newTempName dflags osuf + let split_1 = split_obj 1 + copyFile split_1 tmp_split_1 + removeFile split_1 + joinObjectFiles dflags [tmp_split_1, stub_o] split_1 - return (StopLn, dflags, maybe_loc, output_fn) + -- join them into a single .o file + io $ joinObjectFiles dflags (map split_obj [1..n]) output_fn + return (next_phase, output_fn) ----------------------------------------------------------------------------- -- LlvmOpt phase -runPhase LlvmOpt _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc - = liftIO $ do - let dflags = hsc_dflags hsc_env +runPhase LlvmOpt input_fn dflags + = do let lo_opts = getOpts dflags opt_lo let opt_lvl = max 0 (min 2 $ optLevel dflags) -- don't specify anything if user has specified commands. We do this for @@ -1248,71 +1294,81 @@ then [SysTools.Option (llvmOpts !! opt_lvl)] else [] - output_fn <- get_output_fn dflags LlvmLlc maybe_loc + output_fn <- phaseOutputFilename LlvmLlc - SysTools.runLlvmOpt dflags + io $ SysTools.runLlvmOpt dflags ([ SysTools.FileOption "" input_fn, SysTools.Option "-o", SysTools.FileOption "" output_fn] ++ optFlag ++ map SysTools.Option lo_opts) - return (LlvmLlc, dflags, maybe_loc, output_fn) + return (LlvmLlc, output_fn) where -- we always (unless -optlo specified) run Opt since we rely on it to -- fix up some pretty big deficiencies in the code we generate llvmOpts = ["-mem2reg", "-O1", "-O2"] - ----------------------------------------------------------------------------- -- LlvmLlc phase -runPhase LlvmLlc _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc - = liftIO $ do - let dflags = hsc_dflags hsc_env +runPhase LlvmLlc input_fn dflags + = do let lc_opts = getOpts dflags opt_lc - let opt_lvl = max 0 (min 2 $ optLevel dflags) -#if darwin_TARGET_OS - let nphase = LlvmMangle -#else - let nphase = As -#endif - let rmodel | opt_PIC = "pic" + opt_lvl = max 0 (min 2 $ optLevel dflags) + rmodel | opt_PIC = "pic" | not opt_Static = "dynamic-no-pic" | otherwise = "static" - output_fn <- get_output_fn dflags nphase maybe_loc + output_fn <- phaseOutputFilename LlvmMangle - SysTools.runLlvmLlc dflags + io $ SysTools.runLlvmLlc dflags ([ SysTools.Option (llvmOpts !! opt_lvl), SysTools.Option $ "-relocation-model=" ++ rmodel, SysTools.FileOption "" input_fn, SysTools.Option "-o", SysTools.FileOption "" output_fn] ++ map SysTools.Option lc_opts) - return (nphase, dflags, maybe_loc, output_fn) + return (LlvmMangle, output_fn) where -#if darwin_TARGET_OS - llvmOpts = ["-O1", "-O2", "-O2"] -#else - llvmOpts = ["-O1", "-O2", "-O3"] -#endif - + -- Bug in LLVM at O3 on OSX. + llvmOpts = if platformOS (targetPlatform dflags) == OSDarwin + then ["-O1", "-O2", "-O2"] + else ["-O1", "-O2", "-O3"] ----------------------------------------------------------------------------- -- LlvmMangle phase -runPhase LlvmMangle _stop hsc_env _basename _suff input_fn get_output_fn maybe_loc - = liftIO $ do - let dflags = hsc_dflags hsc_env - output_fn <- get_output_fn dflags As maybe_loc - llvmFixupAsm input_fn output_fn - return (As, dflags, maybe_loc, output_fn) +runPhase LlvmMangle input_fn _dflags + = do + output_fn <- phaseOutputFilename As + io $ llvmFixupAsm input_fn output_fn + return (As, output_fn) + +----------------------------------------------------------------------------- +-- merge in stub objects +runPhase MergeStub input_fn dflags + = do + PipeState{maybe_stub_o} <- getPipeState + output_fn <- phaseOutputFilename StopLn + case maybe_stub_o of + Nothing -> + panic "runPhase(MergeStub): no stub" + Just stub_o -> do + io $ joinObjectFiles dflags [input_fn, stub_o] output_fn + return (StopLn, output_fn) -- warning suppression -runPhase other _stop _dflags _basename _suff _input_fn _get_output_fn _maybe_loc = +runPhase other _input_fn _dflags = panic ("runPhase: don't know how to run phase " ++ show other) + +maybeMergeStub :: CompPipeline Phase +maybeMergeStub + = do + PipeState{maybe_stub_o} <- getPipeState + if isJust maybe_stub_o then return MergeStub else return StopLn + ----------------------------------------------------------------------------- -- MoveBinary sort-of-phase -- After having produced a binary, move it somewhere else and generate a @@ -1344,35 +1400,96 @@ return True | otherwise = return True -mkExtraCObj :: DynFlags -> [String] -> IO FilePath +mkExtraCObj :: DynFlags -> String -> IO FilePath mkExtraCObj dflags xs = do cFile <- newTempName dflags "c" oFile <- newTempName dflags "o" - writeFile cFile $ unlines xs + writeFile cFile xs let rtsDetails = getPackageDetails (pkgState dflags) rtsPackageId - (md_c_flags, _) = machdepCCOpts dflags SysTools.runCc dflags ([Option "-c", FileOption "" cFile, Option "-o", FileOption "" oFile] ++ - map (FileOption "-I") (includeDirs rtsDetails) ++ - map Option md_c_flags) + map (FileOption "-I") (includeDirs rtsDetails)) return oFile -mkRtsOptionsLevelObj :: DynFlags -> IO [FilePath] -mkRtsOptionsLevelObj dflags - = do let mkRtsEnabledObj val - = do fn <- mkExtraCObj dflags - ["#include \"Rts.h\"", - "#include \"RtsOpts.h\"", - "const rtsOptsEnabledEnum rtsOptsEnabled = " - ++ val ++ ";"] - return [fn] - case rtsOptsEnabled dflags of - RtsOptsNone -> mkRtsEnabledObj "rtsOptsNone" - RtsOptsSafeOnly -> return [] -- The default - RtsOptsAll -> mkRtsEnabledObj "rtsOptsAll" +mkExtraObjToLinkIntoBinary :: DynFlags -> [PackageId] -> IO FilePath +mkExtraObjToLinkIntoBinary dflags dep_packages = do + link_info <- getLinkInfo dflags dep_packages + mkExtraCObj dflags (showSDoc (vcat [rts_opts_enabled, + extra_rts_opts, + link_opts link_info] + <> char '\n')) -- final newline, to + -- keep gcc happy + + where + mk_rts_opts_enabled val + = vcat [text "#include \"Rts.h\"", + text "#include \"RtsOpts.h\"", + text "const RtsOptsEnabledEnum rtsOptsEnabled = " <> + text val <> semi ] + + rts_opts_enabled = case rtsOptsEnabled dflags of + RtsOptsNone -> mk_rts_opts_enabled "RtsOptsNone" + RtsOptsSafeOnly -> empty -- The default + RtsOptsAll -> mk_rts_opts_enabled "RtsOptsAll" + + extra_rts_opts = case rtsOpts dflags of + Nothing -> empty + Just opts -> text "char *ghc_rts_opts = " <> text (show opts) <> semi + + link_opts info + | isDarwinTarget = empty + | isWindowsTarget = empty + | otherwise = hcat [ + text "__asm__(\"\\t.section ", text ghcLinkInfoSectionName, + text ",\\\"\\\",", + text elfSectionNote, + text "\\n", + + text "\\t.ascii \\\"", info', text "\\\"\\n\");" ] + where + -- we need to escape twice: once because we're inside a C string, + -- and again because we're inside an asm string. + info' = text $ (escape.escape) info + + escape :: String -> String + escape = concatMap (charToC.fromIntegral.ord) + + elfSectionNote :: String + elfSectionNote = case platformArch (targetPlatform dflags) of + ArchX86 -> "@note" + ArchX86_64 -> "@note" + ArchPPC -> "@note" + ArchPPC_64 -> "@note" + ArchSPARC -> "@note" + ArchARM -> "%note" + ArchUnknown -> panic "elfSectionNote ArchUnknown" + +-- The "link info" is a string representing the parameters of the +-- link. We save this information in the binary, and the next time we +-- link, if nothing else has changed, we use the link info stored in +-- the existing binary to decide whether to re-link or not. +getLinkInfo :: DynFlags -> [PackageId] -> IO String +getLinkInfo dflags dep_packages = do + package_link_opts <- getPackageLinkOpts dflags dep_packages +#ifdef darwin_TARGET_OS + pkg_frameworks <- getPackageFrameworks dflags dep_packages +#endif + extra_ld_inputs <- readIORef v_Ld_inputs + let + link_info = (package_link_opts, +#ifdef darwin_TARGET_OS + pkg_frameworks, +#endif + rtsOpts dflags, + rtsOptsEnabled dflags, + dopt Opt_NoHsMain dflags, + extra_ld_inputs, + getOpts dflags opt_l) + -- + return (show link_info) -- generates a Perl skript starting a parallel prg under PVM mk_pvm_wrapper_script :: String -> String -> String -> String @@ -1459,7 +1576,7 @@ linkBinary :: DynFlags -> [FilePath] -> [PackageId] -> IO () linkBinary dflags o_files dep_packages = do - let verb = getVerbFlag dflags + let verbFlags = getVerbFlags dflags output_fn = exeFileName dflags -- get the full list of packages to link with, by combining the @@ -1468,12 +1585,12 @@ pkg_lib_paths <- getPackageLibraryPath dflags dep_packages let pkg_lib_path_opts = concat (map get_pkg_lib_path_opts pkg_lib_paths) -#ifdef elf_OBJ_FORMAT - get_pkg_lib_path_opts l | (dynLibLoader dflags)==SystemDependent && not opt_Static = ["-L" ++ l, "-Wl,-rpath", "-Wl," ++ l] - | otherwise = ["-L" ++ l] -#else - get_pkg_lib_path_opts l = ["-L" ++ l] -#endif + get_pkg_lib_path_opts l + | osElfTarget (platformOS (targetPlatform dflags)) && + dynLibLoader dflags == SystemDependent && + not opt_Static + = ["-L" ++ l, "-Wl,-rpath", "-Wl," ++ l] + | otherwise = ["-L" ++ l] let lib_paths = libraryPaths dflags let lib_path_opts = map ("-L"++) lib_paths @@ -1484,15 +1601,8 @@ let no_hs_main = dopt Opt_NoHsMain dflags let main_lib | no_hs_main = [] | otherwise = [ "-lHSrtsmain" ] - rtsEnabledObj <- mkRtsOptionsLevelObj dflags - rtsOptsObj <- case rtsOpts dflags of - Just opts -> - do fn <- mkExtraCObj dflags - -- We assume that the Haskell "show" does - -- the right thing here - ["char *ghc_rts_opts = " ++ show opts ++ ";"] - return [fn] - Nothing -> return [] + + extraLinkObj <- mkExtraObjToLinkIntoBinary dflags dep_packages pkg_link_opts <- getPackageLinkOpts dflags dep_packages @@ -1542,20 +1652,31 @@ rc_objs <- maybeCreateManifest dflags output_fn - let (md_c_flags, _) = machdepCCOpts dflags SysTools.runLink dflags ( - [ SysTools.Option verb - , SysTools.Option "-o" - , SysTools.FileOption "" output_fn - ] + map SysTools.Option verbFlags + ++ [ SysTools.Option "-o" + , SysTools.FileOption "" output_fn + ] ++ map SysTools.Option ( - md_c_flags + [] -#ifdef mingw32_TARGET_OS -- Permit the linker to auto link _symbol to _imp_symbol. -- This lets us link against DLLs without needing an "import library". - ++ ["-Wl,--enable-auto-import"] -#endif + ++ (if platformOS (targetPlatform dflags) == OSMinGW32 + then ["-Wl,--enable-auto-import"] + else []) + + -- '-no_pie' - On OS X, the linker otherwise complains that it cannot build + -- position independent code due to some offensive code in GMP. + -- '-no_compact_unwind' + -- - C++/Objective-C exceptions cannot use optimised stack + -- unwinding code (the optimised form is the default in Xcode 4 on + -- x86_64). + ++ (if platformOS (targetPlatform dflags) == OSDarwin && + platformArch (targetPlatform dflags) == ArchX86_64 + then ["-Wl,-no_pie", "-Wl,-no_compact_unwind"] + else []) + ++ o_files ++ extra_ld_inputs ++ lib_path_opts @@ -1567,8 +1688,7 @@ #endif ++ pkg_lib_path_opts ++ main_lib - ++ rtsEnabledObj - ++ rtsOptsObj + ++ [extraLinkObj] ++ pkg_link_opts #ifdef darwin_TARGET_OS ++ pkg_framework_path_opts @@ -1587,93 +1707,86 @@ exeFileName :: DynFlags -> FilePath exeFileName dflags | Just s <- outputFile dflags = -#if defined(mingw32_HOST_OS) - if null (takeExtension s) - then s <.> "exe" - else s -#else - s -#endif + if platformOS (targetPlatform dflags) == OSMinGW32 + then if null (takeExtension s) + then s <.> "exe" + else s + else s | otherwise = -#if defined(mingw32_HOST_OS) - "main.exe" -#else - "a.out" -#endif + if platformOS (targetPlatform dflags) == OSMinGW32 + then "main.exe" + else "a.out" maybeCreateManifest :: DynFlags -> FilePath -- filename of executable -> IO [FilePath] -- extra objects to embed, maybe -#ifndef mingw32_TARGET_OS -maybeCreateManifest _ _ = do - return [] -#else -maybeCreateManifest dflags exe_filename = do - if not (dopt Opt_GenManifest dflags) then return [] else do +maybeCreateManifest dflags exe_filename + | platformOS (targetPlatform dflags) == OSMinGW32 && + dopt Opt_GenManifest dflags + = do let manifest_filename = exe_filename <.> "manifest" + + writeFile manifest_filename $ + "\n"++ + " \n"++ + " \n\n"++ + " \n"++ + " \n"++ + " \n"++ + " \n"++ + " \n"++ + " \n"++ + " \n"++ + "\n" + + -- Windows will find the manifest file if it is named + -- foo.exe.manifest. However, for extra robustness, and so that + -- we can move the binary around, we can embed the manifest in + -- the binary itself using windres: + if not (dopt Opt_EmbedManifest dflags) then return [] else do + + rc_filename <- newTempName dflags "rc" + rc_obj_filename <- newTempName dflags (objectSuf dflags) + + writeFile rc_filename $ + "1 24 MOVEABLE PURE " ++ show manifest_filename ++ "\n" + -- magic numbers :-) + -- show is a bit hackish above, but we need to escape the + -- backslashes in the path. + + let wr_opts = getOpts dflags opt_windres + runWindres dflags $ map SysTools.Option $ + ["--input="++rc_filename, + "--output="++rc_obj_filename, + "--output-format=coff"] + ++ wr_opts + -- no FileOptions here: windres doesn't like seeing + -- backslashes, apparently - let manifest_filename = exe_filename <.> "manifest" + removeFile manifest_filename - writeFile manifest_filename $ - "\n"++ - " \n"++ - " \n\n"++ - " \n"++ - " \n"++ - " \n"++ - " \n"++ - " \n"++ - " \n"++ - " \n"++ - "\n" - - -- Windows will find the manifest file if it is named foo.exe.manifest. - -- However, for extra robustness, and so that we can move the binary around, - -- we can embed the manifest in the binary itself using windres: - if not (dopt Opt_EmbedManifest dflags) then return [] else do - - rc_filename <- newTempName dflags "rc" - rc_obj_filename <- newTempName dflags (objectSuf dflags) - - writeFile rc_filename $ - "1 24 MOVEABLE PURE " ++ show manifest_filename ++ "\n" - -- magic numbers :-) - -- show is a bit hackish above, but we need to escape the - -- backslashes in the path. - - let wr_opts = getOpts dflags opt_windres - runWindres dflags $ map SysTools.Option $ - ["--input="++rc_filename, - "--output="++rc_obj_filename, - "--output-format=coff"] - ++ wr_opts - -- no FileOptions here: windres doesn't like seeing - -- backslashes, apparently - - removeFile manifest_filename - - return [rc_obj_filename] -#endif + return [rc_obj_filename] + | otherwise = return [] linkDynLib :: DynFlags -> [String] -> [PackageId] -> IO () linkDynLib dflags o_files dep_packages = do - let verb = getVerbFlag dflags + let verbFlags = getVerbFlags dflags let o_file = outputFile dflags pkgs <- getPreloadPackagesAnd dflags dep_packages let pkg_lib_paths = collectLibraryPaths pkgs let pkg_lib_path_opts = concatMap get_pkg_lib_path_opts pkg_lib_paths -#ifdef elf_OBJ_FORMAT - get_pkg_lib_path_opts l | (dynLibLoader dflags)==SystemDependent && not opt_Static = ["-L" ++ l, "-Wl,-rpath", "-Wl," ++ l] - | otherwise = ["-L" ++ l] -#else - get_pkg_lib_path_opts l = ["-L" ++ l] -#endif + get_pkg_lib_path_opts l + | osElfTarget (platformOS (targetPlatform dflags)) && + dynLibLoader dflags == SystemDependent && + not opt_Static + = ["-L" ++ l, "-Wl,-rpath", "-Wl," ++ l] + | otherwise = ["-L" ++ l] let lib_paths = libraryPaths dflags let lib_path_opts = map ("-L"++) lib_paths @@ -1685,20 +1798,19 @@ -- not allow undefined symbols. -- The RTS library path is still added to the library search path -- above in case the RTS is being explicitly linked in (see #3807). -#if !defined(mingw32_HOST_OS) - let pkgs_no_rts = filter ((/= rtsPackageId) . packageConfigId) pkgs -#else - let pkgs_no_rts = pkgs -#endif + let pkgs_no_rts = case platformOS (targetPlatform dflags) of + OSMinGW32 -> + pkgs + _ -> + filter ((/= rtsPackageId) . packageConfigId) pkgs let pkg_link_opts = collectLinkOpts dflags pkgs_no_rts -- probably _stub.o files extra_ld_inputs <- readIORef v_Ld_inputs - let (md_c_flags, _) = machdepCCOpts dflags let extra_ld_opts = getOpts dflags opt_l - rtsEnabledObj <- mkRtsOptionsLevelObj dflags + extraLinkObj <- mkExtraObjToLinkIntoBinary dflags dep_packages #if defined(mingw32_HOST_OS) ----------------------------------------------------------------------------- @@ -1706,28 +1818,27 @@ ----------------------------------------------------------------------------- let output_fn = case o_file of { Just s -> s; Nothing -> "HSdll.dll"; } - SysTools.runLink dflags - ([ SysTools.Option verb - , SysTools.Option "-o" - , SysTools.FileOption "" output_fn - , SysTools.Option "-shared" - ] ++ - [ SysTools.FileOption "-Wl,--out-implib=" (output_fn ++ ".a") - | dopt Opt_SharedImplib dflags - ] + SysTools.runLink dflags ( + map SysTools.Option verbFlags + ++ [ SysTools.Option "-o" + , SysTools.FileOption "" output_fn + , SysTools.Option "-shared" + ] ++ + [ SysTools.FileOption "-Wl,--out-implib=" (output_fn ++ ".a") + | dopt Opt_SharedImplib dflags + ] ++ map (SysTools.FileOption "") o_files ++ map SysTools.Option ( - md_c_flags -- Permit the linker to auto link _symbol to _imp_symbol -- This lets us link against DLLs without needing an "import library" - ++ ["-Wl,--enable-auto-import"] + ["-Wl,--enable-auto-import"] ++ extra_ld_inputs ++ lib_path_opts ++ extra_ld_opts ++ pkg_lib_path_opts - ++ rtsEnabledObj + ++ [extraLinkObj] ++ pkg_link_opts )) #elif defined(darwin_TARGET_OS) @@ -1766,15 +1877,14 @@ Nothing -> do pwd <- getCurrentDirectory return $ pwd `combine` output_fn - SysTools.runLink dflags - ([ SysTools.Option verb - , SysTools.Option "-dynamiclib" - , SysTools.Option "-o" - , SysTools.FileOption "" output_fn - ] + SysTools.runLink dflags ( + map SysTools.Option verbFlags + ++ [ SysTools.Option "-dynamiclib" + , SysTools.Option "-o" + , SysTools.FileOption "" output_fn + ] ++ map SysTools.Option ( - md_c_flags - ++ o_files + o_files ++ [ "-undefined", "dynamic_lookup", "-single_module", #if !defined(x86_64_TARGET_ARCH) "-Wl,-read_only_relocs,suppress", @@ -1784,7 +1894,7 @@ ++ lib_path_opts ++ extra_ld_opts ++ pkg_lib_path_opts - ++ rtsEnabledObj + ++ [extraLinkObj] ++ pkg_link_opts )) #else @@ -1802,14 +1912,13 @@ -- non-PIC intra-package-relocations ["-Wl,-Bsymbolic"] - SysTools.runLink dflags - ([ SysTools.Option verb - , SysTools.Option "-o" - , SysTools.FileOption "" output_fn - ] + SysTools.runLink dflags ( + map SysTools.Option verbFlags + ++ [ SysTools.Option "-o" + , SysTools.FileOption "" output_fn + ] ++ map SysTools.Option ( - md_c_flags - ++ o_files + o_files ++ [ "-shared" ] ++ bsymbolicFlag -- Set the library soname. We use -h rather than -soname as @@ -1819,7 +1928,7 @@ ++ lib_path_opts ++ extra_ld_opts ++ pkg_lib_path_opts - ++ rtsEnabledObj + ++ [extraLinkObj] ++ pkg_link_opts )) #endif @@ -1835,14 +1944,11 @@ let include_paths = foldr (\ x xs -> "-I" : x : xs) [] (cmdline_include_paths ++ pkg_include_dirs) - let verb = getVerbFlag dflags + let verbFlags = getVerbFlags dflags let cc_opts - | not include_cc_opts = [] - | otherwise = (optc ++ md_c_flags) - where - optc = getOpts dflags opt_c - (md_c_flags, _) = machdepCCOpts dflags + | include_cc_opts = getOpts dflags opt_c + | otherwise = [] let cpp_prog args | raw = SysTools.runCpp dflags args | otherwise = SysTools.runCc dflags (SysTools.Option "-E" : args) @@ -1855,7 +1961,7 @@ -- remember, in code we *compile*, the HOST is the same our TARGET, -- and BUILD is the same as our HOST. - cpp_prog ([SysTools.Option verb] + cpp_prog ( map SysTools.Option verbFlags ++ map SysTools.Option include_paths ++ map SysTools.Option hsSourceCppOpts ++ map SysTools.Option target_defs @@ -1881,6 +1987,45 @@ hsSourceCppOpts = [ "-D__GLASGOW_HASKELL__="++cProjectVersionInt ] +-- --------------------------------------------------------------------------- +-- join object files into a single relocatable object file, using ld -r + +joinObjectFiles :: DynFlags -> [FilePath] -> FilePath -> IO () +joinObjectFiles dflags o_files output_fn = do + let ld_r args = SysTools.runLink dflags ([ + SysTools.Option "-nostdlib", + SysTools.Option "-nodefaultlibs", + SysTools.Option "-Wl,-r" + ] + -- gcc on sparc sets -Wl,--relax implicitly, but + -- -r and --relax are incompatible for ld, so + -- disable --relax explicitly. + ++ (if platformArch (targetPlatform dflags) == ArchSPARC + then [SysTools.Option "-Wl,-no-relax"] + else []) + ++ [ + SysTools.Option ld_build_id, + SysTools.Option ld_x_flag, + SysTools.Option "-o", + SysTools.FileOption "" output_fn ] + ++ args) + + ld_x_flag | null cLD_X = "" + | otherwise = "-Wl,-x" + + -- suppress the generation of the .note.gnu.build-id section, + -- which we don't need and sometimes causes ld to emit a + -- warning: + ld_build_id | cLdHasBuildId == "YES" = "-Wl,--build-id=none" + | otherwise = "" + + if cLdIsGNULd == "YES" + then do + script <- newTempName dflags "ldscript" + writeFile script $ "INPUT(" ++ unwords o_files ++ ")" + ld_r [SysTools.FileOption "" script] + else do + ld_r (map (SysTools.FileOption "") o_files) -- ----------------------------------------------------------------------------- -- Misc. @@ -1895,21 +2040,4 @@ HscLlvm -> LlvmOpt HscNothing -> StopLn HscInterpreted -> StopLn - _other -> StopLn - - -hscMaybeAdjustTarget :: DynFlags -> Phase -> HscSource -> HscTarget -> HscTarget -hscMaybeAdjustTarget dflags stop _ current_hsc_lang - = hsc_lang - where - keep_hc = dopt Opt_KeepHcFiles dflags - hsc_lang - -- don't change the lang if we're interpreting - | current_hsc_lang == HscInterpreted = current_hsc_lang - - -- force -fvia-C if we are being asked for a .hc file - | HCc <- stop = HscC - | keep_hc = HscC - -- otherwise, stick to the plan - | otherwise = current_hsc_lang diff -Nru ghc-7.0.3/compiler/main/DynamicLoading.hs ghc-7.2.1/compiler/main/DynamicLoading.hs --- ghc-7.0.3/compiler/main/DynamicLoading.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/compiler/main/DynamicLoading.hs 2011-08-07 17:10:05.000000000 +0000 @@ -0,0 +1,150 @@ +-- | Dynamically lookup up values from modules and loading them. +module DynamicLoading ( +#ifdef GHCI + -- * Force loading information + forceLoadModuleInterfaces, + forceLoadNameModuleInterface, + forceLoadTyCon, + + -- * Finding names + lookupRdrNameInModule, + + -- * Loading values + getValueSafely, + lessUnsafeCoerce +#endif + ) where + +#ifdef GHCI +import Linker ( linkModule, getHValue, lessUnsafeCoerce ) +import OccName ( occNameSpace ) +import Name ( nameOccName ) +import SrcLoc ( noSrcSpan ) +import Finder ( findImportedModule, cannotFindModule ) +import DriverPhases ( HscSource(HsSrcFile) ) +import TcRnDriver ( getModuleExports ) +import TcRnMonad ( initTc, initIfaceTcRn ) +import LoadIface ( loadUserInterface ) +import RdrName ( RdrName, Provenance(..), ImportSpec(..), ImpDeclSpec(..), ImpItemSpec(..), + mkGlobalRdrEnv, lookupGRE_RdrName, gre_name, rdrNameSpace ) +import RnNames ( gresFromAvails ) +import PrelNames ( iNTERACTIVE ) + +import HscTypes ( HscEnv(..), FindResult(..), lookupTypeHscEnv ) +import TypeRep ( TyThing(..), pprTyThingCategory ) +import Type ( Type, eqType ) +import TyCon ( TyCon ) +import Name ( Name, nameModule_maybe ) +import Id ( idType ) +import Module ( Module, ModuleName ) +import Panic ( GhcException(..), throwGhcException ) +import FastString +import Outputable + +import Data.Maybe ( mapMaybe ) + + +-- | Force the interfaces for the given modules to be loaded. The 'SDoc' parameter is used +-- for debugging (@-ddump-if-trace@) only: it is shown as the reason why the module is being loaded. +forceLoadModuleInterfaces :: HscEnv -> SDoc -> [Module] -> IO () +forceLoadModuleInterfaces hsc_env doc modules + = (initTc hsc_env HsSrcFile False iNTERACTIVE $ initIfaceTcRn $ mapM_ (loadUserInterface False doc) modules) >> return () + +-- | Force the interface for the module containing the name to be loaded. The 'SDoc' parameter is used +-- for debugging (@-ddump-if-trace@) only: it is shown as the reason why the module is being loaded. +forceLoadNameModuleInterface :: HscEnv -> SDoc -> Name -> IO () +forceLoadNameModuleInterface hsc_env reason name = do + let name_modules = mapMaybe nameModule_maybe [name] + forceLoadModuleInterfaces hsc_env reason name_modules + +-- | Load the 'TyCon' associated with the given name, come hell or high water. Fails if: +-- +-- * The interface could not be loaded +-- * The name is not that of a 'TyCon' +-- * The name did not exist in the loaded module +forceLoadTyCon :: HscEnv -> Name -> IO TyCon +forceLoadTyCon hsc_env con_name = do + forceLoadNameModuleInterface hsc_env (ptext (sLit "contains a name used in an invocation of loadTyConTy")) con_name + + mb_con_thing <- lookupTypeHscEnv hsc_env con_name + case mb_con_thing of + Nothing -> throwCmdLineErrorS $ missingTyThingError con_name + Just (ATyCon tycon) -> return tycon + Just con_thing -> throwCmdLineErrorS $ wrongTyThingError con_name con_thing + +-- | Loads the value corresponding to a 'Name' if that value has the given 'Type'. This only provides limited safety +-- in that it is up to the user to ensure that that type corresponds to the type you try to use the return value at! +-- +-- If the value found was not of the correct type, returns @Nothing@. Any other condition results in an exception: +-- +-- * If we could not load the names module +-- * If the thing being loaded is not a value +-- * If the Name does not exist in the module +-- * If the link failed + +getValueSafely :: HscEnv -> Name -> Type -> IO (Maybe a) +getValueSafely hsc_env val_name expected_type = do + forceLoadNameModuleInterface hsc_env (ptext (sLit "contains a name used in an invocation of getValueSafely")) val_name + + -- Now look up the names for the value and type constructor in the type environment + mb_val_thing <- lookupTypeHscEnv hsc_env val_name + case mb_val_thing of + Nothing -> throwCmdLineErrorS $ missingTyThingError val_name + Just (AnId id) -> do + -- Check the value type in the interface against the type recovered from the type constructor + -- before finally casting the value to the type we assume corresponds to that constructor + if expected_type `eqType` idType id + then do + -- Link in the module that contains the value, if it has such a module + case nameModule_maybe val_name of + Just mod -> do linkModule hsc_env mod + return () + Nothing -> return () + -- Find the value that we just linked in and cast it given that we have proved it's type + hval <- getHValue hsc_env val_name + value <- lessUnsafeCoerce (hsc_dflags hsc_env) "getValueSafely" hval + return $ Just value + else return Nothing + Just val_thing -> throwCmdLineErrorS $ wrongTyThingError val_name val_thing + +-- | Finds the 'Name' corresponding to the given 'RdrName' in the context of the 'ModuleName'. Returns @Nothing@ if no +-- such 'Name' could be found. Any other condition results in an exception: +-- +-- * If the module could not be found +-- * If we could not determine the imports of the module +lookupRdrNameInModule :: HscEnv -> ModuleName -> RdrName -> IO (Maybe Name) +lookupRdrNameInModule hsc_env mod_name rdr_name = do + -- First find the package the module resides in by searching exposed packages and home modules + found_module <- findImportedModule hsc_env mod_name Nothing + case found_module of + Found _ mod -> do + -- Find the exports of the module + (_, mb_avail_info) <- getModuleExports hsc_env mod + case mb_avail_info of + Just avail_info -> do + -- Try and find the required name in the exports + let decl_spec = ImpDeclSpec { is_mod = mod_name, is_as = mod_name, is_qual = False, is_dloc = noSrcSpan } + provenance = Imported [ImpSpec decl_spec ImpAll] + env = mkGlobalRdrEnv (gresFromAvails provenance avail_info) + case [name | gre <- lookupGRE_RdrName rdr_name env, let name = gre_name gre, rdrNameSpace rdr_name == occNameSpace (nameOccName name)] of + [name] -> return (Just name) + [] -> return Nothing + _ -> panic "lookupRdrNameInModule" + Nothing -> throwCmdLineErrorS $ hsep [ptext (sLit "Could not determine the exports of the module"), ppr mod_name] + err -> throwCmdLineErrorS $ cannotFindModule dflags mod_name err + where + dflags = hsc_dflags hsc_env + + +wrongTyThingError :: Name -> TyThing -> SDoc +wrongTyThingError name got_thing = hsep [ptext (sLit "The name"), ppr name, ptext (sLit "is not that of a value but rather a"), pprTyThingCategory got_thing] + +missingTyThingError :: Name -> SDoc +missingTyThingError name = hsep [ptext (sLit "The name"), ppr name, ptext (sLit "is not in the type environment: are you sure it exists?")] + +throwCmdLineErrorS :: SDoc -> IO a +throwCmdLineErrorS = throwCmdLineError . showSDoc + +throwCmdLineError :: String -> IO a +throwCmdLineError = throwGhcException . CmdLineError +#endif diff -Nru ghc-7.0.3/compiler/main/DynFlags.hs ghc-7.2.1/compiler/main/DynFlags.hs --- ghc-7.0.3/compiler/main/DynFlags.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/main/DynFlags.hs 2011-08-07 17:10:05.000000000 +0000 @@ -1,6 +1,3 @@ -{-# OPTIONS_GHC -w #-} --- Temporary, until rtsIsProfiled is fixed - -- | -- Dynamic flags -- @@ -15,11 +12,16 @@ module DynFlags ( -- * Dynamic flags and associated configuration types DynFlag(..), + WarningFlag(..), ExtensionFlag(..), + LogAction, glasgowExtsFlags, dopt, dopt_set, dopt_unset, + wopt, + wopt_set, + wopt_unset, xopt, xopt_set, xopt_unset, @@ -31,37 +33,52 @@ PackageFlag(..), Option(..), showOpt, DynLibLoader(..), - fFlags, fLangFlags, xFlags, - dphPackage, - wayNames, + fFlags, fWarningFlags, fLangFlags, xFlags, + DPHBackend(..), dphPackageMaybe, + wayNames, dynFlagDependencies, + + -- ** Safe Haskell + SafeHaskellMode(..), + safeHaskellOn, safeLanguageOn, + safeDirectImpsReq, safeImplicitImpsReq, + + -- ** System tool settings and locations + 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_a, opt_l, + opt_windres, opt_lo, opt_lc, + -- ** Manipulating DynFlags - defaultDynFlags, -- DynFlags + defaultDynFlags, -- Settings -> DynFlags initDynFlags, -- DynFlags -> IO DynFlags + defaultLogAction, getOpts, -- DynFlags -> (DynFlags -> [a]) -> [a] - getVerbFlag, + getVerbFlags, updOptLevel, setTmpDir, setPackageName, doingTickyProfiling, -- ** Parsing DynFlags - parseDynamicFlags, - parseDynamicNoPackageFlags, + parseDynamicFlagsCmdLine, + parseDynamicFilePragma, allFlags, supportedLanguagesAndExtensions, -- ** DynFlag C compiler options - machdepCCOpts, picCCOpts, + picCCOpts, -- * Configuration of the stg-to-stg passes StgToDo(..), getStgToDo, -- * Compiler configuration suitable for display to the user - Printable(..), compilerInfo #ifdef GHCI -- Only in stage 2 can we be sure that the RTS @@ -72,9 +89,7 @@ #include "HsVersions.h" -#ifndef OMIT_NATIVE_CODEGEN import Platform -#endif import Module import PackageConfig import PrelNames ( mAIN ) @@ -90,10 +105,14 @@ 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,6 +120,8 @@ import Data.List import Data.Map (Map) import qualified Data.Map as Map +import Data.Set (Set) +import qualified Data.Set as Set import System.FilePath import System.IO ( stderr, hPutChar ) @@ -112,8 +133,24 @@ -- debugging flags = Opt_D_dump_cmm + | Opt_D_dump_raw_cmm | Opt_D_dump_cmmz | Opt_D_dump_cmmz_pretty + -- All of the cmmz subflags (there are a lot!) Automatically + -- enabled if you run -ddump-cmmz + | Opt_D_dump_cmmz_cbe + | Opt_D_dump_cmmz_proc + | Opt_D_dump_cmmz_spills + | Opt_D_dump_cmmz_rewrite + | Opt_D_dump_cmmz_dead + | Opt_D_dump_cmmz_stub + | Opt_D_dump_cmmz_sp + | Opt_D_dump_cmmz_procmap + | Opt_D_dump_cmmz_split + | Opt_D_dump_cmmz_lower + | Opt_D_dump_cmmz_info + | Opt_D_dump_cmmz_cafs + -- end cmmz subflags | Opt_D_dump_cps_cmm | Opt_D_dump_cvt_cmm | Opt_D_dump_asm @@ -126,6 +163,7 @@ | Opt_D_dump_asm_stats | Opt_D_dump_asm_expanded | Opt_D_dump_llvm + | Opt_D_dump_core_stats | Opt_D_dump_cpranal | Opt_D_dump_deriv | Opt_D_dump_ds @@ -133,9 +171,11 @@ | Opt_D_dump_foreign | Opt_D_dump_inlinings | Opt_D_dump_rule_firings + | Opt_D_dump_rule_rewrites | Opt_D_dump_occur_anal | Opt_D_dump_parsed | Opt_D_dump_rn + | Opt_D_dump_core_pipeline -- TODO FIXME: dump after simplifier stats | Opt_D_dump_simpl | Opt_D_dump_simpl_iterations | Opt_D_dump_simpl_phases @@ -155,6 +195,7 @@ | Opt_D_dump_cs_trace -- Constraint solver in type checker | Opt_D_dump_tc_trace | Opt_D_dump_if_trace + | Opt_D_dump_vt_trace | Opt_D_dump_splices | Opt_D_dump_BCOs | Opt_D_dump_vect @@ -177,36 +218,6 @@ | Opt_DoAsmLinting | Opt_WarnIsError -- -Werror; makes warnings fatal - | Opt_WarnDuplicateExports - | Opt_WarnHiShadows - | Opt_WarnImplicitPrelude - | Opt_WarnIncompletePatterns - | Opt_WarnIncompletePatternsRecUpd - | Opt_WarnMissingFields - | Opt_WarnMissingImportList - | Opt_WarnMissingMethods - | Opt_WarnMissingSigs - | Opt_WarnMissingLocalSigs - | Opt_WarnNameShadowing - | Opt_WarnOverlappingPatterns - | Opt_WarnTypeDefaults - | Opt_WarnMonomorphism - | Opt_WarnUnusedBinds - | Opt_WarnUnusedImports - | Opt_WarnUnusedMatches - | Opt_WarnWarningsDeprecations - | Opt_WarnDeprecatedFlags - | Opt_WarnDodgyExports - | Opt_WarnDodgyImports - | Opt_WarnOrphans - | Opt_WarnAutoOrphans - | Opt_WarnTabs - | Opt_WarnUnrecognisedPragmas - | Opt_WarnDodgyForeignImports - | Opt_WarnLazyUnliftedBindings - | Opt_WarnUnusedDoBind - | Opt_WarnWrongDoBind - | Opt_WarnAlternativeLayoutRuleTransitional | Opt_PrintExplicitForalls @@ -224,7 +235,6 @@ | Opt_DoEtaReduction | Opt_CaseMerge | Opt_UnboxStrictFields - | Opt_MethodSharing | Opt_DictsCheap | Opt_EnableRewriteRules -- Apply rewrite rules during simplification | Opt_Vectorise @@ -244,8 +254,6 @@ -- misc opts | Opt_Pp | Opt_ForceRecomp - | Opt_DryRun - | Opt_DoAsmMangling | Opt_ExcessPrecision | Opt_EagerBlackHoling | Opt_ReadUserPackageConf @@ -253,6 +261,7 @@ | Opt_SplitObjs | Opt_StgStats | Opt_HideAllPackages + | Opt_DistrustAllPackages | Opt_PrintBindResult | Opt_Haddock | Opt_HaddockOptions @@ -268,6 +277,7 @@ | Opt_BuildingCabalPackage | Opt_SSE2 | Opt_GhciSandbox + | Opt_HelpfulErrors -- temporary flags | Opt_RunCPS @@ -281,15 +291,63 @@ | Opt_KeepHiDiffs | Opt_KeepHcFiles | Opt_KeepSFiles - | Opt_KeepRawSFiles | Opt_KeepTmpFiles | Opt_KeepRawTokenStream | Opt_KeepLlvmFiles deriving (Eq, Show) +data WarningFlag = + Opt_WarnDuplicateExports + | Opt_WarnHiShadows + | Opt_WarnImplicitPrelude + | Opt_WarnIncompletePatterns + | Opt_WarnIncompleteUniPatterns + | Opt_WarnIncompletePatternsRecUpd + | Opt_WarnMissingFields + | Opt_WarnMissingImportList + | Opt_WarnMissingMethods + | Opt_WarnMissingSigs + | Opt_WarnMissingLocalSigs + | Opt_WarnNameShadowing + | Opt_WarnOverlappingPatterns + | Opt_WarnTypeDefaults + | Opt_WarnMonomorphism + | Opt_WarnUnusedBinds + | Opt_WarnUnusedImports + | Opt_WarnUnusedMatches + | Opt_WarnWarningsDeprecations + | Opt_WarnDeprecatedFlags + | Opt_WarnDodgyExports + | Opt_WarnDodgyImports + | Opt_WarnOrphans + | Opt_WarnAutoOrphans + | Opt_WarnIdentities + | Opt_WarnTabs + | Opt_WarnUnrecognisedPragmas + | Opt_WarnDodgyForeignImports + | Opt_WarnLazyUnliftedBindings + | Opt_WarnUnusedDoBind + | Opt_WarnWrongDoBind + | Opt_WarnAlternativeLayoutRuleTransitional + deriving (Eq, Show) + data Language = Haskell98 | Haskell2010 +-- | The various Safe Haskell modes +data SafeHaskellMode + = Sf_None + | Sf_SafeImports + | Sf_Trustworthy + | Sf_Safe + deriving (Eq) + +instance Outputable SafeHaskellMode where + ppr Sf_None = ptext $ sLit "None" + ppr Sf_SafeImports = ptext $ sLit "SafeImports" + ppr Sf_Trustworthy = ptext $ sLit "Trustworthy" + ppr Sf_Safe = ptext $ sLit "Safe" + data ExtensionFlag = Opt_Cpp | Opt_OverlappingInstances @@ -302,13 +360,13 @@ | Opt_ExtendedDefaultRules -- Use GHC's extended rules for defaulting | Opt_ForeignFunctionInterface | Opt_UnliftedFFITypes + | Opt_InterruptibleFFI | Opt_GHCForeignImportPrim - | Opt_PArr -- Syntactic support for parallel arrays + | Opt_ParallelArrays -- Syntactic support for parallel arrays | Opt_Arrows -- Arrow-notation syntax | Opt_TemplateHaskell | Opt_QuasiQuotes | Opt_ImplicitParams - | Opt_Generics -- "Derivable type classes" | Opt_ImplicitPrelude | Opt_ScopedTypeVariables | Opt_UnboxedTuples @@ -320,6 +378,7 @@ | Opt_RecordPuns | Opt_ViewPatterns | Opt_GADTs + | Opt_GADTSyntax | Opt_NPlusKPatterns | Opt_DoAndIfThenElse | Opt_RebindableSyntax @@ -329,6 +388,8 @@ | Opt_DeriveFunctor | Opt_DeriveTraversable | Opt_DeriveFoldable + | Opt_DeriveGeneric -- Allow deriving Generic/1 + | Opt_DefaultSignatures -- Allow extra signatures for defmeths | Opt_TypeSynonymInstances | Opt_FlexibleContexts @@ -344,6 +405,7 @@ | Opt_KindSignatures | Opt_ParallelListComp | Opt_TransformListComp + | Opt_MonadComprehensions | Opt_GeneralizedNewtypeDeriving | Opt_RecursiveDo | Opt_DoRec @@ -356,11 +418,12 @@ | Opt_ImpredicativeTypes | Opt_TypeOperators | Opt_PackageImports - | Opt_NewQualifiedOperators | Opt_ExplicitForAll | Opt_AlternativeLayoutRule | Opt_AlternativeLayoutRuleTransitional | Opt_DatatypeContexts + | Opt_NondecreasingIndentation + | Opt_RelaxedLayout deriving (Eq, Show) -- | Contains not only a collection of 'DynFlag's but also a plethora of @@ -385,10 +448,7 @@ floatLamArgs :: Maybe Int, -- ^ Arg count for lambda floating -- See CoreMonad.FloatOutSwitches -#ifndef OMIT_NATIVE_CODEGEN - targetPlatform :: Platform, -- ^ The platform we're compiling for. Used by the NCG. -#endif - stolen_x86_regs :: Int, + targetPlatform :: Platform.Platform, -- ^ The platform we're compiling for. Used by the NCG. cmdlineHcIncludes :: [String], -- ^ @\-\#includes@ importPaths :: [FilePath], mainModIs :: Module, @@ -433,42 +493,17 @@ 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 + -- Plugins + pluginModNames :: [ModuleName], + pluginModNameOpts :: [(ModuleName,String)], - -- commands for particular phases - pgm_L :: String, - pgm_P :: (String,[Option]), - pgm_F :: String, - pgm_c :: (String,[Option]), - pgm_m :: (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, @@ -478,8 +513,6 @@ -- 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. @@ -498,10 +531,18 @@ filesToClean :: IORef [FilePath], dirsToClean :: IORef (Map FilePath FilePath), + -- Names of files which were generated from -ddump-to-file; used to + -- track which ones we need to truncate because it's our first run + -- through + generatedDumps :: IORef (Set FilePath), + -- hsc dynamic flags flags :: [DynFlag], + warningFlags :: [WarningFlag], -- Don't change this without updating extensionFlags: language :: Maybe Language, + -- | Safe Haskell mode + safeHaskell :: SafeHaskellMode, -- Don't change this without updating extensionFlags: extensions :: [OnOff ExtensionFlag], -- extensionFlags should always be equal to @@ -509,11 +550,107 @@ extensionFlags :: [ExtensionFlag], -- | Message output action: use "ErrUtils" instead of this if you can - log_action :: Severity -> SrcSpan -> PprStyle -> Message -> IO (), + log_action :: LogAction, 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_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_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 @@ -541,11 +678,17 @@ = HscC -- ^ Generate C code. | HscAsm -- ^ Generate assembly using the native code generator. | HscLlvm -- ^ Generate assembly using the llvm code generator. - | HscJava -- ^ Generate Java bytecode. | HscInterpreted -- ^ Generate bytecode. (Requires 'LinkInMemory') | HscNothing -- ^ Don't generate any code. See notes above. deriving (Eq, Show) +showHscTargetFlag :: HscTarget -> String +showHscTargetFlag HscC = "-fvia-c" +showHscTargetFlag HscAsm = "-fasm" +showHscTargetFlag HscLlvm = "-fllvm" +showHscTargetFlag HscInterpreted = "-fbyte-code" +showHscTargetFlag HscNothing = "-fno-code" + -- | Will this target result in an object file on the disk? isObjectTarget :: HscTarget -> Bool isObjectTarget HscC = True @@ -595,10 +738,12 @@ -- static. If the way flags were made dynamic, we could fix this. data PackageFlag - = ExposePackage String + = ExposePackage String | ExposePackageId String - | HidePackage String - | IgnorePackage String + | HidePackage String + | IgnorePackage String + | TrustPackage String + | DistrustPackage String deriving Eq defaultHscTarget :: HscTarget @@ -608,8 +753,9 @@ -- object files on the current platform. defaultObjectTarget :: HscTarget defaultObjectTarget + | cGhcUnregisterised == "YES" = HscC | cGhcWithNativeCodeGen == "YES" = HscAsm - | otherwise = HscC + | otherwise = HscLlvm data DynLibLoader = Deployable @@ -617,6 +763,7 @@ deriving Eq data RtsOptsEnabled = RtsOptsNone | RtsOptsSafeOnly | RtsOptsAll + deriving (Show) -- | Used by 'GHC.newSession' to partially initialize a new 'DynFlags' value initDynFlags :: DynFlags -> IO DynFlags @@ -625,18 +772,20 @@ ways <- readIORef v_Ways refFilesToClean <- newIORef [] refDirsToClean <- newIORef Map.empty + refGeneratedDumps <- newIORef Set.empty return dflags{ ways = ways, buildTag = mkBuildTag (filter (not . wayRTSOnly) ways), rtsBuildTag = mkBuildTag ways, filesToClean = refFilesToClean, - dirsToClean = refDirsToClean + dirsToClean = refDirsToClean, + generatedDumps = refGeneratedDumps } -- | 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, @@ -649,23 +798,20 @@ maxSimplIterations = 4, shouldDumpSimplPhase = Nothing, ruleCheck = Nothing, - specConstrThreshold = Just 200, + specConstrThreshold = Just 2000, specConstrCount = Just 3, - liberateCaseThreshold = Just 200, + liberateCaseThreshold = Just 2000, floatLamArgs = Just 0, -- Default: float only if no fvs strictnessBefore = [], -#ifndef OMIT_NATIVE_CODEGEN targetPlatform = defaultTargetPlatform, -#endif - stolen_x86_regs = 4, cmdlineHcIncludes = [], importPaths = ["."], mainModIs = mAIN, mainFunIs = Nothing, ctxtStkDepth = mAX_CONTEXT_REDUCTION_DEPTH, - dphBackend = DPHPar, + dphBackend = DPHNone, thisPackage = mainPackageId, @@ -678,6 +824,9 @@ hcSuf = phaseInputExt HCc, hiSuf = "hi", + pluginModNames = [], + pluginModNameOpts = [], + outputFile = Nothing, outputHi = Nothing, dynLibLoader = SystemDependent, @@ -687,25 +836,11 @@ 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, @@ -714,26 +849,7 @@ 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_m = panic "defaultDynFlags: No pgm_m", - 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, @@ -742,25 +858,31 @@ -- end of ghc -M values filesToClean = panic "defaultDynFlags: No filesToClean", dirsToClean = panic "defaultDynFlags: No dirsToClean", + generatedDumps = panic "defaultDynFlags: No generatedDumps", haddockOptions = Nothing, flags = defaultFlags, + warningFlags = standardWarnings, language = Nothing, + safeHaskell = Sf_None, extensions = [], extensionFlags = flattenExtensionFlags Nothing [], - - log_action = \severity srcSpan style msg -> - case severity of - SevOutput -> printOutput (msg style) - SevInfo -> printErrs (msg style) - SevFatal -> printErrs (msg style) - _ -> do - hPutChar stderr '\n' - printErrs ((mkLocMessage srcSpan msg) style) - -- careful (#2302): printErrs prints in UTF-8, whereas - -- converting to string first and using hPutStr would - -- just emit the low 8 bits of each unicode char. + log_action = defaultLogAction } +type LogAction = Severity -> SrcSpan -> PprStyle -> Message -> IO () + +defaultLogAction :: LogAction +defaultLogAction severity srcSpan style msg + = case severity of + SevOutput -> printSDoc msg style + SevInfo -> printErrs msg style + SevFatal -> printErrs msg style + _ -> do hPutChar stderr '\n' + printErrs (mkLocMessage srcSpan msg) style + -- careful (#2302): printErrs prints in UTF-8, whereas + -- converting to string first and using hPutStr would + -- just emit the low 8 bits of each unicode char. + {- Note [Verbosity levels] ~~~~~~~~~~~~~~~~~~~~~~~ @@ -785,18 +907,35 @@ defaultExtensionFlags = languageExtensions ml languageExtensions :: Maybe Language -> [ExtensionFlag] + languageExtensions Nothing + -- Nothing => the default case = Opt_MonoPatBinds -- Experimentally, I'm making this non-standard -- behaviour the default, to see if anyone notices -- SLPJ July 06 -- In due course I'd like Opt_MonoLocalBinds to be on by default + -- But NB it's implied by GADTs etc -- SLPJ September 2010 - : languageExtensions (Just Haskell2010) + : Opt_NondecreasingIndentation -- This has been on by default for some time + : delete Opt_DatatypeContexts -- The Haskell' committee decided to + -- remove datatype contexts from the + -- language: + -- http://www.haskell.org/pipermail/haskell-prime/2011-January/003335.html + (languageExtensions (Just Haskell2010)) + languageExtensions (Just Haskell98) = [Opt_ImplicitPrelude, Opt_MonomorphismRestriction, Opt_NPlusKPatterns, - Opt_DatatypeContexts] + Opt_DatatypeContexts, + Opt_NondecreasingIndentation + -- strictly speaking non-standard, but we always had this + -- on implicitly before the option was added in 7.1, and + -- turning it off breaks code, so we're keeping it on for + -- backwards compatibility. Cabal uses -XHaskell98 by + -- default unless you specify another language. + ] + languageExtensions (Just Haskell2010) = [Opt_ImplicitPrelude, Opt_MonomorphismRestriction, @@ -819,6 +958,18 @@ dopt_unset :: DynFlags -> DynFlag -> DynFlags dopt_unset dfs f = dfs{ flags = filter (/= f) (flags dfs) } +-- | Test whether a 'WarningFlag' is set +wopt :: WarningFlag -> DynFlags -> Bool +wopt f dflags = f `elem` (warningFlags dflags) + +-- | Set a 'WarningFlag' +wopt_set :: DynFlags -> WarningFlag -> DynFlags +wopt_set dfs f = dfs{ warningFlags = f : warningFlags dfs } + +-- | Unset a 'WarningFlag' +wopt_unset :: DynFlags -> WarningFlag -> DynFlags +wopt_unset dfs f = dfs{ warningFlags = filter (/= f) (warningFlags dfs) } + -- | Test whether a 'ExtensionFlag' is set xopt :: ExtensionFlag -> DynFlags -> Bool xopt f dflags = f `elem` extensionFlags dflags @@ -837,6 +988,7 @@ in dfs { extensions = onoffs, extensionFlags = flattenExtensionFlags (language dfs) onoffs } +-- | Set the Haskell language standard to use setLanguage :: Language -> DynP () setLanguage l = upd f where f dfs = let mLang = Just l @@ -846,6 +998,60 @@ extensionFlags = flattenExtensionFlags mLang oneoffs } +-- | Some modules have dependencies on others through the DynFlags rather than textual imports +dynFlagDependencies :: DynFlags -> [ModuleName] +dynFlagDependencies = pluginModNames + +-- | Is the Safe Haskell safe language in use +safeLanguageOn :: DynFlags -> Bool +safeLanguageOn dflags = safeHaskell dflags == Sf_Safe + +-- | Test if Safe Haskell is on in some form +safeHaskellOn :: DynFlags -> Bool +safeHaskellOn dflags = safeHaskell dflags /= Sf_None + +-- | Set a 'Safe Haskell' flag +setSafeHaskell :: SafeHaskellMode -> DynP () +setSafeHaskell s = updM f + where f dfs = do + let sf = safeHaskell dfs + safeM <- combineSafeFlags sf s + return $ dfs { safeHaskell = safeM } + +-- | Are all direct imports required to be safe for this Safe Haskell mode? +-- Direct imports are when the code explicitly imports a module +safeDirectImpsReq :: DynFlags -> Bool +safeDirectImpsReq = safeLanguageOn + +-- | Are all implicit imports required to be safe for this Safe Haskell mode? +-- Implicit imports are things in the prelude. e.g System.IO when print is used. +safeImplicitImpsReq :: DynFlags -> Bool +safeImplicitImpsReq = safeLanguageOn + +-- | Combine two Safe Haskell modes correctly. Used for dealing with multiple flags. +-- This makes Safe Haskell very much a monoid but for now I prefer this as I don't +-- want to export this functionality from the module but do want to export the +-- type constructors. +combineSafeFlags :: SafeHaskellMode -> SafeHaskellMode -> DynP SafeHaskellMode +combineSafeFlags a b = + case (a,b) of + (Sf_None, sf) -> return sf + (sf, Sf_None) -> return sf + + (Sf_SafeImports, sf) -> return sf + (sf, Sf_SafeImports) -> return sf + + (Sf_Trustworthy, Sf_Safe) -> err + (Sf_Safe, Sf_Trustworthy) -> err + + (a,b) | a == b -> return a + | otherwise -> err + + where err = do + let s = "Incompatible Safe Haskell flags! (" ++ showPpr a ++ ", " ++ showPpr b ++ ")" + addErr s + return $ panic s -- Just for saftey instead of returning say, a + -- | Retrieve the options corresponding to a particular @opt_*@ field in the correct order getOpts :: DynFlags -- ^ 'DynFlags' to retrieve the options from -> (DynFlags -> [a]) -- ^ Relevant record accessor: one of the @opt_*@ accessors @@ -855,10 +1061,10 @@ -- | Gets the verbosity flag for the current verbosity level. This is fed to -- other tools, so GHC-specific verbosity flags like @-ddump-most@ are not included -getVerbFlag :: DynFlags -> String -getVerbFlag dflags - | verbosity dflags >= 3 = "-v" - | otherwise = "" +getVerbFlags :: DynFlags -> [String] +getVerbFlags dflags + | verbosity dflags >= 4 = ["-v"] + | otherwise = [] setObjectDir, setHiDir, setStubDir, setOutputDir, setDylibInstallName, setObjectSuf, setHiSuf, setHcSuf, parseDynLibLoaderMode, @@ -872,7 +1078,8 @@ setHiDir f d = d{ hiDir = Just f} setStubDir f d = d{ stubDir = Just f, includePaths = f : includePaths d } -- -stubdir D adds an implicit -I D, so that gcc can find the _stub.h file - -- \#included from the .hc file when compiling with -fvia-C. + -- \#included from the .hc file when compiling via C (i.e. unregisterised + -- builds). setOutputDir f = setObjectDir f . setHiDir f . setStubDir f setDylibInstallName f d = d{ dylibInstallName = Just f} @@ -883,6 +1090,16 @@ setOutputFile f d = d{ outputFile = f} setOutputHi f d = d{ outputHi = f} +addPluginModuleName :: String -> DynFlags -> DynFlags +addPluginModuleName name d = d { pluginModNames = (mkModuleName name) : (pluginModNames d) } + +addPluginModuleNameOption :: String -> DynFlags -> DynFlags +addPluginModuleNameOption optflag d = d { pluginModNameOpts = (mkModuleName m, option) : (pluginModNameOpts d) } + where (m, rest) = break (== ':') optflag + option = case rest of + [] -> "" -- should probably signal an error + (_:plug_opt) -> plug_opt -- ignore the ':' from break + parseDynLibLoaderMode f d = case splitAt 8 f of ("deploy", "") -> d{ dynLibLoader = Deployable } @@ -893,9 +1110,9 @@ -- 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 @@ -938,6 +1155,7 @@ -- transformed (e.g., "/out=") String -- the filepath/filename portion | Option String + deriving ( Eq ) showOpt :: Option -> String showOpt (FileOption pre f) = pre ++ f @@ -993,26 +1211,27 @@ -- the parsed 'DynFlags', the left-over arguments, and a list of warnings. -- Throws a 'UsageError' if errors occurred during parsing (such as unknown -- flags or missing arguments). -parseDynamicFlags :: Monad m => +parseDynamicFlagsCmdLine :: Monad m => DynFlags -> [Located String] -> m (DynFlags, [Located String], [Located String]) -- ^ Updated 'DynFlags', left-over arguments, and -- list of warnings. -parseDynamicFlags dflags args = parseDynamicFlags_ dflags args True +parseDynamicFlagsCmdLine dflags args = parseDynamicFlags dflags args True --- | Like 'parseDynamicFlags' but does not allow the package flags (-package, --- -hide-package, -ignore-package, -hide-all-packages, -package-conf). -parseDynamicNoPackageFlags :: Monad m => +-- | Like 'parseDynamicFlagsCmdLine' but does not allow the package flags +-- (-package, -hide-package, -ignore-package, -hide-all-packages, -package-conf). +-- Used to parse flags set in a modules pragma. +parseDynamicFilePragma :: Monad m => DynFlags -> [Located String] -> m (DynFlags, [Located String], [Located String]) -- ^ Updated 'DynFlags', left-over arguments, and -- list of warnings. -parseDynamicNoPackageFlags dflags args = parseDynamicFlags_ dflags args False +parseDynamicFilePragma dflags args = parseDynamicFlags dflags args False -parseDynamicFlags_ :: Monad m => +parseDynamicFlags :: Monad m => DynFlags -> [Located String] -> Bool -> m (DynFlags, [Located String], [Located String]) -parseDynamicFlags_ dflags0 args pkg_flags = do +parseDynamicFlags dflags0 args cmdline = do -- XXX Legacy support code -- We used to accept things like -- optdep-f -optdepdepend @@ -1026,32 +1245,43 @@ args' = f args -- Note: -ignore-package (package_flags) must precede -i* (dynamic_flags) - flag_spec | pkg_flags = package_flags ++ dynamic_flags + flag_spec | cmdline = package_flags ++ dynamic_flags | otherwise = dynamic_flags + let safeLevel = if safeLanguageOn dflags0 + then determineSafeLevel cmdline else NeverAllowed let ((leftover, errs, warns), dflags1) - = runCmdLine (processArgs flag_spec args') dflags0 + = runCmdLine (processArgs flag_spec args' safeLevel cmdline) dflags0 when (not (null errs)) $ ghcError $ errorsToGhcException errs - -- Cannot use -fPIC with registerised -fvia-C, because the mangler - -- isn't up to the job. We know that if hscTarget == HscC, then the - -- user has explicitly used -fvia-C, because -fasm is the default, - -- unless there is no NCG on this platform. The latter case is - -- checked when the -fPIC flag is parsed. - -- - let (pic_warns, dflags2) - | opt_PIC && hscTarget dflags1 == HscC && cGhcUnregisterised == "NO" - = ([L noSrcSpan $ "Warning: -fvia-C is incompatible with -fPIC; ignoring -fvia-C"], - dflags1{ hscTarget = HscAsm }) -#if !(x86_64_TARGET_ARCH && linux_TARGET_OS) - | (not opt_Static || opt_PIC) && hscTarget dflags1 == HscLlvm - = ([L noSrcSpan $ "Warning: -fllvm is incompatible with -fPIC and -" - ++ "dynamic on this platform;\n ignoring -fllvm"], - dflags1{ hscTarget = HscAsm }) -#endif - | otherwise = ([], dflags1) + -- check for disabled flags in safe haskell + -- Hack: unfortunately flags that are completely disabled can't be stopped from being + -- enabled on the command line before a -XSafe or -XSafeLanguage flag is encountered. + -- the easiest way to fix this is to just check that they aren't enabled now. The down + -- side is that flags marked as NeverAllowed must also be checked here placing a sync + -- burden on the ghc hacker. + let (dflags2, sh_warns) = if (safeLanguageOn dflags1) + then shFlagsDisallowed dflags1 + else (dflags1, []) + + return (dflags2, leftover, sh_warns ++ warns) + +-- | Extensions that can't be enabled at all when compiling in Safe mode +-- checkSafeHaskellFlags :: MonadIO m => DynFlags -> m () +shFlagsDisallowed :: DynFlags -> (DynFlags, [Located String]) +shFlagsDisallowed dflags = foldl check_method (dflags, []) bad_flags + where + check_method (df, warns) (test,str,fix) + | test df = (fix df, warns ++ safeFailure str) + | otherwise = (df, warns) + + bad_flags = [(xopt Opt_GeneralizedNewtypeDeriving, "-XGeneralizedNewtypeDeriving", + flip xopt_unset Opt_GeneralizedNewtypeDeriving), + (xopt Opt_TemplateHaskell, "-XTemplateHaskell", + flip xopt_unset Opt_TemplateHaskell)] - return (dflags2, leftover, pic_warns ++ warns) + safeFailure str = [L noSrcSpan $ "Warning: " ++ str ++ " is not allowed in" + ++ " Safe Haskell; ignoring " ++ str] {- ********************************************************************** @@ -1063,305 +1293,339 @@ allFlags :: [String] allFlags = map ('-':) $ [ flagName flag | flag <- dynamic_flags, ok (flagOptKind flag) ] ++ - map ("fno-"++) flags ++ - map ("f"++) flags ++ - map ("f"++) flags' ++ + map ("fno-"++) fflags ++ + map ("f"++) fflags ++ map ("X"++) supportedExtensions where ok (PrefixPred _ _) = False - ok _ = True - flags = [ name | (name, _, _) <- fFlags ] - flags' = [ name | (name, _, _) <- fLangFlags ] + ok _ = True + fflags = fflags0 ++ fflags1 ++ fflags2 + fflags0 = [ name | (name, _, _, _) <- fFlags ] + fflags1 = [ name | (name, _, _, _) <- fWarningFlags ] + fflags2 = [ name | (name, _, _, _) <- fLangFlags ] --------------- The main flags themselves ------------------ dynamic_flags :: [Flag (CmdLineP DynFlags)] dynamic_flags = [ - Flag "n" (NoArg (setDynFlag Opt_DryRun)) - , Flag "cpp" (NoArg (setExtensionFlag Opt_Cpp)) - , Flag "F" (NoArg (setDynFlag Opt_Pp)) - , Flag "#include" + flagA "n" (NoArg (addWarn "The -n flag is deprecated and no longer has any effect")) + , flagA "cpp" (NoArg (setExtensionFlag Opt_Cpp)) + , flagA "F" (NoArg (setDynFlag Opt_Pp)) + , flagA "#include" (HasArg (\s -> do { addCmdlineHCInclude s ; addWarn "-#include and INCLUDE pragmas are deprecated: They no longer have any effect" })) - , Flag "v" (OptIntSuffix setVerbosity) + , flagA "v" (OptIntSuffix setVerbosity) ------- 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 "pgmP" (hasArg setPgmP) - , Flag "pgmF" (hasArg (\f d -> d{ pgm_F = f})) - , Flag "pgmc" (hasArg (\f d -> d{ pgm_c = (f,[])})) - , Flag "pgmm" (hasArg (\f d -> d{ pgm_m = (f,[])})) - , 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})) + , flagA "pgmlo" (hasArg (\f -> alterSettings (\s -> s { sPgm_lo = (f,[])}))) + , flagA "pgmlc" (hasArg (\f -> alterSettings (\s -> s { sPgm_lc = (f,[])}))) + , flagA "pgmL" (hasArg (\f -> alterSettings (\s -> s { sPgm_L = f}))) + , flagA "pgmP" (hasArg setPgmP) + , flagA "pgmF" (hasArg (\f -> alterSettings (\s -> s { sPgm_F = f}))) + , flagA "pgmc" (hasArg (\f -> alterSettings (\s -> s { sPgm_c = (f,[])}))) + , flagA "pgmm" (HasArg (\_ -> addWarn "The -pgmm flag does nothing; it will be removed in a future GHC release")) + , flagA "pgms" (hasArg (\f -> alterSettings (\s -> s { sPgm_s = (f,[])}))) + , flagA "pgma" (hasArg (\f -> alterSettings (\s -> s { sPgm_a = (f,[])}))) + , flagA "pgml" (hasArg (\f -> alterSettings (\s -> s { sPgm_l = (f,[])}))) + , flagA "pgmdll" (hasArg (\f -> alterSettings (\s -> s { sPgm_dll = (f,[])}))) + , flagA "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 "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 "optl" (hasArg addOptl) - , Flag "optwindres" (hasArg (\f d -> d{ opt_windres = f : opt_windres d})) + , flagA "optlo" (hasArg (\f -> alterSettings (\s -> s { sOpt_lo = f : sOpt_lo s}))) + , flagA "optlc" (hasArg (\f -> alterSettings (\s -> s { sOpt_lc = f : sOpt_lc s}))) + , flagA "optL" (hasArg (\f -> alterSettings (\s -> s { sOpt_L = f : sOpt_L s}))) + , flagA "optP" (hasArg addOptP) + , flagA "optF" (hasArg (\f -> alterSettings (\s -> s { sOpt_F = f : sOpt_F s}))) + , flagA "optc" (hasArg (\f -> alterSettings (\s -> s { sOpt_c = f : sOpt_c s}))) + , flagA "optm" (HasArg (\_ -> addWarn "The -optm flag does nothing; it will be removed in a future GHC release")) + , flagA "opta" (hasArg (\f -> alterSettings (\s -> s { sOpt_a = f : sOpt_a s}))) + , flagA "optl" (hasArg addOptl) + , flagA "optwindres" (hasArg (\f -> alterSettings (\s -> s { sOpt_windres = f : sOpt_windres s}))) - , Flag "split-objs" + , flagA "split-objs" (NoArg (if can_split then setDynFlag Opt_SplitObjs else addWarn "ignoring -fsplit-objs")) -------- ghc -M ----------------------------------------------------- - , Flag "dep-suffix" (hasArg addDepSuffix) - , Flag "optdep-s" (hasArgDF addDepSuffix "Use -dep-suffix instead") - , Flag "dep-makefile" (hasArg setDepMakefile) - , Flag "optdep-f" (hasArgDF setDepMakefile "Use -dep-makefile instead") - , Flag "optdep-w" (NoArg (deprecate "doesn't do anything")) - , Flag "include-pkg-deps" (noArg (setDepIncludePkgDeps True)) - , Flag "optdep--include-prelude" (noArgDF (setDepIncludePkgDeps True) "Use -include-pkg-deps instead") - , Flag "optdep--include-pkg-deps" (noArgDF (setDepIncludePkgDeps True) "Use -include-pkg-deps instead") - , Flag "exclude-module" (hasArg addDepExcludeMod) - , Flag "optdep--exclude-module" (hasArgDF addDepExcludeMod "Use -exclude-module instead") - , Flag "optdep-x" (hasArgDF addDepExcludeMod "Use -exclude-module instead") + , flagA "dep-suffix" (hasArg addDepSuffix) + , flagA "optdep-s" (hasArgDF addDepSuffix "Use -dep-suffix instead") + , flagA "dep-makefile" (hasArg setDepMakefile) + , flagA "optdep-f" (hasArgDF setDepMakefile "Use -dep-makefile instead") + , flagA "optdep-w" (NoArg (deprecate "doesn't do anything")) + , flagA "include-pkg-deps" (noArg (setDepIncludePkgDeps True)) + , flagA "optdep--include-prelude" (noArgDF (setDepIncludePkgDeps True) "Use -include-pkg-deps instead") + , flagA "optdep--include-pkg-deps" (noArgDF (setDepIncludePkgDeps True) "Use -include-pkg-deps instead") + , flagA "exclude-module" (hasArg addDepExcludeMod) + , flagA "optdep--exclude-module" (hasArgDF addDepExcludeMod "Use -exclude-module instead") + , flagA "optdep-x" (hasArgDF addDepExcludeMod "Use -exclude-module instead") -------- Linking ---------------------------------------------------- - , Flag "no-link" (noArg (\d -> d{ ghcLink=NoLink })) - , Flag "shared" (noArg (\d -> d{ ghcLink=LinkDynLib })) - , Flag "dynload" (hasArg parseDynLibLoaderMode) - , Flag "dylib-install-name" (hasArg setDylibInstallName) + , flagA "no-link" (noArg (\d -> d{ ghcLink=NoLink })) + , flagA "shared" (noArg (\d -> d{ ghcLink=LinkDynLib })) + , flagA "dynload" (hasArg parseDynLibLoaderMode) + , flagA "dylib-install-name" (hasArg setDylibInstallName) ------- Libraries --------------------------------------------------- - , Flag "L" (Prefix addLibraryPath) - , Flag "l" (AnySuffix (upd . addOptl)) + , flagA "L" (Prefix addLibraryPath) + , flagA "l" (hasArg (addOptl . ("-l" ++))) ------- Frameworks -------------------------------------------------- -- -framework-path should really be -F ... - , Flag "framework-path" (HasArg addFrameworkPath) - , Flag "framework" (hasArg addCmdlineFramework) + , flagA "framework-path" (HasArg addFrameworkPath) + , flagA "framework" (hasArg addCmdlineFramework) ------- Output Redirection ------------------------------------------ - , Flag "odir" (hasArg setObjectDir) - , Flag "o" (SepArg (upd . setOutputFile . Just)) - , Flag "ohi" (hasArg (setOutputHi . Just )) - , Flag "osuf" (hasArg setObjectSuf) - , Flag "hcsuf" (hasArg setHcSuf) - , Flag "hisuf" (hasArg setHiSuf) - , Flag "hidir" (hasArg setHiDir) - , Flag "tmpdir" (hasArg setTmpDir) - , Flag "stubdir" (hasArg setStubDir) - , Flag "outputdir" (hasArg setOutputDir) - , Flag "ddump-file-prefix" (hasArg (setDumpPrefixForce . Just)) + , flagA "odir" (hasArg setObjectDir) + , flagA "o" (sepArg (setOutputFile . Just)) + , flagA "ohi" (hasArg (setOutputHi . Just )) + , flagA "osuf" (hasArg setObjectSuf) + , flagA "hcsuf" (hasArg setHcSuf) + , flagA "hisuf" (hasArg setHiSuf) + , flagA "hidir" (hasArg setHiDir) + , flagA "tmpdir" (hasArg setTmpDir) + , flagA "stubdir" (hasArg setStubDir) + , flagA "outputdir" (hasArg setOutputDir) + , flagA "ddump-file-prefix" (hasArg (setDumpPrefixForce . Just)) ------- Keeping temporary files ------------------------------------- -- These can be singular (think ghc -c) or plural (think ghc --make) - , Flag "keep-hc-file" (NoArg (setDynFlag Opt_KeepHcFiles)) - , Flag "keep-hc-files" (NoArg (setDynFlag Opt_KeepHcFiles)) - , Flag "keep-s-file" (NoArg (setDynFlag Opt_KeepSFiles)) - , Flag "keep-s-files" (NoArg (setDynFlag Opt_KeepSFiles)) - , Flag "keep-raw-s-file" (NoArg (setDynFlag Opt_KeepRawSFiles)) - , Flag "keep-raw-s-files" (NoArg (setDynFlag Opt_KeepRawSFiles)) - , Flag "keep-llvm-file" (NoArg (setDynFlag Opt_KeepLlvmFiles)) - , Flag "keep-llvm-files" (NoArg (setDynFlag Opt_KeepLlvmFiles)) + , flagA "keep-hc-file" (NoArg (setDynFlag Opt_KeepHcFiles)) + , flagA "keep-hc-files" (NoArg (setDynFlag Opt_KeepHcFiles)) + , flagA "keep-s-file" (NoArg (setDynFlag Opt_KeepSFiles)) + , flagA "keep-s-files" (NoArg (setDynFlag Opt_KeepSFiles)) + , flagA "keep-raw-s-file" (NoArg (addWarn "The -keep-raw-s-file flag does nothing; it will be removed in a future GHC release")) + , flagA "keep-raw-s-files" (NoArg (addWarn "The -keep-raw-s-files flag does nothing; it will be removed in a future GHC release")) + , flagA "keep-llvm-file" (NoArg (setDynFlag Opt_KeepLlvmFiles)) + , flagA "keep-llvm-files" (NoArg (setDynFlag Opt_KeepLlvmFiles)) -- This only makes sense as plural - , Flag "keep-tmp-files" (NoArg (setDynFlag Opt_KeepTmpFiles)) + , flagA "keep-tmp-files" (NoArg (setDynFlag Opt_KeepTmpFiles)) ------- Miscellaneous ---------------------------------------------- - , Flag "no-auto-link-packages" (NoArg (unSetDynFlag Opt_AutoLinkPackages)) - , Flag "no-hs-main" (NoArg (setDynFlag Opt_NoHsMain)) - , Flag "with-rtsopts" (HasArg setRtsOpts) - , Flag "rtsopts" (NoArg (setRtsOptsEnabled RtsOptsAll)) - , Flag "rtsopts=all" (NoArg (setRtsOptsEnabled RtsOptsAll)) - , Flag "rtsopts=some" (NoArg (setRtsOptsEnabled RtsOptsSafeOnly)) - , Flag "rtsopts=none" (NoArg (setRtsOptsEnabled RtsOptsNone)) - , Flag "no-rtsopts" (NoArg (setRtsOptsEnabled RtsOptsNone)) - , Flag "main-is" (SepArg setMainIs) - , Flag "haddock" (NoArg (setDynFlag Opt_Haddock)) - , Flag "haddock-opts" (hasArg addHaddockOpts) - , Flag "hpcdir" (SepArg setOptHpcDir) + , flagA "no-auto-link-packages" (NoArg (unSetDynFlag Opt_AutoLinkPackages)) + , flagA "no-hs-main" (NoArg (setDynFlag Opt_NoHsMain)) + , flagA "with-rtsopts" (HasArg setRtsOpts) + , flagA "rtsopts" (NoArg (setRtsOptsEnabled RtsOptsAll)) + , flagA "rtsopts=all" (NoArg (setRtsOptsEnabled RtsOptsAll)) + , flagA "rtsopts=some" (NoArg (setRtsOptsEnabled RtsOptsSafeOnly)) + , flagA "rtsopts=none" (NoArg (setRtsOptsEnabled RtsOptsNone)) + , flagA "no-rtsopts" (NoArg (setRtsOptsEnabled RtsOptsNone)) + , flagA "main-is" (SepArg setMainIs) + , flagA "haddock" (NoArg (setDynFlag Opt_Haddock)) + , flagA "haddock-opts" (hasArg addHaddockOpts) + , flagA "hpcdir" (SepArg setOptHpcDir) ------- recompilation checker -------------------------------------- - , Flag "recomp" (NoArg (do { unSetDynFlag Opt_ForceRecomp + , flagA "recomp" (NoArg (do { unSetDynFlag Opt_ForceRecomp ; deprecate "Use -fno-force-recomp instead" })) - , Flag "no-recomp" (NoArg (do { setDynFlag Opt_ForceRecomp + , flagA "no-recomp" (NoArg (do { setDynFlag Opt_ForceRecomp ; deprecate "Use -fforce-recomp instead" })) ------ HsCpp opts --------------------------------------------------- - , Flag "D" (AnySuffix (upd . addOptP)) - , Flag "U" (AnySuffix (upd . addOptP)) + , flagA "D" (AnySuffix (upd . addOptP)) + , flagA "U" (AnySuffix (upd . addOptP)) ------- Include/Import Paths ---------------------------------------- - , Flag "I" (Prefix addIncludePath) - , Flag "i" (OptPrefix addImportPath) + , flagA "I" (Prefix addIncludePath) + , flagA "i" (OptPrefix addImportPath) ------ Debugging ---------------------------------------------------- - , Flag "dstg-stats" (NoArg (setDynFlag Opt_StgStats)) + , flagA "dstg-stats" (NoArg (setDynFlag Opt_StgStats)) - , Flag "ddump-cmm" (setDumpFlag Opt_D_dump_cmm) - , Flag "ddump-cmmz" (setDumpFlag Opt_D_dump_cmmz) - , Flag "ddump-cmmz-pretty" (setDumpFlag Opt_D_dump_cmmz_pretty) - , Flag "ddump-cps-cmm" (setDumpFlag Opt_D_dump_cps_cmm) - , Flag "ddump-cvt-cmm" (setDumpFlag Opt_D_dump_cvt_cmm) - , Flag "ddump-asm" (setDumpFlag Opt_D_dump_asm) - , Flag "ddump-asm-native" (setDumpFlag Opt_D_dump_asm_native) - , Flag "ddump-asm-liveness" (setDumpFlag Opt_D_dump_asm_liveness) - , Flag "ddump-asm-coalesce" (setDumpFlag Opt_D_dump_asm_coalesce) - , Flag "ddump-asm-regalloc" (setDumpFlag Opt_D_dump_asm_regalloc) - , Flag "ddump-asm-conflicts" (setDumpFlag Opt_D_dump_asm_conflicts) - , Flag "ddump-asm-regalloc-stages" (setDumpFlag Opt_D_dump_asm_regalloc_stages) - , Flag "ddump-asm-stats" (setDumpFlag Opt_D_dump_asm_stats) - , Flag "ddump-asm-expanded" (setDumpFlag Opt_D_dump_asm_expanded) - , Flag "ddump-llvm" (NoArg (do { setObjTarget HscLlvm - ; setDumpFlag' Opt_D_dump_llvm})) - , Flag "ddump-cpranal" (setDumpFlag Opt_D_dump_cpranal) - , Flag "ddump-deriv" (setDumpFlag Opt_D_dump_deriv) - , Flag "ddump-ds" (setDumpFlag Opt_D_dump_ds) - , Flag "ddump-flatC" (setDumpFlag Opt_D_dump_flatC) - , Flag "ddump-foreign" (setDumpFlag Opt_D_dump_foreign) - , Flag "ddump-inlinings" (setDumpFlag Opt_D_dump_inlinings) - , Flag "ddump-rule-firings" (setDumpFlag Opt_D_dump_rule_firings) - , Flag "ddump-occur-anal" (setDumpFlag Opt_D_dump_occur_anal) - , Flag "ddump-parsed" (setDumpFlag Opt_D_dump_parsed) - , Flag "ddump-rn" (setDumpFlag Opt_D_dump_rn) - , Flag "ddump-simpl" (setDumpFlag Opt_D_dump_simpl) - , Flag "ddump-simpl-iterations" (setDumpFlag Opt_D_dump_simpl_iterations) - , Flag "ddump-simpl-phases" (OptPrefix setDumpSimplPhases) - , Flag "ddump-spec" (setDumpFlag Opt_D_dump_spec) - , Flag "ddump-prep" (setDumpFlag Opt_D_dump_prep) - , Flag "ddump-stg" (setDumpFlag Opt_D_dump_stg) - , Flag "ddump-stranal" (setDumpFlag Opt_D_dump_stranal) - , Flag "ddump-tc" (setDumpFlag Opt_D_dump_tc) - , Flag "ddump-types" (setDumpFlag Opt_D_dump_types) - , Flag "ddump-rules" (setDumpFlag Opt_D_dump_rules) - , Flag "ddump-cse" (setDumpFlag Opt_D_dump_cse) - , Flag "ddump-worker-wrapper" (setDumpFlag Opt_D_dump_worker_wrapper) - , Flag "ddump-rn-trace" (setDumpFlag Opt_D_dump_rn_trace) - , Flag "ddump-if-trace" (setDumpFlag Opt_D_dump_if_trace) - , Flag "ddump-cs-trace" (setDumpFlag Opt_D_dump_cs_trace) - , Flag "ddump-tc-trace" (setDumpFlag Opt_D_dump_tc_trace) - , Flag "ddump-splices" (setDumpFlag Opt_D_dump_splices) - , Flag "ddump-rn-stats" (setDumpFlag Opt_D_dump_rn_stats) - , Flag "ddump-opt-cmm" (setDumpFlag Opt_D_dump_opt_cmm) - , Flag "ddump-simpl-stats" (setDumpFlag Opt_D_dump_simpl_stats) - , Flag "ddump-bcos" (setDumpFlag Opt_D_dump_BCOs) - , Flag "dsource-stats" (setDumpFlag Opt_D_source_stats) - , Flag "dverbose-core2core" (NoArg (do { setVerbosity (Just 2) - ; setVerboseCore2Core })) - , Flag "dverbose-stg2stg" (setDumpFlag Opt_D_verbose_stg2stg) - , Flag "ddump-hi" (setDumpFlag Opt_D_dump_hi) - , Flag "ddump-minimal-imports" (setDumpFlag Opt_D_dump_minimal_imports) - , Flag "ddump-vect" (setDumpFlag Opt_D_dump_vect) - , Flag "ddump-hpc" (setDumpFlag Opt_D_dump_hpc) - , Flag "ddump-mod-cycles" (setDumpFlag Opt_D_dump_mod_cycles) - , Flag "ddump-view-pattern-commoning" (setDumpFlag Opt_D_dump_view_pattern_commoning) - , Flag "ddump-to-file" (setDumpFlag Opt_DumpToFile) - , Flag "ddump-hi-diffs" (setDumpFlag Opt_D_dump_hi_diffs) - , Flag "ddump-rtti" (setDumpFlag Opt_D_dump_rtti) - , Flag "dcore-lint" (NoArg (setDynFlag Opt_DoCoreLinting)) - , Flag "dstg-lint" (NoArg (setDynFlag Opt_DoStgLinting)) - , Flag "dcmm-lint" (NoArg (setDynFlag Opt_DoCmmLinting)) - , Flag "dasm-lint" (NoArg (setDynFlag Opt_DoAsmLinting)) - , Flag "dshow-passes" (NoArg (do forceRecompile - setVerbosity (Just 2))) - , Flag "dfaststring-stats" (NoArg (setDynFlag Opt_D_faststring_stats)) + , flagA "ddump-cmm" (setDumpFlag Opt_D_dump_cmm) + , flagA "ddump-raw-cmm" (setDumpFlag Opt_D_dump_raw_cmm) + , flagA "ddump-cmmz" (setDumpFlag Opt_D_dump_cmmz) + , flagA "ddump-cmmz-pretty" (setDumpFlag Opt_D_dump_cmmz_pretty) + , flagA "ddump-cmmz-cbe" (setDumpFlag Opt_D_dump_cmmz_cbe) + , flagA "ddump-cmmz-spills" (setDumpFlag Opt_D_dump_cmmz_spills) + , flagA "ddump-cmmz-proc" (setDumpFlag Opt_D_dump_cmmz_proc) + , flagA "ddump-cmmz-rewrite" (setDumpFlag Opt_D_dump_cmmz_rewrite) + , flagA "ddump-cmmz-dead" (setDumpFlag Opt_D_dump_cmmz_dead) + , flagA "ddump-cmmz-stub" (setDumpFlag Opt_D_dump_cmmz_stub) + , flagA "ddump-cmmz-sp" (setDumpFlag Opt_D_dump_cmmz_sp) + , flagA "ddump-cmmz-procmap" (setDumpFlag Opt_D_dump_cmmz_procmap) + , flagA "ddump-cmmz-split" (setDumpFlag Opt_D_dump_cmmz_split) + , flagA "ddump-cmmz-lower" (setDumpFlag Opt_D_dump_cmmz_lower) + , flagA "ddump-cmmz-info" (setDumpFlag Opt_D_dump_cmmz_info) + , flagA "ddump-cmmz-cafs" (setDumpFlag Opt_D_dump_cmmz_cafs) + , flagA "ddump-core-stats" (setDumpFlag Opt_D_dump_core_stats) + , flagA "ddump-cps-cmm" (setDumpFlag Opt_D_dump_cps_cmm) + , flagA "ddump-cvt-cmm" (setDumpFlag Opt_D_dump_cvt_cmm) + , flagA "ddump-asm" (setDumpFlag Opt_D_dump_asm) + , flagA "ddump-asm-native" (setDumpFlag Opt_D_dump_asm_native) + , flagA "ddump-asm-liveness" (setDumpFlag Opt_D_dump_asm_liveness) + , flagA "ddump-asm-coalesce" (setDumpFlag Opt_D_dump_asm_coalesce) + , flagA "ddump-asm-regalloc" (setDumpFlag Opt_D_dump_asm_regalloc) + , flagA "ddump-asm-conflicts" (setDumpFlag Opt_D_dump_asm_conflicts) + , flagA "ddump-asm-regalloc-stages" (setDumpFlag Opt_D_dump_asm_regalloc_stages) + , flagA "ddump-asm-stats" (setDumpFlag Opt_D_dump_asm_stats) + , flagA "ddump-asm-expanded" (setDumpFlag Opt_D_dump_asm_expanded) + , flagA "ddump-llvm" (NoArg (do { setObjTarget HscLlvm + ; setDumpFlag' Opt_D_dump_llvm})) + , flagA "ddump-cpranal" (setDumpFlag Opt_D_dump_cpranal) + , flagA "ddump-deriv" (setDumpFlag Opt_D_dump_deriv) + , flagA "ddump-ds" (setDumpFlag Opt_D_dump_ds) + , flagA "ddump-flatC" (setDumpFlag Opt_D_dump_flatC) + , flagA "ddump-foreign" (setDumpFlag Opt_D_dump_foreign) + , flagA "ddump-inlinings" (setDumpFlag Opt_D_dump_inlinings) + , flagA "ddump-rule-firings" (setDumpFlag Opt_D_dump_rule_firings) + , flagA "ddump-rule-rewrites" (setDumpFlag Opt_D_dump_rule_rewrites) + , flagA "ddump-occur-anal" (setDumpFlag Opt_D_dump_occur_anal) + , flagA "ddump-parsed" (setDumpFlag Opt_D_dump_parsed) + , flagA "ddump-rn" (setDumpFlag Opt_D_dump_rn) + , flagA "ddump-core-pipeline" (setDumpFlag Opt_D_dump_core_pipeline) + , flagA "ddump-simpl" (setDumpFlag Opt_D_dump_simpl) + , flagA "ddump-simpl-iterations" (setDumpFlag Opt_D_dump_simpl_iterations) + , flagA "ddump-simpl-phases" (OptPrefix setDumpSimplPhases) + , flagA "ddump-spec" (setDumpFlag Opt_D_dump_spec) + , flagA "ddump-prep" (setDumpFlag Opt_D_dump_prep) + , flagA "ddump-stg" (setDumpFlag Opt_D_dump_stg) + , flagA "ddump-stranal" (setDumpFlag Opt_D_dump_stranal) + , flagA "ddump-tc" (setDumpFlag Opt_D_dump_tc) + , flagA "ddump-types" (setDumpFlag Opt_D_dump_types) + , flagA "ddump-rules" (setDumpFlag Opt_D_dump_rules) + , flagA "ddump-cse" (setDumpFlag Opt_D_dump_cse) + , flagA "ddump-worker-wrapper" (setDumpFlag Opt_D_dump_worker_wrapper) + , flagA "ddump-rn-trace" (setDumpFlag Opt_D_dump_rn_trace) + , flagA "ddump-if-trace" (setDumpFlag Opt_D_dump_if_trace) + , flagA "ddump-cs-trace" (setDumpFlag Opt_D_dump_cs_trace) + , flagA "ddump-tc-trace" (setDumpFlag Opt_D_dump_tc_trace) + , flagA "ddump-vt-trace" (setDumpFlag Opt_D_dump_vt_trace) + , flagA "ddump-splices" (setDumpFlag Opt_D_dump_splices) + , flagA "ddump-rn-stats" (setDumpFlag Opt_D_dump_rn_stats) + , flagA "ddump-opt-cmm" (setDumpFlag Opt_D_dump_opt_cmm) + , flagA "ddump-simpl-stats" (setDumpFlag Opt_D_dump_simpl_stats) + , flagA "ddump-bcos" (setDumpFlag Opt_D_dump_BCOs) + , flagA "dsource-stats" (setDumpFlag Opt_D_source_stats) + , flagA "dverbose-core2core" (NoArg (do { setVerbosity (Just 2) + ; setVerboseCore2Core })) + , flagA "dverbose-stg2stg" (setDumpFlag Opt_D_verbose_stg2stg) + , flagA "ddump-hi" (setDumpFlag Opt_D_dump_hi) + , flagA "ddump-minimal-imports" (setDumpFlag Opt_D_dump_minimal_imports) + , flagA "ddump-vect" (setDumpFlag Opt_D_dump_vect) + , flagA "ddump-hpc" (setDumpFlag Opt_D_dump_hpc) + , flagA "ddump-mod-cycles" (setDumpFlag Opt_D_dump_mod_cycles) + , flagA "ddump-view-pattern-commoning" (setDumpFlag Opt_D_dump_view_pattern_commoning) + , flagA "ddump-to-file" (setDumpFlag Opt_DumpToFile) + , flagA "ddump-hi-diffs" (setDumpFlag Opt_D_dump_hi_diffs) + , flagA "ddump-rtti" (setDumpFlag Opt_D_dump_rtti) + , flagA "dcore-lint" (NoArg (setDynFlag Opt_DoCoreLinting)) + , flagA "dstg-lint" (NoArg (setDynFlag Opt_DoStgLinting)) + , flagA "dcmm-lint" (NoArg (setDynFlag Opt_DoCmmLinting)) + , flagA "dasm-lint" (NoArg (setDynFlag Opt_DoAsmLinting)) + , flagA "dshow-passes" (NoArg (do forceRecompile + setVerbosity (Just 2))) + , flagA "dfaststring-stats" (NoArg (setDynFlag Opt_D_faststring_stats)) ------ Machine dependant (-m) stuff --------------------------- - , Flag "monly-2-regs" (noArg (\s -> s{stolen_x86_regs = 2})) - , Flag "monly-3-regs" (noArg (\s -> s{stolen_x86_regs = 3})) - , Flag "monly-4-regs" (noArg (\s -> s{stolen_x86_regs = 4})) - , Flag "msse2" (NoArg (setDynFlag Opt_SSE2)) + , flagA "monly-2-regs" (NoArg (addWarn "The -monly-2-regs flag does nothing; it will be removed in a future GHC release")) + , flagA "monly-3-regs" (NoArg (addWarn "The -monly-3-regs flag does nothing; it will be removed in a future GHC release")) + , flagA "monly-4-regs" (NoArg (addWarn "The -monly-4-regs flag does nothing; it will be removed in a future GHC release")) + , flagA "msse2" (NoArg (setDynFlag Opt_SSE2)) ------ Warning opts ------------------------------------------------- - , Flag "W" (NoArg (mapM_ setDynFlag minusWOpts)) - , Flag "Werror" (NoArg (setDynFlag Opt_WarnIsError)) - , Flag "Wwarn" (NoArg (unSetDynFlag Opt_WarnIsError)) - , Flag "Wall" (NoArg (mapM_ setDynFlag minusWallOpts)) - , Flag "Wnot" (NoArg (do { mapM_ unSetDynFlag minusWallOpts - ; deprecate "Use -w instead" })) - , Flag "w" (NoArg (mapM_ unSetDynFlag minuswRemovesOpts)) - + , flagA "W" (NoArg (mapM_ setWarningFlag minusWOpts)) + , flagA "Werror" (NoArg (setDynFlag Opt_WarnIsError)) + , flagA "Wwarn" (NoArg (unSetDynFlag Opt_WarnIsError)) + , flagA "Wall" (NoArg (mapM_ setWarningFlag minusWallOpts)) + , flagA "Wnot" (NoArg (do upd (\dfs -> dfs {warningFlags = []}) + deprecate "Use -w instead")) + , flagA "w" (NoArg (upd (\dfs -> dfs {warningFlags = []}))) + + ------ Plugin flags ------------------------------------------------ + , flagA "fplugin-opt" (hasArg addPluginModuleNameOption) + , flagA "fplugin" (hasArg addPluginModuleName) + ------ Optimisation flags ------------------------------------------ - , Flag "O" (noArg (setOptLevel 1)) - , Flag "Onot" (noArgDF (setOptLevel 0) "Use -O0 instead") - , Flag "Odph" (noArg setDPHOpt) - , Flag "O" (OptIntSuffix (\mb_n -> upd (setOptLevel (mb_n `orElse` 1)))) + , flagA "O" (noArgM (setOptLevel 1)) + , flagA "Onot" (noArgM (\dflags -> do deprecate "Use -O0 instead" + setOptLevel 0 dflags)) + , flagA "Odph" (noArgM setDPHOpt) + , flagA "O" (optIntSuffixM (\mb_n -> setOptLevel (mb_n `orElse` 1))) -- If the number is missing, use 1 - , Flag "fsimplifier-phases" (intSuffix (\n d -> d{ simplPhases = n })) - , Flag "fmax-simplifier-iterations" (intSuffix (\n d -> d{ maxSimplIterations = n })) - , Flag "fspec-constr-threshold" (intSuffix (\n d -> d{ specConstrThreshold = Just n })) - , Flag "fno-spec-constr-threshold" (noArg (\d -> d{ specConstrThreshold = Nothing })) - , Flag "fspec-constr-count" (intSuffix (\n d -> d{ specConstrCount = Just n })) - , Flag "fno-spec-constr-count" (noArg (\d -> d{ specConstrCount = Nothing })) - , Flag "fliberate-case-threshold" (intSuffix (\n d -> d{ liberateCaseThreshold = Just n })) - , Flag "fno-liberate-case-threshold" (noArg (\d -> d{ liberateCaseThreshold = Nothing })) - , Flag "frule-check" (SepArg (\s -> upd (\d -> d{ ruleCheck = Just s }))) - , 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 })) + , flagA "fsimplifier-phases" (intSuffix (\n d -> d{ simplPhases = n })) + , flagA "fmax-simplifier-iterations" (intSuffix (\n d -> d{ maxSimplIterations = n })) + , flagA "fspec-constr-threshold" (intSuffix (\n d -> d{ specConstrThreshold = Just n })) + , flagA "fno-spec-constr-threshold" (noArg (\d -> d{ specConstrThreshold = Nothing })) + , flagA "fspec-constr-count" (intSuffix (\n d -> d{ specConstrCount = Just n })) + , flagA "fno-spec-constr-count" (noArg (\d -> d{ specConstrCount = Nothing })) + , flagA "fliberate-case-threshold" (intSuffix (\n d -> d{ liberateCaseThreshold = Just n })) + , flagA "fno-liberate-case-threshold" (noArg (\d -> d{ liberateCaseThreshold = Nothing })) + , flagA "frule-check" (sepArg (\s d -> d{ ruleCheck = Just s })) + , flagA "fcontext-stack" (intSuffix (\n d -> d{ ctxtStkDepth = n })) + , flagA "fstrictness-before" (intSuffix (\n d -> d{ strictnessBefore = n : strictnessBefore d })) + , flagA "ffloat-lam-args" (intSuffix (\n d -> d{ floatLamArgs = Just n })) + , flagA "ffloat-all-lams" (noArg (\d -> d{ floatLamArgs = Nothing })) ------ Profiling ---------------------------------------------------- -- XXX Should the -f* flags be deprecated? -- They don't seem to be documented - , Flag "fauto-sccs-on-all-toplevs" (NoArg (setDynFlag Opt_AutoSccsOnAllToplevs)) - , Flag "auto-all" (NoArg (setDynFlag Opt_AutoSccsOnAllToplevs)) - , Flag "no-auto-all" (NoArg (unSetDynFlag Opt_AutoSccsOnAllToplevs)) - , Flag "fauto-sccs-on-exported-toplevs" (NoArg (setDynFlag Opt_AutoSccsOnExportedToplevs)) - , Flag "auto" (NoArg (setDynFlag Opt_AutoSccsOnExportedToplevs)) - , Flag "no-auto" (NoArg (unSetDynFlag Opt_AutoSccsOnExportedToplevs)) - , Flag "fauto-sccs-on-individual-cafs" (NoArg (setDynFlag Opt_AutoSccsOnIndividualCafs)) - , Flag "caf-all" (NoArg (setDynFlag Opt_AutoSccsOnIndividualCafs)) - , Flag "no-caf-all" (NoArg (unSetDynFlag Opt_AutoSccsOnIndividualCafs)) + , flagA "fauto-sccs-on-all-toplevs" (NoArg (setDynFlag Opt_AutoSccsOnAllToplevs)) + , flagA "auto-all" (NoArg (setDynFlag Opt_AutoSccsOnAllToplevs)) + , flagA "no-auto-all" (NoArg (unSetDynFlag Opt_AutoSccsOnAllToplevs)) + , flagA "fauto-sccs-on-exported-toplevs" (NoArg (setDynFlag Opt_AutoSccsOnExportedToplevs)) + , flagA "auto" (NoArg (setDynFlag Opt_AutoSccsOnExportedToplevs)) + , flagA "no-auto" (NoArg (unSetDynFlag Opt_AutoSccsOnExportedToplevs)) + , flagA "fauto-sccs-on-individual-cafs" (NoArg (setDynFlag Opt_AutoSccsOnIndividualCafs)) + , flagA "caf-all" (NoArg (setDynFlag Opt_AutoSccsOnIndividualCafs)) + , flagA "no-caf-all" (NoArg (unSetDynFlag Opt_AutoSccsOnIndividualCafs)) ------ DPH flags ---------------------------------------------------- - , Flag "fdph-seq" (NoArg (setDPHBackend DPHSeq)) - , Flag "fdph-par" (NoArg (setDPHBackend DPHPar)) - , Flag "fdph-this" (NoArg (setDPHBackend DPHThis)) + , flagA "fdph-seq" (NoArg (setDPHBackend DPHSeq)) + , flagA "fdph-par" (NoArg (setDPHBackend DPHPar)) + , flagA "fdph-this" (NoArg (setDPHBackend DPHThis)) + , flagA "fdph-none" (NoArg (setDPHBackend DPHNone)) ------ Compiler flags ----------------------------------------------- - , Flag "fasm" (NoArg (setObjTarget HscAsm)) - , Flag "fvia-c" (NoArg (setObjTarget HscC >> - (addWarn "The -fvia-c flag will be removed in a future GHC release"))) - , Flag "fvia-C" (NoArg (setObjTarget HscC >> - (addWarn "The -fvia-C flag will be removed in a future GHC release"))) - , Flag "fllvm" (NoArg (setObjTarget HscLlvm)) - - , Flag "fno-code" (NoArg (do upd $ \d -> d{ ghcLink=NoLink } - setTarget HscNothing)) - , Flag "fbyte-code" (NoArg (setTarget HscInterpreted)) - , Flag "fobject-code" (NoArg (setTarget defaultHscTarget)) - , Flag "fglasgow-exts" (NoArg (enableGlasgowExts >> deprecate "Use individual extensions instead")) - , Flag "fno-glasgow-exts" (NoArg (disableGlasgowExts >> deprecate "Use individual extensions instead")) + , flagA "fasm" (NoArg (setObjTarget HscAsm)) + , flagA "fvia-c" (NoArg + (addWarn "The -fvia-c flag does nothing; it will be removed in a future GHC release")) + , flagA "fvia-C" (NoArg + (addWarn "The -fvia-C flag does nothing; it will be removed in a future GHC release")) + , flagA "fllvm" (NoArg (setObjTarget HscLlvm)) + + , flagA "fno-code" (NoArg (do { upd $ \d -> d{ ghcLink=NoLink } + ; setTarget HscNothing })) + , flagA "fbyte-code" (NoArg (setTarget HscInterpreted)) + , flagA "fobject-code" (NoArg (setTarget defaultHscTarget)) + , flagA "fglasgow-exts" (NoArg (enableGlasgowExts >> deprecate "Use individual extensions instead")) + , flagA "fno-glasgow-exts" (NoArg (disableGlasgowExts >> deprecate "Use individual extensions instead")) ] ++ map (mkFlag turnOn "f" setDynFlag ) fFlags ++ map (mkFlag turnOff "fno-" unSetDynFlag) fFlags + ++ map (mkFlag turnOn "f" setWarningFlag ) fWarningFlags + ++ map (mkFlag turnOff "fno-" unSetWarningFlag) fWarningFlags ++ map (mkFlag turnOn "f" setExtensionFlag ) fLangFlags ++ map (mkFlag turnOff "fno-" unSetExtensionFlag) fLangFlags ++ map (mkFlag turnOn "X" setExtensionFlag ) xFlags ++ map (mkFlag turnOff "XNo" unSetExtensionFlag) xFlags ++ map (mkFlag turnOn "X" setLanguage) languageFlags + ++ map (mkFlag turnOn "X" setSafeHaskell) safeHaskellFlags + ++ [ flagA "XGenerics" (NoArg (deprecate "it does nothing; look into -XDefaultSignatures and -XDeriveGeneric for generic programming support.")) + , flagA "XNoGenerics" (NoArg (deprecate "it does nothing; look into -XDefaultSignatures and -XDeriveGeneric for generic programming support.")) ] package_flags :: [Flag (CmdLineP DynFlags)] package_flags = [ ------- Packages ---------------------------------------------------- - Flag "package-conf" (HasArg extraPkgConf_) - , Flag "no-user-package-conf" (NoArg (unSetDynFlag Opt_ReadUserPackageConf)) - , Flag "package-name" (hasArg setPackageName) - , Flag "package-id" (HasArg exposePackageId) - , Flag "package" (HasArg exposePackage) - , Flag "hide-package" (HasArg hidePackage) - , Flag "hide-all-packages" (NoArg (setDynFlag Opt_HideAllPackages)) - , Flag "ignore-package" (HasArg ignorePackage) - , Flag "syslib" (HasArg (\s -> do { exposePackage s - ; deprecate "Use -package instead" })) + -- specifying these to be flagC is redundant since they are actually + -- static flags, but best to do this anyway. + flagC "package-conf" (HasArg extraPkgConf_) + , flagC "no-user-package-conf" (NoArg (unSetDynFlag Opt_ReadUserPackageConf)) + , flagC "package-name" (hasArg setPackageName) + , flagC "package-id" (HasArg exposePackageId) + , flagC "package" (HasArg exposePackage) + , flagC "hide-package" (HasArg hidePackage) + , flagC "hide-all-packages" (NoArg (setDynFlag Opt_HideAllPackages)) + , flagC "ignore-package" (HasArg ignorePackage) + , flagC "syslib" (HasArg (\s -> do { exposePackage s + ; deprecate "Use -package instead" })) + , flagC "trust" (HasArg trustPackage) + , flagC "distrust" (HasArg distrustPackage) + , flagC "distrust-all-packages" (NoArg (setDynFlag Opt_DistrustAllPackages)) ] type TurnOnFlag = Bool -- True <=> we are turning the flag on @@ -1371,6 +1635,7 @@ type FlagSpec flag = ( String -- Flag in string form + , FlagSafety , flag -- Flag in internal form , TurnOnFlag -> DynP ()) -- Extra action to run when the flag is found -- Typically, emit a warning or error @@ -1380,8 +1645,8 @@ -> (flag -> DynP ()) -- ^ What to do when the flag is found -> FlagSpec flag -- ^ Specification of this particular flag -> Flag (CmdLineP DynFlags) -mkFlag turn_on flagPrefix f (name, flag, extra_action) - = Flag (flagPrefix ++ name) (NoArg (f flag >> extra_action turn_on)) +mkFlag turn_on flagPrefix f (name, fsafe, flag, extra_action) + = Flag (flagPrefix ++ name) fsafe (NoArg (f flag >> extra_action turn_on)) deprecatedForExtension :: String -> TurnOnFlag -> DynP () deprecatedForExtension lang turn_on @@ -1400,221 +1665,243 @@ nop _ = return () -- | These @-f\@ flags can all be reversed with @-fno-\@ +fWarningFlags :: [FlagSpec WarningFlag] +fWarningFlags = [ + ( "warn-dodgy-foreign-imports", AlwaysAllowed, Opt_WarnDodgyForeignImports, nop ), + ( "warn-dodgy-exports", AlwaysAllowed, Opt_WarnDodgyExports, nop ), + ( "warn-dodgy-imports", AlwaysAllowed, Opt_WarnDodgyImports, nop ), + ( "warn-duplicate-exports", AlwaysAllowed, Opt_WarnDuplicateExports, nop ), + ( "warn-hi-shadowing", AlwaysAllowed, Opt_WarnHiShadows, nop ), + ( "warn-implicit-prelude", AlwaysAllowed, Opt_WarnImplicitPrelude, nop ), + ( "warn-incomplete-patterns", AlwaysAllowed, Opt_WarnIncompletePatterns, nop ), + ( "warn-incomplete-uni-patterns", AlwaysAllowed, Opt_WarnIncompleteUniPatterns, nop ), + ( "warn-incomplete-record-updates", AlwaysAllowed, Opt_WarnIncompletePatternsRecUpd, nop ), + ( "warn-missing-fields", AlwaysAllowed, Opt_WarnMissingFields, nop ), + ( "warn-missing-import-lists", AlwaysAllowed, Opt_WarnMissingImportList, nop ), + ( "warn-missing-methods", AlwaysAllowed, Opt_WarnMissingMethods, nop ), + ( "warn-missing-signatures", AlwaysAllowed, Opt_WarnMissingSigs, nop ), + ( "warn-missing-local-sigs", AlwaysAllowed, Opt_WarnMissingLocalSigs, nop ), + ( "warn-name-shadowing", AlwaysAllowed, Opt_WarnNameShadowing, nop ), + ( "warn-overlapping-patterns", AlwaysAllowed, Opt_WarnOverlappingPatterns, nop ), + ( "warn-type-defaults", AlwaysAllowed, Opt_WarnTypeDefaults, nop ), + ( "warn-monomorphism-restriction", AlwaysAllowed, Opt_WarnMonomorphism, nop ), + ( "warn-unused-binds", AlwaysAllowed, Opt_WarnUnusedBinds, nop ), + ( "warn-unused-imports", AlwaysAllowed, Opt_WarnUnusedImports, nop ), + ( "warn-unused-matches", AlwaysAllowed, Opt_WarnUnusedMatches, nop ), + ( "warn-warnings-deprecations", AlwaysAllowed, Opt_WarnWarningsDeprecations, nop ), + ( "warn-deprecations", AlwaysAllowed, Opt_WarnWarningsDeprecations, nop ), + ( "warn-deprecated-flags", AlwaysAllowed, Opt_WarnDeprecatedFlags, nop ), + ( "warn-orphans", AlwaysAllowed, Opt_WarnOrphans, nop ), + ( "warn-identities", AlwaysAllowed, Opt_WarnIdentities, nop ), + ( "warn-auto-orphans", AlwaysAllowed, Opt_WarnAutoOrphans, nop ), + ( "warn-tabs", AlwaysAllowed, Opt_WarnTabs, nop ), + ( "warn-unrecognised-pragmas", AlwaysAllowed, Opt_WarnUnrecognisedPragmas, nop ), + ( "warn-lazy-unlifted-bindings", AlwaysAllowed, Opt_WarnLazyUnliftedBindings, nop), + ( "warn-unused-do-bind", AlwaysAllowed, Opt_WarnUnusedDoBind, nop ), + ( "warn-wrong-do-bind", AlwaysAllowed, Opt_WarnWrongDoBind, nop ), + ( "warn-alternative-layout-rule-transitional", AlwaysAllowed, Opt_WarnAlternativeLayoutRuleTransitional, nop )] + +-- | These @-f\@ flags can all be reversed with @-fno-\@ fFlags :: [FlagSpec DynFlag] fFlags = [ - ( "warn-dodgy-foreign-imports", Opt_WarnDodgyForeignImports, nop ), - ( "warn-dodgy-exports", Opt_WarnDodgyExports, nop ), - ( "warn-dodgy-imports", Opt_WarnDodgyImports, nop ), - ( "warn-duplicate-exports", Opt_WarnDuplicateExports, nop ), - ( "warn-hi-shadowing", Opt_WarnHiShadows, nop ), - ( "warn-implicit-prelude", Opt_WarnImplicitPrelude, nop ), - ( "warn-incomplete-patterns", Opt_WarnIncompletePatterns, nop ), - ( "warn-incomplete-record-updates", Opt_WarnIncompletePatternsRecUpd, nop ), - ( "warn-missing-fields", Opt_WarnMissingFields, nop ), - ( "warn-missing-import-lists", Opt_WarnMissingImportList, nop ), - ( "warn-missing-methods", Opt_WarnMissingMethods, nop ), - ( "warn-missing-signatures", Opt_WarnMissingSigs, nop ), - ( "warn-missing-local-sigs", Opt_WarnMissingLocalSigs, nop ), - ( "warn-name-shadowing", Opt_WarnNameShadowing, nop ), - ( "warn-overlapping-patterns", Opt_WarnOverlappingPatterns, nop ), - ( "warn-type-defaults", Opt_WarnTypeDefaults, nop ), - ( "warn-monomorphism-restriction", Opt_WarnMonomorphism, nop ), - ( "warn-unused-binds", Opt_WarnUnusedBinds, nop ), - ( "warn-unused-imports", Opt_WarnUnusedImports, nop ), - ( "warn-unused-matches", Opt_WarnUnusedMatches, nop ), - ( "warn-warnings-deprecations", Opt_WarnWarningsDeprecations, nop ), - ( "warn-deprecations", Opt_WarnWarningsDeprecations, nop ), - ( "warn-deprecated-flags", Opt_WarnDeprecatedFlags, nop ), - ( "warn-orphans", Opt_WarnOrphans, nop ), - ( "warn-auto-orphans", Opt_WarnAutoOrphans, nop ), - ( "warn-tabs", Opt_WarnTabs, nop ), - ( "warn-unrecognised-pragmas", Opt_WarnUnrecognisedPragmas, nop ), - ( "warn-lazy-unlifted-bindings", Opt_WarnLazyUnliftedBindings, nop), - ( "warn-unused-do-bind", Opt_WarnUnusedDoBind, nop ), - ( "warn-wrong-do-bind", Opt_WarnWrongDoBind, nop ), - ( "warn-alternative-layout-rule-transitional", Opt_WarnAlternativeLayoutRuleTransitional, nop ), - ( "print-explicit-foralls", Opt_PrintExplicitForalls, nop ), - ( "strictness", Opt_Strictness, nop ), - ( "specialise", Opt_Specialise, nop ), - ( "float-in", Opt_FloatIn, nop ), - ( "static-argument-transformation", Opt_StaticArgumentTransformation, nop ), - ( "full-laziness", Opt_FullLaziness, nop ), - ( "liberate-case", Opt_LiberateCase, nop ), - ( "spec-constr", Opt_SpecConstr, nop ), - ( "cse", Opt_CSE, nop ), - ( "ignore-interface-pragmas", Opt_IgnoreInterfacePragmas, nop ), - ( "omit-interface-pragmas", Opt_OmitInterfacePragmas, nop ), - ( "expose-all-unfoldings", Opt_ExposeAllUnfoldings, nop ), - ( "do-lambda-eta-expansion", Opt_DoLambdaEtaExpansion, nop ), - ( "ignore-asserts", Opt_IgnoreAsserts, nop ), - ( "do-eta-reduction", Opt_DoEtaReduction, nop ), - ( "case-merge", Opt_CaseMerge, nop ), - ( "unbox-strict-fields", Opt_UnboxStrictFields, nop ), - ( "method-sharing", Opt_MethodSharing, nop ), - ( "dicts-cheap", Opt_DictsCheap, nop ), - ( "excess-precision", Opt_ExcessPrecision, nop ), - ( "eager-blackholing", Opt_EagerBlackHoling, nop ), - ( "asm-mangling", Opt_DoAsmMangling, nop ), - ( "print-bind-result", Opt_PrintBindResult, nop ), - ( "force-recomp", Opt_ForceRecomp, nop ), - ( "hpc-no-auto", Opt_Hpc_No_Auto, nop ), - ( "rewrite-rules", Opt_EnableRewriteRules, useInstead "enable-rewrite-rules" ), - ( "enable-rewrite-rules", Opt_EnableRewriteRules, nop ), - ( "break-on-exception", Opt_BreakOnException, nop ), - ( "break-on-error", Opt_BreakOnError, nop ), - ( "print-evld-with-show", Opt_PrintEvldWithShow, nop ), - ( "print-bind-contents", Opt_PrintBindContents, nop ), - ( "run-cps", Opt_RunCPS, nop ), - ( "run-cpsz", Opt_RunCPSZ, nop ), - ( "new-codegen", Opt_TryNewCodeGen, nop ), - ( "convert-to-zipper-and-back", Opt_ConvertToZipCfgAndBack, nop ), - ( "vectorise", Opt_Vectorise, nop ), - ( "regs-graph", Opt_RegsGraph, nop ), - ( "regs-iterative", Opt_RegsIterative, nop ), - ( "gen-manifest", Opt_GenManifest, nop ), - ( "embed-manifest", Opt_EmbedManifest, nop ), - ( "ext-core", Opt_EmitExternalCore, nop ), - ( "shared-implib", Opt_SharedImplib, nop ), - ( "ghci-sandbox", Opt_GhciSandbox, nop ), - ( "building-cabal-package", Opt_BuildingCabalPackage, nop ), - ( "implicit-import-qualified", Opt_ImplicitImportQualified, nop ) + ( "print-explicit-foralls", AlwaysAllowed, Opt_PrintExplicitForalls, nop ), + ( "strictness", AlwaysAllowed, Opt_Strictness, nop ), + ( "specialise", AlwaysAllowed, Opt_Specialise, nop ), + ( "float-in", AlwaysAllowed, Opt_FloatIn, nop ), + ( "static-argument-transformation", AlwaysAllowed, Opt_StaticArgumentTransformation, nop ), + ( "full-laziness", AlwaysAllowed, Opt_FullLaziness, nop ), + ( "liberate-case", AlwaysAllowed, Opt_LiberateCase, nop ), + ( "spec-constr", AlwaysAllowed, Opt_SpecConstr, nop ), + ( "cse", AlwaysAllowed, Opt_CSE, nop ), + ( "ignore-interface-pragmas", AlwaysAllowed, Opt_IgnoreInterfacePragmas, nop ), + ( "omit-interface-pragmas", AlwaysAllowed, Opt_OmitInterfacePragmas, nop ), + ( "expose-all-unfoldings", AlwaysAllowed, Opt_ExposeAllUnfoldings, nop ), + ( "do-lambda-eta-expansion", AlwaysAllowed, Opt_DoLambdaEtaExpansion, nop ), + ( "ignore-asserts", AlwaysAllowed, Opt_IgnoreAsserts, nop ), + ( "do-eta-reduction", AlwaysAllowed, Opt_DoEtaReduction, nop ), + ( "case-merge", AlwaysAllowed, Opt_CaseMerge, nop ), + ( "unbox-strict-fields", AlwaysAllowed, Opt_UnboxStrictFields, nop ), + ( "dicts-cheap", AlwaysAllowed, Opt_DictsCheap, nop ), + ( "excess-precision", AlwaysAllowed, Opt_ExcessPrecision, nop ), + ( "eager-blackholing", AlwaysAllowed, Opt_EagerBlackHoling, nop ), + ( "print-bind-result", AlwaysAllowed, Opt_PrintBindResult, nop ), + ( "force-recomp", AlwaysAllowed, Opt_ForceRecomp, nop ), + ( "hpc-no-auto", AlwaysAllowed, Opt_Hpc_No_Auto, nop ), + ( "rewrite-rules", AlwaysAllowed, Opt_EnableRewriteRules, useInstead "enable-rewrite-rules" ), + ( "enable-rewrite-rules", AlwaysAllowed, Opt_EnableRewriteRules, nop ), + ( "break-on-exception", AlwaysAllowed, Opt_BreakOnException, nop ), + ( "break-on-error", AlwaysAllowed, Opt_BreakOnError, nop ), + ( "print-evld-with-show", AlwaysAllowed, Opt_PrintEvldWithShow, nop ), + ( "print-bind-contents", AlwaysAllowed, Opt_PrintBindContents, nop ), + ( "run-cps", AlwaysAllowed, Opt_RunCPS, nop ), + ( "run-cpsz", AlwaysAllowed, Opt_RunCPSZ, nop ), + ( "new-codegen", AlwaysAllowed, Opt_TryNewCodeGen, nop ), + ( "convert-to-zipper-and-back", AlwaysAllowed, Opt_ConvertToZipCfgAndBack, nop ), + ( "vectorise", AlwaysAllowed, Opt_Vectorise, nop ), + ( "regs-graph", AlwaysAllowed, Opt_RegsGraph, nop ), + ( "regs-iterative", AlwaysAllowed, Opt_RegsIterative, nop ), + ( "gen-manifest", AlwaysAllowed, Opt_GenManifest, nop ), + ( "embed-manifest", AlwaysAllowed, Opt_EmbedManifest, nop ), + ( "ext-core", AlwaysAllowed, Opt_EmitExternalCore, nop ), + ( "shared-implib", AlwaysAllowed, Opt_SharedImplib, nop ), + ( "ghci-sandbox", AlwaysAllowed, Opt_GhciSandbox, nop ), + ( "helpful-errors", AlwaysAllowed, Opt_HelpfulErrors, nop ), + ( "building-cabal-package", AlwaysAllowed, Opt_BuildingCabalPackage, nop ), + ( "implicit-import-qualified", AlwaysAllowed, Opt_ImplicitImportQualified, nop ) ] -- | These @-f\@ flags can all be reversed with @-fno-\@ fLangFlags :: [FlagSpec ExtensionFlag] fLangFlags = [ - ( "th", Opt_TemplateHaskell, + ( "th", NeverAllowed, Opt_TemplateHaskell, deprecatedForExtension "TemplateHaskell" >> checkTemplateHaskellOk ), - ( "fi", Opt_ForeignFunctionInterface, + ( "fi", RestrictedFunction, Opt_ForeignFunctionInterface, deprecatedForExtension "ForeignFunctionInterface" ), - ( "ffi", Opt_ForeignFunctionInterface, + ( "ffi", RestrictedFunction, Opt_ForeignFunctionInterface, deprecatedForExtension "ForeignFunctionInterface" ), - ( "arrows", Opt_Arrows, + ( "arrows", AlwaysAllowed, Opt_Arrows, deprecatedForExtension "Arrows" ), - ( "generics", Opt_Generics, - deprecatedForExtension "Generics" ), - ( "implicit-prelude", Opt_ImplicitPrelude, + ( "implicit-prelude", AlwaysAllowed, Opt_ImplicitPrelude, deprecatedForExtension "ImplicitPrelude" ), - ( "bang-patterns", Opt_BangPatterns, + ( "bang-patterns", AlwaysAllowed, Opt_BangPatterns, deprecatedForExtension "BangPatterns" ), - ( "monomorphism-restriction", Opt_MonomorphismRestriction, + ( "monomorphism-restriction", AlwaysAllowed, Opt_MonomorphismRestriction, deprecatedForExtension "MonomorphismRestriction" ), - ( "mono-pat-binds", Opt_MonoPatBinds, + ( "mono-pat-binds", AlwaysAllowed, Opt_MonoPatBinds, deprecatedForExtension "MonoPatBinds" ), - ( "extended-default-rules", Opt_ExtendedDefaultRules, + ( "extended-default-rules", AlwaysAllowed, Opt_ExtendedDefaultRules, deprecatedForExtension "ExtendedDefaultRules" ), - ( "implicit-params", Opt_ImplicitParams, + ( "implicit-params", AlwaysAllowed, Opt_ImplicitParams, deprecatedForExtension "ImplicitParams" ), - ( "scoped-type-variables", Opt_ScopedTypeVariables, + ( "scoped-type-variables", AlwaysAllowed, Opt_ScopedTypeVariables, deprecatedForExtension "ScopedTypeVariables" ), - ( "parr", Opt_PArr, - deprecatedForExtension "PArr" ), - ( "allow-overlapping-instances", Opt_OverlappingInstances, + ( "parr", AlwaysAllowed, Opt_ParallelArrays, + deprecatedForExtension "ParallelArrays" ), + ( "PArr", AlwaysAllowed, Opt_ParallelArrays, + deprecatedForExtension "ParallelArrays" ), + ( "allow-overlapping-instances", RestrictedFunction, Opt_OverlappingInstances, deprecatedForExtension "OverlappingInstances" ), - ( "allow-undecidable-instances", Opt_UndecidableInstances, + ( "allow-undecidable-instances", AlwaysAllowed, Opt_UndecidableInstances, deprecatedForExtension "UndecidableInstances" ), - ( "allow-incoherent-instances", Opt_IncoherentInstances, + ( "allow-incoherent-instances", AlwaysAllowed, Opt_IncoherentInstances, deprecatedForExtension "IncoherentInstances" ) ] supportedLanguages :: [String] -supportedLanguages = [ name | (name, _, _) <- languageFlags ] +supportedLanguages = [ name | (name, _, _, _) <- languageFlags ] + +supportedLanguageOverlays :: [String] +supportedLanguageOverlays = [ name | (name, _, _, _) <- safeHaskellFlags ] supportedExtensions :: [String] -supportedExtensions = [ name' | (name, _, _) <- xFlags, name' <- [name, "No" ++ name] ] +supportedExtensions = [ name' | (name, _, _, _) <- xFlags, name' <- [name, "No" ++ name] ] supportedLanguagesAndExtensions :: [String] -supportedLanguagesAndExtensions = supportedLanguages ++ supportedExtensions +supportedLanguagesAndExtensions = + supportedLanguages ++ supportedLanguageOverlays ++ supportedExtensions -- | These -X flags cannot be reversed with -XNo languageFlags :: [FlagSpec Language] languageFlags = [ - ( "Haskell98", Haskell98, nop ), - ( "Haskell2010", Haskell2010, nop ) + ( "Haskell98", AlwaysAllowed, Haskell98, nop ), + ( "Haskell2010", AlwaysAllowed, Haskell2010, nop ) ] +-- | These -X flags cannot be reversed with -XNo +-- They are used to place hard requirements on what GHC Haskell language +-- features can be used. +safeHaskellFlags :: [FlagSpec SafeHaskellMode] +safeHaskellFlags = [mkF Sf_SafeImports, mkF Sf_Trustworthy, mkF' Sf_Safe] + where mkF flag = (showPpr flag, AlwaysAllowed, flag, nop) + mkF' flag = (showPpr flag, EnablesSafe, flag, nop) + -- | These -X flags can all be reversed with -XNo xFlags :: [FlagSpec ExtensionFlag] xFlags = [ - ( "CPP", Opt_Cpp, nop ), - ( "PostfixOperators", Opt_PostfixOperators, nop ), - ( "TupleSections", Opt_TupleSections, nop ), - ( "PatternGuards", Opt_PatternGuards, nop ), - ( "UnicodeSyntax", Opt_UnicodeSyntax, nop ), - ( "MagicHash", Opt_MagicHash, nop ), - ( "PolymorphicComponents", Opt_PolymorphicComponents, nop ), - ( "ExistentialQuantification", Opt_ExistentialQuantification, nop ), - ( "KindSignatures", Opt_KindSignatures, nop ), - ( "EmptyDataDecls", Opt_EmptyDataDecls, nop ), - ( "ParallelListComp", Opt_ParallelListComp, nop ), - ( "TransformListComp", Opt_TransformListComp, nop ), - ( "ForeignFunctionInterface", Opt_ForeignFunctionInterface, nop ), - ( "UnliftedFFITypes", Opt_UnliftedFFITypes, nop ), - ( "GHCForeignImportPrim", Opt_GHCForeignImportPrim, nop ), - ( "LiberalTypeSynonyms", Opt_LiberalTypeSynonyms, nop ), - ( "Rank2Types", Opt_Rank2Types, nop ), - ( "RankNTypes", Opt_RankNTypes, nop ), - ( "ImpredicativeTypes", Opt_ImpredicativeTypes, nop), - ( "TypeOperators", Opt_TypeOperators, nop ), - ( "RecursiveDo", Opt_RecursiveDo, + ( "CPP", AlwaysAllowed, Opt_Cpp, nop ), + ( "PostfixOperators", AlwaysAllowed, Opt_PostfixOperators, nop ), + ( "TupleSections", AlwaysAllowed, Opt_TupleSections, nop ), + ( "PatternGuards", AlwaysAllowed, Opt_PatternGuards, nop ), + ( "UnicodeSyntax", AlwaysAllowed, Opt_UnicodeSyntax, nop ), + ( "MagicHash", AlwaysAllowed, Opt_MagicHash, nop ), + ( "PolymorphicComponents", AlwaysAllowed, Opt_PolymorphicComponents, nop ), + ( "ExistentialQuantification", AlwaysAllowed, Opt_ExistentialQuantification, nop ), + ( "KindSignatures", AlwaysAllowed, Opt_KindSignatures, nop ), + ( "EmptyDataDecls", AlwaysAllowed, Opt_EmptyDataDecls, nop ), + ( "ParallelListComp", AlwaysAllowed, Opt_ParallelListComp, nop ), + ( "TransformListComp", AlwaysAllowed, Opt_TransformListComp, nop ), + ( "MonadComprehensions", AlwaysAllowed, Opt_MonadComprehensions, nop), + ( "ForeignFunctionInterface", RestrictedFunction, Opt_ForeignFunctionInterface, nop ), + ( "UnliftedFFITypes", AlwaysAllowed, Opt_UnliftedFFITypes, nop ), + ( "InterruptibleFFI", AlwaysAllowed, Opt_InterruptibleFFI, nop ), + ( "GHCForeignImportPrim", AlwaysAllowed, Opt_GHCForeignImportPrim, nop ), + ( "LiberalTypeSynonyms", AlwaysAllowed, Opt_LiberalTypeSynonyms, nop ), + ( "Rank2Types", AlwaysAllowed, Opt_Rank2Types, nop ), + ( "RankNTypes", AlwaysAllowed, Opt_RankNTypes, nop ), + ( "ImpredicativeTypes", AlwaysAllowed, Opt_ImpredicativeTypes, nop), + ( "TypeOperators", AlwaysAllowed, Opt_TypeOperators, nop ), + ( "RecursiveDo", AlwaysAllowed, Opt_RecursiveDo, -- Enables 'mdo' deprecatedForExtension "DoRec"), - ( "DoRec", Opt_DoRec, nop ), - ( "Arrows", Opt_Arrows, nop ), - ( "PArr", Opt_PArr, nop ), - ( "TemplateHaskell", Opt_TemplateHaskell, checkTemplateHaskellOk ), - ( "QuasiQuotes", Opt_QuasiQuotes, nop ), - ( "Generics", Opt_Generics, nop ), - ( "ImplicitPrelude", Opt_ImplicitPrelude, nop ), - ( "RecordWildCards", Opt_RecordWildCards, nop ), - ( "NamedFieldPuns", Opt_RecordPuns, nop ), - ( "RecordPuns", Opt_RecordPuns, + ( "DoRec", AlwaysAllowed, Opt_DoRec, nop ), -- Enables 'rec' keyword + ( "Arrows", AlwaysAllowed, Opt_Arrows, nop ), + ( "ParallelArrays", AlwaysAllowed, Opt_ParallelArrays, nop ), + ( "TemplateHaskell", NeverAllowed, Opt_TemplateHaskell, checkTemplateHaskellOk ), + ( "QuasiQuotes", AlwaysAllowed, Opt_QuasiQuotes, nop ), + ( "ImplicitPrelude", AlwaysAllowed, Opt_ImplicitPrelude, nop ), + ( "RecordWildCards", AlwaysAllowed, Opt_RecordWildCards, nop ), + ( "NamedFieldPuns", AlwaysAllowed, Opt_RecordPuns, nop ), + ( "RecordPuns", AlwaysAllowed, Opt_RecordPuns, deprecatedForExtension "NamedFieldPuns" ), - ( "DisambiguateRecordFields", Opt_DisambiguateRecordFields, nop ), - ( "OverloadedStrings", Opt_OverloadedStrings, nop ), - ( "GADTs", Opt_GADTs, nop ), - ( "ViewPatterns", Opt_ViewPatterns, nop ), - ( "TypeFamilies", Opt_TypeFamilies, nop ), - ( "BangPatterns", Opt_BangPatterns, nop ), - ( "MonomorphismRestriction", Opt_MonomorphismRestriction, nop ), - ( "NPlusKPatterns", Opt_NPlusKPatterns, nop ), - ( "DoAndIfThenElse", Opt_DoAndIfThenElse, nop ), - ( "RebindableSyntax", Opt_RebindableSyntax, nop ), - ( "MonoPatBinds", Opt_MonoPatBinds, nop ), - ( "ExplicitForAll", Opt_ExplicitForAll, nop ), - ( "AlternativeLayoutRule", Opt_AlternativeLayoutRule, nop ), - ( "AlternativeLayoutRuleTransitional",Opt_AlternativeLayoutRuleTransitional, nop ), - ( "DatatypeContexts", Opt_DatatypeContexts, nop ), - ( "MonoLocalBinds", Opt_MonoLocalBinds, nop ), - ( "RelaxedPolyRec", Opt_RelaxedPolyRec, + ( "DisambiguateRecordFields", AlwaysAllowed, Opt_DisambiguateRecordFields, nop ), + ( "OverloadedStrings", AlwaysAllowed, Opt_OverloadedStrings, nop ), + ( "GADTs", AlwaysAllowed, Opt_GADTs, nop ), + ( "GADTSyntax", AlwaysAllowed, Opt_GADTSyntax, nop ), + ( "ViewPatterns", AlwaysAllowed, Opt_ViewPatterns, nop ), + ( "TypeFamilies", AlwaysAllowed, Opt_TypeFamilies, nop ), + ( "BangPatterns", AlwaysAllowed, Opt_BangPatterns, nop ), + ( "MonomorphismRestriction", AlwaysAllowed, Opt_MonomorphismRestriction, nop ), + ( "NPlusKPatterns", AlwaysAllowed, Opt_NPlusKPatterns, nop ), + ( "DoAndIfThenElse", AlwaysAllowed, Opt_DoAndIfThenElse, nop ), + ( "RebindableSyntax", AlwaysAllowed, Opt_RebindableSyntax, nop ), + ( "MonoPatBinds", AlwaysAllowed, Opt_MonoPatBinds, nop ), + ( "ExplicitForAll", AlwaysAllowed, Opt_ExplicitForAll, nop ), + ( "AlternativeLayoutRule", AlwaysAllowed, Opt_AlternativeLayoutRule, nop ), + ( "AlternativeLayoutRuleTransitional",AlwaysAllowed, Opt_AlternativeLayoutRuleTransitional, nop ), + ( "DatatypeContexts", AlwaysAllowed, Opt_DatatypeContexts, + \ turn_on -> when turn_on $ deprecate "It was widely considered a misfeature, and has been removed from the Haskell language." ), + ( "NondecreasingIndentation", AlwaysAllowed, Opt_NondecreasingIndentation, nop ), + ( "RelaxedLayout", AlwaysAllowed, Opt_RelaxedLayout, nop ), + ( "MonoLocalBinds", AlwaysAllowed, Opt_MonoLocalBinds, nop ), + ( "RelaxedPolyRec", AlwaysAllowed, Opt_RelaxedPolyRec, \ turn_on -> if not turn_on then deprecate "You can't turn off RelaxedPolyRec any more" else return () ), - ( "ExtendedDefaultRules", Opt_ExtendedDefaultRules, nop ), - ( "ImplicitParams", Opt_ImplicitParams, nop ), - ( "ScopedTypeVariables", Opt_ScopedTypeVariables, nop ), + ( "ExtendedDefaultRules", AlwaysAllowed, Opt_ExtendedDefaultRules, nop ), + ( "ImplicitParams", AlwaysAllowed, Opt_ImplicitParams, nop ), + ( "ScopedTypeVariables", AlwaysAllowed, Opt_ScopedTypeVariables, nop ), - ( "PatternSignatures", Opt_ScopedTypeVariables, + ( "PatternSignatures", AlwaysAllowed, Opt_ScopedTypeVariables, deprecatedForExtension "ScopedTypeVariables" ), - ( "UnboxedTuples", Opt_UnboxedTuples, nop ), - ( "StandaloneDeriving", Opt_StandaloneDeriving, nop ), - ( "DeriveDataTypeable", Opt_DeriveDataTypeable, nop ), - ( "DeriveFunctor", Opt_DeriveFunctor, nop ), - ( "DeriveTraversable", Opt_DeriveTraversable, nop ), - ( "DeriveFoldable", Opt_DeriveFoldable, nop ), - ( "TypeSynonymInstances", Opt_TypeSynonymInstances, nop ), - ( "FlexibleContexts", Opt_FlexibleContexts, nop ), - ( "FlexibleInstances", Opt_FlexibleInstances, nop ), - ( "ConstrainedClassMethods", Opt_ConstrainedClassMethods, nop ), - ( "MultiParamTypeClasses", Opt_MultiParamTypeClasses, nop ), - ( "FunctionalDependencies", Opt_FunctionalDependencies, nop ), - ( "GeneralizedNewtypeDeriving", Opt_GeneralizedNewtypeDeriving, nop ), - ( "OverlappingInstances", Opt_OverlappingInstances, nop ), - ( "UndecidableInstances", Opt_UndecidableInstances, nop ), - ( "IncoherentInstances", Opt_IncoherentInstances, nop ), - ( "PackageImports", Opt_PackageImports, nop ), - ( "NewQualifiedOperators", Opt_NewQualifiedOperators, - \_ -> deprecate "The new qualified operator syntax was rejected by Haskell'" ) + ( "UnboxedTuples", AlwaysAllowed, Opt_UnboxedTuples, nop ), + ( "StandaloneDeriving", AlwaysAllowed, Opt_StandaloneDeriving, nop ), + ( "DeriveDataTypeable", AlwaysAllowed, Opt_DeriveDataTypeable, nop ), + ( "DeriveFunctor", AlwaysAllowed, Opt_DeriveFunctor, nop ), + ( "DeriveTraversable", AlwaysAllowed, Opt_DeriveTraversable, nop ), + ( "DeriveFoldable", AlwaysAllowed, Opt_DeriveFoldable, nop ), + ( "DeriveGeneric", AlwaysAllowed, Opt_DeriveGeneric, nop ), + ( "DefaultSignatures", AlwaysAllowed, Opt_DefaultSignatures, nop ), + ( "TypeSynonymInstances", AlwaysAllowed, Opt_TypeSynonymInstances, nop ), + ( "FlexibleContexts", AlwaysAllowed, Opt_FlexibleContexts, nop ), + ( "FlexibleInstances", AlwaysAllowed, Opt_FlexibleInstances, nop ), + ( "ConstrainedClassMethods", AlwaysAllowed, Opt_ConstrainedClassMethods, nop ), + ( "MultiParamTypeClasses", AlwaysAllowed, Opt_MultiParamTypeClasses, nop ), + ( "FunctionalDependencies", AlwaysAllowed, Opt_FunctionalDependencies, nop ), + ( "GeneralizedNewtypeDeriving", AlwaysAllowed, Opt_GeneralizedNewtypeDeriving, nop ), + ( "OverlappingInstances", RestrictedFunction, Opt_OverlappingInstances, nop ), + ( "UndecidableInstances", AlwaysAllowed, Opt_UndecidableInstances, nop ), + ( "IncoherentInstances", AlwaysAllowed, Opt_IncoherentInstances, nop ), + ( "PackageImports", AlwaysAllowed, Opt_PackageImports, nop ) ] defaultFlags :: [DynFlag] @@ -1622,23 +1909,22 @@ = [ Opt_AutoLinkPackages, Opt_ReadUserPackageConf, - Opt_MethodSharing, - - Opt_DoAsmMangling, - Opt_SharedImplib, +#if GHC_DEFAULT_NEW_CODEGEN + Opt_TryNewCodeGen, +#endif + Opt_GenManifest, Opt_EmbedManifest, Opt_PrintBindContents, - Opt_GhciSandbox + Opt_GhciSandbox, + Opt_HelpfulErrors ] ++ [f | (ns,f) <- optLevelFlags, 0 `elem` ns] -- The default -O0 options - ++ standardWarnings - impliedFlags :: [(ExtensionFlag, TurnOnFlag, ExtensionFlag)] impliedFlags = [ (Opt_RankNTypes, turnOn, Opt_ExplicitForAll) @@ -1647,9 +1933,12 @@ , (Opt_LiberalTypeSynonyms, turnOn, Opt_ExplicitForAll) , (Opt_ExistentialQuantification, turnOn, Opt_ExplicitForAll) , (Opt_PolymorphicComponents, turnOn, Opt_ExplicitForAll) + , (Opt_FlexibleInstances, turnOn, Opt_TypeSynonymInstances) + , (Opt_FunctionalDependencies, turnOn, Opt_MultiParamTypeClasses) , (Opt_RebindableSyntax, turnOff, Opt_ImplicitPrelude) -- NB: turn off! + , (Opt_GADTs, turnOn, Opt_GADTSyntax) , (Opt_GADTs, turnOn, Opt_MonoLocalBinds) , (Opt_TypeFamilies, turnOn, Opt_MonoLocalBinds) @@ -1663,6 +1952,8 @@ -- stuff like " 'a' not in scope ", which is a bit silly -- if the compiler has just filled in field 'a' of constructor 'C' , (Opt_RecordWildCards, turnOn, Opt_DisambiguateRecordFields) + + , (Opt_ParallelArrays, turnOn, Opt_ParallelListComp) ] optLevelFlags :: [([Int], DynFlag)] @@ -1705,7 +1996,7 @@ -- ----------------------------------------------------------------------------- -- Standard sets of warning options -standardWarnings :: [DynFlag] +standardWarnings :: [WarningFlag] standardWarnings = [ Opt_WarnWarningsDeprecations, Opt_WarnDeprecatedFlags, @@ -1720,7 +2011,8 @@ Opt_WarnAlternativeLayoutRuleTransitional ] -minusWOpts :: [DynFlag] +minusWOpts :: [WarningFlag] +-- Things you get with -W minusWOpts = standardWarnings ++ [ Opt_WarnUnusedBinds, @@ -1731,7 +2023,8 @@ Opt_WarnDodgyImports ] -minusWallOpts :: [DynFlag] +minusWallOpts :: [WarningFlag] +-- Things you get with -Wall minusWallOpts = minusWOpts ++ [ Opt_WarnTypeDefaults, @@ -1742,18 +2035,6 @@ Opt_WarnUnusedDoBind ] --- minuswRemovesOpts should be every warning option -minuswRemovesOpts :: [DynFlag] -minuswRemovesOpts - = minusWallOpts ++ - [Opt_WarnImplicitPrelude, - Opt_WarnIncompletePatternsRecUpd, - Opt_WarnMonomorphism, - Opt_WarnUnrecognisedPragmas, - Opt_WarnAutoOrphans, - Opt_WarnTabs - ] - enableGlasgowExts :: DynP () enableGlasgowExts = do setDynFlag Opt_PrintExplicitForalls mapM_ setExtensionFlag glasgowExtsFlags @@ -1775,6 +2056,7 @@ , Opt_DeriveFunctor , Opt_DeriveFoldable , Opt_DeriveTraversable + , Opt_DeriveGeneric , Opt_FlexibleContexts , Opt_FlexibleInstances , Opt_ConstrainedClassMethods @@ -1802,18 +2084,20 @@ 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 {- ********************************************************************** @@ -1825,13 +2109,21 @@ type DynP = EwM (CmdLineP DynFlags) upd :: (DynFlags -> DynFlags) -> DynP () -upd f = liftEwM (do { dfs <- getCmdLineState - ; putCmdLineState $! (f dfs) }) +upd f = liftEwM (do dflags <- getCmdLineState + putCmdLineState $! f dflags) + +updM :: (DynFlags -> DynP DynFlags) -> DynP () +updM f = do dflags <- liftEwM getCmdLineState + dflags' <- f dflags + liftEwM $ putCmdLineState $! dflags' --------------- Constructor functions for OptKind ----------------- noArg :: (DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) noArg fn = NoArg (upd fn) +noArgM :: (DynFlags -> DynP DynFlags) -> OptKind (CmdLineP DynFlags) +noArgM fn = NoArg (updM fn) + noArgDF :: (DynFlags -> DynFlags) -> String -> OptKind (CmdLineP DynFlags) noArgDF fn deprec = NoArg (upd fn >> deprecate deprec) @@ -1842,9 +2134,16 @@ hasArgDF fn deprec = HasArg (\s -> do { upd (fn s) ; deprecate deprec }) +sepArg :: (String -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) +sepArg fn = SepArg (upd . fn) + intSuffix :: (Int -> DynFlags -> DynFlags) -> OptKind (CmdLineP DynFlags) intSuffix fn = IntSuffix (\n -> upd (fn n)) +optIntSuffixM :: (Maybe Int -> DynFlags -> DynP DynFlags) + -> OptKind (CmdLineP DynFlags) +optIntSuffixM fn = OptIntSuffix (\mi -> updM (fn mi)) + setDumpFlag :: DynFlag -> OptKind (CmdLineP DynFlags) setDumpFlag dump_flag = NoArg (setDumpFlag' dump_flag) @@ -1854,6 +2153,11 @@ unSetDynFlag f = upd (\dfs -> dopt_unset dfs f) -------------------------- +setWarningFlag, unSetWarningFlag :: WarningFlag -> DynP () +setWarningFlag f = upd (\dfs -> wopt_set dfs f) +unSetWarningFlag f = upd (\dfs -> wopt_unset dfs f) + +-------------------------- setExtensionFlag, unSetExtensionFlag :: ExtensionFlag -> DynP () setExtensionFlag f = do { upd (\dfs -> xopt_set dfs f) ; sequence_ deps } @@ -1870,6 +2174,10 @@ -- (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 @@ -1888,14 +2196,13 @@ -- recompiled which probably isn't what you want forceRecompile = do { dfs <- liftEwM getCmdLineState ; when (force_recomp dfs) (setDynFlag Opt_ForceRecomp) } - where + where force_recomp dfs = isOneShot (ghcMode dfs) setVerboseCore2Core :: DynP () setVerboseCore2Core = do forceRecompile setDynFlag Opt_D_verbose_core2core upd (\dfs -> dfs { shouldDumpSimplPhase = Nothing }) - setDumpSimplPhases :: String -> DynP () setDumpSimplPhases s = do forceRecompile @@ -1912,7 +2219,8 @@ extraPkgConf_ :: FilePath -> DynP () extraPkgConf_ p = upd (\s -> s{ extraPkgConfs = p : extraPkgConfs s }) -exposePackage, exposePackageId, hidePackage, ignorePackage :: String -> DynP () +exposePackage, exposePackageId, hidePackage, ignorePackage, + trustPackage, distrustPackage :: String -> DynP () exposePackage p = upd (\s -> s{ packageFlags = ExposePackage p : packageFlags s }) exposePackageId p = @@ -1921,6 +2229,10 @@ upd (\s -> s{ packageFlags = HidePackage p : packageFlags s }) ignorePackage p = upd (\s -> s{ packageFlags = IgnorePackage p : packageFlags s }) +trustPackage p = exposePackage p >> -- both trust and distrust also expose a package + upd (\s -> s{ packageFlags = TrustPackage p : packageFlags s }) +distrustPackage p = exposePackage p >> + upd (\s -> s{ packageFlags = DistrustPackage p : packageFlags s }) setPackageName :: String -> DynFlags -> DynFlags setPackageName p s = s{ thisPackage = stringToPackageId p } @@ -1935,68 +2247,79 @@ | otherwise = dfs -- Changes the target only if we're compiling object code. This is --- used by -fasm and -fvia-C, which switch from one to the other, but --- not from bytecode to object-code. The idea is that -fasm/-fvia-C +-- used by -fasm and -fllvm, which switch from one to the other, but +-- not from bytecode to object-code. The idea is that -fasm/-fllvm -- can be safely used in an OPTIONS_GHC pragma. setObjTarget :: HscTarget -> DynP () -setObjTarget l = upd set +setObjTarget l = updM set where - set dfs - | isObjectTarget (hscTarget dfs) = dfs { hscTarget = l } - | otherwise = dfs + set dflags + | isObjectTarget (hscTarget dflags) + = case l of + HscC + | cGhcUnregisterised /= "YES" -> + do addWarn ("Compiler not unregisterised, so ignoring " ++ flag) + return dflags + HscAsm + | cGhcWithNativeCodeGen /= "YES" -> + do addWarn ("Compiler has no native codegen, so ignoring " ++ + flag) + return dflags + HscLlvm + | not ((arch == ArchX86_64) && (os == OSLinux || os == OSDarwin)) && + (not opt_Static || opt_PIC) + -> + do addWarn ("Ignoring " ++ flag ++ " as it is incompatible with -fPIC and -dynamic on this platform") + return dflags + _ -> return $ dflags { hscTarget = l } + | otherwise = return dflags + where platform = targetPlatform dflags + arch = platformArch platform + os = platformOS platform + flag = showHscTargetFlag l -setOptLevel :: Int -> DynFlags -> DynFlags +setOptLevel :: Int -> DynFlags -> DynP DynFlags setOptLevel n dflags | hscTarget dflags == HscInterpreted && n > 0 - = dflags - -- not in IO any more, oh well: - -- putStr "warning: -O conflicts with --interactive; -O ignored.\n" + = do addWarn "-O conflicts with --interactive; -O ignored." + return dflags | otherwise - = updOptLevel n dflags + = return (updOptLevel n dflags) -- -Odph is equivalent to -- -- -O2 optimise as much as possible --- -fno-method-sharing sharing specialisation defeats fusion --- sometimes --- -fdicts-cheap always inline dictionaries -- -fmax-simplifier-iterations20 this is necessary sometimes --- -fsimplifier-phases=3 we use an additional simplifier phase --- for fusion --- -fno-spec-constr-threshold run SpecConstr even for big loops --- -fno-spec-constr-count SpecConstr as much as possible --- -finline-enough-args hack to prevent excessive inlining +-- -fsimplifier-phases=3 we use an additional simplifier phase for fusion -- -setDPHOpt :: DynFlags -> DynFlags +setDPHOpt :: DynFlags -> DynP DynFlags setDPHOpt dflags = setOptLevel 2 (dflags { maxSimplIterations = 20 , simplPhases = 3 - , specConstrThreshold = Nothing - , specConstrCount = Nothing }) - `dopt_set` Opt_DictsCheap - `dopt_unset` Opt_MethodSharing -data DPHBackend = DPHPar - | DPHSeq - | DPHThis +-- Determines the package used by the vectoriser for the symbols of the vectorised code. +-- 'DPHNone' indicates that no data-parallel backend library is available; hence, the +-- vectoriser cannot be used. +-- +data DPHBackend = DPHPar -- "dph-par" + | DPHSeq -- "dph-seq" + | DPHThis -- the currently compiled package + | DPHNone -- no DPH library available deriving(Eq, Ord, Enum, Show) setDPHBackend :: DPHBackend -> DynP () -setDPHBackend backend - = do - upd $ \dflags -> dflags { dphBackend = backend } - mapM_ exposePackage (dph_packages backend) - where - dph_packages DPHThis = [] - dph_packages DPHPar = ["dph-prim-par", "dph-par"] - dph_packages DPHSeq = ["dph-prim-seq", "dph-seq"] - -dphPackage :: DynFlags -> PackageId -dphPackage dflags = case dphBackend dflags of - DPHPar -> dphParPackageId - DPHSeq -> dphSeqPackageId - DPHThis -> thisPackage dflags +setDPHBackend backend = upd $ \dflags -> dflags { dphBackend = backend } + +-- Query the DPH backend package to be used by the vectoriser and desugaring of DPH syntax. +-- +dphPackageMaybe :: DynFlags -> Maybe PackageId +dphPackageMaybe dflags + = case dphBackend dflags of + DPHPar -> Just dphParPackageId + DPHSeq -> Just dphSeqPackageId + DPHThis -> Just (thisPackage dflags) + DPHNone -> Nothing setMainIs :: String -> DynP () setMainIs arg @@ -2022,7 +2345,6 @@ addImportPath "" = upd (\s -> s{importPaths = []}) addImportPath p = upd (\s -> s{importPaths = importPaths s ++ splitPathList p}) - addLibraryPath p = upd (\s -> s{libraryPaths = libraryPaths s ++ splitPathList p}) @@ -2093,7 +2415,7 @@ -- 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 @@ -2118,103 +2440,14 @@ -- 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 - [String]) -- for registerised HC compilations -machdepCCOpts dflags = let (flagsAll, flagsRegHc) = machdepCCOpts' dflags - in (cCcOpts ++ flagsAll, flagsRegHc) - -machdepCCOpts' :: DynFlags -> ([String], -- flags for all C compilations - [String]) -- for registerised HC compilations -machdepCCOpts' _dflags -#if alpha_TARGET_ARCH - = ( ["-w", "-mieee" -#ifdef HAVE_THREADED_RTS_SUPPORT - , "-D_REENTRANT" -#endif - ], [] ) - -- For now, to suppress the gcc warning "call-clobbered - -- register used for global register variable", we simply - -- disable all warnings altogether using the -w flag. Oh well. - -#elif hppa_TARGET_ARCH - -- ___HPUX_SOURCE, not _HPUX_SOURCE, is #defined if -ansi! - -- (very nice, but too bad the HP /usr/include files don't agree.) - = ( ["-D_HPUX_SOURCE"], [] ) - -#elif m68k_TARGET_ARCH - -- -fno-defer-pop : for the .hc files, we want all the pushing/ - -- popping of args to routines to be explicit; if we let things - -- be deferred 'til after an STGJUMP, imminent death is certain! - -- - -- -fomit-frame-pointer : *don't* - -- It's better to have a6 completely tied up being a frame pointer - -- rather than let GCC pick random things to do with it. - -- (If we want to steal a6, then we would try to do things - -- as on iX86, where we *do* steal the frame pointer [%ebp].) - = ( [], ["-fno-defer-pop", "-fno-omit-frame-pointer"] ) - -#elif i386_TARGET_ARCH - -- -fno-defer-pop : basically the same game as for m68k - -- - -- -fomit-frame-pointer : *must* in .hc files; because we're stealing - -- the fp (%ebp) for our register maps. - = let n_regs = stolen_x86_regs _dflags - in - ( - [ if opt_Static then "-DDONT_WANT_WIN32_DLL_SUPPORT" else "" - ], - [ "-fno-defer-pop", - "-fomit-frame-pointer", - -- we want -fno-builtin, because when gcc inlines - -- built-in functions like memcpy() it tends to - -- run out of registers, requiring -monly-n-regs - "-fno-builtin", - "-DSTOLEN_X86_REGS="++show n_regs ] - ) - -#elif ia64_TARGET_ARCH - = ( [], ["-fomit-frame-pointer", "-G0"] ) - -#elif x86_64_TARGET_ARCH - = ( - [], - ["-fomit-frame-pointer", - "-fno-asynchronous-unwind-tables", - -- the unwind tables are unnecessary for HC code, - -- and get in the way of -split-objs. Another option - -- would be to throw them away in the mangler, but this - -- is easier. - "-fno-builtin" - -- calling builtins like strlen() using the FFI can - -- cause gcc to run out of regs, so use the external - -- version. - ] ) - -#elif sparc_TARGET_ARCH - = ( [], ["-w"] ) - -- For now, to suppress the gcc warning "call-clobbered - -- register used for global register variable", we simply - -- disable all warnings altogether using the -w flag. Oh well. - -#elif powerpc_apple_darwin_TARGET - -- -no-cpp-precomp: - -- Disable Apple's precompiling preprocessor. It's a great thing - -- for "normal" programs, but it doesn't support register variable - -- declarations. - = ( [], ["-no-cpp-precomp"] ) -#else - = ( [], [] ) -#endif - picCCOpts :: DynFlags -> [String] picCCOpts _dflags #if darwin_TARGET_OS @@ -2252,36 +2485,39 @@ -- Splitting can_split :: Bool -can_split = cSplitObjs == "YES" +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 cBuildPlatform), - ("Host platform", String cHostPlatform), - ("Target platform", String cTargetPlatform), - ("Have interpreter", String cGhcWithInterpreter), - ("Object splitting", String cSplitObjs), - ("Have native code generator", String cGhcWithNativeCodeGen), - ("Have llvm code generator", String cGhcWithLlvmCodeGen), - ("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), + ("Gcc Linker flags", show cGccLinkerOpts), + ("Ld Linker flags", show cLdLinkerOpts) + ] diff -Nru ghc-7.0.3/compiler/main/ErrUtils.lhs ghc-7.2.1/compiler/main/ErrUtils.lhs --- ghc-7.0.3/compiler/main/ErrUtils.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/main/ErrUtils.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -13,7 +13,7 @@ errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo, Messages, errorsFound, emptyMessages, mkErrMsg, mkPlainErrMsg, mkLongErrMsg, mkWarnMsg, mkPlainWarnMsg, - printErrorsAndWarnings, printBagOfErrors, printBagOfWarnings, + printBagOfErrors, printBagOfWarnings, warnIsErrorMsg, mkLongWarnMsg, ghcExit, @@ -24,7 +24,7 @@ -- * Messages during compilation putMsg, putMsgWith, errorMsg, - fatalErrorMsg, + fatalErrorMsg, fatalErrorMsg', compilationProgressMsg, showPass, debugTraceMsg, @@ -36,12 +36,14 @@ import Util ( sortLe ) import Outputable import SrcLoc -import DynFlags ( DynFlags(..), DynFlag(..), dopt ) +import DynFlags import StaticFlags ( opt_ErrorSpans ) -import Control.Monad import System.Exit ( ExitCode(..), exitWith ) import Data.List +import qualified Data.Set as Set +import Data.IORef +import Control.Monad import System.IO -- ----------------------------------------------------------------------------- @@ -68,7 +70,8 @@ -- would look strange. Better to say explicitly "". printError :: SrcSpan -> Message -> IO () -printError span msg = printErrs (mkLocMessage span msg $ defaultErrStyle) +printError span msg = + printErrs (mkLocMessage span msg) defaultErrStyle -- ----------------------------------------------------------------------------- @@ -126,56 +129,29 @@ emptyMessages = (emptyBag, emptyBag) warnIsErrorMsg :: ErrMsg -warnIsErrorMsg = mkPlainErrMsg noSrcSpan (text "\nFailing due to -Werror.\n") +warnIsErrorMsg = mkPlainErrMsg noSrcSpan (text "\nFailing due to -Werror.") errorsFound :: DynFlags -> Messages -> Bool --- The dyn-flags are used to see if the user has specified --- -Werror, which says that warnings should be fatal -errorsFound dflags (warns, errs) - | dopt Opt_WarnIsError dflags = not (isEmptyBag errs) || not (isEmptyBag warns) - | otherwise = not (isEmptyBag errs) - -printErrorsAndWarnings :: DynFlags -> Messages -> IO () -printErrorsAndWarnings dflags (warns, errs) - | no_errs && no_warns = return () - | no_errs = do printBagOfWarnings dflags warns - when (dopt Opt_WarnIsError dflags) $ - errorMsg dflags $ - text "\nFailing due to -Werror.\n" - -- Don't print any warnings if there are errors - | otherwise = printBagOfErrors dflags errs - where - no_warns = isEmptyBag warns - no_errs = isEmptyBag errs +errorsFound _dflags (_warns, errs) = not (isEmptyBag errs) printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO () -printBagOfErrors dflags bag_of_errors - = sequence_ [ let style = mkErrStyle unqual - in log_action dflags SevError s style (d $$ e) - | ErrMsg { errMsgSpans = s:_, - errMsgShortDoc = d, - errMsgExtraInfo = e, - errMsgContext = unqual } <- sorted_errs ] - where - bag_ls = bagToList bag_of_errors - sorted_errs = sortLe occ'ed_before bag_ls +printBagOfErrors dflags bag_of_errors = + printMsgBag dflags bag_of_errors SevError - occ'ed_before err1 err2 = - case compare (head (errMsgSpans err1)) (head (errMsgSpans err2)) of - LT -> True - EQ -> True - GT -> False +printBagOfWarnings :: DynFlags -> Bag WarnMsg -> IO () +printBagOfWarnings dflags bag_of_warns = + printMsgBag dflags bag_of_warns SevWarning -printBagOfWarnings :: DynFlags -> Bag ErrMsg -> IO () -printBagOfWarnings dflags bag_of_warns +printMsgBag :: DynFlags -> Bag ErrMsg -> Severity -> IO () +printMsgBag dflags bag sev = sequence_ [ let style = mkErrStyle unqual - in log_action dflags SevWarning s style (d $$ e) + in log_action dflags sev s style (d $$ e) | ErrMsg { errMsgSpans = s:_, errMsgShortDoc = d, errMsgExtraInfo = e, errMsgContext = unqual } <- sorted_errs ] where - bag_ls = bagToList bag_of_warns + bag_ls = bagToList bag sorted_errs = sortLe occ'ed_before bag_ls occ'ed_before err1 err2 = @@ -214,11 +190,11 @@ = return () dumpIfSet_dyn_or :: DynFlags -> [DynFlag] -> String -> SDoc -> IO () -dumpIfSet_dyn_or dflags flags hdr doc - | or [dopt flag dflags | flag <- flags] - || verbosity dflags >= 4 - = printDump (mkDumpDoc hdr doc) - | otherwise = return () +dumpIfSet_dyn_or _ [] _ _ = return () +dumpIfSet_dyn_or dflags (flag : flags) hdr doc + = if dopt flag dflags || verbosity dflags >= 4 + then dumpSDoc dflags flag hdr doc + else dumpIfSet_dyn_or dflags flags hdr doc mkDumpDoc :: String -> SDoc -> SDoc mkDumpDoc hdr doc @@ -235,19 +211,26 @@ -- otherwise emit to stdout. dumpSDoc :: DynFlags -> DynFlag -> String -> SDoc -> IO () dumpSDoc dflags dflag hdr doc - = do let mFile = chooseDumpFile dflags dflag - case mFile of - -- write the dump to a file - -- don't add the header in this case, we can see what kind - -- of dump it is from the filename. - Just fileName - -> do handle <- openFile fileName AppendMode - hPrintDump handle doc - hClose handle - - -- write the dump to stdout - Nothing - -> do printDump (mkDumpDoc hdr doc) + = do let mFile = chooseDumpFile dflags dflag + case mFile of + -- write the dump to a file + -- don't add the header in this case, we can see what kind + -- of dump it is from the filename. + Just fileName + -> do + let gdref = generatedDumps dflags + gd <- readIORef gdref + let append = Set.member fileName gd + mode = if append then AppendMode else WriteMode + when (not append) $ + writeIORef gdref (Set.insert fileName gd) + handle <- openFile fileName mode + hPrintDump handle doc + hClose handle + + -- write the dump to stdout + Nothing + -> printDump (mkDumpDoc hdr doc) -- | Choose where to put a dump file based on DynFlags @@ -313,7 +296,10 @@ errorMsg dflags msg = log_action dflags SevError noSrcSpan defaultErrStyle msg fatalErrorMsg :: DynFlags -> Message -> IO () -fatalErrorMsg dflags msg = log_action dflags SevFatal noSrcSpan defaultErrStyle msg +fatalErrorMsg dflags msg = fatalErrorMsg' (log_action dflags) msg + +fatalErrorMsg' :: LogAction -> Message -> IO () +fatalErrorMsg' la msg = la SevFatal noSrcSpan defaultErrStyle msg compilationProgressMsg :: DynFlags -> String -> IO () compilationProgressMsg dflags msg @@ -326,5 +312,4 @@ debugTraceMsg :: DynFlags -> Int -> Message -> IO () debugTraceMsg dflags val msg = ifVerbose dflags val (log_action dflags SevInfo noSrcSpan defaultDumpStyle msg) - \end{code} diff -Nru ghc-7.0.3/compiler/main/Finder.lhs ghc-7.2.1/compiler/main/Finder.lhs --- ghc-7.0.3/compiler/main/Finder.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/main/Finder.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -26,6 +26,8 @@ ) where +#include "HsVersions.h" + import Module import HscTypes import Packages @@ -35,20 +37,21 @@ import DynFlags import Outputable import UniqFM -import Maybes ( expectJust ) +import Maybes ( expectJust ) import Exception ( evaluate ) import Distribution.Text import Distribution.Package hiding (PackageId) -import Data.IORef ( IORef, writeIORef, readIORef, atomicModifyIORef ) +import Data.IORef ( IORef, writeIORef, readIORef, atomicModifyIORef ) import System.Directory import System.FilePath import Control.Monad -import System.Time ( ClockTime ) +import System.Time ( ClockTime ) +import Data.List ( partition ) -type FileExt = String -- Filename extension -type BaseName = String -- Basename of file +type FileExt = String -- Filename extension +type BaseName = String -- Basename of file -- ----------------------------------------------------------------------------- -- The Finder @@ -71,9 +74,9 @@ writeIORef fc_ref emptyUFM flushModLocationCache this_pkg mlc_ref where - this_pkg = thisPackage (hsc_dflags hsc_env) - fc_ref = hsc_FC hsc_env - mlc_ref = hsc_MLC hsc_env + this_pkg = thisPackage (hsc_dflags hsc_env) + fc_ref = hsc_FC hsc_env + mlc_ref = hsc_MLC hsc_env flushModLocationCache :: PackageId -> IORef ModLocationCache -> IO () flushModLocationCache this_pkg ref = do @@ -81,7 +84,7 @@ _ <- evaluate =<< readIORef ref return () where is_ext mod _ | modulePackageId mod /= this_pkg = True - | otherwise = False + | otherwise = False addToFinderCache :: IORef FinderCache -> ModuleName -> FindResult -> IO () addToFinderCache ref key val = @@ -100,7 +103,7 @@ atomicModifyIORef ref $ \c -> (delModuleEnv c key, ()) lookupFinderCache :: IORef FinderCache -> ModuleName -> IO (Maybe FindResult) -lookupFinderCache ref key = do +lookupFinderCache ref key = do c <- readIORef ref return $! lookupUFM c key @@ -122,97 +125,102 @@ findImportedModule :: HscEnv -> ModuleName -> Maybe FastString -> IO FindResult findImportedModule hsc_env mod_name mb_pkg = case mb_pkg of - Nothing -> unqual_import - Just pkg | pkg == fsLit "this" -> home_import -- "this" is special - | otherwise -> pkg_import + Nothing -> unqual_import + Just pkg | pkg == fsLit "this" -> home_import -- "this" is special + | otherwise -> pkg_import where home_import = findHomeModule hsc_env mod_name pkg_import = findExposedPackageModule hsc_env mod_name mb_pkg - unqual_import = home_import - `orIfNotFound` - findExposedPackageModule hsc_env mod_name Nothing + unqual_import = home_import + `orIfNotFound` + findExposedPackageModule hsc_env mod_name Nothing -- | Locate a specific 'Module'. The purpose of this function is to -- create a 'ModLocation' for a given 'Module', that is to find out -- where the files associated with this module live. It is used when --- reading the interface for a module mentioned by another interface, +-- reading the interface for a module mentioned by another interface, -- for example (a "system import"). findExactModule :: HscEnv -> Module -> IO FindResult findExactModule hsc_env mod = - let dflags = hsc_dflags hsc_env in - if modulePackageId mod == thisPackage dflags - then findHomeModule hsc_env (moduleName mod) - else findPackageModule hsc_env mod + let dflags = hsc_dflags hsc_env + in if modulePackageId mod == thisPackage dflags + then findHomeModule hsc_env (moduleName mod) + else findPackageModule hsc_env mod -- ----------------------------------------------------------------------------- -- Helpers orIfNotFound :: IO FindResult -> IO FindResult -> IO FindResult -this `orIfNotFound` or_this = do +orIfNotFound this or_this = do res <- this case res of - NotFound places1 _mb_pkg1 mod_hiddens1 pkg_hiddens1 -> do - res2 <- or_this - case res2 of - NotFound places2 mb_pkg2 mod_hiddens2 pkg_hiddens2 -> - return (NotFound (places1 ++ places2) - mb_pkg2 -- snd arg is the package search - (mod_hiddens1 ++ mod_hiddens2) - (pkg_hiddens1 ++ pkg_hiddens2)) - _other -> return res2 + NotFound { fr_paths = paths1, fr_mods_hidden = mh1 + , fr_pkgs_hidden = ph1, fr_suggestions = s1 } + -> do res2 <- or_this + case res2 of + NotFound { fr_paths = paths2, fr_pkg = mb_pkg2, fr_mods_hidden = mh2 + , fr_pkgs_hidden = ph2, fr_suggestions = s2 } + -> return (NotFound { fr_paths = paths1 ++ paths2 + , fr_pkg = mb_pkg2 -- snd arg is the package search + , fr_mods_hidden = mh1 ++ mh2 + , fr_pkgs_hidden = ph1 ++ ph2 + , fr_suggestions = s1 ++ s2 }) + _other -> return res2 _other -> return res homeSearchCache :: HscEnv -> ModuleName -> IO FindResult -> IO FindResult homeSearchCache hsc_env mod_name do_this = do m <- lookupFinderCache (hsc_FC hsc_env) mod_name - case m of + case m of Just result -> return result Nothing -> do - result <- do_this - addToFinderCache (hsc_FC hsc_env) mod_name result - case result of - Found loc mod -> addToModLocationCache (hsc_MLC hsc_env) mod loc - _other -> return () - return result + result <- do_this + addToFinderCache (hsc_FC hsc_env) mod_name result + case result of + Found loc mod -> addToModLocationCache (hsc_MLC hsc_env) mod loc + _other -> return () + return result findExposedPackageModule :: HscEnv -> ModuleName -> Maybe FastString -> IO FindResult findExposedPackageModule hsc_env mod_name mb_pkg -- not found in any package: - | null found_exposed = return (NotFound [] Nothing mod_hiddens pkg_hiddens) - -- found in just one exposed package: - | [(pkg_conf, _)] <- found_exposed - = let pkgid = packageConfigId pkg_conf in - findPackageModule_ hsc_env (mkModule pkgid mod_name) pkg_conf - | otherwise - = return (FoundMultiple (map (packageConfigId.fst) found_exposed)) - where - dflags = hsc_dflags hsc_env - found = lookupModuleInAllPackages dflags mod_name - - for_this_pkg = filter ((`matches` mb_pkg) . fst) found - - found_exposed = [ (pkg_conf,exposed_mod) - | x@(pkg_conf,exposed_mod) <- for_this_pkg, - is_exposed x ] - - is_exposed (pkg_conf,exposed_mod) = exposed pkg_conf && exposed_mod - - mod_hiddens = [ packageConfigId pkg_conf - | (pkg_conf,False) <- found ] - - pkg_hiddens = [ packageConfigId pkg_conf - | (pkg_conf,_) <- found, not (exposed pkg_conf) ] - - _pkg_conf `matches` Nothing = True - pkg_conf `matches` Just pkg = - case packageName pkg_conf of - PackageName n -> pkg == mkFastString n - + = case lookupModuleWithSuggestions (hsc_dflags hsc_env) mod_name of + Left suggest -> return (NotFound { fr_paths = [], fr_pkg = Nothing + , fr_pkgs_hidden = [], fr_mods_hidden = [] + , fr_suggestions = suggest }) + Right found + | null found_exposed -- Found, but with no exposed copies + -> return (NotFound { fr_paths = [], fr_pkg = Nothing + , fr_pkgs_hidden = pkg_hiddens, fr_mods_hidden = mod_hiddens + , fr_suggestions = [] }) + + | [(pkg_conf,_)] <- found_exposed -- Found uniquely + -> let pkgid = packageConfigId pkg_conf in + findPackageModule_ hsc_env (mkModule pkgid mod_name) pkg_conf + + | otherwise -- Found in more than one place + -> return (FoundMultiple (map (packageConfigId.fst) found_exposed)) + where + for_this_pkg = case mb_pkg of + Nothing -> found + Just p -> filter ((`matches` p) . fst) found + found_exposed = filter is_exposed for_this_pkg + is_exposed (pkg_conf,exposed_mod) = exposed pkg_conf && exposed_mod + + mod_hiddens = [ packageConfigId pkg_conf + | (pkg_conf,False) <- found ] + + pkg_hiddens = [ packageConfigId pkg_conf + | (pkg_conf,_) <- found, not (exposed pkg_conf) ] + + pkg_conf `matches` pkg + = case packageName pkg_conf of + PackageName n -> pkg == mkFastString n modLocationCache :: HscEnv -> Module -> IO FindResult -> IO FindResult modLocationCache hsc_env mod do_this = do @@ -221,10 +229,10 @@ Just loc -> return (Found loc mod) Nothing -> do result <- do_this - case result of - Found loc mod -> addToModLocationCache (hsc_MLC hsc_env) mod loc - _other -> return () - return result + case result of + Found loc mod -> addToModLocationCache (hsc_MLC hsc_env) mod loc + _other -> return () + return result where mlc = hsc_MLC hsc_env @@ -242,7 +250,7 @@ removeFromModLocationCache (hsc_MLC hsc_env) (mkModule this_pkg mod) -- ----------------------------------------------------------------------------- --- The internal workers +-- The internal workers -- | Search for a module in the home package only. findHomeModule :: HscEnv -> ModuleName -> IO FindResult @@ -254,60 +262,58 @@ hisuf = hiSuf dflags mod = mkModule (thisPackage dflags) mod_name - source_exts = + source_exts = [ ("hs", mkHomeModLocationSearched dflags mod_name "hs") , ("lhs", mkHomeModLocationSearched dflags mod_name "lhs") ] - - hi_exts = [ (hisuf, mkHiOnlyModLocation dflags hisuf) - , (addBootSuffix hisuf, mkHiOnlyModLocation dflags hisuf) - ] - - -- In compilation manager modes, we look for source files in the home - -- package because we can compile these automatically. In one-shot - -- compilation mode we look for .hi and .hi-boot files only. + + hi_exts = [ (hisuf, mkHiOnlyModLocation dflags hisuf) + , (addBootSuffix hisuf, mkHiOnlyModLocation dflags hisuf) + ] + + -- In compilation manager modes, we look for source files in the home + -- package because we can compile these automatically. In one-shot + -- compilation mode we look for .hi and .hi-boot files only. exts | isOneShot (ghcMode dflags) = hi_exts - | otherwise = source_exts + | otherwise = source_exts in -- special case for GHC.Prim; we won't find it in the filesystem. -- This is important only when compiling the base package (where GHC.Prim -- is a home module). - if mod == gHC_PRIM + if mod == gHC_PRIM then return (Found (error "GHC.Prim ModLocation") mod) - else - - searchPathExts home_path mod exts + else searchPathExts home_path mod exts -- | Search for a module in external packages only. findPackageModule :: HscEnv -> Module -> IO FindResult findPackageModule hsc_env mod = do let - dflags = hsc_dflags hsc_env - pkg_id = modulePackageId mod - pkg_map = pkgIdMap (pkgState dflags) + dflags = hsc_dflags hsc_env + pkg_id = modulePackageId mod + pkg_map = pkgIdMap (pkgState dflags) -- case lookupPackage pkg_map pkg_id of Nothing -> return (NoPackage pkg_id) Just pkg_conf -> findPackageModule_ hsc_env mod pkg_conf - + findPackageModule_ :: HscEnv -> Module -> PackageConfig -> IO FindResult -findPackageModule_ hsc_env mod pkg_conf = +findPackageModule_ hsc_env mod pkg_conf = modLocationCache hsc_env mod $ -- special case for GHC.Prim; we won't find it in the filesystem. - if mod == gHC_PRIM + if mod == gHC_PRIM then return (Found (error "GHC.Prim ModLocation") mod) - else + else let dflags = hsc_dflags hsc_env tag = buildTag dflags - -- hi-suffix for packages depends on the build tag. + -- hi-suffix for packages depends on the build tag. package_hisuf | null tag = "hi" - | otherwise = tag ++ "_hi" + | otherwise = tag ++ "_hi" mk_hi_loc = mkHiOnlyModLocation dflags package_hisuf @@ -329,49 +335,52 @@ -- General path searching searchPathExts - :: [FilePath] -- paths to search - -> Module -- module name + :: [FilePath] -- paths to search + -> Module -- module name -> [ ( - FileExt, -- suffix - FilePath -> BaseName -> IO ModLocation -- action + FileExt, -- suffix + FilePath -> BaseName -> IO ModLocation -- action ) - ] + ] -> IO FindResult -searchPathExts paths mod exts +searchPathExts paths mod exts = do result <- search to_search {- - hPutStrLn stderr (showSDoc $ - vcat [text "Search" <+> ppr mod <+> sep (map (text. fst) exts) - , nest 2 (vcat (map text paths)) - , case result of - Succeeded (loc, p) -> text "Found" <+> ppr loc - Failed fs -> text "not found"]) --} - return result + hPutStrLn stderr (showSDoc $ + vcat [text "Search" <+> ppr mod <+> sep (map (text. fst) exts) + , nest 2 (vcat (map text paths)) + , case result of + Succeeded (loc, p) -> text "Found" <+> ppr loc + Failed fs -> text "not found"]) +-} + return result where basename = moduleNameSlashes (moduleName mod) to_search :: [(FilePath, IO ModLocation)] to_search = [ (file, fn path basename) - | path <- paths, - (ext,fn) <- exts, - let base | path == "." = basename - | otherwise = path basename - file = base <.> ext - ] + | path <- paths, + (ext,fn) <- exts, + let base | path == "." = basename + | otherwise = path basename + file = base <.> ext + ] + + search [] = return (NotFound { fr_paths = map fst to_search + , fr_pkg = Just (modulePackageId mod) + , fr_mods_hidden = [], fr_pkgs_hidden = [] + , fr_suggestions = [] }) - search [] = return (NotFound (map fst to_search) (Just (modulePackageId mod)) - [] []) search ((file, mk_result) : rest) = do b <- doesFileExist file - if b - then do { loc <- mk_result; return (Found loc mod) } - else search rest + if b + then do { loc <- mk_result; return (Found loc mod) } + else search rest mkHomeModLocationSearched :: DynFlags -> ModuleName -> FileExt - -> FilePath -> BaseName -> IO ModLocation + -> FilePath -> BaseName -> IO ModLocation mkHomeModLocationSearched dflags mod suff path basename = do mkHomeModLocation2 dflags mod (path basename) suff @@ -406,7 +415,7 @@ -- (b) and (c): The filename of the source file, minus its extension -- -- ext --- The filename extension of the source file (usually "hs" or "lhs"). +-- The filename extension of the source file (usually "hs" or "lhs"). mkHomeModLocation :: DynFlags -> ModuleName -> FilePath -> IO ModLocation mkHomeModLocation dflags mod src_filename = do @@ -414,10 +423,10 @@ mkHomeModLocation2 dflags mod basename extension mkHomeModLocation2 :: DynFlags - -> ModuleName - -> FilePath -- Of source module, without suffix - -> String -- Suffix - -> IO ModLocation + -> ModuleName + -> FilePath -- Of source module, without suffix + -> String -- Suffix + -> IO ModLocation mkHomeModLocation2 dflags mod src_basename ext = do let mod_basename = moduleNameSlashes mod @@ -425,37 +434,37 @@ hi_fn <- mkHiPath dflags src_basename mod_basename return (ModLocation{ ml_hs_file = Just (src_basename <.> ext), - ml_hi_file = hi_fn, - ml_obj_file = obj_fn }) + ml_hi_file = hi_fn, + ml_obj_file = obj_fn }) mkHiOnlyModLocation :: DynFlags -> Suffix -> FilePath -> String - -> IO ModLocation + -> IO ModLocation mkHiOnlyModLocation dflags hisuf path basename = do let full_basename = path basename obj_fn <- mkObjPath dflags full_basename basename return ModLocation{ ml_hs_file = Nothing, - ml_hi_file = full_basename <.> hisuf, - -- Remove the .hi-boot suffix from - -- hi_file, if it had one. We always - -- want the name of the real .hi file - -- in the ml_hi_file field. - ml_obj_file = obj_fn + ml_hi_file = full_basename <.> hisuf, + -- Remove the .hi-boot suffix from + -- hi_file, if it had one. We always + -- want the name of the real .hi file + -- in the ml_hi_file field. + ml_obj_file = obj_fn } -- | Constructs the filename of a .o file for a given source file. -- Does /not/ check whether the .o file exists mkObjPath :: DynFlags - -> FilePath -- the filename of the source file, minus the extension - -> String -- the module name with dots replaced by slashes + -> FilePath -- the filename of the source file, minus the extension + -> String -- the module name with dots replaced by slashes -> IO FilePath mkObjPath dflags basename mod_basename = do let - odir = objectDir dflags - osuf = objectSuf dflags - - obj_basename | Just dir <- odir = dir mod_basename - | otherwise = basename + odir = objectDir dflags + osuf = objectSuf dflags + + obj_basename | Just dir <- odir = dir mod_basename + | otherwise = basename return (obj_basename <.> osuf) @@ -463,16 +472,16 @@ -- Does /not/ check whether the .hi file exists mkHiPath :: DynFlags - -> FilePath -- the filename of the source file, minus the extension - -> String -- the module name with dots replaced by slashes + -> FilePath -- the filename of the source file, minus the extension + -> String -- the module name with dots replaced by slashes -> IO FilePath mkHiPath dflags basename mod_basename = do let - hidir = hiDir dflags - hisuf = hiSuf dflags + hidir = hiDir dflags + hisuf = hiSuf dflags - hi_basename | Just dir <- hidir = dir mod_basename - | otherwise = basename + hi_basename | Just dir <- hidir = dir mod_basename + | otherwise = basename return (hi_basename <.> hisuf) @@ -487,14 +496,14 @@ :: DynFlags -> ModuleName -> ModLocation - -> (FilePath,FilePath,FilePath) + -> FilePath mkStubPaths dflags mod location = let stubdir = stubDir dflags mod_basename = moduleNameSlashes mod - src_basename = dropExtension $ expectJust "mkStubPaths" + src_basename = dropExtension $ expectJust "mkStubPaths" (ml_hs_file location) stub_basename0 @@ -502,37 +511,27 @@ | otherwise = src_basename stub_basename = stub_basename0 ++ "_stub" - - obj = ml_obj_file location - osuf = objectSuf dflags - stub_obj_base = dropTail (length osuf + 1) obj ++ "_stub" - -- NB. not takeFileName, see #3093 in - (stub_basename <.> "c", - stub_basename <.> "h", - stub_obj_base <.> objectSuf dflags) + stub_basename <.> "h" -- ----------------------------------------------------------------------------- --- findLinkable isn't related to the other stuff in here, +-- findLinkable isn't related to the other stuff in here, -- but there's no other obvious place for it findObjectLinkableMaybe :: Module -> ModLocation -> IO (Maybe Linkable) findObjectLinkableMaybe mod locn = do let obj_fn = ml_obj_file locn - maybe_obj_time <- modificationTimeIfExists obj_fn - case maybe_obj_time of - Nothing -> return Nothing - Just obj_time -> liftM Just (findObjectLinkable mod obj_fn obj_time) + maybe_obj_time <- modificationTimeIfExists obj_fn + case maybe_obj_time of + Nothing -> return Nothing + Just obj_time -> liftM Just (findObjectLinkable mod obj_fn obj_time) -- Make an object linkable when we know the object file exists, and we know -- its modification time. findObjectLinkable :: Module -> FilePath -> ClockTime -> IO Linkable -findObjectLinkable mod obj_fn obj_time = do - let stub_fn = (dropExtension obj_fn ++ "_stub") <.> "o" - stub_exist <- doesFileExist stub_fn - if stub_exist - then return (LM obj_time mod [DotO obj_fn, DotO stub_fn]) - else return (LM obj_time mod [DotO obj_fn]) +findObjectLinkable mod obj_fn obj_time = return (LM obj_time mod [DotO obj_fn]) + -- We used to look for _stub.o files here, but that was a bug (#706) + -- Now GHC merges the stub.o into the main .o (#3687) -- ----------------------------------------------------------------------------- -- Error messages @@ -550,34 +549,39 @@ cantFindErr _ multiple_found _ mod_name (FoundMultiple pkgs) = hang (ptext multiple_found <+> quotes (ppr mod_name) <> colon) 2 ( sep [ptext (sLit "it was found in multiple packages:"), - hsep (map (text.packageIdString) pkgs)] + hsep (map (text.packageIdString) pkgs)] ) cantFindErr cannot_find _ dflags mod_name find_result - = hang (ptext cannot_find <+> quotes (ppr mod_name) <> colon) - 2 more_info + = ptext cannot_find <+> quotes (ppr mod_name) + $$ more_info where + pkg_map :: PackageConfigMap + pkg_map = pkgIdMap (pkgState dflags) + more_info = case find_result of - NoPackage pkg - -> ptext (sLit "no package matching") <+> quotes (ppr pkg) <+> - ptext (sLit "was found") - - NotFound files mb_pkg mod_hiddens pkg_hiddens - | Just pkg <- mb_pkg, pkg /= thisPackage dflags - -> not_found_in_package pkg files + NoPackage pkg + -> ptext (sLit "no package matching") <+> quotes (ppr pkg) <+> + ptext (sLit "was found") + + NotFound { fr_paths = files, fr_pkg = mb_pkg + , fr_mods_hidden = mod_hiddens, fr_pkgs_hidden = pkg_hiddens + , fr_suggestions = suggest } + | Just pkg <- mb_pkg, pkg /= thisPackage dflags + -> not_found_in_package pkg files + + | not (null suggest) + -> pp_suggestions suggest $$ tried_these files | null files && null mod_hiddens && null pkg_hiddens - -> ptext (sLit "it is not a module in the current program, or in any known package.") + -> ptext (sLit "It is not a module in the current program, or in any known package.") - | otherwise - -> vcat (map pkg_hidden pkg_hiddens) $$ - vcat (map mod_hidden mod_hiddens) $$ + | otherwise + -> vcat (map pkg_hidden pkg_hiddens) $$ + vcat (map mod_hidden mod_hiddens) $$ tried_these files - NotFoundInPackage pkg - -> ptext (sLit "it is not in package") <+> quotes (ppr pkg) - - _ -> panic "cantFindErr" + _ -> panic "cantFindErr" build_tag = buildTag dflags @@ -600,10 +604,10 @@ tried_these files | null files = empty | verbosity dflags < 3 = - ptext (sLit "Use -v to see a list of the files searched for.") + ptext (sLit "Use -v to see a list of the files searched for.") | otherwise = - hang (ptext (sLit "locations searched:")) 2 $ vcat (map text files) - + hang (ptext (sLit "Locations searched:")) 2 $ vcat (map text files) + pkg_hidden pkg = ptext (sLit "It is a member of the hidden package") <+> quotes (ppr pkg) <> dot $$ cabal_pkg_hidden_hint pkg @@ -619,4 +623,23 @@ mod_hidden pkg = ptext (sLit "it is a hidden module in the package") <+> quotes (ppr pkg) + + pp_suggestions :: [Module] -> SDoc + pp_suggestions sugs + | null sugs = empty + | otherwise = hang (ptext (sLit "Perhaps you meant")) + 2 (vcat [ vcat (map pp_exp exposed_sugs) + , vcat (map pp_hid hidden_sugs) ]) + where + (exposed_sugs, hidden_sugs) = partition from_exposed_pkg sugs + + from_exposed_pkg m = case lookupPackage pkg_map (modulePackageId m) of + Just pkg_config -> exposed pkg_config + Nothing -> WARN( True, ppr m ) -- Should not happen + False + + pp_exp mod = ppr (moduleName mod) + <+> parens (ptext (sLit "from") <+> ppr (modulePackageId mod)) + pp_hid mod = ppr (moduleName mod) + <+> parens (ptext (sLit "needs flag -package") <+> ppr (modulePackageId mod)) \end{code} diff -Nru ghc-7.0.3/compiler/main/GHC.hs ghc-7.2.1/compiler/main/GHC.hs --- ghc-7.0.3/compiler/main/GHC.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/main/GHC.hs 2011-08-07 17:10:05.000000000 +0000 @@ -15,9 +15,9 @@ Ghc, GhcT, GhcMonad(..), runGhc, runGhcT, initGhcMonad, gcatch, gbracket, gfinally, - clearWarnings, getWarnings, hasWarnings, - printExceptionAndWarnings, printWarnings, - handleSourceError, defaultCallbacks, GhcApiCallbacks(..), + printException, + printExceptionAndWarnings, + handleSourceError, needsTemplateHaskell, -- * Flags and settings @@ -38,7 +38,7 @@ -- * Loading\/compiling the program depanal, - load, loadWithLogger, LoadHowMuch(..), + load, LoadHowMuch(..), SuccessFlag(..), succeeded, failed, defaultWarnErrLogger, WarnErrLogger, workingDirectoryChanged, @@ -67,9 +67,11 @@ modInfoInstances, modInfoIsExportedName, modInfoLookupName, + modInfoIface, lookupGlobalName, findGlobalAnns, mkPrintUnqualifiedForModule, + ModIface(..), -- * Querying the environment packageDbModules, @@ -92,11 +94,12 @@ typeKind, parseName, RunResult(..), - runStmt, parseImportDecl, SingleStep(..), + runStmt, runStmtWithLocation, + parseImportDecl, SingleStep(..), resume, Resume(resumeStmt, resumeThreadId, resumeBreakInfo, resumeSpan, resumeHistory, resumeHistoryIx), - History(historyBreakInfo, historyEnclosingDecl), + History(historyBreakInfo, historyEnclosingDecls), GHC.getHistorySpan, getHistoryModule, getResumeContext, abandon, abandonAll, @@ -170,7 +173,7 @@ pprParendType, pprTypeApp, Kind, PredType, - ThetaType, pprForAll, pprThetaArrow, + ThetaType, pprForAll, pprThetaArrow, pprThetaArrowTy, -- ** Entities TyThing(..), @@ -185,10 +188,10 @@ compareFixity, -- ** Source locations - SrcLoc, pprDefnLoc, - mkSrcLoc, isGoodSrcLoc, noSrcLoc, + SrcLoc(..), RealSrcLoc, pprDefnLoc, + mkSrcLoc, noSrcLoc, srcLocFile, srcLocLine, srcLocCol, - SrcSpan, + SrcSpan(..), RealSrcSpan, mkSrcSpan, srcLocSpan, isGoodSrcSpan, noSrcSpan, srcSpanStart, srcSpanEnd, srcSpanFile, @@ -196,7 +199,7 @@ srcSpanStartCol, srcSpanEndCol, -- ** Located - Located(..), + GenLocated(..), Located, -- *** Constructing Located noLoc, mkGeneralLocated, @@ -217,6 +220,9 @@ getTokenStream, getRichTokenStream, showRichTokenStream, addSourceToTokens, + -- * Pure interface to the parser + parser, + -- * Miscellaneous --sessionHscEnv, cyclicModuleErr, @@ -232,17 +238,17 @@ #include "HsVersions.h" #ifdef GHCI -import qualified Linker import Linker ( HValue ) import ByteCodeInstr import BreakArray import InteractiveEval #endif -import TcRnDriver -import TcIface +import HscMain +import GhcMake +import DriverPipeline ( compile' ) +import GhcMonad import TcRnTypes -import TcRnMonad ( initIfaceCheck ) import Packages import NameSet import RdrName @@ -252,7 +258,6 @@ import Coercion ( synTyConResKind ) import TcType hiding( typeKind ) import Id -import Var import TysPrim ( alphaTyVars ) import TyCon import Class @@ -260,84 +265,77 @@ import DataCon import Name hiding ( varName ) -- import OccName ( parenSymOcc ) -import InstEnv ( Instance, instanceDFunId, pprInstance, pprInstanceHdr, - emptyInstEnv ) -import FamInstEnv ( emptyFamInstEnv ) +import InstEnv import SrcLoc ---import CoreSyn +import CoreSyn ( CoreBind ) import TidyPgm -import DriverPipeline -import DriverPhases ( Phase(..), isHaskellSrcFilename, startPhase ) -import HeaderInfo +import DriverPhases ( Phase(..), isHaskellSrcFilename ) import Finder -import HscMain import HscTypes import DynFlags import StaticFlagParser import qualified StaticFlags -import SysTools ( initSysTools, cleanTempFiles, cleanTempFilesExcept, +import SysTools ( initSysTools, cleanTempFiles, cleanTempDirs ) import Annotations import Module import UniqFM import Panic -import Digraph -import Bag ( unitBag, listToBag, emptyBag, isEmptyBag ) +import Bag ( unitBag ) import ErrUtils import MonadUtils import Util -import StringBuffer ( StringBuffer, hGetStringBuffer, nextChar ) +import StringBuffer import Outputable import BasicTypes -import Maybes ( expectJust, mapCatMaybes ) +import Maybes ( expectJust ) import FastString +import qualified Parser import Lexer -import System.Directory ( getModificationTime, doesFileExist, - getCurrentDirectory ) +import System.Directory ( doesFileExist, getCurrentDirectory ) import Data.Maybe -import Data.Map (Map) -import qualified Data.Map as Map -import qualified FiniteMap as Map -import Data.List -import qualified Data.List as List +import Data.List ( find ) import Data.Typeable ( Typeable ) import Data.Word ( Word8 ) import Control.Monad import System.Exit ( exitWith, ExitCode(..) ) -import System.Time ( ClockTime, getClockTime ) +import System.Time ( getClockTime ) import Exception import Data.IORef import System.FilePath import System.IO -import System.IO.Error ( try, isDoesNotExistError ) import Prelude hiding (init) --- ----------------------------------------------------------------------------- --- Exception handlers +-- %************************************************************************ +-- %* * +-- Initialisation: exception handlers +-- %* * +-- %************************************************************************ + -- | Install some default exception handlers and run the inner computation. -- Unless you want to handle exceptions yourself, you should wrap this around -- the top level of your program. The default handlers output the error -- message(s) to stderr and exit cleanly. -defaultErrorHandler :: (ExceptionMonad m, MonadIO m) => DynFlags -> m a -> m a -defaultErrorHandler dflags inner = +defaultErrorHandler :: (ExceptionMonad m, MonadIO m) => LogAction -> m a -> m a +defaultErrorHandler la inner = -- top-level exception handler: any unrecognised exception is a compiler bug. ghandle (\exception -> liftIO $ do hFlush stdout case fromException exception of -- an IO exception probably isn't our fault, so don't panic Just (ioe :: IOException) -> - fatalErrorMsg dflags (text (show ioe)) + fatalErrorMsg' la (text (show ioe)) _ -> case fromException exception of Just UserInterrupt -> exitWith (ExitFailure 1) Just StackOverflow -> - fatalErrorMsg dflags (text "stack overflow: use +RTS -K to increase it") + fatalErrorMsg' la (text "stack overflow: use +RTS -K to increase it") _ -> case fromException exception of Just (ex :: ExitCode) -> throw ex _ -> - fatalErrorMsg dflags + fatalErrorMsg' la (text (show (Panic (show exception)))) exitWith (ExitFailure 1) ) $ @@ -349,7 +347,7 @@ case ge of PhaseFailed _ code -> exitWith code Signal _ -> exitWith (ExitFailure 1) - _ -> do fatalErrorMsg dflags (text (show ge)) + _ -> do fatalErrorMsg' la (text (show ge)) exitWith (ExitFailure 1) ) $ inner @@ -371,30 +369,12 @@ -- so there shouldn't be any difficulty if we receive further -- signals. --- | Print the error message and all warnings. Useful inside exception --- handlers. Clears warnings after printing. -printExceptionAndWarnings :: GhcMonad m => SourceError -> m () -printExceptionAndWarnings err = do - let errs = srcErrorMessages err - warns <- getWarnings - dflags <- getSessionDynFlags - if isEmptyBag errs - -- Empty errors means we failed due to -Werror. (Since this function - -- takes a source error as argument, we know for sure _some_ error - -- did indeed happen.) - then liftIO $ do - printBagOfWarnings dflags warns - printBagOfErrors dflags (unitBag warnIsErrorMsg) - else liftIO $ printBagOfErrors dflags errs - clearWarnings - --- | Print all accumulated warnings using 'log_action'. -printWarnings :: GhcMonad m => m () -printWarnings = do - dflags <- getSessionDynFlags - warns <- getWarnings - liftIO $ printBagOfWarnings dflags warns - clearWarnings + +-- %************************************************************************ +-- %* * +-- The Ghc Monad +-- %* * +-- %************************************************************************ -- | Run function for the 'Ghc' monad. -- @@ -409,9 +389,8 @@ -> Ghc a -- ^ The action to perform. -> IO a runGhc mb_top_dir ghc = do - wref <- newIORef emptyBag - ref <- newIORef undefined - let session = Session ref wref + ref <- newIORef (panic "empty session") + let session = Session ref flip unGhc session $ do initGhcMonad mb_top_dir ghc @@ -428,9 +407,8 @@ -> GhcT m a -- ^ The action to perform. -> m a runGhcT mb_top_dir ghct = do - wref <- liftIO $ newIORef emptyBag - ref <- liftIO $ newIORef undefined - let session = Session ref wref + ref <- liftIO $ newIORef (panic "empty session") + let session = Session ref flip unGhcT session $ do initGhcMonad mb_top_dir ghct @@ -454,25 +432,17 @@ liftIO $ StaticFlags.initStaticOpts - dflags0 <- liftIO $ initDynFlags defaultDynFlags - dflags <- liftIO $ initSysTools mb_top_dir dflags0 - env <- liftIO $ newHscEnv defaultCallbacks dflags + mySettings <- liftIO $ initSysTools mb_top_dir + dflags <- liftIO $ initDynFlags (defaultDynFlags mySettings) + env <- liftIO $ newHscEnv dflags setSession env - clearWarnings - -defaultCallbacks :: GhcApiCallbacks -defaultCallbacks = - GhcApiCallbacks { - reportModuleCompilationResult = - \_ mb_err -> defaultWarnErrLogger mb_err - } --- ----------------------------------------------------------------------------- --- Flags & settings --- | Grabs the DynFlags from the Session -getSessionDynFlags :: GhcMonad m => m DynFlags -getSessionDynFlags = withSession (return . hsc_dflags) +-- %************************************************************************ +-- %* * +-- Flags & settings +-- %* * +-- %************************************************************************ -- | Updates the DynFlags in a Session. This also reads -- the package database (unless it has already been read), @@ -491,34 +461,18 @@ modifySession (\h -> h{ hsc_dflags = dflags' }) return preload --- | If there is no -o option, guess the name of target executable --- by using top-level source file name as a base. -guessOutputFile :: GhcMonad m => m () -guessOutputFile = modifySession $ \env -> - let dflags = hsc_dflags env - mod_graph = hsc_mod_graph env - mainModuleSrcPath :: Maybe String - mainModuleSrcPath = do - let isMain = (== mainModIs dflags) . ms_mod - [ms] <- return (filter isMain mod_graph) - ml_hs_file (ms_location ms) - name = fmap dropExtension mainModuleSrcPath - -#if defined(mingw32_HOST_OS) - -- we must add the .exe extention unconditionally here, otherwise - -- when name has an extension of its own, the .exe extension will - -- not be added by DriverPipeline.exeFileName. See #2248 - name_exe = fmap (<.> "exe") name -#else - name_exe = name -#endif - in - case outputFile dflags of - Just _ -> env - Nothing -> env { hsc_dflags = dflags { outputFile = name_exe } } --- ----------------------------------------------------------------------------- --- Targets +parseDynamicFlags :: Monad m => + DynFlags -> [Located String] + -> m (DynFlags, [Located String], [Located String]) +parseDynamicFlags = parseDynamicFlagsCmdLine + + +-- %************************************************************************ +-- %* * +-- Setting, getting, and modifying the targets +-- %* * +-- %************************************************************************ -- ToDo: think about relative vs. absolute file paths. And what -- happens when the current directory changes. @@ -589,337 +543,23 @@ target tid = Target tid obj_allowed Nothing --- ----------------------------------------------------------------------------- --- Loading the program - --- | Perform a dependency analysis starting from the current targets --- and update the session with the new module graph. --- --- Dependency analysis entails parsing the @import@ directives and may --- therefore require running certain preprocessors. --- --- Note that each 'ModSummary' in the module graph caches its 'DynFlags'. --- These 'DynFlags' are determined by the /current/ session 'DynFlags' and the --- @OPTIONS@ and @LANGUAGE@ pragmas of the parsed module. Thus if you want to --- changes to the 'DynFlags' to take effect you need to call this function --- again. --- -depanal :: GhcMonad m => - [ModuleName] -- ^ excluded modules - -> Bool -- ^ allow duplicate roots - -> m ModuleGraph -depanal excluded_mods allow_dup_roots = do - hsc_env <- getSession - let - dflags = hsc_dflags hsc_env - targets = hsc_targets hsc_env - old_graph = hsc_mod_graph hsc_env - - liftIO $ showPass dflags "Chasing dependencies" - liftIO $ debugTraceMsg dflags 2 (hcat [ - text "Chasing modules from: ", - hcat (punctuate comma (map pprTarget targets))]) - - mod_graph <- downsweep hsc_env old_graph excluded_mods allow_dup_roots - modifySession $ \_ -> hsc_env { hsc_mod_graph = mod_graph } - return mod_graph - --- | Describes which modules of the module graph need to be loaded. -data LoadHowMuch - = LoadAllTargets - -- ^ Load all targets and its dependencies. - | LoadUpTo ModuleName - -- ^ Load only the given module and its dependencies. - | LoadDependenciesOf ModuleName - -- ^ Load only the dependencies of the given module, but not the module - -- itself. - --- | Try to load the program. See 'LoadHowMuch' for the different modes. --- --- This function implements the core of GHC's @--make@ mode. It preprocesses, --- compiles and loads the specified modules, avoiding re-compilation wherever --- possible. Depending on the target (see 'DynFlags.hscTarget') compilating --- and loading may result in files being created on disk. --- --- Calls the 'reportModuleCompilationResult' callback after each compiling --- each module, whether successful or not. --- --- Throw a 'SourceError' if errors are encountered before the actual --- compilation starts (e.g., during dependency analysis). All other errors --- are reported using the callback. --- -load :: GhcMonad m => LoadHowMuch -> m SuccessFlag -load how_much = do - mod_graph <- depanal [] False - load2 how_much mod_graph - --- | A function called to log warnings and errors. -type WarnErrLogger = GhcMonad m => Maybe SourceError -> m () - -defaultWarnErrLogger :: WarnErrLogger -defaultWarnErrLogger Nothing = printWarnings -defaultWarnErrLogger (Just e) = printExceptionAndWarnings e - --- | Try to load the program. If a Module is supplied, then just --- attempt to load up to this target. If no Module is supplied, --- then try to load all targets. --- --- The first argument is a function that is called after compiling each --- module to print wanrings and errors. --- --- While compiling a module, all 'SourceError's are caught and passed to the --- logger, however, this function may still throw a 'SourceError' if --- dependency analysis failed (e.g., due to a parse error). --- -loadWithLogger :: GhcMonad m => WarnErrLogger -> LoadHowMuch -> m SuccessFlag -loadWithLogger logger how_much = do - -- Dependency analysis first. Note that this fixes the module graph: - -- even if we don't get a fully successful upsweep, the full module - -- graph is still retained in the Session. We can tell which modules - -- were successfully loaded by inspecting the Session's HPT. - withLocalCallbacks (\cbs -> cbs { reportModuleCompilationResult = - \_ -> logger }) $ - load how_much - -load2 :: GhcMonad m => LoadHowMuch -> [ModSummary] - -> m SuccessFlag -load2 how_much mod_graph = do - guessOutputFile - hsc_env <- getSession - - let hpt1 = hsc_HPT hsc_env - let dflags = hsc_dflags hsc_env - - -- The "bad" boot modules are the ones for which we have - -- B.hs-boot in the module graph, but no B.hs - -- The downsweep should have ensured this does not happen - -- (see msDeps) - let all_home_mods = [ms_mod_name s - | s <- mod_graph, not (isBootSummary s)] - bad_boot_mods = [s | s <- mod_graph, isBootSummary s, - not (ms_mod_name s `elem` all_home_mods)] - ASSERT( null bad_boot_mods ) return () - - -- check that the module given in HowMuch actually exists, otherwise - -- topSortModuleGraph will bomb later. - let checkHowMuch (LoadUpTo m) = checkMod m - checkHowMuch (LoadDependenciesOf m) = checkMod m - checkHowMuch _ = id - - checkMod m and_then - | m `elem` all_home_mods = and_then - | otherwise = do - liftIO $ errorMsg dflags (text "no such module:" <+> - quotes (ppr m)) - return Failed - - checkHowMuch how_much $ do - - -- mg2_with_srcimps drops the hi-boot nodes, returning a - -- graph with cycles. Among other things, it is used for - -- backing out partially complete cycles following a failed - -- upsweep, and for removing from hpt all the modules - -- not in strict downwards closure, during calls to compile. - let mg2_with_srcimps :: [SCC ModSummary] - mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing - - -- If we can determine that any of the {-# SOURCE #-} imports - -- are definitely unnecessary, then emit a warning. - warnUnnecessarySourceImports mg2_with_srcimps - - let - -- check the stability property for each module. - stable_mods@(stable_obj,stable_bco) - = checkStability hpt1 mg2_with_srcimps all_home_mods - - -- prune bits of the HPT which are definitely redundant now, - -- to save space. - pruned_hpt = pruneHomePackageTable hpt1 - (flattenSCCs mg2_with_srcimps) - stable_mods - - _ <- liftIO $ evaluate pruned_hpt - - -- before we unload anything, make sure we don't leave an old - -- interactive context around pointing to dead bindings. Also, - -- write the pruned HPT to allow the old HPT to be GC'd. - modifySession $ \_ -> hsc_env{ hsc_IC = emptyInteractiveContext, - hsc_HPT = pruned_hpt } - - liftIO $ debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$ - text "Stable BCO:" <+> ppr stable_bco) - - -- Unload any modules which are going to be re-linked this time around. - let stable_linkables = [ linkable - | m <- stable_obj++stable_bco, - Just hmi <- [lookupUFM pruned_hpt m], - Just linkable <- [hm_linkable hmi] ] - liftIO $ unload hsc_env stable_linkables - - -- We could at this point detect cycles which aren't broken by - -- a source-import, and complain immediately, but it seems better - -- to let upsweep_mods do this, so at least some useful work gets - -- done before the upsweep is abandoned. - --hPutStrLn stderr "after tsort:\n" - --hPutStrLn stderr (showSDoc (vcat (map ppr mg2))) - - -- Now do the upsweep, calling compile for each module in - -- turn. Final result is version 3 of everything. - - -- Topologically sort the module graph, this time including hi-boot - -- nodes, and possibly just including the portion of the graph - -- reachable from the module specified in the 2nd argument to load. - -- This graph should be cycle-free. - -- If we're restricting the upsweep to a portion of the graph, we - -- also want to retain everything that is still stable. - let full_mg :: [SCC ModSummary] - full_mg = topSortModuleGraph False mod_graph Nothing - - maybe_top_mod = case how_much of - LoadUpTo m -> Just m - LoadDependenciesOf m -> Just m - _ -> Nothing - - partial_mg0 :: [SCC ModSummary] - partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod - - -- LoadDependenciesOf m: we want the upsweep to stop just - -- short of the specified module (unless the specified module - -- is stable). - partial_mg - | LoadDependenciesOf _mod <- how_much - = ASSERT( case last partial_mg0 of - AcyclicSCC ms -> ms_mod_name ms == _mod; _ -> False ) - List.init partial_mg0 - | otherwise - = partial_mg0 - - stable_mg = - [ AcyclicSCC ms - | AcyclicSCC ms <- full_mg, - ms_mod_name ms `elem` stable_obj++stable_bco, - ms_mod_name ms `notElem` [ ms_mod_name ms' | - AcyclicSCC ms' <- partial_mg ] ] - - mg = stable_mg ++ partial_mg - - -- clean up between compilations - let cleanup = cleanTempFilesExcept dflags - (ppFilesFromSummaries (flattenSCCs mg2_with_srcimps)) - - liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep") - 2 (ppr mg)) - (upsweep_ok, hsc_env1, modsUpswept) - <- upsweep (hsc_env { hsc_HPT = emptyHomePackageTable }) - pruned_hpt stable_mods cleanup mg - - -- Make modsDone be the summaries for each home module now - -- available; this should equal the domain of hpt3. - -- Get in in a roughly top .. bottom order (hence reverse). - - let modsDone = reverse modsUpswept - - -- Try and do linking in some form, depending on whether the - -- upsweep was completely or only partially successful. - - if succeeded upsweep_ok - - then - -- Easy; just relink it all. - do liftIO $ debugTraceMsg dflags 2 (text "Upsweep completely successful.") - - -- Clean up after ourselves - liftIO $ cleanTempFilesExcept dflags (ppFilesFromSummaries modsDone) - - -- Issue a warning for the confusing case where the user - -- said '-o foo' but we're not going to do any linking. - -- We attempt linking if either (a) one of the modules is - -- called Main, or (b) the user said -no-hs-main, indicating - -- that main() is going to come from somewhere else. - -- - let ofile = outputFile dflags - let no_hs_main = dopt Opt_NoHsMain dflags - let - main_mod = mainModIs dflags - a_root_is_Main = any ((==main_mod).ms_mod) mod_graph - do_linking = a_root_is_Main || no_hs_main || ghcLink dflags == LinkDynLib - - when (ghcLink dflags == LinkBinary - && isJust ofile && not do_linking) $ - liftIO $ debugTraceMsg dflags 1 $ - text ("Warning: output was redirected with -o, " ++ - "but no output will be generated\n" ++ - "because there is no " ++ - moduleNameString (moduleName main_mod) ++ " module.") - - -- link everything together - linkresult <- liftIO $ link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1) - - loadFinish Succeeded linkresult hsc_env1 - - else - -- Tricky. We need to back out the effects of compiling any - -- half-done cycles, both so as to clean up the top level envs - -- and to avoid telling the interactive linker to link them. - do liftIO $ debugTraceMsg dflags 2 (text "Upsweep partially successful.") - - let modsDone_names - = map ms_mod modsDone - let mods_to_zap_names - = findPartiallyCompletedCycles modsDone_names - mg2_with_srcimps - let mods_to_keep - = filter ((`notElem` mods_to_zap_names).ms_mod) - modsDone - - let hpt4 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep) - (hsc_HPT hsc_env1) - - -- Clean up after ourselves - liftIO $ cleanTempFilesExcept dflags (ppFilesFromSummaries mods_to_keep) - - -- there should be no Nothings where linkables should be, now - ASSERT(all (isJust.hm_linkable) - (eltsUFM (hsc_HPT hsc_env))) do - - -- Link everything together - linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt4 - - let hsc_env4 = hsc_env1{ hsc_HPT = hpt4 } - loadFinish Failed linkresult hsc_env4 --- Finish up after a load. +-- | Inform GHC that the working directory has changed. GHC will flush +-- its cache of module locations, since it may no longer be valid. +-- +-- Note: Before changing the working directory make sure all threads running +-- in the same session have stopped. If you change the working directory, +-- you should also unload the current program (set targets to empty, +-- followed by load). +workingDirectoryChanged :: GhcMonad m => m () +workingDirectoryChanged = withSession $ (liftIO . flushFinderCaches) --- If the link failed, unload everything and return. -loadFinish :: GhcMonad m => - SuccessFlag -> SuccessFlag -> HscEnv - -> m SuccessFlag -loadFinish _all_ok Failed hsc_env - = do liftIO $ unload hsc_env [] - modifySession $ \_ -> discardProg hsc_env - return Failed - --- Empty the interactive context and set the module context to the topmost --- newly loaded module, or the Prelude if none were loaded. -loadFinish all_ok Succeeded hsc_env - = do modifySession $ \_ -> hsc_env{ hsc_IC = emptyInteractiveContext } - return all_ok - - --- Forget the current program, but retain the persistent info in HscEnv -discardProg :: HscEnv -> HscEnv -discardProg hsc_env - = hsc_env { hsc_mod_graph = emptyMG, - hsc_IC = emptyInteractiveContext, - hsc_HPT = emptyHomePackageTable } - --- used to fish out the preprocess output files for the purposes of --- cleaning up. The preprocessed file *might* be the same as the --- source file, but that doesn't do any harm. -ppFilesFromSummaries :: [ModSummary] -> [FilePath] -ppFilesFromSummaries summaries = map ms_hspp_file summaries --- ----------------------------------------------------------------------------- +-- %************************************************************************ +-- %* * +-- Running phases one at a time +-- %* * +-- %************************************************************************ class ParsedMod m where modSummary :: m -> ModSummary @@ -965,7 +605,7 @@ instance TypecheckedMod TypecheckedModule where renamedSource m = tm_renamed_source m typecheckedSource m = tm_typechecked_source m - moduleInfo m = tm_checked_module_info m + moduleInfo m = tm_checked_module_info m tm_internals m = tm_internals_ m -- | The result of successful desugaring (i.e., translation to core). Also @@ -1026,9 +666,9 @@ -- Throws a 'SourceError' on parse error. parseModule :: GhcMonad m => ModSummary -> m ParsedModule parseModule ms = do - rdr_module <- withTempSession - (\e -> e { hsc_dflags = ms_hspp_opts ms }) $ - hscParse ms + hsc_env <- getSession + let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms } + rdr_module <- liftIO $ hscParse hsc_env_tmp ms return (ParsedModule ms rdr_module) -- | Typecheck and rename a parsed module. @@ -1037,11 +677,12 @@ typecheckModule :: GhcMonad m => ParsedModule -> m TypecheckedModule typecheckModule pmod = do let ms = modSummary pmod - withTempSession (\e -> e { hsc_dflags = ms_hspp_opts ms }) $ do - (tc_gbl_env, rn_info) - <- hscTypecheckRename ms (parsedSource pmod) - details <- makeSimpleDetails tc_gbl_env - return $ + hsc_env <- getSession + let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms } + (tc_gbl_env, rn_info) + <- liftIO $ hscTypecheckRename hsc_env_tmp ms (parsedSource pmod) + details <- liftIO $ makeSimpleDetails hsc_env_tmp tc_gbl_env + return $ TypecheckedModule { tm_internals_ = (tc_gbl_env, details), tm_parsed_module = pmod, @@ -1052,9 +693,10 @@ minf_type_env = md_types details, minf_exports = availsToNameSet $ md_exports details, minf_rdr_env = Just (tcg_rdr_env tc_gbl_env), - minf_instances = md_insts details + minf_instances = md_insts details, + minf_iface = Nothing #ifdef GHCI - ,minf_modBreaks = emptyModBreaks + ,minf_modBreaks = emptyModBreaks #endif }} @@ -1062,10 +704,11 @@ desugarModule :: GhcMonad m => TypecheckedModule -> m DesugaredModule desugarModule tcm = do let ms = modSummary tcm - withTempSession (\e -> e { hsc_dflags = ms_hspp_opts ms }) $ do - let (tcg, _) = tm_internals tcm - guts <- hscDesugar ms tcg - return $ + let (tcg, _) = tm_internals tcm + hsc_env <- getSession + let hsc_env_tmp = hsc_env { hsc_dflags = ms_hspp_opts ms } + guts <- liftIO $ hscDesugar hsc_env_tmp ms tcg + return $ DesugaredModule { dm_typechecked_module = tcm, dm_core_module = guts @@ -1086,33 +729,52 @@ let mod = ms_mod_name ms let loc = ms_location ms let (tcg, _details) = tm_internals tcm - hpt_new <- - withTempSession (\e -> e { hsc_dflags = ms_hspp_opts ms }) $ do - let compilerBackend comp env ms' _ _mb_old_iface _ = - withTempSession (\_ -> env) $ - hscBackend comp tcg ms' Nothing - - hsc_env <- getSession - mod_info <- do - mb_linkable <- - case ms_obj_date ms of + mb_linkable <- case ms_obj_date ms of Just t | t > ms_hs_date ms -> do l <- liftIO $ findObjectLinkable (ms_mod ms) (ml_obj_file loc) t return (Just l) _otherwise -> return Nothing - compile' (compilerBackend hscNothingCompiler - ,compilerBackend hscInteractiveCompiler - ,hscCheckRecompBackend hscBatchCompiler tcg) - hsc_env ms 1 1 Nothing mb_linkable - -- compile' shouldn't change the environment - return $ addToUFM (hsc_HPT hsc_env) mod mod_info - modifySession $ \e -> e{ hsc_HPT = hpt_new } + let source_modified | isNothing mb_linkable = SourceModified + | otherwise = SourceUnmodified + -- we can't determine stability here + + -- compile doesn't change the session + hsc_env <- getSession + mod_info <- liftIO $ compile' (hscNothingBackendOnly tcg, + hscInteractiveBackendOnly tcg, + hscBatchBackendOnly tcg) + hsc_env ms 1 1 Nothing mb_linkable + source_modified + + modifySession $ \e -> e{ hsc_HPT = addToUFM (hsc_HPT e) mod mod_info } return tcm +-- %************************************************************************ +-- %* * +-- Dealing with Core +-- %* * +-- %************************************************************************ + +-- | A CoreModule consists of just the fields of a 'ModGuts' that are needed for +-- the 'GHC.compileToCoreModule' interface. +data CoreModule + = CoreModule { + -- | Module name + cm_module :: !Module, + -- | Type environment for types declared in this module + cm_types :: !TypeEnv, + -- | Declarations + cm_binds :: [CoreBind] + } + +instance Outputable CoreModule where + ppr (CoreModule {cm_module = mn, cm_types = te, cm_binds = cb}) = + text "%module" <+> ppr mn <+> ppr te $$ vcat (map ppr cb) + -- | This is the way to get access to the Core bindings corresponding -- to a module. 'compileToCore' parses, typechecks, and -- desugars the module, then returns the resulting Core module (consisting of @@ -1159,47 +821,16 @@ ms_obj_date = Nothing, -- Only handling the single-module case for now, so no imports. ms_srcimps = [], - ms_imps = [], + ms_textual_imps = [], -- No source file ms_hspp_file = "", ms_hspp_opts = dflags, ms_hspp_buf = Nothing } - let maybe_simplify mod_guts | simplify = hscSimplify mod_guts - | otherwise = return mod_guts - guts <- maybe_simplify (mkModGuts cm) - (iface, changed, _details, cgguts) - <- hscNormalIface guts Nothing - hscWriteIface iface changed modSummary - _ <- hscGenHardCode cgguts modSummary - return () - --- Makes a "vanilla" ModGuts. -mkModGuts :: CoreModule -> ModGuts -mkModGuts coreModule = ModGuts { - mg_module = cm_module coreModule, - mg_boot = False, - mg_exports = [], - mg_deps = noDependencies, - mg_dir_imps = emptyModuleEnv, - mg_used_names = emptyNameSet, - mg_rdr_env = emptyGlobalRdrEnv, - mg_fix_env = emptyFixityEnv, - mg_types = emptyTypeEnv, - mg_insts = [], - mg_fam_insts = [], - mg_rules = [], - mg_binds = cm_binds coreModule, - mg_foreign = NoStubs, - mg_warns = NoWarnings, - mg_anns = [], - mg_hpc_info = emptyHpcInfo False, - mg_modBreaks = emptyModBreaks, - mg_vect_info = noVectInfo, - mg_inst_env = emptyInstEnv, - mg_fam_inst_env = emptyFamInstEnv -} + hsc_env <- getSession + liftIO $ hscCompileCore hsc_env simplify modSummary (cm_binds cm) + compileCore :: GhcMonad m => Bool -> FilePath -> m CoreModule compileCore simplify fn = do @@ -1222,7 +853,7 @@ -- If simplify is true: simplify (hscSimplify), then tidy -- (tidyProgram). hsc_env <- getSession - simpl_guts <- hscSimplify mod_guts + simpl_guts <- liftIO $ hscSimplify hsc_env mod_guts tidy_guts <- liftIO $ tidyProgram hsc_env simpl_guts return $ Left tidy_guts else @@ -1236,1099 +867,18 @@ gutsToCoreModule :: Either (CgGuts, ModDetails) ModGuts -> CoreModule gutsToCoreModule (Left (cg, md)) = CoreModule { cm_module = cg_module cg, cm_types = md_types md, - cm_imports = cg_dir_imps cg, cm_binds = cg_binds cg + cm_binds = cg_binds cg } gutsToCoreModule (Right mg) = CoreModule { cm_module = mg_module mg, cm_types = mg_types mg, - cm_imports = moduleEnvKeys (mg_dir_imps mg), cm_binds = mg_binds mg + cm_binds = mg_binds mg } --- --------------------------------------------------------------------------- --- Unloading - -unload :: HscEnv -> [Linkable] -> IO () -unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables' - = case ghcLink (hsc_dflags hsc_env) of -#ifdef GHCI - LinkInMemory -> Linker.unload (hsc_dflags hsc_env) stable_linkables -#else - LinkInMemory -> panic "unload: no interpreter" - -- urgh. avoid warnings: - hsc_env stable_linkables -#endif - _other -> return () - --- ----------------------------------------------------------------------------- - -{- | - - Stability tells us which modules definitely do not need to be recompiled. - There are two main reasons for having stability: - - - avoid doing a complete upsweep of the module graph in GHCi when - modules near the bottom of the tree have not changed. - - - to tell GHCi when it can load object code: we can only load object code - for a module when we also load object code fo all of the imports of the - module. So we need to know that we will definitely not be recompiling - any of these modules, and we can use the object code. - - The stability check is as follows. Both stableObject and - stableBCO are used during the upsweep phase later. - -@ - stable m = stableObject m || stableBCO m - - stableObject m = - all stableObject (imports m) - && old linkable does not exist, or is == on-disk .o - && date(on-disk .o) > date(.hs) - - stableBCO m = - all stable (imports m) - && date(BCO) > date(.hs) -@ - - These properties embody the following ideas: - - - if a module is stable, then: - - - if it has been compiled in a previous pass (present in HPT) - then it does not need to be compiled or re-linked. - - - if it has not been compiled in a previous pass, - then we only need to read its .hi file from disk and - link it to produce a 'ModDetails'. - - - if a modules is not stable, we will definitely be at least - re-linking, and possibly re-compiling it during the 'upsweep'. - All non-stable modules can (and should) therefore be unlinked - before the 'upsweep'. - - - Note that objects are only considered stable if they only depend - on other objects. We can't link object code against byte code. --} - -checkStability - :: HomePackageTable -- HPT from last compilation - -> [SCC ModSummary] -- current module graph (cyclic) - -> [ModuleName] -- all home modules - -> ([ModuleName], -- stableObject - [ModuleName]) -- stableBCO - -checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs - where - checkSCC (stable_obj, stable_bco) scc0 - | stableObjects = (scc_mods ++ stable_obj, stable_bco) - | stableBCOs = (stable_obj, scc_mods ++ stable_bco) - | otherwise = (stable_obj, stable_bco) - where - scc = flattenSCC scc0 - scc_mods = map ms_mod_name scc - home_module m = m `elem` all_home_mods && m `notElem` scc_mods - - scc_allimps = nub (filter home_module (concatMap ms_home_allimps scc)) - -- all imports outside the current SCC, but in the home pkg - - stable_obj_imps = map (`elem` stable_obj) scc_allimps - stable_bco_imps = map (`elem` stable_bco) scc_allimps - - stableObjects = - and stable_obj_imps - && all object_ok scc - - stableBCOs = - and (zipWith (||) stable_obj_imps stable_bco_imps) - && all bco_ok scc - - object_ok ms - | Just t <- ms_obj_date ms = t >= ms_hs_date ms - && same_as_prev t - | otherwise = False - where - same_as_prev t = case lookupUFM hpt (ms_mod_name ms) of - Just hmi | Just l <- hm_linkable hmi - -> isObjectLinkable l && t == linkableTime l - _other -> True - -- why '>=' rather than '>' above? If the filesystem stores - -- times to the nearset second, we may occasionally find that - -- the object & source have the same modification time, - -- especially if the source was automatically generated - -- and compiled. Using >= is slightly unsafe, but it matches - -- make's behaviour. - - bco_ok ms - = case lookupUFM hpt (ms_mod_name ms) of - Just hmi | Just l <- hm_linkable hmi -> - not (isObjectLinkable l) && - linkableTime l >= ms_hs_date ms - _other -> False - --- ----------------------------------------------------------------------------- - --- | Prune the HomePackageTable --- --- Before doing an upsweep, we can throw away: --- --- - For non-stable modules: --- - all ModDetails, all linked code --- - all unlinked code that is out of date with respect to --- the source file --- --- This is VERY IMPORTANT otherwise we'll end up requiring 2x the --- space at the end of the upsweep, because the topmost ModDetails of the --- old HPT holds on to the entire type environment from the previous --- compilation. - -pruneHomePackageTable - :: HomePackageTable - -> [ModSummary] - -> ([ModuleName],[ModuleName]) - -> HomePackageTable - -pruneHomePackageTable hpt summ (stable_obj, stable_bco) - = mapUFM prune hpt - where prune hmi - | is_stable modl = hmi' - | otherwise = hmi'{ hm_details = emptyModDetails } - where - modl = moduleName (mi_module (hm_iface hmi)) - hmi' | Just l <- hm_linkable hmi, linkableTime l < ms_hs_date ms - = hmi{ hm_linkable = Nothing } - | otherwise - = hmi - where ms = expectJust "prune" (lookupUFM ms_map modl) - - ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ] - - is_stable m = m `elem` stable_obj || m `elem` stable_bco - --- ----------------------------------------------------------------------------- - --- Return (names of) all those in modsDone who are part of a cycle --- as defined by theGraph. -findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> [Module] -findPartiallyCompletedCycles modsDone theGraph - = chew theGraph - where - chew [] = [] - chew ((AcyclicSCC _):rest) = chew rest -- acyclic? not interesting. - chew ((CyclicSCC vs):rest) - = let names_in_this_cycle = nub (map ms_mod vs) - mods_in_this_cycle - = nub ([done | done <- modsDone, - done `elem` names_in_this_cycle]) - chewed_rest = chew rest - in - if notNull mods_in_this_cycle - && length mods_in_this_cycle < length names_in_this_cycle - then mods_in_this_cycle ++ chewed_rest - else chewed_rest - --- ----------------------------------------------------------------------------- - --- | The upsweep --- --- This is where we compile each module in the module graph, in a pass --- from the bottom to the top of the graph. --- --- There better had not be any cyclic groups here -- we check for them. - -upsweep - :: GhcMonad m => - HscEnv -- ^ Includes initially-empty HPT - -> HomePackageTable -- ^ HPT from last time round (pruned) - -> ([ModuleName],[ModuleName]) -- ^ stable modules (see checkStability) - -> IO () -- ^ How to clean up unwanted tmp files - -> [SCC ModSummary] -- ^ Mods to do (the worklist) - -> m (SuccessFlag, - HscEnv, - [ModSummary]) - -- ^ Returns: - -- - -- 1. A flag whether the complete upsweep was successful. - -- 2. The 'HscEnv' with an updated HPT - -- 3. A list of modules which succeeded loading. - -upsweep hsc_env old_hpt stable_mods cleanup sccs = do - (res, hsc_env, done) <- upsweep' hsc_env old_hpt [] sccs 1 (length sccs) - return (res, hsc_env, reverse done) - where - - upsweep' hsc_env _old_hpt done - [] _ _ - = return (Succeeded, hsc_env, done) - - upsweep' hsc_env _old_hpt done - (CyclicSCC ms:_) _ _ - = do liftIO $ fatalErrorMsg (hsc_dflags hsc_env) (cyclicModuleErr ms) - return (Failed, hsc_env, done) - - upsweep' hsc_env old_hpt done - (AcyclicSCC mod:mods) mod_index nmods - = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++ - -- show (map (moduleUserString.moduleName.mi_module.hm_iface) - -- (moduleEnvElts (hsc_HPT hsc_env))) - let logger = reportModuleCompilationResult (hsc_callbacks hsc_env) - - mb_mod_info - <- handleSourceError - (\err -> do logger mod (Just err); return Nothing) $ do - mod_info <- upsweep_mod hsc_env old_hpt stable_mods - mod mod_index nmods - logger mod Nothing -- log warnings - return (Just mod_info) - - liftIO cleanup -- Remove unwanted tmp files between compilations - - case mb_mod_info of - Nothing -> return (Failed, hsc_env, done) - Just mod_info -> do - let this_mod = ms_mod_name mod - - -- Add new info to hsc_env - hpt1 = addToUFM (hsc_HPT hsc_env) this_mod mod_info - hsc_env1 = hsc_env { hsc_HPT = hpt1 } - - -- Space-saving: delete the old HPT entry - -- for mod BUT if mod is a hs-boot - -- node, don't delete it. For the - -- interface, the HPT entry is probaby for the - -- main Haskell source file. Deleting it - -- would force the real module to be recompiled - -- every time. - old_hpt1 | isBootSummary mod = old_hpt - | otherwise = delFromUFM old_hpt this_mod - - done' = mod:done - - -- fixup our HomePackageTable after we've finished compiling - -- a mutually-recursive loop. See reTypecheckLoop, below. - hsc_env2 <- liftIO $ reTypecheckLoop hsc_env1 mod done' - - upsweep' hsc_env2 old_hpt1 done' mods (mod_index+1) nmods - --- | Compile a single module. Always produce a Linkable for it if --- successful. If no compilation happened, return the old Linkable. -upsweep_mod :: GhcMonad m => - HscEnv - -> HomePackageTable - -> ([ModuleName],[ModuleName]) - -> ModSummary - -> Int -- index of module - -> Int -- total number of modules - -> m HomeModInfo - -upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods - = let - this_mod_name = ms_mod_name summary - this_mod = ms_mod summary - mb_obj_date = ms_obj_date summary - obj_fn = ml_obj_file (ms_location summary) - hs_date = ms_hs_date summary - - is_stable_obj = this_mod_name `elem` stable_obj - is_stable_bco = this_mod_name `elem` stable_bco - - old_hmi = lookupUFM old_hpt this_mod_name - - -- We're using the dflags for this module now, obtained by - -- applying any options in its LANGUAGE & OPTIONS_GHC pragmas. - dflags = ms_hspp_opts summary - prevailing_target = hscTarget (hsc_dflags hsc_env) - local_target = hscTarget dflags - - -- If OPTIONS_GHC contains -fasm or -fvia-C, be careful that - -- we don't do anything dodgy: these should only work to change - -- from -fvia-C to -fasm and vice-versa, otherwise we could - -- end up trying to link object code to byte code. - target = if prevailing_target /= local_target - && (not (isObjectTarget prevailing_target) - || not (isObjectTarget local_target)) - then prevailing_target - else local_target - - -- store the corrected hscTarget into the summary - summary' = summary{ ms_hspp_opts = dflags { hscTarget = target } } - - -- The old interface is ok if - -- a) we're compiling a source file, and the old HPT - -- entry is for a source file - -- b) we're compiling a hs-boot file - -- Case (b) allows an hs-boot file to get the interface of its - -- real source file on the second iteration of the compilation - -- manager, but that does no harm. Otherwise the hs-boot file - -- will always be recompiled - - mb_old_iface - = case old_hmi of - Nothing -> Nothing - Just hm_info | isBootSummary summary -> Just iface - | not (mi_boot iface) -> Just iface - | otherwise -> Nothing - where - iface = hm_iface hm_info - - compile_it :: GhcMonad m => Maybe Linkable -> m HomeModInfo - compile_it = compile hsc_env summary' mod_index nmods mb_old_iface - - compile_it_discard_iface :: GhcMonad m => - Maybe Linkable -> m HomeModInfo - compile_it_discard_iface - = compile hsc_env summary' mod_index nmods Nothing - - -- With the HscNothing target we create empty linkables to avoid - -- recompilation. We have to detect these to recompile anyway if - -- the target changed since the last compile. - is_fake_linkable - | Just hmi <- old_hmi, Just l <- hm_linkable hmi = - null (linkableUnlinked l) - | otherwise = - -- we have no linkable, so it cannot be fake - False - - implies False _ = True - implies True x = x - - in - case () of - _ - -- Regardless of whether we're generating object code or - -- byte code, we can always use an existing object file - -- if it is *stable* (see checkStability). - | is_stable_obj, Just hmi <- old_hmi -> do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "skipping stable obj mod:" <+> ppr this_mod_name) - return hmi - -- object is stable, and we have an entry in the - -- old HPT: nothing to do - - | is_stable_obj, isNothing old_hmi -> do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "compiling stable on-disk mod:" <+> ppr this_mod_name) - linkable <- liftIO $ findObjectLinkable this_mod obj_fn - (expectJust "upsweep1" mb_obj_date) - compile_it (Just linkable) - -- object is stable, but we need to load the interface - -- off disk to make a HMI. - - | not (isObjectTarget target), is_stable_bco, - (target /= HscNothing) `implies` not is_fake_linkable -> - ASSERT(isJust old_hmi) -- must be in the old_hpt - let Just hmi = old_hmi in do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "skipping stable BCO mod:" <+> ppr this_mod_name) - return hmi - -- BCO is stable: nothing to do - - | not (isObjectTarget target), - Just hmi <- old_hmi, - Just l <- hm_linkable hmi, - not (isObjectLinkable l), - (target /= HscNothing) `implies` not is_fake_linkable, - linkableTime l >= ms_hs_date summary -> do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "compiling non-stable BCO mod:" <+> ppr this_mod_name) - compile_it (Just l) - -- we have an old BCO that is up to date with respect - -- to the source: do a recompilation check as normal. - - -- When generating object code, if there's an up-to-date - -- object file on the disk, then we can use it. - -- However, if the object file is new (compared to any - -- linkable we had from a previous compilation), then we - -- must discard any in-memory interface, because this - -- means the user has compiled the source file - -- separately and generated a new interface, that we must - -- read from the disk. - -- - | isObjectTarget target, - Just obj_date <- mb_obj_date, - obj_date >= hs_date -> do - case old_hmi of - Just hmi - | Just l <- hm_linkable hmi, - isObjectLinkable l && linkableTime l == obj_date -> do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "compiling mod with new on-disk obj:" <+> ppr this_mod_name) - compile_it (Just l) - _otherwise -> do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "compiling mod with new on-disk obj2:" <+> ppr this_mod_name) - linkable <- liftIO $ findObjectLinkable this_mod obj_fn obj_date - compile_it_discard_iface (Just linkable) - - _otherwise -> do - liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 - (text "compiling mod:" <+> ppr this_mod_name) - compile_it Nothing - - - --- Filter modules in the HPT -retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable -retainInTopLevelEnvs keep_these hpt - = listToUFM [ (mod, expectJust "retain" mb_mod_info) - | mod <- keep_these - , let mb_mod_info = lookupUFM hpt mod - , isJust mb_mod_info ] - --- --------------------------------------------------------------------------- --- Typecheck module loops - -{- -See bug #930. This code fixes a long-standing bug in --make. The -problem is that when compiling the modules *inside* a loop, a data -type that is only defined at the top of the loop looks opaque; but -after the loop is done, the structure of the data type becomes -apparent. - -The difficulty is then that two different bits of code have -different notions of what the data type looks like. - -The idea is that after we compile a module which also has an .hs-boot -file, we re-generate the ModDetails for each of the modules that -depends on the .hs-boot file, so that everyone points to the proper -TyCons, Ids etc. defined by the real module, not the boot module. -Fortunately re-generating a ModDetails from a ModIface is easy: the -function TcIface.typecheckIface does exactly that. - -Picking the modules to re-typecheck is slightly tricky. Starting from -the module graph consisting of the modules that have already been -compiled, we reverse the edges (so they point from the imported module -to the importing module), and depth-first-search from the .hs-boot -node. This gives us all the modules that depend transitively on the -.hs-boot module, and those are exactly the modules that we need to -re-typecheck. - -Following this fix, GHC can compile itself with --make -O2. --} - -reTypecheckLoop :: HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv -reTypecheckLoop hsc_env ms graph - | not (isBootSummary ms) && - any (\m -> ms_mod m == this_mod && isBootSummary m) graph - = do - let mss = reachableBackwards (ms_mod_name ms) graph - non_boot = filter (not.isBootSummary) mss - debugTraceMsg (hsc_dflags hsc_env) 2 $ - text "Re-typechecking loop: " <> ppr (map ms_mod_name non_boot) - typecheckLoop hsc_env (map ms_mod_name non_boot) - | otherwise - = return hsc_env - where - this_mod = ms_mod ms - -typecheckLoop :: HscEnv -> [ModuleName] -> IO HscEnv -typecheckLoop hsc_env mods = do - new_hpt <- - fixIO $ \new_hpt -> do - let new_hsc_env = hsc_env{ hsc_HPT = new_hpt } - mds <- initIfaceCheck new_hsc_env $ - mapM (typecheckIface . hm_iface) hmis - let new_hpt = addListToUFM old_hpt - (zip mods [ hmi{ hm_details = details } - | (hmi,details) <- zip hmis mds ]) - return new_hpt - return hsc_env{ hsc_HPT = new_hpt } - where - old_hpt = hsc_HPT hsc_env - hmis = map (expectJust "typecheckLoop" . lookupUFM old_hpt) mods - -reachableBackwards :: ModuleName -> [ModSummary] -> [ModSummary] -reachableBackwards mod summaries - = [ ms | (ms,_,_) <- reachableG (transposeG graph) root ] - where -- the rest just sets up the graph: - (graph, lookup_node) = moduleGraphNodes False summaries - root = expectJust "reachableBackwards" (lookup_node HsBootFile mod) - --- --------------------------------------------------------------------------- --- Topological sort of the module graph - -type SummaryNode = (ModSummary, Int, [Int]) - -topSortModuleGraph - :: Bool - -- ^ Drop hi-boot nodes? (see below) - -> [ModSummary] - -> Maybe ModuleName - -- ^ Root module name. If @Nothing@, use the full graph. - -> [SCC ModSummary] --- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes --- The resulting list of strongly-connected-components is in topologically --- sorted order, starting with the module(s) at the bottom of the --- dependency graph (ie compile them first) and ending with the ones at --- the top. --- --- Drop hi-boot nodes (first boolean arg)? --- --- - @False@: treat the hi-boot summaries as nodes of the graph, --- so the graph must be acyclic --- --- - @True@: eliminate the hi-boot nodes, and instead pretend --- the a source-import of Foo is an import of Foo --- The resulting graph has no hi-boot nodes, but can be cyclic - -topSortModuleGraph drop_hs_boot_nodes summaries mb_root_mod - = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph - where - (graph, lookup_node) = moduleGraphNodes drop_hs_boot_nodes summaries - - initial_graph = case mb_root_mod of - Nothing -> graph - Just root_mod -> - -- restrict the graph to just those modules reachable from - -- the specified module. We do this by building a graph with - -- the full set of nodes, and determining the reachable set from - -- the specified node. - let root | Just node <- lookup_node HsSrcFile root_mod, graph `hasVertexG` node = node - | otherwise = ghcError (ProgramError "module does not exist") - in graphFromEdgedVertices (seq root (reachableG graph root)) - -summaryNodeKey :: SummaryNode -> Int -summaryNodeKey (_, k, _) = k - -summaryNodeSummary :: SummaryNode -> ModSummary -summaryNodeSummary (s, _, _) = s - -moduleGraphNodes :: Bool -> [ModSummary] - -> (Graph SummaryNode, HscSource -> ModuleName -> Maybe SummaryNode) -moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVertices nodes, lookup_node) - where - numbered_summaries = zip summaries [1..] - - lookup_node :: HscSource -> ModuleName -> Maybe SummaryNode - lookup_node hs_src mod = Map.lookup (mod, hs_src) node_map - - lookup_key :: HscSource -> ModuleName -> Maybe Int - lookup_key hs_src mod = fmap summaryNodeKey (lookup_node hs_src mod) - - node_map :: NodeMap SummaryNode - node_map = Map.fromList [ ((moduleName (ms_mod s), ms_hsc_src s), node) - | node@(s, _, _) <- nodes ] - - -- We use integers as the keys for the SCC algorithm - nodes :: [SummaryNode] - nodes = [ (s, key, out_keys) - | (s, key) <- numbered_summaries - -- Drop the hi-boot ones if told to do so - , not (isBootSummary s && drop_hs_boot_nodes) - , let out_keys = out_edge_keys hs_boot_key (map unLoc (ms_home_srcimps s)) ++ - out_edge_keys HsSrcFile (map unLoc (ms_home_imps s)) ++ - (-- see [boot-edges] below - if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile - then [] - else case lookup_key HsBootFile (ms_mod_name s) of - Nothing -> [] - Just k -> [k]) ] - - -- [boot-edges] if this is a .hs and there is an equivalent - -- .hs-boot, add a link from the former to the latter. This - -- has the effect of detecting bogus cases where the .hs-boot - -- depends on the .hs, by introducing a cycle. Additionally, - -- it ensures that we will always process the .hs-boot before - -- the .hs, and so the HomePackageTable will always have the - -- most up to date information. - - -- Drop hs-boot nodes by using HsSrcFile as the key - hs_boot_key | drop_hs_boot_nodes = HsSrcFile - | otherwise = HsBootFile - - out_edge_keys :: HscSource -> [ModuleName] -> [Int] - out_edge_keys hi_boot ms = mapCatMaybes (lookup_key hi_boot) ms - -- If we want keep_hi_boot_nodes, then we do lookup_key with - -- the IsBootInterface parameter True; else False - - -type NodeKey = (ModuleName, HscSource) -- The nodes of the graph are -type NodeMap a = Map NodeKey a -- keyed by (mod, src_file_type) pairs - -msKey :: ModSummary -> NodeKey -msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) = (moduleName mod,boot) - -mkNodeMap :: [ModSummary] -> NodeMap ModSummary -mkNodeMap summaries = Map.fromList [ (msKey s, s) | s <- summaries] - -nodeMapElts :: NodeMap a -> [a] -nodeMapElts = Map.elems - --- | If there are {-# SOURCE #-} imports between strongly connected --- components in the topological sort, then those imports can --- definitely be replaced by ordinary non-SOURCE imports: if SOURCE --- were necessary, then the edge would be part of a cycle. -warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m () -warnUnnecessarySourceImports sccs = - logWarnings (listToBag (concatMap (check.flattenSCC) sccs)) - where check ms = - let mods_in_this_cycle = map ms_mod_name ms in - [ warn i | m <- ms, i <- ms_home_srcimps m, - unLoc i `notElem` mods_in_this_cycle ] - - warn :: Located ModuleName -> WarnMsg - warn (L loc mod) = - mkPlainErrMsg loc - (ptext (sLit "Warning: {-# SOURCE #-} unnecessary in import of ") - <+> quotes (ppr mod)) - ------------------------------------------------------------------------------ --- Downsweep (dependency analysis) - --- Chase downwards from the specified root set, returning summaries --- for all home modules encountered. Only follow source-import --- links. - --- We pass in the previous collection of summaries, which is used as a --- cache to avoid recalculating a module summary if the source is --- unchanged. --- --- The returned list of [ModSummary] nodes has one node for each home-package --- module, plus one for any hs-boot files. The imports of these nodes --- are all there, including the imports of non-home-package modules. - -downsweep :: GhcMonad m => - HscEnv - -> [ModSummary] -- Old summaries - -> [ModuleName] -- Ignore dependencies on these; treat - -- them as if they were package modules - -> Bool -- True <=> allow multiple targets to have - -- the same module name; this is - -- very useful for ghc -M - -> m [ModSummary] - -- The elts of [ModSummary] all have distinct - -- (Modules, IsBoot) identifiers, unless the Bool is true - -- in which case there can be repeats -downsweep hsc_env old_summaries excl_mods allow_dup_roots - = do -- catch error messages and return them - --handleErrMsg -- should be covered by GhcMonad now - -- (\err_msg -> printBagOfErrors (hsc_dflags hsc_env) (unitBag err_msg) >> return Nothing) $ do - rootSummaries <- mapM getRootSummary roots - let root_map = mkRootMap rootSummaries - checkDuplicates root_map - summs <- loop (concatMap msDeps rootSummaries) root_map - return summs - where - roots = hsc_targets hsc_env - - old_summary_map :: NodeMap ModSummary - old_summary_map = mkNodeMap old_summaries - - getRootSummary :: GhcMonad m => Target -> m ModSummary - getRootSummary (Target (TargetFile file mb_phase) obj_allowed maybe_buf) - = do exists <- liftIO $ doesFileExist file - if exists - then summariseFile hsc_env old_summaries file mb_phase - obj_allowed maybe_buf - else throwOneError $ mkPlainErrMsg noSrcSpan $ - text "can't find file:" <+> text file - getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf) - = do maybe_summary <- summariseModule hsc_env old_summary_map False - (L rootLoc modl) obj_allowed - maybe_buf excl_mods - case maybe_summary of - Nothing -> packageModErr modl - Just s -> return s - - rootLoc = mkGeneralSrcSpan (fsLit "") - - -- In a root module, the filename is allowed to diverge from the module - -- name, so we have to check that there aren't multiple root files - -- defining the same module (otherwise the duplicates will be silently - -- ignored, leading to confusing behaviour). - checkDuplicates :: GhcMonad m => NodeMap [ModSummary] -> m () - checkDuplicates root_map - | allow_dup_roots = return () - | null dup_roots = return () - | otherwise = liftIO $ multiRootsErr (head dup_roots) - where - dup_roots :: [[ModSummary]] -- Each at least of length 2 - dup_roots = filterOut isSingleton (nodeMapElts root_map) - - loop :: GhcMonad m => - [(Located ModuleName,IsBootInterface)] - -- Work list: process these modules - -> NodeMap [ModSummary] - -- Visited set; the range is a list because - -- the roots can have the same module names - -- if allow_dup_roots is True - -> m [ModSummary] - -- The result includes the worklist, except - -- for those mentioned in the visited set - loop [] done = return (concat (nodeMapElts done)) - loop ((wanted_mod, is_boot) : ss) done - | Just summs <- Map.lookup key done - = if isSingleton summs then - loop ss done - else - do { liftIO $ multiRootsErr summs; return [] } - | otherwise - = do mb_s <- summariseModule hsc_env old_summary_map - is_boot wanted_mod True - Nothing excl_mods - case mb_s of - Nothing -> loop ss done - Just s -> loop (msDeps s ++ ss) (Map.insert key [s] done) - where - key = (unLoc wanted_mod, if is_boot then HsBootFile else HsSrcFile) - --- XXX Does the (++) here need to be flipped? -mkRootMap :: [ModSummary] -> NodeMap [ModSummary] -mkRootMap summaries = Map.insertListWith (flip (++)) - [ (msKey s, [s]) | s <- summaries ] - Map.empty - -msDeps :: ModSummary -> [(Located ModuleName, IsBootInterface)] --- (msDeps s) returns the dependencies of the ModSummary s. --- A wrinkle is that for a {-# SOURCE #-} import we return --- *both* the hs-boot file --- *and* the source file --- as "dependencies". That ensures that the list of all relevant --- modules always contains B.hs if it contains B.hs-boot. --- Remember, this pass isn't doing the topological sort. It's --- just gathering the list of all relevant ModSummaries -msDeps s = - concat [ [(m,True), (m,False)] | m <- ms_home_srcimps s ] - ++ [ (m,False) | m <- ms_home_imps s ] - -home_imps :: [Located (ImportDecl RdrName)] -> [Located ModuleName] -home_imps imps = [ ideclName i | L _ i <- imps, isLocal (ideclPkgQual i) ] - where isLocal Nothing = True - isLocal (Just pkg) | pkg == fsLit "this" = True -- "this" is special - isLocal _ = False - -ms_home_allimps :: ModSummary -> [ModuleName] -ms_home_allimps ms = map unLoc (ms_home_srcimps ms ++ ms_home_imps ms) - -ms_home_srcimps :: ModSummary -> [Located ModuleName] -ms_home_srcimps = home_imps . ms_srcimps - -ms_home_imps :: ModSummary -> [Located ModuleName] -ms_home_imps = home_imps . ms_imps - ------------------------------------------------------------------------------ --- Summarising modules - --- We have two types of summarisation: --- --- * Summarise a file. This is used for the root module(s) passed to --- cmLoadModules. The file is read, and used to determine the root --- module name. The module name may differ from the filename. --- --- * Summarise a module. We are given a module name, and must provide --- a summary. The finder is used to locate the file in which the module --- resides. - -summariseFile - :: GhcMonad m => - HscEnv - -> [ModSummary] -- old summaries - -> FilePath -- source file name - -> Maybe Phase -- start phase - -> Bool -- object code allowed? - -> Maybe (StringBuffer,ClockTime) - -> m ModSummary - -summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf - -- we can use a cached summary if one is available and the - -- source file hasn't changed, But we have to look up the summary - -- by source file, rather than module name as we do in summarise. - | Just old_summary <- findSummaryBySourceFile old_summaries file - = do - let location = ms_location old_summary - - -- return the cached summary if the source didn't change - src_timestamp <- case maybe_buf of - Just (_,t) -> return t - Nothing -> liftIO $ getModificationTime file - -- The file exists; we checked in getRootSummary above. - -- If it gets removed subsequently, then this - -- getModificationTime may fail, but that's the right - -- behaviour. - - if ms_hs_date old_summary == src_timestamp - then do -- update the object-file timestamp - obj_timestamp <- - if isObjectTarget (hscTarget (hsc_dflags hsc_env)) - || obj_allowed -- bug #1205 - then liftIO $ getObjTimestamp location False - else return Nothing - return old_summary{ ms_obj_date = obj_timestamp } - else - new_summary - - | otherwise - = new_summary - where - new_summary = do - let dflags = hsc_dflags hsc_env - - (dflags', hspp_fn, buf) - <- preprocessFile hsc_env file mb_phase maybe_buf - - (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn file - - -- Make a ModLocation for this file - location <- liftIO $ mkHomeModLocation dflags mod_name file - - -- Tell the Finder cache where it is, so that subsequent calls - -- to findModule will find it, even if it's not on any search path - mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location - - src_timestamp <- case maybe_buf of - Just (_,t) -> return t - Nothing -> liftIO $ getModificationTime file - -- getMofificationTime may fail - - -- when the user asks to load a source file by name, we only - -- use an object file if -fobject-code is on. See #1205. - obj_timestamp <- - if isObjectTarget (hscTarget (hsc_dflags hsc_env)) - || obj_allowed -- bug #1205 - then liftIO $ modificationTimeIfExists (ml_obj_file location) - else return Nothing - - return (ModSummary { ms_mod = mod, ms_hsc_src = HsSrcFile, - ms_location = location, - ms_hspp_file = hspp_fn, - ms_hspp_opts = dflags', - ms_hspp_buf = Just buf, - ms_srcimps = srcimps, ms_imps = the_imps, - ms_hs_date = src_timestamp, - ms_obj_date = obj_timestamp }) - -findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary -findSummaryBySourceFile summaries file - = case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms], - expectJust "findSummaryBySourceFile" (ml_hs_file (ms_location ms)) == file ] of - [] -> Nothing - (x:_) -> Just x - --- Summarise a module, and pick up source and timestamp. -summariseModule - :: GhcMonad m => - HscEnv - -> NodeMap ModSummary -- Map of old summaries - -> IsBootInterface -- True <=> a {-# SOURCE #-} import - -> Located ModuleName -- Imported module to be summarised - -> Bool -- object code allowed? - -> Maybe (StringBuffer, ClockTime) - -> [ModuleName] -- Modules to exclude - -> m (Maybe ModSummary) -- Its new summary - -summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) - obj_allowed maybe_buf excl_mods - | wanted_mod `elem` excl_mods - = return Nothing - - | Just old_summary <- Map.lookup (wanted_mod, hsc_src) old_summary_map - = do -- Find its new timestamp; all the - -- ModSummaries in the old map have valid ml_hs_files - let location = ms_location old_summary - src_fn = expectJust "summariseModule" (ml_hs_file location) - - -- check the modification time on the source file, and - -- return the cached summary if it hasn't changed. If the - -- file has disappeared, we need to call the Finder again. - case maybe_buf of - Just (_,t) -> check_timestamp old_summary location src_fn t - Nothing -> do - m <- liftIO $ System.IO.Error.try (getModificationTime src_fn) - case m of - Right t -> check_timestamp old_summary location src_fn t - Left e | isDoesNotExistError e -> find_it - | otherwise -> liftIO $ ioError e - - | otherwise = find_it - where - dflags = hsc_dflags hsc_env - - hsc_src = if is_boot then HsBootFile else HsSrcFile - - check_timestamp old_summary location src_fn src_timestamp - | ms_hs_date old_summary == src_timestamp = do - -- update the object-file timestamp - obj_timestamp <- liftIO $ - if isObjectTarget (hscTarget (hsc_dflags hsc_env)) - || obj_allowed -- bug #1205 - then getObjTimestamp location is_boot - else return Nothing - return (Just old_summary{ ms_obj_date = obj_timestamp }) - | otherwise = - -- source changed: re-summarise. - new_summary location (ms_mod old_summary) src_fn src_timestamp - - find_it = do - -- Don't use the Finder's cache this time. If the module was - -- previously a package module, it may have now appeared on the - -- search path, so we want to consider it to be a home module. If - -- the module was previously a home module, it may have moved. - liftIO $ uncacheModule hsc_env wanted_mod - found <- liftIO $ findImportedModule hsc_env wanted_mod Nothing - case found of - Found location mod - | isJust (ml_hs_file location) -> - -- Home package - just_found location mod - | otherwise -> - -- Drop external-pkg - ASSERT(modulePackageId mod /= thisPackage dflags) - return Nothing - - err -> liftIO $ noModError dflags loc wanted_mod err - -- Not found - - just_found location mod = do - -- Adjust location to point to the hs-boot source file, - -- hi file, object file, when is_boot says so - let location' | is_boot = addBootSuffixLocn location - | otherwise = location - src_fn = expectJust "summarise2" (ml_hs_file location') - - -- Check that it exists - -- It might have been deleted since the Finder last found it - maybe_t <- liftIO $ modificationTimeIfExists src_fn - case maybe_t of - Nothing -> noHsFileErr loc src_fn - Just t -> new_summary location' mod src_fn t - - - new_summary location mod src_fn src_timestamp - = do - -- Preprocess the source file and get its imports - -- The dflags' contains the OPTIONS pragmas - (dflags', hspp_fn, buf) <- preprocessFile hsc_env src_fn Nothing maybe_buf - (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn - - when (mod_name /= wanted_mod) $ - throwOneError $ mkPlainErrMsg mod_loc $ - text "File name does not match module name:" - $$ text "Saw:" <+> quotes (ppr mod_name) - $$ text "Expected:" <+> quotes (ppr wanted_mod) - - -- Find the object timestamp, and return the summary - obj_timestamp <- liftIO $ - if isObjectTarget (hscTarget (hsc_dflags hsc_env)) - || obj_allowed -- bug #1205 - then getObjTimestamp location is_boot - else return Nothing - - return (Just (ModSummary { ms_mod = mod, - ms_hsc_src = hsc_src, - ms_location = location, - ms_hspp_file = hspp_fn, - ms_hspp_opts = dflags', - ms_hspp_buf = Just buf, - ms_srcimps = srcimps, - ms_imps = the_imps, - ms_hs_date = src_timestamp, - ms_obj_date = obj_timestamp })) - - -getObjTimestamp :: ModLocation -> Bool -> IO (Maybe ClockTime) -getObjTimestamp location is_boot - = if is_boot then return Nothing - else modificationTimeIfExists (ml_obj_file location) - - -preprocessFile :: GhcMonad m => - HscEnv - -> FilePath - -> Maybe Phase -- ^ Starting phase - -> Maybe (StringBuffer,ClockTime) - -> m (DynFlags, FilePath, StringBuffer) -preprocessFile hsc_env src_fn mb_phase Nothing - = do - (dflags', hspp_fn) <- preprocess hsc_env (src_fn, mb_phase) - buf <- liftIO $ hGetStringBuffer hspp_fn - return (dflags', hspp_fn, buf) - -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 - -- - (dflags', leftovers, warns) - <- parseDynamicNoPackageFlags dflags local_opts - checkProcessArgsResult leftovers - handleFlagWarnings dflags' warns - - 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 - | xopt Opt_Cpp dflags' = True - | dopt Opt_Pp dflags' = True - | otherwise = False - - when needs_preprocessing $ - ghcError (ProgramError "buffer needs preprocesing; interactive check disabled") - - return (dflags', src_fn, buf) - - ------------------------------------------------------------------------------ --- Error messages ------------------------------------------------------------------------------ - -noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> IO ab --- ToDo: we don't have a proper line number for this error -noModError dflags loc wanted_mod err - = throwOneError $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err - -noHsFileErr :: GhcMonad m => SrcSpan -> String -> m a -noHsFileErr loc path - = throwOneError $ mkPlainErrMsg loc $ text "Can't find" <+> text path - -packageModErr :: GhcMonad m => ModuleName -> m a -packageModErr mod - = throwOneError $ mkPlainErrMsg noSrcSpan $ - text "module" <+> quotes (ppr mod) <+> text "is a package module" - -multiRootsErr :: [ModSummary] -> IO () -multiRootsErr [] = panic "multiRootsErr" -multiRootsErr summs@(summ1:_) - = throwOneError $ mkPlainErrMsg noSrcSpan $ - text "module" <+> quotes (ppr mod) <+> - text "is defined in multiple files:" <+> - sep (map text files) - where - mod = ms_mod summ1 - files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs - -cyclicModuleErr :: [ModSummary] -> SDoc -cyclicModuleErr ms - = hang (ptext (sLit "Module imports form a cycle for modules:")) - 2 (vcat (map show_one ms)) - where - mods_in_cycle = map ms_mod_name ms - imp_modname = unLoc . ideclName . unLoc - just_in_cycle = filter ((`elem` mods_in_cycle) . imp_modname) - - show_one ms = - vcat [ show_mod (ms_hsc_src ms) (ms_mod_name ms) <+> - maybe empty (parens . text) (ml_hs_file (ms_location ms)), - nest 2 $ ptext (sLit "imports:") <+> vcat [ - pp_imps HsBootFile (just_in_cycle $ ms_srcimps ms), - pp_imps HsSrcFile (just_in_cycle $ ms_imps ms) ] - ] - show_mod hsc_src mod = ppr mod <> text (hscSourceString hsc_src) - pp_imps src imps = fsep (map (show_mod src . unLoc . ideclName . unLoc) imps) - - --- | Inform GHC that the working directory has changed. GHC will flush --- its cache of module locations, since it may no longer be valid. --- --- Note: Before changing the working directory make sure all threads running --- in the same session have stopped. If you change the working directory, --- you should also unload the current program (set targets to empty, --- followed by load). -workingDirectoryChanged :: GhcMonad m => m () -workingDirectoryChanged = withSession $ (liftIO . flushFinderCaches) - --- ----------------------------------------------------------------------------- --- inspecting the session +-- %************************************************************************ +-- %* * +-- Inspecting the session +-- %* * +-- %************************************************************************ -- | Get the module dependency graph. getModuleGraph :: GhcMonad m => m ModuleGraph -- ToDo: DiGraph ModSummary @@ -2368,11 +918,11 @@ minf_type_env :: TypeEnv, minf_exports :: NameSet, -- ToDo, [AvailInfo] like ModDetails? minf_rdr_env :: Maybe GlobalRdrEnv, -- Nothing for a compiled/package mod - minf_instances :: [Instance] + minf_instances :: [Instance], + minf_iface :: Maybe ModIface #ifdef GHCI - ,minf_modBreaks :: ModBreaks + ,minf_modBreaks :: ModBreaks #endif - -- ToDo: this should really contain the ModIface too } -- We don't want HomeModInfo here, because a ModuleInfo applies -- to package modules too. @@ -2382,11 +932,13 @@ getModuleInfo mdl = withSession $ \hsc_env -> do let mg = hsc_mod_graph hsc_env if mdl `elem` map ms_mod mg - then liftIO $ getHomeModuleInfo hsc_env (moduleName mdl) + then liftIO $ getHomeModuleInfo hsc_env mdl else do {- if isHomeModule (hsc_dflags hsc_env) mdl then return Nothing else -} liftIO $ getPackageModuleInfo hsc_env mdl + -- ToDo: we don't understand what the following comment means. + -- (SDM, 19/7/2011) -- getPackageModuleInfo will attempt to find the interface, so -- we don't want to call it for a home module, just in case there -- was a problem loading the module and the interface doesn't @@ -2395,11 +947,16 @@ getPackageModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) #ifdef GHCI getPackageModuleInfo hsc_env mdl = do - (_msgs, mb_avails) <- getModuleExports hsc_env mdl + mb_avails <- hscGetModuleExports hsc_env mdl + -- This is the only use of hscGetModuleExports. Perhaps we could use + -- hscRnImportDecls instead, but that does a lot more than we need + -- (building instance environment, checking family instance consistency + -- etc.). case mb_avails of Nothing -> return Nothing Just avails -> do - eps <- readIORef (hsc_EPS hsc_env) + eps <- hscEPS hsc_env + iface <- lookupModuleIface hsc_env mdl let names = availsToNameSet avails pte = eps_PTE eps @@ -2411,30 +968,42 @@ minf_exports = names, minf_rdr_env = Just $! availsToGlobalRdrEnv (moduleName mdl) avails, minf_instances = error "getModuleInfo: instances for package module unimplemented", + minf_iface = iface, minf_modBreaks = emptyModBreaks })) #else +-- bogusly different for non-GHCI (ToDo) getPackageModuleInfo _hsc_env _mdl = do - -- bogusly different for non-GHCI (ToDo) return Nothing #endif -getHomeModuleInfo :: HscEnv -> ModuleName -> IO (Maybe ModuleInfo) +getHomeModuleInfo :: HscEnv -> Module -> IO (Maybe ModuleInfo) getHomeModuleInfo hsc_env mdl = - case lookupUFM (hsc_HPT hsc_env) mdl of + case lookupUFM (hsc_HPT hsc_env) (moduleName mdl) of Nothing -> return Nothing Just hmi -> do let details = hm_details hmi + iface <- lookupModuleIface hsc_env mdl return (Just (ModuleInfo { minf_type_env = md_types details, minf_exports = availsToNameSet (md_exports details), minf_rdr_env = mi_globals $! hm_iface hmi, - minf_instances = md_insts details + minf_instances = md_insts details, + minf_iface = iface #ifdef GHCI ,minf_modBreaks = getModBreaks hmi #endif })) +lookupModuleIface :: HscEnv -> Module -> IO (Maybe ModIface) +lookupModuleIface env m = do + eps <- hscEPS env + let dflags = hsc_dflags env + pkgIfaceT = eps_PIT eps + homePkgT = hsc_HPT env + iface = lookupIfaceByModule dflags homePkgT pkgIfaceT m + return iface + -- | The list of top-level entities defined in a module modInfoTyThings :: ModuleInfo -> [TyThing] modInfoTyThings minf = typeEnvElts (minf_type_env minf) @@ -2471,6 +1040,9 @@ return $! lookupType (hsc_dflags hsc_env) (hsc_HPT hsc_env) (eps_PTE eps) name +modInfoIface :: ModuleInfo -> Maybe ModIface +modInfoIface = minf_iface + #ifdef GHCI modInfoModBreaks :: ModuleInfo -> ModBreaks modInfoModBreaks = minf_modBreaks @@ -2564,7 +1136,7 @@ getTokenStream :: GhcMonad m => Module -> m [Located Token] getTokenStream mod = do (sourceFile, source, flags) <- getModuleSourceAndFlags mod - let startLoc = mkSrcLoc (mkFastString sourceFile) 1 1 + let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1 case lexTokenStream source startLoc flags of POk _ ts -> return ts PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err) @@ -2575,7 +1147,7 @@ getRichTokenStream :: GhcMonad m => Module -> m [(Located Token, String)] getRichTokenStream mod = do (sourceFile, source, flags) <- getModuleSourceAndFlags mod - let startLoc = mkSrcLoc (mkFastString sourceFile) 1 1 + let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1 case lexTokenStream source startLoc flags of POk _ ts -> return $ addSourceToTokens startLoc source ts PFailed span err -> throw $ mkSrcErr (unitBag $ mkPlainErrMsg span err) @@ -2583,21 +1155,22 @@ -- | Given a source location and a StringBuffer corresponding to this -- location, return a rich token stream with the source associated to the -- tokens. -addSourceToTokens :: SrcLoc -> StringBuffer -> [Located Token] +addSourceToTokens :: RealSrcLoc -> StringBuffer -> [Located Token] -> [(Located Token, String)] addSourceToTokens _ _ [] = [] addSourceToTokens loc buf (t@(L span _) : ts) - | not (isGoodSrcSpan span) = (t,"") : addSourceToTokens loc buf ts - | otherwise = (t,str) : addSourceToTokens newLoc newBuf ts - where - (newLoc, newBuf, str) = go "" loc buf - start = srcSpanStart span - end = srcSpanEnd span - go acc loc buf | loc < start = go acc nLoc nBuf - | start <= loc && loc < end = go (ch:acc) nLoc nBuf - | otherwise = (loc, buf, reverse acc) - where (ch, nBuf) = nextChar buf - nLoc = advanceSrcLoc loc ch + = case span of + UnhelpfulSpan _ -> (t,"") : addSourceToTokens loc buf ts + RealSrcSpan s -> (t,str) : addSourceToTokens newLoc newBuf ts + where + (newLoc, newBuf, str) = go "" loc buf + start = realSrcSpanStart s + end = realSrcSpanEnd s + go acc loc buf | loc < start = go acc nLoc nBuf + | start <= loc && loc < end = go (ch:acc) nLoc nBuf + | otherwise = (loc, buf, reverse acc) + where (ch, nBuf) = nextChar buf + nLoc = advanceSrcLoc loc ch -- | Take a rich token stream such as produced from 'getRichTokenStream' and @@ -2605,21 +1178,26 @@ -- insignificant whitespace.) showRichTokenStream :: [(Located Token, String)] -> String showRichTokenStream ts = go startLoc ts "" - where sourceFile = srcSpanFile (getLoc . fst . head $ ts) - startLoc = mkSrcLoc sourceFile 1 1 + where sourceFile = getFile $ map (getLoc . fst) ts + getFile [] = panic "showRichTokenStream: No source file found" + getFile (UnhelpfulSpan _ : xs) = getFile xs + getFile (RealSrcSpan s : _) = srcSpanFile s + startLoc = mkRealSrcLoc sourceFile 1 1 go _ [] = id go loc ((L span _, str):ts) - | not (isGoodSrcSpan span) = go loc ts - | locLine == tokLine = ((replicate (tokCol - locCol) ' ') ++) - . (str ++) - . go tokEnd ts - | otherwise = ((replicate (tokLine - locLine) '\n') ++) - . ((replicate tokCol ' ') ++) - . (str ++) - . go tokEnd ts - where (locLine, locCol) = (srcLocLine loc, srcLocCol loc) - (tokLine, tokCol) = (srcSpanStartLine span, srcSpanStartCol span) - tokEnd = srcSpanEnd span + = case span of + UnhelpfulSpan _ -> go loc ts + RealSrcSpan s + | locLine == tokLine -> ((replicate (tokCol - locCol) ' ') ++) + . (str ++) + . go tokEnd ts + | otherwise -> ((replicate (tokLine - locLine) '\n') ++) + . ((replicate tokCol ' ') ++) + . (str ++) + . go tokEnd ts + where (locLine, locCol) = (srcLocLine loc, srcLocCol loc) + (tokLine, tokCol) = (srcSpanStartLine s, srcSpanStartCol s) + tokEnd = realSrcSpanEnd s -- ----------------------------------------------------------------------------- -- Interactive evaluation @@ -2701,8 +1279,30 @@ -- | Returns the 'TyThing' for a 'Name'. The 'Name' may refer to any -- entity known to GHC, including 'Name's defined using 'runStmt'. lookupName :: GhcMonad m => Name -> m (Maybe TyThing) -lookupName name = withSession $ \hsc_env -> do - mb_tything <- ioMsg $ tcRnLookupName hsc_env name - return mb_tything - -- XXX: calls panic in some circumstances; is that ok? +lookupName name = + withSession $ \hsc_env -> + liftIO $ hscTcRcLookupName hsc_env name + +-- ----------------------------------------------------------------------------- +-- Pure API + +-- | A pure interface to the module parser. +-- +parser :: String -- ^ Haskell module source text (full Unicode is supported) + -> DynFlags -- ^ the flags + -> FilePath -- ^ the filename (for source locations) + -> Either ErrorMessages (WarningMessages, Located (HsModule RdrName)) + +parser str dflags filename = + let + loc = mkRealSrcLoc (mkFastString filename) 1 1 + buf = stringToStringBuffer str + in + case unP Parser.parseModule (mkPState dflags buf loc) of + + PFailed span err -> + Left (unitBag (mkPlainErrMsg span err)) + POk pst rdr_module -> + let (warns,_) = getMessages pst in + Right (warns, rdr_module) diff -Nru ghc-7.0.3/compiler/main/GhcMake.hs ghc-7.2.1/compiler/main/GhcMake.hs --- ghc-7.0.3/compiler/main/GhcMake.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/compiler/main/GhcMake.hs 2011-08-07 17:10:05.000000000 +0000 @@ -0,0 +1,1492 @@ +{-# LANGUAGE ScopedTypeVariables #-} + +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow, 2011 +-- +-- This module implements multi-module compilation, and is used +-- by --make and GHCi. +-- +-- ----------------------------------------------------------------------------- + +module GhcMake( + depanal, + load, LoadHowMuch(..), + + topSortModuleGraph, + + noModError, cyclicModuleErr + ) where + +#include "HsVersions.h" + +#ifdef GHCI +import qualified Linker ( unload ) +#endif + +import DriverPipeline +import DriverPhases +import GhcMonad +import Module +import HscTypes +import ErrUtils +import DynFlags +import HsSyn hiding ((<.>)) +import Finder +import HeaderInfo +import TcIface ( typecheckIface ) +import TcRnMonad ( initIfaceCheck ) +import RdrName ( RdrName ) + +import Exception ( evaluate, tryIO ) +import Panic +import SysTools +import BasicTypes +import SrcLoc +import Util +import Digraph +import Bag ( listToBag ) +import Maybes ( expectJust, mapCatMaybes ) +import StringBuffer +import FastString +import Outputable +import UniqFM + +import qualified Data.Map as Map +import qualified FiniteMap as Map( insertListWith) + +import System.Directory ( doesFileExist, getModificationTime ) +import System.IO ( fixIO ) +import System.IO.Error ( isDoesNotExistError ) +import System.Time ( ClockTime ) +import System.FilePath +import Control.Monad +import Data.Maybe +import Data.List +import qualified Data.List as List + +-- ----------------------------------------------------------------------------- +-- Loading the program + +-- | Perform a dependency analysis starting from the current targets +-- and update the session with the new module graph. +-- +-- Dependency analysis entails parsing the @import@ directives and may +-- therefore require running certain preprocessors. +-- +-- Note that each 'ModSummary' in the module graph caches its 'DynFlags'. +-- These 'DynFlags' are determined by the /current/ session 'DynFlags' and the +-- @OPTIONS@ and @LANGUAGE@ pragmas of the parsed module. Thus if you want to +-- changes to the 'DynFlags' to take effect you need to call this function +-- again. +-- +depanal :: GhcMonad m => + [ModuleName] -- ^ excluded modules + -> Bool -- ^ allow duplicate roots + -> m ModuleGraph +depanal excluded_mods allow_dup_roots = do + hsc_env <- getSession + let + dflags = hsc_dflags hsc_env + targets = hsc_targets hsc_env + old_graph = hsc_mod_graph hsc_env + + liftIO $ showPass dflags "Chasing dependencies" + liftIO $ debugTraceMsg dflags 2 (hcat [ + text "Chasing modules from: ", + hcat (punctuate comma (map pprTarget targets))]) + + mod_graph <- liftIO $ downsweep hsc_env old_graph excluded_mods allow_dup_roots + modifySession $ \_ -> hsc_env { hsc_mod_graph = mod_graph } + return mod_graph + +-- | Describes which modules of the module graph need to be loaded. +data LoadHowMuch + = LoadAllTargets + -- ^ Load all targets and its dependencies. + | LoadUpTo ModuleName + -- ^ Load only the given module and its dependencies. + | LoadDependenciesOf ModuleName + -- ^ Load only the dependencies of the given module, but not the module + -- itself. + +-- | Try to load the program. See 'LoadHowMuch' for the different modes. +-- +-- This function implements the core of GHC's @--make@ mode. It preprocesses, +-- compiles and loads the specified modules, avoiding re-compilation wherever +-- possible. Depending on the target (see 'DynFlags.hscTarget') compilating +-- and loading may result in files being created on disk. +-- +-- Calls the 'reportModuleCompilationResult' callback after each compiling +-- each module, whether successful or not. +-- +-- Throw a 'SourceError' if errors are encountered before the actual +-- compilation starts (e.g., during dependency analysis). All other errors +-- are reported using the callback. +-- +load :: GhcMonad m => LoadHowMuch -> m SuccessFlag +load how_much = do + mod_graph <- depanal [] False + load2 how_much mod_graph + +load2 :: GhcMonad m => LoadHowMuch -> [ModSummary] + -> m SuccessFlag +load2 how_much mod_graph = do + guessOutputFile + hsc_env <- getSession + + let hpt1 = hsc_HPT hsc_env + let dflags = hsc_dflags hsc_env + + -- The "bad" boot modules are the ones for which we have + -- B.hs-boot in the module graph, but no B.hs + -- The downsweep should have ensured this does not happen + -- (see msDeps) + let all_home_mods = [ms_mod_name s + | s <- mod_graph, not (isBootSummary s)] + bad_boot_mods = [s | s <- mod_graph, isBootSummary s, + not (ms_mod_name s `elem` all_home_mods)] + ASSERT( null bad_boot_mods ) return () + + -- check that the module given in HowMuch actually exists, otherwise + -- topSortModuleGraph will bomb later. + let checkHowMuch (LoadUpTo m) = checkMod m + checkHowMuch (LoadDependenciesOf m) = checkMod m + checkHowMuch _ = id + + checkMod m and_then + | m `elem` all_home_mods = and_then + | otherwise = do + liftIO $ errorMsg dflags (text "no such module:" <+> + quotes (ppr m)) + return Failed + + checkHowMuch how_much $ do + + -- mg2_with_srcimps drops the hi-boot nodes, returning a + -- graph with cycles. Among other things, it is used for + -- backing out partially complete cycles following a failed + -- upsweep, and for removing from hpt all the modules + -- not in strict downwards closure, during calls to compile. + let mg2_with_srcimps :: [SCC ModSummary] + mg2_with_srcimps = topSortModuleGraph True mod_graph Nothing + + -- If we can determine that any of the {-# SOURCE #-} imports + -- are definitely unnecessary, then emit a warning. + warnUnnecessarySourceImports mg2_with_srcimps + + let + -- check the stability property for each module. + stable_mods@(stable_obj,stable_bco) + = checkStability hpt1 mg2_with_srcimps all_home_mods + + -- prune bits of the HPT which are definitely redundant now, + -- to save space. + pruned_hpt = pruneHomePackageTable hpt1 + (flattenSCCs mg2_with_srcimps) + stable_mods + + _ <- liftIO $ evaluate pruned_hpt + + -- before we unload anything, make sure we don't leave an old + -- interactive context around pointing to dead bindings. Also, + -- write the pruned HPT to allow the old HPT to be GC'd. + modifySession $ \_ -> hsc_env{ hsc_IC = emptyInteractiveContext, + hsc_HPT = pruned_hpt } + + liftIO $ debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$ + text "Stable BCO:" <+> ppr stable_bco) + + -- Unload any modules which are going to be re-linked this time around. + let stable_linkables = [ linkable + | m <- stable_obj++stable_bco, + Just hmi <- [lookupUFM pruned_hpt m], + Just linkable <- [hm_linkable hmi] ] + liftIO $ unload hsc_env stable_linkables + + -- We could at this point detect cycles which aren't broken by + -- a source-import, and complain immediately, but it seems better + -- to let upsweep_mods do this, so at least some useful work gets + -- done before the upsweep is abandoned. + --hPutStrLn stderr "after tsort:\n" + --hPutStrLn stderr (showSDoc (vcat (map ppr mg2))) + + -- Now do the upsweep, calling compile for each module in + -- turn. Final result is version 3 of everything. + + -- Topologically sort the module graph, this time including hi-boot + -- nodes, and possibly just including the portion of the graph + -- reachable from the module specified in the 2nd argument to load. + -- This graph should be cycle-free. + -- If we're restricting the upsweep to a portion of the graph, we + -- also want to retain everything that is still stable. + let full_mg :: [SCC ModSummary] + full_mg = topSortModuleGraph False mod_graph Nothing + + maybe_top_mod = case how_much of + LoadUpTo m -> Just m + LoadDependenciesOf m -> Just m + _ -> Nothing + + partial_mg0 :: [SCC ModSummary] + partial_mg0 = topSortModuleGraph False mod_graph maybe_top_mod + + -- LoadDependenciesOf m: we want the upsweep to stop just + -- short of the specified module (unless the specified module + -- is stable). + partial_mg + | LoadDependenciesOf _mod <- how_much + = ASSERT( case last partial_mg0 of + AcyclicSCC ms -> ms_mod_name ms == _mod; _ -> False ) + List.init partial_mg0 + | otherwise + = partial_mg0 + + stable_mg = + [ AcyclicSCC ms + | AcyclicSCC ms <- full_mg, + ms_mod_name ms `elem` stable_obj++stable_bco, + ms_mod_name ms `notElem` [ ms_mod_name ms' | + AcyclicSCC ms' <- partial_mg ] ] + + mg = stable_mg ++ partial_mg + + -- clean up between compilations + let cleanup hsc_env = intermediateCleanTempFiles dflags + (flattenSCCs mg2_with_srcimps) + hsc_env + + liftIO $ debugTraceMsg dflags 2 (hang (text "Ready for upsweep") + 2 (ppr mg)) + + setSession hsc_env{ hsc_HPT = emptyHomePackageTable } + (upsweep_ok, modsUpswept) + <- upsweep pruned_hpt stable_mods cleanup mg + + -- Make modsDone be the summaries for each home module now + -- available; this should equal the domain of hpt3. + -- Get in in a roughly top .. bottom order (hence reverse). + + let modsDone = reverse modsUpswept + + -- Try and do linking in some form, depending on whether the + -- upsweep was completely or only partially successful. + + if succeeded upsweep_ok + + then + -- Easy; just relink it all. + do liftIO $ debugTraceMsg dflags 2 (text "Upsweep completely successful.") + + -- Clean up after ourselves + hsc_env1 <- getSession + liftIO $ intermediateCleanTempFiles dflags modsDone hsc_env1 + + -- Issue a warning for the confusing case where the user + -- said '-o foo' but we're not going to do any linking. + -- We attempt linking if either (a) one of the modules is + -- called Main, or (b) the user said -no-hs-main, indicating + -- that main() is going to come from somewhere else. + -- + let ofile = outputFile dflags + let no_hs_main = dopt Opt_NoHsMain dflags + let + main_mod = mainModIs dflags + a_root_is_Main = any ((==main_mod).ms_mod) mod_graph + do_linking = a_root_is_Main || no_hs_main || ghcLink dflags == LinkDynLib + + when (ghcLink dflags == LinkBinary + && isJust ofile && not do_linking) $ + liftIO $ debugTraceMsg dflags 1 $ + text ("Warning: output was redirected with -o, " ++ + "but no output will be generated\n" ++ + "because there is no " ++ + moduleNameString (moduleName main_mod) ++ " module.") + + -- link everything together + linkresult <- liftIO $ link (ghcLink dflags) dflags do_linking (hsc_HPT hsc_env1) + + loadFinish Succeeded linkresult + + else + -- Tricky. We need to back out the effects of compiling any + -- half-done cycles, both so as to clean up the top level envs + -- and to avoid telling the interactive linker to link them. + do liftIO $ debugTraceMsg dflags 2 (text "Upsweep partially successful.") + + let modsDone_names + = map ms_mod modsDone + let mods_to_zap_names + = findPartiallyCompletedCycles modsDone_names + mg2_with_srcimps + let mods_to_keep + = filter ((`notElem` mods_to_zap_names).ms_mod) + modsDone + + hsc_env1 <- getSession + let hpt4 = retainInTopLevelEnvs (map ms_mod_name mods_to_keep) + (hsc_HPT hsc_env1) + + -- Clean up after ourselves + liftIO $ intermediateCleanTempFiles dflags mods_to_keep hsc_env1 + + -- there should be no Nothings where linkables should be, now + ASSERT(all (isJust.hm_linkable) + (eltsUFM (hsc_HPT hsc_env))) do + + -- Link everything together + linkresult <- liftIO $ link (ghcLink dflags) dflags False hpt4 + + modifySession $ \hsc_env -> hsc_env{ hsc_HPT = hpt4 } + loadFinish Failed linkresult + +-- Finish up after a load. + +-- If the link failed, unload everything and return. +loadFinish :: GhcMonad m => + SuccessFlag -> SuccessFlag + -> m SuccessFlag +loadFinish _all_ok Failed + = do hsc_env <- getSession + liftIO $ unload hsc_env [] + modifySession discardProg + return Failed + +-- Empty the interactive context and set the module context to the topmost +-- newly loaded module, or the Prelude if none were loaded. +loadFinish all_ok Succeeded + = do modifySession $ \hsc_env -> hsc_env{ hsc_IC = emptyInteractiveContext } + return all_ok + + +-- Forget the current program, but retain the persistent info in HscEnv +discardProg :: HscEnv -> HscEnv +discardProg hsc_env + = hsc_env { hsc_mod_graph = emptyMG, + hsc_IC = emptyInteractiveContext, + hsc_HPT = emptyHomePackageTable } + +intermediateCleanTempFiles :: DynFlags -> [ModSummary] -> HscEnv -> IO () +intermediateCleanTempFiles dflags summaries hsc_env + = cleanTempFilesExcept dflags except + where + except = + -- Save preprocessed files. The preprocessed file *might* be + -- the same as the source file, but that doesn't do any + -- harm. + map ms_hspp_file summaries ++ + -- Save object files for loaded modules. The point of this + -- is that we might have generated and compiled a stub C + -- file, and in the case of GHCi the object file will be a + -- temporary file which we must not remove because we need + -- to load/link it later. + hptObjs (hsc_HPT hsc_env) + +-- | If there is no -o option, guess the name of target executable +-- by using top-level source file name as a base. +guessOutputFile :: GhcMonad m => m () +guessOutputFile = modifySession $ \env -> + let dflags = hsc_dflags env + mod_graph = hsc_mod_graph env + mainModuleSrcPath :: Maybe String + mainModuleSrcPath = do + let isMain = (== mainModIs dflags) . ms_mod + [ms] <- return (filter isMain mod_graph) + ml_hs_file (ms_location ms) + name = fmap dropExtension mainModuleSrcPath + +#if defined(mingw32_HOST_OS) + -- we must add the .exe extention unconditionally here, otherwise + -- when name has an extension of its own, the .exe extension will + -- not be added by DriverPipeline.exeFileName. See #2248 + name_exe = fmap (<.> "exe") name +#else + name_exe = name +#endif + in + case outputFile dflags of + Just _ -> env + Nothing -> env { hsc_dflags = dflags { outputFile = name_exe } } + +-- ----------------------------------------------------------------------------- + +-- | Prune the HomePackageTable +-- +-- Before doing an upsweep, we can throw away: +-- +-- - For non-stable modules: +-- - all ModDetails, all linked code +-- - all unlinked code that is out of date with respect to +-- the source file +-- +-- This is VERY IMPORTANT otherwise we'll end up requiring 2x the +-- space at the end of the upsweep, because the topmost ModDetails of the +-- old HPT holds on to the entire type environment from the previous +-- compilation. + +pruneHomePackageTable + :: HomePackageTable + -> [ModSummary] + -> ([ModuleName],[ModuleName]) + -> HomePackageTable + +pruneHomePackageTable hpt summ (stable_obj, stable_bco) + = mapUFM prune hpt + where prune hmi + | is_stable modl = hmi' + | otherwise = hmi'{ hm_details = emptyModDetails } + where + modl = moduleName (mi_module (hm_iface hmi)) + hmi' | Just l <- hm_linkable hmi, linkableTime l < ms_hs_date ms + = hmi{ hm_linkable = Nothing } + | otherwise + = hmi + where ms = expectJust "prune" (lookupUFM ms_map modl) + + ms_map = listToUFM [(ms_mod_name ms, ms) | ms <- summ] + + is_stable m = m `elem` stable_obj || m `elem` stable_bco + +-- ----------------------------------------------------------------------------- + +-- Return (names of) all those in modsDone who are part of a cycle +-- as defined by theGraph. +findPartiallyCompletedCycles :: [Module] -> [SCC ModSummary] -> [Module] +findPartiallyCompletedCycles modsDone theGraph + = chew theGraph + where + chew [] = [] + chew ((AcyclicSCC _):rest) = chew rest -- acyclic? not interesting. + chew ((CyclicSCC vs):rest) + = let names_in_this_cycle = nub (map ms_mod vs) + mods_in_this_cycle + = nub ([done | done <- modsDone, + done `elem` names_in_this_cycle]) + chewed_rest = chew rest + in + if notNull mods_in_this_cycle + && length mods_in_this_cycle < length names_in_this_cycle + then mods_in_this_cycle ++ chewed_rest + else chewed_rest + + +-- --------------------------------------------------------------------------- +-- Unloading + +unload :: HscEnv -> [Linkable] -> IO () +unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables' + = case ghcLink (hsc_dflags hsc_env) of +#ifdef GHCI + LinkInMemory -> Linker.unload (hsc_dflags hsc_env) stable_linkables +#else + LinkInMemory -> panic "unload: no interpreter" + -- urgh. avoid warnings: + hsc_env stable_linkables +#endif + _other -> return () + +-- ----------------------------------------------------------------------------- + +{- | + + Stability tells us which modules definitely do not need to be recompiled. + There are two main reasons for having stability: + + - avoid doing a complete upsweep of the module graph in GHCi when + modules near the bottom of the tree have not changed. + + - to tell GHCi when it can load object code: we can only load object code + for a module when we also load object code fo all of the imports of the + module. So we need to know that we will definitely not be recompiling + any of these modules, and we can use the object code. + + The stability check is as follows. Both stableObject and + stableBCO are used during the upsweep phase later. + +@ + stable m = stableObject m || stableBCO m + + stableObject m = + all stableObject (imports m) + && old linkable does not exist, or is == on-disk .o + && date(on-disk .o) > date(.hs) + + stableBCO m = + all stable (imports m) + && date(BCO) > date(.hs) +@ + + These properties embody the following ideas: + + - if a module is stable, then: + + - if it has been compiled in a previous pass (present in HPT) + then it does not need to be compiled or re-linked. + + - if it has not been compiled in a previous pass, + then we only need to read its .hi file from disk and + link it to produce a 'ModDetails'. + + - if a modules is not stable, we will definitely be at least + re-linking, and possibly re-compiling it during the 'upsweep'. + All non-stable modules can (and should) therefore be unlinked + before the 'upsweep'. + + - Note that objects are only considered stable if they only depend + on other objects. We can't link object code against byte code. +-} + +checkStability + :: HomePackageTable -- HPT from last compilation + -> [SCC ModSummary] -- current module graph (cyclic) + -> [ModuleName] -- all home modules + -> ([ModuleName], -- stableObject + [ModuleName]) -- stableBCO + +checkStability hpt sccs all_home_mods = foldl checkSCC ([],[]) sccs + where + checkSCC (stable_obj, stable_bco) scc0 + | stableObjects = (scc_mods ++ stable_obj, stable_bco) + | stableBCOs = (stable_obj, scc_mods ++ stable_bco) + | otherwise = (stable_obj, stable_bco) + where + scc = flattenSCC scc0 + scc_mods = map ms_mod_name scc + home_module m = m `elem` all_home_mods && m `notElem` scc_mods + + scc_allimps = nub (filter home_module (concatMap ms_home_allimps scc)) + -- all imports outside the current SCC, but in the home pkg + + stable_obj_imps = map (`elem` stable_obj) scc_allimps + stable_bco_imps = map (`elem` stable_bco) scc_allimps + + stableObjects = + and stable_obj_imps + && all object_ok scc + + stableBCOs = + and (zipWith (||) stable_obj_imps stable_bco_imps) + && all bco_ok scc + + object_ok ms + | Just t <- ms_obj_date ms = t >= ms_hs_date ms + && same_as_prev t + | otherwise = False + where + same_as_prev t = case lookupUFM hpt (ms_mod_name ms) of + Just hmi | Just l <- hm_linkable hmi + -> isObjectLinkable l && t == linkableTime l + _other -> True + -- why '>=' rather than '>' above? If the filesystem stores + -- times to the nearset second, we may occasionally find that + -- the object & source have the same modification time, + -- especially if the source was automatically generated + -- and compiled. Using >= is slightly unsafe, but it matches + -- make's behaviour. + + bco_ok ms + = case lookupUFM hpt (ms_mod_name ms) of + Just hmi | Just l <- hm_linkable hmi -> + not (isObjectLinkable l) && + linkableTime l >= ms_hs_date ms + _other -> False + +-- ----------------------------------------------------------------------------- + +-- | The upsweep +-- +-- This is where we compile each module in the module graph, in a pass +-- from the bottom to the top of the graph. +-- +-- There better had not be any cyclic groups here -- we check for them. + +upsweep + :: GhcMonad m + => HomePackageTable -- ^ HPT from last time round (pruned) + -> ([ModuleName],[ModuleName]) -- ^ stable modules (see checkStability) + -> (HscEnv -> IO ()) -- ^ How to clean up unwanted tmp files + -> [SCC ModSummary] -- ^ Mods to do (the worklist) + -> m (SuccessFlag, + [ModSummary]) + -- ^ Returns: + -- + -- 1. A flag whether the complete upsweep was successful. + -- 2. The 'HscEnv' in the monad has an updated HPT + -- 3. A list of modules which succeeded loading. + +upsweep old_hpt stable_mods cleanup sccs = do + (res, done) <- upsweep' old_hpt [] sccs 1 (length sccs) + return (res, reverse done) + where + + upsweep' _old_hpt done + [] _ _ + = return (Succeeded, done) + + upsweep' _old_hpt done + (CyclicSCC ms:_) _ _ + = do dflags <- getSessionDynFlags + liftIO $ fatalErrorMsg dflags (cyclicModuleErr ms) + return (Failed, done) + + upsweep' old_hpt done + (AcyclicSCC mod:mods) mod_index nmods + = do -- putStrLn ("UPSWEEP_MOD: hpt = " ++ + -- show (map (moduleUserString.moduleName.mi_module.hm_iface) + -- (moduleEnvElts (hsc_HPT hsc_env))) + let logger _mod = defaultWarnErrLogger + + hsc_env <- getSession + + -- Remove unwanted tmp files between compilations + liftIO (cleanup hsc_env) + + mb_mod_info + <- handleSourceError + (\err -> do logger mod (Just err); return Nothing) $ do + mod_info <- liftIO $ upsweep_mod hsc_env old_hpt stable_mods + mod mod_index nmods + logger mod Nothing -- log warnings + return (Just mod_info) + + case mb_mod_info of + Nothing -> return (Failed, done) + Just mod_info -> do + let this_mod = ms_mod_name mod + + -- Add new info to hsc_env + hpt1 = addToUFM (hsc_HPT hsc_env) this_mod mod_info + hsc_env1 = hsc_env { hsc_HPT = hpt1 } + + -- Space-saving: delete the old HPT entry + -- for mod BUT if mod is a hs-boot + -- node, don't delete it. For the + -- interface, the HPT entry is probaby for the + -- main Haskell source file. Deleting it + -- would force the real module to be recompiled + -- every time. + old_hpt1 | isBootSummary mod = old_hpt + | otherwise = delFromUFM old_hpt this_mod + + done' = mod:done + + -- fixup our HomePackageTable after we've finished compiling + -- a mutually-recursive loop. See reTypecheckLoop, below. + hsc_env2 <- liftIO $ reTypecheckLoop hsc_env1 mod done' + setSession hsc_env2 + + upsweep' old_hpt1 done' mods (mod_index+1) nmods + +-- | Compile a single module. Always produce a Linkable for it if +-- successful. If no compilation happened, return the old Linkable. +upsweep_mod :: HscEnv + -> HomePackageTable + -> ([ModuleName],[ModuleName]) + -> ModSummary + -> Int -- index of module + -> Int -- total number of modules + -> IO HomeModInfo + +upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods + = let + this_mod_name = ms_mod_name summary + this_mod = ms_mod summary + mb_obj_date = ms_obj_date summary + obj_fn = ml_obj_file (ms_location summary) + hs_date = ms_hs_date summary + + is_stable_obj = this_mod_name `elem` stable_obj + is_stable_bco = this_mod_name `elem` stable_bco + + old_hmi = lookupUFM old_hpt this_mod_name + + -- We're using the dflags for this module now, obtained by + -- applying any options in its LANGUAGE & OPTIONS_GHC pragmas. + dflags = ms_hspp_opts summary + prevailing_target = hscTarget (hsc_dflags hsc_env) + local_target = hscTarget dflags + + -- If OPTIONS_GHC contains -fasm or -fvia-C, be careful that + -- we don't do anything dodgy: these should only work to change + -- from -fvia-C to -fasm and vice-versa, otherwise we could + -- end up trying to link object code to byte code. + target = if prevailing_target /= local_target + && (not (isObjectTarget prevailing_target) + || not (isObjectTarget local_target)) + then prevailing_target + else local_target + + -- store the corrected hscTarget into the summary + summary' = summary{ ms_hspp_opts = dflags { hscTarget = target } } + + -- The old interface is ok if + -- a) we're compiling a source file, and the old HPT + -- entry is for a source file + -- b) we're compiling a hs-boot file + -- Case (b) allows an hs-boot file to get the interface of its + -- real source file on the second iteration of the compilation + -- manager, but that does no harm. Otherwise the hs-boot file + -- will always be recompiled + + mb_old_iface + = case old_hmi of + Nothing -> Nothing + Just hm_info | isBootSummary summary -> Just iface + | not (mi_boot iface) -> Just iface + | otherwise -> Nothing + where + iface = hm_iface hm_info + + compile_it :: Maybe Linkable -> SourceModified -> IO HomeModInfo + compile_it mb_linkable src_modified = + compile hsc_env summary' mod_index nmods + mb_old_iface mb_linkable src_modified + + compile_it_discard_iface :: Maybe Linkable -> SourceModified + -> IO HomeModInfo + compile_it_discard_iface mb_linkable src_modified = + compile hsc_env summary' mod_index nmods + Nothing mb_linkable src_modified + + -- With the HscNothing target we create empty linkables to avoid + -- recompilation. We have to detect these to recompile anyway if + -- the target changed since the last compile. + is_fake_linkable + | Just hmi <- old_hmi, Just l <- hm_linkable hmi = + null (linkableUnlinked l) + | otherwise = + -- we have no linkable, so it cannot be fake + False + + implies False _ = True + implies True x = x + + in + case () of + _ + -- Regardless of whether we're generating object code or + -- byte code, we can always use an existing object file + -- if it is *stable* (see checkStability). + | is_stable_obj, Just hmi <- old_hmi -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "skipping stable obj mod:" <+> ppr this_mod_name) + return hmi + -- object is stable, and we have an entry in the + -- old HPT: nothing to do + + | is_stable_obj, isNothing old_hmi -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "compiling stable on-disk mod:" <+> ppr this_mod_name) + linkable <- liftIO $ findObjectLinkable this_mod obj_fn + (expectJust "upsweep1" mb_obj_date) + compile_it (Just linkable) SourceUnmodifiedAndStable + -- object is stable, but we need to load the interface + -- off disk to make a HMI. + + | not (isObjectTarget target), is_stable_bco, + (target /= HscNothing) `implies` not is_fake_linkable -> + ASSERT(isJust old_hmi) -- must be in the old_hpt + let Just hmi = old_hmi in do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "skipping stable BCO mod:" <+> ppr this_mod_name) + return hmi + -- BCO is stable: nothing to do + + | not (isObjectTarget target), + Just hmi <- old_hmi, + Just l <- hm_linkable hmi, + not (isObjectLinkable l), + (target /= HscNothing) `implies` not is_fake_linkable, + linkableTime l >= ms_hs_date summary -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "compiling non-stable BCO mod:" <+> ppr this_mod_name) + compile_it (Just l) SourceUnmodified + -- we have an old BCO that is up to date with respect + -- to the source: do a recompilation check as normal. + + -- When generating object code, if there's an up-to-date + -- object file on the disk, then we can use it. + -- However, if the object file is new (compared to any + -- linkable we had from a previous compilation), then we + -- must discard any in-memory interface, because this + -- means the user has compiled the source file + -- separately and generated a new interface, that we must + -- read from the disk. + -- + | isObjectTarget target, + Just obj_date <- mb_obj_date, + obj_date >= hs_date -> do + case old_hmi of + Just hmi + | Just l <- hm_linkable hmi, + isObjectLinkable l && linkableTime l == obj_date -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "compiling mod with new on-disk obj:" <+> ppr this_mod_name) + compile_it (Just l) SourceUnmodified + _otherwise -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "compiling mod with new on-disk obj2:" <+> ppr this_mod_name) + linkable <- liftIO $ findObjectLinkable this_mod obj_fn obj_date + compile_it_discard_iface (Just linkable) SourceUnmodified + + _otherwise -> do + liftIO $ debugTraceMsg (hsc_dflags hsc_env) 5 + (text "compiling mod:" <+> ppr this_mod_name) + compile_it Nothing SourceModified + + + +-- Filter modules in the HPT +retainInTopLevelEnvs :: [ModuleName] -> HomePackageTable -> HomePackageTable +retainInTopLevelEnvs keep_these hpt + = listToUFM [ (mod, expectJust "retain" mb_mod_info) + | mod <- keep_these + , let mb_mod_info = lookupUFM hpt mod + , isJust mb_mod_info ] + +-- --------------------------------------------------------------------------- +-- Typecheck module loops + +{- +See bug #930. This code fixes a long-standing bug in --make. The +problem is that when compiling the modules *inside* a loop, a data +type that is only defined at the top of the loop looks opaque; but +after the loop is done, the structure of the data type becomes +apparent. + +The difficulty is then that two different bits of code have +different notions of what the data type looks like. + +The idea is that after we compile a module which also has an .hs-boot +file, we re-generate the ModDetails for each of the modules that +depends on the .hs-boot file, so that everyone points to the proper +TyCons, Ids etc. defined by the real module, not the boot module. +Fortunately re-generating a ModDetails from a ModIface is easy: the +function TcIface.typecheckIface does exactly that. + +Picking the modules to re-typecheck is slightly tricky. Starting from +the module graph consisting of the modules that have already been +compiled, we reverse the edges (so they point from the imported module +to the importing module), and depth-first-search from the .hs-boot +node. This gives us all the modules that depend transitively on the +.hs-boot module, and those are exactly the modules that we need to +re-typecheck. + +Following this fix, GHC can compile itself with --make -O2. +-} + +reTypecheckLoop :: HscEnv -> ModSummary -> ModuleGraph -> IO HscEnv +reTypecheckLoop hsc_env ms graph + | not (isBootSummary ms) && + any (\m -> ms_mod m == this_mod && isBootSummary m) graph + = do + let mss = reachableBackwards (ms_mod_name ms) graph + non_boot = filter (not.isBootSummary) mss + debugTraceMsg (hsc_dflags hsc_env) 2 $ + text "Re-typechecking loop: " <> ppr (map ms_mod_name non_boot) + typecheckLoop hsc_env (map ms_mod_name non_boot) + | otherwise + = return hsc_env + where + this_mod = ms_mod ms + +typecheckLoop :: HscEnv -> [ModuleName] -> IO HscEnv +typecheckLoop hsc_env mods = do + new_hpt <- + fixIO $ \new_hpt -> do + let new_hsc_env = hsc_env{ hsc_HPT = new_hpt } + mds <- initIfaceCheck new_hsc_env $ + mapM (typecheckIface . hm_iface) hmis + let new_hpt = addListToUFM old_hpt + (zip mods [ hmi{ hm_details = details } + | (hmi,details) <- zip hmis mds ]) + return new_hpt + return hsc_env{ hsc_HPT = new_hpt } + where + old_hpt = hsc_HPT hsc_env + hmis = map (expectJust "typecheckLoop" . lookupUFM old_hpt) mods + +reachableBackwards :: ModuleName -> [ModSummary] -> [ModSummary] +reachableBackwards mod summaries + = [ ms | (ms,_,_) <- reachableG (transposeG graph) root ] + where -- the rest just sets up the graph: + (graph, lookup_node) = moduleGraphNodes False summaries + root = expectJust "reachableBackwards" (lookup_node HsBootFile mod) + +-- --------------------------------------------------------------------------- +-- Topological sort of the module graph + +type SummaryNode = (ModSummary, Int, [Int]) + +topSortModuleGraph + :: Bool + -- ^ Drop hi-boot nodes? (see below) + -> [ModSummary] + -> Maybe ModuleName + -- ^ Root module name. If @Nothing@, use the full graph. + -> [SCC ModSummary] +-- ^ Calculate SCCs of the module graph, possibly dropping the hi-boot nodes +-- The resulting list of strongly-connected-components is in topologically +-- sorted order, starting with the module(s) at the bottom of the +-- dependency graph (ie compile them first) and ending with the ones at +-- the top. +-- +-- Drop hi-boot nodes (first boolean arg)? +-- +-- - @False@: treat the hi-boot summaries as nodes of the graph, +-- so the graph must be acyclic +-- +-- - @True@: eliminate the hi-boot nodes, and instead pretend +-- the a source-import of Foo is an import of Foo +-- The resulting graph has no hi-boot nodes, but can be cyclic + +topSortModuleGraph drop_hs_boot_nodes summaries mb_root_mod + = map (fmap summaryNodeSummary) $ stronglyConnCompG initial_graph + where + (graph, lookup_node) = moduleGraphNodes drop_hs_boot_nodes summaries + + initial_graph = case mb_root_mod of + Nothing -> graph + Just root_mod -> + -- restrict the graph to just those modules reachable from + -- the specified module. We do this by building a graph with + -- the full set of nodes, and determining the reachable set from + -- the specified node. + let root | Just node <- lookup_node HsSrcFile root_mod, graph `hasVertexG` node = node + | otherwise = ghcError (ProgramError "module does not exist") + in graphFromEdgedVertices (seq root (reachableG graph root)) + +summaryNodeKey :: SummaryNode -> Int +summaryNodeKey (_, k, _) = k + +summaryNodeSummary :: SummaryNode -> ModSummary +summaryNodeSummary (s, _, _) = s + +moduleGraphNodes :: Bool -> [ModSummary] + -> (Graph SummaryNode, HscSource -> ModuleName -> Maybe SummaryNode) +moduleGraphNodes drop_hs_boot_nodes summaries = (graphFromEdgedVertices nodes, lookup_node) + where + numbered_summaries = zip summaries [1..] + + lookup_node :: HscSource -> ModuleName -> Maybe SummaryNode + lookup_node hs_src mod = Map.lookup (mod, hs_src) node_map + + lookup_key :: HscSource -> ModuleName -> Maybe Int + lookup_key hs_src mod = fmap summaryNodeKey (lookup_node hs_src mod) + + node_map :: NodeMap SummaryNode + node_map = Map.fromList [ ((moduleName (ms_mod s), ms_hsc_src s), node) + | node@(s, _, _) <- nodes ] + + -- We use integers as the keys for the SCC algorithm + nodes :: [SummaryNode] + nodes = [ (s, key, out_keys) + | (s, key) <- numbered_summaries + -- Drop the hi-boot ones if told to do so + , not (isBootSummary s && drop_hs_boot_nodes) + , let out_keys = out_edge_keys hs_boot_key (map unLoc (ms_home_srcimps s)) ++ + out_edge_keys HsSrcFile (map unLoc (ms_home_imps s)) ++ + (-- see [boot-edges] below + if drop_hs_boot_nodes || ms_hsc_src s == HsBootFile + then [] + else case lookup_key HsBootFile (ms_mod_name s) of + Nothing -> [] + Just k -> [k]) ] + + -- [boot-edges] if this is a .hs and there is an equivalent + -- .hs-boot, add a link from the former to the latter. This + -- has the effect of detecting bogus cases where the .hs-boot + -- depends on the .hs, by introducing a cycle. Additionally, + -- it ensures that we will always process the .hs-boot before + -- the .hs, and so the HomePackageTable will always have the + -- most up to date information. + + -- Drop hs-boot nodes by using HsSrcFile as the key + hs_boot_key | drop_hs_boot_nodes = HsSrcFile + | otherwise = HsBootFile + + out_edge_keys :: HscSource -> [ModuleName] -> [Int] + out_edge_keys hi_boot ms = mapCatMaybes (lookup_key hi_boot) ms + -- If we want keep_hi_boot_nodes, then we do lookup_key with + -- the IsBootInterface parameter True; else False + + +type NodeKey = (ModuleName, HscSource) -- The nodes of the graph are +type NodeMap a = Map.Map NodeKey a -- keyed by (mod, src_file_type) pairs + +msKey :: ModSummary -> NodeKey +msKey (ModSummary { ms_mod = mod, ms_hsc_src = boot }) = (moduleName mod,boot) + +mkNodeMap :: [ModSummary] -> NodeMap ModSummary +mkNodeMap summaries = Map.fromList [ (msKey s, s) | s <- summaries] + +nodeMapElts :: NodeMap a -> [a] +nodeMapElts = Map.elems + +-- | If there are {-# SOURCE #-} imports between strongly connected +-- components in the topological sort, then those imports can +-- definitely be replaced by ordinary non-SOURCE imports: if SOURCE +-- were necessary, then the edge would be part of a cycle. +warnUnnecessarySourceImports :: GhcMonad m => [SCC ModSummary] -> m () +warnUnnecessarySourceImports sccs = do + logWarnings (listToBag (concatMap (check.flattenSCC) sccs)) + where check ms = + let mods_in_this_cycle = map ms_mod_name ms in + [ warn i | m <- ms, i <- ms_home_srcimps m, + unLoc i `notElem` mods_in_this_cycle ] + + warn :: Located ModuleName -> WarnMsg + warn (L loc mod) = + mkPlainErrMsg loc + (ptext (sLit "Warning: {-# SOURCE #-} unnecessary in import of ") + <+> quotes (ppr mod)) + +----------------------------------------------------------------------------- +-- Downsweep (dependency analysis) + +-- Chase downwards from the specified root set, returning summaries +-- for all home modules encountered. Only follow source-import +-- links. + +-- We pass in the previous collection of summaries, which is used as a +-- cache to avoid recalculating a module summary if the source is +-- unchanged. +-- +-- The returned list of [ModSummary] nodes has one node for each home-package +-- module, plus one for any hs-boot files. The imports of these nodes +-- are all there, including the imports of non-home-package modules. + +downsweep :: HscEnv + -> [ModSummary] -- Old summaries + -> [ModuleName] -- Ignore dependencies on these; treat + -- them as if they were package modules + -> Bool -- True <=> allow multiple targets to have + -- the same module name; this is + -- very useful for ghc -M + -> IO [ModSummary] + -- The elts of [ModSummary] all have distinct + -- (Modules, IsBoot) identifiers, unless the Bool is true + -- in which case there can be repeats +downsweep hsc_env old_summaries excl_mods allow_dup_roots + = do + rootSummaries <- mapM getRootSummary roots + let root_map = mkRootMap rootSummaries + checkDuplicates root_map + summs <- loop (concatMap msDeps rootSummaries) root_map + return summs + where + roots = hsc_targets hsc_env + + old_summary_map :: NodeMap ModSummary + old_summary_map = mkNodeMap old_summaries + + getRootSummary :: Target -> IO ModSummary + getRootSummary (Target (TargetFile file mb_phase) obj_allowed maybe_buf) + = do exists <- liftIO $ doesFileExist file + if exists + then summariseFile hsc_env old_summaries file mb_phase + obj_allowed maybe_buf + else throwOneError $ mkPlainErrMsg noSrcSpan $ + text "can't find file:" <+> text file + getRootSummary (Target (TargetModule modl) obj_allowed maybe_buf) + = do maybe_summary <- summariseModule hsc_env old_summary_map False + (L rootLoc modl) obj_allowed + maybe_buf excl_mods + case maybe_summary of + Nothing -> packageModErr modl + Just s -> return s + + rootLoc = mkGeneralSrcSpan (fsLit "") + + -- In a root module, the filename is allowed to diverge from the module + -- name, so we have to check that there aren't multiple root files + -- defining the same module (otherwise the duplicates will be silently + -- ignored, leading to confusing behaviour). + checkDuplicates :: NodeMap [ModSummary] -> IO () + checkDuplicates root_map + | allow_dup_roots = return () + | null dup_roots = return () + | otherwise = liftIO $ multiRootsErr (head dup_roots) + where + dup_roots :: [[ModSummary]] -- Each at least of length 2 + dup_roots = filterOut isSingleton (nodeMapElts root_map) + + loop :: [(Located ModuleName,IsBootInterface)] + -- Work list: process these modules + -> NodeMap [ModSummary] + -- Visited set; the range is a list because + -- the roots can have the same module names + -- if allow_dup_roots is True + -> IO [ModSummary] + -- The result includes the worklist, except + -- for those mentioned in the visited set + loop [] done = return (concat (nodeMapElts done)) + loop ((wanted_mod, is_boot) : ss) done + | Just summs <- Map.lookup key done + = if isSingleton summs then + loop ss done + else + do { multiRootsErr summs; return [] } + | otherwise + = do mb_s <- summariseModule hsc_env old_summary_map + is_boot wanted_mod True + Nothing excl_mods + case mb_s of + Nothing -> loop ss done + Just s -> loop (msDeps s ++ ss) (Map.insert key [s] done) + where + key = (unLoc wanted_mod, if is_boot then HsBootFile else HsSrcFile) + +-- XXX Does the (++) here need to be flipped? +mkRootMap :: [ModSummary] -> NodeMap [ModSummary] +mkRootMap summaries = Map.insertListWith (flip (++)) + [ (msKey s, [s]) | s <- summaries ] + Map.empty + +msDeps :: ModSummary -> [(Located ModuleName, IsBootInterface)] +-- (msDeps s) returns the dependencies of the ModSummary s. +-- A wrinkle is that for a {-# SOURCE #-} import we return +-- *both* the hs-boot file +-- *and* the source file +-- as "dependencies". That ensures that the list of all relevant +-- modules always contains B.hs if it contains B.hs-boot. +-- Remember, this pass isn't doing the topological sort. It's +-- just gathering the list of all relevant ModSummaries +msDeps s = + concat [ [(m,True), (m,False)] | m <- ms_home_srcimps s ] + ++ [ (m,False) | m <- ms_home_imps s ] + +home_imps :: [Located (ImportDecl RdrName)] -> [Located ModuleName] +home_imps imps = [ ideclName i | L _ i <- imps, isLocal (ideclPkgQual i) ] + where isLocal Nothing = True + isLocal (Just pkg) | pkg == fsLit "this" = True -- "this" is special + isLocal _ = False + +ms_home_allimps :: ModSummary -> [ModuleName] +ms_home_allimps ms = map unLoc (ms_home_srcimps ms ++ ms_home_imps ms) + +ms_home_srcimps :: ModSummary -> [Located ModuleName] +ms_home_srcimps = home_imps . ms_srcimps + +ms_home_imps :: ModSummary -> [Located ModuleName] +ms_home_imps = home_imps . ms_imps + +----------------------------------------------------------------------------- +-- Summarising modules + +-- We have two types of summarisation: +-- +-- * Summarise a file. This is used for the root module(s) passed to +-- cmLoadModules. The file is read, and used to determine the root +-- module name. The module name may differ from the filename. +-- +-- * Summarise a module. We are given a module name, and must provide +-- a summary. The finder is used to locate the file in which the module +-- resides. + +summariseFile + :: HscEnv + -> [ModSummary] -- old summaries + -> FilePath -- source file name + -> Maybe Phase -- start phase + -> Bool -- object code allowed? + -> Maybe (StringBuffer,ClockTime) + -> IO ModSummary + +summariseFile hsc_env old_summaries file mb_phase obj_allowed maybe_buf + -- we can use a cached summary if one is available and the + -- source file hasn't changed, But we have to look up the summary + -- by source file, rather than module name as we do in summarise. + | Just old_summary <- findSummaryBySourceFile old_summaries file + = do + let location = ms_location old_summary + + -- return the cached summary if the source didn't change + src_timestamp <- case maybe_buf of + Just (_,t) -> return t + Nothing -> liftIO $ getModificationTime file + -- The file exists; we checked in getRootSummary above. + -- If it gets removed subsequently, then this + -- getModificationTime may fail, but that's the right + -- behaviour. + + if ms_hs_date old_summary == src_timestamp + then do -- update the object-file timestamp + obj_timestamp <- + if isObjectTarget (hscTarget (hsc_dflags hsc_env)) + || obj_allowed -- bug #1205 + then liftIO $ getObjTimestamp location False + else return Nothing + return old_summary{ ms_obj_date = obj_timestamp } + else + new_summary + + | otherwise + = new_summary + where + new_summary = do + let dflags = hsc_dflags hsc_env + + (dflags', hspp_fn, buf) + <- preprocessFile hsc_env file mb_phase maybe_buf + + (srcimps,the_imps, L _ mod_name) <- getImports dflags' buf hspp_fn file + + -- Make a ModLocation for this file + location <- liftIO $ mkHomeModLocation dflags mod_name file + + -- Tell the Finder cache where it is, so that subsequent calls + -- to findModule will find it, even if it's not on any search path + mod <- liftIO $ addHomeModuleToFinder hsc_env mod_name location + + src_timestamp <- case maybe_buf of + Just (_,t) -> return t + Nothing -> liftIO $ getModificationTime file + -- getMofificationTime may fail + + -- when the user asks to load a source file by name, we only + -- use an object file if -fobject-code is on. See #1205. + obj_timestamp <- + if isObjectTarget (hscTarget (hsc_dflags hsc_env)) + || obj_allowed -- bug #1205 + then liftIO $ modificationTimeIfExists (ml_obj_file location) + else return Nothing + + return (ModSummary { ms_mod = mod, ms_hsc_src = HsSrcFile, + ms_location = location, + ms_hspp_file = hspp_fn, + ms_hspp_opts = dflags', + ms_hspp_buf = Just buf, + ms_srcimps = srcimps, ms_textual_imps = the_imps, + ms_hs_date = src_timestamp, + ms_obj_date = obj_timestamp }) + +findSummaryBySourceFile :: [ModSummary] -> FilePath -> Maybe ModSummary +findSummaryBySourceFile summaries file + = case [ ms | ms <- summaries, HsSrcFile <- [ms_hsc_src ms], + expectJust "findSummaryBySourceFile" (ml_hs_file (ms_location ms)) == file ] of + [] -> Nothing + (x:_) -> Just x + +-- Summarise a module, and pick up source and timestamp. +summariseModule + :: HscEnv + -> NodeMap ModSummary -- Map of old summaries + -> IsBootInterface -- True <=> a {-# SOURCE #-} import + -> Located ModuleName -- Imported module to be summarised + -> Bool -- object code allowed? + -> Maybe (StringBuffer, ClockTime) + -> [ModuleName] -- Modules to exclude + -> IO (Maybe ModSummary) -- Its new summary + +summariseModule hsc_env old_summary_map is_boot (L loc wanted_mod) + obj_allowed maybe_buf excl_mods + | wanted_mod `elem` excl_mods + = return Nothing + + | Just old_summary <- Map.lookup (wanted_mod, hsc_src) old_summary_map + = do -- Find its new timestamp; all the + -- ModSummaries in the old map have valid ml_hs_files + let location = ms_location old_summary + src_fn = expectJust "summariseModule" (ml_hs_file location) + + -- check the modification time on the source file, and + -- return the cached summary if it hasn't changed. If the + -- file has disappeared, we need to call the Finder again. + case maybe_buf of + Just (_,t) -> check_timestamp old_summary location src_fn t + Nothing -> do + m <- tryIO (getModificationTime src_fn) + case m of + Right t -> check_timestamp old_summary location src_fn t + Left e | isDoesNotExistError e -> find_it + | otherwise -> ioError e + + | otherwise = find_it + where + dflags = hsc_dflags hsc_env + + hsc_src = if is_boot then HsBootFile else HsSrcFile + + check_timestamp old_summary location src_fn src_timestamp + | ms_hs_date old_summary == src_timestamp = do + -- update the object-file timestamp + obj_timestamp <- + if isObjectTarget (hscTarget (hsc_dflags hsc_env)) + || obj_allowed -- bug #1205 + then getObjTimestamp location is_boot + else return Nothing + return (Just old_summary{ ms_obj_date = obj_timestamp }) + | otherwise = + -- source changed: re-summarise. + new_summary location (ms_mod old_summary) src_fn src_timestamp + + find_it = do + -- Don't use the Finder's cache this time. If the module was + -- previously a package module, it may have now appeared on the + -- search path, so we want to consider it to be a home module. If + -- the module was previously a home module, it may have moved. + uncacheModule hsc_env wanted_mod + found <- findImportedModule hsc_env wanted_mod Nothing + case found of + Found location mod + | isJust (ml_hs_file location) -> + -- Home package + just_found location mod + | otherwise -> + -- Drop external-pkg + ASSERT(modulePackageId mod /= thisPackage dflags) + return Nothing + + err -> noModError dflags loc wanted_mod err + -- Not found + + just_found location mod = do + -- Adjust location to point to the hs-boot source file, + -- hi file, object file, when is_boot says so + let location' | is_boot = addBootSuffixLocn location + | otherwise = location + src_fn = expectJust "summarise2" (ml_hs_file location') + + -- Check that it exists + -- It might have been deleted since the Finder last found it + maybe_t <- modificationTimeIfExists src_fn + case maybe_t of + Nothing -> noHsFileErr loc src_fn + Just t -> new_summary location' mod src_fn t + + + new_summary location mod src_fn src_timestamp + = do + -- Preprocess the source file and get its imports + -- The dflags' contains the OPTIONS pragmas + (dflags', hspp_fn, buf) <- preprocessFile hsc_env src_fn Nothing maybe_buf + (srcimps, the_imps, L mod_loc mod_name) <- getImports dflags' buf hspp_fn src_fn + + when (mod_name /= wanted_mod) $ + throwOneError $ mkPlainErrMsg mod_loc $ + text "File name does not match module name:" + $$ text "Saw:" <+> quotes (ppr mod_name) + $$ text "Expected:" <+> quotes (ppr wanted_mod) + + -- Find the object timestamp, and return the summary + obj_timestamp <- + if isObjectTarget (hscTarget (hsc_dflags hsc_env)) + || obj_allowed -- bug #1205 + then getObjTimestamp location is_boot + else return Nothing + + return (Just (ModSummary { ms_mod = mod, + ms_hsc_src = hsc_src, + ms_location = location, + ms_hspp_file = hspp_fn, + ms_hspp_opts = dflags', + ms_hspp_buf = Just buf, + ms_srcimps = srcimps, + ms_textual_imps = the_imps, + ms_hs_date = src_timestamp, + ms_obj_date = obj_timestamp })) + + +getObjTimestamp :: ModLocation -> Bool -> IO (Maybe ClockTime) +getObjTimestamp location is_boot + = if is_boot then return Nothing + else modificationTimeIfExists (ml_obj_file location) + + +preprocessFile :: HscEnv + -> FilePath + -> Maybe Phase -- ^ Starting phase + -> Maybe (StringBuffer,ClockTime) + -> IO (DynFlags, FilePath, StringBuffer) +preprocessFile hsc_env src_fn mb_phase Nothing + = do + (dflags', hspp_fn) <- preprocess hsc_env (src_fn, mb_phase) + buf <- hGetStringBuffer hspp_fn + return (dflags', hspp_fn, buf) + +preprocessFile hsc_env src_fn mb_phase (Just (buf, _time)) + = do + let dflags = hsc_dflags hsc_env + let local_opts = getOptions dflags buf src_fn + + (dflags', leftovers, warns) + <- parseDynamicFilePragma dflags local_opts + checkProcessArgsResult leftovers + handleFlagWarnings dflags' warns + + 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 + | xopt Opt_Cpp dflags' = True + | dopt Opt_Pp dflags' = True + | otherwise = False + + when needs_preprocessing $ + ghcError (ProgramError "buffer needs preprocesing; interactive check disabled") + + return (dflags', src_fn, buf) + + +----------------------------------------------------------------------------- +-- Error messages +----------------------------------------------------------------------------- + +noModError :: DynFlags -> SrcSpan -> ModuleName -> FindResult -> IO ab +-- ToDo: we don't have a proper line number for this error +noModError dflags loc wanted_mod err + = throwOneError $ mkPlainErrMsg loc $ cannotFindModule dflags wanted_mod err + +noHsFileErr :: SrcSpan -> String -> IO a +noHsFileErr loc path + = throwOneError $ mkPlainErrMsg loc $ text "Can't find" <+> text path + +packageModErr :: ModuleName -> IO a +packageModErr mod + = throwOneError $ mkPlainErrMsg noSrcSpan $ + text "module" <+> quotes (ppr mod) <+> text "is a package module" + +multiRootsErr :: [ModSummary] -> IO () +multiRootsErr [] = panic "multiRootsErr" +multiRootsErr summs@(summ1:_) + = throwOneError $ mkPlainErrMsg noSrcSpan $ + text "module" <+> quotes (ppr mod) <+> + text "is defined in multiple files:" <+> + sep (map text files) + where + mod = ms_mod summ1 + files = map (expectJust "checkDup" . ml_hs_file . ms_location) summs + +cyclicModuleErr :: [ModSummary] -> SDoc +-- From a strongly connected component we find +-- a single cycle to report +cyclicModuleErr mss + = ASSERT( not (null mss) ) + case findCycle graph of + Nothing -> ptext (sLit "Unexpected non-cycle") <+> ppr mss + Just path -> vcat [ ptext (sLit "Module imports form a cycle:") + , nest 2 (show_path path) ] + where + graph :: [Node NodeKey ModSummary] + graph = [(ms, msKey ms, get_deps ms) | ms <- mss] + + get_deps :: ModSummary -> [NodeKey] + get_deps ms = ([ (unLoc m, HsBootFile) | m <- ms_home_srcimps ms ] ++ + [ (unLoc m, HsSrcFile) | m <- ms_home_imps ms ]) + + show_path [] = panic "show_path" + show_path [m] = ptext (sLit "module") <+> ppr_ms m + <+> ptext (sLit "imports itself") + show_path (m1:m2:ms) = vcat ( nest 7 (ptext (sLit "module") <+> ppr_ms m1) + : nest 6 (ptext (sLit "imports") <+> ppr_ms m2) + : go ms ) + where + go [] = [ptext (sLit "which imports") <+> ppr_ms m1] + go (m:ms) = (ptext (sLit "which imports") <+> ppr_ms m) : go ms + + + ppr_ms :: ModSummary -> SDoc + ppr_ms ms = quotes (ppr (moduleName (ms_mod ms))) <+> + (parens (text (msHsFilePath ms))) + diff -Nru ghc-7.0.3/compiler/main/GhcMonad.hs ghc-7.2.1/compiler/main/GhcMonad.hs --- ghc-7.0.3/compiler/main/GhcMonad.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/compiler/main/GhcMonad.hs 2011-08-07 17:10:05.000000000 +0000 @@ -0,0 +1,198 @@ +{-# OPTIONS_GHC -funbox-strict-fields #-} +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow, 2010 +-- +-- The Session type and related functionality +-- +-- ----------------------------------------------------------------------------- + +module GhcMonad ( + -- * 'Ghc' monad stuff + GhcMonad(..), + Ghc(..), + GhcT(..), liftGhcT, + reflectGhc, reifyGhc, + getSessionDynFlags, + liftIO, + Session(..), withSession, modifySession, withTempSession, + + -- ** Warnings + logWarnings, printException, printExceptionAndWarnings, + WarnErrLogger, defaultWarnErrLogger + ) where + +import MonadUtils +import HscTypes +import DynFlags +import Exception +import ErrUtils + +import Data.IORef + +-- ----------------------------------------------------------------------------- +-- | A monad that has all the features needed by GHC API calls. +-- +-- In short, a GHC monad +-- +-- - allows embedding of IO actions, +-- +-- - can log warnings, +-- +-- - allows handling of (extensible) exceptions, and +-- +-- - maintains a current session. +-- +-- If you do not use 'Ghc' or 'GhcT', make sure to call 'GHC.initGhcMonad' +-- before any call to the GHC API functions can occur. +-- +class (Functor m, MonadIO m, ExceptionMonad m) => GhcMonad m where + getSession :: m HscEnv + setSession :: HscEnv -> m () + + +-- | Call the argument with the current session. +withSession :: GhcMonad m => (HscEnv -> m a) -> m a +withSession f = getSession >>= f + +-- | Grabs the DynFlags from the Session +getSessionDynFlags :: GhcMonad m => m DynFlags +getSessionDynFlags = withSession (return . hsc_dflags) + +-- | Set the current session to the result of applying the current session to +-- the argument. +modifySession :: GhcMonad m => (HscEnv -> HscEnv) -> m () +modifySession f = do h <- getSession + setSession $! f h + +withSavedSession :: GhcMonad m => m a -> m a +withSavedSession m = do + saved_session <- getSession + m `gfinally` setSession saved_session + +-- | Call an action with a temporarily modified Session. +withTempSession :: GhcMonad m => (HscEnv -> HscEnv) -> m a -> m a +withTempSession f m = + withSavedSession $ modifySession f >> m + +-- ----------------------------------------------------------------------------- +-- | A monad that allows logging of warnings. + +logWarnings :: GhcMonad m => WarningMessages -> m () +logWarnings warns = do + dflags <- getSessionDynFlags + liftIO $ printOrThrowWarnings dflags warns + +-- ----------------------------------------------------------------------------- +-- | A minimal implementation of a 'GhcMonad'. If you need a custom monad, +-- e.g., to maintain additional state consider wrapping this monad or using +-- 'GhcT'. +newtype Ghc a = Ghc { unGhc :: Session -> IO a } + +-- | The Session is a handle to the complete state of a compilation +-- session. A compilation session consists of a set of modules +-- constituting the current program or library, the context for +-- interactive evaluation, and various caches. +data Session = Session !(IORef HscEnv) + +instance Functor Ghc where + fmap f m = Ghc $ \s -> f `fmap` unGhc m s + +instance Monad Ghc where + return a = Ghc $ \_ -> return a + m >>= g = Ghc $ \s -> do a <- unGhc m s; unGhc (g a) s + +instance MonadIO Ghc where + liftIO ioA = Ghc $ \_ -> ioA + +instance ExceptionMonad Ghc where + gcatch act handle = + Ghc $ \s -> unGhc act s `gcatch` \e -> unGhc (handle e) s + gblock (Ghc m) = Ghc $ \s -> gblock (m s) + gunblock (Ghc m) = Ghc $ \s -> gunblock (m s) + gmask f = + Ghc $ \s -> gmask $ \io_restore -> + let + g_restore (Ghc m) = Ghc $ \s -> io_restore (m s) + in + unGhc (f g_restore) s + +instance GhcMonad Ghc where + getSession = Ghc $ \(Session r) -> readIORef r + setSession s' = Ghc $ \(Session r) -> writeIORef r s' + +-- | Reflect a computation in the 'Ghc' monad into the 'IO' monad. +-- +-- You can use this to call functions returning an action in the 'Ghc' monad +-- inside an 'IO' action. This is needed for some (too restrictive) callback +-- arguments of some library functions: +-- +-- > libFunc :: String -> (Int -> IO a) -> IO a +-- > ghcFunc :: Int -> Ghc a +-- > +-- > ghcFuncUsingLibFunc :: String -> Ghc a -> Ghc a +-- > ghcFuncUsingLibFunc str = +-- > reifyGhc $ \s -> +-- > libFunc $ \i -> do +-- > reflectGhc (ghcFunc i) s +-- +reflectGhc :: Ghc a -> Session -> IO a +reflectGhc m = unGhc m + +-- > Dual to 'reflectGhc'. See its documentation. +reifyGhc :: (Session -> IO a) -> Ghc a +reifyGhc act = Ghc $ act + +-- ----------------------------------------------------------------------------- +-- | A monad transformer to add GHC specific features to another monad. +-- +-- Note that the wrapped monad must support IO and handling of exceptions. +newtype GhcT m a = GhcT { unGhcT :: Session -> m a } +liftGhcT :: Monad m => m a -> GhcT m a +liftGhcT m = GhcT $ \_ -> m + +instance Functor m => Functor (GhcT m) where + fmap f m = GhcT $ \s -> f `fmap` unGhcT m s + +instance Monad m => Monad (GhcT m) where + return x = GhcT $ \_ -> return x + m >>= k = GhcT $ \s -> do a <- unGhcT m s; unGhcT (k a) s + +instance MonadIO m => MonadIO (GhcT m) where + liftIO ioA = GhcT $ \_ -> liftIO ioA + +instance ExceptionMonad m => ExceptionMonad (GhcT m) where + gcatch act handle = + GhcT $ \s -> unGhcT act s `gcatch` \e -> unGhcT (handle e) s + gblock (GhcT m) = GhcT $ \s -> gblock (m s) + gunblock (GhcT m) = GhcT $ \s -> gunblock (m s) + gmask f = + GhcT $ \s -> gmask $ \io_restore -> + let + g_restore (GhcT m) = GhcT $ \s -> io_restore (m s) + in + unGhcT (f g_restore) s + +instance (Functor m, ExceptionMonad m, MonadIO m) => GhcMonad (GhcT m) where + getSession = GhcT $ \(Session r) -> liftIO $ readIORef r + setSession s' = GhcT $ \(Session r) -> liftIO $ writeIORef r s' + + +-- | Print the error message and all warnings. Useful inside exception +-- handlers. Clears warnings after printing. +printException :: GhcMonad m => SourceError -> m () +printException err = do + dflags <- getSessionDynFlags + liftIO $ printBagOfErrors dflags (srcErrorMessages err) + +{-# DEPRECATED printExceptionAndWarnings "use printException instead" #-} +printExceptionAndWarnings :: GhcMonad m => SourceError -> m () +printExceptionAndWarnings = printException + +-- | A function called to log warnings and errors. +type WarnErrLogger = GhcMonad m => Maybe SourceError -> m () + +defaultWarnErrLogger :: WarnErrLogger +defaultWarnErrLogger Nothing = return () +defaultWarnErrLogger (Just e) = printException e + diff -Nru ghc-7.0.3/compiler/main/GhcPlugins.hs ghc-7.2.1/compiler/main/GhcPlugins.hs --- ghc-7.0.3/compiler/main/GhcPlugins.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/compiler/main/GhcPlugins.hs 2011-08-07 17:10:05.000000000 +0000 @@ -0,0 +1,83 @@ +{-# OPTIONS_GHC -fno-warn-duplicate-exports #-} + +-- | This module is not used by GHC itself. Rather, it exports all of +-- the functions and types you are likely to need when writing a +-- plugin for GHC. So authors of plugins can probably get away simply +-- with saying "import GhcPlugins". +-- +-- Particularly interesting modules for plugin writers include +-- "CoreSyn" and "CoreMonad". +module GhcPlugins( + module CoreMonad, + module RdrName, module OccName, module Name, module Var, module Id, module IdInfo, + module CoreSyn, module Literal, module DataCon, + module CoreUtils, module MkCore, module CoreFVs, module CoreSubst, + module Rules, module Annotations, + module DynFlags, module Packages, + module Module, module Type, module TyCon, module Coercion, + module TysWiredIn, module HscTypes, module BasicTypes, + module VarSet, module VarEnv, module NameSet, module NameEnv, + module UniqSet, module UniqFM, module FiniteMap, + module Util, module Serialized, module SrcLoc, module Outputable, + module UniqSupply, module Unique, module FastString, module FastTypes + ) where + +-- Plugin stuff itself +import CoreMonad + +-- Variable naming +import RdrName +import OccName hiding ( varName {- conflicts with Var.varName -} ) +import Name hiding ( varName {- reexport from OccName, conflicts with Var.varName -} ) +import Var +import Id hiding ( lazySetIdInfo, setIdExported, setIdNotExported {- all three conflict with Var -} ) +import IdInfo + +-- Core +import CoreSyn +import Literal +import DataCon +import CoreUtils +import MkCore +import CoreFVs +import CoreSubst + +-- Core "extras" +import Rules +import Annotations + +-- Pipeline-related stuff +import DynFlags +import Packages + +-- Important GHC types +import Module +import Type hiding {- conflict with CoreSubst -} + ( substTy, extendTvSubst, extendTvSubstList, isInScope ) +import Coercion hiding {- conflict with CoreSubst -} + ( substTy, extendTvSubst, substCo, substTyVarBndr, lookupTyVar ) +import TyCon +import TysWiredIn +import HscTypes +import BasicTypes hiding ( Version {- conflicts with Packages.Version -} ) + +-- Collections and maps +import VarSet +import VarEnv +import NameSet +import NameEnv +import UniqSet +import UniqFM +-- Conflicts with UniqFM: +--import LazyUniqFM +import FiniteMap + +-- Common utilities +import Util +import Serialized +import SrcLoc +import Outputable +import UniqSupply +import Unique ( Unique, Uniquable(..) ) +import FastString +import FastTypes diff -Nru ghc-7.0.3/compiler/main/HeaderInfo.hs ghc-7.2.1/compiler/main/HeaderInfo.hs --- ghc-7.0.3/compiler/main/HeaderInfo.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/main/HeaderInfo.hs 2011-08-07 17:10:05.000000000 +0000 @@ -33,9 +33,9 @@ import Pretty () import Maybes import Bag ( emptyBag, listToBag, unitBag ) - -import MonadUtils ( MonadIO ) +import MonadUtils import Exception + import Control.Monad import System.IO import System.IO.Unsafe @@ -46,17 +46,16 @@ -- | Parse the imports of a source file. -- -- Throws a 'SourceError' if parsing fails. -getImports :: GhcMonad m => - DynFlags +getImports :: DynFlags -> StringBuffer -- ^ Parse this. -> FilePath -- ^ Filename the buffer came from. Used for -- reporting parse error locations. -> FilePath -- ^ The original source filename (used for locations -- in the function result) - -> m ([Located (ImportDecl RdrName)], [Located (ImportDecl RdrName)], Located ModuleName) + -> IO ([Located (ImportDecl RdrName)], [Located (ImportDecl RdrName)], Located ModuleName) -- ^ The source imports, normal imports, and the module name. getImports dflags buf filename source_filename = do - let loc = mkSrcLoc (mkFastString filename) 1 1 + let loc = mkRealSrcLoc (mkFastString filename) 1 1 case unP parseHeader (mkPState dflags buf loc) of PFailed span err -> parseError span err POk pst rdr_module -> do @@ -66,7 +65,7 @@ ms = (emptyBag, errs) -- logWarnings warns if errorsFound dflags ms - then liftIO $ throwIO $ mkSrcErr errs + then throwIO $ mkSrcErr errs else case rdr_module of L _ (HsModule mb_mod _ imps _ _ _) -> @@ -99,22 +98,23 @@ | otherwise = [preludeImportDecl] where explicit_prelude_import - = notNull [ () | L _ (ImportDecl mod Nothing _ _ _ _) <- import_decls, + = notNull [ () | L _ (ImportDecl mod Nothing _ _ _ _ _) <- import_decls, unLoc mod == pRELUDE_NAME ] preludeImportDecl :: LImportDecl RdrName preludeImportDecl = L loc $ - ImportDecl (L loc pRELUDE_NAME) - Nothing {- no specific package -} - False {- Not a boot interface -} - False {- Not qualified -} - Nothing {- No "as" -} - Nothing {- No import list -} + ImportDecl (L loc pRELUDE_NAME) + Nothing {- No specific package -} + False {- Not a boot interface -} + False {- Not a safe import -} + False {- Not qualified -} + Nothing {- No "as" -} + Nothing {- No import list -} loc = mkGeneralSrcSpan (fsLit "Implicit import declaration") -parseError :: GhcMonad m => SrcSpan -> Message -> m a +parseError :: SrcSpan -> Message -> IO a parseError span err = throwOneError $ mkPlainErrMsg span err -------------------------------------------------------------- @@ -144,7 +144,7 @@ buf <- hGetStringBufferBlock handle blockSize unsafeInterleaveIO $ lazyLexBuf handle (pragState dflags buf loc) False where - loc = mkSrcLoc (mkFastString filename) 1 1 + loc = mkRealSrcLoc (mkFastString filename) 1 1 lazyLexBuf :: Handle -> PState -> Bool -> IO [Located Token] lazyLexBuf handle state eof = do @@ -161,7 +161,7 @@ _other -> do rest <- lazyLexBuf handle state' eof return (t : rest) _ | not eof -> getMore handle state - | otherwise -> return [L (last_loc state) ITeof] + | otherwise -> return [L (RealSrcSpan (last_loc state)) ITeof] -- parser assumes an ITeof sentinel at the end getMore :: Handle -> PState -> IO [Located Token] @@ -176,12 +176,12 @@ getToks :: DynFlags -> FilePath -> StringBuffer -> [Located Token] getToks dflags filename buf = lexAll (pragState dflags buf loc) where - loc = mkSrcLoc (mkFastString filename) 1 1 + loc = mkRealSrcLoc (mkFastString filename) 1 1 lexAll state = case unP (lexer return) state of POk _ t@(L _ ITeof) -> [t] POk state' t -> t : lexAll state' - _ -> [L (last_loc state) ITeof] + _ -> [L (RealSrcSpan (last_loc state)) ITeof] -- | Parse OPTIONS and LANGUAGE pragmas of the source file. @@ -285,7 +285,8 @@ mkPlainErrMsg loc $ text "Unsupported extension: " <> text unsup $$ if null suggestions then empty else text "Perhaps you meant" <+> quotedListWithOr (map text suggestions) - where suggestions = fuzzyMatch unsup supportedLanguagesAndExtensions + where + suggestions = fuzzyMatch unsup supportedLanguagesAndExtensions optionsErrorMsgs :: [String] -> [Located String] -> FilePath -> Messages diff -Nru ghc-7.0.3/compiler/main/HscMain.lhs ghc-7.2.1/compiler/main/HscMain.lhs --- ghc-7.0.3/compiler/main/HscMain.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/main/HscMain.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -2,104 +2,133 @@ % (c) The GRASP/AQUA Project, Glasgow University, 1993-2000 % \begin{code} --- | Main driver for the compiling plain Haskell source code. +-- | Main API for compiling plain Haskell source code. -- --- This module implements compilation of a Haskell-only source file. It is --- /not/ concerned with preprocessing of source files; this is handled in --- "DriverPipeline". +-- This module implements compilation of a Haskell source. It is +-- /not/ concerned with preprocessing of source files; this is handled +-- in "DriverPipeline". +-- +-- There are various entry points depending on what mode we're in: +-- "batch" mode (@--make@), "one-shot" mode (@-c@, @-S@ etc.), and +-- "interactive" mode (GHCi). There are also entry points for +-- individual passes: parsing, typechecking/renaming, desugaring, and +-- simplification. +-- +-- All the functions here take an 'HscEnv' as a parameter, but none of +-- them return a new one: 'HscEnv' is treated as an immutable value +-- from here on in (although it has mutable components, for the +-- caches). +-- +-- Warning messages are dealt with consistently throughout this API: +-- during compilation warnings are collected, and before any function +-- in @HscMain@ returns, the warnings are either printed, or turned +-- into a real compialtion error if the @-Werror@ flag is enabled. -- module HscMain - ( newHscEnv, hscCmmFile - , hscParseIdentifier - , hscSimplify - , hscNormalIface, hscWriteIface, hscGenHardCode -#ifdef GHCI - , hscStmt, hscTcExpr, hscImport, hscKcType - , compileExpr -#endif - , HsCompiler(..) - , hscOneShotCompiler, hscNothingCompiler - , hscInteractiveCompiler, hscBatchCompiler - , hscCompileOneShot -- :: Compiler HscStatus - , hscCompileBatch -- :: Compiler (HscStatus, ModIface, ModDetails) - , hscCompileNothing -- :: Compiler (HscStatus, ModIface, ModDetails) - , hscCompileInteractive -- :: Compiler (InteractiveStatus, ModIface, ModDetails) - , hscCheckRecompBackend + ( + -- * Making an HscEnv + newHscEnv + + -- * Compiling complete source files + , Compiler , HscStatus' (..) , InteractiveStatus, HscStatus + , hscCompileOneShot + , hscCompileBatch + , hscCompileNothing + , hscCompileInteractive + , hscCompileCmmFile + , hscCompileCore - -- The new interface + -- * Running passes separately , hscParse - , hscTypecheck , hscTypecheckRename , hscDesugar , makeSimpleIface , makeSimpleDetails + , hscSimplify -- ToDo, shouldn't really export this + + -- ** Backends + , hscOneShotBackendOnly + , hscBatchBackendOnly + , hscNothingBackendOnly + , hscInteractiveBackendOnly + + -- * Support for interactive evaluation + , hscParseIdentifier + , hscTcRcLookupName + , hscTcRnGetInfo +#ifdef GHCI + , hscRnImportDecls + , hscGetModuleExports + , hscTcRnLookupRdrName + , hscStmt, hscStmtWithLocation + , hscTcExpr, hscImport, hscKcType + , hscCompileCoreExpr +#endif + ) where #ifdef GHCI -import CodeOutput ( outputForeignStubs ) import ByteCodeGen ( byteCodeGen, coreExprToBCOs ) import Linker ( HValue, linkExpr ) import CoreTidy ( tidyExpr ) -import CorePrep ( corePrepExpr ) -import Desugar ( deSugarExpr ) -import SimplCore ( simplifyExpr ) -import TcRnDriver ( tcRnStmt, tcRnExpr, tcRnType ) -import Type ( Type, tyVarsOfTypes ) +import Type ( Type ) +import TcType ( tyVarsOfTypes ) import PrelNames ( iNTERACTIVE ) import {- Kind parts of -} Type ( Kind ) import Id ( idType ) import CoreLint ( lintUnfolding ) import DsMeta ( templateHaskellNames ) -import SrcLoc ( SrcSpan, noSrcLoc, interactiveSrcLoc, srcLocSpan, noSrcSpan, unLoc ) import VarSet import VarEnv ( emptyTidyEnv ) import Panic #endif import Id ( Id ) -import Module ( emptyModuleEnv, ModLocation(..), Module ) +import Module +import Packages import RdrName import HsSyn import CoreSyn -import SrcLoc ( Located(..) ) import StringBuffer import Parser -import Lexer -import SrcLoc ( mkSrcLoc ) -import TcRnDriver ( tcRnModule ) +import Lexer hiding (getDynFlags) +import SrcLoc +import TcRnDriver import TcIface ( typecheckIface ) -import TcRnMonad ( initIfaceCheck, TcGblEnv(..) ) +import TcRnMonad import IfaceEnv ( initNameCache ) import LoadIface ( ifaceStats, initExternalPackageState ) import PrelInfo ( wiredInThings, basicKnownKeyNames ) import MkIface -import Desugar ( deSugar ) -import SimplCore ( core2core ) +import Desugar +import SimplCore import TidyPgm -import CorePrep ( corePrepPgm ) +import CorePrep import CoreToStg ( coreToStg ) import qualified StgCmm ( codeGen ) import StgSyn import CostCentre -import TyCon ( TyCon, isDataTyCon ) +import ProfInit +import TyCon ( TyCon, isDataTyCon ) import Name ( Name, NamedThing(..) ) import SimplStg ( stg2stg ) import CodeGen ( codeGen ) -import Cmm ( Cmm ) +import OldCmm ( Cmm ) import PprCmm ( pprCmms ) import CmmParse ( parseCmmFile ) import CmmBuildInfoTables -import CmmCPS -import CmmCPSZ +import CmmPipeline import CmmInfo import OptimizationFuel ( initOptFuelState ) import CmmCvt -import CmmTx -import CmmContFlowOpt -import CodeOutput ( codeOutput ) +import CmmContFlowOpt ( runCmmContFlowOpts ) +import CodeOutput import NameEnv ( emptyNameEnv ) +import NameSet ( emptyNameSet ) +import InstEnv +import FamInstEnv ( emptyFamInstEnv ) import Fingerprint ( Fingerprint ) import DynFlags @@ -113,12 +142,11 @@ import FastString import UniqFM ( emptyUFM ) import UniqSupply ( initUs_ ) -import Bag ( unitBag ) +import Bag import Exception --- import MonadUtils import Control.Monad --- import System.IO +import Data.Maybe ( catMaybes ) import Data.IORef \end{code} #include "HsVersions.h" @@ -131,16 +159,15 @@ %************************************************************************ \begin{code} -newHscEnv :: GhcApiCallbacks -> DynFlags -> IO HscEnv -newHscEnv callbacks dflags +newHscEnv :: DynFlags -> IO HscEnv +newHscEnv dflags = do { eps_var <- newIORef initExternalPackageState - ; us <- mkSplitUniqSupply 'r' - ; nc_var <- newIORef (initNameCache us knownKeyNames) - ; fc_var <- newIORef emptyUFM + ; us <- mkSplitUniqSupply 'r' + ; nc_var <- newIORef (initNameCache us knownKeyNames) + ; fc_var <- newIORef emptyUFM ; mlc_var <- newIORef emptyModuleEnv ; optFuel <- initOptFuelState ; return (HscEnv { hsc_dflags = dflags, - hsc_callbacks = callbacks, hsc_targets = [], hsc_mod_graph = [], hsc_IC = emptyInteractiveContext, @@ -153,26 +180,155 @@ hsc_type_env_var = Nothing } ) } -knownKeyNames :: [Name] -- Put here to avoid loops involving DsMeta, - -- where templateHaskellNames are defined -knownKeyNames = map getName wiredInThings - ++ basicKnownKeyNames +knownKeyNames :: [Name] -- Put here to avoid loops involving DsMeta, + -- where templateHaskellNames are defined +knownKeyNames + = map getName wiredInThings + ++ basicKnownKeyNames #ifdef GHCI - ++ templateHaskellNames + ++ templateHaskellNames #endif -\end{code} +-- ----------------------------------------------------------------------------- +-- The Hsc monad: collecting warnings -\begin{code} +newtype Hsc a = Hsc (HscEnv -> WarningMessages -> IO (a, WarningMessages)) + +instance Monad Hsc where + return a = Hsc $ \_ w -> return (a, w) + Hsc m >>= k = Hsc $ \e w -> do (a, w1) <- m e w + case k a of + Hsc k' -> k' e w1 + +instance MonadIO Hsc where + liftIO io = Hsc $ \_ w -> do a <- io; return (a, w) + +runHsc :: HscEnv -> Hsc a -> IO a +runHsc hsc_env (Hsc hsc) = do + (a, w) <- hsc hsc_env emptyBag + printOrThrowWarnings (hsc_dflags hsc_env) w + return a + +getWarnings :: Hsc WarningMessages +getWarnings = Hsc $ \_ w -> return (w, w) + +clearWarnings :: Hsc () +clearWarnings = Hsc $ \_ _w -> return ((), emptyBag) + +logWarnings :: WarningMessages -> Hsc () +logWarnings w = Hsc $ \_ w0 -> return ((), w0 `unionBags` w) + +getHscEnv :: Hsc HscEnv +getHscEnv = Hsc $ \e w -> return (e, w) + +getDynFlags :: Hsc DynFlags +getDynFlags = Hsc $ \e w -> return (hsc_dflags e, w) + +handleWarnings :: Hsc () +handleWarnings = do + dflags <- getDynFlags + w <- getWarnings + liftIO $ printOrThrowWarnings dflags w + clearWarnings + +-- | log warning in the monad, and if there are errors then +-- throw a SourceError exception. +logWarningsReportErrors :: Messages -> Hsc () +logWarningsReportErrors (warns,errs) = do + logWarnings warns + when (not (isEmptyBag errs)) $ do + liftIO $ throwIO $ mkSrcErr errs + +-- | Deal with errors and warnings returned by a compilation step +-- +-- In order to reduce dependencies to other parts of the compiler, functions +-- outside the "main" parts of GHC return warnings and errors as a parameter +-- and signal success via by wrapping the result in a 'Maybe' type. This +-- function logs the returned warnings and propagates errors as exceptions +-- (of type 'SourceError'). +-- +-- This function assumes the following invariants: +-- +-- 1. If the second result indicates success (is of the form 'Just x'), +-- there must be no error messages in the first result. +-- +-- 2. If there are no error messages, but the second result indicates failure +-- there should be warnings in the first result. That is, if the action +-- failed, it must have been due to the warnings (i.e., @-Werror@). +ioMsgMaybe :: IO (Messages, Maybe a) -> Hsc a +ioMsgMaybe ioA = do + ((warns,errs), mb_r) <- liftIO $ ioA + logWarnings warns + case mb_r of + Nothing -> liftIO $ throwIO (mkSrcErr errs) + Just r -> ASSERT( isEmptyBag errs ) return r + +-- | like ioMsgMaybe, except that we ignore error messages and return +-- 'Nothing' instead. +ioMsgMaybe' :: IO (Messages, Maybe a) -> Hsc (Maybe a) +ioMsgMaybe' ioA = do + ((warns,_errs), mb_r) <- liftIO $ ioA + logWarnings warns + return mb_r + +-- ----------------------------------------------------------------------------- +-- | Lookup things in the compiler's environment + +#ifdef GHCI +hscTcRnLookupRdrName :: HscEnv -> RdrName -> IO [Name] +hscTcRnLookupRdrName hsc_env rdr_name = + runHsc hsc_env $ ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name +#endif + +hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing) +hscTcRcLookupName hsc_env name = + runHsc hsc_env $ ioMsgMaybe' $ tcRnLookupName hsc_env name + -- ignore errors: the only error we're likely to get is + -- "name not found", and the Maybe in the return type + -- is used to indicate that. + +hscTcRnGetInfo :: HscEnv -> Name -> IO (Maybe (TyThing, Fixity, [Instance])) +hscTcRnGetInfo hsc_env name = + runHsc hsc_env $ ioMsgMaybe' $ tcRnGetInfo hsc_env name + +#ifdef GHCI +hscGetModuleExports :: HscEnv -> Module -> IO (Maybe [AvailInfo]) +hscGetModuleExports hsc_env mdl = + runHsc hsc_env $ ioMsgMaybe' $ getModuleExports hsc_env mdl + +-- ----------------------------------------------------------------------------- +-- | Rename some import declarations + +hscRnImportDecls + :: HscEnv + -> Module + -> [LImportDecl RdrName] + -> IO GlobalRdrEnv + +-- It is important that we use tcRnImports instead of calling rnImports directly +-- because tcRnImports will force-load any orphan modules necessary, making extra +-- instances/family instances visible (GHC #4832) +hscRnImportDecls hsc_env this_mod import_decls + = runHsc hsc_env $ ioMsgMaybe $ initTc hsc_env HsSrcFile False this_mod $ + fmap tcg_rdr_env $ tcRnImports hsc_env this_mod import_decls + +#endif + +-- ----------------------------------------------------------------------------- -- | parse a file, returning the abstract syntax -hscParse :: GhcMonad m => - ModSummary - -> m (Located (HsModule RdrName)) -hscParse mod_summary = do - hsc_env <- getSession - let dflags = hsc_dflags hsc_env + +hscParse :: HscEnv -> ModSummary -> IO (Located (HsModule RdrName)) +hscParse hsc_env mod_summary = runHsc hsc_env $ hscParse' mod_summary + +-- internal version, that doesn't fail due to -Werror +hscParse' :: ModSummary -> Hsc (Located (HsModule RdrName)) +hscParse' mod_summary + = do + dflags <- getDynFlags + let src_filename = ms_hspp_file mod_summary maybe_src_buf = ms_hspp_buf mod_summary + -------------------------- Parser ---------------- liftIO $ showPass dflags "Parser" {-# SCC "Parser" #-} do @@ -184,34 +340,21 @@ Just b -> return b Nothing -> liftIO $ hGetStringBuffer src_filename - let loc = mkSrcLoc (mkFastString src_filename) 1 1 + let loc = mkRealSrcLoc (mkFastString src_filename) 1 1 case unP parseModule (mkPState dflags buf loc) of PFailed span err -> - throwOneError (mkPlainErrMsg span err) + liftIO $ throwOneError (mkPlainErrMsg span err) POk pst rdr_module -> do - let ms@(warns,errs) = getMessages pst - logWarnings warns - if errorsFound dflags ms then - liftIO $ throwIO $ mkSrcErr errs - else liftIO $ do - dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr rdr_module) ; - dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" - (ppSourceStats False rdr_module) ; - return rdr_module + logWarningsReportErrors (getMessages pst) + liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" $ + ppr rdr_module + liftIO $ dumpIfSet_dyn dflags Opt_D_source_stats "Source Statistics" $ + ppSourceStats False rdr_module + return rdr_module -- ToDo: free the string buffer later. --- | Rename and typecheck a module -hscTypecheck :: GhcMonad m => - ModSummary -> Located (HsModule RdrName) - -> m TcGblEnv -hscTypecheck mod_summary rdr_module = do - hsc_env <- getSession - r <- {-# SCC "Typecheck-Rename" #-} - ioMsgMaybe $ tcRnModule hsc_env (ms_hsc_src mod_summary) False rdr_module - return r - -- XXX: should this really be a Maybe X? Check under which circumstances this -- can become a Nothing and decide whether this should instead throw an -- exception/signal an error. @@ -220,48 +363,59 @@ Maybe LHsDocString)) -- | Rename and typecheck a module, additionally returning the renamed syntax -hscTypecheckRename :: - GhcMonad m => - ModSummary -> Located (HsModule RdrName) - -> m (TcGblEnv, RenamedStuff) -hscTypecheckRename mod_summary rdr_module = do - hsc_env <- getSession - tc_result +hscTypecheckRename :: HscEnv -> ModSummary -> Located (HsModule RdrName) + -> IO (TcGblEnv, RenamedStuff) +hscTypecheckRename hsc_env mod_summary rdr_module + = runHsc hsc_env $ do + tc_result <- {-# SCC "Typecheck-Rename" #-} - ioMsgMaybe $ tcRnModule hsc_env (ms_hsc_src mod_summary) True rdr_module + ioMsgMaybe $ + tcRnModule hsc_env (ms_hsc_src mod_summary) True rdr_module - let -- This 'do' is in the Maybe monad! - rn_info = do { decl <- tcg_rn_decls tc_result - ; let imports = tcg_rn_imports tc_result + let -- This 'do' is in the Maybe monad! + rn_info = do decl <- tcg_rn_decls tc_result + let imports = tcg_rn_imports tc_result exports = tcg_rn_exports tc_result doc_hdr = tcg_doc_hdr tc_result - ; return (decl,imports,exports,doc_hdr) } + return (decl,imports,exports,doc_hdr) - return (tc_result, rn_info) + return (tc_result, rn_info) -- | Convert a typechecked module to Core -hscDesugar :: GhcMonad m => ModSummary -> TcGblEnv -> m ModGuts -hscDesugar mod_summary tc_result = - withSession $ \hsc_env -> - ioMsgMaybe $ deSugar hsc_env (ms_location mod_summary) tc_result +hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts +hscDesugar hsc_env mod_summary tc_result + = runHsc hsc_env $ hscDesugar' mod_summary tc_result + +hscDesugar' :: ModSummary -> TcGblEnv -> Hsc ModGuts +hscDesugar' mod_summary tc_result + = do + hsc_env <- getHscEnv + r <- ioMsgMaybe $ + deSugar hsc_env (ms_location mod_summary) tc_result + + handleWarnings + -- always check -Werror after desugaring, this is + -- the last opportunity for warnings to arise before + -- the backend. + return r -- | Make a 'ModIface' from the results of typechecking. Used when -- not optimising, and the interface doesn't need to contain any -- unfoldings or other cross-module optimisation info. -- ToDo: the old interface is only needed to get the version numbers, -- we should use fingerprint versions instead. -makeSimpleIface :: GhcMonad m => +makeSimpleIface :: HscEnv -> Maybe ModIface -> TcGblEnv -> ModDetails - -> m (ModIface,Bool) -makeSimpleIface maybe_old_iface tc_result details = - withSession $ \hsc_env -> - ioMsgMaybe $ mkIfaceTc hsc_env (fmap mi_iface_hash maybe_old_iface) details tc_result + -> IO (ModIface,Bool) +makeSimpleIface hsc_env maybe_old_iface tc_result details + = runHsc hsc_env $ + ioMsgMaybe $ + mkIfaceTc hsc_env (fmap mi_iface_hash maybe_old_iface) details tc_result -- | Make a 'ModDetails' from the results of typechecking. Used when -- typechecking only, as opposed to full compilation. -makeSimpleDetails :: GhcMonad m => TcGblEnv -> m ModDetails -makeSimpleDetails tc_result = - withSession $ \hsc_env -> liftIO $ mkBootModDetailsTc hsc_env tc_result +makeSimpleDetails :: HscEnv -> TcGblEnv -> IO ModDetails +makeSimpleDetails hsc_env tc_result = mkBootModDetailsTc hsc_env tc_result \end{code} %************************************************************************ @@ -276,7 +430,7 @@ It's the task of the compilation proper to compile Haskell, hs-boot and -core files to either byte-code, hard-code (C, asm, Java, ect) or to +core files to either byte-code, hard-code (C, asm, LLVM, ect) or to nothing at all (the module is still parsed and type-checked. This feature is mostly used by IDE's and the likes). Compilation can happen in either 'one-shot', 'batch', 'nothing', @@ -307,7 +461,8 @@ data HscStatus' a = HscNoRecomp | HscRecomp - Bool -- Has stub files. This is a hack. We can't compile C files here + (Maybe FilePath) + -- Has stub files. This is a hack. We can't compile C files here -- since it's done in DriverPipeline. For now we just return True -- if we want the caller to compile them for us. a @@ -327,82 +482,108 @@ -- FIXME: The old interface and module index are only using in 'batch' and -- 'interactive' mode. They should be removed from 'oneshot' mode. -type Compiler result = GhcMonad m => - HscEnv +type Compiler result = HscEnv -> ModSummary - -> Bool -- True <=> source unchanged + -> SourceModified -> Maybe ModIface -- Old interface, if available -> Maybe (Int,Int) -- Just (i,n) <=> module i of n (for msgs) - -> m result + -> IO result data HsCompiler a = HsCompiler { -- | Called when no recompilation is necessary. - hscNoRecomp :: GhcMonad m => - ModIface -> m a, + hscNoRecomp :: ModIface + -> Hsc a, -- | Called to recompile the module. - hscRecompile :: GhcMonad m => - ModSummary -> Maybe Fingerprint -> m a, + hscRecompile :: ModSummary -> Maybe Fingerprint + -> Hsc a, - hscBackend :: GhcMonad m => - TcGblEnv -> ModSummary -> Maybe Fingerprint -> m a, + hscBackend :: TcGblEnv -> ModSummary -> Maybe Fingerprint + -> Hsc a, -- | Code generation for Boot modules. - hscGenBootOutput :: GhcMonad m => - TcGblEnv -> ModSummary -> Maybe Fingerprint -> m a, + hscGenBootOutput :: TcGblEnv -> ModSummary -> Maybe Fingerprint + -> Hsc a, -- | Code generation for normal modules. - hscGenOutput :: GhcMonad m => - ModGuts -> ModSummary -> Maybe Fingerprint -> m a + hscGenOutput :: ModGuts -> ModSummary -> Maybe Fingerprint + -> Hsc a } -genericHscCompile :: GhcMonad m => - HsCompiler a - -> (Maybe (Int,Int) -> Bool -> ModSummary -> m ()) - -> HscEnv -> ModSummary -> Bool +genericHscCompile :: HsCompiler a + -> (HscEnv -> Maybe (Int,Int) -> RecompReason -> ModSummary -> IO ()) + -> HscEnv -> ModSummary -> SourceModified -> Maybe ModIface -> Maybe (Int, Int) - -> m a -genericHscCompile compiler hscMessage - hsc_env mod_summary source_unchanged - mb_old_iface0 mb_mod_index = - withTempSession (\_ -> hsc_env) $ do + -> IO a +genericHscCompile compiler hscMessage hsc_env + mod_summary source_modified + mb_old_iface0 mb_mod_index + = do (recomp_reqd, mb_checked_iface) <- {-# SCC "checkOldIface" #-} - liftIO $ checkOldIface hsc_env mod_summary - source_unchanged mb_old_iface0 + checkOldIface hsc_env mod_summary + source_modified mb_old_iface0 -- save the interface that comes back from checkOldIface. -- In one-shot mode we don't have the old iface until this -- point, when checkOldIface reads it from the disk. let mb_old_hash = fmap mi_iface_hash mb_checked_iface + + let + skip iface = do + hscMessage hsc_env mb_mod_index RecompNotRequired mod_summary + runHsc hsc_env $ hscNoRecomp compiler iface + + compile reason = do + hscMessage hsc_env mb_mod_index reason mod_summary + runHsc hsc_env $ hscRecompile compiler mod_summary mb_old_hash + + stable = case source_modified of + SourceUnmodifiedAndStable -> True + _ -> False + + -- If the module used TH splices when it was last compiled, + -- then the recompilation check is not accurate enough (#481) + -- and we must ignore it. However, if the module is stable + -- (none of the modules it depends on, directly or indirectly, + -- changed), then we *can* skip recompilation. This is why + -- the SourceModified type contains SourceUnmodifiedAndStable, + -- and it's pretty important: otherwise ghc --make would + -- always recompile TH modules, even if nothing at all has + -- changed. Stability is just the same check that make is + -- doing for us in one-shot mode. + case mb_checked_iface of - Just iface | not recomp_reqd - -> do hscMessage mb_mod_index False mod_summary - hscNoRecomp compiler iface - _otherwise - -> do hscMessage mb_mod_index True mod_summary - hscRecompile compiler mod_summary mb_old_hash + Just iface | not recomp_reqd -> + if mi_used_th iface && not stable + then compile RecompForcedByTH + else skip iface + _otherwise -> + compile RecompRequired + hscCheckRecompBackend :: HsCompiler a -> TcGblEnv -> Compiler a hscCheckRecompBackend compiler tc_result - hsc_env mod_summary source_unchanged mb_old_iface _m_of_n = - withTempSession (\_ -> hsc_env) $ do + hsc_env mod_summary source_modified mb_old_iface _m_of_n + = do (recomp_reqd, mb_checked_iface) <- {-# SCC "checkOldIface" #-} - liftIO $ checkOldIface hsc_env mod_summary - source_unchanged mb_old_iface + checkOldIface hsc_env mod_summary + source_modified mb_old_iface let mb_old_hash = fmap mi_iface_hash mb_checked_iface case mb_checked_iface of Just iface | not recomp_reqd - -> hscNoRecomp compiler iface{ mi_globals = Just (tcg_rdr_env tc_result) } + -> runHsc hsc_env $ + hscNoRecomp compiler + iface{ mi_globals = Just (tcg_rdr_env tc_result) } _otherwise - -> hscBackend compiler tc_result mod_summary mb_old_hash + -> runHsc hsc_env $ + hscBackend compiler tc_result mod_summary mb_old_hash -genericHscRecompile :: GhcMonad m => - HsCompiler a +genericHscRecompile :: HsCompiler a -> ModSummary -> Maybe Fingerprint - -> m a + -> Hsc a genericHscRecompile compiler mod_summary mb_old_hash | ExtCoreFile <- ms_hsc_src mod_summary = panic "GHC does not currently support reading External Core files" @@ -410,17 +591,21 @@ tc_result <- hscFileFrontEnd mod_summary hscBackend compiler tc_result mod_summary mb_old_hash -genericHscBackend :: GhcMonad m => - HsCompiler a +genericHscBackend :: HsCompiler a -> TcGblEnv -> ModSummary -> Maybe Fingerprint - -> m a + -> Hsc a genericHscBackend compiler tc_result mod_summary mb_old_hash | HsBootFile <- ms_hsc_src mod_summary = hscGenBootOutput compiler tc_result mod_summary mb_old_hash | otherwise = do - guts <- hscDesugar mod_summary tc_result + guts <- hscDesugar' mod_summary tc_result hscGenOutput compiler guts mod_summary mb_old_hash +compilerBackend :: HsCompiler a -> TcGblEnv -> Compiler a +compilerBackend comp tcg hsc_env ms' _ _mb_old_iface _ = + runHsc hsc_env $ + hscBackend comp tcg ms' Nothing + -------------------------------------------------------------- -- Compilers -------------------------------------------------------------- @@ -430,27 +615,27 @@ HsCompiler { hscNoRecomp = \_old_iface -> do - withSession (liftIO . dumpIfaceStats) + hsc_env <- getHscEnv + liftIO $ dumpIfaceStats hsc_env return HscNoRecomp , hscRecompile = genericHscRecompile hscOneShotCompiler , hscBackend = \ tc_result mod_summary mb_old_hash -> do - hsc_env <- getSession - case hscTarget (hsc_dflags hsc_env) of - HscNothing -> return (HscRecomp False ()) - _otherw -> genericHscBackend hscOneShotCompiler + dflags <- getDynFlags + case hscTarget dflags of + HscNothing -> return (HscRecomp Nothing ()) + _otherw -> genericHscBackend hscOneShotCompiler tc_result mod_summary mb_old_hash , hscGenBootOutput = \tc_result mod_summary mb_old_iface -> do (iface, changed, _) <- hscSimpleIface tc_result mb_old_iface hscWriteIface iface changed mod_summary - return (HscRecomp False ()) + return (HscRecomp Nothing ()) , hscGenOutput = \guts0 mod_summary mb_old_iface -> do - guts <- hscSimplify guts0 - (iface, changed, _details, cgguts) - <- hscNormalIface guts mb_old_iface + guts <- hscSimplify' guts0 + (iface, changed, _details, cgguts) <- hscNormalIface guts mb_old_iface hscWriteIface iface changed mod_summary hasStub <- hscGenHardCode cgguts mod_summary return (HscRecomp hasStub ()) @@ -458,10 +643,11 @@ -- Compile Haskell, boot and extCore in OneShot mode. hscCompileOneShot :: Compiler OneShotResult -hscCompileOneShot hsc_env mod_summary src_changed mb_old_iface mb_i_of_n = do +hscCompileOneShot hsc_env mod_summary src_changed mb_old_iface mb_i_of_n + = do -- One-shot mode needs a knot-tying mutable variable for interface -- files. See TcRnTypes.TcGblEnv.tcg_type_env_var. - type_env_var <- liftIO $ newIORef emptyNameEnv + type_env_var <- newIORef emptyNameEnv let mod = ms_mod mod_summary hsc_env' = hsc_env{ hsc_type_env_var = Just (mod, type_env_var) } @@ -471,6 +657,9 @@ mb_old_iface mb_i_of_n +hscOneShotBackendOnly :: TcGblEnv -> Compiler OneShotResult +hscOneShotBackendOnly = compilerBackend hscOneShotCompiler + -------------------------------------------------------------- hscBatchCompiler :: HsCompiler BatchResult @@ -486,15 +675,13 @@ , hscBackend = genericHscBackend hscBatchCompiler , hscGenBootOutput = \tc_result mod_summary mb_old_iface -> do - (iface, changed, details) - <- hscSimpleIface tc_result mb_old_iface + (iface, changed, details) <- hscSimpleIface tc_result mb_old_iface hscWriteIface iface changed mod_summary - return (HscRecomp False (), iface, details) + return (HscRecomp Nothing (), iface, details) , hscGenOutput = \guts0 mod_summary mb_old_iface -> do - guts <- hscSimplify guts0 - (iface, changed, details, cgguts) - <- hscNormalIface guts mb_old_iface + guts <- hscSimplify' guts0 + (iface, changed, details, cgguts) <- hscNormalIface guts mb_old_iface hscWriteIface iface changed mod_summary hasStub <- hscGenHardCode cgguts mod_summary return (HscRecomp hasStub (), iface, details) @@ -504,6 +691,9 @@ hscCompileBatch :: Compiler (HscStatus, ModIface, ModDetails) hscCompileBatch = genericHscCompile hscBatchCompiler batchMsg +hscBatchBackendOnly :: TcGblEnv -> Compiler BatchResult +hscBatchBackendOnly = hscCheckRecompBackend hscBatchCompiler + -------------------------------------------------------------- hscInteractiveCompiler :: HsCompiler InteractiveResult @@ -519,12 +709,11 @@ , hscGenBootOutput = \tc_result _mod_summary mb_old_iface -> do (iface, _changed, details) <- hscSimpleIface tc_result mb_old_iface - return (HscRecomp False Nothing, iface, details) + return (HscRecomp Nothing Nothing, iface, details) , hscGenOutput = \guts0 mod_summary mb_old_iface -> do - guts <- hscSimplify guts0 - (iface, _changed, details, cgguts) - <- hscNormalIface guts mb_old_iface + guts <- hscSimplify' guts0 + (iface, _changed, details, cgguts) <- hscNormalIface guts mb_old_iface hscInteractive (iface, details, cgguts) mod_summary } @@ -532,6 +721,9 @@ hscCompileInteractive :: Compiler (InteractiveStatus, ModIface, ModDetails) hscCompileInteractive = genericHscCompile hscInteractiveCompiler batchMsg +hscInteractiveBackendOnly :: TcGblEnv -> Compiler InteractiveResult +hscInteractiveBackendOnly = compilerBackend hscInteractiveCompiler + -------------------------------------------------------------- hscNothingCompiler :: HsCompiler NothingResult @@ -544,8 +736,9 @@ , hscRecompile = genericHscRecompile hscNothingCompiler , hscBackend = \tc_result _mod_summary mb_old_iface -> do + handleWarnings (iface, _changed, details) <- hscSimpleIface tc_result mb_old_iface - return (HscRecomp False (), iface, details) + return (HscRecomp Nothing (), iface, details) , hscGenBootOutput = \_ _ _ -> panic "hscCompileNothing: hscGenBootOutput should not be called" @@ -558,89 +751,289 @@ hscCompileNothing :: Compiler (HscStatus, ModIface, ModDetails) hscCompileNothing = genericHscCompile hscNothingCompiler batchMsg +hscNothingBackendOnly :: TcGblEnv -> Compiler NothingResult +hscNothingBackendOnly = compilerBackend hscNothingCompiler + -------------------------------------------------------------- -- NoRecomp handlers -------------------------------------------------------------- -genModDetails :: GhcMonad m => ModIface -> m ModDetails -genModDetails old_iface = - withSession $ \hsc_env -> liftIO $ do +genModDetails :: ModIface -> Hsc ModDetails +genModDetails old_iface + = do + hsc_env <- getHscEnv new_details <- {-# SCC "tcRnIface" #-} - initIfaceCheck hsc_env $ - typecheckIface old_iface - dumpIfaceStats hsc_env + liftIO $ initIfaceCheck hsc_env $ + typecheckIface old_iface + liftIO $ dumpIfaceStats hsc_env return new_details -------------------------------------------------------------- -- Progress displayers. -------------------------------------------------------------- -oneShotMsg :: GhcMonad m => Maybe (Int,Int) -> Bool -> ModSummary -> m () -oneShotMsg _mb_mod_index recomp _mod_summary - = do hsc_env <- getSession - liftIO $ do - if recomp - then return () - else compilationProgressMsg (hsc_dflags hsc_env) $ - "compilation IS NOT required" - -batchMsg :: GhcMonad m => Maybe (Int,Int) -> Bool -> ModSummary -> m () -batchMsg mb_mod_index recomp mod_summary - = do hsc_env <- getSession - let showMsg msg = compilationProgressMsg (hsc_dflags hsc_env) $ - (showModuleIndex mb_mod_index ++ - msg ++ showModMsg (hscTarget (hsc_dflags hsc_env)) recomp mod_summary) - liftIO $ do - if recomp - then showMsg "Compiling " - else if verbosity (hsc_dflags hsc_env) >= 2 - then showMsg "Skipping " - else return () +data RecompReason = RecompNotRequired | RecompRequired | RecompForcedByTH + deriving Eq + +oneShotMsg :: HscEnv -> Maybe (Int,Int) -> RecompReason -> ModSummary -> IO () +oneShotMsg hsc_env _mb_mod_index recomp _mod_summary = + case recomp of + RecompNotRequired -> + compilationProgressMsg (hsc_dflags hsc_env) $ + "compilation IS NOT required" + _other -> + return () + +batchMsg :: HscEnv -> Maybe (Int,Int) -> RecompReason -> ModSummary -> IO () +batchMsg hsc_env mb_mod_index recomp mod_summary + = case recomp of + RecompRequired -> showMsg "Compiling " + RecompNotRequired + | verbosity (hsc_dflags hsc_env) >= 2 -> showMsg "Skipping " + | otherwise -> return () + RecompForcedByTH -> showMsg "Compiling [TH] " + where + showMsg msg = + compilationProgressMsg (hsc_dflags hsc_env) $ + (showModuleIndex mb_mod_index ++ + msg ++ showModMsg (hscTarget (hsc_dflags hsc_env)) (recomp == RecompRequired) mod_summary) -------------------------------------------------------------- -- FrontEnds -------------------------------------------------------------- -hscFileFrontEnd :: GhcMonad m => ModSummary -> m TcGblEnv -hscFileFrontEnd mod_summary = - do rdr_module <- hscParse mod_summary - hscTypecheck mod_summary rdr_module +hscFileFrontEnd :: ModSummary -> Hsc TcGblEnv +hscFileFrontEnd mod_summary = do + rdr_module <- hscParse' mod_summary + hsc_env <- getHscEnv + tcg_env <- + {-# SCC "Typecheck-Rename" #-} + ioMsgMaybe $ + tcRnModule hsc_env (ms_hsc_src mod_summary) False rdr_module + dflags <- getDynFlags + -- XXX: See Note [Safe Haskell API] + if safeHaskellOn dflags + then do + tcg_env1 <- checkSafeImports dflags hsc_env tcg_env + if safeLanguageOn dflags + then do + -- we also nuke user written RULES. + logWarnings $ warns (tcg_rules tcg_env1) + return tcg_env1 { tcg_rules = [] } + else do + -- Wipe out trust required packages if the module isn't + -- trusted. Not doing this doesn't cause any problems + -- but means the hi file will say some pkgs should be + -- trusted when they don't need to be (since its an + -- untrusted module) and we don't force them to be. + let imps = tcg_imports tcg_env1 + imps' = imps { imp_trust_pkgs = [] } + return tcg_env1 { tcg_imports = imps' } + + else + return tcg_env + + where + warns rules = listToBag $ map warnRules rules + warnRules (L loc (HsRule n _ _ _ _ _ _)) = + mkPlainWarnMsg loc $ + text "Rule \"" <> ftext n <> text "\" ignored" $+$ + text "User defined rules are disabled under Safe Haskell" + +-------------------------------------------------------------- +-- Safe Haskell +-------------------------------------------------------------- + +-- Note [Safe Haskell API] +-- ~~~~~~~~~~~~~~~~~~~~~~ +-- XXX: We only call this in hscFileFrontend and don't expose +-- it to the GHC API. External users of GHC can't properly use +-- the GHC API and Safe Haskell. + + +-- Note [Safe Haskell Trust Check] +-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-- Safe Haskell checks that an import is trusted according to the following +-- rules for an import of module M that resides in Package P: +-- +-- * If M is recorded as Safe and all its trust dependencies are OK +-- then M is considered safe. +-- * If M is recorded as Trustworthy and P is considered trusted and +-- all M's trust dependencies are OK then M is considered safe. +-- +-- By trust dependencies we mean that the check is transitive. So if +-- a module M that is Safe relies on a module N that is trustworthy, +-- importing module M will first check (according to the second case) +-- that N is trusted before checking M is trusted. +-- +-- This is a minimal description, so please refer to the user guide +-- for more details. The user guide is also considered the authoritative +-- source in this matter, not the comments or code. + + +-- | Validate that safe imported modules are actually safe. +-- For modules in the HomePackage (the package the module we +-- are compiling in resides) this just involves checking its +-- trust type is 'Safe' or 'Trustworthy'. For modules that +-- reside in another package we also must check that the +-- external pacakge is trusted. See the Note [Safe Haskell +-- Trust Check] above for more information. +-- +-- The code for this is quite tricky as the whole algorithm +-- is done in a few distinct phases in different parts of the +-- code base. See RnNames.rnImportDecl for where package trust +-- dependencies for a module are collected and unioned. +-- Specifically see the Note [RnNames . Tracking Trust Transitively] +-- and the Note [RnNames . Trust Own Package]. +checkSafeImports :: DynFlags -> HscEnv -> TcGblEnv -> Hsc TcGblEnv +checkSafeImports dflags hsc_env tcg_env + = do + imps <- mapM condense imports' + pkgs <- mapM checkSafe imps + checkPkgTrust pkg_reqs + + -- add in trusted package requirements for this module + let new_trust = emptyImportAvails { imp_trust_pkgs = catMaybes pkgs } + return tcg_env { tcg_imports = imp_info `plusImportAvails` new_trust } + + where + imp_info = tcg_imports tcg_env -- ImportAvails + imports = imp_mods imp_info -- ImportedMods + imports' = moduleEnvToList imports -- (Module, [ImportedModsVal]) + pkg_reqs = imp_trust_pkgs imp_info -- [PackageId] + + condense :: (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, IsSafeImport) + condense (_, []) = panic "HscMain.condense: Pattern match failure!" + condense (m, x:xs) = do (_,_,l,s) <- foldlM cond' x xs + return (m, l, s) + + -- ImportedModsVal = (ModuleName, Bool, SrcSpan, IsSafeImport) + cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal + cond' v1@(m1,_,l1,s1) (_,_,_,s2) + | s1 /= s2 + = liftIO $ throwIO $ mkSrcErr $ unitBag $ mkPlainErrMsg l1 + (text "Module" <+> ppr m1 <+> (text $ "is imported" + ++ " both as a safe and unsafe import!")) + | otherwise + = return v1 + + lookup' :: Module -> Hsc (Maybe ModIface) + lookup' m = do + hsc_eps <- liftIO $ hscEPS hsc_env + let pkgIfaceT = eps_PIT hsc_eps + homePkgT = hsc_HPT hsc_env + iface = lookupIfaceByModule dflags homePkgT pkgIfaceT m + return iface + + isHomePkg :: Module -> Bool + isHomePkg m + | thisPackage dflags == modulePackageId m = True + | otherwise = False + + -- | Check the package a module resides in is trusted. + -- Safe compiled modules are trusted without requiring + -- that their package is trusted. For trustworthy modules, + -- modules in the home package are trusted but otherwise + -- we check the package trust flag. + packageTrusted :: SafeHaskellMode -> Bool -> Module -> Bool + packageTrusted Sf_Safe False _ = True + packageTrusted _ _ m + | isHomePkg m = True + | otherwise = trusted $ getPackageDetails (pkgState dflags) + (modulePackageId m) + + -- Is a module trusted? Return Nothing if True, or a String + -- if it isn't, containing the reason it isn't + isModSafe :: Module -> SrcSpan -> Hsc (Maybe SDoc) + isModSafe m l = do + iface <- lookup' m + case iface of + -- can't load iface to check trust! + Nothing -> liftIO $ throwIO $ mkSrcErr $ unitBag $ mkPlainErrMsg l + $ text "Can't load the interface file for" <+> ppr m <> + text ", to check that it can be safely imported" + + -- got iface, check trust + Just iface' -> do + let trust = getSafeMode $ mi_trust iface' + trust_own_pkg = mi_trust_pkg iface' + -- check module is trusted + safeM = trust `elem` [Sf_Safe, Sf_Trustworthy] + -- check package is trusted + safeP = packageTrusted trust trust_own_pkg m + if safeM && safeP + then return Nothing + else return $ Just $ if safeM + then text "The package (" <> ppr (modulePackageId m) <> + text ") the module resides in isn't trusted." + else text "The module itself isn't safe." + + -- Here we check the transitive package trust requirements are OK still. + checkPkgTrust :: [PackageId] -> Hsc () + checkPkgTrust pkgs = do + case errors of + [] -> return () + _ -> (liftIO . throwIO . mkSrcErr . listToBag) errors + where + errors = catMaybes $ map go pkgs + go pkg + | trusted $ getPackageDetails (pkgState dflags) pkg + = Nothing + | otherwise + = Just $ mkPlainErrMsg noSrcSpan + $ text "The package (" <> ppr pkg <> text ") is required" + <> text " to be trusted but it isn't!" + + checkSafe :: (Module, SrcSpan, IsSafeImport) -> Hsc (Maybe PackageId) + checkSafe (_, _, False) = return Nothing + checkSafe (m, l, True ) = do + module_safe <- isModSafe m l + case module_safe of + Nothing -> return pkg + Just s -> liftIO $ throwIO $ mkSrcErr $ unitBag $ mkPlainErrMsg l + $ ppr m <+> text "can't be safely imported!" + <+> s + where pkg | isHomePkg m = Nothing + | otherwise = Just (modulePackageId m) + -------------------------------------------------------------- -- Simplifiers -------------------------------------------------------------- -hscSimplify :: GhcMonad m => ModGuts -> m ModGuts -hscSimplify ds_result - = do hsc_env <- getSession - simpl_result <- {-# SCC "Core2Core" #-} - liftIO $ core2core hsc_env ds_result - return simpl_result +hscSimplify :: HscEnv -> ModGuts -> IO ModGuts +hscSimplify hsc_env modguts = runHsc hsc_env $ hscSimplify' modguts + +hscSimplify' :: ModGuts -> Hsc ModGuts +hscSimplify' ds_result + = do hsc_env <- getHscEnv + {-# SCC "Core2Core" #-} + liftIO $ core2core hsc_env ds_result -------------------------------------------------------------- -- Interface generators -------------------------------------------------------------- -hscSimpleIface :: GhcMonad m => - TcGblEnv +hscSimpleIface :: TcGblEnv -> Maybe Fingerprint - -> m (ModIface, Bool, ModDetails) + -> Hsc (ModIface, Bool, ModDetails) hscSimpleIface tc_result mb_old_iface - = do hsc_env <- getSession + = do + hsc_env <- getHscEnv details <- liftIO $ mkBootModDetailsTc hsc_env tc_result (new_iface, no_change) <- {-# SCC "MkFinalIface" #-} - ioMsgMaybe $ mkIfaceTc hsc_env mb_old_iface details tc_result + ioMsgMaybe $ + mkIfaceTc hsc_env mb_old_iface details tc_result -- And the answer is ... liftIO $ dumpIfaceStats hsc_env return (new_iface, no_change, details) -hscNormalIface :: GhcMonad m => - ModGuts +hscNormalIface :: ModGuts -> Maybe Fingerprint - -> m (ModIface, Bool, ModDetails, CgGuts) + -> Hsc (ModIface, Bool, ModDetails, CgGuts) hscNormalIface simpl_result mb_old_iface - = do hsc_env <- getSession - + = do + hsc_env <- getHscEnv (cg_guts, details) <- {-# SCC "CoreTidy" #-} liftIO $ tidyProgram hsc_env simpl_result @@ -651,9 +1044,10 @@ -- until after code output (new_iface, no_change) <- {-# SCC "MkFinalIface" #-} - ioMsgMaybe $ mkIface hsc_env mb_old_iface - details simpl_result - -- Emit external core + ioMsgMaybe $ + mkIface hsc_env mb_old_iface details simpl_result + + -- Emit external core -- This should definitely be here and not after CorePrep, -- because CorePrep produces unqualified constructor wrapper declarations, -- so its output isn't valid External Core (without some preprocessing). @@ -667,33 +1061,33 @@ -- BackEnd combinators -------------------------------------------------------------- -hscWriteIface :: GhcMonad m => - ModIface -> Bool +hscWriteIface :: ModIface + -> Bool -> ModSummary - -> m () + -> Hsc () + hscWriteIface iface no_change mod_summary - = do hsc_env <- getSession - let dflags = hsc_dflags hsc_env - liftIO $ do + = do dflags <- getDynFlags unless no_change - $ writeIfaceFile dflags (ms_location mod_summary) iface + $ liftIO $ writeIfaceFile dflags (ms_location mod_summary) iface -- | Compile to hard-code. -hscGenHardCode :: GhcMonad m => - CgGuts -> ModSummary - -> m Bool -- ^ @True@ <=> stub.c exists +hscGenHardCode :: CgGuts -> ModSummary + -> Hsc (Maybe FilePath) -- ^ @Just f@ <=> _stub.c is f hscGenHardCode cgguts mod_summary - = withSession $ \hsc_env -> liftIO $ do + = do + hsc_env <- getHscEnv + liftIO $ do let CgGuts{ -- This is the last use of the ModGuts in a compilation. -- From now on, we just use the bits we need. cg_module = this_mod, cg_binds = core_binds, cg_tycons = tycons, - cg_dir_imps = dir_imps, - cg_foreign = foreign_stubs, + cg_foreign = foreign_stubs0, cg_dep_pkgs = dependencies, cg_hpc_info = hpc_info } = cgguts dflags = hsc_dflags hsc_env + platform = targetPlatform dflags location = ms_location mod_summary data_tycons = filter isDataTyCon tycons -- cg_tycons includes newtypes, for the benefit of External Core, @@ -709,36 +1103,39 @@ <- {-# SCC "CoreToStg" #-} myCoreToStg dflags this_mod prepd_binds + let prof_init = profilingInitCode this_mod cost_centre_info + foreign_stubs = foreign_stubs0 `appendStubC` prof_init + ------------------ Code generation ------------------ - cmms <- if dopt Opt_TryNewCodeGen (hsc_dflags hsc_env) + + cmms <- if dopt Opt_TryNewCodeGen dflags then do cmms <- tryNewCodeGen hsc_env this_mod data_tycons - dir_imps cost_centre_info + cost_centre_info stg_binds hpc_info return cmms else {-# SCC "CodeGen" #-} codeGen dflags this_mod data_tycons - dir_imps cost_centre_info + cost_centre_info stg_binds hpc_info --- Optionally run experimental Cmm transformations --- - -- cmms <- optionallyConvertAndOrCPS hsc_env cmms + cmms <- optionallyConvertAndOrCPS hsc_env cmms -- unless certain dflags are on, the identity function ------------------ Code output ----------------------- rawcmms <- cmmToRawCmm cmms - dumpIfSet_dyn dflags Opt_D_dump_cmmz "Raw Cmm" (ppr rawcmms) + dumpIfSet_dyn dflags Opt_D_dump_raw_cmm "Raw Cmm" (pprPlatform platform rawcmms) (_stub_h_exists, stub_c_exists) <- codeOutput dflags this_mod location foreign_stubs dependencies rawcmms return stub_c_exists -hscInteractive :: GhcMonad m => - (ModIface, ModDetails, CgGuts) +hscInteractive :: (ModIface, ModDetails, CgGuts) -> ModSummary - -> m (InteractiveStatus, ModIface, ModDetails) + -> Hsc (InteractiveStatus, ModIface, ModDetails) #ifdef GHCI hscInteractive (iface, details, cgguts) mod_summary - = do hsc_env <- getSession - liftIO $ do + = do + dflags <- getDynFlags let CgGuts{ -- This is the last use of the ModGuts in a compilation. -- From now on, we just use the bits we need. cg_module = this_mod, @@ -746,7 +1143,7 @@ cg_tycons = tycons, cg_foreign = foreign_stubs, cg_modBreaks = mod_breaks } = cgguts - dflags = hsc_dflags hsc_env + location = ms_location mod_summary data_tycons = filter isDataTyCon tycons -- cg_tycons includes newtypes, for the benefit of External Core, @@ -756,12 +1153,13 @@ -- PREPARE FOR CODE GENERATION -- Do saturation and convert to A-normal form prepd_binds <- {-# SCC "CorePrep" #-} - corePrepPgm dflags core_binds data_tycons ; + liftIO $ corePrepPgm dflags core_binds data_tycons ; ----------------- Generate byte code ------------------ - comp_bc <- byteCodeGen dflags prepd_binds data_tycons mod_breaks + comp_bc <- liftIO $ byteCodeGen dflags prepd_binds data_tycons mod_breaks ------------------ Create f-x-dynamic C-side stuff --- (_istub_h_exists, istub_c_exists) - <- outputForeignStubs dflags this_mod location foreign_stubs + <- liftIO $ outputForeignStubs dflags this_mod + location foreign_stubs return (HscRecomp istub_c_exists (Just (comp_bc, mod_breaks)) , iface, details) #else @@ -770,15 +1168,16 @@ ------------------------------ -hscCmmFile :: GhcMonad m => HscEnv -> FilePath -> m () -hscCmmFile hsc_env filename = do - dflags <- return $ hsc_dflags hsc_env - cmm <- ioMsgMaybe $ - parseCmmFile dflags filename - cmms <- liftIO $ optionallyConvertAndOrCPS hsc_env [cmm] - rawCmms <- liftIO $ cmmToRawCmm cmms - _ <- liftIO $ codeOutput dflags no_mod no_loc NoStubs [] rawCmms - return () +hscCompileCmmFile :: HscEnv -> FilePath -> IO () +hscCompileCmmFile hsc_env filename + = runHsc hsc_env $ do + let dflags = hsc_dflags hsc_env + cmm <- ioMsgMaybe $ parseCmmFile dflags filename + liftIO $ do + cmms <- optionallyConvertAndOrCPS hsc_env [cmm] + rawCmms <- cmmToRawCmm cmms + _ <- codeOutput dflags no_mod no_loc NoStubs [] rawCmms + return () where no_mod = panic "hscCmmFile: no_mod" no_loc = ModLocation{ ml_hs_file = Just filename, @@ -787,35 +1186,29 @@ -------------------- Stuff for new code gen --------------------- -tryNewCodeGen :: HscEnv -> Module -> [TyCon] -> [Module] - -> CollectedCCs - -> [(StgBinding,[(Id,[Id])])] - -> HpcInfo - -> IO [Cmm] -tryNewCodeGen hsc_env this_mod data_tycons imported_mods - cost_centre_info stg_binds hpc_info = - do { let dflags = hsc_dflags hsc_env - ; prog <- StgCmm.codeGen dflags this_mod data_tycons imported_mods - cost_centre_info stg_binds hpc_info - ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Cmm produced by new codegen" - (pprCmms prog) - - ; prog <- return $ map (runTx $ runCmmOpts cmmCfgOptsZ) prog - -- Control flow optimisation +tryNewCodeGen :: HscEnv -> Module -> [TyCon] + -> CollectedCCs + -> [(StgBinding,[(Id,[Id])])] + -> HpcInfo + -> IO [Cmm] +tryNewCodeGen hsc_env this_mod data_tycons + cost_centre_info stg_binds hpc_info = + do { let dflags = hsc_dflags hsc_env + platform = targetPlatform dflags + ; prog <- StgCmm.codeGen dflags this_mod data_tycons + cost_centre_info stg_binds hpc_info + ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Cmm produced by new codegen" + (pprCmms platform prog) -- We are building a single SRT for the entire module, so -- we must thread it through all the procedures as we cps-convert them. ; us <- mkSplitUniqSupply 'S' - ; let topSRT = initUs_ us emptySRT - ; (topSRT, prog) <- foldM (protoCmmCPSZ hsc_env) (topSRT, []) prog - -- The main CPS conversion - - ; prog <- return $ map (runTx $ runCmmOpts cmmCfgOptsZ) (srtToData topSRT : prog) - -- Control flow optimisation, again - - ; let prog' = map cmmOfZgraph prog - ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" (ppr prog') - ; return prog' } + ; let initTopSRT = initUs_ us emptySRT + ; (topSRT, prog) <- foldM (cmmPipeline hsc_env) (initTopSRT, []) prog + + ; let prog' = map cmmOfZgraph (srtToData topSRT : prog) + ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Output Cmm" (pprPlatform platform prog') + ; return prog' } optionallyConvertAndOrCPS :: HscEnv -> [Cmm] -> IO [Cmm] @@ -825,33 +1218,29 @@ cmms <- if dopt Opt_ConvertToZipCfgAndBack dflags then mapM (testCmmConversion hsc_env) cmms else return cmms - --------- Optionally convert to CPS (MDA) ----------- - cmms <- if not (dopt Opt_ConvertToZipCfgAndBack dflags) && - dopt Opt_RunCPS dflags - then cmmCPS dflags cmms - else return cmms return cmms testCmmConversion :: HscEnv -> Cmm -> IO Cmm testCmmConversion hsc_env cmm = do let dflags = hsc_dflags hsc_env + platform = targetPlatform dflags showPass dflags "CmmToCmm" - dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- pre-conversion" (ppr cmm) + dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- pre-conversion" (pprPlatform platform cmm) --continuationC <- cmmCPS dflags abstractC >>= cmmToRawCmm us <- mkSplitUniqSupply 'C' - let cfopts = runTx $ runCmmOpts cmmCfgOptsZ - let cvtm = do g <- cmmToZgraph cmm - return $ cfopts g - let zgraph = initUs_ us cvtm - us <- mkSplitUniqSupply 'S' - let topSRT = initUs_ us emptySRT - (_, [cps_zgraph]) <- protoCmmCPSZ hsc_env (topSRT, []) zgraph - let chosen_graph = if dopt Opt_RunCPSZ dflags then cps_zgraph else zgraph - dumpIfSet_dyn dflags Opt_D_dump_cmmz "C-- Zipper Graph" (ppr chosen_graph) + let zgraph = initUs_ us (cmmToZgraph platform cmm) + chosen_graph <- + if dopt Opt_RunCPSZ dflags + then do us <- mkSplitUniqSupply 'S' + let topSRT = initUs_ us emptySRT + (_, [zgraph]) <- cmmPipeline hsc_env (topSRT, []) zgraph + return zgraph + else return (runCmmContFlowOpts zgraph) + dumpIfSet_dyn dflags Opt_D_dump_cmmz "C-- Zipper Graph" (pprPlatform platform chosen_graph) showPass dflags "Convert from Z back to Cmm" - let cvt = cmmOfZgraph $ cfopts $ chosen_graph - dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- post-conversion" (ppr cvt) + let cvt = cmmOfZgraph chosen_graph + dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- post-conversion" (pprPlatform platform cvt) return cvt myCoreToStg :: DynFlags -> Module -> [CoreBind] @@ -905,116 +1294,176 @@ \begin{code} #ifdef GHCI hscStmt -- Compile a stmt all the way to an HValue, but don't run it - :: GhcMonad m => - HscEnv + :: HscEnv -> String -- The statement - -> m (Maybe ([Id], HValue)) + -> IO (Maybe ([Id], HValue)) -- ^ 'Nothing' <==> empty statement (or comment only), but no parse error -hscStmt hsc_env stmt = do - maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) stmt +hscStmt hsc_env stmt = hscStmtWithLocation hsc_env stmt "" 1 + +hscStmtWithLocation -- Compile a stmt all the way to an HValue, but don't run it + :: HscEnv + -> String -- The statement + -> String -- the source + -> Int -- ^ starting line + -> IO (Maybe ([Id], HValue)) + -- ^ 'Nothing' <==> empty statement (or comment only), but no parse error +hscStmtWithLocation hsc_env stmt source linenumber = runHsc hsc_env $ do + maybe_stmt <- hscParseStmtWithLocation source linenumber stmt case maybe_stmt of Nothing -> return Nothing Just parsed_stmt -> do -- The real stuff -- Rename and typecheck it let icontext = hsc_IC hsc_env - (ids, tc_expr) <- ioMsgMaybe $ tcRnStmt hsc_env icontext parsed_stmt + (ids, tc_expr) <- ioMsgMaybe $ + tcRnStmt hsc_env icontext parsed_stmt -- Desugar it let rdr_env = ic_rn_gbl_env icontext type_env = mkTypeEnv (map AnId (ic_tmp_ids icontext)) ds_expr <- ioMsgMaybe $ deSugarExpr hsc_env iNTERACTIVE rdr_env type_env tc_expr + handleWarnings -- Then desugar, code gen, and link it let src_span = srcLocSpan interactiveSrcLoc - hval <- liftIO $ compileExpr hsc_env src_span ds_expr + hsc_env <- getHscEnv + hval <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr return $ Just (ids, hval) -hscImport :: GhcMonad m => HscEnv -> String -> m (ImportDecl RdrName) -hscImport hsc_env str = do - (L _ (HsModule{hsmodImports=is})) <- hscParseThing parseModule (hsc_dflags hsc_env) str +hscImport :: HscEnv -> String -> IO (ImportDecl RdrName) +hscImport hsc_env str = runHsc hsc_env $ do + (L _ (HsModule{hsmodImports=is})) <- + hscParseThing parseModule str case is of [i] -> return (unLoc i) - _ -> throwOneError (mkPlainErrMsg noSrcSpan (ptext (sLit "parse error in import declaration"))) + _ -> liftIO $ throwOneError $ + mkPlainErrMsg noSrcSpan $ + ptext (sLit "parse error in import declaration") hscTcExpr -- Typecheck an expression (but don't run it) - :: GhcMonad m => - HscEnv + :: HscEnv -> String -- The expression - -> m Type + -> IO Type -hscTcExpr hsc_env expr = do - maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) expr - let icontext = hsc_IC hsc_env +hscTcExpr hsc_env expr = runHsc hsc_env $ do + maybe_stmt <- hscParseStmt expr case maybe_stmt of - Just (L _ (ExprStmt expr _ _)) -> do - ty <- ioMsgMaybe $ tcRnExpr hsc_env icontext expr - return ty - _ -> do throw $ 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 - :: GhcMonad m => - HscEnv + :: HscEnv -> String -- ^ The type - -> m Kind + -> IO Kind -hscKcType hsc_env str = do - ty <- hscParseType (hsc_dflags hsc_env) str - let icontext = hsc_IC hsc_env - ioMsgMaybe $ tcRnType hsc_env icontext ty +hscKcType hsc_env str = runHsc hsc_env $ do + ty <- hscParseType str + ioMsgMaybe $ tcRnType hsc_env (hsc_IC hsc_env) ty #endif \end{code} \begin{code} #ifdef GHCI -hscParseStmt :: GhcMonad m => DynFlags -> String -> m (Maybe (LStmt RdrName)) +hscParseStmt :: String -> Hsc (Maybe (LStmt RdrName)) hscParseStmt = hscParseThing parseStmt -hscParseType :: GhcMonad m => DynFlags -> String -> m (LHsType RdrName) +hscParseStmtWithLocation :: String -> Int + -> String -> Hsc (Maybe (LStmt RdrName)) +hscParseStmtWithLocation source linenumber stmt = + hscParseThingWithLocation source linenumber parseStmt stmt + +hscParseType :: String -> Hsc (LHsType RdrName) hscParseType = hscParseThing parseType #endif -hscParseIdentifier :: GhcMonad m => DynFlags -> String -> m (Located RdrName) -hscParseIdentifier = hscParseThing parseIdentifier +hscParseIdentifier :: HscEnv -> String -> IO (Located RdrName) +hscParseIdentifier hsc_env str = runHsc hsc_env $ + hscParseThing parseIdentifier str -hscParseThing :: (Outputable thing, GhcMonad m) +hscParseThing :: (Outputable thing) => Lexer.P thing - -> DynFlags -> String - -> m thing - -- Nothing => Parse error (message already printed) - -- Just x => success -hscParseThing parser dflags str - = (liftIO $ showPass dflags "Parser") >> - {-# SCC "Parser" #-} do - - buf <- liftIO $ stringToStringBuffer str + -> String + -> Hsc thing +hscParseThing = hscParseThingWithLocation "" 1 + +hscParseThingWithLocation :: (Outputable thing) + => String -> Int + -> Lexer.P thing + -> String + -> Hsc thing +hscParseThingWithLocation source linenumber parser str + = {-# SCC "Parser" #-} do + dflags <- getDynFlags + liftIO $ showPass dflags "Parser" - let loc = mkSrcLoc (fsLit "") 1 1 + let buf = stringToStringBuffer str + loc = mkRealSrcLoc (fsLit source) linenumber 1 case unP parser (mkPState dflags buf loc) of - PFailed span err -> do + PFailed span err -> do let msg = mkPlainErrMsg span err - throw (mkSrcErr (unitBag msg)) - - POk pst thing -> do + liftIO $ throwIO (mkSrcErr (unitBag msg)) - let ms@(warns, errs) = getMessages pst - logWarnings warns - when (errorsFound dflags ms) $ -- handle -Werror - throw (mkSrcErr errs) - - --ToDo: can't free the string buffer until we've finished this - -- compilation sweep and all the identifiers have gone away. + POk pst thing -> do + logWarningsReportErrors (getMessages pst) liftIO $ dumpIfSet_dyn dflags Opt_D_dump_parsed "Parser" (ppr thing) return thing \end{code} +\begin{code} +hscCompileCore :: HscEnv + -> Bool + -> ModSummary + -> [CoreBind] + -> IO () + +hscCompileCore hsc_env simplify mod_summary binds + = runHsc hsc_env $ do + let maybe_simplify mod_guts | simplify = hscSimplify' mod_guts + | otherwise = return mod_guts + guts <- maybe_simplify (mkModGuts (ms_mod mod_summary) binds) + (iface, changed, _details, cgguts) <- hscNormalIface guts Nothing + hscWriteIface iface changed mod_summary + _ <- hscGenHardCode cgguts mod_summary + return () + +-- Makes a "vanilla" ModGuts. +mkModGuts :: Module -> [CoreBind] -> ModGuts +mkModGuts mod binds = ModGuts { + mg_module = mod, + mg_boot = False, + mg_exports = [], + mg_deps = noDependencies, + mg_dir_imps = emptyModuleEnv, + mg_used_names = emptyNameSet, + mg_used_th = False, + mg_rdr_env = emptyGlobalRdrEnv, + mg_fix_env = emptyFixityEnv, + mg_types = emptyTypeEnv, + mg_insts = [], + mg_fam_insts = [], + mg_rules = [], + mg_vect_decls = [], + mg_binds = binds, + mg_foreign = NoStubs, + mg_warns = NoWarnings, + mg_anns = [], + mg_hpc_info = emptyHpcInfo False, + mg_modBreaks = emptyModBreaks, + mg_vect_info = noVectInfo, + mg_inst_env = emptyInstEnv, + mg_fam_inst_env = emptyFamInstEnv, + mg_trust_pkg = False +} +\end{code} + %************************************************************************ %* * Desugar, simplify, convert to bytecode, and link an expression @@ -1023,46 +1472,42 @@ \begin{code} #ifdef GHCI -compileExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO HValue - -compileExpr hsc_env srcspan ds_expr +hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO HValue +hscCompileCoreExpr hsc_env srcspan ds_expr | rtsIsProfiled - = throwIO (InstallationError "You can't call compileExpr in a profiled compiler") + = throwIO (InstallationError "You can't call hscCompileCoreExpr in a profiled compiler") -- Otherwise you get a seg-fault when you run it - | otherwise - = do { let { dflags = hsc_dflags hsc_env ; - lint_on = dopt Opt_DoCoreLinting dflags } - - -- Simplify it - ; simpl_expr <- simplifyExpr dflags ds_expr - - -- Tidy it (temporary, until coreSat does cloning) - ; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr - - -- Prepare for codegen - ; prepd_expr <- corePrepExpr dflags tidy_expr - - -- Lint if necessary - -- ToDo: improve SrcLoc - ; if lint_on then - let ictxt = hsc_IC hsc_env - tyvars = varSetElems (tyVarsOfTypes (map idType (ic_tmp_ids ictxt))) - in - case lintUnfolding noSrcLoc tyvars prepd_expr of - Just err -> pprPanic "compileExpr" err - Nothing -> return () - else - return () + | otherwise = do + let dflags = hsc_dflags hsc_env + let lint_on = dopt Opt_DoCoreLinting dflags + + -- Simplify it + simpl_expr <- simplifyExpr dflags ds_expr + + -- Tidy it (temporary, until coreSat does cloning) + let tidy_expr = tidyExpr emptyTidyEnv simpl_expr + + -- Prepare for codegen + prepd_expr <- corePrepExpr dflags tidy_expr + + -- Lint if necessary + -- ToDo: improve SrcLoc + when lint_on $ + let ictxt = hsc_IC hsc_env + tyvars = varSetElems (tyVarsOfTypes (map idType (ic_tmp_ids ictxt))) + in + case lintUnfolding noSrcLoc tyvars prepd_expr of + Just err -> pprPanic "hscCompileCoreExpr" err + Nothing -> return () - -- Convert to BCOs - ; bcos <- coreExprToBCOs dflags prepd_expr + -- Convert to BCOs + bcos <- coreExprToBCOs dflags prepd_expr - -- link it - ; hval <- linkExpr hsc_env srcspan bcos + -- link it + hval <- linkExpr hsc_env srcspan bcos - ; return hval - } + return hval #endif \end{code} diff -Nru ghc-7.0.3/compiler/main/HscStats.lhs ghc-7.2.1/compiler/main/HscStats.lhs --- ghc-7.0.3/compiler/main/HscStats.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/main/HscStats.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -32,12 +32,13 @@ [("ExportAll ", export_all), -- 1 if no export list ("ExportDecls ", export_ds), ("ExportModules ", export_ms), - ("Imports ", import_no), - (" ImpQual ", import_qual), - (" ImpAs ", import_as), - (" ImpAll ", import_all), - (" ImpPartial ", import_partial), - (" ImpHiding ", import_hiding), + ("Imports ", imp_no), + (" ImpSafe ", imp_safe), + (" ImpQual ", imp_qual), + (" ImpAs ", imp_as), + (" ImpAll ", imp_all), + (" ImpPartial ", imp_partial), + (" ImpHiding ", imp_hiding), ("FixityDecls ", fixity_sigs), ("DefaultDecls ", default_ds), ("TypeDecls ", type_ds), @@ -55,6 +56,7 @@ ("InstType ", inst_type_ds), ("InstData ", inst_data_ds), ("TypeSigs ", bind_tys), + ("GenericSigs ", generic_sigs), ("ValBinds ", val_bind_ds), ("FunBinds ", fn_bind_ds), ("InlineMeths ", method_inlines), @@ -74,7 +76,7 @@ trim ls = takeWhile (not.isSpace) (dropWhile isSpace ls) - (fixity_sigs, bind_tys, bind_specs, bind_inlines) + (fixity_sigs, bind_tys, bind_specs, bind_inlines, generic_sigs) = count_sigs [d | SigD d <- decls] -- NB: this omits fixity decls on local bindings and -- in class decls. ToDo @@ -98,8 +100,8 @@ (val_bind_ds, fn_bind_ds) = foldr add2 (0,0) (map count_bind val_decls) - (import_no, import_qual, import_as, import_all, import_partial, import_hiding) - = foldr add6 (0,0,0,0,0,0) (map import_info imports) + (imp_no, imp_safe, imp_qual, imp_as, imp_all, imp_partial, imp_hiding) + = foldr add7 (0,0,0,0,0,0,0) (map import_info imports) (data_constrs, data_derivs) = foldr add2 (0,0) (map data_info tycl_decls) (class_method_ds, default_method_ds) @@ -112,23 +114,25 @@ count_bind (FunBind {}) = (0,1) count_bind b = pprPanic "count_bind: Unhandled binder" (ppr b) - count_sigs sigs = foldr add4 (0,0,0,0) (map sig_info sigs) + count_sigs sigs = foldr add5 (0,0,0,0,0) (map sig_info sigs) - sig_info (FixSig _) = (1,0,0,0) - sig_info (TypeSig _ _) = (0,1,0,0) - sig_info (SpecSig _ _ _) = (0,0,1,0) - sig_info (InlineSig _ _) = (0,0,0,1) - sig_info _ = (0,0,0,0) - - import_info (L _ (ImportDecl _ _ _ qual as spec)) - = add6 (1, qual_info qual, as_info as, 0,0,0) (spec_info spec) + sig_info (FixSig _) = (1,0,0,0,0) + sig_info (TypeSig _ _) = (0,1,0,0,0) + sig_info (SpecSig _ _ _) = (0,0,1,0,0) + sig_info (InlineSig _ _) = (0,0,0,1,0) + sig_info (GenericSig _ _) = (0,0,0,0,1) + sig_info _ = (0,0,0,0,0) + + import_info (L _ (ImportDecl _ _ _ safe qual as spec)) + = add7 (1, safe_info safe, qual_info qual, as_info as, 0,0,0) (spec_info spec) + safe_info = qual_info qual_info False = 0 qual_info True = 1 as_info Nothing = 0 as_info (Just _) = 1 - spec_info Nothing = (0,0,0,1,0,0) - spec_info (Just (False, _)) = (0,0,0,0,1,0) - spec_info (Just (True, _)) = (0,0,0,0,0,1) + spec_info Nothing = (0,0,0,0,1,0,0) + spec_info (Just (False, _)) = (0,0,0,0,0,1,0) + spec_info (Just (True, _)) = (0,0,0,0,0,0,1) data_info (TyData {tcdCons = cs, tcdDerivs = derivs}) = (length cs, case derivs of Nothing -> 0 @@ -137,13 +141,13 @@ class_info decl@(ClassDecl {}) = case count_sigs (map unLoc (tcdSigs decl)) of - (_,classops,_,_) -> + (_,classops,_,_,_) -> (classops, addpr (foldr add2 (0,0) (map (count_bind.unLoc) (bagToList (tcdMeths decl))))) class_info _ = (0,0) inst_info (InstDecl _ inst_meths inst_sigs ats) = case count_sigs (map unLoc inst_sigs) of - (_,_,ss,is) -> + (_,_,ss,is,_) -> case foldr add2 (0, 0) (map (countATDecl . unLoc) ats) of (tyDecl, dtDecl) -> (addpr (foldr add2 (0,0) @@ -157,15 +161,13 @@ addpr :: (Int,Int) -> Int add2 :: (Int,Int) -> (Int,Int) -> (Int, Int) - add4 :: (Int,Int,Int,Int) -> (Int,Int,Int,Int) -> (Int, Int, Int, Int) add5 :: (Int,Int,Int,Int,Int) -> (Int,Int,Int,Int,Int) -> (Int, Int, Int, Int, Int) - add6 :: (Int,Int,Int,Int,Int,Int) -> (Int,Int,Int,Int,Int,Int) -> (Int, Int, Int, Int, Int, Int) + add7 :: (Int,Int,Int,Int,Int,Int,Int) -> (Int,Int,Int,Int,Int,Int,Int) -> (Int, Int, Int, Int, Int, Int, Int) addpr (x,y) = x+y add2 (x1,x2) (y1,y2) = (x1+y1,x2+y2) - add4 (x1,x2,x3,x4) (y1,y2,y3,y4) = (x1+y1,x2+y2,x3+y3,x4+y4) add5 (x1,x2,x3,x4,x5) (y1,y2,y3,y4,y5) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5) - add6 (x1,x2,x3,x4,x5,x6) (y1,y2,y3,y4,y5,y6) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5,x6+y6) + add7 (x1,x2,x3,x4,x5,x6,x7) (y1,y2,y3,y4,y5,y6,y7) = (x1+y1,x2+y2,x3+y3,x4+y4,x5+y5,x6+y6,x7+y7) \end{code} diff -Nru ghc-7.0.3/compiler/main/HscTypes.lhs ghc-7.2.1/compiler/main/HscTypes.lhs --- ghc-7.0.3/compiler/main/HscTypes.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/main/HscTypes.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -6,41 +6,29 @@ \begin{code} -- | Types for the per-module compiler module HscTypes ( - -- * 'Ghc' monad stuff - Ghc(..), GhcT(..), liftGhcT, - GhcMonad(..), WarnLogMonad(..), - liftIO, - ioMsgMaybe, ioMsg, - logWarnings, clearWarnings, hasWarnings, - SourceError, GhcApiError, mkSrcErr, srcErrorMessages, mkApiErr, - throwOneError, handleSourceError, - reflectGhc, reifyGhc, - handleFlagWarnings, - - -- * Sessions and compilation state - Session(..), withSession, modifySession, withTempSession, + -- * compilation state HscEnv(..), hscEPS, FinderCache, FindResult(..), ModLocationCache, Target(..), TargetId(..), pprTarget, pprTargetId, ModuleGraph, emptyMG, - -- ** Callbacks - GhcApiCallbacks(..), withLocalCallbacks, -- * Information about modules ModDetails(..), emptyModDetails, - ModGuts(..), CoreModule(..), CgGuts(..), ForeignStubs(..), - ImportedMods, + ModGuts(..), CgGuts(..), ForeignStubs(..), appendStubC, + ImportedMods, ImportedModsVal, - ModSummary(..), ms_mod_name, showModMsg, isBootSummary, + ModSummary(..), ms_imps, ms_mod_name, showModMsg, isBootSummary, msHsFilePath, msHiFilePath, msObjFilePath, + SourceModified(..), -- * Information about the module being compiled HscSource(..), isHsBoot, hscSourceString, -- Re-exported from DriverPhases -- * State relating to modules in this package HomePackageTable, HomeModInfo(..), emptyHomePackageTable, - hptInstances, hptRules, hptVectInfo, - + hptInstances, hptRules, hptVectInfo, + hptObjs, + -- * State relating to known packages ExternalPackageState(..), EpsStats(..), addEpsInStats, PackageTypeEnv, PackageIfaceTable, emptyPackageIfaceTable, @@ -67,13 +55,13 @@ -- * TyThings and type environments TyThing(..), - tyThingClass, tyThingTyCon, tyThingDataCon, tyThingId, - implicitTyThings, isImplicitTyThing, + tyThingClass, tyThingTyCon, tyThingDataCon, tyThingId, tyThingCoAxiom, + implicitTyThings, implicitTyConThings, implicitClassThings, isImplicitTyThing, TypeEnv, lookupType, lookupTypeHscEnv, mkTypeEnv, emptyTypeEnv, extendTypeEnv, extendTypeEnvList, extendTypeEnvWithIds, lookupTypeEnv, typeEnvElts, typeEnvClasses, typeEnvTyCons, typeEnvIds, - typeEnvDataCons, + typeEnvDataCons, typeEnvCoAxioms, -- * MonadThings MonadThings(..), @@ -83,14 +71,14 @@ Dependencies(..), noDependencies, NameCache(..), OrigNameCache, OrigIParamCache, Avails, availsToNameSet, availsToNameEnv, availName, availNames, - GenAvailInfo(..), AvailInfo, RdrAvailInfo, - IfaceExport, + AvailInfo(..), + IfaceExport, stableAvailCmp, -- * Warnings Warnings(..), WarningTxt(..), plusWarns, -- * Linker stuff - Linkable(..), isObjectLinkable, + Linkable(..), isObjectLinkable, linkableObjs, Unlinked(..), CompiledByteCode, isObject, nameOfObject, isInterpretable, byteCodeOfObject, @@ -102,13 +90,22 @@ -- * Vectorisation information VectInfo(..), IfaceVectInfo(..), noVectInfo, plusVectInfo, - noIfaceVectInfo + noIfaceVectInfo, + + -- * Safe Haskell information + IfaceTrustInfo, getSafeMode, setSafeMode, noIfaceTrustInfo, + trustInfoToNum, numToTrustInfo, IsSafeImport, + + -- * Compilation errors and warnings + SourceError, GhcApiError, mkSrcErr, srcErrorMessages, mkApiErr, + throwOneError, handleSourceError, + handleFlagWarnings, printOrThrowWarnings, ) where #include "HsVersions.h" #ifdef GHCI -import ByteCodeAsm ( CompiledByteCode ) +import ByteCodeAsm ( CompiledByteCode ) import {-# SOURCE #-} InteractiveEval ( Resume ) #endif @@ -116,16 +113,17 @@ import RdrName import Name import NameEnv -import NameSet +import NameSet import Module -import InstEnv ( InstEnv, Instance ) -import FamInstEnv ( FamInstEnv, FamInst ) -import Rules ( RuleBase ) -import CoreSyn ( CoreBind ) +import InstEnv ( InstEnv, Instance ) +import FamInstEnv ( FamInstEnv, FamInst ) +import Rules ( RuleBase ) +import CoreSyn ( CoreBind ) import VarEnv +import VarSet import Var import Id -import Type +import Type import Annotations import Class ( Class, classAllSelIds, classATs, classTyCon ) @@ -133,27 +131,25 @@ import DataCon ( DataCon, dataConImplicitIds, dataConWrapId ) import PrelNames ( gHC_PRIM ) import Packages hiding ( Version(..) ) -import DynFlags ( DynFlags(..), isOneShot, HscTarget (..), dopt, - DynFlag(..) ) +import DynFlags import DriverPhases ( HscSource(..), isHsBoot, hscSourceString, Phase ) import BasicTypes ( IPName, defaultFixity, WarningTxt(..) ) import OptimizationFuel ( OptFuelState ) import IfaceSyn -import CoreSyn ( CoreRule ) +import CoreSyn ( CoreRule, CoreVect ) import Maybes ( orElse, expectJust, catMaybes ) import Outputable import BreakArray -import SrcLoc ( SrcSpan, Located(..) ) +import SrcLoc import UniqFM ( lookupUFM, eltsUFM, emptyUFM ) import UniqSupply ( UniqSupply ) import FastString import StringBuffer ( StringBuffer ) import Fingerprint import MonadUtils -import Data.Dynamic ( Typeable ) -import qualified Data.Dynamic as Dyn import Bag import ErrUtils +import Util import System.FilePath import System.Time ( ClockTime ) @@ -161,24 +157,16 @@ import Data.Array ( Array, array ) import Data.List import Data.Map (Map) +import Data.Word import Control.Monad ( mplus, guard, liftM, when ) import Exception -\end{code} - - -%************************************************************************ -%* * -\subsection{Compilation environment} -%* * -%************************************************************************ +import Data.Typeable ( Typeable ) +-- ----------------------------------------------------------------------------- +-- Source Errors -\begin{code} --- | The Session is a handle to the complete state of a compilation --- session. A compilation session consists of a set of modules --- constituting the current program or library, the context for --- interactive evaluation, and various caches. -data Session = Session !(IORef HscEnv) !(IORef WarningMessages) +-- When the compiler (HscMain) discovers errors, it throws an +-- exception in the IO monad. mkSrcErr :: ErrorMessages -> SourceError srcErrorMessages :: SourceError -> ErrorMessages @@ -203,18 +191,13 @@ -- -- See 'printExceptionAndWarnings' for more information on what to take care -- of when writing a custom error handler. -data SourceError = SourceError ErrorMessages +newtype SourceError = SourceError ErrorMessages + deriving Typeable instance Show SourceError where show (SourceError msgs) = unlines . map show . bagToList $ msgs -- ToDo: is there some nicer way to print this? -sourceErrorTc :: Dyn.TyCon -sourceErrorTc = Dyn.mkTyCon "SourceError" -{-# NOINLINE sourceErrorTc #-} -instance Typeable SourceError where - typeOf _ = Dyn.mkTyConApp sourceErrorTc [] - instance Exception SourceError mkSrcErr = SourceError @@ -231,270 +214,35 @@ srcErrorMessages (SourceError msgs) = msgs -- | XXX: what exactly is an API error? -data GhcApiError = GhcApiError SDoc +newtype GhcApiError = GhcApiError SDoc + deriving Typeable instance Show GhcApiError where show (GhcApiError msg) = showSDoc msg -ghcApiErrorTc :: Dyn.TyCon -ghcApiErrorTc = Dyn.mkTyCon "GhcApiError" -{-# NOINLINE ghcApiErrorTc #-} -instance Typeable GhcApiError where - typeOf _ = Dyn.mkTyConApp ghcApiErrorTc [] - instance Exception GhcApiError mkApiErr = GhcApiError --- | A monad that allows logging of warnings. -class Monad m => WarnLogMonad m where - setWarnings :: WarningMessages -> m () - getWarnings :: m WarningMessages - -logWarnings :: WarnLogMonad m => WarningMessages -> m () -logWarnings warns = do - warns0 <- getWarnings - setWarnings (unionBags warns warns0) - --- | Clear the log of 'Warnings'. -clearWarnings :: WarnLogMonad m => m () -clearWarnings = setWarnings emptyBag - --- | Returns true if there were any warnings. -hasWarnings :: WarnLogMonad m => m Bool -hasWarnings = getWarnings >>= return . not . isEmptyBag - --- | A monad that has all the features needed by GHC API calls. --- --- In short, a GHC monad --- --- - allows embedding of IO actions, --- --- - can log warnings, --- --- - allows handling of (extensible) exceptions, and --- --- - maintains a current session. --- --- If you do not use 'Ghc' or 'GhcT', make sure to call 'GHC.initGhcMonad' --- before any call to the GHC API functions can occur. --- -class (Functor m, MonadIO m, WarnLogMonad m, ExceptionMonad m) - => GhcMonad m where - getSession :: m HscEnv - setSession :: HscEnv -> m () - --- | Call the argument with the current session. -withSession :: GhcMonad m => (HscEnv -> m a) -> m a -withSession f = getSession >>= f - --- | Set the current session to the result of applying the current session to --- the argument. -modifySession :: GhcMonad m => (HscEnv -> HscEnv) -> m () -modifySession f = do h <- getSession - setSession $! f h - -withSavedSession :: GhcMonad m => m a -> m a -withSavedSession m = do - saved_session <- getSession - m `gfinally` setSession saved_session - --- | Call an action with a temporarily modified Session. -withTempSession :: GhcMonad m => (HscEnv -> HscEnv) -> m a -> m a -withTempSession f m = - withSavedSession $ modifySession f >> m - --- | A minimal implementation of a 'GhcMonad'. If you need a custom monad, --- e.g., to maintain additional state consider wrapping this monad or using --- 'GhcT'. -newtype Ghc a = Ghc { unGhc :: Session -> IO a } - -instance Functor Ghc where - fmap f m = Ghc $ \s -> f `fmap` unGhc m s - -instance Monad Ghc where - return a = Ghc $ \_ -> return a - m >>= g = Ghc $ \s -> do a <- unGhc m s; unGhc (g a) s - -instance MonadIO Ghc where - liftIO ioA = Ghc $ \_ -> ioA - -instance ExceptionMonad Ghc where - gcatch act handle = - Ghc $ \s -> unGhc act s `gcatch` \e -> unGhc (handle e) s - gblock (Ghc m) = Ghc $ \s -> gblock (m s) - gunblock (Ghc m) = Ghc $ \s -> gunblock (m s) - gmask f = - Ghc $ \s -> gmask $ \io_restore -> - let - g_restore (Ghc m) = Ghc $ \s -> io_restore (m s) - in - unGhc (f g_restore) s - -instance WarnLogMonad Ghc where - setWarnings warns = Ghc $ \(Session _ wref) -> writeIORef wref warns - -- | Return 'Warnings' accumulated so far. - getWarnings = Ghc $ \(Session _ wref) -> readIORef wref - -instance GhcMonad Ghc where - getSession = Ghc $ \(Session r _) -> readIORef r - setSession s' = Ghc $ \(Session r _) -> writeIORef r s' - --- | A monad transformer to add GHC specific features to another monad. --- --- Note that the wrapped monad must support IO and handling of exceptions. -newtype GhcT m a = GhcT { unGhcT :: Session -> m a } -liftGhcT :: Monad m => m a -> GhcT m a -liftGhcT m = GhcT $ \_ -> m - -instance Functor m => Functor (GhcT m) where - fmap f m = GhcT $ \s -> f `fmap` unGhcT m s - -instance Monad m => Monad (GhcT m) where - return x = GhcT $ \_ -> return x - m >>= k = GhcT $ \s -> do a <- unGhcT m s; unGhcT (k a) s - -instance MonadIO m => MonadIO (GhcT m) where - liftIO ioA = GhcT $ \_ -> liftIO ioA - -instance ExceptionMonad m => ExceptionMonad (GhcT m) where - gcatch act handle = - GhcT $ \s -> unGhcT act s `gcatch` \e -> unGhcT (handle e) s - gblock (GhcT m) = GhcT $ \s -> gblock (m s) - gunblock (GhcT m) = GhcT $ \s -> gunblock (m s) - gmask f = - GhcT $ \s -> gmask $ \io_restore -> - let - g_restore (GhcT m) = GhcT $ \s -> io_restore (m s) - in - unGhcT (f g_restore) s - -instance MonadIO m => WarnLogMonad (GhcT m) where - setWarnings warns = GhcT $ \(Session _ wref) -> liftIO $ writeIORef wref warns - -- | Return 'Warnings' accumulated so far. - getWarnings = GhcT $ \(Session _ wref) -> liftIO $ readIORef wref - -instance (Functor m, ExceptionMonad m, MonadIO m) => GhcMonad (GhcT m) where - getSession = GhcT $ \(Session r _) -> liftIO $ readIORef r - setSession s' = GhcT $ \(Session r _) -> liftIO $ writeIORef r s' - --- | Lift an IO action returning errors messages into a 'GhcMonad'. --- --- In order to reduce dependencies to other parts of the compiler, functions --- outside the "main" parts of GHC return warnings and errors as a parameter --- and signal success via by wrapping the result in a 'Maybe' type. This --- function logs the returned warnings and propagates errors as exceptions --- (of type 'SourceError'). --- --- This function assumes the following invariants: --- --- 1. If the second result indicates success (is of the form 'Just x'), --- there must be no error messages in the first result. --- --- 2. If there are no error messages, but the second result indicates failure --- there should be warnings in the first result. That is, if the action --- failed, it must have been due to the warnings (i.e., @-Werror@). -ioMsgMaybe :: GhcMonad m => - IO (Messages, Maybe a) -> m a -ioMsgMaybe ioA = do - ((warns,errs), mb_r) <- liftIO ioA - logWarnings warns - case mb_r of - Nothing -> liftIO $ throwIO (mkSrcErr errs) - Just r -> ASSERT( isEmptyBag errs ) return r - --- | Lift a non-failing IO action into a 'GhcMonad'. --- --- Like 'ioMsgMaybe', but assumes that the action will never return any error --- messages. -ioMsg :: GhcMonad m => IO (Messages, a) -> m a -ioMsg ioA = do - ((warns,errs), r) <- liftIO ioA - logWarnings warns - ASSERT( isEmptyBag errs ) return r - --- | Reflect a computation in the 'Ghc' monad into the 'IO' monad. --- --- You can use this to call functions returning an action in the 'Ghc' monad --- inside an 'IO' action. This is needed for some (too restrictive) callback --- arguments of some library functions: --- --- > libFunc :: String -> (Int -> IO a) -> IO a --- > ghcFunc :: Int -> Ghc a --- > --- > ghcFuncUsingLibFunc :: String -> Ghc a -> Ghc a --- > ghcFuncUsingLibFunc str = --- > reifyGhc $ \s -> --- > libFunc $ \i -> do --- > reflectGhc (ghcFunc i) s --- -reflectGhc :: Ghc a -> Session -> IO a -reflectGhc m = unGhc m - --- > Dual to 'reflectGhc'. See its documentation. -reifyGhc :: (Session -> IO a) -> Ghc a -reifyGhc act = Ghc $ act +-- | Given a bag of warnings, turn them into an exception if +-- -Werror is enabled, or print them out otherwise. +printOrThrowWarnings :: DynFlags -> Bag WarnMsg -> IO () +printOrThrowWarnings dflags warns + | dopt Opt_WarnIsError dflags + = when (not (isEmptyBag warns)) $ do + throwIO $ mkSrcErr $ warns `snocBag` warnIsErrorMsg + | otherwise + = printBagOfWarnings dflags warns -handleFlagWarnings :: GhcMonad m => DynFlags -> [Located String] -> m () +handleFlagWarnings :: DynFlags -> [Located String] -> IO () handleFlagWarnings dflags warns - = when (dopt Opt_WarnDeprecatedFlags dflags) - (handleFlagWarnings' dflags warns) - -handleFlagWarnings' :: GhcMonad m => DynFlags -> [Located String] -> m () -handleFlagWarnings' _ [] = return () -handleFlagWarnings' dflags warns - = do -- It would be nicer if warns :: [Located Message], but that has circular - -- import problems. - logWarnings $ listToBag (map mkFlagWarning warns) - when (dopt Opt_WarnIsError dflags) $ - liftIO $ throwIO $ mkSrcErr emptyBag - -mkFlagWarning :: Located String -> WarnMsg -mkFlagWarning (L loc warn) - = mkPlainWarnMsg loc (text warn) -\end{code} - -\begin{code} --- | These functions are called in various places of the GHC API. --- --- API clients can override any of these callbacks to change GHC's default --- behaviour. -data GhcApiCallbacks - = GhcApiCallbacks { - - -- | Called by 'load' after the compilating of each module. - -- - -- The default implementation simply prints all warnings and errors to - -- @stderr@. Don't forget to call 'clearWarnings' when implementing your - -- own call. - -- - -- The first argument is the module that was compiled. - -- - -- The second argument is @Nothing@ if no errors occured, but there may - -- have been warnings. If it is @Just err@ at least one error has - -- occured. If 'srcErrorMessages' is empty, compilation failed due to - -- @-Werror@. - reportModuleCompilationResult :: GhcMonad m => - ModSummary -> Maybe SourceError - -> m () - } - --- | Temporarily modify the callbacks. After the action is executed all --- callbacks are reset (not, however, any other modifications to the session --- state.) -withLocalCallbacks :: GhcMonad m => - (GhcApiCallbacks -> GhcApiCallbacks) - -> m a -> m a -withLocalCallbacks f m = do - hsc_env <- getSession - let cb0 = hsc_callbacks hsc_env - let cb' = f cb0 - setSession (hsc_env { hsc_callbacks = cb' `seq` cb' }) - r <- m - hsc_env' <- getSession - setSession (hsc_env' { hsc_callbacks = cb0 }) - return r + = when (wopt Opt_WarnDeprecatedFlags dflags) $ do + -- It would be nicer if warns :: [Located Message], but that + -- has circular import problems. + let bag = listToBag [ mkPlainWarnMsg loc (text warn) + | L loc warn <- warns ] + printOrThrowWarnings dflags bag \end{code} \begin{code} @@ -513,9 +261,6 @@ hsc_dflags :: DynFlags, -- ^ The dynamic flag settings - hsc_callbacks :: GhcApiCallbacks, - -- ^ Callbacks for the GHC API. - hsc_targets :: [Target], -- ^ The targets (or roots) of the current session @@ -746,6 +491,9 @@ -- And get its dfuns , thing <- things ] + +hptObjs :: HomePackageTable -> [FilePath] +hptObjs hpt = concat (map (maybe [] linkableObjs . hm_linkable) (eltsUFM hpt)) \end{code} %************************************************************************ @@ -799,14 +547,22 @@ -- ^ The requested package was not found | FoundMultiple [PackageId] -- ^ _Error_: both in multiple packages - | NotFound [FilePath] (Maybe PackageId) [PackageId] [PackageId] - -- ^ The module was not found, including either - -- * the specified places were searched - -- * the package that this module should have been in - -- * list of packages in which the module was hidden, - -- * list of hidden packages containing this module - | NotFoundInPackage PackageId - -- ^ The module was not found in this package + + | NotFound -- Not found + { fr_paths :: [FilePath] -- Places where I looked + + , fr_pkg :: Maybe PackageId -- Just p => module is in this package's + -- manifest, but couldn't find + -- the .hi file + + , fr_mods_hidden :: [PackageId] -- Module is in these packages, + -- but the *module* is hidden + + , fr_pkgs_hidden :: [PackageId] -- Module is in these packages, + -- but the *package* is hidden + + , fr_suggestions :: [Module] -- Possible mis-spelled modules + } -- | Cache that remembers where we found a particular module. Contains both -- home modules and package modules. On @:load@, only home modules are @@ -861,6 +617,8 @@ mi_exp_hash :: !Fingerprint, -- ^ Hash of export list + mi_used_th :: !Bool, -- ^ Module required TH splices when it was compiled. This disables recompilation avoidance (see #481). + mi_fixities :: [(OccName,Fixity)], -- ^ Fixities @@ -919,8 +677,17 @@ -- isn't in decls. It's useful to know that when -- seeing if we are up to date wrt. the old interface. -- The 'OccName' is the parent of the name, if it has one. - mi_hpc :: !AnyHpcUsage + mi_hpc :: !AnyHpcUsage, -- ^ True if this program uses Hpc at any point in the program. + mi_trust :: !IfaceTrustInfo, + -- ^ Safe Haskell Trust information for this module. + mi_trust_pkg :: !Bool + -- ^ Do we require the package this module resides in be trusted + -- to trust this module? This is used for the situation where a + -- module is Safe (so doesn't require the package be trusted + -- itself) but imports some trustworthy modules from its own + -- package (which does require its own package be trusted). + -- See Note [RnNames . Trust Own Package] } -- | The 'ModDetails' is essentially a cache for information in the 'ModIface' @@ -950,14 +717,16 @@ } -- | Records the modules directly imported by a module for extracting e.g. usage information -type ImportedMods = ModuleEnv [(ModuleName, Bool, SrcSpan)] +type ImportedMods = ModuleEnv [ImportedModsVal] +type ImportedModsVal = (ModuleName, Bool, SrcSpan, IsSafeImport) + -- TODO: we are not actually using the codomain of this type at all, so it can be -- replaced with ModuleEnv () -- | 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 @@ -969,7 +738,8 @@ -- generate initialisation code mg_used_names:: !NameSet, -- ^ What the module needed (used in 'MkIface.mkIface') - mg_rdr_env :: !GlobalRdrEnv, -- ^ Top-level lexical environment + mg_used_th :: !Bool, -- ^ Did we run a TH splice? + mg_rdr_env :: !GlobalRdrEnv, -- ^ Top-level lexical environment -- These fields all describe the things **declared in this module** mg_fix_env :: !FixityEnv, -- ^ Fixities declared in this module @@ -982,9 +752,11 @@ mg_binds :: ![CoreBind], -- ^ Bindings for this module mg_foreign :: !ForeignStubs, -- ^ Foreign exports declared in this module mg_warns :: !Warnings, -- ^ Warnings declared in the module - mg_anns :: [Annotation], -- ^ Annotations declared in this module - mg_hpc_info :: !HpcInfo, -- ^ Coverage tick boxes in the module + mg_anns :: [Annotation], -- ^ Annotations declared in this module + mg_hpc_info :: !HpcInfo, -- ^ Coverage tick boxes in the module mg_modBreaks :: !ModBreaks, -- ^ Breakpoints for the module + mg_vect_decls:: ![CoreVect], -- ^ Vectorisation declarations in this module + -- (produced by desugarer & consumed by vectoriser) mg_vect_info :: !VectInfo, -- ^ Pool of vectorised declarations in the module -- The next two fields are unusual, because they give instance @@ -995,9 +767,12 @@ mg_inst_env :: InstEnv, -- ^ Class instance environment from /home-package/ modules (including -- this one); c.f. 'tcg_inst_env' - mg_fam_inst_env :: FamInstEnv + mg_fam_inst_env :: FamInstEnv, -- ^ Type-family instance enviroment for /home-package/ modules -- (including this one); c.f. 'tcg_fam_inst_env' + mg_trust_pkg :: Bool + -- ^ Do we need to trust our own package for Safe Haskell? + -- See Note [RnNames . Trust Own Package] } -- The ModGuts takes on several slightly different forms: @@ -1006,24 +781,6 @@ -- mg_rules Orphan rules only (local ones now attached to binds) -- mg_binds With rules attached --- | A CoreModule consists of just the fields of a 'ModGuts' that are needed for --- the 'GHC.compileToCoreModule' interface. -data CoreModule - = CoreModule { - -- | Module name - cm_module :: !Module, - -- | Type environment for types declared in this module - cm_types :: !TypeEnv, - -- | Declarations - cm_binds :: [CoreBind], - -- | Imports - cm_imports :: ![Module] - } - -instance Outputable CoreModule where - ppr (CoreModule {cm_module = mn, cm_types = te, cm_binds = cb}) = - text "%module" <+> ppr mn <+> ppr te $$ vcat (map ppr cb) - -- The ModGuts takes on several slightly different forms: -- -- After simplification, the following fields change slightly: @@ -1055,11 +812,7 @@ -- data constructor workers; reason: we we regard them -- as part of the code-gen of tycons - cg_dir_imps :: ![Module], - -- ^ Directly-imported modules; used to generate - -- initialisation code - - cg_foreign :: !ForeignStubs, -- ^ Foreign export stubs + cg_foreign :: !ForeignStubs, -- ^ Foreign export stubs cg_dep_pkgs :: ![PackageId], -- ^ Dependent packages, used to -- generate #includes for C code gen cg_hpc_info :: !HpcInfo, -- ^ Program coverage tick box information @@ -1079,6 +832,10 @@ -- -- 2) C stubs to use when calling -- "foreign exported" functions + +appendStubC :: ForeignStubs -> SDoc -> ForeignStubs +appendStubC NoStubs c_code = ForeignStubs empty c_code +appendStubC (ForeignStubs h c) c_code = ForeignStubs h (c $$ c_code) \end{code} \begin{code} @@ -1094,7 +851,8 @@ mi_usages = [], mi_exports = [], mi_exp_hash = fingerprint0, - mi_fixities = [], + mi_used_th = False, + mi_fixities = [], mi_warns = NoWarnings, mi_anns = [], mi_insts = [], @@ -1107,7 +865,9 @@ mi_warn_fn = emptyIfaceWarnCache, mi_fix_fn = emptyIfaceFixCache, mi_hash_fn = emptyIfaceHashCache, - mi_hpc = False + mi_hpc = False, + mi_trust = noIfaceTrustInfo, + mi_trust_pkg = False } \end{code} @@ -1119,37 +879,47 @@ %************************************************************************ \begin{code} --- | Interactive context, recording information relevant to GHCi +-- | Interactive context, recording information about the state of the +-- context in which statements are executed in a GHC session. +-- data InteractiveContext = InteractiveContext { - ic_toplev_scope :: [Module] -- ^ The context includes the "top-level" scope of - -- these modules - - , ic_exports :: [(Module, Maybe (ImportDecl RdrName))] -- ^ The context includes just the exported parts of these - -- modules - - , ic_rn_gbl_env :: GlobalRdrEnv -- ^ The contexts' cached 'GlobalRdrEnv', built from - -- 'ic_toplev_scope' and 'ic_exports' - - , ic_tmp_ids :: [Id] -- ^ Names bound during interaction with the user. - -- Later Ids shadow earlier ones with the same OccName - -- Expressions are typed with these Ids in the envt - -- For runtime-debugging, these Ids may have free - -- TcTyVars of RuntimUnkSkol flavour, but no free TyVars - -- (because the typechecker doesn't expect that) + -- These two fields are only stored here so that the client + -- can retrieve them with GHC.getContext. GHC itself doesn't + -- use them, but it does reset them to empty sometimes (such + -- as before a GHC.load). The context is set with GHC.setContext. + ic_toplev_scope :: [Module], + -- ^ The context includes the "top-level" scope of + -- these modules + ic_imports :: [ImportDecl RdrName], + -- ^ The context is extended with these import declarations + + ic_rn_gbl_env :: GlobalRdrEnv, + -- ^ The contexts' cached 'GlobalRdrEnv', built by + -- 'InteractiveEval.setContext' + + ic_tmp_ids :: [Id], + -- ^ Names bound during interaction with the user. Later + -- Ids shadow earlier ones with the same OccName + -- Expressions are typed with these Ids in the envt For + -- runtime-debugging, these Ids may have free TcTyVars of + -- RuntimUnkSkol flavour, but no free TyVars (because the + -- typechecker doesn't expect that) #ifdef GHCI - , ic_resume :: [Resume] -- ^ The stack of breakpoint contexts + ic_resume :: [Resume], + -- ^ The stack of breakpoint contexts #endif - , ic_cwd :: Maybe FilePath -- virtual CWD of the program + ic_cwd :: Maybe FilePath + -- virtual CWD of the program } emptyInteractiveContext :: InteractiveContext emptyInteractiveContext = InteractiveContext { ic_toplev_scope = [], - ic_exports = [], + ic_imports = [], ic_rn_gbl_env = emptyGlobalRdrEnv, ic_tmp_ids = [] #ifdef GHCI @@ -1283,19 +1053,18 @@ -- This invariant is used in LoadIface.loadDecl (see note [Tricky iface loop]) -- The order of the list does not matter. implicitTyThings :: TyThing -> [TyThing] - --- For data and newtype declarations: -implicitTyThings (ATyCon tc) - = -- fields (names of selectors) - -- (possibly) implicit coercion and family coercion - -- depending on whether it's a newtype or a family instance or both - implicitCoTyCon tc ++ - -- for each data constructor in order, - -- the contructor, worker, and (possibly) wrapper - concatMap (extras_plus . ADataCon) (tyConDataCons tc) - -implicitTyThings (AClass cl) - = -- dictionary datatype: +implicitTyThings (AnId _) = [] +implicitTyThings (ACoAxiom _cc) = [] +implicitTyThings (ATyCon tc) = implicitTyConThings tc +implicitTyThings (AClass cl) = implicitClassThings cl +implicitTyThings (ADataCon dc) = map AnId (dataConImplicitIds dc) + -- For data cons add the worker and (possibly) wrapper + +implicitClassThings :: Class -> [TyThing] +implicitClassThings cl + = -- Does not include default methods, because those Ids may have + -- their own pragmas, unfoldings etc, not derived from the Class object + -- Dictionary datatype: -- [extras_plus:] -- type constructor -- [recursive call:] @@ -1311,11 +1080,16 @@ -- superclass and operation selectors map AnId (classAllSelIds cl) -implicitTyThings (ADataCon dc) = - -- For data cons add the worker and (possibly) wrapper - map AnId (dataConImplicitIds dc) +implicitTyConThings :: TyCon -> [TyThing] +implicitTyConThings tc + = -- fields (names of selectors) + -- (possibly) implicit coercion and family coercion + -- depending on whether it's a newtype or a family instance or both + implicitCoTyCon tc ++ + -- for each data constructor in order, + -- the contructor, worker, and (possibly) wrapper + concatMap (extras_plus . ADataCon) (tyConDataCons tc) -implicitTyThings (AnId _) = [] -- add a thing and recursive call extras_plus :: TyThing -> [TyThing] @@ -1325,10 +1099,10 @@ -- add the implicit coercion tycon implicitCoTyCon :: TyCon -> [TyThing] implicitCoTyCon tc - = map ATyCon . catMaybes $ [-- Just if newtype, Nothing if not - newTyConCo_maybe tc, + = map ACoAxiom . catMaybes $ [-- Just if newtype, Nothing if not + newTyConCo_maybe tc, -- Just if family instance, Nothing if not - tyConFamilyCoercion_maybe tc] + tyConFamilyCoercion_maybe tc] -- sortByOcc = sortBy (\ x -> \ y -> getOccName x < getOccName y) @@ -1338,10 +1112,11 @@ -- of some other declaration, or it is generated implicitly by some -- other declaration. isImplicitTyThing :: TyThing -> Bool -isImplicitTyThing (ADataCon _) = True -isImplicitTyThing (AnId id) = isImplicitId id -isImplicitTyThing (AClass _) = False -isImplicitTyThing (ATyCon tc) = isImplicitTyCon tc +isImplicitTyThing (ADataCon {}) = True +isImplicitTyThing (AnId id) = isImplicitId id +isImplicitTyThing (AClass {}) = False +isImplicitTyThing (ATyCon tc) = isImplicitTyCon tc +isImplicitTyThing (ACoAxiom {}) = True extendTypeEnvWithIds :: TypeEnv -> [Id] -> TypeEnv extendTypeEnvWithIds env ids @@ -1363,6 +1138,7 @@ typeEnvElts :: TypeEnv -> [TyThing] typeEnvClasses :: TypeEnv -> [Class] typeEnvTyCons :: TypeEnv -> [TyCon] +typeEnvCoAxioms :: TypeEnv -> [CoAxiom] typeEnvIds :: TypeEnv -> [Id] typeEnvDataCons :: TypeEnv -> [DataCon] lookupTypeEnv :: TypeEnv -> Name -> Maybe TyThing @@ -1371,6 +1147,7 @@ typeEnvElts env = nameEnvElts env typeEnvClasses env = [cl | AClass cl <- typeEnvElts env] typeEnvTyCons env = [tc | ATyCon tc <- typeEnvElts env] +typeEnvCoAxioms env = [ax | ACoAxiom ax <- typeEnvElts env] typeEnvIds env = [id | AnId id <- typeEnvElts env] typeEnvDataCons env = [dc | ADataCon dc <- typeEnvElts env] @@ -1426,6 +1203,11 @@ tyThingTyCon (ATyCon tc) = tc tyThingTyCon other = pprPanic "tyThingTyCon" (pprTyThing other) +-- | Get the 'CoAxiom' from a 'TyThing' if it is a coercion axiom thing. Panics otherwise +tyThingCoAxiom :: TyThing -> CoAxiom +tyThingCoAxiom (ACoAxiom ax) = ax +tyThingCoAxiom other = pprPanic "tyThingCoAxiom" (pprTyThing other) + -- | Get the 'Class' from a 'TyThing' if it is a class thing. Panics otherwise tyThingClass :: TyThing -> Class tyThingClass (AClass cls) = cls @@ -1546,27 +1328,24 @@ \begin{code} -- | A collection of 'AvailInfo' - several things that are \"available\" type Avails = [AvailInfo] --- | 'Name'd things that are available -type AvailInfo = GenAvailInfo Name --- | 'RdrName'd things that are available -type RdrAvailInfo = GenAvailInfo OccName -- | Records what things are "available", i.e. in scope -data GenAvailInfo name = Avail name -- ^ An ordinary identifier in scope - | AvailTC name - [name] -- ^ A type or class in scope. Parameters: - -- - -- 1) The name of the type or class - -- - -- 2) The available pieces of type or class. - -- NB: If the type or class is itself - -- to be in scope, it must be in this list. - -- Thus, typically: @AvailTC Eq [Eq, ==, \/=]@ - deriving( Eq ) +data AvailInfo = Avail Name -- ^ An ordinary identifier in scope + | AvailTC Name + [Name] -- ^ A type or class in scope. Parameters: + -- + -- 1) The name of the type or class + -- 2) The available pieces of type or class. + -- + -- The AvailTC Invariant: + -- * If the type or class is itself + -- to be in scope, it must be *first* in this list. + -- Thus, typically: @AvailTC Eq [Eq, ==, \/=]@ + deriving( Eq ) -- Equality used when deciding if the interface has changed -- | The original names declared of a certain module that are exported -type IfaceExport = (Module, [GenAvailInfo OccName]) +type IfaceExport = AvailInfo availsToNameSet :: [AvailInfo] -> NameSet availsToNameSet avails = foldr add emptyNameSet avails @@ -1579,21 +1358,29 @@ -- | Just the main name made available, i.e. not the available pieces -- of type or class brought into scope by the 'GenAvailInfo' -availName :: GenAvailInfo name -> name +availName :: AvailInfo -> Name availName (Avail n) = n availName (AvailTC n _) = n -- | All names made available by the availability information -availNames :: GenAvailInfo name -> [name] +availNames :: AvailInfo -> [Name] availNames (Avail n) = [n] availNames (AvailTC _ ns) = ns -instance Outputable n => Outputable (GenAvailInfo n) where +instance Outputable AvailInfo where ppr = pprAvail -pprAvail :: Outputable n => GenAvailInfo n -> SDoc +pprAvail :: AvailInfo -> SDoc pprAvail (Avail n) = ppr n pprAvail (AvailTC n ns) = ppr n <> braces (hsep (punctuate comma (map ppr ns))) + +stableAvailCmp :: AvailInfo -> AvailInfo -> Ordering +-- Compare lexicographically +stableAvailCmp (Avail n1) (Avail n2) = n1 `stableNameCmp` n2 +stableAvailCmp (Avail {}) (AvailTC {}) = LT +stableAvailCmp (AvailTC n ns) (AvailTC m ms) = (n `stableNameCmp` m) `thenCmp` + (cmpList stableNameCmp ns ms) +stableAvailCmp (AvailTC {}) (Avail {}) = GT \end{code} \begin{code} @@ -1658,19 +1445,21 @@ data Dependencies = Deps { dep_mods :: [(ModuleName, IsBootInterface)] -- ^ Home-package module dependencies - , dep_pkgs :: [PackageId] - -- ^ External package dependencies - , dep_orphs :: [Module] - -- ^ Orphan modules (whether home or external pkg), - -- *not* including family instance orphans as they - -- are anyway included in 'dep_finsts' - , dep_finsts :: [Module] + , dep_pkgs :: [(PackageId, Bool)] + -- ^ External package dependencies. The bool indicates + -- if the package is required to be trusted when the + -- module is imported as a safe import (Safe Haskell). + -- See Note [RnNames . Tracking Trust Transitively] + , dep_orphs :: [Module] + -- ^ Orphan modules (whether home or external pkg), + -- *not* including family instance orphans as they + -- are anyway included in 'dep_finsts' + , dep_finsts :: [Module] -- ^ Modules that contain family instances (whether the -- instances are from the home or an external package) } deriving( Eq ) - -- Equality used only for old/new comparison in MkIface.addVersionInfo - + -- Equality used only for old/new comparison in MkIface.addVersionInfo -- See 'TcRnTypes.ImportAvails' for details on dependencies. noDependencies :: Dependencies @@ -1681,7 +1470,10 @@ = UsagePackageModule { usg_mod :: Module, -- ^ External package module depended on - usg_mod_hash :: Fingerprint + usg_mod_hash :: Fingerprint, + -- ^ Cached module fingerprint + usg_safe :: IsSafeImport + -- ^ Was this module imported as a safe import } -- ^ Module from another package | UsageHomeModule { usg_mod_name :: ModuleName, @@ -1692,9 +1484,11 @@ -- ^ Entities we depend on, sorted by occurrence name and fingerprinted. -- NB: usages are for parent names only, e.g. type constructors -- but not the associated data constructors. - usg_exports :: Maybe Fingerprint + usg_exports :: Maybe Fingerprint, -- ^ Fingerprint for the export list we used to depend on this module, -- if we depend on the export list + usg_safe :: IsSafeImport + -- ^ Was this module imported as a safe import } -- ^ Module from the current package deriving( Eq ) -- The export list field is (Just v) if we depend on the export list: @@ -1861,22 +1655,38 @@ -- * An external-core source module data ModSummary = ModSummary { - ms_mod :: Module, -- ^ Identity of the module - ms_hsc_src :: HscSource, -- ^ The module source either plain Haskell, hs-boot or external core - ms_location :: ModLocation, -- ^ Location of the various files belonging to the module - ms_hs_date :: ClockTime, -- ^ Timestamp of source file - ms_obj_date :: Maybe ClockTime, -- ^ Timestamp of object, if we have one - ms_srcimps :: [Located (ImportDecl RdrName)], -- ^ Source imports of the module - ms_imps :: [Located (ImportDecl RdrName)], -- ^ Non-source imports of the module - ms_hspp_file :: FilePath, -- ^ Filename of preprocessed source file - ms_hspp_opts :: DynFlags, -- ^ Cached flags from @OPTIONS@, @INCLUDE@ + ms_mod :: Module, -- ^ Identity of the module + ms_hsc_src :: HscSource, -- ^ The module source either plain Haskell, hs-boot or external core + ms_location :: ModLocation, -- ^ Location of the various files belonging to the module + ms_hs_date :: ClockTime, -- ^ Timestamp of source file + ms_obj_date :: Maybe ClockTime, -- ^ Timestamp of object, if we have one + ms_srcimps :: [Located (ImportDecl RdrName)], -- ^ Source imports of the module + ms_textual_imps :: [Located (ImportDecl RdrName)], -- ^ Non-source imports of the module from the module *text* + ms_hspp_file :: FilePath, -- ^ Filename of preprocessed source file + ms_hspp_opts :: DynFlags, -- ^ Cached flags from @OPTIONS@, @INCLUDE@ -- and @LANGUAGE@ pragmas in the modules source code - ms_hspp_buf :: Maybe StringBuffer -- ^ The actual preprocessed source, if we have it + ms_hspp_buf :: Maybe StringBuffer -- ^ The actual preprocessed source, if we have it } ms_mod_name :: ModSummary -> ModuleName ms_mod_name = moduleName . ms_mod +ms_imps :: ModSummary -> [Located (ImportDecl RdrName)] +ms_imps ms = ms_textual_imps ms ++ map mk_additional_import (dynFlagDependencies (ms_hspp_opts ms)) + where + -- This is a not-entirely-satisfactory means of creating an import that corresponds to an + -- import that did not occur in the program text, such as those induced by the use of + -- plugins (the -plgFoo flag) + mk_additional_import mod_nm = noLoc $ ImportDecl { + ideclName = noLoc mod_nm, + ideclPkgQual = Nothing, + ideclSource = False, + ideclQualified = False, + ideclAs = Nothing, + ideclHiding = Nothing, + ideclSafe = False + } + -- The ModLocation contains both the original source filename and the -- filename of the cleaned-up source file after all preprocessing has been -- done. The point is that the summariser will have to cpp/unlit/whatever @@ -1902,7 +1712,7 @@ nest 3 (sep [text "ms_hs_date = " <> text (show (ms_hs_date ms)), text "ms_mod =" <+> ppr (ms_mod ms) <> text (hscSourceString (ms_hsc_src ms)) <> comma, - text "ms_imps =" <+> ppr (ms_imps ms), + text "ms_textual_imps =" <+> ppr (ms_textual_imps ms), text "ms_srcimps =" <+> ppr (ms_srcimps ms)]), char '}' ] @@ -1923,6 +1733,30 @@ mod_str = showSDoc (ppr mod) ++ hscSourceString (ms_hsc_src mod_summary) \end{code} +%************************************************************************ +%* * +\subsection{Recmpilation} +%* * +%************************************************************************ + +\begin{code} +-- | Indicates whether a given module's source has been modified since it +-- was last compiled. +data SourceModified + = SourceModified + -- ^ the source has been modified + | SourceUnmodified + -- ^ the source has not been modified. Compilation may or may + -- not be necessary, depending on whether any dependencies have + -- changed since we last compiled. + | SourceUnmodifiedAndStable + -- ^ the source has not been modified, and furthermore all of + -- its (transitive) dependencies are up to date; it definitely + -- does not need to be recompiled. This is important for two + -- reasons: (a) we can omit the version check in checkOldIface, + -- and (b) if the module used TH splices we don't need to force + -- recompilation. +\end{code} %************************************************************************ %* * @@ -1956,9 +1790,9 @@ \end{code} %************************************************************************ -%* * +%* * \subsection{Vectorisation Support} -%* * +%* * %************************************************************************ The following information is generated and consumed by the vectorisation @@ -1971,49 +1805,106 @@ on just the OccName easily in a Core pass. \begin{code} --- | Vectorisation information for 'ModGuts', 'ModDetails' and 'ExternalPackageState'. +-- |Vectorisation information for 'ModGuts', 'ModDetails' and 'ExternalPackageState'; see also +-- documentation at 'Vectorise.Env.GlobalEnv'. data VectInfo - = VectInfo { - vectInfoVar :: VarEnv (Var , Var ), -- ^ @(f, f_v)@ keyed on @f@ - vectInfoTyCon :: NameEnv (TyCon , TyCon), -- ^ @(T, T_v)@ keyed on @T@ - vectInfoDataCon :: NameEnv (DataCon, DataCon), -- ^ @(C, C_v)@ keyed on @C@ - vectInfoPADFun :: NameEnv (TyCon , Var), -- ^ @(T_v, paT)@ keyed on @T_v@ - vectInfoIso :: NameEnv (TyCon , Var) -- ^ @(T, isoT)@ keyed on @T@ + = VectInfo + { vectInfoVar :: VarEnv (Var , Var ) -- ^ @(f, f_v)@ keyed on @f@ + , vectInfoTyCon :: NameEnv (TyCon , TyCon) -- ^ @(T, T_v)@ keyed on @T@ + , vectInfoDataCon :: NameEnv (DataCon, DataCon) -- ^ @(C, C_v)@ keyed on @C@ + , vectInfoPADFun :: NameEnv (TyCon , Var) -- ^ @(T_v, paT)@ keyed on @T_v@ + , vectInfoIso :: NameEnv (TyCon , Var) -- ^ @(T, isoT)@ keyed on @T@ + , vectInfoScalarVars :: VarSet -- ^ set of purely scalar variables + , vectInfoScalarTyCons :: NameSet -- ^ set of scalar type constructors } --- | Vectorisation information for 'ModIface': a slightly less low-level view +-- |Vectorisation information for 'ModIface'; i.e, the vectorisation information propagated +-- across module boundaries. +-- data IfaceVectInfo - = IfaceVectInfo { - ifaceVectInfoVar :: [Name], - -- ^ All variables in here have a vectorised variant - ifaceVectInfoTyCon :: [Name], - -- ^ All 'TyCon's in here have a vectorised variant; - -- the name of the vectorised variant and those of its - -- data constructors are determined by 'OccName.mkVectTyConOcc' - -- and 'OccName.mkVectDataConOcc'; the names of - -- the isomorphisms are determined by 'OccName.mkVectIsoOcc' - ifaceVectInfoTyConReuse :: [Name] - -- ^ The vectorised form of all the 'TyCon's in here coincides with - -- the unconverted form; the name of the isomorphisms is determined - -- by 'OccName.mkVectIsoOcc' + = IfaceVectInfo + { ifaceVectInfoVar :: [Name] -- ^ All variables in here have a vectorised variant + , ifaceVectInfoTyCon :: [Name] -- ^ All 'TyCon's in here have a vectorised variant; + -- the name of the vectorised variant and those of its + -- data constructors are determined by + -- 'OccName.mkVectTyConOcc' and + -- 'OccName.mkVectDataConOcc'; the names of the + -- isomorphisms are determined by 'OccName.mkVectIsoOcc' + , ifaceVectInfoTyConReuse :: [Name] -- ^ The vectorised form of all the 'TyCon's in here + -- coincides with the unconverted form; the name of the + -- isomorphisms is determined by 'OccName.mkVectIsoOcc' + , ifaceVectInfoScalarVars :: [Name] -- iface version of 'vectInfoScalarVar' + , ifaceVectInfoScalarTyCons :: [Name] -- iface version of 'vectInfoScalarTyCon' } noVectInfo :: VectInfo -noVectInfo = VectInfo emptyVarEnv emptyNameEnv emptyNameEnv emptyNameEnv emptyNameEnv +noVectInfo + = VectInfo emptyVarEnv emptyNameEnv emptyNameEnv emptyNameEnv emptyNameEnv emptyVarSet + emptyNameSet plusVectInfo :: VectInfo -> VectInfo -> VectInfo plusVectInfo vi1 vi2 = - VectInfo (vectInfoVar vi1 `plusVarEnv` vectInfoVar vi2) - (vectInfoTyCon vi1 `plusNameEnv` vectInfoTyCon vi2) - (vectInfoDataCon vi1 `plusNameEnv` vectInfoDataCon vi2) - (vectInfoPADFun vi1 `plusNameEnv` vectInfoPADFun vi2) - (vectInfoIso vi1 `plusNameEnv` vectInfoIso vi2) + VectInfo (vectInfoVar vi1 `plusVarEnv` vectInfoVar vi2) + (vectInfoTyCon vi1 `plusNameEnv` vectInfoTyCon vi2) + (vectInfoDataCon vi1 `plusNameEnv` vectInfoDataCon vi2) + (vectInfoPADFun vi1 `plusNameEnv` vectInfoPADFun vi2) + (vectInfoIso vi1 `plusNameEnv` vectInfoIso vi2) + (vectInfoScalarVars vi1 `unionVarSet` vectInfoScalarVars vi2) + (vectInfoScalarTyCons vi1 `unionNameSets` vectInfoScalarTyCons vi2) concatVectInfo :: [VectInfo] -> VectInfo concatVectInfo = foldr plusVectInfo noVectInfo noIfaceVectInfo :: IfaceVectInfo -noIfaceVectInfo = IfaceVectInfo [] [] [] +noIfaceVectInfo = IfaceVectInfo [] [] [] [] [] +\end{code} + +%************************************************************************ +%* * +\subsection{Safe Haskell Support} +%* * +%************************************************************************ + +This stuff here is related to supporting the Safe Haskell extension, +primarily about storing under what trust type a module has been compiled. + +\begin{code} +-- | Is an import a safe import? +type IsSafeImport = Bool + +-- | Safe Haskell information for 'ModIface' +-- Simply a wrapper around SafeHaskellMode to sepperate iface and flags +newtype IfaceTrustInfo = TrustInfo SafeHaskellMode + +getSafeMode :: IfaceTrustInfo -> SafeHaskellMode +getSafeMode (TrustInfo x) = x + +setSafeMode :: SafeHaskellMode -> IfaceTrustInfo +setSafeMode = TrustInfo + +noIfaceTrustInfo :: IfaceTrustInfo +noIfaceTrustInfo = setSafeMode Sf_None + +trustInfoToNum :: IfaceTrustInfo -> Word8 +trustInfoToNum it + = case getSafeMode it of + Sf_None -> 0 + Sf_SafeImports -> 1 + Sf_Trustworthy -> 2 + Sf_Safe -> 3 + +numToTrustInfo :: Word8 -> IfaceTrustInfo +numToTrustInfo 0 = setSafeMode Sf_None +numToTrustInfo 1 = setSafeMode Sf_SafeImports +numToTrustInfo 2 = setSafeMode Sf_Trustworthy +numToTrustInfo 3 = setSafeMode Sf_Safe +numToTrustInfo n = error $ "numToTrustInfo: bad input number! (" ++ show n ++ ")" + +instance Outputable IfaceTrustInfo where + ppr (TrustInfo Sf_None) = ptext $ sLit "none" + ppr (TrustInfo Sf_SafeImports) = ptext $ sLit "safe-imports" + ppr (TrustInfo Sf_Trustworthy) = ptext $ sLit "trustworthy" + ppr (TrustInfo Sf_Safe) = ptext $ sLit "safe" \end{code} %************************************************************************ @@ -2050,6 +1941,9 @@ -- compiling a module in HscNothing mode, and this choice -- happens to work well with checkStability in module GHC. +linkableObjs :: Linkable -> [FilePath] +linkableObjs l = [ f | DotO f <- linkableUnlinked l ] + instance Outputable Linkable where ppr (LM when_made mod unlinkeds) = (text "LinkableM" <+> parens (text (show when_made)) <+> ppr mod) @@ -2124,13 +2018,16 @@ -- ^ An array giving the source span of each breakpoint. , modBreaks_vars :: !(Array BreakIndex [OccName]) -- ^ An array giving the names of the free variables at each breakpoint. + , modBreaks_decls :: !(Array BreakIndex [String]) + -- ^ An array giving the names of the declarations enclosing each breakpoint. } emptyModBreaks :: ModBreaks emptyModBreaks = ModBreaks { modBreaks_flags = error "ModBreaks.modBreaks_array not initialised" -- Todo: can we avoid this? - , modBreaks_locs = array (0,-1) [] - , modBreaks_vars = array (0,-1) [] + , modBreaks_locs = array (0,-1) [] + , modBreaks_vars = array (0,-1) [] + , modBreaks_decls = array (0,-1) [] } \end{code} diff -Nru ghc-7.0.3/compiler/main/InteractiveEval.hs ghc-7.2.1/compiler/main/InteractiveEval.hs --- ghc-7.0.3/compiler/main/InteractiveEval.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/main/InteractiveEval.hs 2011-08-07 17:10:05.000000000 +0000 @@ -9,7 +9,8 @@ module InteractiveEval ( #ifdef GHCI RunResult(..), Status(..), Resume(..), History(..), - runStmt, parseImportDecl, SingleStep(..), + runStmt, runStmtWithLocation, + parseImportDecl, SingleStep(..), resume, abandon, abandonAll, getResumeContext, @@ -37,12 +38,11 @@ #include "HsVersions.h" -import HscMain hiding (compileExpr) -import HsSyn (ImportDecl) +import GhcMonad +import HscMain +import HsSyn import HscTypes -import TcRnDriver -import TcRnMonad (initTc) -import RnNames (gresFromAvails, rnImports) +import RnNames (gresFromAvails) import InstEnv import Type import TcType hiding( typeKind ) @@ -64,27 +64,27 @@ import UniqFM import Maybes import ErrUtils -import Util import SrcLoc import BreakArray import RtClosureInspect -import BasicTypes import Outputable import FastString import MonadUtils import System.Directory import Data.Dynamic -import Data.List (find, partition) +import Data.List (find) import Control.Monad +#if __GLASGOW_HASKELL__ >= 701 +import Foreign.Safe +#else import Foreign hiding (unsafePerformIO) +#endif import Foreign.C import GHC.Exts import Data.Array import Exception import Control.Concurrent -import Data.List (sortBy) --- import Foreign.StablePtr import System.IO import System.IO.Unsafe @@ -139,16 +139,14 @@ = History { historyApStack :: HValue, historyBreakInfo :: BreakInfo, - historyEnclosingDecl :: Id - -- ^^ A cache of the enclosing top level declaration, for convenience + historyEnclosingDecls :: [String] -- declarations enclosing the breakpoint } mkHistory :: HscEnv -> HValue -> BreakInfo -> History mkHistory hsc_env hval bi = let - h = History hval bi decl - decl = findEnclosingDecl hsc_env (getHistoryModule h) - (getHistorySpan hsc_env h) - in h + decls = findEnclosingDecls hsc_env bi + in History hval bi decls + getHistoryModule :: History -> Module getHistoryModule = breakInfo_module . historyBreakInfo @@ -163,7 +161,7 @@ getModBreaks :: HomeModInfo -> ModBreaks getModBreaks hmi - | Just linkable <- hm_linkable hmi, + | Just linkable <- hm_linkable hmi, [BCOs _ modBreaks] <- linkableUnlinked linkable = modBreaks | otherwise @@ -173,23 +171,24 @@ -- ToDo: a better way to do this would be to keep hold of the decl_path computed -- by the coverage pass, which gives the list of lexically-enclosing bindings -- for each tick. -findEnclosingDecl :: HscEnv -> Module -> SrcSpan -> Id -findEnclosingDecl hsc_env mod span = - case lookupUFM (hsc_HPT hsc_env) (moduleName mod) of - Nothing -> panic "findEnclosingDecl" - Just hmi -> let - globals = typeEnvIds (md_types (hm_details hmi)) - Just decl = - find (\id -> let n = idName id in - nameSrcSpan n < span && isExternalName n) - (reverse$ sortBy (compare `on` (nameSrcSpan.idName)) - globals) - in decl +findEnclosingDecls :: HscEnv -> BreakInfo -> [String] +findEnclosingDecls hsc_env inf = + let hmi = expectJust "findEnclosingDecls" $ + lookupUFM (hsc_HPT hsc_env) (moduleName $ breakInfo_module inf) + mb = getModBreaks hmi + in modBreaks_decls mb ! breakInfo_number inf + -- | Run a statement in the current interactive context. Statement -- may bind multple values. runStmt :: GhcMonad m => String -> SingleStep -> m RunResult -runStmt expr step = +runStmt = runStmtWithLocation "" 1 + +-- | Run a statement in the current interactive context. Passing debug information +-- Statement may bind multple values. +runStmtWithLocation :: GhcMonad m => String -> Int -> + String -> SingleStep -> m RunResult +runStmtWithLocation source linenumber expr step = do hsc_env <- getSession @@ -198,23 +197,15 @@ -- Turn off -fwarn-unused-bindings when running a statement, to hide -- warnings about the implicit bindings we introduce. - let dflags' = dopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds + let dflags' = wopt_unset (hsc_dflags hsc_env) Opt_WarnUnusedBinds hsc_env' = hsc_env{ hsc_dflags = dflags' } - r <- hscStmt hsc_env' expr + r <- liftIO $ hscStmtWithLocation hsc_env' expr source linenumber case r of Nothing -> return RunFailed -- empty statement / comment Just (ids, hval) -> do - -- XXX: This is the only place we can print warnings before the - -- result. Is this really the right thing to do? It's fine for - -- GHCi, but what's correct for other GHC API clients? We could - -- introduce a callback argument. - warns <- getWarnings - liftIO $ printBagOfWarnings dflags' warns - clearWarnings - status <- withVirtualCWD $ withBreakAction (isStep step) dflags' breakMVar statusMVar $ do @@ -254,7 +245,7 @@ gbracket set_cwd reset_cwd $ \_ -> m parseImportDecl :: GhcMonad m => String -> m (ImportDecl RdrName) -parseImportDecl expr = withSession $ \hsc_env -> hscImport hsc_env expr +parseImportDecl expr = withSession $ \hsc_env -> liftIO $ hscImport hsc_env expr emptyHistory :: BoundedList History emptyHistory = nilBL 50 -- keep a log of length 50 @@ -789,39 +780,27 @@ -- module. They always shadow anything in scope in the current context. setContext :: GhcMonad m => [Module] -- ^ entire top level scope of these modules - -> [(Module, Maybe (ImportDecl RdrName))] -- ^ exports of these modules + -> [ImportDecl RdrName] -- ^ these import declarations -> m () -setContext toplev_mods other_mods = do +setContext toplev_mods import_decls = do hsc_env <- getSession let old_ic = hsc_IC hsc_env hpt = hsc_HPT hsc_env - (decls,mods) = partition (isJust . snd) other_mods -- time for tracing - export_mods = map fst mods - imprt_decls = map noLoc (catMaybes (map snd decls)) + imprt_decls = map noLoc import_decls -- - export_env <- liftIO $ mkExportEnv hsc_env export_mods import_env <- if null imprt_decls then return emptyGlobalRdrEnv else do - let imports = rnImports imprt_decls - this_mod = if null toplev_mods then pRELUDE else head toplev_mods - (_, env, _,_) <- - ioMsgMaybe $ liftIO $ initTc hsc_env HsSrcFile False this_mod imports - return env + let this_mod | null toplev_mods = pRELUDE + | otherwise = head toplev_mods + liftIO $ hscRnImportDecls hsc_env this_mod imprt_decls + toplev_envs <- liftIO $ mapM (mkTopLevEnv hpt) toplev_mods - let all_env = foldr plusGlobalRdrEnv (plusGlobalRdrEnv export_env import_env) toplev_envs + + let all_env = foldr plusGlobalRdrEnv import_env toplev_envs modifySession $ \_ -> hsc_env{ hsc_IC = old_ic { ic_toplev_scope = toplev_mods, - ic_exports = other_mods, - ic_rn_gbl_env = all_env }} - --- Make a GlobalRdrEnv based on the exports of the modules only. -mkExportEnv :: HscEnv -> [Module] -> IO GlobalRdrEnv -mkExportEnv hsc_env mods - = do { stuff <- mapM (getModuleExports hsc_env) mods - ; let (_msgs, mb_name_sets) = unzip stuff - envs = [ availsToGlobalRdrEnv (moduleName mod) avails - | (Just avails, mod) <- zip mb_name_sets mods ] - ; return $! foldr plusGlobalRdrEnv emptyGlobalRdrEnv envs } + ic_imports = import_decls, + ic_rn_gbl_env = all_env }} availsToGlobalRdrEnv :: ModuleName -> [AvailInfo] -> GlobalRdrEnv availsToGlobalRdrEnv mod_name avails @@ -849,9 +828,9 @@ -- | Get the interactive evaluation context, consisting of a pair of the -- set of modules from which we take the full top-level scope, and the set -- of modules from which we take just the exports respectively. -getContext :: GhcMonad m => m ([Module],[(Module, Maybe (ImportDecl RdrName))]) +getContext :: GhcMonad m => m ([Module],[ImportDecl RdrName]) getContext = withSession $ \HscEnv{ hsc_IC=ic } -> - return (ic_toplev_scope ic, ic_exports ic) + return (ic_toplev_scope ic, ic_imports ic) -- | Returns @True@ if the specified module is interpreted, and hence has -- its full top-level scope available. @@ -871,7 +850,7 @@ getInfo :: GhcMonad m => Name -> m (Maybe (TyThing,Fixity,[Instance])) getInfo name = withSession $ \hsc_env -> - do mb_stuff <- ioMsg $ tcRnGetInfo hsc_env name + do mb_stuff <- liftIO $ hscTcRnGetInfo hsc_env name case mb_stuff of Nothing -> return Nothing Just (thing, fixity, ispecs) -> do @@ -923,8 +902,8 @@ -- the identifier can refer to in the current interactive context. parseName :: GhcMonad m => String -> m [Name] parseName str = withSession $ \hsc_env -> do - (L _ rdr_name) <- hscParseIdentifier (hsc_dflags hsc_env) str - ioMsgMaybe $ tcRnLookupRdrName hsc_env rdr_name + (L _ rdr_name) <- liftIO $ hscParseIdentifier hsc_env str + liftIO $ hscTcRnLookupRdrName hsc_env rdr_name -- ----------------------------------------------------------------------------- -- Getting the type of an expression @@ -932,7 +911,7 @@ -- | Get the type of an expression exprType :: GhcMonad m => String -> m Type exprType expr = withSession $ \hsc_env -> do - ty <- hscTcExpr hsc_env expr + ty <- liftIO $ hscTcExpr hsc_env expr return $ tidyType emptyTidyEnv ty -- ----------------------------------------------------------------------------- @@ -941,14 +920,14 @@ -- | Get the kind of a type typeKind :: GhcMonad m => String -> m Kind typeKind str = withSession $ \hsc_env -> do - hscKcType hsc_env str + liftIO $ hscKcType hsc_env str ----------------------------------------------------------------------------- -- cmCompileExpr: compile an expression and deliver an HValue compileExpr :: GhcMonad m => String -> m HValue compileExpr expr = withSession $ \hsc_env -> do - Just (ids, hval) <- hscStmt hsc_env ("let __cmCompileExpr = "++expr) + Just (ids, hval) <- liftIO $ hscStmt hsc_env ("let __cmCompileExpr = "++expr) -- Run it! hvals <- liftIO (unsafeCoerce# hval :: IO [HValue]) @@ -961,14 +940,9 @@ dynCompileExpr :: GhcMonad m => String -> m Dynamic dynCompileExpr expr = do - (full,exports) <- getContext - setContext full $ - (mkModule - (stringToPackageId "base") (mkModuleName "Data.Dynamic") - ,Nothing):exports let stmt = "let __dynCompileExpr = Data.Dynamic.toDyn (" ++ expr ++ ")" - Just (ids, hvals) <- withSession (flip hscStmt stmt) - setContext full exports + Just (ids, hvals) <- withSession $ \hsc_env -> + liftIO $ hscStmt hsc_env stmt vals <- liftIO (unsafeCoerce# hvals :: IO [Dynamic]) case (ids,vals) of (_:[], v:[]) -> return v diff -Nru ghc-7.0.3/compiler/main/Packages.lhs ghc-7.2.1/compiler/main/Packages.lhs --- ghc-7.0.3/compiler/main/Packages.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/main/Packages.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -14,7 +14,7 @@ PackageState(..), initPackages, getPackageDetails, - lookupModuleInAllPackages, + lookupModuleInAllPackages, lookupModuleWithSuggestions, -- * Inspecting the set of packages in scope getPackageIncludePath, @@ -36,7 +36,7 @@ #include "HsVersions.h" import PackageConfig -import DynFlags ( dopt, DynFlag(..), DynFlags(..), PackageFlag(..) ) +import DynFlags import StaticFlags import Config ( cProjectVersion ) import Name ( Name, nameModule_maybe ) @@ -56,7 +56,8 @@ import Exception import System.Directory -import System.FilePath +import System.FilePath as FilePath +import qualified System.FilePath.Posix as FilePath.Posix import Control.Monad import Data.List as List import Data.Map (Map) @@ -170,7 +171,7 @@ initPackages dflags = do pkg_db <- case pkgDatabase dflags of Nothing -> readPackageConfigs dflags - Just db -> return $ maybeHidePackages dflags db + Just db -> return $ setBatchPackageFlags dflags db (pkg_state, preload, this_pkg) <- mkPackageState dflags pkg_db [] (thisPackage dflags) return (dflags{ pkgDatabase = Just pkg_db, @@ -246,39 +247,74 @@ let top_dir = topDir dflags - pkg_configs1 = mungePackagePaths top_dir proto_pkg_configs - pkg_configs2 = maybeHidePackages dflags pkg_configs1 + pkgroot = takeDirectory conf_file + pkg_configs1 = map (mungePackagePaths top_dir pkgroot) proto_pkg_configs + pkg_configs2 = setBatchPackageFlags dflags pkg_configs1 -- return pkg_configs2 -maybeHidePackages :: DynFlags -> [PackageConfig] -> [PackageConfig] -maybeHidePackages dflags pkgs - | dopt Opt_HideAllPackages dflags = map hide pkgs - | otherwise = pkgs +setBatchPackageFlags :: DynFlags -> [PackageConfig] -> [PackageConfig] +setBatchPackageFlags dflags pkgs = (maybeDistrustAll . maybeHideAll) pkgs where - hide pkg = pkg{ exposed = False } + maybeHideAll pkgs' + | dopt Opt_HideAllPackages dflags = map hide pkgs' + | otherwise = pkgs' + + maybeDistrustAll pkgs' + | dopt Opt_DistrustAllPackages dflags = map distrust pkgs' + | otherwise = pkgs' -mungePackagePaths :: String -> [PackageConfig] -> [PackageConfig] --- Replace the string "$topdir" at the beginning of a path --- with the current topdir (obtained from the -B option). -mungePackagePaths top_dir ps = map munge_pkg ps - where - munge_pkg p = p{ importDirs = munge_paths (importDirs p), - includeDirs = munge_paths (includeDirs p), - libraryDirs = munge_paths (libraryDirs p), - frameworkDirs = munge_paths (frameworkDirs p), - haddockInterfaces = munge_paths (haddockInterfaces p), - haddockHTMLs = munge_paths (haddockHTMLs p) - } - - munge_paths = map munge_path - - munge_path p - | Just p' <- stripPrefix "$topdir" p = top_dir ++ p' - | Just p' <- stripPrefix "$httptopdir" p = toHttpPath top_dir ++ p' - | otherwise = p + hide pkg = pkg{ exposed = False } + distrust pkg = pkg{ exposed = False } - toHttpPath p = "file:///" ++ p +-- TODO: This code is duplicated in utils/ghc-pkg/Main.hs +mungePackagePaths :: FilePath -> FilePath -> PackageConfig -> PackageConfig +-- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec +-- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html) +-- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}. +-- The "pkgroot" is the directory containing the package database. +-- +-- Also perform a similar substitution for the older GHC-specific +-- "$topdir" variable. The "topdir" is the location of the ghc +-- installation (obtained from the -B option). +mungePackagePaths top_dir pkgroot pkg = + pkg { + importDirs = munge_paths (importDirs pkg), + includeDirs = munge_paths (includeDirs pkg), + libraryDirs = munge_paths (libraryDirs pkg), + frameworkDirs = munge_paths (frameworkDirs pkg), + haddockInterfaces = munge_paths (haddockInterfaces pkg), + haddockHTMLs = munge_urls (haddockHTMLs pkg) + } + where + munge_paths = map munge_path + munge_urls = map munge_url + + munge_path p + | Just p' <- stripVarPrefix "${pkgroot}" p = pkgroot ++ p' + | Just p' <- stripVarPrefix "$topdir" p = top_dir ++ p' + | otherwise = p + + munge_url p + | Just p' <- stripVarPrefix "${pkgrooturl}" p = toUrlPath pkgroot p' + | Just p' <- stripVarPrefix "$httptopdir" p = toUrlPath top_dir p' + | otherwise = p + + toUrlPath r p = "file:///" + -- URLs always use posix style '/' separators: + ++ FilePath.Posix.joinPath + (r : -- We need to drop a leading "/" or "\\" + -- if there is one: + dropWhile (all isPathSeparator) + (FilePath.splitDirectories p)) + + -- We could drop the separator here, and then use above. However, + -- by leaving it in and using ++ we keep the same path separator + -- rather than letting FilePath change it to use \ as the separator + stripVarPrefix var path = case stripPrefix var path of + Just [] -> Just [] + Just cs@(c : _) | isPathSeparator c -> Just cs + _ -> Nothing -- ----------------------------------------------------------------------------- @@ -315,6 +351,20 @@ Right (ps,qs) -> return (map hide ps ++ qs) where hide p = p {exposed=False} + -- we trust all matching packages. Maybe should only trust first one? + -- and leave others the same or set them untrusted + TrustPackage str -> + case selectPackages (matchingStr str) pkgs unusable of + Left ps -> packageFlagErr flag ps + Right (ps,qs) -> return (map trust ps ++ qs) + where trust p = p {trusted=True} + + DistrustPackage str -> + case selectPackages (matchingStr str) pkgs unusable of + Left ps -> packageFlagErr flag ps + Right (ps,qs) -> return (map distrust ps ++ qs) + where distrust p = p {trusted=False} + _ -> panic "applyPackageFlag" where @@ -378,6 +428,8 @@ HidePackage p -> text "-hide-package " <> text p ExposePackage p -> text "-package " <> text p ExposePackageId p -> text "-package-id " <> text p + TrustPackage p -> text "-trust " <> text p + DistrustPackage p -> text "-distrust " <> text p ppr_reasons = vcat (map ppr_reason reasons) ppr_reason (p, reason) = pprReason (pprIPkg p <+> text "is") reason @@ -622,7 +674,6 @@ -> IO (PackageState, [PackageId], -- new packages to preload PackageId) -- this package, might be modified if the current - -- package is a wired-in package. mkPackageState dflags pkgs0 preload0 this_package = do @@ -666,7 +717,13 @@ -} let - flags = reverse (packageFlags dflags) + flags = reverse (packageFlags dflags) ++ dphPackage + -- expose the appropriate DPH backend library + dphPackage = case dphBackend dflags of + DPHPar -> [ExposePackage "dph-prim-par", ExposePackage "dph-par"] + DPHSeq -> [ExposePackage "dph-prim-seq", ExposePackage "dph-seq"] + DPHThis -> [] + DPHNone -> [] -- pkgs0 with duplicate packages filtered out. This is -- important: it is possible for a package in the global package @@ -750,19 +807,19 @@ -- set up preloaded package when we are just building it preload3 = nub $ filter (/= this_package) $ (basicLinkedPackages ++ preload2) - + -- Close the preload packages with their dependencies dep_preload <- closeDeps pkg_db ipid_map (zip preload3 (repeat Nothing)) let new_dep_preload = filter (`notElem` preload0) dep_preload let pstate = PackageState{ preloadPackages = dep_preload, - pkgIdMap = pkg_db, - moduleToPkgConfAll = mkModuleMap pkg_db, + pkgIdMap = pkg_db, + moduleToPkgConfAll = mkModuleMap pkg_db, installedPackageIdMap = ipid_map - } + } return (pstate, new_dep_preload, this_package) - + -- ----------------------------------------------------------------------------- -- Make the mapping from module to package info @@ -879,10 +936,32 @@ -- @(pkgconf, exposed)@ where pkgconf is the PackageConfig for that package, -- and exposed is @True@ if the package exposes the module. lookupModuleInAllPackages :: DynFlags -> ModuleName -> [(PackageConfig,Bool)] -lookupModuleInAllPackages dflags m = - case lookupUFM (moduleToPkgConfAll (pkgState dflags)) m of - Nothing -> [] - Just ps -> ps +lookupModuleInAllPackages dflags m + = case lookupModuleWithSuggestions dflags m of + Right pbs -> pbs + Left _ -> [] + +lookupModuleWithSuggestions + :: DynFlags -> ModuleName + -> Either [Module] [(PackageConfig,Bool)] + -- Lookup module in all packages + -- Right pbs => found in pbs + -- Left ms => not found; but here are sugestions +lookupModuleWithSuggestions dflags m + = case lookupUFM (moduleToPkgConfAll pkg_state) m of + Nothing -> Left suggestions + Just ps -> Right ps + where + pkg_state = pkgState dflags + suggestions + | dopt Opt_HelpfulErrors dflags = fuzzyLookup (moduleNameString m) all_mods + | otherwise = [] + + all_mods :: [(String, Module)] -- All modules + all_mods = [ (moduleNameString mod_nm, mkModule pkg_id mod_nm) + | pkg_config <- eltsUFM (pkgIdMap pkg_state) + , let pkg_id = packageConfigId pkg_config + , mod_nm <- exposedModules pkg_config ] -- | Find all the 'PackageConfig' in both the preload packages from 'DynFlags' and corresponding to the list of -- 'PackageConfig's diff -Nru ghc-7.0.3/compiler/main/PprTyThing.hs ghc-7.2.1/compiler/main/PprTyThing.hs --- ghc-7.0.3/compiler/main/PprTyThing.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/main/PprTyThing.hs 2011-08-07 17:10:05.000000000 +0000 @@ -23,8 +23,8 @@ import Id import IdInfo import TyCon +import Coercion( pprCoAxiom ) import TcType -import Var import Name import Outputable import FastString @@ -45,7 +45,7 @@ ---------------------------- -- | Pretty-prints a 'TyThing' with its defining location. pprTyThingLoc :: PrintExplicitForalls -> TyThing -> SDoc -pprTyThingLoc pefas tyThing +pprTyThingLoc pefas tyThing = showWithLoc loc (pprTyThing pefas tyThing) where loc = pprNameLoc (GHC.getName tyThing) @@ -57,10 +57,11 @@ ppr_ty_thing pefas _ (AnId id) = pprId pefas id ppr_ty_thing pefas _ (ADataCon dataCon) = pprDataConSig pefas dataCon ppr_ty_thing pefas show_me (ATyCon tyCon) = pprTyCon pefas show_me tyCon +ppr_ty_thing _ _ (ACoAxiom ax) = pprCoAxiom ax ppr_ty_thing pefas show_me (AClass cls) = pprClass pefas show_me cls -- | Pretty-prints a 'TyThing' in context: that is, if the entity --- is a data constructor, record selector, or class method, then +-- is a data constructor, record selector, or class method, then -- the entity's parent declaration is pretty-printed with irrelevant -- parts omitted. pprTyThingInContext :: PrintExplicitForalls -> TyThing -> SDoc @@ -77,7 +78,7 @@ (pprTyThingInContext pefas tyThing) pprTyThingParent_maybe :: TyThing -> Maybe TyThing --- (pprTyThingParent_maybe x) returns (Just p) +-- (pprTyThingParent_maybe x) returns (Just p) -- when pprTyThingInContext sould print a declaration for p -- (albeit with some "..." in it) when asked to show x pprTyThingParent_maybe (ADataCon dc) = Just (ATyCon (dataConTyCon dc)) @@ -94,6 +95,7 @@ pprTyThingHdr pefas (AnId id) = pprId pefas id pprTyThingHdr pefas (ADataCon dataCon) = pprDataConSig pefas dataCon pprTyThingHdr pefas (ATyCon tyCon) = pprTyConHdr pefas tyCon +pprTyThingHdr _ (ACoAxiom ax) = pprCoAxiom ax pprTyThingHdr pefas (AClass cls) = pprClassHdr pefas cls pprTyConHdr :: PrintExplicitForalls -> TyCon -> SDoc @@ -103,7 +105,7 @@ | otherwise = ptext keyword <+> opt_family <+> opt_stupid <+> ppr_bndr tyCon <+> hsep (map ppr vars) where - vars | GHC.isPrimTyCon tyCon || + vars | GHC.isPrimTyCon tyCon || GHC.isFunTyCon tyCon = take (GHC.tyConArity tyCon) GHC.alphaTyVars | otherwise = GHC.tyConTyVars tyCon @@ -116,7 +118,7 @@ | otherwise = empty opt_stupid -- The "stupid theta" part of the declaration - | isAlgTyCon tyCon = GHC.pprThetaArrow (tyConStupidTheta tyCon) + | isAlgTyCon tyCon = GHC.pprThetaArrowTy (tyConStupidTheta tyCon) | otherwise = empty -- Returns 'empty' if null theta pprDataConSig :: PrintExplicitForalls -> GHC.DataCon -> SDoc @@ -125,14 +127,14 @@ pprClassHdr :: PrintExplicitForalls -> GHC.Class -> SDoc pprClassHdr _ cls - = ptext (sLit "class") <+> - GHC.pprThetaArrow (GHC.classSCTheta cls) <+> + = ptext (sLit "class") <+> + GHC.pprThetaArrowTy (GHC.classSCTheta cls) <+> ppr_bndr cls <+> hsep (map ppr tyVars) <+> GHC.pprFundeps funDeps where (tyVars, funDeps) = GHC.classTvsFds cls - + pprId :: PrintExplicitForalls -> Var -> SDoc pprId pefas ident = hang (ppr_bndr ident <+> dcolon) @@ -147,7 +149,7 @@ -- forall a. C a => forall b. Ord b => stuff -- Then we want to display -- (C a, Ord b) => stuff -pprTypeForUser print_foralls ty +pprTypeForUser print_foralls ty | print_foralls = ppr tidy_ty | otherwise = ppr (mkPhiTy ctxt ty') where @@ -160,7 +162,7 @@ = if GHC.isFamilyTyCon tyCon then pprTyConHdr pefas tyCon <+> dcolon <+> pprTypeForUser pefas (GHC.synTyConResKind tyCon) - else + else let rhs_type = GHC.synTyConType tyCon in hang (pprTyConHdr pefas tyCon <+> equals) 2 (pprTypeForUser pefas rhs_type) | otherwise @@ -168,7 +170,7 @@ pprAlgTyCon :: PrintExplicitForalls -> ShowMe -> TyCon -> SDoc pprAlgTyCon pefas show_me tyCon - | gadt = pprTyConHdr pefas tyCon <+> ptext (sLit "where") $$ + | gadt = pprTyConHdr pefas tyCon <+> ptext (sLit "where") $$ nest 2 (vcat (ppr_trim show_con datacons)) | otherwise = hang (pprTyConHdr pefas tyCon) 2 (add_bars (ppr_trim show_con datacons)) @@ -184,8 +186,8 @@ pprDataConDecl :: PrintExplicitForalls -> ShowMe -> Bool -> GHC.DataCon -> SDoc pprDataConDecl pefas show_me gadt_style dataCon | not gadt_style = ppr_fields tys_w_strs - | otherwise = ppr_bndr dataCon <+> dcolon <+> - sep [ pp_foralls, GHC.pprThetaArrow theta, pp_tau ] + | otherwise = ppr_bndr dataCon <+> dcolon <+> + sep [ pp_foralls, GHC.pprThetaArrowTy theta, pp_tau ] -- Printing out the dataCon as a type signature, in GADT style where (forall_tvs, theta, tau) = tcSplitSigmaTy (GHC.dataConUserType dataCon) @@ -214,15 +216,15 @@ | null labels = ppr_bndr dataCon <+> sep (map pprParendBangTy fields) | otherwise - = ppr_bndr dataCon <+> - braces (sep (punctuate comma (ppr_trim maybe_show_label + = ppr_bndr dataCon <+> + braces (sep (punctuate comma (ppr_trim maybe_show_label (zip labels fields)))) pprClass :: PrintExplicitForalls -> ShowMe -> GHC.Class -> SDoc pprClass pefas show_me cls | null methods = pprClassHdr pefas cls - | otherwise + | otherwise = hang (pprClassHdr pefas cls <+> ptext (sLit "where")) 2 (vcat (ppr_trim show_meth methods)) where @@ -237,7 +239,7 @@ -- Here's the magic incantation to strip off the dictionary -- from the class op type. Stolen from IfaceSyn.tyThingToIfaceDecl. -- - -- It's important to tidy it *before* splitting it up, so that if + -- It's important to tidy it *before* splitting it up, so that if -- we have class C a b where -- op :: forall a. a -> b -- then the inner forall on op gets renamed to a1, and we print @@ -268,7 +270,7 @@ ppr_bndr a = GHC.pprParenSymName a showWithLoc :: SDoc -> SDoc -> SDoc -showWithLoc loc doc +showWithLoc loc doc = hang doc 2 (char '\t' <> comment <+> loc) -- The tab tries to make them line up a bit where diff -Nru ghc-7.0.3/compiler/main/StaticFlagParser.hs ghc-7.2.1/compiler/main/StaticFlagParser.hs --- ghc-7.0.3/compiler/main/StaticFlagParser.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/main/StaticFlagParser.hs 2011-08-07 17:10:05.000000000 +0000 @@ -50,7 +50,7 @@ ready <- readIORef v_opt_C_ready when ready $ ghcError (ProgramError "Too late for parseStaticFlags: call it before newSession") - (leftover, errs, warns1) <- processArgs static_flags args + (leftover, errs, warns1) <- processArgs static_flags args CmdLineOnly True when (not (null errs)) $ ghcError $ errorsToGhcException errs -- deal with the way flags: the way (eg. prof) gives rise to @@ -62,7 +62,8 @@ let unreg_flags | cGhcUnregisterised == "YES" = unregFlags | otherwise = [] - (more_leftover, errs, warns2) <- processArgs static_flags (unreg_flags ++ way_flags') + (more_leftover, errs, warns2) <- + processArgs static_flags (unreg_flags ++ way_flags') CmdLineOnly True -- see sanity code in staticOpts writeIORef v_opt_C_ready True @@ -103,59 +104,65 @@ static_flags = [ ------- GHCi ------------------------------------------------------- - Flag "ignore-dot-ghci" (PassFlag addOpt) - , Flag "read-dot-ghci" (NoArg (removeOpt "-ignore-dot-ghci")) + flagC "ignore-dot-ghci" (PassFlag addOpt) + , flagC "read-dot-ghci" (NoArg (removeOpt "-ignore-dot-ghci")) ------- ways -------------------------------------------------------- - , Flag "prof" (NoArg (addWay WayProf)) - , Flag "eventlog" (NoArg (addWay WayEventLog)) - , Flag "parallel" (NoArg (addWay WayPar)) - , Flag "gransim" (NoArg (addWay WayGran)) - , Flag "smp" (NoArg (addWay WayThreaded >> deprecate "Use -threaded instead")) - , Flag "debug" (NoArg (addWay WayDebug)) - , Flag "ndp" (NoArg (addWay WayNDP)) - , Flag "threaded" (NoArg (addWay WayThreaded)) + , flagC "prof" (NoArg (addWay WayProf)) + , flagC "eventlog" (NoArg (addWay WayEventLog)) + , flagC "parallel" (NoArg (addWay WayPar)) + , flagC "gransim" (NoArg (addWay WayGran)) + , flagC "smp" (NoArg (addWay WayThreaded >> deprecate "Use -threaded instead")) + , flagC "debug" (NoArg (addWay WayDebug)) + , flagC "ndp" (NoArg (addWay WayNDP)) + , flagC "threaded" (NoArg (addWay WayThreaded)) - , Flag "ticky" (PassFlag (\f -> do addOpt f; addWay WayDebug)) + , flagC "ticky" (PassFlag (\f -> do addOpt f; addWay WayDebug)) -- -ticky enables ticky-ticky code generation, and also implies -debug which -- is required to get the RTS ticky support. ------ Debugging ---------------------------------------------------- - , Flag "dppr-debug" (PassFlag addOpt) - , Flag "dsuppress-uniques" (PassFlag addOpt) - , Flag "dsuppress-coercions" (PassFlag addOpt) - , Flag "dsuppress-module-prefixes" (PassFlag addOpt) - , Flag "dppr-user-length" (AnySuffix addOpt) - , Flag "dopt-fuel" (AnySuffix addOpt) - , Flag "dtrace-level" (AnySuffix addOpt) - , Flag "dno-debug-output" (PassFlag addOpt) - , Flag "dstub-dead-values" (PassFlag addOpt) + , flagC "dppr-debug" (PassFlag addOpt) + , flagC "dppr-cols" (AnySuffix addOpt) + , flagC "dppr-user-length" (AnySuffix addOpt) + , flagC "dppr-case-as-let" (PassFlag addOpt) + , flagC "dsuppress-all" (PassFlag addOpt) + , flagC "dsuppress-uniques" (PassFlag addOpt) + , flagC "dsuppress-coercions" (PassFlag addOpt) + , flagC "dsuppress-module-prefixes" (PassFlag addOpt) + , flagC "dsuppress-type-applications" (PassFlag addOpt) + , flagC "dsuppress-idinfo" (PassFlag addOpt) + , flagC "dsuppress-type-signatures" (PassFlag addOpt) + , flagC "dopt-fuel" (AnySuffix addOpt) + , flagC "dtrace-level" (AnySuffix addOpt) + , flagC "dno-debug-output" (PassFlag addOpt) + , flagC "dstub-dead-values" (PassFlag addOpt) -- rest of the debugging flags are dynamic ----- Linker -------------------------------------------------------- - , Flag "static" (PassFlag addOpt) - , Flag "dynamic" (NoArg (removeOpt "-static" >> addWay WayDyn)) + , flagC "static" (PassFlag addOpt) + , flagC "dynamic" (NoArg (removeOpt "-static" >> addWay WayDyn)) -- ignored for compat w/ gcc: - , Flag "rdynamic" (NoArg (return ())) + , flagC "rdynamic" (NoArg (return ())) ----- RTS opts ------------------------------------------------------ - , Flag "H" (HasArg (\s -> liftEwM (setHeapSize (fromIntegral (decodeSize s))))) + , flagC "H" (HasArg (\s -> liftEwM (setHeapSize (fromIntegral (decodeSize s))))) - , Flag "Rghc-timing" (NoArg (liftEwM enableTimingStats)) + , flagC "Rghc-timing" (NoArg (liftEwM enableTimingStats)) ------ Compiler flags ----------------------------------------------- -- -fPIC requires extra checking: only the NCG supports it. -- See also DynFlags.parseDynamicFlags. - , Flag "fPIC" (PassFlag setPIC) + , flagC "fPIC" (PassFlag setPIC) -- All other "-fno-" options cancel out "-f" on the hsc cmdline - , Flag "fno-" + , flagC "fno-" (PrefixPred (\s -> isStaticFlag ("f"++s)) (\s -> removeOpt ("-f"++s))) -- Pass all remaining "-f" options to hsc - , Flag "f" (AnySuffixPred isStaticFlag addOpt) + , flagC "f" (AnySuffixPred isStaticFlag addOpt) ] setPIC :: String -> StaticP () @@ -177,9 +184,9 @@ "dno-black-holing", "fno-state-hack", "fsimple-list-literals", - "fno-ds-multi-tyvar", "fruntime-types", "fno-pre-inlining", + "fno-opt-coercion", "fexcess-precision", "static", "fhardwire-lib-paths", @@ -204,7 +211,6 @@ unregFlags = map (mkGeneralLocated "in unregFlags") [ "-optc-DNO_REGS" , "-optc-DUSE_MINIINTERPRETER" - , "-fno-asm-mangling" , "-funregisterised" ] ----------------------------------------------------------------------------- diff -Nru ghc-7.0.3/compiler/main/StaticFlags.hs ghc-7.2.1/compiler/main/StaticFlags.hs --- ghc-7.0.3/compiler/main/StaticFlags.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/main/StaticFlags.hs 2011-08-07 17:10:05.000000000 +0000 @@ -21,11 +21,19 @@ -- Output style options opt_PprUserLength, + opt_PprCols, + opt_PprCaseAsLet, + opt_PprStyle_Debug, opt_TraceLevel, + opt_NoDebugOutput, + + -- Suppressing boring aspects of core dumps + opt_SuppressAll, opt_SuppressUniques, opt_SuppressCoercions, opt_SuppressModulePrefixes, - opt_PprStyle_Debug, opt_TraceLevel, - opt_NoDebugOutput, + opt_SuppressTypeApplications, + opt_SuppressIdInfo, + opt_SuppressTypeSignatures, -- profiling opts opt_SccProfilingOn, @@ -39,12 +47,12 @@ opt_Parallel, -- optimisation opts - opt_DsMultiTyVar, opt_NoStateHack, opt_SimpleListLiterals, opt_CprOff, opt_SimplNoPreInlining, opt_SimplExcessPrecision, + opt_NoOptCoercion, opt_MaxWorkerArgs, -- Unfolding control @@ -64,6 +72,7 @@ -- misc opts opt_IgnoreDotGhci, + opt_GhciScripts, opt_ErrorSpans, opt_GranMacros, opt_HiVersion, @@ -76,7 +85,10 @@ opt_Ticky, -- For the parser - addOpt, removeOpt, addWay, getWayFlags, v_opt_C_ready + addOpt, removeOpt, addWay, getWayFlags, v_opt_C_ready, + + -- Saving/restoring globals + saveStaticFlagGlobals, restoreStaticFlagGlobals ) where #include "HsVersions.h" @@ -84,9 +96,10 @@ import Config import FastString import Util -import Maybes ( firstJusts ) +import Maybes ( firstJusts, catMaybes ) import Panic +import Control.Monad ( liftM3 ) import Data.Maybe ( listToMaybe ) import Data.IORef import System.IO.Unsafe ( unsafePerformIO ) @@ -113,6 +126,7 @@ lookup_def_int :: String -> Int -> Int lookup_def_float :: String -> Float -> Float lookup_str :: String -> Maybe String +lookup_all_str :: String -> [String] -- holds the static opts while they're being collected, before -- being unsafely read by unpacked_static_opts below. @@ -143,6 +157,10 @@ Just str -> Just str Nothing -> Nothing +lookup_all_str sw = map f $ catMaybes (map (stripPrefix sw) staticFlags) where + f ('=' : str) = str + f str = str + lookup_def_int sw def = case (lookup_str sw) of Nothing -> def -- Use default Just xx -> try_read sw xx @@ -159,7 +177,7 @@ = 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. @@ -181,16 +199,72 @@ opt_IgnoreDotGhci :: Bool opt_IgnoreDotGhci = lookUp (fsLit "-ignore-dot-ghci") + +opt_GhciScripts :: [String] +opt_GhciScripts = lookup_all_str "-ghci-script" + +-- 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") --- debugging opts -opt_SuppressUniques :: Bool -opt_SuppressUniques = lookUp (fsLit "-dsuppress-uniques") - +-- | Suppress all coercions, them replacing with '...' opt_SuppressCoercions :: Bool -opt_SuppressCoercions = lookUp (fsLit "-dsuppress-coercions") +opt_SuppressCoercions + = lookUp (fsLit "-dsuppress-all") + || lookUp (fsLit "-dsuppress-coercions") +-- | Suppress module id prefixes on variables. opt_SuppressModulePrefixes :: Bool -opt_SuppressModulePrefixes = lookUp (fsLit "-dsuppress-module-prefixes") +opt_SuppressModulePrefixes + = lookUp (fsLit "-dsuppress-all") + || lookUp (fsLit "-dsuppress-module-prefixes") + +-- | Suppress type applications. +opt_SuppressTypeApplications :: Bool +opt_SuppressTypeApplications + = lookUp (fsLit "-dsuppress-all") + || lookUp (fsLit "-dsuppress-type-applications") + +-- | Suppress info such as arity and unfoldings on identifiers. +opt_SuppressIdInfo :: Bool +opt_SuppressIdInfo + = lookUp (fsLit "-dsuppress-all") + || lookUp (fsLit "-dsuppress-idinfo") + +-- | Suppress separate type signatures in core, but leave types on lambda bound vars +opt_SuppressTypeSignatures :: Bool +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") + +-- | Set the maximum width of the dumps +-- If GHC's command line options are bad then the options parser uses the +-- pretty printer display the error message. In this case the staticFlags +-- won't be initialized yet, so we must check for this case explicitly +-- and return the default value. +opt_PprCols :: Int +opt_PprCols + = unsafePerformIO + $ do ready <- readIORef v_opt_C_ready + if (not ready) + then return 100 + else return $ lookup_def_int "-dppr-cols" 100 + opt_PprStyle_Debug :: Bool opt_PprStyle_Debug = lookUp (fsLit "-dppr-debug") @@ -208,7 +282,6 @@ opt_NoDebugOutput :: Bool opt_NoDebugOutput = lookUp (fsLit "-dno-debug-output") - -- profiling opts opt_SccProfilingOn :: Bool opt_SccProfilingOn = lookUp (fsLit "-fscc-profiling") @@ -227,11 +300,6 @@ opt_Parallel :: Bool opt_Parallel = lookUp (fsLit "-fparallel") --- optimisation opts -opt_DsMultiTyVar :: Bool -opt_DsMultiTyVar = not (lookUp (fsLit "-fno-ds-multi-tyvar")) - -- On by default - opt_SimpleListLiterals :: Bool opt_SimpleListLiterals = lookUp (fsLit "-fsimple-list-literals") @@ -267,6 +335,9 @@ opt_SimplExcessPrecision :: Bool opt_SimplExcessPrecision = lookUp (fsLit "-fexcess-precision") +opt_NoOptCoercion :: Bool +opt_NoOptCoercion = lookUp (fsLit "-fno-opt-coercion") + -- Unfolding control -- See Note [Discounts and thresholds] in CoreUnfold @@ -274,16 +345,16 @@ opt_UF_DearOp, opt_UF_FunAppDiscount, opt_UF_DictDiscount :: Int opt_UF_KeenessFactor :: Float -opt_UF_CreationThreshold = lookup_def_int "-funfolding-creation-threshold" (45::Int) -opt_UF_UseThreshold = lookup_def_int "-funfolding-use-threshold" (6::Int) -opt_UF_FunAppDiscount = lookup_def_int "-funfolding-fun-discount" (6::Int) +opt_UF_CreationThreshold = lookup_def_int "-funfolding-creation-threshold" (450::Int) +opt_UF_UseThreshold = lookup_def_int "-funfolding-use-threshold" (60::Int) +opt_UF_FunAppDiscount = lookup_def_int "-funfolding-fun-discount" (60::Int) -opt_UF_DictDiscount = lookup_def_int "-funfolding-dict-discount" (3::Int) +opt_UF_DictDiscount = lookup_def_int "-funfolding-dict-discount" (30::Int) -- Be fairly keen to inline a fuction if that means -- we'll be able to pick the right method from a dictionary opt_UF_KeenessFactor = lookup_def_float "-funfolding-keeness-factor" (1.5::Float) -opt_UF_DearOp = ( 4 :: Int) +opt_UF_DearOp = ( 40 :: Int) -- Related to linking @@ -495,3 +566,21 @@ [ "-XParr" , "-fvectorise"] ] + +----------------------------------------------------------------------------- +-- Tunneling our global variables into a new instance of the GHC library + +-- Ignore the v_Ld_inputs global because: +-- a) It is mutated even once GHC has been initialised, which means that I'd +-- have to add another layer of indirection to truly share the value +-- b) We can get away without sharing it because it only affects the link, +-- and is mutated by the GHC exe. Users who load up a new copy of the GHC +-- library while another is running almost certainly won't actually access it. +saveStaticFlagGlobals :: IO (Bool, [String], [Way]) +saveStaticFlagGlobals = liftM3 (,,) (readIORef v_opt_C_ready) (readIORef v_opt_C) (readIORef v_Ways) + +restoreStaticFlagGlobals :: (Bool, [String], [Way]) -> IO () +restoreStaticFlagGlobals (c_ready, c, ways) = do + writeIORef v_opt_C_ready c_ready + writeIORef v_opt_C c + writeIORef v_Ways ways diff -Nru ghc-7.0.3/compiler/main/SysTools.lhs ghc-7.2.1/compiler/main/SysTools.lhs --- ghc-7.0.3/compiler/main/SysTools.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/main/SysTools.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -7,6 +7,7 @@ ----------------------------------------------------------------------------- \begin{code} +{-# OPTIONS -fno-warn-unused-do-bind #-} module SysTools ( -- Initialisation initSysTools, @@ -14,17 +15,18 @@ -- Interface to system tools runUnlit, runCpp, runCc, -- [Option] -> IO () runPp, -- [Option] -> IO () - runMangle, runSplit, -- [Option] -> IO () + runSplit, -- [Option] -> IO () runAs, runLink, -- [Option] -> IO () runMkDLL, runWindres, runLlvmOpt, runLlvmLlc, + figureLlvmVersion, + readElfSection, touch, -- String -> String -> IO () copy, copyWithHeader, - getExtraViaCOpts, -- Temporary-file management setTmpDir, @@ -45,8 +47,9 @@ import Panic import Util import DynFlags - +import StaticFlags import Exception + import Data.IORef import Control.Monad import System.Exit @@ -58,6 +61,8 @@ import Data.Char import Data.List import qualified Data.Map as Map +import Text.ParserCombinators.ReadP hiding (char) +import qualified Text.ParserCombinators.ReadP as R #ifndef mingw32_HOST_OS import qualified System.Posix.Internals @@ -66,7 +71,7 @@ import Foreign.C.String #endif -import System.Process ( runInteractiveProcess, getProcessExitCode ) +import System.Process import Control.Concurrent import FastString import SrcLoc ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan ) @@ -144,24 +149,47 @@ \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 $ case stripPrefix "$topdir" xs of + Just [] -> + top_dir + Just xs'@(c:_) + | isPathSeparator c -> + top_dir ++ xs' + _ -> + 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 <- getSetting "C compiler command" + ; gcc_args_str <- getSetting "C compiler flags" + ; let gcc_args = map Option (words gcc_args_str) + ; perl_path <- getSetting "perl command" ; let pkgconfig_path = installed "package.conf.d" ghc_usage_msg_path = installed "ghc-usage.txt" @@ -171,30 +199,17 @@ -- architecture-specific stuff is done when building Config.hs unlit_path = installed cGHC_UNLIT_PGM - -- split and mangle are Perl scripts + -- split is a Perl script split_script = installed cGHC_SPLIT_PGM - mangle_script = installed cGHC_MANGLER_PGM - windres_path = installed_mingw_bin "windres" + ; windres_path <- getSetting "windres command" ; 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 - | otherwise = "touch" - -- On Win32 we don't want to rely on #!/bin/perl, so we prepend - -- a call to Perl to get the invocation of split and mangle. + ; touch_path <- getSetting "touch command" + + ; let -- On Win32 we don't want to rely on #!/bin/perl, so we prepend + -- a call to Perl to get the invocation of split. -- On Unix, scripts are invoked using the '#!' method. Binary -- installations of GHC on Unix place the correct line on the -- front of the script at installation time, so we don't want @@ -202,50 +217,62 @@ (split_prog, split_args) | isWindowsHost = (perl_path, [Option split_script]) | otherwise = (split_script, []) - (mangle_prog, mangle_args) - | isWindowsHost = (perl_path, [Option mangle_script]) - | otherwise = (mangle_script, []) - (mkdll_prog, mkdll_args) - | not isWindowsHost - = panic "Can't build DLLs on a non-Win32 system" - | otherwise = - (installed_mingw_bin cMKDLL, []) + ; mkdll_prog <- getSetting "dllwrap command" + ; let mkdll_args = [] -- cpp is derived from gcc on all platforms -- HACK, see setPgmP below. We keep 'words' here to remember to fix -- Config.hs one day. - ; let cpp_path = (gcc_prog, - (Option "-E"):(map Option (words cRAWCPP_FLAGS))) + ; let cpp_prog = gcc_prog + cpp_args = Option "-E" + : map Option (words cRAWCPP_FLAGS) + ++ gcc_args -- Other things being equal, as and ld are simply gcc ; let as_prog = gcc_prog + as_args = gcc_args ld_prog = gcc_prog + ld_args = gcc_args - -- figure out llvm location. (TODO: Acutally implement). + -- We just assume on command line ; 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_m = (mangle_prog,mangle_args), - 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_prog, cpp_args), + sPgm_F = "", + sPgm_c = (gcc_prog, gcc_args), + sPgm_s = (split_prog,split_args), + sPgm_a = (as_prog, as_args), + sPgm_l = (ld_prog, ld_args), + 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_l = [], + sOpt_windres = [], + sOpt_lo = [], + sOpt_lc = [] } } \end{code} @@ -372,11 +399,6 @@ = (path, '\"' : head b_dirs ++ "\";" ++ paths) mangle_path other = other -runMangle :: DynFlags -> [Option] -> IO () -runMangle dflags args = do - let (p,args0) = pgm_m dflags - runSomething dflags "Mangler" p (args0++args) - runSplit :: DynFlags -> [Option] -> IO () runSplit dflags args = do let (p,args0) = pgm_s dflags @@ -389,16 +411,56 @@ mb_env <- getGccEnv args1 runSomethingFiltered dflags id "Assembler" p args1 mb_env +-- | Run the LLVM Optimiser runLlvmOpt :: DynFlags -> [Option] -> IO () runLlvmOpt dflags args = do let (p,args0) = pgm_lo dflags runSomething dflags "LLVM Optimiser" p (args0++args) +-- | Run the LLVM Compiler runLlvmLlc :: DynFlags -> [Option] -> IO () runLlvmLlc dflags args = do let (p,args0) = pgm_lc dflags runSomething dflags "LLVM Compiler" p (args0++args) +-- | Figure out which version of LLVM we are running this session +figureLlvmVersion :: DynFlags -> IO (Maybe Int) +figureLlvmVersion dflags = do + let (pgm,opts) = pgm_lc dflags + args = filter notNull (map showOpt opts) + -- we grab the args even though they should be useless just in + -- case the user is using a customised 'llc' that requires some + -- of the options they've specified. llc doesn't care what other + -- options are specified when '-version' is used. + args' = args ++ ["-version"] + ver <- catchIO (do + (pin, pout, perr, _) <- runInteractiveProcess pgm args' + Nothing Nothing + {- > llc -version + Low Level Virtual Machine (http://llvm.org/): + llvm version 2.8 (Ubuntu 2.8-0Ubuntu1) + ... + -} + hSetBinaryMode pout False + _ <- hGetLine pout + vline <- hGetLine pout + v <- case filter isDigit vline of + [] -> fail "no digits!" + [x] -> fail $ "only 1 digit! (" ++ show x ++ ")" + (x:y:_) -> return ((read [x,y]) :: Int) + hClose pin + hClose pout + hClose perr + return $ Just v + ) + (\err -> do + putMsg dflags $ text $ "Error (" ++ show err ++ ")" + putMsg dflags $ text "Warning: Couldn't figure out LLVM version!" + putMsg dflags $ text "Make sure you have installed LLVM" + return Nothing) + return ver + + runLink :: DynFlags -> [Option] -> IO () runLink dflags args = do let (p,args0) = pgm_l dflags @@ -454,10 +516,26 @@ 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) +readElfSection _dflags section exe = do + let + prog = "readelf" + args = [Option "-p", Option section, FileOption "" exe] + -- + r <- readProcessWithExitCode prog (filter notNull (map showOpt args)) "" + case r of + (ExitSuccess, out, _err) -> return (doFilter (lines out)) + _ -> return Nothing + where + doFilter [] = Nothing + doFilter (s:r) = case readP_to_S parse s of + [(p,"")] -> Just p + _r -> doFilter r + where parse = do + skipSpaces; R.char '['; skipSpaces; string "0]"; skipSpaces; + munch (const True) \end{code} %************************************************************************ @@ -489,8 +567,8 @@ $ do let ref = filesToClean dflags files <- readIORef ref let (to_keep, to_delete) = partition (`elem` dont_delete) files - removeTmpFiles dflags to_delete writeIORef ref to_keep + removeTmpFiles dflags to_delete -- find a temporary name that doesn't already exist. @@ -512,8 +590,9 @@ -- 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 -> @@ -528,7 +607,7 @@ writeIORef ref mapping' debugTraceMsg dflags 2 (ptext (sLit "Created temporary directory:") <+> text dirname) return dirname - `IO.catch` \e -> + `catchIO` \e -> if isAlreadyExistsError e then mkTempDir (x+1) else ioError e @@ -567,7 +646,7 @@ (non_deletees, deletees) = partition isHaskellUserSrcFilename fs removeWith :: DynFlags -> (FilePath -> IO ()) -> FilePath -> IO () -removeWith dflags remover f = remover f `IO.catch` +removeWith dflags remover f = remover f `catchIO` (\e -> let msg = if isDoesNotExistError e then ptext (sLit "Warning: deleting non-existent") <+> text f @@ -597,9 +676,14 @@ runSomethingFiltered dflags filter_fn phase_name pgm args mb_env = do let real_args = filter notNull (map showOpt args) - traceCmd dflags phase_name (unwords (pgm:real_args)) $ do +#if __GLASGOW_HASKELL__ >= 701 + cmdLine = showCommandForUser pgm real_args +#else + cmdLine = unwords (pgm:real_args) +#endif + traceCmd dflags phase_name cmdLine $ do (exit_code, doesn'tExist) <- - IO.catch (do + catchIO (do rc <- builderMainLoop dflags filter_fn pgm real_args mb_env case rc of ExitSuccess{} -> return (rc, False) @@ -739,20 +823,16 @@ | EOF traceCmd :: DynFlags -> String -> String -> IO () -> IO () --- a) trace the command (at two levels of verbosity) --- b) don't do it at all if dry-run is set +-- trace the command (at two levels of verbosity) traceCmd dflags phase_name cmd_line action = do { let verb = verbosity dflags ; showPass dflags phase_name ; debugTraceMsg dflags 3 (text cmd_line) ; hFlush stderr - -- Test for -n flag - ; unless (dopt Opt_DryRun dflags) $ do { - -- And run it! - ; action `IO.catch` handle_exn verb - }} + ; action `catchIO` handle_exn verb + } where handle_exn _verb exn = do { debugTraceMsg dflags 2 (char '\n') ; debugTraceMsg dflags 2 (ptext (sLit "Failed:") <+> text cmd_line <+> text (show exn)) @@ -773,14 +853,15 @@ #if defined(mingw32_HOST_OS) -- Assuming we are running ghc, accessed by path $(stuff)/bin/ghc.exe, -- return the path $(stuff)/lib. -getBaseDir = do let len = (2048::Int) -- plenty, PATH_MAX is 512 under Win32. - buf <- mallocArray len - ret <- getModuleFileName nullPtr buf len - if ret == 0 then free buf >> return Nothing - else do s <- peekCString buf - free buf - return (Just (rootDir s)) +getBaseDir = try_size 2048 -- plenty, PATH_MAX is 512 under Win32. where + try_size size = allocaArray (fromIntegral size) $ \buf -> do + ret <- c_GetModuleFileName nullPtr buf size + case ret of + 0 -> return Nothing + _ | ret < size -> fmap (Just . rootDir) $ peekCWString buf + | otherwise -> try_size (size * 2) + rootDir s = case splitFileName $ normalise s of (d, ghc_exe) | lower ghc_exe `elem` ["ghc.exe", @@ -795,8 +876,8 @@ where fail = panic ("can't decompose ghc.exe path: " ++ show s) lower = map toLower -foreign import stdcall unsafe "GetModuleFileNameA" - getModuleFileName :: Ptr () -> CString -> Int -> IO Int32 +foreign import stdcall unsafe "windows.h GetModuleFileNameW" + c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32 #else getBaseDir = return Nothing #endif diff -Nru ghc-7.0.3/compiler/main/TidyPgm.lhs ghc-7.2.1/compiler/main/TidyPgm.lhs --- ghc-7.0.3/compiler/main/TidyPgm.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/main/TidyPgm.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -46,6 +46,7 @@ import Util import FastString +import Control.Monad ( when ) import Data.List ( sortBy ) import Data.IORef ( IORef, readIORef, writeIORef ) \end{code} @@ -291,8 +292,7 @@ mg_binds = binds, mg_rules = imp_rules, mg_vect_info = vect_info, - mg_dir_imps = dir_imps, - mg_anns = anns, + mg_anns = anns, mg_deps = deps, mg_foreign = foreign_stubs, mg_hpc_info = hpc_info, @@ -353,15 +353,21 @@ (ptext (sLit "rules")) (pprRulesForUser tidy_rules) - ; let dir_imp_mods = moduleEnvKeys dir_imps - - ; return (CgGuts { cg_module = mod, - cg_tycons = alg_tycons, - cg_binds = all_tidy_binds, - cg_dir_imps = dir_imp_mods, - cg_foreign = foreign_stubs, - cg_dep_pkgs = dep_pkgs deps, - cg_hpc_info = hpc_info, + -- Print one-line size info + ; let cs = coreBindsStats tidy_binds + ; when (dopt Opt_D_dump_core_stats dflags) + (printDump (ptext (sLit "Tidy size (terms,types,coercions)") + <+> ppr (moduleName mod) <> colon + <+> int (cs_tm cs) + <+> int (cs_ty cs) + <+> int (cs_co cs) )) + + ; return (CgGuts { cg_module = mod, + cg_tycons = alg_tycons, + cg_binds = all_tidy_binds, + cg_foreign = foreign_stubs, + cg_dep_pkgs = map fst $ dep_pkgs deps, + cg_hpc_info = hpc_info, cg_modBreaks = modBreaks }, ModDetails { md_types = tidy_type_env, @@ -481,12 +487,16 @@ \begin{code} tidyVectInfo :: TidyEnv -> VectInfo -> VectInfo -tidyVectInfo (_, var_env) info@(VectInfo { vectInfoVar = vars - , vectInfoPADFun = pas - , vectInfoIso = isos }) - = info { vectInfoVar = tidy_vars - , vectInfoPADFun = tidy_pas - , vectInfoIso = tidy_isos } +tidyVectInfo (_, var_env) info@(VectInfo { vectInfoVar = vars + , vectInfoPADFun = pas + , vectInfoIso = isos + , vectInfoScalarVars = scalarVars + }) + = info { vectInfoVar = tidy_vars + , vectInfoPADFun = tidy_pas + , vectInfoIso = tidy_isos + , vectInfoScalarVars = tidy_scalarVars + } where tidy_vars = mkVarEnv $ map tidy_var_mapping @@ -498,6 +508,10 @@ tidy_var_mapping (from, to) = (from', (from', lookup_var to)) where from' = lookup_var from tidy_snd_var (x, var) = (x, lookup_var var) + + tidy_scalarVars = mkVarSet + $ map lookup_var + $ varSetElems scalarVars lookup_var var = lookupWithDefaultVarEnv var_env var var \end{code} @@ -687,111 +701,142 @@ let unfold_env' = extendVarEnv unfold_env id (name',False) tidy_internal ids unfold_env' occ_env' -addExternal :: Bool -> Id -> ([Id],Bool) +addExternal :: Bool -> Id -> ([Id], Bool) addExternal expose_all id = (new_needed_ids, show_unfold) where - new_needed_ids = unfold_ids ++ - filter (\id -> isLocalId id && - not (id `elemVarSet` unfold_set)) - (varSetElems spec_ids) -- XXX non-det ordering - + new_needed_ids = bndrFvsInOrder show_unfold id idinfo = idInfo id + show_unfold = show_unfolding (unfoldingInfo idinfo) never_active = isNeverActive (inlinePragmaActivation (inlinePragInfo idinfo)) - loop_breaker = isNonRuleLoopBreaker (occInfo idinfo) + loop_breaker = isStrongLoopBreaker (occInfo idinfo) bottoming_fn = isBottomingSig (strictnessInfo idinfo `orElse` topSig) - spec_ids = specInfoFreeVars (specInfo idinfo) -- Stuff to do with the Id's unfolding -- We leave the unfolding there even if there is a worker - -- In GHCI the unfolding is used by importers - show_unfold = isJust mb_unfold_ids - (unfold_set, unfold_ids) = mb_unfold_ids `orElse` (emptyVarSet, []) - - mb_unfold_ids :: Maybe (IdSet, [Id]) -- Nothing => don't unfold - mb_unfold_ids = case unfoldingInfo idinfo of - CoreUnfolding { uf_tmpl = unf_rhs, uf_src = src, uf_guidance = guide } - | show_unfolding src guide - -> Just (unf_ext_ids src unf_rhs) - DFunUnfolding _ _ ops -> Just (exprsFvsInOrder (dfunArgExprs ops)) - _ -> Nothing - where - unf_ext_ids (InlineWrapper v) _ = (unitVarSet v, [v]) - unf_ext_ids _ unf_rhs = exprFvsInOrder unf_rhs - -- For a wrapper, externalise the wrapper id rather than the - -- fvs of the rhs. The two usually come down to the same thing - -- but I've seen cases where we had a wrapper id $w but a - -- rhs where $w had been inlined; see Trac #3922 + -- In GHCi the unfolding is used by importers - show_unfolding unf_source unf_guidance + show_unfolding (CoreUnfolding { uf_src = src, uf_guidance = guidance }) = expose_all -- 'expose_all' says to expose all -- unfoldings willy-nilly - || isStableSource unf_source -- Always expose things whose - -- source is an inline rule + || isStableSource src -- Always expose things whose + -- source is an inline rule || not (bottoming_fn -- No need to inline bottom functions || never_active -- Or ones that say not to || loop_breaker -- Or that are loop breakers - || neverUnfoldGuidance unf_guidance) - --- We want a deterministic free-variable list. exprFreeVars gives us --- a VarSet, which is in a non-deterministic order when converted to a --- list. Hence, here we define a free-variable finder that returns --- the free variables in the order that they are encountered. --- --- Note [choosing external names] + || neverUnfoldGuidance guidance) + show_unfolding (DFunUnfolding {}) = True + show_unfolding _ = False +\end{code} -exprFvsInOrder :: CoreExpr -> (VarSet, [Id]) -exprFvsInOrder e = run (dffvExpr e) +%************************************************************************ +%* * + Deterministic free variables +%* * +%************************************************************************ -exprsFvsInOrder :: [CoreExpr] -> (VarSet, [Id]) -exprsFvsInOrder es = run (mapM_ dffvExpr es) +We want a deterministic free-variable list. exprFreeVars gives us +a VarSet, which is in a non-deterministic order when converted to a +list. Hence, here we define a free-variable finder that returns +the free variables in the order that they are encountered. -run :: DFFV () -> (VarSet, [Id]) -run (DFFV m) = case m emptyVarSet [] of - (set,ids,_) -> (set,ids) +Note [choosing external names] -newtype DFFV a = DFFV (VarSet -> [Var] -> (VarSet,[Var],a)) +\begin{code} +bndrFvsInOrder :: Bool -> Id -> [Id] +bndrFvsInOrder show_unfold id + = run (dffvLetBndr show_unfold id) + +run :: DFFV () -> [Id] +run (DFFV m) = case m emptyVarSet (emptyVarSet, []) of + ((_,ids),_) -> ids + +newtype DFFV a + = DFFV (VarSet -- Envt: non-top-level things that are in scope + -- we don't want to record these as free vars + -> (VarSet, [Var]) -- Input State: (set, list) of free vars so far + -> ((VarSet,[Var]),a)) -- Output state instance Monad DFFV where - return a = DFFV $ \set ids -> (set, ids, a) - (DFFV m) >>= k = DFFV $ \set ids -> - case m set ids of - (set',ids',a) -> case k a of - DFFV f -> f set' ids' + return a = DFFV $ \_ st -> (st, a) + (DFFV m) >>= k = DFFV $ \env st -> + case m env st of + (st',a) -> case k a of + DFFV f -> f env st' + +extendScope :: Var -> DFFV a -> DFFV a +extendScope v (DFFV f) = DFFV (\env st -> f (extendVarSet env v) st) + +extendScopeList :: [Var] -> DFFV a -> DFFV a +extendScopeList vs (DFFV f) = DFFV (\env st -> f (extendVarSetList env vs) st) insert :: Var -> DFFV () -insert v = DFFV $ \ set ids -> case () of - _ | v `elemVarSet` set -> (set,ids,()) - | otherwise -> (extendVarSet set v, v:ids, ()) +insert v = DFFV $ \ env (set, ids) -> + let keep_me = isLocalId v && + not (v `elemVarSet` env) && + not (v `elemVarSet` set) + in if keep_me + then ((extendVarSet set v, v:ids), ()) + else ((set, ids), ()) + dffvExpr :: CoreExpr -> DFFV () -dffvExpr e = go emptyVarSet e +dffvExpr (Var v) = insert v +dffvExpr (App e1 e2) = dffvExpr e1 >> dffvExpr e2 +dffvExpr (Lam v e) = extendScope v (dffvExpr e) +dffvExpr (Note _ e) = dffvExpr e +dffvExpr (Cast e _) = dffvExpr e +dffvExpr (Let (NonRec x r) e) = dffvBind (x,r) >> extendScope x (dffvExpr e) +dffvExpr (Let (Rec prs) e) = extendScopeList (map fst prs) $ + (mapM_ dffvBind prs >> dffvExpr e) +dffvExpr (Case e b _ as) = dffvExpr e >> extendScope b (mapM_ dffvAlt as) +dffvExpr _other = return () + +dffvAlt :: (t, [Var], CoreExpr) -> DFFV () +dffvAlt (_,xs,r) = extendScopeList xs (dffvExpr r) + +dffvBind :: (Id, CoreExpr) -> DFFV () +dffvBind(x,r) = dffvLetBndr True x >> dffvExpr r + +dffvLetBndr :: Bool -> Id -> DFFV () +dffvLetBndr show_unfold id + | not (isId id) = return () + | otherwise + = do { when show_unfold (go_unf (unfoldingInfo idinfo)) + ; extendScope id $ -- See Note [Rule free var hack] in CoreFVs + mapM_ go_rule (specInfoRules (specInfo idinfo)) } where - go scope e = case e of - Var v | isLocalId v && not (v `elemVarSet` scope) -> insert v - App e1 e2 -> do go scope e1; go scope e2 - Lam v e -> go (extendVarSet scope v) e - Note _ e -> go scope e - Cast e _ -> go scope e - Let (NonRec x r) e -> do go scope r; go (extendVarSet scope x) e - Let (Rec prs) e -> do let scope' = extendVarSetList scope (map fst prs) - mapM_ (go scope') (map snd prs) - go scope' e - Case e b _ as -> do go scope e - mapM_ (go_alt (extendVarSet scope b)) as - _other -> return () + idinfo = idInfo id - go_alt scope (_,xs,r) = go (extendVarSetList scope xs) r + go_unf (CoreUnfolding { uf_tmpl = rhs, uf_src = src }) + = case src of + InlineWrapper v -> insert v + _ -> dffvExpr rhs + -- For a wrapper, externalise the wrapper id rather than the + -- fvs of the rhs. The two usually come down to the same thing + -- but I've seen cases where we had a wrapper id $w but a + -- rhs where $w had been inlined; see Trac #3922 + + go_unf (DFunUnfolding _ _ args) = mapM_ dffvExpr args + go_unf _ = return () + + go_rule (BuiltinRule {}) = return () + go_rule (Rule { ru_bndrs = bndrs, ru_rhs = rhs }) + = extendScopeList bndrs (dffvExpr rhs) \end{code} --------------------------------------------------------------------- --- tidyTopName --- This is where we set names to local/global based on whether they really are --- externally visible (see comment at the top of this module). If the name --- was previously local, we have to give it a unique occurrence name if --- we intend to externalise it. +%************************************************************************ +%* * + tidyTopName +%* * +%************************************************************************ + +This is where we set names to local/global based on whether they really are +externally visible (see comment at the top of this module). If the name +was previously local, we have to give it a unique occurrence name if +we intend to externalise it. \begin{code} tidyTopName :: Module -> IORef NameCache -> Maybe Id -> TidyOccEnv @@ -854,10 +899,9 @@ (occ_env', occ') = tidyOccName occ_env new_occ - mk_new_local nc = (nc { nsUniqs = us2 }, mkInternalName uniq occ' loc) + mk_new_local nc = (nc { nsUniqs = us }, mkInternalName uniq occ' loc) where - (us1, us2) = splitUniqSupply (nsUniqs nc) - uniq = uniqFromSupply us1 + (uniq, us) = takeUniqFromSupply (nsUniqs nc) mk_new_external nc = allocateGlobalBinder nc mod occ' loc -- If we want to externalise a currently-local name, check @@ -1151,6 +1195,7 @@ cafRefs p (Note _n e) = cafRefs p e cafRefs p (Cast e _co) = cafRefs p e cafRefs _ (Type _) = fastBool False +cafRefs _ (Coercion _) = fastBool False cafRefss :: VarEnv Id -> [Expr a] -> FastBool cafRefss _ [] = fastBool False diff -Nru ghc-7.0.3/compiler/Makefile ghc-7.2.1/compiler/Makefile --- ghc-7.0.3/compiler/Makefile 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/Makefile 2011-08-07 17:10:05.000000000 +0000 @@ -16,32 +16,9 @@ default_to_ghc : all_ghc dir = compiler -TOP = .. -SPEC_TARGETS = 1 2 3 -include $(TOP)/mk/sub-makefile.mk + +include ../mk/compiler-ghc.mk all_ghc : +$(TOPMAKE) all_ghc $(EXTRA_MAKE_OPTS) -FAST_MAKE_OPTS += compiler_stage1_NO_BUILD_DEPS=YES compiler_stage2_NO_BUILD_DEPS=YES compiler_stage3_NO_BUILD_DEPS=YES - -.PHONY: 1 2 3 - -1: - +$(TOPMAKE) stage=1 all_ghc_stage1 $(FAST_MAKE_OPTS) NO_STAGE1_DEPS=YES NO_STAGE2_DEPS=YES - -2: - +$(TOPMAKE) stage=2 all_ghc_stage2 $(FAST_MAKE_OPTS) NO_STAGE2_DEPS=YES - -3: - +$(TOPMAKE) stage=3 all_ghc_stage3 $(FAST_MAKE_OPTS) NO_STAGE3_DEPS=YES - -.PHONY: extra-help -help : extra-help -extra-help : - @echo " make 1" - @echo " make 2" - @echo " make 3" - @echo - @echo " Build the stage 1, 2 or 3 GHC respectively, omitting dependencies" - @echo " and initial phases for speed." diff -Nru ghc-7.0.3/compiler/Makefile.local ghc-7.2.1/compiler/Makefile.local --- ghc-7.0.3/compiler/Makefile.local 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/compiler/Makefile.local 1970-01-01 00:00:00.000000000 +0000 @@ -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 -Nru ghc-7.0.3/compiler/nativeGen/Alpha/CodeGen.hs ghc-7.2.1/compiler/nativeGen/Alpha/CodeGen.hs --- ghc-7.0.3/compiler/nativeGen/Alpha/CodeGen.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/nativeGen/Alpha/CodeGen.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,789 +0,0 @@ -module Alpha.CodeGen () - -where - -{- - -getRegister :: CmmExpr -> NatM Register - -#if !x86_64_TARGET_ARCH - -- on x86_64, we have %rip for PicBaseReg, but it's not a full-featured - -- register, it can only be used for rip-relative addressing. -getRegister (CmmReg (CmmGlobal PicBaseReg)) - = do - reg <- getPicBaseNat wordSize - return (Fixed wordSize reg nilOL) -#endif - -getRegister (CmmReg reg) - = return (Fixed (cmmTypeSize (cmmRegType reg)) - (getRegisterReg reg) nilOL) - -getRegister tree@(CmmRegOff _ _) - = getRegister (mangleIndexTree tree) - - -#if WORD_SIZE_IN_BITS==32 - -- for 32-bit architectuers, support some 64 -> 32 bit conversions: - -- TO_W_(x), TO_W_(x >> 32) - -getRegister (CmmMachOp (MO_UU_Conv W64 W32) - [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do - ChildCode64 code rlo <- iselExpr64 x - return $ Fixed II32 (getHiVRegFromLo rlo) code - -getRegister (CmmMachOp (MO_SS_Conv W64 W32) - [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do - ChildCode64 code rlo <- iselExpr64 x - return $ Fixed II32 (getHiVRegFromLo rlo) code - -getRegister (CmmMachOp (MO_UU_Conv W64 W32) [x]) = do - ChildCode64 code rlo <- iselExpr64 x - return $ Fixed II32 rlo code - -getRegister (CmmMachOp (MO_SS_Conv W64 W32) [x]) = do - ChildCode64 code rlo <- iselExpr64 x - return $ Fixed II32 rlo code - -#endif - --- end of machine-"independent" bit; here we go on the rest... - - -getRegister (StDouble d) - = getBlockIdNat `thenNat` \ lbl -> - getNewRegNat PtrRep `thenNat` \ tmp -> - let code dst = mkSeqInstrs [ - LDATA RoDataSegment lbl [ - DATA TF [ImmLab (rational d)] - ], - LDA tmp (AddrImm (ImmCLbl lbl)), - LD TF dst (AddrReg tmp)] - in - return (Any FF64 code) - -getRegister (StPrim primop [x]) -- unary PrimOps - = case primop of - IntNegOp -> trivialUCode (NEG Q False) x - - NotOp -> trivialUCode NOT x - - FloatNegOp -> trivialUFCode FloatRep (FNEG TF) x - DoubleNegOp -> trivialUFCode FF64 (FNEG TF) x - - OrdOp -> coerceIntCode IntRep x - ChrOp -> chrCode x - - Float2IntOp -> coerceFP2Int x - Int2FloatOp -> coerceInt2FP pr x - Double2IntOp -> coerceFP2Int x - Int2DoubleOp -> coerceInt2FP pr x - - Double2FloatOp -> coerceFltCode x - Float2DoubleOp -> coerceFltCode x - - other_op -> getRegister (StCall fn CCallConv FF64 [x]) - where - fn = case other_op of - FloatExpOp -> fsLit "exp" - FloatLogOp -> fsLit "log" - FloatSqrtOp -> fsLit "sqrt" - FloatSinOp -> fsLit "sin" - FloatCosOp -> fsLit "cos" - FloatTanOp -> fsLit "tan" - FloatAsinOp -> fsLit "asin" - FloatAcosOp -> fsLit "acos" - FloatAtanOp -> fsLit "atan" - FloatSinhOp -> fsLit "sinh" - FloatCoshOp -> fsLit "cosh" - FloatTanhOp -> fsLit "tanh" - DoubleExpOp -> fsLit "exp" - DoubleLogOp -> fsLit "log" - DoubleSqrtOp -> fsLit "sqrt" - DoubleSinOp -> fsLit "sin" - DoubleCosOp -> fsLit "cos" - DoubleTanOp -> fsLit "tan" - DoubleAsinOp -> fsLit "asin" - DoubleAcosOp -> fsLit "acos" - DoubleAtanOp -> fsLit "atan" - DoubleSinhOp -> fsLit "sinh" - DoubleCoshOp -> fsLit "cosh" - DoubleTanhOp -> fsLit "tanh" - where - pr = panic "MachCode.getRegister: no primrep needed for Alpha" - -getRegister (StPrim primop [x, y]) -- dyadic PrimOps - = case primop of - CharGtOp -> trivialCode (CMP LTT) y x - CharGeOp -> trivialCode (CMP LE) y x - CharEqOp -> trivialCode (CMP EQQ) x y - CharNeOp -> int_NE_code x y - CharLtOp -> trivialCode (CMP LTT) x y - CharLeOp -> trivialCode (CMP LE) x y - - IntGtOp -> trivialCode (CMP LTT) y x - IntGeOp -> trivialCode (CMP LE) y x - IntEqOp -> trivialCode (CMP EQQ) x y - IntNeOp -> int_NE_code x y - IntLtOp -> trivialCode (CMP LTT) x y - IntLeOp -> trivialCode (CMP LE) x y - - WordGtOp -> trivialCode (CMP ULT) y x - WordGeOp -> trivialCode (CMP ULE) x y - WordEqOp -> trivialCode (CMP EQQ) x y - WordNeOp -> int_NE_code x y - WordLtOp -> trivialCode (CMP ULT) x y - WordLeOp -> trivialCode (CMP ULE) x y - - AddrGtOp -> trivialCode (CMP ULT) y x - AddrGeOp -> trivialCode (CMP ULE) y x - AddrEqOp -> trivialCode (CMP EQQ) x y - AddrNeOp -> int_NE_code x y - AddrLtOp -> trivialCode (CMP ULT) x y - AddrLeOp -> trivialCode (CMP ULE) x y - - FloatGtOp -> cmpF_code (FCMP TF LE) EQQ x y - FloatGeOp -> cmpF_code (FCMP TF LTT) EQQ x y - FloatEqOp -> cmpF_code (FCMP TF EQQ) NE x y - FloatNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y - FloatLtOp -> cmpF_code (FCMP TF LTT) NE x y - FloatLeOp -> cmpF_code (FCMP TF LE) NE x y - - DoubleGtOp -> cmpF_code (FCMP TF LE) EQQ x y - DoubleGeOp -> cmpF_code (FCMP TF LTT) EQQ x y - DoubleEqOp -> cmpF_code (FCMP TF EQQ) NE x y - DoubleNeOp -> cmpF_code (FCMP TF EQQ) EQQ x y - DoubleLtOp -> cmpF_code (FCMP TF LTT) NE x y - DoubleLeOp -> cmpF_code (FCMP TF LE) NE x y - - IntAddOp -> trivialCode (ADD Q False) x y - IntSubOp -> trivialCode (SUB Q False) x y - IntMulOp -> trivialCode (MUL Q False) x y - IntQuotOp -> trivialCode (DIV Q False) x y - IntRemOp -> trivialCode (REM Q False) x y - - WordAddOp -> trivialCode (ADD Q False) x y - WordSubOp -> trivialCode (SUB Q False) x y - WordMulOp -> trivialCode (MUL Q False) x y - WordQuotOp -> trivialCode (DIV Q True) x y - WordRemOp -> trivialCode (REM Q True) x y - - FloatAddOp -> trivialFCode W32 (FADD TF) x y - FloatSubOp -> trivialFCode W32 (FSUB TF) x y - FloatMulOp -> trivialFCode W32 (FMUL TF) x y - FloatDivOp -> trivialFCode W32 (FDIV TF) x y - - DoubleAddOp -> trivialFCode W64 (FADD TF) x y - DoubleSubOp -> trivialFCode W64 (FSUB TF) x y - DoubleMulOp -> trivialFCode W64 (FMUL TF) x y - DoubleDivOp -> trivialFCode W64 (FDIV TF) x y - - AddrAddOp -> trivialCode (ADD Q False) x y - AddrSubOp -> trivialCode (SUB Q False) x y - AddrRemOp -> trivialCode (REM Q True) x y - - AndOp -> trivialCode AND x y - OrOp -> trivialCode OR x y - XorOp -> trivialCode XOR x y - SllOp -> trivialCode SLL x y - SrlOp -> trivialCode SRL x y - - ISllOp -> trivialCode SLL x y -- was: panic "AlphaGen:isll" - ISraOp -> trivialCode SRA x y -- was: panic "AlphaGen:isra" - ISrlOp -> trivialCode SRL x y -- was: panic "AlphaGen:isrl" - - FloatPowerOp -> getRegister (StCall (fsLit "pow") CCallConv FF64 [x,y]) - DoublePowerOp -> getRegister (StCall (fsLit "pow") CCallConv FF64 [x,y]) - where - {- ------------------------------------------------------------ - Some bizarre special code for getting condition codes into - registers. Integer non-equality is a test for equality - followed by an XOR with 1. (Integer comparisons always set - the result register to 0 or 1.) Floating point comparisons of - any kind leave the result in a floating point register, so we - need to wrangle an integer register out of things. - -} - int_NE_code :: StixTree -> StixTree -> NatM Register - - int_NE_code x y - = trivialCode (CMP EQQ) x y `thenNat` \ register -> - getNewRegNat IntRep `thenNat` \ tmp -> - let - code = registerCode register tmp - src = registerName register tmp - code__2 dst = code . mkSeqInstr (XOR src (RIImm (ImmInt 1)) dst) - in - return (Any IntRep code__2) - - {- ------------------------------------------------------------ - Comments for int_NE_code also apply to cmpF_code - -} - cmpF_code - :: (Reg -> Reg -> Reg -> Instr) - -> Cond - -> StixTree -> StixTree - -> NatM Register - - cmpF_code instr cond x y - = trivialFCode pr instr x y `thenNat` \ register -> - getNewRegNat FF64 `thenNat` \ tmp -> - getBlockIdNat `thenNat` \ lbl -> - let - code = registerCode register tmp - result = registerName register tmp - - code__2 dst = code . mkSeqInstrs [ - OR zeroh (RIImm (ImmInt 1)) dst, - BF cond result (ImmCLbl lbl), - OR zeroh (RIReg zeroh) dst, - NEWBLOCK lbl] - in - return (Any IntRep code__2) - where - pr = panic "trivialU?FCode: does not use PrimRep on Alpha" - ------------------------------------------------------------ - -getRegister (CmmLoad pk mem) - = getAmode mem `thenNat` \ amode -> - let - code = amodeCode amode - src = amodeAddr amode - size = primRepToSize pk - code__2 dst = code . mkSeqInstr (LD size dst src) - in - return (Any pk code__2) - -getRegister (StInt i) - | fits8Bits i - = let - code dst = mkSeqInstr (OR zeroh (RIImm src) dst) - in - return (Any IntRep code) - | otherwise - = let - code dst = mkSeqInstr (LDI Q dst src) - in - return (Any IntRep code) - where - src = ImmInt (fromInteger i) - -getRegister leaf - | isJust imm - = let - code dst = mkSeqInstr (LDA dst (AddrImm imm__2)) - in - return (Any PtrRep code) - where - imm = maybeImm leaf - imm__2 = case imm of Just x -> x - - -getAmode :: CmmExpr -> NatM Amode -getAmode tree@(CmmRegOff _ _) = getAmode (mangleIndexTree tree) - --- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#if alpha_TARGET_ARCH - -getAmode (StPrim IntSubOp [x, StInt i]) - = getNewRegNat PtrRep `thenNat` \ tmp -> - getRegister x `thenNat` \ register -> - let - code = registerCode register tmp - reg = registerName register tmp - off = ImmInt (-(fromInteger i)) - in - return (Amode (AddrRegImm reg off) code) - -getAmode (StPrim IntAddOp [x, StInt i]) - = getNewRegNat PtrRep `thenNat` \ tmp -> - getRegister x `thenNat` \ register -> - let - code = registerCode register tmp - reg = registerName register tmp - off = ImmInt (fromInteger i) - in - return (Amode (AddrRegImm reg off) code) - -getAmode leaf - | isJust imm - = return (Amode (AddrImm imm__2) id) - where - imm = maybeImm leaf - imm__2 = case imm of Just x -> x - -getAmode other - = getNewRegNat PtrRep `thenNat` \ tmp -> - getRegister other `thenNat` \ register -> - let - code = registerCode register tmp - reg = registerName register tmp - in - return (Amode (AddrReg reg) code) - -#endif /* alpha_TARGET_ARCH */ - - --- ----------------------------------------------------------------------------- --- Generating assignments - --- Assignments are really at the heart of the whole code generation --- business. Almost all top-level nodes of any real importance are --- assignments, which correspond to loads, stores, or register --- transfers. If we're really lucky, some of the register transfers --- will go away, because we can use the destination register to --- complete the code generation for the right hand side. This only --- fails when the right hand side is forced into a fixed register --- (e.g. the result of a call). - -assignMem_IntCode :: Size -> CmmExpr -> CmmExpr -> NatM InstrBlock -assignReg_IntCode :: Size -> CmmReg -> CmmExpr -> NatM InstrBlock - -assignMem_FltCode :: Size -> CmmExpr -> CmmExpr -> NatM InstrBlock -assignReg_FltCode :: Size -> CmmReg -> CmmExpr -> NatM InstrBlock - - -assignIntCode pk (CmmLoad dst _) src - = getNewRegNat IntRep `thenNat` \ tmp -> - getAmode dst `thenNat` \ amode -> - getRegister src `thenNat` \ register -> - let - code1 = amodeCode amode [] - dst__2 = amodeAddr amode - code2 = registerCode register tmp [] - src__2 = registerName register tmp - sz = primRepToSize pk - code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2) - in - return code__2 - -assignIntCode pk dst src - = getRegister dst `thenNat` \ register1 -> - getRegister src `thenNat` \ register2 -> - let - dst__2 = registerName register1 zeroh - code = registerCode register2 dst__2 - src__2 = registerName register2 dst__2 - code__2 = if isFixed register2 - then code . mkSeqInstr (OR src__2 (RIReg src__2) dst__2) - else code - in - return code__2 - -assignFltCode pk (CmmLoad dst _) src - = getNewRegNat pk `thenNat` \ tmp -> - getAmode dst `thenNat` \ amode -> - getRegister src `thenNat` \ register -> - let - code1 = amodeCode amode [] - dst__2 = amodeAddr amode - code2 = registerCode register tmp [] - src__2 = registerName register tmp - sz = primRepToSize pk - code__2 = asmSeqThen [code1, code2] . mkSeqInstr (ST sz src__2 dst__2) - in - return code__2 - -assignFltCode pk dst src - = getRegister dst `thenNat` \ register1 -> - getRegister src `thenNat` \ register2 -> - let - dst__2 = registerName register1 zeroh - code = registerCode register2 dst__2 - src__2 = registerName register2 dst__2 - code__2 = if isFixed register2 - then code . mkSeqInstr (FMOV src__2 dst__2) - else code - in - return code__2 - - --- ----------------------------------------------------------------------------- --- Generating an non-local jump - --- (If applicable) Do not fill the delay slots here; you will confuse the --- register allocator. - -genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock - --- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -genJump (CmmLabel lbl) - | isAsmTemp lbl = returnInstr (BR target) - | otherwise = returnInstrs [LDA pv (AddrImm target), JMP zeroh (AddrReg pv) 0] - where - target = ImmCLbl lbl - -genJump tree - = getRegister tree `thenNat` \ register -> - getNewRegNat PtrRep `thenNat` \ tmp -> - let - dst = registerName register pv - code = registerCode register pv - target = registerName register pv - in - if isFixed register then - returnSeq code [OR dst (RIReg dst) pv, JMP zeroh (AddrReg pv) 0] - else - return (code . mkSeqInstr (JMP zeroh (AddrReg pv) 0)) - - --- ----------------------------------------------------------------------------- --- Unconditional branches - -genBranch :: BlockId -> NatM InstrBlock - -genBranch = return . toOL . mkBranchInstr - - --- ----------------------------------------------------------------------------- --- Conditional jumps - -{- -Conditional jumps are always to local labels, so we can use branch -instructions. We peek at the arguments to decide what kind of -comparison to do. - -ALPHA: For comparisons with 0, we're laughing, because we can just do -the desired conditional branch. - --} - - -genCondJump - :: BlockId -- the branch target - -> CmmExpr -- the condition on which to branch - -> NatM InstrBlock - --- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -genCondJump id (StPrim op [x, StInt 0]) - = getRegister x `thenNat` \ register -> - getNewRegNat (registerRep register) - `thenNat` \ tmp -> - let - code = registerCode register tmp - value = registerName register tmp - pk = registerRep register - target = ImmCLbl lbl - in - returnSeq code [BI (cmpOp op) value target] - where - cmpOp CharGtOp = GTT - cmpOp CharGeOp = GE - cmpOp CharEqOp = EQQ - cmpOp CharNeOp = NE - cmpOp CharLtOp = LTT - cmpOp CharLeOp = LE - cmpOp IntGtOp = GTT - cmpOp IntGeOp = GE - cmpOp IntEqOp = EQQ - cmpOp IntNeOp = NE - cmpOp IntLtOp = LTT - cmpOp IntLeOp = LE - cmpOp WordGtOp = NE - cmpOp WordGeOp = ALWAYS - cmpOp WordEqOp = EQQ - cmpOp WordNeOp = NE - cmpOp WordLtOp = NEVER - cmpOp WordLeOp = EQQ - cmpOp AddrGtOp = NE - cmpOp AddrGeOp = ALWAYS - cmpOp AddrEqOp = EQQ - cmpOp AddrNeOp = NE - cmpOp AddrLtOp = NEVER - cmpOp AddrLeOp = EQQ - -genCondJump lbl (StPrim op [x, StDouble 0.0]) - = getRegister x `thenNat` \ register -> - getNewRegNat (registerRep register) - `thenNat` \ tmp -> - let - code = registerCode register tmp - value = registerName register tmp - pk = registerRep register - target = ImmCLbl lbl - in - return (code . mkSeqInstr (BF (cmpOp op) value target)) - where - cmpOp FloatGtOp = GTT - cmpOp FloatGeOp = GE - cmpOp FloatEqOp = EQQ - cmpOp FloatNeOp = NE - cmpOp FloatLtOp = LTT - cmpOp FloatLeOp = LE - cmpOp DoubleGtOp = GTT - cmpOp DoubleGeOp = GE - cmpOp DoubleEqOp = EQQ - cmpOp DoubleNeOp = NE - cmpOp DoubleLtOp = LTT - cmpOp DoubleLeOp = LE - -genCondJump lbl (StPrim op [x, y]) - | fltCmpOp op - = trivialFCode pr instr x y `thenNat` \ register -> - getNewRegNat FF64 `thenNat` \ tmp -> - let - code = registerCode register tmp - result = registerName register tmp - target = ImmCLbl lbl - in - return (code . mkSeqInstr (BF cond result target)) - where - pr = panic "trivialU?FCode: does not use PrimRep on Alpha" - - fltCmpOp op = case op of - FloatGtOp -> True - FloatGeOp -> True - FloatEqOp -> True - FloatNeOp -> True - FloatLtOp -> True - FloatLeOp -> True - DoubleGtOp -> True - DoubleGeOp -> True - DoubleEqOp -> True - DoubleNeOp -> True - DoubleLtOp -> True - DoubleLeOp -> True - _ -> False - (instr, cond) = case op of - FloatGtOp -> (FCMP TF LE, EQQ) - FloatGeOp -> (FCMP TF LTT, EQQ) - FloatEqOp -> (FCMP TF EQQ, NE) - FloatNeOp -> (FCMP TF EQQ, EQQ) - FloatLtOp -> (FCMP TF LTT, NE) - FloatLeOp -> (FCMP TF LE, NE) - DoubleGtOp -> (FCMP TF LE, EQQ) - DoubleGeOp -> (FCMP TF LTT, EQQ) - DoubleEqOp -> (FCMP TF EQQ, NE) - DoubleNeOp -> (FCMP TF EQQ, EQQ) - DoubleLtOp -> (FCMP TF LTT, NE) - DoubleLeOp -> (FCMP TF LE, NE) - -genCondJump lbl (StPrim op [x, y]) - = trivialCode instr x y `thenNat` \ register -> - getNewRegNat IntRep `thenNat` \ tmp -> - let - code = registerCode register tmp - result = registerName register tmp - target = ImmCLbl lbl - in - return (code . mkSeqInstr (BI cond result target)) - where - (instr, cond) = case op of - CharGtOp -> (CMP LE, EQQ) - CharGeOp -> (CMP LTT, EQQ) - CharEqOp -> (CMP EQQ, NE) - CharNeOp -> (CMP EQQ, EQQ) - CharLtOp -> (CMP LTT, NE) - CharLeOp -> (CMP LE, NE) - IntGtOp -> (CMP LE, EQQ) - IntGeOp -> (CMP LTT, EQQ) - IntEqOp -> (CMP EQQ, NE) - IntNeOp -> (CMP EQQ, EQQ) - IntLtOp -> (CMP LTT, NE) - IntLeOp -> (CMP LE, NE) - WordGtOp -> (CMP ULE, EQQ) - WordGeOp -> (CMP ULT, EQQ) - WordEqOp -> (CMP EQQ, NE) - WordNeOp -> (CMP EQQ, EQQ) - WordLtOp -> (CMP ULT, NE) - WordLeOp -> (CMP ULE, NE) - AddrGtOp -> (CMP ULE, EQQ) - AddrGeOp -> (CMP ULT, EQQ) - AddrEqOp -> (CMP EQQ, NE) - AddrNeOp -> (CMP EQQ, EQQ) - AddrLtOp -> (CMP ULT, NE) - AddrLeOp -> (CMP ULE, NE) - --- ----------------------------------------------------------------------------- --- Generating C calls - --- Now the biggest nightmare---calls. Most of the nastiness is buried in --- @get_arg@, which moves the arguments to the correct registers/stack --- locations. Apart from that, the code is easy. --- --- (If applicable) Do not fill the delay slots here; you will confuse the --- register allocator. - -genCCall - :: CmmCallTarget -- function to call - -> HintedCmmFormals -- where to put the result - -> HintedCmmActuals -- arguments (of mixed type) - -> NatM InstrBlock - --- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -ccallResultRegs = - -genCCall fn cconv result_regs args - = mapAccumLNat get_arg (allArgRegs, eXTRA_STK_ARGS_HERE) args - `thenNat` \ ((unused,_), argCode) -> - let - nRegs = length allArgRegs - length unused - code = asmSeqThen (map ($ []) argCode) - in - returnSeq code [ - LDA pv (AddrImm (ImmLab (ptext fn))), - JSR ra (AddrReg pv) nRegs, - LDGP gp (AddrReg ra)] - where - ------------------------ - {- Try to get a value into a specific register (or registers) for - a call. The first 6 arguments go into the appropriate - argument register (separate registers for integer and floating - point arguments, but used in lock-step), and the remaining - arguments are dumped to the stack, beginning at 0(sp). Our - first argument is a pair of the list of remaining argument - registers to be assigned for this call and the next stack - offset to use for overflowing arguments. This way, - @get_Arg@ can be applied to all of a call's arguments using - @mapAccumLNat@. - -} - get_arg - :: ([(Reg,Reg)], Int) -- Argument registers and stack offset (accumulator) - -> StixTree -- Current argument - -> NatM (([(Reg,Reg)],Int), InstrBlock) -- Updated accumulator and code - - -- We have to use up all of our argument registers first... - - get_arg ((iDst,fDst):dsts, offset) arg - = getRegister arg `thenNat` \ register -> - let - reg = if isFloatType pk then fDst else iDst - code = registerCode register reg - src = registerName register reg - pk = registerRep register - in - return ( - if isFloatType pk then - ((dsts, offset), if isFixed register then - code . mkSeqInstr (FMOV src fDst) - else code) - else - ((dsts, offset), if isFixed register then - code . mkSeqInstr (OR src (RIReg src) iDst) - else code)) - - -- Once we have run out of argument registers, we move to the - -- stack... - - get_arg ([], offset) arg - = getRegister arg `thenNat` \ register -> - getNewRegNat (registerRep register) - `thenNat` \ tmp -> - let - code = registerCode register tmp - src = registerName register tmp - pk = registerRep register - sz = primRepToSize pk - in - return (([], offset + 1), code . mkSeqInstr (ST sz src (spRel offset))) - -trivialCode instr x (StInt y) - | fits8Bits y - = getRegister x `thenNat` \ register -> - getNewRegNat IntRep `thenNat` \ tmp -> - let - code = registerCode register tmp - src1 = registerName register tmp - src2 = ImmInt (fromInteger y) - code__2 dst = code . mkSeqInstr (instr src1 (RIImm src2) dst) - in - return (Any IntRep code__2) - -trivialCode instr x y - = getRegister x `thenNat` \ register1 -> - getRegister y `thenNat` \ register2 -> - getNewRegNat IntRep `thenNat` \ tmp1 -> - getNewRegNat IntRep `thenNat` \ tmp2 -> - let - code1 = registerCode register1 tmp1 [] - src1 = registerName register1 tmp1 - code2 = registerCode register2 tmp2 [] - src2 = registerName register2 tmp2 - code__2 dst = asmSeqThen [code1, code2] . - mkSeqInstr (instr src1 (RIReg src2) dst) - in - return (Any IntRep code__2) - ------------- -trivialUCode instr x - = getRegister x `thenNat` \ register -> - getNewRegNat IntRep `thenNat` \ tmp -> - let - code = registerCode register tmp - src = registerName register tmp - code__2 dst = code . mkSeqInstr (instr (RIReg src) dst) - in - return (Any IntRep code__2) - ------------- -trivialFCode _ instr x y - = getRegister x `thenNat` \ register1 -> - getRegister y `thenNat` \ register2 -> - getNewRegNat FF64 `thenNat` \ tmp1 -> - getNewRegNat FF64 `thenNat` \ tmp2 -> - let - code1 = registerCode register1 tmp1 - src1 = registerName register1 tmp1 - - code2 = registerCode register2 tmp2 - src2 = registerName register2 tmp2 - - code__2 dst = asmSeqThen [code1 [], code2 []] . - mkSeqInstr (instr src1 src2 dst) - in - return (Any FF64 code__2) - -trivialUFCode _ instr x - = getRegister x `thenNat` \ register -> - getNewRegNat FF64 `thenNat` \ tmp -> - let - code = registerCode register tmp - src = registerName register tmp - code__2 dst = code . mkSeqInstr (instr src dst) - in - return (Any FF64 code__2) - -#if alpha_TARGET_ARCH - -coerceInt2FP _ x - = getRegister x `thenNat` \ register -> - getNewRegNat IntRep `thenNat` \ reg -> - let - code = registerCode register reg - src = registerName register reg - - code__2 dst = code . mkSeqInstrs [ - ST Q src (spRel 0), - LD TF dst (spRel 0), - CVTxy Q TF dst dst] - in - return (Any FF64 code__2) - -------------- -coerceFP2Int x - = getRegister x `thenNat` \ register -> - getNewRegNat FF64 `thenNat` \ tmp -> - let - code = registerCode register tmp - src = registerName register tmp - - code__2 dst = code . mkSeqInstrs [ - CVTxy TF Q src tmp, - ST TF tmp (spRel 0), - LD Q dst (spRel 0)] - in - return (Any IntRep code__2) - -#endif /* alpha_TARGET_ARCH */ - - --} - - - - - diff -Nru ghc-7.0.3/compiler/nativeGen/Alpha/Instr.hs ghc-7.2.1/compiler/nativeGen/Alpha/Instr.hs --- ghc-7.0.3/compiler/nativeGen/Alpha/Instr.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/nativeGen/Alpha/Instr.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,142 +0,0 @@ ------------------------------------------------------------------------------ --- --- Machine-dependent assembly language --- --- (c) The University of Glasgow 1993-2004 --- ------------------------------------------------------------------------------ - -#include "HsVersions.h" -#include "nativeGen/NCG.h" - -module Alpha.Instr ( --- Cond(..), --- Instr(..), --- RI(..) -) - -where - -{- -import BlockId -import Regs -import Cmm -import FastString -import CLabel - -data Cond - = ALWAYS -- For BI (same as BR) - | EQQ -- For CMP and BI (NB: "EQ" is a 1.3 Prelude name) - | GE -- For BI only - | GTT -- For BI only (NB: "GT" is a 1.3 Prelude name) - | LE -- For CMP and BI - | LTT -- For CMP and BI (NB: "LT" is a 1.3 Prelude name) - | NE -- For BI only - | NEVER -- For BI (null instruction) - | ULE -- For CMP only - | ULT -- For CMP only - deriving Eq - - --- ----------------------------------------------------------------------------- --- Machine's assembly language - --- We have a few common "instructions" (nearly all the pseudo-ops) but --- mostly all of 'Instr' is machine-specific. - --- Register or immediate -data RI - = RIReg Reg - | RIImm Imm - -data Instr - -- comment pseudo-op - = COMMENT FastString - - -- some static data spat out during code - -- generation. Will be extracted before - -- pretty-printing. - | LDATA Section [CmmStatic] - - -- start a new basic block. Useful during - -- codegen, removed later. Preceding - -- instruction should be a jump, as per the - -- invariants for a BasicBlock (see Cmm). - | NEWBLOCK BlockId - - -- specify current stack offset for - -- benefit of subsequent passes - | DELTA Int - - -- | spill this reg to a stack slot - | SPILL Reg Int - - -- | reload this reg from a stack slot - | RELOAD Int Reg - - -- Loads and stores. - | LD Size Reg AddrMode -- size, dst, src - | LDA Reg AddrMode -- dst, src - | LDAH Reg AddrMode -- dst, src - | LDGP Reg AddrMode -- dst, src - | LDI Size Reg Imm -- size, dst, src - | ST Size Reg AddrMode -- size, src, dst - - -- Int Arithmetic. - | CLR Reg -- dst - | ABS Size RI Reg -- size, src, dst - | NEG Size Bool RI Reg -- size, overflow, src, dst - | ADD Size Bool Reg RI Reg -- size, overflow, src, src, dst - | SADD Size Size Reg RI Reg -- size, scale, src, src, dst - | SUB Size Bool Reg RI Reg -- size, overflow, src, src, dst - | SSUB Size Size Reg RI Reg -- size, scale, src, src, dst - | MUL Size Bool Reg RI Reg -- size, overflow, src, src, dst - | DIV Size Bool Reg RI Reg -- size, unsigned, src, src, dst - | REM Size Bool Reg RI Reg -- size, unsigned, src, src, dst - - -- Simple bit-twiddling. - | NOT RI Reg - | AND Reg RI Reg - | ANDNOT Reg RI Reg - | OR Reg RI Reg - | ORNOT Reg RI Reg - | XOR Reg RI Reg - | XORNOT Reg RI Reg - | SLL Reg RI Reg - | SRL Reg RI Reg - | SRA Reg RI Reg - - | ZAP Reg RI Reg - | ZAPNOT Reg RI Reg - - | NOP - - -- Comparison - | CMP Cond Reg RI Reg - - -- Float Arithmetic. - | FCLR Reg - | FABS Reg Reg - | FNEG Size Reg Reg - | FADD Size Reg Reg Reg - | FDIV Size Reg Reg Reg - | FMUL Size Reg Reg Reg - | FSUB Size Reg Reg Reg - | CVTxy Size Size Reg Reg - | FCMP Size Cond Reg Reg Reg - | FMOV Reg Reg - - -- Jumping around. - | BI Cond Reg Imm - | BF Cond Reg Imm - | BR Imm - | JMP Reg AddrMode Int - | BSR Imm Int - | JSR Reg AddrMode Int - - -- Alpha-specific pseudo-ops. - | FUNBEGIN CLabel - | FUNEND CLabel - - --} diff -Nru ghc-7.0.3/compiler/nativeGen/Alpha/Ppr.hs-old ghc-7.2.1/compiler/nativeGen/Alpha/Ppr.hs-old --- ghc-7.0.3/compiler/nativeGen/Alpha/Ppr.hs-old 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/nativeGen/Alpha/Ppr.hs-old 1970-01-01 00:00:00.000000000 +0000 @@ -1,562 +0,0 @@ - -module Alpha.Ppr ( -{- - pprReg, - pprSize, - pprCond, - pprAddr, - pprSectionHeader, - pprTypeAndSizeDecl, - pprRI, - pprRegRIReg, - pprSizeRegRegReg --} -) - -where - -{- -#include "nativeGen/NCG.h" -#include "HsVersions.h" - -import BlockId -import Cmm -import Regs -- may differ per-platform -import Instrs - -import CLabel ( CLabel, pprCLabel, externallyVisibleCLabel, - labelDynamic, mkAsmTempLabel, entryLblToInfoLbl ) - -#if HAVE_SUBSECTIONS_VIA_SYMBOLS -import CLabel ( mkDeadStripPreventer ) -#endif - -import Panic ( panic ) -import Unique ( pprUnique ) -import Pretty -import FastString -import qualified Outputable -import Outputable ( Outputable, pprPanic, ppr, docToSDoc) - -import Data.Array.ST -import Data.Word ( Word8 ) -import Control.Monad.ST -import Data.Char ( chr, ord ) -import Data.Maybe ( isJust ) - - - -pprReg :: Reg -> Doc -pprReg r - = case r of - RealReg i -> ppr_reg_no i - VirtualRegI u -> text "%vI_" <> asmSDoc (pprUnique u) - VirtualRegHi u -> text "%vHi_" <> asmSDoc (pprUnique u) - VirtualRegF u -> text "%vF_" <> asmSDoc (pprUnique u) - VirtualRegD u -> text "%vD_" <> asmSDoc (pprUnique u) - where - ppr_reg_no :: Int -> Doc - ppr_reg_no i = ptext - (case i of { - 0 -> sLit "$0"; 1 -> sLit "$1"; - 2 -> sLit "$2"; 3 -> sLit "$3"; - 4 -> sLit "$4"; 5 -> sLit "$5"; - 6 -> sLit "$6"; 7 -> sLit "$7"; - 8 -> sLit "$8"; 9 -> sLit "$9"; - 10 -> sLit "$10"; 11 -> sLit "$11"; - 12 -> sLit "$12"; 13 -> sLit "$13"; - 14 -> sLit "$14"; 15 -> sLit "$15"; - 16 -> sLit "$16"; 17 -> sLit "$17"; - 18 -> sLit "$18"; 19 -> sLit "$19"; - 20 -> sLit "$20"; 21 -> sLit "$21"; - 22 -> sLit "$22"; 23 -> sLit "$23"; - 24 -> sLit "$24"; 25 -> sLit "$25"; - 26 -> sLit "$26"; 27 -> sLit "$27"; - 28 -> sLit "$28"; 29 -> sLit "$29"; - 30 -> sLit "$30"; 31 -> sLit "$31"; - 32 -> sLit "$f0"; 33 -> sLit "$f1"; - 34 -> sLit "$f2"; 35 -> sLit "$f3"; - 36 -> sLit "$f4"; 37 -> sLit "$f5"; - 38 -> sLit "$f6"; 39 -> sLit "$f7"; - 40 -> sLit "$f8"; 41 -> sLit "$f9"; - 42 -> sLit "$f10"; 43 -> sLit "$f11"; - 44 -> sLit "$f12"; 45 -> sLit "$f13"; - 46 -> sLit "$f14"; 47 -> sLit "$f15"; - 48 -> sLit "$f16"; 49 -> sLit "$f17"; - 50 -> sLit "$f18"; 51 -> sLit "$f19"; - 52 -> sLit "$f20"; 53 -> sLit "$f21"; - 54 -> sLit "$f22"; 55 -> sLit "$f23"; - 56 -> sLit "$f24"; 57 -> sLit "$f25"; - 58 -> sLit "$f26"; 59 -> sLit "$f27"; - 60 -> sLit "$f28"; 61 -> sLit "$f29"; - 62 -> sLit "$f30"; 63 -> sLit "$f31"; - _ -> sLit "very naughty alpha register" - }) - - -pprSize :: Size -> Doc -pprSize x = ptext (case x of - B -> sLit "b" - Bu -> sLit "bu" --- W -> sLit "w" UNUSED --- Wu -> sLit "wu" UNUSED - L -> sLit "l" - Q -> sLit "q" --- FF -> sLit "f" UNUSED --- DF -> sLit "d" UNUSED --- GF -> sLit "g" UNUSED --- SF -> sLit "s" UNUSED - TF -> sLit "t" - - -pprCond :: Cond -> Doc -pprCond c - = ptext (case c of - EQQ -> sLit "eq" - LTT -> sLit "lt" - LE -> sLit "le" - ULT -> sLit "ult" - ULE -> sLit "ule" - NE -> sLit "ne" - GTT -> sLit "gt" - GE -> sLit "ge") - - -pprAddr :: AddrMode -> Doc -pprAddr (AddrReg r) = parens (pprReg r) -pprAddr (AddrImm i) = pprImm i -pprAddr (AddrRegImm r1 i) - = (<>) (pprImm i) (parens (pprReg r1)) - - -pprSectionHeader Text - = ptext (sLit "\t.text\n\t.align 3") - -pprSectionHeader Data - = ptext (sLit "\t.data\n\t.align 3") - -pprSectionHeader ReadOnlyData - = ptext (sLit "\t.data\n\t.align 3") - -pprSectionHeader RelocatableReadOnlyData - = ptext (sLit "\t.data\n\t.align 3") - -pprSectionHeader UninitialisedData - = ptext (sLit "\t.bss\n\t.align 3") - -pprSectionHeader ReadOnlyData16 - = ptext (sLit "\t.data\n\t.align 4") - -pprSectionHeader (OtherSection sec) - = panic "PprMach.pprSectionHeader: unknown section" - - -pprTypeAndSizeDecl :: CLabel -> Doc -pprTypeAndSizeDecl lbl - = empty - - - -pprInstr :: Instr -> Doc - -pprInstr (DELTA d) - = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d))) - -pprInstr (NEWBLOCK _) - = panic "PprMach.pprInstr: NEWBLOCK" - -pprInstr (LDATA _ _) - = panic "PprMach.pprInstr: LDATA" - -pprInstr (SPILL reg slot) - = hcat [ - ptext (sLit "\tSPILL"), - char '\t', - pprReg reg, - comma, - ptext (sLit "SLOT") <> parens (int slot)] - -pprInstr (RELOAD slot reg) - = hcat [ - ptext (sLit "\tRELOAD"), - char '\t', - ptext (sLit "SLOT") <> parens (int slot), - comma, - pprReg reg] - -pprInstr (LD size reg addr) - = hcat [ - ptext (sLit "\tld"), - pprSize size, - char '\t', - pprReg reg, - comma, - pprAddr addr - ] - -pprInstr (LDA reg addr) - = hcat [ - ptext (sLit "\tlda\t"), - pprReg reg, - comma, - pprAddr addr - ] - -pprInstr (LDAH reg addr) - = hcat [ - ptext (sLit "\tldah\t"), - pprReg reg, - comma, - pprAddr addr - ] - -pprInstr (LDGP reg addr) - = hcat [ - ptext (sLit "\tldgp\t"), - pprReg reg, - comma, - pprAddr addr - ] - -pprInstr (LDI size reg imm) - = hcat [ - ptext (sLit "\tldi"), - pprSize size, - char '\t', - pprReg reg, - comma, - pprImm imm - ] - -pprInstr (ST size reg addr) - = hcat [ - ptext (sLit "\tst"), - pprSize size, - char '\t', - pprReg reg, - comma, - pprAddr addr - ] - -pprInstr (CLR reg) - = hcat [ - ptext (sLit "\tclr\t"), - pprReg reg - ] - -pprInstr (ABS size ri reg) - = hcat [ - ptext (sLit "\tabs"), - pprSize size, - char '\t', - pprRI ri, - comma, - pprReg reg - ] - -pprInstr (NEG size ov ri reg) - = hcat [ - ptext (sLit "\tneg"), - pprSize size, - if ov then ptext (sLit "v\t") else char '\t', - pprRI ri, - comma, - pprReg reg - ] - -pprInstr (ADD size ov reg1 ri reg2) - = hcat [ - ptext (sLit "\tadd"), - pprSize size, - if ov then ptext (sLit "v\t") else char '\t', - pprReg reg1, - comma, - pprRI ri, - comma, - pprReg reg2 - ] - -pprInstr (SADD size scale reg1 ri reg2) - = hcat [ - ptext (case scale of {{-UNUSED:L -> (sLit "\ts4");-} Q -> (sLit "\ts8")}), - ptext (sLit "add"), - pprSize size, - char '\t', - pprReg reg1, - comma, - pprRI ri, - comma, - pprReg reg2 - ] - -pprInstr (SUB size ov reg1 ri reg2) - = hcat [ - ptext (sLit "\tsub"), - pprSize size, - if ov then ptext (sLit "v\t") else char '\t', - pprReg reg1, - comma, - pprRI ri, - comma, - pprReg reg2 - ] - -pprInstr (SSUB size scale reg1 ri reg2) - = hcat [ - ptext (case scale of {{-UNUSED:L -> (sLit "\ts4");-} Q -> (sLit "\ts8")}), - ptext (sLit "sub"), - pprSize size, - char '\t', - pprReg reg1, - comma, - pprRI ri, - comma, - pprReg reg2 - ] - -pprInstr (MUL size ov reg1 ri reg2) - = hcat [ - ptext (sLit "\tmul"), - pprSize size, - if ov then ptext (sLit "v\t") else char '\t', - pprReg reg1, - comma, - pprRI ri, - comma, - pprReg reg2 - ] - -pprInstr (DIV size uns reg1 ri reg2) - = hcat [ - ptext (sLit "\tdiv"), - pprSize size, - if uns then ptext (sLit "u\t") else char '\t', - pprReg reg1, - comma, - pprRI ri, - comma, - pprReg reg2 - ] - -pprInstr (REM size uns reg1 ri reg2) - = hcat [ - ptext (sLit "\trem"), - pprSize size, - if uns then ptext (sLit "u\t") else char '\t', - pprReg reg1, - comma, - pprRI ri, - comma, - pprReg reg2 - ] - -pprInstr (NOT ri reg) - = hcat [ - ptext (sLit "\tnot"), - char '\t', - pprRI ri, - comma, - pprReg reg - ] - -pprInstr (AND reg1 ri reg2) = pprRegRIReg (sLit "and") reg1 ri reg2 -pprInstr (ANDNOT reg1 ri reg2) = pprRegRIReg (sLit "andnot") reg1 ri reg2 -pprInstr (OR reg1 ri reg2) = pprRegRIReg (sLit "or") reg1 ri reg2 -pprInstr (ORNOT reg1 ri reg2) = pprRegRIReg (sLit "ornot") reg1 ri reg2 -pprInstr (XOR reg1 ri reg2) = pprRegRIReg (sLit "xor") reg1 ri reg2 -pprInstr (XORNOT reg1 ri reg2) = pprRegRIReg (sLit "xornot") reg1 ri reg2 - -pprInstr (SLL reg1 ri reg2) = pprRegRIReg (sLit "sll") reg1 ri reg2 -pprInstr (SRL reg1 ri reg2) = pprRegRIReg (sLit "srl") reg1 ri reg2 -pprInstr (SRA reg1 ri reg2) = pprRegRIReg (sLit "sra") reg1 ri reg2 - -pprInstr (ZAP reg1 ri reg2) = pprRegRIReg (sLit "zap") reg1 ri reg2 -pprInstr (ZAPNOT reg1 ri reg2) = pprRegRIReg (sLit "zapnot") reg1 ri reg2 - -pprInstr (NOP) = ptext (sLit "\tnop") - -pprInstr (CMP cond reg1 ri reg2) - = hcat [ - ptext (sLit "\tcmp"), - pprCond cond, - char '\t', - pprReg reg1, - comma, - pprRI ri, - comma, - pprReg reg2 - ] - -pprInstr (FCLR reg) - = hcat [ - ptext (sLit "\tfclr\t"), - pprReg reg - ] - -pprInstr (FABS reg1 reg2) - = hcat [ - ptext (sLit "\tfabs\t"), - pprReg reg1, - comma, - pprReg reg2 - ] - -pprInstr (FNEG size reg1 reg2) - = hcat [ - ptext (sLit "\tneg"), - pprSize size, - char '\t', - pprReg reg1, - comma, - pprReg reg2 - ] - -pprInstr (FADD size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "add") size reg1 reg2 reg3 -pprInstr (FDIV size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "div") size reg1 reg2 reg3 -pprInstr (FMUL size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "mul") size reg1 reg2 reg3 -pprInstr (FSUB size reg1 reg2 reg3) = pprSizeRegRegReg (sLit "sub") size reg1 reg2 reg3 - -pprInstr (CVTxy size1 size2 reg1 reg2) - = hcat [ - ptext (sLit "\tcvt"), - pprSize size1, - case size2 of {Q -> ptext (sLit "qc"); _ -> pprSize size2}, - char '\t', - pprReg reg1, - comma, - pprReg reg2 - ] - -pprInstr (FCMP size cond reg1 reg2 reg3) - = hcat [ - ptext (sLit "\tcmp"), - pprSize size, - pprCond cond, - char '\t', - pprReg reg1, - comma, - pprReg reg2, - comma, - pprReg reg3 - ] - -pprInstr (FMOV reg1 reg2) - = hcat [ - ptext (sLit "\tfmov\t"), - pprReg reg1, - comma, - pprReg reg2 - ] - -pprInstr (BI ALWAYS reg lab) = pprInstr (BR lab) - -pprInstr (BI NEVER reg lab) = empty - -pprInstr (BI cond reg lab) - = hcat [ - ptext (sLit "\tb"), - pprCond cond, - char '\t', - pprReg reg, - comma, - pprImm lab - ] - -pprInstr (BF cond reg lab) - = hcat [ - ptext (sLit "\tfb"), - pprCond cond, - char '\t', - pprReg reg, - comma, - pprImm lab - ] - -pprInstr (BR lab) - = (<>) (ptext (sLit "\tbr\t")) (pprImm lab) - -pprInstr (JMP reg addr hint) - = hcat [ - ptext (sLit "\tjmp\t"), - pprReg reg, - comma, - pprAddr addr, - comma, - int hint - ] - -pprInstr (BSR imm n) - = (<>) (ptext (sLit "\tbsr\t")) (pprImm imm) - -pprInstr (JSR reg addr n) - = hcat [ - ptext (sLit "\tjsr\t"), - pprReg reg, - comma, - pprAddr addr - ] - -pprInstr (FUNBEGIN clab) - = hcat [ - if (externallyVisibleCLabel clab) then - hcat [ptext (sLit "\t.globl\t"), pp_lab, char '\n'] - else - empty, - ptext (sLit "\t.ent "), - pp_lab, - char '\n', - pp_lab, - pp_ldgp, - pp_lab, - pp_frame - ] - where - pp_lab = pprCLabel_asm clab - - -- NEVER use commas within those string literals, cpp will ruin your day - pp_ldgp = hcat [ ptext (sLit ":\n\tldgp $29"), char ',', ptext (sLit "0($27)\n") ] - pp_frame = hcat [ ptext (sLit "..ng:\n\t.frame $30"), char ',', - ptext (sLit "4240"), char ',', - ptext (sLit "$26"), char ',', - ptext (sLit "0\n\t.prologue 1") ] - -pprInstr (FUNEND clab) - = (<>) (ptext (sLit "\t.align 4\n\t.end ")) (pprCLabel_asm clab) - - -pprRI :: RI -> Doc - -pprRI (RIReg r) = pprReg r -pprRI (RIImm r) = pprImm r - -pprRegRIReg :: LitString -> Reg -> RI -> Reg -> Doc -pprRegRIReg name reg1 ri reg2 - = hcat [ - char '\t', - ptext name, - char '\t', - pprReg reg1, - comma, - pprRI ri, - comma, - pprReg reg2 - ] - -pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc -pprSizeRegRegReg name size reg1 reg2 reg3 - = hcat [ - char '\t', - ptext name, - pprSize size, - char '\t', - pprReg reg1, - comma, - pprReg reg2, - comma, - pprReg reg3 - ] - --} - - - diff -Nru ghc-7.0.3/compiler/nativeGen/Alpha/RegInfo.hs ghc-7.2.1/compiler/nativeGen/Alpha/RegInfo.hs --- ghc-7.0.3/compiler/nativeGen/Alpha/RegInfo.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/nativeGen/Alpha/RegInfo.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,218 +0,0 @@ - ------------------------------------------------------------------------------ --- --- (c) The University of Glasgow 1996-2004 --- ------------------------------------------------------------------------------ - -module Alpha.RegInfo ( -{- - RegUsage(..), - noUsage, - regUsage, - patchRegs, - jumpDests, - isJumpish, - patchJump, - isRegRegMove, - - JumpDest, canShortcut, shortcutJump, shortcutStatic, - - maxSpillSlots, - mkSpillInstr, - mkLoadInstr, - mkRegRegMoveInstr, - mkBranchInstr --} -) - -where - -{- -#include "nativeGen/NCG.h" -#include "HsVersions.h" - - -import BlockId -import Cmm -import CLabel -import Instrs -import Regs -import Outputable -import Constants ( rESERVED_C_STACK_BYTES ) -import FastBool - -data RegUsage = RU [Reg] [Reg] - -noUsage :: RegUsage -noUsage = RU [] [] - -regUsage :: Instr -> RegUsage - -regUsage instr = case instr of - SPILL reg slot -> usage ([reg], []) - RELOAD slot reg -> usage ([], [reg]) - LD B reg addr -> usage (regAddr addr, [reg, t9]) - LD Bu reg addr -> usage (regAddr addr, [reg, t9]) --- LD W reg addr -> usage (regAddr addr, [reg, t9]) : UNUSED --- LD Wu reg addr -> usage (regAddr addr, [reg, t9]) : UNUSED - LD sz reg addr -> usage (regAddr addr, [reg]) - LDA reg addr -> usage (regAddr addr, [reg]) - LDAH reg addr -> usage (regAddr addr, [reg]) - LDGP reg addr -> usage (regAddr addr, [reg]) - LDI sz reg imm -> usage ([], [reg]) - ST B reg addr -> usage (reg : regAddr addr, [t9, t10]) --- ST W reg addr -> usage (reg : regAddr addr, [t9, t10]) : UNUSED - ST sz reg addr -> usage (reg : regAddr addr, []) - CLR reg -> usage ([], [reg]) - ABS sz ri reg -> usage (regRI ri, [reg]) - NEG sz ov ri reg -> usage (regRI ri, [reg]) - ADD sz ov r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SADD sz sc r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SUB sz ov r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SSUB sz sc r1 ar r2 -> usage (r1 : regRI ar, [r2]) - MUL sz ov r1 ar r2 -> usage (r1 : regRI ar, [r2]) - DIV sz un r1 ar r2 -> usage (r1 : regRI ar, [r2, t9, t10, t11, t12]) - REM sz un r1 ar r2 -> usage (r1 : regRI ar, [r2, t9, t10, t11, t12]) - NOT ri reg -> usage (regRI ri, [reg]) - AND r1 ar r2 -> usage (r1 : regRI ar, [r2]) - ANDNOT r1 ar r2 -> usage (r1 : regRI ar, [r2]) - OR r1 ar r2 -> usage (r1 : regRI ar, [r2]) - ORNOT r1 ar r2 -> usage (r1 : regRI ar, [r2]) - XOR r1 ar r2 -> usage (r1 : regRI ar, [r2]) - XORNOT r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SLL r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SRL r1 ar r2 -> usage (r1 : regRI ar, [r2]) - SRA r1 ar r2 -> usage (r1 : regRI ar, [r2]) - ZAP r1 ar r2 -> usage (r1 : regRI ar, [r2]) - ZAPNOT r1 ar r2 -> usage (r1 : regRI ar, [r2]) - CMP co r1 ar r2 -> usage (r1 : regRI ar, [r2]) - FCLR reg -> usage ([], [reg]) - FABS r1 r2 -> usage ([r1], [r2]) - FNEG sz r1 r2 -> usage ([r1], [r2]) - FADD sz r1 r2 r3 -> usage ([r1, r2], [r3]) - FDIV sz r1 r2 r3 -> usage ([r1, r2], [r3]) - FMUL sz r1 r2 r3 -> usage ([r1, r2], [r3]) - FSUB sz r1 r2 r3 -> usage ([r1, r2], [r3]) - CVTxy sz1 sz2 r1 r2 -> usage ([r1], [r2]) - FCMP sz co r1 r2 r3 -> usage ([r1, r2], [r3]) - FMOV r1 r2 -> usage ([r1], [r2]) - - - -- We assume that all local jumps will be BI/BF/BR. JMP must be out-of-line. - BI cond reg lbl -> usage ([reg], []) - BF cond reg lbl -> usage ([reg], []) - JMP reg addr hint -> RU (mkRegSet (filter interesting (regAddr addr))) freeRegSet - - BSR _ n -> RU (argRegSet n) callClobberedRegSet - JSR reg addr n -> RU (argRegSet n) callClobberedRegSet - - _ -> noUsage - - where - usage (src, dst) = RU (mkRegSet (filter interesting src)) - (mkRegSet (filter interesting dst)) - - interesting (FixedReg _) = False - interesting _ = True - - regAddr (AddrReg r1) = [r1] - regAddr (AddrRegImm r1 _) = [r1] - regAddr (AddrImm _) = [] - - regRI (RIReg r) = [r] - regRI _ = [] - - -patchRegs :: Instr -> (Reg -> Reg) -> Instr -patchRegs instr env = case instr of - SPILL reg slot -> SPILL (env reg) slot - RELOAD slot reg -> RELOAD slot (env reg) - LD sz reg addr -> LD sz (env reg) (fixAddr addr) - LDA reg addr -> LDA (env reg) (fixAddr addr) - LDAH reg addr -> LDAH (env reg) (fixAddr addr) - LDGP reg addr -> LDGP (env reg) (fixAddr addr) - LDI sz reg imm -> LDI sz (env reg) imm - ST sz reg addr -> ST sz (env reg) (fixAddr addr) - CLR reg -> CLR (env reg) - ABS sz ar reg -> ABS sz (fixRI ar) (env reg) - NEG sz ov ar reg -> NEG sz ov (fixRI ar) (env reg) - ADD sz ov r1 ar r2 -> ADD sz ov (env r1) (fixRI ar) (env r2) - SADD sz sc r1 ar r2 -> SADD sz sc (env r1) (fixRI ar) (env r2) - SUB sz ov r1 ar r2 -> SUB sz ov (env r1) (fixRI ar) (env r2) - SSUB sz sc r1 ar r2 -> SSUB sz sc (env r1) (fixRI ar) (env r2) - MUL sz ov r1 ar r2 -> MUL sz ov (env r1) (fixRI ar) (env r2) - DIV sz un r1 ar r2 -> DIV sz un (env r1) (fixRI ar) (env r2) - REM sz un r1 ar r2 -> REM sz un (env r1) (fixRI ar) (env r2) - NOT ar reg -> NOT (fixRI ar) (env reg) - AND r1 ar r2 -> AND (env r1) (fixRI ar) (env r2) - ANDNOT r1 ar r2 -> ANDNOT (env r1) (fixRI ar) (env r2) - OR r1 ar r2 -> OR (env r1) (fixRI ar) (env r2) - ORNOT r1 ar r2 -> ORNOT (env r1) (fixRI ar) (env r2) - XOR r1 ar r2 -> XOR (env r1) (fixRI ar) (env r2) - XORNOT r1 ar r2 -> XORNOT (env r1) (fixRI ar) (env r2) - SLL r1 ar r2 -> SLL (env r1) (fixRI ar) (env r2) - SRL r1 ar r2 -> SRL (env r1) (fixRI ar) (env r2) - SRA r1 ar r2 -> SRA (env r1) (fixRI ar) (env r2) - ZAP r1 ar r2 -> ZAP (env r1) (fixRI ar) (env r2) - ZAPNOT r1 ar r2 -> ZAPNOT (env r1) (fixRI ar) (env r2) - CMP co r1 ar r2 -> CMP co (env r1) (fixRI ar) (env r2) - FCLR reg -> FCLR (env reg) - FABS r1 r2 -> FABS (env r1) (env r2) - FNEG s r1 r2 -> FNEG s (env r1) (env r2) - FADD s r1 r2 r3 -> FADD s (env r1) (env r2) (env r3) - FDIV s r1 r2 r3 -> FDIV s (env r1) (env r2) (env r3) - FMUL s r1 r2 r3 -> FMUL s (env r1) (env r2) (env r3) - FSUB s r1 r2 r3 -> FSUB s (env r1) (env r2) (env r3) - CVTxy s1 s2 r1 r2 -> CVTxy s1 s2 (env r1) (env r2) - FCMP s co r1 r2 r3 -> FCMP s co (env r1) (env r2) (env r3) - FMOV r1 r2 -> FMOV (env r1) (env r2) - BI cond reg lbl -> BI cond (env reg) lbl - BF cond reg lbl -> BF cond (env reg) lbl - JMP reg addr hint -> JMP (env reg) (fixAddr addr) hint - JSR reg addr i -> JSR (env reg) (fixAddr addr) i - _ -> instr - where - fixAddr (AddrReg r1) = AddrReg (env r1) - fixAddr (AddrRegImm r1 i) = AddrRegImm (env r1) i - fixAddr other = other - - fixRI (RIReg r) = RIReg (env r) - fixRI other = other - - -mkSpillInstr - :: Reg -- register to spill - -> Int -- current stack delta - -> Int -- spill slot to use - -> Instr - -mkSpillInstr reg delta slot - = let off = spillSlotToOffset slot - in - -- Alpha: spill below the stack pointer (?) - ST sz dyn (spRel (- (off `div` 8))) - - -mkLoadInstr - :: Reg -- register to load - -> Int -- current stack delta - -> Int -- spill slot to use - -> Instr -mkLoadInstr reg delta slot - = let off = spillSlotToOffset slot - in - LD sz dyn (spRel (- (off `div` 8))) - - -mkBranchInstr - :: BlockId - -> [Instr] - -mkBranchInstr id = [BR id] - --} - - - - diff -Nru ghc-7.0.3/compiler/nativeGen/Alpha/Regs.hs ghc-7.2.1/compiler/nativeGen/Alpha/Regs.hs --- ghc-7.0.3/compiler/nativeGen/Alpha/Regs.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/nativeGen/Alpha/Regs.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,323 +0,0 @@ --- ----------------------------------------------------------------------------- --- --- (c) The University of Glasgow 1994-2004 --- --- Alpha support is rotted and incomplete. --- ----------------------------------------------------------------------------- - - -module Alpha.Regs ( -{- - Size(..), - AddrMode(..), - fits8Bits, - fReg, - gp, pv, ra, sp, t9, t10, t11, t12, v0, f0, zeroh --} -) - -where - -{- -#include "nativeGen/NCG.h" -#include "HsVersions.h" -#include "../includes/stg/MachRegs.h" - -import RegsBase - -import BlockId -import Cmm -import CLabel ( CLabel, mkMainCapabilityLabel ) -import Pretty -import Outputable ( Outputable(..), pprPanic, panic ) -import qualified Outputable -import Unique -import UniqSet -import Constants -import FastTypes -import FastBool -import UniqFM - - -data Size - = B -- byte - | Bu --- | W -- word (2 bytes): UNUSED --- | Wu -- : UNUSED - | L -- longword (4 bytes) - | Q -- quadword (8 bytes) --- | FF -- VAX F-style floating pt: UNUSED --- | GF -- VAX G-style floating pt: UNUSED --- | DF -- VAX D-style floating pt: UNUSED --- | SF -- IEEE single-precision floating pt: UNUSED - | TF -- IEEE double-precision floating pt - deriving Eq - - -data AddrMode - = AddrImm Imm - | AddrReg Reg - | AddrRegImm Reg Imm - - -addrOffset :: AddrMode -> Int -> Maybe AddrMode -addrOffset addr off - = case addr of - _ -> panic "MachMisc.addrOffset not defined for Alpha" - -fits8Bits :: Integer -> Bool -fits8Bits i = i >= -256 && i < 256 - - --- The Alpha has 64 registers of interest; 32 integer registers and 32 floating --- point registers. The mapping of STG registers to alpha machine registers --- is defined in StgRegs.h. We are, of course, prepared for any eventuality. - -fReg :: Int -> RegNo -fReg x = (32 + x) - -v0, f0, ra, pv, gp, sp, zeroh :: Reg -v0 = realReg 0 -f0 = realReg (fReg 0) -ra = FixedReg ILIT(26) -pv = t12 -gp = FixedReg ILIT(29) -sp = FixedReg ILIT(30) -zeroh = FixedReg ILIT(31) -- "zero" is used in 1.3 (MonadZero method) - -t9, t10, t11, t12 :: Reg -t9 = realReg 23 -t10 = realReg 24 -t11 = realReg 25 -t12 = realReg 27 - - -#define f0 32 -#define f1 33 -#define f2 34 -#define f3 35 -#define f4 36 -#define f5 37 -#define f6 38 -#define f7 39 -#define f8 40 -#define f9 41 -#define f10 42 -#define f11 43 -#define f12 44 -#define f13 45 -#define f14 46 -#define f15 47 -#define f16 48 -#define f17 49 -#define f18 50 -#define f19 51 -#define f20 52 -#define f21 53 -#define f22 54 -#define f23 55 -#define f24 56 -#define f25 57 -#define f26 58 -#define f27 59 -#define f28 60 -#define f29 61 -#define f30 62 -#define f31 63 - - --- allMachRegs is the complete set of machine regs. -allMachRegNos :: [RegNo] -allMachRegNos = [0..63] - - --- these are the regs which we cannot assume stay alive over a --- C call. -callClobberedRegs :: [Reg] -callClobberedRegs - = [0, 1, 2, 3, 4, 5, 6, 7, 8, - 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27, 28, 29, - fReg 0, fReg 1, fReg 10, fReg 11, fReg 12, fReg 13, fReg 14, fReg 15, - fReg 16, fReg 17, fReg 18, fReg 19, fReg 20, fReg 21, fReg 22, fReg 23, - fReg 24, fReg 25, fReg 26, fReg 27, fReg 28, fReg 29, fReg 30] - - --- argRegs is the set of regs which are read for an n-argument call to C. --- For archs which pass all args on the stack (x86), is empty. --- Sparc passes up to the first 6 args in regs. --- Dunno about Alpha. -argRegs :: RegNo -> [Reg] - -argRegs 0 = [] -argRegs 1 = freeMappedRegs [16, fReg 16] -argRegs 2 = freeMappedRegs [16, 17, fReg 16, fReg 17] -argRegs 3 = freeMappedRegs [16, 17, 18, fReg 16, fReg 17, fReg 18] -argRegs 4 = freeMappedRegs [16, 17, 18, 19, fReg 16, fReg 17, fReg 18, fReg 19] -argRegs 5 = freeMappedRegs [16, 17, 18, 19, 20, fReg 16, fReg 17, fReg 18, fReg 19, fReg 20] -argRegs 6 = freeMappedRegs [16, 17, 18, 19, 20, 21, fReg 16, fReg 17, fReg 18, fReg 19, fReg 20, fReg 21] -argRegs _ = panic "MachRegs.argRegs(alpha): don't know about >6 arguments!" - - --- all of the arg regs ?? -allArgRegs :: [(Reg, Reg)] -allArgRegs = [(realReg i, realReg (fReg i)) | i <- [16..21]] - - --- horror show ----------------------------------------------------------------- - -freeReg :: RegNo -> FastBool - -freeReg 26 = fastBool False -- return address (ra) -freeReg 28 = fastBool False -- reserved for the assembler (at) -freeReg 29 = fastBool False -- global pointer (gp) -freeReg 30 = fastBool False -- stack pointer (sp) -freeReg 31 = fastBool False -- always zero (zeroh) -freeReg 63 = fastBool False -- always zero (f31) - -#ifdef REG_Base -freeReg REG_Base = fastBool False -#endif -#ifdef REG_R1 -freeReg REG_R1 = fastBool False -#endif -#ifdef REG_R2 -freeReg REG_R2 = fastBool False -#endif -#ifdef REG_R3 -freeReg REG_R3 = fastBool False -#endif -#ifdef REG_R4 -freeReg REG_R4 = fastBool False -#endif -#ifdef REG_R5 -freeReg REG_R5 = fastBool False -#endif -#ifdef REG_R6 -freeReg REG_R6 = fastBool False -#endif -#ifdef REG_R7 -freeReg REG_R7 = fastBool False -#endif -#ifdef REG_R8 -freeReg REG_R8 = fastBool False -#endif -#ifdef REG_F1 -freeReg REG_F1 = fastBool False -#endif -#ifdef REG_F2 -freeReg REG_F2 = fastBool False -#endif -#ifdef REG_F3 -freeReg REG_F3 = fastBool False -#endif -#ifdef REG_F4 -freeReg REG_F4 = fastBool False -#endif -#ifdef REG_D1 -freeReg REG_D1 = fastBool False -#endif -#ifdef REG_D2 -freeReg REG_D2 = fastBool False -#endif -#ifdef REG_Sp -freeReg REG_Sp = fastBool False -#endif -#ifdef REG_Su -freeReg REG_Su = fastBool False -#endif -#ifdef REG_SpLim -freeReg REG_SpLim = fastBool False -#endif -#ifdef REG_Hp -freeReg REG_Hp = fastBool False -#endif -#ifdef REG_HpLim -freeReg REG_HpLim = fastBool False -#endif -freeReg n = fastBool True - - --- | Returns 'Nothing' if this global register is not stored --- in a real machine register, otherwise returns @'Just' reg@, where --- reg is the machine register it is stored in. - -globalRegMaybe :: GlobalReg -> Maybe Reg - -#ifdef REG_Base -globalRegMaybe BaseReg = Just (RealReg REG_Base) -#endif -#ifdef REG_R1 -globalRegMaybe (VanillaReg 1 _) = Just (RealReg REG_R1) -#endif -#ifdef REG_R2 -globalRegMaybe (VanillaReg 2 _) = Just (RealReg REG_R2) -#endif -#ifdef REG_R3 -globalRegMaybe (VanillaReg 3 _) = Just (RealReg REG_R3) -#endif -#ifdef REG_R4 -globalRegMaybe (VanillaReg 4 _) = Just (RealReg REG_R4) -#endif -#ifdef REG_R5 -globalRegMaybe (VanillaReg 5 _) = Just (RealReg REG_R5) -#endif -#ifdef REG_R6 -globalRegMaybe (VanillaReg 6 _) = Just (RealReg REG_R6) -#endif -#ifdef REG_R7 -globalRegMaybe (VanillaReg 7 _) = Just (RealReg REG_R7) -#endif -#ifdef REG_R8 -globalRegMaybe (VanillaReg 8 _) = Just (RealReg REG_R8) -#endif -#ifdef REG_R9 -globalRegMaybe (VanillaReg 9 _) = Just (RealReg REG_R9) -#endif -#ifdef REG_R10 -globalRegMaybe (VanillaReg 10 _) = Just (RealReg REG_R10) -#endif -#ifdef REG_F1 -globalRegMaybe (FloatReg 1) = Just (RealReg REG_F1) -#endif -#ifdef REG_F2 -globalRegMaybe (FloatReg 2) = Just (RealReg REG_F2) -#endif -#ifdef REG_F3 -globalRegMaybe (FloatReg 3) = Just (RealReg REG_F3) -#endif -#ifdef REG_F4 -globalRegMaybe (FloatReg 4) = Just (RealReg REG_F4) -#endif -#ifdef REG_D1 -globalRegMaybe (DoubleReg 1) = Just (RealReg REG_D1) -#endif -#ifdef REG_D2 -globalRegMaybe (DoubleReg 2) = Just (RealReg REG_D2) -#endif -#ifdef REG_Sp -globalRegMaybe Sp = Just (RealReg REG_Sp) -#endif -#ifdef REG_Lng1 -globalRegMaybe (LongReg 1) = Just (RealReg REG_Lng1) -#endif -#ifdef REG_Lng2 -globalRegMaybe (LongReg 2) = Just (RealReg REG_Lng2) -#endif -#ifdef REG_SpLim -globalRegMaybe SpLim = Just (RealReg REG_SpLim) -#endif -#ifdef REG_Hp -globalRegMaybe Hp = Just (RealReg REG_Hp) -#endif -#ifdef REG_HpLim -globalRegMaybe HpLim = Just (RealReg REG_HpLim) -#endif -#ifdef REG_CurrentTSO -globalRegMaybe CurrentTSO = Just (RealReg REG_CurrentTSO) -#endif -#ifdef REG_CurrentNursery -globalRegMaybe CurrentNursery = Just (RealReg REG_CurrentNursery) -#endif -globalRegMaybe _ = Nothing - --} diff -Nru ghc-7.0.3/compiler/nativeGen/AsmCodeGen.lhs ghc-7.2.1/compiler/nativeGen/AsmCodeGen.lhs --- ghc-7.0.3/compiler/nativeGen/AsmCodeGen.lhs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/nativeGen/AsmCodeGen.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -7,51 +7,30 @@ -- ----------------------------------------------------------------------------- \begin{code} -{-# OPTIONS -w #-} --- 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 - module AsmCodeGen ( nativeCodeGen ) where #include "HsVersions.h" #include "nativeGen/NCG.h" -#if alpha_TARGET_ARCH -import Alpha.CodeGen -import Alpha.Regs -import Alpha.RegInfo -import Alpha.Instr - -#elif i386_TARGET_ARCH || x86_64_TARGET_ARCH -import X86.CodeGen -import X86.Regs -import X86.RegInfo -import X86.Instr -import X86.Ppr - -#elif sparc_TARGET_ARCH -import SPARC.CodeGen -import SPARC.Regs -import SPARC.Instr -import SPARC.Ppr -import SPARC.ShortcutJump - -#elif powerpc_TARGET_ARCH -import PPC.CodeGen -import PPC.Cond -import PPC.Regs -import PPC.RegInfo -import PPC.Instr -import PPC.Ppr - -#else -#error "AsmCodeGen: unknown architecture" - -#endif +import qualified X86.CodeGen +import qualified X86.Regs +import qualified X86.Instr +import qualified X86.Ppr + +import qualified SPARC.CodeGen +import qualified SPARC.Regs +import qualified SPARC.Instr +import qualified SPARC.Ppr +import qualified SPARC.ShortcutJump +import qualified SPARC.CodeGen.Expand + +import qualified PPC.CodeGen +import qualified PPC.Cond +import qualified PPC.Regs +import qualified PPC.RegInfo +import qualified PPC.Instr +import qualified PPC.Ppr import RegAlloc.Liveness import qualified RegAlloc.Linear.Main as Linear @@ -59,39 +38,33 @@ import qualified GraphColor as Color import qualified RegAlloc.Graph.Main as Color import qualified RegAlloc.Graph.Stats as Color -import qualified RegAlloc.Graph.Coalesce as Color import qualified RegAlloc.Graph.TrivColorable as Color -import qualified SPARC.CodeGen.Expand as SPARC - import TargetReg import Platform +import Config import Instruction import PIC import Reg -import RegClass import NCGMonad import BlockId import CgUtils ( fixStgRegisters ) -import Cmm -import CmmOpt ( cmmMiniInline, cmmMachOpFold ) -import PprCmm +import OldCmm +import CmmOpt ( cmmEliminateDeadBlocks, cmmMiniInline, cmmMachOpFold ) +import OldPprCmm import CLabel -import State import UniqFM import Unique ( Unique, getUnique ) import UniqSupply import DynFlags -#if powerpc_TARGET_ARCH -import StaticFlags ( opt_Static, opt_PIC ) -#endif +import StaticFlags import Util -import Config ( cProjectVersion ) -import Module +import BasicTypes ( Alignment ) import Digraph +import Pretty (Doc) import qualified Pretty import BufWrite import Outputable @@ -104,11 +77,7 @@ --import OrdList import Data.List -import Data.Int -import Data.Word -import Data.Bits import Data.Maybe -import GHC.Exts import Control.Monad import System.IO @@ -163,17 +132,93 @@ -- ----------------------------------------------------------------------------- -- Top-level of the native codegen +data NcgImpl statics instr jumpDest = NcgImpl { + cmmTopCodeGen :: RawCmmTop -> NatM [NatCmmTop statics instr], + generateJumpTableForInstr :: instr -> Maybe (NatCmmTop statics instr), + getJumpDestBlockId :: jumpDest -> Maybe BlockId, + canShortcut :: instr -> Maybe jumpDest, + shortcutStatics :: (BlockId -> Maybe jumpDest) -> statics -> statics, + shortcutJump :: (BlockId -> Maybe jumpDest) -> instr -> instr, + pprNatCmmTop :: Platform -> NatCmmTop statics instr -> Doc, + maxSpillSlots :: Int, + allocatableRegs :: [RealReg], + ncg_x86fp_kludge :: [NatCmmTop statics instr] -> [NatCmmTop statics instr], + ncgExpandTop :: [NatCmmTop statics instr] -> [NatCmmTop statics instr], + ncgMakeFarBranches :: [NatBasicBlock instr] -> [NatBasicBlock instr] + } + -------------------- nativeCodeGen :: DynFlags -> Handle -> UniqSupply -> [RawCmm] -> IO () nativeCodeGen dflags h us cmms + = let nCG' :: (Outputable statics, PlatformOutputable instr, Instruction instr) => NcgImpl statics instr jumpDest -> IO () + nCG' ncgImpl = nativeCodeGen' dflags ncgImpl h us cmms + x86NcgImpl = NcgImpl { + cmmTopCodeGen = X86.CodeGen.cmmTopCodeGen + ,generateJumpTableForInstr = X86.CodeGen.generateJumpTableForInstr + ,getJumpDestBlockId = X86.Instr.getJumpDestBlockId + ,canShortcut = X86.Instr.canShortcut + ,shortcutStatics = X86.Instr.shortcutStatics + ,shortcutJump = X86.Instr.shortcutJump + ,pprNatCmmTop = X86.Ppr.pprNatCmmTop + ,maxSpillSlots = X86.Instr.maxSpillSlots + ,allocatableRegs = X86.Regs.allocatableRegs + ,ncg_x86fp_kludge = id + ,ncgExpandTop = id + ,ncgMakeFarBranches = id + } + in case platformArch $ targetPlatform dflags of + ArchX86 -> nCG' (x86NcgImpl { ncg_x86fp_kludge = map x86fp_kludge }) + ArchX86_64 -> nCG' x86NcgImpl + ArchPPC -> + nCG' $ NcgImpl { + cmmTopCodeGen = PPC.CodeGen.cmmTopCodeGen + ,generateJumpTableForInstr = PPC.CodeGen.generateJumpTableForInstr + ,getJumpDestBlockId = PPC.RegInfo.getJumpDestBlockId + ,canShortcut = PPC.RegInfo.canShortcut + ,shortcutStatics = PPC.RegInfo.shortcutStatics + ,shortcutJump = PPC.RegInfo.shortcutJump + ,pprNatCmmTop = PPC.Ppr.pprNatCmmTop + ,maxSpillSlots = PPC.Instr.maxSpillSlots + ,allocatableRegs = PPC.Regs.allocatableRegs + ,ncg_x86fp_kludge = id + ,ncgExpandTop = id + ,ncgMakeFarBranches = makeFarBranches + } + ArchSPARC -> + nCG' $ NcgImpl { + cmmTopCodeGen = SPARC.CodeGen.cmmTopCodeGen + ,generateJumpTableForInstr = SPARC.CodeGen.generateJumpTableForInstr + ,getJumpDestBlockId = SPARC.ShortcutJump.getJumpDestBlockId + ,canShortcut = SPARC.ShortcutJump.canShortcut + ,shortcutStatics = SPARC.ShortcutJump.shortcutStatics + ,shortcutJump = SPARC.ShortcutJump.shortcutJump + ,pprNatCmmTop = SPARC.Ppr.pprNatCmmTop + ,maxSpillSlots = SPARC.Instr.maxSpillSlots + ,allocatableRegs = SPARC.Regs.allocatableRegs + ,ncg_x86fp_kludge = id + ,ncgExpandTop = map SPARC.CodeGen.Expand.expandTop + ,ncgMakeFarBranches = id + } + ArchARM -> + panic "nativeCodeGen: No NCG for ARM" + ArchPPC_64 -> + panic "nativeCodeGen: No NCG for PPC 64" + ArchUnknown -> + panic "nativeCodeGen: No NCG for unknown arch" + +nativeCodeGen' :: (Outputable statics, PlatformOutputable instr, Instruction instr) + => DynFlags + -> NcgImpl statics instr jumpDest + -> Handle -> UniqSupply -> [RawCmm] -> IO () +nativeCodeGen' dflags ncgImpl h us cmms = do - let split_cmms = concat $ map add_split cmms - + let platform = targetPlatform dflags + split_cmms = concat $ map add_split cmms -- BufHandle is a performance hack. We could hide it inside -- Pretty if it weren't for the fact that we do lots of little -- printDocs here (in order to do codegen in constant space). bufh <- newBufHandle h - (imports, prof) <- cmmNativeGens dflags bufh us split_cmms [] [] 0 + (imports, prof) <- cmmNativeGens dflags ncgImpl bufh us split_cmms [] [] 0 bFlush bufh let (native, colorStats, linearStats) @@ -182,7 +227,7 @@ -- dump native code dumpIfSet_dyn dflags Opt_D_dump_asm "Asm code" - (vcat $ map (docToSDoc . pprNatCmmTop) $ concat native) + (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl platform) $ concat native) -- dump global NCG stats for graph coloring allocator (case concat $ catMaybes colorStats of @@ -200,10 +245,10 @@ dumpIfSet_dyn dflags Opt_D_dump_asm_conflicts "Register conflict graph" $ Color.dotGraph - targetRegDotColor - (Color.trivColorable - targetVirtualRegSqueeze - targetRealRegSqueeze) + (targetRegDotColor platform) + (Color.trivColorable platform + (targetVirtualRegSqueeze platform) + (targetRealRegSqueeze platform)) $ graphGlobal) @@ -223,21 +268,37 @@ | dopt Opt_SplitObjs dflags = split_marker : tops | otherwise = tops - split_marker = CmmProc [] mkSplitMarkerLabel [] (ListGraph []) + split_marker = CmmProc Nothing mkSplitMarkerLabel (ListGraph []) -- | Do native code generation on all these cmms. -- -cmmNativeGens dflags h us [] impAcc profAcc count +cmmNativeGens :: (Outputable statics, PlatformOutputable instr, Instruction instr) + => DynFlags + -> NcgImpl statics instr jumpDest + -> BufHandle + -> UniqSupply + -> [RawCmmTop] + -> [[CLabel]] + -> [ ([NatCmmTop statics instr], + Maybe [Color.RegAllocStats statics instr], + Maybe [Linear.RegAllocStats]) ] + -> Int + -> IO ( [[CLabel]], + [([NatCmmTop statics instr], + Maybe [Color.RegAllocStats statics instr], + Maybe [Linear.RegAllocStats])] ) + +cmmNativeGens _ _ _ _ [] impAcc profAcc _ = return (reverse impAcc, reverse profAcc) -cmmNativeGens dflags h us (cmm : cmms) impAcc profAcc count +cmmNativeGens dflags ncgImpl h us (cmm : cmms) impAcc profAcc count = do (us', native, imports, colorStats, linearStats) - <- cmmNativeGen dflags us cmm count + <- cmmNativeGen dflags ncgImpl us cmm count Pretty.bufLeftRender h - $ {-# SCC "pprNativeCode" #-} Pretty.vcat $ map pprNatCmmTop native + $ {-# SCC "pprNativeCode" #-} Pretty.vcat $ map (pprNatCmmTop ncgImpl (targetPlatform dflags)) native -- carefully evaluate this strictly. Binding it with 'let' -- and then using 'seq' doesn't work, because the let @@ -253,7 +314,8 @@ -- force evaulation all this stuff to avoid space leaks seqString (showSDoc $ vcat $ map ppr imports) `seq` return () - cmmNativeGens dflags h us' cmms + cmmNativeGens dflags ncgImpl + h us' cmms (imports : impAcc) ((lsPprNative, colorStats, linearStats) : profAcc) count' @@ -265,19 +327,22 @@ -- | Complete native code generation phase for a single top-level chunk of Cmm. -- Dumping the output of each stage along the way. -- Global conflict graph and NGC stats -cmmNativeGen - :: DynFlags +cmmNativeGen + :: (Outputable statics, PlatformOutputable instr, Instruction instr) + => DynFlags + -> NcgImpl statics instr jumpDest -> UniqSupply -> RawCmmTop -- ^ the cmm to generate code for -> Int -- ^ sequence number of this top thing -> IO ( UniqSupply - , [NatCmmTop Instr] -- native code - , [CLabel] -- things imported by this cmm - , Maybe [Color.RegAllocStats Instr] -- stats for the coloring register allocator - , Maybe [Linear.RegAllocStats]) -- stats for the linear register allocators + , [NatCmmTop statics instr] -- native code + , [CLabel] -- things imported by this cmm + , Maybe [Color.RegAllocStats statics instr] -- stats for the coloring register allocator + , Maybe [Linear.RegAllocStats]) -- stats for the linear register allocators -cmmNativeGen dflags us cmm count +cmmNativeGen dflags ncgImpl us cmm count = do + let platform = targetPlatform dflags -- rewrite assignments to global regs let fixed_cmm = @@ -291,27 +356,27 @@ dumpIfSet_dyn dflags Opt_D_dump_opt_cmm "Optimised Cmm" - (pprCmm $ Cmm [opt_cmm]) + (pprCmm platform $ Cmm [opt_cmm]) -- generate native code from cmm let ((native, lastMinuteImports), usGen) = {-# SCC "genMachCode" #-} - initUs us $ genMachCode dflags opt_cmm + initUs us $ genMachCode dflags (cmmTopCodeGen ncgImpl) opt_cmm dumpIfSet_dyn dflags Opt_D_dump_asm_native "Native code" - (vcat $ map (docToSDoc . pprNatCmmTop) native) + (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl platform) native) -- tag instructions with register liveness information let (withLiveness, usLive) = {-# SCC "regLiveness" #-} initUs usGen - $ mapUs regLiveness + $ mapUs (regLiveness platform) $ map natCmmTopToLive native dumpIfSet_dyn dflags Opt_D_dump_asm_liveness "Liveness annotations added" - (vcat $ map ppr withLiveness) + (vcat $ map (pprPlatform platform) withLiveness) -- allocate registers (alloced, usAlloc, ppr_raStatsColor, ppr_raStatsLinear) <- @@ -321,9 +386,9 @@ -- the regs usable for allocation let (alloc_regs :: UniqFM (UniqSet RealReg)) = foldr (\r -> plusUFM_C unionUniqSets - $ unitUFM (targetClassOfRealReg r) (unitUniqSet r)) + $ unitUFM (targetClassOfRealReg platform r) (unitUniqSet r)) emptyUFM - $ allocatableRegs + $ allocatableRegs ncgImpl -- do the graph coloring register allocation let ((alloced, regAllocStats), usAlloc) @@ -332,20 +397,20 @@ $ Color.regAlloc dflags alloc_regs - (mkUniqSet [0..maxSpillSlots]) + (mkUniqSet [0 .. maxSpillSlots ncgImpl]) withLiveness -- dump out what happened during register allocation dumpIfSet_dyn dflags Opt_D_dump_asm_regalloc "Registers allocated" - (vcat $ map (docToSDoc . pprNatCmmTop) alloced) + (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl platform) alloced) dumpIfSet_dyn dflags Opt_D_dump_asm_regalloc_stages "Build/spill stages" (vcat $ map (\(stage, stats) -> text "# --------------------------" $$ text "# cmm " <> int count <> text " Stage " <> int stage - $$ ppr stats) + $$ pprPlatform platform stats) $ zip [0..] regAllocStats) let mPprStats = @@ -365,11 +430,11 @@ = {-# SCC "RegAlloc" #-} initUs usLive $ liftM unzip - $ mapUs Linear.regAlloc withLiveness + $ mapUs (Linear.regAlloc dflags) withLiveness dumpIfSet_dyn dflags Opt_D_dump_asm_regalloc "Registers allocated" - (vcat $ map (docToSDoc . pprNatCmmTop) alloced) + (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl platform) alloced) let mPprStats = if dopt Opt_D_dump_asm_stats dflags @@ -382,38 +447,38 @@ , Nothing , mPprStats) + ---- x86fp_kludge. This pass inserts ffree instructions to clear + ---- the FPU stack on x86. The x86 ABI requires that the FPU stack + ---- is clear, and library functions can return odd results if it + ---- isn't. + ---- + ---- NB. must happen before shortcutBranches, because that + ---- generates JXX_GBLs which we can't fix up in x86fp_kludge. + let kludged = {-# SCC "x86fp_kludge" #-} ncg_x86fp_kludge ncgImpl alloced + + ---- generate jump tables + let tabled = + {-# SCC "generateJumpTables" #-} + generateJumpTables ncgImpl kludged + ---- shortcut branches let shorted = {-# SCC "shortcutBranches" #-} - shortcutBranches dflags alloced + shortcutBranches dflags ncgImpl tabled ---- sequence blocks let sequenced = {-# SCC "sequenceBlocks" #-} - map sequenceTop shorted - - ---- x86fp_kludge - let kludged = -#if i386_TARGET_ARCH - {-# SCC "x86fp_kludge" #-} - map x86fp_kludge sequenced -#else - sequenced -#endif + map (sequenceTop ncgImpl) shorted - ---- expansion of SPARC synthetic instrs -#if sparc_TARGET_ARCH + ---- expansion of SPARC synthetic instrs let expanded = {-# SCC "sparc_expand" #-} - map SPARC.expandTop kludged + ncgExpandTop ncgImpl sequenced dumpIfSet_dyn dflags Opt_D_dump_asm_expanded "Synthetic instructions expanded" - (vcat $ map (docToSDoc . pprNatCmmTop) expanded) -#else - let expanded = - kludged -#endif + (vcat $ map (docToSDoc . pprNatCmmTop ncgImpl platform) expanded) return ( usAlloc , expanded @@ -422,12 +487,10 @@ , ppr_raStatsLinear) -#if i386_TARGET_ARCH -x86fp_kludge :: NatCmmTop Instr -> NatCmmTop Instr +x86fp_kludge :: NatCmmTop (Alignment, CmmStatics) X86.Instr.Instr -> NatCmmTop (Alignment, CmmStatics) X86.Instr.Instr x86fp_kludge top@(CmmData _ _) = top -x86fp_kludge top@(CmmProc info lbl params (ListGraph code)) = - CmmProc info lbl params (ListGraph $ i386_insert_ffrees code) -#endif +x86fp_kludge (CmmProc info lbl (ListGraph code)) = + CmmProc info lbl (ListGraph $ X86.Instr.i386_insert_ffrees code) -- | Build a doc for all the imports. @@ -451,14 +514,12 @@ -- stack so add the note in: Pretty.$$ Pretty.text ".section .note.GNU-stack,\"\",@progbits" #endif -#if !defined(darwin_TARGET_OS) -- And just because every other compiler does, lets stick in -- an identifier directive: .ident "GHC x.y.z" - Pretty.$$ let compilerIdent = Pretty.text "GHC" Pretty.<+> + Pretty.$$ let compilerIdent = Pretty.text "GHC" Pretty.<+> Pretty.text cProjectVersion in Pretty.text ".ident" Pretty.<+> Pretty.doubleQuotes compilerIdent -#endif where -- Generate "symbol stubs" for all external symbols that might @@ -484,7 +545,7 @@ | otherwise = Pretty.empty - doPpr lbl = (lbl, Pretty.render $ pprCLabel lbl astyle) + doPpr lbl = (lbl, renderWithStyle (pprCLabel lbl) astyle) astyle = mkCodeStyle AsmStyle @@ -498,12 +559,12 @@ -- fallthroughs. sequenceTop - :: NatCmmTop Instr - -> NatCmmTop Instr + :: Instruction instr + => NcgImpl statics instr jumpDest -> NatCmmTop statics instr -> NatCmmTop statics instr -sequenceTop top@(CmmData _ _) = top -sequenceTop (CmmProc info lbl params (ListGraph blocks)) = - CmmProc info lbl params (ListGraph $ makeFarBranches $ sequenceBlocks blocks) +sequenceTop _ top@(CmmData _ _) = top +sequenceTop ncgImpl (CmmProc info lbl (ListGraph blocks)) = + CmmProc info lbl (ListGraph $ ncgMakeFarBranches ncgImpl $ sequenceBlocks blocks) -- The algorithm is very simple (and stupid): we make a graph out of -- the blocks where there is an edge from one block to another iff the @@ -513,7 +574,7 @@ -- destination of the out edge to the front of the list, and continue. -- FYI, the classic layout for basic blocks uses postorder DFS; this --- algorithm is implemented in cmm/ZipCfg.hs (NR 6 Sep 2007). +-- algorithm is implemented in Hoopl. sequenceBlocks :: Instruction instr @@ -546,8 +607,12 @@ [one] -> [getUnique one] _many -> [] +mkNode :: (Instruction t) + => GenBasicBlock t + -> (GenBasicBlock t, Unique, [Unique]) mkNode block@(BasicBlock id instrs) = (block, getUnique id, getOutEdges instrs) +seqBlocks :: (Eq t) => [(GenBasicBlock t1, t, [t])] -> [GenBasicBlock t1] seqBlocks [] = [] seqBlocks ((block,_,[]) : rest) = block : seqBlocks rest @@ -560,7 +625,8 @@ -- fallthroughs within a loop. seqBlocks _ = panic "AsmCodegen:seqBlocks" -reorder id accum [] = (False, reverse accum) +reorder :: (Eq a) => a -> [(t, a, t1)] -> [(t, a, t1)] -> (Bool, [(t, a, t1)]) +reorder _ accum [] = (False, reverse accum) reorder id accum (b@(block,id',out) : rest) | id == id' = (True, (block,id,out) : reverse accum ++ rest) | otherwise = reorder id (b:accum) rest @@ -572,11 +638,9 @@ -- Conditional branches on PowerPC are limited to +-32KB; if our Procs get too -- big, we have to work around this limitation. -makeFarBranches - :: [NatBasicBlock Instr] - -> [NatBasicBlock Instr] - -#if powerpc_TARGET_ARCH +makeFarBranches + :: [NatBasicBlock PPC.Instr.Instr] + -> [NatBasicBlock PPC.Instr.Instr] makeFarBranches blocks | last blockAddresses < nearLimit = blocks | otherwise = zipWith handleBlock blockAddresses blocks @@ -587,12 +651,12 @@ handleBlock addr (BasicBlock id instrs) = BasicBlock id (zipWith makeFar [addr..] instrs) - makeFar _ (BCC ALWAYS tgt) = BCC ALWAYS tgt - makeFar addr (BCC cond tgt) + makeFar _ (PPC.Instr.BCC PPC.Cond.ALWAYS tgt) = PPC.Instr.BCC PPC.Cond.ALWAYS tgt + makeFar addr (PPC.Instr.BCC cond tgt) | abs (addr - targetAddr) >= nearLimit - = BCCFAR cond tgt + = PPC.Instr.BCCFAR cond tgt | otherwise - = BCC cond tgt + = PPC.Instr.BCC cond tgt where Just targetAddr = lookupUFM blockAddressMap tgt makeFar _ other = other @@ -603,30 +667,44 @@ -- things exactly blockAddressMap = listToUFM $ zip (map blockId blocks) blockAddresses -#else -makeFarBranches = id -#endif + +-- ----------------------------------------------------------------------------- +-- Generate jump tables + +-- Analyzes all native code and generates data sections for all jump +-- table instructions. +generateJumpTables + :: NcgImpl statics instr jumpDest + -> [NatCmmTop statics instr] -> [NatCmmTop statics instr] +generateJumpTables ncgImpl xs = concatMap f xs + where f p@(CmmProc _ _ (ListGraph xs)) = p : concatMap g xs + f p = [p] + g (BasicBlock _ xs) = catMaybes (map (generateJumpTableForInstr ncgImpl) xs) -- ----------------------------------------------------------------------------- -- Shortcut branches -shortcutBranches - :: DynFlags - -> [NatCmmTop Instr] - -> [NatCmmTop Instr] +shortcutBranches + :: DynFlags + -> NcgImpl statics instr jumpDest + -> [NatCmmTop statics instr] + -> [NatCmmTop statics instr] -shortcutBranches dflags tops +shortcutBranches dflags ncgImpl tops | optLevel dflags < 1 = tops -- only with -O or higher - | otherwise = map (apply_mapping mapping) tops' + | otherwise = map (apply_mapping ncgImpl mapping) tops' where - (tops', mappings) = mapAndUnzip build_mapping tops + (tops', mappings) = mapAndUnzip (build_mapping ncgImpl) tops mapping = foldr plusUFM emptyUFM mappings -build_mapping top@(CmmData _ _) = (top, emptyUFM) -build_mapping (CmmProc info lbl params (ListGraph [])) - = (CmmProc info lbl params (ListGraph []), emptyUFM) -build_mapping (CmmProc info lbl params (ListGraph (head:blocks))) - = (CmmProc info lbl params (ListGraph (head:others)), mapping) +build_mapping :: NcgImpl statics instr jumpDest + -> GenCmmTop d t (ListGraph instr) + -> (GenCmmTop d t (ListGraph instr), UniqFM jumpDest) +build_mapping _ top@(CmmData _ _) = (top, emptyUFM) +build_mapping _ (CmmProc info lbl (ListGraph [])) + = (CmmProc info lbl (ListGraph []), emptyUFM) +build_mapping ncgImpl (CmmProc info lbl (ListGraph (head:blocks))) + = (CmmProc info lbl (ListGraph (head:others)), mapping) -- drop the shorted blocks, but don't ever drop the first one, -- because it is pointed to by a global label. where @@ -635,12 +713,13 @@ -- Don't completely eliminate loops here -- that can leave a dangling jump! (_, shortcut_blocks, others) = foldl split (emptyBlockSet, [], []) blocks split (s, shortcut_blocks, others) b@(BasicBlock id [insn]) - | Just (DestBlockId dest) <- canShortcut insn, - (elemBlockSet dest s) || dest == id -- loop checks + | Just jd <- canShortcut ncgImpl insn, + Just dest <- getJumpDestBlockId ncgImpl jd, + (setMember dest s) || dest == id -- loop checks = (s, shortcut_blocks, b : others) split (s, shortcut_blocks, others) (BasicBlock id [insn]) - | Just dest <- canShortcut insn - = (extendBlockSet s id, (id,dest) : shortcut_blocks, others) + | Just dest <- canShortcut ncgImpl insn + = (setInsert id s, (id,dest) : shortcut_blocks, others) split (s, shortcut_blocks, others) other = (s, shortcut_blocks, other : others) @@ -648,15 +727,17 @@ mapping = foldl add emptyUFM shortcut_blocks add ufm (id,dest) = addToUFM ufm id dest -apply_mapping ufm (CmmData sec statics) - = CmmData sec (map (shortcutStatic (lookupUFM ufm)) statics) - -- we need to get the jump tables, so apply the mapping to the entries - -- of a CmmData too. -apply_mapping ufm (CmmProc info lbl params (ListGraph blocks)) - = CmmProc info lbl params (ListGraph $ map short_bb blocks) +apply_mapping :: NcgImpl statics instr jumpDest + -> UniqFM jumpDest + -> GenCmmTop statics h (ListGraph instr) + -> GenCmmTop statics h (ListGraph instr) +apply_mapping ncgImpl ufm (CmmData sec statics) + = CmmData sec (shortcutStatics ncgImpl (lookupUFM ufm) statics) +apply_mapping ncgImpl ufm (CmmProc info lbl (ListGraph blocks)) + = CmmProc info lbl (ListGraph $ map short_bb blocks) where short_bb (BasicBlock id insns) = BasicBlock id $! map short_insn insns - short_insn i = shortcutJump (lookupUFM ufm) i + short_insn i = shortcutJump ncgImpl (lookupUFM ufm) i -- shortcutJump should apply the mapping repeatedly, -- just in case we can short multiple branches. @@ -682,15 +763,16 @@ genMachCode :: DynFlags + -> (RawCmmTop -> NatM [NatCmmTop statics instr]) -> RawCmmTop -> UniqSM - ( [NatCmmTop Instr] + ( [NatCmmTop statics instr] , [CLabel]) -genMachCode dflags cmm_top +genMachCode dflags cmmTopCodeGen cmm_top = do { initial_us <- getUs ; let initial_st = mkNatM_State initial_us 0 dflags - (new_tops, final_st) = initNat initial_st (cmmTopCodeGen dflags cmm_top) + (new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top) final_delta = natm_delta final_st final_imports = natm_imports final_st ; if final_delta == 0 @@ -698,7 +780,6 @@ else pprPanic "genMachCode: nonzero final delta" (int final_delta) } - -- ----------------------------------------------------------------------------- -- Generic Cmm optimiser @@ -712,11 +793,15 @@ (i) introduce the appropriate indirections and position independent refs (ii) compile a list of imported symbols + (d) Some arch-specific optimizations -Ideas for other things we could do (ToDo): +(a) and (b) will be moving to the new Hoopl pipeline, however, (c) and +(d) are only needed by the native backend and will continue to live +here. + +Ideas for other things we could do (put these in Hoopl please!): - shortcut jumps-to-jumps - - eliminate dead code blocks - simple CSE: if an expr is assigned to a temp, then replace later occs of that expr with the temp, until the expr is no longer valid (can push through temp assignments, and certain assigns to mem...) @@ -724,9 +809,9 @@ cmmToCmm :: DynFlags -> RawCmmTop -> (RawCmmTop, [CLabel]) cmmToCmm _ top@(CmmData _ _) = (top, []) -cmmToCmm dflags (CmmProc info lbl params (ListGraph blocks)) = runCmmOpt dflags $ do - blocks' <- mapM cmmBlockConFold (cmmMiniInline blocks) - return $ CmmProc info lbl params (ListGraph blocks') +cmmToCmm dflags (CmmProc info lbl (ListGraph blocks)) = runCmmOpt dflags $ do + blocks' <- mapM cmmBlockConFold (cmmMiniInline (cmmEliminateDeadBlocks blocks)) + return $ CmmProc info lbl (ListGraph blocks') newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #)) @@ -740,7 +825,7 @@ CmmOptM g' -> g' (imports', dflags) addImportCmmOpt :: CLabel -> CmmOptM () -addImportCmmOpt lbl = CmmOptM $ \(imports, dflags) -> (# (), lbl:imports #) +addImportCmmOpt lbl = CmmOptM $ \(imports, _dflags) -> (# (), lbl:imports #) getDynFlagsCmmOpt :: CmmOptM DynFlags getDynFlagsCmmOpt = CmmOptM $ \(imports, dflags) -> (# dflags, imports #) @@ -754,6 +839,16 @@ stmts' <- mapM cmmStmtConFold stmts return $ BasicBlock id stmts' +-- This does three optimizations, but they're very quick to check, so we don't +-- bother turning them off even when the Hoopl code is active. Since +-- this is on the old Cmm representation, we can't reuse the code either: +-- * reg = reg --> nop +-- * if 0 then jump --> nop +-- * if 1 then jump --> jump +-- We might be tempted to skip this step entirely of not opt_PIC, but +-- there is some PowerPC code for the non-PIC case, which would also +-- have to be separated. +cmmStmtConFold :: CmmStmt -> CmmOptM CmmStmt cmmStmtConFold stmt = case stmt of CmmAssign reg src @@ -789,8 +884,8 @@ CmmComment (mkFastString ("deleted: " ++ showSDoc (pprStmt stmt))) - CmmLit (CmmInt n _) -> CmmBranch dest - other -> CmmCondBranch test' dest + CmmLit (CmmInt _ _) -> CmmBranch dest + _other -> CmmCondBranch test' dest CmmSwitch expr ids -> do expr' <- cmmExprConFold DataReference expr @@ -799,49 +894,63 @@ other -> return other - -cmmExprConFold referenceKind expr - = case expr of +cmmExprConFold :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr +cmmExprConFold referenceKind expr = do + dflags <- getDynFlagsCmmOpt + -- Skip constant folding if new code generator is running + -- (this optimization is done in Hoopl) + let expr' = if dopt Opt_TryNewCodeGen dflags + then expr + else cmmExprCon expr + cmmExprNative referenceKind expr' + +cmmExprCon :: CmmExpr -> CmmExpr +cmmExprCon (CmmLoad addr rep) = CmmLoad (cmmExprCon addr) rep +cmmExprCon (CmmMachOp mop args) = cmmMachOpFold mop (map cmmExprCon args) +cmmExprCon other = other + +-- handles both PIC and non-PIC cases... a very strange mixture +-- of things to do. +cmmExprNative :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr +cmmExprNative referenceKind expr = do + dflags <- getDynFlagsCmmOpt + let arch = platformArch (targetPlatform dflags) + case expr of CmmLoad addr rep - -> do addr' <- cmmExprConFold DataReference addr + -> do addr' <- cmmExprNative DataReference addr return $ CmmLoad addr' rep CmmMachOp mop args - -- For MachOps, we first optimize the children, and then we try - -- our hand at some constant-folding. - -> do args' <- mapM (cmmExprConFold DataReference) args - return $ cmmMachOpFold mop args' + -> do args' <- mapM (cmmExprNative DataReference) args + return $ CmmMachOp mop args' CmmLit (CmmLabel lbl) -> do - dflags <- getDynFlagsCmmOpt - cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl + cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl CmmLit (CmmLabelOff lbl off) -> do - dflags <- getDynFlagsCmmOpt - dynRef <- cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl + dynRef <- cmmMakeDynamicReference dflags addImportCmmOpt referenceKind lbl + -- need to optimize here, since it's late return $ cmmMachOpFold (MO_Add wordWidth) [ dynRef, (CmmLit $ CmmInt (fromIntegral off) wordWidth) ] -#if powerpc_TARGET_ARCH - -- On powerpc (non-PIC), it's easier to jump directly to a label than - -- to use the register table, so we replace these registers - -- with the corresponding labels: + -- On powerpc (non-PIC), it's easier to jump directly to a label than + -- to use the register table, so we replace these registers + -- with the corresponding labels: CmmReg (CmmGlobal EagerBlackholeInfo) - | not opt_PIC - -> cmmExprConFold referenceKind $ + | arch == ArchPPC && not opt_PIC + -> cmmExprNative referenceKind $ CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_EAGER_BLACKHOLE_info"))) CmmReg (CmmGlobal GCEnter1) - | not opt_PIC - -> cmmExprConFold referenceKind $ + | arch == ArchPPC && not opt_PIC + -> cmmExprNative referenceKind $ CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_enter_1"))) CmmReg (CmmGlobal GCFun) - | not opt_PIC - -> cmmExprConFold referenceKind $ + | arch == ArchPPC && not opt_PIC + -> cmmExprNative referenceKind $ CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "__stg_gc_fun"))) -#endif other -> return other diff -Nru ghc-7.0.3/compiler/nativeGen/Instruction.hs ghc-7.2.1/compiler/nativeGen/Instruction.hs --- ghc-7.0.3/compiler/nativeGen/Instruction.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/nativeGen/Instruction.hs 2011-08-07 17:10:05.000000000 +0000 @@ -1,11 +1,11 @@ module Instruction ( - RegUsage(..), - noUsage, - NatCmm, - NatCmmTop, - NatBasicBlock, - Instruction(..) + RegUsage(..), + noUsage, + NatCmm, + NatCmmTop, + NatBasicBlock, + Instruction(..) ) where @@ -13,20 +13,21 @@ import Reg import BlockId -import Cmm +import OldCmm +import Platform -- | Holds a list of source and destination registers used by a --- particular instruction. +-- particular instruction. -- -- Machine registers that are pre-allocated to stgRegs are filtered --- out, because they are uninteresting from a register allocation --- standpoint. (We wouldn't want them to end up on the free list!) +-- out, because they are uninteresting from a register allocation +-- standpoint. (We wouldn't want them to end up on the free list!) -- -- As far as we are concerned, the fixed registers simply don't exist --- (for allocation purposes, anyway). +-- (for allocation purposes, anyway). -- -data RegUsage - = RU [Reg] [Reg] +data RegUsage + = RU [Reg] [Reg] -- | No regs read or written to. noUsage :: RegUsage @@ -36,124 +37,127 @@ -- Our flavours of the Cmm types -- Type synonyms for Cmm populated with native code type NatCmm instr - = GenCmm - CmmStatic - [CmmStatic] - (ListGraph instr) - -type NatCmmTop instr - = GenCmmTop - CmmStatic - [CmmStatic] - (ListGraph instr) + = GenCmm + CmmStatics + (Maybe CmmStatics) + (ListGraph instr) + +type NatCmmTop statics instr + = GenCmmTop + statics + (Maybe CmmStatics) + (ListGraph instr) type NatBasicBlock instr - = GenBasicBlock instr + = GenBasicBlock instr -- | Common things that we can do with instructions, on all architectures. --- These are used by the shared parts of the native code generator, --- specifically the register allocators. +-- These are used by the shared parts of the native code generator, +-- specifically the register allocators. -- -class Instruction instr where - - -- | Get the registers that are being used by this instruction. - -- regUsage doesn't need to do any trickery for jumps and such. - -- Just state precisely the regs read and written by that insn. - -- The consequences of control flow transfers, as far as register - -- allocation goes, are taken care of by the register allocator. - -- - regUsageOfInstr - :: instr - -> RegUsage - - - -- | Apply a given mapping to all the register references in this - -- instruction. - patchRegsOfInstr - :: instr - -> (Reg -> Reg) - -> instr - - - -- | Checks whether this instruction is a jump/branch instruction. - -- One that can change the flow of control in a way that the - -- register allocator needs to worry about. - isJumpishInstr - :: instr -> Bool - - - -- | Give the possible destinations of this jump instruction. - -- Must be defined for all jumpish instructions. - jumpDestsOfInstr - :: instr -> [BlockId] - - - -- | Change the destination of this jump instruction. - -- Used in the linear allocator when adding fixup blocks for join - -- points. - patchJumpInstr - :: instr - -> (BlockId -> BlockId) - -> instr - - - -- | An instruction to spill a register into a spill slot. - mkSpillInstr - :: Reg -- ^ the reg to spill - -> Int -- ^ the current stack delta - -> Int -- ^ spill slot to use - -> instr - - - -- | An instruction to reload a register from a spill slot. - mkLoadInstr - :: Reg -- ^ the reg to reload. - -> Int -- ^ the current stack delta - -> Int -- ^ the spill slot to use - -> instr - - -- | See if this instruction is telling us the current C stack delta - takeDeltaInstr - :: instr - -> Maybe Int - - -- | Check whether this instruction is some meta thing inserted into - -- the instruction stream for other purposes. - -- - -- Not something that has to be treated as a real machine instruction - -- and have its registers allocated. - -- - -- eg, comments, delta, ldata, etc. - isMetaInstr - :: instr - -> Bool - - - - -- | Copy the value in a register to another one. - -- Must work for all register classes. - mkRegRegMoveInstr - :: Reg -- ^ source register - -> Reg -- ^ destination register - -> instr - - -- | Take the source and destination from this reg -> reg move instruction - -- or Nothing if it's not one - takeRegRegMoveInstr - :: instr - -> Maybe (Reg, Reg) - - -- | Make an unconditional jump instruction. - -- For architectures with branch delay slots, its ok to put - -- a NOP after the jump. Don't fill the delay slot with an - -- instruction that references regs or you'll confuse the - -- linear allocator. - mkJumpInstr - :: BlockId - -> [instr] - - +class Instruction instr where + + -- | Get the registers that are being used by this instruction. + -- regUsage doesn't need to do any trickery for jumps and such. + -- Just state precisely the regs read and written by that insn. + -- The consequences of control flow transfers, as far as register + -- allocation goes, are taken care of by the register allocator. + -- + regUsageOfInstr + :: instr + -> RegUsage + + + -- | Apply a given mapping to all the register references in this + -- instruction. + patchRegsOfInstr + :: instr + -> (Reg -> Reg) + -> instr + + + -- | Checks whether this instruction is a jump/branch instruction. + -- One that can change the flow of control in a way that the + -- register allocator needs to worry about. + isJumpishInstr + :: instr -> Bool + + + -- | Give the possible destinations of this jump instruction. + -- Must be defined for all jumpish instructions. + jumpDestsOfInstr + :: instr -> [BlockId] + + + -- | Change the destination of this jump instruction. + -- Used in the linear allocator when adding fixup blocks for join + -- points. + patchJumpInstr + :: instr + -> (BlockId -> BlockId) + -> instr + + + -- | An instruction to spill a register into a spill slot. + mkSpillInstr + :: Platform + -> Reg -- ^ the reg to spill + -> Int -- ^ the current stack delta + -> Int -- ^ spill slot to use + -> instr + + + -- | An instruction to reload a register from a spill slot. + mkLoadInstr + :: Platform + -> Reg -- ^ the reg to reload. + -> Int -- ^ the current stack delta + -> Int -- ^ the spill slot to use + -> instr + + -- | See if this instruction is telling us the current C stack delta + takeDeltaInstr + :: instr + -> Maybe Int + + -- | Check whether this instruction is some meta thing inserted into + -- the instruction stream for other purposes. + -- + -- Not something that has to be treated as a real machine instruction + -- and have its registers allocated. + -- + -- eg, comments, delta, ldata, etc. + isMetaInstr + :: instr + -> Bool + + + + -- | Copy the value in a register to another one. + -- Must work for all register classes. + mkRegRegMoveInstr + :: Platform + -> Reg -- ^ source register + -> Reg -- ^ destination register + -> instr + + -- | Take the source and destination from this reg -> reg move instruction + -- or Nothing if it's not one + takeRegRegMoveInstr + :: instr + -> Maybe (Reg, Reg) + + -- | Make an unconditional jump instruction. + -- For architectures with branch delay slots, its ok to put + -- a NOP after the jump. Don't fill the delay slot with an + -- instruction that references regs or you'll confuse the + -- linear allocator. + mkJumpInstr + :: BlockId + -> [instr] + + diff -Nru ghc-7.0.3/compiler/nativeGen/NCG.h ghc-7.2.1/compiler/nativeGen/NCG.h --- ghc-7.0.3/compiler/nativeGen/NCG.h 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/nativeGen/NCG.h 2011-08-07 17:10:05.000000000 +0000 @@ -14,97 +14,18 @@ #define COMMA , -- - - - - - - - - - - - - - - - - - - - - - -#if alpha_TARGET_ARCH -# define IF_ARCH_alpha(x,y) x -#else -# define IF_ARCH_alpha(x,y) y -#endif --- - - - - - - - - - - - - - - - - - - - - - #if i386_TARGET_ARCH # define IF_ARCH_i386(x,y) x #else # define IF_ARCH_i386(x,y) y #endif -- - - - - - - - - - - - - - - - - - - - - - -#if x86_64_TARGET_ARCH -# define IF_ARCH_x86_64(x,y) x -#else -# define IF_ARCH_x86_64(x,y) y -#endif --- - - - - - - - - - - - - - - - - - - - - - -#if freebsd_TARGET_OS -# define IF_OS_freebsd(x,y) x -#else -# define IF_OS_freebsd(x,y) y -#endif --- - - - - - - - - - - - - - - - - - - - - - -#if dragonfly_TARGET_OS -# define IF_OS_dragonfly(x,y) x -#else -# define IF_OS_dragonfly(x,y) y -#endif --- - - - - - - - - - - - - - - - - - - - - - -#if netbsd_TARGET_OS -# define IF_OS_netbsd(x,y) x -#else -# define IF_OS_netbsd(x,y) y -#endif --- - - - - - - - - - - - - - - - - - - - - - -#if openbsd_TARGET_OS -# define IF_OS_openbsd(x,y) x -#else -# define IF_OS_openbsd(x,y) y -#endif --- - - - - - - - - - - - - - - - - - - - - - #if linux_TARGET_OS # define IF_OS_linux(x,y) x #else # define IF_OS_linux(x,y) y #endif -- - - - - - - - - - - - - - - - - - - - - - -#if linuxaout_TARGET_OS -# define IF_OS_linuxaout(x,y) x -#else -# define IF_OS_linuxaout(x,y) y -#endif --- - - - - - - - - - - - - - - - - - - - - - -#if bsdi_TARGET_OS -# define IF_OS_bsdi(x,y) x -#else -# define IF_OS_bsdi(x,y) y -#endif --- - - - - - - - - - - - - - - - - - - - - - -#if cygwin32_TARGET_OS -# define IF_OS_cygwin32(x,y) x -#else -# define IF_OS_cygwin32(x,y) y -#endif --- - - - - - - - - - - - - - - - - - - - - - -#if sparc_TARGET_ARCH -# define IF_ARCH_sparc(x,y) x -#else -# define IF_ARCH_sparc(x,y) y -#endif --- - - - - - - - - - - - - - - - - - - - - - -#if sunos4_TARGET_OS -# define IF_OS_sunos4(x,y) x -#else -# define IF_OS_sunos4(x,y) y -#endif --- - - - - - - - - - - - - - - - - - - - - - --- NB: this will catch i386-*-solaris2, too -#if solaris2_TARGET_OS -# define IF_OS_solaris2(x,y) x -#else -# define IF_OS_solaris2(x,y) y -#endif --- - - - - - - - - - - - - - - - - - - - - - -#if powerpc_TARGET_ARCH -# define IF_ARCH_powerpc(x,y) x -#else -# define IF_ARCH_powerpc(x,y) y -#endif --- - - - - - - - - - - - - - - - - - - - - - #if darwin_TARGET_OS # define IF_OS_darwin(x,y) x #else diff -Nru ghc-7.0.3/compiler/nativeGen/NCGMonad.hs ghc-7.2.1/compiler/nativeGen/NCGMonad.hs --- ghc-7.0.3/compiler/nativeGen/NCGMonad.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/nativeGen/NCGMonad.hs 2011-08-07 17:10:05.000000000 +0000 @@ -90,8 +90,8 @@ getUniqueNat :: NatM Unique getUniqueNat = NatM $ \ (NatM_State us delta imports pic dflags) -> - case splitUniqSupply us of - (us1,us2) -> (uniqFromSupply us1, (NatM_State us2 delta imports pic dflags)) + case takeUniqFromSupply us of + (uniq, us') -> (uniq, (NatM_State us' delta imports pic dflags)) getDynFlagsNat :: NatM DynFlags @@ -120,7 +120,7 @@ getBlockIdNat :: NatM BlockId getBlockIdNat = do u <- getUniqueNat - return (BlockId u) + return (mkBlockId u) getNewLabelNat :: NatM CLabel @@ -130,18 +130,20 @@ getNewRegNat :: Size -> NatM Reg -getNewRegNat rep - = do u <- getUniqueNat - return (RegVirtual $ targetMkVirtualReg u rep) +getNewRegNat rep + = do u <- getUniqueNat + dflags <- getDynFlagsNat + return (RegVirtual $ targetMkVirtualReg (targetPlatform dflags) u rep) getNewRegPairNat :: Size -> NatM (Reg,Reg) -getNewRegPairNat rep - = do u <- getUniqueNat - let vLo = targetMkVirtualReg u rep - let lo = RegVirtual $ targetMkVirtualReg u rep - let hi = RegVirtual $ getHiVirtualRegFromLo vLo - return (lo, hi) +getNewRegPairNat rep + = do u <- getUniqueNat + dflags <- getDynFlagsNat + let vLo = targetMkVirtualReg (targetPlatform dflags) u rep + let lo = RegVirtual $ targetMkVirtualReg (targetPlatform dflags) u rep + let hi = RegVirtual $ getHiVirtualRegFromLo vLo + return (lo, hi) getPicBaseMaybeNat :: NatM (Maybe Reg) diff -Nru ghc-7.0.3/compiler/nativeGen/PIC.hs ghc-7.2.1/compiler/nativeGen/PIC.hs --- ghc-7.0.3/compiler/nativeGen/PIC.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/nativeGen/PIC.hs 2011-08-07 17:10:05.000000000 +0000 @@ -63,7 +63,7 @@ import NCGMonad -import Cmm +import OldCmm import CLabel ( CLabel, ForeignLabelSource(..), pprCLabel, mkDynamicLinkerLabel, DynamicLinkerLabelInfo(..), dynamicLinkerLabelInfo, mkPicBaseLabel, @@ -709,18 +709,17 @@ initializePicBase_ppc :: Arch -> OS -> Reg - -> [NatCmmTop PPC.Instr] - -> NatM [NatCmmTop PPC.Instr] + -> [NatCmmTop CmmStatics PPC.Instr] + -> NatM [NatCmmTop CmmStatics PPC.Instr] initializePicBase_ppc ArchPPC os picReg - (CmmProc info lab params (ListGraph blocks) : statics) + (CmmProc info lab (ListGraph blocks) : statics) | osElfTarget os = do gotOffLabel <- getNewLabelNat tmp <- getNewRegNat $ intSize wordWidth let - gotOffset = CmmData Text [ - CmmDataLabel gotOffLabel, + gotOffset = CmmData Text $ Statics gotOffLabel [ CmmStaticLit (CmmLabelDiffOff gotLabel mkPicBaseLabel 0) @@ -739,11 +738,11 @@ : PPC.ADD picReg picReg (PPC.RIReg tmp) : insns) - return (CmmProc info lab params (ListGraph (b' : tail blocks)) : gotOffset : statics) + return (CmmProc info lab (ListGraph (b' : tail blocks)) : gotOffset : statics) initializePicBase_ppc ArchPPC OSDarwin picReg - (CmmProc info lab params (ListGraph blocks) : statics) - = return (CmmProc info lab params (ListGraph (b':tail blocks)) : statics) + (CmmProc info lab (ListGraph blocks) : statics) + = return (CmmProc info lab (ListGraph (b':tail blocks)) : statics) where BasicBlock bID insns = head blocks b' = BasicBlock bID (PPC.FETCHPC picReg : insns) @@ -762,19 +761,19 @@ initializePicBase_x86 :: Arch -> OS -> Reg - -> [NatCmmTop X86.Instr] - -> NatM [NatCmmTop X86.Instr] + -> [NatCmmTop (Alignment, CmmStatics) X86.Instr] + -> NatM [NatCmmTop (Alignment, CmmStatics) X86.Instr] initializePicBase_x86 ArchX86 os picReg - (CmmProc info lab params (ListGraph blocks) : statics) + (CmmProc info lab (ListGraph blocks) : statics) | osElfTarget os - = return (CmmProc info lab params (ListGraph (b':tail blocks)) : statics) + = return (CmmProc info lab (ListGraph (b':tail blocks)) : statics) where BasicBlock bID insns = head blocks b' = BasicBlock bID (X86.FETCHGOT picReg : insns) initializePicBase_x86 ArchX86 OSDarwin picReg - (CmmProc info lab params (ListGraph blocks) : statics) - = return (CmmProc info lab params (ListGraph (b':tail blocks)) : statics) + (CmmProc info lab (ListGraph blocks) : statics) + = return (CmmProc info lab (ListGraph (b':tail blocks)) : statics) where BasicBlock bID insns = head blocks b' = BasicBlock bID (X86.FETCHPC picReg : insns) diff -Nru ghc-7.0.3/compiler/nativeGen/Platform.hs ghc-7.2.1/compiler/nativeGen/Platform.hs --- ghc-7.0.3/compiler/nativeGen/Platform.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/nativeGen/Platform.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,107 +0,0 @@ - --- | A description of the platform we're compiling for. --- Used by the native code generator. --- In the future, this module should be the only one that references --- the evil #defines for each TARGET_ARCH and TARGET_OS --- -module Platform ( - Platform(..), - Arch(..), - OS(..), - - defaultTargetPlatform, - osElfTarget -) - -where - -#include "HsVersions.h" - - --- | Contains enough information for the native code generator to emit --- code for this platform. -data Platform - = Platform - { platformArch :: Arch - , platformOS :: OS } - - --- | Architectures that the native code generator knows about. --- TODO: It might be nice to extend these constructors with information --- about what instruction set extensions an architecture might support. --- -data Arch - = ArchAlpha - | ArchX86 - | ArchX86_64 - | ArchPPC - | ArchPPC_64 - | ArchSPARC - deriving (Show, Eq) - - --- | Operating systems that the native code generator knows about. --- Having OSUnknown should produce a sensible default, but no promises. -data OS - = OSUnknown - | OSLinux - | OSDarwin - | OSSolaris2 - | OSMinGW32 - | OSFreeBSD - | OSOpenBSD - deriving (Show, Eq) - - --- | This predicates tells us whether the OS supports ELF-like shared libraries. -osElfTarget :: OS -> Bool -osElfTarget OSLinux = True -osElfTarget OSFreeBSD = True -osElfTarget OSOpenBSD = True -osElfTarget OSSolaris2 = True -osElfTarget _ = False - --- | This is the target platform as far as the #ifdefs are concerned. --- These are set in includes/ghcplatform.h by the autoconf scripts -defaultTargetPlatform :: Platform -defaultTargetPlatform - = Platform defaultTargetArch defaultTargetOS - - --- | Move the evil TARGET_ARCH #ifdefs into Haskell land. -defaultTargetArch :: Arch -#if alpha_TARGET_ARCH -defaultTargetArch = ArchAlpha -#elif i386_TARGET_ARCH -defaultTargetArch = ArchX86 -#elif x86_64_TARGET_ARCH -defaultTargetArch = ArchX86_64 -#elif powerpc_TARGET_ARCH -defaultTargetArch = ArchPPC -#elif powerpc64_TARGET_ARCH -defaultTargetArch = ArchPPC_64 -#elif sparc_TARGET_ARCH -defaultTargetArch = ArchSPARC -#else -#error "Platform.buildArch: undefined" -#endif - - --- | Move the evil TARGET_OS #ifdefs into Haskell land. -defaultTargetOS :: OS -#if linux_TARGET_OS -defaultTargetOS = OSLinux -#elif darwin_TARGET_OS -defaultTargetOS = OSDarwin -#elif solaris2_TARGET_OS -defaultTargetOS = OSSolaris2 -#elif mingw32_TARGET_OS -defaultTargetOS = OSMinGW32 -#elif freebsd_TARGET_OS -defaultTargetOS = OSFreeBSD -#elif openbsd_TARGET_OS -defaultTargetOS = OSOpenBSD -#else -defaultTargetOS = OSUnknown -#endif - diff -Nru ghc-7.0.3/compiler/nativeGen/PPC/CodeGen.hs ghc-7.2.1/compiler/nativeGen/PPC/CodeGen.hs --- ghc-7.0.3/compiler/nativeGen/PPC/CodeGen.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/nativeGen/PPC/CodeGen.hs 2011-08-07 17:10:05.000000000 +0000 @@ -1,4 +1,3 @@ -{-# OPTIONS -w #-} ----------------------------------------------------------------------------- -- @@ -13,10 +12,11 @@ -- (c) the #if blah_TARGET_ARCH} things, the -- structure should not be too overwhelming. -module PPC.CodeGen ( - cmmTopCodeGen, - InstrBlock -) +module PPC.CodeGen ( + cmmTopCodeGen, + generateJumpTableForInstr, + InstrBlock +) where @@ -28,7 +28,6 @@ import PPC.Instr import PPC.Cond import PPC.Regs -import PPC.RegInfo import NCGMonad import Instruction import PIC @@ -40,26 +39,23 @@ -- Our intermediate code: import BlockId -import PprCmm ( pprExpr ) -import Cmm +import PprCmm ( pprExpr ) +import OldCmm import CLabel -- The rest: -import StaticFlags ( opt_PIC ) +import StaticFlags ( opt_PIC ) import OrdList -import qualified Outputable as O import Outputable +import Unique import DynFlags -import Control.Monad ( mapAndUnzipM ) +import Control.Monad ( mapAndUnzipM ) import Data.Bits -import Data.Int import Data.Word -#if darwin_TARGET_OS || linux_TARGET_OS import BasicTypes import FastString -#endif -- ----------------------------------------------------------------------------- -- Top-level of the instruction selector @@ -69,28 +65,28 @@ -- left-to-right traversal (pre-order?) yields the insns in the correct -- order. -cmmTopCodeGen - :: DynFlags - -> RawCmmTop - -> NatM [NatCmmTop Instr] +cmmTopCodeGen + :: RawCmmTop + -> NatM [NatCmmTop CmmStatics Instr] -cmmTopCodeGen dflags (CmmProc info lab params (ListGraph blocks)) = do +cmmTopCodeGen (CmmProc info lab (ListGraph blocks)) = do (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks picBaseMb <- getPicBaseMaybeNat - let proc = CmmProc info lab params (ListGraph $ concat nat_blocks) + dflags <- getDynFlagsNat + let proc = CmmProc info lab (ListGraph $ concat nat_blocks) tops = proc : concat statics os = platformOS $ targetPlatform dflags case picBaseMb of Just picBase -> initializePicBase_ppc ArchPPC os picBase tops Nothing -> return tops - -cmmTopCodeGen dflags (CmmData sec dat) = do + +cmmTopCodeGen (CmmData sec dat) = do return [CmmData sec dat] -- no translation, we just use CmmStatic -basicBlockCodeGen - :: CmmBasicBlock - -> NatM ( [NatBasicBlock Instr] - , [NatCmmTop Instr]) +basicBlockCodeGen + :: CmmBasicBlock + -> NatM ( [NatBasicBlock Instr] + , [NatCmmTop CmmStatics Instr]) basicBlockCodeGen (BasicBlock id stmts) = do instrs <- stmtsToInstrs stmts @@ -99,14 +95,14 @@ -- instruction stream into basic blocks again. Also, we extract -- LDATAs here too. let - (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs - - mkBlocks (NEWBLOCK id) (instrs,blocks,statics) - = ([], BasicBlock id instrs : blocks, statics) - mkBlocks (LDATA sec dat) (instrs,blocks,statics) - = (instrs, blocks, CmmData sec dat:statics) - mkBlocks instr (instrs,blocks,statics) - = (instr:instrs, blocks, statics) + (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs + + mkBlocks (NEWBLOCK id) (instrs,blocks,statics) + = ([], BasicBlock id instrs : blocks, statics) + mkBlocks (LDATA sec dat) (instrs,blocks,statics) + = (instrs, blocks, CmmData sec dat:statics) + mkBlocks instr (instrs,blocks,statics) + = (instr:instrs, blocks, statics) -- in return (BasicBlock id top : other_blocks, statics) @@ -116,56 +112,56 @@ return (concatOL instrss) stmtToInstrs :: CmmStmt -> NatM InstrBlock -stmtToInstrs stmt = case stmt of - CmmNop -> return nilOL +stmtToInstrs stmt = do + dflags <- getDynFlagsNat + case stmt of + CmmNop -> return nilOL CmmComment s -> return (unitOL (COMMENT s)) CmmAssign reg src | isFloatType ty -> assignReg_FltCode size reg src -#if WORD_SIZE_IN_BITS==32 - | isWord64 ty -> assignReg_I64Code reg src -#endif - | otherwise -> assignReg_IntCode size reg src - where ty = cmmRegType reg - size = cmmTypeSize ty + | target32Bit (targetPlatform dflags) && + isWord64 ty -> assignReg_I64Code reg src + | otherwise -> assignReg_IntCode size reg src + where ty = cmmRegType reg + size = cmmTypeSize ty CmmStore addr src | isFloatType ty -> assignMem_FltCode size addr src -#if WORD_SIZE_IN_BITS==32 - | isWord64 ty -> assignMem_I64Code addr src -#endif - | otherwise -> assignMem_IntCode size addr src - where ty = cmmExprType src - size = cmmTypeSize ty + | target32Bit (targetPlatform dflags) && + isWord64 ty -> assignMem_I64Code addr src + | otherwise -> assignMem_IntCode size addr src + where ty = cmmExprType src + size = cmmTypeSize ty CmmCall target result_regs args _ _ -> genCCall target result_regs args - CmmBranch id -> genBranch id + CmmBranch id -> genBranch id CmmCondBranch arg id -> genCondJump id arg CmmSwitch arg ids -> genSwitch arg ids - CmmJump arg params -> genJump arg - CmmReturn params -> + CmmJump arg _ -> genJump arg + CmmReturn _ -> panic "stmtToInstrs: return statement should have been cps'd away" -------------------------------------------------------------------------------- -- | 'InstrBlock's are the insn sequences generated by the insn selectors. --- They are really trees of insns to facilitate fast appending, where a --- left-to-right traversal yields the insns in the correct order. +-- They are really trees of insns to facilitate fast appending, where a +-- left-to-right traversal yields the insns in the correct order. -- -type InstrBlock - = OrdList Instr +type InstrBlock + = OrdList Instr -- | Register's passed up the tree. If the stix code forces the register --- to live in a pre-decided machine register, it comes out as @Fixed@; --- otherwise, it comes out as @Any@, and the parent can decide which --- register to put it in. +-- to live in a pre-decided machine register, it comes out as @Fixed@; +-- otherwise, it comes out as @Any@, and the parent can decide which +-- register to put it in. -- data Register - = Fixed Size Reg InstrBlock - | Any Size (Reg -> InstrBlock) + = Fixed Size Reg InstrBlock + | Any Size (Reg -> InstrBlock) swizzleRegisterRep :: Register -> Size -> Register @@ -207,22 +203,11 @@ -} --- | Check whether an integer will fit in 32 bits. --- A CmmInt is intended to be truncated to the appropriate --- number of bits, so here we truncate it to Int64. This is --- important because e.g. -1 as a CmmInt might be either --- -1 or 18446744073709551615. --- -is32BitInteger :: Integer -> Bool -is32BitInteger i = i64 <= 0x7fffffff && i64 >= -0x80000000 - where i64 = fromIntegral i :: Int64 - - -- | Convert a BlockId to some CmmStatic data jumpTableEntry :: Maybe BlockId -> CmmStatic jumpTableEntry Nothing = CmmStaticLit (CmmInt 0 wordWidth) -jumpTableEntry (Just (BlockId id)) = CmmStaticLit (CmmLabel blockLabel) - where blockLabel = mkAsmTempLabel id +jumpTableEntry (Just blockid) = CmmStaticLit (CmmLabel blockLabel) + where blockLabel = mkAsmTempLabel (getUnique blockid) @@ -237,7 +222,7 @@ where width = typeWidth (cmmRegType reg) mangleIndexTree _ - = panic "PPC.CodeGen.mangleIndexTree: no match" + = panic "PPC.CodeGen.mangleIndexTree: no match" -- ----------------------------------------------------------------------------- -- Code gen for 64-bit arithmetic on 32-bit platforms @@ -255,27 +240,27 @@ by applying getHiVRegFromLo to it. -} -data ChildCode64 -- a.k.a "Register64" - = ChildCode64 - InstrBlock -- code - Reg -- the lower 32-bit temporary which contains the - -- result; use getHiVRegFromLo to find the other - -- VRegUnique. Rules of this simplified insn - -- selection game are therefore that the returned - -- Reg may be modified +data ChildCode64 -- a.k.a "Register64" + = ChildCode64 + InstrBlock -- code + Reg -- the lower 32-bit temporary which contains the + -- result; use getHiVRegFromLo to find the other + -- VRegUnique. Rules of this simplified insn + -- selection game are therefore that the returned + -- Reg may be modified -- | The dual to getAnyReg: compute an expression into a register, but --- we don't mind which one it is. +-- we don't mind which one it is. getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock) getSomeReg expr = do r <- getRegister expr case r of Any rep code -> do - tmp <- getNewRegNat rep - return (tmp, code tmp) - Fixed _ reg code -> - return (reg, code) + tmp <- getNewRegNat rep + return (tmp, code tmp) + Fixed _ reg code -> + return (reg, code) getI64Amodes :: CmmExpr -> NatM (AddrMode, AddrMode, InstrBlock) getI64Amodes addrTree = do @@ -291,21 +276,21 @@ assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM InstrBlock assignMem_I64Code addrTree valueTree = do (hi_addr, lo_addr, addr_code) <- getI64Amodes addrTree - ChildCode64 vcode rlo <- iselExpr64 valueTree - let - rhi = getHiVRegFromLo rlo - - -- Big-endian store - mov_hi = ST II32 rhi hi_addr - mov_lo = ST II32 rlo lo_addr - -- in - return (vcode `appOL` addr_code `snocOL` mov_lo `snocOL` mov_hi) + ChildCode64 vcode rlo <- iselExpr64 valueTree + let + rhi = getHiVRegFromLo rlo + + -- Big-endian store + mov_hi = ST II32 rhi hi_addr + mov_lo = ST II32 rlo lo_addr + -- in + return (vcode `appOL` addr_code `snocOL` mov_lo `snocOL` mov_hi) assignReg_I64Code :: CmmReg -> CmmExpr -> NatM InstrBlock -assignReg_I64Code (CmmLocal (LocalReg u_dst pk)) valueTree = do +assignReg_I64Code (CmmLocal (LocalReg u_dst _)) valueTree = do ChildCode64 vcode r_src_lo <- iselExpr64 valueTree - let + let r_dst_lo = RegVirtual $ mkVirtualReg u_dst II32 r_dst_hi = getHiVRegFromLo r_dst_lo r_src_hi = getHiVRegFromLo r_src_lo @@ -316,7 +301,7 @@ vcode `snocOL` mov_lo `snocOL` mov_hi ) -assignReg_I64Code lvalue valueTree +assignReg_I64Code _ _ = panic "assignReg_I64Code(powerpc): invalid lvalue" @@ -326,7 +311,7 @@ (rlo, rhi) <- getNewRegPairNat II32 let mov_hi = LD II32 rhi hi_addr mov_lo = LD II32 rlo lo_addr - return $ ChildCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi) + return $ ChildCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi) rlo iselExpr64 (CmmReg (CmmLocal (LocalReg vu ty))) | isWord64 ty @@ -335,17 +320,17 @@ iselExpr64 (CmmLit (CmmInt i _)) = do (rlo,rhi) <- getNewRegPairNat II32 let - half0 = fromIntegral (fromIntegral i :: Word16) - half1 = fromIntegral ((fromIntegral i `shiftR` 16) :: Word16) - half2 = fromIntegral ((fromIntegral i `shiftR` 32) :: Word16) - half3 = fromIntegral ((fromIntegral i `shiftR` 48) :: Word16) - - code = toOL [ - LIS rlo (ImmInt half1), - OR rlo rlo (RIImm $ ImmInt half0), - LIS rhi (ImmInt half3), - OR rlo rlo (RIImm $ ImmInt half2) - ] + half0 = fromIntegral (fromIntegral i :: Word16) + half1 = fromIntegral ((fromIntegral i `shiftR` 16) :: Word16) + half2 = fromIntegral ((fromIntegral i `shiftR` 32) :: Word16) + half3 = fromIntegral ((fromIntegral i `shiftR` 48) :: Word16) + + code = toOL [ + LIS rlo (ImmInt half1), + OR rlo rlo (RIImm $ ImmInt half0), + LIS rhi (ImmInt half3), + OR rlo rlo (RIImm $ ImmInt half2) + ] -- in return (ChildCode64 code rlo) @@ -354,12 +339,12 @@ ChildCode64 code2 r2lo <- iselExpr64 e2 (rlo,rhi) <- getNewRegPairNat II32 let - r1hi = getHiVRegFromLo r1lo - r2hi = getHiVRegFromLo r2lo - code = code1 `appOL` - code2 `appOL` - toOL [ ADDC rlo r1lo r2lo, - ADDE rhi r1hi r2hi ] + r1hi = getHiVRegFromLo r1lo + r2hi = getHiVRegFromLo r2lo + code = code1 `appOL` + code2 `appOL` + toOL [ ADDC rlo r1lo r2lo, + ADDE rhi r1hi r2hi ] -- in return (ChildCode64 code rlo) @@ -376,70 +361,74 @@ getRegister :: CmmExpr -> NatM Register +getRegister e = do dflags <- getDynFlagsNat + getRegister' dflags e + +getRegister' :: DynFlags -> CmmExpr -> NatM Register -getRegister (CmmReg (CmmGlobal PicBaseReg)) +getRegister' _ (CmmReg (CmmGlobal PicBaseReg)) = do reg <- getPicBaseNat archWordSize return (Fixed archWordSize reg nilOL) -getRegister (CmmReg reg) - = return (Fixed (cmmTypeSize (cmmRegType reg)) - (getRegisterReg reg) nilOL) +getRegister' _ (CmmReg reg) + = return (Fixed (cmmTypeSize (cmmRegType reg)) + (getRegisterReg reg) nilOL) -getRegister tree@(CmmRegOff _ _) - = getRegister (mangleIndexTree tree) +getRegister' dflags tree@(CmmRegOff _ _) + = getRegister' dflags (mangleIndexTree tree) - -#if WORD_SIZE_IN_BITS==32 -- for 32-bit architectuers, support some 64 -> 32 bit conversions: -- TO_W_(x), TO_W_(x >> 32) -getRegister (CmmMachOp (MO_UU_Conv W64 W32) - [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do +getRegister' dflags (CmmMachOp (MO_UU_Conv W64 W32) + [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) + | target32Bit (targetPlatform dflags) = do ChildCode64 code rlo <- iselExpr64 x return $ Fixed II32 (getHiVRegFromLo rlo) code -getRegister (CmmMachOp (MO_SS_Conv W64 W32) - [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do +getRegister' dflags (CmmMachOp (MO_SS_Conv W64 W32) + [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) + | target32Bit (targetPlatform dflags) = do ChildCode64 code rlo <- iselExpr64 x return $ Fixed II32 (getHiVRegFromLo rlo) code -getRegister (CmmMachOp (MO_UU_Conv W64 W32) [x]) = do +getRegister' dflags (CmmMachOp (MO_UU_Conv W64 W32) [x]) + | target32Bit (targetPlatform dflags) = do ChildCode64 code rlo <- iselExpr64 x return $ Fixed II32 rlo code -getRegister (CmmMachOp (MO_SS_Conv W64 W32) [x]) = do +getRegister' dflags (CmmMachOp (MO_SS_Conv W64 W32) [x]) + | target32Bit (targetPlatform dflags) = do ChildCode64 code rlo <- iselExpr64 x - return $ Fixed II32 rlo code - -#endif - + return $ Fixed II32 rlo code -getRegister (CmmLoad mem pk) +getRegister' dflags (CmmLoad mem pk) | not (isWord64 pk) = do + let platform = targetPlatform dflags Amode addr addr_code <- getAmode mem - let code dst = ASSERT((targetClassOfReg dst == RcDouble) == isFloatType pk) + let code dst = ASSERT((targetClassOfReg platform dst == RcDouble) == isFloatType pk) addr_code `snocOL` LD size dst addr return (Any size code) where size = cmmTypeSize pk -- catch simple cases of zero- or sign-extended load -getRegister (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad mem _]) = do +getRegister' _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad mem _]) = do Amode addr addr_code <- getAmode mem return (Any II32 (\dst -> addr_code `snocOL` LD II8 dst addr)) -- Note: there is no Load Byte Arithmetic instruction, so no signed case here -getRegister (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad mem _]) = do +getRegister' _ (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad mem _]) = do Amode addr addr_code <- getAmode mem return (Any II32 (\dst -> addr_code `snocOL` LD II16 dst addr)) -getRegister (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad mem _]) = do +getRegister' _ (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad mem _]) = do Amode addr addr_code <- getAmode mem return (Any II32 (\dst -> addr_code `snocOL` LA II16 dst addr)) -getRegister (CmmMachOp mop [x]) -- unary MachOps +getRegister' dflags (CmmMachOp mop [x]) -- unary MachOps = case mop of MO_Not rep -> triv_ucode_int rep NOT @@ -467,25 +456,25 @@ MO_UU_Conv W32 to -> conversionNop (intSize to) x MO_UU_Conv W16 W8 -> conversionNop II8 x MO_UU_Conv W8 to -> trivialCode to False AND x (CmmLit (CmmInt 255 W32)) - MO_UU_Conv W16 to -> trivialCode to False AND x (CmmLit (CmmInt 65535 W32)) - _ -> panic "PPC.CodeGen.getRegister: no match" + MO_UU_Conv W16 to -> trivialCode to False AND x (CmmLit (CmmInt 65535 W32)) + _ -> panic "PPC.CodeGen.getRegister: no match" where - triv_ucode_int width instr = trivialUCode (intSize width) instr x - triv_ucode_float width instr = trivialUCode (floatSize width) instr x + triv_ucode_int width instr = trivialUCode (intSize width) instr x + triv_ucode_float width instr = trivialUCode (floatSize width) instr x conversionNop new_size expr - = do e_code <- getRegister expr + = do e_code <- getRegister' dflags expr return (swizzleRegisterRep e_code new_size) -getRegister (CmmMachOp mop [x, y]) -- dyadic PrimOps +getRegister' _ (CmmMachOp mop [x, y]) -- dyadic PrimOps = case mop of - MO_F_Eq w -> condFltReg EQQ x y - MO_F_Ne w -> condFltReg NE x y - MO_F_Gt w -> condFltReg GTT x y - MO_F_Ge w -> condFltReg GE x y - MO_F_Lt w -> condFltReg LTT x y - MO_F_Le w -> condFltReg LE x y + MO_F_Eq _ -> condFltReg EQQ x y + MO_F_Ne _ -> condFltReg NE x y + MO_F_Gt _ -> condFltReg GTT x y + MO_F_Ge _ -> condFltReg GE x y + MO_F_Lt _ -> condFltReg LTT x y + MO_F_Le _ -> condFltReg LE x y MO_Eq rep -> condIntReg EQQ (extendUExpr rep x) (extendUExpr rep y) MO_Ne rep -> condIntReg NE (extendUExpr rep x) (extendUExpr rep y) @@ -504,7 +493,7 @@ MO_F_Sub w -> triv_float w FSUB MO_F_Mul w -> triv_float w FMUL MO_F_Quot w -> triv_float w FDIV - + -- optimize addition with 32-bit immediate -- (needed for PIC) MO_Add W32 -> @@ -532,16 +521,16 @@ MO_Mul rep -> trivialCode rep True MULLW x y MO_S_MulMayOflo W32 -> trivialCodeNoImm' II32 MULLW_MayOflo x y - - MO_S_MulMayOflo rep -> panic "S_MulMayOflo (rep /= II32): not implemented" - MO_U_MulMayOflo rep -> panic "U_MulMayOflo: not implemented" + + MO_S_MulMayOflo _ -> panic "S_MulMayOflo (rep /= II32): not implemented" + MO_U_MulMayOflo _ -> panic "U_MulMayOflo: not implemented" MO_S_Quot rep -> trivialCodeNoImm' (intSize rep) DIVW (extendSExpr rep x) (extendSExpr rep y) MO_U_Quot rep -> trivialCodeNoImm' (intSize rep) DIVWU (extendUExpr rep x) (extendUExpr rep y) - + MO_S_Rem rep -> remainderCode rep DIVW (extendSExpr rep x) (extendSExpr rep y) MO_U_Rem rep -> remainderCode rep DIVWU (extendUExpr rep x) (extendUExpr rep y) - + MO_And rep -> trivialCode rep False AND x y MO_Or rep -> trivialCode rep False OR x y MO_Xor rep -> trivialCode rep False XOR x y @@ -549,32 +538,32 @@ MO_Shl rep -> trivialCode rep False SLW x y MO_S_Shr rep -> trivialCode rep False SRAW (extendSExpr rep x) y MO_U_Shr rep -> trivialCode rep False SRW (extendUExpr rep x) y - _ -> panic "PPC.CodeGen.getRegister: no match" + _ -> panic "PPC.CodeGen.getRegister: no match" where triv_float :: Width -> (Size -> Reg -> Reg -> Reg -> Instr) -> NatM Register triv_float width instr = trivialCodeNoImm (floatSize width) instr x y -getRegister (CmmLit (CmmInt i rep)) +getRegister' _ (CmmLit (CmmInt i rep)) | Just imm <- makeImmediate rep True i = let - code dst = unitOL (LI dst imm) + code dst = unitOL (LI dst imm) in - return (Any (intSize rep) code) + return (Any (intSize rep) code) -getRegister (CmmLit (CmmFloat f frep)) = do +getRegister' _ (CmmLit (CmmFloat f frep)) = do lbl <- getNewLabelNat dflags <- getDynFlagsNat dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl Amode addr addr_code <- getAmode dynRef let size = floatSize frep - code dst = - LDATA ReadOnlyData [CmmDataLabel lbl, - CmmStaticLit (CmmFloat f frep)] + code dst = + LDATA ReadOnlyData (Statics lbl + [CmmStaticLit (CmmFloat f frep)]) `consOL` (addr_code `snocOL` LD size dst addr) return (Any size code) -getRegister (CmmLit lit) +getRegister' _ (CmmLit lit) = let rep = cmmLitType lit imm = litToImm lit code dst = toOL [ @@ -583,20 +572,23 @@ ] in return (Any (cmmTypeSize rep) code) -getRegister other = pprPanic "getRegister(ppc)" (pprExpr other) - +getRegister' _ other = pprPanic "getRegister(ppc)" (pprExpr other) + -- extend?Rep: wrap integer expression of type rep -- in a conversion to II32 +extendSExpr :: Width -> CmmExpr -> CmmExpr extendSExpr W32 x = x extendSExpr rep x = CmmMachOp (MO_SS_Conv rep W32) [x] + +extendUExpr :: Width -> CmmExpr -> CmmExpr extendUExpr W32 x = x extendUExpr rep x = CmmMachOp (MO_UU_Conv rep W32) [x] -- ----------------------------------------------------------------------------- -- The 'Amode' type: Memory addressing modes passed up the tree. -data Amode - = Amode AddrMode InstrBlock +data Amode + = Amode AddrMode InstrBlock {- Now, given a tree (the argument to an CmmLoad) that references memory, @@ -648,13 +640,13 @@ let imm = litToImm lit code = unitOL (LIS tmp (HA imm)) return (Amode (AddrRegImm tmp (LO imm)) code) - + getAmode (CmmMachOp (MO_Add W32) [x, y]) = do (regX, codeX) <- getSomeReg x (regY, codeY) <- getSomeReg y return (Amode (AddrRegReg regX regY) (codeX `appOL` codeY)) - + getAmode other = do (reg, code) <- getSomeReg other @@ -665,8 +657,8 @@ -- The 'CondCode' type: Condition codes passed up the tree. -data CondCode - = CondCode Bool Cond InstrBlock +data CondCode + = CondCode Bool Cond InstrBlock -- Set up a condition code for a conditional branch. @@ -704,9 +696,9 @@ MO_U_Lt rep -> condIntCode LU (extendUExpr rep x) (extendUExpr rep y) MO_U_Le rep -> condIntCode LEU (extendUExpr rep x) (extendUExpr rep y) - other -> pprPanic "getCondCode(powerpc)" (pprMachOp mop) + _ -> pprPanic "getCondCode(powerpc)" (pprMachOp mop) -getCondCode other = panic "getCondCode(2)(powerpc)" +getCondCode _ = panic "getCondCode(2)(powerpc)" @@ -721,7 +713,7 @@ = do (src1, code) <- getSomeReg x let - code' = code `snocOL` + code' = code `snocOL` (if condUnsigned cond then CMPL else CMP) II32 src1 (RIImm src2) return (CondCode False cond code') @@ -729,19 +721,19 @@ (src1, code1) <- getSomeReg x (src2, code2) <- getSomeReg y let - code' = code1 `appOL` code2 `snocOL` - (if condUnsigned cond then CMPL else CMP) II32 src1 (RIReg src2) + code' = code1 `appOL` code2 `snocOL` + (if condUnsigned cond then CMPL else CMP) II32 src1 (RIReg src2) return (CondCode False cond code') condFltCode cond x y = do (src1, code1) <- getSomeReg x (src2, code2) <- getSomeReg y let - code' = code1 `appOL` code2 `snocOL` FCMP src1 src2 - code'' = case cond of -- twiddle CR to handle unordered case + code' = code1 `appOL` code2 `snocOL` FCMP src1 src2 + code'' = case cond of -- twiddle CR to handle unordered case GE -> code' `snocOL` CRNOR ltbit eqbit gtbit - LE -> code' `snocOL` CRNOR gtbit eqbit ltbit - _ -> code' + LE -> code' `snocOL` CRNOR gtbit eqbit ltbit + _ -> code' where ltbit = 0 ; eqbit = 2 ; gtbit = 1 return (CondCode True cond code'') @@ -797,7 +789,7 @@ genJump tree = do (target,code) <- getSomeReg tree - return (code `snocOL` MTCTR target `snocOL` BCTR []) + return (code `snocOL` MTCTR target `snocOL` BCTR [] Nothing) -- ----------------------------------------------------------------------------- @@ -826,7 +818,7 @@ genCondJump - :: BlockId -- the branch target + :: BlockId -- the branch target -> CmmExpr -- the condition on which to branch -> NatM InstrBlock @@ -842,31 +834,47 @@ -- Now the biggest nightmare---calls. Most of the nastiness is buried in -- @get_arg@, which moves the arguments to the correct registers/stack -- locations. Apart from that, the code is easy. --- +-- -- (If applicable) Do not fill the delay slots here; you will confuse the -- register allocator. -genCCall - :: CmmCallTarget -- function to call - -> HintedCmmFormals -- where to put the result - -> HintedCmmActuals -- arguments (of mixed type) +genCCall :: CmmCallTarget -- function to call + -> [HintedCmmFormal] -- where to put the result + -> [HintedCmmActual] -- arguments (of mixed type) + -> NatM InstrBlock +genCCall target dest_regs argsAndHints + = do dflags <- getDynFlagsNat + case platformOS (targetPlatform dflags) of + OSLinux -> genCCall' GCPLinux target dest_regs argsAndHints + OSDarwin -> genCCall' GCPDarwin target dest_regs argsAndHints + OSSolaris2 -> panic "PPC.CodeGen.genCCall: not defined for this os" + OSMinGW32 -> panic "PPC.CodeGen.genCCall: not defined for this os" + OSFreeBSD -> panic "PPC.CodeGen.genCCall: not defined for this os" + OSOpenBSD -> panic "PPC.CodeGen.genCCall: not defined for this os" + OSUnknown -> panic "PPC.CodeGen.genCCall: not defined for this os" + +data GenCCallPlatform = GCPLinux | GCPDarwin + +genCCall' + :: GenCCallPlatform + -> CmmCallTarget -- function to call + -> [HintedCmmFormal] -- where to put the result + -> [HintedCmmActual] -- arguments (of mixed type) -> NatM InstrBlock - -#if darwin_TARGET_OS || linux_TARGET_OS {- The PowerPC calling convention for Darwin/Mac OS X is described in Apple's document "Inside Mac OS X - Mach-O Runtime Architecture". - + PowerPC Linux uses the System V Release 4 Calling Convention for PowerPC. It is described in the "System V Application Binary Interface PowerPC Processor Supplement". Both conventions are similar: Parameters may be passed in general-purpose registers starting at r3, in - floating point registers starting at f1, or on the stack. - + floating point registers starting at f1, or on the stack. + But there are substantial differences: * The number of registers used for parameter passing and the exact set of nonvolatile registers differs (see MachRegs.lhs). @@ -882,7 +890,7 @@ 4-byte aligned like everything else on Darwin. * The SysV spec claims that FF32 is represented as FF64 on the stack. GCC on PowerPC Linux does not agree, so neither do we. - + According to both conventions, The parameter area should be part of the caller's stack frame, allocated in the caller's prologue code (large enough to hold the parameter lists for all called routines). The NCG already @@ -892,11 +900,11 @@ -} -genCCall (CmmPrim MO_WriteBarrier) _ _ +genCCall' _ (CmmPrim MO_WriteBarrier) _ _ = return $ unitOL LWSYNC -genCCall target dest_regs argsAndHints - = ASSERT (not $ any (`elem` [II8,II16]) $ map cmmTypeSize argReps) +genCCall' gcp target dest_regs argsAndHints + = ASSERT (not $ any (`elem` [II16]) $ map cmmTypeSize argReps) -- we rely on argument promotion in the codeGen do (finalStack,passArgumentsCode,usedRegs) <- passArguments @@ -904,56 +912,67 @@ allArgRegs allFPArgRegs initialStackOffset (toOL []) [] - + (labelOrExpr, reduceToFF32) <- case target of - CmmCallee (CmmLit (CmmLabel lbl)) conv -> return (Left lbl, False) - CmmCallee expr conv -> return (Right expr, False) - CmmPrim mop -> outOfLineFloatOp mop - + CmmCallee (CmmLit (CmmLabel lbl)) _ -> return (Left lbl, False) + CmmCallee expr _ -> return (Right expr, False) + CmmPrim mop -> outOfLineMachOp mop + let codeBefore = move_sp_down finalStack `appOL` passArgumentsCode codeAfter = move_sp_up finalStack `appOL` moveResult reduceToFF32 case labelOrExpr of Left lbl -> do - return ( codeBefore + return ( codeBefore `snocOL` BL lbl usedRegs - `appOL` codeAfter) + `appOL` codeAfter) Right dyn -> do - (dynReg, dynCode) <- getSomeReg dyn - return ( dynCode - `snocOL` MTCTR dynReg - `appOL` codeBefore + (dynReg, dynCode) <- getSomeReg dyn + return ( dynCode + `snocOL` MTCTR dynReg + `appOL` codeBefore `snocOL` BCTRL usedRegs - `appOL` codeAfter) + `appOL` codeAfter) where -#if darwin_TARGET_OS - initialStackOffset = 24 - -- size of linkage area + size of arguments, in bytes - stackDelta _finalStack = roundTo 16 $ (24 +) $ max 32 $ sum $ - map (widthInBytes . typeWidth) argReps -#elif linux_TARGET_OS - initialStackOffset = 8 - stackDelta finalStack = roundTo 16 finalStack -#endif - args = map hintlessCmm argsAndHints - argReps = map cmmExprType args + initialStackOffset = case gcp of + GCPDarwin -> 24 + GCPLinux -> 8 + -- size of linkage area + size of arguments, in bytes + stackDelta finalStack = case gcp of + GCPDarwin -> + roundTo 16 $ (24 +) $ max 32 $ sum $ + map (widthInBytes . typeWidth) argReps + GCPLinux -> roundTo 16 finalStack + + -- need to remove alignment information + argsAndHints' | (CmmPrim mop) <- target, + (mop == MO_Memcpy || + mop == MO_Memset || + mop == MO_Memmove) + = init argsAndHints + + | otherwise + = argsAndHints - roundTo a x | x `mod` a == 0 = x - | otherwise = x + a - (x `mod` a) + args = map hintlessCmm argsAndHints' + argReps = map cmmExprType args + + roundTo a x | x `mod` a == 0 = x + | otherwise = x + a - (x `mod` a) move_sp_down finalStack | delta > 64 = toOL [STU II32 sp (AddrRegImm sp (ImmInt (-delta))), - DELTA (-delta)] - | otherwise = nilOL - where delta = stackDelta finalStack - move_sp_up finalStack - | delta > 64 = + DELTA (-delta)] + | otherwise = nilOL + where delta = stackDelta finalStack + move_sp_up finalStack + | delta > 64 = toOL [ADD sp sp (RIImm (ImmInt delta)), DELTA 0] - | otherwise = nilOL - where delta = stackDelta finalStack - + | otherwise = nilOL + where delta = stackDelta finalStack + passArguments [] _ _ stackOffset accumCode accumUsed = return (stackOffset, accumCode, accumUsed) passArguments ((arg,arg_ty):args) gprs fprs stackOffset @@ -962,57 +981,56 @@ ChildCode64 code vr_lo <- iselExpr64 arg let vr_hi = getHiVRegFromLo vr_lo -#if darwin_TARGET_OS - passArguments args - (drop 2 gprs) - fprs - (stackOffset+8) - (accumCode `appOL` code - `snocOL` storeWord vr_hi gprs stackOffset - `snocOL` storeWord vr_lo (drop 1 gprs) (stackOffset+4)) - ((take 2 gprs) ++ accumUsed) - where - storeWord vr (gpr:_) offset = MR gpr vr - storeWord vr [] offset = ST II32 vr (AddrRegImm sp (ImmInt offset)) - -#elif linux_TARGET_OS - let stackOffset' = roundTo 8 stackOffset - stackCode = accumCode `appOL` code - `snocOL` ST II32 vr_hi (AddrRegImm sp (ImmInt stackOffset')) - `snocOL` ST II32 vr_lo (AddrRegImm sp (ImmInt (stackOffset'+4))) - regCode hireg loreg = - accumCode `appOL` code - `snocOL` MR hireg vr_hi - `snocOL` MR loreg vr_lo - - case gprs of - hireg : loreg : regs | even (length gprs) -> - passArguments args regs fprs stackOffset - (regCode hireg loreg) (hireg : loreg : accumUsed) - _skipped : hireg : loreg : regs -> - passArguments args regs fprs stackOffset - (regCode hireg loreg) (hireg : loreg : accumUsed) - _ -> -- only one or no regs left - passArguments args [] fprs (stackOffset'+8) - stackCode accumUsed -#endif - + case gcp of + GCPDarwin -> + do let storeWord vr (gpr:_) _ = MR gpr vr + storeWord vr [] offset + = ST II32 vr (AddrRegImm sp (ImmInt offset)) + passArguments args + (drop 2 gprs) + fprs + (stackOffset+8) + (accumCode `appOL` code + `snocOL` storeWord vr_hi gprs stackOffset + `snocOL` storeWord vr_lo (drop 1 gprs) (stackOffset+4)) + ((take 2 gprs) ++ accumUsed) + GCPLinux -> + do let stackOffset' = roundTo 8 stackOffset + stackCode = accumCode `appOL` code + `snocOL` ST II32 vr_hi (AddrRegImm sp (ImmInt stackOffset')) + `snocOL` ST II32 vr_lo (AddrRegImm sp (ImmInt (stackOffset'+4))) + regCode hireg loreg = + accumCode `appOL` code + `snocOL` MR hireg vr_hi + `snocOL` MR loreg vr_lo + + case gprs of + hireg : loreg : regs | even (length gprs) -> + passArguments args regs fprs stackOffset + (regCode hireg loreg) (hireg : loreg : accumUsed) + _skipped : hireg : loreg : regs -> + passArguments args regs fprs stackOffset + (regCode hireg loreg) (hireg : loreg : accumUsed) + _ -> -- only one or no regs left + passArguments args [] fprs (stackOffset'+8) + stackCode accumUsed + passArguments ((arg,rep):args) gprs fprs stackOffset accumCode accumUsed | reg : _ <- regs = do register <- getRegister arg let code = case register of Fixed _ freg fcode -> fcode `snocOL` MR reg freg Any _ acode -> acode reg + stackOffsetRes = case gcp of + -- The Darwin ABI requires that we reserve + -- stack slots for register parameters + GCPDarwin -> stackOffset + stackBytes + -- ... the SysV ABI doesn't. + GCPLinux -> stackOffset passArguments args (drop nGprs gprs) (drop nFprs fprs) -#if darwin_TARGET_OS - -- The Darwin ABI requires that we reserve stack slots for register parameters - (stackOffset + stackBytes) -#elif linux_TARGET_OS - -- ... the SysV ABI doesn't. - stackOffset -#endif + stackOffsetRes (accumCode `appOL` code) (reg : accumUsed) | otherwise = do @@ -1024,30 +1042,44 @@ (accumCode `appOL` code `snocOL` ST (cmmTypeSize rep) vr stackSlot) accumUsed where -#if darwin_TARGET_OS - -- stackOffset is at least 4-byte aligned - -- The Darwin ABI is happy with that. - stackOffset' = stackOffset -#else - -- ... the SysV ABI requires 8-byte alignment for doubles. - stackOffset' | isFloatType rep && typeWidth rep == W64 = - roundTo 8 stackOffset - | otherwise = stackOffset -#endif + stackOffset' = case gcp of + GCPDarwin -> + -- stackOffset is at least 4-byte aligned + -- The Darwin ABI is happy with that. + stackOffset + GCPLinux + -- ... the SysV ABI requires 8-byte + -- alignment for doubles. + | isFloatType rep && typeWidth rep == W64 -> + roundTo 8 stackOffset + | otherwise -> + stackOffset stackSlot = AddrRegImm sp (ImmInt stackOffset') - (nGprs, nFprs, stackBytes, regs) = case cmmTypeSize rep of - II32 -> (1, 0, 4, gprs) -#if darwin_TARGET_OS - -- The Darwin ABI requires that we skip a corresponding number of GPRs when - -- we use the FPRs. - FF32 -> (1, 1, 4, fprs) - FF64 -> (2, 1, 8, fprs) -#elif linux_TARGET_OS - -- ... the SysV ABI doesn't. - FF32 -> (0, 1, 4, fprs) - FF64 -> (0, 1, 8, fprs) -#endif - + (nGprs, nFprs, stackBytes, regs) + = case gcp of + GCPDarwin -> + case cmmTypeSize rep of + II8 -> (1, 0, 4, gprs) + II32 -> (1, 0, 4, gprs) + -- The Darwin ABI requires that we skip a + -- corresponding number of GPRs when we use + -- the FPRs. + FF32 -> (1, 1, 4, fprs) + FF64 -> (2, 1, 8, fprs) + II16 -> panic "genCCall' passArguments II16" + II64 -> panic "genCCall' passArguments II64" + FF80 -> panic "genCCall' passArguments FF80" + GCPLinux -> + case cmmTypeSize rep of + II8 -> (1, 0, 4, gprs) + II32 -> (1, 0, 4, gprs) + -- ... the SysV ABI doesn't. + FF32 -> (0, 1, 4, fprs) + FF64 -> (0, 1, 8, fprs) + II16 -> panic "genCCall' passArguments II16" + II64 -> panic "genCCall' passArguments II64" + FF80 -> panic "genCCall' passArguments FF80" + moveResult reduceToFF32 = case dest_regs of [] -> nilOL @@ -1059,8 +1091,9 @@ | otherwise -> unitOL (MR r_dest r3) where rep = cmmRegType (CmmLocal dest) r_dest = getRegisterReg (CmmLocal dest) - - outOfLineFloatOp mop = + _ -> panic "genCCall' moveResult: Bad dest_regs" + + outOfLineMachOp mop = do dflags <- getDynFlagsNat mopExpr <- cmmMakeDynamicReference dflags addImportNat CallReference $ @@ -1074,49 +1107,50 @@ MO_F32_Exp -> (fsLit "exp", True) MO_F32_Log -> (fsLit "log", True) MO_F32_Sqrt -> (fsLit "sqrt", True) - + MO_F32_Sin -> (fsLit "sin", True) MO_F32_Cos -> (fsLit "cos", True) MO_F32_Tan -> (fsLit "tan", True) - + MO_F32_Asin -> (fsLit "asin", True) MO_F32_Acos -> (fsLit "acos", True) MO_F32_Atan -> (fsLit "atan", True) - + MO_F32_Sinh -> (fsLit "sinh", True) MO_F32_Cosh -> (fsLit "cosh", True) MO_F32_Tanh -> (fsLit "tanh", True) MO_F32_Pwr -> (fsLit "pow", True) - + MO_F64_Exp -> (fsLit "exp", False) MO_F64_Log -> (fsLit "log", False) MO_F64_Sqrt -> (fsLit "sqrt", False) - + MO_F64_Sin -> (fsLit "sin", False) MO_F64_Cos -> (fsLit "cos", False) MO_F64_Tan -> (fsLit "tan", False) - + MO_F64_Asin -> (fsLit "asin", False) MO_F64_Acos -> (fsLit "acos", False) MO_F64_Atan -> (fsLit "atan", False) - + MO_F64_Sinh -> (fsLit "sinh", False) MO_F64_Cosh -> (fsLit "cosh", False) MO_F64_Tanh -> (fsLit "tanh", False) MO_F64_Pwr -> (fsLit "pow", False) + + MO_Memcpy -> (fsLit "memcpy", False) + MO_Memset -> (fsLit "memset", False) + MO_Memmove -> (fsLit "memmove", False) + other -> pprPanic "genCCall(ppc): unknown callish op" (pprCallishMachOp other) -#else /* darwin_TARGET_OS || linux_TARGET_OS */ -genCCall = panic "PPC.CodeGen.genCCall: not defined for this os" -#endif - -- ----------------------------------------------------------------------------- -- Generating a table-branch genSwitch :: CmmExpr -> [Maybe BlockId] -> NatM InstrBlock -genSwitch expr ids +genSwitch expr ids | opt_PIC = do (reg,e_code) <- getSomeReg expr @@ -1125,22 +1159,12 @@ 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 id)) - = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0) - where blockLabel = mkAsmTempLabel id - - 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 @@ -1148,26 +1172,34 @@ (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 CmmStatics 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 (Statics lbl jumpTable)) +generateJumpTableForInstr _ = Nothing -- ----------------------------------------------------------------------------- -- 'condIntReg' and 'condFltReg': condition codes into registers -- Turn those condition codes into integers now (when they appear on -- the right hand side of an assignment). --- +-- -- (If applicable) Do not fill the delay slots here; you will confuse the -- register allocator. @@ -1192,27 +1224,27 @@ MFCR dst, RLWINM dst dst (bit + 1) 31 31 ] - + negate_code | do_negate = unitOL (CRNOR bit bit bit) | otherwise = nilOL - + (bit, do_negate) = case cond of LTT -> (0, False) LE -> (1, True) EQQ -> (2, False) GE -> (0, True) GTT -> (1, False) - + NE -> (2, True) - + LU -> (0, False) LEU -> (1, True) GEU -> (0, True) GU -> (1, False) - _ -> panic "PPC.CodeGen.codeReg: no match" - + _ -> panic "PPC.CodeGen.codeReg: no match" + return (Any II32 code) - + condIntReg cond x y = condReg (condIntCode cond x y) condFltReg cond x y = condReg (condFltCode cond x y) @@ -1242,38 +1274,38 @@ * The only expression for which getRegister returns Fixed is (CmmReg reg). * If getRegister returns Any, then the code it generates may modify only: - (a) fresh temporaries - (b) the destination register + (a) fresh temporaries + (b) the destination register It may *not* modify global registers, unless the global register happens to be the destination register. It may not clobber any other registers. In fact, only ccalls clobber any fixed registers. Also, it may not modify the counter register (used by genCCall). - + Corollary: If a getRegister for a subexpression returns Fixed, you need not move it to a fresh temporary before evaluating the next subexpression. The Fixed register won't be modified. Therefore, we don't need a counterpart for the x86's getStableReg on PPC. - + * SDM's First Rule is valid for PowerPC, too: subexpressions can depend on the value of the destination register. -} -trivialCode - :: Width - -> Bool - -> (Reg -> Reg -> RI -> Instr) - -> CmmExpr - -> CmmExpr - -> NatM Register +trivialCode + :: Width + -> Bool + -> (Reg -> Reg -> RI -> Instr) + -> CmmExpr + -> CmmExpr + -> NatM Register trivialCode rep signed instr x (CmmLit (CmmInt y _)) - | Just imm <- makeImmediate rep signed y + | Just imm <- makeImmediate rep signed y = do (src1, code1) <- getSomeReg x let code dst = code1 `snocOL` instr dst src1 (RIImm imm) return (Any (intSize rep) code) - + trivialCode rep _ instr x y = do (src1, code1) <- getSomeReg x (src2, code2) <- getSomeReg y @@ -1281,28 +1313,28 @@ return (Any (intSize rep) code) trivialCodeNoImm' :: Size -> (Reg -> Reg -> Reg -> Instr) - -> CmmExpr -> CmmExpr -> NatM Register + -> CmmExpr -> CmmExpr -> NatM Register trivialCodeNoImm' size instr x y = do (src1, code1) <- getSomeReg x (src2, code2) <- getSomeReg y let code dst = code1 `appOL` code2 `snocOL` instr dst src1 src2 return (Any size code) - + trivialCodeNoImm :: Size -> (Size -> Reg -> Reg -> Reg -> Instr) - -> CmmExpr -> CmmExpr -> NatM Register + -> CmmExpr -> CmmExpr -> NatM Register trivialCodeNoImm size instr x y = trivialCodeNoImm' size (instr size) x y - - -trivialUCode - :: Size - -> (Reg -> Reg -> Instr) - -> CmmExpr - -> NatM Register + + +trivialUCode + :: Size + -> (Reg -> Reg -> Instr) + -> CmmExpr + -> NatM Register trivialUCode rep instr x = do (src, code) <- getSomeReg x let code' dst = code `snocOL` instr dst src return (Any rep code') - + -- There is no "remainder" instruction on the PPC, so we have to do -- it the hard way. -- The "div" parameter is the division instruction to use (DIVW or DIVWU) @@ -1330,32 +1362,31 @@ dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl Amode addr addr_code <- getAmode dynRef let - code' dst = code `appOL` maybe_exts `appOL` toOL [ - LDATA ReadOnlyData - [CmmDataLabel lbl, - CmmStaticLit (CmmInt 0x43300000 W32), - CmmStaticLit (CmmInt 0x80000000 W32)], - XORIS itmp src (ImmInt 0x8000), - ST II32 itmp (spRel 3), - LIS itmp (ImmInt 0x4330), - ST II32 itmp (spRel 2), - LD FF64 ftmp (spRel 2) + code' dst = code `appOL` maybe_exts `appOL` toOL [ + LDATA ReadOnlyData $ Statics lbl + [CmmStaticLit (CmmInt 0x43300000 W32), + CmmStaticLit (CmmInt 0x80000000 W32)], + XORIS itmp src (ImmInt 0x8000), + ST II32 itmp (spRel 3), + LIS itmp (ImmInt 0x4330), + ST II32 itmp (spRel 2), + LD FF64 ftmp (spRel 2) ] `appOL` addr_code `appOL` toOL [ - LD FF64 dst addr, - FSUB FF64 dst ftmp dst - ] `appOL` maybe_frsp dst - + LD FF64 dst addr, + FSUB FF64 dst ftmp dst + ] `appOL` maybe_frsp dst + maybe_exts = case fromRep of W8 -> unitOL $ EXTS II8 src src W16 -> unitOL $ EXTS II16 src src W32 -> nilOL - _ -> panic "PPC.CodeGen.coerceInt2FP: no match" + _ -> panic "PPC.CodeGen.coerceInt2FP: no match" - maybe_frsp dst - = case toRep of + maybe_frsp dst + = case toRep of W32 -> unitOL $ FRSP dst dst W64 -> nilOL - _ -> panic "PPC.CodeGen.coerceInt2FP: no match" + _ -> panic "PPC.CodeGen.coerceInt2FP: no match" return (Any (floatSize toRep) code') @@ -1365,11 +1396,11 @@ (src, code) <- getSomeReg x tmp <- getNewRegNat FF64 let - code' dst = code `appOL` toOL [ - -- convert to int in FP reg - FCTIWZ tmp src, - -- store value (64bit) from FP to stack - ST FF64 tmp (spRel 2), - -- read low word of value (high word is undefined) - LD II32 dst (spRel 3)] + code' dst = code `appOL` toOL [ + -- convert to int in FP reg + FCTIWZ tmp src, + -- store value (64bit) from FP to stack + ST FF64 tmp (spRel 2), + -- read low word of value (high word is undefined) + LD II32 dst (spRel 3)] return (Any (intSize toRep) code') diff -Nru ghc-7.0.3/compiler/nativeGen/PPC/Instr.hs ghc-7.2.1/compiler/nativeGen/PPC/Instr.hs --- ghc-7.0.3/compiler/nativeGen/PPC/Instr.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/nativeGen/PPC/Instr.hs 2011-08-07 17:10:05.000000000 +0000 @@ -28,10 +28,11 @@ import Constants (rESERVED_C_STACK_BYTES) import BlockId -import Cmm +import OldCmm import FastString import CLabel import Outputable +import Platform import FastBool -------------------------------------------------------------------------------- @@ -43,18 +44,18 @@ -- | Instruction instance for powerpc instance Instruction Instr where - regUsageOfInstr = ppc_regUsageOfInstr - patchRegsOfInstr = ppc_patchRegsOfInstr - isJumpishInstr = ppc_isJumpishInstr - jumpDestsOfInstr = ppc_jumpDestsOfInstr - patchJumpInstr = ppc_patchJumpInstr - mkSpillInstr = ppc_mkSpillInstr - mkLoadInstr = ppc_mkLoadInstr - takeDeltaInstr = ppc_takeDeltaInstr - isMetaInstr = ppc_isMetaInstr - mkRegRegMoveInstr = ppc_mkRegRegMoveInstr - takeRegRegMoveInstr = ppc_takeRegRegMoveInstr - mkJumpInstr = ppc_mkJumpInstr + regUsageOfInstr = ppc_regUsageOfInstr + patchRegsOfInstr = ppc_patchRegsOfInstr + isJumpishInstr = ppc_isJumpishInstr + jumpDestsOfInstr = ppc_jumpDestsOfInstr + patchJumpInstr = ppc_patchJumpInstr + mkSpillInstr = ppc_mkSpillInstr + mkLoadInstr = ppc_mkLoadInstr + takeDeltaInstr = ppc_takeDeltaInstr + isMetaInstr = ppc_isMetaInstr + mkRegRegMoveInstr _ = ppc_mkRegRegMoveInstr + takeRegRegMoveInstr = ppc_takeRegRegMoveInstr + mkJumpInstr = ppc_mkJumpInstr -- ----------------------------------------------------------------------------- @@ -75,7 +76,7 @@ -- some static data spat out during code -- generation. Will be extracted before -- pretty-printing. - | LDATA Section [CmmStatic] + | LDATA Section CmmStatics -- start a new basic block. Useful during -- codegen, removed later. Preceding @@ -104,7 +105,7 @@ | 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 +185,7 @@ 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 +258,7 @@ 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 +327,7 @@ = case insn of BCC _ id -> [id] BCCFAR _ id -> [id] - BCTR targets -> targets + BCTR targets _ -> [id | Just id <- targets] _ -> [] @@ -338,7 +339,7 @@ = 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 @@ -346,15 +347,16 @@ -- | An instruction to spill a register into a spill slot. ppc_mkSpillInstr - :: Reg -- register to spill - -> Int -- current stack delta - -> Int -- spill slot to use + :: Platform + -> Reg -- register to spill + -> Int -- current stack delta + -> Int -- spill slot to use -> Instr -ppc_mkSpillInstr reg delta slot +ppc_mkSpillInstr platform reg delta slot = let off = spillSlotToOffset slot in - let sz = case targetClassOfReg reg of + let sz = case targetClassOfReg platform reg of RcInteger -> II32 RcDouble -> FF64 _ -> panic "PPC.Instr.mkSpillInstr: no match" @@ -362,15 +364,16 @@ ppc_mkLoadInstr - :: Reg -- register to load - -> Int -- current stack delta - -> Int -- spill slot to use + :: Platform + -> Reg -- register to load + -> Int -- current stack delta + -> Int -- spill slot to use -> Instr -ppc_mkLoadInstr reg delta slot +ppc_mkLoadInstr platform reg delta slot = let off = spillSlotToOffset slot in - let sz = case targetClassOfReg reg of + let sz = case targetClassOfReg platform reg of RcInteger -> II32 RcDouble -> FF64 _ -> panic "PPC.Instr.mkLoadInstr: no match" diff -Nru ghc-7.0.3/compiler/nativeGen/PPC/Ppr.hs ghc-7.2.1/compiler/nativeGen/PPC/Ppr.hs --- ghc-7.0.3/compiler/nativeGen/PPC/Ppr.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/nativeGen/PPC/Ppr.hs 2011-08-07 17:10:05.000000000 +0000 @@ -12,7 +12,6 @@ pprSectionHeader, pprData, pprInstr, - pprUserReg, pprSize, pprImm, pprDataItem, @@ -33,16 +32,16 @@ import RegClass import TargetReg -import BlockId -import Cmm +import OldCmm import CLabel -import Unique ( pprUnique ) +import Unique ( pprUnique, Uniquable(..) ) +import Platform import Pretty import FastString import qualified Outputable -import Outputable ( Outputable, panic ) +import Outputable ( PlatformOutputable, panic ) import Data.Word import Data.Bits @@ -51,26 +50,30 @@ -- ----------------------------------------------------------------------------- -- Printing this stuff out -pprNatCmmTop :: NatCmmTop Instr -> Doc -pprNatCmmTop (CmmData section dats) = - pprSectionHeader section $$ vcat (map pprData dats) +pprNatCmmTop :: Platform -> NatCmmTop CmmStatics Instr -> Doc +pprNatCmmTop _ (CmmData section dats) = + pprSectionHeader section $$ pprDatas dats -- special case for split markers: -pprNatCmmTop (CmmProc [] lbl _ (ListGraph [])) = pprLabel lbl +pprNatCmmTop _ (CmmProc Nothing lbl (ListGraph [])) = pprLabel lbl -pprNatCmmTop (CmmProc info lbl _ (ListGraph blocks)) = + -- special case for code without an info table: +pprNatCmmTop platform (CmmProc Nothing lbl (ListGraph blocks)) = pprSectionHeader Text $$ - (if null info then -- blocks guaranteed not null, so label needed - pprLabel lbl - else + pprLabel lbl $$ -- blocks guaranteed not null, so label needed + vcat (map (pprBasicBlock platform) blocks) + +pprNatCmmTop platform (CmmProc (Just (Statics info_lbl info)) _entry_lbl (ListGraph blocks)) = + pprSectionHeader Text $$ + ( #if HAVE_SUBSECTIONS_VIA_SYMBOLS - pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl) - <> char ':' $$ + pprCLabel_asm (mkDeadStripPreventer info_lbl) + <> char ':' $$ #endif vcat (map pprData info) $$ - pprLabel (entryLblToInfoLbl lbl) + pprLabel info_lbl ) $$ - vcat (map pprBasicBlock blocks) + vcat (map (pprBasicBlock platform) blocks) -- above: Even the first block gets a label, because with branch-chain -- elimination, it might be the target of a goto. #if HAVE_SUBSECTIONS_VIA_SYMBOLS @@ -80,24 +83,24 @@ -- from the entry code to a label on the _top_ of of the info table, -- so that the linker will not think it is unreferenced and dead-strip -- it. That's why the label is called a DeadStripPreventer (_dsp). - $$ if not (null info) - then text "\t.long " - <+> pprCLabel_asm (entryLblToInfoLbl lbl) - <+> char '-' - <+> pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl) - else empty + $$ text "\t.long " + <+> pprCLabel_asm info_lbl + <+> char '-' + <+> pprCLabel_asm (mkDeadStripPreventer info_lbl) #endif -pprBasicBlock :: NatBasicBlock Instr -> Doc -pprBasicBlock (BasicBlock (BlockId id) instrs) = - pprLabel (mkAsmTempLabel id) $$ - vcat (map pprInstr instrs) +pprBasicBlock :: Platform -> NatBasicBlock Instr -> Doc +pprBasicBlock platform (BasicBlock blockid instrs) = + pprLabel (mkAsmTempLabel (getUnique blockid)) $$ + vcat (map (pprInstr platform) instrs) + + +pprDatas :: CmmStatics -> Doc +pprDatas (Statics lbl dats) = vcat (pprLabel lbl : map pprData dats) pprData :: CmmStatic -> Doc -pprData (CmmAlign bytes) = pprAlign bytes -pprData (CmmDataLabel lbl) = pprLabel lbl pprData (CmmString str) = pprASCII str #if darwin_TARGET_OS @@ -111,9 +114,7 @@ pprGloblDecl :: CLabel -> Doc pprGloblDecl lbl | not (externallyVisibleCLabel lbl) = empty - | otherwise = ptext IF_ARCH_sparc((sLit ".global "), - (sLit ".globl ")) <> - pprCLabel_asm lbl + | otherwise = ptext (sLit ".globl ") <> pprCLabel_asm lbl pprTypeAndSizeDecl :: CLabel -> Doc #if linux_TARGET_OS @@ -137,29 +138,13 @@ do1 :: Word8 -> Doc do1 w = ptext (sLit "\t.byte\t") <> int (fromIntegral w) -pprAlign :: Int -> Doc -pprAlign bytes = - ptext (sLit ".align ") <> int pow2 - where - pow2 = log2 bytes - - log2 :: Int -> Int -- cache the common ones - log2 1 = 0 - log2 2 = 1 - log2 4 = 2 - log2 8 = 3 - log2 n = 1 + log2 (n `quot` 2) - -- ----------------------------------------------------------------------------- -- pprInstr: print an 'Instr' -instance Outputable Instr where - ppr instr = Outputable.docToSDoc $ pprInstr instr - +instance PlatformOutputable Instr where + pprPlatform platform instr = Outputable.docToSDoc $ pprInstr platform instr -pprUserReg :: Reg -> Doc -pprUserReg = pprReg pprReg :: Reg -> Doc @@ -352,31 +337,26 @@ = panic "PPC.Ppr.pprDataItem: no match" -pprInstr :: Instr -> Doc +pprInstr :: Platform -> Instr -> Doc -pprInstr (COMMENT _) = empty -- nuke 'em +pprInstr _ (COMMENT _) = empty -- nuke 'em {- -pprInstr (COMMENT s) - = IF_ARCH_alpha( ((<>) (ptext (sLit "\t# ")) (ftext s)) - ,IF_ARCH_sparc( ((<>) (ptext (sLit "# ")) (ftext s)) - ,IF_ARCH_i386( ((<>) (ptext (sLit "# ")) (ftext s)) - ,IF_ARCH_x86_64( ((<>) (ptext (sLit "# ")) (ftext s)) - ,IF_ARCH_powerpc( IF_OS_linux( +pprInstr _ (COMMENT s) + IF_OS_linux( ((<>) (ptext (sLit "# ")) (ftext s)), ((<>) (ptext (sLit "; ")) (ftext s))) - ,))))) -} -pprInstr (DELTA d) - = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d))) +pprInstr platform (DELTA d) + = pprInstr platform (COMMENT (mkFastString ("\tdelta = " ++ show d))) -pprInstr (NEWBLOCK _) +pprInstr _ (NEWBLOCK _) = panic "PprMach.pprInstr: NEWBLOCK" -pprInstr (LDATA _ _) +pprInstr _ (LDATA _ _) = panic "PprMach.pprInstr: LDATA" {- -pprInstr (SPILL reg slot) +pprInstr _ (SPILL reg slot) = hcat [ ptext (sLit "\tSPILL"), char '\t', @@ -384,7 +364,7 @@ comma, ptext (sLit "SLOT") <> parens (int slot)] -pprInstr (RELOAD slot reg) +pprInstr _ (RELOAD slot reg) = hcat [ ptext (sLit "\tRELOAD"), char '\t', @@ -393,7 +373,7 @@ pprReg reg] -} -pprInstr (LD sz reg addr) = hcat [ +pprInstr _ (LD sz reg addr) = hcat [ char '\t', ptext (sLit "l"), ptext (case sz of @@ -411,7 +391,7 @@ ptext (sLit ", "), pprAddr addr ] -pprInstr (LA sz reg addr) = hcat [ +pprInstr _ (LA sz reg addr) = hcat [ char '\t', ptext (sLit "l"), ptext (case sz of @@ -429,7 +409,7 @@ ptext (sLit ", "), pprAddr addr ] -pprInstr (ST sz reg addr) = hcat [ +pprInstr _ (ST sz reg addr) = hcat [ char '\t', ptext (sLit "st"), pprSize sz, @@ -440,7 +420,7 @@ ptext (sLit ", "), pprAddr addr ] -pprInstr (STU sz reg addr) = hcat [ +pprInstr _ (STU sz reg addr) = hcat [ char '\t', ptext (sLit "st"), pprSize sz, @@ -451,7 +431,7 @@ ptext (sLit ", "), pprAddr addr ] -pprInstr (LIS reg imm) = hcat [ +pprInstr _ (LIS reg imm) = hcat [ char '\t', ptext (sLit "lis"), char '\t', @@ -459,7 +439,7 @@ ptext (sLit ", "), pprImm imm ] -pprInstr (LI reg imm) = hcat [ +pprInstr _ (LI reg imm) = hcat [ char '\t', ptext (sLit "li"), char '\t', @@ -467,11 +447,11 @@ ptext (sLit ", "), pprImm imm ] -pprInstr (MR reg1 reg2) +pprInstr platform (MR reg1 reg2) | reg1 == reg2 = empty | otherwise = hcat [ char '\t', - case targetClassOfReg reg1 of + case targetClassOfReg platform reg1 of RcInteger -> ptext (sLit "mr") _ -> ptext (sLit "fmr"), char '\t', @@ -479,7 +459,7 @@ ptext (sLit ", "), pprReg reg2 ] -pprInstr (CMP sz reg ri) = hcat [ +pprInstr _ (CMP sz reg ri) = hcat [ char '\t', op, char '\t', @@ -495,7 +475,7 @@ RIReg _ -> empty RIImm _ -> char 'i' ] -pprInstr (CMPL sz reg ri) = hcat [ +pprInstr _ (CMPL sz reg ri) = hcat [ char '\t', op, char '\t', @@ -511,16 +491,16 @@ RIReg _ -> empty RIImm _ -> char 'i' ] -pprInstr (BCC cond (BlockId id)) = hcat [ +pprInstr _ (BCC cond blockid) = hcat [ char '\t', ptext (sLit "b"), pprCond cond, char '\t', pprCLabel_asm lbl ] - where lbl = mkAsmTempLabel id + where lbl = mkAsmTempLabel (getUnique blockid) -pprInstr (BCCFAR cond (BlockId id)) = vcat [ +pprInstr _ (BCCFAR cond blockid) = vcat [ hcat [ ptext (sLit "\tb"), pprCond (condNegate cond), @@ -531,35 +511,35 @@ pprCLabel_asm lbl ] ] - where lbl = mkAsmTempLabel id + where lbl = mkAsmTempLabel (getUnique blockid) -pprInstr (JMP lbl) = hcat [ -- an alias for b that takes a CLabel +pprInstr _ (JMP lbl) = hcat [ -- an alias for b that takes a CLabel char '\t', ptext (sLit "b"), char '\t', pprCLabel_asm lbl ] -pprInstr (MTCTR reg) = hcat [ +pprInstr _ (MTCTR reg) = hcat [ char '\t', ptext (sLit "mtctr"), char '\t', pprReg reg ] -pprInstr (BCTR _) = hcat [ +pprInstr _ (BCTR _ _) = hcat [ char '\t', ptext (sLit "bctr") ] -pprInstr (BL lbl _) = hcat [ +pprInstr _ (BL lbl _) = hcat [ ptext (sLit "\tbl\t"), pprCLabel_asm lbl ] -pprInstr (BCTRL _) = hcat [ +pprInstr _ (BCTRL _) = hcat [ char '\t', ptext (sLit "bctrl") ] -pprInstr (ADD reg1 reg2 ri) = pprLogic (sLit "add") reg1 reg2 ri -pprInstr (ADDIS reg1 reg2 imm) = hcat [ +pprInstr _ (ADD reg1 reg2 ri) = pprLogic (sLit "add") reg1 reg2 ri +pprInstr _ (ADDIS reg1 reg2 imm) = hcat [ char '\t', ptext (sLit "addis"), char '\t', @@ -570,15 +550,15 @@ pprImm imm ] -pprInstr (ADDC reg1 reg2 reg3) = pprLogic (sLit "addc") reg1 reg2 (RIReg reg3) -pprInstr (ADDE reg1 reg2 reg3) = pprLogic (sLit "adde") reg1 reg2 (RIReg reg3) -pprInstr (SUBF reg1 reg2 reg3) = pprLogic (sLit "subf") reg1 reg2 (RIReg reg3) -pprInstr (MULLW reg1 reg2 ri@(RIReg _)) = pprLogic (sLit "mullw") reg1 reg2 ri -pprInstr (MULLW reg1 reg2 ri@(RIImm _)) = pprLogic (sLit "mull") reg1 reg2 ri -pprInstr (DIVW reg1 reg2 reg3) = pprLogic (sLit "divw") reg1 reg2 (RIReg reg3) -pprInstr (DIVWU reg1 reg2 reg3) = pprLogic (sLit "divwu") reg1 reg2 (RIReg reg3) +pprInstr _ (ADDC reg1 reg2 reg3) = pprLogic (sLit "addc") reg1 reg2 (RIReg reg3) +pprInstr _ (ADDE reg1 reg2 reg3) = pprLogic (sLit "adde") reg1 reg2 (RIReg reg3) +pprInstr _ (SUBF reg1 reg2 reg3) = pprLogic (sLit "subf") reg1 reg2 (RIReg reg3) +pprInstr _ (MULLW reg1 reg2 ri@(RIReg _)) = pprLogic (sLit "mullw") reg1 reg2 ri +pprInstr _ (MULLW reg1 reg2 ri@(RIImm _)) = pprLogic (sLit "mull") reg1 reg2 ri +pprInstr _ (DIVW reg1 reg2 reg3) = pprLogic (sLit "divw") reg1 reg2 (RIReg reg3) +pprInstr _ (DIVWU reg1 reg2 reg3) = pprLogic (sLit "divwu") reg1 reg2 (RIReg reg3) -pprInstr (MULLW_MayOflo reg1 reg2 reg3) = vcat [ +pprInstr _ (MULLW_MayOflo reg1 reg2 reg3) = vcat [ hcat [ ptext (sLit "\tmullwo\t"), pprReg reg1, ptext (sLit ", "), pprReg reg2, ptext (sLit ", "), pprReg reg3 ], @@ -590,7 +570,7 @@ -- for some reason, "andi" doesn't exist. -- we'll use "andi." instead. -pprInstr (AND reg1 reg2 (RIImm imm)) = hcat [ +pprInstr _ (AND reg1 reg2 (RIImm imm)) = hcat [ char '\t', ptext (sLit "andi."), char '\t', @@ -600,12 +580,12 @@ ptext (sLit ", "), pprImm imm ] -pprInstr (AND reg1 reg2 ri) = pprLogic (sLit "and") reg1 reg2 ri +pprInstr _ (AND reg1 reg2 ri) = pprLogic (sLit "and") reg1 reg2 ri -pprInstr (OR reg1 reg2 ri) = pprLogic (sLit "or") reg1 reg2 ri -pprInstr (XOR reg1 reg2 ri) = pprLogic (sLit "xor") reg1 reg2 ri +pprInstr _ (OR reg1 reg2 ri) = pprLogic (sLit "or") reg1 reg2 ri +pprInstr _ (XOR reg1 reg2 ri) = pprLogic (sLit "xor") reg1 reg2 ri -pprInstr (XORIS reg1 reg2 imm) = hcat [ +pprInstr _ (XORIS reg1 reg2 imm) = hcat [ char '\t', ptext (sLit "xoris"), char '\t', @@ -616,7 +596,7 @@ pprImm imm ] -pprInstr (EXTS sz reg1 reg2) = hcat [ +pprInstr _ (EXTS sz reg1 reg2) = hcat [ char '\t', ptext (sLit "exts"), pprSize sz, @@ -626,13 +606,13 @@ pprReg reg2 ] -pprInstr (NEG reg1 reg2) = pprUnary (sLit "neg") reg1 reg2 -pprInstr (NOT reg1 reg2) = pprUnary (sLit "not") reg1 reg2 +pprInstr _ (NEG reg1 reg2) = pprUnary (sLit "neg") reg1 reg2 +pprInstr _ (NOT reg1 reg2) = pprUnary (sLit "not") reg1 reg2 -pprInstr (SLW reg1 reg2 ri) = pprLogic (sLit "slw") reg1 reg2 (limitShiftRI ri) -pprInstr (SRW reg1 reg2 ri) = pprLogic (sLit "srw") reg1 reg2 (limitShiftRI ri) -pprInstr (SRAW reg1 reg2 ri) = pprLogic (sLit "sraw") reg1 reg2 (limitShiftRI ri) -pprInstr (RLWINM reg1 reg2 sh mb me) = hcat [ +pprInstr _ (SLW reg1 reg2 ri) = pprLogic (sLit "slw") reg1 reg2 (limitShiftRI ri) +pprInstr _ (SRW reg1 reg2 ri) = pprLogic (sLit "srw") reg1 reg2 (limitShiftRI ri) +pprInstr _ (SRAW reg1 reg2 ri) = pprLogic (sLit "sraw") reg1 reg2 (limitShiftRI ri) +pprInstr _ (RLWINM reg1 reg2 sh mb me) = hcat [ ptext (sLit "\trlwinm\t"), pprReg reg1, ptext (sLit ", "), @@ -645,13 +625,13 @@ int me ] -pprInstr (FADD sz reg1 reg2 reg3) = pprBinaryF (sLit "fadd") sz reg1 reg2 reg3 -pprInstr (FSUB sz reg1 reg2 reg3) = pprBinaryF (sLit "fsub") sz reg1 reg2 reg3 -pprInstr (FMUL sz reg1 reg2 reg3) = pprBinaryF (sLit "fmul") sz reg1 reg2 reg3 -pprInstr (FDIV sz reg1 reg2 reg3) = pprBinaryF (sLit "fdiv") sz reg1 reg2 reg3 -pprInstr (FNEG reg1 reg2) = pprUnary (sLit "fneg") reg1 reg2 +pprInstr _ (FADD sz reg1 reg2 reg3) = pprBinaryF (sLit "fadd") sz reg1 reg2 reg3 +pprInstr _ (FSUB sz reg1 reg2 reg3) = pprBinaryF (sLit "fsub") sz reg1 reg2 reg3 +pprInstr _ (FMUL sz reg1 reg2 reg3) = pprBinaryF (sLit "fmul") sz reg1 reg2 reg3 +pprInstr _ (FDIV sz reg1 reg2 reg3) = pprBinaryF (sLit "fdiv") sz reg1 reg2 reg3 +pprInstr _ (FNEG reg1 reg2) = pprUnary (sLit "fneg") reg1 reg2 -pprInstr (FCMP reg1 reg2) = hcat [ +pprInstr _ (FCMP reg1 reg2) = hcat [ char '\t', ptext (sLit "fcmpu\tcr0, "), -- Note: we're using fcmpu, not fcmpo @@ -662,10 +642,10 @@ pprReg reg2 ] -pprInstr (FCTIWZ reg1 reg2) = pprUnary (sLit "fctiwz") reg1 reg2 -pprInstr (FRSP reg1 reg2) = pprUnary (sLit "frsp") reg1 reg2 +pprInstr _ (FCTIWZ reg1 reg2) = pprUnary (sLit "fctiwz") reg1 reg2 +pprInstr _ (FRSP reg1 reg2) = pprUnary (sLit "frsp") reg1 reg2 -pprInstr (CRNOR dst src1 src2) = hcat [ +pprInstr _ (CRNOR dst src1 src2) = hcat [ ptext (sLit "\tcrnor\t"), int dst, ptext (sLit ", "), @@ -674,28 +654,28 @@ int src2 ] -pprInstr (MFCR reg) = hcat [ +pprInstr _ (MFCR reg) = hcat [ char '\t', ptext (sLit "mfcr"), char '\t', pprReg reg ] -pprInstr (MFLR reg) = hcat [ +pprInstr _ (MFLR reg) = hcat [ char '\t', ptext (sLit "mflr"), char '\t', pprReg reg ] -pprInstr (FETCHPC reg) = vcat [ +pprInstr _ (FETCHPC reg) = vcat [ ptext (sLit "\tbcl\t20,31,1f"), hcat [ ptext (sLit "1:\tmflr\t"), pprReg reg ] ] -pprInstr LWSYNC = ptext (sLit "\tlwsync") +pprInstr _ LWSYNC = ptext (sLit "\tlwsync") --- pprInstr _ = panic "pprInstr (ppc)" +-- pprInstr _ _ = panic "pprInstr (ppc)" pprLogic :: LitString -> Reg -> Reg -> RI -> Doc diff -Nru ghc-7.0.3/compiler/nativeGen/PPC/RegInfo.hs ghc-7.2.1/compiler/nativeGen/PPC/RegInfo.hs --- ghc-7.0.3/compiler/nativeGen/PPC/RegInfo.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/nativeGen/PPC/RegInfo.hs 2011-08-07 17:10:05.000000000 +0000 @@ -7,11 +7,11 @@ ----------------------------------------------------------------------------- module PPC.RegInfo ( - JumpDest( DestBlockId ), + JumpDest( DestBlockId ), getJumpDestBlockId, canShortcut, shortcutJump, - shortcutStatic + shortcutStatics ) where @@ -23,13 +23,18 @@ import PPC.Instr import BlockId -import Cmm +import OldCmm import CLabel import Outputable +import Unique data JumpDest = DestBlockId BlockId | DestImm Imm +getJumpDestBlockId :: JumpDest -> Maybe BlockId +getJumpDestBlockId (DestBlockId bid) = Just bid +getJumpDestBlockId _ = Nothing + canShortcut :: Instr -> Maybe JumpDest canShortcut _ = Nothing @@ -38,18 +43,24 @@ -- Here because it knows about JumpDest -shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic +shortcutStatics :: (BlockId -> Maybe JumpDest) -> CmmStatics -> CmmStatics +shortcutStatics fn (Statics lbl statics) + = Statics lbl $ map (shortcutStatic fn) statics + -- we need to get the jump tables, so apply the mapping to the entries + -- of a CmmData too. + +shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel +shortcutLabel fn lab + | Just uq <- maybeAsmTemp lab = shortBlockId fn (mkBlockId uq) + | otherwise = lab +shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic shortcutStatic fn (CmmStaticLit (CmmLabel lab)) - | Just uq <- maybeAsmTemp lab - = CmmStaticLit (CmmLabel (shortBlockId fn (BlockId uq))) - + = CmmStaticLit (CmmLabel (shortcutLabel fn lab)) shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off)) - | Just uq <- maybeAsmTemp lbl1 - = CmmStaticLit (CmmLabelDiffOff (shortBlockId fn (BlockId uq)) lbl2 off) + = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off) -- slightly dodgy, we're ignoring the second label, but this -- works with the way we use CmmLabelDiffOff for jump tables now. - shortcutStatic _ other_static = other_static @@ -58,10 +69,11 @@ -> BlockId -> CLabel -shortBlockId fn blockid@(BlockId uq) = +shortBlockId fn blockid = case fn blockid of Nothing -> mkAsmTempLabel uq Just (DestBlockId blockid') -> shortBlockId fn blockid' Just (DestImm (ImmCLbl lbl)) -> lbl _other -> panic "shortBlockId" + where uq = getUnique blockid diff -Nru ghc-7.0.3/compiler/nativeGen/PPC/Regs.hs ghc-7.2.1/compiler/nativeGen/PPC/Regs.hs --- ghc-7.0.3/compiler/nativeGen/PPC/Regs.hs 2011-03-26 18:10:03.000000000 +0000 +++ ghc-7.2.1/compiler/nativeGen/PPC/Regs.hs 2011-08-07 17:10:05.000000000 +0000 @@ -55,7 +55,7 @@ import Size import BlockId -import Cmm +import OldCmm import CLabel ( CLabel ) import Unique @@ -209,7 +209,6 @@ -- argRegs is the set of regs which are read for an n-argument call to C. -- For archs which pass all args on the stack (x86), is empty. -- Sparc passes up to the first 6 args in regs. --- Dunno about Alpha. argRegs :: RegNo -> [Reg] argRegs 0 = [] argRegs 1 = map regSingle [3] diff -Nru ghc-7.0.3/compiler/nativeGen/PprInstruction.hs ghc-7.2.1/compiler/nativeGen/PprInstruction.hs --- ghc-7.0.3/compiler/nativeGen/PprInstruction.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/compiler/nativeGen/PprInstruction.hs 2011-08-07 17:10:05.000000000 +0000 @@ -0,0 +1,2 @@ + + pprInstruction :: Platform -> instr -> SDoc diff -Nru ghc-7.0.3/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs ghc-7.2.1/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs --- ghc-7.0.3/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs 2011-08-07 17:10:05.000000000 +0000 @@ -12,7 +12,7 @@ import Instruction import Reg -import Cmm +import OldCmm import Bag import Digraph import UniqFM @@ -27,8 +27,8 @@ -- the same and the move instruction safely erased. regCoalesce :: Instruction instr - => [LiveCmmTop instr] - -> UniqSM [LiveCmmTop instr] + => [LiveCmmTop statics instr] + -> UniqSM [LiveCmmTop statics instr] regCoalesce code = do @@ -61,17 +61,17 @@ -- then we can rename the two regs to the same thing and eliminate the move. slurpJoinMovs :: Instruction instr - => LiveCmmTop instr + => LiveCmmTop statics instr -> Bag (Reg, Reg) slurpJoinMovs live = slurpCmm emptyBag live where - slurpCmm rs CmmData{} = rs - slurpCmm rs (CmmProc _ _ _ sccs) = foldl' slurpBlock rs (flattenSCCs sccs) - slurpBlock rs (BasicBlock _ instrs) = foldl' slurpLI rs instrs + slurpCmm rs CmmData{} = rs + slurpCmm rs (CmmProc _ _ sccs) = foldl' slurpBlock rs (flattenSCCs sccs) + slurpBlock rs (BasicBlock _ instrs) = foldl' slurpLI rs instrs - slurpLI rs (LiveInstr _ Nothing) = rs + slurpLI rs (LiveInstr _ Nothing) = rs slurpLI rs (LiveInstr instr (Just live)) | Just (r1, r2) <- takeRegRegMoveInstr instr , elementOfUniqSet r1 $ liveDieRead live diff -Nru ghc-7.0.3/compiler/nativeGen/RegAlloc/Graph/Main.hs ghc-7.2.1/compiler/nativeGen/RegAlloc/Graph/Main.hs --- ghc-7.0.3/compiler/nativeGen/RegAlloc/Graph/Main.hs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/nativeGen/RegAlloc/Graph/Main.hs 2011-08-07 17:10:05.000000000 +0000 @@ -28,6 +28,7 @@ import UniqFM import Bag import Outputable +import Platform import DynFlags import Data.List @@ -44,12 +45,12 @@ -- | The top level of the graph coloring register allocator. regAlloc - :: (Outputable instr, Instruction instr) + :: (Outputable statics, PlatformOutputable instr, Instruction instr) => DynFlags -> UniqFM (UniqSet RealReg) -- ^ the registers we can use for allocation -> UniqSet Int -- ^ the set of available spill slots. - -> [LiveCmmTop instr] -- ^ code annotated with liveness information. - -> UniqSM ( [NatCmmTop instr], [RegAllocStats instr] ) + -> [LiveCmmTop statics instr] -- ^ code annotated with liveness information. + -> UniqSM ( [NatCmmTop statics instr], [RegAllocStats statics instr] ) -- ^ code with registers allocated and stats for each stage of -- allocation @@ -58,9 +59,10 @@ -- TODO: the regClass function is currently hard coded to the default target -- architecture. Would prefer to determine this from dflags. -- There are other uses of targetRegClass later in this module. - let triv = trivColorable - targetVirtualRegSqueeze - targetRealRegSqueeze + let platform = targetPlatform dflags + triv = trivColorable platform + (targetVirtualRegSqueeze platform) + (targetRealRegSqueeze platform) (code_final, debug_codeGraphs, _) <- regAlloc_spin dflags 0 @@ -79,6 +81,7 @@ debug_codeGraphs code = do + let platform = targetPlatform dflags -- if any of these dump flags are turned on we want to hang on to -- intermediate structures in the allocator - otherwise tell the -- allocator to ditch them early so we don't end up creating space leaks. @@ -111,7 +114,7 @@ -- build a map of the cost of spilling each instruction -- this will only actually be computed if we have to spill something. let spillCosts = foldl' plusSpillCostInfo zeroSpillCostInfo - $ map slurpSpillCostInfo code + $ map (slurpSpillCostInfo platform) code -- the function to choose regs to leave uncolored let spill = chooseSpill spillCosts @@ -159,14 +162,14 @@ else graph_colored -- patch the registers using the info in the graph - let code_patched = map (patchRegsFromGraph graph_colored_lint) code_coalesced + let code_patched = map (patchRegsFromGraph platform graph_colored_lint) code_coalesced -- clean out unneeded SPILL/RELOADs - let code_spillclean = map cleanSpills code_patched + let code_spillclean = map (cleanSpills platform) code_patched -- strip off liveness information, -- and rewrite SPILL/RELOAD pseudos into real instructions along the way - let code_final = map stripLive code_spillclean + let code_final = map (stripLive platform) code_spillclean -- record what happened in this stage for debugging let stat = @@ -211,7 +214,7 @@ -- NOTE: we have to reverse the SCCs here to get them back into the reverse-dependency -- order required by computeLiveness. If they're not in the correct order -- that function will panic. - code_relive <- mapM (regLiveness . reverseBlocksInTops) code_spilled + code_relive <- mapM (regLiveness platform . reverseBlocksInTops) code_spilled -- record what happened in this stage for debugging let stat = @@ -239,7 +242,7 @@ -- | Build a graph from the liveness and coalesce information in this code. buildGraph :: Instruction instr - => [LiveCmmTop instr] + => [LiveCmmTop statics instr] -> UniqSM (Color.Graph VirtualReg RegClass RealReg) buildGraph code @@ -320,11 +323,11 @@ -- | Patch registers in code using the reg -> reg mapping in this graph. patchRegsFromGraph - :: (Outputable instr, Instruction instr) - => Color.Graph VirtualReg RegClass RealReg - -> LiveCmmTop instr -> LiveCmmTop instr + :: (Outputable statics, PlatformOutputable instr, Instruction instr) + => Platform -> Color.Graph VirtualReg RegClass RealReg + -> LiveCmmTop statics instr -> LiveCmmTop statics instr -patchRegsFromGraph graph code +patchRegsFromGraph platform graph code = let -- a function to lookup the hardreg for a virtual reg from the graph. patchF reg @@ -343,12 +346,12 @@ | otherwise = pprPanic "patchRegsFromGraph: register mapping failed." ( text "There is no node in the graph for register " <> ppr reg - $$ ppr code + $$ pprPlatform platform code $$ Color.dotGraph (\_ -> text "white") - (trivColorable - targetVirtualRegSqueeze - targetRealRegSqueeze) + (trivColorable platform + (targetVirtualRegSqueeze platform) + (targetRealRegSqueeze platform)) graph) in patchEraseLive patchF code diff -Nru ghc-7.0.3/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs ghc-7.2.1/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs --- ghc-7.0.3/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs 2011-08-07 17:10:05.000000000 +0000 @@ -33,12 +33,13 @@ import Reg import BlockId -import Cmm +import OldCmm import UniqSet import UniqFM import Unique import State import Outputable +import Platform import Data.List import Data.Maybe @@ -47,28 +48,28 @@ import qualified Data.Map as Map import qualified Data.Set as Set - -- type Slot = Int -- | Clean out unneeded spill\/reloads from this top level thing. -cleanSpills - :: Instruction instr - => LiveCmmTop instr -> LiveCmmTop instr +cleanSpills + :: Instruction instr + => Platform -> LiveCmmTop statics instr -> LiveCmmTop statics instr -cleanSpills cmm - = evalState (cleanSpin 0 cmm) initCleanS +cleanSpills platform cmm + = evalState (cleanSpin platform 0 cmm) initCleanS -- | do one pass of cleaning -cleanSpin - :: Instruction instr - => Int - -> LiveCmmTop instr - -> CleanM (LiveCmmTop instr) +cleanSpin + :: Instruction instr + => Platform + -> Int + -> LiveCmmTop statics instr + -> CleanM (LiveCmmTop statics instr) {- -cleanSpin spinCount code +cleanSpin _ spinCount code = do jumpValid <- gets sJumpValid pprTrace "cleanSpin" ( int spinCount @@ -79,7 +80,7 @@ $ cleanSpin' spinCount code -} -cleanSpin spinCount code +cleanSpin platform spinCount code = do -- init count of cleaned spills\/reloads modify $ \s -> s @@ -87,7 +88,7 @@ , sCleanedReloadsAcc = 0 , sReloadedBy = emptyUFM } - code_forward <- mapBlockTopM cleanBlockForward code + code_forward <- mapBlockTopM (cleanBlockForward platform) code code_backward <- cleanTopBackward code_forward -- During the cleaning of each block we collected information about what regs @@ -108,16 +109,17 @@ then return code -- otherwise go around again - else cleanSpin (spinCount + 1) code_backward + else cleanSpin platform (spinCount + 1) code_backward -- | Clean one basic block -cleanBlockForward - :: Instruction instr - => LiveBasicBlock instr - -> CleanM (LiveBasicBlock instr) +cleanBlockForward + :: Instruction instr + => Platform + -> LiveBasicBlock instr + -> CleanM (LiveBasicBlock instr) -cleanBlockForward (BasicBlock blockId instrs) +cleanBlockForward platform (BasicBlock blockId instrs) = do -- see if we have a valid association for the entry to this block jumpValid <- gets sJumpValid @@ -125,7 +127,7 @@ Just assoc -> assoc Nothing -> emptyAssoc - instrs_reload <- cleanForward blockId assoc [] instrs + instrs_reload <- cleanForward platform blockId assoc [] instrs return $ BasicBlock blockId instrs_reload @@ -136,37 +138,38 @@ -- then we don't need to do the reload. -- cleanForward - :: Instruction instr - => BlockId -- ^ the block that we're currently in - -> Assoc Store -- ^ two store locations are associated if they have the same value - -> [LiveInstr instr] -- ^ acc - -> [LiveInstr instr] -- ^ instrs to clean (in backwards order) - -> CleanM [LiveInstr instr] -- ^ cleaned instrs (in forward order) + :: Instruction instr + => Platform + -> BlockId -- ^ the block that we're currently in + -> Assoc Store -- ^ two store locations are associated if they have the same value + -> [LiveInstr instr] -- ^ acc + -> [LiveInstr instr] -- ^ instrs to clean (in backwards order) + -> CleanM [LiveInstr instr] -- ^ cleaned instrs (in forward order) -cleanForward _ _ acc [] +cleanForward _ _ _ acc [] = return acc -- write out live range joins via spill slots to just a spill and a reg-reg move -- hopefully the spill will be also be cleaned in the next pass -- -cleanForward blockId assoc acc (li1 : li2 : instrs) +cleanForward platform blockId assoc acc (li1 : li2 : instrs) | LiveInstr (SPILL reg1 slot1) _ <- li1 , LiveInstr (RELOAD slot2 reg2) _ <- li2 , slot1 == slot2 = do modify $ \s -> s { sCleanedReloadsAcc = sCleanedReloadsAcc s + 1 } - cleanForward blockId assoc acc - (li1 : LiveInstr (mkRegRegMoveInstr reg1 reg2) Nothing : instrs) + cleanForward platform blockId assoc acc + (li1 : LiveInstr (mkRegRegMoveInstr platform reg1 reg2) Nothing : instrs) -cleanForward blockId assoc acc (li@(LiveInstr i1 _) : instrs) +cleanForward platform blockId assoc acc (li@(LiveInstr i1 _) : instrs) | Just (r1, r2) <- takeRegRegMoveInstr i1 = if r1 == r2 -- erase any left over nop reg reg moves while we're here -- this will also catch any nop moves that the "write out live range joins" case above -- happens to add - then cleanForward blockId assoc acc instrs + then cleanForward platform blockId assoc acc instrs -- if r1 has the same value as some slots and we copy r1 to r2, -- then r2 is now associated with those slots instead @@ -174,50 +177,51 @@ $ delAssoc (SReg r2) $ assoc - cleanForward blockId assoc' (li : acc) instrs + cleanForward platform blockId assoc' (li : acc) instrs -cleanForward blockId assoc acc (li : instrs) +cleanForward platform blockId assoc acc (li : instrs) -- update association due to the spill | LiveInstr (SPILL reg slot) _ <- li = let assoc' = addAssoc (SReg reg) (SSlot slot) $ delAssoc (SSlot slot) $ assoc - in cleanForward blockId assoc' (li : acc) instrs + in cleanForward platform blockId assoc' (li : acc) instrs -- clean a reload instr | LiveInstr (RELOAD{}) _ <- li - = do (assoc', mli) <- cleanReload blockId assoc li + = do (assoc', mli) <- cleanReload platform blockId assoc li case mli of - Nothing -> cleanForward blockId assoc' acc instrs - Just li' -> cleanForward blockId assoc' (li' : acc) instrs + Nothing -> cleanForward platform blockId assoc' acc instrs + Just li' -> cleanForward platform blockId assoc' (li' : acc) instrs -- remember the association over a jump | LiveInstr instr _ <- li , targets <- jumpDestsOfInstr instr , not $ null targets = do mapM_ (accJumpValid assoc) targets - cleanForward blockId assoc (li : acc) instrs + cleanForward platform blockId assoc (li : acc) instrs -- writing to a reg changes its value. | LiveInstr instr _ <- li , RU _ written <- regUsageOfInstr instr = let assoc' = foldr delAssoc assoc (map SReg $ nub written) - in cleanForward blockId assoc' (li : acc) instrs + in cleanForward platform blockId assoc' (li : acc) instrs -- | Try and rewrite a reload instruction to something more pleasing -- -cleanReload - :: Instruction instr - => BlockId - -> Assoc Store - -> LiveInstr instr - -> CleanM (Assoc Store, Maybe (LiveInstr instr)) +cleanReload + :: Instruction instr + => Platform + -> BlockId + -> Assoc Store + -> LiveInstr instr + -> CleanM (Assoc Store, Maybe (LiveInstr instr)) -cleanReload blockId assoc li@(LiveInstr (RELOAD slot reg) _) +cleanReload platform blockId assoc li@(LiveInstr (RELOAD slot reg) _) -- if the reg we're reloading already has the same value as the slot -- then we can erase the instruction outright @@ -234,7 +238,7 @@ $ delAssoc (SReg reg) $ assoc - return (assoc', Just $ LiveInstr (mkRegRegMoveInstr reg2 reg) Nothing) + return (assoc', Just $ LiveInstr (mkRegRegMoveInstr platform reg2 reg) Nothing) -- gotta keep this instr | otherwise @@ -248,7 +252,7 @@ return (assoc', Just li) -cleanReload _ _ _ +cleanReload _ _ _ _ = panic "RegSpillClean.cleanReload: unhandled instr" @@ -283,18 +287,18 @@ -- cleanTopBackward :: Instruction instr - => LiveCmmTop instr - -> CleanM (LiveCmmTop instr) + => LiveCmmTop statics instr + -> CleanM (LiveCmmTop statics instr) cleanTopBackward cmm = case cmm of CmmData{} -> return cmm - CmmProc info label params sccs + CmmProc info label sccs | LiveInfo _ _ _ liveSlotsOnEntry <- info -> do sccs' <- mapM (mapSCCM (cleanBlockBackward liveSlotsOnEntry)) sccs - return $ CmmProc info label params sccs' + return $ CmmProc info label sccs' cleanBlockBackward diff -Nru ghc-7.0.3/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs ghc-7.2.1/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs --- ghc-7.0.3/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs 2011-08-07 17:10:05.000000000 +0000 @@ -24,11 +24,12 @@ import GraphBase import BlockId -import Cmm +import OldCmm import UniqFM import UniqSet import Digraph (flattenSCCs) import Outputable +import Platform import State import Data.List (nub, minimumBy) @@ -62,16 +63,16 @@ -- for each vreg, the number of times it was written to, read from, -- and the number of instructions it was live on entry to (lifetime) -- -slurpSpillCostInfo - :: (Outputable instr, Instruction instr) - => LiveCmmTop instr - -> SpillCostInfo +slurpSpillCostInfo :: (PlatformOutputable instr, Instruction instr) + => Platform + -> LiveCmmTop statics instr + -> SpillCostInfo -slurpSpillCostInfo cmm +slurpSpillCostInfo platform cmm = execState (countCmm cmm) zeroSpillCostInfo where countCmm CmmData{} = return () - countCmm (CmmProc info _ _ sccs) + countCmm (CmmProc info _ sccs) = mapM_ (countBlock info) $ flattenSCCs sccs @@ -79,7 +80,7 @@ -- the info table from the CmmProc countBlock info (BasicBlock blockId instrs) | LiveInfo _ _ (Just blockLive) _ <- info - , Just rsLiveEntry <- lookupBlockEnv blockLive blockId + , Just rsLiveEntry <- mapLookup blockId blockLive , rsLiveEntry_virt <- takeVirtuals rsLiveEntry = countLIs rsLiveEntry_virt instrs @@ -96,7 +97,7 @@ | otherwise = pprPanic "RegSpillCost.slurpSpillCostInfo" - (text "no liveness information on instruction " <> ppr instr) + (text "no liveness information on instruction " <> pprPlatform platform instr) countLIs rsLiveEntry (LiveInstr instr (Just live) : lis) = do diff -Nru ghc-7.0.3/compiler/nativeGen/RegAlloc/Graph/Spill.hs ghc-7.2.1/compiler/nativeGen/RegAlloc/Graph/Spill.hs --- ghc-7.0.3/compiler/nativeGen/RegAlloc/Graph/Spill.hs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/nativeGen/RegAlloc/Graph/Spill.hs 2011-08-07 17:10:05.000000000 +0000 @@ -12,7 +12,7 @@ import RegAlloc.Liveness import Instruction import Reg -import Cmm hiding (RegSet) +import OldCmm hiding (RegSet) import BlockId import State @@ -41,13 +41,13 @@ -- regSpill :: Instruction instr - => [LiveCmmTop instr] -- ^ the code + => [LiveCmmTop statics instr] -- ^ the code -> UniqSet Int -- ^ available stack slots -> UniqSet VirtualReg -- ^ the regs to spill -> UniqSM - ([LiveCmmTop instr] -- code with SPILL and RELOAD meta instructions added. - , UniqSet Int -- left over slots - , SpillStats ) -- stats about what happened during spilling + ([LiveCmmTop statics instr] -- code with SPILL and RELOAD meta instructions added. + , UniqSet Int -- left over slots + , SpillStats ) -- stats about what happened during spilling regSpill code slotsFree regs @@ -81,20 +81,20 @@ regSpill_top :: Instruction instr => RegMap Int -- ^ map of vregs to slots they're being spilled to. - -> LiveCmmTop instr -- ^ the top level thing. - -> SpillM (LiveCmmTop instr) + -> LiveCmmTop statics instr -- ^ the top level thing. + -> SpillM (LiveCmmTop statics instr) regSpill_top regSlotMap cmm = case cmm of CmmData{} -> return cmm - CmmProc info label params sccs + CmmProc info label sccs | LiveInfo static firstId mLiveVRegsOnEntry liveSlotsOnEntry <- info -> do -- We should only passed Cmms with the liveness maps filled in, but we'll -- create empty ones if they're not there just in case. - let liveVRegsOnEntry = fromMaybe emptyBlockEnv mLiveVRegsOnEntry + let liveVRegsOnEntry = fromMaybe mapEmpty mLiveVRegsOnEntry -- The liveVRegsOnEntry contains the set of vregs that are live on entry to -- each basic block. If we spill one of those vregs we remove it from that @@ -103,7 +103,7 @@ -- reload instructions after we've done a successful allocation. let liveSlotsOnEntry' :: Map BlockId (Set Int) liveSlotsOnEntry' - = foldBlockEnv patchLiveSlot liveSlotsOnEntry liveVRegsOnEntry + = mapFoldWithKey patchLiveSlot liveSlotsOnEntry liveVRegsOnEntry let info' = LiveInfo static firstId @@ -113,7 +113,7 @@ -- Apply the spiller to all the basic blocks in the CmmProc. sccs' <- mapM (mapSCCM (regSpill_block regSlotMap)) sccs - return $ CmmProc info' label params sccs' + return $ CmmProc info' label sccs' where -- | Given a BlockId and the set of registers live in it, -- if registers in this block are being spilled to stack slots, @@ -292,12 +292,11 @@ newUnique :: SpillM Unique newUnique - = do us <- gets stateUS - case splitUniqSupply us of - (us1, us2) - -> do let uniq = uniqFromSupply us1 - modify $ \s -> s { stateUS = us2 } - return uniq + = do us <- gets stateUS + case takeUniqFromSupply us of + (uniq, us') + -> do modify $ \s -> s { stateUS = us' } + return uniq accSpillSL (r1, s1, l1) (_, s2, l2) = (r1, s1 + s2, l1 + l2) diff -Nru ghc-7.0.3/compiler/nativeGen/RegAlloc/Graph/Stats.hs ghc-7.2.1/compiler/nativeGen/RegAlloc/Graph/Stats.hs --- ghc-7.0.3/compiler/nativeGen/RegAlloc/Graph/Stats.hs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/nativeGen/RegAlloc/Graph/Stats.hs 2011-08-07 17:10:05.000000000 +0000 @@ -27,7 +27,8 @@ import Reg import TargetReg -import Cmm +import OldCmm +import OldPprCmm() import Outputable import UniqFM import UniqSet @@ -35,56 +36,56 @@ import Data.List -data RegAllocStats instr +data RegAllocStats statics instr -- initial graph = RegAllocStatsStart - { raLiveCmm :: [LiveCmmTop instr] -- ^ initial code, with liveness + { raLiveCmm :: [LiveCmmTop statics instr] -- ^ initial code, with liveness , raGraph :: Color.Graph VirtualReg RegClass RealReg -- ^ the initial, uncolored graph , raSpillCosts :: SpillCostInfo } -- ^ information to help choose which regs to spill -- a spill stage | RegAllocStatsSpill - { raCode :: [LiveCmmTop instr] -- ^ the code we tried to allocate registers for + { raCode :: [LiveCmmTop statics instr] -- ^ the code we tried to allocate registers for , raGraph :: Color.Graph VirtualReg RegClass RealReg -- ^ the partially colored graph , raCoalesced :: UniqFM VirtualReg -- ^ the regs that were coaleced , raSpillStats :: SpillStats -- ^ spiller stats , raSpillCosts :: SpillCostInfo -- ^ number of instrs each reg lives for - , raSpilled :: [LiveCmmTop instr] } -- ^ code with spill instructions added + , raSpilled :: [LiveCmmTop statics instr] } -- ^ code with spill instructions added -- a successful coloring | RegAllocStatsColored - { raCode :: [LiveCmmTop instr] -- ^ the code we tried to allocate registers for + { raCode :: [LiveCmmTop statics instr] -- ^ the code we tried to allocate registers for , raGraph :: Color.Graph VirtualReg RegClass RealReg -- ^ the uncolored graph , raGraphColored :: Color.Graph VirtualReg RegClass RealReg -- ^ the coalesced and colored graph , raCoalesced :: UniqFM VirtualReg -- ^ the regs that were coaleced - , raCodeCoalesced :: [LiveCmmTop instr] -- ^ code with coalescings applied - , raPatched :: [LiveCmmTop instr] -- ^ code with vregs replaced by hregs - , raSpillClean :: [LiveCmmTop instr] -- ^ code with unneeded spill\/reloads cleaned out - , raFinal :: [NatCmmTop instr] -- ^ final code + , raCodeCoalesced :: [LiveCmmTop statics instr] -- ^ code with coalescings applied + , raPatched :: [LiveCmmTop statics instr] -- ^ code with vregs replaced by hregs + , raSpillClean :: [LiveCmmTop statics instr] -- ^ code with unneeded spill\/reloads cleaned out + , raFinal :: [NatCmmTop statics instr] -- ^ final code , raSRMs :: (Int, Int, Int) } -- ^ spill\/reload\/reg-reg moves present in this code -instance Outputable instr => Outputable (RegAllocStats instr) where +instance (Outputable statics, PlatformOutputable instr) => PlatformOutputable (RegAllocStats statics instr) where - ppr (s@RegAllocStatsStart{}) + pprPlatform platform (s@RegAllocStatsStart{}) = text "# Start" $$ text "# Native code with liveness information." - $$ ppr (raLiveCmm s) + $$ pprPlatform platform (raLiveCmm s) $$ text "" $$ text "# Initial register conflict graph." $$ Color.dotGraph - targetRegDotColor - (trivColorable - targetVirtualRegSqueeze - targetRealRegSqueeze) + (targetRegDotColor platform) + (trivColorable platform + (targetVirtualRegSqueeze platform) + (targetRealRegSqueeze platform)) (raGraph s) - ppr (s@RegAllocStatsSpill{}) + pprPlatform platform (s@RegAllocStatsSpill{}) = text "# Spill" $$ text "# Code with liveness information." - $$ (ppr (raCode s)) + $$ pprPlatform platform (raCode s) $$ text "" $$ (if (not $ isNullUFM $ raCoalesced s) @@ -98,22 +99,22 @@ $$ text "" $$ text "# Code with spills inserted." - $$ (ppr (raSpilled s)) + $$ pprPlatform platform (raSpilled s) - ppr (s@RegAllocStatsColored { raSRMs = (spills, reloads, moves) }) + pprPlatform platform (s@RegAllocStatsColored { raSRMs = (spills, reloads, moves) }) = text "# Colored" $$ text "# Code with liveness information." - $$ (ppr (raCode s)) + $$ pprPlatform platform (raCode s) $$ text "" $$ text "# Register conflict graph (colored)." $$ Color.dotGraph - targetRegDotColor - (trivColorable - targetVirtualRegSqueeze - targetRealRegSqueeze) + (targetRegDotColor platform) + (trivColorable platform + (targetVirtualRegSqueeze platform) + (targetRealRegSqueeze platform)) (raGraphColored s) $$ text "" @@ -124,19 +125,19 @@ else empty) $$ text "# Native code after coalescings applied." - $$ ppr (raCodeCoalesced s) + $$ pprPlatform platform (raCodeCoalesced s) $$ text "" $$ text "# Native code after register allocation." - $$ ppr (raPatched s) + $$ pprPlatform platform (raPatched s) $$ text "" $$ text "# Clean out unneeded spill/reloads." - $$ ppr (raSpillClean s) + $$ pprPlatform platform (raSpillClean s) $$ text "" $$ text "# Final code, after rewriting spill/rewrite pseudo instrs." - $$ ppr (raFinal s) + $$ pprPlatform platform (raFinal s) $$ text "" $$ text "# Score:" $$ (text "# spills inserted: " <> int spills) @@ -146,7 +147,7 @@ -- | Do all the different analysis on this list of RegAllocStats pprStats - :: [RegAllocStats instr] + :: [RegAllocStats statics instr] -> Color.Graph VirtualReg RegClass RealReg -> SDoc @@ -161,7 +162,7 @@ -- | Dump a table of how many spill loads \/ stores were inserted for each vreg. pprStatsSpills - :: [RegAllocStats instr] -> SDoc + :: [RegAllocStats statics instr] -> SDoc pprStatsSpills stats = let @@ -179,7 +180,7 @@ -- | Dump a table of how long vregs tend to live for in the initial code. pprStatsLifetimes - :: [RegAllocStats instr] -> SDoc + :: [RegAllocStats statics instr] -> SDoc pprStatsLifetimes stats = let info = foldl' plusSpillCostInfo zeroSpillCostInfo @@ -207,7 +208,7 @@ -- | Dump a table of how many conflicts vregs tend to have in the initial code. pprStatsConflict - :: [RegAllocStats instr] -> SDoc + :: [RegAllocStats statics instr] -> SDoc pprStatsConflict stats = let confMap = foldl' (plusUFM_C (\(c1, n1) (_, n2) -> (c1, n1 + n2))) @@ -224,7 +225,7 @@ -- | For every vreg, dump it's how many conflicts it has and its lifetime -- good for making a scatter plot. pprStatsLifeConflict - :: [RegAllocStats instr] + :: [RegAllocStats statics instr] -> Color.Graph VirtualReg RegClass RealReg -- ^ global register conflict graph -> SDoc @@ -255,7 +256,7 @@ -- Lets us see how well the register allocator has done. countSRMs :: Instruction instr - => LiveCmmTop instr -> (Int, Int, Int) + => LiveCmmTop statics instr -> (Int, Int, Int) countSRMs cmm = execState (mapBlockTopM countSRM_block cmm) (0, 0, 0) diff -Nru ghc-7.0.3/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs ghc-7.2.1/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs --- ghc-7.0.3/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs 2011-08-07 17:10:05.000000000 +0000 @@ -1,7 +1,7 @@ -{-# OPTIONS -fno-warn-unused-binds #-} +{-# LANGUAGE BangPatterns #-} module RegAlloc.Graph.TrivColorable ( - trivColorable, + trivColorable, ) where @@ -15,78 +15,51 @@ import UniqFM import FastTypes +import Platform +import Panic -- trivColorable --------------------------------------------------------------- -- trivColorable function for the graph coloring allocator -- --- This gets hammered by scanGraph during register allocation, --- so needs to be fairly efficient. +-- This gets hammered by scanGraph during register allocation, +-- so needs to be fairly efficient. -- --- NOTE: This only works for arcitectures with just RcInteger and RcDouble --- (which are disjoint) ie. x86, x86_64 and ppc +-- NOTE: This only works for arcitectures with just RcInteger and RcDouble +-- (which are disjoint) ie. x86, x86_64 and ppc -- --- The number of allocatable regs is hard coded here so we can do a fast --- comparision in trivColorable. +-- The number of allocatable regs is hard coded in here so we can do +-- a fast comparision in trivColorable. -- --- It's ok if these numbers are _less_ than the actual number of free regs, --- but they can't be more or the register conflict graph won't color. +-- It's ok if these numbers are _less_ than the actual number of free +-- regs, but they can't be more or the register conflict +-- graph won't color. -- --- If the graph doesn't color then the allocator will panic, but it won't --- generate bad object code or anything nasty like that. +-- If the graph doesn't color then the allocator will panic, but it won't +-- generate bad object code or anything nasty like that. -- --- There is an allocatableRegsInClass :: RegClass -> Int, but doing the unboxing --- is too slow for us here. +-- There is an allocatableRegsInClass :: RegClass -> Int, but doing +-- the unboxing is too slow for us here. +-- TODO: Is that still true? Could we use allocatableRegsInClass +-- without losing performance now? -- --- Look at includes/stg/MachRegs.h to get these numbers. +-- Look at includes/stg/MachRegs.h to get the numbers. -- -#if i386_TARGET_ARCH -#define ALLOCATABLE_REGS_INTEGER (_ILIT(3)) -#define ALLOCATABLE_REGS_DOUBLE (_ILIT(6)) -#define ALLOCATABLE_REGS_FLOAT (_ILIT(0)) -#define ALLOCATABLE_REGS_SSE (_ILIT(8)) - - -#elif x86_64_TARGET_ARCH -#define ALLOCATABLE_REGS_INTEGER (_ILIT(5)) -#define ALLOCATABLE_REGS_DOUBLE (_ILIT(0)) -#define ALLOCATABLE_REGS_FLOAT (_ILIT(0)) -#define ALLOCATABLE_REGS_SSE (_ILIT(10)) - -#elif powerpc_TARGET_ARCH -#define ALLOCATABLE_REGS_INTEGER (_ILIT(16)) -#define ALLOCATABLE_REGS_DOUBLE (_ILIT(26)) -#define ALLOCATABLE_REGS_FLOAT (_ILIT(0)) -#define ALLOCATABLE_REGS_SSE (_ILIT(0)) - - -#elif sparc_TARGET_ARCH -#define ALLOCATABLE_REGS_INTEGER (_ILIT(14)) -#define ALLOCATABLE_REGS_DOUBLE (_ILIT(11)) -#define ALLOCATABLE_REGS_FLOAT (_ILIT(22)) -#define ALLOCATABLE_REGS_SSE (_ILIT(0)) - - -#else -#error ToDo: choose which trivColorable function to use for this architecture. -#endif - - -- Disjoint registers ---------------------------------------------------------- --- --- The definition has been unfolded into individual cases for speed. --- Each architecture has a different register setup, so we use a --- different regSqueeze function for each. --- -accSqueeze - :: FastInt - -> FastInt - -> (reg -> FastInt) - -> UniqFM reg - -> FastInt +-- +-- The definition has been unfolded into individual cases for speed. +-- Each architecture has a different register setup, so we use a +-- different regSqueeze function for each. +-- +accSqueeze + :: FastInt + -> FastInt + -> (reg -> FastInt) + -> UniqFM reg + -> FastInt accSqueeze count maxCount squeeze ufm = acc count (eltsUFM ufm) where acc count [] = count @@ -126,59 +99,96 @@ -} trivColorable - :: (RegClass -> VirtualReg -> FastInt) - -> (RegClass -> RealReg -> FastInt) - -> Triv VirtualReg RegClass RealReg - -trivColorable virtualRegSqueeze realRegSqueeze RcInteger conflicts exclusions - | count2 <- accSqueeze (_ILIT(0)) ALLOCATABLE_REGS_INTEGER - (virtualRegSqueeze RcInteger) - conflicts - - , count3 <- accSqueeze count2 ALLOCATABLE_REGS_INTEGER - (realRegSqueeze RcInteger) - exclusions - - = count3 <# ALLOCATABLE_REGS_INTEGER - -trivColorable virtualRegSqueeze realRegSqueeze RcFloat conflicts exclusions - | count2 <- accSqueeze (_ILIT(0)) ALLOCATABLE_REGS_FLOAT - (virtualRegSqueeze RcFloat) - conflicts - - , count3 <- accSqueeze count2 ALLOCATABLE_REGS_FLOAT - (realRegSqueeze RcFloat) - exclusions - - = count3 <# ALLOCATABLE_REGS_FLOAT - -trivColorable virtualRegSqueeze realRegSqueeze RcDouble conflicts exclusions - | count2 <- accSqueeze (_ILIT(0)) ALLOCATABLE_REGS_DOUBLE - (virtualRegSqueeze RcDouble) - conflicts - - , count3 <- accSqueeze count2 ALLOCATABLE_REGS_DOUBLE - (realRegSqueeze RcDouble) - exclusions - - = count3 <# ALLOCATABLE_REGS_DOUBLE - -trivColorable virtualRegSqueeze realRegSqueeze RcDoubleSSE conflicts exclusions - | count2 <- accSqueeze (_ILIT(0)) ALLOCATABLE_REGS_SSE - (virtualRegSqueeze RcDoubleSSE) - conflicts - - , count3 <- accSqueeze count2 ALLOCATABLE_REGS_SSE - (realRegSqueeze RcDoubleSSE) - exclusions + :: Platform + -> (RegClass -> VirtualReg -> FastInt) + -> (RegClass -> RealReg -> FastInt) + -> Triv VirtualReg RegClass RealReg + +trivColorable platform virtualRegSqueeze realRegSqueeze RcInteger conflicts exclusions + | let !cALLOCATABLE_REGS_INTEGER + = iUnbox (case platformArch platform of + ArchX86 -> 3 + ArchX86_64 -> 5 + ArchPPC -> 16 + ArchSPARC -> 14 + ArchPPC_64 -> panic "trivColorable ArchPPC_64" + ArchARM -> panic "trivColorable ArchARM" + ArchUnknown -> panic "trivColorable ArchUnknown") + , count2 <- accSqueeze (_ILIT(0)) cALLOCATABLE_REGS_INTEGER + (virtualRegSqueeze RcInteger) + conflicts + + , count3 <- accSqueeze count2 cALLOCATABLE_REGS_INTEGER + (realRegSqueeze RcInteger) + exclusions + + = count3 <# cALLOCATABLE_REGS_INTEGER + +trivColorable platform virtualRegSqueeze realRegSqueeze RcFloat conflicts exclusions + | let !cALLOCATABLE_REGS_FLOAT + = iUnbox (case platformArch platform of + ArchX86 -> 0 + ArchX86_64 -> 0 + ArchPPC -> 0 + ArchSPARC -> 22 + ArchPPC_64 -> panic "trivColorable ArchPPC_64" + ArchARM -> panic "trivColorable ArchARM" + ArchUnknown -> panic "trivColorable ArchUnknown") + , count2 <- accSqueeze (_ILIT(0)) cALLOCATABLE_REGS_FLOAT + (virtualRegSqueeze RcFloat) + conflicts + + , count3 <- accSqueeze count2 cALLOCATABLE_REGS_FLOAT + (realRegSqueeze RcFloat) + exclusions + + = count3 <# cALLOCATABLE_REGS_FLOAT + +trivColorable platform virtualRegSqueeze realRegSqueeze RcDouble conflicts exclusions + | let !cALLOCATABLE_REGS_DOUBLE + = iUnbox (case platformArch platform of + ArchX86 -> 6 + ArchX86_64 -> 0 + ArchPPC -> 26 + ArchSPARC -> 11 + ArchPPC_64 -> panic "trivColorable ArchPPC_64" + ArchARM -> panic "trivColorable ArchARM" + ArchUnknown -> panic "trivColorable ArchUnknown") + , count2 <- accSqueeze (_ILIT(0)) cALLOCATABLE_REGS_DOUBLE + (virtualRegSqueeze RcDouble) + conflicts + + , count3 <- accSqueeze count2 cALLOCATABLE_REGS_DOUBLE + (realRegSqueeze RcDouble) + exclusions + + = count3 <# cALLOCATABLE_REGS_DOUBLE + +trivColorable platform virtualRegSqueeze realRegSqueeze RcDoubleSSE conflicts exclusions + | let !cALLOCATABLE_REGS_SSE + = iUnbox (case platformArch platform of + ArchX86 -> 8 + ArchX86_64 -> 10 + ArchPPC -> 0 + ArchSPARC -> 0 + ArchPPC_64 -> panic "trivColorable ArchPPC_64" + ArchARM -> panic "trivColorable ArchARM" + ArchUnknown -> panic "trivColorable ArchUnknown") + , count2 <- accSqueeze (_ILIT(0)) cALLOCATABLE_REGS_SSE + (virtualRegSqueeze RcDoubleSSE) + conflicts + + , count3 <- accSqueeze count2 cALLOCATABLE_REGS_SSE + (realRegSqueeze RcDoubleSSE) + exclusions - = count3 <# ALLOCATABLE_REGS_SSE + = count3 <# cALLOCATABLE_REGS_SSE -- Specification Code ---------------------------------------------------------- -- --- The trivColorable function for each particular architecture should --- implement the following function, but faster. +-- The trivColorable function for each particular architecture should +-- implement the following function, but faster. -- {- @@ -186,39 +196,39 @@ trivColorable classN conflicts exclusions = let - acc :: Reg -> (Int, Int) -> (Int, Int) - acc r (cd, cf) - = case regClass r of - RcInteger -> (cd+1, cf) - RcFloat -> (cd, cf+1) - _ -> panic "Regs.trivColorable: reg class not handled" + acc :: Reg -> (Int, Int) -> (Int, Int) + acc r (cd, cf) + = case regClass r of + RcInteger -> (cd+1, cf) + RcFloat -> (cd, cf+1) + _ -> panic "Regs.trivColorable: reg class not handled" - tmp = foldUniqSet acc (0, 0) conflicts - (countInt, countFloat) = foldUniqSet acc tmp exclusions + tmp = foldUniqSet acc (0, 0) conflicts + (countInt, countFloat) = foldUniqSet acc tmp exclusions - squeese = worst countInt classN RcInteger - + worst countFloat classN RcFloat + squeese = worst countInt classN RcInteger + + worst countFloat classN RcFloat - in squeese < allocatableRegsInClass classN + in squeese < allocatableRegsInClass classN -- | Worst case displacement --- node N of classN has n neighbors of class C. +-- node N of classN has n neighbors of class C. -- --- We currently only have RcInteger and RcDouble, which don't conflict at all. --- This is a bit boring compared to what's in RegArchX86. +-- We currently only have RcInteger and RcDouble, which don't conflict at all. +-- This is a bit boring compared to what's in RegArchX86. -- worst :: Int -> RegClass -> RegClass -> Int worst n classN classC = case classN of - RcInteger - -> case classC of - RcInteger -> min n (allocatableRegsInClass RcInteger) - RcFloat -> 0 - - RcDouble - -> case classC of - RcFloat -> min n (allocatableRegsInClass RcFloat) - RcInteger -> 0 + RcInteger + -> case classC of + RcInteger -> min n (allocatableRegsInClass RcInteger) + RcFloat -> 0 + + RcDouble + -> case classC of + RcFloat -> min n (allocatableRegsInClass RcFloat) + RcInteger -> 0 -- allocatableRegs is allMachRegNos with the fixed-use regs removed. -- i.e., these are the regs for which we are prepared to allow the @@ -230,21 +240,21 @@ -- | The number of regs in each class. --- We go via top level CAFs to ensure that we're not recomputing --- the length of these lists each time the fn is called. +-- We go via top level CAFs to ensure that we're not recomputing +-- the length of these lists each time the fn is called. allocatableRegsInClass :: RegClass -> Int allocatableRegsInClass cls = case cls of - RcInteger -> allocatableRegsInteger - RcFloat -> allocatableRegsDouble + RcInteger -> allocatableRegsInteger + RcFloat -> allocatableRegsDouble allocatableRegsInteger :: Int -allocatableRegsInteger - = length $ filter (\r -> regClass r == RcInteger) - $ map RealReg allocatableRegs +allocatableRegsInteger + = length $ filter (\r -> regClass r == RcInteger) + $ map RealReg allocatableRegs allocatableRegsFloat :: Int allocatableRegsFloat - = length $ filter (\r -> regClass r == RcFloat - $ map RealReg allocatableRegs + = length $ filter (\r -> regClass r == RcFloat + $ map RealReg allocatableRegs -} diff -Nru ghc-7.0.3/compiler/nativeGen/RegAlloc/Linear/Base.hs ghc-7.2.1/compiler/nativeGen/RegAlloc/Linear/Base.hs --- ghc-7.0.3/compiler/nativeGen/RegAlloc/Linear/Base.hs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/nativeGen/RegAlloc/Linear/Base.hs 2011-08-07 17:10:05.000000000 +0000 @@ -2,23 +2,22 @@ -- | Put common type definitions here to break recursive module dependencies. module RegAlloc.Linear.Base ( - BlockAssignment, + BlockAssignment, - Loc(..), - regsOfLoc, + Loc(..), + regsOfLoc, - -- for stats - SpillReason(..), - RegAllocStats(..), - - -- the allocator monad - RA_State(..), - RegM(..) + -- for stats + SpillReason(..), + RegAllocStats(..), + + -- the allocator monad + RA_State(..), + RegM(..) ) where -import RegAlloc.Linear.FreeRegs import RegAlloc.Linear.StackMap import RegAlloc.Liveness import Reg @@ -30,40 +29,40 @@ -- | Used to store the register assignment on entry to a basic block. --- We use this to handle join points, where multiple branch instructions --- target a particular label. We have to insert fixup code to make --- the register assignments from the different sources match up. +-- We use this to handle join points, where multiple branch instructions +-- target a particular label. We have to insert fixup code to make +-- the register assignments from the different sources match up. -- -type BlockAssignment - = BlockMap (FreeRegs, RegMap Loc) +type BlockAssignment freeRegs + = BlockMap (freeRegs, RegMap Loc) -- | Where a vreg is currently stored --- A temporary can be marked as living in both a register and memory --- (InBoth), for example if it was recently loaded from a spill location. --- This makes it cheap to spill (no save instruction required), but we --- have to be careful to turn this into InReg if the value in the --- register is changed. - --- This is also useful when a temporary is about to be clobbered. We --- save it in a spill location, but mark it as InBoth because the current --- instruction might still want to read it. +-- A temporary can be marked as living in both a register and memory +-- (InBoth), for example if it was recently loaded from a spill location. +-- This makes it cheap to spill (no save instruction required), but we +-- have to be careful to turn this into InReg if the value in the +-- register is changed. + +-- This is also useful when a temporary is about to be clobbered. We +-- save it in a spill location, but mark it as InBoth because the current +-- instruction might still want to read it. -- -data Loc - -- | vreg is in a register - = InReg !RealReg - - -- | vreg is held in a stack slot - | InMem {-# UNPACK #-} !StackSlot +data Loc + -- | vreg is in a register + = InReg !RealReg + + -- | vreg is held in a stack slot + | InMem {-# UNPACK #-} !StackSlot - -- | vreg is held in both a register and a stack slot - | InBoth !RealReg - {-# UNPACK #-} !StackSlot - deriving (Eq, Show, Ord) + -- | vreg is held in both a register and a stack slot + | InBoth !RealReg + {-# UNPACK #-} !StackSlot + deriving (Eq, Show, Ord) instance Outputable Loc where - ppr l = text (show l) + ppr l = text (show l) -- | Get the reg numbers stored in this Loc. @@ -74,64 +73,64 @@ -- | Reasons why instructions might be inserted by the spiller. --- Used when generating stats for -ddrop-asm-stats. +-- Used when generating stats for -ddrop-asm-stats. -- data SpillReason - -- | vreg was spilled to a slot so we could use its - -- current hreg for another vreg - = SpillAlloc !Unique + -- | vreg was spilled to a slot so we could use its + -- current hreg for another vreg + = SpillAlloc !Unique - -- | vreg was moved because its hreg was clobbered - | SpillClobber !Unique + -- | vreg was moved because its hreg was clobbered + | SpillClobber !Unique - -- | vreg was loaded from a spill slot - | SpillLoad !Unique + -- | vreg was loaded from a spill slot + | SpillLoad !Unique - -- | reg-reg move inserted during join to targets - | SpillJoinRR !Unique + -- | reg-reg move inserted during join to targets + | SpillJoinRR !Unique - -- | reg-mem move inserted during join to targets - | SpillJoinRM !Unique + -- | reg-mem move inserted during join to targets + | SpillJoinRM !Unique -- | Used to carry interesting stats out of the register allocator. data RegAllocStats - = RegAllocStats - { ra_spillInstrs :: UniqFM [Int] } + = RegAllocStats + { ra_spillInstrs :: UniqFM [Int] } -- | The register alloctor state -data RA_State - = RA_State +data RA_State freeRegs + = RA_State - { - -- | the current mapping from basic blocks to - -- the register assignments at the beginning of that block. - ra_blockassig :: BlockAssignment - - -- | free machine registers - , ra_freeregs :: {-#UNPACK#-}!FreeRegs - - -- | assignment of temps to locations - , ra_assig :: RegMap Loc - - -- | current stack delta - , ra_delta :: Int - - -- | free stack slots for spilling - , ra_stack :: StackMap - - -- | unique supply for generating names for join point fixup blocks. - , ra_us :: UniqSupply - - -- | Record why things were spilled, for -ddrop-asm-stats. - -- Just keep a list here instead of a map of regs -> reasons. - -- We don't want to slow down the allocator if we're not going to emit the stats. - , ra_spills :: [SpillReason] } + { + -- | the current mapping from basic blocks to + -- the register assignments at the beginning of that block. + ra_blockassig :: BlockAssignment freeRegs + + -- | free machine registers + , ra_freeregs :: !freeRegs + + -- | assignment of temps to locations + , ra_assig :: RegMap Loc + + -- | current stack delta + , ra_delta :: Int + + -- | free stack slots for spilling + , ra_stack :: StackMap + + -- | unique supply for generating names for join point fixup blocks. + , ra_us :: UniqSupply + + -- | Record why things were spilled, for -ddrop-asm-stats. + -- Just keep a list here instead of a map of regs -> reasons. + -- We don't want to slow down the allocator if we're not going to emit the stats. + , ra_spills :: [SpillReason] } -- | The register allocator monad type. -newtype RegM a - = RegM { unReg :: RA_State -> (# RA_State, a #) } +newtype RegM freeRegs a + = RegM { unReg :: RA_State freeRegs -> (# RA_State freeRegs, a #) } diff -Nru ghc-7.0.3/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs ghc-7.2.1/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs --- ghc-7.0.3/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs 2011-08-07 17:10:05.000000000 +0000 @@ -1,18 +1,19 @@ module RegAlloc.Linear.FreeRegs ( - FreeRegs(), - noFreeRegs, - releaseReg, - initFreeRegs, - getFreeRegs, - allocateReg, - maxSpillSlots + FR(..), + maxSpillSlots ) #include "HsVersions.h" where +import Reg +import RegClass + +import Panic +import Platform + -- ----------------------------------------------------------------------------- -- The free register set -- This needs to be *efficient* @@ -25,21 +26,46 @@ -- getFreeRegs cls f = filter ( (==cls) . regClass . RealReg ) f -- allocateReg f r = filter (/= r) f - -#if defined(powerpc_TARGET_ARCH) -import RegAlloc.Linear.PPC.FreeRegs -import PPC.Instr (maxSpillSlots) - -#elif defined(sparc_TARGET_ARCH) -import RegAlloc.Linear.SPARC.FreeRegs -import SPARC.Instr (maxSpillSlots) - -#elif defined(i386_TARGET_ARCH) || defined(x86_64_TARGET_ARCH) -import RegAlloc.Linear.X86.FreeRegs -import X86.Instr (maxSpillSlots) - -#else -#error "RegAlloc.Linear.FreeRegs not defined for this architecture." - -#endif +import qualified RegAlloc.Linear.PPC.FreeRegs as PPC +import qualified RegAlloc.Linear.SPARC.FreeRegs as SPARC +import qualified RegAlloc.Linear.X86.FreeRegs as X86 + +import qualified PPC.Instr +import qualified SPARC.Instr +import qualified X86.Instr + +class Show freeRegs => FR freeRegs where + frAllocateReg :: RealReg -> freeRegs -> freeRegs + frGetFreeRegs :: RegClass -> freeRegs -> [RealReg] + frInitFreeRegs :: freeRegs + frReleaseReg :: RealReg -> freeRegs -> freeRegs + +instance FR X86.FreeRegs where + frAllocateReg = X86.allocateReg + frGetFreeRegs = X86.getFreeRegs + frInitFreeRegs = X86.initFreeRegs + frReleaseReg = X86.releaseReg + +instance FR PPC.FreeRegs where + frAllocateReg = PPC.allocateReg + frGetFreeRegs = PPC.getFreeRegs + frInitFreeRegs = PPC.initFreeRegs + frReleaseReg = PPC.releaseReg + +instance FR SPARC.FreeRegs where + frAllocateReg = SPARC.allocateReg + frGetFreeRegs = SPARC.getFreeRegs + frInitFreeRegs = SPARC.initFreeRegs + frReleaseReg = SPARC.releaseReg + +maxSpillSlots :: Platform -> Int +maxSpillSlots platform + = case platformArch platform of + ArchX86 -> X86.Instr.maxSpillSlots + ArchX86_64 -> X86.Instr.maxSpillSlots + ArchPPC -> PPC.Instr.maxSpillSlots + ArchSPARC -> SPARC.Instr.maxSpillSlots + ArchARM -> panic "maxSpillSlots ArchARM" + ArchPPC_64 -> panic "maxSpillSlots ArchPPC_64" + ArchUnknown -> panic "maxSpillSlots ArchUnknown" diff -Nru ghc-7.0.3/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs ghc-7.2.1/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs --- ghc-7.0.3/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs 2011-08-07 17:10:05.000000000 +0000 @@ -1,5 +1,3 @@ -{-# OPTIONS -fno-warn-missing-signatures #-} - -- | Handles joining of a jump instruction to its targets. @@ -23,9 +21,10 @@ import Reg import BlockId -import Cmm hiding (RegSet) +import OldCmm hiding (RegSet) import Digraph import Outputable +import Platform import Unique import UniqFM import UniqSet @@ -35,30 +34,32 @@ -- vregs are in the correct regs for its destination. -- joinToTargets - :: Instruction instr - => BlockMap RegSet -- ^ maps the unique of the blockid to the set of vregs + :: (FR freeRegs, Instruction instr) + => Platform + -> BlockMap RegSet -- ^ maps the unique of the blockid to the set of vregs -- that are known to be live on the entry to each block. -> BlockId -- ^ id of the current block -> instr -- ^ branch instr on the end of the source block. - -> RegM ([NatBasicBlock instr] -- fresh blocks of fixup code. + -> RegM freeRegs ([NatBasicBlock instr] -- fresh blocks of fixup code. , instr) -- the original branch instruction, but maybe patched to jump -- to a fixup block first. -joinToTargets block_live id instr +joinToTargets platform block_live id instr -- we only need to worry about jump instructions. | not $ isJumpishInstr instr = return ([], instr) | otherwise - = joinToTargets' block_live [] id instr (jumpDestsOfInstr instr) + = joinToTargets' platform block_live [] id instr (jumpDestsOfInstr instr) ----- joinToTargets' - :: Instruction instr - => BlockMap RegSet -- ^ maps the unique of the blockid to the set of vregs + :: (FR freeRegs, Instruction instr) + => Platform + -> BlockMap RegSet -- ^ maps the unique of the blockid to the set of vregs -- that are known to be live on the entry to each block. -> [NatBasicBlock instr] -- ^ acc blocks of fixup code. @@ -68,15 +69,15 @@ -> [BlockId] -- ^ branch destinations still to consider. - -> RegM ( [NatBasicBlock instr] + -> RegM freeRegs ( [NatBasicBlock instr] , instr) -- no more targets to consider. all done. -joinToTargets' _ new_blocks _ instr [] +joinToTargets' _ _ new_blocks _ instr [] = return (new_blocks, instr) -- handle a branch target. -joinToTargets' block_live new_blocks block_id instr (dest:dests) +joinToTargets' platform block_live new_blocks block_id instr (dest:dests) = do -- get the map of where the vregs are stored on entry to each basic block. block_assig <- getBlockAssigR @@ -86,7 +87,7 @@ -- adjust the current assignment to remove any vregs that are not live -- on entry to the destination block. - let Just live_set = lookupBlockEnv block_live dest + let Just live_set = mapLookup dest block_live let still_live uniq _ = uniq `elemUniqSet_Directly` live_set let adjusted_assig = filterUFM_Directly still_live assig @@ -96,42 +97,64 @@ , not (elemUniqSet_Directly reg live_set) , r <- regsOfLoc loc ] - case lookupBlockEnv block_assig dest of + case mapLookup dest block_assig of Nothing -> joinToTargets_first - block_live new_blocks block_id instr dest dests + platform block_live new_blocks block_id instr dest dests block_assig adjusted_assig to_free Just (_, dest_assig) -> joinToTargets_again - block_live new_blocks block_id instr dest dests + platform block_live new_blocks block_id instr dest dests adjusted_assig dest_assig -- this is the first time we jumped to this block. -joinToTargets_first block_live new_blocks block_id instr dest dests +joinToTargets_first :: (FR freeRegs, Instruction instr) + => Platform + -> BlockMap RegSet + -> [NatBasicBlock instr] + -> BlockId + -> instr + -> BlockId + -> [BlockId] + -> BlockAssignment freeRegs + -> RegMap Loc + -> [RealReg] + -> RegM freeRegs ([NatBasicBlock instr], instr) +joinToTargets_first platform block_live new_blocks block_id instr dest dests block_assig src_assig - (to_free :: [RealReg]) + to_free = do -- free up the regs that are not live on entry to this block. freeregs <- getFreeRegsR - let freeregs' = foldr releaseReg freeregs to_free + let freeregs' = foldr frReleaseReg freeregs to_free -- remember the current assignment on entry to this block. - setBlockAssigR (extendBlockEnv block_assig dest - (freeregs', src_assig)) + setBlockAssigR (mapInsert dest (freeregs', src_assig) block_assig) - joinToTargets' block_live new_blocks block_id instr dests + joinToTargets' platform block_live new_blocks block_id instr dests -- we've jumped to this block before -joinToTargets_again - block_live new_blocks block_id instr dest dests - src_assig dest_assig +joinToTargets_again :: (Instruction instr, FR freeRegs) + => Platform + -> BlockMap RegSet + -> [NatBasicBlock instr] + -> BlockId + -> instr + -> BlockId + -> [BlockId] + -> UniqFM Loc + -> UniqFM Loc + -> RegM freeRegs ([NatBasicBlock instr], instr) +joinToTargets_again + platform block_live new_blocks block_id instr dest dests + src_assig dest_assig -- the assignments already match, no problem. | ufmToList dest_assig == ufmToList src_assig - = joinToTargets' block_live new_blocks block_id instr dests + = joinToTargets' platform block_live new_blocks block_id instr dests -- assignments don't match, need fixup code | otherwise @@ -166,14 +189,14 @@ (return ()) -} delta <- getDeltaR - fixUpInstrs_ <- mapM (handleComponent delta instr) sccs + fixUpInstrs_ <- mapM (handleComponent platform delta instr) sccs let fixUpInstrs = concat fixUpInstrs_ -- make a new basic block containing the fixup code. -- A the end of the current block we will jump to the fixup one, -- then that will jump to our original destination. fixup_block_id <- getUniqueR - let block = BasicBlock (BlockId fixup_block_id) + let block = BasicBlock (mkBlockId fixup_block_id) $ fixUpInstrs ++ mkJumpInstr dest {- pprTrace @@ -184,16 +207,16 @@ -} -- if we didn't need any fixups, then don't include the block case fixUpInstrs of - [] -> joinToTargets' block_live new_blocks block_id instr dests + [] -> joinToTargets' platform block_live new_blocks block_id instr dests -- patch the original branch instruction so it goes to our -- fixup block instead. _ -> let instr' = patchJumpInstr instr (\bid -> if bid == dest - then BlockId fixup_block_id - else dest) + then mkBlockId fixup_block_id + else bid) -- no change! - in joinToTargets' block_live (block : new_blocks) block_id instr' dests + in joinToTargets' platform block_live (block : new_blocks) block_id instr' dests -- | Construct a graph of register\/spill movements. @@ -263,14 +286,14 @@ -- handleComponent :: Instruction instr - => Int -> instr -> SCC (Unique, Loc, [Loc]) -> RegM [instr] + => Platform -> Int -> instr -> SCC (Unique, Loc, [Loc]) -> RegM freeRegs [instr] -- If the graph is acyclic then we won't get the swapping problem below. -- In this case we can just do the moves directly, and avoid having to -- go via a spill slot. -- -handleComponent delta _ (AcyclicSCC (vreg, src, dsts)) - = mapM (makeMove delta vreg src) dsts +handleComponent platform delta _ (AcyclicSCC (vreg, src, dsts)) + = mapM (makeMove platform delta vreg src) dsts -- Handle some cyclic moves. @@ -288,53 +311,54 @@ -- are allocated exclusively for a virtual register and therefore can not -- require a fixup. -- -handleComponent delta instr +handleComponent platform delta instr (CyclicSCC ( (vreg, InReg sreg, (InReg dreg: _)) : rest)) -- dest list may have more than one element, if the reg is also InMem. = do -- spill the source into its slot (instrSpill, slot) - <- spillR (RegReal sreg) vreg + <- spillR platform (RegReal sreg) vreg -- reload into destination reg - instrLoad <- loadR (RegReal dreg) slot + instrLoad <- loadR platform (RegReal dreg) slot - remainingFixUps <- mapM (handleComponent delta instr) + remainingFixUps <- mapM (handleComponent platform delta instr) (stronglyConnCompFromEdgedVerticesR rest) -- make sure to do all the reloads after all the spills, -- so we don't end up clobbering the source values. return ([instrSpill] ++ concat remainingFixUps ++ [instrLoad]) -handleComponent _ _ (CyclicSCC _) +handleComponent _ _ _ (CyclicSCC _) = panic "Register Allocator: handleComponent cyclic" -- | Move a vreg between these two locations. -- -makeMove - :: Instruction instr - => Int -- ^ current C stack delta. - -> Unique -- ^ unique of the vreg that we're moving. - -> Loc -- ^ source location. - -> Loc -- ^ destination location. - -> RegM instr -- ^ move instruction. - -makeMove _ vreg (InReg src) (InReg dst) - = do recordSpill (SpillJoinRR vreg) - return $ mkRegRegMoveInstr (RegReal src) (RegReal dst) - -makeMove delta vreg (InMem src) (InReg dst) - = do recordSpill (SpillJoinRM vreg) - return $ mkLoadInstr (RegReal dst) delta src - -makeMove delta vreg (InReg src) (InMem dst) - = do recordSpill (SpillJoinRM vreg) - return $ mkSpillInstr (RegReal src) delta dst +makeMove + :: Instruction instr + => Platform + -> Int -- ^ current C stack delta. + -> Unique -- ^ unique of the vreg that we're moving. + -> Loc -- ^ source location. + -> Loc -- ^ destination location. + -> RegM freeRegs instr -- ^ move instruction. + +makeMove platform _ vreg (InReg src) (InReg dst) + = do recordSpill (SpillJoinRR vreg) + return $ mkRegRegMoveInstr platform (RegReal src) (RegReal dst) + +makeMove platform delta vreg (InMem src) (InReg dst) + = do recordSpill (SpillJoinRM vreg) + return $ mkLoadInstr platform (RegReal dst) delta src + +makeMove platform delta vreg (InReg src) (InMem dst) + = do recordSpill (SpillJoinRM vreg) + return $ mkSpillInstr platform (RegReal src) delta dst -- we don't handle memory to memory moves. -- they shouldn't happen because we don't share stack slots between vregs. -makeMove _ vreg src dst +makeMove _ _ vreg src dst = panic $ "makeMove " ++ show vreg ++ " (" ++ show src ++ ") (" ++ show dst ++ ")" ++ " we don't handle mem->mem moves." diff -Nru ghc-7.0.3/compiler/nativeGen/RegAlloc/Linear/Main.hs ghc-7.2.1/compiler/nativeGen/RegAlloc/Linear/Main.hs --- ghc-7.0.3/compiler/nativeGen/RegAlloc/Linear/Main.hs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/nativeGen/RegAlloc/Linear/Main.hs 2011-08-07 17:10:05.000000000 +0000 @@ -1,4 +1,3 @@ -{-# OPTIONS -fno-warn-missing-signatures #-} ----------------------------------------------------------------------------- -- -- The register allocator @@ -9,82 +8,82 @@ {- The algorithm is roughly: - + 1) Compute strongly connected components of the basic block list. 2) Compute liveness (mapping from pseudo register to point(s) of death?). 3) Walk instructions in each basic block. We keep track of - (a) Free real registers (a bitmap?) - (b) Current assignment of temporaries to machine registers and/or - spill slots (call this the "assignment"). - (c) Partial mapping from basic block ids to a virt-to-loc mapping. - When we first encounter a branch to a basic block, - we fill in its entry in this table with the current mapping. + (a) Free real registers (a bitmap?) + (b) Current assignment of temporaries to machine registers and/or + spill slots (call this the "assignment"). + (c) Partial mapping from basic block ids to a virt-to-loc mapping. + When we first encounter a branch to a basic block, + we fill in its entry in this table with the current mapping. For each instruction: - (a) For each real register clobbered by this instruction: - If a temporary resides in it, - If the temporary is live after this instruction, - Move the temporary to another (non-clobbered & free) reg, - or spill it to memory. Mark the temporary as residing - in both memory and a register if it was spilled (it might - need to be read by this instruction). - (ToDo: this is wrong for jump instructions?) - - (b) For each temporary *read* by the instruction: - If the temporary does not have a real register allocation: - - Allocate a real register from the free list. If - the list is empty: - - Find a temporary to spill. Pick one that is - not used in this instruction (ToDo: not - used for a while...) - - generate a spill instruction - - If the temporary was previously spilled, - generate an instruction to read the temp from its spill loc. - (optimisation: if we can see that a real register is going to + (a) For each real register clobbered by this instruction: + If a temporary resides in it, + If the temporary is live after this instruction, + Move the temporary to another (non-clobbered & free) reg, + or spill it to memory. Mark the temporary as residing + in both memory and a register if it was spilled (it might + need to be read by this instruction). + (ToDo: this is wrong for jump instructions?) + + (b) For each temporary *read* by the instruction: + If the temporary does not have a real register allocation: + - Allocate a real register from the free list. If + the list is empty: + - Find a temporary to spill. Pick one that is + not used in this instruction (ToDo: not + used for a while...) + - generate a spill instruction + - If the temporary was previously spilled, + generate an instruction to read the temp from its spill loc. + (optimisation: if we can see that a real register is going to be used soon, then don't use it for allocation). - (c) Update the current assignment + (c) Update the current assignment - (d) If the intstruction is a branch: - if the destination block already has a register assignment, - Generate a new block with fixup code and redirect the - jump to the new block. - else, - Update the block id->assignment mapping with the current - assignment. - - (e) Delete all register assignments for temps which are read - (only) and die here. Update the free register list. - - (f) Mark all registers clobbered by this instruction as not free, - and mark temporaries which have been spilled due to clobbering - as in memory (step (a) marks then as in both mem & reg). - - (g) For each temporary *written* by this instruction: - Allocate a real register as for (b), spilling something - else if necessary. - - except when updating the assignment, drop any memory - locations that the temporary was previously in, since - they will be no longer valid after this instruction. - - (h) Delete all register assignments for temps which are - written and die here (there should rarely be any). Update - the free register list. + (d) If the instruction is a branch: + if the destination block already has a register assignment, + Generate a new block with fixup code and redirect the + jump to the new block. + else, + Update the block id->assignment mapping with the current + assignment. + + (e) Delete all register assignments for temps which are read + (only) and die here. Update the free register list. + + (f) Mark all registers clobbered by this instruction as not free, + and mark temporaries which have been spilled due to clobbering + as in memory (step (a) marks then as in both mem & reg). + + (g) For each temporary *written* by this instruction: + Allocate a real register as for (b), spilling something + else if necessary. + - except when updating the assignment, drop any memory + locations that the temporary was previously in, since + they will be no longer valid after this instruction. + + (h) Delete all register assignments for temps which are + written and die here (there should rarely be any). Update + the free register list. - (i) Rewrite the instruction with the new mapping. + (i) Rewrite the instruction with the new mapping. - (j) For each spilled reg known to be now dead, re-add its stack slot - to the free list. + (j) For each spilled reg known to be now dead, re-add its stack slot + to the free list. -} module RegAlloc.Linear.Main ( - regAlloc, - module RegAlloc.Linear.Base, - module RegAlloc.Linear.Stats + regAlloc, + module RegAlloc.Linear.Base, + module RegAlloc.Linear.Stats ) where #include "HsVersions.h" @@ -96,20 +95,25 @@ import RegAlloc.Linear.FreeRegs import RegAlloc.Linear.Stats import RegAlloc.Linear.JoinToTargets +import qualified RegAlloc.Linear.PPC.FreeRegs as PPC +import qualified RegAlloc.Linear.SPARC.FreeRegs as SPARC +import qualified RegAlloc.Linear.X86.FreeRegs as X86 import TargetReg import RegAlloc.Liveness import Instruction import Reg import BlockId -import Cmm hiding (RegSet) +import OldCmm hiding (RegSet) import Digraph +import DynFlags import Unique import UniqSet import UniqFM import UniqSupply import Outputable +import Platform import Data.Maybe import Data.List @@ -122,38 +126,39 @@ -- Top level of the register allocator -- Allocate registers -regAlloc - :: (Outputable instr, Instruction instr) - => LiveCmmTop instr - -> UniqSM (NatCmmTop instr, Maybe RegAllocStats) - -regAlloc (CmmData sec d) - = return - ( CmmData sec d - , Nothing ) - -regAlloc (CmmProc (LiveInfo info _ _ _) lbl params []) - = return ( CmmProc info lbl params (ListGraph []) - , Nothing ) - -regAlloc (CmmProc static lbl params sccs) - | LiveInfo info (Just first_id) (Just block_live) _ <- static - = do - -- do register allocation on each component. - (final_blocks, stats) - <- linearRegAlloc first_id block_live sccs - - -- make sure the block that was first in the input list - -- stays at the front of the output - let ((first':_), rest') - = partition ((== first_id) . blockId) final_blocks - - return ( CmmProc info lbl params (ListGraph (first' : rest')) - , Just stats) - +regAlloc + :: (PlatformOutputable instr, Instruction instr) + => DynFlags + -> LiveCmmTop statics instr + -> UniqSM (NatCmmTop statics instr, Maybe RegAllocStats) + +regAlloc _ (CmmData sec d) + = return + ( CmmData sec d + , Nothing ) + +regAlloc _ (CmmProc (LiveInfo info _ _ _) lbl []) + = return ( CmmProc info lbl (ListGraph []) + , Nothing ) + +regAlloc dflags (CmmProc static lbl sccs) + | LiveInfo info (Just first_id) (Just block_live) _ <- static + = do + -- do register allocation on each component. + (final_blocks, stats) + <- linearRegAlloc dflags first_id block_live sccs + + -- make sure the block that was first in the input list + -- stays at the front of the output + let ((first':_), rest') + = partition ((== first_id) . blockId) final_blocks + + return ( CmmProc info lbl (ListGraph (first' : rest')) + , Just stats) + -- bogus. to make non-exhaustive match warning go away. -regAlloc (CmmProc _ _ _ _) - = panic "RegAllocLinear.regAlloc: no match" +regAlloc _ (CmmProc _ _ _) + = panic "RegAllocLinear.regAlloc: no match" -- ----------------------------------------------------------------------------- @@ -165,164 +170,207 @@ -- an entry in the block map or it is the first block. -- linearRegAlloc - :: (Outputable instr, Instruction instr) - => BlockId -- ^ the first block - -> BlockMap RegSet -- ^ live regs on entry to each basic block - -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths" - -> UniqSM ([NatBasicBlock instr], RegAllocStats) - -linearRegAlloc first_id block_live sccs - = do us <- getUs - let (_, _, stats, blocks) = - runR emptyBlockMap initFreeRegs emptyRegMap emptyStackMap us - $ linearRA_SCCs first_id block_live [] sccs - - return (blocks, stats) - -linearRA_SCCs _ _ blocksAcc [] - = return $ reverse blocksAcc - -linearRA_SCCs first_id block_live blocksAcc (AcyclicSCC block : sccs) - = do blocks' <- processBlock block_live block - linearRA_SCCs first_id block_live - ((reverse blocks') ++ blocksAcc) - sccs + :: (PlatformOutputable instr, Instruction instr) + => DynFlags + -> BlockId -- ^ the first block + -> BlockMap RegSet -- ^ live regs on entry to each basic block + -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths" + -> UniqSM ([NatBasicBlock instr], RegAllocStats) + +linearRegAlloc dflags first_id block_live sccs + = let platform = targetPlatform dflags + in case platformArch platform of + ArchX86 -> linearRegAlloc' platform (frInitFreeRegs :: X86.FreeRegs) first_id block_live sccs + ArchX86_64 -> linearRegAlloc' platform (frInitFreeRegs :: X86.FreeRegs) first_id block_live sccs + ArchSPARC -> linearRegAlloc' platform (frInitFreeRegs :: SPARC.FreeRegs) first_id block_live sccs + ArchPPC -> linearRegAlloc' platform (frInitFreeRegs :: PPC.FreeRegs) first_id block_live sccs + ArchARM -> panic "linearRegAlloc ArchARM" + ArchPPC_64 -> panic "linearRegAlloc ArchPPC_64" + ArchUnknown -> panic "linearRegAlloc ArchUnknown" + +linearRegAlloc' + :: (FR freeRegs, PlatformOutputable instr, Instruction instr) + => Platform + -> freeRegs + -> BlockId -- ^ the first block + -> BlockMap RegSet -- ^ live regs on entry to each basic block + -> [SCC (LiveBasicBlock instr)] -- ^ instructions annotated with "deaths" + -> UniqSM ([NatBasicBlock instr], RegAllocStats) + +linearRegAlloc' platform initFreeRegs first_id block_live sccs + = do us <- getUs + let (_, _, stats, blocks) = + runR emptyBlockMap initFreeRegs emptyRegMap (emptyStackMap platform) us + $ linearRA_SCCs platform first_id block_live [] sccs + return (blocks, stats) + + +linearRA_SCCs :: (FR freeRegs, Instruction instr, PlatformOutputable instr) + => Platform + -> BlockId + -> BlockMap RegSet + -> [NatBasicBlock instr] + -> [SCC (LiveBasicBlock instr)] + -> RegM freeRegs [NatBasicBlock instr] + +linearRA_SCCs _ _ _ blocksAcc [] + = return $ reverse blocksAcc + +linearRA_SCCs platform first_id block_live blocksAcc (AcyclicSCC block : sccs) + = do blocks' <- processBlock platform block_live block + linearRA_SCCs platform first_id block_live + ((reverse blocks') ++ blocksAcc) + sccs -linearRA_SCCs first_id block_live blocksAcc (CyclicSCC blocks : sccs) +linearRA_SCCs platform first_id block_live blocksAcc (CyclicSCC blocks : sccs) = do - blockss' <- process first_id block_live blocks [] (return []) False - linearRA_SCCs first_id block_live - (reverse (concat blockss') ++ blocksAcc) - sccs + blockss' <- process platform first_id block_live blocks [] (return []) False + linearRA_SCCs platform first_id block_live + (reverse (concat blockss') ++ blocksAcc) + sccs {- from John Dias's patch 2008/10/16: The linear-scan allocator sometimes allocates a block - before allocating one of its predecessors, which could lead to + before allocating one of its predecessors, which could lead to inconsistent allocations. Make it so a block is only allocated if a predecessor has set the "incoming" assignments for the block, or if it's the procedure's entry block. BL 2009/02: Careful. If the assignment for a block doesn't get set for - some reason then this function will loop. We should probably do some + some reason then this function will loop. We should probably do some more sanity checking to guard against this eventuality. -} -process _ _ [] [] accum _ - = return $ reverse accum +process :: (FR freeRegs, Instruction instr, PlatformOutputable instr) + => Platform + -> BlockId + -> BlockMap RegSet + -> [GenBasicBlock (LiveInstr instr)] + -> [GenBasicBlock (LiveInstr instr)] + -> [[NatBasicBlock instr]] + -> Bool + -> RegM freeRegs [[NatBasicBlock instr]] + +process _ _ _ [] [] accum _ + = return $ reverse accum + +process platform first_id block_live [] next_round accum madeProgress + | not madeProgress + + {- BUGS: There are so many unreachable blocks in the code the warnings are overwhelming. + pprTrace "RegAlloc.Linear.Main.process: no progress made, bailing out." + ( text "Unreachable blocks:" + $$ vcat (map ppr next_round)) -} + = return $ reverse accum + + | otherwise + = process platform first_id block_live + next_round [] accum False -process first_id block_live [] next_round accum madeProgress - | not madeProgress - - {- BUGS: There are so many unreachable blocks in the code the warnings are overwhelming. - pprTrace "RegAlloc.Linear.Main.process: no progress made, bailing out." - ( text "Unreachable blocks:" - $$ vcat (map ppr next_round)) -} - = return $ reverse accum - - | otherwise - = process first_id block_live - next_round [] accum False - -process first_id block_live (b@(BasicBlock id _) : blocks) - next_round accum madeProgress - = do - block_assig <- getBlockAssigR +process platform first_id block_live (b@(BasicBlock id _) : blocks) + next_round accum madeProgress + = do + block_assig <- getBlockAssigR - if isJust (lookupBlockEnv block_assig id) + if isJust (mapLookup id block_assig) || id == first_id - then do - b' <- processBlock block_live b - process first_id block_live blocks - next_round (b' : accum) True + then do + b' <- processBlock platform block_live b + process platform first_id block_live blocks + next_round (b' : accum) True - else process first_id block_live blocks - (b : next_round) accum madeProgress + else process platform first_id block_live blocks + (b : next_round) accum madeProgress -- | Do register allocation on this basic block -- processBlock - :: (Outputable instr, Instruction instr) - => BlockMap RegSet -- ^ live regs on entry to each basic block - -> LiveBasicBlock instr -- ^ block to do register allocation on - -> RegM [NatBasicBlock instr] -- ^ block with registers allocated - -processBlock block_live (BasicBlock id instrs) - = do initBlock id - (instrs', fixups) - <- linearRA block_live [] [] id instrs - return $ BasicBlock id instrs' : fixups + :: (FR freeRegs, PlatformOutputable instr, Instruction instr) + => Platform + -> BlockMap RegSet -- ^ live regs on entry to each basic block + -> LiveBasicBlock instr -- ^ block to do register allocation on + -> RegM freeRegs [NatBasicBlock instr] -- ^ block with registers allocated + +processBlock platform block_live (BasicBlock id instrs) + = do initBlock id + (instrs', fixups) + <- linearRA platform block_live [] [] id instrs + return $ BasicBlock id instrs' : fixups -- | Load the freeregs and current reg assignment into the RegM state --- for the basic block with this BlockId. -initBlock :: BlockId -> RegM () +-- for the basic block with this BlockId. +initBlock :: FR freeRegs => BlockId -> RegM freeRegs () initBlock id - = do block_assig <- getBlockAssigR - case lookupBlockEnv block_assig id of - -- no prior info about this block: assume everything is - -- free and the assignment is empty. - Nothing - -> do -- pprTrace "initFreeRegs" (text $ show initFreeRegs) (return ()) - - setFreeRegsR initFreeRegs - setAssigR emptyRegMap - - -- load info about register assignments leading into this block. - Just (freeregs, assig) - -> do setFreeRegsR freeregs - setAssigR assig + = do block_assig <- getBlockAssigR + case mapLookup id block_assig of + -- no prior info about this block: assume everything is + -- free and the assignment is empty. + Nothing + -> do -- pprTrace "initFreeRegs" (text $ show initFreeRegs) (return ()) + + setFreeRegsR frInitFreeRegs + setAssigR emptyRegMap + + -- load info about register assignments leading into this block. + Just (freeregs, assig) + -> do setFreeRegsR freeregs + setAssigR assig -- | Do allocation for a sequence of instructions. linearRA - :: (Outputable instr, Instruction instr) - => BlockMap RegSet -- ^ map of what vregs are live on entry to each block. - -> [instr] -- ^ accumulator for instructions already processed. - -> [NatBasicBlock instr] -- ^ accumulator for blocks of fixup code. - -> BlockId -- ^ id of the current block, for debugging. - -> [LiveInstr instr] -- ^ liveness annotated instructions in this block. - - -> RegM ( [instr] -- instructions after register allocation - , [NatBasicBlock instr]) -- fresh blocks of fixup code. - + :: (FR freeRegs, PlatformOutputable instr, Instruction instr) + => Platform + -> BlockMap RegSet -- ^ map of what vregs are live on entry to each block. + -> [instr] -- ^ accumulator for instructions already processed. + -> [NatBasicBlock instr] -- ^ accumulator for blocks of fixup code. + -> BlockId -- ^ id of the current block, for debugging. + -> [LiveInstr instr] -- ^ liveness annotated instructions in this block. + + -> RegM freeRegs + ( [instr] -- instructions after register allocation + , [NatBasicBlock instr]) -- fresh blocks of fixup code. + + +linearRA _ _ accInstr accFixup _ [] + = return + ( reverse accInstr -- instrs need to be returned in the correct order. + , accFixup) -- it doesn't matter what order the fixup blocks are returned in. -linearRA _ accInstr accFixup _ [] - = return - ( reverse accInstr -- instrs need to be returned in the correct order. - , accFixup) -- it doesn't matter what order the fixup blocks are returned in. - -linearRA block_live accInstr accFixups id (instr:instrs) +linearRA platform block_live accInstr accFixups id (instr:instrs) = do - (accInstr', new_fixups) - <- raInsn block_live accInstr id instr + (accInstr', new_fixups) + <- raInsn platform block_live accInstr id instr - linearRA block_live accInstr' (new_fixups ++ accFixups) id instrs + linearRA platform block_live accInstr' (new_fixups ++ accFixups) id instrs -- | Do allocation for a single instruction. -raInsn - :: (Outputable instr, Instruction instr) - => BlockMap RegSet -- ^ map of what vregs are love on entry to each block. - -> [instr] -- ^ accumulator for instructions already processed. - -> BlockId -- ^ the id of the current block, for debugging - -> LiveInstr instr -- ^ the instr to have its regs allocated, with liveness info. - -> RegM - ( [instr] -- new instructions - , [NatBasicBlock instr]) -- extra fixup blocks - -raInsn _ new_instrs _ (LiveInstr ii Nothing) - | Just n <- takeDeltaInstr ii - = do setDeltaR n - return (new_instrs, []) - -raInsn _ new_instrs _ (LiveInstr ii Nothing) - | isMetaInstr ii - = return (new_instrs, []) +raInsn + :: (FR freeRegs, PlatformOutputable instr, Instruction instr) + => Platform + -> BlockMap RegSet -- ^ map of what vregs are love on entry to each block. + -> [instr] -- ^ accumulator for instructions already processed. + -> BlockId -- ^ the id of the current block, for debugging + -> LiveInstr instr -- ^ the instr to have its regs allocated, with liveness info. + -> RegM freeRegs + ( [instr] -- new instructions + , [NatBasicBlock instr]) -- extra fixup blocks + +raInsn _ _ new_instrs _ (LiveInstr ii Nothing) + | Just n <- takeDeltaInstr ii + = do setDeltaR n + return (new_instrs, []) + +raInsn _ _ new_instrs _ (LiveInstr ii Nothing) + | isMetaInstr ii + = return (new_instrs, []) -raInsn block_live new_instrs id (LiveInstr (Instr instr) (Just live)) +raInsn platform block_live new_instrs id (LiveInstr (Instr instr) (Just live)) = do assig <- getAssigR @@ -331,81 +379,89 @@ -- register does not already have an assignment, -- and the source register is assigned to a register, not to a spill slot, -- then we can eliminate the instruction. - -- (we can't eliminitate it if the source register is on the stack, because + -- (we can't eliminate it if the source register is on the stack, because -- we do not want to use one spill slot for different virtual registers) case takeRegRegMoveInstr instr of - Just (src,dst) | src `elementOfUniqSet` (liveDieRead live), - isVirtualReg dst, - not (dst `elemUFM` assig), - Just (InReg _) <- (lookupUFM assig src) -> do - case src of - (RegReal rr) -> setAssigR (addToUFM assig dst (InReg rr)) - -- if src is a fixed reg, then we just map dest to this - -- reg in the assignment. src must be an allocatable reg, - -- otherwise it wouldn't be in r_dying. - _virt -> case lookupUFM assig src of - Nothing -> panic "raInsn" - Just loc -> - setAssigR (addToUFM (delFromUFM assig src) dst loc) + Just (src,dst) | src `elementOfUniqSet` (liveDieRead live), + isVirtualReg dst, + not (dst `elemUFM` assig), + Just (InReg _) <- (lookupUFM assig src) -> do + case src of + (RegReal rr) -> setAssigR (addToUFM assig dst (InReg rr)) + -- if src is a fixed reg, then we just map dest to this + -- reg in the assignment. src must be an allocatable reg, + -- otherwise it wouldn't be in r_dying. + _virt -> case lookupUFM assig src of + Nothing -> panic "raInsn" + Just loc -> + setAssigR (addToUFM (delFromUFM assig src) dst loc) - -- we have eliminated this instruction + -- we have eliminated this instruction {- - freeregs <- getFreeRegsR - assig <- getAssigR - pprTrace "raInsn" (text "ELIMINATED: " <> docToSDoc (pprInstr instr) - $$ ppr r_dying <+> ppr w_dying $$ text (show freeregs) $$ ppr assig) $ do + freeregs <- getFreeRegsR + assig <- getAssigR + pprTrace "raInsn" (text "ELIMINATED: " <> docToSDoc (pprInstr instr) + $$ ppr r_dying <+> ppr w_dying $$ text (show freeregs) $$ ppr assig) $ do -} - return (new_instrs, []) - - _ -> genRaInsn block_live new_instrs id instr - (uniqSetToList $ liveDieRead live) - (uniqSetToList $ liveDieWrite live) + return (new_instrs, []) + _ -> genRaInsn platform block_live new_instrs id instr + (uniqSetToList $ liveDieRead live) + (uniqSetToList $ liveDieWrite live) -raInsn _ _ _ instr - = pprPanic "raInsn" (text "no match for:" <> ppr instr) +raInsn platform _ _ _ instr + = pprPanic "raInsn" (text "no match for:" <> pprPlatform platform instr) +genRaInsn :: (FR freeRegs, Instruction instr, PlatformOutputable instr) + => Platform + -> BlockMap RegSet + -> [instr] + -> BlockId + -> instr + -> [Reg] + -> [Reg] + -> RegM freeRegs ([instr], [NatBasicBlock instr]) -genRaInsn block_live new_instrs block_id instr r_dying w_dying = +genRaInsn platform block_live new_instrs block_id instr r_dying w_dying = case regUsageOfInstr instr of { RU read written -> do - let real_written = [ rr | (RegReal rr) <- written ] - let virt_written = [ vr | (RegVirtual vr) <- written ] + let real_written = [ rr | (RegReal rr) <- written ] + let virt_written = [ vr | (RegVirtual vr) <- written ] -- we don't need to do anything with real registers that are -- only read by this instr. (the list is typically ~2 elements, -- so using nub isn't a problem). - let virt_read = nub [ vr | (RegVirtual vr) <- read ] + let virt_read = nub [ vr | (RegVirtual vr) <- read ] -- (a) save any temporaries which will be clobbered by this instruction - clobber_saves <- saveClobberedTemps real_written r_dying + clobber_saves <- saveClobberedTemps platform real_written r_dying -- debugging {- freeregs <- getFreeRegsR assig <- getAssigR - pprTrace "genRaInsn" - (ppr instr - $$ text "r_dying = " <+> ppr r_dying - $$ text "w_dying = " <+> ppr w_dying - $$ text "virt_read = " <+> ppr virt_read - $$ text "virt_written = " <+> ppr virt_written - $$ text "freeregs = " <+> text (show freeregs) - $$ text "assig = " <+> ppr assig) - $ do + pprTrace "genRaInsn" + (ppr instr + $$ text "r_dying = " <+> ppr r_dying + $$ text "w_dying = " <+> ppr w_dying + $$ text "virt_read = " <+> ppr virt_read + $$ text "virt_written = " <+> ppr virt_written + $$ text "freeregs = " <+> text (show freeregs) + $$ text "assig = " <+> ppr assig) + $ do -} -- (b), (c) allocate real regs for all regs read by this instruction. - (r_spills, r_allocd) <- - allocateRegsAndSpill True{-reading-} virt_read [] [] virt_read + (r_spills, r_allocd) <- + allocateRegsAndSpill platform True{-reading-} virt_read [] [] virt_read -- (d) Update block map for new destinations -- NB. do this before removing dead regs from the assignment, because -- these dead regs might in fact be live in the jump targets (they're -- only dead in the code that follows in the current basic block). (fixup_blocks, adjusted_instr) - <- joinToTargets block_live block_id instr + <- joinToTargets platform block_live block_id instr -- (e) Delete all register assignments for temps which are read -- (only) and die here. Update the free register list. @@ -415,43 +471,43 @@ clobberRegs real_written -- (g) Allocate registers for temporaries *written* (only) - (w_spills, w_allocd) <- - allocateRegsAndSpill False{-writing-} virt_written [] [] virt_written + (w_spills, w_allocd) <- + allocateRegsAndSpill platform False{-writing-} virt_written [] [] virt_written -- (h) Release registers for temps which are written here and not -- used again. releaseRegs w_dying let - -- (i) Patch the instruction - patch_map - = listToUFM - [ (t, RegReal r) - | (t, r) <- zip virt_read r_allocd - ++ zip virt_written w_allocd ] - - patched_instr - = patchRegsOfInstr adjusted_instr patchLookup - - patchLookup x - = case lookupUFM patch_map x of - Nothing -> x - Just y -> y + -- (i) Patch the instruction + patch_map + = listToUFM + [ (t, RegReal r) + | (t, r) <- zip virt_read r_allocd + ++ zip virt_written w_allocd ] + + patched_instr + = patchRegsOfInstr adjusted_instr patchLookup + + patchLookup x + = case lookupUFM patch_map x of + Nothing -> x + Just y -> y -- (j) free up stack slots for dead spilled regs -- TODO (can't be bothered right now) -- erase reg->reg moves where the source and destination are the same. - -- If the src temp didn't die in this instr but happened to be allocated - -- to the same real reg as the destination, then we can erase the move anyway. - let squashed_instr = case takeRegRegMoveInstr patched_instr of - Just (src, dst) - | src == dst -> [] - _ -> [patched_instr] + -- If the src temp didn't die in this instr but happened to be allocated + -- to the same real reg as the destination, then we can erase the move anyway. + let squashed_instr = case takeRegRegMoveInstr patched_instr of + Just (src, dst) + | src == dst -> [] + _ -> [patched_instr] let code = squashed_instr ++ w_spills ++ reverse r_spills - ++ clobber_saves ++ new_instrs + ++ clobber_saves ++ new_instrs -- pprTrace "patched-code" ((vcat $ map (docToSDoc . pprInstr) code)) $ do -- pprTrace "pached-fixup" ((ppr fixup_blocks)) $ do @@ -463,114 +519,126 @@ -- ----------------------------------------------------------------------------- -- releaseRegs +releaseRegs :: FR freeRegs => [Reg] -> RegM freeRegs () releaseRegs regs = do assig <- getAssigR free <- getFreeRegsR - loop assig free regs + loop assig free regs where loop _ free _ | free `seq` False = undefined loop assig free [] = do setAssigR assig; setFreeRegsR free; return () - loop assig free (RegReal rr : rs) = loop assig (releaseReg rr free) rs - loop assig free (r:rs) = + loop assig free (RegReal rr : rs) = loop assig (frReleaseReg rr free) rs + loop assig free (r:rs) = case lookupUFM assig r of - Just (InBoth real _) -> loop (delFromUFM assig r) (releaseReg real free) rs - Just (InReg real) -> loop (delFromUFM assig r) (releaseReg real free) rs - _other -> loop (delFromUFM assig r) free rs + Just (InBoth real _) -> loop (delFromUFM assig r) (frReleaseReg real free) rs + Just (InReg real) -> loop (delFromUFM assig r) (frReleaseReg real free) rs + _other -> loop (delFromUFM assig r) free rs -- ----------------------------------------------------------------------------- -- Clobber real registers -- For each temp in a register that is going to be clobbered: --- - if the temp dies after this instruction, do nothing --- - otherwise, put it somewhere safe (another reg if possible, --- otherwise spill and record InBoth in the assignment). --- - for allocateRegs on the temps *read*, --- - clobbered regs are allocatable. +-- - if the temp dies after this instruction, do nothing +-- - otherwise, put it somewhere safe (another reg if possible, +-- otherwise spill and record InBoth in the assignment). +-- - for allocateRegs on the temps *read*, +-- - clobbered regs are allocatable. -- --- for allocateRegs on the temps *written*, --- - clobbered regs are not allocatable. +-- for allocateRegs on the temps *written*, +-- - clobbered regs are not allocatable. -- --- TODO: instead of spilling, try to copy clobbered --- temps to another register if possible. +-- TODO: instead of spilling, try to copy clobbered +-- temps to another register if possible. -- saveClobberedTemps - :: Instruction instr - => [RealReg] -- real registers clobbered by this instruction - -> [Reg] -- registers which are no longer live after this insn - -> RegM [instr] -- return: instructions to spill any temps that will - -- be clobbered. + :: (PlatformOutputable instr, Instruction instr) + => Platform + -> [RealReg] -- real registers clobbered by this instruction + -> [Reg] -- registers which are no longer live after this insn + -> RegM freeRegs [instr] -- return: instructions to spill any temps that will + -- be clobbered. -saveClobberedTemps [] _ - = return [] +saveClobberedTemps _ [] _ + = return [] -saveClobberedTemps clobbered dying +saveClobberedTemps platform clobbered dying = do - assig <- getAssigR - let to_spill - = [ (temp,reg) - | (temp, InReg reg) <- ufmToList assig - , any (realRegsAlias reg) clobbered - , temp `notElem` map getUnique dying ] - - (instrs,assig') <- clobber assig [] to_spill - setAssigR assig' - return instrs + assig <- getAssigR + let to_spill + = [ (temp,reg) + | (temp, InReg reg) <- ufmToList assig + , any (realRegsAlias reg) clobbered + , temp `notElem` map getUnique dying ] + + (instrs,assig') <- clobber assig [] to_spill + setAssigR assig' + return instrs where - clobber assig instrs [] - = return (instrs, assig) + clobber assig instrs [] + = return (instrs, assig) - clobber assig instrs ((temp, reg) : rest) - = do - (spill, slot) <- spillR (RegReal reg) temp + clobber assig instrs ((temp, reg) : rest) + = do + (spill, slot) <- spillR platform (RegReal reg) temp - -- record why this reg was spilled for profiling - recordSpill (SpillClobber temp) + -- record why this reg was spilled for profiling + recordSpill (SpillClobber temp) - let new_assign = addToUFM assig temp (InBoth reg slot) + let new_assign = addToUFM assig temp (InBoth reg slot) - clobber new_assign (spill : instrs) rest + clobber new_assign (spill : instrs) rest --- | Mark all these regal regs as allocated, --- and kick out their vreg assignments. +-- | Mark all these real regs as allocated, +-- and kick out their vreg assignments. -- -clobberRegs :: [RealReg] -> RegM () -clobberRegs [] - = return () +clobberRegs :: FR freeRegs => [RealReg] -> RegM freeRegs () +clobberRegs [] + = return () -clobberRegs clobbered +clobberRegs clobbered = do - freeregs <- getFreeRegsR - setFreeRegsR $! foldr allocateReg freeregs clobbered + freeregs <- getFreeRegsR + setFreeRegsR $! foldr frAllocateReg freeregs clobbered - assig <- getAssigR - setAssigR $! clobber assig (ufmToList assig) + assig <- getAssigR + setAssigR $! clobber assig (ufmToList assig) where - -- if the temp was InReg and clobbered, then we will have - -- saved it in saveClobberedTemps above. So the only case - -- we have to worry about here is InBoth. Note that this - -- also catches temps which were loaded up during allocation - -- of read registers, not just those saved in saveClobberedTemps. - - clobber assig [] - = assig - - clobber assig ((temp, InBoth reg slot) : rest) - | any (realRegsAlias reg) clobbered - = clobber (addToUFM assig temp (InMem slot)) rest - - clobber assig (_:rest) - = clobber assig rest + -- if the temp was InReg and clobbered, then we will have + -- saved it in saveClobberedTemps above. So the only case + -- we have to worry about here is InBoth. Note that this + -- also catches temps which were loaded up during allocation + -- of read registers, not just those saved in saveClobberedTemps. + + clobber assig [] + = assig + + clobber assig ((temp, InBoth reg slot) : rest) + | any (realRegsAlias reg) clobbered + = clobber (addToUFM assig temp (InMem slot)) rest + + clobber assig (_:rest) + = clobber assig rest -- ----------------------------------------------------------------------------- -- allocateRegsAndSpill +-- Why are we performing a spill? +data SpillLoc = ReadMem StackSlot -- reading from register only in memory + | WriteNew -- writing to a new variable + | WriteMem -- writing to register only in memory +-- Note that ReadNew is not valid, since you don't want to be reading +-- from an uninitialized register. We also don't need the location of +-- the register in memory, since that will be invalidated by the write. +-- Technically, we could coalesce WriteNew and WriteMem into a single +-- entry as well. -- EZY + -- This function does several things: -- For each temporary referred to by this instruction, -- we allocate a real register (spilling another temporary if necessary). @@ -579,149 +647,170 @@ -- the list of free registers and free stack slots. allocateRegsAndSpill - :: Instruction instr - => Bool -- True <=> reading (load up spilled regs) - -> [VirtualReg] -- don't push these out - -> [instr] -- spill insns - -> [RealReg] -- real registers allocated (accum.) - -> [VirtualReg] -- temps to allocate - -> RegM ( [instr] - , [RealReg]) - -allocateRegsAndSpill _ _ spills alloc [] - = return (spills, reverse alloc) - -allocateRegsAndSpill reading keep spills alloc (r:rs) - = do assig <- getAssigR - case lookupUFM assig r of - -- case (1a): already in a register - Just (InReg my_reg) -> - allocateRegsAndSpill reading keep spills (my_reg:alloc) rs - - -- case (1b): already in a register (and memory) - -- NB1. if we're writing this register, update its assignemnt to be - -- InReg, because the memory value is no longer valid. - -- NB2. This is why we must process written registers here, even if they - -- are also read by the same instruction. - Just (InBoth my_reg _) - -> do when (not reading) (setAssigR (addToUFM assig r (InReg my_reg))) - allocateRegsAndSpill reading keep spills (my_reg:alloc) rs - - -- Not already in a register, so we need to find a free one... - loc -> allocRegsAndSpill_spill reading keep spills alloc r rs loc assig - - -allocRegsAndSpill_spill reading keep spills alloc r rs loc assig + :: (FR freeRegs, PlatformOutputable instr, Instruction instr) + => Platform + -> Bool -- True <=> reading (load up spilled regs) + -> [VirtualReg] -- don't push these out + -> [instr] -- spill insns + -> [RealReg] -- real registers allocated (accum.) + -> [VirtualReg] -- temps to allocate + -> RegM freeRegs ( [instr] , [RealReg]) + +allocateRegsAndSpill _ _ _ spills alloc [] + = return (spills, reverse alloc) + +allocateRegsAndSpill platform reading keep spills alloc (r:rs) + = do assig <- getAssigR + let doSpill = allocRegsAndSpill_spill platform reading keep spills alloc r rs assig + case lookupUFM assig r of + -- case (1a): already in a register + Just (InReg my_reg) -> + allocateRegsAndSpill platform reading keep spills (my_reg:alloc) rs + + -- case (1b): already in a register (and memory) + -- NB1. if we're writing this register, update its assignment to be + -- InReg, because the memory value is no longer valid. + -- NB2. This is why we must process written registers here, even if they + -- are also read by the same instruction. + Just (InBoth my_reg _) + -> do when (not reading) (setAssigR (addToUFM assig r (InReg my_reg))) + allocateRegsAndSpill platform reading keep spills (my_reg:alloc) rs + + -- Not already in a register, so we need to find a free one... + Just (InMem slot) | reading -> doSpill (ReadMem slot) + | otherwise -> doSpill WriteMem + Nothing | reading -> + -- pprPanic "allocateRegsAndSpill: Cannot read from uninitialized register" (ppr r) + -- ToDo: This case should be a panic, but we + -- sometimes see an unreachable basic block which + -- triggers this because the register allocator + -- will start with an empty assignment. + doSpill WriteNew + + | otherwise -> doSpill WriteNew + + +-- reading is redundant with reason, but we keep it around because it's +-- convenient and it maintains the recursive structure of the allocator. -- EZY +allocRegsAndSpill_spill :: (FR freeRegs, Instruction instr, PlatformOutputable instr) + => Platform + -> Bool + -> [VirtualReg] + -> [instr] + -> [RealReg] + -> VirtualReg + -> [VirtualReg] + -> UniqFM Loc + -> SpillLoc + -> RegM freeRegs ([instr], [RealReg]) +allocRegsAndSpill_spill platform reading keep spills alloc r rs assig spill_loc = do - freeRegs <- getFreeRegsR - let freeRegs_thisClass = getFreeRegs (classOfVirtualReg r) freeRegs + freeRegs <- getFreeRegsR + let freeRegs_thisClass = frGetFreeRegs (classOfVirtualReg r) freeRegs case freeRegs_thisClass of - -- case (2): we have a free register - (my_reg : _) -> - do spills' <- loadTemp reading r loc my_reg spills - - let new_loc - -- if the tmp was in a slot, then now its in a reg as well - | Just (InMem slot) <- loc - , reading - = InBoth my_reg slot - - -- tmp has been loaded into a reg - | otherwise - = InReg my_reg - - setAssigR (addToUFM assig r $! new_loc) - setFreeRegsR $ allocateReg my_reg freeRegs - - allocateRegsAndSpill reading keep spills' (my_reg : alloc) rs - - - -- case (3): we need to push something out to free up a register - [] -> - do let keep' = map getUnique keep - - -- the vregs we could kick out that are already in a slot - let candidates_inBoth - = [ (temp, reg, mem) - | (temp, InBoth reg mem) <- ufmToList assig - , temp `notElem` keep' - , targetClassOfRealReg reg == classOfVirtualReg r ] - - -- the vregs we could kick out that are only in a reg - -- this would require writing the reg to a new slot before using it. - let candidates_inReg - = [ (temp, reg) - | (temp, InReg reg) <- ufmToList assig - , temp `notElem` keep' - , targetClassOfRealReg reg == classOfVirtualReg r ] - - let result - - -- we have a temporary that is in both register and mem, - -- just free up its register for use. - | (temp, my_reg, slot) : _ <- candidates_inBoth - = do spills' <- loadTemp reading r loc my_reg spills - let assig1 = addToUFM assig temp (InMem slot) - let assig2 = addToUFM assig1 r (InReg my_reg) - - setAssigR assig2 - allocateRegsAndSpill reading keep spills' (my_reg:alloc) rs - - -- otherwise, we need to spill a temporary that currently - -- resides in a register. - | (temp_to_push_out, (my_reg :: RealReg)) : _ - <- candidates_inReg - = do - (spill_insn, slot) <- spillR (RegReal my_reg) temp_to_push_out - let spill_store = (if reading then id else reverse) - [ -- COMMENT (fsLit "spill alloc") - spill_insn ] - - -- record that this temp was spilled - recordSpill (SpillAlloc temp_to_push_out) - - -- update the register assignment - let assig1 = addToUFM assig temp_to_push_out (InMem slot) - let assig2 = addToUFM assig1 r (InReg my_reg) - setAssigR assig2 - - -- if need be, load up a spilled temp into the reg we've just freed up. - spills' <- loadTemp reading r loc my_reg spills - - allocateRegsAndSpill reading keep - (spill_store ++ spills') - (my_reg:alloc) rs - - - -- there wasn't anything to spill, so we're screwed. - | otherwise - = pprPanic ("RegAllocLinear.allocRegsAndSpill: no spill candidates\n") - $ vcat - [ text "allocating vreg: " <> text (show r) - , text "assignment: " <> text (show $ ufmToList assig) - , text "freeRegs: " <> text (show freeRegs) - , text "initFreeRegs: " <> text (show initFreeRegs) ] - - result - + -- case (2): we have a free register + (my_reg : _) -> + do spills' <- loadTemp platform r spill_loc my_reg spills + + setAssigR (addToUFM assig r $! newLocation spill_loc my_reg) + setFreeRegsR $ frAllocateReg my_reg freeRegs + + allocateRegsAndSpill platform reading keep spills' (my_reg : alloc) rs + + + -- case (3): we need to push something out to free up a register + [] -> + do let keep' = map getUnique keep + + -- the vregs we could kick out that are already in a slot + let candidates_inBoth + = [ (temp, reg, mem) + | (temp, InBoth reg mem) <- ufmToList assig + , temp `notElem` keep' + , targetClassOfRealReg platform reg == classOfVirtualReg r ] + + -- the vregs we could kick out that are only in a reg + -- this would require writing the reg to a new slot before using it. + let candidates_inReg + = [ (temp, reg) + | (temp, InReg reg) <- ufmToList assig + , temp `notElem` keep' + , targetClassOfRealReg platform reg == classOfVirtualReg r ] + + let result + + -- we have a temporary that is in both register and mem, + -- just free up its register for use. + | (temp, my_reg, slot) : _ <- candidates_inBoth + = do spills' <- loadTemp platform r spill_loc my_reg spills + let assig1 = addToUFM assig temp (InMem slot) + let assig2 = addToUFM assig1 r $! newLocation spill_loc my_reg + + setAssigR assig2 + allocateRegsAndSpill platform reading keep spills' (my_reg:alloc) rs + + -- otherwise, we need to spill a temporary that currently + -- resides in a register. + | (temp_to_push_out, (my_reg :: RealReg)) : _ + <- candidates_inReg + = do + (spill_insn, slot) <- spillR platform (RegReal my_reg) temp_to_push_out + let spill_store = (if reading then id else reverse) + [ -- COMMENT (fsLit "spill alloc") + spill_insn ] + + -- record that this temp was spilled + recordSpill (SpillAlloc temp_to_push_out) + + -- update the register assignment + let assig1 = addToUFM assig temp_to_push_out (InMem slot) + let assig2 = addToUFM assig1 r $! newLocation spill_loc my_reg + setAssigR assig2 + + -- if need be, load up a spilled temp into the reg we've just freed up. + spills' <- loadTemp platform r spill_loc my_reg spills + + allocateRegsAndSpill platform reading keep + (spill_store ++ spills') + (my_reg:alloc) rs + + + -- there wasn't anything to spill, so we're screwed. + | otherwise + = pprPanic ("RegAllocLinear.allocRegsAndSpill: no spill candidates\n") + $ vcat + [ text "allocating vreg: " <> text (show r) + , text "assignment: " <> text (show $ ufmToList assig) + , text "freeRegs: " <> text (show freeRegs) + , text "initFreeRegs: " <> text (show (frInitFreeRegs `asTypeOf` freeRegs)) ] + + result + + +-- | Calculate a new location after a register has been loaded. +newLocation :: SpillLoc -> RealReg -> Loc +-- if the tmp was read from a slot, then now its in a reg as well +newLocation (ReadMem slot) my_reg = InBoth my_reg slot +-- writes will always result in only the register being available +newLocation _ my_reg = InReg my_reg --- | Load up a spilled temporary if we need to. +-- | Load up a spilled temporary if we need to (read from memory). loadTemp - :: Instruction instr - => Bool - -> VirtualReg -- the temp being loaded - -> Maybe Loc -- the current location of this temp - -> RealReg -- the hreg to load the temp into - -> [instr] - -> RegM [instr] + :: (PlatformOutputable instr, Instruction instr) + => Platform + -> VirtualReg -- the temp being loaded + -> SpillLoc -- the current location of this temp + -> RealReg -- the hreg to load the temp into + -> [instr] + -> RegM freeRegs [instr] -loadTemp True vreg (Just (InMem slot)) hreg spills +loadTemp platform vreg (ReadMem slot) hreg spills = do - insn <- loadR (RegReal hreg) slot - recordSpill (SpillLoad $ getUnique vreg) - return $ {- COMMENT (fsLit "spill load") : -} insn : spills + insn <- loadR platform (RegReal hreg) slot + recordSpill (SpillLoad $ getUnique vreg) + return $ {- COMMENT (fsLit "spill load") : -} insn : spills loadTemp _ _ _ _ spills = return spills diff -Nru ghc-7.0.3/compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs ghc-7.2.1/compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs --- ghc-7.0.3/compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs 2011-08-07 17:10:05.000000000 +0000 @@ -32,8 +32,8 @@ releaseReg :: RealReg -> FreeRegs -> FreeRegs releaseReg (RealRegSingle r) (FreeRegs g f) - | r > 31 = FreeRegs g (f .|. (1 `shiftL` (fromIntegral r - 32))) - | otherwise = FreeRegs (g .|. (1 `shiftL` fromIntegral r)) f + | r > 31 = FreeRegs g (f .|. (1 `shiftL` (r - 32))) + | otherwise = FreeRegs (g .|. (1 `shiftL` r)) f releaseReg _ _ = panic "RegAlloc.Linear.PPC.releaseReg: bad reg" @@ -53,8 +53,8 @@ allocateReg :: RealReg -> FreeRegs -> FreeRegs allocateReg (RealRegSingle r) (FreeRegs g f) - | r > 31 = FreeRegs g (f .&. complement (1 `shiftL` (fromIntegral r - 32))) - | otherwise = FreeRegs (g .&. complement (1 `shiftL` fromIntegral r)) f + | r > 31 = FreeRegs g (f .&. complement (1 `shiftL` (r - 32))) + | otherwise = FreeRegs (g .&. complement (1 `shiftL` r)) f allocateReg _ _ = panic "RegAlloc.Linear.PPC.allocateReg: bad reg" diff -Nru ghc-7.0.3/compiler/nativeGen/RegAlloc/Linear/StackMap.hs ghc-7.2.1/compiler/nativeGen/RegAlloc/Linear/StackMap.hs --- ghc-7.0.3/compiler/nativeGen/RegAlloc/Linear/StackMap.hs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/nativeGen/RegAlloc/Linear/StackMap.hs 2011-08-07 17:10:05.000000000 +0000 @@ -22,6 +22,7 @@ import RegAlloc.Linear.FreeRegs import Outputable +import Platform import UniqFM import Unique @@ -39,8 +40,8 @@ -- | An empty stack map, with all slots available. -emptyStackMap :: StackMap -emptyStackMap = StackMap [0..maxSpillSlots] emptyUFM +emptyStackMap :: Platform -> StackMap +emptyStackMap platform = StackMap [0 .. maxSpillSlots platform] emptyUFM -- | If this vreg unique already has a stack assignment then return the slot number, diff -Nru ghc-7.0.3/compiler/nativeGen/RegAlloc/Linear/State.hs ghc-7.2.1/compiler/nativeGen/RegAlloc/Linear/State.hs --- ghc-7.0.3/compiler/nativeGen/RegAlloc/Linear/State.hs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/nativeGen/RegAlloc/Linear/State.hs 2011-08-07 17:10:05.000000000 +0000 @@ -32,29 +32,29 @@ import RegAlloc.Linear.Stats import RegAlloc.Linear.StackMap import RegAlloc.Linear.Base -import RegAlloc.Linear.FreeRegs import RegAlloc.Liveness import Instruction import Reg +import Platform import Unique import UniqSupply -- | The RegM Monad -instance Monad RegM where +instance Monad (RegM freeRegs) where m >>= k = RegM $ \s -> case unReg m s of { (# s, a #) -> unReg (k a) s } return a = RegM $ \s -> (# s, a #) -- | Run a computation in the RegM register allocator monad. -runR :: BlockAssignment - -> FreeRegs +runR :: BlockAssignment freeRegs + -> freeRegs -> RegMap Loc -> StackMap -> UniqSupply - -> RegM a - -> (BlockAssignment, StackMap, RegAllocStats, a) + -> RegM freeRegs a + -> (BlockAssignment freeRegs, StackMap, RegAllocStats, a) runR block_assig freeregs assig stack us thing = case unReg thing @@ -76,66 +76,66 @@ -- | Make register allocator stats from its final state. -makeRAStats :: RA_State -> RegAllocStats +makeRAStats :: RA_State freeRegs -> RegAllocStats makeRAStats state = RegAllocStats { ra_spillInstrs = binSpillReasons (ra_spills state) } -spillR :: Instruction instr - => Reg -> Unique -> RegM (instr, Int) +spillR :: Instruction instr + => Platform -> Reg -> Unique -> RegM freeRegs (instr, Int) -spillR reg temp = RegM $ \ s@RA_State{ra_delta=delta, ra_stack=stack} -> +spillR platform reg temp = RegM $ \ s@RA_State{ra_delta=delta, ra_stack=stack} -> let (stack',slot) = getStackSlotFor stack temp - instr = mkSpillInstr reg delta slot + instr = mkSpillInstr platform reg delta slot in (# s{ra_stack=stack'}, (instr,slot) #) -loadR :: Instruction instr - => Reg -> Int -> RegM instr +loadR :: Instruction instr + => Platform -> Reg -> Int -> RegM freeRegs instr -loadR reg slot = RegM $ \ s@RA_State{ra_delta=delta} -> - (# s, mkLoadInstr reg delta slot #) +loadR platform reg slot = RegM $ \ s@RA_State{ra_delta=delta} -> + (# s, mkLoadInstr platform reg delta slot #) -getFreeRegsR :: RegM FreeRegs +getFreeRegsR :: RegM freeRegs freeRegs getFreeRegsR = RegM $ \ s@RA_State{ra_freeregs = freeregs} -> (# s, freeregs #) -setFreeRegsR :: FreeRegs -> RegM () +setFreeRegsR :: freeRegs -> RegM freeRegs () setFreeRegsR regs = RegM $ \ s -> (# s{ra_freeregs = regs}, () #) -getAssigR :: RegM (RegMap Loc) +getAssigR :: RegM freeRegs (RegMap Loc) getAssigR = RegM $ \ s@RA_State{ra_assig = assig} -> (# s, assig #) -setAssigR :: RegMap Loc -> RegM () +setAssigR :: RegMap Loc -> RegM freeRegs () setAssigR assig = RegM $ \ s -> (# s{ra_assig=assig}, () #) -getBlockAssigR :: RegM BlockAssignment +getBlockAssigR :: RegM freeRegs (BlockAssignment freeRegs) getBlockAssigR = RegM $ \ s@RA_State{ra_blockassig = assig} -> (# s, assig #) -setBlockAssigR :: BlockAssignment -> RegM () +setBlockAssigR :: BlockAssignment freeRegs -> RegM freeRegs () setBlockAssigR assig = RegM $ \ s -> (# s{ra_blockassig = assig}, () #) -setDeltaR :: Int -> RegM () +setDeltaR :: Int -> RegM freeRegs () setDeltaR n = RegM $ \ s -> (# s{ra_delta = n}, () #) -getDeltaR :: RegM Int +getDeltaR :: RegM freeRegs Int getDeltaR = RegM $ \s -> (# s, ra_delta s #) -getUniqueR :: RegM Unique +getUniqueR :: RegM freeRegs Unique getUniqueR = RegM $ \s -> - case splitUniqSupply (ra_us s) of - (us1, us2) -> (# s{ra_us = us2}, uniqFromSupply us1 #) + case takeUniqFromSupply (ra_us s) of + (uniq, us) -> (# s{ra_us = us}, uniq #) -- | Record that a spill instruction was inserted, for profiling. -recordSpill :: SpillReason -> RegM () +recordSpill :: SpillReason -> RegM freeRegs () recordSpill spill = RegM $ \s -> (# s { ra_spills = spill : ra_spills s}, () #) diff -Nru ghc-7.0.3/compiler/nativeGen/RegAlloc/Linear/Stats.hs ghc-7.2.1/compiler/nativeGen/RegAlloc/Linear/Stats.hs --- ghc-7.0.3/compiler/nativeGen/RegAlloc/Linear/Stats.hs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/nativeGen/RegAlloc/Linear/Stats.hs 2011-08-07 17:10:05.000000000 +0000 @@ -10,7 +10,7 @@ import RegAlloc.Liveness import Instruction -import Cmm (GenBasicBlock(..)) +import OldCmm (GenBasicBlock(..)) import UniqFM import Outputable @@ -37,7 +37,7 @@ -- | Count reg-reg moves remaining in this code. countRegRegMovesNat :: Instruction instr - => NatCmmTop instr -> Int + => NatCmmTop statics instr -> Int countRegRegMovesNat cmm = execState (mapGenBlockTopM countBlock cmm) 0 @@ -58,7 +58,7 @@ -- | Pretty print some RegAllocStats pprStats :: Instruction instr - => [NatCmmTop instr] -> [RegAllocStats] -> SDoc + => [NatCmmTop statics instr] -> [RegAllocStats] -> SDoc pprStats code statss = let -- sum up all the instrs inserted by the spiller diff -Nru ghc-7.0.3/compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs ghc-7.2.1/compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs --- ghc-7.0.3/compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs 2011-08-07 17:10:05.000000000 +0000 @@ -47,7 +47,7 @@ allocateReg :: RealReg -> FreeRegs -> FreeRegs allocateReg (RealRegSingle r) f - = f .&. complement (1 `shiftL` fromIntegral r) + = f .&. complement (1 `shiftL` r) allocateReg _ _ = panic "RegAlloc.Linear.X86.FreeRegs.allocateReg: no reg" diff -Nru ghc-7.0.3/compiler/nativeGen/RegAlloc/Liveness.hs ghc-7.2.1/compiler/nativeGen/RegAlloc/Liveness.hs --- ghc-7.0.3/compiler/nativeGen/RegAlloc/Liveness.hs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/nativeGen/RegAlloc/Liveness.hs 2011-08-07 17:10:05.000000000 +0000 @@ -8,38 +8,39 @@ {-# OPTIONS -Wall -fno-warn-name-shadowing #-} module RegAlloc.Liveness ( - RegSet, - RegMap, emptyRegMap, - BlockMap, emptyBlockMap, - LiveCmmTop, - InstrSR (..), - LiveInstr (..), - Liveness (..), - LiveInfo (..), - LiveBasicBlock, - - mapBlockTop, mapBlockTopM, mapSCCM, - mapGenBlockTop, mapGenBlockTopM, - stripLive, - stripLiveBlock, - slurpConflicts, - slurpReloadCoalesce, - eraseDeltasLive, - patchEraseLive, - patchRegsLiveInstr, - reverseBlocksInTops, - regLiveness, - natCmmTopToLive + RegSet, + RegMap, emptyRegMap, + BlockMap, emptyBlockMap, + LiveCmmTop, + InstrSR (..), + LiveInstr (..), + Liveness (..), + LiveInfo (..), + LiveBasicBlock, + + mapBlockTop, mapBlockTopM, mapSCCM, + mapGenBlockTop, mapGenBlockTopM, + stripLive, + stripLiveBlock, + slurpConflicts, + slurpReloadCoalesce, + eraseDeltasLive, + patchEraseLive, + patchRegsLiveInstr, + reverseBlocksInTops, + regLiveness, + natCmmTopToLive ) where import Reg import Instruction import BlockId -import Cmm hiding (RegSet) -import PprCmm() +import OldCmm hiding (RegSet) +import OldPprCmm() import Digraph import Outputable +import Platform import Unique import UniqSet import UniqFM @@ -50,9 +51,9 @@ import Data.List import Data.Maybe -import Data.Map (Map) -import Data.Set (Set) -import qualified Data.Map as Map +import Data.Map (Map) +import Data.Set (Set) +import qualified Data.Map as Map ----------------------------------------------------------------------------- type RegSet = UniqSet Reg @@ -64,877 +65,875 @@ type BlockMap a = BlockEnv a -emptyBlockMap :: BlockEnv a -emptyBlockMap = emptyBlockEnv - -- | A top level thing which carries liveness information. -type LiveCmmTop instr - = GenCmmTop - CmmStatic - LiveInfo - [SCC (LiveBasicBlock instr)] +type LiveCmmTop statics instr + = GenCmmTop + statics + LiveInfo + [SCC (LiveBasicBlock instr)] -- | The register allocator also wants to use SPILL/RELOAD meta instructions, --- so we'll keep those here. +-- so we'll keep those here. data InstrSR instr - -- | A real machine instruction - = Instr instr + -- | A real machine instruction + = Instr instr - -- | spill this reg to a stack slot - | SPILL Reg Int + -- | spill this reg to a stack slot + | SPILL Reg Int - -- | reload this reg from a stack slot - | RELOAD Int Reg + -- | reload this reg from a stack slot + | RELOAD Int Reg instance Instruction instr => Instruction (InstrSR instr) where - regUsageOfInstr i - = case i of - Instr instr -> regUsageOfInstr instr - SPILL reg _ -> RU [reg] [] - RELOAD _ reg -> RU [] [reg] - - patchRegsOfInstr i f - = case i of - Instr instr -> Instr (patchRegsOfInstr instr f) - SPILL reg slot -> SPILL (f reg) slot - RELOAD slot reg -> RELOAD slot (f reg) - - isJumpishInstr i - = case i of - Instr instr -> isJumpishInstr instr - _ -> False - - jumpDestsOfInstr i - = case i of - Instr instr -> jumpDestsOfInstr instr - _ -> [] - - patchJumpInstr i f - = case i of - Instr instr -> Instr (patchJumpInstr instr f) - _ -> i - - mkSpillInstr = error "mkSpillInstr[InstrSR]: Not making SPILL meta-instr" - mkLoadInstr = error "mkLoadInstr[InstrSR]: Not making LOAD meta-instr" - - takeDeltaInstr i - = case i of - Instr instr -> takeDeltaInstr instr - _ -> Nothing - - isMetaInstr i - = case i of - Instr instr -> isMetaInstr instr - _ -> False - - mkRegRegMoveInstr r1 r2 = Instr (mkRegRegMoveInstr r1 r2) - - takeRegRegMoveInstr i - = case i of - Instr instr -> takeRegRegMoveInstr instr - _ -> Nothing + regUsageOfInstr i + = case i of + Instr instr -> regUsageOfInstr instr + SPILL reg _ -> RU [reg] [] + RELOAD _ reg -> RU [] [reg] + + patchRegsOfInstr i f + = case i of + Instr instr -> Instr (patchRegsOfInstr instr f) + SPILL reg slot -> SPILL (f reg) slot + RELOAD slot reg -> RELOAD slot (f reg) + + isJumpishInstr i + = case i of + Instr instr -> isJumpishInstr instr + _ -> False + + jumpDestsOfInstr i + = case i of + Instr instr -> jumpDestsOfInstr instr + _ -> [] + + patchJumpInstr i f + = case i of + Instr instr -> Instr (patchJumpInstr instr f) + _ -> i + + mkSpillInstr = error "mkSpillInstr[InstrSR]: Not making SPILL meta-instr" + mkLoadInstr = error "mkLoadInstr[InstrSR]: Not making LOAD meta-instr" + + takeDeltaInstr i + = case i of + Instr instr -> takeDeltaInstr instr + _ -> Nothing + + isMetaInstr i + = case i of + Instr instr -> isMetaInstr instr + _ -> False + + mkRegRegMoveInstr platform r1 r2 + = Instr (mkRegRegMoveInstr platform r1 r2) + + takeRegRegMoveInstr i + = case i of + Instr instr -> takeRegRegMoveInstr instr + _ -> Nothing + + mkJumpInstr target = map Instr (mkJumpInstr target) - mkJumpInstr target = map Instr (mkJumpInstr target) - -- | An instruction with liveness information. data LiveInstr instr - = LiveInstr (InstrSR instr) (Maybe Liveness) + = LiveInstr (InstrSR instr) (Maybe Liveness) -- | Liveness information. --- The regs which die are ones which are no longer live in the *next* instruction --- in this sequence. --- (NB. if the instruction is a jump, these registers might still be live --- at the jump target(s) - you have to check the liveness at the destination --- block to find out). +-- The regs which die are ones which are no longer live in the *next* instruction +-- in this sequence. +-- (NB. if the instruction is a jump, these registers might still be live +-- at the jump target(s) - you have to check the liveness at the destination +-- block to find out). data Liveness - = Liveness - { liveBorn :: RegSet -- ^ registers born in this instruction (written to for first time). - , liveDieRead :: RegSet -- ^ registers that died because they were read for the last time. - , liveDieWrite :: RegSet } -- ^ registers that died because they were clobbered by something. + = Liveness + { liveBorn :: RegSet -- ^ registers born in this instruction (written to for first time). + , liveDieRead :: RegSet -- ^ registers that died because they were read for the last time. + , liveDieWrite :: RegSet } -- ^ registers that died because they were clobbered by something. -- | Stash regs live on entry to each basic block in the info part of the cmm code. data LiveInfo - = LiveInfo - [CmmStatic] -- cmm static stuff - (Maybe BlockId) -- id of the first block - (Maybe (BlockMap RegSet)) -- argument locals live on entry to this block - (Map BlockId (Set Int)) -- stack slots live on entry to this block + = LiveInfo + (Maybe CmmStatics) -- cmm info table static stuff + (Maybe BlockId) -- id of the first block + (Maybe (BlockMap RegSet)) -- argument locals live on entry to this block + (Map BlockId (Set Int)) -- stack slots live on entry to this block -- | A basic block with liveness information. type LiveBasicBlock instr - = GenBasicBlock (LiveInstr instr) + = GenBasicBlock (LiveInstr instr) -instance Outputable instr - => Outputable (InstrSR instr) where +instance PlatformOutputable instr + => PlatformOutputable (InstrSR instr) where - ppr (Instr realInstr) - = ppr realInstr + pprPlatform platform (Instr realInstr) + = pprPlatform platform realInstr - ppr (SPILL reg slot) - = hcat [ - ptext (sLit "\tSPILL"), - char ' ', - ppr reg, - comma, - ptext (sLit "SLOT") <> parens (int slot)] - - ppr (RELOAD slot reg) - = hcat [ - ptext (sLit "\tRELOAD"), - char ' ', - ptext (sLit "SLOT") <> parens (int slot), - comma, - ppr reg] - -instance Outputable instr - => Outputable (LiveInstr instr) where - - ppr (LiveInstr instr Nothing) - = ppr instr - - ppr (LiveInstr instr (Just live)) - = ppr instr - $$ (nest 8 - $ vcat - [ pprRegs (ptext (sLit "# born: ")) (liveBorn live) - , pprRegs (ptext (sLit "# r_dying: ")) (liveDieRead live) - , pprRegs (ptext (sLit "# w_dying: ")) (liveDieWrite live) ] - $+$ space) - - where pprRegs :: SDoc -> RegSet -> SDoc - pprRegs name regs - | isEmptyUniqSet regs = empty - | otherwise = name <> (hcat $ punctuate space $ map ppr $ uniqSetToList regs) + pprPlatform _ (SPILL reg slot) + = hcat [ + ptext (sLit "\tSPILL"), + char ' ', + ppr reg, + comma, + ptext (sLit "SLOT") <> parens (int slot)] + + pprPlatform _ (RELOAD slot reg) + = hcat [ + ptext (sLit "\tRELOAD"), + char ' ', + ptext (sLit "SLOT") <> parens (int slot), + comma, + ppr reg] + +instance PlatformOutputable instr + => PlatformOutputable (LiveInstr instr) where + + pprPlatform platform (LiveInstr instr Nothing) + = pprPlatform platform instr + + pprPlatform platform (LiveInstr instr (Just live)) + = pprPlatform platform instr + $$ (nest 8 + $ vcat + [ pprRegs (ptext (sLit "# born: ")) (liveBorn live) + , pprRegs (ptext (sLit "# r_dying: ")) (liveDieRead live) + , pprRegs (ptext (sLit "# w_dying: ")) (liveDieWrite live) ] + $+$ space) + + where pprRegs :: SDoc -> RegSet -> SDoc + pprRegs name regs + | isEmptyUniqSet regs = empty + | otherwise = name <> (hcat $ punctuate space $ map ppr $ uniqSetToList regs) instance Outputable LiveInfo where - ppr (LiveInfo static firstId liveVRegsOnEntry liveSlotsOnEntry) - = (vcat $ map ppr static) - $$ text "# firstId = " <> ppr firstId - $$ text "# liveVRegsOnEntry = " <> ppr liveVRegsOnEntry - $$ text "# liveSlotsOnEntry = " <> text (show liveSlotsOnEntry) + ppr (LiveInfo mb_static firstId liveVRegsOnEntry liveSlotsOnEntry) + = (maybe empty ppr mb_static) + $$ text "# firstId = " <> ppr firstId + $$ text "# liveVRegsOnEntry = " <> ppr liveVRegsOnEntry + $$ text "# liveSlotsOnEntry = " <> text (show liveSlotsOnEntry) -- | map a function across all the basic blocks in this code -- mapBlockTop - :: (LiveBasicBlock instr -> LiveBasicBlock instr) - -> LiveCmmTop instr -> LiveCmmTop instr + :: (LiveBasicBlock instr -> LiveBasicBlock instr) + -> LiveCmmTop statics instr -> LiveCmmTop statics instr mapBlockTop f cmm - = evalState (mapBlockTopM (\x -> return $ f x) cmm) () + = evalState (mapBlockTopM (\x -> return $ f x) cmm) () -- | map a function across all the basic blocks in this code (monadic version) -- mapBlockTopM - :: Monad m - => (LiveBasicBlock instr -> m (LiveBasicBlock instr)) - -> LiveCmmTop instr -> m (LiveCmmTop instr) + :: Monad m + => (LiveBasicBlock instr -> m (LiveBasicBlock instr)) + -> LiveCmmTop statics instr -> m (LiveCmmTop statics instr) mapBlockTopM _ cmm@(CmmData{}) - = return cmm + = return cmm -mapBlockTopM f (CmmProc header label params sccs) - = do sccs' <- mapM (mapSCCM f) sccs - return $ CmmProc header label params sccs' +mapBlockTopM f (CmmProc header label sccs) + = do sccs' <- mapM (mapSCCM f) sccs + return $ CmmProc header label sccs' mapSCCM :: Monad m => (a -> m b) -> SCC a -> m (SCC b) -mapSCCM f (AcyclicSCC x) - = do x' <- f x - return $ AcyclicSCC x' +mapSCCM f (AcyclicSCC x) + = do x' <- f x + return $ AcyclicSCC x' mapSCCM f (CyclicSCC xs) - = do xs' <- mapM f xs - return $ CyclicSCC xs' + = do xs' <- mapM f xs + return $ CyclicSCC xs' -- map a function across all the basic blocks in this code mapGenBlockTop - :: (GenBasicBlock i -> GenBasicBlock i) - -> (GenCmmTop d h (ListGraph i) -> GenCmmTop d h (ListGraph i)) + :: (GenBasicBlock i -> GenBasicBlock i) + -> (GenCmmTop d h (ListGraph i) -> GenCmmTop d h (ListGraph i)) mapGenBlockTop f cmm - = evalState (mapGenBlockTopM (\x -> return $ f x) cmm) () + = evalState (mapGenBlockTopM (\x -> return $ f x) cmm) () -- | map a function across all the basic blocks in this code (monadic version) mapGenBlockTopM - :: Monad m - => (GenBasicBlock i -> m (GenBasicBlock i)) - -> (GenCmmTop d h (ListGraph i) -> m (GenCmmTop d h (ListGraph i))) + :: Monad m + => (GenBasicBlock i -> m (GenBasicBlock i)) + -> (GenCmmTop d h (ListGraph i) -> m (GenCmmTop d h (ListGraph i))) mapGenBlockTopM _ cmm@(CmmData{}) - = return cmm + = return cmm -mapGenBlockTopM f (CmmProc header label params (ListGraph blocks)) - = do blocks' <- mapM f blocks - return $ CmmProc header label params (ListGraph blocks') +mapGenBlockTopM f (CmmProc header label (ListGraph blocks)) + = do blocks' <- mapM f blocks + return $ CmmProc header label (ListGraph blocks') -- | Slurp out the list of register conflicts and reg-reg moves from this top level thing. --- Slurping of conflicts and moves is wrapped up together so we don't have --- to make two passes over the same code when we want to build the graph. +-- Slurping of conflicts and moves is wrapped up together so we don't have +-- to make two passes over the same code when we want to build the graph. -- -slurpConflicts - :: Instruction instr - => LiveCmmTop instr - -> (Bag (UniqSet Reg), Bag (Reg, Reg)) +slurpConflicts + :: Instruction instr + => LiveCmmTop statics instr + -> (Bag (UniqSet Reg), Bag (Reg, Reg)) slurpConflicts live - = slurpCmm (emptyBag, emptyBag) live + = slurpCmm (emptyBag, emptyBag) live - where slurpCmm rs CmmData{} = rs - slurpCmm rs (CmmProc info _ _ sccs) - = foldl' (slurpSCC info) rs sccs - - slurpSCC info rs (AcyclicSCC b) - = slurpBlock info rs b - - slurpSCC info rs (CyclicSCC bs) - = foldl' (slurpBlock info) rs bs - - slurpBlock info rs (BasicBlock blockId instrs) - | LiveInfo _ _ (Just blockLive) _ <- info - , Just rsLiveEntry <- lookupBlockEnv blockLive blockId - , (conflicts, moves) <- slurpLIs rsLiveEntry rs instrs - = (consBag rsLiveEntry conflicts, moves) - - | otherwise - = panic "Liveness.slurpConflicts: bad block" - - slurpLIs rsLive (conflicts, moves) [] - = (consBag rsLive conflicts, moves) - - slurpLIs rsLive rs (LiveInstr _ Nothing : lis) - = slurpLIs rsLive rs lis - - slurpLIs rsLiveEntry (conflicts, moves) (LiveInstr instr (Just live) : lis) - = let - -- regs that die because they are read for the last time at the start of an instruction - -- are not live across it. - rsLiveAcross = rsLiveEntry `minusUniqSet` (liveDieRead live) - - -- regs live on entry to the next instruction. - -- be careful of orphans, make sure to delete dying regs _after_ unioning - -- in the ones that are born here. - rsLiveNext = (rsLiveAcross `unionUniqSets` (liveBorn live)) - `minusUniqSet` (liveDieWrite live) - - -- orphan vregs are the ones that die in the same instruction they are born in. - -- these are likely to be results that are never used, but we still - -- need to assign a hreg to them.. - rsOrphans = intersectUniqSets - (liveBorn live) - (unionUniqSets (liveDieWrite live) (liveDieRead live)) - - -- - rsConflicts = unionUniqSets rsLiveNext rsOrphans - - in case takeRegRegMoveInstr instr of - Just rr -> slurpLIs rsLiveNext - ( consBag rsConflicts conflicts - , consBag rr moves) lis - - Nothing -> slurpLIs rsLiveNext - ( consBag rsConflicts conflicts - , moves) lis + where slurpCmm rs CmmData{} = rs + slurpCmm rs (CmmProc info _ sccs) + = foldl' (slurpSCC info) rs sccs + + slurpSCC info rs (AcyclicSCC b) + = slurpBlock info rs b + + slurpSCC info rs (CyclicSCC bs) + = foldl' (slurpBlock info) rs bs + + slurpBlock info rs (BasicBlock blockId instrs) + | LiveInfo _ _ (Just blockLive) _ <- info + , Just rsLiveEntry <- mapLookup blockId blockLive + , (conflicts, moves) <- slurpLIs rsLiveEntry rs instrs + = (consBag rsLiveEntry conflicts, moves) + + | otherwise + = panic "Liveness.slurpConflicts: bad block" + + slurpLIs rsLive (conflicts, moves) [] + = (consBag rsLive conflicts, moves) + + slurpLIs rsLive rs (LiveInstr _ Nothing : lis) + = slurpLIs rsLive rs lis + + slurpLIs rsLiveEntry (conflicts, moves) (LiveInstr instr (Just live) : lis) + = let + -- regs that die because they are read for the last time at the start of an instruction + -- are not live across it. + rsLiveAcross = rsLiveEntry `minusUniqSet` (liveDieRead live) + + -- regs live on entry to the next instruction. + -- be careful of orphans, make sure to delete dying regs _after_ unioning + -- in the ones that are born here. + rsLiveNext = (rsLiveAcross `unionUniqSets` (liveBorn live)) + `minusUniqSet` (liveDieWrite live) + + -- orphan vregs are the ones that die in the same instruction they are born in. + -- these are likely to be results that are never used, but we still + -- need to assign a hreg to them.. + rsOrphans = intersectUniqSets + (liveBorn live) + (unionUniqSets (liveDieWrite live) (liveDieRead live)) + + -- + rsConflicts = unionUniqSets rsLiveNext rsOrphans + + in case takeRegRegMoveInstr instr of + Just rr -> slurpLIs rsLiveNext + ( consBag rsConflicts conflicts + , consBag rr moves) lis + + Nothing -> slurpLIs rsLiveNext + ( consBag rsConflicts conflicts + , moves) lis -- | For spill\/reloads -- --- SPILL v1, slot1 --- ... --- RELOAD slot1, v2 --- --- If we can arrange that v1 and v2 are allocated to the same hreg it's more likely --- the spill\/reload instrs can be cleaned and replaced by a nop reg-reg move. +-- SPILL v1, slot1 +-- ... +-- RELOAD slot1, v2 +-- +-- If we can arrange that v1 and v2 are allocated to the same hreg it's more likely +-- the spill\/reload instrs can be cleaned and replaced by a nop reg-reg move. -- -- -slurpReloadCoalesce - :: forall instr. Instruction instr - => LiveCmmTop instr - -> Bag (Reg, Reg) +slurpReloadCoalesce + :: forall statics instr. Instruction instr + => LiveCmmTop statics instr + -> Bag (Reg, Reg) slurpReloadCoalesce live - = slurpCmm emptyBag live + = slurpCmm emptyBag live - where + where slurpCmm :: Bag (Reg, Reg) -> GenCmmTop t t1 [SCC (LiveBasicBlock instr)] -> Bag (Reg, Reg) - slurpCmm cs CmmData{} = cs - slurpCmm cs (CmmProc _ _ _ sccs) - = slurpComp cs (flattenSCCs sccs) + slurpCmm cs CmmData{} = cs + slurpCmm cs (CmmProc _ _ sccs) + = slurpComp cs (flattenSCCs sccs) slurpComp :: Bag (Reg, Reg) -> [LiveBasicBlock instr] -> Bag (Reg, Reg) - slurpComp cs blocks - = let (moveBags, _) = runState (slurpCompM blocks) emptyUFM - in unionManyBags (cs : moveBags) + slurpComp cs blocks + = let (moveBags, _) = runState (slurpCompM blocks) emptyUFM + in unionManyBags (cs : moveBags) slurpCompM :: [LiveBasicBlock instr] -> State (UniqFM [UniqFM Reg]) [Bag (Reg, Reg)] - slurpCompM blocks - = do -- run the analysis once to record the mapping across jumps. - mapM_ (slurpBlock False) blocks - - -- run it a second time while using the information from the last pass. - -- We /could/ run this many more times to deal with graphical control - -- flow and propagating info across multiple jumps, but it's probably - -- not worth the trouble. - mapM (slurpBlock True) blocks + slurpCompM blocks + = do -- run the analysis once to record the mapping across jumps. + mapM_ (slurpBlock False) blocks + + -- run it a second time while using the information from the last pass. + -- We /could/ run this many more times to deal with graphical control + -- flow and propagating info across multiple jumps, but it's probably + -- not worth the trouble. + mapM (slurpBlock True) blocks slurpBlock :: Bool -> LiveBasicBlock instr -> State (UniqFM [UniqFM Reg]) (Bag (Reg, Reg)) - slurpBlock propagate (BasicBlock blockId instrs) - = do -- grab the slot map for entry to this block - slotMap <- if propagate - then getSlotMap blockId - else return emptyUFM - - (_, mMoves) <- mapAccumLM slurpLI slotMap instrs - return $ listToBag $ catMaybes mMoves - - slurpLI :: UniqFM Reg -- current slotMap - -> LiveInstr instr - -> State (UniqFM [UniqFM Reg]) -- blockId -> [slot -> reg] - -- for tracking slotMaps across jumps - - ( UniqFM Reg -- new slotMap - , Maybe (Reg, Reg)) -- maybe a new coalesce edge - - slurpLI slotMap li - - -- remember what reg was stored into the slot - | LiveInstr (SPILL reg slot) _ <- li - , slotMap' <- addToUFM slotMap slot reg - = return (slotMap', Nothing) - - -- add an edge betwen the this reg and the last one stored into the slot - | LiveInstr (RELOAD slot reg) _ <- li - = case lookupUFM slotMap slot of - Just reg2 - | reg /= reg2 -> return (slotMap, Just (reg, reg2)) - | otherwise -> return (slotMap, Nothing) - - Nothing -> return (slotMap, Nothing) - - -- if we hit a jump, remember the current slotMap - | LiveInstr (Instr instr) _ <- li - , targets <- jumpDestsOfInstr instr - , not $ null targets - = do mapM_ (accSlotMap slotMap) targets - return (slotMap, Nothing) - - | otherwise - = return (slotMap, Nothing) - - -- record a slotmap for an in edge to this block - accSlotMap slotMap blockId - = modify (\s -> addToUFM_C (++) s blockId [slotMap]) - - -- work out the slot map on entry to this block - -- if we have slot maps for multiple in-edges then we need to merge them. - getSlotMap blockId - = do map <- get - let slotMaps = fromMaybe [] (lookupUFM map blockId) - return $ foldr mergeSlotMaps emptyUFM slotMaps - - mergeSlotMaps :: UniqFM Reg -> UniqFM Reg -> UniqFM Reg - mergeSlotMaps map1 map2 - = listToUFM - $ [ (k, r1) | (k, r1) <- ufmToList map1 - , case lookupUFM map2 k of - Nothing -> False - Just r2 -> r1 == r2 ] + slurpBlock propagate (BasicBlock blockId instrs) + = do -- grab the slot map for entry to this block + slotMap <- if propagate + then getSlotMap blockId + else return emptyUFM + + (_, mMoves) <- mapAccumLM slurpLI slotMap instrs + return $ listToBag $ catMaybes mMoves + + slurpLI :: UniqFM Reg -- current slotMap + -> LiveInstr instr + -> State (UniqFM [UniqFM Reg]) -- blockId -> [slot -> reg] + -- for tracking slotMaps across jumps + + ( UniqFM Reg -- new slotMap + , Maybe (Reg, Reg)) -- maybe a new coalesce edge + + slurpLI slotMap li + + -- remember what reg was stored into the slot + | LiveInstr (SPILL reg slot) _ <- li + , slotMap' <- addToUFM slotMap slot reg + = return (slotMap', Nothing) + + -- add an edge betwen the this reg and the last one stored into the slot + | LiveInstr (RELOAD slot reg) _ <- li + = case lookupUFM slotMap slot of + Just reg2 + | reg /= reg2 -> return (slotMap, Just (reg, reg2)) + | otherwise -> return (slotMap, Nothing) + + Nothing -> return (slotMap, Nothing) + + -- if we hit a jump, remember the current slotMap + | LiveInstr (Instr instr) _ <- li + , targets <- jumpDestsOfInstr instr + , not $ null targets + = do mapM_ (accSlotMap slotMap) targets + return (slotMap, Nothing) + + | otherwise + = return (slotMap, Nothing) + + -- record a slotmap for an in edge to this block + accSlotMap slotMap blockId + = modify (\s -> addToUFM_C (++) s blockId [slotMap]) + + -- work out the slot map on entry to this block + -- if we have slot maps for multiple in-edges then we need to merge them. + getSlotMap blockId + = do map <- get + let slotMaps = fromMaybe [] (lookupUFM map blockId) + return $ foldr mergeSlotMaps emptyUFM slotMaps + + mergeSlotMaps :: UniqFM Reg -> UniqFM Reg -> UniqFM Reg + mergeSlotMaps map1 map2 + = listToUFM + $ [ (k, r1) | (k, r1) <- ufmToList map1 + , case lookupUFM map2 k of + Nothing -> False + Just r2 -> r1 == r2 ] -- | Strip away liveness information, yielding NatCmmTop -stripLive - :: (Outputable instr, Instruction instr) - => LiveCmmTop instr - -> NatCmmTop instr - -stripLive live - = stripCmm live - - where stripCmm (CmmData sec ds) = CmmData sec ds - - stripCmm (CmmProc (LiveInfo info (Just first_id) _ _) label params sccs) - = let final_blocks = flattenSCCs sccs - - -- make sure the block that was first in the input list - -- stays at the front of the output. This is the entry point - -- of the proc, and it needs to come first. - ((first':_), rest') - = partition ((== first_id) . blockId) final_blocks - - in CmmProc info label params - (ListGraph $ map stripLiveBlock $ first' : rest') - - -- procs used for stg_split_markers don't contain any blocks, and have no first_id. - stripCmm (CmmProc (LiveInfo info Nothing _ _) label params []) - = CmmProc info label params (ListGraph []) - - -- If the proc has blocks but we don't know what the first one was, then we're dead. - stripCmm proc - = pprPanic "RegAlloc.Liveness.stripLive: no first_id on proc" (ppr proc) - +stripLive + :: (Outputable statics, PlatformOutputable instr, Instruction instr) + => Platform + -> LiveCmmTop statics instr + -> NatCmmTop statics instr + +stripLive platform live + = stripCmm live + + where stripCmm (CmmData sec ds) = CmmData sec ds + stripCmm (CmmProc (LiveInfo info (Just first_id) _ _) label sccs) + = let final_blocks = flattenSCCs sccs + + -- make sure the block that was first in the input list + -- stays at the front of the output. This is the entry point + -- of the proc, and it needs to come first. + ((first':_), rest') + = partition ((== first_id) . blockId) final_blocks + + in CmmProc info label + (ListGraph $ map (stripLiveBlock platform) $ first' : rest') + + -- procs used for stg_split_markers don't contain any blocks, and have no first_id. + stripCmm (CmmProc (LiveInfo info Nothing _ _) label []) + = CmmProc info label (ListGraph []) + + -- If the proc has blocks but we don't know what the first one was, then we're dead. + stripCmm proc + = pprPanic "RegAlloc.Liveness.stripLive: no first_id on proc" (pprPlatform platform proc) -- | Strip away liveness information from a basic block, --- and make real spill instructions out of SPILL, RELOAD pseudos along the way. +-- and make real spill instructions out of SPILL, RELOAD pseudos along the way. stripLiveBlock - :: Instruction instr - => LiveBasicBlock instr - -> NatBasicBlock instr - -stripLiveBlock (BasicBlock i lis) - = BasicBlock i instrs' - - where (instrs', _) - = runState (spillNat [] lis) 0 - - spillNat acc [] - = return (reverse acc) - - spillNat acc (LiveInstr (SPILL reg slot) _ : instrs) - = do delta <- get - spillNat (mkSpillInstr reg delta slot : acc) instrs - - spillNat acc (LiveInstr (RELOAD slot reg) _ : instrs) - = do delta <- get - spillNat (mkLoadInstr reg delta slot : acc) instrs - - spillNat acc (LiveInstr (Instr instr) _ : instrs) - | Just i <- takeDeltaInstr instr - = do put i - spillNat acc instrs + :: Instruction instr + => Platform + -> LiveBasicBlock instr + -> NatBasicBlock instr + +stripLiveBlock platform (BasicBlock i lis) + = BasicBlock i instrs' + + where (instrs', _) + = runState (spillNat [] lis) 0 + + spillNat acc [] + = return (reverse acc) + + spillNat acc (LiveInstr (SPILL reg slot) _ : instrs) + = do delta <- get + spillNat (mkSpillInstr platform reg delta slot : acc) instrs + + spillNat acc (LiveInstr (RELOAD slot reg) _ : instrs) + = do delta <- get + spillNat (mkLoadInstr platform reg delta slot : acc) instrs + + spillNat acc (LiveInstr (Instr instr) _ : instrs) + | Just i <- takeDeltaInstr instr + = do put i + spillNat acc instrs - spillNat acc (LiveInstr (Instr instr) _ : instrs) - = spillNat (instr : acc) instrs + spillNat acc (LiveInstr (Instr instr) _ : instrs) + = spillNat (instr : acc) instrs -- | Erase Delta instructions. -eraseDeltasLive - :: Instruction instr - => LiveCmmTop instr - -> LiveCmmTop instr +eraseDeltasLive + :: Instruction instr + => LiveCmmTop statics instr + -> LiveCmmTop statics instr eraseDeltasLive cmm - = mapBlockTop eraseBlock cmm + = mapBlockTop eraseBlock cmm where - eraseBlock (BasicBlock id lis) - = BasicBlock id - $ filter (\(LiveInstr i _) -> not $ isJust $ takeDeltaInstr i) - $ lis + eraseBlock (BasicBlock id lis) + = BasicBlock id + $ filter (\(LiveInstr i _) -> not $ isJust $ takeDeltaInstr i) + $ lis -- | Patch the registers in this code according to this register mapping. --- also erase reg -> reg moves when the reg is the same. --- also erase reg -> reg moves when the destination dies in this instr. +-- also erase reg -> reg moves when the reg is the same. +-- also erase reg -> reg moves when the destination dies in this instr. patchEraseLive - :: Instruction instr - => (Reg -> Reg) - -> LiveCmmTop instr -> LiveCmmTop instr + :: Instruction instr + => (Reg -> Reg) + -> LiveCmmTop statics instr -> LiveCmmTop statics instr patchEraseLive patchF cmm - = patchCmm cmm + = patchCmm cmm where - patchCmm cmm@CmmData{} = cmm + patchCmm cmm@CmmData{} = cmm - patchCmm (CmmProc info label params sccs) - | LiveInfo static id (Just blockMap) mLiveSlots <- info - = let - patchRegSet set = mkUniqSet $ map patchF $ uniqSetToList set - blockMap' = mapBlockEnv patchRegSet blockMap + patchCmm (CmmProc info label sccs) + | LiveInfo static id (Just blockMap) mLiveSlots <- info + = let + patchRegSet set = mkUniqSet $ map patchF $ uniqSetToList set + blockMap' = mapMap patchRegSet blockMap - info' = LiveInfo static id (Just blockMap') mLiveSlots - in CmmProc info' label params $ map patchSCC sccs + info' = LiveInfo static id (Just blockMap') mLiveSlots + in CmmProc info' label $ map patchSCC sccs - | otherwise - = panic "RegAlloc.Liveness.patchEraseLive: no blockMap" + | otherwise + = panic "RegAlloc.Liveness.patchEraseLive: no blockMap" - patchSCC (AcyclicSCC b) = AcyclicSCC (patchBlock b) - patchSCC (CyclicSCC bs) = CyclicSCC (map patchBlock bs) + patchSCC (AcyclicSCC b) = AcyclicSCC (patchBlock b) + patchSCC (CyclicSCC bs) = CyclicSCC (map patchBlock bs) - patchBlock (BasicBlock id lis) - = BasicBlock id $ patchInstrs lis + patchBlock (BasicBlock id lis) + = BasicBlock id $ patchInstrs lis - patchInstrs [] = [] - patchInstrs (li : lis) + patchInstrs [] = [] + patchInstrs (li : lis) - | LiveInstr i (Just live) <- li' - , Just (r1, r2) <- takeRegRegMoveInstr i - , eatMe r1 r2 live - = patchInstrs lis + | LiveInstr i (Just live) <- li' + , Just (r1, r2) <- takeRegRegMoveInstr i + , eatMe r1 r2 live + = patchInstrs lis - | otherwise - = li' : patchInstrs lis + | otherwise + = li' : patchInstrs lis - where li' = patchRegsLiveInstr patchF li + where li' = patchRegsLiveInstr patchF li - eatMe r1 r2 live - -- source and destination regs are the same - | r1 == r2 = True + eatMe r1 r2 live + -- source and destination regs are the same + | r1 == r2 = True - -- desination reg is never used - | elementOfUniqSet r2 (liveBorn live) - , elementOfUniqSet r2 (liveDieRead live) || elementOfUniqSet r2 (liveDieWrite live) - = True + -- desination reg is never used + | elementOfUniqSet r2 (liveBorn live) + , elementOfUniqSet r2 (liveDieRead live) || elementOfUniqSet r2 (liveDieWrite live) + = True - | otherwise = False + | otherwise = False -- | Patch registers in this LiveInstr, including the liveness information. -- patchRegsLiveInstr - :: Instruction instr - => (Reg -> Reg) - -> LiveInstr instr -> LiveInstr instr + :: Instruction instr + => (Reg -> Reg) + -> LiveInstr instr -> LiveInstr instr patchRegsLiveInstr patchF li = case li of - LiveInstr instr Nothing - -> LiveInstr (patchRegsOfInstr instr patchF) Nothing + LiveInstr instr Nothing + -> LiveInstr (patchRegsOfInstr instr patchF) Nothing - LiveInstr instr (Just live) - -> LiveInstr - (patchRegsOfInstr instr patchF) - (Just live - { -- WARNING: have to go via lists here because patchF changes the uniq in the Reg - liveBorn = mkUniqSet $ map patchF $ uniqSetToList $ liveBorn live - , liveDieRead = mkUniqSet $ map patchF $ uniqSetToList $ liveDieRead live - , liveDieWrite = mkUniqSet $ map patchF $ uniqSetToList $ liveDieWrite live }) + LiveInstr instr (Just live) + -> LiveInstr + (patchRegsOfInstr instr patchF) + (Just live + { -- WARNING: have to go via lists here because patchF changes the uniq in the Reg + liveBorn = mkUniqSet $ map patchF $ uniqSetToList $ liveBorn live + , liveDieRead = mkUniqSet $ map patchF $ uniqSetToList $ liveDieRead live + , liveDieWrite = mkUniqSet $ map patchF $ uniqSetToList $ liveDieWrite live }) -------------------------------------------------------------------------------- -- | Convert a NatCmmTop to a LiveCmmTop, with empty liveness information -natCmmTopToLive - :: Instruction instr - => NatCmmTop instr - -> LiveCmmTop instr +natCmmTopToLive + :: Instruction instr + => NatCmmTop statics instr + -> LiveCmmTop statics instr natCmmTopToLive (CmmData i d) - = CmmData i d + = CmmData i d + +natCmmTopToLive (CmmProc info lbl (ListGraph [])) + = CmmProc (LiveInfo info Nothing Nothing Map.empty) lbl [] + +natCmmTopToLive (CmmProc info lbl (ListGraph blocks@(first : _))) + = let first_id = blockId first + sccs = sccBlocks blocks + sccsLive = map (fmap (\(BasicBlock l instrs) -> + BasicBlock l (map (\i -> LiveInstr (Instr i) Nothing) instrs))) + $ sccs + + in CmmProc (LiveInfo info (Just first_id) Nothing Map.empty) lbl sccsLive + -natCmmTopToLive (CmmProc info lbl params (ListGraph [])) - = CmmProc (LiveInfo info Nothing Nothing Map.empty) - lbl params [] - -natCmmTopToLive (CmmProc info lbl params (ListGraph blocks@(first : _))) - = let first_id = blockId first - sccs = sccBlocks blocks - sccsLive = map (fmap (\(BasicBlock l instrs) -> - BasicBlock l (map (\i -> LiveInstr (Instr i) Nothing) instrs))) - $ sccs - - in CmmProc (LiveInfo info (Just first_id) Nothing Map.empty) - lbl params sccsLive - - -sccBlocks - :: Instruction instr - => [NatBasicBlock instr] - -> [SCC (NatBasicBlock instr)] +sccBlocks + :: Instruction instr + => [NatBasicBlock instr] + -> [SCC (NatBasicBlock instr)] sccBlocks blocks = stronglyConnCompFromEdgedVertices graph where - getOutEdges :: Instruction instr => [instr] -> [BlockId] - getOutEdges instrs = concat $ map jumpDestsOfInstr instrs + getOutEdges :: Instruction instr => [instr] -> [BlockId] + getOutEdges instrs = concat $ map jumpDestsOfInstr instrs - graph = [ (block, getUnique id, map getUnique (getOutEdges instrs)) - | block@(BasicBlock id instrs) <- blocks ] + graph = [ (block, getUnique id, map getUnique (getOutEdges instrs)) + | block@(BasicBlock id instrs) <- blocks ] --------------------------------------------------------------------------------- -- Annotate code with register liveness information -- regLiveness - :: (Outputable instr, Instruction instr) - => LiveCmmTop instr - -> UniqSM (LiveCmmTop instr) - -regLiveness (CmmData i d) - = returnUs $ CmmData i d - -regLiveness (CmmProc info lbl params []) - | LiveInfo static mFirst _ _ <- info - = returnUs $ CmmProc - (LiveInfo static mFirst (Just emptyBlockEnv) Map.empty) - lbl params [] - -regLiveness (CmmProc info lbl params sccs) - | LiveInfo static mFirst _ liveSlotsOnEntry <- info - = let (ann_sccs, block_live) = computeLiveness sccs + :: (PlatformOutputable instr, Instruction instr) + => Platform + -> LiveCmmTop statics instr + -> UniqSM (LiveCmmTop statics instr) + +regLiveness _ (CmmData i d) + = returnUs $ CmmData i d + +regLiveness _ (CmmProc info lbl []) + | LiveInfo static mFirst _ _ <- info + = returnUs $ CmmProc + (LiveInfo static mFirst (Just mapEmpty) Map.empty) + lbl [] + +regLiveness platform (CmmProc info lbl sccs) + | LiveInfo static mFirst _ liveSlotsOnEntry <- info + = let (ann_sccs, block_live) = computeLiveness platform sccs - in returnUs $ CmmProc (LiveInfo static mFirst (Just block_live) liveSlotsOnEntry) - lbl params ann_sccs + in returnUs $ CmmProc (LiveInfo static mFirst (Just block_live) liveSlotsOnEntry) + lbl ann_sccs -- ----------------------------------------------------------------------------- -- | Check ordering of Blocks --- The computeLiveness function requires SCCs to be in reverse dependent order. --- If they're not the liveness information will be wrong, and we'll get a bad allocation. --- Better to check for this precondition explicitly or some other poor sucker will --- waste a day staring at bad assembly code.. --- +-- The computeLiveness function requires SCCs to be in reverse dependent order. +-- If they're not the liveness information will be wrong, and we'll get a bad allocation. +-- Better to check for this precondition explicitly or some other poor sucker will +-- waste a day staring at bad assembly code.. +-- checkIsReverseDependent - :: Instruction instr - => [SCC (LiveBasicBlock instr)] -- ^ SCCs of blocks that we're about to run the liveness determinator on. - -> Maybe BlockId -- ^ BlockIds that fail the test (if any) - + :: Instruction instr + => [SCC (LiveBasicBlock instr)] -- ^ SCCs of blocks that we're about to run the liveness determinator on. + -> Maybe BlockId -- ^ BlockIds that fail the test (if any) + checkIsReverseDependent sccs' = go emptyUniqSet sccs' - where go _ [] - = Nothing - - go blocksSeen (AcyclicSCC block : sccs) - = let dests = slurpJumpDestsOfBlock block - blocksSeen' = unionUniqSets blocksSeen $ mkUniqSet [blockId block] - badDests = dests `minusUniqSet` blocksSeen' - in case uniqSetToList badDests of - [] -> go blocksSeen' sccs - bad : _ -> Just bad - - go blocksSeen (CyclicSCC blocks : sccs) - = let dests = unionManyUniqSets $ map slurpJumpDestsOfBlock blocks - blocksSeen' = unionUniqSets blocksSeen $ mkUniqSet $ map blockId blocks - badDests = dests `minusUniqSet` blocksSeen' - in case uniqSetToList badDests of - [] -> go blocksSeen' sccs - bad : _ -> Just bad - - slurpJumpDestsOfBlock (BasicBlock _ instrs) - = unionManyUniqSets - $ map (mkUniqSet . jumpDestsOfInstr) - [ i | LiveInstr i _ <- instrs] + where go _ [] + = Nothing + + go blocksSeen (AcyclicSCC block : sccs) + = let dests = slurpJumpDestsOfBlock block + blocksSeen' = unionUniqSets blocksSeen $ mkUniqSet [blockId block] + badDests = dests `minusUniqSet` blocksSeen' + in case uniqSetToList badDests of + [] -> go blocksSeen' sccs + bad : _ -> Just bad + + go blocksSeen (CyclicSCC blocks : sccs) + = let dests = unionManyUniqSets $ map slurpJumpDestsOfBlock blocks + blocksSeen' = unionUniqSets blocksSeen $ mkUniqSet $ map blockId blocks + badDests = dests `minusUniqSet` blocksSeen' + in case uniqSetToList badDests of + [] -> go blocksSeen' sccs + bad : _ -> Just bad + + slurpJumpDestsOfBlock (BasicBlock _ instrs) + = unionManyUniqSets + $ map (mkUniqSet . jumpDestsOfInstr) + [ i | LiveInstr i _ <- instrs] -- | If we've compute liveness info for this code already we have to reverse -- the SCCs in each top to get them back to the right order so we can do it again. -reverseBlocksInTops :: LiveCmmTop instr -> LiveCmmTop instr +reverseBlocksInTops :: LiveCmmTop statics instr -> LiveCmmTop statics instr reverseBlocksInTops top = case top of - CmmData{} -> top - CmmProc info lbl params sccs -> CmmProc info lbl params (reverse sccs) + CmmData{} -> top + CmmProc info lbl sccs -> CmmProc info lbl (reverse sccs) + - -- | Computing liveness --- +-- -- On entry, the SCCs must be in "reverse" order: later blocks may transfer -- control to earlier ones only, else `panic`. --- +-- -- The SCCs returned are in the *opposite* order, which is exactly what we -- want for the next pass. -- computeLiveness - :: (Outputable instr, Instruction instr) - => [SCC (LiveBasicBlock instr)] - -> ([SCC (LiveBasicBlock instr)], -- instructions annotated with list of registers - -- which are "dead after this instruction". - BlockMap RegSet) -- blocks annontated with set of live registers - -- on entry to the block. + :: (PlatformOutputable instr, Instruction instr) + => Platform + -> [SCC (LiveBasicBlock instr)] + -> ([SCC (LiveBasicBlock instr)], -- instructions annotated with list of registers + -- which are "dead after this instruction". + BlockMap RegSet) -- blocks annontated with set of live registers + -- on entry to the block. -computeLiveness sccs +computeLiveness platform sccs = case checkIsReverseDependent sccs of - Nothing -> livenessSCCs emptyBlockMap [] sccs - Just bad -> pprPanic "RegAlloc.Liveness.computeLivenss" - (vcat [ text "SCCs aren't in reverse dependent order" - , text "bad blockId" <+> ppr bad - , ppr sccs]) + Nothing -> livenessSCCs emptyBlockMap [] sccs + Just bad -> pprPanic "RegAlloc.Liveness.computeLivenss" + (vcat [ text "SCCs aren't in reverse dependent order" + , text "bad blockId" <+> ppr bad + , pprPlatform platform sccs]) livenessSCCs :: Instruction instr => BlockMap RegSet - -> [SCC (LiveBasicBlock instr)] -- accum + -> [SCC (LiveBasicBlock instr)] -- accum -> [SCC (LiveBasicBlock instr)] -> ( [SCC (LiveBasicBlock instr)] - , BlockMap RegSet) + , BlockMap RegSet) -livenessSCCs blockmap done [] - = (done, blockmap) +livenessSCCs blockmap done [] + = (done, blockmap) livenessSCCs blockmap done (AcyclicSCC block : sccs) - = let (blockmap', block') = livenessBlock blockmap block - in livenessSCCs blockmap' (AcyclicSCC block' : done) sccs + = let (blockmap', block') = livenessBlock blockmap block + in livenessSCCs blockmap' (AcyclicSCC block' : done) sccs livenessSCCs blockmap done - (CyclicSCC blocks : sccs) = - livenessSCCs blockmap' (CyclicSCC blocks':done) sccs + (CyclicSCC blocks : sccs) = + livenessSCCs blockmap' (CyclicSCC blocks':done) sccs where (blockmap', blocks') - = iterateUntilUnchanged linearLiveness equalBlockMaps - blockmap blocks + = iterateUntilUnchanged linearLiveness equalBlockMaps + blockmap blocks iterateUntilUnchanged :: (a -> b -> (a,c)) -> (a -> a -> Bool) -> a -> b -> (a,c) - iterateUntilUnchanged f eq a b - = head $ - concatMap tail $ - groupBy (\(a1, _) (a2, _) -> eq a1 a2) $ - iterate (\(a, _) -> f a b) $ - (a, panic "RegLiveness.livenessSCCs") + iterateUntilUnchanged f eq a b + = head $ + concatMap tail $ + groupBy (\(a1, _) (a2, _) -> eq a1 a2) $ + iterate (\(a, _) -> f a b) $ + (a, panic "RegLiveness.livenessSCCs") - linearLiveness - :: Instruction instr - => BlockMap RegSet -> [LiveBasicBlock instr] - -> (BlockMap RegSet, [LiveBasicBlock instr]) + linearLiveness + :: Instruction instr + => BlockMap RegSet -> [LiveBasicBlock instr] + -> (BlockMap RegSet, [LiveBasicBlock instr]) linearLiveness = mapAccumL livenessBlock -- probably the least efficient way to compare two -- BlockMaps for equality. - equalBlockMaps a b - = a' == b' - where a' = map f $ blockEnvToList a - b' = map f $ blockEnvToList b - f (key,elt) = (key, uniqSetToList elt) + equalBlockMaps a b + = a' == b' + where a' = map f $ mapToList a + b' = map f $ mapToList b + f (key,elt) = (key, uniqSetToList elt) -- | Annotate a basic block with register liveness information. -- livenessBlock - :: Instruction instr - => BlockMap RegSet - -> LiveBasicBlock instr - -> (BlockMap RegSet, LiveBasicBlock instr) + :: Instruction instr + => BlockMap RegSet + -> LiveBasicBlock instr + -> (BlockMap RegSet, LiveBasicBlock instr) livenessBlock blockmap (BasicBlock block_id instrs) = let - (regsLiveOnEntry, instrs1) - = livenessBack emptyUniqSet blockmap [] (reverse instrs) - blockmap' = extendBlockEnv blockmap block_id regsLiveOnEntry + (regsLiveOnEntry, instrs1) + = livenessBack emptyUniqSet blockmap [] (reverse instrs) + blockmap' = mapInsert block_id regsLiveOnEntry blockmap - instrs2 = livenessForward regsLiveOnEntry instrs1 + instrs2 = livenessForward regsLiveOnEntry instrs1 - output = BasicBlock block_id instrs2 + output = BasicBlock block_id instrs2 - in ( blockmap', output) + in ( blockmap', output) -- | Calculate liveness going forwards, --- filling in when regs are born +-- filling in when regs are born livenessForward - :: Instruction instr - => RegSet -- regs live on this instr - -> [LiveInstr instr] -> [LiveInstr instr] + :: Instruction instr + => RegSet -- regs live on this instr + -> [LiveInstr instr] -> [LiveInstr instr] -livenessForward _ [] = [] +livenessForward _ [] = [] livenessForward rsLiveEntry (li@(LiveInstr instr mLive) : lis) - | Nothing <- mLive - = li : livenessForward rsLiveEntry lis + | Nothing <- mLive + = li : livenessForward rsLiveEntry lis - | Just live <- mLive - , RU _ written <- regUsageOfInstr instr - = let - -- Regs that are written to but weren't live on entry to this instruction - -- are recorded as being born here. - rsBorn = mkUniqSet - $ filter (\r -> not $ elementOfUniqSet r rsLiveEntry) written - - rsLiveNext = (rsLiveEntry `unionUniqSets` rsBorn) - `minusUniqSet` (liveDieRead live) - `minusUniqSet` (liveDieWrite live) + | Just live <- mLive + , RU _ written <- regUsageOfInstr instr + = let + -- Regs that are written to but weren't live on entry to this instruction + -- are recorded as being born here. + rsBorn = mkUniqSet + $ filter (\r -> not $ elementOfUniqSet r rsLiveEntry) written + + rsLiveNext = (rsLiveEntry `unionUniqSets` rsBorn) + `minusUniqSet` (liveDieRead live) + `minusUniqSet` (liveDieWrite live) - in LiveInstr instr (Just live { liveBorn = rsBorn }) - : livenessForward rsLiveNext lis + in LiveInstr instr (Just live { liveBorn = rsBorn }) + : livenessForward rsLiveNext lis -livenessForward _ _ = panic "RegLiveness.livenessForward: no match" +livenessForward _ _ = panic "RegLiveness.livenessForward: no match" -- | Calculate liveness going backwards, --- filling in when regs die, and what regs are live across each instruction +-- filling in when regs die, and what regs are live across each instruction livenessBack - :: Instruction instr - => RegSet -- regs live on this instr - -> BlockMap RegSet -- regs live on entry to other BBs - -> [LiveInstr instr] -- instructions (accum) - -> [LiveInstr instr] -- instructions - -> (RegSet, [LiveInstr instr]) + :: Instruction instr + => RegSet -- regs live on this instr + -> BlockMap RegSet -- regs live on entry to other BBs + -> [LiveInstr instr] -- instructions (accum) + -> [LiveInstr instr] -- instructions + -> (RegSet, [LiveInstr instr]) livenessBack liveregs _ done [] = (liveregs, done) livenessBack liveregs blockmap acc (instr : instrs) - = let (liveregs', instr') = liveness1 liveregs blockmap instr - in livenessBack liveregs' blockmap (instr' : acc) instrs + = let (liveregs', instr') = liveness1 liveregs blockmap instr + in livenessBack liveregs' blockmap (instr' : acc) instrs -- don't bother tagging comments or deltas with liveness -liveness1 - :: Instruction instr - => RegSet - -> BlockMap RegSet - -> LiveInstr instr - -> (RegSet, LiveInstr instr) +liveness1 + :: Instruction instr + => RegSet + -> BlockMap RegSet + -> LiveInstr instr + -> (RegSet, LiveInstr instr) liveness1 liveregs _ (LiveInstr instr _) - | isMetaInstr instr - = (liveregs, LiveInstr instr Nothing) + | isMetaInstr instr + = (liveregs, LiveInstr instr Nothing) liveness1 liveregs blockmap (LiveInstr instr _) - | not_a_branch - = (liveregs1, LiveInstr instr - (Just $ Liveness - { liveBorn = emptyUniqSet - , liveDieRead = mkUniqSet r_dying - , liveDieWrite = mkUniqSet w_dying })) - - | otherwise - = (liveregs_br, LiveInstr instr - (Just $ Liveness - { liveBorn = emptyUniqSet - , liveDieRead = mkUniqSet r_dying_br - , liveDieWrite = mkUniqSet w_dying })) - - where - RU read written = regUsageOfInstr instr - - -- registers that were written here are dead going backwards. - -- registers that were read here are live going backwards. - liveregs1 = (liveregs `delListFromUniqSet` written) - `addListToUniqSet` read - - -- registers that are not live beyond this point, are recorded - -- as dying here. - r_dying = [ reg | reg <- read, reg `notElem` written, - not (elementOfUniqSet reg liveregs) ] - - w_dying = [ reg | reg <- written, - not (elementOfUniqSet reg liveregs) ] - - -- union in the live regs from all the jump destinations of this - -- instruction. - targets = jumpDestsOfInstr instr -- where we go from here - not_a_branch = null targets + | not_a_branch + = (liveregs1, LiveInstr instr + (Just $ Liveness + { liveBorn = emptyUniqSet + , liveDieRead = mkUniqSet r_dying + , liveDieWrite = mkUniqSet w_dying })) + + | otherwise + = (liveregs_br, LiveInstr instr + (Just $ Liveness + { liveBorn = emptyUniqSet + , liveDieRead = mkUniqSet r_dying_br + , liveDieWrite = mkUniqSet w_dying })) + + where + RU read written = regUsageOfInstr instr + + -- registers that were written here are dead going backwards. + -- registers that were read here are live going backwards. + liveregs1 = (liveregs `delListFromUniqSet` written) + `addListToUniqSet` read + + -- registers that are not live beyond this point, are recorded + -- as dying here. + r_dying = [ reg | reg <- read, reg `notElem` written, + not (elementOfUniqSet reg liveregs) ] + + w_dying = [ reg | reg <- written, + not (elementOfUniqSet reg liveregs) ] + + -- union in the live regs from all the jump destinations of this + -- instruction. + targets = jumpDestsOfInstr instr -- where we go from here + not_a_branch = null targets - targetLiveRegs target - = case lookupBlockEnv blockmap target of + targetLiveRegs target + = case mapLookup target blockmap of Just ra -> ra Nothing -> emptyRegMap live_from_branch = unionManyUniqSets (map targetLiveRegs targets) - liveregs_br = liveregs1 `unionUniqSets` live_from_branch + liveregs_br = liveregs1 `unionUniqSets` live_from_branch -- registers that are live only in the branch targets should -- be listed as dying here. diff -Nru ghc-7.0.3/compiler/nativeGen/Size.hs ghc-7.2.1/compiler/nativeGen/Size.hs --- ghc-7.0.3/compiler/nativeGen/Size.hs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/nativeGen/Size.hs 2011-08-07 17:10:05.000000000 +0000 @@ -12,17 +12,18 @@ -- properly. eg SPARC doesn't care about FF80. -- module Size ( - Size(..), - intSize, - floatSize, - isFloatSize, - cmmTypeSize, - sizeToWidth + Size(..), + intSize, + floatSize, + isFloatSize, + cmmTypeSize, + sizeToWidth, + sizeInBytes ) where -import Cmm +import OldCmm import Outputable -- It looks very like the old MachRep, but it's now of purely local @@ -99,5 +100,6 @@ FF32 -> W32 FF64 -> W64 FF80 -> W80 - +sizeInBytes :: Size -> Int +sizeInBytes = widthInBytes . sizeToWidth diff -Nru ghc-7.0.3/compiler/nativeGen/SPARC/CodeGen/Amode.hs ghc-7.2.1/compiler/nativeGen/SPARC/CodeGen/Amode.hs --- ghc-7.0.3/compiler/nativeGen/SPARC/CodeGen/Amode.hs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/nativeGen/SPARC/CodeGen/Amode.hs 2011-08-07 17:10:05.000000000 +0000 @@ -15,7 +15,7 @@ import NCGMonad import Size -import Cmm +import OldCmm import OrdList diff -Nru ghc-7.0.3/compiler/nativeGen/SPARC/CodeGen/Base.hs ghc-7.2.1/compiler/nativeGen/SPARC/CodeGen/Base.hs --- ghc-7.0.3/compiler/nativeGen/SPARC/CodeGen/Base.hs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/nativeGen/SPARC/CodeGen/Base.hs 2011-08-07 17:10:05.000000000 +0000 @@ -22,7 +22,8 @@ import Size import Reg -import Cmm +import OldCmm +import OldPprCmm () import Outputable import OrdList diff -Nru ghc-7.0.3/compiler/nativeGen/SPARC/CodeGen/CCall.hs ghc-7.2.1/compiler/nativeGen/SPARC/CodeGen/CCall.hs --- ghc-7.0.3/compiler/nativeGen/SPARC/CodeGen/CCall.hs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/nativeGen/SPARC/CodeGen/CCall.hs 2011-08-07 17:10:05.000000000 +0000 @@ -19,13 +19,15 @@ import Size import Reg -import Cmm +import OldCmm import CLabel import BasicTypes import OrdList +import DynFlags import FastString import Outputable +import Platform {- Now the biggest nightmare---calls. Most of the nastiness is buried in @@ -62,9 +64,9 @@ -} genCCall - :: CmmCallTarget -- function to call - -> HintedCmmFormals -- where to put the result - -> HintedCmmActuals -- arguments (of mixed type) + :: CmmCallTarget -- function to call + -> [HintedCmmFormal] -- where to put the result + -> [HintedCmmActual] -- arguments (of mixed type) -> NatM InstrBlock @@ -80,9 +82,19 @@ genCCall target dest_regs argsAndHints = do + -- need to remove alignment information + let argsAndHints' | (CmmPrim mop) <- target, + (mop == MO_Memcpy || + mop == MO_Memset || + mop == MO_Memmove) + = init argsAndHints + + | otherwise + = argsAndHints + -- strip hints from the arg regs let args :: [CmmExpr] - args = map hintlessCmm argsAndHints + args = map hintlessCmm argsAndHints' -- work out the arguments, and assign them to integer regs @@ -104,7 +116,7 @@ return (dyn_c `snocOL` CALL (Right dyn_r) n_argRegs_used False) CmmPrim mop - -> do res <- outOfLineFloatOp mop + -> do res <- outOfLineMachOp mop lblOrMopExpr <- case res of Left lbl -> do return (unitOL (CALL (Left (litToImm (CmmLabel lbl))) n_argRegs_used False)) @@ -127,6 +139,7 @@ let transfer_code = toOL (move_final vregs allArgRegs extraStackArgsHere) + dflags <- getDynFlagsNat return $ argcode `appOL` move_sp_down `appOL` @@ -134,7 +147,7 @@ callinsns `appOL` unitOL NOP `appOL` move_sp_up `appOL` - assign_code dest_regs + assign_code (targetPlatform dflags) dest_regs -- | Generate code to calculate an argument, and move it into one @@ -214,11 +227,11 @@ -- | Assign results returned from the call into their -- desination regs. -- -assign_code :: [CmmHinted LocalReg] -> OrdList Instr +assign_code :: Platform -> [CmmHinted LocalReg] -> OrdList Instr -assign_code [] = nilOL +assign_code _ [] = nilOL -assign_code [CmmHinted dest _hint] +assign_code platform [CmmHinted dest _hint] = let rep = localRegType dest width = typeWidth rep r_dest = getRegisterReg (CmmLocal dest) @@ -234,32 +247,32 @@ | not $ isFloatType rep , W32 <- width - = unitOL $ mkRegRegMoveInstr (regSingle $ oReg 0) r_dest + = unitOL $ mkRegRegMoveInstr platform (regSingle $ oReg 0) r_dest | not $ isFloatType rep , W64 <- width , r_dest_hi <- getHiVRegFromLo r_dest - = toOL [ mkRegRegMoveInstr (regSingle $ oReg 0) r_dest_hi - , mkRegRegMoveInstr (regSingle $ oReg 1) r_dest] + = toOL [ mkRegRegMoveInstr platform (regSingle $ oReg 0) r_dest_hi + , mkRegRegMoveInstr platform (regSingle $ oReg 1) r_dest] | otherwise = panic "SPARC.CodeGen.GenCCall: no match" in result -assign_code _ +assign_code _ _ = panic "SPARC.CodeGen.GenCCall: no match" -- | Generate a call to implement an out-of-line floating point operation -outOfLineFloatOp +outOfLineMachOp :: CallishMachOp -> NatM (Either CLabel CmmExpr) -outOfLineFloatOp mop +outOfLineMachOp mop = do let functionName - = outOfLineFloatOp_table mop + = outOfLineMachOp_table mop dflags <- getDynFlagsNat mopExpr <- cmmMakeDynamicReference dflags addImportNat CallReference @@ -275,11 +288,11 @@ -- | Decide what C function to use to implement a CallishMachOp -- -outOfLineFloatOp_table +outOfLineMachOp_table :: CallishMachOp -> FastString -outOfLineFloatOp_table mop +outOfLineMachOp_table mop = case mop of MO_F32_Exp -> fsLit "expf" MO_F32_Log -> fsLit "logf" @@ -315,5 +328,9 @@ MO_F64_Cosh -> fsLit "cosh" MO_F64_Tanh -> fsLit "tanh" - _ -> pprPanic "outOfLineFloatOp(sparc): Unknown callish mach op " + MO_Memcpy -> fsLit "memcpy" + MO_Memset -> fsLit "memset" + MO_Memmove -> fsLit "memmove" + + _ -> pprPanic "outOfLineMachOp(sparc): Unknown callish mach op " (pprCallishMachOp mop) diff -Nru ghc-7.0.3/compiler/nativeGen/SPARC/CodeGen/CondCode.hs ghc-7.2.1/compiler/nativeGen/SPARC/CodeGen/CondCode.hs --- ghc-7.0.3/compiler/nativeGen/SPARC/CodeGen/CondCode.hs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/nativeGen/SPARC/CodeGen/CondCode.hs 2011-08-07 17:10:05.000000000 +0000 @@ -17,7 +17,7 @@ import NCGMonad import Size -import Cmm +import OldCmm import OrdList import Outputable diff -Nru ghc-7.0.3/compiler/nativeGen/SPARC/CodeGen/Expand.hs ghc-7.2.1/compiler/nativeGen/SPARC/CodeGen/Expand.hs --- ghc-7.0.3/compiler/nativeGen/SPARC/CodeGen/Expand.hs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/nativeGen/SPARC/CodeGen/Expand.hs 2011-08-07 17:10:05.000000000 +0000 @@ -14,19 +14,19 @@ import Instruction import Reg import Size -import Cmm +import OldCmm import Outputable import OrdList -- | Expand out synthetic instructions in this top level thing -expandTop :: NatCmmTop Instr -> NatCmmTop Instr +expandTop :: NatCmmTop CmmStatics Instr -> NatCmmTop CmmStatics Instr expandTop top@(CmmData{}) = top -expandTop (CmmProc info lbl params (ListGraph blocks)) - = CmmProc info lbl params (ListGraph $ map expandBlock blocks) +expandTop (CmmProc info lbl (ListGraph blocks)) + = CmmProc info lbl (ListGraph $ map expandBlock blocks) -- | Expand out synthetic instructions in this block diff -Nru ghc-7.0.3/compiler/nativeGen/SPARC/CodeGen/Gen32.hs ghc-7.2.1/compiler/nativeGen/SPARC/CodeGen/Gen32.hs --- ghc-7.0.3/compiler/nativeGen/SPARC/CodeGen/Gen32.hs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/nativeGen/SPARC/CodeGen/Gen32.hs 2011-08-07 17:10:05.000000000 +0000 @@ -22,9 +22,9 @@ import Size import Reg -import Cmm -import BlockId +import OldCmm +import Control.Monad (liftM) import OrdList import Outputable @@ -83,9 +83,8 @@ let code dst = toOL [ -- the data area - LDATA ReadOnlyData - [CmmDataLabel lbl, - CmmStaticLit (CmmFloat f W32)], + LDATA ReadOnlyData $ Statics lbl + [CmmStaticLit (CmmFloat f W32)], -- load the literal SETHI (HI (ImmCLbl lbl)) tmp, @@ -97,9 +96,8 @@ lbl <- getNewLabelNat tmp <- getNewRegNat II32 let code dst = toOL [ - LDATA ReadOnlyData - [CmmDataLabel lbl, - CmmStaticLit (CmmFloat d W64)], + LDATA ReadOnlyData $ Statics lbl + [CmmStaticLit (CmmFloat d W64)], SETHI (HI (ImmCLbl lbl)) tmp, LD II64 (AddrRegImm tmp (LO (ImmCLbl lbl))) dst] return (Any FF64 code) @@ -638,8 +636,8 @@ return (Any II32 code__2) condIntReg cond x y = do - bid1@(BlockId _) <- getBlockIdNat - bid2@(BlockId _) <- getBlockIdNat + bid1 <- liftM (\a -> seq a a) getBlockIdNat + bid2 <- liftM (\a -> seq a a) getBlockIdNat CondCode _ cond cond_code <- condIntCode cond x y let code__2 dst @@ -664,8 +662,8 @@ condFltReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register condFltReg cond x y = do - bid1@(BlockId _) <- getBlockIdNat - bid2@(BlockId _) <- getBlockIdNat + bid1 <- liftM (\a -> seq a a) getBlockIdNat + bid2 <- liftM (\a -> seq a a) getBlockIdNat CondCode _ cond cond_code <- condFltCode cond x y let diff -Nru ghc-7.0.3/compiler/nativeGen/SPARC/CodeGen/Gen32.hs-boot ghc-7.2.1/compiler/nativeGen/SPARC/CodeGen/Gen32.hs-boot --- ghc-7.0.3/compiler/nativeGen/SPARC/CodeGen/Gen32.hs-boot 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/nativeGen/SPARC/CodeGen/Gen32.hs-boot 2011-08-07 17:10:05.000000000 +0000 @@ -10,7 +10,7 @@ import NCGMonad import Reg -import Cmm +import OldCmm getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock) getRegister :: CmmExpr -> NatM Register diff -Nru ghc-7.0.3/compiler/nativeGen/SPARC/CodeGen/Gen64.hs ghc-7.2.1/compiler/nativeGen/SPARC/CodeGen/Gen64.hs --- ghc-7.0.3/compiler/nativeGen/SPARC/CodeGen/Gen64.hs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/nativeGen/SPARC/CodeGen/Gen64.hs 2011-08-07 17:10:05.000000000 +0000 @@ -21,8 +21,9 @@ import Size import Reg -import Cmm +import OldCmm +import DynFlags import OrdList import Outputable @@ -182,10 +183,12 @@ -- compute expr and load it into r_dst_lo (a_reg, a_code) <- getSomeReg expr - let code = a_code + dflags <- getDynFlagsNat + let platform = targetPlatform dflags + code = a_code `appOL` toOL - [ mkRegRegMoveInstr g0 r_dst_hi -- clear high 32 bits - , mkRegRegMoveInstr a_reg r_dst_lo ] + [ mkRegRegMoveInstr platform g0 r_dst_hi -- clear high 32 bits + , mkRegRegMoveInstr platform a_reg r_dst_lo ] return $ ChildCode64 code r_dst_lo diff -Nru ghc-7.0.3/compiler/nativeGen/SPARC/CodeGen/Sanity.hs ghc-7.2.1/compiler/nativeGen/SPARC/CodeGen/Sanity.hs --- ghc-7.0.3/compiler/nativeGen/SPARC/CodeGen/Sanity.hs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/nativeGen/SPARC/CodeGen/Sanity.hs 2011-08-07 17:10:05.000000000 +0000 @@ -12,18 +12,20 @@ import SPARC.Ppr () import Instruction -import Cmm +import OldCmm import Outputable +import Platform -- | Enforce intra-block invariants. -- -checkBlock - :: CmmBasicBlock - -> NatBasicBlock Instr -> NatBasicBlock Instr +checkBlock :: Platform + -> CmmBasicBlock + -> NatBasicBlock Instr + -> NatBasicBlock Instr -checkBlock cmm block@(BasicBlock _ instrs) +checkBlock platform cmm block@(BasicBlock _ instrs) | checkBlockInstrs instrs = block @@ -31,9 +33,9 @@ = pprPanic ("SPARC.CodeGen: bad block\n") ( vcat [ text " -- cmm -----------------\n" - , ppr cmm + , pprPlatform platform cmm , text " -- native code ---------\n" - , ppr block ]) + , pprPlatform platform block ]) checkBlockInstrs :: [Instr] -> Bool diff -Nru ghc-7.0.3/compiler/nativeGen/SPARC/CodeGen.hs ghc-7.2.1/compiler/nativeGen/SPARC/CodeGen.hs --- ghc-7.0.3/compiler/nativeGen/SPARC/CodeGen.hs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/nativeGen/SPARC/CodeGen.hs 2011-08-07 17:10:05.000000000 +0000 @@ -8,6 +8,7 @@ module SPARC.CodeGen ( cmmTopCodeGen, + generateJumpTableForInstr, InstrBlock ) @@ -36,34 +37,35 @@ -- Our intermediate code: import BlockId -import Cmm +import OldCmm import CLabel -- The rest: +import DynFlags import StaticFlags ( opt_PIC ) import OrdList import Outputable +import Platform +import Unique import Control.Monad ( mapAndUnzipM ) -import DynFlags -- | Top level code generation -cmmTopCodeGen - :: DynFlags - -> RawCmmTop - -> NatM [NatCmmTop Instr] - -cmmTopCodeGen _ - (CmmProc info lab params (ListGraph blocks)) - = do - (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks +cmmTopCodeGen :: RawCmmTop + -> NatM [NatCmmTop CmmStatics Instr] - let proc = CmmProc info lab params (ListGraph $ concat nat_blocks) - let tops = proc : concat statics +cmmTopCodeGen (CmmProc info lab (ListGraph blocks)) + = do + dflags <- getDynFlagsNat + let platform = targetPlatform dflags + (nat_blocks,statics) <- mapAndUnzipM (basicBlockCodeGen platform) blocks - return tops - -cmmTopCodeGen _ (CmmData sec dat) = do + let proc = CmmProc info lab (ListGraph $ concat nat_blocks) + let tops = proc : concat statics + + return tops + +cmmTopCodeGen (CmmData sec dat) = do return [CmmData sec dat] -- no translation, we just use CmmStatic @@ -72,12 +74,12 @@ -- are indicated by the NEWBLOCK instruction. We must split up the -- instruction stream into basic blocks again. Also, we extract -- LDATAs here too. -basicBlockCodeGen - :: CmmBasicBlock - -> NatM ( [NatBasicBlock Instr] - , [NatCmmTop Instr]) +basicBlockCodeGen :: Platform + -> CmmBasicBlock + -> NatM ( [NatBasicBlock Instr] + , [NatCmmTop CmmStatics Instr]) -basicBlockCodeGen cmm@(BasicBlock id stmts) = do +basicBlockCodeGen platform cmm@(BasicBlock id stmts) = do instrs <- stmtsToInstrs stmts let (top,other_blocks,statics) @@ -94,7 +96,7 @@ -- do intra-block sanity checking blocksChecked - = map (checkBlock cmm) + = map (checkBlock platform cmm) $ BasicBlock id top : other_blocks return (blocksChecked, statics) @@ -161,8 +163,8 @@ -- | Convert a BlockId to some CmmStatic data jumpTableEntry :: Maybe BlockId -> CmmStatic jumpTableEntry Nothing = CmmStaticLit (CmmInt 0 wordWidth) -jumpTableEntry (Just (BlockId id)) = CmmStaticLit (CmmLabel blockLabel) - where blockLabel = mkAsmTempLabel id +jumpTableEntry (Just blockid) = CmmStaticLit (CmmLabel blockLabel) + where blockLabel = mkAsmTempLabel (getUnique blockid) @@ -298,15 +300,11 @@ 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.. @@ -314,6 +312,11 @@ -- 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 CmmStatics Instr) +generateJumpTableForInstr (JMP_TBL _ ids label) = + let jumpTable = map jumpTableEntry ids + in Just (CmmData ReadOnlyData (Statics label jumpTable)) +generateJumpTableForInstr _ = Nothing diff -Nru ghc-7.0.3/compiler/nativeGen/SPARC/Imm.hs ghc-7.2.1/compiler/nativeGen/SPARC/Imm.hs --- ghc-7.0.3/compiler/nativeGen/SPARC/Imm.hs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/nativeGen/SPARC/Imm.hs 2011-08-07 17:10:05.000000000 +0000 @@ -8,7 +8,7 @@ where -import Cmm +import OldCmm import CLabel import BlockId diff -Nru ghc-7.0.3/compiler/nativeGen/SPARC/Instr.hs ghc-7.2.1/compiler/nativeGen/SPARC/Instr.hs --- ghc-7.0.3/compiler/nativeGen/SPARC/Instr.hs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/nativeGen/SPARC/Instr.hs 2011-08-07 17:10:05.000000000 +0000 @@ -37,11 +37,13 @@ import Reg import Size +import CLabel import BlockId -import Cmm +import OldCmm import FastString import FastBool import Outputable +import Platform -- | Register or immediate @@ -111,7 +113,7 @@ -- some static data spat out during code generation. -- Will be extracted before pretty-printing. - | LDATA Section [CmmStatic] + | LDATA Section CmmStatics -- Start a new basic block. Useful during codegen, removed later. -- Preceding instruction should be a jump, as per the invariants @@ -194,7 +196,7 @@ -- 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 +249,7 @@ 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 +317,7 @@ 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 +347,7 @@ = case insn of BI _ _ id -> [id] BF _ _ id -> [id] - JMP_TBL _ ids -> ids + JMP_TBL _ ids _ -> [id | Just id <- ids] _ -> [] @@ -354,6 +356,7 @@ = 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 @@ -361,15 +364,16 @@ -- | Make a spill instruction. -- On SPARC we spill below frame pointer leaving 2 words/spill sparc_mkSpillInstr - :: Reg -- ^ register to spill - -> Int -- ^ current stack delta - -> Int -- ^ spill slot to use - -> Instr + :: Platform + -> Reg -- ^ register to spill + -> Int -- ^ current stack delta + -> Int -- ^ spill slot to use + -> Instr -sparc_mkSpillInstr reg _ slot +sparc_mkSpillInstr platform reg _ slot = let off = spillSlotToOffset slot off_w = 1 + (off `div` 4) - sz = case targetClassOfReg reg of + sz = case targetClassOfReg platform reg of RcInteger -> II32 RcFloat -> FF32 RcDouble -> FF64 @@ -380,15 +384,16 @@ -- | Make a spill reload instruction. sparc_mkLoadInstr - :: Reg -- ^ register to load into - -> Int -- ^ current stack delta - -> Int -- ^ spill slot to use - -> Instr + :: Platform + -> Reg -- ^ register to load into + -> Int -- ^ current stack delta + -> Int -- ^ spill slot to use + -> Instr -sparc_mkLoadInstr reg _ slot +sparc_mkLoadInstr platform reg _ slot = let off = spillSlotToOffset slot off_w = 1 + (off `div` 4) - sz = case targetClassOfReg reg of + sz = case targetClassOfReg platform reg of RcInteger -> II32 RcFloat -> FF32 RcDouble -> FF64 @@ -428,13 +433,14 @@ -- have to go via memory. -- sparc_mkRegRegMoveInstr - :: Reg - -> Reg - -> Instr - -sparc_mkRegRegMoveInstr src dst - | srcClass <- targetClassOfReg src - , dstClass <- targetClassOfReg dst + :: Platform + -> Reg + -> Reg + -> Instr + +sparc_mkRegRegMoveInstr platform src dst + | srcClass <- targetClassOfReg platform src + , dstClass <- targetClassOfReg platform dst , srcClass == dstClass = case srcClass of RcInteger -> ADD False False src (RIReg g0) dst diff -Nru ghc-7.0.3/compiler/nativeGen/SPARC/Ppr.hs ghc-7.2.1/compiler/nativeGen/SPARC/Ppr.hs --- ghc-7.0.3/compiler/nativeGen/SPARC/Ppr.hs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/nativeGen/SPARC/Ppr.hs 2011-08-07 17:10:05.000000000 +0000 @@ -12,7 +12,6 @@ pprSectionHeader, pprData, pprInstr, - pprUserReg, pprSize, pprImm, pprDataItem @@ -34,13 +33,14 @@ import Size import PprBase -import BlockId -import Cmm +import OldCmm +import OldPprCmm() import CLabel -import Unique ( pprUnique ) +import Unique ( Uniquable(..), pprUnique ) import qualified Outputable -import Outputable (Outputable, panic) +import Outputable (PlatformOutputable, panic) +import Platform import Pretty import FastString import Data.Word @@ -48,24 +48,28 @@ -- ----------------------------------------------------------------------------- -- Printing this stuff out -pprNatCmmTop :: NatCmmTop Instr -> Doc -pprNatCmmTop (CmmData section dats) = - pprSectionHeader section $$ vcat (map pprData dats) +pprNatCmmTop :: Platform -> NatCmmTop CmmStatics Instr -> Doc +pprNatCmmTop _ (CmmData section dats) = + pprSectionHeader section $$ pprDatas dats -- special case for split markers: -pprNatCmmTop (CmmProc [] lbl _ (ListGraph [])) = pprLabel lbl +pprNatCmmTop _ (CmmProc Nothing lbl (ListGraph [])) = pprLabel lbl -pprNatCmmTop (CmmProc info lbl _ (ListGraph blocks)) = + -- special case for code without info table: +pprNatCmmTop _ (CmmProc Nothing lbl (ListGraph blocks)) = pprSectionHeader Text $$ - (if null info then -- blocks guaranteed not null, so label needed - pprLabel lbl - else + pprLabel lbl $$ -- blocks guaranteed not null, so label needed + vcat (map pprBasicBlock blocks) + +pprNatCmmTop _ (CmmProc (Just (Statics info_lbl info)) _entry_lbl (ListGraph blocks)) = + pprSectionHeader Text $$ + ( #if HAVE_SUBSECTIONS_VIA_SYMBOLS - pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl) - <> char ':' $$ + pprCLabel_asm (mkDeadStripPreventer info_lbl) + <> char ':' $$ #endif vcat (map pprData info) $$ - pprLabel (entryLblToInfoLbl lbl) + pprLabel info_lbl ) $$ vcat (map pprBasicBlock blocks) -- above: Even the first block gets a label, because with branch-chain @@ -77,24 +81,23 @@ -- from the entry code to a label on the _top_ of of the info table, -- so that the linker will not think it is unreferenced and dead-strip -- it. That's why the label is called a DeadStripPreventer (_dsp). - $$ if not (null info) - then text "\t.long " - <+> pprCLabel_asm (entryLblToInfoLbl lbl) - <+> char '-' - <+> pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl) - else empty + $$ text "\t.long " + <+> pprCLabel_asm info_lbl + <+> char '-' + <+> pprCLabel_asm (mkDeadStripPreventer info_lbl) #endif pprBasicBlock :: NatBasicBlock Instr -> Doc -pprBasicBlock (BasicBlock (BlockId id) instrs) = - pprLabel (mkAsmTempLabel id) $$ +pprBasicBlock (BasicBlock blockid instrs) = + pprLabel (mkAsmTempLabel (getUnique blockid)) $$ vcat (map pprInstr instrs) +pprDatas :: CmmStatics -> Doc +pprDatas (Statics lbl dats) = vcat (pprLabel lbl : map pprData dats) + pprData :: CmmStatic -> Doc -pprData (CmmAlign bytes) = pprAlign bytes -pprData (CmmDataLabel lbl) = pprLabel lbl pprData (CmmString str) = pprASCII str pprData (CmmUninitialised bytes) = ptext (sLit ".skip ") <> int bytes pprData (CmmStaticLit lit) = pprDataItem lit @@ -102,9 +105,7 @@ pprGloblDecl :: CLabel -> Doc pprGloblDecl lbl | not (externallyVisibleCLabel lbl) = empty - | otherwise = ptext IF_ARCH_sparc((sLit ".global "), - (sLit ".globl ")) <> - pprCLabel_asm lbl + | otherwise = ptext (sLit ".global ") <> pprCLabel_asm lbl pprTypeAndSizeDecl :: CLabel -> Doc #if linux_TARGET_OS @@ -128,22 +129,12 @@ do1 :: Word8 -> Doc do1 w = ptext (sLit "\t.byte\t") <> int (fromIntegral w) -pprAlign :: Int -> Doc -pprAlign bytes = - ptext (sLit ".align ") <> int bytes - -- ----------------------------------------------------------------------------- -- pprInstr: print an 'Instr' -instance Outputable Instr where - ppr instr = Outputable.docToSDoc $ pprInstr instr - - --- | Pretty print a register. --- This is an alias of pprReg for legacy reasons, should remove it. -pprUserReg :: Reg -> Doc -pprUserReg = pprReg +instance PlatformOutputable Instr where + pprPlatform _ instr = Outputable.docToSDoc $ pprInstr instr -- | Pretty print a register. @@ -526,24 +517,24 @@ ] -pprInstr (BI cond b (BlockId id)) +pprInstr (BI cond b blockid) = hcat [ ptext (sLit "\tb"), pprCond cond, if b then pp_comma_a else empty, char '\t', - pprCLabel_asm (mkAsmTempLabel id) + pprCLabel_asm (mkAsmTempLabel (getUnique blockid)) ] -pprInstr (BF cond b (BlockId id)) +pprInstr (BF cond b blockid) = hcat [ ptext (sLit "\tfb"), pprCond cond, if b then pp_comma_a else empty, char '\t', - pprCLabel_asm (mkAsmTempLabel id) + pprCLabel_asm (mkAsmTempLabel (getUnique 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 -Nru ghc-7.0.3/compiler/nativeGen/SPARC/Regs.hs ghc-7.2.1/compiler/nativeGen/SPARC/Regs.hs --- ghc-7.0.3/compiler/nativeGen/SPARC/Regs.hs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/nativeGen/SPARC/Regs.hs 2011-08-07 17:10:05.000000000 +0000 @@ -37,7 +37,7 @@ import RegClass import Size -import PprCmm () +-- import PprCmm () import Unique import Outputable diff -Nru ghc-7.0.3/compiler/nativeGen/SPARC/ShortcutJump.hs ghc-7.2.1/compiler/nativeGen/SPARC/ShortcutJump.hs --- ghc-7.0.3/compiler/nativeGen/SPARC/ShortcutJump.hs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/nativeGen/SPARC/ShortcutJump.hs 2011-08-07 17:10:05.000000000 +0000 @@ -1,9 +1,9 @@ module SPARC.ShortcutJump ( - JumpDest(..), + JumpDest(..), getJumpDestBlockId, canShortcut, shortcutJump, - shortcutStatic, + shortcutStatics, shortBlockId ) @@ -14,9 +14,10 @@ import CLabel import BlockId -import Cmm +import OldCmm import Panic +import Unique @@ -24,6 +25,10 @@ = DestBlockId BlockId | DestImm Imm +getJumpDestBlockId :: JumpDest -> Maybe BlockId +getJumpDestBlockId (DestBlockId bid) = Just bid +getJumpDestBlockId _ = Nothing + canShortcut :: Instr -> Maybe JumpDest canShortcut _ = Nothing @@ -33,16 +38,23 @@ shortcutJump _ other = other -shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic -shortcutStatic fn (CmmStaticLit (CmmLabel lab)) - | Just uq <- maybeAsmTemp lab - = CmmStaticLit (CmmLabel (shortBlockId fn (BlockId uq))) +shortcutStatics :: (BlockId -> Maybe JumpDest) -> CmmStatics -> CmmStatics +shortcutStatics fn (Statics lbl statics) + = Statics lbl $ map (shortcutStatic fn) statics + -- we need to get the jump tables, so apply the mapping to the entries + -- of a CmmData too. + +shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel +shortcutLabel fn lab + | Just uq <- maybeAsmTemp lab = shortBlockId fn (mkBlockId uq) + | otherwise = lab +shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic +shortcutStatic fn (CmmStaticLit (CmmLabel lab)) + = CmmStaticLit (CmmLabel (shortcutLabel fn lab)) shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off)) - | Just uq <- maybeAsmTemp lbl1 - = CmmStaticLit (CmmLabelDiffOff (shortBlockId fn (BlockId uq)) lbl2 off) - + = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off) -- slightly dodgy, we're ignoring the second label, but this -- works with the way we use CmmLabelDiffOff for jump tables now. shortcutStatic _ other_static @@ -50,9 +62,9 @@ shortBlockId :: (BlockId -> Maybe JumpDest) -> BlockId -> CLabel -shortBlockId fn blockid@(BlockId uq) = +shortBlockId fn blockid = case fn blockid of - Nothing -> mkAsmTempLabel uq + Nothing -> mkAsmTempLabel (getUnique blockid) Just (DestBlockId blockid') -> shortBlockId fn blockid' Just (DestImm (ImmCLbl lbl)) -> lbl _other -> panic "shortBlockId" diff -Nru ghc-7.0.3/compiler/nativeGen/TargetReg.hs ghc-7.2.1/compiler/nativeGen/TargetReg.hs --- ghc-7.0.3/compiler/nativeGen/TargetReg.hs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/nativeGen/TargetReg.hs 2011-08-07 17:10:05.000000000 +0000 @@ -27,70 +27,83 @@ import RegClass import Size -import CmmExpr (wordWidth) +import CmmType (wordWidth) import Outputable import Unique import FastTypes +import Platform +import qualified X86.Regs as X86 +import qualified X86.RegInfo as X86 -#if i386_TARGET_ARCH || x86_64_TARGET_ARCH -import qualified X86.Regs as X86 -import qualified X86.RegInfo as X86 - -#elif powerpc_TARGET_ARCH -import qualified PPC.Regs as PPC - -#elif sparc_TARGET_ARCH -import qualified SPARC.Regs as SPARC - -#else -#error "RegAlloc.Graph.TargetReg: not defined" -#endif - -targetVirtualRegSqueeze :: RegClass -> VirtualReg -> FastInt -targetRealRegSqueeze :: RegClass -> RealReg -> FastInt -targetClassOfRealReg :: RealReg -> RegClass -targetWordSize :: Size -targetMkVirtualReg :: Unique -> Size -> VirtualReg -targetRegDotColor :: RealReg -> SDoc - --- x86 ------------------------------------------------------------------------- -#if i386_TARGET_ARCH || x86_64_TARGET_ARCH -targetVirtualRegSqueeze = X86.virtualRegSqueeze -targetRealRegSqueeze = X86.realRegSqueeze -targetClassOfRealReg = X86.classOfRealReg -targetWordSize = intSize wordWidth -targetMkVirtualReg = X86.mkVirtualReg -targetRegDotColor = X86.regDotColor - --- ppc ------------------------------------------------------------------------- -#elif powerpc_TARGET_ARCH -targetVirtualRegSqueeze = PPC.virtualRegSqueeze -targetRealRegSqueeze = PPC.realRegSqueeze -targetClassOfRealReg = PPC.classOfRealReg -targetWordSize = intSize wordWidth -targetMkVirtualReg = PPC.mkVirtualReg -targetRegDotColor = PPC.regDotColor - --- sparc ----------------------------------------------------------------------- -#elif sparc_TARGET_ARCH -targetVirtualRegSqueeze = SPARC.virtualRegSqueeze -targetRealRegSqueeze = SPARC.realRegSqueeze -targetClassOfRealReg = SPARC.classOfRealReg -targetWordSize = intSize wordWidth -targetMkVirtualReg = SPARC.mkVirtualReg -targetRegDotColor = SPARC.regDotColor - --------------------------------------------------------------------------------- -#else -#error "RegAlloc.Graph.TargetReg: not defined" -#endif +import qualified PPC.Regs as PPC +import qualified SPARC.Regs as SPARC -targetClassOfReg :: Reg -> RegClass -targetClassOfReg reg +targetVirtualRegSqueeze :: Platform -> RegClass -> VirtualReg -> FastInt +targetVirtualRegSqueeze platform + = case platformArch platform of + ArchX86 -> X86.virtualRegSqueeze + ArchX86_64 -> X86.virtualRegSqueeze + ArchPPC -> PPC.virtualRegSqueeze + ArchSPARC -> SPARC.virtualRegSqueeze + ArchPPC_64 -> panic "targetVirtualRegSqueeze ArchPPC_64" + ArchARM -> panic "targetVirtualRegSqueeze ArchARM" + ArchUnknown -> panic "targetVirtualRegSqueeze ArchUnknown" + +targetRealRegSqueeze :: Platform -> RegClass -> RealReg -> FastInt +targetRealRegSqueeze platform + = case platformArch platform of + ArchX86 -> X86.realRegSqueeze + ArchX86_64 -> X86.realRegSqueeze + ArchPPC -> PPC.realRegSqueeze + ArchSPARC -> SPARC.realRegSqueeze + ArchPPC_64 -> panic "targetRealRegSqueeze ArchPPC_64" + ArchARM -> panic "targetRealRegSqueeze ArchARM" + ArchUnknown -> panic "targetRealRegSqueeze ArchUnknown" + +targetClassOfRealReg :: Platform -> RealReg -> RegClass +targetClassOfRealReg platform + = case platformArch platform of + ArchX86 -> X86.classOfRealReg + ArchX86_64 -> X86.classOfRealReg + ArchPPC -> PPC.classOfRealReg + ArchSPARC -> SPARC.classOfRealReg + ArchPPC_64 -> panic "targetClassOfRealReg ArchPPC_64" + ArchARM -> panic "targetClassOfRealReg ArchARM" + ArchUnknown -> panic "targetClassOfRealReg ArchUnknown" + +-- TODO: This should look at targetPlatform too +targetWordSize :: Size +targetWordSize = intSize wordWidth + +targetMkVirtualReg :: Platform -> Unique -> Size -> VirtualReg +targetMkVirtualReg platform + = case platformArch platform of + ArchX86 -> X86.mkVirtualReg + ArchX86_64 -> X86.mkVirtualReg + ArchPPC -> PPC.mkVirtualReg + ArchSPARC -> SPARC.mkVirtualReg + ArchPPC_64 -> panic "targetMkVirtualReg ArchPPC_64" + ArchARM -> panic "targetMkVirtualReg ArchARM" + ArchUnknown -> panic "targetMkVirtualReg ArchUnknown" + +targetRegDotColor :: Platform -> RealReg -> SDoc +targetRegDotColor platform + = case platformArch platform of + ArchX86 -> X86.regDotColor platform + ArchX86_64 -> X86.regDotColor platform + ArchPPC -> PPC.regDotColor + ArchSPARC -> SPARC.regDotColor + ArchPPC_64 -> panic "targetRegDotColor ArchPPC_64" + ArchARM -> panic "targetRegDotColor ArchARM" + ArchUnknown -> panic "targetRegDotColor ArchUnknown" + + +targetClassOfReg :: Platform -> Reg -> RegClass +targetClassOfReg platform reg = case reg of - RegVirtual vr -> classOfVirtualReg vr - RegReal rr -> targetClassOfRealReg rr + RegVirtual vr -> classOfVirtualReg vr + RegReal rr -> targetClassOfRealReg platform rr diff -Nru ghc-7.0.3/compiler/nativeGen/X86/CodeGen.hs ghc-7.2.1/compiler/nativeGen/X86/CodeGen.hs --- ghc-7.0.3/compiler/nativeGen/X86/CodeGen.hs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/nativeGen/X86/CodeGen.hs 2011-08-07 17:10:05.000000000 +0000 @@ -1,10 +1,3 @@ -{-# OPTIONS -w #-} --- 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 - ----------------------------------------------------------------------------- -- -- Generating machine code (instruction selection) @@ -18,10 +11,11 @@ -- (c) the #if blah_TARGET_ARCH} things, the -- structure should not be too overwhelming. -module X86.CodeGen ( - cmmTopCodeGen, - InstrBlock -) +module X86.CodeGen ( + cmmTopCodeGen, + generateJumpTableForInstr, + InstrBlock +) where @@ -34,85 +28,80 @@ import X86.Cond import X86.Regs import X86.RegInfo -import X86.Ppr import Instruction import PIC import NCGMonad import Size import Reg -import RegClass import Platform -- Our intermediate code: import BasicTypes import BlockId -import PprCmm ( pprExpr ) -import Cmm +import PprCmm () +import OldCmm +import OldPprCmm () import CLabel -import ClosureInfo ( C_SRT(..) ) -- The rest: -import StaticFlags ( opt_PIC ) -import ForeignCall ( CCallConv(..) ) +import StaticFlags ( opt_PIC ) +import ForeignCall ( CCallConv(..) ) import OrdList -import Pretty -import qualified Outputable as O import Outputable +import Unique import FastString -import FastBool ( isFastTrue ) -import Constants ( wORD_SIZE ) +import FastBool ( isFastTrue ) +import Constants ( wORD_SIZE ) import DynFlags -import Debug.Trace ( trace ) - -import Control.Monad ( mapAndUnzipM ) -import Data.Maybe ( fromJust ) +import Control.Monad import Data.Bits -import Data.Word import Data.Int +import Data.Maybe +import Data.Word sse2Enabled :: NatM Bool -#if x86_64_TARGET_ARCH --- SSE2 is fixed on for x86_64. It would be possible to make it optional, --- but we'd need to fix at least the foreign call code where the calling --- convention specifies the use of xmm regs, and possibly other places. -sse2Enabled = return True -#else sse2Enabled = do dflags <- getDynFlagsNat - return (dopt Opt_SSE2 dflags) -#endif + case platformArch (targetPlatform dflags) of + ArchX86_64 -> -- SSE2 is fixed on for x86_64. It would be + -- possible to make it optional, but we'd need to + -- fix at least the foreign call code where the + -- calling convention specifies the use of xmm regs, + -- and possibly other places. + return True + ArchX86 -> return (dopt Opt_SSE2 dflags) + _ -> panic "sse2Enabled: Not an X86* arch" if_sse2 :: NatM a -> NatM a -> NatM a if_sse2 sse2 x87 = do b <- sse2Enabled if b then sse2 else x87 -cmmTopCodeGen - :: DynFlags - -> RawCmmTop - -> NatM [NatCmmTop Instr] +cmmTopCodeGen + :: RawCmmTop + -> NatM [NatCmmTop (Alignment, CmmStatics) Instr] -cmmTopCodeGen dynflags - (CmmProc info lab params (ListGraph blocks)) = do +cmmTopCodeGen (CmmProc info lab (ListGraph blocks)) = do (nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks picBaseMb <- getPicBaseMaybeNat - let proc = CmmProc info lab params (ListGraph $ concat nat_blocks) + dflags <- getDynFlagsNat + let proc = CmmProc info lab (ListGraph $ concat nat_blocks) tops = proc : concat statics - os = platformOS $ targetPlatform dynflags + os = platformOS $ targetPlatform dflags case picBaseMb of Just picBase -> initializePicBase_x86 ArchX86 os picBase tops Nothing -> return tops - -cmmTopCodeGen _ (CmmData sec dat) = do - return [CmmData sec dat] -- no translation, we just use CmmStatic + +cmmTopCodeGen (CmmData sec dat) = do + return [CmmData sec (1, dat)] -- no translation, we just use CmmStatic -basicBlockCodeGen - :: CmmBasicBlock - -> NatM ( [NatBasicBlock Instr] - , [NatCmmTop Instr]) +basicBlockCodeGen + :: CmmBasicBlock + -> NatM ( [NatBasicBlock Instr] + , [NatCmmTop (Alignment, CmmStatics) Instr]) basicBlockCodeGen (BasicBlock id stmts) = do instrs <- stmtsToInstrs stmts @@ -121,14 +110,14 @@ -- instruction stream into basic blocks again. Also, we extract -- LDATAs here too. let - (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs - - mkBlocks (NEWBLOCK id) (instrs,blocks,statics) - = ([], BasicBlock id instrs : blocks, statics) - mkBlocks (LDATA sec dat) (instrs,blocks,statics) - = (instrs, blocks, CmmData sec dat:statics) - mkBlocks instr (instrs,blocks,statics) - = (instr:instrs, blocks, statics) + (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs + + mkBlocks (NEWBLOCK id) (instrs,blocks,statics) + = ([], BasicBlock id instrs : blocks, statics) + mkBlocks (LDATA sec dat) (instrs,blocks,statics) + = (instrs, blocks, CmmData sec dat:statics) + mkBlocks instr (instrs,blocks,statics) + = (instr:instrs, blocks, statics) -- in return (BasicBlock id top : other_blocks, statics) @@ -140,75 +129,74 @@ stmtToInstrs :: CmmStmt -> NatM InstrBlock -stmtToInstrs stmt = case stmt of - CmmNop -> return nilOL +stmtToInstrs stmt = do + dflags <- getDynFlagsNat + let is32Bit = target32Bit (targetPlatform dflags) + case stmt of + CmmNop -> return nilOL CmmComment s -> return (unitOL (COMMENT s)) CmmAssign reg src - | isFloatType ty -> assignReg_FltCode size reg src -#if WORD_SIZE_IN_BITS==32 - | isWord64 ty -> assignReg_I64Code reg src -#endif - | otherwise -> assignReg_IntCode size reg src - where ty = cmmRegType reg - size = cmmTypeSize ty + | isFloatType ty -> assignReg_FltCode size reg src + | is32Bit && isWord64 ty -> assignReg_I64Code reg src + | otherwise -> assignReg_IntCode size reg src + where ty = cmmRegType reg + size = cmmTypeSize ty CmmStore addr src - | isFloatType ty -> assignMem_FltCode size addr src -#if WORD_SIZE_IN_BITS==32 - | isWord64 ty -> assignMem_I64Code addr src -#endif - | otherwise -> assignMem_IntCode size addr src - where ty = cmmExprType src - size = cmmTypeSize ty + | isFloatType ty -> assignMem_FltCode size addr src + | is32Bit && isWord64 ty -> assignMem_I64Code addr src + | otherwise -> assignMem_IntCode size addr src + where ty = cmmExprType src + size = cmmTypeSize ty CmmCall target result_regs args _ _ -> genCCall target result_regs args - CmmBranch id -> genBranch id + CmmBranch id -> genBranch id CmmCondBranch arg id -> genCondJump id arg CmmSwitch arg ids -> genSwitch arg ids - CmmJump arg params -> genJump arg - CmmReturn params -> + CmmJump arg _ -> genJump arg + CmmReturn _ -> panic "stmtToInstrs: return statement should have been cps'd away" -------------------------------------------------------------------------------- -- | 'InstrBlock's are the insn sequences generated by the insn selectors. --- They are really trees of insns to facilitate fast appending, where a --- left-to-right traversal yields the insns in the correct order. +-- They are really trees of insns to facilitate fast appending, where a +-- left-to-right traversal yields the insns in the correct order. -- -type InstrBlock - = OrdList Instr +type InstrBlock + = OrdList Instr -- | Condition codes passed up the tree. -- -data CondCode - = CondCode Bool Cond InstrBlock +data CondCode + = CondCode Bool Cond InstrBlock -- | a.k.a "Register64" --- Reg is the lower 32-bit temporary which contains the result. --- Use getHiVRegFromLo to find the other VRegUnique. +-- Reg is the lower 32-bit temporary which contains the result. +-- Use getHiVRegFromLo to find the other VRegUnique. -- --- Rules of this simplified insn selection game are therefore that --- the returned Reg may be modified +-- Rules of this simplified insn selection game are therefore that +-- the returned Reg may be modified -- -data ChildCode64 - = ChildCode64 +data ChildCode64 + = ChildCode64 InstrBlock - Reg + Reg -- | Register's passed up the tree. If the stix code forces the register --- to live in a pre-decided machine register, it comes out as @Fixed@; --- otherwise, it comes out as @Any@, and the parent can decide which --- register to put it in. +-- to live in a pre-decided machine register, it comes out as @Fixed@; +-- otherwise, it comes out as @Any@, and the parent can decide which +-- register to put it in. -- data Register - = Fixed Size Reg InstrBlock - | Any Size (Reg -> InstrBlock) + = Fixed Size Reg InstrBlock + | Any Size (Reg -> InstrBlock) swizzleRegisterRep :: Register -> Size -> Register @@ -235,8 +223,8 @@ -- | Memory addressing modes passed up the tree. -data Amode - = Amode AddrMode InstrBlock +data Amode + = Amode AddrMode InstrBlock {- Now, given a tree (the argument to an CmmLoad) that references memory, @@ -258,10 +246,10 @@ -- | Check whether an integer will fit in 32 bits. --- A CmmInt is intended to be truncated to the appropriate --- number of bits, so here we truncate it to Int64. This is --- important because e.g. -1 as a CmmInt might be either --- -1 or 18446744073709551615. +-- A CmmInt is intended to be truncated to the appropriate +-- number of bits, so here we truncate it to Int64. This is +-- important because e.g. -1 as a CmmInt might be either +-- -1 or 18446744073709551615. -- is32BitInteger :: Integer -> Bool is32BitInteger i = i64 <= 0x7fffffff && i64 >= -0x80000000 @@ -271,8 +259,8 @@ -- | Convert a BlockId to some CmmStatic data jumpTableEntry :: Maybe BlockId -> CmmStatic jumpTableEntry Nothing = CmmStaticLit (CmmInt 0 wordWidth) -jumpTableEntry (Just (BlockId id)) = CmmStaticLit (CmmLabel blockLabel) - where blockLabel = mkAsmTempLabel id +jumpTableEntry (Just blockid) = CmmStaticLit (CmmLabel blockLabel) + where blockLabel = mkAsmTempLabel (getUnique blockid) -- ----------------------------------------------------------------------------- @@ -280,32 +268,29 @@ -- Expand CmmRegOff. ToDo: should we do it this way around, or convert -- CmmExprs into CmmRegOff? -mangleIndexTree :: CmmExpr -> CmmExpr -mangleIndexTree (CmmRegOff reg off) +mangleIndexTree :: CmmReg -> Int -> CmmExpr +mangleIndexTree reg off = CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)] where width = typeWidth (cmmRegType reg) -- | The dual to getAnyReg: compute an expression into a register, but --- we don't mind which one it is. +-- we don't mind which one it is. getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock) getSomeReg expr = do r <- getRegister expr case r of Any rep code -> do - tmp <- getNewRegNat rep - return (tmp, code tmp) - Fixed _ reg code -> - return (reg, code) - - - + tmp <- getNewRegNat rep + return (tmp, code tmp) + Fixed _ reg code -> + return (reg, code) assignMem_I64Code :: CmmExpr -> CmmExpr -> NatM InstrBlock assignMem_I64Code addrTree valueTree = do Amode addr addr_code <- getAmode addrTree ChildCode64 vcode rlo <- iselExpr64 valueTree - let + let rhi = getHiVRegFromLo rlo -- Little-endian store @@ -316,9 +301,9 @@ assignReg_I64Code :: CmmReg -> CmmExpr -> NatM InstrBlock -assignReg_I64Code (CmmLocal (LocalReg u_dst pk)) valueTree = do +assignReg_I64Code (CmmLocal (LocalReg u_dst _)) valueTree = do ChildCode64 vcode r_src_lo <- iselExpr64 valueTree - let + let r_dst_lo = RegVirtual $ mkVirtualReg u_dst II32 r_dst_hi = getHiVRegFromLo r_dst_lo r_src_hi = getHiVRegFromLo r_src_lo @@ -329,53 +314,51 @@ vcode `snocOL` mov_lo `snocOL` mov_hi ) -assignReg_I64Code lvalue valueTree +assignReg_I64Code _ _ = panic "assignReg_I64Code(i386): invalid lvalue" - - iselExpr64 :: CmmExpr -> NatM ChildCode64 iselExpr64 (CmmLit (CmmInt i _)) = do (rlo,rhi) <- getNewRegPairNat II32 let - r = fromIntegral (fromIntegral i :: Word32) - q = fromIntegral ((fromIntegral i `shiftR` 32) :: Word32) - code = toOL [ - MOV II32 (OpImm (ImmInteger r)) (OpReg rlo), - MOV II32 (OpImm (ImmInteger q)) (OpReg rhi) - ] + r = fromIntegral (fromIntegral i :: Word32) + q = fromIntegral (fromIntegral (i `shiftR` 32) :: Word32) + code = toOL [ + MOV II32 (OpImm (ImmInteger r)) (OpReg rlo), + MOV II32 (OpImm (ImmInteger q)) (OpReg rhi) + ] -- in return (ChildCode64 code rlo) iselExpr64 (CmmLoad addrTree ty) | isWord64 ty = do Amode addr addr_code <- getAmode addrTree (rlo,rhi) <- getNewRegPairNat II32 - let + let mov_lo = MOV II32 (OpAddr addr) (OpReg rlo) mov_hi = MOV II32 (OpAddr (fromJust (addrOffset addr 4))) (OpReg rhi) -- in return ( - ChildCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi) + ChildCode64 (addr_code `snocOL` mov_lo `snocOL` mov_hi) rlo ) iselExpr64 (CmmReg (CmmLocal (LocalReg vu ty))) | isWord64 ty = return (ChildCode64 nilOL (RegVirtual $ mkVirtualReg vu II32)) - + -- we handle addition, but rather badly iselExpr64 (CmmMachOp (MO_Add _) [e1, CmmLit (CmmInt i _)]) = do ChildCode64 code1 r1lo <- iselExpr64 e1 (rlo,rhi) <- getNewRegPairNat II32 let - r = fromIntegral (fromIntegral i :: Word32) - q = fromIntegral ((fromIntegral i `shiftR` 32) :: Word32) - r1hi = getHiVRegFromLo r1lo - code = code1 `appOL` - toOL [ MOV II32 (OpReg r1lo) (OpReg rlo), - ADD II32 (OpImm (ImmInteger r)) (OpReg rlo), - MOV II32 (OpReg r1hi) (OpReg rhi), - ADC II32 (OpImm (ImmInteger q)) (OpReg rhi) ] + r = fromIntegral (fromIntegral i :: Word32) + q = fromIntegral (fromIntegral (i `shiftR` 32) :: Word32) + r1hi = getHiVRegFromLo r1lo + code = code1 `appOL` + toOL [ MOV II32 (OpReg r1lo) (OpReg rlo), + ADD II32 (OpImm (ImmInteger r)) (OpReg rlo), + MOV II32 (OpReg r1hi) (OpReg rhi), + ADC II32 (OpImm (ImmInteger q)) (OpReg rhi) ] -- in return (ChildCode64 code rlo) @@ -384,14 +367,14 @@ ChildCode64 code2 r2lo <- iselExpr64 e2 (rlo,rhi) <- getNewRegPairNat II32 let - r1hi = getHiVRegFromLo r1lo - r2hi = getHiVRegFromLo r2lo - code = code1 `appOL` - code2 `appOL` - toOL [ MOV II32 (OpReg r1lo) (OpReg rlo), - ADD II32 (OpReg r2lo) (OpReg rlo), - MOV II32 (OpReg r1hi) (OpReg rhi), - ADC II32 (OpReg r2hi) (OpReg rhi) ] + r1hi = getHiVRegFromLo r1lo + r2hi = getHiVRegFromLo r2lo + code = code1 `appOL` + code2 `appOL` + toOL [ MOV II32 (OpReg r1lo) (OpReg rlo), + ADD II32 (OpReg r2lo) (OpReg rlo), + MOV II32 (OpReg r1hi) (OpReg rhi), + ADC II32 (OpReg r2hi) (OpReg rhi) ] -- in return (ChildCode64 code rlo) @@ -401,7 +384,7 @@ let r_dst_hi = getHiVRegFromLo r_dst_lo code = fn r_dst_lo return ( - ChildCode64 (code `snocOL` + ChildCode64 (code `snocOL` MOV II32 (OpImm (ImmInt 0)) (OpReg r_dst_hi)) r_dst_lo ) @@ -410,59 +393,61 @@ = pprPanic "iselExpr64(i386)" (ppr expr) - -------------------------------------------------------------------------------- getRegister :: CmmExpr -> NatM Register +getRegister e = do dflags <- getDynFlagsNat + getRegister' (target32Bit (targetPlatform dflags)) e -#if !x86_64_TARGET_ARCH - -- on x86_64, we have %rip for PicBaseReg, but it's not a full-featured - -- register, it can only be used for rip-relative addressing. -getRegister (CmmReg (CmmGlobal PicBaseReg)) - = do - reg <- getPicBaseNat archWordSize - return (Fixed archWordSize reg nilOL) -#endif - -getRegister (CmmReg reg) - = do use_sse2 <- sse2Enabled - let - sz = cmmTypeSize (cmmRegType reg) - size | not use_sse2 && isFloatSize sz = FF80 - | otherwise = sz - -- - return (Fixed sz (getRegisterReg use_sse2 reg) nilOL) - - -getRegister tree@(CmmRegOff _ _) - = getRegister (mangleIndexTree tree) - - -#if WORD_SIZE_IN_BITS==32 - -- for 32-bit architectuers, support some 64 -> 32 bit conversions: - -- TO_W_(x), TO_W_(x >> 32) +getRegister' :: Bool -> CmmExpr -> NatM Register -getRegister (CmmMachOp (MO_UU_Conv W64 W32) - [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do +getRegister' is32Bit (CmmReg reg) + = case reg of + CmmGlobal PicBaseReg + | is32Bit -> + -- on x86_64, we have %rip for PicBaseReg, but it's not + -- a full-featured register, it can only be used for + -- rip-relative addressing. + do reg' <- getPicBaseNat archWordSize + return (Fixed archWordSize reg' nilOL) + _ -> + do use_sse2 <- sse2Enabled + let + sz = cmmTypeSize (cmmRegType reg) + size | not use_sse2 && isFloatSize sz = FF80 + | otherwise = sz + -- + return (Fixed size (getRegisterReg use_sse2 reg) nilOL) + + +getRegister' is32Bit (CmmRegOff r n) + = getRegister' is32Bit $ mangleIndexTree r n + +-- for 32-bit architectuers, support some 64 -> 32 bit conversions: +-- TO_W_(x), TO_W_(x >> 32) + +getRegister' is32Bit (CmmMachOp (MO_UU_Conv W64 W32) + [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) + | is32Bit = do ChildCode64 code rlo <- iselExpr64 x return $ Fixed II32 (getHiVRegFromLo rlo) code -getRegister (CmmMachOp (MO_SS_Conv W64 W32) - [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) = do +getRegister' is32Bit (CmmMachOp (MO_SS_Conv W64 W32) + [CmmMachOp (MO_U_Shr W64) [x,CmmLit (CmmInt 32 _)]]) + | is32Bit = do ChildCode64 code rlo <- iselExpr64 x return $ Fixed II32 (getHiVRegFromLo rlo) code -getRegister (CmmMachOp (MO_UU_Conv W64 W32) [x]) = do +getRegister' is32Bit (CmmMachOp (MO_UU_Conv W64 W32) [x]) + | is32Bit = do ChildCode64 code rlo <- iselExpr64 x return $ Fixed II32 rlo code -getRegister (CmmMachOp (MO_SS_Conv W64 W32) [x]) = do +getRegister' is32Bit (CmmMachOp (MO_SS_Conv W64 W32) [x]) + | is32Bit = do ChildCode64 code rlo <- iselExpr64 x - return $ Fixed II32 rlo code - -#endif - + return $ Fixed II32 rlo code -getRegister (CmmLit lit@(CmmFloat f w)) = +getRegister' _ (CmmLit lit@(CmmFloat f w)) = if_sse2 float_const_sse2 float_const_x87 where float_const_sse2 @@ -470,8 +455,8 @@ let size = floatSize w code dst = unitOL (XOR size (OpReg dst) (OpReg dst)) - -- I don't know why there are xorpd, xorps, and pxor instructions. - -- They all appear to do the same thing --SDM + -- I don't know why there are xorpd, xorps, and pxor instructions. + -- They all appear to do the same thing --SDM return (Any size code) | otherwise = do @@ -483,72 +468,70 @@ | f == 0.0 -> let code dst = unitOL (GLDZ dst) in return (Any FF80 code) - + | f == 1.0 -> let code dst = unitOL (GLD1 dst) in return (Any FF80 code) - + _otherwise -> do Amode addr code <- memConstant (widthInBytes w) lit loadFloatAmode False w addr code -- catch simple cases of zero- or sign-extended load -getRegister (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad addr _]) = do +getRegister' _ (CmmMachOp (MO_UU_Conv W8 W32) [CmmLoad addr _]) = do code <- intLoadCode (MOVZxL II8) addr return (Any II32 code) -getRegister (CmmMachOp (MO_SS_Conv W8 W32) [CmmLoad addr _]) = do +getRegister' _ (CmmMachOp (MO_SS_Conv W8 W32) [CmmLoad addr _]) = do code <- intLoadCode (MOVSxL II8) addr return (Any II32 code) -getRegister (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad addr _]) = do +getRegister' _ (CmmMachOp (MO_UU_Conv W16 W32) [CmmLoad addr _]) = do code <- intLoadCode (MOVZxL II16) addr return (Any II32 code) -getRegister (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad addr _]) = do +getRegister' _ (CmmMachOp (MO_SS_Conv W16 W32) [CmmLoad addr _]) = do code <- intLoadCode (MOVSxL II16) addr return (Any II32 code) - -#if x86_64_TARGET_ARCH - -- catch simple cases of zero- or sign-extended load -getRegister (CmmMachOp (MO_UU_Conv W8 W64) [CmmLoad addr _]) = do +getRegister' is32Bit (CmmMachOp (MO_UU_Conv W8 W64) [CmmLoad addr _]) + | not is32Bit = do code <- intLoadCode (MOVZxL II8) addr return (Any II64 code) -getRegister (CmmMachOp (MO_SS_Conv W8 W64) [CmmLoad addr _]) = do +getRegister' is32Bit (CmmMachOp (MO_SS_Conv W8 W64) [CmmLoad addr _]) + | not is32Bit = do code <- intLoadCode (MOVSxL II8) addr return (Any II64 code) -getRegister (CmmMachOp (MO_UU_Conv W16 W64) [CmmLoad addr _]) = do +getRegister' is32Bit (CmmMachOp (MO_UU_Conv W16 W64) [CmmLoad addr _]) + | not is32Bit = do code <- intLoadCode (MOVZxL II16) addr return (Any II64 code) -getRegister (CmmMachOp (MO_SS_Conv W16 W64) [CmmLoad addr _]) = do +getRegister' is32Bit (CmmMachOp (MO_SS_Conv W16 W64) [CmmLoad addr _]) + | not is32Bit = do code <- intLoadCode (MOVSxL II16) addr return (Any II64 code) -getRegister (CmmMachOp (MO_UU_Conv W32 W64) [CmmLoad addr _]) = do +getRegister' is32Bit (CmmMachOp (MO_UU_Conv W32 W64) [CmmLoad addr _]) + | not is32Bit = do code <- intLoadCode (MOV II32) addr -- 32-bit loads zero-extend return (Any II64 code) -getRegister (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad addr _]) = do +getRegister' is32Bit (CmmMachOp (MO_SS_Conv W32 W64) [CmmLoad addr _]) + | not is32Bit = do code <- intLoadCode (MOVSxL II32) addr return (Any II64 code) -getRegister (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg), +getRegister' is32Bit (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg), CmmLit displacement]) - = return $ Any II64 (\dst -> unitOL $ + | not is32Bit = do + return $ Any II64 (\dst -> unitOL $ LEA II64 (OpAddr (ripRel (litToImm displacement))) (OpReg dst)) -#endif /* x86_64_TARGET_ARCH */ - - - - - -getRegister (CmmMachOp mop [x]) = do -- unary MachOps +getRegister' is32Bit (CmmMachOp mop [x]) = do -- unary MachOps sse2 <- sse2Enabled case mop of MO_F_Neg w @@ -566,14 +549,12 @@ MO_UU_Conv W32 W16 -> toI16Reg W32 x MO_SS_Conv W32 W16 -> toI16Reg W32 x -#if x86_64_TARGET_ARCH - MO_UU_Conv W64 W32 -> conversionNop II64 x - MO_SS_Conv W64 W32 -> conversionNop II64 x - MO_UU_Conv W64 W16 -> toI16Reg W64 x - MO_SS_Conv W64 W16 -> toI16Reg W64 x - MO_UU_Conv W64 W8 -> toI8Reg W64 x - MO_SS_Conv W64 W8 -> toI8Reg W64 x -#endif + MO_UU_Conv W64 W32 | not is32Bit -> conversionNop II64 x + MO_SS_Conv W64 W32 | not is32Bit -> conversionNop II64 x + MO_UU_Conv W64 W16 | not is32Bit -> toI16Reg W64 x + MO_SS_Conv W64 W16 | not is32Bit -> toI16Reg W64 x + MO_UU_Conv W64 W8 | not is32Bit -> toI8Reg W64 x + MO_SS_Conv W64 W8 | not is32Bit -> toI8Reg W64 x MO_UU_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intSize rep1) x MO_SS_Conv rep1 rep2 | rep1 == rep2 -> conversionNop (intSize rep1) x @@ -587,98 +568,94 @@ MO_SS_Conv W16 W32 -> integerExtend W16 W32 MOVSxL x MO_SS_Conv W8 W16 -> integerExtend W8 W16 MOVSxL x -#if x86_64_TARGET_ARCH - MO_UU_Conv W8 W64 -> integerExtend W8 W64 MOVZxL x - MO_UU_Conv W16 W64 -> integerExtend W16 W64 MOVZxL x - MO_UU_Conv W32 W64 -> integerExtend W32 W64 MOVZxL x - MO_SS_Conv W8 W64 -> integerExtend W8 W64 MOVSxL x - MO_SS_Conv W16 W64 -> integerExtend W16 W64 MOVSxL x - MO_SS_Conv W32 W64 -> integerExtend W32 W64 MOVSxL x - -- for 32-to-64 bit zero extension, amd64 uses an ordinary movl. - -- However, we don't want the register allocator to throw it - -- away as an unnecessary reg-to-reg move, so we keep it in - -- the form of a movzl and print it as a movl later. -#endif + MO_UU_Conv W8 W64 | not is32Bit -> integerExtend W8 W64 MOVZxL x + MO_UU_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOVZxL x + MO_UU_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOVZxL x + MO_SS_Conv W8 W64 | not is32Bit -> integerExtend W8 W64 MOVSxL x + MO_SS_Conv W16 W64 | not is32Bit -> integerExtend W16 W64 MOVSxL x + MO_SS_Conv W32 W64 | not is32Bit -> integerExtend W32 W64 MOVSxL x + -- for 32-to-64 bit zero extension, amd64 uses an ordinary movl. + -- However, we don't want the register allocator to throw it + -- away as an unnecessary reg-to-reg move, so we keep it in + -- the form of a movzl and print it as a movl later. MO_FF_Conv W32 W64 | sse2 -> coerceFP2FP W64 x - | otherwise -> conversionNop FF80 x + | otherwise -> conversionNop FF80 x - MO_FF_Conv W64 W32 - | sse2 -> coerceFP2FP W32 x - | otherwise -> conversionNop FF80 x + MO_FF_Conv W64 W32 -> coerceFP2FP W32 x MO_FS_Conv from to -> coerceFP2Int from to x MO_SF_Conv from to -> coerceInt2FP from to x - other -> pprPanic "getRegister" (pprMachOp mop) + _other -> pprPanic "getRegister" (pprMachOp mop) where - triv_ucode :: (Size -> Operand -> Instr) -> Size -> NatM Register - triv_ucode instr size = trivialUCode size (instr size) x + triv_ucode :: (Size -> Operand -> Instr) -> Size -> NatM Register + triv_ucode instr size = trivialUCode size (instr size) x - -- signed or unsigned extension. - integerExtend :: Width -> Width - -> (Size -> Operand -> Operand -> Instr) - -> CmmExpr -> NatM Register - integerExtend from to instr expr = do - (reg,e_code) <- if from == W8 then getByteReg expr - else getSomeReg expr - let - code dst = - e_code `snocOL` - instr (intSize from) (OpReg reg) (OpReg dst) - return (Any (intSize to) code) + -- signed or unsigned extension. + integerExtend :: Width -> Width + -> (Size -> Operand -> Operand -> Instr) + -> CmmExpr -> NatM Register + integerExtend from to instr expr = do + (reg,e_code) <- if from == W8 then getByteReg expr + else getSomeReg expr + let + code dst = + e_code `snocOL` + instr (intSize from) (OpReg reg) (OpReg dst) + return (Any (intSize to) code) - toI8Reg :: Width -> CmmExpr -> NatM Register - toI8Reg new_rep expr + toI8Reg :: Width -> CmmExpr -> NatM Register + toI8Reg new_rep expr = do codefn <- getAnyReg expr - return (Any (intSize new_rep) codefn) - -- HACK: use getAnyReg to get a byte-addressable register. - -- If the source was a Fixed register, this will add the - -- mov instruction to put it into the desired destination. - -- We're assuming that the destination won't be a fixed - -- non-byte-addressable register; it won't be, because all - -- fixed registers are word-sized. + return (Any (intSize new_rep) codefn) + -- HACK: use getAnyReg to get a byte-addressable register. + -- If the source was a Fixed register, this will add the + -- mov instruction to put it into the desired destination. + -- We're assuming that the destination won't be a fixed + -- non-byte-addressable register; it won't be, because all + -- fixed registers are word-sized. - toI16Reg = toI8Reg -- for now + toI16Reg = toI8Reg -- for now - conversionNop :: Size -> CmmExpr -> NatM Register + conversionNop :: Size -> CmmExpr -> NatM Register conversionNop new_size expr - = do e_code <- getRegister expr + = do e_code <- getRegister' is32Bit expr return (swizzleRegisterRep e_code new_size) -getRegister e@(CmmMachOp mop [x, y]) = do -- dyadic MachOps +getRegister' _ (CmmMachOp mop [x, y]) = do -- dyadic MachOps sse2 <- sse2Enabled case mop of - MO_F_Eq w -> condFltReg EQQ x y - MO_F_Ne w -> condFltReg NE x y - MO_F_Gt w -> condFltReg GTT x y - MO_F_Ge w -> condFltReg GE x y - MO_F_Lt w -> condFltReg LTT x y - MO_F_Le w -> condFltReg LE x y - - MO_Eq rep -> condIntReg EQQ x y - MO_Ne rep -> condIntReg NE x y - - MO_S_Gt rep -> condIntReg GTT x y - MO_S_Ge rep -> condIntReg GE x y - MO_S_Lt rep -> condIntReg LTT x y - MO_S_Le rep -> condIntReg LE x y - - MO_U_Gt rep -> condIntReg GU x y - MO_U_Ge rep -> condIntReg GEU x y - MO_U_Lt rep -> condIntReg LU x y - MO_U_Le rep -> condIntReg LEU x y + MO_F_Eq _ -> condFltReg EQQ x y + MO_F_Ne _ -> condFltReg NE x y + MO_F_Gt _ -> condFltReg GTT x y + MO_F_Ge _ -> condFltReg GE x y + MO_F_Lt _ -> condFltReg LTT x y + MO_F_Le _ -> condFltReg LE x y + + MO_Eq _ -> condIntReg EQQ x y + MO_Ne _ -> condIntReg NE x y + + MO_S_Gt _ -> condIntReg GTT x y + MO_S_Ge _ -> condIntReg GE x y + MO_S_Lt _ -> condIntReg LTT x y + MO_S_Le _ -> condIntReg LE x y + + MO_U_Gt _ -> condIntReg GU x y + MO_U_Ge _ -> condIntReg GEU x y + MO_U_Lt _ -> condIntReg LU x y + MO_U_Le _ -> condIntReg LEU x y MO_F_Add w | sse2 -> trivialFCode_sse2 w ADD x y - | otherwise -> trivialFCode_x87 w GADD x y + | otherwise -> trivialFCode_x87 GADD x y MO_F_Sub w | sse2 -> trivialFCode_sse2 w SUB x y - | otherwise -> trivialFCode_x87 w GSUB x y + | otherwise -> trivialFCode_x87 GSUB x y MO_F_Quot w | sse2 -> trivialFCode_sse2 w FDIV x y - | otherwise -> trivialFCode_x87 w GDIV x y + | otherwise -> trivialFCode_x87 GDIV x y MO_F_Mul w | sse2 -> trivialFCode_sse2 w MUL x y - | otherwise -> trivialFCode_x87 w GMUL x y + | otherwise -> trivialFCode_x87 GMUL x y MO_Add rep -> add_code rep x y MO_Sub rep -> sub_code rep x y @@ -695,66 +672,66 @@ MO_Or rep -> triv_op rep OR MO_Xor rep -> triv_op rep XOR - {- Shift ops on x86s have constraints on their source, it - either has to be Imm, CL or 1 - => trivialCode is not restrictive enough (sigh.) - -} + {- Shift ops on x86s have constraints on their source, it + either has to be Imm, CL or 1 + => trivialCode is not restrictive enough (sigh.) + -} MO_Shl rep -> shift_code rep SHL x y {-False-} MO_U_Shr rep -> shift_code rep SHR x y {-False-} MO_S_Shr rep -> shift_code rep SAR x y {-False-} - other -> pprPanic "getRegister(x86) - binary CmmMachOp (1)" (pprMachOp mop) + _other -> pprPanic "getRegister(x86) - binary CmmMachOp (1)" (pprMachOp mop) where -------------------- triv_op width instr = trivialCode width op (Just op) x y - where op = instr (intSize width) + where op = instr (intSize width) imulMayOflo :: Width -> CmmExpr -> CmmExpr -> NatM Register imulMayOflo rep a b = do (a_reg, a_code) <- getNonClobberedReg a b_code <- getAnyReg b - let - shift_amt = case rep of - W32 -> 31 - W64 -> 63 - _ -> panic "shift_amt" + let + shift_amt = case rep of + W32 -> 31 + W64 -> 63 + _ -> panic "shift_amt" - size = intSize rep + size = intSize rep code = a_code `appOL` b_code eax `appOL` toOL [ - IMUL2 size (OpReg a_reg), -- result in %edx:%eax + IMUL2 size (OpReg a_reg), -- result in %edx:%eax SAR size (OpImm (ImmInt shift_amt)) (OpReg eax), - -- sign extend lower part + -- sign extend lower part SUB size (OpReg edx) (OpReg eax) - -- compare against upper + -- compare against upper -- eax==0 if high part == sign extended low part ] -- in - return (Fixed size eax code) + return (Fixed size eax code) -------------------- shift_code :: Width - -> (Size -> Operand -> Operand -> Instr) - -> CmmExpr - -> CmmExpr - -> NatM Register + -> (Size -> Operand -> Operand -> Instr) + -> CmmExpr + -> CmmExpr + -> NatM Register {- Case1: shift length as immediate -} - shift_code width instr x y@(CmmLit lit) = do - x_code <- getAnyReg x - let - size = intSize width - code dst - = x_code dst `snocOL` - instr size (OpImm (litToImm lit)) (OpReg dst) - -- in - return (Any size code) - + shift_code width instr x (CmmLit lit) = do + x_code <- getAnyReg x + let + size = intSize width + code dst + = x_code dst `snocOL` + instr size (OpImm (litToImm lit)) (OpReg dst) + -- in + return (Any size code) + {- Case2: shift length is complex (non-immediate) * y must go in %ecx. * we cannot do y first *and* put its result in %ecx, because %ecx might be clobbered by x. - * if we do y second, then x cannot be + * if we do y second, then x cannot be in a clobbered reg. Also, we cannot clobber x's reg with the instruction itself. * so we can either: @@ -766,143 +743,137 @@ -} shift_code width instr x y{-amount-} = do x_code <- getAnyReg x - let size = intSize width - tmp <- getNewRegNat size + let size = intSize width + tmp <- getNewRegNat size y_code <- getAnyReg y - let - code = x_code tmp `appOL` - y_code ecx `snocOL` - instr size (OpReg ecx) (OpReg tmp) + let + code = x_code tmp `appOL` + y_code ecx `snocOL` + instr size (OpReg ecx) (OpReg tmp) -- in return (Fixed size tmp code) -------------------- add_code :: Width -> CmmExpr -> CmmExpr -> NatM Register add_code rep x (CmmLit (CmmInt y _)) - | is32BitInteger y = add_int rep x y + | is32BitInteger y = add_int rep x y add_code rep x y = trivialCode rep (ADD size) (Just (ADD size)) x y where size = intSize rep -------------------- sub_code :: Width -> CmmExpr -> CmmExpr -> NatM Register sub_code rep x (CmmLit (CmmInt y _)) - | is32BitInteger (-y) = add_int rep x (-y) + | is32BitInteger (-y) = add_int rep x (-y) sub_code rep x y = trivialCode rep (SUB (intSize rep)) Nothing x y -- our three-operand add instruction: add_int width x y = do - (x_reg, x_code) <- getSomeReg x - let - size = intSize width - imm = ImmInt (fromInteger y) - code dst + (x_reg, x_code) <- getSomeReg x + let + size = intSize width + imm = ImmInt (fromInteger y) + code dst = x_code `snocOL` - LEA size - (OpAddr (AddrBaseIndex (EABaseReg x_reg) EAIndexNone imm)) + LEA size + (OpAddr (AddrBaseIndex (EABaseReg x_reg) EAIndexNone imm)) (OpReg dst) - -- - return (Any size code) + -- + return (Any size code) ---------------------- div_code width signed quotient x y = do - (y_op, y_code) <- getRegOrMem y -- cannot be clobbered - x_code <- getAnyReg x - let - size = intSize width - widen | signed = CLTD size - | otherwise = XOR size (OpReg edx) (OpReg edx) - - instr | signed = IDIV - | otherwise = DIV - - code = y_code `appOL` - x_code eax `appOL` - toOL [widen, instr size y_op] + (y_op, y_code) <- getRegOrMem y -- cannot be clobbered + x_code <- getAnyReg x + let + size = intSize width + widen | signed = CLTD size + | otherwise = XOR size (OpReg edx) (OpReg edx) + + instr | signed = IDIV + | otherwise = DIV + + code = y_code `appOL` + x_code eax `appOL` + toOL [widen, instr size y_op] - result | quotient = eax - | otherwise = edx + result | quotient = eax + | otherwise = edx - -- in + -- in return (Fixed size result code) -getRegister (CmmLoad mem pk) +getRegister' _ (CmmLoad mem pk) | isFloatType pk = do Amode addr mem_code <- getAmode mem use_sse2 <- sse2Enabled loadFloatAmode use_sse2 (typeWidth pk) addr mem_code -#if i386_TARGET_ARCH -getRegister (CmmLoad mem pk) - | not (isWord64 pk) - = do +getRegister' is32Bit (CmmLoad mem pk) + | is32Bit && not (isWord64 pk) + = do code <- intLoadCode instr mem return (Any size code) where width = typeWidth pk size = intSize width instr = case width of - W8 -> MOVZxL II8 - _other -> MOV size - -- We always zero-extend 8-bit loads, if we - -- can't think of anything better. This is because - -- we can't guarantee access to an 8-bit variant of every register - -- (esi and edi don't have 8-bit variants), so to make things - -- simpler we do our 8-bit arithmetic with full 32-bit registers. -#endif + W8 -> MOVZxL II8 + _other -> MOV size + -- We always zero-extend 8-bit loads, if we + -- can't think of anything better. This is because + -- we can't guarantee access to an 8-bit variant of every register + -- (esi and edi don't have 8-bit variants), so to make things + -- simpler we do our 8-bit arithmetic with full 32-bit registers. -#if x86_64_TARGET_ARCH -- Simpler memory load code on x86_64 -getRegister (CmmLoad mem pk) - = do +getRegister' is32Bit (CmmLoad mem pk) + | not is32Bit + = do code <- intLoadCode (MOV size) mem return (Any size code) where size = intSize $ typeWidth pk -#endif -getRegister (CmmLit (CmmInt 0 width)) +getRegister' _ (CmmLit (CmmInt 0 width)) = let - size = intSize width + size = intSize width - -- x86_64: 32-bit xor is one byte shorter, and zero-extends to 64 bits - adj_size = case size of II64 -> II32; _ -> size - size1 = IF_ARCH_i386( size, adj_size ) - code dst + -- x86_64: 32-bit xor is one byte shorter, and zero-extends to 64 bits + size1 = IF_ARCH_i386( size, case size of II64 -> II32; _ -> size ) + code dst = unitOL (XOR size1 (OpReg dst) (OpReg dst)) in - return (Any size code) + return (Any size code) -#if x86_64_TARGET_ARCH -- optimisation for loading small literals on x86_64: take advantage -- of the automatic zero-extension from 32 to 64 bits, because the 32-bit -- instruction forms are shorter. -getRegister (CmmLit lit) - | isWord64 (cmmLitType lit), not (isBigLit lit) - = let - imm = litToImm lit - code dst = unitOL (MOV II32 (OpImm imm) (OpReg dst)) +getRegister' is32Bit (CmmLit lit) + | not is32Bit, isWord64 (cmmLitType lit), not (isBigLit lit) + = let + imm = litToImm lit + code dst = unitOL (MOV II32 (OpImm imm) (OpReg dst)) in - return (Any II64 code) + return (Any II64 code) where isBigLit (CmmInt i _) = i < 0 || i > 0xffffffff isBigLit _ = False - -- note1: not the same as (not.is32BitLit), because that checks for - -- signed literals that fit in 32 bits, but we want unsigned - -- literals here. - -- note2: all labels are small, because we're assuming the - -- small memory model (see gcc docs, -mcmodel=small). -#endif + -- note1: not the same as (not.is32BitLit), because that checks for + -- signed literals that fit in 32 bits, but we want unsigned + -- literals here. + -- note2: all labels are small, because we're assuming the + -- small memory model (see gcc docs, -mcmodel=small). -getRegister (CmmLit lit) - = let - size = cmmTypeSize (cmmLitType lit) - imm = litToImm lit - code dst = unitOL (MOV size (OpImm imm) (OpReg dst)) +getRegister' _ (CmmLit lit) + = let + size = cmmTypeSize (cmmLitType lit) + imm = litToImm lit + code dst = unitOL (MOV size (OpImm imm) (OpReg dst)) in - return (Any size code) + return (Any size code) -getRegister other = pprPanic "getRegister(x86)" (ppr other) +getRegister' _ other = pprPanic "getRegister(x86)" (ppr other) intLoadCode :: (Operand -> Operand -> Instr) -> CmmExpr @@ -926,23 +897,23 @@ -- Fixed registers might not be byte-addressable, so we make sure we've -- got a temporary, inserting an extra reg copy if necessary. getByteReg :: CmmExpr -> NatM (Reg, InstrBlock) -#if x86_64_TARGET_ARCH -getByteReg = getSomeReg -- all regs are byte-addressable on x86_64 -#else getByteReg expr = do - r <- getRegister expr - case r of - Any rep code -> do - tmp <- getNewRegNat rep - return (tmp, code tmp) - Fixed rep reg code - | isVirtualReg reg -> return (reg,code) - | otherwise -> do - tmp <- getNewRegNat rep - return (tmp, code `snocOL` reg2reg rep reg tmp) - -- ToDo: could optimise slightly by checking for byte-addressable - -- real registers, but that will happen very rarely if at all. -#endif + dflags <- getDynFlagsNat + if target32Bit (targetPlatform dflags) + then do r <- getRegister expr + case r of + Any rep code -> do + tmp <- getNewRegNat rep + return (tmp, code tmp) + Fixed rep reg code + | isVirtualReg reg -> return (reg,code) + | otherwise -> do + tmp <- getNewRegNat rep + return (tmp, code `snocOL` reg2reg rep reg tmp) + -- ToDo: could optimise slightly by checking for + -- byte-addressable real registers, but that will + -- happen very rarely if at all. + else getSomeReg expr -- all regs are byte-addressable on x86_64 -- Another variant: this time we want the result in a register that cannot -- be modified by code to evaluate an arbitrary expression. @@ -951,65 +922,66 @@ r <- getRegister expr case r of Any rep code -> do - tmp <- getNewRegNat rep - return (tmp, code tmp) + tmp <- getNewRegNat rep + return (tmp, code tmp) Fixed rep reg code - -- only free regs can be clobbered - | RegReal (RealRegSingle rr) <- reg - , isFastTrue (freeReg rr) - -> do - tmp <- getNewRegNat rep - return (tmp, code `snocOL` reg2reg rep reg tmp) - | otherwise -> - return (reg, code) + -- only free regs can be clobbered + | RegReal (RealRegSingle rr) <- reg + , isFastTrue (freeReg rr) + -> do + tmp <- getNewRegNat rep + return (tmp, code `snocOL` reg2reg rep reg tmp) + | otherwise -> + return (reg, code) reg2reg :: Size -> Reg -> Reg -> Instr -reg2reg size src dst +reg2reg size src dst | size == FF80 = GMOV src dst - | otherwise = MOV size (OpReg src) (OpReg dst) + | otherwise = MOV size (OpReg src) (OpReg dst) -------------------------------------------------------------------------------- getAmode :: CmmExpr -> NatM Amode -getAmode tree@(CmmRegOff _ _) = getAmode (mangleIndexTree tree) +getAmode e = do dflags <- getDynFlagsNat + getAmode' (target32Bit (targetPlatform dflags)) e -#if x86_64_TARGET_ARCH +getAmode' :: Bool -> CmmExpr -> NatM Amode +getAmode' _ (CmmRegOff r n) = getAmode $ mangleIndexTree r n -getAmode (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg), - CmmLit displacement]) +getAmode' is32Bit (CmmMachOp (MO_Add W64) [CmmReg (CmmGlobal PicBaseReg), + CmmLit displacement]) + | not is32Bit = return $ Amode (ripRel (litToImm displacement)) nilOL -#endif - --- This is all just ridiculous, since it carefully undoes +-- This is all just ridiculous, since it carefully undoes -- what mangleIndexTree has just done. -getAmode (CmmMachOp (MO_Sub rep) [x, CmmLit lit@(CmmInt i _)]) +getAmode' _ (CmmMachOp (MO_Sub _rep) [x, CmmLit lit@(CmmInt i _)]) | is32BitLit lit -- ASSERT(rep == II32)??? = do (x_reg, x_code) <- getSomeReg x let off = ImmInt (-(fromInteger i)) return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code) - -getAmode (CmmMachOp (MO_Add rep) [x, CmmLit lit]) + +getAmode' _ (CmmMachOp (MO_Add _rep) [x, CmmLit lit]) | is32BitLit lit -- ASSERT(rep == II32)??? = do (x_reg, x_code) <- getSomeReg x let off = litToImm lit return (Amode (AddrBaseIndex (EABaseReg x_reg) EAIndexNone off) x_code) --- Turn (lit1 << n + lit2) into (lit2 + lit1 << n) so it will be +-- Turn (lit1 << n + lit2) into (lit2 + lit1 << n) so it will be -- recognised by the next rule. -getAmode (CmmMachOp (MO_Add rep) [a@(CmmMachOp (MO_Shl _) _), - b@(CmmLit _)]) - = getAmode (CmmMachOp (MO_Add rep) [b,a]) +getAmode' is32Bit (CmmMachOp (MO_Add rep) [a@(CmmMachOp (MO_Shl _) _), + b@(CmmLit _)]) + = getAmode' is32Bit (CmmMachOp (MO_Add rep) [b,a]) -getAmode (CmmMachOp (MO_Add rep) [x, CmmMachOp (MO_Shl _) - [y, CmmLit (CmmInt shift _)]]) +getAmode' _ (CmmMachOp (MO_Add _) [x, CmmMachOp (MO_Shl _) + [y, CmmLit (CmmInt shift _)]]) | shift == 0 || shift == 1 || shift == 2 || shift == 3 = x86_complex_amode x y shift 0 -getAmode (CmmMachOp (MO_Add rep) +getAmode' _ (CmmMachOp (MO_Add _) [x, CmmMachOp (MO_Add _) [CmmMachOp (MO_Shl _) [y, CmmLit (CmmInt shift _)], CmmLit (CmmInt offset _)]]) @@ -1017,13 +989,13 @@ && is32BitInteger offset = x86_complex_amode x y shift offset -getAmode (CmmMachOp (MO_Add rep) [x,y]) +getAmode' _ (CmmMachOp (MO_Add _) [x,y]) = x86_complex_amode x y 0 0 -getAmode (CmmLit lit) | is32BitLit lit +getAmode' _ (CmmLit lit) | is32BitLit lit = return (Amode (ImmAddr (litToImm lit) 0) nilOL) -getAmode expr = do +getAmode' _ expr = do (reg,code) <- getSomeReg expr return (Amode (AddrBaseIndex (EABaseReg reg) EAIndexNone (ImmInt 0)) code) @@ -1031,12 +1003,13 @@ x86_complex_amode :: CmmExpr -> CmmExpr -> Integer -> Integer -> NatM Amode x86_complex_amode base index shift offset = do (x_reg, x_code) <- getNonClobberedReg base - -- x must be in a temp, because it has to stay live over y_code - -- we could compre x_reg and y_reg and do something better here... + -- x must be in a temp, because it has to stay live over y_code + -- we could compre x_reg and y_reg and do something better here... (y_reg, y_code) <- getSomeReg index let - code = x_code `appOL` y_code - base = case shift of 0 -> 1; 1 -> 2; 2 -> 4; 3 -> 8 + code = x_code `appOL` y_code + base = case shift of 0 -> 1; 1 -> 2; 2 -> 4; 3 -> 8; + n -> panic $ "x86_complex_amode: unhandled shift! (" ++ show n ++ ")" return (Amode (AddrBaseIndex (EABaseReg x_reg) (EAIndex y_reg base) (ImmInt (fromIntegral offset))) code) @@ -1071,14 +1044,14 @@ && IF_ARCH_i386(not (isWord64 pk), True) then do Amode src mem_code <- getAmode mem - (src',save_code) <- - if (amodeCouldBeClobbered src) - then do - tmp <- getNewRegNat archWordSize - return (AddrBaseIndex (EABaseReg tmp) EAIndexNone (ImmInt 0), - unitOL (LEA II32 (OpAddr src) (OpReg tmp))) - else - return (src, nilOL) + (src',save_code) <- + if (amodeCouldBeClobbered src) + then do + tmp <- getNewRegNat archWordSize + return (AddrBaseIndex (EABaseReg tmp) EAIndexNone (ImmInt 0), + unitOL (LEA II32 (OpAddr src) (OpReg tmp))) + else + return (src, nilOL) return (OpAddr src', save_code `appOL` mem_code) else do getNonClobberedOperand_generic (CmmLoad mem pk) @@ -1093,6 +1066,7 @@ amodeCouldBeClobbered :: AddrMode -> Bool amodeCouldBeClobbered amode = any regClobbered (addrModeRegs amode) +regClobbered :: Reg -> Bool regClobbered (RegReal (RealRegSingle rr)) = isFastTrue (freeReg rr) regClobbered _ = False @@ -1124,6 +1098,7 @@ getOperand e = getOperand_generic e +getOperand_generic :: CmmExpr -> NatM (Operand, InstrBlock) getOperand_generic e = do (reg, code) <- getSomeReg e return (OpReg reg, code) @@ -1131,26 +1106,24 @@ isOperand :: CmmExpr -> Bool isOperand (CmmLoad _ _) = True isOperand (CmmLit lit) = is32BitLit lit - || isSuitableFloatingPointLit lit + || isSuitableFloatingPointLit lit isOperand _ = False memConstant :: Int -> CmmLit -> NatM Amode memConstant align lit = do -#ifdef x86_64_TARGET_ARCH - lbl <- getNewLabelNat - let addr = ripRel (ImmCLbl lbl) - addr_code = nilOL -#else lbl <- getNewLabelNat dflags <- getDynFlagsNat - dynRef <- cmmMakeDynamicReference dflags addImportNat DataReference lbl - Amode addr addr_code <- getAmode dynRef -#endif + (addr, addr_code) <- if target32Bit (targetPlatform dflags) + then do dynRef <- cmmMakeDynamicReference + dflags + addImportNat + DataReference + lbl + Amode addr addr_code <- getAmode dynRef + return (addr, addr_code) + else return (ripRel (ImmCLbl lbl), nilOL) let code = - LDATA ReadOnlyData - [CmmAlign align, - CmmDataLabel lbl, - CmmStaticLit lit] + LDATA ReadOnlyData (align, Statics lbl [CmmStaticLit lit]) `consOL` addr_code return (Amode addr code) @@ -1170,6 +1143,7 @@ -- use it directly from memory. However, if the literal is -- zero, we're better off generating it into a register using -- xor. +isSuitableFloatingPointLit :: CmmLit -> Bool isSuitableFloatingPointLit (CmmFloat f _) = f /= 0.0 isSuitableFloatingPointLit _ = False @@ -1187,12 +1161,13 @@ (reg, code) <- getNonClobberedReg e return (OpReg reg, code) +is32BitLit :: CmmLit -> Bool #if x86_64_TARGET_ARCH is32BitLit (CmmInt i W64) = is32BitInteger i -- assume that labels are in the range 0-2^31-1: this assumes the -- small memory model (see gcc docs, -mcmodel=small). #endif -is32BitLit x = True +is32BitLit _ = True @@ -1204,7 +1179,7 @@ -- yes, they really do seem to want exactly the same! getCondCode (CmmMachOp mop [x, y]) - = + = case mop of MO_F_Eq W32 -> condFltCode EQQ x y MO_F_Ne W32 -> condFltCode NE x y @@ -1220,20 +1195,20 @@ MO_F_Lt W64 -> condFltCode LTT x y MO_F_Le W64 -> condFltCode LE x y - MO_Eq rep -> condIntCode EQQ x y - MO_Ne rep -> condIntCode NE x y + MO_Eq _ -> condIntCode EQQ x y + MO_Ne _ -> condIntCode NE x y - MO_S_Gt rep -> condIntCode GTT x y - MO_S_Ge rep -> condIntCode GE x y - MO_S_Lt rep -> condIntCode LTT x y - MO_S_Le rep -> condIntCode LE x y - - MO_U_Gt rep -> condIntCode GU x y - MO_U_Ge rep -> condIntCode GEU x y - MO_U_Lt rep -> condIntCode LU x y - MO_U_Le rep -> condIntCode LEU x y + MO_S_Gt _ -> condIntCode GTT x y + MO_S_Ge _ -> condIntCode GE x y + MO_S_Lt _ -> condIntCode LTT x y + MO_S_Le _ -> condIntCode LE x y + + MO_U_Gt _ -> condIntCode GU x y + MO_U_Ge _ -> condIntCode GEU x y + MO_U_Lt _ -> condIntCode LU x y + MO_U_Le _ -> condIntCode LEU x y - other -> pprPanic "getCondCode(x86,x86_64,sparc)" (ppr (CmmMachOp mop [x,y])) + _other -> pprPanic "getCondCode(x86,x86_64,sparc)" (ppr (CmmMachOp mop [x,y])) getCondCode other = pprPanic "getCondCode(2)(x86,sparc)" (ppr other) @@ -1249,16 +1224,16 @@ condIntCode cond (CmmLoad x pk) (CmmLit lit) | is32BitLit lit = do Amode x_addr x_code <- getAmode x let - imm = litToImm lit - code = x_code `snocOL` - CMP (cmmTypeSize pk) (OpImm imm) (OpAddr x_addr) + imm = litToImm lit + code = x_code `snocOL` + CMP (cmmTypeSize pk) (OpImm imm) (OpAddr x_addr) -- return (CondCode False cond code) -- anything vs zero, using a mask -- TODO: Add some sanity checking!!!! -condIntCode cond (CmmMachOp (MO_And rep) [x,o2]) (CmmLit (CmmInt 0 pk)) - | (CmmLit lit@(CmmInt mask pk2)) <- o2, is32BitLit lit +condIntCode cond (CmmMachOp (MO_And _) [x,o2]) (CmmLit (CmmInt 0 pk)) + | (CmmLit lit@(CmmInt mask _)) <- o2, is32BitLit lit = do (x_reg, x_code) <- getSomeReg x let @@ -1271,17 +1246,17 @@ condIntCode cond x (CmmLit (CmmInt 0 pk)) = do (x_reg, x_code) <- getSomeReg x let - code = x_code `snocOL` - TEST (intSize pk) (OpReg x_reg) (OpReg x_reg) + code = x_code `snocOL` + TEST (intSize pk) (OpReg x_reg) (OpReg x_reg) -- return (CondCode False cond code) -- anything vs operand condIntCode cond x y | isOperand y = do (x_reg, x_code) <- getNonClobberedReg x - (y_op, y_code) <- getOperand y + (y_op, y_code) <- getOperand y let - code = x_code `appOL` y_code `snocOL` + code = x_code `appOL` y_code `snocOL` CMP (cmmTypeSize (cmmExprType x)) y_op (OpReg x_reg) -- in return (CondCode False cond code) @@ -1291,9 +1266,9 @@ (y_reg, y_code) <- getNonClobberedReg y (x_op, x_code) <- getRegOrMem x let - code = y_code `appOL` - x_code `snocOL` - CMP (cmmTypeSize (cmmExprType x)) (OpReg y_reg) x_op + code = y_code `appOL` + x_code `snocOL` + CMP (cmmTypeSize (cmmExprType x)) (OpReg y_reg) x_op -- in return (CondCode False cond code) @@ -1302,7 +1277,7 @@ -------------------------------------------------------------------------------- condFltCode :: Cond -> CmmExpr -> CmmExpr -> NatM CondCode -condFltCode cond x y +condFltCode cond x y = if_sse2 condFltCode_sse2 condFltCode_x87 where @@ -1310,14 +1285,13 @@ = ASSERT(cond `elem` ([EQQ, NE, LE, LTT, GE, GTT])) do (x_reg, x_code) <- getNonClobberedReg x (y_reg, y_code) <- getSomeReg y - use_sse2 <- sse2Enabled let - code = x_code `appOL` y_code `snocOL` - GCMP cond x_reg y_reg + code = x_code `appOL` y_code `snocOL` + GCMP cond x_reg y_reg -- The GCMP insn does the test and sets the zero flag if comparable -- and true. Hence we always supply EQQ as the condition to test. return (CondCode True EQQ code) - + -- in the SSE2 comparison ops (ucomiss, ucomisd) the left arg may be -- an operand, but the right must be a reg. We can probably do better -- than this general case... @@ -1325,11 +1299,11 @@ (x_reg, x_code) <- getNonClobberedReg x (y_op, y_code) <- getOperand y let - code = x_code `appOL` - y_code `snocOL` - CMP (floatSize $ cmmExprWidth x) y_op (OpReg x_reg) - -- NB(1): we need to use the unsigned comparison operators on the - -- result of this comparison. + code = x_code `appOL` + y_code `snocOL` + CMP (floatSize $ cmmExprWidth x) y_op (OpReg x_reg) + -- NB(1): we need to use the unsigned comparison operators on the + -- result of this comparison. -- in return (CondCode True (condToUnsigned cond) code) @@ -1355,7 +1329,7 @@ -- integer assignment to memory -- specific case of adding/subtracting an integer to a particular address. --- ToDo: catch other cases where we can use an operation directly on a memory +-- ToDo: catch other cases where we can use an operation directly on a memory -- address. assignMem_IntCode pk addr (CmmMachOp op [CmmLoad addr2 _, CmmLit (CmmInt i _)]) @@ -1376,22 +1350,22 @@ Amode addr code_addr <- getAmode addr (code_src, op_src) <- get_op_RI src let - code = code_src `appOL` - code_addr `snocOL` + code = code_src `appOL` + code_addr `snocOL` MOV pk op_src (OpAddr addr) - -- NOTE: op_src is stable, so it will still be valid - -- after code_addr. This may involve the introduction - -- of an extra MOV to a temporary register, but we hope - -- the register allocator will get rid of it. + -- NOTE: op_src is stable, so it will still be valid + -- after code_addr. This may involve the introduction + -- of an extra MOV to a temporary register, but we hope + -- the register allocator will get rid of it. -- return code where - get_op_RI :: CmmExpr -> NatM (InstrBlock,Operand) -- code, operator + get_op_RI :: CmmExpr -> NatM (InstrBlock,Operand) -- code, operator get_op_RI (CmmLit lit) | is32BitLit lit = return (nilOL, OpImm (litToImm lit)) get_op_RI op = do (reg,code) <- getNonClobberedReg op - return (code, OpReg reg) + return (code, OpReg reg) -- Assign; dst is a reg, rhs is mem @@ -1400,7 +1374,7 @@ return (load_code (getRegisterReg False{-no sse2-} reg)) -- dst is a reg, but src could be anything -assignReg_IntCode pk reg src = do +assignReg_IntCode _ reg src = do code <- getAnyReg src return (code (getRegisterReg False{-no sse2-} reg)) @@ -1411,14 +1385,14 @@ Amode addr addr_code <- getAmode addr use_sse2 <- sse2Enabled let - code = src_code `appOL` - addr_code `snocOL` + code = src_code `appOL` + addr_code `snocOL` if use_sse2 then MOV pk (OpReg src_reg) (OpAddr addr) else GST pk src_reg addr return code -- Floating point assignment to a register/temporary -assignReg_FltCode pk reg src = do +assignReg_FltCode _ reg src = do use_sse2 <- sse2Enabled src_code <- getAnyReg src return (src_code (getRegisterReg use_sse2 reg)) @@ -1426,7 +1400,7 @@ genJump :: CmmExpr{-the branch target-} -> NatM InstrBlock -genJump (CmmLoad mem pk) = do +genJump (CmmLoad mem _) = do Amode target code <- getAmode mem return (code `snocOL` JMP (OpAddr target)) @@ -1459,7 +1433,7 @@ -} genCondJump - :: BlockId -- the branch target + :: BlockId -- the branch target -> CmmExpr -- the condition on which to branch -> NatM InstrBlock @@ -1468,31 +1442,31 @@ use_sse2 <- sse2Enabled if not is_float || not use_sse2 then - return (cond_code `snocOL` JXX cond id) + return (cond_code `snocOL` JXX cond id) else do - lbl <- getBlockIdNat + lbl <- getBlockIdNat - -- see comment with condFltReg - let code = case cond of - NE -> or_unordered - GU -> plain_test - GEU -> plain_test - _ -> and_ordered - - plain_test = unitOL ( - JXX cond id - ) - or_unordered = toOL [ - JXX cond id, - JXX PARITY id - ] - and_ordered = toOL [ - JXX PARITY lbl, - JXX cond id, - JXX ALWAYS lbl, - NEWBLOCK lbl - ] - return (cond_code `appOL` code) + -- see comment with condFltReg + let code = case cond of + NE -> or_unordered + GU -> plain_test + GEU -> plain_test + _ -> and_ordered + + plain_test = unitOL ( + JXX cond id + ) + or_unordered = toOL [ + JXX cond id, + JXX PARITY id + ] + and_ordered = toOL [ + JXX PARITY lbl, + JXX cond id, + JXX ALWAYS lbl, + NEWBLOCK lbl + ] + return (cond_code `appOL` code) -- ----------------------------------------------------------------------------- @@ -1501,411 +1475,522 @@ -- Now the biggest nightmare---calls. Most of the nastiness is buried in -- @get_arg@, which moves the arguments to the correct registers/stack -- locations. Apart from that, the code is easy. --- +-- -- (If applicable) Do not fill the delay slots here; you will confuse the -- register allocator. genCCall - :: CmmCallTarget -- function to call - -> HintedCmmFormals -- where to put the result - -> HintedCmmActuals -- arguments (of mixed type) + :: CmmCallTarget -- function to call + -> [HintedCmmFormal] -- where to put the result + -> [HintedCmmActual] -- arguments (of mixed type) -> NatM InstrBlock -- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -#if i386_TARGET_ARCH - -genCCall (CmmPrim MO_WriteBarrier) _ _ = return nilOL - -- write barrier compiles to no code on x86/x86-64; - -- we keep it this long in order to prevent earlier optimisations. - --- we only cope with a single result for foreign calls -genCCall (CmmPrim op) [CmmHinted r _] args = do - l1 <- getNewLabelNat - l2 <- getNewLabelNat - sse2 <- sse2Enabled - if sse2 - then - outOfLineFloatOp op r args - else case op of - MO_F32_Sqrt -> actuallyInlineFloatOp GSQRT FF32 args - MO_F64_Sqrt -> actuallyInlineFloatOp GSQRT FF64 args - - MO_F32_Sin -> actuallyInlineFloatOp (\s -> GSIN s l1 l2) FF32 args - MO_F64_Sin -> actuallyInlineFloatOp (\s -> GSIN s l1 l2) FF64 args - - MO_F32_Cos -> actuallyInlineFloatOp (\s -> GCOS s l1 l2) FF32 args - MO_F64_Cos -> actuallyInlineFloatOp (\s -> GCOS s l1 l2) FF64 args - - MO_F32_Tan -> actuallyInlineFloatOp (\s -> GTAN s l1 l2) FF32 args - MO_F64_Tan -> actuallyInlineFloatOp (\s -> GTAN s l1 l2) FF64 args - - other_op -> outOfLineFloatOp op r args - - where - actuallyInlineFloatOp instr size [CmmHinted x _] - = do res <- trivialUFCode size (instr size) x - any <- anyReg res - return (any (getRegisterReg False (CmmLocal r))) - -genCCall target dest_regs args = do - let - sizes = map (arg_size . cmmExprType . hintlessCmm) (reverse args) -#if !darwin_TARGET_OS - tot_arg_size = sum sizes -#else - raw_arg_size = sum sizes - tot_arg_size = roundTo 16 raw_arg_size - arg_pad_size = tot_arg_size - raw_arg_size - delta0 <- getDeltaNat - setDeltaNat (delta0 - arg_pad_size) -#endif - - use_sse2 <- sse2Enabled - push_codes <- mapM (push_arg use_sse2) (reverse args) - delta <- getDeltaNat - - -- in - -- deal with static vs dynamic call targets - (callinsns,cconv) <- - case target of - -- CmmPrim -> ... - CmmCallee (CmmLit (CmmLabel lbl)) conv - -> -- ToDo: stdcall arg sizes - return (unitOL (CALL (Left fn_imm) []), conv) - where fn_imm = ImmCLbl lbl - CmmCallee expr conv - -> do { (dyn_r, dyn_c) <- getSomeReg expr - ; ASSERT( isWord32 (cmmExprType expr) ) - return (dyn_c `snocOL` CALL (Right dyn_r) [], conv) } - - let push_code -#if darwin_TARGET_OS - | arg_pad_size /= 0 - = toOL [SUB II32 (OpImm (ImmInt arg_pad_size)) (OpReg esp), - DELTA (delta0 - arg_pad_size)] - `appOL` concatOL push_codes - | otherwise -#endif - = concatOL push_codes - call = callinsns `appOL` - toOL ( - -- Deallocate parameters after call for ccall; - -- but not for stdcall (callee does it) - (if cconv == StdCallConv || tot_arg_size==0 then [] else - [ADD II32 (OpImm (ImmInt tot_arg_size)) (OpReg esp)]) - ++ - [DELTA (delta + tot_arg_size)] - ) - -- in - setDeltaNat (delta + tot_arg_size) +-- Unroll memcpy calls if the source and destination pointers are at +-- least DWORD aligned and the number of bytes to copy isn't too +-- large. Otherwise, call C's memcpy. +genCCall (CmmPrim MO_Memcpy) _ [CmmHinted dst _, CmmHinted src _, + CmmHinted (CmmLit (CmmInt n _)) _, + CmmHinted (CmmLit (CmmInt align _)) _] + | n <= maxInlineSizeThreshold && align .&. 3 == 0 = do + code_dst <- getAnyReg dst + dst_r <- getNewRegNat size + code_src <- getAnyReg src + src_r <- getNewRegNat size + tmp_r <- getNewRegNat size + return $ code_dst dst_r `appOL` code_src src_r `appOL` + go dst_r src_r tmp_r n + where + size = if align .&. 4 /= 0 then II32 else archWordSize - let - -- assign the results, if necessary - assign_code [] = nilOL - assign_code [CmmHinted dest _hint] - | isFloatType ty = - if use_sse2 - then let tmp_amode = AddrBaseIndex (EABaseReg esp) - EAIndexNone - (ImmInt 0) - sz = floatSize w - in toOL [ SUB II32 (OpImm (ImmInt b)) (OpReg esp), - GST sz fake0 tmp_amode, - MOV sz (OpAddr tmp_amode) (OpReg r_dest), - ADD II32 (OpImm (ImmInt b)) (OpReg esp)] - else unitOL (GMOV fake0 r_dest) - | isWord64 ty = toOL [MOV II32 (OpReg eax) (OpReg r_dest), - MOV II32 (OpReg edx) (OpReg r_dest_hi)] - | otherwise = unitOL (MOV (intSize w) (OpReg eax) (OpReg r_dest)) - where - ty = localRegType dest - w = typeWidth ty - b = widthInBytes w - r_dest_hi = getHiVRegFromLo r_dest - r_dest = getRegisterReg use_sse2 (CmmLocal dest) - assign_code many = pprPanic "genCCall.assign_code - too many return values:" (ppr many) - - return (push_code `appOL` - call `appOL` - assign_code dest_regs) + sizeBytes = fromIntegral (sizeInBytes size) + go :: Reg -> Reg -> Reg -> Integer -> OrdList Instr + go dst src tmp i + | i >= sizeBytes = + unitOL (MOV size (OpAddr src_addr) (OpReg tmp)) `appOL` + unitOL (MOV size (OpReg tmp) (OpAddr dst_addr)) `appOL` + go dst src tmp (i - sizeBytes) + -- Deal with remaining bytes. + | i >= 4 = -- Will never happen on 32-bit + unitOL (MOV II32 (OpAddr src_addr) (OpReg tmp)) `appOL` + unitOL (MOV II32 (OpReg tmp) (OpAddr dst_addr)) `appOL` + go dst src tmp (i - 4) + | i >= 2 = + unitOL (MOVZxL II16 (OpAddr src_addr) (OpReg tmp)) `appOL` + unitOL (MOV II16 (OpReg tmp) (OpAddr dst_addr)) `appOL` + go dst src tmp (i - 2) + | i >= 1 = + unitOL (MOVZxL II8 (OpAddr src_addr) (OpReg tmp)) `appOL` + unitOL (MOV II8 (OpReg tmp) (OpAddr dst_addr)) `appOL` + go dst src tmp (i - 1) + | otherwise = nilOL + where + src_addr = AddrBaseIndex (EABaseReg src) EAIndexNone + (ImmInteger (n - i)) + dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone + (ImmInteger (n - i)) + +genCCall (CmmPrim MO_Memset) _ [CmmHinted dst _, + CmmHinted (CmmLit (CmmInt c _)) _, + CmmHinted (CmmLit (CmmInt n _)) _, + CmmHinted (CmmLit (CmmInt align _)) _] + | n <= maxInlineSizeThreshold && align .&. 3 == 0 = do + code_dst <- getAnyReg dst + dst_r <- getNewRegNat size + return $ code_dst dst_r `appOL` go dst_r n where - arg_size :: CmmType -> Int -- Width in bytes - arg_size ty = widthInBytes (typeWidth ty) - - roundTo a x | x `mod` a == 0 = x - | otherwise = x + a - (x `mod` a) + (size, val) = case align .&. 3 of + 2 -> (II16, c2) + 0 -> (II32, c4) + _ -> (II8, c) + c2 = c `shiftL` 8 .|. c + c4 = c2 `shiftL` 16 .|. c2 + + sizeBytes = fromIntegral (sizeInBytes size) + + go :: Reg -> Integer -> OrdList Instr + go dst i + -- TODO: Add movabs instruction and support 64-bit sets. + | i >= sizeBytes = -- This might be smaller than the below sizes + unitOL (MOV size (OpImm (ImmInteger val)) (OpAddr dst_addr)) `appOL` + go dst (i - sizeBytes) + | i >= 4 = -- Will never happen on 32-bit + unitOL (MOV II32 (OpImm (ImmInteger c4)) (OpAddr dst_addr)) `appOL` + go dst (i - 4) + | i >= 2 = + unitOL (MOV II16 (OpImm (ImmInteger c2)) (OpAddr dst_addr)) `appOL` + go dst (i - 2) + | i >= 1 = + unitOL (MOV II8 (OpImm (ImmInteger c)) (OpAddr dst_addr)) `appOL` + go dst (i - 1) + | otherwise = nilOL + where + dst_addr = AddrBaseIndex (EABaseReg dst) EAIndexNone + (ImmInteger (n - i)) +genCCall (CmmPrim MO_WriteBarrier) _ _ = return nilOL + -- write barrier compiles to no code on x86/x86-64; + -- we keep it this long in order to prevent earlier optimisations. - push_arg :: Bool -> HintedCmmActual {-current argument-} - -> NatM InstrBlock -- code +genCCall target dest_regs args = + do dflags <- getDynFlagsNat + if target32Bit (targetPlatform dflags) + then genCCall32 target dest_regs args + else genCCall64 target dest_regs args + +genCCall32 :: CmmCallTarget -- function to call + -> [HintedCmmFormal] -- where to put the result + -> [HintedCmmActual] -- arguments (of mixed type) + -> NatM InstrBlock +genCCall32 target dest_regs args = + case (target, dest_regs) of + -- void return type prim op + (CmmPrim op, []) -> + outOfLineCmmOp op Nothing args + -- we only cope with a single result for foreign calls + (CmmPrim op, [r_hinted@(CmmHinted r _)]) -> do + l1 <- getNewLabelNat + l2 <- getNewLabelNat + sse2 <- sse2Enabled + if sse2 + then + outOfLineCmmOp op (Just r_hinted) args + else case op of + MO_F32_Sqrt -> actuallyInlineFloatOp GSQRT FF32 args + MO_F64_Sqrt -> actuallyInlineFloatOp GSQRT FF64 args + + MO_F32_Sin -> actuallyInlineFloatOp (\s -> GSIN s l1 l2) FF32 args + MO_F64_Sin -> actuallyInlineFloatOp (\s -> GSIN s l1 l2) FF64 args + + MO_F32_Cos -> actuallyInlineFloatOp (\s -> GCOS s l1 l2) FF32 args + MO_F64_Cos -> actuallyInlineFloatOp (\s -> GCOS s l1 l2) FF64 args + + MO_F32_Tan -> actuallyInlineFloatOp (\s -> GTAN s l1 l2) FF32 args + MO_F64_Tan -> actuallyInlineFloatOp (\s -> GTAN s l1 l2) FF64 args + + _other_op -> outOfLineCmmOp op (Just r_hinted) args + + where + actuallyInlineFloatOp instr size [CmmHinted x _] + = do res <- trivialUFCode size (instr size) x + any <- anyReg res + return (any (getRegisterReg False (CmmLocal r))) + + actuallyInlineFloatOp _ _ args + = panic $ "genCCall.actuallyInlineFloatOp: bad number of arguments! (" + ++ show (length args) ++ ")" + _ -> do + let + sizes = map (arg_size . cmmExprType . hintlessCmm) (reverse args) + raw_arg_size = sum sizes + tot_arg_size = roundTo 16 raw_arg_size + arg_pad_size = tot_arg_size - raw_arg_size + delta0 <- getDeltaNat + setDeltaNat (delta0 - arg_pad_size) - push_arg use_sse2 (CmmHinted arg _hint) -- we don't need the hints on x86 - | isWord64 arg_ty = do - ChildCode64 code r_lo <- iselExpr64 arg + use_sse2 <- sse2Enabled + push_codes <- mapM (push_arg use_sse2) (reverse args) delta <- getDeltaNat - setDeltaNat (delta - 8) - let - r_hi = getHiVRegFromLo r_lo - -- in - return ( code `appOL` - toOL [PUSH II32 (OpReg r_hi), DELTA (delta - 4), - PUSH II32 (OpReg r_lo), DELTA (delta - 8), - DELTA (delta-8)] - ) - | isFloatType arg_ty = do - (reg, code) <- getSomeReg arg - delta <- getDeltaNat - setDeltaNat (delta-size) - return (code `appOL` - toOL [SUB II32 (OpImm (ImmInt size)) (OpReg esp), - DELTA (delta-size), - let addr = AddrBaseIndex (EABaseReg esp) - EAIndexNone - (ImmInt 0) - size = floatSize (typeWidth arg_ty) - in - if use_sse2 - then MOV size (OpReg reg) (OpAddr addr) - else GST size reg addr - ] - ) + -- in + -- deal with static vs dynamic call targets + (callinsns,cconv) <- + case target of + CmmCallee (CmmLit (CmmLabel lbl)) conv + -> -- ToDo: stdcall arg sizes + return (unitOL (CALL (Left fn_imm) []), conv) + where fn_imm = ImmCLbl lbl + CmmCallee expr conv + -> do { (dyn_r, dyn_c) <- getSomeReg expr + ; ASSERT( isWord32 (cmmExprType expr) ) + return (dyn_c `snocOL` CALL (Right dyn_r) [], conv) } + CmmPrim _ + -> panic $ "genCCall: Can't handle CmmPrim call type here, error " + ++ "probably because too many return values." + + let push_code + | arg_pad_size /= 0 + = toOL [SUB II32 (OpImm (ImmInt arg_pad_size)) (OpReg esp), + DELTA (delta0 - arg_pad_size)] + `appOL` concatOL push_codes + | otherwise + = concatOL push_codes + + -- Deallocate parameters after call for ccall; + -- but not for stdcall (callee does it) + -- + -- We have to pop any stack padding we added + -- even if we are doing stdcall, though (#5052) + pop_size | cconv /= StdCallConv = tot_arg_size + | otherwise = arg_pad_size + + call = callinsns `appOL` + toOL ( + (if pop_size==0 then [] else + [ADD II32 (OpImm (ImmInt pop_size)) (OpReg esp)]) + ++ + [DELTA (delta + tot_arg_size)] + ) + -- in + setDeltaNat (delta + tot_arg_size) - | otherwise = do - (operand, code) <- getOperand arg - delta <- getDeltaNat - setDeltaNat (delta-size) - return (code `snocOL` - PUSH II32 operand `snocOL` - DELTA (delta-size)) + let + -- assign the results, if necessary + assign_code [] = nilOL + assign_code [CmmHinted dest _hint] + | isFloatType ty = + if use_sse2 + then let tmp_amode = AddrBaseIndex (EABaseReg esp) + EAIndexNone + (ImmInt 0) + sz = floatSize w + in toOL [ SUB II32 (OpImm (ImmInt b)) (OpReg esp), + GST sz fake0 tmp_amode, + MOV sz (OpAddr tmp_amode) (OpReg r_dest), + ADD II32 (OpImm (ImmInt b)) (OpReg esp)] + else unitOL (GMOV fake0 r_dest) + | isWord64 ty = toOL [MOV II32 (OpReg eax) (OpReg r_dest), + MOV II32 (OpReg edx) (OpReg r_dest_hi)] + | otherwise = unitOL (MOV (intSize w) (OpReg eax) (OpReg r_dest)) + where + ty = localRegType dest + w = typeWidth ty + b = widthInBytes w + r_dest_hi = getHiVRegFromLo r_dest + r_dest = getRegisterReg use_sse2 (CmmLocal dest) + assign_code many = pprPanic "genCCall.assign_code - too many return values:" (ppr many) + + return (push_code `appOL` + call `appOL` + assign_code dest_regs) where - arg_ty = cmmExprType arg - size = arg_size arg_ty -- Byte size - -#elif x86_64_TARGET_ARCH + arg_size :: CmmType -> Int -- Width in bytes + arg_size ty = widthInBytes (typeWidth ty) -genCCall (CmmPrim MO_WriteBarrier) _ _ = return nilOL - -- write barrier compiles to no code on x86/x86-64; - -- we keep it this long in order to prevent earlier optimisations. - - -genCCall (CmmPrim op) [CmmHinted r _] args = - outOfLineFloatOp op r args + roundTo a x | x `mod` a == 0 = x + | otherwise = x + a - (x `mod` a) -genCCall target dest_regs args = do + push_arg :: Bool -> HintedCmmActual {-current argument-} + -> NatM InstrBlock -- code - -- load up the register arguments - (stack_args, aregs, fregs, load_args_code) - <- load_args args allArgRegs allFPArgRegs nilOL - - let - fp_regs_used = reverse (drop (length fregs) (reverse allFPArgRegs)) - int_regs_used = reverse (drop (length aregs) (reverse allArgRegs)) - arg_regs = [eax] ++ int_regs_used ++ fp_regs_used - -- for annotating the call instruction with - - sse_regs = length fp_regs_used - - tot_arg_size = arg_size * length stack_args - - -- On entry to the called function, %rsp should be aligned - -- on a 16-byte boundary +8 (i.e. the first stack arg after - -- the return address is 16-byte aligned). In STG land - -- %rsp is kept 16-byte aligned (see StgCRun.c), so we just - -- need to make sure we push a multiple of 16-bytes of args, - -- plus the return address, to get the correct alignment. - -- Urg, this is hard. We need to feed the delta back into - -- the arg pushing code. - (real_size, adjust_rsp) <- - if tot_arg_size `rem` 16 == 0 - then return (tot_arg_size, nilOL) - else do -- we need to adjust... - delta <- getDeltaNat - setDeltaNat (delta-8) - return (tot_arg_size+8, toOL [ - SUB II64 (OpImm (ImmInt 8)) (OpReg rsp), - DELTA (delta-8) - ]) - - -- push the stack args, right to left - push_code <- push_args (reverse stack_args) nilOL - delta <- getDeltaNat - - -- deal with static vs dynamic call targets - (callinsns,cconv) <- - case target of - -- CmmPrim -> ... - CmmCallee (CmmLit (CmmLabel lbl)) conv - -> -- ToDo: stdcall arg sizes - return (unitOL (CALL (Left fn_imm) arg_regs), conv) - where fn_imm = ImmCLbl lbl - CmmCallee expr conv - -> do (dyn_r, dyn_c) <- getSomeReg expr - return (dyn_c `snocOL` CALL (Right dyn_r) arg_regs, conv) + push_arg use_sse2 (CmmHinted arg _hint) -- we don't need the hints on x86 + | isWord64 arg_ty = do + ChildCode64 code r_lo <- iselExpr64 arg + delta <- getDeltaNat + setDeltaNat (delta - 8) + let + r_hi = getHiVRegFromLo r_lo + -- in + return ( code `appOL` + toOL [PUSH II32 (OpReg r_hi), DELTA (delta - 4), + PUSH II32 (OpReg r_lo), DELTA (delta - 8), + DELTA (delta-8)] + ) + + | isFloatType arg_ty = do + (reg, code) <- getSomeReg arg + delta <- getDeltaNat + setDeltaNat (delta-size) + return (code `appOL` + toOL [SUB II32 (OpImm (ImmInt size)) (OpReg esp), + DELTA (delta-size), + let addr = AddrBaseIndex (EABaseReg esp) + EAIndexNone + (ImmInt 0) + size = floatSize (typeWidth arg_ty) + in + if use_sse2 + then MOV size (OpReg reg) (OpAddr addr) + else GST size reg addr + ] + ) + + | otherwise = do + (operand, code) <- getOperand arg + delta <- getDeltaNat + setDeltaNat (delta-size) + return (code `snocOL` + PUSH II32 operand `snocOL` + DELTA (delta-size)) + + where + arg_ty = cmmExprType arg + size = arg_size arg_ty -- Byte size + +genCCall64 :: CmmCallTarget -- function to call + -> [HintedCmmFormal] -- where to put the result + -> [HintedCmmActual] -- arguments (of mixed type) + -> NatM InstrBlock +genCCall64 target dest_regs args = + case (target, dest_regs) of + (CmmPrim op, []) -> + -- void return type prim op + outOfLineCmmOp op Nothing args + (CmmPrim op, [res]) -> + -- we only cope with a single result for foreign calls + outOfLineCmmOp op (Just res) args + _ -> do + -- load up the register arguments + (stack_args, aregs, fregs, load_args_code) + <- load_args args allArgRegs allFPArgRegs nilOL - let - -- The x86_64 ABI requires us to set %al to the number of SSE2 - -- registers that contain arguments, if the called routine - -- is a varargs function. We don't know whether it's a - -- varargs function or not, so we have to assume it is. - -- - -- It's not safe to omit this assignment, even if the number - -- of SSE2 regs in use is zero. If %al is larger than 8 - -- on entry to a varargs function, seg faults ensue. - assign_eax n = unitOL (MOV II32 (OpImm (ImmInt n)) (OpReg eax)) - - let call = callinsns `appOL` - toOL ( - -- Deallocate parameters after call for ccall; - -- but not for stdcall (callee does it) - (if cconv == StdCallConv || real_size==0 then [] else - [ADD (intSize wordWidth) (OpImm (ImmInt real_size)) (OpReg esp)]) - ++ - [DELTA (delta + real_size)] - ) - -- in - setDeltaNat (delta + real_size) - - let - -- assign the results, if necessary - assign_code [] = nilOL - assign_code [CmmHinted dest _hint] = - case typeWidth rep of - W32 | isFloatType rep -> unitOL (MOV (floatSize W32) (OpReg xmm0) (OpReg r_dest)) - W64 | isFloatType rep -> unitOL (MOV (floatSize W64) (OpReg xmm0) (OpReg r_dest)) - _ -> unitOL (MOV (cmmTypeSize rep) (OpReg rax) (OpReg r_dest)) - where - rep = localRegType dest - r_dest = getRegisterReg True (CmmLocal dest) - assign_code many = panic "genCCall.assign_code many" - - return (load_args_code `appOL` - adjust_rsp `appOL` - push_code `appOL` - assign_eax sse_regs `appOL` - call `appOL` - assign_code dest_regs) + let + fp_regs_used = reverse (drop (length fregs) (reverse allFPArgRegs)) + int_regs_used = reverse (drop (length aregs) (reverse allArgRegs)) + arg_regs = [eax] ++ int_regs_used ++ fp_regs_used + -- for annotating the call instruction with + + sse_regs = length fp_regs_used + + tot_arg_size = arg_size * length stack_args + + -- On entry to the called function, %rsp should be aligned + -- on a 16-byte boundary +8 (i.e. the first stack arg after + -- the return address is 16-byte aligned). In STG land + -- %rsp is kept 16-byte aligned (see StgCRun.c), so we just + -- need to make sure we push a multiple of 16-bytes of args, + -- plus the return address, to get the correct alignment. + -- Urg, this is hard. We need to feed the delta back into + -- the arg pushing code. + (real_size, adjust_rsp) <- + if tot_arg_size `rem` 16 == 0 + then return (tot_arg_size, nilOL) + else do -- we need to adjust... + delta <- getDeltaNat + setDeltaNat (delta-8) + return (tot_arg_size+8, toOL [ + SUB II64 (OpImm (ImmInt 8)) (OpReg rsp), + DELTA (delta-8) + ]) - where - arg_size = 8 -- always, at the mo + -- push the stack args, right to left + push_code <- push_args (reverse stack_args) nilOL + delta <- getDeltaNat - load_args :: [CmmHinted CmmExpr] - -> [Reg] -- int regs avail for args - -> [Reg] -- FP regs avail for args - -> InstrBlock - -> NatM ([CmmHinted CmmExpr],[Reg],[Reg],InstrBlock) - load_args args [] [] code = return (args, [], [], code) - -- no more regs to use - load_args [] aregs fregs code = return ([], aregs, fregs, code) - -- no more args to push - load_args ((CmmHinted arg hint) : rest) aregs fregs code - | isFloatType arg_rep = - case fregs of - [] -> push_this_arg - (r:rs) -> do - arg_code <- getAnyReg arg - load_args rest aregs rs (code `appOL` arg_code r) - | otherwise = - case aregs of - [] -> push_this_arg - (r:rs) -> do - arg_code <- getAnyReg arg - load_args rest rs fregs (code `appOL` arg_code r) - where - arg_rep = cmmExprType arg - - push_this_arg = do - (args',ars,frs,code') <- load_args rest aregs fregs code - return ((CmmHinted arg hint):args', ars, frs, code') - - push_args [] code = return code - push_args ((CmmHinted arg hint):rest) code - | isFloatType arg_rep = do - (arg_reg, arg_code) <- getSomeReg arg - delta <- getDeltaNat - setDeltaNat (delta-arg_size) - let code' = code `appOL` arg_code `appOL` toOL [ - SUB (intSize wordWidth) (OpImm (ImmInt arg_size)) (OpReg rsp) , - DELTA (delta-arg_size), - MOV (floatSize width) (OpReg arg_reg) (OpAddr (spRel 0))] - push_args rest code' - - | otherwise = do - -- we only ever generate word-sized function arguments. Promotion - -- has already happened: our Int8# type is kept sign-extended - -- in an Int#, for example. - ASSERT(width == W64) return () - (arg_op, arg_code) <- getOperand arg - delta <- getDeltaNat - setDeltaNat (delta-arg_size) - let code' = code `appOL` arg_code `appOL` toOL [ - PUSH II64 arg_op, - DELTA (delta-arg_size)] - push_args rest code' - where - arg_rep = cmmExprType arg - width = typeWidth arg_rep - -#else -genCCall = panic "X86.genCCAll: not defined" + -- deal with static vs dynamic call targets + (callinsns,cconv) <- + case target of + CmmCallee (CmmLit (CmmLabel lbl)) conv + -> -- ToDo: stdcall arg sizes + return (unitOL (CALL (Left fn_imm) arg_regs), conv) + where fn_imm = ImmCLbl lbl + CmmCallee expr conv + -> do (dyn_r, dyn_c) <- getSomeReg expr + return (dyn_c `snocOL` CALL (Right dyn_r) arg_regs, conv) + CmmPrim _ + -> panic $ "genCCall: Can't handle CmmPrim call type here, error " + ++ "probably because too many return values." -#endif /* x86_64_TARGET_ARCH */ + let + -- The x86_64 ABI requires us to set %al to the number of SSE2 + -- registers that contain arguments, if the called routine + -- is a varargs function. We don't know whether it's a + -- varargs function or not, so we have to assume it is. + -- + -- It's not safe to omit this assignment, even if the number + -- of SSE2 regs in use is zero. If %al is larger than 8 + -- on entry to a varargs function, seg faults ensue. + assign_eax n = unitOL (MOV II32 (OpImm (ImmInt n)) (OpReg eax)) + + let call = callinsns `appOL` + toOL ( + -- Deallocate parameters after call for ccall; + -- but not for stdcall (callee does it) + (if cconv == StdCallConv || real_size==0 then [] else + [ADD (intSize wordWidth) (OpImm (ImmInt real_size)) (OpReg esp)]) + ++ + [DELTA (delta + real_size)] + ) + -- in + setDeltaNat (delta + real_size) + let + -- assign the results, if necessary + assign_code [] = nilOL + assign_code [CmmHinted dest _hint] = + case typeWidth rep of + W32 | isFloatType rep -> unitOL (MOV (floatSize W32) (OpReg xmm0) (OpReg r_dest)) + W64 | isFloatType rep -> unitOL (MOV (floatSize W64) (OpReg xmm0) (OpReg r_dest)) + _ -> unitOL (MOV (cmmTypeSize rep) (OpReg rax) (OpReg r_dest)) + where + rep = localRegType dest + r_dest = getRegisterReg True (CmmLocal dest) + assign_code _many = panic "genCCall.assign_code many" + + return (load_args_code `appOL` + adjust_rsp `appOL` + push_code `appOL` + assign_eax sse_regs `appOL` + call `appOL` + assign_code dest_regs) + where + arg_size = 8 -- always, at the mo + load_args :: [CmmHinted CmmExpr] + -> [Reg] -- int regs avail for args + -> [Reg] -- FP regs avail for args + -> InstrBlock + -> NatM ([CmmHinted CmmExpr],[Reg],[Reg],InstrBlock) + load_args args [] [] code = return (args, [], [], code) + -- no more regs to use + load_args [] aregs fregs code = return ([], aregs, fregs, code) + -- no more args to push + load_args ((CmmHinted arg hint) : rest) aregs fregs code + | isFloatType arg_rep = + case fregs of + [] -> push_this_arg + (r:rs) -> do + arg_code <- getAnyReg arg + load_args rest aregs rs (code `appOL` arg_code r) + | otherwise = + case aregs of + [] -> push_this_arg + (r:rs) -> do + arg_code <- getAnyReg arg + load_args rest rs fregs (code `appOL` arg_code r) + where + arg_rep = cmmExprType arg + + push_this_arg = do + (args',ars,frs,code') <- load_args rest aregs fregs code + return ((CmmHinted arg hint):args', ars, frs, code') + + push_args [] code = return code + push_args ((CmmHinted arg _):rest) code + | isFloatType arg_rep = do + (arg_reg, arg_code) <- getSomeReg arg + delta <- getDeltaNat + setDeltaNat (delta-arg_size) + let code' = code `appOL` arg_code `appOL` toOL [ + SUB (intSize wordWidth) (OpImm (ImmInt arg_size)) (OpReg rsp) , + DELTA (delta-arg_size), + MOV (floatSize width) (OpReg arg_reg) (OpAddr (spRel 0))] + push_args rest code' + + | otherwise = do + -- we only ever generate word-sized function arguments. Promotion + -- has already happened: our Int8# type is kept sign-extended + -- in an Int#, for example. + ASSERT(width == W64) return () + (arg_op, arg_code) <- getOperand arg + delta <- getDeltaNat + setDeltaNat (delta-arg_size) + let code' = code `appOL` arg_code `appOL` toOL [ + PUSH II64 arg_op, + DELTA (delta-arg_size)] + push_args rest code' + where + arg_rep = cmmExprType arg + width = typeWidth arg_rep + +-- | We're willing to inline and unroll memcpy/memset calls that touch +-- at most these many bytes. This threshold is the same as the one +-- used by GCC and LLVM. +maxInlineSizeThreshold :: Integer +maxInlineSizeThreshold = 128 -outOfLineFloatOp :: CallishMachOp -> CmmFormal -> HintedCmmActuals -> NatM InstrBlock -outOfLineFloatOp mop res args +outOfLineCmmOp :: CallishMachOp -> Maybe HintedCmmFormal -> [HintedCmmActual] -> NatM InstrBlock +outOfLineCmmOp mop res args = do dflags <- getDynFlagsNat targetExpr <- cmmMakeDynamicReference dflags addImportNat CallReference lbl let target = CmmCallee targetExpr CCallConv - - stmtToInstrs (CmmCall target [CmmHinted res NoHint] args CmmUnsafe CmmMayReturn) - where - -- Assume we can call these functions directly, and that they're not in a dynamic library. - -- TODO: Why is this ok? Under linux this code will be in libm.so - -- Is is because they're really implemented as a primitive instruction by the assembler?? -- BL 2009/12/31 - lbl = mkForeignLabel fn Nothing ForeignLabelInThisPackage IsFunction - - fn = case mop of - MO_F32_Sqrt -> fsLit "sqrtf" - MO_F32_Sin -> fsLit "sinf" - MO_F32_Cos -> fsLit "cosf" - MO_F32_Tan -> fsLit "tanf" - MO_F32_Exp -> fsLit "expf" - MO_F32_Log -> fsLit "logf" - - MO_F32_Asin -> fsLit "asinf" - MO_F32_Acos -> fsLit "acosf" - MO_F32_Atan -> fsLit "atanf" - - MO_F32_Sinh -> fsLit "sinhf" - MO_F32_Cosh -> fsLit "coshf" - MO_F32_Tanh -> fsLit "tanhf" - MO_F32_Pwr -> fsLit "powf" - - MO_F64_Sqrt -> fsLit "sqrt" - MO_F64_Sin -> fsLit "sin" - MO_F64_Cos -> fsLit "cos" - MO_F64_Tan -> fsLit "tan" - MO_F64_Exp -> fsLit "exp" - MO_F64_Log -> fsLit "log" - - MO_F64_Asin -> fsLit "asin" - MO_F64_Acos -> fsLit "acos" - MO_F64_Atan -> fsLit "atan" - - MO_F64_Sinh -> fsLit "sinh" - MO_F64_Cosh -> fsLit "cosh" - MO_F64_Tanh -> fsLit "tanh" - MO_F64_Pwr -> fsLit "pow" - + stmtToInstrs (CmmCall target (catMaybes [res]) args' CmmUnsafe CmmMayReturn) + where + -- Assume we can call these functions directly, and that they're not in a dynamic library. + -- TODO: Why is this ok? Under linux this code will be in libm.so + -- Is is because they're really implemented as a primitive instruction by the assembler?? -- BL 2009/12/31 + lbl = mkForeignLabel fn Nothing ForeignLabelInThisPackage IsFunction + + args' = case mop of + MO_Memcpy -> init args + MO_Memset -> init args + MO_Memmove -> init args + _ -> args + + fn = case mop of + MO_F32_Sqrt -> fsLit "sqrtf" + MO_F32_Sin -> fsLit "sinf" + MO_F32_Cos -> fsLit "cosf" + MO_F32_Tan -> fsLit "tanf" + MO_F32_Exp -> fsLit "expf" + MO_F32_Log -> fsLit "logf" + + MO_F32_Asin -> fsLit "asinf" + MO_F32_Acos -> fsLit "acosf" + MO_F32_Atan -> fsLit "atanf" + + MO_F32_Sinh -> fsLit "sinhf" + MO_F32_Cosh -> fsLit "coshf" + MO_F32_Tanh -> fsLit "tanhf" + MO_F32_Pwr -> fsLit "powf" + + MO_F64_Sqrt -> fsLit "sqrt" + MO_F64_Sin -> fsLit "sin" + MO_F64_Cos -> fsLit "cos" + MO_F64_Tan -> fsLit "tan" + MO_F64_Exp -> fsLit "exp" + MO_F64_Log -> fsLit "log" + + MO_F64_Asin -> fsLit "asin" + MO_F64_Acos -> fsLit "acos" + MO_F64_Atan -> fsLit "atan" + + MO_F64_Sinh -> fsLit "sinh" + MO_F64_Cosh -> fsLit "cosh" + MO_F64_Tanh -> fsLit "tanh" + MO_F64_Pwr -> fsLit "pow" + + MO_Memcpy -> fsLit "memcpy" + MO_Memset -> fsLit "memset" + MO_Memmove -> fsLit "memmove" + other -> panic $ "outOfLineCmmOp: unmatched op! (" ++ show other ++ ")" -- ----------------------------------------------------------------------------- @@ -1921,77 +2006,75 @@ 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 id)) - = CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0) - where blockLabel = mkAsmTempLabel id - - op = OpAddr (AddrBaseIndex (EABaseReg tableReg) + let op = OpAddr (AddrBaseIndex (EABaseReg tableReg) (EAIndex reg wORD_SIZE) (ImmInt 0)) -#if x86_64_TARGET_ARCH -#if darwin_TARGET_OS - -- on Mac OS X/x86_64, put the jump table in the text section - -- to work around a limitation of the linker. - -- ld64 is unable to handle the relocations for - -- .quad L1 - L0 - -- if L0 is not preceded by a non-anonymous label in its section. - - 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) - ] -#else - -- HACK: On x86_64 binutils<2.17 is only able to generate PC32 - -- relocations, hence we only get 32-bit offsets in the jump - -- table. As these offsets are always negative we need to properly - -- sign extend them to 64-bit. This hack should be removed in - -- 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 ] - ] -#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 ] - ] -#endif - return code + return $ if target32Bit (targetPlatform dflags) + then e_code `appOL` t_code `appOL` toOL [ + ADD (intSize wordWidth) op (OpReg tableReg), + JMP_TBL (OpReg tableReg) ids ReadOnlyData lbl + ] + else case platformOS (targetPlatform dflags) of + OSDarwin -> + -- on Mac OS X/x86_64, put the jump table + -- in the text section to work around a + -- limitation of the linker. + -- ld64 is unable to handle the relocations for + -- .quad L1 - L0 + -- if L0 is not preceded by a non-anonymous + -- label in its section. + e_code `appOL` t_code `appOL` toOL [ + ADD (intSize wordWidth) op (OpReg tableReg), + JMP_TBL (OpReg tableReg) ids Text lbl + ] + _ -> + -- HACK: On x86_64 binutils<2.17 is only able + -- to generate PC32 relocations, hence we only + -- get 32-bit offsets in the jump table. As + -- these offsets are always negative we need + -- to properly sign extend them to 64-bit. + -- This hack should be removed in conjunction + -- with the hack in PprMach.hs/pprDataItem + -- once binutils 2.17 is standard. + e_code `appOL` t_code `appOL` toOL [ + MOVSxL II32 op (OpReg reg), + ADD (intSize wordWidth) (OpReg reg) (OpReg tableReg), + JMP_TBL (OpReg tableReg) ids ReadOnlyData lbl + ] | otherwise = do (reg,e_code) <- getSomeReg expr lbl <- getNewLabelNat - let - jumpTable = map jumpTableEntry ids - op = OpAddr (AddrBaseIndex EABaseNone (EAIndex reg wORD_SIZE) (ImmCLbl lbl)) + let 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 (Alignment, CmmStatics) Instr) +generateJumpTableForInstr (JMP_TBL _ ids section lbl) = Just (createJumpTable ids section lbl) +generateJumpTableForInstr _ = Nothing + +createJumpTable :: [Maybe BlockId] -> Section -> CLabel -> GenCmmTop (Alignment, CmmStatics) h g +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 (1, Statics lbl jumpTable) -- ----------------------------------------------------------------------------- -- 'condIntReg' and 'condFltReg': condition codes into registers -- Turn those condition codes into integers now (when they appear on -- the right hand side of an assignment). --- +-- -- (If applicable) Do not fill the delay slots here; you will confuse the -- register allocator. @@ -2000,11 +2083,11 @@ condIntReg cond x y = do CondCode _ cond cond_code <- condIntCode cond x y tmp <- getNewRegNat II8 - let - code dst = cond_code `appOL` toOL [ - SETCC cond (OpReg tmp), - MOVZxL II8 (OpReg tmp) (OpReg dst) - ] + let + code dst = cond_code `appOL` toOL [ + SETCC cond (OpReg tmp), + MOVZxL II8 (OpReg tmp) (OpReg dst) + ] -- in return (Any II32 code) @@ -2016,57 +2099,57 @@ condFltReg_x87 = do CondCode _ cond cond_code <- condFltCode cond x y tmp <- getNewRegNat II8 - let - code dst = cond_code `appOL` toOL [ - SETCC cond (OpReg tmp), - MOVZxL II8 (OpReg tmp) (OpReg dst) - ] + let + code dst = cond_code `appOL` toOL [ + SETCC cond (OpReg tmp), + MOVZxL II8 (OpReg tmp) (OpReg dst) + ] -- in return (Any II32 code) - + condFltReg_sse2 = do CondCode _ cond cond_code <- condFltCode cond x y tmp1 <- getNewRegNat archWordSize tmp2 <- getNewRegNat archWordSize - let - -- We have to worry about unordered operands (eg. comparisons - -- against NaN). If the operands are unordered, the comparison - -- sets the parity flag, carry flag and zero flag. - -- All comparisons are supposed to return false for unordered - -- operands except for !=, which returns true. - -- - -- Optimisation: we don't have to test the parity flag if we - -- know the test has already excluded the unordered case: eg > - -- and >= test for a zero carry flag, which can only occur for - -- ordered operands. - -- - -- ToDo: by reversing comparisons we could avoid testing the - -- parity flag in more cases. - - code dst = - cond_code `appOL` - (case cond of - NE -> or_unordered dst - GU -> plain_test dst - GEU -> plain_test dst - _ -> and_ordered dst) - - plain_test dst = toOL [ - SETCC cond (OpReg tmp1), - MOVZxL II8 (OpReg tmp1) (OpReg dst) - ] - or_unordered dst = toOL [ - SETCC cond (OpReg tmp1), - SETCC PARITY (OpReg tmp2), - OR II8 (OpReg tmp1) (OpReg tmp2), - MOVZxL II8 (OpReg tmp2) (OpReg dst) - ] - and_ordered dst = toOL [ - SETCC cond (OpReg tmp1), - SETCC NOTPARITY (OpReg tmp2), - AND II8 (OpReg tmp1) (OpReg tmp2), - MOVZxL II8 (OpReg tmp2) (OpReg dst) - ] + let + -- We have to worry about unordered operands (eg. comparisons + -- against NaN). If the operands are unordered, the comparison + -- sets the parity flag, carry flag and zero flag. + -- All comparisons are supposed to return false for unordered + -- operands except for !=, which returns true. + -- + -- Optimisation: we don't have to test the parity flag if we + -- know the test has already excluded the unordered case: eg > + -- and >= test for a zero carry flag, which can only occur for + -- ordered operands. + -- + -- ToDo: by reversing comparisons we could avoid testing the + -- parity flag in more cases. + + code dst = + cond_code `appOL` + (case cond of + NE -> or_unordered dst + GU -> plain_test dst + GEU -> plain_test dst + _ -> and_ordered dst) + + plain_test dst = toOL [ + SETCC cond (OpReg tmp1), + MOVZxL II8 (OpReg tmp1) (OpReg dst) + ] + or_unordered dst = toOL [ + SETCC cond (OpReg tmp1), + SETCC PARITY (OpReg tmp2), + OR II8 (OpReg tmp1) (OpReg tmp2), + MOVZxL II8 (OpReg tmp2) (OpReg dst) + ] + and_ordered dst = toOL [ + SETCC cond (OpReg tmp1), + SETCC NOTPARITY (OpReg tmp2), + AND II8 (OpReg tmp1) (OpReg tmp2), + MOVZxL II8 (OpReg tmp2) (OpReg dst) + ] -- in return (Any II32 code) @@ -2090,7 +2173,7 @@ * You cannot assume anything about the destination register dst; it may be anything, including a fixed reg. -* You may compute an operand into a fixed reg, but you may not +* You may compute an operand into a fixed reg, but you may not subsequently change the contents of that fixed reg. If you want to do so, first copy the value either to a temporary or into dst. You are free to modify dst even if it happens @@ -2099,8 +2182,8 @@ * You cannot assume that a fixed reg will stay live over an arbitrary computation. The same applies to the dst reg. -* Temporary regs obtained from getNewRegNat are distinct from - each other and from all other regs, and stay live over +* Temporary regs obtained from getNewRegNat are distinct from + each other and from all other regs, and stay live over arbitrary computations. -------------------- @@ -2122,27 +2205,32 @@ therefore not read by any of the sub-computations). * If getRegister returns Any, then the code it generates may modify only: - (a) fresh temporaries - (b) the destination register - (c) known registers (eg. %ecx is used by shifts) + (a) fresh temporaries + (b) the destination register + (c) known registers (eg. %ecx is used by shifts) In particular, it may *not* modify global registers, unless the global register happens to be the destination register. -} -trivialCode width instr (Just revinstr) (CmmLit lit_a) b +trivialCode :: Width -> (Operand -> Operand -> Instr) + -> Maybe (Operand -> Operand -> Instr) + -> CmmExpr -> CmmExpr -> NatM Register +trivialCode width _ (Just revinstr) (CmmLit lit_a) b | is32BitLit lit_a = do b_code <- getAnyReg b let - code dst - = b_code dst `snocOL` + code dst + = b_code dst `snocOL` revinstr (OpImm (litToImm lit_a)) (OpReg dst) -- in return (Any (intSize width) code) -trivialCode width instr maybe_revinstr a b +trivialCode width instr _ a b = genTrivialCode (intSize width) instr a b -- This is re-used for floating pt instructions too. +genTrivialCode :: Size -> (Operand -> Operand -> Instr) + -> CmmExpr -> CmmExpr -> NatM Register genTrivialCode rep instr a b = do (b_op, b_code) <- getNonClobberedOperand b a_code <- getAnyReg a @@ -2155,56 +2243,64 @@ -- as the destination reg. In this case, we have to save b in a -- new temporary across the computation of a. code dst - | dst `regClashesWithOp` b_op = - b_code `appOL` - unitOL (MOV rep b_op (OpReg tmp)) `appOL` - a_code dst `snocOL` - instr (OpReg tmp) (OpReg dst) - | otherwise = - b_code `appOL` - a_code dst `snocOL` - instr b_op (OpReg dst) + | dst `regClashesWithOp` b_op = + b_code `appOL` + unitOL (MOV rep b_op (OpReg tmp)) `appOL` + a_code dst `snocOL` + instr (OpReg tmp) (OpReg dst) + | otherwise = + b_code `appOL` + a_code dst `snocOL` + instr b_op (OpReg dst) -- in return (Any rep code) +regClashesWithOp :: Reg -> Operand -> Bool reg `regClashesWithOp` OpReg reg2 = reg == reg2 reg `regClashesWithOp` OpAddr amode = any (==reg) (addrModeRegs amode) -reg `regClashesWithOp` _ = False +_ `regClashesWithOp` _ = False ----------- +trivialUCode :: Size -> (Operand -> Instr) + -> CmmExpr -> NatM Register trivialUCode rep instr x = do x_code <- getAnyReg x let code dst = - x_code dst `snocOL` - instr (OpReg dst) + x_code dst `snocOL` + instr (OpReg dst) return (Any rep code) ----------- -trivialFCode_x87 width instr x y = do +trivialFCode_x87 :: (Size -> Reg -> Reg -> Reg -> Instr) + -> CmmExpr -> CmmExpr -> NatM Register +trivialFCode_x87 instr x y = do (x_reg, x_code) <- getNonClobberedReg x -- these work for float regs too (y_reg, y_code) <- getSomeReg y let size = FF80 -- always, on x87 code dst = - x_code `appOL` - y_code `snocOL` - instr size x_reg y_reg dst + x_code `appOL` + y_code `snocOL` + instr size x_reg y_reg dst return (Any size code) +trivialFCode_sse2 :: Width -> (Size -> Operand -> Operand -> Instr) + -> CmmExpr -> CmmExpr -> NatM Register trivialFCode_sse2 pk instr x y = genTrivialCode size (instr size) x y where size = floatSize pk +trivialUFCode :: Size -> (Reg -> Reg -> Instr) -> CmmExpr -> NatM Register trivialUFCode size instr x = do (x_reg, x_code) <- getSomeReg x let code dst = - x_code `snocOL` - instr x_reg dst + x_code `snocOL` + instr x_reg dst -- in return (Any size code) @@ -2216,15 +2312,19 @@ coerce_x87 = do (x_reg, x_code) <- getSomeReg x let - opc = case to of W32 -> GITOF; W64 -> GITOD + opc = case to of W32 -> GITOF; W64 -> GITOD; + n -> panic $ "coerceInt2FP.x87: unhandled width (" + ++ show n ++ ")" code dst = x_code `snocOL` opc x_reg dst - -- ToDo: works for non-II32 reps? + -- ToDo: works for non-II32 reps? return (Any FF80 code) - + coerce_sse2 = do (x_op, x_code) <- getOperand x -- ToDo: could be a safe operand let opc = case to of W32 -> CVTSI2SS; W64 -> CVTSI2SD + n -> panic $ "coerceInt2FP.sse: unhandled width (" + ++ show n ++ ")" code dst = x_code `snocOL` opc (intSize from) x_op dst -- in return (Any (floatSize to) code) @@ -2238,15 +2338,19 @@ (x_reg, x_code) <- getSomeReg x let opc = case from of W32 -> GFTOI; W64 -> GDTOI + n -> panic $ "coerceFP2Int.x87: unhandled width (" + ++ show n ++ ")" code dst = x_code `snocOL` opc x_reg dst - -- ToDo: works for non-II32 reps? + -- ToDo: works for non-II32 reps? -- in return (Any (intSize to) code) - + coerceFP2Int_sse2 = do (x_op, x_code) <- getOperand x -- ToDo: could be a safe operand let - opc = case from of W32 -> CVTTSS2SIQ; W64 -> CVTTSD2SIQ + opc = case from of W32 -> CVTTSS2SIQ; W64 -> CVTTSD2SIQ; + n -> panic $ "coerceFP2Init.sse: unhandled width (" + ++ show n ++ ")" code dst = x_code `snocOL` opc (intSize to) x_op dst -- in return (Any (intSize to) code) @@ -2256,12 +2360,16 @@ -------------------------------------------------------------------------------- coerceFP2FP :: Width -> CmmExpr -> NatM Register coerceFP2FP to x = do + use_sse2 <- sse2Enabled (x_reg, x_code) <- getSomeReg x let - opc = case to of W32 -> CVTSD2SS; W64 -> CVTSS2SD + opc | use_sse2 = case to of W32 -> CVTSD2SS; W64 -> CVTSS2SD; + n -> panic $ "coerceFP2FP: unhandled width (" + ++ show n ++ ")" + | otherwise = GDTOF code dst = x_code `snocOL` opc x_reg dst -- in - return (Any (floatSize to) code) + return (Any (if use_sse2 then floatSize to else FF80) code) -------------------------------------------------------------------------------- @@ -2278,7 +2386,7 @@ let code dst = x_code dst `appOL` amode_code `appOL` toOL [ MOV sz (OpAddr amode) (OpReg tmp), - XOR sz (OpReg tmp) (OpReg dst) - ] + XOR sz (OpReg tmp) (OpReg dst) + ] -- return (Any sz code) diff -Nru ghc-7.0.3/compiler/nativeGen/X86/Instr.hs ghc-7.2.1/compiler/nativeGen/X86/Instr.hs --- ghc-7.0.3/compiler/nativeGen/X86/Instr.hs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/nativeGen/X86/Instr.hs 2011-08-07 17:10:05.000000000 +0000 @@ -21,12 +21,14 @@ import TargetReg import BlockId -import Cmm +import OldCmm import FastString import FastBool import Outputable +import Platform import Constants (rESERVED_C_STACK_BYTES) +import BasicTypes (Alignment) import CLabel import UniqSet import Unique @@ -102,7 +104,7 @@ -} {- -MORE FLOATING POINT MUSINGS... +Note [x86 Floating point precision] Intel's internal floating point registers are by default 80 bit extended precision. This means that all operations done on values in @@ -141,16 +143,16 @@ 128 bit slot (so we get alignment). We spill at 80-bits and ignore the alignment problems. -In the future, we'll use the SSE registers for floating point. This -requires a CPU that supports SSE2 (ordinary SSE only supports 32 bit -precision float ops), which means P4 or Xeon and above. Using SSE -will solve all these problems, because the SSE registers use fixed 32 -bit or 64 bit precision. +In the future [edit: now available in GHC 7.0.1, with the -msse2 +flag], we'll use the SSE registers for floating point. This requires +a CPU that supports SSE2 (ordinary SSE only supports 32 bit precision +float ops), which means P4 or Xeon and above. Using SSE will solve +all these problems, because the SSE registers use fixed 32 bit or 64 +bit precision. --SDM 1/2003 -} - data Instr -- comment pseudo-op = COMMENT FastString @@ -158,7 +160,7 @@ -- some static data spat out during code -- generation. Will be extracted before -- pretty-printing. - | LDATA Section [CmmStatic] + | LDATA Section (Alignment, CmmStatics) -- start a new basic block. Useful during -- codegen, removed later. Preceding @@ -227,6 +229,8 @@ | GITOF Reg Reg -- src(intreg), dst(fpreg) | GITOD Reg Reg -- src(intreg), dst(fpreg) + | GDTOF Reg Reg -- src(fpreg), dst(fpreg) + | GADD Size Reg Reg Reg -- src1, src2, dst | GDIV Size Reg Reg Reg -- src1, src2, dst | GSUB Size Reg Reg Reg -- src1, src2, dst @@ -286,7 +290,11 @@ | 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. @@ -347,7 +355,7 @@ 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] @@ -366,6 +374,8 @@ GITOF src dst -> mkRU [src] [dst] GITOD src dst -> mkRU [src] [dst] + GDTOF src dst -> mkRU [src] [dst] + GADD _ s1 s2 dst -> mkRU [s1,s2] [dst] GSUB _ s1 s2 dst -> mkRU [s1,s2] [dst] GMUL _ s1 s2 dst -> mkRU [s1,s2] [dst] @@ -477,7 +487,7 @@ 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) @@ -492,6 +502,8 @@ GITOF src dst -> GITOF (env src) (env dst) GITOD src dst -> GITOD (env src) (env dst) + GDTOF src dst -> GDTOF (env src) (env dst) + GADD sz s1 s2 dst -> GADD sz (env s1) (env s2) (env dst) GSUB sz s1 s2 dst -> GSUB sz (env s1) (env s2) (env dst) GMUL sz s1 s2 dst -> GMUL sz (env s1) (env s2) (env dst) @@ -572,7 +584,7 @@ x86_jumpDestsOfInstr insn = case insn of JXX _ id -> [id] - JMP_TBL _ ids -> ids + JMP_TBL _ ids _ _ -> [id | Just id <- ids] _ -> [] @@ -582,7 +594,8 @@ 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 @@ -591,16 +604,17 @@ -- ----------------------------------------------------------------------------- -- | Make a spill instruction. x86_mkSpillInstr - :: Reg -- register to spill - -> Int -- current stack delta - -> Int -- spill slot to use - -> Instr + :: Platform + -> Reg -- register to spill + -> Int -- current stack delta + -> Int -- spill slot to use + -> Instr -x86_mkSpillInstr reg delta slot +x86_mkSpillInstr platform reg delta slot = let off = spillSlotToOffset slot in let off_w = (off-delta) `div` IF_ARCH_i386(4,8) - in case targetClassOfReg reg of + in case targetClassOfReg platform reg of RcInteger -> MOV IF_ARCH_i386(II32,II64) (OpReg reg) (OpAddr (spRel off_w)) RcDouble -> GST FF80 reg (spRel off_w) {- RcFloat/RcDouble -} @@ -610,16 +624,17 @@ -- | Make a spill reload instruction. x86_mkLoadInstr - :: Reg -- register to load - -> Int -- current stack delta - -> Int -- spill slot to use - -> Instr + :: Platform + -> Reg -- register to load + -> Int -- current stack delta + -> Int -- spill slot to use + -> Instr -x86_mkLoadInstr reg delta slot +x86_mkLoadInstr platform reg delta slot = let off = spillSlotToOffset slot in let off_w = (off-delta) `div` IF_ARCH_i386(4,8) - in case targetClassOfReg reg of + in case targetClassOfReg platform reg of RcInteger -> MOV IF_ARCH_i386(II32,II64) (OpAddr (spRel off_w)) (OpReg reg) RcDouble -> GLD FF80 (spRel off_w) reg {- RcFloat/RcDouble -} @@ -677,12 +692,13 @@ -- have to go via memory. -- x86_mkRegRegMoveInstr - :: Reg - -> Reg - -> Instr + :: Platform + -> Reg + -> Reg + -> Instr -x86_mkRegRegMoveInstr src dst - = case targetClassOfReg src of +x86_mkRegRegMoveInstr platform src dst + = case targetClassOfReg platform src of #if i386_TARGET_ARCH RcInteger -> MOV II32 (OpReg src) (OpReg dst) #else @@ -734,7 +750,7 @@ where p insn r = case insn of CALL _ _ -> GFREE : insn : r JMP _ -> GFREE : insn : r - JXX_GBL _ _ -> GFREE : insn : r + JXX_GBL _ _ -> panic "i386_insert_ffrees: cannot handle JXX_GBL" _ -> insn : r -- if you ever add a new FP insn to the fake x86 FP insn set, @@ -749,8 +765,9 @@ GLD1{} -> True GFTOI{} -> True GDTOI{} -> True - GITOF{} -> True - GITOD{} -> True + GITOF{} -> True + GITOD{} -> True + GDTOF{} -> True GADD{} -> True GDIV{} -> True GSUB{} -> True @@ -768,6 +785,9 @@ data JumpDest = DestBlockId BlockId | DestImm Imm +getJumpDestBlockId :: JumpDest -> Maybe BlockId +getJumpDestBlockId (DestBlockId bid) = Just bid +getJumpDestBlockId _ = Nothing canShortcut :: Instr -> Maybe JumpDest canShortcut (JXX ALWAYS id) = Just (DestBlockId id) @@ -778,27 +798,35 @@ -- This helper shortcuts a sequence of branches. -- The blockset helps avoid following cycles. shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr -shortcutJump fn insn = shortcutJump' fn emptyBlockSet insn +shortcutJump fn insn = shortcutJump' fn (setEmpty :: BlockSet) insn where shortcutJump' fn seen insn@(JXX cc id) = - if elemBlockSet id seen then insn + if setMember id seen then insn else case fn id of Nothing -> insn Just (DestBlockId id') -> shortcutJump' fn seen' (JXX cc id') Just (DestImm imm) -> shortcutJump' fn seen' (JXX_GBL cc imm) - where seen' = extendBlockSet seen id + where seen' = setInsert id seen shortcutJump' _ _ other = other -- Here because it knows about JumpDest +shortcutStatics :: (BlockId -> Maybe JumpDest) -> (Alignment, CmmStatics) -> (Alignment, CmmStatics) +shortcutStatics fn (align, Statics lbl statics) + = (align, Statics lbl $ map (shortcutStatic fn) statics) + -- we need to get the jump tables, so apply the mapping to the entries + -- of a CmmData too. + +shortcutLabel :: (BlockId -> Maybe JumpDest) -> CLabel -> CLabel +shortcutLabel fn lab + | Just uq <- maybeAsmTemp lab = shortBlockId fn emptyUniqSet (mkBlockId uq) + | otherwise = lab + shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic shortcutStatic fn (CmmStaticLit (CmmLabel lab)) - | Just uq <- maybeAsmTemp lab - = CmmStaticLit (CmmLabel (shortBlockId fn emptyUniqSet (BlockId uq))) + = CmmStaticLit (CmmLabel (shortcutLabel fn lab)) shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off)) - | Just uq <- maybeAsmTemp lbl1 - = CmmStaticLit (CmmLabelDiffOff (shortBlockId fn emptyUniqSet (BlockId uq)) lbl2 off) + = CmmStaticLit (CmmLabelDiffOff (shortcutLabel fn lbl1) lbl2 off) -- slightly dodgy, we're ignoring the second label, but this -- works with the way we use CmmLabelDiffOff for jump tables now. - shortcutStatic _ other_static = other_static @@ -808,10 +836,11 @@ -> BlockId -> CLabel -shortBlockId fn seen blockid@(BlockId uq) = +shortBlockId fn seen blockid = case (elementOfUniqSet uq seen, fn blockid) of (True, _) -> mkAsmTempLabel uq (_, Nothing) -> mkAsmTempLabel uq (_, Just (DestBlockId blockid')) -> shortBlockId fn (addOneToUniqSet seen uq) blockid' (_, Just (DestImm (ImmCLbl lbl))) -> lbl (_, _other) -> panic "shortBlockId" + where uq = getUnique blockid diff -Nru ghc-7.0.3/compiler/nativeGen/X86/Ppr.hs ghc-7.2.1/compiler/nativeGen/X86/Ppr.hs --- ghc-7.0.3/compiler/nativeGen/X86/Ppr.hs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/nativeGen/X86/Ppr.hs 2011-08-07 17:10:05.000000000 +0000 @@ -7,15 +7,14 @@ ----------------------------------------------------------------------------- module X86.Ppr ( - pprNatCmmTop, - pprBasicBlock, - pprSectionHeader, - pprData, - pprInstr, - pprUserReg, - pprSize, - pprImm, - pprDataItem, + pprNatCmmTop, + pprBasicBlock, + pprSectionHeader, + pprData, + pprInstr, + pprSize, + pprImm, + pprDataItem, ) where @@ -32,14 +31,15 @@ import PprBase -import BlockId -import Cmm +import BasicTypes (Alignment) +import OldCmm import CLabel -import Unique ( pprUnique ) +import Unique ( pprUnique, Uniquable(..) ) +import Platform import Pretty import FastString import qualified Outputable -import Outputable (panic, Outputable) +import Outputable (panic, PlatformOutputable) import Data.Word @@ -50,26 +50,31 @@ -- ----------------------------------------------------------------------------- -- Printing this stuff out -pprNatCmmTop :: NatCmmTop Instr -> Doc -pprNatCmmTop (CmmData section dats) = - pprSectionHeader section $$ vcat (map pprData dats) +pprNatCmmTop :: Platform -> NatCmmTop (Alignment, CmmStatics) Instr -> Doc +pprNatCmmTop platform (CmmData section dats) = + pprSectionHeader section $$ pprDatas platform dats -- special case for split markers: -pprNatCmmTop (CmmProc [] lbl _ (ListGraph [])) = pprLabel lbl +pprNatCmmTop platform (CmmProc Nothing lbl (ListGraph [])) = pprLabel platform lbl -pprNatCmmTop (CmmProc info lbl _ (ListGraph blocks)) = + -- special case for code without info table: +pprNatCmmTop platform (CmmProc Nothing lbl (ListGraph blocks)) = pprSectionHeader Text $$ - (if null info then -- blocks guaranteed not null, so label needed - pprLabel lbl - else + pprLabel platform lbl $$ -- blocks guaranteed not null, so label needed + vcat (map (pprBasicBlock platform) blocks) $$ + pprSizeDecl platform lbl + +pprNatCmmTop platform (CmmProc (Just (Statics info_lbl info)) _entry_lbl (ListGraph blocks)) = + pprSectionHeader Text $$ + ( #if HAVE_SUBSECTIONS_VIA_SYMBOLS - pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl) - <> char ':' $$ + pprCLabel_asm (mkDeadStripPreventer info_lbl) + <> char ':' $$ #endif - vcat (map pprData info) $$ - pprLabel (entryLblToInfoLbl lbl) + vcat (map (pprData platform) info) $$ + pprLabel platform info_lbl ) $$ - vcat (map pprBasicBlock blocks) + vcat (map (pprBasicBlock platform) blocks) -- above: Even the first block gets a label, because with branch-chain -- elimination, it might be the target of a goto. #if HAVE_SUBSECTIONS_VIA_SYMBOLS @@ -79,54 +84,57 @@ -- from the entry code to a label on the _top_ of of the info table, -- so that the linker will not think it is unreferenced and dead-strip -- it. That's why the label is called a DeadStripPreventer (_dsp). - $$ if not (null info) - then text "\t.long " - <+> pprCLabel_asm (entryLblToInfoLbl lbl) - <+> char '-' - <+> pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl) - else empty + $$ text "\t.long " + <+> pprCLabel_asm info_lbl + <+> char '-' + <+> pprCLabel_asm (mkDeadStripPreventer info_lbl) #endif + $$ pprSizeDecl platform info_lbl +-- | Output the ELF .size directive. +pprSizeDecl :: Platform -> CLabel -> Doc +pprSizeDecl platform lbl + | osElfTarget (platformOS platform) = + ptext (sLit "\t.size") <+> pprCLabel_asm lbl + <> ptext (sLit ", .-") <> pprCLabel_asm lbl + | otherwise = empty + +pprBasicBlock :: Platform -> NatBasicBlock Instr -> Doc +pprBasicBlock platform (BasicBlock blockid instrs) = + pprLabel platform (mkAsmTempLabel (getUnique blockid)) $$ + vcat (map (pprInstr platform) instrs) + + +pprDatas :: Platform -> (Alignment, CmmStatics) -> Doc +pprDatas platform (align, (Statics lbl dats)) + = vcat (pprAlign platform align : pprLabel platform lbl : map (pprData platform) dats) + -- TODO: could remove if align == 1 + +pprData :: Platform -> CmmStatic -> Doc +pprData _ (CmmString str) = pprASCII str + +pprData platform (CmmUninitialised bytes) + | platformOS platform == OSDarwin = ptext (sLit ".space ") <> int bytes + | otherwise = ptext (sLit ".skip ") <> int bytes -pprBasicBlock :: NatBasicBlock Instr -> Doc -pprBasicBlock (BasicBlock (BlockId id) instrs) = - pprLabel (mkAsmTempLabel id) $$ - vcat (map pprInstr instrs) - - -pprData :: CmmStatic -> Doc -pprData (CmmAlign bytes) = pprAlign bytes -pprData (CmmDataLabel lbl) = pprLabel lbl -pprData (CmmString str) = pprASCII str - -#if darwin_TARGET_OS -pprData (CmmUninitialised bytes) = ptext (sLit ".space ") <> int bytes -#else -pprData (CmmUninitialised bytes) = ptext (sLit ".skip ") <> int bytes -#endif - -pprData (CmmStaticLit lit) = pprDataItem lit +pprData _ (CmmStaticLit lit) = pprDataItem lit pprGloblDecl :: CLabel -> Doc pprGloblDecl lbl | not (externallyVisibleCLabel lbl) = empty - | otherwise = ptext IF_ARCH_sparc((sLit ".global "), - (sLit ".globl ")) <> - pprCLabel_asm lbl - -pprTypeAndSizeDecl :: CLabel -> Doc -#if elf_OBJ_FORMAT -pprTypeAndSizeDecl lbl - | not (externallyVisibleCLabel lbl) = empty - | otherwise = ptext (sLit ".type ") <> - pprCLabel_asm lbl <> ptext (sLit ", @object") -#else -pprTypeAndSizeDecl _ - = empty -#endif + | otherwise = ptext (sLit ".globl ") <> pprCLabel_asm lbl -pprLabel :: CLabel -> Doc -pprLabel lbl = pprGloblDecl lbl $$ pprTypeAndSizeDecl lbl $$ (pprCLabel_asm lbl <> char ':') +pprTypeAndSizeDecl :: Platform -> CLabel -> Doc +pprTypeAndSizeDecl platform lbl + | osElfTarget (platformOS platform) && externallyVisibleCLabel lbl + = ptext (sLit ".type ") <> + pprCLabel_asm lbl <> ptext (sLit ", @object") + | otherwise = empty + +pprLabel :: Platform -> CLabel -> Doc +pprLabel platform lbl = pprGloblDecl lbl + $$ pprTypeAndSizeDecl platform lbl + $$ (pprCLabel_asm lbl <> char ':') pprASCII :: [Word8] -> Doc @@ -136,44 +144,30 @@ do1 :: Word8 -> Doc do1 w = ptext (sLit "\t.byte\t") <> int (fromIntegral w) -pprAlign :: Int -> Doc - - -pprAlign bytes - = ptext (sLit ".align ") <> int IF_OS_darwin(pow2, bytes) +pprAlign :: Platform -> Int -> Doc +pprAlign platform bytes + = ptext (sLit ".align ") <> int alignment where - -#if darwin_TARGET_OS - pow2 = log2 bytes - - log2 :: Int -> Int -- cache the common ones - log2 1 = 0 - log2 2 = 1 - log2 4 = 2 - log2 8 = 3 - log2 n = 1 + log2 (n `quot` 2) -#endif + alignment = if platformOS platform == OSDarwin + then log2 bytes + else bytes + + log2 :: Int -> Int -- cache the common ones + log2 1 = 0 + log2 2 = 1 + log2 4 = 2 + log2 8 = 3 + log2 n = 1 + log2 (n `quot` 2) -- ----------------------------------------------------------------------------- -- pprInstr: print an 'Instr' -instance Outputable Instr where - ppr instr = Outputable.docToSDoc $ pprInstr instr - +instance PlatformOutputable Instr where + pprPlatform platform instr = Outputable.docToSDoc $ pprInstr platform instr -#if i386_TARGET_ARCH || x86_64_TARGET_ARCH -pprUserReg :: Reg -> Doc -pprUserReg = pprReg IF_ARCH_i386(II32,) IF_ARCH_x86_64(II64,) -#else -pprUserReg :: Reg -> Doc -pprUserReg = panic "X86.Ppr.pprUserReg: not defined" - -#endif - -pprReg :: Size -> Reg -> Doc - -pprReg s r +pprReg :: Platform -> Size -> Reg -> Doc +pprReg _ s r = case r of RegReal (RealRegSingle i) -> ppr_reg_no s i RegReal (RealRegPair _ _) -> panic "X86.Ppr: no reg pairs on this arch" @@ -191,26 +185,26 @@ ppr_reg_byte i = ptext (case i of { - 0 -> sLit "%al"; 1 -> sLit "%bl"; - 2 -> sLit "%cl"; 3 -> sLit "%dl"; - _ -> sLit "very naughty I386 byte register" + 0 -> sLit "%al"; 1 -> sLit "%bl"; + 2 -> sLit "%cl"; 3 -> sLit "%dl"; + _ -> sLit "very naughty I386 byte register" }) ppr_reg_word i = ptext (case i of { - 0 -> sLit "%ax"; 1 -> sLit "%bx"; - 2 -> sLit "%cx"; 3 -> sLit "%dx"; - 4 -> sLit "%si"; 5 -> sLit "%di"; - 6 -> sLit "%bp"; 7 -> sLit "%sp"; - _ -> sLit "very naughty I386 word register" + 0 -> sLit "%ax"; 1 -> sLit "%bx"; + 2 -> sLit "%cx"; 3 -> sLit "%dx"; + 4 -> sLit "%si"; 5 -> sLit "%di"; + 6 -> sLit "%bp"; 7 -> sLit "%sp"; + _ -> sLit "very naughty I386 word register" }) ppr_reg_long i = ptext (case i of { - 0 -> sLit "%eax"; 1 -> sLit "%ebx"; - 2 -> sLit "%ecx"; 3 -> sLit "%edx"; - 4 -> sLit "%esi"; 5 -> sLit "%edi"; - 6 -> sLit "%ebp"; 7 -> sLit "%esp"; + 0 -> sLit "%eax"; 1 -> sLit "%ebx"; + 2 -> sLit "%ecx"; 3 -> sLit "%edx"; + 4 -> sLit "%esi"; 5 -> sLit "%edi"; + 6 -> sLit "%ebp"; 7 -> sLit "%esp"; _ -> ppr_reg_float i }) #elif x86_64_TARGET_ARCH @@ -222,53 +216,53 @@ ppr_reg_byte i = ptext (case i of { - 0 -> sLit "%al"; 1 -> sLit "%bl"; - 2 -> sLit "%cl"; 3 -> sLit "%dl"; - 4 -> sLit "%sil"; 5 -> sLit "%dil"; -- new 8-bit regs! - 6 -> sLit "%bpl"; 7 -> sLit "%spl"; - 8 -> sLit "%r8b"; 9 -> sLit "%r9b"; - 10 -> sLit "%r10b"; 11 -> sLit "%r11b"; - 12 -> sLit "%r12b"; 13 -> sLit "%r13b"; - 14 -> sLit "%r14b"; 15 -> sLit "%r15b"; - _ -> sLit "very naughty x86_64 byte register" + 0 -> sLit "%al"; 1 -> sLit "%bl"; + 2 -> sLit "%cl"; 3 -> sLit "%dl"; + 4 -> sLit "%sil"; 5 -> sLit "%dil"; -- new 8-bit regs! + 6 -> sLit "%bpl"; 7 -> sLit "%spl"; + 8 -> sLit "%r8b"; 9 -> sLit "%r9b"; + 10 -> sLit "%r10b"; 11 -> sLit "%r11b"; + 12 -> sLit "%r12b"; 13 -> sLit "%r13b"; + 14 -> sLit "%r14b"; 15 -> sLit "%r15b"; + _ -> sLit "very naughty x86_64 byte register" }) ppr_reg_word i = ptext (case i of { - 0 -> sLit "%ax"; 1 -> sLit "%bx"; - 2 -> sLit "%cx"; 3 -> sLit "%dx"; - 4 -> sLit "%si"; 5 -> sLit "%di"; - 6 -> sLit "%bp"; 7 -> sLit "%sp"; - 8 -> sLit "%r8w"; 9 -> sLit "%r9w"; - 10 -> sLit "%r10w"; 11 -> sLit "%r11w"; - 12 -> sLit "%r12w"; 13 -> sLit "%r13w"; - 14 -> sLit "%r14w"; 15 -> sLit "%r15w"; - _ -> sLit "very naughty x86_64 word register" + 0 -> sLit "%ax"; 1 -> sLit "%bx"; + 2 -> sLit "%cx"; 3 -> sLit "%dx"; + 4 -> sLit "%si"; 5 -> sLit "%di"; + 6 -> sLit "%bp"; 7 -> sLit "%sp"; + 8 -> sLit "%r8w"; 9 -> sLit "%r9w"; + 10 -> sLit "%r10w"; 11 -> sLit "%r11w"; + 12 -> sLit "%r12w"; 13 -> sLit "%r13w"; + 14 -> sLit "%r14w"; 15 -> sLit "%r15w"; + _ -> sLit "very naughty x86_64 word register" }) ppr_reg_long i = ptext (case i of { - 0 -> sLit "%eax"; 1 -> sLit "%ebx"; - 2 -> sLit "%ecx"; 3 -> sLit "%edx"; - 4 -> sLit "%esi"; 5 -> sLit "%edi"; - 6 -> sLit "%ebp"; 7 -> sLit "%esp"; - 8 -> sLit "%r8d"; 9 -> sLit "%r9d"; - 10 -> sLit "%r10d"; 11 -> sLit "%r11d"; - 12 -> sLit "%r12d"; 13 -> sLit "%r13d"; - 14 -> sLit "%r14d"; 15 -> sLit "%r15d"; - _ -> sLit "very naughty x86_64 register" + 0 -> sLit "%eax"; 1 -> sLit "%ebx"; + 2 -> sLit "%ecx"; 3 -> sLit "%edx"; + 4 -> sLit "%esi"; 5 -> sLit "%edi"; + 6 -> sLit "%ebp"; 7 -> sLit "%esp"; + 8 -> sLit "%r8d"; 9 -> sLit "%r9d"; + 10 -> sLit "%r10d"; 11 -> sLit "%r11d"; + 12 -> sLit "%r12d"; 13 -> sLit "%r13d"; + 14 -> sLit "%r14d"; 15 -> sLit "%r15d"; + _ -> sLit "very naughty x86_64 register" }) ppr_reg_quad i = ptext (case i of { - 0 -> sLit "%rax"; 1 -> sLit "%rbx"; - 2 -> sLit "%rcx"; 3 -> sLit "%rdx"; - 4 -> sLit "%rsi"; 5 -> sLit "%rdi"; - 6 -> sLit "%rbp"; 7 -> sLit "%rsp"; - 8 -> sLit "%r8"; 9 -> sLit "%r9"; - 10 -> sLit "%r10"; 11 -> sLit "%r11"; - 12 -> sLit "%r12"; 13 -> sLit "%r13"; - 14 -> sLit "%r14"; 15 -> sLit "%r15"; + 0 -> sLit "%rax"; 1 -> sLit "%rbx"; + 2 -> sLit "%rcx"; 3 -> sLit "%rdx"; + 4 -> sLit "%rsi"; 5 -> sLit "%rdi"; + 6 -> sLit "%rbp"; 7 -> sLit "%rsp"; + 8 -> sLit "%r8"; 9 -> sLit "%r9"; + 10 -> sLit "%r10"; 11 -> sLit "%r11"; + 12 -> sLit "%r12"; 13 -> sLit "%r13"; + 14 -> sLit "%r14"; 15 -> sLit "%r15"; _ -> ppr_reg_float i }) #else @@ -278,52 +272,52 @@ #if defined(i386_TARGET_ARCH) || defined(x86_64_TARGET_ARCH) ppr_reg_float :: Int -> LitString ppr_reg_float i = case i of - 16 -> sLit "%fake0"; 17 -> sLit "%fake1" - 18 -> sLit "%fake2"; 19 -> sLit "%fake3" - 20 -> sLit "%fake4"; 21 -> sLit "%fake5" - 24 -> sLit "%xmm0"; 25 -> sLit "%xmm1" - 26 -> sLit "%xmm2"; 27 -> sLit "%xmm3" - 28 -> sLit "%xmm4"; 29 -> sLit "%xmm5" - 30 -> sLit "%xmm6"; 31 -> sLit "%xmm7" - 32 -> sLit "%xmm8"; 33 -> sLit "%xmm9" - 34 -> sLit "%xmm10"; 35 -> sLit "%xmm11" - 36 -> sLit "%xmm12"; 37 -> sLit "%xmm13" - 38 -> sLit "%xmm14"; 39 -> sLit "%xmm15" - _ -> sLit "very naughty x86 register" + 16 -> sLit "%fake0"; 17 -> sLit "%fake1" + 18 -> sLit "%fake2"; 19 -> sLit "%fake3" + 20 -> sLit "%fake4"; 21 -> sLit "%fake5" + 24 -> sLit "%xmm0"; 25 -> sLit "%xmm1" + 26 -> sLit "%xmm2"; 27 -> sLit "%xmm3" + 28 -> sLit "%xmm4"; 29 -> sLit "%xmm5" + 30 -> sLit "%xmm6"; 31 -> sLit "%xmm7" + 32 -> sLit "%xmm8"; 33 -> sLit "%xmm9" + 34 -> sLit "%xmm10"; 35 -> sLit "%xmm11" + 36 -> sLit "%xmm12"; 37 -> sLit "%xmm13" + 38 -> sLit "%xmm14"; 39 -> sLit "%xmm15" + _ -> sLit "very naughty x86 register" #endif pprSize :: Size -> Doc -pprSize x +pprSize x = ptext (case x of - II8 -> sLit "b" - II16 -> sLit "w" - II32 -> sLit "l" - II64 -> sLit "q" - FF32 -> sLit "ss" -- "scalar single-precision float" (SSE2) - FF64 -> sLit "sd" -- "scalar double-precision float" (SSE2) - FF80 -> sLit "t" - ) + II8 -> sLit "b" + II16 -> sLit "w" + II32 -> sLit "l" + II64 -> sLit "q" + FF32 -> sLit "ss" -- "scalar single-precision float" (SSE2) + FF64 -> sLit "sd" -- "scalar double-precision float" (SSE2) + FF80 -> sLit "t" + ) pprSize_x87 :: Size -> Doc pprSize_x87 x = ptext $ case x of - FF32 -> sLit "s" - FF64 -> sLit "l" - FF80 -> sLit "t" + FF32 -> sLit "s" + FF64 -> sLit "l" + FF80 -> sLit "t" _ -> panic "X86.Ppr.pprSize_x87" pprCond :: Cond -> Doc pprCond c = ptext (case c of { - GEU -> sLit "ae"; LU -> sLit "b"; - EQQ -> sLit "e"; GTT -> sLit "g"; - GE -> sLit "ge"; GU -> sLit "a"; - LTT -> sLit "l"; LE -> sLit "le"; - LEU -> sLit "be"; NE -> sLit "ne"; - NEG -> sLit "s"; POS -> sLit "ns"; - CARRY -> sLit "c"; OFLO -> sLit "o"; - PARITY -> sLit "p"; NOTPARITY -> sLit "np"; - ALWAYS -> sLit "mp"}) + GEU -> sLit "ae"; LU -> sLit "b"; + EQQ -> sLit "e"; GTT -> sLit "g"; + GE -> sLit "ge"; GU -> sLit "a"; + LTT -> sLit "l"; LE -> sLit "le"; + LEU -> sLit "be"; NE -> sLit "ne"; + NEG -> sLit "s"; POS -> sLit "ns"; + CARRY -> sLit "c"; OFLO -> sLit "o"; + PARITY -> sLit "p"; NOTPARITY -> sLit "np"; + ALWAYS -> sLit "mp"}) pprImm :: Imm -> Doc @@ -342,32 +336,32 @@ -pprAddr :: AddrMode -> Doc -pprAddr (ImmAddr imm off) - = let pp_imm = pprImm imm +pprAddr :: Platform -> AddrMode -> Doc +pprAddr _ (ImmAddr imm off) + = let pp_imm = pprImm imm in if (off == 0) then - pp_imm + pp_imm else if (off < 0) then - pp_imm <> int off + pp_imm <> int off else - pp_imm <> char '+' <> int off + pp_imm <> char '+' <> int off -pprAddr (AddrBaseIndex base index displacement) +pprAddr platform (AddrBaseIndex base index displacement) = let - pp_disp = ppr_disp displacement - pp_off p = pp_disp <> char '(' <> p <> char ')' - pp_reg r = pprReg archWordSize r + pp_disp = ppr_disp displacement + pp_off p = pp_disp <> char '(' <> p <> char ')' + pp_reg r = pprReg platform archWordSize r in case (base, index) of (EABaseNone, EAIndexNone) -> pp_disp (EABaseReg b, EAIndexNone) -> pp_off (pp_reg b) (EABaseRip, EAIndexNone) -> pp_off (ptext (sLit "%rip")) (EABaseNone, EAIndex r i) -> pp_off (comma <> pp_reg r <> comma <> int i) - (EABaseReg b, EAIndex r i) -> pp_off (pp_reg b <> comma <> pp_reg r + (EABaseReg b, EAIndex r i) -> pp_off (pp_reg b <> comma <> pp_reg r <> comma <> int i) - _ -> panic "X86.Ppr.pprAddr: no match" - + _ -> panic "X86.Ppr.pprAddr: no match" + where ppr_disp (ImmInt 0) = empty ppr_disp imm = pprImm imm @@ -376,57 +370,57 @@ pprSectionHeader :: Section -> Doc #if i386_TARGET_ARCH -# if darwin_TARGET_OS +# if darwin_TARGET_OS pprSectionHeader seg = case seg of - Text -> ptext (sLit ".text\n\t.align 2") - Data -> ptext (sLit ".data\n\t.align 2") - ReadOnlyData -> ptext (sLit ".const\n.align 2") - RelocatableReadOnlyData -> ptext (sLit ".const_data\n.align 2") - UninitialisedData -> ptext (sLit ".data\n\t.align 2") - ReadOnlyData16 -> ptext (sLit ".const\n.align 4") - OtherSection _ -> panic "X86.Ppr.pprSectionHeader: unknown section" + Text -> ptext (sLit ".text\n\t.align 2") + Data -> ptext (sLit ".data\n\t.align 2") + ReadOnlyData -> ptext (sLit ".const\n.align 2") + RelocatableReadOnlyData -> ptext (sLit ".const_data\n.align 2") + UninitialisedData -> ptext (sLit ".data\n\t.align 2") + ReadOnlyData16 -> ptext (sLit ".const\n.align 4") + OtherSection _ -> panic "X86.Ppr.pprSectionHeader: unknown section" # else pprSectionHeader seg = case seg of - Text -> ptext (sLit ".text\n\t.align 4,0x90") - Data -> ptext (sLit ".data\n\t.align 4") - ReadOnlyData -> ptext (sLit ".section .rodata\n\t.align 4") - RelocatableReadOnlyData -> ptext (sLit ".section .data\n\t.align 4") - UninitialisedData -> ptext (sLit ".section .bss\n\t.align 4") - ReadOnlyData16 -> ptext (sLit ".section .rodata\n\t.align 16") - OtherSection _ -> panic "X86.Ppr.pprSectionHeader: unknown section" + Text -> ptext (sLit ".text\n\t.align 4,0x90") + Data -> ptext (sLit ".data\n\t.align 4") + ReadOnlyData -> ptext (sLit ".section .rodata\n\t.align 4") + RelocatableReadOnlyData -> ptext (sLit ".section .data\n\t.align 4") + UninitialisedData -> ptext (sLit ".section .bss\n\t.align 4") + ReadOnlyData16 -> ptext (sLit ".section .rodata\n\t.align 16") + OtherSection _ -> panic "X86.Ppr.pprSectionHeader: unknown section" # endif #elif x86_64_TARGET_ARCH -# if darwin_TARGET_OS +# if darwin_TARGET_OS pprSectionHeader seg = case seg of - Text -> ptext (sLit ".text\n.align 3") - Data -> ptext (sLit ".data\n.align 3") - ReadOnlyData -> ptext (sLit ".const\n.align 3") - RelocatableReadOnlyData -> ptext (sLit ".const_data\n.align 3") - UninitialisedData -> ptext (sLit ".data\n\t.align 3") - ReadOnlyData16 -> ptext (sLit ".const\n.align 4") - OtherSection _ -> panic "PprMach.pprSectionHeader: unknown section" + Text -> ptext (sLit ".text\n.align 3") + Data -> ptext (sLit ".data\n.align 3") + ReadOnlyData -> ptext (sLit ".const\n.align 3") + RelocatableReadOnlyData -> ptext (sLit ".const_data\n.align 3") + UninitialisedData -> ptext (sLit ".data\n\t.align 3") + ReadOnlyData16 -> ptext (sLit ".const\n.align 4") + OtherSection _ -> panic "PprMach.pprSectionHeader: unknown section" # else pprSectionHeader seg = case seg of - Text -> ptext (sLit ".text\n\t.align 8") - Data -> ptext (sLit ".data\n\t.align 8") - ReadOnlyData -> ptext (sLit ".section .rodata\n\t.align 8") - RelocatableReadOnlyData -> ptext (sLit ".section .data\n\t.align 8") - UninitialisedData -> ptext (sLit ".section .bss\n\t.align 8") - ReadOnlyData16 -> ptext (sLit ".section .rodata.cst16\n\t.align 16") - OtherSection _ -> panic "PprMach.pprSectionHeader: unknown section" + Text -> ptext (sLit ".text\n\t.align 8") + Data -> ptext (sLit ".data\n\t.align 8") + ReadOnlyData -> ptext (sLit ".section .rodata\n\t.align 8") + RelocatableReadOnlyData -> ptext (sLit ".section .data\n\t.align 8") + UninitialisedData -> ptext (sLit ".section .bss\n\t.align 8") + ReadOnlyData16 -> ptext (sLit ".section .rodata.cst16\n\t.align 16") + OtherSection _ -> panic "PprMach.pprSectionHeader: unknown section" # endif #else -pprSectionHeader _ = panic "X86.Ppr.pprSectionHeader: not defined for this architecture" +pprSectionHeader _ = panic "X86.Ppr.pprSectionHeader: not defined for this architecture" #endif @@ -437,22 +431,22 @@ pprDataItem lit = vcat (ppr_item (cmmTypeSize $ cmmLitType lit) lit) where - imm = litToImm lit + imm = litToImm lit - -- These seem to be common: - ppr_item II8 _ = [ptext (sLit "\t.byte\t") <> pprImm imm] - ppr_item II32 _ = [ptext (sLit "\t.long\t") <> pprImm imm] + -- These seem to be common: + ppr_item II8 _ = [ptext (sLit "\t.byte\t") <> pprImm imm] + ppr_item II32 _ = [ptext (sLit "\t.long\t") <> pprImm imm] - ppr_item FF32 (CmmFloat r _) + ppr_item FF32 (CmmFloat r _) = let bs = floatToBytes (fromRational r) in map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs - ppr_item FF64 (CmmFloat r _) + ppr_item FF64 (CmmFloat r _) = let bs = doubleToBytes (fromRational r) in map (\b -> ptext (sLit "\t.byte\t") <> pprImm (ImmInt b)) bs #if i386_TARGET_ARCH || x86_64_TARGET_ARCH - ppr_item II16 _ = [ptext (sLit "\t.word\t") <> pprImm imm] + ppr_item II16 _ = [ptext (sLit "\t.word\t") <> pprImm imm] #endif #if i386_TARGET_ARCH && darwin_TARGET_OS ppr_item II64 (CmmInt x _) = @@ -463,207 +457,199 @@ (fromIntegral (x `shiftR` 32) :: Word32))] #endif #if i386_TARGET_ARCH || (darwin_TARGET_OS && x86_64_TARGET_ARCH) - ppr_item II64 _ = [ptext (sLit "\t.quad\t") <> pprImm imm] + ppr_item II64 _ = [ptext (sLit "\t.quad\t") <> pprImm imm] #endif #if x86_64_TARGET_ARCH && !darwin_TARGET_OS - -- x86_64: binutils can't handle the R_X86_64_PC64 relocation - -- type, which means we can't do pc-relative 64-bit addresses. - -- Fortunately we're assuming the small memory model, in which - -- all such offsets will fit into 32 bits, so we have to stick - -- to 32-bit offset fields and modify the RTS appropriately + -- x86_64: binutils can't handle the R_X86_64_PC64 relocation + -- type, which means we can't do pc-relative 64-bit addresses. + -- Fortunately we're assuming the small memory model, in which + -- all such offsets will fit into 32 bits, so we have to stick + -- to 32-bit offset fields and modify the RTS appropriately -- -- See Note [x86-64-relative] in includes/rts/storage/InfoTables.h - -- - ppr_item II64 x - | isRelativeReloc x = - [ptext (sLit "\t.long\t") <> pprImm imm, - ptext (sLit "\t.long\t0")] - | otherwise = - [ptext (sLit "\t.quad\t") <> pprImm imm] - where - isRelativeReloc (CmmLabelDiffOff _ _ _) = True - isRelativeReloc _ = False + -- + ppr_item II64 x + | isRelativeReloc x = + [ptext (sLit "\t.long\t") <> pprImm imm, + ptext (sLit "\t.long\t0")] + | otherwise = + [ptext (sLit "\t.quad\t") <> pprImm imm] + where + isRelativeReloc (CmmLabelDiffOff _ _ _) = True + isRelativeReloc _ = False #endif - ppr_item _ _ - = panic "X86.Ppr.ppr_item: no match" + ppr_item _ _ + = panic "X86.Ppr.ppr_item: no match" -pprInstr :: Instr -> Doc +pprInstr :: Platform -> Instr -> Doc -pprInstr (COMMENT _) = empty -- nuke 'em +pprInstr _ (COMMENT _) = empty -- nuke 'em {- -pprInstr (COMMENT s) - = IF_ARCH_alpha( ((<>) (ptext (sLit "\t# ")) (ftext s)) - ,IF_ARCH_sparc( ((<>) (ptext (sLit "# ")) (ftext s)) - ,IF_ARCH_i386( ((<>) (ptext (sLit "# ")) (ftext s)) - ,IF_ARCH_x86_64( ((<>) (ptext (sLit "# ")) (ftext s)) - ,IF_ARCH_powerpc( IF_OS_linux( - ((<>) (ptext (sLit "# ")) (ftext s)), - ((<>) (ptext (sLit "; ")) (ftext s))) - ,))))) +pprInstr _ (COMMENT s) = ptext (sLit "# ") <> ftext s -} -pprInstr (DELTA d) - = pprInstr (COMMENT (mkFastString ("\tdelta = " ++ show d))) +pprInstr platform (DELTA d) + = pprInstr platform (COMMENT (mkFastString ("\tdelta = " ++ show d))) -pprInstr (NEWBLOCK _) +pprInstr _ (NEWBLOCK _) = panic "PprMach.pprInstr: NEWBLOCK" -pprInstr (LDATA _ _) +pprInstr _ (LDATA _ _) = panic "PprMach.pprInstr: LDATA" {- -pprInstr (SPILL reg slot) +pprInstr _ (SPILL reg slot) = hcat [ - ptext (sLit "\tSPILL"), - char ' ', - pprUserReg reg, - comma, - ptext (sLit "SLOT") <> parens (int slot)] + ptext (sLit "\tSPILL"), + char ' ', + pprUserReg reg, + comma, + ptext (sLit "SLOT") <> parens (int slot)] -pprInstr (RELOAD slot reg) +pprInstr _ (RELOAD slot reg) = hcat [ - ptext (sLit "\tRELOAD"), - char ' ', - ptext (sLit "SLOT") <> parens (int slot), - comma, - pprUserReg reg] + ptext (sLit "\tRELOAD"), + char ' ', + ptext (sLit "SLOT") <> parens (int slot), + comma, + pprUserReg reg] -} -pprInstr (MOV size src dst) - = pprSizeOpOp (sLit "mov") size src dst +pprInstr platform (MOV size src dst) + = pprSizeOpOp platform (sLit "mov") size src dst -pprInstr (MOVZxL II32 src dst) = pprSizeOpOp (sLit "mov") II32 src dst - -- 32-to-64 bit zero extension on x86_64 is accomplished by a simple - -- movl. But we represent it as a MOVZxL instruction, because - -- the reg alloc would tend to throw away a plain reg-to-reg - -- move, and we still want it to do that. - -pprInstr (MOVZxL sizes src dst) = pprSizeOpOpCoerce (sLit "movz") sizes II32 src dst - -- zero-extension only needs to extend to 32 bits: on x86_64, - -- the remaining zero-extension to 64 bits is automatic, and the 32-bit - -- instruction is shorter. +pprInstr platform (MOVZxL II32 src dst) = pprSizeOpOp platform (sLit "mov") II32 src dst + -- 32-to-64 bit zero extension on x86_64 is accomplished by a simple + -- movl. But we represent it as a MOVZxL instruction, because + -- the reg alloc would tend to throw away a plain reg-to-reg + -- move, and we still want it to do that. + +pprInstr platform (MOVZxL sizes src dst) = pprSizeOpOpCoerce platform (sLit "movz") sizes II32 src dst + -- zero-extension only needs to extend to 32 bits: on x86_64, + -- the remaining zero-extension to 64 bits is automatic, and the 32-bit + -- instruction is shorter. -pprInstr (MOVSxL sizes src dst) = pprSizeOpOpCoerce (sLit "movs") sizes archWordSize src dst +pprInstr platform (MOVSxL sizes src dst) = pprSizeOpOpCoerce platform (sLit "movs") sizes archWordSize src dst -- here we do some patching, since the physical registers are only set late -- in the code generation. -pprInstr (LEA size (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3)) +pprInstr platform (LEA size (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3)) | reg1 == reg3 - = pprSizeOpOp (sLit "add") size (OpReg reg2) dst + = pprSizeOpOp platform (sLit "add") size (OpReg reg2) dst -pprInstr (LEA size (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3)) +pprInstr platform (LEA size (OpAddr (AddrBaseIndex (EABaseReg reg1) (EAIndex reg2 1) (ImmInt 0))) dst@(OpReg reg3)) | reg2 == reg3 - = pprSizeOpOp (sLit "add") size (OpReg reg1) dst + = pprSizeOpOp platform (sLit "add") size (OpReg reg1) dst -pprInstr (LEA size (OpAddr (AddrBaseIndex (EABaseReg reg1) EAIndexNone displ)) dst@(OpReg reg3)) +pprInstr platform (LEA size (OpAddr (AddrBaseIndex (EABaseReg reg1) EAIndexNone displ)) dst@(OpReg reg3)) | reg1 == reg3 - = pprInstr (ADD size (OpImm displ) dst) + = pprInstr platform (ADD size (OpImm displ) dst) -pprInstr (LEA size src dst) = pprSizeOpOp (sLit "lea") size src dst +pprInstr platform (LEA size src dst) = pprSizeOpOp platform (sLit "lea") size src dst -pprInstr (ADD size (OpImm (ImmInt (-1))) dst) - = pprSizeOp (sLit "dec") size dst -pprInstr (ADD size (OpImm (ImmInt 1)) dst) - = pprSizeOp (sLit "inc") size dst -pprInstr (ADD size src dst) - = pprSizeOpOp (sLit "add") size src dst -pprInstr (ADC size src dst) - = pprSizeOpOp (sLit "adc") size src dst -pprInstr (SUB size src dst) = pprSizeOpOp (sLit "sub") size src dst -pprInstr (IMUL size op1 op2) = pprSizeOpOp (sLit "imul") size op1 op2 +pprInstr platform (ADD size (OpImm (ImmInt (-1))) dst) + = pprSizeOp platform (sLit "dec") size dst +pprInstr platform (ADD size (OpImm (ImmInt 1)) dst) + = pprSizeOp platform (sLit "inc") size dst +pprInstr platform (ADD size src dst) + = pprSizeOpOp platform (sLit "add") size src dst +pprInstr platform (ADC size src dst) + = pprSizeOpOp platform (sLit "adc") size src dst +pprInstr platform (SUB size src dst) = pprSizeOpOp platform (sLit "sub") size src dst +pprInstr platform (IMUL size op1 op2) = pprSizeOpOp platform (sLit "imul") size op1 op2 {- A hack. The Intel documentation says that "The two and three operand forms [of IMUL] may also be used with unsigned operands because the lower half of the product is the same regardless if (sic) the operands are signed or unsigned. The CF and OF flags, however, cannot be used to determine if the upper half of the - result is non-zero." So there. --} -pprInstr (AND size src dst) = pprSizeOpOp (sLit "and") size src dst -pprInstr (OR size src dst) = pprSizeOpOp (sLit "or") size src dst - -pprInstr (XOR FF32 src dst) = pprOpOp (sLit "xorps") FF32 src dst -pprInstr (XOR FF64 src dst) = pprOpOp (sLit "xorpd") FF64 src dst -pprInstr (XOR size src dst) = pprSizeOpOp (sLit "xor") size src dst - -pprInstr (NOT size op) = pprSizeOp (sLit "not") size op -pprInstr (NEGI size op) = pprSizeOp (sLit "neg") size op - -pprInstr (SHL size src dst) = pprShift (sLit "shl") size src dst -pprInstr (SAR size src dst) = pprShift (sLit "sar") size src dst -pprInstr (SHR size src dst) = pprShift (sLit "shr") size src dst - -pprInstr (BT size imm src) = pprSizeImmOp (sLit "bt") size imm src - -pprInstr (CMP size src dst) - | is_float size = pprSizeOpOp (sLit "ucomi") size src dst -- SSE2 - | otherwise = pprSizeOpOp (sLit "cmp") size src dst + result is non-zero." So there. +-} +pprInstr platform (AND size src dst) = pprSizeOpOp platform (sLit "and") size src dst +pprInstr platform (OR size src dst) = pprSizeOpOp platform (sLit "or") size src dst + +pprInstr platform (XOR FF32 src dst) = pprOpOp platform (sLit "xorps") FF32 src dst +pprInstr platform (XOR FF64 src dst) = pprOpOp platform (sLit "xorpd") FF64 src dst +pprInstr platform (XOR size src dst) = pprSizeOpOp platform (sLit "xor") size src dst + +pprInstr platform (NOT size op) = pprSizeOp platform (sLit "not") size op +pprInstr platform (NEGI size op) = pprSizeOp platform (sLit "neg") size op + +pprInstr platform (SHL size src dst) = pprShift platform (sLit "shl") size src dst +pprInstr platform (SAR size src dst) = pprShift platform (sLit "sar") size src dst +pprInstr platform (SHR size src dst) = pprShift platform (sLit "shr") size src dst + +pprInstr platform (BT size imm src) = pprSizeImmOp platform (sLit "bt") size imm src + +pprInstr platform (CMP size src dst) + | is_float size = pprSizeOpOp platform (sLit "ucomi") size src dst -- SSE2 + | otherwise = pprSizeOpOp platform (sLit "cmp") size src dst where - -- This predicate is needed here and nowhere else - is_float FF32 = True - is_float FF64 = True - is_float FF80 = True - is_float _ = False - -pprInstr (TEST size src dst) = pprSizeOpOp (sLit "test") size src dst -pprInstr (PUSH size op) = pprSizeOp (sLit "push") size op -pprInstr (POP size op) = pprSizeOp (sLit "pop") size op + -- This predicate is needed here and nowhere else + is_float FF32 = True + is_float FF64 = True + is_float FF80 = True + is_float _ = False + +pprInstr platform (TEST size src dst) = pprSizeOpOp platform (sLit "test") size src dst +pprInstr platform (PUSH size op) = pprSizeOp platform (sLit "push") size op +pprInstr platform (POP size op) = pprSizeOp platform (sLit "pop") size op -- both unused (SDM): -- pprInstr PUSHA = ptext (sLit "\tpushal") -- pprInstr POPA = ptext (sLit "\tpopal") -pprInstr NOP = ptext (sLit "\tnop") -pprInstr (CLTD II32) = ptext (sLit "\tcltd") -pprInstr (CLTD II64) = ptext (sLit "\tcqto") +pprInstr _ NOP = ptext (sLit "\tnop") +pprInstr _ (CLTD II32) = ptext (sLit "\tcltd") +pprInstr _ (CLTD II64) = ptext (sLit "\tcqto") -pprInstr (SETCC cond op) = pprCondInstr (sLit "set") cond (pprOperand II8 op) +pprInstr platform (SETCC cond op) = pprCondInstr (sLit "set") cond (pprOperand platform II8 op) -pprInstr (JXX cond (BlockId id)) +pprInstr _ (JXX cond blockid) = pprCondInstr (sLit "j") cond (pprCLabel_asm lab) - where lab = mkAsmTempLabel id + where lab = mkAsmTempLabel (getUnique blockid) -pprInstr (JXX_GBL cond imm) = pprCondInstr (sLit "j") cond (pprImm imm) +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 (CALL (Left imm) _) = (<>) (ptext (sLit "\tcall ")) (pprImm imm) -pprInstr (CALL (Right reg) _) = (<>) (ptext (sLit "\tcall *")) (pprReg archWordSize reg) - -pprInstr (IDIV sz op) = pprSizeOp (sLit "idiv") sz op -pprInstr (DIV sz op) = pprSizeOp (sLit "div") sz op -pprInstr (IMUL2 sz op) = pprSizeOp (sLit "imul") sz op +pprInstr _ (JMP (OpImm imm)) = (<>) (ptext (sLit "\tjmp ")) (pprImm imm) +pprInstr platform (JMP op) = (<>) (ptext (sLit "\tjmp *")) (pprOperand platform archWordSize op) +pprInstr platform (JMP_TBL op _ _ _) = pprInstr platform (JMP op) +pprInstr _ (CALL (Left imm) _) = (<>) (ptext (sLit "\tcall ")) (pprImm imm) +pprInstr platform (CALL (Right reg) _) = (<>) (ptext (sLit "\tcall *")) (pprReg platform archWordSize reg) + +pprInstr platform (IDIV sz op) = pprSizeOp platform (sLit "idiv") sz op +pprInstr platform (DIV sz op) = pprSizeOp platform (sLit "div") sz op +pprInstr platform (IMUL2 sz op) = pprSizeOp platform (sLit "imul") sz op -- x86_64 only -pprInstr (MUL size op1 op2) = pprSizeOpOp (sLit "mul") size op1 op2 +pprInstr platform (MUL size op1 op2) = pprSizeOpOp platform (sLit "mul") size op1 op2 -pprInstr (FDIV size op1 op2) = pprSizeOpOp (sLit "div") size op1 op2 +pprInstr platform (FDIV size op1 op2) = pprSizeOpOp platform (sLit "div") size op1 op2 -pprInstr (CVTSS2SD from to) = pprRegReg (sLit "cvtss2sd") from to -pprInstr (CVTSD2SS from to) = pprRegReg (sLit "cvtsd2ss") from to -pprInstr (CVTTSS2SIQ sz from to) = pprSizeOpReg (sLit "cvttss2si") sz from to -pprInstr (CVTTSD2SIQ sz from to) = pprSizeOpReg (sLit "cvttsd2si") sz from to -pprInstr (CVTSI2SS sz from to) = pprSizeOpReg (sLit "cvtsi2ss") sz from to -pprInstr (CVTSI2SD sz from to) = pprSizeOpReg (sLit "cvtsi2sd") sz from to +pprInstr platform (CVTSS2SD from to) = pprRegReg platform (sLit "cvtss2sd") from to +pprInstr platform (CVTSD2SS from to) = pprRegReg platform (sLit "cvtsd2ss") from to +pprInstr platform (CVTTSS2SIQ sz from to) = pprSizeSizeOpReg platform (sLit "cvttss2si") FF32 sz from to +pprInstr platform (CVTTSD2SIQ sz from to) = pprSizeSizeOpReg platform (sLit "cvttsd2si") FF64 sz from to +pprInstr platform (CVTSI2SS sz from to) = pprSizeOpReg platform (sLit "cvtsi2ss") sz from to +pprInstr platform (CVTSI2SD sz from to) = pprSizeOpReg platform (sLit "cvtsi2sd") sz from to -- FETCHGOT for PIC on ELF platforms -pprInstr (FETCHGOT reg) +pprInstr platform (FETCHGOT reg) = vcat [ ptext (sLit "\tcall 1f"), - hcat [ ptext (sLit "1:\tpopl\t"), pprReg II32 reg ], + hcat [ ptext (sLit "1:\tpopl\t"), pprReg platform II32 reg ], hcat [ ptext (sLit "\taddl\t$_GLOBAL_OFFSET_TABLE_+(.-1b), "), - pprReg II32 reg ] + pprReg platform II32 reg ] ] -- FETCHPC for PIC on Darwin/x86 -- get the instruction pointer into a register -- (Terminology note: the IP is called Program Counter on PPC, -- and it's a good thing to use the same name on both platforms) -pprInstr (FETCHPC reg) +pprInstr platform (FETCHPC reg) = vcat [ ptext (sLit "\tcall 1f"), - hcat [ ptext (sLit "1:\tpopl\t"), pprReg II32 reg ] + hcat [ ptext (sLit "1:\tpopl\t"), pprReg platform II32 reg ] ] @@ -673,36 +659,36 @@ -- Simulating a flat register set on the x86 FP stack is tricky. -- you have to free %st(7) before pushing anything on the FP reg stack -- so as to preclude the possibility of a FP stack overflow exception. -pprInstr g@(GMOV src dst) +pprInstr platform g@(GMOV src dst) | src == dst = empty - | otherwise - = pprG g (hcat [gtab, gpush src 0, gsemi, gpop dst 1]) + | otherwise + = pprG platform g (hcat [gtab, gpush src 0, gsemi, gpop dst 1]) -- GLD sz addr dst ==> FLDsz addr ; FSTP (dst+1) -pprInstr g@(GLD sz addr dst) - = pprG g (hcat [gtab, text "fld", pprSize_x87 sz, gsp, - pprAddr addr, gsemi, gpop dst 1]) +pprInstr platform g@(GLD sz addr dst) + = pprG platform g (hcat [gtab, text "fld", pprSize_x87 sz, gsp, + pprAddr platform addr, gsemi, gpop dst 1]) -- GST sz src addr ==> FLD dst ; FSTPsz addr -pprInstr g@(GST sz src addr) +pprInstr platform g@(GST sz src addr) | src == fake0 && sz /= FF80 -- fstt instruction doesn't exist - = pprG g (hcat [gtab, - text "fst", pprSize_x87 sz, gsp, pprAddr addr]) + = pprG platform g (hcat [gtab, + text "fst", pprSize_x87 sz, gsp, pprAddr platform addr]) | otherwise - = pprG g (hcat [gtab, gpush src 0, gsemi, - text "fstp", pprSize_x87 sz, gsp, pprAddr addr]) + = pprG platform g (hcat [gtab, gpush src 0, gsemi, + text "fstp", pprSize_x87 sz, gsp, pprAddr platform addr]) -pprInstr g@(GLDZ dst) - = pprG g (hcat [gtab, text "fldz ; ", gpop dst 1]) -pprInstr g@(GLD1 dst) - = pprG g (hcat [gtab, text "fld1 ; ", gpop dst 1]) +pprInstr platform g@(GLDZ dst) + = pprG platform g (hcat [gtab, text "fldz ; ", gpop dst 1]) +pprInstr platform g@(GLD1 dst) + = pprG platform g (hcat [gtab, text "fld1 ; ", gpop dst 1]) -pprInstr (GFTOI src dst) - = pprInstr (GDTOI src dst) +pprInstr platform (GFTOI src dst) + = pprInstr platform (GDTOI src dst) -pprInstr g@(GDTOI src dst) - = pprG g (vcat [ +pprInstr platform g@(GDTOI src dst) + = pprG platform g (vcat [ hcat [gtab, text "subl $8, %esp ; fnstcw 4(%esp)"], hcat [gtab, gpush src 0], hcat [gtab, text "movzwl 4(%esp), ", reg, @@ -713,15 +699,20 @@ hcat [gtab, text "addl $8, %esp"] ]) where - reg = pprReg II32 dst + reg = pprReg platform II32 dst -pprInstr (GITOF src dst) - = pprInstr (GITOD src dst) +pprInstr platform (GITOF src dst) + = pprInstr platform (GITOD src dst) -pprInstr g@(GITOD src dst) - = pprG g (hcat [gtab, text "pushl ", pprReg II32 src, - text " ; fildl (%esp) ; ", - gpop dst 1, text " ; addl $4,%esp"]) +pprInstr platform g@(GITOD src dst) + = pprG platform g (hcat [gtab, text "pushl ", pprReg platform II32 src, + text " ; fildl (%esp) ; ", + gpop dst 1, text " ; addl $4,%esp"]) + +pprInstr platform g@(GDTOF src dst) + = pprG platform g (vcat [gtab <> gpush src 0, + gtab <> text "subl $4,%esp ; fstps (%esp) ; flds (%esp) ; addl $4,%esp ;", + gtab <> gpop dst 1]) {- Gruesome swamp follows. If you're unfortunate enough to have ventured this far into the jungle AND you give a Rat's Ass (tm) what's going @@ -736,19 +727,19 @@ Here's how the general (non-inequality) case works. As an example, consider generating the an equality test: - pushl %eax -- we need to mess with this + pushl %eax -- we need to mess with this fcomp and pop pushed src1 - -- Result of comparison is in FPU Status Register bits - -- C3 C2 and C0 - fstsw %ax -- Move FPU Status Reg to %ax - sahf -- move C3 C2 C0 from %ax to integer flag reg + -- Result of comparison is in FPU Status Register bits + -- C3 C2 and C0 + fstsw %ax -- Move FPU Status Reg to %ax + sahf -- move C3 C2 C0 from %ax to integer flag reg -- now the serious magic begins - setpo %ah -- %ah = if comparable(neither arg was NaN) then 1 else 0 + setpo %ah -- %ah = if comparable(neither arg was NaN) then 1 else 0 sete %al -- %al = if arg1 == arg2 then 1 else 0 andb %ah,%al -- %al &= %ah -- so %al == 1 iff (comparable && same); else it holds 0 - decb %al -- %al == 0, ZeroFlag=1 iff (comparable && same); + decb %al -- %al == 0, ZeroFlag=1 iff (comparable && same); else %al == 0xFF, ZeroFlag=0 -- the zero flag is now set as we desire. popl %eax @@ -761,19 +752,19 @@ decb %al -- if (incomparable || different) then (%al == 0, ZF=1) else (%al == 0xFF, ZF=0) -} -pprInstr g@(GCMP cond src1 src2) +pprInstr platform g@(GCMP cond src1 src2) | case cond of { NE -> True; _ -> False } - = pprG g (vcat [ + = pprG platform g (vcat [ hcat [gtab, text "pushl %eax ; ",gpush src1 0], - hcat [gtab, text "fcomp ", greg src2 1, + hcat [gtab, text "fcomp ", greg src2 1, text "; fstsw %ax ; sahf ; setpe %ah"], hcat [gtab, text "setne %al ; ", text "orb %ah,%al ; decb %al ; popl %eax"] ]) | otherwise - = pprG g (vcat [ + = pprG platform g (vcat [ hcat [gtab, text "pushl %eax ; ",gpush src1 0], - hcat [gtab, text "fcomp ", greg src2 1, + hcat [gtab, text "fcomp ", greg src2 1, text "; fstsw %ax ; sahf ; setpo %ah"], hcat [gtab, text "set", pprCond (fix_FP_cond cond), text " %al ; ", text "andb %ah,%al ; decb %al ; popl %eax"] @@ -789,100 +780,100 @@ fix_FP_cond LE = LEU fix_FP_cond EQQ = EQQ fix_FP_cond NE = NE - fix_FP_cond _ = panic "X86.Ppr.fix_FP_cond: no match" + fix_FP_cond _ = panic "X86.Ppr.fix_FP_cond: no match" -- there should be no others -pprInstr g@(GABS _ src dst) - = pprG g (hcat [gtab, gpush src 0, text " ; fabs ; ", gpop dst 1]) +pprInstr platform g@(GABS _ src dst) + = pprG platform g (hcat [gtab, gpush src 0, text " ; fabs ; ", gpop dst 1]) -pprInstr g@(GNEG _ src dst) - = pprG g (hcat [gtab, gpush src 0, text " ; fchs ; ", gpop dst 1]) +pprInstr platform g@(GNEG _ src dst) + = pprG platform g (hcat [gtab, gpush src 0, text " ; fchs ; ", gpop dst 1]) -pprInstr g@(GSQRT sz src dst) - = pprG g (hcat [gtab, gpush src 0, text " ; fsqrt"] $$ - hcat [gtab, gcoerceto sz, gpop dst 1]) +pprInstr platform g@(GSQRT sz src dst) + = pprG platform g (hcat [gtab, gpush src 0, text " ; fsqrt"] $$ + hcat [gtab, gcoerceto sz, gpop dst 1]) -pprInstr g@(GSIN sz l1 l2 src dst) - = pprG g (pprTrigOp "fsin" False l1 l2 src dst sz) +pprInstr platform g@(GSIN sz l1 l2 src dst) + = pprG platform g (pprTrigOp "fsin" False l1 l2 src dst sz) -pprInstr g@(GCOS sz l1 l2 src dst) - = pprG g (pprTrigOp "fcos" False l1 l2 src dst sz) +pprInstr platform g@(GCOS sz l1 l2 src dst) + = pprG platform g (pprTrigOp "fcos" False l1 l2 src dst sz) -pprInstr g@(GTAN sz l1 l2 src dst) - = pprG g (pprTrigOp "fptan" True l1 l2 src dst sz) +pprInstr platform g@(GTAN sz l1 l2 src dst) + = pprG platform g (pprTrigOp "fptan" True l1 l2 src dst sz) -- In the translations for GADD, GMUL, GSUB and GDIV, -- the first two cases are mere optimisations. The otherwise clause -- generates correct code under all circumstances. -pprInstr g@(GADD _ src1 src2 dst) +pprInstr platform g@(GADD _ src1 src2 dst) | src1 == dst - = pprG g (text "\t#GADD-xxxcase1" $$ - hcat [gtab, gpush src2 0, - text " ; faddp %st(0),", greg src1 1]) + = pprG platform g (text "\t#GADD-xxxcase1" $$ + hcat [gtab, gpush src2 0, + text " ; faddp %st(0),", greg src1 1]) | src2 == dst - = pprG g (text "\t#GADD-xxxcase2" $$ - hcat [gtab, gpush src1 0, - text " ; faddp %st(0),", greg src2 1]) + = pprG platform g (text "\t#GADD-xxxcase2" $$ + hcat [gtab, gpush src1 0, + text " ; faddp %st(0),", greg src2 1]) | otherwise - = pprG g (hcat [gtab, gpush src1 0, - text " ; fadd ", greg src2 1, text ",%st(0)", - gsemi, gpop dst 1]) + = pprG platform g (hcat [gtab, gpush src1 0, + text " ; fadd ", greg src2 1, text ",%st(0)", + gsemi, gpop dst 1]) -pprInstr g@(GMUL _ src1 src2 dst) +pprInstr platform g@(GMUL _ src1 src2 dst) | src1 == dst - = pprG g (text "\t#GMUL-xxxcase1" $$ - hcat [gtab, gpush src2 0, - text " ; fmulp %st(0),", greg src1 1]) + = pprG platform g (text "\t#GMUL-xxxcase1" $$ + hcat [gtab, gpush src2 0, + text " ; fmulp %st(0),", greg src1 1]) | src2 == dst - = pprG g (text "\t#GMUL-xxxcase2" $$ - hcat [gtab, gpush src1 0, - text " ; fmulp %st(0),", greg src2 1]) + = pprG platform g (text "\t#GMUL-xxxcase2" $$ + hcat [gtab, gpush src1 0, + text " ; fmulp %st(0),", greg src2 1]) | otherwise - = pprG g (hcat [gtab, gpush src1 0, - text " ; fmul ", greg src2 1, text ",%st(0)", - gsemi, gpop dst 1]) + = pprG platform g (hcat [gtab, gpush src1 0, + text " ; fmul ", greg src2 1, text ",%st(0)", + gsemi, gpop dst 1]) -pprInstr g@(GSUB _ src1 src2 dst) +pprInstr platform g@(GSUB _ src1 src2 dst) | src1 == dst - = pprG g (text "\t#GSUB-xxxcase1" $$ - hcat [gtab, gpush src2 0, - text " ; fsubrp %st(0),", greg src1 1]) + = pprG platform g (text "\t#GSUB-xxxcase1" $$ + hcat [gtab, gpush src2 0, + text " ; fsubrp %st(0),", greg src1 1]) | src2 == dst - = pprG g (text "\t#GSUB-xxxcase2" $$ - hcat [gtab, gpush src1 0, - text " ; fsubp %st(0),", greg src2 1]) + = pprG platform g (text "\t#GSUB-xxxcase2" $$ + hcat [gtab, gpush src1 0, + text " ; fsubp %st(0),", greg src2 1]) | otherwise - = pprG g (hcat [gtab, gpush src1 0, - text " ; fsub ", greg src2 1, text ",%st(0)", - gsemi, gpop dst 1]) + = pprG platform g (hcat [gtab, gpush src1 0, + text " ; fsub ", greg src2 1, text ",%st(0)", + gsemi, gpop dst 1]) -pprInstr g@(GDIV _ src1 src2 dst) +pprInstr platform g@(GDIV _ src1 src2 dst) | src1 == dst - = pprG g (text "\t#GDIV-xxxcase1" $$ - hcat [gtab, gpush src2 0, - text " ; fdivrp %st(0),", greg src1 1]) + = pprG platform g (text "\t#GDIV-xxxcase1" $$ + hcat [gtab, gpush src2 0, + text " ; fdivrp %st(0),", greg src1 1]) | src2 == dst - = pprG g (text "\t#GDIV-xxxcase2" $$ - hcat [gtab, gpush src1 0, - text " ; fdivp %st(0),", greg src2 1]) + = pprG platform g (text "\t#GDIV-xxxcase2" $$ + hcat [gtab, gpush src1 0, + text " ; fdivp %st(0),", greg src2 1]) | otherwise - = pprG g (hcat [gtab, gpush src1 0, - text " ; fdiv ", greg src2 1, text ",%st(0)", - gsemi, gpop dst 1]) + = pprG platform g (hcat [gtab, gpush src1 0, + text " ; fdiv ", greg src2 1, text ",%st(0)", + gsemi, gpop dst 1]) -pprInstr GFREE +pprInstr _ GFREE = vcat [ ptext (sLit "\tffree %st(0) ;ffree %st(1) ;ffree %st(2) ;ffree %st(3)"), - ptext (sLit "\tffree %st(4) ;ffree %st(5)") + ptext (sLit "\tffree %st(4) ;ffree %st(5)") ] -pprInstr _ - = panic "X86.Ppr.pprInstr: no match" +pprInstr _ _ + = panic "X86.Ppr.pprInstr: no match" pprTrigOp :: String -> Bool -> CLabel -> CLabel -> Reg -> Reg -> Size -> Doc @@ -960,212 +951,219 @@ gregno _ = --pprPanic "gregno" (ppr other) 999 -- bogus; only needed for debug printing -pprG :: Instr -> Doc -> Doc -pprG fake actual - = (char '#' <> pprGInstr fake) $$ actual - - -pprGInstr :: Instr -> Doc -pprGInstr (GMOV src dst) = pprSizeRegReg (sLit "gmov") FF64 src dst -pprGInstr (GLD sz src dst) = pprSizeAddrReg (sLit "gld") sz src dst -pprGInstr (GST sz src dst) = pprSizeRegAddr (sLit "gst") sz src dst - -pprGInstr (GLDZ dst) = pprSizeReg (sLit "gldz") FF64 dst -pprGInstr (GLD1 dst) = pprSizeReg (sLit "gld1") FF64 dst - -pprGInstr (GFTOI src dst) = pprSizeSizeRegReg (sLit "gftoi") FF32 II32 src dst -pprGInstr (GDTOI src dst) = pprSizeSizeRegReg (sLit "gdtoi") FF64 II32 src dst - -pprGInstr (GITOF src dst) = pprSizeSizeRegReg (sLit "gitof") II32 FF32 src dst -pprGInstr (GITOD src dst) = pprSizeSizeRegReg (sLit "gitod") II32 FF64 src dst - -pprGInstr (GCMP co src dst) = pprCondRegReg (sLit "gcmp_") FF64 co src dst -pprGInstr (GABS sz src dst) = pprSizeRegReg (sLit "gabs") sz src dst -pprGInstr (GNEG sz src dst) = pprSizeRegReg (sLit "gneg") sz src dst -pprGInstr (GSQRT sz src dst) = pprSizeRegReg (sLit "gsqrt") sz src dst -pprGInstr (GSIN sz _ _ src dst) = pprSizeRegReg (sLit "gsin") sz src dst -pprGInstr (GCOS sz _ _ src dst) = pprSizeRegReg (sLit "gcos") sz src dst -pprGInstr (GTAN sz _ _ src dst) = pprSizeRegReg (sLit "gtan") sz src dst - -pprGInstr (GADD sz src1 src2 dst) = pprSizeRegRegReg (sLit "gadd") sz src1 src2 dst -pprGInstr (GSUB sz src1 src2 dst) = pprSizeRegRegReg (sLit "gsub") sz src1 src2 dst -pprGInstr (GMUL sz src1 src2 dst) = pprSizeRegRegReg (sLit "gmul") sz src1 src2 dst -pprGInstr (GDIV sz src1 src2 dst) = pprSizeRegRegReg (sLit "gdiv") sz src1 src2 dst +pprG :: Platform -> Instr -> Doc -> Doc +pprG platform fake actual + = (char '#' <> pprGInstr platform fake) $$ actual + + +pprGInstr :: Platform -> Instr -> Doc +pprGInstr platform (GMOV src dst) = pprSizeRegReg platform (sLit "gmov") FF64 src dst +pprGInstr platform (GLD sz src dst) = pprSizeAddrReg platform (sLit "gld") sz src dst +pprGInstr platform (GST sz src dst) = pprSizeRegAddr platform (sLit "gst") sz src dst + +pprGInstr platform (GLDZ dst) = pprSizeReg platform (sLit "gldz") FF64 dst +pprGInstr platform (GLD1 dst) = pprSizeReg platform (sLit "gld1") FF64 dst + +pprGInstr platform (GFTOI src dst) = pprSizeSizeRegReg platform (sLit "gftoi") FF32 II32 src dst +pprGInstr platform (GDTOI src dst) = pprSizeSizeRegReg platform (sLit "gdtoi") FF64 II32 src dst + +pprGInstr platform (GITOF src dst) = pprSizeSizeRegReg platform (sLit "gitof") II32 FF32 src dst +pprGInstr platform (GITOD src dst) = pprSizeSizeRegReg platform (sLit "gitod") II32 FF64 src dst +pprGInstr platform (GDTOF src dst) = pprSizeSizeRegReg platform (sLit "gdtof") FF64 FF32 src dst + +pprGInstr platform (GCMP co src dst) = pprCondRegReg platform (sLit "gcmp_") FF64 co src dst +pprGInstr platform (GABS sz src dst) = pprSizeRegReg platform (sLit "gabs") sz src dst +pprGInstr platform (GNEG sz src dst) = pprSizeRegReg platform (sLit "gneg") sz src dst +pprGInstr platform (GSQRT sz src dst) = pprSizeRegReg platform (sLit "gsqrt") sz src dst +pprGInstr platform (GSIN sz _ _ src dst) = pprSizeRegReg platform (sLit "gsin") sz src dst +pprGInstr platform (GCOS sz _ _ src dst) = pprSizeRegReg platform (sLit "gcos") sz src dst +pprGInstr platform (GTAN sz _ _ src dst) = pprSizeRegReg platform (sLit "gtan") sz src dst + +pprGInstr platform (GADD sz src1 src2 dst) = pprSizeRegRegReg platform (sLit "gadd") sz src1 src2 dst +pprGInstr platform (GSUB sz src1 src2 dst) = pprSizeRegRegReg platform (sLit "gsub") sz src1 src2 dst +pprGInstr platform (GMUL sz src1 src2 dst) = pprSizeRegRegReg platform (sLit "gmul") sz src1 src2 dst +pprGInstr platform (GDIV sz src1 src2 dst) = pprSizeRegRegReg platform (sLit "gdiv") sz src1 src2 dst -pprGInstr _ = panic "X86.Ppr.pprGInstr: no match" +pprGInstr _ _ = panic "X86.Ppr.pprGInstr: no match" pprDollImm :: Imm -> Doc pprDollImm i = ptext (sLit "$") <> pprImm i -pprOperand :: Size -> Operand -> Doc -pprOperand s (OpReg r) = pprReg s r -pprOperand _ (OpImm i) = pprDollImm i -pprOperand _ (OpAddr ea) = pprAddr ea +pprOperand :: Platform -> Size -> Operand -> Doc +pprOperand platform s (OpReg r) = pprReg platform s r +pprOperand _ _ (OpImm i) = pprDollImm i +pprOperand platform _ (OpAddr ea) = pprAddr platform ea pprMnemonic_ :: LitString -> Doc -pprMnemonic_ name = +pprMnemonic_ name = char '\t' <> ptext name <> space pprMnemonic :: LitString -> Size -> Doc -pprMnemonic name size = +pprMnemonic name size = char '\t' <> ptext name <> pprSize size <> space -pprSizeImmOp :: LitString -> Size -> Imm -> Operand -> Doc -pprSizeImmOp name size imm op1 +pprSizeImmOp :: Platform -> LitString -> Size -> Imm -> Operand -> Doc +pprSizeImmOp platform name size imm op1 = hcat [ - pprMnemonic name size, - char '$', - pprImm imm, - comma, - pprOperand size op1 + pprMnemonic name size, + char '$', + pprImm imm, + comma, + pprOperand platform size op1 ] - -pprSizeOp :: LitString -> Size -> Operand -> Doc -pprSizeOp name size op1 + +pprSizeOp :: Platform -> LitString -> Size -> Operand -> Doc +pprSizeOp platform name size op1 = hcat [ - pprMnemonic name size, - pprOperand size op1 + pprMnemonic name size, + pprOperand platform size op1 ] -pprSizeOpOp :: LitString -> Size -> Operand -> Operand -> Doc -pprSizeOpOp name size op1 op2 +pprSizeOpOp :: Platform -> LitString -> Size -> Operand -> Operand -> Doc +pprSizeOpOp platform name size op1 op2 = hcat [ - pprMnemonic name size, - pprOperand size op1, - comma, - pprOperand size op2 + pprMnemonic name size, + pprOperand platform size op1, + comma, + pprOperand platform size op2 ] -pprOpOp :: LitString -> Size -> Operand -> Operand -> Doc -pprOpOp name size op1 op2 +pprOpOp :: Platform -> LitString -> Size -> Operand -> Operand -> Doc +pprOpOp platform name size op1 op2 = hcat [ - pprMnemonic_ name, - pprOperand size op1, - comma, - pprOperand size op2 + pprMnemonic_ name, + pprOperand platform size op1, + comma, + pprOperand platform size op2 ] -pprSizeReg :: LitString -> Size -> Reg -> Doc -pprSizeReg name size reg1 +pprSizeReg :: Platform -> LitString -> Size -> Reg -> Doc +pprSizeReg platform name size reg1 = hcat [ - pprMnemonic name size, - pprReg size reg1 + pprMnemonic name size, + pprReg platform size reg1 ] -pprSizeRegReg :: LitString -> Size -> Reg -> Reg -> Doc -pprSizeRegReg name size reg1 reg2 +pprSizeRegReg :: Platform -> LitString -> Size -> Reg -> Reg -> Doc +pprSizeRegReg platform name size reg1 reg2 = hcat [ - pprMnemonic name size, - pprReg size reg1, + pprMnemonic name size, + pprReg platform size reg1, comma, - pprReg size reg2 + pprReg platform size reg2 ] -pprRegReg :: LitString -> Reg -> Reg -> Doc -pprRegReg name reg1 reg2 +pprRegReg :: Platform -> LitString -> Reg -> Reg -> Doc +pprRegReg platform name reg1 reg2 = hcat [ - pprMnemonic_ name, - pprReg archWordSize reg1, + pprMnemonic_ name, + pprReg platform archWordSize reg1, comma, - pprReg archWordSize reg2 + pprReg platform archWordSize reg2 ] -pprSizeOpReg :: LitString -> Size -> Operand -> Reg -> Doc -pprSizeOpReg name size op1 reg2 +pprSizeOpReg :: Platform -> LitString -> Size -> Operand -> Reg -> Doc +pprSizeOpReg platform name size op1 reg2 = hcat [ - pprMnemonic name size, - pprOperand size op1, + pprMnemonic name size, + pprOperand platform size op1, comma, - pprReg archWordSize reg2 + pprReg platform archWordSize reg2 ] - -pprCondRegReg :: LitString -> Size -> Cond -> Reg -> Reg -> Doc -pprCondRegReg name size cond reg1 reg2 +pprCondRegReg :: Platform -> LitString -> Size -> Cond -> Reg -> Reg -> Doc +pprCondRegReg platform name size cond reg1 reg2 = hcat [ - char '\t', - ptext name, - pprCond cond, - space, - pprReg size reg1, + char '\t', + ptext name, + pprCond cond, + space, + pprReg platform size reg1, comma, - pprReg size reg2 + pprReg platform size reg2 ] -pprSizeSizeRegReg :: LitString -> Size -> Size -> Reg -> Reg -> Doc -pprSizeSizeRegReg name size1 size2 reg1 reg2 +pprSizeSizeRegReg :: Platform -> LitString -> Size -> Size -> Reg -> Reg -> Doc +pprSizeSizeRegReg platform name size1 size2 reg1 reg2 = hcat [ - char '\t', - ptext name, - pprSize size1, + char '\t', + ptext name, + pprSize size1, pprSize size2, - space, - pprReg size1 reg1, - + space, + pprReg platform size1 reg1, comma, - pprReg size2 reg2 + pprReg platform size2 reg2 ] +pprSizeSizeOpReg :: Platform -> LitString -> Size -> Size -> Operand -> Reg -> Doc +pprSizeSizeOpReg platform name size1 size2 op1 reg2 + = hcat [ + pprMnemonic name size2, + pprOperand platform size1 op1, + comma, + pprReg platform size2 reg2 + ] -pprSizeRegRegReg :: LitString -> Size -> Reg -> Reg -> Reg -> Doc -pprSizeRegRegReg name size reg1 reg2 reg3 +pprSizeRegRegReg :: Platform -> LitString -> Size -> Reg -> Reg -> Reg -> Doc +pprSizeRegRegReg platform name size reg1 reg2 reg3 = hcat [ - pprMnemonic name size, - pprReg size reg1, + pprMnemonic name size, + pprReg platform size reg1, comma, - pprReg size reg2, + pprReg platform size reg2, comma, - pprReg size reg3 + pprReg platform size reg3 ] -pprSizeAddrReg :: LitString -> Size -> AddrMode -> Reg -> Doc -pprSizeAddrReg name size op dst +pprSizeAddrReg :: Platform -> LitString -> Size -> AddrMode -> Reg -> Doc +pprSizeAddrReg platform name size op dst = hcat [ - pprMnemonic name size, - pprAddr op, - comma, - pprReg size dst + pprMnemonic name size, + pprAddr platform op, + comma, + pprReg platform size dst ] -pprSizeRegAddr :: LitString -> Size -> Reg -> AddrMode -> Doc -pprSizeRegAddr name size src op +pprSizeRegAddr :: Platform -> LitString -> Size -> Reg -> AddrMode -> Doc +pprSizeRegAddr platform name size src op = hcat [ - pprMnemonic name size, - pprReg size src, - comma, - pprAddr op + pprMnemonic name size, + pprReg platform size src, + comma, + pprAddr platform op ] -pprShift :: LitString -> Size -> Operand -> Operand -> Doc -pprShift name size src dest +pprShift :: Platform -> LitString -> Size -> Operand -> Operand -> Doc +pprShift platform name size src dest = hcat [ - pprMnemonic name size, - pprOperand II8 src, -- src is 8-bit sized - comma, - pprOperand size dest + pprMnemonic name size, + pprOperand platform II8 src, -- src is 8-bit sized + comma, + pprOperand platform size dest ] -pprSizeOpOpCoerce :: LitString -> Size -> Size -> Operand -> Operand -> Doc -pprSizeOpOpCoerce name size1 size2 op1 op2 +pprSizeOpOpCoerce :: Platform -> LitString -> Size -> Size -> Operand -> Operand -> Doc +pprSizeOpOpCoerce platform name size1 size2 op1 op2 = hcat [ char '\t', ptext name, pprSize size1, pprSize size2, space, - pprOperand size1 op1, - comma, - pprOperand size2 op2 + pprOperand platform size1 op1, + comma, + pprOperand platform size2 op2 ] diff -Nru ghc-7.0.3/compiler/nativeGen/X86/RegInfo.hs ghc-7.2.1/compiler/nativeGen/X86/RegInfo.hs --- ghc-7.0.3/compiler/nativeGen/X86/RegInfo.hs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/nativeGen/X86/RegInfo.hs 2011-08-07 17:10:05.000000000 +0000 @@ -13,12 +13,11 @@ import Reg import Outputable +import Platform import Unique -#if i386_TARGET_ARCH || x86_64_TARGET_ARCH import UniqFM import X86.Regs -#endif mkVirtualReg :: Unique -> Size -> VirtualReg @@ -29,52 +28,39 @@ FF80 -> VirtualRegD u _other -> VirtualRegI u +regDotColor :: Platform -> RealReg -> SDoc +regDotColor platform reg + = let Just str = lookupUFM (regColors platform) reg + in text str + +regColors :: Platform -> UniqFM [Char] +regColors platform = listToUFM (normalRegColors platform ++ fpRegColors) + +normalRegColors :: Platform -> [(Reg,String)] +normalRegColors platform + = case platformArch platform of + ArchX86 -> [ (eax, "#00ff00") + , (ebx, "#0000ff") + , (ecx, "#00ffff") + , (edx, "#0080ff") ] + ArchX86_64 -> [ (rax, "#00ff00"), (eax, "#00ff00") + , (rbx, "#0000ff"), (ebx, "#0000ff") + , (rcx, "#00ffff"), (ecx, "#00ffff") + , (rdx, "#0080ff"), (edx, "#00ffff") + , (r8, "#00ff80") + , (r9, "#008080") + , (r10, "#0040ff") + , (r11, "#00ff40") + , (r12, "#008040") + , (r13, "#004080") + , (r14, "#004040") + , (r15, "#002080") ] + ArchPPC -> panic "X86 normalRegColors ArchPPC" + ArchPPC_64 -> panic "X86 normalRegColors ArchPPC_64" + ArchSPARC -> panic "X86 normalRegColors ArchSPARC" + ArchARM -> panic "X86 normalRegColors ArchARM" + ArchUnknown -> panic "X86 normalRegColors ArchUnknown" --- reg colors for x86 -#if i386_TARGET_ARCH -regDotColor :: RealReg -> SDoc -regDotColor reg - = let Just str = lookupUFM regColors reg - in text str - -regColors :: UniqFM [Char] -regColors - = listToUFM - $ [ (eax, "#00ff00") - , (ebx, "#0000ff") - , (ecx, "#00ffff") - , (edx, "#0080ff") ] - ++ fpRegColors - --- reg colors for x86_64 -#elif x86_64_TARGET_ARCH -regDotColor :: RealReg -> SDoc -regDotColor reg - = let Just str = lookupUFM regColors reg - in text str - -regColors :: UniqFM [Char] -regColors - = listToUFM - $ [ (rax, "#00ff00"), (eax, "#00ff00") - , (rbx, "#0000ff"), (ebx, "#0000ff") - , (rcx, "#00ffff"), (ecx, "#00ffff") - , (rdx, "#0080ff"), (edx, "#00ffff") - , (r8, "#00ff80") - , (r9, "#008080") - , (r10, "#0040ff") - , (r11, "#00ff40") - , (r12, "#008040") - , (r13, "#004080") - , (r14, "#004040") - , (r15, "#002080") ] - ++ fpRegColors -#else -regDotColor :: Reg -> SDoc -regDotColor = panic "not defined" -#endif - -#if i386_TARGET_ARCH || x86_64_TARGET_ARCH fpRegColors :: [(Reg,String)] fpRegColors = [ (fake0, "#ff00ff") @@ -85,4 +71,4 @@ , (fake5, "#5500ff") ] ++ zip (map regSingle [24..39]) (repeat "red") -#endif + diff -Nru ghc-7.0.3/compiler/nativeGen/X86/Regs.hs ghc-7.2.1/compiler/nativeGen/X86/Regs.hs --- ghc-7.0.3/compiler/nativeGen/X86/Regs.hs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/nativeGen/X86/Regs.hs 2011-08-07 17:10:05.000000000 +0000 @@ -54,7 +54,7 @@ import RegClass import BlockId -import Cmm +import OldCmm import CLabel ( CLabel ) import Pretty import Outputable ( panic ) @@ -249,7 +249,6 @@ -- argRegs is the set of regs which are read for an n-argument call to C. -- For archs which pass all args on the stack (x86), is empty. -- Sparc passes up to the first 6 args in regs. --- Dunno about Alpha. argRegs :: RegNo -> [Reg] argRegs _ = panic "MachRegs.argRegs(x86): should not be used!" @@ -333,10 +332,24 @@ {- AMD x86_64 architecture: -- Registers 0-16 have 32-bit counterparts (eax, ebx etc.) -- Registers 0-7 have 16-bit counterparts (ax, bx etc.) -- Registers 0-3 have 8 bit counterparts (ah, bh etc.) +- All 16 integer registers are addressable as 8, 16, 32 and 64-bit values: + 8 16 32 64 + --------------------- + al ax eax rax + bl bx ebx rbx + cl cx ecx rcx + dl dx edx rdx + sil si esi rsi + dil si edi rdi + bpl bp ebp rbp + spl sp esp rsp + r10b r10w r10d r10 + r11b r11w r11d r11 + r12b r12w r12d r12 + r13b r13w r13d r13 + r14b r14w r14d r14 + r15b r15w r15d r15 -} rax, rbx, rcx, rdx, rsp, rbp, rsi, rdi, diff -Nru ghc-7.0.3/compiler/parser/cutils.c ghc-7.2.1/compiler/parser/cutils.c --- ghc-7.0.3/compiler/parser/cutils.c 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/parser/cutils.c 2011-08-07 17:10:05.000000000 +0000 @@ -4,9 +4,6 @@ */ #include "Rts.h" -#if __GLASGOW_HASKELL__ <= 610 -#include "RtsFlags.h" -#endif #include "HsFFI.h" diff -Nru ghc-7.0.3/compiler/parser/LexCore.hs ghc-7.2.1/compiler/parser/LexCore.hs --- ghc-7.0.3/compiler/parser/LexCore.hs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/parser/LexCore.hs 2011-08-07 17:10:05.000000000 +0000 @@ -86,7 +86,8 @@ | isDigit c -> cont (TKrational (fromInteger sgn * r)) rest' where ((r,rest'):_) = readFloat (digits ++ ('.':c:rest)) -- When reading a floating-point number, which is - -- a bit complicated, use the Haskell 98 library function + -- a bit complicated, use the standard library function + -- "readFloat" (digits,rest) -> cont (TKinteger (sgn * (read digits))) rest lexName :: (a -> String -> b) -> (String -> a) -> String -> b diff -Nru ghc-7.0.3/compiler/parser/Lexer.hs ghc-7.2.1/compiler/parser/Lexer.hs --- ghc-7.0.3/compiler/parser/Lexer.hs 2011-03-26 20:51:08.000000000 +0000 +++ ghc-7.2.1/compiler/parser/Lexer.hs 2011-08-07 20:09:18.000000000 +0000 @@ -1,7 +1,8 @@ {-# OPTIONS -fglasgow-exts -cpp #-} -{-# LINE 33 "compiler/parser/Lexer.x" #-} +{-# LINE 34 "compiler/parser/Lexer.x" #-} -- XXX The above flags turn off warnings in the generated code: +{-# LANGUAGE BangPatterns #-} {-# OPTIONS_GHC -fno-warn-unused-matches #-} {-# OPTIONS_GHC -fno-warn-unused-binds #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-} @@ -15,11 +16,12 @@ module Lexer ( Token(..), lexer, pragState, mkPState, PState(..), - P(..), ParseResult(..), getSrcLoc, + P(..), ParseResult(..), getSrcLoc, getPState, getDynFlags, withThisPackage, failLocMsgP, failSpanMsgP, srcParseFail, - getMessages, + getMessages, popContext, pushCurrentContext, setLastToken, setSrcLoc, + activeContext, nextIsEOF, getLexState, popLexState, pushLexState, extension, bangPatEnabled, datatypeContextsEnabled, addWarning, @@ -36,8 +38,8 @@ import DynFlags import Module import Ctype -import BasicTypes ( InlineSpec(..), RuleMatchInfo(..) ) -import Util ( readRational ) +import BasicTypes ( InlineSpec(..), RuleMatchInfo(..), FractionalLit(..) ) +import Util ( readRational ) import Control.Monad import Data.Bits @@ -67,25 +69,25 @@ import GlaExts #endif alex_base :: AlexAddr -alex_base = AlexA# "\x01\x00\x00\x00\x7b\x00\x00\x00\x84\x00\x00\x00\x8d\x00\x00\x00\xa9\x00\x00\x00\xb2\x00\x00\x00\xcc\x00\x00\x00\xf8\x00\x00\x00\x01\x01\x00\x00\xef\x00\x00\x00\x1d\x01\x00\x00\x58\x01\x00\x00\xfc\xff\xff\xff\xbb\x00\x00\x00\xc0\x00\x00\x00\xfb\xff\xff\xff\x06\x00\x00\x00\xee\xff\xff\xff\x79\x00\x00\x00\xcd\x00\x00\x00\xf0\x00\x00\x00\xe5\xff\xff\xff\xe6\xff\xff\xff\x78\x00\x00\x00\xe7\xff\xff\xff\x54\x00\x00\x00\x0b\x00\x00\x00\x0c\x00\x00\x00\x0d\x00\x00\x00\x0e\x00\x00\x00\xca\x01\x00\x00\xcc\x01\x00\x00\xce\x01\x00\x00\xd6\x01\x00\x00\xec\xff\xff\xff\x82\x00\x00\x00\x5d\x00\x00\x00\xed\xff\xff\xff\xde\x01\x00\x00\x33\x02\x00\x00\x5b\x02\x00\x00\x9e\x02\x00\x00\xc6\x02\x00\x00\x11\x00\x00\x00\x13\x00\x00\x00\x14\x00\x00\x00\x15\x00\x00\x00\x16\x00\x00\x00\x81\x00\x00\x00\x89\x00\x00\x00\x8a\x00\x00\x00\x8b\x00\x00\x00\x93\x00\x00\x00\x95\x00\x00\x00\x96\x00\x00\x00\x97\x00\x00\x00\x98\x00\x00\x00\x99\x00\x00\x00\x9c\x00\x00\x00\x09\x03\x00\x00\x31\x03\x00\x00\x74\x03\x00\x00\x9c\x03\x00\x00\xdf\x03\x00\x00\x07\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x00\x00\x00\x44\x00\x00\x00\x3c\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\xae\x00\x00\x00\x52\x00\x00\x00\x4c\x00\x00\x00\x5a\x00\x00\x00\x61\x00\x00\x00\x51\x00\x00\x00\x00\x00\x00\x00\xba\x00\x00\x00\xc4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\x00\x00\x00\x6e\x00\x00\x00\x66\x00\x00\x00\x73\x00\x00\x00\x00\x00\x00\x00\x47\x04\x00\x00\xc1\x04\x00\x00\x3b\x05\x00\x00\xb5\x05\x00\x00\x2f\x06\x00\x00\xa9\x06\x00\x00\x23\x07\x00\x00\x9d\x07\x00\x00\x17\x08\x00\x00\x91\x08\x00\x00\x0b\x09\x00\x00\x85\x09\x00\x00\x1f\x01\x00\x00\xff\x09\x00\x00\x7d\x0a\x00\x00\xfb\x0a\x00\x00\xd3\x00\x00\x00\x56\x01\x00\x00\x79\x0b\x00\x00\xf7\x0b\x00\x00\x75\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x00\x00\x64\x00\x00\x00\xf3\x0c\x00\x00\x6d\x0d\x00\x00\x00\x00\x00\x00\xc2\x00\x00\x00\xc7\x0d\x00\x00\x75\x00\x00\x00\xea\x0d\x00\x00\x00\x00\x00\x00\x18\x01\x00\x00\x00\x00\x00\x00\x0a\x0e\x00\x00\x00\x00\x00\x00\x66\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa6\x0e\x00\x00\x00\x00\x00\x00\x00\x0f\x00\x00\x00\x00\x00\x00\x5a\x0f\x00\x00\x00\x00\x00\x00\xb4\x0f\x00\x00\x00\x00\x00\x00\x0e\x10\x00\x00\x4e\x10\x00\x00\xa8\x10\x00\x00\x02\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x11\x00\x00\xb0\x11\x00\x00\x6b\x04\x00\x00\x00\x00\x00\x00\x0a\x12\x00\x00\x64\x12\x00\x00\x00\x00\x00\x00\xd0\x00\x00\x00\x00\x00\x00\x00\xbe\x12\x00\x00\x18\x13\x00\x00\x72\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc6\x13\x00\x00\x20\x14\x00\x00\x7a\x14\x00\x00\xd4\x14\x00\x00\x0e\x15\x00\x00\x68\x15\x00\x00\xe6\x15\x00\x00\x40\x16\x00\x00\x9a\x16\x00\x00\xf4\x16\x00\x00\x4e\x17\x00\x00\xa8\x17\x00\x00\x02\x18\x00\x00\x5c\x18\x00\x00\xb6\x18\x00\x00\x10\x19\x00\x00\x6a\x19\x00\x00\xc4\x19\x00\x00\xd2\x00\x00\x00\xdb\x00\x00\x00\xdd\x00\x00\x00\xe6\x00\x00\x00\x1e\x1a\x00\x00\x41\x1a\x00\x00\x64\x1a\x00\x00\x87\x1a\x00\x00\x00\x00\x00\x00\xaa\x1a\x00\x00\xcd\x1a\x00\x00\xf0\x1a\x00\x00\x00\x00\x00\x00\x13\x1b\x00\x00\x36\x1b\x00\x00\x59\x1b\x00\x00\x7c\x1b\x00\x00\x9f\x1b\x00\x00\xbd\x1b\x00\x00\x1d\x04\x00\x00\xb4\x01\x00\x00\xef\x01\x00\x00\xc0\x15\x00\x00\xcc\x0c\x00\x00\x31\x05\x00\x00\x96\x05\x00\x00\x10\x06\x00\x00\xb6\x04\x00\x00\xa6\x05\x00\x00\x19\x05\x00\x00\x20\x06\x00\x00\x87\x06\x00\x00\xf2\x00\x00\x00\xf3\x00\x00\x00\xf4\x00\x00\x00\x00\x00\x00\x00\x06\x1c\x00\x00\x9f\x06\x00\x00\x00\x00\x00\x00\x0e\x02\x00\x00\x1a\x03\x00\x00\x00\x00\x00\x00\x4f\x1c\x00\x00\x66\x1c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf6\x00\x00\x00\x19\x07\x00\x00\x7e\x07\x00\x00\xf8\x07\x00\x00\x01\x07\x00\x00\x8e\x07\x00\x00\x08\x08\x00\x00\x74\x08\x00\x00\x82\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# +alex_base = AlexA# "\x01\x00\x00\x00\x7b\x00\x00\x00\x84\x00\x00\x00\x8d\x00\x00\x00\xa9\x00\x00\x00\xb2\x00\x00\x00\xcc\x00\x00\x00\xf8\x00\x00\x00\x01\x01\x00\x00\xef\x00\x00\x00\x1d\x01\x00\x00\x58\x01\x00\x00\xfc\xff\xff\xff\xbb\x00\x00\x00\xc0\x00\x00\x00\xfb\xff\xff\xff\x06\x00\x00\x00\xee\xff\xff\xff\x79\x00\x00\x00\xcd\x00\x00\x00\xf0\x00\x00\x00\xe5\xff\xff\xff\xe6\xff\xff\xff\x78\x00\x00\x00\xe7\xff\xff\xff\xe8\xff\xff\xff\x0c\x00\x00\x00\x0d\x00\x00\x00\x0e\x00\x00\x00\x0f\x00\x00\x00\xca\x01\x00\x00\xcc\x01\x00\x00\xce\x01\x00\x00\xd6\x01\x00\x00\xed\xff\xff\xff\x82\x00\x00\x00\x5d\x00\x00\x00\xf0\xff\xff\xff\xde\x01\x00\x00\x33\x02\x00\x00\x5b\x02\x00\x00\x9e\x02\x00\x00\xc6\x02\x00\x00\x11\x00\x00\x00\x14\x00\x00\x00\x15\x00\x00\x00\x16\x00\x00\x00\x77\x00\x00\x00\x81\x00\x00\x00\x89\x00\x00\x00\x8a\x00\x00\x00\x8b\x00\x00\x00\x93\x00\x00\x00\x95\x00\x00\x00\x96\x00\x00\x00\x97\x00\x00\x00\x98\x00\x00\x00\x99\x00\x00\x00\x9c\x00\x00\x00\x09\x03\x00\x00\x31\x03\x00\x00\x74\x03\x00\x00\x9c\x03\x00\x00\xdf\x03\x00\x00\x07\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x00\x00\x00\x44\x00\x00\x00\x3c\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x00\x00\xae\x00\x00\x00\x52\x00\x00\x00\x4c\x00\x00\x00\x5a\x00\x00\x00\x61\x00\x00\x00\x51\x00\x00\x00\x00\x00\x00\x00\xba\x00\x00\x00\xc4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\x00\x00\x00\x6b\x00\x00\x00\x65\x00\x00\x00\x73\x00\x00\x00\x00\x00\x00\x00\x47\x04\x00\x00\xc1\x04\x00\x00\x3b\x05\x00\x00\xb5\x05\x00\x00\x2f\x06\x00\x00\xa9\x06\x00\x00\x23\x07\x00\x00\x9d\x07\x00\x00\x17\x08\x00\x00\x91\x08\x00\x00\x0b\x09\x00\x00\x85\x09\x00\x00\x1f\x01\x00\x00\xff\x09\x00\x00\x7d\x0a\x00\x00\xfb\x0a\x00\x00\xca\x00\x00\x00\x56\x01\x00\x00\x79\x0b\x00\x00\xf7\x0b\x00\x00\x75\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\x00\x00\x64\x00\x00\x00\xf3\x0c\x00\x00\x6d\x0d\x00\x00\x00\x00\x00\x00\xb1\x00\x00\x00\xc7\x0d\x00\x00\x72\x00\x00\x00\xea\x0d\x00\x00\x00\x00\x00\x00\x18\x01\x00\x00\x00\x00\x00\x00\x0a\x0e\x00\x00\x00\x00\x00\x00\x66\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa6\x0e\x00\x00\x00\x00\x00\x00\x00\x0f\x00\x00\x00\x00\x00\x00\x5a\x0f\x00\x00\x00\x00\x00\x00\xb4\x0f\x00\x00\x00\x00\x00\x00\x0e\x10\x00\x00\x4e\x10\x00\x00\xa8\x10\x00\x00\x02\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x11\x00\x00\xb0\x11\x00\x00\x6b\x04\x00\x00\x00\x00\x00\x00\x0a\x12\x00\x00\x64\x12\x00\x00\x00\x00\x00\x00\xcf\x00\x00\x00\x00\x00\x00\x00\xbe\x12\x00\x00\x18\x13\x00\x00\x72\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc6\x13\x00\x00\x20\x14\x00\x00\x7a\x14\x00\x00\xd4\x14\x00\x00\x0e\x15\x00\x00\x68\x15\x00\x00\xe6\x15\x00\x00\x40\x16\x00\x00\x9a\x16\x00\x00\xf4\x16\x00\x00\x4e\x17\x00\x00\xa8\x17\x00\x00\x02\x18\x00\x00\x5c\x18\x00\x00\xb6\x18\x00\x00\x10\x19\x00\x00\x6a\x19\x00\x00\xc4\x19\x00\x00\xd0\x00\x00\x00\xd2\x00\x00\x00\xdb\x00\x00\x00\xdd\x00\x00\x00\x1e\x1a\x00\x00\x41\x1a\x00\x00\x64\x1a\x00\x00\x87\x1a\x00\x00\xaa\x1a\x00\x00\xcd\x1a\x00\x00\xf0\x1a\x00\x00\x0e\x1b\x00\x00\x1d\x04\x00\x00\xb4\x01\x00\x00\xef\x01\x00\x00\xc0\x15\x00\x00\xcc\x0c\x00\x00\x31\x05\x00\x00\x96\x05\x00\x00\x10\x06\x00\x00\xb6\x04\x00\x00\xa6\x05\x00\x00\x19\x05\x00\x00\x20\x06\x00\x00\x87\x06\x00\x00\xe6\x00\x00\x00\xf2\x00\x00\x00\xf3\x00\x00\x00\x00\x00\x00\x00\x57\x1b\x00\x00\x9f\x06\x00\x00\x00\x00\x00\x00\x0e\x02\x00\x00\x1a\x03\x00\x00\x00\x00\x00\x00\xa0\x1b\x00\x00\xb7\x1b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf4\x00\x00\x00\x19\x07\x00\x00\x7e\x07\x00\x00\xf8\x07\x00\x00\x01\x07\x00\x00\x8e\x07\x00\x00\x08\x08\x00\x00\x74\x08\x00\x00\x82\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# alex_table :: AlexAddr -alex_table = AlexA# "\x00\x00\x0d\x00\xb0\x00\xb6\x00\x0f\x00\xc8\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0f\x00\x58\x00\x0d\x00\x0d\x00\x0d\x00\x10\x00\xff\xff\x5d\x00\x11\x00\x11\x00\x13\x00\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\x29\x00\xff\xff\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0d\x00\xc8\x00\xf3\x00\x76\x00\x8c\x00\xc8\x00\xc8\x00\xf2\x00\x96\x00\xa0\x00\xc8\x00\xc8\x00\xa3\x00\x26\x00\xc8\x00\xc8\x00\xcb\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\x7e\x00\xa4\x00\xc8\x00\xc8\x00\xc8\x00\x9a\x00\xc8\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\x7c\x00\xc8\x00\xa2\x00\xc8\x00\xb6\x00\xa5\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\x19\x00\x89\x00\xa6\x00\xc8\x00\x0d\x00\x14\x00\xff\xff\xff\xff\x0f\x00\x41\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x27\x00\xff\xff\xff\xff\x0f\x00\x52\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\xff\xff\xff\xff\xff\xff\x0f\x00\x52\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x5e\x00\xff\xff\x43\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0d\x00\x12\x00\xff\xff\x54\x00\x22\x00\x42\x00\x44\x00\x45\x00\x47\x00\x0d\x00\x0d\x00\x28\x00\x54\x00\x22\x00\x0f\x00\x48\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x47\x00\x4a\x00\x22\x00\x0f\x00\x50\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x4b\x00\x4c\x00\x4d\x00\x4f\x00\x0e\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\xff\xff\x0e\x00\x0e\x00\x0e\x00\x4f\x00\x57\x00\x9d\x00\x0d\x00\x0d\x00\x53\x00\x55\x00\x0f\x00\x22\x00\x0d\x00\x0d\x00\x0d\x00\x6f\x00\x0d\x00\x56\x00\xff\xff\x71\x00\x22\x00\x0e\x00\x6e\x00\x65\x00\x65\x00\x65\x00\x65\x00\x65\x00\x65\x00\x65\x00\x65\x00\x65\x00\x65\x00\x0d\x00\x7a\x00\x67\x00\x77\x00\x5f\x00\x79\x00\x74\x00\x9b\x00\x0d\x00\xb9\x00\x16\x00\x79\x00\x0f\x00\x22\x00\x0d\x00\x0d\x00\x0d\x00\x0e\x00\xba\x00\x15\x00\xbb\x00\x10\x00\xff\xff\x0e\x00\x0e\x00\x0e\x00\x0d\x00\x46\x00\x15\x00\xbc\x00\x0f\x00\x4e\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x7a\x00\x6c\x00\x00\x00\x60\x00\x79\x00\xe5\x00\xe6\x00\xe7\x00\x0e\x00\xf1\x00\x79\x00\x00\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x0d\x00\x00\x00\x16\x00\x23\x00\x0f\x00\x00\x00\x0d\x00\x0d\x00\x0d\x00\x79\x00\x00\x00\x16\x00\x22\x00\x00\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x00\x00\x79\x00\x0d\x00\x00\x00\x00\x00\x70\x00\x00\x00\x79\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x79\x00\x24\x00\x00\x00\x95\x00\x00\x00\x79\x00\x65\x00\x65\x00\x65\x00\x65\x00\x65\x00\x65\x00\x65\x00\x65\x00\x65\x00\x65\x00\xaf\x00\xb5\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x0f\x00\x58\x00\x0d\x00\x0d\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x79\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x00\x00\x00\x00\x79\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x75\x00\x16\x00\x00\x00\x00\x00\x00\x00\x9f\x00\xa0\x00\x00\x00\x00\x00\xa3\x00\x25\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x00\x00\x00\x00\x00\x00\xa4\x00\x79\x00\x00\x00\x00\x00\x00\x00\x16\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xa1\x00\x00\x00\xa2\x00\x00\x00\xb5\x00\xa5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\x18\x00\xff\xff\xa6\x00\xff\xff\xda\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xc9\x00\x00\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\x00\x00\x2f\x00\x2f\x00\x30\x00\x30\x00\x31\x00\x33\x00\x00\x00\x2f\x00\x00\x00\x30\x00\x00\x00\x33\x00\x32\x00\x33\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc9\x00\x33\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\x00\x00\x00\x00\x00\x00\xc9\x00\xc9\x00\x00\x00\x2a\x00\xc9\x00\xc9\x00\xdd\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xc9\x00\x00\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\xcd\x00\x00\x00\x2f\x00\x00\x00\x30\x00\x00\x00\x33\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdf\x00\x00\x00\x00\x00\x33\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\xc9\x00\x00\x00\xc9\x00\xff\xff\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\x2f\x00\x00\x00\x30\x00\x00\x00\x33\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x33\x00\x1e\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xc9\x00\x00\x00\xc9\x00\xff\xff\xff\xff\x69\x00\x3b\x00\xff\xff\xff\xff\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x69\x00\x00\x00\x69\x00\x69\x00\x69\x00\x69\x00\x00\x00\x00\x00\x00\x00\x69\x00\x69\x00\x00\x00\x3c\x00\x69\x00\x69\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x69\x00\x00\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x69\x00\x00\x00\x69\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xc9\x00\x3b\x00\xff\xff\xff\xff\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x69\x00\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x21\x00\xc9\x00\x00\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\x00\x00\x00\x00\x00\x00\xc9\x00\xc9\x00\x00\x00\x3d\x00\xc9\x00\xc9\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\xc9\x00\x00\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc9\x00\x00\x00\xc9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\x69\x00\x3e\x00\xff\xff\xff\xff\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc9\x00\xff\xff\xc9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\x69\x00\x00\x00\x69\x00\x69\x00\x69\x00\x69\x00\x00\x00\x00\x00\x00\x00\x69\x00\x69\x00\x00\x00\x3f\x00\x69\x00\x69\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x69\x00\x00\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x69\x00\x00\x00\x69\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc9\x00\x00\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\x00\x00\x00\x00\x00\x00\xc9\x00\xc9\x00\xff\xff\x40\x00\xc9\x00\xc9\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x69\x00\xc9\x00\x69\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\x00\x00\x3e\x00\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\xc9\x00\x00\x00\xc9\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x69\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc9\x00\x00\x00\xc9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x69\x00\x00\x00\x69\x00\x69\x00\x69\x00\x69\x00\x00\x00\x00\x00\x00\x00\x69\x00\x69\x00\xc9\x00\x3f\x00\x69\x00\x69\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x69\x00\xff\xff\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc9\x00\x00\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\x00\x00\x00\x00\x00\x00\xc9\x00\xc9\x00\x00\x00\x40\x00\xc9\x00\xc9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x69\x00\x00\x00\x69\x00\x00\x00\x00\x00\xd9\x00\xc9\x00\x00\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\x59\x00\x59\x00\x59\x00\xd4\x00\x00\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x69\x00\x00\x00\x69\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd7\x00\xc9\x00\x00\x00\xc9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x00\x00\xd7\x00\xc9\x00\x00\x00\xc9\x00\x00\x00\x00\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x00\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x5a\x00\x5a\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8f\x00\xff\xff\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\x00\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5a\x00\x00\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5b\x00\x5b\x00\x5b\x00\x00\x00\x73\x00\x00\x00\x00\x00\x00\x00\x00\x00\x73\x00\x73\x00\x73\x00\x73\x00\xd2\x00\xd2\x00\xd2\x00\xd2\x00\xd2\x00\xd2\x00\xd2\x00\xd2\x00\xd2\x00\xd2\x00\x00\x00\xe8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x73\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\xd1\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x00\x00\xd5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\xd5\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x00\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5c\x00\x5c\x00\x5c\x00\xe8\x00\x73\x00\x00\x00\x00\x00\x00\x00\x00\x00\x73\x00\x73\x00\x73\x00\x73\x00\x00\x00\x00\x00\x00\x00\xd2\x00\xd2\x00\xd2\x00\xd2\x00\xd2\x00\xd2\x00\xd2\x00\xd2\x00\xd2\x00\xd2\x00\x00\x00\xd6\x00\x00\x00\xd6\x00\x00\x00\x73\x00\xd2\x00\xd2\x00\xd2\x00\xd2\x00\xd2\x00\xd2\x00\xd2\x00\xd2\x00\xd2\x00\xd2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x59\x00\x59\x00\x59\x00\xe8\x00\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x61\x00\x61\x00\x61\x00\x00\x00\x00\x00\x00\x00\xd3\x00\xd3\x00\xd3\x00\xd3\x00\xd3\x00\xd3\x00\xd3\x00\xd3\x00\xd3\x00\xd3\x00\x00\x00\xd8\x00\x00\x00\xd8\x00\x00\x00\x61\x00\xd3\x00\xd3\x00\xd3\x00\xd3\x00\xd3\x00\xd3\x00\xd3\x00\xd3\x00\xd3\x00\xd3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x00\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x5a\x00\x5a\x00\x5a\x00\x00\x00\x62\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x62\x00\x62\x00\xd3\x00\xd3\x00\xd3\x00\xd3\x00\xd3\x00\xd3\x00\xd3\x00\xd3\x00\xd3\x00\xd3\x00\x00\x00\xdc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x00\x00\x00\x00\x00\x00\xec\x00\x00\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x00\x00\xef\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\xef\x00\x00\x00\x00\x00\x00\x00\x5a\x00\x00\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5b\x00\x5b\x00\x5b\x00\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\x00\x63\x00\x63\x00\x63\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\x00\x00\xe8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\xe9\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x00\x00\xed\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\xed\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x00\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5c\x00\x5c\x00\x5c\x00\xe8\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x64\x00\x64\x00\x64\x00\x00\x00\x00\x00\x00\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\x00\x00\xee\x00\x00\x00\xee\x00\x00\x00\x64\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x59\x00\x59\x00\x59\x00\xe8\x00\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x61\x00\x61\x00\x61\x00\x00\x00\x00\x00\x00\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\xea\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x00\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x5a\x00\x5a\x00\x5a\x00\x00\x00\x62\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x62\x00\x62\x00\xf0\x00\x00\x00\xf0\x00\x00\x00\x00\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\x00\x00\x00\x00\x00\x00\x62\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\xeb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5a\x00\x00\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5b\x00\x5b\x00\x5b\x00\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\x00\x63\x00\x63\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x00\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5c\x00\x5c\x00\x5c\x00\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x64\x00\x64\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x68\x00\x68\x00\x68\x00\x68\x00\x00\x00\x68\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x68\x00\x68\x00\x66\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x00\x00\x68\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x68\x00\x68\x00\x66\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x00\x00\x68\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x68\x00\x68\x00\x66\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x00\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6d\x00\x6b\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x00\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6d\x00\x6b\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x00\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6d\x00\x6b\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x72\x00\x72\x00\x72\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x00\x00\x00\x00\x00\x00\x00\x00\x72\x00\x00\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x00\x00\x73\x00\x00\x00\x00\x00\x00\x00\x00\x00\x73\x00\x73\x00\x73\x00\x73\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x73\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x00\x00\x00\x00\x00\x00\xc9\x00\x72\x00\x00\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\xc9\x00\x00\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\x00\x00\x9c\x00\xc9\x00\xc9\x00\x00\x00\x78\x00\xc9\x00\xc9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc9\x00\x00\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\x00\x00\x00\x00\x00\x00\xc9\x00\x93\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\x00\x00\x00\x00\x00\x00\xc9\x00\xc9\x00\x00\x00\xc9\x00\xc9\x00\xc9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\x00\x00\x00\x00\x00\x00\x91\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc9\x00\x7b\x00\xc9\x00\xc9\x00\x00\x00\xc9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc9\x00\x74\x00\xc9\x00\x93\x00\xca\x00\x93\x00\x93\x00\x93\x00\x85\x00\x81\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x83\x00\x93\x00\x93\x00\x93\x00\x87\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x00\x00\x7f\x00\xca\x00\x00\x00\xca\x00\xca\x00\xca\x00\xca\x00\x00\x00\x00\x00\x00\x00\xca\x00\xca\x00\x00\x00\xca\x00\xca\x00\xca\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xca\x00\x00\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\x94\x00\x94\x00\x94\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xca\x00\x7d\x00\xca\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x00\x00\x00\x00\xca\x00\x00\x00\xca\x00\x00\x00\x00\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x00\x00\x94\x00\x00\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x00\x00\x94\x00\x00\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x00\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x00\x00\x94\x00\x00\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x00\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x00\x00\x00\x00\x00\x00\xc9\x00\x94\x00\x00\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\xc9\x00\x86\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\x00\x00\x00\x00\x97\x00\xc9\x00\xc9\x00\x00\x00\xc9\x00\xc9\x00\xc9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc9\x00\x00\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\x8b\x00\x8b\x00\x8b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc9\x00\x88\x00\xc9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x00\x00\x00\x00\xc9\x00\x9e\x00\xc9\x00\x00\x00\x00\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x00\x00\x8b\x00\x00\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x00\x00\x8a\x00\x00\x00\xc9\x00\x8b\x00\x00\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\xc9\x00\x00\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\x00\x00\x8d\x00\x00\x00\xc9\x00\xc9\x00\x00\x00\xc9\x00\xc9\x00\xc9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc9\x00\x00\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc9\x00\x00\x00\xc9\x00\x8a\x00\x00\x00\x8a\x00\x8a\x00\x8a\x00\x8a\x00\x8a\x00\x8a\x00\x8a\x00\x8a\x00\x8a\x00\x8a\x00\x8a\x00\x8a\x00\x8a\x00\x8a\x00\x8a\x00\x8a\x00\x8a\x00\x8a\x00\x8a\x00\x8a\x00\x8a\x00\x8a\x00\x8a\x00\x8a\x00\x8a\x00\x8a\x00\x90\x00\xc9\x00\x00\x00\xc9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x8e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x94\x00\x94\x00\x94\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x8e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x00\x00\x94\x00\x00\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x00\x00\x92\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x99\x00\x99\x00\x99\x00\x00\x00\x94\x00\x00\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x00\x00\x92\x00\x00\x00\x00\x00\x00\x00\x00\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x00\x00\x99\x00\x00\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x00\x00\x98\x00\x00\x00\xc9\x00\x99\x00\x00\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\xc9\x00\x00\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\x00\x00\x00\x00\x00\x00\xc9\x00\xc9\x00\x00\x00\xc9\x00\xc9\x00\xc9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc9\x00\x00\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\xa9\x00\xa9\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc9\x00\x00\x00\xc9\x00\x98\x00\x00\x00\x98\x00\x98\x00\x98\x00\x98\x00\x98\x00\x98\x00\x98\x00\x98\x00\x98\x00\x98\x00\x98\x00\x98\x00\x98\x00\x98\x00\x98\x00\x98\x00\x98\x00\x98\x00\x98\x00\x98\x00\x98\x00\x98\x00\x98\x00\x98\x00\x98\x00\x98\x00\xa9\x00\xc9\x00\x00\x00\xc9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xaa\x00\xaa\x00\xaa\x00\x00\x00\xa9\x00\x00\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\x00\x00\x00\x00\xb9\x00\x00\x00\x00\x00\x00\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xa9\x00\xa9\x00\xa9\x00\x00\x00\xaa\x00\x00\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xaa\x00\xaa\x00\xaa\x00\x00\x00\xa9\x00\x00\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\xa9\x00\x00\x00\x00\x00\xb9\x00\x00\x00\x00\x00\x00\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\x00\x00\xad\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaa\x00\x00\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xaa\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xae\x00\xa8\x00\x00\x00\xbd\x00\xa7\x00\x00\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xbd\x00\x00\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\x00\x00\xc4\x00\x00\x00\xbd\x00\xbd\x00\x00\x00\xbd\x00\xbd\x00\xbd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbf\x00\x00\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xbd\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\x00\x00\xbd\x00\x00\x00\xbd\x00\xa8\x00\x00\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xdb\x00\xbd\x00\x00\x00\xbd\x00\xb1\x00\xb1\x00\xb1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\x00\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\x00\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xcf\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb2\x00\xb2\x00\xb2\x00\x00\x00\xb1\x00\x00\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\x00\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xac\x00\x00\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb3\x00\xb3\x00\xb3\x00\x00\x00\xb2\x00\x00\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\x00\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb4\x00\xb4\x00\xb4\x00\x00\x00\xb3\x00\x00\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\x00\x00\x00\x00\xbc\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xac\x00\x00\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb1\x00\xb1\x00\xb1\x00\x00\x00\xb4\x00\x00\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\x00\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb2\x00\xb2\x00\xb2\x00\x00\x00\xb1\x00\x00\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\x00\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xac\x00\x00\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb3\x00\xb3\x00\xb3\x00\x00\x00\xb2\x00\x00\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xab\x00\x00\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb4\x00\xb4\x00\xb4\x00\x00\x00\xb3\x00\x00\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\x00\x00\x00\x00\xbc\x00\x00\x00\x00\x00\x00\x00\xb4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xac\x00\x00\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb7\x00\xb7\x00\xb7\x00\x00\x00\xb4\x00\x00\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb8\x00\xb8\x00\xb8\x00\x00\x00\xb7\x00\x00\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\x00\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb7\x00\xb7\x00\xb7\x00\x00\x00\xb8\x00\x00\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb8\x00\xb8\x00\xb8\x00\x00\x00\xb7\x00\x00\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\xb7\x00\x00\x00\x00\x00\xbb\x00\x00\x00\x00\x00\x00\x00\xb8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\x00\x00\x00\x00\x00\x00\xbe\x00\xb8\x00\x00\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xb8\x00\xbe\x00\x00\x00\xbe\x00\xbe\x00\xbe\x00\xbe\x00\xbe\x00\x00\x00\x00\x00\xbe\x00\xbe\x00\x00\x00\xbe\x00\xbe\x00\xbe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbe\x00\x00\x00\xbe\x00\xbe\x00\xbe\x00\xbe\x00\xbe\x00\x00\x00\x00\x00\x00\x00\xbe\x00\x00\x00\xbe\x00\xbe\x00\xbe\x00\xbe\x00\xc0\x00\x00\x00\x00\x00\xbe\x00\xbe\x00\x00\x00\xbe\x00\xbe\x00\xbe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbe\x00\xbe\x00\xbe\x00\xbe\x00\xbe\x00\xbe\x00\xbe\x00\xbe\x00\x00\x00\x00\x00\x00\x00\xc0\x00\x00\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\x00\x00\x00\x00\xc0\x00\xc0\x00\x00\x00\xc0\x00\xc0\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbe\x00\x00\x00\xbe\x00\xbe\x00\xc0\x00\xbe\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\x00\x00\x00\x00\x00\x00\xc0\x00\x00\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc3\x00\x00\x00\x00\x00\xc0\x00\xc0\x00\x00\x00\xc0\x00\xc0\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbe\x00\x00\x00\xbe\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\x00\x00\x00\x00\x00\x00\xc3\x00\x00\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\x00\x00\xc1\x00\xc3\x00\xc3\x00\x00\x00\xc3\x00\xc3\x00\xc3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x00\x00\x00\xc0\x00\xc0\x00\xc3\x00\xc0\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\x00\x00\x00\x00\x00\x00\xc3\x00\x00\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc2\x00\x00\x00\xc1\x00\xc3\x00\xc3\x00\x00\x00\xc3\x00\xc3\x00\xc3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x00\x00\x00\xc0\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\x00\x00\x00\x00\x00\x00\xc2\x00\x00\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc7\x00\x00\x00\x00\x00\xc2\x00\xc2\x00\x00\x00\xc2\x00\xc2\x00\xc2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x00\x00\x00\xc3\x00\xc3\x00\xc6\x00\xc3\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\xc2\x00\x00\x00\x00\x00\x00\x00\xc7\x00\x00\x00\xc7\x00\xc7\x00\xc7\x00\xc7\x00\xc7\x00\x00\x00\xc5\x00\xc7\x00\xc7\x00\x00\x00\xc7\x00\xc7\x00\xc7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x00\x00\x00\xc3\x00\xc2\x00\xc7\x00\xc2\x00\xc7\x00\xc7\x00\xc7\x00\xc7\x00\xc7\x00\x00\x00\x00\x00\x00\x00\xc7\x00\x00\x00\xc7\x00\xc7\x00\xc7\x00\xc7\x00\xc9\x00\x00\x00\xc5\x00\xc7\x00\xc7\x00\x00\x00\xc7\x00\xc7\x00\xc7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc2\x00\x00\x00\xc2\x00\xc7\x00\xc7\x00\xc7\x00\xc7\x00\xc7\x00\xc7\x00\xc7\x00\xc7\x00\x00\x00\x00\x00\x00\x00\xc9\x00\x00\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\x00\x00\x00\x00\xc9\x00\xc9\x00\x00\x00\xc9\x00\xc9\x00\xc9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\x00\x00\xc7\x00\xc7\x00\xc9\x00\xc7\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\x00\x00\x00\x00\x00\x00\xc9\x00\x00\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\xca\x00\x00\x00\x00\x00\xc9\x00\xc9\x00\x00\x00\xc9\x00\xc9\x00\xc9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\x00\x00\xc7\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\x00\x00\x00\x00\x00\x00\xca\x00\x00\x00\xca\x00\xca\x00\xca\x00\xca\x00\x00\x00\x00\x00\x00\x00\xca\x00\xca\x00\x00\x00\xca\x00\xca\x00\xca\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc9\x00\x00\x00\xc9\x00\xc9\x00\xca\x00\xc9\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xd9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd4\x00\x00\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\xcc\x00\x00\x00\xc9\x00\x00\x00\xc9\x00\xca\x00\x00\x00\xca\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xce\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xca\x00\x00\x00\xca\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdc\x00\x00\x00\x00\x00\xce\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xec\x00\xd0\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\xde\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xef\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xef\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe2\x00\x00\x00\x00\x00\xe1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe4\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\x00\x00\x00\x00\x00\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\xe3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# +alex_table = AlexA# "\x00\x00\x0d\x00\xae\x00\xb4\x00\x0f\x00\xbf\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x0f\x00\x58\x00\x0d\x00\x0d\x00\x0d\x00\x10\x00\xff\xff\x5d\x00\x11\x00\x11\x00\x13\x00\x14\x00\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\x0d\x00\x29\x00\xff\xff\xff\xff\xff\xff\x0d\x00\xbf\x00\xea\x00\x76\x00\x8c\x00\xbf\x00\xbf\x00\xe9\x00\x96\x00\x9e\x00\xbf\x00\xbf\x00\xa1\x00\x26\x00\xbf\x00\xbf\x00\xc2\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\x7e\x00\xa2\x00\xbf\x00\xbf\x00\xbf\x00\x9a\x00\xbf\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\xae\x00\x7c\x00\xbf\x00\xa0\x00\xbf\x00\xb4\x00\xa3\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\xb4\x00\x19\x00\x89\x00\xa4\x00\xbf\x00\x0d\x00\xff\xff\xff\xff\xff\xff\x0f\x00\x41\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x27\x00\xff\xff\xff\xff\x0f\x00\x52\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\xff\xff\xff\xff\xff\xff\x0f\x00\x52\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x5e\x00\xff\xff\x43\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0d\x00\x12\x00\xff\xff\x54\x00\x22\x00\x42\x00\x44\x00\x45\x00\x47\x00\x0d\x00\x0d\x00\x28\x00\x54\x00\x22\x00\x0f\x00\x48\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x47\x00\x4a\x00\x22\x00\x0f\x00\x50\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x4b\x00\x4c\x00\x4d\x00\x4f\x00\x0e\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\xff\xff\x0e\x00\x0e\x00\x0e\x00\x4f\x00\x57\x00\x53\x00\x0d\x00\x0d\x00\x55\x00\xff\xff\x0f\x00\x22\x00\x0d\x00\x0d\x00\x0d\x00\x6f\x00\x0d\x00\x56\x00\x71\x00\x77\x00\x22\x00\x0e\x00\x6e\x00\x65\x00\x65\x00\x65\x00\x65\x00\x65\x00\x65\x00\x65\x00\x65\x00\x65\x00\x65\x00\x0d\x00\x7a\x00\x67\x00\x74\x00\x5f\x00\x79\x00\x9b\x00\xb7\x00\x0d\x00\xb8\x00\x16\x00\x79\x00\x0f\x00\x22\x00\x0d\x00\x0d\x00\x0d\x00\x0e\x00\xb9\x00\x15\x00\xba\x00\x10\x00\xff\xff\x0e\x00\x0e\x00\x0e\x00\x0d\x00\x46\x00\x15\x00\xdc\x00\x0f\x00\x4e\x00\x0d\x00\x0d\x00\x0d\x00\x0d\x00\x7a\x00\x6c\x00\x00\x00\x60\x00\x79\x00\xdd\x00\xde\x00\xe8\x00\x0e\x00\x00\x00\x79\x00\x00\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x0d\x00\x00\x00\x16\x00\x23\x00\x0f\x00\x00\x00\x0d\x00\x0d\x00\x0d\x00\x79\x00\x00\x00\x16\x00\x22\x00\x00\x00\x00\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x00\x00\x79\x00\x0d\x00\x00\x00\x00\x00\x70\x00\x00\x00\x79\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x79\x00\x24\x00\x95\x00\x00\x00\x00\x00\x79\x00\x65\x00\x65\x00\x65\x00\x65\x00\x65\x00\x65\x00\x65\x00\x65\x00\x65\x00\x65\x00\xad\x00\xb3\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x0f\x00\x58\x00\x0d\x00\x0d\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x00\x00\x00\x79\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x00\x00\x00\x00\x79\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x75\x00\x16\x00\x00\x00\x00\x00\x00\x00\x9d\x00\x9e\x00\x00\x00\x00\x00\xa1\x00\x25\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x6a\x00\x00\x00\x00\x00\x00\x00\xa2\x00\x79\x00\x00\x00\x00\x00\x00\x00\x16\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\xad\x00\x9f\x00\x00\x00\xa0\x00\x00\x00\xb3\x00\xa3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\xb3\x00\x18\x00\xff\xff\xa4\x00\xff\xff\xd1\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xc0\x00\x00\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\x00\x00\x2f\x00\x2f\x00\x30\x00\x30\x00\x31\x00\x33\x00\x00\x00\x2f\x00\x00\x00\x30\x00\x00\x00\x33\x00\x32\x00\x33\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x00\x33\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\x00\x00\x00\x00\x00\x00\xc0\x00\xc0\x00\x00\x00\x2a\x00\xc0\x00\xc0\x00\xd4\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xc0\x00\x00\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\xc4\x00\x00\x00\x2f\x00\x00\x00\x30\x00\x00\x00\x33\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd6\x00\x00\x00\x00\x00\x33\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\xc0\x00\x00\x00\xc0\x00\xff\xff\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\x2f\x00\x00\x00\x30\x00\x00\x00\x33\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x33\x00\x1e\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xc0\x00\x00\x00\xc0\x00\xff\xff\xff\xff\x69\x00\x3b\x00\xff\xff\xff\xff\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x69\x00\x00\x00\x69\x00\x69\x00\x69\x00\x69\x00\x00\x00\x00\x00\x00\x00\x69\x00\x69\x00\x00\x00\x3c\x00\x69\x00\x69\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x69\x00\x00\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x69\x00\x00\x00\x69\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\xc0\x00\x3b\x00\xff\xff\xff\xff\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x69\x00\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x21\x00\xc0\x00\x00\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\x00\x00\x00\x00\x00\x00\xc0\x00\xc0\x00\x00\x00\x3d\x00\xc0\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\xc0\x00\x00\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x00\x00\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\x69\x00\x3e\x00\xff\xff\xff\xff\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x00\xff\xff\xc0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\xd7\x00\x69\x00\x00\x00\x69\x00\x69\x00\x69\x00\x69\x00\x00\x00\x00\x00\x00\x00\x69\x00\x69\x00\x00\x00\x3f\x00\x69\x00\x69\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x69\x00\x00\x00\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x69\x00\x00\x00\x69\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x00\x00\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\x00\x00\x00\x00\x00\x00\xc0\x00\xc0\x00\xff\xff\x40\x00\xc0\x00\xc0\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x69\x00\xc0\x00\x69\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\x00\x00\x3e\x00\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x00\x00\x00\xc0\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x69\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x00\x00\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x69\x00\x00\x00\x69\x00\x69\x00\x69\x00\x69\x00\x00\x00\x00\x00\x00\x00\x69\x00\x69\x00\xc0\x00\x3f\x00\x69\x00\x69\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x69\x00\xff\xff\x69\x00\x69\x00\x69\x00\x69\x00\x69\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x00\x00\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\x00\x00\x00\x00\x00\x00\xc0\x00\xc0\x00\x00\x00\x40\x00\xc0\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x69\x00\x00\x00\x69\x00\x00\x00\x00\x00\xd0\x00\xc0\x00\x00\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\x59\x00\x59\x00\x59\x00\xcb\x00\x00\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x69\x00\x00\x00\x69\x00\x00\x00\x00\x00\x00\x00\x00\x00\xce\x00\xc0\x00\x00\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x00\x00\xce\x00\xc0\x00\x00\x00\xc0\x00\x00\x00\x00\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x00\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x5a\x00\x5a\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8f\x00\xff\xff\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\x8f\x00\xc8\x00\xc8\x00\xc8\x00\xc8\x00\xc8\x00\xc8\x00\xc8\x00\xc8\x00\xc8\x00\xc8\x00\x00\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5a\x00\x00\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5b\x00\x5b\x00\x5b\x00\x00\x00\x73\x00\x00\x00\x00\x00\x00\x00\x00\x00\x73\x00\x73\x00\x73\x00\x73\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\x00\x00\xdf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x73\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc8\x00\xc8\x00\xc8\x00\xc8\x00\xc8\x00\xc8\x00\xc8\x00\xc8\x00\xc8\x00\xc8\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x00\x00\xcc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\xcc\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x00\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5c\x00\x5c\x00\x5c\x00\xdf\x00\x73\x00\x00\x00\x00\x00\x00\x00\x00\x00\x73\x00\x73\x00\x73\x00\x73\x00\x00\x00\x00\x00\x00\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\x00\x00\xcd\x00\x00\x00\xcd\x00\x00\x00\x73\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\xc9\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x59\x00\x59\x00\x59\x00\xdf\x00\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x61\x00\x61\x00\x61\x00\x00\x00\x00\x00\x00\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\x00\x00\xcf\x00\x00\x00\xcf\x00\x00\x00\x61\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x00\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x5a\x00\x5a\x00\x5a\x00\x00\x00\x62\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x62\x00\x62\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\xca\x00\x00\x00\xd3\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x00\x00\x00\x00\x00\x00\xe3\x00\x00\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x00\x00\xe6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\xe6\x00\x00\x00\x00\x00\x00\x00\x5a\x00\x00\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5b\x00\x5b\x00\x5b\x00\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\x00\x63\x00\x63\x00\x63\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\x00\x00\xdf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\xe0\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x00\x00\xe4\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\xe4\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x00\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5c\x00\x5c\x00\x5c\x00\xdf\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x64\x00\x64\x00\x64\x00\x00\x00\x00\x00\x00\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\x00\x00\xe5\x00\x00\x00\xe5\x00\x00\x00\x64\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x59\x00\x59\x00\x59\x00\xdf\x00\x61\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x61\x00\x61\x00\x61\x00\x00\x00\x00\x00\x00\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\xe1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x00\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x59\x00\x5a\x00\x5a\x00\x5a\x00\x00\x00\x62\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\x62\x00\x62\x00\x62\x00\xe7\x00\x00\x00\xe7\x00\x00\x00\x00\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\x00\x00\x00\x00\x00\x00\x62\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\xe2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5a\x00\x00\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5a\x00\x5b\x00\x5b\x00\x5b\x00\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\x00\x63\x00\x63\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x00\x00\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5b\x00\x5c\x00\x5c\x00\x5c\x00\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x64\x00\x64\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x00\x00\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x5c\x00\x68\x00\x68\x00\x68\x00\x68\x00\x00\x00\x68\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x68\x00\x68\x00\x66\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x00\x00\x68\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x68\x00\x68\x00\x66\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x00\x00\x68\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x68\x00\x68\x00\x66\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x68\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x00\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6d\x00\x6b\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x00\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6d\x00\x6b\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x00\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6d\x00\x6b\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x72\x00\x72\x00\x72\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\x00\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x00\x00\x00\x00\x00\x00\x00\x00\x72\x00\x00\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x00\x00\x73\x00\x00\x00\x00\x00\x00\x00\x00\x00\x73\x00\x73\x00\x73\x00\x73\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x73\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x00\x00\x00\x00\x00\x00\xc0\x00\x72\x00\x00\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\x72\x00\xc0\x00\x00\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\x00\x00\x9c\x00\xc0\x00\xc0\x00\x00\x00\x78\x00\xc0\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x00\x00\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\x00\x00\x00\x00\x00\x00\xc0\x00\x93\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\x00\x00\x00\x00\x00\x00\xc0\x00\xc0\x00\x00\x00\xc0\x00\xc0\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x91\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x00\x7b\x00\xc0\x00\xc0\x00\x00\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x00\x74\x00\xc0\x00\x93\x00\xc1\x00\x93\x00\x93\x00\x93\x00\x85\x00\x81\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x83\x00\x93\x00\x93\x00\x93\x00\x87\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x93\x00\x00\x00\x7f\x00\xc1\x00\x00\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\x00\x00\x00\x00\x00\x00\xc1\x00\xc1\x00\x00\x00\xc1\x00\xc1\x00\xc1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc1\x00\x00\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\x94\x00\x94\x00\x94\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc1\x00\x7d\x00\xc1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x00\x00\x00\x00\xc1\x00\x00\x00\xc1\x00\x00\x00\x00\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x00\x00\x94\x00\x00\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x00\x00\x94\x00\x00\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x00\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x00\x00\x94\x00\x00\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x00\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x00\x00\x00\x00\x00\x00\xc0\x00\x94\x00\x00\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\xc0\x00\x86\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\x00\x00\x00\x00\x97\x00\xc0\x00\xc0\x00\x00\x00\xc0\x00\xc0\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x00\x00\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\x8b\x00\x8b\x00\x8b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x00\x88\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x00\x00\x00\x00\xc0\x00\x00\x00\xc0\x00\x00\x00\x00\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x00\x00\x8b\x00\x00\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x00\x00\x8a\x00\x00\x00\xc0\x00\x8b\x00\x00\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\x8b\x00\xc0\x00\x00\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\x00\x00\x8d\x00\x00\x00\xc0\x00\xc0\x00\x00\x00\xc0\x00\xc0\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x00\x00\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x00\x00\x00\xc0\x00\x8a\x00\x00\x00\x8a\x00\x8a\x00\x8a\x00\x8a\x00\x8a\x00\x8a\x00\x8a\x00\x8a\x00\x8a\x00\x8a\x00\x8a\x00\x8a\x00\x8a\x00\x8a\x00\x8a\x00\x8a\x00\x8a\x00\x8a\x00\x8a\x00\x8a\x00\x8a\x00\x8a\x00\x8a\x00\x8a\x00\x8a\x00\x8a\x00\x90\x00\xc0\x00\x00\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x8e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x94\x00\x94\x00\x94\x00\x00\x00\x90\x00\x00\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x90\x00\x00\x00\x8e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x00\x00\x94\x00\x00\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x00\x00\x92\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x99\x00\x99\x00\x99\x00\x00\x00\x94\x00\x00\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x94\x00\x00\x00\x92\x00\x00\x00\x00\x00\x00\x00\x00\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x00\x00\x99\x00\x00\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x00\x00\x98\x00\x00\x00\xc0\x00\x99\x00\x00\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\x99\x00\xc0\x00\x00\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\x00\x00\x00\x00\x00\x00\xc0\x00\xc0\x00\x00\x00\xc0\x00\xc0\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x00\x00\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa7\x00\xa7\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x00\x00\x00\xc0\x00\x98\x00\x00\x00\x98\x00\x98\x00\x98\x00\x98\x00\x98\x00\x98\x00\x98\x00\x98\x00\x98\x00\x98\x00\x98\x00\x98\x00\x98\x00\x98\x00\x98\x00\x98\x00\x98\x00\x98\x00\x98\x00\x98\x00\x98\x00\x98\x00\x98\x00\x98\x00\x98\x00\x98\x00\xa7\x00\xc0\x00\x00\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa8\x00\xa8\x00\xa8\x00\x00\x00\xa7\x00\x00\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa7\x00\xa7\x00\xa7\x00\x00\x00\xa8\x00\x00\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa8\x00\xa8\x00\xa8\x00\x00\x00\xa7\x00\x00\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\xa7\x00\x00\x00\x00\x00\xb7\x00\x00\x00\x00\x00\x00\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\x00\x00\xab\x00\xa5\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa8\x00\x00\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xa8\x00\xab\x00\xab\x00\xab\x00\xab\x00\xab\x00\xab\x00\xab\x00\xab\x00\xab\x00\xab\x00\xab\x00\xab\x00\xab\x00\xab\x00\xab\x00\xab\x00\xab\x00\xab\x00\xab\x00\xab\x00\xab\x00\xab\x00\xab\x00\xab\x00\xab\x00\xab\x00\xac\x00\xa6\x00\x00\x00\xbb\x00\xa5\x00\x00\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xa5\x00\xbb\x00\x00\x00\xbb\x00\xbb\x00\xbb\x00\xbb\x00\x00\x00\x00\x00\x00\x00\xbb\x00\xbb\x00\x00\x00\xbb\x00\xbb\x00\xbb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbd\x00\x00\x00\xbb\x00\xbb\x00\xbb\x00\xbb\x00\xbb\x00\xac\x00\xac\x00\xac\x00\xac\x00\xac\x00\xac\x00\xac\x00\xac\x00\xac\x00\xac\x00\xac\x00\xac\x00\xac\x00\xac\x00\xac\x00\xac\x00\xac\x00\xac\x00\xac\x00\xac\x00\xac\x00\xac\x00\xac\x00\xac\x00\xac\x00\xac\x00\x00\x00\xbb\x00\x00\x00\xbb\x00\xa6\x00\x00\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xa6\x00\xd2\x00\xbb\x00\x00\x00\xbb\x00\xaf\x00\xaf\x00\xaf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\x00\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xc6\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xb0\x00\xb0\x00\xb0\x00\x00\x00\xaf\x00\x00\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\x00\x00\x00\x00\xb8\x00\x00\x00\x00\x00\x00\x00\xb0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaa\x00\x00\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb1\x00\xb1\x00\xb1\x00\x00\x00\xb0\x00\x00\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb2\x00\xb2\x00\xb2\x00\x00\x00\xb1\x00\x00\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\x00\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaa\x00\x00\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xaf\x00\xaf\x00\xaf\x00\x00\x00\xb2\x00\x00\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xb0\x00\xb0\x00\xb0\x00\x00\x00\xaf\x00\x00\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\xaf\x00\x00\x00\x00\x00\xb8\x00\x00\x00\x00\x00\x00\x00\xb0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaa\x00\x00\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb1\x00\xb1\x00\xb1\x00\x00\x00\xb0\x00\x00\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\xb0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x00\x00\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb2\x00\xb2\x00\xb2\x00\x00\x00\xb1\x00\x00\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\xb1\x00\x00\x00\x00\x00\xba\x00\x00\x00\x00\x00\x00\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xaa\x00\x00\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb5\x00\xb5\x00\xb5\x00\x00\x00\xb2\x00\x00\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\xb2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb6\x00\xb6\x00\xb6\x00\x00\x00\xb5\x00\x00\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\x00\x00\x00\x00\xb9\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb5\x00\xb5\x00\xb5\x00\x00\x00\xb6\x00\x00\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb6\x00\xb6\x00\xb6\x00\x00\x00\xb5\x00\x00\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\xb5\x00\x00\x00\x00\x00\xb9\x00\x00\x00\x00\x00\x00\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\x00\x00\x00\x00\x00\x00\xbc\x00\xb6\x00\x00\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xb6\x00\xbc\x00\x00\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\x00\x00\x00\x00\xbc\x00\xbc\x00\x00\x00\xbc\x00\xbc\x00\xbc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x00\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x00\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbe\x00\x00\x00\x00\x00\xbc\x00\xbc\x00\x00\x00\xbc\x00\xbc\x00\xbc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\xbc\x00\x00\x00\x00\x00\x00\x00\xbe\x00\x00\x00\xbe\x00\xbe\x00\xbe\x00\xbe\x00\xbe\x00\x00\x00\x00\x00\xbe\x00\xbe\x00\x00\x00\xbe\x00\xbe\x00\xbe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x00\x00\xbc\x00\xbc\x00\xbe\x00\xbc\x00\xbe\x00\xbe\x00\xbe\x00\xbe\x00\xbe\x00\x00\x00\x00\x00\x00\x00\xbe\x00\x00\x00\xbe\x00\xbe\x00\xbe\x00\xbe\x00\xc0\x00\x00\x00\x00\x00\xbe\x00\xbe\x00\x00\x00\xbe\x00\xbe\x00\xbe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x00\x00\x00\xbc\x00\xbe\x00\xbe\x00\xbe\x00\xbe\x00\xbe\x00\xbe\x00\xbe\x00\xbe\x00\x00\x00\x00\x00\x00\x00\xc0\x00\x00\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\x00\x00\x00\x00\xc0\x00\xc0\x00\x00\x00\xc0\x00\xc0\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbe\x00\x00\x00\xbe\x00\xbe\x00\xc0\x00\xbe\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\x00\x00\x00\x00\x00\x00\xc0\x00\x00\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc1\x00\x00\x00\x00\x00\xc0\x00\xc0\x00\x00\x00\xc0\x00\xc0\x00\xc0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbe\x00\x00\x00\xbe\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\xc0\x00\x00\x00\x00\x00\x00\x00\xc1\x00\x00\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\x00\x00\x00\x00\x00\x00\xc1\x00\xc1\x00\x00\x00\xc1\x00\xc1\x00\xc1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc0\x00\x00\x00\xc0\x00\xc0\x00\xc1\x00\xc0\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xc1\x00\xd0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcb\x00\x00\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\xc3\x00\x00\x00\xc0\x00\x00\x00\xc0\x00\xc1\x00\x00\x00\xc1\x00\x00\x00\x00\x00\x00\x00\x00\x00\xce\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc1\x00\x00\x00\xc1\x00\x00\x00\x00\x00\x00\x00\x00\x00\xce\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd3\x00\x00\x00\x00\x00\xc5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x00\xc7\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\xd5\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe6\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x00\x00\x00\x00\x00\xd8\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\x00\x00\x00\x00\x00\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\xda\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# alex_check :: AlexAddr -alex_check = AlexA# "\xff\xff\x05\x00\x01\x00\x02\x00\x09\x00\x04\x00\x05\x00\x0b\x00\x0c\x00\x0d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x09\x00\x0a\x00\x23\x00\x2d\x00\x2d\x00\x2d\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x2d\x00\x2d\x00\x0a\x00\x20\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x05\x00\x2d\x00\x0a\x00\x0a\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x05\x00\x2d\x00\x0a\x00\x0a\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x05\x00\x0a\x00\x0a\x00\x0a\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x20\x00\x23\x00\x0a\x00\x23\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x20\x00\x2d\x00\x0a\x00\x23\x00\x2d\x00\x65\x00\x6e\x00\x69\x00\x0a\x00\x20\x00\x05\x00\x2d\x00\x23\x00\x2d\x00\x09\x00\x61\x00\x0b\x00\x0c\x00\x0d\x00\x05\x00\x0a\x00\x6d\x00\x2d\x00\x09\x00\x21\x00\x0b\x00\x0c\x00\x0d\x00\x05\x00\x67\x00\x61\x00\x72\x00\x0a\x00\x05\x00\x0b\x00\x0c\x00\x0d\x00\x20\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0a\x00\x6c\x00\x7c\x00\x05\x00\x20\x00\x65\x00\x6e\x00\x09\x00\x2d\x00\x0b\x00\x0c\x00\x0d\x00\x7d\x00\x20\x00\x69\x00\x0a\x00\x2d\x00\x2d\x00\x20\x00\x7d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x20\x00\x20\x00\x22\x00\x2d\x00\x23\x00\x24\x00\x7d\x00\x23\x00\x05\x00\x23\x00\x7b\x00\x2a\x00\x09\x00\x2d\x00\x0b\x00\x0c\x00\x0d\x00\x05\x00\x23\x00\x7b\x00\x23\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x05\x00\x6c\x00\x7b\x00\x23\x00\x09\x00\x70\x00\x0b\x00\x0c\x00\x0d\x00\x20\x00\x20\x00\x22\x00\xff\xff\x23\x00\x24\x00\x23\x00\x23\x00\x23\x00\x20\x00\x23\x00\x2a\x00\xff\xff\x2d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x05\x00\xff\xff\x7b\x00\x2d\x00\x09\x00\xff\xff\x0b\x00\x0c\x00\x0d\x00\x5e\x00\xff\xff\x7b\x00\x2d\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x24\x00\x20\x00\xff\xff\xff\xff\x23\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\xff\xff\x7c\x00\x2d\x00\xff\xff\x7c\x00\xff\xff\x5e\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x01\x00\x02\x00\xff\xff\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\xff\xff\x7c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\xff\xff\xff\xff\x5e\x00\xff\xff\x20\x00\xff\xff\xff\xff\x23\x00\x7b\x00\xff\xff\xff\xff\xff\xff\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\x2d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\x3b\x00\x7c\x00\xff\xff\xff\xff\xff\xff\x7b\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\x5d\x00\xff\xff\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x0a\x00\x7d\x00\x0a\x00\x23\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\x04\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\xff\xff\x23\x00\x24\x00\x23\x00\x24\x00\x23\x00\x24\x00\xff\xff\x2a\x00\xff\xff\x2a\x00\xff\xff\x2a\x00\x23\x00\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\x2a\x00\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\xff\xff\x5e\x00\xff\xff\x5e\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\x5e\x00\xff\xff\xff\xff\x04\x00\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\x0a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x7c\x00\xff\xff\x7c\x00\xff\xff\x7c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x7c\x00\xff\xff\x7e\x00\x2a\x00\x2b\x00\x04\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\x04\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x3a\x00\x7e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\x04\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x3a\x00\x7e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\x04\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x3a\x00\x7e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\x04\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x3a\x00\x7e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\x23\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x01\x00\x02\x00\x03\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x65\x00\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x0a\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x65\x00\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\x23\x00\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x2b\x00\xff\xff\x2d\x00\xff\xff\x20\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\x23\x00\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x2b\x00\xff\xff\x2d\x00\xff\xff\x20\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x65\x00\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x65\x00\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\x23\x00\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x2b\x00\xff\xff\x2d\x00\xff\xff\x20\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\x23\x00\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x2b\x00\xff\xff\x2d\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\x20\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\x06\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\x06\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\x06\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\x06\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\x06\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\x06\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\x04\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x04\x00\xff\xff\x29\x00\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x21\x00\x02\x00\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\x3a\x00\x5e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x3a\x00\x7e\x00\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x5f\x00\x04\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\x5d\x00\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\x04\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x21\x00\x7c\x00\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\x29\x00\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\x5d\x00\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\x02\x00\xff\xff\x04\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\x28\x00\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\x02\x00\xff\xff\x04\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\xff\xff\x04\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\x28\x00\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\x7c\x00\xff\xff\x7e\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\x04\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x04\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x04\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\x3a\x00\x5e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x04\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\x5c\x00\x3a\x00\x5e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x04\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\x5c\x00\x3a\x00\x5e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x04\x00\xff\xff\x29\x00\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\x5c\x00\x3a\x00\x5e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x04\x00\xff\xff\x29\x00\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\x5c\x00\x3a\x00\x5e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x04\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\x5c\x00\x3a\x00\x5e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x04\x00\xff\xff\x29\x00\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\x5c\x00\x3a\x00\x5e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x04\x00\xff\xff\x29\x00\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\x5c\x00\x3a\x00\x5e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x04\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\x5c\x00\x3a\x00\x5e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x04\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\x5c\x00\x3a\x00\x5e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\x5c\x00\x3a\x00\x5e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\x78\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x78\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# +alex_check = AlexA# "\xff\xff\x05\x00\x01\x00\x02\x00\x09\x00\x04\x00\x05\x00\x0b\x00\x0c\x00\x0d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x09\x00\x0a\x00\x23\x00\x2d\x00\x2d\x00\x2d\x00\x2d\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x2d\x00\x0a\x00\x20\x00\x2d\x00\x0a\x00\x0a\x00\x0a\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x05\x00\x0a\x00\x0a\x00\x0a\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x05\x00\x2d\x00\x0a\x00\x0a\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x05\x00\x0a\x00\x0a\x00\x0a\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x20\x00\x23\x00\x0a\x00\x23\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x0a\x00\x20\x00\x2d\x00\x0a\x00\x23\x00\x2d\x00\x65\x00\x6e\x00\x69\x00\x0a\x00\x20\x00\x05\x00\x2d\x00\x23\x00\x2d\x00\x09\x00\x61\x00\x0b\x00\x0c\x00\x0d\x00\x05\x00\x0a\x00\x6d\x00\x2d\x00\x09\x00\x21\x00\x0b\x00\x0c\x00\x0d\x00\x05\x00\x67\x00\x61\x00\x72\x00\x0a\x00\x05\x00\x0b\x00\x0c\x00\x0d\x00\x20\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0a\x00\x6c\x00\x65\x00\x05\x00\x20\x00\x6e\x00\x0a\x00\x09\x00\x2d\x00\x0b\x00\x0c\x00\x0d\x00\x7d\x00\x20\x00\x69\x00\x2d\x00\x2d\x00\x2d\x00\x20\x00\x7d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x20\x00\x20\x00\x22\x00\x7d\x00\x23\x00\x24\x00\x23\x00\x23\x00\x05\x00\x23\x00\x7b\x00\x2a\x00\x09\x00\x2d\x00\x0b\x00\x0c\x00\x0d\x00\x05\x00\x23\x00\x7b\x00\x23\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x05\x00\x6c\x00\x7b\x00\x23\x00\x09\x00\x70\x00\x0b\x00\x0c\x00\x0d\x00\x20\x00\x20\x00\x22\x00\xff\xff\x23\x00\x24\x00\x23\x00\x23\x00\x23\x00\x20\x00\xff\xff\x2a\x00\xff\xff\x2d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x05\x00\xff\xff\x7b\x00\x2d\x00\x09\x00\xff\xff\x0b\x00\x0c\x00\x0d\x00\x5e\x00\xff\xff\x7b\x00\x2d\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x24\x00\x20\x00\xff\xff\xff\xff\x23\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\xff\xff\x7c\x00\x2d\x00\x7c\x00\xff\xff\xff\xff\x5e\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x01\x00\x02\x00\xff\xff\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\xff\xff\x7c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7b\x00\xff\xff\xff\xff\x5e\x00\xff\xff\x20\x00\xff\xff\xff\xff\x23\x00\x7b\x00\xff\xff\xff\xff\xff\xff\x28\x00\x29\x00\xff\xff\xff\xff\x2c\x00\x2d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\x3b\x00\x7c\x00\xff\xff\xff\xff\xff\xff\x7b\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\xff\xff\x5d\x00\xff\xff\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x0a\x00\x7d\x00\x0a\x00\x23\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\x04\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\xff\xff\x23\x00\x24\x00\x23\x00\x24\x00\x23\x00\x24\x00\xff\xff\x2a\x00\xff\xff\x2a\x00\xff\xff\x2a\x00\x23\x00\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\x2a\x00\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\xff\xff\x5e\x00\xff\xff\x5e\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\x5e\x00\xff\xff\xff\xff\x04\x00\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\x0a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x7c\x00\xff\xff\x7c\x00\xff\xff\x7c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x7c\x00\xff\xff\x7e\x00\x2a\x00\x2b\x00\x04\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\x04\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x3a\x00\x7e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\x04\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x3a\x00\x7e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\x04\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x3a\x00\x7e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x04\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\x04\x00\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x3a\x00\x7e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\x23\x00\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x01\x00\x02\x00\x03\x00\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x65\x00\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x0a\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x65\x00\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\x23\x00\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x2b\x00\xff\xff\x2d\x00\xff\xff\x20\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\x23\x00\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x2b\x00\xff\xff\x2d\x00\xff\xff\x20\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x65\x00\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x65\x00\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\x23\x00\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x2b\x00\xff\xff\x2d\x00\xff\xff\x20\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\x23\x00\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x2b\x00\xff\xff\x2d\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\x20\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\x06\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\x06\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\x06\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\x06\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\x06\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x01\x00\x02\x00\x03\x00\x04\x00\xff\xff\x06\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\x2b\x00\x2c\x00\x2d\x00\x2e\x00\x2f\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x3a\x00\x3b\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x5b\x00\x5c\x00\x5d\x00\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x0b\x00\x0c\x00\x0d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x20\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\x04\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x04\x00\xff\xff\x29\x00\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x21\x00\x02\x00\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\x3a\x00\x5e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x3a\x00\x7e\x00\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x5f\x00\x04\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\x5d\x00\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\x04\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x21\x00\x7c\x00\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\x29\x00\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\x5d\x00\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\x02\x00\xff\xff\x04\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\x28\x00\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\x02\x00\xff\xff\x04\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x27\x00\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\xff\xff\x04\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\x7c\x00\xff\xff\x7e\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\x01\x00\x02\x00\x03\x00\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\x04\x00\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x04\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3a\x00\xff\xff\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x04\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5c\x00\x3a\x00\x5e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x04\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\x5c\x00\x3a\x00\x5e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x04\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\x5c\x00\x3a\x00\x5e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x04\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\x5c\x00\x3a\x00\x5e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\x04\x00\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\x5c\x00\x3a\x00\x5e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\xff\xff\xff\xff\xff\xff\x21\x00\xff\xff\x23\x00\x24\x00\x25\x00\x26\x00\xff\xff\xff\xff\xff\xff\x2a\x00\x2b\x00\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\x5c\x00\x3a\x00\x5e\x00\x3c\x00\x3d\x00\x3e\x00\x3f\x00\x40\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\x7c\x00\xff\xff\x7e\x00\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\xff\xff\x7e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x2e\x00\x78\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x58\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x23\x00\xff\xff\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x78\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# alex_deflt :: AlexAddr -alex_deflt = AlexA# "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x69\x00\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\x1c\x00\x1d\x00\x1c\x00\x1d\x00\x1a\x00\x1b\x00\x1a\x00\x1a\x00\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\x2b\x00\x2c\x00\x2b\x00\x2b\x00\x2d\x00\x2e\x00\x2d\x00\x2e\x00\x34\x00\x35\x00\x34\x00\x36\x00\x34\x00\x34\x00\x35\x00\x36\x00\x39\x00\x3a\x00\x39\x00\x3a\x00\x37\x00\x38\x00\x37\x00\x37\x00\x38\x00\x37\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x51\x00\x51\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# +alex_deflt = AlexA# "\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x69\x00\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\x1c\x00\x1d\x00\x1c\x00\x1d\x00\x1a\x00\x1b\x00\x1a\x00\x1a\x00\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\x2b\x00\x2c\x00\x2b\x00\x2b\x00\x2d\x00\x2e\x00\x2d\x00\x2e\x00\x34\x00\x35\x00\x34\x00\x36\x00\x34\x00\x34\x00\x35\x00\x36\x00\x39\x00\x3a\x00\x39\x00\x3a\x00\x37\x00\x38\x00\x37\x00\x37\x00\x38\x00\x37\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x51\x00\x51\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# -alex_accept = listArray (0::Int,243) [[],[(AlexAcc (alex_action_13))],[(AlexAcc (alex_action_17))],[(AlexAcc (alex_action_18))],[(AlexAcc (alex_action_19))],[],[],[(AlexAcc (alex_action_24))],[],[],[],[],[],[(AlexAccSkip)],[(AlexAccSkip)],[(AlexAcc (alex_action_1))],[(AlexAcc (alex_action_1))],[(AlexAccPred (alex_action_2) ( isNormalComment ))],[(AlexAccPred (alex_action_2) ( isNormalComment )),(AlexAcc (alex_action_24))],[(AlexAccPred (alex_action_2) ( isNormalComment ))],[(AlexAccPred (alex_action_2) ( isNormalComment ))],[(AlexAccPred (alex_action_14) ( notFollowedBy '-' ))],[],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_65))],[(AlexAcc (alex_action_65))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_3))],[(AlexAccPred (alex_action_8) ( atEOL ))],[(AlexAccPred (alex_action_8) ( atEOL )),(AlexAcc (alex_action_24))],[(AlexAccPred (alex_action_8) ( atEOL ))],[(AlexAccPred (alex_action_8) ( atEOL ))],[],[(AlexAcc (alex_action_24))],[],[],[(AlexAcc (alex_action_79))],[(AlexAccPred (alex_action_7) ( atEOL ))],[(AlexAccPred (alex_action_7) ( atEOL )),(AlexAcc (alex_action_24))],[(AlexAccPred (alex_action_7) ( atEOL ))],[(AlexAccPred (alex_action_7) ( atEOL )),(AlexAcc (alex_action_79))],[(AlexAcc (alex_action_4))],[(AlexAcc (alex_action_4))],[(AlexAcc (alex_action_4))],[(AlexAcc (alex_action_4))],[(AlexAccPred (alex_action_5) ( ifExtension (not . haddockEnabled) ))],[(AlexAccPred (alex_action_5) ( ifExtension (not . haddockEnabled) )),(AlexAcc (alex_action_24))],[(AlexAccPred (alex_action_5) ( ifExtension (not . haddockEnabled) )),(AlexAcc (alex_action_33))],[(AlexAccPred (alex_action_5) ( ifExtension (not . haddockEnabled) )),(AlexAcc (alex_action_35))],[(AlexAccPred (alex_action_5) ( ifExtension (not . haddockEnabled) )),(AlexAccPred (alex_action_37) ( ifExtension haddockEnabled ))],[(AlexAccPred (alex_action_5) ( ifExtension (not . haddockEnabled) ))],[(AlexAccPred (alex_action_5) ( ifExtension (not . haddockEnabled) )),(AlexAcc (alex_action_24))],[(AlexAccPred (alex_action_5) ( ifExtension (not . haddockEnabled) )),(AlexAcc (alex_action_35))],[(AlexAcc (alex_action_6))],[(AlexAcc (alex_action_6))],[(AlexAcc (alex_action_6))],[(AlexAcc (alex_action_6))],[(AlexAccPred (alex_action_7) ( atEOL ))],[(AlexAccPred (alex_action_7) ( atEOL )),(AlexAcc (alex_action_24))],[(AlexAccPred (alex_action_7) ( atEOL )),(AlexAcc (alex_action_79))],[(AlexAccPred (alex_action_7) ( atEOL ))],[(AlexAccPred (alex_action_7) ( atEOL )),(AlexAcc (alex_action_24))],[(AlexAccPred (alex_action_7) ( atEOL )),(AlexAcc (alex_action_79))],[(AlexAccSkip)],[(AlexAccPred (alex_action_10) (alexPrevCharIs '\n'))],[(AlexAccPred (alex_action_10) (alexPrevCharIs '\n'))],[],[],[],[(AlexAccSkipPred (alexPrevCharIs '\n'))],[],[],[],[],[],[],[],[(AlexAccSkipPred (alexPrevCharIs '\n'))],[],[],[(AlexAccSkip)],[(AlexAccPred (alex_action_16) (alexPrevCharIs '\n'))],[(AlexAccPred (alex_action_16) (alexPrevCharIs '\n'))],[],[],[],[(AlexAcc (alex_action_20))],[(AlexAccPred (alex_action_21) ( known_pragma linePrags ))],[(AlexAccPred (alex_action_21) ( known_pragma linePrags )),(AlexAcc (alex_action_24))],[(AlexAccPred (alex_action_21) ( known_pragma linePrags )),(AlexAccPred (alex_action_29) ( known_pragma oneWordPrags )),(AlexAccPred (alex_action_30) ( known_pragma ignoredPrags )),(AlexAccPred (alex_action_32) ( known_pragma fileHeaderPrags ))],[(AlexAccPred (alex_action_21) ( known_pragma linePrags )),(AlexAccPred (alex_action_29) ( known_pragma oneWordPrags )),(AlexAccPred (alex_action_30) ( known_pragma ignoredPrags )),(AlexAccPred (alex_action_34) ( known_pragma fileHeaderPrags ))],[],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_36))],[(AlexAcc (alex_action_36))],[],[(AlexAcc (alex_action_24))],[],[],[(AlexAcc (alex_action_22))],[(AlexAcc (alex_action_23))],[],[],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_26))],[],[],[(AlexAcc (alex_action_27))],[(AlexAcc (alex_action_27))],[],[],[(AlexAccPred (alex_action_28) ( known_pragma twoWordPrags ))],[],[(AlexAcc (alex_action_31))],[],[(AlexAcc (alex_action_79))],[],[(AlexAcc (alex_action_79))],[(AlexAccPred (alex_action_38) ( ifExtension haddockEnabled ))],[],[(AlexAccPred (alex_action_39) ( ifExtension parrEnabled ))],[(AlexAcc (alex_action_60))],[(AlexAccPred (alex_action_40) ( ifExtension parrEnabled ))],[(AlexAcc (alex_action_80))],[(AlexAccPred (alex_action_41) ( ifExtension thEnabled ))],[(AlexAccPred (alex_action_42) ( ifExtension thEnabled )),(AlexAccPred (alex_action_50) ( ifExtension qqEnabled ))],[],[(AlexAccPred (alex_action_43) ( ifExtension thEnabled )),(AlexAccPred (alex_action_50) ( ifExtension qqEnabled ))],[],[(AlexAccPred (alex_action_44) ( ifExtension thEnabled )),(AlexAccPred (alex_action_50) ( ifExtension qqEnabled ))],[],[(AlexAccPred (alex_action_45) ( ifExtension thEnabled )),(AlexAccPred (alex_action_50) ( ifExtension qqEnabled ))],[],[(AlexAccPred (alex_action_46) ( ifExtension thEnabled ))],[(AlexAcc (alex_action_79))],[(AlexAccPred (alex_action_47) ( ifExtension thEnabled ))],[(AlexAccPred (alex_action_47) ( ifExtension thEnabled ))],[(AlexAcc (alex_action_79))],[(AlexAccPred (alex_action_48) ( ifExtension thEnabled ))],[(AlexAccPred (alex_action_49) ( ifExtension qqEnabled ))],[],[],[],[(AlexAccPred (alex_action_50) ( ifExtension qqEnabled ))],[],[],[(AlexAccPred (alex_action_51) ( ifExtension arrowsEnabled `alexAndPred` notFollowedBySymbol ))],[(AlexAcc (alex_action_58))],[(AlexAccPred (alex_action_52) ( ifExtension arrowsEnabled ))],[(AlexAccPred (alex_action_53) ( ifExtension ipEnabled ))],[(AlexAccPred (alex_action_53) ( ifExtension ipEnabled ))],[(AlexAcc (alex_action_79))],[(AlexAccPred (alex_action_54) ( ifExtension unboxedTuplesEnabled `alexAndPred` notFollowedBySymbol ))],[(AlexAccPred (alex_action_55) ( ifExtension unboxedTuplesEnabled ))],[(AlexAccPred (alex_action_56) ( ifExtension genericsEnabled ))],[(AlexAccPred (alex_action_57) ( ifExtension genericsEnabled ))],[(AlexAcc (alex_action_58))],[(AlexAcc (alex_action_59))],[(AlexAcc (alex_action_60))],[(AlexAcc (alex_action_61))],[(AlexAcc (alex_action_62))],[(AlexAcc (alex_action_63))],[(AlexAcc (alex_action_64))],[(AlexAcc (alex_action_66))],[(AlexAcc (alex_action_67))],[(AlexAcc (alex_action_67))],[(AlexAcc (alex_action_67))],[(AlexAcc (alex_action_67))],[],[],[(AlexAcc (alex_action_68))],[(AlexAcc (alex_action_68))],[(AlexAcc (alex_action_70))],[(AlexAcc (alex_action_70))],[(AlexAcc (alex_action_68))],[(AlexAcc (alex_action_68))],[(AlexAcc (alex_action_70))],[(AlexAcc (alex_action_70))],[(AlexAcc (alex_action_69))],[(AlexAcc (alex_action_69))],[(AlexAcc (alex_action_69))],[(AlexAcc (alex_action_69))],[(AlexAccPred (alex_action_71) ( ifExtension magicHashEnabled ))],[(AlexAccPred (alex_action_72) ( ifExtension magicHashEnabled ))],[(AlexAccPred (alex_action_73) ( ifExtension magicHashEnabled ))],[(AlexAccPred (alex_action_74) ( ifExtension magicHashEnabled ))],[(AlexAccPred (alex_action_75) ( ifExtension oldQualOps ))],[(AlexAccPred (alex_action_75) ( ifExtension oldQualOps ))],[(AlexAccPred (alex_action_76) ( ifExtension oldQualOps ))],[(AlexAccPred (alex_action_76) ( ifExtension oldQualOps ))],[(AlexAccPred (alex_action_77) ( ifExtension newQualOps ))],[],[],[],[(AlexAccPred (alex_action_78) ( ifExtension newQualOps ))],[],[],[(AlexAcc (alex_action_79))],[(AlexAcc (alex_action_79))],[(AlexAcc (alex_action_80))],[(AlexAcc (alex_action_81))],[(AlexAcc (alex_action_81))],[(AlexAcc (alex_action_82))],[],[(AlexAcc (alex_action_83))],[],[(AlexAcc (alex_action_84))],[(AlexAcc (alex_action_84))],[(AlexAcc (alex_action_84))],[],[],[],[],[],[(AlexAccPred (alex_action_85) ( ifExtension magicHashEnabled ))],[(AlexAccPred (alex_action_86) ( ifExtension magicHashEnabled ))],[(AlexAccPred (alex_action_87) ( ifExtension magicHashEnabled ))],[(AlexAccPred (alex_action_88) ( ifExtension magicHashEnabled ))],[],[],[(AlexAccPred (alex_action_89) ( ifExtension magicHashEnabled ))],[],[],[(AlexAccPred (alex_action_90) ( ifExtension magicHashEnabled ))],[],[],[(AlexAccPred (alex_action_91) ( ifExtension magicHashEnabled ))],[(AlexAccPred (alex_action_92) ( ifExtension magicHashEnabled ))],[(AlexAccPred (alex_action_93) ( ifExtension magicHashEnabled ))],[(AlexAccPred (alex_action_94) ( ifExtension magicHashEnabled ))],[],[],[],[],[],[],[],[],[(AlexAccPred (alex_action_95) ( ifExtension magicHashEnabled ))],[(AlexAcc (alex_action_96))],[(AlexAcc (alex_action_97))]] -{-# LINE 421 "compiler/parser/Lexer.x" #-} +alex_accept = listArray (0::Int,234) [[],[(AlexAcc (alex_action_13))],[(AlexAcc (alex_action_17))],[(AlexAcc (alex_action_18))],[(AlexAcc (alex_action_19))],[],[],[(AlexAcc (alex_action_24))],[],[],[],[],[],[(AlexAccSkip)],[(AlexAccSkip)],[(AlexAcc (alex_action_1))],[(AlexAcc (alex_action_1))],[(AlexAccPred (alex_action_2) ( isNormalComment ))],[(AlexAccPred (alex_action_2) ( isNormalComment )),(AlexAcc (alex_action_24))],[(AlexAccPred (alex_action_2) ( isNormalComment ))],[(AlexAccPred (alex_action_2) ( isNormalComment ))],[(AlexAccPred (alex_action_14) ( notFollowedBy '-' ))],[],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_63))],[(AlexAcc (alex_action_63))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_3))],[(AlexAccPred (alex_action_8) ( atEOL ))],[(AlexAccPred (alex_action_8) ( atEOL )),(AlexAcc (alex_action_24))],[(AlexAccPred (alex_action_8) ( atEOL ))],[(AlexAccPred (alex_action_8) ( atEOL ))],[],[(AlexAcc (alex_action_24))],[],[],[(AlexAcc (alex_action_75))],[(AlexAccPred (alex_action_7) ( atEOL ))],[(AlexAccPred (alex_action_7) ( atEOL )),(AlexAcc (alex_action_24))],[(AlexAccPred (alex_action_7) ( atEOL ))],[(AlexAccPred (alex_action_7) ( atEOL )),(AlexAcc (alex_action_75))],[(AlexAcc (alex_action_4))],[(AlexAcc (alex_action_4))],[(AlexAcc (alex_action_4))],[(AlexAcc (alex_action_4))],[(AlexAccPred (alex_action_5) ( ifExtension (not . haddockEnabled) ))],[(AlexAccPred (alex_action_5) ( ifExtension (not . haddockEnabled) )),(AlexAcc (alex_action_24))],[(AlexAccPred (alex_action_5) ( ifExtension (not . haddockEnabled) )),(AlexAcc (alex_action_33))],[(AlexAccPred (alex_action_5) ( ifExtension (not . haddockEnabled) )),(AlexAcc (alex_action_35))],[(AlexAccPred (alex_action_5) ( ifExtension (not . haddockEnabled) )),(AlexAccPred (alex_action_37) ( ifExtension haddockEnabled ))],[(AlexAccPred (alex_action_5) ( ifExtension (not . haddockEnabled) ))],[(AlexAccPred (alex_action_5) ( ifExtension (not . haddockEnabled) )),(AlexAcc (alex_action_24))],[(AlexAccPred (alex_action_5) ( ifExtension (not . haddockEnabled) )),(AlexAcc (alex_action_35))],[(AlexAcc (alex_action_6))],[(AlexAcc (alex_action_6))],[(AlexAcc (alex_action_6))],[(AlexAcc (alex_action_6))],[(AlexAccPred (alex_action_7) ( atEOL ))],[(AlexAccPred (alex_action_7) ( atEOL )),(AlexAcc (alex_action_24))],[(AlexAccPred (alex_action_7) ( atEOL )),(AlexAcc (alex_action_75))],[(AlexAccPred (alex_action_7) ( atEOL ))],[(AlexAccPred (alex_action_7) ( atEOL )),(AlexAcc (alex_action_24))],[(AlexAccPred (alex_action_7) ( atEOL )),(AlexAcc (alex_action_75))],[(AlexAccSkip)],[(AlexAccPred (alex_action_10) (alexPrevCharIs '\n'))],[(AlexAccPred (alex_action_10) (alexPrevCharIs '\n'))],[],[],[],[(AlexAccSkipPred (alexPrevCharIs '\n'))],[],[],[],[],[],[],[],[(AlexAccSkipPred (alexPrevCharIs '\n'))],[],[],[(AlexAccSkip)],[(AlexAccPred (alex_action_16) (alexPrevCharIs '\n'))],[(AlexAccPred (alex_action_16) (alexPrevCharIs '\n'))],[],[],[],[(AlexAcc (alex_action_20))],[(AlexAccPred (alex_action_21) ( known_pragma linePrags ))],[(AlexAccPred (alex_action_21) ( known_pragma linePrags )),(AlexAcc (alex_action_24))],[(AlexAccPred (alex_action_21) ( known_pragma linePrags )),(AlexAccPred (alex_action_29) ( known_pragma oneWordPrags )),(AlexAccPred (alex_action_30) ( known_pragma ignoredPrags )),(AlexAccPred (alex_action_32) ( known_pragma fileHeaderPrags ))],[(AlexAccPred (alex_action_21) ( known_pragma linePrags )),(AlexAccPred (alex_action_29) ( known_pragma oneWordPrags )),(AlexAccPred (alex_action_30) ( known_pragma ignoredPrags )),(AlexAccPred (alex_action_34) ( known_pragma fileHeaderPrags ))],[],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_36))],[(AlexAcc (alex_action_36))],[],[(AlexAcc (alex_action_24))],[],[],[(AlexAcc (alex_action_22))],[(AlexAcc (alex_action_23))],[],[],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_26))],[],[],[(AlexAcc (alex_action_27))],[(AlexAcc (alex_action_27))],[],[],[(AlexAccPred (alex_action_28) ( known_pragma twoWordPrags ))],[],[(AlexAcc (alex_action_31))],[],[(AlexAcc (alex_action_75))],[],[(AlexAcc (alex_action_75))],[(AlexAccPred (alex_action_38) ( ifExtension haddockEnabled ))],[],[(AlexAccPred (alex_action_39) ( ifExtension parrEnabled ))],[(AlexAcc (alex_action_58))],[(AlexAccPred (alex_action_40) ( ifExtension parrEnabled ))],[(AlexAcc (alex_action_76))],[(AlexAccPred (alex_action_41) ( ifExtension thEnabled ))],[(AlexAccPred (alex_action_42) ( ifExtension thEnabled )),(AlexAccPred (alex_action_50) ( ifExtension qqEnabled ))],[],[(AlexAccPred (alex_action_43) ( ifExtension thEnabled )),(AlexAccPred (alex_action_50) ( ifExtension qqEnabled ))],[],[(AlexAccPred (alex_action_44) ( ifExtension thEnabled )),(AlexAccPred (alex_action_50) ( ifExtension qqEnabled ))],[],[(AlexAccPred (alex_action_45) ( ifExtension thEnabled )),(AlexAccPred (alex_action_50) ( ifExtension qqEnabled ))],[],[(AlexAccPred (alex_action_46) ( ifExtension thEnabled ))],[(AlexAcc (alex_action_75))],[(AlexAccPred (alex_action_47) ( ifExtension thEnabled ))],[(AlexAccPred (alex_action_47) ( ifExtension thEnabled ))],[(AlexAcc (alex_action_75))],[(AlexAccPred (alex_action_48) ( ifExtension thEnabled ))],[(AlexAccPred (alex_action_49) ( ifExtension qqEnabled ))],[],[],[],[(AlexAccPred (alex_action_50) ( ifExtension qqEnabled ))],[],[],[(AlexAccPred (alex_action_51) ( ifExtension arrowsEnabled `alexAndPred` notFollowedBySymbol ))],[(AlexAcc (alex_action_56))],[(AlexAccPred (alex_action_52) ( ifExtension arrowsEnabled ))],[(AlexAccPred (alex_action_53) ( ifExtension ipEnabled ))],[(AlexAccPred (alex_action_53) ( ifExtension ipEnabled ))],[(AlexAcc (alex_action_75))],[(AlexAccPred (alex_action_54) ( ifExtension unboxedTuplesEnabled `alexAndPred` notFollowedBySymbol ))],[(AlexAccPred (alex_action_55) ( ifExtension unboxedTuplesEnabled ))],[(AlexAcc (alex_action_56))],[(AlexAcc (alex_action_57))],[(AlexAcc (alex_action_58))],[(AlexAcc (alex_action_59))],[(AlexAcc (alex_action_60))],[(AlexAcc (alex_action_61))],[(AlexAcc (alex_action_62))],[(AlexAcc (alex_action_64))],[(AlexAcc (alex_action_65))],[(AlexAcc (alex_action_65))],[(AlexAcc (alex_action_65))],[(AlexAcc (alex_action_65))],[],[],[(AlexAcc (alex_action_66))],[(AlexAcc (alex_action_66))],[(AlexAcc (alex_action_68))],[(AlexAcc (alex_action_68))],[(AlexAcc (alex_action_66))],[(AlexAcc (alex_action_66))],[(AlexAcc (alex_action_68))],[(AlexAcc (alex_action_68))],[(AlexAcc (alex_action_67))],[(AlexAcc (alex_action_67))],[(AlexAcc (alex_action_67))],[(AlexAcc (alex_action_67))],[(AlexAccPred (alex_action_69) ( ifExtension magicHashEnabled ))],[(AlexAccPred (alex_action_70) ( ifExtension magicHashEnabled ))],[(AlexAccPred (alex_action_71) ( ifExtension magicHashEnabled ))],[(AlexAccPred (alex_action_72) ( ifExtension magicHashEnabled ))],[(AlexAcc (alex_action_73))],[(AlexAcc (alex_action_73))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_74))],[(AlexAcc (alex_action_75))],[(AlexAcc (alex_action_75))],[(AlexAcc (alex_action_76))],[(AlexAcc (alex_action_77))],[(AlexAcc (alex_action_77))],[(AlexAcc (alex_action_78))],[],[(AlexAcc (alex_action_79))],[],[(AlexAcc (alex_action_80))],[(AlexAcc (alex_action_80))],[(AlexAcc (alex_action_80))],[],[],[],[],[],[(AlexAccPred (alex_action_81) ( ifExtension magicHashEnabled ))],[(AlexAccPred (alex_action_82) ( ifExtension magicHashEnabled ))],[(AlexAccPred (alex_action_83) ( ifExtension magicHashEnabled ))],[(AlexAccPred (alex_action_84) ( ifExtension magicHashEnabled ))],[],[],[(AlexAccPred (alex_action_85) ( ifExtension magicHashEnabled ))],[],[],[(AlexAccPred (alex_action_86) ( ifExtension magicHashEnabled ))],[],[],[(AlexAccPred (alex_action_87) ( ifExtension magicHashEnabled ))],[(AlexAccPred (alex_action_88) ( ifExtension magicHashEnabled ))],[(AlexAccPred (alex_action_89) ( ifExtension magicHashEnabled ))],[(AlexAccPred (alex_action_90) ( ifExtension magicHashEnabled ))],[],[],[],[],[],[],[],[],[(AlexAccPred (alex_action_91) ( ifExtension magicHashEnabled ))],[(AlexAcc (alex_action_92))],[(AlexAcc (alex_action_93))]] +{-# LINE 417 "compiler/parser/Lexer.x" #-} -- ----------------------------------------------------------------------------- -- The token type data Token - = ITas -- Haskell keywords + = ITas -- Haskell keywords | ITcase | ITclass | ITdata @@ -109,15 +111,15 @@ | ITthen | ITtype | ITwhere - | ITscc -- ToDo: remove (we use {-# SCC "..." #-} now) + | ITscc -- ToDo: remove (we use {-# SCC "..." #-} now) - | ITforall -- GHC extension keywords + | ITforall -- GHC extension keywords | ITforeign | ITexport | ITlabel | ITdynamic | ITsafe - | ITthreadsafe + | ITinterruptible | ITunsafe | ITstdcallconv | ITccallconv @@ -128,10 +130,10 @@ | ITby | ITusing - -- Pragmas + -- Pragmas | ITinline_prag InlineSpec RuleMatchInfo - | ITspec_prag -- SPECIALISE - | ITspec_inline_prag Bool -- SPECIALISE INLINE (or NOINLINE) + | ITspec_prag -- SPECIALISE + | ITspec_inline_prag Bool -- SPECIALISE INLINE (or NOINLINE) | ITsource_prag | ITrules_prag | ITwarning_prag @@ -146,8 +148,11 @@ | IToptions_prag String | ITinclude_prag String | ITlanguage_prag + | ITvect_prag + | ITvect_scalar_prag + | ITnovect_prag - | ITdotdot -- reserved symbols + | ITdotdot -- reserved symbols | ITcolon | ITdcolon | ITequal @@ -163,17 +168,17 @@ | ITstar | ITdot - | ITbiglam -- GHC-extension symbols + | ITbiglam -- GHC-extension symbols - | ITocurly -- special symbols + | ITocurly -- special symbols | ITccurly | ITocurlybar -- {|, for type applications | ITccurlybar -- |}, for type applications | ITvocurly | ITvccurly | ITobrack - | ITopabrack -- [:, for parallel arrays with -XParr - | ITcpabrack -- :], for parallel arrays with -XParr + | ITopabrack -- [:, for parallel arrays with -XParallelArrays + | ITcpabrack -- :], for parallel arrays with -XParallelArrays | ITcbrack | IToparen | ITcparen @@ -184,7 +189,7 @@ | ITunderscore | ITbackquote - | ITvarid FastString -- identifiers + | ITvarid FastString -- identifiers | ITconid FastString | ITvarsym FastString | ITconsym FastString @@ -195,44 +200,44 @@ | ITprefixqvarsym (FastString,FastString) | ITprefixqconsym (FastString,FastString) - | ITdupipvarid FastString -- GHC extension: implicit param: ?x + | ITdupipvarid FastString -- GHC extension: implicit param: ?x | ITchar Char | ITstring FastString | ITinteger Integer - | ITrational Rational + | ITrational FractionalLit | ITprimchar Char | ITprimstring FastString | ITprimint Integer | ITprimword Integer - | ITprimfloat Rational - | ITprimdouble Rational + | ITprimfloat FractionalLit + | ITprimdouble FractionalLit -- Template Haskell extension tokens - | ITopenExpQuote -- [| or [e| - | ITopenPatQuote -- [p| - | ITopenDecQuote -- [d| - | ITopenTypQuote -- [t| - | ITcloseQuote -- |] - | ITidEscape FastString -- $x - | ITparenEscape -- $( - | ITvarQuote -- ' - | ITtyQuote -- '' - | ITquasiQuote (FastString,FastString,SrcSpan) -- [:...|...|] + | ITopenExpQuote -- [| or [e| + | ITopenPatQuote -- [p| + | ITopenDecQuote -- [d| + | ITopenTypQuote -- [t| + | ITcloseQuote -- |] + | ITidEscape FastString -- $x + | ITparenEscape -- $( + | ITvarQuote -- ' + | ITtyQuote -- '' + | ITquasiQuote (FastString,FastString,RealSrcSpan) -- [:...|...|] -- Arrow notation extension | ITproc | ITrec - | IToparenbar -- (| - | ITcparenbar -- |) - | ITlarrowtail -- -< - | ITrarrowtail -- >- - | ITLarrowtail -- -<< - | ITRarrowtail -- >>- + | IToparenbar -- (| + | ITcparenbar -- |) + | ITlarrowtail -- -< + | ITrarrowtail -- >- + | ITLarrowtail -- -<< + | ITRarrowtail -- >>- - | ITunknown String -- Used when the lexer can't make sense of it - | ITeof -- end of file token + | ITunknown String -- Used when the lexer can't make sense of it + | ITeof -- end of file token -- Documentation annotations | ITdocCommentNext String -- something beginning '-- |' @@ -248,32 +253,6 @@ deriving Show -- debugging #endif -{- -isSpecial :: Token -> Bool --- If we see M.x, where x is a keyword, but --- is special, we treat is as just plain M.x, --- not as a keyword. -isSpecial ITas = True -isSpecial IThiding = True -isSpecial ITqualified = True -isSpecial ITforall = True -isSpecial ITexport = True -isSpecial ITlabel = True -isSpecial ITdynamic = True -isSpecial ITsafe = True -isSpecial ITthreadsafe = True -isSpecial ITunsafe = True -isSpecial ITccallconv = True -isSpecial ITstdcallconv = True -isSpecial ITprimcallconv = True -isSpecial ITmdo = True -isSpecial ITfamily = True -isSpecial ITgroup = True -isSpecial ITby = True -isSpecial ITusing = True -isSpecial _ = False --} - -- the bitmap provided as the third component indicates whether the -- corresponding extension keyword is valid under the extension options -- provided to the compiler; if the extension corresponding to *any* of the @@ -283,54 +262,56 @@ -- reservedWordsFM :: UniqFM (Token, Int) reservedWordsFM = listToUFM $ - map (\(x, y, z) -> (mkFastString x, (y, z))) - [( "_", ITunderscore, 0 ), - ( "as", ITas, 0 ), - ( "case", ITcase, 0 ), - ( "class", ITclass, 0 ), - ( "data", ITdata, 0 ), - ( "default", ITdefault, 0 ), - ( "deriving", ITderiving, 0 ), - ( "do", ITdo, 0 ), - ( "else", ITelse, 0 ), - ( "hiding", IThiding, 0 ), - ( "if", ITif, 0 ), - ( "import", ITimport, 0 ), - ( "in", ITin, 0 ), - ( "infix", ITinfix, 0 ), - ( "infixl", ITinfixl, 0 ), - ( "infixr", ITinfixr, 0 ), - ( "instance", ITinstance, 0 ), - ( "let", ITlet, 0 ), - ( "module", ITmodule, 0 ), - ( "newtype", ITnewtype, 0 ), - ( "of", ITof, 0 ), - ( "qualified", ITqualified, 0 ), - ( "then", ITthen, 0 ), - ( "type", ITtype, 0 ), - ( "where", ITwhere, 0 ), - ( "_scc_", ITscc, 0 ), -- ToDo: remove - - ( "forall", ITforall, bit explicitForallBit .|. bit inRulePragBit), - ( "mdo", ITmdo, bit recursiveDoBit), - ( "family", ITfamily, bit tyFamBit), - ( "group", ITgroup, bit transformComprehensionsBit), - ( "by", ITby, bit transformComprehensionsBit), - ( "using", ITusing, bit transformComprehensionsBit), - - ( "foreign", ITforeign, bit ffiBit), - ( "export", ITexport, bit ffiBit), - ( "label", ITlabel, bit ffiBit), - ( "dynamic", ITdynamic, bit ffiBit), - ( "safe", ITsafe, bit ffiBit), - ( "threadsafe", ITthreadsafe, bit ffiBit), -- ToDo: remove - ( "unsafe", ITunsafe, bit ffiBit), - ( "stdcall", ITstdcallconv, bit ffiBit), - ( "ccall", ITccallconv, bit ffiBit), - ( "prim", ITprimcallconv, bit ffiBit), + map (\(x, y, z) -> (mkFastString x, (y, z))) + [( "_", ITunderscore, 0 ), + ( "as", ITas, 0 ), + ( "case", ITcase, 0 ), + ( "class", ITclass, 0 ), + ( "data", ITdata, 0 ), + ( "default", ITdefault, 0 ), + ( "deriving", ITderiving, 0 ), + ( "do", ITdo, 0 ), + ( "else", ITelse, 0 ), + ( "hiding", IThiding, 0 ), + ( "if", ITif, 0 ), + ( "import", ITimport, 0 ), + ( "in", ITin, 0 ), + ( "infix", ITinfix, 0 ), + ( "infixl", ITinfixl, 0 ), + ( "infixr", ITinfixr, 0 ), + ( "instance", ITinstance, 0 ), + ( "let", ITlet, 0 ), + ( "module", ITmodule, 0 ), + ( "newtype", ITnewtype, 0 ), + ( "of", ITof, 0 ), + ( "qualified", ITqualified, 0 ), + ( "then", ITthen, 0 ), + ( "type", ITtype, 0 ), + ( "where", ITwhere, 0 ), + ( "_scc_", ITscc, 0 ), -- ToDo: remove + + ( "forall", ITforall, bit explicitForallBit .|. + bit inRulePragBit), + ( "mdo", ITmdo, bit recursiveDoBit), + ( "family", ITfamily, bit tyFamBit), + ( "group", ITgroup, bit transformComprehensionsBit), + ( "by", ITby, bit transformComprehensionsBit), + ( "using", ITusing, bit transformComprehensionsBit), + + ( "foreign", ITforeign, bit ffiBit), + ( "export", ITexport, bit ffiBit), + ( "label", ITlabel, bit ffiBit), + ( "dynamic", ITdynamic, bit ffiBit), + ( "safe", ITsafe, bit ffiBit .|. + bit safeHaskellBit), + ( "interruptible", ITinterruptible, bit interruptibleFfiBit), + ( "unsafe", ITunsafe, bit ffiBit), + ( "stdcall", ITstdcallconv, bit ffiBit), + ( "ccall", ITccallconv, bit ffiBit), + ( "prim", ITprimcallconv, bit ffiBit), - ( "rec", ITrec, bit recBit), - ( "proc", ITproc, bit arrowsBit) + ( "rec", ITrec, bit recBit), + ( "proc", ITproc, bit arrowsBit) ] reservedSymsFM :: UniqFM (Token, Int -> Bool) @@ -383,7 +364,7 @@ -- ----------------------------------------------------------------------------- -- Lexer actions -type Action = SrcSpan -> StringBuffer -> Int -> P (Located Token) +type Action = RealSrcSpan -> StringBuffer -> Int -> P (RealLocated Token) special :: Token -> Action special tok span _buf _len = return (L span tok) @@ -396,16 +377,16 @@ idtoken f span buf len = return (L span $! (f buf len)) skip_one_varid :: (FastString -> Token) -> Action -skip_one_varid f span buf len +skip_one_varid f span buf len = return (L span $! f (lexemeToFastString (stepOn buf) (len-1))) strtoken :: (String -> Token) -> Action -strtoken f span buf len = +strtoken f span buf len = return (L span $! (f $! lexemeToString buf len)) init_strtoken :: Int -> (String -> Token) -> Action -- like strtoken, but drops the last N character(s) -init_strtoken drop f span buf len = +init_strtoken drop f span buf len = return (L span $! (f $! lexemeToString buf (len-drop))) begin :: Int -> Action @@ -415,6 +396,19 @@ pop _span _buf _len = do _ <- popLexState lexToken +hopefully_open_brace :: Action +hopefully_open_brace span buf len + = do relaxed <- extension relaxedLayout + ctx <- getContext + (AI l _) <- getInput + let offset = srcLocCol l + isOK = relaxed || + case ctx of + Layout prev_off : _ -> prev_off < offset + _ -> True + if isOK then pop_and open_brace span buf len + else failSpanMsgP (RealSrcSpan span) (text "Missing block") + pop_and :: Action -> Action pop_and act span buf len = do _ <- popLexState act span buf len @@ -424,7 +418,7 @@ nextCharIs buf p = not (atEnd buf) && p (currentChar buf) notFollowedBy :: Char -> AlexAccPred Int -notFollowedBy char _ _ _ (AI _ buf) +notFollowedBy char _ _ _ (AI _ buf) = nextCharIs buf (/=char) notFollowedBySymbol :: AlexAccPred Int @@ -447,11 +441,6 @@ spaceAndP :: StringBuffer -> (StringBuffer -> Bool) -> Bool spaceAndP buf p = p buf || nextCharIs buf (==' ') && p (snd (nextChar buf)) -{- -haddockDisabledAnd p bits _ _ (AI _ buf) - = if haddockEnabled bits then False else (p buf) --} - atEOL :: AlexAccPred Int atEOL _ _ _ (AI _ buf) = atEnd buf || currentChar buf == '\n' @@ -462,14 +451,14 @@ multiline_doc_comment span buf _len = withLexedDocType (worker "") where worker commentAcc input docType oneLine = case alexGetChar input of - Just ('\n', input') + Just ('\n', input') | oneLine -> docCommentEnd input commentAcc docType buf span | otherwise -> case checkIfCommentLine input' of Just input -> worker ('\n':commentAcc) input docType False Nothing -> docCommentEnd input commentAcc docType buf span Just (c, input) -> worker (c:commentAcc) input docType oneLine Nothing -> docCommentEnd input commentAcc docType buf span - + checkIfCommentLine input = check (dropNonNewlineSpace input) where check input = case alexGetChar input of @@ -481,7 +470,7 @@ _ -> Nothing dropNonNewlineSpace input = case alexGetChar input of - Just (c, input') + Just (c, input') | isSpace c && c /= '\n' -> dropNonNewlineSpace input' | otherwise -> input Nothing -> input @@ -495,7 +484,7 @@ nested comments require traversing by hand, they can't be parsed using regular expressions. -} -nested_comment :: P (Located Token) -> Action +nested_comment :: P (RealLocated Token) -> Action nested_comment cont span _str _len = do input <- getInput go "" (1::Int) input @@ -536,8 +525,8 @@ Just (_,_) -> go ('\123':commentAcc) input docType False Just (c,input) -> go (c:commentAcc) input docType False -withLexedDocType :: (AlexInput -> (String -> Token) -> Bool -> P (Located Token)) - -> P (Located Token) +withLexedDocType :: (AlexInput -> (String -> Token) -> Bool -> P (RealLocated Token)) + -> P (RealLocated Token) withLexedDocType lexDocComment = do input@(AI _ buf) <- getInput case prevChar buf ' ' of @@ -547,8 +536,8 @@ '*' -> lexDocSection 1 input '#' -> lexDocComment input ITdocOptionsOld False _ -> panic "withLexedDocType: Bad doc type" - where - lexDocSection n input = case alexGetChar input of + where + lexDocSection n input = case alexGetChar input of Just ('*', input) -> lexDocSection (n+1) input Just (_, _) -> lexDocComment input (ITdocSection n) True Nothing -> do setInput input; lexToken -- eof reached, lex it normally @@ -569,31 +558,31 @@ ------------------------------------------------------------------------------- -- This function is quite tricky. We can't just return a new token, we also -- need to update the state of the parser. Why? Because the token is longer --- than what was lexed by Alex, and the lexToken function doesn't know this, so +-- than what was lexed by Alex, and the lexToken function doesn't know this, so -- it writes the wrong token length to the parser state. This function is --- called afterwards, so it can just update the state. +-- called afterwards, so it can just update the state. docCommentEnd :: AlexInput -> String -> (String -> Token) -> StringBuffer -> - SrcSpan -> P (Located Token) + RealSrcSpan -> P (RealLocated Token) docCommentEnd input commentAcc docType buf span = do setInput input let (AI loc nextBuf) = input comment = reverse commentAcc - span' = mkSrcSpan (srcSpanStart span) loc + span' = mkRealSrcSpan (realSrcSpanStart span) loc last_len = byteDiff buf nextBuf - + span `seq` setLastToken span' last_len return (L span' (docType comment)) - -errBrace :: AlexInput -> SrcSpan -> P a -errBrace (AI end _) span = failLocMsgP (srcSpanStart span) end "unterminated `{-'" + +errBrace :: AlexInput -> RealSrcSpan -> P a +errBrace (AI end _) span = failLocMsgP (realSrcSpanStart span) end "unterminated `{-'" open_brace, close_brace :: Action -open_brace span _str _len = do +open_brace span _str _len = do ctx <- getContext setContext (NoLayout:ctx) return (L span ITocurly) -close_brace span _str _len = do +close_brace span _str _len = do popContext return (L span ITccurly) @@ -608,44 +597,44 @@ splitQualName orig_buf len parens = split orig_buf orig_buf where split buf dot_buf - | orig_buf `byteDiff` buf >= len = done dot_buf - | c == '.' = found_dot buf' - | otherwise = split buf' dot_buf + | orig_buf `byteDiff` buf >= len = done dot_buf + | c == '.' = found_dot buf' + | otherwise = split buf' dot_buf where (c,buf') = nextChar buf - + -- careful, we might get names like M.... -- so, if the character after the dot is not upper-case, this is -- the end of the qualifier part. found_dot buf -- buf points after the '.' - | isUpper c = split buf' buf - | otherwise = done buf + | isUpper c = split buf' buf + | otherwise = done buf where (c,buf') = nextChar buf done dot_buf = - (lexemeToFastString orig_buf (qual_size - 1), - if parens -- Prelude.(+) + (lexemeToFastString orig_buf (qual_size - 1), + if parens -- Prelude.(+) then lexemeToFastString (stepOn dot_buf) (len - qual_size - 2) else lexemeToFastString dot_buf (len - qual_size)) where - qual_size = orig_buf `byteDiff` dot_buf + qual_size = orig_buf `byteDiff` dot_buf varid :: Action varid span buf len = fs `seq` case lookupUFM reservedWordsFM fs of - Just (keyword,0) -> do - maybe_layout keyword - return (L span keyword) - Just (keyword,exts) -> do - b <- extension (\i -> exts .&. i /= 0) - if b then do maybe_layout keyword - return (L span keyword) - else return (L span (ITvarid fs)) - _other -> return (L span (ITvarid fs)) + Just (keyword,0) -> do + maybe_layout keyword + return (L span keyword) + Just (keyword,exts) -> do + b <- extension (\i -> exts .&. i /= 0) + if b then do maybe_layout keyword + return (L span keyword) + else return (L span (ITvarid fs)) + _other -> return (L span (ITvarid fs)) where - fs = lexemeToFastString buf len + fs = lexemeToFastString buf len conid :: StringBuffer -> Int -> Token conid buf len = ITconid fs @@ -661,27 +650,27 @@ varsym = sym ITvarsym consym = sym ITconsym -sym :: (FastString -> Token) -> SrcSpan -> StringBuffer -> Int - -> P (Located Token) -sym con span buf len = +sym :: (FastString -> Token) -> RealSrcSpan -> StringBuffer -> Int + -> P (RealLocated Token) +sym con span buf len = case lookupUFM reservedSymsFM fs of - Just (keyword,exts) -> do - b <- extension exts - if b then return (L span keyword) - else return (L span $! con fs) - _other -> return (L span $! con fs) + Just (keyword,exts) -> do + b <- extension exts + if b then return (L span keyword) + else return (L span $! con fs) + _other -> return (L span $! con fs) where - fs = lexemeToFastString buf len + fs = lexemeToFastString buf len -- Variations on the integral numeric literal. tok_integral :: (Integer -> Token) - -> (Integer -> Integer) - -- -> (StringBuffer -> StringBuffer) -> (Int -> Int) - -> Int -> Int - -> (Integer, (Char->Int)) -> Action -tok_integral itint transint transbuf translen (radix,char_to_int) span buf len = - return $ L span $ itint $! transint $ parseUnsignedInteger - (offsetBytes transbuf buf) (subtract translen len) radix char_to_int + -> (Integer -> Integer) + -> Int -> Int + -> (Integer, (Char -> Int)) + -> Action +tok_integral itint transint transbuf translen (radix,char_to_int) span buf len + = return $ L span $ itint $! transint $ parseUnsignedInteger + (offsetBytes transbuf buf) (subtract translen len) radix char_to_int -- some conveniences for use with tok_integral tok_num :: (Integer -> Integer) @@ -705,9 +694,12 @@ -- readRational can understand negative rationals, exponents, everything. tok_float, tok_primfloat, tok_primdouble :: String -> Token -tok_float str = ITrational $! readRational str -tok_primfloat str = ITprimfloat $! readRational str -tok_primdouble str = ITprimdouble $! readRational str +tok_float str = ITrational $! readFractionalLit str +tok_primfloat str = ITprimfloat $! readFractionalLit str +tok_primdouble str = ITprimdouble $! readFractionalLit str + +readFractionalLit :: String -> FractionalLit +readFractionalLit str = (FL $! str) $! readRational str -- ----------------------------------------------------------------------------- -- Layout processing @@ -715,20 +707,20 @@ -- we're at the first token on a line, insert layout tokens if necessary do_bol :: Action do_bol span _str _len = do - pos <- getOffside - case pos of - LT -> do + pos <- getOffside + case pos of + LT -> do --trace "layout: inserting '}'" $ do - popContext - -- do NOT pop the lex state, we might have a ';' to insert - return (L span ITvccurly) - EQ -> do + popContext + -- do NOT pop the lex state, we might have a ';' to insert + return (L span ITvccurly) + EQ -> do --trace "layout: inserting ';'" $ do - _ <- popLexState - return (L span ITsemi) - GT -> do - _ <- popLexState - lexToken + _ <- popLexState + return (L span ITsemi) + GT -> do + _ <- popLexState + lexToken -- certain keywords put us in the "layout" state, where we might -- add an opening curly brace. @@ -765,17 +757,19 @@ (AI l _) <- getInput let offset = srcLocCol l ctx <- getContext + nondecreasing <- extension nondecreasingIndentation + let strict' = strict || not nondecreasing case ctx of - Layout prev_off : _ | - (strict && prev_off >= offset || - not strict && prev_off > offset) -> do - -- token is indented to the left of the previous context. - -- we must generate a {} sequence now. - pushLexState layout_left - return (L span ITvocurly) - _ -> do - setContext (Layout offset : ctx) - return (L span ITvocurly) + Layout prev_off : _ | + (strict' && prev_off >= offset || + not strict' && prev_off > offset) -> do + -- token is indented to the left of the previous context. + -- we must generate a {} sequence now. + pushLexState layout_left + return (L span ITvocurly) + _ -> do + setContext (Layout offset : ctx) + return (L span ITvocurly) do_layout_left :: Action do_layout_left span _buf _len = do @@ -789,8 +783,8 @@ setLine :: Int -> Action setLine code span buf len = do let line = parseUnsignedInteger buf len 10 octDecDigit - setSrcLoc (mkSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1) - -- subtract one: the line number refers to the *following* line + setSrcLoc (mkRealSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1) + -- subtract one: the line number refers to the *following* line _ <- popLexState pushLexState code lexToken @@ -798,12 +792,17 @@ setFile :: Int -> Action setFile code span buf len = do let file = lexemeToFastString (stepOn buf) (len-2) - setAlrLastLoc noSrcSpan - setSrcLoc (mkSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span)) + setAlrLastLoc $ alrInitialLoc file + setSrcLoc (mkRealSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span)) _ <- popLexState pushLexState code lexToken +alrInitialLoc :: FastString -> RealSrcSpan +alrInitialLoc file = mkRealSrcSpan loc loc + where -- This is a hack to ensure that the first line in a file + -- looks like it is after the initial location: + loc = mkRealSrcLoc file (-1) (-1) -- ----------------------------------------------------------------------------- -- Options, includes and language pragmas. @@ -814,7 +813,7 @@ start <- getSrcLoc tok <- go [] input end <- getSrcLoc - return (L (mkSrcSpan start end) tok) + return (L (mkRealSrcSpan start end) tok) where go acc input = if isString input "#-}" then do setInput input @@ -827,7 +826,7 @@ = case alexGetChar i of Just (c,i') | c == x -> isString i' xs _other -> False - err (AI end _) = failLocMsgP (srcSpanStart span) end "unterminated options pragma" + err (AI end _) = failLocMsgP (realSrcSpanStart span) end "unterminated options pragma" -- ----------------------------------------------------------------------------- @@ -838,8 +837,8 @@ lex_string_tok :: Action lex_string_tok span _buf _len = do tok <- lex_string "" - end <- getSrcLoc - return (L (mkSrcSpan (srcSpanStart span) end) tok) + end <- getSrcLoc + return (L (mkRealSrcSpan (realSrcSpanStart span) end) tok) lex_string :: String -> P Token lex_string s = do @@ -848,32 +847,32 @@ Nothing -> lit_error i Just ('"',i) -> do - setInput i - magicHash <- extension magicHashEnabled - if magicHash - then do - i <- getInput - case alexGetChar' i of - Just ('#',i) -> do - setInput i - if any (> '\xFF') s + setInput i + magicHash <- extension magicHashEnabled + if magicHash + then do + i <- getInput + case alexGetChar' i of + Just ('#',i) -> do + setInput i + if any (> '\xFF') s then failMsgP "primitive string literal must contain only characters <= \'\\xFF\'" else let s' = mkZFastString (reverse s) in - return (ITprimstring s') - -- mkZFastString is a hack to avoid encoding the - -- string in UTF-8. We just want the exact bytes. - _other -> - return (ITstring (mkFastString (reverse s))) - else - return (ITstring (mkFastString (reverse s))) + return (ITprimstring s') + -- mkZFastString is a hack to avoid encoding the + -- string in UTF-8. We just want the exact bytes. + _other -> + return (ITstring (mkFastString (reverse s))) + else + return (ITstring (mkFastString (reverse s))) Just ('\\',i) - | Just ('&',i) <- next -> do - setInput i; lex_string s - | Just (c,i) <- next, c <= '\x7f' && is_space c -> do + | Just ('&',i) <- next -> do + setInput i; lex_string s + | Just (c,i) <- next, c <= '\x7f' && is_space c -> do -- is_space only works for <= '\x7f' (#3751) - setInput i; lex_stringgap s - where next = alexGetChar' i + setInput i; lex_stringgap s + where next = alexGetChar' i Just (c, i1) -> do case c of @@ -894,172 +893,172 @@ lex_char_tok :: Action -- Here we are basically parsing character literals, such as 'x' or '\n' -- but, when Template Haskell is on, we additionally spot --- 'x and ''T, returning ITvarQuote and ITtyQuote respectively, +-- 'x and ''T, returning ITvarQuote and ITtyQuote respectively, -- but WITHOUT CONSUMING the x or T part (the parser does that). -- So we have to do two characters of lookahead: when we see 'x we need to -- see if there's a trailing quote -lex_char_tok span _buf _len = do -- We've seen ' - i1 <- getInput -- Look ahead to first character - let loc = srcSpanStart span +lex_char_tok span _buf _len = do -- We've seen ' + i1 <- getInput -- Look ahead to first character + let loc = realSrcSpanStart span case alexGetChar' i1 of - Nothing -> lit_error i1 + Nothing -> lit_error i1 - Just ('\'', i2@(AI end2 _)) -> do -- We've seen '' - th_exts <- extension thEnabled - if th_exts then do - setInput i2 - return (L (mkSrcSpan loc end2) ITtyQuote) - else lit_error i1 - - Just ('\\', i2@(AI _end2 _)) -> do -- We've seen 'backslash - setInput i2 - lit_ch <- lex_escape + Just ('\'', i2@(AI end2 _)) -> do -- We've seen '' + th_exts <- extension thEnabled + if th_exts then do + setInput i2 + return (L (mkRealSrcSpan loc end2) ITtyQuote) + else lit_error i1 + + Just ('\\', i2@(AI _end2 _)) -> do -- We've seen 'backslash + setInput i2 + lit_ch <- lex_escape i3 <- getInput - mc <- getCharOrFail i3 -- Trailing quote - if mc == '\'' then finish_char_tok loc lit_ch - else lit_error i3 + mc <- getCharOrFail i3 -- Trailing quote + if mc == '\'' then finish_char_tok loc lit_ch + else lit_error i3 Just (c, i2@(AI _end2 _)) - | not (isAny c) -> lit_error i1 - | otherwise -> + | not (isAny c) -> lit_error i1 + | otherwise -> - -- We've seen 'x, where x is a valid character - -- (i.e. not newline etc) but not a quote or backslash - case alexGetChar' i2 of -- Look ahead one more character - Just ('\'', i3) -> do -- We've seen 'x' - setInput i3 - finish_char_tok loc c - _other -> do -- We've seen 'x not followed by quote - -- (including the possibility of EOF) - -- If TH is on, just parse the quote only - th_exts <- extension thEnabled - let (AI end _) = i1 - if th_exts then return (L (mkSrcSpan loc end) ITvarQuote) - else lit_error i2 - -finish_char_tok :: SrcLoc -> Char -> P (Located Token) -finish_char_tok loc ch -- We've already seen the closing quote - -- Just need to check for trailing # - = do magicHash <- extension magicHashEnabled - i@(AI end _) <- getInput - if magicHash then do - case alexGetChar' i of - Just ('#',i@(AI end _)) -> do - setInput i - return (L (mkSrcSpan loc end) (ITprimchar ch)) - _other -> - return (L (mkSrcSpan loc end) (ITchar ch)) - else do - return (L (mkSrcSpan loc end) (ITchar ch)) + -- We've seen 'x, where x is a valid character + -- (i.e. not newline etc) but not a quote or backslash + case alexGetChar' i2 of -- Look ahead one more character + Just ('\'', i3) -> do -- We've seen 'x' + setInput i3 + finish_char_tok loc c + _other -> do -- We've seen 'x not followed by quote + -- (including the possibility of EOF) + -- If TH is on, just parse the quote only + th_exts <- extension thEnabled + let (AI end _) = i1 + if th_exts then return (L (mkRealSrcSpan loc end) ITvarQuote) + else lit_error i2 + +finish_char_tok :: RealSrcLoc -> Char -> P (RealLocated Token) +finish_char_tok loc ch -- We've already seen the closing quote + -- Just need to check for trailing # + = do magicHash <- extension magicHashEnabled + i@(AI end _) <- getInput + if magicHash then do + case alexGetChar' i of + Just ('#',i@(AI end _)) -> do + setInput i + return (L (mkRealSrcSpan loc end) (ITprimchar ch)) + _other -> + return (L (mkRealSrcSpan loc end) (ITchar ch)) + else do + return (L (mkRealSrcSpan loc end) (ITchar ch)) isAny :: Char -> Bool isAny c | c > '\x7f' = isPrint c - | otherwise = is_any c + | otherwise = is_any c lex_escape :: P Char lex_escape = do i0 <- getInput c <- getCharOrFail i0 case c of - 'a' -> return '\a' - 'b' -> return '\b' - 'f' -> return '\f' - 'n' -> return '\n' - 'r' -> return '\r' - 't' -> return '\t' - 'v' -> return '\v' - '\\' -> return '\\' - '"' -> return '\"' - '\'' -> return '\'' - '^' -> do i1 <- getInput + 'a' -> return '\a' + 'b' -> return '\b' + 'f' -> return '\f' + 'n' -> return '\n' + 'r' -> return '\r' + 't' -> return '\t' + 'v' -> return '\v' + '\\' -> return '\\' + '"' -> return '\"' + '\'' -> return '\'' + '^' -> do i1 <- getInput c <- getCharOrFail i1 - if c >= '@' && c <= '_' - then return (chr (ord c - ord '@')) - else lit_error i1 - - 'x' -> readNum is_hexdigit 16 hexDigit - 'o' -> readNum is_octdigit 8 octDecDigit - x | is_decdigit x -> readNum2 is_decdigit 10 octDecDigit (octDecDigit x) - - c1 -> do - i <- getInput - case alexGetChar' i of - Nothing -> lit_error i0 - Just (c2,i2) -> + if c >= '@' && c <= '_' + then return (chr (ord c - ord '@')) + else lit_error i1 + + 'x' -> readNum is_hexdigit 16 hexDigit + 'o' -> readNum is_octdigit 8 octDecDigit + x | is_decdigit x -> readNum2 is_decdigit 10 octDecDigit (octDecDigit x) + + c1 -> do + i <- getInput + case alexGetChar' i of + Nothing -> lit_error i0 + Just (c2,i2) -> case alexGetChar' i2 of - Nothing -> do lit_error i0 - Just (c3,i3) -> - let str = [c1,c2,c3] in - case [ (c,rest) | (p,c) <- silly_escape_chars, - Just rest <- [stripPrefix p str] ] of - (escape_char,[]):_ -> do - setInput i3 - return escape_char - (escape_char,_:_):_ -> do - setInput i2 - return escape_char - [] -> lit_error i0 + Nothing -> do lit_error i0 + Just (c3,i3) -> + let str = [c1,c2,c3] in + case [ (c,rest) | (p,c) <- silly_escape_chars, + Just rest <- [stripPrefix p str] ] of + (escape_char,[]):_ -> do + setInput i3 + return escape_char + (escape_char,_:_):_ -> do + setInput i2 + return escape_char + [] -> lit_error i0 readNum :: (Char -> Bool) -> Int -> (Char -> Int) -> P Char readNum is_digit base conv = do i <- getInput c <- getCharOrFail i - if is_digit c - then readNum2 is_digit base conv (conv c) - else lit_error i + if is_digit c + then readNum2 is_digit base conv (conv c) + else lit_error i readNum2 :: (Char -> Bool) -> Int -> (Char -> Int) -> Int -> P Char readNum2 is_digit base conv i = do input <- getInput read i input where read i input = do - case alexGetChar' input of - Just (c,input') | is_digit c -> do + case alexGetChar' input of + Just (c,input') | is_digit c -> do let i' = i*base + conv c if i' > 0x10ffff then setInput input >> lexError "numeric escape sequence out of range" else read i' input' - _other -> do + _other -> do setInput input; return (chr i) silly_escape_chars :: [(String, Char)] silly_escape_chars = [ - ("NUL", '\NUL'), - ("SOH", '\SOH'), - ("STX", '\STX'), - ("ETX", '\ETX'), - ("EOT", '\EOT'), - ("ENQ", '\ENQ'), - ("ACK", '\ACK'), - ("BEL", '\BEL'), - ("BS", '\BS'), - ("HT", '\HT'), - ("LF", '\LF'), - ("VT", '\VT'), - ("FF", '\FF'), - ("CR", '\CR'), - ("SO", '\SO'), - ("SI", '\SI'), - ("DLE", '\DLE'), - ("DC1", '\DC1'), - ("DC2", '\DC2'), - ("DC3", '\DC3'), - ("DC4", '\DC4'), - ("NAK", '\NAK'), - ("SYN", '\SYN'), - ("ETB", '\ETB'), - ("CAN", '\CAN'), - ("EM", '\EM'), - ("SUB", '\SUB'), - ("ESC", '\ESC'), - ("FS", '\FS'), - ("GS", '\GS'), - ("RS", '\RS'), - ("US", '\US'), - ("SP", '\SP'), - ("DEL", '\DEL') - ] + ("NUL", '\NUL'), + ("SOH", '\SOH'), + ("STX", '\STX'), + ("ETX", '\ETX'), + ("EOT", '\EOT'), + ("ENQ", '\ENQ'), + ("ACK", '\ACK'), + ("BEL", '\BEL'), + ("BS", '\BS'), + ("HT", '\HT'), + ("LF", '\LF'), + ("VT", '\VT'), + ("FF", '\FF'), + ("CR", '\CR'), + ("SO", '\SO'), + ("SI", '\SI'), + ("DLE", '\DLE'), + ("DC1", '\DC1'), + ("DC2", '\DC2'), + ("DC3", '\DC3'), + ("DC4", '\DC4'), + ("NAK", '\NAK'), + ("SYN", '\SYN'), + ("ETB", '\ETB'), + ("CAN", '\CAN'), + ("EM", '\EM'), + ("SUB", '\SUB'), + ("ESC", '\ESC'), + ("FS", '\FS'), + ("GS", '\GS'), + ("RS", '\RS'), + ("US", '\US'), + ("SP", '\SP'), + ("DEL", '\DEL') + ] -- before calling lit_error, ensure that the current input is pointing to -- the position of the error in the buffer. This is so that we can report @@ -1071,8 +1070,8 @@ getCharOrFail :: AlexInput -> P Char getCharOrFail i = do case alexGetChar' i of - Nothing -> lexError "unexpected end-of-file in string/character literal" - Just (c,i) -> do setInput i; return c + Nothing -> lexError "unexpected end-of-file in string/character literal" + Just (c,i) -> do setInput i; return c -- ----------------------------------------------------------------------------- -- QuasiQuote @@ -1080,15 +1079,15 @@ lex_quasiquote_tok :: Action lex_quasiquote_tok span buf len = do let quoter = tail (lexemeToString buf (len - 1)) - -- 'tail' drops the initial '[', - -- while the -1 drops the trailing '|' - quoteStart <- getSrcLoc + -- 'tail' drops the initial '[', + -- while the -1 drops the trailing '|' + quoteStart <- getSrcLoc quote <- lex_quasiquote "" - end <- getSrcLoc - return (L (mkSrcSpan (srcSpanStart span) end) + end <- getSrcLoc + return (L (mkRealSrcSpan (realSrcSpanStart span) end) (ITquasiQuote (mkFastString quoter, mkFastString (reverse quote), - mkSrcSpan quoteStart end))) + mkRealSrcSpan quoteStart end))) lex_quasiquote :: String -> P String lex_quasiquote s = do @@ -1097,31 +1096,31 @@ Nothing -> lit_error i Just ('\\',i) - | Just ('|',i) <- next -> do - setInput i; lex_quasiquote ('|' : s) - | Just (']',i) <- next -> do - setInput i; lex_quasiquote (']' : s) - where next = alexGetChar' i + | Just ('|',i) <- next -> do + setInput i; lex_quasiquote ('|' : s) + | Just (']',i) <- next -> do + setInput i; lex_quasiquote (']' : s) + where next = alexGetChar' i Just ('|',i) - | Just (']',i) <- next -> do - setInput i; return s - where next = alexGetChar' i + | Just (']',i) <- next -> do + setInput i; return s + where next = alexGetChar' i Just (c, i) -> do - setInput i; lex_quasiquote (c : s) + setInput i; lex_quasiquote (c : s) -- ----------------------------------------------------------------------------- -- Warnings -warn :: DynFlag -> SDoc -> Action +warn :: WarningFlag -> SDoc -> Action warn option warning srcspan _buf _len = do - addWarning option srcspan warning + addWarning option (RealSrcSpan srcspan) warning lexToken -warnThen :: DynFlag -> SDoc -> Action -> Action +warnThen :: WarningFlag -> SDoc -> Action -> Action warnThen option warning action srcspan buf len = do - addWarning option srcspan warning + addWarning option (RealSrcSpan srcspan) warning action srcspan buf len -- ----------------------------------------------------------------------------- @@ -1134,32 +1133,33 @@ data ParseResult a = POk PState a - | PFailed - SrcSpan -- The start and end of the text span related to - -- the error. Might be used in environments which can - -- show this span, e.g. by highlighting it. - Message -- The error message + | PFailed + SrcSpan -- The start and end of the text span related to + -- the error. Might be used in environments which can + -- show this span, e.g. by highlighting it. + Message -- The error message -data PState = PState { - buffer :: StringBuffer, +data PState = PState { + buffer :: StringBuffer, dflags :: DynFlags, messages :: Messages, - last_loc :: SrcSpan, -- pos of previous token - last_len :: !Int, -- len of previous token - loc :: SrcLoc, -- current loc (end of prev token + 1) - extsBitmap :: !Int, -- bitmap that determines permitted extensions - context :: [LayoutContext], - lex_state :: [Int], + last_loc :: RealSrcSpan, -- pos of previous token + last_len :: !Int, -- len of previous token + loc :: RealSrcLoc, -- current loc (end of prev token + 1) + extsBitmap :: !Int, -- bitmap that determines permitted + -- extensions + context :: [LayoutContext], + lex_state :: [Int], -- Used in the alternative layout rule: -- These tokens are the next ones to be sent out. They are -- just blindly emitted, without the rule looking at them again: - alr_pending_implicit_tokens :: [Located Token], + alr_pending_implicit_tokens :: [RealLocated Token], -- This is the next token to be considered or, if it is Nothing, -- we need to get the next token from the input stream: - alr_next_token :: Maybe (Located Token), + alr_next_token :: Maybe (RealLocated Token), -- This is what we consider to be the locatino of the last token -- emitted: - alr_last_loc :: SrcSpan, + alr_last_loc :: RealSrcSpan, -- The stack of layout contexts: alr_context :: [ALRContext], -- Are we expecting a '{'? If it's Just, then the ALRLayout tells @@ -1169,11 +1169,11 @@ -- token doesn't need to close anything: alr_justClosedExplicitLetBlock :: Bool } - -- last_loc and last_len are used when generating error messages, - -- and in pushCurrentContext only. Sigh, if only Happy passed the - -- current token to happyError, we could at least get rid of last_len. - -- Getting rid of last_loc would require finding another way to - -- implement pushCurrentContext (which is only called from one place). + -- last_loc and last_len are used when generating error messages, + -- and in pushCurrentContext only. Sigh, if only Happy passed the + -- current token to happyError, we could at least get rid of last_len. + -- Getting rid of last_loc would require finding another way to + -- implement pushCurrentContext (which is only called from one place). data ALRContext = ALRNoLayout Bool{- does it contain commas? -} Bool{- is it a 'let' block? -} @@ -1195,18 +1195,18 @@ thenP :: P a -> (a -> P b) -> P b (P m) `thenP` k = P $ \ s -> - case m s of - POk s1 a -> (unP (k a)) s1 - PFailed span err -> PFailed span err + case m s of + POk s1 a -> (unP (k a)) s1 + PFailed span err -> PFailed span err failP :: String -> P a -failP msg = P $ \s -> PFailed (last_loc s) (text msg) +failP msg = P $ \s -> PFailed (RealSrcSpan (last_loc s)) (text msg) failMsgP :: String -> P a -failMsgP msg = P $ \s -> PFailed (last_loc s) (text msg) +failMsgP msg = P $ \s -> PFailed (RealSrcSpan (last_loc s)) (text msg) -failLocMsgP :: SrcLoc -> SrcLoc -> String -> P a -failLocMsgP loc1 loc2 str = P $ \_ -> PFailed (mkSrcSpan loc1 loc2) (text str) +failLocMsgP :: RealSrcLoc -> RealSrcLoc -> String -> P a +failLocMsgP loc1 loc2 str = P $ \_ -> PFailed (RealSrcSpan (mkRealSrcSpan loc1 loc2)) (text str) failSpanMsgP :: SrcSpan -> SDoc -> P a failSpanMsgP span msg = P $ \_ -> PFailed span msg @@ -1219,8 +1219,8 @@ withThisPackage :: (PackageId -> a) -> P a withThisPackage f - = do pkg <- liftM thisPackage getDynFlags - return $ f pkg + = do pkg <- liftM thisPackage getDynFlags + return $ f pkg extension :: (Int -> Bool) -> P Bool extension p = P $ \s -> POk s (p $! extsBitmap s) @@ -1231,81 +1231,81 @@ setExts :: (Int -> Int) -> P () setExts f = P $ \s -> POk s{ extsBitmap = f (extsBitmap s) } () -setSrcLoc :: SrcLoc -> P () +setSrcLoc :: RealSrcLoc -> P () setSrcLoc new_loc = P $ \s -> POk s{loc=new_loc} () -getSrcLoc :: P SrcLoc +getSrcLoc :: P RealSrcLoc getSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s loc -setLastToken :: SrcSpan -> Int -> P () -setLastToken loc len = P $ \s -> POk s { - last_loc=loc, +setLastToken :: RealSrcSpan -> Int -> P () +setLastToken loc len = P $ \s -> POk s { + last_loc=loc, last_len=len } () -data AlexInput = AI SrcLoc StringBuffer +data AlexInput = AI RealSrcLoc StringBuffer alexInputPrevChar :: AlexInput -> Char alexInputPrevChar (AI _ buf) = prevChar buf '\n' alexGetChar :: AlexInput -> Maybe (Char,AlexInput) -alexGetChar (AI loc s) +alexGetChar (AI loc s) | atEnd s = Nothing - | otherwise = adj_c `seq` loc' `seq` s' `seq` - --trace (show (ord c)) $ - Just (adj_c, (AI loc' s')) + | otherwise = adj_c `seq` loc' `seq` s' `seq` + --trace (show (ord c)) $ + Just (adj_c, (AI loc' s')) where (c,s') = nextChar s loc' = advanceSrcLoc loc c - non_graphic = '\x0' - upper = '\x1' - lower = '\x2' - digit = '\x3' - symbol = '\x4' - space = '\x5' - other_graphic = '\x6' - - adj_c - | c <= '\x06' = non_graphic - | c <= '\x7f' = c + non_graphic = '\x0' + upper = '\x1' + lower = '\x2' + digit = '\x3' + symbol = '\x4' + space = '\x5' + other_graphic = '\x6' + + adj_c + | c <= '\x06' = non_graphic + | c <= '\x7f' = c -- Alex doesn't handle Unicode, so when Unicode -- character is encountered we output these values -- with the actual character value hidden in the state. - | otherwise = - case generalCategory c of - UppercaseLetter -> upper - LowercaseLetter -> lower - TitlecaseLetter -> upper - ModifierLetter -> other_graphic - OtherLetter -> lower -- see #1103 - NonSpacingMark -> other_graphic - SpacingCombiningMark -> other_graphic - EnclosingMark -> other_graphic - DecimalNumber -> digit - LetterNumber -> other_graphic - OtherNumber -> other_graphic - ConnectorPunctuation -> symbol - DashPunctuation -> symbol - OpenPunctuation -> other_graphic - ClosePunctuation -> other_graphic - InitialQuote -> other_graphic - FinalQuote -> other_graphic - OtherPunctuation -> symbol - MathSymbol -> symbol - CurrencySymbol -> symbol - ModifierSymbol -> symbol - OtherSymbol -> symbol - Space -> space - _other -> non_graphic + | otherwise = + case generalCategory c of + UppercaseLetter -> upper + LowercaseLetter -> lower + TitlecaseLetter -> upper + ModifierLetter -> other_graphic + OtherLetter -> lower -- see #1103 + NonSpacingMark -> other_graphic + SpacingCombiningMark -> other_graphic + EnclosingMark -> other_graphic + DecimalNumber -> digit + LetterNumber -> other_graphic + OtherNumber -> digit -- see #4373 + ConnectorPunctuation -> symbol + DashPunctuation -> symbol + OpenPunctuation -> other_graphic + ClosePunctuation -> other_graphic + InitialQuote -> other_graphic + FinalQuote -> other_graphic + OtherPunctuation -> symbol + MathSymbol -> symbol + CurrencySymbol -> symbol + ModifierSymbol -> symbol + OtherSymbol -> symbol + Space -> space + _other -> non_graphic -- This version does not squash unicode characters, it is used when -- lexing strings. alexGetChar' :: AlexInput -> Maybe (Char,AlexInput) -alexGetChar' (AI loc s) +alexGetChar' (AI loc s) | atEnd s = Nothing - | otherwise = c `seq` loc' `seq` s' `seq` - --trace (show (ord c)) $ - Just (c, (AI loc' s')) + | otherwise = c `seq` loc' `seq` s' `seq` + --trace (show (ord c)) $ + Just (c, (AI loc' s')) where (c,s') = nextChar s loc' = advanceSrcLoc loc c @@ -1315,6 +1315,11 @@ setInput :: AlexInput -> P () setInput (AI l b) = P $ \s -> POk s{ loc=l, buffer=b } () +nextIsEOF :: P Bool +nextIsEOF = do + AI _ s <- getInput + return $ atEnd s + pushLexState :: Int -> P () pushLexState ls = P $ \s@PState{ lex_state=l } -> POk s{lex_state=ls:l} () @@ -1324,15 +1329,24 @@ getLexState :: P Int getLexState = P $ \s@PState{ lex_state=ls:_ } -> POk s ls -popNextToken :: P (Maybe (Located Token)) +popNextToken :: P (Maybe (RealLocated Token)) popNextToken = P $ \s@PState{ alr_next_token = m } -> POk (s {alr_next_token = Nothing}) m -setAlrLastLoc :: SrcSpan -> P () +activeContext :: P Bool +activeContext = do + ctxt <- getALRContext + expc <- getAlrExpectingOCurly + impt <- implicitTokenPending + case (ctxt,expc) of + ([],Nothing) -> return impt + _other -> return True + +setAlrLastLoc :: RealSrcSpan -> P () setAlrLastLoc l = P $ \s -> POk (s {alr_last_loc = l}) () -getAlrLastLoc :: P SrcSpan +getAlrLastLoc :: P RealSrcSpan getAlrLastLoc = P $ \s@(PState {alr_last_loc = l}) -> POk s l getALRContext :: P [ALRContext] @@ -1349,17 +1363,24 @@ setJustClosedExplicitLetBlock b = P $ \s -> POk (s {alr_justClosedExplicitLetBlock = b}) () -setNextToken :: Located Token -> P () +setNextToken :: RealLocated Token -> P () setNextToken t = P $ \s -> POk (s {alr_next_token = Just t}) () -popPendingImplicitToken :: P (Maybe (Located Token)) +implicitTokenPending :: P Bool +implicitTokenPending + = P $ \s@PState{ alr_pending_implicit_tokens = ts } -> + case ts of + [] -> POk s False + _ -> POk s True + +popPendingImplicitToken :: P (Maybe (RealLocated Token)) popPendingImplicitToken = P $ \s@PState{ alr_pending_implicit_tokens = ts } -> case ts of [] -> POk s Nothing (t : ts') -> POk (s {alr_pending_implicit_tokens = ts'}) (Just t) -setPendingImplicitTokens :: [Located Token] -> P () +setPendingImplicitTokens :: [RealLocated Token] -> P () setPendingImplicitTokens ts = P $ \s -> POk (s {alr_pending_implicit_tokens = ts}) () getAlrExpectingOCurly :: P (Maybe ALRLayout) @@ -1369,28 +1390,28 @@ setAlrExpectingOCurly b = P $ \s -> POk (s {alr_expecting_ocurly = b}) () -- for reasons of efficiency, flags indicating language extensions (eg, --- -fglasgow-exts or -XParr) are represented by a bitmap stored in an unboxed --- integer +-- -fglasgow-exts or -XParallelArrays) are represented by a bitmap +-- stored in an unboxed Int -genericsBit :: Int -genericsBit = 0 -- {| and |} ffiBit :: Int -ffiBit = 1 +ffiBit= 0 +interruptibleFfiBit :: Int +interruptibleFfiBit = 1 parrBit :: Int -parrBit = 2 +parrBit = 3 arrowsBit :: Int arrowsBit = 4 thBit :: Int -thBit = 5 +thBit = 5 ipBit :: Int -ipBit = 6 +ipBit = 6 explicitForallBit :: Int explicitForallBit = 7 -- the 'forall' keyword and '.' symbol bangPatBit :: Int -bangPatBit = 8 -- Tells the parser to understand bang-patterns - -- (doesn't affect the lexer) +bangPatBit = 8 -- Tells the parser to understand bang-patterns + -- (doesn't affect the lexer) tyFamBit :: Int -tyFamBit = 9 -- indexed type families: 'family' keyword and kind sigs +tyFamBit = 9 -- indexed type families: 'family' keyword and kind sigs haddockBit :: Int haddockBit = 10 -- Lex and parse Haddock comments magicHashBit :: Int @@ -1408,22 +1429,24 @@ transformComprehensionsBit :: Int transformComprehensionsBit = 17 qqBit :: Int -qqBit = 18 -- enable quasiquoting +qqBit = 18 -- enable quasiquoting inRulePragBit :: Int inRulePragBit = 19 rawTokenStreamBit :: Int rawTokenStreamBit = 20 -- producing a token stream with all comments included -newQualOpsBit :: Int -newQualOpsBit = 21 -- Haskell' qualified operator syntax, e.g. Prelude.(+) recBit :: Int recBit = 22 -- rec alternativeLayoutRuleBit :: Int alternativeLayoutRuleBit = 23 +relaxedLayoutBit :: Int +relaxedLayoutBit = 24 +nondecreasingIndentationBit :: Int +nondecreasingIndentationBit = 25 +safeHaskellBit :: Int +safeHaskellBit = 26 always :: Int -> Bool always _ = True -genericsEnabled :: Int -> Bool -genericsEnabled flags = testBit flags genericsBit parrEnabled :: Int -> Bool parrEnabled flags = testBit flags parrBit arrowsEnabled :: Int -> Bool @@ -1456,29 +1479,29 @@ -- inRulePrag flags = testBit flags inRulePragBit rawTokenStreamEnabled :: Int -> Bool rawTokenStreamEnabled flags = testBit flags rawTokenStreamBit -newQualOps :: Int -> Bool -newQualOps flags = testBit flags newQualOpsBit -oldQualOps :: Int -> Bool -oldQualOps flags = not (newQualOps flags) alternativeLayoutRule :: Int -> Bool alternativeLayoutRule flags = testBit flags alternativeLayoutRuleBit +relaxedLayout :: Int -> Bool +relaxedLayout flags = testBit flags relaxedLayoutBit +nondecreasingIndentation :: Int -> Bool +nondecreasingIndentation flags = testBit flags nondecreasingIndentationBit -- PState for parsing options pragmas -- -pragState :: DynFlags -> StringBuffer -> SrcLoc -> PState +pragState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState pragState dynflags buf loc = (mkPState dynflags buf loc) { lex_state = [bol, option_prags, 0] } -- create a parse state -- -mkPState :: DynFlags -> StringBuffer -> SrcLoc -> PState +mkPState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState mkPState flags buf loc = PState { - buffer = buf, + buffer = buf, dflags = flags, messages = emptyMessages, - last_loc = mkSrcSpan loc loc, + last_loc = mkRealSrcSpan loc loc, last_len = 0, loc = loc, extsBitmap = fromIntegral bitmap, @@ -1486,45 +1509,48 @@ lex_state = [bol, 0], alr_pending_implicit_tokens = [], alr_next_token = Nothing, - alr_last_loc = noSrcSpan, + alr_last_loc = alrInitialLoc (fsLit ""), alr_context = [], alr_expecting_ocurly = Nothing, alr_justClosedExplicitLetBlock = False } where - bitmap = genericsBit `setBitIf` xopt Opt_Generics flags - .|. ffiBit `setBitIf` xopt Opt_ForeignFunctionInterface flags - .|. parrBit `setBitIf` xopt Opt_PArr flags - .|. arrowsBit `setBitIf` xopt Opt_Arrows flags - .|. thBit `setBitIf` xopt Opt_TemplateHaskell flags - .|. qqBit `setBitIf` xopt Opt_QuasiQuotes flags - .|. ipBit `setBitIf` xopt Opt_ImplicitParams flags - .|. explicitForallBit `setBitIf` xopt Opt_ExplicitForAll flags - .|. bangPatBit `setBitIf` xopt Opt_BangPatterns flags - .|. tyFamBit `setBitIf` xopt Opt_TypeFamilies flags - .|. haddockBit `setBitIf` dopt Opt_Haddock flags - .|. magicHashBit `setBitIf` xopt Opt_MagicHash flags - .|. kindSigsBit `setBitIf` xopt Opt_KindSignatures flags - .|. recursiveDoBit `setBitIf` xopt Opt_RecursiveDo flags - .|. recBit `setBitIf` xopt Opt_DoRec flags - .|. recBit `setBitIf` xopt Opt_Arrows flags - .|. unicodeSyntaxBit `setBitIf` xopt Opt_UnicodeSyntax flags - .|. unboxedTuplesBit `setBitIf` xopt Opt_UnboxedTuples flags - .|. datatypeContextsBit `setBitIf` xopt Opt_DatatypeContexts flags - .|. transformComprehensionsBit `setBitIf` xopt Opt_TransformListComp flags - .|. rawTokenStreamBit `setBitIf` dopt Opt_KeepRawTokenStream flags - .|. newQualOpsBit `setBitIf` xopt Opt_NewQualifiedOperators flags - .|. alternativeLayoutRuleBit `setBitIf` xopt Opt_AlternativeLayoutRule flags + bitmap = ffiBit `setBitIf` xopt Opt_ForeignFunctionInterface flags + .|. interruptibleFfiBit `setBitIf` xopt Opt_InterruptibleFFI 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 + .|. nondecreasingIndentationBit `setBitIf` xopt Opt_NondecreasingIndentation flags + .|. safeHaskellBit `setBitIf` safeHaskellOn flags -- setBitIf :: Int -> Bool -> Int b `setBitIf` cond | cond = bit b - | otherwise = 0 + | otherwise = 0 -addWarning :: DynFlag -> SrcSpan -> SDoc -> P () +addWarning :: WarningFlag -> SrcSpan -> SDoc -> P () addWarning option srcspan warning = P $ \s@PState{messages=(ws,es), dflags=d} -> let warning' = mkWarnMsg srcspan alwaysQualify warning - ws' = if dopt option d then ws `snocBag` warning' else ws + ws' = if wopt option d then ws `snocBag` warning' else ws in POk s{messages=(ws', es)} () getMessages :: PState -> Messages @@ -1537,40 +1563,40 @@ setContext ctx = P $ \s -> POk s{context=ctx} () popContext :: P () -popContext = P $ \ s@(PState{ buffer = buf, context = ctx, +popContext = P $ \ s@(PState{ buffer = buf, context = ctx, last_len = len, last_loc = last_loc }) -> case ctx of - (_:tl) -> POk s{ context = tl } () - [] -> PFailed last_loc (srcParseErr buf len) + (_:tl) -> POk s{ context = tl } () + [] -> PFailed (RealSrcSpan last_loc) (srcParseErr buf len) -- Push a new layout context at the indentation of the last token read. -- This is only used at the outer level of a module when the 'module' -- keyword is missing. pushCurrentContext :: P () -pushCurrentContext = P $ \ s@PState{ last_loc=loc, context=ctx } -> +pushCurrentContext = P $ \ s@PState{ last_loc=loc, context=ctx } -> POk s{context = Layout (srcSpanStartCol loc) : ctx} () getOffside :: P Ordering getOffside = P $ \s@PState{last_loc=loc, context=stk} -> let offs = srcSpanStartCol loc in - let ord = case stk of - (Layout n:_) -> --trace ("layout: " ++ show n ++ ", offs: " ++ show offs) $ + let ord = case stk of + (Layout n:_) -> --trace ("layout: " ++ show n ++ ", offs: " ++ show offs) $ compare offs n - _ -> GT - in POk s ord + _ -> GT + in POk s ord -- --------------------------------------------------------------------------- -- Construct a parse error srcParseErr - :: StringBuffer -- current buffer (placed just after the last token) - -> Int -- length of the previous token + :: StringBuffer -- current buffer (placed just after the last token) + -> Int -- length of the previous token -> Message srcParseErr buf len - = hcat [ if null token - then ptext (sLit "parse error (possibly incorrect indentation)") - else hcat [ptext (sLit "parse error on input "), - char '`', text token, char '\''] + = hcat [ if null token + then ptext (sLit "parse error (possibly incorrect indentation)") + else hcat [ptext (sLit "parse error on input "), + char '`', text token, char '\''] ] where token = lexemeToString (offsetBytes (-len) buf) len @@ -1578,9 +1604,9 @@ -- the location of the error. This is the entry point for errors -- detected during parsing. srcParseFail :: P a -srcParseFail = P $ \PState{ buffer = buf, last_len = len, - last_loc = last_loc } -> - PFailed last_loc (srcParseErr buf len) +srcParseFail = P $ \PState{ buffer = buf, last_len = len, + last_loc = last_loc } -> + PFailed (RealSrcSpan last_loc) (srcParseErr buf len) -- A lexical error is reported at a particular position in the source file, -- not over a token range. @@ -1598,11 +1624,11 @@ lexer cont = do alr <- extension alternativeLayoutRule let lexTokenFun = if alr then lexTokenAlr else lexToken - tok@(L _span _tok__) <- lexTokenFun - --trace ("token: " ++ show _tok__) $ do - cont tok + (L span tok) <- lexTokenFun + --trace ("token: " ++ show tok) $ do + cont (L (RealSrcSpan span) tok) -lexTokenAlr :: P (Located Token) +lexTokenAlr :: P (RealLocated Token) lexTokenAlr = do mPending <- popPendingImplicitToken t <- case mPending of Nothing -> @@ -1624,7 +1650,7 @@ _ -> return () return t -alternativeLayoutRuleToken :: Located Token -> P (Located Token) +alternativeLayoutRuleToken :: RealLocated Token -> P (RealLocated Token) alternativeLayoutRuleToken t = do context <- getALRContext lastLoc <- getAlrLastLoc @@ -1635,8 +1661,7 @@ let transitional = xopt Opt_AlternativeLayoutRuleTransitional dflags thisLoc = getLoc t thisCol = srcSpanStartCol thisLoc - newLine = (lastLoc == noSrcSpan) - || (srcSpanStartLine thisLoc > srcSpanEndLine lastLoc) + newLine = srcSpanStartLine thisLoc > srcSpanEndLine lastLoc case (unLoc t, context, mExpectingOCurly) of -- This case handles a GHC extension to the original H98 -- layout rule... @@ -1696,7 +1721,7 @@ (ITwhere, ALRLayout _ col : ls, _) | newLine && thisCol == col && transitional -> do addWarning Opt_WarnAlternativeLayoutRuleTransitional - thisLoc + (RealSrcSpan thisLoc) (transitionalAlternativeLayoutWarning "`where' clause at the same depth as implicit layout block") setALRContext ls @@ -1708,7 +1733,7 @@ (ITvbar, ALRLayout _ col : ls, _) | newLine && thisCol == col && transitional -> do addWarning Opt_WarnAlternativeLayoutRuleTransitional - thisLoc + (RealSrcSpan thisLoc) (transitionalAlternativeLayoutWarning "`|' at the same depth as implicit layout block") setALRContext ls @@ -1823,14 +1848,14 @@ topNoLayoutContainsCommas (ALRLayout _ _ : ls) = topNoLayoutContainsCommas ls topNoLayoutContainsCommas (ALRNoLayout b _ : _) = b -lexToken :: P (Located Token) +lexToken :: P (RealLocated Token) lexToken = do inp@(AI loc1 buf) <- getInput sc <- getLexState exts <- getExts case alexScanUser exts inp sc of AlexEOF -> do - let span = mkSrcSpan loc1 loc1 + let span = mkRealSrcSpan loc1 loc1 setLastToken span 0 return (L span ITeof) AlexError (AI loc2 buf) -> @@ -1840,23 +1865,21 @@ lexToken AlexToken inp2@(AI end buf2) _ t -> do setInput inp2 - let span = mkSrcSpan loc1 end + let span = mkRealSrcSpan loc1 end let bytes = byteDiff buf buf2 span `seq` setLastToken span bytes t span buf bytes -reportLexError :: SrcLoc -> SrcLoc -> StringBuffer -> [Char] -> P a +reportLexError :: RealSrcLoc -> RealSrcLoc -> StringBuffer -> [Char] -> P a reportLexError loc1 loc2 buf str | atEnd buf = failLocMsgP loc1 loc2 (str ++ " at end of input") | otherwise = - let - c = fst (nextChar buf) - in - if c == '\0' -- decoding errors are mapped to '\0', see utf8DecodeChar# - then failLocMsgP loc2 loc2 (str ++ " (UTF-8 decoding error)") - else failLocMsgP loc1 loc2 (str ++ " at character " ++ show c) + let c = fst (nextChar buf) + in if c == '\0' -- decoding errors are mapped to '\0', see utf8DecodeChar# + then failLocMsgP loc2 loc2 (str ++ " (UTF-8 decoding error)") + else failLocMsgP loc1 loc2 (str ++ " at character " ++ show c) -lexTokenStream :: StringBuffer -> SrcLoc -> DynFlags -> ParseResult [Located Token] +lexTokenStream :: StringBuffer -> RealSrcLoc -> DynFlags -> ParseResult [Located Token] lexTokenStream buf loc dflags = unP go initState where dflags' = dopt_set (dopt_unset dflags Opt_Haddock) Opt_KeepRawTokenStream initState = mkPState dflags' buf loc @@ -1885,7 +1908,7 @@ ("inline", token (ITinline_prag Inline FunLike)), ("inlinable", token (ITinline_prag Inlinable FunLike)), ("inlineable", token (ITinline_prag Inlinable FunLike)), - -- Spelling variant + -- Spelling variant ("notinline", token (ITinline_prag NoInline FunLike)), ("specialize", token ITspec_prag), ("source", token ITsource_prag), @@ -1895,13 +1918,15 @@ ("generated", token ITgenerated_prag), ("core", token ITcore_prag), ("unpack", token ITunpack_prag), - ("ann", token ITann_prag)]) + ("ann", token ITann_prag), + ("vectorize", token ITvect_prag), + ("novectorize", token ITnovect_prag)]) twoWordPrags = Map.fromList([("inline conlike", token (ITinline_prag Inline ConLike)), ("notinline conlike", token (ITinline_prag NoInline ConLike)), ("specialize inline", token (ITspec_inline_prag True)), - ("specialize notinline", token (ITspec_inline_prag False))]) - + ("specialize notinline", token (ITspec_inline_prag False)), + ("vectorize scalar", token ITvect_scalar_prag)]) dispatch_pragmas :: Map String Action -> Action dispatch_pragmas prags span buf len = case Map.lookup (clean_pragma (lexemeToString buf len)) prags of @@ -1920,6 +1945,8 @@ canonical prag' = case prag' of "noinline" -> "notinline" "specialise" -> "specialize" + "vectorise" -> "vectorize" + "novectorise" -> "novectorize" "constructorlike" -> "conlike" _ -> prag' canon_ws s = unwords (map canonical (words s)) @@ -1947,7 +1974,7 @@ alex_action_8 = lineCommentToken alex_action_10 = begin line_prag1 alex_action_13 = do_bol -alex_action_14 = pop_and open_brace +alex_action_14 = hopefully_open_brace alex_action_16 = begin line_prag1 alex_action_17 = new_layout_context True alex_action_18 = new_layout_context False @@ -1989,48 +2016,44 @@ alex_action_53 = skip_one_varid ITdupipvarid alex_action_54 = token IToubxparen alex_action_55 = token ITcubxparen -alex_action_56 = token ITocurlybar -alex_action_57 = token ITccurlybar -alex_action_58 = special IToparen -alex_action_59 = special ITcparen -alex_action_60 = special ITobrack -alex_action_61 = special ITcbrack -alex_action_62 = special ITcomma -alex_action_63 = special ITsemi -alex_action_64 = special ITbackquote -alex_action_65 = open_brace -alex_action_66 = close_brace -alex_action_67 = idtoken qvarid -alex_action_68 = idtoken qconid -alex_action_69 = varid -alex_action_70 = idtoken conid -alex_action_71 = idtoken qvarid -alex_action_72 = idtoken qconid -alex_action_73 = varid -alex_action_74 = idtoken conid -alex_action_75 = idtoken qvarsym -alex_action_76 = idtoken qconsym -alex_action_77 = idtoken prefixqvarsym -alex_action_78 = idtoken prefixqconsym -alex_action_79 = varsym -alex_action_80 = consym -alex_action_81 = tok_num positive 0 0 decimal -alex_action_82 = tok_num positive 2 2 octal -alex_action_83 = tok_num positive 2 2 hexadecimal -alex_action_84 = strtoken tok_float -alex_action_85 = tok_primint positive 0 1 decimal -alex_action_86 = tok_primint positive 2 3 octal -alex_action_87 = tok_primint positive 2 3 hexadecimal -alex_action_88 = tok_primint negative 1 2 decimal -alex_action_89 = tok_primint negative 3 4 octal -alex_action_90 = tok_primint negative 3 4 hexadecimal -alex_action_91 = tok_primword 0 2 decimal -alex_action_92 = tok_primword 2 4 octal -alex_action_93 = tok_primword 2 4 hexadecimal -alex_action_94 = init_strtoken 1 tok_primfloat -alex_action_95 = init_strtoken 2 tok_primdouble -alex_action_96 = lex_char_tok -alex_action_97 = lex_string_tok +alex_action_56 = special IToparen +alex_action_57 = special ITcparen +alex_action_58 = special ITobrack +alex_action_59 = special ITcbrack +alex_action_60 = special ITcomma +alex_action_61 = special ITsemi +alex_action_62 = special ITbackquote +alex_action_63 = open_brace +alex_action_64 = close_brace +alex_action_65 = idtoken qvarid +alex_action_66 = idtoken qconid +alex_action_67 = varid +alex_action_68 = idtoken conid +alex_action_69 = idtoken qvarid +alex_action_70 = idtoken qconid +alex_action_71 = varid +alex_action_72 = idtoken conid +alex_action_73 = idtoken qvarsym +alex_action_74 = idtoken qconsym +alex_action_75 = varsym +alex_action_76 = consym +alex_action_77 = tok_num positive 0 0 decimal +alex_action_78 = tok_num positive 2 2 octal +alex_action_79 = tok_num positive 2 2 hexadecimal +alex_action_80 = strtoken tok_float +alex_action_81 = tok_primint positive 0 1 decimal +alex_action_82 = tok_primint positive 2 3 octal +alex_action_83 = tok_primint positive 2 3 hexadecimal +alex_action_84 = tok_primint negative 1 2 decimal +alex_action_85 = tok_primint negative 3 4 octal +alex_action_86 = tok_primint negative 3 4 hexadecimal +alex_action_87 = tok_primword 0 2 decimal +alex_action_88 = tok_primword 2 4 octal +alex_action_89 = tok_primword 2 4 hexadecimal +alex_action_90 = init_strtoken 1 tok_primfloat +alex_action_91 = init_strtoken 2 tok_primdouble +alex_action_92 = lex_char_tok +alex_action_93 = lex_string_tok {-# LINE 1 "templates/GenericTemplate.hs" #-} {-# LINE 1 "templates/GenericTemplate.hs" #-} {-# LINE 1 "" #-} diff -Nru ghc-7.0.3/compiler/parser/Lexer.x.source ghc-7.2.1/compiler/parser/Lexer.x.source --- ghc-7.0.3/compiler/parser/Lexer.x.source 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/parser/Lexer.x.source 2011-08-07 17:10:05.000000000 +0000 @@ -7,7 +7,8 @@ -- definition, with some hand-coded bits. -- -- Completely accurate information about token-spans within the source --- file is maintained. Every token has a start and end SrcLoc attached to it. +-- file is maintained. Every token has a start and end RealSrcLoc +-- attached to it. -- ----------------------------------------------------------------------------- @@ -20,7 +21,7 @@ -- - pragma-end should be only valid in a pragma -- qualified operator NOTES. --- +-- -- - If M.(+) is a single lexeme, then.. -- - Probably (+) should be a single lexeme too, for consistency. -- Otherwise ( + ) would be a prefix operator, but M.( + ) would not be. @@ -32,6 +33,7 @@ { -- XXX The above flags turn off warnings in the generated code: +{-# LANGUAGE BangPatterns #-} {-# OPTIONS_GHC -fno-warn-unused-matches #-} {-# OPTIONS_GHC -fno-warn-unused-binds #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-} @@ -45,11 +47,12 @@ module Lexer ( Token(..), lexer, pragState, mkPState, PState(..), - P(..), ParseResult(..), getSrcLoc, + P(..), ParseResult(..), getSrcLoc, getPState, getDynFlags, withThisPackage, failLocMsgP, failSpanMsgP, srcParseFail, - getMessages, + getMessages, popContext, pushCurrentContext, setLastToken, setSrcLoc, + activeContext, nextIsEOF, getLexState, popLexState, pushLexState, extension, bangPatEnabled, datatypeContextsEnabled, addWarning, @@ -66,8 +69,8 @@ import DynFlags import Module import Ctype -import BasicTypes ( InlineSpec(..), RuleMatchInfo(..) ) -import Util ( readRational ) +import BasicTypes ( InlineSpec(..), RuleMatchInfo(..), FractionalLit(..) ) +import Util ( readRational ) import Control.Monad import Data.Bits @@ -105,7 +108,7 @@ $unigraphic = \x06 -- Trick Alex into handling Unicode. See alexGetChar. $graphic = [$small $large $symbol $digit $special $unigraphic \:\"\'] -$octit = 0-7 +$octit = 0-7 $hexit = [$decdigit A-F a-f] $symchar = [$symbol \:] $nl = [\n\r] @@ -139,7 +142,7 @@ haskell :- -- everywhere: skip whitespace and comments -$white_no_nl+ ; +$white_no_nl+ ; $tab+ { warn Opt_WarnTabs (text "Warning: Tab character") } -- Everywhere: deal with nested comments. We explicitly rule out @@ -156,7 +159,7 @@ -- have to exclude those. -- Since Haddock comments aren't valid in every state, we need to rule them --- out here. +-- out here. -- The following two rules match comments that begin with two dashes, but -- continue with a different character. The rules test that this character @@ -199,53 +202,53 @@ -- as a nested comment. We don't bother with this: if the line begins -- with {-#, then we'll assume it's a pragma we know about and go for do_bol. { - \n ; - ^\# (line)? { begin line_prag1 } - ^\# pragma .* \n ; -- GCC 3.3 CPP generated, apparently - ^\# \! .* \n ; -- #!, for scripts - () { do_bol } + \n ; + ^\# (line)? { begin line_prag1 } + ^\# pragma .* \n ; -- GCC 3.3 CPP generated, apparently + ^\# \! .* \n ; -- #!, for scripts + () { do_bol } } -- after a layout keyword (let, where, do, of), we begin a new layout -- context if the curly brace is missing. -- Careful! This stuff is quite delicate. { - \{ / { notFollowedBy '-' } { pop_and open_brace } - -- we might encounter {-# here, but {- has been handled already - \n ; - ^\# (line)? { begin line_prag1 } + \{ / { notFollowedBy '-' } { hopefully_open_brace } + -- we might encounter {-# here, but {- has been handled already + \n ; + ^\# (line)? { begin line_prag1 } } -- do is treated in a subtly different way, see new_layout_context - () { new_layout_context True } - () { new_layout_context False } + () { new_layout_context True } + () { new_layout_context False } -- after a new layout context which was found to be to the left of the -- previous context, we have generated a '{' token, and we now need to -- generate a matching '}' token. - () { do_layout_left } + () { do_layout_left } -<0,option_prags> \n { begin bol } +<0,option_prags> \n { begin bol } "{-#" $whitechar* $pragmachar+ / { known_pragma linePrags } { dispatch_pragmas linePrags } -- single-line line pragmas, of the form -- # "" \n - $decdigit+ { setLine line_prag1a } - \" [$graphic \ ]* \" { setFile line_prag1b } - .* { pop } + $decdigit+ { setLine line_prag1a } + \" [$graphic \ ]* \" { setFile line_prag1b } + .* { pop } -- Haskell-style line pragmas, of the form -- {-# LINE "" #-} - $decdigit+ { setLine line_prag2a } - \" [$graphic \ ]* \" { setFile line_prag2b } - "#-}"|"-}" { pop } + $decdigit+ { setLine line_prag2a } + \" [$graphic \ ]* \" { setFile line_prag2b } + "#-}"|"-}" { pop } -- NOTE: accept -} at the end of a LINE pragma, for compatibility -- with older versions of GHC which generated these. <0,option_prags> { - "{-#" $whitechar* $pragmachar+ + "{-#" $whitechar* $pragmachar+ $whitechar+ $pragmachar+ / { known_pragma twoWordPrags } { dispatch_pragmas twoWordPrags } @@ -257,14 +260,14 @@ { dispatch_pragmas ignoredPrags } -- ToDo: should only be valid inside a pragma: - "#-}" { endPrag } + "#-}" { endPrag } } { "{-#" $whitechar* $pragmachar+ / { known_pragma fileHeaderPrags } { dispatch_pragmas fileHeaderPrags } - "-- #" { multiline_doc_comment } + "-- #" { multiline_doc_comment } } <0> { @@ -294,19 +297,19 @@ -- "special" symbols <0> { - "[:" / { ifExtension parrEnabled } { token ITopabrack } - ":]" / { ifExtension parrEnabled } { token ITcpabrack } + "[:" / { ifExtension parrEnabled } { token ITopabrack } + ":]" / { ifExtension parrEnabled } { token ITcpabrack } } - + <0> { - "[|" / { ifExtension thEnabled } { token ITopenExpQuote } - "[e|" / { ifExtension thEnabled } { token ITopenExpQuote } - "[p|" / { ifExtension thEnabled } { token ITopenPatQuote } - "[d|" / { ifExtension thEnabled } { layout_token ITopenDecQuote } - "[t|" / { ifExtension thEnabled } { token ITopenTypQuote } - "|]" / { ifExtension thEnabled } { token ITcloseQuote } - \$ @varid / { ifExtension thEnabled } { skip_one_varid ITidEscape } - "$(" / { ifExtension thEnabled } { token ITparenEscape } + "[|" / { ifExtension thEnabled } { token ITopenExpQuote } + "[e|" / { ifExtension thEnabled } { token ITopenExpQuote } + "[p|" / { ifExtension thEnabled } { token ITopenPatQuote } + "[d|" / { ifExtension thEnabled } { layout_token ITopenDecQuote } + "[t|" / { ifExtension thEnabled } { token ITopenTypQuote } + "|]" / { ifExtension thEnabled } { token ITcloseQuote } + \$ @varid / { ifExtension thEnabled } { skip_one_varid ITidEscape } + "$(" / { ifExtension thEnabled } { token ITparenEscape } -- For backward compatibility, accept the old dollar syntax "[$" @varid "|" / { ifExtension qqEnabled } @@ -318,12 +321,12 @@ <0> { "(|" / { ifExtension arrowsEnabled `alexAndPred` notFollowedBySymbol } - { special IToparenbar } + { special IToparenbar } "|)" / { ifExtension arrowsEnabled } { special ITcparenbar } } <0> { - \? @varid / { ifExtension ipEnabled } { skip_one_varid ITdupipvarid } + \? @varid / { ifExtension ipEnabled } { skip_one_varid ITdupipvarid } } <0> { @@ -333,29 +336,24 @@ { token ITcubxparen } } -<0> { - "{|" / { ifExtension genericsEnabled } { token ITocurlybar } - "|}" / { ifExtension genericsEnabled } { token ITccurlybar } -} - <0,option_prags> { - \( { special IToparen } - \) { special ITcparen } - \[ { special ITobrack } - \] { special ITcbrack } - \, { special ITcomma } - \; { special ITsemi } - \` { special ITbackquote } - - \{ { open_brace } - \} { close_brace } + \( { special IToparen } + \) { special ITcparen } + \[ { special ITobrack } + \] { special ITcbrack } + \, { special ITcomma } + \; { special ITsemi } + \` { special ITbackquote } + + \{ { open_brace } + \} { close_brace } } <0,option_prags> { - @qual @varid { idtoken qvarid } - @qual @conid { idtoken qconid } - @varid { varid } - @conid { idtoken conid } + @qual @varid { idtoken qvarid } + @qual @conid { idtoken qconid } + @varid { varid } + @conid { idtoken conid } } <0> { @@ -368,10 +366,8 @@ -- ToDo: - move `var` and (sym) into lexical syntax? -- - remove backquote from $special? <0> { - @qual @varsym / { ifExtension oldQualOps } { idtoken qvarsym } - @qual @consym / { ifExtension oldQualOps } { idtoken qconsym } - @qual \( @varsym \) / { ifExtension newQualOps } { idtoken prefixqvarsym } - @qual \( @consym \) / { ifExtension newQualOps } { idtoken prefixqconsym } + @qual @varsym { idtoken qvarsym } + @qual @consym { idtoken qconsym } @varsym { varsym } @consym { consym } } @@ -414,8 +410,8 @@ -- lexer, we would still have to parse the string afterward in order -- to convert it to a String. <0> { - \' { lex_char_tok } - \" { lex_string_tok } + \' { lex_char_tok } + \" { lex_string_tok } } { @@ -423,7 +419,7 @@ -- The token type data Token - = ITas -- Haskell keywords + = ITas -- Haskell keywords | ITcase | ITclass | ITdata @@ -447,15 +443,15 @@ | ITthen | ITtype | ITwhere - | ITscc -- ToDo: remove (we use {-# SCC "..." #-} now) + | ITscc -- ToDo: remove (we use {-# SCC "..." #-} now) - | ITforall -- GHC extension keywords + | ITforall -- GHC extension keywords | ITforeign | ITexport | ITlabel | ITdynamic | ITsafe - | ITthreadsafe + | ITinterruptible | ITunsafe | ITstdcallconv | ITccallconv @@ -466,10 +462,10 @@ | ITby | ITusing - -- Pragmas + -- Pragmas | ITinline_prag InlineSpec RuleMatchInfo - | ITspec_prag -- SPECIALISE - | ITspec_inline_prag Bool -- SPECIALISE INLINE (or NOINLINE) + | ITspec_prag -- SPECIALISE + | ITspec_inline_prag Bool -- SPECIALISE INLINE (or NOINLINE) | ITsource_prag | ITrules_prag | ITwarning_prag @@ -484,8 +480,11 @@ | IToptions_prag String | ITinclude_prag String | ITlanguage_prag + | ITvect_prag + | ITvect_scalar_prag + | ITnovect_prag - | ITdotdot -- reserved symbols + | ITdotdot -- reserved symbols | ITcolon | ITdcolon | ITequal @@ -501,17 +500,17 @@ | ITstar | ITdot - | ITbiglam -- GHC-extension symbols + | ITbiglam -- GHC-extension symbols - | ITocurly -- special symbols + | ITocurly -- special symbols | ITccurly | ITocurlybar -- {|, for type applications | ITccurlybar -- |}, for type applications | ITvocurly | ITvccurly | ITobrack - | ITopabrack -- [:, for parallel arrays with -XParr - | ITcpabrack -- :], for parallel arrays with -XParr + | ITopabrack -- [:, for parallel arrays with -XParallelArrays + | ITcpabrack -- :], for parallel arrays with -XParallelArrays | ITcbrack | IToparen | ITcparen @@ -522,7 +521,7 @@ | ITunderscore | ITbackquote - | ITvarid FastString -- identifiers + | ITvarid FastString -- identifiers | ITconid FastString | ITvarsym FastString | ITconsym FastString @@ -533,44 +532,44 @@ | ITprefixqvarsym (FastString,FastString) | ITprefixqconsym (FastString,FastString) - | ITdupipvarid FastString -- GHC extension: implicit param: ?x + | ITdupipvarid FastString -- GHC extension: implicit param: ?x | ITchar Char | ITstring FastString | ITinteger Integer - | ITrational Rational + | ITrational FractionalLit | ITprimchar Char | ITprimstring FastString | ITprimint Integer | ITprimword Integer - | ITprimfloat Rational - | ITprimdouble Rational + | ITprimfloat FractionalLit + | ITprimdouble FractionalLit -- Template Haskell extension tokens - | ITopenExpQuote -- [| or [e| - | ITopenPatQuote -- [p| - | ITopenDecQuote -- [d| - | ITopenTypQuote -- [t| - | ITcloseQuote -- |] - | ITidEscape FastString -- $x - | ITparenEscape -- $( - | ITvarQuote -- ' - | ITtyQuote -- '' - | ITquasiQuote (FastString,FastString,SrcSpan) -- [:...|...|] + | ITopenExpQuote -- [| or [e| + | ITopenPatQuote -- [p| + | ITopenDecQuote -- [d| + | ITopenTypQuote -- [t| + | ITcloseQuote -- |] + | ITidEscape FastString -- $x + | ITparenEscape -- $( + | ITvarQuote -- ' + | ITtyQuote -- '' + | ITquasiQuote (FastString,FastString,RealSrcSpan) -- [:...|...|] -- Arrow notation extension | ITproc | ITrec - | IToparenbar -- (| - | ITcparenbar -- |) - | ITlarrowtail -- -< - | ITrarrowtail -- >- - | ITLarrowtail -- -<< - | ITRarrowtail -- >>- + | IToparenbar -- (| + | ITcparenbar -- |) + | ITlarrowtail -- -< + | ITrarrowtail -- >- + | ITLarrowtail -- -<< + | ITRarrowtail -- >>- - | ITunknown String -- Used when the lexer can't make sense of it - | ITeof -- end of file token + | ITunknown String -- Used when the lexer can't make sense of it + | ITeof -- end of file token -- Documentation annotations | ITdocCommentNext String -- something beginning '-- |' @@ -586,32 +585,6 @@ deriving Show -- debugging #endif -{- -isSpecial :: Token -> Bool --- If we see M.x, where x is a keyword, but --- is special, we treat is as just plain M.x, --- not as a keyword. -isSpecial ITas = True -isSpecial IThiding = True -isSpecial ITqualified = True -isSpecial ITforall = True -isSpecial ITexport = True -isSpecial ITlabel = True -isSpecial ITdynamic = True -isSpecial ITsafe = True -isSpecial ITthreadsafe = True -isSpecial ITunsafe = True -isSpecial ITccallconv = True -isSpecial ITstdcallconv = True -isSpecial ITprimcallconv = True -isSpecial ITmdo = True -isSpecial ITfamily = True -isSpecial ITgroup = True -isSpecial ITby = True -isSpecial ITusing = True -isSpecial _ = False --} - -- the bitmap provided as the third component indicates whether the -- corresponding extension keyword is valid under the extension options -- provided to the compiler; if the extension corresponding to *any* of the @@ -621,54 +594,56 @@ -- reservedWordsFM :: UniqFM (Token, Int) reservedWordsFM = listToUFM $ - map (\(x, y, z) -> (mkFastString x, (y, z))) - [( "_", ITunderscore, 0 ), - ( "as", ITas, 0 ), - ( "case", ITcase, 0 ), - ( "class", ITclass, 0 ), - ( "data", ITdata, 0 ), - ( "default", ITdefault, 0 ), - ( "deriving", ITderiving, 0 ), - ( "do", ITdo, 0 ), - ( "else", ITelse, 0 ), - ( "hiding", IThiding, 0 ), - ( "if", ITif, 0 ), - ( "import", ITimport, 0 ), - ( "in", ITin, 0 ), - ( "infix", ITinfix, 0 ), - ( "infixl", ITinfixl, 0 ), - ( "infixr", ITinfixr, 0 ), - ( "instance", ITinstance, 0 ), - ( "let", ITlet, 0 ), - ( "module", ITmodule, 0 ), - ( "newtype", ITnewtype, 0 ), - ( "of", ITof, 0 ), - ( "qualified", ITqualified, 0 ), - ( "then", ITthen, 0 ), - ( "type", ITtype, 0 ), - ( "where", ITwhere, 0 ), - ( "_scc_", ITscc, 0 ), -- ToDo: remove - - ( "forall", ITforall, bit explicitForallBit .|. bit inRulePragBit), - ( "mdo", ITmdo, bit recursiveDoBit), - ( "family", ITfamily, bit tyFamBit), - ( "group", ITgroup, bit transformComprehensionsBit), - ( "by", ITby, bit transformComprehensionsBit), - ( "using", ITusing, bit transformComprehensionsBit), - - ( "foreign", ITforeign, bit ffiBit), - ( "export", ITexport, bit ffiBit), - ( "label", ITlabel, bit ffiBit), - ( "dynamic", ITdynamic, bit ffiBit), - ( "safe", ITsafe, bit ffiBit), - ( "threadsafe", ITthreadsafe, bit ffiBit), -- ToDo: remove - ( "unsafe", ITunsafe, bit ffiBit), - ( "stdcall", ITstdcallconv, bit ffiBit), - ( "ccall", ITccallconv, bit ffiBit), - ( "prim", ITprimcallconv, bit ffiBit), + map (\(x, y, z) -> (mkFastString x, (y, z))) + [( "_", ITunderscore, 0 ), + ( "as", ITas, 0 ), + ( "case", ITcase, 0 ), + ( "class", ITclass, 0 ), + ( "data", ITdata, 0 ), + ( "default", ITdefault, 0 ), + ( "deriving", ITderiving, 0 ), + ( "do", ITdo, 0 ), + ( "else", ITelse, 0 ), + ( "hiding", IThiding, 0 ), + ( "if", ITif, 0 ), + ( "import", ITimport, 0 ), + ( "in", ITin, 0 ), + ( "infix", ITinfix, 0 ), + ( "infixl", ITinfixl, 0 ), + ( "infixr", ITinfixr, 0 ), + ( "instance", ITinstance, 0 ), + ( "let", ITlet, 0 ), + ( "module", ITmodule, 0 ), + ( "newtype", ITnewtype, 0 ), + ( "of", ITof, 0 ), + ( "qualified", ITqualified, 0 ), + ( "then", ITthen, 0 ), + ( "type", ITtype, 0 ), + ( "where", ITwhere, 0 ), + ( "_scc_", ITscc, 0 ), -- ToDo: remove + + ( "forall", ITforall, bit explicitForallBit .|. + bit inRulePragBit), + ( "mdo", ITmdo, bit recursiveDoBit), + ( "family", ITfamily, bit tyFamBit), + ( "group", ITgroup, bit transformComprehensionsBit), + ( "by", ITby, bit transformComprehensionsBit), + ( "using", ITusing, bit transformComprehensionsBit), + + ( "foreign", ITforeign, bit ffiBit), + ( "export", ITexport, bit ffiBit), + ( "label", ITlabel, bit ffiBit), + ( "dynamic", ITdynamic, bit ffiBit), + ( "safe", ITsafe, bit ffiBit .|. + bit safeHaskellBit), + ( "interruptible", ITinterruptible, bit interruptibleFfiBit), + ( "unsafe", ITunsafe, bit ffiBit), + ( "stdcall", ITstdcallconv, bit ffiBit), + ( "ccall", ITccallconv, bit ffiBit), + ( "prim", ITprimcallconv, bit ffiBit), - ( "rec", ITrec, bit recBit), - ( "proc", ITproc, bit arrowsBit) + ( "rec", ITrec, bit recBit), + ( "proc", ITproc, bit arrowsBit) ] reservedSymsFM :: UniqFM (Token, Int -> Bool) @@ -721,7 +696,7 @@ -- ----------------------------------------------------------------------------- -- Lexer actions -type Action = SrcSpan -> StringBuffer -> Int -> P (Located Token) +type Action = RealSrcSpan -> StringBuffer -> Int -> P (RealLocated Token) special :: Token -> Action special tok span _buf _len = return (L span tok) @@ -734,16 +709,16 @@ idtoken f span buf len = return (L span $! (f buf len)) skip_one_varid :: (FastString -> Token) -> Action -skip_one_varid f span buf len +skip_one_varid f span buf len = return (L span $! f (lexemeToFastString (stepOn buf) (len-1))) strtoken :: (String -> Token) -> Action -strtoken f span buf len = +strtoken f span buf len = return (L span $! (f $! lexemeToString buf len)) init_strtoken :: Int -> (String -> Token) -> Action -- like strtoken, but drops the last N character(s) -init_strtoken drop f span buf len = +init_strtoken drop f span buf len = return (L span $! (f $! lexemeToString buf (len-drop))) begin :: Int -> Action @@ -753,6 +728,19 @@ pop _span _buf _len = do _ <- popLexState lexToken +hopefully_open_brace :: Action +hopefully_open_brace span buf len + = do relaxed <- extension relaxedLayout + ctx <- getContext + (AI l _) <- getInput + let offset = srcLocCol l + isOK = relaxed || + case ctx of + Layout prev_off : _ -> prev_off < offset + _ -> True + if isOK then pop_and open_brace span buf len + else failSpanMsgP (RealSrcSpan span) (text "Missing block") + pop_and :: Action -> Action pop_and act span buf len = do _ <- popLexState act span buf len @@ -762,7 +750,7 @@ nextCharIs buf p = not (atEnd buf) && p (currentChar buf) notFollowedBy :: Char -> AlexAccPred Int -notFollowedBy char _ _ _ (AI _ buf) +notFollowedBy char _ _ _ (AI _ buf) = nextCharIs buf (/=char) notFollowedBySymbol :: AlexAccPred Int @@ -785,11 +773,6 @@ spaceAndP :: StringBuffer -> (StringBuffer -> Bool) -> Bool spaceAndP buf p = p buf || nextCharIs buf (==' ') && p (snd (nextChar buf)) -{- -haddockDisabledAnd p bits _ _ (AI _ buf) - = if haddockEnabled bits then False else (p buf) --} - atEOL :: AlexAccPred Int atEOL _ _ _ (AI _ buf) = atEnd buf || currentChar buf == '\n' @@ -800,14 +783,14 @@ multiline_doc_comment span buf _len = withLexedDocType (worker "") where worker commentAcc input docType oneLine = case alexGetChar input of - Just ('\n', input') + Just ('\n', input') | oneLine -> docCommentEnd input commentAcc docType buf span | otherwise -> case checkIfCommentLine input' of Just input -> worker ('\n':commentAcc) input docType False Nothing -> docCommentEnd input commentAcc docType buf span Just (c, input) -> worker (c:commentAcc) input docType oneLine Nothing -> docCommentEnd input commentAcc docType buf span - + checkIfCommentLine input = check (dropNonNewlineSpace input) where check input = case alexGetChar input of @@ -819,7 +802,7 @@ _ -> Nothing dropNonNewlineSpace input = case alexGetChar input of - Just (c, input') + Just (c, input') | isSpace c && c /= '\n' -> dropNonNewlineSpace input' | otherwise -> input Nothing -> input @@ -833,7 +816,7 @@ nested comments require traversing by hand, they can't be parsed using regular expressions. -} -nested_comment :: P (Located Token) -> Action +nested_comment :: P (RealLocated Token) -> Action nested_comment cont span _str _len = do input <- getInput go "" (1::Int) input @@ -874,8 +857,8 @@ Just (_,_) -> go ('\123':commentAcc) input docType False Just (c,input) -> go (c:commentAcc) input docType False -withLexedDocType :: (AlexInput -> (String -> Token) -> Bool -> P (Located Token)) - -> P (Located Token) +withLexedDocType :: (AlexInput -> (String -> Token) -> Bool -> P (RealLocated Token)) + -> P (RealLocated Token) withLexedDocType lexDocComment = do input@(AI _ buf) <- getInput case prevChar buf ' ' of @@ -885,8 +868,8 @@ '*' -> lexDocSection 1 input '#' -> lexDocComment input ITdocOptionsOld False _ -> panic "withLexedDocType: Bad doc type" - where - lexDocSection n input = case alexGetChar input of + where + lexDocSection n input = case alexGetChar input of Just ('*', input) -> lexDocSection (n+1) input Just (_, _) -> lexDocComment input (ITdocSection n) True Nothing -> do setInput input; lexToken -- eof reached, lex it normally @@ -907,31 +890,31 @@ ------------------------------------------------------------------------------- -- This function is quite tricky. We can't just return a new token, we also -- need to update the state of the parser. Why? Because the token is longer --- than what was lexed by Alex, and the lexToken function doesn't know this, so +-- than what was lexed by Alex, and the lexToken function doesn't know this, so -- it writes the wrong token length to the parser state. This function is --- called afterwards, so it can just update the state. +-- called afterwards, so it can just update the state. docCommentEnd :: AlexInput -> String -> (String -> Token) -> StringBuffer -> - SrcSpan -> P (Located Token) + RealSrcSpan -> P (RealLocated Token) docCommentEnd input commentAcc docType buf span = do setInput input let (AI loc nextBuf) = input comment = reverse commentAcc - span' = mkSrcSpan (srcSpanStart span) loc + span' = mkRealSrcSpan (realSrcSpanStart span) loc last_len = byteDiff buf nextBuf - + span `seq` setLastToken span' last_len return (L span' (docType comment)) - -errBrace :: AlexInput -> SrcSpan -> P a -errBrace (AI end _) span = failLocMsgP (srcSpanStart span) end "unterminated `{-'" + +errBrace :: AlexInput -> RealSrcSpan -> P a +errBrace (AI end _) span = failLocMsgP (realSrcSpanStart span) end "unterminated `{-'" open_brace, close_brace :: Action -open_brace span _str _len = do +open_brace span _str _len = do ctx <- getContext setContext (NoLayout:ctx) return (L span ITocurly) -close_brace span _str _len = do +close_brace span _str _len = do popContext return (L span ITccurly) @@ -946,44 +929,44 @@ splitQualName orig_buf len parens = split orig_buf orig_buf where split buf dot_buf - | orig_buf `byteDiff` buf >= len = done dot_buf - | c == '.' = found_dot buf' - | otherwise = split buf' dot_buf + | orig_buf `byteDiff` buf >= len = done dot_buf + | c == '.' = found_dot buf' + | otherwise = split buf' dot_buf where (c,buf') = nextChar buf - + -- careful, we might get names like M.... -- so, if the character after the dot is not upper-case, this is -- the end of the qualifier part. found_dot buf -- buf points after the '.' - | isUpper c = split buf' buf - | otherwise = done buf + | isUpper c = split buf' buf + | otherwise = done buf where (c,buf') = nextChar buf done dot_buf = - (lexemeToFastString orig_buf (qual_size - 1), - if parens -- Prelude.(+) + (lexemeToFastString orig_buf (qual_size - 1), + if parens -- Prelude.(+) then lexemeToFastString (stepOn dot_buf) (len - qual_size - 2) else lexemeToFastString dot_buf (len - qual_size)) where - qual_size = orig_buf `byteDiff` dot_buf + qual_size = orig_buf `byteDiff` dot_buf varid :: Action varid span buf len = fs `seq` case lookupUFM reservedWordsFM fs of - Just (keyword,0) -> do - maybe_layout keyword - return (L span keyword) - Just (keyword,exts) -> do - b <- extension (\i -> exts .&. i /= 0) - if b then do maybe_layout keyword - return (L span keyword) - else return (L span (ITvarid fs)) - _other -> return (L span (ITvarid fs)) + Just (keyword,0) -> do + maybe_layout keyword + return (L span keyword) + Just (keyword,exts) -> do + b <- extension (\i -> exts .&. i /= 0) + if b then do maybe_layout keyword + return (L span keyword) + else return (L span (ITvarid fs)) + _other -> return (L span (ITvarid fs)) where - fs = lexemeToFastString buf len + fs = lexemeToFastString buf len conid :: StringBuffer -> Int -> Token conid buf len = ITconid fs @@ -999,27 +982,27 @@ varsym = sym ITvarsym consym = sym ITconsym -sym :: (FastString -> Token) -> SrcSpan -> StringBuffer -> Int - -> P (Located Token) -sym con span buf len = +sym :: (FastString -> Token) -> RealSrcSpan -> StringBuffer -> Int + -> P (RealLocated Token) +sym con span buf len = case lookupUFM reservedSymsFM fs of - Just (keyword,exts) -> do - b <- extension exts - if b then return (L span keyword) - else return (L span $! con fs) - _other -> return (L span $! con fs) + Just (keyword,exts) -> do + b <- extension exts + if b then return (L span keyword) + else return (L span $! con fs) + _other -> return (L span $! con fs) where - fs = lexemeToFastString buf len + fs = lexemeToFastString buf len -- Variations on the integral numeric literal. tok_integral :: (Integer -> Token) - -> (Integer -> Integer) - -- -> (StringBuffer -> StringBuffer) -> (Int -> Int) - -> Int -> Int - -> (Integer, (Char->Int)) -> Action -tok_integral itint transint transbuf translen (radix,char_to_int) span buf len = - return $ L span $ itint $! transint $ parseUnsignedInteger - (offsetBytes transbuf buf) (subtract translen len) radix char_to_int + -> (Integer -> Integer) + -> Int -> Int + -> (Integer, (Char -> Int)) + -> Action +tok_integral itint transint transbuf translen (radix,char_to_int) span buf len + = return $ L span $ itint $! transint $ parseUnsignedInteger + (offsetBytes transbuf buf) (subtract translen len) radix char_to_int -- some conveniences for use with tok_integral tok_num :: (Integer -> Integer) @@ -1043,9 +1026,12 @@ -- readRational can understand negative rationals, exponents, everything. tok_float, tok_primfloat, tok_primdouble :: String -> Token -tok_float str = ITrational $! readRational str -tok_primfloat str = ITprimfloat $! readRational str -tok_primdouble str = ITprimdouble $! readRational str +tok_float str = ITrational $! readFractionalLit str +tok_primfloat str = ITprimfloat $! readFractionalLit str +tok_primdouble str = ITprimdouble $! readFractionalLit str + +readFractionalLit :: String -> FractionalLit +readFractionalLit str = (FL $! str) $! readRational str -- ----------------------------------------------------------------------------- -- Layout processing @@ -1053,20 +1039,20 @@ -- we're at the first token on a line, insert layout tokens if necessary do_bol :: Action do_bol span _str _len = do - pos <- getOffside - case pos of - LT -> do + pos <- getOffside + case pos of + LT -> do --trace "layout: inserting '}'" $ do - popContext - -- do NOT pop the lex state, we might have a ';' to insert - return (L span ITvccurly) - EQ -> do + popContext + -- do NOT pop the lex state, we might have a ';' to insert + return (L span ITvccurly) + EQ -> do --trace "layout: inserting ';'" $ do - _ <- popLexState - return (L span ITsemi) - GT -> do - _ <- popLexState - lexToken + _ <- popLexState + return (L span ITsemi) + GT -> do + _ <- popLexState + lexToken -- certain keywords put us in the "layout" state, where we might -- add an opening curly brace. @@ -1103,17 +1089,19 @@ (AI l _) <- getInput let offset = srcLocCol l ctx <- getContext + nondecreasing <- extension nondecreasingIndentation + let strict' = strict || not nondecreasing case ctx of - Layout prev_off : _ | - (strict && prev_off >= offset || - not strict && prev_off > offset) -> do - -- token is indented to the left of the previous context. - -- we must generate a {} sequence now. - pushLexState layout_left - return (L span ITvocurly) - _ -> do - setContext (Layout offset : ctx) - return (L span ITvocurly) + Layout prev_off : _ | + (strict' && prev_off >= offset || + not strict' && prev_off > offset) -> do + -- token is indented to the left of the previous context. + -- we must generate a {} sequence now. + pushLexState layout_left + return (L span ITvocurly) + _ -> do + setContext (Layout offset : ctx) + return (L span ITvocurly) do_layout_left :: Action do_layout_left span _buf _len = do @@ -1127,8 +1115,8 @@ setLine :: Int -> Action setLine code span buf len = do let line = parseUnsignedInteger buf len 10 octDecDigit - setSrcLoc (mkSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1) - -- subtract one: the line number refers to the *following* line + setSrcLoc (mkRealSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1) + -- subtract one: the line number refers to the *following* line _ <- popLexState pushLexState code lexToken @@ -1136,12 +1124,17 @@ setFile :: Int -> Action setFile code span buf len = do let file = lexemeToFastString (stepOn buf) (len-2) - setAlrLastLoc noSrcSpan - setSrcLoc (mkSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span)) + setAlrLastLoc $ alrInitialLoc file + setSrcLoc (mkRealSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span)) _ <- popLexState pushLexState code lexToken +alrInitialLoc :: FastString -> RealSrcSpan +alrInitialLoc file = mkRealSrcSpan loc loc + where -- This is a hack to ensure that the first line in a file + -- looks like it is after the initial location: + loc = mkRealSrcLoc file (-1) (-1) -- ----------------------------------------------------------------------------- -- Options, includes and language pragmas. @@ -1152,7 +1145,7 @@ start <- getSrcLoc tok <- go [] input end <- getSrcLoc - return (L (mkSrcSpan start end) tok) + return (L (mkRealSrcSpan start end) tok) where go acc input = if isString input "#-}" then do setInput input @@ -1165,7 +1158,7 @@ = case alexGetChar i of Just (c,i') | c == x -> isString i' xs _other -> False - err (AI end _) = failLocMsgP (srcSpanStart span) end "unterminated options pragma" + err (AI end _) = failLocMsgP (realSrcSpanStart span) end "unterminated options pragma" -- ----------------------------------------------------------------------------- @@ -1176,8 +1169,8 @@ lex_string_tok :: Action lex_string_tok span _buf _len = do tok <- lex_string "" - end <- getSrcLoc - return (L (mkSrcSpan (srcSpanStart span) end) tok) + end <- getSrcLoc + return (L (mkRealSrcSpan (realSrcSpanStart span) end) tok) lex_string :: String -> P Token lex_string s = do @@ -1186,32 +1179,32 @@ Nothing -> lit_error i Just ('"',i) -> do - setInput i - magicHash <- extension magicHashEnabled - if magicHash - then do - i <- getInput - case alexGetChar' i of - Just ('#',i) -> do - setInput i - if any (> '\xFF') s + setInput i + magicHash <- extension magicHashEnabled + if magicHash + then do + i <- getInput + case alexGetChar' i of + Just ('#',i) -> do + setInput i + if any (> '\xFF') s then failMsgP "primitive string literal must contain only characters <= \'\\xFF\'" else let s' = mkZFastString (reverse s) in - return (ITprimstring s') - -- mkZFastString is a hack to avoid encoding the - -- string in UTF-8. We just want the exact bytes. - _other -> - return (ITstring (mkFastString (reverse s))) - else - return (ITstring (mkFastString (reverse s))) + return (ITprimstring s') + -- mkZFastString is a hack to avoid encoding the + -- string in UTF-8. We just want the exact bytes. + _other -> + return (ITstring (mkFastString (reverse s))) + else + return (ITstring (mkFastString (reverse s))) Just ('\\',i) - | Just ('&',i) <- next -> do - setInput i; lex_string s - | Just (c,i) <- next, c <= '\x7f' && is_space c -> do + | Just ('&',i) <- next -> do + setInput i; lex_string s + | Just (c,i) <- next, c <= '\x7f' && is_space c -> do -- is_space only works for <= '\x7f' (#3751) - setInput i; lex_stringgap s - where next = alexGetChar' i + setInput i; lex_stringgap s + where next = alexGetChar' i Just (c, i1) -> do case c of @@ -1232,172 +1225,172 @@ lex_char_tok :: Action -- Here we are basically parsing character literals, such as 'x' or '\n' -- but, when Template Haskell is on, we additionally spot --- 'x and ''T, returning ITvarQuote and ITtyQuote respectively, +-- 'x and ''T, returning ITvarQuote and ITtyQuote respectively, -- but WITHOUT CONSUMING the x or T part (the parser does that). -- So we have to do two characters of lookahead: when we see 'x we need to -- see if there's a trailing quote -lex_char_tok span _buf _len = do -- We've seen ' - i1 <- getInput -- Look ahead to first character - let loc = srcSpanStart span +lex_char_tok span _buf _len = do -- We've seen ' + i1 <- getInput -- Look ahead to first character + let loc = realSrcSpanStart span case alexGetChar' i1 of - Nothing -> lit_error i1 + Nothing -> lit_error i1 - Just ('\'', i2@(AI end2 _)) -> do -- We've seen '' - th_exts <- extension thEnabled - if th_exts then do - setInput i2 - return (L (mkSrcSpan loc end2) ITtyQuote) - else lit_error i1 - - Just ('\\', i2@(AI _end2 _)) -> do -- We've seen 'backslash - setInput i2 - lit_ch <- lex_escape + Just ('\'', i2@(AI end2 _)) -> do -- We've seen '' + th_exts <- extension thEnabled + if th_exts then do + setInput i2 + return (L (mkRealSrcSpan loc end2) ITtyQuote) + else lit_error i1 + + Just ('\\', i2@(AI _end2 _)) -> do -- We've seen 'backslash + setInput i2 + lit_ch <- lex_escape i3 <- getInput - mc <- getCharOrFail i3 -- Trailing quote - if mc == '\'' then finish_char_tok loc lit_ch - else lit_error i3 + mc <- getCharOrFail i3 -- Trailing quote + if mc == '\'' then finish_char_tok loc lit_ch + else lit_error i3 Just (c, i2@(AI _end2 _)) - | not (isAny c) -> lit_error i1 - | otherwise -> + | not (isAny c) -> lit_error i1 + | otherwise -> - -- We've seen 'x, where x is a valid character - -- (i.e. not newline etc) but not a quote or backslash - case alexGetChar' i2 of -- Look ahead one more character - Just ('\'', i3) -> do -- We've seen 'x' - setInput i3 - finish_char_tok loc c - _other -> do -- We've seen 'x not followed by quote - -- (including the possibility of EOF) - -- If TH is on, just parse the quote only - th_exts <- extension thEnabled - let (AI end _) = i1 - if th_exts then return (L (mkSrcSpan loc end) ITvarQuote) - else lit_error i2 - -finish_char_tok :: SrcLoc -> Char -> P (Located Token) -finish_char_tok loc ch -- We've already seen the closing quote - -- Just need to check for trailing # - = do magicHash <- extension magicHashEnabled - i@(AI end _) <- getInput - if magicHash then do - case alexGetChar' i of - Just ('#',i@(AI end _)) -> do - setInput i - return (L (mkSrcSpan loc end) (ITprimchar ch)) - _other -> - return (L (mkSrcSpan loc end) (ITchar ch)) - else do - return (L (mkSrcSpan loc end) (ITchar ch)) + -- We've seen 'x, where x is a valid character + -- (i.e. not newline etc) but not a quote or backslash + case alexGetChar' i2 of -- Look ahead one more character + Just ('\'', i3) -> do -- We've seen 'x' + setInput i3 + finish_char_tok loc c + _other -> do -- We've seen 'x not followed by quote + -- (including the possibility of EOF) + -- If TH is on, just parse the quote only + th_exts <- extension thEnabled + let (AI end _) = i1 + if th_exts then return (L (mkRealSrcSpan loc end) ITvarQuote) + else lit_error i2 + +finish_char_tok :: RealSrcLoc -> Char -> P (RealLocated Token) +finish_char_tok loc ch -- We've already seen the closing quote + -- Just need to check for trailing # + = do magicHash <- extension magicHashEnabled + i@(AI end _) <- getInput + if magicHash then do + case alexGetChar' i of + Just ('#',i@(AI end _)) -> do + setInput i + return (L (mkRealSrcSpan loc end) (ITprimchar ch)) + _other -> + return (L (mkRealSrcSpan loc end) (ITchar ch)) + else do + return (L (mkRealSrcSpan loc end) (ITchar ch)) isAny :: Char -> Bool isAny c | c > '\x7f' = isPrint c - | otherwise = is_any c + | otherwise = is_any c lex_escape :: P Char lex_escape = do i0 <- getInput c <- getCharOrFail i0 case c of - 'a' -> return '\a' - 'b' -> return '\b' - 'f' -> return '\f' - 'n' -> return '\n' - 'r' -> return '\r' - 't' -> return '\t' - 'v' -> return '\v' - '\\' -> return '\\' - '"' -> return '\"' - '\'' -> return '\'' - '^' -> do i1 <- getInput + 'a' -> return '\a' + 'b' -> return '\b' + 'f' -> return '\f' + 'n' -> return '\n' + 'r' -> return '\r' + 't' -> return '\t' + 'v' -> return '\v' + '\\' -> return '\\' + '"' -> return '\"' + '\'' -> return '\'' + '^' -> do i1 <- getInput c <- getCharOrFail i1 - if c >= '@' && c <= '_' - then return (chr (ord c - ord '@')) - else lit_error i1 - - 'x' -> readNum is_hexdigit 16 hexDigit - 'o' -> readNum is_octdigit 8 octDecDigit - x | is_decdigit x -> readNum2 is_decdigit 10 octDecDigit (octDecDigit x) - - c1 -> do - i <- getInput - case alexGetChar' i of - Nothing -> lit_error i0 - Just (c2,i2) -> + if c >= '@' && c <= '_' + then return (chr (ord c - ord '@')) + else lit_error i1 + + 'x' -> readNum is_hexdigit 16 hexDigit + 'o' -> readNum is_octdigit 8 octDecDigit + x | is_decdigit x -> readNum2 is_decdigit 10 octDecDigit (octDecDigit x) + + c1 -> do + i <- getInput + case alexGetChar' i of + Nothing -> lit_error i0 + Just (c2,i2) -> case alexGetChar' i2 of - Nothing -> do lit_error i0 - Just (c3,i3) -> - let str = [c1,c2,c3] in - case [ (c,rest) | (p,c) <- silly_escape_chars, - Just rest <- [stripPrefix p str] ] of - (escape_char,[]):_ -> do - setInput i3 - return escape_char - (escape_char,_:_):_ -> do - setInput i2 - return escape_char - [] -> lit_error i0 + Nothing -> do lit_error i0 + Just (c3,i3) -> + let str = [c1,c2,c3] in + case [ (c,rest) | (p,c) <- silly_escape_chars, + Just rest <- [stripPrefix p str] ] of + (escape_char,[]):_ -> do + setInput i3 + return escape_char + (escape_char,_:_):_ -> do + setInput i2 + return escape_char + [] -> lit_error i0 readNum :: (Char -> Bool) -> Int -> (Char -> Int) -> P Char readNum is_digit base conv = do i <- getInput c <- getCharOrFail i - if is_digit c - then readNum2 is_digit base conv (conv c) - else lit_error i + if is_digit c + then readNum2 is_digit base conv (conv c) + else lit_error i readNum2 :: (Char -> Bool) -> Int -> (Char -> Int) -> Int -> P Char readNum2 is_digit base conv i = do input <- getInput read i input where read i input = do - case alexGetChar' input of - Just (c,input') | is_digit c -> do + case alexGetChar' input of + Just (c,input') | is_digit c -> do let i' = i*base + conv c if i' > 0x10ffff then setInput input >> lexError "numeric escape sequence out of range" else read i' input' - _other -> do + _other -> do setInput input; return (chr i) silly_escape_chars :: [(String, Char)] silly_escape_chars = [ - ("NUL", '\NUL'), - ("SOH", '\SOH'), - ("STX", '\STX'), - ("ETX", '\ETX'), - ("EOT", '\EOT'), - ("ENQ", '\ENQ'), - ("ACK", '\ACK'), - ("BEL", '\BEL'), - ("BS", '\BS'), - ("HT", '\HT'), - ("LF", '\LF'), - ("VT", '\VT'), - ("FF", '\FF'), - ("CR", '\CR'), - ("SO", '\SO'), - ("SI", '\SI'), - ("DLE", '\DLE'), - ("DC1", '\DC1'), - ("DC2", '\DC2'), - ("DC3", '\DC3'), - ("DC4", '\DC4'), - ("NAK", '\NAK'), - ("SYN", '\SYN'), - ("ETB", '\ETB'), - ("CAN", '\CAN'), - ("EM", '\EM'), - ("SUB", '\SUB'), - ("ESC", '\ESC'), - ("FS", '\FS'), - ("GS", '\GS'), - ("RS", '\RS'), - ("US", '\US'), - ("SP", '\SP'), - ("DEL", '\DEL') - ] + ("NUL", '\NUL'), + ("SOH", '\SOH'), + ("STX", '\STX'), + ("ETX", '\ETX'), + ("EOT", '\EOT'), + ("ENQ", '\ENQ'), + ("ACK", '\ACK'), + ("BEL", '\BEL'), + ("BS", '\BS'), + ("HT", '\HT'), + ("LF", '\LF'), + ("VT", '\VT'), + ("FF", '\FF'), + ("CR", '\CR'), + ("SO", '\SO'), + ("SI", '\SI'), + ("DLE", '\DLE'), + ("DC1", '\DC1'), + ("DC2", '\DC2'), + ("DC3", '\DC3'), + ("DC4", '\DC4'), + ("NAK", '\NAK'), + ("SYN", '\SYN'), + ("ETB", '\ETB'), + ("CAN", '\CAN'), + ("EM", '\EM'), + ("SUB", '\SUB'), + ("ESC", '\ESC'), + ("FS", '\FS'), + ("GS", '\GS'), + ("RS", '\RS'), + ("US", '\US'), + ("SP", '\SP'), + ("DEL", '\DEL') + ] -- before calling lit_error, ensure that the current input is pointing to -- the position of the error in the buffer. This is so that we can report @@ -1409,8 +1402,8 @@ getCharOrFail :: AlexInput -> P Char getCharOrFail i = do case alexGetChar' i of - Nothing -> lexError "unexpected end-of-file in string/character literal" - Just (c,i) -> do setInput i; return c + Nothing -> lexError "unexpected end-of-file in string/character literal" + Just (c,i) -> do setInput i; return c -- ----------------------------------------------------------------------------- -- QuasiQuote @@ -1418,15 +1411,15 @@ lex_quasiquote_tok :: Action lex_quasiquote_tok span buf len = do let quoter = tail (lexemeToString buf (len - 1)) - -- 'tail' drops the initial '[', - -- while the -1 drops the trailing '|' - quoteStart <- getSrcLoc + -- 'tail' drops the initial '[', + -- while the -1 drops the trailing '|' + quoteStart <- getSrcLoc quote <- lex_quasiquote "" - end <- getSrcLoc - return (L (mkSrcSpan (srcSpanStart span) end) + end <- getSrcLoc + return (L (mkRealSrcSpan (realSrcSpanStart span) end) (ITquasiQuote (mkFastString quoter, mkFastString (reverse quote), - mkSrcSpan quoteStart end))) + mkRealSrcSpan quoteStart end))) lex_quasiquote :: String -> P String lex_quasiquote s = do @@ -1435,31 +1428,31 @@ Nothing -> lit_error i Just ('\\',i) - | Just ('|',i) <- next -> do - setInput i; lex_quasiquote ('|' : s) - | Just (']',i) <- next -> do - setInput i; lex_quasiquote (']' : s) - where next = alexGetChar' i + | Just ('|',i) <- next -> do + setInput i; lex_quasiquote ('|' : s) + | Just (']',i) <- next -> do + setInput i; lex_quasiquote (']' : s) + where next = alexGetChar' i Just ('|',i) - | Just (']',i) <- next -> do - setInput i; return s - where next = alexGetChar' i + | Just (']',i) <- next -> do + setInput i; return s + where next = alexGetChar' i Just (c, i) -> do - setInput i; lex_quasiquote (c : s) + setInput i; lex_quasiquote (c : s) -- ----------------------------------------------------------------------------- -- Warnings -warn :: DynFlag -> SDoc -> Action +warn :: WarningFlag -> SDoc -> Action warn option warning srcspan _buf _len = do - addWarning option srcspan warning + addWarning option (RealSrcSpan srcspan) warning lexToken -warnThen :: DynFlag -> SDoc -> Action -> Action +warnThen :: WarningFlag -> SDoc -> Action -> Action warnThen option warning action srcspan buf len = do - addWarning option srcspan warning + addWarning option (RealSrcSpan srcspan) warning action srcspan buf len -- ----------------------------------------------------------------------------- @@ -1472,32 +1465,33 @@ data ParseResult a = POk PState a - | PFailed - SrcSpan -- The start and end of the text span related to - -- the error. Might be used in environments which can - -- show this span, e.g. by highlighting it. - Message -- The error message + | PFailed + SrcSpan -- The start and end of the text span related to + -- the error. Might be used in environments which can + -- show this span, e.g. by highlighting it. + Message -- The error message -data PState = PState { - buffer :: StringBuffer, +data PState = PState { + buffer :: StringBuffer, dflags :: DynFlags, messages :: Messages, - last_loc :: SrcSpan, -- pos of previous token - last_len :: !Int, -- len of previous token - loc :: SrcLoc, -- current loc (end of prev token + 1) - extsBitmap :: !Int, -- bitmap that determines permitted extensions - context :: [LayoutContext], - lex_state :: [Int], + last_loc :: RealSrcSpan, -- pos of previous token + last_len :: !Int, -- len of previous token + loc :: RealSrcLoc, -- current loc (end of prev token + 1) + extsBitmap :: !Int, -- bitmap that determines permitted + -- extensions + context :: [LayoutContext], + lex_state :: [Int], -- Used in the alternative layout rule: -- These tokens are the next ones to be sent out. They are -- just blindly emitted, without the rule looking at them again: - alr_pending_implicit_tokens :: [Located Token], + alr_pending_implicit_tokens :: [RealLocated Token], -- This is the next token to be considered or, if it is Nothing, -- we need to get the next token from the input stream: - alr_next_token :: Maybe (Located Token), + alr_next_token :: Maybe (RealLocated Token), -- This is what we consider to be the locatino of the last token -- emitted: - alr_last_loc :: SrcSpan, + alr_last_loc :: RealSrcSpan, -- The stack of layout contexts: alr_context :: [ALRContext], -- Are we expecting a '{'? If it's Just, then the ALRLayout tells @@ -1507,11 +1501,11 @@ -- token doesn't need to close anything: alr_justClosedExplicitLetBlock :: Bool } - -- last_loc and last_len are used when generating error messages, - -- and in pushCurrentContext only. Sigh, if only Happy passed the - -- current token to happyError, we could at least get rid of last_len. - -- Getting rid of last_loc would require finding another way to - -- implement pushCurrentContext (which is only called from one place). + -- last_loc and last_len are used when generating error messages, + -- and in pushCurrentContext only. Sigh, if only Happy passed the + -- current token to happyError, we could at least get rid of last_len. + -- Getting rid of last_loc would require finding another way to + -- implement pushCurrentContext (which is only called from one place). data ALRContext = ALRNoLayout Bool{- does it contain commas? -} Bool{- is it a 'let' block? -} @@ -1533,18 +1527,18 @@ thenP :: P a -> (a -> P b) -> P b (P m) `thenP` k = P $ \ s -> - case m s of - POk s1 a -> (unP (k a)) s1 - PFailed span err -> PFailed span err + case m s of + POk s1 a -> (unP (k a)) s1 + PFailed span err -> PFailed span err failP :: String -> P a -failP msg = P $ \s -> PFailed (last_loc s) (text msg) +failP msg = P $ \s -> PFailed (RealSrcSpan (last_loc s)) (text msg) failMsgP :: String -> P a -failMsgP msg = P $ \s -> PFailed (last_loc s) (text msg) +failMsgP msg = P $ \s -> PFailed (RealSrcSpan (last_loc s)) (text msg) -failLocMsgP :: SrcLoc -> SrcLoc -> String -> P a -failLocMsgP loc1 loc2 str = P $ \_ -> PFailed (mkSrcSpan loc1 loc2) (text str) +failLocMsgP :: RealSrcLoc -> RealSrcLoc -> String -> P a +failLocMsgP loc1 loc2 str = P $ \_ -> PFailed (RealSrcSpan (mkRealSrcSpan loc1 loc2)) (text str) failSpanMsgP :: SrcSpan -> SDoc -> P a failSpanMsgP span msg = P $ \_ -> PFailed span msg @@ -1557,8 +1551,8 @@ withThisPackage :: (PackageId -> a) -> P a withThisPackage f - = do pkg <- liftM thisPackage getDynFlags - return $ f pkg + = do pkg <- liftM thisPackage getDynFlags + return $ f pkg extension :: (Int -> Bool) -> P Bool extension p = P $ \s -> POk s (p $! extsBitmap s) @@ -1569,81 +1563,81 @@ setExts :: (Int -> Int) -> P () setExts f = P $ \s -> POk s{ extsBitmap = f (extsBitmap s) } () -setSrcLoc :: SrcLoc -> P () +setSrcLoc :: RealSrcLoc -> P () setSrcLoc new_loc = P $ \s -> POk s{loc=new_loc} () -getSrcLoc :: P SrcLoc +getSrcLoc :: P RealSrcLoc getSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s loc -setLastToken :: SrcSpan -> Int -> P () -setLastToken loc len = P $ \s -> POk s { - last_loc=loc, +setLastToken :: RealSrcSpan -> Int -> P () +setLastToken loc len = P $ \s -> POk s { + last_loc=loc, last_len=len } () -data AlexInput = AI SrcLoc StringBuffer +data AlexInput = AI RealSrcLoc StringBuffer alexInputPrevChar :: AlexInput -> Char alexInputPrevChar (AI _ buf) = prevChar buf '\n' alexGetChar :: AlexInput -> Maybe (Char,AlexInput) -alexGetChar (AI loc s) +alexGetChar (AI loc s) | atEnd s = Nothing - | otherwise = adj_c `seq` loc' `seq` s' `seq` - --trace (show (ord c)) $ - Just (adj_c, (AI loc' s')) + | otherwise = adj_c `seq` loc' `seq` s' `seq` + --trace (show (ord c)) $ + Just (adj_c, (AI loc' s')) where (c,s') = nextChar s loc' = advanceSrcLoc loc c - non_graphic = '\x0' - upper = '\x1' - lower = '\x2' - digit = '\x3' - symbol = '\x4' - space = '\x5' - other_graphic = '\x6' - - adj_c - | c <= '\x06' = non_graphic - | c <= '\x7f' = c + non_graphic = '\x0' + upper = '\x1' + lower = '\x2' + digit = '\x3' + symbol = '\x4' + space = '\x5' + other_graphic = '\x6' + + adj_c + | c <= '\x06' = non_graphic + | c <= '\x7f' = c -- Alex doesn't handle Unicode, so when Unicode -- character is encountered we output these values -- with the actual character value hidden in the state. - | otherwise = - case generalCategory c of - UppercaseLetter -> upper - LowercaseLetter -> lower - TitlecaseLetter -> upper - ModifierLetter -> other_graphic - OtherLetter -> lower -- see #1103 - NonSpacingMark -> other_graphic - SpacingCombiningMark -> other_graphic - EnclosingMark -> other_graphic - DecimalNumber -> digit - LetterNumber -> other_graphic - OtherNumber -> other_graphic - ConnectorPunctuation -> symbol - DashPunctuation -> symbol - OpenPunctuation -> other_graphic - ClosePunctuation -> other_graphic - InitialQuote -> other_graphic - FinalQuote -> other_graphic - OtherPunctuation -> symbol - MathSymbol -> symbol - CurrencySymbol -> symbol - ModifierSymbol -> symbol - OtherSymbol -> symbol - Space -> space - _other -> non_graphic + | otherwise = + case generalCategory c of + UppercaseLetter -> upper + LowercaseLetter -> lower + TitlecaseLetter -> upper + ModifierLetter -> other_graphic + OtherLetter -> lower -- see #1103 + NonSpacingMark -> other_graphic + SpacingCombiningMark -> other_graphic + EnclosingMark -> other_graphic + DecimalNumber -> digit + LetterNumber -> other_graphic + OtherNumber -> digit -- see #4373 + ConnectorPunctuation -> symbol + DashPunctuation -> symbol + OpenPunctuation -> other_graphic + ClosePunctuation -> other_graphic + InitialQuote -> other_graphic + FinalQuote -> other_graphic + OtherPunctuation -> symbol + MathSymbol -> symbol + CurrencySymbol -> symbol + ModifierSymbol -> symbol + OtherSymbol -> symbol + Space -> space + _other -> non_graphic -- This version does not squash unicode characters, it is used when -- lexing strings. alexGetChar' :: AlexInput -> Maybe (Char,AlexInput) -alexGetChar' (AI loc s) +alexGetChar' (AI loc s) | atEnd s = Nothing - | otherwise = c `seq` loc' `seq` s' `seq` - --trace (show (ord c)) $ - Just (c, (AI loc' s')) + | otherwise = c `seq` loc' `seq` s' `seq` + --trace (show (ord c)) $ + Just (c, (AI loc' s')) where (c,s') = nextChar s loc' = advanceSrcLoc loc c @@ -1653,6 +1647,11 @@ setInput :: AlexInput -> P () setInput (AI l b) = P $ \s -> POk s{ loc=l, buffer=b } () +nextIsEOF :: P Bool +nextIsEOF = do + AI _ s <- getInput + return $ atEnd s + pushLexState :: Int -> P () pushLexState ls = P $ \s@PState{ lex_state=l } -> POk s{lex_state=ls:l} () @@ -1662,15 +1661,24 @@ getLexState :: P Int getLexState = P $ \s@PState{ lex_state=ls:_ } -> POk s ls -popNextToken :: P (Maybe (Located Token)) +popNextToken :: P (Maybe (RealLocated Token)) popNextToken = P $ \s@PState{ alr_next_token = m } -> POk (s {alr_next_token = Nothing}) m -setAlrLastLoc :: SrcSpan -> P () +activeContext :: P Bool +activeContext = do + ctxt <- getALRContext + expc <- getAlrExpectingOCurly + impt <- implicitTokenPending + case (ctxt,expc) of + ([],Nothing) -> return impt + _other -> return True + +setAlrLastLoc :: RealSrcSpan -> P () setAlrLastLoc l = P $ \s -> POk (s {alr_last_loc = l}) () -getAlrLastLoc :: P SrcSpan +getAlrLastLoc :: P RealSrcSpan getAlrLastLoc = P $ \s@(PState {alr_last_loc = l}) -> POk s l getALRContext :: P [ALRContext] @@ -1687,17 +1695,24 @@ setJustClosedExplicitLetBlock b = P $ \s -> POk (s {alr_justClosedExplicitLetBlock = b}) () -setNextToken :: Located Token -> P () +setNextToken :: RealLocated Token -> P () setNextToken t = P $ \s -> POk (s {alr_next_token = Just t}) () -popPendingImplicitToken :: P (Maybe (Located Token)) +implicitTokenPending :: P Bool +implicitTokenPending + = P $ \s@PState{ alr_pending_implicit_tokens = ts } -> + case ts of + [] -> POk s False + _ -> POk s True + +popPendingImplicitToken :: P (Maybe (RealLocated Token)) popPendingImplicitToken = P $ \s@PState{ alr_pending_implicit_tokens = ts } -> case ts of [] -> POk s Nothing (t : ts') -> POk (s {alr_pending_implicit_tokens = ts'}) (Just t) -setPendingImplicitTokens :: [Located Token] -> P () +setPendingImplicitTokens :: [RealLocated Token] -> P () setPendingImplicitTokens ts = P $ \s -> POk (s {alr_pending_implicit_tokens = ts}) () getAlrExpectingOCurly :: P (Maybe ALRLayout) @@ -1707,28 +1722,28 @@ setAlrExpectingOCurly b = P $ \s -> POk (s {alr_expecting_ocurly = b}) () -- for reasons of efficiency, flags indicating language extensions (eg, --- -fglasgow-exts or -XParr) are represented by a bitmap stored in an unboxed --- integer +-- -fglasgow-exts or -XParallelArrays) are represented by a bitmap +-- stored in an unboxed Int -genericsBit :: Int -genericsBit = 0 -- {| and |} ffiBit :: Int -ffiBit = 1 +ffiBit= 0 +interruptibleFfiBit :: Int +interruptibleFfiBit = 1 parrBit :: Int -parrBit = 2 +parrBit = 3 arrowsBit :: Int arrowsBit = 4 thBit :: Int -thBit = 5 +thBit = 5 ipBit :: Int -ipBit = 6 +ipBit = 6 explicitForallBit :: Int explicitForallBit = 7 -- the 'forall' keyword and '.' symbol bangPatBit :: Int -bangPatBit = 8 -- Tells the parser to understand bang-patterns - -- (doesn't affect the lexer) +bangPatBit = 8 -- Tells the parser to understand bang-patterns + -- (doesn't affect the lexer) tyFamBit :: Int -tyFamBit = 9 -- indexed type families: 'family' keyword and kind sigs +tyFamBit = 9 -- indexed type families: 'family' keyword and kind sigs haddockBit :: Int haddockBit = 10 -- Lex and parse Haddock comments magicHashBit :: Int @@ -1746,22 +1761,24 @@ transformComprehensionsBit :: Int transformComprehensionsBit = 17 qqBit :: Int -qqBit = 18 -- enable quasiquoting +qqBit = 18 -- enable quasiquoting inRulePragBit :: Int inRulePragBit = 19 rawTokenStreamBit :: Int rawTokenStreamBit = 20 -- producing a token stream with all comments included -newQualOpsBit :: Int -newQualOpsBit = 21 -- Haskell' qualified operator syntax, e.g. Prelude.(+) recBit :: Int recBit = 22 -- rec alternativeLayoutRuleBit :: Int alternativeLayoutRuleBit = 23 +relaxedLayoutBit :: Int +relaxedLayoutBit = 24 +nondecreasingIndentationBit :: Int +nondecreasingIndentationBit = 25 +safeHaskellBit :: Int +safeHaskellBit = 26 always :: Int -> Bool always _ = True -genericsEnabled :: Int -> Bool -genericsEnabled flags = testBit flags genericsBit parrEnabled :: Int -> Bool parrEnabled flags = testBit flags parrBit arrowsEnabled :: Int -> Bool @@ -1794,29 +1811,29 @@ -- inRulePrag flags = testBit flags inRulePragBit rawTokenStreamEnabled :: Int -> Bool rawTokenStreamEnabled flags = testBit flags rawTokenStreamBit -newQualOps :: Int -> Bool -newQualOps flags = testBit flags newQualOpsBit -oldQualOps :: Int -> Bool -oldQualOps flags = not (newQualOps flags) alternativeLayoutRule :: Int -> Bool alternativeLayoutRule flags = testBit flags alternativeLayoutRuleBit +relaxedLayout :: Int -> Bool +relaxedLayout flags = testBit flags relaxedLayoutBit +nondecreasingIndentation :: Int -> Bool +nondecreasingIndentation flags = testBit flags nondecreasingIndentationBit -- PState for parsing options pragmas -- -pragState :: DynFlags -> StringBuffer -> SrcLoc -> PState +pragState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState pragState dynflags buf loc = (mkPState dynflags buf loc) { lex_state = [bol, option_prags, 0] } -- create a parse state -- -mkPState :: DynFlags -> StringBuffer -> SrcLoc -> PState +mkPState :: DynFlags -> StringBuffer -> RealSrcLoc -> PState mkPState flags buf loc = PState { - buffer = buf, + buffer = buf, dflags = flags, messages = emptyMessages, - last_loc = mkSrcSpan loc loc, + last_loc = mkRealSrcSpan loc loc, last_len = 0, loc = loc, extsBitmap = fromIntegral bitmap, @@ -1824,45 +1841,48 @@ lex_state = [bol, 0], alr_pending_implicit_tokens = [], alr_next_token = Nothing, - alr_last_loc = noSrcSpan, + alr_last_loc = alrInitialLoc (fsLit ""), alr_context = [], alr_expecting_ocurly = Nothing, alr_justClosedExplicitLetBlock = False } where - bitmap = genericsBit `setBitIf` xopt Opt_Generics flags - .|. ffiBit `setBitIf` xopt Opt_ForeignFunctionInterface flags - .|. parrBit `setBitIf` xopt Opt_PArr flags - .|. arrowsBit `setBitIf` xopt Opt_Arrows flags - .|. thBit `setBitIf` xopt Opt_TemplateHaskell flags - .|. qqBit `setBitIf` xopt Opt_QuasiQuotes flags - .|. ipBit `setBitIf` xopt Opt_ImplicitParams flags - .|. explicitForallBit `setBitIf` xopt Opt_ExplicitForAll flags - .|. bangPatBit `setBitIf` xopt Opt_BangPatterns flags - .|. tyFamBit `setBitIf` xopt Opt_TypeFamilies flags - .|. haddockBit `setBitIf` dopt Opt_Haddock flags - .|. magicHashBit `setBitIf` xopt Opt_MagicHash flags - .|. kindSigsBit `setBitIf` xopt Opt_KindSignatures flags - .|. recursiveDoBit `setBitIf` xopt Opt_RecursiveDo flags - .|. recBit `setBitIf` xopt Opt_DoRec flags - .|. recBit `setBitIf` xopt Opt_Arrows flags - .|. unicodeSyntaxBit `setBitIf` xopt Opt_UnicodeSyntax flags - .|. unboxedTuplesBit `setBitIf` xopt Opt_UnboxedTuples flags - .|. datatypeContextsBit `setBitIf` xopt Opt_DatatypeContexts flags - .|. transformComprehensionsBit `setBitIf` xopt Opt_TransformListComp flags - .|. rawTokenStreamBit `setBitIf` dopt Opt_KeepRawTokenStream flags - .|. newQualOpsBit `setBitIf` xopt Opt_NewQualifiedOperators flags - .|. alternativeLayoutRuleBit `setBitIf` xopt Opt_AlternativeLayoutRule flags + bitmap = ffiBit `setBitIf` xopt Opt_ForeignFunctionInterface flags + .|. interruptibleFfiBit `setBitIf` xopt Opt_InterruptibleFFI 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 + .|. nondecreasingIndentationBit `setBitIf` xopt Opt_NondecreasingIndentation flags + .|. safeHaskellBit `setBitIf` safeHaskellOn flags -- setBitIf :: Int -> Bool -> Int b `setBitIf` cond | cond = bit b - | otherwise = 0 + | otherwise = 0 -addWarning :: DynFlag -> SrcSpan -> SDoc -> P () +addWarning :: WarningFlag -> SrcSpan -> SDoc -> P () addWarning option srcspan warning = P $ \s@PState{messages=(ws,es), dflags=d} -> let warning' = mkWarnMsg srcspan alwaysQualify warning - ws' = if dopt option d then ws `snocBag` warning' else ws + ws' = if wopt option d then ws `snocBag` warning' else ws in POk s{messages=(ws', es)} () getMessages :: PState -> Messages @@ -1875,40 +1895,40 @@ setContext ctx = P $ \s -> POk s{context=ctx} () popContext :: P () -popContext = P $ \ s@(PState{ buffer = buf, context = ctx, +popContext = P $ \ s@(PState{ buffer = buf, context = ctx, last_len = len, last_loc = last_loc }) -> case ctx of - (_:tl) -> POk s{ context = tl } () - [] -> PFailed last_loc (srcParseErr buf len) + (_:tl) -> POk s{ context = tl } () + [] -> PFailed (RealSrcSpan last_loc) (srcParseErr buf len) -- Push a new layout context at the indentation of the last token read. -- This is only used at the outer level of a module when the 'module' -- keyword is missing. pushCurrentContext :: P () -pushCurrentContext = P $ \ s@PState{ last_loc=loc, context=ctx } -> +pushCurrentContext = P $ \ s@PState{ last_loc=loc, context=ctx } -> POk s{context = Layout (srcSpanStartCol loc) : ctx} () getOffside :: P Ordering getOffside = P $ \s@PState{last_loc=loc, context=stk} -> let offs = srcSpanStartCol loc in - let ord = case stk of - (Layout n:_) -> --trace ("layout: " ++ show n ++ ", offs: " ++ show offs) $ + let ord = case stk of + (Layout n:_) -> --trace ("layout: " ++ show n ++ ", offs: " ++ show offs) $ compare offs n - _ -> GT - in POk s ord + _ -> GT + in POk s ord -- --------------------------------------------------------------------------- -- Construct a parse error srcParseErr - :: StringBuffer -- current buffer (placed just after the last token) - -> Int -- length of the previous token + :: StringBuffer -- current buffer (placed just after the last token) + -> Int -- length of the previous token -> Message srcParseErr buf len - = hcat [ if null token - then ptext (sLit "parse error (possibly incorrect indentation)") - else hcat [ptext (sLit "parse error on input "), - char '`', text token, char '\''] + = hcat [ if null token + then ptext (sLit "parse error (possibly incorrect indentation)") + else hcat [ptext (sLit "parse error on input "), + char '`', text token, char '\''] ] where token = lexemeToString (offsetBytes (-len) buf) len @@ -1916,9 +1936,9 @@ -- the location of the error. This is the entry point for errors -- detected during parsing. srcParseFail :: P a -srcParseFail = P $ \PState{ buffer = buf, last_len = len, - last_loc = last_loc } -> - PFailed last_loc (srcParseErr buf len) +srcParseFail = P $ \PState{ buffer = buf, last_len = len, + last_loc = last_loc } -> + PFailed (RealSrcSpan last_loc) (srcParseErr buf len) -- A lexical error is reported at a particular position in the source file, -- not over a token range. @@ -1936,11 +1956,11 @@ lexer cont = do alr <- extension alternativeLayoutRule let lexTokenFun = if alr then lexTokenAlr else lexToken - tok@(L _span _tok__) <- lexTokenFun - --trace ("token: " ++ show _tok__) $ do - cont tok + (L span tok) <- lexTokenFun + --trace ("token: " ++ show tok) $ do + cont (L (RealSrcSpan span) tok) -lexTokenAlr :: P (Located Token) +lexTokenAlr :: P (RealLocated Token) lexTokenAlr = do mPending <- popPendingImplicitToken t <- case mPending of Nothing -> @@ -1962,7 +1982,7 @@ _ -> return () return t -alternativeLayoutRuleToken :: Located Token -> P (Located Token) +alternativeLayoutRuleToken :: RealLocated Token -> P (RealLocated Token) alternativeLayoutRuleToken t = do context <- getALRContext lastLoc <- getAlrLastLoc @@ -1973,8 +1993,7 @@ let transitional = xopt Opt_AlternativeLayoutRuleTransitional dflags thisLoc = getLoc t thisCol = srcSpanStartCol thisLoc - newLine = (lastLoc == noSrcSpan) - || (srcSpanStartLine thisLoc > srcSpanEndLine lastLoc) + newLine = srcSpanStartLine thisLoc > srcSpanEndLine lastLoc case (unLoc t, context, mExpectingOCurly) of -- This case handles a GHC extension to the original H98 -- layout rule... @@ -2034,7 +2053,7 @@ (ITwhere, ALRLayout _ col : ls, _) | newLine && thisCol == col && transitional -> do addWarning Opt_WarnAlternativeLayoutRuleTransitional - thisLoc + (RealSrcSpan thisLoc) (transitionalAlternativeLayoutWarning "`where' clause at the same depth as implicit layout block") setALRContext ls @@ -2046,7 +2065,7 @@ (ITvbar, ALRLayout _ col : ls, _) | newLine && thisCol == col && transitional -> do addWarning Opt_WarnAlternativeLayoutRuleTransitional - thisLoc + (RealSrcSpan thisLoc) (transitionalAlternativeLayoutWarning "`|' at the same depth as implicit layout block") setALRContext ls @@ -2161,14 +2180,14 @@ topNoLayoutContainsCommas (ALRLayout _ _ : ls) = topNoLayoutContainsCommas ls topNoLayoutContainsCommas (ALRNoLayout b _ : _) = b -lexToken :: P (Located Token) +lexToken :: P (RealLocated Token) lexToken = do inp@(AI loc1 buf) <- getInput sc <- getLexState exts <- getExts case alexScanUser exts inp sc of AlexEOF -> do - let span = mkSrcSpan loc1 loc1 + let span = mkRealSrcSpan loc1 loc1 setLastToken span 0 return (L span ITeof) AlexError (AI loc2 buf) -> @@ -2178,23 +2197,21 @@ lexToken AlexToken inp2@(AI end buf2) _ t -> do setInput inp2 - let span = mkSrcSpan loc1 end + let span = mkRealSrcSpan loc1 end let bytes = byteDiff buf buf2 span `seq` setLastToken span bytes t span buf bytes -reportLexError :: SrcLoc -> SrcLoc -> StringBuffer -> [Char] -> P a +reportLexError :: RealSrcLoc -> RealSrcLoc -> StringBuffer -> [Char] -> P a reportLexError loc1 loc2 buf str | atEnd buf = failLocMsgP loc1 loc2 (str ++ " at end of input") | otherwise = - let - c = fst (nextChar buf) - in - if c == '\0' -- decoding errors are mapped to '\0', see utf8DecodeChar# - then failLocMsgP loc2 loc2 (str ++ " (UTF-8 decoding error)") - else failLocMsgP loc1 loc2 (str ++ " at character " ++ show c) + let c = fst (nextChar buf) + in if c == '\0' -- decoding errors are mapped to '\0', see utf8DecodeChar# + then failLocMsgP loc2 loc2 (str ++ " (UTF-8 decoding error)") + else failLocMsgP loc1 loc2 (str ++ " at character " ++ show c) -lexTokenStream :: StringBuffer -> SrcLoc -> DynFlags -> ParseResult [Located Token] +lexTokenStream :: StringBuffer -> RealSrcLoc -> DynFlags -> ParseResult [Located Token] lexTokenStream buf loc dflags = unP go initState where dflags' = dopt_set (dopt_unset dflags Opt_Haddock) Opt_KeepRawTokenStream initState = mkPState dflags' buf loc @@ -2223,7 +2240,7 @@ ("inline", token (ITinline_prag Inline FunLike)), ("inlinable", token (ITinline_prag Inlinable FunLike)), ("inlineable", token (ITinline_prag Inlinable FunLike)), - -- Spelling variant + -- Spelling variant ("notinline", token (ITinline_prag NoInline FunLike)), ("specialize", token ITspec_prag), ("source", token ITsource_prag), @@ -2233,13 +2250,15 @@ ("generated", token ITgenerated_prag), ("core", token ITcore_prag), ("unpack", token ITunpack_prag), - ("ann", token ITann_prag)]) + ("ann", token ITann_prag), + ("vectorize", token ITvect_prag), + ("novectorize", token ITnovect_prag)]) twoWordPrags = Map.fromList([("inline conlike", token (ITinline_prag Inline ConLike)), ("notinline conlike", token (ITinline_prag NoInline ConLike)), ("specialize inline", token (ITspec_inline_prag True)), - ("specialize notinline", token (ITspec_inline_prag False))]) - + ("specialize notinline", token (ITspec_inline_prag False)), + ("vectorize scalar", token ITvect_scalar_prag)]) dispatch_pragmas :: Map String Action -> Action dispatch_pragmas prags span buf len = case Map.lookup (clean_pragma (lexemeToString buf len)) prags of @@ -2258,6 +2277,8 @@ canonical prag' = case prag' of "noinline" -> "notinline" "specialise" -> "specialize" + "vectorise" -> "vectorize" + "novectorise" -> "novectorize" "constructorlike" -> "conlike" _ -> prag' canon_ws s = unwords (map canonical (words s)) diff -Nru ghc-7.0.3/compiler/parser/ParserCore.hs ghc-7.2.1/compiler/parser/ParserCore.hs --- ghc-7.0.3/compiler/parser/ParserCore.hs 2011-03-26 20:51:08.000000000 +0000 +++ ghc-7.2.1/compiler/parser/ParserCore.hs 2011-08-07 20:09:18.000000000 +0000 @@ -1,14 +1,7 @@ {-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} {-# OPTIONS -fglasgow-exts -cpp #-} -{-# OPTIONS -Wwarn -w -XNoMonomorphismRestriction #-} --- The NoMonomorphismRestriction deals with a Happy infelicity --- With OutsideIn's more conservativ monomorphism restriction --- we aren't generalising --- notHappyAtAll = error "urk" --- which is terrible. Switching off the restriction allows --- the generalisation. Better would be to make Happy generate --- an appropriate signature. --- +{-# LANGUAGE BangPatterns #-} -- required for versions of Happy before 1.18.6 +{-# OPTIONS -Wwarn -w #-} -- 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 @@ -1017,13 +1010,12 @@ happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) - = case happyOut21 happy_x_3 of { happy_var_3 -> - case happyOut33 happy_x_5 of { happy_var_5 -> + = case happyOut33 happy_x_5 of { happy_var_5 -> case happyOut28 happy_x_7 of { happy_var_7 -> case happyOut36 happy_x_9 of { happy_var_9 -> happyIn35 - (IfaceCase happy_var_5 (fst happy_var_7) happy_var_3 happy_var_9 - ) `HappyStk` happyRest}}}} + (IfaceCase happy_var_5 (fst happy_var_7) happy_var_9 + ) `HappyStk` happyRest}}} happyReduce_71 = happySpecReduce_3 31# happyReduction_71 happyReduction_71 happy_x_3 @@ -1044,7 +1036,7 @@ happyIn35 (IfaceFCall (ForeignCall.CCall (CCallSpec (StaticTarget (mkFastString happy_var_2) Nothing) - CCallConv (PlaySafe False))) + CCallConv PlaySafe)) happy_var_3 )}} diff -Nru ghc-7.0.3/compiler/parser/ParserCoreUtils.hs ghc-7.2.1/compiler/parser/ParserCoreUtils.hs --- ghc-7.0.3/compiler/parser/ParserCoreUtils.hs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/parser/ParserCoreUtils.hs 2011-08-07 17:10:05.000000000 +0000 @@ -1,5 +1,6 @@ module ParserCoreUtils where +import Exception import System.IO data ParseResult a = OkP a | FailP String @@ -19,7 +20,7 @@ getCoreModuleName :: FilePath -> IO String getCoreModuleName fpath = - catch (do + catchIO (do h <- openFile fpath ReadMode ls <- hGetContents h let mo = findMod (words ls) diff -Nru ghc-7.0.3/compiler/parser/ParserCore.y.source ghc-7.2.1/compiler/parser/ParserCore.y.source --- ghc-7.0.3/compiler/parser/ParserCore.y.source 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/parser/ParserCore.y.source 2011-08-07 17:10:05.000000000 +0000 @@ -1,13 +1,6 @@ { -{-# OPTIONS -Wwarn -w -XNoMonomorphismRestriction #-} --- The NoMonomorphismRestriction deals with a Happy infelicity --- With OutsideIn's more conservativ monomorphism restriction --- we aren't generalising --- notHappyAtAll = error "urk" --- which is terrible. Switching off the restriction allows --- the generalisation. Better would be to make Happy generate --- an appropriate signature. --- +{-# LANGUAGE BangPatterns #-} -- required for versions of Happy before 1.18.6 +{-# OPTIONS -Wwarn -w #-} -- 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 @@ -276,7 +269,7 @@ | '%let' let_bind '%in' exp { IfaceLet $2 $4 } -- gaw 2004 | '%case' '(' ty ')' aexp '%of' id_bndr - '{' alts1 '}' { IfaceCase $5 (fst $7) $3 $9 } + '{' alts1 '}' { IfaceCase $5 (fst $7) $9 } | '%cast' aexp aty { IfaceCast $2 $3 } -- No InlineMe any more -- | '%note' STRING exp @@ -286,7 +279,7 @@ -- } | '%external' STRING aty { IfaceFCall (ForeignCall.CCall (CCallSpec (StaticTarget (mkFastString $2) Nothing) - CCallConv (PlaySafe False))) + CCallConv PlaySafe)) $3 } alts1 :: { [IfaceAlt] } diff -Nru ghc-7.0.3/compiler/parser/Parser.hs ghc-7.2.1/compiler/parser/Parser.hs --- ghc-7.0.3/compiler/parser/Parser.hs 2011-03-26 20:51:08.000000000 +0000 +++ ghc-7.2.1/compiler/parser/Parser.hs 2011-08-07 20:09:18.000000000 +0000 @@ -1,14 +1,7 @@ {-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} {-# OPTIONS -fglasgow-exts -cpp #-} -{-# OPTIONS -Wwarn -w -XNoMonomorphismRestriction #-} --- The NoMonomorphismRestriction deals with a Happy infelicity --- With OutsideIn's more conservativ monomorphism restriction --- we aren't generalising --- notHappyAtAll = error "urk" --- which is terrible. Switching off the restriction allows --- the generalisation. Better would be to make Happy generate --- an appropriate signature. - +{-# LANGUAGE BangPatterns #-} -- required for versions of Happy before 1.18.6 +{-# OPTIONS -Wwarn -w #-} -- 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 @@ -40,9 +33,7 @@ ) import OccName ( varName, dataName, tcClsName, tvName ) import DataCon ( DataCon, dataConName ) -import SrcLoc ( Located(..), unLoc, getLoc, noLoc, combineSrcSpans, - SrcSpan, combineLocs, srcLocFile, - mkSrcLoc, mkSrcSpan ) +import SrcLoc import Module import StaticFlags ( opt_SccProfilingOn, opt_Hpc ) import Type ( Kind, liftedTypeKind, unliftedTypeKind ) @@ -146,16 +137,16 @@ happyOut18 :: (HappyAbsSyn ) -> ([LImportDecl RdrName]) happyOut18 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut18 #-} -happyIn19 :: (Maybe [LIE RdrName]) -> (HappyAbsSyn ) +happyIn19 :: ([LImportDecl RdrName]) -> (HappyAbsSyn ) happyIn19 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn19 #-} -happyOut19 :: (HappyAbsSyn ) -> (Maybe [LIE RdrName]) +happyOut19 :: (HappyAbsSyn ) -> ([LImportDecl RdrName]) happyOut19 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut19 #-} -happyIn20 :: ([LIE RdrName]) -> (HappyAbsSyn ) +happyIn20 :: (Maybe [LIE RdrName]) -> (HappyAbsSyn ) happyIn20 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn20 #-} -happyOut20 :: (HappyAbsSyn ) -> ([LIE RdrName]) +happyOut20 :: (HappyAbsSyn ) -> (Maybe [LIE RdrName]) happyOut20 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut20 #-} happyIn21 :: ([LIE RdrName]) -> (HappyAbsSyn ) @@ -170,10 +161,10 @@ happyOut22 :: (HappyAbsSyn ) -> ([LIE RdrName]) happyOut22 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut22 #-} -happyIn23 :: (LIE RdrName) -> (HappyAbsSyn ) +happyIn23 :: ([LIE RdrName]) -> (HappyAbsSyn ) happyIn23 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn23 #-} -happyOut23 :: (HappyAbsSyn ) -> (LIE RdrName) +happyOut23 :: (HappyAbsSyn ) -> ([LIE RdrName]) happyOut23 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut23 #-} happyIn24 :: (LIE RdrName) -> (HappyAbsSyn ) @@ -182,16 +173,16 @@ happyOut24 :: (HappyAbsSyn ) -> (LIE RdrName) happyOut24 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut24 #-} -happyIn25 :: ([RdrName]) -> (HappyAbsSyn ) +happyIn25 :: (LIE RdrName) -> (HappyAbsSyn ) happyIn25 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn25 #-} -happyOut25 :: (HappyAbsSyn ) -> ([RdrName]) +happyOut25 :: (HappyAbsSyn ) -> (LIE RdrName) happyOut25 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut25 #-} -happyIn26 :: (Located RdrName) -> (HappyAbsSyn ) +happyIn26 :: ([RdrName]) -> (HappyAbsSyn ) happyIn26 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn26 #-} -happyOut26 :: (HappyAbsSyn ) -> (Located RdrName) +happyOut26 :: (HappyAbsSyn ) -> ([RdrName]) happyOut26 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut26 #-} happyIn27 :: (Located RdrName) -> (HappyAbsSyn ) @@ -200,28 +191,28 @@ happyOut27 :: (HappyAbsSyn ) -> (Located RdrName) happyOut27 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut27 #-} -happyIn28 :: ([LImportDecl RdrName]) -> (HappyAbsSyn ) +happyIn28 :: (Located RdrName) -> (HappyAbsSyn ) happyIn28 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn28 #-} -happyOut28 :: (HappyAbsSyn ) -> ([LImportDecl RdrName]) +happyOut28 :: (HappyAbsSyn ) -> (Located RdrName) happyOut28 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut28 #-} -happyIn29 :: (LImportDecl RdrName) -> (HappyAbsSyn ) +happyIn29 :: ([LImportDecl RdrName]) -> (HappyAbsSyn ) happyIn29 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn29 #-} -happyOut29 :: (HappyAbsSyn ) -> (LImportDecl RdrName) +happyOut29 :: (HappyAbsSyn ) -> ([LImportDecl RdrName]) happyOut29 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut29 #-} -happyIn30 :: (IsBootInterface) -> (HappyAbsSyn ) +happyIn30 :: (LImportDecl RdrName) -> (HappyAbsSyn ) happyIn30 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn30 #-} -happyOut30 :: (HappyAbsSyn ) -> (IsBootInterface) +happyOut30 :: (HappyAbsSyn ) -> (LImportDecl RdrName) happyOut30 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut30 #-} -happyIn31 :: (Maybe FastString) -> (HappyAbsSyn ) +happyIn31 :: (IsBootInterface) -> (HappyAbsSyn ) happyIn31 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn31 #-} -happyOut31 :: (HappyAbsSyn ) -> (Maybe FastString) +happyOut31 :: (HappyAbsSyn ) -> (IsBootInterface) happyOut31 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut31 #-} happyIn32 :: (Bool) -> (HappyAbsSyn ) @@ -230,64 +221,64 @@ happyOut32 :: (HappyAbsSyn ) -> (Bool) happyOut32 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut32 #-} -happyIn33 :: (Located (Maybe ModuleName)) -> (HappyAbsSyn ) +happyIn33 :: (Maybe FastString) -> (HappyAbsSyn ) happyIn33 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn33 #-} -happyOut33 :: (HappyAbsSyn ) -> (Located (Maybe ModuleName)) +happyOut33 :: (HappyAbsSyn ) -> (Maybe FastString) happyOut33 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut33 #-} -happyIn34 :: (Located (Maybe (Bool, [LIE RdrName]))) -> (HappyAbsSyn ) +happyIn34 :: (Bool) -> (HappyAbsSyn ) happyIn34 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn34 #-} -happyOut34 :: (HappyAbsSyn ) -> (Located (Maybe (Bool, [LIE RdrName]))) +happyOut34 :: (HappyAbsSyn ) -> (Bool) happyOut34 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut34 #-} -happyIn35 :: (Located (Bool, [LIE RdrName])) -> (HappyAbsSyn ) +happyIn35 :: (Located (Maybe ModuleName)) -> (HappyAbsSyn ) happyIn35 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn35 #-} -happyOut35 :: (HappyAbsSyn ) -> (Located (Bool, [LIE RdrName])) +happyOut35 :: (HappyAbsSyn ) -> (Located (Maybe ModuleName)) happyOut35 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut35 #-} -happyIn36 :: (Int) -> (HappyAbsSyn ) +happyIn36 :: (Located (Maybe (Bool, [LIE RdrName]))) -> (HappyAbsSyn ) happyIn36 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn36 #-} -happyOut36 :: (HappyAbsSyn ) -> (Int) +happyOut36 :: (HappyAbsSyn ) -> (Located (Maybe (Bool, [LIE RdrName]))) happyOut36 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut36 #-} -happyIn37 :: (Located FixityDirection) -> (HappyAbsSyn ) +happyIn37 :: (Located (Bool, [LIE RdrName])) -> (HappyAbsSyn ) happyIn37 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn37 #-} -happyOut37 :: (HappyAbsSyn ) -> (Located FixityDirection) +happyOut37 :: (HappyAbsSyn ) -> (Located (Bool, [LIE RdrName])) happyOut37 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut37 #-} -happyIn38 :: (Located [Located RdrName]) -> (HappyAbsSyn ) +happyIn38 :: (Int) -> (HappyAbsSyn ) happyIn38 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn38 #-} -happyOut38 :: (HappyAbsSyn ) -> (Located [Located RdrName]) +happyOut38 :: (HappyAbsSyn ) -> (Int) happyOut38 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut38 #-} -happyIn39 :: (OrdList (LHsDecl RdrName)) -> (HappyAbsSyn ) +happyIn39 :: (Located FixityDirection) -> (HappyAbsSyn ) happyIn39 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn39 #-} -happyOut39 :: (HappyAbsSyn ) -> (OrdList (LHsDecl RdrName)) +happyOut39 :: (HappyAbsSyn ) -> (Located FixityDirection) happyOut39 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut39 #-} -happyIn40 :: (OrdList (LHsDecl RdrName)) -> (HappyAbsSyn ) +happyIn40 :: (Located [Located RdrName]) -> (HappyAbsSyn ) happyIn40 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn40 #-} -happyOut40 :: (HappyAbsSyn ) -> (OrdList (LHsDecl RdrName)) +happyOut40 :: (HappyAbsSyn ) -> (Located [Located RdrName]) happyOut40 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut40 #-} -happyIn41 :: (LTyClDecl RdrName) -> (HappyAbsSyn ) +happyIn41 :: (OrdList (LHsDecl RdrName)) -> (HappyAbsSyn ) happyIn41 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn41 #-} -happyOut41 :: (HappyAbsSyn ) -> (LTyClDecl RdrName) +happyOut41 :: (HappyAbsSyn ) -> (OrdList (LHsDecl RdrName)) happyOut41 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut41 #-} -happyIn42 :: (LTyClDecl RdrName) -> (HappyAbsSyn ) +happyIn42 :: (OrdList (LHsDecl RdrName)) -> (HappyAbsSyn ) happyIn42 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn42 #-} -happyOut42 :: (HappyAbsSyn ) -> (LTyClDecl RdrName) +happyOut42 :: (HappyAbsSyn ) -> (OrdList (LHsDecl RdrName)) happyOut42 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut42 #-} happyIn43 :: (LTyClDecl RdrName) -> (HappyAbsSyn ) @@ -302,40 +293,40 @@ happyOut44 :: (HappyAbsSyn ) -> (LTyClDecl RdrName) happyOut44 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut44 #-} -happyIn45 :: (Located NewOrData) -> (HappyAbsSyn ) +happyIn45 :: (LTyClDecl RdrName) -> (HappyAbsSyn ) happyIn45 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn45 #-} -happyOut45 :: (HappyAbsSyn ) -> (Located NewOrData) +happyOut45 :: (HappyAbsSyn ) -> (LTyClDecl RdrName) happyOut45 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut45 #-} -happyIn46 :: (Located (Maybe Kind)) -> (HappyAbsSyn ) +happyIn46 :: (LTyClDecl RdrName) -> (HappyAbsSyn ) happyIn46 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn46 #-} -happyOut46 :: (HappyAbsSyn ) -> (Located (Maybe Kind)) +happyOut46 :: (HappyAbsSyn ) -> (LTyClDecl RdrName) happyOut46 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut46 #-} -happyIn47 :: (Located (Maybe (LHsContext RdrName), LHsType RdrName)) -> (HappyAbsSyn ) +happyIn47 :: (Located NewOrData) -> (HappyAbsSyn ) happyIn47 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn47 #-} -happyOut47 :: (HappyAbsSyn ) -> (Located (Maybe (LHsContext RdrName), LHsType RdrName)) +happyOut47 :: (HappyAbsSyn ) -> (Located NewOrData) happyOut47 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut47 #-} -happyIn48 :: (LDerivDecl RdrName) -> (HappyAbsSyn ) +happyIn48 :: (Located (Maybe Kind)) -> (HappyAbsSyn ) happyIn48 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn48 #-} -happyOut48 :: (HappyAbsSyn ) -> (LDerivDecl RdrName) +happyOut48 :: (HappyAbsSyn ) -> (Located (Maybe Kind)) happyOut48 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut48 #-} -happyIn49 :: (Located (OrdList (LHsDecl RdrName))) -> (HappyAbsSyn ) +happyIn49 :: (Located (Maybe (LHsContext RdrName), LHsType RdrName)) -> (HappyAbsSyn ) happyIn49 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn49 #-} -happyOut49 :: (HappyAbsSyn ) -> (Located (OrdList (LHsDecl RdrName))) +happyOut49 :: (HappyAbsSyn ) -> (Located (Maybe (LHsContext RdrName), LHsType RdrName)) happyOut49 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut49 #-} -happyIn50 :: (Located (OrdList (LHsDecl RdrName))) -> (HappyAbsSyn ) +happyIn50 :: (LDerivDecl RdrName) -> (HappyAbsSyn ) happyIn50 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn50 #-} -happyOut50 :: (HappyAbsSyn ) -> (Located (OrdList (LHsDecl RdrName))) +happyOut50 :: (HappyAbsSyn ) -> (LDerivDecl RdrName) happyOut50 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut50 #-} happyIn51 :: (Located (OrdList (LHsDecl RdrName))) -> (HappyAbsSyn ) @@ -386,70 +377,70 @@ happyOut58 :: (HappyAbsSyn ) -> (Located (OrdList (LHsDecl RdrName))) happyOut58 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut58 #-} -happyIn59 :: (Located (HsLocalBinds RdrName)) -> (HappyAbsSyn ) +happyIn59 :: (Located (OrdList (LHsDecl RdrName))) -> (HappyAbsSyn ) happyIn59 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn59 #-} -happyOut59 :: (HappyAbsSyn ) -> (Located (HsLocalBinds RdrName)) +happyOut59 :: (HappyAbsSyn ) -> (Located (OrdList (LHsDecl RdrName))) happyOut59 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut59 #-} -happyIn60 :: (Located (HsLocalBinds RdrName)) -> (HappyAbsSyn ) +happyIn60 :: (Located (OrdList (LHsDecl RdrName))) -> (HappyAbsSyn ) happyIn60 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn60 #-} -happyOut60 :: (HappyAbsSyn ) -> (Located (HsLocalBinds RdrName)) +happyOut60 :: (HappyAbsSyn ) -> (Located (OrdList (LHsDecl RdrName))) happyOut60 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut60 #-} -happyIn61 :: (OrdList (LHsDecl RdrName)) -> (HappyAbsSyn ) +happyIn61 :: (Located (HsLocalBinds RdrName)) -> (HappyAbsSyn ) happyIn61 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn61 #-} -happyOut61 :: (HappyAbsSyn ) -> (OrdList (LHsDecl RdrName)) +happyOut61 :: (HappyAbsSyn ) -> (Located (HsLocalBinds RdrName)) happyOut61 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut61 #-} -happyIn62 :: (LHsDecl RdrName) -> (HappyAbsSyn ) +happyIn62 :: (Located (HsLocalBinds RdrName)) -> (HappyAbsSyn ) happyIn62 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn62 #-} -happyOut62 :: (HappyAbsSyn ) -> (LHsDecl RdrName) +happyOut62 :: (HappyAbsSyn ) -> (Located (HsLocalBinds RdrName)) happyOut62 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut62 #-} -happyIn63 :: (Maybe Activation) -> (HappyAbsSyn ) +happyIn63 :: (OrdList (LHsDecl RdrName)) -> (HappyAbsSyn ) happyIn63 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn63 #-} -happyOut63 :: (HappyAbsSyn ) -> (Maybe Activation) +happyOut63 :: (HappyAbsSyn ) -> (OrdList (LHsDecl RdrName)) happyOut63 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut63 #-} -happyIn64 :: (Activation) -> (HappyAbsSyn ) +happyIn64 :: (LHsDecl RdrName) -> (HappyAbsSyn ) happyIn64 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn64 #-} -happyOut64 :: (HappyAbsSyn ) -> (Activation) +happyOut64 :: (HappyAbsSyn ) -> (LHsDecl RdrName) happyOut64 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut64 #-} -happyIn65 :: ([RuleBndr RdrName]) -> (HappyAbsSyn ) +happyIn65 :: (Maybe Activation) -> (HappyAbsSyn ) happyIn65 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn65 #-} -happyOut65 :: (HappyAbsSyn ) -> ([RuleBndr RdrName]) +happyOut65 :: (HappyAbsSyn ) -> (Maybe Activation) happyOut65 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut65 #-} -happyIn66 :: ([RuleBndr RdrName]) -> (HappyAbsSyn ) +happyIn66 :: (Activation) -> (HappyAbsSyn ) happyIn66 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn66 #-} -happyOut66 :: (HappyAbsSyn ) -> ([RuleBndr RdrName]) +happyOut66 :: (HappyAbsSyn ) -> (Activation) happyOut66 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut66 #-} -happyIn67 :: (RuleBndr RdrName) -> (HappyAbsSyn ) +happyIn67 :: ([RuleBndr RdrName]) -> (HappyAbsSyn ) happyIn67 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn67 #-} -happyOut67 :: (HappyAbsSyn ) -> (RuleBndr RdrName) +happyOut67 :: (HappyAbsSyn ) -> ([RuleBndr RdrName]) happyOut67 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut67 #-} -happyIn68 :: (OrdList (LHsDecl RdrName)) -> (HappyAbsSyn ) +happyIn68 :: ([RuleBndr RdrName]) -> (HappyAbsSyn ) happyIn68 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn68 #-} -happyOut68 :: (HappyAbsSyn ) -> (OrdList (LHsDecl RdrName)) +happyOut68 :: (HappyAbsSyn ) -> ([RuleBndr RdrName]) happyOut68 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut68 #-} -happyIn69 :: (OrdList (LHsDecl RdrName)) -> (HappyAbsSyn ) +happyIn69 :: (RuleBndr RdrName) -> (HappyAbsSyn ) happyIn69 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn69 #-} -happyOut69 :: (HappyAbsSyn ) -> (OrdList (LHsDecl RdrName)) +happyOut69 :: (HappyAbsSyn ) -> (RuleBndr RdrName) happyOut69 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut69 #-} happyIn70 :: (OrdList (LHsDecl RdrName)) -> (HappyAbsSyn ) @@ -464,94 +455,94 @@ happyOut71 :: (HappyAbsSyn ) -> (OrdList (LHsDecl RdrName)) happyOut71 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut71 #-} -happyIn72 :: (Located [FastString]) -> (HappyAbsSyn ) +happyIn72 :: (OrdList (LHsDecl RdrName)) -> (HappyAbsSyn ) happyIn72 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn72 #-} -happyOut72 :: (HappyAbsSyn ) -> (Located [FastString]) +happyOut72 :: (HappyAbsSyn ) -> (OrdList (LHsDecl RdrName)) happyOut72 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut72 #-} -happyIn73 :: (Located (OrdList FastString)) -> (HappyAbsSyn ) +happyIn73 :: (OrdList (LHsDecl RdrName)) -> (HappyAbsSyn ) happyIn73 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn73 #-} -happyOut73 :: (HappyAbsSyn ) -> (Located (OrdList FastString)) +happyOut73 :: (HappyAbsSyn ) -> (OrdList (LHsDecl RdrName)) happyOut73 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut73 #-} -happyIn74 :: (LHsDecl RdrName) -> (HappyAbsSyn ) +happyIn74 :: (Located [FastString]) -> (HappyAbsSyn ) happyIn74 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn74 #-} -happyOut74 :: (HappyAbsSyn ) -> (LHsDecl RdrName) +happyOut74 :: (HappyAbsSyn ) -> (Located [FastString]) happyOut74 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut74 #-} -happyIn75 :: (LHsDecl RdrName) -> (HappyAbsSyn ) +happyIn75 :: (Located (OrdList FastString)) -> (HappyAbsSyn ) happyIn75 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn75 #-} -happyOut75 :: (HappyAbsSyn ) -> (LHsDecl RdrName) +happyOut75 :: (HappyAbsSyn ) -> (Located (OrdList FastString)) happyOut75 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut75 #-} -happyIn76 :: (CCallConv) -> (HappyAbsSyn ) +happyIn76 :: (LHsDecl RdrName) -> (HappyAbsSyn ) happyIn76 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn76 #-} -happyOut76 :: (HappyAbsSyn ) -> (CCallConv) +happyOut76 :: (HappyAbsSyn ) -> (LHsDecl RdrName) happyOut76 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut76 #-} -happyIn77 :: (Safety) -> (HappyAbsSyn ) +happyIn77 :: (LHsDecl RdrName) -> (HappyAbsSyn ) happyIn77 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn77 #-} -happyOut77 :: (HappyAbsSyn ) -> (Safety) +happyOut77 :: (HappyAbsSyn ) -> (LHsDecl RdrName) happyOut77 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut77 #-} -happyIn78 :: (Located (Located FastString, Located RdrName, LHsType RdrName)) -> (HappyAbsSyn ) +happyIn78 :: (CCallConv) -> (HappyAbsSyn ) happyIn78 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn78 #-} -happyOut78 :: (HappyAbsSyn ) -> (Located (Located FastString, Located RdrName, LHsType RdrName)) +happyOut78 :: (HappyAbsSyn ) -> (CCallConv) happyOut78 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut78 #-} -happyIn79 :: (Maybe (LHsType RdrName)) -> (HappyAbsSyn ) +happyIn79 :: (Safety) -> (HappyAbsSyn ) happyIn79 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn79 #-} -happyOut79 :: (HappyAbsSyn ) -> (Maybe (LHsType RdrName)) +happyOut79 :: (HappyAbsSyn ) -> (Safety) happyOut79 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut79 #-} -happyIn80 :: (Maybe (LHsType RdrName)) -> (HappyAbsSyn ) +happyIn80 :: (Located (Located FastString, Located RdrName, LHsType RdrName)) -> (HappyAbsSyn ) happyIn80 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn80 #-} -happyOut80 :: (HappyAbsSyn ) -> (Maybe (LHsType RdrName)) +happyOut80 :: (HappyAbsSyn ) -> (Located (Located FastString, Located RdrName, LHsType RdrName)) happyOut80 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut80 #-} -happyIn81 :: (LHsType RdrName) -> (HappyAbsSyn ) +happyIn81 :: (Maybe (LHsType RdrName)) -> (HappyAbsSyn ) happyIn81 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn81 #-} -happyOut81 :: (HappyAbsSyn ) -> (LHsType RdrName) +happyOut81 :: (HappyAbsSyn ) -> (Maybe (LHsType RdrName)) happyOut81 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut81 #-} -happyIn82 :: (LHsType RdrName) -> (HappyAbsSyn ) +happyIn82 :: (Maybe (LHsType RdrName)) -> (HappyAbsSyn ) happyIn82 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn82 #-} -happyOut82 :: (HappyAbsSyn ) -> (LHsType RdrName) +happyOut82 :: (HappyAbsSyn ) -> (Maybe (LHsType RdrName)) happyOut82 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut82 #-} -happyIn83 :: (Located [Located RdrName]) -> (HappyAbsSyn ) +happyIn83 :: (LHsType RdrName) -> (HappyAbsSyn ) happyIn83 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn83 #-} -happyOut83 :: (HappyAbsSyn ) -> (Located [Located RdrName]) +happyOut83 :: (HappyAbsSyn ) -> (LHsType RdrName) happyOut83 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut83 #-} -happyIn84 :: ([LHsType RdrName]) -> (HappyAbsSyn ) +happyIn84 :: (LHsType RdrName) -> (HappyAbsSyn ) happyIn84 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn84 #-} -happyOut84 :: (HappyAbsSyn ) -> ([LHsType RdrName]) +happyOut84 :: (HappyAbsSyn ) -> (LHsType RdrName) happyOut84 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut84 #-} -happyIn85 :: (LHsType RdrName) -> (HappyAbsSyn ) +happyIn85 :: (Located [Located RdrName]) -> (HappyAbsSyn ) happyIn85 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn85 #-} -happyOut85 :: (HappyAbsSyn ) -> (LHsType RdrName) +happyOut85 :: (HappyAbsSyn ) -> (Located [Located RdrName]) happyOut85 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut85 #-} -happyIn86 :: (Located HsBang) -> (HappyAbsSyn ) +happyIn86 :: ([LHsType RdrName]) -> (HappyAbsSyn ) happyIn86 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn86 #-} -happyOut86 :: (HappyAbsSyn ) -> (Located HsBang) +happyOut86 :: (HappyAbsSyn ) -> ([LHsType RdrName]) happyOut86 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut86 #-} happyIn87 :: (LHsType RdrName) -> (HappyAbsSyn ) @@ -560,16 +551,16 @@ happyOut87 :: (HappyAbsSyn ) -> (LHsType RdrName) happyOut87 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut87 #-} -happyIn88 :: (LHsType RdrName) -> (HappyAbsSyn ) +happyIn88 :: (Located HsBang) -> (HappyAbsSyn ) happyIn88 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn88 #-} -happyOut88 :: (HappyAbsSyn ) -> (LHsType RdrName) +happyOut88 :: (HappyAbsSyn ) -> (Located HsBang) happyOut88 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut88 #-} -happyIn89 :: (LHsContext RdrName) -> (HappyAbsSyn ) +happyIn89 :: (LHsType RdrName) -> (HappyAbsSyn ) happyIn89 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn89 #-} -happyOut89 :: (HappyAbsSyn ) -> (LHsContext RdrName) +happyOut89 :: (HappyAbsSyn ) -> (LHsType RdrName) happyOut89 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut89 #-} happyIn90 :: (LHsType RdrName) -> (HappyAbsSyn ) @@ -578,10 +569,10 @@ happyOut90 :: (HappyAbsSyn ) -> (LHsType RdrName) happyOut90 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut90 #-} -happyIn91 :: (LHsType RdrName) -> (HappyAbsSyn ) +happyIn91 :: (LHsContext RdrName) -> (HappyAbsSyn ) happyIn91 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn91 #-} -happyOut91 :: (HappyAbsSyn ) -> (LHsType RdrName) +happyOut91 :: (HappyAbsSyn ) -> (LHsContext RdrName) happyOut91 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut91 #-} happyIn92 :: (LHsType RdrName) -> (HappyAbsSyn ) @@ -602,16 +593,16 @@ happyOut94 :: (HappyAbsSyn ) -> (LHsType RdrName) happyOut94 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut94 #-} -happyIn95 :: ([LHsType RdrName]) -> (HappyAbsSyn ) +happyIn95 :: (LHsType RdrName) -> (HappyAbsSyn ) happyIn95 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn95 #-} -happyOut95 :: (HappyAbsSyn ) -> ([LHsType RdrName]) +happyOut95 :: (HappyAbsSyn ) -> (LHsType RdrName) happyOut95 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut95 #-} -happyIn96 :: ([LHsType RdrName]) -> (HappyAbsSyn ) +happyIn96 :: (LHsType RdrName) -> (HappyAbsSyn ) happyIn96 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn96 #-} -happyOut96 :: (HappyAbsSyn ) -> ([LHsType RdrName]) +happyOut96 :: (HappyAbsSyn ) -> (LHsType RdrName) happyOut96 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut96 #-} happyIn97 :: ([LHsType RdrName]) -> (HappyAbsSyn ) @@ -620,70 +611,70 @@ happyOut97 :: (HappyAbsSyn ) -> ([LHsType RdrName]) happyOut97 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut97 #-} -happyIn98 :: ([LHsTyVarBndr RdrName]) -> (HappyAbsSyn ) +happyIn98 :: ([LHsType RdrName]) -> (HappyAbsSyn ) happyIn98 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn98 #-} -happyOut98 :: (HappyAbsSyn ) -> ([LHsTyVarBndr RdrName]) +happyOut98 :: (HappyAbsSyn ) -> ([LHsType RdrName]) happyOut98 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut98 #-} -happyIn99 :: (LHsTyVarBndr RdrName) -> (HappyAbsSyn ) +happyIn99 :: ([LHsType RdrName]) -> (HappyAbsSyn ) happyIn99 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn99 #-} -happyOut99 :: (HappyAbsSyn ) -> (LHsTyVarBndr RdrName) +happyOut99 :: (HappyAbsSyn ) -> ([LHsType RdrName]) happyOut99 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut99 #-} -happyIn100 :: (Located [Located (FunDep RdrName)]) -> (HappyAbsSyn ) +happyIn100 :: ([LHsTyVarBndr RdrName]) -> (HappyAbsSyn ) happyIn100 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn100 #-} -happyOut100 :: (HappyAbsSyn ) -> (Located [Located (FunDep RdrName)]) +happyOut100 :: (HappyAbsSyn ) -> ([LHsTyVarBndr RdrName]) happyOut100 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut100 #-} -happyIn101 :: (Located [Located (FunDep RdrName)]) -> (HappyAbsSyn ) +happyIn101 :: (LHsTyVarBndr RdrName) -> (HappyAbsSyn ) happyIn101 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn101 #-} -happyOut101 :: (HappyAbsSyn ) -> (Located [Located (FunDep RdrName)]) +happyOut101 :: (HappyAbsSyn ) -> (LHsTyVarBndr RdrName) happyOut101 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut101 #-} -happyIn102 :: (Located (FunDep RdrName)) -> (HappyAbsSyn ) +happyIn102 :: (Located [Located (FunDep RdrName)]) -> (HappyAbsSyn ) happyIn102 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn102 #-} -happyOut102 :: (HappyAbsSyn ) -> (Located (FunDep RdrName)) +happyOut102 :: (HappyAbsSyn ) -> (Located [Located (FunDep RdrName)]) happyOut102 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut102 #-} -happyIn103 :: (Located [RdrName]) -> (HappyAbsSyn ) +happyIn103 :: (Located [Located (FunDep RdrName)]) -> (HappyAbsSyn ) happyIn103 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn103 #-} -happyOut103 :: (HappyAbsSyn ) -> (Located [RdrName]) +happyOut103 :: (HappyAbsSyn ) -> (Located [Located (FunDep RdrName)]) happyOut103 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut103 #-} -happyIn104 :: (Located Kind) -> (HappyAbsSyn ) +happyIn104 :: (Located (FunDep RdrName)) -> (HappyAbsSyn ) happyIn104 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn104 #-} -happyOut104 :: (HappyAbsSyn ) -> (Located Kind) +happyOut104 :: (HappyAbsSyn ) -> (Located (FunDep RdrName)) happyOut104 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut104 #-} -happyIn105 :: (Located Kind) -> (HappyAbsSyn ) +happyIn105 :: (Located [RdrName]) -> (HappyAbsSyn ) happyIn105 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn105 #-} -happyOut105 :: (HappyAbsSyn ) -> (Located Kind) +happyOut105 :: (HappyAbsSyn ) -> (Located [RdrName]) happyOut105 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut105 #-} -happyIn106 :: (Located [LConDecl RdrName]) -> (HappyAbsSyn ) +happyIn106 :: (Located Kind) -> (HappyAbsSyn ) happyIn106 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn106 #-} -happyOut106 :: (HappyAbsSyn ) -> (Located [LConDecl RdrName]) +happyOut106 :: (HappyAbsSyn ) -> (Located Kind) happyOut106 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut106 #-} -happyIn107 :: (Located [LConDecl RdrName]) -> (HappyAbsSyn ) +happyIn107 :: (Located Kind) -> (HappyAbsSyn ) happyIn107 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn107 #-} -happyOut107 :: (HappyAbsSyn ) -> (Located [LConDecl RdrName]) +happyOut107 :: (HappyAbsSyn ) -> (Located Kind) happyOut107 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut107 #-} -happyIn108 :: ([LConDecl RdrName]) -> (HappyAbsSyn ) +happyIn108 :: (Located [LConDecl RdrName]) -> (HappyAbsSyn ) happyIn108 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn108 #-} -happyOut108 :: (HappyAbsSyn ) -> ([LConDecl RdrName]) +happyOut108 :: (HappyAbsSyn ) -> (Located [LConDecl RdrName]) happyOut108 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut108 #-} happyIn109 :: (Located [LConDecl RdrName]) -> (HappyAbsSyn ) @@ -692,40 +683,40 @@ happyOut109 :: (HappyAbsSyn ) -> (Located [LConDecl RdrName]) happyOut109 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut109 #-} -happyIn110 :: (Located [LConDecl RdrName]) -> (HappyAbsSyn ) +happyIn110 :: ([LConDecl RdrName]) -> (HappyAbsSyn ) happyIn110 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn110 #-} -happyOut110 :: (HappyAbsSyn ) -> (Located [LConDecl RdrName]) +happyOut110 :: (HappyAbsSyn ) -> ([LConDecl RdrName]) happyOut110 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut110 #-} -happyIn111 :: (LConDecl RdrName) -> (HappyAbsSyn ) +happyIn111 :: (Located [LConDecl RdrName]) -> (HappyAbsSyn ) happyIn111 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn111 #-} -happyOut111 :: (HappyAbsSyn ) -> (LConDecl RdrName) +happyOut111 :: (HappyAbsSyn ) -> (Located [LConDecl RdrName]) happyOut111 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut111 #-} -happyIn112 :: (Located [LHsTyVarBndr RdrName]) -> (HappyAbsSyn ) +happyIn112 :: (Located [LConDecl RdrName]) -> (HappyAbsSyn ) happyIn112 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn112 #-} -happyOut112 :: (HappyAbsSyn ) -> (Located [LHsTyVarBndr RdrName]) +happyOut112 :: (HappyAbsSyn ) -> (Located [LConDecl RdrName]) happyOut112 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut112 #-} -happyIn113 :: (Located (Located RdrName, HsConDeclDetails RdrName)) -> (HappyAbsSyn ) +happyIn113 :: (LConDecl RdrName) -> (HappyAbsSyn ) happyIn113 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn113 #-} -happyOut113 :: (HappyAbsSyn ) -> (Located (Located RdrName, HsConDeclDetails RdrName)) +happyOut113 :: (HappyAbsSyn ) -> (LConDecl RdrName) happyOut113 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut113 #-} -happyIn114 :: ([ConDeclField RdrName]) -> (HappyAbsSyn ) +happyIn114 :: (Located [LHsTyVarBndr RdrName]) -> (HappyAbsSyn ) happyIn114 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn114 #-} -happyOut114 :: (HappyAbsSyn ) -> ([ConDeclField RdrName]) +happyOut114 :: (HappyAbsSyn ) -> (Located [LHsTyVarBndr RdrName]) happyOut114 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut114 #-} -happyIn115 :: ([ConDeclField RdrName]) -> (HappyAbsSyn ) +happyIn115 :: (Located (Located RdrName, HsConDeclDetails RdrName)) -> (HappyAbsSyn ) happyIn115 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn115 #-} -happyOut115 :: (HappyAbsSyn ) -> ([ConDeclField RdrName]) +happyOut115 :: (HappyAbsSyn ) -> (Located (Located RdrName, HsConDeclDetails RdrName)) happyOut115 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut115 #-} happyIn116 :: ([ConDeclField RdrName]) -> (HappyAbsSyn ) @@ -734,70 +725,70 @@ happyOut116 :: (HappyAbsSyn ) -> ([ConDeclField RdrName]) happyOut116 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut116 #-} -happyIn117 :: (Located (Maybe [LHsType RdrName])) -> (HappyAbsSyn ) +happyIn117 :: ([ConDeclField RdrName]) -> (HappyAbsSyn ) happyIn117 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn117 #-} -happyOut117 :: (HappyAbsSyn ) -> (Located (Maybe [LHsType RdrName])) +happyOut117 :: (HappyAbsSyn ) -> ([ConDeclField RdrName]) happyOut117 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut117 #-} -happyIn118 :: (LHsDecl RdrName) -> (HappyAbsSyn ) +happyIn118 :: ([ConDeclField RdrName]) -> (HappyAbsSyn ) happyIn118 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn118 #-} -happyOut118 :: (HappyAbsSyn ) -> (LHsDecl RdrName) +happyOut118 :: (HappyAbsSyn ) -> ([ConDeclField RdrName]) happyOut118 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut118 #-} -happyIn119 :: (LDocDecl) -> (HappyAbsSyn ) +happyIn119 :: (Located (Maybe [LHsType RdrName])) -> (HappyAbsSyn ) happyIn119 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn119 #-} -happyOut119 :: (HappyAbsSyn ) -> (LDocDecl) +happyOut119 :: (HappyAbsSyn ) -> (Located (Maybe [LHsType RdrName])) happyOut119 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut119 #-} -happyIn120 :: (Located (OrdList (LHsDecl RdrName))) -> (HappyAbsSyn ) +happyIn120 :: (LHsDecl RdrName) -> (HappyAbsSyn ) happyIn120 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn120 #-} -happyOut120 :: (HappyAbsSyn ) -> (Located (OrdList (LHsDecl RdrName))) +happyOut120 :: (HappyAbsSyn ) -> (LHsDecl RdrName) happyOut120 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut120 #-} -happyIn121 :: (Located (GRHSs RdrName)) -> (HappyAbsSyn ) +happyIn121 :: (LDocDecl) -> (HappyAbsSyn ) happyIn121 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn121 #-} -happyOut121 :: (HappyAbsSyn ) -> (Located (GRHSs RdrName)) +happyOut121 :: (HappyAbsSyn ) -> (LDocDecl) happyOut121 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut121 #-} -happyIn122 :: (Located [LGRHS RdrName]) -> (HappyAbsSyn ) +happyIn122 :: (Located (OrdList (LHsDecl RdrName))) -> (HappyAbsSyn ) happyIn122 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn122 #-} -happyOut122 :: (HappyAbsSyn ) -> (Located [LGRHS RdrName]) +happyOut122 :: (HappyAbsSyn ) -> (Located (OrdList (LHsDecl RdrName))) happyOut122 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut122 #-} -happyIn123 :: (LGRHS RdrName) -> (HappyAbsSyn ) +happyIn123 :: (Located (GRHSs RdrName)) -> (HappyAbsSyn ) happyIn123 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn123 #-} -happyOut123 :: (HappyAbsSyn ) -> (LGRHS RdrName) +happyOut123 :: (HappyAbsSyn ) -> (Located (GRHSs RdrName)) happyOut123 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut123 #-} -happyIn124 :: (Located (OrdList (LHsDecl RdrName))) -> (HappyAbsSyn ) +happyIn124 :: (Located [LGRHS RdrName]) -> (HappyAbsSyn ) happyIn124 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn124 #-} -happyOut124 :: (HappyAbsSyn ) -> (Located (OrdList (LHsDecl RdrName))) +happyOut124 :: (HappyAbsSyn ) -> (Located [LGRHS RdrName]) happyOut124 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut124 #-} -happyIn125 :: (Located (HsQuasiQuote RdrName)) -> (HappyAbsSyn ) +happyIn125 :: (LGRHS RdrName) -> (HappyAbsSyn ) happyIn125 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn125 #-} -happyOut125 :: (HappyAbsSyn ) -> (Located (HsQuasiQuote RdrName)) +happyOut125 :: (HappyAbsSyn ) -> (LGRHS RdrName) happyOut125 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut125 #-} -happyIn126 :: (LHsExpr RdrName) -> (HappyAbsSyn ) +happyIn126 :: (Located (OrdList (LHsDecl RdrName))) -> (HappyAbsSyn ) happyIn126 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn126 #-} -happyOut126 :: (HappyAbsSyn ) -> (LHsExpr RdrName) +happyOut126 :: (HappyAbsSyn ) -> (Located (OrdList (LHsDecl RdrName))) happyOut126 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut126 #-} -happyIn127 :: (LHsExpr RdrName) -> (HappyAbsSyn ) +happyIn127 :: (Located (HsQuasiQuote RdrName)) -> (HappyAbsSyn ) happyIn127 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn127 #-} -happyOut127 :: (HappyAbsSyn ) -> (LHsExpr RdrName) +happyOut127 :: (HappyAbsSyn ) -> (Located (HsQuasiQuote RdrName)) happyOut127 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut127 #-} happyIn128 :: (LHsExpr RdrName) -> (HappyAbsSyn ) @@ -806,34 +797,34 @@ happyOut128 :: (HappyAbsSyn ) -> (LHsExpr RdrName) happyOut128 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut128 #-} -happyIn129 :: (Bool) -> (HappyAbsSyn ) +happyIn129 :: (LHsExpr RdrName) -> (HappyAbsSyn ) happyIn129 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn129 #-} -happyOut129 :: (HappyAbsSyn ) -> (Bool) +happyOut129 :: (HappyAbsSyn ) -> (LHsExpr RdrName) happyOut129 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut129 #-} -happyIn130 :: (Located FastString) -> (HappyAbsSyn ) +happyIn130 :: (LHsExpr RdrName) -> (HappyAbsSyn ) happyIn130 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn130 #-} -happyOut130 :: (HappyAbsSyn ) -> (Located FastString) +happyOut130 :: (HappyAbsSyn ) -> (LHsExpr RdrName) happyOut130 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut130 #-} -happyIn131 :: (Located (FastString,(Int,Int),(Int,Int))) -> (HappyAbsSyn ) +happyIn131 :: (Bool) -> (HappyAbsSyn ) happyIn131 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn131 #-} -happyOut131 :: (HappyAbsSyn ) -> (Located (FastString,(Int,Int),(Int,Int))) +happyOut131 :: (HappyAbsSyn ) -> (Bool) happyOut131 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut131 #-} -happyIn132 :: (LHsExpr RdrName) -> (HappyAbsSyn ) +happyIn132 :: (Located FastString) -> (HappyAbsSyn ) happyIn132 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn132 #-} -happyOut132 :: (HappyAbsSyn ) -> (LHsExpr RdrName) +happyOut132 :: (HappyAbsSyn ) -> (Located FastString) happyOut132 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut132 #-} -happyIn133 :: (LHsExpr RdrName) -> (HappyAbsSyn ) +happyIn133 :: (Located (FastString,(Int,Int),(Int,Int))) -> (HappyAbsSyn ) happyIn133 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn133 #-} -happyOut133 :: (HappyAbsSyn ) -> (LHsExpr RdrName) +happyOut133 :: (HappyAbsSyn ) -> (Located (FastString,(Int,Int),(Int,Int))) happyOut133 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut133 #-} happyIn134 :: (LHsExpr RdrName) -> (HappyAbsSyn ) @@ -848,46 +839,46 @@ happyOut135 :: (HappyAbsSyn ) -> (LHsExpr RdrName) happyOut135 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut135 #-} -happyIn136 :: ([LHsCmdTop RdrName]) -> (HappyAbsSyn ) +happyIn136 :: (LHsExpr RdrName) -> (HappyAbsSyn ) happyIn136 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn136 #-} -happyOut136 :: (HappyAbsSyn ) -> ([LHsCmdTop RdrName]) +happyOut136 :: (HappyAbsSyn ) -> (LHsExpr RdrName) happyOut136 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut136 #-} -happyIn137 :: (LHsCmdTop RdrName) -> (HappyAbsSyn ) +happyIn137 :: (LHsExpr RdrName) -> (HappyAbsSyn ) happyIn137 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn137 #-} -happyOut137 :: (HappyAbsSyn ) -> (LHsCmdTop RdrName) +happyOut137 :: (HappyAbsSyn ) -> (LHsExpr RdrName) happyOut137 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut137 #-} -happyIn138 :: ([LHsDecl RdrName]) -> (HappyAbsSyn ) +happyIn138 :: ([LHsCmdTop RdrName]) -> (HappyAbsSyn ) happyIn138 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn138 #-} -happyOut138 :: (HappyAbsSyn ) -> ([LHsDecl RdrName]) +happyOut138 :: (HappyAbsSyn ) -> ([LHsCmdTop RdrName]) happyOut138 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut138 #-} -happyIn139 :: ([LHsDecl RdrName]) -> (HappyAbsSyn ) +happyIn139 :: (LHsCmdTop RdrName) -> (HappyAbsSyn ) happyIn139 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn139 #-} -happyOut139 :: (HappyAbsSyn ) -> ([LHsDecl RdrName]) +happyOut139 :: (HappyAbsSyn ) -> (LHsCmdTop RdrName) happyOut139 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut139 #-} -happyIn140 :: (LHsExpr RdrName) -> (HappyAbsSyn ) +happyIn140 :: ([LHsDecl RdrName]) -> (HappyAbsSyn ) happyIn140 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn140 #-} -happyOut140 :: (HappyAbsSyn ) -> (LHsExpr RdrName) +happyOut140 :: (HappyAbsSyn ) -> ([LHsDecl RdrName]) happyOut140 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut140 #-} -happyIn141 :: ([HsTupArg RdrName]) -> (HappyAbsSyn ) +happyIn141 :: ([LHsDecl RdrName]) -> (HappyAbsSyn ) happyIn141 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn141 #-} -happyOut141 :: (HappyAbsSyn ) -> ([HsTupArg RdrName]) +happyOut141 :: (HappyAbsSyn ) -> ([LHsDecl RdrName]) happyOut141 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut141 #-} -happyIn142 :: ([HsTupArg RdrName]) -> (HappyAbsSyn ) +happyIn142 :: (LHsExpr RdrName) -> (HappyAbsSyn ) happyIn142 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn142 #-} -happyOut142 :: (HappyAbsSyn ) -> ([HsTupArg RdrName]) +happyOut142 :: (HappyAbsSyn ) -> (LHsExpr RdrName) happyOut142 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut142 #-} happyIn143 :: ([HsTupArg RdrName]) -> (HappyAbsSyn ) @@ -896,28 +887,28 @@ happyOut143 :: (HappyAbsSyn ) -> ([HsTupArg RdrName]) happyOut143 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut143 #-} -happyIn144 :: (LHsExpr RdrName) -> (HappyAbsSyn ) +happyIn144 :: ([HsTupArg RdrName]) -> (HappyAbsSyn ) happyIn144 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn144 #-} -happyOut144 :: (HappyAbsSyn ) -> (LHsExpr RdrName) +happyOut144 :: (HappyAbsSyn ) -> ([HsTupArg RdrName]) happyOut144 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut144 #-} -happyIn145 :: (Located [LHsExpr RdrName]) -> (HappyAbsSyn ) +happyIn145 :: ([HsTupArg RdrName]) -> (HappyAbsSyn ) happyIn145 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn145 #-} -happyOut145 :: (HappyAbsSyn ) -> (Located [LHsExpr RdrName]) +happyOut145 :: (HappyAbsSyn ) -> ([HsTupArg RdrName]) happyOut145 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut145 #-} -happyIn146 :: (Located [LStmt RdrName]) -> (HappyAbsSyn ) +happyIn146 :: (LHsExpr RdrName) -> (HappyAbsSyn ) happyIn146 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn146 #-} -happyOut146 :: (HappyAbsSyn ) -> (Located [LStmt RdrName]) +happyOut146 :: (HappyAbsSyn ) -> (LHsExpr RdrName) happyOut146 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut146 #-} -happyIn147 :: (Located [[LStmt RdrName]]) -> (HappyAbsSyn ) +happyIn147 :: (Located [LHsExpr RdrName]) -> (HappyAbsSyn ) happyIn147 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn147 #-} -happyOut147 :: (HappyAbsSyn ) -> (Located [[LStmt RdrName]]) +happyOut147 :: (HappyAbsSyn ) -> (Located [LHsExpr RdrName]) happyOut147 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut147 #-} happyIn148 :: (Located [LStmt RdrName]) -> (HappyAbsSyn ) @@ -926,40 +917,40 @@ happyOut148 :: (HappyAbsSyn ) -> (Located [LStmt RdrName]) happyOut148 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut148 #-} -happyIn149 :: (Located ([LStmt RdrName] -> Stmt RdrName)) -> (HappyAbsSyn ) +happyIn149 :: (Located [[LStmt RdrName]]) -> (HappyAbsSyn ) happyIn149 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn149 #-} -happyOut149 :: (HappyAbsSyn ) -> (Located ([LStmt RdrName] -> Stmt RdrName)) +happyOut149 :: (HappyAbsSyn ) -> (Located [[LStmt RdrName]]) happyOut149 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut149 #-} -happyIn150 :: (LHsExpr RdrName) -> (HappyAbsSyn ) +happyIn150 :: (Located [LStmt RdrName]) -> (HappyAbsSyn ) happyIn150 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn150 #-} -happyOut150 :: (HappyAbsSyn ) -> (LHsExpr RdrName) +happyOut150 :: (HappyAbsSyn ) -> (Located [LStmt RdrName]) happyOut150 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut150 #-} -happyIn151 :: (Located [LStmt RdrName]) -> (HappyAbsSyn ) +happyIn151 :: (Located ([LStmt RdrName] -> Stmt RdrName)) -> (HappyAbsSyn ) happyIn151 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn151 #-} -happyOut151 :: (HappyAbsSyn ) -> (Located [LStmt RdrName]) +happyOut151 :: (HappyAbsSyn ) -> (Located ([LStmt RdrName] -> Stmt RdrName)) happyOut151 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut151 #-} -happyIn152 :: (Located [LStmt RdrName]) -> (HappyAbsSyn ) +happyIn152 :: (LHsExpr RdrName) -> (HappyAbsSyn ) happyIn152 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn152 #-} -happyOut152 :: (HappyAbsSyn ) -> (Located [LStmt RdrName]) +happyOut152 :: (HappyAbsSyn ) -> (LHsExpr RdrName) happyOut152 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut152 #-} -happyIn153 :: (Located [LMatch RdrName]) -> (HappyAbsSyn ) +happyIn153 :: (Located [LStmt RdrName]) -> (HappyAbsSyn ) happyIn153 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn153 #-} -happyOut153 :: (HappyAbsSyn ) -> (Located [LMatch RdrName]) +happyOut153 :: (HappyAbsSyn ) -> (Located [LStmt RdrName]) happyOut153 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut153 #-} -happyIn154 :: (Located [LMatch RdrName]) -> (HappyAbsSyn ) +happyIn154 :: (Located [LStmt RdrName]) -> (HappyAbsSyn ) happyIn154 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn154 #-} -happyOut154 :: (HappyAbsSyn ) -> (Located [LMatch RdrName]) +happyOut154 :: (HappyAbsSyn ) -> (Located [LStmt RdrName]) happyOut154 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut154 #-} happyIn155 :: (Located [LMatch RdrName]) -> (HappyAbsSyn ) @@ -968,64 +959,64 @@ happyOut155 :: (HappyAbsSyn ) -> (Located [LMatch RdrName]) happyOut155 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut155 #-} -happyIn156 :: (LMatch RdrName) -> (HappyAbsSyn ) +happyIn156 :: (Located [LMatch RdrName]) -> (HappyAbsSyn ) happyIn156 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn156 #-} -happyOut156 :: (HappyAbsSyn ) -> (LMatch RdrName) +happyOut156 :: (HappyAbsSyn ) -> (Located [LMatch RdrName]) happyOut156 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut156 #-} -happyIn157 :: (Located (GRHSs RdrName)) -> (HappyAbsSyn ) +happyIn157 :: (Located [LMatch RdrName]) -> (HappyAbsSyn ) happyIn157 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn157 #-} -happyOut157 :: (HappyAbsSyn ) -> (Located (GRHSs RdrName)) +happyOut157 :: (HappyAbsSyn ) -> (Located [LMatch RdrName]) happyOut157 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut157 #-} -happyIn158 :: (Located [LGRHS RdrName]) -> (HappyAbsSyn ) +happyIn158 :: (LMatch RdrName) -> (HappyAbsSyn ) happyIn158 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn158 #-} -happyOut158 :: (HappyAbsSyn ) -> (Located [LGRHS RdrName]) +happyOut158 :: (HappyAbsSyn ) -> (LMatch RdrName) happyOut158 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut158 #-} -happyIn159 :: (Located [LGRHS RdrName]) -> (HappyAbsSyn ) +happyIn159 :: (Located (GRHSs RdrName)) -> (HappyAbsSyn ) happyIn159 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn159 #-} -happyOut159 :: (HappyAbsSyn ) -> (Located [LGRHS RdrName]) +happyOut159 :: (HappyAbsSyn ) -> (Located (GRHSs RdrName)) happyOut159 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut159 #-} -happyIn160 :: (LGRHS RdrName) -> (HappyAbsSyn ) +happyIn160 :: (Located [LGRHS RdrName]) -> (HappyAbsSyn ) happyIn160 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn160 #-} -happyOut160 :: (HappyAbsSyn ) -> (LGRHS RdrName) +happyOut160 :: (HappyAbsSyn ) -> (Located [LGRHS RdrName]) happyOut160 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut160 #-} -happyIn161 :: (LPat RdrName) -> (HappyAbsSyn ) +happyIn161 :: (Located [LGRHS RdrName]) -> (HappyAbsSyn ) happyIn161 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn161 #-} -happyOut161 :: (HappyAbsSyn ) -> (LPat RdrName) +happyOut161 :: (HappyAbsSyn ) -> (Located [LGRHS RdrName]) happyOut161 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut161 #-} -happyIn162 :: (LPat RdrName) -> (HappyAbsSyn ) +happyIn162 :: (LGRHS RdrName) -> (HappyAbsSyn ) happyIn162 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn162 #-} -happyOut162 :: (HappyAbsSyn ) -> (LPat RdrName) +happyOut162 :: (HappyAbsSyn ) -> (LGRHS RdrName) happyOut162 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut162 #-} -happyIn163 :: ([LPat RdrName]) -> (HappyAbsSyn ) +happyIn163 :: (LPat RdrName) -> (HappyAbsSyn ) happyIn163 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn163 #-} -happyOut163 :: (HappyAbsSyn ) -> ([LPat RdrName]) +happyOut163 :: (HappyAbsSyn ) -> (LPat RdrName) happyOut163 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut163 #-} -happyIn164 :: (Located [LStmt RdrName]) -> (HappyAbsSyn ) +happyIn164 :: (LPat RdrName) -> (HappyAbsSyn ) happyIn164 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn164 #-} -happyOut164 :: (HappyAbsSyn ) -> (Located [LStmt RdrName]) +happyOut164 :: (HappyAbsSyn ) -> (LPat RdrName) happyOut164 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut164 #-} -happyIn165 :: (Located [LStmt RdrName]) -> (HappyAbsSyn ) +happyIn165 :: ([LPat RdrName]) -> (HappyAbsSyn ) happyIn165 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn165 #-} -happyOut165 :: (HappyAbsSyn ) -> (Located [LStmt RdrName]) +happyOut165 :: (HappyAbsSyn ) -> ([LPat RdrName]) happyOut165 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut165 #-} happyIn166 :: (Located [LStmt RdrName]) -> (HappyAbsSyn ) @@ -1034,76 +1025,76 @@ happyOut166 :: (HappyAbsSyn ) -> (Located [LStmt RdrName]) happyOut166 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut166 #-} -happyIn167 :: (Maybe (LStmt RdrName)) -> (HappyAbsSyn ) +happyIn167 :: (Located [LStmt RdrName]) -> (HappyAbsSyn ) happyIn167 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn167 #-} -happyOut167 :: (HappyAbsSyn ) -> (Maybe (LStmt RdrName)) +happyOut167 :: (HappyAbsSyn ) -> (Located [LStmt RdrName]) happyOut167 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut167 #-} -happyIn168 :: (LStmt RdrName) -> (HappyAbsSyn ) +happyIn168 :: (Located [LStmt RdrName]) -> (HappyAbsSyn ) happyIn168 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn168 #-} -happyOut168 :: (HappyAbsSyn ) -> (LStmt RdrName) +happyOut168 :: (HappyAbsSyn ) -> (Located [LStmt RdrName]) happyOut168 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut168 #-} -happyIn169 :: (LStmt RdrName) -> (HappyAbsSyn ) +happyIn169 :: (Maybe (LStmt RdrName)) -> (HappyAbsSyn ) happyIn169 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn169 #-} -happyOut169 :: (HappyAbsSyn ) -> (LStmt RdrName) +happyOut169 :: (HappyAbsSyn ) -> (Maybe (LStmt RdrName)) happyOut169 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut169 #-} -happyIn170 :: (([HsRecField RdrName (LHsExpr RdrName)], Bool)) -> (HappyAbsSyn ) +happyIn170 :: (LStmt RdrName) -> (HappyAbsSyn ) happyIn170 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn170 #-} -happyOut170 :: (HappyAbsSyn ) -> (([HsRecField RdrName (LHsExpr RdrName)], Bool)) +happyOut170 :: (HappyAbsSyn ) -> (LStmt RdrName) happyOut170 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut170 #-} -happyIn171 :: (([HsRecField RdrName (LHsExpr RdrName)], Bool)) -> (HappyAbsSyn ) +happyIn171 :: (LStmt RdrName) -> (HappyAbsSyn ) happyIn171 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn171 #-} -happyOut171 :: (HappyAbsSyn ) -> (([HsRecField RdrName (LHsExpr RdrName)], Bool)) +happyOut171 :: (HappyAbsSyn ) -> (LStmt RdrName) happyOut171 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut171 #-} -happyIn172 :: (HsRecField RdrName (LHsExpr RdrName)) -> (HappyAbsSyn ) +happyIn172 :: (([HsRecField RdrName (LHsExpr RdrName)], Bool)) -> (HappyAbsSyn ) happyIn172 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn172 #-} -happyOut172 :: (HappyAbsSyn ) -> (HsRecField RdrName (LHsExpr RdrName)) +happyOut172 :: (HappyAbsSyn ) -> (([HsRecField RdrName (LHsExpr RdrName)], Bool)) happyOut172 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut172 #-} -happyIn173 :: (Located [LIPBind RdrName]) -> (HappyAbsSyn ) +happyIn173 :: (([HsRecField RdrName (LHsExpr RdrName)], Bool)) -> (HappyAbsSyn ) happyIn173 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn173 #-} -happyOut173 :: (HappyAbsSyn ) -> (Located [LIPBind RdrName]) +happyOut173 :: (HappyAbsSyn ) -> (([HsRecField RdrName (LHsExpr RdrName)], Bool)) happyOut173 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut173 #-} -happyIn174 :: (LIPBind RdrName) -> (HappyAbsSyn ) +happyIn174 :: (HsRecField RdrName (LHsExpr RdrName)) -> (HappyAbsSyn ) happyIn174 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn174 #-} -happyOut174 :: (HappyAbsSyn ) -> (LIPBind RdrName) +happyOut174 :: (HappyAbsSyn ) -> (HsRecField RdrName (LHsExpr RdrName)) happyOut174 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut174 #-} -happyIn175 :: (Located (IPName RdrName)) -> (HappyAbsSyn ) +happyIn175 :: (Located [LIPBind RdrName]) -> (HappyAbsSyn ) happyIn175 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn175 #-} -happyOut175 :: (HappyAbsSyn ) -> (Located (IPName RdrName)) +happyOut175 :: (HappyAbsSyn ) -> (Located [LIPBind RdrName]) happyOut175 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut175 #-} -happyIn176 :: (Located [RdrName]) -> (HappyAbsSyn ) +happyIn176 :: (LIPBind RdrName) -> (HappyAbsSyn ) happyIn176 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn176 #-} -happyOut176 :: (HappyAbsSyn ) -> (Located [RdrName]) +happyOut176 :: (HappyAbsSyn ) -> (LIPBind RdrName) happyOut176 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut176 #-} -happyIn177 :: (Located RdrName) -> (HappyAbsSyn ) +happyIn177 :: (Located (IPName RdrName)) -> (HappyAbsSyn ) happyIn177 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn177 #-} -happyOut177 :: (HappyAbsSyn ) -> (Located RdrName) +happyOut177 :: (HappyAbsSyn ) -> (Located (IPName RdrName)) happyOut177 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut177 #-} -happyIn178 :: (Located RdrName) -> (HappyAbsSyn ) +happyIn178 :: (Located [RdrName]) -> (HappyAbsSyn ) happyIn178 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn178 #-} -happyOut178 :: (HappyAbsSyn ) -> (Located RdrName) +happyOut178 :: (HappyAbsSyn ) -> (Located [RdrName]) happyOut178 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut178 #-} happyIn179 :: (Located RdrName) -> (HappyAbsSyn ) @@ -1112,28 +1103,28 @@ happyOut179 :: (HappyAbsSyn ) -> (Located RdrName) happyOut179 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut179 #-} -happyIn180 :: (Located [Located RdrName]) -> (HappyAbsSyn ) +happyIn180 :: (Located RdrName) -> (HappyAbsSyn ) happyIn180 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn180 #-} -happyOut180 :: (HappyAbsSyn ) -> (Located [Located RdrName]) +happyOut180 :: (HappyAbsSyn ) -> (Located RdrName) happyOut180 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut180 #-} -happyIn181 :: (Located DataCon) -> (HappyAbsSyn ) +happyIn181 :: (Located RdrName) -> (HappyAbsSyn ) happyIn181 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn181 #-} -happyOut181 :: (HappyAbsSyn ) -> (Located DataCon) +happyOut181 :: (HappyAbsSyn ) -> (Located RdrName) happyOut181 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut181 #-} -happyIn182 :: (Located RdrName) -> (HappyAbsSyn ) +happyIn182 :: (Located [Located RdrName]) -> (HappyAbsSyn ) happyIn182 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn182 #-} -happyOut182 :: (HappyAbsSyn ) -> (Located RdrName) +happyOut182 :: (HappyAbsSyn ) -> (Located [Located RdrName]) happyOut182 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut182 #-} -happyIn183 :: (Located RdrName) -> (HappyAbsSyn ) +happyIn183 :: (Located DataCon) -> (HappyAbsSyn ) happyIn183 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn183 #-} -happyOut183 :: (HappyAbsSyn ) -> (Located RdrName) +happyOut183 :: (HappyAbsSyn ) -> (Located DataCon) happyOut183 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut183 #-} happyIn184 :: (Located RdrName) -> (HappyAbsSyn ) @@ -1190,28 +1181,28 @@ happyOut192 :: (HappyAbsSyn ) -> (Located RdrName) happyOut192 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut192 #-} -happyIn193 :: (LHsExpr RdrName) -> (HappyAbsSyn ) +happyIn193 :: (Located RdrName) -> (HappyAbsSyn ) happyIn193 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn193 #-} -happyOut193 :: (HappyAbsSyn ) -> (LHsExpr RdrName) +happyOut193 :: (HappyAbsSyn ) -> (Located RdrName) happyOut193 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut193 #-} -happyIn194 :: (LHsExpr RdrName) -> (HappyAbsSyn ) +happyIn194 :: (Located RdrName) -> (HappyAbsSyn ) happyIn194 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn194 #-} -happyOut194 :: (HappyAbsSyn ) -> (LHsExpr RdrName) +happyOut194 :: (HappyAbsSyn ) -> (Located RdrName) happyOut194 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut194 #-} -happyIn195 :: (Located RdrName) -> (HappyAbsSyn ) +happyIn195 :: (LHsExpr RdrName) -> (HappyAbsSyn ) happyIn195 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn195 #-} -happyOut195 :: (HappyAbsSyn ) -> (Located RdrName) +happyOut195 :: (HappyAbsSyn ) -> (LHsExpr RdrName) happyOut195 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut195 #-} -happyIn196 :: (Located RdrName) -> (HappyAbsSyn ) +happyIn196 :: (LHsExpr RdrName) -> (HappyAbsSyn ) happyIn196 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn196 #-} -happyOut196 :: (HappyAbsSyn ) -> (Located RdrName) +happyOut196 :: (HappyAbsSyn ) -> (LHsExpr RdrName) happyOut196 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut196 #-} happyIn197 :: (Located RdrName) -> (HappyAbsSyn ) @@ -1292,28 +1283,28 @@ happyOut209 :: (HappyAbsSyn ) -> (Located RdrName) happyOut209 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut209 #-} -happyIn210 :: (Located FastString) -> (HappyAbsSyn ) +happyIn210 :: (Located RdrName) -> (HappyAbsSyn ) happyIn210 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn210 #-} -happyOut210 :: (HappyAbsSyn ) -> (Located FastString) +happyOut210 :: (HappyAbsSyn ) -> (Located RdrName) happyOut210 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut210 #-} -happyIn211 :: (Located FastString) -> (HappyAbsSyn ) +happyIn211 :: (Located RdrName) -> (HappyAbsSyn ) happyIn211 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn211 #-} -happyOut211 :: (HappyAbsSyn ) -> (Located FastString) +happyOut211 :: (HappyAbsSyn ) -> (Located RdrName) happyOut211 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut211 #-} -happyIn212 :: (Located RdrName) -> (HappyAbsSyn ) +happyIn212 :: (Located FastString) -> (HappyAbsSyn ) happyIn212 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn212 #-} -happyOut212 :: (HappyAbsSyn ) -> (Located RdrName) +happyOut212 :: (HappyAbsSyn ) -> (Located FastString) happyOut212 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut212 #-} -happyIn213 :: (Located RdrName) -> (HappyAbsSyn ) +happyIn213 :: (Located FastString) -> (HappyAbsSyn ) happyIn213 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn213 #-} -happyOut213 :: (HappyAbsSyn ) -> (Located RdrName) +happyOut213 :: (HappyAbsSyn ) -> (Located FastString) happyOut213 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut213 #-} happyIn214 :: (Located RdrName) -> (HappyAbsSyn ) @@ -1328,64 +1319,64 @@ happyOut215 :: (HappyAbsSyn ) -> (Located RdrName) happyOut215 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut215 #-} -happyIn216 :: (Located HsLit) -> (HappyAbsSyn ) +happyIn216 :: (Located RdrName) -> (HappyAbsSyn ) happyIn216 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn216 #-} -happyOut216 :: (HappyAbsSyn ) -> (Located HsLit) +happyOut216 :: (HappyAbsSyn ) -> (Located RdrName) happyOut216 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut216 #-} -happyIn217 :: (()) -> (HappyAbsSyn ) +happyIn217 :: (Located RdrName) -> (HappyAbsSyn ) happyIn217 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn217 #-} -happyOut217 :: (HappyAbsSyn ) -> (()) +happyOut217 :: (HappyAbsSyn ) -> (Located RdrName) happyOut217 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut217 #-} -happyIn218 :: (Located ModuleName) -> (HappyAbsSyn ) +happyIn218 :: (Located HsLit) -> (HappyAbsSyn ) happyIn218 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn218 #-} -happyOut218 :: (HappyAbsSyn ) -> (Located ModuleName) +happyOut218 :: (HappyAbsSyn ) -> (Located HsLit) happyOut218 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut218 #-} -happyIn219 :: (Int) -> (HappyAbsSyn ) +happyIn219 :: (()) -> (HappyAbsSyn ) happyIn219 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn219 #-} -happyOut219 :: (HappyAbsSyn ) -> (Int) +happyOut219 :: (HappyAbsSyn ) -> (()) happyOut219 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut219 #-} -happyIn220 :: (LHsDocString) -> (HappyAbsSyn ) +happyIn220 :: (Located ModuleName) -> (HappyAbsSyn ) happyIn220 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn220 #-} -happyOut220 :: (HappyAbsSyn ) -> (LHsDocString) +happyOut220 :: (HappyAbsSyn ) -> (Located ModuleName) happyOut220 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut220 #-} -happyIn221 :: (LHsDocString) -> (HappyAbsSyn ) +happyIn221 :: (Int) -> (HappyAbsSyn ) happyIn221 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn221 #-} -happyOut221 :: (HappyAbsSyn ) -> (LHsDocString) +happyOut221 :: (HappyAbsSyn ) -> (Int) happyOut221 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut221 #-} -happyIn222 :: (Located (String, HsDocString)) -> (HappyAbsSyn ) +happyIn222 :: (LHsDocString) -> (HappyAbsSyn ) happyIn222 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn222 #-} -happyOut222 :: (HappyAbsSyn ) -> (Located (String, HsDocString)) +happyOut222 :: (HappyAbsSyn ) -> (LHsDocString) happyOut222 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut222 #-} -happyIn223 :: (Located (Int, HsDocString)) -> (HappyAbsSyn ) +happyIn223 :: (LHsDocString) -> (HappyAbsSyn ) happyIn223 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn223 #-} -happyOut223 :: (HappyAbsSyn ) -> (Located (Int, HsDocString)) +happyOut223 :: (HappyAbsSyn ) -> (LHsDocString) happyOut223 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut223 #-} -happyIn224 :: (Maybe LHsDocString) -> (HappyAbsSyn ) +happyIn224 :: (Located (String, HsDocString)) -> (HappyAbsSyn ) happyIn224 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn224 #-} -happyOut224 :: (HappyAbsSyn ) -> (Maybe LHsDocString) +happyOut224 :: (HappyAbsSyn ) -> (Located (String, HsDocString)) happyOut224 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut224 #-} -happyIn225 :: (Maybe LHsDocString) -> (HappyAbsSyn ) +happyIn225 :: (Located (Int, HsDocString)) -> (HappyAbsSyn ) happyIn225 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyIn225 #-} -happyOut225 :: (HappyAbsSyn ) -> (Maybe LHsDocString) +happyOut225 :: (HappyAbsSyn ) -> (Located (Int, HsDocString)) happyOut225 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut225 #-} happyIn226 :: (Maybe LHsDocString) -> (HappyAbsSyn ) @@ -1394,6 +1385,18 @@ happyOut226 :: (HappyAbsSyn ) -> (Maybe LHsDocString) happyOut226 x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyOut226 #-} +happyIn227 :: (Maybe LHsDocString) -> (HappyAbsSyn ) +happyIn227 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn227 #-} +happyOut227 :: (HappyAbsSyn ) -> (Maybe LHsDocString) +happyOut227 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut227 #-} +happyIn228 :: (Maybe LHsDocString) -> (HappyAbsSyn ) +happyIn228 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyIn228 #-} +happyOut228 :: (HappyAbsSyn ) -> (Maybe LHsDocString) +happyOut228 x = Happy_GHC_Exts.unsafeCoerce# x +{-# INLINE happyOut228 #-} happyInTok :: ((Located Token)) -> (HappyAbsSyn ) happyInTok x = Happy_GHC_Exts.unsafeCoerce# x {-# INLINE happyInTok #-} @@ -1403,21 +1406,21 @@ happyActOffsets :: HappyAddr -happyActOffsets = HappyA# "\x3d\x01\xcb\x1c\x3d\x32\xbd\x2d\x13\x00\x42\x34\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8c\x03\x00\x00\x00\x00\x00\x00\x27\x07\x2b\x07\x29\x07\x00\x00\x00\x00\xb3\x2e\xaa\x06\xe6\x06\x00\x00\x5d\x25\x00\x00\x00\x00\xeb\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf0\x35\x00\x00\x00\x00\x00\x00\xed\x06\x00\x00\xd1\xff\x3d\x28\xd7\x27\x0b\x25\x67\x26\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd7\x1f\x00\x00\xa2\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcd\x06\x4e\x07\xfc\x03\xa2\x33\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd3\x06\x00\x00\xe0\x06\x26\x21\x00\x00\xd7\x1f\xd7\x1f\xdf\x21\x00\x00\xd2\x06\x00\x00\xc0\x06\x82\x06\x00\x00\x00\x00\x00\x00\x00\x00\xbd\x06\x00\x00\x00\x00\xd7\x1f\x08\x04\xd7\x1f\x06\x04\xac\x06\xe0\x03\xdf\x21\xe0\x03\xa6\x06\x92\x06\x8f\x06\x59\x20\xdf\x21\xdf\x21\xdf\x21\xbf\x19\x41\x1a\xbb\x18\x39\x18\x61\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd7\x1f\xd7\x1f\xbd\x2d\xde\x03\x00\x00\xd7\x1f\x23\x33\x94\x33\x76\x06\xe5\x06\x29\x14\x00\x00\x29\x14\xa8\x06\x00\x00\x9a\x06\x00\x00\x87\x06\x96\x06\x00\x00\x00\x00\x00\x00\x61\x2e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x0d\x94\x06\x93\x06\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x2e\xca\x06\x99\x06\xdb\x06\xbb\x06\x00\x00\x00\x00\x00\x00\xbd\x2d\xc8\x03\x00\x00\x57\x2d\x39\x00\x8d\x06\x17\x34\x8d\x06\x7a\x06\xa3\x34\xa3\x34\x91\x34\xdf\x21\xb7\x17\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\xa0\x03\x00\x00\x00\x00\x91\x06\x8c\x06\xba\x03\x9f\x03\x00\x00\x00\x00\x27\x09\x8b\x06\x64\x06\xab\x14\xab\x14\x62\x06\x37\x0d\x5e\x06\x00\x00\x00\x00\x00\x00\x97\x06\x26\x21\x8e\x03\x7d\x06\x00\x00\xd7\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x35\x17\x00\x00\x00\x00\x73\x33\x37\x02\x7c\x06\x7b\x06\x79\x06\x78\x06\x77\x06\xb3\x16\xdf\x21\x00\x00\xed\x00\x6c\x06\x73\x06\xb8\x00\x74\x06\x69\x06\x00\x00\x00\x00\xdf\x21\x00\x00\x00\x00\x59\x20\xdf\x21\x59\x06\x8a\x06\x89\x06\x00\x00\xc3\x1a\xc3\x1a\x72\x06\x00\x00\x00\x00\x00\x00\xa4\x06\x31\x16\x31\x16\x63\x06\x00\x00\x85\x06\xdf\x21\xd7\x1f\xf6\x33\x00\x00\x00\x00\x00\x00\x00\x00\xd7\x1f\x00\x00\x05\x2d\xd7\x1f\xd7\x1f\xd7\x1f\xd7\x1f\xb3\x2e\x5a\x06\x55\x06\x6d\x03\x58\x06\x56\x06\x27\x02\x54\x06\x41\x06\x4d\x06\x38\x06\x6a\x03\x00\x00\xcb\x00\x3b\x06\x00\x00\x39\x06\x22\x02\x34\x06\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x06\x00\x00\x37\x06\x00\x00\x3c\x06\x00\x00\x1c\x01\x00\x00\x64\x35\x42\x06\x36\x06\xf0\x35\x00\x00\x29\x34\xb3\x2e\x00\x00\xb3\x2e\x00\x00\xb3\x2e\x00\x00\x05\x2d\xb3\x2e\x00\x00\xe6\x23\x05\x2d\x00\x00\x1e\x06\x51\x03\xcb\x04\x00\x00\x00\x00\x6e\x06\x00\x00\x21\x06\x1d\x06\x0f\x2e\x00\x00\x00\x00\xaf\x25\x00\x00\x00\x00\x3d\x06\x15\x06\x00\x00\x05\x2d\x00\x00\x9a\x00\x00\x00\x00\x00\xdc\x02\x18\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x95\x01\x00\x00\x05\x2d\x00\x00\x00\x00\x05\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x23\x06\x00\x00\x12\x06\x31\x06\x00\x00\x00\x00\x00\x00\x63\x03\x52\x06\x00\x00\x64\x01\x00\x00\x65\x2e\x62\x01\x00\x00\x30\x06\x46\x01\x2e\x01\xd7\x1f\xd7\x1f\x17\x00\x0f\x06\xc3\x1a\x1c\x06\xd7\x1f\x00\x00\x2c\x06\x00\x00\x59\x20\x2a\x06\x41\x1a\x00\x00\xd7\x1f\x49\x1c\x41\x1a\x00\x00\xd7\x1f\x49\x1c\x41\x1a\xe8\x05\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x19\x00\x00\x01\x06\xe9\x09\x00\x00\x00\x00\xd7\x1f\x41\x1a\x5d\x21\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\xef\x05\x00\x00\x00\x00\xcb\x04\x00\x00\x00\x00\x00\x00\xe6\x05\x21\x02\xdb\x20\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x20\xdb\x05\x86\x06\x87\x00\x00\x00\xdc\xff\xd9\x05\x42\x00\x00\x00\xdc\xff\x41\x00\x00\x00\xe1\x05\x42\x34\x00\x00\xd3\xff\xf7\x05\x05\x2d\x42\x34\x00\x00\x91\x04\x91\x04\xf5\x05\xb3\x2e\xb3\x2e\x1b\x06\x00\x00\x0e\x06\x0c\x06\xe7\x05\x05\x2d\x05\x2d\xb3\x2e\xe0\x05\xd5\x05\x00\x00\x64\x35\x21\x02\x9f\x2c\xfd\xff\xb3\x2e\xab\x14\xf9\x03\x00\x00\x29\x14\x00\x00\x00\x00\x00\x00\xba\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xea\x34\x00\x00\xfd\xff\xf8\x05\x04\x06\xcf\x05\x95\x01\x00\x00\x00\x00\x00\x00\xc0\x05\x00\x00\x53\x24\xce\x05\xf0\x35\x00\x00\x30\x00\x00\x00\xd7\x1f\x51\x1e\x12\x00\xb3\x2e\xe5\x05\x00\x00\xcd\x05\xaf\x05\x00\x00\x00\x00\x00\x00\x91\x05\x00\x00\x00\x00\x3f\x03\xcc\x05\xbf\x05\x39\x2c\x14\x32\x00\x00\x00\x00\x00\x00\xe9\x31\xc2\x05\xc1\x05\xd3\x2b\x83\x05\x96\x05\xac\x05\xc8\x05\x00\x00\x7d\x05\x00\x00\x74\x05\x00\x00\x00\x00\xa3\x34\xa3\x34\x00\x00\x00\x00\xa3\x34\x8c\x05\x89\x05\xdb\x20\xa4\x05\xa0\x05\x00\x00\x7c\x05\x78\x05\xdc\xff\xdc\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf4\x00\x00\x00\x00\x00\x00\x00\x6f\x00\x00\x00\x00\x00\x55\x1f\x00\x00\xab\x00\x00\x00\x00\x00\x00\x00\x8b\x05\xb3\x2e\x00\x00\x6e\x05\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x1a\x00\x00\x00\x00\x00\x00\x00\x00\x68\x05\x00\x00\x31\x16\xd3\x1e\x00\x00\x00\x00\xd3\x1e\x00\x00\xc7\x1b\xc7\x1b\xd3\x1e\xf6\x33\x00\x00\x00\x00\x00\x00\x73\x05\x72\x05\x85\x05\x00\x00\x00\x00\x95\x01\x4f\x05\xd3\x2b\x64\x35\x00\x00\x95\x01\xb3\x2e\x00\x00\x00\x00\x6d\x05\xa6\x05\xc0\x03\xb3\x2e\x65\x05\x00\x00\x48\x05\x00\x00\x46\x05\x5f\x05\x95\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x00\x5d\x05\x00\x00\x70\x05\xc7\x1b\x67\x05\x4c\x05\x00\x00\x00\x00\x00\x00\x6b\x05\x00\x00\x62\x05\x00\x00\xd3\x1e\xd3\x1e\x7b\x05\xc5\x04\x45\x1b\x45\x1b\xd3\x1e\x6c\x05\x69\x05\x88\x05\x00\x00\x00\x00\x66\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x00\x00\x00\x00\x00\xd3\x1e\x43\x35\xd3\x2b\x00\x00\x47\x05\x3a\x05\x5c\x05\x00\x00\x00\x00\xd7\x31\x00\x00\x5b\x05\x53\x05\x45\x05\x43\x05\x1d\x35\x00\x00\x00\x00\x44\x05\xa5\x24\x41\x05\xf0\x35\xd3\x2b\x00\x00\x00\x00\x2d\x15\x2d\x15\x19\x03\x00\x00\x00\x00\x00\x00\x1c\x05\x00\x00\xab\x35\x00\x00\x0d\x03\x00\x00\x6d\x2b\x3e\x05\x1a\x05\x00\x00\x5a\x05\x00\x00\x00\x00\xec\x02\x24\x05\xb3\x2e\xb3\x2e\xb3\x2e\x2e\x05\x07\x2b\xb3\x2e\x07\x2b\x00\x00\xf9\x04\x00\x00\x01\x03\x5e\x05\xcf\x02\x49\x05\x58\x05\xff\x04\xfe\x04\xf9\x03\x00\x00\x00\x00\x00\x00\x00\x00\x52\x05\x0a\x06\x0a\x06\x00\x00\x00\x00\x71\x27\xf6\xff\x00\x00\x3d\x05\x00\x00\x0b\x27\x00\x00\xa1\x2a\x84\x00\x16\x00\xf9\x00\x3b\x2a\x00\x00\x00\x00\x51\x1e\xd3\x1e\x00\x00\x00\x00\xaf\x15\xaf\x15\x00\x00\x00\x00\x00\x00\x55\x05\x00\x00\xb3\x2e\x00\x00\x3d\x00\x00\x00\x00\x00\xb3\x2e\xec\x00\x00\x00\x06\x05\xb3\x2e\xb3\x2e\xb3\x2e\xd5\x29\xb3\x2e\xd5\x29\x15\x05\xd5\x29\x00\x00\x00\x00\x6f\x29\x00\x00\x17\x05\x01\x05\xfc\x34\x00\x00\x8a\x35\xa5\x13\x00\x00\xdb\x04\x00\x00\xce\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd3\x1e\xd3\x1e\xd3\x1e\x00\x00\x00\x00\xd8\x04\x3b\x05\x00\x00\x00\x00\x19\x00\x6f\x29\xcf\x1d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe7\x04\x00\x00\x02\x33\xc0\x03\x00\x00\x00\x00\x00\x00\xaa\x02\x00\x00\x31\x05\x31\x05\x00\x00\xc0\x03\xe4\x04\x00\x00\xb3\x01\x39\x07\xc0\x03\x00\x00\x00\x00\x00\x00\x0e\x05\xee\x04\x00\x00\x4d\x1d\xd3\x1e\xd3\x1e\xe8\x04\x00\x00\x00\x00\xf2\x04\x00\x00\x29\x14\x29\x14\x00\x00\xd3\x1e\xdf\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x29\x0f\x2e\xa3\x04\xa3\x04\x00\x00\x09\x29\x00\x00\x2d\x15\xd7\x04\x00\x00\xdd\xff\x34\x00\xb3\x01\x00\x00\xd7\x35\x00\x00\x00\x00\x3b\x00\x00\x00\xb3\x2e\xb3\x2e\xc7\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x2e\xbd\x35\xd2\x04\xba\x04\xb4\x04\x00\x00\x17\x00\xb3\x04\xb0\x04\xd1\x04\xbd\x04\xd8\x01\xb7\x04\xb9\x04\x00\x00\x00\x00\xae\x04\xd1\xff\xa3\x28\xd2\x02\x0a\x06\x00\x00\x00\x00\xa3\x28\x82\x04\xb6\x04\xb1\x04\x01\x26\x7c\x04\x00\x00\xaf\x15\xaf\x04\xaa\x04\x00\x00\x00\x00\x00\x00\x00\x00\x80\x04\xc0\x03\xc7\x04\xcd\x04\xa3\x28\x00\x00\x00\x00\xa3\x28\x00\x00\x17\x00\x7d\x04\xd3\x1e\x64\x04\x00\x00\x00\x00\x83\x04\x00\x00\x00\x00\x00\x00\x00\x00\x91\x32\x61\x04\x5f\x04\x5f\x04\xc0\x03\xf0\x01\x00\x00\x00\x00\xe5\x04\x59\x04\x00\x00\xd3\x1e\x76\x04\x00\x00\x00\x00\x00\x00\x4e\x04\x00\x00\x00\x00\x9a\x04\x4c\x04\xc0\x03\x00\x00\x00\x00\xa3\x28\x00\x00\x00\x00\xb3\x2e\xb3\x2e\x32\x04\xb3\x2e\x00\x00\x18\x04\x00\x00\x00\x00\x00\x00\x0d\x01\x00\x00\x3d\x04\x40\x04\x00\x00\xb9\x26\x10\x04\xb3\x2e\xb3\x2e\x00\x00\x21\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd0\x01\x00\x00\xb2\x32\x00\x00\x00\x00\x00\x00\x00\x00\xa3\x28\x00\x00\x00\x00"# +happyActOffsets = HappyA# "\x58\x00\x18\x1e\x48\x33\xfc\x2c\x33\x00\x6b\x35\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb0\x06\x00\x00\x00\x00\x00\x00\x95\x07\x9b\x07\xa6\x07\x00\x00\x00\x00\x98\x07\x00\x00\xef\x2d\x1d\x07\x5b\x07\x00\x00\x3e\x25\x00\x00\x00\x00\x62\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf6\x36\x00\x00\x00\x00\x00\x00\x5f\x07\x00\x00\x4d\x00\xce\x27\x7b\x27\xeb\x24\x33\x26\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x21\x00\x00\x13\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3f\x07\xf8\x2c\x10\x04\xa0\x34\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x46\x07\x00\x00\x51\x07\x81\x21\x00\x00\x36\x21\x36\x21\x4a\x23\x00\x00\x45\x07\x00\x00\x50\x07\x06\x07\x00\x00\x00\x00\x00\x00\x00\x00\x36\x07\x00\x00\x00\x00\x36\x21\x09\x04\x36\x21\x03\x04\x18\x07\xda\x03\x4a\x23\xda\x03\x17\x07\x16\x07\x09\x07\xbb\x21\x4a\x23\x4a\x23\x4a\x23\xfa\x1a\x7f\x1b\xf0\x19\x6b\x19\xcf\x23\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x21\x36\x21\xfc\x2c\xd4\x03\x00\x00\x36\x21\x34\x34\x87\x34\xee\x06\x60\x07\x39\x14\x00\x00\x39\x14\x20\x07\x00\x00\x12\x07\x00\x00\x00\x07\x0c\x07\x00\x00\x00\x00\x00\x00\x9e\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8e\x22\x0d\x07\x08\x07\x00\x00\x00\x00\x00\x00\x00\x00\xef\x2d\x44\x07\x0b\x07\x53\x07\x28\x07\x00\x00\x00\x00\x00\x00\xfc\x2c\xc1\x03\x00\x00\xa9\x2c\x13\x00\x03\x07\x19\x35\x03\x07\xef\x06\xba\x35\xba\x35\x8c\x35\x6b\x35\x6b\x35\x6b\x35\x4a\x23\xe6\x18\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x6d\x03\x00\x00\x00\x00\xff\x06\xfa\x06\x20\x04\xa6\x03\x00\x00\x00\x00\x9a\x2d\xf2\x06\xd2\x06\xbe\x14\xbe\x14\xce\x06\xf2\x02\xcc\x06\x00\x00\x00\x00\x00\x00\xf1\x06\x81\x21\x96\x03\xdc\x06\x00\x00\x36\x21\x00\x00\x00\x00\x00\x00\x00\x00\x61\x18\x00\x00\x00\x00\x74\x23\x1c\x02\xed\x06\xec\x06\xe9\x06\xdd\x06\xdb\x06\xdc\x17\x4a\x23\x00\x00\x69\x01\xd3\x06\xda\x06\xe3\x00\xd5\x06\xc6\x06\x00\x00\x00\x00\x4a\x23\x00\x00\x00\x00\xbb\x21\x4a\x23\xb6\x06\xd8\x06\xd6\x06\x00\x00\x04\x1c\x04\x1c\xcd\x06\x00\x00\x00\x00\x00\x00\x02\x07\x57\x17\x57\x17\xac\x06\x00\x00\xf6\x06\x4a\x23\x36\x21\x07\x35\x00\x00\x00\x00\x00\x00\x00\x00\x36\x21\x00\x00\x58\x2c\x36\x21\x36\x21\x36\x21\x36\x21\xef\x2d\xba\x06\xa2\x06\x8c\x03\xb2\x06\xaf\x06\x02\x02\xae\x06\xad\x06\x9f\x06\xa8\x06\x8b\x03\x00\x00\x6e\x01\xab\x06\x00\x00\xa7\x06\xcf\x01\xa1\x06\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x06\x00\x00\xa0\x06\x00\x00\xa5\x06\x00\x00\xbf\xff\x00\x00\x56\x36\xaa\x06\xa3\x06\xf6\x36\x00\x00\xfc\x23\xef\x2d\x00\x00\xef\x2d\x00\x00\xef\x2d\x00\x00\x58\x2c\xef\x2d\x00\x00\xb2\x34\x58\x2c\x00\x00\x8c\x06\x8c\x06\x48\x03\xe5\x04\x00\x00\x00\x00\xde\x06\x00\x00\x8e\x06\x87\x06\x4d\x2d\x00\x00\x00\x00\x8f\x25\x00\x00\x00\x00\xa9\x06\x80\x06\x00\x00\x58\x2c\x00\x00\xba\x00\x00\x00\x00\x00\x49\x02\x7d\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x02\x00\x00\x58\x2c\x00\x00\x00\x00\x58\x2c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8b\x06\x00\x00\x79\x06\x99\x06\x00\x00\x00\x00\x00\x00\x5a\x03\xc0\x06\x00\x00\x61\x00\x00\x00\x42\x06\x1b\x00\x00\x00\x96\x06\x49\x01\x0a\x01\x36\x21\x36\x21\x0b\x00\x68\x06\x04\x1c\x83\x06\x36\x21\x00\x00\x8f\x06\x00\x00\xbb\x21\x74\x06\x7f\x1b\x00\x00\x36\x21\x93\x1d\x7f\x1b\x00\x00\x36\x21\x93\x1d\x7f\x1b\x65\x06\x00\x00\x00\x00\x00\x00\x00\x00\x75\x1a\x00\x00\x53\x06\x01\x07\x00\x00\x00\x00\x36\x21\x7f\x1b\xc5\x22\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x6b\x06\x00\x00\x00\x00\xe5\x04\x00\x00\x00\x00\x00\x00\x56\x06\x83\x02\x78\x06\x76\x06\x6d\x06\x40\x22\x00\x00\x00\x00\x00\x00\x00\x00\x40\x22\x46\x06\xbb\x08\xb7\x00\x00\x00\xf8\xff\x48\x06\x83\x00\x00\x00\xf8\xff\x5e\x00\x00\x00\x50\x06\x6b\x35\x00\x00\x68\x00\x66\x06\x58\x2c\x6b\x35\x00\x00\xd4\x04\xd4\x04\x62\x06\xef\x2d\xef\x2d\x92\x06\x00\x00\x7f\x06\x77\x06\x58\x06\x58\x2c\x58\x2c\xef\x2d\x40\x06\x3e\x06\x00\x00\x56\x36\x83\x02\x05\x2c\xb1\x00\xef\x2d\xbe\x14\xe8\x05\x00\x00\x39\x14\x00\x00\x00\x00\x00\x00\x1d\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdb\x35\x00\x00\xb1\x00\x64\x06\x75\x06\x3b\x06\x01\x02\x00\x00\x00\x00\x00\x00\x33\x06\x00\x00\x45\x24\x38\x06\xf6\x36\x00\x00\x67\x00\x00\x00\x36\x21\xa7\x1f\x7b\x00\xef\x2d\x5d\x06\x00\x00\x35\x06\x1a\x06\x00\x00\x00\x00\x00\x00\x51\x06\x00\x00\x00\x00\x59\x03\x1b\x06\x16\x06\xb2\x2b\x1f\x33\x00\x00\x00\x00\x00\x00\xdf\x32\x19\x06\x18\x06\x5f\x2b\xe3\x05\xfb\x05\x11\x06\x31\x06\x00\x00\xdc\x05\x00\x00\xda\x05\x00\x00\x00\x00\xba\x35\xba\x35\x00\x00\x00\x00\xba\x35\xec\x05\xe5\x05\x40\x22\xfe\x05\xfd\x05\x36\x21\x00\x00\x00\x00\x00\x00\xca\x05\xd5\x05\xf8\xff\xf8\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\x00\x00\x00\x00\x00\x00\x00\xd2\xff\x00\x00\x00\x00\xb1\x20\x00\x00\xdb\x00\x00\x00\x00\x00\x00\x00\xdf\x05\xef\x2d\x00\x00\xbe\x05\x00\x00\x00\x00\x00\x00\x00\x00\x04\x1c\x00\x00\x00\x00\x00\x00\x00\x00\xb5\x05\x00\x00\x57\x17\x2c\x20\x00\x00\x00\x00\x2c\x20\x00\x00\x0e\x1d\x0e\x1d\x2c\x20\x07\x35\x00\x00\x00\x00\x00\x00\xc5\x05\xc4\x05\xd9\x05\x00\x00\x00\x00\x01\x02\xa3\x05\x5f\x2b\x56\x36\x00\x00\x01\x02\xef\x2d\x00\x00\x00\x00\xbd\x05\xf0\x05\x04\x04\xef\x2d\xbb\x05\x00\x00\x8e\x05\x00\x00\x9d\x05\xb3\x05\x01\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x96\x05\x00\x00\xb6\x05\x0e\x1d\xa2\x05\x8c\x05\x00\x00\x00\x00\x00\x00\xb2\x05\x00\x00\xa5\x05\x00\x00\x2c\x20\x2c\x20\xc0\x05\xeb\x04\x89\x1c\x89\x1c\x2c\x20\xae\x05\xac\x05\xcc\x05\xa7\x05\x00\x00\x00\x00\xa4\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x74\x01\x00\x00\x00\x00\x2c\x20\x44\x36\x5f\x2b\x00\x00\x8a\x05\x78\x05\x89\x05\x00\x00\x00\x00\xeb\x22\x00\x00\x98\x05\x90\x05\x85\x05\x7d\x05\x16\x36\x00\x00\x00\x00\x7a\x05\x96\x24\x7c\x05\xf6\x36\x5f\x2b\x00\x00\x00\x00\xd2\x16\xd2\x16\x49\x05\x00\x00\x00\x00\x00\x00\x55\x05\x00\x00\x96\x36\x00\x00\x45\x03\x00\x00\x0c\x2b\x75\x05\x4d\x05\x00\x00\x8f\x05\x00\x00\x00\x00\x3a\x03\x56\x05\xef\x2d\xef\x2d\xef\x2d\x5e\x05\xb9\x2a\xef\x2d\xb9\x2a\x00\x00\x2c\x05\x00\x00\xa1\x01\x9a\x05\xc3\x02\x86\x05\x95\x05\x38\x05\x37\x05\xe8\x05\x00\x00\x00\x00\x00\x00\x00\x00\x91\x05\xe0\x08\xe0\x08\x00\x00\x00\x00\x28\x27\xe2\xff\x00\x00\x79\x05\x00\x00\xd5\x26\x00\x00\x66\x2a\xf6\xff\xe6\xff\xd9\x01\x13\x2a\x00\x00\x00\x00\xa7\x1f\x2c\x20\x00\x00\x00\x00\x4d\x16\x4d\x16\x00\x00\x00\x00\x00\x00\xde\x02\x00\x00\x00\x00\xef\x2d\x00\x00\x17\x00\x00\x00\x00\x00\xef\x2d\xbe\x00\x00\x00\x3f\x05\xef\x2d\xef\x2d\xef\x2d\xc0\x29\xef\x2d\xc0\x29\x50\x05\xc0\x29\x00\x00\x00\x00\x6d\x29\x00\x00\x4f\x05\x3e\x05\x04\x36\x00\x00\x84\x36\x66\x04\x00\x00\x1b\x05\x00\x00\x00\x00\xb6\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x20\x2c\x20\x2c\x20\x00\x00\x00\x00\x17\x05\x7b\x05\x00\x00\x00\x00\x4e\x01\x6d\x29\x22\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2a\x05\x00\x00\x13\x34\x04\x04\x00\x00\x00\x00\x00\x00\xac\x02\x00\x00\x76\x05\x76\x05\x00\x00\x04\x04\x27\x05\x00\x00\x5c\x02\xd8\x04\x04\x04\x00\x00\x00\x00\x00\x00\x5c\x05\x3a\x05\x00\x00\x9d\x1e\x2c\x20\x2c\x20\x34\x05\x00\x00\x00\x00\x43\x05\x00\x00\x39\x14\x39\x14\x00\x00\x2c\x20\x29\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x29\x4d\x2d\xf4\x04\xf4\x04\x00\x00\x1a\x29\x00\x00\xc8\x15\x25\x05\x00\x00\x89\x00\x60\x05\x00\x00\xcd\x36\x00\x00\x00\x00\x0d\x00\x00\x00\xef\x2d\x2c\x20\xef\x2d\x71\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xef\x2d\xbf\x36\x19\x05\x0d\x05\x0c\x05\x00\x00\x0b\x00\x04\x05\x00\x05\x1a\x05\x10\x05\x36\x01\x0a\x05\x06\x05\x00\x00\x00\x00\xfb\x04\x4d\x00\xc7\x28\x39\x01\xe0\x08\x00\x00\x00\x00\xc7\x28\xda\x04\x02\x05\x09\x05\xe0\x25\xd6\x04\x00\x00\x43\x15\xd0\x04\x81\x03\x07\x05\x00\x00\x09\x00\x5c\x02\x2b\x05\x3c\x05\xc7\x28\x00\x00\x00\x00\xc7\x28\x00\x00\x0b\x00\xef\x04\x2c\x20\xb9\x04\x00\x00\x00\x00\xe1\x04\x00\x00\x00\x00\x00\x00\x00\x00\x9f\x33\xc2\x04\xb3\x04\xb3\x04\x04\x04\xc7\x01\x00\x00\x00\x00\xdd\x08\xb6\x04\x00\x00\x2c\x20\xd1\x04\x00\x00\x00\x00\x00\x00\xa6\x04\x00\x00\x00\x00\x01\x05\x00\x00\x00\x00\x00\x00\xa4\x04\x04\x04\x00\x00\x74\x28\x00\x00\x21\x28\x00\x00\x00\x00\xef\x2d\xef\x2d\x88\x04\xef\x2d\x00\x00\x59\x04\x00\x00\x00\x00\x00\x00\x1a\x01\x00\x00\x7c\x04\x72\x04\x00\x00\x84\x26\x41\x04\xef\x2d\xef\x2d\x00\x00\x00\x00\x43\x04\x04\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x01\x00\x00\xc0\x33\x00\x00\x00\x00\x17\x04\x00\x00\x00\x00\x21\x28\x00\x00\x00\x00\x00\x00"# happyGotoOffsets :: HappyAddr -happyGotoOffsets = HappyA# "\x01\x00\x6a\x0c\x8a\x00\x6b\x2f\x03\x00\x47\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x69\x02\x00\x00\x00\x00\x00\x00\x00\x00\xd0\x04\x00\x00\x00\x00\x00\x00\x78\x23\x00\x00\x00\x00\x00\x00\xd8\x1f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5a\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6d\x01\x59\x2f\x1c\x2f\x58\x08\x16\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x89\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa6\x07\x91\x03\xf6\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2a\x0b\x00\x00\x6b\x11\x4d\x11\x59\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x29\x11\xdb\x03\x0b\x11\xac\x04\x00\x00\xce\x03\x32\x13\xcb\x03\x00\x00\x00\x00\x00\x00\x6d\x12\x23\x13\x35\x05\x11\x13\x5d\x07\xfe\x06\x40\x06\x9f\x06\xc5\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xed\x10\xe9\x11\x14\x2f\xd2\x03\x00\x00\xc9\x10\x6d\x04\x6f\x03\x00\x00\x00\x00\x1e\x01\x00\x00\xfa\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x04\x00\x00\x00\x00\x00\x00\x00\x00\x96\x07\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd5\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xda\x06\x00\x00\x00\x00\x00\x00\x33\x04\x00\x00\x00\x00\x00\x00\xf9\x22\x9d\x04\x00\x00\xd6\x30\x03\x04\x92\x04\xd4\x02\x75\x04\x49\x04\x42\x03\x7c\x01\xf4\x02\xff\x12\xda\x05\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x03\x72\x03\x00\x00\x00\x00\x00\x00\x00\x00\x50\x01\x27\x03\x00\x00\x00\x00\xa6\x07\x00\x00\x00\x00\x6b\x02\xfa\x01\x00\x00\x2a\x0b\x00\x00\x00\x00\x73\x03\x00\x00\x00\x00\x33\x07\xb6\xff\x00\x00\x00\x00\xcb\x11\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x08\x00\x00\x00\x00\x43\x02\xb6\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x08\x35\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc9\x12\x00\x00\x00\x00\x4c\x12\xb5\x12\x00\x00\x00\x00\x00\x00\x00\x00\x31\x0c\xf8\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xec\x04\x7f\x04\x78\x03\x00\x00\x00\x00\x8e\x12\xab\x10\xa1\x01\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x12\x00\x00\x9d\x23\x8d\x10\x69\x10\x4b\x10\x2d\x10\xaa\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0f\x01\x00\x00\xe3\xff\x00\x00\x00\x00\x0c\x02\x00\x00\xa2\x01\x8f\x30\x00\x00\x7f\x30\x00\x00\x6a\x30\x00\x00\xe5\x2e\x27\x31\x00\x00\xc8\x01\xd0\x2e\x00\x00\x00\x00\x17\x03\xe3\x03\x00\x00\x00\x00\xc2\x03\x00\x00\x00\x00\x00\x00\x5e\x21\x00\x00\x00\x00\xec\x0a\x00\x00\x00\x00\x00\x00\x0a\x03\x00\x00\xa2\x2e\x00\x00\x00\x00\x00\x00\x00\x00\xda\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x12\x04\x00\x00\x22\x2a\x00\x00\x00\x00\xf2\x26\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x28\x03\x00\x00\x00\x00\xfb\x02\x00\x00\xd5\x04\xf1\x02\x00\x00\x00\x00\x00\x00\x00\x00\x09\x10\xeb\x0f\xe6\x02\xe8\x02\xbf\x0b\x00\x00\xcd\x0f\x00\x00\x00\x00\x00\x00\x2b\x12\x3c\x03\x97\x09\x00\x00\xa9\x0f\x32\x0a\x38\x09\x00\x00\x8b\x0f\xf6\x09\xd9\x08\x9e\xff\x00\x00\x00\x00\x00\x00\x00\x00\xbc\x07\x00\x00\x00\x00\xbe\x04\x00\x00\x00\x00\x0d\x12\x7a\x08\x32\x03\x00\x00\x00\x00\x00\x00\x00\x00\x9a\x02\x00\x00\x00\x00\x00\x00\x61\x03\x00\x00\x00\x00\x00\x00\x00\x00\x1e\x04\x7f\x12\x00\x00\x00\x00\x00\x00\x00\x00\xcb\x05\xa5\x02\x0b\x01\x00\x00\x00\x00\x0e\x03\x00\x00\x00\x00\x00\x00\x03\x03\x00\x00\x00\x00\x26\x04\x87\x02\x00\x00\x00\x00\x00\x00\xe6\x22\x1a\x02\x00\x00\xf8\x02\xf2\x02\x00\x00\x46\x30\x28\x30\x00\x00\x00\x00\xfa\x02\xe4\x02\x00\x00\xd4\x22\x8c\x24\x18\x30\xa8\x02\x00\x00\x00\x00\xcd\xff\xb3\x03\x6b\x08\x44\x00\x88\x06\xd8\x02\xb5\x00\x00\x00\xdc\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x01\x00\x00\x31\x00\x92\x02\x89\x02\x00\x00\xb6\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x07\x00\x00\x02\x02\x00\x00\xe1\xff\x00\x00\x6d\x0f\x86\x0b\x00\x00\x06\x30\xb5\x02\x4c\x03\xa7\x02\x00\x00\x00\x00\x00\x00\x00\x00\xb1\x02\x00\x00\x00\x00\x96\x02\x75\x02\x00\x00\x4e\x2d\x80\x00\x00\x00\x00\x00\x00\x00\xbe\x00\x00\x00\x00\x00\xc4\x22\x00\x00\x00\x00\x00\x00\x5d\x02\x00\x00\x5b\x02\x00\x00\x4d\x02\x00\x00\x00\x00\x08\x01\xe1\x03\x00\x00\x00\x00\x44\x02\x00\x00\x00\x00\x68\x01\x00\x00\x00\x00\x00\x00\x00\x00\x79\x02\x42\x02\x30\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x49\x0f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xde\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x0b\x00\x00\x00\x00\x00\x00\x00\x00\xe7\x02\x00\x00\x77\x05\x2b\x0f\x00\x00\x00\x00\x0d\x0f\x00\x00\x14\x0b\xed\x0a\xe9\x0e\xf6\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa7\x03\xd6\x01\x9a\x2e\xf6\x00\x00\x00\x5f\x03\x16\x31\x00\x00\x00\x00\x62\x02\x00\x00\x86\x00\x5a\x20\x00\x00\x00\x00\xd5\x01\x00\x00\x9f\xff\x00\x00\x1b\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x01\x00\x00\x00\x00\x0b\x02\x98\x05\x00\x00\xd4\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcb\x0e\xad\x0e\x00\x00\x00\x00\x6c\x0a\xa3\x0c\x89\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xad\x11\xd9\xff\x52\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd8\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9d\x00\x00\x00\x00\x00\x00\x00\x80\x06\x00\x00\xc6\x00\x3e\x2d\x00\x00\x00\x00\x66\x03\xf9\x02\x70\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x82\xff\x00\x00\x0e\x02\x00\x00\x02\x27\x00\x00\x00\x00\x00\x00\xfb\x01\x00\x00\x00\x00\x2d\x03\x00\x00\xf6\x2f\xe2\x2f\xd2\x2f\x00\x00\x5d\x29\x03\x31\x91\x28\x00\x00\x06\x00\x00\x00\x57\x02\xb9\x01\x00\x00\xaf\x01\xb0\x01\x00\x00\x00\x00\x3f\x01\x00\x00\x00\x00\x00\x00\x00\x00\xa9\x01\xd2\x05\x36\x04\x00\x00\x00\x00\x40\x22\xad\x00\x00\x00\xa4\x01\x00\x00\x5a\x20\x00\x00\x96\x2c\x34\x01\x2a\x01\x00\x00\xc5\x27\x00\x00\x00\x00\x16\x0d\x6b\x0e\x00\x00\x00\x00\x5e\x04\xf1\x03\x00\x00\x99\x01\xa0\x02\xd7\x01\x00\x00\xc1\x04\x00\x00\xde\x00\x00\x00\x00\x00\x9f\x2f\x00\x00\x00\x00\x00\x00\x8f\x2f\x49\x2f\x55\x29\xca\x2b\xf3\x30\xfe\x2a\x00\x00\xf8\x25\x00\x00\x00\x00\x29\x09\x00\x00\x00\x00\x00\x00\xd7\xff\x00\x00\x83\xff\xbe\x04\x00\x00\x00\x00\x00\x00\xa0\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x0e\x29\x0e\x0b\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xed\x03\x8d\x23\xdd\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3f\x02\x54\x00\x00\x00\x00\x00\x00\x00\x98\x01\x00\x00\xc0\x02\xae\x02\x00\x00\x1d\x00\x00\x00\x00\x00\xc5\x00\xad\x03\xfa\xff\x00\x00\x00\x00\x00\x00\x5b\x01\xdb\x00\x00\x00\xae\x0a\xed\x0d\xaf\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\x00\x08\x00\x00\x00\x91\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd0\x23\x5a\x20\x91\x00\x6d\x00\x00\x00\x32\x2a\x00\x00\xd3\x03\x00\x00\x00\x00\x1c\x00\xa8\x01\x38\x00\x00\x00\x82\xff\x00\x00\x00\x00\x4c\x00\x00\x00\x89\x28\xe3\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe6\x25\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcc\xff\x1b\x23\x00\x01\xb0\x02\x00\x00\x00\x00\xd4\x09\xc3\x01\x00\x00\x00\x00\x83\x09\x58\x01\x00\x00\x59\x05\xcf\x00\xbc\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x85\x00\x4f\x00\x86\x2c\x00\x00\x00\x00\xba\x2b\x00\x00\xa4\xff\x00\x00\x73\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdc\x00\x00\x00\x00\x00\x00\x00\x25\x00\x00\x00\x00\x00\x00\x00\xea\x01\x00\x00\x00\x00\x4f\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x23\x00\x00\x00\x14\x00\x00\x00\x00\x00\xee\x2a\x00\x00\x00\x00\xe9\x2d\x37\x25\x7e\xff\xbd\x27\x00\x00\x9a\xff\x00\x00\x00\x00\x00\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x09\xd5\x00\x5a\x20\x5a\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x02\x00\x00\xfb\xff\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x23\x00\x00\x00\x00"# +happyGotoOffsets = HappyA# "\x01\x00\x1f\x0c\x7c\x00\x61\x32\x03\x00\xa2\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1e\x02\x00\x00\x00\x00\x00\x00\x00\x00\xde\x04\x00\x00\x00\x00\x00\x00\xdb\x04\x00\x00\xcd\x21\x00\x00\x00\x00\x00\x00\x3a\x21\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xca\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x59\x32\x24\x32\x1b\x08\x68\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1e\x11\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x19\x08\xb8\x03\xdc\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x51\x0b\x00\x00\x00\x11\xdf\x10\x67\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc1\x10\xe9\x03\xa3\x10\xb2\x04\x00\x00\xd2\x03\x49\x13\xcc\x03\x00\x00\x00\x00\x00\x00\x2c\x12\x2b\x13\xeb\x09\x0d\x13\xb1\x06\x52\x06\x93\x05\xf2\x05\x6f\x05\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7f\x10\x96\x11\x1c\x32\xd7\x03\x00\x00\x61\x10\x90\x03\x28\x05\x00\x00\x00\x00\x0d\x01\x00\x00\xef\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x04\x00\x00\x00\x00\x00\x00\x00\x00\xea\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x06\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x90\x06\x00\x00\x00\x00\x00\x00\x24\x04\x00\x00\x00\x00\x00\x00\x80\x2e\x6d\x04\x00\x00\x2b\x1f\xe8\x03\xa9\x04\x74\x03\x90\x04\x64\x04\xdc\x02\x72\x01\x79\x04\xbc\x02\xaf\x02\x9e\x02\xef\x12\x33\x05\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x03\x5c\x03\x00\x00\x00\x00\x00\x00\x00\x00\x5e\x01\x52\x03\x00\x00\x00\x00\x19\x08\x00\x00\x00\x00\x60\x02\xf0\x01\x00\x00\x51\x0b\x00\x00\x00\x00\xa3\x03\x00\x00\x00\x00\x18\x0b\x91\xff\x00\x00\x00\x00\x78\x11\x00\x00\x00\x00\x00\x00\x00\x00\x70\x07\x00\x00\x00\x00\xc0\x01\x91\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x07\xeb\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd1\x12\x00\x00\x00\x00\xf3\x11\xb3\x12\x00\x00\x00\x00\x00\x00\x00\x00\xe6\x0b\xad\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x86\x04\x46\x04\xa4\x03\x00\x00\x00\x00\x95\x12\x43\x10\x0e\x04\x00\x00\x00\x00\x00\x00\x00\x00\xb4\x11\x00\x00\x14\x2f\x22\x10\x04\x10\xe6\x0f\xc2\x0f\xa6\x1e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x42\x01\x00\x00\xec\xff\x00\x00\x00\x00\x92\x01\x00\x00\x91\x02\x21\x1e\x00\x00\x9c\x1d\x00\x00\x92\x1c\x00\x00\xe7\x31\xba\x20\x00\x00\x02\x01\xd6\x31\x00\x00\x00\x00\x00\x00\x3e\x03\x14\x04\x00\x00\x00\x00\xf4\x03\x00\x00\x00\x00\x00\x00\xbd\x21\x00\x00\x00\x00\xc8\x08\x00\x00\x00\x00\x00\x00\x46\x03\x00\x00\xaa\x31\x00\x00\x00\x00\x00\x00\x00\x00\xed\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x04\x00\x00\x5a\x30\x00\x00\x00\x00\x1d\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x72\x03\x00\x00\x00\x00\x2f\x03\x00\x00\x24\x06\x2c\x03\x00\x00\x00\x00\x00\x00\x00\x00\xa4\x0f\x86\x0f\x1b\x03\x41\x03\x74\x0b\x00\x00\x65\x0f\x00\x00\x00\x00\x00\x00\xd2\x11\x8e\x03\xee\x08\x00\x00\x47\x0f\x8a\x09\x8f\x08\x00\x00\x29\x0f\x4e\x09\x2f\x08\x90\xff\x00\x00\x00\x00\x00\x00\x00\x00\x11\x07\x00\x00\x00\x00\xb9\x07\x00\x00\x00\x00\xb4\x11\xd0\x07\x5f\x01\x00\x00\x00\x00\x00\x00\x00\x00\xff\x02\x00\x00\x00\x00\x00\x00\xbe\x03\x00\x00\x00\x00\x00\x00\x00\x00\x68\x04\x00\x00\x00\x00\x00\x00\x74\x12\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x12\x03\x03\x8a\x06\x00\x00\x00\x00\x61\x03\x00\x00\x00\x00\x00\x00\x55\x03\x00\x00\x00\x00\x3e\x04\x54\x02\x00\x00\x00\x00\x00\x00\x65\x2e\x0f\x02\x00\x00\x69\x03\x5b\x03\x00\x00\x88\x1b\x03\x1b\x00\x00\x00\x00\x53\x03\x78\x03\x00\x00\x55\x2e\xa3\x0a\x7e\x1a\x09\x03\x00\x00\x00\x00\xc8\xff\x38\x04\xda\x08\x0c\x00\xd1\x05\xce\x02\x3a\x02\x00\x00\x80\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xdd\x01\x00\x00\xfd\xff\xfa\x02\xea\x02\x00\x00\xe2\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa7\x07\x00\x00\x81\x01\x00\x00\xe4\xff\x00\x00\x05\x0f\x3b\x0b\x00\x00\xf9\x19\x23\x03\x03\x01\x21\x03\x00\x00\x00\x00\x00\x00\x00\x00\x29\x03\x00\x00\x00\x00\x0c\x03\x0d\x03\x00\x00\x99\x31\xe2\x00\x00\x00\x00\x00\x00\x00\x21\x00\x00\x00\x00\x00\x0e\x2e\x00\x00\x00\x00\x00\x00\xd5\x02\x00\x00\xf5\x02\x00\x00\xab\x02\x00\x00\x00\x00\x35\x03\x20\x02\x00\x00\x00\x00\xd1\x01\x00\x00\x00\x00\x3b\x12\x00\x00\x00\x00\xe7\x0e\x00\x00\x00\x00\x00\x00\x00\x00\xd8\x02\xcb\x02\xc6\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc9\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd7\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x51\x03\x00\x00\xfa\x04\xa8\x0e\x00\x00\x00\x00\x8a\x0e\x00\x00\xc8\x0a\x6c\x0a\x6c\x0e\xf5\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\x03\x9b\x01\x63\x31\x99\x01\x00\x00\x16\x03\x35\x20\x00\x00\x00\x00\xc2\x02\x00\x00\x4e\x00\xfe\x0c\x00\x00\x00\x00\x79\x01\x00\x00\x78\x00\x00\x00\xbf\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\x01\x00\x00\x00\x00\x8f\x02\x5a\x0a\x00\x00\x23\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x48\x0e\x2a\x0e\x00\x00\x00\x00\xc4\x09\x58\x0c\x0c\x0e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5a\x11\xd5\xff\xe3\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xed\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x73\x01\x00\x00\x00\x00\x00\x00\x4e\x07\x00\x00\x7b\x01\x53\x31\x00\x00\x00\x00\x5d\x03\xef\x02\xa4\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x9b\x00\x00\x00\x68\x02\x00\x00\x98\x2f\x00\x00\x00\x00\x00\x00\x52\x02\x00\x00\x00\x00\xf3\x02\x00\x00\xef\x18\xe5\x17\x60\x17\x00\x00\x15\x30\xb0\x1f\xe8\x2f\x00\x00\xb9\xff\x00\x00\x48\x02\x0b\x02\x00\x00\x00\x02\x04\x02\x00\x00\x00\x00\xcf\x05\x00\x00\x00\x00\x00\x00\x00\x00\xfc\x01\xe0\x05\xe8\x04\x00\x00\x00\x00\xd1\x2d\x0b\x01\x00\x00\xeb\x01\x00\x00\xfe\x0c\x00\x00\x29\x31\x66\x01\x5b\x01\x00\x00\xd8\x2f\x00\x00\x00\x00\xb9\x0c\xeb\x0d\x00\x00\x00\x00\x12\x04\xd1\x03\x00\x00\xab\x01\x96\x02\xf8\x00\x00\x00\x00\x00\x77\x05\x00\x00\x37\x01\x00\x00\x00\x00\xdb\x16\x00\x00\x00\x00\x00\x00\x56\x16\xd1\x15\x4c\x15\x16\x31\x74\x19\xec\x30\x00\x00\x64\x2f\x00\x00\x00\x00\x61\x07\x00\x00\x00\x00\x00\x00\xcd\xff\x00\x00\x0e\x01\xb9\x07\x00\x00\x00\x00\x00\x00\x00\x00\xba\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xcd\x0d\xaf\x0d\x8b\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x01\xd7\x2e\x92\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf7\xff\x7d\x00\x00\x00\x00\x00\x00\x00\xa5\x01\x00\x00\xa2\x02\x33\x02\x00\x00\x66\x00\x00\x00\x00\x00\xe6\x00\x0b\x05\x62\x00\x00\x00\x00\x00\x00\x00\xff\x00\xe0\x00\x00\x00\xfd\x09\x6d\x0d\x4f\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x26\x00\x08\x00\x00\x00\x2b\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x2f\xfe\x0c\xd5\x00\xab\x00\x00\x00\xdc\x30\x00\x00\x9d\x03\x00\x00\x00\x00\xee\xff\x35\x01\x00\x00\x9b\x00\x00\x00\x00\x00\x84\x00\x00\x00\xc7\x14\x3c\x11\x21\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc1\x23\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x31\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xea\xff\xa2\x2e\xca\x00\x4c\x02\x00\x00\x00\x00\x78\x24\x60\x01\x00\x00\x00\x00\x3f\x03\x2c\x01\x00\x00\xba\x04\xda\x00\xb9\x07\xd3\x00\x00\x00\xd2\x00\xb6\xff\x63\x00\x46\x00\xa6\x30\x00\x00\x00\x00\x6c\x30\x00\x00\xaa\xff\x00\x00\xf2\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe1\x01\x00\x00\x00\x00\x00\x00\x44\x00\x00\x00\x00\x00\x00\x00\xa3\x00\x00\x00\x00\x00\xcb\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc2\xff\x00\x00\x00\x00\x00\x00\x00\x00\x34\x00\x00\x00\x24\x2f\x00\x00\x3f\x30\x00\x00\x00\x00\x6a\x18\xd4\x0a\x54\xff\x5c\x26\x00\x00\x98\xff\x00\x00\x00\x00\x00\x00\x36\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3f\x03\x74\xff\xfe\x0c\xfe\x0c\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x02\x00\x00\x65\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x92\x2e\x00\x00\x00\x00\x00\x00"# happyDefActions :: HappyAddr -happyDefActions = HappyA# "\xf1\xff\x41\xfe\x00\x00\x00\x00\xf1\xff\x00\x00\xfa\xff\xee\xfd\xeb\xfd\xe7\xfd\xd8\xfd\xd6\xfd\xd7\xfd\xe3\xfd\xd5\xfd\xd4\xfd\xd3\xfd\xe5\xfd\xe4\xfd\xe6\xfd\xe2\xfd\xd2\xfd\xd1\xfd\xd0\xfd\xcf\xfd\x00\x00\xe8\xfd\xea\xfd\xe9\xfd\x00\x00\xc6\xff\x00\x00\xf3\xff\xb1\xfd\x00\x00\x00\x00\x00\x00\x31\xff\x2a\xff\x1b\xff\x10\xff\x00\x00\x1a\xff\x1a\xfe\x12\xfe\x0c\xfe\x19\xff\xfb\xfd\xf5\xfd\x04\xff\xf3\xfd\xf2\xfd\xf4\xfd\x00\x00\x36\xff\xad\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xf6\xfd\x0b\xfe\x0e\xfe\x0d\xfe\x30\xfe\x0d\xff\x0e\xff\x00\x00\xc6\xfe\x00\x00\xf9\xff\x29\xfe\xf7\xff\xf8\xff\xff\xfd\xe0\xfd\xe1\xfd\xdc\xfd\xd9\xfd\x2b\xfe\xcb\xfd\x1c\xfe\xc7\xfd\xc4\xfd\xdb\xfd\xce\xfd\xcc\xfd\xcd\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xc8\xfd\xda\xfd\xc5\xfd\xca\xfd\xdd\xfd\xc6\xfd\xc9\xfd\xa3\xfe\x8e\xfe\x3d\xfe\xc0\xfe\xbf\xfe\x00\x00\x00\x00\xb2\xfe\xab\xfe\xa8\xfe\xa6\xfe\x00\x00\x00\x00\x42\xfe\x40\xfe\xa4\xfe\xca\xff\xcb\xff\xa2\xfe\x99\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x66\xfe\x00\x00\x00\x00\x00\x00\xc3\xfd\xc2\xfd\xa1\xfe\xa0\xfe\xbf\xfd\xbe\xfd\xc1\xfd\xc0\xfd\xbd\xfd\xbc\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x98\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc6\xff\xf4\xff\xc6\xff\x00\x00\xe7\xff\xe9\xff\xc7\xff\xb8\xff\xe6\xff\xaf\xff\xae\xff\xad\xff\x00\x00\xab\xff\xa5\xff\xd3\xfe\xdb\xfe\xa4\xff\xd6\xfe\xa3\xff\x00\x00\xeb\xfd\xda\xfe\xd9\xfe\xd8\xfe\xd7\xfe\x00\x00\x93\xff\x00\x00\x00\x00\xc3\xff\xb6\xff\xb5\xff\xb4\xff\x00\x00\x00\x00\x92\xff\x00\x00\x00\x00\x68\xff\x00\x00\x68\xff\x6a\xff\x56\xff\x5b\xff\x00\x00\x00\x00\x00\x00\xb5\xfd\xb4\xfd\xb3\xfd\xb2\xfd\x00\x00\x00\x00\x93\xfe\x94\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x95\xfe\x96\xfe\x00\x00\x00\x00\x00\x00\x87\xfe\x87\xfe\x00\x00\x00\x00\x00\x00\xa3\xfe\x8b\xfe\xcb\xff\x85\xfe\xc0\xfe\x00\x00\x00\x00\x00\xfe\x00\x00\x01\xfe\xfd\xfd\xde\xfd\xdf\xfd\x00\x00\x21\xfe\xb6\xfd\x00\x00\x00\x00\x00\x00\xde\xfd\x00\x00\xdf\xfd\x1c\xfe\x00\x00\xdb\xfd\x23\xfe\x65\xfe\x64\xfe\x00\x00\x7b\xfe\x00\x00\x7a\xfe\x1f\xfe\x4e\xfe\xb9\xfe\xa9\xfe\x4d\xfe\x4a\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x3f\xfe\x45\xfe\x45\xfe\x00\x00\xb7\xfe\xaf\xfe\x72\xff\x3c\xfe\x75\xff\x75\xff\xb0\xfe\xb8\xfe\x00\x00\x00\x00\x00\x00\x3a\xfe\xac\xfe\xb5\xfe\xb6\xfe\x02\xfe\x00\x00\x03\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x07\xff\x00\x00\x00\x00\x17\xfe\x00\x00\x00\x00\x09\xfe\x00\x00\x00\x00\x00\x00\x19\xfe\xf1\xfd\x08\xfe\x0a\xfe\x00\x00\x13\xfe\x00\x00\x14\xfe\x00\x00\xe3\xfe\xe1\xfe\xae\xfd\x00\x00\x00\x00\x00\x00\x04\xff\x03\xff\x00\x00\x00\x00\x1c\xff\x00\x00\x10\xfe\x00\x00\xf8\xfd\x00\x00\x00\x00\xf7\xfd\x00\x00\x00\x00\x18\xff\xe4\xff\x00\x00\xee\xff\xb9\xfd\xb8\xfd\xc8\xff\x33\xff\x00\x00\x00\x00\x26\xff\x27\xff\x28\xff\x2a\xff\x29\xff\x32\xff\x00\x00\x00\x00\x05\xff\x00\x00\x35\xff\x00\x00\x3b\xff\xf0\xfd\x00\x00\x00\x00\x17\xff\x14\xff\x13\xff\x15\xfe\x18\xfe\xb7\xfd\xfa\xfd\x11\xfe\x00\x00\x12\xff\x00\x00\x16\xfe\x15\xff\x00\x00\x0f\xff\xf6\xff\x22\xfe\x2a\xfe\xec\xfd\x20\xfe\x1b\xfe\xfe\xfd\x00\x00\xc1\xfe\xc2\xfe\xc3\xfe\xc4\xfe\xc5\xfe\x3e\xff\xbe\xfe\x00\x00\x3b\xfe\x38\xfe\x35\xfe\x37\xfe\x3e\xfe\xaa\xfe\x00\x00\x00\x00\xb1\xfe\x00\x00\x76\xff\x42\xff\x00\x00\x32\xfe\xa4\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\xfe\x45\xfe\x00\x00\x00\x00\xae\xfe\x00\x00\x4c\xfe\x4a\xfe\x40\xff\x00\x00\x9b\xfe\x79\xfe\x00\x00\x00\x00\x9a\xfe\x00\x00\x00\x00\x00\x00\x7d\xfe\x80\xfe\xed\xfd\x9e\xfe\x81\xfe\x7c\xfe\x9f\xfe\x00\x00\x83\xfe\x9c\xfe\x9d\xfe\x84\xfe\x00\x00\x00\x00\x92\xfe\x90\xfe\x91\xfe\x86\xfe\x00\x00\x00\x00\x8f\xfe\x97\xfe\xee\xff\xea\xff\xba\xfd\xbb\xfd\x00\x00\x00\x00\x00\x00\x2c\xfe\x26\xfe\x2d\xfe\x28\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x5c\xff\x00\x00\x2f\xfe\x00\x00\x57\xff\x00\x00\x00\x00\x6b\xff\x68\xff\x00\x00\x67\xff\x00\x00\x00\x00\x00\x00\x00\x00\xa9\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\xff\x79\xff\xbf\xff\x00\x00\x00\x00\x08\xff\x00\x00\x01\xff\x00\x00\x8e\xff\x00\x00\x00\x00\x00\x00\x91\xff\x00\x00\xb0\xff\x00\x00\xb7\xff\xc8\xff\xeb\xff\xe8\xff\xc9\xff\xcb\xfe\x06\xfe\xb2\xff\x07\xfe\x05\xfe\x1e\xfe\x00\x00\xb1\xff\x91\xff\xf3\xfe\xdf\xfe\x00\x00\x00\x00\x41\xff\xcd\xfe\x3d\xff\x00\x00\x2d\xff\x25\xff\x00\x00\x04\xff\xd4\xfe\x6e\xff\xcf\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x83\xff\xfc\xfe\x91\xff\x00\x00\x09\xff\x8d\xff\xc4\xff\xc1\xff\xc0\xff\xac\xff\x00\x00\x91\xff\x00\x00\x00\x00\x00\x00\x4a\xff\x49\xff\x48\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\xff\xa6\xff\x6c\xff\x55\xff\x00\x00\x54\xff\xa8\xff\x58\xff\x00\x00\x5a\xff\xa7\xff\x5d\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd5\xfe\xed\xfd\xe0\xff\x00\x00\x00\x00\x89\xfe\x88\xfe\x8a\xfe\x8c\xfe\x8d\xfe\x82\xfe\xfc\xfd\x7f\xfe\x7e\xfe\x85\xfe\x73\xfe\x61\xfe\x72\xfe\x70\xfe\x6d\xfe\x6c\xfe\x00\x00\x63\xfe\x85\xfe\x75\xfe\x77\xfe\x74\xfe\x00\x00\x00\x00\x4b\xfe\x00\x00\xb3\xfe\x49\xfe\x46\xfe\x47\xfe\x45\xfe\x48\xfe\xb4\xfe\xbc\xfe\x71\xff\x33\xfe\x74\xff\x77\xff\x00\x00\x70\xff\x73\xff\x00\x00\xba\xfe\x00\x00\x00\x00\x00\x00\x00\x00\xa7\xfe\xa5\xfe\x06\xff\x00\x00\x00\x00\xfa\xfe\xf7\xfe\xf8\xfe\x00\x00\xaf\xfd\x00\x00\x00\x00\x34\xff\x00\x00\x00\x00\xf9\xfd\x0f\xfe\xe0\xff\x00\x00\xd9\xff\x26\xff\x00\x00\x3c\xff\xaf\xfd\xb0\xfd\xad\xfd\x00\x00\x00\x00\x11\xff\x16\xff\x39\xfe\x36\xfe\x4f\xfe\x00\x00\x5b\xfe\x57\xfe\x42\xff\x00\x00\x00\x00\xb0\xfe\x31\xfe\x78\xff\x34\xfe\x00\x00\x44\xfe\x00\x00\x3f\xff\x00\x00\x78\xfe\x6b\xfe\xcf\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x50\xff\x4e\xff\x00\x00\x27\xfe\xef\xfd\x5e\xff\x2e\xfe\x59\xff\x00\x00\x51\xff\x6d\xff\x00\x00\x00\x00\x00\x00\x66\xff\x00\x00\x3a\xff\x00\x00\xc7\xfe\xca\xfe\x00\x00\x4c\xff\x00\x00\x46\xff\x45\xff\x47\xff\x00\x00\x4b\xff\xa1\xff\x00\x00\x25\xff\x00\x00\x04\xff\x00\x00\xa0\xff\x7a\xff\x7d\xff\x7d\xff\x00\x00\xc2\xff\xaa\xff\x9c\xff\x00\xff\xfe\xfe\x00\x00\xa2\xff\x00\x00\x8f\xff\x00\x00\x00\x00\x60\xfe\x5e\xfe\x6e\xff\xd1\xfe\xd0\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\xff\x00\x00\x00\x00\x00\x00\x90\xff\xad\xfd\x9e\xff\x00\x00\xdf\xfe\x00\x00\xf3\xfe\xdf\xfe\x00\x00\x00\x00\x00\x00\xb3\xff\x1d\xfe\x04\xfe\x9b\xff\xdf\xfe\xf0\xfe\xf0\xfe\x9d\xff\xde\xfe\x00\x00\xed\xfe\xeb\xfe\xe7\xfe\x2f\xff\x1d\xff\x1f\xff\x00\x00\x21\xff\x23\xff\x2e\xff\x00\x00\x6f\xff\xd2\xfe\x00\x00\x00\x00\xcc\xfe\x84\xff\x87\xff\x87\xff\xfb\xfe\xfc\xfe\xfc\xfe\xbd\xff\x82\xff\x00\x00\x7e\xff\x00\x00\x81\xff\x93\xff\x00\x00\x00\x00\x9f\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\xff\xc9\xfe\x00\x00\x65\xff\x00\x00\x00\x00\x62\xff\x60\xff\x00\x00\x00\x00\x53\xff\x00\x00\x4f\xff\x00\x00\xf0\xff\xef\xff\x62\xfe\x6f\xfe\x6e\xfe\x71\xfe\x00\x00\x00\x00\x00\x00\x76\xfe\xbd\xfe\x00\x00\x00\x00\x5d\xfe\x5a\xfe\x00\x00\x00\x00\x58\xfe\x5c\xfe\xf9\xfe\xf6\xfe\xe2\xfe\xe0\xfe\x02\xff\x00\x00\xde\xff\xdb\xff\xd9\xff\xd6\xff\xd7\xff\xd8\xff\x00\x00\xe5\xff\xc6\xff\xc6\xff\xda\xff\xd9\xff\xd4\xff\xd5\xff\x00\x00\x00\x00\xd9\xff\xe1\xff\x59\xfe\x56\xfe\x6e\xff\x53\xfe\x51\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x6a\xfe\x68\xfe\x69\xfe\xf5\xff\xc6\xff\xc6\xff\x52\xff\x00\x00\x00\x00\x61\xff\x64\xff\xc8\xfe\x39\xff\x43\xff\x00\x00\x1d\xff\x21\xff\x23\xff\x2e\xff\x00\x00\x7c\xff\x7f\xff\x00\x00\x7b\xff\x91\xff\xbb\xff\x00\x00\xff\xfe\xfd\xfe\x8c\xff\x88\xff\x00\x00\x8b\xff\x00\x00\x00\x00\x00\x00\xce\xfe\x5f\xfe\x30\xff\x22\xff\x20\xff\x1e\xff\x00\x00\x04\xff\x00\x00\x0b\xff\x00\x00\xdd\xfe\x00\x00\xf1\xfe\x25\xfe\x00\x00\x00\x00\x00\x00\xc8\xfd\x00\x00\x9a\xff\xf5\xfe\xc5\xfd\xad\xfd\x00\x00\x00\x00\xf0\xfe\xf4\xfe\xdc\xfe\x00\x00\xaf\xfd\x00\x00\x00\x00\xe6\xfe\xaf\xfd\x86\xff\x89\xff\x91\xff\x91\xff\x85\xff\xbe\xff\xc5\xff\xbc\xff\x00\x00\xd9\xff\xf3\xfe\xdf\xfe\x00\x00\x80\xff\x44\xff\x00\x00\x69\xff\x00\x00\x00\x00\x00\x00\x00\x00\xbb\xfe\x54\xfe\x00\x00\x52\xfe\x55\xfe\xdf\xff\xd0\xff\x00\x00\xdc\xff\xe2\xff\xe3\xff\xd9\xff\x00\x00\xce\xff\xcd\xff\x00\x00\x00\x00\xd2\xff\x00\x00\x00\x00\x67\xfe\xed\xff\xec\xff\x00\x00\x96\xff\x95\xff\xdf\xfe\x00\x00\xd9\xff\x97\xff\x99\xff\x00\x00\x8a\xff\xe9\xfe\x00\x00\x00\x00\x00\x00\x00\x00\xe8\xfe\xad\xfd\x0a\xff\xf2\xfe\x24\xfe\x00\x00\xef\xfe\x00\x00\x00\x00\xec\xfe\xe6\xfe\xaf\xfd\x2c\xff\xe5\xfe\x98\xff\x00\x00\xba\xff\x94\xff\x5f\xff\xad\xfe\x50\xfe\xd3\xff\xcc\xff\x00\x00\xd1\xff\x00\x00\xdd\xff\xcf\xff\xb9\xff\xea\xfe\x00\x00\xee\xfe"# +happyDefActions = HappyA# "\xf1\xff\x3a\xfe\x00\x00\x00\x00\xf1\xff\x00\x00\xfa\xff\xe7\xfd\xe4\xfd\xe0\xfd\xd1\xfd\xcf\xfd\xd0\xfd\xdc\xfd\xce\xfd\xcd\xfd\xcc\xfd\xde\xfd\xdd\xfd\xdf\xfd\xdb\xfd\xcb\xfd\xca\xfd\xc9\xfd\xc8\xfd\x00\x00\xe1\xfd\xe3\xfd\xe2\xfd\x00\x00\xc4\xff\x00\x00\xe4\xff\xf3\xff\xc4\xff\xaa\xfd\x00\x00\x00\x00\x00\x00\x29\xff\x22\xff\x13\xff\x08\xff\x00\x00\x12\xff\x13\xfe\x0b\xfe\x05\xfe\x11\xff\xf4\xfd\xee\xfd\xfd\xfe\xec\xfd\xeb\xfd\xed\xfd\x00\x00\x2e\xff\xa6\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xef\xfd\x04\xfe\x07\xfe\x06\xfe\x29\xfe\x06\xff\x00\x00\xbf\xfe\x00\x00\xf9\xff\x22\xfe\xf7\xff\xf8\xff\xf8\xfd\xd9\xfd\xda\xfd\xd5\xfd\xd2\xfd\x24\xfe\xc4\xfd\x15\xfe\xc0\xfd\xbd\xfd\xd4\xfd\xc7\xfd\xc5\xfd\xc6\xfd\x00\x00\x00\x00\x00\x00\x00\x00\xc1\xfd\xd3\xfd\xbe\xfd\xc3\xfd\xd6\xfd\xbf\xfd\xc2\xfd\x9c\xfe\x87\xfe\x36\xfe\xb9\xfe\xb8\xfe\x00\x00\x00\x00\xab\xfe\xa4\xfe\xa1\xfe\x9f\xfe\x00\x00\x00\x00\x3b\xfe\x39\xfe\x9d\xfe\xc8\xff\xc9\xff\x9b\xfe\x92\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\xfe\x00\x00\x00\x00\x00\x00\xbc\xfd\xbb\xfd\x9a\xfe\x99\xfe\xb8\xfd\xb7\xfd\xba\xfd\xb9\xfd\xb6\xfd\xb5\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x91\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc4\xff\xf4\xff\xc4\xff\x00\x00\xe7\xff\xe9\xff\xc5\xff\xb4\xff\xe6\xff\xab\xff\xaa\xff\xa9\xff\x00\x00\xa7\xff\x9e\xff\xcc\xfe\xd4\xfe\x9d\xff\xcf\xfe\x9c\xff\x00\x00\xe4\xfd\xd3\xfe\xd2\xfe\xd1\xfe\xd0\xfe\x00\x00\x8c\xff\x00\x00\x00\x00\xc1\xff\xb2\xff\xb1\xff\xb0\xff\x00\x00\x00\x00\x8b\xff\x00\x00\x00\x00\x60\xff\x00\x00\x60\xff\x62\xff\x4e\xff\x53\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xae\xfd\xad\xfd\xac\xfd\xab\xfd\x00\x00\x00\x00\x8c\xfe\x8d\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x8e\xfe\x8f\xfe\x00\x00\x00\x00\x00\x00\x80\xfe\x80\xfe\x00\x00\x00\x00\x00\x00\x9c\xfe\x84\xfe\xc9\xff\x7e\xfe\xb9\xfe\x00\x00\x00\x00\xf9\xfd\x00\x00\xfa\xfd\xf6\xfd\xd7\xfd\xd8\xfd\x00\x00\x1a\xfe\xaf\xfd\x00\x00\x00\x00\x00\x00\xd7\xfd\x00\x00\xd8\xfd\x15\xfe\x00\x00\xd4\xfd\x1c\xfe\x5e\xfe\x5d\xfe\x00\x00\x74\xfe\x00\x00\x73\xfe\x18\xfe\x47\xfe\xb2\xfe\xa2\xfe\x46\xfe\x43\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x38\xfe\x3e\xfe\x3e\xfe\x00\x00\xb0\xfe\xa8\xfe\x6a\xff\x35\xfe\x6d\xff\x6d\xff\xa9\xfe\xb1\xfe\x00\x00\x00\x00\x00\x00\x33\xfe\xa5\xfe\xae\xfe\xaf\xfe\xfb\xfd\x00\x00\xfc\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\x00\x00\x00\x00\x10\xfe\x00\x00\x00\x00\x02\xfe\x00\x00\x00\x00\x00\x00\x12\xfe\xea\xfd\x01\xfe\x03\xfe\x00\x00\x0c\xfe\x00\x00\x0d\xfe\x00\x00\xdc\xfe\xda\xfe\xa7\xfd\x00\x00\x00\x00\x00\x00\xfd\xfe\xfc\xfe\x00\x00\x00\x00\x14\xff\x00\x00\x09\xfe\x00\x00\xf1\xfd\x00\x00\x00\x00\xf0\xfd\x00\x00\x00\x00\x10\xff\xe1\xff\xe0\xff\x00\x00\xee\xff\xb2\xfd\xb1\xfd\xc6\xff\x2b\xff\x00\x00\x00\x00\x1e\xff\x1f\xff\x20\xff\x22\xff\x21\xff\x2a\xff\x00\x00\x00\x00\xfe\xfe\x00\x00\x2d\xff\x00\x00\x33\xff\xe9\xfd\x00\x00\x00\x00\x0f\xff\x0c\xff\x0b\xff\x0e\xfe\x11\xfe\xb0\xfd\xf3\xfd\x0a\xfe\x00\x00\x0a\xff\x00\x00\x0f\xfe\x0d\xff\x00\x00\x07\xff\xf6\xff\x1b\xfe\x23\xfe\xe5\xfd\x19\xfe\x14\xfe\xf7\xfd\x00\x00\xba\xfe\xbb\xfe\xbc\xfe\xbd\xfe\xbe\xfe\x36\xff\xb7\xfe\x00\x00\x34\xfe\x31\xfe\x2e\xfe\x30\xfe\x37\xfe\xa3\xfe\x00\x00\x00\x00\xaa\xfe\x00\x00\x6e\xff\x3a\xff\x00\x00\x2b\xfe\x9d\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3c\xfe\x3e\xfe\x00\x00\x00\x00\xa7\xfe\x00\x00\x45\xfe\x43\xfe\x38\xff\x00\x00\x94\xfe\x72\xfe\x00\x00\x00\x00\x93\xfe\x00\x00\x00\x00\x00\x00\x76\xfe\x79\xfe\xe6\xfd\x97\xfe\x7a\xfe\x75\xfe\x98\xfe\x00\x00\x7c\xfe\x95\xfe\x96\xfe\x7d\xfe\x00\x00\x00\x00\x8b\xfe\x89\xfe\x8a\xfe\x7f\xfe\x00\x00\x00\x00\x88\xfe\x90\xfe\xee\xff\xea\xff\xb3\xfd\xb4\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\xfe\x1f\xfe\x26\xfe\x21\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x54\xff\x00\x00\x28\xfe\x00\x00\x4f\xff\x00\x00\x00\x00\x63\xff\x60\xff\x00\x00\x5f\xff\x00\x00\x00\x00\x00\x00\x00\x00\xa5\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x05\xff\x71\xff\xbf\xff\x00\x00\x00\x00\x01\xff\x00\x00\xfa\xfe\x00\x00\x87\xff\x00\x00\x00\x00\x00\x00\x8a\xff\x00\x00\xac\xff\x00\x00\xb3\xff\xc6\xff\xeb\xff\xe8\xff\xc7\xff\xc4\xfe\xff\xfd\xae\xff\x00\xfe\xfe\xfd\x17\xfe\x00\x00\xad\xff\x8a\xff\xec\xfe\xd8\xfe\x00\x00\x00\x00\x39\xff\xc6\xfe\x35\xff\x00\x00\x25\xff\x1d\xff\x00\x00\xfd\xfe\xcd\xfe\x66\xff\xc8\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x7b\xff\xf5\xfe\x8a\xff\x00\x00\x02\xff\x86\xff\xc2\xff\xbb\xff\xc0\xff\xa8\xff\x00\x00\x8a\xff\x00\x00\x00\x00\x00\x00\x42\xff\x41\xff\x40\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\xff\xa2\xff\x64\xff\x4d\xff\x00\x00\x4c\xff\xa4\xff\x50\xff\x00\x00\x52\xff\xa3\xff\x55\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xa1\xff\x9f\xff\xce\xfe\xe6\xfd\xde\xff\x00\x00\x00\x00\x82\xfe\x81\xfe\x83\xfe\x85\xfe\x86\xfe\x7b\xfe\xf5\xfd\x78\xfe\x77\xfe\x7e\xfe\x6c\xfe\x5a\xfe\x6b\xfe\x69\xfe\x66\xfe\x65\xfe\x00\x00\x5c\xfe\x7e\xfe\x6e\xfe\x70\xfe\x6d\xfe\x00\x00\x00\x00\x44\xfe\x00\x00\xac\xfe\x42\xfe\x3f\xfe\x40\xfe\x3e\xfe\x41\xfe\xad\xfe\xb5\xfe\x69\xff\x2c\xfe\x6c\xff\x6f\xff\x00\x00\x68\xff\x6b\xff\x00\x00\xb3\xfe\x00\x00\x00\x00\x00\x00\x00\x00\xa0\xfe\x9e\xfe\xff\xfe\x00\x00\x00\x00\xf3\xfe\xf0\xfe\xf1\xfe\x00\x00\xa8\xfd\x00\x00\x00\x00\x2c\xff\x00\x00\x00\x00\xf2\xfd\x08\xfe\xde\xff\x00\x00\xd7\xff\x1e\xff\x00\x00\x34\xff\xa8\xfd\xa9\xfd\xa6\xfd\x00\x00\x00\x00\x09\xff\x0e\xff\x32\xfe\x2f\xfe\x48\xfe\x00\x00\x54\xfe\x50\xfe\x3a\xff\x00\x00\x00\x00\xa9\xfe\x2a\xfe\x70\xff\x2d\xfe\x00\x00\x3d\xfe\x00\x00\x37\xff\x00\x00\x71\xfe\x64\xfe\xc8\xfd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x48\xff\x46\xff\x00\x00\x20\xfe\xe8\xfd\x56\xff\x27\xfe\x51\xff\x00\x00\x49\xff\x65\xff\x00\x00\x00\x00\x00\x00\x5e\xff\x00\x00\x32\xff\x00\x00\xc0\xfe\xc3\xfe\x00\x00\x44\xff\x00\x00\x3e\xff\x3d\xff\x3f\xff\x00\x00\x43\xff\x9a\xff\x00\x00\x1d\xff\x00\x00\xfd\xfe\x00\x00\x99\xff\x72\xff\x75\xff\x75\xff\xbd\xff\xbc\xff\xa6\xff\x95\xff\xf9\xfe\xf7\xfe\x00\x00\x9b\xff\x00\x00\x88\xff\x00\x00\x00\x00\x59\xfe\x57\xfe\x66\xff\xca\xfe\xc9\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1c\xff\x00\x00\x00\x00\x00\x00\x89\xff\xa6\xfd\x97\xff\x00\x00\xd8\xfe\x00\x00\xec\xfe\xd8\xfe\x00\x00\x00\x00\x00\x00\xaf\xff\x16\xfe\xfd\xfd\x94\xff\xd8\xfe\xe9\xfe\xe9\xfe\x96\xff\xd7\xfe\x00\x00\xe6\xfe\xe4\xfe\xe0\xfe\x27\xff\x15\xff\x17\xff\x00\x00\x19\xff\x1b\xff\x26\xff\x00\x00\x67\xff\xcb\xfe\x00\x00\x00\x00\xc5\xfe\x7c\xff\x7f\xff\x7f\xff\xf4\xfe\xf5\xfe\xf5\xfe\x00\x00\xbe\xff\x7a\xff\x00\x00\x76\xff\x00\x00\x79\xff\x8c\xff\x00\x00\x00\x00\x98\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x45\xff\xc2\xfe\x00\x00\x5d\xff\x00\x00\x00\x00\x5a\xff\x58\xff\x00\x00\x00\x00\x4b\xff\x00\x00\x47\xff\xa0\xff\x00\x00\xf0\xff\xef\xff\x5b\xfe\x68\xfe\x67\xfe\x6a\xfe\x00\x00\x00\x00\x00\x00\x6f\xfe\xb6\xfe\x00\x00\x00\x00\x56\xfe\x53\xfe\x00\x00\x00\x00\x51\xfe\x55\xfe\xf2\xfe\xef\xfe\xdb\xfe\xd9\xfe\xfb\xfe\x00\x00\xdc\xff\xd9\xff\xd7\xff\xd4\xff\xd5\xff\xd6\xff\x00\x00\xe5\xff\xc4\xff\xc4\xff\xd8\xff\xd7\xff\xd2\xff\xd3\xff\x00\x00\x00\x00\xd7\xff\xdf\xff\x52\xfe\x4f\xfe\x66\xff\x4c\xfe\x4a\xfe\x00\x00\x00\x00\x00\x00\x00\x00\x63\xfe\x61\xfe\x62\xfe\xf5\xff\xc4\xff\xc4\xff\x4a\xff\x00\x00\x00\x00\x59\xff\x5c\xff\xc1\xfe\x31\xff\x3b\xff\x00\x00\x15\xff\x19\xff\x1b\xff\x26\xff\x00\x00\x74\xff\x77\xff\x00\x00\x73\xff\x8a\xff\xb9\xff\xf8\xfe\xf6\xfe\x85\xff\x80\xff\x00\x00\x84\xff\x00\x00\x00\x00\x00\x00\x00\x00\xc7\xfe\x58\xfe\x28\xff\x1a\xff\x18\xff\x16\xff\x00\x00\xfd\xfe\x00\x00\x04\xff\x00\x00\xd6\xfe\x00\x00\xea\xfe\x1e\xfe\x00\x00\x00\x00\x00\x00\xc1\xfd\x00\x00\x93\xff\xee\xfe\xbe\xfd\xa6\xfd\x00\x00\x00\x00\xe9\xfe\xed\xfe\xd5\xfe\x00\x00\xa8\xfd\x00\x00\x00\x00\xdf\xfe\xa8\xfd\x7e\xff\x81\xff\x8a\xff\x00\x00\x8a\xff\x7d\xff\xb7\xff\x00\x00\xec\xfe\xd8\xfe\x00\x00\x78\xff\x3c\xff\x00\x00\x61\xff\x00\x00\x00\x00\x00\x00\x00\x00\xb4\xfe\x4d\xfe\x00\x00\x4b\xfe\x4e\xfe\xdd\xff\xce\xff\x00\x00\xda\xff\xe2\xff\xe3\xff\xd7\xff\x00\x00\xcc\xff\xcb\xff\x00\x00\x00\x00\xd0\xff\x00\x00\x00\x00\x60\xfe\xed\xff\xec\xff\x00\x00\x8f\xff\x8e\xff\xd8\xfe\xba\xff\xc3\xff\xb8\xff\x00\x00\xd7\xff\x90\xff\x00\x00\x92\xff\x00\x00\x82\xff\xe2\xfe\x00\x00\x00\x00\x00\x00\x00\x00\xe1\xfe\xa6\xfd\x03\xff\xeb\xfe\x1d\xfe\x00\x00\xe8\xfe\x00\x00\x00\x00\xe5\xfe\xdf\xfe\xa8\xfd\x24\xff\xde\xfe\x91\xff\x83\xff\x00\x00\xd7\xff\x8d\xff\x57\xff\xa6\xfe\x49\xfe\xd1\xff\xca\xff\x00\x00\xcf\xff\x00\x00\xdb\xff\xcd\xff\x00\x00\xb6\xff\xe3\xfe\x00\x00\xe7\xfe\xb5\xff"# happyCheck :: HappyAddr -happyCheck = HappyA# "\xff\xff\x67\x00\x01\x00\x02\x00\x03\x00\x02\x00\x03\x00\x06\x00\x0e\x00\x0f\x00\x6b\x00\x6c\x00\x09\x00\x12\x00\x13\x00\x07\x00\x08\x00\x3a\x00\x3b\x00\x3a\x00\x3b\x00\x34\x00\x43\x00\x00\x00\x4b\x00\x3c\x00\x3d\x00\x13\x00\x14\x00\x15\x00\x46\x00\x4e\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x86\x00\x1d\x00\x13\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x0e\x00\x0f\x00\x25\x00\x4b\x00\x53\x00\x28\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x3f\x00\x6a\x00\x6b\x00\x6c\x00\x3c\x00\x3d\x00\x00\x00\x86\x00\x00\x00\x0a\x00\xbd\x00\x6d\x00\xbf\x00\x26\x00\x07\x00\x08\x00\x0c\x00\x75\x00\xc4\x00\x6c\x00\x19\x00\x42\x00\xcd\x00\xca\x00\xca\x00\x3c\x00\x13\x00\x14\x00\x15\x00\x75\x00\x3d\x00\x73\x00\x3f\x00\x1d\x00\x26\x00\x3f\x00\x1d\x00\x41\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x5a\x00\x5b\x00\x25\x00\x0e\x00\x0f\x00\x28\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x52\x00\x26\x00\x75\x00\x66\x00\x67\x00\xd4\x00\x3f\x00\x5e\x00\xd3\x00\x75\x00\xd4\x00\xda\x00\xd1\x00\x6e\x00\x6f\x00\x70\x00\xda\x00\x39\x00\x39\x00\x74\x00\x75\x00\x42\x00\x77\x00\x78\x00\x65\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x75\x00\xd3\x00\x00\x00\x57\x00\x76\x00\x52\x00\xc1\x00\x52\x00\x6d\x00\xc4\x00\x0c\x00\x0d\x00\x0e\x00\x0f\x00\x65\x00\xca\x00\x5d\x00\xc1\x00\x5d\x00\xc4\x00\xc4\x00\xc4\x00\x5d\x00\x5d\x00\xd4\x00\xca\x00\xca\x00\xca\x00\xc1\x00\xaa\x00\xda\x00\xc4\x00\xad\x00\x65\x00\x6e\x00\x6f\x00\x70\x00\xca\x00\x3f\x00\xa7\x00\x74\x00\x75\x00\xaa\x00\x77\x00\x78\x00\xad\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x6d\x00\xc2\x00\xc3\x00\xc4\x00\x39\x00\x3d\x00\xbd\x00\x3f\x00\xbf\x00\xca\x00\x46\x00\xcc\x00\xcd\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\x5e\x00\xd4\x00\xca\x00\xd6\x00\xd7\x00\xca\x00\x1e\x00\xcc\x00\xcd\x00\x3c\x00\x54\x00\xd0\x00\xd8\x00\xd4\x00\xd8\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xda\x00\x5e\x00\x26\x00\xa7\x00\x5d\x00\x3a\x00\xaa\x00\x62\x00\xd4\x00\xad\x00\xd6\x00\xd7\x00\x41\x00\x11\x00\x12\x00\x13\x00\xd4\x00\xd4\x00\x3a\x00\xd6\x00\xd7\x00\x26\x00\xda\x00\x3f\x00\x5e\x00\xd4\x00\x76\x00\xd6\x00\xd7\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\x07\x00\x08\x00\x45\x00\x46\x00\xd4\x00\xca\x00\x3c\x00\xcc\x00\xcd\x00\xd2\x00\xda\x00\xd0\x00\x13\x00\x14\x00\x15\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xd1\x00\x4e\x00\x5e\x00\x1d\x00\xd4\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xd1\x00\xda\x00\x25\x00\x5a\x00\x5b\x00\x28\x00\x58\x00\x5d\x00\x07\x00\x08\x00\x3a\x00\xd4\x00\x5e\x00\xd6\x00\xd7\x00\x3f\x00\xd4\x00\x3a\x00\xd6\x00\xd7\x00\x13\x00\x14\x00\x15\x00\xaa\x00\x41\x00\x3d\x00\xad\x00\x3f\x00\xaf\x00\x4e\x00\x1d\x00\x42\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xc1\x00\xd5\x00\x25\x00\xc4\x00\xbb\x00\x28\x00\x3f\x00\x3b\x00\x5d\x00\xca\x00\x5e\x00\xc2\x00\xc3\x00\xc4\x00\xc5\x00\x13\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd4\x00\xcf\x00\xd6\x00\xd7\x00\xc1\x00\xd3\x00\x42\x00\xc4\x00\x00\x00\xae\x00\x00\x00\x58\x00\xd5\x00\xca\x00\x6e\x00\x6f\x00\x70\x00\x5e\x00\xb7\x00\xb8\x00\x74\x00\x75\x00\x63\x00\x77\x00\x78\x00\x98\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x5e\x00\x13\x00\x4e\x00\xc8\x00\xc9\x00\xc1\x00\xcb\x00\xd4\x00\xc4\x00\xbd\x00\xcf\x00\xbf\x00\xaa\x00\xda\x00\xca\x00\xad\x00\x4d\x00\x5d\x00\x6e\x00\x6f\x00\x70\x00\x34\x00\xca\x00\x75\x00\x74\x00\x75\x00\x4e\x00\x77\x00\x78\x00\xd2\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xc2\x00\xc3\x00\xc4\x00\xa7\x00\x0a\x00\x5d\x00\xaa\x00\x05\x00\xca\x00\xad\x00\xcc\x00\xcd\x00\xd5\x00\xab\x00\xac\x00\xad\x00\xd9\x00\xd1\x00\xa8\x00\xa9\x00\x75\x00\xab\x00\x52\x00\xad\x00\x52\x00\xc1\x00\x3c\x00\x3d\x00\xc4\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\x5d\x00\xca\x00\x5d\x00\x1a\x00\x1b\x00\xca\x00\xa7\x00\xcc\x00\xcd\x00\xaa\x00\xc1\x00\xd0\x00\xad\x00\xc4\x00\xcd\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xca\x00\xc8\x00\xc9\x00\xcd\x00\xcb\x00\x6a\x00\x6b\x00\x6c\x00\xcf\x00\x46\x00\x47\x00\x75\x00\xd3\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xd4\x00\x08\x00\x7d\x00\x7e\x00\x7f\x00\xca\x00\xda\x00\xcc\x00\xcd\x00\x57\x00\xae\x00\xd0\x00\x13\x00\x19\x00\x15\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xb7\x00\xb8\x00\x5f\x00\x1d\x00\xc4\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xd5\x00\xca\x00\x25\x00\x08\x00\xcd\x00\x28\x00\xb5\x00\xb6\x00\xc8\x00\xc9\x00\xd5\x00\xcb\x00\x3b\x00\x68\x00\x13\x00\xcf\x00\xa7\x00\xc0\x00\x62\x00\xaa\x00\x3b\x00\x61\x00\xad\x00\x6d\x00\x1d\x00\x65\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x6d\x00\x42\x00\x25\x00\xb5\x00\xb6\x00\x28\x00\xd3\x00\xa8\x00\xa9\x00\x6d\x00\xab\x00\x58\x00\xad\x00\xc2\x00\xc3\x00\xc4\x00\xd5\x00\x5e\x00\x34\x00\x58\x00\xd9\x00\xca\x00\x63\x00\xcc\x00\xcd\x00\x5e\x00\x67\x00\xd0\x00\x2b\x00\xcf\x00\x63\x00\x42\x00\xc1\x00\xd3\x00\x67\x00\xc4\x00\xd4\x00\xd2\x00\xa2\x00\xa3\x00\xa4\x00\xca\x00\xda\x00\x58\x00\xcd\x00\x6e\x00\x6f\x00\x70\x00\x79\x00\x5e\x00\x10\x00\x74\x00\x75\x00\x47\x00\x77\x00\x78\x00\xd1\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x5a\x00\x5b\x00\x3d\x00\xbd\x00\x3f\x00\xbf\x00\xc0\x00\xc2\x00\xc3\x00\xc4\x00\x5a\x00\x5b\x00\x6e\x00\x6f\x00\x70\x00\xca\x00\xca\x00\x0b\x00\x74\x00\x75\x00\x40\x00\x77\x00\x78\x00\x08\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x58\x00\xb3\x00\xb4\x00\x83\x00\x13\x00\x58\x00\x5e\x00\x3d\x00\x40\x00\xa7\x00\x0b\x00\x5e\x00\xaa\x00\xbf\x00\x1d\x00\xad\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x41\x00\x58\x00\x25\x00\x36\x00\xca\x00\x28\x00\xaa\x00\x5e\x00\x39\x00\xad\x00\xd5\x00\xa3\x00\xa4\x00\x26\x00\xd9\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xa7\x00\xc8\x00\xc9\x00\xaa\x00\xcb\x00\xca\x00\xad\x00\xcc\x00\xcd\x00\xd5\x00\xd5\x00\xd0\x00\x42\x00\xd9\x00\xd9\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\x5a\x00\x5b\x00\xcc\x00\xcd\x00\xc2\x00\xc3\x00\xc4\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xbd\x00\xca\x00\xbf\x00\x14\x00\x15\x00\xca\x00\x2f\x00\xcc\x00\xcd\x00\x17\x00\xbd\x00\xd0\x00\xbf\x00\xca\x00\x26\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xce\x00\xcf\x00\x14\x00\x15\x00\xca\x00\xd3\x00\x13\x00\x6e\x00\x6f\x00\x70\x00\xc2\x00\xc3\x00\xc4\x00\x74\x00\x75\x00\x2c\x00\x77\x00\x78\x00\xca\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x13\x00\xa8\x00\xa9\x00\x83\x00\xab\x00\xb1\x00\xad\x00\xb3\x00\xb4\x00\x62\x00\x1d\x00\x6d\x00\x4d\x00\x20\x00\x21\x00\x22\x00\x51\x00\x18\x00\x25\x00\x5e\x00\x5f\x00\x28\x00\xc2\x00\xc3\x00\xc4\x00\x5c\x00\xc1\x00\xc3\x00\xc4\x00\xc4\x00\xca\x00\xb3\x00\xb4\x00\x13\x00\xca\x00\xca\x00\xcc\x00\xcd\x00\xcd\x00\xa7\x00\x63\x00\x64\x00\xaa\x00\x1d\x00\xbd\x00\xad\x00\xbf\x00\x42\x00\x4d\x00\x4d\x00\x24\x00\x25\x00\x51\x00\x51\x00\x45\x00\x46\x00\x47\x00\xca\x00\x53\x00\x2d\x00\x2e\x00\x4c\x00\x57\x00\x30\x00\x59\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xc7\x00\xc8\x00\xc9\x00\x61\x00\xcb\x00\xca\x00\x44\x00\xcc\x00\xcd\x00\x4d\x00\x75\x00\xd0\x00\x44\x00\x51\x00\x62\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\x40\x00\x7f\x00\x13\x00\x6e\x00\x6f\x00\x70\x00\xc2\x00\xc3\x00\xc4\x00\x74\x00\x75\x00\x40\x00\x77\x00\x78\x00\xca\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x57\x00\xb4\x00\x4d\x00\xab\x00\xac\x00\xad\x00\x51\x00\x32\x00\x33\x00\xb1\x00\x61\x00\xb3\x00\xb4\x00\x04\x00\x65\x00\x6e\x00\x6f\x00\x70\x00\x69\x00\xd1\x00\xa7\x00\x74\x00\x75\x00\xaa\x00\x77\x00\x78\x00\xad\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x13\x00\x61\x00\x60\x00\x61\x00\xcd\x00\x65\x00\xa7\x00\x3e\x00\x3f\x00\xaa\x00\x1d\x00\x48\x00\xad\x00\x9e\x00\xc2\x00\xc3\x00\xc4\x00\x24\x00\x25\x00\x4d\x00\xa6\x00\xa7\x00\xca\x00\x51\x00\xcc\x00\xcd\x00\x2d\x00\x2e\x00\xd0\x00\xc2\x00\xc3\x00\xc4\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xa9\x00\xca\x00\xab\x00\xa7\x00\xad\x00\xca\x00\xaa\x00\xcc\x00\xcd\x00\xad\x00\x75\x00\xd0\x00\x5d\x00\x5e\x00\x5f\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\x4d\x00\x7f\x00\x61\x00\x81\x00\x51\x00\xc1\x00\x65\x00\xd1\x00\xc4\x00\x91\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xca\x00\x60\x00\x61\x00\xcd\x00\xd1\x00\xca\x00\x5a\x00\xcc\x00\xcd\x00\x5a\x00\x5e\x00\xd0\x00\xc0\x00\x5e\x00\xd1\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\x45\x00\x46\x00\x47\x00\x6e\x00\x6f\x00\x70\x00\x15\x00\x4c\x00\xa7\x00\x74\x00\x75\x00\xaa\x00\x77\x00\x78\x00\xad\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x13\x00\x04\x00\x5a\x00\xd2\x00\xa8\x00\xa9\x00\x5e\x00\xab\x00\x62\x00\xad\x00\x1d\x00\x79\x00\x66\x00\x80\x00\xc2\x00\xc3\x00\xc4\x00\x24\x00\x25\x00\x5a\x00\xd3\x00\x41\x00\xca\x00\x5e\x00\xcc\x00\xcd\x00\x2d\x00\x61\x00\xd0\x00\xc1\x00\x13\x00\x65\x00\xc4\x00\x60\x00\x61\x00\xc2\x00\xc3\x00\xc4\x00\xca\x00\xa7\x00\x1d\x00\xcd\x00\xaa\x00\xca\x00\x58\x00\xad\x00\x23\x00\x4d\x00\x60\x00\x61\x00\x5e\x00\x51\x00\x29\x00\x2a\x00\x62\x00\x63\x00\xd1\x00\xb0\x00\xb1\x00\x67\x00\xb3\x00\xb4\x00\x71\x00\x72\x00\x73\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\x4d\x00\xbd\x00\x4d\x00\xbf\x00\x51\x00\xca\x00\x51\x00\xcc\x00\xcd\x00\x3b\x00\x75\x00\xd0\x00\x77\x00\x78\x00\xca\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\x45\x00\x46\x00\x47\x00\x6e\x00\x6f\x00\x70\x00\xd2\x00\x4c\x00\x43\x00\x74\x00\x75\x00\x16\x00\x77\x00\x78\x00\x1c\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x4d\x00\x82\x00\x4d\x00\x5a\x00\x51\x00\x5f\x00\x51\x00\x5e\x00\x62\x00\x63\x00\x37\x00\x38\x00\x6e\x00\x6f\x00\x70\x00\xb5\x00\xb6\x00\xd3\x00\x74\x00\x75\x00\x9c\x00\x77\x00\x78\x00\x9c\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x13\x00\x60\x00\x61\x00\xc7\x00\xc8\x00\xc9\x00\x9c\x00\xcb\x00\x58\x00\xa7\x00\x1d\x00\x3c\x00\xaa\x00\x35\x00\x36\x00\xad\x00\x23\x00\x95\x00\x96\x00\x97\x00\x98\x00\x76\x00\x29\x00\x2a\x00\xa8\x00\xa9\x00\x4e\x00\xab\x00\x75\x00\xad\x00\x71\x00\x72\x00\x73\x00\x13\x00\x61\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xa7\x00\x63\x00\x64\x00\xaa\x00\x1d\x00\xca\x00\xad\x00\xcc\x00\xcd\x00\x07\x00\xc1\x00\xd0\x00\x58\x00\xc4\x00\x58\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\xca\x00\x37\x00\x38\x00\xcd\x00\x39\x00\x31\x00\x58\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\x25\x00\x26\x00\x27\x00\xc3\x00\xc4\x00\xca\x00\x5d\x00\xcc\x00\xcd\x00\x5e\x00\xca\x00\xd0\x00\xcc\x00\xcd\x00\x41\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\x37\x00\x38\x00\x4e\x00\x6e\x00\x6f\x00\x70\x00\x32\x00\x33\x00\x6d\x00\x74\x00\x75\x00\x07\x00\x77\x00\x78\x00\x57\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x32\x00\x33\x00\x19\x00\xab\x00\xac\x00\xad\x00\x14\x00\x15\x00\x3c\x00\xb1\x00\x27\x00\xb3\x00\xb4\x00\x3c\x00\x3d\x00\x6e\x00\x6f\x00\x70\x00\x2b\x00\x2c\x00\x76\x00\x74\x00\x75\x00\x44\x00\x77\x00\x78\x00\x76\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x13\x00\x35\x00\x36\x00\x4c\x00\xcd\x00\x4d\x00\xa7\x00\x58\x00\x4e\x00\xaa\x00\x1d\x00\x4d\x00\xad\x00\x58\x00\x3c\x00\x5e\x00\x4e\x00\x5d\x00\x3f\x00\x51\x00\x52\x00\x3d\x00\x54\x00\x55\x00\xaa\x00\x5e\x00\x76\x00\xad\x00\x3c\x00\x47\x00\x31\x00\x2c\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\x3b\x00\xa5\x00\xa6\x00\xa7\x00\x19\x00\xca\x00\xaa\x00\xcc\x00\xcd\x00\xad\x00\x3f\x00\xd0\x00\xc2\x00\xc3\x00\xc4\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\x75\x00\xca\x00\x53\x00\xcc\x00\xcd\x00\x57\x00\x57\x00\x0c\x00\x59\x00\x58\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\x09\x00\x6d\x00\x61\x00\x6c\x00\x13\x00\xca\x00\x65\x00\xcc\x00\xcd\x00\x4c\x00\x69\x00\xd0\x00\x39\x00\x3c\x00\x4c\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\x02\x00\x1b\x00\x07\x00\x6e\x00\x6f\x00\x70\x00\x5f\x00\x5f\x00\x07\x00\x74\x00\x75\x00\x19\x00\x77\x00\x78\x00\x07\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x13\x00\xaf\x00\x75\x00\x41\x00\x4c\x00\xb0\x00\xb1\x00\x19\x00\xb3\x00\xb4\x00\x1d\x00\xb9\x00\x5e\x00\xbb\x00\x5e\x00\x3d\x00\x23\x00\x3c\x00\xbd\x00\x3c\x00\xbf\x00\x3c\x00\x29\x00\xc5\x00\xaf\x00\xc7\x00\xc8\x00\xc9\x00\x44\x00\xcb\x00\x13\x00\xca\x00\xce\x00\xcf\x00\xb9\x00\x3c\x00\xbb\x00\xa5\x00\xa6\x00\xa7\x00\x1d\x00\x39\x00\xaa\x00\x3c\x00\x5e\x00\xad\x00\xc5\x00\x54\x00\xc7\x00\xc8\x00\xc9\x00\x39\x00\xcb\x00\x19\x00\x39\x00\xce\x00\xcf\x00\x39\x00\x2b\x00\x45\x00\x3d\x00\x5d\x00\x75\x00\x13\x00\x3c\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x4e\x00\xca\x00\x58\x00\xcc\x00\xcd\x00\x5d\x00\x75\x00\xd0\x00\x58\x00\x76\x00\x19\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\x57\x00\x76\x00\x41\x00\x6e\x00\x6f\x00\x70\x00\x58\x00\x58\x00\x41\x00\x74\x00\x75\x00\x57\x00\x77\x00\x78\x00\x6a\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x39\x00\x5e\x00\x6d\x00\xa7\x00\x39\x00\x13\x00\xaa\x00\x6c\x00\x58\x00\xad\x00\x1b\x00\x58\x00\x6e\x00\x6f\x00\x70\x00\x3c\x00\x6c\x00\x54\x00\x74\x00\x75\x00\x13\x00\x77\x00\x78\x00\x6d\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xc2\x00\xc3\x00\xc4\x00\x39\x00\x39\x00\x3d\x00\x6c\x00\x19\x00\xca\x00\xa7\x00\xcc\x00\xcd\x00\xaa\x00\x44\x00\xd0\x00\xad\x00\x58\x00\x3c\x00\x3c\x00\x3c\x00\x07\x00\x3d\x00\x75\x00\x76\x00\x77\x00\x78\x00\x19\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x5e\x00\x44\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\xa7\x00\x3f\x00\x39\x00\xaa\x00\x16\x00\xca\x00\xad\x00\xcc\x00\xcd\x00\x19\x00\x0d\x00\xd0\x00\x92\x00\x93\x00\x94\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\x99\x00\x3d\x00\x3c\x00\x53\x00\x63\x00\x64\x00\x5e\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\x61\x00\x4e\x00\x58\x00\xa7\x00\x75\x00\xca\x00\xaa\x00\xcc\x00\xcd\x00\xad\x00\x5e\x00\xd0\x00\x7d\x00\x7e\x00\x7f\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\x75\x00\x76\x00\x77\x00\x78\x00\x13\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xc2\x00\xc3\x00\xc4\x00\x53\x00\x84\x00\x85\x00\x5f\x00\x57\x00\xca\x00\x59\x00\xcc\x00\xcd\x00\x3c\x00\x3b\x00\xd0\x00\x17\x00\x4e\x00\x61\x00\x5d\x00\x3d\x00\x3d\x00\x65\x00\x5e\x00\x4e\x00\xa7\x00\x69\x00\x50\x00\xaa\x00\x5e\x00\x62\x00\xad\x00\x3c\x00\x0c\x00\x5d\x00\x5f\x00\xab\x00\xac\x00\xad\x00\x5f\x00\xa7\x00\x4c\x00\xb1\x00\xaa\x00\xb3\x00\xb4\x00\xad\x00\x46\x00\xaf\x00\x4e\x00\x54\x00\x58\x00\xc2\x00\xc3\x00\xc4\x00\x56\x00\x58\x00\x5a\x00\x58\x00\xba\x00\xca\x00\xbc\x00\xcc\x00\xcd\x00\x58\x00\x15\x00\xd0\x00\xc2\x00\xc3\x00\xc4\x00\xcd\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\x5e\x00\x58\x00\xd3\x00\x58\x00\x27\x00\x58\x00\x0d\x00\x13\x00\x41\x00\x5f\x00\x75\x00\x76\x00\x77\x00\x78\x00\x5f\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x5d\x00\x3b\x00\x39\x00\x39\x00\x84\x00\x85\x00\x6d\x00\x5e\x00\x54\x00\x56\x00\x5e\x00\x45\x00\x46\x00\x47\x00\x4e\x00\x58\x00\x58\x00\x58\x00\x4c\x00\x58\x00\x58\x00\x55\x00\x4e\x00\x5a\x00\x41\x00\x51\x00\x52\x00\x7d\x00\x54\x00\x55\x00\x58\x00\x7d\x00\x53\x00\x7d\x00\x56\x00\x58\x00\x5e\x00\x54\x00\x6c\x00\xa7\x00\x62\x00\x63\x00\xaa\x00\x30\x00\x11\x00\xad\x00\x24\x00\xaf\x00\x57\x00\x5e\x00\x5e\x00\x5d\x00\x6d\x00\x75\x00\x4e\x00\x5d\x00\x13\x00\x83\x00\xba\x00\x6c\x00\xbc\x00\x75\x00\x6c\x00\x42\x00\x40\x00\x27\x00\xc2\x00\xc3\x00\xc4\x00\x83\x00\xc6\x00\xc7\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\x13\x00\x6c\x00\xd3\x00\x75\x00\x76\x00\x77\x00\x78\x00\x6c\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x4d\x00\x40\x00\x54\x00\x4f\x00\x84\x00\x85\x00\x83\x00\x39\x00\x3c\x00\x4e\x00\x00\x00\x44\x00\x51\x00\x52\x00\x83\x00\x54\x00\x55\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\x0c\x00\xb0\x00\xb1\x00\x13\x00\xb3\x00\xb4\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xa7\x00\xbf\x00\xff\xff\xaa\x00\xca\x00\xff\xff\xad\x00\xff\xff\xaf\x00\x75\x00\xff\xff\xff\xff\xca\x00\xff\xff\xff\xff\xd5\x00\xff\xff\xff\xff\xff\xff\xba\x00\xff\xff\xbc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc2\x00\xc3\x00\xc4\x00\xff\xff\xc6\x00\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\x13\x00\xff\xff\xd3\x00\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x45\x00\x46\x00\x47\x00\xff\xff\x84\x00\xff\xff\xff\xff\x4c\x00\xff\xff\x89\x00\xff\xff\x3b\x00\xb0\x00\xb1\x00\x8e\x00\xb3\x00\xb4\x00\x41\x00\xff\xff\xff\xff\xff\xff\x45\x00\x46\x00\x47\x00\xff\xff\xbd\x00\xff\xff\xbf\x00\x4c\x00\x62\x00\x63\x00\xff\xff\xff\xff\x66\x00\x67\x00\xff\xff\xff\xff\xff\xff\xca\x00\xa7\x00\x58\x00\xff\xff\xaa\x00\xff\xff\xff\xff\xad\x00\x5e\x00\xaf\x00\xff\xff\xff\xff\x62\x00\x63\x00\xff\xff\xff\xff\x66\x00\x67\x00\xff\xff\xff\xff\xba\x00\xff\xff\xbc\x00\xff\xff\xff\xff\x27\x00\xff\xff\xff\xff\xc2\x00\xc3\x00\xc4\x00\xff\xff\xc6\x00\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\x13\x00\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x84\x00\xaf\x00\xff\xff\x4e\x00\x88\x00\x89\x00\x51\x00\x52\x00\x4e\x00\x54\x00\x55\x00\xb9\x00\xff\xff\xbb\x00\xff\xff\x55\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xff\xff\xcb\x00\xff\xff\xff\xff\xce\x00\xcf\x00\xff\xff\xa7\x00\xff\xff\xff\xff\xaa\x00\xff\xff\xff\xff\xad\x00\x75\x00\xaf\x00\xff\xff\xff\xff\xff\xff\x75\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xba\x00\xff\xff\xbc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc2\x00\xc3\x00\xc4\x00\xff\xff\xc6\x00\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\x13\x00\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x84\x00\xff\xff\xff\xff\x87\x00\xff\xff\xff\xff\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xff\xff\xbd\x00\xff\xff\xbf\x00\xff\xff\xff\xff\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\xff\xff\xa7\x00\xff\xff\xca\x00\xaa\x00\xff\xff\xff\xff\xad\x00\xff\xff\xaf\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xd5\x00\xcb\x00\xff\xff\xff\xff\xce\x00\xcf\x00\xba\x00\xff\xff\xbc\x00\xd3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xc2\x00\xc3\x00\xc4\x00\xff\xff\xc6\x00\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\x13\x00\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x84\x00\xff\xff\xff\xff\x87\x00\xff\xff\xff\xff\xff\xff\x4e\x00\x4f\x00\xff\xff\x51\x00\x52\x00\xff\xff\x54\x00\x55\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\x4a\x00\xff\xff\xff\xff\xff\xff\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\xff\xff\xa7\x00\xff\xff\xff\xff\xaa\x00\xff\xff\xff\xff\xad\x00\xff\xff\xaf\x00\xff\xff\xff\xff\x75\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xba\x00\xff\xff\xbc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc2\x00\xc3\x00\xc4\x00\x75\x00\xc6\x00\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\x13\x00\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x84\x00\xa7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xff\xff\xff\xff\xff\xff\xa7\x00\xff\xff\xff\xff\xbd\x00\xff\xff\xbf\x00\xc0\x00\xff\xff\xff\xff\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\xff\xff\xa7\x00\xca\x00\xff\xff\xaa\x00\xff\xff\xff\xff\xad\x00\xbd\x00\xaf\x00\xbf\x00\xd3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xba\x00\xca\x00\xbc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc2\x00\xc3\x00\xc4\x00\xff\xff\xc6\x00\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\x13\x00\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x84\x00\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\x4e\x00\x4f\x00\xff\xff\x51\x00\x52\x00\xff\xff\x54\x00\x55\x00\x45\x00\x46\x00\x47\x00\x59\x00\xff\xff\xff\xff\x49\x00\x4c\x00\xff\xff\x4c\x00\xff\xff\x4e\x00\x4f\x00\xff\xff\x51\x00\x52\x00\xff\xff\x54\x00\x55\x00\x58\x00\xa7\x00\xff\xff\xff\xff\xaa\x00\xff\xff\x5e\x00\xad\x00\xff\xff\xaf\x00\x62\x00\x63\x00\x75\x00\xff\xff\x66\x00\x67\x00\xff\xff\xff\xff\xff\xff\xff\xff\xba\x00\xff\xff\xbc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc2\x00\xc3\x00\xc4\x00\x75\x00\xc6\x00\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\x13\x00\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x84\x00\xa7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa7\x00\x4e\x00\xff\xff\xbd\x00\xff\xff\xbf\x00\xff\xff\xff\xff\x55\x00\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\xff\xff\xa7\x00\xca\x00\xff\xff\xaa\x00\xff\xff\xff\xff\xad\x00\xbd\x00\xaf\x00\xbf\x00\xd3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xba\x00\xca\x00\xbc\x00\xff\xff\xff\xff\xff\xff\x75\x00\xff\xff\xc2\x00\xc3\x00\xc4\x00\xff\xff\xc6\x00\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\x13\x00\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x84\x00\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\x4f\x00\x3b\x00\x51\x00\x52\x00\xff\xff\x54\x00\x55\x00\x56\x00\x57\x00\xff\xff\xff\xff\x45\x00\x46\x00\x47\x00\xae\x00\xff\xff\xb0\x00\xb1\x00\x4c\x00\xb3\x00\xb4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa7\x00\xff\xff\xbd\x00\xaa\x00\xbf\x00\xff\xff\xad\x00\x13\x00\xaf\x00\xff\xff\x5f\x00\x75\x00\xff\xff\x62\x00\x63\x00\xca\x00\xff\xff\x66\x00\x67\x00\xba\x00\xcf\x00\xbc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc2\x00\xc3\x00\xc4\x00\xff\xff\xc6\x00\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa7\x00\xff\xff\xff\xff\xff\xff\x13\x00\x8a\x00\x8b\x00\x8c\x00\x8d\x00\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x99\x00\xff\xff\xbd\x00\xff\xff\xbf\x00\xff\xff\xff\xff\xff\xff\xa1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa7\x00\xca\x00\xff\xff\xaa\x00\xff\xff\xff\xff\xad\x00\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc2\x00\xc3\x00\xc4\x00\xff\xff\x8a\x00\x8b\x00\x8c\x00\x8d\x00\xca\x00\x13\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xff\xff\xff\xff\xff\xff\x99\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa7\x00\xff\xff\xff\xff\xaa\x00\xff\xff\xff\xff\xad\x00\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc2\x00\xc3\x00\xc4\x00\x8b\x00\x8c\x00\x8d\x00\xff\xff\xff\xff\xca\x00\xff\xff\xcc\x00\xcd\x00\x13\x00\xff\xff\xd0\x00\xff\xff\xff\xff\x99\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa7\x00\xff\xff\xff\xff\xaa\x00\xff\xff\xff\xff\xad\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\x13\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\xcc\x00\xcd\x00\x4e\x00\xff\xff\xd0\x00\x8f\x00\x90\x00\xff\xff\xff\xff\x55\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x99\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa7\x00\xff\xff\xff\xff\xaa\x00\xff\xff\xff\xff\xad\x00\xff\xff\xff\xff\xff\xff\xff\xff\x13\x00\x75\x00\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xff\xff\xff\xff\xff\xff\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\x92\x00\x93\x00\x94\x00\xff\xff\xff\xff\xff\xff\xff\xff\x99\x00\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xa7\x00\xff\xff\xff\xff\xaa\x00\xff\xff\x13\x00\xad\x00\xff\xff\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xff\xff\xff\xff\xff\xff\x92\x00\x93\x00\x94\x00\xbd\x00\xbe\x00\xbf\x00\xc0\x00\x99\x00\xff\xff\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xca\x00\xff\xff\xcc\x00\xcd\x00\xa7\x00\xff\xff\xd0\x00\xaa\x00\xff\xff\xff\xff\xad\x00\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x00\xff\xff\xff\xff\xff\xff\xc2\x00\xc3\x00\xc4\x00\xaf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\xcc\x00\xcd\x00\xff\xff\xb9\x00\xd0\x00\xbb\x00\x99\x00\xff\xff\xff\xff\xff\xff\x9d\x00\xff\xff\xff\xff\xa0\x00\xa1\x00\xc5\x00\xff\xff\xc7\x00\xc8\x00\xc9\x00\xa7\x00\xcb\x00\xff\xff\xaa\x00\xce\x00\xcf\x00\xad\x00\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x00\xff\xff\xff\xff\xff\xff\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\x8f\x00\x90\x00\xca\x00\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\x99\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa7\x00\xff\xff\xff\xff\xaa\x00\xff\xff\xff\xff\xad\x00\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x00\xff\xff\xff\xff\xff\xff\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\x99\x00\xff\xff\xff\xff\xff\xff\x9d\x00\xff\xff\xff\xff\xa0\x00\xa1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa7\x00\xff\xff\xff\xff\xaa\x00\xff\xff\xff\xff\xad\x00\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x00\xff\xff\xff\xff\xff\xff\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\x99\x00\xff\xff\xff\xff\xff\xff\x9d\x00\xff\xff\xff\xff\xa0\x00\xa1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa7\x00\xff\xff\xff\xff\xaa\x00\xff\xff\xff\xff\xad\x00\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x00\xff\xff\xff\xff\xff\xff\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\x99\x00\xff\xff\xff\xff\xff\xff\x9d\x00\xff\xff\xff\xff\xa0\x00\xa1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa7\x00\xff\xff\xff\xff\xaa\x00\xff\xff\xff\xff\xad\x00\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x00\xff\xff\xff\xff\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\x99\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9f\x00\xa0\x00\xa1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa7\x00\xff\xff\xff\xff\xaa\x00\xff\xff\xff\xff\xad\x00\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x00\xff\xff\xff\xff\xc2\x00\xc3\x00\xc4\x00\xff\xff\x8d\x00\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\x99\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa7\x00\xff\xff\xff\xff\xaa\x00\xff\xff\xff\xff\xad\x00\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x00\xff\xff\xff\xff\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\xcc\x00\xcd\x00\x94\x00\x3b\x00\xd0\x00\xff\xff\xff\xff\x99\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x45\x00\x46\x00\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xa7\x00\xff\xff\x13\x00\xaa\x00\xff\xff\xff\xff\xad\x00\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x5f\x00\xff\xff\xff\xff\x62\x00\x63\x00\xff\xff\xff\xff\x66\x00\x67\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\x13\x00\xff\xff\xff\xff\xca\x00\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\x99\x00\xff\xff\xff\xff\xff\xff\xff\xff\x7d\x00\xff\xff\xff\xff\xa1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa7\x00\xff\xff\xff\xff\xaa\x00\xff\xff\x13\x00\xad\x00\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\x3c\x00\x3d\x00\xff\xff\x3f\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\x45\x00\x46\x00\x47\x00\xca\x00\xff\xff\xcc\x00\xcd\x00\x4c\x00\xff\xff\xd0\x00\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xff\xff\xff\xff\xff\xff\xa7\x00\x5f\x00\xff\xff\xaa\x00\x62\x00\x63\x00\xad\x00\xff\xff\x66\x00\x67\x00\x13\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xa7\x00\xcc\x00\xcd\x00\xaa\x00\x13\x00\xd0\x00\xad\x00\xff\xff\xff\xff\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc2\x00\xc3\x00\xc4\x00\xa7\x00\xff\xff\xff\xff\xaa\x00\x13\x00\xca\x00\xad\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc2\x00\xc3\x00\xc4\x00\xa7\x00\xff\xff\xff\xff\xaa\x00\xff\xff\xca\x00\xad\x00\xcc\x00\xcd\x00\xff\xff\x13\x00\xd0\x00\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\xcc\x00\xcd\x00\xff\xff\x13\x00\xd0\x00\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa7\x00\xff\xff\xff\xff\xaa\x00\xff\xff\xff\xff\xad\x00\xff\xff\x13\x00\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc2\x00\xc3\x00\xc4\x00\xa7\x00\xff\xff\xff\xff\xaa\x00\xff\xff\xca\x00\xad\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xff\xff\x13\x00\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xc2\x00\xc3\x00\xc4\x00\xa7\x00\xff\xff\xff\xff\xaa\x00\xff\xff\xca\x00\xad\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xff\xff\x13\x00\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xa7\x00\xcc\x00\xcd\x00\xaa\x00\xff\xff\xd0\x00\xad\x00\xff\xff\x13\x00\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc2\x00\xc3\x00\xc4\x00\xa7\x00\xff\xff\xff\xff\xaa\x00\xff\xff\xca\x00\xad\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xff\xff\x13\x00\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xc2\x00\xc3\x00\xc4\x00\xa7\x00\xff\xff\xff\xff\xaa\x00\xff\xff\xca\x00\xad\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xff\xff\x13\x00\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xa7\x00\xcc\x00\xcd\x00\xaa\x00\xff\xff\xd0\x00\xad\x00\xff\xff\x13\x00\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc2\x00\xc3\x00\xc4\x00\xa7\x00\xff\xff\xff\xff\xaa\x00\xff\xff\xca\x00\xad\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xff\xff\x13\x00\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xc2\x00\xc3\x00\xc4\x00\xa7\x00\xff\xff\xff\xff\xaa\x00\xff\xff\xca\x00\xad\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xff\xff\x13\x00\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xa7\x00\xcc\x00\xcd\x00\xaa\x00\xff\xff\xd0\x00\xad\x00\xff\xff\x13\x00\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc2\x00\xc3\x00\xc4\x00\xa7\x00\xff\xff\xff\xff\xaa\x00\xff\xff\xca\x00\xad\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xff\xff\x13\x00\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xc2\x00\xc3\x00\xc4\x00\xa7\x00\xff\xff\xff\xff\xaa\x00\xff\xff\xca\x00\xad\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xff\xff\x13\x00\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xa7\x00\xcc\x00\xcd\x00\xaa\x00\xff\xff\xd0\x00\xad\x00\xff\xff\x13\x00\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc2\x00\xc3\x00\xc4\x00\xa7\x00\xff\xff\xff\xff\xaa\x00\xff\xff\xca\x00\xad\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xff\xff\x13\x00\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xc2\x00\xc3\x00\xc4\x00\xa7\x00\xff\xff\xff\xff\xaa\x00\xff\xff\xca\x00\xad\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xff\xff\x13\x00\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xa7\x00\xcc\x00\xcd\x00\xaa\x00\xff\xff\xd0\x00\xad\x00\xff\xff\x13\x00\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc2\x00\xc3\x00\xc4\x00\xa7\x00\xff\xff\xff\xff\xaa\x00\xff\xff\xca\x00\xad\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xff\xff\x13\x00\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xc2\x00\xc3\x00\xc4\x00\xa7\x00\xff\xff\xff\xff\xaa\x00\xff\xff\xca\x00\xad\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xff\xff\x13\x00\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xa7\x00\xcc\x00\xcd\x00\xaa\x00\xff\xff\xd0\x00\xad\x00\xff\xff\x13\x00\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc2\x00\xc3\x00\xc4\x00\xa7\x00\xff\xff\xff\xff\xaa\x00\xff\xff\xca\x00\xad\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xff\xff\x13\x00\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xc2\x00\xc3\x00\xc4\x00\xa7\x00\xff\xff\xff\xff\xaa\x00\xff\xff\xca\x00\xad\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xff\xff\x13\x00\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xa7\x00\xcc\x00\xcd\x00\xaa\x00\xff\xff\xd0\x00\xad\x00\xff\xff\x13\x00\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc2\x00\xc3\x00\xc4\x00\xa7\x00\xff\xff\xff\xff\xaa\x00\xff\xff\xca\x00\xad\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xff\xff\x13\x00\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xc2\x00\xc3\x00\xc4\x00\xa7\x00\xff\xff\xff\xff\xaa\x00\xff\xff\xca\x00\xad\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xff\xff\x13\x00\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xa7\x00\xcc\x00\xcd\x00\xaa\x00\xff\xff\xd0\x00\xad\x00\xff\xff\x13\x00\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc2\x00\xc3\x00\xc4\x00\xa7\x00\xff\xff\xff\xff\xaa\x00\xff\xff\xca\x00\xad\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xff\xff\x13\x00\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xc2\x00\xc3\x00\xc4\x00\xa7\x00\xff\xff\xff\xff\xaa\x00\xff\xff\xca\x00\xad\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xff\xff\x13\x00\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xa7\x00\xcc\x00\xcd\x00\xaa\x00\xff\xff\xd0\x00\xad\x00\xff\xff\x13\x00\xff\xff\x75\x00\x76\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc2\x00\xc3\x00\xc4\x00\xa7\x00\xff\xff\xff\xff\xaa\x00\xff\xff\xca\x00\xad\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xff\xff\x13\x00\xff\xff\x75\x00\xff\xff\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xc2\x00\xc3\x00\xc4\x00\xa7\x00\xff\xff\xff\xff\xaa\x00\xff\xff\xca\x00\xad\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xff\xff\x13\x00\xff\xff\x75\x00\xff\xff\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xa7\x00\xcc\x00\xcd\x00\xaa\x00\xff\xff\xd0\x00\xad\x00\xff\xff\xff\xff\xff\xff\x75\x00\x13\x00\x77\x00\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc2\x00\xc3\x00\xc4\x00\xa7\x00\xff\xff\xff\xff\xaa\x00\xff\xff\xca\x00\xad\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xff\xff\x13\x00\xff\xff\x75\x00\xff\xff\xff\xff\x78\x00\xff\xff\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xc2\x00\xc3\x00\xc4\x00\xa7\x00\xff\xff\x13\x00\xaa\x00\xff\xff\xca\x00\xad\x00\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x13\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7d\x00\x7e\x00\x7f\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xa7\x00\xcc\x00\xcd\x00\xaa\x00\xff\xff\xd0\x00\xad\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\xff\xff\xff\xff\xff\xff\x9a\x00\x9b\x00\xff\xff\x13\x00\x7d\x00\x7e\x00\x7f\x00\xff\xff\xff\xff\xff\xff\xc2\x00\xc3\x00\xc4\x00\xa7\x00\xff\xff\xff\xff\xaa\x00\xff\xff\xca\x00\xad\x00\xcc\x00\xcd\x00\xff\xff\x13\x00\xd0\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\xff\xff\xff\xff\xff\xff\x9a\x00\x9b\x00\xff\xff\xff\xff\x7d\x00\x7e\x00\x7f\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xa7\x00\x75\x00\xca\x00\xaa\x00\xcc\x00\xcd\x00\xad\x00\xff\xff\xd0\x00\x7d\x00\x7e\x00\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\xff\xff\xff\xff\xff\xff\x9a\x00\xff\xff\xff\xff\xff\xff\x7d\x00\x7e\x00\x7f\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\x13\x00\xff\xff\xa7\x00\xff\xff\xca\x00\xaa\x00\xcc\x00\xcd\x00\xad\x00\xff\xff\xd0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x00\xff\xff\xa7\x00\xff\xff\xff\xff\xaa\x00\x75\x00\xff\xff\xad\x00\xff\xff\xff\xff\xc2\x00\xc3\x00\xc4\x00\x7d\x00\x7e\x00\x7f\x00\xa7\x00\x13\x00\xca\x00\xaa\x00\xcc\x00\xcd\x00\xad\x00\xff\xff\xd0\x00\x75\x00\xff\xff\xff\xff\xc2\x00\xc3\x00\xc4\x00\xff\xff\x13\x00\x7d\x00\x7e\x00\x7f\x00\xca\x00\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\xcc\x00\xcd\x00\xa7\x00\xff\xff\xd0\x00\xaa\x00\xff\xff\xff\xff\xad\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x00\xff\xff\xff\xff\xff\xff\xa7\x00\xff\xff\xff\xff\xaa\x00\x75\x00\xff\xff\xad\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\x7d\x00\x7e\x00\x7f\x00\xca\x00\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\x75\x00\xff\xff\xff\xff\xff\xff\xff\xff\xc2\x00\xc3\x00\xc4\x00\x7d\x00\x7e\x00\x7f\x00\xff\xff\xff\xff\xca\x00\xff\xff\xcc\x00\xcd\x00\xff\xff\x75\x00\xd0\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7d\x00\x7e\x00\x7f\x00\xff\xff\xff\xff\xff\xff\xa7\x00\x75\x00\xff\xff\xaa\x00\xff\xff\xff\xff\xad\x00\xff\xff\xff\xff\x7d\x00\x7e\x00\x7f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa7\x00\xff\xff\xff\xff\xaa\x00\xff\xff\xff\xff\xad\x00\xff\xff\xff\xff\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xa7\x00\xcc\x00\xcd\x00\xaa\x00\x75\x00\xd0\x00\xad\x00\xff\xff\xff\xff\xc2\x00\xc3\x00\xc4\x00\x7d\x00\x7e\x00\x7f\x00\xa7\x00\xff\xff\xca\x00\xaa\x00\xcc\x00\xcd\x00\xad\x00\x3b\x00\xd0\x00\x3d\x00\xff\xff\xff\xff\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\x45\x00\x46\x00\x47\x00\xca\x00\xff\xff\xcc\x00\xcd\x00\x4c\x00\xff\xff\xd0\x00\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\xcc\x00\xcd\x00\xa7\x00\xff\xff\xd0\x00\xaa\x00\x5f\x00\xff\xff\xad\x00\x62\x00\x63\x00\xff\xff\xff\xff\x66\x00\x67\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc2\x00\xc3\x00\xc4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\xcc\x00\xcd\x00\xff\xff\xff\xff\xd0\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\xff\xff\x0a\x00\x0b\x00\x0c\x00\xff\xff\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\xff\xff\x14\x00\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\x38\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\x55\x00\xff\xff\x57\x00\xff\xff\x59\x00\xff\xff\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x60\x00\x61\x00\xff\xff\xff\xff\x64\x00\x65\x00\xff\xff\xff\xff\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\xff\xff\x14\x00\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\x38\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\x55\x00\xff\xff\x57\x00\xff\xff\x59\x00\xff\xff\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x60\x00\x61\x00\xff\xff\xff\xff\x64\x00\x65\x00\xff\xff\xff\xff\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\x0e\x00\x0f\x00\x10\x00\xff\xff\x12\x00\xff\xff\x14\x00\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\x1a\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\x55\x00\xff\xff\x57\x00\xff\xff\x59\x00\xff\xff\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x60\x00\x61\x00\xff\xff\xff\xff\x64\x00\x65\x00\xff\xff\xff\xff\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\x0e\x00\x0f\x00\x10\x00\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\x1a\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\x55\x00\xff\xff\x57\x00\xff\xff\x59\x00\xff\xff\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x60\x00\x61\x00\xff\xff\xff\xff\x64\x00\x65\x00\xff\xff\xff\xff\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\x0e\x00\x0f\x00\x10\x00\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\x55\x00\xff\xff\x57\x00\xff\xff\x59\x00\xff\xff\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x60\x00\x61\x00\xff\xff\xff\xff\x64\x00\x65\x00\xff\xff\xff\xff\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\x45\x00\x46\x00\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\x55\x00\xff\xff\x57\x00\x58\x00\x59\x00\xff\xff\x5b\x00\xff\xff\xff\xff\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\x79\x00\x7a\x00\x7b\x00\x7c\x00\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\x45\x00\x46\x00\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\x55\x00\xff\xff\x57\x00\xff\xff\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\x79\x00\x7a\x00\x7b\x00\x7c\x00\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\x45\x00\x46\x00\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\x55\x00\xff\xff\x57\x00\x58\x00\x59\x00\xff\xff\x5b\x00\xff\xff\xff\xff\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\x79\x00\x7a\x00\x7b\x00\x7c\x00\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\x45\x00\x46\x00\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\x55\x00\xff\xff\x57\x00\xff\xff\x59\x00\x5a\x00\x5b\x00\xff\xff\xff\xff\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\x79\x00\x7a\x00\x7b\x00\x7c\x00\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\x45\x00\x46\x00\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\x55\x00\xff\xff\x57\x00\x58\x00\x59\x00\xff\xff\x5b\x00\xff\xff\xff\xff\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\x79\x00\x7a\x00\x7b\x00\x7c\x00\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\x45\x00\x46\x00\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\x55\x00\xff\xff\x57\x00\xff\xff\x59\x00\xff\xff\x5b\x00\xff\xff\xff\xff\x5e\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\x79\x00\x7a\x00\x7b\x00\x7c\x00\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\x45\x00\x46\x00\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\x54\x00\x55\x00\xff\xff\x57\x00\xff\xff\x59\x00\xff\xff\x5b\x00\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\x79\x00\x7a\x00\x7b\x00\x7c\x00\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\x45\x00\x46\x00\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\x55\x00\xff\xff\x57\x00\xff\xff\x59\x00\xff\xff\x5b\x00\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\x79\x00\x7a\x00\x7b\x00\x7c\x00\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\x55\x00\xff\xff\x57\x00\xff\xff\x59\x00\xff\xff\x5b\x00\xff\xff\x5d\x00\xff\xff\xff\xff\x60\x00\x61\x00\xff\xff\xff\xff\x64\x00\x65\x00\xff\xff\xff\xff\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\x79\x00\x7a\x00\x7b\x00\x7c\x00\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\xff\xff\x1a\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\x55\x00\xff\xff\x57\x00\xff\xff\x59\x00\xff\xff\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x60\x00\x61\x00\xff\xff\xff\xff\x64\x00\x65\x00\xff\xff\xff\xff\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\x79\x00\x7a\x00\x7b\x00\x7c\x00\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\x55\x00\xff\xff\x57\x00\xff\xff\x59\x00\xff\xff\x5b\x00\xff\xff\x5d\x00\xff\xff\xff\xff\x60\x00\x61\x00\xff\xff\xff\xff\x64\x00\x65\x00\xff\xff\xff\xff\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\x79\x00\x7a\x00\x7b\x00\x7c\x00\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\xff\xff\x1a\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\x55\x00\xff\xff\x57\x00\xff\xff\x59\x00\xff\xff\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x60\x00\x61\x00\xff\xff\xff\xff\x64\x00\x65\x00\xff\xff\xff\xff\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\x79\x00\x7a\x00\x7b\x00\x7c\x00\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\x55\x00\xff\xff\x57\x00\xff\xff\x59\x00\xff\xff\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x60\x00\x61\x00\xff\xff\xff\xff\x64\x00\x65\x00\xff\xff\xff\xff\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\x79\x00\x7a\x00\x7b\x00\x7c\x00\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\x55\x00\xff\xff\x57\x00\xff\xff\x59\x00\xff\xff\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x60\x00\x61\x00\xff\xff\xff\xff\x64\x00\x65\x00\xff\xff\xff\xff\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\x79\x00\x7a\x00\x7b\x00\x7c\x00\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\x55\x00\xff\xff\x57\x00\xff\xff\x59\x00\xff\xff\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x60\x00\x61\x00\xff\xff\xff\xff\x64\x00\x65\x00\xff\xff\xff\xff\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\x79\x00\x7a\x00\x7b\x00\x7c\x00\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\x45\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\x55\x00\xff\xff\x57\x00\xff\xff\x59\x00\xff\xff\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x60\x00\x61\x00\xff\xff\xff\xff\x64\x00\x65\x00\xff\xff\xff\xff\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\x79\x00\x7a\x00\x7b\x00\x7c\x00\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\x55\x00\xff\xff\x57\x00\xff\xff\x59\x00\xff\xff\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x60\x00\x61\x00\xff\xff\xff\xff\x64\x00\x65\x00\xff\xff\xff\xff\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\x79\x00\x7a\x00\x7b\x00\x7c\x00\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\x55\x00\xff\xff\x57\x00\xff\xff\x59\x00\xff\xff\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x60\x00\x61\x00\xff\xff\xff\xff\x64\x00\x65\x00\xff\xff\xff\xff\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\x79\x00\x7a\x00\x7b\x00\x7c\x00\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\x45\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\x55\x00\x55\x00\x57\x00\xff\xff\x59\x00\xff\xff\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x60\x00\x61\x00\xff\xff\xff\xff\x64\x00\x65\x00\xff\xff\xff\xff\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\xff\xff\x75\x00\xff\xff\xff\xff\x79\x00\x7a\x00\x7b\x00\x7c\x00\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xb0\x00\xb1\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xbe\x00\xbf\x00\xc0\x00\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\xff\xff\x46\x00\xff\xff\xff\xff\xca\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\x55\x00\x55\x00\x57\x00\xff\xff\x59\x00\xff\xff\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x60\x00\x61\x00\xff\xff\xff\xff\x64\x00\x65\x00\xff\xff\xff\xff\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\xff\xff\x75\x00\xff\xff\xff\xff\x79\x00\x7a\x00\x7b\x00\x7c\x00\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\xff\xff\x53\x00\xff\xff\x55\x00\x4e\x00\x57\x00\x55\x00\x59\x00\x52\x00\x5b\x00\x54\x00\x55\x00\xff\xff\xff\xff\x60\x00\x61\x00\xff\xff\xff\xff\x64\x00\x65\x00\xff\xff\xff\xff\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\xff\xff\x75\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x75\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x01\x00\x02\x00\xff\xff\x3b\x00\x3c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x16\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x24\x00\x25\x00\x26\x00\x27\x00\x5f\x00\xff\xff\x2a\x00\x62\x00\x63\x00\xff\xff\xff\xff\x66\x00\x67\x00\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\xbf\x00\xff\xff\xff\xff\xbd\x00\xff\xff\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\xff\xff\xff\xff\x4e\x00\xca\x00\xff\xff\xff\xff\x53\x00\xff\xff\x55\x00\x55\x00\x57\x00\xff\xff\x59\x00\xff\xff\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\x60\x00\x61\x00\xff\xff\xff\xff\x64\x00\x65\x00\xff\xff\xff\xff\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\xff\xff\x75\x00\xff\xff\xff\xff\x79\x00\x7a\x00\x7b\x00\x7c\x00\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\x55\x00\xff\xff\x57\x00\xff\xff\x59\x00\xff\xff\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x60\x00\x61\x00\xff\xff\xff\xff\x64\x00\x65\x00\xff\xff\xff\xff\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\x79\x00\x7a\x00\x7b\x00\x7c\x00\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x24\x00\x25\x00\x26\x00\x27\x00\x49\x00\xff\xff\x2a\x00\xff\xff\xff\xff\x4e\x00\x4f\x00\xff\xff\x51\x00\x52\x00\xff\xff\x54\x00\x55\x00\x56\x00\x57\x00\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\x4c\x00\xff\xff\x4e\x00\x4f\x00\xff\xff\x51\x00\x52\x00\xff\xff\x54\x00\x55\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\x75\x00\x55\x00\xff\xff\x57\x00\xff\xff\x59\x00\xff\xff\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x60\x00\x61\x00\xff\xff\xff\xff\x64\x00\x65\x00\x75\x00\xff\xff\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\xff\xff\xff\xff\xff\xff\xff\xff\x79\x00\x7a\x00\x7b\x00\x7c\x00\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\x82\x00\xff\xff\xff\xff\xff\xff\xa7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xa7\x00\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\xbf\x00\xff\xff\xff\xff\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\xff\xff\x49\x00\xff\xff\xbd\x00\x4c\x00\xbf\x00\x4e\x00\x4f\x00\xff\xff\x51\x00\x52\x00\xff\xff\x54\x00\x55\x00\xff\xff\xff\xff\xca\x00\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\x4f\x00\xff\xff\x51\x00\x52\x00\xff\xff\x54\x00\x55\x00\x56\x00\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\x4f\x00\xff\xff\x51\x00\x52\x00\x75\x00\x54\x00\x55\x00\x56\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\x4f\x00\x75\x00\x51\x00\x52\x00\xff\xff\x54\x00\x55\x00\x56\x00\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\x4f\x00\x75\x00\x51\x00\x52\x00\xff\xff\x54\x00\x55\x00\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\x4f\x00\xa7\x00\x51\x00\x52\x00\x75\x00\x54\x00\x55\x00\xff\xff\xff\xff\xff\xff\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\xff\xff\xff\xff\xa7\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\xbd\x00\xff\xff\xbf\x00\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xa7\x00\xca\x00\xff\xff\x75\x00\xbd\x00\xff\xff\xbf\x00\xff\xff\xff\xff\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\xa7\x00\xff\xff\xff\xff\xbd\x00\xff\xff\xbf\x00\xff\xff\xff\xff\xff\xff\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\xff\xff\xff\xff\xca\x00\xff\xff\xa7\x00\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\xbf\x00\xff\xff\xff\xff\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\xff\xff\xff\xff\xa7\x00\xca\x00\xff\xff\xff\xff\x4e\x00\xff\xff\xbd\x00\xff\xff\xbf\x00\xb0\x00\xb1\x00\x55\x00\xb3\x00\xb4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\x49\x00\xff\xff\xbd\x00\xff\xff\xbf\x00\x4e\x00\x4f\x00\xff\xff\x51\x00\x52\x00\xff\xff\x54\x00\x55\x00\xff\xff\xff\xff\xca\x00\x49\x00\xff\xff\x02\x00\xff\xff\xff\xff\x4e\x00\x4f\x00\x75\x00\x51\x00\x52\x00\x0a\x00\x54\x00\x55\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\x75\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\xff\xff\xff\xff\x4e\x00\xff\xff\x50\x00\x51\x00\xff\xff\x53\x00\x54\x00\x55\x00\xff\xff\xff\xff\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa7\x00\xbd\x00\xff\xff\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\xca\x00\xff\xff\xa7\x00\x75\x00\x60\x00\x61\x00\xff\xff\xff\xff\xbd\x00\x65\x00\xbf\x00\xb0\x00\xb1\x00\x69\x00\xb3\x00\xb4\x00\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xca\x00\xff\xff\xff\xff\xbd\x00\xff\xff\xbf\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xa7\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\xbd\x00\xff\xff\xbf\x00\x3d\x00\xff\xff\x3f\x00\xff\xff\x41\x00\xff\xff\x43\x00\x44\x00\xff\xff\x46\x00\xca\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\x02\x00\x55\x00\xff\xff\x57\x00\xff\xff\x59\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\x16\x00\x69\x00\xff\xff\xff\xff\xff\xff\x6d\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x76\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\x7e\x00\x7f\x00\xff\xff\xff\xff\x82\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\x4f\x00\x37\x00\x51\x00\x52\x00\xff\xff\x54\x00\x55\x00\xff\xff\xff\xff\x58\x00\x59\x00\x41\x00\xff\xff\x43\x00\x44\x00\xff\xff\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\x55\x00\xff\xff\x57\x00\xff\xff\x59\x00\xff\xff\xff\xff\x75\x00\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\x02\x00\x69\x00\xff\xff\xff\xff\xff\xff\x6d\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x76\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\x7e\x00\x7f\x00\xff\xff\x1b\x00\x82\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\xa7\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\xff\xff\x37\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\xbf\x00\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\x02\x00\x55\x00\xff\xff\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\x0a\x00\xff\xff\x5e\x00\xff\xff\x60\x00\x61\x00\x62\x00\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\x16\x00\x69\x00\x6a\x00\xff\xff\xff\xff\x6d\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x4e\x00\xff\xff\x2a\x00\xff\xff\x7e\x00\x7f\x00\x54\x00\x55\x00\x82\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\xff\xff\x43\x00\x44\x00\xff\xff\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\x4d\x00\xff\xff\x75\x00\xff\xff\xff\xff\xff\xff\x53\x00\x02\x00\x55\x00\xff\xff\x57\x00\xff\xff\x59\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\x16\x00\x69\x00\xff\xff\xff\xff\xff\xff\x6d\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\x7e\x00\x7f\x00\xff\xff\xff\xff\x82\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x37\x00\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\xff\xff\x43\x00\xff\xff\xbd\x00\x46\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\x53\x00\x02\x00\x55\x00\xff\xff\x57\x00\xff\xff\x59\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\xff\xff\x65\x00\xff\xff\x67\x00\x16\x00\x69\x00\xff\xff\xff\xff\xff\xff\x6d\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\x7e\x00\x7f\x00\xff\xff\xff\xff\x82\x00\xff\xff\xff\xff\x4e\x00\xff\xff\xff\xff\x51\x00\x37\x00\xff\xff\x54\x00\x55\x00\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4a\x00\xff\xff\x43\x00\x44\x00\x4e\x00\x46\x00\x50\x00\x51\x00\xff\xff\x53\x00\x54\x00\x55\x00\x4d\x00\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\x55\x00\xff\xff\x57\x00\xff\xff\x59\x00\x75\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\xff\xff\x02\x00\x69\x00\xff\xff\xff\xff\x75\x00\x6d\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\x7e\x00\x7f\x00\xff\xff\x1b\x00\x82\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\xff\xff\xff\xff\xff\xff\x37\x00\xa7\x00\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\xbf\x00\xff\xff\xff\xff\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\x46\x00\xff\xff\xff\xff\xca\x00\xff\xff\xff\xff\xff\xff\x4d\x00\xbd\x00\xff\xff\xbf\x00\xff\xff\xff\xff\x53\x00\x02\x00\x55\x00\xff\xff\x57\x00\xff\xff\x59\x00\x5a\x00\xca\x00\x0a\x00\xff\xff\x5e\x00\xff\xff\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\x16\x00\x69\x00\x6a\x00\xff\xff\xff\xff\x6d\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\x7e\x00\x7f\x00\xff\xff\xff\xff\x82\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\x02\x00\x55\x00\xff\xff\x57\x00\xff\xff\x59\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\x5f\x00\x60\x00\x61\x00\xff\xff\x63\x00\xff\xff\x65\x00\xff\xff\xff\xff\x16\x00\x69\x00\xff\xff\xff\xff\xff\xff\x6d\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\x7e\x00\x7f\x00\xff\xff\xff\xff\x82\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\x4f\x00\x37\x00\x51\x00\x52\x00\xff\xff\x54\x00\x55\x00\x3d\x00\xff\xff\x3f\x00\x59\x00\x4a\x00\xff\xff\xff\xff\x44\x00\x4e\x00\x46\x00\x50\x00\x51\x00\xff\xff\x53\x00\x54\x00\x55\x00\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\x55\x00\xff\xff\x57\x00\xff\xff\x59\x00\xff\xff\xff\xff\x75\x00\xff\xff\xff\xff\xff\xff\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\x02\x00\x69\x00\xff\xff\xff\xff\x75\x00\x6d\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\x7e\x00\x7f\x00\xff\xff\x1b\x00\x82\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\xa7\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\xff\xff\x37\x00\xa7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\xbf\x00\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\x4d\x00\xbd\x00\xff\xff\xbf\x00\xff\xff\xff\xff\x53\x00\xff\xff\x55\x00\xff\xff\x57\x00\x58\x00\x59\x00\xff\xff\xca\x00\xff\xff\xff\xff\xff\xff\xff\xff\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\x02\x00\x69\x00\x6a\x00\xff\xff\xff\xff\x6d\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\x7e\x00\x7f\x00\xff\xff\x1b\x00\x82\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x54\x00\x55\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\xff\xff\xff\xff\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\x69\x00\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\x55\x00\x56\x00\x57\x00\xff\xff\x59\x00\xff\xff\x75\x00\xff\xff\xff\xff\xff\xff\xff\xff\x60\x00\x61\x00\xff\xff\x75\x00\xff\xff\x65\x00\xff\xff\xff\xff\x02\x00\x69\x00\x6a\x00\xff\xff\xff\xff\x6d\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\x7e\x00\x7f\x00\xff\xff\x1b\x00\x82\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xa7\x00\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\xff\xff\xff\xff\x37\x00\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\xbd\x00\xff\xff\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\x46\x00\xbf\x00\xff\xff\xff\xff\xca\x00\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\x53\x00\x54\x00\x55\x00\xff\xff\x57\x00\xff\xff\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\x02\x00\x69\x00\x6a\x00\xff\xff\xff\xff\x6d\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\x7e\x00\x7f\x00\xff\xff\x1b\x00\x82\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\xff\xff\xff\xff\x37\x00\x52\x00\xff\xff\x54\x00\x55\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\xff\xff\xff\xff\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\x55\x00\xff\xff\x57\x00\xff\xff\x59\x00\xff\xff\x75\x00\xff\xff\xff\xff\xff\xff\xff\xff\x60\x00\x61\x00\xff\xff\x75\x00\xff\xff\x65\x00\xff\xff\xff\xff\x02\x00\x69\x00\x6a\x00\xff\xff\xff\xff\x6d\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\x7e\x00\x7f\x00\xff\xff\x1b\x00\x82\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xa7\x00\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\xff\xff\xff\xff\x37\x00\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\xbd\x00\xff\xff\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\x46\x00\xbf\x00\xff\xff\xff\xff\xca\x00\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\x53\x00\xff\xff\x55\x00\xff\xff\x57\x00\xff\xff\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\x02\x00\x69\x00\x6a\x00\xff\xff\xff\xff\x6d\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\x7e\x00\x7f\x00\xff\xff\x1b\x00\x82\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\xff\xff\xff\xff\x37\x00\x52\x00\xff\xff\x54\x00\x55\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\xff\xff\xff\xff\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\x55\x00\xff\xff\x57\x00\xff\xff\x59\x00\xff\xff\x75\x00\xff\xff\xff\xff\xff\xff\xff\xff\x60\x00\x61\x00\xff\xff\x75\x00\xff\xff\x65\x00\xff\xff\xff\xff\x02\x00\x69\x00\x6a\x00\xff\xff\xff\xff\x6d\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\x7e\x00\x7f\x00\xff\xff\x1b\x00\x82\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xa7\x00\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\xff\xff\xff\xff\x37\x00\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\xbd\x00\xff\xff\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\x46\x00\xbf\x00\xff\xff\xff\xff\xca\x00\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\x53\x00\xff\xff\x55\x00\xff\xff\x57\x00\xff\xff\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\x02\x00\x69\x00\x6a\x00\xff\xff\xff\xff\x6d\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\x7e\x00\x7f\x00\xff\xff\x1b\x00\x82\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\x4f\x00\x37\x00\x51\x00\x52\x00\xff\xff\x54\x00\x55\x00\xff\xff\xff\xff\xff\xff\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\x46\x00\x50\x00\x51\x00\xff\xff\x53\x00\x54\x00\x55\x00\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\x55\x00\xff\xff\x57\x00\xff\xff\x59\x00\xff\xff\xff\xff\x75\x00\xff\xff\xff\xff\xff\xff\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\x02\x00\x69\x00\x6a\x00\xff\xff\x75\x00\x6d\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\x7e\x00\x7f\x00\xff\xff\x1b\x00\x82\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\xa7\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\xff\xff\x37\x00\xa7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\xbf\x00\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\x4d\x00\xbd\x00\xff\xff\xbf\x00\xff\xff\xff\xff\x53\x00\xff\xff\x55\x00\xff\xff\x57\x00\xff\xff\x59\x00\xff\xff\xca\x00\xff\xff\xff\xff\xff\xff\xff\xff\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\x02\x00\x69\x00\x6a\x00\xff\xff\xff\xff\x6d\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\x7e\x00\x7f\x00\xff\xff\x1b\x00\x82\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\x4f\x00\x37\x00\x51\x00\x52\x00\xff\xff\x54\x00\x55\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\x46\x00\x50\x00\x51\x00\xff\xff\x53\x00\x54\x00\x55\x00\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\x55\x00\xff\xff\x57\x00\xff\xff\x59\x00\xff\xff\xff\xff\x75\x00\xff\xff\xff\xff\xff\xff\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\x02\x00\x69\x00\x6a\x00\xff\xff\x75\x00\x6d\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\x7e\x00\x7f\x00\xff\xff\x1b\x00\x82\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\xa7\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\xff\xff\x37\x00\xa7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\xbf\x00\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\x4d\x00\xbd\x00\xff\xff\xbf\x00\xff\xff\xff\xff\x53\x00\xff\xff\x55\x00\xff\xff\x57\x00\xff\xff\x59\x00\xff\xff\xca\x00\xff\xff\xff\xff\xff\xff\xff\xff\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\x02\x00\x69\x00\x6a\x00\xff\xff\xff\xff\x6d\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\x7e\x00\x7f\x00\xff\xff\x1b\x00\x82\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\x4f\x00\x37\x00\x51\x00\x52\x00\xff\xff\x54\x00\x55\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\x46\x00\x50\x00\x51\x00\xff\xff\x53\x00\x54\x00\x55\x00\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\x55\x00\xff\xff\x57\x00\xff\xff\x59\x00\xff\xff\xff\xff\x75\x00\xff\xff\xff\xff\xff\xff\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\x02\x00\x69\x00\x6a\x00\xff\xff\x75\x00\x6d\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\x7e\x00\x7f\x00\xff\xff\x1b\x00\x82\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\xa7\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\xff\xff\x37\x00\xa7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\xbf\x00\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\x4d\x00\xbd\x00\xff\xff\xbf\x00\xff\xff\xff\xff\x53\x00\xff\xff\x55\x00\xff\xff\x57\x00\xff\xff\x59\x00\xff\xff\xca\x00\xff\xff\xff\xff\xff\xff\xff\xff\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\x02\x00\x69\x00\x6a\x00\xff\xff\xff\xff\x6d\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\x7e\x00\x7f\x00\xff\xff\x1b\x00\x82\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\x4f\x00\x37\x00\x51\x00\x52\x00\xff\xff\x54\x00\x55\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\x46\x00\x50\x00\x51\x00\xff\xff\x53\x00\x54\x00\x55\x00\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\x55\x00\xff\xff\x57\x00\xff\xff\x59\x00\xff\xff\xff\xff\x75\x00\xff\xff\xff\xff\xff\xff\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\x02\x00\x69\x00\x6a\x00\xff\xff\x75\x00\x6d\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\x7e\x00\x7f\x00\xff\xff\x1b\x00\x82\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\xa7\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\xff\xff\x37\x00\xa7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\xbf\x00\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\x4d\x00\xbd\x00\xff\xff\xbf\x00\xff\xff\xff\xff\x53\x00\x02\x00\x55\x00\xff\xff\x57\x00\xff\xff\x59\x00\xff\xff\xca\x00\x0a\x00\xff\xff\xff\xff\xff\xff\x60\x00\x61\x00\xff\xff\x11\x00\xff\xff\x65\x00\xff\xff\xff\xff\x16\x00\x69\x00\x6a\x00\xff\xff\xff\xff\x6d\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\x7e\x00\x7f\x00\xff\xff\xff\xff\x82\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\x4f\x00\x37\x00\x51\x00\x52\x00\xff\xff\x54\x00\x55\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\x46\x00\x50\x00\x51\x00\xff\xff\x53\x00\x54\x00\x55\x00\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\x55\x00\xff\xff\x57\x00\xff\xff\x59\x00\xff\xff\xff\xff\x75\x00\xff\xff\xff\xff\xff\xff\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\x02\x00\x69\x00\xff\xff\xff\xff\x75\x00\x6d\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\x7e\x00\x7f\x00\xff\xff\x1b\x00\x82\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\xa7\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\xff\xff\x37\x00\xa7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\xbf\x00\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\x4d\x00\xbd\x00\xff\xff\xbf\x00\xff\xff\xff\xff\x53\x00\x02\x00\x55\x00\xff\xff\x57\x00\xff\xff\x59\x00\xff\xff\xca\x00\x0a\x00\xff\xff\xff\xff\xff\xff\x60\x00\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\xff\xff\xff\xff\x16\x00\x69\x00\x6a\x00\xff\xff\xff\xff\x6d\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x4e\x00\xff\xff\x2a\x00\xff\xff\x7e\x00\x7f\x00\x54\x00\x55\x00\x82\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x44\x00\xff\xff\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\x75\x00\xff\xff\xff\xff\xff\xff\x53\x00\x02\x00\x55\x00\xff\xff\x57\x00\xff\xff\x59\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\x60\x00\x61\x00\xff\xff\x11\x00\xff\xff\x65\x00\xff\xff\xff\xff\x16\x00\x69\x00\xff\xff\xff\xff\xff\xff\x6d\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\x7e\x00\x7f\x00\xff\xff\xff\xff\x82\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x37\x00\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\xff\xff\xff\xff\x3b\x00\x3c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\x46\x00\xbf\x00\xff\xff\x45\x00\x46\x00\x47\x00\xff\xff\x4d\x00\xff\xff\xff\xff\x4c\x00\xff\xff\xca\x00\x53\x00\x02\x00\x55\x00\xff\xff\x57\x00\xff\xff\x59\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\x60\x00\x61\x00\xff\xff\x5f\x00\xff\xff\x65\x00\x62\x00\x63\x00\x16\x00\x69\x00\x66\x00\x67\x00\xff\xff\x6d\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\x7e\x00\x7f\x00\xff\xff\xff\xff\x82\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\x4f\x00\x37\x00\x51\x00\x52\x00\xff\xff\x54\x00\x55\x00\x4e\x00\x4f\x00\xff\xff\x51\x00\x52\x00\xff\xff\x54\x00\x55\x00\xff\xff\x46\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\x55\x00\xff\xff\x57\x00\xff\xff\x59\x00\xff\xff\xff\xff\x75\x00\xff\xff\xff\xff\xff\xff\x60\x00\x61\x00\xff\xff\xff\xff\x75\x00\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\x4e\x00\x4f\x00\x6d\x00\x51\x00\x52\x00\xff\xff\x54\x00\x55\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7e\x00\x7f\x00\x4e\x00\x4f\x00\x82\x00\x51\x00\x52\x00\xff\xff\x54\x00\x55\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa7\x00\xff\xff\xff\xff\xff\xff\x75\x00\xff\xff\xff\xff\xff\xff\xa7\x00\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\xff\xff\xff\xff\xff\xff\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\xbd\x00\xff\xff\xbf\x00\x75\x00\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\xbf\x00\x4e\x00\x4f\x00\xca\x00\x51\x00\x52\x00\xff\xff\x54\x00\x55\x00\x4e\x00\x4f\x00\xca\x00\x51\x00\x52\x00\xff\xff\x54\x00\x55\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\xff\xff\xff\xff\xa7\x00\xbd\x00\xff\xff\xbf\x00\xff\xff\x75\x00\xff\xff\xff\xff\xff\xff\xb0\x00\xb1\x00\x4e\x00\xb3\x00\xb4\x00\xca\x00\x52\x00\xff\xff\x54\x00\x55\x00\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\xbf\x00\xff\xff\xff\xff\x4e\x00\x4f\x00\xff\xff\x51\x00\x52\x00\xff\xff\x54\x00\x55\x00\xca\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\x4f\x00\xa7\x00\x51\x00\x52\x00\x75\x00\x54\x00\x55\x00\xff\xff\xff\xff\xa7\x00\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\xff\xff\xff\xff\xff\xff\xb0\x00\xb1\x00\x75\x00\xb3\x00\xb4\x00\xbd\x00\xff\xff\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\xbf\x00\xff\xff\x4e\x00\xca\x00\xff\xff\x75\x00\x52\x00\xff\xff\x54\x00\x55\x00\xff\xff\xca\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\xff\xff\xff\xff\xff\xff\x52\x00\xff\xff\x54\x00\x55\x00\xff\xff\xff\xff\xff\xff\xff\xff\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\xff\xff\xff\xff\xa7\x00\xff\xff\xff\xff\xff\xff\x75\x00\xff\xff\xbd\x00\xff\xff\xbf\x00\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xa7\x00\xca\x00\x75\x00\xff\xff\xbd\x00\xff\xff\xbf\x00\xff\xff\xff\xff\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\x4e\x00\xff\xff\xff\xff\xca\x00\x52\x00\xff\xff\x54\x00\x55\x00\xbd\x00\xff\xff\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\xff\xff\xff\xff\xff\xff\x52\x00\xca\x00\x54\x00\x55\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\x4e\x00\xff\xff\xff\xff\x75\x00\x52\x00\xff\xff\x54\x00\x55\x00\xbd\x00\xff\xff\xbf\x00\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\x4e\x00\xff\xff\xff\xff\x75\x00\x52\x00\xca\x00\x54\x00\x55\x00\xbd\x00\xff\xff\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\xff\xff\xff\xff\xca\x00\x52\x00\x75\x00\x54\x00\x55\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\xff\xff\xff\xff\xff\xff\x52\x00\x75\x00\x54\x00\x55\x00\xff\xff\xff\xff\xff\xff\xff\xff\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\xff\xff\xbd\x00\xff\xff\xbf\x00\xb0\x00\xb1\x00\x4e\x00\xb3\x00\xb4\x00\xff\xff\x52\x00\xff\xff\x54\x00\x55\x00\xca\x00\x75\x00\xff\xff\xbd\x00\xff\xff\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\xff\xff\xca\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\xbf\x00\xb0\x00\xb1\x00\x4e\x00\xb3\x00\xb4\x00\x75\x00\x52\x00\xff\xff\x54\x00\x55\x00\xca\x00\xff\xff\xff\xff\xbd\x00\xff\xff\xbf\x00\xff\xff\xff\xff\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\x4e\x00\xff\xff\xff\xff\xca\x00\x52\x00\xff\xff\x54\x00\x55\x00\xbd\x00\xff\xff\xbf\x00\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\x4e\x00\xff\xff\x75\x00\xff\xff\x52\x00\xca\x00\x54\x00\x55\x00\xbd\x00\xff\xff\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\x75\x00\xff\xff\xb0\x00\xb1\x00\x4e\x00\xb3\x00\xb4\x00\xff\xff\x52\x00\xff\xff\x54\x00\x55\x00\xff\xff\xff\xff\xff\xff\xbd\x00\x75\x00\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\x75\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\xff\xff\xff\xff\xbd\x00\x52\x00\xbf\x00\x54\x00\x55\x00\xff\xff\xff\xff\xff\xff\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\xca\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\xbf\x00\xb0\x00\xb1\x00\x4e\x00\xb3\x00\xb4\x00\xff\xff\xff\xff\xff\xff\x54\x00\x55\x00\xca\x00\xff\xff\x75\x00\xbd\x00\xff\xff\xbf\x00\xff\xff\xff\xff\x4e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x54\x00\x55\x00\xca\x00\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4e\x00\xff\xff\xff\xff\xbd\x00\x75\x00\xbf\x00\x54\x00\x55\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\x4e\x00\xff\xff\xff\xff\x75\x00\xff\xff\xff\xff\x54\x00\x55\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\x75\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x75\x00\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\xff\xff\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\xbf\x00\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\xff\xff\xff\xff\xbd\x00\xff\xff\xbf\x00\xff\xff\xff\xff\xff\xff\xb0\x00\xb1\x00\xff\xff\xb3\x00\xb4\x00\xff\xff\xff\xff\xca\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbd\x00\xff\xff\xbf\x00\xff\xff\xb0\x00\xb1\x00\x02\x00\xb3\x00\xb4\x00\xff\xff\xff\xff\xff\xff\xff\xff\xca\x00\x0a\x00\xff\xff\xff\xff\xbd\x00\xff\xff\xbf\x00\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\xca\x00\x1b\x00\x0a\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x24\x00\x25\x00\x26\x00\x27\x00\x16\x00\xff\xff\x2a\x00\xff\xff\xff\xff\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x57\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x60\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x02\x00\x57\x00\xff\xff\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\x6c\x00\xff\xff\xff\xff\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x57\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6c\x00\xff\xff\x45\x00\x46\x00\x47\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\xff\xff\x02\x00\x57\x00\xff\xff\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x5f\x00\x60\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x16\x00\xff\xff\x18\x00\xff\xff\xff\xff\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x02\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\x18\x00\x3a\x00\xff\xff\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\xff\xff\xff\xff\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x60\x00\x61\x00\xff\xff\xff\xff\x64\x00\x65\x00\xff\xff\xff\xff\x68\x00\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x53\x00\xff\xff\xff\xff\xff\xff\x57\x00\xff\xff\x59\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x60\x00\x61\x00\xff\xff\x13\x00\x64\x00\x65\x00\x16\x00\xff\xff\x68\x00\x69\x00\xff\xff\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x02\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x57\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5e\x00\xff\xff\x60\x00\x61\x00\xff\xff\xff\xff\x64\x00\x65\x00\xff\xff\xff\xff\x68\x00\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x53\x00\xff\xff\xff\xff\xff\xff\x57\x00\xff\xff\x59\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x60\x00\x61\x00\xff\xff\xff\xff\x64\x00\x65\x00\x16\x00\xff\xff\x68\x00\x69\x00\xff\xff\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x02\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x16\x00\x25\x00\x26\x00\x27\x00\xff\xff\x1b\x00\x2a\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x60\x00\x61\x00\xff\xff\xff\xff\x64\x00\x65\x00\xff\xff\xff\xff\x68\x00\x69\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\x55\x00\xff\xff\x57\x00\xff\xff\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x60\x00\x61\x00\xff\xff\xff\xff\x02\x00\x65\x00\xff\xff\xff\xff\xff\xff\x69\x00\xff\xff\xff\xff\x0a\x00\xff\xff\x60\x00\x61\x00\xff\xff\xff\xff\x64\x00\x65\x00\xff\xff\xff\xff\x68\x00\x69\x00\x16\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x02\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\xff\xff\xff\xff\x02\x00\xff\xff\x16\x00\xff\xff\xff\xff\x3a\x00\xff\xff\x1b\x00\x0a\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x24\x00\x25\x00\x26\x00\x27\x00\x16\x00\xff\xff\x2a\x00\xff\xff\xff\xff\x02\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x0a\x00\x57\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\x60\x00\xff\xff\x16\x00\xff\xff\x64\x00\xff\xff\xff\xff\x1b\x00\x68\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\x57\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\x57\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x60\x00\xff\xff\x62\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x57\x00\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x60\x00\xff\xff\x13\x00\x02\x00\x64\x00\x16\x00\xff\xff\x18\x00\x68\x00\xff\xff\x1b\x00\x0a\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x24\x00\x25\x00\x26\x00\x27\x00\x16\x00\xff\xff\x2a\x00\xff\xff\xff\xff\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x53\x00\xff\xff\xff\xff\xff\xff\x57\x00\xff\xff\x59\x00\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\x60\x00\x61\x00\xff\xff\x0a\x00\xff\xff\x53\x00\xff\xff\xff\xff\xff\xff\x57\x00\xff\xff\x59\x00\xff\xff\x02\x00\xff\xff\x16\x00\xff\xff\xff\xff\x60\x00\x61\x00\x1b\x00\x0a\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x24\x00\x25\x00\x26\x00\x27\x00\x16\x00\xff\xff\x2a\x00\xff\xff\xff\xff\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x02\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x24\x00\x25\x00\x26\x00\x27\x00\x02\x00\xff\xff\x2a\x00\xff\xff\xff\xff\x60\x00\x61\x00\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x57\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\x60\x00\xff\xff\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x02\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x57\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\x60\x00\xff\xff\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x24\x00\x25\x00\x26\x00\x27\x00\x02\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x57\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\x60\x00\xff\xff\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x02\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x57\x00\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\x16\x00\xff\xff\xff\xff\x60\x00\xff\xff\xff\xff\x0a\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x16\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x02\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x0a\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\x60\x00\xff\xff\x41\x00\x16\x00\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x0a\x00\xff\xff\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x57\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\xff\xff\x60\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x57\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x57\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x57\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x60\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# +happyCheck = HappyA# "\xff\xff\x69\x00\x01\x00\x02\x00\x03\x00\x02\x00\x03\x00\x06\x00\x11\x00\x3c\x00\x3d\x00\x00\x00\x09\x00\x00\x00\x0b\x00\x07\x00\x08\x00\x3c\x00\x3d\x00\x0a\x00\x42\x00\x4d\x00\x28\x00\x00\x00\x88\x00\x88\x00\x36\x00\x00\x00\x14\x00\x15\x00\x16\x00\x0c\x00\x61\x00\x68\x00\x69\x00\xcf\x00\x42\x00\x28\x00\x40\x00\x1f\x00\x42\x00\x21\x00\x22\x00\x23\x00\x24\x00\x07\x00\x08\x00\x27\x00\x1d\x00\x6f\x00\x2a\x00\x61\x00\x28\x00\x48\x00\x40\x00\x78\x00\x42\x00\x4d\x00\x14\x00\x15\x00\x16\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x1f\x00\x13\x00\x21\x00\x22\x00\x23\x00\x24\x00\xd7\x00\x44\x00\x27\x00\x56\x00\xdb\x00\x2a\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x67\x00\x6c\x00\x6d\x00\x6e\x00\x75\x00\x78\x00\x0d\x00\x0e\x00\x0f\x00\x10\x00\x79\x00\x55\x00\x00\x00\x55\x00\x5a\x00\x67\x00\xd5\x00\xd5\x00\x6f\x00\x47\x00\x48\x00\x44\x00\x13\x00\x55\x00\x60\x00\xd6\x00\x79\x00\x55\x00\x0f\x00\x10\x00\x67\x00\xdc\x00\x0f\x00\x10\x00\x60\x00\x70\x00\x71\x00\x72\x00\x60\x00\x00\x00\xd3\x00\x76\x00\x77\x00\x19\x00\x79\x00\x7a\x00\x50\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xd4\x00\xc3\x00\x0f\x00\x10\x00\xc6\x00\xd6\x00\x6c\x00\x6d\x00\x6e\x00\xc6\x00\xcc\x00\xdc\x00\x70\x00\x71\x00\x72\x00\xcc\x00\x3c\x00\xc6\x00\x76\x00\x77\x00\x51\x00\x79\x00\x7a\x00\xcc\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x50\x00\x42\x00\xb3\x00\x78\x00\xb5\x00\xb6\x00\x46\x00\xc3\x00\xc3\x00\xa9\x00\xc6\x00\xc6\x00\xac\x00\x6f\x00\x55\x00\xaf\x00\xcc\x00\xcc\x00\x3f\x00\xc4\x00\xc5\x00\xc6\x00\x60\x00\x3c\x00\xd6\x00\x60\x00\x51\x00\xcc\x00\xd6\x00\x78\x00\xdc\x00\x64\x00\x3f\x00\x40\x00\xdc\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xa9\x00\x78\x00\x60\x00\xac\x00\xd6\x00\xcc\x00\xaf\x00\xce\x00\xcf\x00\x70\x00\xdc\x00\xd2\x00\xda\x00\x61\x00\xda\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xd6\x00\x60\x00\xc3\x00\x6d\x00\x6e\x00\xc6\x00\xdc\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xcc\x00\x1c\x00\x1d\x00\x3f\x00\x40\x00\xcc\x00\x3c\x00\xce\x00\xcf\x00\x07\x00\x08\x00\xd2\x00\x3f\x00\xd6\x00\x28\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xdc\x00\x78\x00\x28\x00\x14\x00\x15\x00\x16\x00\xd6\x00\xd1\x00\xd8\x00\xd9\x00\xd6\x00\xd5\x00\xd8\x00\xd9\x00\x1f\x00\x51\x00\x21\x00\x22\x00\x23\x00\x24\x00\x07\x00\x08\x00\x27\x00\x60\x00\x3d\x00\x2a\x00\xd6\x00\x61\x00\xd8\x00\xd9\x00\x60\x00\x44\x00\x3d\x00\x14\x00\x15\x00\x16\x00\xd6\x00\x42\x00\xd8\x00\xd9\x00\xac\x00\x78\x00\x48\x00\xaf\x00\x1f\x00\xb1\x00\x21\x00\x22\x00\x23\x00\x24\x00\xd3\x00\x44\x00\x27\x00\x36\x00\x3d\x00\x2a\x00\xd6\x00\xbd\x00\xd8\x00\xd9\x00\xd6\x00\x44\x00\xd8\x00\xd9\x00\xc4\x00\xc5\x00\xc6\x00\xc7\x00\x61\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd6\x00\xac\x00\x1b\x00\x44\x00\xaf\x00\xd6\x00\xdc\x00\xd8\x00\xd9\x00\xd3\x00\x3e\x00\x3e\x00\xbf\x00\x51\x00\xc1\x00\x5c\x00\x5d\x00\x70\x00\x71\x00\x72\x00\x5f\x00\x60\x00\x61\x00\x76\x00\x77\x00\xcc\x00\x79\x00\x7a\x00\x60\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xce\x00\xcf\x00\x14\x00\x3e\x00\x5b\x00\x5b\x00\xad\x00\xae\x00\xaf\x00\x9a\x00\x61\x00\x61\x00\x70\x00\x71\x00\x72\x00\x66\x00\x66\x00\xd7\x00\x76\x00\x77\x00\x6a\x00\x79\x00\x7a\x00\x08\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x56\x00\x42\x00\x5b\x00\x44\x00\x5a\x00\x14\x00\x5c\x00\x16\x00\x61\x00\xa9\x00\xcf\x00\x51\x00\xac\x00\x66\x00\x64\x00\xaf\x00\x1f\x00\x6a\x00\x21\x00\x22\x00\x23\x00\x24\x00\xc3\x00\x3d\x00\x27\x00\xc6\x00\x60\x00\x2a\x00\x42\x00\xd7\x00\x3f\x00\xcc\x00\x0a\x00\x3e\x00\x3f\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xa9\x00\xb5\x00\xb6\x00\xac\x00\xd4\x00\xcc\x00\xaf\x00\xce\x00\xcf\x00\x05\x00\xbf\x00\xd2\x00\xc1\x00\xc1\x00\x44\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\x5b\x00\x61\x00\x57\x00\xd4\x00\xcc\x00\xcc\x00\x61\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xc6\x00\x61\x00\x77\x00\x5c\x00\x5d\x00\xcc\x00\xcc\x00\xce\x00\xcf\x00\x5c\x00\x5d\x00\xd2\x00\x81\x00\xd6\x00\x83\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xdc\x00\xb7\x00\xb8\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x5c\x00\x5d\x00\x70\x00\x71\x00\x72\x00\x12\x00\x13\x00\x14\x00\x76\x00\x77\x00\x08\x00\x79\x00\x7a\x00\x5a\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xd1\x00\xd7\x00\x14\x00\x64\x00\xd5\x00\xdb\x00\xa9\x00\x68\x00\xd3\x00\xac\x00\x61\x00\x6c\x00\xaf\x00\x1f\x00\x3f\x00\x21\x00\x22\x00\x23\x00\x24\x00\xb7\x00\xb8\x00\x27\x00\xd6\x00\x40\x00\x2a\x00\x42\x00\xaa\x00\xab\x00\xdc\x00\xad\x00\xc2\x00\xaf\x00\x5b\x00\xc4\x00\xc5\x00\xc6\x00\x5c\x00\x5d\x00\x61\x00\xa9\x00\x5b\x00\xcc\x00\xac\x00\xce\x00\xcf\x00\xaf\x00\x61\x00\xd2\x00\xd7\x00\xd5\x00\x44\x00\xc3\x00\xc3\x00\xd7\x00\xc6\x00\xc6\x00\xbf\x00\xdb\x00\xc1\x00\xd7\x00\xcc\x00\xcc\x00\xbf\x00\xcf\x00\xc1\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\xcc\x00\x15\x00\x16\x00\x49\x00\x4a\x00\xcc\x00\xcc\x00\xce\x00\xcf\x00\xd7\x00\xbf\x00\xd2\x00\xc1\x00\xdb\x00\x6a\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\x20\x00\x5a\x00\xc3\x00\x5b\x00\xcc\x00\xc6\x00\x70\x00\x71\x00\x72\x00\x61\x00\x64\x00\xcc\x00\x76\x00\x77\x00\x08\x00\x79\x00\x7a\x00\x6f\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xd7\x00\x6f\x00\x14\x00\x85\x00\xdb\x00\x5b\x00\x13\x00\x14\x00\x6f\x00\xaa\x00\xab\x00\x61\x00\xad\x00\x1f\x00\xaf\x00\x21\x00\x22\x00\x23\x00\x24\x00\xc5\x00\xc6\x00\x27\x00\x36\x00\xbf\x00\x2a\x00\xc1\x00\xcc\x00\xac\x00\xce\x00\xcf\x00\xaf\x00\x48\x00\x49\x00\x4a\x00\xc3\x00\x2d\x00\xcc\x00\xc6\x00\x4f\x00\xa9\x00\xa5\x00\xa6\x00\xac\x00\xcc\x00\x7b\x00\xaf\x00\xcf\x00\xc5\x00\xc6\x00\xc6\x00\x44\x00\xc4\x00\xc5\x00\xc6\x00\xcc\x00\xcc\x00\xce\x00\xcf\x00\xcf\x00\xcc\x00\x65\x00\xce\x00\xcf\x00\x65\x00\x66\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x15\x00\x16\x00\xc4\x00\xc5\x00\xc6\x00\xcc\x00\x19\x00\xce\x00\xcf\x00\x64\x00\xcc\x00\xd2\x00\x40\x00\x68\x00\x42\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xaa\x00\xab\x00\xd3\x00\xad\x00\x0c\x00\xaf\x00\x70\x00\x71\x00\x72\x00\xc4\x00\xc5\x00\xc6\x00\x76\x00\x77\x00\x49\x00\x79\x00\x7a\x00\xcc\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x14\x00\xc3\x00\x0c\x00\x85\x00\xc6\x00\xc9\x00\xca\x00\xcb\x00\xb0\x00\xcd\x00\xcc\x00\x1f\x00\x43\x00\xcf\x00\x22\x00\x23\x00\x24\x00\xb9\x00\xba\x00\x27\x00\x60\x00\x61\x00\x2a\x00\xad\x00\xae\x00\xaf\x00\x50\x00\xb5\x00\xb6\x00\xb3\x00\x54\x00\xb5\x00\xb6\x00\x14\x00\xca\x00\xcb\x00\x50\x00\xcd\x00\x42\x00\xa9\x00\x54\x00\xd1\x00\xac\x00\x42\x00\x1f\x00\xaf\x00\x3b\x00\xac\x00\x44\x00\x50\x00\xaf\x00\x26\x00\x27\x00\x54\x00\xc4\x00\xc5\x00\xc6\x00\xcf\x00\x40\x00\x41\x00\x2f\x00\x30\x00\xcc\x00\x62\x00\x63\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x34\x00\x35\x00\xc4\x00\xc5\x00\xc6\x00\xcc\x00\x38\x00\xce\x00\xcf\x00\x3e\x00\xcc\x00\xd2\x00\xce\x00\xcf\x00\x28\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\x48\x00\x49\x00\x4a\x00\x31\x00\x70\x00\x71\x00\x72\x00\x4f\x00\x64\x00\x1a\x00\x76\x00\x77\x00\x68\x00\x79\x00\x7a\x00\x28\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xbf\x00\x2e\x00\xc1\x00\xc2\x00\x62\x00\xd0\x00\xd1\x00\x65\x00\x66\x00\x6f\x00\xd5\x00\x69\x00\x6a\x00\xcc\x00\x64\x00\x70\x00\x71\x00\x72\x00\xc4\x00\xc5\x00\xc6\x00\x76\x00\x77\x00\x5e\x00\x79\x00\x7a\x00\xcc\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x14\x00\x80\x00\xc4\x00\xc5\x00\xc6\x00\x41\x00\xa9\x00\x62\x00\x63\x00\xac\x00\xcc\x00\x1f\x00\xaf\x00\x62\x00\x63\x00\xc4\x00\xc5\x00\xc6\x00\x26\x00\x27\x00\x32\x00\xaa\x00\xab\x00\xcc\x00\xad\x00\x50\x00\xaf\x00\x2f\x00\x30\x00\x54\x00\x50\x00\x18\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x50\x00\x57\x00\x42\x00\xa9\x00\x54\x00\xcc\x00\xac\x00\xce\x00\xcf\x00\xaf\x00\xc3\x00\xd2\x00\x46\x00\xc6\x00\x42\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xcc\x00\x50\x00\x50\x00\xcf\x00\x64\x00\x54\x00\x54\x00\x46\x00\x68\x00\x14\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x77\x00\xca\x00\xcb\x00\xb6\x00\xcd\x00\xcc\x00\x1f\x00\xce\x00\xcf\x00\x3e\x00\x3f\x00\xd2\x00\x04\x00\x26\x00\x27\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\x48\x00\x49\x00\x4a\x00\x2f\x00\x70\x00\x71\x00\x72\x00\x4f\x00\x64\x00\xd3\x00\x76\x00\x77\x00\x68\x00\x79\x00\x7a\x00\x4a\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xaa\x00\xab\x00\xa0\x00\xad\x00\x62\x00\xaf\x00\x14\x00\x65\x00\x66\x00\x5d\x00\x5d\x00\x69\x00\x6a\x00\x61\x00\x61\x00\xd3\x00\xb0\x00\x1f\x00\xb2\x00\xb3\x00\x5d\x00\xb5\x00\xb6\x00\x25\x00\x61\x00\xc3\x00\xa8\x00\xa9\x00\xc6\x00\x2b\x00\x2c\x00\xbf\x00\xd3\x00\xc1\x00\xcc\x00\xd3\x00\x5d\x00\xcf\x00\x93\x00\xa9\x00\x61\x00\xc2\x00\xac\x00\x16\x00\xcc\x00\xaf\x00\x70\x00\x71\x00\x72\x00\xd1\x00\x50\x00\xd4\x00\x76\x00\x77\x00\x54\x00\x79\x00\x7a\x00\x04\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x7b\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x50\x00\x82\x00\x14\x00\xd5\x00\x54\x00\xcc\x00\x50\x00\xce\x00\xcf\x00\x45\x00\x54\x00\xd2\x00\xd4\x00\x1f\x00\xd3\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\x25\x00\xc4\x00\xc5\x00\xc6\x00\x17\x00\xac\x00\x2b\x00\x2c\x00\xaf\x00\xcc\x00\x70\x00\x71\x00\x72\x00\x62\x00\x63\x00\xa9\x00\x76\x00\x77\x00\xac\x00\x79\x00\x7a\x00\xaf\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x50\x00\xc4\x00\xc5\x00\xc6\x00\x54\x00\x1e\x00\x50\x00\x14\x00\x84\x00\xcc\x00\x54\x00\xce\x00\xcf\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x44\x00\x1f\x00\xc4\x00\xc5\x00\xc6\x00\xcc\x00\x9e\x00\xce\x00\xcf\x00\x5d\x00\xcc\x00\xd2\x00\x9e\x00\x61\x00\x5b\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\x39\x00\x3a\x00\x33\x00\xa9\x00\x5b\x00\x78\x00\xac\x00\x7a\x00\x7b\x00\xaf\x00\x61\x00\x70\x00\x71\x00\x72\x00\x65\x00\x66\x00\x9e\x00\x76\x00\x77\x00\x6a\x00\x79\x00\x7a\x00\xd5\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x62\x00\x63\x00\x14\x00\x37\x00\x38\x00\xcc\x00\x5b\x00\xce\x00\xcf\x00\x34\x00\x35\x00\xd2\x00\x3e\x00\x1f\x00\x40\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\x73\x00\x74\x00\x75\x00\x48\x00\x49\x00\x4a\x00\x3f\x00\xa4\x00\xa5\x00\xa6\x00\x4f\x00\x70\x00\x71\x00\x72\x00\x33\x00\x79\x00\xa9\x00\x76\x00\x77\x00\xac\x00\x79\x00\x7a\x00\xaf\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x62\x00\x39\x00\x3a\x00\x65\x00\x66\x00\x51\x00\x14\x00\x69\x00\x6a\x00\x78\x00\xc4\x00\xc5\x00\xc6\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x1f\x00\xcc\x00\x73\x00\x74\x00\x75\x00\xcc\x00\x25\x00\xce\x00\xcf\x00\x39\x00\x3a\x00\xd2\x00\x2b\x00\x34\x00\x35\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\x64\x00\xa7\x00\xa8\x00\xa9\x00\x15\x00\x16\x00\xac\x00\x15\x00\x16\x00\xaf\x00\x70\x00\x71\x00\x72\x00\x25\x00\x26\x00\x27\x00\x76\x00\x77\x00\x5a\x00\x79\x00\x7a\x00\x5b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x07\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x3c\x00\x14\x00\x3f\x00\x40\x00\x5b\x00\xcc\x00\x60\x00\xce\x00\xcf\x00\x2b\x00\x2c\x00\xd2\x00\x1f\x00\x35\x00\x36\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\x48\x00\x49\x00\x4a\x00\x61\x00\xab\x00\x44\x00\xad\x00\x4f\x00\xaf\x00\x70\x00\x70\x00\x71\x00\x72\x00\xa7\x00\xa8\x00\xa9\x00\x76\x00\x77\x00\xac\x00\x79\x00\x7a\x00\xaf\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xc3\x00\x65\x00\x66\x00\xc6\x00\x51\x00\x69\x00\x6a\x00\x07\x00\x19\x00\xcc\x00\x3f\x00\x14\x00\xcf\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x65\x00\x66\x00\x79\x00\x47\x00\x4f\x00\xcc\x00\x79\x00\xce\x00\xcf\x00\x5b\x00\x51\x00\xd2\x00\x3f\x00\x50\x00\x42\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\x50\x00\x61\x00\x02\x00\xa9\x00\x60\x00\x40\x00\xac\x00\x5b\x00\x3f\x00\xaf\x00\x70\x00\x71\x00\x72\x00\x79\x00\x61\x00\x2c\x00\x76\x00\x77\x00\x3e\x00\x79\x00\x7a\x00\x19\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x42\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x5a\x00\x0c\x00\x14\x00\x09\x00\x5b\x00\xcc\x00\x70\x00\xce\x00\xcf\x00\x6f\x00\x3c\x00\xd2\x00\x4f\x00\x4f\x00\x3f\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\x1b\x00\xad\x00\xae\x00\xaf\x00\x07\x00\x62\x00\x62\x00\xb3\x00\x07\x00\xb5\x00\xb6\x00\x19\x00\x29\x00\x07\x00\x44\x00\xa9\x00\x78\x00\x4f\x00\xac\x00\x14\x00\x19\x00\xaf\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x61\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x40\x00\x61\x00\xcf\x00\x6f\x00\x86\x00\x87\x00\x3f\x00\x3f\x00\xc3\x00\xc4\x00\xc5\x00\xc6\x00\x47\x00\xb7\x00\xb8\x00\x3f\x00\x3c\x00\xcc\x00\x50\x00\xce\x00\xcf\x00\x53\x00\x54\x00\xd2\x00\x56\x00\x57\x00\x3f\x00\xd6\x00\xd7\x00\xd8\x00\xd9\x00\xc9\x00\xca\x00\xcb\x00\x3f\x00\xcd\x00\x61\x00\xb2\x00\xb3\x00\xa9\x00\xb5\x00\xb6\x00\xac\x00\x3c\x00\x57\x00\xaf\x00\x3c\x00\xb1\x00\x19\x00\x77\x00\xbf\x00\x3c\x00\xc1\x00\x3c\x00\x2b\x00\x60\x00\x48\x00\x77\x00\xbc\x00\x81\x00\xbe\x00\x40\x00\x51\x00\xcc\x00\x3f\x00\x60\x00\xc4\x00\xc5\x00\xc6\x00\x29\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\x14\x00\x79\x00\xd5\x00\x19\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x5b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x78\x00\x5b\x00\x5a\x00\xa9\x00\x86\x00\x87\x00\xac\x00\x79\x00\x44\x00\xaf\x00\x5b\x00\x5b\x00\x50\x00\x6d\x00\x44\x00\x53\x00\x54\x00\x3e\x00\x56\x00\x57\x00\xb2\x00\xb3\x00\x61\x00\xb5\x00\xb6\x00\x70\x00\x5a\x00\x48\x00\x49\x00\x4a\x00\xc4\x00\xc5\x00\xc6\x00\xbf\x00\x4f\x00\xc1\x00\x3c\x00\x3c\x00\xcc\x00\xa9\x00\xce\x00\xcf\x00\xac\x00\x5b\x00\xd2\x00\xaf\x00\xcc\x00\xb1\x00\x65\x00\x66\x00\x5b\x00\x77\x00\x6f\x00\x62\x00\x6f\x00\x1b\x00\x65\x00\x66\x00\xbc\x00\x3f\x00\xbe\x00\x57\x00\x70\x00\x3c\x00\x3c\x00\x40\x00\xc4\x00\xc5\x00\xc6\x00\x3f\x00\xc8\x00\xc9\x00\xca\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\x14\x00\x16\x00\xd5\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x49\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x3f\x00\x5b\x00\x19\x00\x3f\x00\x86\x00\x87\x00\x47\x00\x40\x00\x07\x00\x19\x00\x61\x00\xb0\x00\x3e\x00\x3f\x00\x42\x00\xb2\x00\xb3\x00\x47\x00\xb5\x00\xb6\x00\xb9\x00\xba\x00\x48\x00\x49\x00\x4a\x00\xad\x00\xae\x00\xaf\x00\xbf\x00\x4f\x00\xc1\x00\xb3\x00\x3c\x00\xb5\x00\xb6\x00\x20\x00\x19\x00\xca\x00\xcb\x00\xa9\x00\xcd\x00\xcc\x00\xac\x00\x0d\x00\xd1\x00\xaf\x00\x40\x00\xb1\x00\x62\x00\x3f\x00\x56\x00\x65\x00\x66\x00\x61\x00\x64\x00\x69\x00\x6a\x00\x40\x00\xbc\x00\xcf\x00\xbe\x00\x5b\x00\x3c\x00\x3f\x00\x3c\x00\x62\x00\xc4\x00\xc5\x00\xc6\x00\x29\x00\xc8\x00\xc9\x00\x51\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\x14\x00\x61\x00\xd5\x00\x60\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x3e\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x51\x00\xb1\x00\x40\x00\x17\x00\x86\x00\x40\x00\x61\x00\x53\x00\x51\x00\x8b\x00\x61\x00\xbb\x00\x50\x00\xbd\x00\x90\x00\x53\x00\x54\x00\x65\x00\x56\x00\x57\x00\x3f\x00\x62\x00\x0c\x00\xc7\x00\x60\x00\xc9\x00\xca\x00\xcb\x00\x62\x00\xcd\x00\x4f\x00\x49\x00\xd0\x00\xd1\x00\x51\x00\x57\x00\x48\x00\x49\x00\x4a\x00\xa9\x00\x5b\x00\x59\x00\xac\x00\x4f\x00\x61\x00\xaf\x00\x5b\x00\xb1\x00\x62\x00\x5d\x00\x5b\x00\x77\x00\x5b\x00\x5b\x00\x5b\x00\x15\x00\x60\x00\x5b\x00\xbc\x00\x0d\x00\xbe\x00\x44\x00\x3c\x00\x29\x00\x3c\x00\x65\x00\xc4\x00\xc5\x00\xc6\x00\x69\x00\xc8\x00\xc9\x00\x62\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\x14\x00\x70\x00\x61\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x57\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x59\x00\x61\x00\x44\x00\x5b\x00\x86\x00\x5b\x00\x5d\x00\x50\x00\x8a\x00\x8b\x00\x53\x00\x54\x00\x3e\x00\x56\x00\x57\x00\xb2\x00\xb3\x00\x5b\x00\xb5\x00\xb6\x00\x5b\x00\x5b\x00\x48\x00\x49\x00\x4a\x00\x80\x00\x5b\x00\x80\x00\xbf\x00\x4f\x00\xc1\x00\x80\x00\x59\x00\xca\x00\xcb\x00\x57\x00\xcd\x00\x30\x00\x56\x00\xa9\x00\xd1\x00\xcc\x00\xac\x00\x6f\x00\xd5\x00\xaf\x00\x77\x00\xb1\x00\x62\x00\x11\x00\x5a\x00\x65\x00\x66\x00\x24\x00\x61\x00\x69\x00\x6a\x00\x60\x00\xbc\x00\x61\x00\xbe\x00\x70\x00\x51\x00\x60\x00\x13\x00\x86\x00\xc4\x00\xc5\x00\xc6\x00\x6f\x00\xc8\x00\xc9\x00\x45\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\x14\x00\x6f\x00\x6f\x00\x6f\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x86\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x43\x00\x43\x00\x50\x00\x57\x00\x86\x00\x52\x00\x86\x00\x89\x00\x3c\x00\xb2\x00\xb3\x00\x50\x00\xb5\x00\xb6\x00\x3f\x00\x47\x00\x86\x00\x0c\x00\x57\x00\x00\x00\x0c\x00\x13\x00\xbf\x00\xff\xff\xc1\x00\x4b\x00\xff\xff\xff\xff\x4e\x00\xff\xff\x50\x00\x51\x00\xff\xff\x53\x00\x54\x00\xcc\x00\x56\x00\x57\x00\xff\xff\xa9\x00\xff\xff\xff\xff\xac\x00\xff\xff\xff\xff\xaf\x00\xff\xff\xb1\x00\xff\xff\xff\xff\x77\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbc\x00\xff\xff\xbe\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\x77\x00\xc8\x00\xc9\x00\xff\xff\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\x14\x00\xff\xff\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\x86\x00\x50\x00\xff\xff\x89\x00\xff\xff\xff\xff\xff\xff\xff\xff\x57\x00\xff\xff\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xff\xff\xff\xff\xff\xff\xa9\x00\xff\xff\xff\xff\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xff\xff\xff\xff\xb2\x00\xb3\x00\xff\xff\xb5\x00\xb6\x00\xff\xff\xa9\x00\xcc\x00\xff\xff\xac\x00\xff\xff\x77\x00\xaf\x00\xbf\x00\xb1\x00\xc1\x00\xff\xff\xff\xff\xd7\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbc\x00\xcc\x00\xbe\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\xff\xff\xc8\x00\xc9\x00\xff\xff\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\x14\x00\xff\xff\xff\xff\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\x86\x00\xff\xff\xff\xff\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xb1\x00\x50\x00\x51\x00\xff\xff\x53\x00\x54\x00\xff\xff\x56\x00\x57\x00\xcc\x00\xbb\x00\xff\xff\xbd\x00\xff\xff\xff\xff\xa9\x00\xff\xff\xff\xff\xac\x00\xff\xff\xd7\x00\xaf\x00\xc7\x00\xb1\x00\xc9\x00\xca\x00\xcb\x00\xff\xff\xcd\x00\xff\xff\xff\xff\xd0\x00\xd1\x00\xff\xff\xbc\x00\xff\xff\xbe\x00\xff\xff\xff\xff\xff\xff\x77\x00\xff\xff\xc4\x00\xc5\x00\xc6\x00\xff\xff\xc8\x00\xc9\x00\xff\xff\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\x14\x00\xff\xff\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\x86\x00\xff\xff\xff\xff\x50\x00\x51\x00\xff\xff\x53\x00\x54\x00\xff\xff\x56\x00\x57\x00\xff\xff\xff\xff\xff\xff\x5b\x00\xa9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb2\x00\xb3\x00\xff\xff\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xa9\x00\xff\xff\xbf\x00\xac\x00\xc1\x00\xc2\x00\xaf\x00\x77\x00\xb1\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xff\xff\xcd\x00\xcc\x00\xff\xff\xd0\x00\xd1\x00\xbc\x00\xff\xff\xbe\x00\xd5\x00\xff\xff\xd5\x00\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\xff\xff\xc8\x00\xc9\x00\x3e\x00\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\x14\x00\x48\x00\x49\x00\x4a\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x4f\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xa9\x00\xff\xff\xff\xff\xff\xff\x86\x00\x5b\x00\xff\xff\x50\x00\xff\xff\xb2\x00\xb3\x00\x61\x00\xb5\x00\xb6\x00\x57\x00\x65\x00\x66\x00\xff\xff\xff\xff\xff\xff\x4b\x00\x4c\x00\xbf\x00\xff\xff\xc1\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\xff\xff\x56\x00\xcc\x00\xff\xff\x56\x00\x5a\x00\xa9\x00\x5c\x00\x5a\x00\xac\x00\x5c\x00\xd5\x00\xaf\x00\x77\x00\xb1\x00\x64\x00\xff\xff\xff\xff\x64\x00\x68\x00\xff\xff\xff\xff\x68\x00\x6c\x00\xff\xff\xbc\x00\x6c\x00\xbe\x00\xff\xff\xff\xff\xff\xff\x77\x00\xff\xff\xc4\x00\xc5\x00\xc6\x00\xff\xff\xc8\x00\xc9\x00\xff\xff\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\x14\x00\xff\xff\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xff\xff\x50\x00\xff\xff\xff\xff\x86\x00\x54\x00\xff\xff\x56\x00\x57\x00\xff\xff\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xff\xff\xff\xff\xa9\x00\xff\xff\xff\xff\xff\xff\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xff\xff\xb2\x00\xb3\x00\xff\xff\xb5\x00\xb6\x00\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xa9\x00\x77\x00\xbf\x00\xac\x00\xc1\x00\xff\xff\xaf\x00\x14\x00\xb1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xbc\x00\xff\xff\xbe\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\xff\xff\xc8\x00\xc9\x00\xff\xff\xcb\x00\xcc\x00\xcd\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\xd2\x00\xff\xff\xff\xff\xff\xff\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xb2\x00\xb3\x00\xff\xff\xb5\x00\xb6\x00\x14\x00\xff\xff\x8c\x00\x8d\x00\x8e\x00\x8f\x00\xff\xff\xff\xff\xbf\x00\xff\xff\xc1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9b\x00\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xa3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa9\x00\xff\xff\xff\xff\xac\x00\xff\xff\xff\xff\xaf\x00\xff\xff\x14\x00\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x14\x00\xc4\x00\xc5\x00\xc6\x00\xff\xff\x8c\x00\x8d\x00\x8e\x00\x8f\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xd2\x00\xff\xff\xff\xff\xff\xff\xff\xff\x9b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa9\x00\xff\xff\xff\xff\xac\x00\xff\xff\xff\xff\xaf\x00\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\x8d\x00\x8e\x00\x8f\x00\xff\xff\xff\xff\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xd2\x00\xff\xff\xff\xff\x9b\x00\xff\xff\xff\xff\x77\x00\xff\xff\xff\xff\xff\xff\xff\xff\xa3\x00\xff\xff\x7e\x00\x7f\x00\x80\x00\x81\x00\xa9\x00\x14\x00\xff\xff\xac\x00\xff\xff\xff\xff\xaf\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xff\xff\x14\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\xff\xff\xff\xff\xff\xff\x91\x00\x92\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xa9\x00\xff\xff\xd2\x00\xac\x00\x9b\x00\xff\xff\xaf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa9\x00\xff\xff\xff\xff\xac\x00\xff\xff\xff\xff\xaf\x00\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xd2\x00\xff\xff\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xd2\x00\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x14\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\x94\x00\x95\x00\x96\x00\xff\xff\xff\xff\x50\x00\x51\x00\x9b\x00\x53\x00\x54\x00\xff\xff\x56\x00\x57\x00\xff\xff\xff\xff\x5a\x00\x5b\x00\xff\xff\x94\x00\x95\x00\x96\x00\xa9\x00\xff\xff\xff\xff\xac\x00\x9b\x00\xff\xff\xaf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa9\x00\x14\x00\xff\xff\xac\x00\xff\xff\x77\x00\xaf\x00\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xcc\x00\xff\xff\xce\x00\xcf\x00\x56\x00\x57\x00\xd2\x00\xff\xff\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xd2\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xff\xff\x77\x00\xa9\x00\xff\xff\xff\xff\x14\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb2\x00\xb3\x00\xff\xff\xb5\x00\xb6\x00\xff\xff\xff\xff\x94\x00\x95\x00\x96\x00\xff\xff\xff\xff\xff\xff\xbf\x00\x9b\x00\xc1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xa9\x00\xff\xff\xff\xff\xac\x00\xff\xff\xff\xff\xaf\x00\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xff\xff\xff\xff\xb2\x00\xb3\x00\x14\x00\xb5\x00\xb6\x00\xff\xff\xc4\x00\xc5\x00\xc6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xbf\x00\xcc\x00\xc1\x00\xce\x00\xcf\x00\xff\xff\xff\xff\xd2\x00\xff\xff\xff\xff\x9b\x00\xff\xff\xff\xff\xcc\x00\x9f\x00\xff\xff\xff\xff\xa2\x00\xa3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa9\x00\xff\xff\xff\xff\xac\x00\xff\xff\xff\xff\xaf\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\x14\x00\xff\xff\xff\xff\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\xb1\x00\xff\xff\xff\xff\x91\x00\x92\x00\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xbb\x00\xd2\x00\xbd\x00\x9b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa3\x00\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xa9\x00\xcd\x00\xff\xff\xac\x00\xd0\x00\xd1\x00\xaf\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\x14\x00\xff\xff\xff\xff\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\xb1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xbb\x00\xd2\x00\xbd\x00\x9b\x00\xff\xff\xff\xff\xff\xff\x9f\x00\xff\xff\xff\xff\xa2\x00\xa3\x00\xc7\x00\xff\xff\xc9\x00\xca\x00\xcb\x00\xa9\x00\xcd\x00\xff\xff\xac\x00\xd0\x00\xd1\x00\xaf\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\x14\x00\xff\xff\xff\xff\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xd2\x00\xff\xff\x9b\x00\xff\xff\xff\xff\xff\xff\x9f\x00\xff\xff\xff\xff\xa2\x00\xa3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa9\x00\xff\xff\xff\xff\xac\x00\xff\xff\xff\xff\xaf\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\x14\x00\xff\xff\xff\xff\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xd2\x00\xff\xff\x9b\x00\xff\xff\xff\xff\xff\xff\x9f\x00\xff\xff\xff\xff\xa2\x00\xa3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa9\x00\xff\xff\xff\xff\xac\x00\xff\xff\xff\xff\xaf\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x14\x00\xff\xff\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xd2\x00\xff\xff\x9b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa1\x00\xa2\x00\xa3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa9\x00\xff\xff\xff\xff\xac\x00\xff\xff\x14\x00\xaf\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x14\x00\xff\xff\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\xff\xff\x8f\x00\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xd2\x00\xff\xff\x9b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa3\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa9\x00\xff\xff\xff\xff\xac\x00\xff\xff\x14\x00\xaf\x00\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xce\x00\xcf\x00\x96\x00\xff\xff\xd2\x00\xff\xff\xff\xff\x9b\x00\xff\xff\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xa9\x00\xff\xff\xff\xff\xac\x00\x14\x00\xff\xff\xaf\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9b\x00\x57\x00\xc4\x00\xc5\x00\xc6\x00\xff\xff\xff\xff\xff\xff\xa3\x00\xff\xff\xcc\x00\xff\xff\xce\x00\xcf\x00\xa9\x00\x14\x00\xd2\x00\xac\x00\xff\xff\xff\xff\xaf\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xa9\x00\x77\x00\xff\xff\xac\x00\xff\xff\xff\xff\xaf\x00\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\xff\xff\x14\x00\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xd2\x00\xff\xff\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xce\x00\xcf\x00\xa9\x00\xff\xff\xd2\x00\xac\x00\x14\x00\xff\xff\xaf\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xb2\x00\xb3\x00\xff\xff\xb5\x00\xb6\x00\xff\xff\xc4\x00\xc5\x00\xc6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xbf\x00\xcc\x00\xc1\x00\xce\x00\xcf\x00\xff\xff\x14\x00\xd2\x00\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\xcc\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xa9\x00\xff\xff\xff\xff\xac\x00\xff\xff\xff\xff\xaf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x14\x00\xff\xff\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xc4\x00\xc5\x00\xc6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xa9\x00\xce\x00\xcf\x00\xac\x00\xff\xff\xd2\x00\xaf\x00\x14\x00\xff\xff\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\xa9\x00\xff\xff\xff\xff\xac\x00\xff\xff\xcc\x00\xaf\x00\xce\x00\xcf\x00\xff\xff\x14\x00\xd2\x00\xff\xff\xff\xff\xff\xff\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xc4\x00\xc5\x00\xc6\x00\xa9\x00\xff\xff\xff\xff\xac\x00\xff\xff\xcc\x00\xaf\x00\xce\x00\xcf\x00\xff\xff\x14\x00\xd2\x00\xff\xff\xff\xff\xff\xff\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xc4\x00\xc5\x00\xc6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xa9\x00\xce\x00\xcf\x00\xac\x00\x14\x00\xd2\x00\xaf\x00\xff\xff\xff\xff\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\xa9\x00\xff\xff\xff\xff\xac\x00\xff\xff\xcc\x00\xaf\x00\xce\x00\xcf\x00\xff\xff\x14\x00\xd2\x00\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\xa9\x00\xff\xff\xff\xff\xac\x00\xff\xff\xcc\x00\xaf\x00\xce\x00\xcf\x00\xff\xff\x14\x00\xd2\x00\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\xff\xff\xff\xff\xff\xff\xa9\x00\xff\xff\xcc\x00\xac\x00\xce\x00\xcf\x00\xaf\x00\x14\x00\xd2\x00\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\xa9\x00\xff\xff\xff\xff\xac\x00\xff\xff\xcc\x00\xaf\x00\xce\x00\xcf\x00\xff\xff\x14\x00\xd2\x00\xff\xff\xff\xff\xff\xff\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xc4\x00\xc5\x00\xc6\x00\xa9\x00\xff\xff\xff\xff\xac\x00\xff\xff\xcc\x00\xaf\x00\xce\x00\xcf\x00\xff\xff\x14\x00\xd2\x00\xff\xff\xff\xff\xff\xff\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xc4\x00\xc5\x00\xc6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xa9\x00\xce\x00\xcf\x00\xac\x00\x14\x00\xd2\x00\xaf\x00\xff\xff\xff\xff\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\xa9\x00\xff\xff\xff\xff\xac\x00\xff\xff\xcc\x00\xaf\x00\xce\x00\xcf\x00\xff\xff\x14\x00\xd2\x00\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\xa9\x00\xff\xff\xff\xff\xac\x00\xff\xff\xcc\x00\xaf\x00\xce\x00\xcf\x00\xff\xff\x14\x00\xd2\x00\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\xff\xff\xff\xff\xff\xff\xa9\x00\xff\xff\xcc\x00\xac\x00\xce\x00\xcf\x00\xaf\x00\x14\x00\xd2\x00\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\xa9\x00\xff\xff\xff\xff\xac\x00\xff\xff\xcc\x00\xaf\x00\xce\x00\xcf\x00\xff\xff\x14\x00\xd2\x00\xff\xff\xff\xff\xff\xff\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xc4\x00\xc5\x00\xc6\x00\xa9\x00\xff\xff\xff\xff\xac\x00\xff\xff\xcc\x00\xaf\x00\xce\x00\xcf\x00\xff\xff\x14\x00\xd2\x00\xff\xff\xff\xff\xff\xff\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xc4\x00\xc5\x00\xc6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xa9\x00\xce\x00\xcf\x00\xac\x00\x14\x00\xd2\x00\xaf\x00\xff\xff\xff\xff\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\xa9\x00\xff\xff\xff\xff\xac\x00\xff\xff\xcc\x00\xaf\x00\xce\x00\xcf\x00\xff\xff\x14\x00\xd2\x00\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\xa9\x00\xff\xff\xff\xff\xac\x00\xff\xff\xcc\x00\xaf\x00\xce\x00\xcf\x00\xff\xff\x14\x00\xd2\x00\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\xff\xff\xff\xff\xff\xff\xa9\x00\xff\xff\xcc\x00\xac\x00\xce\x00\xcf\x00\xaf\x00\x14\x00\xd2\x00\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\xa9\x00\xff\xff\xff\xff\xac\x00\xff\xff\xcc\x00\xaf\x00\xce\x00\xcf\x00\xff\xff\x14\x00\xd2\x00\xff\xff\xff\xff\xff\xff\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xc4\x00\xc5\x00\xc6\x00\xa9\x00\xff\xff\xff\xff\xac\x00\xff\xff\xcc\x00\xaf\x00\xce\x00\xcf\x00\xff\xff\x14\x00\xd2\x00\xff\xff\xff\xff\xff\xff\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xc4\x00\xc5\x00\xc6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xa9\x00\xce\x00\xcf\x00\xac\x00\x14\x00\xd2\x00\xaf\x00\xff\xff\xff\xff\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\xa9\x00\xff\xff\xff\xff\xac\x00\xff\xff\xcc\x00\xaf\x00\xce\x00\xcf\x00\xff\xff\x14\x00\xd2\x00\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\xa9\x00\xff\xff\xff\xff\xac\x00\xff\xff\xcc\x00\xaf\x00\xce\x00\xcf\x00\xff\xff\x14\x00\xd2\x00\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\xff\xff\xff\xff\xff\xff\xa9\x00\xff\xff\xcc\x00\xac\x00\xce\x00\xcf\x00\xaf\x00\x14\x00\xd2\x00\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\xa9\x00\xff\xff\xff\xff\xac\x00\xff\xff\xcc\x00\xaf\x00\xce\x00\xcf\x00\xff\xff\x14\x00\xd2\x00\xff\xff\xff\xff\xff\xff\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xc4\x00\xc5\x00\xc6\x00\xa9\x00\xff\xff\xff\xff\xac\x00\xff\xff\xcc\x00\xaf\x00\xce\x00\xcf\x00\xff\xff\x14\x00\xd2\x00\xff\xff\xff\xff\xff\xff\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xc4\x00\xc5\x00\xc6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xa9\x00\xce\x00\xcf\x00\xac\x00\x14\x00\xd2\x00\xaf\x00\xff\xff\xff\xff\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\xa9\x00\xff\xff\xff\xff\xac\x00\x14\x00\xcc\x00\xaf\x00\xce\x00\xcf\x00\xff\xff\xff\xff\xd2\x00\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\xa9\x00\xff\xff\xff\xff\xac\x00\x14\x00\xcc\x00\xaf\x00\xce\x00\xcf\x00\xff\xff\xff\xff\xd2\x00\xff\xff\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\xff\xff\xff\xff\xff\xff\xa9\x00\x14\x00\xcc\x00\xac\x00\xce\x00\xcf\x00\xaf\x00\xff\xff\xd2\x00\xff\xff\x77\x00\xff\xff\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\xa9\x00\x14\x00\xff\xff\xac\x00\xff\xff\xcc\x00\xaf\x00\xce\x00\xcf\x00\xff\xff\x77\x00\xd2\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\xa9\x00\x14\x00\xff\xff\xac\x00\xff\xff\xcc\x00\xaf\x00\xce\x00\xcf\x00\xff\xff\x77\x00\xd2\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\xa9\x00\xff\xff\xff\xff\xac\x00\x14\x00\xcc\x00\xaf\x00\xce\x00\xcf\x00\xff\xff\x77\x00\xd2\x00\x79\x00\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\xa9\x00\xff\xff\xff\xff\xac\x00\xff\xff\xcc\x00\xaf\x00\xce\x00\xcf\x00\xff\xff\x77\x00\xd2\x00\xff\xff\x7a\x00\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\xa9\x00\x14\x00\xff\xff\xac\x00\xff\xff\xcc\x00\xaf\x00\xce\x00\xcf\x00\xff\xff\x77\x00\xd2\x00\xff\xff\xff\xff\xff\xff\xff\xff\x14\x00\xff\xff\x7f\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\xa9\x00\xff\xff\xff\xff\xac\x00\x14\x00\xcc\x00\xaf\x00\xce\x00\xcf\x00\xff\xff\xff\xff\xd2\x00\xff\xff\x77\x00\xff\xff\xff\xff\xff\xff\x9c\x00\x9d\x00\xff\xff\xff\xff\x7f\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\xa9\x00\xff\xff\xff\xff\xac\x00\xff\xff\xcc\x00\xaf\x00\xce\x00\xcf\x00\xff\xff\xff\xff\xd2\x00\xff\xff\x14\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x9c\x00\x9d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\xff\xff\xff\xff\xff\xff\xa9\x00\xff\xff\xcc\x00\xac\x00\xce\x00\xcf\x00\xaf\x00\x77\x00\xd2\x00\xff\xff\xff\xff\xff\xff\xff\xff\x14\x00\xff\xff\x7f\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\x77\x00\xff\xff\xff\xff\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\x7f\x00\x80\x00\x81\x00\xff\xff\xff\xff\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\x77\x00\xd2\x00\xff\xff\x14\x00\x9c\x00\xff\xff\xff\xff\xff\xff\x7f\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa9\x00\xff\xff\xff\xff\xac\x00\xff\xff\xff\xff\xaf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa9\x00\x14\x00\xff\xff\xac\x00\xff\xff\xff\xff\xaf\x00\x77\x00\xff\xff\xff\xff\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\x7f\x00\x80\x00\x81\x00\xa9\x00\xff\xff\xcc\x00\xac\x00\xce\x00\xcf\x00\xaf\x00\xff\xff\xd2\x00\xc4\x00\xc5\x00\xc6\x00\xff\xff\x14\x00\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\x77\x00\xd2\x00\xff\xff\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\x7f\x00\x80\x00\x81\x00\xff\xff\xff\xff\xcc\x00\xff\xff\xce\x00\xcf\x00\xa9\x00\xff\xff\xd2\x00\xac\x00\x14\x00\xff\xff\xaf\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x77\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7f\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\xff\xff\xff\xff\xff\xff\xa9\x00\x14\x00\xcc\x00\xac\x00\xce\x00\xcf\x00\xaf\x00\xff\xff\xd2\x00\xff\xff\x77\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7f\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\xa9\x00\x14\x00\xff\xff\xac\x00\xff\xff\xcc\x00\xaf\x00\xce\x00\xcf\x00\xff\xff\x77\x00\xd2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7f\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\xa9\x00\x14\x00\xff\xff\xac\x00\xff\xff\xcc\x00\xaf\x00\xce\x00\xcf\x00\xff\xff\x77\x00\xd2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7f\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\xa9\x00\xff\xff\xff\xff\xac\x00\xff\xff\xcc\x00\xaf\x00\xce\x00\xcf\x00\xff\xff\x77\x00\xd2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7f\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\xa9\x00\xff\xff\xff\xff\xac\x00\xff\xff\xcc\x00\xaf\x00\xce\x00\xcf\x00\xff\xff\x77\x00\xd2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7f\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\xa9\x00\xff\xff\xff\xff\xac\x00\xff\xff\xcc\x00\xaf\x00\xce\x00\xcf\x00\xff\xff\x77\x00\xd2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x7f\x00\x80\x00\x81\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\xa9\x00\xff\xff\xff\xff\xac\x00\xff\xff\xcc\x00\xaf\x00\xce\x00\xcf\x00\xff\xff\xff\xff\xd2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\xa9\x00\xff\xff\xff\xff\xac\x00\xff\xff\xcc\x00\xaf\x00\xce\x00\xcf\x00\xff\xff\xff\xff\xd2\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xc4\x00\xc5\x00\xc6\x00\x57\x00\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xce\x00\xcf\x00\xff\xff\xff\xff\xd2\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\xff\xff\x0a\x00\x0b\x00\x0c\x00\xff\xff\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\xff\xff\x14\x00\x77\x00\x16\x00\xff\xff\x18\x00\xff\xff\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\x38\x00\x39\x00\x3a\x00\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\x46\x00\xff\xff\x48\x00\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb2\x00\xb3\x00\xff\xff\xb5\x00\xb6\x00\xff\xff\x56\x00\xff\xff\x58\x00\xff\xff\x5a\x00\xff\xff\x5c\x00\xbf\x00\x5e\x00\xc1\x00\xff\xff\xff\xff\xff\xff\x63\x00\x64\x00\xff\xff\xff\xff\x67\x00\x68\x00\xff\xff\xcc\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xff\xff\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x01\x00\x02\x00\x03\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\x0e\x00\x0f\x00\x10\x00\x11\x00\x12\x00\xff\xff\x14\x00\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\x1a\x00\x1b\x00\x1c\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\xff\xff\x38\x00\x39\x00\x3a\x00\x3b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\x46\x00\xff\xff\x48\x00\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x50\x00\x5a\x00\xff\xff\x5c\x00\x54\x00\x5e\x00\x56\x00\x57\x00\xff\xff\xff\xff\x63\x00\x64\x00\xff\xff\xff\xff\x67\x00\x68\x00\xff\xff\xff\xff\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x77\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\x06\x00\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\x0e\x00\x0f\x00\x10\x00\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\x1a\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\xff\xff\xb2\x00\xb3\x00\xff\xff\xb5\x00\xb6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\xff\xff\xbf\x00\xff\xff\xc1\x00\x46\x00\xff\xff\x48\x00\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x50\x00\x5a\x00\xff\xff\x5c\x00\x54\x00\x5e\x00\x56\x00\x57\x00\xff\xff\xff\xff\x63\x00\x64\x00\xff\xff\xff\xff\x67\x00\x68\x00\xff\xff\xff\xff\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x77\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\x0e\x00\x0f\x00\x10\x00\xff\xff\x12\x00\xff\xff\x14\x00\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\x1a\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\xff\xff\xb2\x00\xb3\x00\xff\xff\xb5\x00\xb6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\xff\xff\xbf\x00\xff\xff\xc1\x00\x46\x00\xff\xff\x48\x00\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x50\x00\x5a\x00\xff\xff\x5c\x00\x54\x00\x5e\x00\x56\x00\x57\x00\xff\xff\xff\xff\x63\x00\x64\x00\xff\xff\xff\xff\x67\x00\x68\x00\xff\xff\xff\xff\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x77\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\x06\x00\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\x0e\x00\x0f\x00\x10\x00\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\x1a\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\xff\xff\xb2\x00\xb3\x00\xff\xff\xb5\x00\xb6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\xff\xff\xbf\x00\xff\xff\xc1\x00\x46\x00\xff\xff\x48\x00\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x50\x00\x5a\x00\xff\xff\x5c\x00\x54\x00\x5e\x00\x56\x00\x57\x00\xff\xff\xff\xff\x63\x00\x64\x00\xff\xff\xff\xff\x67\x00\x68\x00\xff\xff\xff\xff\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x77\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x01\x00\x02\x00\x03\x00\xff\xff\x05\x00\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\x0e\x00\x0f\x00\x10\x00\xff\xff\x12\x00\xff\xff\x14\x00\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\x1a\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\xff\xff\xb2\x00\xb3\x00\xff\xff\xb5\x00\xb6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\xff\xff\xbf\x00\xff\xff\xc1\x00\x46\x00\xff\xff\x48\x00\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x50\x00\x5a\x00\xff\xff\x5c\x00\x54\x00\x5e\x00\x56\x00\x57\x00\xff\xff\xff\xff\x63\x00\x64\x00\xff\xff\xff\xff\x67\x00\x68\x00\xff\xff\xff\xff\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x77\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\x0e\x00\x0f\x00\x10\x00\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\x2d\x00\x2e\x00\x2f\x00\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\xff\xff\xb2\x00\xb3\x00\xff\xff\xb5\x00\xb6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\xff\xff\xbf\x00\xff\xff\xc1\x00\x46\x00\xff\xff\x48\x00\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x50\x00\x5a\x00\xff\xff\x5c\x00\x54\x00\x5e\x00\x56\x00\x57\x00\xff\xff\xff\xff\x63\x00\x64\x00\xff\xff\xff\xff\x67\x00\x68\x00\xff\xff\xff\xff\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x77\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\xff\xff\xb2\x00\xb3\x00\xff\xff\xb5\x00\xb6\x00\xff\xff\xff\xff\xff\xff\x3e\x00\xff\xff\xff\xff\x41\x00\xff\xff\xbf\x00\xff\xff\xc1\x00\x46\x00\xff\xff\x48\x00\x49\x00\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x50\x00\x5a\x00\x5b\x00\x5c\x00\x54\x00\x5e\x00\x56\x00\x57\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x77\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\xff\xff\xb2\x00\xb3\x00\xff\xff\xb5\x00\xb6\x00\xff\xff\xff\xff\xff\xff\x3e\x00\xff\xff\xff\xff\x41\x00\xff\xff\xbf\x00\xff\xff\xc1\x00\x46\x00\xff\xff\x48\x00\x49\x00\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x50\x00\x5a\x00\xff\xff\x5c\x00\x5d\x00\x5e\x00\x56\x00\x57\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x77\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\xff\xff\xb2\x00\xb3\x00\xff\xff\xb5\x00\xb6\x00\xff\xff\xff\xff\xff\xff\x3e\x00\xff\xff\xff\xff\x41\x00\xff\xff\xbf\x00\xff\xff\xc1\x00\x46\x00\xff\xff\x48\x00\x49\x00\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x50\x00\x5a\x00\x5b\x00\x5c\x00\x54\x00\x5e\x00\x56\x00\x57\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x77\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\xff\xff\xb2\x00\xb3\x00\xff\xff\xb5\x00\xb6\x00\xff\xff\xff\xff\xff\xff\x3e\x00\xff\xff\xff\xff\x41\x00\xff\xff\xbf\x00\xff\xff\xc1\x00\x46\x00\xff\xff\x48\x00\x49\x00\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x50\x00\x5a\x00\xff\xff\x5c\x00\x5d\x00\x5e\x00\x56\x00\x57\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x77\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\xff\xff\xb2\x00\xb3\x00\xff\xff\xb5\x00\xb6\x00\xff\xff\xff\xff\xff\xff\x3e\x00\xff\xff\xff\xff\x41\x00\xff\xff\xbf\x00\xff\xff\xc1\x00\x46\x00\xff\xff\x48\x00\x49\x00\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x50\x00\x5a\x00\x5b\x00\x5c\x00\x54\x00\x5e\x00\x56\x00\x57\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x77\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\xff\xff\xb2\x00\xb3\x00\xff\xff\xb5\x00\xb6\x00\xff\xff\xff\xff\xff\xff\x3e\x00\xff\xff\xff\xff\x41\x00\xff\xff\xbf\x00\xff\xff\xc1\x00\x46\x00\xff\xff\x48\x00\x49\x00\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x50\x00\x5a\x00\xff\xff\x5c\x00\x54\x00\x5e\x00\x56\x00\x57\x00\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x77\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\xff\xff\xb2\x00\xb3\x00\xff\xff\xb5\x00\xb6\x00\xff\xff\xff\xff\xff\xff\x3e\x00\xff\xff\xff\xff\x41\x00\xff\xff\xbf\x00\xff\xff\xc1\x00\x46\x00\xff\xff\x48\x00\x49\x00\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x58\x00\x50\x00\x5a\x00\xff\xff\x5c\x00\x54\x00\x5e\x00\x56\x00\x57\x00\xff\xff\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x77\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\xff\xff\xb2\x00\xb3\x00\xff\xff\xb5\x00\xb6\x00\xff\xff\xff\xff\xff\xff\x3e\x00\xff\xff\xff\xff\x41\x00\xff\xff\xbf\x00\xff\xff\xc1\x00\x46\x00\xff\xff\x48\x00\x49\x00\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x50\x00\x5a\x00\xff\xff\x5c\x00\x54\x00\x5e\x00\x56\x00\x57\x00\xff\xff\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x77\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\xff\xff\xb2\x00\xb3\x00\xff\xff\xb5\x00\xb6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\xff\xff\xbf\x00\xff\xff\xc1\x00\x46\x00\xff\xff\x48\x00\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\xff\xff\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\x63\x00\x64\x00\xff\xff\xff\xff\x67\x00\x68\x00\xff\xff\xff\xff\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xff\xff\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\xff\xff\x1a\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\x46\x00\xff\xff\x48\x00\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x50\x00\x5a\x00\xff\xff\x5c\x00\x54\x00\x5e\x00\x56\x00\x57\x00\xff\xff\xff\xff\x63\x00\x64\x00\xff\xff\xff\xff\x67\x00\x68\x00\xff\xff\xff\xff\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x77\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\xff\xff\xb2\x00\xb3\x00\xff\xff\xb5\x00\xb6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\xff\xff\xbf\x00\xff\xff\xc1\x00\x46\x00\xff\xff\x48\x00\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\xff\xff\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\x60\x00\xff\xff\xff\xff\x63\x00\x64\x00\xff\xff\xff\xff\x67\x00\x68\x00\xff\xff\xff\xff\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xff\xff\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\x17\x00\xff\xff\xff\xff\x1a\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\xff\xff\xff\xff\xff\xff\xff\xff\x46\x00\xff\xff\x48\x00\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x50\x00\x5a\x00\xff\xff\x5c\x00\x54\x00\x5e\x00\x56\x00\x57\x00\xff\xff\xff\xff\x63\x00\x64\x00\xff\xff\xff\xff\x67\x00\x68\x00\xff\xff\xff\xff\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x77\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\x29\x00\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\xff\xff\xb2\x00\xb3\x00\xff\xff\xb5\x00\xb6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\xff\xff\xbf\x00\xff\xff\xc1\x00\x46\x00\xff\xff\x48\x00\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x50\x00\x5a\x00\xff\xff\x5c\x00\x54\x00\x5e\x00\x56\x00\x57\x00\xff\xff\xff\xff\x63\x00\x64\x00\xff\xff\xff\xff\x67\x00\x68\x00\xff\xff\xff\xff\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x77\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\xff\xff\xb2\x00\xb3\x00\xff\xff\xb5\x00\xb6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\xff\xff\xbf\x00\xff\xff\xc1\x00\x46\x00\xff\xff\x48\x00\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x50\x00\x5a\x00\xff\xff\x5c\x00\x54\x00\x5e\x00\x56\x00\x57\x00\xff\xff\xff\xff\x63\x00\x64\x00\xff\xff\xff\xff\x67\x00\x68\x00\xff\xff\xff\xff\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x77\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\xff\xff\xb2\x00\xb3\x00\xff\xff\xb5\x00\xb6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\xff\xff\xbf\x00\xff\xff\xc1\x00\x46\x00\xff\xff\x48\x00\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x50\x00\x5a\x00\xff\xff\x5c\x00\x54\x00\x5e\x00\x56\x00\x57\x00\xff\xff\xff\xff\x63\x00\x64\x00\xff\xff\xff\xff\x67\x00\x68\x00\xff\xff\xff\xff\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x77\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\xff\xff\xb2\x00\xb3\x00\xff\xff\xb5\x00\xb6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\xff\xff\xbf\x00\xff\xff\xc1\x00\x46\x00\xff\xff\x48\x00\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x50\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\x56\x00\x57\x00\xff\xff\xff\xff\x63\x00\x64\x00\xff\xff\xff\xff\x67\x00\x68\x00\xff\xff\xff\xff\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x77\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\xff\xff\xb2\x00\xb3\x00\xff\xff\xb5\x00\xb6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\xff\xff\xbf\x00\xff\xff\xc1\x00\x46\x00\xff\xff\x48\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x50\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\x56\x00\x57\x00\xff\xff\xff\xff\x63\x00\x64\x00\xff\xff\xff\xff\x67\x00\x68\x00\xff\xff\xff\xff\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x77\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\xff\xff\xb2\x00\xb3\x00\xff\xff\xb5\x00\xb6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\xff\xff\xbf\x00\xff\xff\xc1\x00\x46\x00\xff\xff\x48\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x50\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\x56\x00\x57\x00\xff\xff\xff\xff\x63\x00\x64\x00\xff\xff\xff\xff\x67\x00\x68\x00\xff\xff\xff\xff\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x77\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x01\x00\x02\x00\x03\x00\xff\xff\xff\xff\xff\xff\xff\xff\x08\x00\xff\xff\x0a\x00\x0b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x12\x00\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x1a\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x23\x00\x24\x00\x25\x00\x26\x00\x27\x00\x28\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x32\x00\x33\x00\x34\x00\xff\xff\xb2\x00\xb3\x00\xff\xff\xb5\x00\xb6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\xff\xff\xbf\x00\xff\xff\xc1\x00\x46\x00\xff\xff\x48\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\x56\x00\xff\xff\x58\x00\xff\xff\x5a\x00\x57\x00\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x63\x00\x64\x00\xff\xff\xff\xff\x67\x00\x68\x00\xff\xff\xff\xff\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\xff\xff\x77\x00\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xff\xff\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x01\x00\x02\x00\xff\xff\x3e\x00\x3f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x16\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x24\x00\x25\x00\x26\x00\x27\x00\x62\x00\xff\xff\x2a\x00\x65\x00\x66\x00\xff\xff\xff\xff\x69\x00\x6a\x00\xb2\x00\xb3\x00\xb4\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xff\xff\xff\xff\xff\xff\xff\xff\x46\x00\xff\xff\xff\xff\x49\x00\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x57\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\x50\x00\x63\x00\x64\x00\xff\xff\xff\xff\x67\x00\x68\x00\x57\x00\xff\xff\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\xff\xff\x77\x00\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xff\xff\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x01\x00\x02\x00\xff\xff\x77\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xb2\x00\xb3\x00\xff\xff\xb5\x00\xb6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbf\x00\xff\xff\xc1\x00\xb2\x00\xb3\x00\xff\xff\xb5\x00\xb6\x00\xff\xff\xff\xff\x46\x00\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xbf\x00\xff\xff\xc1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\xcc\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x63\x00\x64\x00\xff\xff\xff\xff\x67\x00\x68\x00\xff\xff\xff\xff\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xff\xff\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\x3f\x00\x40\x00\x0a\x00\x42\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x48\x00\x49\x00\x4a\x00\xff\xff\xff\xff\x16\x00\xff\xff\x4f\x00\xff\xff\xff\xff\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x24\x00\x25\x00\x26\x00\x27\x00\x02\x00\xff\xff\x2a\x00\x62\x00\xff\xff\xff\xff\x65\x00\x66\x00\x0a\x00\xff\xff\x69\x00\x6a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\xff\xff\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\x5f\x00\xff\xff\xff\xff\xff\xff\x63\x00\x64\x00\xff\xff\xff\xff\x67\x00\x68\x00\xff\xff\xff\xff\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x5a\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x01\x00\x02\x00\xff\xff\x63\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x46\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\x56\x00\xff\xff\x58\x00\xff\xff\x5a\x00\xff\xff\x5c\x00\xff\xff\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x63\x00\x64\x00\xff\xff\xff\xff\x67\x00\x68\x00\xff\xff\xff\xff\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\xff\xff\xff\xff\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\xff\xff\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\x01\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x63\x00\x64\x00\x0a\x00\xff\xff\x67\x00\x68\x00\xff\xff\xff\xff\x6b\x00\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\x16\x00\xff\xff\x53\x00\xff\xff\xff\xff\x56\x00\x57\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\xff\xff\x56\x00\x2a\x00\x58\x00\xff\xff\x5a\x00\xff\xff\x5c\x00\x6b\x00\x5e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x63\x00\x64\x00\xff\xff\xff\xff\x67\x00\x68\x00\x77\x00\xff\xff\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x02\x00\xff\xff\xff\xff\xff\xff\x7c\x00\x7d\x00\x7e\x00\x7f\x00\x0a\x00\x81\x00\x82\x00\x83\x00\x84\x00\x85\x00\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x63\x00\xff\xff\x65\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xb2\x00\xb3\x00\xff\xff\xb5\x00\xb6\x00\xff\xff\xff\xff\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\xff\xff\xbf\x00\xff\xff\xc1\x00\xff\xff\xff\xff\x40\x00\xff\xff\x42\x00\xff\xff\x44\x00\xff\xff\x46\x00\x47\x00\xcc\x00\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\x50\x00\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\xff\xff\x5a\x00\x0a\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x16\x00\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x79\x00\xff\xff\x2a\x00\xff\xff\xff\xff\x4b\x00\xff\xff\xff\xff\x81\x00\x82\x00\x50\x00\x51\x00\x85\x00\x53\x00\x54\x00\x37\x00\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x44\x00\xff\xff\x46\x00\x47\x00\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\x02\x00\x58\x00\x77\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\x68\x00\xff\xff\x6a\x00\x16\x00\x6c\x00\xff\xff\xff\xff\xff\xff\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x79\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\x81\x00\x82\x00\xff\xff\xff\xff\x85\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa9\x00\x37\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb2\x00\xb3\x00\xff\xff\xb5\x00\xb6\x00\x44\x00\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xbf\x00\xff\xff\xc1\x00\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x56\x00\xff\xff\x58\x00\xcc\x00\x5a\x00\x5b\x00\x5c\x00\x0a\x00\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\x64\x00\x65\x00\x66\x00\xff\xff\x68\x00\x16\x00\x6a\x00\xff\xff\x6c\x00\x6d\x00\xff\xff\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x81\x00\x82\x00\xff\xff\xff\xff\x85\x00\xff\xff\xff\xff\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x44\x00\xff\xff\x46\x00\x47\x00\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\x50\x00\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\xff\xff\x5a\x00\x0a\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x16\x00\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x81\x00\x82\x00\xff\xff\xff\xff\x85\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x44\x00\xff\xff\x46\x00\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\x50\x00\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\xff\xff\x5a\x00\x0a\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x16\x00\x68\x00\xff\xff\x6a\x00\xff\xff\x6c\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x81\x00\x82\x00\xff\xff\xff\xff\x85\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x46\x00\x47\x00\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x56\x00\xff\xff\x58\x00\xff\xff\x5a\x00\xff\xff\x5c\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x62\x00\x63\x00\x64\x00\xff\xff\x66\x00\xff\xff\x68\x00\x16\x00\xff\xff\xff\xff\x6c\x00\xff\xff\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x81\x00\x82\x00\xff\xff\xff\xff\x85\x00\xff\xff\xff\xff\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\xff\xff\x5a\x00\x0a\x00\x5c\x00\x5d\x00\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\x64\x00\xff\xff\xff\xff\x16\x00\x68\x00\xff\xff\xff\xff\xff\xff\x6c\x00\x6d\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\x50\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x56\x00\x57\x00\x81\x00\x82\x00\xff\xff\xff\xff\x85\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\x6b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x77\x00\x50\x00\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\xff\xff\x5a\x00\x0a\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x62\x00\x63\x00\x64\x00\xff\xff\x66\x00\x16\x00\x68\x00\xff\xff\xff\xff\xff\xff\x6c\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x81\x00\x82\x00\xff\xff\xff\xff\x85\x00\xff\xff\xff\xff\x37\x00\xff\xff\xb2\x00\xb3\x00\xff\xff\xb5\x00\xb6\x00\xff\xff\xff\xff\x40\x00\xff\xff\x42\x00\xff\xff\xff\xff\xff\xff\xbf\x00\x47\x00\xc1\x00\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xcc\x00\xff\xff\x02\x00\x56\x00\xff\xff\x58\x00\xff\xff\x5a\x00\xff\xff\x5c\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x63\x00\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\x16\x00\xff\xff\xff\xff\x6c\x00\xff\xff\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x81\x00\x82\x00\xff\xff\xff\xff\x85\x00\xff\xff\xff\xff\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x56\x00\xff\xff\x58\x00\xff\xff\x5a\x00\x5b\x00\x5c\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x63\x00\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\x16\x00\xff\xff\xff\xff\x6c\x00\x6d\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x81\x00\x82\x00\xff\xff\xff\xff\x85\x00\xff\xff\xff\xff\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x56\x00\xff\xff\x58\x00\x59\x00\x5a\x00\xff\xff\x5c\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x63\x00\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\x16\x00\xff\xff\xff\xff\x6c\x00\x6d\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x81\x00\x82\x00\xff\xff\xff\xff\x85\x00\xff\xff\xff\xff\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x56\x00\x57\x00\x58\x00\xff\xff\x5a\x00\xff\xff\x5c\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x63\x00\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\x16\x00\xff\xff\xff\xff\x6c\x00\x6d\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x81\x00\x82\x00\xff\xff\xff\xff\x85\x00\xff\xff\xff\xff\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x56\x00\xff\xff\x58\x00\xff\xff\x5a\x00\xff\xff\x5c\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x63\x00\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\x16\x00\xff\xff\xff\xff\x6c\x00\x6d\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x81\x00\x82\x00\xff\xff\xff\xff\x85\x00\xff\xff\xff\xff\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x56\x00\xff\xff\x58\x00\xff\xff\x5a\x00\xff\xff\x5c\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x63\x00\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\x16\x00\xff\xff\xff\xff\x6c\x00\x6d\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x81\x00\x82\x00\xff\xff\xff\xff\x85\x00\xff\xff\xff\xff\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x56\x00\xff\xff\x58\x00\xff\xff\x5a\x00\xff\xff\x5c\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x63\x00\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\x16\x00\xff\xff\xff\xff\x6c\x00\x6d\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x81\x00\x82\x00\xff\xff\xff\xff\x85\x00\xff\xff\xff\xff\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x56\x00\xff\xff\x58\x00\xff\xff\x5a\x00\xff\xff\x5c\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x63\x00\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\x16\x00\xff\xff\xff\xff\x6c\x00\x6d\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x81\x00\x82\x00\xff\xff\xff\xff\x85\x00\xff\xff\xff\xff\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x56\x00\xff\xff\x58\x00\xff\xff\x5a\x00\xff\xff\x5c\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x63\x00\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\x16\x00\xff\xff\xff\xff\x6c\x00\x6d\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x81\x00\x82\x00\xff\xff\xff\xff\x85\x00\xff\xff\xff\xff\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x56\x00\xff\xff\x58\x00\xff\xff\x5a\x00\xff\xff\x5c\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x63\x00\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\x16\x00\xff\xff\xff\xff\x6c\x00\x6d\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x81\x00\x82\x00\xff\xff\xff\xff\x85\x00\xff\xff\xff\xff\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x56\x00\xff\xff\x58\x00\xff\xff\x5a\x00\xff\xff\x5c\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x63\x00\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\x16\x00\xff\xff\xff\xff\x6c\x00\x6d\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x81\x00\x82\x00\xff\xff\xff\xff\x85\x00\xff\xff\xff\xff\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x56\x00\xff\xff\x58\x00\xff\xff\x5a\x00\xff\xff\x5c\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x63\x00\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\x16\x00\xff\xff\xff\xff\x6c\x00\x6d\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x81\x00\x82\x00\xff\xff\xff\xff\x85\x00\xff\xff\xff\xff\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x56\x00\xff\xff\x58\x00\xff\xff\x5a\x00\xff\xff\x5c\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x63\x00\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\x16\x00\xff\xff\xff\xff\x6c\x00\x6d\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x81\x00\x82\x00\xff\xff\xff\xff\x85\x00\xff\xff\xff\xff\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x56\x00\xff\xff\x58\x00\xff\xff\x5a\x00\xff\xff\x5c\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x63\x00\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\x16\x00\xff\xff\xff\xff\x6c\x00\x6d\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x81\x00\x82\x00\xff\xff\xff\xff\x85\x00\xff\xff\xff\xff\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x56\x00\xff\xff\x58\x00\xff\xff\x5a\x00\xff\xff\x5c\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x63\x00\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\x16\x00\xff\xff\xff\xff\x6c\x00\x6d\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x81\x00\x82\x00\xff\xff\xff\xff\x85\x00\xff\xff\xff\xff\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x56\x00\xff\xff\x58\x00\xff\xff\x5a\x00\xff\xff\x5c\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x63\x00\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\x16\x00\xff\xff\xff\xff\x6c\x00\x6d\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x81\x00\x82\x00\xff\xff\xff\xff\x85\x00\xff\xff\xff\xff\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x56\x00\xff\xff\x58\x00\xff\xff\x5a\x00\xff\xff\x5c\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x63\x00\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\x16\x00\xff\xff\xff\xff\x6c\x00\x6d\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x81\x00\x82\x00\xff\xff\xff\xff\x85\x00\xff\xff\xff\xff\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\xff\xff\x5a\x00\x0a\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\x63\x00\x64\x00\xff\xff\xff\xff\x16\x00\x68\x00\xff\xff\xff\xff\xff\xff\x6c\x00\x6d\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x81\x00\x82\x00\xff\xff\xff\xff\x85\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x56\x00\xff\xff\x58\x00\xff\xff\x5a\x00\xff\xff\x5c\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x63\x00\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\x16\x00\xff\xff\xff\xff\x6c\x00\xff\xff\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\x81\x00\x82\x00\xff\xff\xff\xff\x85\x00\xff\xff\xff\xff\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x44\x00\xff\xff\xff\xff\xff\xff\x48\x00\x49\x00\x4a\x00\xff\xff\xff\xff\x49\x00\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\x56\x00\x5b\x00\x58\x00\xff\xff\x5a\x00\x0a\x00\x5c\x00\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\x66\x00\x63\x00\x64\x00\x69\x00\x6a\x00\x16\x00\x68\x00\xff\xff\xff\xff\xff\xff\x6c\x00\x6d\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x81\x00\x82\x00\xff\xff\xff\xff\x85\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x47\x00\xff\xff\x49\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\xff\xff\x5a\x00\x0a\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x11\x00\x63\x00\x64\x00\xff\xff\xff\xff\x16\x00\x68\x00\xff\xff\xff\xff\xff\xff\x6c\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x81\x00\x82\x00\xff\xff\xff\xff\x85\x00\xff\xff\xff\xff\x37\x00\xff\xff\xff\xff\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x48\x00\x49\x00\x4a\x00\xff\xff\xff\xff\x49\x00\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\x56\x00\x5b\x00\x58\x00\xff\xff\x5a\x00\x0a\x00\x5c\x00\x61\x00\xff\xff\xff\xff\xff\xff\x65\x00\x66\x00\x63\x00\x64\x00\x69\x00\x6a\x00\x16\x00\x68\x00\xff\xff\xff\xff\xff\xff\x6c\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\x4b\x00\xff\xff\xff\xff\x81\x00\x82\x00\x50\x00\x51\x00\x85\x00\x53\x00\x54\x00\x37\x00\x56\x00\x57\x00\x58\x00\x59\x00\xff\xff\xff\xff\xff\xff\x4b\x00\xff\xff\xff\xff\x4e\x00\xff\xff\x50\x00\x51\x00\xff\xff\x53\x00\x54\x00\x49\x00\x56\x00\x57\x00\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\x58\x00\x77\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x63\x00\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\x4b\x00\x77\x00\x6c\x00\x4e\x00\xff\xff\x50\x00\x51\x00\xff\xff\x53\x00\x54\x00\xff\xff\x56\x00\x57\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x81\x00\x82\x00\xff\xff\xff\xff\x85\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb2\x00\xb3\x00\x77\x00\xb5\x00\xb6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xa9\x00\xff\xff\xff\xff\xff\xff\xbf\x00\xff\xff\xc1\x00\xff\xff\xff\xff\xb2\x00\xb3\x00\xff\xff\xb5\x00\xb6\x00\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\x4b\x00\xff\xff\xbf\x00\xff\xff\xc1\x00\x50\x00\x51\x00\xff\xff\x53\x00\x54\x00\xff\xff\x56\x00\x57\x00\x58\x00\xff\xff\xcc\x00\x4b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\x51\x00\xa9\x00\x53\x00\x54\x00\xff\xff\x56\x00\x57\x00\x58\x00\xff\xff\xff\xff\xb2\x00\xb3\x00\xff\xff\xb5\x00\xb6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x4b\x00\x77\x00\xbf\x00\xff\xff\xc1\x00\x50\x00\x51\x00\xff\xff\x53\x00\x54\x00\xff\xff\x56\x00\x57\x00\x58\x00\xff\xff\xcc\x00\xff\xff\x77\x00\x4b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\x51\x00\xff\xff\x53\x00\x54\x00\xff\xff\x56\x00\x57\x00\xff\xff\xff\xff\xff\xff\x4b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\x51\x00\xff\xff\x53\x00\x54\x00\x77\x00\x56\x00\x57\x00\xff\xff\xff\xff\xff\xff\xff\xff\xa9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb2\x00\xb3\x00\x77\x00\xb5\x00\xb6\x00\xff\xff\xff\xff\xa9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbf\x00\xff\xff\xc1\x00\xb2\x00\xb3\x00\x77\x00\xb5\x00\xb6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\x4b\x00\xff\xff\xbf\x00\xff\xff\xc1\x00\x50\x00\x51\x00\xa9\x00\x53\x00\x54\x00\xff\xff\x56\x00\x57\x00\xff\xff\xff\xff\xcc\x00\xb2\x00\xb3\x00\xff\xff\xb5\x00\xb6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xa9\x00\xff\xff\xff\xff\xff\xff\xbf\x00\xff\xff\xc1\x00\xff\xff\xff\xff\xb2\x00\xb3\x00\xff\xff\xb5\x00\xb6\x00\xff\xff\xff\xff\xa9\x00\xcc\x00\xff\xff\x77\x00\xff\xff\xff\xff\xbf\x00\xff\xff\xc1\x00\xb2\x00\xb3\x00\xff\xff\xb5\x00\xb6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\x4b\x00\xff\xff\xbf\x00\xff\xff\xc1\x00\x50\x00\x51\x00\xff\xff\x53\x00\x54\x00\xff\xff\x56\x00\x57\x00\xff\xff\xff\xff\xcc\x00\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x57\x00\xff\xff\xff\xff\xff\xff\xff\xff\xa9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb2\x00\xb3\x00\x77\x00\xb5\x00\xb6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbf\x00\xff\xff\xc1\x00\xff\xff\xff\xff\x77\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xcc\x00\x50\x00\xff\xff\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x57\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4c\x00\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x57\x00\xff\xff\xa9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb2\x00\xb3\x00\xff\xff\xb5\x00\xb6\x00\x77\x00\xff\xff\xa9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbf\x00\xff\xff\xc1\x00\xb2\x00\xb3\x00\xff\xff\xb5\x00\xb6\x00\x77\x00\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xbf\x00\x4c\x00\xc1\x00\xff\xff\xff\xff\x50\x00\xff\xff\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x57\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb2\x00\xb3\x00\xff\xff\xb5\x00\xb6\x00\xff\xff\xff\xff\xa9\x00\xff\xff\x77\x00\xff\xff\xff\xff\xff\xff\xbf\x00\xff\xff\xc1\x00\xb2\x00\xb3\x00\xff\xff\xb5\x00\xb6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xbf\x00\xff\xff\xc1\x00\xff\xff\xff\xff\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\xff\xff\xa9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb2\x00\xb3\x00\xff\xff\xb5\x00\xb6\x00\x77\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbf\x00\xff\xff\xc1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x77\x00\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x50\x00\x51\x00\xff\xff\x53\x00\x54\x00\xff\xff\x56\x00\x57\x00\xff\xff\xff\xff\xff\xff\x5b\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb2\x00\xb3\x00\x77\x00\xb5\x00\xb6\x00\x50\x00\x51\x00\xa9\x00\x53\x00\x54\x00\x77\x00\x56\x00\x57\x00\xbf\x00\xff\xff\xc1\x00\xb2\x00\xb3\x00\xff\xff\xb5\x00\xb6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xbf\x00\xff\xff\xc1\x00\x50\x00\x51\x00\xff\xff\x53\x00\x54\x00\xff\xff\x56\x00\x57\x00\xff\xff\xff\xff\xcc\x00\x5b\x00\x77\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\x51\x00\xa9\x00\x53\x00\x54\x00\xff\xff\x56\x00\x57\x00\xff\xff\xff\xff\xa9\x00\xb2\x00\xb3\x00\xff\xff\xb5\x00\xb6\x00\xff\xff\xff\xff\xff\xff\xb2\x00\xb3\x00\x77\x00\xb5\x00\xb6\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbf\x00\xff\xff\xc1\x00\xff\xff\xff\xff\xcc\x00\xff\xff\x77\x00\xff\xff\xff\xff\xff\xff\xff\xff\xa9\x00\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb2\x00\xb3\x00\xff\xff\xb5\x00\xb6\x00\x50\x00\x51\x00\xff\xff\x53\x00\x54\x00\xff\xff\x56\x00\x57\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xff\xff\xa9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xb2\x00\xb3\x00\xff\xff\xb5\x00\xb6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xa9\x00\xff\xff\xff\xff\xff\xff\xbf\x00\xff\xff\xc1\x00\xff\xff\x77\x00\xb2\x00\xb3\x00\xff\xff\xb5\x00\xb6\x00\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xbf\x00\x50\x00\xc1\x00\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x57\x00\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x57\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa9\x00\xff\xff\xff\xff\xff\xff\x77\x00\xff\xff\xff\xff\xff\xff\xff\xff\xb2\x00\xb3\x00\xff\xff\xb5\x00\xb6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x77\x00\xff\xff\xbf\x00\x50\x00\xc1\x00\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x57\x00\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\xff\xff\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x57\x00\xff\xff\xff\xff\xff\xff\xff\xff\xa9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x77\x00\xb2\x00\xb3\x00\xff\xff\xb5\x00\xb6\x00\xff\xff\xff\xff\xa9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbf\x00\xff\xff\xc1\x00\xb2\x00\xb3\x00\x77\x00\xb5\x00\xb6\x00\x50\x00\x51\x00\xff\xff\x53\x00\x54\x00\xcc\x00\x56\x00\x57\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\x51\x00\xff\xff\x53\x00\x54\x00\xcc\x00\x56\x00\x57\x00\xff\xff\xff\xff\xff\xff\xff\xff\xa9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb2\x00\xb3\x00\x77\x00\xb5\x00\xb6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa9\x00\xff\xff\xff\xff\xbf\x00\xff\xff\xc1\x00\xff\xff\xff\xff\x77\x00\xb2\x00\xb3\x00\xff\xff\xb5\x00\xb6\x00\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbf\x00\x50\x00\xc1\x00\x52\x00\x53\x00\xff\xff\x55\x00\x56\x00\x57\x00\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\x51\x00\xa9\x00\x53\x00\x54\x00\xff\xff\x56\x00\x57\x00\xff\xff\xff\xff\xff\xff\xb2\x00\xb3\x00\xff\xff\xb5\x00\xb6\x00\xff\xff\xff\xff\xa9\x00\xff\xff\xff\xff\xff\xff\x77\x00\xff\xff\xbf\x00\xff\xff\xc1\x00\xb2\x00\xb3\x00\xff\xff\xb5\x00\xb6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\x77\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\x50\x00\x51\x00\xff\xff\x53\x00\x54\x00\xff\xff\x56\x00\x57\x00\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x50\x00\x51\x00\xff\xff\x53\x00\x54\x00\xff\xff\x56\x00\x57\x00\xff\xff\xff\xff\xff\xff\xa9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb2\x00\xb3\x00\x77\x00\xb5\x00\xb6\x00\xff\xff\xff\xff\xff\xff\xa9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xbf\x00\xff\xff\xc1\x00\xff\xff\xb2\x00\xb3\x00\x77\x00\xb5\x00\xb6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xbf\x00\xff\xff\xc1\x00\x50\x00\x51\x00\xff\xff\x53\x00\x54\x00\xff\xff\x56\x00\x57\x00\x50\x00\x51\x00\xcc\x00\x53\x00\x54\x00\xff\xff\x56\x00\x57\x00\xff\xff\xff\xff\xff\xff\xa9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xb2\x00\xb3\x00\xff\xff\xb5\x00\xb6\x00\xff\xff\xff\xff\xff\xff\xa9\x00\xff\xff\xff\xff\x77\x00\xff\xff\xbf\x00\xff\xff\xc1\x00\xff\xff\xb2\x00\xb3\x00\x77\x00\xb5\x00\xb6\x00\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xbf\x00\xff\xff\xc1\x00\x50\x00\x51\x00\xff\xff\x53\x00\x54\x00\xff\xff\x56\x00\x57\x00\x50\x00\x51\x00\xcc\x00\x53\x00\x54\x00\xff\xff\x56\x00\x57\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa9\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xa9\x00\xb2\x00\xb3\x00\x77\x00\xb5\x00\xb6\x00\xff\xff\xff\xff\xff\xff\xb2\x00\xb3\x00\x77\x00\xb5\x00\xb6\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xbf\x00\xff\xff\xc1\x00\xff\xff\xff\xff\xcc\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xa9\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xa9\x00\xb2\x00\xb3\x00\xff\xff\xb5\x00\xb6\x00\xff\xff\xff\xff\xff\xff\xb2\x00\xb3\x00\xff\xff\xb5\x00\xb6\x00\xbf\x00\xff\xff\xc1\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xbf\x00\x02\x00\xc1\x00\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xcc\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x5a\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x63\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x02\x00\xff\xff\xff\xff\xff\xff\x6f\x00\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x63\x00\xff\xff\xff\xff\xff\xff\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x6f\x00\xff\xff\x48\x00\x49\x00\x4a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x4f\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\xff\xff\x02\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x16\x00\xff\xff\x18\x00\xff\xff\xff\xff\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x02\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\xff\xff\x1b\x00\x3d\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x56\x00\xff\xff\xff\xff\xff\xff\x5a\x00\x5b\x00\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x63\x00\x64\x00\xff\xff\xff\xff\x67\x00\x68\x00\xff\xff\xff\xff\x6b\x00\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x56\x00\xff\xff\xff\xff\xff\xff\x5a\x00\xff\xff\x5c\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x63\x00\x64\x00\xff\xff\x13\x00\x67\x00\x68\x00\x16\x00\xff\xff\x6b\x00\x6c\x00\xff\xff\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x02\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\xff\xff\x63\x00\x64\x00\xff\xff\xff\xff\x67\x00\x68\x00\xff\xff\xff\xff\x6b\x00\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\x56\x00\xff\xff\xff\xff\xff\xff\x5a\x00\xff\xff\x5c\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x63\x00\x64\x00\xff\xff\xff\xff\x67\x00\x68\x00\x16\x00\xff\xff\x6b\x00\x6c\x00\xff\xff\x02\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x0a\x00\xff\xff\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\x02\x00\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\x0a\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x24\x00\x25\x00\x26\x00\x27\x00\x16\x00\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\xff\xff\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x56\x00\xff\xff\x58\x00\xff\xff\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x63\x00\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\xff\xff\xff\xff\xff\xff\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x63\x00\x64\x00\xff\xff\xff\xff\x67\x00\x68\x00\x02\x00\xff\xff\x6b\x00\x6c\x00\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\x63\x00\x64\x00\xff\xff\xff\xff\xff\xff\x68\x00\x02\x00\xff\xff\x16\x00\x6c\x00\xff\xff\xff\xff\xff\xff\x1b\x00\x0a\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x11\x00\x24\x00\x25\x00\x26\x00\x27\x00\x16\x00\xff\xff\x2a\x00\xff\xff\xff\xff\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x3d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x63\x00\xff\xff\xff\xff\x02\x00\x67\x00\xff\xff\xff\xff\xff\xff\x6b\x00\x5a\x00\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x63\x00\xff\xff\xff\xff\xff\xff\x67\x00\x16\x00\xff\xff\xff\xff\x6b\x00\xff\xff\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x02\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x13\x00\xff\xff\xff\xff\x16\x00\xff\xff\x18\x00\xff\xff\xff\xff\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x63\x00\xff\xff\x16\x00\xff\xff\x67\x00\xff\xff\xff\xff\x1b\x00\x6b\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x02\x00\x24\x00\x25\x00\x26\x00\x27\x00\x56\x00\xff\xff\x2a\x00\x0a\x00\x5a\x00\xff\xff\x5c\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x63\x00\x64\x00\x16\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\x56\x00\xff\xff\xff\xff\xff\xff\x5a\x00\xff\xff\x5c\x00\xff\xff\x02\x00\xff\xff\x16\x00\xff\xff\xff\xff\x63\x00\x64\x00\x1b\x00\x0a\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x24\x00\x25\x00\x26\x00\x27\x00\x16\x00\xff\xff\x2a\x00\xff\xff\xff\xff\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x24\x00\x25\x00\x26\x00\x27\x00\x63\x00\x64\x00\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x5a\x00\x1b\x00\x0a\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x63\x00\x24\x00\x25\x00\x26\x00\x27\x00\x16\x00\xff\xff\x2a\x00\xff\xff\x5a\x00\x1b\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x63\x00\x24\x00\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\x5a\x00\x1b\x00\x0a\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x63\x00\x24\x00\x25\x00\x26\x00\x27\x00\x16\x00\xff\xff\x2a\x00\xff\xff\x5a\x00\xff\xff\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x63\x00\xff\xff\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x02\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\x0a\x00\xff\xff\xff\xff\x44\x00\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\xff\xff\x16\x00\x25\x00\x26\x00\x27\x00\x63\x00\xff\xff\x2a\x00\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x5a\x00\xff\xff\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\x02\x00\x63\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x0a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x00\x1e\x00\x1f\x00\x20\x00\x21\x00\x22\x00\x5a\x00\xff\xff\x25\x00\x26\x00\x27\x00\xff\xff\xff\xff\x2a\x00\xff\xff\x63\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x63\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x63\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# happyTable :: HappyAddr -happyTable = HappyA# "\x00\x00\x08\x04\x9d\x00\x9e\x00\x9f\x00\x1d\x00\x1e\x00\xa0\x00\xde\x03\x64\x03\x5e\x03\x47\x01\x1f\x00\x1a\x04\xe7\x03\xd5\x03\xa3\x00\x86\x03\x41\x03\x40\x03\x41\x03\xf2\x02\x3d\x02\xd2\x01\x24\x02\x17\x02\xad\xfd\x63\x00\xa4\x00\xa5\x00\x3b\x03\xe4\xfe\x0e\x04\x62\x03\x63\x03\x64\x03\x5d\x02\xa6\x00\xf2\xff\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xe1\x03\x64\x03\xab\x00\x6f\x01\x44\x02\xac\x00\x19\x04\x62\x03\x63\x03\x64\x03\xad\xfd\x06\x04\x46\x01\x47\x01\x17\x02\xad\xfd\xd2\x01\xbd\x01\xd2\x01\xcd\x03\x25\x03\x3e\x02\x2f\x00\xce\x03\xd6\x03\xa3\x00\xef\x01\xd0\x00\x85\x03\x45\x02\xf5\x02\xad\x00\x06\x03\x30\x00\x09\x00\xee\x02\x63\x00\xa4\x00\xa5\x00\xd0\x00\x29\xff\xf3\x02\x29\xff\xf0\x01\x03\x03\x7a\x03\xa6\x00\x7b\x03\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xc0\x03\x4c\x01\xab\x00\x6c\x03\x64\x03\xac\x00\xf4\x03\x62\x03\x63\x03\x64\x03\xd3\x01\x13\x02\xd0\x00\x12\x03\x13\x03\x48\x01\x24\x02\x90\x02\xbe\x01\xd0\x00\x48\x01\x14\x03\xef\x03\xae\x00\xaf\x00\xb0\x00\x49\x01\x41\x02\x46\x02\xb1\x00\x64\x00\xad\x00\xb2\x00\x67\x00\xcf\x03\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x22\x00\xbe\x01\x45\x00\xce\x03\xd1\x00\xd3\x01\x70\x01\xd3\x01\x10\x04\x71\x01\x61\x03\x62\x03\x63\x03\x64\x03\x04\x03\x09\x00\xc6\x03\xd3\x02\x93\x03\x42\x03\x71\x01\x42\x03\x42\x02\x47\x02\x48\x01\x09\x00\x09\x00\x09\x00\x70\x01\x73\x00\x49\x01\x71\x01\x47\x00\x14\x02\xae\x00\xaf\x00\xb0\x00\x09\x00\xb8\x02\x72\x00\xb1\x00\x64\x00\x73\x00\xb2\x00\x67\x00\x47\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\xf2\x03\xe7\x00\x07\x00\x08\x00\x4a\x02\x28\xff\x4d\x01\x28\xff\x2f\x00\x09\x00\xd8\x02\x4f\x00\x50\x00\xb3\x00\x74\x00\x07\x00\xb4\x00\xb9\x02\x65\x03\x30\x00\x66\x03\x67\x03\x09\x00\x0a\x02\x4f\x00\x50\x00\x8f\x02\x46\x03\x75\x00\x20\x00\x48\x01\x20\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\x14\x03\x47\x03\xf6\x03\x72\x00\x4b\x02\xb5\x02\x73\x00\xf3\x03\x65\x03\x47\x00\x66\x03\x67\x03\xc6\x01\xe5\x03\xe6\x03\xe7\x03\x48\x01\x65\x03\xb3\x01\x66\x03\x67\x03\xf7\x03\x15\x02\xb4\x01\x90\x02\x65\x03\xd1\x00\x66\x03\x67\x03\xb3\x00\x74\x00\x07\x00\xb4\x00\xa2\x00\xa3\x00\xd1\x02\xd2\x02\x48\x01\x09\x00\x7d\x01\x4f\x00\x50\x00\xc9\x03\x15\x02\x75\x00\x63\x00\xa4\x00\xa5\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xbc\x03\xc5\x03\xb5\x01\xa6\x00\x48\x01\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xc8\x03\x15\x02\xab\x00\x32\x03\x4c\x01\xac\x00\x7e\x01\xc6\x03\xd3\x00\xa3\x00\xb7\x01\x65\x03\x7f\x01\x66\x03\x67\x03\xb8\x01\x65\x03\xba\x02\x66\x03\x67\x03\x63\x00\xa4\x00\xa5\x00\x46\x00\xc6\x01\x32\xff\x47\x00\x32\xff\x48\x00\x92\x03\xa6\x00\xad\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xd3\x02\xa4\x03\xab\x00\x71\x01\x49\x00\xac\x00\xc4\x02\x54\x00\x93\x03\x09\x00\xb9\x01\x06\x00\x07\x00\x08\x00\x4a\x00\xf2\xff\x4b\x00\x4c\x00\x4d\x00\x09\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x65\x03\x4c\x02\x66\x03\x67\x03\x39\x03\x30\x01\xad\x00\x71\x01\xd2\x01\x0b\x02\xd2\x01\xff\x00\xa5\x03\x09\x00\xae\x00\xaf\x00\xb0\x00\xf5\x00\x0c\x02\x0d\x02\xb1\x00\x64\x00\x5f\x00\xb2\x00\x67\x00\xdc\x03\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\xad\xfd\x63\x00\x78\x02\x0e\x02\x4d\x00\xd3\x02\x4e\x00\x48\x01\x71\x01\x4d\x01\x0f\x02\x2f\x00\x73\x00\xa9\x03\x09\x00\x47\x00\xa2\x00\x79\x02\xae\x00\xaf\x00\xb0\x00\xdd\x03\x30\x00\xd0\x00\xb1\x00\x64\x00\x7a\x02\xb2\x00\x67\x00\xdf\x03\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\xe7\x00\x07\x00\x08\x00\x72\x00\x69\x03\x7b\x02\x73\x00\x80\x03\x09\x00\x47\x00\x4f\x00\x50\x00\x9c\x02\xaf\x03\x03\x04\xd7\x01\x1c\x04\x94\x03\xe3\x01\xe0\x01\x22\x00\xd6\x01\xd3\x01\xd7\x01\xd3\x01\x9a\x02\xdd\x01\xde\x01\x71\x01\xb3\x00\x74\x00\x07\x00\xb4\x00\x79\x02\x09\x00\x7b\x02\xca\x03\xcb\x03\x09\x00\x72\x00\x4f\x00\x50\x00\x73\x00\xd8\x01\x75\x00\x47\x00\x71\x01\xd9\x01\xb5\x00\xb6\x00\xb7\x00\xb8\x00\x09\x00\x4b\x02\x4d\x00\xd9\x01\x4e\x00\x45\x01\x46\x01\x47\x01\x4c\x02\x8b\x02\x8c\x02\x64\x00\x30\x01\xb3\x00\x74\x00\x07\x00\xb4\x00\x48\x01\x08\x02\xbf\x02\x6c\x00\x6d\x00\x09\x00\x73\x01\x4f\x00\x50\x00\x8d\x02\x0b\x02\x75\x00\x63\x00\x96\x03\x09\x02\xb5\x00\xb6\x00\xb7\x00\xb8\x00\x08\x03\x0d\x02\x99\x03\xa6\x00\x05\x03\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xa4\x03\x09\x00\xab\x00\xca\x01\x06\x03\xac\x00\x38\x01\x39\x01\x0e\x02\x4d\x00\xa5\x03\x4e\x00\x54\x00\xa7\x03\x63\x00\x0f\x02\x72\x00\x3a\x01\x0c\x03\x73\x00\x54\x00\x5f\x01\x47\x00\xb5\x03\xa6\x00\x60\x01\xa7\x00\xa8\x00\xa9\x00\xaa\x00\x0b\x03\xad\x00\xab\x00\x38\x01\x39\x01\xac\x00\x3b\x01\xdf\x01\xe0\x01\x0f\x03\xd6\x01\xff\x00\xd7\x01\x74\x00\x07\x00\x08\x00\x9c\x02\xf5\x00\x1e\x03\xff\x00\xfa\x03\x09\x00\x5f\x00\x4f\x00\x50\x00\xf5\x00\x62\x00\x75\x00\x22\x03\x4c\x02\xb8\x03\xad\x00\xd8\x01\x30\x01\x41\x01\x71\x01\x48\x01\x28\x03\x92\x01\x93\x01\x94\x01\x09\x00\x49\x01\x18\x04\xd9\x01\xae\x00\xaf\x00\xb0\x00\x55\x03\x19\x04\x6d\x03\xb1\x00\x64\x00\x58\x03\xb2\x00\x67\x00\x5b\x03\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\xf5\x02\x4c\x01\x23\x02\x6a\x01\x24\x02\x2f\x00\x3a\x01\x95\x01\x07\x00\x08\x00\x6c\x01\x4c\x01\xae\x00\xaf\x00\xb0\x00\x09\x00\x30\x00\x96\x02\xb1\x00\x64\x00\xba\x02\xb2\x00\x67\x00\xca\x01\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x79\x01\x62\x01\x2d\x00\xcb\x01\x63\x00\x85\x01\x7a\x01\xc2\x02\xbb\x02\x72\x00\xbc\x02\x7a\x01\x73\x00\x63\x01\xa6\x00\x47\x00\xa7\x00\xa8\x00\xa9\x00\xaa\x00\xc5\x02\xc0\x01\xab\x00\xc7\x02\x30\x00\xac\x00\x15\x04\xf5\x00\xc8\x02\x47\x00\x9c\x02\xa2\x02\x94\x01\xdf\x02\x00\x04\xb3\x00\x74\x00\x07\x00\xb4\x00\x72\x00\x4b\x02\x4d\x00\x73\x00\x4e\x00\x09\x00\x47\x00\x4f\x00\x50\x00\x9c\x02\x9c\x02\x75\x00\xad\x00\x5f\x03\x9d\x02\xb5\x00\xb6\x00\xb7\x00\xb8\x00\x4b\x01\x4c\x01\x4f\x00\x50\x00\x95\x01\x07\x00\x08\x00\xb3\x00\x74\x00\x07\x00\xb4\x00\x4d\x01\x09\x00\x2f\x00\xe2\x03\xa5\x00\x09\x00\xe0\x02\x4f\x00\x50\x00\xe3\x02\x4d\x01\x75\x00\x2f\x00\x30\x00\xe6\x02\xb5\x00\xb6\x00\xb7\x00\xb8\x00\x2f\x01\x52\x00\xe3\x03\xa5\x00\x30\x00\x30\x01\xe5\x00\xae\x00\xaf\x00\xb0\x00\x39\x02\x07\x00\x08\x00\xb1\x00\x64\x00\xea\x02\xb2\x00\x67\x00\x09\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x63\x00\xdf\x01\xe0\x01\xcc\x01\xd6\x01\x6e\x03\xd7\x01\x2c\x00\x2d\x00\x01\x03\xa6\x00\xff\x02\x6b\x03\x11\x02\xa9\x00\xaa\x00\x6c\x03\x2d\x02\xab\x00\x98\x03\xe9\x02\xac\x00\x6f\x03\x07\x00\x08\x00\x26\x02\xd8\x01\xc0\x01\x08\x00\x71\x01\x09\x00\x10\x03\x2d\x00\x63\x00\x09\x00\x09\x00\x2c\x01\x50\x00\xd9\x01\x72\x00\x02\x04\xae\x03\x73\x00\xa6\x00\x4d\x01\x47\x00\x2f\x00\xad\x00\x82\x03\x0e\x03\x29\x03\x2a\x03\x83\x03\x0f\x03\x55\x00\x56\x00\x57\x00\x30\x00\x59\x00\x2b\x03\x2c\x03\x58\x00\x05\x04\x2f\x02\x5b\x00\xb3\x00\x74\x00\x07\x00\xb4\x00\x2e\x01\xf9\x00\x4d\x00\x5d\x00\x4e\x00\x09\x00\x34\x02\x4f\x00\x50\x00\x18\x01\x64\x00\x75\x00\x38\x02\x19\x01\x5e\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\x42\x02\xe6\x00\xe5\x00\xae\x00\xaf\x00\xb0\x00\x3e\x02\x07\x00\x08\x00\xb1\x00\x64\x00\x48\x02\xb2\x00\x67\x00\x09\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x12\x03\x4d\x02\x24\x03\xaf\x03\xb0\x03\xd7\x01\x25\x03\x15\x01\x1d\x03\xb1\x03\x3e\x00\x2c\x00\x2d\x00\x52\x02\x3f\x00\xae\x00\xaf\x00\x2d\x03\x40\x00\x56\x02\x72\x00\xb1\x00\x64\x00\x73\x00\x9e\x01\x67\x00\x47\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x63\x00\x5f\x01\x5c\x03\x89\x02\xd9\x01\x60\x01\x72\x00\xe1\x01\xe2\x01\x73\x00\xa6\x00\x6b\x02\x47\x00\x72\x02\xe7\x00\x07\x00\x08\x00\x29\x03\x2a\x03\xe2\x02\xae\x02\xaf\x02\x09\x00\xe3\x02\x4f\x00\x50\x00\x2b\x03\x30\x03\x75\x00\xea\x01\x07\x00\x08\x00\xb3\x00\x74\x00\x07\x00\xb4\x00\xd5\x01\x09\x00\xd6\x01\x72\x00\xd7\x01\x09\x00\x73\x00\x4f\x00\x50\x00\x47\x00\x64\x00\x75\x00\xe7\x02\xe8\x02\xe9\x02\xb5\x00\xb6\x00\xb7\x00\xb8\x00\x81\x02\x57\x02\x5f\x01\x58\x02\x82\x02\xd8\x01\x60\x01\x74\x02\x71\x01\x7f\x02\xb3\x00\x74\x00\x07\x00\xb4\x00\x09\x00\x99\x02\x89\x02\xd9\x01\x7c\x02\x09\x00\x80\x01\x4f\x00\x50\x00\x88\x01\x7a\x01\x75\x00\x3a\x01\x7a\x01\x7d\x02\xb5\x00\xb6\x00\xb7\x00\xb8\x00\x55\x00\x56\x00\x57\x00\xae\x00\xaf\x00\x2d\x03\x09\x02\x58\x00\x72\x00\xb1\x00\x64\x00\x73\x00\x9e\x01\x67\x00\x47\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x63\x00\x95\x02\xc4\x01\x5d\x01\xe3\x01\xe0\x01\xf5\x00\xd6\x01\x5e\x00\xd7\x01\xa6\x00\x9a\x01\x61\x00\xc6\x01\xe7\x00\x07\x00\x08\x00\x29\x03\x2a\x03\x37\x01\x35\x01\x3d\x01\x09\x00\xf5\x00\x4f\x00\x50\x00\xd1\x03\x5f\x01\x75\x00\xd8\x01\x63\x00\x60\x01\x71\x01\x9e\x02\x89\x02\x06\x00\x07\x00\x08\x00\x09\x00\x72\x00\xa6\x00\xd9\x01\x73\x00\x09\x00\x3e\x01\x47\x00\x9a\x03\x18\x01\xfd\x02\x89\x02\xf5\x00\x19\x01\x9b\x03\x9c\x03\x3f\x01\x40\x01\xd0\x01\xd5\x00\x2b\x00\x41\x01\x2c\x00\x2d\x00\x1f\x02\x20\x02\x21\x02\xb3\x00\x74\x00\x07\x00\xb4\x00\xe1\x00\xd6\x00\x11\x01\x2f\x00\xe2\x00\x09\x00\x12\x01\x4f\x00\x50\x00\x54\x00\xd0\x00\x75\x00\xd2\x00\xd3\x00\x30\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\x55\x00\x56\x00\x57\x00\xae\x00\xaf\x00\x2d\x03\xcf\x01\x58\x00\xed\x01\xb1\x00\x64\x00\xf6\x01\x9e\x01\x67\x00\x04\x02\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x18\x01\xdf\x00\x11\x01\xf4\x00\x19\x01\x11\x02\x12\x01\xf5\x00\x5e\x00\x5f\x00\x3f\x02\xe8\x01\xae\x00\xaf\x00\x9d\x03\x38\x01\x39\x01\x2d\x01\xb1\x00\x64\x00\x0f\x01\x9e\x01\x67\x00\x13\x01\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x63\x00\x88\x02\x89\x02\x2e\x01\xf9\x00\x4d\x00\x1a\x01\x4e\x00\x1c\x04\x72\x00\xa6\x00\x1e\x04\x73\x00\xe4\x01\xe5\x01\x47\x00\x9a\x03\x75\x03\x76\x03\x77\x03\x78\x03\xd1\x00\x9b\x03\xa0\x03\xc3\x02\xe0\x01\x08\x04\xd6\x01\xd0\x00\xd7\x01\x50\x02\x20\x02\x21\x02\x63\x00\x5d\x00\xb3\x00\x74\x00\x07\x00\xb4\x00\x72\x00\xad\x03\xae\x03\x73\x00\xa6\x00\x09\x00\x47\x00\x4f\x00\x50\x00\x01\x03\xd8\x01\x75\x00\x10\x04\x71\x01\x12\x04\xb5\x00\xb6\x00\xb7\x00\xb8\x00\x09\x00\xe7\x01\xe8\x01\xd9\x01\x13\x04\x9c\x01\x15\x04\xb3\x00\x74\x00\x07\x00\xb4\x00\x36\x02\x37\x02\x38\x02\x2b\x01\x08\x00\x09\x00\x61\x01\x4f\x00\x50\x00\xe5\x03\x09\x00\x75\x00\x2c\x01\x50\x00\xec\x03\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xec\x01\xe8\x01\xef\x03\xae\x00\xaf\x00\x9d\x03\x15\x01\xf3\x01\xed\x03\xb1\x00\x64\x00\x01\x03\x9e\x01\x67\x00\xf6\x03\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x15\x01\x16\x01\x03\x03\xaf\x03\xb0\x03\xd7\x01\x5b\x01\xa5\x00\x17\x02\xb1\x03\x95\x03\x2c\x00\x2d\x00\x17\x02\xf9\x03\xae\x00\xaf\x00\x9d\x01\x50\x03\x51\x03\xd1\x00\xb1\x00\x64\x00\xff\x03\x9e\x01\x67\x00\xd1\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x63\x00\x54\x02\x55\x02\x00\x04\xd9\x01\x0b\xfe\x72\x00\xc5\xfd\xb7\x03\x73\x00\xa6\x00\xb9\x03\x47\x00\xbe\x03\xba\x03\xbb\x03\x22\x00\xbc\x03\xc0\x03\xfc\x01\xfd\x01\xd1\x03\x26\x00\x27\x00\xdb\x00\xbf\x03\xd1\x00\x47\x00\xd4\x03\xff\x01\xa2\x01\xd8\x03\xb3\x00\x74\x00\x07\x00\xb4\x00\xd9\x03\x9f\x01\xa0\x01\xa1\x01\xf5\x02\x09\x00\x73\x00\x4f\x00\x50\x00\x47\x00\x7a\x03\x75\x00\xdc\x00\x07\x00\x08\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\x28\x00\x09\x00\x59\x00\x4f\x00\x50\x00\xe1\x03\x17\x04\xbe\x00\x5b\x00\x74\x03\xb3\x00\x74\x00\x07\x00\xb4\x00\x7c\x03\x7d\x03\x5d\x00\x84\x03\x63\x00\x09\x00\x60\x00\x4f\x00\x50\x00\x88\x03\x63\x00\x75\x00\x89\x03\x8c\x03\x91\x03\xb5\x00\xb6\x00\xb7\x00\xb8\x00\x98\x03\xa9\x03\x01\x03\xae\x00\xaf\x00\x9d\x01\x0a\x03\x0b\x03\x01\x03\xb1\x00\x64\x00\x03\x03\x9e\x01\x67\x00\x01\x03\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x63\x00\x22\x01\xd0\x00\x19\x03\x1d\x03\x2a\x00\x2b\x00\xf5\x02\x2c\x00\x2d\x00\xa6\x00\x23\x01\x20\x03\x24\x01\x28\x03\x21\x03\x9a\x03\x34\x03\x2e\x00\xe6\xfd\x2f\x00\xe4\xfd\xf9\x03\x4a\x00\x22\x01\x4b\x00\x4c\x00\x4d\x00\x39\x03\x4e\x00\x63\x00\x30\x00\x51\x00\x52\x00\x23\x01\xe5\xfd\x24\x01\xa3\x01\xa0\x01\xa1\x01\xa6\x00\x3d\x03\x73\x00\x3b\x03\x3e\x03\x47\x00\x4a\x00\x3f\x03\x4b\x00\x4c\x00\x4d\x00\x48\x03\x4e\x00\x49\x03\x4a\x03\x51\x00\x52\x00\x4b\x03\x52\x03\x55\x03\x7c\x02\x9c\x01\x64\x00\x63\x00\x5a\x03\xb3\x00\x74\x00\x07\x00\xb4\x00\x07\x01\x6b\x00\x6c\x00\x6d\x00\x57\x03\x09\x00\x5e\x03\x4f\x00\x50\x00\x5b\x03\xd0\x00\x75\x00\x61\x03\xd1\x00\x69\x03\xb5\x00\xb6\x00\xb7\x00\xb8\x00\x98\x02\xd1\x00\xa0\x02\xae\x00\xaf\x00\x9d\x03\xa1\x02\xa2\x02\xb4\x02\xb1\x00\x64\x00\x98\x02\x9e\x01\x67\x00\x41\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\xbe\x02\xef\xfd\xb2\x02\x72\x00\xbf\x02\x63\x00\x73\x00\xc7\x02\xc1\x02\x47\x00\xca\x02\xc2\x02\xae\x00\xaf\x00\xad\x02\xcb\x02\xe7\x01\xcc\x02\xb1\x00\x64\x00\x63\x00\x9e\x01\x67\x00\xcd\x02\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x74\x00\x07\x00\x08\x00\xd0\x02\xd1\x02\xdf\x02\xe5\x02\xec\x02\x09\x00\x72\x00\x4f\x00\x50\x00\x73\x00\xfd\x02\x75\x00\x47\x00\xe6\x02\x17\x02\x17\x02\xf7\x02\x01\x03\xff\x02\x64\x00\xa4\x02\x66\x00\x67\x00\x03\x03\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x08\x03\x26\x02\xb3\x00\x74\x00\x07\x00\xb4\x00\x72\x00\x28\x02\x2d\x02\x73\x00\x2f\x02\x09\x00\x47\x00\x4f\x00\x50\x00\x31\x02\xa5\x01\x75\x00\x57\x03\xa6\x02\xa7\x02\xb5\x00\xb6\x00\xb7\x00\xb8\x00\xa8\x02\x34\x02\x3c\x02\xea\x01\xb4\x03\xae\x03\x48\x02\xb3\x00\x74\x00\x07\x00\xb4\x00\x3e\x00\x56\x02\x52\x02\x72\x00\x64\x00\x09\x00\x73\x00\x4f\x00\x50\x00\x47\x00\xf5\x00\x75\x00\x4e\x02\x6c\x00\x6d\x00\xb5\x00\xb6\x00\xb7\x00\xb8\x00\x64\x00\xe8\x00\xe9\x00\x67\x00\x63\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x74\x00\x07\x00\x08\x00\x59\x00\xf6\x00\xf7\x00\x5c\x02\xb3\x03\x09\x00\x5b\x00\x4f\x00\x50\x00\x6d\x02\x6f\x02\x75\x00\x7f\x02\x71\x02\xb4\x03\x74\x02\x7c\x02\x83\x02\x3f\x00\x84\x02\x85\x02\x72\x00\x40\x00\x86\x02\x73\x00\x8e\x02\x3f\x01\x47\x00\x92\x02\xbe\x00\x61\x01\x94\x02\xaf\x03\xb0\x03\xd7\x01\x95\x02\x72\x00\x6e\x01\xb1\x03\x73\x00\x2c\x00\x2d\x00\x47\x00\x6f\x01\xec\x00\x75\x01\x76\x01\x78\x01\x74\x00\x07\x00\x08\x00\x77\x01\x7b\x01\x81\x01\x7c\x01\xed\x00\x09\x00\xee\x00\x4f\x00\x50\x00\x83\x01\x9a\x01\x75\x00\x74\x00\x07\x00\x08\x00\xd9\x01\xef\x00\xf8\x00\xd3\x01\xfa\x00\x09\x00\x4e\x00\x4f\x00\x50\x00\xfb\x00\x52\x00\x75\x00\x82\x01\x84\x01\xfc\x00\x86\x01\x12\x02\x87\x01\xa5\x01\x63\x00\xa6\x01\x89\x01\x64\x00\xe8\x00\xe9\x00\x67\x00\x8a\x01\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x9c\x01\x54\x00\xab\x01\xac\x01\xf6\x00\xf7\x00\xad\x01\xb1\x01\xb2\x01\xb6\x01\xb1\x01\x55\x00\x56\x00\x57\x00\x22\x00\x86\x01\xdc\xfd\xbc\x01\x58\x00\x87\x01\xbd\x01\x50\x01\x22\x00\xc3\x01\xc6\x01\xfc\x01\xfd\x01\xc8\x01\x26\x00\x27\x00\xff\x00\xca\x01\xea\x01\xce\x01\x43\x01\xcf\x01\xf5\x00\x45\x01\xe7\x01\x72\x00\x5e\x00\x5f\x00\x73\x00\xf8\x01\xf9\x01\x47\x00\xfb\x01\xec\x00\xfa\x01\xf0\xfd\xff\x01\x04\x02\x06\x02\x28\x00\x08\x02\x07\x02\xd5\x00\xff\xff\xed\x00\x0d\x01\xee\x00\x28\x00\x0e\x01\x1d\x01\x1e\x01\xfb\x01\x74\x00\x07\x00\x08\x00\xff\xff\xef\x00\xf8\x00\xf9\x00\xfa\x00\x09\x00\x4e\x00\x4f\x00\x50\x00\xfb\x00\x52\x00\x75\x00\x63\x00\x0f\x01\xfc\x00\x64\x00\xe8\x00\xe9\x00\x67\x00\x15\x01\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x1f\x01\x4f\xfe\x06\x01\x2b\x01\xea\x00\xeb\x00\xff\xff\x4b\x01\x50\x01\x22\x00\xff\xff\x5a\x01\xfc\x01\xfd\x01\xff\xff\x26\x00\x27\x00\x2a\x00\x2b\x00\x34\x03\x2c\x00\x2d\x00\x52\x01\x39\x01\xbe\x00\x2a\x00\x2b\x00\x5d\x01\x2c\x00\x2d\x00\x2e\x00\x35\x03\x2f\x00\x54\x01\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x72\x00\x2f\x00\x00\x00\x73\x00\x30\x00\x00\x00\x47\x00\x00\x00\xec\x00\x28\x00\x00\x00\x00\x00\x30\x00\x00\x00\x00\x00\xf9\x02\x00\x00\x00\x00\x00\x00\xed\x00\x00\x00\xee\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x74\x00\x07\x00\x08\x00\x00\x00\xef\x00\xf0\x00\x00\x00\xf1\x00\x09\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x75\x00\x63\x00\x00\x00\xf2\x00\x64\x00\xe8\x00\xe9\x00\x67\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x55\x00\x56\x00\x57\x00\x00\x00\xff\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x01\x00\x00\x54\x00\x2a\x00\x2b\x00\x01\x01\x2c\x00\x2d\x00\x32\x01\x00\x00\x00\x00\x00\x00\x55\x00\x56\x00\x57\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x58\x00\x5e\x00\x40\x01\x00\x00\x00\x00\x61\x00\x41\x01\x00\x00\x00\x00\x00\x00\x30\x00\x72\x00\xff\x00\x00\x00\x73\x00\x00\x00\x00\x00\x47\x00\xf5\x00\xec\x00\x00\x00\x00\x00\x5e\x00\x5f\x00\x00\x00\x00\x00\x61\x00\x62\x00\x00\x00\x00\x00\xed\x00\x00\x00\xee\x00\x00\x00\x00\x00\x01\x02\x00\x00\x00\x00\x74\x00\x07\x00\x08\x00\x00\x00\xef\x00\xf0\x00\x00\x00\xf1\x00\x09\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x75\x00\x63\x00\x00\x00\x00\x00\x64\x00\xe8\x00\xe9\x00\x67\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x01\x22\x01\x00\x00\x22\x00\x03\x01\x04\x01\xfc\x01\xfd\x01\x22\x00\x26\x00\x27\x00\xc4\x01\x00\x00\x24\x01\x00\x00\x50\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4a\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x00\x00\x4e\x00\x00\x00\x00\x00\x51\x00\x52\x00\x00\x00\x72\x00\x00\x00\x00\x00\x73\x00\x00\x00\x00\x00\x47\x00\x28\x00\xec\x00\x00\x00\x00\x00\x00\x00\x28\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xed\x00\x00\x00\xee\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x74\x00\x07\x00\x08\x00\x00\x00\xef\x00\xf0\x00\x00\x00\xf1\x00\x09\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x75\x00\x63\x00\x00\x00\x00\x00\x64\x00\xe8\x00\xe9\x00\x67\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb9\x01\x00\x00\x00\x00\x5c\x02\x00\x00\x00\x00\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x2a\x00\x2b\x00\xf7\x02\x2c\x00\x2d\x00\x52\x01\x39\x01\x00\x00\x2e\x00\x00\x00\x2f\x00\x00\x00\x00\x00\x2e\x00\xf8\x02\x2f\x00\x54\x01\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x00\x00\x72\x00\x00\x00\x30\x00\x73\x00\x00\x00\x00\x00\x47\x00\x00\x00\xec\x00\x00\x00\x2e\x01\xf9\x00\x4d\x00\xf9\x02\x4e\x00\x00\x00\x00\x00\x2f\x01\x52\x00\xed\x00\x00\x00\xee\x00\x30\x01\x00\x00\x00\x00\x00\x00\x00\x00\x74\x00\x07\x00\x08\x00\x00\x00\xef\x00\xf0\x00\x00\x00\xf1\x00\x09\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x75\x00\x63\x00\x00\x00\x00\x00\x64\x00\xe8\x00\xe9\x00\x67\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb9\x01\x00\x00\x00\x00\xba\x01\x00\x00\x00\x00\x00\x00\x22\x00\x37\x01\x00\x00\x24\x00\x25\x00\x00\x00\x26\x00\x27\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x17\x02\x18\x02\x00\x00\x00\x00\x00\x00\x22\x00\x90\x01\x19\x02\x1a\x02\x25\x00\x1b\x02\x1c\x02\x27\x00\x00\x00\x72\x00\x00\x00\x00\x00\x73\x00\x00\x00\x00\x00\x47\x00\x00\x00\xec\x00\x00\x00\x00\x00\x28\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xed\x00\x00\x00\xee\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x74\x00\x07\x00\x08\x00\x28\x00\xef\x00\xf0\x00\x00\x00\xf1\x00\x09\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x75\x00\x63\x00\x00\x00\x00\x00\x64\x00\xe8\x00\xe9\x00\x67\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5a\x02\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x38\x01\x39\x01\x00\x00\x00\x00\x00\x00\x1d\x02\x00\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x3a\x01\x00\x00\x00\x00\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x72\x00\x30\x00\x00\x00\x73\x00\x00\x00\x00\x00\x47\x00\x2e\x00\xec\x00\x2f\x00\x3b\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xed\x00\x30\x00\xee\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x74\x00\x07\x00\x08\x00\x00\x00\xef\x00\xf0\x00\x00\x00\xf1\x00\x09\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x75\x00\x63\x00\x00\x00\x00\x00\x64\x00\x5e\x02\xe9\x00\x67\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x02\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\x22\x00\x33\x01\x00\x00\x24\x00\x25\x00\x00\x00\x26\x00\x27\x00\x55\x00\x56\x00\x57\x00\x34\x01\x00\x00\x00\x00\xcd\x02\x58\x00\x00\x00\x89\x03\x00\x00\x22\x00\x90\x01\x00\x00\x24\x00\x25\x00\x00\x00\x26\x00\x27\x00\xff\x00\x72\x00\x00\x00\x00\x00\x73\x00\x00\x00\xf5\x00\x47\x00\x00\x00\xec\x00\x5e\x00\x5f\x00\x28\x00\x00\x00\x61\x00\x62\x00\x00\x00\x00\x00\x00\x00\x00\x00\xed\x00\x00\x00\xee\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x74\x00\x07\x00\x08\x00\x28\x00\xef\x00\xf0\x00\x00\x00\xf1\x00\x09\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x75\x00\x63\x00\x00\x00\x00\x00\x64\x00\x67\x02\xe9\x00\x67\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5f\x02\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x29\x00\x22\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x00\x00\x00\x00\x50\x01\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x72\x00\x30\x00\x00\x00\x73\x00\x00\x00\x00\x00\x47\x00\x2e\x00\xec\x00\x2f\x00\x35\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xed\x00\x30\x00\xee\x00\x00\x00\x00\x00\x00\x00\x28\x00\x00\x00\x74\x00\x07\x00\x08\x00\x00\x00\xef\x00\xf0\x00\x00\x00\xf1\x00\x09\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x75\x00\x63\x00\x00\x00\x00\x00\x64\x00\xe8\x00\xe9\x00\x67\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x02\x00\x00\xf4\x01\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x90\x01\x54\x00\x24\x00\x25\x00\x00\x00\x26\x00\x27\x00\xaa\x03\x01\x04\x00\x00\x00\x00\x55\x00\x56\x00\x57\x00\xfb\x03\x00\x00\x2a\x00\x2b\x00\x58\x00\x2c\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x72\x00\x00\x00\x2e\x00\x73\x00\x2f\x00\x00\x00\x47\x00\x63\x00\xec\x00\x00\x00\x5c\x00\x28\x00\x00\x00\x5e\x00\x5f\x00\x30\x00\x00\x00\x61\x00\x62\x00\xed\x00\x0f\x02\xee\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x74\x00\x07\x00\x08\x00\x00\x00\xef\x00\xf0\x00\x00\x00\xf1\x00\x09\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x75\x00\x00\x00\x00\x00\x00\x00\x64\x00\x65\x00\x66\x00\x67\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x29\x00\x00\x00\x00\x00\x00\x00\x63\x00\x60\x02\x61\x02\x62\x02\x63\x02\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x64\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x72\x00\x30\x00\x00\x00\x73\x00\x00\x00\x00\x00\x47\x00\x00\x00\x00\x00\x00\x00\x64\x00\x65\x00\x66\x00\x67\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x74\x00\x07\x00\x08\x00\x00\x00\x68\x02\x61\x02\x62\x02\x63\x02\x09\x00\x63\x00\x4f\x00\x50\x00\x00\x00\x00\x00\x75\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x72\x00\x00\x00\x00\x00\x73\x00\x00\x00\x00\x00\x47\x00\x00\x00\x64\x00\x65\x00\x66\x00\x67\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x74\x00\x07\x00\x08\x00\x4e\x03\x62\x02\x63\x02\x00\x00\x00\x00\x09\x00\x00\x00\x4f\x00\x50\x00\x63\x00\x00\x00\x75\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x72\x00\x00\x00\x00\x00\x73\x00\x00\x00\x00\x00\x47\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x65\x00\x66\x00\x67\x00\x63\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x74\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x00\x00\x4f\x00\x50\x00\x22\x00\x00\x00\x75\x00\xdb\x03\xef\x02\x00\x00\x00\x00\x50\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf0\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x72\x00\x00\x00\x00\x00\x73\x00\x00\x00\x00\x00\x47\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\x00\x28\x00\x64\x00\xa4\x02\x66\x00\x67\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x74\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x00\x00\x4f\x00\x50\x00\x00\x00\x00\x00\x75\x00\xa5\x02\xa6\x02\xa7\x02\x00\x00\x00\x00\x00\x00\x00\x00\xa8\x02\x00\x00\x00\x00\x64\x00\xa4\x02\x66\x00\x67\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x72\x00\x00\x00\x00\x00\x73\x00\x00\x00\x63\x00\x47\x00\x00\x00\x2a\x00\x2b\x00\x51\x01\x2c\x00\x2d\x00\x52\x01\x39\x01\x00\x00\x00\x00\x00\x00\xaa\x02\xa6\x02\xa7\x02\x2e\x00\x53\x01\x2f\x00\x54\x01\xa8\x02\x00\x00\x74\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x09\x00\x00\x00\x4f\x00\x50\x00\x72\x00\x00\x00\x75\x00\x73\x00\x00\x00\x00\x00\x47\x00\x64\x00\x65\x00\x66\x00\x67\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x74\x00\x07\x00\x08\x00\x22\x01\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x00\x00\x4f\x00\x50\x00\x00\x00\x23\x01\x75\x00\x24\x01\x6e\x00\x00\x00\x00\x00\x00\x00\xb0\x02\x00\x00\x00\x00\xa7\x01\x71\x00\x4a\x00\x00\x00\x4b\x00\x4c\x00\x4d\x00\x72\x00\x4e\x00\x00\x00\x73\x00\x51\x00\x52\x00\x47\x00\x64\x00\x65\x00\x66\x00\x67\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x74\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\xee\x02\xef\x02\x09\x00\x00\x00\x4f\x00\x50\x00\x00\x00\x00\x00\x75\x00\x00\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf0\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x72\x00\x00\x00\x00\x00\x73\x00\x00\x00\x00\x00\x47\x00\x64\x00\x65\x00\x66\x00\x67\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x74\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x00\x00\x4f\x00\x50\x00\x00\x00\x00\x00\x75\x00\x00\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x71\x02\x00\x00\x00\x00\xa7\x01\x71\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x72\x00\x00\x00\x00\x00\x73\x00\x00\x00\x00\x00\x47\x00\x64\x00\x65\x00\x66\x00\x67\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x74\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x00\x00\x4f\x00\x50\x00\x00\x00\x00\x00\x75\x00\x00\x00\x6e\x00\x00\x00\x00\x00\x00\x00\xa6\x01\x00\x00\x00\x00\xa7\x01\x71\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x72\x00\x00\x00\x00\x00\x73\x00\x00\x00\x00\x00\x47\x00\x64\x00\x65\x00\x66\x00\x67\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x74\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x00\x00\x4f\x00\x50\x00\x00\x00\x00\x00\x75\x00\x00\x00\x6e\x00\x00\x00\x00\x00\x00\x00\xa9\x01\x00\x00\x00\x00\xa7\x01\x71\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x72\x00\x00\x00\x00\x00\x73\x00\x00\x00\x00\x00\x47\x00\x64\x00\x65\x00\x66\x00\x67\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\x00\x00\x00\x00\x00\x74\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x00\x00\x4f\x00\x50\x00\x00\x00\x00\x00\x75\x00\x00\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\x00\x70\x00\x71\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x72\x00\x00\x00\x00\x00\x73\x00\x00\x00\x00\x00\x47\x00\x64\x00\x65\x00\x66\x00\x67\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\x00\x00\x00\x00\x00\x74\x00\x07\x00\x08\x00\x00\x00\x4c\x03\x00\x00\x00\x00\x00\x00\x09\x00\x00\x00\x4f\x00\x50\x00\x00\x00\x00\x00\x75\x00\x00\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4d\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x72\x00\x00\x00\x00\x00\x73\x00\x00\x00\x00\x00\x47\x00\x00\x00\x64\x00\xa4\x02\x66\x00\x67\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\x00\x00\x00\x00\x00\x74\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x00\x00\x4f\x00\x50\x00\x74\x03\x54\x00\x75\x00\x00\x00\x00\x00\xa8\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x72\x00\x00\x00\x63\x00\x73\x00\x00\x00\x00\x00\x47\x00\x64\x00\x65\x00\x66\x00\x67\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x5c\x00\x00\x00\x00\x00\x5e\x00\x5f\x00\x00\x00\x00\x00\x61\x00\x62\x00\x74\x00\x07\x00\x08\x00\x00\x00\x00\x00\x63\x00\x00\x00\x00\x00\x09\x00\x00\x00\x4f\x00\x50\x00\x00\x00\x00\x00\x75\x00\x00\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc9\x01\x00\x00\x00\x00\xa2\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x72\x00\x00\x00\x00\x00\x73\x00\x00\x00\x63\x00\x47\x00\x64\x00\x13\x04\x66\x00\x67\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x01\x02\x42\xff\x00\x00\x42\xff\x74\x00\x07\x00\x08\x00\x00\x00\x00\x00\x55\x00\x56\x00\x57\x00\x09\x00\x00\x00\x4f\x00\x50\x00\x58\x00\x00\x00\x75\x00\x00\x00\x64\x00\xed\x03\x66\x00\x67\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x72\x00\x5c\x00\x00\x00\x73\x00\x5e\x00\x5f\x00\x47\x00\x00\x00\x61\x00\x62\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\xd4\x03\x66\x00\x67\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x74\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x72\x00\x4f\x00\x50\x00\x73\x00\x63\x00\x75\x00\x47\x00\x00\x00\x00\x00\x00\x00\x64\x00\xd9\x03\x66\x00\x67\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x74\x00\x07\x00\x08\x00\x72\x00\x00\x00\x00\x00\x73\x00\x63\x00\x09\x00\x47\x00\x4f\x00\x50\x00\x00\x00\x00\x00\x75\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x74\x00\x07\x00\x08\x00\x72\x00\x00\x00\x00\x00\x73\x00\x00\x00\x09\x00\x47\x00\x4f\x00\x50\x00\x00\x00\x63\x00\x75\x00\x64\x00\xda\x03\x66\x00\x67\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x74\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x00\x00\x4f\x00\x50\x00\x00\x00\x63\x00\x75\x00\x64\x00\x7d\x03\x66\x00\x67\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x72\x00\x00\x00\x00\x00\x73\x00\x00\x00\x00\x00\x47\x00\x00\x00\x63\x00\x00\x00\x64\x00\x7e\x03\x66\x00\x67\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x74\x00\x07\x00\x08\x00\x72\x00\x00\x00\x00\x00\x73\x00\x00\x00\x09\x00\x47\x00\x4f\x00\x50\x00\x00\x00\x00\x00\x75\x00\x00\x00\x00\x00\x63\x00\x00\x00\x64\x00\x7f\x03\x66\x00\x67\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x74\x00\x07\x00\x08\x00\x72\x00\x00\x00\x00\x00\x73\x00\x00\x00\x09\x00\x47\x00\x4f\x00\x50\x00\x00\x00\x00\x00\x75\x00\x00\x00\x00\x00\x63\x00\x00\x00\x64\x00\xa1\x03\x66\x00\x67\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x74\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x72\x00\x4f\x00\x50\x00\x73\x00\x00\x00\x75\x00\x47\x00\x00\x00\x63\x00\x00\x00\x64\x00\x4b\x03\x66\x00\x67\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x74\x00\x07\x00\x08\x00\x72\x00\x00\x00\x00\x00\x73\x00\x00\x00\x09\x00\x47\x00\x4f\x00\x50\x00\x00\x00\x00\x00\x75\x00\x00\x00\x00\x00\x63\x00\x00\x00\x64\x00\x52\x03\x66\x00\x67\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x74\x00\x07\x00\x08\x00\x72\x00\x00\x00\x00\x00\x73\x00\x00\x00\x09\x00\x47\x00\x4f\x00\x50\x00\x00\x00\x00\x00\x75\x00\x00\x00\x00\x00\x63\x00\x00\x00\x64\x00\x53\x03\x66\x00\x67\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x74\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x72\x00\x4f\x00\x50\x00\x73\x00\x00\x00\x75\x00\x47\x00\x00\x00\x63\x00\x00\x00\x64\x00\xa3\x02\x66\x00\x67\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x74\x00\x07\x00\x08\x00\x72\x00\x00\x00\x00\x00\x73\x00\x00\x00\x09\x00\x47\x00\x4f\x00\x50\x00\x00\x00\x00\x00\x75\x00\x00\x00\x00\x00\x63\x00\x00\x00\x64\x00\xab\x02\x66\x00\x67\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x74\x00\x07\x00\x08\x00\x72\x00\x00\x00\x00\x00\x73\x00\x00\x00\x09\x00\x47\x00\x4f\x00\x50\x00\x00\x00\x00\x00\x75\x00\x00\x00\x00\x00\x63\x00\x00\x00\x64\x00\xac\x02\x66\x00\x67\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x74\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x72\x00\x4f\x00\x50\x00\x73\x00\x00\x00\x75\x00\x47\x00\x00\x00\x63\x00\x00\x00\x64\x00\xb5\x02\x66\x00\x67\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x74\x00\x07\x00\x08\x00\x72\x00\x00\x00\x00\x00\x73\x00\x00\x00\x09\x00\x47\x00\x4f\x00\x50\x00\x00\x00\x00\x00\x75\x00\x00\x00\x00\x00\x63\x00\x00\x00\x64\x00\xf1\x02\x66\x00\x67\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x74\x00\x07\x00\x08\x00\x72\x00\x00\x00\x00\x00\x73\x00\x00\x00\x09\x00\x47\x00\x4f\x00\x50\x00\x00\x00\x00\x00\x75\x00\x00\x00\x00\x00\x63\x00\x00\x00\x64\x00\x66\x02\x66\x00\x67\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x74\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x72\x00\x4f\x00\x50\x00\x73\x00\x00\x00\x75\x00\x47\x00\x00\x00\x63\x00\x00\x00\x64\x00\x69\x02\x66\x00\x67\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x74\x00\x07\x00\x08\x00\x72\x00\x00\x00\x00\x00\x73\x00\x00\x00\x09\x00\x47\x00\x4f\x00\x50\x00\x00\x00\x00\x00\x75\x00\x00\x00\x00\x00\x63\x00\x00\x00\x64\x00\x6f\x02\x66\x00\x67\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x74\x00\x07\x00\x08\x00\x72\x00\x00\x00\x00\x00\x73\x00\x00\x00\x09\x00\x47\x00\x4f\x00\x50\x00\x00\x00\x00\x00\x75\x00\x00\x00\x00\x00\x63\x00\x00\x00\x64\x00\x75\x02\x66\x00\x67\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x74\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x72\x00\x4f\x00\x50\x00\x73\x00\x00\x00\x75\x00\x47\x00\x00\x00\x63\x00\x00\x00\x64\x00\x76\x02\x66\x00\x67\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x74\x00\x07\x00\x08\x00\x72\x00\x00\x00\x00\x00\x73\x00\x00\x00\x09\x00\x47\x00\x4f\x00\x50\x00\x00\x00\x00\x00\x75\x00\x00\x00\x00\x00\x63\x00\x00\x00\x64\x00\x8b\x01\x66\x00\x67\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x74\x00\x07\x00\x08\x00\x72\x00\x00\x00\x00\x00\x73\x00\x00\x00\x09\x00\x47\x00\x4f\x00\x50\x00\x00\x00\x00\x00\x75\x00\x00\x00\x00\x00\x63\x00\x00\x00\x64\x00\x8c\x01\x66\x00\x67\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x74\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x72\x00\x4f\x00\x50\x00\x73\x00\x00\x00\x75\x00\x47\x00\x00\x00\x63\x00\x00\x00\x64\x00\x8d\x01\x66\x00\x67\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x74\x00\x07\x00\x08\x00\x72\x00\x00\x00\x00\x00\x73\x00\x00\x00\x09\x00\x47\x00\x4f\x00\x50\x00\x00\x00\x00\x00\x75\x00\x00\x00\x00\x00\x63\x00\x00\x00\x64\x00\x8e\x01\x66\x00\x67\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x74\x00\x07\x00\x08\x00\x72\x00\x00\x00\x00\x00\x73\x00\x00\x00\x09\x00\x47\x00\x4f\x00\x50\x00\x00\x00\x00\x00\x75\x00\x00\x00\x00\x00\x63\x00\x00\x00\x64\x00\x97\x01\x66\x00\x67\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x74\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x72\x00\x4f\x00\x50\x00\x73\x00\x00\x00\x75\x00\x47\x00\x00\x00\x63\x00\x00\x00\x64\x00\xde\x00\x66\x00\x67\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x74\x00\x07\x00\x08\x00\x72\x00\x00\x00\x00\x00\x73\x00\x00\x00\x09\x00\x47\x00\x4f\x00\x50\x00\x00\x00\x00\x00\x75\x00\x00\x00\x00\x00\x63\x00\x00\x00\x64\x00\xe4\x00\x66\x00\x67\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x74\x00\x07\x00\x08\x00\x72\x00\x00\x00\x00\x00\x73\x00\x00\x00\x09\x00\x47\x00\x4f\x00\x50\x00\x00\x00\x00\x00\x75\x00\x00\x00\x00\x00\x63\x00\x00\x00\x64\x00\x19\x01\x66\x00\x67\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x74\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x72\x00\x4f\x00\x50\x00\x73\x00\x00\x00\x75\x00\x47\x00\x00\x00\x63\x00\x00\x00\x64\x00\x1b\x01\x66\x00\x67\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x74\x00\x07\x00\x08\x00\x72\x00\x00\x00\x00\x00\x73\x00\x00\x00\x09\x00\x47\x00\x4f\x00\x50\x00\x00\x00\x00\x00\x75\x00\x00\x00\x00\x00\x63\x00\x00\x00\x64\x00\x20\x01\x66\x00\x67\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x74\x00\x07\x00\x08\x00\x72\x00\x00\x00\x00\x00\x73\x00\x00\x00\x09\x00\x47\x00\x4f\x00\x50\x00\x00\x00\x00\x00\x75\x00\x00\x00\x00\x00\x63\x00\x00\x00\x64\x00\x21\x01\x66\x00\x67\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x74\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x72\x00\x4f\x00\x50\x00\x73\x00\x00\x00\x75\x00\x47\x00\x00\x00\x63\x00\x00\x00\x64\x00\x32\x01\x66\x00\x67\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x74\x00\x07\x00\x08\x00\x72\x00\x00\x00\x00\x00\x73\x00\x00\x00\x09\x00\x47\x00\x4f\x00\x50\x00\x00\x00\x00\x00\x75\x00\x00\x00\x00\x00\x63\x00\x00\x00\x64\x00\x00\x00\x44\x03\x67\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x74\x00\x07\x00\x08\x00\x72\x00\x00\x00\x00\x00\x73\x00\x00\x00\x09\x00\x47\x00\x4f\x00\x50\x00\x00\x00\x00\x00\x75\x00\x00\x00\x00\x00\x63\x00\x00\x00\x64\x00\x00\x00\xc1\x01\x67\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x74\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x72\x00\x4f\x00\x50\x00\x73\x00\x00\x00\x75\x00\x47\x00\x00\x00\x00\x00\x00\x00\x64\x00\x63\x00\xe3\x00\x67\x00\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x74\x00\x07\x00\x08\x00\x72\x00\x00\x00\x00\x00\x73\x00\x00\x00\x09\x00\x47\x00\x4f\x00\x50\x00\x00\x00\x00\x00\x75\x00\x00\x00\x00\x00\x63\x00\x00\x00\x64\x00\x00\x00\x00\x00\x91\x01\x00\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x74\x00\x07\x00\x08\x00\x72\x00\x00\x00\x63\x00\x73\x00\x00\x00\x09\x00\x47\x00\x4f\x00\x50\x00\x00\x00\x00\x00\x75\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x01\x6c\x00\x6d\x00\x74\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x72\x00\x4f\x00\x50\x00\x73\x00\x00\x00\x75\x00\x47\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\xae\x01\x6d\x02\x00\x00\x63\x00\x09\x01\x6c\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x74\x00\x07\x00\x08\x00\x72\x00\x00\x00\x00\x00\x73\x00\x00\x00\x09\x00\x47\x00\x4f\x00\x50\x00\x00\x00\x63\x00\x75\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\xae\x01\xaf\x01\x00\x00\x00\x00\x09\x01\x6c\x00\x6d\x00\x74\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x72\x00\x64\x00\x09\x00\x73\x00\x4f\x00\x50\x00\x47\x00\x00\x00\x75\x00\x4f\x02\x6c\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x0a\x01\x00\x00\x00\x00\x00\x00\x98\x01\x6c\x00\x6d\x00\x74\x00\x07\x00\x08\x00\x00\x00\x63\x00\x00\x00\x72\x00\x00\x00\x09\x00\x73\x00\x4f\x00\x50\x00\x47\x00\x00\x00\x75\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\x00\x00\x00\x72\x00\x00\x00\x00\x00\x73\x00\x64\x00\x00\x00\x47\x00\x00\x00\x00\x00\x74\x00\x07\x00\x08\x00\xad\x01\x6c\x00\x6d\x00\x72\x00\x63\x00\x09\x00\x73\x00\x4f\x00\x50\x00\x47\x00\x00\x00\x75\x00\x64\x00\x00\x00\x00\x00\x74\x00\x07\x00\x08\x00\x00\x00\x63\x00\x1f\x01\x6c\x00\x6d\x00\x09\x00\x00\x00\x4f\x00\x50\x00\x00\x00\x00\x00\x75\x00\x74\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x00\x00\x4f\x00\x50\x00\x72\x00\x00\x00\x75\x00\x73\x00\x00\x00\x00\x00\x47\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\x00\x00\x00\x00\x00\x00\x00\x72\x00\x00\x00\x00\x00\x73\x00\x64\x00\x00\x00\x47\x00\x74\x00\x07\x00\x08\x00\x00\x00\x00\x00\xd4\x01\x6c\x00\x6d\x00\x09\x00\x00\x00\x4f\x00\x50\x00\x00\x00\x00\x00\x75\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x74\x00\x07\x00\x08\x00\x06\x01\x6c\x00\x6d\x00\x00\x00\x00\x00\x09\x00\x00\x00\x4f\x00\x50\x00\x00\x00\x64\x00\x75\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x01\x6c\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x72\x00\x64\x00\x00\x00\x73\x00\x00\x00\x00\x00\x47\x00\x00\x00\x00\x00\x12\x01\x6c\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x72\x00\x00\x00\x00\x00\x73\x00\x00\x00\x00\x00\x47\x00\x00\x00\x00\x00\x74\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x72\x00\x4f\x00\x50\x00\x73\x00\x64\x00\x75\x00\x47\x00\x00\x00\x00\x00\x74\x00\x07\x00\x08\x00\x1f\x01\x6c\x00\x6d\x00\x72\x00\x00\x00\x09\x00\x73\x00\x4f\x00\x50\x00\x47\x00\x54\x00\x75\x00\x85\x03\x00\x00\x00\x00\x74\x00\x07\x00\x08\x00\x00\x00\x00\x00\x55\x00\x56\x00\x57\x00\x09\x00\x00\x00\x4f\x00\x50\x00\x58\x00\x00\x00\x75\x00\x74\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x00\x00\x4f\x00\x50\x00\x72\x00\x00\x00\x75\x00\x73\x00\x5c\x00\x00\x00\x47\x00\x5e\x00\x5f\x00\x00\x00\x00\x00\x61\x00\x62\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x74\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x00\x00\x4f\x00\x50\x00\x00\x00\x00\x00\x75\x00\x77\x00\x0b\x00\x78\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\x79\x00\x00\x00\x0c\x00\x7a\x00\xbe\x00\x00\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\x00\x00\xc4\x00\x00\x00\x0d\x00\x00\x00\xc5\x00\x00\x00\x7c\x00\x0e\x00\xc6\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x7d\x00\x15\x00\x16\x00\x17\x00\x18\x00\x7e\x00\x00\x00\x19\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\x00\x00\xca\x00\x80\x00\x81\x00\x82\x00\xcb\x00\xcc\x00\x00\x00\xcd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x85\x00\xce\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x00\x00\x88\x00\x00\x00\xcf\x00\x00\x00\x8a\x00\x00\x00\x8b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x5d\x00\x00\x00\x00\x00\x1c\x00\x60\x00\x00\x00\x00\x00\x1d\x00\x63\x00\x41\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\x96\x00\x97\x00\x98\x00\x99\x00\x00\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x45\x00\x77\x00\x0b\x00\x78\x00\xba\x00\xbb\x00\xbc\x00\xbd\x00\x79\x00\x00\x00\x0c\x00\x7a\x00\x00\x00\x00\x00\xbf\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\x00\x00\xc4\x00\x00\x00\x0d\x00\x00\x00\xc5\x00\x00\x00\x7c\x00\x0e\x00\xc6\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x7d\x00\x15\x00\x16\x00\x17\x00\x18\x00\x7e\x00\x00\x00\x19\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\x00\x00\xca\x00\x80\x00\x81\x00\x82\x00\xcb\x00\xcc\x00\x00\x00\xcd\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x85\x00\xce\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x00\x00\x88\x00\x00\x00\xcf\x00\x00\x00\x8a\x00\x00\x00\x8b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x5d\x00\x00\x00\x00\x00\x1c\x00\x60\x00\x00\x00\x00\x00\x1d\x00\x63\x00\x41\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\x96\x00\x97\x00\x98\x00\x99\x00\x00\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x45\x00\x77\x00\x0b\x00\x78\x00\x00\x00\x2f\x03\x00\x00\x00\x00\x79\x00\x00\x00\x0c\x00\x7a\x00\x00\x00\x00\x00\xbf\x00\xc0\x00\xc1\x00\x00\x00\xc3\x00\x00\x00\xc4\x00\x00\x00\x0d\x00\x00\x00\x30\x03\x00\x00\x7c\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x7d\x00\x15\x00\x16\x00\x17\x00\x18\x00\x7e\x00\x00\x00\x19\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\x00\x00\x00\x00\x80\x00\x81\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x85\x00\xce\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x00\x00\x88\x00\x00\x00\xcf\x00\x00\x00\x8a\x00\x00\x00\x8b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x5d\x00\x00\x00\x00\x00\x1c\x00\x60\x00\x00\x00\x00\x00\x1d\x00\x63\x00\x41\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\x96\x00\x97\x00\x98\x00\x99\x00\x00\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x45\x00\x77\x00\x0b\x00\x78\x00\x00\x00\x9f\x03\x00\x00\x00\x00\x79\x00\x00\x00\x0c\x00\x7a\x00\x00\x00\x00\x00\xbf\x00\xc0\x00\xc1\x00\x00\x00\xc3\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\xa0\x03\x00\x00\x7c\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x7d\x00\x15\x00\x16\x00\x17\x00\x18\x00\x7e\x00\x00\x00\x19\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\x00\x00\x00\x00\x80\x00\x81\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x85\x00\xce\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x00\x00\x88\x00\x00\x00\xcf\x00\x00\x00\x8a\x00\x00\x00\x8b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x5d\x00\x00\x00\x00\x00\x1c\x00\x60\x00\x00\x00\x00\x00\x1d\x00\x63\x00\x41\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\x96\x00\x97\x00\x98\x00\x99\x00\x00\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x45\x00\x77\x00\x0b\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x79\x00\x00\x00\x0c\x00\x7a\x00\x00\x00\x00\x00\xbf\x00\xc0\x00\xc1\x00\x00\x00\xc3\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x7d\x00\x15\x00\x16\x00\x17\x00\x18\x00\x7e\x00\x00\x00\x19\x00\x00\x00\x00\x00\xc7\x00\xc8\x00\xc9\x00\x00\x00\x00\x00\x80\x00\x81\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x85\x00\xce\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x00\x00\x88\x00\x00\x00\xcf\x00\x00\x00\x8a\x00\x00\x00\x8b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x5d\x00\x00\x00\x00\x00\x1c\x00\x60\x00\x00\x00\x00\x00\x1d\x00\x63\x00\x41\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\xd0\x00\xd1\x00\xd2\x00\xd3\x00\x96\x00\x97\x00\x98\x00\x99\x00\x00\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x45\x00\x77\x00\x0b\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x79\x00\x00\x00\x0c\x00\x7a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x7d\x00\x15\x00\x16\x00\x17\x00\x18\x00\x7e\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x81\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\x00\x00\x83\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x85\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x00\x00\x88\x00\x00\x00\x89\x00\x85\x01\x8a\x00\x00\x00\x8b\x00\x00\x00\x00\x00\x7a\x01\xf6\x00\x1b\x00\x5d\x00\x5e\x00\x5f\x00\x1c\x00\x60\x00\x61\x00\x62\x00\x1d\x00\x63\x00\x41\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x00\x00\x00\x00\x00\x00\x00\x00\x96\x00\x97\x00\x98\x00\x99\x00\x00\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x45\x00\x77\x00\x0b\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x79\x00\x00\x00\x0c\x00\x7a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x7d\x00\x15\x00\x16\x00\x17\x00\x18\x00\x7e\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x81\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\x00\x00\x83\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x85\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x00\x00\x88\x00\x00\x00\x89\x00\x00\x00\x8a\x00\x88\x01\x8b\x00\x00\x00\x00\x00\x7a\x01\xf6\x00\x1b\x00\x5d\x00\x5e\x00\x5f\x00\x1c\x00\x60\x00\x61\x00\x62\x00\x1d\x00\x63\x00\x41\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x00\x00\x00\x00\x00\x00\x00\x00\x96\x00\x97\x00\x98\x00\x99\x00\x00\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x45\x00\x77\x00\x0b\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x79\x00\x00\x00\x0c\x00\x7a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x7d\x00\x15\x00\x16\x00\x17\x00\x18\x00\x7e\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x81\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\x00\x00\x83\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\xfe\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x00\x00\x88\x00\x00\x00\x89\x00\xff\x00\x8a\x00\x00\x00\x8b\x00\x00\x00\x00\x00\xf5\x00\xf6\x00\x1b\x00\x5d\x00\x5e\x00\x5f\x00\x1c\x00\x60\x00\x61\x00\x62\x00\x1d\x00\x63\x00\x41\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x00\x00\x00\x00\x00\x00\x00\x00\x96\x00\x97\x00\x98\x00\x99\x00\x00\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x45\x00\x77\x00\x0b\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x79\x00\x00\x00\x0c\x00\x7a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x7d\x00\x15\x00\x16\x00\x17\x00\x18\x00\x7e\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x81\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\x00\x00\x83\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x85\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x00\x00\x88\x00\x00\x00\x89\x00\x00\x00\x8a\x00\xf4\x00\x8b\x00\x00\x00\x00\x00\xf5\x00\xf6\x00\x1b\x00\x5d\x00\x5e\x00\x5f\x00\x1c\x00\x60\x00\x61\x00\x62\x00\x1d\x00\x63\x00\x41\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x00\x00\x00\x00\x00\x00\x00\x00\x96\x00\x97\x00\x98\x00\x99\x00\x00\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x45\x00\x77\x00\x0b\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x79\x00\x00\x00\x0c\x00\x7a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x7d\x00\x15\x00\x16\x00\x17\x00\x18\x00\x7e\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x81\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\x00\x00\x83\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\xfe\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x00\x00\x88\x00\x00\x00\x89\x00\xff\x00\x8a\x00\x00\x00\x8b\x00\x00\x00\x00\x00\xf5\x00\xf6\x00\x1b\x00\x5d\x00\x5e\x00\x5f\x00\x1c\x00\x60\x00\x61\x00\x62\x00\x1d\x00\x63\x00\x41\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x00\x00\x00\x00\x00\x00\x00\x00\x96\x00\x97\x00\x98\x00\x99\x00\x00\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x45\x00\x77\x00\x0b\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x79\x00\x00\x00\x0c\x00\x7a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x7d\x00\x15\x00\x16\x00\x17\x00\x18\x00\x7e\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x81\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\x00\x00\x83\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x85\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x00\x00\x88\x00\x00\x00\x89\x00\x00\x00\x8a\x00\x00\x00\x8b\x00\x00\x00\x00\x00\x7a\x01\xf6\x00\x1b\x00\x5d\x00\x5e\x00\x5f\x00\x1c\x00\x60\x00\x61\x00\x62\x00\x1d\x00\x63\x00\x41\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x00\x00\x00\x00\x00\x00\x00\x00\x96\x00\x97\x00\x98\x00\x99\x00\x00\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x45\x00\x77\x00\x0b\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x79\x00\x00\x00\x0c\x00\x7a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x7d\x00\x15\x00\x16\x00\x17\x00\x18\x00\x7e\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x81\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\x00\x00\x83\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x85\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x06\x01\x88\x00\x00\x00\x89\x00\x00\x00\x8a\x00\x00\x00\x8b\x00\x00\x00\x00\x00\x00\x00\xf6\x00\x1b\x00\x5d\x00\x5e\x00\x5f\x00\x1c\x00\x60\x00\x61\x00\x62\x00\x1d\x00\x63\x00\x41\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x00\x00\x00\x00\x00\x00\x00\x00\x96\x00\x97\x00\x98\x00\x99\x00\x00\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x45\x00\x77\x00\x0b\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x79\x00\x00\x00\x0c\x00\x7a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x7d\x00\x15\x00\x16\x00\x17\x00\x18\x00\x7e\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x81\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\x00\x00\x83\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x85\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x00\x00\x88\x00\x00\x00\x89\x00\x00\x00\x8a\x00\x00\x00\x8b\x00\x00\x00\x00\x00\x00\x00\xf6\x00\x1b\x00\x5d\x00\x5e\x00\x5f\x00\x1c\x00\x60\x00\x61\x00\x62\x00\x1d\x00\x63\x00\x41\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x00\x00\x00\x00\x00\x00\x00\x00\x96\x00\x97\x00\x98\x00\x99\x00\x00\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x45\x00\x77\x00\x0b\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x79\x00\x00\x00\x0c\x00\x7a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7b\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x7d\x00\x15\x00\x16\x00\x17\x00\x18\x00\x7e\x00\x7f\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x81\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x85\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x00\x00\x88\x00\x00\x00\x89\x00\x00\x00\x8a\x00\x00\x00\x8b\x00\x00\x00\xa9\x01\x00\x00\x00\x00\x1b\x00\x5d\x00\x00\x00\x00\x00\x1c\x00\x60\x00\x00\x00\x00\x00\x1d\x00\x63\x00\x41\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x00\x00\x00\x00\x00\x00\x00\x00\x96\x00\x97\x00\x98\x00\x99\x00\x00\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x45\x00\x77\x00\x0b\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x79\x00\x00\x00\x0c\x00\x7a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7b\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x66\x02\x00\x00\x00\x00\x7c\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x7d\x00\x15\x00\x16\x00\x17\x00\x18\x00\x7e\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x81\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x85\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x00\x00\x88\x00\x00\x00\x89\x00\x00\x00\x8a\x00\x00\x00\x8b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x5d\x00\x00\x00\x00\x00\x1c\x00\x60\x00\x00\x00\x00\x00\x1d\x00\x63\x00\x41\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x00\x00\x00\x00\x00\x00\x00\x00\x96\x00\x97\x00\x98\x00\x99\x00\x00\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x45\x00\x77\x00\x0b\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x79\x00\x00\x00\x0c\x00\x7a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x7d\x00\x15\x00\x16\x00\x17\x00\x18\x00\x7e\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x81\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x85\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x00\x00\x88\x00\x00\x00\x89\x00\x00\x00\x8a\x00\x00\x00\x8b\x00\x00\x00\xaa\x02\x00\x00\x00\x00\x1b\x00\x5d\x00\x00\x00\x00\x00\x1c\x00\x60\x00\x00\x00\x00\x00\x1d\x00\x63\x00\x41\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x00\x00\x00\x00\x00\x00\x00\x00\x96\x00\x97\x00\x98\x00\x99\x00\x00\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x45\x00\x77\x00\x0b\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x79\x00\x00\x00\x0c\x00\x7a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7b\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x66\x02\x00\x00\x00\x00\x7c\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x7d\x00\x15\x00\x16\x00\x17\x00\x18\x00\x7e\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x81\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x85\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x00\x00\x88\x00\x00\x00\x89\x00\x00\x00\x8a\x00\x00\x00\x8b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x5d\x00\x00\x00\x00\x00\x1c\x00\x60\x00\x00\x00\x00\x00\x1d\x00\x63\x00\x41\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x00\x00\x00\x00\x00\x00\x00\x00\x96\x00\x97\x00\x98\x00\x99\x00\x00\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x45\x00\x77\x00\x0b\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x79\x00\x00\x00\x0c\x00\x7a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7b\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x7d\x00\x15\x00\x16\x00\x17\x00\x18\x00\x7e\x00\x7f\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x81\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x85\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x00\x00\x88\x00\x00\x00\x89\x00\x00\x00\x8a\x00\x00\x00\x8b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x5d\x00\x00\x00\x00\x00\x1c\x00\x60\x00\x00\x00\x00\x00\x1d\x00\x63\x00\x41\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x00\x00\x00\x00\x00\x00\x00\x00\x96\x00\x97\x00\x98\x00\x99\x00\x00\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x45\x00\x77\x00\x0b\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x79\x00\x00\x00\x0c\x00\x7a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7b\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x7d\x00\x15\x00\x16\x00\x17\x00\x18\x00\x7e\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x81\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x85\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x00\x00\x88\x00\x00\x00\x89\x00\x00\x00\x8a\x00\x00\x00\x8b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x5d\x00\x00\x00\x00\x00\x1c\x00\x60\x00\x00\x00\x00\x00\x1d\x00\x63\x00\x41\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x00\x00\x00\x00\x00\x00\x00\x00\x96\x00\x97\x00\x98\x00\x99\x00\x00\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x45\x00\x77\x00\x0b\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x79\x00\x00\x00\x0c\x00\x7a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x7d\x00\x15\x00\x16\x00\x17\x00\x18\x00\x7e\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x81\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x85\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x00\x00\x88\x00\x00\x00\x89\x00\x00\x00\x8a\x00\x00\x00\x8b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x5d\x00\x00\x00\x00\x00\x1c\x00\x60\x00\x00\x00\x00\x00\x1d\x00\x63\x00\x41\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x00\x00\x00\x00\x00\x00\x00\x00\x96\x00\x97\x00\x98\x00\x99\x00\x00\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x45\x00\x77\x00\x0b\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x79\x00\x00\x00\x0c\x00\x7a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7b\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x7d\x00\x15\x00\x16\x00\x17\x00\x18\x00\x7e\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x81\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x85\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x00\x00\x88\x00\x00\x00\x89\x00\x00\x00\x8a\x00\x00\x00\x8b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x5d\x00\x00\x00\x00\x00\x1c\x00\x60\x00\x00\x00\x00\x00\x1d\x00\x63\x00\x41\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x00\x00\x00\x00\x00\x00\x00\x00\x96\x00\x97\x00\x98\x00\x99\x00\x00\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x45\x00\x77\x00\x0b\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x79\x00\x00\x00\x0c\x00\x7a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x7d\x00\x15\x00\x16\x00\x17\x00\x18\x00\x7e\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x81\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x00\x00\x88\x00\x00\x00\x89\x00\x00\x00\x8a\x00\x00\x00\x8b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x5d\x00\x00\x00\x00\x00\x1c\x00\x60\x00\x00\x00\x00\x00\x1d\x00\x63\x00\x41\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x00\x00\x00\x00\x00\x00\x00\x00\x96\x00\x97\x00\x98\x00\x99\x00\x00\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x45\x00\x77\x00\x0b\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x79\x00\x00\x00\x0c\x00\x7a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x7d\x00\x15\x00\x16\x00\x17\x00\x18\x00\x7e\x00\x00\x00\xb7\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x81\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x00\x00\x88\x00\x00\x00\x89\x00\x00\x00\x8a\x00\x00\x00\x8b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x5d\x00\x00\x00\x00\x00\x1c\x00\x60\x00\x00\x00\x00\x00\x1d\x00\x63\x00\x41\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x00\x00\x00\x00\x00\x00\x00\x00\x96\x00\x97\x00\x98\x00\x99\x00\x00\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x45\x00\x77\x00\x0b\x00\x78\x00\x00\x00\x00\x00\x00\x00\x00\x00\x79\x00\x00\x00\x0c\x00\x7a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc3\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x7d\x00\x15\x00\x16\x00\x17\x00\x18\x00\x7e\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x81\x00\x82\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x83\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x85\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x00\x00\x87\x00\x00\x00\x88\x00\x50\x01\x89\x00\x00\x00\x8a\x00\x00\x00\x8b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x5d\x00\x00\x00\x00\x00\x1c\x00\x60\x00\x00\x00\x00\x00\x1d\x00\x63\x00\x41\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x00\x00\x28\x00\x00\x00\x00\x00\x96\x00\x97\x00\x98\x00\x99\x00\x00\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x45\x00\x77\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x00\x00\x15\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x2b\x00\x51\x01\x2c\x00\x2d\x00\x52\x01\x39\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x53\x01\x2f\x00\x54\x01\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x00\x00\x0c\x01\x00\x00\x00\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x00\x00\x87\x00\x00\x00\x88\x00\x50\x01\x89\x00\x00\x00\x8a\x00\x00\x00\x8b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x5d\x00\x00\x00\x00\x00\x1c\x00\x60\x00\x00\x00\x00\x00\x1d\x00\x63\x00\x41\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x00\x00\x28\x00\x00\x00\x00\x00\x96\x00\x97\x00\x98\x00\x99\x00\x00\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x45\x00\x77\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x00\x00\x15\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x00\x00\x87\x00\x00\x00\x88\x00\x22\x00\x89\x00\xb2\x02\x8a\x00\xc6\x03\x8b\x00\x67\x01\x27\x00\x00\x00\x00\x00\x1b\x00\x5d\x00\x00\x00\x00\x00\x1c\x00\x60\x00\x00\x00\x00\x00\x1d\x00\x63\x00\x41\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x00\x00\x00\x00\x00\x00\x28\x00\x96\x00\x97\x00\x98\x00\x99\x00\x28\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x45\x00\x77\x00\x0b\x00\x00\x00\x54\x00\x26\x01\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x55\x00\x56\x00\x57\x00\x27\x01\x28\x01\x29\x01\x2a\x01\x58\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x00\x00\x15\x00\x16\x00\x17\x00\x18\x00\x5c\x00\x00\x00\x19\x00\x5e\x00\x5f\x00\x00\x00\x00\x00\x61\x00\x62\x00\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x00\x00\x00\x00\x22\x00\x30\x00\x00\x00\x00\x00\x87\x00\x00\x00\x88\x00\x50\x01\x89\x00\x00\x00\x8a\x00\x00\x00\x8b\x00\x5a\x02\x00\x00\x00\x00\x00\x00\x1b\x00\x5d\x00\x00\x00\x00\x00\x1c\x00\x60\x00\x00\x00\x00\x00\x1d\x00\x63\x00\x41\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x00\x00\x28\x00\x00\x00\x00\x00\x96\x00\x97\x00\x98\x00\x99\x00\x00\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x45\x00\x77\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x00\x00\x15\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x00\x00\x88\x00\x00\x00\x89\x00\x00\x00\x8a\x00\x00\x00\x8b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x5d\x00\x00\x00\x00\x00\x1c\x00\x60\x00\x00\x00\x00\x00\x1d\x00\x63\x00\x41\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x00\x00\x00\x00\x00\x00\x00\x00\x96\x00\x97\x00\x98\x00\x99\x00\x00\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x45\x00\x77\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x00\x00\x15\x00\x16\x00\x17\x00\x18\x00\xf4\x01\x00\x00\x19\x00\x00\x00\x00\x00\x22\x00\x90\x01\x00\x00\x24\x00\x25\x00\x00\x00\x26\x00\x27\x00\xaa\x03\xab\x03\x00\x00\x00\x00\x00\x00\xcd\x02\x00\x00\x00\x00\x3f\x03\x00\x00\x22\x00\x90\x01\x00\x00\x24\x00\x25\x00\x00\x00\x26\x00\x27\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x87\x00\x28\x00\x88\x00\x00\x00\x89\x00\x00\x00\x8a\x00\x00\x00\x8b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x5d\x00\x00\x00\x00\x00\x1c\x00\x60\x00\x28\x00\x00\x00\x1d\x00\x63\x00\x41\x00\x8c\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x00\x00\x00\x00\x00\x00\x00\x00\x96\x00\x97\x00\x98\x00\x99\x00\x00\x00\x9a\x00\x9b\x00\x9c\x00\x9d\x00\x45\x00\x00\x00\x00\x00\x00\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x29\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x00\x00\x00\x00\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x00\x00\xcd\x02\x00\x00\x2e\x00\xce\x02\x2f\x00\x22\x00\x90\x01\x00\x00\x24\x00\x25\x00\x00\x00\x26\x00\x27\x00\x00\x00\x00\x00\x30\x00\xf4\x01\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x90\x01\x00\x00\x24\x00\x25\x00\x00\x00\x26\x00\x27\x00\x2b\x02\x00\x00\x00\x00\x00\x00\x00\x00\xf4\x01\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x90\x01\x00\x00\x24\x00\x25\x00\x28\x00\x26\x00\x27\x00\x3a\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf4\x01\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x90\x01\x28\x00\x24\x00\x25\x00\x00\x00\x26\x00\x27\x00\xf5\x01\x00\x00\x00\x00\x00\x00\x00\x00\x1e\x04\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x90\x01\x28\x00\x24\x00\x25\x00\x00\x00\x26\x00\x27\x00\x00\x00\x00\x00\x00\x00\x05\x04\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x90\x01\x29\x00\x24\x00\x25\x00\x28\x00\x26\x00\x27\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x00\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x28\x00\x2e\x00\x00\x00\x2f\x00\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x29\x00\x30\x00\x00\x00\x28\x00\x2e\x00\x00\x00\x2f\x00\x00\x00\x00\x00\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x29\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x00\x00\x30\x00\x00\x00\x29\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x00\x00\x00\x00\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x00\x00\x29\x00\x30\x00\x00\x00\x00\x00\x22\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x2a\x00\x2b\x00\x5a\x01\x2c\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x17\x02\x00\x00\x2e\x00\x00\x00\x2f\x00\x22\x00\x90\x01\x00\x00\x24\x00\x25\x00\x00\x00\x26\x00\x27\x00\x00\x00\x00\x00\x30\x00\x8f\x01\x00\x00\x0b\x00\x00\x00\x00\x00\x22\x00\x90\x01\x28\x00\x24\x00\x25\x00\x0c\x00\x26\x00\x27\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x28\x00\x0f\x00\x10\x00\x11\x00\x33\x00\x34\x00\x35\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x28\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd2\x03\x00\x00\x00\x00\x00\x00\x22\x00\x00\x00\x19\x02\xda\x02\x00\x00\x1b\x02\xdb\x02\x27\x00\x00\x00\x00\x00\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x29\x00\x2e\x00\x00\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x30\x00\x00\x00\x29\x00\x28\x00\x3d\x00\x3e\x00\x00\x00\x00\x00\x2e\x00\x3f\x00\x2f\x00\x2a\x00\x2b\x00\x40\x00\x2c\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x00\x00\x30\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x33\x00\x34\x00\x35\x00\x00\x00\xdc\x02\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x2a\xff\x00\x00\x2a\xff\x00\x00\xfb\x02\x00\x00\xfc\x02\x2b\xff\x00\x00\x37\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x01\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x39\x00\x0b\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x59\x01\x3d\x00\x3e\x00\x3f\x01\x40\x01\x00\x00\x3f\x00\x00\x00\x41\x01\x0d\x00\x40\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x33\x00\x34\x00\x35\x00\x00\x00\xd1\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x43\x00\x44\x00\x00\x00\x00\x00\x45\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x33\x01\x36\x00\x24\x00\x25\x00\x00\x00\x26\x00\x27\x00\x00\x00\x00\x00\x29\x02\x2a\x02\x37\x03\x00\x00\x38\x03\x2b\xff\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x01\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x39\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x28\x00\x00\x00\x00\x00\x59\x01\x3d\x00\x3e\x00\x3f\x01\x40\x01\x00\x00\x3f\x00\x00\x00\x41\x01\x0b\x00\x40\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x43\x00\x44\x00\x00\x00\x32\x00\x45\x00\x0f\x00\x10\x00\x11\x00\x33\x00\x34\x00\x35\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x29\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x36\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x3d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x39\x00\x0b\x00\x3a\x00\x00\x00\x3b\x00\x3e\x01\x3c\x00\x00\x00\x00\x00\x0c\x00\x00\x00\xf5\x00\x00\x00\x3d\x00\x3e\x00\x3f\x01\x40\x01\x00\x00\x3f\x00\x00\x00\x41\x01\x0d\x00\x40\x00\x41\x00\x00\x00\x00\x00\x42\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x33\x00\x34\x00\x35\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x22\x00\x00\x00\x19\x00\x00\x00\x43\x00\x44\x00\x0b\x04\x27\x00\x45\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x01\x00\x00\x57\x01\x2b\xff\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x01\x38\x00\x00\x00\x28\x00\x00\x00\x00\x00\x00\x00\x39\x00\x0b\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x59\x01\x3d\x00\x3e\x00\x3f\x01\x40\x01\x00\x00\x3f\x00\x00\x00\x41\x01\x0d\x00\x40\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x33\x00\x34\x00\x35\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x43\x00\x44\x00\x00\x00\x00\x00\x45\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x01\x00\x00\x93\x02\x00\x00\x2e\x00\x37\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x01\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x39\x00\x0b\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x59\x01\x3d\x00\x3e\x00\x3f\x01\x40\x01\x00\x00\x3f\x00\x00\x00\x41\x01\x0d\x00\x40\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x33\x00\x34\x00\x35\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x43\x00\x44\x00\x00\x00\x00\x00\x45\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\xc1\x03\x36\x00\x00\x00\xc2\x03\x27\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x8a\x03\x00\x00\xfd\x03\x2b\xff\x22\x00\x37\x00\x19\x02\xda\x02\x00\x00\x1b\x02\xdb\x02\x27\x00\x38\x00\xc3\x03\x00\x00\x00\x00\x00\x00\x00\x00\x39\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x3c\x00\x28\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfe\x03\x3d\x00\x3e\x00\x00\x00\x5f\x00\x00\x00\x3f\x00\x00\x00\x00\x00\x0b\x00\x40\x00\x00\x00\x00\x00\x28\x00\x42\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x43\x00\x44\x00\x00\x00\x32\x00\x45\x00\x0f\x00\x10\x00\x11\x00\x33\x00\x34\x00\x35\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x36\x00\xdc\x02\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x00\x00\x00\x00\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x37\x00\x00\x00\x00\x00\x30\x00\x00\x00\x00\x00\x00\x00\x38\x00\x2e\x00\x00\x00\x2f\x00\x00\x00\x00\x00\x39\x00\x0b\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x3c\x00\x37\x01\x30\x00\x0c\x00\x00\x00\xf5\x00\x00\x00\x3d\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x3f\x00\x00\x00\x00\x00\x0d\x00\x40\x00\x41\x00\x00\x00\x00\x00\x42\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x33\x00\x34\x00\x35\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x43\x00\x44\x00\x00\x00\x00\x00\x45\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x39\x00\x0b\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\xfe\x03\x3d\x00\x3e\x00\x00\x00\x5f\x00\x00\x00\x3f\x00\x00\x00\x00\x00\x0d\x00\x40\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x33\x00\x34\x00\x35\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x43\x00\x44\x00\x00\x00\x00\x00\x45\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x33\x01\x36\x00\x24\x00\x25\x00\x00\x00\x26\x00\x27\x00\x26\xff\x00\x00\x26\xff\x86\x02\x21\x03\x00\x00\x00\x00\x2c\xff\x22\x00\x37\x00\x19\x02\xda\x02\x00\x00\x1b\x02\xdb\x02\x27\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x39\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x28\x00\x00\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x3f\x00\x00\x00\x00\x00\x0b\x00\x40\x00\x00\x00\x00\x00\x28\x00\x42\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x43\x00\x44\x00\x00\x00\x32\x00\x45\x00\x0f\x00\x10\x00\x11\x00\x33\x00\x34\x00\x35\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x29\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x36\x00\xdc\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x38\x00\x2e\x00\x00\x00\x2f\x00\x00\x00\x00\x00\x39\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\xad\x03\x3c\x00\x00\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x3f\x00\x00\x00\x00\x00\x0b\x00\x40\x00\x41\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x43\x00\x44\x00\x00\x00\x32\x00\x45\x00\x0f\x00\x10\x00\x11\x00\x33\x00\x34\x00\x35\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x36\x00\x00\x00\x00\x00\x09\x04\x27\x00\x22\x00\x90\x02\xa3\x03\x1a\x02\x25\x00\x1b\x02\x1c\x02\x27\x00\x00\x00\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\x0a\x04\x00\x00\x00\x00\x00\x00\x39\x00\x00\x00\x3a\x00\x43\x01\x3b\x00\x00\x00\x3c\x00\x00\x00\x28\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x00\x00\x28\x00\x00\x00\x3f\x00\x00\x00\x00\x00\x0b\x00\x40\x00\x41\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x43\x00\x44\x00\x00\x00\x32\x00\x45\x00\x0f\x00\x10\x00\x11\x00\x33\x00\x34\x00\x35\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x02\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x00\x00\x36\x00\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x2e\x00\x00\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x37\x00\x2f\x00\x00\x00\x00\x00\x30\x00\x00\x00\x00\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x39\x00\x45\x01\x3a\x00\x00\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x3f\x00\x00\x00\x00\x00\x0b\x00\x40\x00\x41\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x43\x00\x44\x00\x00\x00\x32\x00\x45\x00\x0f\x00\x10\x00\x11\x00\x33\x00\x34\x00\x35\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x36\x00\xc7\x03\x00\x00\x67\x01\x27\x00\x22\x00\x61\x01\x15\x03\x1a\x02\x25\x00\x1b\x02\x1c\x02\x27\x00\x00\x00\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x39\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x28\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x00\x00\x28\x00\x00\x00\x3f\x00\x00\x00\x00\x00\x0b\x00\x40\x00\x41\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x43\x00\x44\x00\x00\x00\xde\x02\x45\x00\x0f\x00\x10\x00\x11\x00\x33\x00\x34\x00\x35\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x02\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x00\x00\x36\x00\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x2e\x00\x00\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x37\x00\x2f\x00\x00\x00\x00\x00\x30\x00\x00\x00\x00\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x39\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x3f\x00\x00\x00\x00\x00\x0b\x00\x40\x00\x41\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x43\x00\x44\x00\x00\x00\x32\x00\x45\x00\x0f\x00\x10\x00\x11\x00\x33\x00\x34\x00\x35\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x36\x00\x8d\x03\x00\x00\x67\x01\x27\x00\x22\x00\x65\x01\x17\x03\x1a\x02\x25\x00\x1b\x02\x1c\x02\x27\x00\x00\x00\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x39\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x28\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x00\x00\x28\x00\x00\x00\x3f\x00\x00\x00\x00\x00\x0b\x00\x40\x00\x41\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x43\x00\x44\x00\x00\x00\xde\x02\x45\x00\x0f\x00\x10\x00\x11\x00\x33\x00\x34\x00\x35\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x02\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x00\x00\x36\x00\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x2e\x00\x00\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x37\x00\x2f\x00\x00\x00\x00\x00\x30\x00\x00\x00\x00\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x39\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x3f\x00\x00\x00\x00\x00\x0b\x00\x40\x00\x41\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x43\x00\x44\x00\x00\x00\x1f\x02\x45\x00\x0f\x00\x10\x00\x11\x00\x33\x00\x34\x00\x35\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x33\x01\x36\x00\x24\x00\x25\x00\x00\x00\x26\x00\x27\x00\x00\x00\x00\x00\x00\x00\x87\x02\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x37\x00\xa3\x03\xda\x02\x00\x00\x1b\x02\xdb\x02\x27\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x39\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x28\x00\x00\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x3f\x00\x00\x00\x00\x00\x0b\x00\x40\x00\x41\x00\x00\x00\x28\x00\x42\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x43\x00\x44\x00\x00\x00\xde\x02\x45\x00\x0f\x00\x10\x00\x11\x00\x33\x00\x34\x00\x35\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x29\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x36\x00\xdc\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x38\x00\x2e\x00\x00\x00\x2f\x00\x00\x00\x00\x00\x39\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x3f\x00\x00\x00\x00\x00\x0b\x00\x40\x00\x41\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x43\x00\x44\x00\x00\x00\x1f\x02\x45\x00\x0f\x00\x10\x00\x11\x00\x33\x00\x34\x00\x35\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x0d\x04\x36\x00\x24\x00\x25\x00\x00\x00\x26\x00\x27\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x37\x00\x15\x03\xda\x02\x00\x00\x1b\x02\xdb\x02\x27\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x39\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x28\x00\x00\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x3f\x00\x00\x00\x00\x00\x0b\x00\x40\x00\x41\x00\x00\x00\x28\x00\x42\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x43\x00\x44\x00\x00\x00\xde\x02\x45\x00\x0f\x00\x10\x00\x11\x00\x33\x00\x34\x00\x35\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x29\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x36\x00\xdc\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x38\x00\x2e\x00\x00\x00\x2f\x00\x00\x00\x00\x00\x39\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x3f\x00\x00\x00\x00\x00\x0b\x00\x40\x00\x41\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x43\x00\x44\x00\x00\x00\x32\x00\x45\x00\x0f\x00\x10\x00\x11\x00\x33\x00\x34\x00\x35\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\xf0\x03\x36\x00\x24\x00\x25\x00\x00\x00\x26\x00\x27\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x37\x00\x17\x03\xda\x02\x00\x00\x1b\x02\xdb\x02\x27\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x39\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x28\x00\x00\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x3f\x00\x00\x00\x00\x00\x0b\x00\x40\x00\x41\x00\x00\x00\x28\x00\x42\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x43\x00\x44\x00\x00\x00\xde\x02\x45\x00\x0f\x00\x10\x00\x11\x00\x33\x00\x34\x00\x35\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x29\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x36\x00\xdc\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x38\x00\x2e\x00\x00\x00\x2f\x00\x00\x00\x00\x00\x39\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x3f\x00\x00\x00\x00\x00\x0b\x00\x40\x00\x41\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x43\x00\x44\x00\x00\x00\x1f\x02\x45\x00\x0f\x00\x10\x00\x11\x00\x33\x00\x34\x00\x35\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\xf1\x03\x36\x00\x24\x00\x25\x00\x00\x00\x26\x00\x27\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x37\x00\xa6\x03\xda\x02\x00\x00\x1b\x02\xdb\x02\x27\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x39\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x28\x00\x00\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x3f\x00\x00\x00\x00\x00\x0b\x00\x40\x00\x41\x00\x00\x00\x28\x00\x42\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x43\x00\x44\x00\x00\x00\x32\x00\x45\x00\x0f\x00\x10\x00\x11\x00\x33\x00\x34\x00\x35\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x29\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x36\x00\xdc\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x38\x00\x2e\x00\x00\x00\x2f\x00\x00\x00\x00\x00\x39\x00\x0b\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x30\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x00\x00\xf2\x01\x00\x00\x3f\x00\x00\x00\x00\x00\x0d\x00\x40\x00\x41\x00\x00\x00\x00\x00\x42\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x33\x00\x34\x00\x35\x00\x00\x00\xf3\x01\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x43\x00\x44\x00\x00\x00\x00\x00\x45\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x31\x03\x36\x00\x24\x00\x25\x00\x00\x00\x26\x00\x27\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x37\x00\xd9\x02\xda\x02\x00\x00\x1b\x02\xdb\x02\x27\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x39\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x28\x00\x00\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x3f\x00\x00\x00\x00\x00\x0b\x00\x40\x00\x00\x00\x00\x00\x28\x00\x42\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x43\x00\x44\x00\x00\x00\x32\x00\x45\x00\x0f\x00\x10\x00\x11\x00\x33\x00\x34\x00\x35\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x29\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x36\x00\xdc\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x38\x00\x2e\x00\x00\x00\x2f\x00\x00\x00\x00\x00\x39\x00\x0b\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x30\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x3f\x00\x00\x00\x00\x00\x0d\x00\x40\x00\x41\x00\x00\x00\x00\x00\x42\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x33\x00\x34\x00\x35\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x22\x00\x00\x00\x19\x00\x00\x00\x43\x00\x44\x00\x0c\x04\x27\x00\x45\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\xff\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\x28\x00\x00\x00\x00\x00\x00\x00\x39\x00\x0b\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x00\x00\x03\x02\x00\x00\x3f\x00\x00\x00\x00\x00\x0d\x00\x40\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x33\x00\x34\x00\x35\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x43\x00\x44\x00\x00\x00\x00\x00\x45\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x00\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x00\x00\x54\x00\x01\x02\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x37\x00\x2f\x00\x00\x00\x55\x00\x56\x00\x57\x00\x00\x00\x38\x00\x00\x00\x00\x00\x58\x00\x00\x00\x30\x00\x39\x00\x0b\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x00\x00\x5c\x00\x00\x00\x3f\x00\x5e\x00\x5f\x00\x0d\x00\x40\x00\x61\x00\x62\x00\x00\x00\x42\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x33\x00\x34\x00\x35\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x43\x00\x44\x00\x00\x00\x00\x00\x45\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x9b\x02\x36\x00\x24\x00\x25\x00\x00\x00\x26\x00\x27\x00\x22\x00\x90\x02\x00\x00\x24\x00\x25\x00\x00\x00\x26\x00\x27\x00\x00\x00\x37\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x39\x00\x00\x00\x3a\x00\x00\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x00\x00\x28\x00\x00\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x00\x00\x00\x00\x28\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x22\x00\x61\x01\x42\x00\x24\x00\x25\x00\x00\x00\x26\x00\x27\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x43\x00\x44\x00\x22\x00\x65\x01\x45\x00\x24\x00\x25\x00\x00\x00\x26\x00\x27\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x29\x00\x00\x00\x00\x00\x00\x00\x28\x00\x00\x00\x00\x00\x00\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x2e\x00\x00\x00\x2f\x00\x28\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x22\x00\xe2\x00\x30\x00\x24\x00\x25\x00\x00\x00\x26\x00\x27\x00\x22\x00\x41\x01\x30\x00\x24\x00\x25\x00\x00\x00\x26\x00\x27\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x28\x00\x00\x00\x00\x00\x29\x00\x2e\x00\x00\x00\x2f\x00\x00\x00\x28\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x2b\x00\x22\x00\x2c\x00\x2d\x00\x30\x00\x8e\x03\x00\x00\x67\x01\x27\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x00\x00\x00\x00\x22\x00\x43\x01\x00\x00\x24\x00\x25\x00\x00\x00\x26\x00\x27\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x23\x00\x29\x00\x24\x00\x25\x00\x28\x00\x26\x00\x27\x00\x00\x00\x00\x00\x29\x00\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x2b\x00\x28\x00\x2c\x00\x2d\x00\x2e\x00\x00\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x00\x00\x22\x00\x30\x00\x00\x00\x28\x00\x8f\x03\x00\x00\x67\x01\x27\x00\x00\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x00\x00\x93\x03\x00\x00\x67\x01\x27\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x00\x00\x29\x00\x00\x00\x00\x00\x00\x00\x28\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x29\x00\x30\x00\x28\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x00\x00\x00\x00\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x22\x00\x00\x00\x00\x00\x30\x00\x19\x03\x00\x00\x67\x01\x27\x00\x2e\x00\x00\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x00\x00\x1a\x03\x30\x00\x67\x01\x27\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x22\x00\x00\x00\x00\x00\x28\x00\x1b\x03\x00\x00\x67\x01\x27\x00\x2e\x00\x00\x00\x2f\x00\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x22\x00\x00\x00\x00\x00\x28\x00\xec\x02\x30\x00\x67\x01\x27\x00\x2e\x00\x00\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x30\x00\x28\x02\x28\x00\x67\x01\x27\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x00\x00\x31\x02\x28\x00\x67\x01\x27\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x28\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x2a\x00\x2b\x00\x22\x00\x2c\x00\x2d\x00\x00\x00\x32\x02\x00\x00\x67\x01\x27\x00\x30\x00\x28\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x2a\x00\x2b\x00\x22\x00\x2c\x00\x2d\x00\x28\x00\x66\x01\x00\x00\x67\x01\x27\x00\x30\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x00\x00\x00\x00\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x22\x00\x00\x00\x00\x00\x30\x00\x68\x01\x00\x00\x67\x01\x27\x00\x2e\x00\x00\x00\x2f\x00\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x22\x00\x00\x00\x28\x00\x00\x00\x69\x01\x30\x00\x67\x01\x27\x00\x2e\x00\x00\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x28\x00\x00\x00\x2a\x00\x2b\x00\x22\x00\x2c\x00\x2d\x00\x00\x00\x8a\x01\x00\x00\x67\x01\x27\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x28\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x28\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x2e\x00\xf0\x01\x2f\x00\x67\x01\x27\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x2a\x00\x2b\x00\x22\x00\x2c\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x8c\x03\x27\x00\x30\x00\x00\x00\x28\x00\x2e\x00\x00\x00\x2f\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x03\x27\x00\x30\x00\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\x00\x00\x00\x00\x2e\x00\x28\x00\x2f\x00\x98\x02\x27\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x22\x00\x00\x00\x00\x00\x28\x00\x00\x00\x00\x00\x64\x01\x27\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x28\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x28\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x00\x00\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x2b\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x00\x00\x30\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x00\x00\x2a\x00\x2b\x00\x0b\x00\x2c\x00\x2d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x0c\x00\x00\x00\x00\x00\x2e\x00\x00\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x30\x00\x0e\x00\x0c\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x00\x00\x15\x00\x16\x00\x17\x00\x18\x00\x0d\x00\x00\x00\x19\x00\x00\x00\x00\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\xd5\x02\xd6\x02\xd7\x02\x00\x00\x15\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x73\x01\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x1b\x00\x15\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x0b\x00\x73\x01\x00\x00\x00\x00\xd8\x02\x00\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x1b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\xd8\x02\x00\x00\x00\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x00\x00\x15\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x73\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x00\x00\x00\x00\x00\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd8\x02\x00\x00\x55\x00\x56\x00\x57\x00\x00\x00\x00\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x00\x00\x00\x00\x0b\x00\x5a\x00\x00\x00\x5b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x5c\x00\x1b\x00\x5d\x00\x5e\x00\x5f\x00\x1c\x00\x60\x00\x61\x00\x62\x00\x1d\x00\x63\x00\x0d\x00\x00\x00\xe9\x03\x00\x00\x00\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x0b\x00\x15\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\xe9\x03\xea\x03\x00\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x00\x00\x15\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x00\x00\x00\x00\x00\x00\xde\x00\xeb\x03\x5b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x5d\x00\x00\x00\x00\x00\x1c\x00\x60\x00\x00\x00\x00\x00\x1d\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x59\x00\x00\x00\x00\x00\x00\x00\xde\x00\x00\x00\x5b\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x5d\x00\x00\x00\x71\x03\x1c\x00\x60\x00\x0d\x00\x00\x00\x1d\x00\x63\x00\x00\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x0b\x00\x15\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x00\x00\x15\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x72\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x73\x03\x00\x00\x1b\x00\x3e\x00\x00\x00\x00\x00\x1c\x00\x3f\x00\x00\x00\x00\x00\x1d\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x59\x00\x00\x00\x00\x00\x00\x00\xde\x00\x00\x00\x5b\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x5d\x00\x00\x00\x00\x00\x1c\x00\x60\x00\x0d\x00\x00\x00\x1d\x00\x63\x00\x00\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x0b\x00\x15\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x33\x00\x34\x00\x35\x00\x00\x00\x0d\x00\x16\x00\x17\x00\x18\x00\x00\x00\x0e\x00\x19\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x00\x00\x15\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x5d\x00\x00\x00\x00\x00\x1c\x00\x60\x00\x00\x00\x00\x00\x1d\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd8\x00\x00\x00\xd9\x00\x00\x00\xda\x00\x00\x00\xdb\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x00\x3e\x00\x00\x00\x00\x00\x0b\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x1b\x00\x5d\x00\x00\x00\x00\x00\x1c\x00\x60\x00\x00\x00\x00\x00\x1d\x00\x63\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x0b\x00\x15\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xec\x01\x00\x00\x00\x00\x0b\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x97\x01\x00\x00\x0e\x00\x0c\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x00\x00\x15\x00\x16\x00\x17\x00\x18\x00\x0d\x00\x00\x00\x19\x00\x00\x00\x00\x00\x0b\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x33\x00\x34\x00\x35\x00\x0c\x00\x1a\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x1b\x00\x00\x00\x0d\x00\x00\x00\x1c\x00\x00\x00\x00\x00\x0e\x00\x1d\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x00\x00\x15\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x1a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x00\x00\x00\x00\x00\x00\x1c\x00\x00\x00\x00\x00\x00\x00\x1d\x00\x6c\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x00\x00\x00\x3f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x00\x00\xdb\x01\x0b\x00\x1c\x00\x0d\x00\x00\x00\xdc\x01\x1d\x00\x00\x00\x0e\x00\x0c\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x00\x00\x15\x00\x16\x00\x17\x00\x18\x00\x0d\x00\x00\x00\x19\x00\x00\x00\x00\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x00\x00\x15\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x00\x00\x00\x00\x00\x00\xdd\x01\x00\x00\x5b\x00\x00\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x5d\x00\x00\x00\x0c\x00\x00\x00\x59\x00\x00\x00\x00\x00\x00\x00\xdd\x01\x00\x00\x5b\x00\x00\x00\x0b\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x1b\x00\x5d\x00\x0e\x00\x0c\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x00\x00\x15\x00\x16\x00\x17\x00\x18\x00\x0d\x00\x00\x00\x19\x00\x00\x00\x00\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x0b\x00\x15\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x00\x00\x15\x00\x16\x00\x17\x00\x18\x00\x0b\x00\x00\x00\x19\x00\x00\x00\x00\x00\x1b\x00\x5d\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x1b\x00\x00\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x0b\x00\x15\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x73\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x1b\x00\x00\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x00\x00\x15\x00\x16\x00\x17\x00\x18\x00\x0b\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x1b\x00\x00\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x0b\x00\x15\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x73\x01\x00\x00\x00\x00\x00\x00\x0b\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x1b\x00\x00\x00\x00\x00\x0c\x00\x0f\x00\x10\x00\x11\x00\x33\x00\x34\x00\x35\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x0d\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x0f\x00\x10\x00\x11\x00\x33\x00\x34\x00\x35\x00\x00\x00\x0c\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x1b\x00\x00\x00\x27\x03\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x33\x00\x34\x00\x35\x00\x0c\x00\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x6c\x01\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x33\x00\x34\x00\x35\x00\x00\x00\x4f\x01\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x3d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x4f\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# +happyTable = HappyA# "\x00\x00\x18\x04\x9e\x00\x9f\x00\xa0\x00\x1d\x00\x1e\x00\xa1\x00\x7b\x03\x94\x03\x4e\x03\xd7\x01\x1f\x00\xd7\x01\x20\x00\xe1\x03\xa4\x00\x4d\x03\x4e\x03\x04\x04\xc3\x02\x2c\x02\xda\x03\xd7\x01\x68\x02\xc2\x01\xfe\x02\xd7\x01\x64\x00\xa5\x00\xa6\x00\xf7\x01\xa6\xfd\x1e\x03\x1f\x03\x12\x03\xa6\xfd\x0f\x03\x21\xff\xa7\x00\x21\xff\xa8\x00\xa9\x00\xaa\x00\xab\x00\xe2\x03\xa4\x00\xac\x00\xf8\x01\x21\x04\xad\x00\xc4\x02\x1b\x02\x48\x03\x20\xff\xd4\x00\x20\xff\x74\x01\x64\x00\xa5\x00\xa6\x00\x2c\x04\x70\x03\x71\x03\x72\x03\x1f\x04\x70\x03\x71\x03\x72\x03\xa7\x00\xf2\xff\xa8\x00\xa9\x00\xaa\x00\xab\x00\xa7\x02\xae\x00\xac\x00\x4c\x02\x2e\x04\xad\x00\x2a\x04\x70\x03\x71\x03\x72\x03\xdb\x03\x16\x04\x4a\x01\x4b\x01\xff\x02\xd4\x00\x6f\x03\x70\x03\x71\x03\x72\x03\xd5\x00\xd8\x01\xd7\x01\xd8\x01\x05\x04\x10\x03\xc3\x01\xc3\x01\x4d\x02\xdd\x02\xde\x02\xae\x00\xf2\xff\xd8\x01\xd4\x03\x4c\x01\xd5\x00\xd8\x01\xea\x03\x72\x03\x1c\x02\x20\x03\xed\x03\x72\x03\xa1\x03\xaf\x00\xb0\x00\xb1\x00\x84\x02\x46\x00\xfb\x03\xb2\x00\x65\x00\x01\x03\xb3\x00\x68\x00\x23\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x00\x04\x75\x01\x7a\x03\x72\x03\x76\x01\x4c\x01\x49\x01\x4a\x01\x4b\x01\x4f\x03\x09\x00\x20\x03\xaf\x00\xb0\x00\xb1\x00\x09\x00\x49\x02\x4f\x03\xb2\x00\x65\x00\xdd\xfe\xb3\x00\x68\x00\x09\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\xa3\x00\x2c\x02\x7c\x03\x24\x00\x2e\x00\x2f\x00\x45\x02\x75\x01\xdf\x02\x73\x00\x76\x01\x76\x01\x74\x00\xfe\x03\xd8\x01\x48\x00\x09\x00\x09\x00\xfa\x02\x7d\x03\x07\x00\x08\x00\x4a\x02\x4e\x02\x4c\x01\x86\x02\xd3\x03\x09\x00\x4c\x01\xd4\x00\x4d\x01\xff\x03\x1f\x02\xa6\xfd\x1d\x02\xb4\x00\x75\x00\x07\x00\xb5\x00\x73\x00\x24\x00\xd4\x03\x74\x00\x4c\x01\x09\x00\x48\x00\x50\x00\x51\x00\x46\x02\x1d\x02\x76\x00\x21\x00\x9b\x02\x21\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\x4c\x01\x4f\x02\xdf\x02\x6c\x03\x4b\x01\x76\x01\x1d\x02\xb4\x00\x75\x00\x07\x00\xb5\x00\x09\x00\x01\x04\x02\x04\x1f\x02\xa6\xfd\x09\x00\x52\x02\x50\x00\x51\x00\xa3\x00\xa4\x00\x76\x00\x9a\x02\x4c\x01\x05\x04\xb6\x00\xb7\x00\xb8\x00\xb9\x00\x4d\x01\xd4\x00\x07\x04\x64\x00\xa5\x00\xa6\x00\x73\x03\x54\x02\x74\x03\x75\x03\x73\x03\x34\x01\x74\x03\x75\x03\xa7\x00\xa0\x03\xa8\x00\xa9\x00\xaa\x00\xab\x00\xd7\x00\xa4\x00\xac\x00\x53\x02\xc0\x02\xad\x00\x73\x03\x9b\x02\x74\x03\x75\x03\xa1\x03\xcb\x01\xb8\x01\x64\x00\xa5\x00\xa6\x00\x73\x03\xb9\x01\x74\x03\x75\x03\x47\x00\xd4\x00\xe4\x02\x48\x00\xa7\x00\x49\x00\xa8\x00\xa9\x00\xaa\x00\xab\x00\xca\x03\xae\x00\xac\x00\xe9\x03\xc5\x02\xad\x00\x73\x03\x4a\x00\x74\x03\x75\x03\x73\x03\xcb\x01\x74\x03\x75\x03\x06\x00\x07\x00\x08\x00\x4b\x00\xba\x01\x4c\x00\x4d\x00\x4e\x00\x09\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x4c\x01\x26\x04\xd8\x03\xae\x00\x48\x00\x73\x03\x4d\x01\x74\x03\x75\x03\xd7\x03\x55\x00\x55\x00\x31\x03\x83\x02\x31\x00\xce\x03\x50\x01\xaf\x00\xb0\x00\xb1\x00\xf3\x02\xf4\x02\xf5\x02\xb2\x00\x65\x00\x32\x00\xb3\x00\x68\x00\x84\x02\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x50\x00\x51\x00\xe9\x00\x55\x00\x03\x01\x03\x01\xbd\x03\x13\x04\xdf\x01\xe8\x03\xf9\x00\xf9\x00\xaf\x00\xb0\x00\xb1\x00\x60\x00\x60\x00\xb2\x03\xb2\x00\x65\x00\x63\x00\xb3\x00\x68\x00\x10\x02\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x5a\x00\x88\x03\x03\x01\x89\x03\x15\x04\x64\x00\x5c\x00\x11\x02\xf9\x00\x73\x00\xe1\x01\x85\x02\x74\x00\xc6\x03\x5e\x00\x48\x00\xa7\x00\x45\x01\xa8\x00\xa9\x00\xaa\x00\xab\x00\xdf\x02\xbc\x01\xac\x00\x76\x01\x86\x02\xad\x00\xbd\x01\xb3\x03\x82\x01\x09\x00\x77\x03\xe5\x01\xe6\x01\xb4\x00\x75\x00\x07\x00\xb5\x00\x73\x00\x67\x01\x2f\x00\x74\x00\xeb\x03\x09\x00\x48\x00\x50\x00\x51\x00\x8e\x03\x51\x01\x76\x00\x31\x00\x68\x01\xae\x00\xb6\x00\xb7\x00\xb8\x00\xb9\x00\x83\x01\xbe\x01\x53\x03\xa4\x03\x32\x00\x32\x00\x84\x01\xb4\x00\x75\x00\x07\x00\xb5\x00\x93\x03\x54\x03\x65\x00\x3f\x03\x50\x01\x09\x00\x09\x00\x50\x00\x51\x00\x01\x03\x50\x01\x76\x00\x62\x02\x4c\x01\x63\x02\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xb7\x03\x3c\x01\x3d\x01\x83\x03\x84\x03\x85\x03\x86\x03\x71\x01\x50\x01\xaf\x00\xb0\x00\xb1\x00\xf1\x03\xf2\x03\xf3\x03\xb2\x00\x65\x00\xcf\x01\xb3\x00\x68\x00\x1e\x03\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x54\x02\xa7\x02\x64\x00\x40\x00\x34\x01\x0a\x04\x73\x00\x41\x00\xa2\x03\x74\x00\xa6\x03\x42\x00\x48\x00\xa7\x00\xce\x02\xa8\x00\xa9\x00\xaa\x00\xab\x00\x3c\x01\x3d\x01\xac\x00\x4c\x01\x2a\xff\xad\x00\x2a\xff\xe7\x01\xe8\x01\x78\x01\xde\x01\x3e\x01\xdf\x01\x29\x04\xeb\x00\x07\x00\x08\x00\x4f\x01\x50\x01\x2a\x04\x73\x00\x7e\x01\x09\x00\x74\x00\x50\x00\x51\x00\x48\x00\x7f\x01\x76\x00\xb2\x03\x3f\x01\xae\x00\xe0\x01\x46\x03\xa7\x02\x76\x01\x76\x01\x51\x01\x10\x04\x31\x00\xb3\x03\x09\x00\x09\x00\x51\x01\xe1\x01\x31\x00\xb4\x00\x75\x00\x07\x00\xb5\x00\x32\x00\xee\x03\xa6\x00\x96\x02\x97\x02\x09\x00\x32\x00\x50\x00\x51\x00\xa7\x02\x51\x01\x76\x00\x31\x00\x6d\x03\xb5\x03\xb6\x00\xb7\x00\xb8\x00\xb9\x00\x12\x02\x98\x02\xa5\x02\x8a\x01\x32\x00\x76\x01\xaf\x00\xb0\x00\xb1\x00\x7f\x01\x18\x03\x09\x00\xb2\x00\x65\x00\xcf\x01\xb3\x00\x68\x00\xc3\x03\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\xa7\x02\x17\x03\x64\x00\xd0\x01\xa8\x02\xc5\x01\x2b\x04\xf3\x03\x1b\x03\xe7\x01\xe8\x01\xf9\x00\xde\x01\xa7\x00\xdf\x01\xa8\x00\xa9\x00\xaa\x00\xab\x00\xc5\x01\x08\x00\xac\x00\x2a\x03\x51\x01\xad\x00\x31\x00\x09\x00\x74\x00\x30\x01\x51\x00\x48\x00\x56\x00\x57\x00\x58\x00\xe0\x01\x2e\x03\x32\x00\x76\x01\x59\x00\x73\x00\xad\x02\x99\x01\x74\x00\x09\x00\x63\x03\x48\x00\xe1\x01\x2f\x01\x08\x00\x11\x03\xae\x00\xeb\x00\x07\x00\x08\x00\x09\x00\x09\x00\x30\x01\x51\x00\x12\x03\x09\x00\x5f\x00\x50\x00\x51\x00\x12\x04\xbc\x03\xb4\x00\x75\x00\x07\x00\xb5\x00\xef\x03\xa6\x00\x9a\x01\x07\x00\x08\x00\x09\x00\x34\x03\x50\x00\x51\x00\x64\x01\x09\x00\x76\x00\x2b\x02\x65\x01\x2c\x02\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xcf\x02\xe8\x01\x69\x03\xde\x01\xa1\x02\xdf\x01\xaf\x00\xb0\x00\xb1\x00\x41\x02\x07\x00\x08\x00\xb2\x00\x65\x00\x66\x03\xb3\x00\x68\x00\x09\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x64\x00\xe0\x01\xc7\x02\xd1\x01\x76\x01\x32\x01\xfd\x00\x4e\x00\x13\x02\x4f\x00\x09\x00\xa7\x00\xd1\x02\xe1\x01\x19\x02\xaa\x00\xab\x00\x14\x02\x15\x02\xac\x00\xa5\x03\xf5\x02\xad\x00\xbd\x03\xbe\x03\xdf\x01\x79\x03\x1c\x03\x2f\x00\xbf\x03\x7a\x03\x2e\x00\x2f\x00\x64\x00\x16\x02\x4e\x00\x90\x03\x4f\x00\xc5\x02\x73\x00\x91\x03\x17\x02\x74\x00\xc6\x02\xa7\x00\x48\x00\xd4\x02\x74\x00\xae\x00\x1a\x03\x48\x00\x36\x03\x37\x03\x1b\x03\x46\x02\x07\x00\x08\x00\xe1\x01\xe9\x01\xea\x01\x38\x03\x39\x03\x09\x00\x6a\x03\x94\x02\xb4\x00\x75\x00\x07\x00\xb5\x00\x19\x01\x29\x03\xeb\x00\x07\x00\x08\x00\x09\x00\xd3\x02\x50\x00\x51\x00\x55\x00\x09\x00\x76\x00\x50\x00\x51\x00\xeb\x02\xb6\x00\xb7\x00\xb8\x00\xb9\x00\x56\x00\x57\x00\x58\x00\xec\x02\xaf\x00\xb0\x00\xb1\x00\x59\x00\x64\x01\xef\x02\xb2\x00\x65\x00\x65\x01\xb3\x00\x68\x00\xf2\x02\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x01\xf6\x02\x31\x00\x3e\x01\x5d\x00\x33\x01\x53\x00\x5f\x00\x60\x00\x0b\x03\x34\x01\x62\x00\x63\x00\x32\x00\x0d\x03\xaf\x00\xb0\x00\x3a\x03\xda\x01\x07\x00\x08\x00\xb2\x00\x65\x00\x2e\x02\xa3\x01\x68\x00\x09\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x64\x00\xce\x01\xdb\x01\x07\x00\x08\x00\xd0\x02\x73\x00\xa4\x02\x94\x02\x74\x00\x09\x00\xa7\x00\x48\x00\xa9\x02\x94\x02\xdc\x01\x07\x00\x08\x00\x36\x03\x37\x03\x37\x02\xeb\x01\xe8\x01\x09\x00\xde\x01\x1c\x01\xdf\x01\x38\x03\x3d\x03\x1d\x01\x24\x00\x35\x02\xb4\x00\x75\x00\x07\x00\xb5\x00\x30\x03\x54\x01\x4a\x02\x73\x00\x31\x03\x09\x00\x74\x00\x50\x00\x51\x00\x48\x00\xe0\x01\x76\x00\x3c\x02\x76\x01\x50\x02\xb6\x00\xb7\x00\xb8\x00\xb9\x00\x09\x00\xee\x02\x8c\x02\xe1\x01\x64\x01\xef\x02\x8d\x02\x40\x02\x65\x01\x64\x00\xb4\x00\x75\x00\x07\x00\xb5\x00\x2a\x00\x53\x02\x4e\x00\x55\x02\x4f\x00\x09\x00\xa7\x00\x50\x00\x51\x00\x55\x00\x07\x04\x76\x00\x5d\x02\x36\x03\x37\x03\xb6\x00\xb7\x00\xb8\x00\xb9\x00\x56\x00\x57\x00\x58\x00\xdd\x03\xaf\x00\xb0\x00\x3a\x03\x59\x00\x64\x01\x61\x02\xb2\x00\x65\x00\x65\x01\xa3\x01\x68\x00\x76\x02\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\xeb\x01\xe8\x01\x7d\x02\xde\x01\x5d\x00\xdf\x01\x64\x00\x5f\x00\x60\x00\x85\x01\x8d\x01\x62\x00\x63\x00\x7f\x01\x7f\x01\x7f\x02\x0b\x04\xa7\x00\x2c\x00\x2d\x00\xc9\x01\x2e\x00\x2f\x00\xa7\x03\xf9\x00\xe0\x01\xb9\x02\xba\x02\x76\x01\xa8\x03\xa9\x03\x30\x00\x87\x02\x31\x00\x09\x00\x88\x02\x3b\x01\xe1\x01\x8a\x02\x73\x00\xf9\x00\x3e\x01\x74\x00\x11\x02\x32\x00\x48\x00\xaf\x00\xb0\x00\x3a\x03\x17\x02\x1c\x01\x62\x01\xb2\x00\x65\x00\x1d\x01\xa3\x01\x68\x00\xa0\x02\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x9f\x01\xb4\x00\x75\x00\x07\x00\xb5\x00\xe5\x00\xcb\x01\x64\x00\x39\x01\xe6\x00\x09\x00\x15\x01\x50\x00\x51\x00\xf5\x01\x16\x01\x76\x00\xd4\x01\xa7\x00\xd5\x01\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xa7\x03\xf2\x01\x07\x00\x08\x00\xfe\x01\xdf\x00\xa8\x03\xae\x03\x48\x00\x09\x00\xaf\x00\xb0\x00\xaa\x03\x09\x03\x94\x02\x73\x00\xb2\x00\x65\x00\x74\x00\xa3\x01\x68\x00\x48\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x1c\x01\xe0\x00\x07\x00\x08\x00\x1d\x01\x0c\x02\x15\x01\x64\x00\xe3\x00\x09\x00\x16\x01\x50\x00\x51\x00\xb4\x00\x75\x00\x07\x00\xb5\x00\x41\x01\xa7\x00\x06\x00\x07\x00\x08\x00\x09\x00\x13\x01\x50\x00\x51\x00\xf8\x00\x09\x00\x76\x00\x17\x01\xf9\x00\x32\x04\xb6\x00\xb7\x00\xb8\x00\xb9\x00\x47\x02\xf0\x01\xa1\x01\x73\x00\x42\x01\xd4\x00\x74\x00\xd6\x00\xd7\x00\x48\x00\xf9\x00\xaf\x00\xb0\x00\xaa\x03\x43\x01\x44\x01\x1e\x01\xb2\x00\x65\x00\x45\x01\xa3\x01\x68\x00\x31\x01\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\xb4\x00\x75\x00\x07\x00\xb5\x00\x93\x02\x94\x02\x64\x00\xec\x01\xed\x01\x09\x00\x2e\x04\x50\x00\x51\x00\x19\x01\xfb\x01\x76\x00\x55\x00\xa7\x00\x93\x03\xb6\x00\xb7\x00\xb8\x00\xb9\x00\x27\x02\x28\x02\x29\x02\x56\x00\x57\x00\x58\x00\x30\x04\x97\x01\x98\x01\x99\x01\x59\x00\xaf\x00\xb0\x00\xa2\x01\xa7\x01\xd5\x00\x73\x00\xb2\x00\x65\x00\x74\x00\xa3\x01\x68\x00\x48\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x5d\x00\xef\x01\xf0\x01\x5f\x00\x60\x00\x18\x04\x64\x00\x62\x00\x63\x00\xd4\x00\x9a\x01\x07\x00\x08\x00\xb4\x00\x75\x00\x07\x00\xb5\x00\xa7\x00\x09\x00\x5b\x02\x28\x02\x29\x02\x09\x00\xa7\x03\x50\x00\x51\x00\xf4\x01\xf0\x01\x76\x00\x09\x04\x19\x01\x1a\x01\xb6\x00\xb7\x00\xb8\x00\xb9\x00\x5e\x00\xa4\x01\xa5\x01\xa6\x01\x5f\x01\xa6\x00\x74\x00\x60\x01\xa6\x00\x48\x00\xaf\x00\xb0\x00\xa2\x01\x3e\x02\x3f\x02\x40\x02\xb2\x00\x65\x00\x21\x04\xa3\x01\x68\x00\x23\x04\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x0d\x03\xb4\x00\x75\x00\x07\x00\xb5\x00\x24\x04\x64\x00\x1f\x02\x09\x04\x26\x04\x09\x00\x66\x01\x50\x00\x51\x00\x5e\x03\x5f\x03\x76\x00\xa7\x00\x5f\x02\x60\x02\xb6\x00\xb7\x00\xb8\x00\xb9\x00\x56\x00\x57\x00\x58\x00\xf1\x03\xdd\x01\xf8\x03\xde\x01\x59\x00\xdf\x01\xf9\x03\xaf\x00\xb0\x00\xaa\x03\xa8\x01\xa5\x01\xa6\x01\xb2\x00\x65\x00\x74\x00\xa3\x01\x68\x00\x48\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\xe0\x01\x5f\x00\x44\x01\x76\x01\xfb\x03\x62\x00\x45\x01\x0d\x03\x0f\x03\x09\x00\x1f\x02\x64\x00\xe1\x01\xb4\x00\x75\x00\x07\x00\xb5\x00\xbb\x03\xbc\x03\xd5\x00\x0f\x04\x10\x04\x09\x00\xd5\x00\x50\x00\x51\x00\xbe\xfd\xc5\x03\x76\x00\xc8\x03\x04\xfe\xce\x03\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xc7\x03\xc9\x03\xda\x03\x73\x00\xca\x03\xdd\x03\x74\x00\xcc\x03\xe0\x03\x48\x00\xaf\x00\xb0\x00\xb8\x02\xd5\x00\xcd\x03\xe4\x03\xb2\x00\x65\x00\xe5\x03\xa3\x01\x68\x00\x01\x03\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x88\x03\xb4\x00\x75\x00\x07\x00\xb5\x00\xed\x03\xbf\x00\xe9\x00\x8a\x03\x82\x03\x09\x00\x8b\x03\x50\x00\x51\x00\x92\x03\x97\x03\x76\x00\x96\x03\x9f\x03\x9a\x03\xb6\x00\xb7\x00\xb8\x00\xb9\x00\xb7\x03\xbd\x03\xbe\x03\xdf\x01\x0d\x03\x16\x03\x17\x03\xbf\x03\x0d\x03\x2e\x00\x2f\x00\x0f\x03\xa3\x03\x0d\x03\x25\x03\x73\x00\xd4\x00\x29\x03\x74\x00\x64\x00\x01\x03\x48\x00\x65\x00\xec\x00\xed\x00\x68\x00\x2c\x03\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x2d\x03\x34\x03\xe1\x01\x36\x03\xfa\x00\xfb\x00\x41\x03\xdf\xfd\xb4\x00\x75\x00\x07\x00\xb5\x00\x46\x03\x3c\x01\x3d\x01\xdd\xfd\x4a\x03\x09\x00\x24\x00\x50\x00\x51\x00\x04\x02\x05\x02\x76\x00\x28\x00\x29\x00\xde\xfd\xb6\x00\xb7\x00\xb8\x00\xb9\x00\x32\x01\xfd\x00\x4e\x00\x48\x03\x4f\x00\x4b\x03\xd9\x00\x2d\x00\x73\x00\x2e\x00\x2f\x00\x74\x00\x55\x03\x4c\x03\x48\x00\x56\x03\xf0\x00\x57\x03\x65\x00\xda\x00\x58\x03\x31\x00\x59\x03\x60\x03\xa1\x01\x63\x03\x2a\x00\xf1\x00\xea\x00\xf2\x00\x87\x02\x65\x03\x32\x00\x68\x03\x69\x03\x75\x00\x07\x00\x08\x00\x1a\x02\xf3\x00\xfc\x00\xd8\x01\xfe\x00\x09\x00\x4f\x00\x50\x00\x51\x00\xff\x00\x53\x00\x76\x00\x64\x00\xd5\x00\x00\x01\x77\x03\x65\x00\xec\x00\xed\x00\x68\x00\x6c\x03\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\xd4\x00\x6f\x03\xa3\x02\x73\x00\xfa\x00\xfb\x00\x74\x00\xd5\x00\xab\x02\x48\x00\xac\x02\xad\x02\x24\x00\x43\x00\xbf\x02\x04\x02\x05\x02\x55\x00\x28\x00\x29\x00\x2c\x00\x2d\x00\xe8\xfd\x2e\x00\x2f\x00\xbd\x02\xa3\x02\x56\x00\x57\x00\x58\x00\xeb\x00\x07\x00\x08\x00\x30\x00\x59\x00\x31\x00\xca\x02\xcb\x02\x09\x00\x73\x00\x50\x00\x51\x00\x74\x00\xcd\x02\x76\x00\x48\x00\x32\x00\xf0\x00\xc2\x03\xbc\x03\xce\x02\x2a\x00\xd3\x02\x19\x02\xef\x01\xd6\x02\x5f\x00\x60\x00\xf1\x00\xd7\x02\xf2\x00\xd8\x02\xd9\x02\xdc\x02\xdd\x02\xeb\x02\x75\x00\x07\x00\x08\x00\x1f\x02\xf3\x00\xfc\x00\xfd\x00\xfe\x00\x09\x00\x4f\x00\x50\x00\x51\x00\xff\x00\x53\x00\x76\x00\x64\x00\xf1\x02\x00\x01\x65\x00\xec\x00\xed\x00\x68\x00\x07\x02\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x1f\x02\xf2\x02\xf8\x02\x03\x03\xee\x00\xef\x00\x09\x03\x0b\x03\x0d\x03\x0f\x03\x14\x03\x13\x02\x55\x00\x09\x02\x30\x02\x2c\x00\x2d\x00\x2e\x02\x2e\x00\x2f\x00\x14\x03\x15\x02\x56\x00\x57\x00\x58\x00\xbd\x03\xbe\x03\xdf\x01\x30\x00\x59\x00\x31\x00\xbf\x03\x35\x02\x2e\x00\x2f\x00\x37\x02\x39\x02\x16\x02\x4e\x00\x73\x00\x4f\x00\x32\x00\x74\x00\xaa\x01\x17\x02\x48\x00\x3c\x02\xf0\x00\x5d\x00\x44\x02\xf2\x01\x5f\x00\x60\x00\x50\x02\x40\x00\x62\x00\x63\x00\x59\x02\xf1\x00\xe1\x01\xf2\x00\x5d\x02\x5a\x02\x78\x02\x5b\x02\x67\x02\x75\x00\x07\x00\x08\x00\x03\x02\xf3\x00\xf4\x00\x61\x02\xf5\x00\x09\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x76\x00\x64\x00\xf9\x00\xf6\x00\x7f\x02\x65\x00\xec\x00\xed\x00\x68\x00\x7a\x02\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x7c\x02\x26\x01\x87\x02\x8a\x02\x03\x01\x8e\x02\x8f\x02\x91\x02\x90\x02\x04\x01\x99\x02\x27\x01\x24\x00\x28\x01\x05\x01\x04\x02\x05\x02\x43\x01\x28\x00\x29\x00\x9d\x02\x9f\x02\xbf\x00\x4b\x00\x66\x01\x4c\x00\x4d\x00\x4e\x00\xa0\x02\x4f\x00\x73\x01\x74\x01\x52\x00\x53\x00\x7a\x01\x7b\x01\x56\x00\x57\x00\x58\x00\x73\x00\x7d\x01\x7c\x01\x74\x00\x59\x00\x87\x01\x48\x00\x80\x01\xf0\x00\x8e\x01\x86\x01\x81\x01\x2a\x00\x88\x01\x89\x01\x8b\x01\x9f\x01\xa1\x01\x8c\x01\xf1\x00\xaa\x01\xf2\x00\xab\x01\xb0\x01\x09\x02\xb1\x01\x5f\x00\x75\x00\x07\x00\x08\x00\x62\x00\xf3\x00\xf4\x00\x8f\x01\xf5\x00\x09\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x76\x00\x64\x00\xb2\x01\xb6\x01\x65\x00\xec\x00\xed\x00\x68\x00\xb7\x01\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\xbb\x01\xb6\x01\xcb\x01\x8b\x01\x06\x01\xd5\xfd\xc8\x01\x24\x00\x07\x01\x08\x01\x04\x02\x05\x02\x55\x00\x28\x00\x29\x00\x2c\x00\x2d\x00\xc1\x01\x2e\x00\x2f\x00\x8c\x01\xc2\x01\x56\x00\x57\x00\x58\x00\xcd\x01\xd4\x01\xcf\x01\x30\x00\x59\x00\x31\x00\xd3\x01\x47\x01\x53\x02\x4e\x00\x49\x01\x4f\x00\x00\x02\xf2\x01\x73\x00\x54\x02\x32\x00\x74\x00\xef\x01\x34\x01\x48\x00\x2a\x00\xf0\x00\x5d\x00\x01\x02\x02\x02\x5f\x00\x60\x00\x03\x02\xe9\xfd\x62\x00\x63\x00\x0c\x02\xf1\x00\x07\x02\xf2\x00\x0e\x02\x10\x02\x0f\x02\xd9\x00\xff\xff\x75\x00\x07\x00\x08\x00\x11\x01\xf3\x00\xf4\x00\x21\x01\xf5\x00\x09\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x76\x00\x64\x00\x12\x01\x13\x01\x19\x01\x65\x00\xec\x00\xed\x00\x68\x00\xff\xff\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x22\x01\x48\xfe\x23\x01\x0a\x01\xbe\x01\x2f\x01\xff\xff\x67\x02\x4f\x01\x2c\x00\x2d\x00\x24\x00\x2e\x00\x2f\x00\x54\x01\x5e\x01\xff\xff\xbf\x00\x54\x01\xff\xff\xbf\x00\x62\x01\x30\x00\x00\x00\x31\x00\xd9\x02\x00\x00\x00\x00\x97\x03\x00\x00\x24\x00\x95\x01\x00\x00\x26\x00\x27\x00\x32\x00\x28\x00\x29\x00\x00\x00\x73\x00\x00\x00\x00\x00\x74\x00\x00\x00\x00\x00\x48\x00\x00\x00\xf0\x00\x00\x00\x00\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf1\x00\x00\x00\xf2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x75\x00\x07\x00\x08\x00\x2a\x00\xf3\x00\xf4\x00\x00\x00\xf5\x00\x09\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x76\x00\x64\x00\x00\x00\x00\x00\x65\x00\xec\x00\xed\x00\x68\x00\x00\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\xbe\x01\x24\x00\x00\x00\xbf\x01\x00\x00\x00\x00\x00\x00\x00\x00\x54\x01\x00\x00\x2c\x00\x2d\x00\x41\x03\x2e\x00\x2f\x00\x56\x01\x3d\x01\x00\x00\x00\x00\x00\x00\x2b\x00\x00\x00\x00\x00\x30\x00\x42\x03\x31\x00\x58\x01\x00\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x2f\x00\x00\x00\x73\x00\x32\x00\x00\x00\x74\x00\x00\x00\x2a\x00\x48\x00\x30\x00\xf0\x00\x31\x00\x00\x00\x00\x00\x05\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf1\x00\x32\x00\xf2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x75\x00\x07\x00\x08\x00\x00\x00\xf3\x00\xf4\x00\x00\x00\xf5\x00\x09\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x76\x00\x64\x00\x00\x00\x00\x00\x00\x00\x65\x00\xec\x00\xed\x00\x68\x00\x00\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x65\x02\x00\x00\x00\x00\x2c\x00\x2d\x00\x03\x03\x2e\x00\x2f\x00\x56\x01\x3d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x04\x03\x31\x00\x58\x01\x26\x01\x24\x00\x3b\x01\x00\x00\x26\x00\x27\x00\x00\x00\x28\x00\x29\x00\x32\x00\x27\x01\x00\x00\x28\x01\x00\x00\x00\x00\x73\x00\x00\x00\x00\x00\x74\x00\x00\x00\x05\x03\x48\x00\x4b\x00\xf0\x00\x4c\x00\x4d\x00\x4e\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x52\x00\x53\x00\x00\x00\xf1\x00\x00\x00\xf2\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x00\x00\x75\x00\x07\x00\x08\x00\x00\x00\xf3\x00\xf4\x00\x00\x00\xf5\x00\x09\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x76\x00\x64\x00\x00\x00\x00\x00\x65\x00\x69\x02\xed\x00\x68\x00\x00\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6a\x02\x00\x00\x00\x00\x24\x00\x37\x01\x00\x00\x26\x00\x27\x00\x00\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x38\x01\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x2f\x00\x3c\x01\x3d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x73\x00\x00\x00\x30\x00\x74\x00\x31\x00\x3e\x01\x48\x00\x2a\x00\xf0\x00\x00\x00\x32\x01\xfd\x00\x4e\x00\x00\x00\x4f\x00\x32\x00\x00\x00\x33\x01\x53\x00\xf1\x00\x00\x00\xf2\x00\x34\x01\x00\x00\x3f\x01\x00\x00\x00\x00\x75\x00\x07\x00\x08\x00\x00\x00\xf3\x00\xf4\x00\x55\x00\xf5\x00\x09\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x76\x00\x64\x00\x56\x00\x57\x00\x58\x00\x65\x00\x72\x02\xed\x00\x68\x00\x59\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x6a\x02\x03\x01\x00\x00\x24\x00\x00\x00\x2c\x00\x2d\x00\xf9\x00\x2e\x00\x2f\x00\x54\x01\x5f\x00\x60\x00\x00\x00\x00\x00\x00\x00\x1f\x02\x20\x02\x30\x00\x00\x00\x31\x00\x24\x00\x95\x01\x21\x02\x22\x02\x27\x00\x23\x02\x24\x02\x29\x00\x00\x00\x5a\x00\x32\x00\x00\x00\x5a\x00\x28\x04\x73\x00\x5c\x00\xc1\x03\x74\x00\x5c\x00\x39\x01\x48\x00\x2a\x00\xf0\x00\x5e\x00\x00\x00\x00\x00\xc2\x03\x61\x00\x00\x00\x00\x00\x41\x00\x64\x00\x00\x00\xf1\x00\x42\x00\xf2\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x00\x00\x75\x00\x07\x00\x08\x00\x00\x00\xf3\x00\xf4\x00\x00\x00\xf5\x00\x09\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x76\x00\x64\x00\x00\x00\x00\x00\x65\x00\xec\x00\xed\x00\x68\x00\x00\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x24\x00\x00\x00\x00\x00\x75\x02\xd4\x03\x00\x00\x6c\x01\x29\x00\x00\x00\x2c\x00\x2d\x00\x55\x01\x2e\x00\x2f\x00\x56\x01\x3d\x01\x00\x00\x00\x00\x25\x02\x00\x00\x00\x00\x00\x00\x30\x00\x57\x01\x31\x00\x58\x01\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x32\x00\x00\x00\x00\x00\x73\x00\x2a\x00\x30\x00\x74\x00\x31\x00\x00\x00\x48\x00\x64\x00\xf0\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\xf1\x00\x00\x00\xf2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x75\x00\x07\x00\x08\x00\x00\x00\xf3\x00\xf4\x00\x00\x00\xf5\x00\x09\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x76\x00\x00\x00\x00\x00\x00\x00\x00\x00\x65\x00\x66\x00\x67\x00\x68\x00\x00\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x2f\x00\x64\x00\x00\x00\x6b\x02\x6c\x02\x6d\x02\x6e\x02\x00\x00\x00\x00\x30\x00\x00\x00\x31\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x6f\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x73\x00\x00\x00\x00\x00\x74\x00\x00\x00\x00\x00\x48\x00\x00\x00\x64\x00\x00\x00\x65\x00\x66\x00\x67\x00\x68\x00\x00\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x75\x00\x07\x00\x08\x00\x00\x00\x73\x02\x6c\x02\x6d\x02\x6e\x02\x09\x00\x00\x00\x50\x00\x51\x00\x00\x00\x00\x00\x76\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x73\x00\x00\x00\x00\x00\x74\x00\x00\x00\x00\x00\x48\x00\x00\x00\x65\x00\x66\x00\x67\x00\x68\x00\x00\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x75\x00\x07\x00\x08\x00\x5c\x03\x6d\x02\x6e\x02\x00\x00\x00\x00\x09\x00\x00\x00\x50\x00\x51\x00\x00\x00\x00\x00\x76\x00\x00\x00\x00\x00\x6f\x00\x00\x00\x00\x00\x65\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\x02\x00\x00\x0b\x01\x6c\x00\x6d\x00\x6e\x00\x73\x00\x64\x00\x00\x00\x74\x00\x00\x00\x00\x00\x48\x00\x65\x00\x66\x00\x67\x00\x68\x00\x00\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x75\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\xe7\x03\xfb\x02\x09\x00\x00\x00\x50\x00\x51\x00\x73\x00\x00\x00\x76\x00\x74\x00\x6f\x00\x00\x00\x48\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfc\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x73\x00\x00\x00\x00\x00\x74\x00\x00\x00\x00\x00\x48\x00\x00\x00\x00\x00\x75\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x00\x00\x50\x00\x51\x00\x00\x00\x00\x00\x76\x00\x00\x00\x00\x00\x00\x00\x75\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x00\x00\x50\x00\x51\x00\x00\x00\x00\x00\x76\x00\x00\x00\x65\x00\xaf\x02\x67\x00\x68\x00\x00\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x65\x00\xaf\x02\x67\x00\x68\x00\x00\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x65\x03\xb1\x02\xb2\x02\x00\x00\x00\x00\x24\x00\x37\x01\xb3\x02\x26\x00\x27\x00\x00\x00\x28\x00\x29\x00\x00\x00\x00\x00\x31\x02\x32\x02\x00\x00\xb0\x02\xb1\x02\xb2\x02\x73\x00\x00\x00\x00\x00\x74\x00\xb3\x02\x00\x00\x48\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x73\x00\x64\x00\x00\x00\x74\x00\x00\x00\x2a\x00\x48\x00\x00\x00\x00\x00\x75\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x24\x00\x00\x00\x09\x00\x00\x00\x50\x00\x51\x00\x1b\x04\x29\x00\x76\x00\x00\x00\x00\x00\x00\x00\x75\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x00\x00\x50\x00\x51\x00\x00\x00\x00\x00\x76\x00\x65\x00\xaf\x02\x67\x00\x68\x00\x00\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x2a\x00\x2b\x00\x00\x00\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x2f\x00\x00\x00\x00\x00\xb5\x02\xb1\x02\xb2\x02\x00\x00\x00\x00\x00\x00\x30\x00\xb3\x02\x31\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x32\x00\x00\x00\x73\x00\x00\x00\x00\x00\x74\x00\x00\x00\x00\x00\x48\x00\x00\x00\x65\x00\x66\x00\x67\x00\x68\x00\x00\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x64\x00\x2e\x00\x2f\x00\x00\x00\x75\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x09\x00\x31\x00\x50\x00\x51\x00\x00\x00\x00\x00\x76\x00\x00\x00\x00\x00\x6f\x00\x00\x00\x00\x00\x32\x00\xbb\x02\x00\x00\x00\x00\xac\x01\x72\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x73\x00\x00\x00\x00\x00\x74\x00\x00\x00\x00\x00\x48\x00\x65\x00\x66\x00\x67\x00\x68\x00\x00\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x75\x00\x07\x00\x08\x00\x26\x01\x00\x00\x00\x00\xfa\x02\xfb\x02\x09\x00\x00\x00\x50\x00\x51\x00\x00\x00\xc9\x01\x76\x00\x28\x01\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfc\x02\x4b\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x73\x00\x4f\x00\x00\x00\x74\x00\x52\x00\x53\x00\x48\x00\x65\x00\x66\x00\x67\x00\x68\x00\x00\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x75\x00\x07\x00\x08\x00\x26\x01\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x00\x00\x50\x00\x51\x00\x00\x00\x27\x01\x76\x00\x28\x01\x6f\x00\x00\x00\x00\x00\x00\x00\x7c\x02\x00\x00\x00\x00\xac\x01\x72\x00\x4b\x00\x00\x00\x4c\x00\x4d\x00\x4e\x00\x73\x00\x4f\x00\x00\x00\x74\x00\x52\x00\x53\x00\x48\x00\x65\x00\x66\x00\x67\x00\x68\x00\x00\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x75\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x00\x00\x50\x00\x51\x00\x00\x00\x00\x00\x76\x00\x00\x00\x6f\x00\x00\x00\x00\x00\x00\x00\xab\x01\x00\x00\x00\x00\xac\x01\x72\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x73\x00\x00\x00\x00\x00\x74\x00\x00\x00\x00\x00\x48\x00\x65\x00\x66\x00\x67\x00\x68\x00\x00\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x75\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x00\x00\x50\x00\x51\x00\x00\x00\x00\x00\x76\x00\x00\x00\x6f\x00\x00\x00\x00\x00\x00\x00\xae\x01\x00\x00\x00\x00\xac\x01\x72\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x73\x00\x00\x00\x00\x00\x74\x00\x00\x00\x00\x00\x48\x00\x65\x00\x66\x00\x67\x00\x68\x00\x00\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x75\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x00\x00\x50\x00\x51\x00\x00\x00\x00\x00\x76\x00\x00\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x70\x00\x71\x00\x72\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x73\x00\x00\x00\x00\x00\x74\x00\x00\x00\x64\x00\x48\x00\x65\x00\x66\x00\x67\x00\x68\x00\x00\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x75\x00\x07\x00\x08\x00\x00\x00\x5a\x03\x00\x00\x00\x00\x00\x00\x09\x00\x00\x00\x50\x00\x51\x00\x00\x00\x00\x00\x76\x00\x00\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5b\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x73\x00\x00\x00\x00\x00\x74\x00\x00\x00\x64\x00\x48\x00\x00\x00\x65\x00\xaf\x02\x67\x00\x68\x00\x00\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x75\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x00\x00\x50\x00\x51\x00\x82\x03\x00\x00\x76\x00\x00\x00\x00\x00\xb3\x02\x00\x00\x00\x00\x65\x00\x66\x00\x67\x00\x68\x00\x00\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x73\x00\x00\x00\x00\x00\x74\x00\x64\x00\x00\x00\x48\x00\x65\x00\x24\x04\x67\x00\x68\x00\x00\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\x00\x54\x01\x75\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\xb0\x03\x00\x00\x09\x00\x00\x00\x50\x00\x51\x00\x73\x00\x64\x00\x76\x00\x74\x00\x00\x00\x00\x00\x48\x00\x65\x00\xf9\x03\x67\x00\x68\x00\x00\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x73\x00\x2a\x00\x00\x00\x74\x00\x00\x00\x00\x00\x48\x00\x00\x00\x00\x00\x75\x00\x07\x00\x08\x00\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x09\x00\x00\x00\x50\x00\x51\x00\x00\x00\x00\x00\x76\x00\x00\x00\x00\x00\x00\x00\x75\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x00\x00\x50\x00\x51\x00\x73\x00\x00\x00\x76\x00\x74\x00\x64\x00\x00\x00\x48\x00\x65\x00\xe0\x03\x67\x00\x68\x00\x00\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x2f\x00\x00\x00\x75\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x09\x00\x31\x00\x50\x00\x51\x00\x00\x00\x64\x00\x76\x00\x00\x00\x65\x00\xe5\x03\x67\x00\x68\x00\x32\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x73\x00\x00\x00\x00\x00\x74\x00\x00\x00\x00\x00\x48\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x00\x00\x00\x00\x65\x00\xe6\x03\x67\x00\x68\x00\x00\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x75\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x73\x00\x50\x00\x51\x00\x74\x00\x00\x00\x76\x00\x48\x00\x64\x00\x00\x00\x00\x00\x65\x00\x8b\x03\x67\x00\x68\x00\x00\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x75\x00\x07\x00\x08\x00\x73\x00\x00\x00\x00\x00\x74\x00\x00\x00\x09\x00\x48\x00\x50\x00\x51\x00\x00\x00\x64\x00\x76\x00\x00\x00\x00\x00\x00\x00\x00\x00\x65\x00\x8c\x03\x67\x00\x68\x00\x00\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x75\x00\x07\x00\x08\x00\x73\x00\x00\x00\x00\x00\x74\x00\x00\x00\x09\x00\x48\x00\x50\x00\x51\x00\x00\x00\x64\x00\x76\x00\x00\x00\x00\x00\x00\x00\x00\x00\x65\x00\x8d\x03\x67\x00\x68\x00\x00\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x75\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x73\x00\x50\x00\x51\x00\x74\x00\x64\x00\x76\x00\x48\x00\x00\x00\x00\x00\x00\x00\x65\x00\xaf\x03\x67\x00\x68\x00\x00\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x75\x00\x07\x00\x08\x00\x73\x00\x00\x00\x00\x00\x74\x00\x00\x00\x09\x00\x48\x00\x50\x00\x51\x00\x00\x00\x64\x00\x76\x00\x00\x00\x65\x00\x59\x03\x67\x00\x68\x00\x00\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x75\x00\x07\x00\x08\x00\x73\x00\x00\x00\x00\x00\x74\x00\x00\x00\x09\x00\x48\x00\x50\x00\x51\x00\x00\x00\x64\x00\x76\x00\x00\x00\x65\x00\x60\x03\x67\x00\x68\x00\x00\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x75\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x73\x00\x00\x00\x09\x00\x74\x00\x50\x00\x51\x00\x48\x00\x64\x00\x76\x00\x00\x00\x65\x00\x61\x03\x67\x00\x68\x00\x00\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x75\x00\x07\x00\x08\x00\x73\x00\x00\x00\x00\x00\x74\x00\x00\x00\x09\x00\x48\x00\x50\x00\x51\x00\x00\x00\x64\x00\x76\x00\x00\x00\x00\x00\x00\x00\x00\x00\x65\x00\xae\x02\x67\x00\x68\x00\x00\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x75\x00\x07\x00\x08\x00\x73\x00\x00\x00\x00\x00\x74\x00\x00\x00\x09\x00\x48\x00\x50\x00\x51\x00\x00\x00\x64\x00\x76\x00\x00\x00\x00\x00\x00\x00\x00\x00\x65\x00\xb6\x02\x67\x00\x68\x00\x00\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x75\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x73\x00\x50\x00\x51\x00\x74\x00\x64\x00\x76\x00\x48\x00\x00\x00\x00\x00\x00\x00\x65\x00\xb7\x02\x67\x00\x68\x00\x00\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x75\x00\x07\x00\x08\x00\x73\x00\x00\x00\x00\x00\x74\x00\x00\x00\x09\x00\x48\x00\x50\x00\x51\x00\x00\x00\x64\x00\x76\x00\x00\x00\x65\x00\xc0\x02\x67\x00\x68\x00\x00\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x75\x00\x07\x00\x08\x00\x73\x00\x00\x00\x00\x00\x74\x00\x00\x00\x09\x00\x48\x00\x50\x00\x51\x00\x00\x00\x64\x00\x76\x00\x00\x00\x65\x00\xc8\x02\x67\x00\x68\x00\x00\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x75\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x73\x00\x00\x00\x09\x00\x74\x00\x50\x00\x51\x00\x48\x00\x64\x00\x76\x00\x00\x00\x65\x00\xfd\x02\x67\x00\x68\x00\x00\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x75\x00\x07\x00\x08\x00\x73\x00\x00\x00\x00\x00\x74\x00\x00\x00\x09\x00\x48\x00\x50\x00\x51\x00\x00\x00\x64\x00\x76\x00\x00\x00\x00\x00\x00\x00\x00\x00\x65\x00\x71\x02\x67\x00\x68\x00\x00\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x75\x00\x07\x00\x08\x00\x73\x00\x00\x00\x00\x00\x74\x00\x00\x00\x09\x00\x48\x00\x50\x00\x51\x00\x00\x00\x64\x00\x76\x00\x00\x00\x00\x00\x00\x00\x00\x00\x65\x00\x74\x02\x67\x00\x68\x00\x00\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x75\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x73\x00\x50\x00\x51\x00\x74\x00\x64\x00\x76\x00\x48\x00\x00\x00\x00\x00\x00\x00\x65\x00\x7a\x02\x67\x00\x68\x00\x00\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x75\x00\x07\x00\x08\x00\x73\x00\x00\x00\x00\x00\x74\x00\x00\x00\x09\x00\x48\x00\x50\x00\x51\x00\x00\x00\x64\x00\x76\x00\x00\x00\x65\x00\x80\x02\x67\x00\x68\x00\x00\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x75\x00\x07\x00\x08\x00\x73\x00\x00\x00\x00\x00\x74\x00\x00\x00\x09\x00\x48\x00\x50\x00\x51\x00\x00\x00\x64\x00\x76\x00\x00\x00\x65\x00\x81\x02\x67\x00\x68\x00\x00\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x75\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x73\x00\x00\x00\x09\x00\x74\x00\x50\x00\x51\x00\x48\x00\x64\x00\x76\x00\x00\x00\x65\x00\x90\x01\x67\x00\x68\x00\x00\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x75\x00\x07\x00\x08\x00\x73\x00\x00\x00\x00\x00\x74\x00\x00\x00\x09\x00\x48\x00\x50\x00\x51\x00\x00\x00\x64\x00\x76\x00\x00\x00\x00\x00\x00\x00\x00\x00\x65\x00\x91\x01\x67\x00\x68\x00\x00\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x75\x00\x07\x00\x08\x00\x73\x00\x00\x00\x00\x00\x74\x00\x00\x00\x09\x00\x48\x00\x50\x00\x51\x00\x00\x00\x64\x00\x76\x00\x00\x00\x00\x00\x00\x00\x00\x00\x65\x00\x92\x01\x67\x00\x68\x00\x00\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x75\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x73\x00\x50\x00\x51\x00\x74\x00\x64\x00\x76\x00\x48\x00\x00\x00\x00\x00\x00\x00\x65\x00\x93\x01\x67\x00\x68\x00\x00\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x75\x00\x07\x00\x08\x00\x73\x00\x00\x00\x00\x00\x74\x00\x00\x00\x09\x00\x48\x00\x50\x00\x51\x00\x00\x00\x64\x00\x76\x00\x00\x00\x65\x00\x9c\x01\x67\x00\x68\x00\x00\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x75\x00\x07\x00\x08\x00\x73\x00\x00\x00\x00\x00\x74\x00\x00\x00\x09\x00\x48\x00\x50\x00\x51\x00\x00\x00\x64\x00\x76\x00\x00\x00\x65\x00\xe2\x00\x67\x00\x68\x00\x00\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x75\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x73\x00\x00\x00\x09\x00\x74\x00\x50\x00\x51\x00\x48\x00\x64\x00\x76\x00\x00\x00\x65\x00\xe8\x00\x67\x00\x68\x00\x00\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x75\x00\x07\x00\x08\x00\x73\x00\x00\x00\x00\x00\x74\x00\x00\x00\x09\x00\x48\x00\x50\x00\x51\x00\x00\x00\x64\x00\x76\x00\x00\x00\x00\x00\x00\x00\x00\x00\x65\x00\x1d\x01\x67\x00\x68\x00\x00\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x75\x00\x07\x00\x08\x00\x73\x00\x00\x00\x00\x00\x74\x00\x00\x00\x09\x00\x48\x00\x50\x00\x51\x00\x00\x00\x64\x00\x76\x00\x00\x00\x00\x00\x00\x00\x00\x00\x65\x00\x1f\x01\x67\x00\x68\x00\x00\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x75\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x73\x00\x50\x00\x51\x00\x74\x00\x64\x00\x76\x00\x48\x00\x00\x00\x00\x00\x00\x00\x65\x00\x24\x01\x67\x00\x68\x00\x00\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x75\x00\x07\x00\x08\x00\x73\x00\x00\x00\x00\x00\x74\x00\x64\x00\x09\x00\x48\x00\x50\x00\x51\x00\x00\x00\x00\x00\x76\x00\x00\x00\x65\x00\x25\x01\x67\x00\x68\x00\x00\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x75\x00\x07\x00\x08\x00\x73\x00\x00\x00\x00\x00\x74\x00\x64\x00\x09\x00\x48\x00\x50\x00\x51\x00\x00\x00\x00\x00\x76\x00\x00\x00\x65\x00\x36\x01\x67\x00\x68\x00\x00\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x75\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x73\x00\x64\x00\x09\x00\x74\x00\x50\x00\x51\x00\x48\x00\x00\x00\x76\x00\x00\x00\x65\x00\x00\x00\xd5\x03\x68\x00\x00\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x75\x00\x07\x00\x08\x00\x73\x00\x64\x00\x00\x00\x74\x00\x00\x00\x09\x00\x48\x00\x50\x00\x51\x00\x00\x00\x65\x00\x76\x00\x51\x03\x68\x00\x00\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x75\x00\x07\x00\x08\x00\x73\x00\x64\x00\x00\x00\x74\x00\x00\x00\x09\x00\x48\x00\x50\x00\x51\x00\x00\x00\x65\x00\x76\x00\xc6\x01\x68\x00\x00\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x75\x00\x07\x00\x08\x00\x73\x00\x00\x00\x00\x00\x74\x00\x64\x00\x09\x00\x48\x00\x50\x00\x51\x00\x00\x00\x65\x00\x76\x00\xe7\x00\x68\x00\x00\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x75\x00\x07\x00\x08\x00\x73\x00\x00\x00\x00\x00\x74\x00\x00\x00\x09\x00\x48\x00\x50\x00\x51\x00\x00\x00\x65\x00\x76\x00\x00\x00\x96\x01\x00\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x75\x00\x07\x00\x08\x00\x73\x00\x64\x00\x00\x00\x74\x00\x00\x00\x09\x00\x48\x00\x50\x00\x51\x00\x00\x00\x65\x00\x76\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x00\x00\x0d\x01\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x75\x00\x07\x00\x08\x00\x73\x00\x00\x00\x00\x00\x74\x00\x64\x00\x09\x00\x48\x00\x50\x00\x51\x00\x00\x00\x00\x00\x76\x00\x00\x00\x65\x00\x00\x00\x00\x00\x00\x00\xb3\x01\x78\x02\x00\x00\x00\x00\x0d\x01\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x75\x00\x07\x00\x08\x00\x73\x00\x00\x00\x00\x00\x74\x00\x00\x00\x09\x00\x48\x00\x50\x00\x51\x00\x00\x00\x00\x00\x76\x00\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb3\x01\xb4\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x75\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x73\x00\x00\x00\x09\x00\x74\x00\x50\x00\x51\x00\x48\x00\x65\x00\x76\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x00\x00\x0d\x01\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x65\x00\x00\x00\x00\x00\x00\x00\x00\x00\x75\x00\x07\x00\x08\x00\xcb\x02\x6d\x00\x6e\x00\x00\x00\x00\x00\x09\x00\x00\x00\x50\x00\x51\x00\x00\x00\x65\x00\x76\x00\x00\x00\x64\x00\x0e\x01\x00\x00\x00\x00\x00\x00\x56\x02\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x73\x00\x00\x00\x00\x00\x74\x00\x00\x00\x00\x00\x48\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x73\x00\x64\x00\x00\x00\x74\x00\x00\x00\x00\x00\x48\x00\x65\x00\x00\x00\x00\x00\x00\x00\x00\x00\x75\x00\x07\x00\x08\x00\x57\x02\x6d\x00\x6e\x00\x73\x00\x00\x00\x09\x00\x74\x00\x50\x00\x51\x00\x48\x00\x00\x00\x76\x00\x75\x00\x07\x00\x08\x00\x00\x00\x64\x00\x00\x00\x00\x00\x00\x00\x09\x00\x00\x00\x50\x00\x51\x00\x00\x00\x65\x00\x76\x00\x00\x00\x00\x00\x00\x00\x75\x00\x07\x00\x08\x00\x9d\x01\x6d\x00\x6e\x00\x00\x00\x00\x00\x09\x00\x00\x00\x50\x00\x51\x00\x73\x00\x00\x00\x76\x00\x74\x00\x64\x00\x00\x00\x48\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x65\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xb2\x01\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x75\x00\x07\x00\x08\x00\x00\x00\x00\x00\x00\x00\x73\x00\x64\x00\x09\x00\x74\x00\x50\x00\x51\x00\x48\x00\x00\x00\x76\x00\x00\x00\x65\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x23\x01\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x75\x00\x07\x00\x08\x00\x73\x00\x64\x00\x00\x00\x74\x00\x00\x00\x09\x00\x48\x00\x50\x00\x51\x00\x00\x00\x65\x00\x76\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xd9\x01\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x75\x00\x07\x00\x08\x00\x73\x00\x64\x00\x00\x00\x74\x00\x00\x00\x09\x00\x48\x00\x50\x00\x51\x00\x00\x00\x65\x00\x76\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0a\x01\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x75\x00\x07\x00\x08\x00\x73\x00\x00\x00\x00\x00\x74\x00\x00\x00\x09\x00\x48\x00\x50\x00\x51\x00\x00\x00\x65\x00\x76\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x01\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x75\x00\x07\x00\x08\x00\x73\x00\x00\x00\x00\x00\x74\x00\x00\x00\x09\x00\x48\x00\x50\x00\x51\x00\x00\x00\x65\x00\x76\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x16\x01\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x75\x00\x07\x00\x08\x00\x73\x00\x00\x00\x00\x00\x74\x00\x00\x00\x09\x00\x48\x00\x50\x00\x51\x00\x00\x00\x65\x00\x76\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x23\x01\x6d\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x75\x00\x07\x00\x08\x00\x73\x00\x00\x00\x00\x00\x74\x00\x00\x00\x09\x00\x48\x00\x50\x00\x51\x00\x00\x00\x00\x00\x76\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x75\x00\x07\x00\x08\x00\x73\x00\x00\x00\x00\x00\x74\x00\x00\x00\x09\x00\x48\x00\x50\x00\x51\x00\x00\x00\x00\x00\x76\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x75\x00\x07\x00\x08\x00\xbd\x02\x00\x00\x00\x00\x00\x00\x00\x00\x09\x00\x00\x00\x50\x00\x51\x00\x00\x00\x00\x00\x76\x00\x78\x00\x0b\x00\x79\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\x7a\x00\x00\x00\x0c\x00\x7b\x00\xbf\x00\x00\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\x00\x00\xc5\x00\x2a\x00\x0d\x00\x00\x00\xc6\x00\x00\x00\x7d\x00\x0e\x00\xc7\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x7e\x00\x15\x00\x16\x00\x17\x00\x18\x00\x7f\x00\x00\x00\x19\x00\x00\x00\x00\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x81\x00\x82\x00\x83\x00\xcc\x00\xcd\x00\x00\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x00\x00\x86\x00\xd2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x2f\x00\x00\x00\x88\x00\x00\x00\x89\x00\x00\x00\xd3\x00\x00\x00\x8b\x00\x30\x00\x8c\x00\x31\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x5e\x00\x00\x00\x00\x00\x1c\x00\x61\x00\x00\x00\x32\x00\x1d\x00\x64\x00\x43\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x46\x00\x78\x00\x0b\x00\x79\x00\xbb\x00\xbc\x00\xbd\x00\xbe\x00\x7a\x00\x00\x00\x0c\x00\x7b\x00\x00\x00\x00\x00\xc0\x00\xc1\x00\xc2\x00\xc3\x00\xc4\x00\x00\x00\xc5\x00\x00\x00\x0d\x00\x00\x00\xc6\x00\x00\x00\x7d\x00\x0e\x00\xc7\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x7e\x00\x15\x00\x16\x00\x17\x00\x18\x00\x7f\x00\x00\x00\x19\x00\x00\x00\x00\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\xcb\x00\x81\x00\x82\x00\x83\x00\xcc\x00\xcd\x00\x00\x00\xce\x00\xcf\x00\xd0\x00\xd1\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x00\x00\x86\x00\xd2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x00\x00\x89\x00\x24\x00\xd3\x00\x00\x00\x8b\x00\xd6\x03\x8c\x00\x6c\x01\x29\x00\x00\x00\x00\x00\x1b\x00\x5e\x00\x00\x00\x00\x00\x1c\x00\x61\x00\x00\x00\x00\x00\x1d\x00\x64\x00\x43\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x2a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x46\x00\x78\x00\x0b\x00\x79\x00\x00\x00\xac\x03\xad\x03\x00\x00\x7a\x00\x00\x00\x0c\x00\x7b\x00\x00\x00\x00\x00\xc0\x00\xc1\x00\xc2\x00\x00\x00\xc4\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\xae\x03\x00\x00\x7d\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x7e\x00\x15\x00\x16\x00\x17\x00\x18\x00\x7f\x00\x00\x00\x19\x00\x00\x00\x00\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\x00\x00\x81\x00\x82\x00\x83\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x30\x00\x00\x00\x31\x00\x85\x00\x00\x00\x86\x00\xd2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x00\x00\x89\x00\x24\x00\xd3\x00\x00\x00\x8b\x00\x9b\x03\x8c\x00\x6c\x01\x29\x00\x00\x00\x00\x00\x1b\x00\x5e\x00\x00\x00\x00\x00\x1c\x00\x61\x00\x00\x00\x00\x00\x1d\x00\x64\x00\x43\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x2a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x46\x00\x78\x00\x0b\x00\x79\x00\x00\x00\x3c\x03\x00\x00\x00\x00\x7a\x00\x00\x00\x0c\x00\x7b\x00\x00\x00\x00\x00\xc0\x00\xc1\x00\xc2\x00\x00\x00\xc4\x00\x00\x00\xc5\x00\x00\x00\x0d\x00\x00\x00\x3d\x03\x00\x00\x7d\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x7e\x00\x15\x00\x16\x00\x17\x00\x18\x00\x7f\x00\x00\x00\x19\x00\x00\x00\x00\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\x00\x00\x81\x00\x82\x00\x83\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x30\x00\x00\x00\x31\x00\x85\x00\x00\x00\x86\x00\xd2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x00\x00\x89\x00\x24\x00\xd3\x00\x00\x00\x8b\x00\x9c\x03\x8c\x00\x6c\x01\x29\x00\x00\x00\x00\x00\x1b\x00\x5e\x00\x00\x00\x00\x00\x1c\x00\x61\x00\x00\x00\x00\x00\x1d\x00\x64\x00\x43\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x2a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x46\x00\x78\x00\x0b\x00\x79\x00\x00\x00\xac\x03\xad\x03\x00\x00\x7a\x00\x00\x00\x0c\x00\x7b\x00\x00\x00\x00\x00\xc0\x00\xc1\x00\xc2\x00\x00\x00\xc4\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\xae\x03\x00\x00\x7d\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x7e\x00\x15\x00\x16\x00\x17\x00\x18\x00\x7f\x00\x00\x00\x19\x00\x00\x00\x00\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\x00\x00\x81\x00\x82\x00\x83\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x30\x00\x00\x00\x31\x00\x85\x00\x00\x00\x86\x00\xd2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x00\x00\x89\x00\x24\x00\xd3\x00\x00\x00\x8b\x00\x9d\x03\x8c\x00\x6c\x01\x29\x00\x00\x00\x00\x00\x1b\x00\x5e\x00\x00\x00\x00\x00\x1c\x00\x61\x00\x00\x00\x00\x00\x1d\x00\x64\x00\x43\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x2a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x46\x00\x78\x00\x0b\x00\x79\x00\x00\x00\x3c\x03\x00\x00\x00\x00\x7a\x00\x00\x00\x0c\x00\x7b\x00\x00\x00\x00\x00\xc0\x00\xc1\x00\xc2\x00\x00\x00\xc4\x00\x00\x00\xc5\x00\x00\x00\x0d\x00\x00\x00\x3d\x03\x00\x00\x7d\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x7e\x00\x15\x00\x16\x00\x17\x00\x18\x00\x7f\x00\x00\x00\x19\x00\x00\x00\x00\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\x00\x00\x81\x00\x82\x00\x83\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x30\x00\x00\x00\x31\x00\x85\x00\x00\x00\x86\x00\xd2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x00\x00\x89\x00\x24\x00\xd3\x00\x00\x00\x8b\x00\xa1\x03\x8c\x00\x6c\x01\x29\x00\x00\x00\x00\x00\x1b\x00\x5e\x00\x00\x00\x00\x00\x1c\x00\x61\x00\x00\x00\x00\x00\x1d\x00\x64\x00\x43\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x2a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x46\x00\x78\x00\x0b\x00\x79\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7a\x00\x00\x00\x0c\x00\x7b\x00\x00\x00\x00\x00\xc0\x00\xc1\x00\xc2\x00\x00\x00\xc4\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x7d\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x7e\x00\x15\x00\x16\x00\x17\x00\x18\x00\x7f\x00\x00\x00\x19\x00\x00\x00\x00\x00\xc8\x00\xc9\x00\xca\x00\x00\x00\x00\x00\x81\x00\x82\x00\x83\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x30\x00\x00\x00\x31\x00\x85\x00\x00\x00\x86\x00\xd2\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x00\x00\x89\x00\x24\x00\xd3\x00\x00\x00\x8b\x00\x25\x03\x8c\x00\x6c\x01\x29\x00\x00\x00\x00\x00\x1b\x00\x5e\x00\x00\x00\x00\x00\x1c\x00\x61\x00\x00\x00\x00\x00\x1d\x00\x64\x00\x43\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\xd4\x00\xd5\x00\xd6\x00\xd7\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x2a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x46\x00\x78\x00\x0b\x00\x79\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7a\x00\x00\x00\x0c\x00\x7b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc4\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x7d\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x7e\x00\x15\x00\x16\x00\x17\x00\x18\x00\x7f\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x82\x00\x83\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x00\x00\x84\x00\x00\x00\x30\x00\x00\x00\x31\x00\x85\x00\x00\x00\x86\x00\x57\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x00\x00\x89\x00\x24\x00\x8a\x00\x8a\x01\x8b\x00\x26\x03\x8c\x00\x6c\x01\x29\x00\x7f\x01\xfa\x00\x1b\x00\x5e\x00\x5f\x00\x60\x00\x1c\x00\x61\x00\x62\x00\x63\x00\x1d\x00\x64\x00\x43\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x2a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x46\x00\x78\x00\x0b\x00\x79\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7a\x00\x00\x00\x0c\x00\x7b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc4\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x7d\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x7e\x00\x15\x00\x16\x00\x17\x00\x18\x00\x7f\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x82\x00\x83\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x00\x00\x84\x00\x00\x00\x30\x00\x00\x00\x31\x00\x85\x00\x00\x00\x86\x00\x57\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x00\x00\x89\x00\x24\x00\x8a\x00\x00\x00\x8b\x00\x8d\x01\x8c\x00\x1c\x04\x29\x00\x7f\x01\xfa\x00\x1b\x00\x5e\x00\x5f\x00\x60\x00\x1c\x00\x61\x00\x62\x00\x63\x00\x1d\x00\x64\x00\x43\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x2a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x46\x00\x78\x00\x0b\x00\x79\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7a\x00\x00\x00\x0c\x00\x7b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc4\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x7d\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x7e\x00\x15\x00\x16\x00\x17\x00\x18\x00\x7f\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x82\x00\x83\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x00\x00\x84\x00\x00\x00\x30\x00\x00\x00\x31\x00\x85\x00\x00\x00\x02\x01\x57\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x00\x00\x89\x00\x24\x00\x8a\x00\x03\x01\x8b\x00\x27\x03\x8c\x00\x6c\x01\x29\x00\xf9\x00\xfa\x00\x1b\x00\x5e\x00\x5f\x00\x60\x00\x1c\x00\x61\x00\x62\x00\x63\x00\x1d\x00\x64\x00\x43\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x2a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x46\x00\x78\x00\x0b\x00\x79\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7a\x00\x00\x00\x0c\x00\x7b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc4\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x7d\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x7e\x00\x15\x00\x16\x00\x17\x00\x18\x00\x7f\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x82\x00\x83\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x00\x00\x84\x00\x00\x00\x30\x00\x00\x00\x31\x00\x85\x00\x00\x00\x86\x00\x57\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x00\x00\x89\x00\x24\x00\x8a\x00\x00\x00\x8b\x00\xf8\x00\x8c\x00\x9a\x03\x29\x00\xf9\x00\xfa\x00\x1b\x00\x5e\x00\x5f\x00\x60\x00\x1c\x00\x61\x00\x62\x00\x63\x00\x1d\x00\x64\x00\x43\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x2a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x46\x00\x78\x00\x0b\x00\x79\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7a\x00\x00\x00\x0c\x00\x7b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc4\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x7d\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x7e\x00\x15\x00\x16\x00\x17\x00\x18\x00\x7f\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x82\x00\x83\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x00\x00\x84\x00\x00\x00\x30\x00\x00\x00\x31\x00\x85\x00\x00\x00\x02\x01\x57\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x00\x00\x89\x00\x24\x00\x8a\x00\x03\x01\x8b\x00\xf8\x02\x8c\x00\x6c\x01\x29\x00\xf9\x00\xfa\x00\x1b\x00\x5e\x00\x5f\x00\x60\x00\x1c\x00\x61\x00\x62\x00\x63\x00\x1d\x00\x64\x00\x43\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x2a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x46\x00\x78\x00\x0b\x00\x79\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7a\x00\x00\x00\x0c\x00\x7b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc4\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x7d\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x7e\x00\x15\x00\x16\x00\x17\x00\x18\x00\x7f\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x82\x00\x83\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x00\x00\x84\x00\x00\x00\x30\x00\x00\x00\x31\x00\x85\x00\x00\x00\x86\x00\x57\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x00\x00\x89\x00\x24\x00\x8a\x00\x00\x00\x8b\x00\x30\x02\x8c\x00\x6c\x01\x29\x00\x7f\x01\xfa\x00\x1b\x00\x5e\x00\x5f\x00\x60\x00\x1c\x00\x61\x00\x62\x00\x63\x00\x1d\x00\x64\x00\x43\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x2a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x46\x00\x78\x00\x0b\x00\x79\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7a\x00\x00\x00\x0c\x00\x7b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc4\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x7d\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x7e\x00\x15\x00\x16\x00\x17\x00\x18\x00\x7f\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x82\x00\x83\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x00\x00\x84\x00\x00\x00\x30\x00\x00\x00\x31\x00\x85\x00\x00\x00\x86\x00\x57\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x0a\x01\x89\x00\x24\x00\x8a\x00\x00\x00\x8b\x00\x39\x02\x8c\x00\x6c\x01\x29\x00\x00\x00\xfa\x00\x1b\x00\x5e\x00\x5f\x00\x60\x00\x1c\x00\x61\x00\x62\x00\x63\x00\x1d\x00\x64\x00\x43\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x2a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x46\x00\x78\x00\x0b\x00\x79\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7a\x00\x00\x00\x0c\x00\x7b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc4\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x7d\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x7e\x00\x15\x00\x16\x00\x17\x00\x18\x00\x7f\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x82\x00\x83\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x00\x00\x84\x00\x00\x00\x30\x00\x00\x00\x31\x00\x85\x00\x00\x00\x86\x00\x57\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x00\x00\x89\x00\x24\x00\x8a\x00\x00\x00\x8b\x00\x3a\x02\x8c\x00\x6c\x01\x29\x00\x00\x00\xfa\x00\x1b\x00\x5e\x00\x5f\x00\x60\x00\x1c\x00\x61\x00\x62\x00\x63\x00\x1d\x00\x64\x00\x43\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x2a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x46\x00\x78\x00\x0b\x00\x79\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7a\x00\x00\x00\x0c\x00\x7b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x7d\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x7e\x00\x15\x00\x16\x00\x17\x00\x18\x00\x7f\x00\x80\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x82\x00\x83\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x30\x00\x00\x00\x31\x00\x85\x00\x00\x00\x86\x00\x87\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x00\x00\x89\x00\x00\x00\x8a\x00\x00\x00\x8b\x00\x00\x00\x8c\x00\x00\x00\xae\x01\x00\x00\x00\x00\x1b\x00\x5e\x00\x00\x00\x00\x00\x1c\x00\x61\x00\x00\x00\x00\x00\x1d\x00\x64\x00\x43\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x46\x00\x78\x00\x0b\x00\x79\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7a\x00\x00\x00\x0c\x00\x7b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x71\x02\x00\x00\x00\x00\x7d\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x7e\x00\x15\x00\x16\x00\x17\x00\x18\x00\x7f\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x82\x00\x83\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x00\x00\x86\x00\x87\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x00\x00\x89\x00\x24\x00\x8a\x00\x00\x00\x8b\x00\x6b\x01\x8c\x00\x6c\x01\x29\x00\x00\x00\x00\x00\x1b\x00\x5e\x00\x00\x00\x00\x00\x1c\x00\x61\x00\x00\x00\x00\x00\x1d\x00\x64\x00\x43\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x2a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x46\x00\x78\x00\x0b\x00\x79\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7a\x00\x00\x00\x0c\x00\x7b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc4\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x7d\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x7e\x00\x15\x00\x16\x00\x17\x00\x18\x00\x7f\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x82\x00\x83\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x30\x00\x00\x00\x31\x00\x85\x00\x00\x00\x86\x00\x87\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x00\x00\x89\x00\x00\x00\x8a\x00\x00\x00\x8b\x00\x00\x00\x8c\x00\x00\x00\xb5\x02\x00\x00\x00\x00\x1b\x00\x5e\x00\x00\x00\x00\x00\x1c\x00\x61\x00\x00\x00\x00\x00\x1d\x00\x64\x00\x43\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x46\x00\x78\x00\x0b\x00\x79\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7a\x00\x00\x00\x0c\x00\x7b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x71\x02\x00\x00\x00\x00\x7d\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x7e\x00\x15\x00\x16\x00\x17\x00\x18\x00\x7f\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x82\x00\x83\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x00\x00\x86\x00\x87\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x00\x00\x89\x00\x24\x00\x8a\x00\x00\x00\x8b\x00\x6d\x01\x8c\x00\x6c\x01\x29\x00\x00\x00\x00\x00\x1b\x00\x5e\x00\x00\x00\x00\x00\x1c\x00\x61\x00\x00\x00\x00\x00\x1d\x00\x64\x00\x43\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x2a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x46\x00\x78\x00\x0b\x00\x79\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7a\x00\x00\x00\x0c\x00\x7b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x7d\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x7e\x00\x15\x00\x16\x00\x17\x00\x18\x00\x7f\x00\x80\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x82\x00\x83\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x30\x00\x00\x00\x31\x00\x85\x00\x00\x00\x86\x00\x87\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x00\x00\x89\x00\x24\x00\x8a\x00\x00\x00\x8b\x00\x6e\x01\x8c\x00\x6c\x01\x29\x00\x00\x00\x00\x00\x1b\x00\x5e\x00\x00\x00\x00\x00\x1c\x00\x61\x00\x00\x00\x00\x00\x1d\x00\x64\x00\x43\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x2a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x46\x00\x78\x00\x0b\x00\x79\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7a\x00\x00\x00\x0c\x00\x7b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x7d\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x7e\x00\x15\x00\x16\x00\x17\x00\x18\x00\x7f\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x82\x00\x83\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x30\x00\x00\x00\x31\x00\x85\x00\x00\x00\x86\x00\x87\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x00\x00\x89\x00\x24\x00\x8a\x00\x00\x00\x8b\x00\x8f\x01\x8c\x00\x6c\x01\x29\x00\x00\x00\x00\x00\x1b\x00\x5e\x00\x00\x00\x00\x00\x1c\x00\x61\x00\x00\x00\x00\x00\x1d\x00\x64\x00\x43\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x2a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x46\x00\x78\x00\x0b\x00\x79\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7a\x00\x00\x00\x0c\x00\x7b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc4\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x7d\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x7e\x00\x15\x00\x16\x00\x17\x00\x18\x00\x7f\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x82\x00\x83\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x30\x00\x00\x00\x31\x00\x85\x00\x00\x00\x86\x00\x87\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x00\x00\x89\x00\x24\x00\x8a\x00\x00\x00\x8b\x00\xf8\x01\x8c\x00\x6c\x01\x29\x00\x00\x00\x00\x00\x1b\x00\x5e\x00\x00\x00\x00\x00\x1c\x00\x61\x00\x00\x00\x00\x00\x1d\x00\x64\x00\x43\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x2a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x46\x00\x78\x00\x0b\x00\x79\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7a\x00\x00\x00\x0c\x00\x7b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7c\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x7d\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x7e\x00\x15\x00\x16\x00\x17\x00\x18\x00\x7f\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x82\x00\x83\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x30\x00\x00\x00\x31\x00\x85\x00\x00\x00\x86\x00\x87\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x00\x00\x89\x00\x24\x00\x8a\x00\x00\x00\x8b\x00\x00\x00\x8c\x00\x22\x03\x29\x00\x00\x00\x00\x00\x1b\x00\x5e\x00\x00\x00\x00\x00\x1c\x00\x61\x00\x00\x00\x00\x00\x1d\x00\x64\x00\x43\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x2a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x46\x00\x78\x00\x0b\x00\x79\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7a\x00\x00\x00\x0c\x00\x7b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc4\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x7d\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x7e\x00\x15\x00\x16\x00\x17\x00\x18\x00\x7f\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x82\x00\x83\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x30\x00\x00\x00\x31\x00\x85\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x00\x00\x89\x00\x24\x00\x8a\x00\x00\x00\x8b\x00\x00\x00\x8c\x00\xa3\x02\x29\x00\x00\x00\x00\x00\x1b\x00\x5e\x00\x00\x00\x00\x00\x1c\x00\x61\x00\x00\x00\x00\x00\x1d\x00\x64\x00\x43\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x2a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x46\x00\x78\x00\x0b\x00\x79\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7a\x00\x00\x00\x0c\x00\x7b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc4\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x7d\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x7e\x00\x15\x00\x16\x00\x17\x00\x18\x00\x7f\x00\x00\x00\xc2\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x82\x00\x83\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x30\x00\x00\x00\x31\x00\x85\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x00\x00\x89\x00\x24\x00\x8a\x00\x00\x00\x8b\x00\x00\x00\x8c\x00\x69\x01\x29\x00\x00\x00\x00\x00\x1b\x00\x5e\x00\x00\x00\x00\x00\x1c\x00\x61\x00\x00\x00\x00\x00\x1d\x00\x64\x00\x43\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x2a\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x46\x00\x78\x00\x0b\x00\x79\x00\x00\x00\x00\x00\x00\x00\x00\x00\x7a\x00\x00\x00\x0c\x00\x7b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xc4\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x7d\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x7e\x00\x15\x00\x16\x00\x17\x00\x18\x00\x7f\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x00\x82\x00\x83\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x84\x00\x00\x00\x30\x00\x00\x00\x31\x00\x85\x00\x00\x00\x86\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x24\x00\x00\x00\x88\x00\x00\x00\x89\x00\x00\x00\x8a\x00\x54\x01\x8b\x00\x00\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x5e\x00\x00\x00\x00\x00\x1c\x00\x61\x00\x00\x00\x00\x00\x1d\x00\x64\x00\x43\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x46\x00\x78\x00\x0b\x00\x00\x00\x55\x00\x2a\x01\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x56\x00\x57\x00\x58\x00\x2b\x01\x2c\x01\x2d\x01\x2e\x01\x59\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x00\x00\x15\x00\x16\x00\x17\x00\x18\x00\x5d\x00\x00\x00\x19\x00\x5f\x00\x60\x00\x00\x00\x00\x00\x62\x00\x63\x00\x2c\x00\x2d\x00\x55\x01\x2e\x00\x2f\x00\x56\x01\x3d\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x57\x01\x31\x00\x58\x01\x00\x00\x00\x00\x00\x00\x00\x00\x85\x00\x00\x00\x00\x00\x10\x01\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x00\x00\x00\x00\x00\x00\x88\x00\x00\x00\x89\x00\x54\x01\x8a\x00\x00\x00\x8b\x00\x00\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x24\x00\x1b\x00\x5e\x00\x00\x00\x00\x00\x1c\x00\x61\x00\x5e\x01\x00\x00\x1d\x00\x64\x00\x43\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x00\x00\x2a\x00\x00\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x46\x00\x78\x00\x0b\x00\x00\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x00\x00\x15\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x31\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x2f\x00\x00\x00\x00\x00\x85\x00\x00\x00\x00\x00\x32\x00\x00\x00\x00\x00\x30\x00\x00\x00\x31\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x00\x00\x89\x00\x32\x00\x8a\x00\x00\x00\x8b\x00\x00\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x5e\x00\x00\x00\x00\x00\x1c\x00\x61\x00\x00\x00\x00\x00\x1d\x00\x64\x00\x43\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x46\x00\x78\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x09\x02\x3a\xff\x0c\x00\x3a\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x57\x00\x58\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x59\x00\x00\x00\x00\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x00\x00\x15\x00\x16\x00\x17\x00\x18\x00\x0b\x00\x00\x00\x19\x00\x5d\x00\x00\x00\x00\x00\x5f\x00\x60\x00\x0c\x00\x00\x00\x62\x00\x63\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x00\x00\x15\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x88\x00\x00\x00\x89\x00\x00\x00\x8a\x00\x00\x00\x8b\x00\x00\x00\x8c\x00\x65\x02\x00\x00\x00\x00\x00\x00\x1b\x00\x5e\x00\x00\x00\x00\x00\x1c\x00\x61\x00\x00\x00\x00\x00\x1d\x00\x64\x00\x43\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x78\x01\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x46\x00\x78\x00\x0b\x00\x00\x00\x1b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe4\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x00\x00\x15\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x85\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x00\x00\x15\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x88\x00\x00\x00\x89\x00\x00\x00\x8a\x00\x00\x00\x8b\x00\x00\x00\x8c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x5e\x00\x00\x00\x00\x00\x1c\x00\x61\x00\x00\x00\x00\x00\x1d\x00\x64\x00\x43\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x00\x00\x00\x00\x00\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x00\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x46\x00\x78\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x5e\x00\x0c\x00\x00\x00\x1c\x00\x61\x00\x00\x00\x00\x00\x1d\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x00\x00\x15\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x0d\x00\x00\x00\xcf\x03\x00\x00\x00\x00\xd0\x03\x29\x00\x0f\x00\x10\x00\x11\x00\x35\x00\x36\x00\x37\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x88\x00\x19\x00\x89\x00\x00\x00\x8a\x00\x00\x00\x8b\x00\xd1\x03\x8c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x5e\x00\x00\x00\x00\x00\x1c\x00\x61\x00\x2a\x00\x00\x00\x1d\x00\x64\x00\x43\x00\x8d\x00\x8e\x00\x8f\x00\x90\x00\x91\x00\x92\x00\x93\x00\x94\x00\x95\x00\x96\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x97\x00\x98\x00\x99\x00\x9a\x00\x0c\x00\x9b\x00\x9c\x00\x9d\x00\x9e\x00\x46\x00\x00\x00\x71\x01\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x3f\x00\x00\x00\x43\x01\x0f\x00\x10\x00\x11\x00\x35\x00\x36\x00\x37\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x31\x00\x00\x00\x00\x00\x22\xff\x00\x00\x22\xff\x00\x00\x07\x03\x00\x00\x08\x03\x23\xff\x32\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x01\x3a\x00\x00\x00\x00\x00\x0b\x00\x00\x00\x00\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x3d\x00\x0c\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x01\x3f\x00\x40\x00\x43\x01\x44\x01\x0d\x00\x41\x00\x00\x00\x45\x01\x00\x00\x42\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x35\x00\x36\x00\x37\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\xd5\x00\x00\x00\x19\x00\x00\x00\x00\x00\xfc\x01\x00\x00\x00\x00\x44\x00\x45\x00\x24\x00\x95\x01\x46\x00\x26\x00\x27\x00\x38\x00\x28\x00\x29\x00\xb8\x03\x11\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x03\x00\x00\x45\x03\x23\xff\x00\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x01\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x0b\x00\x3c\x00\x2a\x00\x3d\x00\x00\x00\x3e\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x5d\x01\x3f\x00\x40\x00\x43\x01\x44\x01\x00\x00\x41\x00\x00\x00\x45\x01\x0d\x00\x42\x00\x00\x00\x00\x00\x00\x00\x34\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x35\x00\x36\x00\x37\x00\x00\x00\xd5\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x44\x00\x45\x00\x00\x00\x00\x00\x46\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x2f\x00\x41\x01\x00\x00\x00\x00\x00\x00\x00\x00\x39\x00\x00\x00\x00\x00\x30\x00\x00\x00\x31\x00\x00\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x3b\x00\x00\x00\x3c\x00\x32\x00\x3d\x00\x42\x01\x3e\x00\x0c\x00\x00\x00\x00\x00\x00\x00\xf9\x00\x00\x00\x3f\x00\x40\x00\x43\x01\x44\x01\x00\x00\x41\x00\x0d\x00\x45\x01\x00\x00\x42\x00\x43\x00\x00\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x35\x00\x36\x00\x37\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x00\x00\x46\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5a\x01\x00\x00\x5b\x01\x23\xff\x00\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x01\x3a\x00\x00\x00\x00\x00\x0b\x00\x00\x00\x00\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x3d\x00\x0c\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x01\x3f\x00\x40\x00\x43\x01\x44\x01\x0d\x00\x41\x00\x00\x00\x45\x01\x00\x00\x42\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x35\x00\x36\x00\x37\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x00\x00\x46\x00\x00\x00\x00\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5a\x01\x00\x00\x9e\x02\x00\x00\x00\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5c\x01\x3a\x00\x00\x00\x00\x00\x0b\x00\x00\x00\x00\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x3d\x00\x0c\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5d\x01\x3f\x00\x40\x00\x43\x01\x44\x01\x0d\x00\x41\x00\x00\x00\x45\x01\x00\x00\x42\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x35\x00\x36\x00\x37\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x00\x00\x46\x00\x00\x00\x00\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x04\x23\xff\x00\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x3d\x00\x00\x00\x3e\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x04\x3f\x00\x40\x00\x00\x00\x60\x00\x00\x00\x41\x00\x0d\x00\x00\x00\x00\x00\x42\x00\x00\x00\x34\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x35\x00\x36\x00\x37\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x00\x00\x46\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x00\x00\x0b\x00\x00\x00\x00\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x3d\x00\x0c\x00\x3e\x00\x3b\x01\x00\x00\x00\x00\x00\x00\xf9\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x0d\x00\x41\x00\x00\x00\x00\x00\x00\x00\x42\x00\x43\x00\x0f\x00\x10\x00\x11\x00\x35\x00\x36\x00\x37\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x24\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x19\x04\x29\x00\x44\x00\x45\x00\x00\x00\x00\x00\x46\x00\x00\x00\x00\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x3a\x00\x00\x00\x00\x00\x0b\x00\x00\x00\x00\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x3d\x00\x0c\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x04\x3f\x00\x40\x00\x00\x00\x60\x00\x0d\x00\x41\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x35\x00\x36\x00\x37\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x00\x00\x46\x00\x00\x00\x00\x00\x38\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x2f\x00\x00\x00\x00\x00\x1e\xff\x00\x00\x1e\xff\x00\x00\x00\x00\x00\x00\x30\x00\x24\xff\x31\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x00\x00\x32\x00\x00\x00\x0b\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x3d\x00\x00\x00\x3e\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x41\x00\x0d\x00\x00\x00\x00\x00\x42\x00\x00\x00\x34\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x35\x00\x36\x00\x37\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x00\x00\x46\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x3d\x00\xbb\x03\x3e\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x41\x00\x0d\x00\x00\x00\x00\x00\x42\x00\x43\x00\x34\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x35\x00\x36\x00\x37\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x00\x00\x46\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x3b\x00\x00\x00\x3c\x00\x47\x01\x3d\x00\x00\x00\x3e\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x41\x00\x0d\x00\x00\x00\x00\x00\x42\x00\x43\x00\x34\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x35\x00\x36\x00\x37\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x00\x00\x46\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x3b\x00\x49\x01\x3c\x00\x00\x00\x3d\x00\x00\x00\x3e\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x41\x00\x0d\x00\x00\x00\x00\x00\x42\x00\x43\x00\x34\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x35\x00\x36\x00\x37\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x00\x00\x46\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x3d\x00\x00\x00\x3e\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x41\x00\x0d\x00\x00\x00\x00\x00\x42\x00\x43\x00\xea\x02\x00\x00\x0f\x00\x10\x00\x11\x00\x35\x00\x36\x00\x37\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x00\x00\x46\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x3d\x00\x00\x00\x3e\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x41\x00\x0d\x00\x00\x00\x00\x00\x42\x00\x43\x00\x34\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x35\x00\x36\x00\x37\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x00\x00\x46\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x3d\x00\x00\x00\x3e\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x41\x00\x0d\x00\x00\x00\x00\x00\x42\x00\x43\x00\xea\x02\x00\x00\x0f\x00\x10\x00\x11\x00\x35\x00\x36\x00\x37\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x00\x00\x46\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x3d\x00\x00\x00\x3e\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x41\x00\x0d\x00\x00\x00\x00\x00\x42\x00\x43\x00\x34\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x35\x00\x36\x00\x37\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x00\x00\x46\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x3d\x00\x00\x00\x3e\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x41\x00\x0d\x00\x00\x00\x00\x00\x42\x00\x43\x00\xea\x02\x00\x00\x0f\x00\x10\x00\x11\x00\x35\x00\x36\x00\x37\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x00\x00\x46\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x3d\x00\x00\x00\x3e\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x41\x00\x0d\x00\x00\x00\x00\x00\x42\x00\x43\x00\x27\x02\x00\x00\x0f\x00\x10\x00\x11\x00\x35\x00\x36\x00\x37\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x00\x00\x46\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x3d\x00\x00\x00\x3e\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x41\x00\x0d\x00\x00\x00\x00\x00\x42\x00\x43\x00\xea\x02\x00\x00\x0f\x00\x10\x00\x11\x00\x35\x00\x36\x00\x37\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x00\x00\x46\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x3d\x00\x00\x00\x3e\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x41\x00\x0d\x00\x00\x00\x00\x00\x42\x00\x43\x00\x27\x02\x00\x00\x0f\x00\x10\x00\x11\x00\x35\x00\x36\x00\x37\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x00\x00\x46\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x3d\x00\x00\x00\x3e\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x41\x00\x0d\x00\x00\x00\x00\x00\x42\x00\x43\x00\xea\x02\x00\x00\x0f\x00\x10\x00\x11\x00\x35\x00\x36\x00\x37\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x00\x00\x46\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x3d\x00\x00\x00\x3e\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x41\x00\x0d\x00\x00\x00\x00\x00\x42\x00\x43\x00\x34\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x35\x00\x36\x00\x37\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x00\x00\x46\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x3d\x00\x00\x00\x3e\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x41\x00\x0d\x00\x00\x00\x00\x00\x42\x00\x43\x00\xea\x02\x00\x00\x0f\x00\x10\x00\x11\x00\x35\x00\x36\x00\x37\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x00\x00\x46\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x3d\x00\x00\x00\x3e\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x41\x00\x0d\x00\x00\x00\x00\x00\x42\x00\x43\x00\x27\x02\x00\x00\x0f\x00\x10\x00\x11\x00\x35\x00\x36\x00\x37\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x00\x00\x46\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x3d\x00\x00\x00\x3e\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x41\x00\x0d\x00\x00\x00\x00\x00\x42\x00\x43\x00\x34\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x35\x00\x36\x00\x37\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x00\x00\x46\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x00\x00\x0b\x00\x00\x00\x00\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x3d\x00\x0c\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfa\x01\x3f\x00\x40\x00\x00\x00\x00\x00\x0d\x00\x41\x00\x00\x00\x00\x00\x00\x00\x42\x00\x43\x00\x0f\x00\x10\x00\x11\x00\x35\x00\x36\x00\x37\x00\x00\x00\xfb\x01\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x00\x00\x46\x00\x00\x00\x00\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x3d\x00\x00\x00\x3e\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x41\x00\x0d\x00\x00\x00\x00\x00\x42\x00\x00\x00\x34\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x35\x00\x36\x00\x37\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x00\x00\x46\x00\x00\x00\x00\x00\x00\x00\x00\x00\x38\x00\x00\x00\x00\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x36\x01\x00\x00\x00\x00\x00\x00\x56\x00\x57\x00\x58\x00\x00\x00\x00\x00\x39\x00\x00\x00\x59\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x00\x00\x0b\x00\x00\x00\x00\x00\x3b\x00\x03\x01\x3c\x00\x00\x00\x3d\x00\x0c\x00\x3e\x00\xf9\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x60\x00\x3f\x00\x40\x00\x62\x00\x63\x00\x0d\x00\x41\x00\x00\x00\x00\x00\x00\x00\x42\x00\x43\x00\x0f\x00\x10\x00\x11\x00\x35\x00\x36\x00\x37\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x00\x00\x46\x00\x00\x00\x00\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\xff\x00\x00\x39\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x00\x00\x0b\x00\x00\x00\x00\x00\x3b\x00\x00\x00\x3c\x00\x00\x00\x3d\x00\x0c\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x02\x3f\x00\x40\x00\x00\x00\x00\x00\x0d\x00\x41\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x35\x00\x36\x00\x37\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x00\x00\x46\x00\x00\x00\x00\x00\x38\x00\x00\x00\x00\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x56\x00\x57\x00\x58\x00\x00\x00\x00\x00\x39\x00\x00\x00\x59\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x00\x00\x0b\x00\x00\x00\x00\x00\x3b\x00\x03\x01\x3c\x00\x00\x00\x3d\x00\x0c\x00\x3e\x00\xf9\x00\x00\x00\x00\x00\x00\x00\x5f\x00\x60\x00\x3f\x00\x40\x00\x62\x00\x63\x00\x0d\x00\x41\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x35\x00\x36\x00\x37\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\xfc\x01\x00\x00\x00\x00\x44\x00\x45\x00\x24\x00\x95\x01\x46\x00\x26\x00\x27\x00\x38\x00\x28\x00\x29\x00\xb8\x03\xb9\x03\x00\x00\x00\x00\x00\x00\xd9\x02\x00\x00\x00\x00\x4c\x03\x00\x00\x24\x00\x95\x01\x00\x00\x26\x00\x27\x00\x39\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3b\x00\x00\x00\x3c\x00\x2a\x00\x3d\x00\x00\x00\x3e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\xd9\x02\x2a\x00\x42\x00\xda\x02\x00\x00\x24\x00\x95\x01\x00\x00\x26\x00\x27\x00\x00\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x44\x00\x45\x00\x00\x00\x00\x00\x46\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x2a\x00\x2e\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x31\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x32\x00\x00\x00\x00\x00\xfc\x01\x00\x00\x30\x00\x00\x00\x31\x00\x24\x00\x95\x01\x00\x00\x26\x00\x27\x00\x00\x00\x28\x00\x29\x00\x33\x02\x00\x00\x32\x00\xfc\x01\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x95\x01\x2b\x00\x26\x00\x27\x00\x00\x00\x28\x00\x29\x00\x42\x02\x00\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfc\x01\x2a\x00\x30\x00\x00\x00\x31\x00\x24\x00\x95\x01\x00\x00\x26\x00\x27\x00\x00\x00\x28\x00\x29\x00\xfd\x01\x00\x00\x32\x00\x00\x00\x2a\x00\x30\x04\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x95\x01\x00\x00\x26\x00\x27\x00\x00\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x15\x04\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x95\x01\x00\x00\x26\x00\x27\x00\x2a\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x2a\x00\x2e\x00\x2f\x00\x00\x00\x00\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x31\x00\x2c\x00\x2d\x00\x2a\x00\x2e\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x32\x00\x1f\x02\x00\x00\x30\x00\x00\x00\x31\x00\x24\x00\x95\x01\x2b\x00\x26\x00\x27\x00\x00\x00\x28\x00\x29\x00\x00\x00\x00\x00\x32\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x31\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x2f\x00\x00\x00\x00\x00\x2b\x00\x32\x00\x00\x00\x2a\x00\x00\x00\x00\x00\x30\x00\x00\x00\x31\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x32\x00\x94\x01\x00\x00\x30\x00\x00\x00\x31\x00\x24\x00\x95\x01\x00\x00\x26\x00\x27\x00\x00\x00\x28\x00\x29\x00\x00\x00\x00\x00\x32\x00\x00\x00\x1e\x04\x00\x00\x00\x00\x00\x00\x24\x00\x00\x00\x21\x02\xe6\x02\x00\x00\x23\x02\xe7\x02\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x2a\x00\x2e\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x31\x00\x00\x00\x00\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\xde\x03\x00\x00\x00\x00\x32\x00\x24\x00\x00\x00\x21\x02\xe6\x02\x00\x00\x23\x02\xe7\x02\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x98\x03\x00\x00\x00\x00\x00\x00\x24\x00\x00\x00\x21\x02\xe6\x02\x00\x00\x23\x02\xe7\x02\x29\x00\x00\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x2f\x00\x2a\x00\x00\x00\xe8\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x31\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x2f\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x32\x00\x00\x00\x00\x00\x30\x00\x2d\x03\x31\x00\x00\x00\x00\x00\x24\x00\x00\x00\x21\x02\xe6\x02\x00\x00\x23\x02\xe7\x02\x29\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe8\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x2f\x00\x00\x00\x00\x00\xe8\x02\x00\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x31\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x32\x00\x00\x00\x00\x00\x30\x00\x00\x00\x31\x00\x00\x00\x00\x00\x24\x00\x9b\x02\xb1\x03\x22\x02\x27\x00\x23\x02\x24\x02\x29\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x66\x01\x21\x03\x22\x02\x27\x00\x23\x02\x24\x02\x29\x00\x00\x00\xe8\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x2f\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x31\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x32\x00\x24\x00\x6a\x01\x23\x03\x22\x02\x27\x00\x23\x02\x24\x02\x29\x00\x24\x00\x37\x01\x00\x00\x26\x00\x27\x00\x00\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x91\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x25\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x2a\x00\x2e\x00\x2f\x00\x24\x00\x1d\x04\x25\x02\x26\x00\x27\x00\x2a\x00\x28\x00\x29\x00\x30\x00\x00\x00\x31\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x32\x00\x00\x00\x00\x00\x30\x00\x00\x00\x31\x00\x24\x00\x37\x01\x00\x00\x26\x00\x27\x00\x00\x00\x28\x00\x29\x00\x00\x00\x00\x00\x32\x00\x92\x02\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\xfc\x03\x25\x02\x26\x00\x27\x00\x00\x00\x28\x00\x29\x00\x00\x00\x00\x00\x2b\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x2a\x00\x2e\x00\x2f\x00\x30\x00\x00\x00\x31\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x31\x00\x00\x00\x00\x00\x32\x00\x00\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x2f\x00\x24\x00\xfd\x03\x00\x00\x26\x00\x27\x00\x00\x00\x28\x00\x29\x00\x30\x00\x00\x00\x31\x00\x00\x00\x00\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x32\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x31\x00\x00\x00\x2a\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x24\x00\x31\x00\xb1\x03\xe6\x02\x00\x00\x23\x02\xe7\x02\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x24\x00\x00\x00\x21\x03\xe6\x02\x00\x00\x23\x02\xe7\x02\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x00\x00\x30\x00\x24\x00\x31\x00\x23\x03\xe6\x02\x00\x00\x23\x02\xe7\x02\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x00\x00\xb4\x03\xe6\x02\x00\x00\x23\x02\xe7\x02\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe8\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x2f\x00\x00\x00\x00\x00\xe8\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x31\x00\x2c\x00\x2d\x00\x2a\x00\x2e\x00\x2f\x00\x24\x00\x3e\x03\x00\x00\x26\x00\x27\x00\x32\x00\x28\x00\x29\x00\x30\x00\x00\x00\x31\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\xa6\x02\x00\x00\x26\x00\x27\x00\x32\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe8\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x2a\x00\x2e\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe8\x02\x00\x00\x00\x00\x30\x00\x00\x00\x31\x00\x00\x00\x00\x00\x2a\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x2f\x00\x00\x00\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x24\x00\x31\x00\xe5\x02\xe6\x02\x00\x00\x23\x02\xe7\x02\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x9b\x02\x2b\x00\x26\x00\x27\x00\x00\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x2f\x00\x00\x00\x00\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x2a\x00\x00\x00\x30\x00\x00\x00\x31\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x32\x00\x00\x00\x2a\x00\x30\x00\x00\x00\x31\x00\x00\x00\x24\x00\x66\x01\x00\x00\x26\x00\x27\x00\x00\x00\x28\x00\x29\x00\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x24\x00\x6a\x01\x00\x00\x26\x00\x27\x00\x00\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\xe8\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x2a\x00\x2e\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x31\x00\x00\x00\x2c\x00\x2d\x00\x2a\x00\x2e\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x31\x00\x24\x00\xe6\x00\x00\x00\x26\x00\x27\x00\x00\x00\x28\x00\x29\x00\x24\x00\x45\x01\x32\x00\x26\x00\x27\x00\x00\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x00\x00\x00\x00\x2a\x00\x00\x00\x30\x00\x00\x00\x31\x00\x00\x00\x2c\x00\x2d\x00\x2a\x00\x2e\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x30\x00\x00\x00\x31\x00\x24\x00\x47\x01\x00\x00\x26\x00\x27\x00\x00\x00\x28\x00\x29\x00\x24\x00\x25\x00\x32\x00\x26\x00\x27\x00\x00\x00\x28\x00\x29\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2b\x00\x2c\x00\x2d\x00\x2a\x00\x2e\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x2a\x00\x2e\x00\x2f\x00\x30\x00\x00\x00\x31\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x00\x00\x30\x00\x00\x00\x31\x00\x00\x00\x00\x00\x32\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\xe1\x02\xe2\x02\xe3\x02\x2b\x00\x15\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x2b\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x2f\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x2d\x00\x00\x00\x2e\x00\x2f\x00\x30\x00\x00\x00\x31\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x30\x00\x0b\x00\x31\x00\x00\x00\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x32\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x78\x01\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x1b\x00\x15\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x0b\x00\x00\x00\x00\x00\x00\x00\xe4\x02\x00\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x00\x00\x15\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x78\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x00\x00\x00\x00\x00\x00\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe4\x02\x00\x00\x56\x00\x57\x00\x58\x00\x00\x00\x00\x00\x00\x00\x00\x00\x59\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5a\x00\x00\x00\x00\x00\x0b\x00\x5b\x00\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x5d\x00\x1b\x00\x5e\x00\x5f\x00\x60\x00\x1c\x00\x61\x00\x62\x00\x63\x00\x1d\x00\x64\x00\x0d\x00\x00\x00\xf5\x03\x00\x00\x00\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x0b\x00\x15\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\xf5\x03\x00\x00\x00\x00\x0e\x00\xf6\x03\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x00\x00\x15\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x5a\x00\x00\x00\x00\x00\x00\x00\xe2\x00\xf7\x03\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x5e\x00\x00\x00\x00\x00\x1c\x00\x61\x00\x00\x00\x00\x00\x1d\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x5a\x00\x00\x00\x00\x00\x00\x00\xe2\x00\x00\x00\x5c\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x5e\x00\x00\x00\x7f\x03\x1c\x00\x61\x00\x0d\x00\x00\x00\x1d\x00\x64\x00\x00\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x0b\x00\x15\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x00\x00\x15\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x03\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x81\x03\x00\x00\x1b\x00\x40\x00\x00\x00\x00\x00\x1c\x00\x41\x00\x00\x00\x00\x00\x1d\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x5a\x00\x00\x00\x00\x00\x00\x00\xe2\x00\x00\x00\x5c\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x5e\x00\x00\x00\x00\x00\x1c\x00\x61\x00\x0d\x00\x00\x00\x1d\x00\x64\x00\x00\x00\x0b\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x35\x00\x36\x00\x37\x00\x0c\x00\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x0b\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x0c\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x00\x00\x15\x00\x16\x00\x17\x00\x18\x00\x0d\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x35\x00\x36\x00\x37\x00\x00\x00\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\xdc\x00\x00\x00\xdd\x00\x00\x00\xde\x00\x00\x00\xdf\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x41\x00\x00\x00\x00\x00\x00\x00\x42\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x5e\x00\x00\x00\x00\x00\x1c\x00\x61\x00\x0b\x00\x00\x00\x1d\x00\x64\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x3f\x00\x40\x00\x00\x00\x00\x00\x00\x00\x41\x00\x0b\x00\x00\x00\x0d\x00\x42\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x0c\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\xf4\x01\x15\x00\x16\x00\x17\x00\x18\x00\x0d\x00\x00\x00\x19\x00\x00\x00\x00\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x00\x00\x15\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x9c\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x00\x00\x00\x00\x0b\x00\x1c\x00\x00\x00\x00\x00\x00\x00\x1d\x00\x1a\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x00\x00\x00\x00\x00\x00\x1c\x00\x0d\x00\x00\x00\x00\x00\x1d\x00\x00\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x0b\x00\x15\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe3\x01\x00\x00\x00\x00\x0d\x00\x00\x00\xe4\x01\x00\x00\x00\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x00\x00\x15\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x1a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x00\x00\x0d\x00\x00\x00\x1c\x00\x00\x00\x00\x00\x0e\x00\x1d\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x0b\x00\x15\x00\x16\x00\x17\x00\x18\x00\x5a\x00\x00\x00\x19\x00\x0c\x00\xe5\x01\x00\x00\x5c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1b\x00\x5e\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x00\x00\x15\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x5a\x00\x00\x00\x00\x00\x00\x00\xe5\x01\x00\x00\x5c\x00\x00\x00\x0b\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x1b\x00\x5e\x00\x0e\x00\x0c\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x00\x00\x15\x00\x16\x00\x17\x00\x18\x00\x0d\x00\x00\x00\x19\x00\x00\x00\x00\x00\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x00\x00\x15\x00\x16\x00\x17\x00\x18\x00\x1b\x00\x5e\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x51\x03\x0e\x00\x0c\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x1b\x00\x15\x00\x16\x00\x17\x00\x18\x00\x0d\x00\x00\x00\x19\x00\x00\x00\x78\x01\x0e\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x1b\x00\x15\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x51\x03\x0e\x00\x0c\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x13\x00\x14\x00\x1b\x00\x15\x00\x16\x00\x17\x00\x18\x00\x0d\x00\x00\x00\x19\x00\x00\x00\x78\x01\x00\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x35\x00\x36\x00\x37\x00\x1b\x00\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x33\x03\x00\x00\x0f\x00\x10\x00\x11\x00\x35\x00\x36\x00\x37\x00\x00\x00\x0d\x00\x16\x00\x17\x00\x18\x00\x1b\x00\x00\x00\x19\x00\x0f\x00\x10\x00\x11\x00\x35\x00\x36\x00\x37\x00\x71\x01\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x0b\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0f\x00\x10\x00\x11\x00\x35\x00\x36\x00\x37\x00\x53\x01\x00\x00\x16\x00\x17\x00\x18\x00\x00\x00\x00\x00\x19\x00\x00\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x71\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x53\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x3f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# -happyReduceArr = Happy_Data_Array.array (5, 594) [ +happyReduceArr = Happy_Data_Array.array (5, 601) [ (5 , happyReduce_5), (6 , happyReduce_6), (7 , happyReduce_7), @@ -2007,36 +2010,43 @@ (591 , happyReduce_591), (592 , happyReduce_592), (593 , happyReduce_593), - (594 , happyReduce_594) + (594 , happyReduce_594), + (595 , happyReduce_595), + (596 , happyReduce_596), + (597 , happyReduce_597), + (598 , happyReduce_598), + (599 , happyReduce_599), + (600 , happyReduce_600), + (601 , happyReduce_601) ] -happy_n_terms = 132 :: Int -happy_n_nonterms = 219 :: Int +happy_n_terms = 135 :: Int +happy_n_nonterms = 221 :: Int happyReduce_5 = happySpecReduce_1 0# happyReduction_5 happyReduction_5 happy_x_1 - = case happyOut202 happy_x_1 of { happy_var_1 -> + = case happyOut204 happy_x_1 of { happy_var_1 -> happyIn8 (happy_var_1 )} happyReduce_6 = happySpecReduce_1 0# happyReduction_6 happyReduction_6 happy_x_1 - = case happyOut178 happy_x_1 of { happy_var_1 -> + = case happyOut180 happy_x_1 of { happy_var_1 -> happyIn8 (happy_var_1 )} happyReduce_7 = happySpecReduce_1 0# happyReduction_7 happyReduction_7 happy_x_1 - = case happyOut195 happy_x_1 of { happy_var_1 -> + = case happyOut197 happy_x_1 of { happy_var_1 -> happyIn8 (happy_var_1 )} happyReduce_8 = happySpecReduce_1 0# happyReduction_8 happyReduction_8 happy_x_1 - = case happyOut183 happy_x_1 of { happy_var_1 -> + = case happyOut185 happy_x_1 of { happy_var_1 -> happyIn8 (happy_var_1 )} @@ -2061,9 +2071,9 @@ happy_x_1 `HappyStk` happyRest) tk = happyThen (case happyOut10 happy_x_1 of { happy_var_1 -> - case happyOut218 happy_x_3 of { happy_var_3 -> + case happyOut220 happy_x_3 of { happy_var_3 -> case happyOut12 happy_x_4 of { happy_var_4 -> - case happyOut19 happy_x_5 of { happy_var_5 -> + case happyOut20 happy_x_5 of { happy_var_5 -> case happyOut13 happy_x_7 of { happy_var_7 -> ( fileSrcSpan >>= \ loc -> return (L loc (HsModule (Just happy_var_3) happy_var_5 (fst happy_var_7) (snd happy_var_7) happy_var_4 happy_var_1 @@ -2082,7 +2092,7 @@ happyReduce_12 = happySpecReduce_1 2# happyReduction_12 happyReduction_12 happy_x_1 - = case happyOut224 happy_x_1 of { happy_var_1 -> + = case happyOut226 happy_x_1 of { happy_var_1 -> happyIn10 (happy_var_1 )} @@ -2101,7 +2111,7 @@ happyReduction_15 happy_x_3 happy_x_2 happy_x_1 - = case happyOut72 happy_x_2 of { happy_var_2 -> + = case happyOut74 happy_x_2 of { happy_var_2 -> happyIn12 (Just (DeprecatedTxt $ unLoc happy_var_2) )} @@ -2110,7 +2120,7 @@ happyReduction_16 happy_x_3 happy_x_2 happy_x_1 - = case happyOut72 happy_x_2 of { happy_var_2 -> + = case happyOut74 happy_x_2 of { happy_var_2 -> happyIn12 (Just (WarningTxt $ unLoc happy_var_2) )} @@ -2158,7 +2168,7 @@ happyReduce_22 = happySpecReduce_1 7# happyReduction_22 happyReduction_22 happy_x_1 - = case happyOut28 happy_x_1 of { happy_var_1 -> + = case happyOut29 happy_x_1 of { happy_var_1 -> happyIn15 ((reverse happy_var_1,[]) )} @@ -2167,7 +2177,7 @@ happyReduction_23 happy_x_3 happy_x_2 happy_x_1 - = case happyOut28 happy_x_1 of { happy_var_1 -> + = case happyOut29 happy_x_1 of { happy_var_1 -> case happyOut16 happy_x_3 of { happy_var_3 -> happyIn15 ((reverse happy_var_1,happy_var_3) @@ -2182,7 +2192,7 @@ happyReduce_25 = happySpecReduce_1 8# happyReduction_25 happyReduction_25 happy_x_1 - = case happyOut39 happy_x_1 of { happy_var_1 -> + = case happyOut41 happy_x_1 of { happy_var_1 -> happyIn16 (cvTopDecls happy_var_1 )} @@ -2197,29 +2207,28 @@ happy_x_1 `HappyStk` happyRest) tk = happyThen (case happyOut10 happy_x_1 of { happy_var_1 -> - case happyOut218 happy_x_3 of { happy_var_3 -> + case happyOut220 happy_x_3 of { happy_var_3 -> case happyOut12 happy_x_4 of { happy_var_4 -> - case happyOut19 happy_x_5 of { happy_var_5 -> + case happyOut20 happy_x_5 of { happy_var_5 -> case happyOut18 happy_x_7 of { happy_var_7 -> ( fileSrcSpan >>= \ loc -> return (L loc (HsModule (Just happy_var_3) happy_var_5 happy_var_7 [] happy_var_4 happy_var_1 )))}}}}} ) (\r -> happyReturn (happyIn17 r)) -happyReduce_27 = happyMonadReduce 2# 9# happyReduction_27 -happyReduction_27 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` +happyReduce_27 = happyMonadReduce 1# 9# happyReduction_27 +happyReduction_27 (happy_x_1 `HappyStk` happyRest) tk - = happyThen (case happyOut28 happy_x_2 of { happy_var_2 -> + = happyThen (case happyOut19 happy_x_1 of { happy_var_1 -> ( fileSrcSpan >>= \ loc -> - return (L loc (HsModule Nothing Nothing happy_var_2 [] Nothing + return (L loc (HsModule Nothing Nothing happy_var_1 [] Nothing Nothing)))} ) (\r -> happyReturn (happyIn17 r)) happyReduce_28 = happySpecReduce_2 10# happyReduction_28 happyReduction_28 happy_x_2 happy_x_1 - = case happyOut28 happy_x_2 of { happy_var_2 -> + = case happyOut29 happy_x_2 of { happy_var_2 -> happyIn18 (happy_var_2 )} @@ -2227,249 +2236,266 @@ happyReduce_29 = happySpecReduce_2 10# happyReduction_29 happyReduction_29 happy_x_2 happy_x_1 - = case happyOut28 happy_x_2 of { happy_var_2 -> + = case happyOut29 happy_x_2 of { happy_var_2 -> happyIn18 (happy_var_2 )} -happyReduce_30 = happySpecReduce_3 11# happyReduction_30 -happyReduction_30 happy_x_3 - happy_x_2 +happyReduce_30 = happySpecReduce_2 11# happyReduction_30 +happyReduction_30 happy_x_2 happy_x_1 - = case happyOut20 happy_x_2 of { happy_var_2 -> + = case happyOut29 happy_x_2 of { happy_var_2 -> happyIn19 - (Just happy_var_2 + (happy_var_2 )} -happyReduce_31 = happySpecReduce_0 11# happyReduction_31 -happyReduction_31 = happyIn19 - (Nothing - ) +happyReduce_31 = happySpecReduce_2 11# happyReduction_31 +happyReduction_31 happy_x_2 + happy_x_1 + = case happyOut29 happy_x_2 of { happy_var_2 -> + happyIn19 + (happy_var_2 + )} happyReduce_32 = happySpecReduce_3 12# happyReduction_32 happyReduction_32 happy_x_3 happy_x_2 happy_x_1 - = case happyOut22 happy_x_1 of { happy_var_1 -> - case happyOut22 happy_x_3 of { happy_var_3 -> + = case happyOut21 happy_x_2 of { happy_var_2 -> happyIn20 + (Just happy_var_2 + )} + +happyReduce_33 = happySpecReduce_0 12# happyReduction_33 +happyReduction_33 = happyIn20 + (Nothing + ) + +happyReduce_34 = happySpecReduce_3 13# happyReduction_34 +happyReduction_34 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOut23 happy_x_1 of { happy_var_1 -> + case happyOut23 happy_x_3 of { happy_var_3 -> + happyIn21 (happy_var_1 ++ happy_var_3 )}} -happyReduce_33 = happySpecReduce_1 12# happyReduction_33 -happyReduction_33 happy_x_1 - = case happyOut21 happy_x_1 of { happy_var_1 -> - happyIn20 +happyReduce_35 = happySpecReduce_1 13# happyReduction_35 +happyReduction_35 happy_x_1 + = case happyOut22 happy_x_1 of { happy_var_1 -> + happyIn21 (happy_var_1 )} -happyReduce_34 = happyReduce 5# 13# happyReduction_34 -happyReduction_34 (happy_x_5 `HappyStk` +happyReduce_36 = happyReduce 5# 14# happyReduction_36 +happyReduction_36 (happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) - = case happyOut22 happy_x_1 of { happy_var_1 -> - case happyOut24 happy_x_2 of { happy_var_2 -> - case happyOut22 happy_x_3 of { happy_var_3 -> - case happyOut20 happy_x_5 of { happy_var_5 -> - happyIn21 + = case happyOut23 happy_x_1 of { happy_var_1 -> + case happyOut25 happy_x_2 of { happy_var_2 -> + case happyOut23 happy_x_3 of { happy_var_3 -> + case happyOut21 happy_x_5 of { happy_var_5 -> + happyIn22 (happy_var_1 ++ (happy_var_2 : happy_var_3) ++ happy_var_5 ) `HappyStk` happyRest}}}} -happyReduce_35 = happySpecReduce_3 13# happyReduction_35 -happyReduction_35 happy_x_3 +happyReduce_37 = happySpecReduce_3 14# happyReduction_37 +happyReduction_37 happy_x_3 happy_x_2 happy_x_1 - = case happyOut22 happy_x_1 of { happy_var_1 -> - case happyOut24 happy_x_2 of { happy_var_2 -> - case happyOut22 happy_x_3 of { happy_var_3 -> - happyIn21 + = case happyOut23 happy_x_1 of { happy_var_1 -> + case happyOut25 happy_x_2 of { happy_var_2 -> + case happyOut23 happy_x_3 of { happy_var_3 -> + happyIn22 (happy_var_1 ++ (happy_var_2 : happy_var_3) )}}} -happyReduce_36 = happySpecReduce_1 13# happyReduction_36 -happyReduction_36 happy_x_1 - = case happyOut22 happy_x_1 of { happy_var_1 -> - happyIn21 +happyReduce_38 = happySpecReduce_1 14# happyReduction_38 +happyReduction_38 happy_x_1 + = case happyOut23 happy_x_1 of { happy_var_1 -> + happyIn22 (happy_var_1 )} -happyReduce_37 = happySpecReduce_2 14# happyReduction_37 -happyReduction_37 happy_x_2 +happyReduce_39 = happySpecReduce_2 15# happyReduction_39 +happyReduction_39 happy_x_2 happy_x_1 - = case happyOut23 happy_x_1 of { happy_var_1 -> - case happyOut22 happy_x_2 of { happy_var_2 -> - happyIn22 + = case happyOut24 happy_x_1 of { happy_var_1 -> + case happyOut23 happy_x_2 of { happy_var_2 -> + happyIn23 (happy_var_1 : happy_var_2 )}} -happyReduce_38 = happySpecReduce_0 14# happyReduction_38 -happyReduction_38 = happyIn22 +happyReduce_40 = happySpecReduce_0 15# happyReduction_40 +happyReduction_40 = happyIn23 ([] ) -happyReduce_39 = happySpecReduce_1 15# happyReduction_39 -happyReduction_39 happy_x_1 - = case happyOut223 happy_x_1 of { happy_var_1 -> - happyIn23 +happyReduce_41 = happySpecReduce_1 16# happyReduction_41 +happyReduction_41 happy_x_1 + = case happyOut225 happy_x_1 of { happy_var_1 -> + happyIn24 (sL (getLoc happy_var_1) (case (unLoc happy_var_1) of (n, doc) -> IEGroup n doc) )} -happyReduce_40 = happySpecReduce_1 15# happyReduction_40 -happyReduction_40 happy_x_1 - = case happyOut222 happy_x_1 of { happy_var_1 -> - happyIn23 +happyReduce_42 = happySpecReduce_1 16# happyReduction_42 +happyReduction_42 happy_x_1 + = case happyOut224 happy_x_1 of { happy_var_1 -> + happyIn24 (sL (getLoc happy_var_1) (IEDocNamed ((fst . unLoc) happy_var_1)) )} -happyReduce_41 = happySpecReduce_1 15# happyReduction_41 -happyReduction_41 happy_x_1 - = case happyOut220 happy_x_1 of { happy_var_1 -> - happyIn23 +happyReduce_43 = happySpecReduce_1 16# happyReduction_43 +happyReduction_43 happy_x_1 + = case happyOut222 happy_x_1 of { happy_var_1 -> + happyIn24 (sL (getLoc happy_var_1) (IEDoc (unLoc happy_var_1)) )} -happyReduce_42 = happySpecReduce_1 16# happyReduction_42 -happyReduction_42 happy_x_1 - = case happyOut202 happy_x_1 of { happy_var_1 -> - happyIn24 +happyReduce_44 = happySpecReduce_1 17# happyReduction_44 +happyReduction_44 happy_x_1 + = case happyOut204 happy_x_1 of { happy_var_1 -> + happyIn25 (sL (getLoc happy_var_1) (IEVar (unLoc happy_var_1)) )} -happyReduce_43 = happySpecReduce_1 16# happyReduction_43 -happyReduction_43 happy_x_1 - = case happyOut185 happy_x_1 of { happy_var_1 -> - happyIn24 +happyReduce_45 = happySpecReduce_1 17# happyReduction_45 +happyReduction_45 happy_x_1 + = case happyOut187 happy_x_1 of { happy_var_1 -> + happyIn25 (sL (getLoc happy_var_1) (IEThingAbs (unLoc happy_var_1)) )} -happyReduce_44 = happyReduce 4# 16# happyReduction_44 -happyReduction_44 (happy_x_4 `HappyStk` +happyReduce_46 = happyReduce 4# 17# happyReduction_46 +happyReduction_46 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) - = case happyOut185 happy_x_1 of { happy_var_1 -> + = case happyOut187 happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_4 of { happy_var_4 -> - happyIn24 + happyIn25 (sL (comb2 happy_var_1 happy_var_4) (IEThingAll (unLoc happy_var_1)) ) `HappyStk` happyRest}} -happyReduce_45 = happySpecReduce_3 16# happyReduction_45 -happyReduction_45 happy_x_3 +happyReduce_47 = happySpecReduce_3 17# happyReduction_47 +happyReduction_47 happy_x_3 happy_x_2 happy_x_1 - = case happyOut185 happy_x_1 of { happy_var_1 -> + = case happyOut187 happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn24 + happyIn25 (sL (comb2 happy_var_1 happy_var_3) (IEThingWith (unLoc happy_var_1) []) )}} -happyReduce_46 = happyReduce 4# 16# happyReduction_46 -happyReduction_46 (happy_x_4 `HappyStk` +happyReduce_48 = happyReduce 4# 17# happyReduction_48 +happyReduction_48 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) - = case happyOut185 happy_x_1 of { happy_var_1 -> - case happyOut25 happy_x_3 of { happy_var_3 -> + = case happyOut187 happy_x_1 of { happy_var_1 -> + case happyOut26 happy_x_3 of { happy_var_3 -> case happyOutTok happy_x_4 of { happy_var_4 -> - happyIn24 + happyIn25 (sL (comb2 happy_var_1 happy_var_4) (IEThingWith (unLoc happy_var_1) (reverse happy_var_3)) ) `HappyStk` happyRest}}} -happyReduce_47 = happySpecReduce_2 16# happyReduction_47 -happyReduction_47 happy_x_2 +happyReduce_49 = happySpecReduce_2 17# happyReduction_49 +happyReduction_49 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut218 happy_x_2 of { happy_var_2 -> - happyIn24 + case happyOut220 happy_x_2 of { happy_var_2 -> + happyIn25 (sL (comb2 happy_var_1 happy_var_2) (IEModuleContents (unLoc happy_var_2)) )}} -happyReduce_48 = happySpecReduce_3 17# happyReduction_48 -happyReduction_48 happy_x_3 +happyReduce_50 = happySpecReduce_3 18# happyReduction_50 +happyReduction_50 happy_x_3 happy_x_2 happy_x_1 - = case happyOut25 happy_x_1 of { happy_var_1 -> - case happyOut26 happy_x_3 of { happy_var_3 -> - happyIn25 + = case happyOut26 happy_x_1 of { happy_var_1 -> + case happyOut27 happy_x_3 of { happy_var_3 -> + happyIn26 (unLoc happy_var_3 : happy_var_1 )}} -happyReduce_49 = happySpecReduce_1 17# happyReduction_49 -happyReduction_49 happy_x_1 - = case happyOut26 happy_x_1 of { happy_var_1 -> - happyIn25 +happyReduce_51 = happySpecReduce_1 18# happyReduction_51 +happyReduction_51 happy_x_1 + = case happyOut27 happy_x_1 of { happy_var_1 -> + happyIn26 ([unLoc happy_var_1] )} -happyReduce_50 = happySpecReduce_1 18# happyReduction_50 -happyReduction_50 happy_x_1 - = case happyOut27 happy_x_1 of { happy_var_1 -> - happyIn26 +happyReduce_52 = happySpecReduce_1 19# happyReduction_52 +happyReduction_52 happy_x_1 + = case happyOut28 happy_x_1 of { happy_var_1 -> + happyIn27 (happy_var_1 )} -happyReduce_51 = happySpecReduce_2 18# happyReduction_51 -happyReduction_51 happy_x_2 +happyReduce_53 = happySpecReduce_2 19# happyReduction_53 +happyReduction_53 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut178 happy_x_2 of { happy_var_2 -> - happyIn26 + case happyOut180 happy_x_2 of { happy_var_2 -> + happyIn27 (sL (comb2 happy_var_1 happy_var_2) (setRdrNameSpace (unLoc happy_var_2) tcClsName) )}} -happyReduce_52 = happySpecReduce_1 19# happyReduction_52 -happyReduction_52 happy_x_1 - = case happyOut202 happy_x_1 of { happy_var_1 -> - happyIn27 +happyReduce_54 = happySpecReduce_1 20# happyReduction_54 +happyReduction_54 happy_x_1 + = case happyOut204 happy_x_1 of { happy_var_1 -> + happyIn28 (happy_var_1 )} -happyReduce_53 = happySpecReduce_1 19# happyReduction_53 -happyReduction_53 happy_x_1 - = case happyOut178 happy_x_1 of { happy_var_1 -> - happyIn27 +happyReduce_55 = happySpecReduce_1 20# happyReduction_55 +happyReduction_55 happy_x_1 + = case happyOut180 happy_x_1 of { happy_var_1 -> + happyIn28 (happy_var_1 )} -happyReduce_54 = happySpecReduce_3 20# happyReduction_54 -happyReduction_54 happy_x_3 +happyReduce_56 = happySpecReduce_3 21# happyReduction_56 +happyReduction_56 happy_x_3 happy_x_2 happy_x_1 - = case happyOut28 happy_x_1 of { happy_var_1 -> - case happyOut29 happy_x_3 of { happy_var_3 -> - happyIn28 + = case happyOut29 happy_x_1 of { happy_var_1 -> + case happyOut30 happy_x_3 of { happy_var_3 -> + happyIn29 (happy_var_3 : happy_var_1 )}} -happyReduce_55 = happySpecReduce_2 20# happyReduction_55 -happyReduction_55 happy_x_2 +happyReduce_57 = happySpecReduce_2 21# happyReduction_57 +happyReduction_57 happy_x_2 happy_x_1 - = case happyOut28 happy_x_1 of { happy_var_1 -> - happyIn28 + = case happyOut29 happy_x_1 of { happy_var_1 -> + happyIn29 (happy_var_1 )} -happyReduce_56 = happySpecReduce_1 20# happyReduction_56 -happyReduction_56 happy_x_1 - = case happyOut29 happy_x_1 of { happy_var_1 -> - happyIn28 +happyReduce_58 = happySpecReduce_1 21# happyReduction_58 +happyReduction_58 happy_x_1 + = case happyOut30 happy_x_1 of { happy_var_1 -> + happyIn29 ([ happy_var_1 ] )} -happyReduce_57 = happySpecReduce_0 20# happyReduction_57 -happyReduction_57 = happyIn28 +happyReduce_59 = happySpecReduce_0 21# happyReduction_59 +happyReduction_59 = happyIn29 ([] ) -happyReduce_58 = happyReduce 7# 21# happyReduction_58 -happyReduction_58 (happy_x_7 `HappyStk` +happyReduce_60 = happyReduce 8# 22# happyReduction_60 +happyReduction_60 (happy_x_8 `HappyStk` + happy_x_7 `HappyStk` happy_x_6 `HappyStk` happy_x_5 `HappyStk` happy_x_4 `HappyStk` @@ -2478,38 +2504,27 @@ happy_x_1 `HappyStk` happyRest) = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut30 happy_x_2 of { happy_var_2 -> + case happyOut31 happy_x_2 of { happy_var_2 -> case happyOut32 happy_x_3 of { happy_var_3 -> - case happyOut31 happy_x_4 of { happy_var_4 -> - case happyOut218 happy_x_5 of { happy_var_5 -> - case happyOut33 happy_x_6 of { happy_var_6 -> - case happyOut34 happy_x_7 of { happy_var_7 -> - happyIn29 - (L (comb4 happy_var_1 happy_var_5 happy_var_6 happy_var_7) (ImportDecl happy_var_5 happy_var_4 happy_var_2 happy_var_3 (unLoc happy_var_6) (unLoc happy_var_7)) - ) `HappyStk` happyRest}}}}}}} + case happyOut34 happy_x_4 of { happy_var_4 -> + case happyOut33 happy_x_5 of { happy_var_5 -> + case happyOut220 happy_x_6 of { happy_var_6 -> + case happyOut35 happy_x_7 of { happy_var_7 -> + case happyOut36 happy_x_8 of { happy_var_8 -> + happyIn30 + (L (comb4 happy_var_1 happy_var_6 happy_var_7 happy_var_8) (ImportDecl happy_var_6 happy_var_5 happy_var_2 happy_var_3 happy_var_4 (unLoc happy_var_7) (unLoc happy_var_8)) + ) `HappyStk` happyRest}}}}}}}} -happyReduce_59 = happySpecReduce_2 22# happyReduction_59 -happyReduction_59 happy_x_2 +happyReduce_61 = happySpecReduce_2 23# happyReduction_61 +happyReduction_61 happy_x_2 happy_x_1 - = happyIn30 + = happyIn31 (True ) -happyReduce_60 = happySpecReduce_0 22# happyReduction_60 -happyReduction_60 = happyIn30 - (False - ) - -happyReduce_61 = happySpecReduce_1 23# happyReduction_61 -happyReduction_61 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn31 - (Just (getSTRING happy_var_1) - )} - happyReduce_62 = happySpecReduce_0 23# happyReduction_62 happyReduction_62 = happyIn31 - (Nothing + (False ) happyReduce_63 = happySpecReduce_1 24# happyReduction_63 @@ -2523,656 +2538,729 @@ (False ) -happyReduce_65 = happySpecReduce_2 25# happyReduction_65 -happyReduction_65 happy_x_2 - happy_x_1 +happyReduce_65 = happySpecReduce_1 25# happyReduction_65 +happyReduction_65 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut218 happy_x_2 of { happy_var_2 -> happyIn33 - (sL (comb2 happy_var_1 happy_var_2) (Just (unLoc happy_var_2)) - )}} + (Just (getSTRING happy_var_1) + )} happyReduce_66 = happySpecReduce_0 25# happyReduction_66 happyReduction_66 = happyIn33 - (noLoc Nothing + (Nothing ) happyReduce_67 = happySpecReduce_1 26# happyReduction_67 happyReduction_67 happy_x_1 - = case happyOut35 happy_x_1 of { happy_var_1 -> - happyIn34 - (sL (getLoc happy_var_1) (Just (unLoc happy_var_1)) - )} + = happyIn34 + (True + ) happyReduce_68 = happySpecReduce_0 26# happyReduction_68 happyReduction_68 = happyIn34 + (False + ) + +happyReduce_69 = happySpecReduce_2 27# happyReduction_69 +happyReduction_69 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut220 happy_x_2 of { happy_var_2 -> + happyIn35 + (sL (comb2 happy_var_1 happy_var_2) (Just (unLoc happy_var_2)) + )}} + +happyReduce_70 = happySpecReduce_0 27# happyReduction_70 +happyReduction_70 = happyIn35 (noLoc Nothing ) -happyReduce_69 = happySpecReduce_3 27# happyReduction_69 -happyReduction_69 happy_x_3 +happyReduce_71 = happySpecReduce_1 28# happyReduction_71 +happyReduction_71 happy_x_1 + = case happyOut37 happy_x_1 of { happy_var_1 -> + happyIn36 + (sL (getLoc happy_var_1) (Just (unLoc happy_var_1)) + )} + +happyReduce_72 = happySpecReduce_0 28# happyReduction_72 +happyReduction_72 = happyIn36 + (noLoc Nothing + ) + +happyReduce_73 = happySpecReduce_3 29# happyReduction_73 +happyReduction_73 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut20 happy_x_2 of { happy_var_2 -> + case happyOut21 happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn35 + happyIn37 (sL (comb2 happy_var_1 happy_var_3) (False, happy_var_2) )}}} -happyReduce_70 = happyReduce 4# 27# happyReduction_70 -happyReduction_70 (happy_x_4 `HappyStk` +happyReduce_74 = happyReduce 4# 29# happyReduction_74 +happyReduction_74 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut20 happy_x_3 of { happy_var_3 -> + case happyOut21 happy_x_3 of { happy_var_3 -> case happyOutTok happy_x_4 of { happy_var_4 -> - happyIn35 + happyIn37 (sL (comb2 happy_var_1 happy_var_4) (True, happy_var_3) ) `HappyStk` happyRest}}} -happyReduce_71 = happySpecReduce_0 28# happyReduction_71 -happyReduction_71 = happyIn36 +happyReduce_75 = happySpecReduce_0 30# happyReduction_75 +happyReduction_75 = happyIn38 (9 ) -happyReduce_72 = happyMonadReduce 1# 28# happyReduction_72 -happyReduction_72 (happy_x_1 `HappyStk` +happyReduce_76 = happyMonadReduce 1# 30# happyReduction_76 +happyReduction_76 (happy_x_1 `HappyStk` happyRest) tk = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> ( checkPrecP (sL (getLoc happy_var_1) (fromInteger (getINTEGER happy_var_1))))} - ) (\r -> happyReturn (happyIn36 r)) + ) (\r -> happyReturn (happyIn38 r)) -happyReduce_73 = happySpecReduce_1 29# happyReduction_73 -happyReduction_73 happy_x_1 +happyReduce_77 = happySpecReduce_1 31# happyReduction_77 +happyReduction_77 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn37 + happyIn39 (sL (getLoc happy_var_1) InfixN )} -happyReduce_74 = happySpecReduce_1 29# happyReduction_74 -happyReduction_74 happy_x_1 +happyReduce_78 = happySpecReduce_1 31# happyReduction_78 +happyReduction_78 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn37 + happyIn39 (sL (getLoc happy_var_1) InfixL )} -happyReduce_75 = happySpecReduce_1 29# happyReduction_75 -happyReduction_75 happy_x_1 +happyReduce_79 = happySpecReduce_1 31# happyReduction_79 +happyReduction_79 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn37 + happyIn39 (sL (getLoc happy_var_1) InfixR )} -happyReduce_76 = happySpecReduce_3 30# happyReduction_76 -happyReduction_76 happy_x_3 +happyReduce_80 = happySpecReduce_3 32# happyReduction_80 +happyReduction_80 happy_x_3 happy_x_2 happy_x_1 - = case happyOut38 happy_x_1 of { happy_var_1 -> - case happyOut191 happy_x_3 of { happy_var_3 -> - happyIn38 + = case happyOut40 happy_x_1 of { happy_var_1 -> + case happyOut193 happy_x_3 of { happy_var_3 -> + happyIn40 (sL (comb2 happy_var_1 happy_var_3) (happy_var_3 : unLoc happy_var_1) )}} -happyReduce_77 = happySpecReduce_1 30# happyReduction_77 -happyReduction_77 happy_x_1 - = case happyOut191 happy_x_1 of { happy_var_1 -> - happyIn38 +happyReduce_81 = happySpecReduce_1 32# happyReduction_81 +happyReduction_81 happy_x_1 + = case happyOut193 happy_x_1 of { happy_var_1 -> + happyIn40 (sL (getLoc happy_var_1) [happy_var_1] )} -happyReduce_78 = happySpecReduce_3 31# happyReduction_78 -happyReduction_78 happy_x_3 +happyReduce_82 = happySpecReduce_3 33# happyReduction_82 +happyReduction_82 happy_x_3 happy_x_2 happy_x_1 - = case happyOut39 happy_x_1 of { happy_var_1 -> - case happyOut40 happy_x_3 of { happy_var_3 -> - happyIn39 + = case happyOut41 happy_x_1 of { happy_var_1 -> + case happyOut42 happy_x_3 of { happy_var_3 -> + happyIn41 (happy_var_1 `appOL` happy_var_3 )}} -happyReduce_79 = happySpecReduce_2 31# happyReduction_79 -happyReduction_79 happy_x_2 +happyReduce_83 = happySpecReduce_2 33# happyReduction_83 +happyReduction_83 happy_x_2 happy_x_1 - = case happyOut39 happy_x_1 of { happy_var_1 -> - happyIn39 + = case happyOut41 happy_x_1 of { happy_var_1 -> + happyIn41 (happy_var_1 )} -happyReduce_80 = happySpecReduce_1 31# happyReduction_80 -happyReduction_80 happy_x_1 - = case happyOut40 happy_x_1 of { happy_var_1 -> - happyIn39 +happyReduce_84 = happySpecReduce_1 33# happyReduction_84 +happyReduction_84 happy_x_1 + = case happyOut42 happy_x_1 of { happy_var_1 -> + happyIn41 (happy_var_1 )} -happyReduce_81 = happySpecReduce_1 32# happyReduction_81 -happyReduction_81 happy_x_1 - = case happyOut41 happy_x_1 of { happy_var_1 -> - happyIn40 +happyReduce_85 = happySpecReduce_1 34# happyReduction_85 +happyReduction_85 happy_x_1 + = case happyOut43 happy_x_1 of { happy_var_1 -> + happyIn42 (unitOL (sL (getLoc happy_var_1) (TyClD (unLoc happy_var_1))) )} -happyReduce_82 = happySpecReduce_1 32# happyReduction_82 -happyReduction_82 happy_x_1 - = case happyOut42 happy_x_1 of { happy_var_1 -> - happyIn40 +happyReduce_86 = happySpecReduce_1 34# happyReduction_86 +happyReduction_86 happy_x_1 + = case happyOut44 happy_x_1 of { happy_var_1 -> + happyIn42 (unitOL (sL (getLoc happy_var_1) (TyClD (unLoc happy_var_1))) )} -happyReduce_83 = happySpecReduce_3 32# happyReduction_83 -happyReduction_83 happy_x_3 +happyReduce_87 = happySpecReduce_3 34# happyReduction_87 +happyReduction_87 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut94 happy_x_2 of { happy_var_2 -> - case happyOut56 happy_x_3 of { happy_var_3 -> - happyIn40 + case happyOut96 happy_x_2 of { happy_var_2 -> + case happyOut58 happy_x_3 of { happy_var_3 -> + happyIn42 (let (binds, sigs, ats, _) = cvBindsAndSigs (unLoc happy_var_3) - in - unitOL (L (comb3 happy_var_1 happy_var_2 happy_var_3) (InstD (InstDecl happy_var_2 binds sigs ats))) + in + unitOL (L (comb3 happy_var_1 happy_var_2 happy_var_3) (InstD (InstDecl happy_var_2 binds sigs ats))) )}}} -happyReduce_84 = happySpecReduce_1 32# happyReduction_84 -happyReduction_84 happy_x_1 - = case happyOut48 happy_x_1 of { happy_var_1 -> - happyIn40 +happyReduce_88 = happySpecReduce_1 34# happyReduction_88 +happyReduction_88 happy_x_1 + = case happyOut50 happy_x_1 of { happy_var_1 -> + happyIn42 (unitOL (sL (comb2 happy_var_1 happy_var_1) (DerivD (unLoc happy_var_1))) )} -happyReduce_85 = happyReduce 4# 32# happyReduction_85 -happyReduction_85 (happy_x_4 `HappyStk` +happyReduce_89 = happyReduce 4# 34# happyReduction_89 +happyReduction_89 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut96 happy_x_3 of { happy_var_3 -> + case happyOut98 happy_x_3 of { happy_var_3 -> case happyOutTok happy_x_4 of { happy_var_4 -> - happyIn40 + happyIn42 (unitOL (sL (comb2 happy_var_1 happy_var_4) $ DefD (DefaultDecl happy_var_3)) ) `HappyStk` happyRest}}} -happyReduce_86 = happySpecReduce_2 32# happyReduction_86 -happyReduction_86 happy_x_2 +happyReduce_90 = happySpecReduce_2 34# happyReduction_90 +happyReduction_90 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut75 happy_x_2 of { happy_var_2 -> - happyIn40 + case happyOut77 happy_x_2 of { happy_var_2 -> + happyIn42 (unitOL (sL (comb2 happy_var_1 happy_var_2) (unLoc happy_var_2)) )}} -happyReduce_87 = happySpecReduce_3 32# happyReduction_87 -happyReduction_87 happy_x_3 +happyReduce_91 = happySpecReduce_3 34# happyReduction_91 +happyReduction_91 happy_x_3 happy_x_2 happy_x_1 - = case happyOut70 happy_x_2 of { happy_var_2 -> - happyIn40 + = case happyOut72 happy_x_2 of { happy_var_2 -> + happyIn42 (happy_var_2 )} -happyReduce_88 = happySpecReduce_3 32# happyReduction_88 -happyReduction_88 happy_x_3 +happyReduce_92 = happySpecReduce_3 34# happyReduction_92 +happyReduction_92 happy_x_3 happy_x_2 happy_x_1 - = case happyOut68 happy_x_2 of { happy_var_2 -> - happyIn40 + = case happyOut70 happy_x_2 of { happy_var_2 -> + happyIn42 (happy_var_2 )} -happyReduce_89 = happySpecReduce_3 32# happyReduction_89 -happyReduction_89 happy_x_3 +happyReduce_93 = happySpecReduce_3 34# happyReduction_93 +happyReduction_93 happy_x_3 happy_x_2 happy_x_1 - = case happyOut61 happy_x_2 of { happy_var_2 -> - happyIn40 + = case happyOut63 happy_x_2 of { happy_var_2 -> + happyIn42 (happy_var_2 )} -happyReduce_90 = happySpecReduce_1 32# happyReduction_90 -happyReduction_90 happy_x_1 - = case happyOut74 happy_x_1 of { happy_var_1 -> - happyIn40 - (unitOL happy_var_1 - )} - -happyReduce_91 = happySpecReduce_1 32# happyReduction_91 -happyReduction_91 happy_x_1 - = case happyOut120 happy_x_1 of { happy_var_1 -> - happyIn40 - (unLoc happy_var_1 - )} - -happyReduce_92 = happySpecReduce_1 32# happyReduction_92 -happyReduction_92 happy_x_1 - = case happyOut127 happy_x_1 of { happy_var_1 -> - happyIn40 - (unitOL (sL (comb2 happy_var_1 happy_var_1) $ mkTopSpliceDecl happy_var_1) - )} - -happyReduce_93 = happyMonadReduce 4# 33# happyReduction_93 -happyReduction_93 (happy_x_4 `HappyStk` - happy_x_3 `HappyStk` - happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut47 happy_x_2 of { happy_var_2 -> - case happyOut100 happy_x_3 of { happy_var_3 -> - case happyOut52 happy_x_4 of { happy_var_4 -> - ( mkClassDecl (comb4 happy_var_1 happy_var_2 happy_var_3 happy_var_4) happy_var_2 happy_var_3 happy_var_4)}}}} - ) (\r -> happyReturn (happyIn41 r)) +happyReduce_94 = happySpecReduce_3 34# happyReduction_94 +happyReduction_94 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut204 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn42 + (unitOL $ sL (comb2 happy_var_1 happy_var_3) $ VectD (HsVect happy_var_2 Nothing) + )}}} -happyReduce_94 = happyMonadReduce 4# 34# happyReduction_94 -happyReduction_94 (happy_x_4 `HappyStk` +happyReduce_95 = happyReduce 5# 34# happyReduction_95 +happyReduction_95 (happy_x_5 `HappyStk` + happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut204 happy_x_2 of { happy_var_2 -> + case happyOut128 happy_x_4 of { happy_var_4 -> + case happyOutTok happy_x_5 of { happy_var_5 -> + happyIn42 + (unitOL $ sL (comb2 happy_var_1 happy_var_5) $ VectD (HsVect happy_var_2 (Just happy_var_4)) + ) `HappyStk` happyRest}}}} + +happyReduce_96 = happySpecReduce_3 34# happyReduction_96 +happyReduction_96 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut204 happy_x_2 of { happy_var_2 -> + case happyOutTok happy_x_3 of { happy_var_3 -> + happyIn42 + (unitOL $ sL (comb2 happy_var_1 happy_var_3) $ VectD (HsNoVect happy_var_2) + )}}} + +happyReduce_97 = happySpecReduce_1 34# happyReduction_97 +happyReduction_97 happy_x_1 + = case happyOut76 happy_x_1 of { happy_var_1 -> + happyIn42 + (unitOL happy_var_1 + )} + +happyReduce_98 = happySpecReduce_1 34# happyReduction_98 +happyReduction_98 happy_x_1 + = case happyOut122 happy_x_1 of { happy_var_1 -> + happyIn42 + (unLoc happy_var_1 + )} + +happyReduce_99 = happySpecReduce_1 34# happyReduction_99 +happyReduction_99 happy_x_1 + = case happyOut129 happy_x_1 of { happy_var_1 -> + happyIn42 + (unitOL (sL (comb2 happy_var_1 happy_var_1) $ mkTopSpliceDecl happy_var_1) + )} + +happyReduce_100 = happyMonadReduce 4# 35# happyReduction_100 +happyReduction_100 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut49 happy_x_2 of { happy_var_2 -> + case happyOut102 happy_x_3 of { happy_var_3 -> + case happyOut54 happy_x_4 of { happy_var_4 -> + ( mkClassDecl (comb4 happy_var_1 happy_var_2 happy_var_3 happy_var_4) happy_var_2 happy_var_3 happy_var_4)}}}} + ) (\r -> happyReturn (happyIn43 r)) + +happyReduce_101 = happyMonadReduce 4# 36# happyReduction_101 +happyReduction_101 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut90 happy_x_2 of { happy_var_2 -> - case happyOut88 happy_x_4 of { happy_var_4 -> + case happyOut92 happy_x_2 of { happy_var_2 -> + case happyOut90 happy_x_4 of { happy_var_4 -> ( mkTySynonym (comb2 happy_var_1 happy_var_4) False happy_var_2 happy_var_4)}}} - ) (\r -> happyReturn (happyIn42 r)) + ) (\r -> happyReturn (happyIn44 r)) -happyReduce_95 = happyMonadReduce 4# 34# happyReduction_95 -happyReduction_95 (happy_x_4 `HappyStk` +happyReduce_102 = happyMonadReduce 4# 36# happyReduction_102 +happyReduction_102 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut90 happy_x_3 of { happy_var_3 -> - case happyOut46 happy_x_4 of { happy_var_4 -> + case happyOut92 happy_x_3 of { happy_var_3 -> + case happyOut48 happy_x_4 of { happy_var_4 -> ( mkTyFamily (comb3 happy_var_1 happy_var_3 happy_var_4) TypeFamily happy_var_3 (unLoc happy_var_4))}}} - ) (\r -> happyReturn (happyIn42 r)) + ) (\r -> happyReturn (happyIn44 r)) -happyReduce_96 = happyMonadReduce 5# 34# happyReduction_96 -happyReduction_96 (happy_x_5 `HappyStk` +happyReduce_103 = happyMonadReduce 5# 36# happyReduction_103 +happyReduction_103 (happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut90 happy_x_3 of { happy_var_3 -> - case happyOut87 happy_x_5 of { happy_var_5 -> + case happyOut92 happy_x_3 of { happy_var_3 -> + case happyOut89 happy_x_5 of { happy_var_5 -> ( mkTySynonym (comb2 happy_var_1 happy_var_5) True happy_var_3 happy_var_5)}}} - ) (\r -> happyReturn (happyIn42 r)) + ) (\r -> happyReturn (happyIn44 r)) -happyReduce_97 = happyMonadReduce 4# 34# happyReduction_97 -happyReduction_97 (happy_x_4 `HappyStk` +happyReduce_104 = happyMonadReduce 4# 36# happyReduction_104 +happyReduction_104 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk - = happyThen (case happyOut45 happy_x_1 of { happy_var_1 -> - case happyOut47 happy_x_2 of { happy_var_2 -> - case happyOut109 happy_x_3 of { happy_var_3 -> - case happyOut117 happy_x_4 of { happy_var_4 -> + = happyThen (case happyOut47 happy_x_1 of { happy_var_1 -> + case happyOut49 happy_x_2 of { happy_var_2 -> + case happyOut111 happy_x_3 of { happy_var_3 -> + case happyOut119 happy_x_4 of { happy_var_4 -> ( mkTyData (comb4 happy_var_1 happy_var_2 happy_var_3 happy_var_4) (unLoc happy_var_1) False happy_var_2 Nothing (reverse (unLoc happy_var_3)) (unLoc happy_var_4))}}}} - ) (\r -> happyReturn (happyIn42 r)) + ) (\r -> happyReturn (happyIn44 r)) -happyReduce_98 = happyMonadReduce 5# 34# happyReduction_98 -happyReduction_98 (happy_x_5 `HappyStk` +happyReduce_105 = happyMonadReduce 5# 36# happyReduction_105 +happyReduction_105 (happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk - = happyThen (case happyOut45 happy_x_1 of { happy_var_1 -> - case happyOut47 happy_x_2 of { happy_var_2 -> - case happyOut46 happy_x_3 of { happy_var_3 -> - case happyOut106 happy_x_4 of { happy_var_4 -> - case happyOut117 happy_x_5 of { happy_var_5 -> + = happyThen (case happyOut47 happy_x_1 of { happy_var_1 -> + case happyOut49 happy_x_2 of { happy_var_2 -> + case happyOut48 happy_x_3 of { happy_var_3 -> + case happyOut108 happy_x_4 of { happy_var_4 -> + case happyOut119 happy_x_5 of { happy_var_5 -> ( mkTyData (comb4 happy_var_1 happy_var_2 happy_var_4 happy_var_5) (unLoc happy_var_1) False happy_var_2 (unLoc happy_var_3) (unLoc happy_var_4) (unLoc happy_var_5))}}}}} - ) (\r -> happyReturn (happyIn42 r)) + ) (\r -> happyReturn (happyIn44 r)) -happyReduce_99 = happyMonadReduce 4# 34# happyReduction_99 -happyReduction_99 (happy_x_4 `HappyStk` +happyReduce_106 = happyMonadReduce 4# 36# happyReduction_106 +happyReduction_106 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut90 happy_x_3 of { happy_var_3 -> - case happyOut46 happy_x_4 of { happy_var_4 -> + case happyOut92 happy_x_3 of { happy_var_3 -> + case happyOut48 happy_x_4 of { happy_var_4 -> ( mkTyFamily (comb3 happy_var_1 happy_var_2 happy_var_4) DataFamily happy_var_3 (unLoc happy_var_4))}}}} - ) (\r -> happyReturn (happyIn42 r)) + ) (\r -> happyReturn (happyIn44 r)) -happyReduce_100 = happyMonadReduce 5# 34# happyReduction_100 -happyReduction_100 (happy_x_5 `HappyStk` +happyReduce_107 = happyMonadReduce 5# 36# happyReduction_107 +happyReduction_107 (happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk - = happyThen (case happyOut45 happy_x_1 of { happy_var_1 -> - case happyOut47 happy_x_3 of { happy_var_3 -> - case happyOut109 happy_x_4 of { happy_var_4 -> - case happyOut117 happy_x_5 of { happy_var_5 -> + = happyThen (case happyOut47 happy_x_1 of { happy_var_1 -> + case happyOut49 happy_x_3 of { happy_var_3 -> + case happyOut111 happy_x_4 of { happy_var_4 -> + case happyOut119 happy_x_5 of { happy_var_5 -> ( mkTyData (comb4 happy_var_1 happy_var_3 happy_var_4 happy_var_5) (unLoc happy_var_1) True happy_var_3 Nothing (reverse (unLoc happy_var_4)) (unLoc happy_var_5))}}}} - ) (\r -> happyReturn (happyIn42 r)) + ) (\r -> happyReturn (happyIn44 r)) -happyReduce_101 = happyMonadReduce 6# 34# happyReduction_101 -happyReduction_101 (happy_x_6 `HappyStk` +happyReduce_108 = happyMonadReduce 6# 36# happyReduction_108 +happyReduction_108 (happy_x_6 `HappyStk` happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk - = happyThen (case happyOut45 happy_x_1 of { happy_var_1 -> - case happyOut47 happy_x_3 of { happy_var_3 -> - case happyOut46 happy_x_4 of { happy_var_4 -> - case happyOut106 happy_x_5 of { happy_var_5 -> - case happyOut117 happy_x_6 of { happy_var_6 -> + = happyThen (case happyOut47 happy_x_1 of { happy_var_1 -> + case happyOut49 happy_x_3 of { happy_var_3 -> + case happyOut48 happy_x_4 of { happy_var_4 -> + case happyOut108 happy_x_5 of { happy_var_5 -> + case happyOut119 happy_x_6 of { happy_var_6 -> ( mkTyData (comb4 happy_var_1 happy_var_3 happy_var_5 happy_var_6) (unLoc happy_var_1) True happy_var_3 (unLoc happy_var_4) (unLoc happy_var_5) (unLoc happy_var_6))}}}}} - ) (\r -> happyReturn (happyIn42 r)) + ) (\r -> happyReturn (happyIn44 r)) -happyReduce_102 = happyMonadReduce 3# 35# happyReduction_102 -happyReduction_102 (happy_x_3 `HappyStk` +happyReduce_109 = happyMonadReduce 3# 37# happyReduction_109 +happyReduction_109 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut90 happy_x_2 of { happy_var_2 -> - case happyOut46 happy_x_3 of { happy_var_3 -> + case happyOut92 happy_x_2 of { happy_var_2 -> + case happyOut48 happy_x_3 of { happy_var_3 -> ( mkTyFamily (comb3 happy_var_1 happy_var_2 happy_var_3) TypeFamily happy_var_2 (unLoc happy_var_3))}}} - ) (\r -> happyReturn (happyIn43 r)) + ) (\r -> happyReturn (happyIn45 r)) -happyReduce_103 = happyMonadReduce 4# 35# happyReduction_103 -happyReduction_103 (happy_x_4 `HappyStk` +happyReduce_110 = happyMonadReduce 4# 37# happyReduction_110 +happyReduction_110 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut90 happy_x_2 of { happy_var_2 -> - case happyOut87 happy_x_4 of { happy_var_4 -> + case happyOut92 happy_x_2 of { happy_var_2 -> + case happyOut89 happy_x_4 of { happy_var_4 -> ( mkTySynonym (comb2 happy_var_1 happy_var_4) True happy_var_2 happy_var_4)}}} - ) (\r -> happyReturn (happyIn43 r)) + ) (\r -> happyReturn (happyIn45 r)) -happyReduce_104 = happyMonadReduce 3# 35# happyReduction_104 -happyReduction_104 (happy_x_3 `HappyStk` +happyReduce_111 = happyMonadReduce 3# 37# happyReduction_111 +happyReduction_111 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut90 happy_x_2 of { happy_var_2 -> - case happyOut46 happy_x_3 of { happy_var_3 -> + case happyOut92 happy_x_2 of { happy_var_2 -> + case happyOut48 happy_x_3 of { happy_var_3 -> ( mkTyFamily (comb3 happy_var_1 happy_var_2 happy_var_3) DataFamily happy_var_2 (unLoc happy_var_3))}}} - ) (\r -> happyReturn (happyIn43 r)) + ) (\r -> happyReturn (happyIn45 r)) -happyReduce_105 = happyMonadReduce 4# 36# happyReduction_105 -happyReduction_105 (happy_x_4 `HappyStk` +happyReduce_112 = happyMonadReduce 4# 38# happyReduction_112 +happyReduction_112 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut90 happy_x_2 of { happy_var_2 -> - case happyOut87 happy_x_4 of { happy_var_4 -> + case happyOut92 happy_x_2 of { happy_var_2 -> + case happyOut89 happy_x_4 of { happy_var_4 -> ( mkTySynonym (comb2 happy_var_1 happy_var_4) True happy_var_2 happy_var_4)}}} - ) (\r -> happyReturn (happyIn44 r)) + ) (\r -> happyReturn (happyIn46 r)) -happyReduce_106 = happyMonadReduce 4# 36# happyReduction_106 -happyReduction_106 (happy_x_4 `HappyStk` +happyReduce_113 = happyMonadReduce 4# 38# happyReduction_113 +happyReduction_113 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk - = happyThen (case happyOut45 happy_x_1 of { happy_var_1 -> - case happyOut47 happy_x_2 of { happy_var_2 -> - case happyOut109 happy_x_3 of { happy_var_3 -> - case happyOut117 happy_x_4 of { happy_var_4 -> + = happyThen (case happyOut47 happy_x_1 of { happy_var_1 -> + case happyOut49 happy_x_2 of { happy_var_2 -> + case happyOut111 happy_x_3 of { happy_var_3 -> + case happyOut119 happy_x_4 of { happy_var_4 -> ( mkTyData (comb4 happy_var_1 happy_var_2 happy_var_3 happy_var_4) (unLoc happy_var_1) True happy_var_2 Nothing (reverse (unLoc happy_var_3)) (unLoc happy_var_4))}}}} - ) (\r -> happyReturn (happyIn44 r)) + ) (\r -> happyReturn (happyIn46 r)) -happyReduce_107 = happyMonadReduce 5# 36# happyReduction_107 -happyReduction_107 (happy_x_5 `HappyStk` +happyReduce_114 = happyMonadReduce 5# 38# happyReduction_114 +happyReduction_114 (happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk - = happyThen (case happyOut45 happy_x_1 of { happy_var_1 -> - case happyOut47 happy_x_2 of { happy_var_2 -> - case happyOut46 happy_x_3 of { happy_var_3 -> - case happyOut106 happy_x_4 of { happy_var_4 -> - case happyOut117 happy_x_5 of { happy_var_5 -> + = happyThen (case happyOut47 happy_x_1 of { happy_var_1 -> + case happyOut49 happy_x_2 of { happy_var_2 -> + case happyOut48 happy_x_3 of { happy_var_3 -> + case happyOut108 happy_x_4 of { happy_var_4 -> + case happyOut119 happy_x_5 of { happy_var_5 -> ( mkTyData (comb4 happy_var_1 happy_var_2 happy_var_4 happy_var_5) (unLoc happy_var_1) True happy_var_2 (unLoc happy_var_3) (unLoc happy_var_4) (unLoc happy_var_5))}}}}} - ) (\r -> happyReturn (happyIn44 r)) + ) (\r -> happyReturn (happyIn46 r)) -happyReduce_108 = happySpecReduce_1 37# happyReduction_108 -happyReduction_108 happy_x_1 +happyReduce_115 = happySpecReduce_1 39# happyReduction_115 +happyReduction_115 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn45 + happyIn47 (sL (getLoc happy_var_1) DataType )} -happyReduce_109 = happySpecReduce_1 37# happyReduction_109 -happyReduction_109 happy_x_1 +happyReduce_116 = happySpecReduce_1 39# happyReduction_116 +happyReduction_116 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn45 + happyIn47 (sL (getLoc happy_var_1) NewType )} -happyReduce_110 = happySpecReduce_0 38# happyReduction_110 -happyReduction_110 = happyIn46 +happyReduce_117 = happySpecReduce_0 40# happyReduction_117 +happyReduction_117 = happyIn48 (noLoc Nothing ) -happyReduce_111 = happySpecReduce_2 38# happyReduction_111 -happyReduction_111 happy_x_2 +happyReduce_118 = happySpecReduce_2 40# happyReduction_118 +happyReduction_118 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut104 happy_x_2 of { happy_var_2 -> - happyIn46 + case happyOut106 happy_x_2 of { happy_var_2 -> + happyIn48 (sL (comb2 happy_var_1 happy_var_2) (Just (unLoc happy_var_2)) )}} -happyReduce_112 = happySpecReduce_3 39# happyReduction_112 -happyReduction_112 happy_x_3 +happyReduce_119 = happySpecReduce_3 41# happyReduction_119 +happyReduction_119 happy_x_3 happy_x_2 happy_x_1 - = case happyOut89 happy_x_1 of { happy_var_1 -> - case happyOut90 happy_x_3 of { happy_var_3 -> - happyIn47 + = case happyOut91 happy_x_1 of { happy_var_1 -> + case happyOut92 happy_x_3 of { happy_var_3 -> + happyIn49 (sL (comb2 happy_var_1 happy_var_3) (Just happy_var_1, happy_var_3) )}} -happyReduce_113 = happySpecReduce_1 39# happyReduction_113 -happyReduction_113 happy_x_1 - = case happyOut90 happy_x_1 of { happy_var_1 -> - happyIn47 +happyReduce_120 = happySpecReduce_1 41# happyReduction_120 +happyReduction_120 happy_x_1 + = case happyOut92 happy_x_1 of { happy_var_1 -> + happyIn49 (sL (getLoc happy_var_1) (Nothing, happy_var_1) )} -happyReduce_114 = happySpecReduce_3 40# happyReduction_114 -happyReduction_114 happy_x_3 +happyReduce_121 = happySpecReduce_3 42# happyReduction_121 +happyReduction_121 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut94 happy_x_3 of { happy_var_3 -> - happyIn48 + case happyOut96 happy_x_3 of { happy_var_3 -> + happyIn50 (sL (comb2 happy_var_1 happy_var_3) (DerivDecl happy_var_3) )}} -happyReduce_115 = happySpecReduce_1 41# happyReduction_115 -happyReduction_115 happy_x_1 - = case happyOut43 happy_x_1 of { happy_var_1 -> - happyIn49 +happyReduce_122 = happySpecReduce_1 43# happyReduction_122 +happyReduction_122 happy_x_1 + = case happyOut45 happy_x_1 of { happy_var_1 -> + happyIn51 (sL (comb2 happy_var_1 happy_var_1) (unitOL (sL (getLoc happy_var_1) (TyClD (unLoc happy_var_1)))) )} -happyReduce_116 = happySpecReduce_1 41# happyReduction_116 -happyReduction_116 happy_x_1 - = case happyOut120 happy_x_1 of { happy_var_1 -> - happyIn49 +happyReduce_123 = happySpecReduce_1 43# happyReduction_123 +happyReduction_123 happy_x_1 + = case happyOut122 happy_x_1 of { happy_var_1 -> + happyIn51 (happy_var_1 )} -happyReduce_117 = happySpecReduce_3 42# happyReduction_117 -happyReduction_117 happy_x_3 +happyReduce_124 = happyMonadReduce 4# 43# happyReduction_124 +happyReduction_124 (happy_x_4 `HappyStk` + happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut129 happy_x_2 of { happy_var_2 -> + case happyOut84 happy_x_4 of { happy_var_4 -> + ( do { (TypeSig l ty) <- checkValSig happy_var_2 happy_var_4 + ; return (sL (comb2 happy_var_1 happy_var_4) $ unitOL (sL (comb2 happy_var_1 happy_var_4) $ SigD (GenericSig l ty))) })}}} + ) (\r -> happyReturn (happyIn51 r)) + +happyReduce_125 = happySpecReduce_3 44# happyReduction_125 +happyReduction_125 happy_x_3 happy_x_2 happy_x_1 - = case happyOut50 happy_x_1 of { happy_var_1 -> - case happyOut49 happy_x_3 of { happy_var_3 -> - happyIn50 + = case happyOut52 happy_x_1 of { happy_var_1 -> + case happyOut51 happy_x_3 of { happy_var_3 -> + happyIn52 (sL (comb2 happy_var_1 happy_var_3) (unLoc happy_var_1 `appOL` unLoc happy_var_3) )}} -happyReduce_118 = happySpecReduce_2 42# happyReduction_118 -happyReduction_118 happy_x_2 +happyReduce_126 = happySpecReduce_2 44# happyReduction_126 +happyReduction_126 happy_x_2 happy_x_1 - = case happyOut50 happy_x_1 of { happy_var_1 -> + = case happyOut52 happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> - happyIn50 + happyIn52 (sL (comb2 happy_var_1 happy_var_2) (unLoc happy_var_1) )}} -happyReduce_119 = happySpecReduce_1 42# happyReduction_119 -happyReduction_119 happy_x_1 - = case happyOut49 happy_x_1 of { happy_var_1 -> - happyIn50 +happyReduce_127 = happySpecReduce_1 44# happyReduction_127 +happyReduction_127 happy_x_1 + = case happyOut51 happy_x_1 of { happy_var_1 -> + happyIn52 (happy_var_1 )} -happyReduce_120 = happySpecReduce_0 42# happyReduction_120 -happyReduction_120 = happyIn50 +happyReduce_128 = happySpecReduce_0 44# happyReduction_128 +happyReduction_128 = happyIn52 (noLoc nilOL ) -happyReduce_121 = happySpecReduce_3 43# happyReduction_121 -happyReduction_121 happy_x_3 +happyReduce_129 = happySpecReduce_3 45# happyReduction_129 +happyReduction_129 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut50 happy_x_2 of { happy_var_2 -> + case happyOut52 happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn51 + happyIn53 (sL (comb2 happy_var_1 happy_var_3) (unLoc happy_var_2) )}}} -happyReduce_122 = happySpecReduce_3 43# happyReduction_122 -happyReduction_122 happy_x_3 +happyReduce_130 = happySpecReduce_3 45# happyReduction_130 +happyReduction_130 happy_x_3 happy_x_2 happy_x_1 - = case happyOut50 happy_x_2 of { happy_var_2 -> - happyIn51 + = case happyOut52 happy_x_2 of { happy_var_2 -> + happyIn53 (happy_var_2 )} -happyReduce_123 = happySpecReduce_2 44# happyReduction_123 -happyReduction_123 happy_x_2 +happyReduce_131 = happySpecReduce_2 46# happyReduction_131 +happyReduction_131 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut51 happy_x_2 of { happy_var_2 -> - happyIn52 + case happyOut53 happy_x_2 of { happy_var_2 -> + happyIn54 (sL (comb2 happy_var_1 happy_var_2) (unLoc happy_var_2) )}} -happyReduce_124 = happySpecReduce_0 44# happyReduction_124 -happyReduction_124 = happyIn52 +happyReduce_132 = happySpecReduce_0 46# happyReduction_132 +happyReduction_132 = happyIn54 (noLoc nilOL ) -happyReduce_125 = happySpecReduce_1 45# happyReduction_125 -happyReduction_125 happy_x_1 - = case happyOut44 happy_x_1 of { happy_var_1 -> - happyIn53 +happyReduce_133 = happySpecReduce_1 47# happyReduction_133 +happyReduction_133 happy_x_1 + = case happyOut46 happy_x_1 of { happy_var_1 -> + happyIn55 (sL (comb2 happy_var_1 happy_var_1) (unitOL (sL (getLoc happy_var_1) (TyClD (unLoc happy_var_1)))) )} -happyReduce_126 = happySpecReduce_1 45# happyReduction_126 -happyReduction_126 happy_x_1 - = case happyOut120 happy_x_1 of { happy_var_1 -> - happyIn53 +happyReduce_134 = happySpecReduce_1 47# happyReduction_134 +happyReduction_134 happy_x_1 + = case happyOut122 happy_x_1 of { happy_var_1 -> + happyIn55 (happy_var_1 )} -happyReduce_127 = happySpecReduce_3 46# happyReduction_127 -happyReduction_127 happy_x_3 +happyReduce_135 = happySpecReduce_3 48# happyReduction_135 +happyReduction_135 happy_x_3 happy_x_2 happy_x_1 - = case happyOut54 happy_x_1 of { happy_var_1 -> - case happyOut53 happy_x_3 of { happy_var_3 -> - happyIn54 + = case happyOut56 happy_x_1 of { happy_var_1 -> + case happyOut55 happy_x_3 of { happy_var_3 -> + happyIn56 (sL (comb2 happy_var_1 happy_var_3) (unLoc happy_var_1 `appOL` unLoc happy_var_3) )}} -happyReduce_128 = happySpecReduce_2 46# happyReduction_128 -happyReduction_128 happy_x_2 +happyReduce_136 = happySpecReduce_2 48# happyReduction_136 +happyReduction_136 happy_x_2 happy_x_1 - = case happyOut54 happy_x_1 of { happy_var_1 -> + = case happyOut56 happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> - happyIn54 + happyIn56 (sL (comb2 happy_var_1 happy_var_2) (unLoc happy_var_1) )}} -happyReduce_129 = happySpecReduce_1 46# happyReduction_129 -happyReduction_129 happy_x_1 - = case happyOut53 happy_x_1 of { happy_var_1 -> - happyIn54 +happyReduce_137 = happySpecReduce_1 48# happyReduction_137 +happyReduction_137 happy_x_1 + = case happyOut55 happy_x_1 of { happy_var_1 -> + happyIn56 (happy_var_1 )} -happyReduce_130 = happySpecReduce_0 46# happyReduction_130 -happyReduction_130 = happyIn54 +happyReduce_138 = happySpecReduce_0 48# happyReduction_138 +happyReduction_138 = happyIn56 (noLoc nilOL ) -happyReduce_131 = happySpecReduce_3 47# happyReduction_131 -happyReduction_131 happy_x_3 +happyReduce_139 = happySpecReduce_3 49# happyReduction_139 +happyReduction_139 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut54 happy_x_2 of { happy_var_2 -> + case happyOut56 happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn55 + happyIn57 (sL (comb2 happy_var_1 happy_var_3) (unLoc happy_var_2) )}}} -happyReduce_132 = happySpecReduce_3 47# happyReduction_132 -happyReduction_132 happy_x_3 +happyReduce_140 = happySpecReduce_3 49# happyReduction_140 +happyReduction_140 happy_x_3 happy_x_2 happy_x_1 - = case happyOut54 happy_x_2 of { happy_var_2 -> - happyIn55 + = case happyOut56 happy_x_2 of { happy_var_2 -> + happyIn57 (happy_var_2 )} -happyReduce_133 = happySpecReduce_2 48# happyReduction_133 -happyReduction_133 happy_x_2 +happyReduce_141 = happySpecReduce_2 50# happyReduction_141 +happyReduction_141 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut55 happy_x_2 of { happy_var_2 -> - happyIn56 + case happyOut57 happy_x_2 of { happy_var_2 -> + happyIn58 (sL (comb2 happy_var_1 happy_var_2) (unLoc happy_var_2) )}} -happyReduce_134 = happySpecReduce_0 48# happyReduction_134 -happyReduction_134 = happyIn56 +happyReduce_142 = happySpecReduce_0 50# happyReduction_142 +happyReduction_142 = happyIn58 (noLoc nilOL ) -happyReduce_135 = happySpecReduce_3 49# happyReduction_135 -happyReduction_135 happy_x_3 +happyReduce_143 = happySpecReduce_3 51# happyReduction_143 +happyReduction_143 happy_x_3 happy_x_2 happy_x_1 - = case happyOut57 happy_x_1 of { happy_var_1 -> - case happyOut120 happy_x_3 of { happy_var_3 -> - happyIn57 + = case happyOut59 happy_x_1 of { happy_var_1 -> + case happyOut122 happy_x_3 of { happy_var_3 -> + happyIn59 (let { this = unLoc happy_var_3; rest = unLoc happy_var_1; these = rest `appOL` this } @@ -3180,120 +3268,120 @@ sL (comb2 happy_var_1 happy_var_3) these )}} -happyReduce_136 = happySpecReduce_2 49# happyReduction_136 -happyReduction_136 happy_x_2 +happyReduce_144 = happySpecReduce_2 51# happyReduction_144 +happyReduction_144 happy_x_2 happy_x_1 - = case happyOut57 happy_x_1 of { happy_var_1 -> + = case happyOut59 happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> - happyIn57 + happyIn59 (sL (comb2 happy_var_1 happy_var_2) (unLoc happy_var_1) )}} -happyReduce_137 = happySpecReduce_1 49# happyReduction_137 -happyReduction_137 happy_x_1 - = case happyOut120 happy_x_1 of { happy_var_1 -> - happyIn57 +happyReduce_145 = happySpecReduce_1 51# happyReduction_145 +happyReduction_145 happy_x_1 + = case happyOut122 happy_x_1 of { happy_var_1 -> + happyIn59 (happy_var_1 )} -happyReduce_138 = happySpecReduce_0 49# happyReduction_138 -happyReduction_138 = happyIn57 +happyReduce_146 = happySpecReduce_0 51# happyReduction_146 +happyReduction_146 = happyIn59 (noLoc nilOL ) -happyReduce_139 = happySpecReduce_3 50# happyReduction_139 -happyReduction_139 happy_x_3 +happyReduce_147 = happySpecReduce_3 52# happyReduction_147 +happyReduction_147 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut57 happy_x_2 of { happy_var_2 -> + case happyOut59 happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn58 + happyIn60 (sL (comb2 happy_var_1 happy_var_3) (unLoc happy_var_2) )}}} -happyReduce_140 = happySpecReduce_3 50# happyReduction_140 -happyReduction_140 happy_x_3 +happyReduce_148 = happySpecReduce_3 52# happyReduction_148 +happyReduction_148 happy_x_3 happy_x_2 happy_x_1 - = case happyOut57 happy_x_2 of { happy_var_2 -> - happyIn58 + = case happyOut59 happy_x_2 of { happy_var_2 -> + happyIn60 (happy_var_2 )} -happyReduce_141 = happySpecReduce_1 51# happyReduction_141 -happyReduction_141 happy_x_1 - = case happyOut58 happy_x_1 of { happy_var_1 -> - happyIn59 +happyReduce_149 = happySpecReduce_1 53# happyReduction_149 +happyReduction_149 happy_x_1 + = case happyOut60 happy_x_1 of { happy_var_1 -> + happyIn61 (sL (getLoc happy_var_1) (HsValBinds (cvBindGroup (unLoc happy_var_1))) )} -happyReduce_142 = happySpecReduce_3 51# happyReduction_142 -happyReduction_142 happy_x_3 +happyReduce_150 = happySpecReduce_3 53# happyReduction_150 +happyReduction_150 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut173 happy_x_2 of { happy_var_2 -> + case happyOut175 happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn59 + happyIn61 (sL (comb2 happy_var_1 happy_var_3) (HsIPBinds (IPBinds (unLoc happy_var_2) emptyTcEvBinds)) )}}} -happyReduce_143 = happySpecReduce_3 51# happyReduction_143 -happyReduction_143 happy_x_3 +happyReduce_151 = happySpecReduce_3 53# happyReduction_151 +happyReduction_151 happy_x_3 happy_x_2 happy_x_1 - = case happyOut173 happy_x_2 of { happy_var_2 -> - happyIn59 + = case happyOut175 happy_x_2 of { happy_var_2 -> + happyIn61 (L (getLoc happy_var_2) (HsIPBinds (IPBinds (unLoc happy_var_2) emptyTcEvBinds)) )} -happyReduce_144 = happySpecReduce_2 52# happyReduction_144 -happyReduction_144 happy_x_2 +happyReduce_152 = happySpecReduce_2 54# happyReduction_152 +happyReduction_152 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut59 happy_x_2 of { happy_var_2 -> - happyIn60 + case happyOut61 happy_x_2 of { happy_var_2 -> + happyIn62 (sL (comb2 happy_var_1 happy_var_2) (unLoc happy_var_2) )}} -happyReduce_145 = happySpecReduce_0 52# happyReduction_145 -happyReduction_145 = happyIn60 +happyReduce_153 = happySpecReduce_0 54# happyReduction_153 +happyReduction_153 = happyIn62 (noLoc emptyLocalBinds ) -happyReduce_146 = happySpecReduce_3 53# happyReduction_146 -happyReduction_146 happy_x_3 +happyReduce_154 = happySpecReduce_3 55# happyReduction_154 +happyReduction_154 happy_x_3 happy_x_2 happy_x_1 - = case happyOut61 happy_x_1 of { happy_var_1 -> - case happyOut62 happy_x_3 of { happy_var_3 -> - happyIn61 + = case happyOut63 happy_x_1 of { happy_var_1 -> + case happyOut64 happy_x_3 of { happy_var_3 -> + happyIn63 (happy_var_1 `snocOL` happy_var_3 )}} -happyReduce_147 = happySpecReduce_2 53# happyReduction_147 -happyReduction_147 happy_x_2 +happyReduce_155 = happySpecReduce_2 55# happyReduction_155 +happyReduction_155 happy_x_2 happy_x_1 - = case happyOut61 happy_x_1 of { happy_var_1 -> - happyIn61 + = case happyOut63 happy_x_1 of { happy_var_1 -> + happyIn63 (happy_var_1 )} -happyReduce_148 = happySpecReduce_1 53# happyReduction_148 -happyReduction_148 happy_x_1 - = case happyOut62 happy_x_1 of { happy_var_1 -> - happyIn61 +happyReduce_156 = happySpecReduce_1 55# happyReduction_156 +happyReduction_156 happy_x_1 + = case happyOut64 happy_x_1 of { happy_var_1 -> + happyIn63 (unitOL happy_var_1 )} -happyReduce_149 = happySpecReduce_0 53# happyReduction_149 -happyReduction_149 = happyIn61 +happyReduce_157 = happySpecReduce_0 55# happyReduction_157 +happyReduction_157 = happyIn63 (nilOL ) -happyReduce_150 = happyReduce 6# 54# happyReduction_150 -happyReduction_150 (happy_x_6 `HappyStk` +happyReduce_158 = happyReduce 6# 56# happyReduction_158 +happyReduction_158 (happy_x_6 `HappyStk` happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` @@ -3301,1517 +3389,1511 @@ happy_x_1 `HappyStk` happyRest) = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut63 happy_x_2 of { happy_var_2 -> - case happyOut65 happy_x_3 of { happy_var_3 -> - case happyOut127 happy_x_4 of { happy_var_4 -> - case happyOut126 happy_x_6 of { happy_var_6 -> - happyIn62 + case happyOut65 happy_x_2 of { happy_var_2 -> + case happyOut67 happy_x_3 of { happy_var_3 -> + case happyOut129 happy_x_4 of { happy_var_4 -> + case happyOut128 happy_x_6 of { happy_var_6 -> + happyIn64 (sL (comb2 happy_var_1 happy_var_6) $ RuleD (HsRule (getSTRING happy_var_1) (happy_var_2 `orElse` AlwaysActive) happy_var_3 happy_var_4 placeHolderNames happy_var_6 placeHolderNames) ) `HappyStk` happyRest}}}}} -happyReduce_151 = happySpecReduce_0 55# happyReduction_151 -happyReduction_151 = happyIn63 +happyReduce_159 = happySpecReduce_0 57# happyReduction_159 +happyReduction_159 = happyIn65 (Nothing ) -happyReduce_152 = happySpecReduce_1 55# happyReduction_152 -happyReduction_152 happy_x_1 - = case happyOut64 happy_x_1 of { happy_var_1 -> - happyIn63 +happyReduce_160 = happySpecReduce_1 57# happyReduction_160 +happyReduction_160 happy_x_1 + = case happyOut66 happy_x_1 of { happy_var_1 -> + happyIn65 (Just happy_var_1 )} -happyReduce_153 = happySpecReduce_3 56# happyReduction_153 -happyReduction_153 happy_x_3 +happyReduce_161 = happySpecReduce_3 58# happyReduction_161 +happyReduction_161 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_2 of { happy_var_2 -> - happyIn64 + happyIn66 (ActiveAfter (fromInteger (getINTEGER happy_var_2)) )} -happyReduce_154 = happyReduce 4# 56# happyReduction_154 -happyReduction_154 (happy_x_4 `HappyStk` +happyReduce_162 = happyReduce 4# 58# happyReduction_162 +happyReduction_162 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) = case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn64 + happyIn66 (ActiveBefore (fromInteger (getINTEGER happy_var_3)) ) `HappyStk` happyRest} -happyReduce_155 = happySpecReduce_3 57# happyReduction_155 -happyReduction_155 happy_x_3 +happyReduce_163 = happySpecReduce_3 59# happyReduction_163 +happyReduction_163 happy_x_3 happy_x_2 happy_x_1 - = case happyOut66 happy_x_2 of { happy_var_2 -> - happyIn65 + = case happyOut68 happy_x_2 of { happy_var_2 -> + happyIn67 (happy_var_2 )} -happyReduce_156 = happySpecReduce_0 57# happyReduction_156 -happyReduction_156 = happyIn65 +happyReduce_164 = happySpecReduce_0 59# happyReduction_164 +happyReduction_164 = happyIn67 ([] ) -happyReduce_157 = happySpecReduce_1 58# happyReduction_157 -happyReduction_157 happy_x_1 - = case happyOut67 happy_x_1 of { happy_var_1 -> - happyIn66 +happyReduce_165 = happySpecReduce_1 60# happyReduction_165 +happyReduction_165 happy_x_1 + = case happyOut69 happy_x_1 of { happy_var_1 -> + happyIn68 ([happy_var_1] )} -happyReduce_158 = happySpecReduce_2 58# happyReduction_158 -happyReduction_158 happy_x_2 +happyReduce_166 = happySpecReduce_2 60# happyReduction_166 +happyReduction_166 happy_x_2 happy_x_1 - = case happyOut67 happy_x_1 of { happy_var_1 -> - case happyOut66 happy_x_2 of { happy_var_2 -> - happyIn66 + = case happyOut69 happy_x_1 of { happy_var_1 -> + case happyOut68 happy_x_2 of { happy_var_2 -> + happyIn68 (happy_var_1 : happy_var_2 )}} -happyReduce_159 = happySpecReduce_1 59# happyReduction_159 -happyReduction_159 happy_x_1 - = case happyOut204 happy_x_1 of { happy_var_1 -> - happyIn67 +happyReduce_167 = happySpecReduce_1 61# happyReduction_167 +happyReduction_167 happy_x_1 + = case happyOut206 happy_x_1 of { happy_var_1 -> + happyIn69 (RuleBndr happy_var_1 )} -happyReduce_160 = happyReduce 5# 59# happyReduction_160 -happyReduction_160 (happy_x_5 `HappyStk` +happyReduce_168 = happyReduce 5# 61# happyReduction_168 +happyReduction_168 (happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) - = case happyOut204 happy_x_2 of { happy_var_2 -> - case happyOut87 happy_x_4 of { happy_var_4 -> - happyIn67 + = case happyOut206 happy_x_2 of { happy_var_2 -> + case happyOut89 happy_x_4 of { happy_var_4 -> + happyIn69 (RuleBndrSig happy_var_2 happy_var_4 ) `HappyStk` happyRest}} -happyReduce_161 = happySpecReduce_3 60# happyReduction_161 -happyReduction_161 happy_x_3 +happyReduce_169 = happySpecReduce_3 62# happyReduction_169 +happyReduction_169 happy_x_3 happy_x_2 happy_x_1 - = case happyOut68 happy_x_1 of { happy_var_1 -> - case happyOut69 happy_x_3 of { happy_var_3 -> - happyIn68 + = case happyOut70 happy_x_1 of { happy_var_1 -> + case happyOut71 happy_x_3 of { happy_var_3 -> + happyIn70 (happy_var_1 `appOL` happy_var_3 )}} -happyReduce_162 = happySpecReduce_2 60# happyReduction_162 -happyReduction_162 happy_x_2 +happyReduce_170 = happySpecReduce_2 62# happyReduction_170 +happyReduction_170 happy_x_2 happy_x_1 - = case happyOut68 happy_x_1 of { happy_var_1 -> - happyIn68 + = case happyOut70 happy_x_1 of { happy_var_1 -> + happyIn70 (happy_var_1 )} -happyReduce_163 = happySpecReduce_1 60# happyReduction_163 -happyReduction_163 happy_x_1 - = case happyOut69 happy_x_1 of { happy_var_1 -> - happyIn68 +happyReduce_171 = happySpecReduce_1 62# happyReduction_171 +happyReduction_171 happy_x_1 + = case happyOut71 happy_x_1 of { happy_var_1 -> + happyIn70 (happy_var_1 )} -happyReduce_164 = happySpecReduce_0 60# happyReduction_164 -happyReduction_164 = happyIn68 +happyReduce_172 = happySpecReduce_0 62# happyReduction_172 +happyReduction_172 = happyIn70 (nilOL ) -happyReduce_165 = happySpecReduce_2 61# happyReduction_165 -happyReduction_165 happy_x_2 +happyReduce_173 = happySpecReduce_2 63# happyReduction_173 +happyReduction_173 happy_x_2 happy_x_1 - = case happyOut176 happy_x_1 of { happy_var_1 -> - case happyOut72 happy_x_2 of { happy_var_2 -> - happyIn69 + = case happyOut178 happy_x_1 of { happy_var_1 -> + case happyOut74 happy_x_2 of { happy_var_2 -> + happyIn71 (toOL [ sL (comb2 happy_var_1 happy_var_2) $ WarningD (Warning n (WarningTxt $ unLoc happy_var_2)) | n <- unLoc happy_var_1 ] )}} -happyReduce_166 = happySpecReduce_3 62# happyReduction_166 -happyReduction_166 happy_x_3 +happyReduce_174 = happySpecReduce_3 64# happyReduction_174 +happyReduction_174 happy_x_3 happy_x_2 happy_x_1 - = case happyOut70 happy_x_1 of { happy_var_1 -> - case happyOut71 happy_x_3 of { happy_var_3 -> - happyIn70 + = case happyOut72 happy_x_1 of { happy_var_1 -> + case happyOut73 happy_x_3 of { happy_var_3 -> + happyIn72 (happy_var_1 `appOL` happy_var_3 )}} -happyReduce_167 = happySpecReduce_2 62# happyReduction_167 -happyReduction_167 happy_x_2 +happyReduce_175 = happySpecReduce_2 64# happyReduction_175 +happyReduction_175 happy_x_2 happy_x_1 - = case happyOut70 happy_x_1 of { happy_var_1 -> - happyIn70 + = case happyOut72 happy_x_1 of { happy_var_1 -> + happyIn72 (happy_var_1 )} -happyReduce_168 = happySpecReduce_1 62# happyReduction_168 -happyReduction_168 happy_x_1 - = case happyOut71 happy_x_1 of { happy_var_1 -> - happyIn70 +happyReduce_176 = happySpecReduce_1 64# happyReduction_176 +happyReduction_176 happy_x_1 + = case happyOut73 happy_x_1 of { happy_var_1 -> + happyIn72 (happy_var_1 )} -happyReduce_169 = happySpecReduce_0 62# happyReduction_169 -happyReduction_169 = happyIn70 +happyReduce_177 = happySpecReduce_0 64# happyReduction_177 +happyReduction_177 = happyIn72 (nilOL ) -happyReduce_170 = happySpecReduce_2 63# happyReduction_170 -happyReduction_170 happy_x_2 +happyReduce_178 = happySpecReduce_2 65# happyReduction_178 +happyReduction_178 happy_x_2 happy_x_1 - = case happyOut176 happy_x_1 of { happy_var_1 -> - case happyOut72 happy_x_2 of { happy_var_2 -> - happyIn71 + = case happyOut178 happy_x_1 of { happy_var_1 -> + case happyOut74 happy_x_2 of { happy_var_2 -> + happyIn73 (toOL [ sL (comb2 happy_var_1 happy_var_2) $ WarningD (Warning n (DeprecatedTxt $ unLoc happy_var_2)) | n <- unLoc happy_var_1 ] )}} -happyReduce_171 = happySpecReduce_1 64# happyReduction_171 -happyReduction_171 happy_x_1 +happyReduce_179 = happySpecReduce_1 66# happyReduction_179 +happyReduction_179 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn72 + happyIn74 (sL (getLoc happy_var_1) [getSTRING happy_var_1] )} -happyReduce_172 = happySpecReduce_3 64# happyReduction_172 -happyReduction_172 happy_x_3 +happyReduce_180 = happySpecReduce_3 66# happyReduction_180 +happyReduction_180 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut73 happy_x_2 of { happy_var_2 -> + case happyOut75 happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn72 + happyIn74 (sL (comb2 happy_var_1 happy_var_3) $ fromOL (unLoc happy_var_2) )}}} -happyReduce_173 = happySpecReduce_3 65# happyReduction_173 -happyReduction_173 happy_x_3 +happyReduce_181 = happySpecReduce_3 67# happyReduction_181 +happyReduction_181 happy_x_3 happy_x_2 happy_x_1 - = case happyOut73 happy_x_1 of { happy_var_1 -> + = case happyOut75 happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn73 + happyIn75 (sL (comb2 happy_var_1 happy_var_3) (unLoc happy_var_1 `snocOL` getSTRING happy_var_3) )}} -happyReduce_174 = happySpecReduce_1 65# happyReduction_174 -happyReduction_174 happy_x_1 +happyReduce_182 = happySpecReduce_1 67# happyReduction_182 +happyReduction_182 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn73 + happyIn75 (sL (comb2 happy_var_1 happy_var_1) (unitOL (getSTRING happy_var_1)) )} -happyReduce_175 = happyReduce 4# 66# happyReduction_175 -happyReduction_175 (happy_x_4 `HappyStk` +happyReduce_183 = happyReduce 4# 68# happyReduction_183 +happyReduction_183 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut177 happy_x_2 of { happy_var_2 -> - case happyOut133 happy_x_3 of { happy_var_3 -> + case happyOut179 happy_x_2 of { happy_var_2 -> + case happyOut135 happy_x_3 of { happy_var_3 -> case happyOutTok happy_x_4 of { happy_var_4 -> - happyIn74 + happyIn76 (sL (comb2 happy_var_1 happy_var_4) (AnnD $ HsAnnotation (ValueAnnProvenance (unLoc happy_var_2)) happy_var_3) ) `HappyStk` happyRest}}}} -happyReduce_176 = happyReduce 5# 66# happyReduction_176 -happyReduction_176 (happy_x_5 `HappyStk` +happyReduce_184 = happyReduce 5# 68# happyReduction_184 +happyReduction_184 (happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut188 happy_x_3 of { happy_var_3 -> - case happyOut133 happy_x_4 of { happy_var_4 -> + case happyOut190 happy_x_3 of { happy_var_3 -> + case happyOut135 happy_x_4 of { happy_var_4 -> case happyOutTok happy_x_5 of { happy_var_5 -> - happyIn74 + happyIn76 (sL (comb2 happy_var_1 happy_var_5) (AnnD $ HsAnnotation (TypeAnnProvenance (unLoc happy_var_3)) happy_var_4) ) `HappyStk` happyRest}}}} -happyReduce_177 = happyReduce 4# 66# happyReduction_177 -happyReduction_177 (happy_x_4 `HappyStk` +happyReduce_185 = happyReduce 4# 68# happyReduction_185 +happyReduction_185 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut133 happy_x_3 of { happy_var_3 -> + case happyOut135 happy_x_3 of { happy_var_3 -> case happyOutTok happy_x_4 of { happy_var_4 -> - happyIn74 + happyIn76 (sL (comb2 happy_var_1 happy_var_4) (AnnD $ HsAnnotation ModuleAnnProvenance happy_var_3) ) `HappyStk` happyRest}}} -happyReduce_178 = happyMonadReduce 4# 67# happyReduction_178 -happyReduction_178 (happy_x_4 `HappyStk` +happyReduce_186 = happyMonadReduce 4# 69# happyReduction_186 +happyReduction_186 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut76 happy_x_2 of { happy_var_2 -> - case happyOut77 happy_x_3 of { happy_var_3 -> - case happyOut78 happy_x_4 of { happy_var_4 -> + case happyOut78 happy_x_2 of { happy_var_2 -> + case happyOut79 happy_x_3 of { happy_var_3 -> + case happyOut80 happy_x_4 of { happy_var_4 -> ( mkImport happy_var_2 happy_var_3 (unLoc happy_var_4) >>= return.sL (comb2 happy_var_1 happy_var_4))}}}} - ) (\r -> happyReturn (happyIn75 r)) + ) (\r -> happyReturn (happyIn77 r)) -happyReduce_179 = happyMonadReduce 3# 67# happyReduction_179 -happyReduction_179 (happy_x_3 `HappyStk` +happyReduce_187 = happyMonadReduce 3# 69# happyReduction_187 +happyReduction_187 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut76 happy_x_2 of { happy_var_2 -> - case happyOut78 happy_x_3 of { happy_var_3 -> - ( do { d <- mkImport happy_var_2 (PlaySafe False) (unLoc happy_var_3); + case happyOut78 happy_x_2 of { happy_var_2 -> + case happyOut80 happy_x_3 of { happy_var_3 -> + ( do { d <- mkImport happy_var_2 PlaySafe (unLoc happy_var_3); return (sL (comb2 happy_var_1 happy_var_3) d) })}}} - ) (\r -> happyReturn (happyIn75 r)) + ) (\r -> happyReturn (happyIn77 r)) -happyReduce_180 = happyMonadReduce 3# 67# happyReduction_180 -happyReduction_180 (happy_x_3 `HappyStk` +happyReduce_188 = happyMonadReduce 3# 69# happyReduction_188 +happyReduction_188 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut76 happy_x_2 of { happy_var_2 -> - case happyOut78 happy_x_3 of { happy_var_3 -> + case happyOut78 happy_x_2 of { happy_var_2 -> + case happyOut80 happy_x_3 of { happy_var_3 -> ( mkExport happy_var_2 (unLoc happy_var_3) >>= return.sL (comb2 happy_var_1 happy_var_3))}}} - ) (\r -> happyReturn (happyIn75 r)) + ) (\r -> happyReturn (happyIn77 r)) -happyReduce_181 = happySpecReduce_1 68# happyReduction_181 -happyReduction_181 happy_x_1 - = happyIn76 +happyReduce_189 = happySpecReduce_1 70# happyReduction_189 +happyReduction_189 happy_x_1 + = happyIn78 (StdCallConv ) -happyReduce_182 = happySpecReduce_1 68# happyReduction_182 -happyReduction_182 happy_x_1 - = happyIn76 +happyReduce_190 = happySpecReduce_1 70# happyReduction_190 +happyReduction_190 happy_x_1 + = happyIn78 (CCallConv ) -happyReduce_183 = happySpecReduce_1 68# happyReduction_183 -happyReduction_183 happy_x_1 - = happyIn76 +happyReduce_191 = happySpecReduce_1 70# happyReduction_191 +happyReduction_191 happy_x_1 + = happyIn78 (PrimCallConv ) -happyReduce_184 = happySpecReduce_1 69# happyReduction_184 -happyReduction_184 happy_x_1 - = happyIn77 +happyReduce_192 = happySpecReduce_1 71# happyReduction_192 +happyReduction_192 happy_x_1 + = happyIn79 (PlayRisky ) -happyReduce_185 = happySpecReduce_1 69# happyReduction_185 -happyReduction_185 happy_x_1 - = happyIn77 - (PlaySafe False +happyReduce_193 = happySpecReduce_1 71# happyReduction_193 +happyReduction_193 happy_x_1 + = happyIn79 + (PlaySafe ) -happyReduce_186 = happySpecReduce_1 69# happyReduction_186 -happyReduction_186 happy_x_1 - = happyIn77 - (PlaySafe True +happyReduce_194 = happySpecReduce_1 71# happyReduction_194 +happyReduction_194 happy_x_1 + = happyIn79 + (PlayInterruptible ) -happyReduce_187 = happyReduce 4# 70# happyReduction_187 -happyReduction_187 (happy_x_4 `HappyStk` +happyReduce_195 = happyReduce 4# 72# happyReduction_195 +happyReduction_195 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut201 happy_x_2 of { happy_var_2 -> - case happyOut82 happy_x_4 of { happy_var_4 -> - happyIn78 + case happyOut203 happy_x_2 of { happy_var_2 -> + case happyOut84 happy_x_4 of { happy_var_4 -> + happyIn80 (sL (comb2 happy_var_1 happy_var_4) (L (getLoc happy_var_1) (getSTRING happy_var_1), happy_var_2, happy_var_4) ) `HappyStk` happyRest}}} -happyReduce_188 = happySpecReduce_3 70# happyReduction_188 -happyReduction_188 happy_x_3 +happyReduce_196 = happySpecReduce_3 72# happyReduction_196 +happyReduction_196 happy_x_3 happy_x_2 happy_x_1 - = case happyOut201 happy_x_1 of { happy_var_1 -> - case happyOut82 happy_x_3 of { happy_var_3 -> - happyIn78 + = case happyOut203 happy_x_1 of { happy_var_1 -> + case happyOut84 happy_x_3 of { happy_var_3 -> + happyIn80 (sL (comb2 happy_var_1 happy_var_3) (noLoc nilFS, happy_var_1, happy_var_3) )}} -happyReduce_189 = happySpecReduce_0 71# happyReduction_189 -happyReduction_189 = happyIn79 +happyReduce_197 = happySpecReduce_0 73# happyReduction_197 +happyReduction_197 = happyIn81 (Nothing ) -happyReduce_190 = happySpecReduce_2 71# happyReduction_190 -happyReduction_190 happy_x_2 +happyReduce_198 = happySpecReduce_2 73# happyReduction_198 +happyReduction_198 happy_x_2 happy_x_1 - = case happyOut81 happy_x_2 of { happy_var_2 -> - happyIn79 + = case happyOut83 happy_x_2 of { happy_var_2 -> + happyIn81 (Just happy_var_2 )} -happyReduce_191 = happySpecReduce_0 72# happyReduction_191 -happyReduction_191 = happyIn80 +happyReduce_199 = happySpecReduce_0 74# happyReduction_199 +happyReduction_199 = happyIn82 (Nothing ) -happyReduce_192 = happySpecReduce_2 72# happyReduction_192 -happyReduction_192 happy_x_2 +happyReduce_200 = happySpecReduce_2 74# happyReduction_200 +happyReduction_200 happy_x_2 happy_x_1 - = case happyOut93 happy_x_2 of { happy_var_2 -> - happyIn80 + = case happyOut95 happy_x_2 of { happy_var_2 -> + happyIn82 (Just happy_var_2 )} -happyReduce_193 = happySpecReduce_1 73# happyReduction_193 -happyReduction_193 happy_x_1 - = case happyOut87 happy_x_1 of { happy_var_1 -> - happyIn81 +happyReduce_201 = happySpecReduce_1 75# happyReduction_201 +happyReduction_201 happy_x_1 + = case happyOut89 happy_x_1 of { happy_var_1 -> + happyIn83 (sL (getLoc happy_var_1) (mkImplicitHsForAllTy (noLoc []) happy_var_1) )} -happyReduce_194 = happySpecReduce_1 74# happyReduction_194 -happyReduction_194 happy_x_1 - = case happyOut88 happy_x_1 of { happy_var_1 -> - happyIn82 +happyReduce_202 = happySpecReduce_1 76# happyReduction_202 +happyReduction_202 happy_x_1 + = case happyOut90 happy_x_1 of { happy_var_1 -> + happyIn84 (sL (getLoc happy_var_1) (mkImplicitHsForAllTy (noLoc []) happy_var_1) )} -happyReduce_195 = happySpecReduce_3 75# happyReduction_195 -happyReduction_195 happy_x_3 +happyReduce_203 = happySpecReduce_3 77# happyReduction_203 +happyReduction_203 happy_x_3 happy_x_2 happy_x_1 - = case happyOut83 happy_x_1 of { happy_var_1 -> - case happyOut201 happy_x_3 of { happy_var_3 -> - happyIn83 + = case happyOut85 happy_x_1 of { happy_var_1 -> + case happyOut203 happy_x_3 of { happy_var_3 -> + happyIn85 (sL (comb2 happy_var_1 happy_var_3) (happy_var_3 : unLoc happy_var_1) )}} -happyReduce_196 = happySpecReduce_1 75# happyReduction_196 -happyReduction_196 happy_x_1 - = case happyOut201 happy_x_1 of { happy_var_1 -> - happyIn83 +happyReduce_204 = happySpecReduce_1 77# happyReduction_204 +happyReduction_204 happy_x_1 + = case happyOut203 happy_x_1 of { happy_var_1 -> + happyIn85 (sL (getLoc happy_var_1) [happy_var_1] )} -happyReduce_197 = happySpecReduce_1 76# happyReduction_197 -happyReduction_197 happy_x_1 - = case happyOut81 happy_x_1 of { happy_var_1 -> - happyIn84 +happyReduce_205 = happySpecReduce_1 78# happyReduction_205 +happyReduction_205 happy_x_1 + = case happyOut83 happy_x_1 of { happy_var_1 -> + happyIn86 ([ happy_var_1 ] )} -happyReduce_198 = happySpecReduce_3 76# happyReduction_198 -happyReduction_198 happy_x_3 +happyReduce_206 = happySpecReduce_3 78# happyReduction_206 +happyReduction_206 happy_x_3 happy_x_2 happy_x_1 - = case happyOut81 happy_x_1 of { happy_var_1 -> - case happyOut84 happy_x_3 of { happy_var_3 -> - happyIn84 + = case happyOut83 happy_x_1 of { happy_var_1 -> + case happyOut86 happy_x_3 of { happy_var_3 -> + happyIn86 (happy_var_1 : happy_var_3 )}} -happyReduce_199 = happySpecReduce_3 77# happyReduction_199 -happyReduction_199 happy_x_3 +happyReduce_207 = happySpecReduce_3 79# happyReduction_207 +happyReduction_207 happy_x_3 happy_x_2 happy_x_1 - = case happyOut92 happy_x_1 of { happy_var_1 -> - case happyOut186 happy_x_2 of { happy_var_2 -> - case happyOut90 happy_x_3 of { happy_var_3 -> - happyIn85 + = case happyOut94 happy_x_1 of { happy_var_1 -> + case happyOut188 happy_x_2 of { happy_var_2 -> + case happyOut92 happy_x_3 of { happy_var_3 -> + happyIn87 (sL (comb2 happy_var_1 happy_var_3) $ HsOpTy happy_var_1 happy_var_2 happy_var_3 )}}} -happyReduce_200 = happySpecReduce_3 77# happyReduction_200 -happyReduction_200 happy_x_3 +happyReduce_208 = happySpecReduce_3 79# happyReduction_208 +happyReduction_208 happy_x_3 happy_x_2 happy_x_1 - = case happyOut92 happy_x_1 of { happy_var_1 -> - case happyOut198 happy_x_2 of { happy_var_2 -> - case happyOut90 happy_x_3 of { happy_var_3 -> - happyIn85 + = case happyOut94 happy_x_1 of { happy_var_1 -> + case happyOut200 happy_x_2 of { happy_var_2 -> + case happyOut92 happy_x_3 of { happy_var_3 -> + happyIn87 (sL (comb2 happy_var_1 happy_var_3) $ HsOpTy happy_var_1 happy_var_2 happy_var_3 )}}} -happyReduce_201 = happySpecReduce_1 78# happyReduction_201 -happyReduction_201 happy_x_1 +happyReduce_209 = happySpecReduce_1 80# happyReduction_209 +happyReduction_209 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn86 + happyIn88 (sL (getLoc happy_var_1) HsStrict )} -happyReduce_202 = happySpecReduce_3 78# happyReduction_202 -happyReduction_202 happy_x_3 +happyReduce_210 = happySpecReduce_3 80# happyReduction_210 +happyReduction_210 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn86 + happyIn88 (sL (comb2 happy_var_1 happy_var_3) HsUnpack )}} -happyReduce_203 = happyReduce 4# 79# happyReduction_203 -happyReduction_203 (happy_x_4 `HappyStk` +happyReduce_211 = happyReduce 4# 81# happyReduction_211 +happyReduction_211 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut98 happy_x_2 of { happy_var_2 -> - case happyOut87 happy_x_4 of { happy_var_4 -> - happyIn87 + case happyOut100 happy_x_2 of { happy_var_2 -> + case happyOut89 happy_x_4 of { happy_var_4 -> + happyIn89 (sL (comb2 happy_var_1 happy_var_4) $ mkExplicitHsForAllTy happy_var_2 (noLoc []) happy_var_4 ) `HappyStk` happyRest}}} -happyReduce_204 = happySpecReduce_3 79# happyReduction_204 -happyReduction_204 happy_x_3 +happyReduce_212 = happySpecReduce_3 81# happyReduction_212 +happyReduction_212 happy_x_3 happy_x_2 happy_x_1 - = case happyOut89 happy_x_1 of { happy_var_1 -> - case happyOut87 happy_x_3 of { happy_var_3 -> - happyIn87 + = case happyOut91 happy_x_1 of { happy_var_1 -> + case happyOut89 happy_x_3 of { happy_var_3 -> + happyIn89 (sL (comb2 happy_var_1 happy_var_3) $ mkImplicitHsForAllTy happy_var_1 happy_var_3 )}} -happyReduce_205 = happySpecReduce_3 79# happyReduction_205 -happyReduction_205 happy_x_3 +happyReduce_213 = happySpecReduce_3 81# happyReduction_213 +happyReduction_213 happy_x_3 happy_x_2 happy_x_1 - = case happyOut175 happy_x_1 of { happy_var_1 -> - case happyOut90 happy_x_3 of { happy_var_3 -> - happyIn87 + = case happyOut177 happy_x_1 of { happy_var_1 -> + case happyOut92 happy_x_3 of { happy_var_3 -> + happyIn89 (sL (comb2 happy_var_1 happy_var_3) (HsPredTy (HsIParam (unLoc happy_var_1) happy_var_3)) )}} -happyReduce_206 = happySpecReduce_1 79# happyReduction_206 -happyReduction_206 happy_x_1 - = case happyOut90 happy_x_1 of { happy_var_1 -> - happyIn87 +happyReduce_214 = happySpecReduce_1 81# happyReduction_214 +happyReduction_214 happy_x_1 + = case happyOut92 happy_x_1 of { happy_var_1 -> + happyIn89 (happy_var_1 )} -happyReduce_207 = happyReduce 4# 80# happyReduction_207 -happyReduction_207 (happy_x_4 `HappyStk` +happyReduce_215 = happyReduce 4# 82# happyReduction_215 +happyReduction_215 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut98 happy_x_2 of { happy_var_2 -> - case happyOut88 happy_x_4 of { happy_var_4 -> - happyIn88 + case happyOut100 happy_x_2 of { happy_var_2 -> + case happyOut90 happy_x_4 of { happy_var_4 -> + happyIn90 (sL (comb2 happy_var_1 happy_var_4) $ mkExplicitHsForAllTy happy_var_2 (noLoc []) happy_var_4 ) `HappyStk` happyRest}}} -happyReduce_208 = happySpecReduce_3 80# happyReduction_208 -happyReduction_208 happy_x_3 +happyReduce_216 = happySpecReduce_3 82# happyReduction_216 +happyReduction_216 happy_x_3 happy_x_2 happy_x_1 - = case happyOut89 happy_x_1 of { happy_var_1 -> - case happyOut88 happy_x_3 of { happy_var_3 -> - happyIn88 + = case happyOut91 happy_x_1 of { happy_var_1 -> + case happyOut90 happy_x_3 of { happy_var_3 -> + happyIn90 (sL (comb2 happy_var_1 happy_var_3) $ mkImplicitHsForAllTy happy_var_1 happy_var_3 )}} -happyReduce_209 = happySpecReduce_3 80# happyReduction_209 -happyReduction_209 happy_x_3 +happyReduce_217 = happySpecReduce_3 82# happyReduction_217 +happyReduction_217 happy_x_3 happy_x_2 happy_x_1 - = case happyOut175 happy_x_1 of { happy_var_1 -> - case happyOut90 happy_x_3 of { happy_var_3 -> - happyIn88 + = case happyOut177 happy_x_1 of { happy_var_1 -> + case happyOut92 happy_x_3 of { happy_var_3 -> + happyIn90 (sL (comb2 happy_var_1 happy_var_3) (HsPredTy (HsIParam (unLoc happy_var_1) happy_var_3)) )}} -happyReduce_210 = happySpecReduce_1 80# happyReduction_210 -happyReduction_210 happy_x_1 - = case happyOut91 happy_x_1 of { happy_var_1 -> - happyIn88 +happyReduce_218 = happySpecReduce_1 82# happyReduction_218 +happyReduction_218 happy_x_1 + = case happyOut93 happy_x_1 of { happy_var_1 -> + happyIn90 (happy_var_1 )} -happyReduce_211 = happyMonadReduce 3# 81# happyReduction_211 -happyReduction_211 (happy_x_3 `HappyStk` +happyReduce_219 = happyMonadReduce 3# 83# happyReduction_219 +happyReduction_219 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk - = happyThen (case happyOut92 happy_x_1 of { happy_var_1 -> - case happyOut92 happy_x_3 of { happy_var_3 -> + = happyThen (case happyOut94 happy_x_1 of { happy_var_1 -> + case happyOut94 happy_x_3 of { happy_var_3 -> ( checkContext (sL (comb2 happy_var_1 happy_var_3) $ HsPredTy (HsEqualP happy_var_1 happy_var_3)))}} - ) (\r -> happyReturn (happyIn89 r)) + ) (\r -> happyReturn (happyIn91 r)) -happyReduce_212 = happyMonadReduce 1# 81# happyReduction_212 -happyReduction_212 (happy_x_1 `HappyStk` +happyReduce_220 = happyMonadReduce 1# 83# happyReduction_220 +happyReduction_220 (happy_x_1 `HappyStk` happyRest) tk - = happyThen (case happyOut92 happy_x_1 of { happy_var_1 -> + = happyThen (case happyOut94 happy_x_1 of { happy_var_1 -> ( checkContext happy_var_1)} - ) (\r -> happyReturn (happyIn89 r)) + ) (\r -> happyReturn (happyIn91 r)) -happyReduce_213 = happySpecReduce_1 82# happyReduction_213 -happyReduction_213 happy_x_1 - = case happyOut92 happy_x_1 of { happy_var_1 -> - happyIn90 +happyReduce_221 = happySpecReduce_1 84# happyReduction_221 +happyReduction_221 happy_x_1 + = case happyOut94 happy_x_1 of { happy_var_1 -> + happyIn92 (happy_var_1 )} -happyReduce_214 = happySpecReduce_3 82# happyReduction_214 -happyReduction_214 happy_x_3 +happyReduce_222 = happySpecReduce_3 84# happyReduction_222 +happyReduction_222 happy_x_3 happy_x_2 happy_x_1 - = case happyOut92 happy_x_1 of { happy_var_1 -> - case happyOut186 happy_x_2 of { happy_var_2 -> - case happyOut90 happy_x_3 of { happy_var_3 -> - happyIn90 + = case happyOut94 happy_x_1 of { happy_var_1 -> + case happyOut188 happy_x_2 of { happy_var_2 -> + case happyOut92 happy_x_3 of { happy_var_3 -> + happyIn92 (sL (comb2 happy_var_1 happy_var_3) $ HsOpTy happy_var_1 happy_var_2 happy_var_3 )}}} -happyReduce_215 = happySpecReduce_3 82# happyReduction_215 -happyReduction_215 happy_x_3 +happyReduce_223 = happySpecReduce_3 84# happyReduction_223 +happyReduction_223 happy_x_3 happy_x_2 happy_x_1 - = case happyOut92 happy_x_1 of { happy_var_1 -> - case happyOut198 happy_x_2 of { happy_var_2 -> - case happyOut90 happy_x_3 of { happy_var_3 -> - happyIn90 + = case happyOut94 happy_x_1 of { happy_var_1 -> + case happyOut200 happy_x_2 of { happy_var_2 -> + case happyOut92 happy_x_3 of { happy_var_3 -> + happyIn92 (sL (comb2 happy_var_1 happy_var_3) $ HsOpTy happy_var_1 happy_var_2 happy_var_3 )}}} -happyReduce_216 = happySpecReduce_3 82# happyReduction_216 -happyReduction_216 happy_x_3 +happyReduce_224 = happySpecReduce_3 84# happyReduction_224 +happyReduction_224 happy_x_3 happy_x_2 happy_x_1 - = case happyOut92 happy_x_1 of { happy_var_1 -> - case happyOut87 happy_x_3 of { happy_var_3 -> - happyIn90 + = case happyOut94 happy_x_1 of { happy_var_1 -> + case happyOut89 happy_x_3 of { happy_var_3 -> + happyIn92 (sL (comb2 happy_var_1 happy_var_3) $ HsFunTy happy_var_1 happy_var_3 )}} -happyReduce_217 = happySpecReduce_3 82# happyReduction_217 -happyReduction_217 happy_x_3 +happyReduce_225 = happySpecReduce_3 84# happyReduction_225 +happyReduction_225 happy_x_3 happy_x_2 happy_x_1 - = case happyOut92 happy_x_1 of { happy_var_1 -> - case happyOut92 happy_x_3 of { happy_var_3 -> - happyIn90 + = case happyOut94 happy_x_1 of { happy_var_1 -> + case happyOut94 happy_x_3 of { happy_var_3 -> + happyIn92 (sL (comb2 happy_var_1 happy_var_3) $ HsPredTy (HsEqualP happy_var_1 happy_var_3) )}} -happyReduce_218 = happySpecReduce_1 83# happyReduction_218 -happyReduction_218 happy_x_1 - = case happyOut92 happy_x_1 of { happy_var_1 -> - happyIn91 +happyReduce_226 = happySpecReduce_1 85# happyReduction_226 +happyReduction_226 happy_x_1 + = case happyOut94 happy_x_1 of { happy_var_1 -> + happyIn93 (happy_var_1 )} -happyReduce_219 = happySpecReduce_2 83# happyReduction_219 -happyReduction_219 happy_x_2 +happyReduce_227 = happySpecReduce_2 85# happyReduction_227 +happyReduction_227 happy_x_2 happy_x_1 - = case happyOut92 happy_x_1 of { happy_var_1 -> - case happyOut221 happy_x_2 of { happy_var_2 -> - happyIn91 + = case happyOut94 happy_x_1 of { happy_var_1 -> + case happyOut223 happy_x_2 of { happy_var_2 -> + happyIn93 (sL (comb2 happy_var_1 happy_var_2) $ HsDocTy happy_var_1 happy_var_2 )}} -happyReduce_220 = happySpecReduce_3 83# happyReduction_220 -happyReduction_220 happy_x_3 +happyReduce_228 = happySpecReduce_3 85# happyReduction_228 +happyReduction_228 happy_x_3 happy_x_2 happy_x_1 - = case happyOut92 happy_x_1 of { happy_var_1 -> - case happyOut186 happy_x_2 of { happy_var_2 -> - case happyOut90 happy_x_3 of { happy_var_3 -> - happyIn91 + = case happyOut94 happy_x_1 of { happy_var_1 -> + case happyOut188 happy_x_2 of { happy_var_2 -> + case happyOut92 happy_x_3 of { happy_var_3 -> + happyIn93 (sL (comb2 happy_var_1 happy_var_3) $ HsOpTy happy_var_1 happy_var_2 happy_var_3 )}}} -happyReduce_221 = happyReduce 4# 83# happyReduction_221 -happyReduction_221 (happy_x_4 `HappyStk` +happyReduce_229 = happyReduce 4# 85# happyReduction_229 +happyReduction_229 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) - = case happyOut92 happy_x_1 of { happy_var_1 -> - case happyOut186 happy_x_2 of { happy_var_2 -> - case happyOut90 happy_x_3 of { happy_var_3 -> - case happyOut221 happy_x_4 of { happy_var_4 -> - happyIn91 + = case happyOut94 happy_x_1 of { happy_var_1 -> + case happyOut188 happy_x_2 of { happy_var_2 -> + case happyOut92 happy_x_3 of { happy_var_3 -> + case happyOut223 happy_x_4 of { happy_var_4 -> + happyIn93 (sL (comb2 happy_var_1 happy_var_4) $ HsDocTy (L (comb3 happy_var_1 happy_var_2 happy_var_3) (HsOpTy happy_var_1 happy_var_2 happy_var_3)) happy_var_4 ) `HappyStk` happyRest}}}} -happyReduce_222 = happySpecReduce_3 83# happyReduction_222 -happyReduction_222 happy_x_3 +happyReduce_230 = happySpecReduce_3 85# happyReduction_230 +happyReduction_230 happy_x_3 happy_x_2 happy_x_1 - = case happyOut92 happy_x_1 of { happy_var_1 -> - case happyOut198 happy_x_2 of { happy_var_2 -> - case happyOut90 happy_x_3 of { happy_var_3 -> - happyIn91 + = case happyOut94 happy_x_1 of { happy_var_1 -> + case happyOut200 happy_x_2 of { happy_var_2 -> + case happyOut92 happy_x_3 of { happy_var_3 -> + happyIn93 (sL (comb2 happy_var_1 happy_var_3) $ HsOpTy happy_var_1 happy_var_2 happy_var_3 )}}} -happyReduce_223 = happyReduce 4# 83# happyReduction_223 -happyReduction_223 (happy_x_4 `HappyStk` +happyReduce_231 = happyReduce 4# 85# happyReduction_231 +happyReduction_231 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) - = case happyOut92 happy_x_1 of { happy_var_1 -> - case happyOut198 happy_x_2 of { happy_var_2 -> - case happyOut90 happy_x_3 of { happy_var_3 -> - case happyOut221 happy_x_4 of { happy_var_4 -> - happyIn91 + = case happyOut94 happy_x_1 of { happy_var_1 -> + case happyOut200 happy_x_2 of { happy_var_2 -> + case happyOut92 happy_x_3 of { happy_var_3 -> + case happyOut223 happy_x_4 of { happy_var_4 -> + happyIn93 (sL (comb2 happy_var_1 happy_var_4) $ HsDocTy (L (comb3 happy_var_1 happy_var_2 happy_var_3) (HsOpTy happy_var_1 happy_var_2 happy_var_3)) happy_var_4 ) `HappyStk` happyRest}}}} -happyReduce_224 = happySpecReduce_3 83# happyReduction_224 -happyReduction_224 happy_x_3 +happyReduce_232 = happySpecReduce_3 85# happyReduction_232 +happyReduction_232 happy_x_3 happy_x_2 happy_x_1 - = case happyOut92 happy_x_1 of { happy_var_1 -> - case happyOut88 happy_x_3 of { happy_var_3 -> - happyIn91 + = case happyOut94 happy_x_1 of { happy_var_1 -> + case happyOut90 happy_x_3 of { happy_var_3 -> + happyIn93 (sL (comb2 happy_var_1 happy_var_3) $ HsFunTy happy_var_1 happy_var_3 )}} -happyReduce_225 = happyReduce 4# 83# happyReduction_225 -happyReduction_225 (happy_x_4 `HappyStk` +happyReduce_233 = happyReduce 4# 85# happyReduction_233 +happyReduction_233 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) - = case happyOut92 happy_x_1 of { happy_var_1 -> - case happyOut221 happy_x_2 of { happy_var_2 -> - case happyOut88 happy_x_4 of { happy_var_4 -> - happyIn91 + = case happyOut94 happy_x_1 of { happy_var_1 -> + case happyOut223 happy_x_2 of { happy_var_2 -> + case happyOut90 happy_x_4 of { happy_var_4 -> + happyIn93 (sL (comb2 happy_var_1 happy_var_4) $ HsFunTy (L (comb2 happy_var_1 happy_var_2) (HsDocTy happy_var_1 happy_var_2)) happy_var_4 ) `HappyStk` happyRest}}} -happyReduce_226 = happySpecReduce_3 83# happyReduction_226 -happyReduction_226 happy_x_3 +happyReduce_234 = happySpecReduce_3 85# happyReduction_234 +happyReduction_234 happy_x_3 happy_x_2 happy_x_1 - = case happyOut92 happy_x_1 of { happy_var_1 -> - case happyOut92 happy_x_3 of { happy_var_3 -> - happyIn91 + = case happyOut94 happy_x_1 of { happy_var_1 -> + case happyOut94 happy_x_3 of { happy_var_3 -> + happyIn93 (sL (comb2 happy_var_1 happy_var_3) $ HsPredTy (HsEqualP happy_var_1 happy_var_3) )}} -happyReduce_227 = happySpecReduce_2 84# happyReduction_227 -happyReduction_227 happy_x_2 +happyReduce_235 = happySpecReduce_2 86# happyReduction_235 +happyReduction_235 happy_x_2 happy_x_1 - = case happyOut92 happy_x_1 of { happy_var_1 -> - case happyOut93 happy_x_2 of { happy_var_2 -> - happyIn92 + = case happyOut94 happy_x_1 of { happy_var_1 -> + case happyOut95 happy_x_2 of { happy_var_2 -> + happyIn94 (sL (comb2 happy_var_1 happy_var_2) $ HsAppTy happy_var_1 happy_var_2 )}} -happyReduce_228 = happySpecReduce_1 84# happyReduction_228 -happyReduction_228 happy_x_1 - = case happyOut93 happy_x_1 of { happy_var_1 -> - happyIn92 +happyReduce_236 = happySpecReduce_1 86# happyReduction_236 +happyReduction_236 happy_x_1 + = case happyOut95 happy_x_1 of { happy_var_1 -> + happyIn94 (happy_var_1 )} -happyReduce_229 = happySpecReduce_1 85# happyReduction_229 -happyReduction_229 happy_x_1 - = case happyOut184 happy_x_1 of { happy_var_1 -> - happyIn93 +happyReduce_237 = happySpecReduce_1 87# happyReduction_237 +happyReduction_237 happy_x_1 + = case happyOut186 happy_x_1 of { happy_var_1 -> + happyIn95 (sL (getLoc happy_var_1) (HsTyVar (unLoc happy_var_1)) )} -happyReduce_230 = happySpecReduce_1 85# happyReduction_230 -happyReduction_230 happy_x_1 - = case happyOut197 happy_x_1 of { happy_var_1 -> - happyIn93 +happyReduce_238 = happySpecReduce_1 87# happyReduction_238 +happyReduction_238 happy_x_1 + = case happyOut199 happy_x_1 of { happy_var_1 -> + happyIn95 (sL (getLoc happy_var_1) (HsTyVar (unLoc happy_var_1)) )} -happyReduce_231 = happySpecReduce_2 85# happyReduction_231 -happyReduction_231 happy_x_2 +happyReduce_239 = happySpecReduce_2 87# happyReduction_239 +happyReduction_239 happy_x_2 happy_x_1 - = case happyOut86 happy_x_1 of { happy_var_1 -> - case happyOut93 happy_x_2 of { happy_var_2 -> - happyIn93 + = case happyOut88 happy_x_1 of { happy_var_1 -> + case happyOut95 happy_x_2 of { happy_var_2 -> + happyIn95 (sL (comb2 happy_var_1 happy_var_2) (HsBangTy (unLoc happy_var_1) happy_var_2) )}} -happyReduce_232 = happySpecReduce_3 85# happyReduction_232 -happyReduction_232 happy_x_3 +happyReduce_240 = happySpecReduce_3 87# happyReduction_240 +happyReduction_240 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut114 happy_x_2 of { happy_var_2 -> + case happyOut116 happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn93 + happyIn95 (sL (comb2 happy_var_1 happy_var_3) $ HsRecTy happy_var_2 )}}} -happyReduce_233 = happyReduce 5# 85# happyReduction_233 -happyReduction_233 (happy_x_5 `HappyStk` +happyReduce_241 = happyReduce 5# 87# happyReduction_241 +happyReduction_241 (happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut87 happy_x_2 of { happy_var_2 -> - case happyOut97 happy_x_4 of { happy_var_4 -> + case happyOut89 happy_x_2 of { happy_var_2 -> + case happyOut99 happy_x_4 of { happy_var_4 -> case happyOutTok happy_x_5 of { happy_var_5 -> - happyIn93 + happyIn95 (sL (comb2 happy_var_1 happy_var_5) $ HsTupleTy Boxed (happy_var_2:happy_var_4) ) `HappyStk` happyRest}}}} -happyReduce_234 = happySpecReduce_3 85# happyReduction_234 -happyReduction_234 happy_x_3 +happyReduce_242 = happySpecReduce_3 87# happyReduction_242 +happyReduction_242 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut97 happy_x_2 of { happy_var_2 -> + case happyOut99 happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn93 + happyIn95 (sL (comb2 happy_var_1 happy_var_3) $ HsTupleTy Unboxed happy_var_2 )}}} -happyReduce_235 = happySpecReduce_3 85# happyReduction_235 -happyReduction_235 happy_x_3 +happyReduce_243 = happySpecReduce_3 87# happyReduction_243 +happyReduction_243 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut87 happy_x_2 of { happy_var_2 -> + case happyOut89 happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn93 + happyIn95 (sL (comb2 happy_var_1 happy_var_3) $ HsListTy happy_var_2 )}}} -happyReduce_236 = happySpecReduce_3 85# happyReduction_236 -happyReduction_236 happy_x_3 +happyReduce_244 = happySpecReduce_3 87# happyReduction_244 +happyReduction_244 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut87 happy_x_2 of { happy_var_2 -> + case happyOut89 happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn93 + happyIn95 (sL (comb2 happy_var_1 happy_var_3) $ HsPArrTy happy_var_2 )}}} -happyReduce_237 = happySpecReduce_3 85# happyReduction_237 -happyReduction_237 happy_x_3 +happyReduce_245 = happySpecReduce_3 87# happyReduction_245 +happyReduction_245 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut87 happy_x_2 of { happy_var_2 -> + case happyOut89 happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn93 + happyIn95 (sL (comb2 happy_var_1 happy_var_3) $ HsParTy happy_var_2 )}}} -happyReduce_238 = happyReduce 5# 85# happyReduction_238 -happyReduction_238 (happy_x_5 `HappyStk` +happyReduce_246 = happyReduce 5# 87# happyReduction_246 +happyReduction_246 (happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut87 happy_x_2 of { happy_var_2 -> - case happyOut104 happy_x_4 of { happy_var_4 -> + case happyOut89 happy_x_2 of { happy_var_2 -> + case happyOut106 happy_x_4 of { happy_var_4 -> case happyOutTok happy_x_5 of { happy_var_5 -> - happyIn93 + happyIn95 (sL (comb2 happy_var_1 happy_var_5) $ HsKindSig happy_var_2 (unLoc happy_var_4) ) `HappyStk` happyRest}}}} -happyReduce_239 = happySpecReduce_1 85# happyReduction_239 -happyReduction_239 happy_x_1 - = case happyOut125 happy_x_1 of { happy_var_1 -> - happyIn93 +happyReduce_247 = happySpecReduce_1 87# happyReduction_247 +happyReduction_247 happy_x_1 + = case happyOut127 happy_x_1 of { happy_var_1 -> + happyIn95 (sL (getLoc happy_var_1) (HsQuasiQuoteTy (unLoc happy_var_1)) )} -happyReduce_240 = happySpecReduce_3 85# happyReduction_240 -happyReduction_240 happy_x_3 +happyReduce_248 = happySpecReduce_3 87# happyReduction_248 +happyReduction_248 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut126 happy_x_2 of { happy_var_2 -> + case happyOut128 happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn93 + happyIn95 (sL (comb2 happy_var_1 happy_var_3) $ mkHsSpliceTy happy_var_2 )}}} -happyReduce_241 = happySpecReduce_1 85# happyReduction_241 -happyReduction_241 happy_x_1 +happyReduce_249 = happySpecReduce_1 87# happyReduction_249 +happyReduction_249 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn93 + happyIn95 (sL (comb2 happy_var_1 happy_var_1) $ mkHsSpliceTy $ sL (getLoc happy_var_1) $ HsVar $ mkUnqual varName (getTH_ID_SPLICE happy_var_1) )} -happyReduce_242 = happySpecReduce_1 85# happyReduction_242 -happyReduction_242 happy_x_1 - = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn93 - (sL (getLoc happy_var_1) (HsNumTy (getINTEGER happy_var_1)) - )} - -happyReduce_243 = happyMonadReduce 1# 86# happyReduction_243 -happyReduction_243 (happy_x_1 `HappyStk` +happyReduce_250 = happyMonadReduce 1# 88# happyReduction_250 +happyReduction_250 (happy_x_1 `HappyStk` happyRest) tk - = happyThen (case happyOut81 happy_x_1 of { happy_var_1 -> + = happyThen (case happyOut83 happy_x_1 of { happy_var_1 -> ( checkInstType happy_var_1)} - ) (\r -> happyReturn (happyIn94 r)) + ) (\r -> happyReturn (happyIn96 r)) -happyReduce_244 = happySpecReduce_1 87# happyReduction_244 -happyReduction_244 happy_x_1 - = case happyOut94 happy_x_1 of { happy_var_1 -> - happyIn95 +happyReduce_251 = happySpecReduce_1 89# happyReduction_251 +happyReduction_251 happy_x_1 + = case happyOut96 happy_x_1 of { happy_var_1 -> + happyIn97 ([happy_var_1] )} -happyReduce_245 = happySpecReduce_3 87# happyReduction_245 -happyReduction_245 happy_x_3 +happyReduce_252 = happySpecReduce_3 89# happyReduction_252 +happyReduction_252 happy_x_3 happy_x_2 happy_x_1 - = case happyOut94 happy_x_1 of { happy_var_1 -> - case happyOut95 happy_x_3 of { happy_var_3 -> - happyIn95 + = case happyOut96 happy_x_1 of { happy_var_1 -> + case happyOut97 happy_x_3 of { happy_var_3 -> + happyIn97 (happy_var_1 : happy_var_3 )}} -happyReduce_246 = happySpecReduce_1 88# happyReduction_246 -happyReduction_246 happy_x_1 - = case happyOut97 happy_x_1 of { happy_var_1 -> - happyIn96 +happyReduce_253 = happySpecReduce_1 90# happyReduction_253 +happyReduction_253 happy_x_1 + = case happyOut99 happy_x_1 of { happy_var_1 -> + happyIn98 (happy_var_1 )} -happyReduce_247 = happySpecReduce_0 88# happyReduction_247 -happyReduction_247 = happyIn96 +happyReduce_254 = happySpecReduce_0 90# happyReduction_254 +happyReduction_254 = happyIn98 ([] ) -happyReduce_248 = happySpecReduce_1 89# happyReduction_248 -happyReduction_248 happy_x_1 - = case happyOut87 happy_x_1 of { happy_var_1 -> - happyIn97 +happyReduce_255 = happySpecReduce_1 91# happyReduction_255 +happyReduction_255 happy_x_1 + = case happyOut89 happy_x_1 of { happy_var_1 -> + happyIn99 ([happy_var_1] )} -happyReduce_249 = happySpecReduce_3 89# happyReduction_249 -happyReduction_249 happy_x_3 +happyReduce_256 = happySpecReduce_3 91# happyReduction_256 +happyReduction_256 happy_x_3 happy_x_2 happy_x_1 - = case happyOut87 happy_x_1 of { happy_var_1 -> - case happyOut97 happy_x_3 of { happy_var_3 -> - happyIn97 + = case happyOut89 happy_x_1 of { happy_var_1 -> + case happyOut99 happy_x_3 of { happy_var_3 -> + happyIn99 (happy_var_1 : happy_var_3 )}} -happyReduce_250 = happySpecReduce_2 90# happyReduction_250 -happyReduction_250 happy_x_2 +happyReduce_257 = happySpecReduce_2 92# happyReduction_257 +happyReduction_257 happy_x_2 happy_x_1 - = case happyOut99 happy_x_1 of { happy_var_1 -> - case happyOut98 happy_x_2 of { happy_var_2 -> - happyIn98 + = case happyOut101 happy_x_1 of { happy_var_1 -> + case happyOut100 happy_x_2 of { happy_var_2 -> + happyIn100 (happy_var_1 : happy_var_2 )}} -happyReduce_251 = happySpecReduce_0 90# happyReduction_251 -happyReduction_251 = happyIn98 +happyReduce_258 = happySpecReduce_0 92# happyReduction_258 +happyReduction_258 = happyIn100 ([] ) -happyReduce_252 = happySpecReduce_1 91# happyReduction_252 -happyReduction_252 happy_x_1 - = case happyOut197 happy_x_1 of { happy_var_1 -> - happyIn99 +happyReduce_259 = happySpecReduce_1 93# happyReduction_259 +happyReduction_259 happy_x_1 + = case happyOut199 happy_x_1 of { happy_var_1 -> + happyIn101 (sL (getLoc happy_var_1) (UserTyVar (unLoc happy_var_1) placeHolderKind) )} -happyReduce_253 = happyReduce 5# 91# happyReduction_253 -happyReduction_253 (happy_x_5 `HappyStk` +happyReduce_260 = happyReduce 5# 93# happyReduction_260 +happyReduction_260 (happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut197 happy_x_2 of { happy_var_2 -> - case happyOut104 happy_x_4 of { happy_var_4 -> + case happyOut199 happy_x_2 of { happy_var_2 -> + case happyOut106 happy_x_4 of { happy_var_4 -> case happyOutTok happy_x_5 of { happy_var_5 -> - happyIn99 + happyIn101 (sL (comb2 happy_var_1 happy_var_5) (KindedTyVar (unLoc happy_var_2) (unLoc happy_var_4)) ) `HappyStk` happyRest}}}} -happyReduce_254 = happySpecReduce_0 92# happyReduction_254 -happyReduction_254 = happyIn100 +happyReduce_261 = happySpecReduce_0 94# happyReduction_261 +happyReduction_261 = happyIn102 (noLoc [] ) -happyReduce_255 = happySpecReduce_2 92# happyReduction_255 -happyReduction_255 happy_x_2 +happyReduce_262 = happySpecReduce_2 94# happyReduction_262 +happyReduction_262 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut101 happy_x_2 of { happy_var_2 -> - happyIn100 + case happyOut103 happy_x_2 of { happy_var_2 -> + happyIn102 (sL (comb2 happy_var_1 happy_var_2) (reverse (unLoc happy_var_2)) )}} -happyReduce_256 = happySpecReduce_3 93# happyReduction_256 -happyReduction_256 happy_x_3 +happyReduce_263 = happySpecReduce_3 95# happyReduction_263 +happyReduction_263 happy_x_3 happy_x_2 happy_x_1 - = case happyOut101 happy_x_1 of { happy_var_1 -> - case happyOut102 happy_x_3 of { happy_var_3 -> - happyIn101 + = case happyOut103 happy_x_1 of { happy_var_1 -> + case happyOut104 happy_x_3 of { happy_var_3 -> + happyIn103 (sL (comb2 happy_var_1 happy_var_3) (happy_var_3 : unLoc happy_var_1) )}} -happyReduce_257 = happySpecReduce_1 93# happyReduction_257 -happyReduction_257 happy_x_1 - = case happyOut102 happy_x_1 of { happy_var_1 -> - happyIn101 +happyReduce_264 = happySpecReduce_1 95# happyReduction_264 +happyReduction_264 happy_x_1 + = case happyOut104 happy_x_1 of { happy_var_1 -> + happyIn103 (sL (getLoc happy_var_1) [happy_var_1] )} -happyReduce_258 = happySpecReduce_3 94# happyReduction_258 -happyReduction_258 happy_x_3 +happyReduce_265 = happySpecReduce_3 96# happyReduction_265 +happyReduction_265 happy_x_3 happy_x_2 happy_x_1 - = case happyOut103 happy_x_1 of { happy_var_1 -> + = case happyOut105 happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut103 happy_x_3 of { happy_var_3 -> - happyIn102 + case happyOut105 happy_x_3 of { happy_var_3 -> + happyIn104 (L (comb3 happy_var_1 happy_var_2 happy_var_3) (reverse (unLoc happy_var_1), reverse (unLoc happy_var_3)) )}}} -happyReduce_259 = happySpecReduce_0 95# happyReduction_259 -happyReduction_259 = happyIn103 +happyReduce_266 = happySpecReduce_0 97# happyReduction_266 +happyReduction_266 = happyIn105 (noLoc [] ) -happyReduce_260 = happySpecReduce_2 95# happyReduction_260 -happyReduction_260 happy_x_2 +happyReduce_267 = happySpecReduce_2 97# happyReduction_267 +happyReduction_267 happy_x_2 happy_x_1 - = case happyOut103 happy_x_1 of { happy_var_1 -> - case happyOut197 happy_x_2 of { happy_var_2 -> - happyIn103 + = case happyOut105 happy_x_1 of { happy_var_1 -> + case happyOut199 happy_x_2 of { happy_var_2 -> + happyIn105 (sL (comb2 happy_var_1 happy_var_2) (unLoc happy_var_2 : unLoc happy_var_1) )}} -happyReduce_261 = happySpecReduce_1 96# happyReduction_261 -happyReduction_261 happy_x_1 - = case happyOut105 happy_x_1 of { happy_var_1 -> - happyIn104 +happyReduce_268 = happySpecReduce_1 98# happyReduction_268 +happyReduction_268 happy_x_1 + = case happyOut107 happy_x_1 of { happy_var_1 -> + happyIn106 (happy_var_1 )} -happyReduce_262 = happySpecReduce_3 96# happyReduction_262 -happyReduction_262 happy_x_3 +happyReduce_269 = happySpecReduce_3 98# happyReduction_269 +happyReduction_269 happy_x_3 happy_x_2 happy_x_1 - = case happyOut105 happy_x_1 of { happy_var_1 -> - case happyOut104 happy_x_3 of { happy_var_3 -> - happyIn104 + = case happyOut107 happy_x_1 of { happy_var_1 -> + case happyOut106 happy_x_3 of { happy_var_3 -> + happyIn106 (sL (comb2 happy_var_1 happy_var_3) (mkArrowKind (unLoc happy_var_1) (unLoc happy_var_3)) )}} -happyReduce_263 = happySpecReduce_1 97# happyReduction_263 -happyReduction_263 happy_x_1 +happyReduce_270 = happySpecReduce_1 99# happyReduction_270 +happyReduction_270 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn105 + happyIn107 (sL (getLoc happy_var_1) liftedTypeKind )} -happyReduce_264 = happySpecReduce_1 97# happyReduction_264 -happyReduction_264 happy_x_1 +happyReduce_271 = happySpecReduce_1 99# happyReduction_271 +happyReduction_271 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn105 + happyIn107 (sL (getLoc happy_var_1) unliftedTypeKind )} -happyReduce_265 = happySpecReduce_3 97# happyReduction_265 -happyReduction_265 happy_x_3 +happyReduce_272 = happySpecReduce_3 99# happyReduction_272 +happyReduction_272 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut104 happy_x_2 of { happy_var_2 -> + case happyOut106 happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn105 + happyIn107 (sL (comb2 happy_var_1 happy_var_3) (unLoc happy_var_2) )}}} -happyReduce_266 = happyReduce 4# 98# happyReduction_266 -happyReduction_266 (happy_x_4 `HappyStk` +happyReduce_273 = happyReduce 4# 100# happyReduction_273 +happyReduction_273 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut107 happy_x_3 of { happy_var_3 -> - happyIn106 + case happyOut109 happy_x_3 of { happy_var_3 -> + happyIn108 (L (comb2 happy_var_1 happy_var_3) (unLoc happy_var_3) ) `HappyStk` happyRest}} -happyReduce_267 = happyReduce 4# 98# happyReduction_267 -happyReduction_267 (happy_x_4 `HappyStk` +happyReduce_274 = happyReduce 4# 100# happyReduction_274 +happyReduction_274 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut107 happy_x_3 of { happy_var_3 -> - happyIn106 + case happyOut109 happy_x_3 of { happy_var_3 -> + happyIn108 (L (comb2 happy_var_1 happy_var_3) (unLoc happy_var_3) ) `HappyStk` happyRest}} -happyReduce_268 = happySpecReduce_0 98# happyReduction_268 -happyReduction_268 = happyIn106 +happyReduce_275 = happySpecReduce_0 100# happyReduction_275 +happyReduction_275 = happyIn108 (noLoc [] ) -happyReduce_269 = happySpecReduce_3 99# happyReduction_269 -happyReduction_269 happy_x_3 +happyReduce_276 = happySpecReduce_3 101# happyReduction_276 +happyReduction_276 happy_x_3 happy_x_2 happy_x_1 - = case happyOut108 happy_x_1 of { happy_var_1 -> - case happyOut107 happy_x_3 of { happy_var_3 -> - happyIn107 + = case happyOut110 happy_x_1 of { happy_var_1 -> + case happyOut109 happy_x_3 of { happy_var_3 -> + happyIn109 (L (comb2 (head happy_var_1) happy_var_3) (happy_var_1 ++ unLoc happy_var_3) )}} -happyReduce_270 = happySpecReduce_1 99# happyReduction_270 -happyReduction_270 happy_x_1 - = case happyOut108 happy_x_1 of { happy_var_1 -> - happyIn107 +happyReduce_277 = happySpecReduce_1 101# happyReduction_277 +happyReduction_277 happy_x_1 + = case happyOut110 happy_x_1 of { happy_var_1 -> + happyIn109 (L (getLoc (head happy_var_1)) happy_var_1 )} -happyReduce_271 = happySpecReduce_0 99# happyReduction_271 -happyReduction_271 = happyIn107 +happyReduce_278 = happySpecReduce_0 101# happyReduction_278 +happyReduction_278 = happyIn109 (noLoc [] ) -happyReduce_272 = happySpecReduce_3 100# happyReduction_272 -happyReduction_272 happy_x_3 +happyReduce_279 = happySpecReduce_3 102# happyReduction_279 +happyReduction_279 happy_x_3 happy_x_2 happy_x_1 - = case happyOut180 happy_x_1 of { happy_var_1 -> - case happyOut81 happy_x_3 of { happy_var_3 -> - happyIn108 + = case happyOut182 happy_x_1 of { happy_var_1 -> + case happyOut83 happy_x_3 of { happy_var_3 -> + happyIn110 (map (sL (comb2 happy_var_1 happy_var_3)) (mkGadtDecl (unLoc happy_var_1) happy_var_3) )}} -happyReduce_273 = happyMonadReduce 6# 100# happyReduction_273 -happyReduction_273 (happy_x_6 `HappyStk` +happyReduce_280 = happyMonadReduce 6# 102# happyReduction_280 +happyReduction_280 (happy_x_6 `HappyStk` happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk - = happyThen (case happyOut185 happy_x_1 of { happy_var_1 -> - case happyOut114 happy_x_3 of { happy_var_3 -> - case happyOut81 happy_x_6 of { happy_var_6 -> + = happyThen (case happyOut187 happy_x_1 of { happy_var_1 -> + case happyOut116 happy_x_3 of { happy_var_3 -> + case happyOut83 happy_x_6 of { happy_var_6 -> ( do { cd <- mkDeprecatedGadtRecordDecl (comb2 happy_var_1 happy_var_6) happy_var_1 happy_var_3 happy_var_6 ; return [cd] })}}} - ) (\r -> happyReturn (happyIn108 r)) + ) (\r -> happyReturn (happyIn110 r)) -happyReduce_274 = happySpecReduce_3 101# happyReduction_274 -happyReduction_274 happy_x_3 +happyReduce_281 = happySpecReduce_3 103# happyReduction_281 +happyReduction_281 happy_x_3 happy_x_2 happy_x_1 - = case happyOut226 happy_x_1 of { happy_var_1 -> + = case happyOut228 happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut110 happy_x_3 of { happy_var_3 -> - happyIn109 + case happyOut112 happy_x_3 of { happy_var_3 -> + happyIn111 (L (comb2 happy_var_2 happy_var_3) (addConDocs (unLoc happy_var_3) happy_var_1) )}}} -happyReduce_275 = happyReduce 5# 102# happyReduction_275 -happyReduction_275 (happy_x_5 `HappyStk` +happyReduce_282 = happyReduce 5# 104# happyReduction_282 +happyReduction_282 (happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) - = case happyOut110 happy_x_1 of { happy_var_1 -> - case happyOut226 happy_x_2 of { happy_var_2 -> - case happyOut225 happy_x_4 of { happy_var_4 -> - case happyOut111 happy_x_5 of { happy_var_5 -> - happyIn110 + = case happyOut112 happy_x_1 of { happy_var_1 -> + case happyOut228 happy_x_2 of { happy_var_2 -> + case happyOut227 happy_x_4 of { happy_var_4 -> + case happyOut113 happy_x_5 of { happy_var_5 -> + happyIn112 (sL (comb2 happy_var_1 happy_var_5) (addConDoc happy_var_5 happy_var_2 : addConDocFirst (unLoc happy_var_1) happy_var_4) ) `HappyStk` happyRest}}}} -happyReduce_276 = happySpecReduce_1 102# happyReduction_276 -happyReduction_276 happy_x_1 - = case happyOut111 happy_x_1 of { happy_var_1 -> - happyIn110 +happyReduce_283 = happySpecReduce_1 104# happyReduction_283 +happyReduction_283 happy_x_1 + = case happyOut113 happy_x_1 of { happy_var_1 -> + happyIn112 (sL (getLoc happy_var_1) [happy_var_1] )} -happyReduce_277 = happyReduce 6# 103# happyReduction_277 -happyReduction_277 (happy_x_6 `HappyStk` +happyReduce_284 = happyReduce 6# 105# happyReduction_284 +happyReduction_284 (happy_x_6 `HappyStk` happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) - = case happyOut226 happy_x_1 of { happy_var_1 -> - case happyOut112 happy_x_2 of { happy_var_2 -> - case happyOut89 happy_x_3 of { happy_var_3 -> + = case happyOut228 happy_x_1 of { happy_var_1 -> + case happyOut114 happy_x_2 of { happy_var_2 -> + case happyOut91 happy_x_3 of { happy_var_3 -> case happyOutTok happy_x_4 of { happy_var_4 -> - case happyOut113 happy_x_5 of { happy_var_5 -> - case happyOut225 happy_x_6 of { happy_var_6 -> - happyIn111 + case happyOut115 happy_x_5 of { happy_var_5 -> + case happyOut227 happy_x_6 of { happy_var_6 -> + happyIn113 (let (con,details) = unLoc happy_var_5 in addConDoc (L (comb4 happy_var_2 happy_var_3 happy_var_4 happy_var_5) (mkSimpleConDecl con (unLoc happy_var_2) happy_var_3 details)) (happy_var_1 `mplus` happy_var_6) ) `HappyStk` happyRest}}}}}} -happyReduce_278 = happyReduce 4# 103# happyReduction_278 -happyReduction_278 (happy_x_4 `HappyStk` +happyReduce_285 = happyReduce 4# 105# happyReduction_285 +happyReduction_285 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) - = case happyOut226 happy_x_1 of { happy_var_1 -> - case happyOut112 happy_x_2 of { happy_var_2 -> - case happyOut113 happy_x_3 of { happy_var_3 -> - case happyOut225 happy_x_4 of { happy_var_4 -> - happyIn111 + = case happyOut228 happy_x_1 of { happy_var_1 -> + case happyOut114 happy_x_2 of { happy_var_2 -> + case happyOut115 happy_x_3 of { happy_var_3 -> + case happyOut227 happy_x_4 of { happy_var_4 -> + happyIn113 (let (con,details) = unLoc happy_var_3 in addConDoc (L (comb2 happy_var_2 happy_var_3) (mkSimpleConDecl con (unLoc happy_var_2) (noLoc []) details)) (happy_var_1 `mplus` happy_var_4) ) `HappyStk` happyRest}}}} -happyReduce_279 = happySpecReduce_3 104# happyReduction_279 -happyReduction_279 happy_x_3 +happyReduce_286 = happySpecReduce_3 106# happyReduction_286 +happyReduction_286 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut98 happy_x_2 of { happy_var_2 -> + case happyOut100 happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn112 + happyIn114 (sL (comb2 happy_var_1 happy_var_3) happy_var_2 )}}} -happyReduce_280 = happySpecReduce_0 104# happyReduction_280 -happyReduction_280 = happyIn112 +happyReduce_287 = happySpecReduce_0 106# happyReduction_287 +happyReduction_287 = happyIn114 (noLoc [] ) -happyReduce_281 = happyMonadReduce 1# 105# happyReduction_281 -happyReduction_281 (happy_x_1 `HappyStk` +happyReduce_288 = happyMonadReduce 1# 107# happyReduction_288 +happyReduction_288 (happy_x_1 `HappyStk` happyRest) tk - = happyThen (case happyOut92 happy_x_1 of { happy_var_1 -> + = happyThen (case happyOut94 happy_x_1 of { happy_var_1 -> ( splitCon happy_var_1 >>= return.sL (comb2 happy_var_1 happy_var_1))} - ) (\r -> happyReturn (happyIn113 r)) + ) (\r -> happyReturn (happyIn115 r)) -happyReduce_282 = happySpecReduce_3 105# happyReduction_282 -happyReduction_282 happy_x_3 +happyReduce_289 = happySpecReduce_3 107# happyReduction_289 +happyReduction_289 happy_x_3 happy_x_2 happy_x_1 - = case happyOut92 happy_x_1 of { happy_var_1 -> - case happyOut182 happy_x_2 of { happy_var_2 -> - case happyOut92 happy_x_3 of { happy_var_3 -> - happyIn113 + = case happyOut94 happy_x_1 of { happy_var_1 -> + case happyOut184 happy_x_2 of { happy_var_2 -> + case happyOut94 happy_x_3 of { happy_var_3 -> + happyIn115 (sL (comb2 happy_var_1 happy_var_3) (happy_var_2, InfixCon happy_var_1 happy_var_3) )}}} -happyReduce_283 = happySpecReduce_0 106# happyReduction_283 -happyReduction_283 = happyIn114 +happyReduce_290 = happySpecReduce_0 108# happyReduction_290 +happyReduction_290 = happyIn116 ([] ) -happyReduce_284 = happySpecReduce_1 106# happyReduction_284 -happyReduction_284 happy_x_1 - = case happyOut115 happy_x_1 of { happy_var_1 -> - happyIn114 +happyReduce_291 = happySpecReduce_1 108# happyReduction_291 +happyReduction_291 happy_x_1 + = case happyOut117 happy_x_1 of { happy_var_1 -> + happyIn116 (happy_var_1 )} -happyReduce_285 = happyReduce 5# 107# happyReduction_285 -happyReduction_285 (happy_x_5 `HappyStk` +happyReduce_292 = happyReduce 5# 109# happyReduction_292 +happyReduction_292 (happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) - = case happyOut116 happy_x_1 of { happy_var_1 -> - case happyOut226 happy_x_2 of { happy_var_2 -> - case happyOut225 happy_x_4 of { happy_var_4 -> - case happyOut115 happy_x_5 of { happy_var_5 -> - happyIn115 + = case happyOut118 happy_x_1 of { happy_var_1 -> + case happyOut228 happy_x_2 of { happy_var_2 -> + case happyOut227 happy_x_4 of { happy_var_4 -> + case happyOut117 happy_x_5 of { happy_var_5 -> + happyIn117 ([ addFieldDoc f happy_var_4 | f <- happy_var_1 ] ++ addFieldDocs happy_var_5 happy_var_2 ) `HappyStk` happyRest}}}} -happyReduce_286 = happySpecReduce_1 107# happyReduction_286 -happyReduction_286 happy_x_1 - = case happyOut116 happy_x_1 of { happy_var_1 -> - happyIn115 +happyReduce_293 = happySpecReduce_1 109# happyReduction_293 +happyReduction_293 happy_x_1 + = case happyOut118 happy_x_1 of { happy_var_1 -> + happyIn117 (happy_var_1 )} -happyReduce_287 = happyReduce 5# 108# happyReduction_287 -happyReduction_287 (happy_x_5 `HappyStk` +happyReduce_294 = happyReduce 5# 110# happyReduction_294 +happyReduction_294 (happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) - = case happyOut226 happy_x_1 of { happy_var_1 -> - case happyOut83 happy_x_2 of { happy_var_2 -> - case happyOut87 happy_x_4 of { happy_var_4 -> - case happyOut225 happy_x_5 of { happy_var_5 -> - happyIn116 + = case happyOut228 happy_x_1 of { happy_var_1 -> + case happyOut85 happy_x_2 of { happy_var_2 -> + case happyOut89 happy_x_4 of { happy_var_4 -> + case happyOut227 happy_x_5 of { happy_var_5 -> + happyIn118 ([ ConDeclField fld happy_var_4 (happy_var_1 `mplus` happy_var_5) | fld <- reverse (unLoc happy_var_2) ] ) `HappyStk` happyRest}}}} -happyReduce_288 = happySpecReduce_0 109# happyReduction_288 -happyReduction_288 = happyIn117 +happyReduce_295 = happySpecReduce_0 111# happyReduction_295 +happyReduction_295 = happyIn119 (noLoc Nothing ) -happyReduce_289 = happyMonadReduce 2# 109# happyReduction_289 -happyReduction_289 (happy_x_2 `HappyStk` +happyReduce_296 = happyMonadReduce 2# 111# happyReduction_296 +happyReduction_296 (happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut187 happy_x_2 of { happy_var_2 -> + case happyOut189 happy_x_2 of { happy_var_2 -> ( do { let { L loc tv = happy_var_2 } ; p <- checkInstType (L loc (HsTyVar tv)) ; return (sL (comb2 happy_var_1 happy_var_2) (Just [p])) })}} - ) (\r -> happyReturn (happyIn117 r)) + ) (\r -> happyReturn (happyIn119 r)) -happyReduce_290 = happySpecReduce_3 109# happyReduction_290 -happyReduction_290 happy_x_3 +happyReduce_297 = happySpecReduce_3 111# happyReduction_297 +happyReduction_297 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn117 + happyIn119 (sL (comb2 happy_var_1 happy_var_3) (Just []) )}} -happyReduce_291 = happyReduce 4# 109# happyReduction_291 -happyReduction_291 (happy_x_4 `HappyStk` +happyReduce_298 = happyReduce 4# 111# happyReduction_298 +happyReduction_298 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut95 happy_x_3 of { happy_var_3 -> + case happyOut97 happy_x_3 of { happy_var_3 -> case happyOutTok happy_x_4 of { happy_var_4 -> - happyIn117 + happyIn119 (sL (comb2 happy_var_1 happy_var_4) (Just happy_var_3) ) `HappyStk` happyRest}}} -happyReduce_292 = happySpecReduce_1 110# happyReduction_292 -happyReduction_292 happy_x_1 - = case happyOut119 happy_x_1 of { happy_var_1 -> - happyIn118 +happyReduce_299 = happySpecReduce_1 112# happyReduction_299 +happyReduction_299 happy_x_1 + = case happyOut121 happy_x_1 of { happy_var_1 -> + happyIn120 (sL (getLoc happy_var_1) (DocD (unLoc happy_var_1)) )} -happyReduce_293 = happySpecReduce_1 111# happyReduction_293 -happyReduction_293 happy_x_1 - = case happyOut220 happy_x_1 of { happy_var_1 -> - happyIn119 +happyReduce_300 = happySpecReduce_1 113# happyReduction_300 +happyReduction_300 happy_x_1 + = case happyOut222 happy_x_1 of { happy_var_1 -> + happyIn121 (sL (getLoc happy_var_1) (DocCommentNext (unLoc happy_var_1)) )} -happyReduce_294 = happySpecReduce_1 111# happyReduction_294 -happyReduction_294 happy_x_1 - = case happyOut221 happy_x_1 of { happy_var_1 -> - happyIn119 +happyReduce_301 = happySpecReduce_1 113# happyReduction_301 +happyReduction_301 happy_x_1 + = case happyOut223 happy_x_1 of { happy_var_1 -> + happyIn121 (sL (getLoc happy_var_1) (DocCommentPrev (unLoc happy_var_1)) )} -happyReduce_295 = happySpecReduce_1 111# happyReduction_295 -happyReduction_295 happy_x_1 - = case happyOut222 happy_x_1 of { happy_var_1 -> - happyIn119 +happyReduce_302 = happySpecReduce_1 113# happyReduction_302 +happyReduction_302 happy_x_1 + = case happyOut224 happy_x_1 of { happy_var_1 -> + happyIn121 (sL (getLoc happy_var_1) (case (unLoc happy_var_1) of (n, doc) -> DocCommentNamed n doc) )} -happyReduce_296 = happySpecReduce_1 111# happyReduction_296 -happyReduction_296 happy_x_1 - = case happyOut223 happy_x_1 of { happy_var_1 -> - happyIn119 +happyReduce_303 = happySpecReduce_1 113# happyReduction_303 +happyReduction_303 happy_x_1 + = case happyOut225 happy_x_1 of { happy_var_1 -> + happyIn121 (sL (getLoc happy_var_1) (case (unLoc happy_var_1) of (n, doc) -> DocGroup n doc) )} -happyReduce_297 = happySpecReduce_1 112# happyReduction_297 -happyReduction_297 happy_x_1 - = case happyOut124 happy_x_1 of { happy_var_1 -> - happyIn120 +happyReduce_304 = happySpecReduce_1 114# happyReduction_304 +happyReduction_304 happy_x_1 + = case happyOut126 happy_x_1 of { happy_var_1 -> + happyIn122 (happy_var_1 )} -happyReduce_298 = happyMonadReduce 3# 112# happyReduction_298 -happyReduction_298 (happy_x_3 `HappyStk` +happyReduce_305 = happyMonadReduce 3# 114# happyReduction_305 +happyReduction_305 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut133 happy_x_2 of { happy_var_2 -> - case happyOut121 happy_x_3 of { happy_var_3 -> - ( do { pat <- checkPattern happy_var_2; - return (sL (comb2 happy_var_1 happy_var_3) $ unitOL $ sL (comb2 happy_var_1 happy_var_3) $ ValD ( - PatBind (sL (comb2 happy_var_1 happy_var_3) $ BangPat pat) (unLoc happy_var_3) - placeHolderType placeHolderNames)) })}}} - ) (\r -> happyReturn (happyIn120 r)) - -happyReduce_299 = happyMonadReduce 3# 112# happyReduction_299 -happyReduction_299 (happy_x_3 `HappyStk` + case happyOut135 happy_x_2 of { happy_var_2 -> + case happyOut123 happy_x_3 of { happy_var_3 -> + ( do { let { e = sL (comb2 happy_var_1 happy_var_3) (SectionR (sL (comb2 happy_var_1 happy_var_3) (HsVar bang_RDR)) happy_var_2) }; + pat <- checkPattern e; + return $ sL (comb2 happy_var_1 happy_var_3) $ unitOL $ sL (comb2 happy_var_1 happy_var_3) $ ValD $ + PatBind pat (unLoc happy_var_3) + placeHolderType placeHolderNames })}}} + ) (\r -> happyReturn (happyIn122 r)) + +happyReduce_306 = happyMonadReduce 3# 114# happyReduction_306 +happyReduction_306 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk - = happyThen (case happyOut127 happy_x_1 of { happy_var_1 -> - case happyOut79 happy_x_2 of { happy_var_2 -> - case happyOut121 happy_x_3 of { happy_var_3 -> + = happyThen (case happyOut129 happy_x_1 of { happy_var_1 -> + case happyOut81 happy_x_2 of { happy_var_2 -> + case happyOut123 happy_x_3 of { happy_var_3 -> ( do { r <- checkValDef happy_var_1 happy_var_2 happy_var_3; - let { l = comb2 happy_var_1 happy_var_3 }; - return $! (sL l (unitOL $! (sL l $ ValD r))) })}}} - ) (\r -> happyReturn (happyIn120 r)) + let { l = comb2 happy_var_1 happy_var_3 }; + return $! (sL l (unitOL $! (sL l $ ValD r))) })}}} + ) (\r -> happyReturn (happyIn122 r)) -happyReduce_300 = happySpecReduce_1 112# happyReduction_300 -happyReduction_300 happy_x_1 - = case happyOut118 happy_x_1 of { happy_var_1 -> - happyIn120 +happyReduce_307 = happySpecReduce_1 114# happyReduction_307 +happyReduction_307 happy_x_1 + = case happyOut120 happy_x_1 of { happy_var_1 -> + happyIn122 (sL (comb2 happy_var_1 happy_var_1) $ unitOL happy_var_1 )} -happyReduce_301 = happySpecReduce_3 113# happyReduction_301 -happyReduction_301 happy_x_3 +happyReduce_308 = happySpecReduce_3 115# happyReduction_308 +happyReduction_308 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut126 happy_x_2 of { happy_var_2 -> - case happyOut60 happy_x_3 of { happy_var_3 -> - happyIn121 + case happyOut128 happy_x_2 of { happy_var_2 -> + case happyOut62 happy_x_3 of { happy_var_3 -> + happyIn123 (sL (comb3 happy_var_1 happy_var_2 happy_var_3) $ GRHSs (unguardedRHS happy_var_2) (unLoc happy_var_3) )}}} -happyReduce_302 = happySpecReduce_2 113# happyReduction_302 -happyReduction_302 happy_x_2 +happyReduce_309 = happySpecReduce_2 115# happyReduction_309 +happyReduction_309 happy_x_2 happy_x_1 - = case happyOut122 happy_x_1 of { happy_var_1 -> - case happyOut60 happy_x_2 of { happy_var_2 -> - happyIn121 + = case happyOut124 happy_x_1 of { happy_var_1 -> + case happyOut62 happy_x_2 of { happy_var_2 -> + happyIn123 (sL (comb2 happy_var_1 happy_var_2) $ GRHSs (reverse (unLoc happy_var_1)) (unLoc happy_var_2) )}} -happyReduce_303 = happySpecReduce_2 114# happyReduction_303 -happyReduction_303 happy_x_2 +happyReduce_310 = happySpecReduce_2 116# happyReduction_310 +happyReduction_310 happy_x_2 happy_x_1 - = case happyOut122 happy_x_1 of { happy_var_1 -> - case happyOut123 happy_x_2 of { happy_var_2 -> - happyIn122 + = case happyOut124 happy_x_1 of { happy_var_1 -> + case happyOut125 happy_x_2 of { happy_var_2 -> + happyIn124 (sL (comb2 happy_var_1 happy_var_2) (happy_var_2 : unLoc happy_var_1) )}} -happyReduce_304 = happySpecReduce_1 114# happyReduction_304 -happyReduction_304 happy_x_1 - = case happyOut123 happy_x_1 of { happy_var_1 -> - happyIn122 +happyReduce_311 = happySpecReduce_1 116# happyReduction_311 +happyReduction_311 happy_x_1 + = case happyOut125 happy_x_1 of { happy_var_1 -> + happyIn124 (sL (getLoc happy_var_1) [happy_var_1] )} -happyReduce_305 = happyReduce 4# 115# happyReduction_305 -happyReduction_305 (happy_x_4 `HappyStk` +happyReduce_312 = happyReduce 4# 117# happyReduction_312 +happyReduction_312 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut151 happy_x_2 of { happy_var_2 -> - case happyOut126 happy_x_4 of { happy_var_4 -> - happyIn123 + case happyOut153 happy_x_2 of { happy_var_2 -> + case happyOut128 happy_x_4 of { happy_var_4 -> + happyIn125 (sL (comb2 happy_var_1 happy_var_4) $ GRHS (unLoc happy_var_2) happy_var_4 ) `HappyStk` happyRest}}} -happyReduce_306 = happyMonadReduce 3# 116# happyReduction_306 -happyReduction_306 (happy_x_3 `HappyStk` +happyReduce_313 = happyMonadReduce 3# 118# happyReduction_313 +happyReduction_313 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk - = happyThen (case happyOut127 happy_x_1 of { happy_var_1 -> - case happyOut82 happy_x_3 of { happy_var_3 -> + = happyThen (case happyOut129 happy_x_1 of { happy_var_1 -> + case happyOut84 happy_x_3 of { happy_var_3 -> ( do s <- checkValSig happy_var_1 happy_var_3 - ; return (sL (comb2 happy_var_1 happy_var_3) $ unitOL (sL (comb2 happy_var_1 happy_var_3) $ SigD s)))}} - ) (\r -> happyReturn (happyIn124 r)) + ; return (sL (comb2 happy_var_1 happy_var_3) $ unitOL (sL (comb2 happy_var_1 happy_var_3) $ SigD s)))}} + ) (\r -> happyReturn (happyIn126 r)) -happyReduce_307 = happyReduce 5# 116# happyReduction_307 -happyReduction_307 (happy_x_5 `HappyStk` +happyReduce_314 = happyReduce 5# 118# happyReduction_314 +happyReduction_314 (happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) - = case happyOut201 happy_x_1 of { happy_var_1 -> - case happyOut83 happy_x_3 of { happy_var_3 -> - case happyOut82 happy_x_5 of { happy_var_5 -> - happyIn124 - (sL (comb2 happy_var_1 happy_var_5) $ toOL [ sL (comb2 happy_var_1 happy_var_5) $ SigD (TypeSig n happy_var_5) | n <- happy_var_1 : unLoc happy_var_3 ] + = case happyOut203 happy_x_1 of { happy_var_1 -> + case happyOut85 happy_x_3 of { happy_var_3 -> + case happyOut84 happy_x_5 of { happy_var_5 -> + happyIn126 + (sL (comb2 happy_var_1 happy_var_5) $ toOL [ sL (comb2 happy_var_1 happy_var_5) $ SigD (TypeSig (happy_var_1 : unLoc happy_var_3) happy_var_5) ] ) `HappyStk` happyRest}}} -happyReduce_308 = happySpecReduce_3 116# happyReduction_308 -happyReduction_308 happy_x_3 +happyReduce_315 = happySpecReduce_3 118# happyReduction_315 +happyReduction_315 happy_x_3 happy_x_2 happy_x_1 - = case happyOut37 happy_x_1 of { happy_var_1 -> - case happyOut36 happy_x_2 of { happy_var_2 -> - case happyOut38 happy_x_3 of { happy_var_3 -> - happyIn124 + = case happyOut39 happy_x_1 of { happy_var_1 -> + case happyOut38 happy_x_2 of { happy_var_2 -> + case happyOut40 happy_x_3 of { happy_var_3 -> + happyIn126 (sL (comb2 happy_var_1 happy_var_3) $ toOL [ sL (comb2 happy_var_1 happy_var_3) $ SigD (FixSig (FixitySig n (Fixity happy_var_2 (unLoc happy_var_1)))) | n <- unLoc happy_var_3 ] )}}} -happyReduce_309 = happyReduce 4# 116# happyReduction_309 -happyReduction_309 (happy_x_4 `HappyStk` +happyReduce_316 = happyReduce 4# 118# happyReduction_316 +happyReduction_316 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut63 happy_x_2 of { happy_var_2 -> - case happyOut202 happy_x_3 of { happy_var_3 -> + case happyOut65 happy_x_2 of { happy_var_2 -> + case happyOut204 happy_x_3 of { happy_var_3 -> case happyOutTok happy_x_4 of { happy_var_4 -> - happyIn124 + happyIn126 (sL (comb2 happy_var_1 happy_var_4) $ unitOL (sL (comb2 happy_var_1 happy_var_4) $ SigD (InlineSig happy_var_3 (mkInlinePragma (getINLINE happy_var_1) happy_var_2))) ) `HappyStk` happyRest}}}} -happyReduce_310 = happyReduce 5# 116# happyReduction_310 -happyReduction_310 (happy_x_5 `HappyStk` +happyReduce_317 = happyReduce 5# 118# happyReduction_317 +happyReduction_317 (happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut202 happy_x_2 of { happy_var_2 -> - case happyOut84 happy_x_4 of { happy_var_4 -> + case happyOut204 happy_x_2 of { happy_var_2 -> + case happyOut86 happy_x_4 of { happy_var_4 -> case happyOutTok happy_x_5 of { happy_var_5 -> - happyIn124 + happyIn126 (sL (comb2 happy_var_1 happy_var_5) $ toOL [ sL (comb2 happy_var_1 happy_var_5) $ SigD (SpecSig happy_var_2 t defaultInlinePragma) | t <- happy_var_4] ) `HappyStk` happyRest}}}} -happyReduce_311 = happyReduce 6# 116# happyReduction_311 -happyReduction_311 (happy_x_6 `HappyStk` +happyReduce_318 = happyReduce 6# 118# happyReduction_318 +happyReduction_318 (happy_x_6 `HappyStk` happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` @@ -4819,115 +4901,115 @@ happy_x_1 `HappyStk` happyRest) = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut63 happy_x_2 of { happy_var_2 -> - case happyOut202 happy_x_3 of { happy_var_3 -> - case happyOut84 happy_x_5 of { happy_var_5 -> + case happyOut65 happy_x_2 of { happy_var_2 -> + case happyOut204 happy_x_3 of { happy_var_3 -> + case happyOut86 happy_x_5 of { happy_var_5 -> case happyOutTok happy_x_6 of { happy_var_6 -> - happyIn124 + happyIn126 (sL (comb2 happy_var_1 happy_var_6) $ toOL [ sL (comb2 happy_var_1 happy_var_6) $ SigD (SpecSig happy_var_3 t (mkInlinePragma (getSPEC_INLINE happy_var_1) happy_var_2)) | t <- happy_var_5] ) `HappyStk` happyRest}}}}} -happyReduce_312 = happyReduce 4# 116# happyReduction_312 -happyReduction_312 (happy_x_4 `HappyStk` +happyReduce_319 = happyReduce 4# 118# happyReduction_319 +happyReduction_319 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut94 happy_x_3 of { happy_var_3 -> + case happyOut96 happy_x_3 of { happy_var_3 -> case happyOutTok happy_x_4 of { happy_var_4 -> - happyIn124 + happyIn126 (sL (comb2 happy_var_1 happy_var_4) $ unitOL (sL (comb2 happy_var_1 happy_var_4) $ SigD (SpecInstSig happy_var_3)) ) `HappyStk` happyRest}}} -happyReduce_313 = happySpecReduce_1 117# happyReduction_313 -happyReduction_313 happy_x_1 +happyReduce_320 = happySpecReduce_1 119# happyReduction_320 +happyReduction_320 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn125 + happyIn127 (let { loc = getLoc happy_var_1 ; ITquasiQuote (quoter, quote, quoteSpan) = unLoc happy_var_1 ; quoterId = mkUnqual varName quoter } - in sL (getLoc happy_var_1) (mkHsQuasiQuote quoterId quoteSpan quote) + in sL (getLoc happy_var_1) (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) )} -happyReduce_314 = happySpecReduce_3 118# happyReduction_314 -happyReduction_314 happy_x_3 +happyReduce_321 = happySpecReduce_3 120# happyReduction_321 +happyReduction_321 happy_x_3 happy_x_2 happy_x_1 - = case happyOut127 happy_x_1 of { happy_var_1 -> - case happyOut81 happy_x_3 of { happy_var_3 -> - happyIn126 + = case happyOut129 happy_x_1 of { happy_var_1 -> + case happyOut83 happy_x_3 of { happy_var_3 -> + happyIn128 (sL (comb2 happy_var_1 happy_var_3) $ ExprWithTySig happy_var_1 happy_var_3 )}} -happyReduce_315 = happySpecReduce_3 118# happyReduction_315 -happyReduction_315 happy_x_3 +happyReduce_322 = happySpecReduce_3 120# happyReduction_322 +happyReduction_322 happy_x_3 happy_x_2 happy_x_1 - = case happyOut127 happy_x_1 of { happy_var_1 -> - case happyOut126 happy_x_3 of { happy_var_3 -> - happyIn126 + = case happyOut129 happy_x_1 of { happy_var_1 -> + case happyOut128 happy_x_3 of { happy_var_3 -> + happyIn128 (sL (comb2 happy_var_1 happy_var_3) $ HsArrApp happy_var_1 happy_var_3 placeHolderType HsFirstOrderApp True )}} -happyReduce_316 = happySpecReduce_3 118# happyReduction_316 -happyReduction_316 happy_x_3 +happyReduce_323 = happySpecReduce_3 120# happyReduction_323 +happyReduction_323 happy_x_3 happy_x_2 happy_x_1 - = case happyOut127 happy_x_1 of { happy_var_1 -> - case happyOut126 happy_x_3 of { happy_var_3 -> - happyIn126 + = case happyOut129 happy_x_1 of { happy_var_1 -> + case happyOut128 happy_x_3 of { happy_var_3 -> + happyIn128 (sL (comb2 happy_var_1 happy_var_3) $ HsArrApp happy_var_3 happy_var_1 placeHolderType HsFirstOrderApp False )}} -happyReduce_317 = happySpecReduce_3 118# happyReduction_317 -happyReduction_317 happy_x_3 +happyReduce_324 = happySpecReduce_3 120# happyReduction_324 +happyReduction_324 happy_x_3 happy_x_2 happy_x_1 - = case happyOut127 happy_x_1 of { happy_var_1 -> - case happyOut126 happy_x_3 of { happy_var_3 -> - happyIn126 + = case happyOut129 happy_x_1 of { happy_var_1 -> + case happyOut128 happy_x_3 of { happy_var_3 -> + happyIn128 (sL (comb2 happy_var_1 happy_var_3) $ HsArrApp happy_var_1 happy_var_3 placeHolderType HsHigherOrderApp True )}} -happyReduce_318 = happySpecReduce_3 118# happyReduction_318 -happyReduction_318 happy_x_3 +happyReduce_325 = happySpecReduce_3 120# happyReduction_325 +happyReduction_325 happy_x_3 happy_x_2 happy_x_1 - = case happyOut127 happy_x_1 of { happy_var_1 -> - case happyOut126 happy_x_3 of { happy_var_3 -> - happyIn126 + = case happyOut129 happy_x_1 of { happy_var_1 -> + case happyOut128 happy_x_3 of { happy_var_3 -> + happyIn128 (sL (comb2 happy_var_1 happy_var_3) $ HsArrApp happy_var_3 happy_var_1 placeHolderType HsHigherOrderApp False )}} -happyReduce_319 = happySpecReduce_1 118# happyReduction_319 -happyReduction_319 happy_x_1 - = case happyOut127 happy_x_1 of { happy_var_1 -> - happyIn126 +happyReduce_326 = happySpecReduce_1 120# happyReduction_326 +happyReduction_326 happy_x_1 + = case happyOut129 happy_x_1 of { happy_var_1 -> + happyIn128 (happy_var_1 )} -happyReduce_320 = happySpecReduce_1 119# happyReduction_320 -happyReduction_320 happy_x_1 - = case happyOut128 happy_x_1 of { happy_var_1 -> - happyIn127 +happyReduce_327 = happySpecReduce_1 121# happyReduction_327 +happyReduction_327 happy_x_1 + = case happyOut130 happy_x_1 of { happy_var_1 -> + happyIn129 (happy_var_1 )} -happyReduce_321 = happySpecReduce_3 119# happyReduction_321 -happyReduction_321 happy_x_3 +happyReduce_328 = happySpecReduce_3 121# happyReduction_328 +happyReduction_328 happy_x_3 happy_x_2 happy_x_1 - = case happyOut127 happy_x_1 of { happy_var_1 -> - case happyOut193 happy_x_2 of { happy_var_2 -> - case happyOut128 happy_x_3 of { happy_var_3 -> - happyIn127 + = case happyOut129 happy_x_1 of { happy_var_1 -> + case happyOut195 happy_x_2 of { happy_var_2 -> + case happyOut130 happy_x_3 of { happy_var_3 -> + happyIn129 (sL (comb2 happy_var_1 happy_var_3) (OpApp happy_var_1 happy_var_2 (panic "fixity") happy_var_3) )}}} -happyReduce_322 = happyReduce 6# 120# happyReduction_322 -happyReduction_322 (happy_x_6 `HappyStk` +happyReduce_329 = happyReduce 6# 122# happyReduction_329 +happyReduction_329 (happy_x_6 `HappyStk` happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` @@ -4935,31 +5017,31 @@ happy_x_1 `HappyStk` happyRest) = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut162 happy_x_2 of { happy_var_2 -> - case happyOut163 happy_x_3 of { happy_var_3 -> - case happyOut80 happy_x_4 of { happy_var_4 -> - case happyOut126 happy_x_6 of { happy_var_6 -> - happyIn128 + case happyOut164 happy_x_2 of { happy_var_2 -> + case happyOut165 happy_x_3 of { happy_var_3 -> + case happyOut82 happy_x_4 of { happy_var_4 -> + case happyOut128 happy_x_6 of { happy_var_6 -> + happyIn130 (sL (comb2 happy_var_1 happy_var_6) $ HsLam (mkMatchGroup [sL (comb2 happy_var_1 happy_var_6) $ Match (happy_var_2:happy_var_3) happy_var_4 (unguardedGRHSs happy_var_6) ]) ) `HappyStk` happyRest}}}}} -happyReduce_323 = happyReduce 4# 120# happyReduction_323 -happyReduction_323 (happy_x_4 `HappyStk` +happyReduce_330 = happyReduce 4# 122# happyReduction_330 +happyReduction_330 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut59 happy_x_2 of { happy_var_2 -> - case happyOut126 happy_x_4 of { happy_var_4 -> - happyIn128 + case happyOut61 happy_x_2 of { happy_var_2 -> + case happyOut128 happy_x_4 of { happy_var_4 -> + happyIn130 (sL (comb2 happy_var_1 happy_var_4) $ HsLet (unLoc happy_var_2) happy_var_4 ) `HappyStk` happyRest}}} -happyReduce_324 = happyMonadReduce 8# 120# happyReduction_324 -happyReduction_324 (happy_x_8 `HappyStk` +happyReduce_331 = happyMonadReduce 8# 122# happyReduction_331 +happyReduction_331 (happy_x_8 `HappyStk` happy_x_7 `HappyStk` happy_x_6 `HappyStk` happy_x_5 `HappyStk` @@ -4969,138 +5051,134 @@ happy_x_1 `HappyStk` happyRest) tk = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut126 happy_x_2 of { happy_var_2 -> - case happyOut129 happy_x_3 of { happy_var_3 -> - case happyOut126 happy_x_5 of { happy_var_5 -> - case happyOut129 happy_x_6 of { happy_var_6 -> - case happyOut126 happy_x_8 of { happy_var_8 -> + case happyOut128 happy_x_2 of { happy_var_2 -> + case happyOut131 happy_x_3 of { happy_var_3 -> + case happyOut128 happy_x_5 of { happy_var_5 -> + case happyOut131 happy_x_6 of { happy_var_6 -> + case happyOut128 happy_x_8 of { happy_var_8 -> ( checkDoAndIfThenElse happy_var_2 happy_var_3 happy_var_5 happy_var_6 happy_var_8 >> return (sL (comb2 happy_var_1 happy_var_8) $ mkHsIf happy_var_2 happy_var_5 happy_var_8))}}}}}} - ) (\r -> happyReturn (happyIn128 r)) + ) (\r -> happyReturn (happyIn130 r)) -happyReduce_325 = happyReduce 4# 120# happyReduction_325 -happyReduction_325 (happy_x_4 `HappyStk` +happyReduce_332 = happyReduce 4# 122# happyReduction_332 +happyReduction_332 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut126 happy_x_2 of { happy_var_2 -> - case happyOut153 happy_x_4 of { happy_var_4 -> - happyIn128 + case happyOut128 happy_x_2 of { happy_var_2 -> + case happyOut155 happy_x_4 of { happy_var_4 -> + happyIn130 (sL (comb2 happy_var_1 happy_var_4) $ HsCase happy_var_2 (mkMatchGroup (unLoc happy_var_4)) ) `HappyStk` happyRest}}} -happyReduce_326 = happySpecReduce_2 120# happyReduction_326 -happyReduction_326 happy_x_2 +happyReduce_333 = happySpecReduce_2 122# happyReduction_333 +happyReduction_333 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut132 happy_x_2 of { happy_var_2 -> - happyIn128 + case happyOut134 happy_x_2 of { happy_var_2 -> + happyIn130 (sL (comb2 happy_var_1 happy_var_2) $ NegApp happy_var_2 noSyntaxExpr )}} -happyReduce_327 = happyMonadReduce 2# 120# happyReduction_327 -happyReduction_327 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut164 happy_x_2 of { happy_var_2 -> - ( let loc = comb2 happy_var_1 happy_var_2 in - checkDo loc (unLoc happy_var_2) >>= \ (stmts,body) -> - return (L loc (mkHsDo DoExpr stmts body)))}} - ) (\r -> happyReturn (happyIn128 r)) +happyReduce_334 = happySpecReduce_2 122# happyReduction_334 +happyReduction_334 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut166 happy_x_2 of { happy_var_2 -> + happyIn130 + (L (comb2 happy_var_1 happy_var_2) (mkHsDo DoExpr (unLoc happy_var_2)) + )}} -happyReduce_328 = happyMonadReduce 2# 120# happyReduction_328 -happyReduction_328 (happy_x_2 `HappyStk` - happy_x_1 `HappyStk` - happyRest) tk - = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut164 happy_x_2 of { happy_var_2 -> - ( let loc = comb2 happy_var_1 happy_var_2 in - checkDo loc (unLoc happy_var_2) >>= \ (stmts,body) -> - return (L loc (mkHsDo (MDoExpr noPostTcTable) stmts body)))}} - ) (\r -> happyReturn (happyIn128 r)) +happyReduce_335 = happySpecReduce_2 122# happyReduction_335 +happyReduction_335 happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { happy_var_1 -> + case happyOut166 happy_x_2 of { happy_var_2 -> + happyIn130 + (L (comb2 happy_var_1 happy_var_2) (mkHsDo MDoExpr (unLoc happy_var_2)) + )}} -happyReduce_329 = happySpecReduce_2 120# happyReduction_329 -happyReduction_329 happy_x_2 +happyReduce_336 = happySpecReduce_2 122# happyReduction_336 +happyReduction_336 happy_x_2 happy_x_1 - = case happyOut130 happy_x_1 of { happy_var_1 -> - case happyOut126 happy_x_2 of { happy_var_2 -> - happyIn128 + = case happyOut132 happy_x_1 of { happy_var_1 -> + case happyOut128 happy_x_2 of { happy_var_2 -> + happyIn130 (sL (comb2 happy_var_1 happy_var_2) $ if opt_SccProfilingOn then HsSCC (unLoc happy_var_1) happy_var_2 else HsPar happy_var_2 )}} -happyReduce_330 = happySpecReduce_2 120# happyReduction_330 -happyReduction_330 happy_x_2 +happyReduce_337 = happySpecReduce_2 122# happyReduction_337 +happyReduction_337 happy_x_2 happy_x_1 - = case happyOut131 happy_x_1 of { happy_var_1 -> - case happyOut126 happy_x_2 of { happy_var_2 -> - happyIn128 + = case happyOut133 happy_x_1 of { happy_var_1 -> + case happyOut128 happy_x_2 of { happy_var_2 -> + happyIn130 (sL (comb2 happy_var_1 happy_var_2) $ if opt_Hpc then HsTickPragma (unLoc happy_var_1) happy_var_2 else HsPar happy_var_2 )}} -happyReduce_331 = happyMonadReduce 4# 120# happyReduction_331 -happyReduction_331 (happy_x_4 `HappyStk` +happyReduce_338 = happyMonadReduce 4# 122# happyReduction_338 +happyReduction_338 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut133 happy_x_2 of { happy_var_2 -> - case happyOut126 happy_x_4 of { happy_var_4 -> + case happyOut135 happy_x_2 of { happy_var_2 -> + case happyOut128 happy_x_4 of { happy_var_4 -> ( checkPattern happy_var_2 >>= \ p -> return (sL (comb2 happy_var_1 happy_var_4) $ HsProc p (sL (comb2 happy_var_1 happy_var_4) $ HsCmdTop happy_var_4 [] placeHolderType undefined)))}}} - ) (\r -> happyReturn (happyIn128 r)) + ) (\r -> happyReturn (happyIn130 r)) -happyReduce_332 = happyReduce 4# 120# happyReduction_332 -happyReduction_332 (happy_x_4 `HappyStk` +happyReduce_339 = happyReduce 4# 122# happyReduction_339 +happyReduction_339 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut126 happy_x_4 of { happy_var_4 -> - happyIn128 + case happyOut128 happy_x_4 of { happy_var_4 -> + happyIn130 (sL (comb2 happy_var_1 happy_var_4) $ HsCoreAnn (getSTRING happy_var_2) happy_var_4 ) `HappyStk` happyRest}}} -happyReduce_333 = happySpecReduce_1 120# happyReduction_333 -happyReduction_333 happy_x_1 - = case happyOut132 happy_x_1 of { happy_var_1 -> - happyIn128 +happyReduce_340 = happySpecReduce_1 122# happyReduction_340 +happyReduction_340 happy_x_1 + = case happyOut134 happy_x_1 of { happy_var_1 -> + happyIn130 (happy_var_1 )} -happyReduce_334 = happySpecReduce_1 121# happyReduction_334 -happyReduction_334 happy_x_1 - = happyIn129 +happyReduce_341 = happySpecReduce_1 123# happyReduction_341 +happyReduction_341 happy_x_1 + = happyIn131 (True ) -happyReduce_335 = happySpecReduce_0 121# happyReduction_335 -happyReduction_335 = happyIn129 +happyReduce_342 = happySpecReduce_0 123# happyReduction_342 +happyReduction_342 = happyIn131 (False ) -happyReduce_336 = happyMonadReduce 2# 122# happyReduction_336 -happyReduction_336 (happy_x_2 `HappyStk` +happyReduce_343 = happyMonadReduce 2# 124# happyReduction_343 +happyReduction_343 (happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> ( (addWarning Opt_WarnWarningsDeprecations (getLoc happy_var_1) (text "_scc_ is deprecated; use an SCC pragma instead")) >>= \_ -> ( do scc <- getSCC happy_var_2; return $ sL (comb2 happy_var_1 happy_var_2) scc ))}} - ) (\r -> happyReturn (happyIn130 r)) + ) (\r -> happyReturn (happyIn132 r)) -happyReduce_337 = happyMonadReduce 3# 122# happyReduction_337 -happyReduction_337 (happy_x_3 `HappyStk` +happyReduce_344 = happyMonadReduce 3# 124# happyReduction_344 +happyReduction_344 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk @@ -5108,10 +5186,10 @@ case happyOutTok happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> ( do scc <- getSCC happy_var_2; return $ sL (comb2 happy_var_1 happy_var_3) scc)}}} - ) (\r -> happyReturn (happyIn130 r)) + ) (\r -> happyReturn (happyIn132 r)) -happyReduce_338 = happyReduce 10# 123# happyReduction_338 -happyReduction_338 (happy_x_10 `HappyStk` +happyReduce_345 = happyReduce 10# 125# happyReduction_345 +happyReduction_345 (happy_x_10 `HappyStk` happy_x_9 `HappyStk` happy_x_8 `HappyStk` happy_x_7 `HappyStk` @@ -5129,7 +5207,7 @@ case happyOutTok happy_x_7 of { happy_var_7 -> case happyOutTok happy_x_9 of { happy_var_9 -> case happyOutTok happy_x_10 of { happy_var_10 -> - happyIn131 + happyIn133 (sL (comb2 happy_var_1 happy_var_10) $ (getSTRING happy_var_2 ,( fromInteger $ getINTEGER happy_var_3 , fromInteger $ getINTEGER happy_var_5 @@ -5140,651 +5218,653 @@ ) ) `HappyStk` happyRest}}}}}}} -happyReduce_339 = happySpecReduce_2 124# happyReduction_339 -happyReduction_339 happy_x_2 +happyReduce_346 = happySpecReduce_2 126# happyReduction_346 +happyReduction_346 happy_x_2 happy_x_1 - = case happyOut132 happy_x_1 of { happy_var_1 -> - case happyOut133 happy_x_2 of { happy_var_2 -> - happyIn132 + = case happyOut134 happy_x_1 of { happy_var_1 -> + case happyOut135 happy_x_2 of { happy_var_2 -> + happyIn134 (sL (comb2 happy_var_1 happy_var_2) $ HsApp happy_var_1 happy_var_2 )}} -happyReduce_340 = happySpecReduce_1 124# happyReduction_340 -happyReduction_340 happy_x_1 - = case happyOut133 happy_x_1 of { happy_var_1 -> - happyIn132 +happyReduce_347 = happySpecReduce_1 126# happyReduction_347 +happyReduction_347 happy_x_1 + = case happyOut135 happy_x_1 of { happy_var_1 -> + happyIn134 (happy_var_1 )} -happyReduce_341 = happySpecReduce_3 125# happyReduction_341 -happyReduction_341 happy_x_3 +happyReduce_348 = happySpecReduce_3 127# happyReduction_348 +happyReduction_348 happy_x_3 happy_x_2 happy_x_1 - = case happyOut202 happy_x_1 of { happy_var_1 -> - case happyOut133 happy_x_3 of { happy_var_3 -> - happyIn133 + = case happyOut204 happy_x_1 of { happy_var_1 -> + case happyOut135 happy_x_3 of { happy_var_3 -> + happyIn135 (sL (comb2 happy_var_1 happy_var_3) $ EAsPat happy_var_1 happy_var_3 )}} -happyReduce_342 = happySpecReduce_2 125# happyReduction_342 -happyReduction_342 happy_x_2 +happyReduce_349 = happySpecReduce_2 127# happyReduction_349 +happyReduction_349 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut133 happy_x_2 of { happy_var_2 -> - happyIn133 + case happyOut135 happy_x_2 of { happy_var_2 -> + happyIn135 (sL (comb2 happy_var_1 happy_var_2) $ ELazyPat happy_var_2 )}} -happyReduce_343 = happySpecReduce_1 125# happyReduction_343 -happyReduction_343 happy_x_1 - = case happyOut134 happy_x_1 of { happy_var_1 -> - happyIn133 +happyReduce_350 = happySpecReduce_1 127# happyReduction_350 +happyReduction_350 happy_x_1 + = case happyOut136 happy_x_1 of { happy_var_1 -> + happyIn135 (happy_var_1 )} -happyReduce_344 = happyMonadReduce 4# 126# happyReduction_344 -happyReduction_344 (happy_x_4 `HappyStk` +happyReduce_351 = happyMonadReduce 4# 128# happyReduction_351 +happyReduction_351 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk - = happyThen (case happyOut134 happy_x_1 of { happy_var_1 -> + = happyThen (case happyOut136 happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut170 happy_x_3 of { happy_var_3 -> + case happyOut172 happy_x_3 of { happy_var_3 -> case happyOutTok happy_x_4 of { happy_var_4 -> ( do { r <- mkRecConstrOrUpdate happy_var_1 (comb2 happy_var_2 happy_var_4) happy_var_3 ; return (sL (comb2 happy_var_1 happy_var_4) r) })}}}} - ) (\r -> happyReturn (happyIn134 r)) + ) (\r -> happyReturn (happyIn136 r)) -happyReduce_345 = happySpecReduce_1 126# happyReduction_345 -happyReduction_345 happy_x_1 - = case happyOut135 happy_x_1 of { happy_var_1 -> - happyIn134 +happyReduce_352 = happySpecReduce_1 128# happyReduction_352 +happyReduction_352 happy_x_1 + = case happyOut137 happy_x_1 of { happy_var_1 -> + happyIn136 (happy_var_1 )} -happyReduce_346 = happyReduce 4# 126# happyReduction_346 -happyReduction_346 (happy_x_4 `HappyStk` +happyReduce_353 = happyReduce 4# 128# happyReduction_353 +happyReduction_353 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) - = case happyOut27 happy_x_1 of { happy_var_1 -> - case happyOut90 happy_x_3 of { happy_var_3 -> + = case happyOut28 happy_x_1 of { happy_var_1 -> + case happyOut92 happy_x_3 of { happy_var_3 -> case happyOutTok happy_x_4 of { happy_var_4 -> - happyIn134 + happyIn136 (sL (comb2 happy_var_1 happy_var_4) $ HsApp (sL (getLoc happy_var_1) (HsVar (unLoc happy_var_1))) (sL (getLoc happy_var_3) (HsType happy_var_3)) ) `HappyStk` happyRest}}} -happyReduce_347 = happySpecReduce_1 127# happyReduction_347 -happyReduction_347 happy_x_1 - = case happyOut175 happy_x_1 of { happy_var_1 -> - happyIn135 +happyReduce_354 = happySpecReduce_1 129# happyReduction_354 +happyReduction_354 happy_x_1 + = case happyOut177 happy_x_1 of { happy_var_1 -> + happyIn137 (sL (getLoc happy_var_1) (HsIPVar $! unLoc happy_var_1) )} -happyReduce_348 = happySpecReduce_1 127# happyReduction_348 -happyReduction_348 happy_x_1 - = case happyOut27 happy_x_1 of { happy_var_1 -> - happyIn135 +happyReduce_355 = happySpecReduce_1 129# happyReduction_355 +happyReduction_355 happy_x_1 + = case happyOut28 happy_x_1 of { happy_var_1 -> + happyIn137 (sL (getLoc happy_var_1) (HsVar $! unLoc happy_var_1) )} -happyReduce_349 = happySpecReduce_1 127# happyReduction_349 -happyReduction_349 happy_x_1 - = case happyOut216 happy_x_1 of { happy_var_1 -> - happyIn135 +happyReduce_356 = happySpecReduce_1 129# happyReduction_356 +happyReduction_356 happy_x_1 + = case happyOut218 happy_x_1 of { happy_var_1 -> + happyIn137 (sL (getLoc happy_var_1) (HsLit $! unLoc happy_var_1) )} -happyReduce_350 = happySpecReduce_1 127# happyReduction_350 -happyReduction_350 happy_x_1 +happyReduce_357 = happySpecReduce_1 129# happyReduction_357 +happyReduction_357 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn135 + happyIn137 (sL (getLoc happy_var_1) (HsOverLit $! mkHsIntegral (getINTEGER happy_var_1) placeHolderType) )} -happyReduce_351 = happySpecReduce_1 127# happyReduction_351 -happyReduction_351 happy_x_1 +happyReduce_358 = happySpecReduce_1 129# happyReduction_358 +happyReduction_358 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn135 + happyIn137 (sL (getLoc happy_var_1) (HsOverLit $! mkHsFractional (getRATIONAL happy_var_1) placeHolderType) )} -happyReduce_352 = happySpecReduce_3 127# happyReduction_352 -happyReduction_352 happy_x_3 +happyReduce_359 = happySpecReduce_3 129# happyReduction_359 +happyReduction_359 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut140 happy_x_2 of { happy_var_2 -> + case happyOut142 happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn135 + happyIn137 (sL (comb2 happy_var_1 happy_var_3) (HsPar happy_var_2) )}}} -happyReduce_353 = happySpecReduce_3 127# happyReduction_353 -happyReduction_353 happy_x_3 +happyReduce_360 = happySpecReduce_3 129# happyReduction_360 +happyReduction_360 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut141 happy_x_2 of { happy_var_2 -> + case happyOut143 happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn135 + happyIn137 (sL (comb2 happy_var_1 happy_var_3) (ExplicitTuple happy_var_2 Boxed) )}}} -happyReduce_354 = happySpecReduce_3 127# happyReduction_354 -happyReduction_354 happy_x_3 +happyReduce_361 = happySpecReduce_3 129# happyReduction_361 +happyReduction_361 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut140 happy_x_2 of { happy_var_2 -> + case happyOut142 happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn135 + happyIn137 (sL (comb2 happy_var_1 happy_var_3) (ExplicitTuple [Present happy_var_2] Unboxed) )}}} -happyReduce_355 = happySpecReduce_3 127# happyReduction_355 -happyReduction_355 happy_x_3 +happyReduce_362 = happySpecReduce_3 129# happyReduction_362 +happyReduction_362 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut141 happy_x_2 of { happy_var_2 -> + case happyOut143 happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn135 + happyIn137 (sL (comb2 happy_var_1 happy_var_3) (ExplicitTuple happy_var_2 Unboxed) )}}} -happyReduce_356 = happySpecReduce_3 127# happyReduction_356 -happyReduction_356 happy_x_3 +happyReduce_363 = happySpecReduce_3 129# happyReduction_363 +happyReduction_363 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut144 happy_x_2 of { happy_var_2 -> + case happyOut146 happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn135 + happyIn137 (sL (comb2 happy_var_1 happy_var_3) (unLoc happy_var_2) )}}} -happyReduce_357 = happySpecReduce_3 127# happyReduction_357 -happyReduction_357 happy_x_3 +happyReduce_364 = happySpecReduce_3 129# happyReduction_364 +happyReduction_364 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut150 happy_x_2 of { happy_var_2 -> + case happyOut152 happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn135 + happyIn137 (sL (comb2 happy_var_1 happy_var_3) (unLoc happy_var_2) )}}} -happyReduce_358 = happySpecReduce_1 127# happyReduction_358 -happyReduction_358 happy_x_1 +happyReduce_365 = happySpecReduce_1 129# happyReduction_365 +happyReduction_365 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn135 + happyIn137 (sL (getLoc happy_var_1) EWildPat )} -happyReduce_359 = happySpecReduce_1 127# happyReduction_359 -happyReduction_359 happy_x_1 +happyReduce_366 = happySpecReduce_1 129# happyReduction_366 +happyReduction_366 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn135 + happyIn137 (sL (getLoc happy_var_1) $ HsSpliceE (mkHsSplice (sL (getLoc happy_var_1) $ HsVar (mkUnqual varName (getTH_ID_SPLICE happy_var_1)))) )} -happyReduce_360 = happySpecReduce_3 127# happyReduction_360 -happyReduction_360 happy_x_3 +happyReduce_367 = happySpecReduce_3 129# happyReduction_367 +happyReduction_367 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut126 happy_x_2 of { happy_var_2 -> + case happyOut128 happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn135 + happyIn137 (sL (comb2 happy_var_1 happy_var_3) $ HsSpliceE (mkHsSplice happy_var_2) )}}} -happyReduce_361 = happySpecReduce_2 127# happyReduction_361 -happyReduction_361 happy_x_2 +happyReduce_368 = happySpecReduce_2 129# happyReduction_368 +happyReduction_368 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut202 happy_x_2 of { happy_var_2 -> - happyIn135 + case happyOut204 happy_x_2 of { happy_var_2 -> + happyIn137 (sL (comb2 happy_var_1 happy_var_2) $ HsBracket (VarBr (unLoc happy_var_2)) )}} -happyReduce_362 = happySpecReduce_2 127# happyReduction_362 -happyReduction_362 happy_x_2 +happyReduce_369 = happySpecReduce_2 129# happyReduction_369 +happyReduction_369 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut178 happy_x_2 of { happy_var_2 -> - happyIn135 + case happyOut180 happy_x_2 of { happy_var_2 -> + happyIn137 (sL (comb2 happy_var_1 happy_var_2) $ HsBracket (VarBr (unLoc happy_var_2)) )}} -happyReduce_363 = happySpecReduce_2 127# happyReduction_363 -happyReduction_363 happy_x_2 +happyReduce_370 = happySpecReduce_2 129# happyReduction_370 +happyReduction_370 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut197 happy_x_2 of { happy_var_2 -> - happyIn135 + case happyOut199 happy_x_2 of { happy_var_2 -> + happyIn137 (sL (comb2 happy_var_1 happy_var_2) $ HsBracket (VarBr (unLoc happy_var_2)) )}} -happyReduce_364 = happySpecReduce_2 127# happyReduction_364 -happyReduction_364 happy_x_2 +happyReduce_371 = happySpecReduce_2 129# happyReduction_371 +happyReduction_371 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut184 happy_x_2 of { happy_var_2 -> - happyIn135 + case happyOut186 happy_x_2 of { happy_var_2 -> + happyIn137 (sL (comb2 happy_var_1 happy_var_2) $ HsBracket (VarBr (unLoc happy_var_2)) )}} -happyReduce_365 = happySpecReduce_3 127# happyReduction_365 -happyReduction_365 happy_x_3 +happyReduce_372 = happySpecReduce_3 129# happyReduction_372 +happyReduction_372 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut126 happy_x_2 of { happy_var_2 -> + case happyOut128 happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn135 + happyIn137 (sL (comb2 happy_var_1 happy_var_3) $ HsBracket (ExpBr happy_var_2) )}}} -happyReduce_366 = happySpecReduce_3 127# happyReduction_366 -happyReduction_366 happy_x_3 +happyReduce_373 = happySpecReduce_3 129# happyReduction_373 +happyReduction_373 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut87 happy_x_2 of { happy_var_2 -> + case happyOut89 happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn135 + happyIn137 (sL (comb2 happy_var_1 happy_var_3) $ HsBracket (TypBr happy_var_2) )}}} -happyReduce_367 = happyMonadReduce 3# 127# happyReduction_367 -happyReduction_367 (happy_x_3 `HappyStk` +happyReduce_374 = happyMonadReduce 3# 129# happyReduction_374 +happyReduction_374 (happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut127 happy_x_2 of { happy_var_2 -> + case happyOut129 happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> ( checkPattern happy_var_2 >>= \p -> return (sL (comb2 happy_var_1 happy_var_3) $ HsBracket (PatBr p)))}}} - ) (\r -> happyReturn (happyIn135 r)) + ) (\r -> happyReturn (happyIn137 r)) -happyReduce_368 = happySpecReduce_3 127# happyReduction_368 -happyReduction_368 happy_x_3 +happyReduce_375 = happySpecReduce_3 129# happyReduction_375 +happyReduction_375 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut138 happy_x_2 of { happy_var_2 -> + case happyOut140 happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn135 + happyIn137 (sL (comb2 happy_var_1 happy_var_3) $ HsBracket (DecBrL happy_var_2) )}}} -happyReduce_369 = happySpecReduce_1 127# happyReduction_369 -happyReduction_369 happy_x_1 - = case happyOut125 happy_x_1 of { happy_var_1 -> - happyIn135 +happyReduce_376 = happySpecReduce_1 129# happyReduction_376 +happyReduction_376 happy_x_1 + = case happyOut127 happy_x_1 of { happy_var_1 -> + happyIn137 (sL (getLoc happy_var_1) (HsQuasiQuoteE (unLoc happy_var_1)) )} -happyReduce_370 = happyReduce 4# 127# happyReduction_370 -happyReduction_370 (happy_x_4 `HappyStk` +happyReduce_377 = happyReduce 4# 129# happyReduction_377 +happyReduction_377 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut135 happy_x_2 of { happy_var_2 -> - case happyOut136 happy_x_3 of { happy_var_3 -> + case happyOut137 happy_x_2 of { happy_var_2 -> + case happyOut138 happy_x_3 of { happy_var_3 -> case happyOutTok happy_x_4 of { happy_var_4 -> - happyIn135 + happyIn137 (sL (comb2 happy_var_1 happy_var_4) $ HsArrForm happy_var_2 Nothing (reverse happy_var_3) ) `HappyStk` happyRest}}}} -happyReduce_371 = happySpecReduce_2 128# happyReduction_371 -happyReduction_371 happy_x_2 +happyReduce_378 = happySpecReduce_2 130# happyReduction_378 +happyReduction_378 happy_x_2 happy_x_1 - = case happyOut136 happy_x_1 of { happy_var_1 -> - case happyOut137 happy_x_2 of { happy_var_2 -> - happyIn136 + = case happyOut138 happy_x_1 of { happy_var_1 -> + case happyOut139 happy_x_2 of { happy_var_2 -> + happyIn138 (happy_var_2 : happy_var_1 )}} -happyReduce_372 = happySpecReduce_0 128# happyReduction_372 -happyReduction_372 = happyIn136 +happyReduce_379 = happySpecReduce_0 130# happyReduction_379 +happyReduction_379 = happyIn138 ([] ) -happyReduce_373 = happySpecReduce_1 129# happyReduction_373 -happyReduction_373 happy_x_1 - = case happyOut135 happy_x_1 of { happy_var_1 -> - happyIn137 +happyReduce_380 = happySpecReduce_1 131# happyReduction_380 +happyReduction_380 happy_x_1 + = case happyOut137 happy_x_1 of { happy_var_1 -> + happyIn139 (sL (getLoc happy_var_1) $ HsCmdTop happy_var_1 [] placeHolderType undefined )} -happyReduce_374 = happySpecReduce_3 130# happyReduction_374 -happyReduction_374 happy_x_3 +happyReduce_381 = happySpecReduce_3 132# happyReduction_381 +happyReduction_381 happy_x_3 happy_x_2 happy_x_1 - = case happyOut139 happy_x_2 of { happy_var_2 -> - happyIn138 + = case happyOut141 happy_x_2 of { happy_var_2 -> + happyIn140 (happy_var_2 )} -happyReduce_375 = happySpecReduce_3 130# happyReduction_375 -happyReduction_375 happy_x_3 +happyReduce_382 = happySpecReduce_3 132# happyReduction_382 +happyReduction_382 happy_x_3 happy_x_2 happy_x_1 - = case happyOut139 happy_x_2 of { happy_var_2 -> - happyIn138 + = case happyOut141 happy_x_2 of { happy_var_2 -> + happyIn140 (happy_var_2 )} -happyReduce_376 = happySpecReduce_0 131# happyReduction_376 -happyReduction_376 = happyIn139 +happyReduce_383 = happySpecReduce_0 133# happyReduction_383 +happyReduction_383 = happyIn141 ([] ) -happyReduce_377 = happySpecReduce_1 131# happyReduction_377 -happyReduction_377 happy_x_1 +happyReduce_384 = happySpecReduce_1 133# happyReduction_384 +happyReduction_384 happy_x_1 = case happyOut16 happy_x_1 of { happy_var_1 -> - happyIn139 + happyIn141 (happy_var_1 )} -happyReduce_378 = happySpecReduce_1 132# happyReduction_378 -happyReduction_378 happy_x_1 - = case happyOut126 happy_x_1 of { happy_var_1 -> - happyIn140 +happyReduce_385 = happySpecReduce_1 134# happyReduction_385 +happyReduction_385 happy_x_1 + = case happyOut128 happy_x_1 of { happy_var_1 -> + happyIn142 (happy_var_1 )} -happyReduce_379 = happySpecReduce_2 132# happyReduction_379 -happyReduction_379 happy_x_2 +happyReduce_386 = happySpecReduce_2 134# happyReduction_386 +happyReduction_386 happy_x_2 happy_x_1 - = case happyOut127 happy_x_1 of { happy_var_1 -> - case happyOut193 happy_x_2 of { happy_var_2 -> - happyIn140 + = case happyOut129 happy_x_1 of { happy_var_1 -> + case happyOut195 happy_x_2 of { happy_var_2 -> + happyIn142 (sL (comb2 happy_var_1 happy_var_2) $ SectionL happy_var_1 happy_var_2 )}} -happyReduce_380 = happySpecReduce_2 132# happyReduction_380 -happyReduction_380 happy_x_2 +happyReduce_387 = happySpecReduce_2 134# happyReduction_387 +happyReduction_387 happy_x_2 happy_x_1 - = case happyOut194 happy_x_1 of { happy_var_1 -> - case happyOut127 happy_x_2 of { happy_var_2 -> - happyIn140 + = case happyOut196 happy_x_1 of { happy_var_1 -> + case happyOut129 happy_x_2 of { happy_var_2 -> + happyIn142 (sL (comb2 happy_var_1 happy_var_2) $ SectionR happy_var_1 happy_var_2 )}} -happyReduce_381 = happySpecReduce_3 132# happyReduction_381 -happyReduction_381 happy_x_3 +happyReduce_388 = happySpecReduce_3 134# happyReduction_388 +happyReduction_388 happy_x_3 happy_x_2 happy_x_1 - = case happyOut126 happy_x_1 of { happy_var_1 -> - case happyOut140 happy_x_3 of { happy_var_3 -> - happyIn140 + = case happyOut128 happy_x_1 of { happy_var_1 -> + case happyOut142 happy_x_3 of { happy_var_3 -> + happyIn142 (sL (comb2 happy_var_1 happy_var_3) $ EViewPat happy_var_1 happy_var_3 )}} -happyReduce_382 = happySpecReduce_2 133# happyReduction_382 -happyReduction_382 happy_x_2 +happyReduce_389 = happySpecReduce_2 135# happyReduction_389 +happyReduction_389 happy_x_2 happy_x_1 - = case happyOut140 happy_x_1 of { happy_var_1 -> - case happyOut142 happy_x_2 of { happy_var_2 -> - happyIn141 + = case happyOut142 happy_x_1 of { happy_var_1 -> + case happyOut144 happy_x_2 of { happy_var_2 -> + happyIn143 (Present happy_var_1 : happy_var_2 )}} -happyReduce_383 = happySpecReduce_2 133# happyReduction_383 -happyReduction_383 happy_x_2 +happyReduce_390 = happySpecReduce_2 135# happyReduction_390 +happyReduction_390 happy_x_2 happy_x_1 - = case happyOut219 happy_x_1 of { happy_var_1 -> - case happyOut143 happy_x_2 of { happy_var_2 -> - happyIn141 + = case happyOut221 happy_x_1 of { happy_var_1 -> + case happyOut145 happy_x_2 of { happy_var_2 -> + happyIn143 (replicate happy_var_1 missingTupArg ++ happy_var_2 )}} -happyReduce_384 = happySpecReduce_2 134# happyReduction_384 -happyReduction_384 happy_x_2 +happyReduce_391 = happySpecReduce_2 136# happyReduction_391 +happyReduction_391 happy_x_2 happy_x_1 - = case happyOut219 happy_x_1 of { happy_var_1 -> - case happyOut143 happy_x_2 of { happy_var_2 -> - happyIn142 + = case happyOut221 happy_x_1 of { happy_var_1 -> + case happyOut145 happy_x_2 of { happy_var_2 -> + happyIn144 (replicate (happy_var_1-1) missingTupArg ++ happy_var_2 )}} -happyReduce_385 = happySpecReduce_2 135# happyReduction_385 -happyReduction_385 happy_x_2 +happyReduce_392 = happySpecReduce_2 137# happyReduction_392 +happyReduction_392 happy_x_2 happy_x_1 - = case happyOut140 happy_x_1 of { happy_var_1 -> - case happyOut142 happy_x_2 of { happy_var_2 -> - happyIn143 + = case happyOut142 happy_x_1 of { happy_var_1 -> + case happyOut144 happy_x_2 of { happy_var_2 -> + happyIn145 (Present happy_var_1 : happy_var_2 )}} -happyReduce_386 = happySpecReduce_1 135# happyReduction_386 -happyReduction_386 happy_x_1 - = case happyOut140 happy_x_1 of { happy_var_1 -> - happyIn143 +happyReduce_393 = happySpecReduce_1 137# happyReduction_393 +happyReduction_393 happy_x_1 + = case happyOut142 happy_x_1 of { happy_var_1 -> + happyIn145 ([Present happy_var_1] )} -happyReduce_387 = happySpecReduce_0 135# happyReduction_387 -happyReduction_387 = happyIn143 +happyReduce_394 = happySpecReduce_0 137# happyReduction_394 +happyReduction_394 = happyIn145 ([missingTupArg] ) -happyReduce_388 = happySpecReduce_1 136# happyReduction_388 -happyReduction_388 happy_x_1 - = case happyOut140 happy_x_1 of { happy_var_1 -> - happyIn144 +happyReduce_395 = happySpecReduce_1 138# happyReduction_395 +happyReduction_395 happy_x_1 + = case happyOut142 happy_x_1 of { happy_var_1 -> + happyIn146 (sL (getLoc happy_var_1) $ ExplicitList placeHolderType [happy_var_1] )} -happyReduce_389 = happySpecReduce_1 136# happyReduction_389 -happyReduction_389 happy_x_1 - = case happyOut145 happy_x_1 of { happy_var_1 -> - happyIn144 +happyReduce_396 = happySpecReduce_1 138# happyReduction_396 +happyReduction_396 happy_x_1 + = case happyOut147 happy_x_1 of { happy_var_1 -> + happyIn146 (sL (getLoc happy_var_1) $ ExplicitList placeHolderType (reverse (unLoc happy_var_1)) )} -happyReduce_390 = happySpecReduce_2 136# happyReduction_390 -happyReduction_390 happy_x_2 +happyReduce_397 = happySpecReduce_2 138# happyReduction_397 +happyReduction_397 happy_x_2 happy_x_1 - = case happyOut140 happy_x_1 of { happy_var_1 -> + = case happyOut142 happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> - happyIn144 + happyIn146 (sL (comb2 happy_var_1 happy_var_2) $ ArithSeq noPostTcExpr (From happy_var_1) )}} -happyReduce_391 = happyReduce 4# 136# happyReduction_391 -happyReduction_391 (happy_x_4 `HappyStk` +happyReduce_398 = happyReduce 4# 138# happyReduction_398 +happyReduction_398 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) - = case happyOut140 happy_x_1 of { happy_var_1 -> - case happyOut126 happy_x_3 of { happy_var_3 -> + = case happyOut142 happy_x_1 of { happy_var_1 -> + case happyOut128 happy_x_3 of { happy_var_3 -> case happyOutTok happy_x_4 of { happy_var_4 -> - happyIn144 + happyIn146 (sL (comb2 happy_var_1 happy_var_4) $ ArithSeq noPostTcExpr (FromThen happy_var_1 happy_var_3) ) `HappyStk` happyRest}}} -happyReduce_392 = happySpecReduce_3 136# happyReduction_392 -happyReduction_392 happy_x_3 +happyReduce_399 = happySpecReduce_3 138# happyReduction_399 +happyReduction_399 happy_x_3 happy_x_2 happy_x_1 - = case happyOut140 happy_x_1 of { happy_var_1 -> - case happyOut126 happy_x_3 of { happy_var_3 -> - happyIn144 + = case happyOut142 happy_x_1 of { happy_var_1 -> + case happyOut128 happy_x_3 of { happy_var_3 -> + happyIn146 (sL (comb2 happy_var_1 happy_var_3) $ ArithSeq noPostTcExpr (FromTo happy_var_1 happy_var_3) )}} -happyReduce_393 = happyReduce 5# 136# happyReduction_393 -happyReduction_393 (happy_x_5 `HappyStk` +happyReduce_400 = happyReduce 5# 138# happyReduction_400 +happyReduction_400 (happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) - = case happyOut140 happy_x_1 of { happy_var_1 -> - case happyOut126 happy_x_3 of { happy_var_3 -> - case happyOut126 happy_x_5 of { happy_var_5 -> - happyIn144 + = case happyOut142 happy_x_1 of { happy_var_1 -> + case happyOut128 happy_x_3 of { happy_var_3 -> + case happyOut128 happy_x_5 of { happy_var_5 -> + happyIn146 (sL (comb2 happy_var_1 happy_var_5) $ ArithSeq noPostTcExpr (FromThenTo happy_var_1 happy_var_3 happy_var_5) ) `HappyStk` happyRest}}} -happyReduce_394 = happySpecReduce_3 136# happyReduction_394 -happyReduction_394 happy_x_3 - happy_x_2 - happy_x_1 - = case happyOut140 happy_x_1 of { happy_var_1 -> - case happyOut146 happy_x_3 of { happy_var_3 -> - happyIn144 - (sL (comb2 happy_var_1 happy_var_3) $ mkHsDo ListComp (unLoc happy_var_3) happy_var_1 - )}} +happyReduce_401 = happyMonadReduce 3# 138# happyReduction_401 +happyReduction_401 (happy_x_3 `HappyStk` + happy_x_2 `HappyStk` + happy_x_1 `HappyStk` + happyRest) tk + = happyThen (case happyOut142 happy_x_1 of { happy_var_1 -> + case happyOut148 happy_x_3 of { happy_var_3 -> + ( checkMonadComp >>= \ ctxt -> + return (sL (comb2 happy_var_1 happy_var_3) $ + mkHsComp ctxt (unLoc happy_var_3) happy_var_1))}} + ) (\r -> happyReturn (happyIn146 r)) -happyReduce_395 = happySpecReduce_3 137# happyReduction_395 -happyReduction_395 happy_x_3 +happyReduce_402 = happySpecReduce_3 139# happyReduction_402 +happyReduction_402 happy_x_3 happy_x_2 happy_x_1 - = case happyOut145 happy_x_1 of { happy_var_1 -> - case happyOut140 happy_x_3 of { happy_var_3 -> - happyIn145 + = case happyOut147 happy_x_1 of { happy_var_1 -> + case happyOut142 happy_x_3 of { happy_var_3 -> + happyIn147 (sL (comb2 happy_var_1 happy_var_3) (((:) $! happy_var_3) $! unLoc happy_var_1) )}} -happyReduce_396 = happySpecReduce_3 137# happyReduction_396 -happyReduction_396 happy_x_3 +happyReduce_403 = happySpecReduce_3 139# happyReduction_403 +happyReduction_403 happy_x_3 happy_x_2 happy_x_1 - = case happyOut140 happy_x_1 of { happy_var_1 -> - case happyOut140 happy_x_3 of { happy_var_3 -> - happyIn145 + = case happyOut142 happy_x_1 of { happy_var_1 -> + case happyOut142 happy_x_3 of { happy_var_3 -> + happyIn147 (sL (comb2 happy_var_1 happy_var_3) [happy_var_3,happy_var_1] )}} -happyReduce_397 = happySpecReduce_1 138# happyReduction_397 -happyReduction_397 happy_x_1 - = case happyOut147 happy_x_1 of { happy_var_1 -> - happyIn146 +happyReduce_404 = happySpecReduce_1 140# happyReduction_404 +happyReduction_404 happy_x_1 + = case happyOut149 happy_x_1 of { happy_var_1 -> + happyIn148 (case (unLoc happy_var_1) of [qs] -> sL (getLoc happy_var_1) qs -- We just had one thing in our "parallel" list so -- we simply return that thing directly - qss -> sL (getLoc happy_var_1) [sL (getLoc happy_var_1) $ ParStmt [(qs, undefined) | qs <- qss]] + qss -> sL (getLoc happy_var_1) [sL (getLoc happy_var_1) $ ParStmt [(qs, undefined) | qs <- qss] noSyntaxExpr noSyntaxExpr noSyntaxExpr] -- We actually found some actual parallel lists so -- we wrap them into as a ParStmt )} -happyReduce_398 = happySpecReduce_3 139# happyReduction_398 -happyReduction_398 happy_x_3 +happyReduce_405 = happySpecReduce_3 141# happyReduction_405 +happyReduction_405 happy_x_3 happy_x_2 happy_x_1 - = case happyOut148 happy_x_1 of { happy_var_1 -> + = case happyOut150 happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> - case happyOut147 happy_x_3 of { happy_var_3 -> - happyIn147 + case happyOut149 happy_x_3 of { happy_var_3 -> + happyIn149 (L (getLoc happy_var_2) (reverse (unLoc happy_var_1) : unLoc happy_var_3) )}}} -happyReduce_399 = happySpecReduce_1 139# happyReduction_399 -happyReduction_399 happy_x_1 - = case happyOut148 happy_x_1 of { happy_var_1 -> - happyIn147 +happyReduce_406 = happySpecReduce_1 141# happyReduction_406 +happyReduction_406 happy_x_1 + = case happyOut150 happy_x_1 of { happy_var_1 -> + happyIn149 (L (getLoc happy_var_1) [reverse (unLoc happy_var_1)] )} -happyReduce_400 = happySpecReduce_3 140# happyReduction_400 -happyReduction_400 happy_x_3 +happyReduce_407 = happySpecReduce_3 142# happyReduction_407 +happyReduction_407 happy_x_3 happy_x_2 happy_x_1 - = case happyOut148 happy_x_1 of { happy_var_1 -> - case happyOut149 happy_x_3 of { happy_var_3 -> - happyIn148 + = case happyOut150 happy_x_1 of { happy_var_1 -> + case happyOut151 happy_x_3 of { happy_var_3 -> + happyIn150 (sL (comb2 happy_var_1 happy_var_3) [L (getLoc happy_var_3) ((unLoc happy_var_3) (reverse (unLoc happy_var_1)))] )}} -happyReduce_401 = happySpecReduce_3 140# happyReduction_401 -happyReduction_401 happy_x_3 +happyReduce_408 = happySpecReduce_3 142# happyReduction_408 +happyReduction_408 happy_x_3 happy_x_2 happy_x_1 - = case happyOut148 happy_x_1 of { happy_var_1 -> - case happyOut169 happy_x_3 of { happy_var_3 -> - happyIn148 + = case happyOut150 happy_x_1 of { happy_var_1 -> + case happyOut171 happy_x_3 of { happy_var_3 -> + happyIn150 (sL (comb2 happy_var_1 happy_var_3) (happy_var_3 : unLoc happy_var_1) )}} -happyReduce_402 = happySpecReduce_1 140# happyReduction_402 -happyReduction_402 happy_x_1 - = case happyOut149 happy_x_1 of { happy_var_1 -> - happyIn148 +happyReduce_409 = happySpecReduce_1 142# happyReduction_409 +happyReduction_409 happy_x_1 + = case happyOut151 happy_x_1 of { happy_var_1 -> + happyIn150 (sL (comb2 happy_var_1 happy_var_1) [L (getLoc happy_var_1) ((unLoc happy_var_1) [])] )} -happyReduce_403 = happySpecReduce_1 140# happyReduction_403 -happyReduction_403 happy_x_1 - = case happyOut169 happy_x_1 of { happy_var_1 -> - happyIn148 +happyReduce_410 = happySpecReduce_1 142# happyReduction_410 +happyReduction_410 happy_x_1 + = case happyOut171 happy_x_1 of { happy_var_1 -> + happyIn150 (sL (getLoc happy_var_1) [happy_var_1] )} -happyReduce_404 = happySpecReduce_2 141# happyReduction_404 -happyReduction_404 happy_x_2 +happyReduce_411 = happySpecReduce_2 143# happyReduction_411 +happyReduction_411 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut126 happy_x_2 of { happy_var_2 -> - happyIn149 + case happyOut128 happy_x_2 of { happy_var_2 -> + happyIn151 (sL (comb2 happy_var_1 happy_var_2) $ \leftStmts -> (mkTransformStmt leftStmts happy_var_2) )}} -happyReduce_405 = happyReduce 4# 141# happyReduction_405 -happyReduction_405 (happy_x_4 `HappyStk` +happyReduce_412 = happyReduce 4# 143# happyReduction_412 +happyReduction_412 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut126 happy_x_2 of { happy_var_2 -> - case happyOut126 happy_x_4 of { happy_var_4 -> - happyIn149 + case happyOut128 happy_x_2 of { happy_var_2 -> + case happyOut128 happy_x_4 of { happy_var_4 -> + happyIn151 (sL (comb2 happy_var_1 happy_var_4) $ \leftStmts -> (mkTransformByStmt leftStmts happy_var_2 happy_var_4) ) `HappyStk` happyRest}}} -happyReduce_406 = happyReduce 4# 141# happyReduction_406 -happyReduction_406 (happy_x_4 `HappyStk` +happyReduce_413 = happyReduce 4# 143# happyReduction_413 +happyReduction_413 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut126 happy_x_4 of { happy_var_4 -> - happyIn149 + case happyOut128 happy_x_4 of { happy_var_4 -> + happyIn151 (sL (comb2 happy_var_1 happy_var_4) $ \leftStmts -> (mkGroupByStmt leftStmts happy_var_4) ) `HappyStk` happyRest}} -happyReduce_407 = happyReduce 4# 141# happyReduction_407 -happyReduction_407 (happy_x_4 `HappyStk` +happyReduce_414 = happyReduce 4# 143# happyReduction_414 +happyReduction_414 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut126 happy_x_4 of { happy_var_4 -> - happyIn149 + case happyOut128 happy_x_4 of { happy_var_4 -> + happyIn151 (sL (comb2 happy_var_1 happy_var_4) $ \leftStmts -> (mkGroupUsingStmt leftStmts happy_var_4) ) `HappyStk` happyRest}} -happyReduce_408 = happyReduce 6# 141# happyReduction_408 -happyReduction_408 (happy_x_6 `HappyStk` +happyReduce_415 = happyReduce 6# 143# happyReduction_415 +happyReduction_415 (happy_x_6 `HappyStk` happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` @@ -5792,1484 +5872,1484 @@ happy_x_1 `HappyStk` happyRest) = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut126 happy_x_4 of { happy_var_4 -> - case happyOut126 happy_x_6 of { happy_var_6 -> - happyIn149 + case happyOut128 happy_x_4 of { happy_var_4 -> + case happyOut128 happy_x_6 of { happy_var_6 -> + happyIn151 (sL (comb2 happy_var_1 happy_var_6) $ \leftStmts -> (mkGroupByUsingStmt leftStmts happy_var_4 happy_var_6) ) `HappyStk` happyRest}}} -happyReduce_409 = happySpecReduce_0 142# happyReduction_409 -happyReduction_409 = happyIn150 +happyReduce_416 = happySpecReduce_0 144# happyReduction_416 +happyReduction_416 = happyIn152 (noLoc (ExplicitPArr placeHolderType []) ) -happyReduce_410 = happySpecReduce_1 142# happyReduction_410 -happyReduction_410 happy_x_1 - = case happyOut140 happy_x_1 of { happy_var_1 -> - happyIn150 +happyReduce_417 = happySpecReduce_1 144# happyReduction_417 +happyReduction_417 happy_x_1 + = case happyOut142 happy_x_1 of { happy_var_1 -> + happyIn152 (sL (getLoc happy_var_1) $ ExplicitPArr placeHolderType [happy_var_1] )} -happyReduce_411 = happySpecReduce_1 142# happyReduction_411 -happyReduction_411 happy_x_1 - = case happyOut145 happy_x_1 of { happy_var_1 -> - happyIn150 +happyReduce_418 = happySpecReduce_1 144# happyReduction_418 +happyReduction_418 happy_x_1 + = case happyOut147 happy_x_1 of { happy_var_1 -> + happyIn152 (sL (getLoc happy_var_1) $ ExplicitPArr placeHolderType (reverse (unLoc happy_var_1)) )} -happyReduce_412 = happySpecReduce_3 142# happyReduction_412 -happyReduction_412 happy_x_3 +happyReduce_419 = happySpecReduce_3 144# happyReduction_419 +happyReduction_419 happy_x_3 happy_x_2 happy_x_1 - = case happyOut140 happy_x_1 of { happy_var_1 -> - case happyOut126 happy_x_3 of { happy_var_3 -> - happyIn150 + = case happyOut142 happy_x_1 of { happy_var_1 -> + case happyOut128 happy_x_3 of { happy_var_3 -> + happyIn152 (sL (comb2 happy_var_1 happy_var_3) $ PArrSeq noPostTcExpr (FromTo happy_var_1 happy_var_3) )}} -happyReduce_413 = happyReduce 5# 142# happyReduction_413 -happyReduction_413 (happy_x_5 `HappyStk` +happyReduce_420 = happyReduce 5# 144# happyReduction_420 +happyReduction_420 (happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) - = case happyOut140 happy_x_1 of { happy_var_1 -> - case happyOut126 happy_x_3 of { happy_var_3 -> - case happyOut126 happy_x_5 of { happy_var_5 -> - happyIn150 + = case happyOut142 happy_x_1 of { happy_var_1 -> + case happyOut128 happy_x_3 of { happy_var_3 -> + case happyOut128 happy_x_5 of { happy_var_5 -> + happyIn152 (sL (comb2 happy_var_1 happy_var_5) $ PArrSeq noPostTcExpr (FromThenTo happy_var_1 happy_var_3 happy_var_5) ) `HappyStk` happyRest}}} -happyReduce_414 = happySpecReduce_3 142# happyReduction_414 -happyReduction_414 happy_x_3 +happyReduce_421 = happySpecReduce_3 144# happyReduction_421 +happyReduction_421 happy_x_3 happy_x_2 happy_x_1 - = case happyOut140 happy_x_1 of { happy_var_1 -> - case happyOut146 happy_x_3 of { happy_var_3 -> - happyIn150 - (sL (comb2 happy_var_1 happy_var_3) $ mkHsDo PArrComp (unLoc happy_var_3) happy_var_1 + = case happyOut142 happy_x_1 of { happy_var_1 -> + case happyOut148 happy_x_3 of { happy_var_3 -> + happyIn152 + (sL (comb2 happy_var_1 happy_var_3) $ mkHsComp PArrComp (unLoc happy_var_3) happy_var_1 )}} -happyReduce_415 = happySpecReduce_1 143# happyReduction_415 -happyReduction_415 happy_x_1 - = case happyOut152 happy_x_1 of { happy_var_1 -> - happyIn151 +happyReduce_422 = happySpecReduce_1 145# happyReduction_422 +happyReduction_422 happy_x_1 + = case happyOut154 happy_x_1 of { happy_var_1 -> + happyIn153 (L (getLoc happy_var_1) (reverse (unLoc happy_var_1)) )} -happyReduce_416 = happySpecReduce_3 144# happyReduction_416 -happyReduction_416 happy_x_3 +happyReduce_423 = happySpecReduce_3 146# happyReduction_423 +happyReduction_423 happy_x_3 happy_x_2 happy_x_1 - = case happyOut152 happy_x_1 of { happy_var_1 -> - case happyOut169 happy_x_3 of { happy_var_3 -> - happyIn152 + = case happyOut154 happy_x_1 of { happy_var_1 -> + case happyOut171 happy_x_3 of { happy_var_3 -> + happyIn154 (sL (comb2 happy_var_1 happy_var_3) (happy_var_3 : unLoc happy_var_1) )}} -happyReduce_417 = happySpecReduce_1 144# happyReduction_417 -happyReduction_417 happy_x_1 - = case happyOut169 happy_x_1 of { happy_var_1 -> - happyIn152 +happyReduce_424 = happySpecReduce_1 146# happyReduction_424 +happyReduction_424 happy_x_1 + = case happyOut171 happy_x_1 of { happy_var_1 -> + happyIn154 (sL (getLoc happy_var_1) [happy_var_1] )} -happyReduce_418 = happySpecReduce_3 145# happyReduction_418 -happyReduction_418 happy_x_3 +happyReduce_425 = happySpecReduce_3 147# happyReduction_425 +happyReduction_425 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut154 happy_x_2 of { happy_var_2 -> + case happyOut156 happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn153 + happyIn155 (sL (comb2 happy_var_1 happy_var_3) (reverse (unLoc happy_var_2)) )}}} -happyReduce_419 = happySpecReduce_3 145# happyReduction_419 -happyReduction_419 happy_x_3 +happyReduce_426 = happySpecReduce_3 147# happyReduction_426 +happyReduction_426 happy_x_3 happy_x_2 happy_x_1 - = case happyOut154 happy_x_2 of { happy_var_2 -> - happyIn153 + = case happyOut156 happy_x_2 of { happy_var_2 -> + happyIn155 (L (getLoc happy_var_2) (reverse (unLoc happy_var_2)) )} -happyReduce_420 = happySpecReduce_1 146# happyReduction_420 -happyReduction_420 happy_x_1 - = case happyOut155 happy_x_1 of { happy_var_1 -> - happyIn154 +happyReduce_427 = happySpecReduce_1 148# happyReduction_427 +happyReduction_427 happy_x_1 + = case happyOut157 happy_x_1 of { happy_var_1 -> + happyIn156 (sL (getLoc happy_var_1) (unLoc happy_var_1) )} -happyReduce_421 = happySpecReduce_2 146# happyReduction_421 -happyReduction_421 happy_x_2 +happyReduce_428 = happySpecReduce_2 148# happyReduction_428 +happyReduction_428 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut154 happy_x_2 of { happy_var_2 -> - happyIn154 + case happyOut156 happy_x_2 of { happy_var_2 -> + happyIn156 (sL (comb2 happy_var_1 happy_var_2) (unLoc happy_var_2) )}} -happyReduce_422 = happySpecReduce_3 147# happyReduction_422 -happyReduction_422 happy_x_3 +happyReduce_429 = happySpecReduce_3 149# happyReduction_429 +happyReduction_429 happy_x_3 happy_x_2 happy_x_1 - = case happyOut155 happy_x_1 of { happy_var_1 -> - case happyOut156 happy_x_3 of { happy_var_3 -> - happyIn155 + = case happyOut157 happy_x_1 of { happy_var_1 -> + case happyOut158 happy_x_3 of { happy_var_3 -> + happyIn157 (sL (comb2 happy_var_1 happy_var_3) (happy_var_3 : unLoc happy_var_1) )}} -happyReduce_423 = happySpecReduce_2 147# happyReduction_423 -happyReduction_423 happy_x_2 +happyReduce_430 = happySpecReduce_2 149# happyReduction_430 +happyReduction_430 happy_x_2 happy_x_1 - = case happyOut155 happy_x_1 of { happy_var_1 -> + = case happyOut157 happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> - happyIn155 + happyIn157 (sL (comb2 happy_var_1 happy_var_2) (unLoc happy_var_1) )}} -happyReduce_424 = happySpecReduce_1 147# happyReduction_424 -happyReduction_424 happy_x_1 - = case happyOut156 happy_x_1 of { happy_var_1 -> - happyIn155 +happyReduce_431 = happySpecReduce_1 149# happyReduction_431 +happyReduction_431 happy_x_1 + = case happyOut158 happy_x_1 of { happy_var_1 -> + happyIn157 (sL (getLoc happy_var_1) [happy_var_1] )} -happyReduce_425 = happySpecReduce_3 148# happyReduction_425 -happyReduction_425 happy_x_3 +happyReduce_432 = happySpecReduce_3 150# happyReduction_432 +happyReduction_432 happy_x_3 happy_x_2 happy_x_1 - = case happyOut161 happy_x_1 of { happy_var_1 -> - case happyOut79 happy_x_2 of { happy_var_2 -> - case happyOut157 happy_x_3 of { happy_var_3 -> - happyIn156 + = case happyOut163 happy_x_1 of { happy_var_1 -> + case happyOut81 happy_x_2 of { happy_var_2 -> + case happyOut159 happy_x_3 of { happy_var_3 -> + happyIn158 (sL (comb2 happy_var_1 happy_var_3) (Match [happy_var_1] happy_var_2 (unLoc happy_var_3)) )}}} -happyReduce_426 = happySpecReduce_2 149# happyReduction_426 -happyReduction_426 happy_x_2 +happyReduce_433 = happySpecReduce_2 151# happyReduction_433 +happyReduction_433 happy_x_2 happy_x_1 - = case happyOut158 happy_x_1 of { happy_var_1 -> - case happyOut60 happy_x_2 of { happy_var_2 -> - happyIn157 + = case happyOut160 happy_x_1 of { happy_var_1 -> + case happyOut62 happy_x_2 of { happy_var_2 -> + happyIn159 (sL (comb2 happy_var_1 happy_var_2) (GRHSs (unLoc happy_var_1) (unLoc happy_var_2)) )}} -happyReduce_427 = happySpecReduce_2 150# happyReduction_427 -happyReduction_427 happy_x_2 +happyReduce_434 = happySpecReduce_2 152# happyReduction_434 +happyReduction_434 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut126 happy_x_2 of { happy_var_2 -> - happyIn158 + case happyOut128 happy_x_2 of { happy_var_2 -> + happyIn160 (sL (comb2 happy_var_1 happy_var_2) (unguardedRHS happy_var_2) )}} -happyReduce_428 = happySpecReduce_1 150# happyReduction_428 -happyReduction_428 happy_x_1 - = case happyOut159 happy_x_1 of { happy_var_1 -> - happyIn158 +happyReduce_435 = happySpecReduce_1 152# happyReduction_435 +happyReduction_435 happy_x_1 + = case happyOut161 happy_x_1 of { happy_var_1 -> + happyIn160 (sL (getLoc happy_var_1) (reverse (unLoc happy_var_1)) )} -happyReduce_429 = happySpecReduce_2 151# happyReduction_429 -happyReduction_429 happy_x_2 +happyReduce_436 = happySpecReduce_2 153# happyReduction_436 +happyReduction_436 happy_x_2 happy_x_1 - = case happyOut159 happy_x_1 of { happy_var_1 -> - case happyOut160 happy_x_2 of { happy_var_2 -> - happyIn159 + = case happyOut161 happy_x_1 of { happy_var_1 -> + case happyOut162 happy_x_2 of { happy_var_2 -> + happyIn161 (sL (comb2 happy_var_1 happy_var_2) (happy_var_2 : unLoc happy_var_1) )}} -happyReduce_430 = happySpecReduce_1 151# happyReduction_430 -happyReduction_430 happy_x_1 - = case happyOut160 happy_x_1 of { happy_var_1 -> - happyIn159 +happyReduce_437 = happySpecReduce_1 153# happyReduction_437 +happyReduction_437 happy_x_1 + = case happyOut162 happy_x_1 of { happy_var_1 -> + happyIn161 (sL (getLoc happy_var_1) [happy_var_1] )} -happyReduce_431 = happyReduce 4# 152# happyReduction_431 -happyReduction_431 (happy_x_4 `HappyStk` +happyReduce_438 = happyReduce 4# 154# happyReduction_438 +happyReduction_438 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut151 happy_x_2 of { happy_var_2 -> - case happyOut126 happy_x_4 of { happy_var_4 -> - happyIn160 + case happyOut153 happy_x_2 of { happy_var_2 -> + case happyOut128 happy_x_4 of { happy_var_4 -> + happyIn162 (sL (comb2 happy_var_1 happy_var_4) $ GRHS (unLoc happy_var_2) happy_var_4 ) `HappyStk` happyRest}}} -happyReduce_432 = happyMonadReduce 1# 153# happyReduction_432 -happyReduction_432 (happy_x_1 `HappyStk` +happyReduce_439 = happyMonadReduce 1# 155# happyReduction_439 +happyReduction_439 (happy_x_1 `HappyStk` happyRest) tk - = happyThen (case happyOut126 happy_x_1 of { happy_var_1 -> + = happyThen (case happyOut128 happy_x_1 of { happy_var_1 -> ( checkPattern happy_var_1)} - ) (\r -> happyReturn (happyIn161 r)) + ) (\r -> happyReturn (happyIn163 r)) -happyReduce_433 = happyMonadReduce 2# 153# happyReduction_433 -happyReduction_433 (happy_x_2 `HappyStk` +happyReduce_440 = happyMonadReduce 2# 155# happyReduction_440 +happyReduction_440 (happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut133 happy_x_2 of { happy_var_2 -> + case happyOut135 happy_x_2 of { happy_var_2 -> ( checkPattern (sL (comb2 happy_var_1 happy_var_2) (SectionR (sL (getLoc happy_var_1) (HsVar bang_RDR)) happy_var_2)))}} - ) (\r -> happyReturn (happyIn161 r)) + ) (\r -> happyReturn (happyIn163 r)) -happyReduce_434 = happyMonadReduce 1# 154# happyReduction_434 -happyReduction_434 (happy_x_1 `HappyStk` +happyReduce_441 = happyMonadReduce 1# 156# happyReduction_441 +happyReduction_441 (happy_x_1 `HappyStk` happyRest) tk - = happyThen (case happyOut133 happy_x_1 of { happy_var_1 -> + = happyThen (case happyOut135 happy_x_1 of { happy_var_1 -> ( checkPattern happy_var_1)} - ) (\r -> happyReturn (happyIn162 r)) + ) (\r -> happyReturn (happyIn164 r)) -happyReduce_435 = happyMonadReduce 2# 154# happyReduction_435 -happyReduction_435 (happy_x_2 `HappyStk` +happyReduce_442 = happyMonadReduce 2# 156# happyReduction_442 +happyReduction_442 (happy_x_2 `HappyStk` happy_x_1 `HappyStk` happyRest) tk = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut133 happy_x_2 of { happy_var_2 -> + case happyOut135 happy_x_2 of { happy_var_2 -> ( checkPattern (sL (comb2 happy_var_1 happy_var_2) (SectionR (sL (getLoc happy_var_1) (HsVar bang_RDR)) happy_var_2)))}} - ) (\r -> happyReturn (happyIn162 r)) + ) (\r -> happyReturn (happyIn164 r)) -happyReduce_436 = happySpecReduce_2 155# happyReduction_436 -happyReduction_436 happy_x_2 +happyReduce_443 = happySpecReduce_2 157# happyReduction_443 +happyReduction_443 happy_x_2 happy_x_1 - = case happyOut162 happy_x_1 of { happy_var_1 -> - case happyOut163 happy_x_2 of { happy_var_2 -> - happyIn163 + = case happyOut164 happy_x_1 of { happy_var_1 -> + case happyOut165 happy_x_2 of { happy_var_2 -> + happyIn165 (happy_var_1 : happy_var_2 )}} -happyReduce_437 = happySpecReduce_0 155# happyReduction_437 -happyReduction_437 = happyIn163 +happyReduce_444 = happySpecReduce_0 157# happyReduction_444 +happyReduction_444 = happyIn165 ([] ) -happyReduce_438 = happySpecReduce_3 156# happyReduction_438 -happyReduction_438 happy_x_3 +happyReduce_445 = happySpecReduce_3 158# happyReduction_445 +happyReduction_445 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut165 happy_x_2 of { happy_var_2 -> + case happyOut167 happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn164 + happyIn166 (sL (comb2 happy_var_1 happy_var_3) (unLoc happy_var_2) )}}} -happyReduce_439 = happySpecReduce_3 156# happyReduction_439 -happyReduction_439 happy_x_3 +happyReduce_446 = happySpecReduce_3 158# happyReduction_446 +happyReduction_446 happy_x_3 happy_x_2 happy_x_1 - = case happyOut165 happy_x_2 of { happy_var_2 -> - happyIn164 + = case happyOut167 happy_x_2 of { happy_var_2 -> + happyIn166 (happy_var_2 )} -happyReduce_440 = happySpecReduce_2 157# happyReduction_440 -happyReduction_440 happy_x_2 +happyReduce_447 = happySpecReduce_2 159# happyReduction_447 +happyReduction_447 happy_x_2 happy_x_1 - = case happyOut168 happy_x_1 of { happy_var_1 -> - case happyOut166 happy_x_2 of { happy_var_2 -> - happyIn165 + = case happyOut170 happy_x_1 of { happy_var_1 -> + case happyOut168 happy_x_2 of { happy_var_2 -> + happyIn167 (sL (comb2 happy_var_1 happy_var_2) (happy_var_1 : unLoc happy_var_2) )}} -happyReduce_441 = happySpecReduce_2 157# happyReduction_441 -happyReduction_441 happy_x_2 +happyReduce_448 = happySpecReduce_2 159# happyReduction_448 +happyReduction_448 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut165 happy_x_2 of { happy_var_2 -> - happyIn165 + case happyOut167 happy_x_2 of { happy_var_2 -> + happyIn167 (sL (comb2 happy_var_1 happy_var_2) (unLoc happy_var_2) )}} -happyReduce_442 = happySpecReduce_0 157# happyReduction_442 -happyReduction_442 = happyIn165 +happyReduce_449 = happySpecReduce_0 159# happyReduction_449 +happyReduction_449 = happyIn167 (noLoc [] ) -happyReduce_443 = happySpecReduce_2 158# happyReduction_443 -happyReduction_443 happy_x_2 +happyReduce_450 = happySpecReduce_2 160# happyReduction_450 +happyReduction_450 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut165 happy_x_2 of { happy_var_2 -> - happyIn166 + case happyOut167 happy_x_2 of { happy_var_2 -> + happyIn168 (sL (comb2 happy_var_1 happy_var_2) (unLoc happy_var_2) )}} -happyReduce_444 = happySpecReduce_0 158# happyReduction_444 -happyReduction_444 = happyIn166 +happyReduce_451 = happySpecReduce_0 160# happyReduction_451 +happyReduction_451 = happyIn168 (noLoc [] ) -happyReduce_445 = happySpecReduce_1 159# happyReduction_445 -happyReduction_445 happy_x_1 - = case happyOut168 happy_x_1 of { happy_var_1 -> - happyIn167 +happyReduce_452 = happySpecReduce_1 161# happyReduction_452 +happyReduction_452 happy_x_1 + = case happyOut170 happy_x_1 of { happy_var_1 -> + happyIn169 (Just happy_var_1 )} -happyReduce_446 = happySpecReduce_0 159# happyReduction_446 -happyReduction_446 = happyIn167 +happyReduce_453 = happySpecReduce_0 161# happyReduction_453 +happyReduction_453 = happyIn169 (Nothing ) -happyReduce_447 = happySpecReduce_1 160# happyReduction_447 -happyReduction_447 happy_x_1 - = case happyOut169 happy_x_1 of { happy_var_1 -> - happyIn168 +happyReduce_454 = happySpecReduce_1 162# happyReduction_454 +happyReduction_454 happy_x_1 + = case happyOut171 happy_x_1 of { happy_var_1 -> + happyIn170 (happy_var_1 )} -happyReduce_448 = happySpecReduce_2 160# happyReduction_448 -happyReduction_448 happy_x_2 +happyReduce_455 = happySpecReduce_2 162# happyReduction_455 +happyReduction_455 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut164 happy_x_2 of { happy_var_2 -> - happyIn168 + case happyOut166 happy_x_2 of { happy_var_2 -> + happyIn170 (sL (comb2 happy_var_1 happy_var_2) $ mkRecStmt (unLoc happy_var_2) )}} -happyReduce_449 = happySpecReduce_3 161# happyReduction_449 -happyReduction_449 happy_x_3 +happyReduce_456 = happySpecReduce_3 163# happyReduction_456 +happyReduction_456 happy_x_3 happy_x_2 happy_x_1 - = case happyOut161 happy_x_1 of { happy_var_1 -> - case happyOut126 happy_x_3 of { happy_var_3 -> - happyIn169 + = case happyOut163 happy_x_1 of { happy_var_1 -> + case happyOut128 happy_x_3 of { happy_var_3 -> + happyIn171 (sL (comb2 happy_var_1 happy_var_3) $ mkBindStmt happy_var_1 happy_var_3 )}} -happyReduce_450 = happySpecReduce_1 161# happyReduction_450 -happyReduction_450 happy_x_1 - = case happyOut126 happy_x_1 of { happy_var_1 -> - happyIn169 +happyReduce_457 = happySpecReduce_1 163# happyReduction_457 +happyReduction_457 happy_x_1 + = case happyOut128 happy_x_1 of { happy_var_1 -> + happyIn171 (sL (getLoc happy_var_1) $ mkExprStmt happy_var_1 )} -happyReduce_451 = happySpecReduce_2 161# happyReduction_451 -happyReduction_451 happy_x_2 +happyReduce_458 = happySpecReduce_2 163# happyReduction_458 +happyReduction_458 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut59 happy_x_2 of { happy_var_2 -> - happyIn169 + case happyOut61 happy_x_2 of { happy_var_2 -> + happyIn171 (sL (comb2 happy_var_1 happy_var_2) $ LetStmt (unLoc happy_var_2) )}} -happyReduce_452 = happySpecReduce_1 162# happyReduction_452 -happyReduction_452 happy_x_1 - = case happyOut171 happy_x_1 of { happy_var_1 -> - happyIn170 +happyReduce_459 = happySpecReduce_1 164# happyReduction_459 +happyReduction_459 happy_x_1 + = case happyOut173 happy_x_1 of { happy_var_1 -> + happyIn172 (happy_var_1 )} -happyReduce_453 = happySpecReduce_0 162# happyReduction_453 -happyReduction_453 = happyIn170 +happyReduce_460 = happySpecReduce_0 164# happyReduction_460 +happyReduction_460 = happyIn172 (([], False) ) -happyReduce_454 = happySpecReduce_3 163# happyReduction_454 -happyReduction_454 happy_x_3 +happyReduce_461 = happySpecReduce_3 165# happyReduction_461 +happyReduction_461 happy_x_3 happy_x_2 happy_x_1 - = case happyOut172 happy_x_1 of { happy_var_1 -> - case happyOut171 happy_x_3 of { happy_var_3 -> - happyIn171 + = case happyOut174 happy_x_1 of { happy_var_1 -> + case happyOut173 happy_x_3 of { happy_var_3 -> + happyIn173 (case happy_var_3 of (flds, dd) -> (happy_var_1 : flds, dd) )}} -happyReduce_455 = happySpecReduce_1 163# happyReduction_455 -happyReduction_455 happy_x_1 - = case happyOut172 happy_x_1 of { happy_var_1 -> - happyIn171 +happyReduce_462 = happySpecReduce_1 165# happyReduction_462 +happyReduction_462 happy_x_1 + = case happyOut174 happy_x_1 of { happy_var_1 -> + happyIn173 (([happy_var_1], False) )} -happyReduce_456 = happySpecReduce_1 163# happyReduction_456 -happyReduction_456 happy_x_1 - = happyIn171 +happyReduce_463 = happySpecReduce_1 165# happyReduction_463 +happyReduction_463 happy_x_1 + = happyIn173 (([], True) ) -happyReduce_457 = happySpecReduce_3 164# happyReduction_457 -happyReduction_457 happy_x_3 +happyReduce_464 = happySpecReduce_3 166# happyReduction_464 +happyReduction_464 happy_x_3 happy_x_2 happy_x_1 - = case happyOut202 happy_x_1 of { happy_var_1 -> - case happyOut126 happy_x_3 of { happy_var_3 -> - happyIn172 + = case happyOut204 happy_x_1 of { happy_var_1 -> + case happyOut128 happy_x_3 of { happy_var_3 -> + happyIn174 (HsRecField happy_var_1 happy_var_3 False )}} -happyReduce_458 = happySpecReduce_1 164# happyReduction_458 -happyReduction_458 happy_x_1 - = case happyOut202 happy_x_1 of { happy_var_1 -> - happyIn172 +happyReduce_465 = happySpecReduce_1 166# happyReduction_465 +happyReduction_465 happy_x_1 + = case happyOut204 happy_x_1 of { happy_var_1 -> + happyIn174 (HsRecField happy_var_1 placeHolderPunRhs True )} -happyReduce_459 = happySpecReduce_3 165# happyReduction_459 -happyReduction_459 happy_x_3 +happyReduce_466 = happySpecReduce_3 167# happyReduction_466 +happyReduction_466 happy_x_3 happy_x_2 happy_x_1 - = case happyOut173 happy_x_1 of { happy_var_1 -> - case happyOut174 happy_x_3 of { happy_var_3 -> - happyIn173 + = case happyOut175 happy_x_1 of { happy_var_1 -> + case happyOut176 happy_x_3 of { happy_var_3 -> + happyIn175 (let { this = happy_var_3; rest = unLoc happy_var_1 } in rest `seq` this `seq` sL (comb2 happy_var_1 happy_var_3) (this : rest) )}} -happyReduce_460 = happySpecReduce_2 165# happyReduction_460 -happyReduction_460 happy_x_2 +happyReduce_467 = happySpecReduce_2 167# happyReduction_467 +happyReduction_467 happy_x_2 happy_x_1 - = case happyOut173 happy_x_1 of { happy_var_1 -> + = case happyOut175 happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> - happyIn173 + happyIn175 (sL (comb2 happy_var_1 happy_var_2) (unLoc happy_var_1) )}} -happyReduce_461 = happySpecReduce_1 165# happyReduction_461 -happyReduction_461 happy_x_1 - = case happyOut174 happy_x_1 of { happy_var_1 -> - happyIn173 +happyReduce_468 = happySpecReduce_1 167# happyReduction_468 +happyReduction_468 happy_x_1 + = case happyOut176 happy_x_1 of { happy_var_1 -> + happyIn175 (let this = happy_var_1 in this `seq` sL (getLoc happy_var_1) [this] )} -happyReduce_462 = happySpecReduce_3 166# happyReduction_462 -happyReduction_462 happy_x_3 +happyReduce_469 = happySpecReduce_3 168# happyReduction_469 +happyReduction_469 happy_x_3 happy_x_2 happy_x_1 - = case happyOut175 happy_x_1 of { happy_var_1 -> - case happyOut126 happy_x_3 of { happy_var_3 -> - happyIn174 + = case happyOut177 happy_x_1 of { happy_var_1 -> + case happyOut128 happy_x_3 of { happy_var_3 -> + happyIn176 (sL (comb2 happy_var_1 happy_var_3) (IPBind (unLoc happy_var_1) happy_var_3) )}} -happyReduce_463 = happySpecReduce_1 167# happyReduction_463 -happyReduction_463 happy_x_1 +happyReduce_470 = happySpecReduce_1 169# happyReduction_470 +happyReduction_470 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn175 + happyIn177 (sL (getLoc happy_var_1) (IPName (mkUnqual varName (getIPDUPVARID happy_var_1))) )} -happyReduce_464 = happySpecReduce_1 168# happyReduction_464 -happyReduction_464 happy_x_1 - = case happyOut177 happy_x_1 of { happy_var_1 -> - happyIn176 +happyReduce_471 = happySpecReduce_1 170# happyReduction_471 +happyReduction_471 happy_x_1 + = case happyOut179 happy_x_1 of { happy_var_1 -> + happyIn178 (sL (getLoc happy_var_1) [unLoc happy_var_1] )} -happyReduce_465 = happySpecReduce_3 168# happyReduction_465 -happyReduction_465 happy_x_3 +happyReduce_472 = happySpecReduce_3 170# happyReduction_472 +happyReduction_472 happy_x_3 happy_x_2 happy_x_1 - = case happyOut177 happy_x_1 of { happy_var_1 -> - case happyOut176 happy_x_3 of { happy_var_3 -> - happyIn176 + = case happyOut179 happy_x_1 of { happy_var_1 -> + case happyOut178 happy_x_3 of { happy_var_3 -> + happyIn178 (sL (comb2 happy_var_1 happy_var_3) (unLoc happy_var_1 : unLoc happy_var_3) )}} -happyReduce_466 = happySpecReduce_1 169# happyReduction_466 -happyReduction_466 happy_x_1 - = case happyOut201 happy_x_1 of { happy_var_1 -> - happyIn177 +happyReduce_473 = happySpecReduce_1 171# happyReduction_473 +happyReduction_473 happy_x_1 + = case happyOut203 happy_x_1 of { happy_var_1 -> + happyIn179 (happy_var_1 )} -happyReduce_467 = happySpecReduce_1 169# happyReduction_467 -happyReduction_467 happy_x_1 - = case happyOut179 happy_x_1 of { happy_var_1 -> - happyIn177 +happyReduce_474 = happySpecReduce_1 171# happyReduction_474 +happyReduction_474 happy_x_1 + = case happyOut181 happy_x_1 of { happy_var_1 -> + happyIn179 (happy_var_1 )} -happyReduce_468 = happySpecReduce_1 170# happyReduction_468 -happyReduction_468 happy_x_1 - = case happyOut212 happy_x_1 of { happy_var_1 -> - happyIn178 +happyReduce_475 = happySpecReduce_1 172# happyReduction_475 +happyReduction_475 happy_x_1 + = case happyOut214 happy_x_1 of { happy_var_1 -> + happyIn180 (happy_var_1 )} -happyReduce_469 = happySpecReduce_3 170# happyReduction_469 -happyReduction_469 happy_x_3 +happyReduce_476 = happySpecReduce_3 172# happyReduction_476 +happyReduction_476 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut214 happy_x_2 of { happy_var_2 -> + case happyOut216 happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn178 + happyIn180 (sL (comb2 happy_var_1 happy_var_3) (unLoc happy_var_2) )}}} -happyReduce_470 = happySpecReduce_1 170# happyReduction_470 -happyReduction_470 happy_x_1 - = case happyOut181 happy_x_1 of { happy_var_1 -> - happyIn178 +happyReduce_477 = happySpecReduce_1 172# happyReduction_477 +happyReduction_477 happy_x_1 + = case happyOut183 happy_x_1 of { happy_var_1 -> + happyIn180 (sL (getLoc happy_var_1) $ nameRdrName (dataConName (unLoc happy_var_1)) )} -happyReduce_471 = happySpecReduce_1 171# happyReduction_471 -happyReduction_471 happy_x_1 - = case happyOut213 happy_x_1 of { happy_var_1 -> - happyIn179 +happyReduce_478 = happySpecReduce_1 173# happyReduction_478 +happyReduction_478 happy_x_1 + = case happyOut215 happy_x_1 of { happy_var_1 -> + happyIn181 (happy_var_1 )} -happyReduce_472 = happySpecReduce_3 171# happyReduction_472 -happyReduction_472 happy_x_3 +happyReduce_479 = happySpecReduce_3 173# happyReduction_479 +happyReduction_479 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut215 happy_x_2 of { happy_var_2 -> + case happyOut217 happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn179 + happyIn181 (sL (comb2 happy_var_1 happy_var_3) (unLoc happy_var_2) )}}} -happyReduce_473 = happySpecReduce_1 171# happyReduction_473 -happyReduction_473 happy_x_1 - = case happyOut181 happy_x_1 of { happy_var_1 -> - happyIn179 +happyReduce_480 = happySpecReduce_1 173# happyReduction_480 +happyReduction_480 happy_x_1 + = case happyOut183 happy_x_1 of { happy_var_1 -> + happyIn181 (sL (getLoc happy_var_1) $ nameRdrName (dataConName (unLoc happy_var_1)) )} -happyReduce_474 = happySpecReduce_1 172# happyReduction_474 -happyReduction_474 happy_x_1 - = case happyOut179 happy_x_1 of { happy_var_1 -> - happyIn180 +happyReduce_481 = happySpecReduce_1 174# happyReduction_481 +happyReduction_481 happy_x_1 + = case happyOut181 happy_x_1 of { happy_var_1 -> + happyIn182 (sL (getLoc happy_var_1) [happy_var_1] )} -happyReduce_475 = happySpecReduce_3 172# happyReduction_475 -happyReduction_475 happy_x_3 +happyReduce_482 = happySpecReduce_3 174# happyReduction_482 +happyReduction_482 happy_x_3 happy_x_2 happy_x_1 - = case happyOut179 happy_x_1 of { happy_var_1 -> - case happyOut180 happy_x_3 of { happy_var_3 -> - happyIn180 + = case happyOut181 happy_x_1 of { happy_var_1 -> + case happyOut182 happy_x_3 of { happy_var_3 -> + happyIn182 (sL (comb2 happy_var_1 happy_var_3) (happy_var_1 : unLoc happy_var_3) )}} -happyReduce_476 = happySpecReduce_2 173# happyReduction_476 -happyReduction_476 happy_x_2 +happyReduce_483 = happySpecReduce_2 175# happyReduction_483 +happyReduction_483 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> - happyIn181 + happyIn183 (sL (comb2 happy_var_1 happy_var_2) unitDataCon )}} -happyReduce_477 = happySpecReduce_3 173# happyReduction_477 -happyReduction_477 happy_x_3 +happyReduce_484 = happySpecReduce_3 175# happyReduction_484 +happyReduction_484 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut219 happy_x_2 of { happy_var_2 -> + case happyOut221 happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn181 + happyIn183 (sL (comb2 happy_var_1 happy_var_3) $ tupleCon Boxed (happy_var_2 + 1) )}}} -happyReduce_478 = happySpecReduce_2 173# happyReduction_478 -happyReduction_478 happy_x_2 +happyReduce_485 = happySpecReduce_2 175# happyReduction_485 +happyReduction_485 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> - happyIn181 + happyIn183 (sL (comb2 happy_var_1 happy_var_2) $ unboxedSingletonDataCon )}} -happyReduce_479 = happySpecReduce_3 173# happyReduction_479 -happyReduction_479 happy_x_3 +happyReduce_486 = happySpecReduce_3 175# happyReduction_486 +happyReduction_486 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut219 happy_x_2 of { happy_var_2 -> + case happyOut221 happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn181 + happyIn183 (sL (comb2 happy_var_1 happy_var_3) $ tupleCon Unboxed (happy_var_2 + 1) )}}} -happyReduce_480 = happySpecReduce_2 173# happyReduction_480 -happyReduction_480 happy_x_2 +happyReduce_487 = happySpecReduce_2 175# happyReduction_487 +happyReduction_487 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> - happyIn181 + happyIn183 (sL (comb2 happy_var_1 happy_var_2) nilDataCon )}} -happyReduce_481 = happySpecReduce_1 174# happyReduction_481 -happyReduction_481 happy_x_1 - = case happyOut215 happy_x_1 of { happy_var_1 -> - happyIn182 +happyReduce_488 = happySpecReduce_1 176# happyReduction_488 +happyReduction_488 happy_x_1 + = case happyOut217 happy_x_1 of { happy_var_1 -> + happyIn184 (happy_var_1 )} -happyReduce_482 = happySpecReduce_3 174# happyReduction_482 -happyReduction_482 happy_x_3 +happyReduce_489 = happySpecReduce_3 176# happyReduction_489 +happyReduction_489 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut213 happy_x_2 of { happy_var_2 -> + case happyOut215 happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn182 + happyIn184 (sL (comb2 happy_var_1 happy_var_3) (unLoc happy_var_2) )}}} -happyReduce_483 = happySpecReduce_1 175# happyReduction_483 -happyReduction_483 happy_x_1 - = case happyOut214 happy_x_1 of { happy_var_1 -> - happyIn183 +happyReduce_490 = happySpecReduce_1 177# happyReduction_490 +happyReduction_490 happy_x_1 + = case happyOut216 happy_x_1 of { happy_var_1 -> + happyIn185 (happy_var_1 )} -happyReduce_484 = happySpecReduce_3 175# happyReduction_484 -happyReduction_484 happy_x_3 +happyReduce_491 = happySpecReduce_3 177# happyReduction_491 +happyReduction_491 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut212 happy_x_2 of { happy_var_2 -> + case happyOut214 happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn183 + happyIn185 (sL (comb2 happy_var_1 happy_var_3) (unLoc happy_var_2) )}}} -happyReduce_485 = happySpecReduce_1 176# happyReduction_485 -happyReduction_485 happy_x_1 - = case happyOut185 happy_x_1 of { happy_var_1 -> - happyIn184 +happyReduce_492 = happySpecReduce_1 178# happyReduction_492 +happyReduction_492 happy_x_1 + = case happyOut187 happy_x_1 of { happy_var_1 -> + happyIn186 (happy_var_1 )} -happyReduce_486 = happySpecReduce_2 176# happyReduction_486 -happyReduction_486 happy_x_2 +happyReduce_493 = happySpecReduce_2 178# happyReduction_493 +happyReduction_493 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> - happyIn184 + happyIn186 (sL (comb2 happy_var_1 happy_var_2) $ getRdrName unitTyCon )}} -happyReduce_487 = happySpecReduce_3 176# happyReduction_487 -happyReduction_487 happy_x_3 +happyReduce_494 = happySpecReduce_3 178# happyReduction_494 +happyReduction_494 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut219 happy_x_2 of { happy_var_2 -> + case happyOut221 happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn184 + happyIn186 (sL (comb2 happy_var_1 happy_var_3) $ getRdrName (tupleTyCon Boxed (happy_var_2 + 1)) )}}} -happyReduce_488 = happySpecReduce_2 176# happyReduction_488 -happyReduction_488 happy_x_2 +happyReduce_495 = happySpecReduce_2 178# happyReduction_495 +happyReduction_495 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> - happyIn184 + happyIn186 (sL (comb2 happy_var_1 happy_var_2) $ getRdrName unboxedSingletonTyCon )}} -happyReduce_489 = happySpecReduce_3 176# happyReduction_489 -happyReduction_489 happy_x_3 +happyReduce_496 = happySpecReduce_3 178# happyReduction_496 +happyReduction_496 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut219 happy_x_2 of { happy_var_2 -> + case happyOut221 happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn184 + happyIn186 (sL (comb2 happy_var_1 happy_var_3) $ getRdrName (tupleTyCon Unboxed (happy_var_2 + 1)) )}}} -happyReduce_490 = happySpecReduce_3 176# happyReduction_490 -happyReduction_490 happy_x_3 +happyReduce_497 = happySpecReduce_3 178# happyReduction_497 +happyReduction_497 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn184 + happyIn186 (sL (comb2 happy_var_1 happy_var_3) $ getRdrName funTyCon )}} -happyReduce_491 = happySpecReduce_2 176# happyReduction_491 -happyReduction_491 happy_x_2 +happyReduce_498 = happySpecReduce_2 178# happyReduction_498 +happyReduction_498 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> - happyIn184 + happyIn186 (sL (comb2 happy_var_1 happy_var_2) $ listTyCon_RDR )}} -happyReduce_492 = happySpecReduce_2 176# happyReduction_492 -happyReduction_492 happy_x_2 +happyReduce_499 = happySpecReduce_2 178# happyReduction_499 +happyReduction_499 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> case happyOutTok happy_x_2 of { happy_var_2 -> - happyIn184 + happyIn186 (sL (comb2 happy_var_1 happy_var_2) $ parrTyCon_RDR )}} -happyReduce_493 = happySpecReduce_1 177# happyReduction_493 -happyReduction_493 happy_x_1 - = case happyOut187 happy_x_1 of { happy_var_1 -> - happyIn185 +happyReduce_500 = happySpecReduce_1 179# happyReduction_500 +happyReduction_500 happy_x_1 + = case happyOut189 happy_x_1 of { happy_var_1 -> + happyIn187 (happy_var_1 )} -happyReduce_494 = happySpecReduce_3 177# happyReduction_494 -happyReduction_494 happy_x_3 +happyReduce_501 = happySpecReduce_3 179# happyReduction_501 +happyReduction_501 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut189 happy_x_2 of { happy_var_2 -> + case happyOut191 happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn185 + happyIn187 (sL (comb2 happy_var_1 happy_var_3) (unLoc happy_var_2) )}}} -happyReduce_495 = happySpecReduce_1 178# happyReduction_495 -happyReduction_495 happy_x_1 - = case happyOut189 happy_x_1 of { happy_var_1 -> - happyIn186 +happyReduce_502 = happySpecReduce_1 180# happyReduction_502 +happyReduction_502 happy_x_1 + = case happyOut191 happy_x_1 of { happy_var_1 -> + happyIn188 (happy_var_1 )} -happyReduce_496 = happySpecReduce_3 178# happyReduction_496 -happyReduction_496 happy_x_3 +happyReduce_503 = happySpecReduce_3 180# happyReduction_503 +happyReduction_503 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut187 happy_x_2 of { happy_var_2 -> + case happyOut189 happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn186 + happyIn188 (sL (comb2 happy_var_1 happy_var_3) (unLoc happy_var_2) )}}} -happyReduce_497 = happySpecReduce_1 179# happyReduction_497 -happyReduction_497 happy_x_1 +happyReduce_504 = happySpecReduce_1 181# happyReduction_504 +happyReduction_504 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn187 + happyIn189 (sL (getLoc happy_var_1) $! mkQual tcClsName (getQCONID happy_var_1) )} -happyReduce_498 = happySpecReduce_1 179# happyReduction_498 -happyReduction_498 happy_x_1 +happyReduce_505 = happySpecReduce_1 181# happyReduction_505 +happyReduction_505 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn187 + happyIn189 (sL (getLoc happy_var_1) $! mkQual tcClsName (getPREFIXQCONSYM happy_var_1) )} -happyReduce_499 = happySpecReduce_1 179# happyReduction_499 -happyReduction_499 happy_x_1 - = case happyOut188 happy_x_1 of { happy_var_1 -> - happyIn187 +happyReduce_506 = happySpecReduce_1 181# happyReduction_506 +happyReduction_506 happy_x_1 + = case happyOut190 happy_x_1 of { happy_var_1 -> + happyIn189 (happy_var_1 )} -happyReduce_500 = happySpecReduce_1 180# happyReduction_500 -happyReduction_500 happy_x_1 +happyReduce_507 = happySpecReduce_1 182# happyReduction_507 +happyReduction_507 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn188 + happyIn190 (sL (getLoc happy_var_1) $! mkUnqual tcClsName (getCONID happy_var_1) )} -happyReduce_501 = happySpecReduce_1 181# happyReduction_501 -happyReduction_501 happy_x_1 +happyReduce_508 = happySpecReduce_1 183# happyReduction_508 +happyReduction_508 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn189 + happyIn191 (sL (getLoc happy_var_1) $! mkQual tcClsName (getQCONSYM happy_var_1) )} -happyReduce_502 = happySpecReduce_1 181# happyReduction_502 -happyReduction_502 happy_x_1 - = case happyOut190 happy_x_1 of { happy_var_1 -> - happyIn189 +happyReduce_509 = happySpecReduce_1 183# happyReduction_509 +happyReduction_509 happy_x_1 + = case happyOut192 happy_x_1 of { happy_var_1 -> + happyIn191 (happy_var_1 )} -happyReduce_503 = happySpecReduce_1 182# happyReduction_503 -happyReduction_503 happy_x_1 +happyReduce_510 = happySpecReduce_1 184# happyReduction_510 +happyReduction_510 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn190 + happyIn192 (sL (getLoc happy_var_1) $! mkUnqual tcClsName (getCONSYM happy_var_1) )} -happyReduce_504 = happySpecReduce_1 183# happyReduction_504 -happyReduction_504 happy_x_1 - = case happyOut192 happy_x_1 of { happy_var_1 -> - happyIn191 +happyReduce_511 = happySpecReduce_1 185# happyReduction_511 +happyReduction_511 happy_x_1 + = case happyOut194 happy_x_1 of { happy_var_1 -> + happyIn193 (happy_var_1 )} -happyReduce_505 = happySpecReduce_1 183# happyReduction_505 -happyReduction_505 happy_x_1 - = case happyOut182 happy_x_1 of { happy_var_1 -> - happyIn191 +happyReduce_512 = happySpecReduce_1 185# happyReduction_512 +happyReduction_512 happy_x_1 + = case happyOut184 happy_x_1 of { happy_var_1 -> + happyIn193 (happy_var_1 )} -happyReduce_506 = happySpecReduce_1 184# happyReduction_506 -happyReduction_506 happy_x_1 - = case happyOut208 happy_x_1 of { happy_var_1 -> - happyIn192 +happyReduce_513 = happySpecReduce_1 186# happyReduction_513 +happyReduction_513 happy_x_1 + = case happyOut210 happy_x_1 of { happy_var_1 -> + happyIn194 (happy_var_1 )} -happyReduce_507 = happySpecReduce_3 184# happyReduction_507 -happyReduction_507 happy_x_3 +happyReduce_514 = happySpecReduce_3 186# happyReduction_514 +happyReduction_514 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut204 happy_x_2 of { happy_var_2 -> + case happyOut206 happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn192 + happyIn194 (sL (comb2 happy_var_1 happy_var_3) (unLoc happy_var_2) )}}} -happyReduce_508 = happySpecReduce_1 185# happyReduction_508 -happyReduction_508 happy_x_1 - = case happyOut195 happy_x_1 of { happy_var_1 -> - happyIn193 +happyReduce_515 = happySpecReduce_1 187# happyReduction_515 +happyReduction_515 happy_x_1 + = case happyOut197 happy_x_1 of { happy_var_1 -> + happyIn195 (sL (getLoc happy_var_1) $ HsVar (unLoc happy_var_1) )} -happyReduce_509 = happySpecReduce_1 185# happyReduction_509 -happyReduction_509 happy_x_1 - = case happyOut183 happy_x_1 of { happy_var_1 -> - happyIn193 +happyReduce_516 = happySpecReduce_1 187# happyReduction_516 +happyReduction_516 happy_x_1 + = case happyOut185 happy_x_1 of { happy_var_1 -> + happyIn195 (sL (getLoc happy_var_1) $ HsVar (unLoc happy_var_1) )} -happyReduce_510 = happySpecReduce_1 186# happyReduction_510 -happyReduction_510 happy_x_1 - = case happyOut196 happy_x_1 of { happy_var_1 -> - happyIn194 +happyReduce_517 = happySpecReduce_1 188# happyReduction_517 +happyReduction_517 happy_x_1 + = case happyOut198 happy_x_1 of { happy_var_1 -> + happyIn196 (sL (getLoc happy_var_1) $ HsVar (unLoc happy_var_1) )} -happyReduce_511 = happySpecReduce_1 186# happyReduction_511 -happyReduction_511 happy_x_1 - = case happyOut183 happy_x_1 of { happy_var_1 -> - happyIn194 +happyReduce_518 = happySpecReduce_1 188# happyReduction_518 +happyReduction_518 happy_x_1 + = case happyOut185 happy_x_1 of { happy_var_1 -> + happyIn196 (sL (getLoc happy_var_1) $ HsVar (unLoc happy_var_1) )} -happyReduce_512 = happySpecReduce_1 187# happyReduction_512 -happyReduction_512 happy_x_1 - = case happyOut205 happy_x_1 of { happy_var_1 -> - happyIn195 +happyReduce_519 = happySpecReduce_1 189# happyReduction_519 +happyReduction_519 happy_x_1 + = case happyOut207 happy_x_1 of { happy_var_1 -> + happyIn197 (happy_var_1 )} -happyReduce_513 = happySpecReduce_3 187# happyReduction_513 -happyReduction_513 happy_x_3 +happyReduce_520 = happySpecReduce_3 189# happyReduction_520 +happyReduction_520 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut203 happy_x_2 of { happy_var_2 -> + case happyOut205 happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn195 + happyIn197 (sL (comb2 happy_var_1 happy_var_3) (unLoc happy_var_2) )}}} -happyReduce_514 = happySpecReduce_1 188# happyReduction_514 -happyReduction_514 happy_x_1 - = case happyOut206 happy_x_1 of { happy_var_1 -> - happyIn196 +happyReduce_521 = happySpecReduce_1 190# happyReduction_521 +happyReduction_521 happy_x_1 + = case happyOut208 happy_x_1 of { happy_var_1 -> + happyIn198 (happy_var_1 )} -happyReduce_515 = happySpecReduce_3 188# happyReduction_515 -happyReduction_515 happy_x_3 +happyReduce_522 = happySpecReduce_3 190# happyReduction_522 +happyReduction_522 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut203 happy_x_2 of { happy_var_2 -> + case happyOut205 happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn196 + happyIn198 (sL (comb2 happy_var_1 happy_var_3) (unLoc happy_var_2) )}}} -happyReduce_516 = happySpecReduce_1 189# happyReduction_516 -happyReduction_516 happy_x_1 - = case happyOut199 happy_x_1 of { happy_var_1 -> - happyIn197 +happyReduce_523 = happySpecReduce_1 191# happyReduction_523 +happyReduction_523 happy_x_1 + = case happyOut201 happy_x_1 of { happy_var_1 -> + happyIn199 (happy_var_1 )} -happyReduce_517 = happySpecReduce_3 189# happyReduction_517 -happyReduction_517 happy_x_3 +happyReduce_524 = happySpecReduce_3 191# happyReduction_524 +happyReduction_524 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut200 happy_x_2 of { happy_var_2 -> + case happyOut202 happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn197 + happyIn199 (sL (comb2 happy_var_1 happy_var_3) (unLoc happy_var_2) )}}} -happyReduce_518 = happySpecReduce_3 190# happyReduction_518 -happyReduction_518 happy_x_3 +happyReduce_525 = happySpecReduce_3 192# happyReduction_525 +happyReduction_525 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut199 happy_x_2 of { happy_var_2 -> + case happyOut201 happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn198 + happyIn200 (sL (comb2 happy_var_1 happy_var_3) (unLoc happy_var_2) )}}} -happyReduce_519 = happySpecReduce_1 190# happyReduction_519 -happyReduction_519 happy_x_1 - = case happyOut200 happy_x_1 of { happy_var_1 -> - happyIn198 +happyReduce_526 = happySpecReduce_1 192# happyReduction_526 +happyReduction_526 happy_x_1 + = case happyOut202 happy_x_1 of { happy_var_1 -> + happyIn200 (happy_var_1 )} -happyReduce_520 = happyMonadReduce 1# 190# happyReduction_520 -happyReduction_520 (happy_x_1 `HappyStk` +happyReduce_527 = happyMonadReduce 1# 192# happyReduction_527 +happyReduction_527 (happy_x_1 `HappyStk` happyRest) tk = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> ( parseErrorSDoc (getLoc happy_var_1) (vcat [ptext (sLit "Illegal symbol '.' in type"), ptext (sLit "Perhaps you intended -XRankNTypes or similar flag"), ptext (sLit "to enable explicit-forall syntax: forall . ")]))} - ) (\r -> happyReturn (happyIn198 r)) + ) (\r -> happyReturn (happyIn200 r)) -happyReduce_521 = happySpecReduce_1 191# happyReduction_521 -happyReduction_521 happy_x_1 +happyReduce_528 = happySpecReduce_1 193# happyReduction_528 +happyReduction_528 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn199 + happyIn201 (sL (getLoc happy_var_1) $! mkUnqual tvName (getVARID happy_var_1) )} -happyReduce_522 = happySpecReduce_1 191# happyReduction_522 -happyReduction_522 happy_x_1 - = case happyOut210 happy_x_1 of { happy_var_1 -> - happyIn199 +happyReduce_529 = happySpecReduce_1 193# happyReduction_529 +happyReduction_529 happy_x_1 + = case happyOut212 happy_x_1 of { happy_var_1 -> + happyIn201 (sL (getLoc happy_var_1) $! mkUnqual tvName (unLoc happy_var_1) )} -happyReduce_523 = happySpecReduce_1 191# happyReduction_523 -happyReduction_523 happy_x_1 +happyReduce_530 = happySpecReduce_1 193# happyReduction_530 +happyReduction_530 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn199 + happyIn201 (sL (getLoc happy_var_1) $! mkUnqual tvName (fsLit "unsafe") )} -happyReduce_524 = happySpecReduce_1 191# happyReduction_524 -happyReduction_524 happy_x_1 +happyReduce_531 = happySpecReduce_1 193# happyReduction_531 +happyReduction_531 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn199 + happyIn201 (sL (getLoc happy_var_1) $! mkUnqual tvName (fsLit "safe") )} -happyReduce_525 = happySpecReduce_1 191# happyReduction_525 -happyReduction_525 happy_x_1 +happyReduce_532 = happySpecReduce_1 193# happyReduction_532 +happyReduction_532 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn199 - (sL (getLoc happy_var_1) $! mkUnqual tvName (fsLit "threadsafe") + happyIn201 + (sL (getLoc happy_var_1) $! mkUnqual tvName (fsLit "interruptible") )} -happyReduce_526 = happySpecReduce_1 192# happyReduction_526 -happyReduction_526 happy_x_1 +happyReduce_533 = happySpecReduce_1 194# happyReduction_533 +happyReduction_533 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn200 + happyIn202 (sL (getLoc happy_var_1) $! mkUnqual tvName (getVARSYM happy_var_1) )} -happyReduce_527 = happySpecReduce_1 193# happyReduction_527 -happyReduction_527 happy_x_1 - = case happyOut204 happy_x_1 of { happy_var_1 -> - happyIn201 +happyReduce_534 = happySpecReduce_1 195# happyReduction_534 +happyReduction_534 happy_x_1 + = case happyOut206 happy_x_1 of { happy_var_1 -> + happyIn203 (happy_var_1 )} -happyReduce_528 = happySpecReduce_3 193# happyReduction_528 -happyReduction_528 happy_x_3 +happyReduce_535 = happySpecReduce_3 195# happyReduction_535 +happyReduction_535 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut208 happy_x_2 of { happy_var_2 -> + case happyOut210 happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn201 + happyIn203 (sL (comb2 happy_var_1 happy_var_3) (unLoc happy_var_2) )}}} -happyReduce_529 = happySpecReduce_1 194# happyReduction_529 -happyReduction_529 happy_x_1 - = case happyOut203 happy_x_1 of { happy_var_1 -> - happyIn202 +happyReduce_536 = happySpecReduce_1 196# happyReduction_536 +happyReduction_536 happy_x_1 + = case happyOut205 happy_x_1 of { happy_var_1 -> + happyIn204 (happy_var_1 )} -happyReduce_530 = happySpecReduce_3 194# happyReduction_530 -happyReduction_530 happy_x_3 +happyReduce_537 = happySpecReduce_3 196# happyReduction_537 +happyReduction_537 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut208 happy_x_2 of { happy_var_2 -> + case happyOut210 happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn202 + happyIn204 (sL (comb2 happy_var_1 happy_var_3) (unLoc happy_var_2) )}}} -happyReduce_531 = happySpecReduce_3 194# happyReduction_531 -happyReduction_531 happy_x_3 +happyReduce_538 = happySpecReduce_3 196# happyReduction_538 +happyReduction_538 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - case happyOut207 happy_x_2 of { happy_var_2 -> + case happyOut209 happy_x_2 of { happy_var_2 -> case happyOutTok happy_x_3 of { happy_var_3 -> - happyIn202 + happyIn204 (sL (comb2 happy_var_1 happy_var_3) (unLoc happy_var_2) )}}} -happyReduce_532 = happySpecReduce_1 195# happyReduction_532 -happyReduction_532 happy_x_1 - = case happyOut204 happy_x_1 of { happy_var_1 -> - happyIn203 +happyReduce_539 = happySpecReduce_1 197# happyReduction_539 +happyReduction_539 happy_x_1 + = case happyOut206 happy_x_1 of { happy_var_1 -> + happyIn205 (happy_var_1 )} -happyReduce_533 = happySpecReduce_1 195# happyReduction_533 -happyReduction_533 happy_x_1 +happyReduce_540 = happySpecReduce_1 197# happyReduction_540 +happyReduction_540 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn203 + happyIn205 (sL (getLoc happy_var_1) $! mkQual varName (getQVARID happy_var_1) )} -happyReduce_534 = happySpecReduce_1 195# happyReduction_534 -happyReduction_534 happy_x_1 +happyReduce_541 = happySpecReduce_1 197# happyReduction_541 +happyReduction_541 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn203 + happyIn205 (sL (getLoc happy_var_1) $! mkQual varName (getPREFIXQVARSYM happy_var_1) )} -happyReduce_535 = happySpecReduce_1 196# happyReduction_535 -happyReduction_535 happy_x_1 +happyReduce_542 = happySpecReduce_1 198# happyReduction_542 +happyReduction_542 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn204 + happyIn206 (sL (getLoc happy_var_1) $! mkUnqual varName (getVARID happy_var_1) )} -happyReduce_536 = happySpecReduce_1 196# happyReduction_536 -happyReduction_536 happy_x_1 - = case happyOut210 happy_x_1 of { happy_var_1 -> - happyIn204 +happyReduce_543 = happySpecReduce_1 198# happyReduction_543 +happyReduction_543 happy_x_1 + = case happyOut212 happy_x_1 of { happy_var_1 -> + happyIn206 (sL (getLoc happy_var_1) $! mkUnqual varName (unLoc happy_var_1) )} -happyReduce_537 = happySpecReduce_1 196# happyReduction_537 -happyReduction_537 happy_x_1 +happyReduce_544 = happySpecReduce_1 198# happyReduction_544 +happyReduction_544 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn204 + happyIn206 (sL (getLoc happy_var_1) $! mkUnqual varName (fsLit "unsafe") )} -happyReduce_538 = happySpecReduce_1 196# happyReduction_538 -happyReduction_538 happy_x_1 +happyReduce_545 = happySpecReduce_1 198# happyReduction_545 +happyReduction_545 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn204 + happyIn206 (sL (getLoc happy_var_1) $! mkUnqual varName (fsLit "safe") )} -happyReduce_539 = happySpecReduce_1 196# happyReduction_539 -happyReduction_539 happy_x_1 +happyReduce_546 = happySpecReduce_1 198# happyReduction_546 +happyReduction_546 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn204 - (sL (getLoc happy_var_1) $! mkUnqual varName (fsLit "threadsafe") + happyIn206 + (sL (getLoc happy_var_1) $! mkUnqual varName (fsLit "interruptible") )} -happyReduce_540 = happySpecReduce_1 196# happyReduction_540 -happyReduction_540 happy_x_1 +happyReduce_547 = happySpecReduce_1 198# happyReduction_547 +happyReduction_547 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn204 + happyIn206 (sL (getLoc happy_var_1) $! mkUnqual varName (fsLit "forall") )} -happyReduce_541 = happySpecReduce_1 196# happyReduction_541 -happyReduction_541 happy_x_1 +happyReduce_548 = happySpecReduce_1 198# happyReduction_548 +happyReduction_548 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn204 + happyIn206 (sL (getLoc happy_var_1) $! mkUnqual varName (fsLit "family") )} -happyReduce_542 = happySpecReduce_1 197# happyReduction_542 -happyReduction_542 happy_x_1 - = case happyOut208 happy_x_1 of { happy_var_1 -> - happyIn205 +happyReduce_549 = happySpecReduce_1 199# happyReduction_549 +happyReduction_549 happy_x_1 + = case happyOut210 happy_x_1 of { happy_var_1 -> + happyIn207 (happy_var_1 )} -happyReduce_543 = happySpecReduce_1 197# happyReduction_543 -happyReduction_543 happy_x_1 - = case happyOut207 happy_x_1 of { happy_var_1 -> - happyIn205 +happyReduce_550 = happySpecReduce_1 199# happyReduction_550 +happyReduction_550 happy_x_1 + = case happyOut209 happy_x_1 of { happy_var_1 -> + happyIn207 (happy_var_1 )} -happyReduce_544 = happySpecReduce_1 198# happyReduction_544 -happyReduction_544 happy_x_1 - = case happyOut209 happy_x_1 of { happy_var_1 -> - happyIn206 +happyReduce_551 = happySpecReduce_1 200# happyReduction_551 +happyReduction_551 happy_x_1 + = case happyOut211 happy_x_1 of { happy_var_1 -> + happyIn208 (happy_var_1 )} -happyReduce_545 = happySpecReduce_1 198# happyReduction_545 -happyReduction_545 happy_x_1 - = case happyOut207 happy_x_1 of { happy_var_1 -> - happyIn206 +happyReduce_552 = happySpecReduce_1 200# happyReduction_552 +happyReduction_552 happy_x_1 + = case happyOut209 happy_x_1 of { happy_var_1 -> + happyIn208 (happy_var_1 )} -happyReduce_546 = happySpecReduce_1 199# happyReduction_546 -happyReduction_546 happy_x_1 +happyReduce_553 = happySpecReduce_1 201# happyReduction_553 +happyReduction_553 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn207 + happyIn209 (sL (getLoc happy_var_1) $ mkQual varName (getQVARSYM happy_var_1) )} -happyReduce_547 = happySpecReduce_1 200# happyReduction_547 -happyReduction_547 happy_x_1 - = case happyOut209 happy_x_1 of { happy_var_1 -> - happyIn208 +happyReduce_554 = happySpecReduce_1 202# happyReduction_554 +happyReduction_554 happy_x_1 + = case happyOut211 happy_x_1 of { happy_var_1 -> + happyIn210 (happy_var_1 )} -happyReduce_548 = happySpecReduce_1 200# happyReduction_548 -happyReduction_548 happy_x_1 +happyReduce_555 = happySpecReduce_1 202# happyReduction_555 +happyReduction_555 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn208 + happyIn210 (sL (getLoc happy_var_1) $ mkUnqual varName (fsLit "-") )} -happyReduce_549 = happySpecReduce_1 201# happyReduction_549 -happyReduction_549 happy_x_1 +happyReduce_556 = happySpecReduce_1 203# happyReduction_556 +happyReduction_556 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn209 + happyIn211 (sL (getLoc happy_var_1) $ mkUnqual varName (getVARSYM happy_var_1) )} -happyReduce_550 = happySpecReduce_1 201# happyReduction_550 -happyReduction_550 happy_x_1 - = case happyOut211 happy_x_1 of { happy_var_1 -> - happyIn209 +happyReduce_557 = happySpecReduce_1 203# happyReduction_557 +happyReduction_557 happy_x_1 + = case happyOut213 happy_x_1 of { happy_var_1 -> + happyIn211 (sL (getLoc happy_var_1) $ mkUnqual varName (unLoc happy_var_1) )} -happyReduce_551 = happySpecReduce_1 202# happyReduction_551 -happyReduction_551 happy_x_1 +happyReduce_558 = happySpecReduce_1 204# happyReduction_558 +happyReduction_558 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn210 + happyIn212 (sL (getLoc happy_var_1) (fsLit "as") )} -happyReduce_552 = happySpecReduce_1 202# happyReduction_552 -happyReduction_552 happy_x_1 +happyReduce_559 = happySpecReduce_1 204# happyReduction_559 +happyReduction_559 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn210 + happyIn212 (sL (getLoc happy_var_1) (fsLit "qualified") )} -happyReduce_553 = happySpecReduce_1 202# happyReduction_553 -happyReduction_553 happy_x_1 +happyReduce_560 = happySpecReduce_1 204# happyReduction_560 +happyReduction_560 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn210 + happyIn212 (sL (getLoc happy_var_1) (fsLit "hiding") )} -happyReduce_554 = happySpecReduce_1 202# happyReduction_554 -happyReduction_554 happy_x_1 +happyReduce_561 = happySpecReduce_1 204# happyReduction_561 +happyReduction_561 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn210 + happyIn212 (sL (getLoc happy_var_1) (fsLit "export") )} -happyReduce_555 = happySpecReduce_1 202# happyReduction_555 -happyReduction_555 happy_x_1 +happyReduce_562 = happySpecReduce_1 204# happyReduction_562 +happyReduction_562 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn210 + happyIn212 (sL (getLoc happy_var_1) (fsLit "label") )} -happyReduce_556 = happySpecReduce_1 202# happyReduction_556 -happyReduction_556 happy_x_1 +happyReduce_563 = happySpecReduce_1 204# happyReduction_563 +happyReduction_563 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn210 + happyIn212 (sL (getLoc happy_var_1) (fsLit "dynamic") )} -happyReduce_557 = happySpecReduce_1 202# happyReduction_557 -happyReduction_557 happy_x_1 +happyReduce_564 = happySpecReduce_1 204# happyReduction_564 +happyReduction_564 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn210 + happyIn212 (sL (getLoc happy_var_1) (fsLit "stdcall") )} -happyReduce_558 = happySpecReduce_1 202# happyReduction_558 -happyReduction_558 happy_x_1 +happyReduce_565 = happySpecReduce_1 204# happyReduction_565 +happyReduction_565 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn210 + happyIn212 (sL (getLoc happy_var_1) (fsLit "ccall") )} -happyReduce_559 = happySpecReduce_1 202# happyReduction_559 -happyReduction_559 happy_x_1 +happyReduce_566 = happySpecReduce_1 204# happyReduction_566 +happyReduction_566 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn210 + happyIn212 (sL (getLoc happy_var_1) (fsLit "prim") )} -happyReduce_560 = happySpecReduce_1 202# happyReduction_560 -happyReduction_560 happy_x_1 +happyReduce_567 = happySpecReduce_1 204# happyReduction_567 +happyReduction_567 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn210 + happyIn212 (sL (getLoc happy_var_1) (fsLit "group") )} -happyReduce_561 = happySpecReduce_1 203# happyReduction_561 -happyReduction_561 happy_x_1 +happyReduce_568 = happySpecReduce_1 205# happyReduction_568 +happyReduction_568 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn211 + happyIn213 (sL (getLoc happy_var_1) (fsLit "!") )} -happyReduce_562 = happySpecReduce_1 203# happyReduction_562 -happyReduction_562 happy_x_1 +happyReduce_569 = happySpecReduce_1 205# happyReduction_569 +happyReduction_569 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn211 + happyIn213 (sL (getLoc happy_var_1) (fsLit ".") )} -happyReduce_563 = happySpecReduce_1 203# happyReduction_563 -happyReduction_563 happy_x_1 +happyReduce_570 = happySpecReduce_1 205# happyReduction_570 +happyReduction_570 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn211 + happyIn213 (sL (getLoc happy_var_1) (fsLit "*") )} -happyReduce_564 = happySpecReduce_1 204# happyReduction_564 -happyReduction_564 happy_x_1 - = case happyOut213 happy_x_1 of { happy_var_1 -> - happyIn212 +happyReduce_571 = happySpecReduce_1 206# happyReduction_571 +happyReduction_571 happy_x_1 + = case happyOut215 happy_x_1 of { happy_var_1 -> + happyIn214 (happy_var_1 )} -happyReduce_565 = happySpecReduce_1 204# happyReduction_565 -happyReduction_565 happy_x_1 +happyReduce_572 = happySpecReduce_1 206# happyReduction_572 +happyReduction_572 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn212 + happyIn214 (sL (getLoc happy_var_1) $! mkQual dataName (getQCONID happy_var_1) )} -happyReduce_566 = happySpecReduce_1 204# happyReduction_566 -happyReduction_566 happy_x_1 +happyReduce_573 = happySpecReduce_1 206# happyReduction_573 +happyReduction_573 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn212 + happyIn214 (sL (getLoc happy_var_1) $! mkQual dataName (getPREFIXQCONSYM happy_var_1) )} -happyReduce_567 = happySpecReduce_1 205# happyReduction_567 -happyReduction_567 happy_x_1 +happyReduce_574 = happySpecReduce_1 207# happyReduction_574 +happyReduction_574 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn213 + happyIn215 (sL (getLoc happy_var_1) $ mkUnqual dataName (getCONID happy_var_1) )} -happyReduce_568 = happySpecReduce_1 206# happyReduction_568 -happyReduction_568 happy_x_1 - = case happyOut215 happy_x_1 of { happy_var_1 -> - happyIn214 +happyReduce_575 = happySpecReduce_1 208# happyReduction_575 +happyReduction_575 happy_x_1 + = case happyOut217 happy_x_1 of { happy_var_1 -> + happyIn216 (happy_var_1 )} -happyReduce_569 = happySpecReduce_1 206# happyReduction_569 -happyReduction_569 happy_x_1 +happyReduce_576 = happySpecReduce_1 208# happyReduction_576 +happyReduction_576 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn214 + happyIn216 (sL (getLoc happy_var_1) $ mkQual dataName (getQCONSYM happy_var_1) )} -happyReduce_570 = happySpecReduce_1 207# happyReduction_570 -happyReduction_570 happy_x_1 +happyReduce_577 = happySpecReduce_1 209# happyReduction_577 +happyReduction_577 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn215 + happyIn217 (sL (getLoc happy_var_1) $ mkUnqual dataName (getCONSYM happy_var_1) )} -happyReduce_571 = happySpecReduce_1 207# happyReduction_571 -happyReduction_571 happy_x_1 +happyReduce_578 = happySpecReduce_1 209# happyReduction_578 +happyReduction_578 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn215 + happyIn217 (sL (getLoc happy_var_1) $ consDataCon_RDR )} -happyReduce_572 = happySpecReduce_1 208# happyReduction_572 -happyReduction_572 happy_x_1 +happyReduce_579 = happySpecReduce_1 210# happyReduction_579 +happyReduction_579 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn216 + happyIn218 (sL (getLoc happy_var_1) $ HsChar $ getCHAR happy_var_1 )} -happyReduce_573 = happySpecReduce_1 208# happyReduction_573 -happyReduction_573 happy_x_1 +happyReduce_580 = happySpecReduce_1 210# happyReduction_580 +happyReduction_580 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn216 + happyIn218 (sL (getLoc happy_var_1) $ HsString $ getSTRING happy_var_1 )} -happyReduce_574 = happySpecReduce_1 208# happyReduction_574 -happyReduction_574 happy_x_1 +happyReduce_581 = happySpecReduce_1 210# happyReduction_581 +happyReduction_581 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn216 + happyIn218 (sL (getLoc happy_var_1) $ HsIntPrim $ getPRIMINTEGER happy_var_1 )} -happyReduce_575 = happySpecReduce_1 208# happyReduction_575 -happyReduction_575 happy_x_1 +happyReduce_582 = happySpecReduce_1 210# happyReduction_582 +happyReduction_582 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn216 + happyIn218 (sL (getLoc happy_var_1) $ HsWordPrim $ getPRIMWORD happy_var_1 )} -happyReduce_576 = happySpecReduce_1 208# happyReduction_576 -happyReduction_576 happy_x_1 +happyReduce_583 = happySpecReduce_1 210# happyReduction_583 +happyReduction_583 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn216 + happyIn218 (sL (getLoc happy_var_1) $ HsCharPrim $ getPRIMCHAR happy_var_1 )} -happyReduce_577 = happySpecReduce_1 208# happyReduction_577 -happyReduction_577 happy_x_1 +happyReduce_584 = happySpecReduce_1 210# happyReduction_584 +happyReduction_584 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn216 + happyIn218 (sL (getLoc happy_var_1) $ HsStringPrim $ getPRIMSTRING happy_var_1 )} -happyReduce_578 = happySpecReduce_1 208# happyReduction_578 -happyReduction_578 happy_x_1 +happyReduce_585 = happySpecReduce_1 210# happyReduction_585 +happyReduction_585 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn216 + happyIn218 (sL (getLoc happy_var_1) $ HsFloatPrim $ getPRIMFLOAT happy_var_1 )} -happyReduce_579 = happySpecReduce_1 208# happyReduction_579 -happyReduction_579 happy_x_1 +happyReduce_586 = happySpecReduce_1 210# happyReduction_586 +happyReduction_586 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn216 + happyIn218 (sL (getLoc happy_var_1) $ HsDoublePrim $ getPRIMDOUBLE happy_var_1 )} -happyReduce_580 = happySpecReduce_1 209# happyReduction_580 -happyReduction_580 happy_x_1 - = happyIn217 +happyReduce_587 = happySpecReduce_1 211# happyReduction_587 +happyReduction_587 happy_x_1 + = happyIn219 (() ) -happyReduce_581 = happyMonadReduce 1# 209# happyReduction_581 -happyReduction_581 (happy_x_1 `HappyStk` +happyReduce_588 = happyMonadReduce 1# 211# happyReduction_588 +happyReduction_588 (happy_x_1 `HappyStk` happyRest) tk = happyThen (( popContext) - ) (\r -> happyReturn (happyIn217 r)) + ) (\r -> happyReturn (happyIn219 r)) -happyReduce_582 = happySpecReduce_1 210# happyReduction_582 -happyReduction_582 happy_x_1 +happyReduce_589 = happySpecReduce_1 212# happyReduction_589 +happyReduction_589 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn218 + happyIn220 (sL (getLoc happy_var_1) $ mkModuleNameFS (getCONID happy_var_1) )} -happyReduce_583 = happySpecReduce_1 210# happyReduction_583 -happyReduction_583 happy_x_1 +happyReduce_590 = happySpecReduce_1 212# happyReduction_590 +happyReduction_590 happy_x_1 = case happyOutTok happy_x_1 of { happy_var_1 -> - happyIn218 + happyIn220 (sL (getLoc happy_var_1) $ let (mod,c) = getQCONID happy_var_1 in mkModuleNameFS (mkFastString (unpackFS mod ++ '.':unpackFS c)) )} -happyReduce_584 = happySpecReduce_2 211# happyReduction_584 -happyReduction_584 happy_x_2 +happyReduce_591 = happySpecReduce_2 213# happyReduction_591 +happyReduction_591 happy_x_2 happy_x_1 - = case happyOut219 happy_x_1 of { happy_var_1 -> - happyIn219 + = case happyOut221 happy_x_1 of { happy_var_1 -> + happyIn221 (happy_var_1 + 1 )} -happyReduce_585 = happySpecReduce_1 211# happyReduction_585 -happyReduction_585 happy_x_1 - = happyIn219 +happyReduce_592 = happySpecReduce_1 213# happyReduction_592 +happyReduction_592 happy_x_1 + = happyIn221 (1 ) -happyReduce_586 = happyMonadReduce 1# 212# happyReduction_586 -happyReduction_586 (happy_x_1 `HappyStk` +happyReduce_593 = happyMonadReduce 1# 214# happyReduction_593 +happyReduction_593 (happy_x_1 `HappyStk` happyRest) tk = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> ( return (sL (getLoc happy_var_1) (HsDocString (mkFastString (getDOCNEXT happy_var_1)))))} - ) (\r -> happyReturn (happyIn220 r)) + ) (\r -> happyReturn (happyIn222 r)) -happyReduce_587 = happyMonadReduce 1# 213# happyReduction_587 -happyReduction_587 (happy_x_1 `HappyStk` +happyReduce_594 = happyMonadReduce 1# 215# happyReduction_594 +happyReduction_594 (happy_x_1 `HappyStk` happyRest) tk = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> ( return (sL (getLoc happy_var_1) (HsDocString (mkFastString (getDOCPREV happy_var_1)))))} - ) (\r -> happyReturn (happyIn221 r)) + ) (\r -> happyReturn (happyIn223 r)) -happyReduce_588 = happyMonadReduce 1# 214# happyReduction_588 -happyReduction_588 (happy_x_1 `HappyStk` +happyReduce_595 = happyMonadReduce 1# 216# happyReduction_595 +happyReduction_595 (happy_x_1 `HappyStk` happyRest) tk = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> ( let string = getDOCNAMED happy_var_1 (name, rest) = break isSpace string in return (sL (getLoc happy_var_1) (name, HsDocString (mkFastString rest))))} - ) (\r -> happyReturn (happyIn222 r)) + ) (\r -> happyReturn (happyIn224 r)) -happyReduce_589 = happyMonadReduce 1# 215# happyReduction_589 -happyReduction_589 (happy_x_1 `HappyStk` +happyReduce_596 = happyMonadReduce 1# 217# happyReduction_596 +happyReduction_596 (happy_x_1 `HappyStk` happyRest) tk = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> ( let (n, doc) = getDOCSECTION happy_var_1 in return (sL (getLoc happy_var_1) (n, HsDocString (mkFastString doc))))} - ) (\r -> happyReturn (happyIn223 r)) + ) (\r -> happyReturn (happyIn225 r)) -happyReduce_590 = happyMonadReduce 1# 216# happyReduction_590 -happyReduction_590 (happy_x_1 `HappyStk` +happyReduce_597 = happyMonadReduce 1# 218# happyReduction_597 +happyReduction_597 (happy_x_1 `HappyStk` happyRest) tk = happyThen (case happyOutTok happy_x_1 of { happy_var_1 -> ( let string = getDOCNEXT happy_var_1 in return (Just (sL (getLoc happy_var_1) (HsDocString (mkFastString string)))))} - ) (\r -> happyReturn (happyIn224 r)) + ) (\r -> happyReturn (happyIn226 r)) -happyReduce_591 = happySpecReduce_1 217# happyReduction_591 -happyReduction_591 happy_x_1 - = case happyOut221 happy_x_1 of { happy_var_1 -> - happyIn225 +happyReduce_598 = happySpecReduce_1 219# happyReduction_598 +happyReduction_598 happy_x_1 + = case happyOut223 happy_x_1 of { happy_var_1 -> + happyIn227 (Just happy_var_1 )} -happyReduce_592 = happySpecReduce_0 217# happyReduction_592 -happyReduction_592 = happyIn225 +happyReduce_599 = happySpecReduce_0 219# happyReduction_599 +happyReduction_599 = happyIn227 (Nothing ) -happyReduce_593 = happySpecReduce_1 218# happyReduction_593 -happyReduction_593 happy_x_1 - = case happyOut220 happy_x_1 of { happy_var_1 -> - happyIn226 +happyReduce_600 = happySpecReduce_1 220# happyReduction_600 +happyReduction_600 happy_x_1 + = case happyOut222 happy_x_1 of { happy_var_1 -> + happyIn228 (Just happy_var_1 )} -happyReduce_594 = happySpecReduce_0 218# happyReduction_594 -happyReduction_594 = happyIn226 +happyReduce_601 = happySpecReduce_0 220# happyReduction_601 +happyReduction_601 = happyIn228 (Nothing ) @@ -7277,7 +7357,7 @@ = lexer(\tk -> let cont i = happyDoAction i tk action sts stk in case tk of { - L _ ITeof -> happyDoAction 131# tk action sts stk; + L _ ITeof -> happyDoAction 134# tk action sts stk; L _ ITunderscore -> cont 1#; L _ ITas -> cont 2#; L _ ITcase -> cont 3#; @@ -7310,7 +7390,7 @@ L _ ITlabel -> cont 30#; L _ ITdynamic -> cont 31#; L _ ITsafe -> cont 32#; - L _ ITthreadsafe -> cont 33#; + L _ ITinterruptible -> cont 33#; L _ ITunsafe -> cont 34#; L _ ITmdo -> cont 35#; L _ ITfamily -> cont 36#; @@ -7334,80 +7414,83 @@ L _ ITwarning_prag -> cont 54#; L _ ITunpack_prag -> cont 55#; L _ ITann_prag -> cont 56#; - L _ ITclose_prag -> cont 57#; - L _ ITdotdot -> cont 58#; - L _ ITcolon -> cont 59#; - L _ ITdcolon -> cont 60#; - L _ ITequal -> cont 61#; - L _ ITlam -> cont 62#; - L _ ITvbar -> cont 63#; - L _ ITlarrow -> cont 64#; - L _ ITrarrow -> cont 65#; - L _ ITat -> cont 66#; - L _ ITtilde -> cont 67#; - L _ ITdarrow -> cont 68#; - L _ ITminus -> cont 69#; - L _ ITbang -> cont 70#; - L _ ITstar -> cont 71#; - L _ ITlarrowtail -> cont 72#; - L _ ITrarrowtail -> cont 73#; - L _ ITLarrowtail -> cont 74#; - L _ ITRarrowtail -> cont 75#; - L _ ITdot -> cont 76#; - L _ ITocurly -> cont 77#; - L _ ITccurly -> cont 78#; - L _ ITocurlybar -> cont 79#; - L _ ITccurlybar -> cont 80#; - L _ ITvocurly -> cont 81#; - L _ ITvccurly -> cont 82#; - L _ ITobrack -> cont 83#; - L _ ITcbrack -> cont 84#; - L _ ITopabrack -> cont 85#; - L _ ITcpabrack -> cont 86#; - L _ IToparen -> cont 87#; - L _ ITcparen -> cont 88#; - L _ IToubxparen -> cont 89#; - L _ ITcubxparen -> cont 90#; - L _ IToparenbar -> cont 91#; - L _ ITcparenbar -> cont 92#; - L _ ITsemi -> cont 93#; - L _ ITcomma -> cont 94#; - L _ ITbackquote -> cont 95#; - L _ (ITvarid _) -> cont 96#; - L _ (ITconid _) -> cont 97#; - L _ (ITvarsym _) -> cont 98#; - L _ (ITconsym _) -> cont 99#; - L _ (ITqvarid _) -> cont 100#; - L _ (ITqconid _) -> cont 101#; - L _ (ITqvarsym _) -> cont 102#; - L _ (ITqconsym _) -> cont 103#; - L _ (ITprefixqvarsym _) -> cont 104#; - L _ (ITprefixqconsym _) -> cont 105#; - L _ (ITdupipvarid _) -> cont 106#; - L _ (ITchar _) -> cont 107#; - L _ (ITstring _) -> cont 108#; - L _ (ITinteger _) -> cont 109#; - L _ (ITrational _) -> cont 110#; - L _ (ITprimchar _) -> cont 111#; - L _ (ITprimstring _) -> cont 112#; - L _ (ITprimint _) -> cont 113#; - L _ (ITprimword _) -> cont 114#; - L _ (ITprimfloat _) -> cont 115#; - L _ (ITprimdouble _) -> cont 116#; - L _ (ITdocCommentNext _) -> cont 117#; - L _ (ITdocCommentPrev _) -> cont 118#; - L _ (ITdocCommentNamed _) -> cont 119#; - L _ (ITdocSection _ _) -> cont 120#; - L _ ITopenExpQuote -> cont 121#; - L _ ITopenPatQuote -> cont 122#; - L _ ITopenTypQuote -> cont 123#; - L _ ITopenDecQuote -> cont 124#; - L _ ITcloseQuote -> cont 125#; - L _ (ITidEscape _) -> cont 126#; - L _ ITparenEscape -> cont 127#; - L _ ITvarQuote -> cont 128#; - L _ ITtyQuote -> cont 129#; - L _ (ITquasiQuote _) -> cont 130#; + L _ ITvect_prag -> cont 57#; + L _ ITvect_scalar_prag -> cont 58#; + L _ ITnovect_prag -> cont 59#; + L _ ITclose_prag -> cont 60#; + L _ ITdotdot -> cont 61#; + L _ ITcolon -> cont 62#; + L _ ITdcolon -> cont 63#; + L _ ITequal -> cont 64#; + L _ ITlam -> cont 65#; + L _ ITvbar -> cont 66#; + L _ ITlarrow -> cont 67#; + L _ ITrarrow -> cont 68#; + L _ ITat -> cont 69#; + L _ ITtilde -> cont 70#; + L _ ITdarrow -> cont 71#; + L _ ITminus -> cont 72#; + L _ ITbang -> cont 73#; + L _ ITstar -> cont 74#; + L _ ITlarrowtail -> cont 75#; + L _ ITrarrowtail -> cont 76#; + L _ ITLarrowtail -> cont 77#; + L _ ITRarrowtail -> cont 78#; + L _ ITdot -> cont 79#; + L _ ITocurly -> cont 80#; + L _ ITccurly -> cont 81#; + L _ ITocurlybar -> cont 82#; + L _ ITccurlybar -> cont 83#; + L _ ITvocurly -> cont 84#; + L _ ITvccurly -> cont 85#; + L _ ITobrack -> cont 86#; + L _ ITcbrack -> cont 87#; + L _ ITopabrack -> cont 88#; + L _ ITcpabrack -> cont 89#; + L _ IToparen -> cont 90#; + L _ ITcparen -> cont 91#; + L _ IToubxparen -> cont 92#; + L _ ITcubxparen -> cont 93#; + L _ IToparenbar -> cont 94#; + L _ ITcparenbar -> cont 95#; + L _ ITsemi -> cont 96#; + L _ ITcomma -> cont 97#; + L _ ITbackquote -> cont 98#; + L _ (ITvarid _) -> cont 99#; + L _ (ITconid _) -> cont 100#; + L _ (ITvarsym _) -> cont 101#; + L _ (ITconsym _) -> cont 102#; + L _ (ITqvarid _) -> cont 103#; + L _ (ITqconid _) -> cont 104#; + L _ (ITqvarsym _) -> cont 105#; + L _ (ITqconsym _) -> cont 106#; + L _ (ITprefixqvarsym _) -> cont 107#; + L _ (ITprefixqconsym _) -> cont 108#; + L _ (ITdupipvarid _) -> cont 109#; + L _ (ITchar _) -> cont 110#; + L _ (ITstring _) -> cont 111#; + L _ (ITinteger _) -> cont 112#; + L _ (ITrational _) -> cont 113#; + L _ (ITprimchar _) -> cont 114#; + L _ (ITprimstring _) -> cont 115#; + L _ (ITprimint _) -> cont 116#; + L _ (ITprimword _) -> cont 117#; + L _ (ITprimfloat _) -> cont 118#; + L _ (ITprimdouble _) -> cont 119#; + L _ (ITdocCommentNext _) -> cont 120#; + L _ (ITdocCommentPrev _) -> cont 121#; + L _ (ITdocCommentNamed _) -> cont 122#; + L _ (ITdocSection _ _) -> cont 123#; + L _ ITopenExpQuote -> cont 124#; + L _ ITopenPatQuote -> cont 125#; + L _ ITopenTypQuote -> cont 126#; + L _ ITopenDecQuote -> cont 127#; + L _ ITcloseQuote -> cont 128#; + L _ (ITidEscape _) -> cont 129#; + L _ ITparenEscape -> cont 130#; + L _ ITvarQuote -> cont 131#; + L _ ITtyQuote -> cont 132#; + L _ (ITquasiQuote _) -> cont 133#; _ -> happyError' tk }) @@ -7427,13 +7510,13 @@ happySomeParser = happyThen (happyParse 0#) (\x -> happyReturn (happyOut9 x)) parseStmt = happySomeParser where - happySomeParser = happyThen (happyParse 1#) (\x -> happyReturn (happyOut167 x)) + happySomeParser = happyThen (happyParse 1#) (\x -> happyReturn (happyOut169 x)) parseIdentifier = happySomeParser where happySomeParser = happyThen (happyParse 2#) (\x -> happyReturn (happyOut8 x)) parseType = happySomeParser where - happySomeParser = happyThen (happyParse 3#) (\x -> happyReturn (happyOut87 x)) + happySomeParser = happyThen (happyParse 3#) (\x -> happyReturn (happyOut89 x)) parseHeader = happySomeParser where happySomeParser = happyThen (happyParse 4#) (\x -> happyReturn (happyOut17 x)) diff -Nru ghc-7.0.3/compiler/parser/Parser.y.pp.source ghc-7.2.1/compiler/parser/Parser.y.pp.source --- ghc-7.0.3/compiler/parser/Parser.y.pp.source 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/parser/Parser.y.pp.source 2011-08-07 17:10:05.000000000 +0000 @@ -8,15 +8,8 @@ -- --------------------------------------------------------------------------- { -{-# OPTIONS -Wwarn -w -XNoMonomorphismRestriction #-} --- The NoMonomorphismRestriction deals with a Happy infelicity --- With OutsideIn's more conservativ monomorphism restriction --- we aren't generalising --- notHappyAtAll = error "urk" --- which is terrible. Switching off the restriction allows --- the generalisation. Better would be to make Happy generate --- an appropriate signature. - +{-# LANGUAGE BangPatterns #-} -- required for versions of Happy before 1.18.6 +{-# OPTIONS -Wwarn -w #-} -- 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 @@ -48,9 +41,7 @@ ) import OccName ( varName, dataName, tcClsName, tvName ) import DataCon ( DataCon, dataConName ) -import SrcLoc ( Located(..), unLoc, getLoc, noLoc, combineSrcSpans, - SrcSpan, combineLocs, srcLocFile, - mkSrcLoc, mkSrcSpan ) +import SrcLoc import Module import StaticFlags ( opt_SccProfilingOn, opt_Hpc ) import Type ( Kind, liftedTypeKind, unliftedTypeKind ) @@ -247,7 +238,7 @@ 'label' { L _ ITlabel } 'dynamic' { L _ ITdynamic } 'safe' { L _ ITsafe } - 'threadsafe' { L _ ITthreadsafe } -- ToDo: remove deprecated alias + 'interruptible' { L _ ITinterruptible } 'unsafe' { L _ ITunsafe } 'mdo' { L _ ITmdo } 'family' { L _ ITfamily } @@ -260,19 +251,22 @@ 'by' { L _ ITby } -- for list transform extension 'using' { L _ ITusing } -- for list transform extension - '{-# INLINE' { L _ (ITinline_prag _ _) } - '{-# SPECIALISE' { L _ ITspec_prag } + '{-# INLINE' { L _ (ITinline_prag _ _) } + '{-# SPECIALISE' { L _ ITspec_prag } '{-# SPECIALISE_INLINE' { L _ (ITspec_inline_prag _) } - '{-# SOURCE' { L _ ITsource_prag } - '{-# RULES' { L _ ITrules_prag } - '{-# CORE' { L _ ITcore_prag } -- hdaume: annotated core - '{-# SCC' { L _ ITscc_prag } - '{-# GENERATED' { L _ ITgenerated_prag } - '{-# DEPRECATED' { L _ ITdeprecated_prag } - '{-# WARNING' { L _ ITwarning_prag } - '{-# UNPACK' { L _ ITunpack_prag } - '{-# ANN' { L _ ITann_prag } - '#-}' { L _ ITclose_prag } + '{-# SOURCE' { L _ ITsource_prag } + '{-# RULES' { L _ ITrules_prag } + '{-# CORE' { L _ ITcore_prag } -- hdaume: annotated core + '{-# SCC' { L _ ITscc_prag } + '{-# GENERATED' { L _ ITgenerated_prag } + '{-# DEPRECATED' { L _ ITdeprecated_prag } + '{-# WARNING' { L _ ITwarning_prag } + '{-# UNPACK' { L _ ITunpack_prag } + '{-# ANN' { L _ ITann_prag } + '{-# VECTORISE' { L _ ITvect_prag } + '{-# VECTORISE_SCALAR' { L _ ITvect_scalar_prag } + '{-# NOVECTORISE' { L _ ITnovect_prag } + '#-}' { L _ ITclose_prag } '..' { L _ ITdotdot } -- reserved symbols ':' { L _ ITcolon } @@ -432,14 +426,18 @@ {% fileSrcSpan >>= \ loc -> return (L loc (HsModule (Just $3) $5 $7 [] $4 $1 ))} - | missing_module_keyword importdecls + | header_body2 {% fileSrcSpan >>= \ loc -> - return (L loc (HsModule Nothing Nothing $2 [] Nothing + return (L loc (HsModule Nothing Nothing $1 [] Nothing Nothing)) } header_body :: { [LImportDecl RdrName] } : '{' importdecls { $2 } - | vocurly importdecls { $2 } + | vocurly importdecls { $2 } + +header_body2 :: { [LImportDecl RdrName] } + : '{' importdecls { $2 } + | missing_module_keyword importdecls { $2 } ----------------------------------------------------------------------------- -- The Export List @@ -505,13 +503,17 @@ | {- empty -} { [] } importdecl :: { LImportDecl RdrName } - : 'import' maybe_src optqualified maybe_pkg modid maybeas maybeimpspec - { L (comb4 $1 $5 $6 $7) (ImportDecl $5 $4 $2 $3 (unLoc $6) (unLoc $7)) } + : 'import' maybe_src maybe_safe optqualified maybe_pkg modid maybeas maybeimpspec + { L (comb4 $1 $6 $7 $8) (ImportDecl $6 $5 $2 $3 $4 (unLoc $7) (unLoc $8)) } maybe_src :: { IsBootInterface } : '{-# SOURCE' '#-}' { True } | {- empty -} { False } +maybe_safe :: { Bool } + : 'safe' { True } + | {- empty -} { False } + maybe_pkg :: { Maybe FastString } : STRING { Just (getSTRING $1) } | {- empty -} { Nothing } @@ -552,31 +554,34 @@ -- Top-Level Declarations topdecls :: { OrdList (LHsDecl RdrName) } - : topdecls ';' topdecl { $1 `appOL` $3 } - | topdecls ';' { $1 } - | topdecl { $1 } + : topdecls ';' topdecl { $1 `appOL` $3 } + | topdecls ';' { $1 } + | topdecl { $1 } topdecl :: { OrdList (LHsDecl RdrName) } - : cl_decl { unitOL (L1 (TyClD (unLoc $1))) } - | ty_decl { unitOL (L1 (TyClD (unLoc $1))) } - | 'instance' inst_type where_inst - { let (binds, sigs, ats, _) = cvBindsAndSigs (unLoc $3) - in - unitOL (L (comb3 $1 $2 $3) (InstD (InstDecl $2 binds sigs ats)))} + : cl_decl { unitOL (L1 (TyClD (unLoc $1))) } + | ty_decl { unitOL (L1 (TyClD (unLoc $1))) } + | 'instance' inst_type where_inst + { let (binds, sigs, ats, _) = cvBindsAndSigs (unLoc $3) + in + unitOL (L (comb3 $1 $2 $3) (InstD (InstDecl $2 binds sigs ats)))} | stand_alone_deriving { unitOL (LL (DerivD (unLoc $1))) } - | 'default' '(' comma_types0 ')' { unitOL (LL $ DefD (DefaultDecl $3)) } - | 'foreign' fdecl { unitOL (LL (unLoc $2)) } + | 'default' '(' comma_types0 ')' { unitOL (LL $ DefD (DefaultDecl $3)) } + | 'foreign' fdecl { unitOL (LL (unLoc $2)) } | '{-# DEPRECATED' deprecations '#-}' { $2 } | '{-# WARNING' warnings '#-}' { $2 } - | '{-# RULES' rules '#-}' { $2 } - | annotation { unitOL $1 } - | decl { unLoc $1 } - - -- Template Haskell Extension - -- The $(..) form is one possible form of infixexp - -- but we treat an arbitrary expression just as if - -- it had a $(..) wrapped around it - | infixexp { unitOL (LL $ mkTopSpliceDecl $1) } + | '{-# RULES' rules '#-}' { $2 } + | '{-# VECTORISE_SCALAR' qvar '#-}' { unitOL $ LL $ VectD (HsVect $2 Nothing) } + | '{-# VECTORISE' qvar '=' exp '#-}' { unitOL $ LL $ VectD (HsVect $2 (Just $4)) } + | '{-# NOVECTORISE' qvar '#-}' { unitOL $ LL $ VectD (HsNoVect $2) } + | annotation { unitOL $1 } + | decl { unLoc $1 } + + -- Template Haskell Extension + -- The $(..) form is one possible form of infixexp + -- but we treat an arbitrary expression just as if + -- it had a $(..) wrapped around it + | infixexp { unitOL (LL $ mkTopSpliceDecl $1) } -- Type classes -- @@ -723,6 +728,11 @@ decl_cls : at_decl_cls { LL (unitOL (L1 (TyClD (unLoc $1)))) } | decl { $1 } + -- A 'default' signature used with the generic-programming extension + | 'default' infixexp '::' sigtypedoc + {% do { (TypeSig l ty) <- checkValSig $2 $4 + ; return (LL $ unitOL (LL $ SigD (GenericSig l ty))) } } + decls_cls :: { Located (OrdList (LHsDecl RdrName)) } -- Reversed : decls_cls ';' decl_cls { LL (unLoc $1 `appOL` unLoc $3) } | decls_cls ';' { LL (unLoc $1) } @@ -883,7 +893,7 @@ fdecl : 'import' callconv safety fspec {% mkImport $2 $3 (unLoc $4) >>= return.LL } | 'import' callconv fspec - {% do { d <- mkImport $2 (PlaySafe False) (unLoc $3); + {% do { d <- mkImport $2 PlaySafe (unLoc $3); return (LL d) } } | 'export' callconv fspec {% mkExport $2 (unLoc $3) >>= return.LL } @@ -895,8 +905,8 @@ safety :: { Safety } : 'unsafe' { PlayRisky } - | 'safe' { PlaySafe False } - | 'threadsafe' { PlaySafe True } -- deprecated alias + | 'safe' { PlaySafe } + | 'interruptible' { PlayInterruptible } fspec :: { Located (Located FastString, Located RdrName, LHsType RdrName) } : STRING var '::' sigtypedoc { LL (L (getLoc $1) (getSTRING $1), $2, $4) } @@ -1023,8 +1033,6 @@ | '$(' exp ')' { LL $ mkHsSpliceTy $2 } | TH_ID_SPLICE { LL $ mkHsSpliceTy $ L1 $ HsVar $ mkUnqual varName (getTH_ID_SPLICE $1) } --- Generics - | INTEGER { L1 (HsNumTy (getINTEGER $1)) } -- An inst_type is what occurs in the head of an instance decl -- e.g. (Foo a, Gaz b) => Wibble a b @@ -1206,15 +1214,20 @@ | docsection { L1 (case (unLoc $1) of (n, doc) -> DocGroup n doc) } decl :: { Located (OrdList (LHsDecl RdrName)) } - : sigdecl { $1 } - | '!' aexp rhs {% do { pat <- checkPattern $2; - return (LL $ unitOL $ LL $ ValD ( - PatBind (LL $ BangPat pat) (unLoc $3) - placeHolderType placeHolderNames)) } } - | infixexp opt_sig rhs {% do { r <- checkValDef $1 $2 $3; - let { l = comb2 $1 $> }; - return $! (sL l (unitOL $! (sL l $ ValD r))) } } - | docdecl { LL $ unitOL $1 } + : sigdecl { $1 } + + | '!' aexp rhs {% do { let { e = LL (SectionR (LL (HsVar bang_RDR)) $2) }; + pat <- checkPattern e; + return $ LL $ unitOL $ LL $ ValD $ + PatBind pat (unLoc $3) + placeHolderType placeHolderNames } } + -- Turn it all into an expression so that + -- checkPattern can check that bangs are enabled + + | infixexp opt_sig rhs {% do { r <- checkValDef $1 $2 $3; + let { l = comb2 $1 $> }; + return $! (sL l (unitOL $! (sL l $ ValD r))) } } + | docdecl { LL $ unitOL $1 } rhs :: { Located (GRHSs RdrName) } : '=' exp wherebinds { sL (comb3 $1 $2 $3) $ GRHSs (unguardedRHS $2) (unLoc $3) } @@ -1228,11 +1241,13 @@ : '|' guardquals '=' exp { sL (comb2 $1 $>) $ GRHS (unLoc $2) $4 } sigdecl :: { Located (OrdList (LHsDecl RdrName)) } - : infixexp '::' sigtypedoc {% do s <- checkValSig $1 $3 - ; return (LL $ unitOL (LL $ SigD s)) } - -- See Note [Declaration/signature overlap] for why we need infixexp here + : + -- See Note [Declaration/signature overlap] for why we need infixexp here + infixexp '::' sigtypedoc + {% do s <- checkValSig $1 $3 + ; return (LL $ unitOL (LL $ SigD s)) } | var ',' sig_vars '::' sigtypedoc - { LL $ toOL [ LL $ SigD (TypeSig n $5) | n <- $1 : unLoc $3 ] } + { LL $ toOL [ LL $ SigD (TypeSig ($1 : unLoc $3) $5) ] } | infix prec ops { LL $ toOL [ LL $ SigD (FixSig (FixitySig n (Fixity $2 (unLoc $1)))) | n <- unLoc $3 ] } | '{-# INLINE' activation qvar '#-}' @@ -1253,7 +1268,7 @@ : TH_QUASIQUOTE { let { loc = getLoc $1 ; ITquasiQuote (quoter, quote, quoteSpan) = unLoc $1 ; quoterId = mkUnqual varName quoter } - in L1 (mkHsQuasiQuote quoterId quoteSpan quote) } + in L1 (mkHsQuasiQuote quoterId (RealSrcSpan quoteSpan) quote) } exp :: { LHsExpr RdrName } : infixexp '::' sigtype { LL $ ExprWithTySig $1 $3 } @@ -1279,12 +1294,9 @@ | 'case' exp 'of' altslist { LL $ HsCase $2 (mkMatchGroup (unLoc $4)) } | '-' fexp { LL $ NegApp $2 noSyntaxExpr } - | 'do' stmtlist {% let loc = comb2 $1 $2 in - checkDo loc (unLoc $2) >>= \ (stmts,body) -> - return (L loc (mkHsDo DoExpr stmts body)) } - | 'mdo' stmtlist {% let loc = comb2 $1 $2 in - checkDo loc (unLoc $2) >>= \ (stmts,body) -> - return (L loc (mkHsDo (MDoExpr noPostTcTable) stmts body)) } + | 'do' stmtlist { L (comb2 $1 $2) (mkHsDo DoExpr (unLoc $2)) } + | 'mdo' stmtlist { L (comb2 $1 $2) (mkHsDo MDoExpr (unLoc $2)) } + | scc_annot exp { LL $ if opt_SccProfilingOn then HsSCC (unLoc $1) $2 else HsPar $2 } @@ -1356,8 +1368,8 @@ | RATIONAL { sL (getLoc $1) (HsOverLit $! mkHsFractional (getRATIONAL $1) placeHolderType) } -- N.B.: sections get parsed by these next two productions. - -- This allows you to write, e.g., '(+ 3, 4 -)', which isn't correct Haskell98 - -- (you'd have to write '((+ 3), (4 -))') + -- This allows you to write, e.g., '(+ 3, 4 -)', which isn't + -- correct Haskell (you'd have to write '((+ 3), (4 -))') -- but the less cluttered version fell out of having texps. | '(' texp ')' { LL (HsPar $2) } | '(' tup_exprs ')' { LL (ExplicitTuple $2 Boxed) } @@ -1417,8 +1429,8 @@ -- Note [Parsing sections] -- ~~~~~~~~~~~~~~~~~~~~~~~ -- We include left and right sections here, which isn't - -- technically right according to Haskell 98. For example - -- (3 +, True) isn't legal + -- technically right according to the Haskell standard. + -- For example (3 +, True) isn't legal. -- However, we want to parse bang patterns like -- (!x, !y) -- and it's convenient to do so here as a section @@ -1459,7 +1471,10 @@ | texp ',' exp '..' { LL $ ArithSeq noPostTcExpr (FromThen $1 $3) } | texp '..' exp { LL $ ArithSeq noPostTcExpr (FromTo $1 $3) } | texp ',' exp '..' exp { LL $ ArithSeq noPostTcExpr (FromThenTo $1 $3 $5) } - | texp '|' flattenedpquals { sL (comb2 $1 $>) $ mkHsDo ListComp (unLoc $3) $1 } + | texp '|' flattenedpquals + {% checkMonadComp >>= \ ctxt -> + return (sL (comb2 $1 $>) $ + mkHsComp ctxt (unLoc $3) $1) } lexps :: { Located [LHsExpr RdrName] } : lexps ',' texp { LL (((:) $! $3) $! unLoc $1) } @@ -1474,7 +1489,7 @@ -- We just had one thing in our "parallel" list so -- we simply return that thing directly - qss -> L1 [L1 $ ParStmt [(qs, undefined) | qs <- qss]] + qss -> L1 [L1 $ ParStmt [(qs, undefined) | qs <- qss] noSyntaxExpr noSyntaxExpr noSyntaxExpr] -- We actually found some actual parallel lists so -- we wrap them into as a ParStmt } @@ -1495,8 +1510,7 @@ -- It is possible to enable bracketing (associating) qualifier lists by uncommenting the lines with {| |} -- above. Due to a lack of consensus on the syntax, this feature is not being used until we get user --- demand. Note that the {| |} symbols are reused from -XGenerics and hence if you want to compile --- a program that makes use of this temporary syntax you must supply that flag to GHC +-- demand. transformqual :: { Located ([LStmt RdrName] -> Stmt RdrName) } -- Function is applied to a list of stmts *in order* @@ -1531,7 +1545,7 @@ (reverse (unLoc $1)) } | texp '..' exp { LL $ PArrSeq noPostTcExpr (FromTo $1 $3) } | texp ',' exp '..' exp { LL $ PArrSeq noPostTcExpr (FromThenTo $1 $3 $5) } - | texp '|' flattenedpquals { LL $ mkHsDo PArrComp (unLoc $3) $1 } + | texp '|' flattenedpquals { LL $ mkHsComp PArrComp (unLoc $3) $1 } -- We are reusing `lexps' and `flattenedpquals' from the list case. @@ -1791,7 +1805,7 @@ | special_id { L1 $! mkUnqual tvName (unLoc $1) } | 'unsafe' { L1 $! mkUnqual tvName (fsLit "unsafe") } | 'safe' { L1 $! mkUnqual tvName (fsLit "safe") } - | 'threadsafe' { L1 $! mkUnqual tvName (fsLit "threadsafe") } + | 'interruptible' { L1 $! mkUnqual tvName (fsLit "interruptible") } tyvarsym :: { Located RdrName } -- Does not include "!", because that is used for strictness marks @@ -1824,7 +1838,7 @@ | special_id { L1 $! mkUnqual varName (unLoc $1) } | 'unsafe' { L1 $! mkUnqual varName (fsLit "unsafe") } | 'safe' { L1 $! mkUnqual varName (fsLit "safe") } - | 'threadsafe' { L1 $! mkUnqual varName (fsLit "threadsafe") } + | 'interruptible' { L1 $! mkUnqual varName (fsLit "interruptible") } | 'forall' { L1 $! mkUnqual varName (fsLit "forall") } | 'family' { L1 $! mkUnqual varName (fsLit "family") } @@ -1850,7 +1864,7 @@ -- These special_ids are treated as keywords in various places, -- but as ordinary ids elsewhere. 'special_id' collects all these --- except 'unsafe', 'forall', and 'family' whose treatment differs +-- except 'unsafe', 'interruptible', 'forall', and 'family' whose treatment differs -- depending on context special_id :: { Located FastString } special_id diff -Nru ghc-7.0.3/compiler/parser/RdrHsSyn.lhs ghc-7.2.1/compiler/parser/RdrHsSyn.lhs --- ghc-7.0.3/compiler/parser/RdrHsSyn.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/parser/RdrHsSyn.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -40,8 +40,7 @@ checkPattern, -- HsExp -> P HsPat bang_RDR, checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat] - checkDo, -- [Stmt] -> P [Stmt] - checkMDo, -- [Stmt] -> P [Stmt] + checkMonadComp, -- P (HsStmtContext RdrName) checkValDef, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl checkValSig, -- (SrcLoc, HsExp, HsRhs, [HsDecl]) -> P HsDecl checkDoAndIfThenElse, @@ -54,6 +53,7 @@ import TypeRep ( Kind ) import RdrName ( RdrName, isRdrTyVar, isRdrTc, mkUnqual, rdrNameOcc, isRdrDataCon, isUnqual, getRdrName, setRdrNameSpace ) +import Name ( Name ) import BasicTypes ( maxPrecedence, Activation(..), RuleMatchInfo, InlinePragma(..), InlineSpec(..) ) import Lexer @@ -127,7 +127,6 @@ HsPredTy p -> extract_pred p acc HsOpTy ty1 (L loc tv) ty2 -> extract_tv loc tv (extract_lty ty1 (extract_lty ty2 acc)) HsParTy ty -> extract_lty ty acc - HsNumTy {} -> acc HsCoreTy {} -> acc -- The type is closed HsQuasiQuoteTy {} -> acc -- Quasi quotes mention no type variables HsSpliceTy {} -> acc -- Type splices mention no type variables @@ -152,8 +151,7 @@ get (L _ (FunBind { fun_matches = MatchGroup ms _ })) acc = foldr (get_m.unLoc) acc ms get _ acc = acc - get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc - get_m _ acc = acc + get_m _ acc = acc \end{code} @@ -611,34 +609,6 @@ check loc _ _ = parseErrorSDoc loc (text "malformed class assertion:" <+> ppr ty) ---------------------------------------------------------------------------- --- Checking statements in a do-expression --- We parse do { e1 ; e2 ; } --- as [ExprStmt e1, ExprStmt e2] --- checkDo (a) checks that the last thing is an ExprStmt --- (b) returns it separately --- same comments apply for mdo as well - -checkDo, checkMDo :: SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName) - -checkDo = checkDoMDo "a " "'do'" -checkMDo = checkDoMDo "an " "'mdo'" - -checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P ([LStmt RdrName], LHsExpr RdrName) -checkDoMDo _ nm loc [] = parseErrorSDoc loc (text ("Empty " ++ nm ++ " construct")) -checkDoMDo pre nm _ ss = do - check ss - where - check [] = panic "RdrHsSyn:checkDoMDo" - check [L _ (ExprStmt e _ _)] = return ([], e) - check [L l e] = parseErrorSDoc l - (text ("The last statement in " ++ pre ++ nm ++ - " construct must be an expression:") - $$ ppr e) - check (s:ss) = do - (ss',e') <- check ss - return ((s:ss'),e') - -- ------------------------------------------------------------------------- -- Checking Patterns. @@ -732,8 +702,6 @@ -> do fs <- mapM checkPatField fs return (ConPatIn c (RecCon (HsRecFields fs dd))) HsQuasiQuoteE q -> return (QuasiQuotePat q) --- Generics - HsType ty -> return (TypePat ty) _ -> patFail loc e0 placeHolderPunRhs :: LHsExpr RdrName @@ -806,23 +774,26 @@ -> P (Sig RdrName) checkValSig (L l (HsVar v)) ty | isUnqual v && not (isDataOcc (rdrNameOcc v)) - = return (TypeSig (L l v) ty) + = return (TypeSig [L l v] ty) checkValSig lhs@(L l _) ty = parseErrorSDoc l ((text "Invalid type signature:" <+> ppr lhs <+> text "::" <+> ppr ty) $$ text hint) where - hint = if looks_like_foreign lhs + hint = if foreign_RDR `looks_like` lhs then "Perhaps you meant to use -XForeignFunctionInterface?" - else "Should be of form :: " + else if default_RDR `looks_like` lhs + then "Perhaps you meant to use -XDefaultSignatures?" + else "Should be of form :: " -- A common error is to forget the ForeignFunctionInterface flag -- so check for that, and suggest. cf Trac #3805 -- Sadly 'foreign import' still barfs 'parse error' because 'import' is a keyword - looks_like_foreign (L _ (HsVar v)) = v == foreign_RDR - looks_like_foreign (L _ (HsApp lhs _)) = looks_like_foreign lhs - looks_like_foreign _ = False + looks_like s (L _ (HsVar v)) = v == s + looks_like s (L _ (HsApp lhs _)) = looks_like s lhs + looks_like _ _ = False foreign_RDR = mkUnqual varName (fsLit "foreign") + default_RDR = mkUnqual varName (fsLit "default") checkDoAndIfThenElse :: LHsExpr RdrName -> Bool @@ -912,6 +883,20 @@ _ -> return Nothing } go _ _ = return Nothing + +--------------------------------------------------------------------------- +-- Check for monad comprehensions +-- +-- If the flag MonadComprehensions is set, return a `MonadComp' context, +-- otherwise use the usual `ListComp' context + +checkMonadComp :: P (HsStmtContext Name) +checkMonadComp = do + pState <- getPState + return $ if xopt Opt_MonadComprehensions (dflags pState) + then MonadComp + else ListComp + --------------------------------------------------------------------------- -- Miscellaneous utilities diff -Nru ghc-7.0.3/compiler/prelude/ForeignCall.lhs ghc-7.2.1/compiler/prelude/ForeignCall.lhs --- ghc-7.0.3/compiler/prelude/ForeignCall.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/prelude/ForeignCall.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -13,8 +13,8 @@ {-# LANGUAGE DeriveDataTypeable #-} module ForeignCall ( - ForeignCall(..), - Safety(..), playSafe, + ForeignCall(..), isSafeForeignCall, + Safety(..), playSafe, playInterruptible, CExportSpec(..), CLabelString, isCLabelString, pprCLabelString, CCallSpec(..), @@ -43,6 +43,9 @@ deriving Eq {-! derive: Binary !-} +isSafeForeignCall :: ForeignCall -> Bool +isSafeForeignCall (CCall (CCallSpec _ _ safe)) = playSafe safe + -- We may need more clues to distinguish foreign calls -- but this simple printer will do for now instance Outputable ForeignCall where @@ -59,9 +62,10 @@ -- by a separate OS thread, i.e., _concurrently_ to the -- execution of other Haskell threads. - Bool -- Indicates the deprecated "threadsafe" annotation - -- which is now an alias for "safe". This information - -- is never used except to emit a deprecation warning. + | PlayInterruptible -- Like PlaySafe, but additionally + -- the worker thread running this foreign call may + -- be unceremoniously killed, so it must be scheduled + -- on an unbound thread. | PlayRisky -- None of the above can happen; the call will return -- without interacting with the runtime system at all @@ -70,13 +74,18 @@ {-! derive: Binary !-} instance Outputable Safety where - ppr (PlaySafe False) = ptext (sLit "safe") - ppr (PlaySafe True) = ptext (sLit "threadsafe") + ppr PlaySafe = ptext (sLit "safe") + ppr PlayInterruptible = ptext (sLit "interruptible") ppr PlayRisky = ptext (sLit "unsafe") playSafe :: Safety -> Bool -playSafe PlaySafe{} = True -playSafe PlayRisky = False +playSafe PlaySafe = True +playSafe PlayInterruptible = True +playSafe PlayRisky = False + +playInterruptible :: Safety -> Bool +playInterruptible PlayInterruptible = True +playInterruptible _ = False \end{code} @@ -230,16 +239,17 @@ get bh = do aa <- get bh; return (CCall aa) instance Binary Safety where - put_ bh (PlaySafe aa) = do + put_ bh PlaySafe = do putByte bh 0 - put_ bh aa - put_ bh PlayRisky = do + put_ bh PlayInterruptible = do putByte bh 1 + put_ bh PlayRisky = do + putByte bh 2 get bh = do h <- getByte bh case h of - 0 -> do aa <- get bh - return (PlaySafe aa) + 0 -> do return PlaySafe + 1 -> do return PlayInterruptible _ -> do return PlayRisky instance Binary CExportSpec where diff -Nru ghc-7.0.3/compiler/prelude/PrelInfo.lhs ghc-7.2.1/compiler/prelude/PrelInfo.lhs --- ghc-7.0.3/compiler/prelude/PrelInfo.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/prelude/PrelInfo.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -8,32 +8,31 @@ wiredInIds, ghcPrimIds, primOpRules, builtinRules, - ghcPrimExports, - wiredInThings, basicKnownKeyNames, - primOpId, - - -- Random other things - maybeCharLikeCon, maybeIntLikeCon, + ghcPrimExports, + wiredInThings, basicKnownKeyNames, + primOpId, + + -- Random other things + maybeCharLikeCon, maybeIntLikeCon, - -- Class categories - isNumericClass, isStandardClass + -- Class categories + isNumericClass, isStandardClass ) where #include "HsVersions.h" -import PrelNames ( basicKnownKeyNames, - hasKey, charDataConKey, intDataConKey, - numericClassKeys, standardClassKeys ) +import PrelNames ( basicKnownKeyNames, + hasKey, charDataConKey, intDataConKey, + numericClassKeys, standardClassKeys ) import PrelRules -import PrimOp ( PrimOp, allThePrimOps, primOpOcc, primOpTag, maxPrimOpTag ) +import PrimOp ( PrimOp, allThePrimOps, primOpTag, maxPrimOpTag ) import DataCon ( DataCon ) import Id ( Id, idName ) import MkId -- All of it, for re-export -import Name ( nameOccName ) import TysPrim ( primTyCons ) import TysWiredIn ( wiredInTyCons ) -import HscTypes ( TyThing(..), implicitTyThings, GenAvailInfo(..), RdrAvailInfo ) +import HscTypes ( TyThing(..), implicitTyThings, AvailInfo(..), IfaceExport ) import Class ( Class, classKey ) import Type ( funTyCon ) import TyCon ( tyConName ) @@ -82,7 +81,7 @@ , map AnId wiredInIds -- PrimOps - , map (AnId . mkPrimOpId) allThePrimOps + , map (AnId . primOpId) allThePrimOps ] where tycon_things = map ATyCon ([funTyCon] ++ primTyCons ++ wiredInTyCons) @@ -99,9 +98,10 @@ %************************************************************************ \begin{code} -primOpIds :: Array Int Id -- Indexed by PrimOp tag +primOpIds :: Array Int Id +-- A cache of the PrimOp Ids, indexed by PrimOp tag primOpIds = array (1,maxPrimOpTag) [ (primOpTag op, mkPrimOpId op) - | op <- allThePrimOps] + | op <- allThePrimOps ] primOpId :: PrimOp -> Id primOpId op = primOpIds ! primOpTag op @@ -118,13 +118,12 @@ wired-in Ids. \begin{code} -ghcPrimExports :: [RdrAvailInfo] +ghcPrimExports :: [IfaceExport] ghcPrimExports - = map (Avail . nameOccName . idName) ghcPrimIds ++ - map (Avail . primOpOcc) allThePrimOps ++ - [ AvailTC occ [occ] | - n <- funTyCon : primTyCons, let occ = nameOccName (tyConName n) - ] + = map (Avail . idName) ghcPrimIds ++ + map (Avail . idName . primOpId) allThePrimOps ++ + [ AvailTC n [n] + | tc <- funTyCon : primTyCons, let n = tyConName tc ] \end{code} diff -Nru ghc-7.0.3/compiler/prelude/PrelNames.lhs ghc-7.2.1/compiler/prelude/PrelNames.lhs --- ghc-7.0.3/compiler/prelude/PrelNames.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/prelude/PrelNames.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -58,7 +58,7 @@ mkTupleTyConUnique ) import BasicTypes ( Boxity(..), Arity ) -import Name ( Name, mkInternalName, mkExternalName ) +import Name ( Name, mkInternalName, mkExternalName, mkSystemVarName ) import SrcLoc import FastString \end{code} @@ -89,20 +89,27 @@ %************************************************************************ -%* * +%* * \subsection{Known key Names} -%* * +%* * %************************************************************************ -This section tells what the compiler knows about the assocation of +This section tells what the compiler knows about the association of names with uniques. These ones are the *non* wired-in ones. The wired in ones are defined in TysWiredIn etc. +The names for DPH can come from one of multiple backend packages. At the point where +'basicKnownKeyNames' is used, we don't know which backend it will be. Hence, we list +the names for multiple backends. That works out fine, although they use the same uniques, +as we are guaranteed to only load one backend; hence, only one of the different names +sharing a unique will be used. + \begin{code} basicKnownKeyNames :: [Name] basicKnownKeyNames = genericTyConNames ++ typeableClassNames + ++ dphKnownKeyNames dphSeqPackageId ++ dphKnownKeyNames dphParPackageId ++ [ -- Type constructors (synonyms especially) ioTyConName, ioDataConName, runMainIOName, @@ -136,9 +143,12 @@ traversableClassName, -- Numeric stuff - negateName, minusName, - fromRationalName, fromIntegerName, - geName, eqName, + negateName, minusName, geName, eqName, + + -- Conversion functions + fromRationalName, fromIntegerName, + toIntegerName, toRationalName, + fromIntegralName, realToFracName, -- String stuff fromStringName, @@ -146,11 +156,11 @@ -- Enum stuff enumFromName, enumFromThenName, enumFromThenToName, enumFromToName, - enumFromToPName, enumFromThenToPName, -- Monad stuff thenIOName, bindIOName, returnIOName, failIOName, failMName, bindMName, thenMName, returnMName, + fmapName, -- MonadRec stuff mfixName, @@ -184,11 +194,6 @@ dollarName, -- The ($) apply function - -- Parallel array operations - nullPName, lengthPName, replicatePName, singletonPName, mapPName, - filterPName, zipPName, crossMapPName, indexPName, - toPName, emptyPName, appPName, - -- FFI primitive types that are not wired-in. stablePtrTyConName, ptrTyConName, funPtrTyConName, int8TyConName, int16TyConName, int32TyConName, int64TyConName, @@ -214,13 +219,47 @@ -- The Either type , eitherTyConName, leftDataConName, rightDataConName + -- Plugins + , pluginTyConName + -- dotnet interop , objectTyConName, marshalObjectName, unmarshalObjectName , marshalStringName, unmarshalStringName, checkDotnetResName + + -- Generics + , genClassName, gen1ClassName + , datatypeClassName, constructorClassName, selectorClassName + + -- Monad comprehensions + , guardMName + , liftMName + , groupMName + , mzipName ] genericTyConNames :: [Name] -genericTyConNames = [crossTyConName, plusTyConName, genUnitTyConName] +genericTyConNames = [ + v1TyConName, u1TyConName, par1TyConName, rec1TyConName, + k1TyConName, m1TyConName, sumTyConName, prodTyConName, + compTyConName, rTyConName, pTyConName, dTyConName, + cTyConName, sTyConName, rec0TyConName, par0TyConName, + d1TyConName, c1TyConName, s1TyConName, noSelTyConName, + repTyConName, rep1TyConName + ] + +-- Know names from the DPH package which vary depending on the selected DPH backend. +-- +dphKnownKeyNames :: PackageId -> [Name] +dphKnownKeyNames dphPkg + = map ($ dphPkg) + [ + -- Parallel array operations + nullPName, lengthPName, replicatePName, singletonPName, mapPName, + filterPName, zipPName, crossMapPName, indexPName, + toPName, emptyPName, appPName, + enumFromToPName, enumFromThenToPName + + ] \end{code} @@ -236,24 +275,25 @@ pRELUDE :: Module pRELUDE = mkBaseModule_ pRELUDE_NAME -gHC_PRIM, gHC_TYPES, gHC_BOOL, gHC_UNIT, gHC_ORDERING, gHC_GENERICS, +gHC_PRIM, gHC_TYPES, gHC_UNIT, gHC_ORDERING, gHC_GENERICS, gHC_MAGIC, - gHC_CLASSES, gHC_BASE, gHC_ENUM, - gHC_SHOW, gHC_READ, gHC_NUM, gHC_INTEGER, gHC_INTEGER_TYPE, gHC_LIST, gHC_PARR, + gHC_CLASSES, gHC_BASE, gHC_ENUM, gHC_CSTRING, + gHC_SHOW, gHC_READ, gHC_NUM, gHC_INTEGER, gHC_INTEGER_TYPE, gHC_LIST, gHC_TUPLE, dATA_TUPLE, dATA_EITHER, dATA_STRING, dATA_FOLDABLE, dATA_TRAVERSABLE, - gHC_PACK, gHC_CONC, gHC_IO, gHC_IO_Exception, - gHC_ST, gHC_ARR, gHC_STABLE, gHC_ADDR, gHC_PTR, gHC_ERR, gHC_REAL, - gHC_FLOAT, gHC_TOP_HANDLER, sYSTEM_IO, dYNAMIC, tYPEABLE, gENERICS, - dOTNET, rEAD_PREC, lEX, gHC_INT, gHC_WORD, mONAD, mONAD_FIX, aRROW, cONTROL_APPLICATIVE, - gHC_DESUGAR, rANDOM, gHC_EXTS, cONTROL_EXCEPTION_BASE :: Module + gHC_CONC, gHC_IO, gHC_IO_Exception, + gHC_ST, gHC_ARR, gHC_STABLE, gHC_PTR, gHC_ERR, gHC_REAL, + gHC_FLOAT, gHC_TOP_HANDLER, sYSTEM_IO, dYNAMIC, tYPEABLE, tYPEABLE_INTERNAL, gENERICS, + dOTNET, rEAD_PREC, lEX, gHC_INT, gHC_WORD, mONAD, mONAD_FIX, mONAD_GROUP, mONAD_ZIP, + aRROW, cONTROL_APPLICATIVE, gHC_DESUGAR, rANDOM, gHC_EXTS, + cONTROL_EXCEPTION_BASE :: Module gHC_PRIM = mkPrimModule (fsLit "GHC.Prim") -- Primitive types and values gHC_TYPES = mkPrimModule (fsLit "GHC.Types") gHC_UNIT = mkPrimModule (fsLit "GHC.Unit") -gHC_BOOL = mkPrimModule (fsLit "GHC.Bool") gHC_ORDERING = mkPrimModule (fsLit "GHC.Ordering") gHC_GENERICS = mkPrimModule (fsLit "GHC.Generics") gHC_MAGIC = mkPrimModule (fsLit "GHC.Magic") +gHC_CSTRING = mkPrimModule (fsLit "GHC.CString") gHC_CLASSES = mkBaseModule (fsLit "GHC.Classes") gHC_BASE = mkBaseModule (fsLit "GHC.Base") @@ -263,22 +303,19 @@ gHC_NUM = mkBaseModule (fsLit "GHC.Num") gHC_INTEGER = mkIntegerModule (fsLit "GHC.Integer") gHC_INTEGER_TYPE= mkIntegerModule (fsLit "GHC.Integer.Type") -gHC_LIST = mkBaseModule (fsLit "GHC.List") -gHC_PARR = mkBaseModule (fsLit "GHC.PArr") -gHC_TUPLE = mkPrimModule (fsLit "GHC.Tuple") -dATA_TUPLE = mkBaseModule (fsLit "Data.Tuple") +gHC_LIST = mkBaseModule (fsLit "GHC.List") +gHC_TUPLE = mkPrimModule (fsLit "GHC.Tuple") +dATA_TUPLE = mkBaseModule (fsLit "Data.Tuple") dATA_EITHER = mkBaseModule (fsLit "Data.Either") dATA_STRING = mkBaseModule (fsLit "Data.String") dATA_FOLDABLE = mkBaseModule (fsLit "Data.Foldable") dATA_TRAVERSABLE= mkBaseModule (fsLit "Data.Traversable") -gHC_PACK = mkBaseModule (fsLit "GHC.Pack") gHC_CONC = mkBaseModule (fsLit "GHC.Conc") gHC_IO = mkBaseModule (fsLit "GHC.IO") gHC_IO_Exception = mkBaseModule (fsLit "GHC.IO.Exception") gHC_ST = mkBaseModule (fsLit "GHC.ST") gHC_ARR = mkBaseModule (fsLit "GHC.Arr") gHC_STABLE = mkBaseModule (fsLit "GHC.Stable") -gHC_ADDR = mkBaseModule (fsLit "GHC.Addr") gHC_PTR = mkBaseModule (fsLit "GHC.Ptr") gHC_ERR = mkBaseModule (fsLit "GHC.Err") gHC_REAL = mkBaseModule (fsLit "GHC.Real") @@ -286,7 +323,8 @@ gHC_TOP_HANDLER = mkBaseModule (fsLit "GHC.TopHandler") sYSTEM_IO = mkBaseModule (fsLit "System.IO") dYNAMIC = mkBaseModule (fsLit "Data.Dynamic") -tYPEABLE = mkBaseModule (fsLit "Data.Typeable") +tYPEABLE = mkBaseModule (fsLit "Data.Typeable") +tYPEABLE_INTERNAL = mkBaseModule (fsLit "Data.Typeable.Internal") gENERICS = mkBaseModule (fsLit "Data.Data") dOTNET = mkBaseModule (fsLit "GHC.Dotnet") rEAD_PREC = mkBaseModule (fsLit "Text.ParserCombinators.ReadPrec") @@ -295,6 +333,8 @@ gHC_WORD = mkBaseModule (fsLit "GHC.Word") mONAD = mkBaseModule (fsLit "Control.Monad") mONAD_FIX = mkBaseModule (fsLit "Control.Monad.Fix") +mONAD_GROUP = mkBaseModule (fsLit "Control.Monad.Group") +mONAD_ZIP = mkBaseModule (fsLit "Control.Monad.Zip") aRROW = mkBaseModule (fsLit "Control.Arrow") cONTROL_APPLICATIVE = mkBaseModule (fsLit "Control.Applicative") gHC_DESUGAR = mkBaseModule (fsLit "GHC.Desugar") @@ -302,6 +342,12 @@ gHC_EXTS = mkBaseModule (fsLit "GHC.Exts") cONTROL_EXCEPTION_BASE = mkBaseModule (fsLit "Control.Exception.Base") +gHC_PARR :: PackageId -> Module +gHC_PARR pkg = mkModule pkg (mkModuleNameFS (fsLit "Data.Array.Parallel")) + +gHC_PARR' :: Module +gHC_PARR' = mkBaseModule (fsLit "GHC.PArr") + mAIN, rOOT_MAIN :: Module mAIN = mkMainModule_ mAIN_NAME rOOT_MAIN = mkMainModule (fsLit ":Main") -- Root module for initialisation @@ -329,6 +375,12 @@ mkBaseModule_ :: ModuleName -> Module mkBaseModule_ m = mkModule basePackageId m +mkThisGhcModule :: FastString -> Module +mkThisGhcModule m = mkModule thisGhcPackageId (mkModuleNameFS m) + +mkThisGhcModule_ :: ModuleName -> Module +mkThisGhcModule_ m = mkModule thisGhcPackageId m + mkMainModule :: FastString -> Module mkMainModule m = mkModule mainPackageId (mkModuleNameFS m) @@ -495,20 +547,67 @@ showSpace_RDR = varQual_RDR gHC_SHOW (fsLit "showSpace") showParen_RDR = varQual_RDR gHC_SHOW (fsLit "showParen") -typeOf_RDR, mkTypeRep_RDR, mkTyConRep_RDR :: RdrName -typeOf_RDR = varQual_RDR tYPEABLE (fsLit "typeOf") -mkTypeRep_RDR = varQual_RDR tYPEABLE (fsLit "mkTyConApp") -mkTyConRep_RDR = varQual_RDR tYPEABLE (fsLit "mkTyCon") +typeOf_RDR, mkTyCon_RDR, mkTyConApp_RDR :: RdrName +typeOf_RDR = varQual_RDR tYPEABLE_INTERNAL (fsLit "typeOf") +mkTyCon_RDR = varQual_RDR tYPEABLE_INTERNAL (fsLit "mkTyCon") +mkTyConApp_RDR = varQual_RDR tYPEABLE_INTERNAL (fsLit "mkTyConApp") undefined_RDR :: RdrName undefined_RDR = varQual_RDR gHC_ERR (fsLit "undefined") +error_RDR :: RdrName +error_RDR = varQual_RDR gHC_ERR (fsLit "error") + +-- Old Generics (constructors and functions) crossDataCon_RDR, inlDataCon_RDR, inrDataCon_RDR, genUnitDataCon_RDR :: RdrName crossDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit ":*:") inlDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Inl") inrDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Inr") genUnitDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Unit") +-- Generics (constructors and functions) +u1DataCon_RDR, par1DataCon_RDR, rec1DataCon_RDR, + k1DataCon_RDR, m1DataCon_RDR, l1DataCon_RDR, r1DataCon_RDR, + prodDataCon_RDR, comp1DataCon_RDR, from_RDR, from1_RDR, + to_RDR, to1_RDR, datatypeName_RDR, moduleName_RDR, conName_RDR, + conFixity_RDR, conIsRecord_RDR, + noArityDataCon_RDR, arityDataCon_RDR, selName_RDR, + prefixDataCon_RDR, infixDataCon_RDR, leftAssocDataCon_RDR, + rightAssocDataCon_RDR, notAssocDataCon_RDR :: RdrName + +u1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "U1") +par1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Par1") +rec1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Rec1") +k1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "K1") +m1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "M1") + +l1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "L1") +r1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "R1") + +prodDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit ":*:") +comp1DataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Comp1") + +from_RDR = varQual_RDR gHC_GENERICS (fsLit "from") +from1_RDR = varQual_RDR gHC_GENERICS (fsLit "from1") +to_RDR = varQual_RDR gHC_GENERICS (fsLit "to") +to1_RDR = varQual_RDR gHC_GENERICS (fsLit "to1") + +datatypeName_RDR = varQual_RDR gHC_GENERICS (fsLit "datatypeName") +moduleName_RDR = varQual_RDR gHC_GENERICS (fsLit "moduleName") +selName_RDR = varQual_RDR gHC_GENERICS (fsLit "selName") +conName_RDR = varQual_RDR gHC_GENERICS (fsLit "conName") +conFixity_RDR = varQual_RDR gHC_GENERICS (fsLit "conFixity") +conIsRecord_RDR = varQual_RDR gHC_GENERICS (fsLit "conIsRecord") + +noArityDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "NoArity") +arityDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Arity") +prefixDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Prefix") +infixDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "Infix") +leftAssocDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "LeftAssociative") +rightAssocDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "RightAssociative") +notAssocDataCon_RDR = dataQual_RDR gHC_GENERICS (fsLit "NotAssociative") + + fmap_RDR, pure_RDR, ap_RDR, foldable_foldr_RDR, traverse_RDR :: RdrName fmap_RDR = varQual_RDR gHC_BASE (fsLit "fmap") pure_RDR = varQual_RDR cONTROL_APPLICATIVE (fsLit "pure") @@ -540,6 +639,9 @@ \begin{code} +wildCardName :: Name +wildCardName = mkSystemVarName wildCardKey (fsLit "wild") + runMainIOName :: Name runMainIOName = varQual gHC_TOP_HANDLER (fsLit "runMainIO") runMainKey @@ -551,19 +653,48 @@ leftDataConName = conName dATA_EITHER (fsLit "Left") leftDataConKey rightDataConName = conName dATA_EITHER (fsLit "Right") rightDataConKey --- Generics -crossTyConName, plusTyConName, genUnitTyConName :: Name -crossTyConName = tcQual gHC_GENERICS (fsLit ":*:") crossTyConKey -plusTyConName = tcQual gHC_GENERICS (fsLit ":+:") plusTyConKey -genUnitTyConName = tcQual gHC_GENERICS (fsLit "Unit") genUnitTyConKey +-- Generics (types) +v1TyConName, u1TyConName, par1TyConName, rec1TyConName, + k1TyConName, m1TyConName, sumTyConName, prodTyConName, + compTyConName, rTyConName, pTyConName, dTyConName, + cTyConName, sTyConName, rec0TyConName, par0TyConName, + d1TyConName, c1TyConName, s1TyConName, noSelTyConName, + repTyConName, rep1TyConName :: Name + +v1TyConName = tcQual gHC_GENERICS (fsLit "V1") v1TyConKey +u1TyConName = tcQual gHC_GENERICS (fsLit "U1") u1TyConKey +par1TyConName = tcQual gHC_GENERICS (fsLit "Par1") par1TyConKey +rec1TyConName = tcQual gHC_GENERICS (fsLit "Rec1") rec1TyConKey +k1TyConName = tcQual gHC_GENERICS (fsLit "K1") k1TyConKey +m1TyConName = tcQual gHC_GENERICS (fsLit "M1") m1TyConKey + +sumTyConName = tcQual gHC_GENERICS (fsLit ":+:") sumTyConKey +prodTyConName = tcQual gHC_GENERICS (fsLit ":*:") prodTyConKey +compTyConName = tcQual gHC_GENERICS (fsLit ":.:") compTyConKey + +rTyConName = tcQual gHC_GENERICS (fsLit "R") rTyConKey +pTyConName = tcQual gHC_GENERICS (fsLit "P") pTyConKey +dTyConName = tcQual gHC_GENERICS (fsLit "D") dTyConKey +cTyConName = tcQual gHC_GENERICS (fsLit "C") cTyConKey +sTyConName = tcQual gHC_GENERICS (fsLit "S") sTyConKey + +rec0TyConName = tcQual gHC_GENERICS (fsLit "Rec0") rec0TyConKey +par0TyConName = tcQual gHC_GENERICS (fsLit "Par0") par0TyConKey +d1TyConName = tcQual gHC_GENERICS (fsLit "D1") d1TyConKey +c1TyConName = tcQual gHC_GENERICS (fsLit "C1") c1TyConKey +s1TyConName = tcQual gHC_GENERICS (fsLit "S1") s1TyConKey +noSelTyConName = tcQual gHC_GENERICS (fsLit "NoSelector") noSelTyConKey + +repTyConName = tcQual gHC_GENERICS (fsLit "Rep") repTyConKey +rep1TyConName = tcQual gHC_GENERICS (fsLit "Rep1") rep1TyConKey -- Base strings Strings unpackCStringName, unpackCStringAppendName, unpackCStringFoldrName, unpackCStringUtf8Name, eqStringName, stringTyConName :: Name -unpackCStringName = varQual gHC_BASE (fsLit "unpackCString#") unpackCStringIdKey -unpackCStringAppendName = varQual gHC_BASE (fsLit "unpackAppendCString#") unpackCStringAppendIdKey -unpackCStringFoldrName = varQual gHC_BASE (fsLit "unpackFoldrCString#") unpackCStringFoldrIdKey -unpackCStringUtf8Name = varQual gHC_BASE (fsLit "unpackCStringUtf8#") unpackCStringUtf8IdKey +unpackCStringName = varQual gHC_CSTRING (fsLit "unpackCString#") unpackCStringIdKey +unpackCStringAppendName = varQual gHC_CSTRING (fsLit "unpackAppendCString#") unpackCStringAppendIdKey +unpackCStringFoldrName = varQual gHC_CSTRING (fsLit "unpackFoldrCString#") unpackCStringFoldrIdKey +unpackCStringUtf8Name = varQual gHC_CSTRING (fsLit "unpackCStringUtf8#") unpackCStringUtf8IdKey eqStringName = varQual gHC_BASE (fsLit "eqString") eqStringIdKey stringTyConName = tcQual gHC_BASE (fsLit "String") stringTyConKey @@ -571,13 +702,18 @@ inlineIdName :: Name inlineIdName = varQual gHC_MAGIC (fsLit "inline") inlineIdKey +-- The 'undefined' function. Used by supercompilation. +undefinedName :: Name +undefinedName = varQual gHC_ERR (fsLit "undefined") undefinedKey + -- Base classes (Eq, Ord, Functor) -eqClassName, eqName, ordClassName, geName, functorClassName :: Name +fmapName, eqClassName, eqName, ordClassName, geName, functorClassName :: Name eqClassName = clsQual gHC_CLASSES (fsLit "Eq") eqClassKey eqName = methName gHC_CLASSES (fsLit "==") eqClassOpKey ordClassName = clsQual gHC_CLASSES (fsLit "Ord") ordClassKey geName = methName gHC_CLASSES (fsLit ">=") geClassOpKey functorClassName = clsQual gHC_BASE (fsLit "Functor") functorClassKey +fmapName = methName gHC_BASE (fsLit "fmap") fmapClassOpKey -- Class Monad monadClassName, thenMName, bindMName, returnMName, failMName :: Name @@ -640,7 +776,7 @@ fstName = varQual dATA_TUPLE (fsLit "fst") fstIdKey sndName = varQual dATA_TUPLE (fsLit "snd") sndIdKey --- Module PrelNum +-- Module GHC.Num numClassName, fromIntegerName, minusName, negateName, plusIntegerName, timesIntegerName, integerTyConName, smallIntegerName :: Name @@ -653,10 +789,11 @@ integerTyConName = tcQual gHC_INTEGER_TYPE (fsLit "Integer") integerTyConKey smallIntegerName = varQual gHC_INTEGER (fsLit "smallInteger") smallIntegerIdKey --- PrelReal types and classes +-- GHC.Real types and classes rationalTyConName, ratioTyConName, ratioDataConName, realClassName, integralClassName, realFracClassName, fractionalClassName, - fromRationalName :: Name + fromRationalName, toIntegerName, toRationalName, fromIntegralName, + realToFracName :: Name rationalTyConName = tcQual gHC_REAL (fsLit "Rational") rationalTyConKey ratioTyConName = tcQual gHC_REAL (fsLit "Ratio") ratioTyConKey ratioDataConName = conName gHC_REAL (fsLit ":%") ratioDataConKey @@ -664,7 +801,11 @@ integralClassName = clsQual gHC_REAL (fsLit "Integral") integralClassKey realFracClassName = clsQual gHC_REAL (fsLit "RealFrac") realFracClassKey fractionalClassName = clsQual gHC_REAL (fsLit "Fractional") fractionalClassKey -fromRationalName = methName gHC_REAL (fsLit "fromRational") fromRationalClassOpKey +fromRationalName = methName gHC_REAL (fsLit "fromRational") fromRationalClassOpKey +toIntegerName = methName gHC_REAL (fsLit "toInteger") toIntegerClassOpKey +toRationalName = methName gHC_REAL (fsLit "toRational") toRationalClassOpKey +fromIntegralName = varQual gHC_REAL (fsLit "fromIntegral") fromIntegralIdKey +realToFracName = varQual gHC_REAL (fsLit "realToFrac") realToFracIdKey -- PrelFloat classes floatingClassName, realFloatClassName :: Name @@ -679,14 +820,14 @@ typeableClassName, typeable1ClassName, typeable2ClassName, typeable3ClassName, typeable4ClassName, typeable5ClassName, typeable6ClassName, typeable7ClassName :: Name -typeableClassName = clsQual tYPEABLE (fsLit "Typeable") typeableClassKey -typeable1ClassName = clsQual tYPEABLE (fsLit "Typeable1") typeable1ClassKey -typeable2ClassName = clsQual tYPEABLE (fsLit "Typeable2") typeable2ClassKey -typeable3ClassName = clsQual tYPEABLE (fsLit "Typeable3") typeable3ClassKey -typeable4ClassName = clsQual tYPEABLE (fsLit "Typeable4") typeable4ClassKey -typeable5ClassName = clsQual tYPEABLE (fsLit "Typeable5") typeable5ClassKey -typeable6ClassName = clsQual tYPEABLE (fsLit "Typeable6") typeable6ClassKey -typeable7ClassName = clsQual tYPEABLE (fsLit "Typeable7") typeable7ClassKey +typeableClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable") typeableClassKey +typeable1ClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable1") typeable1ClassKey +typeable2ClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable2") typeable2ClassKey +typeable3ClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable3") typeable3ClassKey +typeable4ClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable4") typeable4ClassKey +typeable5ClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable5") typeable5ClassKey +typeable6ClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable6") typeable6ClassKey +typeable7ClassName = clsQual tYPEABLE_INTERNAL (fsLit "Typeable7") typeable7ClassKey typeableClassNames :: [Name] typeableClassNames = [ typeableClassName, typeable1ClassName, typeable2ClassName @@ -725,25 +866,35 @@ readClassName :: Name readClassName = clsQual gHC_READ (fsLit "Read") readClassKey +-- Classes Generic and Generic1, Datatype, Constructor and Selector +genClassName, gen1ClassName, datatypeClassName, constructorClassName, + selectorClassName :: Name +genClassName = clsQual gHC_GENERICS (fsLit "Generic") genClassKey +gen1ClassName = clsQual gHC_GENERICS (fsLit "Generic1") gen1ClassKey + +datatypeClassName = clsQual gHC_GENERICS (fsLit "Datatype") datatypeClassKey +constructorClassName = clsQual gHC_GENERICS (fsLit "Constructor") constructorClassKey +selectorClassName = clsQual gHC_GENERICS (fsLit "Selector") selectorClassKey + -- parallel array types and functions enumFromToPName, enumFromThenToPName, nullPName, lengthPName, singletonPName, replicatePName, mapPName, filterPName, zipPName, crossMapPName, indexPName, toPName, - emptyPName, appPName :: Name -enumFromToPName = varQual gHC_PARR (fsLit "enumFromToP") enumFromToPIdKey -enumFromThenToPName= varQual gHC_PARR (fsLit "enumFromThenToP") enumFromThenToPIdKey -nullPName = varQual gHC_PARR (fsLit "nullP") nullPIdKey -lengthPName = varQual gHC_PARR (fsLit "lengthP") lengthPIdKey -singletonPName = varQual gHC_PARR (fsLit "singletonP") singletonPIdKey -replicatePName = varQual gHC_PARR (fsLit "replicateP") replicatePIdKey -mapPName = varQual gHC_PARR (fsLit "mapP") mapPIdKey -filterPName = varQual gHC_PARR (fsLit "filterP") filterPIdKey -zipPName = varQual gHC_PARR (fsLit "zipP") zipPIdKey -crossMapPName = varQual gHC_PARR (fsLit "crossMapP") crossMapPIdKey -indexPName = varQual gHC_PARR (fsLit "!:") indexPIdKey -toPName = varQual gHC_PARR (fsLit "toP") toPIdKey -emptyPName = varQual gHC_PARR (fsLit "emptyP") emptyPIdKey -appPName = varQual gHC_PARR (fsLit "+:+") appPIdKey + emptyPName, appPName :: PackageId -> Name +enumFromToPName pkg = varQual (gHC_PARR pkg) (fsLit "enumFromToP") enumFromToPIdKey +enumFromThenToPName pkg = varQual (gHC_PARR pkg) (fsLit "enumFromThenToP") enumFromThenToPIdKey +nullPName pkg = varQual (gHC_PARR pkg) (fsLit "nullP") nullPIdKey +lengthPName pkg = varQual (gHC_PARR pkg) (fsLit "lengthP") lengthPIdKey +singletonPName pkg = varQual (gHC_PARR pkg) (fsLit "singletonP") singletonPIdKey +replicatePName pkg = varQual (gHC_PARR pkg) (fsLit "replicateP") replicatePIdKey +mapPName pkg = varQual (gHC_PARR pkg) (fsLit "mapP") mapPIdKey +filterPName pkg = varQual (gHC_PARR pkg) (fsLit "filterP") filterPIdKey +zipPName pkg = varQual (gHC_PARR pkg) (fsLit "zipP") zipPIdKey +crossMapPName pkg = varQual (gHC_PARR pkg) (fsLit "crossMapP") crossMapPIdKey +indexPName pkg = varQual (gHC_PARR pkg) (fsLit "!:") indexPIdKey +toPName pkg = varQual (gHC_PARR pkg) (fsLit "toP") toPIdKey +emptyPName pkg = varQual (gHC_PARR pkg) (fsLit "emptyP") emptyPIdKey +appPName pkg = varQual (gHC_PARR pkg) (fsLit "+:+") appPIdKey -- IO things ioTyConName, ioDataConName, thenIOName, bindIOName, returnIOName, @@ -804,6 +955,14 @@ choiceAName = varQual aRROW (fsLit "|||") choiceAIdKey loopAName = varQual aRROW (fsLit "loop") loopAIdKey +-- Monad comprehensions +guardMName, liftMName, groupMName, mzipName :: Name +guardMName = varQual mONAD (fsLit "guard") guardMIdKey +liftMName = varQual mONAD (fsLit "liftM") liftMIdKey +groupMName = varQual mONAD_GROUP (fsLit "mgroupWith") groupMIdKey +mzipName = varQual mONAD_ZIP (fsLit "mzip") mzipIdKey + + -- Annotation type checking toAnnotationWrapperName :: Name toAnnotationWrapperName = varQual gHC_DESUGAR (fsLit "toAnnotationWrapper") toAnnotationWrapperIdKey @@ -828,6 +987,12 @@ marshalStringName = varQual dOTNET (fsLit "marshalString") marshalStringIdKey unmarshalStringName = varQual dOTNET (fsLit "unmarshalString") unmarshalStringIdKey checkDotnetResName = varQual dOTNET (fsLit "checkResult") checkDotnetResNameIdKey + +-- plugins +cORE_MONAD :: Module +cORE_MONAD = mkThisGhcModule (fsLit "CoreMonad") +pluginTyConName :: Name +pluginTyConName = tcQual cORE_MONAD (fsLit "Plugin") pluginTyConKey \end{code} %************************************************************************ @@ -914,6 +1079,15 @@ applicativeClassKey = mkPreludeClassUnique 34 foldableClassKey = mkPreludeClassUnique 35 traversableClassKey = mkPreludeClassUnique 36 + +genClassKey, gen1ClassKey, datatypeClassKey, constructorClassKey, + selectorClassKey :: Unique +genClassKey = mkPreludeClassUnique 37 +gen1ClassKey = mkPreludeClassUnique 38 + +datatypeClassKey = mkPreludeClassUnique 39 +constructorClassKey = mkPreludeClassUnique 40 +selectorClassKey = mkPreludeClassUnique 41 \end{code} %************************************************************************ @@ -973,11 +1147,12 @@ word32PrimTyConKey, word32TyConKey, word64PrimTyConKey, word64TyConKey, liftedConKey, unliftedConKey, anyBoxConKey, kindConKey, boxityConKey, typeConKey, threadIdPrimTyConKey, bcoPrimTyConKey, ptrTyConKey, - funPtrTyConKey, tVarPrimTyConKey :: Unique + funPtrTyConKey, tVarPrimTyConKey, eqPredPrimTyConKey :: Unique statePrimTyConKey = mkPreludeTyConUnique 50 stableNamePrimTyConKey = mkPreludeTyConUnique 51 -stableNameTyConKey = mkPreludeTyConUnique 52 -mutVarPrimTyConKey = mkPreludeTyConUnique 55 +stableNameTyConKey = mkPreludeTyConUnique 52 +eqPredPrimTyConKey = mkPreludeTyConUnique 53 +mutVarPrimTyConKey = mkPreludeTyConUnique 55 ioTyConKey = mkPreludeTyConUnique 56 wordPrimTyConKey = mkPreludeTyConUnique 58 wordTyConKey = mkPreludeTyConUnique 59 @@ -999,12 +1174,6 @@ funPtrTyConKey = mkPreludeTyConUnique 75 tVarPrimTyConKey = mkPreludeTyConUnique 76 --- Generic Type Constructors -crossTyConKey, plusTyConKey, genUnitTyConKey :: Unique -crossTyConKey = mkPreludeTyConUnique 79 -plusTyConKey = mkPreludeTyConUnique 80 -genUnitTyConKey = mkPreludeTyConUnique 81 - -- Parallel array type constructor parrTyConKey :: Unique parrTyConKey = mkPreludeTyConUnique 82 @@ -1017,9 +1186,8 @@ eitherTyConKey = mkPreludeTyConUnique 84 -- Super Kinds constructors -tySuperKindTyConKey, coSuperKindTyConKey :: Unique +tySuperKindTyConKey :: Unique tySuperKindTyConKey = mkPreludeTyConUnique 85 -coSuperKindTyConKey = mkPreludeTyConUnique 86 -- Kind constructors liftedTypeKindTyConKey, openTypeKindTyConKey, unliftedTypeKindTyConKey, @@ -1045,6 +1213,9 @@ csel2CoercionTyConKey = mkPreludeTyConUnique 100 cselRCoercionTyConKey = mkPreludeTyConUnique 101 +pluginTyConKey :: Unique +pluginTyConKey = mkPreludeTyConUnique 102 + unknownTyConKey, unknown1TyConKey, unknown2TyConKey, unknown3TyConKey, opaqueTyConKey :: Unique unknownTyConKey = mkPreludeTyConUnique 129 @@ -1056,8 +1227,43 @@ stringTyConKey :: Unique stringTyConKey = mkPreludeTyConUnique 134 +-- Generics (Unique keys) +v1TyConKey, u1TyConKey, par1TyConKey, rec1TyConKey, + k1TyConKey, m1TyConKey, sumTyConKey, prodTyConKey, + compTyConKey, rTyConKey, pTyConKey, dTyConKey, + cTyConKey, sTyConKey, rec0TyConKey, par0TyConKey, + d1TyConKey, c1TyConKey, s1TyConKey, noSelTyConKey, + repTyConKey, rep1TyConKey :: Unique + +v1TyConKey = mkPreludeTyConUnique 135 +u1TyConKey = mkPreludeTyConUnique 136 +par1TyConKey = mkPreludeTyConUnique 137 +rec1TyConKey = mkPreludeTyConUnique 138 +k1TyConKey = mkPreludeTyConUnique 139 +m1TyConKey = mkPreludeTyConUnique 140 + +sumTyConKey = mkPreludeTyConUnique 141 +prodTyConKey = mkPreludeTyConUnique 142 +compTyConKey = mkPreludeTyConUnique 143 + +rTyConKey = mkPreludeTyConUnique 144 +pTyConKey = mkPreludeTyConUnique 145 +dTyConKey = mkPreludeTyConUnique 146 +cTyConKey = mkPreludeTyConUnique 147 +sTyConKey = mkPreludeTyConUnique 148 + +rec0TyConKey = mkPreludeTyConUnique 149 +par0TyConKey = mkPreludeTyConUnique 150 +d1TyConKey = mkPreludeTyConUnique 151 +c1TyConKey = mkPreludeTyConUnique 152 +s1TyConKey = mkPreludeTyConUnique 153 +noSelTyConKey = mkPreludeTyConUnique 154 + +repTyConKey = mkPreludeTyConUnique 155 +rep1TyConKey = mkPreludeTyConUnique 156 + ---------------- Template Haskell ------------------- --- USES TyConUniques 100-129 +-- USES TyConUniques 200-299 ----------------------------------------------------- unitTyConKey :: Unique @@ -1120,10 +1326,11 @@ noMethodBindingErrorIdKey, nonExhaustiveGuardsErrorIdKey, runtimeErrorIdKey, parErrorIdKey, parIdKey, patErrorIdKey, realWorldPrimIdKey, recConErrorIdKey, recUpdErrorIdKey, - traceIdKey, + traceIdKey, wildCardKey, unpackCStringUtf8IdKey, unpackCStringAppendIdKey, unpackCStringFoldrIdKey, unpackCStringIdKey :: Unique -absentErrorIdKey = mkPreludeMiscIdUnique 1 +wildCardKey = mkPreludeMiscIdUnique 0 -- See Note [WildCard] +absentErrorIdKey = mkPreludeMiscIdUnique 1 augmentIdKey = mkPreludeMiscIdUnique 3 appendIdKey = mkPreludeMiscIdUnique 4 buildIdKey = mkPreludeMiscIdUnique 5 @@ -1207,6 +1414,9 @@ groupWithIdKey = mkPreludeMiscIdUnique 70 dollarIdKey = mkPreludeMiscIdUnique 71 +coercionTokenIdKey :: Unique +coercionTokenIdKey = mkPreludeMiscIdUnique 72 + -- Parallel array functions singletonPIdKey, nullPIdKey, lengthPIdKey, replicatePIdKey, mapPIdKey, filterPIdKey, zipPIdKey, crossMapPIdKey, indexPIdKey, toPIdKey, @@ -1235,6 +1445,9 @@ unmarshalStringIdKey = mkPreludeMiscIdUnique 97 checkDotnetResNameIdKey = mkPreludeMiscIdUnique 98 +undefinedKey :: Unique +undefinedKey = mkPreludeMiscIdUnique 99 + \end{code} Certain class operations from Prelude classes. They get their own @@ -1249,7 +1462,8 @@ fromIntegerClassOpKey, minusClassOpKey, fromRationalClassOpKey, enumFromClassOpKey, enumFromThenClassOpKey, enumFromToClassOpKey, enumFromThenToClassOpKey, eqClassOpKey, geClassOpKey, negateClassOpKey, - failMClassOpKey, bindMClassOpKey, thenMClassOpKey, returnMClassOpKey + failMClassOpKey, bindMClassOpKey, thenMClassOpKey, returnMClassOpKey, + fmapClassOpKey :: Unique fromIntegerClassOpKey = mkPreludeMiscIdUnique 102 minusClassOpKey = mkPreludeMiscIdUnique 103 @@ -1264,6 +1478,7 @@ failMClassOpKey = mkPreludeMiscIdUnique 112 bindMClassOpKey = mkPreludeMiscIdUnique 113 -- (>>=) thenMClassOpKey = mkPreludeMiscIdUnique 114 -- (>>) +fmapClassOpKey = mkPreludeMiscIdUnique 115 returnMClassOpKey = mkPreludeMiscIdUnique 117 -- Recursive do notation @@ -1287,9 +1502,23 @@ toAnnotationWrapperIdKey :: Unique toAnnotationWrapperIdKey = mkPreludeMiscIdUnique 126 +-- Conversion functions +fromIntegralIdKey, realToFracIdKey, toIntegerClassOpKey, toRationalClassOpKey :: Unique +fromIntegralIdKey = mkPreludeMiscIdUnique 127 +realToFracIdKey = mkPreludeMiscIdUnique 128 +toIntegerClassOpKey = mkPreludeMiscIdUnique 129 +toRationalClassOpKey = mkPreludeMiscIdUnique 130 + +-- Monad comprehensions +guardMIdKey, liftMIdKey, groupMIdKey, mzipIdKey :: Unique +guardMIdKey = mkPreludeMiscIdUnique 131 +liftMIdKey = mkPreludeMiscIdUnique 132 +groupMIdKey = mkPreludeMiscIdUnique 133 +mzipIdKey = mkPreludeMiscIdUnique 134 + ---------------- Template Haskell ------------------- --- USES IdUniques 200-399 +-- USES IdUniques 200-499 ----------------------------------------------------- \end{code} diff -Nru ghc-7.0.3/compiler/prelude/PrelRules.lhs ghc-7.2.1/compiler/prelude/PrelRules.lhs --- ghc-7.0.3/compiler/prelude/PrelRules.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/prelude/PrelRules.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -9,7 +9,7 @@ ToDo: check boundaries before folding, e.g. we can fold the Float addition - (i1 + i2) only if it results in a valid Float. + (i1 + i2) only if it results in a valid Float. \begin{code} {-# OPTIONS -optc-DNON_POSIX_SOURCE #-} @@ -22,24 +22,27 @@ import MkCore import Id import Literal -import PrimOp ( PrimOp(..), tagToEnumKey ) +import PrimOp ( PrimOp(..), tagToEnumKey ) import TysWiredIn -import TyCon ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon ) -import DataCon ( dataConTag, dataConTyCon, dataConWorkId, fIRST_TAG ) -import CoreUtils ( cheapEqExpr ) -import CoreUnfold ( exprIsConApp_maybe ) +import TysPrim +import TyCon ( tyConDataCons_maybe, isEnumerationTyCon, isNewTyCon ) +import DataCon ( dataConTag, dataConTyCon, dataConWorkId, fIRST_TAG ) +import CoreUtils ( cheapEqExpr, exprIsHNF ) +import CoreUnfold ( exprIsConApp_maybe ) import Type -import OccName ( occNameFS ) +import OccName ( occNameFS ) import PrelNames -import Maybes ( orElse ) -import Name ( Name, nameOccName ) +import Maybes ( orElse ) +import Name ( Name, nameOccName ) import Outputable import FastString -import StaticFlags ( opt_SimplExcessPrecision ) +import StaticFlags ( opt_SimplExcessPrecision ) import Constants +import BasicTypes import Data.Bits as Bits -import Data.Word ( Word ) +import Data.Int ( Int64 ) +import Data.Word ( Word, Word64 ) \end{code} @@ -48,39 +51,39 @@ primOpRules generates the rewrite rules for each primop These rules do what is often called "constant folding" E.g. the rules for +# might say - 4 +# 5 = 9 -Well, of course you'd need a lot of rules if you did it + 4 +# 5 = 9 +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 -which don't need to be built in are in GHC.Base. For +which don't need to be built in are in GHC.Base. For example: - x +# 0 = x + x +# 0 = x \begin{code} primOpRules :: PrimOp -> Name -> [CoreRule] primOpRules op op_name = primop_rule op where - -- A useful shorthand + -- A useful shorthand one_lit = oneLit op_name two_lits = twoLits op_name relop cmp = two_lits (cmpOp (\ord -> ord `cmp` EQ)) - -- Cunning. cmpOp compares the values to give an Ordering. - -- It applies its argument to that ordering value to turn - -- the ordering into a boolean value. (`cmp` EQ) is just the job. + -- Cunning. cmpOp compares the values to give an Ordering. + -- It applies its argument to that ordering value to turn + -- the ordering into a boolean value. (`cmp` EQ) is just the job. - -- ToDo: something for integer-shift ops? - -- NotOp + -- ToDo: something for integer-shift ops? + -- NotOp primop_rule TagToEnumOp = mkBasicRule op_name 2 tagToEnumRule primop_rule DataToTagOp = mkBasicRule op_name 2 dataToTagRule - -- Int operations + -- Int operations primop_rule IntAddOp = two_lits (intOp2 (+)) primop_rule IntSubOp = two_lits (intOp2 (-)) primop_rule IntMulOp = two_lits (intOp2 (*)) @@ -91,7 +94,7 @@ primop_rule ISraOp = two_lits (intShiftOp2 Bits.shiftR) primop_rule ISrlOp = two_lits (intShiftOp2 shiftRightLogical) - -- Word operations + -- Word operations primop_rule WordAddOp = two_lits (wordOp2 (+)) primop_rule WordSubOp = two_lits (wordOp2 (-)) primop_rule WordMulOp = two_lits (wordOp2 (*)) @@ -103,85 +106,86 @@ primop_rule SllOp = two_lits (wordShiftOp2 Bits.shiftL) primop_rule SrlOp = two_lits (wordShiftOp2 shiftRightLogical) - -- coercions - primop_rule Word2IntOp = one_lit (litCoerce word2IntLit) - primop_rule Int2WordOp = one_lit (litCoerce int2WordLit) - primop_rule Narrow8IntOp = one_lit (litCoerce narrow8IntLit) - primop_rule Narrow16IntOp = one_lit (litCoerce narrow16IntLit) - primop_rule Narrow32IntOp = one_lit (litCoerce narrow32IntLit) - primop_rule Narrow8WordOp = one_lit (litCoerce narrow8WordLit) - primop_rule Narrow16WordOp = one_lit (litCoerce narrow16WordLit) - primop_rule Narrow32WordOp = one_lit (litCoerce narrow32WordLit) - primop_rule OrdOp = one_lit (litCoerce char2IntLit) - primop_rule ChrOp = one_lit (predLitCoerce litFitsInChar int2CharLit) - primop_rule Float2IntOp = one_lit (litCoerce float2IntLit) - primop_rule Int2FloatOp = one_lit (litCoerce int2FloatLit) - primop_rule Double2IntOp = one_lit (litCoerce double2IntLit) - primop_rule Int2DoubleOp = one_lit (litCoerce int2DoubleLit) - -- SUP: Not sure what the standard says about precision in the following 2 cases - primop_rule Float2DoubleOp = one_lit (litCoerce float2DoubleLit) - primop_rule Double2FloatOp = one_lit (litCoerce double2FloatLit) + -- coercions + primop_rule Word2IntOp = one_lit (litCoerce word2IntLit) + primop_rule Int2WordOp = one_lit (litCoerce int2WordLit) + primop_rule Narrow8IntOp = one_lit (litCoerce narrow8IntLit) + primop_rule Narrow16IntOp = one_lit (litCoerce narrow16IntLit) + primop_rule Narrow32IntOp = one_lit (litCoerce narrow32IntLit) + primop_rule Narrow8WordOp = one_lit (litCoerce narrow8WordLit) + primop_rule Narrow16WordOp = one_lit (litCoerce narrow16WordLit) + primop_rule Narrow32WordOp = one_lit (litCoerce narrow32WordLit) + primop_rule OrdOp = one_lit (litCoerce char2IntLit) + primop_rule ChrOp = one_lit (predLitCoerce litFitsInChar int2CharLit) + primop_rule Float2IntOp = one_lit (litCoerce float2IntLit) + primop_rule Int2FloatOp = one_lit (litCoerce int2FloatLit) + primop_rule Double2IntOp = one_lit (litCoerce double2IntLit) + primop_rule Int2DoubleOp = one_lit (litCoerce int2DoubleLit) + -- SUP: Not sure what the standard says about precision in the following 2 cases + primop_rule Float2DoubleOp = one_lit (litCoerce float2DoubleLit) + primop_rule Double2FloatOp = one_lit (litCoerce double2FloatLit) - -- Float + -- Float primop_rule FloatAddOp = two_lits (floatOp2 (+)) primop_rule FloatSubOp = two_lits (floatOp2 (-)) primop_rule FloatMulOp = two_lits (floatOp2 (*)) primop_rule FloatDivOp = two_lits (floatOp2Z (/)) primop_rule FloatNegOp = one_lit negOp - -- Double + -- Double primop_rule DoubleAddOp = two_lits (doubleOp2 (+)) primop_rule DoubleSubOp = two_lits (doubleOp2 (-)) primop_rule DoubleMulOp = two_lits (doubleOp2 (*)) primop_rule DoubleDivOp = two_lits (doubleOp2Z (/)) primop_rule DoubleNegOp = one_lit negOp - -- Relational operators - primop_rule IntEqOp = relop (==) ++ litEq op_name True - primop_rule IntNeOp = relop (/=) ++ litEq op_name False - primop_rule CharEqOp = relop (==) ++ litEq op_name True - primop_rule CharNeOp = relop (/=) ++ litEq op_name False - - primop_rule IntGtOp = relop (>) - primop_rule IntGeOp = relop (>=) - primop_rule IntLeOp = relop (<=) - primop_rule IntLtOp = relop (<) - - primop_rule CharGtOp = relop (>) - primop_rule CharGeOp = relop (>=) - primop_rule CharLeOp = relop (<=) - primop_rule CharLtOp = relop (<) - - primop_rule FloatGtOp = relop (>) - primop_rule FloatGeOp = relop (>=) - primop_rule FloatLeOp = relop (<=) - primop_rule FloatLtOp = relop (<) - primop_rule FloatEqOp = relop (==) - primop_rule FloatNeOp = relop (/=) - - primop_rule DoubleGtOp = relop (>) - primop_rule DoubleGeOp = relop (>=) - primop_rule DoubleLeOp = relop (<=) - primop_rule DoubleLtOp = relop (<) - primop_rule DoubleEqOp = relop (==) - primop_rule DoubleNeOp = relop (/=) - - primop_rule WordGtOp = relop (>) - primop_rule WordGeOp = relop (>=) - primop_rule WordLeOp = relop (<=) - primop_rule WordLtOp = relop (<) - primop_rule WordEqOp = relop (==) - primop_rule WordNeOp = relop (/=) - - primop_rule _ = [] + -- Relational operators + primop_rule IntEqOp = relop (==) ++ litEq op_name True + primop_rule IntNeOp = relop (/=) ++ litEq op_name False + primop_rule CharEqOp = relop (==) ++ litEq op_name True + primop_rule CharNeOp = relop (/=) ++ litEq op_name False + + primop_rule IntGtOp = relop (>) ++ boundsCmp op_name Gt + primop_rule IntGeOp = relop (>=) ++ boundsCmp op_name Ge + primop_rule IntLeOp = relop (<=) ++ boundsCmp op_name Le + primop_rule IntLtOp = relop (<) ++ boundsCmp op_name Lt + + primop_rule CharGtOp = relop (>) ++ boundsCmp op_name Gt + primop_rule CharGeOp = relop (>=) ++ boundsCmp op_name Ge + primop_rule CharLeOp = relop (<=) ++ boundsCmp op_name Le + primop_rule CharLtOp = relop (<) ++ boundsCmp op_name Lt + + primop_rule FloatGtOp = relop (>) + primop_rule FloatGeOp = relop (>=) + primop_rule FloatLeOp = relop (<=) + primop_rule FloatLtOp = relop (<) + primop_rule FloatEqOp = relop (==) + primop_rule FloatNeOp = relop (/=) + + primop_rule DoubleGtOp = relop (>) + primop_rule DoubleGeOp = relop (>=) + primop_rule DoubleLeOp = relop (<=) + primop_rule DoubleLtOp = relop (<) + primop_rule DoubleEqOp = relop (==) + primop_rule DoubleNeOp = relop (/=) + + primop_rule WordGtOp = relop (>) ++ boundsCmp op_name Gt + primop_rule WordGeOp = relop (>=) ++ boundsCmp op_name Ge + primop_rule WordLeOp = relop (<=) ++ boundsCmp op_name Le + primop_rule WordLtOp = relop (<) ++ boundsCmp op_name Lt + primop_rule WordEqOp = relop (==) + primop_rule WordNeOp = relop (/=) + primop_rule SeqOp = mkBasicRule op_name 4 seqRule + primop_rule SparkOp = mkBasicRule op_name 4 sparkRule + primop_rule _ = [] \end{code} %************************************************************************ -%* * +%* * \subsection{Doing the business} -%* * +%* * %************************************************************************ ToDo: the reason these all return Nothing is because there used to be @@ -204,9 +208,9 @@ = go l1 l2 where done res | cmp res = Just trueVal - | otherwise = Just falseVal + | otherwise = Just falseVal - -- These compares are at different types + -- These compares are at different types go (MachChar i1) (MachChar i2) = done (i1 `compare` i2) go (MachInt i1) (MachInt i2) = done (i1 `compare` i2) go (MachInt64 i1) (MachInt64 i2) = done (i1 `compare` i2) @@ -218,7 +222,7 @@ -------------------------- -negOp :: Literal -> Maybe CoreExpr -- Negate +negOp :: Literal -> Maybe CoreExpr -- Negate negOp (MachFloat 0.0) = Nothing -- can't represent -0.0 as a Rational negOp (MachFloat f) = Just (mkFloatVal (-f)) negOp (MachDouble 0.0) = Nothing @@ -229,22 +233,22 @@ -------------------------- intOp2 :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr intOp2 op (MachInt i1) (MachInt i2) = intResult (i1 `op` i2) -intOp2 _ _ _ = Nothing -- Could find LitLit +intOp2 _ _ _ = Nothing -- Could find LitLit intOp2Z :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr -- Like intOp2, but Nothing if i2=0 intOp2Z op (MachInt i1) (MachInt i2) | i2 /= 0 = intResult (i1 `op` i2) -intOp2Z _ _ _ = Nothing -- LitLit or zero dividend +intOp2Z _ _ _ = Nothing -- LitLit or zero dividend intShiftOp2 :: (Integer->Int->Integer) -> Literal -> Literal -> Maybe CoreExpr - -- Shifts take an Int; hence second arg of op is Int +-- Shifts take an Int; hence second arg of op is Int intShiftOp2 op (MachInt i1) (MachInt i2) = intResult (i1 `op` fromInteger i2) -intShiftOp2 _ _ _ = Nothing +intShiftOp2 _ _ _ = Nothing shiftRightLogical :: Integer -> Int -> Integer -- Shift right, putting zeros in rather than sign-propagating as Bits.shiftR would do --- Do this by converting to Word and back. Obviously this won't work for big +-- Do this by converting to Word and back. Obviously this won't work for big -- values, but its ok as we use it here shiftRightLogical x n = fromIntegral (fromInteger x `shiftR` n :: Word) @@ -253,25 +257,25 @@ wordOp2 :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr wordOp2 op (MachWord w1) (MachWord w2) = wordResult (w1 `op` w2) -wordOp2 _ _ _ = Nothing -- Could find LitLit +wordOp2 _ _ _ = Nothing -- Could find LitLit wordOp2Z :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr wordOp2Z op (MachWord w1) (MachWord w2) | w2 /= 0 = wordResult (w1 `op` w2) -wordOp2Z _ _ _ = Nothing -- LitLit or zero dividend +wordOp2Z _ _ _ = Nothing -- LitLit or zero dividend wordBitOp2 :: (Integer->Integer->Integer) -> Literal -> Literal -> Maybe CoreExpr wordBitOp2 op (MachWord w1) (MachWord w2) = wordResult (w1 `op` w2) -wordBitOp2 _ _ _ = Nothing -- Could find LitLit +wordBitOp2 _ _ _ = Nothing -- Could find LitLit wordShiftOp2 :: (Integer->Int->Integer) -> Literal -> Literal -> Maybe CoreExpr - -- Shifts take an Int; hence second arg of op is Int -wordShiftOp2 op (MachWord x) (MachInt n) +-- Shifts take an Int; hence second arg of op is Int +wordShiftOp2 op (MachWord x) (MachInt n) = wordResult (x `op` fromInteger n) - -- Do the shift at type Integer -wordShiftOp2 _ _ _ = Nothing + -- Do the shift at type Integer +wordShiftOp2 _ _ _ = Nothing -------------------------- floatOp2 :: (Rational -> Rational -> Rational) -> Literal -> Literal @@ -309,46 +313,93 @@ -------------------------- - -- This stuff turns - -- n ==# 3# - -- into - -- case n of - -- 3# -> True - -- m -> False - -- - -- This is a Good Thing, because it allows case-of case things - -- to happen, and case-default absorption to happen. For - -- example: - -- - -- if (n ==# 3#) || (n ==# 4#) then e1 else e2 - -- will transform to - -- case n of - -- 3# -> e1 - -- 4# -> e1 - -- m -> e2 - -- (modulo the usual precautions to avoid duplicating e1) +-- This stuff turns +-- n ==# 3# +-- into +-- case n of +-- 3# -> True +-- m -> False +-- +-- This is a Good Thing, because it allows case-of case things +-- to happen, and case-default absorption to happen. For +-- example: +-- +-- if (n ==# 3#) || (n ==# 4#) then e1 else e2 +-- will transform to +-- case n of +-- 3# -> e1 +-- 4# -> e1 +-- m -> e2 +-- (modulo the usual precautions to avoid duplicating e1) -litEq :: Name - -> Bool -- True <=> equality, False <=> inequality +litEq :: Name + -> Bool -- True <=> equality, False <=> inequality -> [CoreRule] litEq op_name is_eq - = [BuiltinRule { ru_name = occNameFS (nameOccName op_name) - `appendFS` (fsLit "->case"), - ru_fn = op_name, - ru_nargs = 2, ru_try = rule_fn }] + = [BuiltinRule { ru_name = occNameFS (nameOccName op_name) + `appendFS` (fsLit "->case"), + ru_fn = op_name, + ru_nargs = 2, ru_try = rule_fn }] where rule_fn _ [Lit lit, expr] = do_lit_eq lit expr rule_fn _ [expr, Lit lit] = do_lit_eq lit expr - rule_fn _ _ = Nothing - + rule_fn _ _ = Nothing + do_lit_eq lit expr = Just (mkWildCase expr (literalType lit) boolTy - [(DEFAULT, [], val_if_neq), - (LitAlt lit, [], val_if_eq)]) + [(DEFAULT, [], val_if_neq), + (LitAlt lit, [], val_if_eq)]) val_if_eq | is_eq = trueVal - | otherwise = falseVal + | otherwise = falseVal val_if_neq | is_eq = falseVal - | otherwise = trueVal + | otherwise = trueVal + + +-- | Check if there is comparison with minBound or maxBound, that is +-- always true or false. For instance, an Int cannot be smaller than its +-- minBound, so we can replace such comparison with False. +boundsCmp :: Name -> Comparison -> [CoreRule] +boundsCmp op_name op = [ rule ] + where + rule = BuiltinRule + { ru_name = occNameFS (nameOccName op_name) + `appendFS` (fsLit "min/maxBound") + , ru_fn = op_name + , ru_nargs = 2 + , ru_try = rule_fn + } + rule_fn _ [a, b] = mkRuleFn op a b + rule_fn _ _ = Nothing + +data Comparison = Gt | Ge | Lt | Le + +mkRuleFn :: Comparison -> CoreExpr -> CoreExpr -> Maybe CoreExpr +mkRuleFn Gt (Lit lit) _ | isMinBound lit = Just falseVal +mkRuleFn Le (Lit lit) _ | isMinBound lit = Just trueVal +mkRuleFn Ge _ (Lit lit) | isMinBound lit = Just trueVal +mkRuleFn Lt _ (Lit lit) | isMinBound lit = Just falseVal +mkRuleFn Ge (Lit lit) _ | isMaxBound lit = Just trueVal +mkRuleFn Lt (Lit lit) _ | isMaxBound lit = Just falseVal +mkRuleFn Gt _ (Lit lit) | isMaxBound lit = Just falseVal +mkRuleFn Le _ (Lit lit) | isMaxBound lit = Just trueVal +mkRuleFn _ _ _ = Nothing + +isMinBound :: Literal -> Bool +isMinBound (MachChar c) = c == minBound +isMinBound (MachInt i) = i == toInteger (minBound :: Int) +isMinBound (MachInt64 i) = i == toInteger (minBound :: Int64) +isMinBound (MachWord i) = i == toInteger (minBound :: Word) +isMinBound (MachWord64 i) = i == toInteger (minBound :: Word64) +isMinBound _ = False + +isMaxBound :: Literal -> Bool +isMaxBound (MachChar c) = c == maxBound +isMaxBound (MachInt i) = i == toInteger (maxBound :: Int) +isMaxBound (MachInt64 i) = i == toInteger (maxBound :: Int64) +isMaxBound (MachWord i) = i == toInteger (maxBound :: Word) +isMaxBound (MachWord64 i) = i == toInteger (maxBound :: Word64) +isMaxBound _ = False + -- Note that we *don't* warn the user about overflow. It's not done at -- runtime either, and compilation of completely harmless things like @@ -366,9 +417,9 @@ %************************************************************************ -%* * -\subsection{Vaguely generic functions -%* * +%* * +\subsection{Vaguely generic functions} +%* * %************************************************************************ \begin{code} @@ -378,8 +429,8 @@ -- Gives the Rule the same name as the primop itself mkBasicRule op_name n_args rule_fn = [BuiltinRule { ru_name = occNameFS (nameOccName op_name), - ru_fn = op_name, - ru_nargs = n_args, ru_try = rule_fn }] + ru_fn = op_name, + ru_nargs = n_args, ru_try = rule_fn }] oneLit :: Name -> (Literal -> Maybe CoreExpr) -> [CoreRule] @@ -390,8 +441,8 @@ rule_fn _ _ = Nothing twoLits :: Name -> (Literal -> Literal -> Maybe CoreExpr) - -> [CoreRule] -twoLits op_name test + -> [CoreRule] +twoLits op_name test = mkBasicRule op_name 2 rule_fn where rule_fn _ [Lit l1, Lit l2] = test (convFloating l1) (convFloating l2) @@ -420,11 +471,11 @@ mkDoubleVal d = Lit (convFloating (MachDouble d)) \end{code} - + %************************************************************************ -%* * +%* * \subsection{Special rules for seq, tagToEnum, dataToTag} -%* * +%* * %************************************************************************ Note [tagToEnum#] @@ -434,11 +485,11 @@ check won't see that, alas. It's crude but it works. Here's are two cases that should fail - f :: forall a. a - f = tagToEnum# 0 -- Can't do tagToEnum# at a type variable + f :: forall a. a + f = tagToEnum# 0 -- Can't do tagToEnum# at a type variable - g :: Int - g = tagToEnum# 0 -- Int is not an enumeration + g :: Int + g = tagToEnum# 0 -- Int is not an enumeration We used to make this check in the type inference engine, but it's quite ugly to do so, because the delayed constraint solving means that we don't @@ -456,13 +507,13 @@ | Just (tycon, tc_args) <- splitTyConApp_maybe ty , isEnumerationTyCon tycon = case filter correct_tag (tyConDataCons_maybe tycon `orElse` []) of - [] -> Nothing -- Abstract type - (dc:rest) -> ASSERT( null rest ) - Just (mkTyApps (Var (dataConWorkId dc)) tc_args) - | otherwise -- See Note [tagToEnum#] + [] -> Nothing -- Abstract type + (dc:rest) -> ASSERT( null rest ) + Just (mkTyApps (Var (dataConWorkId dc)) tc_args) + | otherwise -- See Note [tagToEnum#] = WARN( True, ptext (sLit "tagToEnum# on non-enumeration type") <+> ppr ty ) Just (mkRuntimeErrorApp rUNTIME_ERROR_ID ty "tagToEnum# on non-enumeration type") - where + where correct_tag dc = (dataConTag dc - fIRST_TAG) == tag tag = fromInteger i @@ -470,17 +521,17 @@ \end{code} -For dataToTag#, we can reduce if either - - (a) the argument is a constructor - (b) the argument is a variable whose unfolding is a known constructor +For dataToTag#, we can reduce if either + + (a) the argument is a constructor + (b) the argument is a variable whose unfolding is a known constructor \begin{code} dataToTagRule :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Arg CoreBndr) dataToTagRule _ [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag] | tag_to_enum `hasKey` tagToEnumKey - , ty1 `coreEqType` ty2 - = Just tag -- dataToTag (tagToEnum x) ==> x + , ty1 `eqType` ty2 + = Just tag -- dataToTag (tagToEnum x) ==> x dataToTagRule id_unf [_, val_arg] | Just (dc,_,_) <- exprIsConApp_maybe id_unf val_arg @@ -491,9 +542,30 @@ \end{code} %************************************************************************ -%* * +%* * +\subsection{Rules for seq# and spark#} +%* * +%************************************************************************ + +\begin{code} +-- seq# :: forall a s . a -> State# s -> (# State# s, a #) +seqRule :: IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr +seqRule _ [ty_a, Type ty_s, a, s] | exprIsHNF a + = Just (mkConApp (tupleCon Unboxed 2) + [Type (mkStatePrimTy ty_s), ty_a, s, a]) +seqRule _ _ = Nothing + +-- spark# :: forall a s . a -> State# s -> (# State# s, a #) +sparkRule :: IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr +sparkRule = seqRule -- reduce on HNF, just the same + -- XXX perhaps we shouldn't do this, because a spark eliminated by + -- this rule won't be counted as a dud at runtime? +\end{code} + +%************************************************************************ +%* * \subsection{Built in rules} -%* * +%* * %************************************************************************ Note [Scoping for Builtin rules] @@ -502,17 +574,17 @@ functions mentioned in the RHS of a built-in rule, there's a danger that we'll see - f = ...(eq String x).... + f = ...(eq String x).... - ....and lower down... + ....and lower down... - eqString = ... + eqString = ... Then a rewrite would give - f = ...(eqString x)... - ....and lower down... - eqString = ... + f = ...(eqString x)... + ....and lower down... + eqString = ... and lo, eqString is not in scope. This only really matters when we get to code generation. With -O we do a GlomBinds step that does a new SCC analysis on the whole @@ -528,45 +600,45 @@ -- Rules for non-primops that can't be expressed using a RULE pragma builtinRules = [ BuiltinRule { ru_name = fsLit "AppendLitString", ru_fn = unpackCStringFoldrName, - ru_nargs = 4, ru_try = match_append_lit }, + ru_nargs = 4, ru_try = match_append_lit }, BuiltinRule { ru_name = fsLit "EqString", ru_fn = eqStringName, - ru_nargs = 2, ru_try = match_eq_string }, + ru_nargs = 2, ru_try = match_eq_string }, BuiltinRule { ru_name = fsLit "Inline", ru_fn = inlineIdName, - ru_nargs = 2, ru_try = match_inline } + ru_nargs = 2, ru_try = match_inline } ] --------------------------------------------------- -- The rule is this: --- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n) +-- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n) -- = unpackFoldrCString# "foobaz" c n match_append_lit :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr) match_append_lit _ [Type ty1, - Lit (MachStr s1), - c1, - Var unpk `App` Type ty2 - `App` Lit (MachStr s2) - `App` c2 - `App` n - ] - | unpk `hasKey` unpackCStringFoldrIdKey && + Lit (MachStr s1), + c1, + Var unpk `App` Type ty2 + `App` Lit (MachStr s2) + `App` c2 + `App` n + ] + | unpk `hasKey` unpackCStringFoldrIdKey && c1 `cheapEqExpr` c2 - = ASSERT( ty1 `coreEqType` ty2 ) + = ASSERT( ty1 `eqType` ty2 ) Just (Var unpk `App` Type ty1 - `App` Lit (MachStr (s1 `appendFS` s2)) - `App` c1 - `App` n) + `App` Lit (MachStr (s1 `appendFS` s2)) + `App` c1 + `App` n) match_append_lit _ _ = Nothing --------------------------------------------------- -- The rule is this: --- eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==s2 +-- eqString (unpackCString# (Lit s1)) (unpackCString# (Lit s2) = s1==s2 match_eq_string :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Expr CoreBndr) match_eq_string _ [Var unpk1 `App` Lit (MachStr s1), - Var unpk2 `App` Lit (MachStr s2)] + Var unpk2 `App` Lit (MachStr s2)] | unpk1 `hasKey` unpackCStringIdKey, unpk2 `hasKey` unpackCStringIdKey = Just (if s1 == s2 then trueVal else falseVal) @@ -576,14 +648,14 @@ --------------------------------------------------- -- The rule is this: --- inline f_ty (f a b c) = a b c +-- inline f_ty (f a b c) = a b c -- (if f has an unfolding, EVEN if it's a loop breaker) -- -- It's important to allow the argument to 'inline' to have args itself -- (a) because its more forgiving to allow the programmer to write --- inline f a b c +-- inline f a b c -- or inline (f a b c) --- (b) because a polymorphic f wll get a type argument that the +-- (b) because a polymorphic f wll get a type argument that the -- programmer can't avoid -- -- Also, don't forget about 'inline's type argument! @@ -591,9 +663,8 @@ match_inline _ (Type _ : e : _) | (Var f, args1) <- collectArgs e, Just unf <- maybeUnfoldingTemplate (realIdUnfolding f) - -- Ignore the IdUnfoldingFun here! + -- Ignore the IdUnfoldingFun here! = Just (mkApps unf args1) match_inline _ _ = Nothing \end{code} - diff -Nru ghc-7.0.3/compiler/prelude/PrimOp.lhs ghc-7.2.1/compiler/prelude/PrimOp.lhs --- ghc-7.0.3/compiler/prelude/PrimOp.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/prelude/PrimOp.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -18,8 +18,8 @@ tagToEnumKey, - primOpOutOfLine, primOpNeedsWrapper, - primOpOkForSpeculation, primOpIsCheap, primOpIsDupable, + primOpOutOfLine, primOpCodeSize, + primOpOkForSpeculation, primOpIsCheap, getPrimOpResultInfo, PrimOpResultInfo(..), @@ -363,19 +363,24 @@ -- even if primOpIsCheap sometimes says 'True'. \end{code} -primOpIsDupable -~~~~~~~~~~~~~~~ -primOpIsDupable means that the use of the primop is small enough to -duplicate into different case branches. See CoreUtils.exprIsDupable. +primOpCodeSize +~~~~~~~~~~~~~~ +Gives an indication of the code size of a primop, for the purposes of +calculating unfolding sizes; see CoreUnfold.sizeExpr. + +\begin{code} +primOpCodeSize :: PrimOp -> Int +#include "primop-code-size.hs-incl" + +primOpCodeSizeDefault :: Int +primOpCodeSizeDefault = 1 + -- CoreUnfold.primOpSize already takes into account primOpOutOfLine + -- and adds some further costs for the args in that case. -\begin{code} -primOpIsDupable :: PrimOp -> Bool - -- See comments with CoreUtils.exprIsDupable - -- We say it's dupable it isn't implemented by a C call with a wrapper -primOpIsDupable op = not (primOpNeedsWrapper op) +primOpCodeSizeForeignCall :: Int +primOpCodeSizeForeignCall = 4 \end{code} - \begin{code} primOpCanFail :: PrimOp -> Bool #include "primop-can-fail.hs-incl" @@ -421,14 +426,6 @@ #include "primop-has-side-effects.hs-incl" \end{code} -Inline primitive operations that perform calls need wrappers to save -any live variables that are stored in caller-saves registers. - -\begin{code} -primOpNeedsWrapper :: PrimOp -> Bool -#include "primop-needs-wrapper.hs-incl" -\end{code} - \begin{code} primOpType :: PrimOp -> Type -- you may want to use primOpSig instead primOpType op diff -Nru ghc-7.0.3/compiler/prelude/primops.txt.pp ghc-7.2.1/compiler/prelude/primops.txt.pp --- ghc-7.0.3/compiler/prelude/primops.txt.pp 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/prelude/primops.txt.pp 2011-08-07 17:10:05.000000000 +0000 @@ -43,7 +43,7 @@ has_side_effects = False out_of_line = False commutable = False - needs_wrapper = False + code_size = { primOpCodeSizeDefault } can_fail = False strictness = { \ arity -> mkStrictSig (mkTopDmdType (replicate arity lazyDmd) TopRes) } @@ -155,6 +155,7 @@ primop CharLeOp "leChar#" Compare Char# -> Char# -> Bool primop OrdOp "ord#" GenPrimOp Char# -> Int# + with code_size = 0 ------------------------------------------------------------------------ section "Int#" @@ -212,9 +213,12 @@ primop IntAddCOp "addIntC#" GenPrimOp Int# -> Int# -> (# Int#, Int# #) {Add with carry. First member of result is (wrapped) sum; second member is 0 iff no overflow occured.} + with code_size = 2 + primop IntSubCOp "subIntC#" GenPrimOp Int# -> Int# -> (# Int#, Int# #) {Subtract with carry. First member of result is (wrapped) difference; second member is 0 iff no overflow occured.} + with code_size = 2 primop IntGtOp ">#" Compare Int# -> Int# -> Bool primop IntGeOp ">=#" Compare Int# -> Int# -> Bool @@ -231,8 +235,11 @@ primop IntLeOp "<=#" Compare Int# -> Int# -> Bool primop ChrOp "chr#" GenPrimOp Int# -> Char# + with code_size = 0 primop Int2WordOp "int2Word#" GenPrimOp Int# -> Word# + with code_size = 0 + primop Int2FloatOp "int2Float#" GenPrimOp Int# -> Float# primop Int2DoubleOp "int2Double#" GenPrimOp Int# -> Double# @@ -286,6 +293,7 @@ in the range 0 to word size - 1 inclusive.} primop Word2IntOp "word2Int#" GenPrimOp Word# -> Int# + with code_size = 0 primop WordGtOp "gtWord#" Compare Word# -> Word# -> Bool primop WordGeOp "geWord#" Compare Word# -> Word# -> Bool @@ -396,63 +404,72 @@ primop DoubleExpOp "expDouble#" Monadic Double# -> Double# - with needs_wrapper = True + with + code_size = { primOpCodeSizeForeignCall } primop DoubleLogOp "logDouble#" Monadic Double# -> Double# with - needs_wrapper = True + code_size = { primOpCodeSizeForeignCall } can_fail = True primop DoubleSqrtOp "sqrtDouble#" Monadic Double# -> Double# - with needs_wrapper = True + with + code_size = { primOpCodeSizeForeignCall } primop DoubleSinOp "sinDouble#" Monadic Double# -> Double# - with needs_wrapper = True + with + code_size = { primOpCodeSizeForeignCall } primop DoubleCosOp "cosDouble#" Monadic Double# -> Double# - with needs_wrapper = True + with + code_size = { primOpCodeSizeForeignCall } primop DoubleTanOp "tanDouble#" Monadic Double# -> Double# - with needs_wrapper = True + with + code_size = { primOpCodeSizeForeignCall } primop DoubleAsinOp "asinDouble#" Monadic Double# -> Double# with - needs_wrapper = True + code_size = { primOpCodeSizeForeignCall } can_fail = True primop DoubleAcosOp "acosDouble#" Monadic Double# -> Double# with - needs_wrapper = True + code_size = { primOpCodeSizeForeignCall } can_fail = True primop DoubleAtanOp "atanDouble#" Monadic Double# -> Double# with - needs_wrapper = True + code_size = { primOpCodeSizeForeignCall } primop DoubleSinhOp "sinhDouble#" Monadic Double# -> Double# - with needs_wrapper = True + with + code_size = { primOpCodeSizeForeignCall } primop DoubleCoshOp "coshDouble#" Monadic Double# -> Double# - with needs_wrapper = True + with + code_size = { primOpCodeSizeForeignCall } primop DoubleTanhOp "tanhDouble#" Monadic Double# -> Double# - with needs_wrapper = True + with + code_size = { primOpCodeSizeForeignCall } primop DoublePowerOp "**##" Dyadic Double# -> Double# -> Double# {Exponentiation.} - with needs_wrapper = True + with + code_size = { primOpCodeSizeForeignCall } primop DoubleDecode_2IntOp "decodeDouble_2Int#" GenPrimOp Double# -> (# Int#, Word#, Word#, Int# #) @@ -506,58 +523,71 @@ primop FloatExpOp "expFloat#" Monadic Float# -> Float# - with needs_wrapper = True + with + code_size = { primOpCodeSizeForeignCall } primop FloatLogOp "logFloat#" Monadic Float# -> Float# - with needs_wrapper = True - can_fail = True + with + code_size = { primOpCodeSizeForeignCall } + can_fail = True primop FloatSqrtOp "sqrtFloat#" Monadic Float# -> Float# - with needs_wrapper = True + with + code_size = { primOpCodeSizeForeignCall } primop FloatSinOp "sinFloat#" Monadic Float# -> Float# - with needs_wrapper = True + with + code_size = { primOpCodeSizeForeignCall } primop FloatCosOp "cosFloat#" Monadic Float# -> Float# - with needs_wrapper = True + with + code_size = { primOpCodeSizeForeignCall } primop FloatTanOp "tanFloat#" Monadic Float# -> Float# - with needs_wrapper = True + with + code_size = { primOpCodeSizeForeignCall } primop FloatAsinOp "asinFloat#" Monadic Float# -> Float# - with needs_wrapper = True - can_fail = True + with + code_size = { primOpCodeSizeForeignCall } + can_fail = True primop FloatAcosOp "acosFloat#" Monadic Float# -> Float# - with needs_wrapper = True - can_fail = True + with + code_size = { primOpCodeSizeForeignCall } + can_fail = True primop FloatAtanOp "atanFloat#" Monadic Float# -> Float# - with needs_wrapper = True + with + code_size = { primOpCodeSizeForeignCall } primop FloatSinhOp "sinhFloat#" Monadic Float# -> Float# - with needs_wrapper = True + with + code_size = { primOpCodeSizeForeignCall } primop FloatCoshOp "coshFloat#" Monadic Float# -> Float# - with needs_wrapper = True + with + code_size = { primOpCodeSizeForeignCall } primop FloatTanhOp "tanhFloat#" Monadic Float# -> Float# - with needs_wrapper = True + with + code_size = { primOpCodeSizeForeignCall } primop FloatPowerOp "powerFloat#" Dyadic Float# -> Float# -> Float# - with needs_wrapper = True + with + code_size = { primOpCodeSizeForeignCall } primop Float2DoubleOp "float2Double#" GenPrimOp Float# -> Double# @@ -599,6 +629,15 @@ {Write to specified index of mutable array.} with has_side_effects = True + code_size = 2 -- card update too + +primop SizeofArrayOp "sizeofArray#" GenPrimOp + Array# a -> Int# + {Return the number of elements in the array.} + +primop SizeofMutableArrayOp "sizeofMutableArray#" GenPrimOp + MutableArray# s a -> Int# + {Return the number of elements in the array.} primop IndexArrayOp "indexArray#" GenPrimOp Array# a -> Int# -> (# a #) @@ -618,6 +657,55 @@ out_of_line = True has_side_effects = True +primop CopyArrayOp "copyArray#" GenPrimOp + Array# a -> Int# -> MutableArray# s a -> Int# -> Int# -> State# s -> State# s + {Copy a range of the Array# to the specified region in the MutableArray#. + Both arrays must fully contain the specified ranges, but this is not checked. + The two arrays must not be the same array in different states, but this is not checked either.} + with + has_side_effects = True + code_size = { primOpCodeSizeForeignCall + 4 } + +primop CopyMutableArrayOp "copyMutableArray#" GenPrimOp + MutableArray# s a -> Int# -> MutableArray# s a -> Int# -> Int# -> State# s -> State# s + {Copy a range of the first MutableArray# to the specified region in the second MutableArray#. + Both arrays must fully contain the specified ranges, but this is not checked.} + with + has_side_effects = True + code_size = { primOpCodeSizeForeignCall + 4 } + +primop CloneArrayOp "cloneArray#" GenPrimOp + Array# a -> Int# -> Int# -> Array# a + {Return a newly allocated Array# with the specified subrange of the provided Array#. + The provided Array# should contain the full subrange specified by the two Int#s, but this is not checked.} + with + has_side_effects = True + code_size = { primOpCodeSizeForeignCall + 4 } + +primop CloneMutableArrayOp "cloneMutableArray#" GenPrimOp + MutableArray# s a -> Int# -> Int# -> State# s -> (# State# s, MutableArray# s a #) + {Return a newly allocated Array# with the specified subrange of the provided Array#. + The provided MutableArray# should contain the full subrange specified by the two Int#s, but this is not checked.} + with + has_side_effects = True + code_size = { primOpCodeSizeForeignCall + 4 } + +primop FreezeArrayOp "freezeArray#" GenPrimOp + MutableArray# s a -> Int# -> Int# -> State# s -> (# State# s, Array# a #) + {Return a newly allocated Array# with the specified subrange of the provided MutableArray#. + The provided MutableArray# should contain the full subrange specified by the two Int#s, but this is not checked.} + with + has_side_effects = True + code_size = { primOpCodeSizeForeignCall + 4 } + +primop ThawArrayOp "thawArray#" GenPrimOp + Array# a -> Int# -> Int# -> State# s -> (# State# s, MutableArray# s a #) + {Return a newly allocated Array# with the specified subrange of the provided MutableArray#. + The provided Array# should contain the full subrange specified by the two Int#s, but this is not checked.} + with + has_side_effects = True + code_size = { primOpCodeSizeForeignCall + 4 } + ------------------------------------------------------------------------ section "Byte Arrays" {Operations on {\tt ByteArray\#}. A {\tt ByteArray\#} is a just a region of @@ -859,6 +947,23 @@ MutableByteArray# s -> Int# -> WORD64 -> State# s -> State# s with has_side_effects = True +primop CopyByteArrayOp "copyByteArray#" GenPrimOp + ByteArray# -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s + {Copy a range of the ByteArray# to the specified region in the MutableByteArray#. + Both arrays must fully contain the specified ranges, but this is not checked. + The two arrays must not be the same array in different states, but this is not checked either.} + with + has_side_effects = True + code_size = { primOpCodeSizeForeignCall } + +primop CopyMutableByteArrayOp "copyMutableByteArray#" GenPrimOp + MutableByteArray# s -> Int# -> MutableByteArray# s -> Int# -> Int# -> State# s -> State# s + {Copy a range of the first MutableByteArray# to the specified region in the second MutableByteArray#. + Both arrays must fully contain the specified ranges, but this is not checked.} + with + has_side_effects = True + code_size = { primOpCodeSizeForeignCall } + ------------------------------------------------------------------------ section "Addr#" ------------------------------------------------------------------------ @@ -880,8 +985,10 @@ #if (WORD_SIZE_IN_BITS == 32 || WORD_SIZE_IN_BITS == 64) primop Addr2IntOp "addr2Int#" GenPrimOp Addr# -> Int# {Coerce directly from address to int. Strongly deprecated.} + with code_size = 0 primop Int2AddrOp "int2Addr#" GenPrimOp Int# -> Addr# {Coerce directly from int to address. Strongly deprecated.} + with code_size = 0 #endif primop AddrGtOp "gtAddr#" Compare Addr# -> Addr# -> Bool @@ -1098,6 +1205,7 @@ {Write contents of {\tt MutVar\#}.} with has_side_effects = True + code_size = { primOpCodeSizeForeignCall } -- for the write barrier primop SameMutVarOp "sameMutVar#" GenPrimOp MutVar# s a -> MutVar# s a -> Bool @@ -1113,6 +1221,12 @@ out_of_line = True has_side_effects = True +primop CasMutVarOp "casMutVar#" GenPrimOp + MutVar# s a -> a -> a -> State# s -> (# State# s, Int#, a #) + with + out_of_line = True + has_side_effects = True + ------------------------------------------------------------------------ section "Exceptions" ------------------------------------------------------------------------ @@ -1140,10 +1254,14 @@ -- raiseIO# needs to be a primop, because exceptions in the IO monad -- must be *precise* - we don't want the strictness analyser turning -- one kind of bottom into another, as it is allowed to do in pure code. +-- +-- But we *do* want to know that it returns bottom after +-- being applied to two arguments primop RaiseIOOp "raiseIO#" GenPrimOp a -> State# RealWorld -> (# State# RealWorld, b #) with + strictness = { \ _arity -> mkStrictSig (mkTopDmdType [lazyDmd,lazyDmd] BotRes) } out_of_line = True has_side_effects = True @@ -1320,7 +1438,6 @@ Int# -> State# s -> State# s {Sleep specified number of microseconds.} with - needs_wrapper = True has_side_effects = True out_of_line = True @@ -1328,7 +1445,6 @@ Int# -> State# s -> State# s {Block until input is available on specified file descriptor.} with - needs_wrapper = True has_side_effects = True out_of_line = True @@ -1336,7 +1452,6 @@ Int# -> State# s -> State# s {Block until output is possible on specified file descriptor.} with - needs_wrapper = True has_side_effects = True out_of_line = True @@ -1345,7 +1460,6 @@ Int# -> Int# -> Int# -> Addr# -> State# RealWorld-> (# State# RealWorld, Int#, Int# #) {Asynchronously read bytes from specified file descriptor.} with - needs_wrapper = True has_side_effects = True out_of_line = True @@ -1353,7 +1467,6 @@ Int# -> Int# -> Int# -> Addr# -> State# RealWorld-> (# State# RealWorld, Int#, Int# #) {Asynchronously write bytes from specified file descriptor.} with - needs_wrapper = True has_side_effects = True out_of_line = True @@ -1361,7 +1474,6 @@ Addr# -> Addr# -> State# RealWorld-> (# State# RealWorld, Int#, Int# #) {Asynchronously perform procedure (first arg), passing it 2nd arg.} with - needs_wrapper = True has_side_effects = True out_of_line = True @@ -1437,7 +1549,7 @@ has_side_effects = True primop ThreadStatusOp "threadStatus#" GenPrimOp - ThreadId# -> State# RealWorld -> (# State# RealWorld, Int# #) + ThreadId# -> State# RealWorld -> (# State# RealWorld, Int#, Int#, Int# #) with out_of_line = True has_side_effects = True @@ -1478,6 +1590,7 @@ primop TouchOp "touch#" GenPrimOp o -> State# RealWorld -> State# RealWorld with + code_size = { 0 } has_side_effects = True ------------------------------------------------------------------------ @@ -1497,7 +1610,6 @@ primop DeRefStablePtrOp "deRefStablePtr#" GenPrimOp StablePtr# a -> State# RealWorld -> (# State# RealWorld, a #) with - needs_wrapper = True has_side_effects = True out_of_line = True @@ -1509,7 +1621,6 @@ primop MakeStableNameOp "makeStableName#" GenPrimOp a -> State# RealWorld -> (# State# RealWorld, StableName# a #) with - needs_wrapper = True has_side_effects = True out_of_line = True @@ -1537,6 +1648,22 @@ -- Note that Par is lazy to avoid that the sparked thing -- gets evaluted strictly, which it should *not* be has_side_effects = True + code_size = { primOpCodeSizeForeignCall } + +primop SparkOp "spark#" GenPrimOp + a -> State# s -> (# State# s, a #) + with has_side_effects = True + code_size = { primOpCodeSizeForeignCall } + +primop SeqOp "seq#" GenPrimOp + a -> State# s -> (# State# s, a #) + + -- why return the value? So that we can control sharing of seq'd + -- values: in + -- let x = e in x `seq` ... x ... + -- we don't want to inline x, so better to represent it as + -- let x = e in case seq# x RW of (# _, x' #) -> ... x' ... + -- also it matches the type of rseq in the Eval monad. primop GetSparkOp "getSpark#" GenPrimOp State# s -> (# State# s, Int#, a #) @@ -1626,6 +1753,8 @@ primop AddrToHValueOp "addrToHValue#" GenPrimOp Addr# -> (# a #) {Convert an {\tt Addr\#} to a followable type.} + with + code_size = 0 primop MkApUpd0_Op "mkApUpd0#" GenPrimOp BCO# -> (# a #) @@ -1720,9 +1849,19 @@ but never enters a function value. It's also used to instantiate un-constrained type variables after type - checking. For example + checking. For example, {\tt length} has type + + {\tt length :: forall a. [a] -> Int} + + and the list datacon for the empty list has type + + {\tt [] :: forall a. [a]} + + In order to compose these two terms as {\tt length []} a type + application is required, but there is no constraint on the + choice. In this situation GHC uses {\tt Any}: - {\tt length Any []} + {\tt length Any ([] Any)} Annoyingly, we sometimes need {\tt Any}s of other kinds, such as {\tt (* -> *)} etc. This is a bit like tuples. We define a couple of useful ones here, diff -Nru ghc-7.0.3/compiler/prelude/TysPrim.lhs ghc-7.2.1/compiler/prelude/TysPrim.lhs --- ghc-7.0.3/compiler/prelude/TysPrim.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/prelude/TysPrim.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -14,7 +14,22 @@ openAlphaTy, openBetaTy, openAlphaTyVar, openBetaTyVar, openAlphaTyVars, argAlphaTy, argAlphaTyVar, argBetaTy, argBetaTyVar, - primTyCons, + -- Kind constructors... + tySuperKindTyCon, tySuperKind, + liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon, + argTypeKindTyCon, ubxTupleKindTyCon, + + tySuperKindTyConName, liftedTypeKindTyConName, + openTypeKindTyConName, unliftedTypeKindTyConName, + ubxTupleKindTyConName, argTypeKindTyConName, + + -- Kinds + liftedTypeKind, unliftedTypeKind, openTypeKind, + argTypeKind, ubxTupleKind, + mkArrowKind, mkArrowKinds, isCoercionKind, + + funTyCon, funTyConName, + primTyCons, charPrimTyCon, charPrimTy, intPrimTyCon, intPrimTy, @@ -44,7 +59,9 @@ word32PrimTyCon, word32PrimTy, int64PrimTyCon, int64PrimTy, - word64PrimTyCon, word64PrimTy, + word64PrimTyCon, word64PrimTy, + + eqPredPrimTyCon, -- ty1 ~ ty2 -- * Any anyTyCon, anyTyConOfKind, anyTypeOfKind @@ -54,11 +71,9 @@ import Var ( TyVar, mkTyVar ) import Name ( Name, BuiltInSyntax(..), mkInternalName, mkWiredInName ) -import OccName ( mkTcOcc ) -import OccName ( mkTyVarOccFS, mkTcOccFS ) -import TyCon ( TyCon, mkPrimTyCon, mkLiftedPrimTyCon, mkAnyTyCon ) -import Type -import Coercion +import OccName ( mkTcOcc,mkTyVarOccFS, mkTcOccFS ) +import TyCon +import TypeRep import SrcLoc import Unique ( mkAlphaTyVarUnique ) import PrelNames @@ -102,6 +117,7 @@ , word32PrimTyCon , word64PrimTyCon , anyTyCon + , eqPredPrimTyCon ] mkPrimTc :: FastString -> Unique -> TyCon -> Name @@ -111,7 +127,7 @@ (ATyCon tycon) -- Relevant TyCon UserSyntax -- None are built-in syntax -charPrimTyConName, intPrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, realWorldTyConName, arrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName :: Name +charPrimTyConName, intPrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, realWorldTyConName, arrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPredPrimTyConName :: Name charPrimTyConName = mkPrimTc (fsLit "Char#") charPrimTyConKey charPrimTyCon intPrimTyConName = mkPrimTc (fsLit "Int#") intPrimTyConKey intPrimTyCon int32PrimTyConName = mkPrimTc (fsLit "Int32#") int32PrimTyConKey int32PrimTyCon @@ -122,8 +138,9 @@ addrPrimTyConName = mkPrimTc (fsLit "Addr#") addrPrimTyConKey addrPrimTyCon floatPrimTyConName = mkPrimTc (fsLit "Float#") floatPrimTyConKey floatPrimTyCon doublePrimTyConName = mkPrimTc (fsLit "Double#") doublePrimTyConKey doublePrimTyCon -statePrimTyConName = mkPrimTc (fsLit "State#") statePrimTyConKey statePrimTyCon -realWorldTyConName = mkPrimTc (fsLit "RealWorld") realWorldTyConKey realWorldTyCon +statePrimTyConName = mkPrimTc (fsLit "State#") statePrimTyConKey statePrimTyCon +eqPredPrimTyConName = mkPrimTc (fsLit "~") eqPredPrimTyConKey eqPredPrimTyCon +realWorldTyConName = mkPrimTc (fsLit "RealWorld") realWorldTyConKey realWorldTyCon arrayPrimTyConName = mkPrimTc (fsLit "Array#") arrayPrimTyConKey arrayPrimTyCon byteArrayPrimTyConName = mkPrimTc (fsLit "ByteArray#") byteArrayPrimTyConKey byteArrayPrimTyCon mutableArrayPrimTyConName = mkPrimTc (fsLit "MutableArray#") mutableArrayPrimTyConKey mutableArrayPrimTyCon @@ -193,109 +210,95 @@ %************************************************************************ %* * - Any + FunTyCon %* * %************************************************************************ -Note [Any types] -~~~~~~~~~~~~~~~~ -The type constructor Any::* has these properties - - * It is defined in module GHC.Prim, and exported so that it is - available to users. For this reason it's treated like any other - primitive type: - - has a fixed unique, anyTyConKey, - - lives in the global name cache - - built with TyCon.PrimTyCon - - * It is lifted, and hence represented by a pointer - - * It is inhabited by at least one value, namely bottom - - * You can unsafely coerce any lifted type to Ayny, and back. - - * It does not claim to be a *data* type, and that's important for - the code generator, because the code gen may *enter* a data value - but never enters a function value. +\begin{code} +funTyConName :: Name +funTyConName = mkPrimTyConName (fsLit "(->)") funTyConKey funTyCon - * It is used to instantiate otherwise un-constrained type variables of kind * - For example length Any [] - See Note [Strangely-kinded void TyCons] +funTyCon :: TyCon +funTyCon = mkFunTyCon funTyConName (mkArrowKinds [argTypeKind, openTypeKind] liftedTypeKind) + -- You might think that (->) should have type (?? -> ? -> *), and you'd be right + -- But if we do that we get kind errors when saying + -- instance Control.Arrow (->) + -- becuase the expected kind is (*->*->*). The trouble is that the + -- expected/actual stuff in the unifier does not go contra-variant, whereas + -- the kind sub-typing does. Sigh. It really only matters if you use (->) in + -- a prefix way, thus: (->) Int# Int#. And this is unusual. + -- because they are never in scope in the source +\end{code} -In addition, we have a potentially-infinite family of types, one for -each kind /other than/ *, needed to instantiate otherwise -un-constrained type variables of kinds other than *. This is a bit -like tuples; there is a potentially-infinite family. They have slightly -different characteristics to Any::*: - - * They are built with TyCon.AnyTyCon - * They have non-user-writable names like "Any(*->*)" - * They are not exported by GHC.Prim - * They are uninhabited (of course; not kind *) - * They have a unique derived from their OccName (see Note [Uniques of Any]) - * Their Names do not live in the global name cache -Note [Uniques of Any] -~~~~~~~~~~~~~~~~~~~~~ -Although Any(*->*), say, doesn't have a binding site, it still needs -to have a Unique. Unlike tuples (which are also an infinite family) -there is no convenient way to index them, so we use the Unique from -their OccName instead. That should be unique, - - both wrt each other, because their strings differ +%************************************************************************ +%* * + Kinds +%* * +%************************************************************************ - - and wrt any other Name, because Names get uniques with - various 'char' tags, but the OccName of Any will - get a Unique built with mkTcOccUnique, which has a particular 'char' - tag; see Unique.mkTcOccUnique! +\begin{code} +-- | See "Type#kind_subtyping" for details of the distinction between the 'Kind' 'TyCon's +tySuperKindTyCon, liftedTypeKindTyCon, + openTypeKindTyCon, unliftedTypeKindTyCon, + ubxTupleKindTyCon, argTypeKindTyCon + :: TyCon +tySuperKindTyConName, liftedTypeKindTyConName, + openTypeKindTyConName, unliftedTypeKindTyConName, + ubxTupleKindTyConName, argTypeKindTyConName + :: Name -Note [Strangely-kinded void TyCons] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See Trac #959 for more examples +tySuperKindTyCon = mkSuperKindTyCon tySuperKindTyConName +liftedTypeKindTyCon = mkKindTyCon liftedTypeKindTyConName tySuperKind +openTypeKindTyCon = mkKindTyCon openTypeKindTyConName tySuperKind +unliftedTypeKindTyCon = mkKindTyCon unliftedTypeKindTyConName tySuperKind +ubxTupleKindTyCon = mkKindTyCon ubxTupleKindTyConName tySuperKind +argTypeKindTyCon = mkKindTyCon argTypeKindTyConName tySuperKind -When the type checker finds a type variable with no binding, which -means it can be instantiated with an arbitrary type, it usually -instantiates it to Void. Eg. +-------------------------- +-- ... and now their names - length [] -===> - length Any (Nil Any) +tySuperKindTyConName = mkPrimTyConName (fsLit "BOX") tySuperKindTyConKey tySuperKindTyCon +liftedTypeKindTyConName = mkPrimTyConName (fsLit "*") liftedTypeKindTyConKey liftedTypeKindTyCon +openTypeKindTyConName = mkPrimTyConName (fsLit "?") openTypeKindTyConKey openTypeKindTyCon +unliftedTypeKindTyConName = mkPrimTyConName (fsLit "#") unliftedTypeKindTyConKey unliftedTypeKindTyCon +ubxTupleKindTyConName = mkPrimTyConName (fsLit "(#)") ubxTupleKindTyConKey ubxTupleKindTyCon +argTypeKindTyConName = mkPrimTyConName (fsLit "??") argTypeKindTyConKey argTypeKindTyCon -But in really obscure programs, the type variable might have a kind -other than *, so we need to invent a suitably-kinded type. +mkPrimTyConName :: FastString -> Unique -> TyCon -> Name +mkPrimTyConName occ key tycon = mkWiredInName gHC_PRIM (mkTcOccFS occ) + key + (ATyCon tycon) + BuiltInSyntax + -- All of the super kinds and kinds are defined in Prim and use BuiltInSyntax, + -- because they are never in scope in the source +\end{code} -This commit uses - Any for kind * - Any(*->*) for kind *->* - etc \begin{code} -anyTyConName :: Name -anyTyConName = mkPrimTc (fsLit "Any") anyTyConKey anyTyCon +kindTyConType :: TyCon -> Type +kindTyConType kind = TyConApp kind [] -anyTyCon :: TyCon -anyTyCon = mkLiftedPrimTyCon anyTyConName liftedTypeKind 0 PtrRep +-- | See "Type#kind_subtyping" for details of the distinction between these 'Kind's +liftedTypeKind, unliftedTypeKind, openTypeKind, argTypeKind, ubxTupleKind :: Kind -anyTypeOfKind :: Kind -> Type -anyTypeOfKind kind = mkTyConApp (anyTyConOfKind kind) [] +liftedTypeKind = kindTyConType liftedTypeKindTyCon +unliftedTypeKind = kindTyConType unliftedTypeKindTyCon +openTypeKind = kindTyConType openTypeKindTyCon +argTypeKind = kindTyConType argTypeKindTyCon +ubxTupleKind = kindTyConType ubxTupleKindTyCon -anyTyConOfKind :: Kind -> TyCon --- Map all superkinds of liftedTypeKind to liftedTypeKind -anyTyConOfKind kind - | liftedTypeKind `isSubKind` kind = anyTyCon - | otherwise = tycon - where - -- Derive the name from the kind, thus: - -- Any(*->*), Any(*->*->*) - -- These are names that can't be written by the user, - -- and are not allocated in the global name cache - str = "Any" ++ showSDoc (pprParendKind kind) +-- | Given two kinds @k1@ and @k2@, creates the 'Kind' @k1 -> k2@ +mkArrowKind :: Kind -> Kind -> Kind +mkArrowKind k1 k2 = FunTy k1 k2 - occ = mkTcOcc str - uniq = getUnique occ -- See Note [Uniques of Any] - name = mkWiredInName gHC_PRIM occ uniq (ATyCon tycon) UserSyntax - tycon = mkAnyTyCon name kind -\end{code} +-- | Iterated application of 'mkArrowKind' +mkArrowKinds :: [Kind] -> Kind -> Kind +mkArrowKinds arg_kinds result_kind = foldr mkArrowKind result_kind arg_kinds +tySuperKind :: SuperKind +tySuperKind = kindTyConType tySuperKindTyCon +\end{code} %************************************************************************ %* * @@ -376,6 +379,22 @@ %* * %************************************************************************ +Note [The (~) TyCon) +~~~~~~~~~~~~~~~~~~~~ +There is a perfectly ordinary type constructor (~) that represents the type +of coercions (which, remember, are values). For example + Refl Int :: Int ~ Int + +Atcually it is not quite "perfectly ordinary" because it is kind-polymorphic: + Refl Maybe :: Maybe ~ Maybe + +So the true kind of (~) :: forall k. k -> k -> #. But we don't have +polymorphic kinds (yet). However, (~) really only appears saturated in +which case there is no problem in finding the kind of (ty1 ~ ty2). So +we check that in CoreLint (and, in an assertion, in Kind.typeKind). + +Note [The State# TyCon] +~~~~~~~~~~~~~~~~~~~~~~~ State# is the primitive, unlifted type of states. It has one type parameter, thus State# RealWorld @@ -388,8 +407,13 @@ \begin{code} mkStatePrimTy :: Type -> Type mkStatePrimTy ty = mkTyConApp statePrimTyCon [ty] -statePrimTyCon :: TyCon + +statePrimTyCon :: TyCon -- See Note [The State# TyCon] statePrimTyCon = pcPrimTyCon statePrimTyConName 1 VoidRep + +eqPredPrimTyCon :: TyCon -- The representation type for equality predicates + -- See Note [The (~) TyCon] +eqPredPrimTyCon = pcPrimTyCon eqPredPrimTyConName 2 VoidRep \end{code} RealWorld is deeply magical. It is *primitive*, but it is not @@ -408,7 +432,6 @@ Note: the ``state-pairing'' types are not truly primitive, so they are defined in \tr{TysWiredIn.lhs}, not here. - %************************************************************************ %* * \subsection[TysPrim-arrays]{The primitive array types} @@ -551,3 +574,110 @@ threadIdPrimTyCon :: TyCon threadIdPrimTyCon = pcPrimTyCon0 threadIdPrimTyConName PtrRep \end{code} + + + +%************************************************************************ +%* * + Any +%* * +%************************************************************************ + +Note [Any types] +~~~~~~~~~~~~~~~~ +The type constructor Any::* has these properties + + * It is defined in module GHC.Prim, and exported so that it is + available to users. For this reason it's treated like any other + primitive type: + - has a fixed unique, anyTyConKey, + - lives in the global name cache + - built with TyCon.PrimTyCon + + * It is lifted, and hence represented by a pointer + + * It is inhabited by at least one value, namely bottom + + * You can unsafely coerce any lifted type to Ayny, and back. + + * It does not claim to be a *data* type, and that's important for + the code generator, because the code gen may *enter* a data value + but never enters a function value. + + * It is used to instantiate otherwise un-constrained type variables of kind * + For example length Any [] + See Note [Strangely-kinded void TyCons] + +In addition, we have a potentially-infinite family of types, one for +each kind /other than/ *, needed to instantiate otherwise +un-constrained type variables of kinds other than *. This is a bit +like tuples; there is a potentially-infinite family. They have slightly +different characteristics to Any::*: + + * They are built with TyCon.AnyTyCon + * They have non-user-writable names like "Any(*->*)" + * They are not exported by GHC.Prim + * They are uninhabited (of course; not kind *) + * They have a unique derived from their OccName (see Note [Uniques of Any]) + * Their Names do not live in the global name cache + +Note [Uniques of Any] +~~~~~~~~~~~~~~~~~~~~~ +Although Any(*->*), say, doesn't have a binding site, it still needs +to have a Unique. Unlike tuples (which are also an infinite family) +there is no convenient way to index them, so we use the Unique from +their OccName instead. That should be unique, + - both wrt each other, because their strings differ + + - and wrt any other Name, because Names get uniques with + various 'char' tags, but the OccName of Any will + get a Unique built with mkTcOccUnique, which has a particular 'char' + tag; see Unique.mkTcOccUnique! + +Note [Strangely-kinded void TyCons] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See Trac #959 for more examples + +When the type checker finds a type variable with no binding, which +means it can be instantiated with an arbitrary type, it usually +instantiates it to Void. Eg. + + length [] +===> + length Any (Nil Any) + +But in really obscure programs, the type variable might have a kind +other than *, so we need to invent a suitably-kinded type. + +This commit uses + Any for kind * + Any(*->*) for kind *->* + etc + +\begin{code} +anyTyConName :: Name +anyTyConName = mkPrimTc (fsLit "Any") anyTyConKey anyTyCon + +anyTyCon :: TyCon +anyTyCon = mkLiftedPrimTyCon anyTyConName liftedTypeKind 0 PtrRep + +anyTypeOfKind :: Kind -> Type +anyTypeOfKind kind = mkTyConApp (anyTyConOfKind kind) [] + +anyTyConOfKind :: Kind -> TyCon +-- Map all superkinds of liftedTypeKind to liftedTypeKind +anyTyConOfKind kind + | isLiftedTypeKind kind = anyTyCon + | otherwise = tycon + where + -- Derive the name from the kind, thus: + -- Any(*->*), Any(*->*->*) + -- These are names that can't be written by the user, + -- and are not allocated in the global name cache + str = "Any" ++ showSDoc (pprParendKind kind) + + occ = mkTcOcc str + uniq = getUnique occ -- See Note [Uniques of Any] + name = mkWiredInName gHC_PRIM occ uniq (ATyCon tycon) UserSyntax + tycon = mkAnyTyCon name kind +\end{code} diff -Nru ghc-7.0.3/compiler/prelude/TysWiredIn.lhs ghc-7.2.1/compiler/prelude/TysWiredIn.lhs --- ghc-7.0.3/compiler/prelude/TysWiredIn.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/prelude/TysWiredIn.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -64,23 +64,14 @@ -- others: import Constants ( mAX_TUPLE_SIZE ) import Module ( Module ) +import DataCon ( DataCon, mkDataCon, dataConWorkId, dataConSourceArity ) +import Var +import TyCon +import TypeRep import RdrName import Name -import DataCon ( DataCon, mkDataCon, dataConWorkId, dataConSourceArity ) -import Var -import TyCon ( TyCon, AlgTyConRhs(DataTyCon), tyConDataCons, - mkTupleTyCon, mkAlgTyCon, tyConName, - TyConParent(NoParentTyCon) ) - -import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed, HsBang(..) ) - -import Type ( Type, mkTyConTy, mkTyConApp, mkTyVarTy, mkTyVarTys, - TyThing(..) ) -import Coercion ( unsafeCoercionTyCon, symCoercionTyCon, - transCoercionTyCon, leftCoercionTyCon, - rightCoercionTyCon, instCoercionTyCon ) -import TypeRep ( mkArrowKinds, liftedTypeKind, ubxTupleKind ) -import Unique ( incrUnique, mkTupleTyConUnique, +import BasicTypes ( Arity, RecFlag(..), Boxity(..), isBoxed, HsBang(..) ) +import Unique ( incrUnique, mkTupleTyConUnique, mkTupleDataConUnique, mkPArrDataConUnique ) import Data.Array import FastString @@ -124,12 +115,6 @@ , intTyCon , listTyCon , parrTyCon - , unsafeCoercionTyCon - , symCoercionTyCon - , transCoercionTyCon - , leftCoercionTyCon - , rightCoercionTyCon - , instCoercionTyCon ] \end{code} @@ -153,9 +138,9 @@ intDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "I#") intDataConKey intDataCon boolTyConName, falseDataConName, trueDataConName :: Name -boolTyConName = mkWiredInTyConName UserSyntax gHC_BOOL (fsLit "Bool") boolTyConKey boolTyCon -falseDataConName = mkWiredInDataConName UserSyntax gHC_BOOL (fsLit "False") falseDataConKey falseDataCon -trueDataConName = mkWiredInDataConName UserSyntax gHC_BOOL (fsLit "True") trueDataConKey trueDataCon +boolTyConName = mkWiredInTyConName UserSyntax gHC_TYPES (fsLit "Bool") boolTyConKey boolTyCon +falseDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "False") falseDataConKey falseDataCon +trueDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "True") trueDataConKey trueDataCon listTyConName, nilDataConName, consDataConName :: Name listTyConName = mkWiredInTyConName BuiltInSyntax gHC_TYPES (fsLit "[]") listTyConKey listTyCon @@ -169,8 +154,10 @@ doubleDataConName = mkWiredInDataConName UserSyntax gHC_TYPES (fsLit "D#") doubleDataConKey doubleDataCon parrTyConName, parrDataConName :: Name -parrTyConName = mkWiredInTyConName BuiltInSyntax gHC_PARR (fsLit "[::]") parrTyConKey parrTyCon -parrDataConName = mkWiredInDataConName UserSyntax gHC_PARR (fsLit "PArr") parrDataConKey parrDataCon +parrTyConName = mkWiredInTyConName BuiltInSyntax + gHC_PARR' (fsLit "[::]") parrTyConKey parrTyCon +parrDataConName = mkWiredInDataConName UserSyntax + gHC_PARR' (fsLit "PArr") parrDataConKey parrDataCon boolTyCon_RDR, false_RDR, true_RDR, intTyCon_RDR, charTyCon_RDR, intDataCon_RDR, listTyCon_RDR, consDataCon_RDR, parrTyCon_RDR:: RdrName @@ -209,7 +196,6 @@ (DataTyCon cons is_enum) NoParentTyCon is_rec - True -- All the wired-in tycons have generics False -- Not in GADT syntax pcDataCon :: Name -> [TyVar] -> [Type] -> TyCon -> DataCon @@ -274,7 +260,7 @@ mk_tuple :: Boxity -> Int -> (TyCon,DataCon) mk_tuple boxity arity = (tycon, tuple_con) where - tycon = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con boxity gen_info + tycon = mkTupleTyCon tc_name tc_kind arity tyvars tuple_con boxity modu = mkTupleModule boxity arity tc_name = mkWiredInName modu (mkTupleOcc tcName boxity arity) tc_uniq (ATyCon tycon) BuiltInSyntax @@ -291,8 +277,6 @@ (ADataCon tuple_con) BuiltInSyntax tc_uniq = mkTupleTyConUnique boxity arity dc_uniq = mkTupleDataConUnique boxity arity - gen_info = True -- Tuples all have generics.. - -- hmm: that's a *lot* of code unitTyCon :: TyCon unitTyCon = tupleTyCon Boxed 0 @@ -537,9 +521,9 @@ \end{code} %************************************************************************ -%* * +%* * \subsection[TysWiredIn-PArr]{The @[::]@ type} -%* * +%* * %************************************************************************ Special syntax for parallel arrays needs some wired in definitions. @@ -562,13 +546,13 @@ parrDataCon :: DataCon parrDataCon = pcDataCon - parrDataConName - alpha_tyvar -- forall'ed type variables - [intPrimTy, -- 1st argument: Int# - mkTyConApp -- 2nd argument: Array# a - arrayPrimTyCon - alpha_ty] - parrTyCon + parrDataConName + alpha_tyvar -- forall'ed type variables + [intTy, -- 1st argument: Int + mkTyConApp -- 2nd argument: Array# a + arrayPrimTyCon + alpha_ty] + parrTyCon -- | Check whether a type constructor is the constructor for parallel arrays isPArrTyCon :: TyCon -> Bool @@ -582,31 +566,29 @@ -- yet another constructor pattern -- parrFakeCon :: Arity -> DataCon -parrFakeCon i | i > mAX_TUPLE_SIZE = mkPArrFakeCon i -- build one specially +parrFakeCon i | i > mAX_TUPLE_SIZE = mkPArrFakeCon i -- build one specially parrFakeCon i = parrFakeConArr!i -- pre-defined set of constructors -- parrFakeConArr :: Array Int DataCon parrFakeConArr = array (0, mAX_TUPLE_SIZE) [(i, mkPArrFakeCon i) - | i <- [0..mAX_TUPLE_SIZE]] + | i <- [0..mAX_TUPLE_SIZE]] -- build a fake parallel array constructor for the given arity -- mkPArrFakeCon :: Int -> DataCon mkPArrFakeCon arity = data_con where - data_con = pcDataCon name [tyvar] tyvarTys parrTyCon - tyvar = head alphaTyVars - tyvarTys = replicate arity $ mkTyVarTy tyvar + data_con = pcDataCon name [tyvar] tyvarTys parrTyCon + tyvar = head alphaTyVars + tyvarTys = replicate arity $ mkTyVarTy tyvar nameStr = mkFastString ("MkPArr" ++ show arity) - name = mkWiredInName gHC_PARR (mkDataOccFS nameStr) unique - (ADataCon data_con) UserSyntax - unique = mkPArrDataConUnique arity + name = mkWiredInName gHC_PARR' (mkDataOccFS nameStr) unique + (ADataCon data_con) UserSyntax + unique = mkPArrDataConUnique arity -- | Checks whether a data constructor is a fake constructor for parallel arrays isPArrFakeCon :: DataCon -> Bool isPArrFakeCon dcon = dcon == parrFakeCon (dataConSourceArity dcon) \end{code} - - diff -Nru ghc-7.0.3/compiler/profiling/CostCentre.lhs ghc-7.2.1/compiler/profiling/CostCentre.lhs --- ghc-7.0.3/compiler/profiling/CostCentre.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/profiling/CostCentre.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -10,7 +10,7 @@ -- any warnings in the module. See -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings -- for details -{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE BangPatterns, DeriveDataTypeable #-} module CostCentre ( CostCentre(..), CcName, IsDupdCC(..), IsCafCC(..), diff -Nru ghc-7.0.3/compiler/profiling/ProfInit.hs ghc-7.2.1/compiler/profiling/ProfInit.hs --- ghc-7.0.3/compiler/profiling/ProfInit.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/compiler/profiling/ProfInit.hs 2011-08-07 17:10:05.000000000 +0000 @@ -0,0 +1,45 @@ +-- ----------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow, 2011 +-- +-- Generate code to initialise cost centres +-- +-- ----------------------------------------------------------------------------- + +module ProfInit (profilingInitCode) where + +import CLabel +import CostCentre +import Outputable +import StaticFlags +import FastString +import Module + +-- ----------------------------------------------------------------------------- +-- Initialising cost centres + +-- We must produce declarations for the cost-centres defined in this +-- module; + +profilingInitCode :: Module -> CollectedCCs -> SDoc +profilingInitCode this_mod (local_CCs, ___extern_CCs, singleton_CCSs) + | not opt_SccProfilingOn = empty + | otherwise + = vcat + [ text "static void prof_init_" <> ppr this_mod + <> text "(void) __attribute__((constructor));" + , text "static void prof_init_" <> ppr this_mod <> text "(void)" + , braces (vcat ( + map emitRegisterCC local_CCs ++ + map emitRegisterCCS singleton_CCSs + )) + ] + where + emitRegisterCC cc = + ptext (sLit "extern CostCentre ") <> cc_lbl <> ptext (sLit "[];") $$ + ptext (sLit "REGISTER_CC(") <> cc_lbl <> char ')' <> semi + where cc_lbl = ppr (mkCCLabel cc) + emitRegisterCCS ccs = + ptext (sLit "extern CostCentreStack ") <> ccs_lbl <> ptext (sLit "[];") $$ + ptext (sLit "REGISTER_CCS(") <> ccs_lbl <> char ')' <> semi + where ccs_lbl = ppr (mkCCSLabel ccs) diff -Nru ghc-7.0.3/compiler/rename/RnBinds.lhs ghc-7.2.1/compiler/rename/RnBinds.lhs --- ghc-7.0.3/compiler/rename/RnBinds.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/rename/RnBinds.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -26,7 +26,6 @@ import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts ) import HsSyn -import RdrHsSyn import RnHsSyn import TcRnMonad import RnTypes ( rnHsSigType, rnLHsType, checkPrecMatch) @@ -252,7 +251,13 @@ -> HsValBinds RdrName -> RnM ([Name], HsValBindsLR Name RdrName) rnLocalValBindsLHS fix_env binds - = do { -- Do error checking: we need to check for dups here because we + = do { binds' <- rnValBindsLHS (localRecNameMaker fix_env) binds + + -- Check for duplicates and shadowing + -- Must do this *after* renaming the patterns + -- See Note [Collect binders only after renaming] in HsUtils + + -- We need to check for dups here because we -- don't don't bind all of the variables from the ValBinds at once -- with bindLocatedLocals any more. -- @@ -266,10 +271,10 @@ -- import A(f) -- g = let f = ... in f -- should. - ; binds' <- rnValBindsLHS (localRecNameMaker fix_env) binds ; let bound_names = collectHsValBinders binds' ; envs <- getRdrEnvs ; checkDupAndShadowedNames envs bound_names + ; return (bound_names, binds') } -- renames the left-hand sides @@ -306,7 +311,10 @@ (anal_binds, anal_dus) -> return (valbind', valbind'_dus) where valbind' = ValBindsOut anal_binds sigs' - valbind'_dus = usesOnly (hsSigsFVs sigs') `plusDU` anal_dus + valbind'_dus = anal_dus `plusDU` usesOnly (hsSigsFVs sigs') + -- Put the sig uses *after* the bindings + -- so that the binders are removed from + -- the uses in the sigs } rnValBindsRHS _ _ b = pprPanic "rnValBindsRHS" (ppr b) @@ -357,7 +365,9 @@ -- let x = x in 3 -- should report 'x' unused ; let real_uses = findUses dus result_fvs - ; warnUnusedLocalBinds bound_names real_uses + -- Insert fake uses for variables introduced implicitly by wildcards (#4404) + implicit_uses = hsValBindsImplicits binds' + ; warnUnusedLocalBinds bound_names (real_uses `unionNameSets` implicit_uses) ; let -- The variables "used" in the val binds are: @@ -453,7 +463,7 @@ rnBind _ trim (L loc bind@(PatBind { pat_lhs = pat , pat_rhs = grhss -- pat fvs were stored in bind_fvs - -- after processing the LHS + -- after processing the LHS , bind_fvs = pat_fvs })) = setSrcSpan loc $ do { let bndrs = collectPatBinders pat @@ -473,7 +483,7 @@ , fun_infix = is_infix , fun_matches = matches })) -- invariant: no free vars here when it's a FunBind - = setSrcSpan loc $ + = setSrcSpan loc $ do { let plain_name = unLoc name ; (matches', fvs) <- bindSigTyVarsFV (sig_fn plain_name) $ @@ -556,8 +566,9 @@ where env :: NameEnv [Name] env = mkNameEnv [ (name, map hsLTyVarName ltvs) - | L _ (TypeSig (L _ name) - (L _ (HsForAllTy Explicit ltvs _ _))) <- sigs] + | L _ (TypeSig names + (L _ (HsForAllTy Explicit ltvs _ _))) <- sigs + , (L _ name) <- names] -- Note the pattern-match on "Explicit"; we only bind -- type variables from signatures with an explicit top-level for-all \end{code} @@ -581,23 +592,33 @@ \begin{code} rnMethodBinds :: Name -- Class name -> (Name -> [Name]) -- Signature tyvar function - -> [Name] -- Names for generic type variables -> LHsBinds RdrName -> RnM (LHsBinds Name, FreeVars) -rnMethodBinds cls sig_fn gen_tyvars binds - = foldlM do_one (emptyBag,emptyFVs) (bagToList binds) +rnMethodBinds cls sig_fn binds + = do { checkDupRdrNames meth_names + -- Check that the same method is not given twice in the + -- same instance decl instance C T where + -- f x = ... + -- g y = ... + -- f x = ... + -- We must use checkDupRdrNames because the Name of the + -- method is the Name of the class selector, whose SrcSpan + -- points to the class declaration; and we use rnMethodBinds + -- for instance decls too + + ; foldlM do_one (emptyBag, emptyFVs) (bagToList binds) } where + meth_names = collectMethodBinders binds do_one (binds,fvs) bind - = do { (bind', fvs_bind) <- rnMethodBind cls sig_fn gen_tyvars bind + = do { (bind', fvs_bind) <- rnMethodBind cls sig_fn bind ; return (binds `unionBags` bind', fvs_bind `plusFV` fvs) } rnMethodBind :: Name -> (Name -> [Name]) - -> [Name] -> LHsBindLR RdrName RdrName -> RnM (Bag (LHsBindLR Name Name), FreeVars) -rnMethodBind cls sig_fn gen_tyvars +rnMethodBind cls sig_fn (L loc bind@(FunBind { fun_id = name, fun_infix = is_infix , fun_matches = MatchGroup matches _ })) = setSrcSpan loc $ do @@ -606,7 +627,7 @@ -- We use the selector name as the binder (new_matches, fvs) <- bindSigTyVarsFV (sig_fn plain_name) $ - mapFvRn (rn_match (FunRhs plain_name is_infix)) matches + mapFvRn (rnMatch (FunRhs plain_name is_infix)) matches let new_group = MatchGroup new_matches placeHolderType when is_infix $ checkPrecMatch plain_name new_group @@ -615,24 +636,13 @@ , bind_fvs = fvs })), fvs `addOneFV` plain_name) -- The 'fvs' field isn't used for method binds - where - -- Truly gruesome; bring into scope the correct members of the generic - -- type variables. See comments in RnSource.rnSourceDecl(ClassDecl) - rn_match info match@(L _ (Match (L _ (TypePat ty) : _) _ _)) - = extendTyVarEnvFVRn gen_tvs $ - rnMatch info match - where - tvs = map (rdrNameOcc.unLoc) (extractHsTyRdrTyVars ty) - gen_tvs = [tv | tv <- gen_tyvars, nameOccName tv `elem` tvs] - - rn_match info match = rnMatch info match -- Can't handle method pattern-bindings which bind multiple methods. -rnMethodBind _ _ _ (L loc bind@(PatBind {})) = do +rnMethodBind _ _ (L loc bind@(PatBind {})) = do addErrAt loc (methodBindErr bind) return (emptyBag, emptyFVs) -rnMethodBind _ _ _ b = pprPanic "rnMethodBind" (ppr b) +rnMethodBind _ _ b = pprPanic "rnMethodBind" (ppr b) \end{code} @@ -663,7 +673,12 @@ -- Check for duplicates on RdrName version, -- because renamed version has unboundName for -- not-in-scope binders, which gives bogus dup-sig errors - + -- NB: in a class decl, a 'generic' sig is not considered + -- equal to an ordinary sig, so we allow, say + -- class C a where + -- op :: a -> a + -- default op :: Eq a => a -> a + ; sigs' <- mapM (wrapLocM (renameSig mb_names)) sigs ; let (good_sigs, bad_sigs) = partition (ok_sig . unLoc) sigs' @@ -685,19 +700,26 @@ -- FixitySig is renamed elsewhere. renameSig _ (IdSig x) = return (IdSig x) -- Actually this never occurs -renameSig mb_names sig@(TypeSig v ty) - = do { new_v <- lookupSigOccRn mb_names sig v - ; new_ty <- rnHsSigType (quotes (ppr v)) ty - ; return (TypeSig new_v new_ty) } +renameSig mb_names sig@(TypeSig vs ty) + = do { new_vs <- mapM (lookupSigOccRn mb_names sig) vs + ; new_ty <- rnHsSigType (ppr_sig_bndrs vs) ty + ; return (TypeSig new_vs new_ty) } + +renameSig mb_names sig@(GenericSig vs ty) + = do { defaultSigs_on <- xoptM Opt_DefaultSignatures + ; unless defaultSigs_on (addErr (defaultSigErr sig)) + ; new_v <- mapM (lookupSigOccRn mb_names sig) vs + ; new_ty <- rnHsSigType (ppr_sig_bndrs vs) ty + ; return (GenericSig new_v new_ty) } renameSig _ (SpecInstSig ty) - = do { new_ty <- rnLHsType (text "A SPECIALISE instance pragma") ty + = do { new_ty <- rnLHsType (text "In a SPECIALISE instance pragma") ty ; return (SpecInstSig new_ty) } -- {-# SPECIALISE #-} pragmas can refer to imported Ids -- so, in the top-level case (when mb_names is Nothing) -- we use lookupOccRn. If there's both an imported and a local 'f' --- then the SPECIALISE pragma is ambiguous, unlike alll other signatures +-- then the SPECIALISE pragma is ambiguous, unlike all other signatures renameSig mb_names sig@(SpecSig v ty inl) = do { new_v <- case mb_names of Just {} -> lookupSigOccRn mb_names sig v @@ -712,6 +734,9 @@ renameSig mb_names sig@(FixSig (FixitySig v f)) = do { new_v <- lookupSigOccRn mb_names sig v ; return (FixSig (FixitySig new_v f)) } + +ppr_sig_bndrs :: [Located RdrName] -> SDoc +ppr_sig_bndrs bs = quotes (pprWithCommas ppr bs) \end{code} @@ -773,7 +798,7 @@ rnGRHS' :: HsMatchContext Name -> GRHS RdrName -> RnM (GRHS Name, FreeVars) rnGRHS' ctxt (GRHS guards rhs) = do { pattern_guards_allowed <- xoptM Opt_PatternGuards - ; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) guards $ + ; ((guards', rhs'), fvs) <- rnStmts (PatGuard ctxt) guards $ \ _ -> rnLExpr rhs ; unless (pattern_guards_allowed || is_standard_guard guards') @@ -784,9 +809,9 @@ -- Standard Haskell 1.4 guards are just a single boolean -- expression, rather than a list of qualifiers as in the -- Glasgow extension - is_standard_guard [] = True - is_standard_guard [L _ (ExprStmt _ _ _)] = True - is_standard_guard _ = False + is_standard_guard [] = True + is_standard_guard [L _ (ExprStmt _ _ _ _)] = True + is_standard_guard _ = False \end{code} %************************************************************************ @@ -811,6 +836,11 @@ = addErrAt loc $ sep [ptext (sLit "Misplaced") <+> hsSigDoc sig <> colon, ppr sig] +defaultSigErr :: Sig RdrName -> SDoc +defaultSigErr sig = vcat [ hang (ptext (sLit "Unexpected default signature:")) + 2 (ppr sig) + , ptext (sLit "Use -XDefaultSignatures to enable default signatures") ] + methodBindErr :: HsBindLR RdrName RdrName -> SDoc methodBindErr mbind = hang (ptext (sLit "Pattern bindings (except simple variables) not allowed in instance declarations")) @@ -825,4 +855,5 @@ nonStdGuardErr guards = hang (ptext (sLit "accepting non-standard pattern guards (use -XPatternGuards to suppress this message)")) 4 (interpp'SP guards) + \end{code} diff -Nru ghc-7.0.3/compiler/rename/RnEnv.lhs ghc-7.2.1/compiler/rename/RnEnv.lhs --- ghc-7.0.3/compiler/rename/RnEnv.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/rename/RnEnv.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -5,15 +5,15 @@ \begin{code} module RnEnv ( - newTopSrcBinder, lookupFamInstDeclBndr, + newTopSrcBinder, lookupLocatedTopBndrRn, lookupTopBndrRn, lookupLocatedOccRn, lookupOccRn, - lookupLocatedGlobalOccRn, - lookupGlobalOccRn, lookupGlobalOccRn_maybe, + lookupGlobalOccRn, lookupGlobalOccRn_maybe, lookupLocalDataTcNames, lookupSigOccRn, lookupFixityRn, lookupTyFixityRn, - lookupInstDeclBndr, lookupSubBndr, lookupConstructorFields, - lookupSyntaxName, lookupSyntaxTable, + lookupInstDeclBndr, lookupSubBndr, + lookupSubBndrGREs, lookupConstructorFields, + lookupSyntaxName, lookupSyntaxTable, lookupIfThenElse, lookupGreRn, lookupGreLocalRn, lookupGreRn_maybe, getLookupOccRn, addUsedRdrNames, @@ -36,23 +36,21 @@ #include "HsVersions.h" import LoadIface ( loadInterfaceForName, loadSrcInterface ) -import IfaceEnv ( lookupOrig, newGlobalBinder, newIPName ) +import IfaceEnv ( lookupOrig, newGlobalBinder, newIPName, updNameCache, extendNameCache ) import HsSyn import RdrHsSyn ( extractHsTyRdrTyVars ) import RdrName -import HscTypes ( availNames, ModIface(..), FixItem(..), lookupFixity) +import HscTypes ( NameCache(..), availNames, ModIface(..), FixItem(..), lookupFixity) import TcEnv ( tcLookupDataCon, tcLookupField, isBrackStage ) import TcRnMonad import Id ( isRecordSelector ) -import Name ( Name, nameIsLocalOrFrom, mkInternalName, isWiredInName, - nameSrcLoc, nameSrcSpan, nameOccName, nameModule, isExternalName ) +import Name import NameSet import NameEnv +import Module ( ModuleName, moduleName ) import UniqFM import DataCon ( dataConFieldLabels ) -import OccName -import PrelNames ( mkUnboundName, rOOT_MAIN, iNTERACTIVE, - consDataConKey, forall_tv_RDR ) +import PrelNames ( mkUnboundName, rOOT_MAIN, consDataConKey, forall_tv_RDR ) import Unique import BasicTypes import ErrUtils ( Message ) @@ -93,12 +91,19 @@ -- very confused indeed. This test rejects code like -- data T = (,) Int Int -- unless we are in GHC.Tup - ASSERT2( isExternalName name, ppr name ) - do { this_mod <- getModule - ; unless (this_mod == nameModule name) - (addErrAt loc (badOrigBinding rdr_name)) - ; return name } - + if isExternalName name then + do { this_mod <- getModule + ; unless (this_mod == nameModule name) + (addErrAt loc (badOrigBinding rdr_name)) + ; return name } + else -- See Note [Binders in Template Haskell] in Convert.hs + do { let occ = nameOccName name + ; occ `seq` return () -- c.f. seq in newGlobalBinder + ; this_mod <- getModule + ; updNameCache $ \ ns -> + let name' = mkExternalName (nameUnique name) this_mod occ loc + ns' = ns { nsNames = extendNameCache (nsNames ns) this_mod occ name' } + in (ns', name') } | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name = do { this_mod <- getModule @@ -168,7 +173,7 @@ case nopt of Just n' -> return n' Nothing -> do traceRn $ text "lookupTopBndrRn" - unboundName n + unboundName WL_LocalTop n lookupLocatedTopBndrRn :: Located RdrName -> RnM (Located Name) lookupLocatedTopBndrRn = wrapLocM lookupTopBndrRn @@ -192,7 +197,7 @@ lookupTopBndrRn_maybe rdr_name | Just name <- isExact_maybe rdr_name - = return (Just name) + = do { name' <- lookupExactOcc name; return (Just name') } | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name -- This deals with the case of derived bindings, where @@ -217,6 +222,17 @@ ----------------------------------------------- +lookupExactOcc :: Name -> RnM Name +lookupExactOcc name + | isExternalName name = return name + | otherwise = do { env <- getGlobalRdrEnv + ; let gres = lookupGRE_Name env name + ; case gres of + [] -> return name + [gre] -> return (gre_name gre) + _ -> pprPanic "lookupExactOcc" (ppr name $$ ppr gres) } + +----------------------------------------------- lookupInstDeclBndr :: Name -> RdrName -> RnM Name -- This is called on the method name on the left-hand side of an -- instance declaration binding. eg. instance Functor T where @@ -278,72 +294,83 @@ -> RnM Name lookupSubBndr parent doc rdr_name | Just n <- isExact_maybe rdr_name -- This happens in derived code - = return n + = lookupExactOcc n | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name = lookupOrig rdr_mod rdr_occ | otherwise -- Find all the things the rdr-name maps to - = do { -- and pick the one with the right parent name - ; env <- getGlobalRdrEnv - ; let gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name) - ; case pick parent gres of + = do { -- and pick the one with the right parent namep + env <- getGlobalRdrEnv + ; case lookupSubBndrGREs env parent rdr_name of -- NB: lookupGlobalRdrEnv, not lookupGRE_RdrName! -- The latter does pickGREs, but we want to allow 'x' -- even if only 'M.x' is in scope - [gre] -> do { addUsedRdrNames (used_rdr_names gre) + [gre] -> do { addUsedRdrName gre (used_rdr_name gre) ; return (gre_name gre) } [] -> do { addErr (unknownSubordinateErr doc rdr_name) - ; traceRn (text "RnEnv.lookup_sub_bndr" <+> (ppr rdr_name $$ ppr gres)) ; return (mkUnboundName rdr_name) } gres -> do { addNameClashErrRn rdr_name gres ; return (gre_name (head gres)) } } where - pick NoParent gres -- Normal lookup - = pickGREs rdr_name gres - pick (ParentIs p) gres -- Disambiguating lookup - | isUnqual rdr_name = filter (right_parent p) gres - | otherwise = filter (right_parent p) (pickGREs rdr_name gres) - - right_parent p (GRE { gre_par = ParentIs p' }) = p==p' - right_parent _ _ = False - -- Note [Usage for sub-bndrs] - used_rdr_names gre - | isQual rdr_name = [rdr_name] + used_rdr_name gre + | isQual rdr_name = rdr_name | otherwise = case gre_prov gre of - LocalDef -> [rdr_name] - Imported is -> map mk_qual_rdr is - mk_qual_rdr imp_spec = mkRdrQual (is_as (is_decl imp_spec)) rdr_occ - rdr_occ = rdrNameOcc rdr_name + LocalDef -> rdr_name + Imported is -> used_rdr_name_from_is is + + used_rdr_name_from_is imp_specs -- rdr_name is unqualified + | not (all (is_qual . is_decl) imp_specs) + = rdr_name -- An unqualified import is available + | otherwise + = -- Only qualified imports available, so make up + -- a suitable qualifed name from the first imp_spec + ASSERT( not (null imp_specs) ) + mkRdrQual (is_as (is_decl (head imp_specs))) (rdrNameOcc rdr_name) + +lookupSubBndrGREs :: GlobalRdrEnv -> Parent -> RdrName -> [GlobalRdrElt] +-- If Parent = NoParent, just do a normal lookup +-- If Parent = Parent p then find all GREs that +-- (a) have parent p +-- (b) for Unqual, are in scope qualified or unqualified +-- for Qual, are in scope with that qualification +lookupSubBndrGREs env parent rdr_name + = case parent of + NoParent -> pickGREs rdr_name gres + ParentIs p + | isUnqual rdr_name -> filter (parent_is p) gres + | otherwise -> filter (parent_is p) (pickGREs rdr_name gres) + + where + gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name) + + parent_is p (GRE { gre_par = ParentIs p' }) = p == p' + parent_is _ _ = False newIPNameRn :: IPName RdrName -> TcRnIf m n (IPName Name) newIPNameRn ip_rdr = newIPName (mapIPName rdrNameOcc ip_rdr) - --- If the family is declared locally, it will not yet be in the main --- environment; hence, we pass in an extra one here, which we check first. --- See "Note [Looking up family names in family instances]" in 'RnNames'. --- -lookupFamInstDeclBndr :: GlobalRdrEnv -> Located RdrName -> RnM Name -lookupFamInstDeclBndr tyclGroupEnv (L loc rdr_name) - = setSrcSpan loc $ - case lookupGRE_RdrName rdr_name tyclGroupEnv of - (gre:_) -> return $ gre_name gre - -- if there is more than one, an error will be raised elsewhere - [] -> lookupOccRn rdr_name \end{code} Note [Usage for sub-bndrs] ~~~~~~~~~~~~~~~~~~~~~~~~~~ If you have this import qualified M( C( f ) ) - intance M.C T where + instance M.C T where f x = x then is the qualified import M.f used? Obviously yes. But the RdrName used in the instance decl is unqualified. In effect, we fill in the qualification by looking for f's whose class is M.C But when adding to the UsedRdrNames we must make that qualification -explicit, otherwise we get "Redundant import of M.C". +explicit (saying "used M.f"), otherwise we get "Redundant import of M.f". + +So we make up a suitable (fake) RdrName. But be careful + import qualifed M + import M( C(f) ) + instance C T where + f x = x +Here we want to record a use of 'f', not of 'M.f', otherwise +we'll miss the fact that the qualified import is redundant. -------------------------------------------------- -- Occurrences @@ -361,22 +388,12 @@ -- lookupOccRn looks up an occurrence of a RdrName lookupOccRn :: RdrName -> RnM Name lookupOccRn rdr_name - = getLocalRdrEnv `thenM` \ local_env -> - case lookupLocalRdrEnv local_env rdr_name of - Just name -> return name - Nothing -> lookupGlobalOccRn rdr_name + = do { local_env <- getLocalRdrEnv + ; case lookupLocalRdrEnv local_env rdr_name of { + Just name -> return name ; + Nothing -> do -lookupLocatedGlobalOccRn :: Located RdrName -> RnM (Located Name) -lookupLocatedGlobalOccRn = wrapLocM lookupGlobalOccRn - -lookupGlobalOccRn :: RdrName -> RnM Name --- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global --- environment. Adds an error message if the RdrName is not in scope. --- Also has a special case for GHCi. - -lookupGlobalOccRn rdr_name - = do { -- First look up the name in the normal environment. - mb_name <- lookupGlobalOccRn_maybe rdr_name + { mb_name <- lookupGlobalOccRn_maybe rdr_name ; case mb_name of { Just n -> return n ; Nothing -> do @@ -385,22 +402,33 @@ -- *any* name exported by any module in scope, just as if there -- was an "import qualified M" declaration for every module. allow_qual <- doptM Opt_ImplicitImportQualified - ; mod <- getModule + ; is_ghci <- getIsGHCi -- This test is not expensive, -- and only happens for failed lookups - ; if isQual rdr_name && allow_qual && mod == iNTERACTIVE + ; if isQual rdr_name && allow_qual && is_ghci then lookupQualifiedName rdr_name - else unboundName rdr_name } } } + else unboundName WL_Any rdr_name } } } } } + + +lookupGlobalOccRn :: RdrName -> RnM Name +-- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global +-- environment. Adds an error message if the RdrName is not in scope. +lookupGlobalOccRn rdr_name + = do { mb_name <- lookupGlobalOccRn_maybe rdr_name + ; case mb_name of + Just n -> return n + Nothing -> unboundName WL_Global rdr_name } lookupGlobalOccRn_maybe :: RdrName -> RnM (Maybe Name) -- No filter function; does not report an error on failure lookupGlobalOccRn_maybe rdr_name | Just n <- isExact_maybe rdr_name -- This happens in derived code - = return (Just n) + = do { n' <- lookupExactOcc n; return (Just n') } | Just (rdr_mod, rdr_occ) <- isOrig_maybe rdr_name - = do { n <- lookupOrig rdr_mod rdr_occ; return (Just n) } + = do { n <- lookupOrig rdr_mod rdr_occ + ; return (Just n) } | otherwise = do { mb_gre <- lookupGreRn_maybe rdr_name @@ -409,15 +437,6 @@ Just gre -> return (Just (gre_name gre)) } -unboundName :: RdrName -> RnM Name -unboundName rdr_name - = do { addErr (unknownNameErr rdr_name) - ; env <- getGlobalRdrEnv; - ; traceRn (vcat [unknownNameErr rdr_name, - ptext (sLit "Global envt is:"), - nest 3 (pprGlobalRdrEnv env)]) - ; return (mkUnboundName rdr_name) } - -------------------------------------------------- -- Lookup in the Global RdrEnv of the module -------------------------------------------------- @@ -434,8 +453,7 @@ ; case mb_gre of { Just gre -> return gre ; Nothing -> do - { traceRn $ text "lookupGreRn" - ; name <- unboundName rdr_name + { name <- unboundName WL_Global rdr_name ; return (GRE { gre_name = name, gre_par = NoParent, gre_prov = LocalDef }) }}} @@ -490,14 +508,12 @@ -- and respect hiddenness of modules/packages, hence loadSrcInterface. = loadSrcInterface doc mod False Nothing `thenM` \ iface -> - case [ (mod,occ) | - (mod,avails) <- mi_exports iface, - avail <- avails, - name <- availNames avail, - name == occ ] of - ((mod,occ):ns) -> ASSERT (null ns) - lookupOrig mod occ - _ -> unboundName rdr_name + case [ name + | avail <- mi_exports iface, + name <- availNames avail, + nameOccName name == occ ] of + (n:ns) -> ASSERT (null ns) return n + _ -> unboundName WL_Any rdr_name | otherwise = pprPanic "RnEnv.lookupQualifiedName" (ppr rdr_name) @@ -551,21 +567,21 @@ -- -- See Note [Looking up signature names] lookupBindGroupOcc mb_bound_names what rdr_name - = do { local_env <- getLocalRdrEnv - ; case lookupLocalRdrEnv local_env rdr_name of - Just n -> check_local_name n - Nothing -> do -- Not defined in a nested scope + = do { local_env <- getLocalRdrEnv + ; case lookupLocalRdrEnv local_env rdr_name of { + Just n -> check_local_name n; + Nothing -> do -- Not defined in a nested scope { env <- getGlobalRdrEnv - ; let gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name) - ; case (filter isLocalGRE gres) of - (gre:_) -> check_local_name (gre_name gre) - -- If there is more than one local GRE for the - -- same OccName 'f', that will be reported separately - -- as a duplicate top-level binding for 'f' - [] | null gres -> bale_out_with empty - | otherwise -> bale_out_with import_msg - }} + ; let gres = lookupGlobalRdrEnv env (rdrNameOcc rdr_name) + ; case (filter isLocalGRE gres) of + (gre:_) -> check_local_name (gre_name gre) + -- If there is more than one local GRE for the + -- same OccName 'f', that will be reported separately + -- as a duplicate top-level binding for 'f' + [] | null gres -> bale_out_with empty + | otherwise -> bale_out_with import_msg + }}} where check_local_name name -- The name is in scope, and not imported = case mb_bound_names of @@ -593,7 +609,7 @@ lookupLocalDataTcNames bound_names what rdr_name | Just n <- isExact_maybe rdr_name -- Special case for (:), which doesn't get into the GlobalRdrEnv - = return [n] -- For this we don't need to try the tycon too + = do { n' <- lookupExactOcc n; return [n'] } -- For this we don't need to try the tycon too | otherwise = do { mb_gres <- mapM (lookupBindGroupOcc (Just bound_names) what) (dataTcOccs rdr_name) @@ -766,6 +782,17 @@ checks the type of the user thing against the type of the standard thing. \begin{code} +lookupIfThenElse :: RnM (Maybe (SyntaxExpr Name), FreeVars) +-- Different to lookupSyntaxName because in the non-rebindable +-- case we desugar directly rather than calling an existing function +-- Hence the (Maybe (SyntaxExpr Name)) return type +lookupIfThenElse + = do { rebind <- xoptM Opt_RebindableSyntax + ; if not rebind + then return (Nothing, emptyFVs) + else do { ite <- lookupOccRn (mkVarUnqual (fsLit "ifThenElse")) + ; return (Just (HsVar ite), unitFV ite) } } + lookupSyntaxName :: Name -- The standard name -> RnM (SyntaxExpr Name, FreeVars) -- Possibly a non-standard name lookupSyntaxName std_name @@ -806,8 +833,7 @@ newLocalBndrRn (L loc rdr_name) | Just name <- isExact_maybe rdr_name = return name -- This happens in code generated by Template Haskell - -- although I'm not sure why. Perhpas it's the call - -- in RnPat.newName LetMk? + -- See Note [Binders in Template Haskell] in Convert.lhs | otherwise = do { unless (isUnqual rdr_name) (addErrAt loc (badQualBndrErr rdr_name)) @@ -923,18 +949,20 @@ ------------------------------------- checkDupRdrNames :: [Located RdrName] -> RnM () +-- Check for duplicated names in a binding group checkDupRdrNames rdr_names_w_loc - = -- Check for duplicated names in a binding group - mapM_ (dupNamesErr getLoc) dups + = mapM_ (dupNamesErr getLoc) dups where (_, dups) = removeDups (\n1 n2 -> unLoc n1 `compare` unLoc n2) rdr_names_w_loc checkDupNames :: [Name] -> RnM () +-- Check for duplicated names in a binding group checkDupNames names - = -- Check for duplicated names in a binding group - mapM_ (dupNamesErr nameSrcSpan) dups + = mapM_ (dupNamesErr nameSrcSpan) dups where - (_, dups) = removeDups (\n1 n2 -> nameOccName n1 `compare` nameOccName n2) names + (_, dups) = removeDups (\n1 n2 -> nameOccName n1 `compare` nameOccName n2) $ + filterOut isSystemName names + -- See Note [Binders in Template Haskell] in Convert --------------------- checkDupAndShadowedRdrNames :: [Located RdrName] -> RnM () @@ -955,7 +983,7 @@ ------------------------------------- checkShadowedOccs :: (GlobalRdrEnv, LocalRdrEnv) -> [(SrcSpan,OccName)] -> RnM () checkShadowedOccs (global_env,local_env) loc_occs - = ifDOptM Opt_WarnNameShadowing $ + = ifWOptM Opt_WarnNameShadowing $ do { traceRn (text "shadow" <+> ppr loc_occs) ; mapM_ check_shadow loc_occs } where @@ -993,6 +1021,161 @@ %************************************************************************ %* * + What to do when a lookup fails +%* * +%************************************************************************ + +\begin{code} +data WhereLooking = WL_Any -- Any binding + | WL_Global -- Any top-level binding (local or imported) + | WL_LocalTop -- Any top-level binding in this module + +unboundName :: WhereLooking -> RdrName -> RnM Name +unboundName where_look rdr_name + = do { show_helpful_errors <- doptM Opt_HelpfulErrors + ; let err = unknownNameErr rdr_name + ; if not show_helpful_errors + then addErr err + else do { extra_err <- unknownNameSuggestErr where_look rdr_name + ; addErr (err $$ extra_err) } + + ; env <- getGlobalRdrEnv; + ; traceRn (vcat [unknownNameErr rdr_name, + ptext (sLit "Global envt is:"), + nest 3 (pprGlobalRdrEnv env)]) + + ; return (mkUnboundName rdr_name) } + +unknownNameErr :: RdrName -> SDoc +unknownNameErr rdr_name + = vcat [ hang (ptext (sLit "Not in scope:")) + 2 (pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name)) + <+> quotes (ppr rdr_name)) + , extra ] + where + extra | rdr_name == forall_tv_RDR = perhapsForallMsg + | otherwise = empty + +type HowInScope = Either SrcSpan ImpDeclSpec + -- Left loc => locally bound at loc + -- Right ispec => imported as specified by ispec + +unknownNameSuggestErr :: WhereLooking -> RdrName -> RnM SDoc +unknownNameSuggestErr where_look tried_rdr_name + = do { local_env <- getLocalRdrEnv + ; global_env <- getGlobalRdrEnv + + ; let all_possibilities :: [(String, (RdrName, HowInScope))] + all_possibilities + = [ (showSDoc (ppr r), (r, Left loc)) + | (r,loc) <- local_possibilities local_env ] + ++ [ (showSDoc (ppr r), rp) | (r,rp) <- global_possibilities global_env ] + + suggest = fuzzyLookup (showSDoc (ppr tried_rdr_name)) all_possibilities + perhaps = ptext (sLit "Perhaps you meant") + extra_err = case suggest of + [] -> empty + [p] -> perhaps <+> pp_item p + ps -> sep [ perhaps <+> ptext (sLit "one of these:") + , nest 2 (pprWithCommas pp_item ps) ] + ; return extra_err } + where + pp_item :: (RdrName, HowInScope) -> SDoc + pp_item (rdr, Left loc) = quotes (ppr rdr) <+> -- Locally defined + parens (ptext (sLit "line") <+> int (srcSpanStartLine loc')) + where loc' = case loc of + UnhelpfulSpan _ -> + panic "unknownNameSuggestErr UnhelpfulSpan" + RealSrcSpan l -> l + pp_item (rdr, Right is) = quotes (ppr rdr) <+> -- Imported + parens (ptext (sLit "imported from") <+> ppr (is_mod is)) + + tried_occ = rdrNameOcc tried_rdr_name + tried_is_sym = isSymOcc tried_occ + tried_ns = occNameSpace tried_occ + tried_is_qual = isQual tried_rdr_name + + correct_name_space occ = occNameSpace occ == tried_ns + && isSymOcc occ == tried_is_sym + -- Treat operator and non-operators as non-matching + -- This heuristic avoids things like + -- Not in scope 'f'; perhaps you meant '+' (from Prelude) + + local_ok = case where_look of { WL_Any -> True; _ -> False } + local_possibilities :: LocalRdrEnv -> [(RdrName, SrcSpan)] + local_possibilities env + | tried_is_qual = [] + | not local_ok = [] + | otherwise = [ (mkRdrUnqual occ, nameSrcSpan name) + | name <- occEnvElts env + , let occ = nameOccName name + , correct_name_space occ] + + gre_ok :: GlobalRdrElt -> Bool + gre_ok = case where_look of + WL_LocalTop -> isLocalGRE + _ -> \_ -> True + + global_possibilities :: GlobalRdrEnv -> [(RdrName, (RdrName, HowInScope))] + global_possibilities global_env + | tried_is_qual = [ (rdr_qual, (rdr_qual, how)) + | gre <- globalRdrEnvElts global_env + , gre_ok gre + , let name = gre_name gre + occ = nameOccName name + , correct_name_space occ + , (mod, how) <- quals_in_scope name (gre_prov gre) + , let rdr_qual = mkRdrQual mod occ ] + + | otherwise = [ (rdr_unqual, pair) + | gre <- globalRdrEnvElts global_env + , gre_ok gre + , let name = gre_name gre + prov = gre_prov gre + occ = nameOccName name + rdr_unqual = mkRdrUnqual occ + , correct_name_space occ + , pair <- case (unquals_in_scope name prov, quals_only occ prov) of + (how:_, _) -> [ (rdr_unqual, how) ] + ([], pr:_) -> [ pr ] -- See Note [Only-quals] + ([], []) -> [] ] + + -- Note [Only-quals] + -- The second alternative returns those names with the same + -- OccName as the one we tried, but live in *qualified* imports + -- e.g. if you have: + -- + -- > import qualified Data.Map as Map + -- > foo :: Map + -- + -- then we suggest @Map.Map@. + + -------------------- + unquals_in_scope :: Name -> Provenance -> [HowInScope] + unquals_in_scope n LocalDef = [ Left (nameSrcSpan n) ] + unquals_in_scope _ (Imported is) = [ Right ispec + | i <- is, let ispec = is_decl i + , not (is_qual ispec) ] + + -------------------- + quals_in_scope :: Name -> Provenance -> [(ModuleName, HowInScope)] + -- Ones for which the qualified version is in scope + quals_in_scope n LocalDef = case nameModule_maybe n of + Nothing -> [] + Just m -> [(moduleName m, Left (nameSrcSpan n))] + quals_in_scope _ (Imported is) = [ (is_as ispec, Right ispec) + | i <- is, let ispec = is_decl i ] + + -------------------- + quals_only :: OccName -> Provenance -> [(RdrName, HowInScope)] + -- Ones for which *only* the qualified version is in scope + quals_only _ LocalDef = [] + quals_only occ (Imported is) = [ (mkRdrQual (is_as ispec) occ, Right ispec) + | i <- is, let ispec = is_decl i, is_qual ispec ] +\end{code} + +%************************************************************************ +%* * \subsection{Free variable manipulation} %* * %************************************************************************ @@ -1034,7 +1217,7 @@ \begin{code} warnUnusedTopBinds :: [GlobalRdrElt] -> RnM () warnUnusedTopBinds gres - = ifDOptM Opt_WarnUnusedBinds + = ifWOptM Opt_WarnUnusedBinds $ do isBoot <- tcIsHsBoot let noParent gre = case gre_par gre of NoParent -> True @@ -1050,9 +1233,9 @@ warnUnusedLocalBinds = check_unused Opt_WarnUnusedBinds warnUnusedMatches = check_unused Opt_WarnUnusedMatches -check_unused :: DynFlag -> [Name] -> FreeVars -> RnM () +check_unused :: WarningFlag -> [Name] -> FreeVars -> RnM () check_unused flag bound_names used_names - = ifDOptM flag (warnUnusedLocals (filterOut (`elemNameSet` used_names) bound_names)) + = ifWOptM flag (warnUnusedLocals (filterOut (`elemNameSet` used_names) bound_names)) ------------------------- -- Helpers @@ -1113,16 +1296,6 @@ <+> ptext (sLit "shadows the existing binding") <> plural shadowed_locs, nest 2 (vcat shadowed_locs)] -unknownNameErr :: RdrName -> SDoc -unknownNameErr rdr_name - = vcat [ hang (ptext (sLit "Not in scope:")) - 2 (pprNonVarNameSpace (occNameSpace (rdrNameOcc rdr_name)) - <+> quotes (ppr rdr_name)) - , extra ] - where - extra | rdr_name == forall_tv_RDR = perhapsForallMsg - | otherwise = empty - perhapsForallMsg :: SDoc perhapsForallMsg = vcat [ ptext (sLit "Perhaps you intended to use -XExplicitForAll or similar flag") diff -Nru ghc-7.0.3/compiler/rename/RnExpr.lhs ghc-7.2.1/compiler/rename/RnExpr.lhs --- ghc-7.0.3/compiler/rename/RnExpr.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/rename/RnExpr.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -40,7 +40,7 @@ import LoadIface ( loadInterfaceForName ) import UniqSet import Data.List -import Util ( isSingleton ) +import Util ( isSingleton, snocView ) import ListSetOps ( removeDups ) import Outputable import SrcLoc @@ -224,10 +224,9 @@ rnLExpr expr `thenM` \ (expr',fvExpr) -> return (HsLet binds' expr', fvExpr) -rnExpr (HsDo do_or_lc stmts body _) - = do { ((stmts', body'), fvs) <- rnStmts do_or_lc stmts $ - rnLExpr body - ; return (HsDo do_or_lc stmts' body' placeHolderType, fvs) } +rnExpr (HsDo do_or_lc stmts _) + = do { ((stmts', _), fvs) <- rnStmts do_or_lc stmts (\ _ -> return ((), emptyFVs)) + ; return ( HsDo do_or_lc stmts' placeHolderType, fvs ) } rnExpr (ExplicitList _ exps) = rnExprs exps `thenM` \ (exps', fvs) -> @@ -268,13 +267,10 @@ rnExpr (HsIf _ p b1 b2) = do { (p', fvP) <- rnLExpr p - ; (b1', fvB1) <- rnLExpr b1 - ; (b2', fvB2) <- rnLExpr b2 - ; rebind <- xoptM Opt_RebindableSyntax - ; if not rebind - then return (HsIf Nothing p' b1' b2', plusFVs [fvP, fvB1, fvB2]) - else do { c <- liftM HsVar (lookupOccRn (mkVarUnqual (fsLit "ifThenElse"))) - ; return (HsIf (Just c) p' b1' b2', plusFVs [fvP, fvB1, fvB2]) }} + ; (b1', fvB1) <- rnLExpr b1 + ; (b2', fvB2) <- rnLExpr b2 + ; (mb_ite, fvITE) <- lookupIfThenElse + ; return (HsIf mb_ite p' b1' b2', plusFVs [fvITE, fvP, fvB1, fvB2]) } rnExpr (HsType a) = rnHsTypeFVs doc a `thenM` \ (t, fvT) -> @@ -444,9 +440,9 @@ convertOpFormsCmd (HsLet binds cmd) = HsLet binds (convertOpFormsLCmd cmd) -convertOpFormsCmd (HsDo ctxt stmts body ty) - = HsDo ctxt (map (fmap convertOpFormsStmt) stmts) - (convertOpFormsLCmd body) ty +convertOpFormsCmd (HsDo DoExpr stmts ty) + = HsDo ArrowExpr (map (fmap convertOpFormsStmt) stmts) ty + -- Mark the HsDo as begin the body of an arrow command -- Anything else is unchanged. This includes HsArrForm (already done), -- things with no sub-commands, and illegal commands (which will be @@ -456,8 +452,8 @@ convertOpFormsStmt :: StmtLR id id -> StmtLR id id convertOpFormsStmt (BindStmt pat cmd _ _) = BindStmt pat (convertOpFormsLCmd cmd) noSyntaxExpr noSyntaxExpr -convertOpFormsStmt (ExprStmt cmd _ _) - = ExprStmt (convertOpFormsLCmd cmd) noSyntaxExpr placeHolderType +convertOpFormsStmt (ExprStmt cmd _ _ _) + = ExprStmt (convertOpFormsLCmd cmd) noSyntaxExpr noSyntaxExpr placeHolderType convertOpFormsStmt stmt@(RecStmt { recS_stmts = stmts }) = stmt { recS_stmts = map (fmap convertOpFormsStmt) stmts } convertOpFormsStmt stmt = stmt @@ -498,14 +494,10 @@ methodNamesCmd (HsIf _ _ c1 c2) = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName -methodNamesCmd (HsLet _ c) = methodNamesLCmd c - -methodNamesCmd (HsDo _ stmts body _) - = methodNamesStmts stmts `plusFV` methodNamesLCmd body - -methodNamesCmd (HsApp c _) = methodNamesLCmd c - -methodNamesCmd (HsLam match) = methodNamesMatch match +methodNamesCmd (HsLet _ c) = methodNamesLCmd c +methodNamesCmd (HsDo _ stmts _) = methodNamesStmts stmts +methodNamesCmd (HsApp c _) = methodNamesLCmd c +methodNamesCmd (HsLam match) = methodNamesMatch match methodNamesCmd (HsCase _ matches) = methodNamesMatch matches `addOneFV` choiceAName @@ -541,14 +533,14 @@ methodNamesLStmt = methodNamesStmt . unLoc methodNamesStmt :: StmtLR Name Name -> FreeVars -methodNamesStmt (ExprStmt cmd _ _) = methodNamesLCmd cmd +methodNamesStmt (LastStmt cmd _) = methodNamesLCmd cmd +methodNamesStmt (ExprStmt cmd _ _ _) = methodNamesLCmd cmd methodNamesStmt (BindStmt _ cmd _ _) = methodNamesLCmd cmd methodNamesStmt (RecStmt { recS_stmts = stmts }) = methodNamesStmts stmts `addOneFV` loopAName methodNamesStmt (LetStmt _) = emptyFVs -methodNamesStmt (ParStmt _) = emptyFVs -methodNamesStmt (TransformStmt {}) = emptyFVs -methodNamesStmt (GroupStmt {}) = emptyFVs - -- ParStmt, TransformStmt and GroupStmt can't occur in commands, but it's not convenient to error +methodNamesStmt (ParStmt _ _ _ _) = emptyFVs +methodNamesStmt (TransStmt {}) = emptyFVs + -- ParStmt and TransStmt can't occur in commands, but it's not convenient to error -- here so we just do what's convenient \end{code} @@ -591,14 +583,16 @@ \begin{code} rnBracket :: HsBracket RdrName -> RnM (HsBracket Name, FreeVars) -rnBracket (VarBr n) = do { name <- lookupOccRn n - ; this_mod <- getModule - ; unless (nameIsLocalOrFrom this_mod name) $ -- Reason: deprecation checking asumes the - do { _ <- loadInterfaceForName msg name -- home interface is loaded, and this is the - ; return () } -- only way that is going to happen - ; return (VarBr name, unitFV name) } - where - msg = ptext (sLit "Need interface for Template Haskell quoted Name") +rnBracket (VarBr n) + = do { name <- lookupOccRn n + ; this_mod <- getModule + ; unless (nameIsLocalOrFrom this_mod name) $ -- Reason: deprecation checking assumes + do { _ <- loadInterfaceForName msg name -- the home interface is loaded, and + ; return () } -- this is the only way that is going + -- to happen + ; return (VarBr name, unitFV name) } + where + msg = ptext (sLit "Need interface for Template Haskell quoted Name") rnBracket (ExpBr e) = do { (e', fvs) <- rnLExpr e ; return (ExpBr e', fvs) } @@ -628,7 +622,8 @@ rnSrcDecls group -- Discard the tcg_env; it contains only extra info about fixity - ; traceRn (text "rnBracket dec" <+> (ppr (tcg_dus tcg_env) $$ ppr (duUses (tcg_dus tcg_env)))) + ; traceRn (text "rnBracket dec" <+> (ppr (tcg_dus tcg_env) $$ + ppr (duUses (tcg_dus tcg_env)))) ; return (DecBrG group', duUses (tcg_dus tcg_env)) } rnBracket (DecBrG _) = panic "rnBracket: unexpected DecBrG" @@ -641,54 +636,75 @@ %************************************************************************ \begin{code} -rnStmts :: HsStmtContext Name -> [LStmt RdrName] - -> RnM (thing, FreeVars) - -> RnM (([LStmt Name], thing), FreeVars) +rnStmts :: HsStmtContext Name -> [LStmt RdrName] + -> ([Name] -> RnM (thing, FreeVars)) + -> RnM (([LStmt Name], thing), FreeVars) -- Variables bound by the Stmts, and mentioned in thing_inside, -- do not appear in the result FreeVars -rnStmts (MDoExpr _) stmts thing_inside = rnMDoStmts stmts thing_inside -rnStmts ctxt stmts thing_inside = rnNormalStmts ctxt stmts (\ _ -> thing_inside) - -rnNormalStmts :: HsStmtContext Name -> [LStmt RdrName] - -> ([Name] -> RnM (thing, FreeVars)) - -> RnM (([LStmt Name], thing), FreeVars) --- Variables bound by the Stmts, and mentioned in thing_inside, --- do not appear in the result FreeVars --- --- Renaming a single RecStmt can give a sequence of smaller Stmts +rnStmts ctxt [] thing_inside + = do { checkEmptyStmts ctxt + ; (thing, fvs) <- thing_inside [] + ; return (([], thing), fvs) } + +rnStmts MDoExpr stmts thing_inside -- Deal with mdo + = -- Behave like do { rec { ...all but last... }; last } + do { ((stmts1, (stmts2, thing)), fvs) + <- rnStmt MDoExpr (noLoc $ mkRecStmt all_but_last) $ \ _ -> + do { last_stmt' <- checkLastStmt MDoExpr last_stmt + ; rnStmt MDoExpr last_stmt' thing_inside } + ; return (((stmts1 ++ stmts2), thing), fvs) } + where + Just (all_but_last, last_stmt) = snocView stmts -rnNormalStmts _ [] thing_inside - = do { (res, fvs) <- thing_inside [] - ; return (([], res), fvs) } +rnStmts ctxt (lstmt@(L loc _) : lstmts) thing_inside + | null lstmts + = setSrcSpan loc $ + do { lstmt' <- checkLastStmt ctxt lstmt + ; rnStmt ctxt lstmt' thing_inside } -rnNormalStmts ctxt (stmt@(L loc _) : stmts) thing_inside + | otherwise = do { ((stmts1, (stmts2, thing)), fvs) - <- setSrcSpan loc $ - rnStmt ctxt stmt $ \ bndrs1 -> - rnNormalStmts ctxt stmts $ \ bndrs2 -> - thing_inside (bndrs1 ++ bndrs2) + <- setSrcSpan loc $ + do { checkStmt ctxt lstmt + ; rnStmt ctxt lstmt $ \ bndrs1 -> + rnStmts ctxt lstmts $ \ bndrs2 -> + thing_inside (bndrs1 ++ bndrs2) } ; return (((stmts1 ++ stmts2), thing), fvs) } - -rnStmt :: HsStmtContext Name -> LStmt RdrName +---------------------- +rnStmt :: HsStmtContext Name + -> LStmt RdrName -> ([Name] -> RnM (thing, FreeVars)) -> RnM (([LStmt Name], thing), FreeVars) -- Variables bound by the Stmt, and mentioned in thing_inside, -- do not appear in the result FreeVars -rnStmt _ (L loc (ExprStmt expr _ _)) thing_inside +rnStmt ctxt (L loc (LastStmt expr _)) thing_inside = do { (expr', fv_expr) <- rnLExpr expr - ; (then_op, fvs1) <- lookupSyntaxName thenMName - ; (thing, fvs2) <- thing_inside [] - ; return (([L loc (ExprStmt expr' then_op placeHolderType)], thing), - fv_expr `plusFV` fvs1 `plusFV` fvs2) } + ; (ret_op, fvs1) <- lookupStmtName ctxt returnMName + ; (thing, fvs3) <- thing_inside [] + ; return (([L loc (LastStmt expr' ret_op)], thing), + fv_expr `plusFV` fvs1 `plusFV` fvs3) } + +rnStmt ctxt (L loc (ExprStmt expr _ _ _)) thing_inside + = do { (expr', fv_expr) <- rnLExpr expr + ; (then_op, fvs1) <- lookupStmtName ctxt thenMName + ; (guard_op, fvs2) <- if isListCompExpr ctxt + then lookupStmtName ctxt guardMName + else return (noSyntaxExpr, emptyFVs) + -- Only list/parr/monad comprehensions use 'guard' + -- Also for sub-stmts of same eg [ e | x<-xs, gd | blah ] + -- Here "gd" is a guard + ; (thing, fvs3) <- thing_inside [] + ; return (([L loc (ExprStmt expr' then_op guard_op placeHolderType)], thing), + fv_expr `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } rnStmt ctxt (L loc (BindStmt pat expr _ _)) thing_inside = do { (expr', fv_expr) <- rnLExpr expr -- The binders do not scope over the expression - ; (bind_op, fvs1) <- lookupSyntaxName bindMName - ; (fail_op, fvs2) <- lookupSyntaxName failMName + ; (bind_op, fvs1) <- lookupStmtName ctxt bindMName + ; (fail_op, fvs2) <- lookupStmtName ctxt failMName ; rnPat (StmtCtxt ctxt) pat $ \ pat' -> do { (thing, fvs3) <- thing_inside (collectPatBinders pat') ; return (([L loc (BindStmt pat' expr' bind_op fail_op)], thing), @@ -696,15 +712,13 @@ -- fv_expr shouldn't really be filtered by the rnPatsAndThen -- but it does not matter because the names are unique -rnStmt ctxt (L loc (LetStmt binds)) thing_inside - = do { checkLetStmt ctxt binds - ; rnLocalBindsAndThen binds $ \binds' -> do +rnStmt _ (L loc (LetStmt binds)) thing_inside + = do { rnLocalBindsAndThen binds $ \binds' -> do { (thing, fvs) <- thing_inside (collectLocalBinders binds') ; return (([L loc (LetStmt binds')], thing), fvs) } } rnStmt ctxt (L _ (RecStmt { recS_stmts = rec_stmts })) thing_inside - = do { checkRecStmt ctxt - + = do { -- Step1: Bring all the binders of the mdo into scope -- (Remember that this also removes the binders from the -- finally-returned free-vars.) @@ -714,14 +728,14 @@ -- for which it's the fwd refs within the bind itself -- (This set may not be empty, because we're in a recursive -- context.) - ; rn_rec_stmts_and_then rec_stmts $ \ segs -> do + ; rnRecStmtsAndThen rec_stmts $ \ segs -> do { let bndrs = nameSetToList $ foldr (unionNameSets . (\(ds,_,_,_) -> ds)) emptyNameSet segs ; (thing, fvs_later) <- thing_inside bndrs - ; (return_op, fvs1) <- lookupSyntaxName returnMName - ; (mfix_op, fvs2) <- lookupSyntaxName mfixName - ; (bind_op, fvs3) <- lookupSyntaxName bindMName + ; (return_op, fvs1) <- lookupStmtName ctxt returnMName + ; (mfix_op, fvs2) <- lookupStmtName ctxt mfixName + ; (bind_op, fvs3) <- lookupStmtName ctxt bindMName ; let -- Step 2: Fill in the fwd refs. -- The segments are all singletons, but their fwd-ref @@ -746,57 +760,51 @@ ; return ((rec_stmts', thing), fvs `plusFV` fvs1 `plusFV` fvs2 `plusFV` fvs3) } } -rnStmt ctxt (L loc (ParStmt segs)) thing_inside - = do { checkParStmt ctxt - ; ((segs', thing), fvs) <- rnParallelStmts (ParStmtCtxt ctxt) segs thing_inside - ; return (([L loc (ParStmt segs')], thing), fvs) } - -rnStmt ctxt (L loc (TransformStmt stmts _ using by)) thing_inside - = do { checkTransformStmt ctxt - - ; (using', fvs1) <- rnLExpr using - - ; ((stmts', (by', used_bndrs, thing)), fvs2) - <- rnNormalStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs -> - do { (by', fvs_by) <- case by of - Nothing -> return (Nothing, emptyFVs) - Just e -> do { (e', fvs) <- rnLExpr e; return (Just e', fvs) } - ; (thing, fvs_thing) <- thing_inside bndrs - ; let fvs = fvs_by `plusFV` fvs_thing - used_bndrs = filter (`elemNameSet` fvs) bndrs - -- The paper (Fig 5) has a bug here; we must treat any free varaible of - -- the "thing inside", **or of the by-expression**, as used - ; return ((by', used_bndrs, thing), fvs) } - - ; return (([L loc (TransformStmt stmts' used_bndrs using' by')], thing), - fvs1 `plusFV` fvs2) } - -rnStmt ctxt (L loc (GroupStmt stmts _ by using)) thing_inside - = do { checkTransformStmt ctxt - - -- Rename the 'using' expression in the context before the transform is begun - ; (using', fvs1) <- case using of - Left e -> do { (e', fvs) <- rnLExpr e; return (Left e', fvs) } - Right _ -> do { (e', fvs) <- lookupSyntaxName groupWithName - ; return (Right e', fvs) } +rnStmt ctxt (L loc (ParStmt segs _ _ _)) thing_inside + = do { (mzip_op, fvs1) <- lookupStmtName ctxt mzipName + ; (bind_op, fvs2) <- lookupStmtName ctxt bindMName + ; (return_op, fvs3) <- lookupStmtName ctxt returnMName + ; ((segs', thing), fvs4) <- rnParallelStmts (ParStmtCtxt ctxt) segs thing_inside + ; return ( ([L loc (ParStmt segs' mzip_op bind_op return_op)], thing) + , fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) } + +rnStmt ctxt (L loc (TransStmt { trS_stmts = stmts, trS_by = by, trS_form = form + , trS_using = using })) thing_inside + = do { -- Rename the 'using' expression in the context before the transform is begun + (using', fvs1) <- case form of + GroupFormB -> do { (e,fvs) <- lookupStmtName ctxt groupMName + ; return (noLoc e, fvs) } + _ -> rnLExpr using -- Rename the stmts and the 'by' expression -- Keep track of the variables mentioned in the 'by' expression ; ((stmts', (by', used_bndrs, thing)), fvs2) - <- rnNormalStmts (TransformStmtCtxt ctxt) stmts $ \ bndrs -> + <- rnStmts (TransStmtCtxt ctxt) stmts $ \ bndrs -> do { (by', fvs_by) <- mapMaybeFvRn rnLExpr by ; (thing, fvs_thing) <- thing_inside bndrs ; let fvs = fvs_by `plusFV` fvs_thing used_bndrs = filter (`elemNameSet` fvs) bndrs + -- The paper (Fig 5) has a bug here; we must treat any free varaible + -- of the "thing inside", **or of the by-expression**, as used ; return ((by', used_bndrs, thing), fvs) } - ; let all_fvs = fvs1 `plusFV` fvs2 + -- Lookup `return`, `(>>=)` and `liftM` for monad comprehensions + ; (return_op, fvs3) <- lookupStmtName ctxt returnMName + ; (bind_op, fvs4) <- lookupStmtName ctxt bindMName + ; (fmap_op, fvs5) <- case form of + ThenForm -> return (noSyntaxExpr, emptyFVs) + _ -> lookupStmtName ctxt fmapName + + ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3 + `plusFV` fvs4 `plusFV` fvs5 bndr_map = used_bndrs `zip` used_bndrs - -- See Note [GroupStmt binder map] in HsExpr + -- See Note [TransStmt binder map] in HsExpr ; traceRn (text "rnStmt: implicitly rebound these used binders:" <+> ppr bndr_map) - ; return (([L loc (GroupStmt stmts' bndr_map by' using')], thing), all_fvs) } - + ; return (([L loc (TransStmt { trS_stmts = stmts', trS_bndrs = bndr_map + , trS_by = by', trS_using = using', trS_form = form + , trS_ret = return_op, trS_bind = bind_op + , trS_fmap = fmap_op })], thing), all_fvs) } type ParSeg id = ([LStmt id], [id]) -- The Names are bound by the Stmts @@ -820,7 +828,7 @@ rn_segs env bndrs_so_far ((stmts,_) : segs) = do { ((stmts', (used_bndrs, segs', thing)), fvs) - <- rnNormalStmts ctxt stmts $ \ bndrs -> + <- rnStmts ctxt stmts $ \ bndrs -> setLocalRdrEnv env $ do { ((segs', thing), fvs) <- rn_segs env (bndrs ++ bndrs_so_far) segs ; let used_bndrs = filter (`elemNameSet` fvs) bndrs @@ -832,6 +840,27 @@ cmpByOcc n1 n2 = nameOccName n1 `compare` nameOccName n2 dupErr vs = addErr (ptext (sLit "Duplicate binding in parallel list comprehension for:") <+> quotes (ppr (head vs))) + +lookupStmtName :: HsStmtContext Name -> Name -> RnM (HsExpr Name, FreeVars) +-- Like lookupSyntaxName, but ListComp/PArrComp are never rebindable +-- Neither is ArrowExpr, which has its own desugarer in DsArrows +lookupStmtName ctxt n + = case ctxt of + ListComp -> not_rebindable + PArrComp -> not_rebindable + ArrowExpr -> not_rebindable + PatGuard {} -> not_rebindable + + DoExpr -> rebindable + MDoExpr -> rebindable + MonadComp -> rebindable + GhciStmt -> rebindable -- I suppose? + + ParStmtCtxt c -> lookupStmtName c n -- Look inside to + TransStmtCtxt c -> lookupStmtName c n -- the parent context + where + rebindable = lookupSyntaxName n + not_rebindable = return (HsVar n, emptyFVs) \end{code} Note [Renaming parallel Stmts] @@ -868,28 +897,13 @@ stmts) -- Either Stmt or [Stmt] ----------------------------------------------------- - -rnMDoStmts :: [LStmt RdrName] - -> RnM (thing, FreeVars) - -> RnM (([LStmt Name], thing), FreeVars) -rnMDoStmts stmts thing_inside - = rn_rec_stmts_and_then stmts $ \ segs -> do - { (thing, fvs_later) <- thing_inside - ; let segs_w_fwd_refs = addFwdRefs segs - grouped_segs = glomSegments segs_w_fwd_refs - (stmts', fvs) = segsToStmts emptyRecStmt grouped_segs fvs_later - ; return ((stmts', thing), fvs) } - ---------------------------------------------- - -- wrapper that does both the left- and right-hand sides -rn_rec_stmts_and_then :: [LStmt RdrName] +rnRecStmtsAndThen :: [LStmt RdrName] -- assumes that the FreeVars returned includes -- the FreeVars of the Segments -> ([Segment (LStmt Name)] -> RnM (a, FreeVars)) -> RnM (a, FreeVars) -rn_rec_stmts_and_then s cont +rnRecStmtsAndThen s cont = do { -- (A) Make the mini fixity env for all of the stmts fix_env <- makeMiniFixityEnv (collectRecStmtsFixities s) @@ -898,13 +912,15 @@ -- ...bring them and their fixities into scope ; let bound_names = collectLStmtsBinders (map fst new_lhs_and_fv) + -- Fake uses of variables introduced implicitly (warning suppression, see #4404) + implicit_uses = lStmtsImplicits (map fst new_lhs_and_fv) ; bindLocalNamesFV bound_names $ addLocalFixities fix_env bound_names $ do -- (C) do the right-hand-sides and thing-inside { segs <- rn_rec_stmts bound_names new_lhs_and_fv ; (res, fvs) <- cont segs - ; warnUnusedLocalBinds bound_names fvs + ; warnUnusedLocalBinds bound_names (fvs `unionNameSets` implicit_uses) ; return (res, fvs) }} -- get all the fixity decls in any Let stmt @@ -926,9 +942,11 @@ -- so we don't bother to compute it accurately in the other cases -> RnM [(LStmtLR Name RdrName, FreeVars)] -rn_rec_stmt_lhs _ (L loc (ExprStmt expr a b)) = return [(L loc (ExprStmt expr a b), - -- this is actually correct - emptyFVs)] +rn_rec_stmt_lhs _ (L loc (ExprStmt expr a b c)) + = return [(L loc (ExprStmt expr a b c), emptyFVs)] + +rn_rec_stmt_lhs _ (L loc (LastStmt expr a)) + = return [(L loc (LastStmt expr a), emptyFVs)] rn_rec_stmt_lhs fix_env (L loc (BindStmt pat expr a b)) = do @@ -951,13 +969,10 @@ rn_rec_stmt_lhs fix_env (L _ (RecStmt { recS_stmts = stmts })) -- Flatten Rec inside Rec = rn_rec_stmts_lhs fix_env stmts -rn_rec_stmt_lhs _ stmt@(L _ (ParStmt _)) -- Syntactically illegal in mdo - = pprPanic "rn_rec_stmt" (ppr stmt) - -rn_rec_stmt_lhs _ stmt@(L _ (TransformStmt {})) -- Syntactically illegal in mdo +rn_rec_stmt_lhs _ stmt@(L _ (ParStmt _ _ _ _)) -- Syntactically illegal in mdo = pprPanic "rn_rec_stmt" (ppr stmt) -rn_rec_stmt_lhs _ stmt@(L _ (GroupStmt {})) -- Syntactically illegal in mdo +rn_rec_stmt_lhs _ stmt@(L _ (TransStmt {})) -- Syntactically illegal in mdo = pprPanic "rn_rec_stmt" (ppr stmt) rn_rec_stmt_lhs _ (L _ (LetStmt EmptyLocalBinds)) @@ -982,11 +997,17 @@ -- Rename a Stmt that is inside a RecStmt (or mdo) -- Assumes all binders are already in scope -- Turns each stmt into a singleton Stmt -rn_rec_stmt _ (L loc (ExprStmt expr _ _)) _ +rn_rec_stmt _ (L loc (LastStmt expr _)) _ + = do { (expr', fv_expr) <- rnLExpr expr + ; (ret_op, fvs1) <- lookupSyntaxName returnMName + ; return [(emptyNameSet, fv_expr `plusFV` fvs1, emptyNameSet, + L loc (LastStmt expr' ret_op))] } + +rn_rec_stmt _ (L loc (ExprStmt expr _ _ _)) _ = rnLExpr expr `thenM` \ (expr', fvs) -> lookupSyntaxName thenMName `thenM` \ (then_op, fvs1) -> return [(emptyNameSet, fvs `plusFV` fvs1, emptyNameSet, - L loc (ExprStmt expr' then_op placeHolderType))] + L loc (ExprStmt expr' then_op noSyntaxExpr placeHolderType))] rn_rec_stmt _ (L loc (BindStmt pat' expr _ _)) fv_pat = rnLExpr expr `thenM` \ (expr', fv_expr) -> @@ -1004,7 +1025,7 @@ rn_rec_stmt all_bndrs (L loc (LetStmt (HsValBinds binds'))) _ = do (binds', du_binds) <- - -- fixities and unused are handled above in rn_rec_stmts_and_then + -- fixities and unused are handled above in rnRecStmtsAndThen rnLocalValBindsRHS (mkNameSet all_bndrs) binds' return [(duDefs du_binds, allUses du_binds, emptyNameSet, L loc (LetStmt (HsValBinds binds')))] @@ -1016,11 +1037,8 @@ rn_rec_stmt _ stmt@(L _ (ParStmt {})) _ -- Syntactically illegal in mdo = pprPanic "rn_rec_stmt: ParStmt" (ppr stmt) -rn_rec_stmt _ stmt@(L _ (TransformStmt {})) _ -- Syntactically illegal in mdo - = pprPanic "rn_rec_stmt: TransformStmt" (ppr stmt) - -rn_rec_stmt _ stmt@(L _ (GroupStmt {})) _ -- Syntactically illegal in mdo - = pprPanic "rn_rec_stmt: GroupStmt" (ppr stmt) +rn_rec_stmt _ stmt@(L _ (TransStmt {})) _ -- Syntactically illegal in mdo + = pprPanic "rn_rec_stmt: TransStmt" (ppr stmt) rn_rec_stmt _ (L _ (LetStmt EmptyLocalBinds)) _ = panic "rn_rec_stmt: LetStmt EmptyLocalBinds" @@ -1166,44 +1184,151 @@ %************************************************************************ \begin{code} +checkEmptyStmts :: HsStmtContext Name -> RnM () +-- We've seen an empty sequence of Stmts... is that ok? +checkEmptyStmts ctxt + = unless (okEmpty ctxt) (addErr (emptyErr ctxt)) + +okEmpty :: HsStmtContext a -> Bool +okEmpty (PatGuard {}) = True +okEmpty _ = False + +emptyErr :: HsStmtContext Name -> SDoc +emptyErr (ParStmtCtxt {}) = ptext (sLit "Empty statement group in parallel comprehension") +emptyErr (TransStmtCtxt {}) = ptext (sLit "Empty statement group preceding 'group' or 'then'") +emptyErr ctxt = ptext (sLit "Empty") <+> pprStmtContext ctxt ---------------------- --- Checking when a particular Stmt is ok -checkLetStmt :: HsStmtContext Name -> HsLocalBinds RdrName -> RnM () -checkLetStmt (ParStmtCtxt _) (HsIPBinds binds) = addErr (badIpBinds (ptext (sLit "a parallel list comprehension:")) binds) -checkLetStmt _ctxt _binds = return () - -- We do not allow implicit-parameter bindings in a parallel - -- list comprehension. I'm not sure what it might mean. - ---------- -checkRecStmt :: HsStmtContext Name -> RnM () -checkRecStmt (MDoExpr {}) = return () -- Recursive stmt ok in 'mdo' -checkRecStmt (DoExpr {}) = return () -- and in 'do' -checkRecStmt ctxt = addErr msg +checkLastStmt :: HsStmtContext Name + -> LStmt RdrName + -> RnM (LStmt RdrName) +checkLastStmt ctxt lstmt@(L loc stmt) + = case ctxt of + ListComp -> check_comp + MonadComp -> check_comp + PArrComp -> check_comp + ArrowExpr -> check_do + DoExpr -> check_do + MDoExpr -> check_do + _ -> check_other where - msg = ptext (sLit "Illegal 'rec' stmt in") <+> pprStmtContext ctxt + check_do -- Expect ExprStmt, and change it to LastStmt + = case stmt of + ExprStmt e _ _ _ -> return (L loc (mkLastStmt e)) + LastStmt {} -> return lstmt -- "Deriving" clauses may generate a + -- LastStmt directly (unlike the parser) + _ -> do { addErr (hang last_error 2 (ppr stmt)); return lstmt } + last_error = (ptext (sLit "The last statement in") <+> pprAStmtContext ctxt + <+> ptext (sLit "must be an expression")) + + check_comp -- Expect LastStmt; this should be enforced by the parser! + = case stmt of + LastStmt {} -> return lstmt + _ -> pprPanic "checkLastStmt" (ppr lstmt) ---------- -checkParStmt :: HsStmtContext Name -> RnM () -checkParStmt _ - = do { parallel_list_comp <- xoptM Opt_ParallelListComp - ; checkErr parallel_list_comp msg } - where - msg = ptext (sLit "Illegal parallel list comprehension: use -XParallelListComp") + check_other -- Behave just as if this wasn't the last stmt + = do { checkStmt ctxt lstmt; return lstmt } ---------- -checkTransformStmt :: HsStmtContext Name -> RnM () -checkTransformStmt ListComp -- Ensure we are really within a list comprehension because otherwise the - -- desugarer will break when we come to operate on a parallel array - = do { transform_list_comp <- xoptM Opt_TransformListComp - ; checkErr transform_list_comp msg } - where - msg = ptext (sLit "Illegal transform or grouping list comprehension: use -XTransformListComp") -checkTransformStmt (ParStmtCtxt ctxt) = checkTransformStmt ctxt -- Ok to nest inside a parallel comprehension -checkTransformStmt (TransformStmtCtxt ctxt) = checkTransformStmt ctxt -- Ok to nest inside a parallel comprehension -checkTransformStmt ctxt = addErr msg +-- Checking when a particular Stmt is ok +checkStmt :: HsStmtContext Name + -> LStmt RdrName + -> RnM () +checkStmt ctxt (L _ stmt) + = do { dflags <- getDOpts + ; case okStmt dflags ctxt stmt of + Nothing -> return () + Just extra -> addErr (msg $$ extra) } where - msg = ptext (sLit "Illegal transform or grouping in") <+> pprStmtContext ctxt + msg = sep [ ptext (sLit "Unexpected") <+> pprStmtCat stmt <+> ptext (sLit "statement") + , ptext (sLit "in") <+> pprAStmtContext ctxt ] + +pprStmtCat :: Stmt a -> SDoc +pprStmtCat (TransStmt {}) = ptext (sLit "transform") +pprStmtCat (LastStmt {}) = ptext (sLit "return expression") +pprStmtCat (ExprStmt {}) = ptext (sLit "exprssion") +pprStmtCat (BindStmt {}) = ptext (sLit "binding") +pprStmtCat (LetStmt {}) = ptext (sLit "let") +pprStmtCat (RecStmt {}) = ptext (sLit "rec") +pprStmtCat (ParStmt {}) = ptext (sLit "parallel") + +------------ +isOK, notOK :: Maybe SDoc +isOK = Nothing +notOK = Just empty + +okStmt, okDoStmt, okCompStmt, okParStmt, okPArrStmt + :: DynFlags -> HsStmtContext Name + -> Stmt RdrName -> Maybe SDoc +-- Return Nothing if OK, (Just extra) if not ok +-- The "extra" is an SDoc that is appended to an generic error message + +okStmt dflags ctxt stmt + = case ctxt of + PatGuard {} -> okPatGuardStmt stmt + ParStmtCtxt ctxt -> okParStmt dflags ctxt stmt + DoExpr -> okDoStmt dflags ctxt stmt + MDoExpr -> okDoStmt dflags ctxt stmt + ArrowExpr -> okDoStmt dflags ctxt stmt + GhciStmt -> okDoStmt dflags ctxt stmt + ListComp -> okCompStmt dflags ctxt stmt + MonadComp -> okCompStmt dflags ctxt stmt + PArrComp -> okPArrStmt dflags ctxt stmt + TransStmtCtxt ctxt -> okStmt dflags ctxt stmt + +------------- +okPatGuardStmt :: Stmt RdrName -> Maybe SDoc +okPatGuardStmt stmt + = case stmt of + ExprStmt {} -> isOK + BindStmt {} -> isOK + LetStmt {} -> isOK + _ -> notOK + +------------- +okParStmt dflags ctxt stmt + = case stmt of + LetStmt (HsIPBinds {}) -> notOK + _ -> okStmt dflags ctxt stmt + +---------------- +okDoStmt dflags ctxt stmt + = case stmt of + RecStmt {} + | Opt_DoRec `xopt` dflags -> isOK + | ArrowExpr <- ctxt -> isOK -- Arrows allows 'rec' + | otherwise -> Just (ptext (sLit "Use -XDoRec")) + BindStmt {} -> isOK + LetStmt {} -> isOK + ExprStmt {} -> isOK + _ -> notOK + +---------------- +okCompStmt dflags _ stmt + = case stmt of + BindStmt {} -> isOK + LetStmt {} -> isOK + ExprStmt {} -> isOK + ParStmt {} + | Opt_ParallelListComp `xopt` dflags -> isOK + | otherwise -> Just (ptext (sLit "Use -XParallelListComp")) + TransStmt {} + | Opt_TransformListComp `xopt` dflags -> isOK + | otherwise -> Just (ptext (sLit "Use -XTransformListComp")) + RecStmt {} -> notOK + LastStmt {} -> notOK -- Should not happen (dealt with by checkLastStmt) + +---------------- +okPArrStmt dflags _ stmt + = case stmt of + BindStmt {} -> isOK + LetStmt {} -> isOK + ExprStmt {} -> isOK + ParStmt {} + | Opt_ParallelListComp `xopt` dflags -> isOK + | otherwise -> Just (ptext (sLit "Use -XParallelListComp")) + TransStmt {} -> notOK + RecStmt {} -> notOK + LastStmt {} -> notOK -- Should not happen (dealt with by checkLastStmt) --------- checkTupleSection :: [HsTupArg RdrName] -> RnM () diff -Nru ghc-7.0.3/compiler/rename/RnExpr.lhs-boot ghc-7.2.1/compiler/rename/RnExpr.lhs-boot --- ghc-7.0.3/compiler/rename/RnExpr.lhs-boot 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/rename/RnExpr.lhs-boot 2011-08-07 17:10:05.000000000 +0000 @@ -11,7 +11,7 @@ rnStmts :: --forall thing. HsStmtContext Name -> [LStmt RdrName] - -> RnM (thing, FreeVars) + -> ([Name] -> RnM (thing, FreeVars)) -> RnM (([LStmt Name], thing), FreeVars) \end{code} diff -Nru ghc-7.0.3/compiler/rename/RnHsDoc.hs ghc-7.2.1/compiler/rename/RnHsDoc.hs --- ghc-7.0.3/compiler/rename/RnHsDoc.hs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/rename/RnHsDoc.hs 2011-08-07 17:10:05.000000000 +0000 @@ -3,7 +3,7 @@ import TcRnTypes import HsSyn -import SrcLoc ( Located(..) ) +import SrcLoc rnMbLHsDoc :: Maybe LHsDocString -> RnM (Maybe LHsDocString) diff -Nru ghc-7.0.3/compiler/rename/RnHsSyn.lhs ghc-7.2.1/compiler/rename/RnHsSyn.lhs --- ghc-7.0.3/compiler/rename/RnHsSyn.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/rename/RnHsSyn.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -11,9 +11,7 @@ extractFunDepNames, extractHsCtxtTyNames, extractHsPredTyNames, -- Free variables - hsSigsFVs, hsSigFVs, conDeclFVs, bangTyFVs, - - maybeGenericMatch + hsSigsFVs, hsSigFVs, conDeclFVs, bangTyFVs ) where #include "HsVersions.h" @@ -24,7 +22,7 @@ import Name ( Name, getName, isTyVarName ) import NameSet import BasicTypes ( Boxity ) -import SrcLoc ( Located(..), unLoc ) +import SrcLoc \end{code} %************************************************************************ @@ -66,7 +64,6 @@ get (HsParTy ty) = getl ty get (HsBangTy _ ty) = getl ty get (HsRecTy flds) = extractHsTyNames_s (map cd_fld_type flds) - get (HsNumTy _) = emptyNameSet get (HsTyVar tv) = unitNameSet tv get (HsSpliceTy _ fvs _) = fvs get (HsQuasiQuoteTy {}) = emptyNameSet @@ -120,10 +117,11 @@ hsSigsFVs sigs = plusFVs (map (hsSigFVs.unLoc) sigs) hsSigFVs :: Sig Name -> FreeVars -hsSigFVs (TypeSig _ ty) = extractHsTyNames ty -hsSigFVs (SpecInstSig ty) = extractHsTyNames ty -hsSigFVs (SpecSig _ ty _) = extractHsTyNames ty -hsSigFVs _ = emptyFVs +hsSigFVs (TypeSig _ ty) = extractHsTyNames ty +hsSigFVs (GenericSig _ ty) = extractHsTyNames ty +hsSigFVs (SpecInstSig ty) = extractHsTyNames ty +hsSigFVs (SpecSig _ ty _) = extractHsTyNames ty +hsSigFVs _ = emptyFVs ---------------- conDeclFVs :: LConDecl Name -> FreeVars @@ -144,24 +142,3 @@ bangTyFVs :: LHsType Name -> FreeVars bangTyFVs bty = extractHsTyNames (getBangType bty) \end{code} - - -%************************************************************************ -%* * -\subsection{A few functions on generic defintions -%* * -%************************************************************************ - -These functions on generics are defined over Matches Name, which is -why they are here and not in HsMatches. - -\begin{code} -maybeGenericMatch :: LMatch Name -> Maybe (HsType Name, LMatch Name) - -- Tells whether a Match is for a generic definition - -- and extract the type from a generic match and put it at the front - -maybeGenericMatch (L loc (Match (L _ (TypePat (L _ ty)) : pats) sig_ty grhss)) - = Just (ty, L loc (Match pats sig_ty grhss)) - -maybeGenericMatch _ = Nothing -\end{code} diff -Nru ghc-7.0.3/compiler/rename/RnNames.lhs ghc-7.2.1/compiler/rename/RnNames.lhs --- ghc-7.0.3/compiler/rename/RnNames.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/rename/RnNames.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -5,21 +5,20 @@ \begin{code} module RnNames ( - rnImports, getLocalNonValBinders, - rnExports, extendGlobalRdrEnvRn, + rnImports, getLocalNonValBinders, + rnExports, extendGlobalRdrEnvRn, gresFromAvails, - reportUnusedNames, finishWarnings, + reportUnusedNames, finishWarnings, ) where #include "HsVersions.h" import DynFlags import HsSyn -import TcEnv ( isBrackStage ) +import TcEnv ( isBrackStage ) import RnEnv import RnHsDoc ( rnHsDoc ) -import IfaceEnv ( ifaceExportNames ) -import LoadIface ( loadSrcInterface ) +import LoadIface ( loadSrcInterface ) import TcRnMonad import HeaderInfo ( mkPrelImports ) @@ -37,25 +36,103 @@ import Util import FastString import ListSetOps -import Data.List ( partition, (\\), delete, find ) +import Data.List ( partition, (\\), find ) import qualified Data.Set as Set import System.IO import Control.Monad -import Data.Map (Map) +import Data.Map ( Map ) import qualified Data.Map as Map \end{code} %************************************************************************ -%* * - rnImports -%* * +%* * +\subsection{rnImports} +%* * %************************************************************************ +Note [Tracking Trust Transitively] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we import a package as well as checking that the direct imports are safe +according to the rules outlined in the Note [HscMain . Safe Haskell Trust Check] +we must also check that these rules hold transitively for all dependent modules +and packages. Doing this without caching any trust information would be very +slow as we would need to touch all packages and interface files a module depends +on. To avoid this we make use of the property that if a modules Safe Haskell +mode changes, this triggers a recompilation from that module in the dependcy +graph. So we can just worry mostly about direct imports. There is one trust +property that can change for a package though without recompliation being +triggered, package trust. So we must check that all packages a module +tranitively depends on to be trusted are still trusted when we are compiling +this module (as due to recompilation avoidance some modules below may not be +considered trusted any more without recompilation being triggered). + +We handle this by augmenting the existing transitive list of packages a module M +depends on with a bool for each package that says if it must be trusted when the +module M is being checked for trust. This list of trust required packages for a +single import is gathered in the rnImportDecl function and stored in an +ImportAvails data structure. The union of these trust required packages for all +imports is done by the rnImports function using the combine function which calls +the plusImportAvails function that is a union operation for the ImportAvails +type. This gives us in an ImportAvails structure all packages required to be +trusted for the module we are currently compiling. Checking that these packages +are still trusted (and that direct imports are trusted) is done in +HscMain.checkSafeImports. + +See the note below, [Trust Own Package] for a corner case in this method and +how its handled. + + +Note [Trust Own Package] +~~~~~~~~~~~~~~~~~~~~~~~~ +There is a corner case of package trust checking that the usual transitive check +doesn't cover. (For how the usual check operates see the Note [Tracking Trust +Transitively] below). The case is when you import a -XSafe module M and M +imports a -XTrustworthy module N. If N resides in a different package than M, +then the usual check works as M will record a package dependency on N's package +and mark it as required to be trusted. If N resides in the same package as M +though, then importing M should require its own package be trusted due to N +(since M is -XSafe so doesn't create this requirement by itself). The usual +check fails as a module doesn't record a package dependency of its own package. +So instead we now have a bool field in a modules interface file that simply +states if the module requires its own package to be trusted. This field avoids +us having to load all interface files that the module depends on to see if one +is trustworthy. + + +Note [Trust Transitive Property] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +So there is an interesting design question in regards to transitive trust +checking. Say I have a module B compiled with -XSafe. B is dependent on a bunch +of modules and packages, some packages it requires to be trusted as its using +-XTrustworthy modules from them. Now if I have a module A that doesn't use safe +haskell at all and simply imports B, should A inherit all the the trust +requirements from B? Should A now also require that a package p is trusted since +B required it? + +We currently say no but I saying yes also makes sense. The difference is, if a +module M that doesn't use Safe Haskell imports a module N that does, should all +the trusted package requirements be dropped since M didn't declare that it cares +about Safe Haskell (so -XSafe is more strongly associated with the module doing +the importing) or should it be done still since the author of the module N that +uses Safe Haskell said they cared (so -XSafe is more strongly associated with +the module that was compiled that used it). + +Going with yes is a simpler semantics we think and harder for the user to stuff +up but it does mean that Safe Haskell will affect users who don't care about +Safe Haskell as they might grab a package from Cabal which uses safe haskell (say +network) and that packages imports -XTrustworthy modules from another package +(say bytestring), so requires that package is trusted. The user may now get +compilation errors in code that doesn't do anything with Safe Haskell simply +because they are using the network package. They will have to call 'ghc-pkg +trust network' to get everything working. Due to this invasive nature of going +with yes we have gone with no for now. + + \begin{code} rnImports :: [LImportDecl RdrName] - -> RnM ([LImportDecl Name], GlobalRdrEnv, ImportAvails,AnyHpcUsage) + -> RnM ([LImportDecl Name], GlobalRdrEnv, ImportAvails, AnyHpcUsage) rnImports imports -- PROCESS IMPORT DECLS @@ -63,38 +140,42 @@ -- warning for {- SOURCE -} ones that are unnecessary = do this_mod <- getModule implicit_prelude <- xoptM Opt_ImplicitPrelude - let prel_imports = mkPrelImports (moduleName this_mod) implicit_prelude imports + let prel_imports = mkPrelImports (moduleName this_mod) + implicit_prelude imports (source, ordinary) = partition is_source_import imports - is_source_import (L _ (ImportDecl _ _ is_boot _ _ _)) = is_boot + is_source_import (L _ (ImportDecl _ _ is_boot _ _ _ _)) = is_boot - ifDOptM Opt_WarnImplicitPrelude ( - when (notNull prel_imports) $ addWarn (implicitPreludeWarn) - ) + ifWOptM Opt_WarnImplicitPrelude $ + when (notNull prel_imports) $ addWarn (implicitPreludeWarn) stuff1 <- mapM (rnImportDecl this_mod True) prel_imports stuff2 <- mapM (rnImportDecl this_mod False) ordinary stuff3 <- mapM (rnImportDecl this_mod False) source - let (decls, rdr_env, imp_avails, hpc_usage) = combine (stuff1 ++ stuff2 ++ stuff3) + -- Safe Haskell: See Note [Tracking Trust Transitively] + let (decls, rdr_env, imp_avails, hpc_usage) = + combine (stuff1 ++ stuff2 ++ stuff3) return (decls, rdr_env, imp_avails, hpc_usage) where - combine :: [(LImportDecl Name, GlobalRdrEnv, ImportAvails,AnyHpcUsage)] - -> ([LImportDecl Name], GlobalRdrEnv, ImportAvails,AnyHpcUsage) - combine = foldr plus ([], emptyGlobalRdrEnv, emptyImportAvails,False) - where plus (decl, gbl_env1, imp_avails1,hpc_usage1) - (decls, gbl_env2, imp_avails2,hpc_usage2) - = (decl:decls, - gbl_env1 `plusGlobalRdrEnv` gbl_env2, - imp_avails1 `plusImportAvails` imp_avails2, - hpc_usage1 || hpc_usage2) + combine :: [(LImportDecl Name, GlobalRdrEnv, ImportAvails, AnyHpcUsage)] + -> ([LImportDecl Name], GlobalRdrEnv, ImportAvails, AnyHpcUsage) + combine = foldr plus ([], emptyGlobalRdrEnv, emptyImportAvails, False) + where + plus (decl, gbl_env1, imp_avails1,hpc_usage1) + (decls, gbl_env2, imp_avails2,hpc_usage2) + = ( decl:decls, + gbl_env1 `plusGlobalRdrEnv` gbl_env2, + imp_avails1 `plusImportAvails` imp_avails2, + hpc_usage1 || hpc_usage2 ) rnImportDecl :: Module -> Bool - -> LImportDecl RdrName - -> RnM (LImportDecl Name, GlobalRdrEnv, ImportAvails,AnyHpcUsage) + -> LImportDecl RdrName + -> RnM (LImportDecl Name, GlobalRdrEnv, ImportAvails, AnyHpcUsage) -rnImportDecl this_mod implicit_prelude +rnImportDecl this_mod implicit_prelude (L loc (ImportDecl { ideclName = loc_imp_mod_name, ideclPkgQual = mb_pkg - , ideclSource = want_boot, ideclQualified = qual_only + , ideclSource = want_boot, ideclSafe = mod_safe + , ideclQualified = qual_only , ideclAs = as_mod, ideclHiding = imp_details })) = setSrcSpan loc $ do @@ -102,30 +183,31 @@ pkg_imports <- xoptM Opt_PackageImports when (not pkg_imports) $ addErr packageImportErr - -- If there's an error in loadInterface, (e.g. interface - -- file not found) we get lots of spurious errors from 'filterImports' + -- If there's an error in loadInterface, (e.g. interface + -- file not found) we get lots of spurious errors from 'filterImports' let - imp_mod_name = unLoc loc_imp_mod_name - doc = ppr imp_mod_name <+> ptext (sLit "is directly imported") + imp_mod_name = unLoc loc_imp_mod_name + doc = ppr imp_mod_name <+> ptext (sLit "is directly imported") - -- Check for a missing import list - -- (Opt_WarnMissingImportList also checks for T(..) items - -- but that is done in checkDodgyImport below) + -- Check for a missing import list + -- (Opt_WarnMissingImportList also checks for T(..) items + -- but that is done in checkDodgyImport below) case imp_details of - Just (False, _) -> return () + Just (False, _) -> return () -- Explicit import list _ | implicit_prelude -> return () - | otherwise -> ifDOptM Opt_WarnMissingImportList $ + | qual_only -> return () + | otherwise -> ifWOptM Opt_WarnMissingImportList $ addWarn (missingImportListWarn imp_mod_name) iface <- loadSrcInterface doc imp_mod_name want_boot mb_pkg - -- Compiler sanity check: if the import didn't say - -- {-# SOURCE #-} we should not get a hi-boot file + -- Compiler sanity check: if the import didn't say + -- {-# SOURCE #-} we should not get a hi-boot file WARN( not want_boot && mi_boot iface, ppr imp_mod_name ) (do - -- Issue a user warning for a redundant {- SOURCE -} import - -- NB that we arrange to read all the ordinary imports before - -- any of the {- SOURCE -} imports. + -- Issue a user warning for a redundant {- SOURCE -} import + -- NB that we arrange to read all the ordinary imports before + -- any of the {- SOURCE -} imports. -- -- in --make and GHCi, the compilation manager checks for this, -- and indeed we shouldn't do it here because the existence of @@ -133,107 +215,124 @@ -- is not deterministic. The hs-boot test can show this up. dflags <- getDOpts warnIf (want_boot && not (mi_boot iface) && isOneShot (ghcMode dflags)) - (warnRedundantSourceImport imp_mod_name) + (warnRedundantSourceImport imp_mod_name) let - imp_mod = mi_module iface - warns = mi_warns iface - orph_iface = mi_orphan iface - has_finsts = mi_finsts iface - deps = mi_deps iface - - filtered_exports = filter not_this_mod (mi_exports iface) - not_this_mod (mod,_) = mod /= this_mod - -- If the module exports anything defined in this module, just - -- ignore it. Reason: otherwise it looks as if there are two - -- local definition sites for the thing, and an error gets - -- reported. Easiest thing is just to filter them out up - -- front. This situation only arises if a module imports - -- itself, or another module that imported it. (Necessarily, - -- this invoves a loop.) - -- - -- Tiresome consequence: if you say - -- module A where - -- import B( AType ) - -- type AType = ... - -- - -- module B( AType ) where - -- import {-# SOURCE #-} A( AType ) - -- - -- then you'll get a 'B does not export AType' message. Oh well. - - qual_mod_name = case as_mod of - Nothing -> imp_mod_name - Just another_name -> another_name - imp_spec = ImpDeclSpec { is_mod = imp_mod_name, is_qual = qual_only, - is_dloc = loc, is_as = qual_mod_name } - -- in - - -- Get the total exports from this module - total_avails <- ifaceExportNames filtered_exports - - -- filter the imports according to the import declaration - (new_imp_details, gbl_env) <- - filterImports iface imp_spec imp_details total_avails + imp_mod = mi_module iface + warns = mi_warns iface + orph_iface = mi_orphan iface + has_finsts = mi_finsts iface + deps = mi_deps iface + trust = getSafeMode $ mi_trust iface + trust_pkg = mi_trust_pkg iface + + qual_mod_name = case as_mod of + Nothing -> imp_mod_name + Just another_name -> another_name + imp_spec = ImpDeclSpec { is_mod = imp_mod_name, is_qual = qual_only, + is_dloc = loc, is_as = qual_mod_name } + + -- filter the imports according to the import declaration + (new_imp_details, gres) <- filterImports iface imp_spec imp_details + + let gbl_env = mkGlobalRdrEnv (filterOut from_this_mod gres) + from_this_mod gre = nameModule (gre_name gre) == this_mod + -- If the module exports anything defined in this module, just + -- ignore it. Reason: otherwise it looks as if there are two + -- local definition sites for the thing, and an error gets + -- reported. Easiest thing is just to filter them out up + -- front. This situation only arises if a module imports + -- itself, or another module that imported it. (Necessarily, + -- this invoves a loop.) + -- + -- We do this *after* filterImports, so that if you say + -- module A where + -- import B( AType ) + -- type AType = ... + -- + -- module B( AType ) where + -- import {-# SOURCE #-} A( AType ) + -- + -- then you won't get a 'B does not export AType' message. - dflags <- getDOpts - let - -- Compute new transitive dependencies + -- Compute new transitive dependencies - orphans | orph_iface = ASSERT( not (imp_mod `elem` dep_orphs deps) ) - imp_mod : dep_orphs deps - | otherwise = dep_orphs deps - - finsts | has_finsts = ASSERT( not (imp_mod `elem` dep_finsts deps) ) - imp_mod : dep_finsts deps - | otherwise = dep_finsts deps - - pkg = modulePackageId (mi_module iface) - - (dependent_mods, dependent_pkgs) - | pkg == thisPackage dflags = - -- Imported module is from the home package - -- Take its dependent modules and add imp_mod itself - -- Take its dependent packages unchanged - -- - -- NB: (dep_mods deps) might include a hi-boot file - -- for the module being compiled, CM. Do *not* filter - -- this out (as we used to), because when we've - -- finished dealing with the direct imports we want to - -- know if any of them depended on CM.hi-boot, in - -- which case we should do the hi-boot consistency - -- check. See LoadIface.loadHiBootInterface - ((imp_mod_name, want_boot) : dep_mods deps, dep_pkgs deps) - - | otherwise = - -- Imported module is from another package - -- Dump the dependent modules - -- Add the package imp_mod comes from to the dependent packages - ASSERT2( not (pkg `elem` dep_pkgs deps), ppr pkg <+> ppr (dep_pkgs deps) ) - ([], pkg : dep_pkgs deps) - - -- True <=> import M () - import_all = case imp_details of - Just (is_hiding, ls) -> not is_hiding && null ls - _ -> False - - imports = ImportAvails { - imp_mods = unitModuleEnv imp_mod [(qual_mod_name, import_all, loc)], - imp_orphs = orphans, - imp_finsts = finsts, - imp_dep_mods = mkModDeps dependent_mods, - imp_dep_pkgs = dependent_pkgs + orphans | orph_iface = ASSERT( not (imp_mod `elem` dep_orphs deps) ) + imp_mod : dep_orphs deps + | otherwise = dep_orphs deps + + finsts | has_finsts = ASSERT( not (imp_mod `elem` dep_finsts deps) ) + imp_mod : dep_finsts deps + | otherwise = dep_finsts deps + + pkg = modulePackageId (mi_module iface) + + -- Does this import mean we now require our own pkg + -- to be trusted? See Note [Trust Own Package] + ptrust = trust == Sf_Trustworthy || trust_pkg + + (dependent_mods, dependent_pkgs, pkg_trust_req) + | pkg == thisPackage dflags = + -- Imported module is from the home package + -- Take its dependent modules and add imp_mod itself + -- Take its dependent packages unchanged + -- + -- NB: (dep_mods deps) might include a hi-boot file + -- for the module being compiled, CM. Do *not* filter + -- this out (as we used to), because when we've + -- finished dealing with the direct imports we want to + -- know if any of them depended on CM.hi-boot, in + -- which case we should do the hi-boot consistency + -- check. See LoadIface.loadHiBootInterface + ((imp_mod_name, want_boot) : dep_mods deps, dep_pkgs deps, ptrust) + + | otherwise = + -- Imported module is from another package + -- Dump the dependent modules + -- Add the package imp_mod comes from to the dependent packages + ASSERT2( not (pkg `elem` (map fst $ dep_pkgs deps)) + , ppr pkg <+> ppr (dep_pkgs deps) ) + ([], (pkg, False) : dep_pkgs deps, False) + + -- True <=> import M () + import_all = case imp_details of + Just (is_hiding, ls) -> not is_hiding && null ls + _ -> False + + -- should the import be safe? + mod_safe' = mod_safe + || (not implicit_prelude && safeDirectImpsReq dflags) + || (implicit_prelude && safeImplicitImpsReq dflags) + + imports = ImportAvails { + imp_mods = unitModuleEnv imp_mod + [(qual_mod_name, import_all, loc, mod_safe')], + imp_orphs = orphans, + imp_finsts = finsts, + imp_dep_mods = mkModDeps dependent_mods, + imp_dep_pkgs = map fst $ dependent_pkgs, + -- Add in the imported modules trusted package + -- requirements. ONLY do this though if we import the + -- module as a safe import. + -- See Note [Tracking Trust Transitively] + -- and Note [Trust Transitive Property] + imp_trust_pkgs = if mod_safe' + then map fst $ filter snd dependent_pkgs + else [], + -- Do we require our own pkg to be trusted? + -- See Note [Trust Own Package] + imp_trust_own_pkg = pkg_trust_req } - -- Complain if we import a deprecated module - ifDOptM Opt_WarnWarningsDeprecations ( - case warns of - WarnAll txt -> addWarn (moduleWarn imp_mod_name txt) - _ -> return () + -- Complain if we import a deprecated module + ifWOptM Opt_WarnWarningsDeprecations ( + case warns of + WarnAll txt -> addWarn (moduleWarn imp_mod_name txt) + _ -> return () ) - let new_imp_decl = L loc (ImportDecl loc_imp_mod_name mb_pkg want_boot + let new_imp_decl = L loc (ImportDecl loc_imp_mod_name mb_pkg want_boot mod_safe' qual_only as_mod new_imp_details) return (new_imp_decl, gbl_env, imports, mi_hpc iface) @@ -247,21 +346,21 @@ %************************************************************************ -%* * - importsFromLocalDecls -%* * +%* * +\subsection{importsFromLocalDecls} +%* * %************************************************************************ From the top-level declarations of this module produce - * the lexical environment - * the ImportAvails -created by its bindings. - + * the lexical environment + * the ImportAvails +created by its bindings. + Note [Top-level Names in Template Haskell decl quotes] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider a Template Haskell declaration quotation like this: module M where - f x = h [d| f = 3 |] + f x = h [d| f = 3 |] When renaming the declarations inside [d| ...|], we treat the top level binders specially in two ways @@ -269,7 +368,7 @@ Otherwise the NameCache gets confused by a second allocation of M.f. (We used to invent a fake module ThFake to avoid this, but that had other problems, notably in getting the correct answer for - nameIsLocalOrFrom in lookupFixity. So we now leave tcg_module + nameIsLocalOrFrom in lookupFixity. So we now leave tcg_module unaffected.) 2. We make them *shadow* the outer bindings. If we don't do that, @@ -280,10 +379,10 @@ where-clause, and hence is in the *local* RdrEnv not the *global* RdrEnv. - * The *qualified* name M.f from the enclosing module must certainly - still be available. So we don't nuke it entirely; we just make + * The *qualified* name M.f from the enclosing module must certainly + still be available. So we don't nuke it entirely; we just make it seem like qualified import. - + * We only shadow *External* names (which come from the main module) Do not shadow *Inernal* names because in the bracket [d| class C a where f :: a @@ -298,56 +397,56 @@ \begin{code} extendGlobalRdrEnvRn :: [AvailInfo] - -> MiniFixityEnv - -> RnM (TcGblEnv, TcLclEnv) - -- Updates both the GlobalRdrEnv and the FixityEnv - -- We return a new TcLclEnv only because we might have to - -- delete some bindings from it; - -- see Note [Top-level Names in Template Haskell decl quotes] + -> MiniFixityEnv + -> RnM (TcGblEnv, TcLclEnv) +-- Updates both the GlobalRdrEnv and the FixityEnv +-- We return a new TcLclEnv only because we might have to +-- delete some bindings from it; +-- see Note [Top-level Names in Template Haskell decl quotes] extendGlobalRdrEnvRn avails new_fixities - = do { (gbl_env, lcl_env) <- getEnvs + = do { (gbl_env, lcl_env) <- getEnvs ; stage <- getStage - ; let rdr_env = tcg_rdr_env gbl_env - fix_env = tcg_fix_env gbl_env + ; let rdr_env = tcg_rdr_env gbl_env + fix_env = tcg_fix_env gbl_env + + -- Delete new_occs from global and local envs + -- If we are in a TemplateHaskell decl bracket, + -- we are going to shadow them + -- See Note [Top-level Names in Template Haskell decl quotes] + shadowP = isBrackStage stage + new_occs = map (nameOccName . gre_name) gres + rdr_env1 = transformGREs qual_gre new_occs rdr_env + lcl_env1 = lcl_env { tcl_rdr = delListFromOccEnv (tcl_rdr lcl_env) new_occs } + (rdr_env2, lcl_env2) | shadowP = (rdr_env1, lcl_env1) + | otherwise = (rdr_env, lcl_env) + + rdr_env3 = foldl extendGlobalRdrEnv rdr_env2 gres + fix_env' = foldl extend_fix_env fix_env gres + (rdr_env', dups) = findLocalDupsRdrEnv rdr_env3 new_occs - -- Delete new_occs from global and local envs - -- If we are in a TemplateHaskell decl bracket, - -- we are going to shadow them - -- See Note [Top-level Names in Template Haskell decl quotes] - shadowP = isBrackStage stage - new_occs = map (nameOccName . gre_name) gres - rdr_env1 = transformGREs qual_gre new_occs rdr_env - lcl_env1 = lcl_env { tcl_rdr = delListFromOccEnv (tcl_rdr lcl_env) new_occs } - (rdr_env2, lcl_env2) | shadowP = (rdr_env1, lcl_env1) - | otherwise = (rdr_env, lcl_env) - - rdr_env3 = foldl extendGlobalRdrEnv rdr_env2 gres - fix_env' = foldl extend_fix_env fix_env gres - (rdr_env', dups) = findLocalDupsRdrEnv rdr_env3 new_occs - - gbl_env' = gbl_env { tcg_rdr_env = rdr_env', tcg_fix_env = fix_env' } - - ; mapM_ addDupDeclErr dups - - ; traceRn (text "extendGlobalRdrEnvRn" <+> (ppr new_fixities $$ ppr fix_env $$ ppr fix_env')) - ; return (gbl_env', lcl_env2) } + gbl_env' = gbl_env { tcg_rdr_env = rdr_env', tcg_fix_env = fix_env' } + + ; mapM_ addDupDeclErr dups + + ; traceRn (text "extendGlobalRdrEnvRn" <+> (ppr new_fixities $$ ppr fix_env $$ ppr fix_env')) + ; return (gbl_env', lcl_env2) } where gres = gresFromAvails LocalDef avails - -- If there is a fixity decl for the gre, add it to the fixity env - extend_fix_env fix_env gre + -- If there is a fixity decl for the gre, add it to the fixity env + extend_fix_env fix_env gre | Just (L _ fi) <- lookupFsEnv new_fixities (occNameFS occ) = extendNameEnv fix_env name (FixItem occ fi) | otherwise = fix_env where - name = gre_name gre + name = gre_name gre occ = nameOccName name qual_gre :: GlobalRdrElt -> GlobalRdrElt -- Transform top-level GREs from the module being compiled - -- so that they are out of the way of new definitions in a Template + -- so that they are out of the way of new definitions in a Template -- Haskell bracket -- See Note [Top-level Names in Template Haskell decl quotes] -- Seems like 5 times as much work as it deserves! @@ -358,27 +457,27 @@ qual_gre gre@(GRE { gre_prov = LocalDef, gre_name = name }) | isExternalName name = gre { gre_prov = Imported [imp_spec] } - | otherwise = gre - -- Do not shadow Internal (ie Template Haskell) Names - -- See Note [Top-level Names in Template Haskell decl quotes] - where - mod = ASSERT2( isExternalName name, ppr name) moduleName (nameModule name) - imp_spec = ImpSpec { is_item = ImpAll, is_decl = decl_spec } - decl_spec = ImpDeclSpec { is_mod = mod, is_as = mod, - is_qual = True, -- Qualified only! - is_dloc = srcLocSpan (nameSrcLoc name) } + | otherwise = gre + -- Do not shadow Internal (ie Template Haskell) Names + -- See Note [Top-level Names in Template Haskell decl quotes] + where + mod = ASSERT2( isExternalName name, ppr name) moduleName (nameModule name) + imp_spec = ImpSpec { is_item = ImpAll, is_decl = decl_spec } + decl_spec = ImpDeclSpec { is_mod = mod, is_as = mod, + is_qual = True, -- Qualified only! + is_dloc = srcLocSpan (nameSrcLoc name) } qual_gre gre@(GRE { gre_prov = Imported specs }) - = gre { gre_prov = Imported (map qual_spec specs) } + = gre { gre_prov = Imported (map qual_spec specs) } qual_spec spec@(ImpSpec { is_decl = decl_spec }) - = spec { is_decl = decl_spec { is_qual = True } } + = spec { is_decl = decl_spec { is_qual = True } } \end{code} @getLocalDeclBinders@ returns the names for an @HsDecl@. It's used for source code. - *** See "THE NAMING STORY" in HsDecls **** + *** See "THE NAMING STORY" in HsDecls **** Instances of type families ~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -400,10 +499,10 @@ instance to look up 'M.T'. Alas, we can't! The type family declaration is in the *same* HsGroup as the type instance declaration. Hence, as we are currently collecting the binders declared in that HsGroup, these binders will -not have been added to the global environment yet. +not have been added to the global environment yet. In the case of type classes, this problem does not arise, as a class instance -does not define any binders of it's own. So, we simply don't attempt to look +does not define any binders of its own. So, we simply don't attempt to look up the class names of class instances in 'get_local_binders' below. If we don't look up class instances, can't we get away without looking up type @@ -419,50 +518,58 @@ We solve this problem as follows: - (a) We process all type declarations other than type instances first. - (b) Then, we compute a 'GlobalRdrEnv' from the result of the first step. - (c) Finally, we process all type instances (both those on the toplevel and + (a) We process all type declarations *other* than type instances first. + (b) Then, we compute an 'OccEnv' from the result of the first step. + (c) Finally, we process all type instances (both those on the toplevel and those nested in class instances) and check for the family names in the 'GlobalRdrEnv' produced in the previous step before using 'lookupOccRn'. \begin{code} getLocalNonValBinders :: HsGroup RdrName -> RnM [AvailInfo] --- Get all the top-level binders bound the group *except* +-- Get all the top-level binders bound the group *except* -- for value bindings, which are treated separately -- Specificaly we return AvailInfo for --- type decls (incl constructors and record selectors) --- class decls (including class ops) --- associated types --- foreign imports --- (in hs-boot files) value signatures +-- type decls (incl constructors and record selectors) +-- class decls (including class ops) +-- associated types +-- foreign imports +-- (in hs-boot files) value signatures getLocalNonValBinders group - = do { gbl_env <- getGblEnv - ; get_local_binders gbl_env group } + = do { gbl_env <- getGblEnv + ; get_local_binders gbl_env group } -get_local_binders :: TcGblEnv -> HsGroup RdrName -> RnM [GenAvailInfo Name] +get_local_binders :: TcGblEnv -> HsGroup RdrName -> RnM [AvailInfo] get_local_binders gbl_env (HsGroup {hs_valds = ValBindsIn _ val_sigs, - hs_tyclds = tycl_decls, - hs_instds = inst_decls, - hs_fords = foreign_decls }) - = do { -- separate out the family instance declarations - let (tyinst_decls1, tycl_decls_noinsts) + hs_tyclds = tycl_decls, + hs_instds = inst_decls, + hs_fords = foreign_decls }) + = do { -- separate out the family instance declarations + let (tyinst_decls1, tycl_decls_noinsts) = partition (isFamInstDecl . unLoc) (concat tycl_decls) tyinst_decls = tyinst_decls1 ++ instDeclATs inst_decls - -- process all type/class decls except family instances - ; tc_names <- mapM new_tc tycl_decls_noinsts + -- process all type/class decls except family instances + ; tc_avails <- mapM new_tc tycl_decls_noinsts - -- create a temporary rdr env of the type binders - ; let tc_gres = gresFromAvails LocalDef tc_names - tc_name_env = foldl extendGlobalRdrEnv emptyGlobalRdrEnv tc_gres - - -- process all family instances - ; ti_names <- mapM (new_ti tc_name_env) tyinst_decls - - -- finish off with value binder in case of a hs-boot file - ; val_names <- mapM new_simple val_bndrs - ; return (val_names ++ tc_names ++ ti_names) } + -- Create a temporary env of the type binders + -- See Note [Looking up family names in family instances] + -- NB: associated types may be a sub-bndr of a class + -- AvailTC C [C,T,op] + -- Hence availNames, not availName + ; let local_tc_env :: OccEnv Name + local_tc_env = mkOccEnv [ (occ, n) + | a <- tc_avails + , n <- availNames a + , let occ = nameOccName n + , isTcOcc occ ] + + -- Process all family instances + ; ti_avails <- mapM (new_ti local_tc_env) tyinst_decls + + -- finish off with value binder in case of a hs-boot file + ; val_avails <- mapM new_simple val_bndrs + ; return (val_avails ++ tc_avails ++ ti_avails) } where is_hs_boot = isHsBoot (tcg_src gbl_env) ; @@ -470,39 +577,39 @@ for_hs_bndrs = [nm | L _ (ForeignImport nm _ _) <- foreign_decls] -- In a hs-boot file, the value binders come from the - -- *signatures*, and there should be no foreign binders + -- *signatures*, and there should be no foreign binders val_bndrs :: [Located RdrName] - val_bndrs | is_hs_boot = [nm | L _ (TypeSig nm _) <- val_sigs] + val_bndrs | is_hs_boot = [n | L _ (TypeSig ns _) <- val_sigs, n <- ns] | otherwise = for_hs_bndrs - new_simple :: Located RdrName -> RnM (GenAvailInfo Name) - new_simple rdr_name = do - nm <- newTopSrcBinder rdr_name - return (Avail nm) + new_simple :: Located RdrName -> RnM AvailInfo + new_simple rdr_name = do{ nm <- newTopSrcBinder rdr_name + ; return (Avail nm) } new_tc tc_decl -- NOT for type/data instances - = do { main_name <- newTopSrcBinder main_rdr - ; sub_names <- mapM newTopSrcBinder sub_rdrs - ; return (AvailTC main_name (main_name : sub_names)) } - where - (main_rdr : sub_rdrs) = hsTyClDeclBinders tc_decl + = do { names@(main_name : _) <- mapM newTopSrcBinder (hsTyClDeclBinders tc_decl) + ; return (AvailTC main_name names) } - new_ti tc_name_env ti_decl -- ONLY for type/data instances - = do { main_name <- lookupFamInstDeclBndr tc_name_env main_rdr - ; sub_names <- mapM newTopSrcBinder sub_rdrs - ; return (AvailTC main_name sub_names) } - -- main_name is not bound here! - where - (main_rdr : sub_rdrs) = hsTyClDeclBinders ti_decl + new_ti local_tc_env ti_decl -- ONLY for type/data instances + = do { let L loc tc_rdr = tcdLName (unLoc ti_decl) + ; main_name <- setSrcSpan loc $ + case lookupOccEnv local_tc_env (rdrNameOcc tc_rdr) of + Nothing -> lookupGlobalOccRn tc_rdr + Just n -> return n + -- See Note [Looking up family names in family instances] + + ; sub_names <- mapM newTopSrcBinder (hsTyClDeclBinders ti_decl) + ; return (AvailTC main_name sub_names) } + -- main_name is not bound here! get_local_binders _ g = pprPanic "get_local_binders" (ppr g) \end{code} %************************************************************************ -%* * +%* * \subsection{Filtering imports} -%* * +%* * %************************************************************************ @filterImports@ takes the @ExportEnv@ telling what the imported module makes @@ -510,38 +617,39 @@ \begin{code} filterImports :: ModIface - -> ImpDeclSpec -- The span for the entire import decl - -> Maybe (Bool, [LIE RdrName]) -- Import spec; True => hiding - -> [AvailInfo] -- What's available - -> RnM (Maybe (Bool, [LIE Name]), -- Import spec w/ Names - GlobalRdrEnv) -- Same again, but in GRE form -filterImports _ decl_spec Nothing all_avails - = return (Nothing, mkGlobalRdrEnv (gresFromAvails prov all_avails)) + -> ImpDeclSpec -- The span for the entire import decl + -> Maybe (Bool, [LIE RdrName]) -- Import spec; True => hiding + -> RnM (Maybe (Bool, [LIE Name]), -- Import spec w/ Names + [GlobalRdrElt]) -- Same again, but in GRE form +filterImports iface decl_spec Nothing + = return (Nothing, gresFromAvails prov (mi_exports iface)) where prov = Imported [ImpSpec { is_decl = decl_spec, is_item = ImpAll }] -filterImports iface decl_spec (Just (want_hiding, import_items)) all_avails - = do -- check for errors, convert RdrNames to Names +filterImports iface decl_spec (Just (want_hiding, import_items)) + = do -- check for errors, convert RdrNames to Names opt_typeFamilies <- xoptM Opt_TypeFamilies items1 <- mapM (lookup_lie opt_typeFamilies) import_items let items2 :: [(LIE Name, AvailInfo)] items2 = concat items1 - -- NB the AvailInfo may have duplicates, and several items - -- for the same parent; e.g N(x) and N(y) + -- NB the AvailInfo may have duplicates, and several items + -- for the same parent; e.g N(x) and N(y) names = availsToNameSet (map snd items2) - keep n = not (n `elemNameSet` names) - pruned_avails = filterAvails keep all_avails - hiding_prov = Imported [ImpSpec { is_decl = decl_spec, is_item = ImpAll }] + keep n = not (n `elemNameSet` names) + pruned_avails = filterAvails keep all_avails + hiding_prov = Imported [ImpSpec { is_decl = decl_spec, is_item = ImpAll }] - gres | want_hiding = gresFromAvails hiding_prov pruned_avails - | otherwise = concatMap (gresFromIE decl_spec) items2 + gres | want_hiding = gresFromAvails hiding_prov pruned_avails + | otherwise = concatMap (gresFromIE decl_spec) items2 - return (Just (want_hiding, map fst items2), mkGlobalRdrEnv gres) + return (Just (want_hiding, map fst items2), gres) where - -- This environment is how we map names mentioned in the import + all_avails = mi_exports iface + + -- This environment is how we map names mentioned in the import -- list to the actual Name they correspond to, and the name family -- that the Name belongs to (the AvailInfo). The situation is -- complicated by associated families, which introduce a three-level @@ -551,43 +659,44 @@ -- third component of the environment that gives the class name (= -- grand parent) in case of associated families. -- - -- This env will have entries for data constructors too, - -- they won't make any difference because naked entities like T - -- in an import list map to TcOccs, not VarOccs. - occ_env :: OccEnv (Name, -- the name - AvailInfo, -- the export item providing the name - Maybe Name) -- the parent of associated types - occ_env = mkOccEnv_C combine [ (nameOccName n, (n, a, Nothing)) - | a <- all_avails, n <- availNames a] + -- This env will have entries for data constructors too, + -- they won't make any difference because naked entities like T + -- in an import list map to TcOccs, not VarOccs. + occ_env :: OccEnv (Name, -- the name + AvailInfo, -- the export item providing the name + Maybe Name) -- the parent of associated types + occ_env = mkOccEnv_C combine [ (nameOccName n, (n, a, Nothing)) + | a <- all_avails, n <- availNames a] where -- we know that (1) there are at most entries for one name, (2) their -- first component is identical, (3) they are for tys/cls, and (4) one -- entry has the name in its parent position (the other doesn't) combine (name, AvailTC p1 subs1, Nothing) - (_ , AvailTC p2 subs2, Nothing) + (_ , AvailTC p2 subs2, Nothing) = let - (parent, subs) = if p1 == name then (p2, subs1) else (p1, subs2) - in - (name, AvailTC name subs, Just parent) + (parent, subs) = if p1 == name then (p2, subs1) else (p1, subs2) + in + (name, AvailTC name subs, Just parent) combine x y = pprPanic "filterImports/combine" (ppr x $$ ppr y) lookup_lie :: Bool -> LIE RdrName -> TcRn [(LIE Name, AvailInfo)] lookup_lie opt_typeFamilies (L loc ieRdr) - = do - stuff <- setSrcSpan loc $ + = do + stuff <- setSrcSpan loc $ case lookup_ie opt_typeFamilies ieRdr of Failed err -> addErr err >> return [] Succeeded a -> return a checkDodgyImport stuff return [ (L loc ie, avail) | (ie,avail) <- stuff ] where - -- Warn when importing T(..) if T was exported abstractly + -- Warn when importing T(..) if T was exported abstractly checkDodgyImport stuff | IEThingAll n <- ieRdr, (_, AvailTC _ [_]):_ <- stuff - = ifDOptM Opt_WarnDodgyImports (addWarn (dodgyImportWarn n)) - -- NB. use the RdrName for reporting the warning - | IEThingAll {} <- ieRdr - = ifDOptM Opt_WarnMissingImportList $ + = ifWOptM Opt_WarnDodgyImports (addWarn (dodgyImportWarn n)) + -- NB. use the RdrName for reporting the warning + | IEThingAll {} <- ieRdr + , not (is_qual decl_spec) + = ifWOptM Opt_WarnMissingImportList $ addWarn (missingImportListItem ieRdr) checkDodgyImport _ = return () @@ -599,16 +708,16 @@ -- We return a list here, because in the case of an import -- item like C, if we are hiding, then C refers to *both* a -- type/class and a data constructor. Moreover, when we import - -- data constructors of an associated family, we need separate - -- AvailInfos for the data constructors and the family (as they have - -- different parents). See the discussion at occ_env. + -- data constructors of an associated family, we need separate + -- AvailInfos for the data constructors and the family (as they have + -- different parents). See the discussion at occ_env. lookup_ie :: Bool -> IE RdrName -> MaybeErr Message [(IE Name,AvailInfo)] - lookup_ie opt_typeFamilies ie + lookup_ie opt_typeFamilies ie = let bad_ie :: MaybeErr Message a bad_ie = Failed (badImportItemErr iface decl_spec ie all_avails) - lookup_name rdr - | isQual rdr = Failed (qualImportItemErr rdr) + lookup_name rdr + | isQual rdr = Failed (qualImportItemErr rdr) | Just nm <- lookupOccEnv occ_env (rdrNameOcc rdr) = return nm | otherwise = bad_ie in @@ -620,16 +729,16 @@ IEThingAll tc -> do (name, avail@(AvailTC name2 subs), mb_parent) <- lookup_name tc case mb_parent of - -- non-associated ty/cls - Nothing -> return [(IEThingAll name, avail)] - -- associated ty - Just parent -> return [(IEThingAll name, - AvailTC name2 (subs \\ [name])), - (IEThingAll name, AvailTC parent [name])] + -- non-associated ty/cls + Nothing -> return [(IEThingAll name, avail)] + -- associated ty + Just parent -> return [(IEThingAll name, + AvailTC name2 (subs \\ [name])), + (IEThingAll name, AvailTC parent [name])] IEThingAbs tc | want_hiding -- hiding ( C ) - -- Here the 'C' can be a data constructor + -- Here the 'C' can be a data constructor -- *or* a type/class, or even both -> let tc_name = lookup_name tc dc_name = lookup_name (setRdrNameSpace tc srcDataName) @@ -643,33 +752,33 @@ IEThingWith tc ns -> do (name, AvailTC _ subnames, mb_parent) <- lookup_name tc - let - env = mkOccEnv [(nameOccName s, s) | s <- subnames] - mb_children = map (lookupOccEnv env . rdrNameOcc) ns - children <- if any isNothing mb_children + let + env = mkOccEnv [(nameOccName s, s) | s <- subnames] + mb_children = map (lookupOccEnv env . rdrNameOcc) ns + children <- if any isNothing mb_children then bad_ie else return (catMaybes mb_children) - -- check for proper import of type families - when (not opt_typeFamilies && any isTyConName children) $ + -- check for proper import of type families + when (not opt_typeFamilies && any isTyConName children) $ Failed (typeItemErr (head . filter isTyConName $ children) - (text "in import list")) + (text "in import list")) case mb_parent of - -- non-associated ty/cls - Nothing -> return [(IEThingWith name children, - AvailTC name (name:children))] - -- associated ty - Just parent -> return [(IEThingWith name children, - AvailTC name children), - (IEThingWith name children, - AvailTC parent [name])] + -- non-associated ty/cls + Nothing -> return [(IEThingWith name children, + AvailTC name (name:children))] + -- associated ty + Just parent -> return [(IEThingWith name children, + AvailTC name children), + (IEThingWith name children, + AvailTC parent [name])] _other -> Failed illegalImportItemErr -- could be IEModuleContents, IEGroup, IEDoc, IEDocNamed -- all errors. where - mkIEThingAbs (n, av, Nothing ) = (IEThingAbs n, trimAvail av n) - mkIEThingAbs (n, _, Just parent) = (IEThingAbs n, AvailTC parent [n]) + mkIEThingAbs (n, av, Nothing ) = (IEThingAbs n, trimAvail av n) + mkIEThingAbs (n, _, Just parent) = (IEThingAbs n, AvailTC parent [n]) catMaybeErr :: [MaybeErr err a] -> [a] @@ -677,11 +786,32 @@ \end{code} %************************************************************************ -%* * - Import/Export Utils -%* * +%* * +\subsection{Import/Export Utils} +%* * %************************************************************************ +Note [Exports of data families] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose you see (Trac #5306) + module M where + import X( F ) + data instance F Int = FInt +What does M export? AvailTC F [FInt] + or AvailTC F [F,FInt]? +The former is strictly right because F isn't defined in this module. +But then you can never do an explicit import of M, thus + import M( F( FInt ) ) +becuase F isn't exported by M. Nor can you import FInt alone from here + import M( FInt ) +because we don't have syntax to support that. (It looks like an import of +the type FInt.) + +So we compromise. When constructing exports with no export list, or +with module M( module M ), we add the parent to the exports as well. +But not when you see module M( f ), even if f is a class method with +a parent. Hence the include_parent flag to greExportAvail. + \begin{code} -- | make a 'GlobalRdrEnv' where all the elements point to the same -- import declaration (useful for "hiding" imports, or imports with @@ -692,22 +822,35 @@ gresFromAvail :: (Name -> Provenance) -> AvailInfo -> [GlobalRdrElt] gresFromAvail prov_fn avail - = [ GRE {gre_name = n, - gre_par = availParent n avail, - gre_prov = prov_fn n} + = [ GRE {gre_name = n, + gre_par = availParent n avail, + gre_prov = prov_fn n} | n <- availNames avail ] - -greAvail :: GlobalRdrElt -> AvailInfo -greAvail gre = mkUnitAvail (gre_name gre) (gre_par gre) -mkUnitAvail :: Name -> Parent -> AvailInfo -mkUnitAvail me (ParentIs p) = AvailTC p [me] -mkUnitAvail me NoParent | isTyConName me = AvailTC me [me] - | otherwise = Avail me - -plusAvail :: GenAvailInfo Name -> GenAvailInfo Name -> GenAvailInfo Name -plusAvail (Avail n1) (Avail _) = Avail n1 -plusAvail (AvailTC _ ns1) (AvailTC n2 ns2) = AvailTC n2 (ns1 `unionLists` ns2) +greExportAvail :: Bool -> GlobalRdrElt -> AvailInfo +-- For 'include_parent' see Note [Exports of data families] +greExportAvail include_parent gre + = case gre_par gre of + ParentIs p | include_parent -> AvailTC p [p,me] + | otherwise -> AvailTC p [me] + NoParent | isTyConName me -> AvailTC me [me] + | otherwise -> Avail me + where + me = gre_name gre + +plusAvail :: AvailInfo -> AvailInfo -> AvailInfo +plusAvail a1 a2 + | debugIsOn && availName a1 /= availName a2 + = pprPanic "RnEnv.plusAvail names differ" (hsep [ppr a1,ppr a2]) +plusAvail a1@(Avail {}) (Avail {}) = a1 +plusAvail (AvailTC _ []) a2@(AvailTC {}) = a2 +plusAvail a1@(AvailTC {}) (AvailTC _ []) = a1 +plusAvail (AvailTC n1 (s1:ss1)) (AvailTC n2 (s2:ss2)) + = case (n1==s1, n2==s2) of -- Maintain invariant the parent is first + (True,True) -> AvailTC n1 (s1 : (ss1 `unionLists` ss2)) + (True,False) -> AvailTC n1 (s1 : (ss1 `unionLists` (s2:ss2))) + (False,True) -> AvailTC n1 (s2 : ((s1:ss1) `unionLists` ss2)) + (False,False) -> AvailTC n1 ((s1:ss1) `unionLists` (s2:ss2)) plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [ppr a1,ppr a2]) availParent :: Name -> AvailInfo -> Parent @@ -739,76 +882,38 @@ = gresFromAvail prov_fn avail where is_explicit = case ie of - IEThingAll name -> \n -> n == name - _ -> \_ -> True + IEThingAll name -> \n -> n == name + _ -> \_ -> True prov_fn name = Imported [imp_spec] - where - imp_spec = ImpSpec { is_decl = decl_spec, is_item = item_spec } - item_spec = ImpSome { is_explicit = is_explicit name, is_iloc = loc } + where + imp_spec = ImpSpec { is_decl = decl_spec, is_item = item_spec } + item_spec = ImpSome { is_explicit = is_explicit name, is_iloc = loc } mkChildEnv :: [GlobalRdrElt] -> NameEnv [Name] mkChildEnv gres = foldr add emptyNameEnv gres where - add (GRE { gre_name = n, gre_par = ParentIs p }) env = extendNameEnv_Acc (:) singleton env p n - add _ env = env + add (GRE { gre_name = n, gre_par = ParentIs p }) env = extendNameEnv_Acc (:) singleton env p n + add _ env = env findChildren :: NameEnv [Name] -> Name -> [Name] findChildren env n = lookupNameEnv env n `orElse` [] -\end{code} - ---------------------------------------- - AvailEnv and friends -All this AvailEnv stuff is hardly used; only in a very small -part of RnNames. Todo: remove? ---------------------------------------- - -\begin{code} -type AvailEnv = NameEnv AvailInfo -- Maps a Name to the AvailInfo that contains it - -emptyAvailEnv :: AvailEnv -emptyAvailEnv = emptyNameEnv - -{- Dead code -unitAvailEnv :: AvailInfo -> AvailEnv -unitAvailEnv a = unitNameEnv (availName a) a - -plusAvailEnv :: AvailEnv -> AvailEnv -> AvailEnv -plusAvailEnv = plusNameEnv_C plusAvail - -availEnvElts :: AvailEnv -> [AvailInfo] -availEnvElts = nameEnvElts --} - -addAvail :: AvailEnv -> AvailInfo -> AvailEnv -addAvail avails avail = extendNameEnv_C plusAvail avails (availName avail) avail - -mkAvailEnv :: [AvailInfo] -> AvailEnv - -- 'avails' may have several items with the same availName - -- E.g import Ix( Ix(..), index ) - -- will give Ix(Ix,index,range) and Ix(index) - -- We want to combine these; addAvail does that -mkAvailEnv avails = foldl addAvail emptyAvailEnv avails - --- After combining the avails, we need to ensure that the parent name is the --- first entry in the list of subnames, if it is included at all. (Subsequent --- functions rely on that.) -normaliseAvail :: AvailInfo -> AvailInfo -normaliseAvail avail@(Avail _) = avail -normaliseAvail (AvailTC name subs) = AvailTC name subs' - where - subs' = if name `elem` subs then name : (delete name subs) else subs - --- | combines 'AvailInfo's from the same family +-- | Combines 'AvailInfo's from the same family +-- 'avails' may have several items with the same availName +-- E.g import Ix( Ix(..), index ) +-- will give Ix(Ix,index,range) and Ix(index) +-- We want to combine these; addAvail does that nubAvails :: [AvailInfo] -> [AvailInfo] -nubAvails avails = map normaliseAvail . nameEnvElts . mkAvailEnv $ avails +nubAvails avails = nameEnvElts (foldl add emptyNameEnv avails) + where + add env avail = extendNameEnv_C plusAvail env (availName avail) avail \end{code} %************************************************************************ -%* * +%* * \subsection{Export list processing} -%* * +%* * %************************************************************************ Processing the export list. @@ -824,59 +929,59 @@ @ConcBase.StateAndSynchVar#@, and so on... \begin{code} -type ExportAccum -- The type of the accumulating parameter of - -- the main worker function in rnExports +type ExportAccum -- The type of the accumulating parameter of + -- the main worker function in rnExports = ([LIE Name], -- Export items with Names - ExportOccMap, -- Tracks exported occurrence names - [AvailInfo]) -- The accumulated exported stuff - -- Not nub'd! + ExportOccMap, -- Tracks exported occurrence names + [AvailInfo]) -- The accumulated exported stuff + -- Not nub'd! emptyExportAccum :: ExportAccum -emptyExportAccum = ([], emptyOccEnv, []) +emptyExportAccum = ([], emptyOccEnv, []) type ExportOccMap = OccEnv (Name, IE RdrName) - -- Tracks what a particular exported OccName - -- in an export list refers to, and which item - -- it came from. It's illegal to export two distinct things - -- that have the same occurrence name + -- Tracks what a particular exported OccName + -- in an export list refers to, and which item + -- it came from. It's illegal to export two distinct things + -- that have the same occurrence name -rnExports :: Bool -- False => no 'module M(..) where' header at all +rnExports :: Bool -- False => no 'module M(..) where' header at all -> Maybe [LIE RdrName] -- Nothing => no explicit export list - -> TcGblEnv + -> TcGblEnv -> RnM TcGblEnv - -- Complains if two distinct exports have same OccName + -- Complains if two distinct exports have same OccName -- Warns about identical exports. - -- Complains about exports items not in scope + -- Complains about exports items not in scope -rnExports explicit_mod exports - tcg_env@(TcGblEnv { tcg_mod = this_mod, - tcg_rdr_env = rdr_env, - tcg_imports = imports }) - = do { - -- If the module header is omitted altogether, then behave - -- as if the user had written "module Main(main) where..." - -- EXCEPT in interactive mode, when we behave as if he had - -- written "module Main where ..." - -- Reason: don't want to complain about 'main' not in scope - -- in interactive mode +rnExports explicit_mod exports + tcg_env@(TcGblEnv { tcg_mod = this_mod, + tcg_rdr_env = rdr_env, + tcg_imports = imports }) + = do { + -- If the module header is omitted altogether, then behave + -- as if the user had written "module Main(main) where..." + -- EXCEPT in interactive mode, when we behave as if he had + -- written "module Main where ..." + -- Reason: don't want to complain about 'main' not in scope + -- in interactive mode ; dflags <- getDOpts - ; let real_exports - | explicit_mod = exports - | ghcLink dflags == LinkInMemory = Nothing - | otherwise = Just ([noLoc (IEVar main_RDR_Unqual)]) - -- ToDo: the 'noLoc' here is unhelpful if 'main' - -- turns out to be out of scope - - ; (rn_exports, avails) <- exports_from_avail real_exports rdr_env imports this_mod - ; let final_avails = nubAvails avails -- Combine families - - ; return (tcg_env { tcg_exports = final_avails, + ; let real_exports + | explicit_mod = exports + | ghcLink dflags == LinkInMemory = Nothing + | otherwise = Just ([noLoc (IEVar main_RDR_Unqual)]) + -- ToDo: the 'noLoc' here is unhelpful if 'main' + -- turns out to be out of scope + + ; (rn_exports, avails) <- exports_from_avail real_exports rdr_env imports this_mod + ; let final_avails = nubAvails avails -- Combine families + + ; return (tcg_env { tcg_exports = final_avails, tcg_rn_exports = case tcg_rn_exports tcg_env of - Nothing -> Nothing - Just _ -> rn_exports, - tcg_dus = tcg_dus tcg_env `plusDU` - usesOnly (availsToNameSet final_avails) }) } + Nothing -> Nothing + Just _ -> rn_exports, + tcg_dus = tcg_dus tcg_env `plusDU` + usesOnly (availsToNameSet final_avails) }) } exports_from_avail :: Maybe [LIE RdrName] -- Nothing => no explicit export list @@ -889,8 +994,9 @@ = -- The same as (module M) where M is the current module name, -- so that's how we handle it. let - avails = [ greAvail gre | gre <- globalRdrEnvElts rdr_env, - isLocalGRE gre ] + avails = [ greExportAvail True gre + | gre <- globalRdrEnvElts rdr_env + , isLocalGRE gre ] in return (Nothing, avails) @@ -902,59 +1008,59 @@ do_litem :: ExportAccum -> LIE RdrName -> RnM ExportAccum do_litem acc lie = setSrcSpan (getLoc lie) (exports_from_item acc lie) - kids_env :: NameEnv [Name] -- Maps a parent to its in-scope children + kids_env :: NameEnv [Name] -- Maps a parent to its in-scope children kids_env = mkChildEnv (globalRdrEnvElts rdr_env) imported_modules = [ qual_name | xs <- moduleEnvElts $ imp_mods imports, - (qual_name, _, _) <- xs ] + (qual_name, _, _, _) <- xs ] exports_from_item :: ExportAccum -> LIE RdrName -> RnM ExportAccum - exports_from_item acc@(ie_names, occs, exports) - (L loc ie@(IEModuleContents mod)) - | let earlier_mods = [ mod | (L _ (IEModuleContents mod)) <- ie_names ] - , mod `elem` earlier_mods -- Duplicate export of M - = do { warn_dup_exports <- doptM Opt_WarnDuplicateExports ; - warnIf warn_dup_exports (dupModuleExport mod) ; - return acc } - - | otherwise - = do { implicit_prelude <- xoptM Opt_ImplicitPrelude - ; warnDodgyExports <- doptM Opt_WarnDodgyExports + exports_from_item acc@(ie_names, occs, exports) + (L loc (IEModuleContents mod)) + | let earlier_mods = [ mod | (L _ (IEModuleContents mod)) <- ie_names ] + , mod `elem` earlier_mods -- Duplicate export of M + = do { warn_dup_exports <- woptM Opt_WarnDuplicateExports ; + warnIf warn_dup_exports (dupModuleExport mod) ; + return acc } + + | otherwise + = do { implicit_prelude <- xoptM Opt_ImplicitPrelude + ; warnDodgyExports <- woptM Opt_WarnDodgyExports ; let { exportValid = (mod `elem` imported_modules) || (moduleName this_mod == mod) ; gres = filter (isModuleExported implicit_prelude mod) (globalRdrEnvElts rdr_env) - ; names = map gre_name gres + ; names = map gre_name gres } ; checkErr exportValid (moduleNotImported mod) - ; warnIf (warnDodgyExports && exportValid && null gres) (nullModuleExport mod) + ; warnIf (warnDodgyExports && exportValid && null gres) (nullModuleExport mod) - ; addUsedRdrNames (concat [ [mkRdrQual mod occ, mkRdrUnqual occ] + ; addUsedRdrNames (concat [ [mkRdrQual mod occ, mkRdrUnqual occ] | occ <- map nameOccName names ]) - -- The qualified and unqualified version of all of - -- these names are, in effect, used by this export + -- The qualified and unqualified version of all of + -- these names are, in effect, used by this export - ; occs' <- check_occs ie occs names + ; occs' <- check_occs (IEModuleContents mod) occs names -- This check_occs not only finds conflicts -- between this item and others, but also -- internally within this item. That is, if -- 'M.x' is in scope in several ways, we'll have -- several members of mod_avails with the same -- OccName. - ; return (L loc (IEModuleContents mod) : ie_names, - occs', map greAvail gres ++ exports) } + ; return (L loc (IEModuleContents mod) : ie_names, + occs', map (greExportAvail True) gres ++ exports) } exports_from_item acc@(lie_names, occs, exports) (L loc ie) - | isDoc ie - = do new_ie <- lookup_doc_ie ie - return (L loc new_ie : lie_names, occs, exports) + | isDoc ie + = do new_ie <- lookup_doc_ie ie + return (L loc new_ie : lie_names, occs, exports) - | otherwise + | otherwise = do (new_ie, avail) <- lookup_ie ie if isUnboundName (ieName new_ie) - then return acc -- Avoid error cascade + then return acc -- Avoid error cascade else do occs' <- check_occs ie occs (availNames avail) @@ -963,32 +1069,32 @@ ------------- lookup_ie :: IE RdrName -> RnM (IE Name, AvailInfo) - lookup_ie (IEVar rdr) + lookup_ie (IEVar rdr) = do gre <- lookupGreRn rdr - return (IEVar (gre_name gre), greAvail gre) + return (IEVar (gre_name gre), greExportAvail False gre) - lookup_ie (IEThingAbs rdr) + lookup_ie (IEThingAbs rdr) = do gre <- lookupGreRn rdr - let name = gre_name gre - case gre_par gre of - NoParent -> return (IEThingAbs name, - AvailTC name [name]) - ParentIs p -> return (IEThingAbs name, - AvailTC p [name]) + let name = gre_name gre + case gre_par gre of + NoParent -> return (IEThingAbs name, + AvailTC name [name]) + ParentIs p -> return (IEThingAbs name, + AvailTC p [name]) - lookup_ie ie@(IEThingAll rdr) + lookup_ie ie@(IEThingAll rdr) = do name <- lookupGlobalOccRn rdr - let kids = findChildren kids_env name + let kids = findChildren kids_env name mkKidRdrName = case isQual_maybe rdr of Nothing -> mkRdrUnqual Just (modName, _) -> mkRdrQual modName addUsedRdrNames $ map (mkKidRdrName . nameOccName) kids - warnDodgyExports <- doptM Opt_WarnDodgyExports + warnDodgyExports <- woptM Opt_WarnDodgyExports when (null kids) $ if isTyConName name then when warnDodgyExports $ addWarn (dodgyExportWarn name) else -- This occurs when you export T(..), but - -- only import T abstractly, or T is a synonym. + -- only import T abstractly, or T is a synonym. addErr (exportItemErr ie) return (IEThingAll name, AvailTC name (name:kids)) @@ -998,7 +1104,7 @@ if isUnboundName name then return (IEThingWith name [], AvailTC name [name]) else do - let env = mkOccEnv [ (nameOccName s, s) + let env = mkOccEnv [ (nameOccName s, s) | s <- findChildren kids_env name ] mb_names = map (lookupOccEnv env . rdrNameOcc) sub_rdrs if any isNothing mb_names @@ -1008,21 +1114,21 @@ optTyFam <- xoptM Opt_TypeFamilies when (not optTyFam && any isTyConName names) $ addErr (typeItemErr ( head - . filter isTyConName + . filter isTyConName $ names ) (text "in export list")) return (IEThingWith name names, AvailTC name (name:names)) - lookup_ie _ = panic "lookup_ie" -- Other cases covered earlier + lookup_ie _ = panic "lookup_ie" -- Other cases covered earlier ------------- lookup_doc_ie :: IE RdrName -> RnM (IE Name) lookup_doc_ie (IEGroup lev doc) = do rn_doc <- rnHsDoc doc - return (IEGroup lev rn_doc) + return (IEGroup lev rn_doc) lookup_doc_ie (IEDoc doc) = do rn_doc <- rnHsDoc doc - return (IEDoc rn_doc) + return (IEDoc rn_doc) lookup_doc_ie (IEDocNamed str) = return (IEDocNamed str) - lookup_doc_ie _ = panic "lookup_doc_ie" -- Other cases covered earlier + lookup_doc_ie _ = panic "lookup_doc_ie" -- Other cases covered earlier isDoc :: IE RdrName -> Bool @@ -1036,109 +1142,152 @@ -- True if the thing is in scope *both* unqualified, *and* with qualifier M isModuleExported implicit_prelude mod (GRE { gre_name = name, gre_prov = prov }) | implicit_prelude && isBuiltInSyntax name = False - -- Optimisation: filter out names for built-in syntax - -- They just clutter up the environment (esp tuples), and the parser - -- will generate Exact RdrNames for them, so the cluttered - -- envt is no use. To avoid doing this filter all the time, - -- we use -XNoImplicitPrelude as a clue that the filter is - -- worth while. Really, it's only useful for GHC.Base and GHC.Tuple. - -- - -- It's worth doing because it makes the environment smaller for - -- every module that imports the Prelude + -- Optimisation: filter out names for built-in syntax + -- They just clutter up the environment (esp tuples), and the parser + -- will generate Exact RdrNames for them, so the cluttered + -- envt is no use. To avoid doing this filter all the time, + -- we use -XNoImplicitPrelude as a clue that the filter is + -- worth while. Really, it's only useful for GHC.Base and GHC.Tuple. + -- + -- It's worth doing because it makes the environment smaller for + -- every module that imports the Prelude | otherwise = case prov of - LocalDef | Just name_mod <- nameModule_maybe name - -> moduleName name_mod == mod - | otherwise -> False - Imported is -> any unQualSpecOK is && any (qualSpecOK mod) is + LocalDef | Just name_mod <- nameModule_maybe name + -> moduleName name_mod == mod + | otherwise -> False + Imported is -> any unQualSpecOK is && any (qualSpecOK mod) is ------------------------------- check_occs :: IE RdrName -> ExportOccMap -> [Name] -> RnM ExportOccMap -check_occs ie occs names +check_occs ie occs names -- 'names' are the entities specifed by 'ie' = foldlM check occs names where check occs name = case lookupOccEnv occs name_occ of - Nothing -> return (extendOccEnv occs name_occ (name, ie)) + Nothing -> return (extendOccEnv occs name_occ (name, ie)) - Just (name', ie') - | name == name' -- Duplicate export - -> do { warn_dup_exports <- doptM Opt_WarnDuplicateExports ; - warnIf warn_dup_exports (dupExportWarn name_occ ie ie') ; - return occs } - - | otherwise -- Same occ name but different names: an error - -> do { global_env <- getGlobalRdrEnv ; - addErr (exportClashErr global_env name' name ie' ie) ; - return occs } + Just (name', ie') + | name == name' -- Duplicate export + -- But we don't want to warn if the same thing is exported + -- by two different module exports. See ticket #4478. + -> do unless (dupExport_ok name ie ie') $ do + warn_dup_exports <- woptM Opt_WarnDuplicateExports + warnIf warn_dup_exports (dupExportWarn name_occ ie ie') + return occs + + | otherwise -- Same occ name but different names: an error + -> do { global_env <- getGlobalRdrEnv ; + addErr (exportClashErr global_env name' name ie' ie) ; + return occs } where - name_occ = nameOccName name + name_occ = nameOccName name + + +dupExport_ok :: Name -> IE RdrName -> IE RdrName -> Bool +-- The Name is exported by both IEs. Is that ok? +-- "No" iff the name is mentioned explicitly in both IEs +-- or one of the IEs mentions the name *alone* +-- "Yes" otherwise +-- +-- Examples of "no": module M( f, f ) +-- module M( fmap, Functor(..) ) +-- module M( module Data.List, head ) +-- +-- Example of "yes" +-- module M( module A, module B ) where +-- import A( f ) +-- import B( f ) +-- +-- Example of "yes" (Trac #2436) +-- module M( C(..), T(..) ) where +-- class C a where { data T a } +-- instace C Int where { data T Int = TInt } +-- +-- Example of "yes" (Trac #2436) +-- module Foo ( T ) where +-- data family T a +-- module Bar ( T(..), module Foo ) where +-- import Foo +-- data instance T Int = TInt + +dupExport_ok n ie1 ie2 + = not ( single ie1 || single ie2 + || (explicit_in ie1 && explicit_in ie2) ) + where + explicit_in (IEModuleContents _) = False -- module M + explicit_in (IEThingAll r) = nameOccName n == rdrNameOcc r -- T(..) + explicit_in _ = True + + single (IEVar {}) = True + single (IEThingAbs {}) = True + single _ = False \end{code} %********************************************************* -%* * - Deprecations -%* * +%* * +\subsection{Deprecations} +%* * %********************************************************* \begin{code} -finishWarnings :: DynFlags -> Maybe WarningTxt +finishWarnings :: DynFlags -> Maybe WarningTxt -> TcGblEnv -> RnM TcGblEnv -- (a) Report usage of imports that are deprecated or have other warnings -- (b) If the whole module is warned about or deprecated, update tcg_warns -- All this happens only once per module finishWarnings dflags mod_warn tcg_env - = do { (eps,hpt) <- getEpsAndHpt - ; ifDOptM Opt_WarnWarningsDeprecations $ - mapM_ (check hpt (eps_PIT eps)) all_gres - -- By this time, typechecking is complete, - -- so the PIT is fully populated - - -- Deal with a module deprecation; it overrides all existing warns - ; let new_warns = case mod_warn of - Just txt -> WarnAll txt - Nothing -> tcg_warns tcg_env - ; return (tcg_env { tcg_warns = new_warns }) } + = do { (eps,hpt) <- getEpsAndHpt + ; ifWOptM Opt_WarnWarningsDeprecations $ + mapM_ (check hpt (eps_PIT eps)) all_gres + -- By this time, typechecking is complete, + -- so the PIT is fully populated + + -- Deal with a module deprecation; it overrides all existing warns + ; let new_warns = case mod_warn of + Just txt -> WarnAll txt + Nothing -> tcg_warns tcg_env + ; return (tcg_env { tcg_warns = new_warns }) } where - used_names = allUses (tcg_dus tcg_env) - -- Report on all deprecated uses; hence allUses + used_names = allUses (tcg_dus tcg_env) + -- Report on all deprecated uses; hence allUses all_gres = globalRdrEnvElts (tcg_rdr_env tcg_env) check hpt pit gre@(GRE {gre_name = name, gre_prov = Imported (imp_spec:_)}) | name `elemNameSet` used_names - , Just deprec_txt <- lookupImpDeprec dflags hpt pit gre + , Just deprec_txt <- lookupImpDeprec dflags hpt pit gre = addWarnAt (importSpecLoc imp_spec) - (sep [ptext (sLit "In the use of") <+> - pprNonVarNameSpace (occNameSpace (nameOccName name)) <+> - quotes (ppr name), - (parens imp_msg) <> colon, - (ppr deprec_txt) ]) - where - name_mod = ASSERT2( isExternalName name, ppr name ) nameModule name - imp_mod = importSpecModule imp_spec - imp_msg = ptext (sLit "imported from") <+> ppr imp_mod <> extra - extra | imp_mod == moduleName name_mod = empty - | otherwise = ptext (sLit ", but defined in") <+> ppr name_mod - - check _ _ _ = return () -- Local, or not used, or not deprectated - -- The Imported pattern-match: don't deprecate locally defined names - -- For a start, we may be exporting a deprecated thing - -- Also we may use a deprecated thing in the defn of another - -- deprecated things. We may even use a deprecated thing in - -- the defn of a non-deprecated thing, when changing a module's - -- interface + (sep [ptext (sLit "In the use of") <+> + pprNonVarNameSpace (occNameSpace (nameOccName name)) <+> + quotes (ppr name), + (parens imp_msg) <> colon, + (ppr deprec_txt) ]) + where + name_mod = ASSERT2( isExternalName name, ppr name ) nameModule name + imp_mod = importSpecModule imp_spec + imp_msg = ptext (sLit "imported from") <+> ppr imp_mod <> extra + extra | imp_mod == moduleName name_mod = empty + | otherwise = ptext (sLit ", but defined in") <+> ppr name_mod + + check _ _ _ = return () -- Local, or not used, or not deprectated + -- The Imported pattern-match: don't deprecate locally defined names + -- For a start, we may be exporting a deprecated thing + -- Also we may use a deprecated thing in the defn of another + -- deprecated things. We may even use a deprecated thing in + -- the defn of a non-deprecated thing, when changing a module's + -- interface -lookupImpDeprec :: DynFlags -> HomePackageTable -> PackageIfaceTable - -> GlobalRdrElt -> Maybe WarningTxt +lookupImpDeprec :: DynFlags -> HomePackageTable -> PackageIfaceTable + -> GlobalRdrElt -> Maybe WarningTxt -- The name is definitely imported, so look in HPT, PIT lookupImpDeprec dflags hpt pit gre = case lookupIfaceByModule dflags hpt pit mod of - Just iface -> mi_warn_fn iface name `mplus` -- Bleat if the thing, *or - case gre_par gre of - ParentIs p -> mi_warn_fn iface p -- its parent*, is warn'd - NoParent -> Nothing + Just iface -> mi_warn_fn iface name `mplus` -- Bleat if the thing, *or + case gre_par gre of + ParentIs p -> mi_warn_fn iface p -- its parent*, is warn'd + NoParent -> Nothing - Nothing -> Nothing -- See Note [Used names with interface not loaded] + Nothing -> Nothing -- See Note [Used names with interface not loaded] where name = gre_name gre mod = ASSERT2( isExternalName name, ppr name ) nameModule name @@ -1148,68 +1297,68 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ By now all the interfaces should have been loaded, because reportDeprecations happens after typechecking. -However, it's still (just) possible to to find a used +However, it's still (just) possible to to find a used Name whose interface hasn't been loaded: -a) It might be a WiredInName; in that case we may not load +a) It might be a WiredInName; in that case we may not load its interface (although we could). b) It might be GHC.Real.fromRational, or GHC.Num.fromInteger - These are seen as "used" by the renamer (if -XRebindableSyntax) - is on), but the typechecker may discard their uses + These are seen as "used" by the renamer (if -XRebindableSyntax) + is on), but the typechecker may discard their uses if in fact the in-scope fromRational is GHC.Read.fromRational, - (see tcPat.tcOverloadedLit), and the typechecker sees that the type + (see tcPat.tcOverloadedLit), and the typechecker sees that the type is fixed, say, to GHC.Base.Float (see Inst.lookupSimpleInst). In that obscure case it won't force the interface in. -In both cases we simply don't permit deprecations; +In both cases we simply don't permit deprecations; this is, after all, wired-in stuff. %********************************************************* -%* * - Unused names -%* * +%* * +\subsection{Unused names} +%* * %********************************************************* \begin{code} -reportUnusedNames :: Maybe [LIE RdrName] -- Export list - -> TcGblEnv -> RnM () -reportUnusedNames _export_decls gbl_env - = do { traceRn ((text "RUN") <+> (ppr (tcg_dus gbl_env))) +reportUnusedNames :: Maybe [LIE RdrName] -- Export list + -> TcGblEnv -> RnM () +reportUnusedNames _export_decls gbl_env + = do { traceRn ((text "RUN") <+> (ppr (tcg_dus gbl_env))) ; warnUnusedImportDecls gbl_env - ; warnUnusedTopBinds unused_locals } + ; warnUnusedTopBinds unused_locals } where used_names :: NameSet used_names = findUses (tcg_dus gbl_env) emptyNameSet - -- NB: currently, if f x = g, we only treat 'g' as used if 'f' is used - -- Hence findUses + -- NB: currently, if f x = g, we only treat 'g' as used if 'f' is used + -- Hence findUses - -- Collect the defined names from the in-scope environment + -- Collect the defined names from the in-scope environment defined_names :: [GlobalRdrElt] defined_names = globalRdrEnvElts (tcg_rdr_env gbl_env) - -- Note that defined_and_used, defined_but_not_used - -- are both [GRE]; that's why we need defined_and_used - -- rather than just used_names + -- Note that defined_and_used, defined_but_not_used + -- are both [GRE]; that's why we need defined_and_used + -- rather than just used_names _defined_and_used, defined_but_not_used :: [GlobalRdrElt] - (_defined_and_used, defined_but_not_used) - = partition (gre_is_used used_names) defined_names - + (_defined_and_used, defined_but_not_used) + = partition (gre_is_used used_names) defined_names + kids_env = mkChildEnv defined_names - -- This is done in mkExports too; duplicated work + -- This is done in mkExports too; duplicated work gre_is_used :: NameSet -> GlobalRdrElt -> Bool gre_is_used used_names (GRE {gre_name = name}) - = name `elemNameSet` used_names - || any (`elemNameSet` used_names) (findChildren kids_env name) - -- A use of C implies a use of T, - -- if C was brought into scope by T(..) or T(C) - - -- Filter out the ones that are - -- (a) defined in this module, and - -- (b) not defined by a 'deriving' clause - -- The latter have an Internal Name, so we can filter them out easily + = name `elemNameSet` used_names + || any (`elemNameSet` used_names) (findChildren kids_env name) + -- A use of C implies a use of T, + -- if C was brought into scope by T(..) or T(C) + + -- Filter out the ones that are + -- (a) defined in this module, and + -- (b) not defined by a 'deriving' clause + -- The latter have an Internal Name, so we can filter them out easily unused_locals :: [GlobalRdrElt] unused_locals = filter is_unused_local defined_but_not_used is_unused_local :: GlobalRdrElt -> Bool @@ -1217,19 +1366,19 @@ \end{code} %********************************************************* -%* * - Unused imports -%* * +%* * +\subsection{Unused imports} +%* * %********************************************************* -This code finds which import declarations are unused. The +This code finds which import declarations are unused. The specification and implementation notes are here: http://hackage.haskell.org/trac/ghc/wiki/Commentary/Compiler/UnusedImports \begin{code} -type ImportDeclUsage - = ( LImportDecl Name -- The import declaration - , [AvailInfo] -- What *is* used (normalised) +type ImportDeclUsage + = ( LImportDecl Name -- The import declaration + , [AvailInfo] -- What *is* used (normalised) , [Name] ) -- What is imported but *not* used \end{code} @@ -1238,38 +1387,41 @@ warnUnusedImportDecls gbl_env = do { uses <- readMutVar (tcg_used_rdrnames gbl_env) ; let imports = filter explicit_import (tcg_rn_imports gbl_env) - rdr_env = tcg_rdr_env gbl_env + rdr_env = tcg_rdr_env gbl_env ; let usage :: [ImportDeclUsage] usage = findImportUsage imports rdr_env (Set.elems uses) - ; ifDOptM Opt_WarnUnusedImports $ + ; traceRn (ptext (sLit "Import usage") <+> ppr usage) + ; ifWOptM Opt_WarnUnusedImports $ mapM_ warnUnusedImport usage ; ifDOptM Opt_D_dump_minimal_imports $ printMinimalImports usage } where - explicit_import (L loc _) = isGoodSrcSpan loc - -- Filter out the implicit Prelude import - -- which we do not want to bleat about + explicit_import (L loc _) = case loc of + UnhelpfulSpan _ -> False + RealSrcSpan _ -> True + -- Filter out the implicit Prelude import + -- which we do not want to bleat about \end{code} \begin{code} findImportUsage :: [LImportDecl Name] - -> GlobalRdrEnv - -> [RdrName] + -> GlobalRdrEnv + -> [RdrName] -> [ImportDeclUsage] type ImportMap = Map SrcLoc [AvailInfo] - -- The intermediate data struture records, for each import - -- declaration, what stuff brought into scope by that - -- declaration is actually used in the module. - -- - -- The SrcLoc is the location of the start - -- of a particular 'import' declaration - -- - -- The AvailInfos are the things imported from that decl - -- (just a list, not normalised) +-- The intermediate data struture records, for each import +-- declaration, what stuff brought into scope by that +-- declaration is actually used in the module. +-- +-- The SrcLoc is the location of the start +-- of a particular 'import' declaration +-- +-- The AvailInfos are the things imported from that decl +-- (just a list, not normalised) findImportUsage imports rdr_env rdrs = map unused_decl imports @@ -1281,22 +1433,22 @@ = (decl, nubAvails used_avails, unused_imps) where used_avails = Map.lookup (srcSpanStart loc) import_usage `orElse` [] - dont_report_as_unused = foldr add emptyNameSet used_avails + dont_report_as_unused = foldr add emptyNameSet used_avails add (Avail n) s = s `addOneToNameSet` n add (AvailTC n ns) s = s `addListToNameSet` (n:ns) - -- If you use 'signum' from Num, then the user may well have - -- imported Num(signum). We don't want to complain that - -- Num is not itself mentioned. Hence adding 'n' as - -- well to the list of of "don't report if unused" names - - unused_imps = case imps of - Just (False, imp_ies) -> nameSetToList unused_imps - where - imp_names = mkNameSet (concatMap (ieNames . unLoc) imp_ies) - unused_imps = imp_names `minusNameSet` dont_report_as_unused - - _other -> [] -- No explicit import list => no unused-name list - + -- If you use 'signum' from Num, then the user may well have + -- imported Num(signum). We don't want to complain that + -- Num is not itself mentioned. Hence adding 'n' as + -- well to the list of of "don't report if unused" names + + unused_imps = case imps of + Just (False, imp_ies) -> nameSetToList unused_imps + where + imp_names = mkNameSet (concatMap (ieNames . unLoc) imp_ies) + unused_imps = imp_names `minusNameSet` dont_report_as_unused + + _other -> [] -- No explicit import list => no unused-name list + addUsedRdrName :: GlobalRdrEnv -> RdrName -> ImportMap -> ImportMap -- For a used RdrName, find all the import decls that brought -- it into scope; choose one of them (bestImport), and record @@ -1312,13 +1464,13 @@ add_imp gre (ImpSpec { is_decl = imp_decl_spec }) imp_map = Map.insertWith add decl_loc [avail] imp_map where - add _ avails = avail : avails -- add is really just a specialised (++) + add _ avails = avail : avails -- add is really just a specialised (++) decl_loc = srcSpanStart (is_dloc imp_decl_spec) - name = gre_name gre - avail = case gre_par gre of - ParentIs p -> AvailTC p [name] - NoParent | isTyConName name -> AvailTC name [name] - | otherwise -> Avail name + name = gre_name gre + avail = case gre_par gre of + ParentIs p -> AvailTC p [name] + NoParent | isTyConName name -> AvailTC name [name] + | otherwise -> Avail name bestImport :: [ImportSpec] -> ImportSpec bestImport iss @@ -1328,8 +1480,8 @@ textuallyFirst :: [ImportSpec] -> ImportSpec textuallyFirst iss = case sortWith (is_dloc . is_decl) iss of - [] -> pprPanic "textuallyFirst" (ppr iss) - (is:_) -> is + [] -> pprPanic "textuallyFirst" (ppr iss) + (is:_) -> is isImpAll :: ImportSpec -> Bool isImpAll (ImpSpec { is_item = ImpAll }) = True @@ -1370,14 +1522,14 @@ printMinimalImports imports_w_usage = do { imports' <- mapM mk_minimal imports_w_usage ; this_mod <- getModule - ; liftIO $ + ; liftIO $ do { h <- openFile (mkFilename this_mod) WriteMode ; printForUser h neverQualify (vcat (map ppr imports')) } - -- The neverQualify is important. We are printing Names - -- but they are in the context of an 'import' decl, and - -- we never qualify things inside there - -- E.g. import Blag( f, b ) - -- not import Blag( Blag.f, Blag.g )! + -- The neverQualify is important. We are printing Names + -- but they are in the context of an 'import' decl, and + -- we never qualify things inside there + -- E.g. import Blag( f, b ) + -- not import Blag( Blag.f, Blag.g )! } where mkFilename this_mod = moduleNameString (moduleName this_mod) ++ ".imports" @@ -1392,36 +1544,33 @@ , ideclPkgQual = mb_pkg } = decl ; iface <- loadSrcInterface doc mod_name is_boot mb_pkg ; let lies = map (L l) (concatMap (to_ie iface) used) - ; return (L l (decl { ideclHiding = Just (False, lies) })) } + ; return (L l (decl { ideclHiding = Just (False, lies) })) } where - doc = text "Compute minimal imports for" <+> ppr decl + doc = text "Compute minimal imports for" <+> ppr decl to_ie :: ModIface -> AvailInfo -> [IE Name] - -- The main trick here is that if we're importing all the constructors - -- we want to say "T(..)", but if we're importing only a subset we want - -- to say "T(A,B,C)". So we have to find out what the module exports. - to_ie _ (Avail n) + -- The main trick here is that if we're importing all the constructors + -- we want to say "T(..)", but if we're importing only a subset we want + -- to say "T(A,B,C)". So we have to find out what the module exports. + to_ie _ (Avail n) = [IEVar n] - to_ie _ (AvailTC n [m]) + to_ie _ (AvailTC n [m]) | n==m = [IEThingAbs n] - to_ie iface (AvailTC n ns) - = case [xs | (m,as) <- mi_exports iface - , m == n_mod - , AvailTC x xs <- as - , x == nameOccName n - , x `elem` xs -- Note [Partial export] + to_ie iface (AvailTC n ns) + = case [xs | AvailTC x xs <- mi_exports iface + , x == n + , x `elem` xs -- Note [Partial export] ] of - [xs] | all_used xs -> [IEThingAll n] - | otherwise -> [IEThingWith n (filter (/= n) ns)] - _other -> (map IEVar ns) - where - all_used avail_occs = all (`elem` map nameOccName ns) avail_occs - n_mod = ASSERT( isExternalName n ) nameModule n + [xs] | all_used xs -> [IEThingAll n] + | otherwise -> [IEThingWith n (filter (/= n) ns)] + _other -> map IEVar ns + where + all_used avail_occs = all (`elem` ns) avail_occs \end{code} Note [Partial export] ~~~~~~~~~~~~~~~~~~~~~ -Suppose we have +Suppose we have module A( op ) where class C a where @@ -1440,9 +1589,9 @@ %************************************************************************ -%* * +%* * \subsection{Errors} -%* * +%* * %************************************************************************ \begin{code} @@ -1454,10 +1603,10 @@ badImportItemErrStd :: ModIface -> ImpDeclSpec -> IE RdrName -> SDoc badImportItemErrStd iface decl_spec ie = sep [ptext (sLit "Module"), quotes (ppr (is_mod decl_spec)), source_import, - ptext (sLit "does not export"), quotes (ppr ie)] + ptext (sLit "does not export"), quotes (ppr ie)] where source_import | mi_boot iface = ptext (sLit "(hi-boot interface)") - | otherwise = empty + | otherwise = empty badImportItemErrDataCon :: OccName -> ModIface -> ImpDeclSpec -> IE RdrName -> SDoc badImportItemErrDataCon dataType iface decl_spec ie @@ -1507,62 +1656,74 @@ dodgyMsg :: OutputableBndr n => SDoc -> n -> SDoc dodgyMsg kind tc = sep [ ptext (sLit "The") <+> kind <+> ptext (sLit "item") <+> quotes (ppr (IEThingAll tc)) - <+> ptext (sLit "suggests that"), - quotes (ppr tc) <+> ptext (sLit "has (in-scope) constructors or class methods,"), - ptext (sLit "but it has none") ] + <+> ptext (sLit "suggests that"), + quotes (ppr tc) <+> ptext (sLit "has (in-scope) constructors or class methods,"), + ptext (sLit "but it has none") ] exportItemErr :: IE RdrName -> SDoc exportItemErr export_item = sep [ ptext (sLit "The export item") <+> quotes (ppr export_item), - ptext (sLit "attempts to export constructors or class methods that are not visible here") ] + ptext (sLit "attempts to export constructors or class methods that are not visible here") ] typeItemErr :: Name -> SDoc -> SDoc typeItemErr name wherestr = sep [ ptext (sLit "Using 'type' tag on") <+> quotes (ppr name) <+> wherestr, - ptext (sLit "Use -XTypeFamilies to enable this extension") ] + ptext (sLit "Use -XTypeFamilies to enable this extension") ] exportClashErr :: GlobalRdrEnv -> Name -> Name -> IE RdrName -> IE RdrName -> Message exportClashErr global_env name1 name2 ie1 ie2 = vcat [ ptext (sLit "Conflicting exports for") <+> quotes (ppr occ) <> colon - , ppr_export ie1' name1' - , ppr_export ie2' name2' ] + , ppr_export ie1' name1' + , ppr_export ie2' name2' ] where occ = nameOccName name1 - ppr_export ie name = nest 2 (quotes (ppr ie) <+> ptext (sLit "exports") <+> - quotes (ppr name) <+> pprNameProvenance (get_gre name)) + ppr_export ie name = nest 2 (quotes (ppr ie) <+> ptext (sLit "exports") <+> + quotes (ppr name) <+> pprNameProvenance (get_gre name)) - -- get_gre finds a GRE for the Name, so that we can show its provenance + -- get_gre finds a GRE for the Name, so that we can show its provenance get_gre name - = case lookupGRE_Name global_env name of - (gre:_) -> gre - [] -> pprPanic "exportClashErr" (ppr name) - get_loc name = nameSrcLoc $ gre_name $ get_gre name + = case lookupGRE_Name global_env name of + (gre:_) -> gre + [] -> pprPanic "exportClashErr" (ppr name) + get_loc name = greSrcSpan (get_gre name) (name1', ie1', name2', ie2') = if get_loc name1 < get_loc name2 then (name1, ie1, name2, ie2) else (name2, ie2, name1, ie1) +-- the SrcSpan that pprNameProvenance prints out depends on whether +-- the Name is defined locally or not: for a local definition the +-- definition site is used, otherwise the location of the import +-- declaration. We want to sort the export locations in +-- exportClashErr by this SrcSpan, we need to extract it: +greSrcSpan :: GlobalRdrElt -> SrcSpan +greSrcSpan gre + | Imported (is:_) <- gre_prov gre = is_dloc (is_decl is) + | otherwise = name_span + where + name_span = nameSrcSpan (gre_name gre) + addDupDeclErr :: [Name] -> TcRn () addDupDeclErr [] = panic "addDupDeclErr: empty list" addDupDeclErr names@(name : _) = addErrAt (getSrcSpan (last sorted_names)) $ - -- Report the error at the later location + -- Report the error at the later location vcat [ptext (sLit "Multiple declarations of") <+> quotes (ppr name), - ptext (sLit "Declared at:") <+> vcat (map (ppr . nameSrcLoc) sorted_names)] + ptext (sLit "Declared at:") <+> vcat (map (ppr . nameSrcLoc) sorted_names)] where sorted_names = sortWith nameSrcLoc names dupExportWarn :: OccName -> IE RdrName -> IE RdrName -> SDoc dupExportWarn occ_name ie1 ie2 - = hsep [quotes (ppr occ_name), + = hsep [quotes (ppr occ_name), ptext (sLit "is exported by"), quotes (ppr ie1), ptext (sLit "and"), quotes (ppr ie2)] dupModuleExport :: ModuleName -> SDoc dupModuleExport mod = hsep [ptext (sLit "Duplicate"), - quotes (ptext (sLit "Module") <+> ppr mod), + quotes (ptext (sLit "Module") <+> ppr mod), ptext (sLit "in export list")] moduleNotImported :: ModuleName -> SDoc @@ -1584,11 +1745,11 @@ moduleWarn :: ModuleName -> WarningTxt -> SDoc moduleWarn mod (WarningTxt txt) - = sep [ ptext (sLit "Module") <+> quotes (ppr mod) <> ptext (sLit ":"), + = sep [ ptext (sLit "Module") <+> quotes (ppr mod) <> ptext (sLit ":"), nest 2 (vcat (map ppr txt)) ] moduleWarn mod (DeprecatedTxt txt) = sep [ ptext (sLit "Module") <+> quotes (ppr mod) - <+> ptext (sLit "is deprecated:"), + <+> ptext (sLit "is deprecated:"), nest 2 (vcat (map ppr txt)) ] implicitPreludeWarn :: SDoc diff -Nru ghc-7.0.3/compiler/rename/RnPat.lhs ghc-7.2.1/compiler/rename/RnPat.lhs --- ghc-7.0.3/compiler/rename/RnPat.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/rename/RnPat.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -10,6 +10,7 @@ free variables. \begin{code} +{-# LANGUAGE ScopedTypeVariables #-} module RnPat (-- main entry points rnPat, rnPats, rnBindPat, @@ -47,7 +48,8 @@ import NameSet import RdrName import BasicTypes -import ListSetOps ( removeDups, minusList ) +import Util ( notNull ) +import ListSetOps ( removeDups ) import Outputable import SrcLoc import FastString @@ -229,12 +231,15 @@ ; bindPatSigTyVarsFV (collectSigTysFromPats pats) $ unCpsRn (rnLPatsAndThen (matchNameMaker ctxt) pats) $ \ pats' -> do { -- Check for duplicated and shadowed names - -- Because we don't bind the vars all at once, we can't - -- check incrementally for duplicates; - -- Nor can we check incrementally for shadowing, else we'll - -- complain *twice* about duplicates e.g. f (x,x) = ... - ; let names = collectPatsBinders pats' - ; addErrCtxt doc_pat $ checkDupAndShadowedNames envs_before names + -- Must do this *after* renaming the patterns + -- See Note [Collect binders only after renaming] in HsUtils + -- Because we don't bind the vars all at once, we can't + -- check incrementally for duplicates; + -- Nor can we check incrementally for shadowing, else we'll + -- complain *twice* about duplicates e.g. f (x,x) = ... + ; addErrCtxt doc_pat $ + checkDupAndShadowedNames envs_before $ + collectPatsBinders pats' ; thing_inside pats' } } where doc_pat = ptext (sLit "In") <+> pprMatchContext ctxt @@ -367,10 +372,6 @@ ; pats' <- rnLPatsAndThen mk pats ; return (TuplePat pats' boxed placeHolderType) } -rnPatAndThen _ (TypePat ty) - = do { ty' <- liftCpsFV $ rnHsTypeFVs (text "In a type pattern") ty - ; return (TypePat ty') } - #ifndef GHCI rnPatAndThen _ p@(QuasiQuotePat {}) = pprPanic "Can't do QuasiQuotePat without GHCi" (ppr p) @@ -441,7 +442,8 @@ | HsRecFieldUpd rnHsRecFields1 - :: HsRecFieldContext + :: forall arg. + HsRecFieldContext -> (RdrName -> arg) -- When punning, use this to build a new field -> HsRecFields RdrName (Located arg) -> RnM ([HsRecField Name (Located arg)], FreeVars) @@ -458,64 +460,97 @@ ; parent <- check_disambiguation disambig_ok mb_con ; flds1 <- mapM (rn_fld pun_ok parent) flds ; mapM_ (addErr . dupFieldErr ctxt) dup_flds - ; flds2 <- rn_dotdot dotdot mb_con flds1 - ; return (flds2, mkFVs (getFieldIds flds2)) } + ; dotdot_flds <- rn_dotdot dotdot mb_con flds1 + ; let all_flds | null dotdot_flds = flds1 + | otherwise = flds1 ++ dotdot_flds + ; return (all_flds, mkFVs (getFieldIds all_flds)) } where mb_con = case ctxt of - HsRecFieldUpd -> Nothing - HsRecFieldCon con -> Just con - HsRecFieldPat con -> Just con + HsRecFieldCon con | not (isUnboundName con) -> Just con + HsRecFieldPat con | not (isUnboundName con) -> Just con + _other -> Nothing + -- The unbound name test is because if the constructor + -- isn't in scope the constructor lookup will add an error + -- add an error, but still return an unbound name. + -- We don't want that to screw up the dot-dot fill-in stuff. + doc = case mb_con of Nothing -> ptext (sLit "constructor field name") Just con -> ptext (sLit "field of constructor") <+> quotes (ppr con) - name_to_arg (L loc n) = L loc (mk_arg (mkRdrUnqual (nameOccName n))) - rn_fld pun_ok parent (HsRecField { hsRecFieldId = fld , hsRecFieldArg = arg , hsRecPun = pun }) - = do { fld' <- wrapLocM (lookupSubBndr parent doc) fld + = do { fld'@(L loc fld_nm) <- wrapLocM (lookupSubBndr parent doc) fld ; arg' <- if pun then do { checkErr pun_ok (badPun fld) - ; return (name_to_arg fld') } + ; return (L loc (mk_arg (mkRdrUnqual (nameOccName fld_nm)))) } else return arg ; return (HsRecField { hsRecFieldId = fld' , hsRecFieldArg = arg' , hsRecPun = pun }) } - rn_dotdot Nothing _mb_con flds -- No ".." at all - = return flds - rn_dotdot (Just {}) Nothing flds -- ".." on record update - = do { addErr (badDotDot ctxt); return flds } + rn_dotdot :: Maybe Int -- See Note [DotDot fields] in HsPat + -> Maybe Name -- The constructor (Nothing for an update + -- or out of scope constructor) + -> [HsRecField Name (Located arg)] -- Explicit fields + -> RnM [HsRecField Name (Located arg)] -- Filled in .. fields + rn_dotdot Nothing _mb_con _flds -- No ".." at all + = return [] + rn_dotdot (Just {}) Nothing _flds -- ".." on record update + = do { addErr (badDotDot ctxt); return [] } rn_dotdot (Just n) (Just con) flds -- ".." on record con/pat = ASSERT( n == length flds ) do { loc <- getSrcSpanM -- Rather approximate ; dd_flag <- xoptM Opt_RecordWildCards ; checkErr dd_flag (needFlagDotDot ctxt) - + ; (rdr_env, lcl_env) <- getRdrEnvs ; con_fields <- lookupConstructorFields con ; let present_flds = getFieldIds flds - absent_flds = con_fields `minusList` present_flds - extras = [ HsRecField - { hsRecFieldId = L loc f - , hsRecFieldArg = name_to_arg (L loc f) - , hsRecPun = False } - | f <- absent_flds ] + parent_tc = find_tycon rdr_env con + + -- Only fill in fields whose selectors are in scope (somehow) + fld_in_scope fld = not (null (lookupGRE_Name rdr_env fld)) - ; return (flds ++ extras) } + -- For constructor uses, the arg should be in scope (unqualified) + -- ignoring the record field itself + -- Eg. data R = R { x,y :: Int } + -- f x = R { .. } -- Should expand to R {x=x}, not R{x=x,y=y} + arg_in_scope rdr = rdr `elemLocalRdrEnv` lcl_env + || notNull [ gre | gre <- lookupGRE_RdrName rdr rdr_env + , case gre_par gre of + ParentIs p -> p /= parent_tc + _ -> True ] + + ; return [ HsRecField + { hsRecFieldId = loc_f + , hsRecFieldArg = L loc (mk_arg arg_rdr) + , hsRecPun = False } + | f <- con_fields + , let loc_f = L loc f + arg_rdr = mkRdrUnqual (nameOccName f) + , not (f `elem` present_flds) + , fld_in_scope f + , case ctxt of + HsRecFieldCon {} -> arg_in_scope arg_rdr + _other -> True ] } check_disambiguation :: Bool -> Maybe Name -> RnM Parent - -- When disambiguation is on, return the parent *type constructor* - -- That is, the parent of the data constructor. That's the parent - -- to use for looking up record fields. + -- When disambiguation is on, check_disambiguation disambig_ok mb_con | disambig_ok, Just con <- mb_con - = do { env <- getGlobalRdrEnv - ; return (case lookupGRE_Name env con of - [gre] -> gre_par gre - gres -> WARN( True, ppr con <+> ppr gres ) NoParent) } + = do { env <- getGlobalRdrEnv; return (ParentIs (find_tycon env con)) } | otherwise = return NoParent + find_tycon :: GlobalRdrEnv -> Name {- DataCon -} -> Name {- TyCon -} + -- Return the parent *type constructor* of the data constructor + -- That is, the parent of the data constructor. + -- That's the parent to use for looking up record fields. + find_tycon env con + = case lookupGRE_Name env con of + [GRE { gre_par = ParentIs p }] -> p + gres -> pprPanic "find_tycon" (ppr con $$ ppr gres) + dup_flds :: [[RdrName]] -- Each list represents a RdrName that occurred more than once -- (the list contains all occurrences) diff -Nru ghc-7.0.3/compiler/rename/RnSource.lhs ghc-7.2.1/compiler/rename/RnSource.lhs --- ghc-7.0.3/compiler/rename/RnSource.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/rename/RnSource.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -17,20 +17,20 @@ import HsSyn import RdrName ( RdrName, isRdrDataCon, elemLocalRdrEnv, rdrNameOcc ) -import RdrHsSyn ( extractGenericPatTyVars, extractHsRhoRdrTyVars ) +import RdrHsSyn ( extractHsRhoRdrTyVars ) import RnHsSyn -import RnTypes ( rnLHsType, rnLHsTypes, rnHsSigType, rnHsTypeFVs, rnContext, rnConDeclFields ) +import RnTypes import RnBinds ( rnTopBindsLHS, rnTopBindsRHS, rnMethodBinds, renameSigs, mkSigTvFn, makeMiniFixityEnv) import RnEnv ( lookupLocalDataTcNames, lookupLocatedOccRn, lookupTopBndrRn, lookupLocatedTopBndrRn, - lookupOccRn, newLocalBndrsRn, bindLocalNamesFV, + lookupOccRn, bindLocalNamesFV, bindLocatedLocalsFV, bindPatSigTyVarsFV, bindTyVarsRn, bindTyVarsFV, extendTyVarEnvFVRn, bindLocalNames, checkDupRdrNames, mapFvRn ) import RnNames ( getLocalNonValBinders, extendGlobalRdrEnvRn ) -import HscTypes ( GenAvailInfo(..), availsToNameSet ) +import HscTypes ( AvailInfo(..), availsToNameSet ) import RnHsDoc ( rnHsDoc, rnMbLHsDoc ) import TcRnMonad @@ -97,6 +97,7 @@ hs_fords = foreign_decls, hs_defds = default_decls, hs_ruleds = rule_decls, + hs_vects = vect_decls, hs_docs = docs }) = do { -- (A) Process the fixity declarations, creating a mapping from @@ -168,13 +169,14 @@ -- (H) Rename Everything else (rn_inst_decls, src_fvs2) <- rnList rnSrcInstDecl inst_decls ; - (rn_rule_decls, src_fvs3) <- setOptM Opt_ScopedTypeVariables $ - rnList rnHsRuleDecl rule_decls ; - -- Inside RULES, scoped type variables are on - (rn_foreign_decls, src_fvs4) <- rnList rnHsForeignDecl foreign_decls ; - (rn_ann_decls, src_fvs5) <- rnList rnAnnDecl ann_decls ; - (rn_default_decls, src_fvs6) <- rnList rnDefaultDecl default_decls ; - (rn_deriv_decls, src_fvs7) <- rnList rnSrcDerivDecl deriv_decls ; + (rn_rule_decls, src_fvs3) <- setXOptM Opt_ScopedTypeVariables $ + rnList rnHsRuleDecl rule_decls ; + -- Inside RULES, scoped type variables are on + (rn_vect_decls, src_fvs4) <- rnList rnHsVectDecl vect_decls ; + (rn_foreign_decls, src_fvs5) <- rnList rnHsForeignDecl foreign_decls ; + (rn_ann_decls, src_fvs6) <- rnList rnAnnDecl ann_decls ; + (rn_default_decls, src_fvs7) <- rnList rnDefaultDecl default_decls ; + (rn_deriv_decls, src_fvs8) <- rnList rnSrcDerivDecl deriv_decls ; -- Haddock docs; no free vars rn_docs <- mapM (wrapLocM rnDocDecl) docs ; @@ -190,13 +192,14 @@ hs_annds = rn_ann_decls, hs_defds = rn_default_decls, hs_ruleds = rn_rule_decls, + hs_vects = rn_vect_decls, hs_docs = rn_docs } ; tycl_bndrs = hsTyClDeclsBinders rn_tycl_decls rn_inst_decls ; ford_bndrs = hsForeignDeclsBinders rn_foreign_decls ; other_def = (Just (mkNameSet tycl_bndrs `unionNameSets` mkNameSet ford_bndrs), emptyNameSet) ; other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs3, src_fvs4, - src_fvs5, src_fvs6, src_fvs7] ; + src_fvs5, src_fvs6, src_fvs7, src_fvs8] ; -- It is tiresome to gather the binders from type and class decls src_dus = [other_def] `plusDU` bind_dus `plusDU` usesOnly other_fvs ; @@ -440,30 +443,19 @@ -- The typechecker (not the renamer) checks that all -- the bindings are for the right class let - meth_names = collectMethodBinders mbinds (inst_tyvars, _, cls,_) = splitHsInstDeclTy (unLoc inst_ty') in - checkDupRdrNames meth_names `thenM_` - -- Check that the same method is not given twice in the - -- same instance decl instance C T where - -- f x = ... - -- g y = ... - -- f x = ... - -- We must use checkDupRdrNames because the Name of the - -- method is the Name of the class selector, whose SrcSpan - -- points to the class declaration - extendTyVarEnvForMethodBinds inst_tyvars ( -- (Slightly strangely) the forall-d tyvars scope over -- the method bindings too rnMethodBinds cls (\_ -> []) -- No scoped tyvars - [] mbinds + mbinds ) `thenM` \ (mbinds', meth_fvs) -> -- Rename the associated types -- The typechecker (not the renamer) checks that all -- the declarations are for the right class let - at_names = map (head . hsTyClDeclBinders) ats + at_names = map (tcdLName . unLoc) ats -- The names of the associated types in checkDupRdrNames at_names `thenM_` -- See notes with checkDupRdrNames for methods, above @@ -539,7 +531,7 @@ rnSrcDerivDecl (DerivDecl ty) = do { standalone_deriv_ok <- xoptM Opt_StandaloneDeriving ; unless standalone_deriv_ok (addErr standaloneDerivErr) - ; ty' <- rnLHsType (text "a deriving decl") ty + ; ty' <- rnLHsType (text "In a deriving declaration") ty ; let fvs = extractHsTyNames ty' ; return (DerivDecl ty', fvs) } @@ -658,6 +650,29 @@ %********************************************************* +%* * +\subsection{Vectorisation declarations} +%* * +%********************************************************* + +\begin{code} +rnHsVectDecl :: VectDecl RdrName -> RnM (VectDecl Name, FreeVars) +rnHsVectDecl (HsVect var Nothing) + = do { var' <- wrapLocM lookupTopBndrRn var + ; return (HsVect var' Nothing, unitFV (unLoc var')) + } +rnHsVectDecl (HsVect var (Just rhs)) + = do { var' <- wrapLocM lookupTopBndrRn var + ; (rhs', fv_rhs) <- rnLExpr rhs + ; return (HsVect var' (Just rhs'), fv_rhs `addOneFV` unLoc var') + } +rnHsVectDecl (HsNoVect var) + = do { var' <- wrapLocM lookupTopBndrRn var + ; return (HsNoVect var', unitFV (unLoc var')) + } +\end{code} + +%********************************************************* %* * \subsection{Type, class and iface sig declarations} %* * @@ -788,7 +803,7 @@ -- Check the signatures -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs). - ; let sig_rdr_names_w_locs = [op | L _ (TypeSig op _) <- sigs] + ; let sig_rdr_names_w_locs = [op | L _ (TypeSig ops _) <- sigs, op <- ops] ; checkDupRdrNames sig_rdr_names_w_locs -- Typechecker is responsible for checking that we only -- give default-method bindings for things in this class. @@ -804,15 +819,11 @@ -- we want to name both "x" tyvars with the same unique, so that they are -- easy to group together in the typechecker. ; (mbinds', meth_fvs) - <- extendTyVarEnvForMethodBinds tyvars' $ do - { name_env <- getLocalRdrEnv - ; let gen_rdr_tyvars_w_locs = [ tv | tv <- extractGenericPatTyVars mbinds, - not (unLoc tv `elemLocalRdrEnv` name_env) ] + <- extendTyVarEnvForMethodBinds tyvars' $ -- No need to check for duplicate method signatures -- since that is done by RnNames.extendGlobalRdrEnvRn -- and the methods are already in scope - ; gen_tyvars <- newLocalBndrsRn gen_rdr_tyvars_w_locs - ; rnMethodBinds (unLoc cname') (mkSigTvFn sigs') gen_tyvars mbinds } + rnMethodBinds (unLoc cname') (mkSigTvFn sigs') mbinds -- Haddock docs ; docs' <- mapM (wrapLocM rnDocDecl) docs @@ -908,12 +919,16 @@ ; rdr_env <- getLocalRdrEnv ; let in_scope = (`elemLocalRdrEnv` rdr_env) . unLoc arg_tys = hsConDeclArgTys details - implicit_tvs = case res_ty of + mentioned_tvs = case res_ty of ResTyH98 -> filterOut in_scope (get_rdr_tvs arg_tys) ResTyGADT ty -> get_rdr_tvs (ty : arg_tys) - new_tvs = case expl of - Explicit -> tvs - Implicit -> userHsTyVarBndrs implicit_tvs + + -- With an Explicit forall, check for unused binders + -- With Implicit, find the mentioned ones, and use them as binders + ; new_tvs <- case expl of + Implicit -> return (userHsTyVarBndrs mentioned_tvs) + Explicit -> do { warnUnusedForAlls doc tvs mentioned_tvs + ; return tvs } ; mb_doc' <- rnMbLHsDoc mb_doc @@ -1214,6 +1229,8 @@ = addl (gp { hs_annds = L l d : ts }) ds add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds = addl (gp { hs_ruleds = L l d : ts }) ds +add gp@(HsGroup {hs_vects = ts}) l (VectD d) ds + = addl (gp { hs_vects = L l d : ts }) ds add gp l (DocD d) ds = addl (gp { hs_docs = (L l d) : (hs_docs gp) }) ds @@ -1228,4 +1245,4 @@ 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 -Nru ghc-7.0.3/compiler/rename/RnTypes.lhs ghc-7.2.1/compiler/rename/RnTypes.lhs --- ghc-7.0.3/compiler/rename/RnTypes.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/rename/RnTypes.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -11,7 +11,7 @@ -- Precence related stuff mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn, - checkPrecMatch, checkSectionPrec, + checkPrecMatch, checkSectionPrec, warnUnusedForAlls, -- Splice related stuff rnSplice, checkTH @@ -31,11 +31,12 @@ import TcRnMonad import RdrName import PrelNames -import TypeRep ( funTyConName ) +import TysPrim ( funTyConName ) import Name import SrcLoc import NameSet +import Util ( filterOut ) import BasicTypes ( compareFixity, funTyFixity, negateFixity, Fixity(..), FixityDirection(..) ) import Outputable @@ -93,19 +94,16 @@ rnForAll doc Implicit tyvar_bndrs ctxt ty -rnHsType doc (HsForAllTy Explicit forall_tyvars ctxt tau) = do - -- Explicit quantification. - -- Check that the forall'd tyvars are actually - -- mentioned in the type, and produce a warning if not - let - mentioned = map unLoc (extractHsRhoRdrTyVars ctxt tau) - forall_tyvar_names = hsLTyVarLocNames forall_tyvars - - -- Explicitly quantified but not mentioned in ctxt or tau - warn_guys = filter ((`notElem` mentioned) . unLoc) forall_tyvar_names +rnHsType doc ty@(HsForAllTy Explicit forall_tyvars ctxt tau) + = do { -- Explicit quantification. + -- Check that the forall'd tyvars are actually + -- mentioned in the type, and produce a warning if not + let mentioned = extractHsRhoRdrTyVars ctxt tau + in_type_doc = ptext (sLit "In the type") <+> quotes (ppr ty) + ; warnUnusedForAlls (in_type_doc $$ doc) forall_tyvars mentioned - mapM_ (forAllWarn doc tau) warn_guys - rnForAll doc Explicit forall_tyvars ctxt tau + ; -- rnForAll does the rest + rnForAll doc Explicit forall_tyvars ctxt tau } rnHsType _ (HsTyVar tyvar) = do tyvar' <- lookupOccRn tyvar @@ -139,13 +137,6 @@ = do { flds' <- rnConDeclFields doc flds ; return (HsRecTy flds') } -rnHsType _ (HsNumTy i) - | i == 1 = return (HsNumTy i) - | otherwise = addErr err_msg >> return (HsNumTy i) - where - err_msg = ptext (sLit "Only unit numeric type pattern is valid") - - rnHsType doc (HsFunTy ty1 ty2) = do ty1' <- rnLHsType doc ty1 -- Might find a for-all as the arg of a function type @@ -567,14 +558,19 @@ %********************************************************* \begin{code} -forAllWarn :: SDoc -> LHsType RdrName -> Located RdrName - -> TcRnIf TcGblEnv TcLclEnv () -forAllWarn doc ty (L loc tyvar) - = ifDOptM Opt_WarnUnusedMatches $ - addWarnAt loc (sep [ptext (sLit "The universally quantified type variable") <+> quotes (ppr tyvar), - nest 4 (ptext (sLit "does not appear in the type") <+> quotes (ppr ty))] - $$ - doc) +warnUnusedForAlls :: SDoc -> [LHsTyVarBndr RdrName] -> [Located RdrName] -> TcM () +warnUnusedForAlls in_doc bound used + = ifWOptM Opt_WarnUnusedMatches $ + mapM_ add_warn bound_but_not_used + where + bound_names = hsLTyVarLocNames bound + bound_but_not_used = filterOut ((`elem` mentioned_rdrs) . unLoc) bound_names + mentioned_rdrs = map unLoc used + + add_warn (L loc tv) + = addWarnAt loc $ + vcat [ ptext (sLit "Unused quantified type variable") <+> quotes (ppr tv) + , in_doc ] opTyErr :: RdrName -> HsType RdrName -> SDoc opTyErr op ty@(HsOpTy ty1 _ _) diff -Nru ghc-7.0.3/compiler/simplCore/CoreMonad.lhs ghc-7.2.1/compiler/simplCore/CoreMonad.lhs --- ghc-7.0.3/compiler/simplCore/CoreMonad.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/simplCore/CoreMonad.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -8,10 +8,16 @@ module CoreMonad ( -- * Configuration of the core-to-core passes - CoreToDo(..), + CoreToDo(..), runWhen, runMaybe, SimplifierMode(..), FloatOutSwitches(..), - getCoreToDo, dumpSimplPhase, + dumpSimplPhase, pprPassDetails, + + defaultGentleSimplToDo, + + -- * Plugins + PluginPass, Plugin(..), CommandLineOption, + defaultPlugin, bindsOnlyPass, -- * Counting SimplCount, doSimplTick, doFreeSimplTick, simplCountN, @@ -31,11 +37,14 @@ liftIO, liftIOWithCount, liftIO1, liftIO2, liftIO3, liftIO4, + -- ** Global initialization + reinitializeGlobals, + -- ** Dealing with annotations getAnnotations, getFirstAnnotations, -- ** Debug output - showPass, endPass, endIteration, dumpIfSet, + showPass, endPass, dumpPassResult, lintPassResult, dumpIfSet, -- ** Screen output putMsg, putMsgS, errorMsg, errorMsgS, @@ -58,7 +67,7 @@ import CoreLint ( lintCoreBindings ) import PrelNames ( iNTERACTIVE ) import HscTypes -import Module ( PackageId, Module ) +import Module ( Module ) import DynFlags import StaticFlags import Rules ( RuleBase ) @@ -78,6 +87,7 @@ import Maybes import UniqSupply import UniqFM ( UniqFM, mapUFM, filterUFM ) +import MonadUtils import Util ( split ) import Data.List ( intersperse ) @@ -91,8 +101,16 @@ import Prelude hiding ( read ) #ifdef GHCI +import Control.Concurrent.MVar (MVar) +import Linker ( PersistentLinkerState, saveLinkerGlobals, restoreLinkerGlobals ) import {-# SOURCE #-} TcSplice ( lookupThName_maybe ) import qualified Language.Haskell.TH as TH +#else +saveLinkerGlobals :: IO () +saveLinkerGlobals = return () + +restoreLinkerGlobals :: () -> IO () +restoreLinkerGlobals () = return () #endif \end{code} @@ -111,49 +129,53 @@ showPass dflags pass = Err.showPass dflags (showSDoc (ppr pass)) endPass :: DynFlags -> CoreToDo -> [CoreBind] -> [CoreRule] -> IO () -endPass dflags pass = dumpAndLint dflags True pass empty (coreDumpFlag pass) - --- Same as endPass but doesn't dump Core even with -dverbose-core2core -endIteration :: DynFlags -> CoreToDo -> Int -> [CoreBind] -> [CoreRule] -> IO () -endIteration dflags pass n - = dumpAndLint dflags False pass (ptext (sLit "iteration=") <> int n) - (Just Opt_D_dump_simpl_iterations) +endPass dflags pass binds rules + = do { dumpPassResult dflags mb_flag (ppr pass) empty binds rules + ; lintPassResult dflags pass binds } + where + mb_flag = case coreDumpFlag pass of + Just dflag | dopt dflag dflags -> Just dflag + | dopt Opt_D_verbose_core2core dflags -> Just dflag + _ -> Nothing dumpIfSet :: Bool -> CoreToDo -> SDoc -> SDoc -> IO () dumpIfSet dump_me pass extra_info doc = Err.dumpIfSet dump_me (showSDoc (ppr pass <+> extra_info)) doc -dumpAndLint :: DynFlags -> Bool -> CoreToDo -> SDoc -> Maybe DynFlag - -> [CoreBind] -> [CoreRule] -> IO () --- The "show_all" parameter says to print dump if -dverbose-core2core is on -dumpAndLint dflags show_all pass extra_info mb_dump_flag binds rules - = do { -- Report result size if required +dumpPassResult :: DynFlags + -> Maybe DynFlag -- Just df => show details in a file whose + -- name is specified by df + -> SDoc -- Header + -> SDoc -- Extra info to appear after header + -> [CoreBind] -> [CoreRule] + -> IO () +dumpPassResult dflags mb_flag hdr extra_info binds rules + | Just dflag <- mb_flag + = Err.dumpSDoc dflags dflag (showSDoc hdr) dump_doc + + | otherwise + = Err.debugTraceMsg dflags 2 $ + (text "Result size of" <+> hdr <+> equals <+> int (coreBindsSize binds)) + -- Report result size -- This has the side effect of forcing the intermediate to be evaluated - ; Err.debugTraceMsg dflags 2 $ - (text " Result size =" <+> int (coreBindsSize binds)) - -- Report verbosely, if required - ; let pass_name = showSDoc (ppr pass <+> extra_info) - dump_doc = pprCoreBindings binds - $$ ppUnless (null rules) pp_rules - - ; case mb_dump_flag of - Nothing -> return () - Just dump_flag -> Err.dumpIfSet_dyn_or dflags dump_flags pass_name dump_doc - where - dump_flags | show_all = [dump_flag, Opt_D_verbose_core2core] - | otherwise = [dump_flag] - - -- Type check - ; when (dopt Opt_DoCoreLinting dflags) $ - do { let (warns, errs) = lintCoreBindings binds - ; Err.showPass dflags ("Core Linted result of " ++ pass_name) - ; displayLintResults dflags pass warns errs binds } } where + dump_doc = vcat [ text "Result size =" <+> int (coreBindsSize binds) + , extra_info + , blankLine + , pprCoreBindings binds + , ppUnless (null rules) pp_rules ] pp_rules = vcat [ blankLine , ptext (sLit "------ Local rules for imported ids --------") , pprRules rules ] +lintPassResult :: DynFlags -> CoreToDo -> [CoreBind] -> IO () +lintPassResult dflags pass binds + = when (dopt Opt_DoCoreLinting dflags) $ + do { let (warns, errs) = lintCoreBindings binds + ; Err.showPass dflags ("Core Linted result of " ++ showSDoc (ppr pass)) + ; displayLintResults dflags pass warns errs binds } + displayLintResults :: DynFlags -> CoreToDo -> Bag Err.Message -> Bag Err.Message -> [CoreBind] -> IO () @@ -197,6 +219,7 @@ %************************************************************************ \begin{code} + data CoreToDo -- These are diff core-to-core passes, -- which may be invoked in any order, -- as many times as you like. @@ -204,7 +227,7 @@ = CoreDoSimplify -- The core-to-core simplifier. Int -- Max iterations SimplifierMode - + | CoreDoPluginPass String PluginPass | CoreDoFloatInwards | CoreDoFloatOutwards FloatOutSwitches | CoreLiberateCase @@ -218,7 +241,7 @@ | CoreCSE | CoreDoRuleCheck CompilerPhase String -- Check for non-application of rules -- matching this string - | CoreDoVectorisation PackageId + | CoreDoVectorisation | CoreDoNothing -- Useful when building up | CoreDoPasses [CoreToDo] -- lists of these things @@ -228,8 +251,12 @@ | CoreTidy | CorePrep +\end{code} + +\begin{code} coreDumpFlag :: CoreToDo -> Maybe DynFlag coreDumpFlag (CoreDoSimplify {}) = Just Opt_D_dump_simpl_phases +coreDumpFlag (CoreDoPluginPass {}) = Just Opt_D_dump_core_pipeline coreDumpFlag CoreDoFloatInwards = Just Opt_D_verbose_core2core coreDumpFlag (CoreDoFloatOutwards {}) = Just Opt_D_verbose_core2core coreDumpFlag CoreLiberateCase = Just Opt_D_verbose_core2core @@ -239,10 +266,10 @@ coreDumpFlag CoreDoSpecialising = Just Opt_D_dump_spec coreDumpFlag CoreDoSpecConstr = Just Opt_D_dump_spec coreDumpFlag CoreCSE = Just Opt_D_dump_cse -coreDumpFlag (CoreDoVectorisation {}) = Just Opt_D_dump_vect -coreDumpFlag CoreDesugar = Just Opt_D_dump_ds -coreDumpFlag CoreTidy = Just Opt_D_dump_simpl -coreDumpFlag CorePrep = Just Opt_D_dump_prep +coreDumpFlag CoreDoVectorisation = Just Opt_D_dump_vect +coreDumpFlag CoreDesugar = Just Opt_D_dump_ds +coreDumpFlag CoreTidy = Just Opt_D_dump_simpl +coreDumpFlag CorePrep = Just Opt_D_dump_prep coreDumpFlag CoreDoPrintCore = Nothing coreDumpFlag (CoreDoRuleCheck {}) = Nothing @@ -251,9 +278,8 @@ coreDumpFlag (CoreDoPasses {}) = Nothing instance Outputable CoreToDo where - ppr (CoreDoSimplify n md) = ptext (sLit "Simplifier") - <+> ppr md - <+> ptext (sLit "max-iterations=") <> int n + ppr (CoreDoSimplify _ _) = ptext (sLit "Simplifier") + ppr (CoreDoPluginPass s _) = ptext (sLit "Core plugin: ") <+> text s ppr CoreDoFloatInwards = ptext (sLit "Float inwards") ppr (CoreDoFloatOutwards f) = ptext (sLit "Float out") <> parens (ppr f) ppr CoreLiberateCase = ptext (sLit "Liberate case") @@ -263,15 +289,19 @@ ppr CoreDoSpecialising = ptext (sLit "Specialise") ppr CoreDoSpecConstr = ptext (sLit "SpecConstr") ppr CoreCSE = ptext (sLit "Common sub-expression") - ppr (CoreDoVectorisation {}) = ptext (sLit "Vectorisation") - ppr CoreDesugar = ptext (sLit "Desugar") - ppr CoreTidy = ptext (sLit "Tidy Core") + ppr CoreDoVectorisation = ptext (sLit "Vectorisation") + ppr CoreDesugar = ptext (sLit "Desugar") + ppr CoreTidy = ptext (sLit "Tidy Core") ppr CorePrep = ptext (sLit "CorePrep") ppr CoreDoPrintCore = ptext (sLit "Print core") ppr (CoreDoRuleCheck {}) = ptext (sLit "Rule check") ppr CoreDoGlomBinds = ptext (sLit "Glom binds") ppr CoreDoNothing = ptext (sLit "CoreDoNothing") ppr (CoreDoPasses {}) = ptext (sLit "CoreDoPasses") + +pprPassDetails :: CoreToDo -> SDoc +pprPassDetails (CoreDoSimplify n md) = ppr md <+> ptext (sLit "max-iterations=") <> int n +pprPassDetails _ = empty \end{code} \begin{code} @@ -326,193 +356,17 @@ [ ptext (sLit "Lam =") <+> ppr (floatOutLambdas sw) , ptext (sLit "Consts =") <+> ppr (floatOutConstants sw) , ptext (sLit "PAPs =") <+> ppr (floatOutPartialApplications sw) ]) -\end{code} - - -%************************************************************************ -%* * - Generating the main optimisation pipeline -%* * -%************************************************************************ -\begin{code} -getCoreToDo :: DynFlags -> [CoreToDo] -getCoreToDo dflags - = core_todo - where - opt_level = optLevel dflags - phases = simplPhases dflags - max_iter = maxSimplIterations dflags - rule_check = ruleCheck dflags - strictness = dopt Opt_Strictness dflags - full_laziness = dopt Opt_FullLaziness dflags - do_specialise = dopt Opt_Specialise dflags - do_float_in = dopt Opt_FloatIn dflags - cse = dopt Opt_CSE dflags - spec_constr = dopt Opt_SpecConstr dflags - liberate_case = dopt Opt_LiberateCase dflags - static_args = dopt Opt_StaticArgumentTransformation dflags - rules_on = dopt Opt_EnableRewriteRules dflags - eta_expand_on = dopt Opt_DoLambdaEtaExpansion dflags - - maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase) - - maybe_strictness_before phase - = runWhen (phase `elem` strictnessBefore dflags) CoreDoStrictness - - base_mode = SimplMode { sm_phase = panic "base_mode" - , sm_names = [] - , sm_rules = rules_on - , sm_eta_expand = eta_expand_on - , sm_inline = True - , sm_case_case = True } - - simpl_phase phase names iter - = CoreDoPasses - [ maybe_strictness_before phase - , CoreDoSimplify iter - (base_mode { sm_phase = Phase phase - , sm_names = names }) - - , maybe_rule_check (Phase phase) - ] - - vectorisation - = runWhen (dopt Opt_Vectorise dflags) - $ CoreDoPasses [ simpl_gently, CoreDoVectorisation (dphPackage dflags) ] - - - -- By default, we have 2 phases before phase 0. - - -- Want to run with inline phase 2 after the specialiser to give - -- maximum chance for fusion to work before we inline build/augment - -- in phase 1. This made a difference in 'ansi' where an - -- overloaded function wasn't inlined till too late. - - -- Need phase 1 so that build/augment get - -- inlined. I found that spectral/hartel/genfft lost some useful - -- strictness in the function sumcode' if augment is not inlined - -- before strictness analysis runs - simpl_phases = CoreDoPasses [ simpl_phase phase ["main"] max_iter - | phase <- [phases, phases-1 .. 1] ] - - - -- initial simplify: mk specialiser happy: minimum effort please - simpl_gently = CoreDoSimplify max_iter - (base_mode { sm_phase = InitialPhase +-- | A reasonably gentle simplification pass for doing "obvious" simplifications +defaultGentleSimplToDo :: CoreToDo +defaultGentleSimplToDo = CoreDoSimplify 4 -- 4 is the default maxSimpleIterations + (SimplMode { sm_phase = InitialPhase , sm_names = ["Gentle"] , sm_rules = True -- Note [RULEs enabled in SimplGently] , sm_inline = False - , sm_case_case = False }) - -- Don't do case-of-case transformations. - -- This makes full laziness work better - - core_todo = - if opt_level == 0 then - [vectorisation, - simpl_phase 0 ["final"] max_iter] - else {- opt_level >= 1 -} [ - - -- We want to do the static argument transform before full laziness as it - -- may expose extra opportunities to float things outwards. However, to fix - -- up the output of the transformation we need at do at least one simplify - -- after this before anything else - runWhen static_args (CoreDoPasses [ simpl_gently, CoreDoStaticArgs ]), - - -- We run vectorisation here for now, but we might also try to run - -- it later - vectorisation, - - -- initial simplify: mk specialiser happy: minimum effort please - simpl_gently, - - -- Specialisation is best done before full laziness - -- so that overloaded functions have all their dictionary lambdas manifest - runWhen do_specialise CoreDoSpecialising, - - runWhen full_laziness $ - CoreDoFloatOutwards FloatOutSwitches { - floatOutLambdas = Just 0, - floatOutConstants = True, - floatOutPartialApplications = False }, - -- Was: gentleFloatOutSwitches - -- - -- I have no idea why, but not floating constants to - -- top level is very bad in some cases. - -- - -- Notably: p_ident in spectral/rewrite - -- Changing from "gentle" to "constantsOnly" - -- improved rewrite's allocation by 19%, and - -- made 0.0% difference to any other nofib - -- benchmark - -- - -- Not doing floatOutPartialApplications yet, we'll do - -- that later on when we've had a chance to get more - -- accurate arity information. In fact it makes no - -- difference at all to performance if we do it here, - -- but maybe we save some unnecessary to-and-fro in - -- the simplifier. - - runWhen do_float_in CoreDoFloatInwards, - - simpl_phases, - - -- Phase 0: allow all Ids to be inlined now - -- This gets foldr inlined before strictness analysis - - -- At least 3 iterations because otherwise we land up with - -- huge dead expressions because of an infelicity in the - -- simpifier. - -- let k = BIG in foldr k z xs - -- ==> let k = BIG in letrec go = \xs -> ...(k x).... in go xs - -- ==> let k = BIG in letrec go = \xs -> ...(BIG x).... in go xs - -- Don't stop now! - simpl_phase 0 ["main"] (max max_iter 3), - - runWhen strictness (CoreDoPasses [ - CoreDoStrictness, - CoreDoWorkerWrapper, - CoreDoGlomBinds, - simpl_phase 0 ["post-worker-wrapper"] max_iter - ]), - - runWhen full_laziness $ - CoreDoFloatOutwards FloatOutSwitches { - floatOutLambdas = floatLamArgs dflags, - floatOutConstants = True, - floatOutPartialApplications = True }, - -- nofib/spectral/hartel/wang doubles in speed if you - -- do full laziness late in the day. It only happens - -- after fusion and other stuff, so the early pass doesn't - -- catch it. For the record, the redex is - -- f_el22 (f_el21 r_midblock) - - - runWhen cse CoreCSE, - -- We want CSE to follow the final full-laziness pass, because it may - -- succeed in commoning up things floated out by full laziness. - -- CSE used to rely on the no-shadowing invariant, but it doesn't any more - - runWhen do_float_in CoreDoFloatInwards, - - maybe_rule_check (Phase 0), - - -- Case-liberation for -O2. This should be after - -- strictness analysis and the simplification which follows it. - runWhen liberate_case (CoreDoPasses [ - CoreLiberateCase, - simpl_phase 0 ["post-liberate-case"] max_iter - ]), -- Run the simplifier after LiberateCase to vastly - -- reduce the possiblility of shadowing - -- Reason: see Note [Shadowing] in SpecConstr.lhs - - runWhen spec_constr CoreDoSpecConstr, - - maybe_rule_check (Phase 0), - - -- Final clean-up simplification: - simpl_phase 0 ["final"] max_iter - ] + , sm_eta_expand = False + , sm_case_case = False + }) -- The core-to-core pass ordering is derived from the DynFlags: runWhen :: Bool -> CoreToDo -> CoreToDo @@ -523,6 +377,7 @@ runMaybe (Just x) f = f x runMaybe Nothing _ = CoreDoNothing + dumpSimplPhase :: DynFlags -> SimplifierMode -> Bool dumpSimplPhase dflags mode | Just spec_string <- shouldDumpSimplPhase dflags @@ -568,8 +423,46 @@ But watch out: list fusion can prevent floating. So use phase control to switch off those rules until after floating. -Currently (Oct10) I think that sm_rules is always True, so we -could remove it. + +%************************************************************************ +%* * + Types for Plugins +%* * +%************************************************************************ + +\begin{code} +-- | Command line options gathered from the -PModule.Name:stuff syntax are given to you as this type +type CommandLineOption = String + +-- | 'Plugin' is the core compiler plugin data type. Try to avoid +-- constructing one of these directly, and just modify some fields of +-- 'defaultPlugin' instead: this is to try and preserve source-code +-- compatability when we add fields to this. +-- +-- Nonetheless, this API is preliminary and highly likely to change in the future. +data Plugin = Plugin { + installCoreToDos :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] + -- ^ Modify the Core pipeline that will be used for compilation. + -- This is called as the Core pipeline is built for every module + -- being compiled, and plugins get the opportunity to modify + -- the pipeline in a nondeterministic order. + } + +-- | Default plugin: does nothing at all! For compatability reasons you should base all your +-- plugin definitions on this default value. +defaultPlugin :: Plugin +defaultPlugin = Plugin { + installCoreToDos = const return + } + +-- | A description of the plugin pass itself +type PluginPass = ModGuts -> CoreM ModGuts + +bindsOnlyPass :: ([CoreBind] -> CoreM [CoreBind]) -> ModGuts -> CoreM ModGuts +bindsOnlyPass pass guts + = do { binds' <- pass (mg_binds guts) + ; return (guts { mg_binds = binds' }) } +\end{code} %************************************************************************ @@ -822,7 +715,13 @@ data CoreReader = CoreReader { cr_hsc_env :: HscEnv, cr_rule_base :: RuleBase, - cr_module :: Module + cr_module :: Module, + cr_globals :: ((Bool, [String], [Way]), +#ifdef GHCI + (MVar PersistentLinkerState, Bool)) +#else + ()) +#endif } data CoreWriter = CoreWriter { @@ -880,13 +779,15 @@ -> Module -> CoreM a -> IO (a, SimplCount) -runCoreM hsc_env rule_base us mod m = - liftM extract $ runIOEnv reader $ unCoreM m state +runCoreM hsc_env rule_base us mod m = do + glbls <- liftM2 (,) saveStaticFlagGlobals saveLinkerGlobals + liftM extract $ runIOEnv (reader glbls) $ unCoreM m state where - reader = CoreReader { + reader glbls = CoreReader { cr_hsc_env = hsc_env, cr_rule_base = rule_base, - cr_module = mod + cr_module = mod, + cr_globals = glbls } state = CoreState { cs_uniq_supply = us @@ -950,7 +851,6 @@ %************************************************************************ \begin{code} - getHscEnv :: CoreM HscEnv getHscEnv = read cr_hsc_env @@ -974,9 +874,51 @@ getOrigNameCache = do nameCacheRef <- fmap hsc_NC getHscEnv liftIO $ fmap nsNames $ readIORef nameCacheRef - \end{code} +%************************************************************************ +%* * + Initializing globals +%* * +%************************************************************************ + +This is a rather annoying function. When a plugin is loaded, it currently +gets linked against a *newly loaded* copy of the GHC package. This would +not be a problem, except that the new copy has its own mutable state +that is not shared with that state that has already been initialized by +the original GHC package. + +This leads to loaded plugins calling GHC code which pokes the static flags, +and then dying with a panic because the static flags *it* sees are uninitialized. + +There are two possible solutions: + 1. Export the symbols from the GHC executable from the GHC library and link + against this existing copy rather than a new copy of the GHC library + 2. Carefully ensure that the global state in the two copies of the GHC + library matches + +I tried 1. and it *almost* works (and speeds up plugin load times!) except +on Windows. On Windows the GHC library tends to export more than 65536 symbols +(see #5292) which overflows the limit of what we can export from the EXE and +causes breakage. + +(Note that if the GHC exeecutable was dynamically linked this wouldn't be a problem, +because we could share the GHC library it links to.) + +We are going to try 2. instead. Unfortunately, this means that every plugin +will have to say `reinitializeGlobals` before it does anything, but never mind. + +I've threaded the cr_globals through CoreM rather than giving them as an +argument to the plugin function so that we can turn this function into +(return ()) without breaking any plugins when we eventually get 1. working. + +\begin{code} +reinitializeGlobals :: CoreM () +reinitializeGlobals = do + (sf_globals, linker_globals) <- read cr_globals + liftIO $ restoreStaticFlagGlobals sf_globals + liftIO $ restoreLinkerGlobals linker_globals +\end{code} %************************************************************************ %* * diff -Nru ghc-7.0.3/compiler/simplCore/CSE.lhs ghc-7.2.1/compiler/simplCore/CSE.lhs --- ghc-7.0.3/compiler/simplCore/CSE.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/simplCore/CSE.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -10,12 +10,13 @@ #include "HsVersions.h" +import CoreSubst +import Var ( Var ) import Id ( Id, idType, idInlineActivation, zapIdOccInfo ) import CoreUtils ( hashExpr, eqExpr, exprIsBig, mkAltExpr, exprIsCheap ) import DataCon ( isUnboxedTupleCon ) import Type ( tyConAppArgs ) import CoreSyn -import VarEnv import Outputable import StaticFlags ( opt_PprStyle_Debug ) import BasicTypes ( isAlwaysActive ) @@ -61,12 +62,6 @@ shadowing, but it doesn't any more (it proved too hard), so we clone as we go. We can simply add clones to the substitution already described. -However, we do NOT clone type variables. It's just too hard, because then we need -to run the substitution over types and IdInfo. No no no. Instead, we just throw - -(In fact, I think the simplifier does guarantee no-shadowing for type variables.) - - Note [Case binders 1] ~~~~~~~~~~~~~~~~~~~~~~ Consider @@ -187,36 +182,43 @@ bs' = cseBinds env1 bs cseBind :: CSEnv -> CoreBind -> (CSEnv, CoreBind) -cseBind env (NonRec b e) = let (env', (b',e')) = do_one env (b, e) - in (env', NonRec b' e') -cseBind env (Rec pairs) = let (env', pairs') = mapAccumL do_one env pairs - in (env', Rec pairs') - +cseBind env (NonRec b e) + = (env2, NonRec b' e') + where + (env1, b') = addBinder env b + (env2, e') = cseRhs env1 (b',e) -do_one :: CSEnv -> (Id, CoreExpr) -> (CSEnv, (Id, CoreExpr)) -do_one env (id, rhs) +cseBind env (Rec pairs) + = (env2, Rec (bs' `zip` es')) + where + (bs,es) = unzip pairs + (env1, bs') = addRecBinders env bs + (env2, es') = mapAccumL cseRhs env1 (bs' `zip` es) + +cseRhs :: CSEnv -> (OutBndr, InExpr) -> (CSEnv, OutExpr) +cseRhs env (id',rhs) = case lookupCSEnv env rhs' of - Just (Var other_id) -> (extendSubst env' id other_id, (id', Var other_id)) - Just other_expr -> (env', (id', other_expr)) - Nothing -> (addCSEnvItem env' rhs' (Var id'), (id', rhs')) + Just other_expr -> (env, other_expr) + Nothing -> (addCSEnvItem env rhs' (Var id'), rhs') where - (env', id') = addBinder env id - rhs' | isAlwaysActive (idInlineActivation id) = cseExpr env' rhs - | otherwise = rhs + rhs' | isAlwaysActive (idInlineActivation id') = cseExpr env rhs + | otherwise = rhs -- See Note [CSE for INLINE and NOINLINE] -tryForCSE :: CSEnv -> CoreExpr -> CoreExpr +tryForCSE :: CSEnv -> InExpr -> OutExpr tryForCSE _ (Type t) = Type t +tryForCSE _ (Coercion c) = Coercion c tryForCSE env expr = case lookupCSEnv env expr' of Just smaller_expr -> smaller_expr Nothing -> expr' where expr' = cseExpr env expr -cseExpr :: CSEnv -> CoreExpr -> CoreExpr +cseExpr :: CSEnv -> InExpr -> OutExpr cseExpr _ (Type t) = Type t +cseExpr _ (Coercion co) = Coercion co cseExpr _ (Lit lit) = Lit lit -cseExpr env (Var v) = Var (lookupSubst env v) +cseExpr env (Var v) = lookupSubst env v cseExpr env (App f a) = App (cseExpr env f) (tryForCSE env a) cseExpr env (Note n e) = Note n (cseExpr env e) cseExpr env (Cast e co) = Cast (cseExpr env e) co @@ -224,8 +226,9 @@ in Lam b' (cseExpr env' e) cseExpr env (Let bind e) = let (env', bind') = cseBind env bind in Let bind' (cseExpr env' e) -cseExpr env (Case scrut bndr ty alts) = Case scrut' bndr'' ty (cseAlts env' scrut' bndr bndr'' alts) +cseExpr env (Case scrut bndr ty alts) = Case scrut' bndr'' ty alts' where + alts' = cseAlts env' scrut' bndr bndr'' alts scrut' = tryForCSE env scrut (env', bndr') = addBinder env bndr bndr'' = zapIdOccInfo bndr' @@ -233,7 +236,7 @@ -- cause a dead case binder to be alive, so we -- play safe here and bring them all to life -cseAlts :: CSEnv -> CoreExpr -> CoreBndr -> CoreBndr -> [CoreAlt] -> [CoreAlt] +cseAlts :: CSEnv -> OutExpr -> InBndr -> InBndr -> [InAlt] -> [OutAlt] cseAlts env scrut' bndr _bndr' [(DataAlt con, args, rhs)] | isUnboxedTupleCon con @@ -254,11 +257,11 @@ where (con_target, alt_env) = case scrut' of - Var v' -> (v', extendSubst env bndr v') -- See Note [Case binders 1] + Var v' -> (v', extendCSSubst env bndr v') -- See Note [Case binders 1] -- map: bndr -> v' - _ -> (bndr', extendCSEnv env scrut' (Var bndr')) -- See Note [Case binders 2] - -- map: scrut' -> bndr' + _ -> (bndr', extendCSEnv env scrut' (Var bndr')) -- See Note [Case binders 2] + -- map: scrut' -> bndr' arg_tys = tyConAppArgs (idType bndr) @@ -289,19 +292,25 @@ %************************************************************************ \begin{code} -data CSEnv = CS CSEMap InScopeSet (IdEnv Id) - -- Simple substitution +type InExpr = CoreExpr -- Pre-cloning +type InBndr = CoreBndr +type InAlt = CoreAlt + +type OutExpr = CoreExpr -- Post-cloning +type OutBndr = CoreBndr +type OutAlt = CoreAlt -type CSEMap = UniqFM [(CoreExpr, CoreExpr)] -- This is the reverse mapping +data CSEnv = CS CSEMap Subst +type CSEMap = UniqFM [(OutExpr, OutExpr)] -- This is the reverse mapping -- It maps the hash-code of an expression e to list of (e,e') pairs -- This means that it's good to replace e by e' -- INVARIANT: The expr in the range has already been CSE'd emptyCSEnv :: CSEnv -emptyCSEnv = CS emptyUFM emptyInScopeSet emptyVarEnv +emptyCSEnv = CS emptyUFM emptySubst -lookupCSEnv :: CSEnv -> CoreExpr -> Maybe CoreExpr -lookupCSEnv (CS cs in_scope _) expr +lookupCSEnv :: CSEnv -> OutExpr -> Maybe OutExpr +lookupCSEnv (CS cs sub) expr = case lookupUFM cs (hashExpr expr) of Nothing -> Nothing Just pairs -> lookup_list pairs @@ -310,20 +319,21 @@ -- Reason: when expressions differ we generally find out quickly -- but I found that cheapEqExpr was saying (\x.x) /= (\y.y), -- and this kind of thing happened in real programs - lookup_list :: [(CoreExpr,CoreExpr)] -> Maybe CoreExpr - lookup_list [] = Nothing - lookup_list ((e,e'):es) | eqExpr in_scope e expr = Just e' - | otherwise = lookup_list es + lookup_list :: [(OutExpr,OutExpr)] -> Maybe OutExpr + lookup_list ((e,e'):es) + | eqExpr (substInScope sub) e expr = Just e' + | otherwise = lookup_list es + lookup_list [] = Nothing -addCSEnvItem :: CSEnv -> CoreExpr -> CoreExpr -> CSEnv +addCSEnvItem :: CSEnv -> OutExpr -> OutExpr -> CSEnv addCSEnvItem env expr expr' | exprIsBig expr = env | otherwise = extendCSEnv env expr expr' -- We don't try to CSE big expressions, because they are expensive to compare -- (and are unlikely to be the same anyway) -extendCSEnv :: CSEnv -> CoreExpr -> CoreExpr -> CSEnv -extendCSEnv (CS cs in_scope sub) expr expr' - = CS (addToUFM_C combine cs hash [(expr, expr')]) in_scope sub +extendCSEnv :: CSEnv -> OutExpr -> OutExpr -> CSEnv +extendCSEnv (CS cs sub) expr expr' + = CS (addToUFM_C combine cs hash [(expr, expr')]) sub where hash = hashExpr expr combine old new @@ -334,26 +344,24 @@ long_msg | opt_PprStyle_Debug = (text "hash code" <+> text (show hash)) $$ ppr result | otherwise = empty -lookupSubst :: CSEnv -> Id -> Id -lookupSubst (CS _ _ sub) x = case lookupVarEnv sub x of - Just y -> y - Nothing -> x - -extendSubst :: CSEnv -> Id -> Id -> CSEnv -extendSubst (CS cs in_scope sub) x y = CS cs in_scope (extendVarEnv sub x y) - -addBinder :: CSEnv -> Id -> (CSEnv, Id) -addBinder (CS cs in_scope sub) v - | not (v `elemInScopeSet` in_scope) = (CS cs (extendInScopeSet in_scope v) sub, v) - | isId v = (CS cs (extendInScopeSet in_scope v') (extendVarEnv sub v v'), v') - | otherwise = WARN( True, ppr v ) - (CS emptyUFM in_scope sub, v) - -- This last case is the unusual situation where we have shadowing of - -- a type variable; we have to discard the CSE mapping - -- See Note [Shadowing] - where - v' = uniqAway in_scope v +lookupSubst :: CSEnv -> Id -> OutExpr +lookupSubst (CS _ sub) x = lookupIdSubst (text "CSE.lookupSubst") sub x + +extendCSSubst :: CSEnv -> Id -> Id -> CSEnv +extendCSSubst (CS cs sub) x y = CS cs (extendIdSubst sub x (Var y)) -addBinders :: CSEnv -> [Id] -> (CSEnv, [Id]) -addBinders env vs = mapAccumL addBinder env vs +addBinder :: CSEnv -> Var -> (CSEnv, Var) +addBinder (CS cs sub) v = (CS cs sub', v') + where + (sub', v') = substBndr sub v + +addBinders :: CSEnv -> [Var] -> (CSEnv, [Var]) +addBinders (CS cs sub) vs = (CS cs sub', vs') + where + (sub', vs') = substBndrs sub vs + +addRecBinders :: CSEnv -> [Id] -> (CSEnv, [Id]) +addRecBinders (CS cs sub) vs = (CS cs sub', vs') + where + (sub', vs') = substRecBndrs sub vs \end{code} diff -Nru ghc-7.0.3/compiler/simplCore/FloatIn.lhs ghc-7.2.1/compiler/simplCore/FloatIn.lhs --- ghc-7.0.3/compiler/simplCore/FloatIn.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/simplCore/FloatIn.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -126,14 +126,15 @@ -> CoreExprWithFVs -- Input expr -> CoreExpr -- Result -fiExpr to_drop (_, AnnVar v) = mkCoLets' to_drop (Var v) - -fiExpr to_drop (_, AnnType ty) = ASSERT( null to_drop ) - Type ty -fiExpr to_drop (_, AnnCast expr co) - = Cast (fiExpr to_drop expr) co -- Just float in past coercion - -fiExpr _ (_, AnnLit lit) = Lit lit +fiExpr to_drop (_, AnnLit lit) = ASSERT( null to_drop ) Lit lit +fiExpr to_drop (_, AnnType ty) = ASSERT( null to_drop ) Type ty +fiExpr to_drop (_, AnnVar v) = mkCoLets' to_drop (Var v) +fiExpr to_drop (_, AnnCoercion co) = mkCoLets' to_drop (Coercion co) +fiExpr to_drop (_, AnnCast expr (fvs_co, co)) + = mkCoLets' (drop_here ++ co_drop) $ + Cast (fiExpr e_drop expr) co + where + [drop_here, e_drop, co_drop] = sepBindsByDropPoint False [freeVarsOf expr, fvs_co] to_drop \end{code} Applications: we do float inside applications, mainly because we @@ -198,7 +199,7 @@ go seen_one_shot_id [] = seen_one_shot_id go seen_one_shot_id (b:bs) - | isTyCoVar b = go seen_one_shot_id bs + | isTyVar b = go seen_one_shot_id bs | isOneShotBndr b = go True bs | otherwise = False -- Give up at a non-one-shot Id \end{code} diff -Nru ghc-7.0.3/compiler/simplCore/FloatOut.lhs ghc-7.2.1/compiler/simplCore/FloatOut.lhs --- ghc-7.0.3/compiler/simplCore/FloatOut.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/simplCore/FloatOut.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -16,17 +16,19 @@ import DynFlags ( DynFlags, DynFlag(..) ) import ErrUtils ( dumpIfSet_dyn ) import CostCentre ( dupifyCC, CostCentre ) -import Id ( Id, idType, idArity, isBottomingId ) -import Type ( isUnLiftedType ) -import SetLevels ( Level(..), LevelledExpr, LevelledBind, - setLevels, isTopLvl ) +import DataCon ( DataCon ) +import Id ( Id, idArity, isBottomingId ) +import Var ( Var ) +import SetLevels import UniqSupply ( UniqSupply ) import Bag import Util import Maybes -import UniqFM import Outputable import FastString +import qualified Data.IntMap as M + +#include "HsVersions.h" \end{code} ----------------- @@ -130,13 +132,16 @@ int ntlets, ptext (sLit " Lets floated elsewhere; from "), int lams, ptext (sLit " Lambda groups")]); - return (concat binds_s') + return (bagToList (unionManyBags binds_s')) } -floatTopBind :: LevelledBind -> (FloatStats, [CoreBind]) +floatTopBind :: LevelledBind -> (FloatStats, Bag CoreBind) floatTopBind bind - = case (floatBind bind) of { (fs, floats) -> - (fs, bagToList (flattenFloats floats)) } + = case (floatBind bind) of { (fs, floats, bind') -> + let float_bag = flattenTopFloats floats + in case bind' of + Rec prs -> (fs, unitBag (Rec (addTopFloatPairs float_bag prs))) + NonRec {} -> (fs, float_bag `snocBag` bind') } \end{code} %************************************************************************ @@ -146,45 +151,52 @@ %************************************************************************ \begin{code} -floatBind :: LevelledBind -> (FloatStats, FloatBinds) -floatBind (NonRec (TB var level) rhs) - = case (floatRhs level rhs) of { (fs, rhs_floats, rhs') -> +floatBind :: LevelledBind -> (FloatStats, FloatBinds, CoreBind) +floatBind (NonRec (TB var _) rhs) + = case (floatExpr rhs) of { (fs, rhs_floats, rhs') -> -- A tiresome hack: -- see Note [Bottoming floats: eta expansion] in SetLevels let rhs'' | isBottomingId var = etaExpand (idArity var) rhs' | otherwise = rhs' - in (fs, rhs_floats `plusFloats` unitFloat level (NonRec var rhs'')) } + in (fs, rhs_floats, NonRec var rhs'') } floatBind (Rec pairs) = case floatList do_pair pairs of { (fs, rhs_floats, new_pairs) -> - -- NB: the rhs floats may contain references to the - -- bound things. For example - -- f = ...(let v = ...f... in b) ... - if not (isTopLvl dest_lvl) then - -- Find which bindings float out at least one lambda beyond this one - -- These ones can't mention the binders, because they couldn't - -- be escaping a major level if so. - -- The ones that are not going further can join the letrec; - -- they may not be mutually recursive but the occurrence analyser will - -- find that out. In our example we make a Rec thus: - -- v = ...f... - -- f = ... b ... - case (partitionByMajorLevel dest_lvl rhs_floats) of { (floats', heres) -> - (fs, floats' `plusFloats` unitFloat dest_lvl - (Rec (floatsToBindPairs heres new_pairs))) } - else - -- For top level, no need to partition; just make them all recursive - -- (And the partition wouldn't work because they'd all end up in floats') - (fs, unitFloat dest_lvl - (Rec (floatsToBindPairs (flattenFloats rhs_floats) new_pairs))) } - where - (((TB _ dest_lvl), _) : _) = pairs - - do_pair (TB name level, rhs) - = case (floatRhs level rhs) of { (fs, rhs_floats, rhs') -> - (fs, rhs_floats, (name, rhs')) } + (fs, rhs_floats, Rec (concat new_pairs)) } + where + do_pair (TB name spec, rhs) + | isTopLvl dest_lvl -- See Note [floatBind for top level] + = case (floatExpr rhs) of { (fs, rhs_floats, rhs') -> + (fs, emptyFloats, addTopFloatPairs (flattenTopFloats rhs_floats) [(name, rhs')])} + | otherwise -- Note [Floating out of Rec rhss] + = case (floatExpr rhs) of { (fs, rhs_floats, rhs') -> + case (partitionByLevel dest_lvl rhs_floats) of { (rhs_floats', heres) -> + case (splitRecFloats heres) of { (pairs, case_heres) -> + (fs, rhs_floats', (name, installUnderLambdas case_heres rhs') : pairs) }}} + where + dest_lvl = floatSpecLevel spec + +splitRecFloats :: Bag FloatBind -> ([(Id,CoreExpr)], Bag FloatBind) +-- The "tail" begins with a case +-- See Note [Floating out of Rec rhss] +splitRecFloats fs + = go [] (bagToList fs) + where + go prs (FloatLet (NonRec b r) : fs) = go ((b,r):prs) fs + go prs (FloatLet (Rec prs') : fs) = go (prs' ++ prs) fs + go prs fs = (prs, listToBag fs) + +installUnderLambdas :: Bag FloatBind -> CoreExpr -> CoreExpr +-- Note [Floating out of Rec rhss] +installUnderLambdas floats e + | isEmptyBag floats = e + | otherwise = go e + where + go (Lam b e) = Lam b (go e) + go (Note n e) | notSccNote n = Note n (go e) + go e = install floats e --------------- floatList :: (a -> (FloatStats, FloatBinds, b)) -> [a] -> (FloatStats, FloatBinds, [b]) @@ -194,6 +206,37 @@ (fs_a `add_stats` fs_as, binds_a `plusFloats` binds_as, b:bs) }} \end{code} +Note [Floating out of Rec rhss] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider Rec { f<1,0> = \xy. body } +From the body we may get some floats. The ones with level <1,0> must +stay here, since they may mention f. Ideally we'd like to make them +part of the Rec block pairs -- but we can't if there are any +FloatCases involved. + +Nor is it a good idea to dump them in the rhs, but outside the lambda + f = case x of I# y -> \xy. body +because now f's arity might get worse, which is Not Good. (And if +there's an SCC around the RHS it might not get better again. +See Trac #5342.) + +So, gruesomely, we split the floats into + * the outer FloatLets, which can join the Rec, and + * an inner batch starting in a FloatCase, which are then + pushed *inside* the lambdas. +This loses full-laziness the rare situation where there is a +FloatCase and a Rec interacting. + +Note [floatBind for top level] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We may have a *nested* binding whose destination level is (FloatMe tOP_LEVEL), thus + letrec { foo <0,0> = .... (let bar<0,0> = .. in ..) .... } +The binding for bar will be in the "tops" part of the floating binds, +and thus not partioned by floatBody. + +We could perhaps get rid of the 'tops' component of the floating binds, +but this case works just as well. + %************************************************************************ @@ -202,100 +245,100 @@ %************************************************************************ \begin{code} -floatExpr, floatRhs, floatCaseAlt - :: Level - -> LevelledExpr - -> (FloatStats, FloatBinds, CoreExpr) - -floatCaseAlt lvl arg -- Used rec rhss, and case-alternative rhss - = case (floatExpr lvl arg) of { (fsa, floats, arg') -> - case (partitionByMajorLevel lvl floats) of { (floats', heres) -> - -- Dump bindings that aren't going to escape from a lambda; - -- in particular, we must dump the ones that are bound by - -- the rec or case alternative +floatBody :: Level + -> LevelledExpr + -> (FloatStats, FloatBinds, CoreExpr) + +floatBody lvl arg -- Used rec rhss, and case-alternative rhss + = case (floatExpr arg) of { (fsa, floats, arg') -> + case (partitionByLevel lvl floats) of { (floats', heres) -> + -- Dump bindings are bound here (fsa, floats', install heres arg') }} ----------------- -floatRhs lvl arg -- Used for nested non-rec rhss, and fn args - -- See Note [Floating out of RHS] - = floatExpr lvl arg - ------------------ -floatExpr _ (Var v) = (zeroStats, emptyFloats, Var v) -floatExpr _ (Type ty) = (zeroStats, emptyFloats, Type ty) -floatExpr _ (Lit lit) = (zeroStats, emptyFloats, Lit lit) +floatExpr :: LevelledExpr + -> (FloatStats, FloatBinds, CoreExpr) +floatExpr (Var v) = (zeroStats, emptyFloats, Var v) +floatExpr (Type ty) = (zeroStats, emptyFloats, Type ty) +floatExpr (Coercion co) = (zeroStats, emptyFloats, Coercion co) +floatExpr (Lit lit) = (zeroStats, emptyFloats, Lit lit) -floatExpr lvl (App e a) - = case (floatExpr lvl e) of { (fse, floats_e, e') -> - case (floatRhs lvl a) of { (fsa, floats_a, a') -> +floatExpr (App e a) + = case (floatExpr e) of { (fse, floats_e, e') -> + case (floatExpr a) of { (fsa, floats_a, a') -> (fse `add_stats` fsa, floats_e `plusFloats` floats_a, App e' a') }} -floatExpr _ lam@(Lam _ _) - = let - (bndrs_w_lvls, body) = collectBinders lam +floatExpr lam@(Lam (TB _ lam_spec) _) + = let (bndrs_w_lvls, body) = collectBinders lam bndrs = [b | TB b _ <- bndrs_w_lvls] - lvls = [l | TB _ l <- bndrs_w_lvls] - - -- For the all-tyvar case we are prepared to pull - -- the lets out, to implement the float-out-of-big-lambda - -- transform; but otherwise we only float bindings that are - -- going to escape a value lambda. - -- In particular, for one-shot lambdas we don't float things - -- out; we get no saving by so doing. - partition_fn | all isTyCoVar bndrs = partitionByLevel - | otherwise = partitionByMajorLevel + bndr_lvl = floatSpecLevel lam_spec + -- All the binders have the same level + -- See SetLevels.lvlLamBndrs in - case (floatExpr (last lvls) body) of { (fs, floats, body') -> - - -- Dump any bindings which absolutely cannot go any further - case (partition_fn (head lvls) floats) of { (floats', heres) -> - - (add_to_stats fs floats', floats', mkLams bndrs (install heres body')) - }} + case (floatBody bndr_lvl body) of { (fs, floats, body') -> + (add_to_stats fs floats, floats, mkLams bndrs body') } -floatExpr lvl (Note note@(SCC cc) expr) - = case (floatExpr lvl expr) of { (fs, floating_defns, expr') -> +floatExpr (Note note@(SCC cc) expr) + = case (floatExpr expr) of { (fs, floating_defns, expr') -> let -- Annotate bindings floated outwards past an scc expression -- with the cc. We mark that cc as "duplicated", though. - annotated_defns = wrapCostCentre (dupifyCC cc) floating_defns in (fs, annotated_defns, Note note expr') } -floatExpr lvl (Note note expr) -- Other than SCCs - = case (floatExpr lvl expr) of { (fs, floating_defns, expr') -> +floatExpr (Note note expr) -- Other than SCCs + = case (floatExpr expr) of { (fs, floating_defns, expr') -> (fs, floating_defns, Note note expr') } -floatExpr lvl (Cast expr co) - = case (floatExpr lvl expr) of { (fs, floating_defns, expr') -> +floatExpr (Cast expr co) + = case (floatExpr expr) of { (fs, floating_defns, expr') -> (fs, floating_defns, Cast expr' co) } -floatExpr lvl (Let (NonRec (TB bndr bndr_lvl) rhs) body) - | isUnLiftedType (idType bndr) -- Treat unlifted lets just like a case - -- I.e. floatExpr for rhs, floatCaseAlt for body - = case floatExpr lvl rhs of { (_, rhs_floats, rhs') -> - case floatCaseAlt bndr_lvl body of { (fs, body_floats, body') -> - (fs, rhs_floats `plusFloats` body_floats, Let (NonRec bndr rhs') body') }} - -floatExpr lvl (Let bind body) - = case (floatBind bind) of { (fsb, bind_floats) -> - case (floatExpr lvl body) of { (fse, body_floats, body') -> - case partitionByMajorLevel lvl (bind_floats `plusFloats` body_floats) - of { (floats, heres) -> - -- See Note [Avoiding unnecessary floating] - (add_stats fsb fse, floats, install heres body') } } } - -floatExpr lvl (Case scrut (TB case_bndr case_lvl) ty alts) - = case floatExpr lvl scrut of { (fse, fde, scrut') -> - case floatList float_alt alts of { (fsa, fda, alts') -> - (add_stats fse fsa, fda `plusFloats` fde, Case scrut' case_bndr ty alts') - }} - where - -- Use floatCaseAlt for the alternatives, so that we - -- don't gratuitiously float bindings out of the RHSs - float_alt (con, bs, rhs) - = case (floatCaseAlt case_lvl rhs) of { (fs, rhs_floats, rhs') -> +floatExpr (Let bind body) + = case bind_spec of + FloatMe dest_lvl + -> case (floatBind bind) of { (fsb, bind_floats, bind') -> + case (floatExpr body) of { (fse, body_floats, body') -> + ( add_stats fsb fse + , bind_floats `plusFloats` unitLetFloat dest_lvl bind' + `plusFloats` body_floats + , body') }} + + StayPut bind_lvl -- See Note [Avoiding unnecessary floating] + -> case (floatBind bind) of { (fsb, bind_floats, bind') -> + case (floatBody bind_lvl body) of { (fse, body_floats, body') -> + ( add_stats fsb fse + , bind_floats `plusFloats` body_floats + , Let bind' body') }} + where + bind_spec = case bind of + NonRec (TB _ s) _ -> s + Rec ((TB _ s, _) : _) -> s + Rec [] -> panic "floatExpr:rec" + +floatExpr (Case scrut (TB case_bndr case_spec) ty alts) + = case case_spec of + FloatMe dest_lvl -- Case expression moves + | [(DataAlt con, bndrs, rhs)] <- alts + -> case floatExpr scrut of { (fse, fde, scrut') -> + case floatExpr rhs of { (fsb, fdb, rhs') -> + let + float = unitCaseFloat dest_lvl scrut' + case_bndr con [b | TB b _ <- bndrs] + in + (add_stats fse fsb, fde `plusFloats` float `plusFloats` fdb, rhs') }} + | otherwise + -> pprPanic "Floating multi-case" (ppr alts) + + StayPut bind_lvl -- Case expression stays put + -> case floatExpr scrut of { (fse, fde, scrut') -> + case floatList (float_alt bind_lvl) alts of { (fsa, fda, alts') -> + (add_stats fse fsa, fda `plusFloats` fde, Case scrut' case_bndr ty alts') + }} + where + float_alt bind_lvl (con, bs, rhs) + = case (floatBody bind_lvl rhs) of { (fs, rhs_floats, rhs') -> (fs, rhs_floats, (con, [b | TB b _ <- bs], rhs')) } \end{code} @@ -395,61 +438,92 @@ \begin{code} -type FloatBind = CoreBind -- INVARIANT: a FloatBind is always lifted +data FloatBind + = FloatLet FloatLet + | FloatCase CoreExpr Id DataCon [Var] -- case e of y { C ys -> ... } + +type FloatLet = CoreBind -- INVARIANT: a FloatLet is always lifted +type MajorEnv = M.IntMap MinorEnv -- Keyed by major level +type MinorEnv = M.IntMap (Bag FloatBind) -- Keyed by minor level -data FloatBinds = FB !(Bag FloatBind) -- Destined for top level - !MajorEnv -- Levels other than top +data FloatBinds = FB !(Bag FloatLet) -- Destined for top level + !MajorEnv -- Levels other than top -- See Note [Representation of FloatBinds] -type MajorEnv = UniqFM MinorEnv -- Keyed by major level -type MinorEnv = UniqFM (Bag FloatBind) -- Keyed by minor level - -flattenFloats :: FloatBinds -> Bag FloatBind -flattenFloats (FB tops others) = tops `unionBags` flattenMajor others +instance Outputable FloatBind where + ppr (FloatLet b) = ptext (sLit "LET") <+> ppr b + ppr (FloatCase e b c bs) = hang (ptext (sLit "CASE") <+> ppr e <+> ptext (sLit "of") <+> ppr b) + 2 (ppr c <+> ppr bs) + +instance Outputable FloatBinds where + ppr (FB fbs defs) + = ptext (sLit "FB") <+> (braces $ vcat + [ ptext (sLit "tops =") <+> ppr fbs + , ptext (sLit "non-tops =") <+> ppr defs ]) + +flattenTopFloats :: FloatBinds -> Bag CoreBind +flattenTopFloats (FB tops defs) + = ASSERT2( isEmptyBag (flattenMajor defs), ppr defs ) + tops + +addTopFloatPairs :: Bag CoreBind -> [(Id,CoreExpr)] -> [(Id,CoreExpr)] +addTopFloatPairs float_bag prs + = foldrBag add prs float_bag + where + add (NonRec b r) prs = (b,r):prs + add (Rec prs1) prs2 = prs1 ++ prs2 flattenMajor :: MajorEnv -> Bag FloatBind -flattenMajor = foldUFM (unionBags . flattenMinor) emptyBag +flattenMajor = M.fold (unionBags . flattenMinor) emptyBag flattenMinor :: MinorEnv -> Bag FloatBind -flattenMinor = foldUFM unionBags emptyBag +flattenMinor = M.fold unionBags emptyBag emptyFloats :: FloatBinds -emptyFloats = FB emptyBag emptyUFM +emptyFloats = FB emptyBag M.empty -unitFloat :: Level -> FloatBind -> FloatBinds -unitFloat lvl@(Level major minor) b - | isTopLvl lvl = FB (unitBag b) emptyUFM - | otherwise = FB emptyBag (unitUFM major (unitUFM minor (unitBag b))) +unitCaseFloat :: Level -> CoreExpr -> Id -> DataCon -> [Var] -> FloatBinds +unitCaseFloat (Level major minor) e b con bs + = FB emptyBag (M.singleton major (M.singleton minor (unitBag (FloatCase e b con bs)))) + +unitLetFloat :: Level -> FloatLet -> FloatBinds +unitLetFloat lvl@(Level major minor) b + | isTopLvl lvl = FB (unitBag b) M.empty + | otherwise = FB emptyBag (M.singleton major (M.singleton minor floats)) + where + floats = unitBag (FloatLet b) plusFloats :: FloatBinds -> FloatBinds -> FloatBinds -plusFloats (FB t1 b1) (FB t2 b2) = FB (t1 `unionBags` t2) (b1 `plusMajor` b2) +plusFloats (FB t1 l1) (FB t2 l2) + = FB (t1 `unionBags` t2) (l1 `plusMajor` l2) plusMajor :: MajorEnv -> MajorEnv -> MajorEnv -plusMajor = plusUFM_C plusMinor +plusMajor = M.unionWith plusMinor plusMinor :: MinorEnv -> MinorEnv -> MinorEnv -plusMinor = plusUFM_C unionBags - -floatsToBindPairs :: Bag FloatBind -> [(Id,CoreExpr)] -> [(Id,CoreExpr)] -floatsToBindPairs floats binds = foldrBag add binds floats - where - add (Rec pairs) binds = pairs ++ binds - add (NonRec binder rhs) binds = (binder,rhs) : binds +plusMinor = M.unionWith unionBags install :: Bag FloatBind -> CoreExpr -> CoreExpr install defn_groups expr = foldrBag install_group expr defn_groups where - install_group defns body = Let defns body + install_group (FloatLet defns) body + = Let defns body + install_group (FloatCase e b con bs) body + = Case e b (exprType body) [(DataAlt con, bs, body)] -partitionByMajorLevel, partitionByLevel +partitionByLevel :: Level -- Partitioning level -> FloatBinds -- Defns to be divided into 2 piles... -> (FloatBinds, -- Defns with level strictly < partition level, Bag FloatBind) -- The rest +{- -- ---- partitionByMajorLevel ---- --- Float it if we escape a value lambda, *or* if we get to the top level +-- Float it if we escape a value lambda, +-- *or* if we get to the top level +-- *or* if it's a case-float and its minor level is < current +-- -- If we can get to the top level, say "yes" anyway. This means that -- x = f e -- transforms to @@ -460,28 +534,33 @@ partitionByMajorLevel (Level major _) (FB tops defns) = (FB tops outer, heres `unionBags` flattenMajor inner) where - (outer, mb_heres, inner) = splitUFM defns major + (outer, mb_heres, inner) = M.splitLookup major defns heres = case mb_heres of Nothing -> emptyBag Just h -> flattenMinor h +-} partitionByLevel (Level major minor) (FB tops defns) - = (FB tops (outer_maj `plusMajor` unitUFM major outer_min), + = (FB tops (outer_maj `plusMajor` M.singleton major outer_min), here_min `unionBags` flattenMinor inner_min `unionBags` flattenMajor inner_maj) where - (outer_maj, mb_here_maj, inner_maj) = splitUFM defns major + (outer_maj, mb_here_maj, inner_maj) = M.splitLookup major defns (outer_min, mb_here_min, inner_min) = case mb_here_maj of - Nothing -> (emptyUFM, Nothing, emptyUFM) - Just min_defns -> splitUFM min_defns minor + Nothing -> (M.empty, Nothing, M.empty) + Just min_defns -> M.splitLookup minor min_defns here_min = mb_here_min `orElse` emptyBag wrapCostCentre :: CostCentre -> FloatBinds -> FloatBinds wrapCostCentre cc (FB tops defns) - = FB (wrap_defns tops) (mapUFM (mapUFM wrap_defns) defns) + = FB (mapBag wrap_bind tops) (M.map (M.map wrap_defns) defns) where wrap_defns = mapBag wrap_one - wrap_one (NonRec binder rhs) = NonRec binder (mkSCC cc rhs) - wrap_one (Rec pairs) = Rec (mapSnd (mkSCC cc) pairs) + + wrap_bind (NonRec binder rhs) = NonRec binder (mkSCC cc rhs) + wrap_bind (Rec pairs) = Rec (mapSnd (mkSCC cc) pairs) + + wrap_one (FloatLet bind) = FloatLet (wrap_bind bind) + wrap_one (FloatCase e b c bs) = FloatCase (mkSCC cc e) b c bs \end{code} diff -Nru ghc-7.0.3/compiler/simplCore/LiberateCase.lhs ghc-7.2.1/compiler/simplCore/LiberateCase.lhs --- ghc-7.0.3/compiler/simplCore/LiberateCase.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/simplCore/LiberateCase.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -199,6 +199,7 @@ libCase env (Var v) = libCaseId env v libCase _ (Lit lit) = Lit lit libCase _ (Type ty) = Type ty +libCase _ (Coercion co) = Coercion co libCase env (App fun arg) = App (libCase env fun) (libCase env arg) libCase env (Note note body) = Note note (libCase env body) libCase env (Cast e co) = Cast (libCase env e) co diff -Nru ghc-7.0.3/compiler/simplCore/OccurAnal.lhs ghc-7.2.1/compiler/simplCore/OccurAnal.lhs --- ghc-7.0.3/compiler/simplCore/OccurAnal.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/simplCore/OccurAnal.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -19,23 +19,23 @@ import CoreSyn import CoreFVs -import Type ( tyVarsOfType ) -import CoreUtils ( exprIsTrivial, isDefaultAlt, mkCoerceI, isExpandableApp ) -import Coercion ( CoercionI(..), mkSymCoI ) +import CoreUtils ( exprIsTrivial, isDefaultAlt, isExpandableApp, mkCoerce ) import Id -import NameEnv -import NameSet -import Name ( Name, localiseName ) +import Name( localiseName ) import BasicTypes +import Module( Module ) +import Coercion + import VarSet import VarEnv -import Var ( varUnique ) +import Var + import Maybes ( orElse ) import Digraph ( SCC(..), stronglyConnCompFromEdgedVerticesR ) import PrelNames ( buildIdKey, foldrIdKey, runSTRepIdKey, augmentIdKey ) import Unique import UniqFM -import Util ( mapAndUnzip, filterOut ) +import Util ( mapAndUnzip, filterOut, fstOf3 ) import Bag import Outputable import FastString @@ -52,13 +52,23 @@ Here's the externally-callable interface: \begin{code} -occurAnalysePgm :: Maybe (Activation -> Bool) -> [CoreRule] +occurAnalysePgm :: Module -- Used only in debug output + -> (Activation -> Bool) + -> [CoreRule] -> [CoreVect] -> [CoreBind] -> [CoreBind] -occurAnalysePgm active_rule imp_rules binds - = snd (go (initOccEnv active_rule imp_rules) binds) - where - initial_uds = addIdOccs emptyDetails (rulesFreeVars imp_rules) - -- The RULES keep things alive! +occurAnalysePgm this_mod active_rule imp_rules vects binds + | isEmptyVarEnv final_usage + = binds' + | otherwise -- See Note [Glomming] + = WARN( True, hang (text "Glomming in" <+> ppr this_mod <> colon) + 2 (ppr final_usage ) ) + [Rec (flattenBinds binds')] + where + (final_usage, binds') = go (initOccEnv active_rule) binds + + initial_uds = addIdOccs emptyDetails + (rulesFreeVars imp_rules `unionVarSet` vectsFreeVars vects) + -- The RULES and VECTORISE declarations keep things alive! go :: OccEnv -> [CoreBind] -> (UsageDetails, [CoreBind]) go _ [] @@ -72,10 +82,10 @@ occurAnalyseExpr :: CoreExpr -> CoreExpr -- Do occurrence analysis, and discard occurence info returned occurAnalyseExpr expr - = snd (occAnal (initOccEnv all_active_rules []) expr) + = snd (occAnal (initOccEnv all_active_rules) expr) where -- To be conservative, we say that all inlines and rules are active - all_active_rules = Just (\_ -> True) + all_active_rules = \_ -> True \end{code} @@ -97,7 +107,7 @@ [CoreBind]) occAnalBind env _ (NonRec binder rhs) body_usage - | isTyCoVar binder -- A type let; we don't gather usage info + | isTyVar binder -- A type let; we don't gather usage info = (body_usage, [NonRec binder rhs]) | not (binder `usedIn` body_usage) -- It's not mentioned @@ -107,10 +117,25 @@ = (body_usage' +++ rhs_usage3, [NonRec tagged_binder rhs']) where (body_usage', tagged_binder) = tagBinder body_usage binder - (rhs_usage1, rhs') = occAnalRhs env (idOccInfo tagged_binder) rhs + (rhs_usage1, rhs') = occAnalRhs env (Just tagged_binder) rhs rhs_usage2 = addIdOccs rhs_usage1 (idUnfoldingVars binder) rhs_usage3 = addIdOccs rhs_usage2 (idRuleVars binder) -- See Note [Rules are extra RHSs] and Note [Rule dependency info] + +occAnalBind _ env (Rec pairs) body_usage + = foldr occAnalRec (body_usage, []) sccs + -- For a recursive group, we + -- * occ-analyse all the RHSs + -- * compute strongly-connected components + -- * feed those components to occAnalRec + where + bndr_set = mkVarSet (map fst pairs) + + sccs :: [SCC (Node Details)] + sccs = {-# SCC "occAnalBind.scc" #-} stronglyConnCompFromEdgedVerticesR nodes + + nodes :: [Node Details] + nodes = {-# SCC "occAnalBind.assoc" #-} map (makeNode env bndr_set) pairs \end{code} Note [Dead code] @@ -145,12 +170,25 @@ ...m... -Note [Loop breaking and RULES] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Loop breaking is surprisingly subtle. First read the section 4 of -"Secrets of the GHC inliner". This describes our basic plan. +------------------------------------------------------------ +Note [Forming Rec groups] +~~~~~~~~~~~~~~~~~~~~~~~~~ +We put bindings {f = ef; g = eg } in a Rec group if "f uses g" +and "g uses f", no matter how indirectly. We do a SCC analysis +with an edge f -> g if "f uses g". + +More precisely, "f uses g" iff g should be in scope whereever f is. +That is, g is free in: + a) the rhs 'ef' + b) or the RHS of a rule for f (Note [Rules are extra RHSs]) + c) or the LHS or a rule for f (Note [Rule dependency info]) + +These conditions apply regardless of the activation of the RULE (eg it might be +inactive in this phase but become active later). Once a Rec is broken up +it can never be put back together, so we must be conservative. -However things are made quite a bit more complicated by RULES. Remember +The principle is that, regardless of rule firings, every variale is +always in scope. * Note [Rules are extra RHSs] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -174,60 +212,87 @@ will be put in the same Rec, even though their 'main' RHSs are both non-recursive. + * Note [Rule dependency info] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~ + The VarSet in a SpecInfo is used for dependency analysis in the + occurrence analyser. We must track free vars in *both* lhs and rhs. + Hence use of idRuleVars, rather than idRuleRhsVars in occAnalBind. + Why both? Consider + x = y + RULE f x = v+4 + Then if we substitute y for x, we'd better do so in the + rule's LHS too, so we'd better ensure the RULE appears to mention 'x' + as well as 'v' + * Note [Rules are visible in their own rec group] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We want the rules for 'f' to be visible in f's right-hand side. And we'd like them to be visible in other functions in f's Rec - group. E.g. in Example [Specialisation rules] we want f' rule + group. E.g. in Note [Specialisation rules] we want f' rule to be visible in both f's RHS, and fs's RHS. This means that we must simplify the RULEs first, before looking at any of the definitions. This is done by Simplify.simplRecBind, when it calls addLetIdInfo. - * Note [Choosing loop breakers] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - We avoid infinite inlinings by choosing loop breakers, and - ensuring that a loop breaker cuts each loop. But what is a - "loop"? In particular, a RULE is like an equation for 'f' that - is *always* inlined if it is applicable. We do *not* disable - rules for loop-breakers. It's up to whoever makes the rules to - make sure that the rules themselves always terminate. See Note - [Rules for recursive functions] in Simplify.lhs - - Hence, if - f's RHS (or its INLINE template if it has one) mentions g, and - g has a RULE that mentions h, and - h has a RULE that mentions f - - then we *must* choose f to be a loop breaker. In general, take the - free variables of f's RHS, and augment it with all the variables - reachable by RULES from those starting points. That is the whole - reason for computing rule_fv_env in occAnalBind. (Of course we - only consider free vars that are also binders in this Rec group.) - See also Note [Finding rule RHS free vars] - - Note that when we compute this rule_fv_env, we only consider variables - free in the *RHS* of the rule, in contrast to the way we build the - Rec group in the first place (Note [Rule dependency info]) - - Note that if 'g' has RHS that mentions 'w', we should add w to - g's loop-breaker edges. More concretely there is an edge from f -> g - iff - (a) g is mentioned in f's RHS - (b) h is mentioned in f's RHS, and - g appears in the RHS of a RULE of h - or a transitive sequence of rules starting with h - - Note that in Example [eftInt], *neither* eftInt *nor* eftIntFB is - chosen as a loop breaker, because their RHSs don't mention each other. - And indeed both can be inlined safely. - - Note that the edges of the graph we use for computing loop breakers - are not the same as the edges we use for computing the Rec blocks. - That's why we compute - rec_edges for the Rec block analysis - loop_breaker_edges for the loop breaker analysis +------------------------------------------------------------ +Note [Choosing loop breakers] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Loop breaking is surprisingly subtle. First read the section 4 of +"Secrets of the GHC inliner". This describes our basic plan. +We avoid infinite inlinings by choosing loop breakers, and +ensuring that a loop breaker cuts each loop. + +Fundamentally, we do SCC analysis on a graph. For each recursive +group we choose a loop breaker, delete all edges to that node, +re-analyse the SCC, and iterate. + +But what is the graph? NOT the same graph as was used for Note +[Forming Rec groups]! In particular, a RULE is like an equation for +'f' that is *always* inlined if it is applicable. We do *not* disable +rules for loop-breakers. It's up to whoever makes the rules to make +sure that the rules themselves always terminate. See Note [Rules for +recursive functions] in Simplify.lhs + +Hence, if + f's RHS (or its INLINE template if it has one) mentions g, and + g has a RULE that mentions h, and + h has a RULE that mentions f + +then we *must* choose f to be a loop breaker. Example: see Note +[Specialisation rules]. + +In general, take the free variables of f's RHS, and augment it with +all the variables reachable by RULES from those starting points. That +is the whole reason for computing rule_fv_env in occAnalBind. (Of +course we only consider free vars that are also binders in this Rec +group.) See also Note [Finding rule RHS free vars] + +Note that when we compute this rule_fv_env, we only consider variables +free in the *RHS* of the rule, in contrast to the way we build the +Rec group in the first place (Note [Rule dependency info]) + +Note that if 'g' has RHS that mentions 'w', we should add w to +g's loop-breaker edges. More concretely there is an edge from f -> g +iff + (a) g is mentioned in f's RHS `xor` f's INLINE rhs + (see Note [Inline rules]) + (b) or h is mentioned in f's RHS, and + g appears in the RHS of an active RULE of h + or a transitive sequence of active rules starting with h + +Why "active rules"? See Note [Finding rule RHS free vars] + +Note that in Example [eftInt], *neither* eftInt *nor* eftIntFB is +chosen as a loop breaker, because their RHSs don't mention each other. +And indeed both can be inlined safely. + +Note again that the edges of the graph we use for computing loop breakers +are not the same as the edges we use for computing the Rec blocks. +That's why we compute + +- rec_edges for the Rec block analysis +- loop_breaker_edges for the loop breaker analysis * Note [Finding rule RHS free vars] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -243,8 +308,8 @@ the RULE is only active *before* phase 1. So there's no problem. To make this work, we look for the RHS free vars only for - *active* rules. That's the reason for the is_active argument - to idRhsRuleVars, and the occ_rule_act field of the OccEnv. + *active* rules. That's the reason for the occ_rule_act field + of the OccEnv. * Note [Weak loop breakers] ~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -266,10 +331,28 @@ not choosen as a loop breaker.) Why not? Because then we drop the binding for 'g', which leaves it out of scope in the RULE! + + Here's a somewhat different example of the same thing + Rec { g = h + ; h = ...f... + ; f = f_rhs + RULE f [] = g } + Here the RULE is "below" g, but we *still* can't postInlineUnconditionally + g, because the RULE for f is active throughout. So the RHS of h + might rewrite to h = ...g... + So g must remain in scope in the output program! + + We "solve" this by: - We "solve" this by making g a "weak" or "rules-only" loop breaker, - with OccInfo = IAmLoopBreaker True. A normal "strong" loop breaker - has IAmLoopBreaker False. So + Make g a "weak" loop breaker (OccInfo = IAmLoopBreaker True) + iff g is a "missing free variable" of the Rec group + + A "missing free variable" x is one that is mentioned in an RHS or + INLINE or RULE of a binding in the Rec group, but where the + dependency on x may not show up in the loop_breaker_edges (see + note [Choosing loop breakers} above). + + A normal "strong" loop breaker has IAmLoopBreaker False. So Inline postInlineUnconditionally IAmLoopBreaker False no no @@ -277,32 +360,111 @@ other yes yes The **sole** reason for this kind of loop breaker is so that - postInlineUnconditionally does not fire. Ugh. + postInlineUnconditionally does not fire. Ugh. (Typically it'll + inline via the usual callSiteInline stuff, so it'll be dead in the + next pass, so the main Ugh is the tiresome complication.) - * Note [Rule dependency info] - ~~~~~~~~~~~~~~~~~~~~~~~~~~~ - The VarSet in a SpecInfo is used for dependency analysis in the - occurrence analyser. We must track free vars in *both* lhs and rhs. - Hence use of idRuleVars, rather than idRuleRhsVars in occAnalBind. - Why both? Consider - x = y - RULE f x = 4 - Then if we substitute y for x, we'd better do so in the - rule's LHS too, so we'd better ensure the dependency is respected +Note [Rules for imported functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this + f = /\a. B.g a + RULE B.g Int = 1 + f Int +Note that + * The RULE is for an imported function. + * f is non-recursive +Now we +can get + f Int --> B.g Int Inlining f + --> 1 + f Int Firing RULE +and so the simplifier goes into an infinite loop. This +would not happen if the RULE was for a local function, +because we keep track of dependencies through rules. But +that is pretty much impossible to do for imported Ids. Suppose +f's definition had been + f = /\a. C.h a +where (by some long and devious process), C.h eventually inlines to +B.g. We could only spot such loops by exhaustively following +unfoldings of C.h etc, in case we reach B.g, and hence (via the RULE) +f. + +Note that RULES for imported functions are important in practice; they +occur a lot in the libraries. + +We regard this potential infinite loop as a *programmer* error. +It's up the programmer not to write silly rules like + RULE f x = f x +and the example above is just a more complicated version. + +Note [Specialising imported functions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +BUT for *automatically-generated* rules, the programmer can't be +responsible for the "programmer error" in Note [Rules for imported +functions]. In paricular, consider specialising a recursive function +defined in another module. If we specialise a recursive function B.g, +we get + g_spec = .....(B.g Int)..... + RULE B.g Int = g_spec +Here, g_spec doesn't look recursive, but when the rule fires, it +becomes so. And if B.g was mutually recursive, the loop might +not be as obvious as it is here. + +To avoid this, + * When specialising a function that is a loop breaker, + give a NOINLINE pragma to the specialised function +Note [Glomming] +~~~~~~~~~~~~~~~ +RULES for imported Ids can make something at the top refer to something at the bottom: + f = \x -> B.g (q x) + h = \y -> 3 + + RULE: B.g (q x) = h x + +Applying this rule makes f refer to h, although f doesn't appear to +depend on h. (And, as in Note [Rules for imported functions], the +dependency might be more indirect. For example, f might mention C.t +rather than B.g, where C.t eventually inlines to B.g.) + +NOTICE that this cannot happen for rules whose head is a +locally-defined function, because we accurately track dependencies +through RULES. It only happens for rules whose head is an imported +function (B.g in the example above). + +Solution: + - When simplifying, bring all top level identifiers into + scope at the start, ignoring the Rec/NonRec structure, so + that when 'h' pops up in f's rhs, we find it in the in-scope set + (as the simplifier generally expects). This happens in simplTopBinds. + + - In the occurrence analyser, if there are any out-of-scope + occurrences that pop out of the top, which will happen after + firing the rule: f = \x -> h x + h = \y -> 3 + then just glom all the bindings into a single Rec, so that + the *next* iteration of the occurrence analyser will sort + them all out. This part happens in occurAnalysePgm. - * Note [Inline rules] - ~~~~~~~~~~~~~~~~~~~ - None of the above stuff about RULES applies to Inline Rules, - stored in a CoreUnfolding. The unfolding, if any, is simplified - at the same time as the regular RHS of the function, so it should - be treated *exactly* like an extra RHS. - - There is a danger that we'll be sub-optimal if we see this - f = ...f... - [INLINE f = ..no f...] - where f is recursive, but the INLINE is not. This can just about - happen with a sufficiently odd set of rules; eg +------------------------------------------------------------ +Note [Inline rules] +~~~~~~~~~~~~~~~~~~~ +None of the above stuff about RULES applies to Inline Rules, +stored in a CoreUnfolding. The unfolding, if any, is simplified +at the same time as the regular RHS of the function (ie *not* like +Note [Rules are visible in their own rec group]), so it should be +treated *exactly* like an extra RHS. + +Or, rather, when computing loop-breaker edges, + * If f has an INLINE pragma, and it is active, we treat the + INLINE rhs as f's rhs + * If it's inactive, we treat f as having no rhs + * If it has no INLINE pragma, we look at f's actual rhs + + +There is a danger that we'll be sub-optimal if we see this + f = ...f... + [INLINE f = ..no f...] +where f is recursive, but the INLINE is not. This can just about +happen with a sufficiently odd set of rules; eg foo :: Int -> Int {-# INLINE [1] foo #-} @@ -314,18 +476,17 @@ {-# RULES "foo" [~1] forall x. foo x = bar x #-} - Here the RULE makes bar recursive; but it's INLINE pragma remains - non-recursive. It's tempting to then say that 'bar' should not be - a loop breaker, but an attempt to do so goes wrong in two ways: - a) We may get - $df = ...$cfoo... - $cfoo = ...$df.... - [INLINE $cfoo = ...no-$df...] - But we want $cfoo to depend on $df explicitly so that we - put the bindings in the right order to inline $df in $cfoo - and perhaps break the loop altogether. (Maybe this - b) - +Here the RULE makes bar recursive; but it's INLINE pragma remains +non-recursive. It's tempting to then say that 'bar' should not be +a loop breaker, but an attempt to do so goes wrong in two ways: + a) We may get + $df = ...$cfoo... + $cfoo = ...$df.... + [INLINE $cfoo = ...no-$df...] + But we want $cfoo to depend on $df explicitly so that we + put the bindings in the right order to inline $df in $cfoo + and perhaps break the loop altogether. (Maybe this + b) Example [eftInt] @@ -344,8 +505,8 @@ "eftIntList" [1] eftIntFB (:) [] = eftInt #-} -Example [Specialisation rules] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Specialisation rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this group, which is typical of what SpecConstr builds: fs a = ....f (C a).... @@ -355,141 +516,171 @@ So 'f' and 'fs' are in the same Rec group (since f refers to fs via its RULE). But watch out! If 'fs' is not chosen as a loop breaker, we may get an infinite loop: - - the RULE is applied in f's RHS (see Note [Self-recursive rules] in Simplify - - fs is inlined (say it's small) - - now there's another opportunity to apply the RULE + - the RULE is applied in f's RHS (see Note [Self-recursive rules] in Simplify + - fs is inlined (say it's small) + - now there's another opportunity to apply the RULE This showed up when compiling Control.Concurrent.Chan.getChanContents. \begin{code} -occAnalBind _ env (Rec pairs) body_usage - = foldr (occAnalRec env) (body_usage, []) sccs - -- For a recursive group, we - -- * occ-analyse all the RHSs - -- * compute strongly-connected components - -- * feed those components to occAnalRec - where - -------------Dependency analysis ------------------------------ - bndr_set = mkVarSet (map fst pairs) +type Node details = (details, Unique, [Unique]) -- The Ints are gotten from the Unique, + -- which is gotten from the Id. +data Details + = ND { nd_bndr :: Id -- Binder + , nd_rhs :: CoreExpr -- RHS, already occ-analysed - sccs :: [SCC (Node Details)] - sccs = {-# SCC "occAnalBind.scc" #-} stronglyConnCompFromEdgedVerticesR rec_edges + , nd_uds :: UsageDetails -- Usage from RHS, and RULES, and InlineRule unfolding + -- ignoring phase (ie assuming all are active) + -- See Note [Forming Rec groups] + + , nd_inl :: IdSet -- Free variables of + -- the InlineRule (if present and active) + -- or the RHS (ir no InlineRule) + -- but excluding any RULES + -- This is the IdSet that may be used if the Id is inlined - rec_edges :: [Node Details] - rec_edges = {-# SCC "occAnalBind.assoc" #-} map make_node pairs - - make_node (bndr, rhs) - = (details, varUnique bndr, keysUFM out_edges) - where - details = ND { nd_bndr = bndr, nd_rhs = rhs' - , nd_uds = rhs_usage3, nd_inl = inl_fvs} - - (rhs_usage1, rhs') = occAnalRhs env NoOccInfo rhs - rhs_usage2 = addIdOccs rhs_usage1 rule_fvs -- Note [Rules are extra RHSs] - rhs_usage3 = addIdOccs rhs_usage2 unf_fvs - unf = realIdUnfolding bndr -- Ignore any current loop-breaker flag - unf_fvs = stableUnfoldingVars unf - rule_fvs = idRuleVars bndr -- See Note [Rule dependency info] - - inl_fvs = rhs_fvs `unionVarSet` unf_fvs - rhs_fvs = intersectUFM_C (\b _ -> b) bndr_set rhs_usage1 - out_edges = intersectUFM_C (\b _ -> b) bndr_set rhs_usage3 - -- (a -> b) means a mentions b - -- Given the usage details (a UFM that gives occ info for each free var of - -- the RHS) we can get the list of free vars -- or rather their Int keys -- - -- by just extracting the keys from the finite map. Grimy, but fast. - -- Previously we had this: - -- [ bndr | bndr <- bndrs, - -- maybeToBool (lookupVarEnv rhs_usage bndr)] - -- which has n**2 cost, and this meant that edges_from alone - -- consumed 10% of total runtime! + , nd_weak :: IdSet -- Binders of this Rec that are mentioned in nd_uds + -- but are *not* in nd_inl. These are the ones whose + -- dependencies might not be respected by loop_breaker_edges + -- See Note [Weak loop breakers] + + , nd_active_rule_fvs :: IdSet -- Free variables of the RHS of active RULES + } + +instance Outputable Details where + ppr nd = ptext (sLit "ND") <> braces + (sep [ ptext (sLit "bndr =") <+> ppr (nd_bndr nd) + , ptext (sLit "uds =") <+> ppr (nd_uds nd) + , ptext (sLit "inl =") <+> ppr (nd_inl nd) + , ptext (sLit "weak =") <+> ppr (nd_weak nd) + , ptext (sLit "rule =") <+> ppr (nd_active_rule_fvs nd) + ]) + +makeNode :: OccEnv -> VarSet -> (Var, CoreExpr) -> Node Details +makeNode env bndr_set (bndr, rhs) + = (details, varUnique bndr, keysUFM node_fvs) + where + details = ND { nd_bndr = bndr + , nd_rhs = rhs' + , nd_uds = rhs_usage3 + , nd_weak = node_fvs `minusVarSet` inl_fvs + , nd_inl = inl_fvs + , nd_active_rule_fvs = active_rule_fvs } + + -- Constructing the edges for the main Rec computation + -- See Note [Forming Rec groups] + (rhs_usage1, rhs') = occAnalRhs env Nothing rhs + rhs_usage2 = addIdOccs rhs_usage1 all_rule_fvs -- Note [Rules are extra RHSs] + -- Note [Rule dependency info] + rhs_usage3 = case mb_unf_fvs of + Just unf_fvs -> addIdOccs rhs_usage2 unf_fvs + Nothing -> rhs_usage2 + node_fvs = udFreeVars bndr_set rhs_usage3 + + -- Finding the free variables of the rules + is_active = occ_rule_act env :: Activation -> Bool + rules = filterOut isBuiltinRule (idCoreRules bndr) + rules_w_fvs :: [(Activation, VarSet)] -- Find the RHS fvs + rules_w_fvs = [ (ru_act rule, fvs) + | rule <- rules + , let fvs = exprFreeVars (ru_rhs rule) + `delVarSetList` ru_bndrs rule + , not (isEmptyVarSet fvs) ] + all_rule_fvs = foldr (unionVarSet . snd) rule_lhs_fvs rules_w_fvs + rule_lhs_fvs = foldr (unionVarSet . (\ru -> exprsFreeVars (ru_args ru) + `delVarSetList` ru_bndrs ru)) + emptyVarSet rules + active_rule_fvs = unionVarSets [fvs | (a,fvs) <- rules_w_fvs, is_active a] + + -- Finding the free variables of the INLINE pragma (if any) + unf = realIdUnfolding bndr -- Ignore any current loop-breaker flag + mb_unf_fvs = stableUnfoldingVars isLocalId unf + + -- Find the "nd_inl" free vars; for the loop-breaker phase + inl_fvs = case mb_unf_fvs of + Nothing -> udFreeVars bndr_set rhs_usage1 -- No INLINE, use RHS + Just unf_fvs -> unf_fvs + -- We could check for an *active* INLINE (returning + -- emptyVarSet for an inactive one), but is_active + -- isn't the right thing (it tells about + -- RULE activation), so we'd need more plumbing ----------------------------- -occAnalRec :: OccEnv -> SCC (Node Details) +occAnalRec :: SCC (Node Details) -> (UsageDetails, [CoreBind]) -> (UsageDetails, [CoreBind]) -- The NonRec case is just like a Let (NonRec ...) above -occAnalRec _ (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = rhs, nd_uds = rhs_usage}, _, _)) - (body_usage, binds) - | not (bndr `usedIn` body_usage) - = (body_usage, binds) +occAnalRec (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = rhs, nd_uds = rhs_uds}, _, _)) + (body_uds, binds) + | not (bndr `usedIn` body_uds) + = (body_uds, binds) | otherwise -- It's mentioned in the body - = (body_usage' +++ rhs_usage, + = (body_uds' +++ rhs_uds, NonRec tagged_bndr rhs : binds) where - (body_usage', tagged_bndr) = tagBinder body_usage bndr - + (body_uds', tagged_bndr) = tagBinder body_uds bndr -- The Rec case is the interesting one -- See Note [Loop breaking] -occAnalRec env (CyclicSCC nodes) (body_usage, binds) - | not (any (`usedIn` body_usage) bndrs) -- NB: look at body_usage, not total_usage - = (body_usage, binds) -- Dead code +occAnalRec (CyclicSCC nodes) (body_uds, binds) + | not (any (`usedIn` body_uds) bndrs) -- NB: look at body_uds, not total_uds + = (body_uds, binds) -- Dead code | otherwise -- At this point we always build a single Rec - = (final_usage, Rec pairs : binds) + = -- pprTrace "occAnalRec" (vcat + -- [ text "tagged nodes" <+> ppr tagged_nodes + -- , text "lb edges" <+> ppr loop_breaker_edges]) + (final_uds, Rec pairs : binds) where bndrs = [b | (ND { nd_bndr = b }, _, _) <- nodes] bndr_set = mkVarSet bndrs - non_boring bndr = isId bndr && - (isStableUnfolding (realIdUnfolding bndr) || idHasRules bndr) ---------------------------- -- Tag the binders with their occurrence info - total_usage = foldl add_usage body_usage nodes - add_usage usage_so_far (ND { nd_uds = rhs_usage }, _, _) = usage_so_far +++ rhs_usage - (final_usage, tagged_nodes) = mapAccumL tag_node total_usage nodes - - tag_node :: UsageDetails -> Node Details -> (UsageDetails, Node Details) - -- (a) Tag the binders in the details with occ info - -- (b) Mark the binder with "weak loop-breaker" OccInfo - -- saying "no preInlineUnconditionally" if it is used - -- in any rule (lhs or rhs) of the recursive group - -- See Note [Weak loop breakers] - tag_node usage (details@ND { nd_bndr = bndr }, k, ks) - = (usage `delVarEnv` bndr, (details { nd_bndr = bndr2 }, k, ks)) - where - bndr2 | bndr `elemVarSet` all_rule_fvs = makeLoopBreaker True bndr1 - | otherwise = bndr1 - bndr1 = setBinderOcc usage bndr - all_rule_fvs = bndr_set `intersectVarSet` foldr (unionVarSet . idRuleVars) - emptyVarSet bndrs + tagged_nodes = map tag_node nodes + total_uds = foldl add_uds body_uds nodes + final_uds = total_uds `minusVarEnv` bndr_set + add_uds usage_so_far (nd, _, _) = usage_so_far +++ nd_uds nd + + tag_node :: Node Details -> Node Details + tag_node (details@ND { nd_bndr = bndr }, k, ks) + = (details { nd_bndr = setBinderOcc total_uds bndr }, k, ks) + + --------------------------- + -- Now reconstruct the cycle + pairs :: [(Id,CoreExpr)] + pairs | isEmptyVarSet weak_fvs = reOrderNodes 0 bndr_set weak_fvs tagged_nodes [] + | otherwise = loopBreakNodes 0 bndr_set weak_fvs loop_breaker_edges [] + -- If weak_fvs is empty, the loop_breaker_edges will include all + -- the edges in tagged_nodes, so there isn't any point in doing + -- a fresh SCC computation that will yield a single CyclicSCC result. - ---------------------------- - -- Now reconstruct the cycle - pairs | any non_boring bndrs - = foldr (reOrderRec 0) [] $ - stronglyConnCompFromEdgedVerticesR loop_breaker_edges - | otherwise - = reOrderCycle 0 tagged_nodes [] + weak_fvs :: VarSet + weak_fvs = foldr (unionVarSet . nd_weak . fstOf3) emptyVarSet nodes -- See Note [Choosing loop breakers] for loop_breaker_edges loop_breaker_edges = map mk_node tagged_nodes - mk_node (details@(ND { nd_inl = inl_fvs }), k, _) = (details, k, new_ks) - where - new_ks = keysUFM (fst (extendFvs rule_fv_env inl_fvs)) + mk_node (details@(ND { nd_inl = inl_fvs }), k, _) + = (details, k, keysUFM (extendFvs_ rule_fv_env inl_fvs)) ------------------------------------ - rule_fv_env :: IdEnv IdSet -- Variables from this group mentioned in RHS of rules - -- Domain is *subset* of bound vars (others have no rule fvs) - rule_fv_env = transClosureFV init_rule_fvs - init_rule_fvs - | Just is_active <- occ_rule_act env -- See Note [Finding rule RHS free vars] - = [ (b, rule_fvs) - | b <- bndrs - , isId b - , let rule_fvs = idRuleRhsVars is_active b - `intersectVarSet` bndr_set - , not (isEmptyVarSet rule_fvs)] - | otherwise - = [] + rule_fv_env :: IdEnv IdSet + -- Maps a variable f to the variables from this group + -- mentioned in RHS of active rules for f + -- Domain is *subset* of bound vars (others have no rule fvs) + rule_fv_env = transClosureFV (mkVarEnv init_rule_fvs) + init_rule_fvs -- See Note [Finding rule RHS free vars] + = [ (b, trimmed_rule_fvs) + | (ND { nd_bndr = b, nd_active_rule_fvs = rule_fvs },_,_) <- nodes + , let trimmed_rule_fvs = rule_fvs `intersectVarSet` bndr_set + , not (isEmptyVarSet trimmed_rule_fvs)] \end{code} -@reOrderRec@ is applied to the list of (binder,rhs) pairs for a cyclic +@loopBreakSCC@ is applied to the list of (binder,rhs) pairs for a cyclic strongly connected component (there's guaranteed to be a cycle). It returns the same pairs, but a) in a better order, @@ -504,66 +695,54 @@ that the simplifier will generally do a good job if it works from top bottom, recording inlinings for any Ids which aren't marked as "no-inline" as it goes. -============== -[June 98: I don't understand the following paragraphs, and I've - changed the a=b case again so that it isn't a special case any more.] - -Here's a case that bit me: - - letrec - a = b - b = \x. BIG - in - ...a...a...a.... - -Re-ordering doesn't change the order of bindings, but there was no loop-breaker. - -My solution was to make a=b bindings record b as Many, rather like INLINE bindings. -Perhaps something cleverer would suffice. -=============== - - \begin{code} -type Node details = (details, Unique, [Unique]) -- The Ints are gotten from the Unique, - -- which is gotten from the Id. -data Details - = ND { nd_bndr :: Id -- Binder - , nd_rhs :: CoreExpr -- RHS +type Binding = (Id,CoreExpr) - , nd_uds :: UsageDetails -- Usage from RHS, - -- including RULES and InlineRule unfolding - - , nd_inl :: IdSet -- Other binders *from this Rec group* mentioned in - } -- its InlineRule unfolding (if present) - -- AND the RHS - -- but *excluding* any RULES - -- This is the IdSet that may be used if the Id is inlined - -reOrderRec :: Int -> SCC (Node Details) - -> [(Id,CoreExpr)] -> [(Id,CoreExpr)] --- Sorted into a plausible order. Enough of the Ids have --- IAmALoopBreaker pragmas that there are no loops left. -reOrderRec _ (AcyclicSCC (ND { nd_bndr = bndr, nd_rhs = rhs }, _, _)) - pairs = (bndr, rhs) : pairs -reOrderRec depth (CyclicSCC cycle) pairs = reOrderCycle depth cycle pairs - -reOrderCycle :: Int -> [Node Details] -> [(Id,CoreExpr)] -> [(Id,CoreExpr)] -reOrderCycle _ [] _ - = panic "reOrderCycle" -reOrderCycle _ [(ND { nd_bndr = bndr, nd_rhs = rhs }, _, _)] pairs - = -- Common case of simple self-recursion - (makeLoopBreaker False bndr, rhs) : pairs - -reOrderCycle depth (bind : binds) pairs - = -- Choose a loop breaker, mark it no-inline, - -- do SCC analysis on the rest, and recursively sort them out --- pprTrace "reOrderCycle" (ppr [b | (ND { nd_bndr = b }, _, _) <- bind:binds]) $ - foldr (reOrderRec new_depth) - ([ (makeLoopBreaker False bndr, rhs) - | (ND { nd_bndr = bndr, nd_rhs = rhs }, _, _) <- chosen_binds] ++ pairs) - (stronglyConnCompFromEdgedVerticesR unchosen) +mk_loop_breaker :: Node Details -> Binding +mk_loop_breaker (ND { nd_bndr = bndr, nd_rhs = rhs}, _, _) + = (setIdOccInfo bndr strongLoopBreaker, rhs) + +mk_non_loop_breaker :: VarSet -> Node Details -> Binding +-- See Note [Weak loop breakers] +mk_non_loop_breaker used_in_rules (ND { nd_bndr = bndr, nd_rhs = rhs}, _, _) + | bndr `elemVarSet` used_in_rules = (setIdOccInfo bndr weakLoopBreaker, rhs) + | otherwise = (bndr, rhs) + +udFreeVars :: VarSet -> UsageDetails -> VarSet +-- Find the subset of bndrs that are mentioned in uds +udFreeVars bndrs uds = intersectUFM_C (\b _ -> b) bndrs uds + +loopBreakNodes :: Int + -> VarSet -- All binders + -> VarSet -- Binders whose dependencies may be "missing" + -- See Note [Weak loop breakers] + -> [Node Details] + -> [Binding] -- Append these to the end + -> [Binding] +-- Return the bindings sorted into a plausible order, and marked with loop breakers. +loopBreakNodes depth bndr_set weak_fvs nodes binds + = go (stronglyConnCompFromEdgedVerticesR nodes) binds + where + go [] binds = binds + go (scc:sccs) binds = loop_break_scc scc (go sccs binds) + + loop_break_scc scc binds + = case scc of + AcyclicSCC node -> mk_non_loop_breaker weak_fvs node : binds + CyclicSCC [node] -> mk_loop_breaker node : binds + CyclicSCC nodes -> reOrderNodes depth bndr_set weak_fvs nodes binds + +reOrderNodes :: Int -> VarSet -> VarSet -> [Node Details] -> [Binding] -> [Binding] + -- Choose a loop breaker, mark it no-inline, + -- do SCC analysis on the rest, and recursively sort them out +reOrderNodes _ _ _ [] _ = panic "reOrderNodes" +reOrderNodes depth bndr_set weak_fvs (node : nodes) binds + = -- pprTrace "reOrderNodes" (text "unchosen" <+> ppr unchosen $$ + -- text "chosen" <+> ppr chosen_nodes) $ + loopBreakNodes new_depth bndr_set weak_fvs unchosen $ + (map mk_loop_breaker chosen_nodes ++ binds) where - (chosen_binds, unchosen) = choose_loop_breaker [bind] (score bind) [] binds + (chosen_nodes, unchosen) = choose_loop_breaker (score node) [node] [] nodes approximate_loop_breaker = depth >= 2 new_depth | approximate_loop_breaker = 0 @@ -571,25 +750,30 @@ -- After two iterations (d=0, d=1) give up -- and approximate, returning to d=0 + choose_loop_breaker :: Int -- Best score so far + -> [Node Details] -- Nodes with this score + -> [Node Details] -- Nodes with higher scores + -> [Node Details] -- Unprocessed nodes + -> ([Node Details], [Node Details]) -- This loop looks for the bind with the lowest score -- to pick as the loop breaker. The rest accumulate in - choose_loop_breaker loop_binds _loop_sc acc [] - = (loop_binds, acc) -- Done + choose_loop_breaker _ loop_nodes acc [] + = (loop_nodes, acc) -- Done -- If approximate_loop_breaker is True, we pick *all* -- nodes with lowest score, else just one -- See Note [Complexity of loop breaking] - choose_loop_breaker loop_binds loop_sc acc (bind : binds) + choose_loop_breaker loop_sc loop_nodes acc (node : nodes) | sc < loop_sc -- Lower score so pick this new one - = choose_loop_breaker [bind] sc (loop_binds ++ acc) binds + = choose_loop_breaker sc [node] (loop_nodes ++ acc) nodes | approximate_loop_breaker && sc == loop_sc - = choose_loop_breaker (bind : loop_binds) loop_sc acc binds + = choose_loop_breaker loop_sc (node : loop_nodes) acc nodes | otherwise -- Higher score so don't pick it - = choose_loop_breaker loop_binds loop_sc (bind : acc) binds + = choose_loop_breaker loop_sc loop_nodes (node : acc) nodes where - sc = score bind + sc = score node score :: Node Details -> Int -- Higher score => less likely to be picked as loop breaker score (ND { nd_bndr = bndr, nd_rhs = rhs }, _, _) @@ -604,7 +788,7 @@ _other -> 3 -- Data structures are more important than this -- so that dictionary/method recursion unravels -- Note that this case hits all InlineRule things, so we - -- never look at 'rhs for InlineRule stuff. That's right, because + -- never look at 'rhs' for InlineRule stuff. That's right, because -- 'rhs' is irrelevant for inlining things with an InlineRule | is_con_app rhs = 5 -- Data types help with cases: Note [Constructor applications] @@ -645,11 +829,6 @@ is_con_app (Lam _ e) = is_con_app e is_con_app (Note _ e) = is_con_app e is_con_app _ = False - -makeLoopBreaker :: Bool -> Id -> Id --- Set the loop-breaker flag: see Note [Weak loop breakers] -makeLoopBreaker weak bndr - = ASSERT2( isId bndr, ppr bndr ) setIdOccInfo bndr (IAmALoopBreaker weak) \end{code} Note [Complexity of loop breaking] @@ -784,42 +963,33 @@ we'll catch it next time round. At worst this costs an extra simplifier pass. ToDo: try using the occurrence info for the inline'd binder. -[March 97] We do the same for atomic RHSs. Reason: see notes with reOrderRec. -[June 98, SLPJ] I've undone this change; I don't understand it. See notes with reOrderRec. +[March 97] We do the same for atomic RHSs. Reason: see notes with loopBreakSCC. +[June 98, SLPJ] I've undone this change; I don't understand it. See notes with loopBreakSCC. \begin{code} occAnalRhs :: OccEnv - -> OccInfo -> CoreExpr -- Binder and rhs - -- For non-recs the binder is alrady tagged - -- with occurrence info + -> Maybe Id -> CoreExpr -- Binder and rhs + -- Just b => non-rec, and alrady tagged with occurrence info + -- Nothing => Rec, no occ info -> (UsageDetails, CoreExpr) -- Returned usage details covers only the RHS, -- and *not* the RULE or INLINE template for the Id -occAnalRhs env occ rhs +occAnalRhs env mb_bndr rhs = occAnal ctxt rhs where - ctxt | certainly_inline = env - | otherwise = rhsCtxt env - -- Note that we generally use an rhsCtxt. This tells the occ anal n - -- that it's looking at an RHS, which has an effect in occAnalApp - -- - -- But there's a problem. Consider - -- x1 = a0 : [] - -- x2 = a1 : x1 - -- x3 = a2 : x2 - -- g = f x3 - -- First time round, it looks as if x1 and x2 occur as an arg of a - -- let-bound constructor ==> give them a many-occurrence. - -- But then x3 is inlined (unconditionally as it happens) and - -- next time round, x2 will be, and the next time round x1 will be - -- Result: multiple simplifier iterations. Sigh. - -- Crude solution: use rhsCtxt for things that occur just once... - - certainly_inline = case occ of - OneOcc in_lam one_br _ -> not in_lam && one_br - _ -> False - + -- See Note [Cascading inlines] + ctxt = case mb_bndr of + Just b | certainly_inline b -> env + _other -> rhsCtxt env + + certainly_inline bndr -- See Note [Cascading inlines] + = case idOccInfo bndr of + OneOcc in_lam one_br _ -> not in_lam && one_br && active && not_stable + _ -> False + where + active = isAlwaysActive (idInlineActivation bndr) + not_stable = not (isStableUnfolding (idUnfolding bndr)) addIdOccs :: UsageDetails -> VarSet -> UsageDetails addIdOccs usage id_set = foldVarSet add usage id_set @@ -833,6 +1003,46 @@ -- (Same goes for INLINE.) \end{code} +Note [Cascading inlines] +~~~~~~~~~~~~~~~~~~~~~~~~ +By default we use an rhsCtxt for the RHS of a binding. This tells the +occ anal n that it's looking at an RHS, which has an effect in +occAnalApp. In particular, for constructor applications, it makes +the arguments appear to have NoOccInfo, so that we don't inline into +them. Thus x = f y + k = Just x +we do not want to inline x. + +But there's a problem. Consider + x1 = a0 : [] + x2 = a1 : x1 + x3 = a2 : x2 + g = f x3 +First time round, it looks as if x1 and x2 occur as an arg of a +let-bound constructor ==> give them a many-occurrence. +But then x3 is inlined (unconditionally as it happens) and +next time round, x2 will be, and the next time round x1 will be +Result: multiple simplifier iterations. Sigh. + +So, when analysing the RHS of x3 we notice that x3 will itself +definitely inline the next time round, and so we analyse x3's rhs in +an ordinary context, not rhsCtxt. Hence the "certainly_inline" stuff. + +Annoyingly, we have to approximiate SimplUtils.preInlineUnconditionally. +If we say "yes" when preInlineUnconditionally says "no" the simplifier iterates +indefinitely: + x = f y + k = Just x +inline ==> + k = Just (f y) +float ==> + x1 = f y + k = Just x1 + +This is worse than the slow cascade, so we only want to say "certainly_inline" +if it really is certain. Look at the note with preInlineUnconditionally +for the various clauses. + Expressions ~~~~~~~~~~~ \begin{code} @@ -841,33 +1051,27 @@ -> (UsageDetails, -- Gives info only about the "interesting" Ids CoreExpr) -occAnal _ (Type t) = (emptyDetails, Type t) -occAnal env (Var v) = (mkOneOcc env v False, Var v) +occAnal _ expr@(Type _) = (emptyDetails, expr) +occAnal _ expr@(Lit _) = (emptyDetails, expr) +occAnal env expr@(Var v) = (mkOneOcc env v False, expr) -- At one stage, I gathered the idRuleVars for v here too, -- which in a way is the right thing to do. -- But that went wrong right after specialisation, when -- the *occurrences* of the overloaded function didn't have any -- rules in them, so the *specialised* versions looked as if they -- weren't used at all. -\end{code} - -We regard variables that occur as constructor arguments as "dangerousToDup": -\begin{verbatim} -module A where -f x = let y = expensive x in - let z = (True,y) in - (case z of {(p,q)->q}, case z of {(p,q)->q}) -\end{verbatim} - -We feel free to duplicate the WHNF (True,y), but that means -that y may be duplicated thereby. +occAnal _ (Coercion co) + = (addIdOccs emptyDetails (coVarsOfCo co), Coercion co) + -- See Note [Gather occurrences of coercion veriables] +\end{code} -If we aren't careful we duplicate the (expensive x) call! -Constructors are rather like lambdas in this way. +Note [Gather occurrences of coercion veriables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need to gather info about what coercion variables appear, so that +we can sort them into the right place when doing dependency analysis. \begin{code} -occAnal _ expr@(Lit _) = (emptyDetails, expr) \end{code} \begin{code} @@ -883,7 +1087,10 @@ occAnal env (Cast expr co) = case occAnal env expr of { (usage, expr') -> - (markManyIf (isRhsEnv env) usage, Cast expr' co) + let usage1 = markManyIf (isRhsEnv env) usage + usage2 = addIdOccs usage1 (coVarsOfCo co) + -- See Note [Gather occurrences of coercion veriables] + in (usage2, Cast expr' co) -- If we see let x = y `cast` co -- then mark y as 'Many' so that we don't -- immediately inline y again. @@ -898,7 +1105,7 @@ -- (a) occurrences inside type lambdas only not marked as InsideLam -- (b) type variables not in environment -occAnal env (Lam x body) | isTyCoVar x +occAnal env (Lam x body) | isTyVar x = case occAnal env body of { (body_usage, body') -> (body_usage, Lam x body') } @@ -990,6 +1197,18 @@ Applications are dealt with specially because we want the "build hack" to work. +Note [Arguments of let-bound constructors] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + f x = let y = expensive x in + let z = (True,y) in + (case z of {(p,q)->q}, case z of {(p,q)->q}) +We feel free to duplicate the WHNF (True,y), but that means +that y may be duplicated thereby. + +If we aren't careful we duplicate the (expensive x) call! +Constructors are rather like lambdas in this way. + \begin{code} occAnalApp :: OccEnv -> (Expr CoreBndr, [Arg CoreBndr]) @@ -1005,6 +1224,7 @@ -- arguments are just variables, or trivial expressions. -- -- This is the *whole point* of the isRhsEnv predicate + -- See Note [Arguments of let-bound constructors] in (fun_uds +++ final_args_uds, mkApps (Var fun) args') } where @@ -1115,7 +1335,7 @@ where (body_usg', tagged_bndr) = tagBinder body_usg bndr rhs_usg = unitVarEnv rhs_var NoOccInfo -- We don't need exact info - rhs = mkCoerceI co (Var rhs_var) + rhs = mkCoerce co (Var (zapIdOccInfo rhs_var)) -- See Note [Zap case binders in proxy bindings] \end{code} @@ -1130,12 +1350,10 @@ = OccEnv { occ_encl :: !OccEncl -- Enclosing context information , occ_ctxt :: !CtxtTy -- Tells about linearity , occ_proxy :: ProxyEnv - , occ_rule_fvs :: ImpRuleUsage - , occ_rule_act :: Maybe (Activation -> Bool) -- Nothing => Rules are inactive + , occ_rule_act :: Activation -> Bool -- Which rules are active -- See Note [Finding rule RHS free vars] } - ----------------------------- -- OccEncl is used to control whether to inline into constructor arguments -- For example: @@ -1165,13 +1383,11 @@ -- be applied many times; but when it is, -- the CtxtTy inside applies -initOccEnv :: Maybe (Activation -> Bool) -> [CoreRule] - -> OccEnv -initOccEnv active_rule imp_rules +initOccEnv :: (Activation -> Bool) -> OccEnv +initOccEnv active_rule = OccEnv { occ_encl = OccVanilla , occ_ctxt = [] , occ_proxy = PE emptyVarEnv emptyVarSet - , occ_rule_fvs = findImpRuleUsage active_rule imp_rules , occ_rule_act = active_rule } vanillaCtxt :: OccEnv -> OccEnv @@ -1211,88 +1427,16 @@ = env { occ_ctxt = replicate (valArgCount args) True ++ ctxt } \end{code} -%************************************************************************ -%* * - ImpRuleUsage -%* * -%************************************************************************ - -\begin{code} -type ImpRuleUsage = NameEnv UsageDetails - -- Maps an *imported* Id f to the UsageDetails for *local* Ids - -- used on the RHS for a *local* rule for f. -\end{code} - -Note [ImpRuleUsage] -~~~~~~~~~~~~~~~~ -Consider this, where A.g is an imported Id - - f x = A.g x - {-# RULE "foo" forall x. A.g x = f x #-} - -Obviously there's a loop, but the danger is that the occurrence analyser -will say that 'f' is not a loop breaker. Then the simplifier will -optimise 'f' to - f x = f x -and then gaily inline 'f'. Result infinite loop. More realistically, -these kind of rules are generated when specialising imported INLINABLE Ids. - -Solution: treat an occurrence of A.g as an occurrence of all the local Ids -that occur on the RULE's RHS. This mapping from imported Id to local Ids -is held in occ_rule_fvs. \begin{code} -findImpRuleUsage :: Maybe (Activation -> Bool) -> [CoreRule] -> ImpRuleUsage --- Find the *local* Ids that can be reached transitively, --- via local rules, from each *imported* Id. --- Sigh: this function seems more complicated than it is really worth -findImpRuleUsage Nothing _ = emptyNameEnv -findImpRuleUsage (Just is_active) rules - = mkNameEnv [ (f, mapUFM (\_ -> NoOccInfo) ls) - | f <- rule_names - , let ls = find_lcl_deps f - , not (isEmptyVarSet ls) ] - where - rule_names = map ru_fn rules - rule_name_set = mkNameSet rule_names - - imp_deps :: NameEnv VarSet - -- (f,g) means imported Id 'g' appears in RHS of - -- rule for imported Id 'f', *or* does so transitively - imp_deps = foldr add_imp emptyNameEnv rules - add_imp rule acc - | is_active (ruleActivation rule) - = extendNameEnv_C unionVarSet acc (ru_fn rule) - (exprSomeFreeVars keep_imp (ru_rhs rule)) - | otherwise = acc - keep_imp v = isId v && (idName v `elemNameSet` rule_name_set) - full_imp_deps = transClosureFV (ufmToList imp_deps) - - lcl_deps :: NameEnv VarSet - -- (f, l) means localId 'l' appears immediately - -- in the RHS of a rule for imported Id 'f' - -- Remember, many rules might have the same ru_fn - -- so we do need to fold - lcl_deps = foldr add_lcl emptyNameEnv rules - add_lcl rule acc = extendNameEnv_C unionVarSet acc (ru_fn rule) - (exprFreeIds (ru_rhs rule)) - - find_lcl_deps :: Name -> VarSet - find_lcl_deps f - = foldVarSet (unionVarSet . lookup_lcl . idName) (lookup_lcl f) - (lookupNameEnv full_imp_deps f `orElse` emptyVarSet) - lookup_lcl :: Name -> VarSet - lookup_lcl g = lookupNameEnv lcl_deps g `orElse` emptyVarSet - -------------- -transClosureFV :: Uniquable a => [(a, VarSet)] -> UniqFM VarSet +transClosureFV :: UniqFM VarSet -> UniqFM VarSet -- If (f,g), (g,h) are in the input, then (f,h) is in the output -transClosureFV fv_list +-- as well as (f,g), (g,h) +transClosureFV env | no_change = env - | otherwise = transClosureFV new_fv_list + | otherwise = transClosureFV (listToUFM new_fv_list) where - env = listToUFM fv_list - (no_change, new_fv_list) = mapAccumL bump True fv_list + (no_change, new_fv_list) = mapAccumL bump True (ufmToList env) bump no_change (b,fvs) | no_change_here = (no_change, (b,fvs)) | otherwise = (False, (b,new_fvs)) @@ -1300,17 +1444,21 @@ (new_fvs, no_change_here) = extendFvs env fvs ------------- +extendFvs_ :: UniqFM VarSet -> VarSet -> VarSet +extendFvs_ env s = fst (extendFvs env s) -- Discard the Bool flag + extendFvs :: UniqFM VarSet -> VarSet -> (VarSet, Bool) -- (extendFVs env s) returns -- (s `union` env(s), env(s) `subset` s) extendFvs env s - = foldVarSet add (s, True) s + | isNullUFM env + = (s, True) + | otherwise + = (s `unionVarSet` extras, extras `subVarSet` s) where - add v (vs, no_change_so_far) - = case lookupUFM env v of - Just fvs | not (fvs `subVarSet` s) - -> (vs `unionVarSet` fvs, False) - _ -> (vs, no_change_so_far) + extras :: VarSet -- env(s) + extras = foldUFM unionVarSet emptyVarSet $ + intersectUFM_C (\x _ -> x) env s \end{code} @@ -1321,9 +1469,11 @@ %************************************************************************ \begin{code} -data ProxyEnv - = PE (IdEnv (Id, [(Id,CoercionI)])) VarSet - -- Main env, and its free variables (of both range and domain) +data ProxyEnv -- See Note [ProxyEnv] + = PE (IdEnv -- Domain = scrutinee variables + (Id, -- The scrutinee variable again + [(Id,Coercion)])) -- The case binders that it maps to + VarSet -- Free variables of both range and domain \end{code} Note [ProxyEnv] @@ -1466,6 +1616,17 @@ Notice that later bindings may mention earlier ones, and that we need to go "both ways". +Note [Zap case binders in proxy bindings] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +From the original + case x of cb(dead) { p -> ...x... } +we will get + case x of cb(live) { p -> let x = cb in ...x... } + +Core Lint never expects to find an *occurence* of an Id marked +as Dead, so we must zap the OccInfo on cb before making the +binding x = cb. See Trac #5028. + Historical note [no-case-of-case] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We *used* to suppress the binder-swap in case expressions when @@ -1528,7 +1689,7 @@ information right. \begin{code} -extendProxyEnv :: ProxyEnv -> Id -> CoercionI -> Id -> ProxyEnv +extendProxyEnv :: ProxyEnv -> Id -> Coercion -> Id -> ProxyEnv -- (extendPE x co y) typically arises from -- case (x |> co) of y { ... } -- It extends the proxy env with the binding @@ -1541,7 +1702,7 @@ env2 = extendVarEnv_Acc add single env1 scrut1 (case_bndr,co) single cb_co = (scrut1, [cb_co]) add cb_co (x, cb_cos) = (x, cb_co:cb_cos) - fvs2 = fvs1 `unionVarSet` freeVarsCoI co + fvs2 = fvs1 `unionVarSet` tyCoVarsOfCo co `extendVarSet` case_bndr `extendVarSet` scrut1 @@ -1549,10 +1710,11 @@ -- Localise the scrut_var before shadowing it; we're making a -- new binding for it, and it might have an External Name, or -- even be a GlobalId; Note [Binder swap on GlobalId scrutinees] - -- Also we don't want any INLILNE or NOINLINE pragmas! + -- Also we don't want any INLINE or NOINLINE pragmas! ----------- -type ProxyBind = (Id, Id, CoercionI) +type ProxyBind = (Id, Id, Coercion) + -- (scrut variable, case-binder variable, coercion) getProxies :: OccEnv -> Id -> Bag ProxyBind -- Return a bunch of bindings [...(xi,ei)...] @@ -1562,7 +1724,7 @@ = -- pprTrace "wrapProxies" (ppr case_bndr) $ go_fwd case_bndr where - fwd_pe :: IdEnv (Id, CoercionI) + fwd_pe :: IdEnv (Id, Coercion) fwd_pe = foldVarEnv add1 emptyVarEnv pe where add1 (x,ycos) env = foldr (add2 x) env ycos @@ -1576,23 +1738,23 @@ go_fwd' case_bndr | Just (scrut, co) <- lookupVarEnv fwd_pe case_bndr - = unitBag (scrut, case_bndr, mkSymCoI co) + = unitBag (scrut, case_bndr, mkSymCo co) `unionBags` go_fwd scrut `unionBags` go_bwd scrut [pr | pr@(cb,_) <- lookup_bwd scrut , cb /= case_bndr] | otherwise = emptyBag - lookup_bwd :: Id -> [(Id, CoercionI)] + lookup_bwd :: Id -> [(Id, Coercion)] -- Return case_bndrs that are connected to scrut lookup_bwd scrut = case lookupVarEnv pe scrut of Nothing -> [] Just (_, cb_cos) -> cb_cos - go_bwd :: Id -> [(Id, CoercionI)] -> Bag ProxyBind + go_bwd :: Id -> [(Id, Coercion)] -> Bag ProxyBind go_bwd scrut cb_cos = foldr (unionBags . go_bwd1 scrut) emptyBag cb_cos - go_bwd1 :: Id -> (Id, CoercionI) -> Bag ProxyBind + go_bwd1 :: Id -> (Id, Coercion) -> Bag ProxyBind go_bwd1 scrut (case_bndr, co) = -- pprTrace "go_bwd1" (ppr case_bndr) $ unitBag (case_bndr, scrut, co) @@ -1607,9 +1769,9 @@ where pe = occ_proxy env pe' = case scrut of - Var v -> extendProxyEnv pe v (IdCo (idType v)) cb - Cast (Var v) co -> extendProxyEnv pe v (ACo co) cb - _other -> trimProxyEnv pe [cb] + Var v -> extendProxyEnv pe v (mkReflCo (idType v)) cb + Cast (Var v) co -> extendProxyEnv pe v co cb + _other -> trimProxyEnv pe [cb] ----------- trimOccEnv :: OccEnv -> [CoreBndr] -> OccEnv @@ -1630,12 +1792,7 @@ trim (scrut, cb_cos) | scrut `elemVarSet` bndr_set = (scrut, []) | otherwise = (scrut, filterOut discard cb_cos) discard (cb,co) = bndr_set `intersectsVarSet` - extendVarSet (freeVarsCoI co) cb - ------------ -freeVarsCoI :: CoercionI -> VarSet -freeVarsCoI (IdCo t) = tyVarsOfType t -freeVarsCoI (ACo co) = tyVarsOfType co + extendVarSet (tyCoVarsOfCo co) cb \end{code} @@ -1702,7 +1859,7 @@ setBinderOcc :: UsageDetails -> CoreBndr -> CoreBndr setBinderOcc usage bndr - | isTyCoVar bndr = bndr + | isTyVar bndr = bndr | isExportedId bndr = case idOccInfo bndr of NoOccInfo -> bndr _ -> setIdOccInfo bndr NoOccInfo @@ -1725,12 +1882,15 @@ \begin{code} mkOneOcc :: OccEnv -> Id -> InterestingCxt -> UsageDetails mkOneOcc env id int_cxt - | isLocalId id = unitVarEnv id (OneOcc False True int_cxt) + | isLocalId id + = unitVarEnv id (OneOcc False True int_cxt) + | PE env _ <- occ_proxy env - , id `elemVarEnv` env = unitVarEnv id NoOccInfo - | Just uds <- lookupNameEnv (occ_rule_fvs env) (idName id) - = uds - | otherwise = emptyDetails + , id `elemVarEnv` env + = unitVarEnv id NoOccInfo + + | otherwise + = emptyDetails markMany, markInsideLam, markInsideSCC :: OccInfo -> OccInfo diff -Nru ghc-7.0.3/compiler/simplCore/SAT.lhs ghc-7.2.1/compiler/simplCore/SAT.lhs --- ghc-7.0.3/compiler/simplCore/SAT.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/simplCore/SAT.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -56,6 +56,7 @@ import CoreSyn import CoreUtils import Type +import Coercion import Id import Name import VarEnv @@ -112,7 +113,7 @@ return (Rec (zipEqual "satBind" binders rhss'), mergeIdSATInfos sat_info_rhss') \end{code} \begin{code} -data App = VarApp Id | TypeApp Type +data App = VarApp Id | TypeApp Type | CoApp Coercion data Staticness a = Static a | NotStatic type IdAppInfo = (Id, SATInfo) @@ -133,6 +134,7 @@ pprStaticness :: Staticness App -> SDoc pprStaticness (Static (VarApp _)) = ptext (sLit "SV") pprStaticness (Static (TypeApp _)) = ptext (sLit "ST") +pprStaticness (Static (CoApp _)) = ptext (sLit "SC") pprStaticness NotStatic = ptext (sLit "NS") @@ -142,7 +144,8 @@ mergeSATInfo (NotStatic:statics) (_:apps) = NotStatic : mergeSATInfo statics apps mergeSATInfo (_:statics) (NotStatic:apps) = NotStatic : mergeSATInfo statics apps mergeSATInfo ((Static (VarApp v)):statics) ((Static (VarApp v')):apps) = (if v == v' then Static (VarApp v) else NotStatic) : mergeSATInfo statics apps -mergeSATInfo ((Static (TypeApp t)):statics) ((Static (TypeApp t')):apps) = (if t `coreEqType` t' then Static (TypeApp t) else NotStatic) : mergeSATInfo statics apps +mergeSATInfo ((Static (TypeApp t)):statics) ((Static (TypeApp t')):apps) = (if t `eqType` t' then Static (TypeApp t) else NotStatic) : mergeSATInfo statics apps +mergeSATInfo ((Static (CoApp c)):statics) ((Static (CoApp c')):apps) = (if c `coreEqCoercion` c' then Static (CoApp c) else NotStatic) : mergeSATInfo statics apps mergeSATInfo l r = pprPanic "mergeSATInfo" $ ptext (sLit "Left:") <> pprSATInfo l <> ptext (sLit ", ") <> ptext (sLit "Right:") <> pprSATInfo r @@ -154,9 +157,9 @@ bindersToSATInfo :: [Id] -> SATInfo bindersToSATInfo vs = map (Static . binderToApp) vs - where binderToApp v = if isId v - then VarApp v - else TypeApp $ mkTyVarTy v + where binderToApp v | isId v = VarApp v + | isTyVar v = TypeApp $ mkTyVarTy v + | otherwise = CoApp $ mkCoVarCo v finalizeApp :: Maybe IdAppInfo -> IdSATInfo -> IdSATInfo finalizeApp Nothing id_sat_info = id_sat_info @@ -195,9 +198,10 @@ -- TODO: remove this use of append somehow (use a data structure with O(1) append but a left-to-right kind of interface) let satRemainderWithStaticness arg_staticness = satRemainder $ Just (fn_id, fn_app_info ++ [arg_staticness]) in case arg of - Type t -> satRemainderWithStaticness $ Static (TypeApp t) - Var v -> satRemainderWithStaticness $ Static (VarApp v) - _ -> satRemainderWithStaticness $ NotStatic + Type t -> satRemainderWithStaticness $ Static (TypeApp t) + Coercion c -> satRemainderWithStaticness $ Static (CoApp c) + Var v -> satRemainderWithStaticness $ Static (VarApp v) + _ -> satRemainderWithStaticness $ NotStatic where boring :: CoreExpr -> IdSATInfo -> Maybe IdAppInfo -> SatM (CoreExpr, IdSATInfo, Maybe IdAppInfo) boring fn' sat_info_fn app_info = @@ -229,6 +233,9 @@ satExpr ty@(Type _) _ = do return (ty, emptyIdSATInfo, Nothing) + +satExpr co@(Coercion _) _ = do + return (co, emptyIdSATInfo, Nothing) satExpr (Cast expr coercion) interesting_ids = do (expr', sat_info_expr, expr_app) <- satExpr expr interesting_ids @@ -325,7 +332,7 @@ [Arity 3] GHC.Base.until = \ (@ a_aiK) - (p_a6T :: a_aiK -> GHC.Bool.Bool) + (p_a6T :: a_aiK -> GHC.Types.Bool) (f_a6V :: a_aiK -> a_aiK) (x_a6X :: a_aiK) -> letrec { @@ -335,17 +342,17 @@ \ (x_a6X :: a_aiK) -> let { sat_shadow_r17 :: forall a_a3O. - (a_a3O -> GHC.Bool.Bool) -> (a_a3O -> a_a3O) -> a_a3O -> a_a3O + (a_a3O -> GHC.Types.Bool) -> (a_a3O -> a_a3O) -> a_a3O -> a_a3O [] sat_shadow_r17 = \ (@ a_aiK) - (p_a6T :: a_aiK -> GHC.Bool.Bool) + (p_a6T :: a_aiK -> GHC.Types.Bool) (f_a6V :: a_aiK -> a_aiK) (x_a6X :: a_aiK) -> sat_worker_s1aU x_a6X } in case p_a6T x_a6X of wild_X3y [ALWAYS Dead Nothing] { - GHC.Bool.False -> GHC.Base.until @ a_aiK p_a6T f_a6V (f_a6V x_a6X); - GHC.Bool.True -> x_a6X + GHC.Types.False -> GHC.Base.until @ a_aiK p_a6T f_a6V (f_a6V x_a6X); + GHC.Types.True -> x_a6X }; } in sat_worker_s1aU x_a6X diff -Nru ghc-7.0.3/compiler/simplCore/SetLevels.lhs ghc-7.2.1/compiler/simplCore/SetLevels.lhs --- ghc-7.0.3/compiler/simplCore/SetLevels.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/simplCore/SetLevels.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -46,7 +46,8 @@ setLevels, Level(..), tOP_LEVEL, - LevelledBind, LevelledExpr, + LevelledBind, LevelledExpr, LevelledBndr, + FloatSpec(..), floatSpecLevel, incMinorLvl, ltMajLvl, ltLvl, isTopLvl ) where @@ -55,11 +56,11 @@ import CoreSyn import CoreMonad ( FloatOutSwitches(..) ) -import CoreUtils ( exprType, mkPiTypes ) +import CoreUtils ( exprType, exprOkForSpeculation, mkPiTypes ) import CoreArity ( exprBotStrictness_maybe ) import CoreFVs -- all of it -import CoreSubst ( Subst, emptySubst, extendInScope, extendInScopeList, - extendIdSubst, cloneIdBndr, cloneRecIdBndrs ) +import CoreSubst ( Subst, emptySubst, extendInScope, substBndr, substRecBndrs, + extendIdSubst, cloneBndrs, cloneIdBndr, cloneRecIdBndrs ) import Id import IdInfo import Var @@ -69,7 +70,7 @@ import Name ( getOccName, mkSystemVarName ) import OccName ( occNameString ) import Type ( isUnLiftedType, Type ) -import BasicTypes ( TopLevelFlag(..), Arity ) +import BasicTypes ( Arity ) import UniqSupply import Util import Outputable @@ -83,9 +84,23 @@ %************************************************************************ \begin{code} +type LevelledExpr = TaggedExpr FloatSpec +type LevelledBind = TaggedBind FloatSpec +type LevelledBndr = TaggedBndr FloatSpec + data Level = Level Int -- Level number of enclosing lambdas Int -- Number of big-lambda and/or case expressions between -- here and the nearest enclosing lambda + +data FloatSpec + = FloatMe Level -- Float to just inside the binding + -- tagged with this level + | StayPut Level -- Stay where it is; binding is + -- tagged with tihs level + +floatSpecLevel :: FloatSpec -> Level +floatSpecLevel (FloatMe l) = l +floatSpecLevel (StayPut l) = l \end{code} The {\em level number} on a (type-)lambda-bound variable is the @@ -143,8 +158,9 @@ the worker at all. \begin{code} -type LevelledExpr = TaggedExpr Level -type LevelledBind = TaggedBind Level +instance Outputable FloatSpec where + ppr (FloatMe l) = char 'F' <> ppr l + ppr (StayPut l) = ppr l tOP_LEVEL :: Level tOP_LEVEL = Level 0 0 @@ -205,12 +221,18 @@ ; return (lvld_bind : lvld_binds) } lvlTopBind :: LevelEnv -> Bind Id -> LvlM (LevelledBind, LevelEnv) -lvlTopBind env (NonRec binder rhs) - = lvlBind TopLevel tOP_LEVEL env (AnnNonRec binder (freeVars rhs)) - -- Rhs can have no free vars! +lvlTopBind env (NonRec bndr rhs) + = do rhs' <- lvlExpr tOP_LEVEL env (freeVars rhs) + let bndr' = TB bndr (StayPut tOP_LEVEL) + env' = extendLvlEnv env [bndr'] + return (NonRec bndr' rhs', env') lvlTopBind env (Rec pairs) - = lvlBind TopLevel tOP_LEVEL env (AnnRec [(b,freeVars rhs) | (b,rhs) <- pairs]) + = do let (bndrs,rhss) = unzip pairs + bndrs' = [TB b (StayPut tOP_LEVEL) | b <- bndrs] + env' = extendLvlEnv env bndrs' + rhss' <- mapM (lvlExpr tOP_LEVEL env' . freeVars) rhss + return (Rec (bndrs' `zip` rhss'), env') \end{code} %************************************************************************ @@ -243,6 +265,7 @@ \begin{code} lvlExpr _ _ ( _, AnnType ty) = return (Type ty) +lvlExpr _ _ ( _, AnnCoercion co) = return (Coercion co) lvlExpr _ env (_, AnnVar v) = return (lookupVar env v) lvlExpr _ _ (_, AnnLit lit) = return (Lit lit) @@ -287,7 +310,7 @@ expr' <- lvlExpr ctxt_lvl env expr return (Note note expr') -lvlExpr ctxt_lvl env (_, AnnCast expr co) = do +lvlExpr ctxt_lvl env (_, AnnCast expr (_, co)) = do expr' <- lvlExpr ctxt_lvl env expr return (Cast expr' co) @@ -312,41 +335,42 @@ -- but not nearly so much now non-recursive newtypes are transparent. -- [See SetLevels rev 1.50 for a version with this approach.] -lvlExpr ctxt_lvl env (_, AnnLet (AnnNonRec bndr rhs) body) - | isUnLiftedType (idType bndr) = do - -- Treat unlifted let-bindings (let x = b in e) just like (case b of x -> e) - -- That is, leave it exactly where it is - -- We used to float unlifted bindings too (e.g. to get a cheap primop - -- outside a lambda (to see how, look at lvlBind in rev 1.58) - -- but an unrelated change meant that these unlifed bindings - -- could get to the top level which is bad. And there's not much point; - -- unlifted bindings are always cheap, and so hardly worth floating. - rhs' <- lvlExpr ctxt_lvl env rhs - body' <- lvlExpr incd_lvl env' body - return (Let (NonRec bndr' rhs') body') - where - incd_lvl = incMinorLvl ctxt_lvl - bndr' = TB bndr incd_lvl - env' = extendLvlEnv env [bndr'] - lvlExpr ctxt_lvl env (_, AnnLet bind body) = do - (bind', new_env) <- lvlBind NotTopLevel ctxt_lvl env bind - body' <- lvlExpr ctxt_lvl new_env body + (bind', new_lvl, new_env) <- lvlBind ctxt_lvl env bind + body' <- lvlExpr new_lvl new_env body return (Let bind' body') -lvlExpr ctxt_lvl env (_, AnnCase expr case_bndr ty alts) = do - expr' <- lvlMFE True ctxt_lvl env expr - let alts_env = extendCaseBndrLvlEnv env expr' case_bndr incd_lvl - alts' <- mapM (lvl_alt alts_env) alts - return (Case expr' (TB case_bndr incd_lvl) ty alts') +lvlExpr ctxt_lvl env (_, AnnCase scrut@(scrut_fvs,_) case_bndr ty alts) + | [(con@(DataAlt {}), bs, rhs)] <- alts + , exprOkForSpeculation (deAnnotate scrut) + , not (isTopLvl dest_lvl) -- Can't have top-level cases + = -- Float the case + do { scrut' <- lvlMFE True ctxt_lvl env scrut + ; (rhs_env, (case_bndr':bs')) <- cloneVars env (case_bndr:bs) dest_lvl + -- We don't need to use extendCaseBndrLvlEnv here + -- because we are floating the case outwards so + -- no need to do the binder-swap thing + ; rhs' <- lvlMFE True ctxt_lvl rhs_env rhs + ; let alt' = (con, [TB b (StayPut dest_lvl) | b <- bs'], rhs') + ; return (Case scrut' (TB case_bndr' (FloatMe dest_lvl)) ty [alt']) } + + | otherwise -- Stays put + = do { scrut' <- lvlMFE True ctxt_lvl env scrut + ; let case_bndr' = TB case_bndr bndr_spec + alts_env = extendCaseBndrLvlEnv env scrut' case_bndr' + ; alts' <- mapM (lvl_alt alts_env) alts + ; return (Case scrut' case_bndr' ty alts') } where incd_lvl = incMinorLvl ctxt_lvl - - lvl_alt alts_env (con, bs, rhs) = do - rhs' <- lvlMFE True incd_lvl new_env rhs - return (con, bs', rhs') + bndr_spec = StayPut incd_lvl + dest_lvl = maxFvLevel (const True) env scrut_fvs + -- Don't abstact over type variables, hence const True + + lvl_alt alts_env (con, bs, rhs) + = do { rhs' <- lvlMFE True incd_lvl new_env rhs + ; return (con, bs', rhs') } where - bs' = [ TB b incd_lvl | b <- bs ] + bs' = [ TB b bndr_spec | b <- bs ] new_env = extendLvlEnv alts_env bs' \end{code} @@ -414,7 +438,7 @@ = do { e' <- lvlMFE strict_ctxt ctxt_lvl env e ; return (Note n e') } -lvlMFE strict_ctxt ctxt_lvl env (_, AnnCast e co) +lvlMFE strict_ctxt ctxt_lvl env (_, AnnCast e (_, co)) = do { e' <- lvlMFE strict_ctxt ctxt_lvl env e ; return (Cast e' co) } @@ -423,16 +447,18 @@ = lvlExpr ctxt_lvl env e -- Don't share cases lvlMFE strict_ctxt ctxt_lvl env ann_expr@(fvs, _) - | isUnLiftedType ty -- Can't let-bind it; see Note [Unlifted MFEs] + | isUnLiftedType ty -- Can't let-bind it; see Note [Unlifted MFEs] + -- This includes coercions, which we don't + -- want to float anyway || notWorthFloating ann_expr abs_vars - || not good_destination + || not float_me = -- Don't float it out lvlExpr ctxt_lvl env ann_expr | otherwise -- Float it out! = do expr' <- lvlFloatRhs abs_vars dest_lvl env ann_expr var <- newLvlVar abs_vars ty mb_bot - return (Let (NonRec (TB var dest_lvl) expr') + return (Let (NonRec (TB var (FloatMe dest_lvl)) expr') (mkVarApps (Var var) abs_vars)) where expr = deAnnotate ann_expr @@ -443,16 +469,13 @@ -- A decision to float entails let-binding this thing, and we only do -- that if we'll escape a value lambda, or will go to the top level. - good_destination - | dest_lvl `ltMajLvl` ctxt_lvl -- Escapes a value lambda - = True - -- OLD CODE: not (exprIsCheap expr) || isTopLvl dest_lvl - -- see Note [Escaping a value lambda] - - | otherwise -- Does not escape a value lambda - = isTopLvl dest_lvl -- Only float if we are going to the top level - && floatConsts env -- and the floatConsts flag is on - && not strict_ctxt -- Don't float from a strict context + float_me = dest_lvl `ltMajLvl` ctxt_lvl -- Escapes a value lambda + -- OLD CODE: not (exprIsCheap expr) || isTopLvl dest_lvl + -- see Note [Escaping a value lambda] + + || (isTopLvl dest_lvl -- Only float if we are going to the top level + && floatConsts env -- and the floatConsts flag is on + && not strict_ctxt) -- Don't float from a strict context -- We are keen to float something to the top level, even if it does not -- escape a lambda, because then it needs no allocation. But it's controlled -- by a flag, because doing this too early loses opportunities for RULES @@ -462,9 +485,12 @@ -- Beware: -- concat = /\ a -> foldr ..a.. (++) [] -- was getting turned into - -- concat = /\ a -> lvl a -- lvl = /\ a -> foldr ..a.. (++) [] + -- concat = /\ a -> lvl a -- which is pretty stupid. Hence the strict_ctxt test + -- + -- Also a strict contxt includes uboxed values, and they + -- can't be bound at top level annotateBotStr :: Id -> Maybe (Arity, StrictSig) -> Id annotateBotStr id Nothing = id @@ -491,6 +517,7 @@ go (_, AnnCast e _) n = go e n go (_, AnnApp e arg) n | (_, AnnType {}) <- arg = go e n + | (_, AnnCoercion {}) <- arg = go e n | n==0 = False | is_triv arg = go e (n-1) | otherwise = False @@ -500,6 +527,7 @@ is_triv (_, AnnVar {}) = True -- (ie not worth floating) is_triv (_, AnnCast e _) = is_triv e is_triv (_, AnnApp e (_, AnnType {})) = is_triv e + is_triv (_, AnnApp e (_, AnnCoercion {})) = is_triv e is_triv _ = False \end{code} @@ -555,30 +583,39 @@ The binding stuff works for top level too. \begin{code} -lvlBind :: TopLevelFlag -- Used solely to decide whether to clone - -> Level -- Context level; might be Top even for bindings nested in the RHS - -- of a top level binding +lvlBind :: Level -- Context level; might be Top even for bindings + -- nested in the RHS of a top level binding -> LevelEnv -> CoreBindWithFVs - -> LvlM (LevelledBind, LevelEnv) + -> LvlM (LevelledBind, Level, LevelEnv) -lvlBind top_lvl ctxt_lvl env (AnnNonRec bndr rhs@(rhs_fvs,_)) - | isTyCoVar bndr -- Don't do anything for TyVar binders - -- (simplifier gets rid of them pronto) - = do rhs' <- lvlExpr ctxt_lvl env rhs - return (NonRec (TB bndr ctxt_lvl) rhs', env) +lvlBind ctxt_lvl env (AnnNonRec bndr rhs@(rhs_fvs,_)) + | isTyVar bndr -- Don't do anything for TyVar binders + -- (simplifier gets rid of them pronto) + || not (profitableFloat ctxt_lvl dest_lvl) + || (isTopLvl dest_lvl && isUnLiftedType (idType bndr)) + -- We can't float an unlifted binding to top level, so we don't + -- float it at all. It's a bit brutal, but unlifted bindings + -- aren't expensive either + = -- No float + do rhs' <- lvlExpr ctxt_lvl env rhs + let (env', bndr') = substLetBndrNonRec env bndr bind_lvl + bind_lvl = incMinorLvl ctxt_lvl + tagged_bndr = TB bndr' (StayPut bind_lvl) + return (NonRec tagged_bndr rhs', bind_lvl, env') + -- Otherwise we are going to float | null abs_vars = do -- No type abstraction; clone existing binder rhs' <- lvlExpr dest_lvl env rhs - (env', bndr') <- cloneVar top_lvl env bndr ctxt_lvl dest_lvl - return (NonRec (TB bndr' dest_lvl) rhs', env') + (env', bndr') <- cloneVar env bndr dest_lvl + return (NonRec (TB bndr' (FloatMe dest_lvl)) rhs', ctxt_lvl, env') | otherwise = do -- Yes, type abstraction; create a new binder, extend substitution, etc rhs' <- lvlFloatRhs abs_vars dest_lvl env rhs (env', [bndr']) <- newPolyBndrs dest_lvl env abs_vars [bndr_w_str] - return (NonRec (TB bndr' dest_lvl) rhs', env') + return (NonRec (TB bndr' (FloatMe dest_lvl)) rhs', ctxt_lvl, env') where bind_fvs = rhs_fvs `unionVarSet` idFreeVars bndr @@ -586,15 +623,21 @@ dest_lvl = destLevel env bind_fvs (isFunction rhs) mb_bot mb_bot = exprBotStrictness_maybe (deAnnotate rhs) bndr_w_str = annotateBotStr bndr mb_bot -\end{code} +lvlBind ctxt_lvl env (AnnRec pairs) + | not (profitableFloat ctxt_lvl dest_lvl) + = do let bind_lvl = incMinorLvl ctxt_lvl + (env', bndrs') = substLetBndrsRec env bndrs bind_lvl + tagged_bndrs = [ TB bndr' (StayPut bind_lvl) + | bndr' <- bndrs' ] + rhss' <- mapM (lvlExpr bind_lvl env') rhss + return (Rec (tagged_bndrs `zip` rhss'), bind_lvl, env') -\begin{code} -lvlBind top_lvl ctxt_lvl env (AnnRec pairs) | null abs_vars - = do (new_env, new_bndrs) <- cloneRecVars top_lvl env bndrs ctxt_lvl dest_lvl + = do (new_env, new_bndrs) <- cloneRecVars env bndrs dest_lvl new_rhss <- mapM (lvlExpr ctxt_lvl new_env) rhss - return (Rec ([TB b dest_lvl | b <- new_bndrs] `zip` new_rhss), new_env) + return ( Rec ([TB b (FloatMe dest_lvl) | b <- new_bndrs] `zip` new_rhss) + , ctxt_lvl, new_env) -- ToDo: when enabling the floatLambda stuff, -- I think we want to stop doing this @@ -613,42 +656,50 @@ (bndr,rhs) = head pairs (rhs_lvl, abs_vars_w_lvls) = lvlLamBndrs dest_lvl abs_vars rhs_env = extendLvlEnv env abs_vars_w_lvls - (rhs_env', new_bndr) <- cloneVar NotTopLevel rhs_env bndr rhs_lvl rhs_lvl + (rhs_env', new_bndr) <- cloneVar rhs_env bndr rhs_lvl let (lam_bndrs, rhs_body) = collectAnnBndrs rhs (body_lvl, new_lam_bndrs) = lvlLamBndrs rhs_lvl lam_bndrs body_env = extendLvlEnv rhs_env' new_lam_bndrs new_rhs_body <- lvlExpr body_lvl body_env rhs_body (poly_env, [poly_bndr]) <- newPolyBndrs dest_lvl env abs_vars [bndr] - return (Rec [(TB poly_bndr dest_lvl, - mkLams abs_vars_w_lvls $ - mkLams new_lam_bndrs $ - Let (Rec [(TB new_bndr rhs_lvl, mkLams new_lam_bndrs new_rhs_body)]) - (mkVarApps (Var new_bndr) lam_bndrs))], - poly_env) + return (Rec [(TB poly_bndr (FloatMe dest_lvl) + , mkLams abs_vars_w_lvls $ + mkLams new_lam_bndrs $ + Let (Rec [( TB new_bndr (StayPut rhs_lvl) + , mkLams new_lam_bndrs new_rhs_body)]) + (mkVarApps (Var new_bndr) lam_bndrs))] + , ctxt_lvl + , poly_env) | otherwise = do -- Non-null abs_vars (new_env, new_bndrs) <- newPolyBndrs dest_lvl env abs_vars bndrs new_rhss <- mapM (lvlFloatRhs abs_vars dest_lvl new_env) rhss - return (Rec ([TB b dest_lvl | b <- new_bndrs] `zip` new_rhss), new_env) + return ( Rec ([TB b (FloatMe dest_lvl) | b <- new_bndrs] `zip` new_rhss) + , ctxt_lvl, new_env) where (bndrs,rhss) = unzip pairs -- Finding the free vars of the binding group is annoying - bind_fvs = (unionVarSets [ idFreeVars bndr `unionVarSet` rhs_fvs - | (bndr, (rhs_fvs,_)) <- pairs]) - `minusVarSet` - mkVarSet bndrs + bind_fvs = (unionVarSets [ idFreeVars bndr `unionVarSet` rhs_fvs + | (bndr, (rhs_fvs,_)) <- pairs]) + `minusVarSet` + mkVarSet bndrs dest_lvl = destLevel env bind_fvs (all isFunction rhss) Nothing abs_vars = abstractVars dest_lvl env bind_fvs +profitableFloat :: Level -> Level -> Bool +profitableFloat ctxt_lvl dest_lvl + = (dest_lvl `ltMajLvl` ctxt_lvl) -- Escapes a value lambda + || isTopLvl dest_lvl -- Going all the way to top level + ---------------------------------------------------- -- Three help functions for the type-abstraction case lvlFloatRhs :: [CoreBndr] -> Level -> LevelEnv -> CoreExprWithFVs - -> UniqSM (Expr (TaggedBndr Level)) + -> UniqSM (Expr LevelledBndr) lvlFloatRhs abs_vars dest_lvl env rhs = do rhs' <- lvlExpr rhs_lvl rhs_env rhs return (mkLams abs_vars_w_lvls rhs') @@ -665,7 +716,7 @@ %************************************************************************ \begin{code} -lvlLamBndrs :: Level -> [CoreBndr] -> (Level, [TaggedBndr Level]) +lvlLamBndrs :: Level -> [CoreBndr] -> (Level, [LevelledBndr]) -- Compute the levels for the binders of a lambda group -- The binders returned are exactly the same as the ones passed, -- but they are now paired with a level @@ -673,26 +724,15 @@ = (lvl, []) lvlLamBndrs lvl bndrs - = go (incMinorLvl lvl) - False -- Havn't bumped major level in this group - [] bndrs - where - go old_lvl bumped_major rev_lvld_bndrs (bndr:bndrs) - | isId bndr && -- Go to the next major level if this is a value binder, - not bumped_major && -- and we havn't already gone to the next level (one jump per group) - not (isOneShotLambda bndr) -- and it isn't a one-shot lambda - = go new_lvl True (TB bndr new_lvl : rev_lvld_bndrs) bndrs - - | otherwise - = go old_lvl bumped_major (TB bndr old_lvl : rev_lvld_bndrs) bndrs - - where - new_lvl = incMajorLvl old_lvl + = (new_lvl, [TB bndr (StayPut new_lvl) | bndr <- bndrs]) + -- All the new binders get the same level, because + -- any floating binding is either going to float past + -- all or none. We never separate binders + where + new_lvl | any is_major bndrs = incMajorLvl lvl + | otherwise = incMinorLvl lvl - go old_lvl _ rev_lvld_bndrs [] - = (old_lvl, reverse rev_lvld_bndrs) - -- a lambda like this (\x -> coerce t (\s -> ...)) - -- This happens quite a bit in state-transformer programs + is_major bndr = isId bndr && not (isOneShotLambda bndr) \end{code} \begin{code} @@ -707,8 +747,9 @@ , is_function , countFreeIds fvs <= n_args = tOP_LEVEL -- Send functions to top level; see - -- the comments with isFunction - | otherwise = maxIdLevel env fvs + -- the comments with isFunction + | otherwise = maxFvLevel isId env fvs -- Max over Ids only; the tyvars + -- will be abstracted isFunction :: CoreExprWithFVs -> Bool -- The idea here is that we want to float *functions* to @@ -788,7 +829,7 @@ floatPAPs :: LevelEnv -> Bool floatPAPs le = floatOutPartialApplications (le_switches le) -extendLvlEnv :: LevelEnv -> [TaggedBndr Level] -> LevelEnv +extendLvlEnv :: LevelEnv -> [LevelledBndr] -> LevelEnv -- Used when *not* cloning extendLvlEnv le@(LE { le_lvl_env = lvl_env, le_subst = subst, le_env = id_env }) prs @@ -796,7 +837,7 @@ , le_subst = foldl del_subst subst prs , le_env = foldl del_id id_env prs } where - add_lvl env (TB v l) = extendVarEnv env v l + add_lvl env (TB v s) = extendVarEnv env v (floatSpecLevel s) del_subst env (TB v _) = extendInScope env v del_id env (TB v _) = delVarEnv env v -- We must remove any clone for this variable name in case of @@ -813,26 +854,17 @@ -- incorrectly, because the SubstEnv was still lying around. Ouch! -- KSW 2000-07. -extendInScopeEnv :: LevelEnv -> Var -> LevelEnv -extendInScopeEnv le@(LE { le_subst = subst }) v - = le { le_subst = extendInScope subst v } - -extendInScopeEnvList :: LevelEnv -> [Var] -> LevelEnv -extendInScopeEnvList le@(LE { le_subst = subst }) vs - = le { le_subst = extendInScopeList subst vs } - -- extendCaseBndrLvlEnv adds the mapping case-bndr->scrut-var if it can -- (see point 4 of the module overview comment) -extendCaseBndrLvlEnv :: LevelEnv -> Expr (TaggedBndr Level) -> Var -> Level - -> LevelEnv -extendCaseBndrLvlEnv le@(LE { le_lvl_env = lvl_env, le_subst = subst, le_env = id_env }) - (Var scrut_var) case_bndr lvl - = le { le_lvl_env = extendVarEnv lvl_env case_bndr lvl - , le_subst = extendIdSubst subst case_bndr (Var scrut_var) +extendCaseBndrLvlEnv :: LevelEnv -> Expr LevelledBndr + -> LevelledBndr -> LevelEnv +extendCaseBndrLvlEnv le@(LE { le_subst = subst, le_env = id_env }) + (Var scrut_var) (TB case_bndr _) + = le { le_subst = extendIdSubst subst case_bndr (Var scrut_var) , le_env = extendVarEnv id_env case_bndr ([scrut_var], Var scrut_var) } -extendCaseBndrLvlEnv env _scrut case_bndr lvl - = extendLvlEnv env [TB case_bndr lvl] +extendCaseBndrLvlEnv env _scrut case_bndr + = extendLvlEnv env [case_bndr] extendPolyLvlEnv :: Level -> LevelEnv -> [Var] -> [(Var, Var)] -> LevelEnv extendPolyLvlEnv dest_lvl @@ -849,26 +881,27 @@ extendCloneLvlEnv :: Level -> LevelEnv -> Subst -> [(Var, Var)] -> LevelEnv extendCloneLvlEnv lvl le@(LE { le_lvl_env = lvl_env, le_env = id_env }) new_subst bndr_pairs - = le { le_lvl_env = foldl add_lvl lvl_env bndr_pairs + = le { le_lvl_env = foldl add_lvl lvl_env bndr_pairs , le_subst = new_subst - , le_env = foldl add_id id_env bndr_pairs } + , le_env = foldl add_id id_env bndr_pairs } where add_lvl env (_, v') = extendVarEnv env v' lvl add_id env (v, v') = extendVarEnv env v ([v'], Var v') -maxIdLevel :: LevelEnv -> VarSet -> Level -maxIdLevel (LE { le_lvl_env = lvl_env, le_env = id_env }) var_set +maxFvLevel :: (Var -> Bool) -> LevelEnv -> VarSet -> Level +maxFvLevel max_me (LE { le_lvl_env = lvl_env, le_env = id_env }) var_set = foldVarSet max_in tOP_LEVEL var_set where - max_in in_var lvl = foldr max_out lvl (case lookupVarEnv id_env in_var of - Just (abs_vars, _) -> abs_vars - Nothing -> [in_var]) + max_in in_var lvl + = foldr max_out lvl (case lookupVarEnv id_env in_var of + Just (abs_vars, _) -> abs_vars + Nothing -> [in_var]) max_out out_var lvl - | isId out_var = case lookupVarEnv lvl_env out_var of + | max_me out_var = case lookupVarEnv lvl_env out_var of Just lvl' -> maxLvl lvl' lvl Nothing -> lvl - | otherwise = lvl -- Ignore tyvars in *maxIdLevel* + | otherwise = lvl -- Ignore some vars depending on max_me lookupVar :: LevelEnv -> Id -> LevelledExpr lookupVar le v = case lookupVarEnv (le_env le) v of @@ -894,7 +927,7 @@ (False, True) -> False _ -> v1 <= v2 -- Same family - is_tv v = isTyCoVar v && not (isCoVar v) + is_tv v = isTyVar v uniq :: [Var] -> [Var] -- Remove adjacent duplicates; the sort will have brought them together @@ -925,9 +958,7 @@ absVarsOf id_env v | isId v = [av2 | av1 <- lookup_avs v , av2 <- add_tyvars av1] - | isCoVar v = add_tyvars v - | otherwise = [v] - + | otherwise = ASSERT( isTyVar v ) [v] where lookup_avs v = case lookupVarEnv id_env v of Just (abs_vars, _) -> abs_vars @@ -975,39 +1006,70 @@ -- The deeply tiresome thing is that we have to apply the substitution -- to the rules inside each Id. Grr. But it matters. -cloneVar :: TopLevelFlag -> LevelEnv -> Id -> Level -> Level -> LvlM (LevelEnv, Id) -cloneVar TopLevel env v _ _ - = return (extendInScopeEnv env v, v) -- Don't clone top level things - -- But do extend the in-scope env, to satisfy the in-scope invariant +substLetBndrNonRec :: LevelEnv -> Id -> Level -> (LevelEnv, Id) +substLetBndrNonRec + le@(LE { le_lvl_env = lvl_env, le_subst = subst, le_env = id_env }) + bndr bind_lvl + = ASSERT( isId bndr ) + (env', bndr' ) + where + (subst', bndr') = substBndr subst bndr + env' = le { le_lvl_env = extendVarEnv lvl_env bndr bind_lvl + , le_subst = subst' + , le_env = delVarEnv id_env bndr } + +substLetBndrsRec :: LevelEnv -> [Id] -> Level -> (LevelEnv, [Id]) +substLetBndrsRec + le@(LE { le_lvl_env = lvl_env, le_subst = subst, le_env = id_env }) + bndrs bind_lvl + = ASSERT( all isId bndrs ) + (env', bndrs') + where + (subst', bndrs') = substRecBndrs subst bndrs + env' = le { le_lvl_env = extendVarEnvList lvl_env [(b,bind_lvl) | b <- bndrs] + , le_subst = subst' + , le_env = delVarEnvList id_env bndrs } + +cloneVar :: LevelEnv -> Id -> Level -> LvlM (LevelEnv, Id) +cloneVar env v dest_lvl + = ASSERT( isId v ) + do { us <- getUniqueSupplyM + ; let (subst', v1) = cloneIdBndr (le_subst env) us v + v2 = zapDemandIdInfo v1 + env' = extendCloneLvlEnv dest_lvl env subst' [(v,v2)] + ; return (env', v2) } + +cloneVars :: LevelEnv -> [Var] -> Level -> LvlM (LevelEnv, [Var]) +cloneVars env vs dest_lvl -- Works for tyvars etc too; typically case alts + = do { us <- getUniqueSupplyM + ; let (subst', vs1) = cloneBndrs (le_subst env) us vs + vs2 = map zap_demand vs1 + env' = extendCloneLvlEnv dest_lvl env subst' (vs `zip` vs2) + ; return (env', vs2) } + where + zap_demand :: Var -> Var -- Note [Zapping the demand info] + zap_demand v | not (isId v) = v + | otherwise = zapDemandIdInfo v -cloneVar NotTopLevel env v ctxt_lvl dest_lvl - = ASSERT( isId v ) do - us <- getUniqueSupplyM - let - (subst', v1) = cloneIdBndr (le_subst env) us v - v2 = zap_demand ctxt_lvl dest_lvl v1 - env' = extendCloneLvlEnv dest_lvl env subst' [(v,v2)] - return (env', v2) - -cloneRecVars :: TopLevelFlag -> LevelEnv -> [Id] -> Level -> Level -> LvlM (LevelEnv, [Id]) -cloneRecVars TopLevel env vs _ _ - = return (extendInScopeEnvList env vs, vs) -- Don't clone top level things -cloneRecVars NotTopLevel env vs ctxt_lvl dest_lvl + +cloneRecVars :: LevelEnv -> [Id] -> Level -> LvlM (LevelEnv, [Id]) +cloneRecVars env vs dest_lvl = ASSERT( all isId vs ) do us <- getUniqueSupplyM let (subst', vs1) = cloneRecIdBndrs (le_subst env) us vs - vs2 = map (zap_demand ctxt_lvl dest_lvl) vs1 + vs2 = map zapDemandIdInfo vs1 -- Note [Zapping the demand info] env' = extendCloneLvlEnv dest_lvl env subst' (vs `zip` vs2) return (env', vs2) - - -- VERY IMPORTANT: we must zap the demand info - -- if the thing is going to float out past a lambda, - -- or if it's going to top level (where things can't be strict) -zap_demand :: Level -> Level -> Id -> Id -zap_demand dest_lvl ctxt_lvl id - | ctxt_lvl == dest_lvl, - not (isTopLvl dest_lvl) = id -- Stays, and not going to top level - | otherwise = zapDemandIdInfo id -- Floats out \end{code} + +Note [Zapping the demand info] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +VERY IMPORTANT: we must zap the demand info if the thing is going to +float out, becuause it may be less demanded than at its original +binding site. Eg + f :: Int -> Int + f x = let v = 3*4 in v+x +Here v is strict; but if we float v to top level, it isn't any more. + diff -Nru ghc-7.0.3/compiler/simplCore/SimplCore.lhs ghc-7.2.1/compiler/simplCore/SimplCore.lhs --- ghc-7.0.3/compiler/simplCore/SimplCore.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/simplCore/SimplCore.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -8,7 +8,7 @@ #include "HsVersions.h" -import DynFlags ( DynFlags, DynFlag(..), dopt ) +import DynFlags import CoreSyn import CoreSubst import HscTypes @@ -29,7 +29,7 @@ import FloatOut ( floatOutwards ) import FamInstEnv import Id -import BasicTypes ( CompilerPhase, isDefaultInlinePragma ) +import BasicTypes ( CompilerPhase(..), isDefaultInlinePragma ) import VarSet import VarEnv import LiberateCase ( liberateCase ) @@ -45,6 +45,16 @@ import UniqSupply ( UniqSupply, mkSplitUniqSupply, splitUniqSupply ) import Outputable import Control.Monad + +#ifdef GHCI +import Type ( mkTyConTy ) +import RdrName ( mkRdrQual ) +import OccName ( mkVarOcc ) +import PrelNames ( pluginTyConName ) +import DynamicLoading ( forceLoadTyCon, lookupRdrNameInModule, getValueSafely ) +import Module ( ModuleName ) +import Panic +#endif \end{code} %************************************************************************ @@ -57,9 +67,18 @@ core2core :: HscEnv -> ModGuts -> IO ModGuts core2core hsc_env guts = do { us <- mkSplitUniqSupply 's' - ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base us mod $ - doCorePasses (getCoreToDo dflags) guts + -- make sure all plugins are loaded + ; let builtin_passes = getCoreToDo dflags + ; + ; (guts2, stats) <- runCoreM hsc_env hpt_rule_base us mod $ + do { all_passes <- addPluginPasses dflags builtin_passes + ; runCorePasses all_passes guts } + +{-- + ; Err.dumpIfSet_dyn dflags Opt_D_dump_core_pipeline + "Plugin information" "" -- TODO FIXME: dump plugin info +--} ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl_stats "Grand total simplifier statistics" (pprSimplCount stats) @@ -75,16 +94,262 @@ -- consume the ModGuts to find the module) but somewhat ugly because mg_module may -- _theoretically_ be changed during the Core pipeline (it's part of ModGuts), which -- would mean our cached value would go out of date. +\end{code} + + +%************************************************************************ +%* * + Generating the main optimisation pipeline +%* * +%************************************************************************ + +\begin{code} +getCoreToDo :: DynFlags -> [CoreToDo] +getCoreToDo dflags + = core_todo + where + opt_level = optLevel dflags + phases = simplPhases dflags + max_iter = maxSimplIterations dflags + rule_check = ruleCheck dflags + strictness = dopt Opt_Strictness dflags + full_laziness = dopt Opt_FullLaziness dflags + do_specialise = dopt Opt_Specialise dflags + do_float_in = dopt Opt_FloatIn dflags + cse = dopt Opt_CSE dflags + spec_constr = dopt Opt_SpecConstr dflags + liberate_case = dopt Opt_LiberateCase dflags + static_args = dopt Opt_StaticArgumentTransformation dflags + rules_on = dopt Opt_EnableRewriteRules dflags + eta_expand_on = dopt Opt_DoLambdaEtaExpansion dflags + + maybe_rule_check phase = runMaybe rule_check (CoreDoRuleCheck phase) + + maybe_strictness_before phase + = runWhen (phase `elem` strictnessBefore dflags) CoreDoStrictness + + base_mode = SimplMode { sm_phase = panic "base_mode" + , sm_names = [] + , sm_rules = rules_on + , sm_eta_expand = eta_expand_on + , sm_inline = True + , sm_case_case = True } + + simpl_phase phase names iter + = CoreDoPasses + $ [ maybe_strictness_before phase + , CoreDoSimplify iter + (base_mode { sm_phase = Phase phase + , sm_names = names }) + + , 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) $ + CoreDoPasses [ simpl_gently, CoreDoVectorisation ] + + -- By default, we have 2 phases before phase 0. + + -- Want to run with inline phase 2 after the specialiser to give + -- maximum chance for fusion to work before we inline build/augment + -- in phase 1. This made a difference in 'ansi' where an + -- overloaded function wasn't inlined till too late. + + -- Need phase 1 so that build/augment get + -- inlined. I found that spectral/hartel/genfft lost some useful + -- strictness in the function sumcode' if augment is not inlined + -- before strictness analysis runs + simpl_phases = CoreDoPasses [ simpl_phase phase ["main"] max_iter + | phase <- [phases, phases-1 .. 1] ] + + + -- initial simplify: mk specialiser happy: minimum effort please + simpl_gently = CoreDoSimplify max_iter + (base_mode { sm_phase = InitialPhase + , sm_names = ["Gentle"] + , sm_rules = rules_on -- Note [RULEs enabled in SimplGently] + , sm_inline = False + , sm_case_case = False }) + -- Don't do case-of-case transformations. + -- This makes full laziness work better + + core_todo = + if opt_level == 0 then + [vectorisation, + simpl_phase 0 ["final"] max_iter] + else {- opt_level >= 1 -} [ + + -- We want to do the static argument transform before full laziness as it + -- may expose extra opportunities to float things outwards. However, to fix + -- up the output of the transformation we need at do at least one simplify + -- after this before anything else + runWhen static_args (CoreDoPasses [ simpl_gently, CoreDoStaticArgs ]), + + -- We run vectorisation here for now, but we might also try to run + -- it later + vectorisation, + + -- initial simplify: mk specialiser happy: minimum effort please + simpl_gently, + + -- Specialisation is best done before full laziness + -- so that overloaded functions have all their dictionary lambdas manifest + runWhen do_specialise CoreDoSpecialising, + + runWhen full_laziness $ + CoreDoFloatOutwards FloatOutSwitches { + floatOutLambdas = Just 0, + floatOutConstants = True, + floatOutPartialApplications = False }, + -- Was: gentleFloatOutSwitches + -- + -- I have no idea why, but not floating constants to + -- top level is very bad in some cases. + -- + -- Notably: p_ident in spectral/rewrite + -- Changing from "gentle" to "constantsOnly" + -- improved rewrite's allocation by 19%, and + -- made 0.0% difference to any other nofib + -- benchmark + -- + -- Not doing floatOutPartialApplications yet, we'll do + -- that later on when we've had a chance to get more + -- accurate arity information. In fact it makes no + -- difference at all to performance if we do it here, + -- but maybe we save some unnecessary to-and-fro in + -- the simplifier. + + runWhen do_float_in CoreDoFloatInwards, + + simpl_phases, + + -- Phase 0: allow all Ids to be inlined now + -- This gets foldr inlined before strictness analysis + + -- At least 3 iterations because otherwise we land up with + -- huge dead expressions because of an infelicity in the + -- simpifier. + -- let k = BIG in foldr k z xs + -- ==> let k = BIG in letrec go = \xs -> ...(k x).... in go xs + -- ==> let k = BIG in letrec go = \xs -> ...(BIG x).... in go xs + -- Don't stop now! + simpl_phase 0 ["main"] (max max_iter 3), + + runWhen strictness (CoreDoPasses [ + CoreDoStrictness, + CoreDoWorkerWrapper, + CoreDoGlomBinds, + simpl_phase 0 ["post-worker-wrapper"] max_iter + ]), + + runWhen full_laziness $ + CoreDoFloatOutwards FloatOutSwitches { + floatOutLambdas = floatLamArgs dflags, + floatOutConstants = True, + floatOutPartialApplications = True }, + -- nofib/spectral/hartel/wang doubles in speed if you + -- do full laziness late in the day. It only happens + -- after fusion and other stuff, so the early pass doesn't + -- catch it. For the record, the redex is + -- f_el22 (f_el21 r_midblock) + + + runWhen cse CoreCSE, + -- We want CSE to follow the final full-laziness pass, because it may + -- succeed in commoning up things floated out by full laziness. + -- CSE used to rely on the no-shadowing invariant, but it doesn't any more + + runWhen do_float_in CoreDoFloatInwards, + + maybe_rule_check (Phase 0), + + -- Case-liberation for -O2. This should be after + -- strictness analysis and the simplification which follows it. + runWhen liberate_case (CoreDoPasses [ + CoreLiberateCase, + simpl_phase 0 ["post-liberate-case"] max_iter + ]), -- Run the simplifier after LiberateCase to vastly + -- reduce the possiblility of shadowing + -- Reason: see Note [Shadowing] in SpecConstr.lhs + + runWhen spec_constr CoreDoSpecConstr, + + maybe_rule_check (Phase 0), + + -- Final clean-up simplification: + simpl_phase 0 ["final"] max_iter + ] +\end{code} + +Loading plugins -type CorePass = CoreToDo +\begin{code} +addPluginPasses :: DynFlags -> [CoreToDo] -> CoreM [CoreToDo] +#ifndef GHCI +addPluginPasses _ builtin_passes = return builtin_passes +#else +addPluginPasses dflags builtin_passes + = do { hsc_env <- getHscEnv + ; named_plugins <- liftIO (loadPlugins hsc_env) + ; foldM query_plug builtin_passes named_plugins } + where + query_plug todos (mod_nm, plug) + = installCoreToDos plug options todos + where + options = [ option | (opt_mod_nm, option) <- pluginModNameOpts dflags + , opt_mod_nm == mod_nm ] + +loadPlugins :: HscEnv -> IO [(ModuleName, Plugin)] +loadPlugins hsc_env + = do { let to_load = pluginModNames (hsc_dflags hsc_env) + ; plugins <- mapM (loadPlugin hsc_env) to_load + ; return $ to_load `zip` plugins } + +loadPlugin :: HscEnv -> ModuleName -> IO Plugin +loadPlugin hsc_env mod_name + = do { let plugin_rdr_name = mkRdrQual mod_name (mkVarOcc "plugin") + ; mb_name <- lookupRdrNameInModule hsc_env mod_name plugin_rdr_name + ; case mb_name of { + Nothing -> throwGhcException (CmdLineError $ showSDoc $ hsep + [ ptext (sLit "The module"), ppr mod_name + , ptext (sLit "did not export the plugin name") + , ppr plugin_rdr_name ]) ; + Just name -> + + do { plugin_tycon <- forceLoadTyCon hsc_env pluginTyConName + ; mb_plugin <- getValueSafely hsc_env name (mkTyConTy plugin_tycon) + ; case mb_plugin of + Nothing -> throwGhcException (CmdLineError $ showSDoc $ hsep + [ ptext (sLit "The value"), ppr name + , ptext (sLit "did not have the type") + , ppr pluginTyConName, ptext (sLit "as required")]) + Just plugin -> return plugin } } } +#endif +\end{code} -doCorePasses :: [CorePass] -> ModGuts -> CoreM ModGuts -doCorePasses passes guts +%************************************************************************ +%* * + The CoreToDo interpreter +%* * +%************************************************************************ + +\begin{code} +runCorePasses :: [CoreToDo] -> ModGuts -> CoreM ModGuts +runCorePasses passes guts = foldM do_pass guts passes where do_pass guts CoreDoNothing = return guts - do_pass guts (CoreDoPasses ps) = doCorePasses ps guts + do_pass guts (CoreDoPasses ps) = runCorePasses ps guts do_pass guts pass = do { dflags <- getDynFlags ; liftIO $ showPass dflags pass @@ -92,7 +357,7 @@ ; liftIO $ endPass dflags pass (mg_binds guts') (mg_rules guts') ; return guts' } -doCorePass :: CorePass -> ModGuts -> CoreM ModGuts +doCorePass :: CoreToDo -> ModGuts -> CoreM ModGuts doCorePass pass@(CoreDoSimplify {}) = {-# SCC "Simplify" #-} simplifyPgm pass @@ -123,14 +388,19 @@ doCorePass CoreDoSpecConstr = {-# SCC "SpecConstr" #-} specConstrProgram -doCorePass (CoreDoVectorisation be) = {-# SCC "Vectorise" #-} - vectorise be +doCorePass CoreDoVectorisation = {-# SCC "Vectorise" #-} + vectorise doCorePass CoreDoGlomBinds = doPassDM glomBinds doCorePass CoreDoPrintCore = observe printCore -doCorePass (CoreDoRuleCheck phase pat) = ruleCheck phase pat +doCorePass (CoreDoRuleCheck phase pat) = ruleCheckPass phase pat doCorePass CoreDoNothing = return -doCorePass (CoreDoPasses passes) = doCorePasses passes +doCorePass (CoreDoPasses passes) = runCorePasses passes + +#ifdef GHCI +doCorePass (CoreDoPluginPass _ pass) = {-# SCC "Plugin" #-} pass +#endif + doCorePass pass = pprPanic "doCorePass" (ppr pass) \end{code} @@ -144,8 +414,8 @@ printCore :: a -> [CoreBind] -> IO () printCore _ binds = Err.dumpIfSet True "Print Core" (pprCoreBindings binds) -ruleCheck :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts -ruleCheck current_phase pat guts = do +ruleCheckPass :: CompilerPhase -> String -> ModGuts -> CoreM ModGuts +ruleCheckPass current_phase pat guts = do rb <- getRuleBase dflags <- getDynFlags liftIO $ Err.showPass dflags "RuleCheck" @@ -211,7 +481,7 @@ ; us <- mkSplitUniqSupply 's' ; let (expr', _counts) = initSmpl dflags emptyRuleBase emptyFamInstEnvs us $ - simplExprGently simplEnvForGHCi expr + simplExprGently (simplEnvForGHCi dflags) expr ; Err.dumpIfSet_dyn dflags Opt_D_dump_simpl "Simplified expression" (pprCoreExpr expr') @@ -309,7 +579,8 @@ simplifyPgmIO pass@(CoreDoSimplify max_iterations mode) hsc_env us hpt_rule_base - guts@(ModGuts { mg_binds = binds, mg_rules = rules + guts@(ModGuts { mg_module = this_mod + , mg_binds = binds, mg_rules = rules , mg_fam_inst_env = fam_inst_env }) = do { (termination_msg, it_count, counts_out, guts') <- do_iteration us 1 [] binds rules @@ -326,7 +597,7 @@ dflags = hsc_dflags hsc_env dump_phase = dumpSimplPhase dflags mode simpl_env = mkSimplEnv mode - active_rule = activeRule dflags simpl_env + active_rule = activeRule simpl_env do_iteration :: UniqSupply -> Int -- Counts iterations @@ -356,11 +627,18 @@ -- space usage, especially with -O. JRS, 000620. | let sz = coreBindsSize binds in sz == sz = do { - -- Occurrence analysis - let { tagged_binds = {-# SCC "OccAnal" #-} - occurAnalysePgm active_rule rules binds } ; - Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis" - (pprCoreBindings tagged_binds); + -- Occurrence analysis + let { -- During the 'InitialPhase' (i.e., before vectorisation), we need to make sure + -- that the right-hand sides of vectorisation declarations are taken into + -- account during occurence analysis. + maybeVects = case sm_phase mode of + InitialPhase -> mg_vect_decls guts + _ -> [] + ; tagged_binds = {-# SCC "OccAnal" #-} + occurAnalysePgm this_mod active_rule rules maybeVects binds + } ; + Err.dumpIfSet_dyn dflags Opt_D_dump_occur_anal "Occurrence analysis" + (pprCoreBindings tagged_binds); -- Get any new rules, and extend the rule base -- See Note [Overall plumbing for rules] in Rules.lhs @@ -429,13 +707,18 @@ ------------------- end_iteration :: DynFlags -> CoreToDo -> Int -> SimplCount -> [CoreBind] -> [CoreRule] -> IO () --- Same as endIteration but with simplifier counts end_iteration dflags pass iteration_no counts binds rules - = do { dumpIfSet (dopt Opt_D_dump_simpl_iterations dflags) - pass (ptext (sLit "Simplifier counts")) - (pprSimplCount counts) - - ; endIteration dflags pass iteration_no binds rules } + = do { dumpPassResult dflags mb_flag hdr pp_counts binds rules + ; lintPassResult dflags pass binds } + where + mb_flag | dopt Opt_D_dump_simpl_iterations dflags = Just Opt_D_dump_simpl_phases + | otherwise = Nothing + -- Show details if Opt_D_dump_simpl_iterations is on + + hdr = ptext (sLit "Simplifier iteration=") <> int iteration_no + pp_counts = vcat [ ptext (sLit "---- Simplifier counts for") <+> hdr + , pprSimplCount counts + , ptext (sLit "---- End of simplifier counts for") <+> hdr ] \end{code} diff -Nru ghc-7.0.3/compiler/simplCore/SimplEnv.lhs ghc-7.2.1/compiler/simplCore/SimplEnv.lhs --- ghc-7.0.3/compiler/simplCore/SimplEnv.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/simplCore/SimplEnv.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -16,7 +16,7 @@ -- Environments SimplEnv(..), StaticEnv, pprSimplEnv, -- Temp not abstract - mkSimplEnv, extendIdSubst, SimplEnv.extendTvSubst, + mkSimplEnv, extendIdSubst, SimplEnv.extendTvSubst, SimplEnv.extendCvSubst, zapSubstEnv, setSubstEnv, getInScope, setInScope, setInScopeSet, modifyInScope, addNewInScopeIds, getSimplRules, @@ -24,8 +24,10 @@ SimplSR(..), mkContEx, substId, lookupRecBndr, simplNonRecBndr, simplRecBndrs, simplLamBndr, simplLamBndrs, - simplBinder, simplBinders, addBndrRules, - substExpr, substTy, substTyVar, getTvSubst, mkCoreSubst, + simplBinder, simplBinders, addBndrRules, + substExpr, substTy, substTyVar, getTvSubst, + getCvSubst, substCo, substCoVar, + mkCoreSubst, -- Floats Floats, emptyFloats, isEmptyFloats, addNonRec, addFloats, extendFloats, @@ -46,10 +48,13 @@ import VarSet import OrdList import Id +import MkCore +import TysWiredIn import qualified CoreSubst -import qualified Type ( substTy, substTyVarBndr, substTyVar ) +import qualified Type import Type hiding ( substTy, substTyVarBndr, substTyVar ) -import Coercion +import qualified Coercion +import Coercion hiding ( substCo, substTy, substCoVar, substCoVarBndr, substTyVarBndr ) import BasicTypes import MonadUtils import Outputable @@ -105,8 +110,9 @@ seCC :: CostCentreStack, -- The enclosing CCS (when profiling) -- The current substitution - seTvSubst :: TvSubstEnv, -- InTyVar |--> OutType - seIdSubst :: SimplIdSubst, -- InId |--> OutExpr + seTvSubst :: TvSubstEnv, -- InTyVar |--> OutType + seCvSubst :: CvSubstEnv, -- InTyCoVar |--> OutCoercion + seIdSubst :: SimplIdSubst, -- InId |--> OutExpr ----------- Dynamic part of the environment ----------- -- Dynamic in the sense of describing the setup where @@ -141,13 +147,14 @@ = DoneEx OutExpr -- Completed term | DoneId OutId -- Completed term variable | ContEx TvSubstEnv -- A suspended substitution + CvSubstEnv SimplIdSubst InExpr instance Outputable SimplSR where ppr (DoneEx e) = ptext (sLit "DoneEx") <+> ppr e ppr (DoneId v) = ptext (sLit "DoneId") <+> ppr v - ppr (ContEx _tv _id e) = vcat [ptext (sLit "ContEx") <+> ppr e {-, + ppr (ContEx _tv _cv _id e) = vcat [ptext (sLit "ContEx") <+> ppr e {-, ppr (filter_env tv), ppr (filter_env id) -}] -- where -- fvs = exprFreeVars e @@ -220,13 +227,39 @@ \begin{code} mkSimplEnv :: SimplifierMode -> SimplEnv mkSimplEnv mode - = SimplEnv { seCC = subsumedCCS, - seMode = mode, seInScope = emptyInScopeSet, - seFloats = emptyFloats, - seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv } + = SimplEnv { seCC = subsumedCCS + , seMode = mode + , seInScope = init_in_scope + , seFloats = emptyFloats + , seTvSubst = emptyVarEnv + , seCvSubst = emptyVarEnv + , seIdSubst = emptyVarEnv } -- The top level "enclosing CC" is "SUBSUMED". ---------------------- +init_in_scope :: InScopeSet +init_in_scope = mkInScopeSet (unitVarSet (mkWildValBinder unitTy)) + -- See Note [WildCard binders] +\end{code} + +Note [WildCard binders] +~~~~~~~~~~~~~~~~~~~~~~~ +The program to be simplified may have wild binders + case e of wild { p -> ... } +We want to *rename* them away, so that there are no +occurrences of 'wild-id' (with wildCardKey). The easy +way to do that is to start of with a representative +Id in the in-scope set + +There can be be *occurrences* of wild-id. For example, +MkCore.mkCoreApp transforms + e (a /# b) --> case (a /# b) of wild { DEFAULT -> e wild } +This is ok provided 'wild' isn't free in 'e', and that's the delicate +thing. Generally, you want to run the simplifier to get rid of the +wild-ids before doing much else. + +It's a very dark corner of GHC. Maybe it should be cleaned up. + +\begin{code} getMode :: SimplEnv -> SimplifierMode getMode env = seMode env @@ -246,12 +279,17 @@ --------------------- extendIdSubst :: SimplEnv -> Id -> SimplSR -> SimplEnv extendIdSubst env@(SimplEnv {seIdSubst = subst}) var res - = env {seIdSubst = extendVarEnv subst var res} + = ASSERT2( isId var && not (isCoVar var), ppr var ) + env {seIdSubst = extendVarEnv subst var res} extendTvSubst :: SimplEnv -> TyVar -> Type -> SimplEnv extendTvSubst env@(SimplEnv {seTvSubst = subst}) var res = env {seTvSubst = extendVarEnv subst var res} +extendCvSubst :: SimplEnv -> CoVar -> Coercion -> SimplEnv +extendCvSubst env@(SimplEnv {seCvSubst = subst}) var res + = env {seCvSubst = extendVarEnv subst var res} + --------------------- getInScope :: SimplEnv -> InScopeSet getInScope env = seInScope env @@ -291,13 +329,13 @@ --------------------- zapSubstEnv :: SimplEnv -> SimplEnv -zapSubstEnv env = env {seTvSubst = emptyVarEnv, seIdSubst = emptyVarEnv} +zapSubstEnv env = env {seTvSubst = emptyVarEnv, seCvSubst = emptyVarEnv, seIdSubst = emptyVarEnv} -setSubstEnv :: SimplEnv -> TvSubstEnv -> SimplIdSubst -> SimplEnv -setSubstEnv env tvs ids = env { seTvSubst = tvs, seIdSubst = ids } +setSubstEnv :: SimplEnv -> TvSubstEnv -> CvSubstEnv -> SimplIdSubst -> SimplEnv +setSubstEnv env tvs cvs ids = env { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids } mkContEx :: SimplEnv -> InExpr -> SimplSR -mkContEx (SimplEnv { seTvSubst = tvs, seIdSubst = ids }) e = ContEx tvs ids e +mkContEx (SimplEnv { seTvSubst = tvs, seCvSubst = cvs, seIdSubst = ids }) e = ContEx tvs cvs ids e \end{code} @@ -460,7 +498,7 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ We look up even a global (eg imported) Id in the substitution. Consider case X.g_34 of b { (a,b) -> ... case X.g_34 of { (p,q) -> ...} ... } -The binder-swap in the occurence analyser will add a binding +The binder-swap in the occurrence analyser will add a binding for a LocalId version of g (with the same unique though): case X.g_34 of b { (a,b) -> let g_34 = b in ... case X.g_34 of { (p,q) -> ...} ... } @@ -476,7 +514,6 @@ Just (DoneId v) -> DoneId (refine in_scope v) Just (DoneEx (Var v)) -> DoneId (refine in_scope v) Just res -> res -- DoneEx non-var, or ContEx - where -- Get the most up-to-date thing from the in-scope set -- Even though it isn't in the substitution, it may be in @@ -522,7 +559,7 @@ -- The substitution is extended only if the variable is cloned, because -- we *don't* need to use it to track occurrence info. simplBinder env bndr - | isTyCoVar bndr = do { let (env', tv) = substTyVarBndr env bndr + | isTyVar bndr = do { let (env', tv) = substTyVarBndr env bndr ; seqTyVar tv `seq` return (env', tv) } | otherwise = do { let (env', id) = substIdBndr env bndr ; seqId id `seq` return (env', id) } @@ -559,9 +596,17 @@ ; seqIds ids1 `seq` return env1 } --------------- -substIdBndr :: SimplEnv - -> InBndr -- Env and binder to transform - -> (SimplEnv, OutBndr) +substIdBndr :: SimplEnv -> InBndr -> (SimplEnv, OutBndr) +-- Might be a coercion variable +substIdBndr env bndr + | isCoVar bndr = substCoVarBndr env bndr + | otherwise = substNonCoVarIdBndr env bndr + +--------------- +substNonCoVarIdBndr + :: SimplEnv + -> InBndr -- Env and binder to transform + -> (SimplEnv, OutBndr) -- Clone Id if necessary, substitute its type -- Return an Id with its -- * Type substituted @@ -579,10 +624,10 @@ -- Similar to CoreSubst.substIdBndr, except that -- the type of id_subst differs -- all fragile info is zapped - -substIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) - old_id - = (env { seInScope = in_scope `extendInScopeSet` new_id, +substNonCoVarIdBndr env@(SimplEnv { seInScope = in_scope, seIdSubst = id_subst }) + old_id + = ASSERT2( not (isCoVar old_id), ppr old_id ) + (env { seInScope = in_scope `extendInScopeSet` new_id, seIdSubst = new_subst }, new_id) where id1 = uniqAway in_scope old_id @@ -687,6 +732,10 @@ getTvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) = mkTvSubst in_scope tv_env +getCvSubst :: SimplEnv -> CvSubst +getCvSubst (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env }) + = CvSubst in_scope tv_env cv_env + substTy :: SimplEnv -> Type -> Type substTy env ty = Type.substTy (getTvSubst env) ty @@ -697,7 +746,19 @@ substTyVarBndr env tv = case Type.substTyVarBndr (getTvSubst env) tv of (TvSubst in_scope' tv_env', tv') - -> (env { seInScope = in_scope', seTvSubst = tv_env'}, tv') + -> (env { seInScope = in_scope', seTvSubst = tv_env' }, tv') + +substCoVar :: SimplEnv -> CoVar -> Coercion +substCoVar env tv = Coercion.substCoVar (getCvSubst env) tv + +substCoVarBndr :: SimplEnv -> CoVar -> (SimplEnv, CoVar) +substCoVarBndr env cv + = case Coercion.substCoVarBndr (getCvSubst env) cv of + (CvSubst in_scope' tv_env' cv_env', cv') + -> (env { seInScope = in_scope', seTvSubst = tv_env', seCvSubst = cv_env' }, cv') + +substCo :: SimplEnv -> Coercion -> Coercion +substCo env co = Coercion.substCo (getCvSubst env) co -- When substituting in rules etc we can get CoreSubst to do the work -- But CoreSubst uses a simpler form of IdSubstEnv, so we must impedence-match @@ -705,19 +766,19 @@ -- the substitutions are typically small, and laziness will avoid work in many cases. mkCoreSubst :: SDoc -> SimplEnv -> CoreSubst.Subst -mkCoreSubst doc (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seIdSubst = id_env }) - = mk_subst tv_env id_env +mkCoreSubst doc (SimplEnv { seInScope = in_scope, seTvSubst = tv_env, seCvSubst = cv_env, seIdSubst = id_env }) + = mk_subst tv_env cv_env id_env where - mk_subst tv_env id_env = CoreSubst.mkSubst in_scope tv_env (mapVarEnv fiddle id_env) + mk_subst tv_env cv_env id_env = CoreSubst.mkSubst in_scope tv_env cv_env (mapVarEnv fiddle id_env) - fiddle (DoneEx e) = e - fiddle (DoneId v) = Var v - fiddle (ContEx tv id e) = CoreSubst.substExpr (text "mkCoreSubst" <+> doc) (mk_subst tv id) e + fiddle (DoneEx e) = e + fiddle (DoneId v) = Var v + fiddle (ContEx tv cv id e) = CoreSubst.substExpr (text "mkCoreSubst" <+> doc) (mk_subst tv cv id) e -- Don't shortcut here ------------------ substIdType :: SimplEnv -> Id -> Id -substIdType (SimplEnv { seInScope = in_scope, seTvSubst = tv_env}) id +substIdType (SimplEnv { seInScope = in_scope, seTvSubst = tv_env }) id | isEmptyVarEnv tv_env || isEmptyVarSet (tyVarsOfType old_ty) = id | otherwise = Id.setIdType id (Type.substTy (TvSubst in_scope tv_env) old_ty) -- The tyVarsOfType is cheaper than it looks diff -Nru ghc-7.0.3/compiler/simplCore/Simplify.lhs ghc-7.2.1/compiler/simplCore/Simplify.lhs --- ghc-7.0.3/compiler/simplCore/Simplify.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/simplCore/Simplify.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -17,10 +17,9 @@ import Id import MkId ( seqId, realWorldPrimId ) import MkCore ( mkImpossibleExpr ) -import Var import IdInfo import Name ( mkSystemVarName, isExternalName ) -import Coercion +import Coercion hiding ( substCo, substTy, substCoVar, extendTvSubst ) import OptCoercion ( optCoercion ) import FamInstEnv ( topNormaliseType ) import DataCon ( DataCon, dataConWorkId, dataConRepStrictness ) @@ -28,9 +27,7 @@ import CoreSyn import Demand ( isStrictDmd ) import PprCore ( pprParendExpr, pprCoreExpr ) -import CoreUnfold ( mkUnfolding, mkCoreUnfolding - , mkInlineUnfolding, mkSimpleUnfolding - , exprIsConApp_maybe, callSiteInline, CallCtxt(..) ) +import CoreUnfold import CoreUtils import qualified CoreSubst import CoreArity @@ -44,6 +41,7 @@ import Data.List ( mapAccumL ) import Outputable import FastString +import Pair \end{code} @@ -214,6 +212,7 @@ -- so that if a transformation rule has unexpectedly brought -- anything into scope, then we don't get a complaint about that. -- It's rather as if the top-level binders were imported. + -- See note [Glomming] in OccurAnal. ; env1 <- simplRecBndrs env0 (bindersOfBinds binds0) ; dflags <- getDOptsSmpl ; let dump_flag = dopt Opt_D_verbose_core2core dflags @@ -371,8 +370,11 @@ -> SimplM SimplEnv simplNonRecX env bndr new_rhs - | isDeadBinder bndr -- Not uncommon; e.g. case (a,b) of b { (p,q) -> p } - = return env -- Here b is dead, and we avoid creating + | isDeadBinder bndr -- Not uncommon; e.g. case (a,b) of c { (p,q) -> p } + = return env -- Here c is dead, and we avoid creating + -- the binding c = (a,b) + | Coercion co <- new_rhs + = return (extendCvSubst env bndr co) | otherwise -- the binding b = (a,b) = do { (env', bndr') <- simplBinder env bndr ; completeNonRecX NotTopLevel env' (isStrictId bndr) bndr bndr' new_rhs } @@ -440,7 +442,7 @@ prepareRhs :: TopLevelFlag -> SimplEnv -> OutId -> OutExpr -> SimplM (SimplEnv, OutExpr) -- Adds new floats to the env iff that allows us to return a good RHS prepareRhs top_lvl env id (Cast rhs co) -- Note [Float coercions] - | (ty1, _ty2) <- coercionKind co -- Do *not* do this if rhs has an unlifted type + | Pair ty1 _ty2 <- coercionKind co -- Do *not* do this if rhs has an unlifted type , not (isUnLiftedType ty1) -- see Note [Float coercions (unlifted)] = do { (env', rhs') <- makeTrivialWithInfo top_lvl env sanitised_info rhs ; return (env', Cast rhs' co) } @@ -628,6 +630,12 @@ -- * or by adding to the floats in the envt completeBind env top_lvl old_bndr new_bndr new_rhs + | isCoVar old_bndr + = case new_rhs of + Coercion co -> return (extendCvSubst env old_bndr co) + _ -> return (addNonRec env new_bndr new_rhs) + + | otherwise = ASSERT( isId new_bndr ) do { let old_info = idInfo old_bndr old_unf = unfoldingInfo old_info @@ -638,14 +646,12 @@ ; (new_arity, final_rhs) <- tryEtaExpand env new_bndr new_rhs -- Simplify the unfolding - ; new_unfolding <- simplUnfolding env top_lvl old_bndr occ_info final_rhs old_unf + ; new_unfolding <- simplUnfolding env top_lvl old_bndr final_rhs old_unf ; if postInlineUnconditionally env top_lvl new_bndr occ_info final_rhs new_unfolding -- Inline and discard the binding then do { tick (PostInlineUnconditionally old_bndr) - ; -- pprTrace "postInlineUnconditionally" - -- (ppr old_bndr <+> equals <+> ppr final_rhs $$ ppr occ_info) $ - return (extendIdSubst env old_bndr (DoneEx final_rhs)) } + ; return (extendIdSubst env old_bndr (DoneEx final_rhs)) } -- Use the substitution to make quite, quite sure that the -- substitution will happen, since we are going to discard the binding else @@ -660,7 +666,7 @@ final_id = new_bndr `setIdInfo` info3 - ; -- pprTrace "Binding" (ppr final_id <+> ppr unfolding) $ + ; -- pprTrace "Binding" (ppr final_id <+> ppr new_unfolding) $ return (addNonRec env final_id final_rhs) } } -- The addNonRec adds it to the in-scope set too @@ -678,7 +684,7 @@ -- opportunity to inline 'y' too. addPolyBind top_lvl env (NonRec poly_id rhs) - = do { unfolding <- simplUnfolding env top_lvl poly_id NoOccInfo rhs noUnfolding + = do { unfolding <- simplUnfolding env top_lvl poly_id rhs noUnfolding -- Assumes that poly_id did not have an INLINE prag -- which is perhaps wrong. ToDo: think about this ; let final_id = setIdInfo poly_id $ @@ -695,16 +701,16 @@ ------------------------------ simplUnfolding :: SimplEnv-> TopLevelFlag - -> Id - -> OccInfo -> OutExpr + -> InId + -> OutExpr -> Unfolding -> SimplM Unfolding -- Note [Setting the new unfolding] -simplUnfolding env _ _ _ _ (DFunUnfolding ar con ops) +simplUnfolding env _ _ _ (DFunUnfolding ar con ops) = return (DFunUnfolding ar con ops') where - ops' = map (fmap (substExpr (text "simplUnfolding") env)) ops + ops' = map (substExpr (text "simplUnfolding") env) ops -simplUnfolding env top_lvl id _ _ +simplUnfolding env top_lvl id _ (CoreUnfolding { uf_tmpl = expr, uf_arity = arity , uf_src = src, uf_guidance = guide }) | isStableSource src @@ -712,36 +718,46 @@ ; let src' = CoreSubst.substUnfoldingSource (mkCoreSubst (text "inline-unf") env) src is_top_lvl = isTopLevel top_lvl ; case guide of - UnfIfGoodArgs{} -> - -- We need to force bottoming, or the new unfolding holds - -- on to the old unfolding (which is part of the id). - let bottoming = isBottomingId id - in bottoming `seq` return (mkUnfolding src' is_top_lvl bottoming expr') + UnfWhen sat_ok _ -- Happens for INLINE things + -> let guide' = UnfWhen sat_ok (inlineBoringOk expr') + -- Refresh the boring-ok flag, in case expr' + -- has got small. This happens, notably in the inlinings + -- for dfuns for single-method classes; see + -- Note [Single-method classes] in TcInstDcls. + -- A test case is Trac #4138 + in return (mkCoreUnfolding src' is_top_lvl expr' arity guide') + -- See Note [Top-level flag on inline rules] in CoreUnfold + + _other -- Happens for INLINABLE things + -> let bottoming = isBottomingId id + in bottoming `seq` -- See Note [Force bottoming field] + return (mkUnfolding src' is_top_lvl bottoming expr') -- If the guidance is UnfIfGoodArgs, this is an INLINABLE -- unfolding, and we need to make sure the guidance is kept up -- to date with respect to any changes in the unfolding. - _other -> - return (mkCoreUnfolding src' is_top_lvl expr' arity guide) - -- See Note [Top-level flag on inline rules] in CoreUnfold } where act = idInlineActivation id rule_env = updMode (updModeForInlineRules act) env -- See Note [Simplifying inside InlineRules] in SimplUtils -simplUnfolding _ top_lvl id _occ_info new_rhs _ - = -- We need to force bottoming, or the new unfolding holds - -- on to the old unfolding (which is part of the id). - let bottoming = isBottomingId id - in bottoming `seq` return (mkUnfolding InlineRhs (isTopLevel top_lvl) bottoming new_rhs) - -- We make an unfolding *even for loop-breakers*. - -- Reason: (a) It might be useful to know that they are WHNF - -- (b) In TidyPgm we currently assume that, if we want to - -- expose the unfolding then indeed we *have* an unfolding - -- to expose. (We could instead use the RHS, but currently - -- we don't.) The simple thing is always to have one. +simplUnfolding _ top_lvl id new_rhs _ + = let bottoming = isBottomingId id + in bottoming `seq` -- See Note [Force bottoming field] + return (mkUnfolding InlineRhs (isTopLevel top_lvl) bottoming new_rhs) + -- We make an unfolding *even for loop-breakers*. + -- Reason: (a) It might be useful to know that they are WHNF + -- (b) In TidyPgm we currently assume that, if we want to + -- expose the unfolding then indeed we *have* an unfolding + -- to expose. (We could instead use the RHS, but currently + -- we don't.) The simple thing is always to have one. \end{code} +Note [Force bottoming field] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We need to force bottoming, or the new unfolding holds +on to the old unfolding (which is part of the id). + Note [Arity decrease] ~~~~~~~~~~~~~~~~~~~~~ Generally speaking the arity of a binding should not decrease. But it *can* @@ -861,19 +877,30 @@ -> SimplM (SimplEnv, OutExpr) simplExprF env e cont - = -- pprTrace "simplExprF" (ppr e $$ ppr cont $$ ppr (seTvSubst env) $$ ppr (seIdSubst env) {- $$ ppr (seFloats env) -} ) $ - simplExprF' env e cont + = {- pprTrace "simplExprF" (vcat + [ ppr e + , text "cont =" <+> ppr cont + , text "inscope =" <+> ppr (seInScope env) + , text "tvsubst =" <+> ppr (seTvSubst env) + , text "idsubst =" <+> ppr (seIdSubst env) + , text "cvsubst =" <+> ppr (seCvSubst env) + {- , ppr (seFloats env) -} + ]) $ -} + simplExprF1 env e cont -simplExprF' :: SimplEnv -> InExpr -> SimplCont +simplExprF1 :: SimplEnv -> InExpr -> SimplCont -> SimplM (SimplEnv, OutExpr) -simplExprF' env (Var v) cont = simplVarF env v cont -simplExprF' env (Lit lit) cont = rebuild env (Lit lit) cont -simplExprF' env (Note n expr) cont = simplNote env n expr cont -simplExprF' env (Cast body co) cont = simplCast env body co cont -simplExprF' env (App fun arg) cont = simplExprF env fun $ +simplExprF1 env (Var v) cont = simplIdF env v cont +simplExprF1 env (Lit lit) cont = rebuild env (Lit lit) cont +simplExprF1 env (Note n expr) cont = simplNote env n expr cont +simplExprF1 env (Cast body co) cont = simplCast env body co cont +simplExprF1 env (Coercion co) cont = simplCoercionF env co cont +simplExprF1 env (Type ty) cont = ASSERT( contIsRhsOrArg cont ) + rebuild env (Type (substTy env ty)) cont +simplExprF1 env (App fun arg) cont = simplExprF env fun $ ApplyTo NoDup arg env cont -simplExprF' env expr@(Lam _ _) cont +simplExprF1 env expr@(Lam {}) cont = simplLam env zapped_bndrs body cont -- The main issue here is under-saturated lambdas -- (\x1. \x2. e) arg1 @@ -890,17 +917,12 @@ n_args = countArgs cont -- NB: countArgs counts all the args (incl type args) -- and likewise drop counts all binders (incl type lambdas) - - zappable_bndr b = isId b && not (isOneShotBndr b) - zap b | isTyCoVar b = b - | otherwise = zapLamIdInfo b -simplExprF' env (Type ty) cont - = ASSERT( contIsRhsOrArg cont ) - do { ty' <- simplCoercion env ty - ; rebuild env (Type ty') cont } + zappable_bndr b = isId b && not (isOneShotBndr b) + zap b | isTyVar b = b + | otherwise = zapLamIdInfo b -simplExprF' env (Case scrut bndr _ alts) cont +simplExprF1 env (Case scrut bndr _ alts) cont | sm_case_case (getMode env) = -- Simplify the scrutinee with a Select continuation simplExprF env scrut (Select NoDup bndr alts env cont) @@ -912,7 +934,7 @@ (Select NoDup bndr alts env mkBoringStop) ; rebuild env case_expr' cont } -simplExprF' env (Let (Rec pairs) body) cont +simplExprF1 env (Let (Rec pairs) body) cont = do { env' <- simplRecBndrs env (map fst pairs) -- NB: bndrs' don't have unfoldings or rules -- We add them as we go down @@ -920,7 +942,7 @@ ; env'' <- simplRecBind env' NotTopLevel pairs ; simplExprF env'' body cont } -simplExprF' env (Let (NonRec bndr rhs) body) cont +simplExprF1 env (Let (NonRec bndr rhs) body) cont = simplNonRecE env bndr (rhs, env) ([], body) cont --------------------------------- @@ -933,13 +955,30 @@ new_ty = substTy env ty --------------------------------- -simplCoercion :: SimplEnv -> InType -> SimplM OutType --- The InType isn't *necessarily* a coercion, but it might be --- (in a type application, say) and optCoercion is a no-op on types +simplCoercionF :: SimplEnv -> InCoercion -> SimplCont + -> SimplM (SimplEnv, OutExpr) +-- We are simplifying a term of form (Coercion co) +-- Simplify the InCoercion, and then try to combine with the +-- context, to implememt the rule +-- (Coercion co) |> g +-- = Coercion (syn (nth 0 g) ; co ; nth 1 g) +simplCoercionF env co cont + = do { co' <- simplCoercion env co + ; simpl_co co' cont } + where + simpl_co co (CoerceIt g cont) + = simpl_co new_co cont + where + new_co = mkSymCo g0 `mkTransCo` co `mkTransCo` g1 + [g0, g1] = decomposeCo 2 g + + simpl_co co cont + = seqCo co `seq` rebuild env (Coercion co) cont + +simplCoercion :: SimplEnv -> InCoercion -> SimplM OutCoercion simplCoercion env co - = seqType new_co `seq` return new_co - where - new_co = optCoercion (getTvSubst env) co + = let opt_co = optCoercion (getCvSubst env) co + in opt_co `seq` return opt_co \end{code} @@ -956,7 +995,7 @@ rebuild env expr cont = case cont of Stop {} -> return (env, expr) - CoerceIt co cont -> rebuild env (mkCoerce co expr) cont + CoerceIt co cont -> rebuild env (Cast expr co) cont Select _ bndr alts se cont -> rebuildCase (se `setFloats` env) expr bndr alts cont StrictArg info _ cont -> rebuildCall env (info `addArgTo` expr) cont StrictBind b bs body se cont -> do { env' <- simplNonRecX (se `setFloats` env) b expr @@ -979,15 +1018,16 @@ -> SimplM (SimplEnv, OutExpr) simplCast env body co0 cont0 = do { co1 <- simplCoercion env co0 - ; simplExprF env body (addCoerce co1 cont0) } + ; -- pprTrace "simplCast" (ppr co1) $ + simplExprF env body (addCoerce co1 cont0) } where addCoerce co cont = add_coerce co (coercionKind co) cont - add_coerce _co (s1, k1) cont -- co :: ty~ty - | s1 `coreEqType` k1 = cont -- is a no-op + add_coerce _co (Pair s1 k1) cont -- co :: ty~ty + | s1 `eqType` k1 = cont -- is a no-op - add_coerce co1 (s1, _k2) (CoerceIt co2 cont) - | (_l1, t1) <- coercionKind co2 + add_coerce co1 (Pair s1 _k2) (CoerceIt co2 cont) + | (Pair _l1 t1) <- coercionKind co2 -- e |> (g1 :: S1~L) |> (g2 :: L~T1) -- ==> -- e, if S1=T1 @@ -997,28 +1037,40 @@ -- we may find (coerce T (coerce S (\x.e))) y -- and we'd like it to simplify to e[y/x] in one round -- of simplification - , s1 `coreEqType` t1 = cont -- The coerces cancel out - | otherwise = CoerceIt (mkTransCoercion co1 co2) cont + , s1 `eqType` t1 = cont -- The coerces cancel out + | otherwise = CoerceIt (mkTransCo co1 co2) cont - add_coerce co (s1s2, _t1t2) (ApplyTo dup (Type arg_ty) arg_se cont) + add_coerce co (Pair s1s2 _t1t2) (ApplyTo dup (Type arg_ty) arg_se cont) -- (f |> g) ty ---> (f ty) |> (g @ ty) - -- This implements the PushT and PushC rules from the paper + -- This implements the PushT rule from the paper | Just (tyvar,_) <- splitForAllTy_maybe s1s2 - = let - (new_arg_ty, new_cast) - | isCoVar tyvar = (new_arg_co, mkCselRCoercion co) -- PushC rule - | otherwise = (ty', mkInstCoercion co ty') -- PushT rule - in - ApplyTo dup (Type new_arg_ty) (zapSubstEnv arg_se) (addCoerce new_cast cont) + = ASSERT( isTyVar tyvar ) + ApplyTo Simplified (Type arg_ty') (zapSubstEnv arg_se) (addCoerce new_cast cont) + where + new_cast = mkInstCo co arg_ty' + arg_ty' | isSimplified dup = arg_ty + | otherwise = substTy (arg_se `setInScope` env) arg_ty + +{- + add_coerce co (Pair s1s2 _t1t2) (ApplyTo dup (Coercion arg_co) arg_se cont) + -- This implements the PushC rule from the paper + | Just (covar,_) <- splitForAllTy_maybe s1s2 + = ASSERT( isCoVar covar ) + ApplyTo Simplified (Coercion new_arg_co) (zapSubstEnv arg_se) (addCoerce co1 cont) where - ty' = substTy (arg_se `setInScope` env) arg_ty - new_arg_co = mkCsel1Coercion co `mkTransCoercion` - ty' `mkTransCoercion` - mkSymCoercion (mkCsel2Coercion co) - - add_coerce co (s1s2, _t1t2) (ApplyTo dup arg arg_se cont) - | not (isTypeArg arg) -- This implements the Push rule from the paper - , isFunTy s1s2 -- t1t2 must be a function type, becuase it's applied + [co0, co1] = decomposeCo 2 co + [co00, co01] = decomposeCo 2 co0 + + arg_co' | isSimplified dup = arg_co + | otherwise = substCo (arg_se `setInScope` env) arg_co + new_arg_co = co00 `mkTransCo` + arg_co' `mkTransCo` + mkSymCo co01 +-} + + add_coerce co (Pair s1s2 t1t2) (ApplyTo dup arg arg_se cont) + | isFunTy s1s2 -- This implements the Push rule from the paper + , isFunTy t1t2 -- Check t1t2 to ensure 'arg' is a value arg -- (e |> (g :: s1s2 ~ t1->t2)) f -- ===> -- (e (f |> (arg g :: t1~s1)) @@ -1039,8 +1091,9 @@ -- t2 ~ s2 with left and right on the curried form: -- (->) t1 t2 ~ (->) s1 s2 [co1, co2] = decomposeCo 2 co - new_arg = mkCoerce (mkSymCoercion co1) arg' - arg' = substExpr (text "move-cast") (arg_se `setInScope` env) arg + new_arg = mkCoerce (mkSymCo co1) arg' + arg' = substExpr (text "move-cast") arg_se' arg + arg_se' = arg_se `setInScope` env add_coerce co _ cont = CoerceIt co cont \end{code} @@ -1052,6 +1105,19 @@ %* * %************************************************************************ +Note [Zap unfolding when beta-reducing] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Lambda-bound variables can have stable unfoldings, such as + $j = \x. \b{Unf=Just x}. e +See Note [Case binders and join points] below; the unfolding for lets +us optimise e better. However when we beta-reduce it we want to +revert to using the actual value, otherwise we can end up in the +stupid situation of + let x = blah in + let b{Unf=Just x} = y + in ...b... +Here it'd be far better to drop the unfolding and use the actual RHS. + \begin{code} simplLam :: SimplEnv -> [InId] -> InExpr -> SimplCont -> SimplM (SimplEnv, OutExpr) @@ -1061,7 +1127,12 @@ -- Beta reduction simplLam env (bndr:bndrs) body (ApplyTo _ arg arg_se cont) = do { tick (BetaReduction bndr) - ; simplNonRecE env bndr (arg, arg_se) (bndrs, body) cont } + ; simplNonRecE env (zap_unfolding bndr) (arg, arg_se) (bndrs, body) cont } + where + zap_unfolding bndr -- See Note [Zap unfolding when beta-reducing] + | isId bndr, isStableUnfolding (realIdUnfolding bndr) + = setIdUnfolding bndr NoUnfolding + | otherwise = bndr -- Not enough args, so there are real lambdas left to put in the result simplLam env bndrs body cont @@ -1094,7 +1165,7 @@ -- First deal with type applications and type lets -- (/\a. e) (Type ty) and (let a = Type ty in e) simplNonRecE env bndr (Type ty_arg, rhs_se) (bndrs, body) cont - = ASSERT( isTyCoVar bndr ) + = ASSERT( isTyVar bndr ) do { ty_arg' <- simplType (rhs_se `setInScope` env) ty_arg ; simplLam (extendTvSubst env bndr ty_arg') bndrs body cont } @@ -1104,12 +1175,12 @@ ; -- pprTrace "preInlineUncond" (ppr bndr <+> ppr rhs) $ simplLam (extendIdSubst env bndr (mkContEx rhs_se rhs)) bndrs body cont } - | isStrictId bndr + | isStrictId bndr -- Includes coercions = do { simplExprF (rhs_se `setFloats` env) rhs (StrictBind bndr bndrs body env cont) } | otherwise - = ASSERT( not (isTyCoVar bndr) ) + = ASSERT( not (isTyVar bndr) ) do { (env1, bndr1) <- simplNonRecBndr env bndr ; let (env2, bndr2) = addBndrRules env1 bndr bndr1 ; env3 <- simplLazyBind env2 NotTopLevel NonRecursive bndr bndr2 rhs rhs_se @@ -1151,20 +1222,20 @@ simplVar :: SimplEnv -> InVar -> SimplM OutExpr -- Look up an InVar in the environment simplVar env var - | isTyCoVar var - = return (Type (substTyVar env var)) + | isTyVar var = return (Type (substTyVar env var)) + | isCoVar var = return (Coercion (substCoVar env var)) | otherwise = case substId env var of - DoneId var1 -> return (Var var1) - DoneEx e -> return e - ContEx tvs ids e -> simplExpr (setSubstEnv env tvs ids) e + DoneId var1 -> return (Var var1) + DoneEx e -> return e + ContEx tvs cvs ids e -> simplExpr (setSubstEnv env tvs cvs ids) e -simplVarF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplEnv, OutExpr) -simplVarF env var cont +simplIdF :: SimplEnv -> InId -> SimplCont -> SimplM (SimplEnv, OutExpr) +simplIdF env var cont = case substId env var of - DoneEx e -> simplExprF (zapSubstEnv env) e cont - ContEx tvs ids e -> simplExprF (setSubstEnv env tvs ids) e cont - DoneId var1 -> completeCall env var1 cont + DoneEx e -> simplExprF (zapSubstEnv env) e cont + ContEx tvs cvs ids e -> simplExprF (setSubstEnv env tvs cvs ids) e cont + DoneId var1 -> completeCall env var1 cont -- Note [zapSubstEnv] -- The template is already simplified, so don't re-substitute. -- This is VITAL. Consider @@ -1211,10 +1282,10 @@ | not (dopt Opt_D_dump_inlinings dflags) = stuff | not (dopt Opt_D_verbose_core2core dflags) = if isExternalName (idName var) then - pprTrace "Inlining done:" (ppr var) stuff + pprDefiniteTrace "Inlining done:" (ppr var) stuff else stuff | otherwise - = pprTrace ("Inlining done: " ++ showSDoc (ppr var)) + = pprDefiniteTrace ("Inlining done: " ++ showSDoc (ppr var)) (vcat [text "Inlined fn: " <+> nest 2 (ppr unfolding), text "Cont: " <+> ppr cont]) stuff @@ -1240,13 +1311,14 @@ res = mkApps (Var fun) (reverse rev_args) res_ty = exprType res cont_ty = contResultType env res_ty cont - co = mkUnsafeCoercion res_ty cont_ty - mk_coerce expr | cont_ty `coreEqType` res_ty = expr + co = mkUnsafeCo res_ty cont_ty + mk_coerce expr | cont_ty `eqType` res_ty = expr | otherwise = mkCoerce co expr -rebuildCall env info (ApplyTo _ (Type arg_ty) se cont) - = do { ty' <- simplCoercion (se `setInScope` env) arg_ty - ; rebuildCall env (info `addArgTo` Type ty') cont } +rebuildCall env info (ApplyTo dup_flag (Type arg_ty) se cont) + = do { arg_ty' <- if isSimplified dup_flag then return arg_ty + else simplType (se `setInScope` env) arg_ty + ; rebuildCall env (info `addArgTo` Type arg_ty') cont } rebuildCall env info@(ArgInfo { ai_encl = encl_rules , ai_strs = str:strs, ai_discs = disc:discs }) @@ -1254,7 +1326,7 @@ | isSimplified dup_flag -- See Note [Avoid redundant simplification] = rebuildCall env (addArgTo info' arg) cont - | str -- Strict argument + | str -- Strict argument = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $ simplExprF (arg_se `setFloats` env) arg (StrictArg info' cci cont) @@ -1350,27 +1422,27 @@ | null rules = return Nothing | otherwise - = do { dflags <- getDOptsSmpl - ; case activeRule dflags env of { - Nothing -> return Nothing ; -- No rules apply - Just act_fn -> - case lookupRule act_fn (getUnfoldingInRuleMatch env) (getInScope env) fn args rules of { + = do { case lookupRule (activeRule env) (getUnfoldingInRuleMatch env) + (getInScope env) fn args rules of { Nothing -> return Nothing ; -- No rule matches Just (rule, rule_rhs) -> do { tick (RuleFired (ru_name rule)) + ; dflags <- getDOptsSmpl ; trace_dump dflags rule rule_rhs $ - return (Just (ruleArity rule, rule_rhs)) }}}} + return (Just (ruleArity rule, rule_rhs)) }}} where trace_dump dflags rule rule_rhs stuff - | not (dopt Opt_D_dump_rule_firings dflags) = stuff - | not (dopt Opt_D_verbose_core2core dflags) + | not (dopt Opt_D_dump_rule_firings dflags) + , not (dopt Opt_D_dump_rule_rewrites dflags) = stuff + + | not (dopt Opt_D_dump_rule_rewrites dflags) + = pprDefiniteTrace "Rule fired:" (ftext (ru_name rule)) stuff - = pprTrace "Rule fired:" (ftext (ru_name rule)) stuff | otherwise - = pprTrace "Rule fired" + = pprDefiniteTrace "Rule fired" (vcat [text "Rule:" <+> ftext (ru_name rule), - text "Before:" <+> ppr fn <+> sep (map pprParendExpr args), + text "Before:" <+> hang (ppr fn) 2 (sep (map pprParendExpr args)), text "After: " <+> pprCoreExpr rule_rhs, text "Cont: " <+> ppr call_cont]) stuff @@ -1393,7 +1465,7 @@ %************************************************************************ %* * - Rebuilding a cse expression + Rebuilding a case expression %* * %************************************************************************ @@ -1402,7 +1474,7 @@ The case-elimination transformation discards redundant case expressions. Start with a simple situation: - case x# of ===> e[x#/y#] + case x# of ===> let y# = x# in e y# -> e (when x#, y# are of primitive type, of course). We can't (in general) @@ -1423,29 +1495,40 @@ DEFAULT, after which it's an instance of the previous case. This really only shows up in eliminating error-checking code. -We also make sure that we deal with this very common case: - - case e of - x -> ...x... - -Here we are using the case as a strict let; if x is used only once -then we want to inline it. We have to be careful that this doesn't -make the program terminate when it would have diverged before, so we -check that - - e is already evaluated (it may so if e is a variable) - - x is used strictly, or - -Lastly, the code in SimplUtils.mkCase combines identical RHSs. So +Note that SimplUtils.mkCase combines identical RHSs. So case e of ===> case e of DEFAULT -> r True -> r False -> r Now again the case may be elminated by the CaseElim transformation. +This includes things like (==# a# b#)::Bool so that we simplify + case ==# a# b# of { True -> x; False -> x } +to just + x +This particular example shows up in default methods for +comparision operations (e.g. in (>=) for Int.Int32) Note [CaseElimination: lifted case] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -We do not use exprOkForSpeculation in the lifted case. Consider +We also make sure that we deal with this very common case, +where x has a lifted type: + + case e of + x -> ...x... + +Here we are using the case as a strict let; if x is used only once +then we want to inline it. We have to be careful that this doesn't +make the program terminate when it would have diverged before, so we +check that + (a) 'e' is already evaluated (it may so if e is a variable) + Specifically we check (exprIsHNF e) +or + (b) the scrutinee is a variable and 'x' is used strictly +or + (c) 'x' is not used at all and e is ok-for-speculation + +For the (c), consider case (case a ># b of { True -> (p,q); False -> (q,p) }) of r -> blah The scrutinee is ok-for-speculation (it looks inside cases), but we do @@ -1545,33 +1628,33 @@ -- then there is now only one (DEFAULT) rhs | all isDeadBinder bndrs -- bndrs are [InId] - -- Check that the scrutinee can be let-bound instead of case-bound , if isUnLiftedType (idType case_bndr) - then exprOkForSpeculation scrut - -- Satisfy the let-binding invariant - -- This includes things like (==# a# b#)::Bool - -- so that we simplify - -- case ==# a# b# of { True -> x; False -> x } - -- to just - -- x - -- This particular example shows up in default methods for - -- comparision operations (e.g. in (>=) for Int.Int32) - - else exprIsHNF scrut || var_demanded_later scrut - -- It's already evaluated, or will be demanded later - -- See Note [Case elimination: lifted case] + then ok_for_spec -- Satisfy the let-binding invariant + else elim_lifted = do { tick (CaseElim case_bndr) ; env' <- simplNonRecX env case_bndr scrut -- If case_bndr is deads, simplNonRecX will discard ; simplExprF env' rhs cont } where - -- The case binder is going to be evaluated later, - -- and the scrutinee is a simple variable - var_demanded_later (Var v) = isStrictDmd (idDemandInfo case_bndr) - && not (isTickBoxOp v) + elim_lifted -- See Note [Case elimination: lifted case] + = exprIsHNF scrut + || (strict_case_bndr && scrut_is_var scrut) + -- The case binder is going to be evaluated later, + -- and the scrutinee is a simple variable + + || (is_plain_seq && ok_for_spec) + -- Note: not the same as exprIsHNF + + ok_for_spec = exprOkForSpeculation scrut + is_plain_seq = isDeadBinder case_bndr -- Evaluation *only* for effect + strict_case_bndr = isStrictDmd (idDemandInfo case_bndr) + + scrut_is_var (Cast s _) = scrut_is_var s + scrut_is_var (Var v) = not (isTickBoxOp v) -- ugly hack; covering this case is what -- exprOkForSpeculation was intended for. - var_demanded_later _ = False + scrut_is_var _ = False + -------------------------------------------------- -- 3. Try seq rules; see Note [User-defined RULES for seq] in MkId @@ -1729,10 +1812,10 @@ -> SimplM (SimplEnv, OutExpr, OutId) -- Note [Improving seq] improveSeq fam_envs env scrut case_bndr case_bndr1 [(DEFAULT,_,_)] - | not (isDeadBinder case_bndr) -- Not a pure seq! See the Note! + | not (isDeadBinder case_bndr) -- Not a pure seq! See Note [Improving seq] , Just (co, ty2) <- topNormaliseType fam_envs (idType case_bndr1) = do { case_bndr2 <- newId (fsLit "nt") ty2 - ; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCoercion co) + ; let rhs = DoneEx (Var case_bndr2 `Cast` mkSymCo co) env2 = extendIdSubst env case_bndr rhs ; return (env2, scrut `Cast` co, case_bndr2) } @@ -1795,7 +1878,7 @@ = go vs the_strs where go [] [] = [] - go (v:vs') strs | isTyCoVar v = v : go vs' strs + go (v:vs') strs | isTyVar v = v : go vs' strs go (v:vs') (str:strs) | isMarkedStrict str = evald_v : go vs' strs | otherwise = zapped_v : go vs' strs @@ -1894,7 +1977,7 @@ bind_args env' [] _ = return env' bind_args env' (b:bs') (Type ty : args) - = ASSERT( isTyCoVar b ) + = ASSERT( isTyVar b ) bind_args (extendTvSubst env' b ty) bs' args bind_args env' (b:bs') (arg : args) @@ -1954,16 +2037,44 @@ \begin{code} prepareCaseCont :: SimplEnv -> [InAlt] -> SimplCont - -> SimplM (SimplEnv, SimplCont,SimplCont) - -- Return a duplicatable continuation, a non-duplicable part - -- plus some extra bindings (that scope over the entire - -- continunation) - - -- No need to make it duplicatable if there's only one alternative -prepareCaseCont env [_] cont = return (env, cont, mkBoringStop) -prepareCaseCont env _ cont = mkDupableCont env cont + -> SimplM (SimplEnv, SimplCont, SimplCont) +-- We are considering +-- K[case _ of { p1 -> r1; ...; pn -> rn }] +-- where K is some enclosing continuation for the case +-- Goal: split K into two pieces Kdup,Knodup so that +-- a) Kdup can be duplicated +-- b) Knodup[Kdup[e]] = K[e] +-- The idea is that we'll transform thus: +-- Knodup[ (case _ of { p1 -> Kdup[r1]; ...; pn -> Kdup[rn] } +-- +-- We also return some extra bindings in SimplEnv (that scope over +-- the entire continuation) + +prepareCaseCont env alts cont + | many_alts alts = mkDupableCont env cont + | otherwise = return (env, cont, mkBoringStop) + where + many_alts :: [InAlt] -> Bool -- True iff strictly > 1 non-bottom alternative + many_alts [] = False -- See Note [Bottom alternatives] + many_alts [_] = False + many_alts (alt:alts) + | is_bot_alt alt = many_alts alts + | otherwise = not (all is_bot_alt alts) + + is_bot_alt (_,_,rhs) = exprIsBottom rhs \end{code} +Note [Bottom alternatives] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +When we have + case (case x of { A -> error .. ; B -> e; C -> error ..) + of alts +then we can just duplicate those alts because the A and C cases +will disappear immediately. This is more direct than creating +join points and inlining them away; and in some cases we would +not even create the join points (see Note [Single-alternative case]) +and we would keep the case-of-case which is silly. See Trac #4930. + \begin{code} mkDupableCont :: SimplEnv -> SimplCont -> SimplM (SimplEnv, SimplCont, SimplCont) @@ -2014,10 +2125,13 @@ -- let ji = \xij -> ei -- in case [...hole...] of { pi -> ji xij } do { tick (CaseOfCase case_bndr) - ; (env', dup_cont, nodup_cont) <- mkDupableCont env cont - -- NB: call mkDupableCont here, *not* prepareCaseCont - -- We must make a duplicable continuation, whereas prepareCaseCont - -- doesn't when there is a single case branch + ; (env', dup_cont, nodup_cont) <- prepareCaseCont env alts cont + -- NB: We call prepareCaseCont here. If there is only one + -- alternative, then dup_cont may be big, but that's ok + -- becuase we push it into the single alternative, and then + -- use mkDupableAlt to turn that simplified alternative into + -- a join point if it's too big to duplicate. + -- And this is important: see Note [Fusing case continuations] ; let alt_env = se `setInScope` env' ; (alt_env', case_bndr') <- simplBinder alt_env case_bndr @@ -2081,7 +2195,7 @@ | otherwise = bndrs' ++ [case_bndr_w_unf] abstract_over bndr - | isTyCoVar bndr = True -- Abstract over all type variables just in case + | isTyVar bndr = True -- Abstract over all type variables just in case | otherwise = not (isDeadBinder bndr) -- The deadness info on the new Ids is preserved by simplBinders @@ -2109,6 +2223,37 @@ -- See Note [Duplicated env] \end{code} +Note [Fusing case continuations] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +It's important to fuse two successive case continuations when the +first has one alternative. That's why we call prepareCaseCont here. +Consider this, which arises from thunk splitting (see Note [Thunk +splitting] in WorkWrap): + + let + x* = case (case v of {pn -> rn}) of + I# a -> I# a + in body + +The simplifier will find + (Var v) with continuation + Select (pn -> rn) ( + Select [I# a -> I# a] ( + StrictBind body Stop + +So we'll call mkDupableCont on + Select [I# a -> I# a] (StrictBind body Stop) +There is just one alternative in the first Select, so we want to +simplify the rhs (I# a) with continuation (StricgtBind body Stop) +Supposing that body is big, we end up with + let $j a = + in case v of { pn -> case rn of + I# a -> $j a } +This is just what we want because the rn produces a box that +the case rn cancels with. + +See Trac #4957 a fuller example. + Note [Case binders and join points] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider this @@ -2290,9 +2435,6 @@ Unlike StrictArg, there doesn't seem anything to gain from duplicating a StrictBind continuation, so we don't. -The desire not to duplicate is the entire reason that -mkDupableCont returns a pair of continuations. - Note [Single-alternative cases] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -2362,8 +2504,7 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Here's another single-alternative where we really want to do case-of-case: -data Mk1 = Mk1 Int# -data Mk1 = Mk2 Int# +data Mk1 = Mk1 Int# | Mk2 Int# M1.f = \r [x_s74 y_s6X] @@ -2388,7 +2529,15 @@ So the outer case is doing *nothing at all*, other than serving as a join-point. In this case we really want to do case-of-case and decide -whether to use a real join point or just duplicate the continuation. +whether to use a real join point or just duplicate the continuation: + + let $j s7c = case x of + Mk1 ipv77 -> (==) s7c ipv77 + Mk1 ipv79 -> (==) s7c ipv79 + in + case y of + Mk1 ipv70 -> $j ipv70 + Mk2 ipv72 -> $j ipv72 Hence: check whether the case binder's type is unlifted, because then the outer case is *not* a seq. diff -Nru ghc-7.0.3/compiler/simplCore/SimplUtils.lhs ghc-7.2.1/compiler/simplCore/SimplUtils.lhs --- ghc-7.0.3/compiler/simplCore/SimplUtils.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/simplCore/SimplUtils.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -36,6 +36,7 @@ import CoreSyn import qualified CoreSubst import PprCore +import DataCon ( dataConCannotMatch ) import CoreFVs import CoreUtils import CoreArity @@ -45,17 +46,16 @@ import Var import Demand import SimplMonad -import TcType ( isDictLikeTy ) import Type hiding( substTy ) -import Coercion ( coercionKind ) +import Coercion hiding( substCo ) import TyCon -import Unify ( dataConCannotMatch ) import VarSet import BasicTypes import Util import MonadUtils import Outputable import FastString +import Pair import Data.List \end{code} @@ -99,6 +99,7 @@ | CoerceIt -- C `cast` co OutCoercion -- The coercion simplified + -- Invariant: never an identity coercion SimplCont | ApplyTo -- C arg @@ -208,6 +209,7 @@ contIsTrivial :: SimplCont -> Bool contIsTrivial (Stop {}) = True contIsTrivial (ApplyTo _ (Type _) _ cont) = contIsTrivial cont +contIsTrivial (ApplyTo _ (Coercion _) _ cont) = contIsTrivial cont contIsTrivial (CoerceIt _ cont) = contIsTrivial cont contIsTrivial _ = False @@ -216,17 +218,19 @@ contResultType env ty cont = go cont ty where - subst_ty se ty = substTy (se `setInScope` env) ty + subst_ty se ty = SimplEnv.substTy (se `setInScope` env) ty + subst_co se co = SimplEnv.substCo (se `setInScope` env) co go (Stop {}) ty = ty - go (CoerceIt co cont) _ = go cont (snd (coercionKind co)) + go (CoerceIt co cont) _ = go cont (pSnd (coercionKind co)) go (StrictBind _ bs body se cont) _ = go cont (subst_ty se (exprType (mkLams bs body))) go (StrictArg ai _ cont) _ = go cont (funResultTy (argInfoResultTy ai)) go (Select _ _ alts se cont) _ = go cont (subst_ty se (coreAltsType alts)) go (ApplyTo _ arg se cont) ty = go cont (apply_to_arg ty arg se) - apply_to_arg ty (Type ty_arg) se = applyTy ty (subst_ty se ty_arg) - apply_to_arg ty _ _ = funResultTy ty + apply_to_arg ty (Type ty_arg) se = applyTy ty (subst_ty se ty_arg) + apply_to_arg ty (Coercion co_arg) se = applyCo ty (subst_co se co_arg) + apply_to_arg ty _ _ = funResultTy ty argInfoResultTy :: ArgInfo -> OutType argInfoResultTy (ArgInfo { ai_fun = fun, ai_args = args }) @@ -235,6 +239,7 @@ ------------------- countValArgs :: SimplCont -> Int countValArgs (ApplyTo _ (Type _) _ cont) = countValArgs cont +countValArgs (ApplyTo _ (Coercion _) _ cont) = countValArgs cont countValArgs (ApplyTo _ _ _ cont) = 1 + countValArgs cont countValArgs _ = 0 @@ -468,12 +473,17 @@ sm_eta_expand :: Bool -- Whether eta-expansion is enabled \begin{code} -simplEnvForGHCi :: SimplEnv -simplEnvForGHCi = mkSimplEnv $ - SimplMode { sm_names = ["GHCi"] - , sm_phase = InitialPhase - , sm_rules = True, sm_inline = False - , sm_eta_expand = False, sm_case_case = True } +simplEnvForGHCi :: DynFlags -> SimplEnv +simplEnvForGHCi dflags + = mkSimplEnv $ SimplMode { sm_names = ["GHCi"] + , sm_phase = InitialPhase + , sm_rules = rules_on + , sm_inline = False + , sm_eta_expand = eta_expand_on + , sm_case_case = True } + where + rules_on = dopt Opt_EnableRewriteRules dflags + eta_expand_on = dopt Opt_DoLambdaEtaExpansion dflags -- Do not do any inlining, in case we expose some unboxed -- tuple stuff that confuses the bytecode interpreter @@ -481,9 +491,10 @@ -- See Note [Simplifying inside InlineRules] updModeForInlineRules inline_rule_act current_mode = current_mode { sm_phase = phaseFromActivation inline_rule_act - , sm_rules = True , sm_inline = True , sm_eta_expand = False } + -- For sm_rules, just inherit; sm_rules might be "off" + -- becuase of -fno-enable-rewrite-rules where phaseFromActivation (ActiveAfter n) = Phase n phaseFromActivation _ = InitialPhase @@ -658,11 +669,11 @@ prag = idInlinePragma id ---------------------- -activeRule :: DynFlags -> SimplEnv -> Maybe (Activation -> Bool) +activeRule :: SimplEnv -> Activation -> Bool -- Nothing => No rules at all -activeRule _dflags env - | not (sm_rules mode) = Nothing -- Rewriting is off - | otherwise = Just (isActive (sm_phase mode)) +activeRule env + | not (sm_rules mode) = \_ -> False -- Rewriting is off + | otherwise = isActive (sm_phase mode) where mode = getMode env \end{code} @@ -778,6 +789,11 @@ once, because FloatOut has gone to some trouble to extract them out. Inlining them won't make the program run faster! +Note [Do not inline CoVars unconditionally] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Coercion variables appear inside coercions, and have a separate +substitution, so don't inline them via the IdSubst! + \begin{code} preInlineUnconditionally :: SimplEnv -> TopLevelFlag -> InId -> InExpr -> Bool preInlineUnconditionally env top_lvl bndr rhs @@ -785,6 +801,7 @@ | isStableUnfolding (idUnfolding bndr) = False -- Note [InlineRule and preInlineUnconditionally] | isTopLevel top_lvl && isBottomingId bndr = False -- Note [Top-level bottoming Ids] | opt_SimplNoPreInlining = False + | isCoVar bndr = False -- Note [Do not inline CoVars unconditionally] | otherwise = case idOccInfo bndr of IAmDead -> True -- Happens in ((\x.1) v) OneOcc in_lam True int_cxt -> try_once in_lam int_cxt @@ -882,13 +899,14 @@ postInlineUnconditionally :: SimplEnv -> TopLevelFlag -> OutId -- The binder (an InId would be fine too) + -- (*not* a CoVar) -> OccInfo -- From the InId -> OutExpr -> Unfolding -> Bool postInlineUnconditionally env top_lvl bndr occ_info rhs unfolding | not active = False - | isLoopBreaker occ_info = False -- If it's a loop-breaker of any kind, don't inline + | isWeakLoopBreaker occ_info = False -- If it's a loop-breaker of any kind, don't inline -- because it might be referred to "earlier" | isExportedId bndr = False | isStableUnfolding unfolding = False -- Note [InlineRule and postInlineUnconditionally] @@ -982,6 +1000,7 @@ * There is less point, because the main goal is to get rid of local bindings used in multiple case branches. + * The inliner should inline trivial things at call sites anyway. Note [InlineRule and postInlineUnconditionally] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1026,9 +1045,9 @@ | not (any bad bndrs) -- Note [Casts and lambdas] = do { lam <- mkLam' dflags bndrs body - ; return (mkCoerce (mkPiTypes bndrs co) lam) } + ; return (mkCoerce (mkPiCos bndrs co) lam) } where - co_vars = tyVarsOfType co + co_vars = tyCoVarsOfCo co bad bndr = isCoVar bndr && bndr `elemVarSet` co_vars mkLam' dflags bndrs body@(Lam {}) @@ -1042,7 +1061,7 @@ = do { tick (EtaReduction (head bndrs)) ; return etad_lam } - | otherwise + | otherwise = return (mkLams bndrs body) \end{code} @@ -1085,9 +1104,6 @@ %* * %************************************************************************ -When we meet a let-binding we try eta-expansion. To find the -arity of the RHS we use a little fixpoint analysis; see Note [Arity analysis] - \begin{code} tryEtaExpand :: SimplEnv -> OutId -> OutExpr -> SimplM (Arity, OutExpr) -- See Note [Eta-expanding at let bindings] @@ -1102,17 +1118,20 @@ return (new_arity, new_rhs) } where try_expand dflags + | exprIsTrivial rhs + = return (exprArity rhs, rhs) + | sm_eta_expand (getMode env) -- Provided eta-expansion is on - , not (exprIsTrivial rhs) , let dicts_cheap = dopt Opt_DictsCheap dflags new_arity = findArity dicts_cheap bndr rhs old_arity - , new_arity > rhs_arity + , new_arity > manifest_arity -- And the curent manifest arity isn't enough + -- See Note [Eta expansion to manifes arity] = do { tick (EtaExpansion bndr) ; return (new_arity, etaExpand new_arity rhs) } | otherwise - = return (rhs_arity, rhs) + = return (manifest_arity, rhs) - rhs_arity = exprArity rhs + manifest_arity = manifestArity rhs old_arity = idArity bndr _dmd_arity = length $ fst $ splitStrictSig $ idStrictness bndr @@ -1201,6 +1220,23 @@ as far as the programmer is concerned, it's not applied to two arguments! +Note [Eta expansion to manifest arity] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Eta expansion does *not* eta-expand trivial RHSs, like + x = y +because these will get substituted out in short order. (Indeed +we *eta-contract* if that yields a trivial RHS.) + +Otherwise we eta-expand to produce enough manifest lambdas. +This *does* eta-expand partial applications. eg + x = map g --> x = \v -> map g v + y = \_ -> map g --> y = \_ v -> map g v +One benefit this is that in the definition of y there was +a danger that full laziness would transform to + lvl = map g + y = \_ -> lvl +which is stupid. This doesn't happen in the eta-expanded form. + Note [Arity analysis] ~~~~~~~~~~~~~~~~~~~~~ The motivating example for arity analysis is this: @@ -1330,9 +1366,7 @@ ; return (subst', (NonRec poly_id poly_rhs)) } where rhs' = CoreSubst.substExpr (text "abstract_floats2") subst rhs - tvs_here | any isCoVar main_tvs = main_tvs -- Note [Abstract over coercions] - | otherwise - = varSetElems (main_tv_set `intersectVarSet` exprSomeFreeVars isTyCoVar rhs') + tvs_here = varSetElems (main_tv_set `intersectVarSet` exprSomeFreeVars isTyVar rhs') -- Abstract only over the type variables free in the rhs -- wrt which the new binding is abstracted. But the naive @@ -1544,9 +1578,8 @@ [con] -> -- It matches exactly one constructor, so fill it in do { tick (FillInCaseDefault case_bndr) ; us <- getUniquesM - ; let (ex_tvs, co_tvs, arg_ids) = - dataConRepInstPat us con inst_tys - ; return [(DataAlt con, ex_tvs ++ co_tvs ++ arg_ids, deflt_rhs)] } + ; let (ex_tvs, arg_ids) = dataConRepInstPat us con inst_tys + ; return [(DataAlt con, ex_tvs ++ arg_ids, deflt_rhs)] } _ -> return [(DEFAULT, [], deflt_rhs)] diff -Nru ghc-7.0.3/compiler/specialise/Rules.lhs ghc-7.2.1/compiler/specialise/Rules.lhs --- ghc-7.0.3/compiler/specialise/Rules.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/specialise/Rules.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -37,10 +37,10 @@ import PprCore ( pprRules ) import Type ( Type ) import TcType ( tcSplitTyConApp_maybe ) +import Coercion import CoreTidy ( tidyRules ) import Id import IdInfo ( SpecInfo( SpecInfo ) ) -import Var ( Var ) import VarEnv import VarSet import Name ( Name, NamedThing(..) ) @@ -56,7 +56,6 @@ import Data.List \end{code} - Note [Overall plumbing for rules] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ * After the desugarer: @@ -184,8 +183,9 @@ roughTopName :: CoreExpr -> Maybe Name roughTopName (Type ty) = case tcSplitTyConApp_maybe ty of - Just (tc,_) -> Just (getName tc) - Nothing -> Nothing + Just (tc,_) -> Just (getName tc) + Nothing -> Nothing +roughTopName (Coercion _) = Nothing roughTopName (App f _) = roughTopName f roughTopName (Var f) | isGlobalId f -- Note [Care with roughTopName] , isDataConWorkId f || idArity f > 0 @@ -625,10 +625,7 @@ -- succeed in matching what looks like the template variable 'a' against 3. -- The Var case follows closely what happens in Unify.match -match renv subst (Var v1) e2 - | Just subst <- match_var renv subst v1 e2 - = Just subst - +match renv subst (Var v1) e2 = match_var renv subst v1 e2 match renv subst (Note _ e1) e2 = match renv subst e1 e2 match renv subst e1 (Note _ e2) = match renv subst e1 e2 -- Ignore notes in both template and thing to be matched @@ -714,15 +711,29 @@ match renv subst (Type ty1) (Type ty2) = match_ty renv subst ty1 ty2 +match renv subst (Coercion co1) (Coercion co2) + = match_co renv subst co1 co2 match renv subst (Cast e1 co1) (Cast e2 co2) - = do { subst1 <- match_ty renv subst co1 co2 + = do { subst1 <- match_co renv subst co1 co2 ; match renv subst1 e1 e2 } -- Everything else fails match _ _ _e1 _e2 = -- pprTrace "Failing at" ((text "e1:" <+> ppr _e1) $$ (text "e2:" <+> ppr _e2)) $ Nothing +------------- +match_co :: RuleEnv + -> RuleSubst + -> Coercion + -> Coercion + -> Maybe RuleSubst +match_co renv subst (CoVarCo cv) co + = match_var renv subst cv (Coercion co) +match_co _ _ co1 _ + = pprTrace "match_co baling out" (ppr co1) Nothing + +------------- rnMatchBndr2 :: RuleEnv -> RuleSubst -> Var -> Var -> RuleEnv rnMatchBndr2 renv subst x1 x2 = renv { rv_lcl = rnBndr2 rn_env x1 x2 @@ -1038,6 +1049,7 @@ ruleCheck _ (Var _) = emptyBag ruleCheck _ (Lit _) = emptyBag ruleCheck _ (Type _) = emptyBag +ruleCheck _ (Coercion _) = emptyBag ruleCheck env (App f a) = ruleCheckApp env (App f a) [] ruleCheck env (Note _ e) = ruleCheck env e ruleCheck env (Cast e _) = ruleCheck env e diff -Nru ghc-7.0.3/compiler/specialise/SpecConstr.lhs ghc-7.2.1/compiler/specialise/SpecConstr.lhs --- ghc-7.0.3/compiler/specialise/SpecConstr.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/specialise/SpecConstr.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -1,3 +1,8 @@ +ToDo [Nov 2010] +~~~~~~~~~~~~~~~ +1. Use a library type rather than an annotation for ForceSpecConstr +2. Nuke NoSpecConstr + % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % @@ -28,9 +33,9 @@ import HscTypes ( ModGuts(..) ) import WwLib ( mkWorkerArgs ) import DataCon -import Coercion +import Coercion hiding( substTy, substCo ) import Rules -import Type hiding( substTy ) +import Type hiding ( substTy ) import Id import MkCore ( mkImpossibleExpr ) import Var @@ -45,6 +50,7 @@ import DmdAnal ( both ) import Serialized ( deserializeWithData ) import Util +import Pair import UniqSupply import Outputable import FastString @@ -58,7 +64,6 @@ #ifndef GHCI type SpecConstrAnnotation = () #else -import Literal ( literalType ) import TyCon ( TyCon ) import GHC.Exts( SpecConstrAnnotation(..) ) #endif @@ -382,6 +387,18 @@ we were getting literally hundreds of (mostly unused) specialisations of a local function. +In a case like the above we end up never calling the original un-specialised +function. (Although we still leave its code around just in case.) + +However, if we find any boring calls in the body, including *unsaturated* +ones, such as + letrec foo x y = ....foo... + in map foo xs +then we will end up calling the un-specialised function, so then we *should* +use the calls in the un-specialised RHS as seeds. We call these "boring +call patterns, and callsToPats reports if it finds any of these. + + Note [Do not specialise diverging functions] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Specialising a function that just diverges is a waste of code. @@ -421,22 +438,87 @@ {-# INLINE foldl #-} foldl f z (Stream step s _) = foldl_loop SPEC z s where - foldl_loop SPEC z s = case step s of - Yield x s' -> foldl_loop SPEC (f z x) s' - Skip -> foldl_loop SPEC z s' + foldl_loop !sPEC z s = case step s of + Yield x s' -> foldl_loop sPEC (f z x) s' + Skip -> foldl_loop sPEC z s' Done -> z SpecConstr will spot the SPEC parameter and always fully specialise -foldl_loop. Note that we can't just annotate foldl_loop since it isn't a -top-level function but even if we could, inlining etc. could easily drop the -annotation. We also have to prevent the SPEC argument from being removed by -w/w which is why SPEC is a sum type. This is all quite ugly; we ought to come -up with a better design. +foldl_loop. Note that + + * We have to prevent the SPEC argument from being removed by + w/w which is why (a) SPEC is a sum type, and (b) we have to seq on + the SPEC argument. + + * And lastly, the SPEC argument is ultimately eliminated by + SpecConstr itself so there is no runtime overhead. + +This is all quite ugly; we ought to come up with a better design. ForceSpecConstr arguments are spotted in scExpr' and scTopBinds which then set -force_spec to True when calling specLoop. This flag makes specLoop and -specialise ignore specConstrCount and specConstrThreshold when deciding -whether to specialise a function. +sc_force to True when calling specLoop. This flag does three things: + * Ignore specConstrThreshold, to specialise functions of arbitrary size + (see scTopBind) + * Ignore specConstrCount, to make arbitrary numbers of specialisations + (see specialise) + * Specialise even for arguments that are not scrutinised in the loop + (see argToPat; Trac #4488) + +This flag is inherited for nested non-recursive bindings (which are likely to +be join points and hence should be fully specialised) but reset for nested +recursive bindings. + +What alternatives did I consider? Annotating the loop itself doesn't +work because (a) it is local and (b) it will be w/w'ed and I having +w/w propagating annotation somehow doesn't seem like a good idea. The +types of the loop arguments really seem to be the most persistent +thing. + +Annotating the types that make up the loop state doesn't work, +either, because (a) it would prevent us from using types like Either +or tuples here, (b) we don't want to restrict the set of types that +can be used in Stream states and (c) some types are fixed by the user +(e.g., the accumulator here) but we still want to specialise as much +as possible. + +ForceSpecConstr is done by way of an annotation: + data SPEC = SPEC | SPEC2 + {-# ANN type SPEC ForceSpecConstr #-} +But SPEC is the *only* type so annotated, so it'd be better to +use a particular library type. + +Alternatives to ForceSpecConstr +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Instead of giving the loop an extra argument of type SPEC, we +also considered *wrapping* arguments in SPEC, thus + data SPEC a = SPEC a | SPEC2 + + loop = \arg -> case arg of + SPEC state -> + case state of (x,y) -> ... loop (SPEC (x',y')) ... + S2 -> error ... +The idea is that a SPEC argument says "specialise this argument +regardless of whether the function case-analyses it. But this +doesn't work well: + * SPEC must still be a sum type, else the strictness analyser + eliminates it + * But that means that 'loop' won't be strict in its real payload +This loss of strictness in turn screws up specialisation, because +we may end up with calls like + loop (SPEC (case z of (p,q) -> (q,p))) +Without the SPEC, if 'loop' was strict, the case would move out +and we'd see loop applied to a pair. But if 'loop' isn' strict +this doesn't look like a specialisable call. + +Note [NoSpecConstr] +~~~~~~~~~~~~~~~~~~~ +The ignoreDataCon stuff allows you to say + {-# ANN type T NoSpecConstr #-} +to mean "don't specialise on arguments of this type. It was added +before we had ForceSpecConstr. Lacking ForceSpecConstr we specialised +regardless of size; and then we needed a way to turn that *off*. Now +that we have ForceSpecConstr, this NoSpecConstr is probably redundant. +(Used only for PArray.) ----------------------------------------------------- Stuff not yet handled @@ -546,6 +628,8 @@ data ScEnv = SCE { sc_size :: Maybe Int, -- Size threshold sc_count :: Maybe Int, -- Max # of specialisations for any one fn -- See Note [Avoiding exponential blowup] + sc_force :: Bool, -- Force specialisation? + -- See Note [Forcing specialisation] sc_subst :: Subst, -- Current substitution -- Maps InIds to OutExprs @@ -588,6 +672,7 @@ initScEnv dflags anns = SCE { sc_size = specConstrThreshold dflags, sc_count = specConstrCount dflags, + sc_force = False, sc_subst = emptySubst, sc_how_bound = emptyVarEnv, sc_vals = emptyVarEnv, @@ -603,6 +688,9 @@ ppr RecFun = text "RecFun" ppr RecArg = text "RecArg" +scForce :: ScEnv -> Bool -> ScEnv +scForce env b = env { sc_force = b } + lookupHowBound :: ScEnv -> Id -> Maybe HowBound lookupHowBound env id = lookupVarEnv (sc_how_bound env) id @@ -612,6 +700,9 @@ scSubstTy :: ScEnv -> Type -> Type scSubstTy env ty = substTy (sc_subst env) ty +scSubstCo :: ScEnv -> Coercion -> Coercion +scSubstCo env co = substCo (sc_subst env) co + zapScSubst :: ScEnv -> ScEnv zapScSubst env = env { sc_subst = zapSubstEnv (sc_subst env) } @@ -690,7 +781,7 @@ vanilla_args = map Type (tyConAppArgs (idType case_bndr)) ++ varsToCoreExprs alt_bndrs - zap v | isTyCoVar v = v -- See NB2 above + zap v | isTyVar v = v -- See NB2 above | otherwise = zapIdOccInfo v @@ -706,18 +797,16 @@ --------------------------------------------------- -- See Note [SpecConstrAnnotation] ignoreType :: ScEnv -> Type -> Bool -ignoreAltCon :: ScEnv -> AltCon -> Bool +ignoreDataCon :: ScEnv -> DataCon -> Bool forceSpecBndr :: ScEnv -> Var -> Bool #ifndef GHCI ignoreType _ _ = False -ignoreAltCon _ _ = False +ignoreDataCon _ _ = False forceSpecBndr _ _ = False #else /* GHCI */ -ignoreAltCon env (DataAlt dc) = ignoreTyCon env (dataConTyCon dc) -ignoreAltCon env (LitAlt lit) = ignoreType env (literalType lit) -ignoreAltCon _ DEFAULT = panic "ignoreAltCon" -- DEFAULT cannot be in a ConVal +ignoreDataCon env dc = ignoreTyCon env (dataConTyCon dc) ignoreType env ty = case splitTyConApp_maybe ty of @@ -824,11 +913,6 @@ combineUsages [] = nullUsage combineUsages us = foldr1 combineUsage us -lookupOcc :: ScUsage -> OutVar -> (ScUsage, ArgOcc) -lookupOcc (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndr - = (SCU {scu_calls = sc_calls, scu_occs = delVarEnv sc_occs bndr}, - lookupVarEnv sc_occs bndr `orElse` NoOcc) - lookupOccs :: ScUsage -> [OutVar] -> (ScUsage, [ArgOcc]) lookupOccs (SCU { scu_calls = sc_calls, scu_occs = sc_occs }) bndrs = (SCU {scu_calls = sc_calls, scu_occs = delVarEnvList sc_occs bndrs}, @@ -837,12 +921,13 @@ data ArgOcc = NoOcc -- Doesn't occur at all; or a type argument | UnkOcc -- Used in some unknown way - | ScrutOcc (UniqFM [ArgOcc]) -- See Note [ScrutOcc] - - | BothOcc -- Definitely taken apart, *and* perhaps used in some other way + | ScrutOcc -- See Note [ScrutOcc] + (DataConEnv [ArgOcc]) -- How the sub-components are used -{- Note [ScrutOcc] +type DataConEnv a = UniqFM a -- Keyed by DataCon +{- Note [ScrutOcc] +~~~~~~~~~~~~~~~~~~~ An occurrence of ScrutOcc indicates that the thing, or a `cast` version of the thing, is *only* taken apart or applied. @@ -862,9 +947,11 @@ instance Outputable ArgOcc where ppr (ScrutOcc xs) = ptext (sLit "scrut-occ") <> ppr xs ppr UnkOcc = ptext (sLit "unk-occ") - ppr BothOcc = ptext (sLit "both-occ") ppr NoOcc = ptext (sLit "no-occ") +evalScrutOcc :: ArgOcc +evalScrutOcc = ScrutOcc emptyUFM + -- Experimentally, this vesion of combineOcc makes ScrutOcc "win", so -- that if the thing is scrutinised anywhere then we get to see that -- in the overall result, even if it's also used in a boxed way @@ -873,10 +960,9 @@ combineOcc NoOcc occ = occ combineOcc occ NoOcc = occ combineOcc (ScrutOcc xs) (ScrutOcc ys) = ScrutOcc (plusUFM_C combineOccs xs ys) -combineOcc _occ (ScrutOcc ys) = ScrutOcc ys -combineOcc (ScrutOcc xs) _occ = ScrutOcc xs +combineOcc UnkOcc (ScrutOcc ys) = ScrutOcc ys +combineOcc (ScrutOcc xs) UnkOcc = ScrutOcc xs combineOcc UnkOcc UnkOcc = UnkOcc -combineOcc _ _ = BothOcc combineOccs :: [ArgOcc] -> [ArgOcc] -> [ArgOcc] combineOccs xs ys = zipWithEqual "combineOccs" combineOcc xs ys @@ -891,16 +977,6 @@ | otherwise = usg setScrutOcc _env usg _other _occ -- Catch-all = usg - -conArgOccs :: ArgOcc -> AltCon -> [ArgOcc] --- Find usage of components of data con; returns [UnkOcc...] if unknown --- See Note [ScrutOcc] for the extra UnkOccs in the vanilla datacon case - -conArgOccs (ScrutOcc fm) (DataAlt dc) - | Just pat_arg_occs <- lookupUFM fm dc - = [UnkOcc | _ <- dataConUnivTyVars dc] ++ pat_arg_occs - -conArgOccs _other _con = repeat UnkOcc \end{code} %************************************************************************ @@ -921,15 +997,16 @@ scExpr' env (Var v) = case scSubstId env v of - Var v' -> return (varUsage env v' UnkOcc, Var v') + Var v' -> return (mkVarUsage env v' [], Var v') e' -> scExpr (zapScSubst env) e' scExpr' env (Type t) = return (nullUsage, Type (scSubstTy env t)) +scExpr' env (Coercion c) = return (nullUsage, Coercion (scSubstCo env c)) scExpr' _ e@(Lit {}) = return (nullUsage, e) scExpr' env (Note n e) = do (usg,e') <- scExpr env e return (usg, Note n e') scExpr' env (Cast e co) = do (usg, e') <- scExpr env e - return (usg, Cast e' (scSubstTy env co)) + return (usg, Cast e' (scSubstCo env co)) scExpr' env e@(App _ _) = scApp env (collectArgs e) scExpr' env (Lam b e) = do let (env', b') = extendBndr env b (usg, e') <- scExpr env' e @@ -955,28 +1032,27 @@ ; (alt_usgs, alt_occs, alts') <- mapAndUnzip3M (sc_alt alt_env scrut' b') alts - ; let (alt_usg, b_occ) = lookupOcc (combineUsages alt_usgs) b' - scrut_occ = foldr combineOcc b_occ alt_occs - scrut_usg' = setScrutOcc env scrut_usg scrut' scrut_occ + ; let scrut_occ = foldr1 combineOcc alt_occs -- Never empty + scrut_usg' = setScrutOcc env scrut_usg scrut' scrut_occ -- The combined usage of the scrutinee is given -- by scrut_occ, which is passed to scScrut, which -- in turn treats a bare-variable scrutinee specially - ; return (alt_usg `combineUsage` scrut_usg', + ; return (foldr combineUsage scrut_usg' alt_usgs, Case scrut' b' (scSubstTy env ty) alts') } sc_alt env scrut' b' (con,bs,rhs) = do { let (env1, bs1) = extendBndrsWith RecArg env bs (env2, bs2) = extendCaseBndrs env1 scrut' b' con bs1 - ; (usg,rhs') <- scExpr env2 rhs - ; let (usg', arg_occs) = lookupOccs usg bs2 + ; (usg, rhs') <- scExpr env2 rhs + ; let (usg', b_occ:arg_occs) = lookupOccs usg (b':bs2) scrut_occ = case con of DataAlt dc -> ScrutOcc (unitUFM dc arg_occs) _ -> ScrutOcc emptyUFM - ; return (usg', scrut_occ, (con, bs2, rhs')) } + ; return (usg', b_occ `combineOcc` scrut_occ, (con, bs2, rhs')) } scExpr' env (Let (NonRec bndr rhs) body) - | isTyCoVar bndr -- Type-lets may be created by doBeta + | isTyVar bndr -- Type-lets may be created by doBeta = scExpr' (extendScSubst env bndr rhs) body | otherwise @@ -990,17 +1066,15 @@ ; (body_usg, body') <- scExpr body_env3 body - -- NB: We don't use the ForceSpecConstr mechanism (see - -- Note [Forcing specialisation]) for non-recursive bindings - -- at the moment. I'm not sure if this is the right thing to do. - ; let force_spec = False - ; (spec_usg, specs) <- specialise env force_spec + -- NB: For non-recursive bindings we inherit sc_force flag from + -- the parent function (see Note [Forcing specialisation]) + ; (spec_usg, specs) <- specialise env (scu_calls body_usg) rhs_info (SI [] 0 (Just rhs_usg)) ; return (body_usg { scu_calls = scu_calls body_usg `delVarEnv` bndr' } - `combineUsage` spec_usg, + `combineUsage` rhs_usg `combineUsage` spec_usg, mkLets [NonRec b r | (b,r) <- specInfoBinds rhs_info specs] body') } @@ -1017,15 +1091,16 @@ ; (body_usg, body') <- scExpr rhs_env2 body -- NB: start specLoop from body_usg - ; (spec_usg, specs) <- specLoop rhs_env2 force_spec + ; (spec_usg, specs) <- specLoop (scForce rhs_env2 force_spec) (scu_calls body_usg) rhs_infos nullUsage [SI [] 0 (Just usg) | usg <- rhs_usgs] - -- Do not unconditionally use rhs_usgs. + -- Do not unconditionally generate specialisations from rhs_usgs -- Instead use them only if we find an unspecialised call -- See Note [Local recursive groups] - ; let all_usg = spec_usg `combineUsage` body_usg - bind' = Rec (concat (zipWith specInfoBinds rhs_infos specs)) + ; let rhs_usg = combineUsages rhs_usgs + all_usg = spec_usg `combineUsage` rhs_usg `combineUsage` body_usg + bind' = Rec (concat (zipWith specInfoBinds rhs_infos specs)) ; return (all_usg { scu_calls = scu_calls all_usg `delVarEnvList` bndrs' }, Let bind' body') } @@ -1060,15 +1135,8 @@ fn'@(Lam {}) -> scExpr (zapScSubst env) (doBeta fn' args') -- Do beta-reduction and try again - Var fn' -> return (arg_usg `combineUsage` fn_usg, mkApps (Var fn') args') - where - fn_usg = case lookupHowBound env fn' of - Just RecFun -> SCU { scu_calls = unitVarEnv fn' [(sc_vals env, args')], - scu_occs = emptyVarEnv } - Just RecArg -> SCU { scu_calls = emptyVarEnv, - scu_occs = unitVarEnv fn' (ScrutOcc emptyUFM) } - Nothing -> nullUsage - + Var fn' -> return (arg_usg `combineUsage` mkVarUsage env fn' args', + mkApps (Var fn') args') other_fn' -> return (arg_usg, mkApps other_fn' args') } -- NB: doing this ignores any usage info from the substituted @@ -1090,6 +1158,20 @@ ; return (combineUsages arg_usgs `combineUsage` fn_usg, mkApps fn' args') } ---------------------- +mkVarUsage :: ScEnv -> Id -> [CoreExpr] -> ScUsage +mkVarUsage env fn args + = case lookupHowBound env fn of + Just RecFun -> SCU { scu_calls = unitVarEnv fn [(sc_vals env, args)] + , scu_occs = emptyVarEnv } + Just RecArg -> SCU { scu_calls = emptyVarEnv + , scu_occs = unitVarEnv fn arg_occ } + Nothing -> nullUsage + where + -- I rather think we could use UnkOcc all the time + arg_occ | null args = UnkOcc + | otherwise = evalScrutOcc + +---------------------- scTopBind :: ScEnv -> CoreBind -> UniqSM (ScEnv, CoreBind) scTopBind env (Rec prs) | Just threshold <- sc_size env @@ -1106,7 +1188,7 @@ ; (rhs_usgs, rhs_infos) <- mapAndUnzipM (scRecRhs rhs_env2) (bndrs' `zip` rhss) ; let rhs_usg = combineUsages rhs_usgs - ; (_, specs) <- specLoop rhs_env2 force_spec + ; (_, specs) <- specLoop (scForce rhs_env2 force_spec) (scu_calls rhs_usg) rhs_infos nullUsage [SI [] 0 Nothing | _ <- bndrs] @@ -1141,16 +1223,12 @@ specInfoBinds :: RhsInfo -> SpecInfo -> [(Id,CoreExpr)] specInfoBinds (RI fn new_rhs _ _ _) (SI specs _ _) = [(id,rhs) | OS _ _ id rhs <- specs] ++ + -- First the specialised bindings + [(fn `addIdSpecialisations` rules, new_rhs)] + -- And now the original binding where rules = [r | OS _ r _ _ <- specs] - ----------------------- -varUsage :: ScEnv -> OutVar -> ArgOcc -> ScUsage -varUsage env v use - | Just RecArg <- lookupHowBound env v = SCU { scu_calls = emptyVarEnv - , scu_occs = unitVarEnv v use } - | otherwise = nullUsage \end{code} @@ -1171,10 +1249,13 @@ Int -- Length of specs; used for numbering them - (Maybe ScUsage) -- Nothing => we have generated specialisations - -- from calls in the *original* RHS - -- Just cs => we haven't, and this is the usage - -- of the original RHS + (Maybe ScUsage) -- Just cs => we have not yet used calls in the + -- from calls in the *original* RHS as + -- seeds for new specialisations; + -- if you decide to do so, here is the + -- RHS usage (which has not yet been + -- unleashed) + -- Nothing => we have -- See Note [Local recursive groups] -- One specialisation: Rule plus definition @@ -1184,14 +1265,13 @@ specLoop :: ScEnv - -> Bool -- force specialisation? - -- Note [Forcing specialisation] -> CallEnv -> [RhsInfo] -> ScUsage -> [SpecInfo] -- One per binder; acccumulating parameter -> UniqSM (ScUsage, [SpecInfo]) -- ...ditto... -specLoop env force_spec all_calls rhs_infos usg_so_far specs_so_far - = do { specs_w_usg <- zipWithM (specialise env force_spec all_calls) rhs_infos specs_so_far + +specLoop env all_calls rhs_infos usg_so_far specs_so_far + = do { specs_w_usg <- zipWithM (specialise env all_calls) rhs_infos specs_so_far ; let (new_usg_s, all_specs) = unzip specs_w_usg new_usg = combineUsages new_usg_s new_calls = scu_calls new_usg @@ -1199,23 +1279,24 @@ ; if isEmptyVarEnv new_calls then return (all_usg, all_specs) else - specLoop env force_spec new_calls rhs_infos all_usg all_specs } + specLoop env new_calls rhs_infos all_usg all_specs } specialise :: ScEnv - -> Bool -- force specialisation? - -- Note [Forcing specialisation] -> CallEnv -- Info on calls -> RhsInfo -> SpecInfo -- Original RHS plus patterns dealt with -> UniqSM (ScUsage, SpecInfo) -- New specialised versions and their usage +-- Note: this only generates *specialised* bindings +-- The original binding is added by specInfoBinds +-- -- Note: the rhs here is the optimised version of the original rhs -- So when we make a specialised copy of the RHS, we're starting -- from an RHS whose nested functions have been optimised already. -specialise env force_spec bind_calls (RI fn _ arg_bndrs body arg_occs) - spec_info@(SI specs spec_count mb_unspec) +specialise env bind_calls (RI fn _ arg_bndrs body arg_occs) + spec_info@(SI specs spec_count mb_unspec) | not (isBottomingId fn) -- Note [Do not specialise diverging functions] , not (isNeverActive (idInlineActivation fn)) -- See Note [Transfer activation] , notNull arg_bndrs -- Only specialise functions @@ -1231,9 +1312,11 @@ ; let n_pats = length pats spec_count' = n_pats + spec_count ; case sc_count env of - Just max | not force_spec && spec_count' > max - -> pprTrace "SpecConstr" msg $ - return (nullUsage, spec_info) + Just max | not (sc_force env) && spec_count' > max + -> if (debugIsOn || opt_PprStyle_Debug) -- Suppress this scary message for + then pprTrace "SpecConstr" msg $ -- ordinary users! Trac #5125 + return (nullUsage, spec_info) + else return (nullUsage, spec_info) where msg = vcat [ sep [ ptext (sLit "Function") <+> quotes (ppr fn) , nest 2 (ptext (sLit "has") <+> @@ -1341,6 +1424,7 @@ dmd_env = go emptyVarEnv dmds pats go env ds (Type {} : pats) = go env ds pats + go env ds (Coercion {} : pats) = go env ds pats go env (d:ds) (pat : pats) = go (go_one env d pat) ds pats go env _ _ = env @@ -1409,7 +1493,6 @@ \begin{code} type CallPat = ([Var], [CoreExpr]) -- Quantified variables and arguments - callsToPats :: ScEnv -> [OneSpec] -> [ArgOcc] -> [Call] -> UniqSM (Bool, [CallPat]) -- Result has no duplicate patterns, -- nor ones mentioned in done_pats @@ -1417,7 +1500,7 @@ callsToPats env done_specs bndr_occs calls = do { mb_pats <- mapM (callToPats env bndr_occs) calls - ; let good_pats :: [([Var], [CoreArg])] + ; let good_pats :: [CallPat] good_pats = catMaybes mb_pats done_pats = [p | OS p _ _ _ <- done_specs] is_done p = any (samePat p) done_pats @@ -1435,21 +1518,20 @@ = return Nothing | otherwise = do { let in_scope = substInScope (sc_subst env) - ; prs <- argsToPats env in_scope con_env (args `zip` bndr_occs) - ; let (interesting_s, pats) = unzip prs - pat_fvs = varSetElems (exprsFreeVars pats) + ; (interesting, pats) <- argsToPats env in_scope con_env args bndr_occs + ; let pat_fvs = varSetElems (exprsFreeVars pats) qvars = filterOut (`elemInScopeSet` in_scope) pat_fvs -- Quantify over variables that are not in sccpe -- at the call site -- See Note [Shadowing] at the top - (tvs, ids) = partition isTyCoVar qvars + (tvs, ids) = partition isTyVar qvars qvars' = tvs ++ ids -- Put the type variables first; the type of a term -- variable may mention a type variable ; -- pprTrace "callToPats" (ppr args $$ ppr prs $$ ppr bndr_occs) $ - if or interesting_s + if interesting then return (Just (qvars', pats)) else return Nothing } @@ -1465,9 +1547,10 @@ -> CoreArg -- A call arg (or component thereof) -> ArgOcc -> UniqSM (Bool, CoreArg) + -- Returns (interesting, pat), -- where pat is the pattern derived from the argument --- intersting=True if the pattern is non-trivial (not a variable or type) +-- interesting=True if the pattern is non-trivial (not a variable or type) -- E.g. x:xs --> (True, x:xs) -- f xs --> (False, w) where w is a fresh wildcard -- (f xs, 'c') --> (True, (w, 'c')) where w is a fresh wildcard @@ -1477,6 +1560,9 @@ argToPat _env _in_scope _val_env arg@(Type {}) _arg_occ = return (False, arg) + +argToPat _env _in_scope _val_env arg@(Coercion {}) _arg_occ + = return (False, arg) argToPat env in_scope val_env (Note _ arg) arg_occ = argToPat env in_scope val_env arg arg_occ @@ -1502,6 +1588,9 @@ -} argToPat env in_scope val_env (Cast arg co) arg_occ + | isReflCo co -- Substitution in the SpecConstr itself + -- can lead to identity coercions + = argToPat env in_scope val_env arg arg_occ | not (ignoreType env ty2) = do { (interesting, arg') <- argToPat env in_scope val_env arg arg_occ ; if not interesting then @@ -1510,10 +1599,10 @@ { -- Make a wild-card pattern for the coercion uniq <- getUniqueUs ; let co_name = mkSysTvName uniq (fsLit "sg") - co_var = mkCoVar co_name (mkCoKind ty1 ty2) - ; return (interesting, Cast arg' (mkTyVarTy co_var)) } } + co_var = mkCoVar co_name (mkCoType ty1 ty2) + ; return (interesting, Cast arg' (mkCoVarCo co_var)) } } where - (ty1, ty2) = coercionKind co + Pair ty1 ty2 = coercionKind co @@ -1532,25 +1621,28 @@ -- Check for a constructor application -- NB: this *precedes* the Var case, so that we catch nullary constrs argToPat env in_scope val_env arg arg_occ - | Just (ConVal dc args) <- isValue val_env arg - , not (ignoreAltCon env dc) - , case arg_occ of - ScrutOcc _ -> True -- Used only by case scrutinee - BothOcc -> case arg of -- Used elsewhere - App {} -> True -- see Note [Reboxing] - _other -> False - _other -> False -- No point; the arg is not decomposed - = do { args' <- argsToPats env in_scope val_env (args `zip` conArgOccs arg_occ dc) - ; return (True, mk_con_app dc (map snd args')) } + | Just (ConVal (DataAlt dc) args) <- isValue val_env arg + , not (ignoreDataCon env dc) -- See Note [NoSpecConstr] + , Just arg_occs <- mb_scrut dc + = do { let (ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) args + ; (_, args') <- argsToPats env in_scope val_env rest_args arg_occs + ; return (True, + mkConApp dc (ty_args ++ args')) } + where + mb_scrut dc = case arg_occ of + ScrutOcc bs + | Just occs <- lookupUFM bs dc + -> Just (occs) -- See Note [Reboxing] + _other | sc_force env -> Just (repeat UnkOcc) + | otherwise -> Nothing -- Check if the argument is a variable that - -- is in scope at the function definition site - -- It's worth specialising on this if - -- (a) it's used in an interesting way in the body + -- (a) is used in an interesting way in the body -- (b) we know what its value is + -- In that case it counts as "interesting" argToPat env in_scope val_env (Var v) arg_occ - | case arg_occ of { UnkOcc -> False; _other -> True }, -- (a) - is_value, -- (b) + | sc_force env || case arg_occ of { UnkOcc -> False; _other -> True }, -- (a) + is_value, -- (b) not (ignoreType env (varType v)) = return (True, Var v) where @@ -1584,17 +1676,18 @@ = wildCardPat (exprType arg) wildCardPat :: Type -> UniqSM (Bool, CoreArg) -wildCardPat ty = do { uniq <- getUniqueUs - ; let id = mkSysLocal (fsLit "sc") uniq ty - ; return (False, Var id) } +wildCardPat ty + = do { uniq <- getUniqueUs + ; let id = mkSysLocal (fsLit "sc") uniq ty + ; return (False, Var id) } argsToPats :: ScEnv -> InScopeSet -> ValueEnv - -> [(CoreArg, ArgOcc)] - -> UniqSM [(Bool, CoreArg)] -argsToPats env in_scope val_env args - = mapM do_one args - where - do_one (arg,occ) = argToPat env in_scope val_env arg occ + -> [CoreArg] -> [ArgOcc] -- Should be same length + -> UniqSM (Bool, [CoreArg]) +argsToPats env in_scope val_env args occs + = do { stuff <- zipWithM (argToPat env in_scope val_env) args occs + ; let (interesting_s, args') = unzip stuff + ; return (or interesting_s, args') } \end{code} @@ -1617,7 +1710,7 @@ -- as well, for let-bound constructors! isValue env (Lam b e) - | isTyCoVar b = case isValue env e of + | isTyVar b = case isValue env e of Just _ -> Just LambdaVal Nothing -> Nothing | otherwise = Just LambdaVal @@ -1639,11 +1732,6 @@ isValue _env _expr = Nothing -mk_con_app :: AltCon -> [CoreArg] -> CoreExpr -mk_con_app (LitAlt lit) [] = Lit lit -mk_con_app (DataAlt con) args = mkConApp con args -mk_con_app _other _args = panic "SpecConstr.mk_con_app" - samePat :: CallPat -> CallPat -> Bool samePat (vs1, as1) (vs2, as2) = all2 same as1 as2 @@ -1657,6 +1745,7 @@ same (App f1 a1) (App f2 a2) = same f1 f2 && same a1 a2 same (Type {}) (Type {}) = True -- Note [Ignore type differences] + same (Coercion {}) (Coercion {}) = True same (Note _ e1) e2 = same e1 e2 -- Ignore casts and notes same (Cast e1 _) e2 = same e1 e2 same e1 (Note _ e2) = same e1 e2 diff -Nru ghc-7.0.3/compiler/specialise/Specialise.lhs ghc-7.2.1/compiler/specialise/Specialise.lhs --- ghc-7.0.3/compiler/specialise/Specialise.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/specialise/Specialise.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -709,11 +709,12 @@ ---------------- First the easy cases -------------------- specExpr subst (Type ty) = return (Type (CoreSubst.substTy subst ty), emptyUDs) +specExpr subst (Coercion co) = return (Coercion (CoreSubst.substCo subst co), emptyUDs) specExpr subst (Var v) = return (specVar subst v, emptyUDs) specExpr _ (Lit lit) = return (Lit lit, emptyUDs) specExpr subst (Cast e co) = do (e', uds) <- specExpr subst e - return ((Cast e' (CoreSubst.substTy subst co)), uds) + return ((Cast e' (CoreSubst.substCo subst co)), uds) specExpr subst (Note note body) = do (body', uds) <- specExpr subst body return (Note (specNote subst note) body', uds) @@ -1137,6 +1138,9 @@ -- Add a suitable unfolding if the spec_inl_prag says so -- See Note [Inline specialisations] spec_inl_prag + | not is_local && isStrongLoopBreaker (idOccInfo fn) + = neverInlinePragma -- See Note [Specialising imported functions] in OccurAnal + | otherwise = case inl_prag of InlinePragma { inl_inline = Inlinable } -> inl_prag { inl_inline = EmptyInlineSpec } @@ -1224,16 +1228,22 @@ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Here is a nasty example that bit us badly: see Trac #3591 + class Eq a => C a + instance Eq [a] => C [a] + +--------------- + dfun :: Eq [a] -> C [a] dfun a d = MkD a d (meth d) - d4 = - d2 = dfun T d4 - d1 = $p1 d2 - d3 = dfun T d1 + + d4 :: Eq [T] = + d2 :: C [T] = dfun T d4 + d1 :: Eq [T] = $p1 d2 + d3 :: C [T] = dfun T d1 None of these definitions is recursive. What happened was that we generated a specialisation: - RULE forall d. dfun T d = dT + RULE forall d. dfun T d = dT :: C [T] dT = (MkD a d (meth d)) [T/a, d1/d] = MkD T d1 (meth d1) @@ -1512,7 +1522,7 @@ cmp Nothing Nothing = EQ cmp Nothing (Just _) = LT cmp (Just _) Nothing = GT - cmp (Just t1) (Just t2) = tcCmpType t1 t2 + cmp (Just t1) (Just t2) = cmpType t1 t2 unionCalls :: CallDetails -> CallDetails -> CallDetails unionCalls c1 c2 = plusVarEnv_C unionCallInfoSet c1 c2 @@ -1597,7 +1607,9 @@ interestingDict (Var v) = hasSomeUnfolding (idUnfolding v) || isDataConWorkId v interestingDict (Type _) = False +interestingDict (Coercion _) = False interestingDict (App fn (Type _)) = interestingDict fn +interestingDict (App fn (Coercion _)) = interestingDict fn interestingDict (Note _ a) = interestingDict a interestingDict (Cast e _) = interestingDict e interestingDict _ = True diff -Nru ghc-7.0.3/compiler/stgSyn/CoreToStg.lhs ghc-7.2.1/compiler/stgSyn/CoreToStg.lhs --- ghc-7.0.3/compiler/stgSyn/CoreToStg.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/stgSyn/CoreToStg.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -18,8 +18,8 @@ import Type import TyCon +import MkId ( coercionTokenId ) import Id -import Var ( Var ) import IdInfo import DataCon import CostCentre ( noCCS ) @@ -218,7 +218,7 @@ -- floated out a binding, in which case it will be approximate. consistentCafInfo :: Id -> GenStgBinding Var Id -> Bool consistentCafInfo id bind - = WARN( not (exact || is_sat_thing) , ppr id ) + = WARN( not (exact || is_sat_thing) , ppr id <+> ppr id_marked_caffy <+> ppr binding_is_caffy ) safe where safe = id_marked_caffy || not binding_is_caffy @@ -312,8 +312,9 @@ decisions. Hence no black holes. \begin{code} -coreToStgExpr (Lit l) = return (StgLit l, emptyFVInfo, emptyVarSet) -coreToStgExpr (Var v) = coreToStgApp Nothing v [] +coreToStgExpr (Lit l) = return (StgLit l, emptyFVInfo, emptyVarSet) +coreToStgExpr (Var v) = coreToStgApp Nothing v [] +coreToStgExpr (Coercion _) = coreToStgApp Nothing coercionTokenId [] coreToStgExpr expr@(App _ _) = coreToStgApp Nothing f args @@ -572,6 +573,10 @@ (args', fvs) <- coreToStgArgs args return (args', fvs) +coreToStgArgs (Coercion _ : args) -- Coercion argument; replace with place holder + = do { (args', fvs) <- coreToStgArgs args + ; return (StgVarArg coercionTokenId : args', fvs) } + coreToStgArgs (arg : args) = do -- Non-type argument (stg_args, args_fvs) <- coreToStgArgs args (arg', arg_fvs, _escs) <- coreToStgExpr arg @@ -1124,7 +1129,7 @@ go (Cast e _) as = go e as go (Note _ e) as = go e as go (Lam b e) as - | isTyCoVar b = go e as -- Note [Collect args] + | isTyVar b = go e as -- Note [Collect args] go _ _ = pprPanic "CoreToStg.myCollectArgs" (ppr expr) \end{code} diff -Nru ghc-7.0.3/compiler/stgSyn/StgSyn.lhs ghc-7.2.1/compiler/stgSyn/StgSyn.lhs --- ghc-7.0.3/compiler/stgSyn/StgSyn.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/stgSyn/StgSyn.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -68,7 +68,8 @@ #if mingw32_TARGET_OS import Packages ( isDllName ) - +import Type ( typePrimRep ) +import TyCon ( PrimRep(..) ) #endif \end{code} @@ -118,8 +119,27 @@ = isDllName this_pkg (dataConName con) || any is_dll_arg args where is_dll_arg ::StgArg -> Bool - is_dll_arg (StgVarArg v) = isDllName this_pkg (idName v) + is_dll_arg (StgVarArg v) = isAddrRep (typePrimRep (idType v)) + && isDllName this_pkg (idName v) is_dll_arg _ = False + +isAddrRep :: PrimRep -> Bool +-- True of machine adddresses; these are the things that don't +-- work across DLLs. +-- The key point here is that VoidRep comes out False, so that +-- a top level nullary GADT construtor is False for isDllConApp +-- data T a where +-- T1 :: T Int +-- gives +-- T1 :: forall a. (a~Int) -> T a +-- and hence the top-level binding +-- $WT1 :: T Int +-- $WT1 = T1 Int (Coercion (Refl Int)) +-- The coercion argument here gets VoidRep +isAddrRep AddrRep = True +isAddrRep PtrRep = True +isAddrRep _ = False + #else isDllConApp _ _ _ = False #endif diff -Nru ghc-7.0.3/compiler/stranal/DmdAnal.lhs ghc-7.2.1/compiler/stranal/DmdAnal.lhs --- ghc-7.0.3/compiler/stranal/DmdAnal.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/stranal/DmdAnal.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -18,6 +18,7 @@ import Demand -- All of it import CoreSyn import PprCore +import Coercion ( isCoVarType ) import CoreUtils ( exprIsHNF, exprIsTrivial ) import CoreArity ( exprArity ) import DataCon ( dataConTyCon, dataConRepStrictness ) @@ -28,19 +29,20 @@ setIdStrictness, idDemandInfo, idUnfolding, idDemandInfo_maybe, setIdDemandInfo ) -import Var ( Var ) +import Var ( Var, isTyVar ) import VarEnv import TysWiredIn ( unboxedPairDataCon ) import TysPrim ( realWorldStatePrimTy ) import UniqFM ( addToUFM_Directly, lookupUFM_Directly, minusUFM, filterUFM ) -import Type ( isUnLiftedType, coreEqType, splitTyConApp_maybe ) +import Type ( isUnLiftedType, eqType, splitTyConApp_maybe ) import Coercion ( coercionKind ) import Util ( mapAndUnzip, lengthIs, zipEqual ) import BasicTypes ( Arity, TopLevelFlag(..), isTopLevel, isNeverActive, RecFlag(..), isRec, isMarkedStrict ) import Maybes ( orElse, expectJust ) import Outputable +import Pair import Data.List import FastString \end{code} @@ -144,6 +146,7 @@ dmdAnal _ _ (Lit lit) = (topDmdType, Lit lit) dmdAnal _ _ (Type ty) = (topDmdType, Type ty) -- Doesn't happen, in fact +dmdAnal _ _ (Coercion co) = (topDmdType, Coercion co) dmdAnal env dmd (Var var) = (dmdTransform env var dmd, Var var) @@ -152,7 +155,7 @@ = (dmd_ty, Cast e' co) where (dmd_ty, e') = dmdAnal env dmd' e - to_co = snd (coercionKind co) + to_co = pSnd (coercionKind co) dmd' | Just (tc, _) <- splitTyConApp_maybe to_co , isRecursiveTyCon tc = evalDmd @@ -173,6 +176,11 @@ where (fun_ty, fun') = dmdAnal env dmd fun +dmdAnal sigs dmd (App fun (Coercion co)) + = (fun_ty, App fun' (Coercion co)) + where + (fun_ty, fun') = dmdAnal sigs dmd fun + -- Lots of the other code is there to make this -- beautiful, compositional, application rule :-) dmdAnal env dmd (App fun arg) -- Non-type arguments @@ -184,7 +192,7 @@ (res_ty `bothType` arg_ty, App fun' arg') dmdAnal env dmd (Lam var body) - | isTyCoVar var + | isTyVar var = let (body_ty, body') = dmdAnal env dmd body in @@ -328,7 +336,7 @@ -- ; print len } io_hack_reqd = con == DataAlt unboxedPairDataCon && - idType (head bndrs) `coreEqType` realWorldStatePrimTy + idType (head bndrs) `eqType` realWorldStatePrimTy in (final_alt_ty, (con, bndrs', rhs')) @@ -838,7 +846,7 @@ -- The returned var is annotated with demand info -- No effect on the argument demands annotateBndr dmd_ty@(DmdType fv ds res) var - | isTyCoVar var = (dmd_ty, var) + | isTyVar var = (dmd_ty, var) | otherwise = (DmdType fv' ds res, setIdDemandInfo var dmd) where (fv', dmd) = removeFV fv var res @@ -888,10 +896,15 @@ zapUnlifted :: Id -> Demand -> Demand -- For unlifted-type variables, we are only -- interested in Bot/Abs/Box Abs -zapUnlifted _ Bot = Bot -zapUnlifted _ Abs = Abs -zapUnlifted id dmd | isUnLiftedType (idType id) = lazyDmd - | otherwise = dmd +zapUnlifted id dmd + = case dmd of + _ | isCoVarType ty -> lazyDmd -- For coercions, ignore str/abs totally + Bot -> Bot + Abs -> Abs + _ | isUnLiftedType ty -> lazyDmd -- For unlifted types, ignore strictness + | otherwise -> dmd + where + ty = idType id \end{code} Note [Lamba-bound unfoldings] diff -Nru ghc-7.0.3/compiler/stranal/WorkWrap.lhs ghc-7.2.1/compiler/stranal/WorkWrap.lhs --- ghc-7.0.3/compiler/stranal/WorkWrap.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/stranal/WorkWrap.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -100,6 +100,7 @@ wwExpr :: CoreExpr -> UniqSM CoreExpr wwExpr e@(Type {}) = return e +wwExpr e@(Coercion {}) = return e wwExpr e@(Lit {}) = return e wwExpr e@(Var {}) = return e @@ -173,8 +174,8 @@ because you lose the worker/wrapper stuff. But I don't see a way to avoid that. -Note [Don't w/w inline small non-loop-breker things] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Don't w/w inline small non-loop-breaker things] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ In general, we refrain from w/w-ing *small* functions, which are not loop breakers, because they'll inline anyway. But we must take care: it may look small now, but get to be big later after other inlining @@ -182,10 +183,22 @@ any such functions. I made this change when I observed a big function at the end of -compilation with a useful strictness signature but no w-w. When -I measured it on nofib, it didn't make much difference; just a few -percent improved allocation on one benchmark (bspt/Euclid.space). -But nothing got worse. +compilation with a useful strictness signature but no w-w. (It was +small during demand analysis, we refrained from w/w, and then got big +when something was inlined in its rhs.) When I measured it on nofib, +it didn't make much difference; just a few percent improved allocation +on one benchmark (bspt/Euclid.space). But nothing got worse. + +There is an infelicity though. We may get something like + f = g val +==> + g x = case gw x of r -> I# r + + f {- InlineStable, Template = g val -} + f = case gw x of r -> I# r + +The code for f duplicates that for g, without any real benefit. It +won't really be executed, because calls to f will go via the inlining. Note [Wrapper activation] ~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -413,6 +426,11 @@ -- in case x of -- I# y -> let x = I# y in x } -- See comments above. Is it not beautifully short? +-- Moreover, it works just as well when there are +-- several binders, and if the binders are lifted +-- E.g. x = e +-- --> x = let x = e in +-- case x of (a,b) -> let x = (a,b) in x splitThunk :: Var -> Expr Var -> UniqSM [(Var, Expr Var)] splitThunk fn_id rhs = do diff -Nru ghc-7.0.3/compiler/stranal/WwLib.lhs ghc-7.2.1/compiler/stranal/WwLib.lhs --- ghc-7.0.3/compiler/stranal/WwLib.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/stranal/WwLib.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -23,10 +23,9 @@ import TysPrim ( realWorldStatePrimTy ) import TysWiredIn ( tupleCon ) import Type -import Coercion ( mkSymCoercion, splitNewTypeRepCo_maybe ) +import Coercion ( mkSymCo, splitNewTypeRepCo_maybe ) import BasicTypes ( Boxity(..) ) import Literal ( absentLiteralOf ) -import Var ( Var ) import UniqSupply import Unique import Util ( zipWithEqual ) @@ -244,7 +243,7 @@ = do { (wrap_args, wrap_fn_args, work_fn_args, res_ty) <- mkWWargs subst rep_ty arg_info ; return (wrap_args, - \e -> Cast (wrap_fn_args e) (mkSymCoercion co), + \e -> Cast (wrap_fn_args e) (mkSymCo co), \e -> work_fn_args (Cast e co), res_ty) } @@ -271,7 +270,7 @@ <- mkWWargs subst fun_ty' arg_info' ; return (id : wrap_args, Lam id . wrap_fn_args, - work_fn_args . (`App` Var id), + work_fn_args . (`App` varToCoreExpr id), res_ty) } | otherwise @@ -291,18 +290,12 @@ Note [Freshen type variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -mkWWargs may be given a type like (a~b) => -Which really means forall (co:a~b). -Because the name of the coercion variable, 'co', isn't mentioned in , -nested coercion foralls may all use the same variable; and sometimes do -see Var.mkWildCoVar. - -However, when we do a worker/wrapper split, we must not use shadowed names, +Wen we do a worker/wrapper split, we must not use shadowed names, else we'll get - f = /\ co /\co. fw co co -which is obviously wrong. Actually, the same is true of type variables, which -can in principle shadow, within a type (e.g. forall a. a -> forall a. a->a). -But type variables *are* mentioned in , so we must substitute. + f = /\ a /\a. fw a a +which is obviously wrong. Type variables can can in principle shadow, +within a type (e.g. forall a. a -> forall a. a->a). But type +variables *are* mentioned in , so we must substitute. That's why we carry the TvSubst through mkWWargs @@ -339,7 +332,7 @@ -- brings into scope wrap_arg (via lets) mkWWstr_one :: Var -> UniqSM ([Var], CoreExpr -> CoreExpr, CoreExpr -> CoreExpr) mkWWstr_one arg - | isTyCoVar arg + | isTyVar arg = return ([arg], nop_fn, nop_fn) | otherwise @@ -456,7 +449,7 @@ uniqs <- getUniquesM let (wrap_wild : work_wild : args) = zipWith mk_ww_local uniqs (ubx_tup_ty : body_ty : con_arg_tys) - arg_vars = map Var args + arg_vars = varsToCoreExprs args ubx_tup_con = tupleCon Unboxed n_con_args ubx_tup_ty = exprType ubx_tup_app ubx_tup_app = mkConApp ubx_tup_con (map Type con_arg_tys ++ arg_vars) @@ -525,7 +518,7 @@ | Just (tc, _) <- splitTyConApp_maybe arg_ty , Just lit <- absentLiteralOf tc = Just (Let (NonRec arg (Lit lit))) - | arg_ty `coreEqType` realWorldStatePrimTy + | arg_ty `eqType` realWorldStatePrimTy = Just (Let (NonRec arg (Var realWorldPrimId))) | otherwise = WARN( True, ptext (sLit "No absent value for") <+> ppr arg_ty ) diff -Nru ghc-7.0.3/compiler/typecheck/FamInst.lhs ghc-7.2.1/compiler/typecheck/FamInst.lhs --- ghc-7.0.3/compiler/typecheck/FamInst.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/typecheck/FamInst.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -7,6 +7,7 @@ import HscTypes import FamInstEnv +import LoadIface import TcMType import TcRnMonad import TyCon @@ -82,20 +83,17 @@ ; (eps, hpt) <- getEpsAndHpt ; let { -- Fetch the iface of a given module. Must succeed as - -- all imported modules must already have been loaded. + -- all directly imported modules must already have been loaded. modIface mod = case lookupIfaceByModule dflags hpt (eps_PIT eps) mod of Nothing -> panic "FamInst.checkFamInstConsistency" Just iface -> iface ; hmiModule = mi_module . hm_iface - ; hmiFamInstEnv = mkFamInstEnv . md_fam_insts . hm_details - ; mkFamInstEnv = extendFamInstEnvList emptyFamInstEnv - ; hptModInsts = [ (hmiModule hmi, hmiFamInstEnv hmi) - | hmi <- eltsUFM hpt] - ; modInstsEnv = eps_mod_fam_inst_env eps -- external modules - `extendModuleEnvList` -- plus - hptModInsts -- home package modules + ; hmiFamInstEnv = extendFamInstEnvList emptyFamInstEnv + . md_fam_insts . hm_details + ; hpt_fam_insts = mkModuleEnv [ (hmiModule hmi, hmiFamInstEnv hmi) + | hmi <- eltsUFM hpt] ; groups = map (dep_finsts . mi_deps . modIface) directlyImpMods ; okPairs = listToSet $ concatMap allPairs groups @@ -106,22 +104,27 @@ -- the difference gives us the pairs we need to check now } - ; mapM_ (check modInstsEnv) toCheckPairs + ; mapM_ (check hpt_fam_insts) toCheckPairs } where allPairs [] = [] allPairs (m:ms) = map (ModulePair m) ms ++ allPairs ms - -- The modules are guaranteed to be in the environment, as they are either - -- already loaded in the EPS or they are in the HPT. - -- - check modInstsEnv (ModulePair m1 m2) - = let { instEnv1 = (expectJust "checkFamInstConsistency") . lookupModuleEnv modInstsEnv $ m1 - ; instEnv2 = (expectJust "checkFamInstConsistency") . lookupModuleEnv modInstsEnv $ m2 - ; insts1 = famInstEnvElts instEnv1 - } - in - mapM_ (checkForConflicts (emptyFamInstEnv, instEnv2)) insts1 + check hpt_fam_insts (ModulePair m1 m2) + = do { env1 <- getFamInsts hpt_fam_insts m1 + ; env2 <- getFamInsts hpt_fam_insts m2 + ; mapM_ (checkForConflicts (emptyFamInstEnv, env2)) + (famInstEnvElts env1) } + +getFamInsts :: ModuleEnv FamInstEnv -> Module -> TcM FamInstEnv +getFamInsts hpt_fam_insts mod + | Just env <- lookupModuleEnv hpt_fam_insts mod = return env + | otherwise = do { _ <- initIfaceTcRn (loadSysInterface doc mod) + ; eps <- getEps + ; return (expectJust "checkFamInstConsistency" $ + lookupModuleEnv (eps_mod_fam_inst_env eps) mod) } + where + doc = ppr mod <+> ptext (sLit "is a family-instance module") \end{code} %************************************************************************ @@ -196,17 +199,11 @@ = setSrcSpan (mkSrcSpan loc loc) thing_inside where loc = getSrcLoc famInst -\end{code} - -\begin{code} tcGetFamInstEnvs :: TcM (FamInstEnv, FamInstEnv) -- Gets both the external-package inst-env -- and the home-pkg inst env (includes module being compiled) tcGetFamInstEnvs = do { eps <- getEps; env <- getGblEnv - ; return (eps_fam_inst_env eps, tcg_fam_inst_env env) - } - - + ; return (eps_fam_inst_env eps, tcg_fam_inst_env env) } \end{code} diff -Nru ghc-7.0.3/compiler/typecheck/Inst.lhs ghc-7.2.1/compiler/typecheck/Inst.lhs --- ghc-7.0.3/compiler/typecheck/Inst.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/typecheck/Inst.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -13,8 +13,8 @@ newOverloadedLit, mkOverLit, - tcGetInstEnvs, getOverlapFlag, tcExtendLocalInstEnv, - instCallConstraints, newMethodFromName, + tcGetInstEnvs, getOverlapFlag, + tcExtendLocalInstEnv, instCallConstraints, newMethodFromName, tcSyntaxName, -- Simple functions over evidence variables @@ -46,11 +46,10 @@ import TcType import Class import Unify -import Coercion import HscTypes import Id import Name -import Var +import Var ( Var, TyVar, EvVar, varType, setVarType ) import VarEnv import VarSet import PrelNames @@ -212,11 +211,8 @@ instCallConstraints origin (EqPred ty1 ty2 : preds) -- Try short-cut = do { traceTc "instCallConstraints" $ ppr (EqPred ty1 ty2) - ; coi <- unifyType ty1 ty2 + ; co <- unifyType ty1 ty2 ; co_fn <- instCallConstraints origin preds - ; let co = case coi of - IdCo ty -> ty - ACo co -> co ; return (co_fn <.> WpEvApp (EvCoercion co)) } instCallConstraints origin (pred : preds) @@ -372,14 +368,15 @@ \begin{code} getOverlapFlag :: TcM OverlapFlag getOverlapFlag - = do { dflags <- getDOpts - ; let overlap_ok = xopt Opt_OverlappingInstances dflags - incoherent_ok = xopt Opt_IncoherentInstances dflags - overlap_flag | incoherent_ok = Incoherent - | overlap_ok = OverlapOk - | otherwise = NoOverlap - - ; return overlap_flag } + = do { dflags <- getDOpts + ; let overlap_ok = xopt Opt_OverlappingInstances dflags + incoherent_ok = xopt Opt_IncoherentInstances dflags + safeOverlap = safeLanguageOn dflags + overlap_flag | incoherent_ok = Incoherent safeOverlap + | overlap_ok = OverlapOk safeOverlap + | otherwise = NoOverlap safeOverlap + + ; return overlap_flag } tcGetInstEnvs :: TcM (InstEnv, InstEnv) -- Gets both the external-package inst-env @@ -433,7 +430,7 @@ Nothing -> return () -- Check for duplicate instance decls - ; let { (matches, _) = lookupInstEnv inst_envs cls tys' + ; let { (matches, _, _) = lookupInstEnv inst_envs cls tys' ; dup_ispecs = [ dup_ispec | (dup_ispec, _) <- matches , let (_,_,_,dup_tys) = instanceHead dup_ispec @@ -551,7 +548,7 @@ = EvVarX (tidyEvVar env v) (tidyFlavor env fl) tidyFlavor :: TidyEnv -> CtFlavor -> CtFlavor -tidyFlavor env (Given loc) = Given (tidyGivenLoc env loc) +tidyFlavor env (Given loc gk) = Given (tidyGivenLoc env loc) gk tidyFlavor _ fl = fl tidyGivenLoc :: TidyEnv -> GivenLoc -> GivenLoc @@ -595,8 +592,8 @@ = EvVarX (substEvVar subst v) (substFlavor subst fl) substFlavor :: TvSubst -> CtFlavor -> CtFlavor -substFlavor subst (Given loc) = Given (substGivenLoc subst loc) -substFlavor _ fl = fl +substFlavor subst (Given loc gk) = Given (substGivenLoc subst loc) gk +substFlavor _ fl = fl substGivenLoc :: TvSubst -> GivenLoc -> GivenLoc substGivenLoc subst (CtLoc skol span ctxt) = CtLoc (substSkolemInfo subst skol) span ctxt @@ -605,4 +602,4 @@ substSkolemInfo subst (SigSkol cx ty) = SigSkol cx (substTy subst ty) substSkolemInfo subst (InferSkol ids) = InferSkol (mapSnd (substTy subst) ids) substSkolemInfo _ info = info -\end{code} \ No newline at end of file +\end{code} diff -Nru ghc-7.0.3/compiler/typecheck/TcArrows.lhs ghc-7.2.1/compiler/typecheck/TcArrows.lhs --- ghc-7.0.3/compiler/typecheck/TcArrows.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/typecheck/TcArrows.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -7,7 +7,7 @@ \begin{code} module TcArrows ( tcProc ) where -import {-# SOURCE #-} TcExpr( tcMonoExpr, tcInferRho, tcSyntaxOp ) +import {-# SOURCE #-} TcExpr( tcMonoExpr, tcInferRho, tcSyntaxOp, tcCheckId ) import HsSyn import TcMatches @@ -17,7 +17,9 @@ import TcPat import TcUnify import TcRnMonad +import TcEnv import Coercion +import Id( mkLocalId ) import Inst import Name import TysWiredIn @@ -41,17 +43,17 @@ \begin{code} tcProc :: InPat Name -> LHsCmdTop Name -- proc pat -> expr -> TcRhoType -- Expected type of whole proc expression - -> TcM (OutPat TcId, LHsCmdTop TcId, CoercionI) + -> TcM (OutPat TcId, LHsCmdTop TcId, Coercion) tcProc pat cmd exp_ty = newArrowScope $ do { (coi, (exp_ty1, res_ty)) <- matchExpectedAppTy exp_ty ; (coi1, (arr_ty, arg_ty)) <- matchExpectedAppTy exp_ty1 ; let cmd_env = CmdEnv { cmd_arr = arr_ty } - ; (pat', cmd') <- tcPat ProcExpr pat arg_ty $ + ; (pat', cmd') <- tcPat ProcExpr pat arg_ty $ tcCmdTop cmd_env cmd [] res_ty - ; let res_coi = mkTransCoI coi (mkAppTyCoI coi1 (IdCo res_ty)) - ; return (pat', cmd', res_coi) } + ; let res_coi = mkTransCo coi (mkAppCo coi1 (mkReflCo res_ty)) + ; return (pat', cmd', res_coi) } \end{code} @@ -83,20 +85,12 @@ tcCmdTop env (L loc (HsCmdTop cmd _ _ names)) cmd_stk res_ty = setSrcSpan loc $ - do { cmd' <- tcGuardedCmd env cmd cmd_stk res_ty + do { cmd' <- tcCmd env cmd (cmd_stk, res_ty) ; names' <- mapM (tcSyntaxName ProcOrigin (cmd_arr env)) names ; return (L loc $ HsCmdTop cmd' cmd_stk res_ty names') } ---------------------------------------- -tcGuardedCmd :: CmdEnv -> LHsExpr Name -> CmdStack - -> TcTauType -> TcM (LHsExpr TcId) --- A wrapper that deals with the refinement (if any) -tcGuardedCmd env expr stk res_ty - = do { body <- tcCmd env expr (stk, res_ty) - ; return body - } - tcCmd :: CmdEnv -> LHsExpr Name -> (CmdStack, TcTauType) -> TcM (LHsExpr TcId) -- The main recursive function tcCmd env (L loc expr) res_ty @@ -123,7 +117,7 @@ where match_ctxt = MC { mc_what = CaseAlt, mc_body = mc_body } - mc_body body res_ty' = tcGuardedCmd env body stk res_ty' + mc_body body res_ty' = tcCmd env body (stk, res_ty') tc_cmd env (HsIf mb_fun pred b1 b2) (stack_ty,res_ty) = do { pred_ty <- newFlexiTyVarTy openTypeKind @@ -187,8 +181,8 @@ -- Check the patterns, and the GRHSs inside ; (pats', grhss') <- setSrcSpan mtch_loc $ - tcPats LambdaExpr pats cmd_stk $ - tc_grhss grhss res_ty + tcPats LambdaExpr pats cmd_stk $ + tc_grhss grhss res_ty ; let match' = L mtch_loc (Match pats' Nothing grhss') ; return (HsLam (MatchGroup [match'] res_ty)) @@ -206,22 +200,18 @@ ; return (GRHSs grhss' binds') } tc_grhs res_ty (GRHS guards body) - = do { (guards', rhs') <- tcStmts pg_ctxt tcGuardStmt guards res_ty $ - tcGuardedCmd env body stk' + = do { (guards', rhs') <- tcStmtsAndThen pg_ctxt tcGuardStmt guards res_ty $ + \ res_ty -> tcCmd env body (stk', res_ty) ; return (GRHS guards' rhs') } ------------------------------------------- -- Do notation -tc_cmd env cmd@(HsDo do_or_lc stmts body _ty) (cmd_stk, res_ty) +tc_cmd env cmd@(HsDo do_or_lc stmts _) (cmd_stk, res_ty) = do { checkTc (null cmd_stk) (nonEmptyCmdStkErr cmd) - ; (stmts', body') <- tcStmts do_or_lc (tcMDoStmt tc_rhs) stmts res_ty $ - tcGuardedCmd env body [] - ; return (HsDo do_or_lc stmts' body' res_ty) } + ; stmts' <- tcStmts do_or_lc (tcArrDoStmt env) stmts res_ty + ; return (HsDo do_or_lc stmts' res_ty) } where - tc_rhs rhs = do { ty <- newFlexiTyVarTy liftedTypeKind - ; rhs' <- tcCmd env rhs ([], ty) - ; return (rhs', ty) } ----------------------------------------------------------------- @@ -249,7 +239,7 @@ e_res_ty -- Check expr - ; (inst_binds, expr') <- checkConstraints ArrowSkol [w_tv] [] $ + ; (inst_binds, expr') <- checkConstraints ArrowSkol [w_tv] [] $ escapeArrowScope (tcMonoExpr expr e_ty) -- OK, now we are in a position to unscramble @@ -279,7 +269,7 @@ -- Check that it has the right shape: -- ((w,s1) .. sn) -- where the si do not mention w - ; checkTc (corner_ty `tcEqType` mkTyVarTy w_tv && + ; checkTc (corner_ty `eqType` mkTyVarTy w_tv && not (w_tv `elemVarSet` tyVarsOfTypes arg_tys)) (badFormFun i tup_ty') @@ -307,6 +297,69 @@ %************************************************************************ %* * + Stmts +%* * +%************************************************************************ + +\begin{code} +-------------------------------- +-- Mdo-notation +-- The distinctive features here are +-- (a) RecStmts, and +-- (b) no rebindable syntax + +tcArrDoStmt :: CmdEnv -> TcStmtChecker +tcArrDoStmt env _ (LastStmt rhs _) res_ty thing_inside + = do { rhs' <- tcCmd env rhs ([], res_ty) + ; thing <- thing_inside (panic "tcArrDoStmt") + ; return (LastStmt rhs' noSyntaxExpr, thing) } + +tcArrDoStmt env _ (ExprStmt rhs _ _ _) res_ty thing_inside + = do { (rhs', elt_ty) <- tc_arr_rhs env rhs + ; thing <- thing_inside res_ty + ; return (ExprStmt rhs' noSyntaxExpr noSyntaxExpr elt_ty, thing) } + +tcArrDoStmt env ctxt (BindStmt pat rhs _ _) res_ty thing_inside + = do { (rhs', pat_ty) <- tc_arr_rhs env rhs + ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $ + thing_inside res_ty + ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) } + +tcArrDoStmt env ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = laterNames + , recS_rec_ids = recNames }) res_ty thing_inside + = do { rec_tys <- newFlexiTyVarTys (length recNames) liftedTypeKind + ; let rec_ids = zipWith mkLocalId recNames rec_tys + ; tcExtendIdEnv rec_ids $ do + { (stmts', (later_ids, rec_rets)) + <- tcStmtsAndThen ctxt (tcArrDoStmt env) stmts res_ty $ \ _res_ty' -> + -- ToDo: res_ty not really right + do { rec_rets <- zipWithM tcCheckId recNames rec_tys + ; later_ids <- tcLookupLocalIds laterNames + ; return (later_ids, rec_rets) } + + ; thing <- tcExtendIdEnv later_ids (thing_inside res_ty) + -- NB: The rec_ids for the recursive things + -- already scope over this part. This binding may shadow + -- some of them with polymorphic things with the same Name + -- (see note [RecStmt] in HsExpr) + + ; return (emptyRecStmt { recS_stmts = stmts', recS_later_ids = later_ids + , recS_rec_ids = rec_ids, recS_rec_rets = rec_rets + , recS_ret_ty = res_ty }, thing) + }} + +tcArrDoStmt _ _ stmt _ _ + = pprPanic "tcArrDoStmt: unexpected Stmt" (ppr stmt) + +tc_arr_rhs :: CmdEnv -> LHsExpr Name -> TcM (LHsExpr TcId, TcType) +tc_arr_rhs env rhs = do { ty <- newFlexiTyVarTy liftedTypeKind + ; rhs' <- tcCmd env rhs ([], ty) + ; return (rhs', ty) } +\end{code} + + +%************************************************************************ +%* * Helpers %* * %************************************************************************ diff -Nru ghc-7.0.3/compiler/typecheck/TcBinds.lhs ghc-7.2.1/compiler/typecheck/TcBinds.lhs --- ghc-7.0.3/compiler/typecheck/TcBinds.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/typecheck/TcBinds.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -7,7 +7,7 @@ \begin{code} module TcBinds ( tcLocalBinds, tcTopBinds, tcHsBootSigs, tcPolyBinds, - PragFun, tcSpecPrags, mkPragFun, + PragFun, tcSpecPrags, tcVectDecls, mkPragFun, TcSigInfo(..), SigFun, mkSigFun, badBootDeclErr ) where @@ -25,7 +25,6 @@ import TcPat import TcMType import TcType -import RnBinds( misplacedSigErr ) import Coercion import TysPrim import Id @@ -35,6 +34,7 @@ import NameEnv import SrcLoc import Bag +import ListSetOps import ErrUtils import Digraph import Maybes @@ -43,7 +43,6 @@ import Outputable import FastString -import Data.List( partition ) import Control.Monad #include "HsVersions.h" @@ -103,11 +102,12 @@ -- signatures in it. The renamer checked all this tcHsBootSigs (ValBindsOut binds sigs) = do { checkTc (null binds) badBootDeclErr - ; mapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) } + ; concat <$> mapM (addLocM tc_boot_sig) (filter isTypeLSig sigs) } where - tc_boot_sig (TypeSig (L _ name) ty) - = do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty - ; return (mkVanillaGlobal name sigma_ty) } + tc_boot_sig (TypeSig lnames ty) = mapM f lnames + where + f (L _ name) = do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty + ; return (mkVanillaGlobal name sigma_ty) } -- Notice that we make GlobalIds, not LocalIds tc_boot_sig s = pprPanic "tcHsBootSigs/tc_boot_sig" (ppr s) tcHsBootSigs groups = pprPanic "tcHsBootSigs" (ppr groups) @@ -178,7 +178,7 @@ ; ty_sigs = filter isTypeLSig sigs ; sig_fn = mkSigFun ty_sigs } - ; poly_ids <- checkNoErrs (mapAndRecoverM tcTySig ty_sigs) + ; poly_ids <- concat <$> checkNoErrs (mapAndRecoverM tcTySig ty_sigs) -- No recovery from bad signatures, because the type sigs -- may bind type variables, so proceeding without them -- can lead to a cascade of errors @@ -324,11 +324,13 @@ tcPolyBinds top_lvl sig_fn prag_fn rec_group rec_tc bind_list = setSrcSpan loc $ recoverM (recoveryCode binder_names sig_fn) $ do - -- Set up main recoer; take advantage of any type sigs + -- Set up main recover; take advantage of any type sigs { traceTc "------------------------------------------------" empty ; traceTc "Bindings for" (ppr binder_names) + -- Instantiate the polytypes of any binders that have signatures + -- (as determined by sig_fn), returning a TcSigInfo for each ; tc_sig_fn <- tcInstSigs sig_fn binder_names ; dflags <- getDOpts @@ -347,9 +349,10 @@ ; return (binds, poly_ids) } where binder_names = collectHsBindListBinders bind_list - loc = getLoc (head bind_list) - -- TODO: location a bit awkward, but the mbinds have been - -- dependency analysed and may no longer be adjacent + loc = foldr1 combineSrcSpans (map getLoc bind_list) + -- The mbinds have been dependency analysed and + -- may no longer be adjacent; so find the narrowest + -- span that includes them all ------------------ tcPolyNoGen @@ -387,7 +390,7 @@ -- it binds a single variable, -- it has a signature, tcPolyCheck sig@(TcSigInfo { sig_id = id, sig_tvs = tvs, sig_scoped = scoped - , sig_theta = theta, sig_tau = tau, sig_loc = loc }) + , sig_theta = theta, sig_tau = tau }) prag_fn rec_tc bind_list = do { ev_vars <- newEvVars theta ; let skol_info = SigSkol (FunSigCtxt (idName id)) (mkPhiTy theta tau) @@ -398,6 +401,7 @@ ; export <- mkExport prag_fn tvs theta mono_info + ; loc <- getSrcSpanM ; let (_, poly_id, _, _) = export abs_bind = L loc $ AbsBinds { abs_tvs = tvs @@ -414,10 +418,10 @@ -- dependencies based on type signatures -> [LHsBind Name] -> TcM (LHsBinds TcId, [TcId]) -tcPolyInfer top_lvl mono sig_fn prag_fn rec_tc bind_list +tcPolyInfer top_lvl mono tc_sig_fn prag_fn rec_tc bind_list = do { ((binds', mono_infos), wanted) <- captureConstraints $ - tcMonoBinds sig_fn LetLclBndr rec_tc bind_list + tcMonoBinds tc_sig_fn LetLclBndr rec_tc bind_list ; unifyCtxts [sig | (_, Just sig, _) <- mono_infos] @@ -552,31 +556,108 @@ -------------- tcImpPrags :: [LSig Name] -> TcM [LTcSpecPrag] +-- SPECIALISE pragamas for imported things tcImpPrags prags = do { this_mod <- getModule - ; let is_imp prag - = case sigName prag of - Nothing -> False - Just name -> not (nameIsLocalOrFrom this_mod name) - (spec_prags, others) = partition isSpecLSig $ - filter is_imp prags - ; mapM_ misplacedSigErr others - -- Messy that this misplaced-sig error comes here - -- but the others come from the renamer - ; mapAndRecoverM (wrapLocM tcImpSpec) spec_prags } + ; dflags <- getDOpts + ; if (not_specialising dflags) then + return [] + else + mapAndRecoverM (wrapLocM tcImpSpec) + [L loc (name,prag) | (L loc prag@(SpecSig (L _ name) _ _)) <- prags + , not (nameIsLocalOrFrom this_mod name) ] } + where + -- Ignore SPECIALISE pragmas for imported things + -- when we aren't specialising, or when we aren't generating + -- code. The latter happens when Haddocking the base library; + -- we don't wnat complaints about lack of INLINABLE pragmas + not_specialising dflags + | not (dopt Opt_Specialise dflags) = True + | otherwise = case hscTarget dflags of + HscNothing -> True + HscInterpreted -> True + _other -> False -tcImpSpec :: Sig Name -> TcM TcSpecPrag -tcImpSpec prag@(SpecSig (L _ name) _ _) +tcImpSpec :: (Name, Sig Name) -> TcM TcSpecPrag +tcImpSpec (name, prag) = do { id <- tcLookupId name - ; checkTc (isAnyInlinePragma (idInlinePragma id)) - (impSpecErr name) + ; unless (isAnyInlinePragma (idInlinePragma id)) + (addWarnTc (impSpecErr name)) ; tcSpec id prag } -tcImpSpec p = pprPanic "tcImpSpec" (ppr p) impSpecErr :: Name -> SDoc impSpecErr name = hang (ptext (sLit "You cannot SPECIALISE") <+> quotes (ppr name)) - 2 (ptext (sLit "because its definition has no INLINE/INLINABLE pragma")) + 2 (vcat [ ptext (sLit "because its definition has no INLINE/INLINABLE pragma") + , parens $ sep + [ ptext (sLit "or its defining module") <+> quotes (ppr mod) + , ptext (sLit "was compiled without -O")]]) + where + mod = nameModule name + +-------------- +tcVectDecls :: [LVectDecl Name] -> TcM ([LVectDecl TcId]) +tcVectDecls decls + = do { decls' <- mapM (wrapLocM tcVect) decls + ; let ids = map lvectDeclName decls' + dups = findDupsEq (==) ids + ; mapM_ reportVectDups dups + ; traceTcConstraints "End of tcVectDecls" + ; return decls' + } + where + reportVectDups (first:_second:_more) + = addErrAt (getSrcSpan first) $ + ptext (sLit "Duplicate vectorisation declarations for") <+> ppr first + reportVectDups _ = return () + +-------------- +tcVect :: VectDecl Name -> TcM (VectDecl TcId) +-- We can't typecheck the expression of a vectorisation declaration against the vectorised type +-- of the original definition as this requires internals of the vectoriser not available during +-- type checking. Instead, we infer the type of the expression and leave it to the vectoriser +-- to check the compatibility of the Core types. +tcVect (HsVect name Nothing) + = addErrCtxt (vectCtxt name) $ + do { id <- wrapLocM tcLookupId name + ; return $ HsVect id Nothing + } +tcVect (HsVect name@(L loc _) (Just rhs)) + = addErrCtxt (vectCtxt name) $ + do { _id <- wrapLocM tcLookupId name -- need to ensure that the name is already defined + + -- turn the vectorisation declaration into a single non-recursive binding + ; let bind = L loc $ mkFunBind name [mkSimpleMatch [] rhs] + sigFun = const Nothing + pragFun = mkPragFun [] (unitBag bind) + + -- perform type inference (including generalisation) + ; (binds, [id']) <- tcPolyInfer TopLevel False sigFun pragFun NonRecursive [bind] + + ; traceTc "tcVect inferred type" $ ppr (varType id') + ; traceTc "tcVect bindings" $ ppr binds + + -- add all bindings, including the type variable and dictionary bindings produced by type + -- generalisation to the right-hand side of the vectorisation declaration + ; let [AbsBinds tvs evs _ evBinds actualBinds] = (map unLoc . bagToList) binds + ; let [bind'] = bagToList actualBinds + MatchGroup + [L _ (Match _ _ (GRHSs [L _ (GRHS _ rhs')] _))] + _ = (fun_matches . unLoc) bind' + rhsWrapped = mkHsLams tvs evs (mkHsDictLet evBinds rhs') + + -- We return the type-checked 'Id', to propagate the inferred signature + -- to the vectoriser - see "Note [Typechecked vectorisation pragmas]" in HsDecls + ; return $ HsVect (L loc id') (Just rhsWrapped) + } +tcVect (HsNoVect name) + = addErrCtxt (vectCtxt name) $ + do { id <- wrapLocM tcLookupId name + ; return $ HsNoVect id + } + +vectCtxt :: Located Name -> SDoc +vectCtxt name = ptext (sLit "When checking the vectorisation declaration for") <+> ppr name -------------- -- If typechecking the binds fails, then return with each @@ -791,7 +872,7 @@ -- where F is a type function and (F a ~ [a]) -- Then unification might succeed with a coercion. But it's much -- much simpler to require that such signatures have identical contexts - checkTc (all isIdentityCoI cois) + checkTc (all isReflCo cois) (ptext (sLit "Mutually dependent functions have syntactically distinct contexts")) } \end{code} @@ -1000,10 +1081,12 @@ -- Precondition: no duplicates mkSigFun sigs = lookupNameEnv env where - env = mkNameEnv (mapCatMaybes mk_pair sigs) - mk_pair (L loc (TypeSig (L _ name) lhs_ty)) = Just (name, (hsExplicitTvs lhs_ty, loc)) - mk_pair (L loc (IdSig id)) = Just (idName id, ([], loc)) - mk_pair _ = Nothing + env = mkNameEnv (concatMap mk_pair sigs) + mk_pair (L loc (IdSig id)) = [(idName id, ([], loc))] + mk_pair (L loc (TypeSig lnames lhs_ty)) = map f lnames + where + f (L _ name) = (name, (hsExplicitTvs lhs_ty, loc)) + mk_pair _ = [] -- The scoped names are the ones explicitly mentioned -- in the HsForAll. (There may be more in sigma_ty, because -- of nested type synonyms. See Note [More instantiated than scoped].) @@ -1011,13 +1094,14 @@ \end{code} \begin{code} -tcTySig :: LSig Name -> TcM TcId -tcTySig (L span (TypeSig (L _ name) ty)) - = setSrcSpan span $ - do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty - ; return (mkLocalId name sigma_ty) } +tcTySig :: LSig Name -> TcM [TcId] +tcTySig (L span (TypeSig names ty)) + = setSrcSpan span $ mapM f names + where + f (L _ name) = do { sigma_ty <- tcHsSigType (FunSigCtxt name) ty + ; return (mkLocalId name sigma_ty) } tcTySig (L _ (IdSig id)) - = return id + = return [id] tcTySig s = pprPanic "tcTySig" (ppr s) ------------------- @@ -1132,20 +1216,26 @@ -- This should be a checkTc, not a warnTc, but as of GHC 6.11 -- the versions of alex and happy available have non-conforming -- templates, so the GHC build fails if it's an error: - ; warnUnlifted <- doptM Opt_WarnLazyUnliftedBindings - ; warnTc (warnUnlifted && not bang_pat) + ; warnUnlifted <- woptM Opt_WarnLazyUnliftedBindings + ; warnTc (warnUnlifted && not bang_pat && lifted_pat) + -- No outer bang, but it's a compound pattern + -- E.g (I# x#) = blah + -- Warn about this, but not about + -- x# = 4# +# 1# + -- (# a, b #) = ... (unliftedMustBeBang binds) } | otherwise = return () where - unlifted = any is_unlifted poly_ids - bang_pat = any (isBangHsBind . unLoc) binds + unlifted = any is_unlifted poly_ids + bang_pat = any (isBangHsBind . unLoc) binds + lifted_pat = any (isLiftedPatBind . unLoc) binds is_unlifted id = case tcSplitForAllTys (idType id) of (_, rho) -> isUnLiftedType rho unliftedMustBeBang :: [LHsBind Name] -> SDoc unliftedMustBeBang binds - = hang (text "Bindings containing unlifted types should use an outermost bang pattern:") + = hang (text "Pattern bindings containing unlifted types should use an outermost bang pattern:") 2 (pprBindList binds) strictBindErr :: String -> Bool -> [LHsBind Name] -> SDoc diff -Nru ghc-7.0.3/compiler/typecheck/TcCanonical.lhs ghc-7.2.1/compiler/typecheck/TcCanonical.lhs --- ghc-7.0.3/compiler/typecheck/TcCanonical.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/typecheck/TcCanonical.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -1,19 +1,20 @@ \begin{code} module TcCanonical( - mkCanonical, mkCanonicals, mkCanonicalFEV, canWanteds, canGivens, - canOccursCheck, canEq, - rewriteWithFunDeps + mkCanonical, mkCanonicals, mkCanonicalFEV, mkCanonicalFEVs, canWanteds, canGivens, + canOccursCheck, canEqToWorkList, + rewriteWithFunDeps, mkCanonicalFDAsDerived, mkCanonicalFDAsWanted ) where #include "HsVersions.h" import BasicTypes -import Type +import Id ( evVarPred ) +import TcErrors import TcRnTypes import FunDeps import qualified TcMType as TcM import TcType -import TcErrors +import Type import Coercion import Class import TyCon @@ -22,7 +23,7 @@ import Var import VarEnv ( TidyEnv ) import Outputable -import Control.Monad ( unless, when, zipWithM, zipWithM_ ) +import Control.Monad ( unless, when, zipWithM, zipWithM_, foldM ) import MonadUtils import Control.Applicative ( (<|>) ) @@ -92,7 +93,9 @@ up a bit; right now we waste a lot of energy traversing the same types multiple times. + \begin{code} + -- Flatten a bunch of types all at once. flattenMany :: CtFlavor -> [Type] -> TcS ([Xi], [Coercion], CanonicalCts) -- Coercions :: Xi ~ Type @@ -111,35 +114,35 @@ -- Preserve type synonyms if possible -- We can tell if ty' is function-free by -- whether there are any floated constraints - ; if isEmptyCCan ccs then - return (ty, ty, emptyCCan) + ; if isReflCo co then + return (ty, mkReflCo ty, emptyCCan) else return (xi, co, ccs) } flatten _ v@(TyVarTy _) - = return (v, v, emptyCCan) + = return (v, mkReflCo v, emptyCCan) flatten ctxt (AppTy ty1 ty2) = do { (xi1,co1,c1) <- flatten ctxt ty1 ; (xi2,co2,c2) <- flatten ctxt ty2 - ; return (mkAppTy xi1 xi2, mkAppCoercion co1 co2, c1 `andCCan` c2) } + ; return (mkAppTy xi1 xi2, mkAppCo co1 co2, c1 `andCCan` c2) } flatten ctxt (FunTy ty1 ty2) = do { (xi1,co1,c1) <- flatten ctxt ty1 ; (xi2,co2,c2) <- flatten ctxt ty2 - ; return (mkFunTy xi1 xi2, mkFunCoercion co1 co2, c1 `andCCan` c2) } + ; return (mkFunTy xi1 xi2, mkFunCo co1 co2, c1 `andCCan` c2) } flatten fl (TyConApp tc tys) -- For a normal type constructor or data family application, we just -- recursively flatten the arguments. | not (isSynFamilyTyCon tc) = do { (xis,cos,ccs) <- flattenMany fl tys - ; return (mkTyConApp tc xis, mkTyConCoercion tc cos, ccs) } + ; return (mkTyConApp tc xis, mkTyConAppCo tc cos, ccs) } -- Otherwise, it's a type function application, and we have to -- flatten it away as well, and generate a new given equality constraint -- between the application and a newly generated flattening skolem variable. - | otherwise + | otherwise = ASSERT( tyConArity tc <= length tys ) -- Type functions are saturated do { (xis, cos, ccs) <- flattenMany fl tys ; let (xi_args, xi_rest) = splitAt (tyConArity tc) xis @@ -147,35 +150,41 @@ -- The type function might be *over* saturated -- in which case the remaining arguments should -- be dealt with by AppTys - fam_ty = mkTyConApp tc xi_args - fam_co = fam_ty -- identity - - ; (ret_co, rhs_var, ct) <- - if isGiven fl then - do { rhs_var <- newFlattenSkolemTy fam_ty - ; cv <- newGivenCoVar fam_ty rhs_var fam_co - ; let ct = CFunEqCan { cc_id = cv - , cc_flavor = fl -- Given - , cc_fun = tc - , cc_tyargs = xi_args - , cc_rhs = rhs_var } - ; return $ (mkCoVarCoercion cv, rhs_var, ct) } - else -- Derived or Wanted: make a new *unification* flatten variable - do { rhs_var <- newFlexiTcSTy (typeKind fam_ty) - ; cv <- newCoVar fam_ty rhs_var - ; let ct = CFunEqCan { cc_id = cv - , cc_flavor = mkWantedFlavor fl - -- Always Wanted, not Derived - , cc_fun = tc - , cc_tyargs = xi_args - , cc_rhs = rhs_var } - ; return $ (mkCoVarCoercion cv, rhs_var, ct) } - + fam_ty = mkTyConApp tc xi_args + ; (ret_co, rhs_var, ct) <- + do { is_cached <- lookupFlatCacheMap tc xi_args fl + ; case is_cached of + Just (rhs_var,ret_co,_fl) -> return (ret_co, rhs_var, emptyCCan) + Nothing + | isGivenOrSolved fl -> + do { rhs_var <- newFlattenSkolemTy fam_ty + ; cv <- newGivenCoVar fam_ty rhs_var (mkReflCo fam_ty) + ; let ct = CFunEqCan { cc_id = cv + , cc_flavor = fl -- Given + , cc_fun = tc + , cc_tyargs = xi_args + , cc_rhs = rhs_var } + ; let ret_co = mkCoVarCo cv + ; updateFlatCacheMap tc xi_args rhs_var fl ret_co + ; return $ (ret_co, rhs_var, singleCCan ct) } + | otherwise -> + -- Derived or Wanted: make a new *unification* flatten variable + do { rhs_var <- newFlexiTcSTy (typeKind fam_ty) + ; cv <- newCoVar fam_ty rhs_var + ; let ct = CFunEqCan { cc_id = cv + , cc_flavor = mkWantedFlavor fl + -- Always Wanted, not Derived + , cc_fun = tc + , cc_tyargs = xi_args + , cc_rhs = rhs_var } + ; let ret_co = mkCoVarCo cv + ; updateFlatCacheMap tc xi_args rhs_var fl ret_co + ; return $ (ret_co, rhs_var, singleCCan ct) } } ; return ( foldl AppTy rhs_var xi_rest - , foldl AppTy (mkSymCoercion ret_co - `mkTransCoercion` mkTyConCoercion tc cos_args) cos_rest - , ccs `extendCCans` ct) } - + , foldl AppCo (mkSymCo ret_co + `mkTransCo` mkTyConAppCo tc cos_args) + cos_rest + , ccs `andCCan` ct) } flatten ctxt (PredTy pred) = do { (pred', co, ccs) <- flattenPred ctxt pred @@ -193,22 +202,20 @@ tv_set = mkVarSet tvs ; unless (isEmptyBag bad_eqs) (flattenForAllErrorTcS ctxt ty bad_eqs) - ; return (mkForAllTys tvs rho', mkForAllTys tvs co, ccs) } + ; return (mkForAllTys tvs rho', foldr mkForAllCo co tvs, ccs) } --------------- flattenPred :: CtFlavor -> TcPredType -> TcS (TcPredType, Coercion, CanonicalCts) flattenPred ctxt (ClassP cls tys) = do { (tys', cos, ccs) <- flattenMany ctxt tys - ; return (ClassP cls tys', mkClassPPredCo cls cos, ccs) } + ; return (ClassP cls tys', mkPredCo $ ClassP cls cos, ccs) } flattenPred ctxt (IParam nm ty) = do { (ty', co, ccs) <- flatten ctxt ty - ; return (IParam nm ty', mkIParamPredCo nm co, ccs) } --- TODO: Handling of coercions between EqPreds must be revisited once the New Coercion API is ready! + ; return (IParam nm ty', mkPredCo $ IParam nm co, ccs) } flattenPred ctxt (EqPred ty1 ty2) = do { (ty1', co1, ccs1) <- flatten ctxt ty1 ; (ty2', co2, ccs2) <- flatten ctxt ty2 - ; return (EqPred ty1' ty2', mkEqPredCo co1 co2, ccs1 `andCCan` ccs2) } - + ; return (EqPred ty1' ty2', mkPredCo $ EqPred co1 co2, ccs1 `andCCan` ccs2) } \end{code} %************************************************************************ @@ -218,51 +225,61 @@ %************************************************************************ \begin{code} -canWanteds :: [WantedEvVar] -> TcS CanonicalCts -canWanteds = fmap andCCans . mapM (\(EvVarX ev loc) -> mkCanonical (Wanted loc) ev) +canWanteds :: [WantedEvVar] -> TcS WorkList +canWanteds = fmap unionWorkLists . mapM (\(EvVarX ev loc) -> mkCanonical (Wanted loc) ev) -canGivens :: GivenLoc -> [EvVar] -> TcS CanonicalCts -canGivens loc givens = do { ccs <- mapM (mkCanonical (Given loc)) givens - ; return (andCCans ccs) } +canGivens :: GivenLoc -> [EvVar] -> TcS WorkList +canGivens loc givens = do { ccs <- mapM (mkCanonical (Given loc GivenOrig)) givens + ; return (unionWorkLists ccs) } -mkCanonicals :: CtFlavor -> [EvVar] -> TcS CanonicalCts -mkCanonicals fl vs = fmap andCCans (mapM (mkCanonical fl) vs) +mkCanonicals :: CtFlavor -> [EvVar] -> TcS WorkList +mkCanonicals fl vs = fmap unionWorkLists (mapM (mkCanonical fl) vs) -mkCanonicalFEV :: FlavoredEvVar -> TcS CanonicalCts +mkCanonicalFEV :: FlavoredEvVar -> TcS WorkList mkCanonicalFEV (EvVarX ev fl) = mkCanonical fl ev -mkCanonical :: CtFlavor -> EvVar -> TcS CanonicalCts +mkCanonicalFEVs :: Bag FlavoredEvVar -> TcS WorkList +mkCanonicalFEVs = foldrBagM canon_one emptyWorkList + where -- Preserves order (shouldn't be important, but curently + -- is important for the vectoriser) + canon_one fev wl = do { wl' <- mkCanonicalFEV fev + ; return (unionWorkList wl' wl) } + + +mkCanonical :: CtFlavor -> EvVar -> TcS WorkList mkCanonical fl ev = case evVarPred ev of - ClassP clas tys -> canClass fl ev clas tys - IParam ip ty -> canIP fl ev ip ty - EqPred ty1 ty2 -> canEq fl ev ty1 ty2 + ClassP clas tys -> canClassToWorkList fl ev clas tys + IParam ip ty -> canIPToWorkList fl ev ip ty + EqPred ty1 ty2 -> canEqToWorkList fl ev ty1 ty2 -canClass :: CtFlavor -> EvVar -> Class -> [TcType] -> TcS CanonicalCts -canClass fl v cn tys +canClassToWorkList :: CtFlavor -> EvVar -> Class -> [TcType] -> TcS WorkList +canClassToWorkList fl v cn tys = do { (xis,cos,ccs) <- flattenMany fl tys -- cos :: xis ~ tys - ; let no_flattening_happened = isEmptyCCan ccs - dict_co = mkTyConCoercion (classTyCon cn) cos - ; v_new <- if no_flattening_happened then return v - else if isGiven fl then return v + ; let no_flattening_happened = all isReflCo cos + dict_co = mkTyConAppCo (classTyCon cn) cos + ; v_new <- if no_flattening_happened then return v + else if isGivenOrSolved fl then return v -- The cos are all identities if fl=Given, -- hence nothing to do else do { v' <- newDictVar cn xis -- D xis ; when (isWanted fl) $ setDictBind v (EvCast v' dict_co) - ; when (isGiven fl) $ setDictBind v' (EvCast v (mkSymCoercion dict_co)) + ; when (isGivenOrSolved fl) $ setDictBind v' (EvCast v (mkSymCo dict_co)) -- NB: No more setting evidence for derived now ; return v' } -- Add the superclasses of this one here, See Note [Adding superclasses]. -- But only if we are not simplifying the LHS of a rule. ; sctx <- getTcSContext - ; sc_cts <- if simplEqsOnly sctx then return emptyCCan + ; sc_cts <- if simplEqsOnly sctx then return emptyWorkList else newSCWorkFromFlavored v_new fl cn xis - ; return (sc_cts `andCCan` ccs `extendCCans` CDictCan { cc_id = v_new - , cc_flavor = fl - , cc_class = cn - , cc_tyargs = xis }) } + ; return (sc_cts `unionWorkList` + workListFromEqs ccs `unionWorkList` + workListFromNonEq CDictCan { cc_id = v_new + , cc_flavor = fl + , cc_class = cn + , cc_tyargs = xis }) } \end{code} Note [Adding superclasses] @@ -311,7 +328,7 @@ Here's an example that demonstrates why we chose to NOT add superclasses during simplification: [Comes from ticket #4497] - + class Num (RealOf t) => Normed t type family RealOf x @@ -330,23 +347,27 @@ \begin{code} -newSCWorkFromFlavored :: EvVar -> CtFlavor -> Class -> [Xi] -> TcS CanonicalCts +newSCWorkFromFlavored :: EvVar -> CtFlavor -> Class -> [Xi] -> TcS WorkList -- Returns superclasses, see Note [Adding superclasses] newSCWorkFromFlavored ev orig_flavor cls xis | isDerived orig_flavor - = return emptyCCan -- Deriveds don't yield more superclasses because we will - -- add them transitively in the case of wanteds. + = return emptyWorkList -- Deriveds don't yield more superclasses because we will + -- add them transitively in the case of wanteds. - | isGiven orig_flavor - = do { let sc_theta = immSuperClasses cls xis - flavor = orig_flavor - ; sc_vars <- mapM newEvVar sc_theta - ; _ <- zipWithM_ setEvBind sc_vars [EvSuperClass ev n | n <- [0..]] - ; mkCanonicals flavor sc_vars } - - | isEmptyVarSet (tyVarsOfTypes xis) - = return emptyCCan -- Wanteds with no variables yield no deriveds. - -- See Note [Improvement from Ground Wanteds] + | Just gk <- isGiven_maybe orig_flavor + = case gk of + GivenOrig -> do { let sc_theta = immSuperClasses cls xis + flavor = orig_flavor + ; sc_vars <- mapM newEvVar sc_theta + ; _ <- zipWithM_ setEvBind sc_vars [EvSuperClass ev n | n <- [0..]] + ; mkCanonicals flavor sc_vars } + GivenSolved -> return emptyWorkList + -- Seems very dangerous to add the superclasses for dictionaries that may be + -- partially solved because we may end up with evidence loops. + + | isEmptyVarSet (tyVarsOfTypes xis) + = return emptyWorkList -- Wanteds with no variables yield no deriveds. + -- See Note [Improvement from Ground Wanteds] | otherwise -- Wanted case, just add those SC that can lead to improvement. = do { let sc_rec_theta = transSuperClasses cls xis @@ -366,21 +387,25 @@ -canIP :: CtFlavor -> EvVar -> IPName Name -> TcType -> TcS CanonicalCts +canIPToWorkList :: CtFlavor -> EvVar -> IPName Name -> TcType -> TcS WorkList -- See Note [Canonical implicit parameter constraints] to see why we don't -- immediately canonicalize (flatten) IP constraints. -canIP fl v nm ty - = return $ singleCCan $ CIPCan { cc_id = v - , cc_flavor = fl - , cc_ip_nm = nm - , cc_ip_ty = ty } +canIPToWorkList fl v nm ty + = return $ workListFromNonEq (CIPCan { cc_id = v + , cc_flavor = fl + , cc_ip_nm = nm + , cc_ip_ty = ty }) ----------------- +canEqToWorkList :: CtFlavor -> EvVar -> Type -> Type -> TcS WorkList +canEqToWorkList fl cv ty1 ty2 = do { cts <- canEq fl cv ty1 ty2 + ; return $ workListFromEqs cts } + canEq :: CtFlavor -> EvVar -> Type -> Type -> TcS CanonicalCts canEq fl cv ty1 ty2 - | tcEqType ty1 ty2 -- Dealing with equality here avoids + | eqType ty1 ty2 -- Dealing with equality here avoids -- later spurious occurs checks for a~a - = do { when (isWanted fl) (setCoBind cv ty1) + = do { when (isWanted fl) (setCoBind cv (mkReflCo ty1)) ; return emptyCCan } -- If one side is a variable, orient and flatten, @@ -394,47 +419,6 @@ ; canEqLeaf untch fl cv (classify ty1) (classify ty2) } -- NB: don't use VarCls directly because tv1 or tv2 may be scolems! -canEq fl cv (TyConApp fn tys) ty2 - | isSynFamilyTyCon fn, length tys == tyConArity fn - = do { untch <- getUntouchables - ; canEqLeaf untch fl cv (FunCls fn tys) (classify ty2) } -canEq fl cv ty1 (TyConApp fn tys) - | isSynFamilyTyCon fn, length tys == tyConArity fn - = do { untch <- getUntouchables - ; canEqLeaf untch fl cv (classify ty1) (FunCls fn tys) } - -canEq fl cv s1 s2 - | Just (t1a,t1b,t1c) <- splitCoPredTy_maybe s1, - Just (t2a,t2b,t2c) <- splitCoPredTy_maybe s2 - = do { (v1,v2,v3) - <- if isWanted fl then -- Wanted - do { v1 <- newCoVar t1a t2a - ; v2 <- newCoVar t1b t2b - ; v3 <- newCoVar t1c t2c - ; let res_co = mkCoPredCo (mkCoVarCoercion v1) - (mkCoVarCoercion v2) (mkCoVarCoercion v3) - ; setCoBind cv res_co - ; return (v1,v2,v3) } - else if isGiven fl then -- Given - let co_orig = mkCoVarCoercion cv - coa = mkCsel1Coercion co_orig - cob = mkCsel2Coercion co_orig - coc = mkCselRCoercion co_orig - in do { v1 <- newGivenCoVar t1a t2a coa - ; v2 <- newGivenCoVar t1b t2b cob - ; v3 <- newGivenCoVar t1c t2c coc - ; return (v1,v2,v3) } - else -- Derived - do { v1 <- newDerivedId (EqPred t1a t2a) - ; v2 <- newDerivedId (EqPred t1b t2b) - ; v3 <- newDerivedId (EqPred t1c t2c) - ; return (v1,v2,v3) } - ; cc1 <- canEq fl v1 t1a t2a - ; cc2 <- canEq fl v2 t1b t2b - ; cc3 <- canEq fl v3 t1c t2c - ; return (cc1 `andCCan` cc2 `andCCan` cc3) } - - -- Split up an equality between function types into two equalities. canEq fl cv (FunTy s1 t1) (FunTy s2 t2) = do { (argv, resv) <- @@ -442,11 +426,10 @@ do { argv <- newCoVar s1 s2 ; resv <- newCoVar t1 t2 ; setCoBind cv $ - mkFunCoercion (mkCoVarCoercion argv) (mkCoVarCoercion resv) + mkFunCo (mkCoVarCo argv) (mkCoVarCo resv) ; return (argv,resv) } - - else if isGiven fl then - let [arg,res] = decomposeCo 2 (mkCoVarCoercion cv) + else if isGivenOrSolved fl then + let [arg,res] = decomposeCo 2 (mkCoVarCo cv) in do { argv <- newGivenCoVar s1 s2 arg ; resv <- newGivenCoVar t1 t2 res ; return (argv,resv) } @@ -460,33 +443,17 @@ ; cc2 <- canEq fl resv t1 t2 ; return (cc1 `andCCan` cc2) } -canEq fl cv (PredTy (IParam n1 t1)) (PredTy (IParam n2 t2)) - | n1 == n2 - = if isWanted fl then - do { v <- newCoVar t1 t2 - ; setCoBind cv $ mkIParamPredCo n1 (mkCoVarCoercion cv) - ; canEq fl v t1 t2 } - else return emptyCCan -- DV: How to decompose given IP coercions? - -canEq fl cv (PredTy (ClassP c1 tys1)) (PredTy (ClassP c2 tys2)) - | c1 == c2 - = if isWanted fl then - do { vs <- zipWithM newCoVar tys1 tys2 - ; setCoBind cv $ mkClassPPredCo c1 (map mkCoVarCoercion vs) - ; andCCans <$> zipWith3M (canEq fl) vs tys1 tys2 - } - else return emptyCCan - -- How to decompose given dictionary (and implicit parameter) coercions? - -- You may think that the following is right: - -- let cos = decomposeCo (length tys1) (mkCoVarCoercion cv) - -- in zipWith3M newGivOrDerCoVar tys1 tys2 cos - -- But this assumes that the coercion is a type constructor-based - -- coercion, and not a PredTy (ClassP cn cos) coercion. So we chose - -- to not decompose these coercions. We have to get back to this - -- when we clean up the Coercion API. +canEq fl cv (TyConApp fn tys) ty2 + | isSynFamilyTyCon fn, length tys == tyConArity fn + = do { untch <- getUntouchables + ; canEqLeaf untch fl cv (FunCls fn tys) (classify ty2) } +canEq fl cv ty1 (TyConApp fn tys) + | isSynFamilyTyCon fn, length tys == tyConArity fn + = do { untch <- getUntouchables + ; canEqLeaf untch fl cv (classify ty1) (FunCls fn tys) } canEq fl cv (TyConApp tc1 tys1) (TyConApp tc2 tys2) - | isAlgTyCon tc1 && isAlgTyCon tc2 + | isDecomposableTyCon tc1 && isDecomposableTyCon tc2 , tc1 == tc2 , length tys1 == length tys2 = -- Generate equalities for each of the corresponding arguments @@ -494,11 +461,10 @@ <- if isWanted fl then do { argsv <- zipWithM newCoVar tys1 tys2 ; setCoBind cv $ - mkTyConCoercion tc1 (map mkCoVarCoercion argsv) - ; return argsv } - - else if isGiven fl then - let cos = decomposeCo (length tys1) (mkCoVarCoercion cv) + mkTyConAppCo tc1 (map mkCoVarCo argsv) + ; return argsv } + else if isGivenOrSolved fl then + let cos = decomposeCo (length tys1) (mkCoVarCo cv) in zipWith3M newGivenCoVar tys1 tys2 cos else -- Derived @@ -509,30 +475,32 @@ -- See Note [Equality between type applications] -- Note [Care with type applications] in TcUnify canEq fl cv ty1 ty2 - | Just (s1,t1) <- tcSplitAppTy_maybe ty1 + | Nothing <- tcView ty1 -- Naked applications ONLY + , Nothing <- tcView ty2 -- See Note [Naked given applications] + , Just (s1,t1) <- tcSplitAppTy_maybe ty1 , Just (s2,t2) <- tcSplitAppTy_maybe ty2 - = do { (cv1,cv2) <- - if isWanted fl - then do { cv1 <- newCoVar s1 s2 - ; cv2 <- newCoVar t1 t2 - ; setCoBind cv $ - mkAppCoercion (mkCoVarCoercion cv1) (mkCoVarCoercion cv2) - ; return (cv1,cv2) } - - else if isGiven fl then - let co1 = mkLeftCoercion $ mkCoVarCoercion cv - co2 = mkRightCoercion $ mkCoVarCoercion cv - in do { cv1 <- newGivenCoVar s1 s2 co1 - ; cv2 <- newGivenCoVar t1 t2 co2 - ; return (cv1,cv2) } - else -- Derived - do { cv1 <- newDerivedId (EqPred s1 s2) - ; cv2 <- newDerivedId (EqPred t1 t2) - ; return (cv1,cv2) } - - ; cc1 <- canEq fl cv1 s1 s2 - ; cc2 <- canEq fl cv2 t1 t2 - ; return (cc1 `andCCan` cc2) } + = if isWanted fl + then do { cv1 <- newCoVar s1 s2 + ; cv2 <- newCoVar t1 t2 + ; setCoBind cv $ + mkAppCo (mkCoVarCo cv1) (mkCoVarCo cv2) + ; cc1 <- canEq fl cv1 s1 s2 + ; cc2 <- canEq fl cv2 t1 t2 + ; return (cc1 `andCCan` cc2) } + + else if isDerived fl + then do { cv1 <- newDerivedId (EqPred s1 s2) + ; cv2 <- newDerivedId (EqPred t1 t2) + ; cc1 <- canEq fl cv1 s1 s2 + ; cc2 <- canEq fl cv2 t1 t2 + ; return (cc1 `andCCan` cc2) } + + else do { traceTcS "canEq/(app case)" $ + text "Ommitting decomposition of given equality between: " + <+> ppr ty1 <+> text "and" <+> ppr ty2 + ; return emptyCCan -- We cannot decompose given applications + -- because we no longer have 'left' and 'right' + } canEq fl cv s1@(ForAllTy {}) s2@(ForAllTy {}) | tcIsForAllTy s1, tcIsForAllTy s2, @@ -551,6 +519,25 @@ canEqFailure fl cv = return (singleCCan (mkFrozenError fl cv)) \end{code} +Note [Naked given applications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider: + data A a + type T a = A a +and the given equality: + [G] A a ~ T Int +We will reach the case canEq where we do a tcSplitAppTy_maybe, but if +we dont have the guards (Nothing <- tcView ty1) (Nothing <- tcView +ty2) then the given equation is going to fall through and get +completely forgotten! + +What we want instead is this clause to apply only when there is no +immediate top-level synonym; if there is one it will be later on +unfolded by the later stages of canEq. + +Test-case is in typecheck/should_compile/GivenTypeSynonym.hs + + Note [Equality between type applications] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If we see an equality of the form s1 t1 ~ s2 t2 we can always split @@ -736,10 +723,10 @@ | cls1 `re_orient` cls2 = do { cv' <- if isWanted fl then do { cv' <- newCoVar s2 s1 - ; setCoBind cv $ mkSymCoercion (mkCoVarCoercion cv') + ; setCoBind cv $ mkSymCo (mkCoVarCo cv') ; return cv' } - else if isGiven fl then - newGivenCoVar s2 s1 (mkSymCoercion (mkCoVarCoercion cv)) + else if isGivenOrSolved fl then + newGivenCoVar s2 s1 (mkSymCo (mkCoVarCo cv)) else -- Derived newDerivedId (EqPred s2 s1) ; canEqLeafOriented fl cv' cls2 s1 } @@ -770,18 +757,18 @@ ; (xi2, co2, ccs2) <- flatten fl s2 -- Flatten entire RHS -- co2 :: xi2 ~ s2 ; let ccs = ccs1 `andCCan` ccs2 - no_flattening_happened = isEmptyCCan ccs - ; cv_new <- if no_flattening_happened then return cv - else if isGiven fl then return cv + no_flattening_happened = all isReflCo (co2:cos1) + ; cv_new <- if no_flattening_happened then return cv + else if isGivenOrSolved fl then return cv else if isWanted fl then do { cv' <- newCoVar (unClassify (FunCls fn xis1)) xi2 -- cv' : F xis ~ xi2 ; let -- fun_co :: F xis1 ~ F tys1 - fun_co = mkTyConCoercion fn cos1 + fun_co = mkTyConAppCo fn cos1 -- want_co :: F tys1 ~ s2 - want_co = mkSymCoercion fun_co - `mkTransCoercion` mkCoVarCoercion cv' - `mkTransCoercion` co2 + want_co = mkSymCo fun_co + `mkTransCo` mkCoVarCo cv' + `mkTransCo` co2 ; setCoBind cv want_co ; return cv' } else -- Derived @@ -816,12 +803,12 @@ ; case mxi2' of { Nothing -> canEqFailure fl cv ; Just xi2' -> - do { let no_flattening_happened = isEmptyCCan ccs2 - ; cv_new <- if no_flattening_happened then return cv - else if isGiven fl then return cv + do { let no_flattening_happened = isReflCo co + ; cv_new <- if no_flattening_happened then return cv + else if isGivenOrSolved fl then return cv else if isWanted fl then do { cv' <- newCoVar (mkTyVarTy tv) xi2' -- cv' : tv ~ xi2 - ; setCoBind cv (mkCoVarCoercion cv' `mkTransCoercion` co) + ; setCoBind cv (mkCoVarCo cv' `mkTransCo` co) ; return cv' } else -- Derived newDerivedId (EqPred (mkTyVarTy tv) xi2') @@ -885,7 +872,7 @@ expandAway tv ty@(ForAllTy {}) = let (tvs,rho) = splitForAllTys ty tvs_knds = map tyVarKind tvs - in if tv `elemVarSet` tyVarsOfTypes tvs_knds then + in if tv `elemVarSet` tyVarsOfTypes tvs_knds then -- Can't expand away the kinds unless we create -- fresh variables which we don't want to do at this point. Nothing @@ -1001,62 +988,62 @@ %* * %************************************************************************ +When we spot an equality arising from a functional dependency, +we now use that equality (a "wanted") to rewrite the work-item +constraint right away. This avoids two dangers + + Danger 1: If we send the original constraint on down the pipeline + it may react with an instance declaration, and in delicate + situations (when a Given overlaps with an instance) that + may produce new insoluble goals: see Trac #4952 + + Danger 2: If we don't rewrite the constraint, it may re-react + with the same thing later, and produce the same equality + again --> termination worries. + +To achieve this required some refactoring of FunDeps.lhs (nicer +now!). + \begin{code} rewriteWithFunDeps :: [Equation] - -> [Xi] -> CtFlavor - -> TcS (Maybe ([Xi], [Coercion], CanonicalCts)) -rewriteWithFunDeps eqn_pred_locs xis fl - = do { fd_ev_poss <- mapM (instFunDepEqn fl) eqn_pred_locs - ; let fd_ev_pos :: [(Int,FlavoredEvVar)] + -> [Xi] + -> WantedLoc + -> TcS (Maybe ([Xi], [Coercion], [(EvVar,WantedLoc)])) + -- Not quite a WantedEvVar unfortunately + -- Because our intention could be to make + -- it derived at the end of the day +-- NB: The flavor of the returned EvVars will be decided by the caller +-- Post: returns no trivial equalities (identities) +rewriteWithFunDeps eqn_pred_locs xis wloc + = do { fd_ev_poss <- mapM (instFunDepEqn wloc) eqn_pred_locs + ; let fd_ev_pos :: [(Int,(EvVar,WantedLoc))] fd_ev_pos = concat fd_ev_poss (rewritten_xis, cos) = unzip (rewriteDictParams fd_ev_pos xis) - ; fds <- mapM (\(_,fev) -> mkCanonicalFEV fev) fd_ev_pos - ; let fd_work = unionManyBags fds - ; if isEmptyBag fd_work - then return Nothing - else return (Just (rewritten_xis, cos, fd_work)) } - -instFunDepEqn :: CtFlavor -- Precondition: Only Wanted or Derived - -> Equation - -> TcS [(Int, FlavoredEvVar)] + ; if null fd_ev_pos then return Nothing + else return (Just (rewritten_xis, cos, map snd fd_ev_pos)) } + +instFunDepEqn :: WantedLoc -> Equation -> TcS [(Int,(EvVar,WantedLoc))] -- Post: Returns the position index as well as the corresponding FunDep equality -instFunDepEqn fl (FDEqn { fd_qtvs = qtvs, fd_eqs = eqs +instFunDepEqn wl (FDEqn { fd_qtvs = qtvs, fd_eqs = eqs , fd_pred1 = d1, fd_pred2 = d2 }) = do { let tvs = varSetElems qtvs ; tvs' <- mapM instFlexiTcS tvs ; let subst = zipTopTvSubst tvs (mkTyVarTys tvs') - ; mapM (do_one subst) eqs } + ; foldM (do_one subst) [] eqs } where - fl' = case fl of - Given _ -> panic "mkFunDepEqns" - Wanted loc -> Wanted (push_ctx loc) - Derived loc -> Derived (push_ctx loc) + do_one subst ievs (FDEq { fd_pos = i, fd_ty_left = ty1, fd_ty_right = ty2 }) + = let sty1 = Type.substTy subst ty1 + sty2 = Type.substTy subst ty2 + in if eqType sty1 sty2 then return ievs -- Return no trivial equalities + else do { ev <- newCoVar sty1 sty2 + ; let wl' = push_ctx wl + ; return $ (i,(ev,wl')):ievs } + push_ctx :: WantedLoc -> WantedLoc push_ctx loc = pushErrCtxt FunDepOrigin (False, mkEqnMsg d1 d2) loc - do_one subst (FDEq { fd_pos = i, fd_ty_left = ty1, fd_ty_right = ty2 }) - = do { let sty1 = substTy subst ty1 - sty2 = substTy subst ty2 - ; ev <- newCoVar sty1 sty2 - ; return (i, mkEvVarX ev fl') } - -rewriteDictParams :: [(Int,FlavoredEvVar)] -- A set of coercions : (pos, ty' ~ ty) - -> [Type] -- A sequence of types: tys - -> [(Type,Coercion)] -- Returns : [(ty', co : ty' ~ ty)] -rewriteDictParams param_eqs tys - = zipWith do_one tys [0..] - where - do_one :: Type -> Int -> (Type,Coercion) - do_one ty n = case lookup n param_eqs of - Just wev -> (get_fst_ty wev, mkCoVarCoercion (evVarOf wev)) - Nothing -> (ty,ty) -- Identity - - get_fst_ty wev = case evVarOfPred wev of - EqPred ty1 _ -> ty1 - _ -> panic "rewriteDictParams: non equality fundep" - -mkEqnMsg :: (TcPredType, SDoc) -> (TcPredType, SDoc) -> TidyEnv - -> TcM (TidyEnv, SDoc) +mkEqnMsg :: (TcPredType, SDoc) + -> (TcPredType, SDoc) -> TidyEnv -> TcM (TidyEnv, SDoc) mkEqnMsg (pred1,from1) (pred2,from2) tidy_env = do { zpred1 <- TcM.zonkTcPredType pred1 ; zpred2 <- TcM.zonkTcPredType pred2 @@ -1066,4 +1053,36 @@ nest 2 (sep [ppr tpred1 <> comma, nest 2 from1]), nest 2 (sep [ppr tpred2 <> comma, nest 2 from2])] ; return (tidy_env, msg) } + +rewriteDictParams :: [(Int,(EvVar,WantedLoc))] -- A set of coercions : (pos, ty' ~ ty) + -> [Type] -- A sequence of types: tys + -> [(Type,Coercion)] -- Returns: [(ty', co : ty' ~ ty)] +rewriteDictParams param_eqs tys + = zipWith do_one tys [0..] + where + do_one :: Type -> Int -> (Type,Coercion) + do_one ty n = case lookup n param_eqs of + Just wev -> (get_fst_ty wev, mkCoVarCo (fst wev)) + Nothing -> (ty, mkReflCo ty) -- Identity + + get_fst_ty (wev,_wloc) + | EqPred ty1 _ <- evVarPred wev + = ty1 + | otherwise + = panic "rewriteDictParams: non equality fundep!?" + +mkCanonicalFDAsWanted :: [(EvVar,WantedLoc)] -> TcS WorkList +mkCanonicalFDAsWanted evlocs + = do { ws <- mapM can_as_wanted evlocs + ; return (unionWorkLists ws) } + where can_as_wanted (ev,loc) = mkCanonicalFEV (EvVarX ev (Wanted loc)) + + +mkCanonicalFDAsDerived :: [(EvVar,WantedLoc)] -> TcS WorkList +mkCanonicalFDAsDerived evlocs + = do { ws <- mapM can_as_derived evlocs + ; return (unionWorkLists ws) } + where can_as_derived (ev,loc) = mkCanonicalFEV (EvVarX ev (Derived loc)) + + \end{code} \ No newline at end of file diff -Nru ghc-7.0.3/compiler/typecheck/TcClassDcl.lhs ghc-7.2.1/compiler/typecheck/TcClassDcl.lhs --- ghc-7.0.3/compiler/typecheck/TcClassDcl.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/typecheck/TcClassDcl.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -8,19 +8,15 @@ \begin{code} module TcClassDcl ( tcClassSigs, tcClassDecl2, findMethodBind, instantiateMethod, tcInstanceMethodBody, - mkGenericDefMethBind, getGenericInstances, + mkGenericDefMethBind, tcAddDeclCtxt, badMethodErr, badATErr, omittedATWarn ) where #include "HsVersions.h" import HsSyn -import RnHsSyn -import RnExpr -import Inst -import InstEnv -import TcPat( addInlinePrags ) import TcEnv +import TcPat( addInlinePrags ) import TcBinds import TcUnify import TcHsType @@ -28,21 +24,15 @@ import TcType import TcRnMonad import BuildTyCl( TcMethInfo ) -import Generics import Class -import TyCon -import MkId import Id import Name -import Var import NameEnv import NameSet +import Var import Outputable -import PrelNames import DynFlags import ErrUtils -import Util -import ListSetOps import SrcLoc import Maybes import BasicTypes @@ -50,7 +40,6 @@ import FastString import Control.Monad -import Data.List \end{code} @@ -94,51 +83,44 @@ %************************************************************************ \begin{code} -tcClassSigs :: Name -- Name of the class +tcClassSigs :: Name -- Name of the class -> [LSig Name] -> LHsBinds Name - -> TcM [TcMethInfo] - + -> TcM ([TcMethInfo], -- Exactly one for each method + NameEnv Type) -- Types of the generic-default methods tcClassSigs clas sigs def_methods - = do { dm_env <- mapM (addLocM (checkDefaultBind clas op_names)) - (bagToList def_methods) - ; mapM (tcClassSig (mkNameEnv dm_env)) op_sigs } - where - op_sigs = [sig | sig@(L _ (TypeSig _ _)) <- sigs] - op_names = [n | (L _ (TypeSig (L _ n) _)) <- op_sigs] + = do { gen_dm_prs <- concat <$> mapM (addLocM tc_gen_sig) gen_sigs + ; let gen_dm_env = mkNameEnv gen_dm_prs + + ; op_info <- concat <$> mapM (addLocM (tc_sig gen_dm_env)) vanilla_sigs + + ; let op_names = mkNameSet [ n | (n,_,_) <- op_info ] + ; sequence_ [ failWithTc (badMethodErr clas n) + | n <- dm_bind_names, not (n `elemNameSet` op_names) ] + -- Value binding for non class-method (ie no TypeSig) -checkDefaultBind :: Name -> [Name] -> HsBindLR Name Name -> TcM (Name, DefMethSpec) - -- Check default bindings - -- a) must be for a class op for this class - -- b) must be all generic or all non-generic -checkDefaultBind clas ops (FunBind {fun_id = L _ op, fun_matches = MatchGroup matches _ }) - = do { -- Check that the op is from this class - checkTc (op `elem` ops) (badMethodErr clas op) - - -- Check that all the defns ar generic, or none are - ; case (none_generic, all_generic) of - (True, _) -> return (op, VanillaDM) - (_, True) -> return (op, GenericDM) - _ -> failWith (mixedGenericErr op) - } + ; sequence_ [ failWithTc (badGenericMethod clas n) + | (n,_) <- gen_dm_prs, not (n `elem` dm_bind_names) ] + -- Generic signature without value binding + + ; return (op_info, gen_dm_env) } where - n_generic = count (isJust . maybeGenericMatch) matches - none_generic = n_generic == 0 - all_generic = matches `lengthIs` n_generic - -checkDefaultBind _ _ b = pprPanic "checkDefaultBind" (ppr b) - - -tcClassSig :: NameEnv DefMethSpec -- Info about default methods; - -> LSig Name - -> TcM TcMethInfo - -tcClassSig dm_env (L loc (TypeSig (L _ op_name) op_hs_ty)) - = setSrcSpan loc $ do - { op_ty <- tcHsKindedType op_hs_ty -- Class tyvars already in scope - ; let dm = lookupNameEnv dm_env op_name `orElse` NoDM - ; return (op_name, dm, op_ty) } -tcClassSig _ s = pprPanic "tcClassSig" (ppr s) + vanilla_sigs = [L loc (nm,ty) | L loc (TypeSig nm ty) <- sigs] + gen_sigs = [L loc (nm,ty) | L loc (GenericSig nm ty) <- sigs] + dm_bind_names :: [Name] -- These ones have a value binding in the class decl + dm_bind_names = [op | L _ (FunBind {fun_id = L _ op}) <- bagToList def_methods] + + tc_sig genop_env (op_names, op_hs_ty) + = do { op_ty <- tcHsKindedType op_hs_ty -- Class tyvars already in scope + ; return [ (op_name, f op_name, op_ty) | L _ op_name <- op_names ] } + where + f nm | nm `elemNameEnv` genop_env = GenericDM + | nm `elem` dm_bind_names = VanillaDM + | otherwise = NoDM + + tc_gen_sig (op_names, gen_hs_ty) + = do { gen_op_ty <- tcHsKindedType gen_hs_ty + ; return [ (op_name, gen_op_ty) | L _ op_name <- op_names ] } \end{code} @@ -174,20 +156,21 @@ pred = mkClassPred clas (mkTyVarTys clas_tyvars) ; this_dict <- newEvVar pred + ; traceTc "TIM2" (ppr sigs) ; let tc_dm = tcDefMeth clas clas_tyvars - this_dict default_binds + this_dict default_binds sig_fn prag_fn ; dm_binds <- tcExtendTyVarEnv clas_tyvars $ mapM tc_dm op_items - ; return (listToBag (catMaybes dm_binds)) } + ; return (unionManyBags dm_binds) } tcClassDecl2 d = pprPanic "tcClassDecl2" (ppr d) tcDefMeth :: Class -> [TyVar] -> EvVar -> LHsBinds Name -> SigFun -> PragFun -> ClassOpItem - -> TcM (Maybe (LHsBind Id)) + -> TcM (LHsBinds TcId) -- Generate code for polymorphic default methods only (hence DefMeth) -- (Generic default methods have turned into instance decls by now.) -- This is incompatible with Hugs, which expects a polymorphic @@ -196,40 +179,45 @@ -- (If necessary we can fix that, but we don't have a convenient Id to hand.) tcDefMeth clas tyvars this_dict binds_in sig_fn prag_fn (sel_id, dm_info) = case dm_info of - NoDefMeth -> return Nothing - GenDefMeth -> return Nothing - DefMeth dm_name -> do - { let sel_name = idName sel_id - ; local_dm_name <- newLocalName sel_name - -- Base the local_dm_name on the selector name, because - -- type errors from tcInstanceMethodBody come from here - - -- See Note [Silly default-method bind] - -- (possibly out of date) - - ; let meth_bind = findMethodBind sel_name binds_in - `orElse` pprPanic "tcDefMeth" (ppr sel_id) - -- dm_info = DefMeth dm_name only if there is a binding in binds_in - - dm_sig_fn _ = sig_fn sel_name - dm_id = mkDefaultMethodId sel_id dm_name - local_dm_type = instantiateMethod clas sel_id (mkTyVarTys tyvars) - local_dm_id = mkLocalId local_dm_name local_dm_type - prags = prag_fn sel_name - - ; dm_id_w_inline <- addInlinePrags dm_id prags - ; spec_prags <- tcSpecPrags dm_id prags - - ; warnTc (not (null spec_prags)) - (ptext (sLit "Ignoring SPECIALISE pragmas on default method") - <+> quotes (ppr sel_name)) - - ; liftM Just $ - tcInstanceMethodBody (ClsSkol clas) - tyvars - [this_dict] - dm_id_w_inline local_dm_id - dm_sig_fn IsDefaultMethod meth_bind } + NoDefMeth -> do { mapM_ (addLocM (badDmPrag sel_id)) prags + ; return emptyBag } + DefMeth dm_name -> tc_dm dm_name + GenDefMeth dm_name -> tc_dm dm_name + where + sel_name = idName sel_id + prags = prag_fn sel_name + dm_sig_fn _ = sig_fn sel_name + dm_bind = findMethodBind sel_name binds_in + `orElse` pprPanic "tcDefMeth" (ppr sel_id) + + -- Eg. class C a where + -- op :: forall b. Eq b => a -> [b] -> a + -- gen_op :: a -> a + -- generic gen_op :: D a => a -> a + -- The "local_dm_ty" is precisely the type in the above + -- type signatures, ie with no "forall a. C a =>" prefix + + tc_dm dm_name + = do { dm_id <- tcLookupId dm_name + ; local_dm_name <- newLocalName sel_name + -- Base the local_dm_name on the selector name, because + -- type errors from tcInstanceMethodBody come from here + + ; let local_dm_ty = instantiateMethod clas dm_id (mkTyVarTys tyvars) + local_dm_id = mkLocalId local_dm_name local_dm_ty + + ; dm_id_w_inline <- addInlinePrags dm_id prags + ; spec_prags <- tcSpecPrags dm_id prags + + ; warnTc (not (null spec_prags)) + (ptext (sLit "Ignoring SPECIALISE pragmas on default method") + <+> quotes (ppr sel_name)) + + ; tc_bind <- tcInstanceMethodBody (ClsSkol clas) tyvars [this_dict] + dm_id_w_inline local_dm_id dm_sig_fn + IsDefaultMethod dm_bind + + ; return (unitBag tc_bind) } --------------- tcInstanceMethodBody :: SkolemInfo -> [TcTyVar] -> [EvVar] @@ -246,7 +234,7 @@ let lm_bind = L loc (bind { fun_id = L loc (idName local_meth_id) }) -- Substitute the local_meth_name for the binder -- NB: the binding is always a FunBind - + ; traceTc "TIM" (ppr local_meth_id $$ ppr (meth_sig_fn (idName local_meth_id))) ; (ev_binds, (tc_bind, _)) <- checkConstraints skol_info tyvars dfun_ev_vars $ tcExtendIdEnv [local_meth_id] $ @@ -359,179 +347,22 @@ op Unit = ... \begin{code} -mkGenericDefMethBind :: Class -> [Type] -> Id -> TcM (LHsBind Name) -mkGenericDefMethBind clas inst_tys sel_id +mkGenericDefMethBind :: Class -> [Type] -> Id -> Name -> TcM (LHsBind Name) +mkGenericDefMethBind clas inst_tys sel_id dm_name = -- A generic default method - -- If the method is defined generically, we can only do the job if the - -- instance declaration is for a single-parameter type class with - -- a type constructor applied to type arguments in the instance decl - -- (checkTc, so False provokes the error) - do { checkTc (isJust maybe_tycon) - (badGenericInstance sel_id (notSimple inst_tys)) - ; checkTc (tyConHasGenerics tycon) - (badGenericInstance sel_id (notGeneric tycon)) - - ; dflags <- getDOpts + -- If the method is defined generically, we only have to call the + -- dm_name. + do { dflags <- getDOpts ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Filling in method body" (vcat [ppr clas <+> ppr inst_tys, nest 2 (ppr sel_id <+> equals <+> ppr rhs)])) - -- Rename it before returning it - ; (rn_rhs, _) <- rnLExpr rhs ; return (noLoc $ mkFunBind (noLoc (idName sel_id)) - [mkSimpleMatch [] rn_rhs]) } - where - rhs = mkGenericRhs sel_id clas_tyvar tycon - - -- The tycon is only used in the generic case, and in that - -- case we require that the instance decl is for a single-parameter - -- type class with type variable arguments: - -- instance (...) => C (T a b) - clas_tyvar = ASSERT (not (null (classTyVars clas))) head (classTyVars clas) - Just tycon = maybe_tycon - maybe_tycon = case inst_tys of - [ty] -> case tcSplitTyConApp_maybe ty of - Just (tycon, arg_tys) | all tcIsTyVarTy arg_tys -> Just tycon - _ -> Nothing - _ -> Nothing - - ---------------------------- -getGenericInstances :: [LTyClDecl Name] -> TcM [InstInfo Name] -getGenericInstances class_decls - = do { gen_inst_infos <- mapM (addLocM get_generics) class_decls - ; let { gen_inst_info = concat gen_inst_infos } - - -- Return right away if there is no generic stuff - ; if null gen_inst_info then return [] - else do - - -- Otherwise print it out - { dumpDerivingInfo $ hang (ptext (sLit "Generic instances")) - 2 (vcat (map pprInstInfoDetails gen_inst_info)) - ; return gen_inst_info }} - -get_generics :: TyClDecl Name -> TcM [InstInfo Name] -get_generics decl@(ClassDecl {tcdLName = class_name, tcdMeths = def_methods}) - | null generic_binds - = return [] -- The comon case: no generic default methods - - | otherwise -- A source class decl with generic default methods - = recoverM (return []) $ - tcAddDeclCtxt decl $ do - clas <- tcLookupLocatedClass class_name - - -- Group by type, and - -- make an InstInfo out of each group - let - groups = groupWith listToBag generic_binds - - inst_infos <- mapM (mkGenericInstance clas) groups - - -- Check that there is only one InstInfo for each type constructor - -- The main way this can fail is if you write - -- f {| a+b |} ... = ... - -- f {| x+y |} ... = ... - -- Then at this point we'll have an InstInfo for each - -- - -- The class should be unary, which is why simpleInstInfoTyCon should be ok - let - tc_inst_infos :: [(TyCon, InstInfo Name)] - tc_inst_infos = [(simpleInstInfoTyCon i, i) | i <- inst_infos] - - bad_groups = [group | group <- equivClassesByUniq get_uniq tc_inst_infos, - group `lengthExceeds` 1] - get_uniq (tc,_) = getUnique tc - - mapM_ (addErrTc . dupGenericInsts) bad_groups - - -- Check that there is an InstInfo for each generic type constructor - let - missing = genericTyConNames `minusList` [tyConName tc | (tc,_) <- tc_inst_infos] - - checkTc (null missing) (missingGenericInstances missing) - - return inst_infos - where - generic_binds :: [(HsType Name, LHsBind Name)] - generic_binds = getGenericBinds def_methods -get_generics decl = pprPanic "get_generics" (ppr decl) - - ---------------------------------- -getGenericBinds :: LHsBinds Name -> [(HsType Name, LHsBind Name)] - -- Takes a group of method bindings, finds the generic ones, and returns - -- them in finite map indexed by the type parameter in the definition. -getGenericBinds binds = concat (map getGenericBind (bagToList binds)) - -getGenericBind :: LHsBindLR Name Name -> [(HsType Name, LHsBindLR Name Name)] -getGenericBind (L loc bind@(FunBind { fun_matches = MatchGroup matches ty })) - = groupWith wrap (mapCatMaybes maybeGenericMatch matches) + [mkSimpleMatch [] rhs]) } where - wrap ms = L loc (bind { fun_matches = MatchGroup ms ty }) -getGenericBind _ - = [] - -groupWith :: ([a] -> b) -> [(HsType Name, a)] -> [(HsType Name, b)] -groupWith _ [] = [] -groupWith op ((t,v):prs) = (t, op (v:vs)) : groupWith op rest - where - vs = map snd this - (this,rest) = partition same_t prs - same_t (t', _v) = t `eqPatType` t' - -eqPatLType :: LHsType Name -> LHsType Name -> Bool -eqPatLType t1 t2 = unLoc t1 `eqPatType` unLoc t2 - -eqPatType :: HsType Name -> HsType Name -> Bool --- A very simple equality function, only for --- type patterns in generic function definitions. -eqPatType (HsTyVar v1) (HsTyVar v2) = v1==v2 -eqPatType (HsAppTy s1 t1) (HsAppTy s2 t2) = s1 `eqPatLType` s2 && t1 `eqPatLType` t2 -eqPatType (HsOpTy s1 op1 t1) (HsOpTy s2 op2 t2) = s1 `eqPatLType` s2 && t1 `eqPatLType` t2 && unLoc op1 == unLoc op2 -eqPatType (HsNumTy n1) (HsNumTy n2) = n1 == n2 -eqPatType (HsParTy t1) t2 = unLoc t1 `eqPatType` t2 -eqPatType t1 (HsParTy t2) = t1 `eqPatType` unLoc t2 -eqPatType _ _ = False - ---------------------------------- -mkGenericInstance :: Class - -> (HsType Name, LHsBinds Name) - -> TcM (InstInfo Name) - -mkGenericInstance clas (hs_ty, binds) = do - -- Make a generic instance declaration - -- For example: instance (C a, C b) => C (a+b) where { binds } - - -- Extract the universally quantified type variables - -- and wrap them as forall'd tyvars, so that kind inference - -- works in the standard way - let - sig_tvs = userHsTyVarBndrs $ map noLoc $ nameSetToList $ - extractHsTyVars (noLoc hs_ty) - hs_forall_ty = noLoc $ mkExplicitHsForAllTy sig_tvs (noLoc []) (noLoc hs_ty) - - -- Type-check the instance type, and check its form - forall_inst_ty <- tcHsSigType GenPatCtxt hs_forall_ty - let - (tyvars, inst_ty) = tcSplitForAllTys forall_inst_ty - - checkTc (validGenericInstanceType inst_ty) - (badGenericInstanceType binds) - - -- Make the dictionary function. - span <- getSrcSpanM - overlap_flag <- getOverlapFlag - dfun_name <- newDFunName clas [inst_ty] span - let - inst_theta = [mkClassPred clas [mkTyVarTy tv] | tv <- tyvars] - dfun_id = mkDictFunId dfun_name tyvars inst_theta clas [inst_ty] - ispec = mkLocalInstance dfun_id overlap_flag - - return (InstInfo { iSpec = ispec, iBinds = VanillaInst binds [] False }) + rhs = nlHsVar dm_name \end{code} - %************************************************************************ %* * Error messages @@ -562,6 +393,11 @@ = hsep [ptext (sLit "Class"), quotes (ppr clas), ptext (sLit "does not have a method"), quotes (ppr op)] +badGenericMethod :: Outputable a => a -> Name -> SDoc +badGenericMethod clas op + = hsep [ptext (sLit "Class"), quotes (ppr clas), + ptext (sLit "has a generic-default signature without a binding"), quotes (ppr op)] + badATErr :: Class -> Name -> SDoc badATErr clas at = hsep [ptext (sLit "Class"), quotes (ppr clas), @@ -570,23 +406,7 @@ omittedATWarn :: Name -> SDoc omittedATWarn at = ptext (sLit "No explicit AT declaration for") <+> quotes (ppr at) - -badGenericInstance :: Var -> SDoc -> SDoc -badGenericInstance sel_id because - = sep [ptext (sLit "Can't derive generic code for") <+> quotes (ppr sel_id), - because] - -notSimple :: [Type] -> SDoc -notSimple inst_tys - = vcat [ptext (sLit "because the instance type(s)"), - nest 2 (ppr inst_tys), - ptext (sLit "is not a simple type of form (T a1 ... an)")] - -notGeneric :: TyCon -> SDoc -notGeneric tycon - = vcat [ptext (sLit "because the instance type constructor") <+> quotes (ppr tycon) <+> - ptext (sLit "was not compiled with -XGenerics")] - +{- badGenericInstanceType :: LHsBinds Name -> SDoc badGenericInstanceType binds = vcat [ptext (sLit "Illegal type pattern in the generic bindings"), @@ -604,8 +424,10 @@ ] where ppr_inst_ty (_,inst) = ppr (simpleInstInfoTy inst) - -mixedGenericErr :: Name -> SDoc -mixedGenericErr op - = ptext (sLit "Can't mix generic and non-generic equations for class method") <+> quotes (ppr op) +-} +badDmPrag :: Id -> Sig Name -> TcM () +badDmPrag sel_id prag + = addErrTc (ptext (sLit "The") <+> hsSigDoc prag <+> ptext (sLit "for default method") + <+> quotes (ppr sel_id) + <+> ptext (sLit "lacks an accompanying binding")) \end{code} diff -Nru ghc-7.0.3/compiler/typecheck/TcDeriv.lhs ghc-7.2.1/compiler/typecheck/TcDeriv.lhs --- ghc-7.0.3/compiler/typecheck/TcDeriv.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/typecheck/TcDeriv.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -40,10 +40,13 @@ import NameSet import TyCon import TcType +import BuildTyCl +import BasicTypes import Var import VarSet import PrelNames import SrcLoc +import UniqSupply import Util import ListSetOps import Outputable @@ -125,6 +128,9 @@ ds_cls = c, ds_tys = tys, ds_theta = rhs }) = parens (hsep [ppr l, ppr n, ppr tvs, ppr c, ppr tys] <+> equals <+> ppr rhs) + +instance Outputable DerivSpec where + ppr = pprDerivSpec \end{code} @@ -292,17 +298,21 @@ tcDeriving :: [LTyClDecl Name] -- All type constructors -> [LInstDecl Name] -- All instance declarations -> [LDerivDecl Name] -- All stand-alone deriving declarations - -> TcM ([InstInfo Name], -- The generated "instance decls" - HsValBinds Name, -- Extra generated top-level bindings - DefUses) + -> TcM ([InstInfo Name] -- The generated "instance decls" + ,HsValBinds Name -- Extra generated top-level bindings + ,DefUses + ,[TyCon] -- Extra generated top-level types + ,[TyCon]) -- Extra generated type family instances tcDeriving tycl_decls inst_decls deriv_decls - = recoverM (return ([], emptyValBindsOut, emptyDUs)) $ + = recoverM (return ([], emptyValBindsOut, emptyDUs, [], [])) $ do { -- Fish the "deriving"-related information out of the TcEnv -- And make the necessary "equations". is_boot <- tcIsHsBoot ; traceTc "tcDeriving" (ppr is_boot) - ; early_specs <- makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls + ; (early_specs, genericsExtras) + <- makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls + ; let (repMetaTys, repTyCons, metaInsts) = unzip3 genericsExtras ; overlap_flag <- getOverlapFlag ; let (infer_specs, given_specs) = splitEithers early_specs @@ -313,20 +323,44 @@ ; insts2 <- mapM (genInst False overlap_flag) final_specs - -- Generate the generic to/from functions from each type declaration - ; gen_binds <- mkGenericBinds is_boot tycl_decls - ; (inst_info, rn_binds, rn_dus) <- renameDeriv is_boot gen_binds (insts1 ++ insts2) + -- We no longer generate the old generic to/from functions + -- from each type declaration, so this is emptyBag + ; gen_binds <- return emptyBag -- mkGenericBinds is_boot tycl_decls + + ; (inst_info, rn_binds, rn_dus) + <- renameDeriv is_boot gen_binds (insts1 ++ insts2 ++ concat metaInsts) + ; dflags <- getDOpts + ; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances" + (ddump_deriving inst_info rn_binds repMetaTys repTyCons metaInsts)) +{- ; when (not (null inst_info)) $ dumpDerivingInfo (ddump_deriving inst_info rn_binds) +-} + ; return ( inst_info, rn_binds, rn_dus + , concat (map metaTyCons2TyCons repMetaTys), repTyCons) } + where + ddump_deriving :: [InstInfo Name] -> HsValBinds Name + -> [MetaTyCons] -- ^ Empty data constructors + -> [TyCon] -- ^ Rep type family instances + -> [[(InstInfo RdrName, DerivAuxBinds)]] + -- ^ Instances for the repMetaTys + -> SDoc + ddump_deriving inst_infos extra_binds repMetaTys repTyCons metaInsts + = hang (ptext (sLit "Derived instances")) + 2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos) + $$ ppr extra_binds) + $$ hangP "Generic representation" ( + hangP "Generated datatypes for meta-information" + (vcat (map ppr repMetaTys)) + -- The Outputable instance for TyCon unfortunately only prints the name... + $$ hangP "Representation types" + (vcat (map ppr repTyCons)) + $$ hangP "Meta-information instances" + (vcat (map (pprInstInfoDetails . fst) (concat metaInsts)))) + + hangP s x = text "" $$ hang (ptext (sLit s)) 2 x - ; return (inst_info, rn_binds, rn_dus) } - where - ddump_deriving :: [InstInfo Name] -> HsValBinds Name -> SDoc - ddump_deriving inst_infos extra_binds - = hang (ptext (sLit "Derived instances")) - 2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos) - $$ ppr extra_binds) renameDeriv :: Bool -> LHsBinds RdrName -> [(InstInfo RdrName, DerivAuxBinds)] @@ -340,7 +374,7 @@ | otherwise = discardWarnings $ -- Discard warnings about unused bindings etc - do { (rn_gen, dus_gen) <- setOptM Opt_ScopedTypeVariables $ -- Type signatures in patterns + do { (rn_gen, dus_gen) <- setXOptM Opt_ScopedTypeVariables $ -- Type signatures in patterns -- are used in the generic binds rnTopBinds (ValBindsIn gen_binds []) ; keepAliveSetTc (duDefs dus_gen) -- Mark these guys to be kept alive @@ -379,26 +413,12 @@ -- scope (yuk), and rename the method binds ASSERT( null sigs ) bindLocalNames (map Var.varName tyvars) $ - do { (rn_binds, fvs) <- rnMethodBinds clas_nm (\_ -> []) [] binds + do { (rn_binds, fvs) <- rnMethodBinds clas_nm (\_ -> []) binds ; let binds' = VanillaInst rn_binds [] standalone_deriv ; return (inst_info { iBinds = binds' }, fvs) } where (tyvars,_, clas,_) = instanceHead inst clas_nm = className clas - ------------------------------------------ -mkGenericBinds :: Bool -> [LTyClDecl Name] -> TcM (LHsBinds RdrName) -mkGenericBinds is_boot tycl_decls - | is_boot - = return emptyBag - | otherwise - = do { tcs <- mapM tcLookupTyCon [ tcdName d - | L _ d <- tycl_decls, isDataDecl d ] - ; return (unionManyBags [ mkTyConGenericBinds tc - | tc <- tcs, tyConHasGenerics tc ]) } - -- We are only interested in the data type declarations, - -- and then only in the ones whose 'has-generics' flag is on - -- The predicate tyConHasGenerics finds both of these \end{code} Note [Newtype deriving and unused constructors] @@ -430,34 +450,93 @@ @makeDerivSpecs@ fishes around to find the info about needed derived instances. \begin{code} +-- Make the "extras" for the generic representation +mkGenDerivExtras :: TyCon + -> TcRn (MetaTyCons, TyCon, [(InstInfo RdrName, DerivAuxBinds)]) +mkGenDerivExtras tc = do + { (metaTyCons, rep0TyInst) <- genGenericRepExtras tc + ; metaInsts <- genDtMeta (tc, metaTyCons) + ; return (metaTyCons, rep0TyInst, metaInsts) } + makeDerivSpecs :: Bool -> [LTyClDecl Name] - -> [LInstDecl Name] + -> [LInstDecl Name] -> [LDerivDecl Name] - -> TcM [EarlyDerivSpec] - + -> TcM ( [EarlyDerivSpec] + , [(MetaTyCons, TyCon, [(InstInfo RdrName, DerivAuxBinds)])]) makeDerivSpecs is_boot tycl_decls inst_decls deriv_decls - | is_boot -- No 'deriving' at all in hs-boot files - = do { mapM_ add_deriv_err deriv_locs - ; return [] } + | is_boot -- No 'deriving' at all in hs-boot files + = do { mapM_ add_deriv_err deriv_locs + ; return ([],[]) } | otherwise - = do { eqns1 <- mapAndRecoverM deriveTyData all_tydata - ; eqns2 <- mapAndRecoverM deriveStandalone deriv_decls - ; return (eqns1 ++ eqns2) } - where + = do { eqns1 <- mapAndRecoverM deriveTyData all_tydata + ; eqns2 <- mapAndRecoverM deriveStandalone deriv_decls + + -- Generic representation stuff: we might need to add some "extras" + -- to the instances + ; xDerRep <- getDOpts >>= return . xopt Opt_DeriveGeneric + ; generic_extras_deriv <- if not xDerRep + -- No extras if the flag is off + then (return []) + else do { + let allTyNames = [ tcdName d | L _ d <- tycl_decls, isDataDecl d ] + -- Select only those types that derive Generic + ; let sel_tydata = [ tcdName t | (L _ c, L _ t) <- all_tydata + , getClassName c == Just genClassName ] + ; let sel_deriv_decls = catMaybes [ getTypeName t + | L _ (DerivDecl (L _ t)) <- deriv_decls + , getClassName t == Just genClassName ] + ; derTyDecls <- mapM tcLookupTyCon $ + filter (needsExtras xDerRep + (sel_tydata ++ sel_deriv_decls)) allTyNames + -- We need to generate the extras to add to what has + -- already been derived + ; {- pprTrace "sel_tydata" (ppr sel_tydata) $ + pprTrace "sel_deriv_decls" (ppr sel_deriv_decls) $ + pprTrace "derTyDecls" (ppr derTyDecls) $ + pprTrace "deriv_decls" (ppr deriv_decls) $ -} + mapM mkGenDerivExtras derTyDecls } + + -- Merge and return + ; return ( eqns1 ++ eqns2, generic_extras_deriv) } + where + -- We need extras if the flag DeriveGeneric is on and this type is + -- deriving Generic + needsExtras xDerRep tydata tc_name = xDerRep && tc_name `elem` tydata + + -- Extracts the name of the class in the deriving + getClassName :: HsType Name -> Maybe Name + getClassName (HsForAllTy _ _ _ (L _ n)) = getClassName n + getClassName (HsPredTy (HsClassP n _)) = Just n + getClassName _ = Nothing + + -- Extracts the name of the type in the deriving + -- This function (and also getClassName above) is not really nice, and I + -- might not have covered all possible cases. I wonder if there is no easier + -- way to extract class and type name from a LDerivDecl... + getTypeName :: HsType Name -> Maybe Name + getTypeName (HsForAllTy _ _ _ (L _ n)) = getTypeName n + getTypeName (HsTyVar n) = Just n + getTypeName (HsOpTy _ (L _ n) _) = Just n + getTypeName (HsPredTy (HsClassP _ [L _ n])) = getTypeName n + getTypeName (HsAppTy (L _ n) _) = getTypeName n + getTypeName (HsParTy (L _ n)) = getTypeName n + getTypeName (HsKindSig (L _ n) _) = getTypeName n + getTypeName _ = Nothing + extractTyDataPreds decls = [(p, d) | d@(L _ (TyData {tcdDerivs = Just preds})) <- decls, p <- preds] all_tydata :: [(LHsType Name, LTyClDecl Name)] - -- Derived predicate paired with its data type declaration + -- Derived predicate paired with its data type declaration all_tydata = extractTyDataPreds (instDeclATs inst_decls ++ tycl_decls) deriv_locs = map (getLoc . snd) all_tydata - ++ map getLoc deriv_decls + ++ map getLoc deriv_decls add_deriv_err loc = setSrcSpan loc $ - addErr (hang (ptext (sLit "Deriving not permitted in hs-boot file")) - 2 (ptext (sLit "Use an instance declaration instead"))) + addErr (hang (ptext (sLit "Deriving not permitted in hs-boot file")) + 2 (ptext (sLit "Use an instance declaration instead"))) ------------------------------------------------------------------ deriveStandalone :: LDerivDecl Name -> TcM EarlyDerivSpec @@ -597,32 +676,46 @@ mkEqnHelp orig tvs cls cls_tys tc_app mtheta | Just (tycon, tc_args) <- tcSplitTyConApp_maybe tc_app , isAlgTyCon tycon -- Check for functions, primitive types etc - = do { (rep_tc, rep_tc_args) <- tcLookupDataFamInst tycon tc_args - -- Be careful to test rep_tc here: in the case of families, - -- we want to check the instance tycon, not the family tycon - - -- For standalone deriving (mtheta /= Nothing), - -- check that all the data constructors are in scope. - -- No need for this when deriving Typeable, becuase we don't need - -- the constructors for that. - ; rdr_env <- getGlobalRdrEnv - ; let hidden_data_cons = isAbstractTyCon rep_tc || any not_in_scope (tyConDataCons rep_tc) - not_in_scope dc = null (lookupGRE_Name rdr_env (dataConName dc)) - ; checkTc (isNothing mtheta || - not hidden_data_cons || - className cls `elem` typeableClassNames) - (derivingHiddenErr tycon) - - ; dflags <- getDOpts - ; if isDataTyCon rep_tc then - mkDataTypeEqn orig dflags tvs cls cls_tys - tycon tc_args rep_tc rep_tc_args mtheta - else - mkNewTypeEqn orig dflags tvs cls cls_tys - tycon tc_args rep_tc rep_tc_args mtheta } + = mk_alg_eqn tycon tc_args | otherwise = failWithTc (derivingThingErr False cls cls_tys tc_app (ptext (sLit "The last argument of the instance must be a data or newtype application"))) + + where + bale_out msg = failWithTc (derivingThingErr False cls cls_tys tc_app msg) + + mk_alg_eqn tycon tc_args + | className cls `elem` typeableClassNames + = do { dflags <- getDOpts + ; case checkTypeableConditions (dflags, tycon) of + Just err -> bale_out err + Nothing -> mk_typeable_eqn orig tvs cls tycon tc_args mtheta } + + | isDataFamilyTyCon tycon + , length tc_args /= tyConArity tycon + = bale_out (ptext (sLit "Unsaturated data family application")) + + | otherwise + = do { (rep_tc, rep_tc_args) <- tcLookupDataFamInst tycon tc_args + -- Be careful to test rep_tc here: in the case of families, + -- we want to check the instance tycon, not the family tycon + + -- For standalone deriving (mtheta /= Nothing), + -- check that all the data constructors are in scope. + ; rdr_env <- getGlobalRdrEnv + ; let hidden_data_cons = isAbstractTyCon rep_tc || + any not_in_scope (tyConDataCons rep_tc) + not_in_scope dc = null (lookupGRE_Name rdr_env (dataConName dc)) + ; unless (isNothing mtheta || not hidden_data_cons) + (bale_out (derivingHiddenErr tycon)) + + ; dflags <- getDOpts + ; if isDataTyCon rep_tc then + mkDataTypeEqn orig dflags tvs cls cls_tys + tycon tc_args rep_tc rep_tc_args mtheta + else + mkNewTypeEqn orig dflags tvs cls cls_tys + tycon tc_args rep_tc rep_tc_args mtheta } \end{code} @@ -657,15 +750,10 @@ go_for_it = mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta bale_out msg = failWithTc (derivingThingErr False cls cls_tys (mkTyConApp tycon tc_args) msg) -mk_data_eqn, mk_typeable_eqn - :: CtOrigin -> [TyVar] -> Class - -> TyCon -> [TcType] -> TyCon -> [TcType] -> DerivContext - -> TcM EarlyDerivSpec +mk_data_eqn :: CtOrigin -> [TyVar] -> Class + -> TyCon -> [TcType] -> TyCon -> [TcType] -> DerivContext + -> TcM EarlyDerivSpec mk_data_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta - | getName cls `elem` typeableClassNames - = mk_typeable_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta - - | otherwise = do { dfun_name <- new_dfun_name cls tycon ; loc <- getSrcSpanM ; let inst_tys = [mkTyConApp tycon tc_args] @@ -680,7 +768,11 @@ ; return (if isJust mtheta then Right spec -- Specified context else Left spec) } -- Infer context -mk_typeable_eqn orig tvs cls tycon tc_args rep_tc rep_tc_args mtheta +---------------------- +mk_typeable_eqn :: CtOrigin -> [TyVar] -> Class + -> TyCon -> [TcType] -> DerivContext + -> TcM EarlyDerivSpec +mk_typeable_eqn orig tvs cls tycon tc_args mtheta -- The Typeable class is special in several ways -- data T a b = ... deriving( Typeable ) -- gives @@ -694,7 +786,7 @@ = do { checkTc (cls `hasKey` typeableClassKey) (ptext (sLit "Use deriving( Typeable ) on a data type declaration")) ; real_cls <- tcLookupClass (typeableClassNames !! tyConArity tycon) - ; mk_typeable_eqn orig tvs real_cls tycon [] rep_tc [] (Just []) } + ; mk_typeable_eqn orig tvs real_cls tycon [] (Just []) } | otherwise -- standaone deriving = do { checkTc (null tc_args) @@ -705,15 +797,20 @@ ; return (Right $ DS { ds_loc = loc, ds_orig = orig, ds_name = dfun_name, ds_tvs = [] , ds_cls = cls, ds_tys = [mkTyConApp tycon []] - , ds_tc = rep_tc, ds_tc_args = rep_tc_args + , ds_tc = tycon, ds_tc_args = [] , ds_theta = mtheta `orElse` [], ds_newtype = False }) } - +---------------------- inferConstraints :: [TyVar] -> Class -> [TcType] -> TyCon -> [TcType] -> ThetaType -- Generate a sufficiently large set of constraints that typechecking the -- generated method definitions should succeed. This set will be simplified -- before being used in the instance declaration inferConstraints _ cls inst_tys rep_tc rep_tc_args + -- Generic constraints are easy + | cls `hasKey` genClassKey + = [] + -- The others are a bit more complicated + | otherwise = ASSERT2( equalLength rep_tc_tvs all_rep_tc_args, ppr cls <+> ppr rep_tc ) stupid_constraints ++ extra_constraints ++ sc_constraints ++ con_arg_constraints @@ -794,6 +891,9 @@ where ty_args_why = quotes (ppr (mkClassPred cls cls_tys)) <+> ptext (sLit "is not a class") +checkTypeableConditions :: Condition +checkTypeableConditions = checkFlag Opt_DeriveDataTypeable `andCond` cond_typeableOK + nonStdErr :: Class -> SDoc nonStdErr cls = quotes (ppr cls) <+> ptext (sLit "is not a derivable class") @@ -814,7 +914,8 @@ cond_functorOK False) -- Functor/Fold/Trav works ok for rank-n types | cls_key == traversableClassKey = Just (checkFlag Opt_DeriveTraversable `andCond` cond_functorOK False) - | getName cls `elem` typeableClassNames = Just (checkFlag Opt_DeriveDataTypeable `andCond` cond_typeableOK) + | cls_key == genClassKey = Just (cond_RepresentableOk `andCond` + checkFlag Opt_DeriveGeneric) | otherwise = Nothing where cls_key = getUnique cls @@ -833,7 +934,7 @@ Nothing -> Nothing -- c1 succeeds Just x -> case c2 tc of -- c1 fails Nothing -> Nothing - Just y -> Just (x $$ ptext (sLit " and") $$ y) + Just y -> Just (x $$ ptext (sLit " or") $$ y) -- Both fail andCond :: Condition -> Condition -> Condition @@ -859,11 +960,14 @@ check_con con | isVanillaDataCon con , all isTauTy (dataConOrigArgTys con) = Nothing - | otherwise = Just (badCon con (ptext (sLit "does not have a Haskell-98 type"))) + | otherwise = Just (badCon con (ptext (sLit "must have a Haskell-98 type"))) no_cons_why :: TyCon -> SDoc no_cons_why rep_tc = quotes (pprSourceTyCon rep_tc) <+> - ptext (sLit "has no data constructors") + ptext (sLit "must have at least one data constructor") + +cond_RepresentableOk :: Condition +cond_RepresentableOk (_,t) = canDoGenerics t cond_enumOrProduct :: Condition cond_enumOrProduct = cond_isEnumeration `orCond` @@ -878,7 +982,7 @@ where bad_cons = [ con | con <- tyConDataCons tc , any isUnLiftedType (dataConOrigArgTys con) ] - why = badCon (head bad_cons) (ptext (sLit "has arguments of unlifted type")) + why = badCon (head bad_cons) (ptext (sLit "must have only arguments of lifted type")) cond_isEnumeration :: Condition cond_isEnumeration (_, rep_tc) @@ -886,7 +990,7 @@ | otherwise = Just why where why = sep [ quotes (pprSourceTyCon rep_tc) <+> - ptext (sLit "is not an enumeration type") + ptext (sLit "must be an enumeration type") , ptext (sLit "(an enumeration consists of one or more nullary, non-GADT constructors)") ] -- See Note [Enumeration types] in TyCon @@ -896,26 +1000,22 @@ | otherwise = Just why where why = quotes (pprSourceTyCon rep_tc) <+> - ptext (sLit "does not have precisely one constructor") + ptext (sLit "must have precisely one constructor") cond_typeableOK :: Condition -- OK for Typeable class -- Currently: (a) args all of kind * -- (b) 7 or fewer args -cond_typeableOK (_, rep_tc) - | tyConArity rep_tc > 7 = Just too_many - | not (all (isSubArgTypeKind . tyVarKind) (tyConTyVars rep_tc)) - = Just bad_kind - | isFamInstTyCon rep_tc = Just fam_inst -- no Typable for family insts - | otherwise = Nothing - where - too_many = quotes (pprSourceTyCon rep_tc) <+> - ptext (sLit "has too many arguments") - bad_kind = quotes (pprSourceTyCon rep_tc) <+> - ptext (sLit "has arguments of kind other than `*'") - fam_inst = quotes (pprSourceTyCon rep_tc) <+> - ptext (sLit "is a type family") - +cond_typeableOK (_, tc) + | tyConArity tc > 7 = Just too_many + | not (all (isSubArgTypeKind . tyVarKind) (tyConTyVars tc)) + = Just bad_kind + | otherwise = Nothing + where + too_many = quotes (pprSourceTyCon tc) <+> + ptext (sLit "must have 7 or fewer arguments") + bad_kind = quotes (pprSourceTyCon tc) <+> + ptext (sLit "must only have arguments of kind `*'") functorLikeClassKeys :: [Unique] functorLikeClassKeys = [functorClassKey, foldableClassKey, traversableClassKey] @@ -930,11 +1030,11 @@ cond_functorOK allowFunctions (_, rep_tc) | null tc_tvs = Just (ptext (sLit "Data type") <+> quotes (ppr rep_tc) - <+> ptext (sLit "has no parameters")) + <+> ptext (sLit "must have some type parameters")) | not (null bad_stupid_theta) = Just (ptext (sLit "Data type") <+> quotes (ppr rep_tc) - <+> ptext (sLit "has a class context") <+> pprTheta bad_stupid_theta) + <+> ptext (sLit "must not have a class context") <+> pprTheta bad_stupid_theta) | otherwise = msum (map check_con data_cons) -- msum picks the first 'Just', if any @@ -961,10 +1061,10 @@ , ft_bad_app = Just (badCon con wrong_arg) , ft_forall = \_ x -> x } - existential = ptext (sLit "has existential arguments") - covariant = ptext (sLit "uses the type variable in a function argument") - functions = ptext (sLit "contains function types") - wrong_arg = ptext (sLit "uses the type variable in an argument other than the last") + existential = ptext (sLit "must not have existential arguments") + covariant = ptext (sLit "must not use the type variable in a function argument") + functions = ptext (sLit "must not contain function types") + wrong_arg = ptext (sLit "must not use the type variable in an argument other than the last") checkFlag :: ExtensionFlag -> Condition checkFlag flag (dflags, _) @@ -973,7 +1073,7 @@ where why = ptext (sLit "You need -X") <> text flag_str <+> ptext (sLit "to derive an instance for this class") - flag_str = case [ s | (s, f, _) <- xFlags, f==flag ] of + flag_str = case [ s | (s, _, f, _) <- xFlags, f==flag ] of [s] -> s other -> pprPanic "checkFlag" (ppr other) @@ -988,11 +1088,11 @@ non_iso_class :: Class -> Bool --- *Never* derive Read,Show,Typeable,Data by isomorphism, +-- *Never* derive Read, Show, Typeable, Data, Generic by isomorphism, -- even with -XGeneralizedNewtypeDeriving non_iso_class cls - = classKey cls `elem` ([readClassKey, showClassKey, dataClassKey] ++ - typeableClassKeys) + = classKey cls `elem` ([ readClassKey, showClassKey, dataClassKey + , genClassKey] ++ typeableClassKeys) typeableClassKeys :: [Unique] typeableClassKeys = map getUnique typeableClassNames @@ -1271,7 +1371,7 @@ gen_soln (DS { ds_loc = loc, ds_orig = orig, ds_tvs = tyvars , ds_cls = clas, ds_tys = inst_tys, ds_theta = deriv_rhs }) = setSrcSpan loc $ - addErrCtxt (derivInstCtxt clas inst_tys) $ + addErrCtxt (derivInstCtxt the_pred) $ do { -- Check for a bizarre corner case, when the derived instance decl should -- have form instance C a b => D (T a) where ... -- Note that 'b' isn't a parameter of T. This gives rise to all sorts @@ -1283,10 +1383,10 @@ ; let tv_set = mkVarSet tyvars weird_preds = [pred | pred <- deriv_rhs - , not (tyVarsOfPred pred `subVarSet` tv_set)] + , not (tyVarsOfPred pred `subVarSet` tv_set)] ; mapM_ (addErrTc . badDerivedPred) weird_preds - ; theta <- simplifyDeriv orig tyvars deriv_rhs + ; theta <- simplifyDeriv orig the_pred tyvars deriv_rhs -- checkValidInstance tyvars theta clas inst_tys -- Not necessary; see Note [Exotic derived instance contexts] -- in TcSimplify @@ -1296,6 +1396,8 @@ -- Hence no need to call: -- checkValidInstance tyvars theta clas inst_tys ; return (sortLe (<=) theta) } -- Canonicalise before returning the solution + where + the_pred = mkClassPred clas inst_tys ------------------------------------------------------------------ mkInstance :: OverlapFlag -> ThetaType -> DerivSpec -> Instance @@ -1388,8 +1490,8 @@ -- Representation tycons differ from the tycon in the instance signature in -- case of instances for indexed families. -- -genInst :: Bool -- True <=> standalone deriving - -> OverlapFlag +genInst :: Bool -- True <=> standalone deriving + -> OverlapFlag -> DerivSpec -> TcM (InstInfo RdrName, DerivAuxBinds) genInst standalone_deriv oflag spec@(DS { ds_tc = rep_tycon, ds_tc_args = rep_tc_args @@ -1412,14 +1514,12 @@ where inst_spec = mkInstance oflag theta spec co1 = case tyConFamilyCoercion_maybe rep_tycon of - Just co_con -> ACo (mkTyConApp co_con rep_tc_args) + Just co_con -> mkAxInstCo co_con rep_tc_args Nothing -> id_co -- Not a family => rep_tycon = main tycon - co2 = case newTyConCo_maybe rep_tycon of - Just co_con -> ACo (mkTyConApp co_con rep_tc_args) - Nothing -> id_co -- The newtype is transparent; no need for a cast - co = co1 `mkTransCoI` co2 - id_co = IdCo (mkTyConApp rep_tycon rep_tc_args) + co2 = mkAxInstCo (newTyConCo rep_tycon) rep_tc_args + co = co1 `mkTransCo` co2 + id_co = mkReflCo (mkTyConApp rep_tycon rep_tc_args) -- Example: newtype instance N [a] = N1 (Tree a) -- deriving instance Eq b => Eq (N [(b,b)]) @@ -1440,20 +1540,162 @@ Nothing -> pprPanic "genDerivBinds: bad derived class" (ppr clas) where gen_list :: [(Unique, SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds))] - gen_list = [(eqClassKey, gen_Eq_binds) - ,(ordClassKey, gen_Ord_binds) - ,(enumClassKey, gen_Enum_binds) - ,(boundedClassKey, gen_Bounded_binds) - ,(ixClassKey, gen_Ix_binds) - ,(showClassKey, gen_Show_binds fix_env) - ,(readClassKey, gen_Read_binds fix_env) - ,(dataClassKey, gen_Data_binds) - ,(functorClassKey, gen_Functor_binds) - ,(foldableClassKey, gen_Foldable_binds) - ,(traversableClassKey, gen_Traversable_binds) + gen_list = [(eqClassKey, gen_Eq_binds) + ,(ordClassKey, gen_Ord_binds) + ,(enumClassKey, gen_Enum_binds) + ,(boundedClassKey, gen_Bounded_binds) + ,(ixClassKey, gen_Ix_binds) + ,(showClassKey, gen_Show_binds fix_env) + ,(readClassKey, gen_Read_binds fix_env) + ,(dataClassKey, gen_Data_binds) + ,(functorClassKey, gen_Functor_binds) + ,(foldableClassKey, gen_Foldable_binds) + ,(traversableClassKey, gen_Traversable_binds) + ,(genClassKey, genGenericBinds) ] \end{code} +%************************************************************************ +%* * +\subsection[TcDeriv-generic-binds]{Bindings for the new generic deriving mechanism} +%* * +%************************************************************************ + +For the generic representation we need to generate: +\begin{itemize} +\item A Generic instance +\item A Rep type instance +\item Many auxiliary datatypes and instances for them (for the meta-information) +\end{itemize} + +@genGenericBinds@ does (1) +@genGenericRepExtras@ does (2) and (3) +@genGenericAll@ does all of them + +\begin{code} +genGenericBinds :: SrcSpan -> TyCon -> (LHsBinds RdrName, DerivAuxBinds) +genGenericBinds _ tc = (mkBindsRep tc, [ {- No DerivAuxBinds -} ]) + +genGenericRepExtras :: TyCon -> TcM (MetaTyCons, TyCon) +genGenericRepExtras tc = + do uniqS <- newUniqueSupply + let + -- Uniques for everyone + (uniqD:uniqs) = uniqsFromSupply uniqS + (uniqsC,us) = splitAt (length tc_cons) uniqs + uniqsS :: [[Unique]] -- Unique supply for the S datatypes + uniqsS = mkUniqsS tc_arits us + mkUniqsS [] _ = [] + mkUniqsS (n:t) us = case splitAt n us of + (us1,us2) -> us1 : mkUniqsS t us2 + + tc_name = tyConName tc + tc_cons = tyConDataCons tc + tc_arits = map dataConSourceArity tc_cons + + tc_occ = nameOccName tc_name + d_occ = mkGenD tc_occ + c_occ m = mkGenC tc_occ m + s_occ m n = mkGenS tc_occ m n + mod_name = nameModule (tyConName tc) + d_name = mkExternalName uniqD mod_name d_occ wiredInSrcSpan + c_names = [ mkExternalName u mod_name (c_occ m) wiredInSrcSpan + | (u,m) <- zip uniqsC [0..] ] + s_names = [ [ mkExternalName u mod_name (s_occ m n) wiredInSrcSpan + | (u,n) <- zip us [0..] ] | (us,m) <- zip uniqsS [0..] ] + + mkTyCon name = ASSERT( isExternalName name ) + buildAlgTyCon name [] [] mkAbstractTyConRhs + NonRecursive False NoParentTyCon Nothing + + metaDTyCon <- mkTyCon d_name + metaCTyCons <- sequence [ mkTyCon c_name | c_name <- c_names ] + metaSTyCons <- mapM sequence + [ [ mkTyCon s_name + | s_name <- s_namesC ] | s_namesC <- s_names ] + + let metaDts = MetaTyCons metaDTyCon metaCTyCons metaSTyCons + + rep0_tycon <- tc_mkRepTyCon tc metaDts + + -- pprTrace "rep0" (ppr rep0_tycon) $ + return (metaDts, rep0_tycon) +{- +genGenericAll :: TyCon + -> TcM ((InstInfo RdrName, DerivAuxBinds), MetaTyCons, TyCon) +genGenericAll tc = + do (metaDts, rep0_tycon) <- genGenericRepExtras tc + clas <- tcLookupClass genClassName + dfun_name <- new_dfun_name clas tc + let + mkInstRep = (InstInfo { iSpec = inst, iBinds = binds } + , [ {- No DerivAuxBinds -} ]) + inst = mkLocalInstance dfun NoOverlap + binds = VanillaInst (mkBindsRep tc) [] False + + tvs = tyConTyVars tc + tc_ty = mkTyConApp tc (mkTyVarTys tvs) + + dfun = mkDictFunId dfun_name (tyConTyVars tc) [] clas [tc_ty] + return (mkInstRep, metaDts, rep0_tycon) +-} +genDtMeta :: (TyCon, MetaTyCons) -> TcM [(InstInfo RdrName, DerivAuxBinds)] +genDtMeta (tc,metaDts) = + do dflags <- getDOpts + dClas <- tcLookupClass datatypeClassName + d_dfun_name <- new_dfun_name dClas tc + cClas <- tcLookupClass constructorClassName + c_dfun_names <- sequence [ new_dfun_name cClas tc | _ <- metaC metaDts ] + sClas <- tcLookupClass selectorClassName + s_dfun_names <- sequence (map sequence [ [ new_dfun_name sClas tc + | _ <- x ] + | x <- metaS metaDts ]) + fix_env <- getFixityEnv + + let + safeOverlap = safeLanguageOn dflags + (dBinds,cBinds,sBinds) = mkBindsMetaD fix_env tc + + -- Datatype + d_metaTycon = metaD metaDts + d_inst = mkLocalInstance d_dfun $ NoOverlap safeOverlap + d_binds = VanillaInst dBinds [] False + d_dfun = mkDictFunId d_dfun_name (tyConTyVars tc) [] dClas + [ mkTyConTy d_metaTycon ] + d_mkInst = (InstInfo { iSpec = d_inst, iBinds = d_binds }, []) + + -- Constructor + c_metaTycons = metaC metaDts + c_insts = [ mkLocalInstance (c_dfun c ds) $ NoOverlap safeOverlap + | (c, ds) <- myZip1 c_metaTycons c_dfun_names ] + c_binds = [ VanillaInst c [] False | c <- cBinds ] + c_dfun c dfun_name = mkDictFunId dfun_name (tyConTyVars tc) [] cClas + [ mkTyConTy c ] + c_mkInst = [ (InstInfo { iSpec = is, iBinds = bs }, []) + | (is,bs) <- myZip1 c_insts c_binds ] + + -- Selector + s_metaTycons = metaS metaDts + s_insts = map (map (\(s,ds) -> mkLocalInstance (s_dfun s ds) $ + NoOverlap safeOverlap)) + (myZip2 s_metaTycons s_dfun_names) + s_binds = [ [ VanillaInst s [] False | s <- ss ] | ss <- sBinds ] + s_dfun s dfun_name = mkDictFunId dfun_name (tyConTyVars tc) [] sClas + [ mkTyConTy s ] + s_mkInst = map (map (\(is,bs) -> (InstInfo {iSpec=is, iBinds=bs}, []))) + (myZip2 s_insts s_binds) + + myZip1 :: [a] -> [b] -> [(a,b)] + myZip1 l1 l2 = ASSERT (length l1 == length l2) zip l1 l2 + + myZip2 :: [[a]] -> [[b]] -> [[(a,b)]] + myZip2 l1 l2 = + ASSERT (and (zipWith (>=) (map length l1) (map length l2))) + [ zip x1 x2 | (x1,x2) <- zip l1 l2 ] + + return (d_mkInst : c_mkInst ++ concat s_mkInst) +\end{code} + %************************************************************************ %* * @@ -1500,9 +1742,9 @@ standaloneCtxt ty = hang (ptext (sLit "In the stand-alone deriving instance for")) 2 (quotes (ppr ty)) -derivInstCtxt :: Class -> [Type] -> Message -derivInstCtxt clas inst_tys - = ptext (sLit "When deriving the instance for") <+> parens (pprClassPred clas inst_tys) +derivInstCtxt :: PredType -> Message +derivInstCtxt pred + = ptext (sLit "When deriving the instance for") <+> parens (ppr pred) badDerivedPred :: PredType -> Message badDerivedPred pred diff -Nru ghc-7.0.3/compiler/typecheck/TcEnv.lhs ghc-7.2.1/compiler/typecheck/TcEnv.lhs --- ghc-7.0.3/compiler/typecheck/TcEnv.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/typecheck/TcEnv.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -211,7 +211,7 @@ } tcLookupDataFamInst :: TyCon -> [Type] -> TcM (TyCon, [Type]) --- Find the instance of a data famliy +-- Find the instance of a data family -- Note [Looking up family instances for deriving] tcLookupDataFamInst tycon tys | not (isFamilyTyCon tycon) @@ -461,7 +461,7 @@ \begin{code} tcExtendRules :: [LRuleDecl Id] -> TcM a -> TcM a -- Just pop the new rules into the EPS and envt resp - -- All the rules come from an interface file, not soruce + -- All the rules come from an interface file, not source -- Nevertheless, some may be for this module, if we read -- its interface instead of its source code tcExtendRules lcl_rules thing_inside @@ -626,7 +626,7 @@ -- witness dictionary is identical to the argument -- dictionary. Hence no bindings, no pragmas. - CoercionI -- The coercion maps from newtype to the representation type + Coercion -- The coercion maps from newtype to the representation type -- (mentioning type variables bound by the forall'd iSpec variables) -- E.g. newtype instance N [a] = N1 (Tree a) -- co : N [a] ~ Tree a @@ -640,7 +640,7 @@ pprInstInfo :: InstInfo a -> SDoc pprInstInfo info = hang (ptext (sLit "instance")) 2 (sep [ ifPprDebug (pprForAll tvs) - , pprThetaArrow theta, ppr tau + , pprThetaArrowTy theta, ppr tau , ptext (sLit "where")]) where (tvs, theta, tau) = tcSplitSigmaTy (idType (iDFunId info)) @@ -681,7 +681,7 @@ \end{code} Make a name for the representation tycon of a family instance. It's an -*external* name, like otber top-level names, and hence must be made with +*external* name, like other top-level names, and hence must be made with newGlobalBinder. \begin{code} diff -Nru ghc-7.0.3/compiler/typecheck/TcErrors.lhs ghc-7.2.1/compiler/typecheck/TcErrors.lhs --- ghc-7.0.3/compiler/typecheck/TcErrors.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/typecheck/TcErrors.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -15,25 +15,25 @@ import TcSMonad import TcType import TypeRep - +import Type( isTyVarTy ) +import Unify ( tcMatchTys ) import Inst import InstEnv - import TyCon import Name import NameEnv -import Id ( idType ) +import Id ( idType, evVarPred ) import Var import VarSet import VarEnv import SrcLoc import Bag import ListSetOps( equivClasses ) +import Maybes( mapCatMaybes ) import Util import FastString import Outputable import DynFlags -import StaticFlags( opt_PprStyle_Debug ) import Data.List( partition ) import Control.Monad( when, unless ) \end{code} @@ -105,7 +105,7 @@ -- because they are unconditionally wrong -- Moreover, if any of the insolubles are givens, stop right there -- ignoring nested errors, because the code is inaccessible - = do { let (given, other) = partitionBag (isGiven . evVarX) insols + = do { let (given, other) = partitionBag (isGivenOrSolved . evVarX) insols insol_implics = filterBag ic_insol implics ; if isEmptyBag given then do { mapBagM_ (reportInsoluble ctxt) other @@ -153,7 +153,8 @@ | otherwise = pprPanic "reportInsoluble" (pprEvVarWithType ev) where - inaccessible_msg | Given loc <- flav + inaccessible_msg | Given loc GivenOrig <- flav + -- If a GivenSolved then we should not report inaccessible code = hang (ptext (sLit "Inaccessible code in")) 2 (ppr (ctLocOrigin loc)) | otherwise = empty @@ -222,7 +223,7 @@ where first_loc = evVarX (head ev_vars) ppr_one (EvVarX v loc) - = parens (pprPred (evVarPred v)) <+> pprArisingAt loc + = parens (pprPredTy (evVarPred v)) <+> pprArisingAt loc addErrorReport :: ReportErrCtxt -> SDoc -> TcM () addErrorReport ctxt msg = addErrTcM (cec_tidy ctxt, msg $$ cec_extra ctxt) @@ -241,15 +242,8 @@ -- One item for each enclosing implication getUserGivens (CEC {cec_encl = ctxt}) = reverse $ - [ (givens', loc) | Implic {ic_given = givens, ic_loc = loc} <- ctxt - , let givens' = get_user_givens givens - , not (null givens') ] - where - get_user_givens givens | opt_PprStyle_Debug = givens - | otherwise = filterOut isSilentEvVar givens - -- In user mode, don't show the "silent" givens, used for - -- the "self" dictionary and silent superclass arguments for dfuns - + [ (givens, loc) | Implic {ic_given = givens, ic_loc = loc} <- ctxt + , not (null givens) ] \end{code} @@ -299,8 +293,8 @@ ty1 ty2 -- If the types in the error message are the same as the types we are unifying, -- don't add the extra expected/actual message - | act `tcEqType` ty1 && exp `tcEqType` ty2 = empty - | exp `tcEqType` ty1 && act `tcEqType` ty2 = empty + | act `eqType` ty1 && exp `eqType` ty2 = empty + | exp `eqType` ty1 && act `eqType` ty2 = empty | otherwise = mkExpectedActualMsg act exp getWantedEqExtra orig _ _ = pprArising orig @@ -320,15 +314,10 @@ reportTyVarEqErr :: ReportErrCtxt -> TcTyVar -> TcType -> TcM () -- tv1 and ty2 are already tidied reportTyVarEqErr ctxt tv1 ty2 - | not is_meta1 - , Just tv2 <- tcGetTyVar_maybe ty2 - , isMetaTyVar tv2 - = -- sk ~ alpha: swap - reportTyVarEqErr ctxt tv2 ty1 - - | (not is_meta1) - = -- sk ~ ty, where ty isn't a meta-tyvar: mis-match - addErrorReport (addExtraInfo ctxt ty1 ty2) + | isSkolemTyVar tv1 -- ty2 won't be a meta-tyvar, or else the thing would + -- be oriented the other way round; see TcCanonical.reOrient + || isSigTyVar tv1 && not (isTyVarTy ty2) + = addErrorReport (addExtraInfo ctxt ty1 ty2) (misMatchOrCND ctxt ty1 ty2) -- So tv is a meta tyvar, and presumably it is @@ -376,21 +365,26 @@ , ptext (sLit "bound at") <+> ppr (ctLocOrigin implic_loc)] ; addErrorReport (addExtraInfo ctxt ty1 ty2) (msg $$ nest 2 extra) } - | otherwise -- This can happen, by a recursive decomposition of frozen - -- occurs check constraints - -- Example: alpha ~ T Int alpha has frozen. - -- Then alpha gets unified to T beta gamma - -- So now we have T beta gamma ~ T Int (T beta gamma) - -- Decompose to (beta ~ Int, gamma ~ T beta gamma) - -- The (gamma ~ T beta gamma) is the occurs check, but - -- the (beta ~ Int) isn't an error at all. So return () - = return () - + | otherwise + = pprTrace "reportTyVarEqErr" (ppr tv1 $$ ppr ty2 $$ ppr (cec_encl ctxt)) $ + return () + -- I don't think this should happen, and if it does I want to know + -- Trac #5130 happened because an actual type error was not + -- reported at all! So not reporting is pretty dangerous. + -- + -- OLD, OUT OF DATE COMMENT + -- This can happen, by a recursive decomposition of frozen + -- occurs check constraints + -- Example: alpha ~ T Int alpha has frozen. + -- Then alpha gets unified to T beta gamma + -- So now we have T beta gamma ~ T Int (T beta gamma) + -- Decompose to (beta ~ Int, gamma ~ T beta gamma) + -- The (gamma ~ T beta gamma) is the occurs check, but + -- the (beta ~ Int) isn't an error at all. So return () where - is_meta1 = isMetaTyVar tv1 - k1 = tyVarKind tv1 - k2 = typeKind ty2 - ty1 = mkTyVarTy tv1 + k1 = tyVarKind tv1 + k2 = typeKind ty2 + ty1 = mkTyVarTy tv1 mkTyFunInfoMsg :: TcType -> TcType -> SDoc -- See Note [Non-injective type functions] @@ -419,18 +413,18 @@ couldNotDeduce givens (wanteds, orig) = vcat [ hang (ptext (sLit "Could not deduce") <+> pprTheta wanteds) 2 (pprArising orig) - , vcat pp_givens ] - where - pp_givens - = case givens of + , vcat (pp_givens givens)] + +pp_givens :: [([EvVar], GivenLoc)] -> [SDoc] +pp_givens givens + = case givens of [] -> [] (g:gs) -> ppr_given (ptext (sLit "from the context")) g : map (ppr_given (ptext (sLit "or from"))) gs - - ppr_given herald (gs,loc) - = hang (herald <+> pprEvVarTheta gs) - 2 (sep [ ptext (sLit "bound by") <+> ppr (ctLocOrigin loc) - , ptext (sLit "at") <+> ppr (ctLocSpan loc)]) + where ppr_given herald (gs,loc) + = hang (herald <+> pprEvVarTheta gs) + 2 (sep [ ptext (sLit "bound by") <+> ppr (ctLocOrigin loc) + , ptext (sLit "at") <+> ppr (ctLocSpan loc)]) addExtraInfo :: ReportErrCtxt -> TcType -> TcType -> ReportErrCtxt -- Add on extra info about the types themselves @@ -458,12 +452,22 @@ -- Shows a bit of extra info about skolem constants typeExtraInfoMsg implics ty | Just tv <- tcGetTyVar_maybe ty - , isTcTyVar tv - , isSkolemTyVar tv - = pprSkolTvBinding implics tv - where -typeExtraInfoMsg _ _ = empty -- Normal case - + , isTcTyVar tv, isSkolemTyVar tv + , let pp_tv = quotes (ppr tv) + = case tcTyVarDetails tv of + SkolemTv {} -> pp_tv <+> ppr_skol (getSkolemInfo implics tv) (getSrcLoc tv) + FlatSkol {} -> pp_tv <+> ptext (sLit "is a flattening type variable") + RuntimeUnk {} -> pp_tv <+> ptext (sLit "is an interactive-debugger skolem") + MetaTv {} -> empty + + | otherwise -- Normal case + = empty + + where + ppr_skol UnkSkol _ = ptext (sLit "is an unknown type variable") -- Unhelpful + ppr_skol info loc = sep [ptext (sLit "is a rigid type variable bound by"), + sep [ppr info, ptext (sLit "at") <+> ppr loc]] + -------------------- unifyCtxt :: EqOrigin -> TidyEnv -> TcM (TidyEnv, SDoc) unifyCtxt (UnifyOrigin { uo_actual = act_ty, uo_expected = exp_ty }) tidy_env @@ -551,32 +555,82 @@ -- Note [Flattening in error message generation] ; case lookupInstEnv inst_envs clas tys_flat of - ([], _) -> return (Just pred) -- No match - -- The case of exactly one match and no unifiers means a - -- successful lookup. That can't happen here, because dicts - -- only end up here if they didn't match in Inst.lookupInst - ([_],[]) - | debugIsOn -> pprPanic "check_overlap" (ppr pred) - res -> do { addErrorReport ctxt (mk_overlap_msg res) - ; return Nothing } } + ([], _, _) -> return (Just pred) -- No match + res -> do { addErrorReport ctxt (mk_overlap_msg res) + ; return Nothing } } where - mk_overlap_msg (matches, unifiers) + -- Normal overlap error + mk_overlap_msg (matches, unifiers, False) = ASSERT( not (null matches) ) vcat [ addArising orig (ptext (sLit "Overlapping instances for") - <+> pprPred pred) + <+> pprPredTy pred) , sep [ptext (sLit "Matching instances") <> colon, nest 2 (vcat [pprInstances ispecs, pprInstances unifiers])] + + , if not (null matching_givens) then + sep [ptext (sLit "Matching givens (or their superclasses)") <> colon + , nest 2 (vcat matching_givens)] + else empty + + , if null matching_givens && isSingleton matches && null unifiers then + -- Intuitively, some given matched the wanted in their + -- flattened or rewritten (from given equalities) form + -- but the matcher can't figure that out because the + -- constraints are non-flat and non-rewritten so we + -- simply report back the whole given + -- context. Accelerate Smart.hs showed this problem. + sep [ ptext (sLit "There exists a (perhaps superclass) match") <> colon + , nest 2 (vcat (pp_givens givens))] + else empty + , if not (isSingleton matches) then -- Two or more matches empty - else -- One match, plus some unifiers - ASSERT( not (null unifiers) ) + else -- One match parens (vcat [ptext (sLit "The choice depends on the instantiation of") <+> quotes (pprWithCommas ppr (varSetElems (tyVarsOfPred pred))), - ptext (sLit "To pick the first instance above, use -XIncoherentInstances"), - ptext (sLit "when compiling the other instance declarations")])] - where - ispecs = [ispec | (ispec, _) <- matches] + if null (matching_givens) then + vcat [ ptext (sLit "To pick the first instance above, use -XIncoherentInstances"), + ptext (sLit "when compiling the other instance declarations")] + else empty])] + where + ispecs = [ispec | (ispec, _) <- matches] + + givens = getUserGivens ctxt + matching_givens = mapCatMaybes matchable givens + + matchable (evvars,gloc) + = case ev_vars_matching of + [] -> Nothing + _ -> Just $ hang (pprTheta ev_vars_matching) + 2 (sep [ ptext (sLit "bound by") <+> ppr (ctLocOrigin gloc) + , ptext (sLit "at") <+> ppr (ctLocSpan gloc)]) + where ev_vars_matching = filter ev_var_matches (map evVarPred evvars) + ev_var_matches (ClassP clas' tys') + | clas' == clas + , Just _ <- tcMatchTys (tyVarsOfTypes tys) tys tys' + = True + ev_var_matches (ClassP clas' tys') = + any ev_var_matches (immSuperClasses clas' tys') + ev_var_matches _ = False + + -- Overlap error because of Safe Haskell (first match should be the most + -- specific match) + mk_overlap_msg (matches, _unifiers, True) + = ASSERT( length matches > 1 ) + vcat [ addArising orig (ptext (sLit "Unsafe overlapping instances for") + <+> pprPredTy pred) + , sep [ptext (sLit "The matching instance is") <> colon, + nest 2 (pprInstance $ head ispecs)] + , vcat [ ptext $ sLit "It is compiled in a Safe module and as such can only" + , ptext $ sLit "overlap instances from the same module, however it" + , ptext $ sLit "overlaps the following instances from different modules:" + , nest 2 (vcat [pprInstances $ tail ispecs]) + ] + ] + where + ispecs = [ispec | (ispec, _) <- matches] + reportOverlap _ _ _ _ = panic "reportOverlap" -- Not a ClassP @@ -659,7 +713,6 @@ -- ASSUMPTION: the Insts are fully zonked mkMonomorphismMsg ctxt inst_tvs = do { dflags <- getDOpts - ; traceTc "Mono" (vcat (map (pprSkolTvBinding (cec_encl ctxt)) inst_tvs)) ; (tidy_env, docs) <- findGlobals ctxt (mkVarSet inst_tvs) ; return (tidy_env, mk_msg dflags docs) } where @@ -685,28 +738,6 @@ else empty] -- Only suggest adding "-XNoMonomorphismRestriction" -- if it is not already set! - -pprSkolTvBinding :: [Implication] -> TcTyVar -> SDoc --- Print info about the binding of a skolem tyvar, --- or nothing if we don't have anything useful to say -pprSkolTvBinding implics tv - | isTcTyVar tv = quotes (ppr tv) <+> ppr_details (tcTyVarDetails tv) - | otherwise = quotes (ppr tv) <+> ppr_skol (getSkolemInfo implics tv) - where - ppr_details (SkolemTv {}) = ppr_skol (getSkolemInfo implics tv) - ppr_details (FlatSkol {}) = ptext (sLit "is a flattening type variable") - ppr_details (RuntimeUnk {}) = ptext (sLit "is an interactive-debugger skolem") - ppr_details (MetaTv (SigTv n) _) = ptext (sLit "is bound by the type signature for") - <+> quotes (ppr n) - ppr_details (MetaTv _ _) = ptext (sLit "is a meta type variable") - - - ppr_skol UnkSkol = ptext (sLit "is an unknown type variable") -- Unhelpful - ppr_skol RuntimeUnkSkol = ptext (sLit "is an unknown runtime type") - ppr_skol info = sep [ptext (sLit "is a rigid type variable bound by"), - sep [ppr info, - ptext (sLit "at") <+> ppr (getSrcLoc tv)]] - getSkolemInfo :: [Implication] -> TcTyVar -> SkolemInfo getSkolemInfo [] tv = WARN( True, ptext (sLit "No skolem info:") <+> ppr tv ) @@ -780,7 +811,7 @@ warnDefaulting :: [FlavoredEvVar] -> Type -> TcM () warnDefaulting wanteds default_ty - = do { warn_default <- doptM Opt_WarnTypeDefaults + = do { warn_default <- woptM Opt_WarnTypeDefaults ; env0 <- tcInitTidyEnv ; let wanted_bag = listToBag wanteds tidy_env = tidyFreeTyVars env0 $ @@ -846,9 +877,9 @@ \begin{code} setCtFlavorLoc :: CtFlavor -> TcM a -> TcM a -setCtFlavorLoc (Wanted loc) thing = setCtLoc loc thing -setCtFlavorLoc (Derived loc) thing = setCtLoc loc thing -setCtFlavorLoc (Given loc) thing = setCtLoc loc thing +setCtFlavorLoc (Wanted loc) thing = setCtLoc loc thing +setCtFlavorLoc (Derived loc) thing = setCtLoc loc thing +setCtFlavorLoc (Given loc _gk) thing = setCtLoc loc thing \end{code} %************************************************************************ diff -Nru ghc-7.0.3/compiler/typecheck/TcExpr.lhs ghc-7.2.1/compiler/typecheck/TcExpr.lhs --- ghc-7.0.3/compiler/typecheck/TcExpr.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/typecheck/TcExpr.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -45,15 +45,18 @@ import Coercion import Var import VarSet +import VarEnv import TysWiredIn import TysPrim( intPrimTy ) import PrimOp( tagToEnumKey ) import PrelNames +import Module import DynFlags import SrcLoc import Util import ListSetOps import Maybes +import ErrUtils import Outputable import FastString import Control.Monad @@ -285,8 +288,8 @@ ; co_res <- unifyType op_res_ty res_ty ; op_id <- tcLookupId op_name ; let op' = L loc (HsWrap (mkWpTyApps [arg2_ty, op_res_ty]) (HsVar op_id)) - ; return $ mkHsWrapCoI co_res $ - OpApp (mkLHsWrapCoI co_arg1 arg1') op' fix arg2' } + ; return $ mkHsWrapCo co_res $ + OpApp (mkLHsWrapCo co_arg1 arg1') op' fix arg2' } | otherwise = do { traceTc "Non Application rule" (ppr op) @@ -294,8 +297,8 @@ ; (co_fn, arg_tys, op_res_ty) <- unifyOpFunTys op 2 op_ty ; co_res <- unifyType op_res_ty res_ty ; [arg1', arg2'] <- tcArgs op [arg1, arg2] arg_tys - ; return $ mkHsWrapCoI co_res $ - OpApp arg1' (mkLHsWrapCoI co_fn op') fix arg2' } + ; return $ mkHsWrapCo co_res $ + OpApp arg1' (mkLHsWrapCo co_fn op') fix arg2' } -- Right sections, equivalent to \ x -> x `op` expr, or -- \ x -> op x expr @@ -305,8 +308,8 @@ ; (co_fn, [arg1_ty, arg2_ty], op_res_ty) <- unifyOpFunTys op 2 op_ty ; co_res <- unifyType (mkFunTy arg1_ty op_res_ty) res_ty ; arg2' <- tcArg op (arg2, arg2_ty, 2) - ; return $ mkHsWrapCoI co_res $ - SectionR (mkLHsWrapCoI co_fn op') arg2' } + ; return $ mkHsWrapCo co_res $ + SectionR (mkLHsWrapCo co_fn op') arg2' } tcExpr (SectionL arg1 op) res_ty = do { (op', op_ty) <- tcInferFun op @@ -317,15 +320,15 @@ ; (co_fn, (arg1_ty:arg_tys), op_res_ty) <- unifyOpFunTys op n_reqd_args op_ty ; co_res <- unifyType (mkFunTys arg_tys op_res_ty) res_ty ; arg1' <- tcArg op (arg1, arg1_ty, 1) - ; return $ mkHsWrapCoI co_res $ - SectionL arg1' (mkLHsWrapCoI co_fn op') } + ; return $ mkHsWrapCo co_res $ + SectionL arg1' (mkLHsWrapCo co_fn op') } tcExpr (ExplicitTuple tup_args boxity) res_ty | all tupArgPresent tup_args = do { let tup_tc = tupleTyCon boxity (length tup_args) ; (coi, arg_tys) <- matchExpectedTyConApp tup_tc res_ty ; tup_args1 <- tcTupArgs tup_args arg_tys - ; return $ mkHsWrapCoI coi (ExplicitTuple tup_args1 boxity) } + ; return $ mkHsWrapCo coi (ExplicitTuple tup_args1 boxity) } | otherwise = -- The tup_args are a mixture of Present and Missing (for tuple sections) @@ -344,19 +347,19 @@ -- Handle tuple sections where ; tup_args1 <- tcTupArgs tup_args arg_tys - ; return $ mkHsWrapCoI coi (ExplicitTuple tup_args1 boxity) } + ; return $ mkHsWrapCo coi (ExplicitTuple tup_args1 boxity) } tcExpr (ExplicitList _ exprs) res_ty = do { (coi, elt_ty) <- matchExpectedListTy res_ty ; exprs' <- mapM (tc_elt elt_ty) exprs - ; return $ mkHsWrapCoI coi (ExplicitList elt_ty exprs') } + ; return $ mkHsWrapCo coi (ExplicitList elt_ty exprs') } where tc_elt elt_ty expr = tcPolyExpr expr elt_ty tcExpr (ExplicitPArr _ exprs) res_ty -- maybe empty = do { (coi, elt_ty) <- matchExpectedPArrTy res_ty ; exprs' <- mapM (tc_elt elt_ty) exprs - ; return $ mkHsWrapCoI coi (ExplicitPArr elt_ty exprs') } + ; return $ mkHsWrapCo coi (ExplicitPArr elt_ty exprs') } where tc_elt elt_ty expr = tcPolyExpr expr elt_ty \end{code} @@ -398,22 +401,28 @@ ; b2' <- tcMonoExpr b2 res_ty ; return (HsIf Nothing pred' b1' b2') } -tcExpr (HsIf (Just fun) pred b1 b2) res_ty -- Rebindable syntax +tcExpr (HsIf (Just fun) pred b1 b2) res_ty -- Note [Rebindable syntax for if] = do { pred_ty <- newFlexiTyVarTy openTypeKind - ; b_ty <- newFlexiTyVarTy openTypeKind - ; let if_ty = mkFunTys [pred_ty, b_ty, b_ty] res_ty - ; fun' <- tcSyntaxOp IfOrigin fun if_ty + ; b1_ty <- newFlexiTyVarTy openTypeKind + ; b2_ty <- newFlexiTyVarTy openTypeKind + ; let if_ty = mkFunTys [pred_ty, b1_ty, b2_ty] res_ty + ; fun' <- tcSyntaxOp IfOrigin fun if_ty ; pred' <- tcMonoExpr pred pred_ty - ; b1' <- tcMonoExpr b1 b_ty - ; b2' <- tcMonoExpr b2 b_ty + ; b1' <- tcMonoExpr b1 b1_ty + ; b2' <- tcMonoExpr b2 b2_ty + -- Fundamentally we are just typing (ifThenElse e1 e2 e3) + -- so maybe we should use the code for function applications + -- (which would allow ifThenElse to be higher rank). + -- But it's a little awkward, so I'm leaving it alone for now + -- and it maintains uniformity with other rebindable syntax ; return (HsIf (Just fun') pred' b1' b2') } -tcExpr (HsDo do_or_lc stmts body _) res_ty - = tcDoStmts do_or_lc stmts body res_ty +tcExpr (HsDo do_or_lc stmts _) res_ty + = tcDoStmts do_or_lc stmts res_ty tcExpr (HsProc pat cmd) res_ty = do { (pat', cmd', coi) <- tcProc pat cmd res_ty - ; return $ mkHsWrapCoI coi (HsProc pat' cmd') } + ; return $ mkHsWrapCo coi (HsProc pat' cmd') } tcExpr e@(HsArrApp _ _ _ _ _) _ = failWithTc (vcat [ptext (sLit "The arrow command"), nest 2 (ppr e), @@ -424,6 +433,22 @@ ptext (sLit "was found where an expression was expected")]) \end{code} +Note [Rebindable syntax for if] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The rebindable syntax for 'if' uses the most flexible possible type +for conditionals: + ifThenElse :: p -> b1 -> b2 -> res +to support expressions like this: + + ifThenElse :: Maybe a -> (a -> b) -> b -> b + ifThenElse (Just a) f _ = f a ifThenElse Nothing _ e = e + + example :: String + example = if Just 2 + then \v -> show v + else "No value" + + %************************************************************************ %* * Record construction and update @@ -444,7 +469,7 @@ ; co_res <- unifyType actual_res_ty res_ty ; rbinds' <- tcRecordBinds data_con arg_tys rbinds - ; return $ mkHsWrapCoI co_res $ + ; return $ mkHsWrapCo co_res $ RecordCon (L loc con_id) con_expr rbinds' } \end{code} @@ -580,7 +605,7 @@ -- Take apart a representative constructor con1 = ASSERT( not (null relevant_cons) ) head relevant_cons - (con1_tvs, _, _, _, _, con1_arg_tys, _) = dataConFullSig con1 + (con1_tvs, _, _, _, con1_arg_tys, _) = dataConFullSig con1 con1_flds = dataConFieldLabels con1 con1_res_ty = mkFamilyTyConApp tycon (mkTyVarTys con1_tvs) @@ -618,10 +643,10 @@ ; (_, result_inst_tys, result_inst_env) <- tcInstTyVars con1_tvs ; scrut_inst_tys <- zipWithM mk_inst_ty con1_tvs result_inst_tys - ; let rec_res_ty = substTy result_inst_env con1_res_ty - con1_arg_tys' = map (substTy result_inst_env) con1_arg_tys + ; let rec_res_ty = TcType.substTy result_inst_env con1_res_ty + con1_arg_tys' = map (TcType.substTy result_inst_env) con1_arg_tys scrut_subst = zipTopTvSubst con1_tvs scrut_inst_tys - scrut_ty = substTy scrut_subst con1_res_ty + scrut_ty = TcType.substTy scrut_subst con1_res_ty ; co_res <- unifyType rec_res_ty res_ty @@ -636,11 +661,11 @@ -- Step 7: make a cast for the scrutinee, in the case that it's from a type family ; let scrut_co | Just co_con <- tyConFamilyCoercion_maybe tycon - = WpCast $ mkTyConApp co_con scrut_inst_tys + = WpCast $ mkAxInstCo co_con scrut_inst_tys | otherwise = idHsWrapper -- Phew! - ; return $ mkHsWrapCoI co_res $ + ; return $ mkHsWrapCo co_res $ RecordUpd (mkLHsWrap scrut_co record_expr') rbinds' relevant_cons scrut_inst_tys result_inst_tys } where @@ -680,7 +705,7 @@ ; expr' <- tcPolyExpr expr elt_ty ; enum_from <- newMethodFromName (ArithSeqOrigin seq) enumFromName elt_ty - ; return $ mkHsWrapCoI coi (ArithSeq enum_from (From expr')) } + ; return $ mkHsWrapCo coi (ArithSeq enum_from (From expr')) } tcExpr (ArithSeq _ seq@(FromThen expr1 expr2)) res_ty = do { (coi, elt_ty) <- matchExpectedListTy res_ty @@ -688,7 +713,7 @@ ; expr2' <- tcPolyExpr expr2 elt_ty ; enum_from_then <- newMethodFromName (ArithSeqOrigin seq) enumFromThenName elt_ty - ; return $ mkHsWrapCoI coi + ; return $ mkHsWrapCo coi (ArithSeq enum_from_then (FromThen expr1' expr2')) } tcExpr (ArithSeq _ seq@(FromTo expr1 expr2)) res_ty @@ -697,7 +722,7 @@ ; expr2' <- tcPolyExpr expr2 elt_ty ; enum_from_to <- newMethodFromName (ArithSeqOrigin seq) enumFromToName elt_ty - ; return $ mkHsWrapCoI coi + ; return $ mkHsWrapCo coi (ArithSeq enum_from_to (FromTo expr1' expr2')) } tcExpr (ArithSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty @@ -707,7 +732,7 @@ ; expr3' <- tcPolyExpr expr3 elt_ty ; eft <- newMethodFromName (ArithSeqOrigin seq) enumFromThenToName elt_ty - ; return $ mkHsWrapCoI coi + ; return $ mkHsWrapCo coi (ArithSeq eft (FromThenTo expr1' expr2' expr3')) } tcExpr (PArrSeq _ seq@(FromTo expr1 expr2)) res_ty @@ -715,8 +740,8 @@ ; expr1' <- tcPolyExpr expr1 elt_ty ; expr2' <- tcPolyExpr expr2 elt_ty ; enum_from_to <- newMethodFromName (PArrSeqOrigin seq) - enumFromToPName elt_ty - ; return $ mkHsWrapCoI coi + (enumFromToPName basePackageId) elt_ty -- !!!FIXME: chak + ; return $ mkHsWrapCo coi (PArrSeq enum_from_to (FromTo expr1' expr2')) } tcExpr (PArrSeq _ seq@(FromThenTo expr1 expr2 expr3)) res_ty @@ -725,8 +750,8 @@ ; expr2' <- tcPolyExpr expr2 elt_ty ; expr3' <- tcPolyExpr expr3 elt_ty ; eft <- newMethodFromName (PArrSeqOrigin seq) - enumFromThenToPName elt_ty - ; return $ mkHsWrapCoI coi + (enumFromThenToPName basePackageId) elt_ty -- !!!FIXME: chak + ; return $ mkHsWrapCo coi (PArrSeq eft (FromThenTo expr1' expr2' expr3')) } tcExpr (PArrSeq _ _) _ @@ -797,15 +822,15 @@ -- Typecheck the result, thereby propagating -- info (if any) from result into the argument types -- Both actual_res_ty and res_ty are deeply skolemised - ; co_res <- addErrCtxt (funResCtxt fun) $ + ; co_res <- addErrCtxtM (funResCtxt fun actual_res_ty res_ty) $ unifyType actual_res_ty res_ty -- Typecheck the arguments ; args1 <- tcArgs fun args expected_arg_tys -- Assemble the result - ; let fun2 = mkLHsWrapCoI co_fun fun1 - app = mkLHsWrapCoI co_res (foldl mkHsApp fun2 args1) + ; let fun2 = mkLHsWrapCo co_fun fun1 + app = mkLHsWrapCo co_res (foldl mkHsApp fun2 args1) ; return (unLoc app) } @@ -827,7 +852,7 @@ ; (co_fun, expected_arg_tys, actual_res_ty) <- matchExpectedFunTys (mk_app_msg fun) (length args) fun_tau ; args1 <- tcArgs fun args expected_arg_tys - ; let fun2 = mkLHsWrapCoI co_fun fun1 + ; let fun2 = mkLHsWrapCo co_fun fun1 app = foldl mkHsApp fun2 args1 ; return (unLoc app, actual_res_ty) } @@ -876,7 +901,7 @@ ---------------- unifyOpFunTys :: LHsExpr Name -> Arity -> TcRhoType - -> TcM (CoercionI, [TcSigmaType], TcRhoType) + -> TcM (Coercion, [TcSigmaType], TcRhoType) -- A wrapper for matchExpectedFunTys unifyOpFunTys op arity ty = matchExpectedFunTys herald arity ty where @@ -987,7 +1012,7 @@ ; let theta' = substTheta subst theta ; traceTc "Instantiating" (ppr id <+> text "with" <+> (ppr tys $$ ppr theta')) ; wrap <- instCall orig tys theta' - ; return (mkHsWrap wrap (HsVar id), substTy subst tau) } + ; return (mkHsWrap wrap (HsVar id), TcType.substTy subst tau) } where (tvs, theta, tau) = tcSplitSigmaTy (idType id) \end{code} @@ -1025,22 +1050,6 @@ Current solution: only do the "method sharing" thing for the first type/dict application, not for the iterated ones. A horribly subtle point. -Note [No method sharing] -~~~~~~~~~~~~~~~~~~~~~~~~ -The -fno-method-sharing flag controls what happens so far as the LIE -is concerned. The default case is that for an overloaded function we -generate a "method" Id, and add the Method Inst to the LIE. So you get -something like - f :: Num a => a -> a - f = /\a (d:Num a) -> let m = (+) a d in \ (x:a) -> m x x -If you specify -fno-method-sharing, the dictionary application -isn't shared, so we get - f :: Num a => a -> a - f = /\a (d:Num a) (x:a) -> (+) a d x x -This gets a bit less sharing, but - a) it's better for RULEs involving overloaded functions - b) perhaps fewer separated lambdas - \begin{code} doStupidChecks :: TcId -> [TcType] @@ -1111,7 +1120,7 @@ ; let fun' = L loc (HsWrap (WpTyApp rep_ty) (HsVar fun)) rep_ty = mkTyConApp rep_tc rep_args - ; return (mkHsWrapCoI coi $ HsApp fun' arg') } + ; return (mkHsWrapCo coi $ HsApp fun' arg') } where doc1 = vcat [ ptext (sLit "Specify the type by giving a type signature") , ptext (sLit "e.g. (tagToEnum# x) :: Bool") ] @@ -1119,18 +1128,18 @@ doc3 = ptext (sLit "No family instance for this type") get_rep_ty :: TcType -> TyCon -> [TcType] - -> TcM (CoercionI, TyCon, [TcType]) + -> TcM (Coercion, TyCon, [TcType]) -- Converts a family type (eg F [a]) to its rep type (eg FList a) -- and returns a coercion between the two get_rep_ty ty tc tc_args | not (isFamilyTyCon tc) - = return (IdCo ty, tc, tc_args) + = return (mkReflCo ty, tc, tc_args) | otherwise = do { mb_fam <- tcLookupFamInst tc tc_args ; case mb_fam of Nothing -> failWithTc (tagToEnumError ty doc3) Just (rep_tc, rep_args) - -> return ( ACo (mkSymCoercion (mkTyConApp co_tc rep_args)) + -> return ( mkSymCo (mkAxInstCo co_tc rep_args) , rep_tc, rep_args ) where co_tc = expectJust "tcTagToEnum" $ @@ -1312,7 +1321,7 @@ unless (null missing_s_fields) (addErrTc (missingStrictFields data_con missing_s_fields)) - warn <- doptM Opt_WarnMissingFields + warn <- woptM Opt_WarnMissingFields unless (not (warn && notNull missing_ns_fields)) (warnTc True (missingFields data_con missing_ns_fields)) @@ -1363,9 +1372,23 @@ quotes (ppr fun) <> text ", namely"]) 2 (quotes (ppr arg)) -funResCtxt :: LHsExpr Name -> SDoc -funResCtxt fun - = ptext (sLit "In the return type of a call of") <+> quotes (ppr fun) +funResCtxt :: LHsExpr Name -> TcType -> TcType + -> TidyEnv -> TcM (TidyEnv, Message) +-- When we have a mis-match in the return type of a function +-- try to give a helpful message about too many/few arguments +funResCtxt fun fun_res_ty res_ty env0 + = do { fun_res' <- zonkTcType fun_res_ty + ; res' <- zonkTcType res_ty + ; let n_fun = length (fst (tcSplitFunTys fun_res')) + n_res = length (fst (tcSplitFunTys res')) + what | n_fun > n_res = ptext (sLit "few") + | otherwise = ptext (sLit "many") + extra | n_fun == n_res = empty + | otherwise = ptext (sLit "Probable cause:") <+> quotes (ppr fun) + <+> ptext (sLit "is applied to too") <+> what + <+> ptext (sLit "arguments") + msg = ptext (sLit "In the return type of a call of") <+> quotes (ppr fun) + ; return (env0, msg $$ extra) } badFieldTypes :: [(Name,TcType)] -> SDoc badFieldTypes prs diff -Nru ghc-7.0.3/compiler/typecheck/TcForeign.lhs ghc-7.2.1/compiler/typecheck/TcForeign.lhs --- ghc-7.0.3/compiler/typecheck/TcForeign.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/typecheck/TcForeign.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -12,11 +12,11 @@ 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 @@ -- 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 @@ 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} @@ -88,27 +88,25 @@ \begin{code} tcCheckFIType :: Type -> [Type] -> Type -> ForeignImport -> TcM ForeignImport -tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ safety _ (CLabel _)) +tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ _ _ (CLabel _)) = ASSERT( null arg_tys ) 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. +tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv _ _ 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. checkCg checkCOrAsmOrLlvmOrInterp checkCConv cconv - checkSafety safety case arg_tys of [arg1_ty] -> do checkForeignArgs isFFIExternalTy arg1_tys - checkForeignRes nonIOok isFFIExportResultTy res1_ty - checkForeignRes mustBeIO isFFIDynResultTy res_ty + checkForeignRes nonIOok False isFFIExportResultTy res1_ty + checkForeignRes mustBeIO False isFFIDynResultTy res_ty where (arg1_tys, res1_ty) = tcSplitFunTys arg1_ty _ -> addErrTc (illegalForeignTyErr empty sig_ty) @@ -118,7 +116,6 @@ | isDynamicTarget target = do -- Foreign import dynamic checkCg checkCOrAsmOrLlvmOrInterp checkCConv cconv - checkSafety safety case arg_tys of -- The first arg must be Ptr, FunPtr, or Addr [] -> do check False (illegalForeignTyErr empty sig_ty) @@ -128,7 +125,9 @@ check (isFFIDynArgumentTy arg1_ty) (illegalForeignTyErr argument arg1_ty) checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys - checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty + let safe_on = safeLanguageOn dflags + ioOK = if safe_on then mustBeIO else nonIOok + checkForeignRes ioOK safe_on (isFFIImportResultTy dflags) res_ty return idecl | cconv == PrimCallConv = do dflags <- getDOpts @@ -140,16 +139,19 @@ (text "The safe/unsafe annotation should not be used with `foreign import prim'.") checkForeignArgs (isFFIPrimArgumentTy dflags) arg_tys -- prim import result is more liberal, allows (#,,#) - checkForeignRes nonIOok (isFFIPrimResultTy dflags) res_ty + let safe_on = safeLanguageOn dflags + ioOK = if safe_on then mustBeIO else nonIOok + checkForeignRes ioOK safe_on (isFFIPrimResultTy dflags) res_ty return idecl | otherwise = do -- Normal foreign import checkCg (checkCOrAsmOrLlvmOrDotNetOrInterp) checkCConv cconv - checkSafety safety checkCTarget target dflags <- getDOpts checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys - checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty + let safe_on = safeLanguageOn dflags + ioOK = if safe_on then mustBeIO else nonIOok + checkForeignRes ioOK safe_on (isFFIImportResultTy dflags) res_ty checkMissingAmpersand dflags arg_tys res_ty return idecl @@ -167,21 +169,21 @@ checkMissingAmpersand :: DynFlags -> [Type] -> Type -> TcM () checkMissingAmpersand dflags arg_tys res_ty | null arg_tys && isFunPtrTy res_ty && - dopt Opt_WarnDodgyForeignImports dflags + wopt Opt_WarnDodgyForeignImports dflags = addWarn (ptext (sLit "possible missing & in foreign import of FunPtr")) | otherwise = return () \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 +192,25 @@ 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} @@ -221,7 +223,7 @@ check (isCLabelString str) (badCName str) checkCConv cconv checkForeignArgs isFFIExternalTy arg_tys - checkForeignRes nonIOok isFFIExportResultTy res_ty + checkForeignRes nonIOok False isFFIExportResultTy res_ty where -- Drop the foralls before inspecting n -- the structure of the foreign type. @@ -232,9 +234,9 @@ %************************************************************************ -%* * +%* * \subsection{Miscellaneous} -%* * +%* * %************************************************************************ \begin{code} @@ -246,24 +248,24 @@ 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 () +checkForeignRes :: Bool -> Bool -> (Type -> Bool) -> Type -> TcM () nonIOok, mustBeIO :: Bool nonIOok = True mustBeIO = False -checkForeignRes non_io_result_ok pred_res_ty ty - -- (IO t) is ok, and so is any newtype wrapping thereof +checkForeignRes non_io_result_ok safehs_check pred_res_ty ty + -- (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 $+$ safeHsErr safehs_check) \end{code} \begin{code} @@ -272,7 +274,7 @@ 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 +282,7 @@ 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,68 +290,63 @@ 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" -\end{code} - -Deprecated "threadsafe" calls - -\begin{code} -checkSafety :: Safety -> TcM () -checkSafety (PlaySafe True) = addWarn (text "The `threadsafe' foreign import style is deprecated. Use `safe' instead.") -checkSafety _ = return () +checkCConv CmmCallConv = panic "checkCConv CmmCallConv" \end{code} 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]) +safeHsErr :: Bool -> SDoc +safeHsErr False = empty +safeHsErr True = ptext $ sLit "Safe Haskell is on, all FFI imports must be in the IO monad" + -- Used for 'arg_or_res' argument to illegalForeignTyErr argument, result :: SDoc 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 -Nru ghc-7.0.3/compiler/typecheck/TcGenDeriv.lhs ghc-7.2.1/compiler/typecheck/TcGenDeriv.lhs --- ghc-7.0.3/compiler/typecheck/TcGenDeriv.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/typecheck/TcGenDeriv.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -42,7 +42,7 @@ import HscTypes import PrelInfo import MkCore ( eRROR_ID ) -import PrelNames +import PrelNames hiding (error_RDR) import PrimOp import SrcLoc import TyCon @@ -50,16 +50,19 @@ import TysPrim import TysWiredIn import Type -import Var( TyVar ) import TypeRep import VarSet +import Module import State import Util import MonadUtils import Outputable import FastString import Bag -import Data.List ( partition, intersperse ) +import Fingerprint +import Constants + +import Data.List ( partition, intersperse ) \end{code} \begin{code} @@ -779,7 +782,7 @@ single_con_range = mk_easy_FunBind loc range_RDR [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] $ - nlHsDo ListComp stmts con_expr + noLoc (mkHsComp ListComp stmts con_expr) where stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed @@ -893,15 +896,15 @@ read_nullary_cons = case nullary_cons of [] -> [] - [con] -> [nlHsDo DoExpr [bindLex (match_con con)] (result_expr con [])] + [con] -> [nlHsDo DoExpr (match_con con ++ [noLoc $ mkLastStmt (result_expr con [])])] _ -> [nlHsApp (nlHsVar choose_RDR) (nlList (map mk_pair nullary_cons))] -- NB For operators the parens around (:=:) are matched by the -- enclosing "parens" call, so here we must match the naked -- data_con_str con - match_con con | isSym con_str = symbol_pat con_str - | otherwise = ident_pat con_str + match_con con | isSym con_str = [symbol_pat con_str] + | otherwise = ident_h_pat con_str where con_str = data_con_str con -- For nullary constructors we must match Ident s for normal constrs @@ -925,12 +928,12 @@ prefix_parser = mk_parser prefix_prec prefix_stmts body read_prefix_con - | isSym con_str = [read_punc "(", bindLex (symbol_pat con_str), read_punc ")"] - | otherwise = [bindLex (ident_pat con_str)] + | isSym con_str = [read_punc "(", symbol_pat con_str, read_punc ")"] + | otherwise = ident_h_pat con_str read_infix_con - | isSym con_str = [bindLex (symbol_pat con_str)] - | otherwise = [read_punc "`", bindLex (ident_pat con_str), read_punc "`"] + | isSym con_str = [symbol_pat con_str] + | otherwise = [read_punc "`"] ++ ident_h_pat con_str ++ [read_punc "`"] prefix_stmts -- T a b c = read_prefix_con ++ read_args @@ -965,15 +968,23 @@ ------------------------------------------------------------------------ -- Helpers ------------------------------------------------------------------------ - mk_alt e1 e2 = genOpApp e1 alt_RDR e2 -- e1 +++ e2 - mk_parser p ss b = nlHsApps prec_RDR [nlHsIntLit p, nlHsDo DoExpr ss b] -- prec p (do { ss ; b }) - bindLex pat = noLoc (mkBindStmt pat (nlHsVar lexP_RDR)) -- pat <- lexP - con_app con as = nlHsVarApps (getRdrName con) as -- con as - result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as) + mk_alt e1 e2 = genOpApp e1 alt_RDR e2 -- e1 +++ e2 + mk_parser p ss b = nlHsApps prec_RDR [nlHsIntLit p -- prec p (do { ss ; b }) + , nlHsDo DoExpr (ss ++ [noLoc $ mkLastStmt b])] + bindLex pat = noLoc (mkBindStmt pat (nlHsVar lexP_RDR)) -- pat <- lexP + con_app con as = nlHsVarApps (getRdrName con) as -- con as + result_expr con as = nlHsApp (nlHsVar returnM_RDR) (con_app con as) -- return (con as) punc_pat s = nlConPat punc_RDR [nlLitPat (mkHsString s)] -- Punc 'c' - ident_pat s = nlConPat ident_RDR [nlLitPat (mkHsString s)] -- Ident "foo" - symbol_pat s = nlConPat symbol_RDR [nlLitPat (mkHsString s)] -- Symbol ">>" + + -- For constructors and field labels ending in '#', we hackily + -- let the lexer generate two tokens, and look for both in sequence + -- Thus [Ident "I"; Symbol "#"]. See Trac #5041 + ident_h_pat s | Just (ss, '#') <- snocView s = [ ident_pat ss, symbol_pat "#" ] + | otherwise = [ ident_pat s ] + + ident_pat s = bindLex $ nlConPat ident_RDR [nlLitPat (mkHsString s)] -- Ident "foo" <- lexP + symbol_pat s = bindLex $ nlConPat symbol_RDR [nlLitPat (mkHsString s)] -- Symbol ">>" <- lexP data_con_str con = occNameString (getOccName con) @@ -991,11 +1002,9 @@ -- or (#) = 4 -- Note the parens! read_lbl lbl | isSym lbl_str - = [read_punc "(", - bindLex (symbol_pat lbl_str), - read_punc ")"] + = [read_punc "(", symbol_pat lbl_str, read_punc ")"] | otherwise - = [bindLex (ident_pat lbl_str)] + = ident_h_pat lbl_str where lbl_str = occNameString (getOccName lbl) \end{code} @@ -1156,8 +1165,9 @@ we generate - instance Typeable2 T where - typeOf2 _ = mkTyConApp (mkTyConRep "T") [] + instance Typeable2 T where + typeOf2 _ = mkTyConApp (mkTyCon + "T") [] We are passed the Typeable2 class as well as T @@ -1168,13 +1178,34 @@ mk_easy_FunBind loc (mk_typeOf_RDR tycon) -- Name of appropriate type0f function [nlWildPat] - (nlHsApps mkTypeRep_RDR [tycon_rep, nlList []]) + (nlHsApps mkTyConApp_RDR [tycon_rep, nlList []]) where - tycon_rep = nlHsVar mkTyConRep_RDR `nlHsApp` nlHsLit (mkHsString (showSDocOneLine (ppr tycon))) + tycon_name = tyConName tycon + modl = nameModule tycon_name + pkg = modulePackageId modl + + modl_fs = moduleNameFS (moduleName modl) + pkg_fs = packageIdFS pkg + name_fs = occNameFS (nameOccName tycon_name) + + tycon_rep = nlHsApps mkTyCon_RDR + (map nlHsLit [int64 high, + int64 low, + HsString pkg_fs, + HsString modl_fs, + HsString name_fs]) + + hashThis = unwords $ map unpackFS [pkg_fs, modl_fs, name_fs] + Fingerprint high low = fingerprintString hashThis + + int64 + | wORD_SIZE == 4 = HsWord64Prim . fromIntegral + | otherwise = HsWordPrim . fromIntegral + mk_typeOf_RDR :: TyCon -> RdrName -- Use the arity of the TyCon to make the right typeOfn function -mk_typeOf_RDR tycon = varQual_RDR tYPEABLE (mkFastString ("typeOf" ++ suffix)) +mk_typeOf_RDR tycon = varQual_RDR tYPEABLE_INTERNAL (mkFastString ("typeOf" ++ suffix)) where arity = tyConArity tycon suffix | arity == 0 = "" @@ -1665,7 +1696,7 @@ genAuxBind :: SrcSpan -> DerivAuxBind -> (LHsBind RdrName, LSig RdrName) genAuxBind loc (GenCon2Tag tycon) = (mk_FunBind loc rdr_name eqns, - L loc (TypeSig (L loc rdr_name) (L loc sig_ty))) + L loc (TypeSig [L loc rdr_name] (L loc sig_ty))) where rdr_name = con2tag_RDR tycon @@ -1690,7 +1721,7 @@ = (mk_FunBind loc rdr_name [([nlConVarPat intDataCon_RDR [a_RDR]], nlHsApp (nlHsVar tagToEnum_RDR) a_Expr)], - L loc (TypeSig (L loc rdr_name) (L loc sig_ty))) + L loc (TypeSig [L loc rdr_name] (L loc sig_ty))) where sig_ty = HsCoreTy $ mkForAllTys (tyConTyVars tycon) $ intTy `mkFunTy` mkParentType tycon @@ -1699,7 +1730,7 @@ genAuxBind loc (GenMaxTag tycon) = (mkHsVarBind loc rdr_name rhs, - L loc (TypeSig (L loc rdr_name) (L loc sig_ty))) + L loc (TypeSig [L loc rdr_name] (L loc sig_ty))) where rdr_name = maxtag_RDR tycon sig_ty = HsCoreTy intTy @@ -1709,7 +1740,7 @@ genAuxBind loc (MkTyCon tycon) -- $dT = (mkHsVarBind loc rdr_name rhs, - L loc (TypeSig (L loc rdr_name) sig_ty)) + L loc (TypeSig [L loc rdr_name] sig_ty)) where rdr_name = mk_data_type_name tycon sig_ty = nlHsTyVar dataType_RDR @@ -1720,7 +1751,7 @@ genAuxBind loc (MkDataCon dc) -- $cT1 etc = (mkHsVarBind loc rdr_name rhs, - L loc (TypeSig (L loc rdr_name) sig_ty)) + L loc (TypeSig [L loc rdr_name] sig_ty)) where rdr_name = mk_constr_name dc sig_ty = nlHsTyVar constr_RDR @@ -1831,7 +1862,7 @@ text "for primitive type" <+> ppr ty) | otherwise = head res where - res = [id | (ty',id) <- tbl, ty `tcEqType` ty'] + res = [id | (ty',id) <- tbl, ty `eqType` ty'] ----------------------------------------------------------------------- diff -Nru ghc-7.0.3/compiler/typecheck/TcHsSyn.lhs ghc-7.2.1/compiler/typecheck/TcHsSyn.lhs --- ghc-7.0.3/compiler/typecheck/TcHsSyn.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/typecheck/TcHsSyn.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -35,6 +35,7 @@ import PrelNames import TcType import TcMType +import Coercion import TysPrim import TysWiredIn import DataCon @@ -43,14 +44,15 @@ import Var import VarSet import VarEnv +import DynFlags import Literal import BasicTypes import Maybes import SrcLoc -import DynFlags( DynFlag(..) ) import Bag import FastString import Outputable +-- import Data.Traversable( traverse ) \end{code} \begin{code} @@ -82,7 +84,6 @@ hsPatType (ParPat pat) = hsLPatType pat hsPatType (WildPat ty) = ty hsPatType (VarPat var) = idType var -hsPatType (VarPatOut var _) = idType var hsPatType (BangPat pat) = hsLPatType pat hsPatType (LazyPat pat) = hsLPatType pat hsPatType (LitPat lit) = hsLitType lit @@ -106,6 +107,8 @@ hsLitType (HsInt _) = intTy hsLitType (HsIntPrim _) = intPrimTy hsLitType (HsWordPrim _) = wordPrimTy +hsLitType (HsInt64Prim _) = int64PrimTy +hsLitType (HsWord64Prim _) = word64PrimTy hsLitType (HsInteger _ ty) = ty hsLitType (HsRat _ ty) = ty hsLitType (HsFloatPrim _) = floatPrimTy @@ -120,7 +123,7 @@ | isIntTy ty && inIntRange i = Just (HsLit (HsInt i)) | isWordTy ty && inWordRange i = Just (mkLit wordDataCon (HsWordPrim i)) | isIntegerTy ty = Just (HsLit (HsInteger i ty)) - | otherwise = shortCutLit (HsFractional (fromInteger i)) ty + | otherwise = shortCutLit (HsFractional (integralFractionalLit i)) ty -- The 'otherwise' case is important -- Consider (3 :: Float). Syntactically it looks like an IntLit, -- so we'll call shortCutIntLit, but of course it's a float @@ -270,28 +273,30 @@ zonkTopDecls :: Bag EvBind -> LHsBinds TcId -> NameSet - -> [LRuleDecl TcId] -> [LTcSpecPrag] -> [LForeignDecl TcId] - -> TcM ([Id], - Bag EvBind, - Bag (LHsBind Id), - [LForeignDecl Id], - [LTcSpecPrag], - [LRuleDecl Id]) -zonkTopDecls ev_binds binds sig_ns rules imp_specs fords - = do { (env1, ev_binds') <- zonkEvBinds emptyZonkEnv ev_binds + -> [LRuleDecl TcId] -> [LVectDecl TcId] -> [LTcSpecPrag] -> [LForeignDecl TcId] + -> TcM ([Id], + Bag EvBind, + Bag (LHsBind Id), + [LForeignDecl Id], + [LTcSpecPrag], + [LRuleDecl Id], + [LVectDecl Id]) +zonkTopDecls ev_binds binds sig_ns rules vects imp_specs fords + = do { (env1, ev_binds') <- zonkEvBinds emptyZonkEnv ev_binds -- Warn about missing signatures -- Do this only when we we have a type to offer - ; warn_missing_sigs <- doptM Opt_WarnMissingSigs + ; warn_missing_sigs <- woptM Opt_WarnMissingSigs ; let sig_warn | warn_missing_sigs = topSigWarn sig_ns | otherwise = noSigWarn ; (env2, binds') <- zonkRecMonoBinds env1 sig_warn binds - -- Top level is implicitly recursive - ; rules' <- zonkRules env2 rules + -- Top level is implicitly recursive + ; rules' <- zonkRules env2 rules + ; vects' <- zonkVects env2 vects ; specs' <- zonkLTcSpecPrags env2 imp_specs - ; fords' <- zonkForeignExports env2 fords - ; return (zonkEnvIds env2, ev_binds', binds', fords', specs', rules') } + ; fords' <- zonkForeignExports env2 fords + ; return (zonkEnvIds env2, ev_binds', binds', fords', specs', rules', vects') } --------------------------------------------- zonkLocalBinds :: ZonkEnv -> HsLocalBinds TcId -> TcM (ZonkEnv, HsLocalBinds Id) @@ -302,7 +307,7 @@ = panic "zonkLocalBinds" -- Not in typechecker output zonkLocalBinds env (HsValBinds vb@(ValBindsOut binds sigs)) - = do { warn_missing_sigs <- doptM Opt_WarnMissingLocalSigs + = do { warn_missing_sigs <- woptM Opt_WarnMissingLocalSigs ; let sig_warn | not warn_missing_sigs = noSigWarn | otherwise = localSigWarn sig_ns sig_ns = getTypeSigNames vb @@ -577,12 +582,10 @@ zonkLExpr new_env expr `thenM` \ new_expr -> returnM (HsLet new_binds new_expr) -zonkExpr env (HsDo do_or_lc stmts body ty) - = zonkStmts env stmts `thenM` \ (new_env, new_stmts) -> - zonkLExpr new_env body `thenM` \ new_body -> +zonkExpr env (HsDo do_or_lc stmts ty) + = zonkStmts env stmts `thenM` \ (_, new_stmts) -> zonkTcTypeToType env ty `thenM` \ new_ty -> - zonkDo env do_or_lc `thenM` \ new_do_or_lc -> - returnM (HsDo new_do_or_lc new_stmts new_body new_ty) + returnM (HsDo do_or_lc new_stmts new_ty) zonkExpr env (ExplicitList ty exprs) = zonkTcTypeToType env ty `thenM` \ new_ty -> @@ -676,7 +679,7 @@ zonkCoFn env (WpCompose c1 c2) = do { (env1, c1') <- zonkCoFn env c1 ; (env2, c2') <- zonkCoFn env1 c2 ; return (env2, WpCompose c1' c2') } -zonkCoFn env (WpCast co) = do { co' <- zonkTcTypeToType env co +zonkCoFn env (WpCast co) = do { co' <- zonkTcCoToCo env co ; return (env, WpCast co') } zonkCoFn env (WpEvLam ev) = do { (env', ev') <- zonkEvBndrX env ev ; return (env', WpEvLam ev') } @@ -690,13 +693,6 @@ ; return (env1, WpLet bs') } ------------------------------------------------------------------------- -zonkDo :: ZonkEnv -> HsStmtContext Name -> TcM (HsStmtContext Name) --- Only used for 'do', so the only Ids are in a MDoExpr table -zonkDo env (MDoExpr tbl) = do { tbl' <- mapSndM (zonkExpr env) tbl - ; return (MDoExpr tbl') } -zonkDo _ do_or_lc = return do_or_lc - -------------------------------------------------------------------------- zonkOverLit :: ZonkEnv -> HsOverLit TcId -> TcM (HsOverLit Id) zonkOverLit env lit@(OverLit { ol_witness = e, ol_type = ty }) = do { ty' <- zonkTcTypeToType env ty @@ -735,22 +731,26 @@ ; return (env2, s' : ss') } zonkStmt :: ZonkEnv -> Stmt TcId -> TcM (ZonkEnv, Stmt Id) -zonkStmt env (ParStmt stmts_w_bndrs) +zonkStmt env (ParStmt stmts_w_bndrs mzip_op bind_op return_op) = mappM zonk_branch stmts_w_bndrs `thenM` \ new_stmts_w_bndrs -> let new_binders = concat (map snd new_stmts_w_bndrs) env1 = extendZonkEnv env new_binders in - return (env1, ParStmt new_stmts_w_bndrs) + zonkExpr env1 mzip_op `thenM` \ new_mzip -> + zonkExpr env1 bind_op `thenM` \ new_bind -> + zonkExpr env1 return_op `thenM` \ new_return -> + return (env1, ParStmt new_stmts_w_bndrs new_mzip new_bind new_return) where zonk_branch (stmts, bndrs) = zonkStmts env stmts `thenM` \ (env1, new_stmts) -> returnM (new_stmts, zonkIdOccs env1 bndrs) zonkStmt env (RecStmt { recS_stmts = segStmts, recS_later_ids = lvs, recS_rec_ids = rvs , recS_ret_fn = ret_id, recS_mfix_fn = mfix_id, recS_bind_fn = bind_id - , recS_rec_rets = rets, recS_dicts = binds }) + , recS_rec_rets = rets, recS_ret_ty = ret_ty }) = do { new_rvs <- zonkIdBndrs env rvs ; new_lvs <- zonkIdBndrs env lvs + ; new_ret_ty <- zonkTcTypeToType env ret_ty ; new_ret_id <- zonkExpr env ret_id ; new_mfix_id <- zonkExpr env mfix_id ; new_bind_id <- zonkExpr env bind_id @@ -759,34 +759,38 @@ -- Zonk the ret-expressions in an envt that -- has the polymorphic bindings in the envt ; new_rets <- mapM (zonkExpr env2) rets - ; let env3 = extendZonkEnv env new_lvs -- Only the lvs are needed - ; (env4, new_binds) <- zonkTcEvBinds env3 binds - ; return (env4, + ; return (extendZonkEnv env new_lvs, -- Only the lvs are needed RecStmt { recS_stmts = new_segStmts, recS_later_ids = new_lvs , recS_rec_ids = new_rvs, recS_ret_fn = new_ret_id , recS_mfix_fn = new_mfix_id, recS_bind_fn = new_bind_id - , recS_rec_rets = new_rets, recS_dicts = new_binds }) } + , recS_rec_rets = new_rets, recS_ret_ty = new_ret_ty }) } -zonkStmt env (ExprStmt expr then_op ty) +zonkStmt env (ExprStmt expr then_op guard_op ty) = zonkLExpr env expr `thenM` \ new_expr -> zonkExpr env then_op `thenM` \ new_then -> + zonkExpr env guard_op `thenM` \ new_guard -> zonkTcTypeToType env ty `thenM` \ new_ty -> - returnM (env, ExprStmt new_expr new_then new_ty) + returnM (env, ExprStmt new_expr new_then new_guard new_ty) -zonkStmt env (TransformStmt stmts binders usingExpr maybeByExpr) - = do { (env', stmts') <- zonkStmts env stmts - ; let binders' = zonkIdOccs env' binders - ; usingExpr' <- zonkLExpr env' usingExpr - ; maybeByExpr' <- zonkMaybeLExpr env' maybeByExpr - ; return (env', TransformStmt stmts' binders' usingExpr' maybeByExpr') } - -zonkStmt env (GroupStmt stmts binderMap by using) +zonkStmt env (LastStmt expr ret_op) + = zonkLExpr env expr `thenM` \ new_expr -> + zonkExpr env ret_op `thenM` \ new_ret -> + returnM (env, LastStmt new_expr new_ret) + +zonkStmt env (TransStmt { trS_stmts = stmts, trS_bndrs = binderMap + , trS_by = by, trS_form = form, trS_using = using + , trS_ret = return_op, trS_bind = bind_op, trS_fmap = liftM_op }) = do { (env', stmts') <- zonkStmts env stmts ; binderMap' <- mappM (zonkBinderMapEntry env') binderMap - ; by' <- fmapMaybeM (zonkLExpr env') by - ; using' <- fmapEitherM (zonkLExpr env) (zonkExpr env) using + ; by' <- fmapMaybeM (zonkLExpr env') by + ; using' <- zonkLExpr env using + ; return_op' <- zonkExpr env' return_op + ; bind_op' <- zonkExpr env' bind_op + ; liftM_op' <- zonkExpr env' liftM_op ; let env'' = extendZonkEnv env' (map snd binderMap') - ; return (env'', GroupStmt stmts' binderMap' by' using') } + ; return (env'', TransStmt { trS_stmts = stmts', trS_bndrs = binderMap' + , trS_by = by', trS_form = form, trS_using = using' + , trS_ret = return_op', trS_bind = bind_op', trS_fmap = liftM_op' }) } where zonkBinderMapEntry env (oldBinder, newBinder) = do let oldBinder' = zonkIdOcc env oldBinder @@ -804,11 +808,6 @@ ; new_fail <- zonkExpr env fail_op ; return (env1, BindStmt new_pat new_expr new_bind new_fail) } -zonkMaybeLExpr :: ZonkEnv -> Maybe (LHsExpr TcId) -> TcM (Maybe (LHsExpr Id)) -zonkMaybeLExpr _ Nothing = return Nothing -zonkMaybeLExpr env (Just e) = (zonkLExpr env e) >>= (return . Just) - - ------------------------------------------------------------------------- zonkRecFields :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds TcId) zonkRecFields env (HsRecFields flds dd) @@ -852,11 +851,6 @@ = do { v' <- zonkIdBndr env v ; return (extendZonkEnv1 env v', VarPat v') } -zonk_pat env (VarPatOut v binds) - = do { v' <- zonkIdBndr env v - ; (env', binds') <- zonkTcEvBinds (extendZonkEnv1 env v') binds - ; returnM (env', VarPatOut v' binds') } - zonk_pat env (LazyPat pat) = do { (env', pat') <- zonkPat env pat ; return (env', LazyPat pat') } @@ -1018,10 +1012,28 @@ zonk_it env v | isId v = do { v' <- zonkIdBndr env v; return (extendZonkEnv1 env v', v') } - | isCoVar v = do { v' <- zonkEvBndr env v; return (extendZonkEnv1 env v', v') } | otherwise = ASSERT( isImmutableTyVar v) return (env, v) \end{code} +\begin{code} +zonkVects :: ZonkEnv -> [LVectDecl TcId] -> TcM [LVectDecl Id] +zonkVects env = mappM (wrapLocM (zonkVect env)) + +zonkVect :: ZonkEnv -> VectDecl TcId -> TcM (VectDecl Id) +zonkVect env (HsVect v Nothing) + = do { v' <- wrapLocM (zonkIdBndr env) v + ; return $ HsVect v' Nothing + } +zonkVect env (HsVect v (Just e)) + = do { v' <- wrapLocM (zonkIdBndr env) v + ; e' <- zonkLExpr env e + ; return $ HsVect v' (Just e') + } +zonkVect env (HsNoVect v) + = do { v' <- wrapLocM (zonkIdBndr env) v + ; return $ HsNoVect v' + } +\end{code} %************************************************************************ %* * @@ -1033,10 +1045,10 @@ zonkEvTerm :: ZonkEnv -> EvTerm -> TcM EvTerm zonkEvTerm env (EvId v) = ASSERT2( isId v, ppr v ) return (EvId (zonkIdOcc env v)) -zonkEvTerm env (EvCoercion co) = do { co' <- zonkTcTypeToType env co +zonkEvTerm env (EvCoercion co) = do { co' <- zonkTcCoToCo env co ; return (EvCoercion co') } zonkEvTerm env (EvCast v co) = ASSERT( isId v) - do { co' <- zonkTcTypeToType env co + do { co' <- zonkTcCoToCo env co ; return (EvCast (zonkIdOcc env v) co') } zonkEvTerm env (EvSuperClass d n) = return (EvSuperClass (zonkIdOcc env d) n) zonkEvTerm env (EvDFunApp df tys tms) @@ -1111,4 +1123,27 @@ zonk_unbound_tyvar tv = do { let ty = anyTypeOfKind (tyVarKind tv) ; writeMetaTyVar tv ty ; return ty } -\end{code} \ No newline at end of file + +zonkTcCoToCo :: ZonkEnv -> Coercion -> TcM Coercion +zonkTcCoToCo env co + = go co + where + go (CoVarCo cv) = return (CoVarCo (zonkEvVarOcc env cv)) + go (Refl ty) = do { ty' <- zonkTcTypeToType env ty + ; return (Refl ty') } + go (TyConAppCo tc cos) = do { cos' <- mapM go cos; return (mkTyConAppCo tc cos') } + go (AxiomInstCo ax cos) = do { cos' <- mapM go cos; return (AxiomInstCo ax cos') } + go (AppCo co1 co2) = do { co1' <- go co1; co2' <- go co2 + ; return (mkAppCo co1' co2') } + go (UnsafeCo t1 t2) = do { t1' <- zonkTcTypeToType env t1 + ; t2' <- zonkTcTypeToType env t2 + ; return (mkUnsafeCo t1' t2') } + go (SymCo co) = do { co' <- go co; return (mkSymCo co') } + go (NthCo n co) = do { co' <- go co; return (mkNthCo n co') } + go (TransCo co1 co2) = do { co1' <- go co1; co2' <- go co2 + ; return (mkTransCo co1' co2') } + go (InstCo co ty) = do { co' <- go co; ty' <- zonkTcTypeToType env ty + ; return (mkInstCo co' ty') } + go (ForAllCo tv co) = ASSERT( isImmutableTyVar tv ) + do { co' <- go co; return (mkForAllCo tv co') } +\end{code} diff -Nru ghc-7.0.3/compiler/typecheck/TcHsType.lhs ghc-7.2.1/compiler/typecheck/TcHsType.lhs --- ghc-7.0.3/compiler/typecheck/TcHsType.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/typecheck/TcHsType.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -44,7 +44,6 @@ import Class import Name import NameSet -import PrelNames import TysWiredIn import BasicTypes import SrcLoc @@ -300,7 +299,7 @@ = do { ty' <- kc_check_lhs_type ty exp_kind; return (HsParTy ty') } kc_check_hs_type ty@(HsAppTy ty1 ty2) exp_kind - = do { let (fun_ty, arg_tys) = splitHsAppTys ty1 ty2 + = do { let (fun_ty, arg_tys) = splitHsAppTys ty1 [ty2] ; (fun_ty', fun_kind) <- kc_lhs_type fun_ty ; arg_tys' <- kcCheckApps fun_ty fun_kind arg_tys ty exp_kind ; return (mkHsAppTys fun_ty' arg_tys') } @@ -365,9 +364,6 @@ ty' <- kcLiftedType ty return (HsPArrTy ty', liftedTypeKind) -kc_hs_type (HsNumTy n) - = return (HsNumTy n, liftedTypeKind) - kc_hs_type (HsKindSig ty k) = do ty' <- kc_check_lhs_type ty (EK k EkKindSig) return (HsKindSig ty' k, k) @@ -391,11 +387,10 @@ return (HsOpTy ty1' op ty2', res_kind) kc_hs_type (HsAppTy ty1 ty2) = do + let (fun_ty, arg_tys) = splitHsAppTys ty1 [ty2] (fun_ty', fun_kind) <- kc_lhs_type fun_ty (arg_tys', res_kind) <- kcApps fun_ty fun_kind arg_tys return (mkHsAppTys fun_ty' arg_tys', res_kind) - where - (fun_ty, arg_tys) = splitHsAppTys ty1 ty2 kc_hs_type (HsPredTy pred) = wrongPredErr pred @@ -462,20 +457,6 @@ -- This improves error message; Trac #2994 ; kc_check_lhs_types args_w_kinds } -splitHsAppTys :: LHsType Name -> LHsType Name -> (LHsType Name, [LHsType Name]) -splitHsAppTys fun_ty arg_ty = split fun_ty [arg_ty] - where - split (L _ (HsAppTy f a)) as = split f (a:as) - split f as = (f,as) - -mkHsAppTys :: LHsType Name -> [LHsType Name] -> HsType Name -mkHsAppTys fun_ty [] = pprPanic "mkHsAppTys" (ppr fun_ty) -mkHsAppTys fun_ty (arg_ty:arg_tys) - = foldl mk_app (HsAppTy fun_ty arg_ty) arg_tys - where - mk_app fun arg = HsAppTy (noLoc fun) arg -- Add noLocs for inner nodes of - -- the application; they are - -- never used --------------------------- splitFunKind :: SDoc -> Int -> TcKind -> [b] -> TcM ([(b,ExpKind)], TcKind) @@ -606,11 +587,6 @@ tau_ty2 <- dsHsType ty2 setSrcSpan span (ds_var_app op [tau_ty1,tau_ty2]) -ds_type (HsNumTy n) - = ASSERT(n==1) do - tc <- tcLookupTyCon genUnitTyConName - return (mkTyConApp tc []) - ds_type ty@(HsAppTy _ _) = ds_app ty [] @@ -857,7 +833,7 @@ [(Name, TcType)], -- The new bit of type environment, binding -- the scoped type variables HsWrapper) -- Coercion due to unification with actual ty - -- Of shape: res_ty ~ sig_ty + -- Of shape: res_ty ~ sig_ty tcPatSig ctxt sig res_ty = do { (sig_tvs, sig_ty) <- tcHsPatSigType ctxt sig -- sig_tvs are the type variables free in 'sig', @@ -869,8 +845,7 @@ -- and hence is rigid, so use it to zap the res_ty wrap <- tcSubType PatSigOrigin ctxt res_ty sig_ty ; return (sig_ty, [], wrap) - - } else do { + } else do { -- Type signature binds at least one scoped type variable -- A pattern binding cannot bind scoped type variables @@ -893,20 +868,20 @@ ; checkTc (null bad_tvs) (badPatSigTvs sig_ty bad_tvs) -- Now do a subsumption check of the pattern signature against res_ty - ; sig_tvs' <- tcInstSigTyVars sig_tvs + ; sig_tvs' <- tcInstSigTyVars sig_tvs ; let sig_ty' = substTyWith sig_tvs sig_tv_tys' sig_ty sig_tv_tys' = mkTyVarTys sig_tvs' - ; wrap <- tcSubType PatSigOrigin ctxt res_ty sig_ty' + ; wrap <- tcSubType PatSigOrigin ctxt res_ty sig_ty' -- Check that each is bound to a distinct type variable, -- and one that is not already in scope - ; binds_in_scope <- getScopedTyVarBinds + ; binds_in_scope <- getScopedTyVarBinds ; let tv_binds = map tyVarName sig_tvs `zip` sig_tv_tys' ; check binds_in_scope tv_binds -- Phew! - ; return (sig_ty', tv_binds, wrap) - } } + ; return (sig_ty', tv_binds, wrap) + } } where check _ [] = return () check in_scope ((n,ty):rest) = do { check_one in_scope n ty @@ -917,7 +892,7 @@ -- Must not bind to the same type variable -- as some other in-scope type variable where - dups = [n' | (n',ty') <- in_scope, tcEqType ty' ty] + dups = [n' | (n',ty') <- in_scope, eqType ty' ty] \end{code} diff -Nru ghc-7.0.3/compiler/typecheck/TcInstDcls.lhs ghc-7.2.1/compiler/typecheck/TcInstDcls.lhs --- ghc-7.0.3/compiler/typecheck/TcInstDcls.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/typecheck/TcInstDcls.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -16,26 +16,31 @@ import TcRnMonad import TcMType import TcType +import BuildTyCl import Inst import InstEnv import FamInst import FamInstEnv -import MkCore ( nO_METHOD_BINDING_ERROR_ID ) import TcDeriv import TcEnv import RnSource ( addTcgDUs ) import TcHsType import TcUnify +import MkCore ( nO_METHOD_BINDING_ERROR_ID ) import Type import Coercion import TyCon import DataCon import Class import Var -import VarSet +import VarEnv( mkInScopeSet ) +import VarSet( mkVarSet ) +import Pair import CoreUtils ( mkPiTypes ) import CoreUnfold ( mkDFunUnfolding ) -import CoreSyn ( Expr(Var), DFunArg(..), CoreExpr ) +import CoreSyn ( Expr(Var), CoreExpr, varToCoreExpr ) +import PrelNames ( typeableClassNames ) + import Id import MkId import Name @@ -182,13 +187,14 @@ Note [Single-method classes] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~ If the class has just one method (or, more accurately, just one element -of {superclasses + methods}), then we still use the *same* strategy +of {superclasses + methods}), then we use a different strategy. class C a where op :: a -> a instance C a => C [a] where op = -We translate the class decl into a newtype, which just gives -a top-level axiom: +We translate the class decl into a newtype, which just gives a +top-level axiom. The "constructor" MkC expands to a cast, as does the +class-op selector. axiom Co:C a :: C a ~ (a->a) @@ -198,44 +204,82 @@ MkC :: forall a. (a->a) -> C a MkC = /\a.\op. op |> (sym Co:C a) - df :: forall a. C a => C [a] - {-# NOINLINE df DFun[ $cop_list ] #-} - df = /\a. \d. MkC ($cop_list a d) +The clever RULE stuff doesn't work now, because ($df a d) isn't +a constructor application, so exprIsConApp_maybe won't return +Just . + +Instead, we simply rely on the fact that casts are cheap: + + $df :: forall a. C a => C [a] + {-# INLINE df #-} -- NB: INLINE this + $df = /\a. \d. MkC [a] ($cop_list a d) + = $cop_list |> forall a. C a -> (sym (Co:C [a])) $cop_list :: forall a. C a => [a] -> [a] $cop_list = -The "constructor" MkC expands to a cast, as does the class-op selector. -The RULE works just like for multi-field dictionaries: - - * (df a d) returns (Just (MkC,..,[$cop_list a d])) - to exprIsConApp_Maybe - - * The RULE for op picks the right result +So if we see + (op ($df a d)) +we'll inline 'op' and '$df', since both are simply casts, and +good things happen. + +Why do we use this different strategy? Because otherwise we +end up with non-inlined dictionaries that look like + $df = $cop |> blah +which adds an extra indirection to every use, which seems stupid. See +Trac #4138 for an example (although the regression reported there +wasn't due to the indirction). -This is a bit of a hack, because (df a d) isn't *really* a constructor -application. But it works just fine in this case, exprIsConApp_maybe -is otherwise used only when we hit a case expression which will have -a real data constructor in it. - -The biggest reason for doing it this way, apart from uniformity, is -that we want to be very careful when we have +There is an awkward wrinkle though: we want to be very +careful when we have instance C a => C [a] where {-# INLINE op #-} op = ... then we'll get an INLINE pragma on $cop_list but it's important that $cop_list only inlines when it's applied to *two* arguments (the -dictionary and the list argument +dictionary and the list argument). So we nust not eta-expand $df +above. We ensure that this doesn't happen by putting an INLINE +pragma on the dfun itself; after all, it ends up being just a cast. + +There is one more dark corner to the INLINE story, even more deeply +buried. Consider this (Trac #3772): + + class DeepSeq a => C a where + gen :: Int -> a + + instance C a => C [a] where + gen n = ... -The danger is that we'll get something like - op_list :: C a => [a] -> [a] - op_list = /\a.\d. $cop_list a d -and then we'll eta expand, and then we'll inline TOO EARLY. This happened in -Trac #3772 and I spent far too long fiddling around trying to fix it. -Look at the test for Trac #3772. + class DeepSeq a where + deepSeq :: a -> b -> b - (Note: re-reading the above, I can't see how using the - uniform story solves the problem.) + instance DeepSeq a => DeepSeq [a] where + {-# INLINE deepSeq #-} + deepSeq xs b = foldr deepSeq b xs + +That gives rise to these defns: + + $cdeepSeq :: DeepSeq a -> [a] -> b -> b + -- User INLINE( 3 args )! + $cdeepSeq a (d:DS a) b (x:[a]) (y:b) = ... + + $fDeepSeq[] :: DeepSeq a -> DeepSeq [a] + -- DFun (with auto INLINE pragma) + $fDeepSeq[] a d = $cdeepSeq a d |> blah + + $cp1 a d :: C a => DeepSep [a] + -- We don't want to eta-expand this, lest + -- $cdeepSeq gets inlined in it! + $cp1 a d = $fDeepSep[] a (scsel a d) + + $fC[] :: C a => C [a] + -- Ordinary DFun + $fC[] a d = MkC ($cp1 a d) ($cgen a d) + +Here $cp1 is the code that generates the superclass for C [a]. The +issue is this: we must not eta-expand $cp1 either, or else $fDeepSeq[] +and then $cdeepSeq will inline there, which is definitely wrong. Like +on the dfun, we solve this by adding an INLINE pragma to $cp1. Note [Subtle interaction of recursion and overlap] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -331,59 +375,69 @@ ; let { (local_info, at_tycons_s) = unzip local_info_tycons ; at_idx_tycons = concat at_tycons_s ++ idx_tycons - ; clas_decls = filter (isClassDecl . unLoc) tycl_decls - ; implicit_things = concatMap implicitTyThings at_idx_tycons - ; aux_binds = mkRecSelBinds at_idx_tycons - } + ; implicit_things = concatMap implicitTyConThings at_idx_tycons + ; aux_binds = mkRecSelBinds at_idx_tycons } -- (2) Add the tycons of indexed types and their implicit -- tythings to the global environment - ; tcExtendGlobalEnv (at_idx_tycons ++ implicit_things) $ do { + ; tcExtendGlobalEnv (map ATyCon at_idx_tycons ++ implicit_things) $ do { - -- (3) Instances from generic class declarations - ; generic_inst_info <- getGenericInstances clas_decls -- Next, construct the instance environment so far, consisting -- of -- (a) local instance decls - -- (b) generic instances - -- (c) local family instance decls + -- (b) local family instance decls ; addInsts local_info $ - addInsts generic_inst_info $ addFamInsts at_idx_tycons $ do { - -- (4) Compute instances from "deriving" clauses; + -- (3) Compute instances from "deriving" clauses; -- This stuff computes a context for the derived instance -- decl, so it needs to know about all the instances possible -- NB: class instance declarations can contain derivings as -- part of associated data type declarations - failIfErrsM -- If the addInsts stuff gave any errors, don't - -- try the deriving stuff, becuase that may give - -- more errors still - ; (deriv_inst_info, deriv_binds, deriv_dus) + failIfErrsM -- If the addInsts stuff gave any errors, don't + -- try the deriving stuff, because that may give + -- more errors still + ; (deriv_inst_info, deriv_binds, deriv_dus, deriv_tys, deriv_ty_insts) <- tcDeriving tycl_decls inst_decls deriv_decls - ; gbl_env <- addInsts deriv_inst_info getGblEnv + + -- Extend the global environment also with the generated datatypes for + -- the generic representation + ; let all_tycons = map ATyCon (deriv_tys ++ deriv_ty_insts) + ; gbl_env <- tcExtendGlobalEnv all_tycons $ + tcExtendGlobalEnv (concatMap implicitTyThings all_tycons) $ + addFamInsts deriv_ty_insts $ + addInsts deriv_inst_info getGblEnv + + -- Check that if the module is compiled with -XSafe, there are no + -- hand written instances of Typeable as then unsafe casts could be + -- performed. Derivied instances are OK. + ; dflags <- getDOpts + ; when (safeLanguageOn dflags) $ + mapM_ (\x -> when (is_cls (iSpec x) `elem` typeableClassNames) + (addErrAt (getSrcSpan $ iSpec x) typInstErr)) + local_info + ; return ( addTcgDUs gbl_env deriv_dus, - generic_inst_info ++ deriv_inst_info ++ local_info, + deriv_inst_info ++ local_info, aux_binds `plusHsValBinds` deriv_binds) }}} + where + typInstErr = ptext $ sLit $ "Can't create hand written instances of Typeable in Safe" + ++ " Haskell! Can only derive them" addInsts :: [InstInfo Name] -> TcM a -> TcM a addInsts infos thing_inside = tcExtendLocalInstEnv (map iSpec infos) thing_inside -addFamInsts :: [TyThing] -> TcM a -> TcM a +addFamInsts :: [TyCon] -> TcM a -> TcM a addFamInsts tycons thing_inside - = tcExtendLocalFamInstEnv (map mkLocalFamInstTyThing tycons) thing_inside - where - mkLocalFamInstTyThing (ATyCon tycon) = mkLocalFamInst tycon - mkLocalFamInstTyThing tything = pprPanic "TcInstDcls.addFamInsts" - (ppr tything) + = tcExtendLocalFamInstEnv (map mkLocalFamInst tycons) thing_inside \end{code} \begin{code} tcLocalInstDecl1 :: LInstDecl Name - -> TcM (InstInfo Name, [TyThing]) + -> TcM (InstInfo Name, [TyCon]) -- A source-file instance declaration -- Type-check all the stuff before the "where" -- @@ -427,7 +481,7 @@ checkValidAndMissingATs :: Class -> ([TyVar], [TcType]) -- instance types -> [(LTyClDecl Name, -- source form of AT - TyThing)] -- Core form of AT + TyCon)] -- Core form of AT -> TcM () checkValidAndMissingATs clas inst_tys ats = do { -- Issue a warning for each class AT that is not defined in this @@ -435,7 +489,7 @@ ; let class_ats = map tyConName (classATs clas) defined_ats = listToNameSet . map (tcdName.unLoc.fst) $ ats omitted = filterOut (`elemNameSet` defined_ats) class_ats - ; warn <- doptM Opt_WarnMissingMethods + ; warn <- woptM Opt_WarnMissingMethods ; mapM_ (warnTc warn . omittedATWarn) omitted -- Ensure that all AT indexes that correspond to class parameters @@ -445,12 +499,11 @@ ; mapM_ (checkIndexes clas inst_tys) ats } - checkIndexes clas inst_tys (hsAT, ATyCon tycon) + checkIndexes clas inst_tys (hsAT, tycon) -- !!!TODO: check that this does the Right Thing for indexed synonyms, too! = checkIndexes' clas inst_tys hsAT (tyConTyVars tycon, snd . fromJust . tyConFamInst_maybe $ tycon) - checkIndexes _ _ _ = panic "checkIndexes" checkIndexes' clas (instTvs, instTys) hsAT (atTvs, atTys) = let atName = tcdName . unLoc $ hsAT @@ -510,8 +563,8 @@ | isTyVarTy ty = return () | otherwise = addErrTc $ mustBeVarArgErr ty checkIndex ty (Just instTy) - | ty `tcEqType` instTy = return () - | otherwise = addErrTc $ wrongATArgErr ty instTy + | ty `eqType` instTy = return () + | otherwise = addErrTc $ wrongATArgErr ty instTy listToNameSet = addListToNameSet emptyNameSet @@ -524,7 +577,182 @@ tv1 `sameLexeme` tv2 = nameOccName (tyVarName tv1) == nameOccName (tyVarName tv2) in - extendTvSubst (substSameTyVar tvs replacingTvs) tv replacement + TcType.extendTvSubst (substSameTyVar tvs replacingTvs) tv replacement +\end{code} + + +%************************************************************************ +%* * + Type checking family instances +%* * +%************************************************************************ + +Family instances are somewhat of a hybrid. They are processed together with +class instance heads, but can contain data constructors and hence they share a +lot of kinding and type checking code with ordinary algebraic data types (and +GADTs). + +\begin{code} +tcFamInstDecl :: TopLevelFlag -> LTyClDecl Name -> TcM TyCon +tcFamInstDecl top_lvl (L loc decl) + = -- Prime error recovery, set source location + setSrcSpan loc $ + tcAddDeclCtxt decl $ + do { -- type family instances require -XTypeFamilies + -- and can't (currently) be in an hs-boot file + ; type_families <- xoptM Opt_TypeFamilies + ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file? + ; checkTc type_families $ badFamInstDecl (tcdLName decl) + ; checkTc (not is_boot) $ badBootFamInstDeclErr + + -- Perform kind and type checking + ; tc <- tcFamInstDecl1 decl + ; checkValidTyCon tc -- Remember to check validity; + -- no recursion to worry about here + + -- Check that toplevel type instances are not for associated types. + ; when (isTopLevel top_lvl && isAssocFamily tc) + (addErr $ assocInClassErr (tcdName decl)) + + ; return tc } + +isAssocFamily :: TyCon -> Bool -- Is an assocaited type +isAssocFamily tycon + = case tyConFamInst_maybe tycon of + Nothing -> panic "isAssocFamily: no family?!?" + Just (fam, _) -> isTyConAssoc fam + +assocInClassErr :: Name -> SDoc +assocInClassErr name + = ptext (sLit "Associated type") <+> quotes (ppr name) <+> + ptext (sLit "must be inside a class instance") + + + +tcFamInstDecl1 :: TyClDecl Name -> TcM TyCon + + -- "type instance" +tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name}) + = kcIdxTyPats decl $ \k_tvs k_typats resKind family -> + do { -- check that the family declaration is for a synonym + checkTc (isFamilyTyCon family) (notFamily family) + ; checkTc (isSynTyCon family) (wrongKindOfFamily family) + + ; -- (1) kind check the right-hand side of the type equation + ; k_rhs <- kcCheckLHsType (tcdSynRhs decl) (EK resKind EkUnk) + -- ToDo: the ExpKind could be better + + -- we need the exact same number of type parameters as the family + -- declaration + ; let famArity = tyConArity family + ; checkTc (length k_typats == famArity) $ + wrongNumberOfParmsErr famArity + + -- (2) type check type equation + ; tcTyVarBndrs k_tvs $ \t_tvs -> do { -- turn kinded into proper tyvars + ; t_typats <- mapM tcHsKindedType k_typats + ; t_rhs <- tcHsKindedType k_rhs + + -- (3) check the well-formedness of the instance + ; checkValidTypeInst t_typats t_rhs + + -- (4) construct representation tycon + ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc + ; buildSynTyCon rep_tc_name t_tvs (SynonymTyCon t_rhs) + (typeKind t_rhs) + NoParentTyCon (Just (family, t_typats)) + }} + + -- "newtype instance" and "data instance" +tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, + tcdCons = cons}) + = kcIdxTyPats decl $ \k_tvs k_typats resKind fam_tycon -> + do { -- check that the family declaration is for the right kind + checkTc (isFamilyTyCon fam_tycon) (notFamily fam_tycon) + ; checkTc (isAlgTyCon fam_tycon) (wrongKindOfFamily fam_tycon) + + ; -- (1) kind check the data declaration as usual + ; k_decl <- kcDataDecl decl k_tvs + ; let k_ctxt = tcdCtxt k_decl + k_cons = tcdCons k_decl + + -- result kind must be '*' (otherwise, we have too few patterns) + ; checkTc (isLiftedTypeKind resKind) $ tooFewParmsErr (tyConArity fam_tycon) + + -- (2) type check indexed data type declaration + ; tcTyVarBndrs k_tvs $ \t_tvs -> do { -- turn kinded into proper tyvars + + -- kind check the type indexes and the context + ; t_typats <- mapM tcHsKindedType k_typats + ; stupid_theta <- tcHsKindedContext k_ctxt + + -- (3) Check that + -- (a) left-hand side contains no type family applications + -- (vanilla synonyms are fine, though, and we checked for + -- foralls earlier) + ; mapM_ checkTyFamFreeness t_typats + + ; dataDeclChecks tc_name new_or_data stupid_theta k_cons + + -- (4) construct representation tycon + ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc + ; let ex_ok = True -- Existentials ok for type families! + ; fixM (\ rep_tycon -> do + { let orig_res_ty = mkTyConApp fam_tycon t_typats + ; data_cons <- tcConDecls ex_ok rep_tycon + (t_tvs, orig_res_ty) k_cons + ; tc_rhs <- + case new_or_data of + DataType -> return (mkDataTyConRhs data_cons) + NewType -> ASSERT( not (null data_cons) ) + mkNewTyConRhs rep_tc_name rep_tycon (head data_cons) + ; buildAlgTyCon rep_tc_name t_tvs stupid_theta tc_rhs Recursive + h98_syntax NoParentTyCon (Just (fam_tycon, t_typats)) + -- We always assume that indexed types are recursive. Why? + -- (1) Due to their open nature, we can never be sure that a + -- further instance might not introduce a new recursive + -- dependency. (2) They are always valid loop breakers as + -- they involve a coercion. + }) + }} + where + h98_syntax = case cons of -- All constructors have same shape + L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False + _ -> True + +tcFamInstDecl1 d = pprPanic "tcFamInstDecl1" (ppr d) + +-- Kind checking of indexed types +-- - + +-- Kind check type patterns and kind annotate the embedded type variables. +-- +-- * Here we check that a type instance matches its kind signature, but we do +-- not check whether there is a pattern for each type index; the latter +-- check is only required for type synonym instances. + +kcIdxTyPats :: TyClDecl Name + -> ([LHsTyVarBndr Name] -> [LHsType Name] -> Kind -> TyCon -> TcM a) + -- ^^kinded tvs ^^kinded ty pats ^^res kind + -> TcM a +kcIdxTyPats decl thing_inside + = kcHsTyVars (tcdTyVars decl) $ \tvs -> + do { let tc_name = tcdLName decl + ; fam_tycon <- tcLookupLocatedTyCon tc_name + ; let { (kinds, resKind) = splitKindFunTys (tyConKind fam_tycon) + ; hs_typats = fromJust $ tcdTyPats decl } + + -- we may not have more parameters than the kind indicates + ; checkTc (length kinds >= length hs_typats) $ + tooManyParmsErr (tcdLName decl) + + -- type functions can have a higher-kinded result + ; let resultKind = mkArrowKinds (drop (length hs_typats) kinds) resKind + ; typats <- zipWithM kcCheckLHsType hs_typats + [ EK kind (EkArg (ppr tc_name) n) + | (kind,n) <- kinds `zip` [1..]] + ; thing_inside tvs typats resultKind fam_tycon + } \end{code} @@ -582,26 +810,17 @@ addErrCtxt (instDeclCtxt2 (idType dfun_id)) $ do { -- Instantiate the instance decl with skolem constants ; (inst_tyvars, dfun_theta, inst_head) <- tcSkolDFunType (idType dfun_id) + -- We instantiate the dfun_id with superSkolems. + -- See Note [Subtle interaction of recursion and overlap] + -- and Note [Binding when looking up instances] ; let (clas, inst_tys) = tcSplitDFunHead inst_head - (class_tyvars, sc_theta, _, op_items) = classBigSig clas + (class_tyvars, sc_theta, sc_sels, op_items) = classBigSig clas sc_theta' = substTheta (zipOpenTvSubst class_tyvars inst_tys) sc_theta - n_ty_args = length inst_tyvars - n_silent = dfunNSilent dfun_id - (silent_theta, orig_theta) = splitAt n_silent dfun_theta - - ; silent_ev_vars <- mapM newSilentGiven silent_theta - ; orig_ev_vars <- newEvVars orig_theta - ; let dfun_ev_vars = silent_ev_vars ++ orig_ev_vars - - ; (sc_dicts, sc_args) - <- mapAndUnzipM (tcSuperClass n_ty_args dfun_ev_vars) sc_theta' - - -- Check that any superclasses gotten from a silent arguemnt - -- can be deduced from the originally-specified dfun arguments - ; ct_loc <- getCtLoc ScOrigin - ; _ <- checkConstraints skol_info inst_tyvars orig_ev_vars $ - emitFlats $ listToBag $ - [ mkEvVarX sc ct_loc | sc <- sc_dicts, isSilentEvVar sc ] + ; dfun_ev_vars <- newEvVars dfun_theta + + ; (sc_args, sc_binds) + <- mapAndUnzipM (tcSuperClass inst_tyvars dfun_ev_vars) + (sc_sels `zip` sc_theta') -- Deal with 'SPECIALISE instance' pragmas -- See Note [SPECIALISE instance pragmas] @@ -619,31 +838,50 @@ -- Create the result bindings ; self_dict <- newEvVar (ClassP clas inst_tys) - ; let dict_constr = classDataCon clas - dict_bind = mkVarBind self_dict dict_rhs - dict_rhs = foldl mk_app inst_constr $ - map HsVar sc_dicts ++ map (wrapId arg_wrapper) meth_ids - inst_constr = L loc $ wrapId (mkWpTyApps inst_tys) - (dataConWrapId dict_constr) + ; let class_tc = classTyCon clas + [dict_constr] = tyConDataCons class_tc + dict_bind = mkVarBind self_dict (L loc con_app_args) + -- We don't produce a binding for the dict_constr; instead we -- rely on the simplifier to unfold this saturated application -- We do this rather than generate an HsCon directly, because -- it means that the special cases (e.g. dictionary with only one - -- member) are dealt with by the common MkId.mkDataConWrapId code rather - -- than needing to be repeated here. + -- member) are dealt with by the common MkId.mkDataConWrapId + -- code rather than needing to be repeated here. + -- con_app_tys = MkD ty1 ty2 + -- con_app_scs = MkD ty1 ty2 sc1 sc2 + -- con_app_args = MkD ty1 ty2 sc1 sc2 op1 op2 + con_app_tys = wrapId (mkWpTyApps inst_tys) + (dataConWrapId dict_constr) + con_app_scs = mkHsWrap (mkWpEvApps (map mk_sc_ev_term sc_args)) con_app_tys + con_app_args = foldl mk_app con_app_scs $ + map (wrapId arg_wrapper) meth_ids + + mk_app :: HsExpr Id -> HsExpr Id -> HsExpr Id + mk_app fun arg = HsApp (L loc fun) (L loc arg) + + mk_sc_ev_term :: EvVar -> EvTerm + mk_sc_ev_term sc + | null inst_tv_tys + , null dfun_ev_vars = evVarTerm sc + | otherwise = EvDFunApp sc inst_tv_tys dfun_ev_vars - mk_app :: LHsExpr Id -> HsExpr Id -> LHsExpr Id - mk_app fun arg = L loc (HsApp fun (L loc arg)) - - arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps (mkTyVarTys inst_tyvars) + inst_tv_tys = mkTyVarTys inst_tyvars + arg_wrapper = mkWpEvVarApps dfun_ev_vars <.> mkWpTyApps inst_tv_tys -- Do not inline the dfun; instead give it a magic DFunFunfolding -- See Note [ClassOp/DFun selection] -- See also note [Single-method classes] - dfun_id_w_fun = dfun_id - `setIdUnfolding` mkDFunUnfolding dfun_ty (sc_args ++ meth_args) - `setInlinePragma` dfunInlinePragma - meth_args = map (DFunPolyArg . Var) meth_ids + dfun_id_w_fun + | isNewTyCon class_tc + = dfun_id `setInlinePragma` alwaysInlinePragma { inl_sat = Just 0 } + | otherwise + = dfun_id `setIdUnfolding` mkDFunUnfolding dfun_ty dfun_args + `setInlinePragma` dfunInlinePragma + + dfun_args :: [CoreExpr] + dfun_args = map varToCoreExpr sc_args ++ + map Var meth_ids main_bind = AbsBinds { abs_tvs = inst_tyvars , abs_ev_vars = dfun_ev_vars @@ -653,30 +891,40 @@ , abs_binds = unitBag dict_bind } ; return (unitBag (L loc main_bind) `unionBags` - listToBag meth_binds) + listToBag meth_binds `unionBags` + unionManyBags sc_binds) } where - skol_info = InstSkol -- See Note [Subtle interaction of recursion and overlap] dfun_ty = idType dfun_id dfun_id = instanceDFunId ispec loc = getSrcSpan dfun_id ------------------------------ -tcSuperClass :: Int -> [EvVar] -> PredType -> TcM (EvVar, DFunArg CoreExpr) --- All superclasses should be either --- (a) be one of the arguments to the dfun, of --- (b) be a constant, soluble at top level -tcSuperClass n_ty_args ev_vars pred - | Just (ev, i) <- find n_ty_args ev_vars - = return (ev, DFunLamArg i) - | otherwise - = ASSERT2( isEmptyVarSet (tyVarsOfPred pred), ppr pred) -- Constant! - do { sc_dict <- emitWanted ScOrigin pred - ; return (sc_dict, DFunConstArg (Var sc_dict)) } - where - find _ [] = Nothing - find i (ev:evs) | pred `tcEqPred` evVarPred ev = Just (ev, i) - | otherwise = find (i+1) evs +tcSuperClass :: [TcTyVar] -> [EvVar] + -> (Id, PredType) + -> TcM (TcId, LHsBinds TcId) + +-- Build a top level decl like +-- sc_op = /\a \d. let sc = ... in +-- sc +-- and return sc_op, that binding + +tcSuperClass tyvars ev_vars (sc_sel, sc_pred) + = do { (ev_binds, sc_dict) + <- newImplication InstSkol tyvars ev_vars $ + emitWanted ScOrigin sc_pred + + ; uniq <- newUnique + ; let sc_op_ty = mkForAllTys tyvars $ mkPiTypes ev_vars (varType sc_dict) + sc_op_name = mkDerivedInternalName mkClassOpAuxOcc uniq + (getName sc_sel) + sc_op_id = mkLocalId sc_op_name sc_op_ty + sc_op_bind = mkVarBind sc_op_id (L noSrcSpan $ wrapId sc_wrapper sc_dict) + sc_wrapper = mkWpTyLams tyvars + <.> mkWpLams ev_vars + <.> mkWpLet ev_binds + + ; return (sc_op_id, unitBag sc_op_bind) } ------------------------------ tcSpecInstPrags :: DFunId -> InstBindings Name @@ -690,74 +938,26 @@ ; return (spec_inst_prags, mkPragFun uprags binds) } \end{code} -Note [Silent Superclass Arguments] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Note [Superclass loop avoidance] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider the following (extreme) situation: class C a => D a where ... instance D [a] => D [a] where ... Although this looks wrong (assume D [a] to prove D [a]), it is only a -more extreme case of what happens with recursive dictionaries. +more extreme case of what happens with recursive dictionaries, and it +can, just about, make sense because the methods do some work before +recursing. To implement the dfun we must generate code for the superclass C [a], -which we can get by superclass selection from the supplied argument! -So we’d generate: +which we had better not get by superclass selection from the supplied +argument: dfun :: forall a. D [a] -> D [a] dfun = \d::D [a] -> MkD (scsel d) .. -However this means that if we later encounter a situation where -we have a [Wanted] dw::D [a] we could solve it thus: - dw := dfun dw -Although recursive, this binding would pass the TcSMonadisGoodRecEv -check because it appears as guarded. But in reality, it will make a -bottom superclass. The trouble is that isGoodRecEv can't "see" the -superclass-selection inside dfun. - -Our solution to this problem is to change the way ‘dfuns’ are created -for instances, so that we pass as first arguments to the dfun some -``silent superclass arguments’’, which are the immediate superclasses -of the dictionary we are trying to construct. In our example: - dfun :: forall a. (C [a], D [a] -> D [a] - dfun = \(dc::C [a]) (dd::D [a]) -> DOrd dc ... - -This gives us: - - ----------------------------------------------------------- - DFun Superclass Invariant - ~~~~~~~~~~~~~~~~~~~~~~~~ - In the body of a DFun, every superclass argument to the - returned dictionary is - either * one of the arguments of the DFun, - or * constant, bound at top level - ----------------------------------------------------------- - -This means that no superclass is hidden inside a dfun application, so -the counting argument in isGoodRecEv (more dfun calls than superclass -selections) works correctly. - -The extra arguments required to satisfy the DFun Superclass Invariant -always come first, and are called the "silent" arguments. DFun types -are built (only) by MkId.mkDictFunId, so that is where we decide -what silent arguments are to be added. - -This net effect is that it is safe to treat a dfun application as -wrapping a dictionary constructor around its arguments (in particular, -a dfun never picks superclasses from the arguments under the dictionary -constructor). - -In our example, if we had [Wanted] dw :: D [a] we would get via the instance: - dw := dfun d1 d2 - [Wanted] (d1 :: C [a]) - [Wanted] (d2 :: D [a]) - [Derived] (d :: D [a]) - [Derived] (scd :: C [a]) scd := scsel d - [Derived] (scd2 :: C [a]) scd2 := scsel d2 - -And now, though we *can* solve: - d2 := dw -we will get an isGoodRecEv failure when we try to solve: - d1 := scsel d - or - d1 := scsel d2 +Rather, we want to get it by finding an instance for (C [a]). We +achieve this by + not making the superclasses of a "wanted" + available for solving wanted constraints. Test case SCLoop tests this fix. @@ -809,7 +1009,7 @@ = addErrCtxt (spec_ctxt prag) $ do { let name = idName dfun_id ; (tyvars, theta, clas, tys) <- tcHsInstHead hs_ty - ; let (_, spec_dfun_ty) = mkDictFunTy tyvars theta clas tys + ; let spec_dfun_ty = mkDictFunTy tyvars theta clas tys ; co_fn <- tcSubType (SpecPragOrigin name) SpecInstCtxt (idType dfun_id) spec_dfun_ty @@ -874,10 +1074,11 @@ ---------------------- tc_default :: Id -> DefMeth -> TcM (TcId, LHsBind Id) - tc_default sel_id GenDefMeth -- Derivable type classes stuff - = do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id + + tc_default sel_id (GenDefMeth dm_name) + = do { meth_bind <- mkGenericDefMethBind clas inst_tys sel_id dm_name ; tc_body sel_id False {- Not generated code? -} meth_bind } - + tc_default sel_id NoDefMeth -- No default method at all = do { warnMissingMethod sel_id ; (meth_id, _) <- mkMethIds clas tyvars dfun_ev_vars @@ -912,14 +1113,12 @@ rhs = HsWrap (mkWpEvVarApps [self_dict] <.> mkWpTyApps inst_tys) $ HsVar dm_id - meth_bind = L loc $ VarBind { var_id = local_meth_id - , var_rhs = L loc rhs - , var_inline = False } + meth_bind = mkVarBind local_meth_id (L loc rhs) meth_id1 = meth_id `setInlinePragma` dm_inline_prag - -- Copy the inline pragma (if any) from the default - -- method to this version. Note [INLINE and default methods] + -- Copy the inline pragma (if any) from the default + -- method to this version. Note [INLINE and default methods] - bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars + bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars , abs_exports = [( tyvars, meth_id1, local_meth_id , mk_meth_spec_prags meth_id1 [])] , abs_ev_binds = EvBinds (unitBag self_ev_bind) @@ -999,13 +1198,13 @@ inst_tvs = fst (tcSplitForAllTys (idType dfun_id)) Just (init_inst_tys, _) = snocView inst_tys - rep_ty = fst (coercionKind co) -- [p] + rep_ty = pFst (coercionKind co) -- [p] rep_pred = mkClassPred clas (init_inst_tys ++ [rep_ty]) -- co : [p] ~ T p - co = substTyWith inst_tvs (mkTyVarTys tyvars) $ - case coi of { IdCo ty -> ty ; - ACo co -> mkSymCoercion co } + co = substCoWithTys (mkInScopeSet (mkVarSet tyvars)) + inst_tvs (mkTyVarTys tyvars) $ + mkSymCo coi ---------------- tc_item :: (TcEvBinds, EvVar) -> (Id, DefMeth) -> TcM (TcId, LHsBind TcId) @@ -1014,22 +1213,20 @@ inst_tys sel_id ; let meth_rhs = wrapId (mk_op_wrapper sel_id rep_d) sel_id - meth_bind = VarBind { var_id = local_meth_id - , var_rhs = L loc meth_rhs - , var_inline = False } - + meth_bind = mkVarBind local_meth_id (L loc meth_rhs) bind = AbsBinds { abs_tvs = tyvars, abs_ev_vars = dfun_ev_vars , abs_exports = [(tyvars, meth_id, local_meth_id, noSpecPrags)] , abs_ev_binds = rep_ev_binds - , abs_binds = unitBag $ L loc meth_bind } + , abs_binds = unitBag $ meth_bind } ; return (meth_id, L loc bind) } ---------------- mk_op_wrapper :: Id -> EvVar -> HsWrapper mk_op_wrapper sel_id rep_d - = WpCast (substTyWith sel_tvs (init_inst_tys ++ [co]) local_meth_ty) + = WpCast (liftCoSubstWith sel_tvs (map mkReflCo init_inst_tys ++ [co]) + local_meth_ty) <.> WpEvApp (EvId rep_d) <.> mkWpTyApps (init_inst_tys ++ [rep_ty]) where @@ -1070,7 +1267,7 @@ warnMissingMethod :: Id -> TcM () warnMissingMethod sel_id - = do { warn <- doptM Opt_WarnMissingMethods + = do { warn <- woptM Opt_WarnMissingMethods ; warnTc (warn -- Warn only if -fwarn-missing-methods && not (startsWithUnderscore (getOccName sel_id))) -- Don't warn about _foo methods @@ -1197,7 +1394,7 @@ instDeclCtxt2 dfun_ty = inst_decl_ctxt (ppr (mkClassPred cls tys)) where - (_,cls,tys) = tcSplitDFunTy dfun_ty + (_,_,cls,tys) = tcSplitDFunTy dfun_ty inst_decl_ctxt :: SDoc -> SDoc inst_decl_ctxt doc = ptext (sLit "In the instance declaration for") <+> quotes doc @@ -1219,4 +1416,37 @@ , ptext (sLit "Found") <+> quotes (ppr ty) <+> ptext (sLit "but expected") <+> quotes (ppr instTy) ] + +tooManyParmsErr :: Located Name -> SDoc +tooManyParmsErr tc_name + = ptext (sLit "Family instance has too many parameters:") <+> + quotes (ppr tc_name) + +tooFewParmsErr :: Arity -> SDoc +tooFewParmsErr arity + = ptext (sLit "Family instance has too few parameters; expected") <+> + ppr arity + +wrongNumberOfParmsErr :: Arity -> SDoc +wrongNumberOfParmsErr exp_arity + = ptext (sLit "Number of parameters must match family declaration; expected") + <+> ppr exp_arity + +badBootFamInstDeclErr :: SDoc +badBootFamInstDeclErr + = ptext (sLit "Illegal family instance in hs-boot file") + +notFamily :: TyCon -> SDoc +notFamily tycon + = vcat [ ptext (sLit "Illegal family instance for") <+> quotes (ppr tycon) + , nest 2 $ parens (ppr tycon <+> ptext (sLit "is not an indexed type family"))] + +wrongKindOfFamily :: TyCon -> SDoc +wrongKindOfFamily family + = ptext (sLit "Wrong category of family instance; declaration was for a") + <+> kindOfFamily + where + kindOfFamily | isSynTyCon family = ptext (sLit "type synonym") + | isAlgTyCon family = ptext (sLit "data type") + | otherwise = pprPanic "wrongKindOfFamily" (ppr family) \end{code} diff -Nru ghc-7.0.3/compiler/typecheck/TcInteract.lhs ghc-7.2.1/compiler/typecheck/TcInteract.lhs --- ghc-7.0.3/compiler/typecheck/TcInteract.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/typecheck/TcInteract.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -12,6 +12,7 @@ import TcCanonical import VarSet import Type +import Unify import Id import Var @@ -32,6 +33,7 @@ import TcRnTypes import TcErrors import TcSMonad +import Maybes( orElse ) import Bag import qualified Data.Map as Map @@ -68,8 +70,11 @@ will be marked as solved right before being pushed into the inert set. See note [Touchables and givens]. - 8 No Given constraint mentions a touchable unification variable, - except if the + 8 No Given constraint mentions a touchable unification variable, but + Given/Solved may do so. + + 9 Given constraints will also have their superclasses in the inert set, + but Given/Solved will not. Note that 6 and 7 are /not/ enforced by canonicalization but rather by insertion in the inert list, ie by TcInteract. @@ -158,7 +163,8 @@ , vcat (map ppr (Bag.bagToList $ cCanMapToBag (inert_dicts is))) , vcat (map ppr (Bag.bagToList $ cCanMapToBag (inert_ips is))) , vcat (map ppr (Bag.bagToList $ cCanMapToBag (inert_funeqs is))) - , vcat (map ppr (Bag.bagToList $ inert_frozen is)) + , text "Frozen errors =" <+> -- Clearly print frozen errors + vcat (map ppr (Bag.bagToList $ inert_frozen is)) ] emptyInert :: InertSet @@ -192,7 +198,7 @@ , inert_funeqs = solved_funeqs } in (is_solved, unsolved) - where (unsolved_eqs, solved_eqs) = Bag.partitionBag (not.isGivenCt) eqs + where (unsolved_eqs, solved_eqs) = Bag.partitionBag (not.isGivenOrSolvedCt) eqs (unsolved_ips, solved_ips) = extractUnsolvedCMap (inert_ips is) (unsolved_dicts, solved_dicts) = extractUnsolvedCMap (inert_dicts is) (unsolved_funeqs, solved_funeqs) = extractUnsolvedCMap (inert_funeqs is) @@ -225,22 +231,6 @@ type AtomicInert = CanonicalCt -- constraint pulled from InertSet type WorkItem = CanonicalCt -- constraint pulled from WorkList --- A mixture of Given, Wanted, and Derived constraints. --- We split between equalities and the rest to process equalities first. -type WorkList = CanonicalCts - -unionWorkLists :: WorkList -> WorkList -> WorkList -unionWorkLists = andCCan - -isEmptyWorkList :: WorkList -> Bool -isEmptyWorkList = isEmptyCCan - -emptyWorkList :: WorkList -emptyWorkList = emptyCCan - -workListFromCCan :: CanonicalCt -> WorkList -workListFromCCan = singleCCan - ------------------------ data StopOrContinue = Stop -- Work item is consumed @@ -305,7 +295,7 @@ , sr_stop = ContinueWith work_item }) = do { itr <- stage depth work_item inerts ; traceTcS ("Stage result (" ++ name ++ ")") (ppr itr) - ; let itr' = itr { sr_new_work = accum_work `unionWorkLists` sr_new_work itr } + ; let itr' = itr { sr_new_work = accum_work `unionWorkList` sr_new_work itr } ; run_pipeline stages itr' } \end{code} @@ -343,7 +333,7 @@ map mk_given evs ; return inert_ret } where - flav = Given gloc + flav = Given gloc GivenOrig mk_given ev = mkEvVarX ev flav solveInteractWanted :: InertSet -> [WantedEvVar] -> TcS InertSet @@ -365,7 +355,10 @@ -> (ct,evVarPred ev)) ws) , text "inert = " <+> ppr inert ] - ; (flag, inert_ret) <- foldlBagM (tryPreSolveAndInteract sctx dyn_flags) (True,inert) ws + ; can_ws <- mkCanonicalFEVs ws + + ; (flag, inert_ret) + <- foldrWorkListM (tryPreSolveAndInteract sctx dyn_flags) (True,inert) can_ws ; traceTcS "solveInteract, after clever canonicalization (and interaction):" $ vcat [ text "No interaction happened = " <+> ppr flag @@ -373,29 +366,32 @@ ; return (flag, inert_ret) } - tryPreSolveAndInteract :: SimplContext -> DynFlags + -> CanonicalCt -> (Bool, InertSet) - -> FlavoredEvVar -> TcS (Bool, InertSet) -- Returns: True if it was able to discharge this constraint AND all previous ones -tryPreSolveAndInteract sctx dyn_flags (all_previous_discharged, inert) - flavev@(EvVarX ev_var fl) +tryPreSolveAndInteract sctx dyn_flags ct (all_previous_discharged, inert) = do { let inert_cts = get_inert_cts (evVarPred ev_var) - ; this_one_discharged <- dischargeFromCCans inert_cts flavev + ; this_one_discharged <- + if isCFrozenErr ct then + return False + else + dischargeFromCCans inert_cts ev_var fl ; if this_one_discharged then return (all_previous_discharged, inert) else do - { extra_cts <- mkCanonical fl ev_var - ; inert_ret <- solveInteractWithDepth (ctxtStkDepth dyn_flags,0,[]) - inert extra_cts + { inert_ret <- solveOneWithDepth (ctxtStkDepth dyn_flags,0,[]) ct inert ; return (False, inert_ret) } } where + ev_var = cc_id ct + fl = cc_flavor ct + get_inert_cts (ClassP clas _) | simplEqsOnly sctx = emptyCCan | otherwise = fst (getRelevantCts clas (inert_dicts inert)) @@ -406,28 +402,24 @@ get_inert_cts (EqPred {}) = inert_eqs inert `unionBags` cCanMapToBag (inert_funeqs inert) -dischargeFromCCans :: CanonicalCts -> FlavoredEvVar -> TcS Bool +dischargeFromCCans :: CanonicalCts -> EvVar -> CtFlavor -> TcS Bool -- See if this (pre-canonicalised) work-item is identical to a -- one already in the inert set. Reasons: -- a) Avoid creating superclass constraints for millions of incoming (Num a) constraints -- b) Termination for improve_eqs in TcSimplify.simpl_loop -dischargeFromCCans cans (EvVarX ev fl) +dischargeFromCCans cans ev fl = Bag.foldrBag discharge_ct (return False) cans where the_pred = evVarPred ev discharge_ct :: CanonicalCt -> TcS Bool -> TcS Bool discharge_ct ct _rest - | evVarPred (cc_id ct) `tcEqPred` the_pred + | evVarPred (cc_id ct) `eqPred` the_pred , cc_flavor ct `canSolve` fl - = do { when (isWanted fl) $ set_ev_bind ev (cc_id ct) + = do { when (isWanted fl) $ setEvBind ev (evVarTerm (cc_id ct)) -- Deriveds need no evidence -- For Givens, we already have evidence, and we don't need it twice ; return True } - where - set_ev_bind x y - | EqPred {} <- evVarPred y = setEvBind x (EvCoercion (mkCoVarCoercion y)) - | otherwise = setEvBind x (EvId y) discharge_ct _ct rest = rest \end{code} @@ -448,16 +440,16 @@ constraints. \begin{code} -solveOne :: InertSet -> WorkItem -> TcS InertSet -solveOne inerts workItem +solveOne :: WorkItem -> InertSet -> TcS InertSet +solveOne workItem inerts = do { dyn_flags <- getDynFlags - ; solveOneWithDepth (ctxtStkDepth dyn_flags,0,[]) inerts workItem + ; solveOneWithDepth (ctxtStkDepth dyn_flags,0,[]) workItem inerts } ----------------- solveInteractWithDepth :: (Int, Int, [WorkItem]) - -> InertSet -> WorkList -> TcS InertSet -solveInteractWithDepth ctxt@(max_depth,n,stack) inert ws + -> WorkList -> InertSet -> TcS InertSet +solveInteractWithDepth ctxt@(max_depth,n,stack) ws inert | isEmptyWorkList ws = return inert @@ -467,26 +459,25 @@ | otherwise = do { traceTcS "solveInteractWithDepth" $ vcat [ text "Current depth =" <+> ppr n - , text "Max depth =" <+> ppr max_depth ] + , text "Max depth =" <+> ppr max_depth + , text "ws =" <+> ppr ws ] + - -- Solve equalities first - ; let (eqs, non_eqs) = Bag.partitionBag isCTyEqCan ws - ; is_from_eqs <- Bag.foldlBagM (solveOneWithDepth ctxt) inert eqs - ; Bag.foldlBagM (solveOneWithDepth ctxt) is_from_eqs non_eqs } + ; foldrWorkListM (solveOneWithDepth ctxt) inert ws } + -- use foldr to preserve the order ------------------ -- Fully interact the given work item with an inert set, and return a -- new inert set which has assimilated the new information. solveOneWithDepth :: (Int, Int, [WorkItem]) - -> InertSet -> WorkItem -> TcS InertSet -solveOneWithDepth (max_depth, depth, stack) inert work + -> WorkItem -> InertSet -> TcS InertSet +solveOneWithDepth (max_depth, depth, stack) work inert = do { traceFireTcS depth (text "Solving {" <+> ppr work) ; (new_inert, new_work) <- runSolverPipeline depth thePipeline inert work -- Recursively solve the new work generated -- from workItem, with a greater depth - ; res_inert <- solveInteractWithDepth (max_depth, depth+1, work:stack) - new_inert new_work + ; res_inert <- solveInteractWithDepth (max_depth, depth+1, work:stack) new_work new_inert ; traceFireTcS depth (text "Done }" <+> ppr work) @@ -542,7 +533,7 @@ , sr_stop = ContinueWith workItem } SPSolved workItem' - | not (isGivenCt workItem) + | not (isGivenOrSolvedCt workItem) -- Original was wanted or derived but we have now made him -- given so we have to interact him with the inerts due to -- its status change. This in turn may produce more work. @@ -583,7 +574,7 @@ -- See Note [Touchables and givens] trySpontaneousSolve :: WorkItem -> TcS SPSolveResult trySpontaneousSolve workItem@(CTyEqCan { cc_id = cv, cc_flavor = gw, cc_tyvar = tv1, cc_rhs = xi }) - | isGiven gw + | isGivenOrSolved gw = return SPCantSolve | Just tv2 <- tcGetTyVar_maybe xi = do { tch1 <- isTouchableMetaTyVar tv1 @@ -736,13 +727,13 @@ ] ; setWantedTyBind tv xi - ; cv_given <- newGivenCoVar (mkTyVarTy tv) xi xi + ; let refl_xi = mkReflCo xi + ; cv_given <- newGivenCoVar (mkTyVarTy tv) xi refl_xi - ; when (isWanted wd) (setCoBind cv xi) + ; when (isWanted wd) (setCoBind cv refl_xi) -- We don't want to do this for Derived, that's why we use 'when (isWanted wd)' - ; return $ SPSolved (CTyEqCan { cc_id = cv_given - , cc_flavor = mkGivenFlavor wd UnkSkol + , cc_flavor = mkSolvedFlavor wd UnkSkol , cc_tyvar = tv, cc_rhs = xi }) } \end{code} @@ -833,7 +824,8 @@ interactWithInertEqsStage :: SimplifierStage interactWithInertEqsStage depth workItem inert - = Bag.foldlBagM (interactNext depth) initITR (inert_eqs inert) + = Bag.foldrBagM (interactNext depth) initITR (inert_eqs inert) + -- use foldr to preserve the order where initITR = SR { sr_inerts = inert { inert_eqs = emptyCCan } , sr_new_work = emptyWorkList @@ -851,7 +843,8 @@ initITR = SR { sr_inerts = inert_residual , sr_new_work = emptyWorkList , sr_stop = ContinueWith workItem } - in Bag.foldlBagM (interactNext depth) initITR relevant + in Bag.foldrBagM (interactNext depth) initITR relevant + -- use foldr to preserve the order where getISRelevant :: CanonicalCt -> InertSet -> (CanonicalCts, InertSet) getISRelevant (CFrozenErr {}) is = (emptyCCan, is) @@ -878,8 +871,8 @@ , inert_ips = emptyCCanMap , inert_funeqs = emptyCCanMap }) -interactNext :: SubGoalDepth -> StageResult -> AtomicInert -> TcS StageResult -interactNext depth it inert +interactNext :: SubGoalDepth -> AtomicInert -> StageResult -> TcS StageResult +interactNext depth inert it | ContinueWith work_item <- sr_stop it = do { let inerts = sr_inerts it @@ -891,7 +884,7 @@ = text rule <+> keep_doc <+> vcat [ ptext (sLit "Inert =") <+> ppr inert , ptext (sLit "Work =") <+> ppr work_item - , ppUnless (isEmptyBag new_work) $ + , ppUnless (isEmptyWorkList new_work) $ ptext (sLit "New =") <+> ppr new_work ] keep_doc = case inert_action of KeepInert -> ptext (sLit "[keep]") @@ -907,7 +900,7 @@ DropInert -> inerts ; return $ SR { sr_inerts = inerts_new - , sr_new_work = sr_new_work it `unionWorkLists` new_work + , sr_new_work = sr_new_work it `unionWorkList` new_work , sr_stop = stop } } | otherwise = return $ it { sr_inerts = (sr_inerts it) `updInertSet` inert } @@ -937,70 +930,77 @@ doInteractWithInert inertItem@(CDictCan { cc_id = d1, cc_flavor = fl1, cc_class = cls1, cc_tyargs = tys1 }) workItem@(CDictCan { cc_id = d2, cc_flavor = fl2, cc_class = cls2, cc_tyargs = tys2 }) - | cls1 == cls2 && (and $ zipWith tcEqType tys1 tys2) - = solveOneFromTheOther "Cls/Cls" (EvId d1,fl1) workItem - | cls1 == cls2 && (not (isGiven fl1 && isGiven fl2)) - = -- See Note [When improvement happens] - do { let pty1 = ClassP cls1 tys1 + | cls1 == cls2 + = do { let pty1 = ClassP cls1 tys1 pty2 = ClassP cls2 tys2 inert_pred_loc = (pty1, pprFlavorArising fl1) work_item_pred_loc = (pty2, pprFlavorArising fl2) - fd_eqns = improveFromAnother - inert_pred_loc -- the template - work_item_pred_loc -- the one we aim to rewrite - -- See Note [Efficient Orientation] - - ; m <- rewriteWithFunDeps fd_eqns tys2 fl2 - ; case m of - Nothing -> noInteraction workItem - Just (rewritten_tys2, cos2, fd_work) - | tcEqTypes tys1 rewritten_tys2 - -> -- Solve him on the spot in this case - case fl2 of - Given {} -> pprPanic "Unexpected given" (ppr inertItem $$ ppr workItem) - Derived {} -> mkIRStopK "Cls/Cls fundep (solved)" fd_work - Wanted {} - | isDerived fl1 - -> do { setDictBind d2 (EvCast d1 dict_co) - ; let inert_w = inertItem { cc_flavor = fl2 } + + ; any_fundeps + <- if isGivenOrSolved fl1 && isGivenOrSolved fl2 then return Nothing + -- NB: We don't create fds for given (and even solved), have not seen a useful + -- situation for these and even if we did we'd have to be very careful to only + -- create Derived's and not Wanteds. + + else let fd_eqns = improveFromAnother inert_pred_loc work_item_pred_loc + wloc = get_workitem_wloc fl2 + in rewriteWithFunDeps fd_eqns tys2 wloc + -- See Note [Efficient Orientation], [When improvement happens] + + ; case any_fundeps of + -- No Functional Dependencies + Nothing + | eqTypes tys1 tys2 -> solveOneFromTheOther "Cls/Cls" (EvId d1,fl1) workItem + | otherwise -> noInteraction workItem + + -- Actual Functional Dependencies + Just (rewritten_tys2,cos2,fd_work) + | not (eqTypes tys1 rewritten_tys2) + -- Standard thing: create derived fds and keep on going. Importantly we don't + -- throw workitem back in the worklist because this can cause loops. See #5236. + -> do { fd_cans <- mkCanonicalFDAsDerived fd_work + ; mkIRContinue "Cls/Cls fundep (not solved)" workItem KeepInert fd_cans } + + -- This WHOLE otherwise branch is an optimization where the fd made the things match + | otherwise + , let dict_co = mkTyConAppCo (classTyCon cls1) cos2 + -> case fl2 of + Given {} + -> pprPanic "Unexpected given!" (ppr inertItem $$ ppr workItem) + -- The only way to have created a fundep is if the inert was + -- wanted or derived, in which case the workitem can't be given! + Derived {} + -- The types were made to exactly match so we don't need + -- the workitem any longer. + -> do { fd_cans <- mkCanonicalFDAsDerived fd_work + -- No rewriting really, so let's create deriveds fds + ; mkIRStopK "Cls/Cls fundep (solved)" fd_cans } + Wanted {} + | isDerived fl1 + -> do { setDictBind d2 (EvCast d1 dict_co) + ; let inert_w = inertItem { cc_flavor = fl2 } -- A bit naughty: we take the inert Derived, -- turn it into a Wanted, use it to solve the work-item -- and put it back into the work-list - -- Maybe rather than starting again, we could *replace* the - -- inert item, but its safe and simple to restart - ; mkIRStopD "Cls/Cls fundep (solved)" (inert_w `consBag` fd_work) } - - | otherwise - -> do { setDictBind d2 (EvCast d1 dict_co) - ; mkIRStopK "Cls/Cls fundep (solved)" fd_work } - - | otherwise - -> -- We could not quite solve him, but we still rewrite him - -- Example: class C a b c | a -> b - -- Given: C Int Bool x, Wanted: C Int beta y - -- Then rewrite the wanted to C Int Bool y - -- but note that is still not identical to the given - -- The important thing is that the rewritten constraint is - -- inert wrt the given. - -- However it is not necessarily inert wrt previous inert-set items. - -- class C a b c d | a -> b, b c -> d - -- Inert: c1: C b Q R S, c2: C P Q a b - -- Work: C P alpha R beta - -- Does not react with c1; reacts with c2, with alpha:=Q - -- NOW it reacts with c1! - -- So we must stop, and put the rewritten constraint back in the work list - do { d2' <- newDictVar cls1 rewritten_tys2 - ; case fl2 of - Given {} -> pprPanic "Unexpected given" (ppr inertItem $$ ppr workItem) - Wanted {} -> setDictBind d2 (EvCast d2' dict_co) - Derived {} -> return () - ; let workItem' = workItem { cc_id = d2', cc_tyargs = rewritten_tys2 } - ; mkIRStopK "Cls/Cls fundep (partial)" (workItem' `consBag` fd_work) } - - where - dict_co = mkTyConCoercion (classTyCon cls1) cos2 - } + -- Maybe rather than starting again, we could keep going + -- with the rewritten workitem, having dropped the inert, but its + -- safe to restart. + + -- Also: we have rewriting so lets create wanted fds + ; fd_cans <- mkCanonicalFDAsWanted fd_work + ; mkIRStopD "Cls/Cls fundep (solved)" $ + workListFromNonEq inert_w `unionWorkList` fd_cans } + | otherwise + -> do { setDictBind d2 (EvCast d1 dict_co) + -- Rewriting is happening, so we have to create wanted fds + ; fd_cans <- mkCanonicalFDAsWanted fd_work + ; mkIRStopK "Cls/Cls fundep (solved)" fd_cans } + } + where get_workitem_wloc (Wanted wl) = wl + get_workitem_wloc (Derived wl) = wl + get_workitem_wloc (Given {}) = panic "Unexpected given!" + -- Class constraint and given equality: use the equality to rewrite -- the class constraint. @@ -1018,7 +1018,7 @@ | wfl `canRewrite` ifl , tv `elemVarSet` tyVarsOfTypes xis = do { rewritten_dict <- rewriteDict (cv,tv,xi) (dv,ifl,cl,xis) - ; mkIRContinue "Cls/Eq" workItem DropInert (workListFromCCan rewritten_dict) } + ; mkIRContinue "Cls/Eq" workItem DropInert (workListFromNonEq rewritten_dict) } -- Class constraint and given equality: use the equality to rewrite -- the class constraint. @@ -1034,7 +1034,7 @@ | wfl `canRewrite` ifl , tv `elemVarSet` tyVarsOfType ty = do { rewritten_ip <- rewriteIP (cv,tv,xi) (ipid,ifl,nm,ty) - ; mkIRContinue "IP/Eq" workItem DropInert (workListFromCCan rewritten_ip) } + ; mkIRContinue "IP/Eq" workItem DropInert (workListFromNonEq rewritten_ip) } -- Two implicit parameter constraints. If the names are the same, -- but their types are not, we generate a wanted type equality @@ -1043,7 +1043,7 @@ -- so we just generate a fresh coercion variable that isn't used anywhere. doInteractWithInert (CIPCan { cc_id = id1, cc_flavor = ifl, cc_ip_nm = nm1, cc_ip_ty = ty1 }) workItem@(CIPCan { cc_flavor = wfl, cc_ip_nm = nm2, cc_ip_ty = ty2 }) - | nm1 == nm2 && isGiven wfl && isGiven ifl + | nm1 == nm2 && isGivenOrSolved wfl && isGivenOrSolved ifl = -- See Note [Overriding implicit parameters] -- Dump the inert item, override totally with the new one -- Do not require type equality @@ -1051,15 +1051,22 @@ -- we must *override* the outer one with the inner one mkIRContinue "IP/IP override" workItem DropInert emptyWorkList - | nm1 == nm2 && ty1 `tcEqType` ty2 + | nm1 == nm2 && ty1 `eqType` ty2 = solveOneFromTheOther "IP/IP" (EvId id1,ifl) workItem | 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 (mkSymCo (mkCoVarCo 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 @@ -1073,7 +1080,7 @@ | ifl `canRewrite` wfl , tv `elemVarSet` tyVarsOfTypes (xi2:args) -- Rewrite RHS as well = do { rewritten_funeq <- rewriteFunEq (cv1,tv,xi1) (cv2,wfl,tc,args,xi2) - ; mkIRStopK "Eq/FunEq" (workListFromCCan rewritten_funeq) } + ; mkIRStopK "Eq/FunEq" (workListFromEq rewritten_funeq) } -- Must Stop here, because we may no longer be inert after the rewritting. -- Inert: function equality, work item: equality @@ -1083,7 +1090,7 @@ | wfl `canRewrite` ifl , tv `elemVarSet` tyVarsOfTypes (xi1:args) -- Rewrite RHS as well = do { rewritten_funeq <- rewriteFunEq (cv2,tv,xi2) (cv1,ifl,tc,args,xi1) - ; mkIRContinue "FunEq/Eq" workItem DropInert (workListFromCCan rewritten_funeq) } + ; mkIRContinue "FunEq/Eq" workItem DropInert (workListFromEq rewritten_funeq) } -- One may think that we could (KeepTransformedInert rewritten_funeq) -- but that is wrong, because it may end up not being inert with respect -- to future inerts. Example: @@ -1097,24 +1104,31 @@ , cc_tyargs = args1, cc_rhs = xi1 }) workItem@(CFunEqCan { cc_id = cv2, cc_flavor = fl2, cc_fun = tc2 , cc_tyargs = args2, cc_rhs = xi2 }) + | tc1 == tc2 && and (zipWith eqType args1 args2) + , Just GivenSolved <- isGiven_maybe fl1 + = mkIRContinue "Funeq/Funeq" workItem DropInert emptyWorkList + | tc1 == tc2 && and (zipWith eqType args1 args2) + , Just GivenSolved <- isGiven_maybe fl2 + = mkIRStopK "Funeq/Funeq" emptyWorkList + | fl1 `canSolve` fl2 && lhss_match - = do { cans <- rewriteEqLHS LeftComesFromInert (mkCoVarCoercion cv1,xi1) (cv2,fl2,xi2) + = do { cans <- rewriteEqLHS LeftComesFromInert (mkCoVarCo cv1,xi1) (cv2,fl2,xi2) ; mkIRStopK "FunEq/FunEq" cans } | fl2 `canSolve` fl1 && lhss_match - = do { cans <- rewriteEqLHS RightComesFromInert (mkCoVarCoercion cv2,xi2) (cv1,fl1,xi1) + = do { cans <- rewriteEqLHS RightComesFromInert (mkCoVarCo cv2,xi2) (cv1,fl1,xi1) ; mkIRContinue "FunEq/FunEq" workItem DropInert cans } where - lhss_match = tc1 == tc2 && and (zipWith tcEqType args1 args2) + lhss_match = tc1 == tc2 && eqTypes args1 args2 doInteractWithInert (CTyEqCan { cc_id = cv1, cc_flavor = fl1, cc_tyvar = tv1, cc_rhs = xi1 }) workItem@(CTyEqCan { cc_id = cv2, cc_flavor = fl2, cc_tyvar = tv2, cc_rhs = xi2 }) -- Check for matching LHS | fl1 `canSolve` fl2 && tv1 == tv2 - = do { cans <- rewriteEqLHS LeftComesFromInert (mkCoVarCoercion cv1,xi1) (cv2,fl2,xi2) + = do { cans <- rewriteEqLHS LeftComesFromInert (mkCoVarCo cv1,xi1) (cv2,fl2,xi2) ; mkIRStopK "Eq/Eq lhs" cans } | fl2 `canSolve` fl1 && tv1 == tv2 - = do { cans <- rewriteEqLHS RightComesFromInert (mkCoVarCoercion cv2,xi2) (cv1,fl1,xi1) + = do { cans <- rewriteEqLHS RightComesFromInert (mkCoVarCo cv2,xi2) (cv1,fl1,xi1) ; mkIRContinue "Eq/Eq lhs" workItem DropInert cans } -- Check for rewriting RHS @@ -1145,13 +1159,13 @@ -- Equational Rewriting rewriteDict :: (CoVar, TcTyVar, Xi) -> (DictId, CtFlavor, Class, [Xi]) -> TcS CanonicalCt rewriteDict (cv,tv,xi) (dv,gw,cl,xis) - = do { let cos = substTysWith [tv] [mkCoVarCoercion cv] xis -- xis[tv] ~ xis[xi] + = do { let cos = map (liftCoSubstWith [tv] [mkCoVarCo cv]) xis -- xis[tv] ~ xis[xi] args = substTysWith [tv] [xi] xis con = classTyCon cl - dict_co = mkTyConCoercion con cos + dict_co = mkTyConAppCo con cos ; dv' <- newDictVar cl args ; case gw of - Wanted {} -> setDictBind dv (EvCast dv' (mkSymCoercion dict_co)) + Wanted {} -> setDictBind dv (EvCast dv' (mkSymCo dict_co)) Given {} -> setDictBind dv' (EvCast dv dict_co) Derived {} -> return () -- Derived dicts we don't set any evidence @@ -1162,11 +1176,11 @@ rewriteIP :: (CoVar,TcTyVar,Xi) -> (EvVar,CtFlavor, IPName Name, TcType) -> TcS CanonicalCt rewriteIP (cv,tv,xi) (ipid,gw,nm,ty) - = do { let ip_co = substTyWith [tv] [mkCoVarCoercion cv] ty -- ty[tv] ~ t[xi] - ty' = substTyWith [tv] [xi] ty + = do { let ip_co = liftCoSubstWith [tv] [mkCoVarCo cv] ty -- ty[tv] ~ t[xi] + ty' = substTyWith [tv] [xi] ty ; ipid' <- newIPVar nm ty' ; case gw of - Wanted {} -> setIPBind ipid (EvCast ipid' (mkSymCoercion ip_co)) + Wanted {} -> setIPBind ipid (EvCast ipid' (mkSymCo ip_co)) Given {} -> setIPBind ipid' (EvCast ipid ip_co) Derived {} -> return () -- Derived ips: we don't set any evidence @@ -1177,20 +1191,21 @@ rewriteFunEq :: (CoVar,TcTyVar,Xi) -> (CoVar,CtFlavor,TyCon, [Xi], Xi) -> TcS CanonicalCt rewriteFunEq (cv1,tv,xi1) (cv2,gw, tc,args,xi2) -- cv2 :: F args ~ xi2 - = do { let arg_cos = substTysWith [tv] [mkCoVarCoercion cv1] args - args' = substTysWith [tv] [xi1] args - fun_co = mkTyConCoercion tc arg_cos -- fun_co :: F args ~ F args' + = do { let co_subst = liftCoSubstWith [tv] [mkCoVarCo cv1] + arg_cos = map co_subst args + args' = substTysWith [tv] [xi1] args + fun_co = mkTyConAppCo tc arg_cos -- fun_co :: F args ~ F args' xi2' = substTyWith [tv] [xi1] xi2 - xi2_co = substTyWith [tv] [mkCoVarCoercion cv1] xi2 -- xi2_co :: xi2 ~ xi2' + xi2_co = co_subst xi2 -- xi2_co :: xi2 ~ xi2' ; cv2' <- newCoVar (mkTyConApp tc args') xi2' ; case gw of - Wanted {} -> setCoBind cv2 (fun_co `mkTransCoercion` - mkCoVarCoercion cv2' `mkTransCoercion` - mkSymCoercion xi2_co) - Given {} -> setCoBind cv2' (mkSymCoercion fun_co `mkTransCoercion` - mkCoVarCoercion cv2 `mkTransCoercion` + Wanted {} -> setCoBind cv2 (fun_co `mkTransCo` + mkCoVarCo cv2' `mkTransCo` + mkSymCo xi2_co) + Given {} -> setCoBind cv2' (mkSymCo fun_co `mkTransCo` + mkCoVarCo cv2 `mkTransCo` xi2_co) Derived {} -> return () @@ -1211,20 +1226,20 @@ rewriteEqRHS (cv1,tv1,xi1) (cv2,gw,tv2,xi2) | Just tv2' <- tcGetTyVar_maybe xi2' , tv2 == tv2' -- In this case xi2[xi1/tv1] = tv2, so we have tv2~tv2 - = do { when (isWanted gw) (setCoBind cv2 (mkSymCoercion co2')) - ; return emptyCCan } + = do { when (isWanted gw) (setCoBind cv2 (mkSymCo co2')) + ; return emptyWorkList } | otherwise = do { cv2' <- newCoVar (mkTyVarTy tv2) xi2' ; case gw of - Wanted {} -> setCoBind cv2 $ mkCoVarCoercion cv2' `mkTransCoercion` - mkSymCoercion co2' - Given {} -> setCoBind cv2' $ mkCoVarCoercion cv2 `mkTransCoercion` + Wanted {} -> setCoBind cv2 $ mkCoVarCo cv2' `mkTransCo` + mkSymCo co2' + Given {} -> setCoBind cv2' $ mkCoVarCo cv2 `mkTransCo` co2' Derived {} -> return () - ; canEq gw cv2' (mkTyVarTy tv2) xi2' } + ; canEqToWorkList gw cv2' (mkTyVarTy tv2) xi2' } where xi2' = substTyWith [tv1] [xi1] xi2 - co2' = substTyWith [tv1] [mkCoVarCoercion cv1] xi2 -- xi2 ~ xi2[xi1/tv1] + co2' = liftCoSubstWith [tv1] [mkCoVarCo cv1] xi2 -- xi2 ~ xi2[xi1/tv1] rewriteEqLHS :: WhichComesFromInert -> (Coercion,Xi) -> (CoVar,CtFlavor,Xi) -> TcS WorkList -- Used to ineract two equalities of the following form: @@ -1237,9 +1252,9 @@ = do { cv2' <- newCoVar xi2 xi1 ; case gw of Wanted {} -> setCoBind cv2 $ - co1 `mkTransCoercion` mkSymCoercion (mkCoVarCoercion cv2') + co1 `mkTransCo` mkSymCo (mkCoVarCo cv2') Given {} -> setCoBind cv2' $ - mkSymCoercion (mkCoVarCoercion cv2) `mkTransCoercion` co1 + mkSymCo (mkCoVarCo cv2) `mkTransCo` co1 Derived {} -> return () ; mkCanonical gw cv2' } @@ -1247,9 +1262,9 @@ = do { cv2' <- newCoVar xi1 xi2 ; case gw of Wanted {} -> setCoBind cv2 $ - co1 `mkTransCoercion` mkCoVarCoercion cv2' + co1 `mkTransCo` mkCoVarCo cv2' Given {} -> setCoBind cv2' $ - mkSymCoercion co1 `mkTransCoercion` mkCoVarCoercion cv2 + mkSymCo co1 `mkTransCo` mkCoVarCo cv2 Derived {} -> return () ; mkCanonical gw cv2' } @@ -1257,51 +1272,62 @@ rewriteFrozen (cv1, tv1, xi1) (cv2, fl2) = do { cv2' <- newCoVar ty2a' ty2b' -- ty2a[xi1/tv1] ~ ty2b[xi1/tv1] ; case fl2 of - Wanted {} -> setCoBind cv2 $ co2a' `mkTransCoercion` - mkCoVarCoercion cv2' `mkTransCoercion` - mkSymCoercion co2b' + Wanted {} -> setCoBind cv2 $ co2a' `mkTransCo` + mkCoVarCo cv2' `mkTransCo` + mkSymCo co2b' - Given {} -> setCoBind cv2' $ mkSymCoercion co2a' `mkTransCoercion` - mkCoVarCoercion cv2 `mkTransCoercion` + Given {} -> setCoBind cv2' $ mkSymCo co2a' `mkTransCo` + mkCoVarCo cv2 `mkTransCo` co2b' Derived {} -> return () - ; return (singleCCan $ CFrozenErr { cc_id = cv2', cc_flavor = fl2 }) } + ; return (workListFromNonEq $ CFrozenErr { cc_id = cv2', cc_flavor = fl2 }) } where (ty2a, ty2b) = coVarKind cv2 -- cv2 : ty2a ~ ty2b ty2a' = substTyWith [tv1] [xi1] ty2a ty2b' = substTyWith [tv1] [xi1] ty2b - co2a' = substTyWith [tv1] [mkCoVarCoercion cv1] ty2a -- ty2a ~ ty2a[xi1/tv1] - co2b' = substTyWith [tv1] [mkCoVarCoercion cv1] ty2b -- ty2b ~ ty2b[xi1/tv1] + co2a' = liftCoSubstWith [tv1] [mkCoVarCo cv1] ty2a -- ty2a ~ ty2a[xi1/tv1] + co2b' = liftCoSubstWith [tv1] [mkCoVarCo cv1] ty2b -- ty2b ~ ty2b[xi1/tv1] -solveOneFromTheOther :: String -> (EvTerm, CtFlavor) -> CanonicalCt -> TcS InteractResult +solveOneFromTheOther_ExtraWork :: String -> (EvTerm, CtFlavor) + -> CanonicalCt -> WorkList -> TcS InteractResult -- First argument inert, second argument work-item. They both represent -- wanted/given/derived evidence for the *same* predicate so -- we can discharge one directly from the other. -- -- Precondition: value evidence only (implicit parameters, classes) -- not coercion -solveOneFromTheOther info (ev_term,ifl) workItem +solveOneFromTheOther_ExtraWork info (ev_term,ifl) workItem extra_work | isDerived wfl - = mkIRStopK ("Solved[DW] " ++ info) emptyWorkList + = mkIRStopK ("Solved[DW] " ++ info) extra_work | isDerived ifl -- The inert item is Derived, we can just throw it away, -- The workItem is inert wrt earlier inert-set items, -- so it's safe to continue on from this point - = mkIRContinue ("Solved[DI] " ++ info) workItem DropInert emptyWorkList + = mkIRContinue ("Solved[DI] " ++ info) workItem DropInert extra_work + | Just GivenSolved <- isGiven_maybe ifl, isGivenOrSolved wfl + -- Same if the inert is a GivenSolved -- just get rid of it + = mkIRContinue ("Solved[SI] " ++ info) workItem DropInert extra_work + | otherwise = ASSERT( ifl `canSolve` wfl ) -- Because of Note [The Solver Invariant], plus Derived dealt with do { when (isWanted wfl) $ setEvBind wid ev_term -- Overwrite the binding, if one exists -- If both are Given, we already have evidence; no need to duplicate - ; mkIRStopK ("Solved " ++ info) emptyWorkList } + ; mkIRStopK ("Solved " ++ info) extra_work } where wfl = cc_flavor workItem wid = cc_id workItem + + +solveOneFromTheOther :: String -> (EvTerm, CtFlavor) -> CanonicalCt -> TcS InteractResult +solveOneFromTheOther str evfl ct + = solveOneFromTheOther_ExtraWork str evfl ct emptyWorkList -- extra work is empty + \end{code} Note [Superclasses and recursive dictionaries] @@ -1666,33 +1692,34 @@ -- only reacted with functional dependencies -- arising from top-level instances. -topReactionsStage :: SimplifierStage -topReactionsStage depth workItem inerts - = do { tir <- tryTopReact workItem - ; case tir of - NoTopInt -> - return $ SR { sr_inerts = inerts - , sr_new_work = emptyWorkList - , sr_stop = ContinueWith workItem } - SomeTopInt tir_new_work tir_new_inert -> +topReactionsStage :: SimplifierStage +topReactionsStage depth workItem inerts + = do { tir <- tryTopReact inerts workItem + -- NB: we pass the inerts as well. See Note [Instance and Given overlap] + ; case tir of + NoTopInt -> + return $ SR { sr_inerts = inerts + , sr_new_work = emptyWorkList + , sr_stop = ContinueWith workItem } + SomeTopInt tir_new_work tir_new_inert -> do { bumpStepCountTcS ; traceFireTcS depth (ptext (sLit "Top react") <+> vcat [ ptext (sLit "Work =") <+> ppr workItem , ptext (sLit "New =") <+> ppr tir_new_work ]) - ; return $ SR { sr_inerts = inerts + ; return $ SR { sr_inerts = inerts , sr_new_work = tir_new_work , sr_stop = tir_new_inert } } } -tryTopReact :: WorkItem -> TcS TopInteractResult -tryTopReact workitem +tryTopReact :: InertSet -> WorkItem -> TcS TopInteractResult +tryTopReact inerts workitem = do { -- A flag controls the amount of interaction allowed -- See Note [Simplifying RULE lhs constraints] ctxt <- getTcSContext ; if allowedTopReaction (simplEqsOnly ctxt) workitem then do { traceTcS "tryTopReact / calling doTopReact" (ppr workitem) - ; doTopReact workitem } + ; doTopReact inerts workitem } else return NoTopInt } @@ -1700,7 +1727,7 @@ allowedTopReaction eqs_only (CDictCan {}) = not eqs_only allowedTopReaction _ _ = True -doTopReact :: WorkItem -> TcS TopInteractResult +doTopReact :: InertSet -> WorkItem -> TcS TopInteractResult -- The work item does not react with the inert set, so try interaction with top-level instances -- NB: The place to add superclasses in *not* in doTopReact stage. Instead superclasses are -- added in the worklist as part of the canonicalisation process. @@ -1708,82 +1735,100 @@ -- Given dictionary -- See Note [Given constraint that matches an instance declaration] -doTopReact (CDictCan { cc_flavor = Given {} }) +doTopReact _inerts (CDictCan { cc_flavor = Given {} }) = return NoTopInt -- NB: Superclasses already added since it's canonical -- Derived dictionary: just look for functional dependencies -doTopReact workItem@(CDictCan { cc_flavor = fl@(Derived loc) - , cc_class = cls, cc_tyargs = xis }) +doTopReact _inerts workItem@(CDictCan { cc_flavor = Derived loc + , cc_class = cls, cc_tyargs = xis }) = do { instEnvs <- getInstEnvs ; let fd_eqns = improveFromInstEnv instEnvs (ClassP cls xis, pprArisingAt loc) - ; m <- rewriteWithFunDeps fd_eqns xis fl + ; m <- rewriteWithFunDeps fd_eqns xis loc ; case m of Nothing -> return NoTopInt Just (xis',_,fd_work) -> let workItem' = workItem { cc_tyargs = xis' } -- Deriveds are not supposed to have identity (cc_id is unused!) - in return $ SomeTopInt { tir_new_work = fd_work - , tir_new_inert = ContinueWith workItem' } } + in do { fd_cans <- mkCanonicalFDAsDerived fd_work + ; return $ SomeTopInt { tir_new_work = fd_cans + , tir_new_inert = ContinueWith workItem' } + } + } + -- Wanted dictionary -doTopReact workItem@(CDictCan { cc_id = dv, cc_flavor = fl@(Wanted loc) - , cc_class = cls, cc_tyargs = xis }) - = do { -- See Note [MATCHING-SYNONYMS] - ; lkp_inst_res <- matchClassInst cls xis loc - ; case lkp_inst_res of - NoInstance -> - do { traceTcS "doTopReact/ no class instance for" (ppr dv) - - ; instEnvs <- getInstEnvs - ; let fd_eqns = improveFromInstEnv instEnvs - (ClassP cls xis, pprArisingAt loc) - ; m <- rewriteWithFunDeps fd_eqns xis fl - ; case m of - Nothing -> return NoTopInt - Just (xis',cos,fd_work) -> - do { let dict_co = mkTyConCoercion (classTyCon cls) cos - ; dv'<- newDictVar cls xis' - ; setDictBind dv (EvCast dv' dict_co) - ; let workItem' = CDictCan { cc_id = dv', cc_flavor = fl, - cc_class = cls, cc_tyargs = xis' } - ; return $ - SomeTopInt { tir_new_work = singleCCan workItem' `andCCan` fd_work - , tir_new_inert = Stop } } } - - GenInst wtvs ev_term -- Solved - -- No need to do fundeps stuff here; the instance - -- matches already so we won't get any more info - -- from functional dependencies - | null wtvs - -> do { traceTcS "doTopReact/ found nullary class instance for" (ppr dv) - ; setDictBind dv ev_term - -- Solved in one step and no new wanted work produced. - -- i.e we directly matched a top-level instance - -- No point in caching this in 'inert'; hence Stop - ; return $ SomeTopInt { tir_new_work = emptyWorkList - , tir_new_inert = Stop } } - - | otherwise - -> do { traceTcS "doTopReact/ found nullary class instance for" (ppr dv) - ; setDictBind dv ev_term +doTopReact inerts workItem@(CDictCan { cc_flavor = fl@(Wanted loc) + , cc_class = cls, cc_tyargs = xis }) + -- See Note [MATCHING-SYNONYMS] + = do { traceTcS "doTopReact" (ppr workItem) + ; instEnvs <- getInstEnvs + ; let fd_eqns = improveFromInstEnv instEnvs $ (ClassP cls xis, pprArisingAt loc) + + ; any_fundeps <- rewriteWithFunDeps fd_eqns xis loc + ; case any_fundeps of + -- No Functional Dependencies + Nothing -> + do { lkup_inst_res <- matchClassInst inerts cls xis loc + ; case lkup_inst_res of + GenInst wtvs ev_term + -> doSolveFromInstance wtvs ev_term workItem emptyWorkList + NoInstance + -> return NoTopInt + } + -- Actual Functional Dependencies + Just (xis',cos,fd_work) -> + do { lkup_inst_res <- matchClassInst inerts cls xis' loc + ; case lkup_inst_res of + NoInstance + -> do { fd_cans <- mkCanonicalFDAsDerived fd_work + ; return $ + SomeTopInt { tir_new_work = fd_cans + , tir_new_inert = ContinueWith workItem } } + -- This WHOLE branch is an optimization: we can immediately discharge the dictionary + GenInst wtvs ev_term + -> do { let dict_co = mkTyConAppCo (classTyCon cls) cos + ; fd_cans <- mkCanonicalFDAsWanted fd_work + ; dv' <- newDictVar cls xis' + ; setDictBind dv' ev_term + ; doSolveFromInstance wtvs (EvCast dv' dict_co) workItem fd_cans } + } } + + where doSolveFromInstance :: [WantedEvVar] + -> EvTerm + -> CanonicalCt + -> WorkList -> TcS TopInteractResult + -- Precondition: evidence term matches the predicate of cc_id of workItem + doSolveFromInstance wtvs ev_term workItem extra_work + | null wtvs + = do { traceTcS "doTopReact/found nullary instance for" (ppr (cc_id workItem)) + ; setDictBind (cc_id workItem) ev_term + ; return $ SomeTopInt { tir_new_work = extra_work + , tir_new_inert = Stop } } + | otherwise + = do { traceTcS "doTopReact/found non-nullary instance for" (ppr (cc_id workItem)) + ; setDictBind (cc_id workItem) ev_term -- Solved and new wanted work produced, you may cache the - -- (tentatively solved) dictionary as Given! (used to be: Derived) - ; let solved = workItem { cc_flavor = given_fl } - given_fl = Given (setCtLocOrigin loc UnkSkol) - ; inst_work <- canWanteds wtvs - ; return $ SomeTopInt { tir_new_work = inst_work - , tir_new_inert = ContinueWith solved } } - } + -- (tentatively solved) dictionary as Solved given. + ; let solved = workItem { cc_flavor = solved_fl } + solved_fl = mkSolvedFlavor fl UnkSkol + ; inst_work <- canWanteds wtvs + ; return $ SomeTopInt { tir_new_work = inst_work `unionWorkList` extra_work + , tir_new_inert = ContinueWith solved } } + -- Type functions -doTopReact (CFunEqCan { cc_id = cv, cc_flavor = fl - , cc_fun = tc, cc_tyargs = args, cc_rhs = xi }) +doTopReact _inerts (CFunEqCan { cc_flavor = fl }) + | Just GivenSolved <- isGiven_maybe fl + = return NoTopInt -- If Solved, no more interactions should happen + +-- Otherwise, it's a Given, Derived, or Wanted +doTopReact _inerts workItem@(CFunEqCan { cc_id = cv, cc_flavor = fl + , cc_fun = tc, cc_tyargs = args, cc_rhs = xi }) = ASSERT (isSynFamilyTyCon tc) -- No associated data families have reached that far do { match_res <- matchFam tc args -- See Note [MATCHING-SYNONYMS] ; case match_res of - MatchInstNo - -> return NoTopInt + MatchInstNo -> return NoTopInt MatchInstSingle (rep_tc, rep_tys) -> do { let Just coe_tc = tyConFamilyCoercion_maybe rep_tc Just rhs_ty = tcView (mkTyConApp rep_tc rep_tys) @@ -1791,25 +1836,40 @@ -- RHS of a type function, so that it never -- appears in an error message -- See Note [Type synonym families] in TyCon - coe = mkTyConApp coe_tc rep_tys - ; cv' <- case fl of - Wanted {} -> do { cv' <- newCoVar rhs_ty xi - ; setCoBind cv $ - coe `mkTransCoercion` - mkCoVarCoercion cv' - ; return cv' } - Given {} -> newGivenCoVar xi rhs_ty $ - mkSymCoercion (mkCoVarCoercion cv) `mkTransCoercion` coe - Derived {} -> newDerivedId (EqPred xi rhs_ty) - ; can_cts <- mkCanonical fl cv' - ; return $ SomeTopInt can_cts Stop } + coe = mkAxInstCo coe_tc rep_tys + ; case fl of + Wanted {} -> do { cv' <- newCoVar rhs_ty xi + ; setCoBind cv $ coe `mkTransCo` mkCoVarCo cv' + ; can_cts <- mkCanonical fl cv' + ; let solved = workItem { cc_flavor = solved_fl } + solved_fl = mkSolvedFlavor fl UnkSkol + ; if isEmptyWorkList can_cts then + return (SomeTopInt can_cts Stop) -- No point in caching + else return $ + SomeTopInt { tir_new_work = can_cts + , tir_new_inert = ContinueWith solved } + } + Given {} -> do { cv' <- newGivenCoVar xi rhs_ty $ + mkSymCo (mkCoVarCo cv) `mkTransCo` coe + ; can_cts <- mkCanonical fl cv' + ; return $ + SomeTopInt { tir_new_work = can_cts + , tir_new_inert = Stop } + } + Derived {} -> do { cv' <- newDerivedId (EqPred xi rhs_ty) + ; can_cts <- mkCanonical fl cv' + ; return $ + SomeTopInt { tir_new_work = can_cts + , tir_new_inert = Stop } + } + } _ -> panicTcS $ text "TcSMonad.matchFam returned multiple instances!" } -- Any other work item does not react with any top-level equations -doTopReact _workItem = return NoTopInt +doTopReact _inerts _workItem = return NoTopInt \end{code} @@ -2013,15 +2073,24 @@ = NoInstance | GenInst [WantedEvVar] EvTerm -matchClassInst :: Class -> [Type] -> WantedLoc -> TcS LookupInstResult -matchClassInst clas tys loc +matchClassInst :: InertSet -> Class -> [Type] -> WantedLoc -> TcS LookupInstResult +matchClassInst inerts clas tys loc = do { let pred = mkClassPred clas tys ; mb_result <- matchClass clas tys + ; untch <- getUntouchables ; case mb_result of MatchInstNo -> return NoInstance - MatchInstMany -> return NoInstance -- defer any reactions of a multitude until + MatchInstMany -> return NoInstance -- defer any reactions of a multitude until -- we learn more about the reagent - MatchInstSingle (dfun_id, mb_inst_tys) -> + MatchInstSingle (_,_) + | given_overlap untch -> + do { traceTcS "Delaying instance application" $ + vcat [ text "Workitem=" <+> pprPredTy (ClassP clas tys) + , text "Relevant given dictionaries=" <+> ppr givens_for_this_clas ] + ; return NoInstance -- see Note [Instance and Given overlap] + } + + MatchInstSingle (dfun_id, mb_inst_tys) -> do { checkWellStagedDFun pred dfun_id loc -- It's possible that not all the tyvars are in @@ -2030,7 +2099,7 @@ -- (presumably there's a functional dependency in class C) -- Hence mb_inst_tys :: Either TyVar TcType - ; tys <- instDFunTypes mb_inst_tys + ; tys <- instDFunTypes mb_inst_tys ; let (theta, _) = tcSplitPhiTy (applyTys (idType dfun_id) tys) ; if null theta then return (GenInst [] (EvDFunApp dfun_id tys [])) @@ -2040,4 +2109,68 @@ ; return $ GenInst wevs (EvDFunApp dfun_id tys ev_vars) } } } + where + givens_for_this_clas :: CanonicalCts + givens_for_this_clas = Map.lookup clas (cts_given (inert_dicts inerts)) + `orElse` emptyBag + + given_overlap :: TcsUntouchables -> Bool + given_overlap untch = anyBag (matchable untch) givens_for_this_clas + + matchable untch (CDictCan { cc_class = clas_g, cc_tyargs = sys, cc_flavor = fl }) + | Just GivenOrig <- isGiven_maybe fl + = ASSERT( clas_g == clas ) + case tcUnifyTys (\tv -> if isTouchableMetaTyVar_InRange untch tv && + tv `elemVarSet` tyVarsOfTypes tys + then BindMe else Skolem) tys sys of + -- We can't learn anything more about any variable at this point, so the only + -- cause of overlap can be by an instantiation of a touchable unification + -- variable. Hence we only bind touchable unification variables. In addition, + -- we use tcUnifyTys instead of tcMatchTys to rule out cyclic substitutions. + Nothing -> False + Just _ -> True + | otherwise = False -- No overlap with a solved, already been taken care of + -- by the overlap check with the instance environment. + matchable _tys ct = pprPanic "Expecting dictionary!" (ppr ct) \end{code} + +Note [Instance and Given overlap] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Assume that we have an inert set that looks as follows: + [Given] D [Int] +And an instance declaration: + instance C a => D [a] +A new wanted comes along of the form: + [Wanted] D [alpha] + +One possibility is to apply the instance declaration which will leave us +with an unsolvable goal (C alpha). However, later on a new constraint may +arise (for instance due to a functional dependency between two later dictionaries), +that will add the equality (alpha ~ Int), in which case our ([Wanted] D [alpha]) +will be transformed to [Wanted] D [Int], which could have been discharged by the given. + +The solution is that in matchClassInst and eventually in topReact, we get back with +a matching instance, only when there is no Given in the inerts which is unifiable to +this particular dictionary. + +The end effect is that, much as we do for overlapping instances, we delay choosing a +class instance if there is a possibility of another instance OR a given to match our +constraint later on. This fixes bugs #4981 and #5002. + +This is arguably not easy to appear in practice due to our aggressive prioritization +of equality solving over other constraints, but it is possible. I've added a test case +in typecheck/should-compile/GivenOverlapping.hs + +Moreover notice that our goals here are different than the goals of the top-level +overlapping checks. There we are interested in validating the following principle: + + If we inline a function f at a site where the same global instance environment + is available as the instance environment at the definition site of f then we + should get the same behaviour. + +But for the Given Overlap check our goal is just related to completeness of +constraint solving. + + + + diff -Nru ghc-7.0.3/compiler/typecheck/TcMatches.lhs ghc-7.2.1/compiler/typecheck/TcMatches.lhs --- ghc-7.0.3/compiler/typecheck/TcMatches.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/typecheck/TcMatches.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -6,18 +6,19 @@ TcMatches: Typecheck some @Matches@ \begin{code} +{-# OPTIONS_GHC -w #-} -- debugging module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda, - TcMatchCtxt(..), - tcStmts, tcDoStmts, tcBody, - tcDoStmt, tcMDoStmt, tcGuardStmt + TcMatchCtxt(..), TcStmtChecker, + tcStmts, tcStmtsAndThen, tcDoStmts, tcBody, + tcDoStmt, tcGuardStmt ) where -import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcInferRhoNC, tcCheckId, +import {-# SOURCE #-} TcExpr( tcSyntaxOp, tcInferRhoNC, tcInferRho, tcCheckId, tcMonoExpr, tcMonoExprNC, tcPolyExpr ) import HsSyn +import BasicTypes import TcRnMonad -import Inst import TcEnv import TcPat import TcMType @@ -26,17 +27,18 @@ import TcUnify import Name import TysWiredIn -import PrelNames import Id import TyCon import TysPrim -import Coercion ( mkSymCoI ) +import Coercion ( isReflCo, mkSymCo ) import Outputable -import BasicTypes ( Arity ) import Util import SrcLoc import FastString +-- Create chunkified tuple tybes for monad comprehensions +import MkCore + import Control.Monad #include "HsVersions.h" @@ -145,7 +147,7 @@ matchFunTys herald arity res_ty thing_inside = do { (coi, pat_tys, res_ty) <- matchExpectedFunTys herald arity res_ty ; res <- thing_inside pat_tys res_ty - ; return (coiToHsWrapper (mkSymCoI coi), res) } + ; return (coToHsWrapper (mkSymCo coi), res) } \end{code} %************************************************************************ @@ -223,7 +225,7 @@ tcGRHS :: TcMatchCtxt -> TcRhoType -> GRHS Name -> TcM (GRHS TcId) tcGRHS ctxt res_ty (GRHS guards rhs) - = do { (guards', rhs') <- tcStmts stmt_ctxt tcGuardStmt guards res_ty $ + = do { (guards', rhs') <- tcStmtsAndThen stmt_ctxt tcGuardStmt guards res_ty $ mc_body ctxt rhs ; return (GRHS guards' rhs') } where @@ -240,45 +242,33 @@ \begin{code} tcDoStmts :: HsStmtContext Name -> [LStmt Name] - -> LHsExpr Name -> TcRhoType -> TcM (HsExpr TcId) -- Returns a HsDo -tcDoStmts ListComp stmts body res_ty +tcDoStmts ListComp stmts res_ty = do { (coi, elt_ty) <- matchExpectedListTy res_ty - ; (stmts', body') <- tcStmts ListComp (tcLcStmt listTyCon) stmts - elt_ty $ - tcBody body - ; return $ mkHsWrapCoI coi - (HsDo ListComp stmts' body' (mkListTy elt_ty)) } + ; let list_ty = mkListTy elt_ty + ; stmts' <- tcStmts ListComp (tcLcStmt listTyCon) stmts elt_ty + ; return $ mkHsWrapCo coi (HsDo ListComp stmts' list_ty) } -tcDoStmts PArrComp stmts body res_ty +tcDoStmts PArrComp stmts res_ty = do { (coi, elt_ty) <- matchExpectedPArrTy res_ty - ; (stmts', body') <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts - elt_ty $ - tcBody body - ; return $ mkHsWrapCoI coi - (HsDo PArrComp stmts' body' (mkPArrTy elt_ty)) } - -tcDoStmts DoExpr stmts body res_ty - = do { (stmts', body') <- tcStmts DoExpr tcDoStmt stmts res_ty $ - tcBody body - ; return (HsDo DoExpr stmts' body' res_ty) } - -tcDoStmts ctxt@(MDoExpr _) stmts body res_ty - = do { (coi, (m_ty, elt_ty)) <- matchExpectedAppTy res_ty - ; let res_ty' = mkAppTy m_ty elt_ty -- The matchExpected consumes res_ty - tc_rhs rhs = tcInfer $ \ pat_ty -> - tcMonoExpr rhs (mkAppTy m_ty pat_ty) - - ; (stmts', body') <- tcStmts ctxt (tcMDoStmt tc_rhs) stmts res_ty' $ - tcBody body - - ; let names = [mfixName, bindMName, thenMName, returnMName, failMName] - ; insts <- mapM (\name -> newMethodFromName DoOrigin name m_ty) names - ; return $ mkHsWrapCoI coi $ - HsDo (MDoExpr (names `zip` insts)) stmts' body' res_ty' } + ; let parr_ty = mkPArrTy elt_ty + ; stmts' <- tcStmts PArrComp (tcLcStmt parrTyCon) stmts elt_ty + ; return $ mkHsWrapCo coi (HsDo PArrComp stmts' parr_ty) } + +tcDoStmts DoExpr stmts res_ty + = do { stmts' <- tcStmts DoExpr tcDoStmt stmts res_ty + ; return (HsDo DoExpr stmts' res_ty) } + +tcDoStmts MDoExpr stmts res_ty + = do { stmts' <- tcStmts MDoExpr tcDoStmt stmts res_ty + ; return (HsDo MDoExpr stmts' res_ty) } + +tcDoStmts MonadComp stmts res_ty + = do { stmts' <- tcStmts MonadComp tcMcStmt stmts res_ty + ; return (HsDo MonadComp stmts' res_ty) } -tcDoStmts ctxt _ _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt) +tcDoStmts ctxt _ _ = pprPanic "tcDoStmts" (pprStmtContext ctxt) tcBody :: LHsExpr Name -> TcRhoType -> TcM (LHsExpr TcId) tcBody body res_ty @@ -307,40 +297,52 @@ -> TcStmtChecker -- NB: higher-rank type -> [LStmt Name] -> TcRhoType - -> (TcRhoType -> TcM thing) - -> TcM ([LStmt TcId], thing) + -> TcM [LStmt TcId] +tcStmts ctxt stmt_chk stmts res_ty + = do { (stmts', _) <- tcStmtsAndThen ctxt stmt_chk stmts res_ty $ + const (return ()) + ; return stmts' } + +tcStmtsAndThen :: HsStmtContext Name + -> TcStmtChecker -- NB: higher-rank type + -> [LStmt Name] + -> TcRhoType + -> (TcRhoType -> TcM thing) + -> TcM ([LStmt TcId], thing) -- Note the higher-rank type. stmt_chk is applied at different -- types in the equations for tcStmts -tcStmts _ _ [] res_ty thing_inside +tcStmtsAndThen _ _ [] res_ty thing_inside = do { thing <- thing_inside res_ty ; return ([], thing) } -- LetStmts are handled uniformly, regardless of context -tcStmts ctxt stmt_chk (L loc (LetStmt binds) : stmts) res_ty thing_inside +tcStmtsAndThen ctxt stmt_chk (L loc (LetStmt binds) : stmts) res_ty thing_inside = do { (binds', (stmts',thing)) <- tcLocalBinds binds $ - tcStmts ctxt stmt_chk stmts res_ty thing_inside + tcStmtsAndThen ctxt stmt_chk stmts res_ty thing_inside ; return (L loc (LetStmt binds') : stmts', thing) } -- For the vanilla case, handle the location-setting part -tcStmts ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside +tcStmtsAndThen ctxt stmt_chk (L loc stmt : stmts) res_ty thing_inside = do { (stmt', (stmts', thing)) <- - setSrcSpan loc $ - addErrCtxt (pprStmtInCtxt ctxt stmt) $ - stmt_chk ctxt stmt res_ty $ \ res_ty' -> - popErrCtxt $ - tcStmts ctxt stmt_chk stmts res_ty' $ + setSrcSpan loc $ + addErrCtxt (pprStmtInCtxt ctxt stmt) $ + stmt_chk ctxt stmt res_ty $ \ res_ty' -> + popErrCtxt $ + tcStmtsAndThen ctxt stmt_chk stmts res_ty' $ thing_inside ; return (L loc stmt' : stmts', thing) } --------------------------------- --- Pattern guards +--------------------------------------------------- +-- Pattern guards +--------------------------------------------------- + tcGuardStmt :: TcStmtChecker -tcGuardStmt _ (ExprStmt guard _ _) res_ty thing_inside +tcGuardStmt _ (ExprStmt guard _ _ _) res_ty thing_inside = do { guard' <- tcMonoExpr guard boolTy ; thing <- thing_inside res_ty - ; return (ExprStmt guard' noSyntaxExpr boolTy, thing) } + ; return (ExprStmt guard' noSyntaxExpr noSyntaxExpr boolTy, thing) } tcGuardStmt ctxt (BindStmt pat rhs _ _) res_ty thing_inside = do { (rhs', rhs_ty) <- tcInferRhoNC rhs -- Stmt has a context already @@ -352,25 +354,292 @@ = pprPanic "tcGuardStmt: unexpected Stmt" (ppr stmt) --------------------------------- --- List comprehensions and PArrays +--------------------------------------------------- +-- List comprehensions and PArrays +-- (no rebindable syntax) +--------------------------------------------------- + +-- Dealt with separately, rather than by tcMcStmt, because +-- a) PArr isn't (yet) an instance of Monad, so the generality seems overkill +-- b) We have special desugaring rules for list comprehensions, +-- which avoid creating intermediate lists. They in turn +-- assume that the bind/return operations are the regular +-- polymorphic ones, and in particular don't have any +-- coercion matching stuff in them. It's hard to avoid the +-- potential for non-trivial coercions in tcMcStmt tcLcStmt :: TyCon -- The list/Parray type constructor ([] or PArray) -> TcStmtChecker +tcLcStmt _ _ (LastStmt body _) elt_ty thing_inside + = do { body' <- tcMonoExprNC body elt_ty + ; thing <- thing_inside (panic "tcLcStmt: thing_inside") + ; return (LastStmt body' noSyntaxExpr, thing) } + -- A generator, pat <- rhs -tcLcStmt m_tc ctxt (BindStmt pat rhs _ _) res_ty thing_inside +tcLcStmt m_tc ctxt (BindStmt pat rhs _ _) elt_ty thing_inside = do { pat_ty <- newFlexiTyVarTy liftedTypeKind ; rhs' <- tcMonoExpr rhs (mkTyConApp m_tc [pat_ty]) ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $ - thing_inside res_ty + thing_inside elt_ty ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) } -- A boolean guard -tcLcStmt _ _ (ExprStmt rhs _ _) res_ty thing_inside +tcLcStmt _ _ (ExprStmt rhs _ _ _) elt_ty thing_inside = do { rhs' <- tcMonoExpr rhs boolTy - ; thing <- thing_inside res_ty - ; return (ExprStmt rhs' noSyntaxExpr boolTy, thing) } + ; thing <- thing_inside elt_ty + ; return (ExprStmt rhs' noSyntaxExpr noSyntaxExpr boolTy, thing) } + +-- ParStmt: See notes with tcMcStmt +tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s _ _ _) elt_ty thing_inside + = do { (pairs', thing) <- loop bndr_stmts_s + ; return (ParStmt pairs' noSyntaxExpr noSyntaxExpr noSyntaxExpr, thing) } + where + -- loop :: [([LStmt Name], [Name])] -> TcM ([([LStmt TcId], [TcId])], thing) + loop [] = do { thing <- thing_inside elt_ty + ; return ([], thing) } -- matching in the branches + + loop ((stmts, names) : pairs) + = do { (stmts', (ids, pairs', thing)) + <- tcStmtsAndThen ctxt (tcLcStmt m_tc) stmts elt_ty $ \ _elt_ty' -> + do { ids <- tcLookupLocalIds names + ; (pairs', thing) <- loop pairs + ; return (ids, pairs', thing) } + ; return ( (stmts', ids) : pairs', thing ) } + +tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts + , trS_bndrs = bindersMap + , trS_by = by, trS_using = using }) elt_ty thing_inside + = do { let (bndr_names, n_bndr_names) = unzip bindersMap + unused_ty = pprPanic "tcLcStmt: inner ty" (ppr bindersMap) + -- The inner 'stmts' lack a LastStmt, so the element type + -- passed in to tcStmtsAndThen is never looked at + ; (stmts', (bndr_ids, by')) + <- tcStmtsAndThen (TransStmtCtxt ctxt) (tcLcStmt m_tc) stmts unused_ty $ \_ -> do + { by' <- case by of + Nothing -> return Nothing + Just e -> do { e_ty <- tcInferRho e; return (Just e_ty) } + ; bndr_ids <- tcLookupLocalIds bndr_names + ; return (bndr_ids, by') } + + ; let m_app ty = mkTyConApp m_tc [ty] + + --------------- Typecheck the 'using' function ------------- + -- using :: ((a,b,c)->t) -> m (a,b,c) -> m (a,b,c)m (ThenForm) + -- :: ((a,b,c)->t) -> m (a,b,c) -> m (m (a,b,c))) (GroupForm) + + -- n_app :: Type -> Type -- Wraps a 'ty' into '[ty]' for GroupForm + ; let n_app = case form of + ThenForm -> (\ty -> ty) + _ -> m_app + + by_arrow :: Type -> Type -- Wraps 'ty' to '(a->t) -> ty' if the By is present + by_arrow = case by' of + Nothing -> \ty -> ty + Just (_,e_ty) -> \ty -> (alphaTy `mkFunTy` e_ty) `mkFunTy` ty + + tup_ty = mkBigCoreVarTupTy bndr_ids + poly_arg_ty = m_app alphaTy + poly_res_ty = m_app (n_app alphaTy) + using_poly_ty = mkForAllTy alphaTyVar $ by_arrow $ + poly_arg_ty `mkFunTy` poly_res_ty + + ; using' <- tcPolyExpr using using_poly_ty + ; let final_using = fmap (HsWrap (WpTyApp tup_ty)) using' + + -- 'stmts' returns a result of type (m1_ty tuple_ty), + -- typically something like [(Int,Bool,Int)] + -- We don't know what tuple_ty is yet, so we use a variable + ; let mk_n_bndr :: Name -> TcId -> TcId + mk_n_bndr n_bndr_name bndr_id = mkLocalId n_bndr_name (n_app (idType bndr_id)) + + -- Ensure that every old binder of type `b` is linked up with its + -- new binder which should have type `n b` + -- See Note [GroupStmt binder map] in HsExpr + n_bndr_ids = zipWith mk_n_bndr n_bndr_names bndr_ids + bindersMap' = bndr_ids `zip` n_bndr_ids + + -- Type check the thing in the environment with + -- these new binders and return the result + ; thing <- tcExtendIdEnv n_bndr_ids (thing_inside elt_ty) + + ; return (emptyTransStmt { trS_stmts = stmts', trS_bndrs = bindersMap' + , trS_by = fmap fst by', trS_using = final_using + , trS_form = form }, thing) } + +tcLcStmt _ _ stmt _ _ + = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt) + + +--------------------------------------------------- +-- Monad comprehensions +-- (supports rebindable syntax) +--------------------------------------------------- + +tcMcStmt :: TcStmtChecker + +tcMcStmt _ (LastStmt body return_op) res_ty thing_inside + = do { a_ty <- newFlexiTyVarTy liftedTypeKind + ; return_op' <- tcSyntaxOp MCompOrigin return_op + (a_ty `mkFunTy` res_ty) + ; body' <- tcMonoExprNC body a_ty + ; thing <- thing_inside (panic "tcMcStmt: thing_inside") + ; return (LastStmt body' return_op', thing) } + +-- Generators for monad comprehensions ( pat <- rhs ) +-- +-- [ body | q <- gen ] -> gen :: m a +-- q :: a +-- + +tcMcStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside + = do { rhs_ty <- newFlexiTyVarTy liftedTypeKind + ; pat_ty <- newFlexiTyVarTy liftedTypeKind + ; new_res_ty <- newFlexiTyVarTy liftedTypeKind + + -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty + ; bind_op' <- tcSyntaxOp MCompOrigin bind_op + (mkFunTys [rhs_ty, mkFunTy pat_ty new_res_ty] res_ty) + + -- If (but only if) the pattern can fail, typecheck the 'fail' operator + ; fail_op' <- if isIrrefutableHsPat pat + then return noSyntaxExpr + else tcSyntaxOp MCompOrigin fail_op (mkFunTy stringTy new_res_ty) + + ; rhs' <- tcMonoExprNC rhs rhs_ty + ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $ + thing_inside new_res_ty + + ; return (BindStmt pat' rhs' bind_op' fail_op', thing) } + +-- Boolean expressions. +-- +-- [ body | stmts, expr ] -> expr :: m Bool +-- +tcMcStmt _ (ExprStmt rhs then_op guard_op _) res_ty thing_inside + = do { -- Deal with rebindable syntax: + -- guard_op :: test_ty -> rhs_ty + -- then_op :: rhs_ty -> new_res_ty -> res_ty + -- Where test_ty is, for example, Bool + test_ty <- newFlexiTyVarTy liftedTypeKind + ; rhs_ty <- newFlexiTyVarTy liftedTypeKind + ; new_res_ty <- newFlexiTyVarTy liftedTypeKind + ; rhs' <- tcMonoExpr rhs test_ty + ; guard_op' <- tcSyntaxOp MCompOrigin guard_op + (mkFunTy test_ty rhs_ty) + ; then_op' <- tcSyntaxOp MCompOrigin then_op + (mkFunTys [rhs_ty, new_res_ty] res_ty) + ; thing <- thing_inside new_res_ty + ; return (ExprStmt rhs' then_op' guard_op' rhs_ty, thing) } + +-- Grouping statements +-- +-- [ body | stmts, then group by e ] +-- -> e :: t +-- [ body | stmts, then group by e using f ] +-- -> e :: t +-- f :: forall a. (a -> t) -> m a -> m (m a) +-- [ body | stmts, then group using f ] +-- -> f :: forall a. m a -> m (m a) + +-- We type [ body | (stmts, group by e using f), ... ] +-- f [ (a,b,c) | stmts ] >>= \(a,b,c) -> ...body.... +-- +-- We type the functions as follows: +-- f :: m1 (a,b,c) -> m2 (a,b,c) (ThenForm) +-- :: m1 (a,b,c) -> m2 (n (a,b,c)) (GroupForm) +-- (>>=) :: m2 (a,b,c) -> ((a,b,c) -> res) -> res (ThenForm) +-- :: m2 (n (a,b,c)) -> (n (a,b,c) -> res) -> res (GroupForm) +-- +tcMcStmt ctxt (TransStmt { trS_stmts = stmts, trS_bndrs = bindersMap + , trS_by = by, trS_using = using, trS_form = form + , trS_ret = return_op, trS_bind = bind_op + , trS_fmap = fmap_op }) res_ty thing_inside + = do { let star_star_kind = liftedTypeKind `mkArrowKind` liftedTypeKind + ; m1_ty <- newFlexiTyVarTy star_star_kind + ; m2_ty <- newFlexiTyVarTy star_star_kind + ; tup_ty <- newFlexiTyVarTy liftedTypeKind + ; by_e_ty <- newFlexiTyVarTy liftedTypeKind -- The type of the 'by' expression (if any) + + -- n_app :: Type -> Type -- Wraps a 'ty' into '(n ty)' for GroupForm + ; n_app <- case form of + ThenForm -> return (\ty -> ty) + _ -> do { n_ty <- newFlexiTyVarTy star_star_kind + ; return (n_ty `mkAppTy`) } + ; let by_arrow :: Type -> Type + -- (by_arrow res) produces ((alpha->e_ty) -> res) ('by' present) + -- or res ('by' absent) + by_arrow = case by of + Nothing -> \res -> res + Just {} -> \res -> (alphaTy `mkFunTy` by_e_ty) `mkFunTy` res + + poly_arg_ty = m1_ty `mkAppTy` alphaTy + using_arg_ty = m1_ty `mkAppTy` tup_ty + poly_res_ty = m2_ty `mkAppTy` n_app alphaTy + using_res_ty = m2_ty `mkAppTy` n_app tup_ty + using_poly_ty = mkForAllTy alphaTyVar $ by_arrow $ + poly_arg_ty `mkFunTy` poly_res_ty + + -- 'stmts' returns a result of type (m1_ty tuple_ty), + -- typically something like [(Int,Bool,Int)] + -- We don't know what tuple_ty is yet, so we use a variable + ; let (bndr_names, n_bndr_names) = unzip bindersMap + ; (stmts', (bndr_ids, by', return_op')) <- + tcStmtsAndThen (TransStmtCtxt ctxt) tcMcStmt stmts using_arg_ty $ \res_ty' -> do + { by' <- case by of + Nothing -> return Nothing + Just e -> do { e' <- tcMonoExpr e by_e_ty; return (Just e') } + + -- Find the Ids (and hence types) of all old binders + ; bndr_ids <- tcLookupLocalIds bndr_names + + -- 'return' is only used for the binders, so we know its type. + -- return :: (a,b,c,..) -> m (a,b,c,..) + ; return_op' <- tcSyntaxOp MCompOrigin return_op $ + (mkBigCoreVarTupTy bndr_ids) `mkFunTy` res_ty' + + ; return (bndr_ids, by', return_op') } + + --------------- Typecheck the 'bind' function ------------- + -- (>>=) :: m2 (n (a,b,c)) -> ( n (a,b,c) -> new_res_ty ) -> res_ty + ; new_res_ty <- newFlexiTyVarTy liftedTypeKind + ; bind_op' <- tcSyntaxOp MCompOrigin bind_op $ + using_res_ty `mkFunTy` (n_app tup_ty `mkFunTy` new_res_ty) + `mkFunTy` res_ty + + --------------- Typecheck the 'fmap' function ------------- + ; fmap_op' <- case form of + ThenForm -> return noSyntaxExpr + _ -> fmap unLoc . tcPolyExpr (noLoc fmap_op) $ + mkForAllTy alphaTyVar $ mkForAllTy betaTyVar $ + (alphaTy `mkFunTy` betaTy) + `mkFunTy` (n_app alphaTy) + `mkFunTy` (n_app betaTy) + + --------------- Typecheck the 'using' function ------------- + -- using :: ((a,b,c)->t) -> m1 (a,b,c) -> m2 (n (a,b,c)) + + ; using' <- tcPolyExpr using using_poly_ty + ; let final_using = fmap (HsWrap (WpTyApp tup_ty)) using' + + --------------- Bulding the bindersMap ---------------- + ; let mk_n_bndr :: Name -> TcId -> TcId + mk_n_bndr n_bndr_name bndr_id = mkLocalId n_bndr_name (n_app (idType bndr_id)) + + -- Ensure that every old binder of type `b` is linked up with its + -- new binder which should have type `n b` + -- See Note [GroupStmt binder map] in HsExpr + n_bndr_ids = zipWith mk_n_bndr n_bndr_names bndr_ids + bindersMap' = bndr_ids `zip` n_bndr_ids + + -- Type check the thing in the environment with + -- these new binders and return the result + ; thing <- tcExtendIdEnv n_bndr_ids (thing_inside new_res_ty) + + ; return (TransStmt { trS_stmts = stmts', trS_bndrs = bindersMap' + , trS_by = by', trS_using = final_using + , trS_ret = return_op', trS_bind = bind_op' + , trS_fmap = fmap_op', trS_form = form }, thing) } -- A parallel set of comprehensions -- [ (g x, h x) | ... ; let g v = ... @@ -392,106 +661,95 @@ -- ensure that g,h and x,y don't duplicate, and simply grow the environment. -- So the binders of the first parallel group will be in scope in the second -- group. But that's fine; there's no shadowing to worry about. - -tcLcStmt m_tc ctxt (ParStmt bndr_stmts_s) elt_ty thing_inside - = do { (pairs', thing) <- loop bndr_stmts_s - ; return (ParStmt pairs', thing) } - where - -- loop :: [([LStmt Name], [Name])] -> TcM ([([LStmt TcId], [TcId])], thing) - loop [] = do { thing <- thing_inside elt_ty - ; return ([], thing) } -- matching in the branches - - loop ((stmts, names) : pairs) - = do { (stmts', (ids, pairs', thing)) - <- tcStmts ctxt (tcLcStmt m_tc) stmts elt_ty $ \ _elt_ty' -> - do { ids <- tcLookupLocalIds names - ; (pairs', thing) <- loop pairs - ; return (ids, pairs', thing) } - ; return ( (stmts', ids) : pairs', thing ) } - -tcLcStmt m_tc ctxt (TransformStmt stmts binders usingExpr maybeByExpr) elt_ty thing_inside = do - (stmts', (binders', usingExpr', maybeByExpr', thing)) <- - tcStmts (TransformStmtCtxt ctxt) (tcLcStmt m_tc) stmts elt_ty $ \elt_ty' -> do - let alphaListTy = mkTyConApp m_tc [alphaTy] - - (usingExpr', maybeByExpr') <- - case maybeByExpr of - Nothing -> do - -- We must validate that usingExpr :: forall a. [a] -> [a] - let using_ty = mkForAllTy alphaTyVar (alphaListTy `mkFunTy` alphaListTy) - usingExpr' <- tcPolyExpr usingExpr using_ty - return (usingExpr', Nothing) - Just byExpr -> do - -- We must infer a type such that e :: t and then check that - -- usingExpr :: forall a. (a -> t) -> [a] -> [a] - (byExpr', tTy) <- tcInferRhoNC byExpr - let using_ty = mkForAllTy alphaTyVar $ - (alphaTy `mkFunTy` tTy) - `mkFunTy` alphaListTy `mkFunTy` alphaListTy - usingExpr' <- tcPolyExpr usingExpr using_ty - return (usingExpr', Just byExpr') - - binders' <- tcLookupLocalIds binders - thing <- thing_inside elt_ty' - - return (binders', usingExpr', maybeByExpr', thing) - - return (TransformStmt stmts' binders' usingExpr' maybeByExpr', thing) - -tcLcStmt m_tc ctxt (GroupStmt stmts bindersMap by using) elt_ty thing_inside - = do { let (bndr_names, list_bndr_names) = unzip bindersMap - - ; (stmts', (bndr_ids, by', using_ty, elt_ty')) <- - tcStmts (TransformStmtCtxt ctxt) (tcLcStmt m_tc) stmts elt_ty $ \elt_ty' -> do - (by', using_ty) <- - case by of - Nothing -> -- check that using :: forall a. [a] -> [[a]] - return (Nothing, mkForAllTy alphaTyVar $ - alphaListTy `mkFunTy` alphaListListTy) - - Just by_e -> -- check that using :: forall a. (a -> t) -> [a] -> [[a]] - -- where by :: t - do { (by_e', t_ty) <- tcInferRhoNC by_e - ; return (Just by_e', mkForAllTy alphaTyVar $ - (alphaTy `mkFunTy` t_ty) - `mkFunTy` alphaListTy - `mkFunTy` alphaListListTy) } - -- Find the Ids (and hence types) of all old binders - bndr_ids <- tcLookupLocalIds bndr_names - - return (bndr_ids, by', using_ty, elt_ty') - - -- Ensure that every old binder of type b is linked up with - -- its new binder which should have type [b] - ; let list_bndr_ids = zipWith mk_list_bndr list_bndr_names bndr_ids - bindersMap' = bndr_ids `zip` list_bndr_ids - -- See Note [GroupStmt binder map] in HsExpr - - ; using' <- case using of - Left e -> do { e' <- tcPolyExpr e using_ty; return (Left e') } - Right e -> do { e' <- tcPolyExpr (noLoc e) using_ty; return (Right (unLoc e')) } - - -- Type check the thing in the environment with - -- these new binders and return the result - ; thing <- tcExtendIdEnv list_bndr_ids (thing_inside elt_ty') - ; return (GroupStmt stmts' bindersMap' by' using', thing) } - where - alphaListTy = mkTyConApp m_tc [alphaTy] - alphaListListTy = mkTyConApp m_tc [alphaListTy] - - mk_list_bndr :: Name -> TcId -> TcId - mk_list_bndr list_bndr_name bndr_id - = mkLocalId list_bndr_name (mkTyConApp m_tc [idType bndr_id]) - -tcLcStmt _ _ stmt _ _ - = pprPanic "tcLcStmt: unexpected Stmt" (ppr stmt) - --------------------------------- --- Do-notation --- The main excitement here is dealing with rebindable syntax +-- +-- Note: The `mzip` function will get typechecked via: +-- +-- ParStmt [st1::t1, st2::t2, st3::t3] +-- +-- mzip :: m st1 +-- -> (m st2 -> m st3 -> m (st2, st3)) -- recursive call +-- -> m (st1, (st2, st3)) +-- +tcMcStmt ctxt (ParStmt bndr_stmts_s mzip_op bind_op return_op) res_ty thing_inside + = do { let star_star_kind = liftedTypeKind `mkArrowKind` liftedTypeKind + ; m_ty <- newFlexiTyVarTy star_star_kind + + ; let mzip_ty = mkForAllTys [alphaTyVar, betaTyVar] $ + (m_ty `mkAppTy` alphaTy) + `mkFunTy` + (m_ty `mkAppTy` betaTy) + `mkFunTy` + (m_ty `mkAppTy` mkBoxedTupleTy [alphaTy, betaTy]) + ; mzip_op' <- unLoc `fmap` tcPolyExpr (noLoc mzip_op) mzip_ty + + ; return_op' <- fmap unLoc . tcPolyExpr (noLoc return_op) $ + mkForAllTy alphaTyVar $ + alphaTy `mkFunTy` (m_ty `mkAppTy` alphaTy) + + ; (pairs', thing) <- loop m_ty bndr_stmts_s + + -- Typecheck bind: + ; let tys = map (mkBigCoreVarTupTy . snd) pairs' + tuple_ty = mk_tuple_ty tys + + ; bind_op' <- tcSyntaxOp MCompOrigin bind_op $ + (m_ty `mkAppTy` tuple_ty) + `mkFunTy` (tuple_ty `mkFunTy` res_ty) + `mkFunTy` res_ty + + ; return (ParStmt pairs' mzip_op' bind_op' return_op', thing) } + + where + mk_tuple_ty tys = foldr1 (\tn tm -> mkBoxedTupleTy [tn, tm]) tys + + -- loop :: Type -- m_ty + -- -> [([LStmt Name], [Name])] + -- -> TcM ([([LStmt TcId], [TcId])], thing) + loop _ [] = do { thing <- thing_inside res_ty + ; return ([], thing) } -- matching in the branches + + loop m_ty ((stmts, names) : pairs) + = do { -- type dummy since we don't know all binder types yet + ty_dummy <- newFlexiTyVarTy liftedTypeKind + ; (stmts', (ids, pairs', thing)) + <- tcStmtsAndThen ctxt tcMcStmt stmts ty_dummy $ \res_ty' -> + do { ids <- tcLookupLocalIds names + ; let m_tup_ty = m_ty `mkAppTy` mkBigCoreVarTupTy ids + + ; check_same m_tup_ty res_ty' + ; check_same m_tup_ty ty_dummy + + ; (pairs', thing) <- loop m_ty pairs + ; return (ids, pairs', thing) } + ; return ( (stmts', ids) : pairs', thing ) } + + -- Check that the types match up. + -- This is a grevious hack. They always *will* match + -- If (>>=) and (>>) are polymorpic in the return type, + -- but we don't have any good way to incorporate the coercion + -- so for now we just check that it's the identity + check_same actual expected + = do { coi <- unifyType actual expected + ; unless (isReflCo coi) $ + failWithMisMatch [UnifyOrigin { uo_expected = expected + , uo_actual = actual }] } + +tcMcStmt _ stmt _ _ + = pprPanic "tcMcStmt: unexpected Stmt" (ppr stmt) + + +--------------------------------------------------- +-- Do-notation +-- (supports rebindable syntax) +--------------------------------------------------- tcDoStmt :: TcStmtChecker +tcDoStmt _ (LastStmt body _) res_ty thing_inside + = do { body' <- tcMonoExprNC body res_ty + ; thing <- thing_inside (panic "tcDoStmt: thing_inside") + ; return (LastStmt body' noSyntaxExpr, thing) } + tcDoStmt ctxt (BindStmt pat rhs bind_op fail_op) res_ty thing_inside = do { -- Deal with rebindable syntax: -- (>>=) :: rhs_ty -> (pat_ty -> new_res_ty) -> res_ty @@ -521,7 +779,7 @@ ; return (BindStmt pat' rhs' bind_op' fail_op', thing) } -tcDoStmt _ (ExprStmt rhs then_op _) res_ty thing_inside +tcDoStmt _ (ExprStmt rhs then_op _ _) res_ty thing_inside = do { -- Deal with rebindable syntax; -- (>>) :: rhs_ty -> new_res_ty -> res_ty -- See also Note [Treat rebindable syntax first] @@ -532,7 +790,7 @@ ; rhs' <- tcMonoExprNC rhs rhs_ty ; thing <- thing_inside new_res_ty - ; return (ExprStmt rhs' then_op' rhs_ty, thing) } + ; return (ExprStmt rhs' then_op' noSyntaxExpr rhs_ty, thing) } tcDoStmt ctxt (RecStmt { recS_stmts = stmts, recS_later_ids = later_names , recS_rec_ids = rec_names, recS_ret_fn = ret_op @@ -546,7 +804,7 @@ ; tcExtendIdEnv tup_ids $ do { stmts_ty <- newFlexiTyVarTy liftedTypeKind ; (stmts', (ret_op', tup_rets)) - <- tcStmts ctxt tcDoStmt stmts stmts_ty $ \ inner_res_ty -> + <- tcStmtsAndThen ctxt tcDoStmt stmts stmts_ty $ \ inner_res_ty -> do { tup_rets <- zipWithM tcCheckId tup_names tup_elt_tys -- Unify the types of the "final" Ids (which may -- be polymorphic) with those of "knot-tied" Ids @@ -562,7 +820,6 @@ (mkFunTys [mfix_res_ty, mkFunTy tup_ty new_res_ty] res_ty) ; thing <- thing_inside new_res_ty --- ; lie_binds <- bindLocalMethods lie tup_ids ; let rec_ids = takeList rec_names tup_ids ; later_ids <- tcLookupLocalIds later_names @@ -571,7 +828,7 @@ ; return (RecStmt { recS_stmts = stmts', recS_later_ids = later_ids , recS_rec_ids = rec_ids, recS_ret_fn = ret_op' , recS_mfix_fn = mfix_op', recS_bind_fn = bind_op' - , recS_rec_rets = tup_rets, recS_dicts = emptyTcEvBinds }, thing) + , recS_rec_rets = tup_rets, recS_ret_ty = stmts_ty }, thing) }} tcDoStmt _ stmt _ _ @@ -588,54 +845,6 @@ Otherwise the error shows up when cheking the rebindable syntax, and the expected/inferred stuff is back to front (see Trac #3613). -\begin{code} --------------------------------- --- Mdo-notation --- The distinctive features here are --- (a) RecStmts, and --- (b) no rebindable syntax - -tcMDoStmt :: (LHsExpr Name -> TcM (LHsExpr TcId, TcType)) -- RHS inference - -> TcStmtChecker -tcMDoStmt tc_rhs ctxt (BindStmt pat rhs _ _) res_ty thing_inside - = do { (rhs', pat_ty) <- tc_rhs rhs - ; (pat', thing) <- tcPat (StmtCtxt ctxt) pat pat_ty $ - thing_inside res_ty - ; return (BindStmt pat' rhs' noSyntaxExpr noSyntaxExpr, thing) } - -tcMDoStmt tc_rhs _ (ExprStmt rhs _ _) res_ty thing_inside - = do { (rhs', elt_ty) <- tc_rhs rhs - ; thing <- thing_inside res_ty - ; return (ExprStmt rhs' noSyntaxExpr elt_ty, thing) } - -tcMDoStmt tc_rhs ctxt (RecStmt stmts laterNames recNames _ _ _ _ _) res_ty thing_inside - = do { rec_tys <- newFlexiTyVarTys (length recNames) liftedTypeKind - ; let rec_ids = zipWith mkLocalId recNames rec_tys - ; tcExtendIdEnv rec_ids $ do - { (stmts', (later_ids, rec_rets)) - <- tcStmts ctxt (tcMDoStmt tc_rhs) stmts res_ty $ \ _res_ty' -> - -- ToDo: res_ty not really right - do { rec_rets <- zipWithM tcCheckId recNames rec_tys - ; later_ids <- tcLookupLocalIds laterNames - ; return (later_ids, rec_rets) } - - ; thing <- tcExtendIdEnv later_ids (thing_inside res_ty) - -- NB: The rec_ids for the recursive things - -- already scope over this part. This binding may shadow - -- some of them with polymorphic things with the same Name - -- (see note [RecStmt] in HsExpr) - --- Need the bindLocalMethods if we re-add Method constraints --- ; lie_binds <- bindLocalMethods lie later_ids - ; let lie_binds = emptyTcEvBinds - - ; return (RecStmt stmts' later_ids rec_ids noSyntaxExpr noSyntaxExpr noSyntaxExpr rec_rets lie_binds, thing) - }} - -tcMDoStmt _ _ stmt _ _ - = pprPanic "tcMDoStmt: unexpected Stmt" (ppr stmt) -\end{code} - %************************************************************************ %* * diff -Nru ghc-7.0.3/compiler/typecheck/TcMType.lhs ghc-7.2.1/compiler/typecheck/TcMType.lhs --- ghc-7.0.3/compiler/typecheck/TcMType.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/typecheck/TcMType.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -26,16 +26,15 @@ -------------------------------- -- Creating new evidence variables newEvVar, newCoVar, newEvVars, - writeWantedCoVar, readWantedCoVar, - newIP, newDict, newSilentGiven, isSilentEvVar, + newIP, newDict, newWantedEvVar, newWantedEvVars, newTcEvBinds, addTcEvBind, -------------------------------- -- Instantiation - tcInstTyVar, tcInstTyVars, tcInstSigTyVars, - tcInstType, instMetaTyVar, + tcInstTyVars, tcInstSigTyVars, + tcInstType, tcInstSkolTyVars, tcInstSuperSkolTyVars, tcInstSkolTyVar, tcInstSkolType, tcSkolDFunType, tcSuperSkolTyVars, @@ -43,16 +42,15 @@ -- Checking type validity Rank, UserTypeCtxt(..), checkValidType, checkValidMonoType, SourceTyCtxt(..), checkValidTheta, - checkValidInstance, - checkValidTypeInst, checkTyFamFreeness, + checkValidInstHead, checkValidInstance, + checkInstTermination, checkValidTypeInst, checkTyFamFreeness, arityErr, growPredTyVars, growThetaTyVars, validDerivPred, -------------------------------- -- Zonking zonkType, mkZonkTcTyVar, zonkTcPredType, - zonkTcTypeCarefully, - skolemiseUnboundMetaTyVar, + zonkTcTypeCarefully, skolemiseUnboundMetaTyVar, zonkTcTyVar, zonkTcTyVars, zonkTcTyVarsAndFV, zonkSigTyVar, zonkQuantifiedTyVar, zonkQuantifiedTyVars, zonkTcType, zonkTcTypes, zonkTcThetaType, @@ -72,7 +70,6 @@ import TypeRep import TcType import Type -import Coercion import Class import TyCon import Var @@ -145,7 +142,7 @@ newCoVar :: TcType -> TcType -> TcM CoVar newCoVar ty1 ty2 - = do { name <- newName (mkTyVarOccFS (fsLit "co")) + = do { name <- newName (mkVarOccFS (fsLit "co")) ; return (mkCoVar name (mkPredTy (EqPred ty1 ty2))) } newIP :: IPName Name -> TcType -> TcM IpId @@ -163,26 +160,6 @@ = do { uniq <- newUnique ; loc <- getSrcSpanM ; return (mkInternalName uniq occ loc) } - ------------------ -newSilentGiven :: PredType -> TcM EvVar --- Make a dictionary for a "silent" given dictionary --- Behaves just like any EvVar except that it responds True to isSilentDict --- This is used only to suppress confusing error reports -newSilentGiven (ClassP cls tys) - = do { uniq <- newUnique - ; let name = mkSystemName uniq (mkDictOcc (getOccName cls)) - ; return (mkLocalId name (mkPredTy (ClassP cls tys))) } -newSilentGiven (EqPred ty1 ty2) - = do { uniq <- newUnique - ; let name = mkSystemName uniq (mkTyVarOccFS (fsLit "co")) - ; return (mkCoVar name (mkPredTy (EqPred ty1 ty2))) } -newSilentGiven pred@(IParam {}) - = pprPanic "newSilentDict" (ppr pred) -- Implicit parameters rejected earlier - -isSilentEvVar :: EvVar -> Bool -isSilentEvVar v = isSystemName (Var.varName v) - -- Notice that all *other* evidence variables get Internal Names \end{code} @@ -258,8 +235,17 @@ tcInstSigTyVars :: [TyVar] -> TcM [TcTyVar] -- Make meta SigTv type variables for patten-bound scoped type varaibles -- We use SigTvs for them, so that they can't unify with arbitrary types -tcInstSigTyVars = mapM (\tv -> instMetaTyVar (SigTv (tyVarName tv)) tv) - -- ToDo: the "function binding site is bogus +tcInstSigTyVars = mapM tcInstSigTyVar + +tcInstSigTyVar :: TyVar -> TcM TcTyVar +tcInstSigTyVar tyvar + = do { uniq <- newMetaUnique + ; ref <- newMutVar Flexi + ; let name = setNameUnique (tyVarName tyvar) uniq + -- Use the same OccName so that the tidy-er + -- doesn't rename 'a' to 'a0' etc + kind = tyVarKind tyvar + ; return (mkTcTyVar name kind (MetaTv SigTv ref)) } \end{code} @@ -277,9 +263,9 @@ ; ref <- newMutVar Flexi ; let name = mkTcTyVarName uniq s s = case meta_info of - TauTv -> fsLit "t" - TcsTv -> fsLit "u" - SigTv _ -> fsLit "a" + TauTv -> fsLit "t" + TcsTv -> fsLit "u" + SigTv -> fsLit "a" ; return (mkTcTyVar name kind (MetaTv meta_info ref)) } mkTcTyVarName :: Unique -> FastString -> Name @@ -287,24 +273,10 @@ -- leaving the un-cluttered names free for user names mkTcTyVarName uniq str = mkSysTvName uniq str -instMetaTyVar :: MetaInfo -> TyVar -> TcM TcTyVar --- Make a new meta tyvar whose Name and Kind --- come from an existing TyVar -instMetaTyVar meta_info tyvar - = do { uniq <- newMetaUnique - ; ref <- newMutVar Flexi - ; let name = mkSystemName uniq (getOccName tyvar) - kind = tyVarKind tyvar - ; return (mkTcTyVar name kind (MetaTv meta_info ref)) } - readMetaTyVar :: TyVar -> TcM MetaDetails readMetaTyVar tyvar = ASSERT2( isMetaTyVar tyvar, ppr tyvar ) readMutVar (metaTvRef tyvar) -readWantedCoVar :: CoVar -> TcM MetaDetails -readWantedCoVar covar = ASSERT2( isMetaTyVar covar, ppr covar ) - readMutVar (metaTvRef covar) - isFilledMetaTyVar :: TyVar -> TcM Bool -- True of a filled-in (Indirect) meta type variable isFilledMetaTyVar tv @@ -343,9 +315,6 @@ = WARN( True, text "Writing to non-meta tyvar" <+> ppr tyvar ) return () -writeWantedCoVar :: CoVar -> Coercion -> TcM () -writeWantedCoVar cv co = writeMetaTyVar cv co - -------------------- writeMetaTyVarRef :: TcTyVar -> TcRef MetaDetails -> TcType -> TcM () -- Here the tyvar is for error checking only; @@ -364,8 +333,8 @@ | otherwise = do { meta_details <- readMutVar ref; - ; WARN( not (isFlexi meta_details), - hang (text "Double update of meta tyvar") + ; ASSERT2( isFlexi meta_details, + hang (text "Double update of meta tyvar") 2 (ppr tyvar $$ ppr meta_details) ) traceTc "writeMetaTyVar" (ppr tyvar <+> text ":=" <+> ppr ty) @@ -394,10 +363,6 @@ newFlexiTyVarTys :: Int -> Kind -> TcM [TcType] newFlexiTyVarTys n kind = mapM newFlexiTyVarTy (nOfThem n kind) -tcInstTyVar :: TyVar -> TcM TcTyVar --- Instantiate with a META type variable -tcInstTyVar tyvar = instMetaTyVar TauTv tyvar - tcInstTyVars :: [TyVar] -> TcM ([TcTyVar], [TcType], TvSubst) -- Instantiate with META type variables tcInstTyVars tyvars @@ -407,6 +372,16 @@ -- Since the tyvars are freshly made, -- they cannot possibly be captured by -- any existing for-alls. Hence zipTopTvSubst + +tcInstTyVar :: TyVar -> TcM TcTyVar +-- Make a new unification variable tyvar whose Name and Kind +-- come from an existing TyVar +tcInstTyVar tyvar + = do { uniq <- newMetaUnique + ; ref <- newMutVar Flexi + ; let name = mkSystemName uniq (getOccName tyvar) + kind = tyVarKind tyvar + ; return (mkTcTyVar name kind (MetaTv TauTv ref)) } \end{code} @@ -622,8 +597,8 @@ zonkWantedEvVar (EvVarX v l) = do { v' <- zonkEvVar v; return (EvVarX v' l) } zonkFlavor :: CtFlavor -> TcM CtFlavor -zonkFlavor (Given loc) = do { loc' <- zonkGivenLoc loc; return (Given loc') } -zonkFlavor fl = return fl +zonkFlavor (Given loc gk) = do { loc' <- zonkGivenLoc loc; return (Given loc' gk) } +zonkFlavor fl = return fl zonkGivenLoc :: GivenLoc -> TcM GivenLoc -- GivenLocs may have unification variables inside them! @@ -745,13 +720,12 @@ -- The two interesting cases! go (TyVarTy tyvar) | isTcTyVar tyvar = zonk_tc_tyvar tyvar - | otherwise = liftM TyVarTy $ - zonkTyVar zonk_tc_tyvar tyvar + | otherwise = return (TyVarTy tyvar) -- Ordinary (non Tc) tyvars occur inside quantified types go (ForAllTy tyvar ty) = ASSERT( isImmutableTyVar tyvar ) do ty' <- go ty - tyvar' <- zonkTyVar zonk_tc_tyvar tyvar + tyvar' <- return tyvar return (ForAllTy tyvar' ty') go_pred (ClassP c tys) = do tys' <- mapM go tys @@ -774,16 +748,6 @@ ; case cts of Flexi -> unbound_var_fn tyvar Indirect ty -> zonkType (mkZonkTcTyVar unbound_var_fn) ty } - --- Zonk the kind of a non-TC tyvar in case it is a coercion variable --- (their kind contains types). -zonkTyVar :: (TcTyVar -> TcM Type) -- What to do for a TcTyVar - -> TyVar -> TcM TyVar -zonkTyVar zonk_tc_tyvar tv - | isCoVar tv - = do { kind <- zonkType zonk_tc_tyvar (tyVarKind tv) - ; return $ setTyVarKind tv kind } - | otherwise = return tv \end{code} @@ -1154,7 +1118,7 @@ warnTc (notNull dups) (dupPredWarn dups) mapM_ (check_pred_ty dflags ctxt) theta where - (_,dups) = removeDups tcCmpPred theta + (_,dups) = removeDups cmpPred theta ------------------------- check_pred_ty :: DynFlags -> SourceTyCtxt -> PredType -> TcM () @@ -1175,12 +1139,11 @@ how_to_allow = parens (ptext (sLit "Use -XFlexibleContexts to permit this")) -check_pred_ty dflags ctxt pred@(EqPred ty1 ty2) +check_pred_ty dflags _ctxt pred@(EqPred ty1 ty2) = do { -- Equational constraints are valid in all contexts if type -- families are permitted - ; checkTc (xopt Opt_TypeFamilies dflags) (eqPredTyErr pred) - ; checkTc (case ctxt of ClassSCCtxt {} -> False; _ -> True) - (eqSuperClassErr pred) + ; checkTc (xopt Opt_TypeFamilies dflags || xopt Opt_GADTs dflags) + (eqPredTyErr pred) -- Check the form of the argument types ; checkValidMonoType ty1 @@ -1276,7 +1239,7 @@ ambigErr :: PredType -> SDoc ambigErr pred - = sep [ptext (sLit "Ambiguous constraint") <+> quotes (pprPred pred), + = sep [ptext (sLit "Ambiguous constraint") <+> quotes (pprPredTy pred), nest 2 (ptext (sLit "At least one of the forall'd type variables mentioned by the constraint") $$ ptext (sLit "must be reachable from the type after the '=>'"))] \end{code} @@ -1337,20 +1300,15 @@ = vcat [ptext (sLit "In the context:") <+> pprTheta theta, ptext (sLit "While checking") <+> pprSourceTyCtxt ctxt ] -eqSuperClassErr :: PredType -> SDoc -eqSuperClassErr pred - = hang (ptext (sLit "Alas, GHC 7.0 still cannot handle equality superclasses:")) - 2 (ppr pred) - badPredTyErr, eqPredTyErr, predTyVarErr :: PredType -> SDoc -badPredTyErr pred = ptext (sLit "Illegal constraint") <+> pprPred pred -eqPredTyErr pred = ptext (sLit "Illegal equational constraint") <+> pprPred pred +badPredTyErr pred = ptext (sLit "Illegal constraint") <+> pprPredTy pred +eqPredTyErr pred = ptext (sLit "Illegal equational constraint") <+> pprPredTy pred $$ - parens (ptext (sLit "Use -XTypeFamilies to permit this")) + parens (ptext (sLit "Use -XGADTs or -XTypeFamilies to permit this")) predTyVarErr pred = sep [ptext (sLit "Non type-variable argument"), - nest 2 (ptext (sLit "in the constraint:") <+> pprPred pred)] + nest 2 (ptext (sLit "in the constraint:") <+> pprPredTy pred)] dupPredWarn :: [[PredType]] -> SDoc -dupPredWarn dups = ptext (sLit "Duplicate constraint(s):") <+> pprWithCommas pprPred (map head dups) +dupPredWarn dups = ptext (sLit "Duplicate constraint(s):") <+> pprWithCommas pprPredTy (map head dups) arityErr :: Outputable a => String -> a -> Int -> Int -> SDoc arityErr kind name n m @@ -1498,7 +1456,7 @@ predUndecErr :: PredType -> SDoc -> SDoc predUndecErr pred msg = sep [msg, - nest 2 (ptext (sLit "in the constraint:") <+> pprPred pred)] + nest 2 (ptext (sLit "in the constraint:") <+> pprPredTy pred)] nomoreMsg, smallerMsg, undecidableMsg :: SDoc nomoreMsg = ptext (sLit "Variable occurs more often in a constraint than in the instance head") diff -Nru ghc-7.0.3/compiler/typecheck/TcPat.lhs ghc-7.2.1/compiler/typecheck/TcPat.lhs --- ghc-7.0.3/compiler/typecheck/TcPat.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/typecheck/TcPat.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -36,7 +36,6 @@ import BasicTypes hiding (SuccessFlag(..)) import DynFlags import SrcLoc -import ErrUtils import Util import Outputable import FastString @@ -149,7 +148,7 @@ instance Outputable TcSigInfo where ppr (TcSigInfo { sig_id = id, sig_tvs = tyvars, sig_theta = theta, sig_tau = tau}) - = ppr id <+> ptext (sLit "::") <+> ppr tyvars <+> pprThetaArrow theta <+> ppr tau + = ppr id <+> ptext (sLit "::") <+> ppr tyvars <+> pprThetaArrowTy theta <+> ppr tau \end{code} Note [sig_tau may be polymorphic] @@ -193,7 +192,7 @@ %************************************************************************ \begin{code} -tcPatBndr :: PatEnv -> Name -> TcSigmaType -> TcM (CoercionI, TcId) +tcPatBndr :: PatEnv -> Name -> TcSigmaType -> TcM (Coercion, TcId) -- (coi, xp) = tcPatBndr penv x pat_ty -- Then coi : pat_ty ~ typeof(xp) -- @@ -205,11 +204,11 @@ | otherwise = do { bndr_id <- newNoSigLetBndr no_gen bndr_name pat_ty - ; return (IdCo pat_ty, bndr_id) } + ; return (mkReflCo pat_ty, bndr_id) } tcPatBndr (PE { pe_ctxt = _lam_or_proc }) bndr_name pat_ty = do { bndr <- mkLocalBinder bndr_name pat_ty - ; return (IdCo pat_ty, bndr) } + ; return (mkReflCo pat_ty, bndr) } ------------ newSigLetBndr :: LetBndrSpec -> Name -> TcSigInfo -> TcM TcId @@ -348,9 +347,9 @@ -> TcM a -> TcM (LPat TcId, a) tc_lpat (L span pat) pat_ty penv thing_inside - = setSrcSpan span $ - maybeAddErrCtxt (patCtxt pat) $ - do { (pat', res) <- tc_pat penv pat pat_ty thing_inside + = setSrcSpan span $ + do { (pat', res) <- maybeWrapPatCtxt pat (tc_pat penv pat pat_ty) + thing_inside ; return (L span pat', res) } tc_lpats :: PatEnv @@ -373,17 +372,7 @@ tc_pat penv (VarPat name) pat_ty thing_inside = do { (coi, id) <- tcPatBndr penv name pat_ty ; res <- tcExtendIdEnv1 name id thing_inside - ; return (mkHsWrapPatCoI coi (VarPat id) pat_ty, res) } - -{- Need this if we re-add Method constraints - ; (res, binds) <- bindInstsOfPatId id $ - tcExtendIdEnv1 name id $ - (traceTc (text "binding" <+> ppr name <+> ppr (idType id)) - >> thing_inside) - ; let pat' | isEmptyTcEvBinds binds = VarPat id - | otherwise = VarPatOut id binds - ; return (mkHsWrapPatCoI coi pat' pat_ty, res) } --} + ; return (mkHsWrapPatCo coi (VarPat id) pat_ty, res) } tc_pat penv (ParPat pat) pat_ty thing_inside = do { (pat', res) <- tc_lpat pat pat_ty penv thing_inside @@ -433,7 +422,7 @@ -- perhaps be fixed, but only with a bit more work. -- -- If you fix it, don't forget the bindInstsOfPatIds! - ; return (mkHsWrapPatCoI coi (AsPat (L nm_loc bndr_id) pat') pat_ty, res) } + ; return (mkHsWrapPatCo coi (AsPat (L nm_loc bndr_id) pat') pat_ty, res) } tc_pat penv vpat@(ViewPat expr pat _) overall_pat_ty thing_inside = do { checkUnboxedTuple overall_pat_ty $ @@ -458,7 +447,7 @@ -- pattern must have pat_ty ; (pat', res) <- tc_lpat pat pat_ty penv thing_inside - ; return (ViewPat (mkLHsWrapCoI expr_coi expr') pat' overall_pat_ty, res) } + ; return (ViewPat (mkLHsWrapCo expr_coi expr') pat' overall_pat_ty, res) } -- Type signatures in patterns -- See Note [Pattern coercions] below @@ -469,9 +458,6 @@ ; return (mkHsWrapPat wrap (SigPatOut pat' inner_ty) pat_ty, res) } -tc_pat _ pat@(TypePat _) _ _ - = failWithTc (badTypePat pat) - ------------------------ -- Lists, tuples, arrays tc_pat penv (ListPat pats _) pat_ty thing_inside @@ -521,7 +507,7 @@ ; coi <- unifyPatType lit_ty pat_ty -- coi is of kind: pat_ty ~ lit_ty ; res <- thing_inside - ; return ( mkHsWrapPatCoI coi (LitPat simple_lit) pat_ty + ; return ( mkHsWrapPatCo coi (LitPat simple_lit) pat_ty , res) } ------------------------ @@ -556,19 +542,19 @@ ; instStupidTheta orig [mkClassPred icls [pat_ty']] ; res <- tcExtendIdEnv1 name bndr_id thing_inside - ; return (mkHsWrapPatCoI coi pat' pat_ty, res) } + ; return (mkHsWrapPatCo coi pat' pat_ty, res) } -tc_pat _ _other_pat _ _ = panic "tc_pat" -- ConPatOut, SigPatOut, VarPatOut +tc_pat _ _other_pat _ _ = panic "tc_pat" -- ConPatOut, SigPatOut ---------------- -unifyPatType :: TcType -> TcType -> TcM CoercionI +unifyPatType :: TcType -> TcType -> TcM Coercion -- In patterns we want a coercion from the -- context type (expected) to the actual pattern type -- But we don't want to reverse the args to unifyType because -- that controls the actual/expected stuff in error messages unifyPatType actual_ty expected_ty = do { coi <- unifyType actual_ty expected_ty - ; return (mkSymCoI coi) } + ; return (mkSymCo coi) } \end{code} Note [Hopping the LIE in lazy patterns] @@ -667,7 +653,7 @@ = do { data_con <- tcLookupDataCon con_name ; let tycon = dataConTyCon data_con -- For data families this is the representation tycon - (univ_tvs, ex_tvs, eq_spec, eq_theta, dict_theta, arg_tys, _) + (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) = dataConFullSig data_con -- Instantiate the constructor type variables [a->ty] @@ -689,9 +675,8 @@ tenv = zipTopTvSubst (univ_tvs ++ ex_tvs) (ctxt_res_tys ++ mkTyVarTys ex_tvs') arg_tys' = substTys tenv arg_tys - full_theta = eq_theta ++ dict_theta - ; if null ex_tvs && null eq_spec && null full_theta + ; if null ex_tvs && null eq_spec && null theta then do { -- The common case; no class bindings etc -- (see Note [Arrows and patterns]) (arg_pats', res) <- tcConArgs data_con arg_tys' @@ -706,8 +691,7 @@ else do -- The general case, with existential, -- and local equality constraints - { let eq_preds = [mkEqPred (mkTyVarTy tv, ty) | (tv, ty) <- eq_spec] - theta' = substTheta tenv (eq_preds ++ full_theta) + { let theta' = substTheta tenv (eqSpecPreds eq_spec ++ theta) -- order is *important* as we generate the list of -- dictionary binders from theta' no_equalities = not (any isEqPred theta') @@ -736,21 +720,21 @@ } } ---------------------------- -matchExpectedPatTy :: (TcRhoType -> TcM (CoercionI, a)) +matchExpectedPatTy :: (TcRhoType -> TcM (Coercion, a)) -> TcRhoType -> TcM (HsWrapper, a) -- See Note [Matching polytyped patterns] -- Returns a wrapper : pat_ty ~ inner_ty matchExpectedPatTy inner_match pat_ty | null tvs && null theta = do { (coi, res) <- inner_match pat_ty - ; return (coiToHsWrapper (mkSymCoI coi), res) } + ; return (coToHsWrapper (mkSymCo coi), res) } -- The Sym is because the inner_match returns a coercion -- that is the other way round to matchExpectedPatTy | otherwise = do { (_, tys, subst) <- tcInstTyVars tvs ; wrap1 <- instCall PatOrigin tys (substTheta subst theta) - ; (wrap2, arg_tys) <- matchExpectedPatTy inner_match (substTy subst tau) + ; (wrap2, arg_tys) <- matchExpectedPatTy inner_match (TcType.substTy subst tau) ; return (wrap2 <.> wrap1 , arg_tys) } where (tvs, theta, tau) = tcSplitSigmaTy pat_ty @@ -759,7 +743,7 @@ matchExpectedConTy :: TyCon -- The TyCon that this data -- constructor actually returns -> TcRhoType -- The type of the pattern - -> TcM (CoercionI, [TcSigmaType]) + -> TcM (Coercion, [TcSigmaType]) -- See Note [Matching constructor patterns] -- Returns a coercion : T ty1 ... tyn ~ pat_ty -- This is the same way round as matchExpectedListTy etc @@ -774,17 +758,16 @@ ; coi1 <- unifyType (mkTyConApp fam_tc (substTys subst fam_args)) pat_ty -- coi1 : T (ty1,ty2) ~ pat_ty - ; let coi2 = ACo (mkTyConApp co_tc tys) + ; let coi2 = mkAxInstCo co_tc tys -- coi2 : T (ty1,ty2) ~ T7 ty1 ty2 - ; return (mkTransCoI (mkSymCoI coi2) coi1, tys) } + ; return (mkTransCo (mkSymCo coi2) coi1, tys) } | otherwise = matchExpectedTyConApp data_tc pat_ty -- coi : T tys ~ pat_ty \end{code} -Noate [ Note [Matching constructor patterns] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Suppose (coi, tys) = matchExpectedConType data_tc pat_ty @@ -1016,12 +999,18 @@ -} \begin{code} -patCtxt :: Pat Name -> Maybe Message -- Not all patterns are worth pushing a context -patCtxt (VarPat _) = Nothing -patCtxt (ParPat _) = Nothing -patCtxt (AsPat _ _) = Nothing -patCtxt pat = Just (hang (ptext (sLit "In the pattern:")) - 2 (ppr pat)) +maybeWrapPatCtxt :: Pat Name -> (TcM a -> TcM b) -> TcM a -> TcM b +-- Not all patterns are worth pushing a context +maybeWrapPatCtxt pat tcm thing_inside + | not (worth_wrapping pat) = tcm thing_inside + | otherwise = addErrCtxt msg $ tcm $ popErrCtxt thing_inside + -- Remember to pop before doing thing_inside + where + worth_wrapping (VarPat {}) = False + worth_wrapping (ParPat {}) = False + worth_wrapping (AsPat {}) = False + worth_wrapping _ = True + msg = hang (ptext (sLit "In the pattern:")) 2 (ppr pat) ----------------------------------------------- checkExistentials :: [TyVar] -> PatEnv -> TcM () @@ -1057,9 +1046,6 @@ = hang (ptext (sLit "Illegal polymorphic type signature in pattern:")) 2 (ppr sig_ty) -badTypePat :: Pat Name -> SDoc -badTypePat pat = ptext (sLit "Illegal type pattern") <+> ppr pat - lazyUnliftedPatErr :: OutputableBndr name => Pat name -> TcM () lazyUnliftedPatErr pat = failWithTc $ diff -Nru ghc-7.0.3/compiler/typecheck/TcRnDriver.lhs ghc-7.2.1/compiler/typecheck/TcRnDriver.lhs --- ghc-7.0.3/compiler/typecheck/TcRnDriver.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/typecheck/TcRnDriver.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -2,15 +2,16 @@ % (c) The University of Glasgow 2006 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -\section[TcModule]{Typechecking a whole module} +\section[TcMovectle]{Typechecking a whole module} \begin{code} module TcRnDriver ( #ifdef GHCI tcRnStmt, tcRnExpr, tcRnType, tcRnLookupRdrName, - getModuleExports, + getModuleExports, #endif + tcRnImports, tcRnLookupName, tcRnGetInfo, tcRnModule, @@ -64,7 +65,6 @@ import NameEnv import NameSet import TyCon -import TysPrim import SrcLoc import HscTypes import ListSetOps @@ -204,7 +204,15 @@ = do { (rn_imports, rdr_env, imports,hpc_info) <- rnImports import_decls ; ; let { dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface) - ; dep_mods = imp_dep_mods imports + -- Make sure we record the dependencies from the DynFlags in the EPS or we + -- end up hitting the sanity check in LoadIface.loadInterface that + -- checks for unknown home-package modules being loaded. We put + -- these dependencies on the left so their (non-source) imports + -- take precedence over the (possibly-source) imports on the right. + -- We don't add them to any other field (e.g. the imp_dep_mods of + -- imports) because we don't want to load their instances etc. + ; dep_mods = listToUFM [(mod_nm, (mod_nm, False)) | mod_nm <- dynFlagDependencies (hsc_dflags hsc_env)] + `plusUFM` imp_dep_mods imports -- We want instance declarations from all home-package -- modules below this one, including boot modules, except @@ -245,9 +253,8 @@ -- interfaces, so that their rules and instance decls will be -- found. ; loadOrphanModules (imp_orphs imports) False - ; loadOrphanModules (imp_finsts imports) True - -- Check type-familily consistency + -- Check type-family consistency ; traceRn (text "rn1: checking family instance consistency") ; let { dir_imp_mods = moduleEnvKeys . imp_mods @@ -299,7 +306,7 @@ -- any mutually recursive types are done right -- Just discard the auxiliary bindings; they are generated -- only for Haskell source code, and should already be in Core - (tcg_env, _aux_binds, _dm_ids) <- tcTyAndClassDecls emptyModDetails rn_decls ; + (tcg_env, _aux_binds) <- tcTyAndClassDecls emptyModDetails rn_decls ; setGblEnv tcg_env $ do { -- Make the new type env available to stuff slurped from interface files @@ -316,10 +323,11 @@ final_type_env = extendTypeEnvWithIds (tcg_type_env tcg_env) bndrs ; - mod_guts = ModGuts { mg_module = this_mod, + mod_guts = ModGuts { mg_module = this_mod, mg_boot = False, mg_used_names = emptyNameSet, -- ToDo: compute usage - mg_dir_imps = emptyModuleEnv, -- ?? + mg_used_th = False, + mg_dir_imps = emptyModuleEnv, -- ?? mg_deps = noDependencies, -- ?? mg_exports = my_exports, mg_types = final_type_env, @@ -328,6 +336,7 @@ mg_inst_env = tcg_inst_env tcg_env, mg_fam_inst_env = tcg_fam_inst_env tcg_env, mg_rules = [], + mg_vect_decls = [], mg_anns = [], mg_binds = core_binds, @@ -338,7 +347,8 @@ mg_foreign = NoStubs, mg_hpc_info = emptyHpcInfo False, mg_modBreaks = emptyModBreaks, - mg_vect_info = noVectInfo + mg_vect_info = noVectInfo, + mg_trust_pkg = False } } ; tcCoreDump mod_guts ; @@ -390,30 +400,32 @@ -- It's a waste of time; and we may get debug warnings -- about strangely-typed TyCons! - -- Zonk the final code. This must be done last. - -- Even simplifyTop may do some unification. + -- Zonk the final code. This must be done last. + -- Even simplifyTop may do some unification. -- This pass also warns about missing type signatures - let { (tcg_env, _) = tc_envs - ; TcGblEnv { tcg_type_env = type_env, - tcg_binds = binds, - tcg_sigs = sig_ns, - tcg_ev_binds = cur_ev_binds, - tcg_imp_specs = imp_specs, - tcg_rules = rules, - tcg_fords = fords } = tcg_env + let { (tcg_env, _) = tc_envs + ; TcGblEnv { tcg_type_env = type_env, + tcg_binds = binds, + tcg_sigs = sig_ns, + tcg_ev_binds = cur_ev_binds, + tcg_imp_specs = imp_specs, + tcg_rules = rules, + tcg_vects = vects, + tcg_fords = fords } = tcg_env ; all_ev_binds = cur_ev_binds `unionBags` new_ev_binds } ; - (bind_ids, ev_binds', binds', fords', imp_specs', rules') - <- zonkTopDecls all_ev_binds binds sig_ns rules imp_specs fords ; - - let { final_type_env = extendTypeEnvWithIds type_env bind_ids - ; tcg_env' = tcg_env { tcg_binds = binds', - tcg_ev_binds = ev_binds', - tcg_imp_specs = imp_specs', - tcg_rules = rules', - tcg_fords = fords' } } ; + (bind_ids, ev_binds', binds', fords', imp_specs', rules', vects') + <- zonkTopDecls all_ev_binds binds sig_ns rules vects imp_specs fords ; + + let { final_type_env = extendTypeEnvWithIds type_env bind_ids + ; tcg_env' = tcg_env { tcg_binds = binds', + tcg_ev_binds = ev_binds', + tcg_imp_specs = imp_specs', + tcg_rules = rules', + tcg_vects = vects', + tcg_fords = fords' } } ; - setGlobalTypeEnv tcg_env' final_type_env + setGlobalTypeEnv tcg_env' final_type_env } } tc_rn_src_decls :: ModDetails -> [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv) @@ -480,6 +492,7 @@ hs_fords = for_decls, hs_defds = def_decls, hs_ruleds = rule_decls, + hs_vects = vect_decls, hs_annds = _, hs_valds = val_binds }) <- rnTopSrcDecls first_group ; (gbl_env, lie) <- captureConstraints $ setGblEnv tcg_env $ do { @@ -492,13 +505,13 @@ ; mapM_ (badBootDecl "foreign") for_decls ; mapM_ (badBootDecl "default") def_decls ; mapM_ (badBootDecl "rule") rule_decls + ; mapM_ (badBootDecl "vect") vect_decls -- Typecheck type/class decls ; traceTc "Tc2" empty - ; (tcg_env, aux_binds, dm_ids) + ; (tcg_env, aux_binds) <- tcTyAndClassDecls emptyModDetails tycl_decls - ; setGblEnv tcg_env $ - tcExtendIdEnv dm_ids $ do { + ; setGblEnv tcg_env $ do { -- Typecheck instance decls -- Family instance declarations are rejected here @@ -639,7 +652,7 @@ check_inst boot_inst = case [dfun | inst <- local_insts, let dfun = instanceDFunId inst, - idType dfun `tcEqType` boot_inst_ty ] of + idType dfun `eqType` boot_inst_ty ] of [] -> do { traceTc "check_inst" (vcat [ text "local_insts" <+> vcat (map (ppr . idType . instanceDFunId) local_insts) , text "boot_inst" <+> ppr boot_inst , text "boot_inst_ty" <+> ppr boot_inst_ty @@ -663,7 +676,7 @@ checkBootDecl (AnId id1) (AnId id2) = ASSERT(id1 == id2) - (idType id1 `tcEqType` idType id2) + (idType id1 `eqType` idType id2) checkBootDecl (ATyCon tc1) (ATyCon tc2) = checkBootTyCon tc1 tc2 @@ -680,7 +693,7 @@ eqSig (id1, def_meth1) (id2, def_meth2) = idName id1 == idName id2 && - tcEqTypeX env op_ty1 op_ty2 && + eqTypeX env op_ty1 op_ty2 && def_meth1 == def_meth2 where (_, rho_ty1) = splitForAllTys (idType id1) @@ -689,8 +702,8 @@ op_ty2 = funResultTy rho_ty2 eqFD (as1,bs1) (as2,bs2) = - eqListBy (tcEqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) && - eqListBy (tcEqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2) + eqListBy (eqTypeX env) (mkTyVarTys as1) (mkTyVarTys as2) && + eqListBy (eqTypeX env) (mkTyVarTys bs1) (mkTyVarTys bs2) same_kind tv1 tv2 = eqKind (tyVarKind tv1) (tyVarKind tv2) in @@ -699,7 +712,7 @@ eqListBy eqFD clas_fds1 clas_fds2 && (null sc_theta1 && null op_stuff1 && null ats1 || -- Above tests for an "abstract" class - eqListBy (tcEqPredX env) sc_theta1 sc_theta2 && + eqListBy (eqPredX env) sc_theta1 sc_theta2 && eqListBy eqSig op_stuff1 op_stuff2 && eqListBy checkBootTyCon ats1 ats2) @@ -722,7 +735,7 @@ eqSynRhs SynFamilyTyCon SynFamilyTyCon = True eqSynRhs (SynonymTyCon t1) (SynonymTyCon t2) - = tcEqTypeX env t1 t2 + = eqTypeX env t1 t2 eqSynRhs _ _ = False in equalLength tvs1 tvs2 && @@ -731,7 +744,7 @@ | isAlgTyCon tc1 && isAlgTyCon tc2 = ASSERT(tc1 == tc2) eqKind (tyConKind tc1) (tyConKind tc2) && - eqListBy tcEqPred (tyConStupidTheta tc1) (tyConStupidTheta tc2) && + eqListBy eqPred (tyConStupidTheta tc1) (tyConStupidTheta tc2) && eqAlgRhs (algTyConRhs tc1) (algTyConRhs tc2) | isForeignTyCon tc1 && isForeignTyCon tc2 @@ -755,17 +768,7 @@ && dataConIsInfix c1 == dataConIsInfix c2 && dataConStrictMarks c1 == dataConStrictMarks c2 && dataConFieldLabels c1 == dataConFieldLabels c2 - && let tvs1 = dataConUnivTyVars c1 ++ dataConExTyVars c1 - tvs2 = dataConUnivTyVars c2 ++ dataConExTyVars c2 - env = rnBndrs2 env0 tvs1 tvs2 - in - equalLength tvs1 tvs2 && - eqListBy (tcEqPredX env) - (dataConEqTheta c1 ++ dataConDictTheta c1) - (dataConEqTheta c2 ++ dataConDictTheta c2) && - eqListBy (tcEqTypeX env) - (dataConOrigArgTys c1) - (dataConOrigArgTys c2) + && eqType (dataConUserType c1) (dataConUserType c2) ---------------- missingBootThing :: Name -> String -> SDoc @@ -836,16 +839,16 @@ hs_defds = default_decls, hs_annds = annotation_decls, hs_ruleds = rule_decls, + hs_vects = vect_decls, hs_valds = val_binds }) = do { -- Type-check the type and class decls, and all imported decls -- The latter come in via tycl_decls traceTc "Tc2" empty ; - (tcg_env, aux_binds, dm_ids) <- tcTyAndClassDecls boot_details tycl_decls ; + (tcg_env, aux_binds) <- tcTyAndClassDecls boot_details tycl_decls ; -- If there are any errors, tcTyAndClassDecls fails here - setGblEnv tcg_env $ - tcExtendIdEnv dm_ids $ do { + setGblEnv tcg_env $ do { -- Source-language instances, including derivings, -- and import the supporting declarations @@ -878,21 +881,25 @@ setLclTypeEnv tcl_env $ do { -- Environment doesn't change now - -- Second pass over class and instance declarations, + -- Second pass over class and instance declarations, + -- now using the kind-checked decls traceTc "Tc6" empty ; - inst_binds <- tcInstDecls2 (concat tycl_decls) inst_infos ; + inst_binds <- tcInstDecls2 (concat tycl_decls) inst_infos ; - -- Foreign exports + -- Foreign exports traceTc "Tc7" empty ; - (foe_binds, foe_decls) <- tcForeignExports foreign_decls ; + (foe_binds, foe_decls) <- tcForeignExports foreign_decls ; -- Annotations - annotations <- tcAnnotations annotation_decls ; + annotations <- tcAnnotations annotation_decls ; - -- Rules - rules <- tcRules rule_decls ; + -- Rules + rules <- tcRules rule_decls ; - -- Wrap up + -- Vectorisation declarations + vects <- tcVectDecls vect_decls ; + + -- Wrap up traceTc "Tc7a" empty ; tcg_env <- getGblEnv ; let { all_binds = tc_val_binds `unionBags` @@ -904,15 +911,17 @@ ; sig_names = mkNameSet (collectHsValBinders val_binds) `minusNameSet` getTypeSigNames val_binds - -- Extend the GblEnv with the (as yet un-zonked) - -- bindings, rules, foreign decls - ; tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds - , tcg_imp_specs = tcg_imp_specs tcg_env ++ specs1 ++ specs2 ++ specs3 + -- Extend the GblEnv with the (as yet un-zonked) + -- bindings, rules, foreign decls + ; tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds + , tcg_imp_specs = tcg_imp_specs tcg_env ++ specs1 ++ specs2 ++ + specs3 , tcg_sigs = tcg_sigs tcg_env `unionNameSets` sig_names - , tcg_rules = tcg_rules tcg_env ++ rules - , tcg_anns = tcg_anns tcg_env ++ annotations - , tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ; - return (tcg_env', tcl_env) + , tcg_rules = tcg_rules tcg_env ++ rules + , tcg_vects = tcg_vects tcg_env ++ vects + , tcg_anns = tcg_anns tcg_env ++ annotations + , tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ; + return (tcg_env', tcl_env) }}}}}} \end{code} @@ -1087,7 +1096,8 @@ setInteractiveContext hsc_env ictxt $ do { -- Rename; use CmdLineMode because tcRnStmt is only used interactively - (([rn_stmt], _), fvs) <- rnStmts GhciStmt [rdr_stmt] (return ((), emptyFVs)) ; + (([rn_stmt], _), fvs) <- rnStmts GhciStmt [rdr_stmt] $ \_ -> + return ((), emptyFVs) ; traceRn (text "tcRnStmt" <+> vcat [ppr rdr_stmt, ppr rn_stmt, ppr fvs]) ; failIfErrsM ; rnDump (ppr rn_stmt) ; @@ -1192,7 +1202,7 @@ -------------------- mkPlan :: LStmt Name -> TcM PlanResult -mkPlan (L loc (ExprStmt expr _ _)) -- An expression typed at the prompt +mkPlan (L loc (ExprStmt expr _ _ _)) -- An expression typed at the prompt = do { uniq <- newUnique -- is treated very specially ; let fresh_it = itName uniq the_bind = L loc $ mkFunBind (L loc fresh_it) matches @@ -1201,7 +1211,7 @@ bind_stmt = L loc $ BindStmt (nlVarPat fresh_it) expr (HsVar bindIOName) noSyntaxExpr print_it = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar fresh_it)) - (HsVar thenIOName) placeHolderType + (HsVar thenIOName) noSyntaxExpr placeHolderType -- The plans are: -- [it <- e; print it] but not if it::() @@ -1229,7 +1239,7 @@ mkPlan stmt@(L loc (BindStmt {})) | [v] <- collectLStmtBinders stmt -- One binder, for a bind stmt = do { let print_v = L loc $ ExprStmt (nlHsApp (nlHsVar printName) (nlHsVar v)) - (HsVar thenIOName) placeHolderType + (HsVar thenIOName) noSyntaxExpr placeHolderType ; print_bind_result <- doptM Opt_PrintBindResult ; let print_plan = do @@ -1256,11 +1266,25 @@ let { ret_ty = mkListTy unitTy ; io_ret_ty = mkTyConApp ioTyCon [ret_ty] ; - tc_io_stmts stmts = tcStmts GhciStmt tcDoStmt stmts io_ret_ty ; - + tc_io_stmts stmts = tcStmtsAndThen GhciStmt tcDoStmt stmts io_ret_ty ; names = collectLStmtsBinders stmts ; + } ; + + -- OK, we're ready to typecheck the stmts + traceTc "TcRnDriver.tcGhciStmts: tc stmts" empty ; + ((tc_stmts, ids), lie) <- captureConstraints $ + tc_io_stmts stmts $ \ _ -> + mapM tcLookupId names ; + -- Look up the names right in the middle, + -- where they will all be in scope + + -- Simplify the context + traceTc "TcRnDriver.tcGhciStmts: simplify ctxt" empty ; + const_binds <- checkNoErrs (simplifyInteractive lie) ; + -- checkNoErrs ensures that the plan fails if context redn fails - -- mk_return builds the expression + traceTc "TcRnDriver.tcGhciStmts: done" empty ; + let { -- mk_return builds the expression -- returnIO @ [()] [coerce () x, .., coerce () z] -- -- Despite the inconvenience of building the type applications etc, @@ -1271,27 +1295,14 @@ -- then the type checker would instantiate x..z, and we wouldn't -- get their *polymorphic* values. (And we'd get ambiguity errs -- if they were overloaded, since they aren't applied to anything.) - mk_return ids = nlHsApp (nlHsTyApp ret_id [ret_ty]) - (noLoc $ ExplicitList unitTy (map mk_item ids)) ; + ret_expr = nlHsApp (nlHsTyApp ret_id [ret_ty]) + (noLoc $ ExplicitList unitTy (map mk_item ids)) ; mk_item id = nlHsApp (nlHsTyApp unsafeCoerceId [idType id, unitTy]) - (nlHsVar id) - } ; - - -- OK, we're ready to typecheck the stmts - traceTc "TcRnDriver.tcGhciStmts: tc stmts" empty ; - ((tc_stmts, ids), lie) <- captureConstraints $ tc_io_stmts stmts $ \ _ -> - mapM tcLookupId names ; - -- Look up the names right in the middle, - -- where they will all be in scope - - -- Simplify the context - traceTc "TcRnDriver.tcGhciStmts: simplify ctxt" empty ; - const_binds <- checkNoErrs (simplifyInteractive lie) ; - -- checkNoErrs ensures that the plan fails if context redn fails - - traceTc "TcRnDriver.tcGhciStmts: done" empty ; + (nlHsVar id) ; + stmts = tc_stmts ++ [noLoc (mkLastStmt ret_expr)] + } ; return (ids, mkHsDictLet (EvBinds const_binds) $ - noLoc (HsDo GhciStmt tc_stmts (mk_return ids) io_ret_ty)) + noLoc (HsDo GhciStmt stmts io_ret_ty)) } \end{code} @@ -1312,16 +1323,13 @@ -- Now typecheck the expression; -- it might have a rank-2 type (e.g. :t runST) - uniq <- newUnique ; let { fresh_it = itName uniq } ; - ((_tc_expr, res_ty), lie) <- captureConstraints (tcInferRho rn_expr) ; - ((qtvs, dicts, _), lie_top) <- captureConstraints $ - simplifyInfer TopLevel - False {- No MR for now -} + ((_tc_expr, res_ty), lie) <- captureConstraints (tcInferRho rn_expr) ; + ((qtvs, dicts, _), lie_top) <- captureConstraints $ + simplifyInfer TopLevel False {- No MR for now -} [(fresh_it, res_ty)] lie ; - _ <- simplifyInteractive lie_top ; -- Ignore the dicionary bindings let { all_expr_ty = mkForAllTys qtvs (mkPiTypes dicts res_ty) } ; @@ -1368,29 +1376,20 @@ -- could not be found. getModuleExports :: HscEnv -> Module -> IO (Messages, Maybe [AvailInfo]) getModuleExports hsc_env mod - = let - ic = hsc_IC hsc_env - checkMods = ic_toplev_scope ic ++ map fst (ic_exports ic) - in - initTc hsc_env HsSrcFile False iNTERACTIVE (tcGetModuleExports mod checkMods) + = initTc hsc_env HsSrcFile False iNTERACTIVE (tcGetModuleExports mod) -- Get the export avail info and also load all orphan and family-instance -- modules. Finally, check that the family instances of all modules in the -- interactive context are consistent (these modules are in the second -- argument). -tcGetModuleExports :: Module -> [Module] -> TcM [AvailInfo] -tcGetModuleExports mod directlyImpMods +tcGetModuleExports :: Module -> TcM [AvailInfo] +tcGetModuleExports mod = do { let doc = ptext (sLit "context for compiling statements") ; iface <- initIfaceTcRn $ loadSysInterface doc mod -- Load any orphan-module and family instance-module -- interfaces, so their instances are visible. ; loadOrphanModules (dep_orphs (mi_deps iface)) False - ; loadOrphanModules (dep_finsts (mi_deps iface)) True - - -- Check that the family instances of all directly loaded - -- modules are consistent. - ; checkFamInstConsistency (dep_finsts (mi_deps iface)) directlyImpMods ; ifaceExportNames (mi_exports iface) } @@ -1562,18 +1561,19 @@ -- It's unpleasant having both pprModGuts and pprModDetails here pprTcGblEnv :: TcGblEnv -> SDoc pprTcGblEnv (TcGblEnv { tcg_type_env = type_env, - tcg_insts = insts, - tcg_fam_insts = fam_insts, - tcg_rules = rules, - tcg_imports = imports }) + tcg_insts = insts, + tcg_fam_insts = fam_insts, + tcg_rules = rules, + tcg_vects = vects, + tcg_imports = imports }) = vcat [ ppr_types insts type_env , ppr_tycons fam_insts type_env - , ppr_insts insts - , ppr_fam_insts fam_insts - , vcat (map ppr rules) - , ppr_gen_tycons (typeEnvTyCons type_env) - , ptext (sLit "Dependent modules:") <+> - ppr (sortBy cmp_mp $ eltsUFM (imp_dep_mods imports)) + , ppr_insts insts + , ppr_fam_insts fam_insts + , vcat (map ppr rules) + , vcat (map ppr vects) + , ptext (sLit "Dependent modules:") <+> + ppr (sortBy cmp_mp $ eltsUFM (imp_dep_mods imports)) , ptext (sLit "Dependent packages:") <+> ppr (sortBy stablePackageIdCmp $ imp_dep_pkgs imports)] where -- The two uses of sortBy are just to reduce unnecessary @@ -1606,7 +1606,10 @@ ppr_tycons :: [FamInst] -> TypeEnv -> SDoc ppr_tycons fam_insts type_env - = text "TYPE CONSTRUCTORS" $$ nest 4 (ppr_tydecls tycons) + = vcat [ text "TYPE CONSTRUCTORS" + , nest 2 (ppr_tydecls tycons) + , text "COERCION AXIOMS" + , nest 2 (vcat (map pprCoAxiom (typeEnvCoAxioms type_env))) ] where fi_tycons = map famInstTyCon fam_insts tycons = [tycon | tycon <- typeEnvTyCons type_env, want_tycon tycon] @@ -1638,22 +1641,11 @@ = vcat (map ppr_tycon (sortLe le_sig tycons)) where le_sig tycon1 tycon2 = getOccName tycon1 <= getOccName tycon2 - ppr_tycon tycon - | isCoercionTyCon tycon - = sep [ptext (sLit "coercion") <+> ppr tycon <+> ppr tvs - , nest 2 (dcolon <+> pprEqPred (coercionKind (mkTyConApp tycon (mkTyVarTys tvs))))] - | otherwise = ppr (tyThingToIfaceDecl (ATyCon tycon)) - where - tvs = take (tyConArity tycon) alphaTyVars + ppr_tycon tycon = ppr (tyThingToIfaceDecl (ATyCon tycon)) ppr_rules :: [CoreRule] -> SDoc ppr_rules [] = empty ppr_rules rs = vcat [ptext (sLit "{-# RULES"), nest 2 (pprRules rs), ptext (sLit "#-}")] - -ppr_gen_tycons :: [TyCon] -> SDoc -ppr_gen_tycons [] = empty -ppr_gen_tycons tcs = vcat [ptext (sLit "Tycons with generics:"), - nest 2 (fsep (map ppr (filter tyConHasGenerics tcs)))] \end{code} diff -Nru ghc-7.0.3/compiler/typecheck/TcRnMonad.lhs ghc-7.2.1/compiler/typecheck/TcRnMonad.lhs --- ghc-7.0.3/compiler/typecheck/TcRnMonad.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/typecheck/TcRnMonad.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -22,6 +22,7 @@ import TcType import InstEnv import FamInstEnv +import PrelNames ( iNTERACTIVE ) import Var import Id @@ -73,7 +74,8 @@ tvs_var <- newIORef emptyVarSet ; keep_var <- newIORef emptyNameSet ; used_rdr_var <- newIORef Set.empty ; - th_var <- newIORef False ; + th_var <- newIORef False ; + th_splice_var<- newIORef False ; lie_var <- newIORef emptyWC ; dfun_n_var <- newIORef emptyOccSet ; type_env_var <- case hsc_type_env_var hsc_env of { @@ -83,8 +85,8 @@ maybe_rn_syntax :: forall a. a -> Maybe a ; maybe_rn_syntax empty_val | keep_rn_syntax = Just empty_val - | otherwise = Nothing ; - + | otherwise = Nothing ; + gbl_env = TcGblEnv { tcg_mod = mod, tcg_src = hsc_src, @@ -97,7 +99,8 @@ tcg_inst_env = emptyInstEnv, tcg_fam_inst_env = emptyFamInstEnv, tcg_th_used = th_var, - tcg_exports = [], + tcg_th_splice_used = th_splice_var, + tcg_exports = [], tcg_imports = emptyImportAvails, tcg_used_rdrnames = used_rdr_var, tcg_dus = emptyDUs, @@ -113,11 +116,12 @@ tcg_warns = NoWarnings, tcg_anns = [], tcg_insts = [], - tcg_fam_insts = [], - tcg_rules = [], - tcg_fords = [], - tcg_dfun_n = dfun_n_var, - tcg_keep = keep_var, + tcg_fam_insts = [], + tcg_rules = [], + tcg_fords = [], + tcg_vects = [], + tcg_dfun_n = dfun_n_var, + tcg_keep = keep_var, tcg_doc_hdr = Nothing, tcg_hpc = False, tcg_main = Nothing @@ -166,9 +170,8 @@ -> Module -> TcM r -> IO (Messages, Maybe r) -initTcPrintErrors env mod todo = do - (msgs, res) <- initTc env HsSrcFile False mod todo - return (msgs, res) + +initTcPrintErrors env mod todo = initTc env HsSrcFile False mod todo \end{code} %************************************************************************ @@ -247,21 +250,30 @@ doptM :: DynFlag -> TcRnIf gbl lcl Bool doptM flag = do { dflags <- getDOpts; return (dopt flag dflags) } --- XXX setOptM and unsetOptM operate on different types. One should be renamed. +woptM :: WarningFlag -> TcRnIf gbl lcl Bool +woptM flag = do { dflags <- getDOpts; return (wopt flag dflags) } -setOptM :: ExtensionFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a -setOptM flag = updEnv (\ env@(Env { env_top = top }) -> - env { env_top = top { hsc_dflags = xopt_set (hsc_dflags top) flag}} ) - -unsetOptM :: DynFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a -unsetOptM flag = updEnv (\ env@(Env { env_top = top }) -> - env { env_top = top { hsc_dflags = dopt_unset (hsc_dflags top) flag}} ) +setXOptM :: ExtensionFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a +setXOptM flag = updEnv (\ env@(Env { env_top = top }) -> + env { env_top = top { hsc_dflags = xopt_set (hsc_dflags top) flag}} ) + +unsetDOptM :: DynFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a +unsetDOptM flag = updEnv (\ env@(Env { env_top = top }) -> + env { env_top = top { hsc_dflags = dopt_unset (hsc_dflags top) flag}} ) + +unsetWOptM :: WarningFlag -> TcRnIf gbl lcl a -> TcRnIf gbl lcl a +unsetWOptM flag = updEnv (\ env@(Env { env_top = top }) -> + env { env_top = top { hsc_dflags = wopt_unset (hsc_dflags top) flag}} ) -- | Do it flag is true ifDOptM :: DynFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () ifDOptM flag thing_inside = do { b <- doptM flag; if b then thing_inside else return () } +ifWOptM :: WarningFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () +ifWOptM flag thing_inside = do { b <- woptM flag; + if b then thing_inside else return () } + ifXOptM :: ExtensionFlag -> TcRnIf gbl lcl () -> TcRnIf gbl lcl () ifXOptM flag thing_inside = do { b <- xoptM flag; if b then thing_inside else return () } @@ -328,11 +340,11 @@ newUnique :: TcRnIf gbl lcl Unique newUnique = do { env <- getEnv ; - let { u_var = env_us env } ; - us <- readMutVar u_var ; - case splitUniqSupply us of { (us1,_) -> do { - writeMutVar u_var us1 ; - return $! uniqFromSupply us }}} + let { u_var = env_us env } ; + us <- readMutVar u_var ; + case takeUniqFromSupply us of { (uniq, us') -> do { + writeMutVar u_var us' ; + return $! uniq }}} -- NOTE 1: we strictly split the supply, to avoid the possibility of leaving -- a chain of unevaluated supplies behind. -- NOTE 2: we use the uniq in the supply from the MutVar directly, and @@ -343,11 +355,11 @@ newUniqueSupply :: TcRnIf gbl lcl UniqSupply newUniqueSupply = do { env <- getEnv ; - let { u_var = env_us env } ; - us <- readMutVar u_var ; + let { u_var = env_us env } ; + us <- readMutVar u_var ; case splitUniqSupply us of { (us1,us2) -> do { - writeMutVar u_var us1 ; - return us2 }}} + writeMutVar u_var us1 ; + return us2 }}} newLocalName :: Name -> TcRnIf gbl lcl Name newLocalName name -- Make a clone @@ -405,7 +417,6 @@ traceRn = traceOptTcRn Opt_D_dump_rn_trace traceSplice = traceOptTcRn Opt_D_dump_splices - traceIf, traceHiDiffs :: SDoc -> TcRnIf m n () traceIf = traceOptIf Opt_D_dump_if_trace traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs @@ -452,6 +463,9 @@ setModule :: Module -> TcRn a -> TcRn a setModule mod thing_inside = updGblEnv (\env -> env { tcg_mod = mod }) thing_inside +getIsGHCi :: TcRn Bool +getIsGHCi = do { mod <- getModule; return (mod == iNTERACTIVE) } + tcIsHsBoot :: TcRn Bool tcIsHsBoot = do { env <- getGblEnv; return (isHsBoot (tcg_src env)) } @@ -491,9 +505,10 @@ getSrcSpanM = do { env <- getLclEnv; return (tcl_loc env) } setSrcSpan :: SrcSpan -> TcRn a -> TcRn a -setSrcSpan loc thing_inside - | isGoodSrcSpan loc = updLclEnv (\env -> env { tcl_loc = loc }) thing_inside - | otherwise = thing_inside -- Don't overwrite useful info with useless +setSrcSpan loc@(RealSrcSpan _) thing_inside + = updLclEnv (\env -> env { tcl_loc = loc }) thing_inside +-- Don't overwrite useful info with useless: +setSrcSpan (UnhelpfulSpan _) thing_inside = thing_inside addLocM :: (a -> TcM b) -> Located a -> TcM b addLocM fn (L loc a) = setSrcSpan loc $ fn a @@ -777,11 +792,6 @@ updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) -> env { tcl_ctxt = upd ctxt }) --- Conditionally add an error context -maybeAddErrCtxt :: Maybe Message -> TcM a -> TcM a -maybeAddErrCtxt (Just msg) thing_inside = addErrCtxt msg thing_inside -maybeAddErrCtxt Nothing thing_inside = thing_inside - popErrCtxt :: TcM a -> TcM a popErrCtxt = updCtxt (\ msgs -> case msgs of { [] -> []; (_ : ms) -> ms }) @@ -893,6 +903,9 @@ mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc -- Tidy the error info, trimming excessive contexts mkErrInfo env ctxts + | opt_PprStyle_Debug -- In -dppr-debug style the output + = return empty -- just becomes too voluminous + | otherwise = go 0 env ctxts where go :: Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc @@ -988,10 +1001,10 @@ -- (captureConstraints m) runs m, and returns the type constraints it generates captureConstraints thing_inside = do { lie_var <- newTcRef emptyWC ; - res <- updLclEnv (\ env -> env { tcl_lie = lie_var }) - thing_inside ; - lie <- readTcRef lie_var ; - return (res, lie) } + res <- updLclEnv (\ env -> env { tcl_lie = lie_var }) + thing_inside ; + lie <- readTcRef lie_var ; + return (res, lie) } captureUntouchables :: TcM a -> TcM (a, Untouchables) captureUntouchables thing_inside @@ -1016,20 +1029,30 @@ = updLclEnv upd thing_inside where upd env = env { tcl_env = tcl_env lcl_env, - tcl_tyvars = tcl_tyvars lcl_env } + tcl_tyvars = tcl_tyvars lcl_env } + +traceTcConstraints :: String -> TcM () +traceTcConstraints msg + = do { lie_var <- getConstraintVar + ; lie <- readTcRef lie_var + ; traceTc (msg ++ "LIE:") (ppr lie) + } \end{code} %************************************************************************ -%* * - Template Haskell context -%* * +%* * + Template Haskell context +%* * %************************************************************************ \begin{code} recordThUse :: TcM () recordThUse = do { env <- getGblEnv; writeTcRef (tcg_th_used env) True } +recordThSpliceUse :: TcM () +recordThSpliceUse = do { env <- getGblEnv; writeTcRef (tcg_th_splice_used env) True } + keepAliveTc :: Id -> TcM () -- Record the name in the keep-alive set keepAliveTc id | isLocalId id = do { env <- getGblEnv; @@ -1148,7 +1171,7 @@ failIfM msg = do { env <- getLclEnv ; let full_msg = (if_loc env <> colon) $$ nest 2 msg - ; liftIO (printErrs (full_msg defaultErrStyle)) + ; liftIO (printErrs full_msg defaultErrStyle) ; failM } -------------------- @@ -1183,7 +1206,7 @@ ; return Nothing } }} where - print_errs sdoc = liftIO (printErrs (sdoc defaultErrStyle)) + print_errs sdoc = liftIO (printErrs sdoc defaultErrStyle) forkM :: SDoc -> IfL a -> IfL a forkM doc thing_inside diff -Nru ghc-7.0.3/compiler/typecheck/TcRnTypes.lhs ghc-7.2.1/compiler/typecheck/TcRnTypes.lhs --- ghc-7.0.3/compiler/typecheck/TcRnTypes.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/typecheck/TcRnTypes.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -40,11 +40,13 @@ Implication(..), CtLoc(..), ctLocSpan, ctLocOrigin, setCtLocOrigin, CtOrigin(..), EqOrigin(..), - WantedLoc, GivenLoc, pushErrCtxt, + WantedLoc, GivenLoc, GivenKind(..), pushErrCtxt, - SkolemInfo(..), + SkolemInfo(..), - CtFlavor(..), pprFlavorArising, isWanted, isGiven, isDerived, + CtFlavor(..), pprFlavorArising, isWanted, + isGivenOrSolved, isGiven_maybe, + isDerived, FlavoredEvVar, -- Pretty printing @@ -62,6 +64,7 @@ import HsSyn import HscTypes import Type +import Id ( evVarPred ) import Class ( Class ) import DataCon ( DataCon, dataConUserType ) import TcType @@ -233,6 +236,11 @@ -- is implicit rather than explicit, so we have to zap a -- mutable variable. + tcg_th_splice_used :: TcRef Bool, + -- ^ @True@ <=> A Template Haskell splice was used. + -- + -- Splices disable recompilation avoidance (see #481) + tcg_dfun_n :: TcRef OccSet, -- ^ Allows us to choose unique DFun names. @@ -260,9 +268,10 @@ tcg_warns :: Warnings, -- ...Warnings and deprecations tcg_anns :: [Annotation], -- ...Annotations tcg_insts :: [Instance], -- ...Instances - tcg_fam_insts :: [FamInst], -- ...Family instances - tcg_rules :: [LRuleDecl Id], -- ...Rules - tcg_fords :: [LForeignDecl Id], -- ...Foreign import & exports + tcg_fam_insts :: [FamInst], -- ...Family instances + tcg_rules :: [LRuleDecl Id], -- ...Rules + tcg_fords :: [LForeignDecl Id], -- ...Foreign import & exports + tcg_vects :: [LVectDecl Id], -- ...Vectorisation declarations tcg_doc_hdr :: Maybe LHsDocString, -- ^ Maybe Haddock header docs tcg_hpc :: AnyHpcUsage, -- ^ @True@ if any part of the @@ -323,6 +332,7 @@ -- plus which bit is currently being examined if_tv_env :: UniqFM TyVar, -- Nested tyvar bindings + -- (and coercions) if_id_env :: UniqFM Id -- Nested id binding } \end{code} @@ -566,7 +576,8 @@ -- data ImportAvails = ImportAvails { - imp_mods :: ModuleEnv [(ModuleName, Bool, SrcSpan)], + imp_mods :: ImportedMods, + -- = ModuleEnv [(ModuleName, Bool, SrcSpan, Bool)], -- ^ Domain is all directly-imported modules -- The 'ModuleName' is what the module was imported as, e.g. in -- @ @@ -593,26 +604,43 @@ -- different packages. (currently not the case, but might be in the -- future). - imp_dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface), - -- ^ Home-package modules needed by the module being compiled - -- - -- It doesn't matter whether any of these dependencies - -- are actually /used/ when compiling the module; they - -- are listed if they are below it at all. For - -- example, suppose M imports A which imports X. Then - -- compiling M might not need to consult X.hi, but X - -- is still listed in M's dependencies. + imp_dep_mods :: ModuleNameEnv (ModuleName, IsBootInterface), + -- ^ Home-package modules needed by the module being compiled + -- + -- It doesn't matter whether any of these dependencies + -- are actually /used/ when compiling the module; they + -- are listed if they are below it at all. For + -- example, suppose M imports A which imports X. Then + -- compiling M might not need to consult X.hi, but X + -- is still listed in M's dependencies. - imp_dep_pkgs :: [PackageId], + imp_dep_pkgs :: [PackageId], -- ^ Packages needed by the module being compiled, whether directly, -- or via other modules in this package, or via modules imported -- from other packages. + + imp_trust_pkgs :: [PackageId], + -- ^ This is strictly a subset of imp_dep_pkgs and records the + -- packages the current module needs to trust for Safe Haskell + -- compilation to succeed. A package is required to be trusted if + -- we are dependent on a trustworthy module in that package. + -- While perhaps making imp_dep_pkgs a tuple of (PackageId, Bool) + -- where True for the bool indicates the package is required to be + -- trusted is the more logical design, doing so complicates a lot + -- of code not concerned with Safe Haskell. + -- See Note [RnNames . Tracking Trust Transitively] + + imp_trust_own_pkg :: Bool, + -- ^ Do we require that our own package is trusted? + -- This is to handle efficiently the case where a Safe module imports + -- a Trustworthy module that resides in the same package as it. + -- See Note [RnNames . Trust Own Package] - imp_orphs :: [Module], + imp_orphs :: [Module], -- ^ Orphan modules below us in the import tree (and maybe including -- us for imported modules) - imp_finsts :: [Module] + imp_finsts :: [Module] -- ^ Family instance modules below us in the import tree (and maybe -- including us for imported modules) } @@ -624,30 +652,41 @@ add env elt@(m,_) = addToUFM env m elt emptyImportAvails :: ImportAvails -emptyImportAvails = ImportAvails { imp_mods = emptyModuleEnv, - imp_dep_mods = emptyUFM, - imp_dep_pkgs = [], - imp_orphs = [], - imp_finsts = [] } +emptyImportAvails = ImportAvails { imp_mods = emptyModuleEnv, + imp_dep_mods = emptyUFM, + imp_dep_pkgs = [], + imp_trust_pkgs = [], + imp_trust_own_pkg = False, + imp_orphs = [], + imp_finsts = [] } +-- | Union two ImportAvails +-- +-- This function is a key part of Import handling, basically +-- for each import we create a seperate ImportAvails structure +-- and then union them all together with this function. plusImportAvails :: ImportAvails -> ImportAvails -> ImportAvails plusImportAvails (ImportAvails { imp_mods = mods1, - imp_dep_mods = dmods1, imp_dep_pkgs = dpkgs1, + imp_dep_mods = dmods1, imp_dep_pkgs = dpkgs1, + imp_trust_pkgs = tpkgs1, imp_trust_own_pkg = tself1, imp_orphs = orphs1, imp_finsts = finsts1 }) (ImportAvails { imp_mods = mods2, - imp_dep_mods = dmods2, imp_dep_pkgs = dpkgs2, + imp_dep_mods = dmods2, imp_dep_pkgs = dpkgs2, + imp_trust_pkgs = tpkgs2, imp_trust_own_pkg = tself2, imp_orphs = orphs2, imp_finsts = finsts2 }) - = 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, - imp_finsts = finsts1 `unionLists` finsts2 } + = ImportAvails { imp_mods = plusModuleEnv_C (++) mods1 mods2, + imp_dep_mods = plusUFM_C plus_mod_dep dmods1 dmods2, + imp_dep_pkgs = dpkgs1 `unionLists` dpkgs2, + imp_trust_pkgs = tpkgs1 `unionLists` tpkgs2, + imp_trust_own_pkg = tself1 || tself2, + imp_orphs = orphs1 `unionLists` orphs2, + imp_finsts = finsts1 `unionLists` finsts2 } where plus_mod_dep (m1, boot1) (m2, boot2) - = WARN( not (m1 == m2), (ppr m1 <+> ppr m2) $$ (ppr boot1 <+> ppr boot2) ) - -- Check mod-names match - (m1, boot1 && boot2) -- If either side can "see" a non-hi-boot interface, use that + = WARN( not (m1 == m2), (ppr m1 <+> ppr m2) $$ (ppr boot1 <+> ppr boot2) ) + -- Check mod-names match + (m1, boot1 && boot2) -- If either side can "see" a non-hi-boot interface, use that \end{code} %************************************************************************ @@ -673,7 +712,6 @@ %************************************************************************ %* * Wanted constraints - These are forced to be in TcRnTypes because TcLclEnv mentions WantedConstraints WantedConstraint mentions CtLoc @@ -714,10 +752,10 @@ , wc_insol = n1 `unionBags` n2 } addFlats :: WantedConstraints -> Bag WantedEvVar -> WantedConstraints -addFlats wc wevs = wc { wc_flat = wevs `unionBags` wc_flat wc } +addFlats wc wevs = wc { wc_flat = wc_flat wc `unionBags` wevs } addImplics :: WantedConstraints -> Bag Implication -> WantedConstraints -addImplics wc implic = wc { wc_impl = implic `unionBags` wc_impl wc } +addImplics wc implic = wc { wc_impl = wc_impl wc `unionBags` implic } instance Outputable WantedConstraints where ppr (WC {wc_flat = f, wc_impl = i, wc_insol = n}) @@ -792,8 +830,8 @@ -- which is also the location of all the -- given evidence variables - ic_wanted :: WantedConstraints, -- The wanted - ic_insol :: Bool, -- True iff insolubleWC ic_wantted is true + ic_wanted :: WantedConstraints, -- The wanted + ic_insol :: Bool, -- True iff insolubleWC ic_wanted is true ic_binds :: EvBindsVar -- Points to the place to fill in the -- abstraction and bindings @@ -883,11 +921,12 @@ keepWanted :: Bag FlavoredEvVar -> Bag WantedEvVar keepWanted flevs - = foldlBag keep_wanted emptyBag flevs + = foldrBag keep_wanted emptyBag flevs + -- Important: use fold*r*Bag to preserve the order of the evidence variables. where - keep_wanted :: Bag WantedEvVar -> FlavoredEvVar -> Bag WantedEvVar - keep_wanted r (EvVarX ev (Wanted wloc)) = consBag (EvVarX ev wloc) r - keep_wanted r _ = r + keep_wanted :: FlavoredEvVar -> Bag WantedEvVar -> Bag WantedEvVar + keep_wanted (EvVarX ev (Wanted wloc)) r = consBag (EvVarX ev wloc) r + keep_wanted _ r = r \end{code} @@ -899,7 +938,7 @@ pprEvVarTheta ev_vars = pprTheta (map evVarPred ev_vars) pprEvVarWithType :: EvVar -> SDoc -pprEvVarWithType v = ppr v <+> dcolon <+> pprPred (evVarPred v) +pprEvVarWithType v = ppr v <+> dcolon <+> pprPredTy (evVarPred v) pprWantedsWithLocs :: WantedConstraints -> SDoc pprWantedsWithLocs wcs @@ -921,35 +960,37 @@ \begin{code} data CtFlavor - = Given GivenLoc -- We have evidence for this constraint in TcEvBinds - | Derived WantedLoc - -- We have evidence for this constraint in TcEvBinds; - -- *however* this evidence can contain wanteds, so - -- it's valid only provisionally to the solution of - -- these wanteds - | Wanted WantedLoc -- We have no evidence bindings for this constraint. - --- data DerivedOrig = DerSC | DerInst | DerSelf --- Deriveds are either superclasses of other wanteds or deriveds, or partially --- solved wanteds from instances, or 'self' dictionaries containing yet wanted --- superclasses. + = Given GivenLoc GivenKind -- We have evidence for this constraint in TcEvBinds + | Derived WantedLoc -- Derived's are just hints for unifications + | Wanted WantedLoc -- We have no evidence bindings for this constraint. + +data GivenKind + = GivenOrig -- Originates in some given, such as signature or pattern match + | GivenSolved -- Is given as result of being solved, maybe provisionally on + -- some other wanted constraints. instance Outputable CtFlavor where - ppr (Given {}) = ptext (sLit "[G]") - ppr (Wanted {}) = ptext (sLit "[W]") - ppr (Derived {}) = ptext (sLit "[D]") + ppr (Given _ GivenOrig) = ptext (sLit "[G]") + ppr (Given _ GivenSolved) = ptext (sLit "[S]") -- Print [S] for Given/Solved's + ppr (Wanted {}) = ptext (sLit "[W]") + ppr (Derived {}) = ptext (sLit "[D]") + pprFlavorArising :: CtFlavor -> SDoc -pprFlavorArising (Derived wl ) = pprArisingAt wl +pprFlavorArising (Derived wl) = pprArisingAt wl pprFlavorArising (Wanted wl) = pprArisingAt wl -pprFlavorArising (Given gl) = pprArisingAt gl +pprFlavorArising (Given gl _) = pprArisingAt gl isWanted :: CtFlavor -> Bool isWanted (Wanted {}) = True isWanted _ = False -isGiven :: CtFlavor -> Bool -isGiven (Given {}) = True -isGiven _ = False +isGivenOrSolved :: CtFlavor -> Bool +isGivenOrSolved (Given {}) = True +isGivenOrSolved _ = False + +isGiven_maybe :: CtFlavor -> Maybe GivenKind +isGiven_maybe (Given _ gk) = Just gk +isGiven_maybe _ = Nothing isDerived :: CtFlavor -> Bool isDerived (Derived {}) = True @@ -1036,9 +1077,6 @@ -- polymorphic Ids, and are now checking that their RHS -- constraints are satisfied. - | RuntimeUnkSkol -- a type variable used to represent an unknown - -- runtime type (used in the GHCi debugger) - | BracketSkol -- Template Haskell bracket | UnkSkol -- Unhelpful info (until I improve it) @@ -1073,8 +1111,7 @@ -- UnkSkol -- For type variables the others are dealt with by pprSkolTvBinding. -- For Insts, these cases should not happen -pprSkolInfo UnkSkol = WARN( True, text "pprSkolInfo: UnkSkol" ) ptext (sLit "UnkSkol") -pprSkolInfo RuntimeUnkSkol = WARN( True, text "pprSkolInfo: RuntimeUnkSkol" ) ptext (sLit "RuntimeUnkSkol") +pprSkolInfo UnkSkol = WARN( True, text "pprSkolInfo: UnkSkol" ) ptext (sLit "UnkSkol") \end{code} @@ -1114,6 +1151,7 @@ | StandAloneDerivOrigin -- Typechecking stand-alone deriving | DefaultOrigin -- Typechecking a default decl | DoOrigin -- Arising from a do expression + | MCompOrigin -- Arising from a monad comprehension | IfOrigin -- Arising from an if statement | ProcOrigin -- Arising from a proc expression | AnnOrigin -- An annotation @@ -1149,6 +1187,7 @@ pprO StandAloneDerivOrigin = ptext (sLit "a 'deriving' declaration") pprO DefaultOrigin = ptext (sLit "a 'default' declaration") pprO DoOrigin = ptext (sLit "a do statement") +pprO MCompOrigin = ptext (sLit "a statement in a monad comprehension") pprO ProcOrigin = ptext (sLit "a proc expression") pprO (TypeEqOrigin eq) = ptext (sLit "an equality") <+> ppr eq pprO AnnOrigin = ptext (sLit "an annotation") diff -Nru ghc-7.0.3/compiler/typecheck/TcRules.lhs ghc-7.2.1/compiler/typecheck/TcRules.lhs --- ghc-7.0.3/compiler/typecheck/TcRules.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/typecheck/TcRules.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -17,7 +17,6 @@ import TcExpr import TcEnv import Id -import Var ( Var ) import Name import VarSet import SrcLoc @@ -91,11 +90,14 @@ -- c.f. TcSimplify.simplifyInfer ; zonked_forall_tvs <- zonkTcTyVarsAndFV forall_tvs ; gbl_tvs <- tcGetGlobalTyVars -- Already zonked - ; qtvs <- zonkQuantifiedTyVars $ - varSetElems (zonked_forall_tvs `minusVarSet` gbl_tvs) + ; let extra_bound_tvs = zonked_forall_tvs + `minusVarSet` gbl_tvs + `delVarSetList` tv_bndrs + ; qtvs <- zonkQuantifiedTyVars (varSetElems extra_bound_tvs) + -- The tv_bndrs are already skolems, so no need to zonk them ; return (HsRule name act - (map (RuleBndr . noLoc) (qtvs ++ tpl_ids)) -- yuk + (map (RuleBndr . noLoc) (tv_bndrs ++ qtvs ++ tpl_ids)) -- yuk (mkHsDictLet lhs_ev_binds lhs') fv_lhs (mkHsDictLet rhs_ev_binds rhs') fv_rhs) } diff -Nru ghc-7.0.3/compiler/typecheck/TcSimplify.lhs ghc-7.2.1/compiler/typecheck/TcSimplify.lhs --- ghc-7.0.3/compiler/typecheck/TcSimplify.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/typecheck/TcSimplify.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -1,7 +1,7 @@ \begin{code} module TcSimplify( simplifyInfer, - simplifyDefault, simplifyDeriv, + simplifyDefault, simplifyDeriv, simplifyRule, simplifyTop, simplifyInteractive ) where @@ -15,10 +15,12 @@ import TcSMonad import TcInteract import Inst -import Unify( niFixTvSubst, niSubstTvSet ) +import Id ( evVarPred ) +import Unify ( niFixTvSubst, niSubstTvSet ) import Var import VarSet import VarEnv +import Coercion import TypeRep import Name @@ -49,7 +51,7 @@ -- but when there is nothing to quantify we don't wrap -- in a degenerate implication, so we do that here instead simplifyTop wanteds - = simplifyCheck SimplCheck wanteds + = simplifyCheck (SimplCheck (ptext (sLit "top level"))) wanteds ------------------ simplifyInteractive :: WantedConstraints -> TcM (Bag EvBind) @@ -61,7 +63,8 @@ -> TcM () -- Succeeds iff the constraint is soluble simplifyDefault theta = do { wanted <- newFlatWanteds DefaultOrigin theta - ; _ignored_ev_binds <- simplifyCheck SimplCheck (mkFlatWC wanted) + ; _ignored_ev_binds <- simplifyCheck (SimplCheck (ptext (sLit "defaults"))) + (mkFlatWC wanted) ; return () } \end{code} @@ -75,13 +78,14 @@ \begin{code} simplifyDeriv :: CtOrigin - -> [TyVar] - -> ThetaType -- Wanted - -> TcM ThetaType -- Needed + -> PredType + -> [TyVar] + -> ThetaType -- Wanted + -> TcM ThetaType -- Needed -- Given instance (wanted) => C inst_ty -- Simplify 'wanted' as much as possibles -- Fail if not possible -simplifyDeriv orig tvs theta +simplifyDeriv orig pred tvs theta = do { tvs_skols <- tcInstSkolTyVars tvs -- Skolemize -- The constraint solving machinery -- expects *TcTyVars* not TyVars. @@ -90,12 +94,13 @@ ; let skol_subst = zipTopTvSubst tvs $ map mkTyVarTy tvs_skols subst_skol = zipTopTvSubst tvs_skols $ map mkTyVarTy tvs + doc = parens $ ptext (sLit "deriving") <+> parens (ppr pred) ; wanted <- newFlatWanteds orig (substTheta skol_subst theta) ; traceTc "simplifyDeriv" (ppr tvs $$ ppr theta $$ ppr wanted) ; (residual_wanted, _binds) - <- runTcS SimplInfer NoUntouchables $ + <- runTcS (SimplInfer doc) NoUntouchables $ solveWanteds emptyInert (mkFlatWC wanted) ; let (good, bad) = partitionBagWith get_good (wc_flat residual_wanted) @@ -247,7 +252,7 @@ -- Step 2 -- Now simplify the possibly-bound constraints ; (simpl_results, tc_binds0) - <- runTcS SimplInfer NoUntouchables $ + <- runTcS (SimplInfer (ppr (map fst name_taus))) NoUntouchables $ simplifyWithApprox (zonked_wanteds { wc_flat = perhaps_bound }) ; when (insolubleWC simpl_results) -- Fail fast if there is an insoluble constraint @@ -547,7 +552,7 @@ -- variables; hence *no untouchables* ; (lhs_results, lhs_binds) - <- runTcS SimplRuleLhs untch $ + <- runTcS (SimplRuleLhs name) untch $ solveWanteds emptyInert zonked_lhs ; traceTc "simplifyRule" $ @@ -589,7 +594,8 @@ -- Hence the rather painful ad-hoc treatement here ; rhs_binds_var@(EvBindsVar evb_ref _) <- newTcEvBinds - ; rhs_binds1 <- simplifyCheck SimplCheck $ + ; let doc = ptext (sLit "rhs of rule") <+> doubleQuotes (ftext name) + ; rhs_binds1 <- simplifyCheck (SimplCheck doc) $ WC { wc_flat = emptyBag , wc_insol = emptyBag , wc_impl = unitBag $ @@ -667,6 +673,11 @@ = do { traceTcS "solveWanteds {" (ppr wanted) -- Try the flat bit + -- Discard from insols all the derived/given constraints + -- because they will show up again when we try to solve + -- everything else. Solving them a second time is a bit + -- of a waste, but the code is simple, and the program is + -- wrong anyway! ; let all_flats = flats `unionBags` keepWanted insols ; inert1 <- solveInteractWanted inert (bagToList all_flats) @@ -738,22 +749,26 @@ unsolved_implics } -givensFromWanteds :: CanonicalCts -> Bag FlavoredEvVar --- Extract the *wanted* ones from CanonicalCts --- and make them into *givens* -givensFromWanteds = foldrBag getWanted emptyBag +givensFromWanteds :: SimplContext -> CanonicalCts -> Bag FlavoredEvVar +-- Extract the Wanted ones from CanonicalCts and conver to +-- Givens; not Given/Solved, see Note [Preparing inert set for implications] +givensFromWanteds _ctxt = foldrBag getWanted emptyBag where getWanted :: CanonicalCt -> Bag FlavoredEvVar -> Bag FlavoredEvVar getWanted cc givens - | not (isCFrozenErr cc) - , Wanted loc <- cc_flavor cc - , let given = mkEvVarX (cc_id cc) (Given (setCtLocOrigin loc UnkSkol)) - = given `consBag` givens - | otherwise - = givens -- We are not helping anyone by pushing a Derived in! - -- Because if we could not solve it to start with - -- we are not going to do either inside the impl constraint - + | pushable_wanted cc + = let given = mkEvVarX (cc_id cc) (mkGivenFlavor (cc_flavor cc) UnkSkol) + in given `consBag` givens -- and not mkSolvedFlavor, + -- see Note [Preparing inert set for implications] + | otherwise = givens + + pushable_wanted :: CanonicalCt -> Bool + pushable_wanted cc + | not (isCFrozenErr cc) + , isWantedCt cc + = isEqPred (evVarPred (cc_id cc)) -- see Note [Preparing inert set for implications] + | otherwise = False + solveNestedImplications :: InertSet -> CanonicalCts -> Bag Implication -> TcS (Bag FlavoredEvVar, Bag Implication) @@ -763,14 +778,18 @@ | otherwise = do { -- See Note [Preparing inert set for implications] -- Push the unsolved wanteds inwards, but as givens - traceTcS "solveWanteds: preparing inerts for implications {" empty - - ; let pushed_givens = givensFromWanteds unsolved_cans + + ; simpl_ctx <- getTcSContext + + ; let pushed_givens = givensFromWanteds simpl_ctx unsolved_cans tcs_untouchables = filterVarSet isFlexiTcsTv $ tyVarsOfEvVarXs pushed_givens -- See Note [Extra TcsTv untouchables] - ; (_, inert_for_implics) <- solveInteract just_given_inert pushed_givens + ; traceTcS "solveWanteds: preparing inerts for implications {" + (vcat [ppr tcs_untouchables, ppr pushed_givens]) + + ; (_, inert_for_implics) <- solveInteract just_given_inert pushed_givens ; traceTcS "solveWanteds: } now doing nested implications {" $ vcat [ text "inerts_for_implics =" <+> ppr inert_for_implics @@ -921,6 +940,42 @@ given because the resulting set is not inert. Hence we have to do a 'solveInteract' step first. +Finally, note that we convert them to [Given] and NOT [Given/Solved]. +The reason is that Given/Solved are weaker than Givens and may be discarded. +As an example consider the inference case, where we may have, the following +original constraints: + [Wanted] F Int ~ Int + (F Int ~ a => F Int ~ a) +If we convert F Int ~ Int to [Given/Solved] instead of Given, then the next +given (F Int ~ a) is going to cause the Given/Solved to be ignored, casting +the (F Int ~ a) insoluble. Hence we should really convert the residual +wanteds to plain old Given. + +We need only push in unsolved equalities both in checking mode and inference mode: + + (1) In checking mode we should not push given dictionaries in because of +example LongWayOverlapping.hs, where we might get strange overlap +errors between far-away constraints in the program. But even in +checking mode, we must still push type family equations. Consider: + + type instance F True a b = a + type instance F False a b = b + + [w] F c a b ~ gamma + (c ~ True) => a ~ gamma + (c ~ False) => b ~ gamma + +Since solveCTyFunEqs happens at the very end of solving, the only way to solve +the two implications is temporarily consider (F c a b ~ gamma) as Given (NB: not +merely Given/Solved because it has to interact with the top-level instance +environment) and push it inside the implications. Now, when we come out again at +the end, having solved the implications solveCTyFunEqs will solve this equality. + + (2) In inference mode, we recheck the final constraint in checking mode and +hence we will be able to solve inner implications from top-level quantified +constraints nonetheless. + + Note [Extra TcsTv untouchables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Furthemore, we record the inert set simplifier-generated unification @@ -952,10 +1007,10 @@ constraints. In effect, by floating an equality out of the implication we are committing to have it solved in the outside. -NB: A consequence is that every simplifier-generated TcsTv variable that gets floated out - of an implication becomes now untouchable next time we go inside that implication to - solve any residual constraints. In effect, by floating an equality out of the implication - we are committing to have it solved in the outside. +Note [Float Equalities out of Implications] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +We want to float equalities out of vanilla existentials, but *not* out +of GADT pattern matches. \begin{code} @@ -976,7 +1031,8 @@ ; return (niFixTvSubst ni_subst, unsolved_can_cts) } where - solve_one (cv,tv,ty) = setWantedTyBind tv ty >> setCoBind cv ty + solve_one (cv,tv,ty) = do { setWantedTyBind tv ty + ; setCoBind cv (mkReflCo ty) } ------------ type FunEqBinds = (TvSubstEnv, [(CoVar, TcTyVar, TcType)]) @@ -1019,7 +1075,7 @@ , not (tv `elemVarSet` niSubstTvSet tv_subst (tyVarsOfTypes xis)) -- Occurs check: see Note [Solving Family Equations], Point 2 - = ASSERT ( not (isGiven fl) ) + = ASSERT ( not (isGivenOrSolved fl) ) (cts_in, extendFunEqBinds feb cv tv (mkTyConApp tc xis)) dflt_funeq (cts_in, fun_eq_binds) ct diff -Nru ghc-7.0.3/compiler/typecheck/TcSMonad.lhs ghc-7.2.1/compiler/typecheck/TcSMonad.lhs --- ghc-7.0.3/compiler/typecheck/TcSMonad.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/typecheck/TcSMonad.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -8,16 +8,22 @@ isCDictCan_Maybe, isCIPCan_Maybe, isCFunEqCan_Maybe, isCFrozenErr, + WorkList, unionWorkList, unionWorkLists, isEmptyWorkList, emptyWorkList, + workListFromEq, workListFromNonEq, + workListFromEqs, workListFromNonEqs, foldrWorkListM, + CanonicalCt(..), Xi, tyVarsOfCanonical, tyVarsOfCanonicals, tyVarsOfCDicts, deCanonicalise, mkFrozenError, - isWanted, isGiven, isDerived, - isGivenCt, isWantedCt, isDerivedCt, pprFlavorArising, + isWanted, isGivenOrSolved, isDerived, + isGivenOrSolvedCt, isGivenCt_maybe, + isWantedCt, isDerivedCt, pprFlavorArising, isFlexiTcsTv, canRewrite, canSolve, - combineCtLoc, mkGivenFlavor, mkWantedFlavor, + combineCtLoc, mkSolvedFlavor, mkGivenFlavor, + mkWantedFlavor, getWantedLoc, TcS, runTcS, failTcS, panicTcS, traceTcS, -- Basic functionality @@ -35,6 +41,8 @@ setWantedTyBind, + lookupFlatCacheMap, updateFlatCacheMap, + getInstEnvs, getFamInstEnvs, -- Getting the environments getTopEnv, getGblEnv, getTcEvBinds, getUntouchables, getTcEvBindsBag, getTcSContext, getTcSTyBinds, getTcSTyBindsMap, @@ -78,6 +86,7 @@ import qualified TcMType as TcM import qualified TcEnv as TcM ( checkWellStaged, topIdLvl, tcLookupFamInst, tcGetDefaultTys ) +import Kind import TcType import DynFlags @@ -93,15 +102,20 @@ import Bag import MonadUtils import VarSet +import Pair import FastString import HsBinds -- for TcEvBinds stuff import Id - import TcRnTypes - -import Control.Monad import Data.IORef + +import qualified Data.Map as Map + +#ifdef DEBUG +import StaticFlags( opt_PprStyle_Debug ) +import Control.Monad( when ) +#endif \end{code} @@ -201,9 +215,9 @@ ppr (CIPCan ip fl ip_nm ty) = ppr fl <+> ppr ip <+> dcolon <+> parens (ppr ip_nm <> dcolon <> ppr ty) ppr (CTyEqCan co fl tv ty) - = ppr fl <+> ppr co <+> dcolon <+> pprEqPred (mkTyVarTy tv, ty) + = ppr fl <+> ppr co <+> dcolon <+> pprEqPred (Pair (mkTyVarTy tv) ty) ppr (CFunEqCan co fl tc tys ty) - = ppr fl <+> ppr co <+> dcolon <+> pprEqPred (mkTyConApp tc tys, ty) + = ppr fl <+> ppr co <+> dcolon <+> pprEqPred (Pair (mkTyConApp tc tys) ty) ppr (CFrozenErr co fl) = ppr fl <+> pprEvVarWithType co \end{code} @@ -258,8 +272,58 @@ isCFrozenErr :: CanonicalCt -> Bool isCFrozenErr (CFrozenErr {}) = True isCFrozenErr _ = False + + +-- A mixture of Given, Wanted, and Derived constraints. +-- We split between equalities and the rest to process equalities first. +data WorkList = WorkList { weqs :: CanonicalCts + -- NB: weqs includes equalities /and/ family equalities + , wrest :: CanonicalCts } + +unionWorkList :: WorkList -> WorkList -> WorkList +unionWorkList wl1 wl2 + = WorkList { weqs = weqs wl1 `andCCan` weqs wl2 + , wrest = wrest wl1 `andCCan` wrest wl2 } + +unionWorkLists :: [WorkList] -> WorkList +unionWorkLists = foldr unionWorkList emptyWorkList + +isEmptyWorkList :: WorkList -> Bool +isEmptyWorkList wl = isEmptyCCan (weqs wl) && isEmptyCCan (wrest wl) + +emptyWorkList :: WorkList +emptyWorkList + = WorkList { weqs = emptyBag, wrest = emptyBag } + +workListFromEq :: CanonicalCt -> WorkList +workListFromEq = workListFromEqs . singleCCan + +workListFromNonEq :: CanonicalCt -> WorkList +workListFromNonEq = workListFromNonEqs . singleCCan + +workListFromNonEqs :: CanonicalCts -> WorkList +workListFromNonEqs cts + = WorkList { weqs = emptyCCan, wrest = cts } + +workListFromEqs :: CanonicalCts -> WorkList +workListFromEqs cts + = WorkList { weqs = cts, wrest = emptyCCan } + +foldrWorkListM :: (Monad m) => (CanonicalCt -> r -> m r) + -> r -> WorkList -> m r +-- Prioritizes equalities +foldrWorkListM on_ct r (WorkList {weqs = eqs, wrest = rest }) + = do { r1 <- foldrBagM on_ct r eqs + ; foldrBagM on_ct r1 rest } + +instance Outputable WorkList where + ppr wl = vcat [ text "WorkList (Equalities) = " <+> ppr (weqs wl) + , text "WorkList (Other) = " <+> ppr (wrest wl) ] + \end{code} + + %************************************************************************ %* * CtFlavor @@ -277,11 +341,16 @@ isWantedCt :: CanonicalCt -> Bool isWantedCt ct = isWanted (cc_flavor ct) -isGivenCt :: CanonicalCt -> Bool -isGivenCt ct = isGiven (cc_flavor ct) isDerivedCt :: CanonicalCt -> Bool isDerivedCt ct = isDerived (cc_flavor ct) +isGivenCt_maybe :: CanonicalCt -> Maybe GivenKind +isGivenCt_maybe ct = isGiven_maybe (cc_flavor ct) + +isGivenOrSolvedCt :: CanonicalCt -> Bool +isGivenOrSolvedCt ct = isGivenOrSolved (cc_flavor ct) + + canSolve :: CtFlavor -> CtFlavor -> Bool -- canSolve ctid1 ctid2 -- The constraint ctid1 can be used to solve ctid2 @@ -306,21 +375,27 @@ combineCtLoc :: CtFlavor -> CtFlavor -> WantedLoc -- Precondition: At least one of them should be wanted -combineCtLoc (Wanted loc) _ = loc -combineCtLoc _ (Wanted loc) = loc -combineCtLoc (Derived loc ) _ = loc -combineCtLoc _ (Derived loc ) = loc +combineCtLoc (Wanted loc) _ = loc +combineCtLoc _ (Wanted loc) = loc +combineCtLoc (Derived loc ) _ = loc +combineCtLoc _ (Derived loc ) = loc combineCtLoc _ _ = panic "combineCtLoc: both given" +mkSolvedFlavor :: CtFlavor -> SkolemInfo -> CtFlavor +-- To be called when we actually solve a wanted/derived (perhaps leaving residual goals) +mkSolvedFlavor (Wanted loc) sk = Given (setCtLocOrigin loc sk) GivenSolved +mkSolvedFlavor (Derived loc) sk = Given (setCtLocOrigin loc sk) GivenSolved +mkSolvedFlavor fl@(Given {}) _sk = pprPanic "Solving a given constraint!" $ ppr fl + mkGivenFlavor :: CtFlavor -> SkolemInfo -> CtFlavor -mkGivenFlavor (Wanted loc) sk = Given (setCtLocOrigin loc sk) -mkGivenFlavor (Derived loc) sk = Given (setCtLocOrigin loc sk) -mkGivenFlavor (Given loc) sk = Given (setCtLocOrigin loc sk) +mkGivenFlavor (Wanted loc) sk = Given (setCtLocOrigin loc sk) GivenOrig +mkGivenFlavor (Derived loc) sk = Given (setCtLocOrigin loc sk) GivenOrig +mkGivenFlavor fl@(Given {}) _sk = pprPanic "Solving a given constraint!" $ ppr fl mkWantedFlavor :: CtFlavor -> CtFlavor mkWantedFlavor (Wanted loc) = Wanted loc mkWantedFlavor (Derived loc) = Wanted loc -mkWantedFlavor fl@(Given {}) = pprPanic "mkWantedFlavour" (ppr fl) +mkWantedFlavor fl@(Given {}) = pprPanic "mkWantedFlavor" (ppr fl) \end{code} %************************************************************************ @@ -355,10 +430,33 @@ tcs_untch :: TcsUntouchables, - tcs_ic_depth :: Int, -- Implication nesting depth - tcs_count :: IORef Int -- Global step count + tcs_ic_depth :: Int, -- Implication nesting depth + tcs_count :: IORef Int, -- Global step count + + tcs_flat_map :: IORef FlatCache } +data FlatCache + = FlatCache { givenFlatCache :: Map.Map FunEqHead (TcType,Coercion,CtFlavor) + -- Invariant: all CtFlavors here satisfy isGiven + , wantedFlatCache :: Map.Map FunEqHead (TcType,Coercion,CtFlavor) } + -- Invariant: all CtFlavors here satisfy isWanted + +emptyFlatCache :: FlatCache +emptyFlatCache + = FlatCache { givenFlatCache = Map.empty, wantedFlatCache = Map.empty } + +newtype FunEqHead = FunEqHead (TyCon,[Xi]) + +instance Eq FunEqHead where + FunEqHead (tc1,xis1) == FunEqHead (tc2,xis2) = tc1 == tc2 && eqTypes xis1 xis2 + +instance Ord FunEqHead where + FunEqHead (tc1,xis1) `compare` FunEqHead (tc2,xis2) + = case compare tc1 tc2 of + EQ -> cmpTypes xis1 xis2 + other -> other + type TcsUntouchables = (Untouchables,TcTyVarSet) -- Like the TcM Untouchables, -- but records extra TcsTv variables generated during simplification @@ -367,17 +465,16 @@ \begin{code} data SimplContext - = SimplInfer -- Inferring type of a let-bound thing - | SimplRuleLhs -- Inferring type of a RULE lhs - | SimplInteractive -- Inferring type at GHCi prompt - | SimplCheck -- Checking a type signature or RULE rhs - deriving Eq + = SimplInfer SDoc -- Inferring type of a let-bound thing + | SimplRuleLhs RuleName -- Inferring type of a RULE lhs + | SimplInteractive -- Inferring type at GHCi prompt + | SimplCheck SDoc -- Checking a type signature or RULE rhs instance Outputable SimplContext where - ppr SimplInfer = ptext (sLit "SimplInfer") - ppr SimplRuleLhs = ptext (sLit "SimplRuleLhs") + ppr (SimplInfer d) = ptext (sLit "SimplInfer") <+> d + ppr (SimplCheck d) = ptext (sLit "SimplCheck") <+> d + ppr (SimplRuleLhs n) = ptext (sLit "SimplRuleLhs") <+> doubleQuotes (ftext n) ppr SimplInteractive = ptext (sLit "SimplInteractive") - ppr SimplCheck = ptext (sLit "SimplCheck") isInteractive :: SimplContext -> Bool isInteractive SimplInteractive = True @@ -387,14 +484,14 @@ -- Simplify equalities only, not dictionaries -- This is used for the LHS of rules; ee -- Note [Simplifying RULE lhs constraints] in TcSimplify -simplEqsOnly SimplRuleLhs = True -simplEqsOnly _ = False +simplEqsOnly (SimplRuleLhs {}) = True +simplEqsOnly _ = False performDefaulting :: SimplContext -> Bool -performDefaulting SimplInfer = False -performDefaulting SimplRuleLhs = False -performDefaulting SimplInteractive = True -performDefaulting SimplCheck = True +performDefaulting (SimplInfer {}) = False +performDefaulting (SimplRuleLhs {}) = False +performDefaulting SimplInteractive = True +performDefaulting (SimplCheck {}) = True --------------- newtype TcS a = TcS { unTcS :: TcSEnv -> TcM a } @@ -456,12 +553,14 @@ = do { ty_binds_var <- TcM.newTcRef emptyVarEnv ; ev_binds_var@(EvBindsVar evb_ref _) <- TcM.newTcEvBinds ; step_count <- TcM.newTcRef 0 + ; flat_cache_var <- TcM.newTcRef emptyFlatCache ; let env = TcSEnv { tcs_ev_binds = ev_binds_var , tcs_ty_binds = ty_binds_var , tcs_context = context , tcs_untch = (untouch, emptyVarSet) -- No Tcs untouchables yet , tcs_count = step_count , tcs_ic_depth = 0 + , tcs_flat_map = flat_cache_var } -- Run the computation @@ -472,7 +571,9 @@ #ifdef DEBUG ; count <- TcM.readTcRef step_count - ; TcM.dumpTcRn (ptext (sLit "Constraint solver steps =") <+> int count) + ; when (opt_PprStyle_Debug && count > 0) $ + TcM.debugDumpTcRn (ptext (sLit "Constraint solver steps =") + <+> int count <+> ppr context) #endif -- And return ; ev_binds <- TcM.readTcRef evb_ref @@ -486,21 +587,31 @@ , tcs_untch = (_outer_range, outer_tcs) , tcs_count = count , tcs_ic_depth = idepth - , tcs_context = ctxt } -> - let - inner_untch = (inner_range, outer_tcs `unionVarSet` inner_tcs) + , tcs_context = ctxt + , tcs_flat_map = orig_flat_cache_var + } -> + do { let inner_untch = (inner_range, outer_tcs `unionVarSet` inner_tcs) -- The inner_range should be narrower than the outer one -- (thus increasing the set of untouchables) but -- the inner Tcs-untouchables must be unioned with the -- outer ones! - nest_env = TcSEnv { tcs_ev_binds = ref - , tcs_ty_binds = ty_binds - , tcs_untch = inner_untch - , tcs_count = count - , tcs_ic_depth = idepth+1 - , tcs_context = ctxtUnderImplic ctxt } - in - thing_inside nest_env + + ; orig_flat_cache <- TcM.readTcRef orig_flat_cache_var + ; flat_cache_var <- TcM.newTcRef orig_flat_cache + -- One could be more conservative as well: + -- ; flat_cache_var <- TcM.newTcRef emptyFlatCache + + -- Consider copying the results the tcs_flat_map of the + -- incomping constraint, but we must make sure that we + -- have pushed everything in, which seems somewhat fragile + ; let nest_env = TcSEnv { tcs_ev_binds = ref + , tcs_ty_binds = ty_binds + , tcs_untch = inner_untch + , tcs_count = count + , tcs_ic_depth = idepth+1 + , tcs_context = ctxtUnderImplic ctxt + , tcs_flat_map = flat_cache_var } + ; thing_inside nest_env } recoverTcS :: TcS a -> TcS a -> TcS a recoverTcS (TcS recovery_code) (TcS thing_inside) @@ -509,18 +620,21 @@ ctxtUnderImplic :: SimplContext -> SimplContext -- See Note [Simplifying RULE lhs constraints] in TcSimplify -ctxtUnderImplic SimplRuleLhs = SimplCheck -ctxtUnderImplic ctxt = ctxt +ctxtUnderImplic (SimplRuleLhs n) = SimplCheck (ptext (sLit "lhs of rule") + <+> doubleQuotes (ftext n)) +ctxtUnderImplic ctxt = ctxt tryTcS :: TcS a -> TcS a --- Like runTcS, but from within the TcS monad +-- Like runTcS, but from within the TcS monad -- Ignore all the evidence generated, and do not affect caller's evidence! -tryTcS tcs +tryTcS tcs = TcS (\env -> do { ty_binds_var <- TcM.newTcRef emptyVarEnv ; ev_binds_var <- TcM.newTcEvBinds + ; flat_cache_var <- TcM.newTcRef emptyFlatCache ; let env1 = env { tcs_ev_binds = ev_binds_var - , tcs_ty_binds = ty_binds_var } - ; unTcS tcs env1 }) + , tcs_ty_binds = ty_binds_var + , tcs_flat_map = flat_cache_var } + ; unTcS tcs env1 }) -- Update TcEvBinds -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -543,12 +657,51 @@ getTcSTyBindsMap :: TcS (TyVarEnv (TcTyVar, TcType)) getTcSTyBindsMap = getTcSTyBinds >>= wrapTcS . (TcM.readTcRef) +getFlatCacheMapVar :: TcS (IORef FlatCache) +getFlatCacheMapVar + = TcS (return . tcs_flat_map) + +lookupFlatCacheMap :: TyCon -> [Xi] -> CtFlavor + -> TcS (Maybe (TcType,Coercion,CtFlavor)) +-- For givens, we lookup in given flat cache +lookupFlatCacheMap tc xis (Given {}) + = do { cache_ref <- getFlatCacheMapVar + ; cache_map <- wrapTcS $ TcM.readTcRef cache_ref + ; return $ Map.lookup (FunEqHead (tc,xis)) (givenFlatCache cache_map) } +-- For wanteds, we first lookup in givenFlatCache. +-- If we get nothing back then we lookup in wantedFlatCache. +lookupFlatCacheMap tc xis (Wanted {}) + = do { cache_ref <- getFlatCacheMapVar + ; cache_map <- wrapTcS $ TcM.readTcRef cache_ref + ; case Map.lookup (FunEqHead (tc,xis)) (givenFlatCache cache_map) of + Nothing -> return $ Map.lookup (FunEqHead (tc,xis)) (wantedFlatCache cache_map) + other -> return other } +lookupFlatCacheMap _tc _xis (Derived {}) = return Nothing + +updateFlatCacheMap :: TyCon -> [Xi] + -> TcType -> CtFlavor -> Coercion -> TcS () +updateFlatCacheMap _tc _xis _tv (Derived {}) _co + = return () -- Not caching deriveds +updateFlatCacheMap tc xis ty fl co + = do { cache_ref <- getFlatCacheMapVar + ; cache_map <- wrapTcS $ TcM.readTcRef cache_ref + ; let new_cache_map + | isGivenOrSolved fl + = cache_map { givenFlatCache = Map.insert (FunEqHead (tc,xis)) (ty,co,fl) $ + givenFlatCache cache_map } + | isWanted fl + = cache_map { wantedFlatCache = Map.insert (FunEqHead (tc,xis)) (ty,co,fl) $ + wantedFlatCache cache_map } + | otherwise = pprPanic "updateFlatCacheMap, met Derived!" $ empty + ; wrapTcS $ TcM.writeTcRef cache_ref new_cache_map } + getTcEvBindsBag :: TcS EvBindMap getTcEvBindsBag = do { EvBindsVar ev_ref _ <- getTcEvBinds ; wrapTcS $ TcM.readTcRef ev_ref } + setCoBind :: CoVar -> Coercion -> TcS () setCoBind cv co = setEvBind cv (EvCoercion co) @@ -618,7 +771,7 @@ bind_lvl = TcM.topIdLvl dfun_id pprEq :: TcType -> TcType -> SDoc -pprEq ty1 ty2 = pprPred $ mkEqPred (ty1,ty2) +pprEq ty1 ty2 = pprPredTy $ mkEqPred (ty1,ty2) isTouchableMetaTyVar :: TcTyVar -> TcS Bool isTouchableMetaTyVar tv @@ -763,22 +916,22 @@ = do { let pred = mkClassPred clas tys ; instEnvs <- getInstEnvs ; case lookupInstEnv instEnvs clas tys of { - ([], unifs) -- Nothing matches + ([], unifs, _) -- Nothing matches -> do { traceTcS "matchClass not matching" (vcat [ text "dict" <+> ppr pred, text "unifs" <+> ppr unifs ]) ; return MatchInstNo } ; - ([(ispec, inst_tys)], []) -- A single match + ([(ispec, inst_tys)], [], _) -- A single match -> do { let dfun_id = is_dfun ispec ; traceTcS "matchClass success" (vcat [text "dict" <+> ppr pred, text "witness" <+> ppr dfun_id - <+> ppr (idType dfun_id), ppr instEnvs ]) + <+> ppr (idType dfun_id) ]) -- Record that this dfun is needed ; return $ MatchInstSingle (dfun_id, inst_tys) } ; - (matches, unifs) -- More than one matches + (matches, unifs, _) -- More than one matches -> do { traceTcS "matchClass multiple matches, deferring choice" (vcat [text "dict" <+> ppr pred, text "matches" <+> ppr matches, diff -Nru ghc-7.0.3/compiler/typecheck/TcSplice.lhs ghc-7.2.1/compiler/typecheck/TcSplice.lhs --- ghc-7.0.3/compiler/typecheck/TcSplice.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/typecheck/TcSplice.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -71,6 +71,7 @@ import Outputable import Util ( dropList ) import Data.List ( mapAccumL ) +import Pair import Unique import Data.Maybe import BasicTypes @@ -386,7 +387,7 @@ } tc_bracket _ (ExpBr expr) - = do { any_ty <- newFlexiTyVarTy liftedTypeKind + = do { any_ty <- newFlexiTyVarTy openTypeKind ; _ <- tcMonoExprNC expr any_ty -- NC for no context; tcBracket does that ; tcMetaTy expQTyConName } -- Result type is ExpQ (= Q Exp) @@ -407,7 +408,7 @@ ; tcMetaTy decsQTyConName } -- Result type is Q [Dec] tc_bracket _ (PatBr pat) - = do { any_ty <- newFlexiTyVarTy liftedTypeKind + = do { any_ty <- newFlexiTyVarTy openTypeKind ; _ <- tcPat ThPatQuote pat any_ty $ return () ; tcMetaTy patQTyConName } @@ -809,6 +810,18 @@ -> TcM hs_syn -- Of type t runMeta show_code run_and_convert expr = do { traceTc "About to run" (ppr expr) + ; recordThSpliceUse -- seems to be the best place to do this, + -- we catch all kinds of splices and annotations. + + -- Check that we've had no errors of any sort so far. + -- For example, if we found an error in an earlier defn f, but + -- recovered giving it type f :: forall a.a, it'd be very dodgy + -- to carry ont. Mind you, the staging restrictions mean we won't + -- actually run f, but it still seems wrong. And, more concretely, + -- see Trac #5358 for an example that fell over when trying to + -- reify a function with a "?" kind in it. (These don't occur + -- in type-correct programs. + ; failIfErrsM -- Desugar ; ds_expr <- initDsTc (dsLExpr expr) @@ -816,7 +829,7 @@ ; hsc_env <- getTopEnv ; src_span <- getSrcSpanM ; either_hval <- tryM $ liftIO $ - HscMain.compileExpr hsc_env src_span ds_expr + HscMain.hscCompileCoreExpr hsc_env src_span ds_expr ; case either_hval of { Left exn -> failWithTc (mk_msg "compile and link" exn) ; Right hval -> do @@ -896,13 +909,17 @@ qReport False msg = addReport (text msg) empty qLocation = do { m <- getModule - ; l <- getSrcSpanM - ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile l) - , TH.loc_module = moduleNameString (moduleName m) - , TH.loc_package = packageIdString (modulePackageId m) - , TH.loc_start = (srcSpanStartLine l, srcSpanStartCol l) - , TH.loc_end = (srcSpanEndLine l, srcSpanEndCol l) }) } - + ; l <- getSrcSpanM + ; r <- case l of + UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location" + (ppr l) + RealSrcSpan s -> return s + ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile r) + , TH.loc_module = moduleNameString (moduleName m) + , TH.loc_package = packageIdString (modulePackageId m) + , TH.loc_start = (srcSpanStartLine r, srcSpanStartCol r) + , TH.loc_end = (srcSpanEndLine r, srcSpanEndCol r) }) } + qReify v = reify v qClassInstances = lookupClassInstances @@ -953,11 +970,11 @@ %************************************************************************ \begin{code} -lookupClassInstances :: TH.Name -> [TH.Type] -> TcM [TH.Name] +lookupClassInstances :: TH.Name -> [TH.Type] -> TcM [TH.ClassInstance] lookupClassInstances c ts = do { loc <- getSrcSpanM - ; case convertToHsPred loc (TH.ClassP c ts) of - Left msg -> failWithTc msg + ; case convertToHsPred loc (TH.ClassP c ts) of { + Left msg -> failWithTc msg; Right rdr_pred -> do { rn_pred <- rnLPred doc rdr_pred -- Rename ; kc_pred <- kcHsLPred rn_pred -- Kind check @@ -965,9 +982,8 @@ -- Now look up instances ; inst_envs <- tcGetInstEnvs - ; let (matches, unifies) = lookupInstEnv inst_envs cls tys - dfuns = map is_dfun (map fst matches ++ unifies) - ; return (map reifyName dfuns) } } + ; let (matches, unifies, _) = lookupInstEnv inst_envs cls tys + ; mapM reifyClassInstance (map fst matches ++ unifies) } } } where doc = ptext (sLit "TcSplice.classInstances") \end{code} @@ -1067,8 +1083,9 @@ _ -> return (TH.VarI v ty Nothing fix) } -reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc -reifyThing (AGlobal (AClass cls)) = reifyClass cls +reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc +reifyThing (AGlobal (ACoAxiom ax)) = reifyAxiom ax +reifyThing (AGlobal (AClass cls)) = reifyClass cls reifyThing (AGlobal (ADataCon dc)) = do { let name = dataConName dc ; ty <- reifyType (idType (dataConWrapId dc)) @@ -1092,12 +1109,24 @@ reifyThing (AThing {}) = panic "reifyThing AThing" ------------------------------ +reifyAxiom :: CoAxiom -> TcM TH.Info +reifyAxiom ax@(CoAxiom { co_ax_lhs = lhs, co_ax_rhs = rhs }) + | Just (tc, args) <- tcSplitTyConApp_maybe lhs + = do { args' <- mapM reifyType args + ; rhs' <- reifyType rhs + ; return (TH.TyConI $ TH.TySynInstD (reifyName tc) args' rhs') } + | otherwise + = failWith (ptext (sLit "Can't reify the axiom") <+> ppr ax + <+> dcolon <+> pprEqPred (Pair lhs rhs)) + reifyTyCon :: TyCon -> TcM TH.Info reifyTyCon tc | isFunTyCon tc = return (TH.PrimTyConI (reifyName tc) 2 False) + | isPrimTyCon tc = return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnLiftedTyCon tc)) + | isFamilyTyCon tc = let flavour = reifyFamFlavour tc tvs = tyConTyVars tc @@ -1108,6 +1137,7 @@ in return (TH.TyConI $ TH.FamilyD flavour (reifyName tc) (reifyTyVars tvs) kind') + | isSynTyCon tc = do { let (tvs, rhs) = synTyConDefn tc ; rhs' <- reifyType rhs @@ -1115,7 +1145,7 @@ TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') } -reifyTyCon tc + | otherwise = do { cxt <- reifyCxt (tyConStupidTheta tc) ; let tvs = tyConTyVars tc ; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons tc) @@ -1190,7 +1220,7 @@ reifyType :: TypeRep.Type -> TcM TH.Type -- Monadic only because of failure reifyType ty@(ForAllTy _ _) = reify_for_all ty -reifyType ty@(PredTy {} `FunTy` _) = reify_for_all ty -- Types like ((?x::Int) => Char -> Char) +reifyType ty@(PredTy {} `FunTy` _) = reify_for_all ty -- Types like ((?x::Int) => Char -> Char) reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv)) reifyType (TyConApp tc tys) = reify_tc_app tc tys -- Do not expand type synonyms here reifyType (AppTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `TH.AppT` r2) } diff -Nru ghc-7.0.3/compiler/typecheck/TcTyClsDecls.lhs ghc-7.2.1/compiler/typecheck/TcTyClsDecls.lhs --- ghc-7.0.3/compiler/typecheck/TcTyClsDecls.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/typecheck/TcTyClsDecls.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -7,7 +7,8 @@ \begin{code} module TcTyClsDecls ( - tcTyAndClassDecls, tcFamInstDecl, mkRecSelBinds + tcTyAndClassDecls, kcDataDecl, tcConDecls, mkRecSelBinds, + checkValidTyCon, dataDeclChecks, badFamInstDecl ) where #include "HsVersions.h" @@ -25,17 +26,16 @@ import TcType import TysWiredIn ( unitTy ) import Type -import Generics import Class import TyCon import DataCon import Id -import MkId ( mkDefaultMethodId ) import MkCore ( rEC_SEL_ERROR_ID ) import IdInfo import Var import VarSet import Name +import NameEnv import Outputable import Maybes import Unify @@ -61,12 +61,12 @@ %************************************************************************ \begin{code} + tcTyAndClassDecls :: ModDetails -> [[LTyClDecl Name]] -- Mutually-recursive groups in dependency order -> TcM (TcGblEnv, -- Input env extended by types and classes -- and their implicit Ids,DataCons - HsValBinds Name, -- Renamed bindings for record selectors - [Id]) -- Default method ids + HsValBinds Name) -- Renamed bindings for record selectors -- Fails if there are any errors tcTyAndClassDecls boot_details decls_s @@ -89,7 +89,9 @@ -- And now build the TyCons/Classes ; let rec_flags = calcRecFlags boot_details rec_tyclss - ; concatMapM (tcTyClDecl rec_flags) kc_decls } + ; concatMapM (tcTyClDecl rec_flags) kc_decls } + + ; traceTc "tcTyAndCl3" (ppr tyclss) ; tcExtendGlobalEnv tyclss $ do { -- Perform the validity check @@ -105,11 +107,13 @@ -- second time here. This doesn't matter as the definitions are -- the same. ; let { implicit_things = concatMap implicitTyThings tyclss - ; rec_sel_binds = mkRecSelBinds tyclss + ; rec_sel_binds = mkRecSelBinds [tc | ATyCon tc <- tyclss] ; dm_ids = mkDefaultMethodIds tyclss } - ; env <- tcExtendGlobalEnv implicit_things getGblEnv - ; return (env, rec_sel_binds, dm_ids) } } + ; env <- tcExtendGlobalEnv implicit_things $ + tcExtendGlobalValEnv dm_ids $ + getGblEnv + ; return (env, rec_sel_binds) } } zipRecTyClss :: [[LTyClDecl Name]] -> [TyThing] -- Knot-tied @@ -137,188 +141,6 @@ %************************************************************************ %* * - Type checking family instances -%* * -%************************************************************************ - -Family instances are somewhat of a hybrid. They are processed together with -class instance heads, but can contain data constructors and hence they share a -lot of kinding and type checking code with ordinary algebraic data types (and -GADTs). - -\begin{code} -tcFamInstDecl :: TopLevelFlag -> LTyClDecl Name -> TcM TyThing -tcFamInstDecl top_lvl (L loc decl) - = -- Prime error recovery, set source location - setSrcSpan loc $ - tcAddDeclCtxt decl $ - do { -- type family instances require -XTypeFamilies - -- and can't (currently) be in an hs-boot file - ; type_families <- xoptM Opt_TypeFamilies - ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file? - ; checkTc type_families $ badFamInstDecl (tcdLName decl) - ; checkTc (not is_boot) $ badBootFamInstDeclErr - - -- Perform kind and type checking - ; tc <- tcFamInstDecl1 decl - ; checkValidTyCon tc -- Remember to check validity; - -- no recursion to worry about here - - -- Check that toplevel type instances are not for associated types. - ; when (isTopLevel top_lvl && isAssocFamily tc) - (addErr $ assocInClassErr (tcdName decl)) - - ; return (ATyCon tc) } - -isAssocFamily :: TyCon -> Bool -- Is an assocaited type -isAssocFamily tycon - = case tyConFamInst_maybe tycon of - Nothing -> panic "isAssocFamily: no family?!?" - Just (fam, _) -> isTyConAssoc fam - -assocInClassErr :: Name -> SDoc -assocInClassErr name - = ptext (sLit "Associated type") <+> quotes (ppr name) <+> - ptext (sLit "must be inside a class instance") - - - -tcFamInstDecl1 :: TyClDecl Name -> TcM TyCon - - -- "type instance" -tcFamInstDecl1 (decl@TySynonym {tcdLName = L loc tc_name}) - = kcIdxTyPats decl $ \k_tvs k_typats resKind family -> - do { -- check that the family declaration is for a synonym - checkTc (isFamilyTyCon family) (notFamily family) - ; checkTc (isSynTyCon family) (wrongKindOfFamily family) - - ; -- (1) kind check the right-hand side of the type equation - ; k_rhs <- kcCheckLHsType (tcdSynRhs decl) (EK resKind EkUnk) - -- ToDo: the ExpKind could be better - - -- we need the exact same number of type parameters as the family - -- declaration - ; let famArity = tyConArity family - ; checkTc (length k_typats == famArity) $ - wrongNumberOfParmsErr famArity - - -- (2) type check type equation - ; tcTyVarBndrs k_tvs $ \t_tvs -> do { -- turn kinded into proper tyvars - ; t_typats <- mapM tcHsKindedType k_typats - ; t_rhs <- tcHsKindedType k_rhs - - -- (3) check the well-formedness of the instance - ; checkValidTypeInst t_typats t_rhs - - -- (4) construct representation tycon - ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc - ; buildSynTyCon rep_tc_name t_tvs (SynonymTyCon t_rhs) - (typeKind t_rhs) - NoParentTyCon (Just (family, t_typats)) - }} - - -- "newtype instance" and "data instance" -tcFamInstDecl1 (decl@TyData {tcdND = new_or_data, tcdLName = L loc tc_name, - tcdCons = cons}) - = kcIdxTyPats decl $ \k_tvs k_typats resKind fam_tycon -> - do { -- check that the family declaration is for the right kind - checkTc (isFamilyTyCon fam_tycon) (notFamily fam_tycon) - ; checkTc (isAlgTyCon fam_tycon) (wrongKindOfFamily fam_tycon) - - ; -- (1) kind check the data declaration as usual - ; k_decl <- kcDataDecl decl k_tvs - ; let k_ctxt = tcdCtxt k_decl - k_cons = tcdCons k_decl - - -- result kind must be '*' (otherwise, we have too few patterns) - ; checkTc (isLiftedTypeKind resKind) $ tooFewParmsErr (tyConArity fam_tycon) - - -- (2) type check indexed data type declaration - ; tcTyVarBndrs k_tvs $ \t_tvs -> do { -- turn kinded into proper tyvars - ; unbox_strict <- doptM Opt_UnboxStrictFields - - -- kind check the type indexes and the context - ; t_typats <- mapM tcHsKindedType k_typats - ; stupid_theta <- tcHsKindedContext k_ctxt - - -- (3) Check that - -- (a) left-hand side contains no type family applications - -- (vanilla synonyms are fine, though, and we checked for - -- foralls earlier) - ; mapM_ checkTyFamFreeness t_typats - - -- Check that we don't use GADT syntax in H98 world - ; gadt_ok <- xoptM Opt_GADTs - ; checkTc (gadt_ok || consUseH98Syntax cons) (badGadtDecl tc_name) - - -- (b) a newtype has exactly one constructor - ; checkTc (new_or_data == DataType || isSingleton k_cons) $ - newtypeConError tc_name (length k_cons) - - -- (4) construct representation tycon - ; rep_tc_name <- newFamInstTyConName tc_name t_typats loc - ; let ex_ok = True -- Existentials ok for type families! - ; fixM (\ rep_tycon -> do - { let orig_res_ty = mkTyConApp fam_tycon t_typats - ; data_cons <- tcConDecls unbox_strict ex_ok rep_tycon - (t_tvs, orig_res_ty) k_cons - ; tc_rhs <- - case new_or_data of - DataType -> return (mkDataTyConRhs data_cons) - NewType -> ASSERT( not (null data_cons) ) - mkNewTyConRhs rep_tc_name rep_tycon (head data_cons) - ; buildAlgTyCon rep_tc_name t_tvs stupid_theta tc_rhs Recursive - False h98_syntax NoParentTyCon (Just (fam_tycon, t_typats)) - -- We always assume that indexed types are recursive. Why? - -- (1) Due to their open nature, we can never be sure that a - -- further instance might not introduce a new recursive - -- dependency. (2) They are always valid loop breakers as - -- they involve a coercion. - }) - }} - where - h98_syntax = case cons of -- All constructors have same shape - L _ (ConDecl { con_res = ResTyGADT _ }) : _ -> False - _ -> True - -tcFamInstDecl1 d = pprPanic "tcFamInstDecl1" (ppr d) - --- Kind checking of indexed types --- - - --- Kind check type patterns and kind annotate the embedded type variables. --- --- * Here we check that a type instance matches its kind signature, but we do --- not check whether there is a pattern for each type index; the latter --- check is only required for type synonym instances. - -kcIdxTyPats :: TyClDecl Name - -> ([LHsTyVarBndr Name] -> [LHsType Name] -> Kind -> TyCon -> TcM a) - -- ^^kinded tvs ^^kinded ty pats ^^res kind - -> TcM a -kcIdxTyPats decl thing_inside - = kcHsTyVars (tcdTyVars decl) $ \tvs -> - do { let tc_name = tcdLName decl - ; fam_tycon <- tcLookupLocatedTyCon tc_name - ; let { (kinds, resKind) = splitKindFunTys (tyConKind fam_tycon) - ; hs_typats = fromJust $ tcdTyPats decl } - - -- we may not have more parameters than the kind indicates - ; checkTc (length kinds >= length hs_typats) $ - tooManyParmsErr (tcdLName decl) - - -- type functions can have a higher-kinded result - ; let resultKind = mkArrowKinds (drop (length hs_typats) kinds) resKind - ; typats <- zipWithM kcCheckLHsType hs_typats - [ EK kind (EkArg (ppr tc_name) n) - | (kind,n) <- kinds `zip` [1..]] - ; thing_inside tvs typats resultKind fam_tycon - } -\end{code} - - -%************************************************************************ -%* * Kind checking %* * %************************************************************************ @@ -488,6 +310,8 @@ where kc_sig (TypeSig nm op_ty) = do { op_ty' <- kcHsLiftedSigType op_ty ; return (TypeSig nm op_ty') } + kc_sig (GenericSig nm op_ty) = do { op_ty' <- kcHsLiftedSigType op_ty + ; return (GenericSig nm op_ty') } kc_sig other_sig = return other_sig kcTyClDecl decl@(ForeignType {}) @@ -600,6 +424,7 @@ tcTyClDecl calc_isrec (L loc decl) = setSrcSpan loc $ tcAddDeclCtxt decl $ + traceTc "tcTyAndCl-x" (ppr decl) >> tcTyClDecl1 NoParentTyCon calc_isrec decl -- "type family" declarations @@ -634,7 +459,7 @@ ; checkTc idx_tys $ badFamInstDecl tc_name ; tycon <- buildAlgTyCon tc_name final_tvs [] - DataFamilyTyCon Recursive False True + DataFamilyTyCon Recursive True parent Nothing ; return [ATyCon tycon] } @@ -660,39 +485,20 @@ { extra_tvs <- tcDataKindSig mb_ksig ; let final_tvs = tvs' ++ extra_tvs ; stupid_theta <- tcHsKindedContext ctxt - ; want_generic <- xoptM Opt_Generics - ; unbox_strict <- doptM Opt_UnboxStrictFields - ; empty_data_decls <- xoptM Opt_EmptyDataDecls ; kind_signatures <- xoptM Opt_KindSignatures ; existential_ok <- xoptM Opt_ExistentialQuantification ; gadt_ok <- xoptM Opt_GADTs ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file? ; let ex_ok = existential_ok || gadt_ok -- Data cons can have existential context - -- Check that we don't use GADT syntax in H98 world - ; checkTc (gadt_ok || h98_syntax) (badGadtDecl tc_name) - -- Check that we don't use kind signatures without Glasgow extensions ; checkTc (kind_signatures || isNothing mb_ksig) (badSigTyDecl tc_name) - -- Check that the stupid theta is empty for a GADT-style declaration - ; checkTc (null stupid_theta || h98_syntax) (badStupidTheta tc_name) + ; dataDeclChecks tc_name new_or_data stupid_theta cons - -- Check that a newtype has exactly one constructor - -- Do this before checking for empty data decls, so that - -- we don't suggest -XEmptyDataDecls for newtypes - ; checkTc (new_or_data == DataType || isSingleton cons) - (newtypeConError tc_name (length cons)) - - -- Check that there's at least one condecl, - -- or else we're reading an hs-boot file, or -XEmptyDataDecls - ; checkTc (not (null cons) || empty_data_decls || is_boot) - (emptyConDeclsErr tc_name) - ; tycon <- fixM (\ tycon -> do { let res_ty = mkTyConApp tycon (mkTyVarTys final_tvs) - ; data_cons <- tcConDecls unbox_strict ex_ok - tycon (final_tvs, res_ty) cons + ; data_cons <- tcConDecls ex_ok tycon (final_tvs, res_ty) cons ; tc_rhs <- if null cons && is_boot -- In a hs-boot file, empty cons means then return AbstractTyCon -- "don't know"; hence Abstract @@ -701,8 +507,7 @@ NewType -> ASSERT( not (null data_cons) ) mkNewTyConRhs tc_name tycon (head data_cons) ; buildAlgTyCon tc_name final_tvs stupid_theta tc_rhs is_rec - (want_generic && canDoGenerics data_cons) (not h98_syntax) - NoParentTyCon Nothing + (not h98_syntax) NoParentTyCon Nothing }) ; return [ATyCon tycon] } @@ -718,7 +523,7 @@ tcTyVarBndrs tvs $ \ tvs' -> do { ctxt' <- tcHsKindedContext ctxt ; fds' <- mapM (addLocM tc_fundep) fundeps - ; sig_stuff <- tcClassSigs class_name sigs meths + ; (sig_stuff, gen_dm_env) <- tcClassSigs class_name sigs meths ; clas <- fixM $ \ clas -> do { let -- This little knot is just so we can get -- hold of the name of the class TyCon, which we @@ -731,7 +536,18 @@ ; buildClass False {- Must include unfoldings for selectors -} class_name tvs' ctxt' fds' (concat atss') sig_stuff tc_isrec } - ; return (AClass clas : map ATyCon (classATs clas)) + + ; let gen_dm_ids = [ AnId (mkExportedLocalId gen_dm_name gen_dm_ty) + | (sel_id, GenDefMeth gen_dm_name) <- classOpItems clas + , let gen_dm_tau = expectJust "tcTyClDecl1" $ + lookupNameEnv gen_dm_env (idName sel_id) + , let gen_dm_ty = mkSigmaTy tvs' + [mkClassPred clas (mkTyVarTys tvs')] + gen_dm_tau + ] + class_ats = map ATyCon (classATs clas) + + ; return (AClass clas : gen_dm_ids ++ class_ats ) -- NB: Order is important due to the call to `mkGlobalThings' when -- tying the the type and class declaration type checking knot. } @@ -746,31 +562,53 @@ tcTyClDecl1 _ _ d = pprPanic "tcTyClDecl1" (ppr d) +dataDeclChecks :: Name -> NewOrData -> ThetaType -> [LConDecl Name] -> TcM () +dataDeclChecks tc_name new_or_data stupid_theta cons + = do { -- Check that we don't use GADT syntax in H98 world + gadtSyntax_ok <- xoptM Opt_GADTSyntax + ; let h98_syntax = consUseH98Syntax cons + ; checkTc (gadtSyntax_ok || h98_syntax) (badGadtDecl tc_name) + + -- Check that the stupid theta is empty for a GADT-style declaration + ; checkTc (null stupid_theta || h98_syntax) (badStupidTheta tc_name) + + -- Check that a newtype has exactly one constructor + -- Do this before checking for empty data decls, so that + -- we don't suggest -XEmptyDataDecls for newtypes + ; checkTc (new_or_data == DataType || isSingleton cons) + (newtypeConError tc_name (length cons)) + + -- Check that there's at least one condecl, + -- or else we're reading an hs-boot file, or -XEmptyDataDecls + ; empty_data_decls <- xoptM Opt_EmptyDataDecls + ; is_boot <- tcIsHsBoot -- Are we compiling an hs-boot file? + ; checkTc (not (null cons) || empty_data_decls || is_boot) + (emptyConDeclsErr tc_name) } + ----------------------------------- -tcConDecls :: Bool -> Bool -> TyCon -> ([TyVar], Type) +tcConDecls :: Bool -> TyCon -> ([TyVar], Type) -> [LConDecl Name] -> TcM [DataCon] -tcConDecls unbox ex_ok rep_tycon res_tmpl cons - = mapM (addLocM (tcConDecl unbox ex_ok rep_tycon res_tmpl)) cons +tcConDecls ex_ok rep_tycon res_tmpl cons + = mapM (addLocM (tcConDecl ex_ok rep_tycon res_tmpl)) cons -tcConDecl :: Bool -- True <=> -funbox-strict_fields - -> Bool -- True <=> -XExistentialQuantificaton or -XGADTs +tcConDecl :: Bool -- True <=> -XExistentialQuantificaton or -XGADTs -> TyCon -- Representation tycon -> ([TyVar], Type) -- Return type template (with its template tyvars) -> ConDecl Name -> TcM DataCon -tcConDecl unbox_strict existential_ok rep_tycon res_tmpl -- Data types - (ConDecl {con_name =name, con_qvars = tvs, con_cxt = ctxt +tcConDecl existential_ok rep_tycon res_tmpl -- Data types + con@(ConDecl {con_name = name, con_qvars = tvs, con_cxt = ctxt , con_details = details, con_res = res_ty }) = addErrCtxt (dataConCtxt name) $ tcTyVarBndrs tvs $ \ tvs' -> do { ctxt' <- tcHsKindedContext ctxt - ; checkTc (existential_ok || (null tvs && null (unLoc ctxt))) + ; checkTc (existential_ok || conRepresentibleWithH98Syntax con) (badExistential name) ; (univ_tvs, ex_tvs, eq_preds, res_ty') <- tcResultType res_tmpl tvs' res_ty ; let tc_datacon is_infix field_lbls btys - = do { (arg_tys, stricts) <- mapAndUnzipM (tcConArg unbox_strict) btys + = do { (arg_tys, stricts) <- mapAndUnzipM tcConArg btys ; buildDataCon (unLoc name) is_infix stricts field_lbls univ_tvs ex_tvs eq_preds ctxt' arg_tys @@ -860,14 +698,26 @@ consUseH98Syntax _ = True -- All constructors have same shape +conRepresentibleWithH98Syntax :: ConDecl Name -> Bool +conRepresentibleWithH98Syntax + (ConDecl {con_qvars = tvs, con_cxt = ctxt, con_res = ResTyH98 }) + = null tvs && null (unLoc ctxt) +conRepresentibleWithH98Syntax + (ConDecl {con_qvars = tvs, con_cxt = ctxt, con_res = ResTyGADT (L _ t) }) + = null (unLoc ctxt) && f t (map (hsTyVarName . unLoc) tvs) + where -- Each type variable should be used exactly once in the + -- result type, and the result type must just be the type + -- constructor applied to type variables + f (HsAppTy (L _ t1) (L _ (HsTyVar v2))) vs + = (v2 `elem` vs) && f t1 (delete v2 vs) + f (HsTyVar _) [] = True + f _ _ = False + ------------------- -tcConArg :: Bool -- True <=> -funbox-strict_fields - -> LHsType Name - -> TcM (TcType, HsBang) -tcConArg unbox_strict bty +tcConArg :: LHsType Name -> TcM (TcType, HsBang) +tcConArg bty = do { arg_ty <- tcHsBangType bty - ; let bang = getBangStrictness bty - ; let strict_mark = chooseBoxingStrategy unbox_strict arg_ty bang + ; strict_mark <- chooseBoxingStrategy arg_ty (getBangStrictness bty) ; return (arg_ty, strict_mark) } -- We attempt to unbox/unpack a strict field when either: @@ -876,13 +726,19 @@ -- -- We have turned off unboxing of newtypes because coercions make unboxing -- and reboxing more complicated -chooseBoxingStrategy :: Bool -> TcType -> HsBang -> HsBang -chooseBoxingStrategy unbox_strict_fields arg_ty bang +chooseBoxingStrategy :: TcType -> HsBang -> TcM HsBang +chooseBoxingStrategy arg_ty bang = case bang of - HsNoBang -> HsNoBang - HsUnpack -> can_unbox HsUnpackFailed arg_ty - HsStrict | unbox_strict_fields -> can_unbox HsStrict arg_ty - | otherwise -> HsStrict + HsNoBang -> return HsNoBang + HsStrict -> do { unbox_strict <- doptM Opt_UnboxStrictFields + ; if unbox_strict then return (can_unbox HsStrict arg_ty) + else return HsStrict } + HsUnpack -> do { omit_prags <- doptM Opt_OmitInterfacePragmas + -- Do not respect UNPACK pragmas if OmitInterfacePragmas is on + -- See Trac #5252: unpacking means we must not conceal the + -- representation of the argument type + ; if omit_prags then return HsStrict + else return (can_unbox HsUnpackFailed arg_ty) } HsUnpackFailed -> pprPanic "chooseBoxingStrategy" (ppr arg_ty) -- Source code never has shtes where @@ -958,6 +814,8 @@ ATyCon tc -> checkValidTyCon tc AClass cl -> do { checkValidClass cl ; mapM_ (addLocM checkValidTyCl) (tcdATs decl) } + AnId _ -> return () -- Generic default methods are checked + -- with their parent class _ -> panic "checkValidTyCl" ; traceTc "Done validity of" (ppr thing) } @@ -1083,14 +941,14 @@ -- One argument ; checkTc (null eq_spec) (newtypePredError con) -- Return type is (T a b c) - ; checkTc (null ex_tvs && null eq_theta && null dict_theta) (newtypeExError con) + ; checkTc (null ex_tvs && null theta) (newtypeExError con) -- No existentials ; checkTc (not (any isBanged (dataConStrictMarks con))) (newtypeStrictError con) -- No strictness } where - (_univ_tvs, ex_tvs, eq_spec, eq_theta, dict_theta, arg_tys, _res_ty) = dataConFullSig con + (_univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _res_ty) = dataConFullSig con ------------------------------- checkValidClass :: Class -> TcM () @@ -1118,7 +976,7 @@ where (tyvars, fundeps, theta, _, _, op_stuff) = classExtraBigSig cls unary = isSingleton tyvars - no_generics = null [() | (_, GenDefMeth) <- op_stuff] + no_generics = null [() | (_, (GenDefMeth _)) <- op_stuff] check_op constrained_class_methods (sel_id, dm) = addErrCtxt (classOpCtxt sel_id tau) $ do @@ -1139,10 +997,10 @@ ; checkTc (tyVarsOfType tau `intersectsVarSet` grown_tyvars) (noClassTyVarErr cls sel_id) - -- Check that for a generic method, the type of - -- the method is sufficiently simple - ; checkTc (dm /= GenDefMeth || validGenericMethodType tau) - (badGenericMethodType op_name op_ty) + ; case dm of + GenDefMeth dm_name -> do { dm_id <- tcLookupId dm_name + ; checkValidType (FunSigCtxt op_name) (idType dm_id) } + _ -> return () } where op_name = idName sel_id @@ -1170,7 +1028,7 @@ mkDefaultMethodIds :: [TyThing] -> [Id] -- See Note [Default method Ids and Template Haskell] mkDefaultMethodIds things - = [ mkDefaultMethodId sel_id dm_name + = [ mkExportedLocalId dm_name (idType sel_id) | AClass cls <- things , (sel_id, DefMeth dm_name) <- classOpItems cls ] \end{code} @@ -1192,16 +1050,16 @@ when typechecking the [d| .. |] quote, and typecheck them later. \begin{code} -mkRecSelBinds :: [TyThing] -> HsValBinds Name +mkRecSelBinds :: [TyCon] -> HsValBinds Name -- NB We produce *un-typechecked* bindings, rather like 'deriving' -- This makes life easier, because the later type checking will add -- all necessary type abstractions and applications -mkRecSelBinds ty_things +mkRecSelBinds tycons = ValBindsOut [(NonRecursive, b) | b <- binds] sigs where (sigs, binds) = unzip rec_sels rec_sels = map mkRecSelBind [ (tc,fld) - | ATyCon tc <- ty_things + | tc <- tycons , fld <- tyConFields tc ] mkRecSelBind :: (TyCon, FieldLabel) -> (LSig Name, LHsBinds Name) @@ -1408,12 +1266,6 @@ = ptext (sLit "The multi-parameter class") <+> quotes (ppr clas) <+> ptext (sLit "cannot have generic methods") -badGenericMethodType :: Name -> Kind -> SDoc -badGenericMethodType op op_ty - = hang (ptext (sLit "Generic method type is too complex")) - 2 (vcat [ppr op <+> dcolon <+> ppr op_ty, - ptext (sLit "You can only use type variables, arrows, lists, and tuples")]) - recSynErr :: [LTyClDecl Name] -> TcRn () recSynErr syn_decls = setSrcSpan (getLoc (head sorted_decls)) $ @@ -1451,7 +1303,7 @@ badExistential :: Located Name -> SDoc badExistential con_name = hang (ptext (sLit "Data constructor") <+> quotes (ppr con_name) <+> - ptext (sLit "has existential type variables, or a context")) + ptext (sLit "has existential type variables, a context, or a specialised result type")) 2 (parens $ ptext (sLit "Use -XExistentialQuantification or -XGADTs to allow this")) badStupidTheta :: Name -> SDoc @@ -1495,39 +1347,6 @@ quotes (ppr tc_name) , nest 2 (parens $ ptext (sLit "Use -XTypeFamilies to allow indexed type families")) ] -tooManyParmsErr :: Located Name -> SDoc -tooManyParmsErr tc_name - = ptext (sLit "Family instance has too many parameters:") <+> - quotes (ppr tc_name) - -tooFewParmsErr :: Arity -> SDoc -tooFewParmsErr arity - = ptext (sLit "Family instance has too few parameters; expected") <+> - ppr arity - -wrongNumberOfParmsErr :: Arity -> SDoc -wrongNumberOfParmsErr exp_arity - = ptext (sLit "Number of parameters must match family declaration; expected") - <+> ppr exp_arity - -badBootFamInstDeclErr :: SDoc -badBootFamInstDeclErr - = ptext (sLit "Illegal family instance in hs-boot file") - -notFamily :: TyCon -> SDoc -notFamily tycon - = vcat [ ptext (sLit "Illegal family instance for") <+> quotes (ppr tycon) - , nest 2 $ parens (ppr tycon <+> ptext (sLit "is not an indexed type family"))] - -wrongKindOfFamily :: TyCon -> SDoc -wrongKindOfFamily family - = ptext (sLit "Wrong category of family instance; declaration was for a") - <+> kindOfFamily - where - kindOfFamily | isSynTyCon family = ptext (sLit "type synonym") - | isAlgTyCon family = ptext (sLit "data type") - | otherwise = pprPanic "wrongKindOfFamily" (ppr family) - emptyConDeclsErr :: Name -> SDoc emptyConDeclsErr tycon = sep [quotes (ppr tycon) <+> ptext (sLit "has no constructors"), diff -Nru ghc-7.0.3/compiler/typecheck/TcTyDecls.lhs ghc-7.2.1/compiler/typecheck/TcTyDecls.lhs --- ghc-7.0.3/compiler/typecheck/TcTyDecls.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/typecheck/TcTyDecls.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -30,7 +30,7 @@ import Digraph import BasicTypes import SrcLoc -import Outputable +import Maybes( mapCatMaybes ) import Util ( isSingleton ) import Data.List \end{code} @@ -253,11 +253,10 @@ nt_loop_breakers `unionNameSets` prod_loop_breakers - all_tycons = [ tc | tycls <- tyclss, + all_tycons = [ tc | tc <- mapCatMaybes getTyCon tyclss -- Recursion of newtypes/data types can happen via -- the class TyCon, so tyclss includes the class tycons - let tc = getTyCon tycls, - not (tyConName tc `elemNameSet` boot_name_set) ] + , not (tyConName tc `elemNameSet` boot_name_set) ] -- Remove the boot_name_set because they are going -- to be loop breakers regardless. @@ -321,10 +320,10 @@ new_tc_rhs :: TyCon -> Type new_tc_rhs tc = snd (newTyConRhs tc) -- Ignore the type variables -getTyCon :: TyThing -> TyCon -getTyCon (ATyCon tc) = tc -getTyCon (AClass cl) = classTyCon cl -getTyCon _ = panic "getTyCon" +getTyCon :: TyThing -> Maybe TyCon +getTyCon (ATyCon tc) = Just tc +getTyCon (AClass cl) = Just (classTyCon cl) +getTyCon _ = Nothing findLoopBreakers :: [(TyCon, [TyCon])] -> [Name] -- Finds a set of tycons that cut all loops @@ -356,8 +355,8 @@ go (FunTy a b) = go a `plusNameEnv` go b go (PredTy (IParam _ ty)) = go ty go (PredTy (ClassP cls tys)) = go_tc (classTyCon cls) tys + go (PredTy (EqPred ty1 ty2)) = go ty1 `plusNameEnv` go ty2 go (ForAllTy _ ty) = go ty - go _ = panic "tcTyConsOfType" go_tc tc tys = extendNameEnv (go_s tys) (tyConName tc) tc go_s tys = foldr (plusNameEnv . go) emptyNameEnv tys diff -Nru ghc-7.0.3/compiler/typecheck/TcType.lhs ghc-7.2.1/compiler/typecheck/TcType.lhs --- ghc-7.0.3/compiler/typecheck/TcType.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/typecheck/TcType.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -19,7 +19,7 @@ -------------------------------- -- Types TcType, TcSigmaType, TcRhoType, TcTauType, TcPredType, TcThetaType, - TcTyVar, TcTyVarSet, TcKind, TcCoVar, + TcCoercion, TcTyVar, TcTyVarSet, TcKind, TcCoVar, -------------------------------- -- MetaDetails @@ -50,7 +50,7 @@ --------------------------------- -- Predicates. -- Again, newtypes are opaque - tcEqType, tcEqTypes, tcEqPred, tcCmpType, tcCmpTypes, tcCmpPred, tcEqTypeX, + eqType, eqTypes, eqPred, cmpType, cmpTypes, cmpPred, eqTypeX, eqKind, isSigmaTy, isOverloadedTy, isDoubleTy, isFloatTy, isIntTy, isWordTy, isStringTy, @@ -61,18 +61,11 @@ --------------------------------- -- Misc type manipulators deNoteType, - orphNamesOfType, orphNamesOfDFunHead, + orphNamesOfType, orphNamesOfDFunHead, orphNamesOfCo, getDFunTyKey, --------------------------------- -- Predicate types - getClassPredTys_maybe, getClassPredTys, - isClassPred, isTyVarClassPred, isEqPred, - mkClassPred, mkIPPred, tcSplitPredTy_maybe, - mkDictTy, evVarPred, - isPredTy, isDictTy, isDictLikeTy, - tcSplitDFunTy, tcSplitDFunHead, predTyUnique, - isIPPred, mkMinimalBySCs, transSuperClasses, immSuperClasses, -- * Tidying type related things up for printing @@ -81,7 +74,8 @@ tidyTyVarBndr, tidyFreeTyVars, tidyOpenTyVar, tidyOpenTyVars, tidyTopType, tidyPred, - tidyKind, + tidyKind, + tidyCo, tidyCos, --------------------------------- -- Foreign import and export @@ -101,32 +95,38 @@ tcSplitIOType_maybe, -- :: Type -> Maybe Type -------------------------------- - -- Rexported from Coercion - typeKind, - - -------------------------------- - -- Rexported from Type - Kind, -- Stuff to do with kinds is insensitive to pre/post Tc + -- Rexported from Kind + Kind, typeKind, unliftedTypeKind, liftedTypeKind, argTypeKind, openTypeKind, mkArrowKind, mkArrowKinds, isLiftedTypeKind, isUnliftedTypeKind, isSubOpenTypeKind, isSubArgTypeKind, isSubKind, splitKindFunTys, defaultKind, kindVarRef, mkKindVar, - Type, PredType(..), ThetaType, + -------------------------------- + -- Rexported from Type + Type, Pred(..), PredType, ThetaType, mkForAllTy, mkForAllTys, mkFunTy, mkFunTys, zipFunTys, mkTyConApp, mkAppTy, mkAppTys, applyTy, applyTys, mkTyVarTy, mkTyVarTys, mkTyConTy, mkPredTy, mkPredTys, + getClassPredTys_maybe, getClassPredTys, + isClassPred, isTyVarClassPred, isEqPred, + mkClassPred, mkIPPred, splitPredTy_maybe, + mkDictTy, isPredTy, isDictTy, isDictLikeTy, + tcSplitDFunTy, tcSplitDFunHead, + isIPPred, mkEqPred, + -- Type substitutions TvSubst(..), -- Representation visible to a few friends - TvSubstEnv, emptyTvSubst, substEqSpec, + TvSubstEnv, emptyTvSubst, mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst, mkTopTvSubst, notElemTvSubst, unionTvSubst, - getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope, lookupTyVar, - extendTvSubst, extendTvSubstList, isInScope, mkTvSubst, zipTyEnv, - substTy, substTys, substTyWith, substTheta, substTyVar, substTyVars, substTyVarBndr, + getTvSubstEnv, setTvSubstEnv, getTvInScope, extendTvInScope, + Type.lookupTyVar, Type.extendTvSubst, Type.substTyVarBndr, + extendTvSubstList, isInScope, mkTvSubst, zipTyEnv, + Type.substTy, substTys, substTyWith, substTheta, substTyVar, substTyVars, isUnLiftedType, -- Source types are always lifted isUnboxedTupleType, -- Ditto @@ -138,13 +138,14 @@ pprKind, pprParendKind, pprType, pprParendType, pprTypeApp, pprTyThingCategory, - pprPred, pprTheta, pprThetaArrow, pprClassPred + pprPred, pprTheta, pprThetaArrow, pprThetaArrowTy, pprClassPred ) where #include "HsVersions.h" -- friends: +import Kind import TypeRep import Class import Var @@ -156,7 +157,7 @@ -- others: import DynFlags -import Name +import Name hiding (varName) import NameSet import VarEnv import PrelNames @@ -216,6 +217,8 @@ -- a cannot occur inside a MutTyVar in T; that is, -- T is "flattened" before quantifying over a +type TcCoercion = Coercion -- A TcCoercion can contain TcTypes. + -- These types do not have boxy type variables in them type TcPredType = PredType type TcThetaType = ThetaType @@ -262,7 +265,7 @@ The alternative (currently implemented) is to have a special kind of skolem constant, SigTv, which can unify with other SigTvs. These are *not* treated -as righd for the purposes of GADTs. And they are used *only* for pattern +as rigid for the purposes of GADTs. And they are used *only* for pattern bindings and mutually recursive function bindings. See the function TcBinds.tcInstSig, and its use_skols parameter. @@ -306,14 +309,12 @@ -- A TauTv is always filled in with a tau-type, which -- never contains any ForAlls - | SigTv Name -- A variant of TauTv, except that it should not be + | SigTv -- A variant of TauTv, except that it should not be -- unified with a type, only with a type variable -- SigTvs are only distinguished to improve error messages -- see Note [Signature skolems] -- The MetaDetails, if filled in, will -- always be another SigTv or a SkolemTv - -- The Name is the name of the function from whose - -- type signature we got this skolem | TcsTv -- A MetaTv allocated by the constraint solver -- Its particular property is that it is always "touchable" @@ -392,12 +393,12 @@ \begin{code} pprTcTyVarDetails :: TcTyVarDetails -> SDoc -- For debugging -pprTcTyVarDetails (SkolemTv {}) = ptext (sLit "sk") -pprTcTyVarDetails (RuntimeUnk {}) = ptext (sLit "rt") -pprTcTyVarDetails (FlatSkol {}) = ptext (sLit "fsk") -pprTcTyVarDetails (MetaTv TauTv _) = ptext (sLit "tau") -pprTcTyVarDetails (MetaTv TcsTv _) = ptext (sLit "tcs") -pprTcTyVarDetails (MetaTv (SigTv _) _) = ptext (sLit "sig") +pprTcTyVarDetails (SkolemTv {}) = ptext (sLit "sk") +pprTcTyVarDetails (RuntimeUnk {}) = ptext (sLit "rt") +pprTcTyVarDetails (FlatSkol {}) = ptext (sLit "fsk") +pprTcTyVarDetails (MetaTv TauTv _) = ptext (sLit "tau") +pprTcTyVarDetails (MetaTv TcsTv _) = ptext (sLit "tcs") +pprTcTyVarDetails (MetaTv SigTv _) = ptext (sLit "sig") pprUserTypeCtxt :: UserTypeCtxt -> SDoc pprUserTypeCtxt (FunSigCtxt n) = ptext (sLit "the type signature for") <+> quotes (ppr n) @@ -428,19 +429,13 @@ -- -- It doesn't change the uniques at all, just the print names. tidyTyVarBndr :: TidyEnv -> TyVar -> (TidyEnv, TyVar) -tidyTyVarBndr env@(tidy_env, subst) tyvar +tidyTyVarBndr (tidy_env, subst) tyvar = case tidyOccName tidy_env occ1 of - (tidy', occ') -> ((tidy', subst'), tyvar'') + (tidy', occ') -> ((tidy', subst'), tyvar') where - subst' = extendVarEnv subst tyvar tyvar'' + subst' = extendVarEnv subst tyvar tyvar' tyvar' = setTyVarName tyvar name' - - name' = tidyNameOcc name occ' - - -- Don't forget to tidy the kind for coercions! - tyvar'' | isCoVar tyvar = setTyVarKind tyvar' kind' - | otherwise = tyvar' - kind' = tidyType env (tyVarKind tyvar) + name' = tidyNameOcc name occ' where name = tyVarName tyvar occ = getOccName name @@ -529,6 +524,40 @@ tidyKind env k = tidyOpenType env k \end{code} +%************************************************************************ +%* * + Tidying coercions +%* * +%************************************************************************ + +\begin{code} + +tidyCo :: TidyEnv -> Coercion -> Coercion +tidyCo env@(_, subst) co + = go co + where + go (Refl ty) = Refl (tidyType env ty) + go (TyConAppCo tc cos) = let args = map go cos + in args `seqList` TyConAppCo tc args + go (AppCo co1 co2) = (AppCo $! go co1) $! go co2 + go (ForAllCo tv co) = ForAllCo tvp $! (tidyCo envp co) + where + (envp, tvp) = tidyTyVarBndr env tv + go (CoVarCo cv) = case lookupVarEnv subst cv of + Nothing -> CoVarCo cv + Just cv' -> CoVarCo cv' + go (AxiomInstCo con cos) = let args = tidyCos env cos + in args `seqList` AxiomInstCo con args + go (UnsafeCo ty1 ty2) = (UnsafeCo $! tidyType env ty1) $! tidyType env ty2 + go (SymCo co) = SymCo $! go co + go (TransCo co1 co2) = (TransCo $! go co1) $! go co2 + go (NthCo d co) = NthCo d $! go co + go (InstCo co ty) = (InstCo $! go co) $! tidyType env ty + +tidyCos :: TidyEnv -> [Coercion] -> [Coercion] +tidyCos env = map (tidyCo env) + +\end{code} %************************************************************************ %* * @@ -552,8 +581,8 @@ -- not a SigTv = ASSERT( isTcTyVar tv) case tcTyVarDetails tv of - MetaTv (SigTv _) _ -> False - _ -> True + MetaTv SigTv _ -> False + _ -> True isSkolemTyVar tv = ASSERT2( isTcTyVar tv, ppr tv ) @@ -583,8 +612,8 @@ isSigTyVar tv = ASSERT( isTcTyVar tv ) case tcTyVarDetails tv of - MetaTv (SigTv _) _ -> True - _ -> False + MetaTv SigTv _ -> True + _ -> False metaTvRef :: TyVar -> IORef MetaDetails metaTvRef tv @@ -672,22 +701,19 @@ tcSplitForAllTys ty = split ty ty [] where split orig_ty ty tvs | Just ty' <- tcView ty = split orig_ty ty' tvs - split _ (ForAllTy tv ty) tvs - | not (isCoVar tv) = split ty ty (tv:tvs) - split orig_ty _ tvs = (reverse tvs, orig_ty) + split _ (ForAllTy tv ty) tvs = split ty ty (tv:tvs) + split orig_ty _ tvs = (reverse tvs, orig_ty) tcIsForAllTy :: Type -> Bool tcIsForAllTy ty | Just ty' <- tcView ty = tcIsForAllTy ty' -tcIsForAllTy (ForAllTy tv _) = not (isCoVar tv) -tcIsForAllTy _ = False +tcIsForAllTy (ForAllTy {}) = True +tcIsForAllTy _ = False tcSplitPredFunTy_maybe :: Type -> Maybe (PredType, Type) -- Split off the first predicate argument from a type tcSplitPredFunTy_maybe ty | Just ty' <- tcView ty = tcSplitPredFunTy_maybe ty' -tcSplitPredFunTy_maybe (ForAllTy tv ty) - | isCoVar tv = Just (coVarPred tv, ty) tcSplitPredFunTy_maybe (FunTy arg res) - | Just p <- tcSplitPredTy_maybe arg = Just (p, res) + | Just p <- splitPredTy_maybe arg = Just (p, res) tcSplitPredFunTy_maybe _ = Nothing @@ -822,27 +848,27 @@ tcIsTyVarTy ty = maybeToBool (tcGetTyVar_maybe ty) ----------------------- -tcSplitDFunTy :: Type -> ([TyVar], Class, [Type]) +tcSplitDFunTy :: Type -> ([TyVar], Int, Class, [Type]) -- Split the type of a dictionary function -- We don't use tcSplitSigmaTy, because a DFun may (with NDP) -- have non-Pred arguments, such as -- df :: forall m. (forall b. Eq b => Eq (m b)) -> C m tcSplitDFunTy ty - = case tcSplitForAllTys ty of { (tvs, rho) -> - case tcSplitDFunHead (drop_pred_tys rho) of { (clas, tys) -> - (tvs, clas, tys) }} + = case tcSplitForAllTys ty of { (tvs, rho) -> + case split_dfun_args 0 rho of { (n_theta, tau) -> + case tcSplitDFunHead tau of { (clas, tys) -> + (tvs, n_theta, clas, tys) }}} where - -- Discard the context of the dfun. This can be a mix of + -- Count the context of the dfun. This can be a mix of -- coercion and class constraints; or (in the general NDP case) -- some other function argument - drop_pred_tys ty | Just ty' <- tcView ty = drop_pred_tys ty' - drop_pred_tys (ForAllTy tv ty) = ASSERT( isCoVar tv ) drop_pred_tys ty - drop_pred_tys (FunTy _ ty) = drop_pred_tys ty - drop_pred_tys ty = ty + split_dfun_args n ty | Just ty' <- tcView ty = split_dfun_args n ty' + split_dfun_args n (FunTy _ ty) = split_dfun_args (n+1) ty + split_dfun_args n ty = (n, ty) tcSplitDFunHead :: Type -> (Class, [Type]) tcSplitDFunHead tau - = case tcSplitPredTy_maybe tau of + = case splitPredTy_maybe tau of Just (ClassP clas tys) -> (clas, tys) _ -> pprPanic "tcSplitDFunHead" (ppr tau) @@ -859,6 +885,9 @@ -- Used in Haskell-98 mode, for the argument types of an instance head -- These must be a constructor applied to type variable arguments tcInstHeadTyAppAllTyVars ty + | Just ty' <- tcView ty -- Look through synonyms + = tcInstHeadTyAppAllTyVars ty' + | otherwise = case ty of TyConApp _ tys -> ok tys FunTy arg res -> ok [arg, res] @@ -882,62 +911,6 @@ %* * %************************************************************************ -\begin{code} -evVarPred :: EvVar -> PredType -evVarPred var - = case tcSplitPredTy_maybe (varType var) of - Just pred -> pred - Nothing -> pprPanic "evVarPred" (ppr var <+> ppr (varType var)) - -tcSplitPredTy_maybe :: Type -> Maybe PredType - -- Returns Just for predicates only -tcSplitPredTy_maybe ty | Just ty' <- tcView ty = tcSplitPredTy_maybe ty' -tcSplitPredTy_maybe (PredTy p) = Just p -tcSplitPredTy_maybe _ = Nothing - -predTyUnique :: PredType -> Unique -predTyUnique (IParam n _) = getUnique (ipNameName n) -predTyUnique (ClassP clas _) = getUnique clas -predTyUnique (EqPred a b) = pprPanic "predTyUnique" (ppr (EqPred a b)) -\end{code} - - ---------------------- Dictionary types --------------------------------- - -\begin{code} -mkClassPred :: Class -> [Type] -> PredType -mkClassPred clas tys = ClassP clas tys - -isClassPred :: PredType -> Bool -isClassPred (ClassP _ _) = True -isClassPred _ = False - -isTyVarClassPred :: PredType -> Bool -isTyVarClassPred (ClassP _ tys) = all tcIsTyVarTy tys -isTyVarClassPred _ = False - -getClassPredTys_maybe :: PredType -> Maybe (Class, [Type]) -getClassPredTys_maybe (ClassP clas tys) = Just (clas, tys) -getClassPredTys_maybe _ = Nothing - -getClassPredTys :: PredType -> (Class, [Type]) -getClassPredTys (ClassP clas tys) = (clas, tys) -getClassPredTys _ = panic "getClassPredTys" - -mkDictTy :: Class -> [Type] -> Type -mkDictTy clas tys = mkPredTy (ClassP clas tys) - - - -isDictLikeTy :: Type -> Bool --- Note [Dictionary-like types] -isDictLikeTy ty | Just ty' <- tcView ty = isDictTy ty' -isDictLikeTy (PredTy p) = isClassPred p -isDictLikeTy (TyConApp tc tys) - | isTupleTyCon tc = all isDictLikeTy tys -isDictLikeTy _ = False -\end{code} - Superclasses \begin{code} @@ -947,7 +920,7 @@ , ploc `not_in_preds` rec_scs ] where rec_scs = concatMap trans_super_classes ptys - not_in_preds p ps = null (filter (tcEqPred p) ps) + not_in_preds p ps = null (filter (eqPred p) ps) trans_super_classes (ClassP cls tys) = transSuperClasses cls tys trans_super_classes _other_pty = [] @@ -967,53 +940,6 @@ where (tyvars,sc_theta,_,_) = classBigSig cls \end{code} -Note [Dictionary-like types] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Being "dictionary-like" means either a dictionary type or a tuple thereof. -In GHC 6.10 we build implication constraints which construct such tuples, -and if we land up with a binding - t :: (C [a], Eq [a]) - t = blah -then we want to treat t as cheap under "-fdicts-cheap" for example. -(Implication constraints are normally inlined, but sadly not if the -occurrence is itself inside an INLINE function! Until we revise the -handling of implication constraints, that is.) This turned out to -be important in getting good arities in DPH code. Example: - - class C a - class D a where { foo :: a -> a } - instance C a => D (Maybe a) where { foo x = x } - - bar :: (C a, C b) => a -> b -> (Maybe a, Maybe b) - {-# INLINE bar #-} - bar x y = (foo (Just x), foo (Just y)) - -Then 'bar' should jolly well have arity 4 (two dicts, two args), but -we ended up with something like - bar = __inline_me__ (\d1,d2. let t :: (D (Maybe a), D (Maybe b)) = ... - in \x,y. ) - -This is all a bit ad-hoc; eg it relies on knowing that implication -constraints build tuples. - ---------------------- Implicit parameters --------------------------------- - -\begin{code} -mkIPPred :: IPName Name -> Type -> PredType -mkIPPred ip ty = IParam ip ty - -isIPPred :: PredType -> Bool -isIPPred (IParam _ _) = True -isIPPred _ = False -\end{code} - ---------------------- Equality predicates --------------------------------- -\begin{code} -substEqSpec :: TvSubst -> [(TyVar,Type)] -> [(TcType,TcType)] -substEqSpec subst eq_spec = [ (substTyVar subst tv, substTy subst ty) - | (tv,ty) <- eq_spec] -\end{code} - %************************************************************************ %* * @@ -1035,17 +961,10 @@ isOverloadedTy :: Type -> Bool -- Yes for a type of a function that might require evidence-passing -- Used only by bindLocalMethods --- NB: be sure to check for type with an equality predicate; hence isCoVar isOverloadedTy ty | Just ty' <- tcView ty = isOverloadedTy ty' -isOverloadedTy (ForAllTy tv ty) = isCoVar tv || isOverloadedTy ty -isOverloadedTy (FunTy a _) = isPredTy a -isOverloadedTy _ = False - -isPredTy :: Type -> Bool -- Belongs in TcType because it does - -- not look through newtypes, or predtypes (of course) -isPredTy ty | Just ty' <- tcView ty = isPredTy ty' -isPredTy (PredTy _) = True -isPredTy _ = False +isOverloadedTy (ForAllTy _ ty) = isOverloadedTy ty +isOverloadedTy (FunTy a _) = isPredTy a +isOverloadedTy _ = False \end{code} \begin{code} @@ -1107,14 +1026,9 @@ tcTyVarsOfType (PredTy sty) = tcTyVarsOfPred sty tcTyVarsOfType (FunTy arg res) = tcTyVarsOfType arg `unionVarSet` tcTyVarsOfType res tcTyVarsOfType (AppTy fun arg) = tcTyVarsOfType fun `unionVarSet` tcTyVarsOfType arg -tcTyVarsOfType (ForAllTy tyvar ty) = (tcTyVarsOfType ty `delVarSet` tyvar) - `unionVarSet` tcTyVarsOfTyVar tyvar +tcTyVarsOfType (ForAllTy tyvar ty) = tcTyVarsOfType ty `delVarSet` tyvar -- We do sometimes quantify over skolem TcTyVars -tcTyVarsOfTyVar :: TcTyVar -> TyVarSet -tcTyVarsOfTyVar tv | isCoVar tv = tcTyVarsOfType (tyVarKind tv) - | otherwise = emptyVarSet - tcTyVarsOfTypes :: [Type] -> TyVarSet tcTyVarsOfTypes tys = foldr (unionVarSet.tcTyVarsOfType) emptyVarSet tys @@ -1124,61 +1038,6 @@ tcTyVarsOfPred (EqPred ty1 ty2) = tcTyVarsOfType ty1 `unionVarSet` tcTyVarsOfType ty2 \end{code} -Note [Silly type synonym] -~~~~~~~~~~~~~~~~~~~~~~~~~ -Consider - type T a = Int -What are the free tyvars of (T x)? Empty, of course! -Here's the example that Ralf Laemmel showed me: - foo :: (forall a. C u a -> C u a) -> u - mappend :: Monoid u => u -> u -> u - - bar :: Monoid u => u - bar = foo (\t -> t `mappend` t) -We have to generalise at the arg to f, and we don't -want to capture the constraint (Monad (C u a)) because -it appears to mention a. Pretty silly, but it was useful to him. - -exactTyVarsOfType is used by the type checker to figure out exactly -which type variables are mentioned in a type. It's also used in the -smart-app checking code --- see TcExpr.tcIdApp - -On the other hand, consider a *top-level* definition - f = (\x -> x) :: T a -> T a -If we don't abstract over 'a' it'll get fixed to GHC.Prim.Any, and then -if we have an application like (f "x") we get a confusing error message -involving Any. So the conclusion is this: when generalising - - at top level use tyVarsOfType - - in nested bindings use exactTyVarsOfType -See Trac #1813 for example. - -\begin{code} -exactTyVarsOfType :: TcType -> TyVarSet --- Find the free type variables (of any kind) --- but *expand* type synonyms. See Note [Silly type synonym] above. -exactTyVarsOfType ty - = go ty - where - go ty | Just ty' <- tcView ty = go ty' -- This is the key line - go (TyVarTy tv) = unitVarSet tv - go (TyConApp _ tys) = exactTyVarsOfTypes tys - go (PredTy ty) = go_pred ty - go (FunTy arg res) = go arg `unionVarSet` go res - go (AppTy fun arg) = go fun `unionVarSet` go arg - go (ForAllTy tyvar ty) = delVarSet (go ty) tyvar - `unionVarSet` go_tv tyvar - - go_pred (IParam _ ty) = go ty - go_pred (ClassP _ tys) = exactTyVarsOfTypes tys - go_pred (EqPred ty1 ty2) = go ty1 `unionVarSet` go ty2 - - go_tv tyvar | isCoVar tyvar = go (tyVarKind tyvar) - | otherwise = emptyVarSet - -exactTyVarsOfTypes :: [TcType] -> TyVarSet -exactTyVarsOfTypes tys = foldr (unionVarSet . exactTyVarsOfType) emptyVarSet tys -\end{code} - Find the free tycons and classes of a type. This is used in the front end of the compiler. @@ -1211,6 +1070,26 @@ orphNamesOfDFunHead dfun_ty = case tcSplitSigmaTy dfun_ty of (_, _, head_ty) -> orphNamesOfType head_ty + +orphNamesOfCo :: Coercion -> NameSet +orphNamesOfCo (Refl ty) = orphNamesOfType ty +orphNamesOfCo (TyConAppCo tc cos) = unitNameSet (getName tc) `unionNameSets` orphNamesOfCos cos +orphNamesOfCo (AppCo co1 co2) = orphNamesOfCo co1 `unionNameSets` orphNamesOfCo co2 +orphNamesOfCo (ForAllCo _ co) = orphNamesOfCo co +orphNamesOfCo (CoVarCo _) = emptyNameSet +orphNamesOfCo (AxiomInstCo con cos) = orphNamesOfCoCon con `unionNameSets` orphNamesOfCos cos +orphNamesOfCo (UnsafeCo ty1 ty2) = orphNamesOfType ty1 `unionNameSets` orphNamesOfType ty2 +orphNamesOfCo (SymCo co) = orphNamesOfCo co +orphNamesOfCo (TransCo co1 co2) = orphNamesOfCo co1 `unionNameSets` orphNamesOfCo co2 +orphNamesOfCo (NthCo _ co) = orphNamesOfCo co +orphNamesOfCo (InstCo co ty) = orphNamesOfCo co `unionNameSets` orphNamesOfType ty + +orphNamesOfCos :: [Coercion] -> NameSet +orphNamesOfCos = foldr (unionNameSets . orphNamesOfCo) emptyNameSet + +orphNamesOfCoCon :: CoAxiom -> NameSet +orphNamesOfCoCon (CoAxiom { co_ax_lhs = ty1, co_ax_rhs = ty2 }) + = orphNamesOfType ty1 `unionNameSets` orphNamesOfType ty2 \end{code} @@ -1225,7 +1104,7 @@ being the ) \begin{code} -tcSplitIOType_maybe :: Type -> Maybe (TyCon, Type, CoercionI) +tcSplitIOType_maybe :: Type -> Maybe (TyCon, Type, Coercion) -- (isIOType t) returns Just (IO,t',co) -- if co : t ~ IO t' -- returns Nothing otherwise @@ -1236,7 +1115,7 @@ Just (io_tycon, [io_res_ty]) | io_tycon `hasKey` ioTyConKey - -> Just (io_tycon, io_res_ty, IdCo ty) + -> Just (io_tycon, io_res_ty, mkReflCo ty) Just (tc, tys) | not (isRecursiveTyCon tc) @@ -1244,7 +1123,7 @@ -- Newtypes that require a coercion are ok -> case tcSplitIOType_maybe ty of Nothing -> Nothing - Just (tc, ty', co2) -> Just (tc, ty', co1 `mkTransCoI` co2) + Just (tc, ty', co2) -> Just (tc, ty', co1 `mkTransCo` co2) _ -> Nothing diff -Nru ghc-7.0.3/compiler/typecheck/TcUnify.lhs ghc-7.2.1/compiler/typecheck/TcUnify.lhs --- ghc-7.0.3/compiler/typecheck/TcUnify.lhs 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/typecheck/TcUnify.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -20,7 +20,7 @@ matchExpectedListTy, matchExpectedPArrTy, matchExpectedTyConApp, matchExpectedAppTy, matchExpectedFunTys, matchExpectedFunKind, - wrapFunResCoercion + wrapFunResCoercion, failWithMisMatch ) where #include "HsVersions.h" @@ -28,7 +28,7 @@ import HsSyn import TypeRep import CoreUtils( mkPiTypes ) -import TcErrors ( unifyCtxt ) +import TcErrors ( unifyCtxt ) import TcMType import TcIface import TcRnMonad @@ -44,7 +44,6 @@ import Name import ErrUtils import BasicTypes - import Maybes ( allMaybes ) import Util import Outputable @@ -103,7 +102,7 @@ matchExpectedFunTys :: SDoc -- See Note [Herald for matchExpectedFunTys] -> Arity -> TcRhoType - -> TcM (CoercionI, [TcSigmaType], TcRhoType) + -> TcM (Coercion, [TcSigmaType], TcRhoType) -- If matchExpectFunTys n ty = (co, [t1,..,tn], ty_r) -- then co : ty ~ (t1 -> ... -> tn -> ty_r) @@ -122,7 +121,7 @@ -- then co : ty ~ t1 -> .. -> tn -> ty_r go n_req ty - | n_req == 0 = return (IdCo ty, [], ty) + | n_req == 0 = return (mkReflCo ty, [], ty) go n_req ty | Just ty' <- tcView ty = go n_req ty' @@ -130,7 +129,7 @@ go n_req (FunTy arg_ty res_ty) | not (isPredTy arg_ty) = do { (coi, tys, ty_r) <- go (n_req-1) res_ty - ; return (mkFunTyCoI (IdCo arg_ty) coi, arg_ty:tys, ty_r) } + ; return (mkFunCo (mkReflCo arg_ty) coi, arg_ty:tys, ty_r) } go _ (TyConApp tc _) -- A common case | not (isSynFamilyTyCon tc) @@ -173,14 +172,14 @@ \begin{code} ---------------------- -matchExpectedListTy :: TcRhoType -> TcM (CoercionI, TcRhoType) +matchExpectedListTy :: TcRhoType -> TcM (Coercion, TcRhoType) -- Special case for lists matchExpectedListTy exp_ty = do { (coi, [elt_ty]) <- matchExpectedTyConApp listTyCon exp_ty ; return (coi, elt_ty) } ---------------------- -matchExpectedPArrTy :: TcRhoType -> TcM (CoercionI, TcRhoType) +matchExpectedPArrTy :: TcRhoType -> TcM (Coercion, TcRhoType) -- Special case for parrs matchExpectedPArrTy exp_ty = do { (coi, [elt_ty]) <- matchExpectedTyConApp parrTyCon exp_ty @@ -189,7 +188,7 @@ ---------------------- matchExpectedTyConApp :: TyCon -- T :: k1 -> ... -> kn -> * -> TcRhoType -- orig_ty - -> TcM (CoercionI, -- T a b c ~ orig_ty + -> TcM (Coercion, -- T a b c ~ orig_ty [TcSigmaType]) -- Element types, a b c -- It's used for wired-in tycons, so we call checkWiredInTyCon @@ -200,7 +199,7 @@ = do { checkWiredInTyCon tc ; go (tyConArity tc) orig_ty [] } where - go :: Int -> TcRhoType -> [TcSigmaType] -> TcM (CoercionI, [TcSigmaType]) + go :: Int -> TcRhoType -> [TcSigmaType] -> TcM (Coercion, [TcSigmaType]) -- If go n ty tys = (co, [t1..tn] ++ tys) -- then co : T t1..tn ~ ty @@ -217,12 +216,12 @@ go n_req ty@(TyConApp tycon args) tys | tc == tycon = ASSERT( n_req == length args) -- ty::* - return (IdCo ty, args ++ tys) + return (mkReflCo ty, args ++ tys) go n_req (AppTy fun arg) tys | n_req > 0 = do { (coi, args) <- go (n_req - 1) fun (arg : tys) - ; return (mkAppTyCoI coi (IdCo arg), args) } + ; return (mkAppCo coi (mkReflCo arg), args) } go n_req ty tys = defer n_req ty tys @@ -236,7 +235,7 @@ ---------------------- matchExpectedAppTy :: TcRhoType -- orig_ty - -> TcM (CoercionI, -- m a ~ orig_ty + -> TcM (Coercion, -- m a ~ orig_ty (TcSigmaType, TcSigmaType)) -- Returns m, a -- If the incoming type is a mutable type variable of kind k, then -- matchExpectedAppTy returns a new type variable (m: * -> k); note the *. @@ -248,7 +247,7 @@ | Just ty' <- tcView ty = go ty' | Just (fun_ty, arg_ty) <- tcSplitAppTy_maybe ty - = return (IdCo orig_ty, (fun_ty, arg_ty)) + = return (mkReflCo orig_ty, (fun_ty, arg_ty)) go (TyVarTy tv) | ASSERT( isTcTyVar tv) isMetaTyVar tv @@ -306,14 +305,14 @@ <- tcGen ctxt ty_expected $ \ _ sk_rho -> do { (in_wrap, in_rho) <- deeplyInstantiate origin ty_actual ; coi <- unifyType in_rho sk_rho - ; return (coiToHsWrapper coi <.> in_wrap) } + ; return (coToHsWrapper coi <.> in_wrap) } ; return (sk_wrap <.> inst_wrap) } | otherwise -- Urgh! It seems deeply weird to have equality -- when actual is not a polytype, and it makes a big -- difference e.g. tcfail104 = do { coi <- unifyType ty_actual ty_expected - ; return (coiToHsWrapper coi) } + ; return (coToHsWrapper coi) } tcInfer :: (TcType -> TcM a) -> TcM (a, TcType) tcInfer tc_infer = do { ty <- newFlexiTyVarTy openTypeKind @@ -325,7 +324,7 @@ tcWrapResult expr actual_ty res_ty = do { coi <- unifyType actual_ty res_ty -- Both types are deeply skolemised - ; return (mkHsWrapCoI coi expr) } + ; return (mkHsWrapCo coi expr) } ----------------------------------- wrapFunResCoercion @@ -451,18 +450,18 @@ \begin{code} --------------- -unifyType :: TcTauType -> TcTauType -> TcM CoercionI +unifyType :: TcTauType -> TcTauType -> TcM Coercion -- Actual and expected types -- Returns a coercion : ty1 ~ ty2 unifyType ty1 ty2 = uType [] ty1 ty2 --------------- -unifyPred :: PredType -> PredType -> TcM CoercionI +unifyPred :: PredType -> PredType -> TcM Coercion -- Actual and expected types unifyPred p1 p2 = uPred [UnifyOrigin (mkPredTy p1) (mkPredTy p2)] p1 p2 --------------- -unifyTheta :: TcThetaType -> TcThetaType -> TcM [CoercionI] +unifyTheta :: TcThetaType -> TcThetaType -> TcM [Coercion] -- Actual and expected types unifyTheta theta1 theta2 = do { checkTc (equalLength theta1 theta2) @@ -513,7 +512,7 @@ :: [EqOrigin] -> TcType -- ty1 is the *actual* type -> TcType -- ty2 is the *expected* type - -> TcM CoercionI + -> TcM Coercion -------------- -- It is always safe to defer unification to the main constraint solver @@ -529,7 +528,7 @@ ; doc <- mkErrInfo emptyTidyEnv ctxt ; traceTc "utype_defer" (vcat [ppr co_var, ppr ty1, ppr ty2, ppr origin, doc]) - ; return $ ACo $ mkTyVarTy co_var } + ; return $ mkCoVarCo co_var } uType_defer [] _ _ = panic "uType_defer" @@ -544,16 +543,16 @@ = do { traceTc "u_tys " $ vcat [ sep [ ppr orig_ty1, text "~", ppr orig_ty2] , ppr origin] - ; coi <- go origin orig_ty1 orig_ty2 - ; case coi of - ACo co -> traceTc "u_tys yields coercion:" (ppr co) - IdCo _ -> traceTc "u_tys yields no coercion" empty + ; coi <- go orig_ty1 orig_ty2 + ; if isReflCo coi + then traceTc "u_tys yields no coercion" empty + else traceTc "u_tys yields coercion:" (ppr coi) ; return coi } where bale_out :: [EqOrigin] -> TcM a bale_out origin = failWithMisMatch origin - go :: [EqOrigin] -> TcType -> TcType -> TcM CoercionI + go :: TcType -> TcType -> TcM Coercion -- The arguments to 'go' are always semantically identical -- to orig_ty{1,2} except for looking through type synonyms @@ -561,68 +560,66 @@ -- Note that we pass in *original* (before synonym expansion), -- so that type variables tend to get filled in with -- the most informative version of the type - go origin (TyVarTy tyvar1) ty2 = uVar origin NotSwapped tyvar1 ty2 - go origin ty1 (TyVarTy tyvar2) = uVar origin IsSwapped tyvar2 ty1 + go (TyVarTy tyvar1) ty2 = uVar origin NotSwapped tyvar1 ty2 + go ty1 (TyVarTy tyvar2) = uVar origin IsSwapped tyvar2 ty1 -- Expand synonyms: -- see Note [Unification and synonyms] -- Do this after the variable case so that we tend to unify - -- variables with un-expended type synonym - go origin ty1 ty2 - | Just ty1' <- tcView ty1 = uType origin ty1' ty2 - | Just ty2' <- tcView ty2 = uType origin ty1 ty2' - + -- variables with un-expanded type synonym + -- + -- Also NB that we recurse to 'go' so that we don't push a + -- new item on the origin stack. As a result if we have + -- type Foo = Int + -- and we try to unify Foo ~ Bool + -- we'll end up saying "can't match Foo with Bool" + -- rather than "can't match "Int with Bool". See Trac #4535. + go ty1 ty2 + | Just ty1' <- tcView ty1 = go ty1' ty2 + | Just ty2' <- tcView ty2 = go ty1 ty2' + -- Predicates - go origin (PredTy p1) (PredTy p2) = uPred origin p1 p2 - - -- Coercion functions: (t1a ~ t1b) => t1c ~ (t2a ~ t2b) => t2c - go origin ty1 ty2 - | Just (t1a,t1b,t1c) <- splitCoPredTy_maybe ty1, - Just (t2a,t2b,t2c) <- splitCoPredTy_maybe ty2 - = do { co1 <- uType origin t1a t2a - ; co2 <- uType origin t1b t2b - ; co3 <- uType origin t1c t2c - ; return $ mkCoPredCoI co1 co2 co3 } + go (PredTy p1) (PredTy p2) = uPred origin p1 p2 -- Functions (or predicate functions) just check the two parts - go origin (FunTy fun1 arg1) (FunTy fun2 arg2) + go (FunTy fun1 arg1) (FunTy fun2 arg2) = do { coi_l <- uType origin fun1 fun2 ; coi_r <- uType origin arg1 arg2 - ; return $ mkFunTyCoI coi_l coi_r } + ; return $ mkFunCo coi_l coi_r } -- Always defer if a type synonym family (type function) -- is involved. (Data families behave rigidly.) - go origin ty1@(TyConApp tc1 _) ty2 + go ty1@(TyConApp tc1 _) ty2 | isSynFamilyTyCon tc1 = uType_defer origin ty1 ty2 - go origin ty1 ty2@(TyConApp tc2 _) + go ty1 ty2@(TyConApp tc2 _) | isSynFamilyTyCon tc2 = uType_defer origin ty1 ty2 - go origin (TyConApp tc1 tys1) (TyConApp tc2 tys2) + go (TyConApp tc1 tys1) (TyConApp tc2 tys2) | tc1 == tc2 -- See Note [TyCon app] = do { cois <- uList origin uType tys1 tys2 - ; return $ mkTyConAppCoI tc1 cois } + ; return $ mkTyConAppCo tc1 cois } -- See Note [Care with type applications] - go origin (AppTy s1 t1) ty2 + go (AppTy s1 t1) ty2 | Just (s2,t2) <- tcSplitAppTy_maybe ty2 = do { coi_s <- uType_np origin s1 s2 -- See Note [Unifying AppTy] ; coi_t <- uType origin t1 t2 - ; return $ mkAppTyCoI coi_s coi_t } + ; return $ mkAppCo coi_s coi_t } - go origin ty1 (AppTy s2 t2) + go ty1 (AppTy s2 t2) | Just (s1,t1) <- tcSplitAppTy_maybe ty1 = do { coi_s <- uType_np origin s1 s2 ; coi_t <- uType origin t1 t2 - ; return $ mkAppTyCoI coi_s coi_t } + ; return $ mkAppCo coi_s coi_t } - go _ ty1 ty2 + go ty1 ty2 | tcIsForAllTy ty1 || tcIsForAllTy ty2 = unifySigmaTy origin ty1 ty2 -- Anything else fails - go origin _ _ = bale_out origin + go _ _ = bale_out origin -unifySigmaTy :: [EqOrigin] -> TcType -> TcType -> TcM CoercionI +unifySigmaTy :: [EqOrigin] -> TcType -> TcType -> TcM Coercion unifySigmaTy origin ty1 ty2 = do { let (tvs1, body1) = tcSplitForAllTys ty1 (tvs2, body2) = tcSplitForAllTys ty2 @@ -631,9 +628,8 @@ -- Get location from monad, not from tvs1 ; let tys = mkTyVarTys skol_tvs in_scope = mkInScopeSet (mkVarSet skol_tvs) - phi1 = substTy (mkTvSubst in_scope (zipTyEnv tvs1 tys)) body1 - phi2 = substTy (mkTvSubst in_scope (zipTyEnv tvs2 tys)) body2 --- untch = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2 + phi1 = Type.substTy (mkTvSubst in_scope (zipTyEnv tvs1 tys)) body1 + phi2 = Type.substTy (mkTvSubst in_scope (zipTyEnv tvs2 tys)) body2 ; ((coi, _untch), lie) <- captureConstraints $ captureUntouchables $ @@ -648,23 +644,24 @@ (failWithMisMatch origin) -- ToDo: give details from bad_lie ; emitConstraints lie - ; return (foldr mkForAllTyCoI coi skol_tvs) } + ; return (foldr mkForAllCo coi skol_tvs) } ---------- -uPred :: [EqOrigin] -> PredType -> PredType -> TcM CoercionI +uPred :: [EqOrigin] -> PredType -> PredType -> TcM Coercion uPred origin (IParam n1 t1) (IParam n2 t2) | n1 == n2 = do { coi <- uType origin t1 t2 - ; return $ mkIParamPredCoI n1 coi } + ; return $ mkPredCo $ IParam n1 coi } uPred origin (ClassP c1 tys1) (ClassP c2 tys2) | c1 == c2 = do { cois <- uList origin uType tys1 tys2 -- Guaranteed equal lengths because the kinds check - ; return $ mkClassPPredCoI c1 cois } + ; return $ mkPredCo $ ClassP c1 cois } + uPred origin (EqPred ty1a ty1b) (EqPred ty2a ty2b) - = do { coia <- uType origin ty1a ty2a - ; coib <- uType origin ty1b ty2b - ; return $ mkEqPredCoI coia coib } + = do { coa <- uType origin ty1a ty2a + ; cob <- uType origin ty1b ty2b + ; return $ mkPredCo $ EqPred coa cob } uPred origin _ _ = failWithMisMatch origin @@ -808,7 +805,7 @@ back into @uTys@ if it turns out that the variable is already bound. \begin{code} -uVar :: [EqOrigin] -> SwapFlag -> TcTyVar -> TcTauType -> TcM CoercionI +uVar :: [EqOrigin] -> SwapFlag -> TcTyVar -> TcTauType -> TcM Coercion uVar origin swapped tv1 ty2 = do { traceTc "uVar" (vcat [ ppr origin , ppr swapped @@ -826,13 +823,13 @@ -> SwapFlag -> TcTyVar -> TcTyVarDetails -- Tyvar 1 -> TcTauType -- Type 2 - -> TcM CoercionI + -> TcM Coercion -- "Unfilled" means that the variable is definitely not a filled-in meta tyvar -- It might be a skolem, or untouchable, or meta uUnfilledVar origin swapped tv1 details1 (TyVarTy tv2) | tv1 == tv2 -- Same type variable => no-op - = return (IdCo (mkTyVarTy tv1)) + = return (mkReflCo (mkTyVarTy tv1)) | otherwise -- Distinct type variables = do { lookup2 <- lookupTcTyVar tv2 @@ -866,7 +863,7 @@ -> SwapFlag -> TcTyVar -> TcTyVarDetails -- Tyvar 1 -> TcTyVar -> TcTyVarDetails -- Tyvar 2 - -> TcM CoercionI + -> TcM Coercion -- Invarant: The type variables are distinct, -- Neither is filled in yet @@ -891,8 +888,8 @@ ty1 = mkTyVarTy tv1 ty2 = mkTyVarTy tv2 - nicer_to_update_tv1 _ (SigTv _) = True - nicer_to_update_tv1 (SigTv _) _ = False + nicer_to_update_tv1 _ SigTv = True + nicer_to_update_tv1 SigTv _ = False nicer_to_update_tv1 _ _ = isSystemName (Var.varName tv1) -- Try not to update SigTvs; and try to update sys-y type -- variables in preference to ones gotten (say) by @@ -1045,10 +1042,10 @@ details = ASSERT2( isTcTyVar tyvar, ppr tyvar ) tcTyVarDetails tyvar -updateMeta :: TcTyVar -> TcRef MetaDetails -> TcType -> TcM CoercionI +updateMeta :: TcTyVar -> TcRef MetaDetails -> TcType -> TcM Coercion updateMeta tv1 ref1 ty2 = do { writeMetaTyVarRef tv1 ref1 ty2 - ; return (IdCo ty2) } + ; return (mkReflCo ty2) } \end{code} Note [Unifying untouchables] diff -Nru ghc-7.0.3/compiler/typecheck/TcUnify.lhs-boot ghc-7.2.1/compiler/typecheck/TcUnify.lhs-boot --- ghc-7.0.3/compiler/typecheck/TcUnify.lhs-boot 2011-03-26 18:10:04.000000000 +0000 +++ ghc-7.2.1/compiler/typecheck/TcUnify.lhs-boot 2011-08-07 17:10:05.000000000 +0000 @@ -2,10 +2,10 @@ module TcUnify where import TcType ( TcTauType ) import TcRnTypes( TcM ) -import Coercion (CoercionI) +import Coercion (Coercion) -- This boot file exists only to tie the knot between -- TcUnify and TcSimplify -unifyType :: TcTauType -> TcTauType -> TcM CoercionI +unifyType :: TcTauType -> TcTauType -> TcM Coercion \end{code} diff -Nru ghc-7.0.3/compiler/types/Class.lhs ghc-7.2.1/compiler/types/Class.lhs --- ghc-7.0.3/compiler/types/Class.lhs 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/types/Class.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -13,7 +13,7 @@ FunDep, pprFundeps, pprFunDep, - mkClass, classTyVars, classArity, classSCNEqs, + mkClass, classTyVars, classArity, classKey, className, classATs, classTyCon, classMethods, classOpItems, classBigSig, classExtraBigSig, classTvsFds, classSCTheta, classAllSelIds, classSCSelId @@ -33,6 +33,7 @@ import Outputable import FastString +import Data.Typeable hiding (TyCon) import qualified Data.Data as Data \end{code} @@ -57,20 +58,19 @@ -- We need value-level selectors for the dictionary -- superclasses, but not for the equality superclasses classSCTheta :: [PredType], -- Immediate superclasses, - --- *with equalities first* - classSCNEqs :: Int, -- How many equalities classSCSels :: [Id], -- Selector functions to extract the - -- *dictionary* superclasses from a + -- superclasses from a -- dictionary of this class -- Associated types classATs :: [TyCon], -- Associated type families - -- Class operations + -- Class operations (methods, not superclasses) classOpStuff :: [ClassOpItem], -- Ordered by tag classTyCon :: TyCon -- The data type constructor for -- dictionaries of this class } + deriving Typeable type FunDep a = ([a],[a]) -- e.g. class C a b c | a b -> c, a c -> b where... -- Here fun-deps are [([a,b],[c]), ([a,c],[b])] @@ -81,7 +81,7 @@ data DefMeth = NoDefMeth -- No default method | DefMeth Name -- A polymorphic default method - | GenDefMeth -- A generic default method + | GenDefMeth Name -- A generic default method deriving Eq -- | Convert a `DefMethSpec` to a `DefMeth`, which discards the name field in @@ -91,7 +91,7 @@ = case meth of NoDefMeth -> NoDM DefMeth _ -> VanillaDM - GenDefMeth -> GenericDM + GenDefMeth _ -> GenericDM \end{code} @@ -100,20 +100,19 @@ \begin{code} mkClass :: Name -> [TyVar] -> [([TyVar], [TyVar])] - -> [PredType] -> Int -> [Id] + -> [PredType] -> [Id] -> [TyCon] -> [ClassOpItem] -> TyCon -> Class -mkClass name tyvars fds super_classes n_eqs superdict_sels ats +mkClass name tyvars fds super_classes superdict_sels ats op_stuff tycon = Class { classKey = getUnique name, className = name, classTyVars = tyvars, classFunDeps = fds, classSCTheta = super_classes, - classSCNEqs = n_eqs, classSCSels = superdict_sels, classATs = ats, classOpStuff = op_stuff, @@ -142,11 +141,9 @@ -- Get the n'th superclass selector Id -- where n is 0-indexed, and counts -- *all* superclasses including equalities -classSCSelId (Class { classSCNEqs = n_eqs, classSCSels = sc_sels }) n - = ASSERT( sc_sel_index >= 0 && sc_sel_index < length sc_sels ) - sc_sels !! sc_sel_index - where - sc_sel_index = n - n_eqs -- 0-index into classSCSels +classSCSelId (Class { classSCSels = sc_sels }) n + = ASSERT( n >= 0 && n < length sc_sels ) + sc_sels !! n classMethods :: Class -> [Id] classMethods (Class {classOpStuff = op_stuff}) @@ -208,9 +205,9 @@ showsPrec p c = showsPrecSDoc p (ppr c) instance Outputable DefMeth where - ppr (DefMeth n) = ptext (sLit "Default method") <+> ppr n - ppr GenDefMeth = ptext (sLit "Generic default method") - ppr NoDefMeth = empty -- No default method + ppr (DefMeth n) = ptext (sLit "Default method") <+> ppr n + ppr (GenDefMeth n) = ptext (sLit "Generic default method") <+> ppr n + ppr NoDefMeth = empty -- No default method pprFundeps :: Outputable a => [FunDep a] -> SDoc pprFundeps [] = empty @@ -219,9 +216,6 @@ pprFunDep :: Outputable a => FunDep a -> SDoc pprFunDep (us, vs) = hsep [interppSP us, ptext (sLit "->"), interppSP vs] -instance Data.Typeable Class where - typeOf _ = Data.mkTyConApp (Data.mkTyCon "Class") [] - instance Data.Data Class where -- don't traverse? toConstr _ = abstractConstr "Class" diff -Nru ghc-7.0.3/compiler/types/Coercion.lhs ghc-7.2.1/compiler/types/Coercion.lhs --- ghc-7.0.3/compiler/types/Coercion.lhs 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/types/Coercion.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -7,15 +7,9 @@ -- as used in System FC. See 'CoreSyn.Expr' for -- more on System FC and how coercions fit into it. -- --- Coercions are represented as types, and their kinds tell what types the --- coercion works on. The coercion kind constructor is a special TyCon that --- must always be saturated, like so: --- --- > typeKind (symCoercion type) :: TyConApp CoTyCon{...} [type, type] module Coercion ( -- * Main data type - Coercion, Kind, - typeKind, + Coercion(..), Var, CoVar, -- ** Deconstructing Kinds kindFunResult, kindAppResult, synTyConResKind, @@ -24,237 +18,454 @@ -- ** Predicates on Kinds isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind, isUbxTupleKind, isArgTypeKind, isKind, isTySuperKind, - isCoSuperKind, isSuperKind, isCoercionKind, + isSuperKind, isCoercionKind, mkArrowKind, mkArrowKinds, isSubArgTypeKind, isSubOpenTypeKind, isSubKind, defaultKind, eqKind, isSubKindCon, - mkCoKind, mkCoPredTy, coVarKind, coVarKind_maybe, - coercionKind, coercionKinds, isIdentityCoercion, - - -- ** Equality predicates - isEqPred, mkEqPred, getEqPredTys, isEqPredTy, + mkCoType, coVarKind, coVarKind_maybe, + coercionType, coercionKind, coercionKinds, isReflCo, - -- ** Coercion transformations - mkCoercion, - mkSymCoercion, mkTransCoercion, - mkLeftCoercion, mkRightCoercion, - mkInstCoercion, mkAppCoercion, mkTyConCoercion, mkFunCoercion, - mkForAllCoercion, mkInstsCoercion, mkUnsafeCoercion, - mkNewTypeCoercion, mkFamInstCoercion, mkAppsCoercion, - mkCsel1Coercion, mkCsel2Coercion, mkCselRCoercion, - - mkClassPPredCo, mkIParamPredCo, mkEqPredCo, - mkCoVarCoercion, mkCoPredCo, - - - unsafeCoercionTyCon, symCoercionTyCon, - transCoercionTyCon, leftCoercionTyCon, - rightCoercionTyCon, instCoercionTyCon, -- needed by TysWiredIn - csel1CoercionTyCon, csel2CoercionTyCon, cselRCoercionTyCon, + -- ** Constructing coercions + mkReflCo, mkCoVarCo, + mkAxInstCo, mkPiCo, mkPiCos, + mkSymCo, mkTransCo, mkNthCo, + mkInstCo, mkAppCo, mkTyConAppCo, mkFunCo, + mkForAllCo, mkUnsafeCo, + mkNewTypeCo, mkFamInstCo, + mkPredCo, -- ** Decomposition - decompLR_maybe, decompCsel_maybe, decompInst_maybe, splitCoPredTy_maybe, splitNewTypeRepCo_maybe, instNewTyCon_maybe, decomposeCo, + getCoVar_maybe, + splitTyConAppCo_maybe, + splitAppCo_maybe, + splitForAllCo_maybe, + + -- ** Coercion variables + mkCoVar, isCoVar, isCoVarType, coVarName, setCoVarName, setCoVarUnique, + + -- ** Free variables + tyCoVarsOfCo, tyCoVarsOfCos, coVarsOfCo, coercionSize, + + -- ** Substitution + CvSubstEnv, emptyCvSubstEnv, + CvSubst(..), emptyCvSubst, Coercion.lookupTyVar, lookupCoVar, + isEmptyCvSubst, zapCvSubstEnv, getCvInScope, + substCo, substCos, substCoVar, substCoVars, + substCoWithTy, substCoWithTys, + cvTvSubst, tvCvSubst, zipOpenCvSubst, + substTy, extendTvSubst, + substTyVarBndr, substCoVarBndr, + + -- ** Lifting + liftCoMatch, liftCoSubst, liftCoSubstTyVar, liftCoSubstWith, + -- ** Comparison coreEqCoercion, coreEqCoercion2, - -- * CoercionI - CoercionI(..), - isIdentityCoI, - mkSymCoI, mkTransCoI, - mkTyConAppCoI, mkAppTyCoI, mkFunTyCoI, - mkForAllTyCoI, - fromCoI, - mkClassPPredCoI, mkIParamPredCoI, mkEqPredCoI, mkCoPredCoI - + -- ** Forcing evaluation of coercions + seqCo, + + -- * Pretty-printing + pprCo, pprParendCo, pprCoAxiom, + + -- * Other + applyCo, coVarPred + ) where #include "HsVersions.h" +import Unify ( MatchEnv(..), ruleMatchTyX, matchList ) import TypeRep -import Type +import qualified Type +import Type hiding( substTy, substTyVarBndr, extendTvSubst ) +import Kind +import Class ( classTyCon ) import TyCon -import Class import Var import VarEnv import VarSet -import Name -import PrelNames +import UniqFM ( minusUFM ) +import Maybes ( orElse ) +import Name ( Name, NamedThing(..), nameUnique ) +import OccName ( isSymOcc ) import Util import BasicTypes import Outputable +import Unique +import Pair +import TysPrim ( eqPredPrimTyCon ) +import PrelNames ( funTyConKey ) +import Control.Applicative +import Data.Traversable (traverse, sequenceA) +import Control.Arrow (second) import FastString + +import qualified Data.Data as Data hiding ( TyCon ) \end{code} %************************************************************************ %* * - Functions over Kinds + Coercions %* * %************************************************************************ \begin{code} --- | Essentially 'funResultTy' on kinds -kindFunResult :: Kind -> Kind -kindFunResult k = funResultTy k - -kindAppResult :: Kind -> [arg] -> Kind -kindAppResult k [] = k -kindAppResult k (_:as) = kindAppResult (kindFunResult k) as - --- | Essentially 'splitFunTys' on kinds -splitKindFunTys :: Kind -> ([Kind],Kind) -splitKindFunTys k = splitFunTys k - -splitKindFunTy_maybe :: Kind -> Maybe (Kind,Kind) -splitKindFunTy_maybe = splitFunTy_maybe - --- | Essentially 'splitFunTysN' on kinds -splitKindFunTysN :: Int -> Kind -> ([Kind],Kind) -splitKindFunTysN k = splitFunTysN k - --- | Find the result 'Kind' of a type synonym, --- after applying it to its 'arity' number of type variables --- Actually this function works fine on data types too, --- but they'd always return '*', so we never need to ask -synTyConResKind :: TyCon -> Kind -synTyConResKind tycon = kindAppResult (tyConKind tycon) (tyConTyVars tycon) - --- | See "Type#kind_subtyping" for details of the distinction between these 'Kind's -isUbxTupleKind, isOpenTypeKind, isArgTypeKind, isUnliftedTypeKind :: Kind -> Bool -isOpenTypeKindCon, isUbxTupleKindCon, isArgTypeKindCon, - isUnliftedTypeKindCon, isSubArgTypeKindCon :: TyCon -> Bool - -isOpenTypeKindCon tc = tyConUnique tc == openTypeKindTyConKey - -isOpenTypeKind (TyConApp tc _) = isOpenTypeKindCon tc -isOpenTypeKind _ = False - -isUbxTupleKindCon tc = tyConUnique tc == ubxTupleKindTyConKey - -isUbxTupleKind (TyConApp tc _) = isUbxTupleKindCon tc -isUbxTupleKind _ = False - -isArgTypeKindCon tc = tyConUnique tc == argTypeKindTyConKey - -isArgTypeKind (TyConApp tc _) = isArgTypeKindCon tc -isArgTypeKind _ = False - -isUnliftedTypeKindCon tc = tyConUnique tc == unliftedTypeKindTyConKey - -isUnliftedTypeKind (TyConApp tc _) = isUnliftedTypeKindCon tc -isUnliftedTypeKind _ = False - -isSubOpenTypeKind :: Kind -> Bool --- ^ True of any sub-kind of OpenTypeKind (i.e. anything except arrow) -isSubOpenTypeKind (FunTy k1 k2) = ASSERT2 ( isKind k1, text "isSubOpenTypeKind" <+> ppr k1 <+> text "::" <+> ppr (typeKind k1) ) - ASSERT2 ( isKind k2, text "isSubOpenTypeKind" <+> ppr k2 <+> text "::" <+> ppr (typeKind k2) ) - False -isSubOpenTypeKind (TyConApp kc []) = ASSERT( isKind (TyConApp kc []) ) True -isSubOpenTypeKind other = ASSERT( isKind other ) False - -- This is a conservative answer - -- It matters in the call to isSubKind in - -- checkExpectedKind. - -isSubArgTypeKindCon kc - | isUnliftedTypeKindCon kc = True - | isLiftedTypeKindCon kc = True - | isArgTypeKindCon kc = True - | otherwise = False - -isSubArgTypeKind :: Kind -> Bool --- ^ True of any sub-kind of ArgTypeKind -isSubArgTypeKind (TyConApp kc []) = isSubArgTypeKindCon kc -isSubArgTypeKind _ = False - --- | Is this a super-kind (i.e. a type-of-kinds)? -isSuperKind :: Type -> Bool -isSuperKind (TyConApp (skc) []) = isSuperKindTyCon skc -isSuperKind _ = False - --- | Is this a kind (i.e. a type-of-types)? -isKind :: Kind -> Bool -isKind k = isSuperKind (typeKind k) - -isSubKind :: Kind -> Kind -> Bool --- ^ @k1 \`isSubKind\` k2@ checks that @k1@ <: @k2@ -isSubKind (TyConApp kc1 []) (TyConApp kc2 []) = kc1 `isSubKindCon` kc2 -isSubKind (FunTy a1 r1) (FunTy a2 r2) = (a2 `isSubKind` a1) && (r1 `isSubKind` r2) -isSubKind (PredTy (EqPred ty1 ty2)) (PredTy (EqPred ty1' ty2')) - = ty1 `tcEqType` ty1' && ty2 `tcEqType` ty2' -isSubKind _ _ = False - -eqKind :: Kind -> Kind -> Bool -eqKind = tcEqType - -isSubKindCon :: TyCon -> TyCon -> Bool --- ^ @kc1 \`isSubKindCon\` kc2@ checks that @kc1@ <: @kc2@ -isSubKindCon kc1 kc2 - | isLiftedTypeKindCon kc1 && isLiftedTypeKindCon kc2 = True - | isUnliftedTypeKindCon kc1 && isUnliftedTypeKindCon kc2 = True - | isUbxTupleKindCon kc1 && isUbxTupleKindCon kc2 = True - | isOpenTypeKindCon kc2 = True - -- we already know kc1 is not a fun, its a TyCon - | isArgTypeKindCon kc2 && isSubArgTypeKindCon kc1 = True - | otherwise = False - -defaultKind :: Kind -> Kind --- ^ Used when generalising: default kind ? and ?? to *. See "Type#kind_subtyping" for more --- information on what that means - --- When we generalise, we make generic type variables whose kind is --- simple (* or *->* etc). So generic type variables (other than --- built-in constants like 'error') always have simple kinds. This is important; --- consider --- f x = True --- We want f to get type --- f :: forall (a::*). a -> Bool --- Not --- f :: forall (a::??). a -> Bool --- because that would allow a call like (f 3#) as well as (f True), ---and the calling conventions differ. This defaulting is done in TcMType.zonkTcTyVarBndr. -defaultKind k - | isSubOpenTypeKind k = liftedTypeKind - | isSubArgTypeKind k = liftedTypeKind - | otherwise = k +-- | A 'Coercion' is concrete evidence of the equality/convertibility +-- of two types. + +data Coercion + -- These ones mirror the shape of types + = Refl Type -- See Note [Refl invariant] + -- Invariant: applications of (Refl T) to a bunch of identity coercions + -- always show up as Refl. + -- For example (Refl T) (Refl a) (Refl b) shows up as (Refl (T a b)). + + -- Applications of (Refl T) to some coercions, at least one of + -- which is NOT the identity, show up as TyConAppCo. + -- (They may not be fully saturated however.) + -- ConAppCo coercions (like all coercions other than Refl) + -- are NEVER the identity. + + -- These ones simply lift the correspondingly-named + -- Type constructors into Coercions + | TyConAppCo TyCon [Coercion] -- lift TyConApp + -- The TyCon is never a synonym; + -- we expand synonyms eagerly + + | AppCo Coercion Coercion -- lift AppTy + + -- See Note [Forall coercions] + | ForAllCo TyVar Coercion -- forall a. g + + -- These are special + | CoVarCo CoVar + | AxiomInstCo CoAxiom [Coercion] -- The coercion arguments always *precisely* + -- saturate arity of CoAxiom. + -- See [Coercion axioms applied to coercions] + | UnsafeCo Type Type + | SymCo Coercion + | TransCo Coercion Coercion + + -- These are destructors + | NthCo Int Coercion -- Zero-indexed + | InstCo Coercion Type + deriving (Data.Data, Data.Typeable) \end{code} +Note [Refl invariant] +~~~~~~~~~~~~~~~~~~~~~ +Coercions have the following invariant + Refl is always lifted as far as possible. + +You might think that a consequencs is: + Every identity coercions has Refl at the root + +But that's not quite true because of coercion variables. Consider + g where g :: Int~Int + Left h where h :: Maybe Int ~ Maybe Int +etc. So the consequence is only true of coercions that +have no coercion variables. + +Note [Coercion axioms applied to coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The reason coercion axioms can be applied to coercions and not just +types is to allow for better optimization. There are some cases where +we need to be able to "push transitivity inside" an axiom in order to +expose further opportunities for optimization. + +For example, suppose we have + + C a : t[a] ~ F a + g : b ~ c + +and we want to optimize + + sym (C b) ; t[g] ; C c + +which has the kind + + F b ~ F c + +(stopping through t[b] and t[c] along the way). + +We'd like to optimize this to just F g -- but how? The key is +that we need to allow axioms to be instantiated by *coercions*, +not just by types. Then we can (in certain cases) push +transitivity inside the axiom instantiations, and then react +opposite-polarity instantiations of the same axiom. In this +case, e.g., we match t[g] against the LHS of (C c)'s kind, to +obtain the substitution a |-> g (note this operation is sort +of the dual of lifting!) and hence end up with + + C g : t[b] ~ F c + +which indeed has the same kind as t[g] ; C c. + +Now we have + + sym (C b) ; C g + +which can be optimized to F g. + + +Note [Forall coercions] +~~~~~~~~~~~~~~~~~~~~~~~ +Constructing coercions between forall-types can be a bit tricky. +Currently, the situation is as follows: + + ForAllCo TyVar Coercion + +represents a coercion between polymorphic types, with the rule + + v : k g : t1 ~ t2 + ---------------------------------------------- + ForAllCo v g : (all v:k . t1) ~ (all v:k . t2) + +Note that it's only necessary to coerce between polymorphic types +where the type variables have identical kinds, because equality on +kinds is trivial. + +Note [Predicate coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +Suppose we have + g :: a~b +How can we coerce between types + ([c]~a) => [a] -> c +and + ([c]~b) => [b] -> c +where the equality predicate *itself* differs? + +Answer: we simply treat (~) as an ordinary type constructor, so these +types really look like + + ((~) [c] a) -> [a] -> c + ((~) [c] b) -> [b] -> c + +So the coercion between the two is obviously + + ((~) [c] g) -> [g] -> c + +Another way to see this to say that we simply collapse predicates to +their representation type (see Type.coreView and Type.predTypeRep). + +This collapse is done by mkPredCo; there is no PredCo constructor +in Coercion. This is important because we need Nth to work on +predicates too: + Nth 1 ((~) [c] g) = g +See Simplify.simplCoercionF, which generates such selections. + %************************************************************************ %* * - Coercions +\subsection{Coercion variables} %* * %************************************************************************ +\begin{code} +coVarName :: CoVar -> Name +coVarName = varName + +setCoVarUnique :: CoVar -> Unique -> CoVar +setCoVarUnique = setVarUnique + +setCoVarName :: CoVar -> Name -> CoVar +setCoVarName = setVarName + +isCoVar :: Var -> Bool +isCoVar v = isCoVarType (varType v) + +isCoVarType :: Type -> Bool +isCoVarType = isEqPredTy +\end{code} + \begin{code} --- | A 'Coercion' represents a 'Type' something should be coerced to. -type Coercion = Type +tyCoVarsOfCo :: Coercion -> VarSet +-- Extracts type and coercion variables from a coercion +tyCoVarsOfCo (Refl ty) = tyVarsOfType ty +tyCoVarsOfCo (TyConAppCo _ cos) = tyCoVarsOfCos cos +tyCoVarsOfCo (AppCo co1 co2) = tyCoVarsOfCo co1 `unionVarSet` tyCoVarsOfCo co2 +tyCoVarsOfCo (ForAllCo tv co) = tyCoVarsOfCo co `delVarSet` tv +tyCoVarsOfCo (CoVarCo v) = unitVarSet v +tyCoVarsOfCo (AxiomInstCo _ cos) = tyCoVarsOfCos cos +tyCoVarsOfCo (UnsafeCo ty1 ty2) = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2 +tyCoVarsOfCo (SymCo co) = tyCoVarsOfCo co +tyCoVarsOfCo (TransCo co1 co2) = tyCoVarsOfCo co1 `unionVarSet` tyCoVarsOfCo co2 +tyCoVarsOfCo (NthCo _ co) = tyCoVarsOfCo co +tyCoVarsOfCo (InstCo co ty) = tyCoVarsOfCo co `unionVarSet` tyVarsOfType ty + +tyCoVarsOfCos :: [Coercion] -> VarSet +tyCoVarsOfCos cos = foldr (unionVarSet . tyCoVarsOfCo) emptyVarSet cos + +coVarsOfCo :: Coercion -> VarSet +-- Extract *coerction* variables only. Tiresome to repeat the code, but easy. +coVarsOfCo (Refl _) = emptyVarSet +coVarsOfCo (TyConAppCo _ cos) = coVarsOfCos cos +coVarsOfCo (AppCo co1 co2) = coVarsOfCo co1 `unionVarSet` coVarsOfCo co2 +coVarsOfCo (ForAllCo _ co) = coVarsOfCo co +coVarsOfCo (CoVarCo v) = unitVarSet v +coVarsOfCo (AxiomInstCo _ cos) = coVarsOfCos cos +coVarsOfCo (UnsafeCo _ _) = emptyVarSet +coVarsOfCo (SymCo co) = coVarsOfCo co +coVarsOfCo (TransCo co1 co2) = coVarsOfCo co1 `unionVarSet` coVarsOfCo co2 +coVarsOfCo (NthCo _ co) = coVarsOfCo co +coVarsOfCo (InstCo co _) = coVarsOfCo co + +coVarsOfCos :: [Coercion] -> VarSet +coVarsOfCos cos = foldr (unionVarSet . coVarsOfCo) emptyVarSet cos + +coercionSize :: Coercion -> Int +coercionSize (Refl ty) = typeSize ty +coercionSize (TyConAppCo _ cos) = 1 + sum (map coercionSize cos) +coercionSize (AppCo co1 co2) = coercionSize co1 + coercionSize co2 +coercionSize (ForAllCo _ co) = 1 + coercionSize co +coercionSize (CoVarCo _) = 1 +coercionSize (AxiomInstCo _ cos) = 1 + sum (map coercionSize cos) +coercionSize (UnsafeCo ty1 ty2) = typeSize ty1 + typeSize ty2 +coercionSize (SymCo co) = 1 + coercionSize co +coercionSize (TransCo co1 co2) = 1 + coercionSize co1 + coercionSize co2 +coercionSize (NthCo _ co) = 1 + coercionSize co +coercionSize (InstCo co ty) = 1 + coercionSize co + typeSize ty +\end{code} --- | A 'CoercionKind' is always of form @ty1 ~ ty2@ and indicates the --- types that a 'Coercion' will work on. -type CoercionKind = Kind +%************************************************************************ +%* * + Pretty-printing coercions +%* * +%************************************************************************ + +@pprCo@ is the standard @Coercion@ printer; the overloaded @ppr@ +function is defined to use this. @pprParendCo@ is the same, except it +puts parens around the type, except for the atomic cases. +@pprParendCo@ works just by setting the initial context precedence +very high. + +\begin{code} +instance Outputable Coercion where + ppr = pprCo + +pprCo, pprParendCo :: Coercion -> SDoc +pprCo co = ppr_co TopPrec co +pprParendCo co = ppr_co TyConPrec co + +ppr_co :: Prec -> Coercion -> SDoc +ppr_co _ (Refl ty) = angles (ppr ty) + +ppr_co p co@(TyConAppCo tc cos) + | tc `hasKey` funTyConKey = ppr_fun_co p co + | otherwise = pprTcApp p ppr_co tc cos + +ppr_co p (AppCo co1 co2) = maybeParen p TyConPrec $ + pprCo co1 <+> ppr_co TyConPrec co2 + +ppr_co p co@(ForAllCo {}) = ppr_forall_co p co + +ppr_co _ (CoVarCo cv) + | isSymOcc (getOccName cv) = parens (ppr cv) + | otherwise = ppr cv ------------------------------- +ppr_co p (AxiomInstCo con cos) = pprTypeNameApp p ppr_co (getName con) cos --- | This breaks a 'Coercion' with 'CoercionKind' @T A B C ~ T D E F@ into + +ppr_co p (TransCo co1 co2) = maybeParen p FunPrec $ + ppr_co FunPrec co1 + <+> ptext (sLit ";") + <+> ppr_co FunPrec co2 +ppr_co p (InstCo co ty) = maybeParen p TyConPrec $ + pprParendCo co <> ptext (sLit "@") <> pprType ty + +ppr_co p (UnsafeCo ty1 ty2) = pprPrefixApp p (ptext (sLit "UnsafeCo")) [pprParendType ty1, pprParendType ty2] +ppr_co p (SymCo co) = pprPrefixApp p (ptext (sLit "Sym")) [pprParendCo co] +ppr_co p (NthCo n co) = pprPrefixApp p (ptext (sLit "Nth:") <+> int n) [pprParendCo co] + + +angles :: SDoc -> SDoc +angles p = char '<' <> p <> char '>' + +ppr_fun_co :: Prec -> Coercion -> SDoc +ppr_fun_co p co = pprArrowChain p (split co) + where + split (TyConAppCo f [arg,res]) + | f `hasKey` funTyConKey + = ppr_co FunPrec arg : split res + split co = [ppr_co TopPrec co] + +ppr_forall_co :: Prec -> Coercion -> SDoc +ppr_forall_co p ty + = maybeParen p FunPrec $ + sep [pprForAll tvs, ppr_co TopPrec rho] + where + (tvs, rho) = split1 [] ty + split1 tvs (ForAllCo tv ty) = split1 (tv:tvs) ty + split1 tvs ty = (reverse tvs, ty) +\end{code} + +\begin{code} +pprCoAxiom :: CoAxiom -> SDoc +pprCoAxiom ax + = sep [ ptext (sLit "axiom") <+> ppr ax <+> ppr (co_ax_tvs ax) + , nest 2 (dcolon <+> pprEqPred (Pair (co_ax_lhs ax) (co_ax_rhs ax))) ] +\end{code} + +%************************************************************************ +%* * + Functions over Kinds +%* * +%************************************************************************ + +\begin{code} +-- | This breaks a 'Coercion' with type @T A B C ~ T D E F@ into -- a list of 'Coercion's of kinds @A ~ D@, @B ~ E@ and @E ~ F@. Hence: -- --- > decomposeCo 3 c = [right (left (left c)), right (left c), right c] +-- > decomposeCo 3 c = [nth 0 c, nth 1 c, nth 2 c] decomposeCo :: Arity -> Coercion -> [Coercion] -decomposeCo n co - = go n co [] - where - go 0 _ cos = cos - go n co cos = go (n-1) (mkLeftCoercion co) - (mkRightCoercion co : cos) +decomposeCo arity co = [mkNthCo n co | n <- [0..(arity-1)] ] +-- | Attempts to obtain the type variable underlying a 'Coercion' +getCoVar_maybe :: Coercion -> Maybe CoVar +getCoVar_maybe (CoVarCo cv) = Just cv +getCoVar_maybe _ = Nothing + +-- | Attempts to tease a coercion apart into a type constructor and the application +-- of a number of coercion arguments to that constructor +splitTyConAppCo_maybe :: Coercion -> Maybe (TyCon, [Coercion]) +splitTyConAppCo_maybe (Refl ty) = (fmap . second . map) Refl (splitTyConApp_maybe ty) +splitTyConAppCo_maybe (TyConAppCo tc cos) = Just (tc, cos) +splitTyConAppCo_maybe _ = Nothing + +splitAppCo_maybe :: Coercion -> Maybe (Coercion, Coercion) +-- ^ Attempt to take a coercion application apart. +splitAppCo_maybe (AppCo co1 co2) = Just (co1, co2) +splitAppCo_maybe (TyConAppCo tc cos) + | isDecomposableTyCon tc || cos `lengthExceeds` tyConArity tc + , Just (cos', co') <- snocView cos + = Just (mkTyConAppCo tc cos', co') -- Never create unsaturated type family apps! + -- Use mkTyConAppCo to preserve the invariant + -- that identity coercions are always represented by Refl +splitAppCo_maybe (Refl ty) + | Just (ty1, ty2) <- splitAppTy_maybe ty + = Just (Refl ty1, Refl ty2) +splitAppCo_maybe _ = Nothing + +splitForAllCo_maybe :: Coercion -> Maybe (TyVar, Coercion) +splitForAllCo_maybe (ForAllCo tv co) = Just (tv, co) +splitForAllCo_maybe _ = Nothing ------------------------------------------------------- -- and some coercion kind stuff +coVarPred :: CoVar -> PredType +coVarPred cv + = ASSERT( isCoVar cv ) + case splitPredTy_maybe (varType cv) of + Just pred -> pred + other -> pprPanic "coVarPred" (ppr cv $$ ppr other) + coVarKind :: CoVar -> (Type,Type) -- c :: t1 ~ t2 coVarKind cv = case coVarKind_maybe cv of @@ -262,31 +473,12 @@ Nothing -> pprPanic "coVarKind" (ppr cv $$ ppr (tyVarKind cv)) coVarKind_maybe :: CoVar -> Maybe (Type,Type) -coVarKind_maybe cv = splitCoKind_maybe (tyVarKind cv) - --- | Take a 'CoercionKind' apart into the two types it relates: see also 'mkCoKind'. --- Panics if the argument is not a valid 'CoercionKind' -splitCoKind_maybe :: Kind -> Maybe (Type, Type) -splitCoKind_maybe co | Just co' <- kindView co = splitCoKind_maybe co' -splitCoKind_maybe (PredTy (EqPred ty1 ty2)) = Just (ty1, ty2) -splitCoKind_maybe _ = Nothing +coVarKind_maybe cv = splitEqPredTy_maybe (varType cv) --- | Makes a 'CoercionKind' from two types: the types whose equality +-- | Makes a coercion type from two types: the types whose equality -- is proven by the relevant 'Coercion' -mkCoKind :: Type -> Type -> CoercionKind -mkCoKind ty1 ty2 = PredTy (EqPred ty1 ty2) - --- | (mkCoPredTy s t r) produces the type: (s~t) => r -mkCoPredTy :: Type -> Type -> Type -> Type -mkCoPredTy s t r = ASSERT( not (co_var `elemVarSet` tyVarsOfType r) ) - ForAllTy co_var r - where - co_var = mkWildCoVar (mkCoKind s t) - -mkCoPredCo :: Coercion -> Coercion -> Coercion -> Coercion --- Creates a coercion between (s1~t1) => r1 and (s2~t2) => r2 -mkCoPredCo = mkCoPredTy - +mkCoType :: Type -> Type -> Type +mkCoType ty1 ty2 = PredTy (EqPred ty1 ty2) splitCoPredTy_maybe :: Type -> Maybe (Type, Type, Type) splitCoPredTy_maybe ty @@ -297,25 +489,13 @@ | otherwise = Nothing --- | Tests whether a type is just a type equality predicate -isEqPredTy :: Type -> Bool -isEqPredTy (PredTy pred) = isEqPred pred -isEqPredTy _ = False - --- | Creates a type equality predicate -mkEqPred :: (Type, Type) -> PredType -mkEqPred (ty1, ty2) = EqPred ty1 ty2 - --- | Splits apart a type equality predicate, if the supplied 'PredType' is one. --- Panics otherwise -getEqPredTys :: PredType -> (Type,Type) -getEqPredTys (EqPred ty1 ty2) = (ty1, ty2) -getEqPredTys other = pprPanic "getEqPredTys" (ppr other) - -isIdentityCoercion :: Coercion -> Bool -isIdentityCoercion co - = case coercionKind co of - (t1,t2) -> t1 `coreEqType` t2 +isReflCo :: Coercion -> Bool +isReflCo (Refl {}) = True +isReflCo _ = False + +isReflCo_maybe :: Coercion -> Maybe Type +isReflCo_maybe (Refl ty) = Just ty +isReflCo_maybe _ = Nothing \end{code} %************************************************************************ @@ -324,236 +504,155 @@ %* * %************************************************************************ -Coercion kind and type mk's (make saturated TyConApp CoercionTyCon{...} args) - \begin{code} --- | Make a coercion from the specified coercion 'TyCon' and the 'Type' arguments to --- that coercion. Try to use the @mk*Coercion@ family of functions instead of using this function --- if possible -mkCoercion :: TyCon -> [Type] -> Coercion -mkCoercion coCon args = ASSERT( tyConArity coCon == length args ) - TyConApp coCon args - -mkCoVarCoercion :: CoVar -> Coercion -mkCoVarCoercion cv = mkTyVarTy cv - --- | Apply a 'Coercion' to another 'Coercion', which is presumably a --- 'Coercion' constructor of some kind -mkAppCoercion :: Coercion -> Coercion -> Coercion -mkAppCoercion co1 co2 = mkAppTy co1 co2 +mkCoVarCo :: CoVar -> Coercion +mkCoVarCo cv + | ty1 `eqType` ty2 = Refl ty1 + | otherwise = CoVarCo cv + where + (ty1, ty2) = ASSERT( isCoVar cv ) coVarKind cv + +mkReflCo :: Type -> Coercion +mkReflCo = Refl + +mkAxInstCo :: CoAxiom -> [Type] -> Coercion +mkAxInstCo ax tys + | arity == n_tys = AxiomInstCo ax rtys + | otherwise = ASSERT( arity < n_tys ) + foldl AppCo (AxiomInstCo ax (take arity rtys)) + (drop arity rtys) + where + n_tys = length tys + arity = coAxiomArity ax + rtys = map Refl tys + +-- | Apply a 'Coercion' to another 'Coercion'. +mkAppCo :: Coercion -> Coercion -> Coercion +mkAppCo (Refl ty1) (Refl ty2) = Refl (mkAppTy ty1 ty2) +mkAppCo (Refl (TyConApp tc tys)) co = TyConAppCo tc (map Refl tys ++ [co]) +mkAppCo (TyConAppCo tc cos) co = TyConAppCo tc (cos ++ [co]) +mkAppCo co1 co2 = AppCo co1 co2 +-- Note, mkAppCo is careful to maintain invariants regarding +-- where Refl constructors appear; see the comments in the definition +-- of Coercion and the Note [Refl invariant] in types/TypeRep.lhs. -- | Applies multiple 'Coercion's to another 'Coercion', from left to right. --- See also 'mkAppCoercion' -mkAppsCoercion :: Coercion -> [Coercion] -> Coercion -mkAppsCoercion co1 tys = foldl mkAppTy co1 tys +-- See also 'mkAppCo' +mkAppCos :: Coercion -> [Coercion] -> Coercion +mkAppCos co1 tys = foldl mkAppCo co1 tys -- | Apply a type constructor to a list of coercions. -mkTyConCoercion :: TyCon -> [Coercion] -> Coercion -mkTyConCoercion con cos = mkTyConApp con cos +mkTyConAppCo :: TyCon -> [Coercion] -> Coercion +mkTyConAppCo tc cos + -- Expand type synonyms + | Just (tv_co_prs, rhs_ty, leftover_cos) <- tcExpandTyCon_maybe tc cos + = mkAppCos (liftCoSubst (mkTopCvSubst tv_co_prs) rhs_ty) leftover_cos + + | Just tys <- traverse isReflCo_maybe cos + = Refl (mkTyConApp tc tys) -- See Note [Refl invariant] + + | otherwise = TyConAppCo tc cos -- | Make a function 'Coercion' between two other 'Coercion's -mkFunCoercion :: Coercion -> Coercion -> Coercion -mkFunCoercion co1 co2 = mkFunTy co1 co2 -- NB: Handles correctly the forall for eqpreds! +mkFunCo :: Coercion -> Coercion -> Coercion +mkFunCo co1 co2 = mkTyConAppCo funTyCon [co1, co2] -- | Make a 'Coercion' which binds a variable within an inner 'Coercion' -mkForAllCoercion :: Var -> Coercion -> Coercion +mkForAllCo :: Var -> Coercion -> Coercion -- note that a TyVar should be used here, not a CoVar (nor a TcTyVar) -mkForAllCoercion tv co = ASSERT ( isTyCoVar tv ) mkForAllTy tv co +mkForAllCo tv (Refl ty) = ASSERT( isTyVar tv ) Refl (mkForAllTy tv ty) +mkForAllCo tv co = ASSERT ( isTyVar tv ) ForAllCo tv co +mkPredCo :: Pred Coercion -> Coercion +-- See Note [Predicate coercions] +mkPredCo (EqPred co1 co2) = mkTyConAppCo eqPredPrimTyCon [co1,co2] +mkPredCo (ClassP cls cos) = mkTyConAppCo (classTyCon cls) cos +mkPredCo (IParam _ co) = co ------------------------------- -mkSymCoercion :: Coercion -> Coercion --- ^ Create a symmetric version of the given 'Coercion' that asserts equality --- between the same types but in the other "direction", so a kind of @t1 ~ t2@ --- becomes the kind @t2 ~ t1@. -mkSymCoercion g = mkCoercion symCoercionTyCon [g] - -mkTransCoercion :: Coercion -> Coercion -> Coercion --- ^ Create a new 'Coercion' by exploiting transitivity on the two given 'Coercion's. -mkTransCoercion g1 g2 = mkCoercion transCoercionTyCon [g1, g2] - -mkLeftCoercion :: Coercion -> Coercion --- ^ From an application 'Coercion' build a 'Coercion' that asserts the equality of --- the "functions" on either side of the type equality. So if @c@ has kind @f x ~ g y@ then: --- --- > mkLeftCoercion c :: f ~ g -mkLeftCoercion co = mkCoercion leftCoercionTyCon [co] - -mkRightCoercion :: Coercion -> Coercion --- ^ From an application 'Coercion' build a 'Coercion' that asserts the equality of --- the "arguments" on either side of the type equality. So if @c@ has kind @f x ~ g y@ then: --- --- > mkLeftCoercion c :: x ~ y -mkRightCoercion co = mkCoercion rightCoercionTyCon [co] - -mkCsel1Coercion, mkCsel2Coercion, mkCselRCoercion :: Coercion -> Coercion -mkCsel1Coercion co = mkCoercion csel1CoercionTyCon [co] -mkCsel2Coercion co = mkCoercion csel2CoercionTyCon [co] -mkCselRCoercion co = mkCoercion cselRCoercionTyCon [co] - -------------------------------- -mkInstCoercion :: Coercion -> Type -> Coercion --- ^ Instantiates a 'Coercion' with a 'Type' argument. If possible, it immediately performs --- the resulting beta-reduction, otherwise it creates a suspended instantiation. -mkInstCoercion co ty = mkCoercion instCoercionTyCon [co, ty] - -mkInstsCoercion :: Coercion -> [Type] -> Coercion --- ^ As 'mkInstCoercion', but instantiates the coercion with a number of type arguments, left-to-right -mkInstsCoercion co tys = foldl mkInstCoercion co tys - --- | Manufacture a coercion from this air. Needless to say, this is not usually safe, --- but it is used when we know we are dealing with bottom, which is one case in which --- it is safe. This is also used implement the @unsafeCoerce#@ primitive. --- Optimise by pushing down through type constructors -mkUnsafeCoercion :: Type -> Type -> Coercion -mkUnsafeCoercion (TyConApp tc1 tys1) (TyConApp tc2 tys2) +-- | Create a symmetric version of the given 'Coercion' that asserts +-- equality between the same types but in the other "direction", so +-- a kind of @t1 ~ t2@ becomes the kind @t2 ~ t1@. +mkSymCo :: Coercion -> Coercion + +-- Do a few simple optimizations, but don't bother pushing occurrences +-- of symmetry to the leaves; the optimizer will take care of that. +mkSymCo co@(Refl {}) = co +mkSymCo (UnsafeCo ty1 ty2) = UnsafeCo ty2 ty1 +mkSymCo (SymCo co) = co +mkSymCo co = SymCo co + +-- | Create a new 'Coercion' by composing the two given 'Coercion's transitively. +mkTransCo :: Coercion -> Coercion -> Coercion +mkTransCo (Refl _) co = co +mkTransCo co (Refl _) = co +mkTransCo co1 co2 = TransCo co1 co2 + +mkNthCo :: Int -> Coercion -> Coercion +mkNthCo n (Refl ty) = Refl (getNth n ty) +mkNthCo n co = NthCo n co + +-- | Instantiates a 'Coercion' with a 'Type' argument. +mkInstCo :: Coercion -> Type -> Coercion +mkInstCo co ty = InstCo co ty + +-- | Manufacture a coercion from thin air. Needless to say, this is +-- not usually safe, but it is used when we know we are dealing with +-- bottom, which is one case in which it is safe. This is also used +-- to implement the @unsafeCoerce#@ primitive. Optimise by pushing +-- down through type constructors. +mkUnsafeCo :: Type -> Type -> Coercion +mkUnsafeCo ty1 ty2 | ty1 `eqType` ty2 = Refl ty1 +mkUnsafeCo (TyConApp tc1 tys1) (TyConApp tc2 tys2) | tc1 == tc2 - = TyConApp tc1 (zipWith mkUnsafeCoercion tys1 tys2) + = mkTyConAppCo tc1 (zipWith mkUnsafeCo tys1 tys2) -mkUnsafeCoercion (FunTy a1 r1) (FunTy a2 r2) - = FunTy (mkUnsafeCoercion a1 a2) (mkUnsafeCoercion r1 r2) +mkUnsafeCo (FunTy a1 r1) (FunTy a2 r2) + = mkFunCo (mkUnsafeCo a1 a2) (mkUnsafeCo r1 r2) -mkUnsafeCoercion ty1 ty2 - | ty1 `coreEqType` ty2 = ty1 - | otherwise = mkCoercion unsafeCoercionTyCon [ty1, ty2] +mkUnsafeCo ty1 ty2 = UnsafeCo ty1 ty2 -- See note [Newtype coercions] in TyCon --- | Create a coercion suitable for the given 'TyCon'. The 'Name' should be that of a --- new coercion 'TyCon', the 'TyVar's the arguments expected by the @newtype@ and the --- type the appropriate right hand side of the @newtype@, with the free variables --- a subset of those 'TyVar's. -mkNewTypeCoercion :: Name -> TyCon -> [TyVar] -> Type -> TyCon -mkNewTypeCoercion name tycon tvs rhs_ty - = mkCoercionTyCon name arity desc - where - arity = length tvs - desc = CoAxiom { co_ax_tvs = tvs - , co_ax_lhs = mkTyConApp tycon (mkTyVarTys tvs) - , co_ax_rhs = rhs_ty } +-- | Create a coercion constructor (axiom) suitable for the given +-- newtype 'TyCon'. The 'Name' should be that of a new coercion +-- 'CoAxiom', the 'TyVar's the arguments expected by the @newtype@ and +-- the type the appropriate right hand side of the @newtype@, with +-- the free variables a subset of those 'TyVar's. +mkNewTypeCo :: Name -> TyCon -> [TyVar] -> Type -> CoAxiom +mkNewTypeCo name tycon tvs rhs_ty + = CoAxiom { co_ax_unique = nameUnique name + , co_ax_name = name + , co_ax_tvs = tvs + , co_ax_lhs = mkTyConApp tycon (mkTyVarTys tvs) + , co_ax_rhs = rhs_ty } -- | Create a coercion identifying a @data@, @newtype@ or @type@ representation type -- and its family instance. It has the form @Co tvs :: F ts ~ R tvs@, where @Co@ is --- the coercion tycon built here, @F@ the family tycon and @R@ the (derived) +-- the coercion constructor built here, @F@ the family tycon and @R@ the (derived) -- representation tycon. -mkFamInstCoercion :: Name -- ^ Unique name for the coercion tycon +mkFamInstCo :: Name -- ^ Unique name for the coercion tycon -> [TyVar] -- ^ Type parameters of the coercion (@tvs@) -> TyCon -- ^ Family tycon (@F@) -> [Type] -- ^ Type instance (@ts@) -> TyCon -- ^ Representation tycon (@R@) - -> TyCon -- ^ Coercion tycon (@Co@) -mkFamInstCoercion name tvs family inst_tys rep_tycon - = mkCoercionTyCon name arity desc - where - arity = length tvs - desc = CoAxiom { co_ax_tvs = tvs - , co_ax_lhs = mkTyConApp family inst_tys - , co_ax_rhs = mkTyConApp rep_tycon (mkTyVarTys tvs) } - - -mkClassPPredCo :: Class -> [Coercion] -> Coercion -mkClassPPredCo cls = (PredTy . ClassP cls) - -mkIParamPredCo :: (IPName Name) -> Coercion -> Coercion -mkIParamPredCo ipn = (PredTy . IParam ipn) - -mkEqPredCo :: Coercion -> Coercion -> Coercion -mkEqPredCo co1 co2 = PredTy (EqPred co1 co2) - - -\end{code} - - -%************************************************************************ -%* * - Coercion Type Constructors -%* * -%************************************************************************ - -Example. The coercion ((sym c) (sym d) (sym e)) -will be represented by (TyConApp sym [c, sym d, sym e]) -If sym c :: p1=q1 - sym d :: p2=q2 - sym e :: p3=q3 -then ((sym c) (sym d) (sym e)) :: (p1 p2 p3)=(q1 q2 q3) - -\begin{code} --- | Coercion type constructors: avoid using these directly and instead use --- the @mk*Coercion@ and @split*Coercion@ family of functions if possible. --- --- Each coercion TyCon is built with the special CoercionTyCon record and --- carries its own kinding rule. Such CoercionTyCons must be fully applied --- by any TyConApp in which they are applied, however they may also be over --- applied (see example above) and the kinding function must deal with this. -symCoercionTyCon, transCoercionTyCon, leftCoercionTyCon, - rightCoercionTyCon, instCoercionTyCon, unsafeCoercionTyCon, - csel1CoercionTyCon, csel2CoercionTyCon, cselRCoercionTyCon :: TyCon - -symCoercionTyCon = mkCoercionTyCon symCoercionTyConName 1 CoSym -transCoercionTyCon = mkCoercionTyCon transCoercionTyConName 2 CoTrans -leftCoercionTyCon = mkCoercionTyCon leftCoercionTyConName 1 CoLeft -rightCoercionTyCon = mkCoercionTyCon rightCoercionTyConName 1 CoRight -instCoercionTyCon = mkCoercionTyCon instCoercionTyConName 2 CoInst -csel1CoercionTyCon = mkCoercionTyCon csel1CoercionTyConName 1 CoCsel1 -csel2CoercionTyCon = mkCoercionTyCon csel2CoercionTyConName 1 CoCsel2 -cselRCoercionTyCon = mkCoercionTyCon cselRCoercionTyConName 1 CoCselR -unsafeCoercionTyCon = mkCoercionTyCon unsafeCoercionTyConName 2 CoUnsafe - -transCoercionTyConName, symCoercionTyConName, leftCoercionTyConName, - rightCoercionTyConName, instCoercionTyConName, unsafeCoercionTyConName, - csel1CoercionTyConName, csel2CoercionTyConName, cselRCoercionTyConName :: Name - -transCoercionTyConName = mkCoConName (fsLit "trans") transCoercionTyConKey transCoercionTyCon -symCoercionTyConName = mkCoConName (fsLit "sym") symCoercionTyConKey symCoercionTyCon -leftCoercionTyConName = mkCoConName (fsLit "left") leftCoercionTyConKey leftCoercionTyCon -rightCoercionTyConName = mkCoConName (fsLit "right") rightCoercionTyConKey rightCoercionTyCon -instCoercionTyConName = mkCoConName (fsLit "inst") instCoercionTyConKey instCoercionTyCon -csel1CoercionTyConName = mkCoConName (fsLit "csel1") csel1CoercionTyConKey csel1CoercionTyCon -csel2CoercionTyConName = mkCoConName (fsLit "csel2") csel2CoercionTyConKey csel2CoercionTyCon -cselRCoercionTyConName = mkCoConName (fsLit "cselR") cselRCoercionTyConKey cselRCoercionTyCon -unsafeCoercionTyConName = mkCoConName (fsLit "CoUnsafe") unsafeCoercionTyConKey unsafeCoercionTyCon - -mkCoConName :: FastString -> Unique -> TyCon -> Name -mkCoConName occ key coCon = mkWiredInName gHC_PRIM (mkTcOccFS occ) - key (ATyCon coCon) BuiltInSyntax -\end{code} - -\begin{code} ------------- -decompLR_maybe :: (Type,Type) -> Maybe ((Type,Type), (Type,Type)) --- Helper for left and right. Finds coercion kind of its input and --- returns the left and right projections of the coercion... --- --- if c :: t1 s1 ~ t2 s2 then splitCoercionKindOf c = ((t1, t2), (s1, s2)) -decompLR_maybe (ty1,ty2) - | Just (ty_fun1, ty_arg1) <- splitAppTy_maybe ty1 - , Just (ty_fun2, ty_arg2) <- splitAppTy_maybe ty2 - = Just ((ty_fun1, ty_fun2),(ty_arg1, ty_arg2)) -decompLR_maybe _ = Nothing - ------------- -decompInst_maybe :: (Type, Type) -> Maybe ((TyVar,TyVar), (Type,Type)) -decompInst_maybe (ty1, ty2) - | Just (tv1,r1) <- splitForAllTy_maybe ty1 - , Just (tv2,r2) <- splitForAllTy_maybe ty2 - = Just ((tv1,tv2), (r1,r2)) -decompInst_maybe _ = Nothing - ------------- -decompCsel_maybe :: (Type, Type) -> Maybe ((Type,Type), (Type,Type), (Type,Type)) --- If co :: (s1~t1 => r1) ~ (s2~t2 => r2) --- Then csel1 co :: s1 ~ s2 --- csel2 co :: t1 ~ t2 --- cselR co :: r1 ~ r2 -decompCsel_maybe (ty1, ty2) - | Just (s1, t1, r1) <- splitCoPredTy_maybe ty1 - , Just (s2, t2, r2) <- splitCoPredTy_maybe ty2 - = Just ((s1,s2), (t1,t2), (r1,r2)) -decompCsel_maybe _ = Nothing + -> CoAxiom -- ^ Coercion constructor (@Co@) +mkFamInstCo name tvs family inst_tys rep_tycon + = CoAxiom { co_ax_unique = nameUnique name + , co_ax_name = name + , co_ax_tvs = tvs + , co_ax_lhs = mkTyConApp family inst_tys + , co_ax_rhs = mkTyConApp rep_tycon (mkTyVarTys tvs) } + +mkPiCos :: [Var] -> Coercion -> Coercion +mkPiCos vs co = foldr mkPiCo co vs + +mkPiCo :: Var -> Coercion -> Coercion +mkPiCo v co | isTyVar v = mkForAllCo v co + | otherwise = mkFunCo (mkReflCo (varType v)) co \end{code} - %************************************************************************ %* * Newtypes @@ -561,17 +660,14 @@ %************************************************************************ \begin{code} -instNewTyCon_maybe :: TyCon -> [Type] -> Maybe (Type, CoercionI) +instNewTyCon_maybe :: TyCon -> [Type] -> Maybe (Type, Coercion) -- ^ If @co :: T ts ~ rep_ty@ then: -- -- > instNewTyCon_maybe T ts = Just (rep_ty, co) instNewTyCon_maybe tc tys - | Just (tvs, ty, mb_co_tc) <- unwrapNewTyCon_maybe tc + | Just (tvs, ty, co_tc) <- unwrapNewTyCon_maybe tc = ASSERT( tys `lengthIs` tyConArity tc ) - Just (substTyWith tvs tys ty, - case mb_co_tc of - Nothing -> IdCo (mkTyConApp tc tys) - Just co_tc -> ACo (mkTyConApp co_tc tys)) + Just (substTyWith tvs tys ty, mkAxInstCo co_tc tys) | otherwise = Nothing @@ -588,270 +684,423 @@ splitNewTypeRepCo_maybe ty | Just ty' <- coreView ty = splitNewTypeRepCo_maybe ty' splitNewTypeRepCo_maybe (TyConApp tc tys) - | Just (ty', coi) <- instNewTyCon_maybe tc tys - = case coi of - ACo co -> Just (ty', co) - IdCo _ -> panic "splitNewTypeRepCo_maybe" + | Just (ty', co) <- instNewTyCon_maybe tc tys + = case co of + Refl _ -> panic "splitNewTypeRepCo_maybe" -- This case handled by coreView + _ -> Just (ty', co) splitNewTypeRepCo_maybe _ = Nothing -- | Determines syntactic equality of coercions coreEqCoercion :: Coercion -> Coercion -> Bool -coreEqCoercion = coreEqType +coreEqCoercion co1 co2 = coreEqCoercion2 rn_env co1 co2 + where rn_env = mkRnEnv2 (mkInScopeSet (tyCoVarsOfCo co1 `unionVarSet` tyCoVarsOfCo co2)) coreEqCoercion2 :: RnEnv2 -> Coercion -> Coercion -> Bool -coreEqCoercion2 = coreEqType2 -\end{code} +coreEqCoercion2 env (Refl ty1) (Refl ty2) = eqTypeX env ty1 ty2 +coreEqCoercion2 env (TyConAppCo tc1 cos1) (TyConAppCo tc2 cos2) + = tc1 == tc2 && all2 (coreEqCoercion2 env) cos1 cos2 + +coreEqCoercion2 env (AppCo co11 co12) (AppCo co21 co22) + = coreEqCoercion2 env co11 co21 && coreEqCoercion2 env co12 co22 + +coreEqCoercion2 env (ForAllCo v1 co1) (ForAllCo v2 co2) + = coreEqCoercion2 (rnBndr2 env v1 v2) co1 co2 + +coreEqCoercion2 env (CoVarCo cv1) (CoVarCo cv2) + = rnOccL env cv1 == rnOccR env cv2 + +coreEqCoercion2 env (AxiomInstCo con1 cos1) (AxiomInstCo con2 cos2) + = con1 == con2 + && all2 (coreEqCoercion2 env) cos1 cos2 + +coreEqCoercion2 env (UnsafeCo ty11 ty12) (UnsafeCo ty21 ty22) + = eqTypeX env ty11 ty21 && eqTypeX env ty12 ty22 + +coreEqCoercion2 env (SymCo co1) (SymCo co2) + = coreEqCoercion2 env co1 co2 + +coreEqCoercion2 env (TransCo co11 co12) (TransCo co21 co22) + = coreEqCoercion2 env co11 co21 && coreEqCoercion2 env co12 co22 +coreEqCoercion2 env (NthCo d1 co1) (NthCo d2 co2) + = d1 == d2 && coreEqCoercion2 env co1 co2 + +coreEqCoercion2 env (InstCo co1 ty1) (InstCo co2 ty2) + = coreEqCoercion2 env co1 co2 && eqTypeX env ty1 ty2 + +coreEqCoercion2 _ _ _ = False +\end{code} %************************************************************************ %* * - CoercionI and its constructors -%* * + Substitution of coercions +%* * %************************************************************************ --------------------------------------- --- CoercionI smart constructors --- lifted smart constructors of ordinary coercions +\begin{code} +-- | A substitution of 'Coercion's for 'CoVar's (OR 'TyVar's, when +-- doing a \"lifting\" substitution) +type CvSubstEnv = VarEnv Coercion + +emptyCvSubstEnv :: CvSubstEnv +emptyCvSubstEnv = emptyVarEnv + +data CvSubst + = CvSubst InScopeSet -- The in-scope type variables + TvSubstEnv -- Substitution of types + CvSubstEnv -- Substitution of coercions + +instance Outputable CvSubst where + ppr (CvSubst ins tenv cenv) + = brackets $ sep[ ptext (sLit "CvSubst"), + nest 2 (ptext (sLit "In scope:") <+> ppr ins), + nest 2 (ptext (sLit "Type env:") <+> ppr tenv), + nest 2 (ptext (sLit "Coercion env:") <+> ppr cenv) ] + +emptyCvSubst :: CvSubst +emptyCvSubst = CvSubst emptyInScopeSet emptyVarEnv emptyVarEnv + +isEmptyCvSubst :: CvSubst -> Bool +isEmptyCvSubst (CvSubst _ tenv cenv) = isEmptyVarEnv tenv && isEmptyVarEnv cenv + +getCvInScope :: CvSubst -> InScopeSet +getCvInScope (CvSubst in_scope _ _) = in_scope + +zapCvSubstEnv :: CvSubst -> CvSubst +zapCvSubstEnv (CvSubst in_scope _ _) = CvSubst in_scope emptyVarEnv emptyVarEnv + +cvTvSubst :: CvSubst -> TvSubst +cvTvSubst (CvSubst in_scope tvs _) = TvSubst in_scope tvs + +tvCvSubst :: TvSubst -> CvSubst +tvCvSubst (TvSubst in_scope tenv) = CvSubst in_scope tenv emptyCvSubstEnv + +extendTvSubst :: CvSubst -> TyVar -> Type -> CvSubst +extendTvSubst (CvSubst in_scope tenv cenv) tv ty + = CvSubst in_scope (extendVarEnv tenv tv ty) cenv + +substCoVarBndr :: CvSubst -> CoVar -> (CvSubst, CoVar) +substCoVarBndr subst@(CvSubst in_scope tenv cenv) old_var + = ASSERT( isCoVar old_var ) + (CvSubst (in_scope `extendInScopeSet` new_var) tenv new_cenv, new_var) + where + -- When we substitute (co :: t1 ~ t2) we may get the identity (co :: t ~ t) + -- In that case, mkCoVarCo will return a ReflCoercion, and + -- we want to substitute that (not new_var) for old_var + new_co = mkCoVarCo new_var + no_change = new_var == old_var && not (isReflCo new_co) + + new_cenv | no_change = delVarEnv cenv old_var + | otherwise = extendVarEnv cenv old_var new_co + + new_var = uniqAway in_scope subst_old_var + subst_old_var = mkCoVar (varName old_var) (substTy subst (varType old_var)) + -- It's important to do the substitution for coercions, + -- because only they can have free type variables + +substTyVarBndr :: CvSubst -> TyVar -> (CvSubst, TyVar) +substTyVarBndr (CvSubst in_scope tenv cenv) old_var + = case Type.substTyVarBndr (TvSubst in_scope tenv) old_var of + (TvSubst in_scope' tenv', new_var) -> (CvSubst in_scope' tenv' cenv, new_var) + +zipOpenCvSubst :: [Var] -> [Coercion] -> CvSubst +zipOpenCvSubst vs cos + | debugIsOn && (length vs /= length cos) + = pprTrace "zipOpenCvSubst" (ppr vs $$ ppr cos) emptyCvSubst + | otherwise + = CvSubst (mkInScopeSet (tyCoVarsOfCos cos)) emptyTvSubstEnv (zipVarEnv vs cos) + +mkTopCvSubst :: [(Var,Coercion)] -> CvSubst +mkTopCvSubst prs = CvSubst emptyInScopeSet emptyTvSubstEnv (mkVarEnv prs) + +substCoWithTy :: InScopeSet -> TyVar -> Type -> Coercion -> Coercion +substCoWithTy in_scope tv ty = substCoWithTys in_scope [tv] [ty] + +substCoWithTys :: InScopeSet -> [TyVar] -> [Type] -> Coercion -> Coercion +substCoWithTys in_scope tvs tys co + | debugIsOn && (length tvs /= length tys) + = pprTrace "substCoWithTys" (ppr tvs $$ ppr tys) co + | otherwise + = ASSERT( length tvs == length tys ) + substCo (CvSubst in_scope (zipVarEnv tvs tys) emptyVarEnv) co + +-- | Substitute within a 'Coercion' +substCo :: CvSubst -> Coercion -> Coercion +substCo subst co | isEmptyCvSubst subst = co + | otherwise = subst_co subst co + +-- | Substitute within several 'Coercion's +substCos :: CvSubst -> [Coercion] -> [Coercion] +substCos subst cos | isEmptyCvSubst subst = cos + | otherwise = map (substCo subst) cos + +substTy :: CvSubst -> Type -> Type +substTy subst = Type.substTy (cvTvSubst subst) + +subst_co :: CvSubst -> Coercion -> Coercion +subst_co subst co + = go co + where + go_ty :: Type -> Type + go_ty = Coercion.substTy subst + + go :: Coercion -> Coercion + go (Refl ty) = Refl $! go_ty ty + go (TyConAppCo tc cos) = let args = map go cos + in args `seqList` TyConAppCo tc args + go (AppCo co1 co2) = mkAppCo (go co1) $! go co2 + go (ForAllCo tv co) = case substTyVarBndr subst tv of + (subst', tv') -> + ForAllCo tv' $! subst_co subst' co + go (CoVarCo cv) = substCoVar subst cv + go (AxiomInstCo con cos) = AxiomInstCo con $! map go cos + go (UnsafeCo ty1 ty2) = (UnsafeCo $! go_ty ty1) $! go_ty ty2 + go (SymCo co) = mkSymCo (go co) + go (TransCo co1 co2) = mkTransCo (go co1) (go co2) + go (NthCo d co) = mkNthCo d (go co) + go (InstCo co ty) = mkInstCo (go co) $! go_ty ty + +substCoVar :: CvSubst -> CoVar -> Coercion +substCoVar (CvSubst in_scope _ cenv) cv + | Just co <- lookupVarEnv cenv cv = co + | Just cv1 <- lookupInScope in_scope cv = ASSERT( isCoVar cv1 ) CoVarCo cv1 + | otherwise = WARN( True, ptext (sLit "substCoVar not in scope") <+> ppr cv $$ ppr in_scope) + ASSERT( isCoVar cv ) CoVarCo cv + +substCoVars :: CvSubst -> [CoVar] -> [Coercion] +substCoVars subst cvs = map (substCoVar subst) cvs + +lookupTyVar :: CvSubst -> TyVar -> Maybe Type +lookupTyVar (CvSubst _ tenv _) tv = lookupVarEnv tenv tv + +lookupCoVar :: CvSubst -> Var -> Maybe Coercion +lookupCoVar (CvSubst _ _ cenv) v = lookupVarEnv cenv v +\end{code} + +%************************************************************************ +%* * + "Lifting" substitution + [(TyVar,Coercion)] -> Type -> Coercion +%* * +%************************************************************************ \begin{code} --- | 'CoercionI' represents a /lifted/ ordinary 'Coercion', in that it --- can represent either one of: --- --- 1. A proper 'Coercion' +liftCoSubstWith :: [TyVar] -> [Coercion] -> Type -> Coercion +liftCoSubstWith tvs cos = liftCoSubst (zipOpenCvSubst tvs cos) + +-- | The \"lifting\" operation which substitutes coercions for type +-- variables in a type to produce a coercion. -- --- 2. The identity coercion -data CoercionI = IdCo Type | ACo Coercion +-- For the inverse operation, see 'liftCoMatch' +liftCoSubst :: CvSubst -> Type -> Coercion +-- The CvSubst maps TyVar -> Type (mainly for cloning foralls) +-- TyVar -> Coercion (this is the payload) +-- The unusual thing is that the *coercion* substitution maps +-- some *type* variables. That's the whole point of this function! +liftCoSubst subst ty | isEmptyCvSubst subst = Refl ty + | otherwise = ty_co_subst subst ty + +ty_co_subst :: CvSubst -> Type -> Coercion +ty_co_subst subst ty + = go ty + where + go (TyVarTy tv) = liftCoSubstTyVar subst tv `orElse` Refl (TyVarTy tv) + go (AppTy ty1 ty2) = mkAppCo (go ty1) (go ty2) + go (TyConApp tc tys) = mkTyConAppCo tc (map go tys) + go (FunTy ty1 ty2) = mkFunCo (go ty1) (go ty2) + go (ForAllTy v ty) = mkForAllCo v' $! (ty_co_subst subst' ty) + where + (subst', v') = liftCoSubstTyVarBndr subst v + go (PredTy p) = mkPredCo (go <$> p) + +liftCoSubstTyVar :: CvSubst -> TyVar -> Maybe Coercion +liftCoSubstTyVar subst@(CvSubst _ tenv cenv) tv + = case (lookupVarEnv tenv tv, lookupVarEnv cenv tv) of + (Nothing, Nothing) -> Nothing + (Just ty, Nothing) -> Just (Refl ty) + (Nothing, Just co) -> Just co + (Just {}, Just {}) -> pprPanic "ty_co_subst" (ppr tv $$ ppr subst) + +liftCoSubstTyVarBndr :: CvSubst -> TyVar -> (CvSubst, TyVar) +liftCoSubstTyVarBndr (CvSubst in_scope tenv cenv) old_var + = (CvSubst (in_scope `extendInScopeSet` new_var) + new_tenv + (delVarEnv cenv old_var) -- See Note [Lifting substitutions] + , new_var) + where + new_tenv | no_change = delVarEnv tenv old_var + | otherwise = extendVarEnv tenv old_var (TyVarTy new_var) -liftCoI :: (Type -> Type) -> CoercionI -> CoercionI -liftCoI f (IdCo ty) = IdCo (f ty) -liftCoI f (ACo ty) = ACo (f ty) - -liftCoI2 :: (Type -> Type -> Type) -> CoercionI -> CoercionI -> CoercionI -liftCoI2 f (IdCo ty1) (IdCo ty2) = IdCo (f ty1 ty2) -liftCoI2 f coi1 coi2 = ACo (f (fromCoI coi1) (fromCoI coi2)) - -liftCoIs :: ([Type] -> Type) -> [CoercionI] -> CoercionI -liftCoIs f cois = go_id [] cois - where - go_id rev_tys [] = IdCo (f (reverse rev_tys)) - go_id rev_tys (IdCo ty : cois) = go_id (ty:rev_tys) cois - go_id rev_tys (ACo co : cois) = go_aco (co:rev_tys) cois - - go_aco rev_tys [] = ACo (f (reverse rev_tys)) - go_aco rev_tys (IdCo ty : cois) = go_aco (ty:rev_tys) cois - go_aco rev_tys (ACo co : cois) = go_aco (co:rev_tys) cois - -instance Outputable CoercionI where - ppr (IdCo _) = ptext (sLit "IdCo") - ppr (ACo co) = ppr co - -isIdentityCoI :: CoercionI -> Bool -isIdentityCoI (IdCo _) = True -isIdentityCoI (ACo _) = False - --- | Return either the 'Coercion' contained within the 'CoercionI' or the given --- 'Type' if the 'CoercionI' is the identity 'Coercion' -fromCoI :: CoercionI -> Type -fromCoI (IdCo ty) = ty -- Identity coercion represented -fromCoI (ACo co) = co -- by the type itself - --- | Smart constructor for @sym@ on 'CoercionI', see also 'mkSymCoercion' -mkSymCoI :: CoercionI -> CoercionI -mkSymCoI (IdCo ty) = IdCo ty -mkSymCoI (ACo co) = ACo $ mkCoercion symCoercionTyCon [co] - -- the smart constructor - -- is too smart with tyvars - --- | Smart constructor for @trans@ on 'CoercionI', see also 'mkTransCoercion' -mkTransCoI :: CoercionI -> CoercionI -> CoercionI -mkTransCoI (IdCo _) aco = aco -mkTransCoI aco (IdCo _) = aco -mkTransCoI (ACo co1) (ACo co2) = ACo $ mkTransCoercion co1 co2 - --- | Smart constructor for type constructor application on 'CoercionI', see also 'mkAppCoercion' -mkTyConAppCoI :: TyCon -> [CoercionI] -> CoercionI -mkTyConAppCoI tyCon cois = liftCoIs (mkTyConApp tyCon) cois - --- | Smart constructor for honest-to-god 'Coercion' application on 'CoercionI', see also 'mkAppCoercion' -mkAppTyCoI :: CoercionI -> CoercionI -> CoercionI -mkAppTyCoI = liftCoI2 mkAppTy - -mkFunTyCoI :: CoercionI -> CoercionI -> CoercionI -mkFunTyCoI = liftCoI2 mkFunTy - --- | Smart constructor for quantified 'Coercion's on 'CoercionI', see also 'mkForAllCoercion' -mkForAllTyCoI :: TyVar -> CoercionI -> CoercionI -mkForAllTyCoI tv = liftCoI (ForAllTy tv) + no_change = new_var == old_var + new_var = uniqAway in_scope old_var +\end{code} --- | Smart constructor for class 'Coercion's on 'CoercionI'. Satisfies: --- --- > mkClassPPredCoI cls tys cois :: PredTy (cls tys) ~ PredTy (cls (tys `cast` cois)) -mkClassPPredCoI :: Class -> [CoercionI] -> CoercionI -mkClassPPredCoI cls = liftCoIs (PredTy . ClassP cls) - --- | Smart constructor for implicit parameter 'Coercion's on 'CoercionI'. Similar to 'mkClassPPredCoI' -mkIParamPredCoI :: (IPName Name) -> CoercionI -> CoercionI -mkIParamPredCoI ipn = liftCoI (PredTy . IParam ipn) - --- | Smart constructor for type equality 'Coercion's on 'CoercionI'. Similar to 'mkClassPPredCoI' -mkEqPredCoI :: CoercionI -> CoercionI -> CoercionI -mkEqPredCoI = liftCoI2 (\t1 t2 -> PredTy (EqPred t1 t2)) +Note [Lifting substitutions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider liftCoSubstWith [a] [co] (a, forall a. a) +Then we want to substitute for the free 'a', but obviously not for +the bound 'a'. hence the (delVarEnv cent old_var) in liftCoSubstTyVarBndr. -mkCoPredCoI :: CoercionI -> CoercionI -> CoercionI -> CoercionI -mkCoPredCoI coi1 coi2 coi3 = mkFunTyCoI (mkEqPredCoI coi1 coi2) coi3 +This also why we need a full CvSubst when doing lifting substitutions. +\begin{code} +-- | 'liftCoMatch' is sort of inverse to 'liftCoSubst'. In particular, if +-- @liftCoMatch vars ty co == Just s@, then @tyCoSubst s ty == co@. +-- That is, it matches a type against a coercion of the same +-- "shape", and returns a lifting substitution which could have been +-- used to produce the given coercion from the given type. +liftCoMatch :: TyVarSet -> Type -> Coercion -> Maybe CvSubst +liftCoMatch tmpls ty co + = case ty_co_match menv (emptyVarEnv, emptyVarEnv) ty co of + Just (tv_env, cv_env) -> Just (CvSubst in_scope tv_env cv_env) + Nothing -> Nothing + where + menv = ME { me_tmpls = tmpls, me_env = mkRnEnv2 in_scope } + in_scope = mkInScopeSet (tmpls `unionVarSet` tyCoVarsOfCo co) + -- Like tcMatchTy, assume all the interesting variables + -- in ty are in tmpls + +type TyCoSubstEnv = (TvSubstEnv, CvSubstEnv) + -- Used locally inside ty_co_match only + +-- | 'ty_co_match' does all the actual work for 'liftCoMatch'. +ty_co_match :: MatchEnv -> TyCoSubstEnv -> Type -> Coercion -> Maybe TyCoSubstEnv +ty_co_match menv subst ty co | Just ty' <- coreView ty = ty_co_match menv subst ty' co + + -- Deal with the Refl case by delegating to type matching +ty_co_match menv (tenv, cenv) ty co + | Just ty' <- isReflCo_maybe co + = case ruleMatchTyX ty_menv tenv ty ty' of + Just tenv' -> Just (tenv', cenv) + Nothing -> Nothing + where + ty_menv = menv { me_tmpls = me_tmpls menv `minusUFM` cenv } + -- Remove from the template set any variables already bound to non-refl coercions + + -- Match a type variable against a non-refl coercion +ty_co_match menv subst@(tenv, cenv) (TyVarTy tv1) co + | Just {} <- lookupVarEnv tenv tv1' -- tv1' is already bound to (Refl ty) + = Nothing -- The coercion 'co' is not Refl + + | Just co1' <- lookupVarEnv cenv tv1' -- tv1' is already bound to co1 + = if coreEqCoercion2 (nukeRnEnvL rn_env) co1' co + then Just subst + else Nothing -- no match since tv1 matches two different coercions + + | tv1' `elemVarSet` me_tmpls menv -- tv1' is a template var + = if any (inRnEnvR rn_env) (varSetElems (tyCoVarsOfCo co)) + then Nothing -- occurs check failed + else return (tenv, extendVarEnv cenv tv1' co) + -- BAY: I don't think we need to do any kind matching here yet + -- (compare 'match'), but we probably will when moving to SHE. + + | otherwise -- tv1 is not a template ty var, so the only thing it + -- can match is a reflexivity coercion for itself. + -- But that case is dealt with already + = Nothing + + where + rn_env = me_env menv + tv1' = rnOccL rn_env tv1 + +ty_co_match menv subst (AppTy ty1 ty2) co + | Just (co1, co2) <- splitAppCo_maybe co -- c.f. Unify.match on AppTy + = do { subst' <- ty_co_match menv subst ty1 co1 + ; ty_co_match menv subst' ty2 co2 } + +ty_co_match menv subst (TyConApp tc1 tys) (TyConAppCo tc2 cos) + | tc1 == tc2 = ty_co_matches menv subst tys cos + +ty_co_match menv subst (FunTy ty1 ty2) (TyConAppCo tc cos) + | tc == funTyCon = ty_co_matches menv subst [ty1,ty2] cos + +ty_co_match menv subst (ForAllTy tv1 ty) (ForAllCo tv2 co) + = ty_co_match menv' subst ty co + where + menv' = menv { me_env = rnBndr2 (me_env menv) tv1 tv2 } +ty_co_match _ _ _ _ = Nothing + +ty_co_matches :: MatchEnv -> TyCoSubstEnv -> [Type] -> [Coercion] -> Maybe TyCoSubstEnv +ty_co_matches menv = matchList (ty_co_match menv) \end{code} %************************************************************************ %* * - The kind of a type, and of a coercion + Sequencing on coercions %* * %************************************************************************ \begin{code} -typeKind :: Type -> Kind -typeKind ty@(TyConApp tc tys) - | isCoercionTyCon tc = typeKind (fst (coercionKind ty)) - | otherwise = kindAppResult (tyConKind tc) tys - -- During coercion optimisation we *do* match a type - -- against a coercion (see OptCoercion.matchesAxiomLhs) - -- So the use of typeKind in Unify.match_kind must work on coercions too - -- Hence the isCoercionTyCon case above - -typeKind (PredTy pred) = predKind pred -typeKind (AppTy fun _) = kindFunResult (typeKind fun) -typeKind (ForAllTy _ ty) = typeKind ty -typeKind (TyVarTy tyvar) = tyVarKind tyvar -typeKind (FunTy _arg res) - -- Hack alert. The kind of (Int -> Int#) is liftedTypeKind (*), - -- not unliftedTypKind (#) - -- The only things that can be after a function arrow are - -- (a) types (of kind openTypeKind or its sub-kinds) - -- (b) kinds (of super-kind TY) (e.g. * -> (* -> *)) - | isTySuperKind k = k - | otherwise = ASSERT( isSubOpenTypeKind k) liftedTypeKind - where - k = typeKind res +seqCo :: Coercion -> () +seqCo (Refl ty) = seqType ty +seqCo (TyConAppCo tc cos) = tc `seq` seqCos cos +seqCo (AppCo co1 co2) = seqCo co1 `seq` seqCo co2 +seqCo (ForAllCo tv co) = tv `seq` seqCo co +seqCo (CoVarCo cv) = cv `seq` () +seqCo (AxiomInstCo con cos) = con `seq` seqCos cos +seqCo (UnsafeCo ty1 ty2) = seqType ty1 `seq` seqType ty2 +seqCo (SymCo co) = seqCo co +seqCo (TransCo co1 co2) = seqCo co1 `seq` seqCo co2 +seqCo (NthCo _ co) = seqCo co +seqCo (InstCo co ty) = seqCo co `seq` seqType ty + +seqCos :: [Coercion] -> () +seqCos [] = () +seqCos (co:cos) = seqCo co `seq` seqCos cos +\end{code} ------------------- -predKind :: PredType -> Kind -predKind (EqPred {}) = coSuperKind -- A coercion kind! -predKind (ClassP {}) = liftedTypeKind -- Class and implicitPredicates are -predKind (IParam {}) = liftedTypeKind -- always represented by lifted types + +%************************************************************************ +%* * + The kind of a type, and of a coercion +%* * +%************************************************************************ + +\begin{code} +coercionType :: Coercion -> Type +coercionType co = case coercionKind co of + Pair ty1 ty2 -> mkCoType ty1 ty2 ------------------ -- | If it is the case that -- -- > c :: (t1 ~ t2) -- --- i.e. the kind of @c@ is a 'CoercionKind' relating @t1@ and @t2@, --- then @coercionKind c = (t1, t2)@. -coercionKind :: Coercion -> (Type, Type) -coercionKind ty@(TyVarTy a) | isCoVar a = coVarKind a - | otherwise = (ty, ty) -coercionKind (AppTy ty1 ty2) - = let (s1, t1) = coercionKind ty1 - (s2, t2) = coercionKind ty2 in - (mkAppTy s1 s2, mkAppTy t1 t2) -coercionKind co@(TyConApp tc args) - | Just (ar, desc) <- isCoercionTyCon_maybe tc - -- CoercionTyCons carry their kinding rule, so we use it here - = WARN( not (length args >= ar), ppr co ) -- Always saturated - (let (ty1, ty2) = coTyConAppKind desc (take ar args) - (tys1, tys2) = coercionKinds (drop ar args) - in (mkAppTys ty1 tys1, mkAppTys ty2 tys2)) - - | otherwise - = let (lArgs, rArgs) = coercionKinds args in - (TyConApp tc lArgs, TyConApp tc rArgs) +-- i.e. the kind of @c@ relates @t1@ and @t2@, then @coercionKind c = Pair t1 t2@. +coercionKind :: Coercion -> Pair Type +coercionKind (Refl ty) = Pair ty ty +coercionKind (TyConAppCo tc cos) = mkTyConApp tc <$> (sequenceA $ map coercionKind cos) +coercionKind (AppCo co1 co2) = mkAppTy <$> coercionKind co1 <*> coercionKind co2 +coercionKind (ForAllCo tv co) = mkForAllTy tv <$> coercionKind co +coercionKind (CoVarCo cv) = ASSERT( isCoVar cv ) toPair $ coVarKind cv +coercionKind (AxiomInstCo ax cos) = let Pair tys1 tys2 = coercionKinds cos + in Pair (substTyWith (co_ax_tvs ax) tys1 (co_ax_lhs ax)) + (substTyWith (co_ax_tvs ax) tys2 (co_ax_rhs ax)) +coercionKind (UnsafeCo ty1 ty2) = Pair ty1 ty2 +coercionKind (SymCo co) = swap $ coercionKind co +coercionKind (TransCo co1 co2) = Pair (pFst $ coercionKind co1) (pSnd $ coercionKind co2) +coercionKind (NthCo d co) = getNth d <$> coercionKind co +coercionKind co@(InstCo aco ty) | Just ks <- splitForAllTy_maybe `traverse` coercionKind aco + = (\(tv, body) -> substTyWith [tv] [ty] body) <$> ks + | otherwise = pprPanic "coercionKind" (ppr co) -coercionKind (FunTy ty1 ty2) - = let (t1, t2) = coercionKind ty1 - (s1, s2) = coercionKind ty2 in - (mkFunTy t1 s1, mkFunTy t2 s2) - -coercionKind (ForAllTy tv ty) - | isCoVar tv --- c1 :: s1~s2 c2 :: t1~t2 c3 :: r1~r2 --- ---------------------------------------------- --- c1~c2 => c3 :: (s1~t1) => r1 ~ (s2~t2) => r2 --- or --- forall (_:c1~c2) - = let (c1,c2) = coVarKind tv - (s1,s2) = coercionKind c1 - (t1,t2) = coercionKind c2 - (r1,r2) = coercionKind ty - in - (mkCoPredTy s1 t1 r1, mkCoPredTy s2 t2 r2) - - | otherwise --- c1 :: s1~s2 c2 :: t1~t2 c3 :: r1~r2 --- ---------------------------------------------- --- forall a:k. c :: forall a:k. t1 ~ forall a:k. t2 - = let (ty1, ty2) = coercionKind ty in - (ForAllTy tv ty1, ForAllTy tv ty2) - -coercionKind (PredTy (ClassP cl args)) - = let (lArgs, rArgs) = coercionKinds args in - (PredTy (ClassP cl lArgs), PredTy (ClassP cl rArgs)) -coercionKind (PredTy (IParam name ty)) - = let (ty1, ty2) = coercionKind ty in - (PredTy (IParam name ty1), PredTy (IParam name ty2)) -coercionKind (PredTy (EqPred c1 c2)) - = pprTrace "coercionKind" (pprEqPred (c1,c2)) $ - -- These should not show up in coercions at all - -- becuase they are in the form of for-alls - let k1 = coercionKindPredTy c1 - k2 = coercionKindPredTy c2 in - (k1,k2) - where - coercionKindPredTy c = let (t1, t2) = coercionKind c in mkCoKind t1 t2 - ------------------- -- | Apply 'coercionKind' to multiple 'Coercion's -coercionKinds :: [Coercion] -> ([Type], [Type]) -coercionKinds tys = unzip $ map coercionKind tys +coercionKinds :: [Coercion] -> Pair [Type] +coercionKinds tys = sequenceA $ map coercionKind tys ------------------- --- | 'coTyConAppKind' is given a list of the type arguments to the 'CoTyCon', --- and constructs the types that the resulting coercion relates. --- Fails (in the monad) if ill-kinded. --- Typically the monad is --- either the Lint monad (with the consistency-check flag = True), --- or the ID monad with a panic on failure (and the consistency-check flag = False) -coTyConAppKind - :: CoTyConDesc - -> [Type] -- Exactly right number of args - -> (Type, Type) -- Kind of this application -coTyConAppKind CoUnsafe (ty1:ty2:_) - = (ty1,ty2) -coTyConAppKind CoSym (co:_) - | (ty1,ty2) <- coercionKind co = (ty2,ty1) -coTyConAppKind CoTrans (co1:co2:_) - = (fst (coercionKind co1), snd (coercionKind co2)) -coTyConAppKind CoLeft (co:_) - | Just (res,_) <- decompLR_maybe (coercionKind co) = res -coTyConAppKind CoRight (co:_) - | Just (_,res) <- decompLR_maybe (coercionKind co) = res -coTyConAppKind CoCsel1 (co:_) - | Just (res,_,_) <- decompCsel_maybe (coercionKind co) = res -coTyConAppKind CoCsel2 (co:_) - | Just (_,res,_) <- decompCsel_maybe (coercionKind co) = res -coTyConAppKind CoCselR (co:_) - | Just (_,_,res) <- decompCsel_maybe (coercionKind co) = res -coTyConAppKind CoInst (co:ty:_) - | Just ((tv1,tv2), (ty1,ty2)) <- decompInst_maybe (coercionKind co) - = (substTyWith [tv1] [ty] ty1, substTyWith [tv2] [ty] ty2) -coTyConAppKind (CoAxiom { co_ax_tvs = tvs - , co_ax_lhs = lhs_ty, co_ax_rhs = rhs_ty }) cos - = (substTyWith tvs tys1 lhs_ty, substTyWith tvs tys2 rhs_ty) - where - (tys1, tys2) = coercionKinds cos -coTyConAppKind desc cos = pprTrace "coTyConAppKind" (ppr desc $$ braces (vcat - [ ppr co <+> dcolon <+> pprEqPred (coercionKind co) - | co <- cos ])) $ - coercionKind (head cos) +getNth :: Int -> Type -> Type +getNth n ty | Just (_, tys) <- splitTyConApp_maybe ty + = ASSERT2( n < length tys, ppr n <+> ppr tys ) tys !! n +getNth n ty = pprPanic "getNth" (ppr n <+> ppr ty) \end{code} + +\begin{code} +applyCo :: Type -> Coercion -> Type +-- Gives the type of (e co) where e :: (a~b) => ty +applyCo ty co | Just ty' <- coreView ty = applyCo ty' co +applyCo (FunTy _ ty) _ = ty +applyCo _ _ = panic "applyCo" +\end{code} \ No newline at end of file diff -Nru ghc-7.0.3/compiler/types/FamInstEnv.lhs ghc-7.2.1/compiler/types/FamInstEnv.lhs --- ghc-7.0.3/compiler/types/FamInstEnv.lhs 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/types/FamInstEnv.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -29,7 +29,6 @@ import TyCon import Coercion import VarSet -import Var import Name import UniqFM import Outputable @@ -85,7 +84,12 @@ pprFamInst :: FamInst -> SDoc pprFamInst famInst = hang (pprFamInstHdr famInst) - 2 (ptext (sLit "--") <+> pprNameLoc (getName famInst)) + 2 (vcat [ ifPprDebug (ptext (sLit "Coercion axiom:") <+> pp_ax) + , ptext (sLit "--") <+> pprNameLoc (getName famInst)]) + where + pp_ax = case tyConFamilyCoercion_maybe (fi_tycon famInst) of + Just ax -> ppr ax + Nothing -> ptext (sLit "") pprFamInstHdr :: FamInst -> SDoc pprFamInstHdr (FamInst {fi_tycon = rep_tc}) @@ -303,7 +307,7 @@ -- anything else would be difficult to test for at this stage. conflicting old_fam_inst subst | isAlgTyCon fam = True - | otherwise = not (old_rhs `tcEqType` new_rhs) + | otherwise = not (old_rhs `eqType` new_rhs) where old_tycon = famInstTyCon old_fam_inst old_tvs = tyConTyVars old_tycon @@ -439,35 +443,34 @@ go rec_nts ty | Just ty' <- coreView ty -- Expand synonyms = go rec_nts ty' - go rec_nts (TyConApp tc tys) -- Expand newtypes - | Just co_con <- newTyConCo_maybe tc -- See Note [Expanding newtypes] - = if tc `elem` rec_nts -- in Type.lhs + go rec_nts (TyConApp tc tys) + | isNewTyCon tc -- Expand newtypes + = if tc `elem` rec_nts -- See Note [Expanding newtypes] in Type.lhs then Nothing - else let nt_co = mkTyConApp co_con tys - in add_co nt_co rec_nts' nt_rhs - where - nt_rhs = newTyConInstRhs tc tys - rec_nts' | isRecursiveTyCon tc = tc:rec_nts - | otherwise = rec_nts - - go rec_nts (TyConApp tc tys) -- Expand open tycons - | isFamilyTyCon tc - , (ACo co, ty) <- normaliseTcApp env tc tys - = -- The ACo says "something happened" - -- Note that normaliseType fully normalises, but it has do to so - -- to be sure that - add_co co rec_nts ty + else let nt_co = mkAxInstCo (newTyConCo tc) tys + in add_co nt_co rec_nts' nt_rhs + + | isFamilyTyCon tc -- Expand open tycons + , (co, ty) <- normaliseTcApp env tc tys + -- Note that normaliseType fully normalises, + -- but it has do to so to be sure that + , not (isReflCo co) + = add_co co rec_nts ty + where + nt_rhs = newTyConInstRhs tc tys + rec_nts' | isRecursiveTyCon tc = tc:rec_nts + | otherwise = rec_nts go _ _ = Nothing add_co co rec_nts ty = case go rec_nts ty of Nothing -> Just (co, ty) - Just (co', ty') -> Just (mkTransCoercion co co', ty') + Just (co', ty') -> Just (mkTransCo co co', ty') --------------- -normaliseTcApp :: FamInstEnvs -> TyCon -> [Type] -> (CoercionI, Type) +normaliseTcApp :: FamInstEnvs -> TyCon -> [Type] -> (Coercion, Type) normaliseTcApp env tc tys | isFamilyTyCon tc , tyConArity tc <= length tys -- Unsaturated data families are possible @@ -475,29 +478,30 @@ = let -- A matching family instance exists rep_tc = famInstTyCon fam_inst co_tycon = expectJust "lookupFamInst" (tyConFamilyCoercion_maybe rep_tc) - co = mkTyConApp co_tycon inst_tys - first_coi = mkTransCoI tycon_coi (ACo co) - (rest_coi, nty) = normaliseType env (mkTyConApp rep_tc inst_tys) - fix_coi = mkTransCoI first_coi rest_coi + co = mkAxInstCo co_tycon inst_tys + first_coi = mkTransCo tycon_coi co + (rest_coi,nty) = normaliseType env (mkTyConApp rep_tc inst_tys) + fix_coi = mkTransCo first_coi rest_coi in (fix_coi, nty) - | otherwise + | otherwise -- No unique matching family instance exists; + -- we do not do anything = (tycon_coi, TyConApp tc ntys) where -- Normalise the arg types so that they'll match -- when we lookup in in the instance envt (cois, ntys) = mapAndUnzip (normaliseType env) tys - tycon_coi = mkTyConAppCoI tc cois + tycon_coi = mkTyConAppCo tc cois --------------- normaliseType :: FamInstEnvs -- environment with family instances -> Type -- old type - -> (CoercionI, Type) -- (coercion,new type), where + -> (Coercion, Type) -- (coercion,new type), where -- co :: old-type ~ new_type -- Normalise the input type, by eliminating *all* type-function redexes --- Returns with IdCo if nothing happens +-- Returns with Refl if nothing happens normaliseType env ty | Just ty' <- coreView ty = normaliseType env ty' @@ -506,29 +510,29 @@ normaliseType env (AppTy ty1 ty2) = let (coi1,nty1) = normaliseType env ty1 (coi2,nty2) = normaliseType env ty2 - in (mkAppTyCoI coi1 coi2, mkAppTy nty1 nty2) + in (mkAppCo coi1 coi2, mkAppTy nty1 nty2) normaliseType env (FunTy ty1 ty2) = let (coi1,nty1) = normaliseType env ty1 (coi2,nty2) = normaliseType env ty2 - in (mkFunTyCoI coi1 coi2, mkFunTy nty1 nty2) + in (mkFunCo coi1 coi2, mkFunTy nty1 nty2) normaliseType env (ForAllTy tyvar ty1) = let (coi,nty1) = normaliseType env ty1 - in (mkForAllTyCoI tyvar coi, ForAllTy tyvar nty1) + in (mkForAllCo tyvar coi, ForAllTy tyvar nty1) normaliseType _ ty@(TyVarTy _) - = (IdCo ty,ty) + = (Refl ty,ty) normaliseType env (PredTy predty) = normalisePred env predty --------------- -normalisePred :: FamInstEnvs -> PredType -> (CoercionI,Type) +normalisePred :: FamInstEnvs -> PredType -> (Coercion,Type) normalisePred env (ClassP cls tys) - = let (cois,tys') = mapAndUnzip (normaliseType env) tys - in (mkClassPPredCoI cls cois, PredTy $ ClassP cls tys') + = let (cos,tys') = mapAndUnzip (normaliseType env) tys + in (mkPredCo $ ClassP cls cos, PredTy $ ClassP cls tys') normalisePred env (IParam ipn ty) - = let (coi,ty') = normaliseType env ty - in (mkIParamPredCoI ipn coi, PredTy $ IParam ipn ty') + = let (co,ty') = normaliseType env ty + in (mkPredCo $ (IParam ipn co), PredTy $ IParam ipn ty') normalisePred env (EqPred ty1 ty2) - = let (coi1,ty1') = normaliseType env ty1 - (coi2,ty2') = normaliseType env ty2 - in (mkEqPredCoI coi1 coi2, PredTy $ EqPred ty1' ty2') + = let (co1,ty1') = normaliseType env ty1 + (co2,ty2') = normaliseType env ty2 + in (mkPredCo $ (EqPred co1 co2), PredTy $ EqPred ty1' ty2') \end{code} diff -Nru ghc-7.0.3/compiler/types/FunDeps.lhs ghc-7.2.1/compiler/types/FunDeps.lhs --- ghc-7.0.3/compiler/types/FunDeps.lhs 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/types/FunDeps.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -271,8 +271,8 @@ , fd <- cls_fds , let (ltys1, rs1) = instFD fd cls_tvs tys1 (ltys2, irs2) = instFD_WithPos fd cls_tvs tys2 - , tcEqTypes ltys1 ltys2 -- The LHSs match - , let eqs = zipAndComputeFDEqs tcEqType rs1 irs2 + , eqTypes ltys1 ltys2 -- The LHSs match + , let eqs = zipAndComputeFDEqs eqType rs1 irs2 , not (null eqs) ] improveFromAnother _ _ = [] @@ -386,7 +386,7 @@ fdeqs = zipAndComputeFDEqs (\_ _ -> False) rtys1' irs2' -- Don't discard anything! -- We could discard equal types but it's an overkill to call - -- tcEqType again, since we know for sure that /at least one/ + -- eqType again, since we know for sure that /at least one/ -- equation in there is useful) qtvs' = filterVarSet (`notElemTvSubst` subst) qtvs diff -Nru ghc-7.0.3/compiler/types/Generics.lhs ghc-7.2.1/compiler/types/Generics.lhs --- ghc-7.0.3/compiler/types/Generics.lhs 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/types/Generics.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -1,18 +1,12 @@ % -% (c) The University of Glasgow 2006 +% (c) The University of Glasgow 2011 % \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 - -module Generics ( canDoGenerics, mkTyConGenericBinds, - mkGenericRhs, - validGenericInstanceType, validGenericMethodType + +module Generics ( canDoGenerics, + mkBindsRep, tc_mkRepTyCon, mkBindsMetaD, + MetaTyCons(..), metaTyCons2TyCons ) where @@ -22,17 +16,20 @@ import DataCon import TyCon -import Name +import Name hiding (varName) +import Module (moduleName, moduleNameString) import RdrName import BasicTypes -import Var -import VarSet -import Id import TysWiredIn import PrelNames - + +-- For generation of representation types +import TcEnv (tcLookupTyCon) +import TcRnMonad +import HscTypes +import BuildTyCl + import SrcLoc -import Util import Bag import Outputable import FastString @@ -40,185 +37,6 @@ #include "HsVersions.h" \end{code} -Roadmap of what's where in the Generics work. -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Parser -No real checks. - -RnSource.rnHsType - Checks that HsNumTy has a "1" in it. - -TcInstDcls.mkGenericInstance: - Checks for invalid type patterns, such as f {| Int |} - -TcClassDcl.tcClassSig - Checks for a method type that is too complicated; - e.g. has for-alls or lists in it - We could lift this restriction - -TcClassDecl.mkDefMethRhs - Checks that the instance type is simple, in an instance decl - where we let the compiler fill in a generic method. - e.g. instance C (T Int) - is not valid if C has generic methods. - -TcClassDecl.checkGenericClassIsUnary - Checks that we don't have generic methods in a multi-parameter class - -TcClassDecl.checkDefaultBinds - Checks that all the equations for a method in a class decl - are generic, or all are non-generic - - - -Checking that the type constructors which are present in Generic -patterns (not Unit, this is done differently) is done in mk_inst_info -(TcInstDecls) in a call to tcHsType (TcMonoBinds). This means that -HsOpTy is tied to Generic definitions which is not a very good design -feature, indeed a bug. However, the check is easy to move from -tcHsType back to mk_inst_info and everything will be fine. Also see -bug #5. [I don't think that this is the case anymore after SPJ's latest -changes in that regard. Delete this comment? -=chak/7Jun2] - -Generics.lhs - -Making generic information to put into a tycon. Constructs the -representation type, which, I think, are not used later. Perhaps it is -worth removing them from the GI datatype. Although it does get used in -the construction of conversion functions (internally). - -TyCon.lhs - -Just stores generic information, accessible by tyConGenInfo or tyConGenIds. - -TysWiredIn.lhs - -Defines generic and other type and data constructors. - -This is sadly incomplete, but will be added to. - - -Bugs & shortcomings of existing implementation: -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -2. Another pretty big bug I dscovered at the last minute when I was -testing the code is that at the moment the type variable of the class -is scoped over the entire declaration, including the patterns. For -instance, if I have the following code, - -class Er a where - ... - er {| Plus a b |} (Inl x) (Inl y) = er x y - er {| Plus a b |} (Inr x) (Inr y) = er x y - er {| Plus a b |} _ _ = False - -and I print out the types of the generic patterns, I get the -following. Note that all the variable names for "a" are the same, -while for "b" they are all different. - -check_ty - [std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7g-}, - std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7m-}, - std.Generics.Plus{-33u,i-} a{-r6Z-} b{-r7p-}] - -This is a bug as if I change the code to - - er {| Plus c b |} (Inl x) (Inl y) = er x y - -all the names come out to be different. - -Thus, all the types (Plus a b) come out to be different, so I cannot -compare them and test whether they are all the same and thus cannot -return an error if the type variables are different. - -Temporary fix/hack. I am not checking for this, I just assume they are -the same, see line "check_ty = True" in TcInstDecls. When we resolve -the issue with variables, though - I assume that we will make them to -be the same in all the type patterns, jus uncomment the check and -everything should work smoothly. - -Hence, I have also left the rather silly construction of: -* extracting all the type variables from all the types -* putting them *all* into the environment -* typechecking all the types -* selecting one of them and using it as the instance_ty. - -(the alternative is to make sure that all the types are the same, -taking one, extracting its variables, putting them into the environment, -type checking it, using it as the instance_ty) - -6. What happens if we do not supply all of the generic patterns? At -the moment, the compiler crashes with an error message "Non-exhaustive -patterns in a generic declaration" - - -What has not been addressed: -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -Contexts. In the generated instance declarations for the 3 primitive -type constructors, we need contexts. It is unclear what those should -be. At the moment, we always say eg. (Eq a, Eq b) => Eq (Plus a b) - -Type application. We have type application in expressions -(essentially) on the lhs of an equation. Do we want to allow it on the -RHS? - -Scoping of type variables in a generic definition. At the moment, (see -TcInstDecls) we extract the type variables inside the type patterns -and add them to the environment. See my bug #2 above. This seems pretty -important. - - - -%************************************************************************ -%* * -\subsection{Getting the representation type out} -%* * -%************************************************************************ - -\begin{code} -validGenericInstanceType :: Type -> Bool - -- Checks for validity of the type pattern in a generic - -- declaration. It's ok to have - -- f {| a + b |} ... - -- but it's not OK to have - -- f {| a + Int |} - -validGenericInstanceType inst_ty - = case tcSplitTyConApp_maybe inst_ty of - Just (tycon, tys) -> all isTyVarTy tys && tyConName tycon `elem` genericTyConNames - Nothing -> False - -validGenericMethodType :: Type -> Bool - -- At the moment we only allow method types built from - -- * type variables - -- * function arrow - -- * boxed tuples - -- * lists - -- * an arbitrary type not involving the class type variables - -- e.g. this is ok: forall b. Ord b => [b] -> a - -- where a is the class variable -validGenericMethodType ty - = valid tau - where - (local_tvs, _, tau) = tcSplitSigmaTy ty - - valid ty - | not (isTauTy ty) = False -- Note [Higher ramk methods] - | isTyVarTy ty = True - | no_tyvars_in_ty = True - | otherwise = case tcSplitTyConApp_maybe ty of - Just (tc,tys) -> valid_tycon tc && all valid tys - Nothing -> False - where - no_tyvars_in_ty = all (`elem` local_tvs) (varSetElems (tyVarsOfType ty)) - - valid_tycon tc = tc == funTyCon || tc == listTyCon || isBoxedTupleTyCon tc - -- Compare bimapApp, below -\end{code} - - %************************************************************************ %* * \subsection{Generating representation types} @@ -226,25 +44,47 @@ %************************************************************************ \begin{code} -canDoGenerics :: [DataCon] -> Bool +canDoGenerics :: TyCon -> Maybe SDoc -- Called on source-code data types, to see if we should generate --- generic functions for them. (This info is recorded in the interface file for --- imported data types.) - -canDoGenerics data_cons - = not (any bad_con data_cons) -- See comment below - && not (null data_cons) -- No values of the type +-- generic functions for them. +-- Nothing == yes +-- Just s == no, because of `s` + +canDoGenerics tycon + = mergeErrors ( + -- We do not support datatypes with context + (if (not (null (tyConStupidTheta tycon))) + then (Just (ppr tycon <+> text "must not have a datatype context")) + else Nothing) + -- We don't like type families + : (if (isFamilyTyCon tycon) + then (Just (ppr tycon <+> text "must not be a family instance")) + else Nothing) + -- See comment below + : (map bad_con (tyConDataCons tycon))) where - bad_con dc = any bad_arg_type (dataConOrigArgTys dc) || not (isVanillaDataCon dc) - -- If any of the constructor has an unboxed type as argument, - -- then we can't build the embedding-projection pair, because - -- it relies on instantiating *polymorphic* sum and product types - -- at the argument types of the constructors + -- If any of the constructor has an unboxed type as argument, + -- then we can't build the embedding-projection pair, because + -- it relies on instantiating *polymorphic* sum and product types + -- at the argument types of the constructors + bad_con dc = if (any bad_arg_type (dataConOrigArgTys dc)) + then (Just (ppr dc <+> text "must not have unlifted or polymorphic arguments")) + else (if (not (isVanillaDataCon dc)) + then (Just (ppr dc <+> text "must be a vanilla data constructor")) + else Nothing) + -- Nor can we do the job if it's an existential data constructor, -- Nor if the args are polymorphic types (I don't think) bad_arg_type ty = isUnLiftedType ty || not (isTauTy ty) + + mergeErrors :: [Maybe SDoc] -> Maybe SDoc + mergeErrors [] = Nothing + mergeErrors ((Just s):t) = case mergeErrors t of + Nothing -> Just s + Just s' -> Just (s <> text ", and" $$ s') + mergeErrors (Nothing :t) = mergeErrors t \end{code} %************************************************************************ @@ -255,320 +95,302 @@ \begin{code} type US = Int -- Local unique supply, just a plain Int -type FromAlt = (LPat RdrName, LHsExpr RdrName) +type Alt = (LPat RdrName, LHsExpr RdrName) -mkTyConGenericBinds :: TyCon -> LHsBinds RdrName -mkTyConGenericBinds tycon - = unitBag (L loc (mkFunBind (L loc from_RDR) from_matches)) - `unionBags` +-- Bindings for the Generic instance +mkBindsRep :: TyCon -> LHsBinds RdrName +mkBindsRep tycon = + unitBag (L loc (mkFunBind (L loc from_RDR) from_matches)) + `unionBags` unitBag (L loc (mkFunBind (L loc to_RDR) to_matches)) + where + from_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts] + to_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- to_alts ] + loc = srcLocSpan (getSrcLoc tycon) + datacons = tyConDataCons tycon + + -- Recurse over the sum first + from_alts, to_alts :: [Alt] + (from_alts, to_alts) = mkSum (1 :: US) tycon datacons + +-------------------------------------------------------------------------------- +-- The type instance synonym and synonym +-- type instance Rep (D a b) = Rep_D a b +-- type Rep_D a b = ...representation type for D ... +-------------------------------------------------------------------------------- + +tc_mkRepTyCon :: TyCon -- The type to generate representation for + -> MetaTyCons -- Metadata datatypes to refer to + -> TcM TyCon -- Generated representation0 type +tc_mkRepTyCon tycon metaDts = +-- Consider the example input tycon `D`, where data D a b = D_ a + do { -- `rep0` = GHC.Generics.Rep (type family) + rep0 <- tcLookupTyCon repTyConName + + -- `rep0Ty` = D1 ... (C1 ... (S1 ... (Rec0 a))) :: * -> * + ; rep0Ty <- tc_mkRepTy tycon metaDts + + -- `rep_name` is a name we generate for the synonym + ; rep_name <- newImplicitBinder (tyConName tycon) mkGenR + ; let -- `tyvars` = [a,b] + tyvars = tyConTyVars tycon + + -- rep0Ty has kind * -> * + rep_kind = liftedTypeKind `mkArrowKind` liftedTypeKind + + -- `appT` = D a b + appT = [mkTyConApp tycon (mkTyVarTys tyvars)] + + ; buildSynTyCon rep_name tyvars (SynonymTyCon rep0Ty) rep_kind + NoParentTyCon (Just (rep0, appT)) } + +-------------------------------------------------------------------------------- +-- Type representation +-------------------------------------------------------------------------------- + +tc_mkRepTy :: -- The type to generate representation for + TyCon + -- Metadata datatypes to refer to + -> MetaTyCons + -- Generated representation0 type + -> TcM Type +tc_mkRepTy tycon metaDts = + do + d1 <- tcLookupTyCon d1TyConName + c1 <- tcLookupTyCon c1TyConName + s1 <- tcLookupTyCon s1TyConName + nS1 <- tcLookupTyCon noSelTyConName + rec0 <- tcLookupTyCon rec0TyConName + par0 <- tcLookupTyCon par0TyConName + u1 <- tcLookupTyCon u1TyConName + v1 <- tcLookupTyCon v1TyConName + plus <- tcLookupTyCon sumTyConName + times <- tcLookupTyCon prodTyConName + + let mkSum' a b = mkTyConApp plus [a,b] + mkProd a b = mkTyConApp times [a,b] + mkRec0 a = mkTyConApp rec0 [a] + mkPar0 a = mkTyConApp par0 [a] + mkD a = mkTyConApp d1 [metaDTyCon, sumP (tyConDataCons a)] + mkC i d a = mkTyConApp c1 [d, prod i (dataConOrigArgTys a) + (null (dataConFieldLabels a))] + -- This field has no label + mkS True _ a = mkTyConApp s1 [mkTyConTy nS1, a] + -- This field has a label + mkS False d a = mkTyConApp s1 [d, a] + + sumP [] = mkTyConTy v1 + sumP l = ASSERT (length metaCTyCons == length l) + foldBal mkSum' [ mkC i d a + | (d,(a,i)) <- zip metaCTyCons (zip l [0..])] + -- The Bool is True if this constructor has labelled fields + prod :: Int -> [Type] -> Bool -> Type + prod i [] _ = ASSERT (length metaSTyCons > i) + ASSERT (length (metaSTyCons !! i) == 0) + mkTyConTy u1 + prod i l b = ASSERT (length metaSTyCons > i) + ASSERT (length l == length (metaSTyCons !! i)) + foldBal mkProd [ arg d t b + | (d,t) <- zip (metaSTyCons !! i) l ] + + arg :: Type -> Type -> Bool -> Type + arg d t b = mkS b d (recOrPar t (getTyVar_maybe t)) + -- Argument is not a type variable, use Rec0 + recOrPar t Nothing = mkRec0 t + -- Argument is a type variable, use Par0 + recOrPar t (Just _) = mkPar0 t + + metaDTyCon = mkTyConTy (metaD metaDts) + metaCTyCons = map mkTyConTy (metaC metaDts) + metaSTyCons = map (map mkTyConTy) (metaS metaDts) + + return (mkD tycon) + +-------------------------------------------------------------------------------- +-- Meta-information +-------------------------------------------------------------------------------- + +data MetaTyCons = MetaTyCons { -- One meta datatype per dataype + metaD :: TyCon + -- One meta datatype per constructor + , metaC :: [TyCon] + -- One meta datatype per selector per constructor + , metaS :: [[TyCon]] } + +instance Outputable MetaTyCons where + ppr (MetaTyCons d c s) = ppr d $$ vcat (map ppr c) $$ vcat (map ppr (concat s)) + +metaTyCons2TyCons :: MetaTyCons -> [TyCon] +metaTyCons2TyCons (MetaTyCons d c s) = d : c ++ concat s + + +-- Bindings for Datatype, Constructor, and Selector instances +mkBindsMetaD :: FixityEnv -> TyCon + -> ( LHsBinds RdrName -- Datatype instance + , [LHsBinds RdrName] -- Constructor instances + , [[LHsBinds RdrName]]) -- Selector instances +mkBindsMetaD fix_env tycon = (dtBinds, allConBinds, allSelBinds) + where + mkBag l = foldr1 unionBags + [ unitBag (L loc (mkFunBind (L loc name) matches)) + | (name, matches) <- l ] + dtBinds = mkBag [ (datatypeName_RDR, dtName_matches) + , (moduleName_RDR, moduleName_matches)] + + allConBinds = map conBinds datacons + conBinds c = mkBag ( [ (conName_RDR, conName_matches c)] + ++ ifElseEmpty (dataConIsInfix c) + [ (conFixity_RDR, conFixity_matches c) ] + ++ ifElseEmpty (length (dataConFieldLabels c) > 0) + [ (conIsRecord_RDR, conIsRecord_matches c) ] + ) + + ifElseEmpty p x = if p then x else [] + fixity c = case lookupFixity fix_env (dataConName c) of + Fixity n InfixL -> buildFix n leftAssocDataCon_RDR + Fixity n InfixR -> buildFix n rightAssocDataCon_RDR + Fixity n InfixN -> buildFix n notAssocDataCon_RDR + buildFix n assoc = nlHsApps infixDataCon_RDR [nlHsVar assoc + , nlHsIntLit (toInteger n)] + + allSelBinds = map (map selBinds) datasels + selBinds s = mkBag [(selName_RDR, selName_matches s)] + + loc = srcLocSpan (getSrcLoc tycon) + mkStringLHS s = [mkSimpleHsAlt nlWildPat (nlHsLit (mkHsString s))] + datacons = tyConDataCons tycon + datasels = map dataConFieldLabels datacons + + dtName_matches = mkStringLHS . showPpr . nameOccName . tyConName + $ tycon + moduleName_matches = mkStringLHS . moduleNameString . moduleName + . nameModule . tyConName $ tycon + + conName_matches c = mkStringLHS . showPpr . nameOccName + . dataConName $ c + conFixity_matches c = [mkSimpleHsAlt nlWildPat (fixity c)] + conIsRecord_matches _ = [mkSimpleHsAlt nlWildPat (nlHsVar true_RDR)] + + selName_matches s = mkStringLHS (showPpr (nameOccName s)) + + +-------------------------------------------------------------------------------- +-- Dealing with sums +-------------------------------------------------------------------------------- + +mkSum :: US -- Base for generating unique names + -> TyCon -- The type constructor + -> [DataCon] -- The data constructors + -> ([Alt], -- Alternatives for the T->Trep "from" function + [Alt]) -- Alternatives for the Trep->T "to" function + +-- Datatype without any constructors +mkSum _us tycon [] = ([from_alt], [to_alt]) where - from_matches = [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts] - to_matches = [mkSimpleHsAlt to_pat to_body] - loc = srcLocSpan (getSrcLoc tycon) - datacons = tyConDataCons tycon - (from_RDR, to_RDR) = mkGenericNames tycon - - -- Recurse over the sum first - from_alts :: [FromAlt] - (from_alts, to_pat, to_body) = mk_sum_stuff init_us datacons - init_us = 1::Int -- Unique supply - ----------------------------------------------------- --- Dealing with sums ----------------------------------------------------- - -mk_sum_stuff :: US -- Base for generating unique names - -> [DataCon] -- The data constructors - -> ([FromAlt], -- Alternatives for the T->Trep "from" function - InPat RdrName, LHsExpr RdrName) -- Arg and body of the Trep->T "to" function - --- For example, given --- data T = C | D Int Int Int --- --- mk_sum_stuff v [C,D] = ([C -> Inl Unit, D a b c -> Inr (a :*: (b :*: c))], --- case cd of { Inl u -> C; --- Inr abc -> case abc of { a :*: bc -> --- case bc of { b :*: c -> --- D a b c }} }, --- cd) - -mk_sum_stuff us [datacon] - = ([from_alt], to_pat, to_body_fn app_exp) - where - n_args = dataConSourceArity datacon -- Existentials already excluded - - datacon_vars = map mkGenericLocal [us .. us+n_args-1] - us' = us + n_args - - datacon_rdr = getRdrName datacon - app_exp = nlHsVarApps datacon_rdr datacon_vars - from_alt = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs) - - (_, from_alt_rhs, to_pat, to_body_fn) = mk_prod_stuff us' datacon_vars - -mk_sum_stuff us datacons - = (wrap inlDataCon_RDR l_from_alts ++ wrap inrDataCon_RDR r_from_alts, - nlVarPat to_arg, - noLoc (HsCase (nlHsVar to_arg) - (mkMatchGroup [mkSimpleHsAlt (nlConPat inlDataCon_RDR [l_to_pat]) l_to_body, - mkSimpleHsAlt (nlConPat inrDataCon_RDR [r_to_pat]) r_to_body]))) - where - (l_datacons, r_datacons) = splitInHalf datacons - (l_from_alts, l_to_pat, l_to_body) = mk_sum_stuff us' l_datacons - (r_from_alts, r_to_pat, r_to_body) = mk_sum_stuff us' r_datacons - - to_arg = mkGenericLocal us - us' = us+1 - - wrap :: RdrName -> [FromAlt] -> [FromAlt] - -- Wrap an application of the Inl or Inr constructor round each alternative - wrap dc alts = [(pat, noLoc (HsApp (nlHsVar dc) rhs)) | (pat,rhs) <- alts] - - ----------------------------------------------------- --- Dealing with products ----------------------------------------------------- -mk_prod_stuff :: US -- Base for unique names - -> [RdrName] -- arg-ids; args of the original user-defined constructor - -- They are bound enclosing from_rhs - -- Please bind these in the to_body_fn - -> (US, -- Depleted unique-name supply - LHsExpr RdrName, -- from-rhs: puts together the representation from the arg_ids - InPat RdrName, -- to_pat: - LHsExpr RdrName -> LHsExpr RdrName) -- to_body_fn: takes apart the representation - --- For example: --- mk_prod_stuff abc [a,b,c] = ( a :*: (b :*: c), --- abc, --- \ -> case abc of { a :*: bc -> --- case bc of { b :*: c -> --- ) - --- We need to use different uniques in the branches --- because the returned to_body_fns are nested. --- Hence the returned unqique-name supply - -mk_prod_stuff us [] -- Unit case - = (us+1, - nlHsVar genUnitDataCon_RDR, - noLoc (SigPatIn (nlVarPat (mkGenericLocal us)) - (noLoc (HsTyVar (getRdrName genUnitTyConName)))), - -- Give a signature to the pattern so we get - -- data S a = Nil | S a - -- toS = \x -> case x of { Inl (g :: Unit) -> Nil - -- Inr x -> S x } - -- The (:: Unit) signature ensures that we'll infer the right - -- type for toS. If we leave it out, the type is too polymorphic - - \x -> x) - -mk_prod_stuff us [arg_var] -- Singleton case - = (us, nlHsVar arg_var, nlVarPat arg_var, \x -> x) - -mk_prod_stuff us arg_vars -- Two or more - = (us'', - nlHsApps crossDataCon_RDR [l_alt_rhs, r_alt_rhs], - nlVarPat to_arg, --- gaw 2004 FIX? - \x -> noLoc (HsCase (nlHsVar to_arg) - (mkMatchGroup [mkSimpleHsAlt pat (l_to_body_fn (r_to_body_fn x))]))) + from_alt = (nlWildPat, mkM1_E (makeError errMsgFrom)) + to_alt = (mkM1_P nlWildPat, makeError errMsgTo) + -- These M1s are meta-information for the datatype + makeError s = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString s)) + errMsgFrom = "No generic representation for empty datatype " ++ showPpr tycon + errMsgTo = "No values for empty datatype " ++ showPpr tycon + +-- Datatype with at least one constructor +mkSum us _tycon datacons = + unzip [ mk1Sum us i (length datacons) d | (d,i) <- zip datacons [1..] ] + +-- Build the sum for a particular constructor +mk1Sum :: US -- Base for generating unique names + -> Int -- The index of this constructor + -> Int -- Total number of constructors + -> DataCon -- The data constructor + -> (Alt, -- Alternative for the T->Trep "from" function + Alt) -- Alternative for the Trep->T "to" function +mk1Sum us i n datacon = (from_alt, to_alt) where - to_arg = mkGenericLocal us - (l_arg_vars, r_arg_vars) = splitInHalf arg_vars - (us', l_alt_rhs, l_to_pat, l_to_body_fn) = mk_prod_stuff (us+1) l_arg_vars - (us'', r_alt_rhs, r_to_pat, r_to_body_fn) = mk_prod_stuff us' r_arg_vars - pat = nlConPat crossDataCon_RDR [l_to_pat, r_to_pat] - -splitInHalf :: [a] -> ([a],[a]) -splitInHalf list = (left, right) - where - half = length list `div` 2 - left = take half list - right = drop half list + n_args = dataConSourceArity datacon -- Existentials already excluded -mkGenericLocal :: US -> RdrName -mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u)) + datacon_vars = map mkGenericLocal [us .. us+n_args-1] + us' = us + n_args -mkGenericNames :: TyCon -> (RdrName, RdrName) -mkGenericNames tycon - = (from_RDR, to_RDR) + datacon_rdr = getRdrName datacon + app_exp = nlHsVarApps datacon_rdr datacon_vars + + from_alt = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs) + from_alt_rhs = mkM1_E (genLR_E i n (mkProd_E us' datacon_vars)) + + to_alt = (mkM1_P (genLR_P i n (mkProd_P us' datacon_vars)), to_alt_rhs) + -- These M1s are meta-information for the datatype + to_alt_rhs = app_exp + +-- Generates the L1/R1 sum pattern +genLR_P :: Int -> Int -> LPat RdrName -> LPat RdrName +genLR_P i n p + | n == 0 = error "impossible" + | n == 1 = p + | i <= div n 2 = nlConPat l1DataCon_RDR [genLR_P i (div n 2) p] + | otherwise = nlConPat r1DataCon_RDR [genLR_P (i-m) (n-m) p] + where m = div n 2 + +-- Generates the L1/R1 sum expression +genLR_E :: Int -> Int -> LHsExpr RdrName -> LHsExpr RdrName +genLR_E i n e + | n == 0 = error "impossible" + | n == 1 = e + | i <= div n 2 = nlHsVar l1DataCon_RDR `nlHsApp` genLR_E i (div n 2) e + | otherwise = nlHsVar r1DataCon_RDR `nlHsApp` genLR_E (i-m) (n-m) e + where m = div n 2 + +-------------------------------------------------------------------------------- +-- Dealing with products +-------------------------------------------------------------------------------- + +-- Build a product expression +mkProd_E :: US -- Base for unique names + -> [RdrName] -- List of variables matched on the lhs + -> LHsExpr RdrName -- Resulting product expression +mkProd_E _ [] = mkM1_E (nlHsVar u1DataCon_RDR) +mkProd_E _ vars = mkM1_E (foldBal prod appVars) + -- These M1s are meta-information for the constructor where - tc_name = tyConName tycon - tc_occ = nameOccName tc_name - tc_mod = ASSERT( isExternalName tc_name ) nameModule tc_name - from_RDR = mkOrig tc_mod (mkGenOcc1 tc_occ) - to_RDR = mkOrig tc_mod (mkGenOcc2 tc_occ) -\end{code} - -%************************************************************************ -%* * -\subsection{Generating the RHS of a generic default method} -%* * -%************************************************************************ + appVars = map wrapArg_E vars + prod a b = prodDataCon_RDR `nlHsApps` [a,b] -Generating the Generic default method. Uses the bimaps to generate the -actual method. All of this is rather incomplete, but it would be nice -to make even this work. Example - - class Foo a where - op :: Op a - - instance Foo T - -Then we fill in the RHS for op, RenamedHsExpr, by calling mkGenericRhs: - - instance Foo T where - op = - -To do this, we generate a pair of RenamedHsExprs (EP toOp fromOp), where - - toOp :: Op Trep -> Op T - fromOp :: Op T -> Op Trep - -(the bimap) and then fill in the RHS with - - instance Foo T where - op = toOp op - -Remember, we're generating a RenamedHsExpr, so the result of all this -will be fed to the type checker. So the 'op' on the RHS will be -at the representation type for T, Trep. - - -Note [Polymorphic methods] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Suppose the class op is polymorphic: - - class Baz a where - op :: forall b. Ord b => a -> b -> b - -Then we can still generate a bimap with - - toOP :: forall b. (Trep -> b -> b) -> (T -> b -> b) - -and fill in the instance decl thus - - instance Foo T where - op = toOp op +wrapArg_E :: RdrName -> LHsExpr RdrName +wrapArg_E v = mkM1_E (k1DataCon_RDR `nlHsVarApps` [v]) + -- This M1 is meta-information for the selector + +-- Build a product pattern +mkProd_P :: US -- Base for unique names + -> [RdrName] -- List of variables to match + -> LPat RdrName -- Resulting product pattern +mkProd_P _ [] = mkM1_P (nlNullaryConPat u1DataCon_RDR) +mkProd_P _ vars = mkM1_P (foldBal prod appVars) + -- These M1s are meta-information for the constructor + where + appVars = map wrapArg_P vars + prod a b = prodDataCon_RDR `nlConPat` [a,b] + +wrapArg_P :: RdrName -> LPat RdrName +wrapArg_P v = mkM1_P (k1DataCon_RDR `nlConVarPat` [v]) + -- This M1 is meta-information for the selector -By the time the type checker has done its stuff we'll get +mkGenericLocal :: US -> RdrName +mkGenericLocal u = mkVarUnqual (mkFastString ("g" ++ show u)) - instance Foo T where - op = \b. \dict::Ord b. toOp b (op Trep b dict) +mkM1_E :: LHsExpr RdrName -> LHsExpr RdrName +mkM1_E e = nlHsVar m1DataCon_RDR `nlHsApp` e -Note [Higher rank methods] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -Higher-rank method types don't work, because we'd generate a bimap that -needs impredicative polymorphism. In principle that should be possible -(with boxy types and all) but it would take a bit of working out. Here's -an example: - class ChurchEncode k where - match :: k -> z - -> (forall a b z. a -> b -> z) {- product -} - -> (forall a z. a -> z) {- left -} - -> (forall a z. a -> z) {- right -} - -> z - - match {| Unit |} Unit unit prod left right = unit - match {| a :*: b |} (x :*: y) unit prod left right = prod x y - match {| a :+: b |} (Inl l) unit prod left right = left l - match {| a :+: b |} (Inr r) unit prod left right = right r +mkM1_P :: LPat RdrName -> LPat RdrName +mkM1_P p = m1DataCon_RDR `nlConPat` [p] -\begin{code} -mkGenericRhs :: Id -> TyVar -> TyCon -> LHsExpr RdrName -mkGenericRhs sel_id tyvar tycon - = ASSERT( isSingleton ctxt ) -- Checks shape of selector-id context --- pprTrace "mkGenericRhs" (vcat [ppr sel_id, ppr (idType sel_id), ppr tyvar, ppr tycon, ppr local_tvs, ppr final_ty]) $ - mkHsApp (toEP bimap) (nlHsVar (getRdrName sel_id)) - where - -- Initialising the "Environment" with the from/to functions - -- on the datatype (actually tycon) in question - (from_RDR, to_RDR) = mkGenericNames tycon - - -- Instantiate the selector type, and strip off its class context - (ctxt, op_ty) = tcSplitPhiTy (applyTy (idType sel_id) (mkTyVarTy tyvar)) - - -- Do it again! This deals with the case where the method type - -- is polymorphic -- see Note [Polymorphic methods] above - (local_tvs,_,final_ty) = tcSplitSigmaTy op_ty - - -- Now we probably have a tycon in front - -- of us, quite probably a FunTyCon. - ep = EP (nlHsVar from_RDR) (nlHsVar to_RDR) - bimap = generate_bimap (tyvar, ep, local_tvs) final_ty - -type EPEnv = (TyVar, -- The class type variable - EP (LHsExpr RdrName), -- The EP it maps to - [TyVar] -- Other in-scope tyvars; they have an identity EP - ) - -------------------- -generate_bimap :: EPEnv - -> Type - -> EP (LHsExpr RdrName) --- Top level case - splitting the TyCon. -generate_bimap env@(tv,ep,local_tvs) ty - | all (`elem` local_tvs) (varSetElems (tyVarsOfType ty)) - = idEP -- A constant type - - | Just tv1 <- getTyVar_maybe ty - = ASSERT( tv == tv1 ) ep -- The class tyvar - - | Just (tycon, ty_args) <- tcSplitTyConApp_maybe ty - = bimapTyCon tycon (map (generate_bimap env) ty_args) - - | otherwise - = pprPanic "generate_bimap" (ppr ty) - -------------------- -bimapTyCon :: TyCon -> [EP (LHsExpr RdrName)] -> EP (LHsExpr RdrName) -bimapTyCon tycon arg_eps - | tycon == funTyCon = bimapArrow arg_eps - | tycon == listTyCon = bimapList arg_eps - | isBoxedTupleTyCon tycon = bimapTuple arg_eps - | otherwise = pprPanic "bimapTyCon" (ppr tycon) - -------------------- --- bimapArrow :: [EP a a', EP b b'] -> EP (a->b) (a'->b') -bimapArrow :: [EP (LHsExpr RdrName)] -> EP (LHsExpr RdrName) -bimapArrow [ep1, ep2] - = EP { fromEP = mkHsLam [nlVarPat a_RDR, nlVarPat b_RDR] from_body, - toEP = mkHsLam [nlVarPat a_RDR, nlVarPat b_RDR] to_body } - where - from_body = fromEP ep2 `mkHsApp` (mkHsPar $ nlHsVar a_RDR `mkHsApp` (mkHsPar $ toEP ep1 `mkHsApp` nlHsVar b_RDR)) - to_body = toEP ep2 `mkHsApp` (mkHsPar $ nlHsVar a_RDR `mkHsApp` (mkHsPar $ fromEP ep1 `mkHsApp` nlHsVar b_RDR)) +-- | Variant of foldr1 for producing balanced lists +foldBal :: (a -> a -> a) -> [a] -> a +foldBal op = foldBal' op (error "foldBal: empty list") + +foldBal' :: (a -> a -> a) -> a -> [a] -> a +foldBal' _ x [] = x +foldBal' _ _ [y] = y +foldBal' op x l = let (a,b) = splitAt (length l `div` 2) l + in foldBal' op x a `op` foldBal' op x b -------------------- --- bimapTuple :: [EP a1 b1, ... EP an bn] -> EP (a1,...an) (b1,..bn) -bimapTuple :: [EP (LHsExpr RdrName)] -> EP (LHsExpr RdrName) -bimapTuple eps - = EP { fromEP = mkHsLam [noLoc tuple_pat] from_body, - toEP = mkHsLam [noLoc tuple_pat] to_body } - where - names = takeList eps gs_RDR - tuple_pat = TuplePat (map nlVarPat names) Boxed placeHolderType - eps_w_names = eps `zip` names - to_body = mkLHsTupleExpr [toEP ep `mkHsApp` nlHsVar g | (ep,g) <- eps_w_names] - from_body = mkLHsTupleExpr [fromEP ep `mkHsApp` nlHsVar g | (ep,g) <- eps_w_names] - -------------------- --- bimapList :: EP a b -> EP [a] [b] -bimapList :: [EP (LHsExpr RdrName)] -> EP (LHsExpr RdrName) -bimapList [ep] - = EP { fromEP = nlHsApp (nlHsVar map_RDR) (fromEP ep), - toEP = nlHsApp (nlHsVar map_RDR) (toEP ep) } - -------------------- -a_RDR, b_RDR :: RdrName -a_RDR = mkVarUnqual (fsLit "a") -b_RDR = mkVarUnqual (fsLit "b") - -gs_RDR :: [RdrName] -gs_RDR = [ mkVarUnqual (mkFastString ("g"++show i)) | i <- [(1::Int) .. ] ] - -idEP :: EP (LHsExpr RdrName) -idEP = EP idexpr idexpr - where - idexpr = mkHsLam [nlVarPat a_RDR] (nlHsVar a_RDR) \end{code} diff -Nru ghc-7.0.3/compiler/types/InstEnv.lhs ghc-7.2.1/compiler/types/InstEnv.lhs --- ghc-7.0.3/compiler/types/InstEnv.lhs 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/types/InstEnv.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -46,21 +46,21 @@ \begin{code} data Instance - = Instance { is_cls :: Name -- Class name - - -- Used for "rough matching"; see Note [Rough-match field] - -- INVARIANT: is_tcs = roughMatchTcs is_tys - , is_tcs :: [Maybe Name] -- Top of type args - - -- Used for "proper matching"; see Note [Proper-match fields] - , is_tvs :: TyVarSet -- Template tyvars for full match - , is_tys :: [Type] -- Full arg types - -- INVARIANT: is_dfun Id has type - -- forall is_tvs. (...) => is_cls is_tys - - , is_dfun :: DFunId -- See Note [Haddock assumptions] - , is_flag :: OverlapFlag -- See detailed comments with - -- the decl of BasicTypes.OverlapFlag + = Instance { is_cls :: Name -- Class name + + -- Used for "rough matching"; see Note [Rough-match field] + -- INVARIANT: is_tcs = roughMatchTcs is_tys + , is_tcs :: [Maybe Name] -- Top of type args + + -- Used for "proper matching"; see Note [Proper-match fields] + , is_tvs :: TyVarSet -- Template tyvars for full match + , is_tys :: [Type] -- Full arg types + -- INVARIANT: is_dfun Id has type + -- forall is_tvs. (...) => is_cls is_tys + + , is_dfun :: DFunId -- See Note [Haddock assumptions] + , is_flag :: OverlapFlag -- See detailed comments with + -- the decl of BasicTypes.OverlapFlag } \end{code} @@ -119,7 +119,7 @@ setInstanceDFunId :: Instance -> DFunId -> Instance setInstanceDFunId ispec dfun - = ASSERT( idType dfun `tcEqType` idType (is_dfun ispec) ) + = ASSERT( idType dfun `eqType` idType (is_dfun ispec) ) -- We need to create the cached fields afresh from -- the new dfun id. In particular, the is_tvs in -- the Instance must match those in the dfun! @@ -128,7 +128,7 @@ -- are ok; hence the assert ispec { is_dfun = dfun, is_tvs = mkVarSet tvs, is_tys = tys } where - (tvs, _, tys) = tcSplitDFunTy (idType dfun) + (tvs, _, _, tys) = tcSplitDFunTy (idType dfun) instanceRoughTcs :: Instance -> [Maybe Name] instanceRoughTcs = is_tcs @@ -151,12 +151,8 @@ pprInstanceHdr :: Instance -> SDoc -- Prints the Instance as an instance declaration pprInstanceHdr ispec@(Instance { is_flag = flag }) - = getPprStyle $ \ sty -> - let theta_to_print - | debugStyle sty = theta - | otherwise = drop (dfunNSilent dfun) theta - in ptext (sLit "instance") <+> ppr flag - <+> sep [pprThetaArrow theta_to_print, ppr res_ty] + = ptext (sLit "instance") <+> ppr flag + <+> sep [pprThetaArrowTy theta, ppr res_ty] where dfun = is_dfun ispec (_, theta, res_ty) = tcSplitSigmaTy (idType dfun) @@ -166,14 +162,11 @@ pprInstances ispecs = vcat (map pprInstance ispecs) instanceHead :: Instance -> ([TyVar], ThetaType, Class, [Type]) --- Returns the *source* theta, without the silent arguments -instanceHead ispec - = (tvs, drop n_silent theta, cls, tys) +instanceHead ispec = (tvs, theta, cls, tys) where (tvs, theta, tau) = tcSplitSigmaTy (idType dfun) (cls, tys) = tcSplitDFunHead tau dfun = is_dfun ispec - n_silent = dfunNSilent dfun mkLocalInstance :: DFunId -> OverlapFlag @@ -184,7 +177,7 @@ is_tvs = mkVarSet tvs, is_tys = tys, is_cls = className cls, is_tcs = roughMatchTcs tys } where - (tvs, cls, tys) = tcSplitDFunTy (idType dfun) + (tvs, _, cls, tys) = tcSplitDFunTy (idType dfun) mkImportedInstance :: Name -> [Maybe Name] -> DFunId -> OverlapFlag -> Instance @@ -195,7 +188,7 @@ is_tvs = mkVarSet tvs, is_tys = tys, is_cls = cls, is_tcs = mb_tcs } where - (tvs, _, tys) = tcSplitDFunTy (idType dfun) + (tvs, _, _, tys) = tcSplitDFunTy (idType dfun) roughMatchTcs :: [Type] -> [Maybe Name] roughMatchTcs tys = map rough tys @@ -357,14 +350,11 @@ --------------------------------------------------- type InstEnv = UniqFM ClsInstEnv -- Maps Class to instances for that class -data ClsInstEnv +newtype ClsInstEnv = ClsIE [Instance] -- The instances for a particular class, in any order - Bool -- True <=> there is an instance of form C a b c - -- If *not* then the common case of looking up - -- (C a b c) can fail immediately instance Outputable ClsInstEnv where - ppr (ClsIE is b) = ptext (sLit "ClsIE") <+> ppr b <+> pprInstances is + ppr (ClsIE is) = pprInstances is -- INVARIANTS: -- * The is_tvs are distinct in each Instance @@ -379,26 +369,24 @@ emptyInstEnv = emptyUFM instEnvElts :: InstEnv -> [Instance] -instEnvElts ie = [elt | ClsIE elts _ <- eltsUFM ie, elt <- elts] +instEnvElts ie = [elt | ClsIE elts <- eltsUFM ie, elt <- elts] classInstances :: (InstEnv,InstEnv) -> Class -> [Instance] classInstances (pkg_ie, home_ie) cls = get home_ie ++ get pkg_ie where get env = case lookupUFM env cls of - Just (ClsIE insts _) -> insts - Nothing -> [] + Just (ClsIE insts) -> insts + Nothing -> [] extendInstEnvList :: InstEnv -> [Instance] -> InstEnv extendInstEnvList inst_env ispecs = foldl extendInstEnv inst_env ispecs extendInstEnv :: InstEnv -> Instance -> InstEnv -extendInstEnv inst_env ins_item@(Instance { is_cls = cls_nm, is_tcs = mb_tcs }) - = addToUFM_C add inst_env cls_nm (ClsIE [ins_item] ins_tyvar) +extendInstEnv inst_env ins_item@(Instance { is_cls = cls_nm }) + = addToUFM_C add inst_env cls_nm (ClsIE [ins_item]) where - add (ClsIE cur_insts cur_tyvar) _ = ClsIE (ins_item : cur_insts) - (ins_tyvar || cur_tyvar) - ins_tyvar = not (any isJust mb_tcs) + add (ClsIE cur_insts) _ = ClsIE (ins_item : cur_insts) \end{code} @@ -437,7 +425,9 @@ lookupInstEnv :: (InstEnv, InstEnv) -- External and home package inst-env -> Class -> [Type] -- What we are looking for -> ([InstMatch], -- Successful matches - [Instance]) -- These don't match but do unify + [Instance], -- These don't match but do unify + Bool) -- True if error condition caused by + -- Safe Haskell condition. -- The second component of the result pair happens when we look up -- Foo [a] @@ -447,10 +437,10 @@ -- Then which we choose would depend on the way in which 'a' -- is instantiated. So we report that Foo [b] is a match (mapping b->a) -- but Foo [Int] is a unifier. This gives the caller a better chance of --- giving a suitable error messagen +-- giving a suitable error message lookupInstEnv (pkg_ie, home_ie) cls tys - = (pruned_matches, all_unifs) + = (safe_matches, all_unifs, safe_fail) where rough_tcs = roughMatchTcs tys all_tvs = all isNothing rough_tcs @@ -459,30 +449,49 @@ all_matches = home_matches ++ pkg_matches all_unifs = home_unifs ++ pkg_unifs pruned_matches = foldr insert_overlapping [] all_matches + (safe_matches, safe_fail) = if length pruned_matches == 1 + then check_safe (head pruned_matches) all_matches + else (pruned_matches, False) -- Even if the unifs is non-empty (an error situation) -- we still prune the matches, so that the error message isn't -- misleading (complaining of multiple matches when some should be -- overlapped away) + -- Safe Haskell: We restrict code compiled in 'Safe' mode from + -- overriding code compiled in any other mode. The rational is + -- that code compiled in 'Safe' mode is code that is untrusted + -- by the ghc user. So we shouldn't let that code change the + -- behaviour of code the user didn't compile in 'Safe' mode + -- since thats the code they trust. So 'Safe' instances can only + -- overlap instances from the same module. A same instance origin + -- policy for safe compiled instances. + check_safe match@(inst,_) others + = case isSafeOverlap (is_flag inst) of + -- most specific isn't from a Safe module so OK + False -> ([match], False) + -- otherwise we make sure it only overlaps instances from + -- the same module + True -> (go [] others, True) + where + go bad [] = match:bad + go bad (i@(x,_):unchecked) = + if inSameMod x + then go bad unchecked + else go (i:bad) unchecked + + inSameMod b = + let na = getName $ getName inst + la = isInternalName na + nb = getName $ getName b + lb = isInternalName nb + in (la && lb) || (nameModule na == nameModule nb) + -------------- lookup env = case lookupUFM env cls of Nothing -> ([],[]) -- No instances for this class - Just (ClsIE insts has_tv_insts) - | all_tvs && not has_tv_insts - -> ([],[]) -- Short cut for common case - -- The thing we are looking up is of form (C a b c), and - -- the ClsIE has no instances of that form, so don't bother to search - - | otherwise - -> find [] [] insts + Just (ClsIE insts) -> find [] [] insts -------------- - lookup_tv :: TvSubst -> TyVar -> Either TyVar Type - -- See Note [InstTypes: instantiating types] - lookup_tv subst tv = case lookupTyVar subst tv of - Just ty -> Right ty - Nothing -> Left tv - find ms us [] = (ms, us) find ms us (item@(Instance { is_tcs = mb_tcs, is_tvs = tpl_tvs, is_tys = tpl_tys, is_flag = oflag, @@ -499,8 +508,8 @@ find ((item, map (lookup_tv subst) dfun_tvs) : ms) us rest -- Does not match, so next check whether the things unify - -- See Note [overlapping instances] above - | Incoherent <- oflag + -- See Note [Overlapping instances] above + | Incoherent _ <- oflag = find ms us rest | otherwise @@ -514,6 +523,13 @@ Just _ -> find ms (item:us) rest Nothing -> find ms us rest + ---------------- + lookup_tv :: TvSubst -> TyVar -> Either TyVar Type + -- See Note [InstTypes: instantiating types] + lookup_tv subst tv = case lookupTyVar subst tv of + Just ty -> Right ty + Nothing -> Left tv + --------------- --------------- insert_overlapping :: InstMatch -> [InstMatch] -> [InstMatch] @@ -533,14 +549,18 @@ old_beats_new = item `beats` new_item (instA, _) `beats` (instB, _) - = overlap_ok && - isJust (tcMatchTys (is_tvs instB) (is_tys instB) (is_tys instA)) - -- A beats B if A is more specific than B, and B admits overlap - -- I.e. if B can be instantiated to match A - where - overlap_ok = case is_flag instB of - NoOverlap -> False - _ -> True + = overlap_ok && + isJust (tcMatchTys (is_tvs instB) (is_tys instB) (is_tys instA)) + -- A beats B if A is more specific than B, + -- (ie. if B can be instantiated to match A) + -- and overlap is permitted + where + -- Overlap permitted if *either* instance permits overlap + -- This is a change (Trac #3877, Dec 10). It used to + -- require that instB (the less specific one) permitted overlap. + overlap_ok = case (is_flag instA, is_flag instB) of + (NoOverlap _, NoOverlap _) -> False + _ -> True \end{code} diff -Nru ghc-7.0.3/compiler/types/Kind.lhs ghc-7.2.1/compiler/types/Kind.lhs --- ghc-7.0.3/compiler/types/Kind.lhs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/compiler/types/Kind.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -0,0 +1,235 @@ +% +% (c) The University of Glasgow 2006 +% + +\begin{code} +module Kind ( + -- * Main data type + Kind, typeKind, + + -- Kinds + liftedTypeKind, unliftedTypeKind, openTypeKind, + argTypeKind, ubxTupleKind, + mkArrowKind, mkArrowKinds, + + -- Kind constructors... + liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon, + argTypeKindTyCon, ubxTupleKindTyCon, + + -- Super Kinds + tySuperKind, tySuperKindTyCon, + + pprKind, pprParendKind, + + -- ** Deconstructing Kinds + kindFunResult, kindAppResult, synTyConResKind, + splitKindFunTys, splitKindFunTysN, splitKindFunTy_maybe, + + -- ** Predicates on Kinds + isLiftedTypeKind, isUnliftedTypeKind, isOpenTypeKind, + isUbxTupleKind, isArgTypeKind, isKind, isTySuperKind, + isSuperKind, isCoercionKind, + isLiftedTypeKindCon, + + isSubArgTypeKind, isSubOpenTypeKind, isSubKind, defaultKind, + isSubKindCon, + + ) where + +#include "HsVersions.h" + +import TypeRep +import TysPrim +import TyCon +import Var +import PrelNames +import Outputable +\end{code} + +%************************************************************************ +%* * + Predicates over Kinds +%* * +%************************************************************************ + +\begin{code} +isTySuperKind :: SuperKind -> Bool +isTySuperKind (TyConApp kc []) = kc `hasKey` tySuperKindTyConKey +isTySuperKind _ = False + +------------------- +-- Lastly we need a few functions on Kinds + +isLiftedTypeKindCon :: TyCon -> Bool +isLiftedTypeKindCon tc = tc `hasKey` liftedTypeKindTyConKey +\end{code} + +%************************************************************************ +%* * + The kind of a type +%* * +%************************************************************************ + +\begin{code} +typeKind :: Type -> Kind +typeKind _ty@(TyConApp tc tys) + = ASSERT2( not (tc `hasKey` eqPredPrimTyConKey) || length tys == 2, ppr _ty ) + -- Assertion checks for unsaturated application of (~) + -- See Note [The (~) TyCon] in TysPrim + kindAppResult (tyConKind tc) tys + +typeKind (PredTy pred) = predKind pred +typeKind (AppTy fun _) = kindFunResult (typeKind fun) +typeKind (ForAllTy _ ty) = typeKind ty +typeKind (TyVarTy tyvar) = tyVarKind tyvar +typeKind (FunTy _arg res) + -- Hack alert. The kind of (Int -> Int#) is liftedTypeKind (*), + -- not unliftedTypKind (#) + -- The only things that can be after a function arrow are + -- (a) types (of kind openTypeKind or its sub-kinds) + -- (b) kinds (of super-kind TY) (e.g. * -> (* -> *)) + | isTySuperKind k = k + | otherwise = ASSERT( isSubOpenTypeKind k) liftedTypeKind + where + k = typeKind res + +------------------ +predKind :: PredType -> Kind +predKind (EqPred {}) = unliftedTypeKind -- Coercions are unlifted +predKind (ClassP {}) = liftedTypeKind -- Class and implicitPredicates are +predKind (IParam {}) = liftedTypeKind -- always represented by lifted types +\end{code} + +%************************************************************************ +%* * + Functions over Kinds +%* * +%************************************************************************ + +\begin{code} +-- | Essentially 'funResultTy' on kinds +kindFunResult :: Kind -> Kind +kindFunResult (FunTy _ res) = res +kindFunResult k = pprPanic "kindFunResult" (ppr k) + +kindAppResult :: Kind -> [arg] -> Kind +kindAppResult k [] = k +kindAppResult k (_:as) = kindAppResult (kindFunResult k) as + +-- | Essentially 'splitFunTys' on kinds +splitKindFunTys :: Kind -> ([Kind],Kind) +splitKindFunTys (FunTy a r) = case splitKindFunTys r of + (as, k) -> (a:as, k) +splitKindFunTys k = ([], k) + +splitKindFunTy_maybe :: Kind -> Maybe (Kind,Kind) +splitKindFunTy_maybe (FunTy a r) = Just (a,r) +splitKindFunTy_maybe _ = Nothing + +-- | Essentially 'splitFunTysN' on kinds +splitKindFunTysN :: Int -> Kind -> ([Kind],Kind) +splitKindFunTysN 0 k = ([], k) +splitKindFunTysN n (FunTy a r) = case splitKindFunTysN (n-1) r of + (as, k) -> (a:as, k) +splitKindFunTysN n k = pprPanic "splitKindFunTysN" (ppr n <+> ppr k) + +-- | Find the result 'Kind' of a type synonym, +-- after applying it to its 'arity' number of type variables +-- Actually this function works fine on data types too, +-- but they'd always return '*', so we never need to ask +synTyConResKind :: TyCon -> Kind +synTyConResKind tycon = kindAppResult (tyConKind tycon) (tyConTyVars tycon) + +-- | See "Type#kind_subtyping" for details of the distinction between these 'Kind's +isUbxTupleKind, isOpenTypeKind, isArgTypeKind, isUnliftedTypeKind :: Kind -> Bool +isOpenTypeKindCon, isUbxTupleKindCon, isArgTypeKindCon, + isUnliftedTypeKindCon, isSubArgTypeKindCon :: TyCon -> Bool + +isOpenTypeKindCon tc = tyConUnique tc == openTypeKindTyConKey + +isOpenTypeKind (TyConApp tc _) = isOpenTypeKindCon tc +isOpenTypeKind _ = False + +isUbxTupleKindCon tc = tyConUnique tc == ubxTupleKindTyConKey + +isUbxTupleKind (TyConApp tc _) = isUbxTupleKindCon tc +isUbxTupleKind _ = False + +isArgTypeKindCon tc = tyConUnique tc == argTypeKindTyConKey + +isArgTypeKind (TyConApp tc _) = isArgTypeKindCon tc +isArgTypeKind _ = False + +isUnliftedTypeKindCon tc = tyConUnique tc == unliftedTypeKindTyConKey + +isUnliftedTypeKind (TyConApp tc _) = isUnliftedTypeKindCon tc +isUnliftedTypeKind _ = False + +isSubOpenTypeKind :: Kind -> Bool +-- ^ True of any sub-kind of OpenTypeKind (i.e. anything except arrow) +isSubOpenTypeKind (FunTy k1 k2) = ASSERT2 ( isKind k1, text "isSubOpenTypeKind" <+> ppr k1 <+> text "::" <+> ppr (typeKind k1) ) + ASSERT2 ( isKind k2, text "isSubOpenTypeKind" <+> ppr k2 <+> text "::" <+> ppr (typeKind k2) ) + False +isSubOpenTypeKind (TyConApp kc []) = ASSERT( isKind (TyConApp kc []) ) True +isSubOpenTypeKind other = ASSERT( isKind other ) False + -- This is a conservative answer + -- It matters in the call to isSubKind in + -- checkExpectedKind. + +isSubArgTypeKindCon kc + | isUnliftedTypeKindCon kc = True + | isLiftedTypeKindCon kc = True + | isArgTypeKindCon kc = True + | otherwise = False + +isSubArgTypeKind :: Kind -> Bool +-- ^ True of any sub-kind of ArgTypeKind +isSubArgTypeKind (TyConApp kc []) = isSubArgTypeKindCon kc +isSubArgTypeKind _ = False + +-- | Is this a super-kind (i.e. a type-of-kinds)? +isSuperKind :: Type -> Bool +isSuperKind (TyConApp (skc) []) = isSuperKindTyCon skc +isSuperKind _ = False + +-- | Is this a kind (i.e. a type-of-types)? +isKind :: Kind -> Bool +isKind k = isSuperKind (typeKind k) + +isSubKind :: Kind -> Kind -> Bool +-- ^ @k1 \`isSubKind\` k2@ checks that @k1@ <: @k2@ +isSubKind (TyConApp kc1 []) (TyConApp kc2 []) = kc1 `isSubKindCon` kc2 +isSubKind (FunTy a1 r1) (FunTy a2 r2) = (a2 `isSubKind` a1) && (r1 `isSubKind` r2) +isSubKind _ _ = False + +isSubKindCon :: TyCon -> TyCon -> Bool +-- ^ @kc1 \`isSubKindCon\` kc2@ checks that @kc1@ <: @kc2@ +isSubKindCon kc1 kc2 + | isLiftedTypeKindCon kc1 && isLiftedTypeKindCon kc2 = True + | isUnliftedTypeKindCon kc1 && isUnliftedTypeKindCon kc2 = True + | isUbxTupleKindCon kc1 && isUbxTupleKindCon kc2 = True + | isOpenTypeKindCon kc2 = True + -- we already know kc1 is not a fun, its a TyCon + | isArgTypeKindCon kc2 && isSubArgTypeKindCon kc1 = True + | otherwise = False + +defaultKind :: Kind -> Kind +-- ^ Used when generalising: default kind ? and ?? to *. See "Type#kind_subtyping" for more +-- information on what that means + +-- When we generalise, we make generic type variables whose kind is +-- simple (* or *->* etc). So generic type variables (other than +-- built-in constants like 'error') always have simple kinds. This is important; +-- consider +-- f x = True +-- We want f to get type +-- f :: forall (a::*). a -> Bool +-- Not +-- f :: forall (a::??). a -> Bool +-- because that would allow a call like (f 3#) as well as (f True), +--and the calling conventions differ. This defaulting is done in TcMType.zonkTcTyVarBndr. +defaultKind k + | isSubOpenTypeKind k = liftedTypeKind + | isSubArgTypeKind k = liftedTypeKind + | otherwise = k +\end{code} \ No newline at end of file diff -Nru ghc-7.0.3/compiler/types/OptCoercion.lhs ghc-7.2.1/compiler/types/OptCoercion.lhs --- ghc-7.0.3/compiler/types/OptCoercion.lhs 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/types/OptCoercion.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -1,453 +1,374 @@ -% -% (c) The University of Glasgow 2006 -% - -\begin{code} -{-# OPTIONS_GHC -w #-} -module OptCoercion ( - optCoercion - ) where - -#include "HsVersions.h" - -import Unify ( tcMatchTy ) -import Coercion -import Type -import TypeRep -import TyCon -import Var -import VarSet -import VarEnv -import PrelNames -import Util -import Outputable -\end{code} - -%************************************************************************ -%* * - Optimising coercions -%* * -%************************************************************************ - -Note [Subtle shadowing in coercions] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Supose we optimising a coercion - optCoercion (forall (co_X5:t1~t2). ...co_B1...) -The co_X5 is a wild-card; the bound variable of a coercion for-all -should never appear in the body of the forall. Indeed we often -write it like this - optCoercion ( (t1~t2) => ...co_B1... ) - -Just because it's a wild-card doesn't mean we are free to choose -whatever variable we like. For example it'd be wrong for optCoercion -to return - forall (co_B1:t1~t2). ...co_B1... -because now the co_B1 (which is really free) has been captured, and -subsequent substitutions will go wrong. That's why we can't use -mkCoPredTy in the ForAll case, where this note appears. - -\begin{code} -optCoercion :: TvSubst -> Coercion -> NormalCo --- ^ optCoercion applies a substitution to a coercion, --- *and* optimises it to reduce its size -optCoercion env co = opt_co env False co - -type NormalCo = Coercion - -- Invariants: - -- * The substitution has been fully applied - -- * For trans coercions (co1 `trans` co2) - -- co1 is not a trans, and neither co1 nor co2 is identity - -- * If the coercion is the identity, it has no CoVars of CoTyCons in it (just types) - -type NormalNonIdCo = NormalCo -- Extra invariant: not the identity - -opt_co, opt_co' :: TvSubst - -> Bool -- True <=> return (sym co) - -> Coercion - -> NormalCo -opt_co = opt_co' - -{- Debuggery -opt_co env sym co --- = pprTrace "opt_co {" (ppr sym <+> ppr co) $ --- co1 `seq` --- pprTrace "opt_co done }" (ppr co1) --- WARN( not same_co_kind, ppr co <+> dcolon <+> pprEqPred (s1,t1) --- $$ ppr co1 <+> dcolon <+> pprEqPred (s2,t2) ) - = WARN( not (coreEqType co1 simple_result), - (text "env=" <+> ppr env) $$ - (text "input=" <+> ppr co) $$ - (text "simple=" <+> ppr simple_result) $$ - (text "opt=" <+> ppr co1) ) - co1 - where - co1 = opt_co' env sym co - same_co_kind = s1 `coreEqType` s2 && t1 `coreEqType` t2 - (s,t) = coercionKind (substTy env co) - (s1,t1) | sym = (t,s) - | otherwise = (s,t) - (s2,t2) = coercionKind co1 - - simple_result | sym = mkSymCoercion (substTy env co) - | otherwise = substTy env co --} - -opt_co' env sym (AppTy ty1 ty2) = mkAppTy (opt_co env sym ty1) (opt_co env sym ty2) -opt_co' env sym (FunTy ty1 ty2) = FunTy (opt_co env sym ty1) (opt_co env sym ty2) -opt_co' env sym (PredTy (ClassP cls tys)) = PredTy (ClassP cls (map (opt_co env sym) tys)) -opt_co' env sym (PredTy (IParam n ty)) = PredTy (IParam n (opt_co env sym ty)) -opt_co' _ _ co@(PredTy (EqPred {})) = pprPanic "optCoercion" (ppr co) - -opt_co' env sym co@(TyVarTy tv) - | Just ty <- lookupTyVar env tv = opt_co' (zapTvSubstEnv env) sym ty - | not (isCoVar tv) = co -- Identity; does not mention a CoVar - | ty1 `coreEqType` ty2 = ty1 -- Identity; ..ditto.. - | not sym = co - | otherwise = mkSymCoercion co - where - (ty1,ty2) = coVarKind tv - -opt_co' env sym (ForAllTy tv cor) - | isTyVar tv = case substTyVarBndr env tv of - (env', tv') -> ForAllTy tv' (opt_co' env' sym cor) - -opt_co' env sym co@(ForAllTy co_var cor) - | isCoVar co_var - = WARN( co_var `elemVarSet` tyVarsOfType cor, ppr co ) - ForAllTy co_var' cor' - where - (co1,co2) = coVarKind co_var - co1' = opt_co' env sym co1 - co2' = opt_co' env sym co2 - cor' = opt_co' env sym cor - co_var' = uniqAway (getTvInScope env) (mkWildCoVar (mkCoKind co1' co2')) - -- See Note [Subtle shadowing in coercions] - -opt_co' env sym (TyConApp tc cos) - | Just (arity, desc) <- isCoercionTyCon_maybe tc - = mkAppTys (opt_co_tc_app env sym tc desc (take arity cos)) - (map (opt_co env sym) (drop arity cos)) - | otherwise - = TyConApp tc (map (opt_co env sym) cos) - --------- -opt_co_tc_app :: TvSubst -> Bool -> TyCon -> CoTyConDesc -> [Coercion] -> NormalCo --- Used for CoercionTyCons only --- Arguments are *not* already simplified/substituted -opt_co_tc_app env sym tc desc cos - = case desc of - CoAxiom {} -- Do *not* push sym inside top-level axioms - -- e.g. if g is a top-level axiom - -- g a : F a ~ a - -- Then (sym (g ty)) /= g (sym ty) !! - | sym -> mkSymCoercion the_co - | otherwise -> the_co - where - the_co = TyConApp tc (map (opt_co env False) cos) - -- Note that the_co does *not* have sym pushed into it - - CoTrans - | sym -> opt_trans opt_co2 opt_co1 -- sym (g `o` h) = sym h `o` sym g - | otherwise -> opt_trans opt_co1 opt_co2 - - CoUnsafe - | sym -> mkUnsafeCoercion ty2' ty1' - | otherwise -> mkUnsafeCoercion ty1' ty2' - - CoSym -> opt_co env (not sym) co1 - CoLeft -> opt_lr fst - CoRight -> opt_lr snd - CoCsel1 -> opt_csel fstOf3 - CoCsel2 -> opt_csel sndOf3 - CoCselR -> opt_csel thirdOf3 - - CoInst -- See if the first arg is already a forall - -- ...then we can just extend the current substitution - | Just (tv, co1_body) <- splitForAllTy_maybe co1 - -> opt_co (extendTvSubst env tv ty2') sym co1_body - - -- See if is *now* a forall - | Just (tv, opt_co1_body) <- splitForAllTy_maybe opt_co1 - -> substTyWith [tv] [ty2'] opt_co1_body -- An inefficient one-variable substitution - - | otherwise - -> TyConApp tc [opt_co1, ty2'] - - where - (co1 : cos1) = cos - (co2 : _) = cos1 - - ty1' = substTy env co1 - ty2' = substTy env co2 - - -- These opt_cos have the sym pushed into them - opt_co1 = opt_co env sym co1 - opt_co2 = opt_co env sym co2 - - the_unary_opt_co = TyConApp tc [opt_co1] - - opt_lr sel = case splitAppTy_maybe opt_co1 of - Nothing -> the_unary_opt_co - Just lr -> sel lr - opt_csel sel = case splitCoPredTy_maybe opt_co1 of - Nothing -> the_unary_opt_co - Just lr -> sel lr - -------------- -opt_transL :: [NormalCo] -> [NormalCo] -> [NormalCo] -opt_transL = zipWith opt_trans - -opt_trans :: NormalCo -> NormalCo -> NormalCo -opt_trans co1 co2 - | isIdNormCo co1 = co2 - | otherwise = opt_trans1 co1 co2 - -opt_trans1 :: NormalNonIdCo -> NormalCo -> NormalCo --- First arg is not the identity -opt_trans1 co1 co2 - | isIdNormCo co2 = co1 - | otherwise = opt_trans2 co1 co2 - -opt_trans2 :: NormalNonIdCo -> NormalNonIdCo -> NormalCo --- Neither arg is the identity -opt_trans2 (TyConApp tc [co1a,co1b]) co2 - | tc `hasKey` transCoercionTyConKey - = opt_trans1 co1a (opt_trans2 co1b co2) - -opt_trans2 co1 co2 - | Just co <- opt_trans_rule co1 co2 - = co - -opt_trans2 co1 (TyConApp tc [co2a,co2b]) - | tc `hasKey` transCoercionTyConKey - , Just co1_2a <- opt_trans_rule co1 co2a - = if isIdNormCo co1_2a - then co2b - else opt_trans2 co1_2a co2b - -opt_trans2 co1 co2 - = mkTransCoercion co1 co2 - ------- -opt_trans_rule :: NormalNonIdCo -> NormalNonIdCo -> Maybe NormalCo -opt_trans_rule (TyConApp tc1 args1) (TyConApp tc2 args2) - | tc1 == tc2 - = case isCoercionTyCon_maybe tc1 of - Nothing - -> Just (TyConApp tc1 (opt_transL args1 args2)) - Just (arity, desc) - | arity == length args1 - -> opt_trans_rule_equal_tc desc args1 args2 - | otherwise - -> case opt_trans_rule_equal_tc desc - (take arity args1) - (take arity args2) of - Just co -> Just $ mkAppTys co $ - opt_transL (drop arity args1) (drop arity args2) - Nothing -> Nothing - --- Push transitivity inside apply -opt_trans_rule co1 co2 - | Just (co1a, co1b) <- splitAppTy_maybe co1 - , Just (co2a, co2b) <- etaApp_maybe co2 - = Just (mkAppTy (opt_trans co1a co2a) (opt_trans co1b co2b)) - - | Just (co2a, co2b) <- splitAppTy_maybe co2 - , Just (co1a, co1b) <- etaApp_maybe co1 - = Just (mkAppTy (opt_trans co1a co2a) (opt_trans co1b co2b)) - --- Push transitivity inside (s~t)=>r --- We re-use the CoVar rather than using mkCoPredTy --- See Note [Subtle shadowing in coercions] -opt_trans_rule co1 co2 - | Just (cv1,r1) <- splitForAllTy_maybe co1 - , isCoVar cv1 - , Just (s1,t1) <- coVarKind_maybe cv1 - , Just (s2,t2,r2) <- etaCoPred_maybe co2 - = Just (ForAllTy (mkCoVar (coVarName cv1) (mkCoKind (opt_trans s1 s2) (opt_trans t1 t2))) - (opt_trans r1 r2)) - - | Just (cv2,r2) <- splitForAllTy_maybe co2 - , isCoVar cv2 - , Just (s2,t2) <- coVarKind_maybe cv2 - , Just (s1,t1,r1) <- etaCoPred_maybe co1 - = Just (ForAllTy (mkCoVar (coVarName cv2) (mkCoKind (opt_trans s1 s2) (opt_trans t1 t2))) - (opt_trans r1 r2)) - --- Push transitivity inside forall -opt_trans_rule co1 co2 - | Just (tv1,r1) <- splitTypeForAll_maybe co1 - , Just (tv2,r2) <- etaForAll_maybe co2 - , let r2' = substTyWith [tv2] [TyVarTy tv1] r2 - = Just (ForAllTy tv1 (opt_trans2 r1 r2')) - - | Just (tv2,r2) <- splitTypeForAll_maybe co2 - , Just (tv1,r1) <- etaForAll_maybe co1 - , let r1' = substTyWith [tv1] [TyVarTy tv2] r1 - = Just (ForAllTy tv1 (opt_trans2 r1' r2)) - -opt_trans_rule co1 co2 -{- Omitting for now, because unsound - | Just (sym1, (ax_tc1, ax1_args, ax_tvs, ax_lhs, ax_rhs)) <- co1_is_axiom_maybe - , Just (sym2, (ax_tc2, ax2_args, _, _, _)) <- co2_is_axiom_maybe - , ax_tc1 == ax_tc2 - , sym1 /= sym2 - = Just $ - if sym1 - then substTyWith ax_tvs (opt_transL (map mkSymCoercion ax1_args) ax2_args) ax_rhs - else substTyWith ax_tvs (opt_transL ax1_args (map mkSymCoercion ax2_args)) ax_lhs --} - - | Just (sym, (ax_tc, ax_args, ax_tvs, ax_lhs, _)) <- co1_is_axiom_maybe - , Just cos <- matchesAxiomLhs ax_tvs ax_lhs co2 - = Just $ - if sym - then mkSymCoercion $ TyConApp ax_tc (opt_transL (map mkSymCoercion cos) ax_args) - else TyConApp ax_tc (opt_transL ax_args cos) - - | Just (sym, (ax_tc, ax_args, ax_tvs, ax_lhs, _)) <- isAxiom_maybe co2 - , Just cos <- matchesAxiomLhs ax_tvs ax_lhs co1 - = Just $ - if sym - then mkSymCoercion $ TyConApp ax_tc (opt_transL ax_args (map mkSymCoercion cos)) - else TyConApp ax_tc (opt_transL cos ax_args) - where - co1_is_axiom_maybe = isAxiom_maybe co1 - co2_is_axiom_maybe = isAxiom_maybe co2 - -opt_trans_rule co1 co2 -- Identity rule - | (ty1,_) <- coercionKind co1 - , (_,ty2) <- coercionKind co2 - , ty1 `coreEqType` ty2 - = Just ty2 - -opt_trans_rule _ _ = Nothing - ------------ -isAxiom_maybe :: Coercion -> Maybe (Bool, (TyCon, [Coercion], [TyVar], Type, Type)) -isAxiom_maybe co - | Just (tc, args) <- splitTyConApp_maybe co - , Just (_, desc) <- isCoercionTyCon_maybe tc - = case desc of - CoAxiom { co_ax_tvs = tvs, co_ax_lhs = lhs, co_ax_rhs = rhs } - -> Just (False, (tc, args, tvs, lhs, rhs)) - CoSym | (arg1:_) <- args - -> case isAxiom_maybe arg1 of - Nothing -> Nothing - Just (sym, stuff) -> Just (not sym, stuff) - _ -> Nothing - | otherwise - = Nothing - -matchesAxiomLhs :: [TyVar] -> Type -> Type -> Maybe [Type] -matchesAxiomLhs tvs ty_tmpl ty - = case tcMatchTy (mkVarSet tvs) ty_tmpl ty of - Nothing -> Nothing - Just subst -> Just (map (substTyVar subst) tvs) - ------------ -opt_trans_rule_equal_tc :: CoTyConDesc -> [Coercion] -> [Coercion] -> Maybe Coercion --- Rules for Coercion TyCons only - --- Push transitivity inside instantiation -opt_trans_rule_equal_tc desc [co1,ty1] [co2,ty2] - | CoInst <- desc - , ty1 `coreEqType` ty2 - , co1 `compatible_co` co2 - = Just (mkInstCoercion (opt_trans2 co1 co2) ty1) - -opt_trans_rule_equal_tc desc [co1] [co2] - | CoLeft <- desc, is_compat = Just (mkLeftCoercion res_co) - | CoRight <- desc, is_compat = Just (mkRightCoercion res_co) - | CoCsel1 <- desc, is_compat = Just (mkCsel1Coercion res_co) - | CoCsel2 <- desc, is_compat = Just (mkCsel2Coercion res_co) - | CoCselR <- desc, is_compat = Just (mkCselRCoercion res_co) - where - is_compat = co1 `compatible_co` co2 - res_co = opt_trans2 co1 co2 - -opt_trans_rule_equal_tc _ _ _ = Nothing - -------------- -compatible_co :: Coercion -> Coercion -> Bool --- Check whether (co1 . co2) will be well-kinded -compatible_co co1 co2 - = x1 `coreEqType` x2 - where - (_,x1) = coercionKind co1 - (x2,_) = coercionKind co2 - -------------- -etaForAll_maybe :: Coercion -> Maybe (TyVar, Coercion) --- Try to make the coercion be of form (forall tv. co) -etaForAll_maybe co - | Just (tv, r) <- splitForAllTy_maybe co - , not (isCoVar tv) -- Check it is a *type* forall, not a (t1~t2)=>co - = Just (tv, r) - - | (ty1,ty2) <- coercionKind co - , Just (tv1, _) <- splitTypeForAll_maybe ty1 - , Just (tv2, _) <- splitTypeForAll_maybe ty2 - , tyVarKind tv1 `eqKind` tyVarKind tv2 - = Just (tv1, mkInstCoercion co (mkTyVarTy tv1)) - - | otherwise - = Nothing - -etaCoPred_maybe :: Coercion -> Maybe (Coercion, Coercion, Coercion) -etaCoPred_maybe co - | Just (s,t,r) <- splitCoPredTy_maybe co - = Just (s,t,r) - - -- co :: (s1~t1)=>r1 ~ (s2~t2)=>r2 - | (ty1,ty2) <- coercionKind co -- We know ty1,ty2 have same kind - , Just (s1,_,_) <- splitCoPredTy_maybe ty1 - , Just (s2,_,_) <- splitCoPredTy_maybe ty2 - , typeKind s1 `eqKind` typeKind s2 -- t1,t2 have same kinds - = Just (mkCsel1Coercion co, mkCsel2Coercion co, mkCselRCoercion co) - - | otherwise - = Nothing - -etaApp_maybe :: Coercion -> Maybe (Coercion, Coercion) --- Split a coercion g :: t1a t1b ~ t2a t2b --- into (left g, right g) if possible -etaApp_maybe co - | Just (co1, co2) <- splitAppTy_maybe co - = Just (co1, co2) - - | (ty1,ty2) <- coercionKind co - , Just (ty1a, _) <- splitAppTy_maybe ty1 - , Just (ty2a, _) <- splitAppTy_maybe ty2 - , typeKind ty1a `eqKind` typeKind ty2a - = Just (mkLeftCoercion co, mkRightCoercion co) - - | otherwise - = Nothing - -------------- -splitTypeForAll_maybe :: Type -> Maybe (TyVar, Type) --- Returns Just only for a *type* forall, not a (t1~t2)=>co -splitTypeForAll_maybe ty - | Just (tv, rty) <- splitForAllTy_maybe ty - , not (isCoVar tv) - = Just (tv, rty) - - | otherwise - = Nothing - -------------- -isIdNormCo :: NormalCo -> Bool --- Cheap identity test: look for coercions with no coercion variables at all --- So it'll return False for (sym g `trans` g) -isIdNormCo ty = go ty - where - go (TyVarTy tv) = not (isCoVar tv) - go (AppTy t1 t2) = go t1 && go t2 - go (FunTy t1 t2) = go t1 && go t2 - go (ForAllTy tv ty) = go (tyVarKind tv) && go ty - go (TyConApp tc tys) = not (isCoercionTyCon tc) && all go tys - go (PredTy (IParam _ ty)) = go ty - go (PredTy (ClassP _ tys)) = all go tys - go (PredTy (EqPred t1 t2)) = go t1 && go t2 -\end{code} +% +% (c) The University of Glasgow 2006 +% + +\begin{code} +module OptCoercion ( optCoercion ) where + +#include "HsVersions.h" + +import Coercion +import Type hiding( substTyVarBndr, substTy, extendTvSubst ) +import TyCon +import Var +import VarSet +import VarEnv +import StaticFlags ( opt_NoOptCoercion ) +import Outputable +import Pair +import Maybes( allMaybes ) +import FastString +\end{code} + +%************************************************************************ +%* * + Optimising coercions +%* * +%************************************************************************ + +Note [Subtle shadowing in coercions] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Supose we optimising a coercion + optCoercion (forall (co_X5:t1~t2). ...co_B1...) +The co_X5 is a wild-card; the bound variable of a coercion for-all +should never appear in the body of the forall. Indeed we often +write it like this + optCoercion ( (t1~t2) => ...co_B1... ) + +Just because it's a wild-card doesn't mean we are free to choose +whatever variable we like. For example it'd be wrong for optCoercion +to return + forall (co_B1:t1~t2). ...co_B1... +because now the co_B1 (which is really free) has been captured, and +subsequent substitutions will go wrong. That's why we can't use +mkCoPredTy in the ForAll case, where this note appears. + +\begin{code} +optCoercion :: CvSubst -> Coercion -> NormalCo +-- ^ optCoercion applies a substitution to a coercion, +-- *and* optimises it to reduce its size +optCoercion env co + | opt_NoOptCoercion = substCo env co + | otherwise = opt_co env False co + +type NormalCo = Coercion + -- Invariants: + -- * The substitution has been fully applied + -- * For trans coercions (co1 `trans` co2) + -- co1 is not a trans, and neither co1 nor co2 is identity + -- * If the coercion is the identity, it has no CoVars of CoTyCons in it (just types) + +type NormalNonIdCo = NormalCo -- Extra invariant: not the identity + +opt_co, opt_co' :: CvSubst + -> Bool -- True <=> return (sym co) + -> Coercion + -> NormalCo +opt_co = opt_co' +{- +opt_co env sym co + = pprTrace "opt_co {" (ppr sym <+> ppr co $$ ppr env) $ + co1 `seq` + pprTrace "opt_co done }" (ppr co1) $ + (WARN( not same_co_kind, ppr co <+> dcolon <+> pprEqPred (Pair s1 t1) + $$ ppr co1 <+> dcolon <+> pprEqPred (Pair s2 t2) ) + WARN( not (coreEqCoercion co1 simple_result), + (text "env=" <+> ppr env) $$ + (text "input=" <+> ppr co) $$ + (text "simple=" <+> ppr simple_result) $$ + (text "opt=" <+> ppr co1) ) + co1) + where + co1 = opt_co' env sym co + same_co_kind = s1 `eqType` s2 && t1 `eqType` t2 + Pair s t = coercionKind (substCo env co) + (s1,t1) | sym = (t,s) + | otherwise = (s,t) + Pair s2 t2 = coercionKind co1 + + simple_result | sym = mkSymCo (substCo env co) + | otherwise = substCo env co +-} + +opt_co' env _ (Refl ty) = Refl (substTy env ty) +opt_co' env sym (SymCo co) = opt_co env (not sym) co +opt_co' env sym (TyConAppCo tc cos) = mkTyConAppCo tc (map (opt_co env sym) cos) +opt_co' env sym (AppCo co1 co2) = mkAppCo (opt_co env sym co1) (opt_co env sym co2) +opt_co' env sym (ForAllCo tv co) = case substTyVarBndr env tv of + (env', tv') -> mkForAllCo tv' (opt_co env' sym co) + -- Use the "mk" functions to check for nested Refls + +opt_co' env sym (CoVarCo cv) + | Just co <- lookupCoVar env cv + = opt_co (zapCvSubstEnv env) sym co + + | Just cv1 <- lookupInScope (getCvInScope env) cv + = ASSERT( isCoVar cv1 ) wrapSym sym (CoVarCo cv1) + -- cv1 might have a substituted kind! + + | otherwise = WARN( True, ptext (sLit "opt_co: not in scope:") <+> ppr cv $$ ppr env) + ASSERT( isCoVar cv ) + wrapSym sym (CoVarCo cv) + +opt_co' env sym (AxiomInstCo con cos) + -- Do *not* push sym inside top-level axioms + -- e.g. if g is a top-level axiom + -- g a : f a ~ a + -- then (sym (g ty)) /= g (sym ty) !! + = wrapSym sym $ AxiomInstCo con (map (opt_co env False) cos) + -- Note that the_co does *not* have sym pushed into it + +opt_co' env sym (UnsafeCo ty1 ty2) + | ty1' `eqType` ty2' = Refl ty1' + | sym = mkUnsafeCo ty2' ty1' + | otherwise = mkUnsafeCo ty1' ty2' + where + ty1' = substTy env ty1 + ty2' = substTy env ty2 + +opt_co' env sym (TransCo co1 co2) + | sym = opt_trans in_scope opt_co2 opt_co1 -- sym (g `o` h) = sym h `o` sym g + | otherwise = opt_trans in_scope opt_co1 opt_co2 + where + opt_co1 = opt_co env sym co1 + opt_co2 = opt_co env sym co2 + in_scope = getCvInScope env + +opt_co' env sym (NthCo n co) + | TyConAppCo tc cos <- co' + , isDecomposableTyCon tc -- Not synonym families + = ASSERT( n < length cos ) + cos !! n + | otherwise + = NthCo n co' + where + co' = opt_co env sym co + +opt_co' env sym (InstCo co ty) + -- See if the first arg is already a forall + -- ...then we can just extend the current substitution + | Just (tv, co_body) <- splitForAllCo_maybe co + = opt_co (extendTvSubst env tv ty') sym co_body + + -- See if it is a forall after optimization + -- If so, do an inefficient one-variable substitution + | Just (tv, co'_body) <- splitForAllCo_maybe co' + = substCoWithTy (getCvInScope env) tv ty' co'_body + + | otherwise = InstCo co' ty' + + where + co' = opt_co env sym co + ty' = substTy env ty + +------------- +opt_transList :: InScopeSet -> [NormalCo] -> [NormalCo] -> [NormalCo] +opt_transList is = zipWith (opt_trans is) + +opt_trans :: InScopeSet -> NormalCo -> NormalCo -> NormalCo +opt_trans is co1 co2 + | isReflCo co1 = co2 + | otherwise = opt_trans1 is co1 co2 + +opt_trans1 :: InScopeSet -> NormalNonIdCo -> NormalCo -> NormalCo +-- First arg is not the identity +opt_trans1 is co1 co2 + | isReflCo co2 = co1 + | otherwise = opt_trans2 is co1 co2 + +opt_trans2 :: InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> NormalCo +-- Neither arg is the identity +opt_trans2 is (TransCo co1a co1b) co2 + -- Don't know whether the sub-coercions are the identity + = opt_trans is co1a (opt_trans is co1b co2) + +opt_trans2 is co1 co2 + | Just co <- opt_trans_rule is co1 co2 + = co + +opt_trans2 is co1 (TransCo co2a co2b) + | Just co1_2a <- opt_trans_rule is co1 co2a + = if isReflCo co1_2a + then co2b + else opt_trans1 is co1_2a co2b + +opt_trans2 _ co1 co2 + = mkTransCo co1 co2 + +------ +-- Optimize coercions with a top-level use of transitivity. +opt_trans_rule :: InScopeSet -> NormalNonIdCo -> NormalNonIdCo -> Maybe NormalCo + +-- push transitivity down through matching top-level constructors. +opt_trans_rule is in_co1@(TyConAppCo tc1 cos1) in_co2@(TyConAppCo tc2 cos2) + | tc1 == tc2 = fireTransRule "PushTyConApp" in_co1 in_co2 $ + TyConAppCo tc1 (opt_transList is cos1 cos2) + +-- push transitivity through matching destructors +opt_trans_rule is in_co1@(NthCo d1 co1) in_co2@(NthCo d2 co2) + | d1 == d2 + , co1 `compatible_co` co2 + = fireTransRule "PushNth" in_co1 in_co2 $ + mkNthCo d1 (opt_trans is co1 co2) + +-- Push transitivity inside instantiation +opt_trans_rule is in_co1@(InstCo co1 ty1) in_co2@(InstCo co2 ty2) + | ty1 `eqType` ty2 + , co1 `compatible_co` co2 + = fireTransRule "TrPushInst" in_co1 in_co2 $ + mkInstCo (opt_trans is co1 co2) ty1 + +-- Push transitivity inside apply +opt_trans_rule is in_co1@(AppCo co1a co1b) in_co2@(AppCo co2a co2b) + = fireTransRule "TrPushApp" in_co1 in_co2 $ + mkAppCo (opt_trans is co1a co2a) (opt_trans is co1b co2b) + +opt_trans_rule is co1@(TyConAppCo tc cos1) co2 + | Just cos2 <- etaTyConAppCo_maybe tc co2 + = ASSERT( length cos1 == length cos2 ) + fireTransRule "EtaCompL" co1 co2 $ + TyConAppCo tc (opt_transList is cos1 cos2) + +opt_trans_rule is co1 co2@(TyConAppCo tc cos2) + | Just cos1 <- etaTyConAppCo_maybe tc co1 + = ASSERT( length cos1 == length cos2 ) + fireTransRule "EtaCompR" co1 co2 $ + TyConAppCo tc (opt_transList is cos1 cos2) + +-- Push transitivity inside forall +opt_trans_rule is co1 co2 + | Just (tv1,r1) <- splitForAllCo_maybe co1 + , Just (tv2,r2) <- etaForAllCo_maybe co2 + , let r2' = substCoWithTy is tv2 (mkTyVarTy tv1) r2 + = fireTransRule "EtaAllL" co1 co2 $ + mkForAllCo tv1 (opt_trans2 (extendInScopeSet is tv1) r1 r2') + + | Just (tv2,r2) <- splitForAllCo_maybe co2 + , Just (tv1,r1) <- etaForAllCo_maybe co1 + , let r1' = substCoWithTy is tv1 (mkTyVarTy tv2) r1 + = fireTransRule "EtaAllR" co1 co2 $ + mkForAllCo tv1 (opt_trans2 (extendInScopeSet is tv2) r1' r2) + +-- Push transitivity inside axioms +opt_trans_rule is co1 co2 + + -- TrPushAxR/TrPushSymAxR + | Just (sym, con, cos1) <- co1_is_axiom_maybe + , Just cos2 <- matchAxiom sym con co2 + = fireTransRule "TrPushAxR" co1 co2 $ + if sym + then SymCo $ AxiomInstCo con (opt_transList is (map mkSymCo cos2) cos1) + else AxiomInstCo con (opt_transList is cos1 cos2) + + -- TrPushAxL/TrPushSymAxL + | Just (sym, con, cos2) <- co2_is_axiom_maybe + , Just cos1 <- matchAxiom (not sym) con co1 + = fireTransRule "TrPushAxL" co1 co2 $ + if sym + then SymCo $ AxiomInstCo con (opt_transList is cos2 (map mkSymCo cos1)) + else AxiomInstCo con (opt_transList is cos1 cos2) + + -- TrPushAxSym/TrPushSymAx + | Just (sym1, con1, cos1) <- co1_is_axiom_maybe + , Just (sym2, con2, cos2) <- co2_is_axiom_maybe + , con1 == con2 + , sym1 == not sym2 + , let qtvs = co_ax_tvs con1 + lhs = co_ax_lhs con1 + rhs = co_ax_rhs con1 + pivot_tvs = exactTyVarsOfType (if sym2 then rhs else lhs) + , all (`elemVarSet` pivot_tvs) qtvs + = fireTransRule "TrPushAxSym" co1 co2 $ + if sym2 + then liftCoSubstWith qtvs (opt_transList is cos1 (map mkSymCo cos2)) lhs -- TrPushAxSym + else liftCoSubstWith qtvs (opt_transList is (map mkSymCo cos1) cos2) rhs -- TrPushSymAx + where + co1_is_axiom_maybe = isAxiom_maybe co1 + co2_is_axiom_maybe = isAxiom_maybe co2 + +opt_trans_rule _ co1 co2 -- Identity rule + | Pair ty1 _ <- coercionKind co1 + , Pair _ ty2 <- coercionKind co2 + , ty1 `eqType` ty2 + = fireTransRule "RedTypeDirRefl" co1 co2 $ + Refl ty2 + +opt_trans_rule _ _ _ = Nothing + +fireTransRule :: String -> Coercion -> Coercion -> Coercion -> Maybe Coercion +fireTransRule _rule _co1 _co2 res + = -- pprTrace ("Trans rule fired: " ++ _rule) (vcat [ppr _co1, ppr _co2, ppr res]) $ + Just res + +----------- +wrapSym :: Bool -> Coercion -> Coercion +wrapSym sym co | sym = SymCo co + | otherwise = co + +----------- +isAxiom_maybe :: Coercion -> Maybe (Bool, CoAxiom, [Coercion]) +isAxiom_maybe (SymCo co) + | Just (sym, con, cos) <- isAxiom_maybe co + = Just (not sym, con, cos) +isAxiom_maybe (AxiomInstCo con cos) + = Just (False, con, cos) +isAxiom_maybe _ = Nothing + +matchAxiom :: Bool -- True = match LHS, False = match RHS + -> CoAxiom -> Coercion -> Maybe [Coercion] +-- If we succeed in matching, then *all the quantified type variables are bound* +-- E.g. if tvs = [a,b], lhs/rhs = [b], we'll fail +matchAxiom sym (CoAxiom { co_ax_tvs = qtvs, co_ax_lhs = lhs, co_ax_rhs = rhs }) co + = case liftCoMatch (mkVarSet qtvs) (if sym then lhs else rhs) co of + Nothing -> Nothing + Just subst -> allMaybes (map (liftCoSubstTyVar subst) qtvs) + +------------- +compatible_co :: Coercion -> Coercion -> Bool +-- Check whether (co1 . co2) will be well-kinded +compatible_co co1 co2 + = x1 `eqType` x2 + where + Pair _ x1 = coercionKind co1 + Pair x2 _ = coercionKind co2 + +------------- +etaForAllCo_maybe :: Coercion -> Maybe (TyVar, Coercion) +-- Try to make the coercion be of form (forall tv. co) +etaForAllCo_maybe co + | Just (tv, r) <- splitForAllCo_maybe co + = Just (tv, r) + + | Pair ty1 ty2 <- coercionKind co + , Just (tv1, _) <- splitForAllTy_maybe ty1 + , Just (tv2, _) <- splitForAllTy_maybe ty2 + , tyVarKind tv1 `eqKind` tyVarKind tv2 + = Just (tv1, mkInstCo co (mkTyVarTy tv1)) + + | otherwise + = Nothing + +etaTyConAppCo_maybe :: TyCon -> Coercion -> Maybe [Coercion] +-- If possible, split a coercion +-- g :: T s1 .. sn ~ T t1 .. tn +-- into [ Nth 0 g :: s1~t1, ..., Nth (n-1) g :: sn~tn ] +etaTyConAppCo_maybe tc (TyConAppCo tc2 cos2) + = ASSERT( tc == tc2 ) Just cos2 + +etaTyConAppCo_maybe tc co + | isDecomposableTyCon tc + , Pair ty1 ty2 <- coercionKind co + , Just (tc1, tys1) <- splitTyConApp_maybe ty1 + , Just (tc2, tys2) <- splitTyConApp_maybe ty2 + , tc1 == tc2 + , let n = length tys1 + = ASSERT( tc == tc1 ) + ASSERT( n == length tys2 ) + Just (decomposeCo n co) + -- NB: n might be <> tyConArity tc + -- e.g. data family T a :: * -> * + -- g :: T a b ~ T c d + + | otherwise + = Nothing +\end{code} diff -Nru ghc-7.0.3/compiler/types/TyCon.lhs ghc-7.2.1/compiler/types/TyCon.lhs --- ghc-7.0.3/compiler/types/TyCon.lhs 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/types/TyCon.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -13,7 +13,9 @@ AlgTyConRhs(..), visibleDataCons, TyConParent(..), isNoParent, SynTyConRhs(..), - CoTyConDesc(..), + + -- ** Coercion axiom constructors + CoAxiom(..), coAxiomName, coAxiomArity, -- ** Constructing TyCons mkAlgTyCon, @@ -25,7 +27,6 @@ mkTupleTyCon, mkSynTyCon, mkSuperKindTyCon, - mkCoercionTyCon, mkForeignTyCon, mkAnyTyCon, @@ -35,21 +36,20 @@ isFunTyCon, isPrimTyCon, isTupleTyCon, isUnboxedTupleTyCon, isBoxedTupleTyCon, - isSynTyCon, isClosedSynTyCon, + isSynTyCon, isClosedSynTyCon, isSuperKindTyCon, isDecomposableTyCon, - isCoercionTyCon, isCoercionTyCon_maybe, isForeignTyCon, isAnyTyCon, tyConHasKind, isInjectiveTyCon, isDataTyCon, isProductTyCon, isEnumerationTyCon, - isNewTyCon, isAbstractTyCon, + isNewTyCon, isAbstractTyCon, isFamilyTyCon, isSynFamilyTyCon, isDataFamilyTyCon, isUnLiftedTyCon, isGadtSyntaxTyCon, isTyConAssoc, isRecursiveTyCon, isHiBootTyCon, - isImplicitTyCon, tyConHasGenerics, + isImplicitTyCon, -- ** Extracting information out of TyCons tyConName, @@ -63,16 +63,16 @@ tyConParent, tyConClass_maybe, tyConFamInst_maybe, tyConFamilyCoercion_maybe,tyConFamInstSig_maybe, - synTyConDefn, synTyConRhs, synTyConType, - tyConExtName, -- External name for foreign types + synTyConDefn, synTyConRhs, synTyConType, + tyConExtName, -- External name for foreign types algTyConRhs, newTyConRhs, newTyConEtadRhs, unwrapNewTyCon_maybe, - tupleTyConBoxity, + tupleTyConBoxity, tupleTyConArity, -- ** Manipulating TyCons tcExpandTyCon_maybe, coreExpandTyCon_maybe, makeTyConAbstract, - newTyConCo_maybe, + newTyConCo, newTyConCo_maybe, -- * Primitive representations of Types PrimRep(..), @@ -96,6 +96,7 @@ import Constants import Util import qualified Data.Data as Data +import Data.Typeable hiding (TyCon) \end{code} ----------------------------------------------- @@ -113,7 +114,7 @@ * Reply "yes" to isSynFamilyTyCon, and isFamilyTyCon -* From the user's point of view (F Int) and Bool are simply +* From the user's point of view (F Int) and Bool are simply equivalent types. * A Haskell 98 type synonym is a degenerate form of a type synonym @@ -129,6 +130,36 @@ * Translation of type instance decl: type instance F [a] = Maybe a + translates to a "representation TyCon", 'R:FList', where + R:FList is a SynTyCon, whose + SynTyConRhs is (SynonymTyCon (Maybe a)) + TyConParent is (FamInstTyCon F [a] co) + where co :: F [a] ~ R:FList a + + It's very much as if the user had written + type instance F [a] = R:FList a + type R:FList a = Maybe a + Indeed, in GHC's internal representation, the RHS of every + 'type instance' is simply an application of the representation + TyCon to the quantified varaibles. + + The intermediate representation TyCon is a bit gratuitous, but + it means that: + + each 'type instance' decls is in 1-1 correspondance + with its representation TyCon + + So the result of typechecking a 'type instance' decl is just a + TyCon. In turn this means that type and data families can be + treated uniformly. + +* Translation of type family decl: + type family F a :: * + translates to + a SynTyCon 'F', whose SynTyConRhs is SynFamilyTyCon + +* Translation of type instance decl: + type instance F [a] = Maybe a translates to A SynTyCon 'R:FList a', whose SynTyConRhs is (SynonymTyCon (Maybe a)) @@ -156,6 +187,8 @@ * Reply "yes" to isDataFamilyTyCon, and isFamilyTyCon +* Reply "yes" to isDataFamilyTyCon, and isFamilyTyCon + * The user does not see any "equivalent types" as he did with type synonym families. He just sees constructors with types T1 :: T Int @@ -253,9 +286,6 @@ -- -- 4) Class declarations: @class Foo where@ creates the @Foo@ type constructor of kind @*@ -- --- 5) Type coercions! This is because we represent a coercion from @t1@ to @t2@ --- as a 'Type', where that type has kind @t1 ~ t2@. See "Coercion" for more on this --- -- This data type also encodes a number of primitive, built in type constructors such as those -- for function and tuple types. data TyCon @@ -304,11 +334,7 @@ algTcRec :: RecFlag, -- ^ Tells us whether the data type is part -- of a mutually-recursive group or not - - hasGenerics :: Bool, -- ^ Whether generic (in the -XGenerics sense) - -- to\/from functions are available in the exports - -- of the data type's source module. - + algTcParent :: TyConParent -- ^ Gives the class or family declaration 'TyCon' -- for derived 'TyCon's representing class -- or family instances, respectively. @@ -324,8 +350,7 @@ tyConArity :: Arity, tyConBoxed :: Boxity, tyConTyVars :: [TyVar], - dataCon :: DataCon, -- ^ Corresponding tuple data constructor - hasGenerics :: Bool + dataCon :: DataCon -- ^ Corresponding tuple data constructor } -- | Represents type synonyms @@ -368,17 +393,6 @@ -- holds the name of the imported thing } - -- | Type coercions, such as @(~)@, @sym@, @trans@, @left@ and @right@. - -- INVARIANT: Coercion TyCons are always fully applied - -- But note that a CoTyCon can be *over*-saturated in a type. - -- E.g. (sym g1) Int will be represented as (TyConApp sym [g1,Int]) - | CoTyCon { - tyConUnique :: Unique, - tyConName :: Name, - tyConArity :: Arity, - coTcDesc :: CoTyConDesc - } - -- | Any types. Like tuples, this is a potentially-infinite family of TyCons -- one for each distinct Kind. They have no values at all. -- Because there are infinitely many of them (like tuples) they are @@ -388,7 +402,7 @@ | AnyTyCon { tyConUnique :: Unique, tyConName :: Name, - tc_kind :: Kind -- Never = *; that is done via PrimTyCon + tc_kind :: Kind -- Never = *; that is done via PrimTyCon -- See Note [Any types] in TysPrim } @@ -403,6 +417,7 @@ tyConUnique :: Unique, tyConName :: Name } + deriving Typeable -- | Names of the fields in an algebraic record type type FieldLabel = Name @@ -462,18 +477,14 @@ -- shorter than the declared arity of the 'TyCon'. -- See Note [Newtype eta] - - nt_co :: Maybe TyCon -- ^ A 'TyCon' (which is always a 'CoTyCon') that can - -- have a 'Coercion' extracted from it to create - -- the @newtype@ from the representation 'Type'. - -- - -- This field is optional for non-recursive @newtype@s only. - - -- See Note [Newtype coercions] - -- Invariant: arity = #tvs in nt_etad_rhs; - -- See Note [Newtype eta] - -- Watch out! If any newtypes become transparent - -- again check Trac #1072. + nt_co :: CoAxiom -- The axiom coercion that creates the @newtype@ from + -- the representation 'Type'. + + -- See Note [Newtype coercions] + -- Invariant: arity = #tvs in nt_etad_rhs; + -- See Note [Newtype eta] + -- Watch out! If any newtypes become transparent + -- again check Trac #1072. } -- | Extract those 'DataCon's that we are able to learn about. Note @@ -533,7 +544,7 @@ -- and Note [Type synonym families] TyCon -- The family TyCon [Type] -- Argument types (mentions the tyConTyVars of this TyCon) - TyCon -- The coercion constructor + CoAxiom -- The coercion constructor -- E.g. data intance T [a] = ... -- gives a representation tycon: @@ -564,20 +575,6 @@ -- | A type synonym family e.g. @type family F x y :: * -> *@ | SynFamilyTyCon - --------------------- -data CoTyConDesc - = CoSym | CoTrans - | CoLeft | CoRight - | CoCsel1 | CoCsel2 | CoCselR - | CoInst - - | CoAxiom -- C tvs : F lhs-tys ~ rhs-ty - { co_ax_tvs :: [TyVar] - , co_ax_lhs :: Type - , co_ax_rhs :: Type } - - | CoUnsafe \end{code} Note [Enumeration types] @@ -676,6 +673,32 @@ %************************************************************************ %* * + Coercion axioms +%* * +%************************************************************************ + +\begin{code} +-- | A 'CoAxiom' is a \"coercion constructor\", i.e. a named equality axiom. +data CoAxiom + = CoAxiom -- type equality axiom. + { co_ax_unique :: Unique -- unique identifier + , co_ax_name :: Name -- name for pretty-printing + , co_ax_tvs :: [TyVar] -- bound type variables + , co_ax_lhs :: Type -- left-hand side of the equality + , co_ax_rhs :: Type -- right-hand side of the equality + } + deriving Typeable + +coAxiomArity :: CoAxiom -> Arity +coAxiomArity ax = length (co_ax_tvs ax) + +coAxiomName :: CoAxiom -> Name +coAxiomName = co_ax_name +\end{code} + + +%************************************************************************ +%* * \subsection{PrimRep} %* * %************************************************************************ @@ -763,10 +786,9 @@ -> AlgTyConRhs -- ^ Information about dat aconstructors -> TyConParent -> RecFlag -- ^ Is the 'TyCon' recursive? - -> Bool -- ^ Does it have generic functions? See 'hasGenerics' -> Bool -- ^ Was the 'TyCon' declared with GADT syntax? -> TyCon -mkAlgTyCon name kind tyvars stupid rhs parent is_rec gen_info gadt_syn +mkAlgTyCon name kind tyvars stupid rhs parent is_rec gadt_syn = AlgTyCon { tyConName = name, tyConUnique = nameUnique name, @@ -777,14 +799,13 @@ algTcRhs = rhs, algTcParent = ASSERT( okParent name parent ) parent, algTcRec = is_rec, - algTcGadtSyntax = gadt_syn, - hasGenerics = gen_info + algTcGadtSyntax = gadt_syn } -- | Simpler specialization of 'mkAlgTyCon' for classes mkClassTyCon :: Name -> Kind -> [TyVar] -> AlgTyConRhs -> Class -> RecFlag -> TyCon mkClassTyCon name kind tyvars rhs clas is_rec = - mkAlgTyCon name kind tyvars [] rhs (ClassTyCon clas) is_rec False False + mkAlgTyCon name kind tyvars [] rhs (ClassTyCon clas) is_rec False mkTupleTyCon :: Name -> Kind -- ^ Kind of the resulting 'TyCon' @@ -792,9 +813,8 @@ -> [TyVar] -- ^ 'TyVar's scoped over: see 'tyConTyVars' -> DataCon -> Boxity -- ^ Whether the tuple is boxed or unboxed - -> Bool -- ^ Does it have generic functions? See 'hasGenerics' -> TyCon -mkTupleTyCon name kind arity tyvars con boxed gen_info +mkTupleTyCon name kind arity tyvars con boxed = TupleTyCon { tyConUnique = nameUnique name, tyConName = name, @@ -802,8 +822,7 @@ tyConArity = arity, tyConBoxed = boxed, tyConTyVars = tyvars, - dataCon = con, - hasGenerics = gen_info + dataCon = con } -- ^ Foreign-imported (.NET) type constructors are represented @@ -867,17 +886,6 @@ synTcParent = parent } --- | Create a coercion 'TyCon' -mkCoercionTyCon :: Name -> Arity - -> CoTyConDesc - -> TyCon -mkCoercionTyCon name arity desc - = CoTyCon { - tyConName = name, - tyConUnique = nameUnique name, - tyConArity = arity, - coTcDesc = desc } - mkAnyTyCon :: Name -> Kind -> TyCon mkAnyTyCon name kind = AnyTyCon { tyConName = name, @@ -955,11 +963,11 @@ -- | Take a 'TyCon' apart into the 'TyVar's it scopes over, the 'Type' it expands -- into, and (possibly) a coercion from the representation type to the @newtype@. -- Returns @Nothing@ if this is not possible. -unwrapNewTyCon_maybe :: TyCon -> Maybe ([TyVar], Type, Maybe TyCon) +unwrapNewTyCon_maybe :: TyCon -> Maybe ([TyVar], Type, CoAxiom) unwrapNewTyCon_maybe (AlgTyCon { tyConTyVars = tvs, - algTcRhs = NewTyCon { nt_co = mb_co, + algTcRhs = NewTyCon { nt_co = co, nt_rhs = rhs }}) - = Just (tvs, rhs, mb_co) + = Just (tvs, rhs, co) unwrapNewTyCon_maybe _ = Nothing isProductTyCon :: TyCon -> Bool @@ -991,9 +999,8 @@ isDecomposableTyCon :: TyCon -> Bool -- True iff we can decompose (T a b c) into ((T a b) c) --- Specifically NOT true of synonyms (open and otherwise) and coercions +-- Specifically NOT true of synonyms (open and otherwise) isDecomposableTyCon (SynTyCon {}) = False -isDecomposableTyCon (CoTyCon {}) = False isDecomposableTyCon _other = True -- | Is this an algebraic 'TyCon' declared with the GADT syntax? @@ -1035,7 +1042,7 @@ -- Ultimately we may have injective associated types -- in which case this test will become more interesting -- - -- It'd be unusual to call isInjectiveTyCon on a regular H98 + -- It'd be unusual to call isInjectiveTyCon on a regular H98 -- type synonym, because you should probably have expanded it first -- But regardless, it's not injective! @@ -1074,6 +1081,11 @@ tupleTyConBoxity :: TyCon -> Boxity tupleTyConBoxity tc = tyConBoxed tc +-- | Extract the arity of the given 'TyCon', if it is a 'TupleTyCon'. +-- Panics otherwise +tupleTyConArity :: TyCon -> Arity +tupleTyConArity tc = tyConArity tc + -- | Is this a recursive 'TyCon'? isRecursiveTyCon :: TyCon -> Bool isRecursiveTyCon (AlgTyCon {algTcRec = Recursive}) = True @@ -1100,19 +1112,6 @@ isAnyTyCon (AnyTyCon {}) = True isAnyTyCon _ = False --- | Attempt to pull a 'TyCon' apart into the arity and 'coKindFun' of --- a coercion 'TyCon'. Returns @Nothing@ if the 'TyCon' is not of the --- appropriate kind -isCoercionTyCon_maybe :: TyCon -> Maybe (Arity, CoTyConDesc) -isCoercionTyCon_maybe (CoTyCon {tyConArity = ar, coTcDesc = desc}) - = Just (ar, desc) -isCoercionTyCon_maybe _ = Nothing - --- | Is this a 'TyCon' that represents a coercion? -isCoercionTyCon :: TyCon -> Bool -isCoercionTyCon (CoTyCon {}) = True -isCoercionTyCon _ = False - -- | Identifies implicit tycons that, in particular, do not go into interface -- files (because they are implicitly reconstructed when the interface is -- read). @@ -1142,14 +1141,15 @@ \begin{code} tcExpandTyCon_maybe, coreExpandTyCon_maybe :: TyCon - -> [Type] -- ^ Arguments to 'TyCon' - -> Maybe ([(TyVar,Type)], + -> [tyco] -- ^ Arguments to 'TyCon' + -> Maybe ([(TyVar,tyco)], Type, - [Type]) -- ^ Returns a 'TyVar' substitution, the body type - -- of the synonym (not yet substituted) and any arguments - -- remaining from the application + [tyco]) -- ^ Returns a 'TyVar' substitution, the body type + -- of the synonym (not yet substituted) and any arguments + -- remaining from the application --- ^ Used to create the view the /typechecker/ has on 'TyCon's. We expand (closed) synonyms only, cf. 'coreExpandTyCon_maybe' +-- ^ Used to create the view the /typechecker/ has on 'TyCon's. +-- We expand (closed) synonyms only, cf. 'coreExpandTyCon_maybe' tcExpandTyCon_maybe (SynTyCon {tyConTyVars = tvs, synTcRhs = SynonymTyCon rhs }) tys = expand tvs rhs tys @@ -1157,36 +1157,26 @@ --------------- --- ^ Used to create the view /Core/ has on 'TyCon's. We expand not only closed synonyms like 'tcExpandTyCon_maybe', +-- ^ Used to create the view /Core/ has on 'TyCon's. We expand +-- not only closed synonyms like 'tcExpandTyCon_maybe', -- but also non-recursive @newtype@s -coreExpandTyCon_maybe (AlgTyCon { - algTcRhs = NewTyCon { nt_etad_rhs = etad_rhs, nt_co = Nothing }}) tys - = case etad_rhs of -- Don't do this in the pattern match, lest we accidentally - -- match the etad_rhs of a *recursive* newtype - (tvs,rhs) -> expand tvs rhs tys - coreExpandTyCon_maybe tycon tys = tcExpandTyCon_maybe tycon tys ---------------- -expand :: [TyVar] -> Type -- Template - -> [Type] -- Args - -> Maybe ([(TyVar,Type)], Type, [Type]) -- Expansion +expand :: [TyVar] -> Type -- Template + -> [a] -- Args + -> Maybe ([(TyVar,a)], Type, [a]) -- Expansion expand tvs rhs tys = case n_tvs `compare` length tys of LT -> Just (tvs `zip` tys, rhs, drop n_tvs tys) EQ -> Just (tvs `zip` tys, rhs, []) - GT -> Nothing + GT -> Nothing where n_tvs = length tvs \end{code} \begin{code} --- | Does this 'TyCon' have any generic to\/from functions available? See also 'hasGenerics' -tyConHasGenerics :: TyCon -> Bool -tyConHasGenerics (AlgTyCon {hasGenerics = hg}) = hg -tyConHasGenerics (TupleTyCon {hasGenerics = hg}) = hg -tyConHasGenerics _ = False -- Synonyms tyConKind :: TyCon -> Kind tyConKind (FunTyCon { tc_kind = k }) = k @@ -1199,7 +1189,6 @@ tyConHasKind :: TyCon -> Bool tyConHasKind (SuperKindTyCon {}) = False -tyConHasKind (CoTyCon {}) = False tyConHasKind _ = True -- | As 'tyConDataCons_maybe', but returns the empty list of constructors if no constructors @@ -1252,9 +1241,14 @@ -- | Extracts the @newtype@ coercion from such a 'TyCon', which can be used to construct something -- with the @newtype@s type from its representation type (right hand side). If the supplied 'TyCon' -- is not a @newtype@, returns @Nothing@ -newTyConCo_maybe :: TyCon -> Maybe TyCon -newTyConCo_maybe (AlgTyCon {algTcRhs = NewTyCon { nt_co = co }}) = co -newTyConCo_maybe _ = Nothing +newTyConCo_maybe :: TyCon -> Maybe CoAxiom +newTyConCo_maybe (AlgTyCon {algTcRhs = NewTyCon { nt_co = co }}) = Just co +newTyConCo_maybe _ = Nothing + +newTyConCo :: TyCon -> CoAxiom +newTyConCo tc = case newTyConCo_maybe tc of + Just co -> co + Nothing -> pprPanic "newTyConCo" (ppr tc) -- | Find the primitive representation of a 'TyCon' tyConPrimRep :: TyCon -> PrimRep @@ -1324,6 +1318,7 @@ tyConParent (SynTyCon {synTcParent = parent}) = parent tyConParent _ = NoParentTyCon +---------------------------------------------------------------------------- -- | Is this 'TyCon' that for a family instance, be that for a synonym or an -- algebraic family instance? isFamInstTyCon :: TyCon -> Bool @@ -1331,7 +1326,7 @@ FamInstTyCon {} -> True _ -> False -tyConFamInstSig_maybe :: TyCon -> Maybe (TyCon, [Type], TyCon) +tyConFamInstSig_maybe :: TyCon -> Maybe (TyCon, [Type], CoAxiom) tyConFamInstSig_maybe tc = case tyConParent tc of FamInstTyCon f ts co_tc -> Just (f, ts, co_tc) @@ -1348,7 +1343,7 @@ -- | If this 'TyCon' is that of a family instance, return a 'TyCon' which represents -- a coercion identifying the representation type with the type instance family. -- Otherwise, return @Nothing@ -tyConFamilyCoercion_maybe :: TyCon -> Maybe TyCon +tyConFamilyCoercion_maybe :: TyCon -> Maybe CoAxiom tyConFamilyCoercion_maybe tc = case tyConParent tc of FamInstTyCon _ _ co -> Just co @@ -1382,30 +1377,42 @@ instance Uniquable TyCon where getUnique tc = tyConUnique tc -instance Outputable CoTyConDesc where - ppr CoSym = ptext (sLit "SYM") - ppr CoTrans = ptext (sLit "TRANS") - ppr CoLeft = ptext (sLit "LEFT") - ppr CoRight = ptext (sLit "RIGHT") - ppr CoCsel1 = ptext (sLit "CSEL1") - ppr CoCsel2 = ptext (sLit "CSEL2") - ppr CoCselR = ptext (sLit "CSELR") - ppr CoInst = ptext (sLit "INST") - ppr CoUnsafe = ptext (sLit "UNSAFE") - ppr (CoAxiom {}) = ptext (sLit "AXIOM") - instance Outputable TyCon where ppr tc = ppr (getName tc) instance NamedThing TyCon where getName = tyConName -instance Data.Typeable TyCon where - typeOf _ = Data.mkTyConApp (Data.mkTyCon "TyCon") [] - instance Data.Data TyCon where -- don't traverse? toConstr _ = abstractConstr "TyCon" gunfold _ _ = error "gunfold" dataTypeOf _ = mkNoRepType "TyCon" + +------------------- +instance Eq CoAxiom where + a == b = case (a `compare` b) of { EQ -> True; _ -> False } + a /= b = case (a `compare` b) of { EQ -> False; _ -> True } + +instance Ord CoAxiom where + a <= b = case (a `compare` b) of { LT -> True; EQ -> True; GT -> False } + a < b = case (a `compare` b) of { LT -> True; EQ -> False; GT -> False } + a >= b = case (a `compare` b) of { LT -> False; EQ -> True; GT -> True } + a > b = case (a `compare` b) of { LT -> False; EQ -> False; GT -> True } + compare a b = getUnique a `compare` getUnique b + +instance Uniquable CoAxiom where + getUnique = co_ax_unique + +instance Outputable CoAxiom where + ppr = ppr . getName + +instance NamedThing CoAxiom where + getName = co_ax_name + +instance Data.Data CoAxiom where + -- don't traverse? + toConstr _ = abstractConstr "CoAxiom" + gunfold _ _ = error "gunfold" + dataTypeOf _ = mkNoRepType "CoAxiom" \end{code} diff -Nru ghc-7.0.3/compiler/types/Type.lhs ghc-7.2.1/compiler/types/Type.lhs --- ghc-7.0.3/compiler/types/Type.lhs 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/types/Type.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -20,7 +20,8 @@ -- $type_classification -- $representation_types - TyThing(..), Type, PredType(..), ThetaType, + TyThing(..), Type, Pred(..), PredType, ThetaType, + Var, TyVar, isTyVar, -- ** Constructing and deconstructing types mkTyVarTy, mkTyVarTys, getTyVar, getTyVar_maybe, @@ -45,14 +46,20 @@ -- (Type families) tyFamInsts, predFamInsts, - -- (Source types) - mkPredTy, mkPredTys, mkFamilyTyConApp, isEqPred, coVarPred, + -- Pred types + mkPredTy, mkPredTys, mkFamilyTyConApp, + mkDictTy, isDictLikeTy, isClassPred, + isEqPred, allPred, mkEqPred, + mkClassPred, getClassPredTys, getClassPredTys_maybe, + isTyVarClassPred, + mkIPPred, isIPPred, -- ** Common type constructors funTyCon, -- ** Predicates on types - isTyVarTy, isFunTy, isDictTy, + isTyVarTy, isFunTy, isPredTy, + isDictTy, isEqPredTy, isReflPredTy, splitPredTy_maybe, splitEqPredTy_maybe, -- (Lifting and boxity) isUnLiftedType, isUnboxedTupleType, isAlgType, isClosedAlgType, @@ -65,8 +72,7 @@ -- ** Common Kinds and SuperKinds liftedTypeKind, unliftedTypeKind, openTypeKind, argTypeKind, ubxTupleKind, - - tySuperKind, coSuperKind, + tySuperKind, -- ** Common Kind type constructors liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon, @@ -74,18 +80,18 @@ -- * Type free variables tyVarsOfType, tyVarsOfTypes, tyVarsOfPred, tyVarsOfTheta, - expandTypeSynonyms, + exactTyVarsOfType, exactTyVarsOfTypes, expandTypeSynonyms, + typeSize, -- * Type comparison - coreEqType, coreEqType2, - tcEqType, tcEqTypes, tcCmpType, tcCmpTypes, - tcEqPred, tcEqPredX, tcCmpPred, tcEqTypeX, tcPartOfType, tcPartOfPred, + eqType, eqTypeX, eqTypes, cmpType, cmpTypes, + eqPred, eqPredX, cmpPred, eqKind, -- * Forcing evaluation of types - seqType, seqTypes, + seqType, seqTypes, seqPred, -- * Other views onto Types - coreView, tcView, kindView, + coreView, tcView, repType, @@ -102,18 +108,22 @@ emptyTvSubstEnv, emptyTvSubst, mkTvSubst, mkOpenTvSubst, zipOpenTvSubst, zipTopTvSubst, mkTopTvSubst, notElemTvSubst, - getTvSubstEnv, setTvSubstEnv, zapTvSubstEnv, getTvInScope, + getTvSubstEnv, setTvSubstEnv, + zapTvSubstEnv, getTvInScope, extendTvInScope, extendTvInScopeList, - extendTvSubst, extendTvSubstList, isInScope, composeTvSubst, zipTyEnv, + extendTvSubst, extendTvSubstList, + isInScope, composeTvSubst, zipTyEnv, isEmptyTvSubst, unionTvSubst, -- ** Performing substitution on types substTy, substTys, substTyWith, substTysWith, substTheta, - substPred, substTyVar, substTyVars, substTyVarBndr, deShadowTy, lookupTyVar, + substPred, substTyVar, substTyVars, substTyVarBndr, + cloneTyVarBndr, deShadowTy, lookupTyVar, -- * Pretty-printing pprType, pprParendType, pprTypeApp, pprTyThingCategory, pprTyThing, pprForAll, - pprPred, pprEqPred, pprTheta, pprThetaArrow, pprClassPred, pprKind, pprParendKind, + pprPred, pprPredTy, pprEqPred, pprTheta, pprThetaArrowTy, pprClassPred, + pprKind, pprParendKind, pprSourceTyCon ) where @@ -132,8 +142,12 @@ import Class import TyCon +import TysPrim -- others +import Unique ( Unique ) +import BasicTypes ( IPName ) +import Name ( Name ) import StaticFlags import Util import Outputable @@ -218,31 +232,9 @@ -- its underlying representation type. -- Returns Nothing if there is nothing to look through. -- --- In the case of @newtype@s, it returns one of: --- --- 1) A vanilla 'TyConApp' (recursive newtype, or non-saturated) --- --- 2) The newtype representation (otherwise), meaning the --- type written in the RHS of the newtype declaration, --- which may itself be a newtype --- --- For example, with: --- --- > newtype R = MkR S --- > newtype S = MkS T --- > newtype T = MkT (T -> T) --- --- 'expandNewTcApp' on: --- --- * @R@ gives @Just S@ --- * @S@ gives @Just T@ --- * @T@ gives @Nothing@ (no expansion) - -- By being non-recursive and inlined, this case analysis gets efficiently -- joined onto the case analysis that the caller is already doing -coreView (PredTy p) - | isEqPred p = Nothing - | otherwise = Just (predTypeRep p) +coreView (PredTy p) = Just (predTypeRep p) coreView (TyConApp tc tys) | Just (tenv, rhs, tys') <- coreExpandTyCon_maybe tc tys = Just (mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys') -- Its important to use mkAppTys, rather than (foldl AppTy), @@ -251,7 +243,6 @@ coreView _ = Nothing - ----------------------------------------------- {-# INLINE tcView #-} tcView :: Type -> Maybe Type @@ -282,14 +273,6 @@ go_pred (ClassP c ts) = ClassP c (map go ts) go_pred (IParam ip t) = IParam ip (go t) go_pred (EqPred t1 t2) = EqPred (go t1) (go t2) - ------------------------------------------------ -{-# INLINE kindView #-} -kindView :: Kind -> Maybe Kind --- ^ Similar to 'coreView' or 'tcView', but works on 'Kind's - --- For the moment, we don't even handle synonyms in kinds -kindView _ = Nothing \end{code} @@ -304,12 +287,6 @@ TyVarTy ~~~~~~~ \begin{code} -mkTyVarTy :: TyVar -> Type -mkTyVarTy = TyVarTy - -mkTyVarTys :: [TyVar] -> [Type] -mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy - -- | Attempts to obtain the type variable underlying a 'Type', and panics with the -- given message if this is not a type variable type. See also 'getTyVar_maybe' getTyVar :: String -> Type -> TyVar @@ -383,10 +360,9 @@ repSplitAppTy_maybe (FunTy ty1 ty2) = Just (TyConApp funTyCon [ty1], ty2) repSplitAppTy_maybe (AppTy ty1 ty2) = Just (ty1, ty2) repSplitAppTy_maybe (TyConApp tc tys) - | isDecomposableTyCon tc || length tys > tyConArity tc - = case snocView tys of -- never create unsaturated type family apps - Just (tys', ty') -> Just (TyConApp tc tys', ty') - Nothing -> Nothing + | isDecomposableTyCon tc || tys `lengthExceeds` tyConArity tc + , Just (tys', ty') <- snocView tys + = Just (TyConApp tc tys', ty') -- Never create unsaturated type family apps! repSplitAppTy_maybe _other = Nothing ------------- splitAppTy :: Type -> (Type, Type) @@ -426,8 +402,7 @@ \begin{code} mkFunTy :: Type -> Type -> Type -- ^ Creates a function type from the given argument and result type -mkFunTy arg@(PredTy (EqPred {})) res = ForAllTy (mkWildCoVar arg) res -mkFunTy arg res = FunTy arg res +mkFunTy arg res = FunTy arg res mkFunTys :: [Type] -> Type -> Type mkFunTys tys ty = foldr mkFunTy ty tys @@ -495,20 +470,6 @@ ~~~~~~~~ \begin{code} --- | A key function: builds a 'TyConApp' or 'FunTy' as apppropriate to its arguments. --- Applies its arguments to the constructor from left to right -mkTyConApp :: TyCon -> [Type] -> Type -mkTyConApp tycon tys - | isFunTyCon tycon, [ty1,ty2] <- tys - = FunTy ty1 ty2 - - | otherwise - = TyConApp tycon tys - --- | Create the plain type constructor type which has been applied to no type arguments at all. -mkTyConTy :: TyCon -> Type -mkTyConTy tycon = mkTyConApp tycon [] - -- splitTyConApp "looks through" synonyms, because they don't -- mean a distinct type, but all other type-constructor applications -- including functions are returned as Just .. @@ -611,13 +572,16 @@ = go [] ty where go :: [TyCon] -> Type -> Type - go rec_nts ty | Just ty' <- coreView ty -- Expand synonyms - = go rec_nts ty' - - go rec_nts (ForAllTy _ ty) -- Look through foralls + go rec_nts (ForAllTy _ ty) -- Look through foralls = go rec_nts ty - go rec_nts (TyConApp tc tys) -- Expand newtypes + go rec_nts (PredTy p) -- Expand predicates + = go rec_nts (predTypeRep p) + + go rec_nts (TyConApp tc tys) -- Expand newtypes and synonyms + | Just (tenv, rhs, tys') <- coreExpandTyCon_maybe tc tys + = go rec_nts (mkAppTys (substTy (mkTopTvSubst tenv) rhs) tys') + | Just (rec_nts', ty') <- carefullySplitNewType_maybe rec_nts tc tys = go rec_nts' ty' @@ -755,13 +719,32 @@ %************************************************************************ %* * -\subsection{Source types} + Pred %* * %************************************************************************ -Source types are always lifted. +Polymorphic functions over Pred -The key function is predTypeRep which gives the representation of a source type: +\begin{code} +allPred :: (a -> Bool) -> Pred a -> Bool +allPred p (ClassP _ ts) = all p ts +allPred p (IParam _ t) = p t +allPred p (EqPred t1 t2) = p t1 && p t2 + +isClassPred :: Pred a -> Bool +isClassPred (ClassP {}) = True +isClassPred _ = False + +isEqPred :: Pred a -> Bool +isEqPred (EqPred {}) = True +isEqPred _ = False + +isIPPred :: Pred a -> Bool +isIPPred (IParam {}) = True +isIPPred _ = False +\end{code} + +Make PredTypes \begin{code} mkPredTy :: PredType -> Type @@ -770,88 +753,129 @@ mkPredTys :: ThetaType -> [Type] mkPredTys preds = map PredTy preds -isEqPred :: PredType -> Bool -isEqPred (EqPred _ _) = True -isEqPred _ = False - predTypeRep :: PredType -> Type -- ^ Convert a 'PredType' to its representation type. However, it unwraps -- only the outermost level; for example, the result might be a newtype application predTypeRep (IParam _ ty) = ty predTypeRep (ClassP clas tys) = mkTyConApp (classTyCon clas) tys - -- Result might be a newtype application, but the consumer will - -- look through that too if necessary -predTypeRep (EqPred ty1 ty2) = pprPanic "predTypeRep" (ppr (EqPred ty1 ty2)) +predTypeRep (EqPred ty1 ty2) = mkTyConApp eqPredPrimTyCon [ty1,ty2] -mkFamilyTyConApp :: TyCon -> [Type] -> Type --- ^ Given a family instance TyCon and its arg types, return the --- corresponding family type. E.g: --- --- > data family T a --- > data instance T (Maybe b) = MkT b --- --- Where the instance tycon is :RTL, so: --- --- > mkFamilyTyConApp :RTL Int = T (Maybe Int) -mkFamilyTyConApp tc tys - | Just (fam_tc, fam_tys) <- tyConFamInst_maybe tc - , let fam_subst = zipTopTvSubst (tyConTyVars tc) tys - = mkTyConApp fam_tc (substTys fam_subst fam_tys) - | otherwise - = mkTyConApp tc tys +splitPredTy_maybe :: Type -> Maybe PredType +-- Returns Just for predicates only +splitPredTy_maybe ty | Just ty' <- tcView ty = splitPredTy_maybe ty' +splitPredTy_maybe (PredTy p) = Just p +splitPredTy_maybe _ = Nothing --- | Pretty prints a 'TyCon', using the family instance in case of a --- representation tycon. For example: --- --- > data T [a] = ... --- --- In that case we want to print @T [a]@, where @T@ is the family 'TyCon' -pprSourceTyCon :: TyCon -> SDoc -pprSourceTyCon tycon - | Just (fam_tc, tys) <- tyConFamInst_maybe tycon - = ppr $ fam_tc `TyConApp` tys -- can't be FunTyCon - | otherwise - = ppr tycon +isPredTy :: Type -> Bool +isPredTy ty = isJust (splitPredTy_maybe ty) +\end{code} + +--------------------- Equality types --------------------------------- +\begin{code} +isReflPredTy :: Type -> Bool +isReflPredTy ty = case splitPredTy_maybe ty of + Just (EqPred ty1 ty2) -> ty1 `eqType` ty2 + _ -> False + +splitEqPredTy_maybe :: Type -> Maybe (Type,Type) +splitEqPredTy_maybe ty = case splitPredTy_maybe ty of + Just (EqPred ty1 ty2) -> Just (ty1,ty2) + _ -> Nothing + +isEqPredTy :: Type -> Bool +isEqPredTy ty = case splitPredTy_maybe ty of + Just (EqPred {}) -> True + _ -> False + +-- | Creates a type equality predicate +mkEqPred :: (a, a) -> Pred a +mkEqPred (ty1, ty2) = EqPred ty1 ty2 +\end{code} + +--------------------- Dictionary types --------------------------------- +\begin{code} +mkClassPred :: Class -> [Type] -> PredType +mkClassPred clas tys = ClassP clas tys isDictTy :: Type -> Bool -isDictTy ty = case splitTyConApp_maybe ty of - Just (tc, _) -> isClassTyCon tc - Nothing -> False +isDictTy ty = case splitPredTy_maybe ty of + Just p -> isClassPred p + Nothing -> False + +isTyVarClassPred :: PredType -> Bool +isTyVarClassPred (ClassP _ tys) = all isTyVarTy tys +isTyVarClassPred _ = False + +getClassPredTys_maybe :: PredType -> Maybe (Class, [Type]) +getClassPredTys_maybe (ClassP clas tys) = Just (clas, tys) +getClassPredTys_maybe _ = Nothing + +getClassPredTys :: PredType -> (Class, [Type]) +getClassPredTys (ClassP clas tys) = (clas, tys) +getClassPredTys _ = panic "getClassPredTys" + +mkDictTy :: Class -> [Type] -> Type +mkDictTy clas tys = mkPredTy (ClassP clas tys) + +isDictLikeTy :: Type -> Bool +-- Note [Dictionary-like types] +isDictLikeTy ty | Just ty' <- tcView ty = isDictTy ty' +isDictLikeTy (PredTy p) = isClassPred p +isDictLikeTy (TyConApp tc tys) + | isTupleTyCon tc = all isDictLikeTy tys +isDictLikeTy _ = False \end{code} +Note [Dictionary-like types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Being "dictionary-like" means either a dictionary type or a tuple thereof. +In GHC 6.10 we build implication constraints which construct such tuples, +and if we land up with a binding + t :: (C [a], Eq [a]) + t = blah +then we want to treat t as cheap under "-fdicts-cheap" for example. +(Implication constraints are normally inlined, but sadly not if the +occurrence is itself inside an INLINE function! Until we revise the +handling of implication constraints, that is.) This turned out to +be important in getting good arities in DPH code. Example: + + class C a + class D a where { foo :: a -> a } + instance C a => D (Maybe a) where { foo x = x } + + bar :: (C a, C b) => a -> b -> (Maybe a, Maybe b) + {-# INLINE bar #-} + bar x y = (foo (Just x), foo (Just y)) + +Then 'bar' should jolly well have arity 4 (two dicts, two args), but +we ended up with something like + bar = __inline_me__ (\d1,d2. let t :: (D (Maybe a), D (Maybe b)) = ... + in \x,y. ) + +This is all a bit ad-hoc; eg it relies on knowing that implication +constraints build tuples. + +--------------------- Implicit parameters --------------------------------- + +\begin{code} +mkIPPred :: IPName Name -> Type -> PredType +mkIPPred ip ty = IParam ip ty +\end{code} %************************************************************************ %* * - The free variables of a type + Size %* * %************************************************************************ \begin{code} -tyVarsOfType :: Type -> TyVarSet --- ^ NB: for type synonyms tyVarsOfType does /not/ expand the synonym -tyVarsOfType (TyVarTy tv) = unitVarSet tv -tyVarsOfType (TyConApp _ tys) = tyVarsOfTypes tys -tyVarsOfType (PredTy sty) = tyVarsOfPred sty -tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionVarSet` tyVarsOfType res -tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionVarSet` tyVarsOfType arg -tyVarsOfType (ForAllTy tv ty) -- The kind of a coercion binder - -- can mention type variables! - | isTyVar tv = inner_tvs `delVarSet` tv - | otherwise {- Coercion -} = -- ASSERT( not (tv `elemVarSet` inner_tvs) ) - inner_tvs `unionVarSet` tyVarsOfType (tyVarKind tv) - where - inner_tvs = tyVarsOfType ty - -tyVarsOfTypes :: [Type] -> TyVarSet -tyVarsOfTypes tys = foldr (unionVarSet.tyVarsOfType) emptyVarSet tys - -tyVarsOfPred :: PredType -> TyVarSet -tyVarsOfPred (IParam _ ty) = tyVarsOfType ty -tyVarsOfPred (ClassP _ tys) = tyVarsOfTypes tys -tyVarsOfPred (EqPred ty1 ty2) = tyVarsOfType ty1 `unionVarSet` tyVarsOfType ty2 - -tyVarsOfTheta :: ThetaType -> TyVarSet -tyVarsOfTheta = foldr (unionVarSet . tyVarsOfPred) emptyVarSet +typeSize :: Type -> Int +typeSize (TyVarTy _) = 1 +typeSize (AppTy t1 t2) = typeSize t1 + typeSize t2 +typeSize (FunTy t1 t2) = typeSize t1 + typeSize t2 +typeSize (PredTy p) = predSize typeSize p +typeSize (ForAllTy _ t) = 1 + typeSize t +typeSize (TyConApp _ ts) = 1 + sum (map typeSize ts) \end{code} @@ -881,8 +905,37 @@ predFamInsts (ClassP _cla tys) = concat (map tyFamInsts tys) predFamInsts (IParam _ ty) = tyFamInsts ty predFamInsts (EqPred ty1 ty2) = tyFamInsts ty1 ++ tyFamInsts ty2 -\end{code} +mkFamilyTyConApp :: TyCon -> [Type] -> Type +-- ^ Given a family instance TyCon and its arg types, return the +-- corresponding family type. E.g: +-- +-- > data family T a +-- > data instance T (Maybe b) = MkT b +-- +-- Where the instance tycon is :RTL, so: +-- +-- > mkFamilyTyConApp :RTL Int = T (Maybe Int) +mkFamilyTyConApp tc tys + | Just (fam_tc, fam_tys) <- tyConFamInst_maybe tc + , let fam_subst = zipTopTvSubst (tyConTyVars tc) tys + = mkTyConApp fam_tc (substTys fam_subst fam_tys) + | otherwise + = mkTyConApp tc tys + +-- | Pretty prints a 'TyCon', using the family instance in case of a +-- representation tycon. For example: +-- +-- > data T [a] = ... +-- +-- In that case we want to print @T [a]@, where @T@ is the family 'TyCon' +pprSourceTyCon :: TyCon -> SDoc +pprSourceTyCon tycon + | Just (fam_tc, tys) <- tyConFamInst_maybe tycon + = ppr $ fam_tc `TyConApp` tys -- can't be FunTyCon + | otherwise + = ppr tycon +\end{code} %************************************************************************ %* * @@ -901,6 +954,7 @@ isUnLiftedType ty | Just ty' <- coreView ty = isUnLiftedType ty' isUnLiftedType (ForAllTy _ ty) = isUnLiftedType ty +isUnLiftedType (PredTy p) = isEqPred p isUnLiftedType (TyConApp tc _) = isUnLiftedTyCon tc isUnLiftedType _ = False @@ -926,9 +980,9 @@ isClosedAlgType :: Type -> Bool isClosedAlgType ty = case splitTyConApp_maybe ty of - Just (tc, ty_args) -> ASSERT( ty_args `lengthIs` tyConArity tc ) - isAlgTyCon tc && not (isFamilyTyCon tc) - _other -> False + Just (tc, ty_args) | isAlgTyCon tc && not (isFamilyTyCon tc) + -> ASSERT2( ty_args `lengthIs` tyConArity tc, ppr ty ) True + _other -> False \end{code} \begin{code} @@ -954,7 +1008,8 @@ -- poking the dictionary component, which is wrong.) isStrictPred :: PredType -> Bool isStrictPred (ClassP clas _) = opt_DictsStrict && not (isNewTyCon (classTyCon clas)) -isStrictPred _ = False +isStrictPred (EqPred {}) = True +isStrictPred (IParam {}) = False \end{code} \begin{code} @@ -971,6 +1026,64 @@ %************************************************************************ %* * + The "exact" free variables of a type +%* * +%************************************************************************ + +Note [Silly type synonym] +~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider + type T a = Int +What are the free tyvars of (T x)? Empty, of course! +Here's the example that Ralf Laemmel showed me: + foo :: (forall a. C u a -> C u a) -> u + mappend :: Monoid u => u -> u -> u + + bar :: Monoid u => u + bar = foo (\t -> t `mappend` t) +We have to generalise at the arg to f, and we don't +want to capture the constraint (Monad (C u a)) because +it appears to mention a. Pretty silly, but it was useful to him. + +exactTyVarsOfType is used by the type checker to figure out exactly +which type variables are mentioned in a type. It's also used in the +smart-app checking code --- see TcExpr.tcIdApp + +On the other hand, consider a *top-level* definition + f = (\x -> x) :: T a -> T a +If we don't abstract over 'a' it'll get fixed to GHC.Prim.Any, and then +if we have an application like (f "x") we get a confusing error message +involving Any. So the conclusion is this: when generalising + - at top level use tyVarsOfType + - in nested bindings use exactTyVarsOfType +See Trac #1813 for example. + +\begin{code} +exactTyVarsOfType :: Type -> TyVarSet +-- Find the free type variables (of any kind) +-- but *expand* type synonyms. See Note [Silly type synonym] above. +exactTyVarsOfType ty + = go ty + where + go ty | Just ty' <- tcView ty = go ty' -- This is the key line + go (TyVarTy tv) = unitVarSet tv + go (TyConApp _ tys) = exactTyVarsOfTypes tys + go (PredTy ty) = go_pred ty + go (FunTy arg res) = go arg `unionVarSet` go res + go (AppTy fun arg) = go fun `unionVarSet` go arg + go (ForAllTy tyvar ty) = delVarSet (go ty) tyvar + + go_pred (IParam _ ty) = go ty + go_pred (ClassP _ tys) = exactTyVarsOfTypes tys + go_pred (EqPred ty1 ty2) = go ty1 `unionVarSet` go ty2 + +exactTyVarsOfTypes :: [Type] -> TyVarSet +exactTyVarsOfTypes tys = foldr (unionVarSet . exactTyVarsOfType) emptyVarSet tys +\end{code} + + +%************************************************************************ +%* * \subsection{Sequencing on types} %* * %************************************************************************ @@ -980,7 +1093,7 @@ seqType (TyVarTy tv) = tv `seq` () seqType (AppTy t1 t2) = seqType t1 `seq` seqType t2 seqType (FunTy t1 t2) = seqType t1 `seq` seqType t2 -seqType (PredTy p) = seqPred p +seqType (PredTy p) = seqPred seqType p seqType (TyConApp tc tys) = tc `seq` seqTypes tys seqType (ForAllTy tv ty) = tv `seq` seqType ty @@ -988,115 +1101,40 @@ seqTypes [] = () seqTypes (ty:tys) = seqType ty `seq` seqTypes tys -seqPred :: PredType -> () -seqPred (ClassP c tys) = c `seq` seqTypes tys -seqPred (IParam n ty) = n `seq` seqType ty -seqPred (EqPred ty1 ty2) = seqType ty1 `seq` seqType ty2 +seqPred :: (a -> ()) -> Pred a -> () +seqPred seqt (ClassP c tys) = c `seq` foldr (seq . seqt) () tys +seqPred seqt (IParam n ty) = n `seq` seqt ty +seqPred seqt (EqPred ty1 ty2) = seqt ty1 `seq` seqt ty2 \end{code} %************************************************************************ %* * - Equality for Core types + Comparision for types (We don't use instances so that we know where it happens) %* * %************************************************************************ -Note that eqType works right even for partial applications of newtypes. -See Note [Newtype eta] in TyCon.lhs - \begin{code} --- | Type equality test for Core types (i.e. ignores predicate-types, synonyms etc.) -coreEqType :: Type -> Type -> Bool -coreEqType t1 t2 = coreEqType2 rn_env t1 t2 - where - rn_env = mkRnEnv2 (mkInScopeSet (tyVarsOfType t1 `unionVarSet` tyVarsOfType t2)) +eqKind :: Kind -> Kind -> Bool +eqKind = eqType -coreEqType2 :: RnEnv2 -> Type -> Type -> Bool -coreEqType2 rn_env t1 t2 - = eq rn_env t1 t2 - where - eq env (TyVarTy tv1) (TyVarTy tv2) = rnOccL env tv1 == rnOccR env tv2 - eq env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = eq (rnBndr2 env tv1 tv2) t1 t2 - eq env (AppTy s1 t1) (AppTy s2 t2) = eq env s1 s2 && eq env t1 t2 - eq env (FunTy s1 t1) (FunTy s2 t2) = eq env s1 s2 && eq env t1 t2 - eq env (TyConApp tc1 tys1) (TyConApp tc2 tys2) - | tc1 == tc2, all2 (eq env) tys1 tys2 = True - -- The lengths should be equal because - -- the two types have the same kind - -- NB: if the type constructors differ that does not - -- necessarily mean that the types aren't equal - -- (synonyms, newtypes) - -- Even if the type constructors are the same, but the arguments - -- differ, the two types could be the same (e.g. if the arg is just - -- ignored in the RHS). In both these cases we fall through to an - -- attempt to expand one side or the other. - - -- Now deal with newtypes, synonyms, pred-tys - eq env t1 t2 | Just t1' <- coreView t1 = eq env t1' t2 - | Just t2' <- coreView t2 = eq env t1 t2' - - -- Fall through case; not equal! - eq _ _ _ = False -\end{code} - - -%************************************************************************ -%* * - Comparision for source types - (We don't use instances so that we know where it happens) -%* * -%************************************************************************ - -\begin{code} -tcEqType :: Type -> Type -> Bool +eqType :: Type -> Type -> Bool -- ^ Type equality on source types. Does not look through @newtypes@ or -- 'PredType's, but it does look through type synonyms. -tcEqType t1 t2 = isEqual $ cmpType t1 t2 - -tcEqTypes :: [Type] -> [Type] -> Bool -tcEqTypes tys1 tys2 = isEqual $ cmpTypes tys1 tys2 - -tcCmpType :: Type -> Type -> Ordering --- ^ Type ordering on source types. Does not look through @newtypes@ or --- 'PredType's, but it does look through type synonyms. -tcCmpType t1 t2 = cmpType t1 t2 +eqType t1 t2 = isEqual $ cmpType t1 t2 -tcCmpTypes :: [Type] -> [Type] -> Ordering -tcCmpTypes tys1 tys2 = cmpTypes tys1 tys2 +eqTypeX :: RnEnv2 -> Type -> Type -> Bool +eqTypeX env t1 t2 = isEqual $ cmpTypeX env t1 t2 -tcEqPred :: PredType -> PredType -> Bool -tcEqPred p1 p2 = isEqual $ cmpPred p1 p2 +eqTypes :: [Type] -> [Type] -> Bool +eqTypes tys1 tys2 = isEqual $ cmpTypes tys1 tys2 -tcEqPredX :: RnEnv2 -> PredType -> PredType -> Bool -tcEqPredX env p1 p2 = isEqual $ cmpPredX env p1 p2 - -tcCmpPred :: PredType -> PredType -> Ordering -tcCmpPred p1 p2 = cmpPred p1 p2 - -tcEqTypeX :: RnEnv2 -> Type -> Type -> Bool -tcEqTypeX env t1 t2 = isEqual $ cmpTypeX env t1 t2 -\end{code} +eqPred :: PredType -> PredType -> Bool +eqPred p1 p2 = isEqual $ cmpPred p1 p2 -\begin{code} --- | Checks whether the second argument is a subterm of the first. (We don't care --- about binders, as we are only interested in syntactic subterms.) -tcPartOfType :: Type -> Type -> Bool -tcPartOfType t1 t2 - | tcEqType t1 t2 = True -tcPartOfType t1 t2 - | Just t2' <- tcView t2 = tcPartOfType t1 t2' -tcPartOfType _ (TyVarTy _) = False -tcPartOfType t1 (ForAllTy _ t2) = tcPartOfType t1 t2 -tcPartOfType t1 (AppTy s2 t2) = tcPartOfType t1 s2 || tcPartOfType t1 t2 -tcPartOfType t1 (FunTy s2 t2) = tcPartOfType t1 s2 || tcPartOfType t1 t2 -tcPartOfType t1 (PredTy p2) = tcPartOfPred t1 p2 -tcPartOfType t1 (TyConApp _ ts) = any (tcPartOfType t1) ts - -tcPartOfPred :: Type -> PredType -> Bool -tcPartOfPred t1 (IParam _ t2) = tcPartOfType t1 t2 -tcPartOfPred t1 (ClassP _ ts) = any (tcPartOfType t1) ts -tcPartOfPred t1 (EqPred s2 t2) = tcPartOfType t1 s2 || tcPartOfType t1 t2 +eqPredX :: RnEnv2 -> PredType -> PredType -> Bool +eqPredX env p1 p2 = isEqual $ cmpPredX env p1 p2 \end{code} Now here comes the real worker @@ -1118,8 +1156,13 @@ rn_env = mkRnEnv2 (mkInScopeSet (tyVarsOfPred p1 `unionVarSet` tyVarsOfPred p2)) cmpTypeX :: RnEnv2 -> Type -> Type -> Ordering -- Main workhorse -cmpTypeX env t1 t2 | Just t1' <- tcView t1 = cmpTypeX env t1' t2 - | Just t2' <- tcView t2 = cmpTypeX env t1 t2' +cmpTypeX env t1 t2 | Just t1' <- coreView t1 = cmpTypeX env t1' t2 + | Just t2' <- coreView t2 = cmpTypeX env t1 t2' +-- We expand predicate types, because in Core-land we have +-- lots of definitions like +-- fOrdBool :: Ord Bool +-- fOrdBool = D:Ord .. .. .. +-- So the RHS has a data type cmpTypeX env (TyVarTy tv1) (TyVarTy tv2) = rnOccL env tv1 `compare` rnOccR env tv2 cmpTypeX env (ForAllTy tv1 t1) (ForAllTy tv2 t2) = cmpTypeX (rnBndr2 env tv1 tv2) t1 t2 @@ -1176,8 +1219,8 @@ so we take the easy path and make them an instance of Ord \begin{code} -instance Eq PredType where { (==) = tcEqPred } -instance Ord PredType where { compare = tcCmpPred } +instance Eq PredType where { (==) = eqPred } +instance Ord PredType where { compare = cmpPred } \end{code} @@ -1188,81 +1231,6 @@ %************************************************************************ \begin{code} --- | Type substitution --- --- #tvsubst_invariant# --- The following invariants must hold of a 'TvSubst': --- --- 1. The in-scope set is needed /only/ to --- guide the generation of fresh uniques --- --- 2. In particular, the /kind/ of the type variables in --- the in-scope set is not relevant --- --- 3. The substition is only applied ONCE! This is because --- in general such application will not reached a fixed point. -data TvSubst - = TvSubst InScopeSet -- The in-scope type variables - TvSubstEnv -- The substitution itself - -- See Note [Apply Once] - -- and Note [Extending the TvSubstEnv] - -{- ---------------------------------------------------------- - -Note [Apply Once] -~~~~~~~~~~~~~~~~~ -We use TvSubsts to instantiate things, and we might instantiate - forall a b. ty -\with the types - [a, b], or [b, a]. -So the substition might go [a->b, b->a]. A similar situation arises in Core -when we find a beta redex like - (/\ a /\ b -> e) b a -Then we also end up with a substition that permutes type variables. Other -variations happen to; for example [a -> (a, b)]. - - *************************************************** - *** So a TvSubst must be applied precisely once *** - *************************************************** - -A TvSubst is not idempotent, but, unlike the non-idempotent substitution -we use during unifications, it must not be repeatedly applied. - -Note [Extending the TvSubst] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -See #tvsubst_invariant# for the invariants that must hold. - -This invariant allows a short-cut when the TvSubstEnv is empty: -if the TvSubstEnv is empty --- i.e. (isEmptyTvSubt subst) holds --- -then (substTy subst ty) does nothing. - -For example, consider: - (/\a. /\b:(a~Int). ...b..) Int -We substitute Int for 'a'. The Unique of 'b' does not change, but -nevertheless we add 'b' to the TvSubstEnv, because b's kind does change - -This invariant has several crucial consequences: - -* In substTyVarBndr, we need extend the TvSubstEnv - - if the unique has changed - - or if the kind has changed - -* In substTyVar, we do not need to consult the in-scope set; - the TvSubstEnv is enough - -* In substTy, substTheta, we can short-circuit when the TvSubstEnv is empty - - --------------------------------------------------------------- -} - --- | A substitition of 'Type's for 'TyVar's -type TvSubstEnv = TyVarEnv Type - -- A TvSubstEnv is used both inside a TvSubst (with the apply-once - -- invariant discussed in Note [Apply Once]), and also independently - -- in the middle of matching, and unification (see Types.Unify) - -- So you have to look at the context to know if it's idempotent or - -- apply-once or whatever - emptyTvSubstEnv :: TvSubstEnv emptyTvSubstEnv = emptyVarEnv @@ -1280,11 +1248,11 @@ subst1 = TvSubst in_scope env1 emptyTvSubst :: TvSubst -emptyTvSubst = TvSubst emptyInScopeSet emptyVarEnv +emptyTvSubst = TvSubst emptyInScopeSet emptyTvSubstEnv isEmptyTvSubst :: TvSubst -> Bool -- See Note [Extending the TvSubstEnv] -isEmptyTvSubst (TvSubst _ env) = isEmptyVarEnv env +isEmptyTvSubst (TvSubst _ tenv) = isEmptyVarEnv tenv mkTvSubst :: InScopeSet -> TvSubstEnv -> TvSubst mkTvSubst = TvSubst @@ -1298,34 +1266,34 @@ isInScope :: Var -> TvSubst -> Bool isInScope v (TvSubst in_scope _) = v `elemInScopeSet` in_scope -notElemTvSubst :: TyVar -> TvSubst -> Bool -notElemTvSubst tv (TvSubst _ env) = not (tv `elemVarEnv` env) +notElemTvSubst :: TyCoVar -> TvSubst -> Bool +notElemTvSubst v (TvSubst _ tenv) = not (v `elemVarEnv` tenv) setTvSubstEnv :: TvSubst -> TvSubstEnv -> TvSubst -setTvSubstEnv (TvSubst in_scope _) env = TvSubst in_scope env +setTvSubstEnv (TvSubst in_scope _) tenv = TvSubst in_scope tenv zapTvSubstEnv :: TvSubst -> TvSubst zapTvSubstEnv (TvSubst in_scope _) = TvSubst in_scope emptyVarEnv extendTvInScope :: TvSubst -> Var -> TvSubst -extendTvInScope (TvSubst in_scope env) var = TvSubst (extendInScopeSet in_scope var) env +extendTvInScope (TvSubst in_scope tenv) var = TvSubst (extendInScopeSet in_scope var) tenv extendTvInScopeList :: TvSubst -> [Var] -> TvSubst -extendTvInScopeList (TvSubst in_scope env) vars = TvSubst (extendInScopeSetList in_scope vars) env +extendTvInScopeList (TvSubst in_scope tenv) vars = TvSubst (extendInScopeSetList in_scope vars) tenv extendTvSubst :: TvSubst -> TyVar -> Type -> TvSubst -extendTvSubst (TvSubst in_scope env) tv ty = TvSubst in_scope (extendVarEnv env tv ty) +extendTvSubst (TvSubst in_scope tenv) tv ty = TvSubst in_scope (extendVarEnv tenv tv ty) extendTvSubstList :: TvSubst -> [TyVar] -> [Type] -> TvSubst -extendTvSubstList (TvSubst in_scope env) tvs tys - = TvSubst in_scope (extendVarEnvList env (tvs `zip` tys)) +extendTvSubstList (TvSubst in_scope tenv) tvs tys + = TvSubst in_scope (extendVarEnvList tenv (tvs `zip` tys)) unionTvSubst :: TvSubst -> TvSubst -> TvSubst -- Works when the ranges are disjoint -unionTvSubst (TvSubst in_scope1 env1) (TvSubst in_scope2 env2) - = ASSERT( not (env1 `intersectsVarEnv` env2) ) +unionTvSubst (TvSubst in_scope1 tenv1) (TvSubst in_scope2 tenv2) + = ASSERT( not (tenv1 `intersectsVarEnv` tenv2) ) TvSubst (in_scope1 `unionInScope` in_scope2) - (env1 `plusVarEnv` env2) + (tenv1 `plusVarEnv` tenv2) -- mkOpenTvSubst and zipOpenTvSubst generate the in-scope set from -- the types given; but it's just a thunk so with a bit of luck @@ -1347,7 +1315,7 @@ -- | Generates the in-scope set for the 'TvSubst' from the types in the incoming -- environment, hence "open" mkOpenTvSubst :: TvSubstEnv -> TvSubst -mkOpenTvSubst env = TvSubst (mkInScopeSet (tyVarsOfTypes (varEnvElts env))) env +mkOpenTvSubst tenv = TvSubst (mkInScopeSet (tyVarsOfTypes (varEnvElts tenv))) tenv -- | Generates the in-scope set for the 'TvSubst' from the types in the incoming -- environment, hence "open" @@ -1373,7 +1341,7 @@ zipTyEnv :: [TyVar] -> [Type] -> TvSubstEnv zipTyEnv tyvars tys | debugIsOn && (length tyvars /= length tys) - = pprTrace "mkTopTvSubst" (ppr tyvars $$ ppr tys) emptyVarEnv + = pprTrace "zipTyEnv" (ppr tyvars $$ ppr tys) emptyVarEnv | otherwise = zip_ty_env tyvars tys emptyVarEnv @@ -1398,10 +1366,10 @@ -- zip_ty_env _ _ env = env instance Outputable TvSubst where - ppr (TvSubst ins env) + ppr (TvSubst ins tenv) = brackets $ sep[ ptext (sLit "TvSubst"), nest 2 (ptext (sLit "In scope:") <+> ppr ins), - nest 2 (ptext (sLit "Env:") <+> ppr env) ] + nest 2 (ptext (sLit "Type env:") <+> ppr tenv) ] \end{code} %************************************************************************ @@ -1476,29 +1444,34 @@ ForAllTy tv' $! (subst_ty subst' ty) substTyVar :: TvSubst -> TyVar -> Type -substTyVar subst@(TvSubst _ _) tv - = case lookupTyVar subst tv of { - Nothing -> TyVarTy tv; - Just ty -> ty -- See Note [Apply Once] - } +substTyVar (TvSubst _ tenv) tv + | Just ty <- lookupVarEnv tenv tv = ty -- See Note [Apply Once] + | otherwise = ASSERT( isTyVar tv ) TyVarTy tv + -- We do not require that the tyvar is in scope + -- Reason: we do quite a bit of (substTyWith [tv] [ty] tau) + -- and it's a nuisance to bring all the free vars of tau into + -- scope --- and then force that thunk at every tyvar + -- Instead we have an ASSERT in substTyVarBndr to check for capture substTyVars :: TvSubst -> [TyVar] -> [Type] substTyVars subst tvs = map (substTyVar subst) tvs lookupTyVar :: TvSubst -> TyVar -> Maybe Type -- See Note [Extending the TvSubst] -lookupTyVar (TvSubst _ env) tv = lookupVarEnv env tv +lookupTyVar (TvSubst _ tenv) tv = lookupVarEnv tenv tv -substTyVarBndr :: TvSubst -> TyVar -> (TvSubst, TyVar) -substTyVarBndr subst@(TvSubst in_scope env) old_var - = (TvSubst (in_scope `extendInScopeSet` new_var) new_env, new_var) +substTyVarBndr :: TvSubst -> TyVar -> (TvSubst, TyVar) +substTyVarBndr subst@(TvSubst in_scope tenv) old_var + = ASSERT2( _no_capture, ppr old_var $$ ppr subst ) + (TvSubst (in_scope `extendInScopeSet` new_var) new_env, new_var) where - is_co_var = isCoVar old_var + new_env | no_change = delVarEnv tenv old_var + | otherwise = extendVarEnv tenv old_var (TyVarTy new_var) - new_env | no_change = delVarEnv env old_var - | otherwise = extendVarEnv env old_var (TyVarTy new_var) + _no_capture = not (new_var `elemVarSet` tyVarsOfTypes (varEnvElts tenv)) + -- Assertion check that we are not capturing something in the substitution - no_change = new_var == old_var && not is_co_var + no_change = new_var == old_var -- no_change means that the new_var is identical in -- all respects to the old_var (same unique, same kind) -- See Note [Extending the TvSubst] @@ -1509,14 +1482,16 @@ -- (\x.e) with id_subst = [x |-> e'] -- Here we must simply zap the substitution for x - new_var = uniqAway in_scope subst_old_var + new_var = uniqAway in_scope old_var -- The uniqAway part makes sure the new variable is not already in scope - subst_old_var -- subst_old_var is old_var with the substitution applied to its kind - -- It's only worth doing the substitution for coercions, - -- becuase only they can have free type variables - | is_co_var = setTyVarKind old_var (substTy subst (tyVarKind old_var)) - | otherwise = old_var +cloneTyVarBndr :: TvSubst -> TyVar -> Unique -> (TvSubst, TyVar) +cloneTyVarBndr (TvSubst in_scope tv_env) tv uniq + = (TvSubst (extendInScopeSet in_scope tv') + (extendVarEnv tv_env tv (mkTyVarTy tv')), tv') + where + tv' = setVarUnique tv uniq -- Simply set the unique; the kind + -- has no type variables to worry about \end{code} ---------------------------------------------------- diff -Nru ghc-7.0.3/compiler/types/TypeRep.lhs ghc-7.2.1/compiler/types/TypeRep.lhs --- ghc-7.0.3/compiler/types/TypeRep.lhs 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/types/TypeRep.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -7,44 +7,35 @@ \begin{code} -- We expose the relevant stuff from this module via the Type module {-# OPTIONS_HADDOCK hide #-} -{-# LANGUAGE DeriveDataTypeable #-} - +{-# LANGUAGE DeriveDataTypeable, DeriveFunctor, DeriveFoldable, DeriveTraversable #-} module TypeRep ( TyThing(..), Type(..), - PredType(..), -- to friends + Pred(..), -- to friends - Kind, ThetaType, -- Synonyms + Kind, SuperKind, + PredType, ThetaType, -- Synonyms - funTyCon, funTyConName, + -- Functions over types + mkTyConApp, mkTyConTy, mkTyVarTy, mkTyVarTys, + isLiftedTypeKind, isCoercionKind, - -- Pretty-printing + -- Pretty-printing pprType, pprParendType, pprTypeApp, pprTyThing, pprTyThingCategory, - pprPred, pprEqPred, pprTheta, pprForAll, pprThetaArrow, pprClassPred, + pprPredTy, pprEqPred, pprTheta, pprForAll, pprThetaArrowTy, pprClassPred, + pprKind, pprParendKind, + Prec(..), maybeParen, pprTcApp, pprTypeNameApp, + pprPrefixApp, pprPred, pprArrowChain, pprThetaArrow, + + -- Free variables + tyVarsOfType, tyVarsOfTypes, + tyVarsOfPred, tyVarsOfTheta, + varsOfPred, varsOfTheta, + predSize, - -- Kinds - liftedTypeKind, unliftedTypeKind, openTypeKind, - argTypeKind, ubxTupleKind, - isLiftedTypeKindCon, isLiftedTypeKind, - mkArrowKind, mkArrowKinds, isCoercionKind, - coVarPred, - - -- Kind constructors... - liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon, - argTypeKindTyCon, ubxTupleKindTyCon, - - -- And their names - unliftedTypeKindTyConName, openTypeKindTyConName, - ubxTupleKindTyConName, argTypeKindTyConName, - liftedTypeKindTyConName, - - -- Super Kinds - tySuperKind, coSuperKind, - isTySuperKind, isCoSuperKind, - tySuperKindTyCon, coSuperKindTyCon, - - pprKind, pprParendKind + -- Substitutions + TvSubst(..), TvSubstEnv ) where #include "HsVersions.h" @@ -53,6 +44,8 @@ -- friends: import Var +import VarEnv +import VarSet import Name import BasicTypes import TyCon @@ -62,9 +55,12 @@ import PrelNames import Outputable import FastString +import Pair -- libraries -import Data.Data hiding ( TyCon ) +import qualified Data.Data as Data hiding ( TyCon ) +import qualified Data.Foldable as Data +import qualified Data.Traversable as Data \end{code} ---------------------- @@ -120,13 +116,14 @@ \begin{code} -- | The key representation of types within the compiler data Type - = TyVarTy TyVar -- ^ Vanilla type variable + = TyVarTy TyVar -- ^ Vanilla type variable (*never* a coercion variable) | AppTy Type Type -- ^ Type application to something other than a 'TyCon'. Parameters: -- - -- 1) Function: must /not/ be a 'TyConApp', must be another 'AppTy', or 'TyVarTy' + -- 1) Function: must /not/ be a 'TyConApp', + -- must be another 'AppTy', or 'TyVarTy' -- -- 2) Argument type @@ -135,31 +132,35 @@ [Type] -- ^ Application of a 'TyCon', including newtypes /and/ synonyms. -- Invariant: saturated appliations of 'FunTyCon' must -- use 'FunTy' and saturated synonyms must use their own - -- constructors. However, /unsaturated/ 'FunTyCon's do appear as 'TyConApp's. + -- constructors. However, /unsaturated/ 'FunTyCon's + -- do appear as 'TyConApp's. -- Parameters: -- -- 1) Type constructor being applied to. -- - -- 2) Type arguments. Might not have enough type arguments here to saturate the constructor. - -- Even type synonyms are not necessarily saturated; for example unsaturated type synonyms - -- can appear as the right hand side of a type synonym. + -- 2) Type arguments. Might not have enough type arguments + -- here to saturate the constructor. + -- Even type synonyms are not necessarily saturated; + -- for example unsaturated type synonyms + -- can appear as the right hand side of a type synonym. | FunTy - Type + Type Type -- ^ Special case of 'TyConApp': @TyConApp FunTyCon [t1, t2]@ + -- See Note [Equality-constrained types] | ForAllTy - TyVar + TyCoVar -- Type variable Type -- ^ A polymorphic type | PredTy PredType -- ^ The type of evidence for a type predictate. -- Note that a @PredTy (EqPred _ _)@ can appear only as the kind - -- of a coercion variable; never as the argument or result - -- of a 'FunTy' (unlike the 'PredType' constructors 'ClassP' or 'IParam') + -- of a coercion variable; never as the argument or result of a + -- 'FunTy' (unlike the 'PredType' constructors 'ClassP' or 'IParam') -- See Note [PredTy], and Note [Equality predicates] - deriving (Data, Typeable) + deriving (Data.Data, Data.Typeable) -- | The key type representing kinds in the compiler. -- Invariant: a kind is always in one of these forms: @@ -177,6 +178,15 @@ type SuperKind = Type \end{code} +Note [Equality-constrained types] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The type forall ab. (a ~ [b]) => blah +is encoded like this: + + ForAllTy (a:*) $ ForAllTy (b:*) $ + FunTy (PredTy (EqPred a [b]) $ + blah + ------------------------------------- Note [PredTy] @@ -197,11 +207,13 @@ -- > h :: (r\l) => {r} => {l::Int | r} -- -- Here the @Eq a@ and @?x :: Int -> Int@ and @r\l@ are all called \"predicates\" -data PredType - = ClassP Class [Type] -- ^ Class predicate e.g. @Eq a@ - | IParam (IPName Name) Type -- ^ Implicit parameter e.g. @?x :: Int@ - | EqPred Type Type -- ^ Equality predicate e.g @ty1 ~ ty2@ - deriving (Data, Typeable) +type PredType = Pred Type + +data Pred a -- Typically 'a' is instantiated with Type or Coercion + = ClassP Class [a] -- ^ Class predicate e.g. @Eq a@ + | IParam (IPName Name) a -- ^ Implicit parameter e.g. @?x :: Int@ + | EqPred a a -- ^ Equality predicate e.g @ty1 ~ ty2@ + deriving (Data.Data, Data.Typeable, Data.Foldable, Data.Traversable, Functor) -- | A collection of 'PredType's type ThetaType = [PredType] @@ -240,6 +252,89 @@ %************************************************************************ %* * + Simple constructors +%* * +%************************************************************************ + +These functions are here so that they can be used by TysPrim, +which in turn is imported by Type + +\begin{code} +mkTyVarTy :: TyVar -> Type +mkTyVarTy = TyVarTy + +mkTyVarTys :: [TyVar] -> [Type] +mkTyVarTys = map mkTyVarTy -- a common use of mkTyVarTy + +-- | A key function: builds a 'TyConApp' or 'FunTy' as apppropriate to its arguments. +-- Applies its arguments to the constructor from left to right +mkTyConApp :: TyCon -> [Type] -> Type +mkTyConApp tycon tys + | isFunTyCon tycon, [ty1,ty2] <- tys + = FunTy ty1 ty2 + + | otherwise + = TyConApp tycon tys + +-- | Create the plain type constructor type which has been applied to no type arguments at all. +mkTyConTy :: TyCon -> Type +mkTyConTy tycon = mkTyConApp tycon [] + +isLiftedTypeKind :: Kind -> Bool +-- This function is here because it's used in the pretty printer +isLiftedTypeKind (TyConApp tc []) = tc `hasKey` liftedTypeKindTyConKey +isLiftedTypeKind _ = False + +isCoercionKind :: Kind -> Bool +-- All coercions are of form (ty1 ~ ty2) +-- This function is here rather than in Coercion, because it +-- is used in a knot-tied way to enforce invariants in Var +isCoercionKind (PredTy (EqPred {})) = True +isCoercionKind _ = False +\end{code} + + +%************************************************************************ +%* * + Free variables of types and coercions +%* * +%************************************************************************ + +\begin{code} +tyVarsOfPred :: PredType -> TyCoVarSet +tyVarsOfPred = varsOfPred tyVarsOfType + +tyVarsOfTheta :: ThetaType -> TyCoVarSet +tyVarsOfTheta = varsOfTheta tyVarsOfType + +tyVarsOfType :: Type -> VarSet +-- ^ NB: for type synonyms tyVarsOfType does /not/ expand the synonym +tyVarsOfType (TyVarTy v) = unitVarSet v +tyVarsOfType (TyConApp _ tys) = tyVarsOfTypes tys +tyVarsOfType (PredTy sty) = varsOfPred tyVarsOfType sty +tyVarsOfType (FunTy arg res) = tyVarsOfType arg `unionVarSet` tyVarsOfType res +tyVarsOfType (AppTy fun arg) = tyVarsOfType fun `unionVarSet` tyVarsOfType arg +tyVarsOfType (ForAllTy tyvar ty) = delVarSet (tyVarsOfType ty) tyvar + +tyVarsOfTypes :: [Type] -> TyVarSet +tyVarsOfTypes tys = foldr (unionVarSet . tyVarsOfType) emptyVarSet tys + +varsOfPred :: (a -> VarSet) -> Pred a -> VarSet +varsOfPred f (IParam _ ty) = f ty +varsOfPred f (ClassP _ tys) = foldr (unionVarSet . f) emptyVarSet tys +varsOfPred f (EqPred ty1 ty2) = f ty1 `unionVarSet` f ty2 + +varsOfTheta :: (a -> VarSet) -> [Pred a] -> VarSet +varsOfTheta f = foldr (unionVarSet . varsOfPred f) emptyVarSet + +predSize :: (a -> Int) -> Pred a -> Int +predSize size (IParam _ t) = 1 + size t +predSize size (ClassP _ ts) = 1 + sum (map size ts) +predSize size (EqPred t1 t2) = size t1 + size t2 +\end{code} + +%************************************************************************ +%* * TyThing %* * %************************************************************************ @@ -253,6 +348,7 @@ data TyThing = AnId Id | ADataCon DataCon | ATyCon TyCon + | ACoAxiom CoAxiom | AClass Class instance Outputable TyThing where @@ -263,6 +359,7 @@ pprTyThingCategory :: TyThing -> SDoc pprTyThingCategory (ATyCon _) = ptext (sLit "Type constructor") +pprTyThingCategory (ACoAxiom _) = ptext (sLit "Coercion axiom") pprTyThingCategory (AClass _) = ptext (sLit "Class") pprTyThingCategory (AnId _) = ptext (sLit "Identifier") pprTyThingCategory (ADataCon _) = ptext (sLit "Data constructor") @@ -270,6 +367,7 @@ instance NamedThing TyThing where -- Can't put this with the type getName (AnId id) = getName id -- decl, because the DataCon instance getName (ATyCon tc) = getName tc -- isn't visible there + getName (ACoAxiom cc) = getName cc getName (AClass cl) = getName cl getName (ADataCon dc) = dataConName dc \end{code} @@ -277,131 +375,92 @@ %************************************************************************ %* * - Wired-in type constructors + Substitutions + Data type defined here to avoid unnecessary mutual recursion %* * %************************************************************************ -We define a few wired-in type constructors here to avoid module knots - \begin{code} --------------------------- --- First the TyCons... - --- | See "Type#kind_subtyping" for details of the distinction between the 'Kind' 'TyCon's -funTyCon, tySuperKindTyCon, coSuperKindTyCon, liftedTypeKindTyCon, - openTypeKindTyCon, unliftedTypeKindTyCon, - ubxTupleKindTyCon, argTypeKindTyCon - :: TyCon -funTyConName, tySuperKindTyConName, coSuperKindTyConName, liftedTypeKindTyConName, - openTypeKindTyConName, unliftedTypeKindTyConName, - ubxTupleKindTyConName, argTypeKindTyConName - :: Name - -funTyCon = mkFunTyCon funTyConName (mkArrowKinds [argTypeKind, openTypeKind] liftedTypeKind) - -- You might think that (->) should have type (?? -> ? -> *), and you'd be right - -- But if we do that we get kind errors when saying - -- instance Control.Arrow (->) - -- becuase the expected kind is (*->*->*). The trouble is that the - -- expected/actual stuff in the unifier does not go contra-variant, whereas - -- the kind sub-typing does. Sigh. It really only matters if you use (->) in - -- a prefix way, thus: (->) Int# Int#. And this is unusual. - - -tySuperKindTyCon = mkSuperKindTyCon tySuperKindTyConName -coSuperKindTyCon = mkSuperKindTyCon coSuperKindTyConName - -liftedTypeKindTyCon = mkKindTyCon liftedTypeKindTyConName tySuperKind -openTypeKindTyCon = mkKindTyCon openTypeKindTyConName tySuperKind -unliftedTypeKindTyCon = mkKindTyCon unliftedTypeKindTyConName tySuperKind -ubxTupleKindTyCon = mkKindTyCon ubxTupleKindTyConName tySuperKind -argTypeKindTyCon = mkKindTyCon argTypeKindTyConName tySuperKind - --------------------------- --- ... and now their names - -tySuperKindTyConName = mkPrimTyConName (fsLit "BOX") tySuperKindTyConKey tySuperKindTyCon -coSuperKindTyConName = mkPrimTyConName (fsLit "COERCION") coSuperKindTyConKey coSuperKindTyCon -liftedTypeKindTyConName = mkPrimTyConName (fsLit "*") liftedTypeKindTyConKey liftedTypeKindTyCon -openTypeKindTyConName = mkPrimTyConName (fsLit "?") openTypeKindTyConKey openTypeKindTyCon -unliftedTypeKindTyConName = mkPrimTyConName (fsLit "#") unliftedTypeKindTyConKey unliftedTypeKindTyCon -ubxTupleKindTyConName = mkPrimTyConName (fsLit "(#)") ubxTupleKindTyConKey ubxTupleKindTyCon -argTypeKindTyConName = mkPrimTyConName (fsLit "??") argTypeKindTyConKey argTypeKindTyCon -funTyConName = mkPrimTyConName (fsLit "(->)") funTyConKey funTyCon - -mkPrimTyConName :: FastString -> Unique -> TyCon -> Name -mkPrimTyConName occ key tycon = mkWiredInName gHC_PRIM (mkTcOccFS occ) - key - (ATyCon tycon) - BuiltInSyntax - -- All of the super kinds and kinds are defined in Prim and use BuiltInSyntax, - -- because they are never in scope in the source - ------------------- --- We also need Kinds and SuperKinds, locally and in TyCon - -kindTyConType :: TyCon -> Type -kindTyConType kind = TyConApp kind [] - --- | See "Type#kind_subtyping" for details of the distinction between these 'Kind's -liftedTypeKind, unliftedTypeKind, openTypeKind, argTypeKind, ubxTupleKind :: Kind - -liftedTypeKind = kindTyConType liftedTypeKindTyCon -unliftedTypeKind = kindTyConType unliftedTypeKindTyCon -openTypeKind = kindTyConType openTypeKindTyCon -argTypeKind = kindTyConType argTypeKindTyCon -ubxTupleKind = kindTyConType ubxTupleKindTyCon - --- | Given two kinds @k1@ and @k2@, creates the 'Kind' @k1 -> k2@ -mkArrowKind :: Kind -> Kind -> Kind -mkArrowKind k1 k2 = FunTy k1 k2 - --- | Iterated application of 'mkArrowKind' -mkArrowKinds :: [Kind] -> Kind -> Kind -mkArrowKinds arg_kinds result_kind = foldr mkArrowKind result_kind arg_kinds - -tySuperKind, coSuperKind :: SuperKind -tySuperKind = kindTyConType tySuperKindTyCon -coSuperKind = kindTyConType coSuperKindTyCon - -isTySuperKind :: SuperKind -> Bool -isTySuperKind (TyConApp kc []) = kc `hasKey` tySuperKindTyConKey -isTySuperKind _ = False - -isCoSuperKind :: SuperKind -> Bool -isCoSuperKind (TyConApp kc []) = kc `hasKey` coSuperKindTyConKey -isCoSuperKind _ = False - -------------------- --- Lastly we need a few functions on Kinds +-- | Type substitution +-- +-- #tvsubst_invariant# +-- The following invariants must hold of a 'TvSubst': +-- +-- 1. The in-scope set is needed /only/ to +-- guide the generation of fresh uniques +-- +-- 2. In particular, the /kind/ of the type variables in +-- the in-scope set is not relevant +-- +-- 3. The substition is only applied ONCE! This is because +-- in general such application will not reached a fixed point. +data TvSubst + = TvSubst InScopeSet -- The in-scope type variables + TvSubstEnv -- Substitution of types + -- See Note [Apply Once] + -- and Note [Extending the TvSubstEnv] + +-- | A substitition of 'Type's for 'TyVar's +type TvSubstEnv = TyVarEnv Type + -- A TvSubstEnv is used both inside a TvSubst (with the apply-once + -- invariant discussed in Note [Apply Once]), and also independently + -- in the middle of matching, and unification (see Types.Unify) + -- So you have to look at the context to know if it's idempotent or + -- apply-once or whatever +\end{code} -isLiftedTypeKindCon :: TyCon -> Bool -isLiftedTypeKindCon tc = tc `hasKey` liftedTypeKindTyConKey +Note [Apply Once] +~~~~~~~~~~~~~~~~~ +We use TvSubsts to instantiate things, and we might instantiate + forall a b. ty +\with the types + [a, b], or [b, a]. +So the substition might go [a->b, b->a]. A similar situation arises in Core +when we find a beta redex like + (/\ a /\ b -> e) b a +Then we also end up with a substition that permutes type variables. Other +variations happen to; for example [a -> (a, b)]. + + *************************************************** + *** So a TvSubst must be applied precisely once *** + *************************************************** + +A TvSubst is not idempotent, but, unlike the non-idempotent substitution +we use during unifications, it must not be repeatedly applied. + +Note [Extending the TvSubst] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +See #tvsubst_invariant# for the invariants that must hold. + +This invariant allows a short-cut when the TvSubstEnv is empty: +if the TvSubstEnv is empty --- i.e. (isEmptyTvSubt subst) holds --- +then (substTy subst ty) does nothing. + +For example, consider: + (/\a. /\b:(a~Int). ...b..) Int +We substitute Int for 'a'. The Unique of 'b' does not change, but +nevertheless we add 'b' to the TvSubstEnv, because b's kind does change + +This invariant has several crucial consequences: + +* In substTyVarBndr, we need extend the TvSubstEnv + - if the unique has changed + - or if the kind has changed -isLiftedTypeKind :: Kind -> Bool -isLiftedTypeKind (TyConApp tc []) = isLiftedTypeKindCon tc -isLiftedTypeKind _ = False +* In substTyVar, we do not need to consult the in-scope set; + the TvSubstEnv is enough -isCoercionKind :: Kind -> Bool --- All coercions are of form (ty1 ~ ty2) --- This function is here rather than in Coercion, --- because it's used in a knot-tied way to enforce invariants in Var -isCoercionKind (PredTy (EqPred {})) = True -isCoercionKind _ = False - -coVarPred :: CoVar -> PredType -coVarPred tv - = ASSERT( isCoVar tv ) - case tyVarKind tv of - PredTy eq -> eq - other -> pprPanic "coVarPred" (ppr tv $$ ppr other) +* In substTy, substTheta, we can short-circuit when the TvSubstEnv is empty \end{code} %************************************************************************ %* * -\subsection{The external interface} -%* * + Pretty-printing types + + Defined very early because of debug printing in assertions +%* * %************************************************************************ @pprType@ is the standard @Type@ printer; the overloaded @ppr@ function is @@ -422,43 +481,58 @@ ------------------ pprType, pprParendType :: Type -> SDoc -pprType ty = ppr_type TopPrec ty +pprType ty = ppr_type TopPrec ty pprParendType ty = ppr_type TyConPrec ty -pprTypeApp :: NamedThing a => a -> [Type] -> SDoc --- The first arg is the tycon, or sometimes class --- Print infix if the tycon/class looks like an operator -pprTypeApp tc tys = ppr_type_app TopPrec (getName tc) tys +pprKind, pprParendKind :: Kind -> SDoc +pprKind = pprType +pprParendKind = pprParendType ------------------ -pprPred :: PredType -> SDoc -pprPred (ClassP cls tys) = pprClassPred cls tys -pprPred (IParam ip ty) = ppr ip <> dcolon <> pprType ty -pprPred (EqPred ty1 ty2) = pprEqPred (ty1,ty2) - -pprEqPred :: (Type,Type) -> SDoc -pprEqPred (ty1,ty2) = sep [ ppr_type FunPrec ty1 - , nest 2 (ptext (sLit "~")) - , ppr_type FunPrec ty2] +pprPredTy :: PredType -> SDoc +pprPredTy = pprPred ppr_type + +pprPred :: (Prec -> a -> SDoc) -> Pred a -> SDoc +pprPred pp (ClassP cls tys) = ppr_class_pred pp cls tys +pprPred pp (IParam ip ty) = ppr ip <> dcolon <> pp TopPrec ty +pprPred pp (EqPred ty1 ty2) = ppr_eq_pred pp (Pair ty1 ty2) + +------------ +pprEqPred :: Pair Type -> SDoc +pprEqPred = ppr_eq_pred ppr_type + +ppr_eq_pred :: (Prec -> a -> SDoc) -> Pair a -> SDoc +ppr_eq_pred pp (Pair ty1 ty2) = sep [ pp FunPrec ty1 + , nest 2 (ptext (sLit "~")) + , pp FunPrec ty2] -- Precedence looks like (->) so that we get -- Maybe a ~ Bool -- (a->a) ~ Bool -- Note parens on the latter! +------------ pprClassPred :: Class -> [Type] -> SDoc -pprClassPred clas tys = ppr_type_app TopPrec (getName clas) tys +pprClassPred = ppr_class_pred ppr_type + +ppr_class_pred :: (Prec -> a -> SDoc) -> Class -> [a] -> SDoc +ppr_class_pred pp clas tys = pprTypeNameApp TopPrec pp (getName clas) tys +------------ pprTheta :: ThetaType -> SDoc -- pprTheta [pred] = pprPred pred -- I'm in two minds about this -pprTheta theta = parens (sep (punctuate comma (map pprPred theta))) +pprTheta theta = parens (sep (punctuate comma (map pprPredTy theta))) -pprThetaArrow :: ThetaType -> SDoc -pprThetaArrow [] = empty -pprThetaArrow [pred] - | noParenPred pred = pprPred pred <+> darrow -pprThetaArrow preds = parens (sep (punctuate comma (map pprPred preds))) <+> darrow +pprThetaArrowTy :: ThetaType -> SDoc +pprThetaArrowTy = pprThetaArrow ppr_type -noParenPred :: PredType -> Bool +pprThetaArrow :: (Prec -> a -> SDoc) -> [Pred a] -> SDoc +pprThetaArrow _ [] = empty +pprThetaArrow pp [pred] + | noParenPred pred = pprPred pp pred <+> darrow +pprThetaArrow pp preds = parens (sep (punctuate comma (map (pprPred pp) preds))) + <+> darrow + +noParenPred :: Pred a -> Bool -- A predicate that can appear without parens before a "=>" -- C a => a -> a -- a~b => a -> b @@ -471,8 +545,9 @@ instance Outputable Type where ppr ty = pprType ty -instance Outputable PredType where - ppr = pprPred +instance Outputable (Pred Type) where + ppr = pprPredTy -- Not for arbitrary (Pred a), because the + -- (Outputable a) doesn't give precedence instance Outputable name => OutputableBndr (IPName name) where pprBndr _ n = ppr n -- Simple for now @@ -480,95 +555,47 @@ ------------------ -- OK, here's the main printer -pprKind, pprParendKind :: Kind -> SDoc -pprKind = pprType -pprParendKind = pprParendType - ppr_type :: Prec -> Type -> SDoc -ppr_type _ (TyVarTy tv) -- Note [Infix type variables] - | isSymOcc (getOccName tv) = parens (ppr tv) - | otherwise = ppr tv +ppr_type _ (TyVarTy tv) = ppr_tvar tv ppr_type p (PredTy pred) = maybeParen p TyConPrec $ - ifPprDebug (ptext (sLit "")) <> (ppr pred) -ppr_type p (TyConApp tc tys) = ppr_tc_app p tc tys + ifPprDebug (ptext (sLit "")) <> (pprPredTy pred) +ppr_type p (TyConApp tc tys) = pprTcApp p ppr_type tc tys ppr_type p (AppTy t1 t2) = maybeParen p TyConPrec $ pprType t1 <+> ppr_type TyConPrec t2 -ppr_type p ty@(ForAllTy _ _) = ppr_forall_type p ty +ppr_type p ty@(ForAllTy {}) = ppr_forall_type p ty ppr_type p ty@(FunTy (PredTy _) _) = ppr_forall_type p ty ppr_type p (FunTy ty1 ty2) - = -- We don't want to lose synonyms, so we mustn't use splitFunTys here. - maybeParen p FunPrec $ - sep (ppr_type FunPrec ty1 : ppr_fun_tail ty2) + = pprArrowChain p (ppr_type FunPrec ty1 : ppr_fun_tail ty2) where - ppr_fun_tail (FunTy ty1 ty2) - | not (is_pred ty1) = (arrow <+> ppr_type FunPrec ty1) : ppr_fun_tail ty2 - ppr_fun_tail other_ty = [arrow <+> pprType other_ty] + -- We don't want to lose synonyms, so we mustn't use splitFunTys here. + ppr_fun_tail (FunTy ty1 ty2) + | not (is_pred ty1) = ppr_type FunPrec ty1 : ppr_fun_tail ty2 + ppr_fun_tail other_ty = [ppr_type TopPrec other_ty] + is_pred (PredTy {}) = True is_pred _ = False ppr_forall_type :: Prec -> Type -> SDoc ppr_forall_type p ty = maybeParen p FunPrec $ - sep [pprForAll tvs, pprThetaArrow ctxt, pprType tau] + sep [pprForAll tvs, pprThetaArrowTy ctxt, pprType tau] where (tvs, rho) = split1 [] ty (ctxt, tau) = split2 [] rho - -- We need to be extra careful here as equality constraints will occur as - -- type variables with an equality kind. So, while collecting quantified - -- variables, we separate the coercion variables out and turn them into - -- equality predicates. - split1 tvs (ForAllTy tv ty) - | not (isCoVar tv) = split1 (tv:tvs) ty - split1 tvs ty = (reverse tvs, ty) + split1 tvs (ForAllTy tv ty) = split1 (tv:tvs) ty + split1 tvs ty = (reverse tvs, ty) split2 ps (PredTy p `FunTy` ty) = split2 (p:ps) ty - split2 ps (ForAllTy tv ty) - | isCoVar tv = split2 (coVarPred tv : ps) ty split2 ps ty = (reverse ps, ty) -ppr_tc_app :: Prec -> TyCon -> [Type] -> SDoc -ppr_tc_app _ tc [] - = ppr_tc tc -ppr_tc_app _ tc [ty] - | tc `hasKey` listTyConKey = brackets (pprType ty) - | tc `hasKey` parrTyConKey = ptext (sLit "[:") <> pprType ty <> ptext (sLit ":]") - | tc `hasKey` liftedTypeKindTyConKey = ptext (sLit "*") - | tc `hasKey` unliftedTypeKindTyConKey = ptext (sLit "#") - | tc `hasKey` openTypeKindTyConKey = ptext (sLit "(?)") - | tc `hasKey` ubxTupleKindTyConKey = ptext (sLit "(#)") - | tc `hasKey` argTypeKindTyConKey = ptext (sLit "??") - -ppr_tc_app p tc tys - | isTupleTyCon tc && tyConArity tc == length tys - = tupleParens (tupleTyConBoxity tc) (sep (punctuate comma (map pprType tys))) - | otherwise - = ppr_type_app p (getName tc) tys - -ppr_type_app :: Prec -> Name -> [Type] -> SDoc --- Used for classes as well as types; that's why it's separate from ppr_tc_app -ppr_type_app p tc tys - | is_sym_occ -- Print infix if possible - , [ty1,ty2] <- tys -- We know nothing of precedence though - = maybeParen p FunPrec (sep [ppr_type FunPrec ty1, - pprInfixVar True (ppr tc) <+> ppr_type FunPrec ty2]) - | otherwise - = maybeParen p TyConPrec (hang (pprPrefixVar is_sym_occ (ppr tc)) - 2 (sep (map pprParendType tys))) - where - is_sym_occ = isSymOcc (getOccName tc) - -ppr_tc :: TyCon -> SDoc -- No brackets for SymOcc -ppr_tc tc - = pp_nt_debug <> ppr tc - where - pp_nt_debug | isNewTyCon tc = ifPprDebug (if isRecursiveTyCon tc - then ptext (sLit "") - else ptext (sLit "")) - | otherwise = empty +ppr_tvar :: TyVar -> SDoc +ppr_tvar tv -- Note [Infix type variables] + | isSymOcc (getOccName tv) = parens (ppr tv) + | otherwise = ppr tv ------------------- pprForAll :: [TyVar] -> SDoc @@ -576,15 +603,16 @@ pprForAll tvs = ptext (sLit "forall") <+> sep (map pprTvBndr tvs) <> dot pprTvBndr :: TyVar -> SDoc -pprTvBndr tv | isLiftedTypeKind kind = ppr tv - | otherwise = parens (ppr tv <+> dcolon <+> pprKind kind) +pprTvBndr tv + | isLiftedTypeKind kind = ppr_tvar tv + | otherwise = parens (ppr_tvar tv <+> dcolon <+> pprKind kind) where kind = tyVarKind tv \end{code} Note [Infix type variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In Haskell 98 you can say +With TypeOperators you can say f :: (a ~> b) -> b @@ -600,6 +628,59 @@ See Trac #2766. +\begin{code} +pprTcApp :: Prec -> (Prec -> a -> SDoc) -> TyCon -> [a] -> SDoc +pprTcApp _ _ tc [] -- No brackets for SymOcc + = pp_nt_debug <> ppr tc + where + pp_nt_debug | isNewTyCon tc = ifPprDebug (if isRecursiveTyCon tc + then ptext (sLit "") + else ptext (sLit "")) + | otherwise = empty +pprTcApp _ pp tc [ty] + | tc `hasKey` listTyConKey = brackets (pp TopPrec ty) + | tc `hasKey` parrTyConKey = ptext (sLit "[:") <> pp TopPrec ty <> ptext (sLit ":]") + | tc `hasKey` liftedTypeKindTyConKey = ptext (sLit "*") + | tc `hasKey` unliftedTypeKindTyConKey = ptext (sLit "#") + | tc `hasKey` openTypeKindTyConKey = ptext (sLit "(?)") + | tc `hasKey` ubxTupleKindTyConKey = ptext (sLit "(#)") + | tc `hasKey` argTypeKindTyConKey = ptext (sLit "??") + +pprTcApp p pp tc tys + | isTupleTyCon tc && tyConArity tc == length tys + = tupleParens (tupleTyConBoxity tc) (sep (punctuate comma (map (pp TopPrec) tys))) + | otherwise + = pprTypeNameApp p pp (getName tc) tys + +---------------- +pprTypeApp :: NamedThing a => a -> [Type] -> SDoc +-- The first arg is the tycon, or sometimes class +-- Print infix if the tycon/class looks like an operator +pprTypeApp tc tys = pprTypeNameApp TopPrec ppr_type (getName tc) tys +pprTypeNameApp :: Prec -> (Prec -> a -> SDoc) -> Name -> [a] -> SDoc +-- Used for classes and coercions as well as types; that's why it's separate from pprTcApp +pprTypeNameApp p pp tc tys + | is_sym_occ -- Print infix if possible + , [ty1,ty2] <- tys -- We know nothing of precedence though + = maybeParen p FunPrec $ + sep [pp FunPrec ty1, pprInfixVar True (ppr tc) <+> pp FunPrec ty2] + | otherwise + = pprPrefixApp p (pprPrefixVar is_sym_occ (ppr tc)) (map (pp TyConPrec) tys) + where + is_sym_occ = isSymOcc (getOccName tc) + +---------------- +pprPrefixApp :: Prec -> SDoc -> [SDoc] -> SDoc +pprPrefixApp p pp_fun pp_tys = maybeParen p TyConPrec $ + hang pp_fun 2 (sep pp_tys) + +---------------- +pprArrowChain :: Prec -> [SDoc] -> SDoc +-- pprArrowChain p [a,b,c] generates a -> b -> c +pprArrowChain _ [] = empty +pprArrowChain p (arg:args) = maybeParen p FunPrec $ + sep [arg, sep (map (arrow <+>) args)] +\end{code} diff -Nru ghc-7.0.3/compiler/types/TypeRep.lhs-boot ghc-7.2.1/compiler/types/TypeRep.lhs-boot --- ghc-7.0.3/compiler/types/TypeRep.lhs-boot 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/types/TypeRep.lhs-boot 2011-08-07 17:10:05.000000000 +0000 @@ -2,9 +2,10 @@ module TypeRep where data Type -data PredType +data Pred a data TyThing +type PredType = Pred Type type Kind = Type isCoercionKind :: Kind -> Bool diff -Nru ghc-7.0.3/compiler/types/Unify.lhs ghc-7.2.1/compiler/types/Unify.lhs --- ghc-7.0.3/compiler/types/Unify.lhs 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/types/Unify.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -8,9 +8,11 @@ -- the "tc" prefix indicates that matching always -- respects newtypes (rather than looking through them) tcMatchTy, tcMatchTys, tcMatchTyX, - ruleMatchTyX, tcMatchPreds, MatchEnv(..), - - dataConCannotMatch, + ruleMatchTyX, tcMatchPreds, + + MatchEnv(..), matchList, + + typesCantMatch, -- Side-effect free unification tcUnifyTys, BindFlag(..), @@ -23,16 +25,17 @@ import Var import VarEnv import VarSet +import Kind import Type -import Coercion import TyCon -import DataCon import TypeRep import Outputable import ErrUtils import Util import Maybes import FastString + +import Control.Monad (guard) \end{code} @@ -67,9 +70,11 @@ \begin{code} data MatchEnv - = ME { me_tmpls :: VarSet -- Template tyvars + = ME { me_tmpls :: VarSet -- Template variables , me_env :: RnEnv2 -- Renaming envt for nested foralls - } -- In-scope set includes template tyvars + } -- In-scope set includes template variables + -- Nota Bene: MatchEnv isn't specific to Types. It is used + -- for matching terms and coercions as well as types tcMatchTy :: TyVarSet -- Template tyvars -> Type -- Template @@ -121,7 +126,7 @@ -> [PredType] -> [PredType] -> Maybe TvSubstEnv tcMatchPreds tmpls ps1 ps2 - = match_list (match_pred menv) emptyTvSubstEnv ps1 ps2 + = matchList (match_pred menv) emptyTvSubstEnv ps1 ps2 where menv = ME { me_tmpls = mkVarSet tmpls, me_env = mkRnEnv2 in_scope_tyvars } in_scope_tyvars = mkInScopeSet (tyVarsOfTheta ps1 `unionVarSet` tyVarsOfTheta ps2) @@ -155,9 +160,8 @@ match menv subst (TyVarTy tv1) ty2 | Just ty1' <- lookupVarEnv subst tv1' -- tv1' is already bound - = if tcEqTypeX (nukeRnEnvL rn_env) ty1' ty2 + = if eqTypeX (nukeRnEnvL rn_env) ty1' ty2 -- ty1 has no locally-bound variables, hence nukeRnEnvL - -- Note tcEqType...we are doing source-type matching here then Just subst else Nothing -- ty2 doesn't match @@ -201,14 +205,8 @@ match_kind :: MatchEnv -> TvSubstEnv -> TyVar -> Type -> Maybe TvSubstEnv -- Match the kind of the template tyvar with the kind of Type -- Note [Matching kinds] -match_kind menv subst tv ty - | isCoVar tv = do { let (ty1,ty2) = coVarKind tv - (ty3,ty4) = coercionKind ty - ; subst1 <- match menv subst ty1 ty3 - ; match menv subst1 ty2 ty4 } - | otherwise = if typeKind ty `isSubKind` tyVarKind tv - then Just subst - else Nothing +match_kind _ subst tv ty + = guard (typeKind ty `isSubKind` tyVarKind tv) >> return subst -- Note [Matching kinds] -- ~~~~~~~~~~~~~~~~~~~~~ @@ -226,15 +224,15 @@ -------------- match_tys :: MatchEnv -> TvSubstEnv -> [Type] -> [Type] -> Maybe TvSubstEnv -match_tys menv subst tys1 tys2 = match_list (match menv) subst tys1 tys2 +match_tys menv subst tys1 tys2 = matchList (match menv) subst tys1 tys2 -------------- -match_list :: (TvSubstEnv -> a -> a -> Maybe TvSubstEnv) - -> TvSubstEnv -> [a] -> [a] -> Maybe TvSubstEnv -match_list _ subst [] [] = Just subst -match_list fn subst (ty1:tys1) (ty2:tys2) = do { subst' <- fn subst ty1 ty2 - ; match_list fn subst' tys1 tys2 } -match_list _ _ _ _ = Nothing +matchList :: (env -> a -> b -> Maybe env) + -> env -> [a] -> [b] -> Maybe env +matchList _ subst [] [] = Just subst +matchList fn subst (a:as) (b:bs) = do { subst' <- fn subst a b + ; matchList fn subst' as bs } +matchList _ _ _ _ = Nothing -------------- match_pred :: MatchEnv -> TvSubstEnv -> PredType -> PredType -> Maybe TvSubstEnv @@ -318,26 +316,9 @@ distinct data types fail to match. We can elaborate later. \begin{code} -dataConCannotMatch :: [Type] -> DataCon -> Bool --- Returns True iff the data con *definitely cannot* match a --- scrutinee of type (T tys) --- where T is the type constructor for the data con --- -dataConCannotMatch tys con - | null eq_spec = False -- Common - | all isTyVarTy tys = False -- Also common - | otherwise - = cant_match_s (map (substTyVar subst . fst) eq_spec) - (map snd eq_spec) +typesCantMatch :: [(Type,Type)] -> Bool +typesCantMatch prs = any (\(s,t) -> cant_match s t) prs where - dc_tvs = dataConUnivTyVars con - eq_spec = dataConEqSpec con - subst = zipTopTvSubst dc_tvs tys - - cant_match_s :: [Type] -> [Type] -> Bool - cant_match_s tys1 tys2 = ASSERT( equalLength tys1 tys2 ) - or (zipWith cant_match tys1 tys2) - cant_match :: Type -> Type -> Bool cant_match t1 t2 | Just t1' <- coreView t1 = cant_match t1' t2 @@ -348,7 +329,7 @@ cant_match (TyConApp tc1 tys1) (TyConApp tc2 tys2) | isDataTyCon tc1 && isDataTyCon tc2 - = tc1 /= tc2 || cant_match_s tys1 tys2 + = tc1 /= tc2 || typesCantMatch (zipEqual "typesCantMatch" tys1 tys2) cant_match (FunTy {}) (TyConApp tc _) = isDataTyCon tc cant_match (TyConApp tc _) (FunTy {}) = isDataTyCon tc @@ -370,7 +351,6 @@ \end{code} - %************************************************************************ %* * Unification @@ -415,7 +395,7 @@ | otherwise = subst where range_tvs = foldVarEnv (unionVarSet . tyVarsOfType) emptyVarSet e - subst = mkTvSubst (mkInScopeSet range_tvs) e + subst = mkTvSubst (mkInScopeSet range_tvs) e not_fixpoint = foldVarSet ((||) . in_domain) False range_tvs in_domain tv = tv `elemVarEnv` e diff -Nru ghc-7.0.3/compiler/utils/Bag.lhs ghc-7.2.1/compiler/utils/Bag.lhs --- ghc-7.0.3/compiler/utils/Bag.lhs 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/utils/Bag.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -16,7 +16,7 @@ concatBag, foldBag, foldrBag, foldlBag, isEmptyBag, isSingletonBag, consBag, snocBag, anyBag, listToBag, bagToList, - foldlBagM, mapBagM, mapBagM_, + foldrBagM, foldlBagM, mapBagM, mapBagM_, flatMapBagM, flatMapBagPairM, mapAndUnzipBagM, mapAccumBagLM ) where @@ -41,6 +41,7 @@ | 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 @@ -171,6 +172,12 @@ foldlBag k z (TwoBags b1 b2) = foldlBag k (foldlBag k z b1) b2 foldlBag k z (ListBag xs) = foldl k z xs +foldrBagM :: (Monad m) => (a -> b -> m b) -> b -> Bag a -> m b +foldrBagM _ z EmptyBag = return z +foldrBagM k z (UnitBag x) = k x z +foldrBagM k z (TwoBags b1 b2) = do { z' <- foldrBagM k z b2; foldrBagM k z' b1 } +foldrBagM k z (ListBag xs) = foldrM k z xs + foldlBagM :: (Monad m) => (b -> a -> m b) -> b -> Bag a -> m b foldlBagM _ z EmptyBag = return z foldlBagM k z (UnitBag x) = k z x @@ -256,8 +263,6 @@ 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 -Nru ghc-7.0.3/compiler/utils/Binary.hs ghc-7.2.1/compiler/utils/Binary.hs --- ghc-7.0.3/compiler/utils/Binary.hs 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/utils/Binary.hs 2011-08-07 17:10:05.000000000 +0000 @@ -30,7 +30,9 @@ writeBinMem, readBinMem, + fingerprintBinMem, + computeFingerprint, isEOFBin, @@ -74,6 +76,9 @@ import Data.IORef import Data.Char ( ord, chr ) import Data.Typeable +#if __GLASGOW_HASKELL__ >= 701 +import Data.Typeable.Internal +#endif import Control.Monad ( when ) import System.IO as IO import System.IO.Unsafe ( unsafeInterleaveIO ) @@ -82,11 +87,7 @@ import GHC.Exts import GHC.Word ( Word8(..) ) -#if __GLASGOW_HASKELL__ >= 611 import GHC.IO ( IO(..) ) -#else -import GHC.IOBase ( IO(..) ) -#endif type BinArray = ForeignPtr Word8 @@ -241,6 +242,18 @@ ix <- readFastMutInt ix_r withForeignPtr arr $ \p -> fingerprintData p ix +computeFingerprint :: Binary a + => (BinHandle -> Name -> IO ()) + -> a + -> IO Fingerprint + +computeFingerprint put_name a = do + bh <- openBinMem (3*1024) -- just less than a block + ud <- newWriteState put_name putFS + bh <- return $ setUserData bh ud + put_ bh a + fingerprintBinMem bh + -- expand the size of the array to include a specified offset expandBin :: BinHandle -> Int -> IO () expandBin (BinMem _ _ sz_r arr_r) off = do @@ -440,6 +453,15 @@ d <- get bh return (a,b,c,d) +instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d, e) where + put_ bh (a,b,c,d, e) = do put_ bh a; put_ bh b; put_ bh c; put_ bh d; put_ bh e; + get bh = do a <- get bh + b <- get bh + c <- get bh + d <- get bh + e <- get bh + return (a,b,c,d,e) + instance Binary a => Binary (Maybe a) where put_ bh Nothing = putByte bh 0 put_ bh (Just a) = do putByte bh 1; put_ bh a @@ -557,6 +579,14 @@ -- ----------------------------------------------------------------------------- -- Instances for Data.Typeable stuff +#if __GLASGOW_HASKELL__ >= 701 +instance Binary TyCon where + put_ bh (TyCon _ p m n) = do + put_ bh (p,m,n) + get bh = do + (p,m,n) <- get bh + return (mkTyCon3 p m n) +#else instance Binary TyCon where put_ bh ty_con = do let s = tyConString ty_con @@ -564,6 +594,7 @@ get bh = do s <- get bh return (mkTyCon s) +#endif instance Binary TypeRep where put_ bh type_rep = do diff -Nru ghc-7.0.3/compiler/utils/Digraph.lhs ghc-7.2.1/compiler/utils/Digraph.lhs --- ghc-7.0.3/compiler/utils/Digraph.lhs 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/utils/Digraph.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -3,10 +3,11 @@ % \begin{code} +{-# LANGUAGE ScopedTypeVariables #-} module Digraph( Graph, graphFromVerticesAndAdjacency, graphFromEdgedVertices, - SCC(..), flattenSCC, flattenSCCs, + SCC(..), Node, flattenSCC, flattenSCCs, stronglyConnCompG, topologicalSortG, verticesG, edgesG, hasVertexG, reachableG, transposeG, @@ -14,6 +15,8 @@ vertexGroupsG, emptyG, componentsG, + findCycle, + -- For backwards compatability with the simpler version of Digraph stronglyConnCompFromEdgedVertices, stronglyConnCompFromEdgedVerticesR, @@ -37,7 +40,7 @@ ------------------------------------------------------------------------------ -import Util ( sortLe ) +import Util ( sortLe, minWith, count ) import Outputable import Maybes ( expectJust ) import MonadUtils ( allM ) @@ -50,12 +53,9 @@ import Data.Maybe import Data.Array import Data.List ( (\\) ) - -#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ > 604 import Data.Array.ST -#else -import Data.Array.ST hiding ( indices, bounds ) -#endif +import qualified Data.Map as Map +import qualified Data.Set as Set \end{code} %************************************************************************ @@ -83,6 +83,13 @@ data Edge node = Edge node node +type Node key payload = (payload, key, [key]) + -- The payload is user data, just carried around in this module + -- The keys are ordered + -- The [key] are the dependencies of the node; + -- it's ok to have extra keys in the dependencies that + -- are not the key of any Node in the graph + emptyGraph :: Graph a emptyGraph = Graph (array (1, 0) []) (error "emptyGraph") (const Nothing) @@ -106,10 +113,10 @@ graphFromEdgedVertices :: Ord key - => [(node, key, [key])] -- The graph; its ok for the + => [Node key payload] -- The graph; its ok for the -- out-list to contain keys which arent -- a vertex key, they are ignored - -> Graph (node, key, [key]) + -> Graph (Node key payload) graphFromEdgedVertices [] = emptyGraph graphFromEdgedVertices edged_vertices = Graph graph vertex_fn (key_vertex . key_extractor) where key_extractor (_, k, _) = k @@ -152,6 +159,63 @@ %************************************************************************ \begin{code} +type WorkItem key payload + = (Node key payload, -- Tip of the path + [payload]) -- Rest of the path; + -- [a,b,c] means c depends on b, b depends on a + +-- | Find a reasonably short cycle a->b->c->a, in a strongly +-- connected component. The input nodes are presumed to be +-- a SCC, so you can start anywhere. +findCycle :: forall payload key. Ord key + => [Node key payload] -- The nodes. The dependencies can + -- contain extra keys, which are ignored + -> Maybe [payload] -- A cycle, starting with node + -- so each depends on the next +findCycle graph + = go Set.empty (new_work root_deps []) [] + where + env :: Map.Map key (Node key payload) + env = Map.fromList [ (key, node) | node@(_, key, _) <- graph ] + + -- Find the node with fewest dependencies among the SCC modules + -- This is just a heuristic to find some plausible root module + root :: Node key payload + root = fst (minWith snd [ (node, count (`Map.member` env) deps) + | node@(_,_,deps) <- graph ]) + (root_payload,root_key,root_deps) = root + + + -- 'go' implements Dijkstra's algorithm, more or less + go :: Set.Set key -- Visited + -> [WorkItem key payload] -- Work list, items length n + -> [WorkItem key payload] -- Work list, items length n+1 + -> Maybe [payload] -- Returned cycle + -- Invariant: in a call (go visited ps qs), + -- visited = union (map tail (ps ++ qs)) + + go _ [] [] = Nothing -- No cycles + go visited [] qs = go visited qs [] + go visited (((payload,key,deps), path) : ps) qs + | key == root_key = Just (root_payload : reverse path) + | key `Set.member` visited = go visited ps qs + | key `Map.notMember` env = go visited ps qs + | otherwise = go (Set.insert key visited) + ps (new_qs ++ qs) + where + new_qs = new_work deps (payload : path) + + new_work :: [key] -> [payload] -> [WorkItem key payload] + new_work deps path = [ (n, path) | Just n <- map (`Map.lookup` env) deps ] +\end{code} + +%************************************************************************ +%* * +%* SCC +%* * +%************************************************************************ + +\begin{code} data SCC vertex = AcyclicSCC vertex | CyclicSCC [vertex] @@ -169,6 +233,9 @@ instance Outputable a => Outputable (SCC a) where ppr (AcyclicSCC v) = text "NONREC" $$ (nest 3 (ppr v)) ppr (CyclicSCC vs) = text "REC" $$ (nest 3 (vcat (map ppr vs))) +instance PlatformOutputable a => PlatformOutputable (SCC a) where + pprPlatform platform (AcyclicSCC v) = text "NONREC" $$ (nest 3 (pprPlatform platform v)) + pprPlatform platform (CyclicSCC vs) = text "REC" $$ (nest 3 (vcat (map (pprPlatform platform) vs))) \end{code} %************************************************************************ @@ -196,8 +263,8 @@ -- The following two versions are provided for backwards compatability: stronglyConnCompFromEdgedVertices :: Ord key - => [(node, key, [key])] - -> [SCC node] + => [Node key payload] + -> [SCC payload] stronglyConnCompFromEdgedVertices = map (fmap get_node) . stronglyConnCompFromEdgedVerticesR where get_node (n, _, _) = n @@ -205,8 +272,8 @@ -- the (some of) the result of SCC, so you dont want to lose the dependency info stronglyConnCompFromEdgedVerticesR :: Ord key - => [(node, key, [key])] - -> [SCC (node, key, [key])] + => [Node key payload] + -> [SCC (Node key payload)] stronglyConnCompFromEdgedVerticesR = stronglyConnCompG . graphFromEdgedVertices \end{code} diff -Nru ghc-7.0.3/compiler/utils/Encoding.hs ghc-7.2.1/compiler/utils/Encoding.hs --- ghc-7.0.3/compiler/utils/Encoding.hs 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/utils/Encoding.hs 2011-08-07 17:10:05.000000000 +0000 @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# OPTIONS_GHC -O #-} -- We always optimise this, otherwise performance of a non-optimised -- compiler is severely affected @@ -31,7 +32,7 @@ import Foreign import Data.Char import Numeric -import GHC.Ptr ( Ptr(..) ) +import GHC.Ptr ( Ptr(..) ) import GHC.Base -- ----------------------------------------------------------------------------- diff -Nru ghc-7.0.3/compiler/utils/FastFunctions.lhs ghc-7.2.1/compiler/utils/FastFunctions.lhs --- ghc-7.0.3/compiler/utils/FastFunctions.lhs 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/utils/FastFunctions.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -22,21 +22,10 @@ import GHC.Exts import GHC.Word - -#if __GLASGOW_HASKELL__ >= 611 -import GHC.IO ( IO(..) ) -#else -import GHC.IOBase ( IO(..) ) -#endif - -#if __GLASGOW_HASKELL__ >= 611 -import GHC.IO (unsafeDupableInterleaveIO) -#else -import GHC.IOBase (unsafeDupableInterleaveIO) -#endif - import GHC.Base (unsafeChr) +import GHC.IO (IO(..), unsafeDupableInterleaveIO) + -- Just like unsafePerformIO, but we inline it. {-# INLINE inlinePerformIO #-} inlinePerformIO :: IO a -> a diff -Nru ghc-7.0.3/compiler/utils/FastMutInt.lhs ghc-7.2.1/compiler/utils/FastMutInt.lhs --- ghc-7.0.3/compiler/utils/FastMutInt.lhs 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/utils/FastMutInt.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -1,4 +1,5 @@ \begin{code} +{-# LANGUAGE BangPatterns #-} {-# OPTIONS -cpp #-} {-# OPTIONS_GHC -O #-} -- We always optimise this, otherwise performance of a non-optimised @@ -27,12 +28,6 @@ import GHC.Base import GHC.Ptr -#if __GLASGOW_HASKELL__ >= 611 --- import GHC.IO ( IO(..) ) -#else -import GHC.IOBase ( IO(..) ) -#endif - #else /* ! __GLASGOW_HASKELL__ */ import Data.IORef diff -Nru ghc-7.0.3/compiler/utils/FastString.lhs ghc-7.2.1/compiler/utils/FastString.lhs --- ghc-7.0.3/compiler/utils/FastString.lhs 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/utils/FastString.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -2,6 +2,7 @@ % (c) The University of Glasgow, 1997-2006 % \begin{code} +{-# LANGUAGE BangPatterns #-} {-# OPTIONS -fno-warn-unused-imports #-} -- XXX GHC 6.9 seems to be confused by unpackCString# being used only in -- a RULE @@ -95,7 +96,6 @@ import Panic import Util -import Foreign hiding ( unsafePerformIO ) import Foreign.C import GHC.Exts import System.IO @@ -105,13 +105,15 @@ import Data.Maybe ( isJust ) import Data.Char ( ord ) -#if __GLASGOW_HASKELL__ >= 611 -import GHC.IO ( IO(..) ) +import GHC.IO ( IO(..) ) +import GHC.Ptr ( Ptr(..) ) + +#if __GLASGOW_HASKELL__ >= 701 +import Foreign.Safe #else -import GHC.IOBase ( IO(..) ) +import Foreign hiding ( unsafePerformIO ) #endif -import GHC.Ptr ( Ptr(..) ) #if defined(__GLASGOW_HASKELL__) import GHC.Base ( unpackCString# ) #endif diff -Nru ghc-7.0.3/compiler/utils/Fingerprint.hsc ghc-7.2.1/compiler/utils/Fingerprint.hsc --- ghc-7.0.3/compiler/utils/Fingerprint.hsc 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/utils/Fingerprint.hsc 2011-08-07 17:10:05.000000000 +0000 @@ -9,9 +9,10 @@ -- ---------------------------------------------------------------------------- module Fingerprint ( - Fingerprint(..), fingerprint0, + Fingerprint(..), fingerprint0, readHexFingerprint, - fingerprintData + fingerprintData, + fingerprintString ) where #include "md5.h" @@ -19,11 +20,20 @@ import Outputable -import Foreign -import Foreign.C import Text.Printf import Numeric ( readHex ) +##if __GLASGOW_HASKELL__ >= 701 +-- The MD5 implementation is now in base, to support Typeable +import GHC.Fingerprint +##endif + +##if __GLASGOW_HASKELL__ < 701 +import Data.Char +import Foreign +import Foreign.C +import GHC.IO (unsafeDupablePerformIO) + -- Using 128-bit MD5 fingerprints for now. data Fingerprint = Fingerprint {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 @@ -33,19 +43,6 @@ fingerprint0 :: Fingerprint fingerprint0 = Fingerprint 0 0 -instance Outputable Fingerprint where - ppr (Fingerprint w1 w2) = text (printf "%016x%016x" i1 i2) - where i1 = fromIntegral w1 :: Integer - i2 = fromIntegral w2 :: Integer - -- printf in GHC 6.4.2 didn't have Word64 instances - --- useful for parsing the output of 'md5sum', should we want to do that. -readHexFingerprint :: String -> Fingerprint -readHexFingerprint s = Fingerprint w1 w2 - where (s1,s2) = splitAt 16 s - [(w1,"")] = readHex s1 - [(w2,"")] = readHex (take 16 s2) - peekFingerprint :: Ptr Word8 -> IO Fingerprint peekFingerprint p = do let peekW64 :: Ptr Word8 -> Int -> Word64 -> IO Word64 @@ -69,6 +66,19 @@ c_MD5Final pdigest pctxt peekFingerprint (castPtr pdigest) +-- This is duplicated in libraries/base/GHC/Fingerprint.hs +fingerprintString :: String -> Fingerprint +fingerprintString str = unsafeDupablePerformIO $ + withArrayLen word8s $ \len p -> + fingerprintData p len + where word8s = concatMap f str + f c = let w32 :: Word32 + w32 = fromIntegral (ord c) + in [fromIntegral (w32 `shiftR` 24), + fromIntegral (w32 `shiftR` 16), + fromIntegral (w32 `shiftR` 8), + fromIntegral w32] + data MD5Context foreign import ccall unsafe "MD5Init" @@ -77,3 +87,18 @@ c_MD5Update :: Ptr MD5Context -> Ptr Word8 -> CInt -> IO () foreign import ccall unsafe "MD5Final" c_MD5Final :: Ptr Word8 -> Ptr MD5Context -> IO () +##endif + +instance Outputable Fingerprint where + ppr (Fingerprint w1 w2) = text (printf "%016x%016x" i1 i2) + where i1 = fromIntegral w1 :: Integer + i2 = fromIntegral w2 :: Integer + -- printf in GHC 6.4.2 didn't have Word64 instances + +-- useful for parsing the output of 'md5sum', should we want to do that. +readHexFingerprint :: String -> Fingerprint +readHexFingerprint s = Fingerprint w1 w2 + where (s1,s2) = splitAt 16 s + [(w1,"")] = readHex s1 + [(w2,"")] = readHex (take 16 s2) + diff -Nru ghc-7.0.3/compiler/utils/FiniteMap.lhs ghc-7.2.1/compiler/utils/FiniteMap.lhs --- ghc-7.0.3/compiler/utils/FiniteMap.lhs 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/utils/FiniteMap.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -1,3 +1,4 @@ +Some extra functions to extend Data.Map \begin{code} module FiniteMap ( diff -Nru ghc-7.0.3/compiler/utils/GraphOps.hs ghc-7.2.1/compiler/utils/GraphOps.hs --- ghc-7.0.3/compiler/utils/GraphOps.hs 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/utils/GraphOps.hs 2011-08-07 17:10:05.000000000 +0000 @@ -61,14 +61,14 @@ -- add back conflict edges from other nodes to this one map_conflict = foldUniqSet - (adjustUFM (\n -> n { nodeConflicts = addOneToUniqSet (nodeConflicts n) k})) + (adjustUFM_C (\n -> n { nodeConflicts = addOneToUniqSet (nodeConflicts n) k})) (graphMap graph) (nodeConflicts node) -- add back coalesce edges from other nodes to this one map_coalesce = foldUniqSet - (adjustUFM (\n -> n { nodeCoalesce = addOneToUniqSet (nodeCoalesce n) k})) + (adjustUFM_C (\n -> n { nodeCoalesce = addOneToUniqSet (nodeCoalesce n) k})) map_conflict (nodeCoalesce node) @@ -434,7 +434,7 @@ else node -- panic "GraphOps.freezeNode: edge to freeze wasn't in the coalesce set" -- If the edge isn't actually in the coelesce set then just ignore it. - fm2 = foldUniqSet (adjustUFM (freezeEdge k)) fm1 + fm2 = foldUniqSet (adjustUFM_C (freezeEdge k)) fm1 $ nodeCoalesce node in fm2 @@ -604,7 +604,7 @@ setColor u color = graphMapModify - $ adjustUFM + $ adjustUFM_C (\n -> n { nodeColor = Just color }) u @@ -621,13 +621,14 @@ map k def -{-# INLINE adjustUFM #-} -adjustUFM +-- Argument order different from UniqFM's adjustUFM +{-# INLINE adjustUFM_C #-} +adjustUFM_C :: Uniquable k => (a -> a) -> k -> UniqFM a -> UniqFM a -adjustUFM f k map +adjustUFM_C f k map = case lookupUFM map k of Nothing -> map Just a -> addToUFM map k (f a) diff -Nru ghc-7.0.3/compiler/utils/ListSetOps.lhs ghc-7.2.1/compiler/utils/ListSetOps.lhs --- ghc-7.0.3/compiler/utils/ListSetOps.lhs 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/utils/ListSetOps.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -19,6 +19,8 @@ ) where +#include "HsVersions.h" + import Outputable import Unique import UniqFM @@ -41,9 +43,11 @@ insertList x xs | isIn "insert" x xs = xs | otherwise = x : xs -unionLists :: (Eq a) => [a] -> [a] -> [a] +unionLists :: (Outputable a, Eq a) => [a] -> [a] -> [a] -- Assumes that the arguments contain no duplicates -unionLists xs ys = [x | x <- xs, isn'tIn "unionLists" x ys] ++ ys +unionLists xs ys + = WARN(length xs > 100 || length ys > 100, ppr xs $$ ppr ys) + [x | x <- xs, isn'tIn "unionLists" x ys] ++ ys minusList :: (Eq a) => [a] -> [a] -> [a] -- Everything in the first list that is not in the second list: diff -Nru ghc-7.0.3/compiler/utils/md5.c ghc-7.2.1/compiler/utils/md5.c --- ghc-7.0.3/compiler/utils/md5.c 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/utils/md5.c 2011-08-07 17:10:05.000000000 +0000 @@ -15,6 +15,8 @@ * will fill a supplied 16-byte array with the digest. */ +#if __GLASGOW_HASKELL__ < 701 + #include "HsFFI.h" #include "md5.h" #include @@ -236,3 +238,4 @@ buf[3] += d; } +#endif diff -Nru ghc-7.0.3/compiler/utils/MonadUtils.hs ghc-7.2.1/compiler/utils/MonadUtils.hs --- ghc-7.0.3/compiler/utils/MonadUtils.hs 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/utils/MonadUtils.hs 2011-08-07 17:10:05.000000000 +0000 @@ -27,16 +27,16 @@ import Outputable ----------------------------------------------------------------------------------------- +------------------------------------------------------------------------------- -- Detection of available libraries ----------------------------------------------------------------------------------------- +------------------------------------------------------------------------------- -- we don't depend on MTL for now #define HAVE_MTL 0 ----------------------------------------------------------------------------------------- +------------------------------------------------------------------------------- -- Imports ----------------------------------------------------------------------------------------- +------------------------------------------------------------------------------- import Maybes @@ -47,9 +47,9 @@ import Control.Monad import Control.Monad.Fix ----------------------------------------------------------------------------------------- +------------------------------------------------------------------------------- -- The ID monad ----------------------------------------------------------------------------------------- +------------------------------------------------------------------------------- newtype ID a = ID a instance Monad ID where @@ -61,9 +61,9 @@ runID :: ID a -> a runID (ID x) = x ----------------------------------------------------------------------------------------- +------------------------------------------------------------------------------- -- MTL ----------------------------------------------------------------------------------------- +------------------------------------------------------------------------------- #if !HAVE_MTL @@ -73,10 +73,10 @@ instance MonadIO IO where liftIO = id #endif ----------------------------------------------------------------------------------------- +------------------------------------------------------------------------------- -- Lift combinators -- These are used throughout the compiler ----------------------------------------------------------------------------------------- +------------------------------------------------------------------------------- -- | Lift an 'IO' operation with 1 argument into another monad liftIO1 :: MonadIO m => (a -> IO b) -> a -> m b @@ -94,10 +94,10 @@ liftIO4 :: MonadIO m => (a -> b -> c -> d -> IO e) -> a -> b -> c -> d -> m e liftIO4 = (((.).(.)).((.).(.))) liftIO ----------------------------------------------------------------------------------------- +------------------------------------------------------------------------------- -- Common functions -- These are used throughout the compiler ----------------------------------------------------------------------------------------- +------------------------------------------------------------------------------- zipWith3M :: Monad m => (a -> b -> c -> m d) -> [a] -> [b] -> [c] -> m [d] zipWith3M _ [] _ _ = return [] diff -Nru ghc-7.0.3/compiler/utils/Outputable.lhs ghc-7.2.1/compiler/utils/Outputable.lhs --- ghc-7.0.3/compiler/utils/Outputable.lhs 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/utils/Outputable.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -13,9 +13,10 @@ module Outputable ( -- * Type classes Outputable(..), OutputableBndr(..), + PlatformOutputable(..), -- * Pretty printing combinators - SDoc, + SDoc, runSDoc, initSDocContext, docToSDoc, interppSP, interpp'SP, pprQuotedList, pprWithCommas, quotedListWithOr, empty, nest, @@ -33,6 +34,9 @@ hang, punctuate, ppWhen, ppUnless, speakNth, speakNTimes, speakN, speakNOf, plural, + coloured, PprColour, colType, colCoerc, colDataCon, + colBinder, bold, keyword, + -- * Converting 'SDoc' into strings and outputing it printSDoc, printErrs, printOutput, hPrintDump, printDump, printForC, printForAsm, printForUser, printForUserPartWay, @@ -41,6 +45,7 @@ showSDocForUser, showSDocDebug, showSDocDump, showSDocDumpOneLine, showPpr, showSDocUnqual, showsPrecSDoc, + renderWithStyle, pprInfixVar, pprPrefixVar, pprHsChar, pprHsString, pprHsInfix, pprHsVar, @@ -60,7 +65,7 @@ -- * Error handling and debugging utilities pprPanic, pprSorry, assertPprPanic, pprPanicFastInt, pprPgmError, - pprTrace, warnPprTrace, + pprTrace, pprDefiniteTrace, warnPprTrace, trace, pgmError, panic, sorry, panicFastInt, assertPanic ) where @@ -70,19 +75,30 @@ import StaticFlags import FastString import FastTypes +import Platform import qualified Pretty import Pretty ( Doc, Mode(..) ) import Panic import Data.Char -import Data.Map (Map) import qualified Data.Map as M +import qualified Data.IntMap as IM import Data.Word import System.IO ( Handle, stderr, stdout, hFlush ) import System.FilePath + + +#if __GLASGOW_HASKELL__ >= 701 +import GHC.Show ( showMultiLineString ) +#else +showMultiLineString :: String -> [String] +-- Crude version +showMultiLineString s = [ showList s "" ] +#endif \end{code} + %************************************************************************ %* * \subsection{The @PprStyle@ data type} @@ -208,38 +224,56 @@ %************************************************************************ \begin{code} -type SDoc = PprStyle -> Doc +newtype SDoc = SDoc { runSDoc :: SDocContext -> Doc } + +data SDocContext = SDC + { sdocStyle :: !PprStyle + , sdocLastColour :: !PprColour + -- ^ The most recently used colour. This allows nesting colours. + } + +initSDocContext :: PprStyle -> SDocContext +initSDocContext sty = SDC + { sdocStyle = sty + , sdocLastColour = colReset + } withPprStyle :: PprStyle -> SDoc -> SDoc -withPprStyle sty d _sty' = d sty +withPprStyle sty d = SDoc $ \ctxt -> runSDoc d ctxt{sdocStyle=sty} withPprStyleDoc :: PprStyle -> SDoc -> Doc -withPprStyleDoc sty d = d sty +withPprStyleDoc sty d = runSDoc d (initSDocContext sty) pprDeeper :: SDoc -> SDoc -pprDeeper _ (PprUser _ (PartWay 0)) = Pretty.text "..." -pprDeeper d (PprUser q (PartWay n)) = d (PprUser q (PartWay (n-1))) -pprDeeper d other_sty = d other_sty +pprDeeper d = SDoc $ \ctx -> case ctx of + SDC{sdocStyle=PprUser _ (PartWay 0)} -> Pretty.text "..." + SDC{sdocStyle=PprUser q (PartWay n)} -> + runSDoc d ctx{sdocStyle = PprUser q (PartWay (n-1))} + _ -> runSDoc d ctx pprDeeperList :: ([SDoc] -> SDoc) -> [SDoc] -> SDoc -- Truncate a list that list that is longer than the current depth -pprDeeperList f ds (PprUser q (PartWay n)) - | n==0 = Pretty.text "..." - | otherwise = f (go 0 ds) (PprUser q (PartWay (n-1))) - where - go _ [] = [] - go i (d:ds) | i >= n = [text "...."] - | otherwise = d : go (i+1) ds - -pprDeeperList f ds other_sty - = f ds other_sty +pprDeeperList f ds = SDoc work + where + work ctx@SDC{sdocStyle=PprUser q (PartWay n)} + | n==0 = Pretty.text "..." + | otherwise = + runSDoc (f (go 0 ds)) ctx{sdocStyle = PprUser q (PartWay (n-1))} + where + go _ [] = [] + go i (d:ds) | i >= n = [text "...."] + | otherwise = d : go (i+1) ds + work other_ctx = runSDoc (f ds) other_ctx pprSetDepth :: Depth -> SDoc -> SDoc -pprSetDepth depth doc (PprUser q _) = doc (PprUser q depth) -pprSetDepth _depth doc other_sty = doc other_sty +pprSetDepth depth doc = SDoc $ \ctx -> case ctx of + SDC{sdocStyle=PprUser q _} -> + runSDoc doc ctx{sdocStyle = PprUser q depth} + _ -> + runSDoc doc ctx getPprStyle :: (PprStyle -> SDoc) -> SDoc -getPprStyle df sty = df sty sty +getPprStyle df = SDoc $ \ctx -> runSDoc (df (sdocStyle ctx)) ctx \end{code} \begin{code} @@ -272,22 +306,24 @@ userStyle _other = False ifPprDebug :: SDoc -> SDoc -- Empty for non-debug style -ifPprDebug d sty@PprDebug = d sty -ifPprDebug _ _ = Pretty.empty +ifPprDebug d = SDoc $ \ctx -> case ctx of + SDC{sdocStyle=PprDebug} -> runSDoc d ctx + _ -> Pretty.empty \end{code} \begin{code} -- Unused [7/02 sof] printSDoc :: SDoc -> PprStyle -> IO () printSDoc d sty = do - Pretty.printDoc PageMode stdout (d sty) + Pretty.printDoc PageMode stdout (runSDoc d (initSDocContext sty)) hFlush stdout -- I'm not sure whether the direct-IO approach of Pretty.printDoc -- above is better or worse than the put-big-string approach here -printErrs :: Doc -> IO () -printErrs doc = do Pretty.printDoc PageMode stderr doc - hFlush stderr +printErrs :: SDoc -> PprStyle -> IO () +printErrs doc sty = do + Pretty.printDoc PageMode stderr (runSDoc doc (initSDocContext sty)) + hFlush stderr printOutput :: Doc -> IO () printOutput doc = Pretty.printDoc PageMode stdout doc @@ -297,25 +333,32 @@ hPrintDump :: Handle -> SDoc -> IO () hPrintDump h doc = do - Pretty.printDoc PageMode h (better_doc defaultDumpStyle) + Pretty.printDoc PageMode h + (runSDoc better_doc (initSDocContext defaultDumpStyle)) hFlush h where better_doc = doc $$ blankLine printForUser :: Handle -> PrintUnqualified -> SDoc -> IO () printForUser handle unqual doc - = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual AllTheWay)) + = Pretty.printDoc PageMode handle + (runSDoc doc (initSDocContext (mkUserStyle unqual AllTheWay))) printForUserPartWay :: Handle -> Int -> PrintUnqualified -> SDoc -> IO () printForUserPartWay handle d unqual doc - = Pretty.printDoc PageMode handle (doc (mkUserStyle unqual (PartWay d))) + = Pretty.printDoc PageMode handle + (runSDoc doc (initSDocContext (mkUserStyle unqual (PartWay d)))) -- printForC, printForAsm do what they sound like printForC :: Handle -> SDoc -> IO () -printForC handle doc = Pretty.printDoc LeftMode handle (doc (PprCode CStyle)) +printForC handle doc = + Pretty.printDoc LeftMode handle + (runSDoc doc (initSDocContext (PprCode CStyle))) printForAsm :: Handle -> SDoc -> IO () -printForAsm handle doc = Pretty.printDoc LeftMode handle (doc (PprCode AsmStyle)) +printForAsm handle doc = + Pretty.printDoc LeftMode handle + (runSDoc doc (initSDocContext (PprCode AsmStyle))) pprCode :: CodeStyle -> SDoc -> SDoc pprCode cs d = withPprStyle (PprCode cs) d @@ -327,32 +370,44 @@ -- However, Doc *is* an instance of Show -- showSDoc just blasts it out as a string showSDoc :: SDoc -> String -showSDoc d = Pretty.showDocWith PageMode (d defaultUserStyle) +showSDoc d = + Pretty.showDocWith PageMode + (runSDoc d (initSDocContext defaultUserStyle)) + +renderWithStyle :: SDoc -> PprStyle -> String +renderWithStyle sdoc sty = + Pretty.render (runSDoc sdoc (initSDocContext sty)) -- This shows an SDoc, but on one line only. It's cheaper than a full -- showSDoc, designed for when we're getting results like "Foo.bar" -- and "foo{uniq strictness}" so we don't want fancy layout anyway. showSDocOneLine :: SDoc -> String -showSDocOneLine d = Pretty.showDocWith PageMode (d defaultUserStyle) +showSDocOneLine d = + Pretty.showDocWith PageMode + (runSDoc d (initSDocContext defaultUserStyle)) showSDocForUser :: PrintUnqualified -> SDoc -> String -showSDocForUser unqual doc = show (doc (mkUserStyle unqual AllTheWay)) +showSDocForUser unqual doc = + show (runSDoc doc (initSDocContext (mkUserStyle unqual AllTheWay))) showSDocUnqual :: SDoc -> String -- Only used in the gruesome isOperator -showSDocUnqual d = show (d (mkUserStyle neverQualify AllTheWay)) +showSDocUnqual d = + show (runSDoc d (initSDocContext (mkUserStyle neverQualify AllTheWay))) showsPrecSDoc :: Int -> SDoc -> ShowS -showsPrecSDoc p d = showsPrec p (d defaultUserStyle) +showsPrecSDoc p d = showsPrec p (runSDoc d (initSDocContext defaultUserStyle)) showSDocDump :: SDoc -> String -showSDocDump d = Pretty.showDocWith PageMode (d PprDump) +showSDocDump d = + Pretty.showDocWith PageMode (runSDoc d (initSDocContext PprDump)) showSDocDumpOneLine :: SDoc -> String -showSDocDumpOneLine d = Pretty.showDocWith OneLineMode (d PprDump) +showSDocDumpOneLine d = + Pretty.showDocWith OneLineMode (runSDoc d (initSDocContext PprDump)) showSDocDebug :: SDoc -> String -showSDocDebug d = show (d PprDebug) +showSDocDebug d = show (runSDoc d (initSDocContext PprDebug)) showPpr :: Outputable a => a -> String showPpr = showSDoc . ppr @@ -360,7 +415,7 @@ \begin{code} docToSDoc :: Doc -> SDoc -docToSDoc d = \_ -> d +docToSDoc d = SDoc (\_ -> d) empty :: SDoc char :: Char -> SDoc @@ -373,58 +428,58 @@ double :: Double -> SDoc rational :: Rational -> SDoc -empty _sty = Pretty.empty -char c _sty = Pretty.char c -text s _sty = Pretty.text s -ftext s _sty = Pretty.ftext s -ptext s _sty = Pretty.ptext s -int n _sty = Pretty.int n -integer n _sty = Pretty.integer n -float n _sty = Pretty.float n -double n _sty = Pretty.double n -rational n _sty = Pretty.rational n +empty = docToSDoc $ Pretty.empty +char c = docToSDoc $ Pretty.char c +text s = docToSDoc $ Pretty.text s +ftext s = docToSDoc $ Pretty.ftext s +ptext s = docToSDoc $ Pretty.ptext s +int n = docToSDoc $ Pretty.int n +integer n = docToSDoc $ Pretty.integer n +float n = docToSDoc $ Pretty.float n +double n = docToSDoc $ Pretty.double n +rational n = docToSDoc $ Pretty.rational n parens, braces, brackets, quotes, doubleQuotes, angleBrackets :: SDoc -> SDoc -parens d sty = Pretty.parens (d sty) -braces d sty = Pretty.braces (d sty) -brackets d sty = Pretty.brackets (d sty) -doubleQuotes d sty = Pretty.doubleQuotes (d sty) -angleBrackets d = char '<' <> d <> char '>' +parens d = SDoc $ Pretty.parens . runSDoc d +braces d = SDoc $ Pretty.braces . runSDoc d +brackets d = SDoc $ Pretty.brackets . runSDoc d +doubleQuotes d = SDoc $ Pretty.doubleQuotes . runSDoc d +angleBrackets d = char '<' <> d <> char '>' cparen :: Bool -> SDoc -> SDoc -cparen b d sty = Pretty.cparen b (d sty) +cparen b d = SDoc $ Pretty.cparen b . runSDoc d -- quotes encloses something in single quotes... -- but it omits them if the thing ends in a single quote -- so that we don't get `foo''. Instead we just have foo'. -quotes d sty = case show pp_d of - ('\'' : _) -> pp_d - _other -> Pretty.quotes pp_d - where - pp_d = d sty +quotes d = SDoc $ \sty -> + let pp_d = runSDoc d sty in + case show pp_d of + ('\'' : _) -> pp_d + _other -> Pretty.quotes pp_d semi, comma, colon, equals, space, dcolon, arrow, underscore, dot :: SDoc darrow, lparen, rparen, lbrack, rbrack, lbrace, rbrace, blankLine :: SDoc -blankLine _sty = Pretty.ptext (sLit "") -dcolon _sty = Pretty.ptext (sLit "::") -arrow _sty = Pretty.ptext (sLit "->") -darrow _sty = Pretty.ptext (sLit "=>") -semi _sty = Pretty.semi -comma _sty = Pretty.comma -colon _sty = Pretty.colon -equals _sty = Pretty.equals -space _sty = Pretty.space -underscore = char '_' -dot = char '.' -lparen _sty = Pretty.lparen -rparen _sty = Pretty.rparen -lbrack _sty = Pretty.lbrack -rbrack _sty = Pretty.rbrack -lbrace _sty = Pretty.lbrace -rbrace _sty = Pretty.rbrace +blankLine = docToSDoc $ Pretty.ptext (sLit "") +dcolon = docToSDoc $ Pretty.ptext (sLit "::") +arrow = docToSDoc $ Pretty.ptext (sLit "->") +darrow = docToSDoc $ Pretty.ptext (sLit "=>") +semi = docToSDoc $ Pretty.semi +comma = docToSDoc $ Pretty.comma +colon = docToSDoc $ Pretty.colon +equals = docToSDoc $ Pretty.equals +space = docToSDoc $ Pretty.space +underscore = char '_' +dot = char '.' +lparen = docToSDoc $ Pretty.lparen +rparen = docToSDoc $ Pretty.rparen +lbrack = docToSDoc $ Pretty.lbrack +rbrack = docToSDoc $ Pretty.rbrack +lbrace = docToSDoc $ Pretty.lbrace +rbrace = docToSDoc $ Pretty.rbrace nest :: Int -> SDoc -> SDoc -- ^ Indent 'SDoc' some specified amount @@ -438,11 +493,11 @@ ($+$) :: SDoc -> SDoc -> SDoc -- ^ Join two 'SDoc' together vertically -nest n d sty = Pretty.nest n (d sty) -(<>) d1 d2 sty = (Pretty.<>) (d1 sty) (d2 sty) -(<+>) d1 d2 sty = (Pretty.<+>) (d1 sty) (d2 sty) -($$) d1 d2 sty = (Pretty.$$) (d1 sty) (d2 sty) -($+$) d1 d2 sty = (Pretty.$+$) (d1 sty) (d2 sty) +nest n d = SDoc $ Pretty.nest n . runSDoc d +(<>) d1 d2 = SDoc $ \sty -> (Pretty.<>) (runSDoc d1 sty) (runSDoc d2 sty) +(<+>) d1 d2 = SDoc $ \sty -> (Pretty.<+>) (runSDoc d1 sty) (runSDoc d2 sty) +($$) d1 d2 = SDoc $ \sty -> (Pretty.$$) (runSDoc d1 sty) (runSDoc d2 sty) +($+$) d1 d2 = SDoc $ \sty -> (Pretty.$+$) (runSDoc d1 sty) (runSDoc d2 sty) hcat :: [SDoc] -> SDoc -- ^ Concatenate 'SDoc' horizontally @@ -461,19 +516,19 @@ -- ^ This behaves like 'fsep', but it uses '<>' for horizontal conposition rather than '<+>' -hcat ds sty = Pretty.hcat [d sty | d <- ds] -hsep ds sty = Pretty.hsep [d sty | d <- ds] -vcat ds sty = Pretty.vcat [d sty | d <- ds] -sep ds sty = Pretty.sep [d sty | d <- ds] -cat ds sty = Pretty.cat [d sty | d <- ds] -fsep ds sty = Pretty.fsep [d sty | d <- ds] -fcat ds sty = Pretty.fcat [d sty | d <- ds] +hcat ds = SDoc $ \sty -> Pretty.hcat [runSDoc d sty | d <- ds] +hsep ds = SDoc $ \sty -> Pretty.hsep [runSDoc d sty | d <- ds] +vcat ds = SDoc $ \sty -> Pretty.vcat [runSDoc d sty | d <- ds] +sep ds = SDoc $ \sty -> Pretty.sep [runSDoc d sty | d <- ds] +cat ds = SDoc $ \sty -> Pretty.cat [runSDoc d sty | d <- ds] +fsep ds = SDoc $ \sty -> Pretty.fsep [runSDoc d sty | d <- ds] +fcat ds = SDoc $ \sty -> Pretty.fcat [runSDoc d sty | d <- ds] hang :: SDoc -- ^ The header -> Int -- ^ Amount to indent the hung body -> SDoc -- ^ The hung body, indented and placed below the header -> SDoc -hang d1 n d2 sty = Pretty.hang (d1 sty) n (d2 sty) +hang d1 n d2 = SDoc $ \sty -> Pretty.hang (runSDoc d1 sty) n (runSDoc d2 sty) punctuate :: SDoc -- ^ The punctuation -> [SDoc] -- ^ The list that will have punctuation added between every adjacent pair of elements @@ -490,6 +545,46 @@ ppUnless True _ = empty ppUnless False doc = doc + +-- | A colour\/style for use with 'coloured'. +newtype PprColour = PprColour String + +-- Colours + +colType :: PprColour +colType = PprColour "\27[34m" + +colBold :: PprColour +colBold = PprColour "\27[;1m" + +colCoerc :: PprColour +colCoerc = PprColour "\27[34m" + +colDataCon :: PprColour +colDataCon = PprColour "\27[31m" + +colBinder :: PprColour +colBinder = PprColour "\27[32m" + +colReset :: PprColour +colReset = PprColour "\27[0m" + +-- | Apply the given colour\/style for the argument. +-- +-- Only takes effect if colours are enabled. +coloured :: PprColour -> SDoc -> SDoc +-- TODO: coloured _ sdoc ctxt | coloursDisabled = sdoc ctxt +coloured col@(PprColour c) sdoc = + SDoc $ \ctx@SDC{ sdocLastColour = PprColour lc } -> + let ctx' = ctx{ sdocLastColour = col } in + Pretty.zeroWidthText c Pretty.<> runSDoc sdoc ctx' Pretty.<> Pretty.zeroWidthText lc + +bold :: SDoc -> SDoc +bold = coloured colBold + +keyword :: SDoc -> SDoc +keyword = bold + \end{code} @@ -503,6 +598,17 @@ -- | Class designating that some type has an 'SDoc' representation class Outputable a where ppr :: a -> SDoc + pprPrec :: Rational -> a -> SDoc + + ppr = pprPrec 0 + pprPrec _ = ppr + +class PlatformOutputable a where + pprPlatform :: Platform -> a -> SDoc + pprPlatformPrec :: Platform -> Rational -> a -> SDoc + + pprPlatform platform = pprPlatformPrec platform 0 + pprPlatformPrec platform _ = pprPlatform platform \end{code} \begin{code} @@ -524,12 +630,19 @@ instance Outputable () where ppr _ = text "()" +instance PlatformOutputable () where + pprPlatform _ _ = text "()" instance (Outputable a) => Outputable [a] where ppr xs = brackets (fsep (punctuate comma (map ppr xs))) +instance (PlatformOutputable a) => PlatformOutputable [a] where + pprPlatform platform xs = brackets (fsep (punctuate comma (map (pprPlatform platform) xs))) instance (Outputable a, Outputable b) => Outputable (a, b) where ppr (x,y) = parens (sep [ppr x <> comma, ppr y]) +instance (PlatformOutputable a, PlatformOutputable b) => PlatformOutputable (a, b) where + pprPlatform platform (x,y) + = parens (sep [pprPlatform platform x <> comma, pprPlatform platform y]) instance Outputable a => Outputable (Maybe a) where ppr Nothing = ptext (sLit "Nothing") @@ -563,12 +676,37 @@ ppr d <> comma, ppr e]) +instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e, Outputable f) => + Outputable (a, b, c, d, e, f) where + ppr (a,b,c,d,e,f) = + parens (sep [ppr a <> comma, + ppr b <> comma, + ppr c <> comma, + ppr d <> comma, + ppr e <> comma, + ppr f]) + +instance (Outputable a, Outputable b, Outputable c, Outputable d, Outputable e, Outputable f, Outputable g) => + Outputable (a, b, c, d, e, f, g) where + ppr (a,b,c,d,e,f,g) = + parens (sep [ppr a <> comma, + ppr b <> comma, + ppr c <> comma, + ppr d <> comma, + ppr e <> comma, + ppr f <> comma, + ppr g]) + instance Outputable FastString where ppr fs = ftext fs -- Prints an unadorned string, -- no double quotes or anything -instance (Outputable key, Outputable elt) => Outputable (Map key elt) where +instance (Outputable key, Outputable elt) => Outputable (M.Map key elt) where ppr m = ppr (M.toList m) +instance (PlatformOutputable key, PlatformOutputable elt) => PlatformOutputable (M.Map key elt) where + pprPlatform platform m = pprPlatform platform (M.toList m) +instance (Outputable elt) => Outputable (IM.IntMap elt) where + ppr m = ppr (IM.toList m) \end{code} %************************************************************************ @@ -606,7 +744,7 @@ -- | Special combinator for showing string literals. pprHsString :: FastString -> SDoc -pprHsString fs = text (show (unpackFS fs)) +pprHsString fs = vcat (map text (showMultiLineString (unpackFS fs))) --------------------- -- Put a name in parens if it's an operator @@ -788,24 +926,29 @@ | opt_NoDebugOutput = x | otherwise = pprAndThen trace str doc x +pprDefiniteTrace :: String -> SDoc -> a -> a +-- ^ Same as pprTrace, but show even if -dno-debug-output is on +pprDefiniteTrace str doc x = pprAndThen trace str doc x pprPanicFastInt :: String -> SDoc -> FastInt -- ^ Specialization of pprPanic that can be safely used with 'FastInt' -pprPanicFastInt heading pretty_msg = panicFastInt (show (doc PprDebug)) - where - doc = text heading <+> pretty_msg +pprPanicFastInt heading pretty_msg = + panicFastInt (show (runSDoc doc (initSDocContext PprDebug))) + where + doc = text heading <+> pretty_msg pprAndThen :: (String -> a) -> String -> SDoc -> a -pprAndThen cont heading pretty_msg = cont (show (doc PprDebug)) - where +pprAndThen cont heading pretty_msg = + cont (show (runSDoc doc (initSDocContext PprDebug))) + where doc = sep [text heading, nest 4 pretty_msg] assertPprPanic :: String -> Int -> SDoc -> a -- ^ Panic with an assertation failure, recording the given file and line number. -- Should typically be accessed with the ASSERT family of macros assertPprPanic file line msg - = panic (show (doc PprDebug)) + = panic (show (runSDoc doc (initSDocContext PprDebug))) where doc = sep [hsep[text "ASSERT failed! file", text file, @@ -818,7 +961,7 @@ warnPprTrace _ _file _line _msg x | opt_NoDebugOutput = x warnPprTrace False _file _line _msg x = x warnPprTrace True file line msg x - = trace (show (doc defaultDumpStyle)) x + = trace (show (runSDoc doc (initSDocContext defaultDumpStyle))) x where doc = sep [hsep [text "WARNING: file", text file, text "line", int line], msg] diff -Nru ghc-7.0.3/compiler/utils/Pair.lhs ghc-7.2.1/compiler/utils/Pair.lhs --- ghc-7.0.3/compiler/utils/Pair.lhs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/compiler/utils/Pair.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -0,0 +1,47 @@ + +A simple homogeneous pair type with useful Functor, Applicative, and +Traversable instances. + +\begin{code} +module Pair ( Pair(..), unPair, toPair, swap ) where + +#include "HsVersions.h" + +import Outputable +import Data.Monoid +import Control.Applicative +import Data.Foldable +import Data.Traversable + +data Pair a = Pair { pFst :: a, pSnd :: a } +-- Note that Pair is a *unary* type constructor +-- whereas (,) is binary + +-- The important thing about Pair is that it has a *homogenous* +-- Functor instance, so you can easily apply the same function +-- to both components +instance Functor Pair where + fmap f (Pair x y) = Pair (f x) (f y) + +instance Applicative Pair where + pure x = Pair x x + (Pair f g) <*> (Pair x y) = Pair (f x) (g y) + +instance Foldable Pair where + foldMap f (Pair x y) = f x `mappend` f y + +instance Traversable Pair where + traverse f (Pair x y) = Pair <$> f x <*> f y + +instance Outputable a => Outputable (Pair a) where + ppr (Pair a b) = ppr a <+> char '~' <+> ppr b + +unPair :: Pair a -> (a,a) +unPair (Pair x y) = (x,y) + +toPair :: (a,a) -> Pair a +toPair (x,y) = Pair x y + +swap :: Pair a -> Pair a +swap (Pair x y) = Pair y x +\end{code} \ No newline at end of file diff -Nru ghc-7.0.3/compiler/utils/Panic.lhs ghc-7.2.1/compiler/utils/Panic.lhs --- ghc-7.0.3/compiler/utils/Panic.lhs 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/utils/Panic.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -78,7 +78,7 @@ -- | An error in the user's code, probably. | ProgramError String - deriving Eq + deriving (Typeable, Eq) instance Exception GhcException @@ -87,9 +87,6 @@ showsPrec _ e@(CmdLineError _) = showString ": " . showGhcException e showsPrec _ e = showString progName . showString ": " . showGhcException e -instance Typeable GhcException where - typeOf _ = mkTyConApp ghcExceptionTc [] - -- | The name of this GHC. progName :: String @@ -154,11 +151,6 @@ handleGhcException = ghandle -ghcExceptionTc :: TyCon -ghcExceptionTc = mkTyCon "GhcException" -{-# NOINLINE ghcExceptionTc #-} - - -- | Panics and asserts. panic, sorry, pgmError :: String -> a panic x = throwGhcException (Panic x) diff -Nru ghc-7.0.3/compiler/utils/Platform.hs ghc-7.2.1/compiler/utils/Platform.hs --- ghc-7.0.3/compiler/utils/Platform.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/compiler/utils/Platform.hs 2011-08-07 17:10:05.000000000 +0000 @@ -0,0 +1,126 @@ + +-- | A description of the platform we're compiling for. +-- In the future, this module should be the only one that references +-- the evil #defines for each TARGET_ARCH and TARGET_OS +-- +module Platform ( + Platform(..), + Arch(..), + OS(..), + + defaultTargetPlatform, + target32Bit, + osElfTarget +) + +where + +import Panic + +#include "HsVersions.h" + + +-- | Contains enough information for the native code generator to emit +-- code for this platform. +data Platform + = Platform + { platformArch :: Arch + , platformOS :: OS } + + +-- | Architectures that the native code generator knows about. +-- TODO: It might be nice to extend these constructors with information +-- about what instruction set extensions an architecture might support. +-- +data Arch + = ArchUnknown + | ArchX86 + | ArchX86_64 + | ArchPPC + | ArchPPC_64 + | ArchSPARC + | ArchARM + deriving (Show, Eq) + + +-- | Operating systems that the native code generator knows about. +-- Having OSUnknown should produce a sensible default, but no promises. +data OS + = OSUnknown + | OSLinux + | OSDarwin + | OSSolaris2 + | OSMinGW32 + | OSFreeBSD + | OSOpenBSD + deriving (Show, Eq) + + +target32Bit :: Platform -> Bool +target32Bit p = case platformArch p of + ArchUnknown -> panic "Don't know if ArchUnknown is 32bit" + ArchX86 -> True + ArchX86_64 -> False + ArchPPC -> True + ArchPPC_64 -> False + ArchSPARC -> True + ArchARM -> True + + +-- | This predicates tells us whether the OS supports ELF-like shared libraries. +osElfTarget :: OS -> Bool +osElfTarget OSLinux = True +osElfTarget OSFreeBSD = True +osElfTarget OSOpenBSD = True +osElfTarget OSSolaris2 = True +osElfTarget OSDarwin = False +osElfTarget OSMinGW32 = False +osElfTarget OSUnknown = panic "Don't know if OSUnknown is elf" + + +-- | This is the target platform as far as the #ifdefs are concerned. +-- These are set in includes/ghcplatform.h by the autoconf scripts +defaultTargetPlatform :: Platform +defaultTargetPlatform + = Platform defaultTargetArch defaultTargetOS + + +-- | Move the evil TARGET_ARCH #ifdefs into Haskell land. +defaultTargetArch :: Arch +#if i386_TARGET_ARCH +defaultTargetArch = ArchX86 +#elif x86_64_TARGET_ARCH +defaultTargetArch = ArchX86_64 +#elif powerpc_TARGET_ARCH +defaultTargetArch = ArchPPC +#elif powerpc64_TARGET_ARCH +defaultTargetArch = ArchPPC_64 +#elif sparc_TARGET_ARCH +defaultTargetArch = ArchSPARC +#elif arm_TARGET_ARCH +defaultTargetArch = ArchARM +#else +defaultTargetArch = ArchUnknown +#endif + + +-- | Move the evil TARGET_OS #ifdefs into Haskell land. +defaultTargetOS :: OS +#if linux_TARGET_OS +defaultTargetOS = OSLinux +#elif darwin_TARGET_OS +defaultTargetOS = OSDarwin +#elif solaris2_TARGET_OS +defaultTargetOS = OSSolaris2 +#elif mingw32_TARGET_OS +defaultTargetOS = OSMinGW32 +#elif freebsd_TARGET_OS +defaultTargetOS = OSFreeBSD +#elif kfreebsdgnu_TARGET_OS +defaultTargetOS = OSFreeBSD +#elif openbsd_TARGET_OS +defaultTargetOS = OSOpenBSD +#else +defaultTargetOS = OSUnknown +#endif + diff -Nru ghc-7.0.3/compiler/utils/Pretty.lhs ghc-7.2.1/compiler/utils/Pretty.lhs --- ghc-7.0.3/compiler/utils/Pretty.lhs 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/utils/Pretty.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -152,6 +152,7 @@ \begin{code} +{-# LANGUAGE BangPatterns #-} {-# OPTIONS -fno-warn-unused-imports #-} -- XXX GHC 6.9 seems to be confused by unpackCString# being used only in -- a RULE @@ -162,7 +163,7 @@ empty, isEmpty, nest, - char, text, ftext, ptext, + char, text, ftext, ptext, zeroWidthText, int, integer, float, double, rational, parens, brackets, braces, quotes, doubleQuotes, semi, comma, colon, space, equals, @@ -184,10 +185,9 @@ import FastString import FastTypes import Panic - +import StaticFlags import Numeric (fromRat) import System.IO ---import Foreign.Ptr (castPtr) #if defined(__GLASGOW_HASKELL__) --for a RULES @@ -223,6 +223,10 @@ \begin{code} empty :: Doc isEmpty :: Doc -> Bool +-- | Some text, but without any width. Use for non-printing text +-- such as a HTML or Latex tags +zeroWidthText :: String -> Doc + text :: String -> Doc char :: Char -> Doc @@ -557,8 +561,8 @@ ftext :: FastString -> Doc ftext s = case iUnbox (lengthFS s) of {sl -> textBeside_ (PStr s) sl Empty} ptext :: LitString -> Doc -ptext s_= case iUnbox (lengthLS s) of {sl -> textBeside_ (LStr s sl) sl Empty} - where s = {-castPtr-} s_ +ptext s = case iUnbox (lengthLS s) of {sl -> textBeside_ (LStr s sl) sl Empty} +zeroWidthText s = textBeside_ (Str s) (_ILIT(0)) Empty #if defined(__GLASGOW_HASKELL__) -- RULE that turns (text "abc") into (ptext (A# "abc"#)) to avoid the @@ -998,7 +1002,7 @@ \begin{code} pprCols :: Int -pprCols = 100 -- could make configurable +pprCols = opt_PprCols printDoc :: Mode -> Handle -> Doc -> IO () printDoc LeftMode hdl doc diff -Nru ghc-7.0.3/compiler/utils/Serialized.hs ghc-7.2.1/compiler/utils/Serialized.hs --- ghc-7.0.3/compiler/utils/Serialized.hs 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/utils/Serialized.hs 2011-08-07 17:10:05.000000000 +0000 @@ -82,11 +82,7 @@ serializeConstr (AlgConstr ix) = serializeWord8 1 . serializeInt ix serializeConstr (IntConstr i) = serializeWord8 2 . serializeInteger i serializeConstr (FloatConstr r) = serializeWord8 3 . serializeRational r -#if __GLASGOW_HASKELL__ < 611 -serializeConstr (StringConstr s) = serializeWord8 4 . serializeString s -#else serializeConstr (CharConstr c) = serializeWord8 4 . serializeChar c -#endif deserializeConstr :: [Word8] -> (ConstrRep -> [Word8] -> a) -> a @@ -95,11 +91,7 @@ 1 -> deserializeInt bytes $ \ix -> k (AlgConstr ix) 2 -> deserializeInteger bytes $ \i -> k (IntConstr i) 3 -> deserializeRational bytes $ \r -> k (FloatConstr r) -#if __GLASGOW_HASKELL__ >= 611 4 -> deserializeChar bytes $ \c -> k (CharConstr c) -#else - 4 -> deserializeString bytes $ \s -> k (StringConstr s) -#endif x -> error $ "deserializeConstr: unrecognised serialized constructor type " ++ show x ++ " in context " ++ show bytes @@ -158,13 +150,11 @@ deserializeInteger bytes k = deserializeString bytes (k . read) -#if __GLASGOW_HASKELL__ >= 611 serializeChar :: Char -> [Word8] -> [Word8] serializeChar = serializeString . show deserializeChar :: [Word8] -> (Char -> [Word8] -> a) -> a deserializeChar bytes k = deserializeString bytes (k . read) -#endif serializeString :: String -> [Word8] -> [Word8] diff -Nru ghc-7.0.3/compiler/utils/StringBuffer.lhs ghc-7.2.1/compiler/utils/StringBuffer.lhs --- ghc-7.0.3/compiler/utils/StringBuffer.lhs 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/utils/StringBuffer.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -6,6 +6,7 @@ Buffers for scanning string input stored in external arrays. \begin{code} +{-# LANGUAGE BangPatterns #-} {-# OPTIONS_GHC -O -funbox-strict-fields #-} -- We always optimise this, otherwise performance of a non-optimised -- compiler is severely affected @@ -47,13 +48,17 @@ import FastTypes import FastFunctions -import Foreign import System.IO ( hGetBuf, hFileSize,IOMode(ReadMode), hClose - , Handle, hTell ) + , Handle, hTell, openBinaryFile ) +import System.IO.Unsafe ( unsafePerformIO ) import GHC.Exts -import System.IO ( openBinaryFile ) +#if __GLASGOW_HASKELL__ >= 701 +import Foreign.Safe +#else +import Foreign hiding ( unsafePerformIO ) +#endif -- ----------------------------------------------------------------------------- -- The StringBuffer type @@ -138,8 +143,9 @@ calcLen sb = len sb - cur sb size = sb1_len + sb2_len -stringToStringBuffer :: String -> IO StringBuffer -stringToStringBuffer str = do +stringToStringBuffer :: String -> StringBuffer +stringToStringBuffer str = + unsafePerformIO $ do let size = utf8EncodedLength str buf <- mallocForeignPtrArray (size+3) withForeignPtr buf $ \ptr -> do diff -Nru ghc-7.0.3/compiler/utils/UniqFM.lhs ghc-7.2.1/compiler/utils/UniqFM.lhs --- ghc-7.0.3/compiler/utils/UniqFM.lhs 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/utils/UniqFM.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -36,6 +36,8 @@ addListToUFM,addListToUFM_C, addToUFM_Directly, addListToUFM_Directly, + adjustUFM, + adjustUFM_Directly, delFromUFM, delFromUFM_Directly, delListFromUFM, @@ -45,7 +47,7 @@ intersectUFM, intersectUFM_C, foldUFM, foldUFM_Directly, - mapUFM, + mapUFM, mapUFM_Directly, elemUFM, elemUFM_Directly, filterUFM, filterUFM_Directly, sizeUFM, @@ -53,13 +55,20 @@ lookupUFM, lookupUFM_Directly, lookupWithDefaultUFM, lookupWithDefaultUFM_Directly, eltsUFM, keysUFM, splitUFM, - ufmToList + ufmToList, + joinUFM ) where import Unique ( Uniquable(..), Unique, getKey ) import Outputable +import Compiler.Hoopl hiding (Unique) + +import Data.Function (on) import qualified Data.IntMap as M +import qualified Data.Foldable as Foldable +import Data.Typeable +import Data.Data \end{code} %************************************************************************ @@ -103,6 +112,9 @@ -> UniqFM elt -> [(key,elt)] -> UniqFM elt +adjustUFM :: Uniquable key => (elt -> elt) -> UniqFM elt -> key -> UniqFM elt +adjustUFM_Directly :: (elt -> elt) -> UniqFM elt -> Unique -> UniqFM elt + delFromUFM :: Uniquable key => UniqFM elt -> key -> UniqFM elt delListFromUFM :: Uniquable key => UniqFM elt -> [key] -> UniqFM elt delFromUFM_Directly :: UniqFM elt -> Unique -> UniqFM elt @@ -122,6 +134,7 @@ foldUFM :: (elt -> a -> a) -> a -> UniqFM elt -> a foldUFM_Directly:: (Unique -> elt -> a -> a) -> a -> UniqFM elt -> a mapUFM :: (elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2 +mapUFM_Directly :: (Unique -> elt1 -> elt2) -> UniqFM elt1 -> UniqFM elt2 filterUFM :: (elt -> Bool) -> UniqFM elt -> UniqFM elt filterUFM_Directly :: (Unique -> elt -> Bool) -> UniqFM elt -> UniqFM elt @@ -152,7 +165,14 @@ %************************************************************************ \begin{code} -newtype UniqFM ele = UFM (M.IntMap ele) +newtype UniqFM ele = UFM { unUFM :: M.IntMap ele } + deriving (Typeable,Data) + +instance Eq ele => Eq (UniqFM ele) where + (==) = (==) `on` unUFM + +instance Foldable.Foldable UniqFM where + foldMap f = Foldable.foldMap f . unUFM emptyUFM = UFM M.empty isNullUFM (UFM m) = M.null m @@ -174,6 +194,9 @@ UFM (M.insertWith (\_new old -> exi v old) (getKey $ getUnique k) (new v) m) addListToUFM_C f = foldl (\m (k, v) -> addToUFM_C f m k v) +adjustUFM f (UFM m) k = UFM (M.adjust f (getKey $ getUnique k) m) +adjustUFM_Directly f (UFM m) u = UFM (M.adjust f (getKey u) m) + delFromUFM (UFM m) k = UFM (M.delete (getKey $ getUnique k) m) delListFromUFM = foldl delFromUFM delFromUFM_Directly (UFM m) u = UFM (M.delete (getKey u) m) @@ -183,24 +206,12 @@ plusUFM_C f (UFM x) (UFM y) = UFM (M.unionWith f x y) minusUFM (UFM x) (UFM y) = UFM (M.difference x y) intersectUFM (UFM x) (UFM y) = UFM (M.intersection x y) -#if __GLASGOW_HASKELL__ >= 611 intersectUFM_C f (UFM x) (UFM y) = UFM (M.intersectionWith f x y) -#else --- In GHC 6.10, intersectionWith is (a -> b -> a) instead of (a -> b -> c), --- so we need to jump through some hoops to get the more general type. -intersectUFM_C f (UFM x) (UFM y) = UFM z - where z = let x' = M.map Left x - f' (Left a) b = Right (f a b) - f' (Right _) _ = panic "intersectUFM_C: f': Right" - z' = M.intersectionWith f' x' y - fromRight (Right a) = a - fromRight _ = panic "intersectUFM_C: Left" - in M.map fromRight z' -#endif foldUFM k z (UFM m) = M.fold k z m foldUFM_Directly k z (UFM m) = M.foldWithKey (k . getUnique) z m mapUFM f (UFM m) = UFM (M.map f m) +mapUFM_Directly f (UFM m) = UFM (M.mapWithKey (f . getUnique) m) filterUFM p (UFM m) = UFM (M.filter p m) filterUFM_Directly p (UFM m) = UFM (M.filterWithKey (p . getUnique) m) @@ -218,6 +229,16 @@ eltsUFM (UFM m) = M.elems m ufmToList (UFM m) = map (\(k, v) -> (getUnique k, v)) $ M.toList m +-- Hoopl +joinUFM :: JoinFun v -> JoinFun (UniqFM v) +joinUFM eltJoin l (OldFact old) (NewFact new) = foldUFM_Directly add (NoChange, old) new + where add k new_v (ch, joinmap) = + case lookupUFM_Directly joinmap k of + Nothing -> (SomeChange, addToUFM_Directly joinmap k new_v) + Just old_v -> case eltJoin l (OldFact old_v) (NewFact new_v) of + (SomeChange, v') -> (SomeChange, addToUFM_Directly joinmap k v') + (NoChange, _) -> (ch, joinmap) + \end{code} %************************************************************************ diff -Nru ghc-7.0.3/compiler/utils/Util.lhs ghc-7.2.1/compiler/utils/Util.lhs --- ghc-7.0.3/compiler/utils/Util.lhs 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/utils/Util.lhs 2011-08-07 17:10:05.000000000 +0000 @@ -41,7 +41,7 @@ nTimes, -- * Sorting - sortLe, sortWith, on, + sortLe, sortWith, minWith, on, -- * Comparisons isEqual, eqListBy, @@ -49,7 +49,7 @@ removeSpaces, -- * Edit distance - fuzzyMatch, + fuzzyMatch, fuzzyLookup, -- * Transitive closures transitiveClosure, @@ -66,12 +66,15 @@ -- * Floating point readRational, + -- * read helpers + maybeReadFuzzy, + -- * IO-ish utilities createDirectoryHierarchy, doesDirNameExist, modificationTimeIfExists, - global, consIORef, globalMVar, globalEmptyMVar, + global, consIORef, globalM, -- * Filenames and paths Suffix, @@ -81,31 +84,34 @@ Direction(..), reslash, -- * Utils for defining Data instances - abstractConstr, abstractDataType, mkNoRepType + abstractConstr, abstractDataType, mkNoRepType, + + -- * Utils for printing C code + charToC ) where #include "HsVersions.h" +import Exception import Panic import Data.Data import Data.IORef ( IORef, newIORef, atomicModifyIORef ) import System.IO.Unsafe ( unsafePerformIO ) import Data.List hiding (group) -import Control.Concurrent.MVar ( MVar, newMVar, newEmptyMVar ) #ifdef DEBUG import FastTypes #endif import Control.Monad ( unless ) -import System.IO.Error as IO ( catch, isDoesNotExistError ) +import System.IO.Error as IO ( isDoesNotExistError ) import System.Directory ( doesDirectoryExist, createDirectory, getModificationTime ) import System.FilePath import System.Time ( ClockTime ) -import Data.Char ( isUpper, isAlphaNum, isSpace, ord, isDigit ) +import Data.Char ( isUpper, isAlphaNum, isSpace, chr, ord, isDigit ) import Data.Ratio ( (%) ) import Data.Ord ( comparing ) import Data.Bits @@ -536,6 +542,10 @@ where x `le` y = get_key x < get_key y +minWith :: Ord b => (a -> b) -> [a] -> a +minWith get_key xs = ASSERT( not (null xs) ) + head (sortWith get_key xs) + on :: (a -> a -> c) -> (b -> a) -> b -> b -> c on cmp sel = \x y -> sel x `cmp` sel y @@ -689,40 +699,61 @@ %************************************************************************ \begin{code} --- | Find the "restricted" Damerau-Levenshtein edit distance between two strings. See: . --- Based on the algorithm presented in "A Bit-Vector Algorithm for Computing Levenshtein and Damerau Edit Distances" in PSC'02 (Heikki Hyyro). --- See http://www.cs.uta.fi/~helmu/pubs/psc02.pdf and http://www.cs.uta.fi/~helmu/pubs/PSCerr.html for an explanation +-- | Find the "restricted" Damerau-Levenshtein edit distance between two strings. +-- See: . +-- Based on the algorithm presented in "A Bit-Vector Algorithm for Computing +-- Levenshtein and Damerau Edit Distances" in PSC'02 (Heikki Hyyro). +-- See http://www.cs.uta.fi/~helmu/pubs/psc02.pdf and +-- http://www.cs.uta.fi/~helmu/pubs/PSCerr.html for an explanation restrictedDamerauLevenshteinDistance :: String -> String -> Int -restrictedDamerauLevenshteinDistance str1 str2 = restrictedDamerauLevenshteinDistanceWithLengths m n str1 str2 +restrictedDamerauLevenshteinDistance str1 str2 + = restrictedDamerauLevenshteinDistanceWithLengths m n str1 str2 where m = length str1 n = length str2 -restrictedDamerauLevenshteinDistanceWithLengths :: Int -> Int -> String -> String -> Int +restrictedDamerauLevenshteinDistanceWithLengths + :: Int -> Int -> String -> String -> Int restrictedDamerauLevenshteinDistanceWithLengths m n str1 str2 - | m <= n = if n <= 32 -- n must be larger so this check is sufficient - then restrictedDamerauLevenshteinDistance' (undefined :: Word32) m n str1 str2 - else restrictedDamerauLevenshteinDistance' (undefined :: Integer) m n str1 str2 - | otherwise = if m <= 32 -- m must be larger so this check is sufficient - then restrictedDamerauLevenshteinDistance' (undefined :: Word32) n m str2 str1 - else restrictedDamerauLevenshteinDistance' (undefined :: Integer) n m str2 str1 + | m <= n + = if n <= 32 -- n must be larger so this check is sufficient + then restrictedDamerauLevenshteinDistance' (undefined :: Word32) m n str1 str2 + else restrictedDamerauLevenshteinDistance' (undefined :: Integer) m n str1 str2 + + | otherwise + = if m <= 32 -- m must be larger so this check is sufficient + then restrictedDamerauLevenshteinDistance' (undefined :: Word32) n m str2 str1 + else restrictedDamerauLevenshteinDistance' (undefined :: Integer) n m str2 str1 -restrictedDamerauLevenshteinDistance' :: (Bits bv) => bv -> Int -> Int -> String -> String -> Int +restrictedDamerauLevenshteinDistance' + :: (Bits bv) => bv -> Int -> Int -> String -> String -> Int restrictedDamerauLevenshteinDistance' _bv_dummy m n str1 str2 | [] <- str1 = n - | otherwise = extractAnswer $ foldl' (restrictedDamerauLevenshteinDistanceWorker (matchVectors str1) top_bit_mask vector_mask) (0, 0, m_ones, 0, m) str2 - where m_ones@vector_mask = (2 ^ m) - 1 - top_bit_mask = (1 `shiftL` (m - 1)) `asTypeOf` _bv_dummy - extractAnswer (_, _, _, _, distance) = distance - -restrictedDamerauLevenshteinDistanceWorker :: (Bits bv) => IM.IntMap bv -> bv -> bv -> (bv, bv, bv, bv, Int) -> Char -> (bv, bv, bv, bv, Int) -restrictedDamerauLevenshteinDistanceWorker str1_mvs top_bit_mask vector_mask (pm, d0, vp, vn, distance) char2 - = seq str1_mvs $ seq top_bit_mask $ seq vector_mask $ seq pm' $ seq d0' $ seq vp' $ seq vn' $ seq distance'' $ seq char2 $ (pm', d0', vp', vn', distance'') + | otherwise = extractAnswer $ + foldl' (restrictedDamerauLevenshteinDistanceWorker + (matchVectors str1) top_bit_mask vector_mask) + (0, 0, m_ones, 0, m) str2 + where + m_ones@vector_mask = (2 ^ m) - 1 + top_bit_mask = (1 `shiftL` (m - 1)) `asTypeOf` _bv_dummy + extractAnswer (_, _, _, _, distance) = distance + +restrictedDamerauLevenshteinDistanceWorker + :: (Bits bv) => IM.IntMap bv -> bv -> bv + -> (bv, bv, bv, bv, Int) -> Char -> (bv, bv, bv, bv, Int) +restrictedDamerauLevenshteinDistanceWorker str1_mvs top_bit_mask vector_mask + (pm, d0, vp, vn, distance) char2 + = seq str1_mvs $ seq top_bit_mask $ seq vector_mask $ + seq pm' $ seq d0' $ seq vp' $ seq vn' $ + seq distance'' $ seq char2 $ + (pm', d0', vp', vn', distance'') where pm' = IM.findWithDefault 0 (ord char2) str1_mvs - d0' = ((((sizedComplement vector_mask d0) .&. pm') `shiftL` 1) .&. pm) -- No need to mask the shiftL because of the restricted range of pm + d0' = ((((sizedComplement vector_mask d0) .&. pm') `shiftL` 1) .&. pm) .|. ((((pm' .&. vp) + vp) .&. vector_mask) `xor` vp) .|. pm' .|. vn + -- No need to mask the shiftL because of the restricted range of pm + hp' = vn .|. sizedComplement vector_mask (d0' .|. vp) hn' = d0' .&. vp @@ -745,11 +776,19 @@ in seq ix' $ seq im' $ (ix', im') #ifdef __GLASGOW_HASKELL__ -{-# SPECIALIZE INLINE restrictedDamerauLevenshteinDistance' :: Word32 -> Int -> Int -> String -> String -> Int #-} -{-# SPECIALIZE INLINE restrictedDamerauLevenshteinDistance' :: Integer -> Int -> Int -> String -> String -> Int #-} - -{-# SPECIALIZE restrictedDamerauLevenshteinDistanceWorker :: IM.IntMap Word32 -> Word32 -> Word32 -> (Word32, Word32, Word32, Word32, Int) -> Char -> (Word32, Word32, Word32, Word32, Int) #-} -{-# SPECIALIZE restrictedDamerauLevenshteinDistanceWorker :: IM.IntMap Integer -> Integer -> Integer -> (Integer, Integer, Integer, Integer, Int) -> Char -> (Integer, Integer, Integer, Integer, Int) #-} +{-# SPECIALIZE INLINE restrictedDamerauLevenshteinDistance' + :: Word32 -> Int -> Int -> String -> String -> Int #-} +{-# SPECIALIZE INLINE restrictedDamerauLevenshteinDistance' + :: Integer -> Int -> Int -> String -> String -> Int #-} + +{-# SPECIALIZE restrictedDamerauLevenshteinDistanceWorker + :: IM.IntMap Word32 -> Word32 -> Word32 + -> (Word32, Word32, Word32, Word32, Int) + -> Char -> (Word32, Word32, Word32, Word32, Int) #-} +{-# SPECIALIZE restrictedDamerauLevenshteinDistanceWorker + :: IM.IntMap Integer -> Integer -> Integer + -> (Integer, Integer, Integer, Integer, Int) + -> Char -> (Integer, Integer, Integer, Integer, Int) #-} {-# SPECIALIZE INLINE sizedComplement :: Word32 -> Word32 -> Word32 #-} {-# SPECIALIZE INLINE sizedComplement :: Integer -> Integer -> Integer #-} @@ -758,15 +797,32 @@ {-# SPECIALIZE matchVectors :: String -> IM.IntMap Integer #-} #endif --- | Search for possible matches to the users input in the given list, returning a small number of ranked results fuzzyMatch :: String -> [String] -> [String] -fuzzyMatch user_entered possibilites = map fst $ take mAX_RESULTS $ sortBy (comparing snd) - [ (poss, distance) | poss <- possibilites - , let distance = restrictedDamerauLevenshteinDistance poss user_entered - , distance <= fuzzy_threshold ] - where -- Work out an approriate match threshold (about a quarter of the # of characters the user entered) - fuzzy_threshold = max (round $ fromInteger (genericLength user_entered) / (4 :: Rational)) 1 - mAX_RESULTS = 3 +fuzzyMatch key vals = fuzzyLookup key [(v,v) | v <- vals] + +-- | Search for possible matches to the users input in the given list, +-- returning a small number of ranked results +fuzzyLookup :: String -> [(String,a)] -> [a] +fuzzyLookup user_entered possibilites + = map fst $ take mAX_RESULTS $ sortBy (comparing snd) + [ (poss_val, distance) | (poss_str, poss_val) <- possibilites + , let distance = restrictedDamerauLevenshteinDistance + poss_str user_entered + , distance <= fuzzy_threshold ] + where + -- Work out an approriate match threshold: + -- We report a candidate if its edit distance is <= the threshold, + -- The threshhold is set to about a quarter of the # of characters the user entered + -- Length Threshold + -- 1 0 -- Don't suggest *any* candidates + -- 2 1 -- for single-char identifiers + -- 3 1 + -- 4 1 + -- 5 1 + -- 6 2 + -- + fuzzy_threshold = truncate $ fromIntegral (length user_entered + 2) / (4 :: Rational) + mAX_RESULTS = 3 \end{code} %************************************************************************ @@ -800,11 +856,8 @@ \end{code} \begin{code} -globalMVar :: a -> MVar a -globalMVar a = unsafePerformIO (newMVar a) - -globalEmptyMVar :: MVar a -globalEmptyMVar = unsafePerformIO newEmptyMVar +globalM :: IO a -> IORef a +globalM ma = unsafePerformIO (ma >>= newIORef) \end{code} Module names: @@ -916,6 +969,17 @@ ----------------------------------------------------------------------------- +-- 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 () @@ -939,9 +1003,9 @@ modificationTimeIfExists :: FilePath -> IO (Maybe ClockTime) modificationTimeIfExists f = do (do t <- getModificationTime f; return (Just t)) - `IO.catch` \e -> if isDoesNotExistError e - then return Nothing - else ioError e + `catchIO` \e -> if isDoesNotExistError e + then return Nothing + else ioError e -- split a string at the last character where 'pred' is True, -- returning a pair of strings. The first component holds the string @@ -1019,11 +1083,22 @@ abstractDataType n = mkDataType n [abstractConstr n] \end{code} +%************************************************************************ +%* * +\subsection[Utils-C]{Utils for printing C code} +%* * +%************************************************************************ + \begin{code} --- Old GHC versions come with a base library with this function misspelled. -#if __GLASGOW_HASKELL__ < 612 -mkNoRepType :: String -> DataType -mkNoRepType = mkNorepType -#endif +charToC :: Word8 -> String +charToC w = + case chr (fromIntegral w) of + '\"' -> "\\\"" + '\'' -> "\\\'" + '\\' -> "\\\\" + c | c >= ' ' && c <= '~' -> [c] + | otherwise -> ['\\', + chr (ord '0' + ord c `div` 64), + chr (ord '0' + ord c `div` 8 `mod` 8), + chr (ord '0' + ord c `mod` 8)] \end{code} - diff -Nru ghc-7.0.3/compiler/vectorise/Vectorise/Builtins/Base.hs ghc-7.2.1/compiler/vectorise/Vectorise/Builtins/Base.hs --- ghc-7.0.3/compiler/vectorise/Vectorise/Builtins/Base.hs 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/vectorise/Vectorise/Builtins/Base.hs 2011-08-07 17:10:05.000000000 +0000 @@ -13,7 +13,7 @@ indexBuiltin, -- * Projections - selTy, + selTy, selReplicate, selPick, selTags, @@ -33,7 +33,6 @@ import Type import TyCon import DataCon -import Var import Outputable import Data.Array @@ -61,9 +60,12 @@ , parrayTyCon :: TyCon -- ^ PArray , parrayDataCon :: DataCon -- ^ PArray , pdataTyCon :: TyCon -- ^ PData + , paClass :: Class -- ^ PA , paTyCon :: TyCon -- ^ PA , paDataCon :: DataCon -- ^ PA + , paPRSel :: Var -- ^ PA , preprTyCon :: TyCon -- ^ PRepr + , prClass :: Class -- ^ PR , prTyCon :: TyCon -- ^ PR , prDataCon :: DataCon -- ^ PR , replicatePDVar :: Var -- ^ replicatePD diff -Nru ghc-7.0.3/compiler/vectorise/Vectorise/Builtins/Initialise.hs ghc-7.2.1/compiler/vectorise/Vectorise/Builtins/Initialise.hs --- ghc-7.0.3/compiler/vectorise/Vectorise/Builtins/Initialise.hs 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/vectorise/Vectorise/Builtins/Initialise.hs 2011-08-07 17:10:05.000000000 +0000 @@ -1,14 +1,13 @@ - module Vectorise.Builtins.Initialise ( - -- * Initialisation - initBuiltins, initBuiltinVars, initBuiltinTyCons, initBuiltinDataCons, - initBuiltinPAs, initBuiltinPRs, - initBuiltinBoxedTyCons, initBuiltinScalars, + -- * Initialisation + initBuiltins, initBuiltinVars, initBuiltinTyCons, initBuiltinDataCons, + initBuiltinPAs, initBuiltinPRs, + initBuiltinBoxedTyCons ) where + import Vectorise.Builtins.Base import Vectorise.Builtins.Modules -import Vectorise.Builtins.Prelude import BasicTypes import PrelNames @@ -24,59 +23,93 @@ import Type import Name import Module -import Var import Id import FastString import Outputable import Control.Monad import Data.Array -import Data.List - --- | Create the initial map of builtin types and functions. -initBuiltins - :: PackageId -- ^ package id the builtins are in, eg dph-common - -> DsM Builtins +-- |Create the initial map of builtin types and functions. +-- +initBuiltins :: PackageId -- ^ package id the builtins are in, eg dph-common + -> DsM Builtins initBuiltins pkg = do mapM_ load dph_Orphans + -- From dph-common:Data.Array.Parallel.PArray.PData + -- PData is a type family that maps an element type onto the type + -- we use to hold an array of those elements. + pdataTyCon <- externalTyCon dph_PArray_PData (fsLit "PData") + + -- PR is a type class that holds the primitive operators we can + -- apply to array data. Its functions take arrays in terms of PData types. + prClass <- externalClass dph_PArray_PData (fsLit "PR") + let prTyCon = classTyCon prClass + [prDataCon] = tyConDataCons prTyCon + + + -- From dph-common:Data.Array.Parallel.PArray.PRepr + preprTyCon <- externalTyCon dph_PArray_PRepr (fsLit "PRepr") + paClass <- externalClass dph_PArray_PRepr (fsLit "PA") + let paTyCon = classTyCon paClass + [paDataCon] = tyConDataCons paTyCon + paPRSel = classSCSelId paClass 0 + + replicatePDVar <- externalVar dph_PArray_PRepr (fsLit "replicatePD") + emptyPDVar <- externalVar dph_PArray_PRepr (fsLit "emptyPD") + packByTagPDVar <- externalVar dph_PArray_PRepr (fsLit "packByTagPD") + combines <- mapM (externalVar dph_PArray_PRepr) + [mkFastString ("combine" ++ show i ++ "PD") + | i <- [2..mAX_DPH_COMBINE]] + + let combinePDVars = listArray (2, mAX_DPH_COMBINE) combines + + + -- From dph-common:Data.Array.Parallel.PArray.Scalar + -- Scalar is the class of scalar values. + -- The dictionary contains functions to coerce U.Arrays of scalars + -- to and from the PData representation. + scalarClass <- externalClass dph_PArray_Scalar (fsLit "Scalar") + + -- From dph-common:Data.Array.Parallel.Lifted.PArray - parrayTyCon <- externalTyCon dph_PArray (fsLit "PArray") + -- A PArray (Parallel Array) holds the array length and some array elements + -- represented by the PData type family. + parrayTyCon <- externalTyCon dph_PArray_Base (fsLit "PArray") let [parrayDataCon] = tyConDataCons parrayTyCon - pdataTyCon <- externalTyCon dph_PArray (fsLit "PData") - paTyCon <- externalClassTyCon dph_PArray (fsLit "PA") - let [paDataCon] = tyConDataCons paTyCon - - preprTyCon <- externalTyCon dph_PArray (fsLit "PRepr") - prTyCon <- externalClassTyCon dph_PArray (fsLit "PR") - let [prDataCon] = tyConDataCons prTyCon - - closureTyCon <- externalTyCon dph_Closure (fsLit ":->") - - -- From dph-common:Data.Array.Parallel.Lifted.Repr - voidTyCon <- externalTyCon dph_Repr (fsLit "Void") - wrapTyCon <- externalTyCon dph_Repr (fsLit "Wrap") + -- From dph-common:Data.Array.Parallel.PArray.Types + voidTyCon <- externalTyCon dph_PArray_Types (fsLit "Void") + voidVar <- externalVar dph_PArray_Types (fsLit "void") + fromVoidVar <- externalVar dph_PArray_Types (fsLit "fromVoid") + wrapTyCon <- externalTyCon dph_PArray_Types (fsLit "Wrap") + sum_tcs <- mapM (externalTyCon dph_PArray_Types) (numbered "Sum" 2 mAX_DPH_SUM) + + -- from dph-common:Data.Array.Parallel.PArray.PDataInstances + pvoidVar <- externalVar dph_PArray_PDataInstances (fsLit "pvoid") + punitVar <- externalVar dph_PArray_PDataInstances (fsLit "punit") + + + closureTyCon <- externalTyCon dph_Closure (fsLit ":->") + -- From dph-common:Data.Array.Parallel.Lifted.Unboxed - sel_tys <- mapM (externalType dph_Unboxed) - (numbered "Sel" 2 mAX_DPH_SUM) + sel_tys <- mapM (externalType dph_Unboxed) + (numbered "Sel" 2 mAX_DPH_SUM) - sel_replicates <- mapM (externalFun dph_Unboxed) - (numbered_hash "replicateSel" 2 mAX_DPH_SUM) + sel_replicates <- mapM (externalFun dph_Unboxed) + (numbered_hash "replicateSel" 2 mAX_DPH_SUM) - sel_picks <- mapM (externalFun dph_Unboxed) - (numbered_hash "pickSel" 2 mAX_DPH_SUM) + sel_picks <- mapM (externalFun dph_Unboxed) + (numbered_hash "pickSel" 2 mAX_DPH_SUM) - sel_tags <- mapM (externalFun dph_Unboxed) - (numbered "tagsSel" 2 mAX_DPH_SUM) + sel_tags <- mapM (externalFun dph_Unboxed) + (numbered "tagsSel" 2 mAX_DPH_SUM) - sel_els <- mapM mk_elements - [(i,j) | i <- [2..mAX_DPH_SUM], j <- [0..i-1]] + sel_els <- mapM mk_elements + [(i,j) | i <- [2..mAX_DPH_SUM], j <- [0..i-1]] - sum_tcs <- mapM (externalTyCon dph_Repr) - (numbered "Sum" 2 mAX_DPH_SUM) let selTys = listArray (2, mAX_DPH_SUM) sel_tys selReplicates = listArray (2, mAX_DPH_SUM) sel_replicates @@ -86,48 +119,39 @@ sumTyCons = listArray (2, mAX_DPH_SUM) sum_tcs - voidVar <- externalVar dph_Repr (fsLit "void") - pvoidVar <- externalVar dph_Repr (fsLit "pvoid") - fromVoidVar <- externalVar dph_Repr (fsLit "fromVoid") - punitVar <- externalVar dph_Repr (fsLit "punit") - closureVar <- externalVar dph_Closure (fsLit "closure") - applyVar <- externalVar dph_Closure (fsLit "$:") - liftedClosureVar <- externalVar dph_Closure (fsLit "liftedClosure") - liftedApplyVar <- externalVar dph_Closure (fsLit "liftedApply") - replicatePDVar <- externalVar dph_PArray (fsLit "replicatePD") - emptyPDVar <- externalVar dph_PArray (fsLit "emptyPD") - packByTagPDVar <- externalVar dph_PArray (fsLit "packByTagPD") - - combines <- mapM (externalVar dph_PArray) - [mkFastString ("combine" ++ show i ++ "PD") - | i <- [2..mAX_DPH_COMBINE]] - let combinePDVars = listArray (2, mAX_DPH_COMBINE) combines - scalarClass <- externalClass dph_PArray (fsLit "Scalar") - scalar_map <- externalVar dph_Scalar (fsLit "scalar_map") - scalar_zip2 <- externalVar dph_Scalar (fsLit "scalar_zipWith") - scalar_zips <- mapM (externalVar dph_Scalar) - (numbered "scalar_zipWith" 3 mAX_DPH_SCALAR_ARGS) + closureVar <- externalVar dph_Closure (fsLit "closure") + applyVar <- externalVar dph_Closure (fsLit "$:") + liftedClosureVar <- externalVar dph_Closure (fsLit "liftedClosure") + liftedApplyVar <- externalVar dph_Closure (fsLit "liftedApply") + + scalar_map <- externalVar dph_Scalar (fsLit "scalar_map") + scalar_zip2 <- externalVar dph_Scalar (fsLit "scalar_zipWith") + scalar_zips <- mapM (externalVar dph_Scalar) + (numbered "scalar_zipWith" 3 mAX_DPH_SCALAR_ARGS) - let scalarZips = listArray (1, mAX_DPH_SCALAR_ARGS) + let scalarZips = listArray (1, mAX_DPH_SCALAR_ARGS) (scalar_map : scalar_zip2 : scalar_zips) - closures <- mapM (externalVar dph_Closure) - (numbered "closure" 1 mAX_DPH_SCALAR_ARGS) + closures <- mapM (externalVar dph_Closure) + (numbered "closure" 1 mAX_DPH_SCALAR_ARGS) let closureCtrFuns = listArray (1, mAX_DPH_COMBINE) closures - liftingContext <- liftM (\u -> mkSysLocal (fsLit "lc") u intPrimTy) - newUnique + liftingContext <- liftM (\u -> mkSysLocal (fsLit "lc") u intPrimTy) + newUnique return $ Builtins { dphModules = mods , parrayTyCon = parrayTyCon , parrayDataCon = parrayDataCon , pdataTyCon = pdataTyCon + , paClass = paClass , paTyCon = paTyCon , paDataCon = paDataCon + , paPRSel = paPRSel , preprTyCon = preprTyCon + , prClass = prClass , prTyCon = prTyCon , prDataCon = prDataCon , voidTyCon = voidTyCon @@ -157,13 +181,20 @@ , liftingContext = liftingContext } where - mods@(Modules { - dph_PArray = dph_PArray - , dph_Repr = dph_Repr - , dph_Closure = dph_Closure - , dph_Scalar = dph_Scalar - , dph_Unboxed = dph_Unboxed - }) + -- Extract out all the modules we'll use. + -- These are the modules from the DPH base library that contain + -- the primitive array types and functions that vectorised code uses. + mods@(Modules + { dph_PArray_Base = dph_PArray_Base + , dph_PArray_Scalar = dph_PArray_Scalar + , dph_PArray_PRepr = dph_PArray_PRepr + , dph_PArray_PData = dph_PArray_PData + , dph_PArray_PDataInstances = dph_PArray_PDataInstances + , dph_PArray_Types = dph_PArray_Types + , dph_Closure = dph_Closure + , dph_Scalar = dph_Scalar + , dph_Unboxed = dph_Unboxed + }) = dph_Modules pkg load get_mod = dsLoadModule doc mod @@ -185,33 +216,28 @@ $ mkFastString ("elementsSel" ++ show i ++ "_" ++ show j ++ "#") return ((i,j), Var v) - -- | Get the mapping of names in the Prelude to names in the DPH library. +-- initBuiltinVars :: Builtins -> DsM [(Var, Var)] initBuiltinVars (Builtins { dphModules = mods }) = do - uvars <- zipWithM externalVar umods ufs - vvars <- zipWithM externalVar vmods vfs cvars <- zipWithM externalVar cmods cfs return $ [(v,v) | v <- map dataConWorkId defaultDataConWorkers] ++ zip (map dataConWorkId cons) cvars - ++ zip uvars vvars where - (umods, ufs, vmods, vfs) = unzip4 (preludeVars mods) - (cons, cmods, cfs) = unzip3 (preludeDataCons mods) + (cons, cmods, cfs) = unzip3 (preludeDataCons mods) defaultDataConWorkers :: [DataCon] defaultDataConWorkers = [trueDataCon, falseDataCon, unitDataCon] + preludeDataCons :: Modules -> [(DataCon, Module, FastString)] + preludeDataCons (Modules { dph_Prelude_Tuple = dph_Prelude_Tuple }) + = [mk_tup n dph_Prelude_Tuple (mkFastString $ "tup" ++ show n) | n <- [2..3]] + where + mk_tup n mod name = (tupleCon Boxed n, mod, name) -preludeDataCons :: Modules -> [(DataCon, Module, FastString)] -preludeDataCons (Modules { dph_Prelude_Tuple = dph_Prelude_Tuple }) - = [mk_tup n dph_Prelude_Tuple (mkFastString $ "tup" ++ show n) | n <- [2..3]] - where - mk_tup n mod name = (tupleCon Boxed n, mod, name) - - --- | Get a list of names to `TyCon`s in the mock prelude. +-- |Get a list of names to `TyCon`s in the mock prelude. +-- initBuiltinTyCons :: Builtins -> DsM [(Name, TyCon)] initBuiltinTyCons bi = do @@ -225,89 +251,82 @@ : [(tyConName tc, tc) | tc <- dft_tcs] - where defaultTyCons :: DsM [TyCon] - defaultTyCons - = do word8 <- dsLookupTyCon word8TyConName - return [intTyCon, boolTyCon, doubleTyCon, word8] + where + defaultTyCons :: DsM [TyCon] + defaultTyCons + = do word8 <- dsLookupTyCon word8TyConName + return [intTyCon, boolTyCon, floatTyCon, doubleTyCon, word8] - --- | Get a list of names to `DataCon`s in the mock prelude. +-- |Get a list of names to `DataCon`s in the mock prelude. +-- initBuiltinDataCons :: Builtins -> [(Name, DataCon)] initBuiltinDataCons _ = [(dataConName dc, dc)| dc <- defaultDataCons] - where defaultDataCons :: [DataCon] - defaultDataCons = [trueDataCon, falseDataCon, unitDataCon] - + where + defaultDataCons :: [DataCon] + defaultDataCons = [trueDataCon, falseDataCon, unitDataCon] --- | Get the names of all buildin instance functions for the PA class. +-- |Get the names of all buildin instance functions for the PA class. +-- initBuiltinPAs :: Builtins -> (InstEnv, InstEnv) -> DsM [(Name, Var)] initBuiltinPAs (Builtins { dphModules = mods }) insts - = liftM (initBuiltinDicts insts) (externalClass (dph_PArray mods) (fsLit "PA")) + = liftM (initBuiltinDicts insts) (externalClass (dph_PArray_PRepr mods) (fsLit "PA")) - --- | Get the names of all builtin instance functions for the PR class. +-- |Get the names of all builtin instance functions for the PR class. +-- initBuiltinPRs :: Builtins -> (InstEnv, InstEnv) -> DsM [(Name, Var)] initBuiltinPRs (Builtins { dphModules = mods }) insts - = liftM (initBuiltinDicts insts) (externalClass (dph_PArray mods) (fsLit "PR")) - + = liftM (initBuiltinDicts insts) (externalClass (dph_PArray_PData mods) (fsLit "PR")) --- | Get the names of all DPH instance functions for this class. +-- |Get the names of all DPH instance functions for this class. +-- initBuiltinDicts :: (InstEnv, InstEnv) -> Class -> [(Name, Var)] initBuiltinDicts insts cls = map find $ classInstances insts cls where - find i | [Just tc] <- instanceRoughTcs i = (tc, instanceDFunId i) - | otherwise = pprPanic "Invalid DPH instance" (ppr i) + find i | [Just tc] <- instanceRoughTcs i = (tc, instanceDFunId i) + | otherwise = pprPanic "Invalid DPH instance" (ppr i) - --- | Get a list of boxed `TyCons` in the mock prelude. This is Int only. +-- |Get a list of boxed `TyCons` in the mock prelude. This is Int only. +-- initBuiltinBoxedTyCons :: Builtins -> DsM [(Name, TyCon)] initBuiltinBoxedTyCons = return . builtinBoxedTyCons - where builtinBoxedTyCons :: Builtins -> [(Name, TyCon)] - builtinBoxedTyCons _ - = [(tyConName intPrimTyCon, intTyCon)] - + where + builtinBoxedTyCons :: Builtins -> [(Name, TyCon)] + builtinBoxedTyCons _ + = [(tyConName intPrimTyCon, intTyCon)] --- | Get a list of all scalar functions in the mock prelude. -initBuiltinScalars :: Builtins -> DsM [Var] -initBuiltinScalars bi - = mapM (uncurry externalVar) (preludeScalars $ dphModules bi) +-- Auxilliary look up functions ---------------- --- | Lookup some variable given its name and the module that contains it. +-- Lookup some variable given its name and the module that contains it. +-- externalVar :: Module -> FastString -> DsM Var externalVar mod fs = dsLookupGlobalId =<< lookupOrig mod (mkVarOccFS fs) - --- | Like `externalVar` but wrap the `Var` in a `CoreExpr` +-- Like `externalVar` but wrap the `Var` in a `CoreExpr`. +-- externalFun :: Module -> FastString -> DsM CoreExpr externalFun mod fs = do var <- externalVar mod fs return $ Var var - --- | Lookup some `TyCon` given its name and the module that contains it. +-- Lookup some `TyCon` given its name and the module that contains it. +-- externalTyCon :: Module -> FastString -> DsM TyCon externalTyCon mod fs = dsLookupTyCon =<< lookupOrig mod (mkTcOccFS fs) - --- | Lookup some `Type` given its name and the module that contains it. +-- Lookup some `Type` given its name and the module that contains it. +-- externalType :: Module -> FastString -> DsM Type externalType mod fs = do tycon <- externalTyCon mod fs return $ mkTyConApp tycon [] - --- | Lookup some `Class` given its name and the module that contains it. +-- Lookup some `Class` given its name and the module that contains it. +-- externalClass :: Module -> FastString -> DsM Class externalClass mod fs = dsLookupClass =<< lookupOrig mod (mkClsOccFS fs) - - --- | Like `externalClass`, but get the TyCon of of the class. -externalClassTyCon :: Module -> FastString -> DsM TyCon -externalClassTyCon mod fs = liftM classTyCon (externalClass mod fs) - - diff -Nru ghc-7.0.3/compiler/vectorise/Vectorise/Builtins/Modules.hs ghc-7.2.1/compiler/vectorise/Vectorise/Builtins/Modules.hs --- ghc-7.0.3/compiler/vectorise/Vectorise/Builtins/Modules.hs 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/vectorise/Vectorise/Builtins/Modules.hs 2011-08-07 17:10:05.000000000 +0000 @@ -10,45 +10,51 @@ -- | Ids of the modules that contain our DPH builtins. data Modules - = Modules - { dph_PArray :: Module - , dph_Repr :: Module - , dph_Closure :: Module - , dph_Unboxed :: Module - , dph_Instances :: Module - , dph_Combinators :: Module - , dph_Scalar :: Module - , dph_Prelude_PArr :: Module - , dph_Prelude_Int :: Module - , dph_Prelude_Word8 :: Module - , dph_Prelude_Double :: Module - , dph_Prelude_Bool :: Module - , dph_Prelude_Tuple :: Module - } + = Modules + { dph_PArray_Base :: Module + , dph_PArray_Scalar :: Module + , dph_PArray_ScalarInstances :: Module + , dph_PArray_PRepr :: Module + , dph_PArray_PReprInstances :: Module + , dph_PArray_PData :: Module + , dph_PArray_PDataInstances :: Module + , dph_PArray_Types :: Module + + , dph_Closure :: Module + , dph_Unboxed :: Module + , dph_Scalar :: Module + + , dph_Prelude_Tuple :: Module + } -- | The locations of builtins in the current DPH library. dph_Modules :: PackageId -> Modules dph_Modules pkg - = Modules - { dph_PArray = mk (fsLit "Data.Array.Parallel.Lifted.PArray") - , dph_Repr = mk (fsLit "Data.Array.Parallel.Lifted.Repr") - , dph_Closure = mk (fsLit "Data.Array.Parallel.Lifted.Closure") - , dph_Unboxed = mk (fsLit "Data.Array.Parallel.Lifted.Unboxed") - , dph_Instances = mk (fsLit "Data.Array.Parallel.Lifted.Instances") - , dph_Combinators = mk (fsLit "Data.Array.Parallel.Lifted.Combinators") - , dph_Scalar = mk (fsLit "Data.Array.Parallel.Lifted.Scalar") - - , dph_Prelude_PArr = mk (fsLit "Data.Array.Parallel.Prelude.Base.PArr") - , dph_Prelude_Int = mk (fsLit "Data.Array.Parallel.Prelude.Base.Int") - , dph_Prelude_Word8 = mk (fsLit "Data.Array.Parallel.Prelude.Base.Word8") - , dph_Prelude_Double = mk (fsLit "Data.Array.Parallel.Prelude.Base.Double") - , dph_Prelude_Bool = mk (fsLit "Data.Array.Parallel.Prelude.Base.Bool") - , dph_Prelude_Tuple = mk (fsLit "Data.Array.Parallel.Prelude.Base.Tuple") - } - where mk = mkModule pkg . mkModuleNameFS + = Modules + { dph_PArray_Base = mk (fsLit "Data.Array.Parallel.PArray.Base") + , dph_PArray_Scalar = mk (fsLit "Data.Array.Parallel.PArray.Scalar") + , dph_PArray_ScalarInstances = mk (fsLit "Data.Array.Parallel.PArray.ScalarInstances") + , dph_PArray_PRepr = mk (fsLit "Data.Array.Parallel.PArray.PRepr") + , dph_PArray_PReprInstances = mk (fsLit "Data.Array.Parallel.PArray.PReprInstances") + , dph_PArray_PData = mk (fsLit "Data.Array.Parallel.PArray.PData") + , dph_PArray_PDataInstances = mk (fsLit "Data.Array.Parallel.PArray.PDataInstances") + , dph_PArray_Types = mk (fsLit "Data.Array.Parallel.PArray.Types") + + , dph_Closure = mk (fsLit "Data.Array.Parallel.Lifted.Closure") + , dph_Unboxed = mk (fsLit "Data.Array.Parallel.Lifted.Unboxed") + , dph_Scalar = mk (fsLit "Data.Array.Parallel.Lifted.Scalar") + + , dph_Prelude_Tuple = mk (fsLit "Data.Array.Parallel.Prelude.Tuple") + } + where mk = mkModule pkg . mkModuleNameFS --- | Project out ids of modules that contain orphan instances that we need to load. dph_Orphans :: [Modules -> Module] -dph_Orphans = [dph_Repr, dph_Instances] +dph_Orphans + = [ dph_PArray_Scalar + , dph_PArray_ScalarInstances + , dph_PArray_PReprInstances + , dph_PArray_PDataInstances + , dph_Scalar + ] diff -Nru ghc-7.0.3/compiler/vectorise/Vectorise/Builtins/Prelude.hs ghc-7.2.1/compiler/vectorise/Vectorise/Builtins/Prelude.hs --- ghc-7.0.3/compiler/vectorise/Vectorise/Builtins/Prelude.hs 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/vectorise/Vectorise/Builtins/Prelude.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,236 +0,0 @@ - --- | Mapping of prelude functions to vectorised versions. --- Functions like filterP currently have a working but naive version in GHC.PArr --- During vectorisation we replace these by calls to filterPA, which are --- defined in dph-common Data.Array.Parallel.Lifted.Combinators --- --- As renamer only sees the GHC.PArr functions, if you want to add a new function --- to the vectoriser there has to be a definition for it in GHC.PArr, even though --- it will never be used at runtime. --- -module Vectorise.Builtins.Prelude - ( preludeVars - , preludeScalars) -where -import Vectorise.Builtins.Modules -import PrelNames -import Module -import FastString - - -preludeVars - :: Modules -- ^ Modules containing the DPH backens - -> [( Module, FastString -- Maps the original variable to the one in the DPH - , Module, FastString)] -- packages that it should be rewritten to. - -preludeVars (Modules { dph_Combinators = dph_Combinators - , dph_PArray = dph_PArray - , dph_Prelude_Int = dph_Prelude_Int - , dph_Prelude_Word8 = dph_Prelude_Word8 - , dph_Prelude_Double = dph_Prelude_Double - , dph_Prelude_Bool = dph_Prelude_Bool - , dph_Prelude_PArr = dph_Prelude_PArr - }) - - -- Functions that work on whole PArrays, defined in GHC.PArr - = [ mk gHC_PARR (fsLit "mapP") dph_Combinators (fsLit "mapPA") - , mk gHC_PARR (fsLit "zipWithP") dph_Combinators (fsLit "zipWithPA") - , mk gHC_PARR (fsLit "zipP") dph_Combinators (fsLit "zipPA") - , mk gHC_PARR (fsLit "unzipP") dph_Combinators (fsLit "unzipPA") - , mk gHC_PARR (fsLit "filterP") dph_Combinators (fsLit "filterPA") - , mk gHC_PARR (fsLit "lengthP") dph_Combinators (fsLit "lengthPA") - , mk gHC_PARR (fsLit "replicateP") dph_Combinators (fsLit "replicatePA") - , mk gHC_PARR (fsLit "!:") dph_Combinators (fsLit "indexPA") - , mk gHC_PARR (fsLit "sliceP") dph_Combinators (fsLit "slicePA") - , mk gHC_PARR (fsLit "crossMapP") dph_Combinators (fsLit "crossMapPA") - , mk gHC_PARR (fsLit "singletonP") dph_Combinators (fsLit "singletonPA") - , mk gHC_PARR (fsLit "concatP") dph_Combinators (fsLit "concatPA") - , mk gHC_PARR (fsLit "+:+") dph_Combinators (fsLit "appPA") - , mk gHC_PARR (fsLit "emptyP") dph_PArray (fsLit "emptyPA") - - -- Map scalar functions to versions using closures. - , mk' dph_Prelude_Int "div" "divV" - , mk' dph_Prelude_Int "mod" "modV" - , mk' dph_Prelude_Int "sqrt" "sqrtV" - , mk' dph_Prelude_Int "enumFromToP" "enumFromToPA" - -- , mk' dph_Prelude_Int "upToP" "upToPA" - ] - ++ vars_Ord dph_Prelude_Int - ++ vars_Num dph_Prelude_Int - - ++ vars_Ord dph_Prelude_Word8 - ++ vars_Num dph_Prelude_Word8 - ++ - [ mk' dph_Prelude_Word8 "div" "divV" - , mk' dph_Prelude_Word8 "mod" "modV" - , mk' dph_Prelude_Word8 "fromInt" "fromIntV" - , mk' dph_Prelude_Word8 "toInt" "toIntV" - ] - - ++ vars_Ord dph_Prelude_Double - ++ vars_Num dph_Prelude_Double - ++ vars_Fractional dph_Prelude_Double - ++ vars_Floating dph_Prelude_Double - ++ vars_RealFrac dph_Prelude_Double - ++ - [ mk dph_Prelude_Bool (fsLit "andP") dph_Prelude_Bool (fsLit "andPA") - , mk dph_Prelude_Bool (fsLit "orP") dph_Prelude_Bool (fsLit "orPA") - - , mk gHC_CLASSES (fsLit "not") dph_Prelude_Bool (fsLit "notV") - , mk gHC_CLASSES (fsLit "&&") dph_Prelude_Bool (fsLit "andV") - , mk gHC_CLASSES (fsLit "||") dph_Prelude_Bool (fsLit "orV") - - -- FIXME: temporary - , mk dph_Prelude_PArr (fsLit "fromPArrayP") dph_Prelude_PArr (fsLit "fromPArrayPA") - , mk dph_Prelude_PArr (fsLit "toPArrayP") dph_Prelude_PArr (fsLit "toPArrayPA") - , mk dph_Prelude_PArr (fsLit "fromNestedPArrayP") dph_Prelude_PArr (fsLit "fromNestedPArrayPA") - , mk dph_Prelude_PArr (fsLit "combineP") dph_Combinators (fsLit "combine2PA") - , mk dph_Prelude_PArr (fsLit "updateP") dph_Combinators (fsLit "updatePA") - , mk dph_Prelude_PArr (fsLit "bpermuteP") dph_Combinators (fsLit "bpermutePA") - , mk dph_Prelude_PArr (fsLit "indexedP") dph_Combinators (fsLit "indexedPA") - ] - where - mk = (,,,) - mk' mod v v' = mk mod (fsLit v) mod (fsLit v') - - vars_Ord mod - = [ mk' mod "==" "eqV" - , mk' mod "/=" "neqV" - , mk' mod "<=" "leV" - , mk' mod "<" "ltV" - , mk' mod ">=" "geV" - , mk' mod ">" "gtV" - , mk' mod "min" "minV" - , mk' mod "max" "maxV" - , mk' mod "minimumP" "minimumPA" - , mk' mod "maximumP" "maximumPA" - , mk' mod "minIndexP" "minIndexPA" - , mk' mod "maxIndexP" "maxIndexPA" - ] - - vars_Num mod - = [ mk' mod "+" "plusV" - , mk' mod "-" "minusV" - , mk' mod "*" "multV" - , mk' mod "negate" "negateV" - , mk' mod "abs" "absV" - , mk' mod "sumP" "sumPA" - , mk' mod "productP" "productPA" - ] - - vars_Fractional mod - = [ mk' mod "/" "divideV" - , mk' mod "recip" "recipV" - ] - - vars_Floating mod - = [ mk' mod "pi" "pi" - , mk' mod "exp" "expV" - , mk' mod "sqrt" "sqrtV" - , mk' mod "log" "logV" - , mk' mod "sin" "sinV" - , mk' mod "tan" "tanV" - , mk' mod "cos" "cosV" - , mk' mod "asin" "asinV" - , mk' mod "atan" "atanV" - , mk' mod "acos" "acosV" - , mk' mod "sinh" "sinhV" - , mk' mod "tanh" "tanhV" - , mk' mod "cosh" "coshV" - , mk' mod "asinh" "asinhV" - , mk' mod "atanh" "atanhV" - , mk' mod "acosh" "acoshV" - , mk' mod "**" "powV" - , mk' mod "logBase" "logBaseV" - ] - - vars_RealFrac mod - = [ mk' mod "fromInt" "fromIntV" - , mk' mod "truncate" "truncateV" - , mk' mod "round" "roundV" - , mk' mod "ceiling" "ceilingV" - , mk' mod "floor" "floorV" - ] - - -preludeScalars :: Modules -> [(Module, FastString)] -preludeScalars (Modules { dph_Prelude_Int = dph_Prelude_Int - , dph_Prelude_Word8 = dph_Prelude_Word8 - , dph_Prelude_Double = dph_Prelude_Double - }) - = [ mk dph_Prelude_Int "div" - , mk dph_Prelude_Int "mod" - , mk dph_Prelude_Int "sqrt" - ] - ++ scalars_Ord dph_Prelude_Int - ++ scalars_Num dph_Prelude_Int - - ++ scalars_Ord dph_Prelude_Word8 - ++ scalars_Num dph_Prelude_Word8 - ++ - [ mk dph_Prelude_Word8 "div" - , mk dph_Prelude_Word8 "mod" - , mk dph_Prelude_Word8 "fromInt" - , mk dph_Prelude_Word8 "toInt" - ] - - ++ scalars_Ord dph_Prelude_Double - ++ scalars_Num dph_Prelude_Double - ++ scalars_Fractional dph_Prelude_Double - ++ scalars_Floating dph_Prelude_Double - ++ scalars_RealFrac dph_Prelude_Double - where - mk mod s = (mod, fsLit s) - - scalars_Ord mod - = [ mk mod "==" - , mk mod "/=" - , mk mod "<=" - , mk mod "<" - , mk mod ">=" - , mk mod ">" - , mk mod "min" - , mk mod "max" - ] - - scalars_Num mod - = [ mk mod "+" - , mk mod "-" - , mk mod "*" - , mk mod "negate" - , mk mod "abs" - ] - - scalars_Fractional mod - = [ mk mod "/" - , mk mod "recip" - ] - - scalars_Floating mod - = [ mk mod "pi" - , mk mod "exp" - , mk mod "sqrt" - , mk mod "log" - , mk mod "sin" - , mk mod "tan" - , mk mod "cos" - , mk mod "asin" - , mk mod "atan" - , mk mod "acos" - , mk mod "sinh" - , mk mod "tanh" - , mk mod "cosh" - , mk mod "asinh" - , mk mod "atanh" - , mk mod "acosh" - , mk mod "**" - , mk mod "logBase" - ] - - scalars_RealFrac mod - = [ mk mod "fromInt" - , mk mod "truncate" - , mk mod "round" - , mk mod "ceiling" - , mk mod "floor" - ] diff -Nru ghc-7.0.3/compiler/vectorise/Vectorise/Builtins.hs ghc-7.2.1/compiler/vectorise/Vectorise/Builtins.hs --- ghc-7.0.3/compiler/vectorise/Vectorise/Builtins.hs 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/vectorise/Vectorise/Builtins.hs 2011-08-07 17:10:05.000000000 +0000 @@ -1,6 +1,6 @@ -- | Builtin types and functions used by the vectoriser. --- The source program uses functions from GHC.PArr, which the vectoriser rewrites +-- The source program uses functions from Data.Array.Parallel, which the vectoriser rewrites -- to use equivalent vectorised versions in the DPH backend packages. -- -- The `Builtins` structure holds the name of all the things in the DPH packages @@ -8,32 +8,33 @@ -- civilized panic message if the specified thing cannot be found. -- module Vectorise.Builtins ( - -- * Builtins - Builtins(..), - indexBuiltin, - - -- * Wrapped selectors - selTy, - selReplicate, - selPick, - selTags, - selElements, - sumTyCon, - prodTyCon, - prodDataCon, - combinePDVar, - scalarZip, - closureCtrFun, - - -- * Initialisation - initBuiltins, initBuiltinVars, initBuiltinTyCons, initBuiltinDataCons, - initBuiltinPAs, initBuiltinPRs, - initBuiltinBoxedTyCons, initBuiltinScalars, - - -- * Lookup - primMethod, - primPArray + -- * Builtins + Builtins(..), + indexBuiltin, + + -- * Wrapped selectors + selTy, + selReplicate, + selPick, + selTags, + selElements, + sumTyCon, + prodTyCon, + prodDataCon, + combinePDVar, + scalarZip, + closureCtrFun, + + -- * Initialisation + initBuiltins, initBuiltinVars, initBuiltinTyCons, initBuiltinDataCons, + initBuiltinPAs, initBuiltinPRs, + initBuiltinBoxedTyCons, + + -- * Lookup + primMethod, + primPArray ) where + import Vectorise.Builtins.Base import Vectorise.Builtins.Modules import Vectorise.Builtins.Initialise @@ -48,7 +49,8 @@ import Control.Monad --- | Lookup a method function given its name and instance type. +-- |Lookup a method function given its name and instance type. +-- primMethod :: TyCon -> String -> Builtins -> DsM (Maybe Var) primMethod tycon method (Builtins { dphModules = mods }) | Just suffix <- lookupNameEnv prim_ty_cons (tyConName tycon) @@ -58,7 +60,8 @@ | otherwise = return Nothing --- | Lookup the representation type we use for PArrays that contain a given element type. +-- |Lookup the representation type we use for PArrays that contain a given element type. +-- primPArray :: TyCon -> Builtins -> DsM (Maybe TyCon) primPArray tycon (Builtins { dphModules = mods }) | Just suffix <- lookupNameEnv prim_ty_cons (tyConName tycon) diff -Nru ghc-7.0.3/compiler/vectorise/Vectorise/Env.hs ghc-7.2.1/compiler/vectorise/Vectorise/Env.hs --- ghc-7.0.3/compiler/vectorise/Vectorise/Env.hs 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/vectorise/Vectorise/Env.hs 2011-08-07 17:10:05.000000000 +0000 @@ -1,33 +1,36 @@ module Vectorise.Env ( - Scope(..), + Scope(..), - -- * Local Environments - LocalEnv(..), - emptyLocalEnv, - - -- * Global Environments - GlobalEnv(..), - initGlobalEnv, - extendImportedVarsEnv, - extendScalars, - setFamInstEnv, - extendTyConsEnv, - extendDataConsEnv, - extendPAFunsEnv, - setPRFunsEnv, - setBoxedTyConsEnv, - updVectInfo + -- * Local Environments + LocalEnv(..), + emptyLocalEnv, + + -- * Global Environments + GlobalEnv(..), + initGlobalEnv, + extendImportedVarsEnv, + setFamEnv, + extendFamEnv, + extendTyConsEnv, + extendDataConsEnv, + extendPAFunsEnv, + setPRFunsEnv, + setBoxedTyConsEnv, + modVectInfo ) where + import HscTypes import InstEnv import FamInstEnv import CoreSyn +import Type import TyCon import DataCon import VarEnv import VarSet import Var +import NameSet import Name import NameEnv import FastString @@ -35,25 +38,25 @@ -- | Indicates what scope something (a variable) is in. data Scope a b - = Global a - | Local b + = Global a + | Local b -- LocalEnv ------------------------------------------------------------------- -- | The local environment. data LocalEnv - = LocalEnv { + = LocalEnv { -- Mapping from local variables to their vectorised and lifted versions. - local_vars :: VarEnv (Var, Var) + local_vars :: VarEnv (Var, Var) -- In-scope type variables. - , local_tyvars :: [TyVar] + , local_tyvars :: [TyVar] -- Mapping from tyvars to their PA dictionaries. - , local_tyvar_pa :: VarEnv CoreExpr + , local_tyvar_pa :: VarEnv CoreExpr -- Local binding name. - , local_bind_name :: FastString + , local_bind_name :: FastString } @@ -68,129 +71,158 @@ -- GlobalEnv ------------------------------------------------------------------ --- | The global environment. --- These are things the exist at top-level. -data GlobalEnv - = GlobalEnv { - -- | Mapping from global variables to their vectorised versions. - global_vars :: VarEnv Var - - -- | Purely scalar variables. Code which mentions only these - -- variables doesn't have to be lifted. - , global_scalars :: VarSet - - -- | Exported variables which have a vectorised version. - , global_exported_vars :: VarEnv (Var, Var) - - -- | Mapping from TyCons to their vectorised versions. - -- TyCons which do not have to be vectorised are mapped to themselves. - , global_tycons :: NameEnv TyCon - - -- | Mapping from DataCons to their vectorised versions. - , global_datacons :: NameEnv DataCon - -- | Mapping from TyCons to their PA dfuns. - , global_pa_funs :: NameEnv Var - - -- | Mapping from TyCons to their PR dfuns. - , global_pr_funs :: NameEnv Var - - -- | Mapping from unboxed TyCons to their boxed versions. - , global_boxed_tycons :: NameEnv TyCon +-- |The global environment: entities that exist at top-level. +-- +data GlobalEnv + = GlobalEnv + { global_vars :: VarEnv Var + -- ^Mapping from global variables to their vectorised versions — aka the /vectorisation + -- map/. + + , global_vect_decls :: VarEnv (Type, CoreExpr) + -- ^Mapping from global variables that have a vectorisation declaration to the right-hand + -- side of that declaration and its type. This mapping only applies to non-scalar + -- vectorisation declarations. All variables with a scalar vectorisation declaration are + -- mentioned in 'global_scalars_vars'. + + , global_scalar_vars :: VarSet + -- ^Purely scalar variables. Code which mentions only these variables doesn't have to be + -- lifted. This includes variables from the current module that have a scalar + -- vectorisation declaration and those that the vectoriser determines to be scalar. + + , global_scalar_tycons :: NameSet + -- ^Type constructors whose values can only contain scalar data. Scalar code may only + -- operate on such data. + + , global_novect_vars :: VarSet + -- ^Variables that are not vectorised. (They may be referenced in the right-hand sides + -- of vectorisation declarations, though.) + + , global_exported_vars :: VarEnv (Var, Var) + -- ^Exported variables which have a vectorised version. + + , global_tycons :: NameEnv TyCon + -- ^Mapping from TyCons to their vectorised versions. + -- TyCons which do not have to be vectorised are mapped to themselves. + + , global_datacons :: NameEnv DataCon + -- ^Mapping from DataCons to their vectorised versions. + + , global_pa_funs :: NameEnv Var + -- ^Mapping from TyCons to their PA dfuns. + + , global_pr_funs :: NameEnv Var + -- ^Mapping from TyCons to their PR dfuns. + + , global_boxed_tycons :: NameEnv TyCon + -- ^Mapping from unboxed TyCons to their boxed versions. - -- | External package inst-env & home-package inst-env for class instances. - , global_inst_env :: (InstEnv, InstEnv) + , global_inst_env :: (InstEnv, InstEnv) + -- ^External package inst-env & home-package inst-env for class instances. - -- | External package inst-env & home-package inst-env for family instances. - , global_fam_inst_env :: FamInstEnvs + , global_fam_inst_env :: FamInstEnvs + -- ^External package inst-env & home-package inst-env for family instances. - -- | Hoisted bindings. - , global_bindings :: [(Var, CoreExpr)] + , global_bindings :: [(Var, CoreExpr)] + -- ^Hoisted bindings. } - --- | Create an initial global environment -initGlobalEnv :: VectInfo -> (InstEnv, InstEnv) -> FamInstEnvs -> GlobalEnv -initGlobalEnv info instEnvs famInstEnvs - = GlobalEnv - { global_vars = mapVarEnv snd $ vectInfoVar info - , global_scalars = emptyVarSet - , global_exported_vars = emptyVarEnv - , global_tycons = mapNameEnv snd $ vectInfoTyCon info - , global_datacons = mapNameEnv snd $ vectInfoDataCon info - , global_pa_funs = mapNameEnv snd $ vectInfoPADFun info - , global_pr_funs = emptyNameEnv - , global_boxed_tycons = emptyNameEnv - , global_inst_env = instEnvs - , global_fam_inst_env = famInstEnvs - , global_bindings = [] - } - +-- |Create an initial global environment. +-- +initGlobalEnv :: VectInfo -> [CoreVect] -> (InstEnv, InstEnv) -> FamInstEnvs -> GlobalEnv +initGlobalEnv info vectDecls instEnvs famInstEnvs + = GlobalEnv + { global_vars = mapVarEnv snd $ vectInfoVar info + , global_vect_decls = mkVarEnv vects + , global_scalar_vars = vectInfoScalarVars info `extendVarSetList` scalars + , global_scalar_tycons = vectInfoScalarTyCons info + , global_novect_vars = mkVarSet novects + , global_exported_vars = emptyVarEnv + , global_tycons = mapNameEnv snd $ vectInfoTyCon info + , global_datacons = mapNameEnv snd $ vectInfoDataCon info + , global_pa_funs = mapNameEnv snd $ vectInfoPADFun info + , global_pr_funs = emptyNameEnv + , global_boxed_tycons = emptyNameEnv + , global_inst_env = instEnvs + , global_fam_inst_env = famInstEnvs + , global_bindings = [] + } + where + vects = [(var, (varType var, exp)) | Vect var (Just exp) <- vectDecls] + scalars = [var | Vect var Nothing <- vectDecls] + novects = [var | NoVect var <- vectDecls] -- Operators on Global Environments ------------------------------------------- --- | Extend the list of global variables in an environment. + +-- |Extend the list of global variables in an environment. +-- extendImportedVarsEnv :: [(Var, Var)] -> GlobalEnv -> GlobalEnv extendImportedVarsEnv ps genv - = genv { global_vars = extendVarEnvList (global_vars genv) ps } - + = genv { global_vars = extendVarEnvList (global_vars genv) ps } --- | Extend the set of scalar variables in an environment. -extendScalars :: [Var] -> GlobalEnv -> GlobalEnv -extendScalars vs genv - = genv { global_scalars = extendVarSetList (global_scalars genv) vs } - - --- | Set the list of type family instances in an environment. -setFamInstEnv :: FamInstEnv -> GlobalEnv -> GlobalEnv -setFamInstEnv l_fam_inst genv +-- |Set the list of type family instances in an environment. +-- +setFamEnv :: FamInstEnv -> GlobalEnv -> GlobalEnv +setFamEnv l_fam_inst genv = genv { global_fam_inst_env = (g_fam_inst, l_fam_inst) } where (g_fam_inst, _) = global_fam_inst_env genv +-- |Extend the list of type family instances. +-- +extendFamEnv :: [FamInst] -> GlobalEnv -> GlobalEnv +extendFamEnv new genv + = genv { global_fam_inst_env = (g_fam_inst, extendFamInstEnvList l_fam_inst new) } + where (g_fam_inst, l_fam_inst) = global_fam_inst_env genv --- | Extend the list of type constructors in an environment. +-- |Extend the list of type constructors in an environment. +-- extendTyConsEnv :: [(Name, TyCon)] -> GlobalEnv -> GlobalEnv extendTyConsEnv ps genv = genv { global_tycons = extendNameEnvList (global_tycons genv) ps } - --- | Extend the list of data constructors in an environment. +-- |Extend the list of data constructors in an environment. +-- extendDataConsEnv :: [(Name, DataCon)] -> GlobalEnv -> GlobalEnv extendDataConsEnv ps genv = genv { global_datacons = extendNameEnvList (global_datacons genv) ps } - --- | Extend the list of PA functions in an environment. +-- |Extend the list of PA functions in an environment. +-- extendPAFunsEnv :: [(Name, Var)] -> GlobalEnv -> GlobalEnv extendPAFunsEnv ps genv = genv { global_pa_funs = extendNameEnvList (global_pa_funs genv) ps } - --- | Set the list of PR functions in an environment. +-- |Set the list of PR functions in an environment. +-- setPRFunsEnv :: [(Name, Var)] -> GlobalEnv -> GlobalEnv setPRFunsEnv ps genv = genv { global_pr_funs = mkNameEnv ps } - --- | Set the list of boxed type constructor in an environment. +-- |Set the list of boxed type constructor in an environment. +-- setBoxedTyConsEnv :: [(Name, TyCon)] -> GlobalEnv -> GlobalEnv setBoxedTyConsEnv ps genv = genv { global_boxed_tycons = mkNameEnv ps } - --- | TODO: What is this for? -updVectInfo :: GlobalEnv -> TypeEnv -> VectInfo -> VectInfo -updVectInfo env tyenv info +-- |Compute vectorisation information that goes into 'ModGuts' (and is stored in interface files). +-- The incoming 'vectInfo' is that from the 'HscEnv' and 'EPS'. The outgoing one contains only the +-- definitions for the currently compiled module. +-- +modVectInfo :: GlobalEnv -> TypeEnv -> VectInfo -> VectInfo +modVectInfo env tyenv info = info - { vectInfoVar = global_exported_vars env - , vectInfoTyCon = mk_env typeEnvTyCons global_tycons - , vectInfoDataCon = mk_env typeEnvDataCons global_datacons - , vectInfoPADFun = mk_env typeEnvTyCons global_pa_funs + { vectInfoVar = global_exported_vars env + , vectInfoTyCon = mk_env typeEnvTyCons global_tycons + , vectInfoDataCon = mk_env typeEnvDataCons global_datacons + , vectInfoPADFun = mk_env typeEnvTyCons global_pa_funs + , vectInfoScalarVars = global_scalar_vars env `minusVarSet` vectInfoScalarVars info + , vectInfoScalarTyCons = global_scalar_tycons env `minusNameSet` vectInfoScalarTyCons info } where mk_env from_tyenv from_env - = mkNameEnv [(name, (from,to)) - | from <- from_tyenv tyenv - , let name = getName from - , Just to <- [lookupNameEnv (from_env env) name]] - + = mkNameEnv [(name, (from,to)) + | from <- from_tyenv tyenv + , let name = getName from + , Just to <- [lookupNameEnv (from_env env) name]] diff -Nru ghc-7.0.3/compiler/vectorise/Vectorise/Exp.hs ghc-7.2.1/compiler/vectorise/Vectorise/Exp.hs --- ghc-7.0.3/compiler/vectorise/Vectorise/Exp.hs 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/vectorise/Vectorise/Exp.hs 2011-08-07 17:10:05.000000000 +0000 @@ -1,15 +1,23 @@ -- | Vectorisation of expressions. -module Vectorise.Exp - (vectPolyExpr) -where -import Vectorise.Utils +module Vectorise.Exp ( + + -- Vectorise a polymorphic expression + vectPolyExpr, + + -- Vectorise a scalar expression of functional type + vectScalarFun +) where + +#include "HsVersions.h" + import Vectorise.Type.Type import Vectorise.Var import Vectorise.Vect import Vectorise.Env import Vectorise.Monad import Vectorise.Builtins +import Vectorise.Utils import CoreSyn import CoreUtils @@ -22,7 +30,7 @@ import VarEnv import VarSet import Id -import BasicTypes( isLoopBreaker ) +import BasicTypes( isStrongLoopBreaker ) import Literal import TysWiredIn import TysPrim @@ -33,29 +41,29 @@ -- | Vectorise a polymorphic expression. -vectPolyExpr - :: Bool -- ^ When vectorising the RHS of a binding, whether that - -- binding is a loop breaker. - -> CoreExprWithFVs - -> VM (Inline, VExpr) - -vectPolyExpr loop_breaker (_, AnnNote note expr) - = do (inline, expr') <- vectPolyExpr loop_breaker expr - return (inline, vNote note expr') - -vectPolyExpr loop_breaker expr +-- +vectPolyExpr :: Bool -- ^ When vectorising the RHS of a binding, whether that + -- binding is a loop breaker. + -> [Var] + -> CoreExprWithFVs + -> VM (Inline, Bool, VExpr) +vectPolyExpr loop_breaker recFns (_, AnnNote note expr) + = do (inline, isScalarFn, expr') <- vectPolyExpr loop_breaker recFns expr + return (inline, isScalarFn, vNote note expr') +vectPolyExpr loop_breaker recFns expr = do arity <- polyArity tvs polyAbstract tvs $ \args -> do - (inline, mono') <- vectFnExpr False loop_breaker mono - return (addInlineArity inline arity, + (inline, isScalarFn, mono') <- vectFnExpr False loop_breaker recFns mono + return (addInlineArity inline arity, isScalarFn, mapVect (mkLams $ tvs ++ args) mono') where (tvs, mono) = collectAnnTypeBinders expr --- | Vectorise an expression. +-- |Vectorise an expression. +-- vectExpr :: CoreExprWithFVs -> VM VExpr vectExpr (_, AnnType ty) = liftM vType (vectType ty) @@ -69,6 +77,17 @@ vectExpr (_, AnnNote note expr) = liftM (vNote note) (vectExpr expr) +-- SPECIAL CASE: Vectorise/lift 'patError @ ty err' by only vectorising/lifting the type 'ty'; +-- its only purpose is to abort the program, but we need to adjust the type to keep CoreLint +-- happy. +vectExpr (_, AnnApp (_, AnnApp (_, AnnVar v) (_, AnnType ty)) err) + | v == pAT_ERROR_ID + = do { (vty, lty) <- vectAndLiftType ty + ; return (mkCoreApps (Var v) [Type vty, err'], mkCoreApps (Var v) [Type lty, err']) + } + where + err' = deAnnotate err + vectExpr e@(_, AnnApp _ arg) | isAnnTypeArg arg = vectTyAppExpr fn tys @@ -111,12 +130,13 @@ | Just (tycon, ty_args) <- splitTyConApp_maybe scrut_ty , isAlgTyCon tycon = vectAlgCase tycon ty_args scrut bndr ty alts + | otherwise = cantVectorise "Can't vectorise expression" (ppr scrut_ty) where scrut_ty = exprType (deAnnotate scrut) vectExpr (_, AnnLet (AnnNonRec bndr rhs) body) = do - vrhs <- localV . inBind bndr . liftM snd $ vectPolyExpr False rhs + vrhs <- localV . inBind bndr . liftM (\(_,_,z)->z) $ vectPolyExpr False [] rhs (vbndr, vbody) <- vectBndrIn bndr (vectExpr body) return $ vLet (vNonRec vbndr vrhs) vbody @@ -132,11 +152,11 @@ vect_rhs bndr rhs = localV . inBind bndr - . liftM snd - $ vectPolyExpr (isLoopBreaker $ idOccInfo bndr) rhs + . liftM (\(_,_,z)->z) + $ vectPolyExpr (isStrongLoopBreaker $ idOccInfo bndr) [] rhs vectExpr e@(_, AnnLam bndr _) - | isId bndr = liftM snd $ vectFnExpr True False e + | isId bndr = liftM (\(_,_,z) ->z) $ vectFnExpr True False [] e {- onlyIfV (isEmptyVarSet fvs) (vectScalarLam bs $ deAnnotate body) `orElseV` vectLam True fvs bs body @@ -144,87 +164,146 @@ (bs,body) = collectAnnValBinders e -} -vectExpr e = cantVectorise "Can't vectorise expression" (ppr $ deAnnotate e) - +vectExpr e = cantVectorise "Can't vectorise expression (vectExpr)" (ppr $ deAnnotate e) -- | Vectorise an expression with an outer lambda abstraction. -vectFnExpr - :: Bool -- ^ When the RHS of a binding, whether that binding should be inlined. - -> Bool -- ^ Whether the binding is a loop breaker. - -> CoreExprWithFVs -- ^ Expression to vectorise. Must have an outer `AnnLam`. - -> VM (Inline, VExpr) - -vectFnExpr inline loop_breaker e@(fvs, AnnLam bndr _) - | isId bndr = onlyIfV (isEmptyVarSet fvs) - (mark DontInline . vectScalarLam bs $ deAnnotate body) - `orElseV` mark inlineMe (vectLam inline loop_breaker fvs bs body) - where - (bs,body) = collectAnnValBinders e - -vectFnExpr _ _ e = mark DontInline $ vectExpr e - -mark :: Inline -> VM a -> VM (Inline, a) -mark b p = do { x <- p; return (b,x) } - - --- | Vectorise a function where are the args have scalar type, --- that is Int, Float, Double etc. -vectScalarLam - :: [Var] -- ^ Bound variables of function. - -> CoreExpr -- ^ Function body. - -> VM VExpr - -vectScalarLam args body - = do scalars <- globalScalars - onlyIfV (all is_scalar_ty arg_tys - && is_scalar_ty res_ty - && is_scalar (extendVarSetList scalars args) body - && uses scalars body) - $ do - fn_var <- hoistExpr (fsLit "fn") (mkLams args body) DontInline - zipf <- zipScalars arg_tys res_ty - clo <- scalarClosure arg_tys res_ty (Var fn_var) - (zipf `App` Var fn_var) - clo_var <- hoistExpr (fsLit "clo") clo DontInline - lclo <- liftPD (Var clo_var) - return (Var clo_var, lclo) +-- +vectFnExpr :: Bool -- ^ If we process the RHS of a binding, whether that binding should + -- be inlined + -> Bool -- ^ Whether the binding is a loop breaker + -> [Var] -- ^ Names of function in same recursive binding group + -> CoreExprWithFVs -- ^ Expression to vectorise; must have an outer `AnnLam` + -> VM (Inline, Bool, VExpr) +vectFnExpr inline loop_breaker recFns expr@(_fvs, AnnLam bndr _) + | isId bndr = mark DontInline True (vectScalarFun False recFns (deAnnotate expr)) + `orElseV` + mark inlineMe False (vectLam inline loop_breaker expr) +vectFnExpr _ _ _ e = mark DontInline False $ vectExpr e + +mark :: Inline -> Bool -> VM a -> VM (Inline, Bool, a) +mark b isScalarFn p = do { x <- p; return (b, isScalarFn, x) } + +-- |Vectorise an expression of functional type, where all arguments and the result are of scalar +-- type (i.e., 'Int', 'Float', 'Double' etc.) and which does not contain any subcomputations that +-- involve parallel arrays. Such functionals do not requires the full blown vectorisation +-- transformation; instead, they can be lifted by application of a member of the zipWith family +-- (i.e., 'map', 'zipWith', zipWith3', etc.) +-- +vectScalarFun :: Bool -- ^ Was the function marked as scalar by the user? + -> [Var] -- ^ Functions names in same recursive binding group + -> CoreExpr -- ^ Expression to be vectorised + -> VM VExpr +vectScalarFun forceScalar recFns expr + = do { gscalars <- globalScalars + ; let scalars = gscalars `extendVarSetList` recFns + (arg_tys, res_ty) = splitFunTys (exprType expr) + ; MASSERT( not $ null arg_tys ) + ; onlyIfV (forceScalar -- user asserts the functions is scalar + || + all is_prim_ty arg_tys -- check whether the function is scalar + && is_prim_ty res_ty + && is_scalar scalars expr + && uses scalars expr) + $ mkScalarFun arg_tys res_ty expr + } where - arg_tys = map idType args - res_ty = exprType body - - is_scalar_ty ty + -- FIXME: This is woefully insufficient!!! We need a scalar pragma for types!!! + is_prim_ty ty | Just (tycon, []) <- splitTyConApp_maybe ty = tycon == intTyCon || tycon == floatTyCon || tycon == doubleTyCon - | otherwise = False - is_scalar vs (Var v) = v `elemVarSet` vs - is_scalar _ e@(Lit _) = is_scalar_ty $ exprType e - is_scalar vs (App e1 e2) = is_scalar vs e1 && is_scalar vs e2 - is_scalar _ _ = False - + -- Checks whether an expression contain a non-scalar subexpression. + -- + -- Precodition: The variables in the first argument are scalar. + -- + -- In case of a recursive binding group, we /assume/ that all bindings are scalar (by adding + -- them to the list of scalar variables) and then check them. If one of them turns out not to + -- be scalar, the entire group is regarded as not being scalar. + -- + -- FIXME: Currently, doesn't regard external (non-data constructor) variable and anonymous + -- data constructor as scalar. Should be changed once scalar types are passed + -- through VectInfo. + -- + is_scalar :: VarSet -> CoreExpr -> Bool + is_scalar scalars (Var v) = v `elemVarSet` scalars + is_scalar _scalars (Lit _) = True + is_scalar scalars e@(App e1 e2) + | maybe_parr_ty (exprType e) = False + | otherwise = is_scalar scalars e1 && is_scalar scalars e2 + is_scalar scalars (Lam var body) + | maybe_parr_ty (varType var) = False + | otherwise = is_scalar (scalars `extendVarSet` var) body + is_scalar scalars (Let bind body) = bindsAreScalar && is_scalar scalars' body + where + (bindsAreScalar, scalars') = is_scalar_bind scalars bind + is_scalar scalars (Case e var ty alts) + | is_prim_ty ty = is_scalar scalars' e && all (is_scalar_alt scalars') alts + | otherwise = False + where + scalars' = scalars `extendVarSet` var + is_scalar scalars (Cast e _coe) = is_scalar scalars e + is_scalar scalars (Note _ e ) = is_scalar scalars e + is_scalar _scalars (Type {}) = True + is_scalar _scalars (Coercion {}) = True + + -- Result: (, scalars ++ variables bound in this group) + is_scalar_bind scalars (NonRec var e) = (is_scalar scalars e, scalars `extendVarSet` var) + is_scalar_bind scalars (Rec bnds) = (all (is_scalar scalars') es, scalars') + where + (vars, es) = unzip bnds + scalars' = scalars `extendVarSetList` vars + + is_scalar_alt scalars (_, vars, e) = is_scalar (scalars `extendVarSetList ` vars) e + + -- Checks whether the type might be a parallel array type. In particular, if the outermost + -- constructor is a type family, we conservatively assume that it may be a parallel array type. + maybe_parr_ty :: Type -> Bool + maybe_parr_ty ty + | Just ty' <- coreView ty = maybe_parr_ty ty' + | Just (tyCon, _) <- splitTyConApp_maybe ty = isPArrTyCon tyCon || isSynFamilyTyCon tyCon + maybe_parr_ty _ = False + + -- FIXME: I'm not convinced that this reasoning is (always) sound. If the identify functions + -- is called by some other function that is otherwise scalar, it would be very bad + -- that just this call to the identity makes it not be scalar. -- A scalar function has to actually compute something. Without the check, -- we would treat (\(x :: Int) -> x) as a scalar function and lift it to -- (map (\x -> x)) which is very bad. Normal lifting transforms it to -- (\n# x -> x) which is what we want. - uses funs (Var v) = v `elemVarSet` funs - uses funs (App e1 e2) = uses funs e1 || uses funs e2 - uses _ _ = False - + uses funs (Var v) = v `elemVarSet` funs + uses funs (App e1 e2) = uses funs e1 || uses funs e2 + uses funs (Lam b body) = uses (funs `extendVarSet` b) body + uses funs (Let (NonRec _b letExpr) body) + = uses funs letExpr || uses funs body + uses funs (Case e _eId _ty alts) + = uses funs e || any (uses_alt funs) alts + uses _ _ = False + + uses_alt funs (_, _bs, e) = uses funs e + +mkScalarFun :: [Type] -> Type -> CoreExpr -> VM VExpr +mkScalarFun arg_tys res_ty expr + = do { fn_var <- hoistExpr (fsLit "fn") expr DontInline + ; zipf <- zipScalars arg_tys res_ty + ; clo <- scalarClosure arg_tys res_ty (Var fn_var) (zipf `App` Var fn_var) + ; clo_var <- hoistExpr (fsLit "clo") clo DontInline + ; lclo <- liftPD (Var clo_var) + ; return (Var clo_var, lclo) + } -- | Vectorise a lambda abstraction. -vectLam - :: Bool -- ^ When the RHS of a binding, whether that binding should be inlined. - -> Bool -- ^ Whether the binding is a loop breaker. - -> VarSet -- ^ The free variables in the body. - -> [Var] -- ^ Binding variables. - -> CoreExprWithFVs -- ^ Body of abstraction. - -> VM VExpr - -vectLam inline loop_breaker fvs bs body - = do tyvars <- localTyVars +-- +vectLam :: Bool -- ^ When the RHS of a binding, whether that binding should be inlined. + -> Bool -- ^ Whether the binding is a loop breaker. + -> CoreExprWithFVs -- ^ Body of abstraction. + -> VM VExpr +vectLam inline loop_breaker expr@(fvs, AnnLam _ _) + = do let (bs, body) = collectAnnValBinders expr + + tyvars <- localTyVars (vs, vvs) <- readLEnv $ \env -> unzip [(var, vv) | var <- varSetElems fvs , Just vv <- [lookupVarEnv (local_vars env) var]] @@ -254,11 +333,12 @@ (LitAlt (mkMachInt 0), [], empty)]) | otherwise = return (ve, le) +vectLam _ _ _ = panic "vectLam" vectTyAppExpr :: CoreExprWithFVs -> [Type] -> VM VExpr vectTyAppExpr (_, AnnVar v) tys = vectPolyVar v tys -vectTyAppExpr e tys = cantVectorise "Can't vectorise expression" +vectTyAppExpr e tys = cantVectorise "Can't vectorise expression (vectTyExpr)" (ppr $ deAnnotate e `mkTyApps` tys) diff -Nru ghc-7.0.3/compiler/vectorise/Vectorise/Monad/Base.hs ghc-7.2.1/compiler/vectorise/Vectorise/Monad/Base.hs --- ghc-7.0.3/compiler/vectorise/Vectorise/Monad/Base.hs 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/vectorise/Vectorise/Monad/Base.hs 2011-08-07 17:10:05.000000000 +0000 @@ -13,6 +13,9 @@ maybeCantVectorise, maybeCantVectoriseM, + -- * Debugging + traceVt, dumpOptVt, dumpVt, + -- * Control noV, traceNoV, ensureV, traceEnsureV, @@ -22,14 +25,23 @@ orElseV, fixV, ) where + import Vectorise.Builtins import Vectorise.Env import DsMonad +import TcRnMonad +import ErrUtils import Outputable - +import DynFlags +import StaticFlags + +import Control.Monad +import System.IO (stderr) + -- The Vectorisation Monad ---------------------------------------------------- + -- | Vectorisation can either succeed with new envionment and a value, -- or return with failure. data VResult a @@ -46,6 +58,12 @@ Yes genv' lenv' x -> runVM (f x) bi genv' lenv' No -> return No +instance Functor VM where + fmap = liftM + +instance MonadIO VM where + liftIO = liftDs . liftIO + -- Lifting -------------------------------------------------------------------- -- | Lift a desugaring computation into the vectorisation monad. @@ -78,6 +96,35 @@ Nothing -> cantVectorise s d +-- Debugging ------------------------------------------------------------------ + +-- |Output a trace message if -ddump-vt-trace is active. +-- +traceVt :: String -> SDoc -> VM () +traceVt herald doc + | 1 <= opt_TraceLevel = liftDs $ + traceOptIf Opt_D_dump_vt_trace $ + hang (text herald) 2 doc + | otherwise = return () + +-- |Dump the given program conditionally. +-- +dumpOptVt :: DynFlag -> String -> SDoc -> VM () +dumpOptVt flag header doc + = do { b <- liftDs $ doptM flag + ; if b + then dumpVt header doc + else return () + } + +-- |Dump the given program unconditionally. +-- +dumpVt :: String -> SDoc -> VM () +dumpVt header doc + = do { unqual <- liftDs mkPrintUnqualifiedDs + ; liftIO $ printForUser stderr unqual (mkDumpDoc header doc) + } + -- Control -------------------------------------------------------------------- -- | Return some result saying we've failed. noV :: VM a diff -Nru ghc-7.0.3/compiler/vectorise/Vectorise/Monad/Global.hs ghc-7.2.1/compiler/vectorise/Vectorise/Monad/Global.hs --- ghc-7.0.3/compiler/vectorise/Vectorise/Monad/Global.hs 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/vectorise/Vectorise/Monad/Global.hs 2011-08-07 17:10:05.000000000 +0000 @@ -1,34 +1,41 @@ module Vectorise.Monad.Global ( - readGEnv, - setGEnv, - updGEnv, - - -- * Vars - defGlobalVar, - - -- * Scalars - globalScalars, - - -- * TyCons - lookupTyCon, - lookupBoxedTyCon, - defTyCon, - - -- * Datacons - lookupDataCon, - defDataCon, - - -- * PA Dictionaries - lookupTyConPA, - defTyConPA, - defTyConPAs, - - -- * PR Dictionaries - lookupTyConPR + readGEnv, + setGEnv, + updGEnv, + + -- * Vars + defGlobalVar, + + -- * Vectorisation declarations + lookupVectDecl, noVectDecl, + + -- * Scalars + globalScalars, isGlobalScalar, + + -- * TyCons + lookupTyCon, + lookupBoxedTyCon, + defTyCon, + + -- * Datacons + lookupDataCon, + defDataCon, + + -- * PA Dictionaries + lookupTyConPA, + defTyConPA, + defTyConPAs, + + -- * PR Dictionaries + lookupTyConPR ) where + import Vectorise.Monad.Base import Vectorise.Env + +import CoreSyn +import Type import TyCon import DataCon import NameEnv @@ -38,23 +45,27 @@ -- Global Environment --------------------------------------------------------- --- | Project something from the global environment. + +-- |Project something from the global environment. +-- readGEnv :: (GlobalEnv -> a) -> VM a readGEnv f = VM $ \_ genv lenv -> return (Yes genv lenv (f genv)) - --- | Set the value of the global environment. +-- |Set the value of the global environment. +-- setGEnv :: GlobalEnv -> VM () setGEnv genv = VM $ \_ _ lenv -> return (Yes genv lenv ()) - --- | Update the global environment using the provided function. +-- |Update the global environment using the provided function. +-- updGEnv :: (GlobalEnv -> GlobalEnv) -> VM () updGEnv f = VM $ \_ genv lenv -> return (Yes (f genv) lenv ()) -- Vars ----------------------------------------------------------------------- --- | Add a mapping between a global var and its vectorised version to the state. + +-- |Add a mapping between a global var and its vectorised version to the state. +-- defGlobalVar :: Var -> Var -> VM () defGlobalVar v v' = updGEnv $ \env -> env { global_vars = extendVarEnv (global_vars env) v v' @@ -65,15 +76,36 @@ | otherwise = env +-- Vectorisation declarations ------------------------------------------------- + +-- |Check whether a variable has a (non-scalar) vectorisation declaration. +-- +lookupVectDecl :: Var -> VM (Maybe (Type, CoreExpr)) +lookupVectDecl var = readGEnv $ \env -> lookupVarEnv (global_vect_decls env) var + +-- |Check whether a variable has a 'NOVECTORISE' declaration. +-- +noVectDecl :: Var -> VM Bool +noVectDecl var = readGEnv $ \env -> elemVarSet var (global_novect_vars env) + + -- Scalars -------------------------------------------------------------------- --- | Get the set of global scalar variables. + +-- |Get the set of global scalar variables. +-- globalScalars :: VM VarSet -globalScalars - = readGEnv global_scalars +globalScalars = readGEnv global_scalar_vars + +-- |Check whether a given variable is in the set of global scalar variables. +-- +isGlobalScalar :: Var -> VM Bool +isGlobalScalar var = readGEnv $ \env -> elemVarSet var (global_scalar_vars env) -- TyCons --------------------------------------------------------------------- --- | Lookup the vectorised version of a `TyCon` from the global environment. + +-- |Lookup the vectorised version of a `TyCon` from the global environment. +-- lookupTyCon :: TyCon -> VM (Maybe TyCon) lookupTyCon tc | isUnLiftedTyCon tc || isTupleTyCon tc @@ -82,14 +114,12 @@ | otherwise = readGEnv $ \env -> lookupNameEnv (global_tycons env) (tyConName tc) - -- | Lookup the vectorised version of a boxed `TyCon` from the global environment. lookupBoxedTyCon :: TyCon -> VM (Maybe TyCon) lookupBoxedTyCon tc = readGEnv $ \env -> lookupNameEnv (global_boxed_tycons env) (tyConName tc) - -- | Add a mapping between plain and vectorised `TyCon`s to the global environment. defTyCon :: TyCon -> TyCon -> VM () defTyCon tc tc' = updGEnv $ \env -> @@ -97,6 +127,7 @@ -- DataCons ------------------------------------------------------------------- + -- | Lookup the vectorised version of a `DataCon` from the global environment. lookupDataCon :: DataCon -> VM (Maybe DataCon) lookupDataCon dc diff -Nru ghc-7.0.3/compiler/vectorise/Vectorise/Monad/InstEnv.hs ghc-7.2.1/compiler/vectorise/Vectorise/Monad/InstEnv.hs --- ghc-7.0.3/compiler/vectorise/Vectorise/Monad/InstEnv.hs 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/vectorise/Vectorise/Monad/InstEnv.hs 2011-08-07 17:10:05.000000000 +0000 @@ -38,7 +38,7 @@ lookupInst cls tys = do { instEnv <- getInstEnv ; case lookupInstEnv instEnv cls tys of - ([(inst, inst_tys)], _) + ([(inst, inst_tys)], _, _) | noFlexiVar -> return (instanceDFunId inst, inst_tys') | otherwise -> pprPanic "VectMonad.lookupInst: flexi var: " (ppr $ mkTyConApp (classTyCon cls) tys) diff -Nru ghc-7.0.3/compiler/vectorise/Vectorise/Monad.hs ghc-7.2.1/compiler/vectorise/Vectorise/Monad.hs --- ghc-7.0.3/compiler/vectorise/Vectorise/Monad.hs 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/vectorise/Vectorise/Monad.hs 2011-08-07 17:10:05.000000000 +0000 @@ -1,27 +1,28 @@ module Vectorise.Monad ( - module Vectorise.Monad.Base, - module Vectorise.Monad.Naming, - module Vectorise.Monad.Local, - module Vectorise.Monad.Global, - module Vectorise.Monad.InstEnv, - initV, - - -- * Builtins - liftBuiltinDs, - builtin, - builtins, - - -- * Variables - lookupVar, - maybeCantVectoriseVarM, - dumpVar, - - -- * Primitives - lookupPrimPArray, - lookupPrimMethod -) -where + module Vectorise.Monad.Base, + module Vectorise.Monad.Naming, + module Vectorise.Monad.Local, + module Vectorise.Monad.Global, + module Vectorise.Monad.InstEnv, + initV, + + -- * Builtins + liftBuiltinDs, + builtin, + builtins, + + -- * Variables + lookupVar, + maybeCantVectoriseVarM, + dumpVar, + addGlobalScalar, + + -- * Primitives + lookupPrimPArray, + lookupPrimMethod +) where + import Vectorise.Monad.Base import Vectorise.Monad.Naming import Vectorise.Monad.Local @@ -30,67 +31,73 @@ import Vectorise.Builtins import Vectorise.Env -import HscTypes hiding ( MonadThings(..) ) -import Module +import HscTypes hiding ( MonadThings(..) ) +import DynFlags +import MonadUtils (liftIO) import TyCon import Var import VarEnv import Id import DsMonad import Outputable -import Control.Monad +import FastString +import Control.Monad +import VarSet -- | Run a vectorisation computation. -initV :: PackageId - -> HscEnv - -> ModGuts - -> VectInfo - -> VM a - -> IO (Maybe (VectInfo, a)) - -initV pkg hsc_env guts info p - = do - -- XXX: ignores error messages and warnings, check that this is - -- indeed ok (the use of "Just r" suggests so) - (_,Just r) <- initDs hsc_env (mg_module guts) - (mg_rdr_env guts) - (mg_types guts) - go - return r +-- +initV :: HscEnv + -> ModGuts + -> VectInfo + -> VM a + -> IO (Maybe (VectInfo, a)) +initV hsc_env guts info thing_inside + = do { (_, Just r) <- initDs hsc_env (mg_module guts) (mg_rdr_env guts) (mg_types guts) go + ; return r + } where go - = do - builtins <- initBuiltins pkg - builtin_vars <- initBuiltinVars builtins - builtin_tycons <- initBuiltinTyCons builtins - let builtin_datacons = initBuiltinDataCons builtins - builtin_boxed <- initBuiltinBoxedTyCons builtins - builtin_scalars <- initBuiltinScalars builtins - - eps <- liftIO $ hscEPS hsc_env - let famInstEnvs = (eps_fam_inst_env eps, mg_fam_inst_env guts) - instEnvs = (eps_inst_env eps, mg_inst_env guts) - - builtin_prs <- initBuiltinPRs builtins instEnvs - builtin_pas <- initBuiltinPAs builtins instEnvs - - let genv = extendImportedVarsEnv builtin_vars - . extendScalars builtin_scalars - . extendTyConsEnv builtin_tycons - . extendDataConsEnv builtin_datacons - . extendPAFunsEnv builtin_pas - . setPRFunsEnv builtin_prs - . setBoxedTyConsEnv builtin_boxed - $ initGlobalEnv info instEnvs famInstEnvs - - r <- runVM p builtins genv emptyLocalEnv - case r of - Yes genv _ x -> return $ Just (new_info genv, x) - No -> return Nothing + = do { -- pick a DPH backend + ; dflags <- getDOptsDs + ; case dphPackageMaybe dflags of + Nothing -> failWithDs $ ptext selectBackendErr + Just pkg -> do { + + -- set up tables of builtin entities + ; builtins <- initBuiltins pkg + ; builtin_vars <- initBuiltinVars builtins + ; builtin_tycons <- initBuiltinTyCons builtins + ; let builtin_datacons = initBuiltinDataCons builtins + ; builtin_boxed <- initBuiltinBoxedTyCons builtins + + -- set up class and type family envrionments + ; eps <- liftIO $ hscEPS hsc_env + ; let famInstEnvs = (eps_fam_inst_env eps, mg_fam_inst_env guts) + instEnvs = (eps_inst_env eps, mg_inst_env guts) + ; builtin_prs <- initBuiltinPRs builtins instEnvs + ; builtin_pas <- initBuiltinPAs builtins instEnvs + + -- construct the initial global environment + ; let thing_inside' = traceVt "VectDecls" (ppr (mg_vect_decls guts)) >> thing_inside + ; let genv = extendImportedVarsEnv builtin_vars + . extendTyConsEnv builtin_tycons + . extendDataConsEnv builtin_datacons + . extendPAFunsEnv builtin_pas + . setPRFunsEnv builtin_prs + . setBoxedTyConsEnv builtin_boxed + $ initGlobalEnv info (mg_vect_decls guts) instEnvs famInstEnvs + + -- perform vectorisation + ; r <- runVM thing_inside' builtins genv emptyLocalEnv + ; case r of + Yes genv _ x -> return $ Just (new_info genv, x) + No -> return Nothing + } } - new_info genv = updVectInfo genv (mg_types guts) info + new_info genv = modVectInfo genv (mg_types guts) info + selectBackendErr = sLit "To use -fvectorise select a DPH backend with -fdph-par or -fdph-seq" -- Builtins ------------------------------------------------------------------- -- | Lift a desugaring computation using the `Builtins` into the vectorisation monad. @@ -110,7 +117,7 @@ -- Var ------------------------------------------------------------------------ -- | Lookup the vectorised and\/or lifted versions of this variable. --- If it's in the global environment we get the vectorised version. +-- If it's in the global environment we get the vectorised version. -- If it's in the local environment we get both the vectorised and lifted version. lookupVar :: Var -> VM (Scope Var (Var, Var)) lookupVar v @@ -130,14 +137,24 @@ dumpVar :: Var -> a dumpVar var - | Just _ <- isClassOpId_maybe var - = cantVectorise "ClassOpId not vectorised:" (ppr var) + | Just _ <- isClassOpId_maybe var + = cantVectorise "ClassOpId not vectorised:" (ppr var) - | otherwise - = cantVectorise "Variable not vectorised:" (ppr var) + | otherwise + = cantVectorise "Variable not vectorised:" (ppr var) +-- Global scalars -------------------------------------------------------------- + +addGlobalScalar :: Var -> VM () +addGlobalScalar var + = do { traceVt "addGlobalScalar" (ppr var) + ; updGEnv $ \env -> env{global_scalar_vars = extendVarSet (global_scalar_vars env) var} + } + + -- Primitives ----------------------------------------------------------------- + lookupPrimPArray :: TyCon -> VM (Maybe TyCon) lookupPrimPArray = liftBuiltinDs . primPArray diff -Nru ghc-7.0.3/compiler/vectorise/Vectorise/Type/Env.hs ghc-7.2.1/compiler/vectorise/Vectorise/Type/Env.hs --- ghc-7.0.3/compiler/vectorise/Vectorise/Type/Env.hs 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/vectorise/Vectorise/Type/Env.hs 2011-08-07 17:10:05.000000000 +0000 @@ -1,14 +1,9 @@ -{-# OPTIONS_GHC -fno-warn-missing-signatures #-} -#if __GLASGOW_HASKELL__ >= 611 {-# OPTIONS_GHC -XNoMonoLocalBinds #-} -#endif --- Roman likes local bindings --- If this module lives on I'd like to get rid of this flag in due course module Vectorise.Type.Env ( vectTypeEnv, -) -where +) where + import Vectorise.Env import Vectorise.Vect import Vectorise.Monad @@ -32,7 +27,6 @@ import OccName import Id import MkId -import Var import NameEnv import Unique @@ -44,49 +38,58 @@ import Control.Monad import Data.List -debug = False -dtrace s x = if debug then pprTrace "VectType" s x else x - -- | Vectorise a type environment. -- The type environment contains all the type things defined in a module. -vectTypeEnv - :: TypeEnv - -> VM ( TypeEnv -- Vectorised type environment. - , [FamInst] -- New type family instances. - , [(Var, CoreExpr)]) -- New top level bindings. - +-- +vectTypeEnv :: TypeEnv + -> VM ( TypeEnv -- Vectorised type environment. + , [FamInst] -- New type family instances. + , [(Var, CoreExpr)]) -- New top level bindings. vectTypeEnv env - = dtrace (ppr env) - $ do + = do + traceVt "** vectTypeEnv" $ ppr env + cs <- readGEnv $ mk_map . global_tycons -- Split the list of TyCons into the ones we have to vectorise vs the -- ones we can pass through unchanged. We also pass through algebraic -- types that use non Haskell98 features, as we don't handle those. + let tycons = typeEnvTyCons env + groups = tyConGroups tycons + let (conv_tcs, keep_tcs) = classifyTyCons cs groups + orig_tcs = keep_tcs ++ conv_tcs keep_dcs = concatMap tyConDataCons keep_tcs + -- Just use the unvectorised versions of these constructors in vectorised code. zipWithM_ defTyCon keep_tcs keep_tcs zipWithM_ defDataCon keep_dcs keep_dcs - new_tcs <- vectTyConDecls conv_tcs - - let orig_tcs = keep_tcs ++ conv_tcs + -- Vectorise all the declarations. + new_tcs <- vectTyConDecls conv_tcs -- We don't need to make new representation types for dictionary -- constructors. The constructors are always fully applied, and we don't -- need to lift them to arrays as a dictionary of a particular type -- always has the same value. - let vect_tcs = filter (not . isClassTyCon) - $ keep_tcs ++ new_tcs + let vect_tcs = filter (not . isClassTyCon) + $ keep_tcs ++ new_tcs + reprs <- mapM tyConRepr vect_tcs + repr_tcs <- zipWith3M buildPReprTyCon orig_tcs vect_tcs reprs + pdata_tcs <- zipWith3M buildPDataTyCon orig_tcs vect_tcs reprs + updGEnv $ extendFamEnv + $ map mkLocalFamInst + $ repr_tcs ++ pdata_tcs + + -- Create PRepr and PData instances for the vectorised types. + -- We get back the binds for the instance functions, + -- and some new type constructors for the representation types. (_, binds, inst_tcs) <- fixV $ \ ~(dfuns', _, _) -> do defTyConPAs (zipLazy vect_tcs dfuns') reprs <- mapM tyConRepr vect_tcs - repr_tcs <- zipWith3M buildPReprTyCon orig_tcs vect_tcs reprs - pdata_tcs <- zipWith3M buildPDataTyCon orig_tcs vect_tcs reprs dfuns <- sequence $ zipWith5 buildTyConBindings @@ -99,28 +102,25 @@ binds <- takeHoisted return (dfuns, binds, repr_tcs ++ pdata_tcs) + -- The new type constructors are the vectorised versions of the originals, + -- plus the new type constructors that we use for the representations. let all_new_tcs = new_tcs ++ inst_tcs - let new_env = extendTypeEnvList env - (map ATyCon all_new_tcs - ++ [ADataCon dc | tc <- all_new_tcs - , dc <- tyConDataCons tc]) + let new_env = extendTypeEnvList env + $ map ATyCon all_new_tcs + ++ [ADataCon dc | tc <- all_new_tcs + , dc <- tyConDataCons tc] return (new_env, map mkLocalFamInst inst_tcs, binds) - where - tycons = typeEnvTyCons env - groups = tyConGroups tycons + where mk_map env = listToUFM_Directly [(u, getUnique n /= u) | (u,n) <- nameEnvUniqueElts env] - - buildTyConBindings :: TyCon -> TyCon -> TyCon -> TyCon -> SumRepr -> VM Var buildTyConBindings orig_tc vect_tc prepr_tc pdata_tc repr = do vectDataConWorkers orig_tc vect_tc pdata_tc buildPADict vect_tc prepr_tc pdata_tc repr - vectDataConWorkers :: TyCon -> TyCon -> TyCon -> VM () vectDataConWorkers orig_tc vect_tc arr_tc = do bs <- sequence diff -Nru ghc-7.0.3/compiler/vectorise/Vectorise/Type/PADict.hs ghc-7.2.1/compiler/vectorise/Vectorise/Type/PADict.hs --- ghc-7.0.3/compiler/vectorise/Vectorise/Type/PADict.hs 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/vectorise/Vectorise/Type/PADict.hs 2011-08-07 17:10:05.000000000 +0000 @@ -5,8 +5,7 @@ import Vectorise.Monad import Vectorise.Builtins import Vectorise.Type.Repr -import Vectorise.Type.PRepr -import Vectorise.Type.PRDict +import Vectorise.Type.PRepr( buildPAScAndMethods ) import Vectorise.Utils import BasicTypes @@ -15,37 +14,66 @@ import CoreUnfold import TyCon import Type +import TypeRep import Id import Var import Name +-- import FastString +-- import Outputable +-- debug = False +-- dtrace s x = if debug then pprTrace "Vectoris.Type.PADict" s x else x --- | Build the PA dictionary for some type and hoist it to top level. +-- | Build the PA dictionary function for some type and hoist it to top level. -- The PA dictionary holds fns that convert values to and from their vectorised representations. buildPADict :: TyCon -- ^ tycon of the type being vectorised. -> TyCon -- ^ tycon of the type used for the vectorised representation. - -> TyCon -- + -> TyCon -- ^ PRepr instance tycon -> SumRepr -- ^ representation used for the type being vectorised. -> VM Var -- ^ name of the top-level dictionary function. +-- Recall the definition: +-- class class PR (PRepr a) => PA a where +-- toPRepr :: a -> PRepr a +-- fromPRepr :: PRepr a -> a +-- toArrPRepr :: PData a -> PData (PRepr a) +-- fromArrPRepr :: PData (PRepr a) -> PData a +-- +-- Example: +-- df :: forall a. PA a -> PA (T a) +-- df = /\a. \(d:PA a). MkPA ($PR_df a d) ($toPRepr a d) ... +-- $dPR_df :: forall a. PA a -> PR (PRepr (T a)) +-- $dPR_df = .... +-- $toRepr :: forall a. PA a -> T a -> PRepr (T a) +-- $toPRepr = ... +-- The "..." stuff is filled in by buildPAScAndMethods + buildPADict vect_tc prepr_tc arr_tc repr - = polyAbstract tvs $ \args -> - do - method_ids <- mapM (method args) paMethods + = polyAbstract tvs $ \args -> -- The args are the dictionaries we lambda + -- abstract over; and they are put in the + -- envt, so when we need a (PA a) we can + -- find it in the envt + do -- Get ids for each of the methods in the dictionary, including superclass + method_ids <- mapM (method args) buildPAScAndMethods - pa_tc <- builtin paTyCon + -- Expression to build the dictionary. pa_dc <- builtin paDataCon let dict = mkLams (tvs ++ args) $ mkConApp pa_dc - $ Type inst_ty : map (method_call args) method_ids + $ Type inst_ty + : map (method_call args) method_ids - dfun_ty = mkForAllTys tvs - $ mkFunTys (map varType args) (mkTyConApp pa_tc [inst_ty]) + -- Build the type of the dictionary function. + pa_cls <- builtin paClass + let dfun_ty = mkForAllTys tvs + $ mkFunTys (map varType args) + (PredTy $ ClassP pa_cls [inst_ty]) -- Set the unfolding for the inliner. raw_dfun <- newExportedVar dfun_name dfun_ty - let dfun_unf = mkDFunUnfolding dfun_ty (map (DFunPolyArg . Var) method_ids) + let dfun_unf = mkDFunUnfolding dfun_ty $ + map Var method_ids dfun = raw_dfun `setIdUnfolding` dfun_unf `setInlinePragma` dfunInlinePragma @@ -64,8 +92,8 @@ $ do expr <- build vect_tc prepr_tc arr_tc repr let body = mkLams (tvs ++ args) expr - raw_var <- newExportedVar (method_name name) (exprType body) - let var = raw_var + raw_var <- newExportedVar (method_name name) (exprType body) + let var = raw_var `setIdUnfolding` mkInlineUnfolding (Just (length args)) body `setInlinePragma` alwaysInlinePragma hoistBinding var body @@ -73,12 +101,3 @@ method_call args id = mkApps (Var id) (map Type arg_tys ++ map Var args) method_name name = mkVarOcc $ occNameString dfun_name ++ ('$' : name) - - -paMethods :: [(String, TyCon -> TyCon -> TyCon -> SumRepr -> VM CoreExpr)] -paMethods = [("dictPRepr", buildPRDict), - ("toPRepr", buildToPRepr), - ("fromPRepr", buildFromPRepr), - ("toArrPRepr", buildToArrPRepr), - ("fromArrPRepr", buildFromArrPRepr)] - diff -Nru ghc-7.0.3/compiler/vectorise/Vectorise/Type/PData.hs ghc-7.2.1/compiler/vectorise/Vectorise/Type/PData.hs --- ghc-7.0.3/compiler/vectorise/Vectorise/Type/PData.hs 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/vectorise/Vectorise/Type/PData.hs 2011-08-07 17:10:05.000000000 +0000 @@ -31,7 +31,6 @@ [] -- no stupid theta rhs rec_flag -- FIXME: is this ok? - False -- FIXME: no generics False -- not GADT syntax NoParentTyCon (Just $ mk_fam_inst pdata vect_tc) diff -Nru ghc-7.0.3/compiler/vectorise/Vectorise/Type/PRDict.hs ghc-7.2.1/compiler/vectorise/Vectorise/Type/PRDict.hs --- ghc-7.0.3/compiler/vectorise/Vectorise/Type/PRDict.hs 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/vectorise/Vectorise/Type/PRDict.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,56 +0,0 @@ - -module Vectorise.Type.PRDict - (buildPRDict) -where -import Vectorise.Utils -import Vectorise.Monad -import Vectorise.Builtins -import Vectorise.Type.Repr -import CoreSyn -import CoreUtils -import TyCon -import Type -import Coercion - - - -buildPRDict :: TyCon -> TyCon -> TyCon -> SumRepr -> VM CoreExpr -buildPRDict vect_tc prepr_tc _ r - = do - dict <- sum_dict r - pr_co <- mkBuiltinCo prTyCon - let co = mkAppCoercion pr_co - . mkSymCoercion - $ mkTyConApp arg_co ty_args - return (mkCoerce co dict) - where - ty_args = mkTyVarTys (tyConTyVars vect_tc) - Just arg_co = tyConFamilyCoercion_maybe prepr_tc - - sum_dict EmptySum = prDFunOfTyCon =<< builtin voidTyCon - sum_dict (UnarySum r) = con_dict r - sum_dict (Sum { repr_sum_tc = sum_tc - , repr_con_tys = tys - , repr_cons = cons - }) - = do - dicts <- mapM con_dict cons - dfun <- prDFunOfTyCon sum_tc - return $ dfun `mkTyApps` tys `mkApps` dicts - - con_dict (ConRepr _ r) = prod_dict r - - prod_dict EmptyProd = prDFunOfTyCon =<< builtin voidTyCon - prod_dict (UnaryProd r) = comp_dict r - prod_dict (Prod { repr_tup_tc = tup_tc - , repr_comp_tys = tys - , repr_comps = comps }) - = do - dicts <- mapM comp_dict comps - dfun <- prDFunOfTyCon tup_tc - return $ dfun `mkTyApps` tys `mkApps` dicts - - comp_dict (Keep _ pr) = return pr - comp_dict (Wrap ty) = wrapPR ty - - diff -Nru ghc-7.0.3/compiler/vectorise/Vectorise/Type/PRepr.hs ghc-7.2.1/compiler/vectorise/Vectorise/Type/PRepr.hs --- ghc-7.0.3/compiler/vectorise/Vectorise/Type/PRepr.hs 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/vectorise/Vectorise/Type/PRepr.hs 2011-08-07 17:10:05.000000000 +0000 @@ -1,10 +1,6 @@ module Vectorise.Type.PRepr - ( buildPReprTyCon - , buildToPRepr - , buildFromPRepr - , buildToArrPRepr - , buildFromArrPRepr) + ( buildPReprTyCon, buildPAScAndMethods ) where import Vectorise.Utils import Vectorise.Monad @@ -15,6 +11,7 @@ import MkCore ( mkWildCase ) import TyCon import Type +import Kind import BuildTyCl import OccName import Coercion @@ -47,6 +44,28 @@ tyvars = tyConTyVars vect_tc +----------------------------------------------------- +buildPAScAndMethods :: [(String, TyCon -> TyCon -> TyCon -> SumRepr -> VM CoreExpr)] +-- buildPAScandmethods says how to build the PR superclass and methods of PA +-- class class PR (PRepr a) => PA a where +-- toPRepr :: a -> PRepr a +-- fromPRepr :: PRepr a -> a +-- toArrPRepr :: PData a -> PData (PRepr a) +-- fromArrPRepr :: PData (PRepr a) -> PData a + +buildPAScAndMethods = [("PR", buildPRDict), + ("toPRepr", buildToPRepr), + ("fromPRepr", buildFromPRepr), + ("toArrPRepr", buildToArrPRepr), + ("fromArrPRepr", buildFromArrPRepr)] + +buildPRDict :: TyCon -> TyCon -> TyCon -> SumRepr -> VM CoreExpr +buildPRDict vect_tc prepr_tc _ _ + = prDictOfPReprInstTyCon inst_ty prepr_tc arg_tys + where + arg_tys = mkTyVarTys (tyConTyVars vect_tc) + inst_ty = mkTyConApp vect_tc arg_tys + buildToPRepr :: TyCon -> TyCon -> TyCon -> SumRepr -> VM CoreExpr buildToPRepr vect_tc repr_tc _ repr = do @@ -180,9 +199,9 @@ pdata_co <- mkBuiltinCo pdataTyCon let Just repr_co = tyConFamilyCoercion_maybe prepr_tc - co = mkAppCoercion pdata_co - . mkSymCoercion - $ mkTyConApp repr_co ty_args + co = mkAppCo pdata_co + . mkSymCo + $ mkAxInstCo repr_co ty_args scrut = unwrapFamInstScrut pdata_tc ty_args (Var arg) @@ -262,8 +281,8 @@ pdata_co <- mkBuiltinCo pdataTyCon let Just repr_co = tyConFamilyCoercion_maybe prepr_tc - co = mkAppCoercion pdata_co - $ mkTyConApp repr_co var_tys + co = mkAppCo pdata_co + $ mkAxInstCo repr_co var_tys scrut = mkCoerce co (Var arg) diff -Nru ghc-7.0.3/compiler/vectorise/Vectorise/Type/Repr.hs ghc-7.2.1/compiler/vectorise/Vectorise/Type/Repr.hs --- ghc-7.0.3/compiler/vectorise/Vectorise/Type/Repr.hs 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/vectorise/Vectorise/Type/Repr.hs 2011-08-07 17:10:05.000000000 +0000 @@ -82,7 +82,7 @@ where arity = length tys - comp_repr ty = liftM (Keep ty) (prDictOfType ty) + comp_repr ty = liftM (Keep ty) (prDictOfReprType ty) `orElseV` return (Wrap ty) sumReprType :: SumRepr -> VM Type diff -Nru ghc-7.0.3/compiler/vectorise/Vectorise/Type/TyConDecl.hs ghc-7.2.1/compiler/vectorise/Vectorise/Type/TyConDecl.hs --- ghc-7.0.3/compiler/vectorise/Vectorise/Type/TyConDecl.hs 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/vectorise/Vectorise/Type/TyConDecl.hs 2011-08-07 17:10:05.000000000 +0000 @@ -82,7 +82,6 @@ [] -- no stupid theta. rhs' -- new constructor defs. rec_flag -- FIXME: is this ok? - False -- FIXME: no generics False -- not GADT syntax NoParentTyCon Nothing -- not a family instance diff -Nru ghc-7.0.3/compiler/vectorise/Vectorise/Type/Type.hs ghc-7.2.1/compiler/vectorise/Vectorise/Type/Type.hs --- ghc-7.0.3/compiler/vectorise/Vectorise/Type/Type.hs 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/vectorise/Vectorise/Type/Type.hs 2011-08-07 17:10:05.000000000 +0000 @@ -10,7 +10,6 @@ import TypeRep import Type import TyCon -import Var import Outputable import Control.Monad import Data.List @@ -33,7 +32,7 @@ vectAndLiftType ty | Just ty' <- coreView ty = vectAndLiftType ty' vectAndLiftType ty = do - mdicts <- mapM paDictArgType tyvars + mdicts <- mapM paDictArgType (reverse tyvars) let dicts = [dict | Just dict <- mdicts] vmono_ty <- vectType mono_ty lmono_ty <- mkPDataType vmono_ty @@ -78,7 +77,8 @@ dictsPA <- liftM catMaybes $ mapM paDictArgType tyvars -- pack it all back together. - return $ abstractType tyvars (dictsVect ++ dictsPA) tyBody'' + traceVt "vect ForAllTy: " $ ppr (abstractType tyvars (dictsPA ++ dictsVect) tyBody'') + return $ abstractType tyvars (dictsPA ++ dictsVect) tyBody'' vectType ty = cantVectorise "Can't vectorise type" (ppr ty) diff -Nru ghc-7.0.3/compiler/vectorise/Vectorise/Utils/Base.hs ghc-7.2.1/compiler/vectorise/Vectorise/Utils/Base.hs --- ghc-7.0.3/compiler/vectorise/Vectorise/Utils/Base.hs 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/vectorise/Vectorise/Utils/Base.hs 2011-08-07 17:10:05.000000000 +0000 @@ -15,9 +15,11 @@ mkPDataType, mkBuiltinCo, mkVScrut, - + + preprSynTyCon, pdataReprTyCon, pdataReprDataCon, + prDFunOfTyCon ) where import Vectorise.Monad @@ -35,6 +37,8 @@ import Outputable import FastString +import Control.Monad (liftM) + -- Simple Types --------------------------------------------------------------- voidType :: VM Type @@ -129,7 +133,7 @@ mkBuiltinCo get_tc = do tc <- builtin get_tc - return $ mkTyConApp tc [] + return $ mkTyConAppCo tc [] mkVScrut :: VExpr -> VM (CoreExpr, CoreExpr, TyCon, [Type]) @@ -140,6 +144,9 @@ where ty = exprType ve +preprSynTyCon :: Type -> VM (TyCon, [Type]) +preprSynTyCon ty = builtin preprTyCon >>= (`lookupFamInst` [ty]) + pdataReprTyCon :: Type -> VM (TyCon, [Type]) pdataReprTyCon ty = builtin pdataTyCon >>= (`lookupFamInst` [ty]) @@ -151,4 +158,9 @@ let [dc] = tyConDataCons tc return (dc, arg_tys) +prDFunOfTyCon :: TyCon -> VM CoreExpr +prDFunOfTyCon tycon + = liftM Var + . maybeCantVectoriseM "No PR dictionary for tycon" (ppr tycon) + $ lookupTyConPR tycon diff -Nru ghc-7.0.3/compiler/vectorise/Vectorise/Utils/Closure.hs ghc-7.2.1/compiler/vectorise/Vectorise/Utils/Closure.hs --- ghc-7.0.3/compiler/vectorise/Vectorise/Utils/Closure.hs 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/vectorise/Vectorise/Utils/Closure.hs 2011-08-07 17:10:05.000000000 +0000 @@ -17,7 +17,6 @@ import CoreSyn import Type -import Var import MkCore import CoreUtils import TyCon @@ -38,9 +37,9 @@ -> VM VExpr mkClosure arg_ty res_ty env_ty (vfn,lfn) (venv,lenv) - = do Just dict <- paDictOfType env_ty - mkv <- builtin closureVar - mkl <- builtin liftedClosureVar + = do dict <- paDictOfType env_ty + mkv <- builtin closureVar + mkl <- builtin liftedClosureVar return (Var mkv `mkTyApps` [arg_ty, res_ty, env_ty] `mkApps` [dict, vfn, lfn, venv], Var mkl `mkTyApps` [arg_ty, res_ty, env_ty] `mkApps` [dict, vfn, lfn, lenv]) diff -Nru ghc-7.0.3/compiler/vectorise/Vectorise/Utils/Hoisting.hs ghc-7.2.1/compiler/vectorise/Vectorise/Utils/Hoisting.hs --- ghc-7.0.3/compiler/vectorise/Vectorise/Utils/Hoisting.hs 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/vectorise/Vectorise/Utils/Hoisting.hs 2011-08-07 17:10:05.000000000 +0000 @@ -20,7 +20,6 @@ import CoreUtils import CoreUnfold import Type -import Var import Id import BasicTypes( Arity ) import FastString diff -Nru ghc-7.0.3/compiler/vectorise/Vectorise/Utils/PADict.hs ghc-7.2.1/compiler/vectorise/Vectorise/Utils/PADict.hs --- ghc-7.0.3/compiler/vectorise/Vectorise/Utils/PADict.hs 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/vectorise/Vectorise/Utils/PADict.hs 2011-08-07 17:10:05.000000000 +0000 @@ -1,11 +1,10 @@ module Vectorise.Utils.PADict ( - mkPADictType, paDictArgType, paDictOfType, - paDFunType, - paDFunApply, - paMethod + paMethod, + prDictOfReprType, + prDictOfPReprInstTyCon ) where import Vectorise.Monad @@ -13,6 +12,8 @@ import Vectorise.Utils.Base import CoreSyn +import CoreUtils +import Coercion import Type import TypeRep import TyCon @@ -22,14 +23,14 @@ import Control.Monad -mkPADictType :: Type -> VM Type -mkPADictType ty = mkBuiltinTyConApp paTyCon [ty] - - +-- | Construct the PA argument type for the tyvar. For the tyvar (v :: *) it's +-- just PA v. For (v :: (* -> *) -> *) it's +-- +-- > forall (a :: * -> *). (forall (b :: *). PA b -> PA (a b)) -> PA (v a) +-- paDictArgType :: TyVar -> VM (Maybe Type) paDictArgType tv = go (TyVarTy tv) (tyVarKind tv) where - go ty k | Just k' <- kindView k = go ty k' go ty (FunTy k1 k2) = do tv <- newTyVar (fsLit "a") k1 @@ -42,60 +43,48 @@ go ty k | isLiftedTypeKind k - = liftM Just (mkPADictType ty) + = do + pa_cls <- builtin paClass + return $ Just $ PredTy $ ClassP pa_cls [ty] go _ _ = return Nothing --- | Get the PA dictionary for some type, or `Nothing` if there isn't one. -paDictOfType :: Type -> VM (Maybe CoreExpr) +-- | Get the PA dictionary for some type +-- +paDictOfType :: Type -> VM CoreExpr paDictOfType ty = paDictOfTyApp ty_fn ty_args where (ty_fn, ty_args) = splitAppTys ty - paDictOfTyApp :: Type -> [Type] -> VM (Maybe CoreExpr) + paDictOfTyApp :: Type -> [Type] -> VM CoreExpr paDictOfTyApp ty_fn ty_args | Just ty_fn' <- coreView ty_fn = paDictOfTyApp ty_fn' ty_args + -- for type variables, look up the dfun and apply to the PA dictionaries + -- of the type arguments paDictOfTyApp (TyVarTy tv) ty_args - = do dfun <- maybeV (lookupTyVarPA tv) - liftM Just $ paDFunApply dfun ty_args - - paDictOfTyApp (TyConApp tc _) ty_args - = do mdfun <- lookupTyConPA tc - case mdfun of - Nothing - -> pprTrace "VectUtils.paDictOfType" - (vcat [ text "No PA dictionary" - , text "for tycon: " <> ppr tc - , text "in type: " <> ppr ty]) - $ return Nothing - - Just dfun -> liftM Just $ paDFunApply (Var dfun) ty_args + = do dfun <- maybeCantVectoriseM "No PA dictionary for type variable" + (ppr tv <+> text "in" <+> ppr ty) + $ lookupTyVarPA tv + dicts <- mapM paDictOfType ty_args + return $ dfun `mkTyApps` ty_args `mkApps` dicts + + -- for tycons, we also need to apply the dfun to the PR dictionary of + -- the representation type if the tycon is polymorphic + paDictOfTyApp (TyConApp tc []) ty_args + = do + dfun <- maybeCantVectoriseM "No PA dictionary for type constructor" + (ppr tc <+> text "in" <+> ppr ty) + $ lookupTyConPA tc + dicts <- mapM paDictOfType ty_args + return $ Var dfun `mkTyApps` ty_args `mkApps` dicts - paDictOfTyApp ty _ - = cantVectorise "Can't construct PA dictionary for type" (ppr ty) - - - -paDFunType :: TyCon -> VM Type -paDFunType tc - = do - margs <- mapM paDictArgType tvs - res <- mkPADictType (mkTyConApp tc arg_tys) - return . mkForAllTys tvs - $ mkFunTys [arg | Just arg <- margs] res - where - tvs = tyConTyVars tc - arg_tys = mkTyVarTys tvs - -paDFunApply :: CoreExpr -> [Type] -> VM CoreExpr -paDFunApply dfun tys - = do Just dicts <- liftM sequence $ mapM paDictOfType tys - return $ mkApps (mkTyApps dfun tys) dicts + paDictOfTyApp _ _ = failure + failure = cantVectorise "Can't construct PA dictionary for type" (ppr ty) paMethod :: (Builtins -> Var) -> String -> Type -> VM CoreExpr paMethod _ name ty @@ -106,7 +95,108 @@ paMethod method _ ty = do - fn <- builtin method - Just dict <- paDictOfType ty + fn <- builtin method + dict <- paDictOfType ty return $ mkApps (Var fn) [Type ty, dict] +-- | Given a type @ty@, its PRepr synonym tycon and its type arguments, +-- return the PR @PRepr ty@. Suppose we have: +-- +-- > type instance PRepr (T a1 ... an) = t +-- +-- which is internally translated into +-- +-- > type :R:PRepr a1 ... an = t +-- +-- and the corresponding coercion. Then, +-- +-- > prDictOfPReprInstTyCon (T a1 ... an) :R:PRepr u1 ... un = PR (T u1 ... un) +-- +-- Note that @ty@ is only used for error messages +-- +prDictOfPReprInstTyCon :: Type -> TyCon -> [Type] -> VM CoreExpr +prDictOfPReprInstTyCon ty prepr_tc prepr_args + | Just rhs <- coreView (mkTyConApp prepr_tc prepr_args) + = do + dict <- prDictOfReprType' rhs + pr_co <- mkBuiltinCo prTyCon + let Just arg_co = tyConFamilyCoercion_maybe prepr_tc + let co = mkAppCo pr_co + $ mkSymCo + $ mkAxInstCo arg_co prepr_args + return $ mkCoerce co dict + + | otherwise = cantVectorise "Invalid PRepr type instance" (ppr ty) + +-- | Get the PR dictionary for a type. The argument must be a representation +-- type. +prDictOfReprType :: Type -> VM CoreExpr +prDictOfReprType ty + | Just (tycon, tyargs) <- splitTyConApp_maybe ty + = do + prepr <- builtin preprTyCon + if tycon == prepr + then do + let [ty'] = tyargs + pa <- paDictOfType ty' + sel <- builtin paPRSel + return $ Var sel `App` Type ty' `App` pa + else do + -- a representation tycon must have a PR instance + dfun <- maybeV $ lookupTyConPR tycon + prDFunApply dfun tyargs + + | otherwise + = do + -- it is a tyvar or an application of a tyvar + -- determine the PR dictionary from its PA dictionary + -- + -- NOTE: This assumes that PRepr t ~ t is for all representation types + -- t + -- + -- FIXME: This doesn't work for kinds other than * at the moment. We'd + -- have to simply abstract the term over the missing type arguments. + pa <- paDictOfType ty + prsel <- builtin paPRSel + return $ Var prsel `mkApps` [Type ty, pa] + +prDictOfReprType' :: Type -> VM CoreExpr +prDictOfReprType' ty = prDictOfReprType ty `orElseV` + cantVectorise "No PR dictionary for representation type" + (ppr ty) + +-- | Apply a tycon's PR dfun to dictionary arguments (PR or PA) corresponding +-- to the argument types. +prDFunApply :: Var -> [Type] -> VM CoreExpr +prDFunApply dfun tys + | Just [] <- ctxs -- PR (a :-> b) doesn't have a context + = return $ Var dfun `mkTyApps` tys + + | Just tycons <- ctxs + , length tycons == length tys + = do + pa <- builtin paTyCon + pr <- builtin prTyCon + args <- zipWithM (dictionary pa pr) tys tycons + return $ Var dfun `mkTyApps` tys `mkApps` args + + | otherwise = invalid + where + -- the dfun's contexts - if its type is (PA a, PR b) => PR (C a b) then + -- ctxs is Just [PA, PR] + ctxs = fmap (map fst) + $ sequence + $ map splitTyConApp_maybe + $ fst + $ splitFunTys + $ snd + $ splitForAllTys + $ varType dfun + + dictionary pa pr ty tycon + | tycon == pa = paDictOfType ty + | tycon == pr = prDictOfReprType ty + | otherwise = invalid + + invalid = cantVectorise "Invalid PR dfun type" (ppr (varType dfun) <+> ppr tys) + diff -Nru ghc-7.0.3/compiler/vectorise/Vectorise/Utils/Poly.hs ghc-7.2.1/compiler/vectorise/Vectorise/Utils/Poly.hs --- ghc-7.0.3/compiler/vectorise/Vectorise/Utils/Poly.hs 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/vectorise/Vectorise/Utils/Poly.hs 2011-08-07 17:10:05.000000000 +0000 @@ -11,7 +11,6 @@ import Vectorise.Utils.PADict import CoreSyn import Type -import Var import FastString import Control.Monad @@ -43,11 +42,11 @@ polyApply :: CoreExpr -> [Type] -> VM CoreExpr polyApply expr tys - = do Just dicts <- liftM sequence $ mapM paDictOfType tys + = do dicts <- mapM paDictOfType tys return $ expr `mkTyApps` tys `mkApps` dicts polyVApply :: VExpr -> [Type] -> VM VExpr polyVApply expr tys - = do Just dicts <- liftM sequence $ mapM paDictOfType tys + = do dicts <- mapM paDictOfType tys return $ mapVect (\e -> e `mkTyApps` tys `mkApps` dicts) expr diff -Nru ghc-7.0.3/compiler/vectorise/Vectorise/Utils/PRDict.hs ghc-7.2.1/compiler/vectorise/Vectorise/Utils/PRDict.hs --- ghc-7.0.3/compiler/vectorise/Vectorise/Utils/PRDict.hs 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/vectorise/Vectorise/Utils/PRDict.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,55 +0,0 @@ - -module Vectorise.Utils.PRDict ( - prDFunOfTyCon, - prDictOfType, - prDictOfTyApp, - prDFunApply, - wrapPR -) -where -import Vectorise.Monad -import Vectorise.Builtins -import Vectorise.Utils.PADict - -import CoreSyn -import Type -import TypeRep -import TyCon -import Outputable -import Control.Monad - - -prDFunOfTyCon :: TyCon -> VM CoreExpr -prDFunOfTyCon tycon - = liftM Var - . maybeCantVectoriseM "No PR dictionary for tycon" (ppr tycon) - $ lookupTyConPR tycon - - - -prDictOfType :: Type -> VM CoreExpr -prDictOfType ty = prDictOfTyApp ty_fn ty_args - where - (ty_fn, ty_args) = splitAppTys ty - -prDictOfTyApp :: Type -> [Type] -> VM CoreExpr -prDictOfTyApp ty_fn ty_args - | Just ty_fn' <- coreView ty_fn = prDictOfTyApp ty_fn' ty_args -prDictOfTyApp (TyConApp tc _) ty_args - = do - dfun <- liftM Var $ maybeV (lookupTyConPR tc) - prDFunApply dfun ty_args -prDictOfTyApp _ _ = noV - -prDFunApply :: CoreExpr -> [Type] -> VM CoreExpr -prDFunApply dfun tys - = do - dicts <- mapM prDictOfType tys - return $ mkApps (mkTyApps dfun tys) dicts - -wrapPR :: Type -> VM CoreExpr -wrapPR ty - = do - Just pa_dict <- paDictOfType ty - pr_dfun <- prDFunOfTyCon =<< builtin wrapTyCon - return $ mkApps pr_dfun [Type ty, pa_dict] diff -Nru ghc-7.0.3/compiler/vectorise/Vectorise/Utils.hs ghc-7.2.1/compiler/vectorise/Vectorise/Utils.hs --- ghc-7.0.3/compiler/vectorise/Vectorise/Utils.hs 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/vectorise/Vectorise/Utils.hs 2011-08-07 17:10:05.000000000 +0000 @@ -4,7 +4,6 @@ module Vectorise.Utils.Closure, module Vectorise.Utils.Hoisting, module Vectorise.Utils.PADict, - module Vectorise.Utils.PRDict, module Vectorise.Utils.Poly, -- * Annotated Exprs @@ -28,14 +27,12 @@ import Vectorise.Utils.Closure import Vectorise.Utils.Hoisting import Vectorise.Utils.PADict -import Vectorise.Utils.PRDict import Vectorise.Utils.Poly import Vectorise.Monad import Vectorise.Builtins import CoreSyn import CoreUtils import Type -import Var import Control.Monad @@ -49,7 +46,7 @@ collectAnnTypeBinders :: AnnExpr Var ann -> ([Var], AnnExpr Var ann) collectAnnTypeBinders expr = go [] expr where - go bs (_, AnnLam b e) | isTyCoVar b = go (b:bs) e + go bs (_, AnnLam b e) | isTyVar b = go (b:bs) e go bs e = (reverse bs, e) collectAnnValBinders :: AnnExpr Var ann -> ([Var], AnnExpr Var ann) @@ -63,22 +60,59 @@ isAnnTypeArg _ = False --- PD Functions --------------------------------------------------------------- -replicatePD :: CoreExpr -> CoreExpr -> VM CoreExpr -replicatePD len x = liftM (`mkApps` [len,x]) - (paMethod replicatePDVar "replicatePD" (exprType x)) +-- PD "Parallel Data" Functions ----------------------------------------------- +-- +-- Given some data that has a PA dictionary, we can convert it to its +-- representation type, perform some operation on the data, then convert it back. +-- +-- In the DPH backend, the types of these functions are defined +-- in dph-common/D.A.P.Lifted/PArray.hs +-- +-- | An empty array of the given type. emptyPD :: Type -> VM CoreExpr emptyPD = paMethod emptyPDVar "emptyPD" -packByTagPD :: Type -> CoreExpr -> CoreExpr -> CoreExpr -> CoreExpr -> VM CoreExpr +-- | Produce an array containing copies of a given element. +replicatePD + :: CoreExpr -- ^ Number of copies in the resulting array. + -> CoreExpr -- ^ Value to replicate. + -> VM CoreExpr + +replicatePD len x + = liftM (`mkApps` [len,x]) + $ paMethod replicatePDVar "replicatePD" (exprType x) + + +-- | Select some elements from an array that correspond to a particular tag value +--- and pack them into a new array. +-- eg packByTagPD Int# [:23, 42, 95, 50, 27, 49:] 3 [:1, 2, 1, 2, 3, 2:] 2 +-- ==> [:42, 50, 49:] +-- +packByTagPD + :: Type -- ^ Element type. + -> CoreExpr -- ^ Source array. + -> CoreExpr -- ^ Length of resulting array. + -> CoreExpr -- ^ Tag values of elements in source array. + -> CoreExpr -- ^ The tag value for the elements to select. + -> VM CoreExpr + packByTagPD ty xs len tags t = liftM (`mkApps` [xs, len, tags, t]) (paMethod packByTagPDVar "packByTagPD" ty) -combinePD :: Type -> CoreExpr -> CoreExpr -> [CoreExpr] -> VM CoreExpr +-- | Combine some arrays based on a selector. +-- The selector says which source array to choose for each element of the +-- resulting array. +combinePD + :: Type -- ^ Element type + -> CoreExpr -- ^ Length of resulting array + -> CoreExpr -- ^ Selector. + -> [CoreExpr] -- ^ Arrays to combine. + -> VM CoreExpr + combinePD ty len sel xs = liftM (`mkApps` (len : sel : xs)) (paMethod (combinePDVar n) ("combine" ++ show n ++ "PD") ty) @@ -109,8 +143,8 @@ scalarClosure :: [Type] -> Type -> CoreExpr -> CoreExpr -> VM CoreExpr scalarClosure arg_tys res_ty scalar_fun array_fun = do - ctr <- builtin (closureCtrFun $ length arg_tys) - Just pas <- liftM sequence $ mapM paDictOfType (init arg_tys) + ctr <- builtin (closureCtrFun $ length arg_tys) + pas <- mapM paDictOfType (init arg_tys) return $ Var ctr `mkTyApps` (arg_tys ++ [res_ty]) `mkApps` (pas ++ [scalar_fun, array_fun]) diff -Nru ghc-7.0.3/compiler/vectorise/Vectorise/Var.hs ghc-7.2.1/compiler/vectorise/Vectorise/Var.hs --- ghc-7.0.3/compiler/vectorise/Vectorise/Var.hs 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/vectorise/Vectorise/Var.hs 2011-08-07 17:10:05.000000000 +0000 @@ -17,7 +17,6 @@ import Vectorise.Type.Type import CoreSyn import Type -import Var import VarEnv import Literal import Id diff -Nru ghc-7.0.3/compiler/vectorise/Vectorise.hs ghc-7.2.1/compiler/vectorise/Vectorise.hs --- ghc-7.0.3/compiler/vectorise/Vectorise.hs 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/compiler/vectorise/Vectorise.hs 2011-08-07 17:10:05.000000000 +0000 @@ -1,6 +1,5 @@ -{-# OPTIONS -fno-warn-missing-signatures #-} -module Vectorise( vectorise ) +module Vectorise ( vectorise ) where import Vectorise.Type.Env @@ -13,197 +12,283 @@ import Vectorise.Monad import HscTypes hiding ( MonadThings(..) ) -import Module ( PackageId ) -import CoreSyn import CoreUnfold ( mkInlineUnfolding ) import CoreFVs +import PprCore +import CoreSyn import CoreMonad ( CoreM, getHscEnv ) -import FamInstEnv ( extendFamInstEnvList ) -import Var +import Type import Id import OccName -import BasicTypes ( isLoopBreaker ) +import DynFlags +import BasicTypes ( isStrongLoopBreaker ) import Outputable import Util ( zipLazy ) +import MonadUtils + import Control.Monad -debug = False -dtrace s x = if debug then pprTrace "Vectorise" s x else x -- | Vectorise a single module. --- Takes the package containing the DPH backend we're using. Eg either dph-par or dph-seq. -vectorise :: PackageId -> ModGuts -> CoreM ModGuts -vectorise backend guts - = do hsc_env <- getHscEnv - liftIO $ vectoriseIO backend hsc_env guts - - --- | Vectorise a single monad, given its HscEnv (code gen environment). -vectoriseIO :: PackageId -> HscEnv -> ModGuts -> IO ModGuts -vectoriseIO backend hsc_env guts - = do -- Get information about currently loaded external packages. - eps <- hscEPS hsc_env - - -- Combine vectorisation info from the current module, and external ones. - let info = hptVectInfo hsc_env `plusVectInfo` eps_vect_info eps - - -- Run the main VM computation. - Just (info', guts') <- initV backend hsc_env guts info (vectModule guts) - return (guts' { mg_vect_info = info' }) +-- +vectorise :: ModGuts -> CoreM ModGuts +vectorise guts + = do { hsc_env <- getHscEnv + ; liftIO $ vectoriseIO hsc_env guts + } +-- | Vectorise a single monad, given the dynamic compiler flags and HscEnv. +-- +vectoriseIO :: HscEnv -> ModGuts -> IO ModGuts +vectoriseIO hsc_env guts + = do { -- Get information about currently loaded external packages. + ; eps <- hscEPS hsc_env + + -- Combine vectorisation info from the current module, and external ones. + ; let info = hptVectInfo hsc_env `plusVectInfo` eps_vect_info eps + + -- Run the main VM computation. + ; Just (info', guts') <- initV hsc_env guts info (vectModule guts) + ; return (guts' { mg_vect_info = info' }) + } -- | Vectorise a single module, in the VM monad. +-- vectModule :: ModGuts -> VM ModGuts -vectModule guts - = do -- Vectorise the type environment. - -- This may add new TyCons and DataCons. - -- TODO: What new binds do we get back here? - (types', fam_insts, tc_binds) <- vectTypeEnv (mg_types guts) - - -- TODO: What is this? - let fam_inst_env' = extendFamInstEnvList (mg_fam_inst_env guts) fam_insts - updGEnv (setFamInstEnv fam_inst_env') +vectModule guts@(ModGuts { mg_types = types + , mg_binds = binds + , mg_fam_insts = fam_insts + }) + = do { dumpOptVt Opt_D_dump_vt_trace "Before vectorisation" $ + pprCoreBindings binds + + -- Vectorise the type environment. + -- This may add new TyCons and DataCons. + ; (types', new_fam_insts, tc_binds) <- vectTypeEnv types + + ; (_, fam_inst_env) <- readGEnv global_fam_inst_env -- dicts <- mapM buildPADict pa_insts -- workers <- mapM vectDataConWorkers pa_insts - -- Vectorise all the top level bindings. - binds' <- mapM vectTopBind (mg_binds guts) + -- Vectorise all the top level bindings. + ; binds' <- mapM vectTopBind binds - return $ guts { mg_types = types' - , mg_binds = Rec tc_binds : binds' - , mg_fam_inst_env = fam_inst_env' - , mg_fam_insts = mg_fam_insts guts ++ fam_insts - } - - --- | Try to vectorise a top-level binding. --- If it doesn't vectorise then return it unharmed. --- --- For example, for the binding --- --- @ --- foo :: Int -> Int --- foo = \x -> x + x --- @ --- --- we get --- @ --- foo :: Int -> Int --- foo = \x -> vfoo $: x --- --- v_foo :: Closure void vfoo lfoo --- v_foo = closure vfoo lfoo void --- --- vfoo :: Void -> Int -> Int --- vfoo = ... + ; return $ guts { mg_types = types' + , mg_binds = Rec tc_binds : binds' + , mg_fam_inst_env = fam_inst_env + , mg_fam_insts = fam_insts ++ new_fam_insts + } + } + +-- |Try to vectorise a top-level binding. If it doesn't vectorise then return it unharmed. -- --- lfoo :: PData Void -> PData Int -> PData Int --- lfoo = ... --- @ +-- For example, for the binding -- --- @vfoo@ is the "vectorised", or scalar, version that does the same as the original --- function foo, but takes an explicit environment. --- --- @lfoo@ is the "lifted" version that works on arrays. +-- @ +-- foo :: Int -> Int +-- foo = \x -> x + x +-- @ +-- +-- we get +-- @ +-- foo :: Int -> Int +-- foo = \x -> vfoo $: x +-- +-- v_foo :: Closure void vfoo lfoo +-- v_foo = closure vfoo lfoo void +-- +-- vfoo :: Void -> Int -> Int +-- vfoo = ... +-- +-- lfoo :: PData Void -> PData Int -> PData Int +-- lfoo = ... +-- @ +-- +-- @vfoo@ is the "vectorised", or scalar, version that does the same as the original +-- function foo, but takes an explicit environment. +-- +-- @lfoo@ is the "lifted" version that works on arrays. +-- +-- @v_foo@ combines both of these into a `Closure` that also contains the +-- environment. -- --- @v_foo@ combines both of these into a `Closure` that also contains the --- environment. +-- The original binding @foo@ is rewritten to call the vectorised version +-- present in the closure. -- --- The original binding @foo@ is rewritten to call the vectorised version --- present in the closure. +-- Vectorisation may be surpressed by annotating a binding with a 'NOVECTORISE' pragma. If this +-- pragma is used in a group of mutually recursive bindings, either all or no binding must have +-- the pragma. If only some bindings are annotated, a fatal error is being raised. +-- FIXME: Once we support partial vectorisation, we may be able to vectorise parts of a group, or +-- we may emit a warning and refrain from vectorising the entire group. -- vectTopBind :: CoreBind -> VM CoreBind vectTopBind b@(NonRec var expr) - = do - (inline, expr') <- vectTopRhs var expr - var' <- vectTopBinder var inline expr' - - -- Vectorising the body may create other top-level bindings. - hs <- takeHoisted - - -- To get the same functionality as the original body we project - -- out its vectorised version from the closure. - cexpr <- tryConvert var var' expr - - return . Rec $ (var, cexpr) : (var', expr') : hs - `orElseV` - return b - + = unlessNoVectDecl $ + do { -- Vectorise the right-hand side, create an appropriate top-level binding and add it + -- to the vectorisation map. + ; (inline, isScalar, expr') <- vectTopRhs [] var expr + ; var' <- vectTopBinder var inline expr' + ; when isScalar $ + addGlobalScalar var + + -- We replace the original top-level binding by a value projected from the vectorised + -- closure and add any newly created hoisted top-level bindings. + ; cexpr <- tryConvert var var' expr + ; hs <- takeHoisted + ; return . Rec $ (var, cexpr) : (var', expr') : hs + } + `orElseV` + return b + where + unlessNoVectDecl vectorise + = do { hasNoVectDecl <- noVectDecl var + ; when hasNoVectDecl $ + traceVt "NOVECTORISE" $ ppr var + ; if hasNoVectDecl then return b else vectorise + } vectTopBind b@(Rec bs) - = do - (vars', _, exprs') - <- fixV $ \ ~(_, inlines, rhss) -> - do vars' <- sequence [vectTopBinder var inline rhs + = unlessSomeNoVectDecl $ + do { (vars', _, exprs', hs) <- fixV $ + \ ~(_, inlines, rhss, _) -> + do { -- Vectorise the right-hand sides, create an appropriate top-level bindings + -- and add them to the vectorisation map. + ; vars' <- sequence [vectTopBinder var inline rhs | (var, ~(inline, rhs)) <- zipLazy vars (zip inlines rhss)] - (inlines', exprs') - <- mapAndUnzipM (uncurry vectTopRhs) bs - - return (vars', inlines', exprs') - - hs <- takeHoisted - cexprs <- sequence $ zipWith3 tryConvert vars vars' exprs - return . Rec $ zip vars cexprs ++ zip vars' exprs' ++ hs - `orElseV` - return b + ; (inlines, areScalars, exprs') <- mapAndUnzip3M (uncurry $ vectTopRhs vars) bs + ; hs <- takeHoisted + ; if and areScalars + then -- (1) Entire recursive group is scalar + -- => add all variables to the global set of scalars + do { mapM_ addGlobalScalar vars + ; return (vars', inlines, exprs', hs) + } + else -- (2) At least one binding is not scalar + -- => vectorise again with empty set of local scalars + do { (inlines, _, exprs') <- mapAndUnzip3M (uncurry $ vectTopRhs []) bs + ; hs <- takeHoisted + ; return (vars', inlines, exprs', hs) + } + } + + -- Replace the original top-level bindings by a values projected from the vectorised + -- closures and add any newly created hoisted top-level bindings to the group. + ; cexprs <- sequence $ zipWith3 tryConvert vars vars' exprs + ; return . Rec $ zip vars cexprs ++ zip vars' exprs' ++ hs + } + `orElseV` + return b where (vars, exprs) = unzip bs - + unlessSomeNoVectDecl vectorise + = do { hasNoVectDecls <- mapM noVectDecl vars + ; when (and hasNoVectDecls) $ + traceVt "NOVECTORISE" $ ppr vars + ; if and hasNoVectDecls + then return b -- all bindings have 'NOVECTORISE' + else if or hasNoVectDecls + then cantVectorise noVectoriseErr (ppr b) -- some (but not all) have 'NOVECTORISE' + else vectorise -- no binding has a 'NOVECTORISE' decl + } + noVectoriseErr = "NOVECTORISE must be used on all or no bindings of a recursive group" + -- | Make the vectorised version of this top level binder, and add the mapping -- between it and the original to the state. For some binder @foo@ the vectorised -- version is @$v_foo@ -- --- NOTE: vectTopBinder *MUST* be lazy in inline and expr because of how it is --- used inside of fixV in vectTopBind -vectTopBinder - :: Var -- ^ Name of the binding. - -> Inline -- ^ Whether it should be inlined, used to annotate it. - -> CoreExpr -- ^ RHS of the binding, used to set the `Unfolding` of the returned `Var`. - -> VM Var -- ^ Name of the vectorised binding. - +-- NOTE: 'vectTopBinder' *MUST* be lazy in inline and expr because of how it is +-- used inside of 'fixV' in 'vectTopBind'. +-- +vectTopBinder :: Var -- ^ Name of the binding. + -> Inline -- ^ Whether it should be inlined, used to annotate it. + -> CoreExpr -- ^ RHS of binding, used to set the 'Unfolding' of the returned 'Var'. + -> VM Var -- ^ Name of the vectorised binding. vectTopBinder var inline expr - = do - -- Vectorise the type attached to the var. - vty <- vectType (idType var) - - -- Make the vectorised version of binding's name, and set the unfolding used for inlining. - var' <- liftM (`setIdUnfoldingLazily` unfolding) - $ cloneId mkVectOcc var vty + = do { -- Vectorise the type attached to the var. + ; vty <- vectType (idType var) + + -- If there is a vectorisation declartion for this binding, make sure that its type + -- matches + ; vectDecl <- lookupVectDecl var + ; case vectDecl of + Nothing -> return () + Just (vdty, _) + | eqType vty vdty -> return () + | otherwise -> + cantVectorise ("Type mismatch in vectorisation pragma for " ++ show var) $ + (text "Expected type" <+> ppr vty) + $$ + (text "Inferred type" <+> ppr vdty) + + -- Make the vectorised version of binding's name, and set the unfolding used for inlining + ; var' <- liftM (`setIdUnfoldingLazily` unfolding) + $ cloneId mkVectOcc var vty - -- Add the mapping between the plain and vectorised name to the state. - defGlobalVar var var' + -- Add the mapping between the plain and vectorised name to the state. + ; defGlobalVar var var' - return var' + ; return var' + } where unfolding = case inline of Inline arity -> mkInlineUnfolding (Just arity) expr DontInline -> noUnfolding - -- | Vectorise the RHS of a top-level binding, in an empty local environment. -vectTopRhs - :: Var -- ^ Name of the binding. - -> CoreExpr -- ^ Body of the binding. - -> VM (Inline, CoreExpr) - -vectTopRhs var expr - = dtrace (vcat [text "vectTopRhs", ppr expr]) - $ closedV - $ do (inline, vexpr) <- inBind var - $ vectPolyExpr (isLoopBreaker $ idOccInfo var) - (freeVars expr) - return (inline, vectorised vexpr) - +-- +-- We need to distinguish three cases: +-- +-- (1) We have a (non-scalar) vectorisation declaration for the variable (which explicitly provides +-- vectorised code implemented by the user) +-- => no automatic vectorisation & instead use the user-supplied code +-- +-- (2) We have a scalar vectorisation declaration for the variable +-- => generate vectorised code that uses a scalar 'map'/'zipWith' to lift the computation +-- +-- (3) There is no vectorisation declaration for the variable +-- => perform automatic vectorisation of the RHS +-- +vectTopRhs :: [Var] -- ^ Names of all functions in the rec block + -> Var -- ^ Name of the binding. + -> CoreExpr -- ^ Body of the binding. + -> VM ( Inline -- (1) inline specification for the binding + , Bool -- (2) whether the right-hand side is a scalar computation + , CoreExpr) -- (3) the vectorised right-hand side +vectTopRhs recFs var expr + = closedV + $ do { traceVt ("vectTopRhs of " ++ show var) $ ppr expr + + ; globalScalar <- isGlobalScalar var + ; vectDecl <- lookupVectDecl var + ; rhs globalScalar vectDecl + } + where + rhs _globalScalar (Just (_, expr')) -- Case (1) + = return (inlineMe, False, expr') + rhs True Nothing -- Case (2) + = do { expr' <- vectScalarFun True recFs expr + ; return (inlineMe, True, vectorised expr') + } + rhs False Nothing -- Case (3) + = do { let fvs = freeVars expr + ; (inline, isScalar, vexpr) <- inBind var $ + vectPolyExpr (isStrongLoopBreaker $ idOccInfo var) recFs fvs + ; return (inline, isScalar, vectorised vexpr) + } -- | Project out the vectorised version of a binding from some closure, --- or return the original body if that doesn't work. -tryConvert - :: Var -- ^ Name of the original binding (eg @foo@) - -> Var -- ^ Name of vectorised version of binding (eg @$vfoo@) - -> CoreExpr -- ^ The original body of the binding. - -> VM CoreExpr - +-- or return the original body if that doesn't work or the binding is scalar. +-- +tryConvert :: Var -- ^ Name of the original binding (eg @foo@) + -> Var -- ^ Name of vectorised version of binding (eg @$vfoo@) + -> CoreExpr -- ^ The original body of the binding. + -> VM CoreExpr tryConvert var vect_var rhs - = fromVect (idType var) (Var vect_var) `orElseV` return rhs - + = do { globalScalar <- isGlobalScalar var + ; if globalScalar + then + return rhs + else + fromVect (idType var) (Var vect_var) `orElseV` return rhs + } diff -Nru ghc-7.0.3/configure ghc-7.2.1/configure --- ghc-7.0.3/configure 2011-03-26 18:10:47.000000000 +0000 +++ ghc-7.2.1/configure 2011-08-07 17:11:02.000000000 +0000 @@ -1,6 +1,6 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles. -# Generated by GNU Autoconf 2.65 for The Glorious Glasgow Haskell Compilation System 7.0.3. +# Generated by GNU Autoconf 2.65 for The Glorious Glasgow Haskell Compilation System 7.2.1. # # Report bugs to . # @@ -552,8 +552,8 @@ # Identity of this package. PACKAGE_NAME='The Glorious Glasgow Haskell Compilation System' PACKAGE_TARNAME='ghc' -PACKAGE_VERSION='7.0.3' -PACKAGE_STRING='The Glorious Glasgow Haskell Compilation System 7.0.3' +PACKAGE_VERSION='7.2.1' +PACKAGE_STRING='The Glorious Glasgow Haskell Compilation System 7.2.1' PACKAGE_BUGREPORT='glasgow-haskell-bugs@haskell.org' PACKAGE_URL='' @@ -607,6 +607,7 @@ HavePapiHeader HavePapiLib GTK_CONFIG +LdHasBuildId LdIsGNULd LdXFlag LeadingUnderscore @@ -620,7 +621,6 @@ HappyVersion HappyCmd GhcPkgCmd -HstagsCmd DblatexCmd HAVE_DOCBOOK_XSL XsltprocCmd @@ -633,7 +633,6 @@ TimeCmd SedCmd LN_S -ArSupportsInput RANLIB ArSupportsAtFile ArArgs @@ -644,6 +643,12 @@ INSTALL_SCRIPT INSTALL_PROGRAM ContextDiffCmd +SettingsTouchCommand +SettingsWindresCommand +SettingsDllWrapCommand +SettingsPerlCommand +SettingsCCompilerFlags +SettingsCCompilerCommand CONF_CPP_OPTS_STAGE2 CONF_CPP_OPTS_STAGE1 CONF_CPP_OPTS_STAGE0 @@ -658,9 +663,9 @@ CONF_CC_OPTS_STAGE0 CPP GccExtraViaCOpts +GccLT46 GccLT34 GccVersion -HaveGcc OBJEXT EXEEXT ac_ct_CC @@ -672,17 +677,16 @@ GhcLibsWithUnix MACOSX_DEPLOYMENT_SDK MACOSX_DEPLOYMENT_VERSION -SplitObjsBroken NmCmd NM LdCmd LD WhatGccIsCalled CC +SplitObjsBroken hardtop -HBC -NHC WithHc +SOLARIS_BROKEN_SHLD soext exeext TargetVendor_CPP @@ -717,9 +721,11 @@ ICONV_LIB_DIRS ICONV_INCLUDE_DIRS WithGhc +ArSupportsAtFile_STAGE0 +AR_OPTS_STAGE0 +AR_STAGE0 +CC_STAGE0 ghc_ge_613 -ghc_ge_611 -ghc_ge_6102 GhcPatchLevel GhcMinVersion GhcMajVersion @@ -786,6 +792,7 @@ with_gmp_includes with_gmp_libraries with_hc +with_gcc_4_2 with_gcc with_ld with_nm @@ -1342,7 +1349,7 @@ # Omit some internal or obsolete options to make the list less imposing. # This message is too long to be a string in the A/UX 3.1 sh. cat <<_ACEOF -\`configure' configures The Glorious Glasgow Haskell Compilation System 7.0.3 to adapt to many kinds of systems. +\`configure' configures The Glorious Glasgow Haskell Compilation System 7.2.1 to adapt to many kinds of systems. Usage: $0 [OPTION]... [VAR=VALUE]... @@ -1408,7 +1415,7 @@ if test -n "$ac_init_help"; then case $ac_init_help in - short | recursive ) echo "Configuration of The Glorious Glasgow Haskell Compilation System 7.0.3:";; + short | recursive ) echo "Configuration of The Glorious Glasgow Haskell Compilation System 7.2.1:";; esac cat <<\_ACEOF @@ -1434,6 +1441,7 @@ --with-gmp-libraries directory containing gmp library --with-hc=ARG Use ARG as the path to the compiler for compiling ordinary Haskell code (default= value of --with-ghc) + --with-gcc-4.2=ARG Use ARG as the path to gcc-4.2 [default=autodetect] --with-gcc=ARG Use ARG as the path to gcc [default=autodetect] --with-ld=ARG Use ARG as the path to ld [default=autodetect] --with-nm=ARG Use ARG as the path to nm [default=autodetect] @@ -1517,7 +1525,7 @@ test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF -The Glorious Glasgow Haskell Compilation System configure 7.0.3 +The Glorious Glasgow Haskell Compilation System configure 7.2.1 generated by GNU Autoconf 2.65 Copyright (C) 2009 Free Software Foundation, Inc. @@ -2159,7 +2167,7 @@ This file contains any messages produced by compilers while running configure, to aid debugging if configure makes a mistake. -It was created by The Glorious Glasgow Haskell Compilation System $as_me 7.0.3, which was +It was created by The Glorious Glasgow Haskell Compilation System $as_me 7.2.1, which was generated by GNU Autoconf 2.65. Invocation command line was $ $0 $@ @@ -2766,7 +2774,7 @@ { $as_echo "$as_me:${as_lineno-$LINENO}: result: given $PACKAGE_VERSION" >&5 $as_echo "given $PACKAGE_VERSION" >&6; } elif test -d .git; then - ver_date=`git log -n 1 --date=short --pretty=format:%ci | sed "s/^.*\([0-9][0-9][0-9][0-9]\)-\([0-9][0-9]\)-\([0-9][0-9]\).*$/\1\2\3/"` + ver_date=`git log -n 1 --date=short --pretty=format:%ci | cut -d ' ' -f 1 | tr -d -` if echo $ver_date | grep '^[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9]$' 2>&1 >/dev/null; then true; else as_fn_error "failed to detect version date: check that git is in your path" "$LINENO" 5 fi @@ -2963,40 +2971,51 @@ GhcMinVersion2=`echo "$GhcMinVersion" | sed 's/^\\(.\\)$/0\\1/'` GhcCanonVersion="$GhcMajVersion$GhcMinVersion2" - fp_version1=$GhcVersion; fp_version2=6.10.2 -fp_save_IFS=$IFS; IFS='.' -while test x"$fp_version1" != x || test x"$fp_version2" != x -do + if test $GhcCanonVersion -ge 613; then ghc_ge_613=YES; else ghc_ge_613=NO; fi - set dummy $fp_version1; shift - fp_num1="" - test $# = 0 || { fp_num1="$1"; shift; } - test x"$fp_num1" = x && fp_num1="0" - fp_version1="$*" - set dummy $fp_version2; shift - fp_num2="" - test $# = 0 || { fp_num2="$1"; shift; } - test x"$fp_num2" = x && fp_num2="0" - fp_version2="$*" +if test $GhcCanonVersion -ge 701 +then + CC_STAGE0=`"$WithGhc" --info | grep "^ ,(\"C compiler command\"," | sed -e 's/.*","//' -e 's/")$//'` +else + CC_STAGE0='$(CC)' +fi - test "$fp_num1" = "$fp_num2" || break; -done -IFS=$fp_save_IFS -if test "$fp_num1" -ge "$fp_num2"; then : - ghc_ge_6102=YES + + +if test $GhcCanonVersion -ge 701 +then + AR_STAGE0=`"$WithGhc" --info | grep "^ ,(\"ar command\"," | sed -e 's/.*","//' -e 's/")$//'` else - ghc_ge_6102=NO + AR_STAGE0='$(AR)' fi - if test $GhcCanonVersion -ge 611; then ghc_ge_611=YES; else ghc_ge_611=NO; fi - if test $GhcCanonVersion -ge 613; then ghc_ge_613=YES; else ghc_ge_613=NO; fi - fi -if test "$BootingFromHc" = "NO" -a -d "$srcdir/compiler"; then + + +if test $GhcCanonVersion -ge 701 +then + AR_OPTS_STAGE0=`"$WithGhc" --info | grep "^ ,(\"ar flags\"," | sed -e 's/.*","//' -e 's/")$//'` +else + AR_OPTS_STAGE0='$(AR_OPTS)' +fi + + + +if test $GhcCanonVersion -ge 701 +then + ArSupportsAtFile_STAGE0=`"$WithGhc" --info | grep "^ ,(\"ar supports at file\"," | sed -e 's/.*","//' -e 's/")$//'` +else + ArSupportsAtFile_STAGE0='$(ArSupportsAtFile)' +fi + + +fi + +if test "$BootingFromHc" = "NO"; then if test "$WithGhc" = ""; then as_fn_error "GHC is required unless bootstrapping from .hc files." "$LINENO" 5 fi - fp_version1=$GhcVersion; fp_version2=6.10 + fp_version1=$GhcVersion; fp_version2=6.12 fp_save_IFS=$IFS; IFS='.' while test x"$fp_version1" != x || test x"$fp_version2" != x do @@ -3017,7 +3036,7 @@ done IFS=$fp_save_IFS if test "$fp_num1" -lt "$fp_num2"; then : - as_fn_error "GHC version 6.10 or later is required to compile GHC." "$LINENO" 5 + as_fn_error "GHC version 6.12 or later is required to compile GHC." "$LINENO" 5 fi if test `expr $GhcMinVersion % 2` = "1"; then if test "$EnableBootstrapWithDevelSnaphost" = "NO"; then @@ -3278,7 +3297,7 @@ hppa*) BuildArch="hppa" ;; - i386) + i386|i486|i586|i686) BuildArch="i386" ;; ia64) @@ -3327,7 +3346,18 @@ esac -BuildVendor="$build_vendor" + case "$build_vendor" in + pc|gentoo) # like i686-pc-linux-gnu and i686-gentoo-freebsd8 + BuildVendor="unknown" + ;; + softfloat) # like armv5tel-softfloat-linux-gnueabi + BuildVendor="unknown" + ;; + *) + #pass thru by default + BuildVendor="$build_vendor" + ;; + esac case "$build_os" in @@ -3338,6 +3368,9 @@ freebsd|netbsd|openbsd|dragonfly|osf1|osf3|hpux|linuxaout|kfreebsdgnu|freebsd2|solaris2|cygwin32|mingw32|darwin|gnu|nextstep2|nextstep3|sunos4|ultrix|irix|aix|haiku) BuildOS="$build_os" ;; + freebsd8) # like i686-gentoo-freebsd8 + BuildOS="freebsd" + ;; *) echo "Unknown OS $build_os" exit 1 @@ -3375,7 +3408,7 @@ hppa*) HostArch="hppa" ;; - i386) + i386|i486|i586|i686) HostArch="i386" ;; ia64) @@ -3424,7 +3457,18 @@ esac -HostVendor="$host_vendor" + case "$host_vendor" in + pc|gentoo) # like i686-pc-linux-gnu and i686-gentoo-freebsd8 + HostVendor="unknown" + ;; + softfloat) # like armv5tel-softfloat-linux-gnueabi + HostVendor="unknown" + ;; + *) + #pass thru by default + HostVendor="$host_vendor" + ;; + esac case "$host_os" in @@ -3435,6 +3479,9 @@ freebsd|netbsd|openbsd|dragonfly|osf1|osf3|hpux|linuxaout|kfreebsdgnu|freebsd2|solaris2|cygwin32|mingw32|darwin|gnu|nextstep2|nextstep3|sunos4|ultrix|irix|aix|haiku) HostOS="$host_os" ;; + freebsd8) # like i686-gentoo-freebsd8 + HostOS="freebsd" + ;; *) echo "Unknown OS $host_os" exit 1 @@ -3472,7 +3519,7 @@ hppa*) TargetArch="hppa" ;; - i386) + i386|i486|i586|i686) TargetArch="i386" ;; ia64) @@ -3521,7 +3568,18 @@ esac -TargetVendor="$target_vendor" + case "$target_vendor" in + pc|gentoo) # like i686-pc-linux-gnu and i686-gentoo-freebsd8 + TargetVendor="unknown" + ;; + softfloat) # like armv5tel-softfloat-linux-gnueabi + TargetVendor="unknown" + ;; + *) + #pass thru by default + TargetVendor="$target_vendor" + ;; + esac case "$target_os" in @@ -3532,6 +3590,9 @@ freebsd|netbsd|openbsd|dragonfly|osf1|osf3|hpux|linuxaout|kfreebsdgnu|freebsd2|solaris2|cygwin32|mingw32|darwin|gnu|nextstep2|nextstep3|sunos4|ultrix|irix|aix|haiku) TargetOS="$target_os" ;; + freebsd8) # like i686-gentoo-freebsd8 + TargetOS="freebsd" + ;; *) echo "Unknown OS $target_os" exit 1 @@ -3540,27 +3601,44 @@ fi - -exeext='' -soext='.so' -case $host in -*-unknown-cygwin32) - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: GHC does not support the Cygwin target at the moment" >&5 + windows=NO + exeext='' + soext='.so' + case $host in + *-unknown-cygwin32) + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: GHC does not support the Cygwin target at the moment" >&5 $as_echo "$as_me: WARNING: GHC does not support the Cygwin target at the moment" >&2;} - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: I'm assuming you wanted to build for i386-unknown-mingw32" >&5 + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: I'm assuming you wanted to build for i386-unknown-mingw32" >&5 $as_echo "$as_me: WARNING: I'm assuming you wanted to build for i386-unknown-mingw32" >&2;} - exit 1 - ;; -*-unknown-mingw32) - exeext='.exe' - soext='.dll' - ;; -i386-apple-darwin|powerpc-apple-darwin) - soext='.dylib' - ;; -x86_64-apple-darwin) - soext='.dylib' - ;; + exit 1 + ;; + *-unknown-mingw32) + windows=YES + exeext='.exe' + soext='.dll' + ;; + i386-apple-darwin|powerpc-apple-darwin) + soext='.dylib' + ;; + x86_64-apple-darwin) + soext='.dylib' + ;; + esac + + +# Testing if we shall enable shared libs support on Solaris. +# Anything older than SunOS 5.11 aka Solaris 11 (Express) is broken. + +SOLARIS_BROKEN_SHLD=NO + +case $host in + i386-*-solaris2) + # here we go with the test + MINOR=`uname -r|cut -d '.' -f 2-` + if test "$MINOR" -lt "11"; then + SOLARIS_BROKEN_SHLD=YES + fi + ;; esac checkArch() { @@ -3628,14 +3706,23 @@ # Verify that the installed (bootstrap) GHC is capable of generating # code for the requested build platform. -if test "$build" != "$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" +echo "GHC host : $HostPlatform" +echo "GHC target : $TargetPlatform" + + + @@ -3669,92 +3756,6 @@ -for ac_prog in nhc nhc98 -do - # Extract the first word of "$ac_prog", so it can be a program name with args. -set dummy $ac_prog; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if test "${ac_cv_path_NHC+set}" = set; then : - $as_echo_n "(cached) " >&6 -else - case $NHC in - [\\/]* | ?:[\\/]*) - ac_cv_path_NHC="$NHC" # Let the user override the test with a path. - ;; - *) - as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then - ac_cv_path_NHC="$as_dir/$ac_word$ac_exec_ext" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 - break 2 - fi -done - done -IFS=$as_save_IFS - - ;; -esac -fi -NHC=$ac_cv_path_NHC -if test -n "$NHC"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $NHC" >&5 -$as_echo "$NHC" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - - - test -n "$NHC" && break -done - -# Extract the first word of "hbc", so it can be a program name with args. -set dummy hbc; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if test "${ac_cv_path_HBC+set}" = set; then : - $as_echo_n "(cached) " >&6 -else - case $HBC in - [\\/]* | ?:[\\/]*) - ac_cv_path_HBC="$HBC" # Let the user override the test with a path. - ;; - *) - as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then - ac_cv_path_HBC="$as_dir/$ac_word$ac_exec_ext" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 - break 2 - fi -done - done -IFS=$as_save_IFS - - ;; -esac -fi -HBC=$ac_cv_path_HBC -if test -n "$HBC"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $HBC" >&5 -$as_echo "$HBC" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - - - # This uses GHC, so put it after the "GHC is required" check above: { $as_echo "$as_me:${as_lineno-$LINENO}: Building in-tree ghc-pwd" >&5 @@ -3809,6 +3810,7 @@ test inplace/mingw -ot ghc-tarballs/mingw/binutils*.tar.lzma || test inplace/mingw -ot ghc-tarballs/mingw/gcc-core*.tar.lzma || test inplace/mingw -ot ghc-tarballs/mingw/gcc-c++*.tar.lzma || + test inplace/mingw -ot ghc-tarballs/mingw/libgcc*.tar.gz || test inplace/mingw -ot ghc-tarballs/mingw/libgmp*.tar.gz || test inplace/mingw -ot ghc-tarballs/mingw/libmpc*.tar.gz || test inplace/mingw -ot ghc-tarballs/mingw/libmpfr*.tar.gz || @@ -3826,6 +3828,7 @@ tar --lzma -xf ../../ghc-tarballs/mingw/binutils*.tar.lzma && tar --lzma -xf ../../ghc-tarballs/mingw/gcc-core*.tar.lzma && tar --lzma -xf ../../ghc-tarballs/mingw/gcc-c++*.tar.lzma && + tar --lzma -xf ../../ghc-tarballs/mingw/libgcc*.tar.lzma && tar --lzma -xf ../../ghc-tarballs/mingw/libgmp*.tar.lzma && tar --lzma -xf ../../ghc-tarballs/mingw/libmpc*.tar.lzma && tar --lzma -xf ../../ghc-tarballs/mingw/libmpfr*.tar.lzma && @@ -3861,6 +3864,125 @@ fi + if test "$TargetOS_CPP" = "darwin" + then + { $as_echo "$as_me:${as_lineno-$LINENO}: checking XCode version" >&5 +$as_echo_n "checking XCode version... " >&6; } + XCodeVersion=`xcodebuild -version | grep Xcode | sed "s/Xcode //"` + # Old XCode versions don't actually give the XCode version + if test "$XCodeVersion" = "" + then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: not found (too old?)" >&5 +$as_echo "not found (too old?)" >&6; } + XCodeVersion1=0 + XCodeVersion2=0 + else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $XCodeVersion" >&5 +$as_echo "$XCodeVersion" >&6; } + XCodeVersion1=`echo "$XCodeVersion" | sed 's/\..*//'` + XCodeVersion2=`echo "$XCodeVersion" | sed 's/[^.]*\.\([^.]*\).*/\1/'` + { $as_echo "$as_me:${as_lineno-$LINENO}: XCode version component 1: $XCodeVersion1" >&5 +$as_echo "$as_me: XCode version component 1: $XCodeVersion1" >&6;} + { $as_echo "$as_me:${as_lineno-$LINENO}: XCode version component 2: $XCodeVersion2" >&5 +$as_echo "$as_me: XCode version component 2: $XCodeVersion2" >&6;} + fi + fi + + +SplitObjsBroken=NO +if test "$TargetOS_CPP" = "darwin" +then + # Split objects is broken (#4013) with XCode < 3.2 + if test "$XCodeVersion1" -lt 3 + then + SplitObjsBroken=YES + else + if test "$XCodeVersion1" -eq 3 + then + if test "$XCodeVersion2" -lt 2 + then + SplitObjsBroken=YES + fi + fi + fi +fi + + + + if test "$TargetOS_CPP" = "darwin" && + test "$XCodeVersion1" -ge 4 + then + # From Xcode 4, use 'gcc-4.2' to force the use of the gcc legacy + # backend (instead of the LLVM backend) + + +# Check whether --with-gcc-4.2 was given. +if test "${with_gcc_4_2+set}" = set; then : + withval=$with_gcc_4_2; + if test "$HostOS" = "mingw32" + then + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: Request to use $withval will be ignored" >&5 +$as_echo "$as_me: WARNING: Request to use $withval will be ignored" >&2;} + else + CC=$withval + fi + +else + + if test "$HostOS" != "mingw32" + then + # Extract the first word of "gcc-4.2", so it can be a program name with args. +set dummy gcc-4.2; ac_word=$2 +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 +$as_echo_n "checking for $ac_word... " >&6; } +if test "${ac_cv_path_CC+set}" = set; then : + $as_echo_n "(cached) " >&6 +else + case $CC in + [\\/]* | ?:[\\/]*) + ac_cv_path_CC="$CC" # Let the user override the test with a path. + ;; + *) + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +for as_dir in $PATH +do + IFS=$as_save_IFS + test -z "$as_dir" && as_dir=. + for ac_exec_ext in '' $ac_executable_extensions; do + if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then + ac_cv_path_CC="$as_dir/$ac_word$ac_exec_ext" + $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 + break 2 + fi +done + done +IFS=$as_save_IFS + + ;; +esac +fi +CC=$ac_cv_path_CC +if test -n "$CC"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5 +$as_echo "$CC" >&6; } +else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } +fi + + + if test -z "$CC" + then + as_fn_error "cannot find gcc-4.2 in your PATH, no idea how to link" "$LINENO" 5 + fi + fi + + +fi + + + else + # Check whether --with-gcc was given. if test "${with_gcc+set}" = set; then : @@ -3927,8 +4049,10 @@ fi -export CC -WhatGccIsCalled="$CC" + fi + export CC + WhatGccIsCalled="$CC" + @@ -4071,44 +4195,6 @@ NmCmd="$NM" -SplitObjsBroken=NO -if test "$TargetOS_CPP" = "darwin" -then - { $as_echo "$as_me:${as_lineno-$LINENO}: checking XCode version" >&5 -$as_echo_n "checking XCode version... " >&6; } - XCodeVersion=`xcodebuild -version | grep Xcode | sed "s/Xcode //"` - # Old XCode versions don't actually give the XCode version - if test "$XCodeVersion" = "" - then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: not found (too old?)" >&5 -$as_echo "not found (too old?)" >&6; } - SplitObjsBroken=YES - else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $XCodeVersion" >&5 -$as_echo "$XCodeVersion" >&6; } - XCodeVersion1=`echo "$XCodeVersion" | sed 's/\..*//'` - XCodeVersion2=`echo "$XCodeVersion" | sed 's/[^.]*\.\([^.]*\).*/\1/'` - { $as_echo "$as_me:${as_lineno-$LINENO}: XCode version component 1: $XCodeVersion1" >&5 -$as_echo "$as_me: XCode version component 1: $XCodeVersion1" >&6;} - { $as_echo "$as_me:${as_lineno-$LINENO}: XCode version component 2: $XCodeVersion2" >&5 -$as_echo "$as_me: XCode version component 2: $XCodeVersion2" >&6;} - # Split objects is broken (#4013) with XCode < 3.2 - if test "$XCodeVersion1" -lt 3 - then - SplitObjsBroken=YES - else - if test "$XCodeVersion1" -eq 3 - then - if test "$XCodeVersion2" -lt 2 - then - SplitObjsBroken=YES - fi - fi - fi - fi -fi - - # Check whether --with-macosx-deployment-target was given. if test "${with_macosx_deployment_target+set}" = set; then : @@ -5105,23 +5191,20 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu -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 as_fn_error "gcc is required" "$LINENO" 5 fi -GccLT34= +GccLT34=NO +GccLT46=NO { $as_echo "$as_me:${as_lineno-$LINENO}: checking version of gcc" >&5 $as_echo_n "checking version of gcc... " >&6; } if test "${fp_cv_gcc_version+set}" = set; then : $as_echo_n "(cached) " >&6 else - 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_version1=$fp_cv_gcc_version; fp_version2=3.0 + + fp_cv_gcc_version="`$CC -v 2>&1 | grep 'version ' | sed -e 's/.*version [^0-9]*\([0-9.]*\).*/\1/g'`" + fp_version1=$fp_cv_gcc_version; fp_version2=3.0 fp_save_IFS=$IFS; IFS='.' while test x"$fp_version1" != x || test x"$fp_version2" != x do @@ -5144,10 +5227,10 @@ if test "$fp_num1" -lt "$fp_num2"; then : as_fn_error "Need at least gcc version 3.0 (3.4+ recommended)" "$LINENO" 5 fi - # 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_version1=$fp_cv_gcc_version; fp_version2=3.4 + # 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_version1=$fp_cv_gcc_version; fp_version2=3.4 fp_save_IFS=$IFS; IFS='.' while test x"$fp_version1" != x || test x"$fp_version2" != x do @@ -5170,33 +5253,48 @@ if test "$fp_num1" -lt "$fp_num2"; then : GccLT34=YES fi - else - fp_cv_gcc_version="not-installed" - fi + fp_version1=$fp_cv_gcc_version; fp_version2=4.6 +fp_save_IFS=$IFS; IFS='.' +while test x"$fp_version1" != x || test x"$fp_version2" != x +do + + set dummy $fp_version1; shift + fp_num1="" + test $# = 0 || { fp_num1="$1"; shift; } + test x"$fp_num1" = x && fp_num1="0" + fp_version1="$*" + + set dummy $fp_version2; shift + fp_num2="" + test $# = 0 || { fp_num2="$1"; shift; } + test x"$fp_num2" = x && fp_num2="0" + fp_version2="$*" + + test "$fp_num1" = "$fp_num2" || break; +done +IFS=$fp_save_IFS +if test "$fp_num1" -lt "$fp_num2"; then : + GccLT46=YES +fi fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $fp_cv_gcc_version" >&5 $as_echo "$fp_cv_gcc_version" >&6; } -HaveGcc=$fp_have_gcc - GccVersion=$fp_cv_gcc_version + { $as_echo "$as_me:${as_lineno-$LINENO}: checking Setting up CFLAGS, LDFLAGS, IGNORE_LINKER_LD_FLAGS and CPPFLAGS" >&5 $as_echo_n "checking Setting up CFLAGS, LDFLAGS, IGNORE_LINKER_LD_FLAGS and CPPFLAGS... " >&6; } case $target in i386-apple-darwin) - # By default, gcc on OS X will generate SSE - # instructions, which need things 16-byte aligned, - # but we don't 16-byte align things. Thus drop - # back to generic i686 compatibility. Trac #2983. - CFLAGS="$CFLAGS -march=i686 -m32" - LDFLAGS="$LDFLAGS -march=i686 -m32" + CFLAGS="$CFLAGS -m32" + LDFLAGS="$LDFLAGS -m32" IGNORE_LINKER_LD_FLAGS="$IGNORE_LINKER_LD_FLAGS -arch i386" - CPPFLAGS="$CPPFLAGS -march=i686 -m32" + CPPFLAGS="$CPPFLAGS -m32" ;; x86_64-apple-darwin) CFLAGS="$CFLAGS -m64" @@ -5204,6 +5302,21 @@ IGNORE_LINKER_LD_FLAGS="$IGNORE_LINKER_LD_FLAGS -arch x86_64" CPPFLAGS="$CPPFLAGS -m64" ;; + alpha-*) + # For now, to suppress the gcc warning "call-clobbered + # register used for global register variable", we simply + # disable all warnings altogether using the -w flag. Oh well. + CFLAGS="$CFLAGS -w -mieee -D_REENTRANT" + LDFLAGS="$LDFLAGS -w -mieee -D_REENTRANT" + CPPFLAGS="$CPPFLAGS -w -mieee -D_REENTRANT" + ;; + hppa*) + # ___HPUX_SOURCE, not _HPUX_SOURCE, is #defined if -ansi! + # (very nice, but too bad the HP /usr/include files don't agree.) + CFLAGS="$CFLAGS -D_HPUX_SOURCE" + LDFLAGS="$LDFLAGS -D_HPUX_SOURCE" + CPPFLAGS="$CPPFLAGS -D_HPUX_SOURCE" + ;; esac # If gcc knows about the stack protector, turn it off. @@ -5222,14 +5335,10 @@ $as_echo_n "checking Setting up CONF_CC_OPTS_STAGE0, CONF_GCC_LINKER_OPTS_STAGE0, CONF_LD_LINKER_OPTS_STAGE0 and CONF_CPP_OPTS_STAGE0... " >&6; } case $build in i386-apple-darwin) - # By default, gcc on OS X will generate SSE - # instructions, which need things 16-byte aligned, - # but we don't 16-byte align things. Thus drop - # back to generic i686 compatibility. Trac #2983. - CONF_CC_OPTS_STAGE0="$CONF_CC_OPTS_STAGE0 -march=i686 -m32" - CONF_GCC_LINKER_OPTS_STAGE0="$CONF_GCC_LINKER_OPTS_STAGE0 -march=i686 -m32" + CONF_CC_OPTS_STAGE0="$CONF_CC_OPTS_STAGE0 -m32" + CONF_GCC_LINKER_OPTS_STAGE0="$CONF_GCC_LINKER_OPTS_STAGE0 -m32" CONF_LD_LINKER_OPTS_STAGE0="$CONF_LD_LINKER_OPTS_STAGE0 -arch i386" - CONF_CPP_OPTS_STAGE0="$CONF_CPP_OPTS_STAGE0 -march=i686 -m32" + CONF_CPP_OPTS_STAGE0="$CONF_CPP_OPTS_STAGE0 -m32" ;; x86_64-apple-darwin) CONF_CC_OPTS_STAGE0="$CONF_CC_OPTS_STAGE0 -m64" @@ -5237,6 +5346,21 @@ CONF_LD_LINKER_OPTS_STAGE0="$CONF_LD_LINKER_OPTS_STAGE0 -arch x86_64" CONF_CPP_OPTS_STAGE0="$CONF_CPP_OPTS_STAGE0 -m64" ;; + alpha-*) + # For now, to suppress the gcc warning "call-clobbered + # register used for global register variable", we simply + # disable all warnings altogether using the -w flag. Oh well. + CONF_CC_OPTS_STAGE0="$CONF_CC_OPTS_STAGE0 -w -mieee -D_REENTRANT" + CONF_GCC_LINKER_OPTS_STAGE0="$CONF_GCC_LINKER_OPTS_STAGE0 -w -mieee -D_REENTRANT" + CONF_CPP_OPTS_STAGE0="$CONF_CPP_OPTS_STAGE0 -w -mieee -D_REENTRANT" + ;; + hppa*) + # ___HPUX_SOURCE, not _HPUX_SOURCE, is #defined if -ansi! + # (very nice, but too bad the HP /usr/include files don't agree.) + CONF_CC_OPTS_STAGE0="$CONF_CC_OPTS_STAGE0 -D_HPUX_SOURCE" + CONF_GCC_LINKER_OPTS_STAGE0="$CONF_GCC_LINKER_OPTS_STAGE0 -D_HPUX_SOURCE" + CONF_CPP_OPTS_STAGE0="$CONF_CPP_OPTS_STAGE0 -D_HPUX_SOURCE" + ;; esac # If gcc knows about the stack protector, turn it off. @@ -5255,14 +5379,10 @@ $as_echo_n "checking Setting up CONF_CC_OPTS_STAGE1, CONF_GCC_LINKER_OPTS_STAGE1, CONF_LD_LINKER_OPTS_STAGE1 and CONF_CPP_OPTS_STAGE1... " >&6; } case $target in i386-apple-darwin) - # By default, gcc on OS X will generate SSE - # instructions, which need things 16-byte aligned, - # but we don't 16-byte align things. Thus drop - # back to generic i686 compatibility. Trac #2983. - CONF_CC_OPTS_STAGE1="$CONF_CC_OPTS_STAGE1 -march=i686 -m32" - CONF_GCC_LINKER_OPTS_STAGE1="$CONF_GCC_LINKER_OPTS_STAGE1 -march=i686 -m32" + CONF_CC_OPTS_STAGE1="$CONF_CC_OPTS_STAGE1 -m32" + CONF_GCC_LINKER_OPTS_STAGE1="$CONF_GCC_LINKER_OPTS_STAGE1 -m32" CONF_LD_LINKER_OPTS_STAGE1="$CONF_LD_LINKER_OPTS_STAGE1 -arch i386" - CONF_CPP_OPTS_STAGE1="$CONF_CPP_OPTS_STAGE1 -march=i686 -m32" + CONF_CPP_OPTS_STAGE1="$CONF_CPP_OPTS_STAGE1 -m32" ;; x86_64-apple-darwin) CONF_CC_OPTS_STAGE1="$CONF_CC_OPTS_STAGE1 -m64" @@ -5270,6 +5390,21 @@ CONF_LD_LINKER_OPTS_STAGE1="$CONF_LD_LINKER_OPTS_STAGE1 -arch x86_64" CONF_CPP_OPTS_STAGE1="$CONF_CPP_OPTS_STAGE1 -m64" ;; + alpha-*) + # For now, to suppress the gcc warning "call-clobbered + # register used for global register variable", we simply + # disable all warnings altogether using the -w flag. Oh well. + CONF_CC_OPTS_STAGE1="$CONF_CC_OPTS_STAGE1 -w -mieee -D_REENTRANT" + CONF_GCC_LINKER_OPTS_STAGE1="$CONF_GCC_LINKER_OPTS_STAGE1 -w -mieee -D_REENTRANT" + CONF_CPP_OPTS_STAGE1="$CONF_CPP_OPTS_STAGE1 -w -mieee -D_REENTRANT" + ;; + hppa*) + # ___HPUX_SOURCE, not _HPUX_SOURCE, is #defined if -ansi! + # (very nice, but too bad the HP /usr/include files don't agree.) + CONF_CC_OPTS_STAGE1="$CONF_CC_OPTS_STAGE1 -D_HPUX_SOURCE" + CONF_GCC_LINKER_OPTS_STAGE1="$CONF_GCC_LINKER_OPTS_STAGE1 -D_HPUX_SOURCE" + CONF_CPP_OPTS_STAGE1="$CONF_CPP_OPTS_STAGE1 -D_HPUX_SOURCE" + ;; esac # If gcc knows about the stack protector, turn it off. @@ -5289,14 +5424,10 @@ $as_echo_n "checking Setting up CONF_CC_OPTS_STAGE2, CONF_GCC_LINKER_OPTS_STAGE2, CONF_LD_LINKER_OPTS_STAGE2 and CONF_CPP_OPTS_STAGE2... " >&6; } case $target in i386-apple-darwin) - # By default, gcc on OS X will generate SSE - # instructions, which need things 16-byte aligned, - # but we don't 16-byte align things. Thus drop - # back to generic i686 compatibility. Trac #2983. - CONF_CC_OPTS_STAGE2="$CONF_CC_OPTS_STAGE2 -march=i686 -m32" - CONF_GCC_LINKER_OPTS_STAGE2="$CONF_GCC_LINKER_OPTS_STAGE2 -march=i686 -m32" + CONF_CC_OPTS_STAGE2="$CONF_CC_OPTS_STAGE2 -m32" + CONF_GCC_LINKER_OPTS_STAGE2="$CONF_GCC_LINKER_OPTS_STAGE2 -m32" CONF_LD_LINKER_OPTS_STAGE2="$CONF_LD_LINKER_OPTS_STAGE2 -arch i386" - CONF_CPP_OPTS_STAGE2="$CONF_CPP_OPTS_STAGE2 -march=i686 -m32" + CONF_CPP_OPTS_STAGE2="$CONF_CPP_OPTS_STAGE2 -m32" ;; x86_64-apple-darwin) CONF_CC_OPTS_STAGE2="$CONF_CC_OPTS_STAGE2 -m64" @@ -5304,6 +5435,21 @@ CONF_LD_LINKER_OPTS_STAGE2="$CONF_LD_LINKER_OPTS_STAGE2 -arch x86_64" CONF_CPP_OPTS_STAGE2="$CONF_CPP_OPTS_STAGE2 -m64" ;; + alpha-*) + # For now, to suppress the gcc warning "call-clobbered + # register used for global register variable", we simply + # disable all warnings altogether using the -w flag. Oh well. + CONF_CC_OPTS_STAGE2="$CONF_CC_OPTS_STAGE2 -w -mieee -D_REENTRANT" + CONF_GCC_LINKER_OPTS_STAGE2="$CONF_GCC_LINKER_OPTS_STAGE2 -w -mieee -D_REENTRANT" + CONF_CPP_OPTS_STAGE2="$CONF_CPP_OPTS_STAGE2 -w -mieee -D_REENTRANT" + ;; + hppa*) + # ___HPUX_SOURCE, not _HPUX_SOURCE, is #defined if -ansi! + # (very nice, but too bad the HP /usr/include files don't agree.) + CONF_CC_OPTS_STAGE2="$CONF_CC_OPTS_STAGE2 -D_HPUX_SOURCE" + CONF_GCC_LINKER_OPTS_STAGE2="$CONF_GCC_LINKER_OPTS_STAGE2 -D_HPUX_SOURCE" + CONF_CPP_OPTS_STAGE2="$CONF_CPP_OPTS_STAGE2 -D_HPUX_SOURCE" + ;; esac # If gcc knows about the stack protector, turn it off. @@ -5348,106 +5494,6 @@ if test "$fp_num1" -ge "$fp_num2"; then : fp_cv_gcc_extra_opts="$fp_cv_gcc_extra_opts -fwrapv" fi - case $TargetPlatform in - i386-*|x86_64-*) - fp_version1=$fp_cv_gcc_version; fp_version2=3.2 -fp_save_IFS=$IFS; IFS='.' -while test x"$fp_version1" != x || test x"$fp_version2" != x -do - - set dummy $fp_version1; shift - fp_num1="" - test $# = 0 || { fp_num1="$1"; shift; } - test x"$fp_num1" = x && fp_num1="0" - fp_version1="$*" - - set dummy $fp_version2; shift - fp_num2="" - test $# = 0 || { fp_num2="$1"; shift; } - test x"$fp_num2" = x && fp_num2="0" - fp_version2="$*" - - test "$fp_num1" = "$fp_num2" || break; -done -IFS=$fp_save_IFS -if test "$fp_num1" -ge "$fp_num2"; then : - fp_cv_gcc_extra_opts="$fp_cv_gcc_extra_opts -mno-omit-leaf-frame-pointer" -fi - fp_version1=$fp_cv_gcc_version; fp_version2=3.4 -fp_save_IFS=$IFS; IFS='.' -while test x"$fp_version1" != x || test x"$fp_version2" != x -do - - set dummy $fp_version1; shift - fp_num1="" - test $# = 0 || { fp_num1="$1"; shift; } - test x"$fp_num1" = x && fp_num1="0" - fp_version1="$*" - - set dummy $fp_version2; shift - fp_num2="" - test $# = 0 || { fp_num2="$1"; shift; } - test x"$fp_num2" = x && fp_num2="0" - fp_version2="$*" - - test "$fp_num1" = "$fp_num2" || break; -done -IFS=$fp_save_IFS -if test "$fp_num1" -ge "$fp_num2"; then : - fp_version1=$fp_cv_gcc_version; fp_version2=4.2 -fp_save_IFS=$IFS; IFS='.' -while test x"$fp_version1" != x || test x"$fp_version2" != x -do - - set dummy $fp_version1; shift - fp_num1="" - test $# = 0 || { fp_num1="$1"; shift; } - test x"$fp_num1" = x && fp_num1="0" - fp_version1="$*" - - set dummy $fp_version2; shift - fp_num2="" - test $# = 0 || { fp_num2="$1"; shift; } - test x"$fp_num2" = x && fp_num2="0" - fp_version2="$*" - - test "$fp_num1" = "$fp_num2" || break; -done -IFS=$fp_save_IFS -if test "$fp_num1" -ge "$fp_num2"; then : - fp_cv_gcc_extra_opts="$fp_cv_gcc_extra_opts -fno-toplevel-reorder" -else - fp_cv_gcc_extra_opts="$fp_cv_gcc_extra_opts -fno-unit-at-a-time" - -fi -fi - ;; - sparc-*-solaris2) - fp_version1=$fp_cv_gcc_version; fp_version2=4.2 -fp_save_IFS=$IFS; IFS='.' -while test x"$fp_version1" != x || test x"$fp_version2" != x -do - - set dummy $fp_version1; shift - fp_num1="" - test $# = 0 || { fp_num1="$1"; shift; } - test x"$fp_num1" = x && fp_num1="0" - fp_version1="$*" - - set dummy $fp_version2; shift - fp_num2="" - test $# = 0 || { fp_num2="$1"; shift; } - test x"$fp_num2" = x && fp_num2="0" - fp_version2="$*" - - test "$fp_num1" = "$fp_num2" || break; -done -IFS=$fp_save_IFS -if test "$fp_num1" -ge "$fp_num2"; then : - fp_cv_gcc_extra_opts="$fp_cv_gcc_extra_opts -fno-toplevel-reorder" -fi - ;; - esac fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $fp_cv_gcc_extra_opts" >&5 @@ -5607,6 +5653,31 @@ + + if test "$windows" = YES + then + SettingsCCompilerCommand='$topdir/../mingw/bin/gcc.exe' + SettingsCCompilerFlags='' + SettingsPerlCommand='$topdir/../perl/perl.exe' + SettingsDllWrapCommand='$topdir/../mingw/bin/dllwrap.exe' + SettingsWindresCommand='$topdir/../mingw/bin/windres.exe' + SettingsTouchCommand='$topdir/touchy.exe' + else + SettingsCCompilerCommand="$WhatGccIsCalled" + SettingsCCompilerFlags="$CONF_CC_OPTS_STAGE2" + SettingsPerlCommand="$PerlCmd" + SettingsDllWrapCommand="/bin/false" + SettingsWindresCommand="/bin/false" + SettingsTouchCommand='touch' + fi + + + + + + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for a working context diff" >&5 $as_echo_n "checking for a working context diff... " >&6; } if test "${fp_cv_context_diff+set}" = set; then : @@ -5982,41 +6053,11 @@ fi else - RANLIB=":" - -fi - + RANLIB="true" - -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $fp_prog_ar_raw supports -input" >&5 -$as_echo_n "checking whether $fp_prog_ar_raw supports -input... " >&6; } -if test "${fp_cv_prog_ar_supports_input+set}" = set; then : - $as_echo_n "(cached) " >&6 -else - fp_cv_prog_ar_supports_input=no -if test $fp_prog_ar_is_gnu = no; then - rm -f conftest* - touch conftest.lst - if { (eval "$fp_prog_ar_raw" $fp_prog_ar_args conftest.a -input conftest.lst) 2>conftest.er1 - fp_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - (exit $fp_status); } >/dev/null; then - test -s conftest.err || fp_cv_prog_ar_supports_input=yes - fi - rm -f conftest* -fi -fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $fp_cv_prog_ar_supports_input" >&5 -$as_echo "$fp_cv_prog_ar_supports_input" >&6; } -if test $fp_cv_prog_ar_supports_input = yes; then - ArSupportsInput="-input" -else - ArSupportsInput="" fi - { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether ln -s works" >&5 $as_echo_n "checking whether ln -s works... " >&6; } LN_S=$as_ln_s @@ -6535,52 +6576,6 @@ fi -# Extract the first word of "hasktags", so it can be a program name with args. -set dummy hasktags; ac_word=$2 -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 -$as_echo_n "checking for $ac_word... " >&6; } -if test "${ac_cv_path_HstagsCmd+set}" = set; then : - $as_echo_n "(cached) " >&6 -else - case $HstagsCmd in - [\\/]* | ?:[\\/]*) - ac_cv_path_HstagsCmd="$HstagsCmd" # Let the user override the test with a path. - ;; - *) - as_save_IFS=$IFS; IFS=$PATH_SEPARATOR -for as_dir in $PATH -do - IFS=$as_save_IFS - test -z "$as_dir" && as_dir=. - for ac_exec_ext in '' $ac_executable_extensions; do - if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then - ac_cv_path_HstagsCmd="$as_dir/$ac_word$ac_exec_ext" - $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5 - break 2 - fi -done - done -IFS=$as_save_IFS - - ;; -esac -fi -HstagsCmd=$ac_cv_path_HstagsCmd -if test -n "$HstagsCmd"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $HstagsCmd" >&5 -$as_echo "$HstagsCmd" >&6; } -else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 -$as_echo "no" >&6; } -fi - - -if test -z "$HstagsCmd"; then - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cannot find hasktags in your PATH, you will not be able to build the tags" >&5 -$as_echo "$as_me: WARNING: cannot find hasktags in your PATH, you will not be able to build the tags" >&2;} -fi - - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for ghc-pkg matching $WithGhc" >&5 $as_echo_n "checking for ghc-pkg matching $WithGhc... " >&6; } if test "${fp_cv_matching_ghc_pkg+set}" = set; then : @@ -8462,9 +8457,9 @@ fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for bfd_init in -lbfd" >&5 -$as_echo_n "checking for bfd_init in -lbfd... " >&6; } -if test "${ac_cv_lib_bfd_bfd_init+set}" = set; then : +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for bfd_uncompress_section_contents in -lbfd" >&5 +$as_echo_n "checking for bfd_uncompress_section_contents in -lbfd... " >&6; } +if test "${ac_cv_lib_bfd_bfd_uncompress_section_contents+set}" = set; then : $as_echo_n "(cached) " >&6 else ac_check_lib_save_LIBS=$LIBS @@ -8478,27 +8473,27 @@ #ifdef __cplusplus extern "C" #endif -char bfd_init (); +char bfd_uncompress_section_contents (); int main () { -return bfd_init (); +return bfd_uncompress_section_contents (); ; return 0; } _ACEOF if ac_fn_c_try_link "$LINENO"; then : - ac_cv_lib_bfd_bfd_init=yes + ac_cv_lib_bfd_bfd_uncompress_section_contents=yes else - ac_cv_lib_bfd_bfd_init=no + ac_cv_lib_bfd_bfd_uncompress_section_contents=no fi rm -f core conftest.err conftest.$ac_objext \ conftest$ac_exeext conftest.$ac_ext LIBS=$ac_check_lib_save_LIBS fi -{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_bfd_bfd_init" >&5 -$as_echo "$ac_cv_lib_bfd_bfd_init" >&6; } -if test "x$ac_cv_lib_bfd_bfd_init" = x""yes; then : +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_bfd_bfd_uncompress_section_contents" >&5 +$as_echo "$ac_cv_lib_bfd_bfd_uncompress_section_contents" >&6; } +if test "x$ac_cv_lib_bfd_bfd_uncompress_section_contents" = x""yes; then : cat >>confdefs.h <<_ACEOF #define HAVE_LIBBFD 1 _ACEOF @@ -9472,6 +9467,30 @@ +{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether ld understands --build-id" >&5 +$as_echo_n "checking whether ld understands --build-id... " >&6; } +if test "${fp_cv_ld_build_id+set}" = set; then : + $as_echo_n "(cached) " >&6 +else + echo 'foo() {}' > conftest.c +${CC-cc} -c conftest.c +if ${LdCmd} -r --build-id=none -o conftest2.o conftest.o > /dev/null 2>&1; then + fp_cv_ld_build_id=yes +else + fp_cv_ld_build_id=no +fi +rm -rf conftest* +fi +{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $fp_cv_ld_build_id" >&5 +$as_echo "$fp_cv_ld_build_id" >&6; } +if test "$fp_cv_ld_build_id" = yes; then + LdHasBuildId=YES +else + LdHasBuildId=NO +fi + + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for .subsections_via_symbols" >&5 @@ -9530,6 +9549,24 @@ rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext CFLAGS="$CFLAGS2" + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether __attribute__((visibility(\"hidden\"))) is supported" >&5 +$as_echo_n "checking whether __attribute__((visibility(\"hidden\"))) is supported... " >&6; } + echo '__attribute__((visibility("hidden"))) void foo(void) {}' > conftest.c + if $CC -Wall -Werror -c conftest.c > /dev/null 2>&1 + then + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 +$as_echo "yes" >&6; } + +$as_echo "#define HAS_VISIBILITY_HIDDEN 1" >>confdefs.h + + else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5 +$as_echo "no" >&6; } + fi + rm -f conftest.c conftest.o + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for clock_gettime in -lrt" >&5 $as_echo_n "checking for clock_gettime in -lrt... " >&6; } if test "${ac_cv_lib_rt_clock_gettime+set}" = set; then : @@ -9951,15 +9988,18 @@ -LIBRARY_base_VERSION=`grep -i "^version:" libraries/base/base.cabal | sed "s/.* //"` +dir=base +LIBRARY_base_VERSION=`grep -i "^version:" libraries/${dir}/base.cabal | sed "s/.* //"` -LIBRARY_Cabal_VERSION=`grep -i "^version:" libraries/Cabal/Cabal.cabal | sed "s/.* //"` +dir=Cabal/cabal +LIBRARY_Cabal_VERSION=`grep -i "^version:" libraries/${dir}/Cabal.cabal | sed "s/.* //"` -LIBRARY_ghc_prim_VERSION=`grep -i "^version:" libraries/ghc-prim/ghc-prim.cabal | sed "s/.* //"` +dir=ghc-prim +LIBRARY_ghc_prim_VERSION=`grep -i "^version:" libraries/${dir}/ghc-prim.cabal | sed "s/.* //"` LIBRARY_ghc_VERSION="$ProjectVersion" @@ -9969,7 +10009,7 @@ as_fn_error "compiler/ghc.cabal.in contains tab characters; please remove them" "$LINENO" 5 fi -ac_config_files="$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="$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="$ac_config_commands mk/stamp-h" @@ -10479,7 +10519,7 @@ # report actual input values of CONFIG_FILES etc. instead of their # values after options handling. ac_log=" -This file was extended by The Glorious Glasgow Haskell Compilation System $as_me 7.0.3, which was +This file was extended by The Glorious Glasgow Haskell Compilation System $as_me 7.2.1, which was generated by GNU Autoconf 2.65. Invocation command line was CONFIG_FILES = $CONFIG_FILES @@ -10545,7 +10585,7 @@ cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" ac_cs_version="\\ -The Glorious Glasgow Haskell Compilation System config.status 7.0.3 +The Glorious Glasgow Haskell Compilation System config.status 7.2.1 configured by $0, generated by GNU Autoconf 2.65, with options \\"\$ac_cs_config\\" @@ -10669,7 +10709,7 @@ "ghc/ghc-bin.cabal") CONFIG_FILES="$CONFIG_FILES ghc/ghc-bin.cabal" ;; "utils/runghc/runghc.cabal") CONFIG_FILES="$CONFIG_FILES utils/runghc/runghc.cabal" ;; "ghc.spec") CONFIG_FILES="$CONFIG_FILES ghc.spec" ;; - "extra-gcc-opts") CONFIG_FILES="$CONFIG_FILES extra-gcc-opts" ;; + "settings") CONFIG_FILES="$CONFIG_FILES settings" ;; "docs/users_guide/ug-book.xml") CONFIG_FILES="$CONFIG_FILES docs/users_guide/ug-book.xml" ;; "docs/users_guide/ug-ent.xml") CONFIG_FILES="$CONFIG_FILES docs/users_guide/ug-ent.xml" ;; "docs/index.html") CONFIG_FILES="$CONFIG_FILES docs/index.html" ;; diff -Nru ghc-7.0.3/configure.ac ghc-7.2.1/configure.ac --- ghc-7.0.3/configure.ac 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/configure.ac 2011-08-07 17:10:05.000000000 +0000 @@ -13,7 +13,7 @@ # see what flags are available. (Better yet, read the documentation!) # -AC_INIT([The Glorious Glasgow Haskell Compilation System], [7.0.3], [glasgow-haskell-bugs@haskell.org], [ghc]) +AC_INIT([The Glorious Glasgow Haskell Compilation System], [7.2.1], [glasgow-haskell-bugs@haskell.org], [ghc]) # Set this to YES for a released version, otherwise NO : ${RELEASE=YES} @@ -130,22 +130,22 @@ AC_SUBST(GhcPatchLevel)dnl GhcMinVersion2=`echo "$GhcMinVersion" | sed 's/^\\(.\\)$/0\\1/'` GhcCanonVersion="$GhcMajVersion$GhcMinVersion2" - FP_COMPARE_VERSIONS($GhcVersion,[-ge],[6.10.2], - [ghc_ge_6102=YES], [ghc_ge_6102=NO]) - if test $GhcCanonVersion -ge 611; then ghc_ge_611=YES; else ghc_ge_611=NO; fi if test $GhcCanonVersion -ge 613; then ghc_ge_613=YES; else ghc_ge_613=NO; fi - AC_SUBST(ghc_ge_6102)dnl - AC_SUBST(ghc_ge_611)dnl AC_SUBST(ghc_ge_613)dnl + + BOOTSTRAPPING_GHC_INFO_FIELD([CC_STAGE0],[C compiler command],['$(CC)']) + BOOTSTRAPPING_GHC_INFO_FIELD([AR_STAGE0],[ar command],['$(AR)']) + BOOTSTRAPPING_GHC_INFO_FIELD([AR_OPTS_STAGE0],[ar flags],['$(AR_OPTS)']) + BOOTSTRAPPING_GHC_INFO_FIELD([ArSupportsAtFile_STAGE0],[ar supports at file],['$(ArSupportsAtFile)']) 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 - FP_COMPARE_VERSIONS([$GhcVersion],[-lt],[6.10], - [AC_MSG_ERROR([GHC version 6.10 or later is required to compile GHC.])])dnl + FP_COMPARE_VERSIONS([$GhcVersion],[-lt],[6.12], + [AC_MSG_ERROR([GHC version 6.12 or later is required to compile GHC.])])dnl if test `expr $GhcMinVersion % 2` = "1"; then if test "$EnableBootstrapWithDevelSnaphost" = "NO"; then @@ -207,24 +207,19 @@ FPTOOLS_SET_PLATFORM_VARS -exeext='' -soext='.so' +# Testing if we shall enable shared libs support on Solaris. +# Anything older than SunOS 5.11 aka Solaris 11 (Express) is broken. + +SOLARIS_BROKEN_SHLD=NO + case $host in -*-unknown-cygwin32) - AC_MSG_WARN([GHC does not support the Cygwin target at the moment]) - AC_MSG_WARN([I'm assuming you wanted to build for i386-unknown-mingw32]) - exit 1 - ;; -*-unknown-mingw32) - exeext='.exe' - soext='.dll' - ;; -i386-apple-darwin|powerpc-apple-darwin) - soext='.dylib' - ;; -x86_64-apple-darwin) - soext='.dylib' - ;; + i386-*-solaris2) + # here we go with the test + MINOR=`uname -r|cut -d '.' -f 2-` + if test "$MINOR" -lt "11"; then + SOLARIS_BROKEN_SHLD=YES + fi + ;; esac checkArch() { @@ -292,14 +287,21 @@ # Verify that the installed (bootstrap) GHC is capable of generating # code for the requested build platform. -if test "$build" != "$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" +echo "GHC host : $HostPlatform" +echo "GHC target : $TargetPlatform" + AC_SUBST(BuildPlatform) AC_SUBST(HostPlatform) AC_SUBST(TargetPlatform) @@ -322,6 +324,8 @@ AC_SUBST(exeext) AC_SUBST(soext) +AC_SUBST(SOLARIS_BROKEN_SHLD) + AC_ARG_WITH(hc, [AC_HELP_STRING([--with-hc=ARG], [Use ARG as the path to the compiler for compiling ordinary @@ -331,9 +335,6 @@ ) AC_SUBST(WithHc) -AC_PATH_PROGS(NHC,nhc nhc98) -AC_PATH_PROG(HBC,hbc) - # This uses GHC, so put it after the "GHC is required" check above: FP_INTREE_GHC_PWD FP_FIND_ROOT @@ -353,6 +354,7 @@ test inplace/mingw -ot ghc-tarballs/mingw/binutils*.tar.lzma || test inplace/mingw -ot ghc-tarballs/mingw/gcc-core*.tar.lzma || test inplace/mingw -ot ghc-tarballs/mingw/gcc-c++*.tar.lzma || + test inplace/mingw -ot ghc-tarballs/mingw/libgcc*.tar.gz || test inplace/mingw -ot ghc-tarballs/mingw/libgmp*.tar.gz || test inplace/mingw -ot ghc-tarballs/mingw/libmpc*.tar.gz || test inplace/mingw -ot ghc-tarballs/mingw/libmpfr*.tar.gz || @@ -369,6 +371,7 @@ tar --lzma -xf ../../ghc-tarballs/mingw/binutils*.tar.lzma && tar --lzma -xf ../../ghc-tarballs/mingw/gcc-core*.tar.lzma && tar --lzma -xf ../../ghc-tarballs/mingw/gcc-c++*.tar.lzma && + tar --lzma -xf ../../ghc-tarballs/mingw/libgcc*.tar.lzma && tar --lzma -xf ../../ghc-tarballs/mingw/libgmp*.tar.lzma && tar --lzma -xf ../../ghc-tarballs/mingw/libmpc*.tar.lzma && tar --lzma -xf ../../ghc-tarballs/mingw/libmpfr*.tar.lzma && @@ -400,60 +403,43 @@ fi fi -dnl ** Which gcc to use? -dnl -------------------------------------------------------------- -FP_ARG_WITH_PATH_GNU_PROG([CC], [gcc]) -export CC -WhatGccIsCalled="$CC" -AC_SUBST(WhatGccIsCalled) - -dnl ** Which ld to use? -dnl -------------------------------------------------------------- -FP_ARG_WITH_PATH_GNU_PROG([LD], [ld]) -LdCmd="$LD" -AC_SUBST([LdCmd]) - -dnl ** Which nm to use? -dnl -------------------------------------------------------------- -FP_ARG_WITH_PATH_GNU_PROG([NM], [nm]) -NmCmd="$NM" -AC_SUBST([NmCmd]) +XCODE_VERSION() SplitObjsBroken=NO if test "$TargetOS_CPP" = "darwin" then - AC_MSG_CHECKING(XCode version) - XCodeVersion=`xcodebuild -version | grep Xcode | sed "s/Xcode //"` - # Old XCode versions don't actually give the XCode version - if test "$XCodeVersion" = "" + # Split objects is broken (#4013) with XCode < 3.2 + if test "$XCodeVersion1" -lt 3 then - AC_MSG_RESULT(not found (too old?)) SplitObjsBroken=YES else - AC_MSG_RESULT($XCodeVersion) - XCodeVersion1=`echo "$XCodeVersion" | sed 's/\..*//'` -changequote(, )dnl - XCodeVersion2=`echo "$XCodeVersion" | sed 's/[^.]*\.\([^.]*\).*/\1/'` -changequote([, ])dnl - AC_MSG_NOTICE(XCode version component 1: $XCodeVersion1) - AC_MSG_NOTICE(XCode version component 2: $XCodeVersion2) - # Split objects is broken (#4013) with XCode < 3.2 - if test "$XCodeVersion1" -lt 3 + if test "$XCodeVersion1" -eq 3 then - SplitObjsBroken=YES - else - if test "$XCodeVersion1" -eq 3 + if test "$XCodeVersion2" -lt 2 then - if test "$XCodeVersion2" -lt 2 - then - SplitObjsBroken=YES - fi + SplitObjsBroken=YES fi fi fi fi AC_SUBST([SplitObjsBroken]) +dnl ** Which gcc to use? +dnl -------------------------------------------------------------- +FIND_GCC() + +dnl ** Which ld to use? +dnl -------------------------------------------------------------- +FP_ARG_WITH_PATH_GNU_PROG([LD], [ld]) +LdCmd="$LD" +AC_SUBST([LdCmd]) + +dnl ** Which nm to use? +dnl -------------------------------------------------------------- +FP_ARG_WITH_PATH_GNU_PROG([NM], [nm]) +NmCmd="$NM" +AC_SUBST([NmCmd]) + dnl ** Mac OS X: explicit deployment target dnl -------------------------------------------------------------- AC_ARG_WITH([macosx-deployment-target], @@ -521,7 +507,7 @@ 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]) @@ -547,6 +533,8 @@ AC_SUBST(CONF_CPP_OPTS_STAGE1) AC_SUBST(CONF_CPP_OPTS_STAGE2) +FP_SETTINGS + dnl ** figure out how to do context diffs FP_PROG_CONTEXT_DIFF @@ -562,7 +550,6 @@ 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 @@ -608,8 +595,6 @@ FP_DOCBOOK_XSL FP_PROG_DBLATEX -FP_PROG_HSTAGS - dnl ** check for ghc-pkg command FP_PROG_GHC_PKG @@ -762,7 +747,7 @@ dnl ** check whether this machine has BFD and liberty installed (used for debugging) dnl the order of these tests matters: bfd needs liberty AC_CHECK_LIB(iberty, xmalloc) -AC_CHECK_LIB(bfd, bfd_init) +AC_CHECK_LIB(bfd, bfd_uncompress_section_contents) dnl ################################################################ dnl Check for libraries @@ -800,6 +785,7 @@ dnl ** check for ld, whether it has an -x option, and if it is GNU ld FP_PROG_LD_X FP_PROG_LD_IS_GNU +FP_PROG_LD_BUILD_ID dnl ** check for Apple-style dead-stripping support dnl (.subsections-via-symbols assembler directive) @@ -832,6 +818,8 @@ [AC_MSG_RESULT(no)]) CFLAGS="$CFLAGS2" +FP_VISIBILITY_HIDDEN + dnl ** check for librt AC_CHECK_LIB(rt, clock_gettime) AC_CHECK_FUNCS(clock_gettime timer_create timer_settime) @@ -903,7 +891,7 @@ AC_SUBST(BUILD_DOCBOOK_PDF) LIBRARY_VERSION(base) -LIBRARY_VERSION(Cabal) +LIBRARY_VERSION(Cabal, Cabal/cabal) LIBRARY_VERSION(ghc-prim) LIBRARY_ghc_VERSION="$ProjectVersion" AC_SUBST(LIBRARY_ghc_VERSION) @@ -912,7 +900,7 @@ 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 -Nru ghc-7.0.3/debian/changelog ghc-7.2.1/debian/changelog --- ghc-7.0.3/debian/changelog 2011-06-19 11:56:18.000000000 +0000 +++ ghc-7.2.1/debian/changelog 2011-08-24 20:30:57.000000000 +0000 @@ -1,8 +1,56 @@ -ghc (7.0.3-2~ppa1) natty; urgency=low +ghc (7.2.1-1~ppa1) natty; urgency=low * Backport to natty - -- Stefan Roggensack Sun, 19 Jun 2011 13:56:04 +0200 + -- Stefan Roggensack Wed, 24 Aug 2011 22:30:40 +0200 + +ghc (7.2.1-1) experimental; urgency=low + + * New upstream release. + + -- Joachim Breitner Tue, 23 Aug 2011 20:58:31 +0200 + +ghc (7.2.0.20110728-1) experimental; urgency=low + + * Remove ghc-doc dependency on ghc, it did not have the desired effect. + Instead call ghc-pkg recache in ghc-doc’s trigger as well. + * Install 7.2.1-rc1 to experimental. + * Undo the symlink-workarounds introduced in 7.0.4-3. The -doc work-around + is still needed, as the haddock interface version did not change. + + -- Joachim Breitner Sat, 06 Aug 2011 19:50:04 +0200 + +ghc (7.0.4-4) unstable; urgency=low + + * Let ghc-doc depend on ghc. It already does via ghc-haddock, making this + explicit ensures that the triggers run in the right order. + * debian/patches/hash-version-number: Include the upstream version number in + the ABI hash. We do need to recompile everything, even after a minor ghc + upgrade. This allows to use the same mechanism to ensure correctness and + detect that we need to recompile something as for other kind of + recompilations. (Closes: #633828) + + -- Joachim Breitner Sat, 16 Jul 2011 11:23:09 +0200 + +ghc (7.0.4-3) unstable; urgency=low + + * Employ similar symlink work-around to merge /var/lib/ghc-*/package.conf.d + into /var/lib/ghc/package.conf.d. Also remove version number from + /usr/lib/ghc path. + + -- Joachim Breitner Mon, 11 Jul 2011 13:13:45 +0200 + +ghc (7.0.4-2) unstable; urgency=low + + * Fix ghc-ghci existance check logic + + -- Joachim Breitner Sun, 10 Jul 2011 15:23:55 +0200 + +ghc (7.0.4-1) unstable; urgency=low + + * New upstream release (Closes: #622731) + + -- Joachim Breitner Sat, 09 Jul 2011 19:50:41 +0200 ghc (7.0.3-2) unstable; urgency=low diff -Nru ghc-7.0.3/debian/Dh_Haskell.sh ghc-7.2.1/debian/Dh_Haskell.sh --- ghc-7.0.3/debian/Dh_Haskell.sh 2011-04-09 11:36:49.000000000 +0000 +++ ghc-7.2.1/debian/Dh_Haskell.sh 2011-07-11 10:39:32.000000000 +0000 @@ -192,7 +192,7 @@ *) ;; esac - for f in debian/$pkg/var/lib/ghc-*/package.conf.d/*.conf ; do + for f in debian/$pkg/var/lib/ghc/package.conf.d/*.conf ; do if [ -f "$f" ] ; then echo $f echo " " diff -Nru ghc-7.0.3/debian/gen_contents_index ghc-7.2.1/debian/gen_contents_index --- ghc-7.0.3/debian/gen_contents_index 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/debian/gen_contents_index 2011-07-09 08:25:03.000000000 +0000 @@ -0,0 +1,60 @@ +#! /usr/bin/perl +# gen_contents_index, written for Debian by Kari Pahula +# Copyright 2009 Kari Pahula +# Licensed under BSD3, see /usr/share/common-licenses/BSD + +my @ifaces; +my %pkgs; + +# Add everything from the global Cabal registry to index. +if (-e '/usr/bin/ghc-pkg') { + open CABAL, 'ghc-pkg dump --global |' or warn "ghc-pkg dump failed: $!"; + addInfo (\*CABAL, \%pkgs, \@ifaces); + close CABAL; +} + +exec ('haddock', '--gen-index', '--gen-contents', + '-o', '/usr/share/doc/ghc-doc/html/libraries/', + '-t'. 'Haskell Hierarchical Libraries', + '-p', '/usr/share/doc/ghc-doc/html/libraries/prologue.txt', + @ifaces); + +sub addInfo { + my $fh = shift; + my %dat; + while (<$fh>) { + if (/^name: (.*)/) { + $dat{pkg} = $1; + } elsif (/^version: (.*)/) { + $dat{ver} = $1; + } elsif (/^haddock-interfaces: (.*)/) { + $dat{ifaces} = $1; + } elsif (/^haddock-html: (.*)/) { + $dat{html} = $1; + } elsif (/^---/) { + process(\%dat, @_); + %dat = (); + } + } + process(\%dat, @_); +} + +sub process { + my $dat = shift; + my $pkgs = shift; + my $ifaces = shift; + my $path; + return undef if $$dat{pkg} eq 'ghc'; + my $p = $$dat{pkg}.'-'.$$dat{ver}; + return undef if (exists $$pkgs{$p}); + if ($$dat{html} =~ m,^/usr/share/doc/ghc-doc/html/libraries/(.*),) { + $path = $1; + } elsif ($$dat{html} =~ m,^/usr/share/doc/([^/]*-doc/html/.*),) { + $path = "../../../$1"; + } + + if (defined $path && -r $$dat{ifaces}) { + $$pkgs{$p} = 1; + push @ifaces, "--read-interface=$path,$$dat{ifaces}"; + } +} diff -Nru ghc-7.0.3/debian/gen_contents_index.in ghc-7.2.1/debian/gen_contents_index.in --- ghc-7.0.3/debian/gen_contents_index.in 2011-04-09 11:36:49.000000000 +0000 +++ ghc-7.2.1/debian/gen_contents_index.in 1970-01-01 00:00:00.000000000 +0000 @@ -1,60 +0,0 @@ -#! /usr/bin/perl -# gen_contents_index, written for Debian by Kari Pahula -# Copyright 2009 Kari Pahula -# Licensed under BSD3, see /usr/share/common-licenses/BSD - -my @ifaces; -my %pkgs; - -# Add everything from the global Cabal registry to index. -if (-e '/usr/bin/ghc-pkg') { - open CABAL, 'ghc-pkg dump --global |' or warn "ghc-pkg dump failed: $!"; - addInfo (\*CABAL, \%pkgs, \@ifaces); - close CABAL; -} - -exec ('haddock', '--gen-index', '--gen-contents', - '-o', '/usr/share/doc/ghc-doc/html/libraries/', - '-t'. 'Haskell Hierarchical Libraries', - '-p', '/usr/share/doc/ghc-doc/html/libraries/prologue.txt', - @ifaces); - -sub addInfo { - my $fh = shift; - my %dat; - while (<$fh>) { - if (/^name: (.*)/) { - $dat{pkg} = $1; - } elsif (/^version: (.*)/) { - $dat{ver} = $1; - } elsif (/^haddock-interfaces: (.*)/) { - $dat{ifaces} = $1; - } elsif (/^haddock-html: (.*)/) { - $dat{html} = $1; - } elsif (/^---/) { - process(\%dat, @_); - %dat = (); - } - } - process(\%dat, @_); -} - -sub process { - my $dat = shift; - my $pkgs = shift; - my $ifaces = shift; - my $path; - return undef if $$dat{pkg} eq 'ghc'; - my $p = $$dat{pkg}.'-'.$$dat{ver}; - return undef if (exists $$pkgs{$p}); - if ($$dat{html} =~ m,^/usr/share/doc/ghc-doc/html/libraries/(.*),) { - $path = $1; - } elsif ($$dat{html} =~ m,^/usr/share/doc/([^/]*-doc/html/.*),) { - $path = "../../../$1"; - } - - if (defined $path && -r $$dat{ifaces}) { - $$pkgs{$p} = 1; - push @ifaces, "--read-interface=$path,$$dat{ifaces}"; - } -} diff -Nru ghc-7.0.3/debian/ghc-doc.postinst ghc-7.2.1/debian/ghc-doc.postinst --- ghc-7.0.3/debian/ghc-doc.postinst 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/debian/ghc-doc.postinst 2011-07-30 14:14:41.000000000 +0000 @@ -0,0 +1,60 @@ +#! /bin/sh +# postinst script for ghc-doc +# +set -e + +# summary of how this script can be called: +# * `configure' +# * `abort-upgrade' +# * `abort-remove' `in-favour' +# +# * `abort-deconfigure' `in-favour' +# `removing' +# +# for details, see /usr/doc/packaging-manual/ +# +# quoting from the policy: +# Any necessary prompting should almost always be confined to the +# post-installation script, and should be protected with a conditional +# so that unnecessary prompting doesn't happen if a package's +# installation fails and the `postinst' is called with `abort-upgrade', +# `abort-remove' or `abort-deconfigure'. + +case "$1" in + triggered|configure) + # Older versions of haskell_devscripts installed .haddock files in + # ghc-version-dependent paths. We thus merge them here using symbolic + # links. Luckily, dpkg will cleanly remove the symlinks when the last + # broken package is deinstalled. + # This can be removed once all packages have been rebuilt from source + # with a version of haskell-devscripts that installs into + # /usr/lib/ghc-doc/haddock/ + for path in /usr/lib/ghc-7.0.2/haddock /usr/lib/ghc-7.0.3/haddock + do + if [ -d $path -a ! -L $path ] + then + echo "Turning $path into a symbolic link to /usr/lib/ghc-doc/haddock/" + # This line should successfully do nothing for an empty directory + find $path -maxdepth 1 -mindepth 1 -print0 | xargs -0 -r mv -t /usr/lib/ghc-doc/haddock/ + rmdir $path + ln -s ../ghc-doc/haddock $path + fi + done + + if test -x /usr/lib/ghc/bin/ghc-pkg; then /usr/lib/ghc/bin/ghc-pkg recache --global; fi + /usr/lib/ghc-doc/gen_contents_index + ;; + abort-upgrade|abort-remove|abort-deconfigure) + ;; + *) + echo "postinst called with unknown argument \`$1'" >&2 + exit 0 + ;; +esac + +# dh_installdeb will replace this with shell code automatically +# generated by other debhelper scripts. + +#DEBHELPER# + +exit 0 diff -Nru ghc-7.0.3/debian/ghc-doc.postinst.in ghc-7.2.1/debian/ghc-doc.postinst.in --- ghc-7.0.3/debian/ghc-doc.postinst.in 2011-06-17 14:40:03.000000000 +0000 +++ ghc-7.2.1/debian/ghc-doc.postinst.in 1970-01-01 00:00:00.000000000 +0000 @@ -1,59 +0,0 @@ -#! /bin/sh -# postinst script for ghc-doc -# -set -e - -# summary of how this script can be called: -# * `configure' -# * `abort-upgrade' -# * `abort-remove' `in-favour' -# -# * `abort-deconfigure' `in-favour' -# `removing' -# -# for details, see /usr/doc/packaging-manual/ -# -# quoting from the policy: -# Any necessary prompting should almost always be confined to the -# post-installation script, and should be protected with a conditional -# so that unnecessary prompting doesn't happen if a package's -# installation fails and the `postinst' is called with `abort-upgrade', -# `abort-remove' or `abort-deconfigure'. - -case "$1" in - triggered|configure) - # Older versions of haskell_devscripts installed .haddock files in - # ghc-version-dependent paths. We thus merge them here using symbolic - # links. Luckily, dpkg will cleanly remove the symlinks when the last - # broken package is deinstalled. - # This can be removed once all packages have been rebuilt from source - # with a version of haskell-devscripts that installs into - # /usr/lib/ghc-doc/haddock/ - for path in /usr/lib/ghc-7.0.2/haddock /usr/lib/ghc-7.0.3/haddock - do - if [ -d $path -a ! -L $path ] - then - echo "Turning $path into a symbolic link to /usr/lib/ghc-doc/haddock/" - # This line should successfully do nothing for an empty directory - find $path -maxdepth 1 -mindepth 1 -print0 | xargs -0 -r mv -t /usr/lib/ghc-doc/haddock/ - rmdir $path - ln -s ../ghc-doc/haddock $path - fi - done - - /usr/lib/ghc-doc/gen_contents_index - ;; - abort-upgrade|abort-remove|abort-deconfigure) - ;; - *) - echo "postinst called with unknown argument \`$1'" >&2 - exit 0 - ;; -esac - -# dh_installdeb will replace this with shell code automatically -# generated by other debhelper scripts. - -#DEBHELPER# - -exit 0 diff -Nru ghc-7.0.3/debian/ghc-doc.preinst ghc-7.2.1/debian/ghc-doc.preinst --- ghc-7.0.3/debian/ghc-doc.preinst 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/debian/ghc-doc.preinst 2011-07-09 08:25:03.000000000 +0000 @@ -0,0 +1,21 @@ +#! /bin/sh + +set -e + +case "$1" in + upgrade|install) + if [ -e /usr/share/doc/ghc-doc/html/libraries/ ] ; then + rm -f /usr/share/doc/ghc-doc/html/libraries/index.html \ + /usr/share/doc/ghc-doc/html/libraries/index-frames.html \ + /usr/share/doc/ghc-doc/html/libraries/doc-index.html + rmdir --ignore-fail-on-non-empty /usr/share/doc/ghc-doc/html/libraries/ + rmdir --ignore-fail-on-non-empty /usr/share/doc/ghc-doc/html/ + fi + ;; + *) + ;; +esac + +#DEBHELPER# + +exit 0 diff -Nru ghc-7.0.3/debian/ghc-doc.preinst.in ghc-7.2.1/debian/ghc-doc.preinst.in --- ghc-7.0.3/debian/ghc-doc.preinst.in 2011-04-09 11:36:49.000000000 +0000 +++ ghc-7.2.1/debian/ghc-doc.preinst.in 1970-01-01 00:00:00.000000000 +0000 @@ -1,21 +0,0 @@ -#! /bin/sh - -set -e - -case "$1" in - upgrade|install) - if [ -e /usr/share/doc/ghc-doc/html/libraries/ ] ; then - rm -f /usr/share/doc/ghc-doc/html/libraries/index.html \ - /usr/share/doc/ghc-doc/html/libraries/index-frames.html \ - /usr/share/doc/ghc-doc/html/libraries/doc-index.html - rmdir --ignore-fail-on-non-empty /usr/share/doc/ghc-doc/html/libraries/ - rmdir --ignore-fail-on-non-empty /usr/share/doc/ghc-doc/html/ - fi - ;; - *) - ;; -esac - -#DEBHELPER# - -exit 0 diff -Nru ghc-7.0.3/debian/ghc-doc.triggers ghc-7.2.1/debian/ghc-doc.triggers --- ghc-7.0.3/debian/ghc-doc.triggers 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/debian/ghc-doc.triggers 2011-07-30 14:14:41.000000000 +0000 @@ -0,0 +1,6 @@ +interest /usr/lib/ghc-doc/haddock +interest /usr/lib/ghc-7.0.2/haddock +interest /usr/lib/ghc-7.0.3/haddock +interest /var/lib/ghc/package.conf.d +interest /var/lib/ghc-7.0.3/package.conf.d +interest /var/lib/ghc-7.0.4/package.conf.d diff -Nru ghc-7.0.3/debian/ghc-doc.triggers.in ghc-7.2.1/debian/ghc-doc.triggers.in --- ghc-7.0.3/debian/ghc-doc.triggers.in 2011-06-17 14:49:49.000000000 +0000 +++ ghc-7.2.1/debian/ghc-doc.triggers.in 1970-01-01 00:00:00.000000000 +0000 @@ -1,9 +0,0 @@ -interest /usr/share/doc/ghc-doc/libraries -interest /usr/share/ghc-doc/haddock -interest /usr/share/ghc-doc/ghc-@VERSION@/haddock -interest /usr/share/ghc-doc/ghc-@VERSION@/desc -interest /usr/lib/ghc-doc/haddock -interest /usr/lib/ghc-7.0.2/haddock -interest /usr/lib/ghc-7.0.3/haddock -interest /usr/lib/ghc-@VERSION@/haddock -interest /var/lib/ghc-@VERSION@/package.conf.d diff -Nru ghc-7.0.3/debian/ghc-pkg.man ghc-7.2.1/debian/ghc-pkg.man --- ghc-7.0.3/debian/ghc-pkg.man 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/debian/ghc-pkg.man 2011-07-11 12:44:30.000000000 +0000 @@ -0,0 +1,228 @@ +.TH ghc-pkg 1 "2010-01-27" +.SH NAME +ghc-pkg \- GHC Haskell Cabal package manager +.SH SYNOPSIS +.B ghc-pkg +.I action +.RI [ OPTION ]... +.SH DESCRIPTION +A package is a library of Haskell modules known to the compiler. The +.B ghc-pkg +tool allows adding or removing them from a package database. By +default, the system-wide package database is modified, but +alternatively the user's local package database or another specified +file can be used. +.PP +To make a package available for +.BR ghc , +.B ghc-pkg +can be used to register it. Unregistering it removes it from the +database. Also, packages can be hidden, to make +.B ghc +ignore the package by default, without uninstalling it. Exposing a +package makes a hidden package available. Additionally, +.B ghc-pkg +has various commands to query the package database. +.PP +Where a package name is required, the package can be named in full +including the version number (e.g. +.BR network-1.0 ), +or without the version number. Naming a package without the version +number matches all versions of the package; the specified action will +be applied to all the matching packages. A package specifier that +matches all version of the package can also be written +.BR pkg-* , +to make it clearer that multiple packages are being matched. +.SH ACTIONS +.TP +\fBregister\fP \fIfilename\fP|\fB-\fP +Register the package using the specified installed package +description. +.TP +\fBupdate\fP \fIfilename\fP|\fB-\fP +Register the package, overwriting any other package with the same +name. +.TP +\fBunregister\fP \fIpkg-id\fP +Unregister the specified package. +.TP +\fBexpose\fP \fIpkg-id\fP +Expose the specified package. +.TP +\fBhide\fP \fIpkg-id\fP +Hide the specified package +.TP +\fBlist\fP \fR[\fIpkg\fR]...\fP +List registered packages in the global database, and also the user +database if +.B --user +is given. If a package name is given all the registered versions will +be listed in ascending order. Accepts the +.B --simple-output +flag. +.TP +.B dot +Generate a graph of the package dependencies in a form suitable for +input for the graphviz tools. For example, to generate a PDF of the +dependency graph: +.br +\fB dot \| tred \| dot -Tpdf >pkgs.pdf\fP +.TP +\fBfind-module\fP \fImodule\fP +List registered packages exposing module +.I module +in the global database, and also the user database if +.B --user +is given. All the registered versions will be listed in ascending +order. Accepts the +.B --simple-output +flag. +.TP +\fBlatest\fP \fIpkg-id\fP +Prints the highest registered version of a package. +.TP +.B check +Check the consistency of package dependencies and list broken +packages. Accepts the +.B --simple-output +flag. +.TP +\fBdescribe\fP \fIpkg\fP +Give the registered description for the +specified package. The description is returned in precisely the syntax +required by ghc-pkg register. +.TP +\fBfield\fP \fIpkg field\fP +Extract the specified field of the package description for the +specified package. Accepts comma-separated multiple fields. +.TP +.B dump +Dump the registered description for every package. This is like +.BR ghc-pkg\ describe\ '*' , +expect that it is intended to be used by tools that parse the results, +rather than humans. +.TP +.B recache +Regenerate the package database cache. This command should only be +necessary if you added a package to the database by dropping a file +into the database directory manyally. By default, the global DB is +recached; to recache a different DB use +.B --user +or +.B --package-conf +as appropriate. +.SH OPTIONS +When asked to modify a database +.RB ( register ,\ unregister ,\ update ,\ hide ,\ expose ,\ and\ also\ check ), +.B ghc-pkg +modifies the global database by +default. Specifying +.B --user +causes it to act on the user database, +or +.B --package-conf +can be used to act on another database +entirely. When multiple of these options are given, the rightmost +one is used as the database to act upon. +.PP +Commands that query the package database +.RB ( list ,\ latest ,\ describe ,\ field ) +operate on the list of databases specified by the flags +.BR --user ,\ --global , +and +.BR --package-conf . +If none of these flags are +given, the default is +.BR --global\ --user . +.TP +.B --user +Use the current user's package database. +.TP +.B --global +Use the global package database. +.TP +\fB-f\fP \fIFILE\fP, \fB--package-conf=\fIFILE\fP +Use the specified package config file. +.TP +.BI --global-conf= FILE +Location of the global package config. +.TP +.B --force +Ignore missing dependencies, directories, and libraries. +.TP +.B --force-files +Ignore missing directories and libraries only. +.TP +.BR -g ,\ --auto-ghc-libs +Automatically build libs for GHCi (with register). +.TP +.BR -? ,\ --help +Display a help message and exit. +.TP +.BR -V ,\ --version +Output version information and exit. +.TP +.B --simple-output +Print output in easy-to-parse format for some commands. +.TP +.B --names-only +Only print package names, not versions; can only be used with +.BR list\ --simple-output . +.TP +.B --ignore-case +Ignore case for substring matching. +.SH ENVIRONMENT VARIABLES +.TP +.B GHC_PACKAGE_PATH +The +.B GHC_PACKAGE_PATH +environment variable may be set to a +.BR : -separated +list of files containing package databases. This list of package +databases is used by +.B ghc +and +.BR ghc-pkg , +with earlier databases in the list overriding later ones. This order +was chosen to match the behaviour of the +.B PATH +environment variable; think of it as a list of package databases that +are searched left-to-right for packages. + +If +.B GHC_PACKAGE_PATH +ends in a separator, then the default user and system package +databases are appended, in that order. e.g. to augment the usual set +of packages with a database of your own, you could say: + +.br +\fB export GHC_PACKAGE_PATH=$HOME/.my-ghc-packages.conf:\fP +.br + +To check whether your +.B GHC_PACKAGE_PATH +setting is doing the right thing, +.B ghc-pkg list +will list all the databases in use, in the reverse order they are +searched. +.SH FILES +Both of these locations are changed for Debian. Upstream still keeps +these under +.IR /usr . +Some programs may refer to that, but look in +.I /var +instead. +.TP +.I /var/lib/ghc/package.conf +Global package.conf file. +.TP +.I /var/lib/ghc/package.conf.d/ +Directory for library specific package.conf files. These are added to +the global registry. +.SH "SEE ALSO" +.BR ghc (1), +.BR runghc (1), +.BR hugs (1). +.SH AUTHOR +This manual page was written by Kari Pahula , for the +Debian project (and may be used by others). diff -Nru ghc-7.0.3/debian/ghc-pkg.man.in ghc-7.2.1/debian/ghc-pkg.man.in --- ghc-7.0.3/debian/ghc-pkg.man.in 2011-04-09 11:36:49.000000000 +0000 +++ ghc-7.2.1/debian/ghc-pkg.man.in 1970-01-01 00:00:00.000000000 +0000 @@ -1,228 +0,0 @@ -.TH ghc-pkg 1 "2010-01-27" -.SH NAME -ghc-pkg \- GHC Haskell Cabal package manager -.SH SYNOPSIS -.B ghc-pkg -.I action -.RI [ OPTION ]... -.SH DESCRIPTION -A package is a library of Haskell modules known to the compiler. The -.B ghc-pkg -tool allows adding or removing them from a package database. By -default, the system-wide package database is modified, but -alternatively the user's local package database or another specified -file can be used. -.PP -To make a package available for -.BR ghc , -.B ghc-pkg -can be used to register it. Unregistering it removes it from the -database. Also, packages can be hidden, to make -.B ghc -ignore the package by default, without uninstalling it. Exposing a -package makes a hidden package available. Additionally, -.B ghc-pkg -has various commands to query the package database. -.PP -Where a package name is required, the package can be named in full -including the version number (e.g. -.BR network-1.0 ), -or without the version number. Naming a package without the version -number matches all versions of the package; the specified action will -be applied to all the matching packages. A package specifier that -matches all version of the package can also be written -.BR pkg-* , -to make it clearer that multiple packages are being matched. -.SH ACTIONS -.TP -\fBregister\fP \fIfilename\fP|\fB-\fP -Register the package using the specified installed package -description. -.TP -\fBupdate\fP \fIfilename\fP|\fB-\fP -Register the package, overwriting any other package with the same -name. -.TP -\fBunregister\fP \fIpkg-id\fP -Unregister the specified package. -.TP -\fBexpose\fP \fIpkg-id\fP -Expose the specified package. -.TP -\fBhide\fP \fIpkg-id\fP -Hide the specified package -.TP -\fBlist\fP \fR[\fIpkg\fR]...\fP -List registered packages in the global database, and also the user -database if -.B --user -is given. If a package name is given all the registered versions will -be listed in ascending order. Accepts the -.B --simple-output -flag. -.TP -.B dot -Generate a graph of the package dependencies in a form suitable for -input for the graphviz tools. For example, to generate a PDF of the -dependency graph: -.br -\fB dot \| tred \| dot -Tpdf >pkgs.pdf\fP -.TP -\fBfind-module\fP \fImodule\fP -List registered packages exposing module -.I module -in the global database, and also the user database if -.B --user -is given. All the registered versions will be listed in ascending -order. Accepts the -.B --simple-output -flag. -.TP -\fBlatest\fP \fIpkg-id\fP -Prints the highest registered version of a package. -.TP -.B check -Check the consistency of package dependencies and list broken -packages. Accepts the -.B --simple-output -flag. -.TP -\fBdescribe\fP \fIpkg\fP -Give the registered description for the -specified package. The description is returned in precisely the syntax -required by ghc-pkg register. -.TP -\fBfield\fP \fIpkg field\fP -Extract the specified field of the package description for the -specified package. Accepts comma-separated multiple fields. -.TP -.B dump -Dump the registered description for every package. This is like -.BR ghc-pkg\ describe\ '*' , -expect that it is intended to be used by tools that parse the results, -rather than humans. -.TP -.B recache -Regenerate the package database cache. This command should only be -necessary if you added a package to the database by dropping a file -into the database directory manyally. By default, the global DB is -recached; to recache a different DB use -.B --user -or -.B --package-conf -as appropriate. -.SH OPTIONS -When asked to modify a database -.RB ( register ,\ unregister ,\ update ,\ hide ,\ expose ,\ and\ also\ check ), -.B ghc-pkg -modifies the global database by -default. Specifying -.B --user -causes it to act on the user database, -or -.B --package-conf -can be used to act on another database -entirely. When multiple of these options are given, the rightmost -one is used as the database to act upon. -.PP -Commands that query the package database -.RB ( list ,\ latest ,\ describe ,\ field ) -operate on the list of databases specified by the flags -.BR --user ,\ --global , -and -.BR --package-conf . -If none of these flags are -given, the default is -.BR --global\ --user . -.TP -.B --user -Use the current user's package database. -.TP -.B --global -Use the global package database. -.TP -\fB-f\fP \fIFILE\fP, \fB--package-conf=\fIFILE\fP -Use the specified package config file. -.TP -.BI --global-conf= FILE -Location of the global package config. -.TP -.B --force -Ignore missing dependencies, directories, and libraries. -.TP -.B --force-files -Ignore missing directories and libraries only. -.TP -.BR -g ,\ --auto-ghc-libs -Automatically build libs for GHCi (with register). -.TP -.BR -? ,\ --help -Display a help message and exit. -.TP -.BR -V ,\ --version -Output version information and exit. -.TP -.B --simple-output -Print output in easy-to-parse format for some commands. -.TP -.B --names-only -Only print package names, not versions; can only be used with -.BR list\ --simple-output . -.TP -.B --ignore-case -Ignore case for substring matching. -.SH ENVIRONMENT VARIABLES -.TP -.B GHC_PACKAGE_PATH -The -.B GHC_PACKAGE_PATH -environment variable may be set to a -.BR : -separated -list of files containing package databases. This list of package -databases is used by -.B ghc -and -.BR ghc-pkg , -with earlier databases in the list overriding later ones. This order -was chosen to match the behaviour of the -.B PATH -environment variable; think of it as a list of package databases that -are searched left-to-right for packages. - -If -.B GHC_PACKAGE_PATH -ends in a separator, then the default user and system package -databases are appended, in that order. e.g. to augment the usual set -of packages with a database of your own, you could say: - -.br -\fB export GHC_PACKAGE_PATH=$HOME/.my-ghc-packages.conf:\fP -.br - -To check whether your -.B GHC_PACKAGE_PATH -setting is doing the right thing, -.B ghc-pkg list -will list all the databases in use, in the reverse order they are -searched. -.SH FILES -Both of these locations are changed for Debian. Upstream still keeps -these under -.IR /usr . -Some programs may refer to that, but look in -.I /var -instead. -.TP -.I /var/lib/ghc-@VERSION@/package.conf -Global package.conf file. -.TP -.I /var/lib/ghc-@VERSION@/package.conf.d/ -Directory for library specific package.conf files. These are added to -the global registry. -.SH "SEE ALSO" -.BR ghc (1), -.BR runghc (1), -.BR hugs (1). -.SH AUTHOR -This manual page was written by Kari Pahula , for the -Debian project (and may be used by others). diff -Nru ghc-7.0.3/debian/ghc.postinst ghc-7.2.1/debian/ghc.postinst --- ghc-7.0.3/debian/ghc.postinst 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/debian/ghc.postinst 2011-07-30 14:10:42.000000000 +0000 @@ -0,0 +1,57 @@ +#! /bin/sh +# postinst script for ghc +# +set -e + +execdir=/usr/bin +libdir=/usr/lib/ghc +bindir=$libdir/bin +mandir=/usr/share/man +vardir=/var/lib/ghc + +# summary of how this script can be called: +# * `configure' +# * `abort-upgrade' +# * `abort-remove' `in-favour' +# +# * `abort-deconfigure' `in-favour' +# `removing' +# +# for details, see /usr/doc/packaging-manual/ +# +# quoting from the policy: +# Any necessary prompting should almost always be confined to the +# post-installation script, and should be protected with a conditional +# so that unnecessary prompting doesn't happen if a package's +# installation fails and the `postinst' is called with `abort-upgrade', +# `abort-remove' or `abort-deconfigure'. + +case "$1" in + configure|abort-upgrade|abort-remove|abort-deconfigure) + if $libdir/bin/ghc --info | grep '"Have interpreter","YES"' >/dev/null ; then + update-alternatives \ + --install $execdir/runhaskell runhaskell $execdir/runghc 8600000600 \ + --slave $mandir/man1/runhaskell.1.gz runhaskell.1.gz $mandir/man1/runghc.1.gz + fi + update-alternatives \ + --install $execdir/haskell-compiler haskell-compiler $execdir/ghc 600 \ + --slave $mandir/man1/haskell-compiler.1.gz haskell-compiler.1.gz $mandir/man1/ghc.1.gz + $bindir/ghc-pkg recache --global + $bindir/ghc-pkg check --global || true + ;; + triggered) + $bindir/ghc-pkg recache --global + $bindir/ghc-pkg check --global || true + ;; + *) + echo "postinst called with unknown argument \`$1'" >&2 + exit 0 + ;; +esac + +# dh_installdeb will replace this with shell code automatically +# generated by other debhelper scripts. + +#DEBHELPER# + +exit 0 diff -Nru ghc-7.0.3/debian/ghc.postinst.in ghc-7.2.1/debian/ghc.postinst.in --- ghc-7.0.3/debian/ghc.postinst.in 2011-04-09 11:47:22.000000000 +0000 +++ ghc-7.2.1/debian/ghc.postinst.in 1970-01-01 00:00:00.000000000 +0000 @@ -1,58 +0,0 @@ -#! /bin/sh -# postinst script for ghc -# -# SOURCE: ghc.postinst.in -set -e - -execdir=/usr/bin -libdir=/usr/lib/ghc-@VERSION@ -bindir=$libdir/bin -mandir=/usr/share/man -vardir=/var/lib/ghc-@VERSION@ - -# summary of how this script can be called: -# * `configure' -# * `abort-upgrade' -# * `abort-remove' `in-favour' -# -# * `abort-deconfigure' `in-favour' -# `removing' -# -# for details, see /usr/doc/packaging-manual/ -# -# quoting from the policy: -# Any necessary prompting should almost always be confined to the -# post-installation script, and should be protected with a conditional -# so that unnecessary prompting doesn't happen if a package's -# installation fails and the `postinst' is called with `abort-upgrade', -# `abort-remove' or `abort-deconfigure'. - -case "$1" in - configure|abort-upgrade|abort-remove|abort-deconfigure) - if $libdir/bin/ghc --info | grep '"Have interpreter","YES"' >/dev/null ; then - update-alternatives \ - --install $execdir/runhaskell runhaskell $execdir/runghc 8600000600 \ - --slave $mandir/man1/runhaskell.1.gz runhaskell.1.gz $mandir/man1/runghc.1.gz - fi - update-alternatives \ - --install $execdir/haskell-compiler haskell-compiler $execdir/ghc 600 \ - --slave $mandir/man1/haskell-compiler.1.gz haskell-compiler.1.gz $mandir/man1/ghc.1.gz - $bindir/ghc-pkg recache --global - $bindir/ghc-pkg check --global || true - ;; - triggered) - $bindir/ghc-pkg recache --global - $bindir/ghc-pkg check --global || true - ;; - *) - echo "postinst called with unknown argument \`$1'" >&2 - exit 0 - ;; -esac - -# dh_installdeb will replace this with shell code automatically -# generated by other debhelper scripts. - -#DEBHELPER# - -exit 0 diff -Nru ghc-7.0.3/debian/ghc.prerm ghc-7.2.1/debian/ghc.prerm --- ghc-7.0.3/debian/ghc.prerm 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/debian/ghc.prerm 2011-07-11 10:51:08.000000000 +0000 @@ -0,0 +1,41 @@ +#! /bin/sh +# prerm script for ghc +# +# SOURCE: ghc.prerm.in + +set -e + +execdir=/usr/bin +libdir=/usr/lib/ghc +bindir=$libdir/bin +vardir=/var/lib/ghc + +# summary of how this script can be called: +# * `remove' +# * `upgrade' +# * `failed-upgrade' +# * `remove' `in-favour' +# * `deconfigure' `in-favour' +# `removing' +# +# for details, see /usr/doc/packaging-manual/ + +case "$1" in + remove|upgrade|deconfigure|failed-upgrade) + update-alternatives --remove runhaskell $execdir/runghc + update-alternatives --remove haskell-compiler $execdir/ghc + rm -f $vardir/package.conf.d/package.cache + ;; + *) + echo "prerm called with unknown argument \`$1'" >&2 + exit 0 + ;; +esac + +# dh_installdeb will replace this with shell code automatically +# generated by other debhelper scripts. + +#DEBHELPER# + +exit 0 + diff -Nru ghc-7.0.3/debian/ghc.prerm.in ghc-7.2.1/debian/ghc.prerm.in --- ghc-7.0.3/debian/ghc.prerm.in 2011-04-09 14:53:13.000000000 +0000 +++ ghc-7.2.1/debian/ghc.prerm.in 1970-01-01 00:00:00.000000000 +0000 @@ -1,40 +0,0 @@ -#! /bin/sh -# prerm script for ghc -# -# SOURCE: ghc.prerm.in - -set -e - -execdir=/usr/bin -libdir=/usr/lib/ghc-@VERSION@ -bindir=$libdir/bin -vardir=/var/lib/ghc-@VERSION@ - -# summary of how this script can be called: -# * `remove' -# * `upgrade' -# * `failed-upgrade' -# * `remove' `in-favour' -# * `deconfigure' `in-favour' -# `removing' -# -# for details, see /usr/doc/packaging-manual/ - -case "$1" in - remove|upgrade|deconfigure|failed-upgrade) - update-alternatives --remove runhaskell $execdir/runghc - update-alternatives --remove haskell-compiler $execdir/ghc - ;; - *) - echo "prerm called with unknown argument \`$1'" >&2 - exit 0 - ;; -esac - -# dh_installdeb will replace this with shell code automatically -# generated by other debhelper scripts. - -#DEBHELPER# - -exit 0 - diff -Nru ghc-7.0.3/debian/ghc.triggers ghc-7.2.1/debian/ghc.triggers --- ghc-7.0.3/debian/ghc.triggers 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/debian/ghc.triggers 2011-07-30 14:10:49.000000000 +0000 @@ -0,0 +1 @@ +interest /var/lib/ghc/package.conf.d diff -Nru ghc-7.0.3/debian/ghc.triggers.in ghc-7.2.1/debian/ghc.triggers.in --- ghc-7.0.3/debian/ghc.triggers.in 2011-04-09 11:36:49.000000000 +0000 +++ ghc-7.2.1/debian/ghc.triggers.in 1970-01-01 00:00:00.000000000 +0000 @@ -1 +0,0 @@ -interest /var/lib/ghc-@VERSION@/package.conf.d diff -Nru ghc-7.0.3/debian/patches/autoconf ghc-7.2.1/debian/patches/autoconf --- ghc-7.0.3/debian/patches/autoconf 2011-04-09 14:57:14.000000000 +0000 +++ ghc-7.2.1/debian/patches/autoconf 2011-08-23 18:59:06.000000000 +0000 @@ -27,15 +27,15 @@ Reviewed-By: Last-Update: -Index: ghc-7.0.3/configure +Index: ghc-7.2.1/configure =================================================================== ---- ghc-7.0.3.orig/configure 2011-03-26 23:40:47.000000000 +0530 -+++ ghc-7.0.3/configure 2011-04-09 20:27:11.000000000 +0530 +--- ghc-7.2.1.orig/configure 2011-08-23 20:58:37.000000000 +0200 ++++ ghc-7.2.1/configure 2011-08-23 20:59:03.000000000 +0200 @@ -1,13 +1,13 @@ #! /bin/sh # Guess values for system-dependent variables and create Makefiles. --# Generated by GNU Autoconf 2.65 for The Glorious Glasgow Haskell Compilation System 7.0.3. -+# Generated by GNU Autoconf 2.67 for The Glorious Glasgow Haskell Compilation System 7.0.3. +-# Generated by GNU Autoconf 2.65 for The Glorious Glasgow Haskell Compilation System 7.2.1. ++# Generated by GNU Autoconf 2.68 for The Glorious Glasgow Haskell Compilation System 7.2.1. # # Report bugs to . # @@ -48,1347 +48,60 @@ # # # This configure script is free software; the Free Software Foundation -@@ -319,7 +319,7 @@ - test -d "$as_dir" && break - done - test -z "$as_dirs" || eval "mkdir $as_dirs" -- } || test -d "$as_dir" || as_fn_error "cannot create directory $as_dir" -+ } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" - - - } # as_fn_mkdir_p -@@ -359,19 +359,19 @@ - fi # as_fn_arith - - --# as_fn_error ERROR [LINENO LOG_FD] --# --------------------------------- -+# as_fn_error STATUS ERROR [LINENO LOG_FD] -+# ---------------------------------------- - # Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are - # provided, also output the error to LOG_FD, referencing LINENO. Then exit the --# script with status $?, using 1 if that was 0. -+# script with STATUS, using 1 if that was 0. - as_fn_error () - { -- as_status=$?; test $as_status -eq 0 && as_status=1 -- if test "$3"; then -- as_lineno=${as_lineno-"$2"} as_lineno_stack=as_lineno_stack=$as_lineno_stack -- $as_echo "$as_me:${as_lineno-$LINENO}: error: $1" >&$3 -+ as_status=$1; test $as_status -eq 0 && as_status=1 -+ if test "$4"; then -+ as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack -+ $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 - fi -- $as_echo "$as_me: error: $1" >&2 -+ $as_echo "$as_me: error: $2" >&2 - as_fn_exit $as_status - } # as_fn_error - -@@ -533,7 +533,7 @@ - exec 6>&1 - - # Name of the host. --# hostname on some systems (SVR3.2, Linux) returns a bogus exit status, -+# hostname on some systems (SVR3.2, old GNU/Linux) returns a bogus exit status, - # so uname gets run too. - ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q` - -@@ -863,8 +863,9 @@ - fi - - case $ac_option in -- *=*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;; -- *) ac_optarg=yes ;; -+ *=?*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;; -+ *=) ac_optarg= ;; -+ *) ac_optarg=yes ;; - esac - - # Accept the important Cygnus configure options, so we can diagnose typos. -@@ -909,7 +910,7 @@ - ac_useropt=`expr "x$ac_option" : 'x-*disable-\(.*\)'` - # Reject names that are not valid shell variable names. - expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && -- as_fn_error "invalid feature name: $ac_useropt" -+ as_fn_error $? "invalid feature name: $ac_useropt" - ac_useropt_orig=$ac_useropt - ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` - case $ac_user_opts in -@@ -935,7 +936,7 @@ - ac_useropt=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` - # Reject names that are not valid shell variable names. - expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && -- as_fn_error "invalid feature name: $ac_useropt" -+ as_fn_error $? "invalid feature name: $ac_useropt" - ac_useropt_orig=$ac_useropt - ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` - case $ac_user_opts in -@@ -1139,7 +1140,7 @@ - ac_useropt=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` - # Reject names that are not valid shell variable names. - expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && -- as_fn_error "invalid package name: $ac_useropt" -+ as_fn_error $? "invalid package name: $ac_useropt" - ac_useropt_orig=$ac_useropt - ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` - case $ac_user_opts in -@@ -1155,7 +1156,7 @@ - ac_useropt=`expr "x$ac_option" : 'x-*without-\(.*\)'` - # Reject names that are not valid shell variable names. - expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && -- as_fn_error "invalid package name: $ac_useropt" -+ as_fn_error $? "invalid package name: $ac_useropt" - ac_useropt_orig=$ac_useropt - ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` - case $ac_user_opts in -@@ -1185,8 +1186,8 @@ - | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) - x_libraries=$ac_optarg ;; - -- -*) as_fn_error "unrecognized option: \`$ac_option' --Try \`$0 --help' for more information." -+ -*) as_fn_error $? "unrecognized option: \`$ac_option' -+Try \`$0 --help' for more information" - ;; - - *=*) -@@ -1194,7 +1195,7 @@ - # Reject names that are not valid shell variable names. - case $ac_envvar in #( - '' | [0-9]* | *[!_$as_cr_alnum]* ) -- as_fn_error "invalid variable name: \`$ac_envvar'" ;; -+ as_fn_error $? "invalid variable name: \`$ac_envvar'" ;; - esac - eval $ac_envvar=\$ac_optarg - export $ac_envvar ;; -@@ -1212,13 +1213,13 @@ - - if test -n "$ac_prev"; then - ac_option=--`echo $ac_prev | sed 's/_/-/g'` -- as_fn_error "missing argument to $ac_option" -+ as_fn_error $? "missing argument to $ac_option" - fi - - if test -n "$ac_unrecognized_opts"; then - case $enable_option_checking in - no) ;; -- fatal) as_fn_error "unrecognized options: $ac_unrecognized_opts" ;; -+ fatal) as_fn_error $? "unrecognized options: $ac_unrecognized_opts" ;; - *) $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2 ;; - esac - fi -@@ -1241,7 +1242,7 @@ - [\\/$]* | ?:[\\/]* ) continue;; - NONE | '' ) case $ac_var in *prefix ) continue;; esac;; - esac -- as_fn_error "expected an absolute directory name for --$ac_var: $ac_val" -+ as_fn_error $? "expected an absolute directory name for --$ac_var: $ac_val" - done - - # There might be people who depend on the old broken behavior: `$host' -@@ -1255,8 +1256,8 @@ - if test "x$host_alias" != x; then - if test "x$build_alias" = x; then - cross_compiling=maybe -- $as_echo "$as_me: WARNING: If you wanted to set the --build type, don't use --host. -- If a cross compiler is detected then cross compile mode will be used." >&2 -+ $as_echo "$as_me: WARNING: if you wanted to set the --build type, don't use --host. -+ If a cross compiler is detected then cross compile mode will be used" >&2 - elif test "x$build_alias" != "x$host_alias"; then - cross_compiling=yes - fi -@@ -1271,9 +1272,9 @@ - ac_pwd=`pwd` && test -n "$ac_pwd" && - ac_ls_di=`ls -di .` && - ac_pwd_ls_di=`cd "$ac_pwd" && ls -di .` || -- as_fn_error "working directory cannot be determined" -+ as_fn_error $? "working directory cannot be determined" - test "X$ac_ls_di" = "X$ac_pwd_ls_di" || -- as_fn_error "pwd does not report name of working directory" -+ as_fn_error $? "pwd does not report name of working directory" - - - # Find the source files, if location was not specified. -@@ -1312,11 +1313,11 @@ - fi - if test ! -r "$srcdir/$ac_unique_file"; then - test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .." -- as_fn_error "cannot find sources ($ac_unique_file) in $srcdir" -+ as_fn_error $? "cannot find sources ($ac_unique_file) in $srcdir" - fi - ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work" - ac_abs_confdir=`( -- cd "$srcdir" && test -r "./$ac_unique_file" || as_fn_error "$ac_msg" -+ cd "$srcdir" && test -r "./$ac_unique_file" || as_fn_error $? "$ac_msg" - pwd)` - # When building in place, set srcdir=. - if test "$ac_abs_confdir" = "$ac_pwd"; then -@@ -1356,7 +1357,7 @@ - --help=short display options specific to this package - --help=recursive display the short help of all the included packages - -V, --version display version information and exit -- -q, --quiet, --silent do not print \`checking...' messages -+ -q, --quiet, --silent do not print \`checking ...' messages - --cache-file=FILE cache test results in FILE [disabled] - -C, --config-cache alias for \`--cache-file=config.cache' - -n, --no-create do not create output files -@@ -1518,9 +1519,9 @@ +@@ -1535,9 +1535,9 @@ if $ac_init_version; then cat <<\_ACEOF - The Glorious Glasgow Haskell Compilation System configure 7.0.3 + The Glorious Glasgow Haskell Compilation System configure 7.2.1 -generated by GNU Autoconf 2.65 -+generated by GNU Autoconf 2.67 ++generated by GNU Autoconf 2.68 -Copyright (C) 2009 Free Software Foundation, Inc. +Copyright (C) 2010 Free Software Foundation, Inc. This configure script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it. _ACEOF -@@ -1590,7 +1591,7 @@ - mv -f conftest.er1 conftest.err - fi - $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 -- test $ac_status = 0; } >/dev/null && { -+ test $ac_status = 0; } > conftest.i && { - test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || - test ! -s conftest.err - }; then : -@@ -1656,10 +1657,10 @@ - ac_fn_c_check_header_mongrel () - { - as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack -- if { as_var=$3; eval "test \"\${$as_var+set}\" = set"; }; then : -+ if eval "test \"\${$3+set}\"" = set; then : - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 - $as_echo_n "checking for $2... " >&6; } --if { as_var=$3; eval "test \"\${$as_var+set}\" = set"; }; then : -+if eval "test \"\${$3+set}\"" = set; then : - $as_echo_n "(cached) " >&6 - fi - eval ac_res=\$$3 -@@ -1695,7 +1696,7 @@ - else - ac_header_preproc=no - fi --rm -f conftest.err conftest.$ac_ext -+rm -f conftest.err conftest.i conftest.$ac_ext - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_header_preproc" >&5 - $as_echo "$ac_header_preproc" >&6; } - -@@ -1718,17 +1719,15 @@ - $as_echo "$as_me: WARNING: $2: section \"Present But Cannot Be Compiled\"" >&2;} - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: proceeding with the compiler's result" >&5 - $as_echo "$as_me: WARNING: $2: proceeding with the compiler's result" >&2;} --( cat <<\_ASBOX --## ----------------------------------------------- ## -+( $as_echo "## ----------------------------------------------- ## - ## Report this to glasgow-haskell-bugs@haskell.org ## --## ----------------------------------------------- ## --_ASBOX -+## ----------------------------------------------- ##" - ) | sed "s/^/$as_me: WARNING: /" >&2 - ;; - esac - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 - $as_echo_n "checking for $2... " >&6; } --if { as_var=$3; eval "test \"\${$as_var+set}\" = set"; }; then : -+if eval "test \"\${$3+set}\"" = set; then : - $as_echo_n "(cached) " >&6 - else - eval "$3=\$ac_header_compiler" -@@ -1750,7 +1749,7 @@ - as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 - $as_echo_n "checking for $2... " >&6; } --if { as_var=$3; eval "test \"\${$as_var+set}\" = set"; }; then : -+if eval "test \"\${$3+set}\"" = set; then : - $as_echo_n "(cached) " >&6 - else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -@@ -1781,7 +1780,7 @@ - as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 - $as_echo_n "checking for $2... " >&6; } --if { as_var=$3; eval "test \"\${$as_var+set}\" = set"; }; then : -+if eval "test \"\${$3+set}\"" = set; then : - $as_echo_n "(cached) " >&6 - else - eval "$3=no" -@@ -2058,7 +2057,7 @@ - as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack - { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 - $as_echo_n "checking for $2... " >&6; } --if { as_var=$3; eval "test \"\${$as_var+set}\" = set"; }; then : -+if eval "test \"\${$3+set}\"" = set; then : - $as_echo_n "(cached) " >&6 - else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -@@ -2117,15 +2116,18 @@ - - } # ac_fn_c_check_func - --# ac_fn_c_check_decl LINENO SYMBOL VAR --# ------------------------------------ --# Tests whether SYMBOL is declared, setting cache variable VAR accordingly. -+# ac_fn_c_check_decl LINENO SYMBOL VAR INCLUDES -+# --------------------------------------------- -+# Tests whether SYMBOL is declared in INCLUDES, setting cache variable VAR -+# accordingly. - ac_fn_c_check_decl () - { - as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack -- { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $2 is declared" >&5 --$as_echo_n "checking whether $2 is declared... " >&6; } --if { as_var=$3; eval "test \"\${$as_var+set}\" = set"; }; then : -+ as_decl_name=`echo $2|sed 's/ *(.*//'` -+ as_decl_use=`echo $2|sed -e 's/(/((/' -e 's/)/) 0&/' -e 's/,/) 0& (/g'` -+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $as_decl_name is declared" >&5 -+$as_echo_n "checking whether $as_decl_name is declared... " >&6; } -+if eval "test \"\${$3+set}\"" = set; then : - $as_echo_n "(cached) " >&6 - else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext -@@ -2134,8 +2136,12 @@ - int - main () - { --#ifndef $2 -- (void) $2; -+#ifndef $as_decl_name -+#ifdef __cplusplus -+ (void) $as_decl_use; -+#else -+ (void) $as_decl_name; -+#endif - #endif - - ; -@@ -2160,7 +2166,7 @@ +@@ -2182,7 +2182,7 @@ running configure, to aid debugging if configure makes a mistake. - It was created by The Glorious Glasgow Haskell Compilation System $as_me 7.0.3, which was + It was created by The Glorious Glasgow Haskell Compilation System $as_me 7.2.1, which was -generated by GNU Autoconf 2.65. Invocation command line was -+generated by GNU Autoconf 2.67. Invocation command line was ++generated by GNU Autoconf 2.68. Invocation command line was $ $0 $@ -@@ -2270,11 +2276,9 @@ - { - echo - -- cat <<\_ASBOX --## ---------------- ## -+ $as_echo "## ---------------- ## - ## Cache variables. ## --## ---------------- ## --_ASBOX -+## ---------------- ##" - echo - # The following way of writing the cache mishandles newlines in values, - ( -@@ -2308,11 +2312,9 @@ - ) - echo - -- cat <<\_ASBOX --## ----------------- ## -+ $as_echo "## ----------------- ## - ## Output variables. ## --## ----------------- ## --_ASBOX -+## ----------------- ##" - echo - for ac_var in $ac_subst_vars - do -@@ -2325,11 +2327,9 @@ - echo - - if test -n "$ac_subst_files"; then -- cat <<\_ASBOX --## ------------------- ## -+ $as_echo "## ------------------- ## - ## File substitutions. ## --## ------------------- ## --_ASBOX -+## ------------------- ##" - echo - for ac_var in $ac_subst_files - do -@@ -2343,11 +2343,9 @@ - fi - - if test -s confdefs.h; then -- cat <<\_ASBOX --## ----------- ## -+ $as_echo "## ----------- ## - ## confdefs.h. ## --## ----------- ## --_ASBOX -+## ----------- ##" - echo - cat confdefs.h - echo -@@ -2402,7 +2400,12 @@ - ac_site_file1=NONE - ac_site_file2=NONE - if test -n "$CONFIG_SITE"; then -- ac_site_file1=$CONFIG_SITE -+ # We do not want a PATH search for config.site. -+ case $CONFIG_SITE in #(( -+ -*) ac_site_file1=./$CONFIG_SITE;; -+ */*) ac_site_file1=$CONFIG_SITE;; -+ *) ac_site_file1=./$CONFIG_SITE;; -+ esac - elif test "x$prefix" != xNONE; then - ac_site_file1=$prefix/share/config.site - ac_site_file2=$prefix/etc/config.site -@@ -2417,7 +2420,11 @@ - { $as_echo "$as_me:${as_lineno-$LINENO}: loading site script $ac_site_file" >&5 - $as_echo "$as_me: loading site script $ac_site_file" >&6;} - sed 's/^/| /' "$ac_site_file" >&5 -- . "$ac_site_file" -+ . "$ac_site_file" \ -+ || { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 -+$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} -+as_fn_error $? "failed to load site script $ac_site_file -+See \`config.log' for more details" "$LINENO" 5 ; } - fi - done - -@@ -2493,7 +2500,7 @@ - $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} - { $as_echo "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5 - $as_echo "$as_me: error: changes in the environment can compromise the build" >&2;} -- as_fn_error "run \`make distclean' and/or \`rm $cache_file' and start over" "$LINENO" 5 -+ as_fn_error $? "run \`make distclean' and/or \`rm $cache_file' and start over" "$LINENO" 5 - fi - ## -------------------- ## - ## Main body of script. ## -@@ -2768,7 +2775,7 @@ - elif test -d .git; then - ver_date=`git log -n 1 --date=short --pretty=format:%ci | sed "s/^.*\([0-9][0-9][0-9][0-9]\)-\([0-9][0-9]\)-\([0-9][0-9]\).*$/\1\2\3/"` - if echo $ver_date | grep '^[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9]$' 2>&1 >/dev/null; then true; else -- as_fn_error "failed to detect version date: check that git is in your path" "$LINENO" 5 -+ as_fn_error $? "failed to detect version date: check that git is in your path" "$LINENO" 5 - fi - PACKAGE_VERSION=${PACKAGE_VERSION}.$ver_date - { $as_echo "$as_me:${as_lineno-$LINENO}: result: inferred $PACKAGE_VERSION" >&5 -@@ -2777,7 +2784,7 @@ - # TODO: Remove this branch after conversion to Git - ver_date=`darcs changes --quiet --no-summary --xml | head -500 | grep 'date=' | sed "s/^.*date='\([0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9]\).*$/\1/g" | ${SortCmd} -n | tail -1` - if echo $ver_date | grep '^[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9]$' 2>&1 >/dev/null; then true; else -- as_fn_error "failed to detect version date: check that darcs is in your path" "$LINENO" 5 -+ as_fn_error $? "failed to detect version date: check that darcs is in your path" "$LINENO" 5 - fi - PACKAGE_VERSION=${PACKAGE_VERSION}.$ver_date - { $as_echo "$as_me:${as_lineno-$LINENO}: result: inferred $PACKAGE_VERSION" >&5 -@@ -2808,7 +2815,7 @@ - case $VERSION_MINOR in - ?) ProjectVersionInt=${VERSION_MAJOR}0${VERSION_MINOR} ;; - ??) ProjectVersionInt=${VERSION_MAJOR}${VERSION_MINOR} ;; -- *) as_fn_error "bad minor version in $PACKAGE_VERSION" "$LINENO" 5 ;; -+ *) as_fn_error $? "bad minor version in $PACKAGE_VERSION" "$LINENO" 5 ;; - esac - - -@@ -2958,7 +2965,7 @@ - - - if test "$GhcMajVersion" = "unknown" -o "$GhcMinVersion" = "unknown"; then -- as_fn_error "Cannot determine the version of $WithGhc. Is it really GHC?" "$LINENO" 5 -+ as_fn_error $? "Cannot determine the version of $WithGhc. Is it really GHC?" "$LINENO" 5 - fi - - GhcMinVersion2=`echo "$GhcMinVersion" | sed 's/^\\(.\\)$/0\\1/'` -@@ -2994,7 +3001,7 @@ - - if test "$BootingFromHc" = "NO" -a -d "$srcdir/compiler"; then - if test "$WithGhc" = ""; then -- as_fn_error "GHC is required unless bootstrapping from .hc files." "$LINENO" 5 -+ as_fn_error $? "GHC is required unless bootstrapping from .hc files." "$LINENO" 5 - fi - fp_version1=$GhcVersion; fp_version2=6.10 - fp_save_IFS=$IFS; IFS='.' -@@ -3017,11 +3024,11 @@ - done - IFS=$fp_save_IFS - if test "$fp_num1" -lt "$fp_num2"; then : -- as_fn_error "GHC version 6.10 or later is required to compile GHC." "$LINENO" 5 -+ as_fn_error $? "GHC version 6.10 or later is required to compile GHC." "$LINENO" 5 - fi - if test `expr $GhcMinVersion % 2` = "1"; then - if test "$EnableBootstrapWithDevelSnaphost" = "NO"; then -- as_fn_error " -+ as_fn_error $? " - $WithGhc is a development snapshot of GHC, version $GhcVersion. - Bootstrapping using this version of GHC is not supported, and may not - work. Use --enable-bootstrap-with-devel-snapshot to try it anyway, -@@ -3106,16 +3113,22 @@ - # results in the following code - ac_aux_dir= - for ac_dir in "$srcdir" "$srcdir/.." "$srcdir/../.."; do -- for ac_t in install-sh install.sh shtool; do -- if test -f "$ac_dir/$ac_t"; then -- ac_aux_dir=$ac_dir -- ac_install_sh="$ac_aux_dir/$ac_t -c" -- break 2 -- fi -- done -+ if test -f "$ac_dir/install-sh"; then -+ ac_aux_dir=$ac_dir -+ ac_install_sh="$ac_aux_dir/install-sh -c" -+ break -+ elif test -f "$ac_dir/install.sh"; then -+ ac_aux_dir=$ac_dir -+ ac_install_sh="$ac_aux_dir/install.sh -c" -+ break -+ elif test -f "$ac_dir/shtool"; then -+ ac_aux_dir=$ac_dir -+ ac_install_sh="$ac_aux_dir/shtool install -c" -+ break -+ fi - done - if test -z "$ac_aux_dir"; then -- as_fn_error "cannot find install-sh, install.sh, or shtool in \"$srcdir\" \"$srcdir/..\" \"$srcdir/../..\"" "$LINENO" 5 -+ as_fn_error $? "cannot find install-sh, install.sh, or shtool in \"$srcdir\" \"$srcdir/..\" \"$srcdir/../..\"" "$LINENO" 5 - fi - - # These three variables are undocumented and unsupported, -@@ -3129,7 +3142,7 @@ - - # Make sure we can run config.sub. - $SHELL "$ac_aux_dir/config.sub" sun4 >/dev/null 2>&1 || -- as_fn_error "cannot run $SHELL $ac_aux_dir/config.sub" "$LINENO" 5 -+ as_fn_error $? "cannot run $SHELL $ac_aux_dir/config.sub" "$LINENO" 5 - - { $as_echo "$as_me:${as_lineno-$LINENO}: checking build system type" >&5 - $as_echo_n "checking build system type... " >&6; } -@@ -3140,16 +3153,16 @@ - test "x$ac_build_alias" = x && - ac_build_alias=`$SHELL "$ac_aux_dir/config.guess"` - test "x$ac_build_alias" = x && -- as_fn_error "cannot guess build type; you must specify one" "$LINENO" 5 -+ as_fn_error $? "cannot guess build type; you must specify one" "$LINENO" 5 - ac_cv_build=`$SHELL "$ac_aux_dir/config.sub" $ac_build_alias` || -- as_fn_error "$SHELL $ac_aux_dir/config.sub $ac_build_alias failed" "$LINENO" 5 -+ as_fn_error $? "$SHELL $ac_aux_dir/config.sub $ac_build_alias failed" "$LINENO" 5 - - fi - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_build" >&5 - $as_echo "$ac_cv_build" >&6; } - case $ac_cv_build in - *-*-*) ;; --*) as_fn_error "invalid value of canonical build" "$LINENO" 5;; -+*) as_fn_error $? "invalid value of canonical build" "$LINENO" 5 ;; - esac - build=$ac_cv_build - ac_save_IFS=$IFS; IFS='-' -@@ -3174,7 +3187,7 @@ - ac_cv_host=$ac_cv_build - else - ac_cv_host=`$SHELL "$ac_aux_dir/config.sub" $host_alias` || -- as_fn_error "$SHELL $ac_aux_dir/config.sub $host_alias failed" "$LINENO" 5 -+ as_fn_error $? "$SHELL $ac_aux_dir/config.sub $host_alias failed" "$LINENO" 5 - fi - - fi -@@ -3182,7 +3195,7 @@ - $as_echo "$ac_cv_host" >&6; } - case $ac_cv_host in - *-*-*) ;; --*) as_fn_error "invalid value of canonical host" "$LINENO" 5;; -+*) as_fn_error $? "invalid value of canonical host" "$LINENO" 5 ;; - esac - host=$ac_cv_host - ac_save_IFS=$IFS; IFS='-' -@@ -3207,7 +3220,7 @@ - ac_cv_target=$ac_cv_host +@@ -3956,7 +3956,7 @@ + set dummy gcc-4.2; ac_word=$2 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 + $as_echo_n "checking for $ac_word... " >&6; } +-if test "${ac_cv_path_CC+set}" = set; then : ++if ${ac_cv_path_CC+:} false; then : + $as_echo_n "(cached) " >&6 else - ac_cv_target=`$SHELL "$ac_aux_dir/config.sub" $target_alias` || -- as_fn_error "$SHELL $ac_aux_dir/config.sub $target_alias failed" "$LINENO" 5 -+ as_fn_error $? "$SHELL $ac_aux_dir/config.sub $target_alias failed" "$LINENO" 5 - fi - - fi -@@ -3215,7 +3228,7 @@ - $as_echo "$ac_cv_target" >&6; } - case $ac_cv_target in - *-*-*) ;; --*) as_fn_error "invalid value of canonical target" "$LINENO" 5;; -+*) as_fn_error $? "invalid value of canonical target" "$LINENO" 5 ;; - esac - target=$ac_cv_target - ac_save_IFS=$IFS; IFS='-' -@@ -3761,9 +3774,9 @@ - $as_echo "$as_me: Building in-tree ghc-pwd" >&6;} - rm -rf utils/ghc-pwd/dist-boot - mkdir utils/ghc-pwd/dist-boot -- if ! "$WithGhc" -v0 -no-user-package-conf -hidir utils/ghc-pwd/dist-boot -odir utils/ghc-pwd/dist-boot -stubdir utils/ghc-pwd/dist-boot --make utils/ghc-pwd/Main.hs -o utils/ghc-pwd/dist-boot/ghc-pwd -+ if ! "$WithGhc" -optl-pthread -v0 -no-user-package-conf -hidir utils/ghc-pwd/dist-boot -odir utils/ghc-pwd/dist-boot -stubdir utils/ghc-pwd/dist-boot --make utils/ghc-pwd/Main.hs -o utils/ghc-pwd/dist-boot/ghc-pwd - then -- as_fn_error "Building ghc-pwd failed" "$LINENO" 5 -+ as_fn_error $? "Building ghc-pwd failed" "$LINENO" 5 - fi - - GHC_PWD=utils/ghc-pwd/dist-boot/ghc-pwd -@@ -3776,12 +3789,12 @@ - hardtop=`echo $hardtop | sed 's|^/tmp_mnt.*\(/local/.*\)$|\1|' | sed 's|^/tmp_mnt/|/|'` - - if ! test -d "$hardtop"; then -- as_fn_error "cannot determine current directory" "$LINENO" 5 -+ as_fn_error $? "cannot determine current directory" "$LINENO" 5 - fi - - case "$hardtop" in - *' '*) -- as_fn_error " -+ as_fn_error $? " - The build system does not support building in a directory - containing space characters. - Suggestion: move the build tree somewhere else." "$LINENO" 5 -@@ -3838,7 +3851,7 @@ - PATH=`pwd`/inplace/mingw/bin:$PATH inplace/mingw/bin/realgcc.exe driver/gcc/gcc.c driver/utils/cwrapper.c driver/utils/getLocation.c -Idriver/utils -o inplace/mingw/bin/gcc.exe - if ! test -e inplace/mingw/bin/gcc.exe - then -- as_fn_error "GHC is required unless bootstrapping from .hc files." "$LINENO" 5 -+ as_fn_error $? "GHC is required unless bootstrapping from .hc files." "$LINENO" 5 - fi - { $as_echo "$as_me:${as_lineno-$LINENO}: In-tree mingw tree created" >&5 - $as_echo "$as_me: In-tree mingw tree created" >&6;} -@@ -3919,7 +3932,7 @@ + case $CC in +@@ -3994,7 +3994,7 @@ if test -z "$CC" then -- as_fn_error "cannot find gcc in your PATH, no idea how to link" "$LINENO" 5 -+ as_fn_error $? "cannot find gcc in your PATH, no idea how to link" "$LINENO" 5 - fi - fi - -@@ -3990,7 +4003,7 @@ - - if test -z "$LD" - then -- as_fn_error "cannot find ld in your PATH, no idea how to link" "$LINENO" 5 -+ as_fn_error $? "cannot find ld in your PATH, no idea how to link" "$LINENO" 5 - fi - fi - -@@ -4060,7 +4073,7 @@ - - if test -z "$NM" - then -- as_fn_error "cannot find nm in your PATH, no idea how to link" "$LINENO" 5 -+ as_fn_error $? "cannot find nm in your PATH, no idea how to link" "$LINENO" 5 +- as_fn_error "cannot find gcc-4.2 in your PATH, no idea how to link" "$LINENO" 5 ++ as_fn_error $? "cannot find gcc-4.2 in your PATH, no idea how to link" "$LINENO" 5 fi fi -@@ -4145,7 +4158,7 @@ - $as_echo "none" >&6; } - else - if test ! -d $MACOSX_DEPLOYMENT_SDK; then -- as_fn_error "Unknown deployment target $FP_MACOSX_DEPLOYMENT_TARGET" "$LINENO" 5 -+ as_fn_error $? "Unknown deployment target $FP_MACOSX_DEPLOYMENT_TARGET" "$LINENO" 5 - fi - { $as_echo "$as_me:${as_lineno-$LINENO}: result: ${MACOSX_DEPLOYMENT_VERSION} (${MACOSX_DEPLOYMENT_SDK})" >&5 - $as_echo "${MACOSX_DEPLOYMENT_VERSION} (${MACOSX_DEPLOYMENT_SDK})" >&6; } -@@ -4243,7 +4256,7 @@ - if grep "v5" conftest.out >/dev/null 2>&1; then - : - else -- as_fn_error "your version of perl probably won't work, try upgrading it." "$LINENO" 5 -+ as_fn_error $? "your version of perl probably won't work, try upgrading it." "$LINENO" 5 - fi - rm -fr conftest* - -@@ -4613,8 +4626,8 @@ - - test -z "$CC" && { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 - $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} --as_fn_error "no acceptable C compiler found in \$PATH --See \`config.log' for more details." "$LINENO" 5; } -+as_fn_error $? "no acceptable C compiler found in \$PATH -+See \`config.log' for more details" "$LINENO" 5 ; } - - # Provide some information about the compiler. - $as_echo "$as_me:${as_lineno-$LINENO}: checking for C compiler version" >&5 -@@ -4728,9 +4741,8 @@ - - { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 - $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} --{ as_fn_set_status 77 --as_fn_error "C compiler cannot create executables --See \`config.log' for more details." "$LINENO" 5; }; } -+as_fn_error 77 "C compiler cannot create executables -+See \`config.log' for more details" "$LINENO" 5 ; } - else - { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 - $as_echo "yes" >&6; } -@@ -4772,8 +4784,8 @@ - else - { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 - $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} --as_fn_error "cannot compute suffix of executables: cannot compile and link --See \`config.log' for more details." "$LINENO" 5; } -+as_fn_error $? "cannot compute suffix of executables: cannot compile and link -+See \`config.log' for more details" "$LINENO" 5 ; } - fi - rm -f conftest conftest$ac_cv_exeext - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_exeext" >&5 -@@ -4830,9 +4842,9 @@ - else - { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 - $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} --as_fn_error "cannot run C compiled programs. -+as_fn_error $? "cannot run C compiled programs. - If you meant to cross compile, use \`--host'. --See \`config.log' for more details." "$LINENO" 5; } -+See \`config.log' for more details" "$LINENO" 5 ; } - fi - fi - fi -@@ -4883,8 +4895,8 @@ - - { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 - $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} --as_fn_error "cannot compute suffix of object files: cannot compile --See \`config.log' for more details." "$LINENO" 5; } -+as_fn_error $? "cannot compute suffix of object files: cannot compile -+See \`config.log' for more details" "$LINENO" 5 ; } - fi - rm -f conftest.$ac_cv_objext conftest.$ac_ext - fi -@@ -5111,7 +5123,7 @@ - fp_have_gcc=YES - fi - if test "$fp_have_gcc" = "NO" -a -d $srcdir/ghc; then -- as_fn_error "gcc is required" "$LINENO" 5 -+ as_fn_error $? "gcc is required" "$LINENO" 5 - fi - GccLT34= - { $as_echo "$as_me:${as_lineno-$LINENO}: checking version of gcc" >&5 -@@ -5142,7 +5154,7 @@ - done - IFS=$fp_save_IFS - if test "$fp_num1" -lt "$fp_num2"; then : -- as_fn_error "Need at least gcc version 3.0 (3.4+ recommended)" "$LINENO" 5 -+ as_fn_error $? "Need at least gcc version 3.0 (3.4+ recommended)" "$LINENO" 5 - fi - # 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 -@@ -5498,7 +5510,7 @@ - # Broken: fails on valid input. - continue - fi --rm -f conftest.err conftest.$ac_ext -+rm -f conftest.err conftest.i conftest.$ac_ext - - # OK, works on sane cases. Now check whether nonexistent headers - # can be detected and how. -@@ -5514,11 +5526,11 @@ - ac_preproc_ok=: - break - fi --rm -f conftest.err conftest.$ac_ext -+rm -f conftest.err conftest.i conftest.$ac_ext - - done - # Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. --rm -f conftest.err conftest.$ac_ext -+rm -f conftest.i conftest.err conftest.$ac_ext - if $ac_preproc_ok; then : - break - fi -@@ -5557,7 +5569,7 @@ - # Broken: fails on valid input. - continue - fi --rm -f conftest.err conftest.$ac_ext -+rm -f conftest.err conftest.i conftest.$ac_ext - - # OK, works on sane cases. Now check whether nonexistent headers - # can be detected and how. -@@ -5573,18 +5585,18 @@ - ac_preproc_ok=: - break - fi --rm -f conftest.err conftest.$ac_ext -+rm -f conftest.err conftest.i conftest.$ac_ext - - done - # Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. --rm -f conftest.err conftest.$ac_ext -+rm -f conftest.i conftest.err conftest.$ac_ext - if $ac_preproc_ok; then : - - else - { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 - $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} --as_fn_error "C preprocessor \"$CPP\" fails sanity check --See \`config.log' for more details." "$LINENO" 5; } -+as_fn_error $? "C preprocessor \"$CPP\" fails sanity check -+See \`config.log' for more details" "$LINENO" 5 ; } - fi - - ac_ext=c -@@ -5626,7 +5638,7 @@ - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $fp_cv_context_diff" >&5 - $as_echo "$fp_cv_context_diff" >&6; } - if test x"$fp_cv_context_diff" = xno; then -- as_fn_error "cannot figure out how to do context diffs" "$LINENO" 5 -+ as_fn_error $? "cannot figure out how to do context diffs" "$LINENO" 5 - fi - ContextDiffCmd=$fp_cv_context_diff - -@@ -5772,7 +5784,7 @@ - - - if test -z "$fp_prog_ar_raw"; then -- as_fn_error "cannot find ar in your PATH, no idea how to make a library" "$LINENO" 5 -+ as_fn_error $? "cannot find ar in your PATH, no idea how to make a library" "$LINENO" 5 - fi - fp_prog_ar="$fp_prog_ar_raw" - case $HostPlatform in -@@ -5825,7 +5837,7 @@ - done - rm -f conftest* - if test -z "$fp_cv_prog_ar_args"; then -- as_fn_error "cannot figure out how to use your $fp_prog_ar_raw" "$LINENO" 5 -+ as_fn_error $? "cannot figure out how to use your $fp_prog_ar_raw" "$LINENO" 5 - fi - fi - fi -@@ -6596,7 +6608,7 @@ - if "$fp_ghc_pkg_guess" list > /dev/null 2>&1; then - fp_cv_matching_ghc_pkg=$fp_ghc_pkg_guess - else -- as_fn_error "Cannot find matching ghc-pkg" "$LINENO" 5 -+ as_fn_error $? "Cannot find matching ghc-pkg" "$LINENO" 5 - fi - fi - { $as_echo "$as_me:${as_lineno-$LINENO}: result: $fp_cv_matching_ghc_pkg" >&5 -@@ -6695,7 +6707,7 @@ - done - IFS=$fp_save_IFS - if test "$fp_num1" -lt "$fp_num2"; then : -- as_fn_error "Happy version 1.16 or later is required to compile GHC." "$LINENO" 5 -+ as_fn_error $? "Happy version 1.16 or later is required to compile GHC." "$LINENO" 5 - fi - fi - HappyVersion=$fptools_cv_happy_version; -@@ -6792,7 +6804,7 @@ - done - IFS=$fp_save_IFS - if test "$fp_num1" -lt "$fp_num2"; then : -- as_fn_error "Alex version 2.1.0 or later is required to compile GHC." "$LINENO" 5 -+ as_fn_error $? "Alex version 2.1.0 or later is required to compile GHC." "$LINENO" 5 - fi - fi - AlexVersion=$fptools_cv_alex_version; -@@ -6855,7 +6867,7 @@ - done - IFS=$as_save_IFS - if test -z "$ac_cv_path_GREP"; then -- as_fn_error "no acceptable grep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5 -+ as_fn_error $? "no acceptable grep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5 - fi - else - ac_cv_path_GREP=$GREP -@@ -6921,7 +6933,7 @@ - done - IFS=$as_save_IFS - if test -z "$ac_cv_path_EGREP"; then -- as_fn_error "no acceptable egrep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5 -+ as_fn_error $? "no acceptable egrep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5 - fi - else - ac_cv_path_EGREP=$EGREP -@@ -7253,8 +7265,7 @@ - as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` - ac_fn_c_check_header_compile "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default - " --eval as_val=\$$as_ac_Header -- if test "x$as_val" = x""yes; then : -+if eval test \"x\$"$as_ac_Header"\" = x"yes"; then : - cat >>confdefs.h <<_ACEOF - #define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 - _ACEOF -@@ -7268,8 +7279,7 @@ - do : - as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` - ac_fn_c_check_header_mongrel "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default" --eval as_val=\$$as_ac_Header -- if test "x$as_val" = x""yes; then : -+if eval test \"x\$"$as_ac_Header"\" = x"yes"; then : - cat >>confdefs.h <<_ACEOF - #define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 - _ACEOF -@@ -7341,9 +7351,8 @@ - if test "$ac_cv_type_char" = yes; then - { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 - $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} --{ as_fn_set_status 77 --as_fn_error "cannot compute sizeof (char) --See \`config.log' for more details." "$LINENO" 5; }; } -+as_fn_error 77 "cannot compute sizeof (char) -+See \`config.log' for more details" "$LINENO" 5 ; } - else - ac_cv_sizeof_char=0 - fi -@@ -7375,9 +7384,8 @@ - if test "$ac_cv_type_double" = yes; then - { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 - $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} --{ as_fn_set_status 77 --as_fn_error "cannot compute sizeof (double) --See \`config.log' for more details." "$LINENO" 5; }; } -+as_fn_error 77 "cannot compute sizeof (double) -+See \`config.log' for more details" "$LINENO" 5 ; } - else - ac_cv_sizeof_double=0 - fi -@@ -7409,9 +7417,8 @@ - if test "$ac_cv_type_float" = yes; then - { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 - $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} --{ as_fn_set_status 77 --as_fn_error "cannot compute sizeof (float) --See \`config.log' for more details." "$LINENO" 5; }; } -+as_fn_error 77 "cannot compute sizeof (float) -+See \`config.log' for more details" "$LINENO" 5 ; } - else - ac_cv_sizeof_float=0 - fi -@@ -7443,9 +7450,8 @@ - if test "$ac_cv_type_int" = yes; then - { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 - $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} --{ as_fn_set_status 77 --as_fn_error "cannot compute sizeof (int) --See \`config.log' for more details." "$LINENO" 5; }; } -+as_fn_error 77 "cannot compute sizeof (int) -+See \`config.log' for more details" "$LINENO" 5 ; } - else - ac_cv_sizeof_int=0 - fi -@@ -7477,9 +7483,8 @@ - if test "$ac_cv_type_long" = yes; then - { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 - $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} --{ as_fn_set_status 77 --as_fn_error "cannot compute sizeof (long) --See \`config.log' for more details." "$LINENO" 5; }; } -+as_fn_error 77 "cannot compute sizeof (long) -+See \`config.log' for more details" "$LINENO" 5 ; } - else - ac_cv_sizeof_long=0 - fi -@@ -7512,9 +7517,8 @@ - if test "$ac_cv_type_long_long" = yes; then - { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 - $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} --{ as_fn_set_status 77 --as_fn_error "cannot compute sizeof (long long) --See \`config.log' for more details." "$LINENO" 5; }; } -+as_fn_error 77 "cannot compute sizeof (long long) -+See \`config.log' for more details" "$LINENO" 5 ; } - else - ac_cv_sizeof_long_long=0 - fi -@@ -7547,9 +7551,8 @@ - if test "$ac_cv_type_short" = yes; then - { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 - $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} --{ as_fn_set_status 77 --as_fn_error "cannot compute sizeof (short) --See \`config.log' for more details." "$LINENO" 5; }; } -+as_fn_error 77 "cannot compute sizeof (short) -+See \`config.log' for more details" "$LINENO" 5 ; } - else - ac_cv_sizeof_short=0 - fi -@@ -7581,9 +7584,8 @@ - if test "$ac_cv_type_unsigned_char" = yes; then - { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 - $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} --{ as_fn_set_status 77 --as_fn_error "cannot compute sizeof (unsigned char) --See \`config.log' for more details." "$LINENO" 5; }; } -+as_fn_error 77 "cannot compute sizeof (unsigned char) -+See \`config.log' for more details" "$LINENO" 5 ; } - else - ac_cv_sizeof_unsigned_char=0 - fi -@@ -7615,9 +7617,8 @@ - if test "$ac_cv_type_unsigned_int" = yes; then - { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 - $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} --{ as_fn_set_status 77 --as_fn_error "cannot compute sizeof (unsigned int) --See \`config.log' for more details." "$LINENO" 5; }; } -+as_fn_error 77 "cannot compute sizeof (unsigned int) -+See \`config.log' for more details" "$LINENO" 5 ; } - else - ac_cv_sizeof_unsigned_int=0 - fi -@@ -7649,9 +7650,8 @@ - if test "$ac_cv_type_unsigned_long" = yes; then - { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 - $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} --{ as_fn_set_status 77 --as_fn_error "cannot compute sizeof (unsigned long) --See \`config.log' for more details." "$LINENO" 5; }; } -+as_fn_error 77 "cannot compute sizeof (unsigned long) -+See \`config.log' for more details" "$LINENO" 5 ; } - else - ac_cv_sizeof_unsigned_long=0 - fi -@@ -7684,9 +7684,8 @@ - if test "$ac_cv_type_unsigned_long_long" = yes; then - { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 - $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} --{ as_fn_set_status 77 --as_fn_error "cannot compute sizeof (unsigned long long) --See \`config.log' for more details." "$LINENO" 5; }; } -+as_fn_error 77 "cannot compute sizeof (unsigned long long) -+See \`config.log' for more details" "$LINENO" 5 ; } - else - ac_cv_sizeof_unsigned_long_long=0 - fi -@@ -7719,9 +7718,8 @@ - if test "$ac_cv_type_unsigned_short" = yes; then - { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 - $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} --{ as_fn_set_status 77 --as_fn_error "cannot compute sizeof (unsigned short) --See \`config.log' for more details." "$LINENO" 5; }; } -+as_fn_error 77 "cannot compute sizeof (unsigned short) -+See \`config.log' for more details" "$LINENO" 5 ; } - else - ac_cv_sizeof_unsigned_short=0 - fi -@@ -7753,9 +7751,8 @@ - if test "$ac_cv_type_void_p" = yes; then - { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 - $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} --{ as_fn_set_status 77 --as_fn_error "cannot compute sizeof (void *) --See \`config.log' for more details." "$LINENO" 5; }; } -+as_fn_error 77 "cannot compute sizeof (void *) -+See \`config.log' for more details" "$LINENO" 5 ; } - else - ac_cv_sizeof_void_p=0 - fi -@@ -7786,9 +7783,8 @@ - if ac_fn_c_compute_int "$LINENO" "(long) (&((struct { char c; char ty; } *)0)->ty)" "fp_cv_alignment_char" "$ac_includes_default"; then : - - else -- { as_fn_set_status 77 --as_fn_error "cannot compute alignment (char) --See \`config.log' for more details." "$LINENO" 5; } -+ as_fn_error 77 "cannot compute alignment (char) -+See \`config.log' for more details." "$LINENO" 5 - fi - - -@@ -7815,9 +7811,8 @@ - if ac_fn_c_compute_int "$LINENO" "(long) (&((struct { char c; double ty; } *)0)->ty)" "fp_cv_alignment_double" "$ac_includes_default"; then : - - else -- { as_fn_set_status 77 --as_fn_error "cannot compute alignment (double) --See \`config.log' for more details." "$LINENO" 5; } -+ as_fn_error 77 "cannot compute alignment (double) -+See \`config.log' for more details." "$LINENO" 5 - fi - - -@@ -7844,9 +7839,8 @@ - if ac_fn_c_compute_int "$LINENO" "(long) (&((struct { char c; float ty; } *)0)->ty)" "fp_cv_alignment_float" "$ac_includes_default"; then : - - else -- { as_fn_set_status 77 --as_fn_error "cannot compute alignment (float) --See \`config.log' for more details." "$LINENO" 5; } -+ as_fn_error 77 "cannot compute alignment (float) -+See \`config.log' for more details." "$LINENO" 5 - fi - - -@@ -7873,9 +7867,8 @@ - if ac_fn_c_compute_int "$LINENO" "(long) (&((struct { char c; int ty; } *)0)->ty)" "fp_cv_alignment_int" "$ac_includes_default"; then : - - else -- { as_fn_set_status 77 --as_fn_error "cannot compute alignment (int) --See \`config.log' for more details." "$LINENO" 5; } -+ as_fn_error 77 "cannot compute alignment (int) -+See \`config.log' for more details." "$LINENO" 5 - fi - - -@@ -7902,9 +7895,8 @@ - if ac_fn_c_compute_int "$LINENO" "(long) (&((struct { char c; long ty; } *)0)->ty)" "fp_cv_alignment_long" "$ac_includes_default"; then : - - else -- { as_fn_set_status 77 --as_fn_error "cannot compute alignment (long) --See \`config.log' for more details." "$LINENO" 5; } -+ as_fn_error 77 "cannot compute alignment (long) -+See \`config.log' for more details." "$LINENO" 5 - fi - - -@@ -7932,9 +7924,8 @@ - if ac_fn_c_compute_int "$LINENO" "(long) (&((struct { char c; long long ty; } *)0)->ty)" "fp_cv_alignment_long_long" "$ac_includes_default"; then : - - else -- { as_fn_set_status 77 --as_fn_error "cannot compute alignment (long long) --See \`config.log' for more details." "$LINENO" 5; } -+ as_fn_error 77 "cannot compute alignment (long long) -+See \`config.log' for more details." "$LINENO" 5 - fi - - -@@ -7962,9 +7953,8 @@ - if ac_fn_c_compute_int "$LINENO" "(long) (&((struct { char c; short ty; } *)0)->ty)" "fp_cv_alignment_short" "$ac_includes_default"; then : - - else -- { as_fn_set_status 77 --as_fn_error "cannot compute alignment (short) --See \`config.log' for more details." "$LINENO" 5; } -+ as_fn_error 77 "cannot compute alignment (short) -+See \`config.log' for more details." "$LINENO" 5 - fi - - -@@ -7991,9 +7981,8 @@ - if ac_fn_c_compute_int "$LINENO" "(long) (&((struct { char c; unsigned char ty; } *)0)->ty)" "fp_cv_alignment_unsigned_char" "$ac_includes_default"; then : - - else -- { as_fn_set_status 77 --as_fn_error "cannot compute alignment (unsigned char) --See \`config.log' for more details." "$LINENO" 5; } -+ as_fn_error 77 "cannot compute alignment (unsigned char) -+See \`config.log' for more details." "$LINENO" 5 - fi - - -@@ -8020,9 +8009,8 @@ - if ac_fn_c_compute_int "$LINENO" "(long) (&((struct { char c; unsigned int ty; } *)0)->ty)" "fp_cv_alignment_unsigned_int" "$ac_includes_default"; then : - - else -- { as_fn_set_status 77 --as_fn_error "cannot compute alignment (unsigned int) --See \`config.log' for more details." "$LINENO" 5; } -+ as_fn_error 77 "cannot compute alignment (unsigned int) -+See \`config.log' for more details." "$LINENO" 5 - fi - - -@@ -8049,9 +8037,8 @@ - if ac_fn_c_compute_int "$LINENO" "(long) (&((struct { char c; unsigned long ty; } *)0)->ty)" "fp_cv_alignment_unsigned_long" "$ac_includes_default"; then : - - else -- { as_fn_set_status 77 --as_fn_error "cannot compute alignment (unsigned long) --See \`config.log' for more details." "$LINENO" 5; } -+ as_fn_error 77 "cannot compute alignment (unsigned long) -+See \`config.log' for more details." "$LINENO" 5 - fi - - -@@ -8079,9 +8066,8 @@ - if ac_fn_c_compute_int "$LINENO" "(long) (&((struct { char c; unsigned long long ty; } *)0)->ty)" "fp_cv_alignment_unsigned_long_long" "$ac_includes_default"; then : - - else -- { as_fn_set_status 77 --as_fn_error "cannot compute alignment (unsigned long long) --See \`config.log' for more details." "$LINENO" 5; } -+ as_fn_error 77 "cannot compute alignment (unsigned long long) -+See \`config.log' for more details." "$LINENO" 5 - fi - - -@@ -8109,9 +8095,8 @@ - if ac_fn_c_compute_int "$LINENO" "(long) (&((struct { char c; unsigned short ty; } *)0)->ty)" "fp_cv_alignment_unsigned_short" "$ac_includes_default"; then : - - else -- { as_fn_set_status 77 --as_fn_error "cannot compute alignment (unsigned short) --See \`config.log' for more details." "$LINENO" 5; } -+ as_fn_error 77 "cannot compute alignment (unsigned short) -+See \`config.log' for more details." "$LINENO" 5 - fi - - -@@ -8125,8 +8110,9 @@ - #define ALIGNMENT_UNSIGNED_SHORT $fp_cv_alignment_unsigned_short - _ACEOF - --ac_fn_c_check_type "$LINENO" "void *" "ac_cv_type_void_p" "$ac_includes_default" --if test "x$ac_cv_type_void_p" = x""yes; then : -+as_ac_Type=`$as_echo "ac_cv_type_void *" | $as_tr_sh` -+ac_fn_c_check_type "$LINENO" "void *" "$as_ac_Type" "$ac_includes_default" -+if eval test \"x\$"$as_ac_Type"\" = x"yes"; then : - - fi - { $as_echo "$as_me:${as_lineno-$LINENO}: checking alignment of void *" >&5 -@@ -8138,9 +8124,8 @@ - if ac_fn_c_compute_int "$LINENO" "(long) (&((struct { char c; void * ty; } *)0)->ty)" "fp_cv_alignment_void_p" "$ac_includes_default"; then : - - else -- { as_fn_set_status 77 --as_fn_error "cannot compute alignment (void *) --See \`config.log' for more details." "$LINENO" 5; } -+ as_fn_error 77 "cannot compute alignment (void *) -+See \`config.log' for more details." "$LINENO" 5 - fi - - -@@ -8263,8 +8248,7 @@ - do : - as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` - ac_fn_c_check_func "$LINENO" "$ac_func" "$as_ac_var" --eval as_val=\$$as_ac_var -- if test "x$as_val" = x""yes; then : -+if eval test \"x\$"$as_ac_var"\" = x"yes"; then : - cat >>confdefs.h <<_ACEOF - #define `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1 - _ACEOF -@@ -8276,8 +8260,8 @@ - if test "$cross_compiling" = yes; then : - { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 - $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} --as_fn_error "cannot run test program while cross compiling --See \`config.log' for more details." "$LINENO" 5; } -+as_fn_error $? "cannot run test program while cross compiling -+See \`config.log' for more details" "$LINENO" 5 ; } - else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext - /* end confdefs.h. */ -@@ -8686,8 +8670,7 @@ - for ac_func in _getb67 GETB67 getb67; do - as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` - ac_fn_c_check_func "$LINENO" "$ac_func" "$as_ac_var" --eval as_val=\$$as_ac_var -- if test "x$as_val" = x""yes; then : -+if eval test \"x\$"$as_ac_var"\" = x"yes"; then : - - cat >>confdefs.h <<_ACEOF - #define CRAY_STACKSEG_END $ac_func -@@ -8777,8 +8760,7 @@ - do : - as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` - ac_fn_c_check_func "$LINENO" "$ac_func" "$as_ac_var" --eval as_val=\$$as_ac_var -- if test "x$as_val" = x""yes; then : -+if eval test \"x\$"$as_ac_var"\" = x"yes"; then : - cat >>confdefs.h <<_ACEOF - #define `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1 - _ACEOF -@@ -9277,8 +9259,8 @@ - - ;; #( - *) -- as_fn_error "unknown endianness -- presetting ac_cv_c_bigendian=no (or yes) will help" "$LINENO" 5 ;; -+ as_fn_error $? "unknown endianness -+ presetting ac_cv_c_bigendian=no (or yes) will help" "$LINENO" 5 ;; - esac - - { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether float word order is big endian" >&5 -@@ -9579,8 +9561,7 @@ - do : - as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` - ac_fn_c_check_func "$LINENO" "$ac_func" "$as_ac_var" --eval as_val=\$$as_ac_var -- if test "x$as_val" = x""yes; then : -+if eval test \"x\$"$as_ac_var"\" = x"yes"; then : - cat >>confdefs.h <<_ACEOF - #define `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1 - _ACEOF -@@ -9596,8 +9577,8 @@ - if test "$cross_compiling" = yes; then : - { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 - $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} --as_fn_error "cannot run test program while cross compiling --See \`config.log' for more details." "$LINENO" 5; } -+as_fn_error $? "cannot run test program while cross compiling -+See \`config.log' for more details" "$LINENO" 5 ; } - else - cat confdefs.h - <<_ACEOF >conftest.$ac_ext - /* end confdefs.h. */ -@@ -9966,7 +9947,7 @@ - - - if grep ' ' compiler/ghc.cabal.in 2>&1 >/dev/null; then -- as_fn_error "compiler/ghc.cabal.in contains tab characters; please remove them" "$LINENO" 5 -+ as_fn_error $? "compiler/ghc.cabal.in contains tab characters; please remove them" "$LINENO" 5 - fi - - ac_config_files="$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" -@@ -10056,6 +10037,7 @@ - - ac_libobjs= - ac_ltlibobjs= -+U= - for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue - # 1. Remove the extension, and $U if already installed. - ac_script='s/\$U\././;s/\.o$//;s/\.obj$//' -@@ -10218,19 +10200,19 @@ - (unset CDPATH) >/dev/null 2>&1 && unset CDPATH - - --# as_fn_error ERROR [LINENO LOG_FD] --# --------------------------------- -+# as_fn_error STATUS ERROR [LINENO LOG_FD] -+# ---------------------------------------- - # Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are - # provided, also output the error to LOG_FD, referencing LINENO. Then exit the --# script with status $?, using 1 if that was 0. -+# script with STATUS, using 1 if that was 0. - as_fn_error () - { -- as_status=$?; test $as_status -eq 0 && as_status=1 -- if test "$3"; then -- as_lineno=${as_lineno-"$2"} as_lineno_stack=as_lineno_stack=$as_lineno_stack -- $as_echo "$as_me:${as_lineno-$LINENO}: error: $1" >&$3 -+ as_status=$1; test $as_status -eq 0 && as_status=1 -+ if test "$4"; then -+ as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack -+ $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 - fi -- $as_echo "$as_me: error: $1" >&2 -+ $as_echo "$as_me: error: $2" >&2 - as_fn_exit $as_status - } # as_fn_error - -@@ -10426,7 +10408,7 @@ - test -d "$as_dir" && break - done - test -z "$as_dirs" || eval "mkdir $as_dirs" -- } || test -d "$as_dir" || as_fn_error "cannot create directory $as_dir" -+ } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" - - - } # as_fn_mkdir_p -@@ -10480,7 +10462,7 @@ +@@ -10533,7 +10533,7 @@ # values after options handling. ac_log=" - This file was extended by The Glorious Glasgow Haskell Compilation System $as_me 7.0.3, which was + This file was extended by The Glorious Glasgow Haskell Compilation System $as_me 7.2.1, which was -generated by GNU Autoconf 2.65. Invocation command line was -+generated by GNU Autoconf 2.67. Invocation command line was ++generated by GNU Autoconf 2.68. Invocation command line was CONFIG_FILES = $CONFIG_FILES CONFIG_HEADERS = $CONFIG_HEADERS -@@ -10546,10 +10528,10 @@ +@@ -10599,10 +10599,10 @@ ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" ac_cs_version="\\ - The Glorious Glasgow Haskell Compilation System config.status 7.0.3 + The Glorious Glasgow Haskell Compilation System config.status 7.2.1 -configured by $0, generated by GNU Autoconf 2.65, -+configured by $0, generated by GNU Autoconf 2.67, ++configured by $0, generated by GNU Autoconf 2.68, with options \\"\$ac_cs_config\\" -Copyright (C) 2009 Free Software Foundation, Inc. @@ -1396,247 +109,3 @@ This config.status script is free software; the Free Software Foundation gives unlimited permission to copy, distribute and modify it." -@@ -10565,11 +10547,16 @@ - while test $# != 0 - do - case $1 in -- --*=*) -+ --*=?*) - ac_option=`expr "X$1" : 'X\([^=]*\)='` - ac_optarg=`expr "X$1" : 'X[^=]*=\(.*\)'` - ac_shift=: - ;; -+ --*=) -+ ac_option=`expr "X$1" : 'X\([^=]*\)='` -+ ac_optarg= -+ ac_shift=: -+ ;; - *) - ac_option=$1 - ac_optarg=$2 -@@ -10591,6 +10578,7 @@ - $ac_shift - case $ac_optarg in - *\'*) ac_optarg=`$as_echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; -+ '') as_fn_error $? "missing file argument" ;; - esac - as_fn_append CONFIG_FILES " '$ac_optarg'" - ac_need_defaults=false;; -@@ -10603,7 +10591,7 @@ - ac_need_defaults=false;; - --he | --h) - # Conflict between --help and --header -- as_fn_error "ambiguous option: \`$1' -+ as_fn_error $? "ambiguous option: \`$1' - Try \`$0 --help' for more information.";; - --help | --hel | -h ) - $as_echo "$ac_cs_usage"; exit ;; -@@ -10612,7 +10600,7 @@ - ac_cs_silent=: ;; - - # This is an error. -- -*) as_fn_error "unrecognized option: \`$1' -+ -*) as_fn_error $? "unrecognized option: \`$1' - Try \`$0 --help' for more information." ;; - - *) as_fn_append ac_config_targets " $1" -@@ -10678,7 +10666,7 @@ - "distrib/configure.ac") CONFIG_FILES="$CONFIG_FILES distrib/configure.ac" ;; - "mk/stamp-h") CONFIG_COMMANDS="$CONFIG_COMMANDS mk/stamp-h" ;; - -- *) as_fn_error "invalid argument: \`$ac_config_target'" "$LINENO" 5;; -+ *) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5 ;; - esac - done - -@@ -10716,7 +10704,7 @@ - { - tmp=./conf$$-$RANDOM - (umask 077 && mkdir "$tmp") --} || as_fn_error "cannot create a temporary directory in ." "$LINENO" 5 -+} || as_fn_error $? "cannot create a temporary directory in ." "$LINENO" 5 - - # Set up the scripts for CONFIG_FILES section. - # No need to generate them if there are no CONFIG_FILES. -@@ -10733,7 +10721,7 @@ - fi - ac_cs_awk_cr=`$AWK 'BEGIN { print "a\rb" }' /dev/null` - if test "$ac_cs_awk_cr" = "a${ac_cr}b"; then -- ac_cs_awk_cr='\r' -+ ac_cs_awk_cr='\\r' - else - ac_cs_awk_cr=$ac_cr - fi -@@ -10747,18 +10735,18 @@ - echo "$ac_subst_vars" | sed 's/.*/&!$&$ac_delim/' && - echo "_ACEOF" - } >conf$$subs.sh || -- as_fn_error "could not make $CONFIG_STATUS" "$LINENO" 5 --ac_delim_num=`echo "$ac_subst_vars" | grep -c '$'` -+ as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 -+ac_delim_num=`echo "$ac_subst_vars" | grep -c '^'` - ac_delim='%!_!# ' - for ac_last_try in false false false false false :; do - . ./conf$$subs.sh || -- as_fn_error "could not make $CONFIG_STATUS" "$LINENO" 5 -+ as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 - - ac_delim_n=`sed -n "s/.*$ac_delim\$/X/p" conf$$subs.awk | grep -c X` - if test $ac_delim_n = $ac_delim_num; then - break - elif $ac_last_try; then -- as_fn_error "could not make $CONFIG_STATUS" "$LINENO" 5 -+ as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 - else - ac_delim="$ac_delim!$ac_delim _$ac_delim!! " - fi -@@ -10847,20 +10835,28 @@ - else - cat - fi < "$tmp/subs1.awk" > "$tmp/subs.awk" \ -- || as_fn_error "could not setup config files machinery" "$LINENO" 5 -+ || as_fn_error $? "could not setup config files machinery" "$LINENO" 5 - _ACEOF - --# VPATH may cause trouble with some makes, so we remove $(srcdir), --# ${srcdir} and @srcdir@ from VPATH if srcdir is ".", strip leading and -+# VPATH may cause trouble with some makes, so we remove sole $(srcdir), -+# ${srcdir} and @srcdir@ entries from VPATH if srcdir is ".", strip leading and - # trailing colons and then remove the whole line if VPATH becomes empty - # (actually we leave an empty line to preserve line numbers). - if test "x$srcdir" = x.; then -- ac_vpsub='/^[ ]*VPATH[ ]*=/{ --s/:*\$(srcdir):*/:/ --s/:*\${srcdir}:*/:/ --s/:*@srcdir@:*/:/ --s/^\([^=]*=[ ]*\):*/\1/ -+ ac_vpsub='/^[ ]*VPATH[ ]*=[ ]*/{ -+h -+s/// -+s/^/:/ -+s/[ ]*$/:/ -+s/:\$(srcdir):/:/g -+s/:\${srcdir}:/:/g -+s/:@srcdir@:/:/g -+s/^:*// - s/:*$// -+x -+s/\(=[ ]*\).*/\1/ -+G -+s/\n// - s/^[^=]*=[ ]*$// - }' - fi -@@ -10888,7 +10884,7 @@ - if test -z "$ac_t"; then - break - elif $ac_last_try; then -- as_fn_error "could not make $CONFIG_HEADERS" "$LINENO" 5 -+ as_fn_error $? "could not make $CONFIG_HEADERS" "$LINENO" 5 - else - ac_delim="$ac_delim!$ac_delim _$ac_delim!! " - fi -@@ -10973,7 +10969,7 @@ - _ACAWK - _ACEOF - cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 -- as_fn_error "could not setup config headers machinery" "$LINENO" 5 -+ as_fn_error $? "could not setup config headers machinery" "$LINENO" 5 - fi # test -n "$CONFIG_HEADERS" - - -@@ -10986,7 +10982,7 @@ - esac - case $ac_mode$ac_tag in - :[FHL]*:*);; -- :L* | :C*:*) as_fn_error "invalid tag \`$ac_tag'" "$LINENO" 5;; -+ :L* | :C*:*) as_fn_error $? "invalid tag \`$ac_tag'" "$LINENO" 5 ;; - :[FH]-) ac_tag=-:-;; - :[FH]*) ac_tag=$ac_tag:$ac_tag.in;; - esac -@@ -11014,7 +11010,7 @@ - [\\/$]*) false;; - *) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";; - esac || -- as_fn_error "cannot find input file: \`$ac_f'" "$LINENO" 5;; -+ as_fn_error 1 "cannot find input file: \`$ac_f'" "$LINENO" 5 ;; - esac - case $ac_f in *\'*) ac_f=`$as_echo "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac - as_fn_append ac_file_inputs " '$ac_f'" -@@ -11041,7 +11037,7 @@ - - case $ac_tag in - *:-:* | *:-) cat >"$tmp/stdin" \ -- || as_fn_error "could not create $ac_file" "$LINENO" 5 ;; -+ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; - esac - ;; - esac -@@ -11172,22 +11168,22 @@ - $ac_datarootdir_hack - " - eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$tmp/subs.awk" >$tmp/out \ -- || as_fn_error "could not create $ac_file" "$LINENO" 5 -+ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 - - test -z "$ac_datarootdir_hack$ac_datarootdir_seen" && - { ac_out=`sed -n '/\${datarootdir}/p' "$tmp/out"`; test -n "$ac_out"; } && - { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' "$tmp/out"`; test -z "$ac_out"; } && - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file contains a reference to the variable \`datarootdir' --which seems to be undefined. Please make sure it is defined." >&5 -+which seems to be undefined. Please make sure it is defined" >&5 - $as_echo "$as_me: WARNING: $ac_file contains a reference to the variable \`datarootdir' --which seems to be undefined. Please make sure it is defined." >&2;} -+which seems to be undefined. Please make sure it is defined" >&2;} - - rm -f "$tmp/stdin" - case $ac_file in - -) cat "$tmp/out" && rm -f "$tmp/out";; - *) rm -f "$ac_file" && mv "$tmp/out" "$ac_file";; - esac \ -- || as_fn_error "could not create $ac_file" "$LINENO" 5 -+ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 - ;; - :H) - # -@@ -11198,19 +11194,19 @@ - $as_echo "/* $configure_input */" \ - && eval '$AWK -f "$tmp/defines.awk"' "$ac_file_inputs" - } >"$tmp/config.h" \ -- || as_fn_error "could not create $ac_file" "$LINENO" 5 -+ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 - if diff "$ac_file" "$tmp/config.h" >/dev/null 2>&1; then - { $as_echo "$as_me:${as_lineno-$LINENO}: $ac_file is unchanged" >&5 - $as_echo "$as_me: $ac_file is unchanged" >&6;} - else - rm -f "$ac_file" - mv "$tmp/config.h" "$ac_file" \ -- || as_fn_error "could not create $ac_file" "$LINENO" 5 -+ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 - fi - else - $as_echo "/* $configure_input */" \ - && eval '$AWK -f "$tmp/defines.awk"' "$ac_file_inputs" \ -- || as_fn_error "could not create -" "$LINENO" 5 -+ || as_fn_error $? "could not create -" "$LINENO" 5 - fi - ;; - -@@ -11232,7 +11228,7 @@ - ac_clean_files=$ac_clean_files_save - - test $ac_write_fail = 0 || -- as_fn_error "write failure creating $CONFIG_STATUS" "$LINENO" 5 -+ as_fn_error $? "write failure creating $CONFIG_STATUS" "$LINENO" 5 - - - # configure is writing to config.log, and then calls config.status. -@@ -11253,7 +11249,7 @@ - exec 5>>config.log - # Use ||, not &&, to avoid exiting from the if with $? = 1, which - # would make configure fail if this is the last instruction. -- $ac_cs_success || as_fn_exit $? -+ $ac_cs_success || as_fn_exit 1 - fi - if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then - { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5 diff -Nru ghc-7.0.3/debian/patches/debian-changes-7.2.1-1 ghc-7.2.1/debian/patches/debian-changes-7.2.1-1 --- ghc-7.0.3/debian/patches/debian-changes-7.2.1-1 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/debian/patches/debian-changes-7.2.1-1 2011-08-23 19:00:09.000000000 +0000 @@ -0,0 +1,3032 @@ +Description: Upstream changes introduced in version 7.2.1-1 + This patch has been created by dpkg-source during the package build. + Here's the last changelog entry, hopefully it gives details on why + those changes were made: + . + ghc (7.2.1-1) experimental; urgency=low + . + * New upstream release. + . + The person named in the Author field signed this changelog entry. +Author: Joachim Breitner + +--- +The information above should follow the Patch Tagging Guidelines, please +checkout http://dep.debian.net/deps/dep3/ to learn about the format. Here +are templates for supplementary fields that you might want to add: + +Origin: , +Bug: +Bug-Debian: http://bugs.debian.org/ +Bug-Ubuntu: https://launchpad.net/bugs/ +Forwarded: +Reviewed-By: +Last-Update: + +--- ghc-7.2.1.orig/configure ++++ ghc-7.2.1/configure +@@ -91,6 +91,7 @@ fi + IFS=" "" $as_nl" + + # Find who we are. Look in the path if we contain no directory separator. ++as_myself= + case $0 in #(( + *[\\/]* ) as_myself=$0 ;; + *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +@@ -216,11 +217,18 @@ IFS=$as_save_IFS + # We cannot yet assume a decent shell, so we have to provide a + # neutralization value for shells without unset; and this also + # works around shells that cannot unset nonexistent variables. ++ # Preserve -v and -x to the replacement shell. + BASH_ENV=/dev/null + ENV=/dev/null + (unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV + export CONFIG_SHELL +- exec "$CONFIG_SHELL" "$as_myself" ${1+"$@"} ++ case $- in # (((( ++ *v*x* | *x*v* ) as_opts=-vx ;; ++ *v* ) as_opts=-v ;; ++ *x* ) as_opts=-x ;; ++ * ) as_opts= ;; ++ esac ++ exec "$CONFIG_SHELL" $as_opts "$as_myself" ${1+"$@"} + fi + + if test x$as_have_required = xno; then : +@@ -319,7 +327,7 @@ $as_echo X"$as_dir" | + test -d "$as_dir" && break + done + test -z "$as_dirs" || eval "mkdir $as_dirs" +- } || test -d "$as_dir" || as_fn_error "cannot create directory $as_dir" ++ } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" + + + } # as_fn_mkdir_p +@@ -359,19 +367,19 @@ else + fi # as_fn_arith + + +-# as_fn_error ERROR [LINENO LOG_FD] +-# --------------------------------- ++# as_fn_error STATUS ERROR [LINENO LOG_FD] ++# ---------------------------------------- + # Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are + # provided, also output the error to LOG_FD, referencing LINENO. Then exit the +-# script with status $?, using 1 if that was 0. ++# script with STATUS, using 1 if that was 0. + as_fn_error () + { +- as_status=$?; test $as_status -eq 0 && as_status=1 +- if test "$3"; then +- as_lineno=${as_lineno-"$2"} as_lineno_stack=as_lineno_stack=$as_lineno_stack +- $as_echo "$as_me:${as_lineno-$LINENO}: error: $1" >&$3 ++ as_status=$1; test $as_status -eq 0 && as_status=1 ++ if test "$4"; then ++ as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack ++ $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 + fi +- $as_echo "$as_me: error: $1" >&2 ++ $as_echo "$as_me: error: $2" >&2 + as_fn_exit $as_status + } # as_fn_error + +@@ -533,7 +541,7 @@ test -n "$DJDIR" || exec 7<&0 &1 + + # Name of the host. +-# hostname on some systems (SVR3.2, Linux) returns a bogus exit status, ++# hostname on some systems (SVR3.2, old GNU/Linux) returns a bogus exit status, + # so uname gets run too. + ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q` + +@@ -870,8 +878,9 @@ do + fi + + case $ac_option in +- *=*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;; +- *) ac_optarg=yes ;; ++ *=?*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;; ++ *=) ac_optarg= ;; ++ *) ac_optarg=yes ;; + esac + + # Accept the important Cygnus configure options, so we can diagnose typos. +@@ -916,7 +925,7 @@ do + ac_useropt=`expr "x$ac_option" : 'x-*disable-\(.*\)'` + # Reject names that are not valid shell variable names. + expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && +- as_fn_error "invalid feature name: $ac_useropt" ++ as_fn_error $? "invalid feature name: $ac_useropt" + ac_useropt_orig=$ac_useropt + ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` + case $ac_user_opts in +@@ -942,7 +951,7 @@ do + ac_useropt=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'` + # Reject names that are not valid shell variable names. + expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && +- as_fn_error "invalid feature name: $ac_useropt" ++ as_fn_error $? "invalid feature name: $ac_useropt" + ac_useropt_orig=$ac_useropt + ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` + case $ac_user_opts in +@@ -1146,7 +1155,7 @@ do + ac_useropt=`expr "x$ac_option" : 'x-*with-\([^=]*\)'` + # Reject names that are not valid shell variable names. + expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && +- as_fn_error "invalid package name: $ac_useropt" ++ as_fn_error $? "invalid package name: $ac_useropt" + ac_useropt_orig=$ac_useropt + ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` + case $ac_user_opts in +@@ -1162,7 +1171,7 @@ do + ac_useropt=`expr "x$ac_option" : 'x-*without-\(.*\)'` + # Reject names that are not valid shell variable names. + expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null && +- as_fn_error "invalid package name: $ac_useropt" ++ as_fn_error $? "invalid package name: $ac_useropt" + ac_useropt_orig=$ac_useropt + ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'` + case $ac_user_opts in +@@ -1192,8 +1201,8 @@ do + | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*) + x_libraries=$ac_optarg ;; + +- -*) as_fn_error "unrecognized option: \`$ac_option' +-Try \`$0 --help' for more information." ++ -*) as_fn_error $? "unrecognized option: \`$ac_option' ++Try \`$0 --help' for more information" + ;; + + *=*) +@@ -1201,7 +1210,7 @@ Try \`$0 --help' for more information." + # Reject names that are not valid shell variable names. + case $ac_envvar in #( + '' | [0-9]* | *[!_$as_cr_alnum]* ) +- as_fn_error "invalid variable name: \`$ac_envvar'" ;; ++ as_fn_error $? "invalid variable name: \`$ac_envvar'" ;; + esac + eval $ac_envvar=\$ac_optarg + export $ac_envvar ;; +@@ -1211,7 +1220,7 @@ Try \`$0 --help' for more information." + $as_echo "$as_me: WARNING: you should use --build, --host, --target" >&2 + expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null && + $as_echo "$as_me: WARNING: invalid host type: $ac_option" >&2 +- : ${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option} ++ : "${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}" + ;; + + esac +@@ -1219,13 +1228,13 @@ done + + if test -n "$ac_prev"; then + ac_option=--`echo $ac_prev | sed 's/_/-/g'` +- as_fn_error "missing argument to $ac_option" ++ as_fn_error $? "missing argument to $ac_option" + fi + + if test -n "$ac_unrecognized_opts"; then + case $enable_option_checking in + no) ;; +- fatal) as_fn_error "unrecognized options: $ac_unrecognized_opts" ;; ++ fatal) as_fn_error $? "unrecognized options: $ac_unrecognized_opts" ;; + *) $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2 ;; + esac + fi +@@ -1248,7 +1257,7 @@ do + [\\/$]* | ?:[\\/]* ) continue;; + NONE | '' ) case $ac_var in *prefix ) continue;; esac;; + esac +- as_fn_error "expected an absolute directory name for --$ac_var: $ac_val" ++ as_fn_error $? "expected an absolute directory name for --$ac_var: $ac_val" + done + + # There might be people who depend on the old broken behavior: `$host' +@@ -1262,8 +1271,8 @@ target=$target_alias + if test "x$host_alias" != x; then + if test "x$build_alias" = x; then + cross_compiling=maybe +- $as_echo "$as_me: WARNING: If you wanted to set the --build type, don't use --host. +- If a cross compiler is detected then cross compile mode will be used." >&2 ++ $as_echo "$as_me: WARNING: if you wanted to set the --build type, don't use --host. ++ If a cross compiler is detected then cross compile mode will be used" >&2 + elif test "x$build_alias" != "x$host_alias"; then + cross_compiling=yes + fi +@@ -1278,9 +1287,9 @@ test "$silent" = yes && exec 6>/dev/null + ac_pwd=`pwd` && test -n "$ac_pwd" && + ac_ls_di=`ls -di .` && + ac_pwd_ls_di=`cd "$ac_pwd" && ls -di .` || +- as_fn_error "working directory cannot be determined" ++ as_fn_error $? "working directory cannot be determined" + test "X$ac_ls_di" = "X$ac_pwd_ls_di" || +- as_fn_error "pwd does not report name of working directory" ++ as_fn_error $? "pwd does not report name of working directory" + + + # Find the source files, if location was not specified. +@@ -1319,11 +1328,11 @@ else + fi + if test ! -r "$srcdir/$ac_unique_file"; then + test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .." +- as_fn_error "cannot find sources ($ac_unique_file) in $srcdir" ++ as_fn_error $? "cannot find sources ($ac_unique_file) in $srcdir" + fi + ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work" + ac_abs_confdir=`( +- cd "$srcdir" && test -r "./$ac_unique_file" || as_fn_error "$ac_msg" ++ cd "$srcdir" && test -r "./$ac_unique_file" || as_fn_error $? "$ac_msg" + pwd)` + # When building in place, set srcdir=. + if test "$ac_abs_confdir" = "$ac_pwd"; then +@@ -1363,7 +1372,7 @@ Configuration: + --help=short display options specific to this package + --help=recursive display the short help of all the included packages + -V, --version display version information and exit +- -q, --quiet, --silent do not print \`checking...' messages ++ -q, --quiet, --silent do not print \`checking ...' messages + --cache-file=FILE cache test results in FILE [disabled] + -C, --config-cache alias for \`--cache-file=config.cache' + -n, --no-create do not create output files +@@ -1572,7 +1581,7 @@ sed 's/^/| /' conftest.$ac_ext >&5 + + ac_retval=1 + fi +- eval $as_lineno_stack; test "x$as_lineno_stack" = x && { as_lineno=; unset as_lineno;} ++ eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + as_fn_set_status $ac_retval + + } # ac_fn_c_try_compile +@@ -1598,7 +1607,7 @@ $as_echo "$ac_try_echo"; } >&5 + mv -f conftest.er1 conftest.err + fi + $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5 +- test $ac_status = 0; } >/dev/null && { ++ test $ac_status = 0; } > conftest.i && { + test -z "$ac_c_preproc_warn_flag$ac_c_werror_flag" || + test ! -s conftest.err + }; then : +@@ -1609,7 +1618,7 @@ sed 's/^/| /' conftest.$ac_ext >&5 + + ac_retval=1 + fi +- eval $as_lineno_stack; test "x$as_lineno_stack" = x && { as_lineno=; unset as_lineno;} ++ eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + as_fn_set_status $ac_retval + + } # ac_fn_c_try_cpp +@@ -1651,7 +1660,7 @@ sed 's/^/| /' conftest.$ac_ext >&5 + ac_retval=$ac_status + fi + rm -rf conftest.dSYM conftest_ipa8_conftest.oo +- eval $as_lineno_stack; test "x$as_lineno_stack" = x && { as_lineno=; unset as_lineno;} ++ eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + as_fn_set_status $ac_retval + + } # ac_fn_c_try_run +@@ -1664,10 +1673,10 @@ fi + ac_fn_c_check_header_mongrel () + { + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack +- if { as_var=$3; eval "test \"\${$as_var+set}\" = set"; }; then : ++ if eval \${$3+:} false; then : + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 + $as_echo_n "checking for $2... " >&6; } +-if { as_var=$3; eval "test \"\${$as_var+set}\" = set"; }; then : ++if eval \${$3+:} false; then : + $as_echo_n "(cached) " >&6 + fi + eval ac_res=\$$3 +@@ -1703,7 +1712,7 @@ if ac_fn_c_try_cpp "$LINENO"; then : + else + ac_header_preproc=no + fi +-rm -f conftest.err conftest.$ac_ext ++rm -f conftest.err conftest.i conftest.$ac_ext + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_header_preproc" >&5 + $as_echo "$ac_header_preproc" >&6; } + +@@ -1726,17 +1735,15 @@ $as_echo "$as_me: WARNING: $2: see the A + $as_echo "$as_me: WARNING: $2: section \"Present But Cannot Be Compiled\"" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $2: proceeding with the compiler's result" >&5 + $as_echo "$as_me: WARNING: $2: proceeding with the compiler's result" >&2;} +-( cat <<\_ASBOX +-## ----------------------------------------------- ## ++( $as_echo "## ----------------------------------------------- ## + ## Report this to glasgow-haskell-bugs@haskell.org ## +-## ----------------------------------------------- ## +-_ASBOX ++## ----------------------------------------------- ##" + ) | sed "s/^/$as_me: WARNING: /" >&2 + ;; + esac + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 + $as_echo_n "checking for $2... " >&6; } +-if { as_var=$3; eval "test \"\${$as_var+set}\" = set"; }; then : ++if eval \${$3+:} false; then : + $as_echo_n "(cached) " >&6 + else + eval "$3=\$ac_header_compiler" +@@ -1745,7 +1752,7 @@ eval ac_res=\$$3 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 + $as_echo "$ac_res" >&6; } + fi +- eval $as_lineno_stack; test "x$as_lineno_stack" = x && { as_lineno=; unset as_lineno;} ++ eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + + } # ac_fn_c_check_header_mongrel + +@@ -1758,7 +1765,7 @@ ac_fn_c_check_header_compile () + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 + $as_echo_n "checking for $2... " >&6; } +-if { as_var=$3; eval "test \"\${$as_var+set}\" = set"; }; then : ++if eval \${$3+:} false; then : + $as_echo_n "(cached) " >&6 + else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +@@ -1776,7 +1783,7 @@ fi + eval ac_res=\$$3 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 + $as_echo "$ac_res" >&6; } +- eval $as_lineno_stack; test "x$as_lineno_stack" = x && { as_lineno=; unset as_lineno;} ++ eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + + } # ac_fn_c_check_header_compile + +@@ -1789,7 +1796,7 @@ ac_fn_c_check_type () + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 + $as_echo_n "checking for $2... " >&6; } +-if { as_var=$3; eval "test \"\${$as_var+set}\" = set"; }; then : ++if eval \${$3+:} false; then : + $as_echo_n "(cached) " >&6 + else + eval "$3=no" +@@ -1830,7 +1837,7 @@ fi + eval ac_res=\$$3 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 + $as_echo "$ac_res" >&6; } +- eval $as_lineno_stack; test "x$as_lineno_stack" = x && { as_lineno=; unset as_lineno;} ++ eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + + } # ac_fn_c_check_type + +@@ -2007,7 +2014,7 @@ rm -f core *.core core.conftest.* gmon.o + rm -f conftest.val + + fi +- eval $as_lineno_stack; test "x$as_lineno_stack" = x && { as_lineno=; unset as_lineno;} ++ eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + as_fn_set_status $ac_retval + + } # ac_fn_c_compute_int +@@ -2053,7 +2060,7 @@ fi + # interfere with the next link command; also delete a directory that is + # left behind by Apple's compiler. We do this before executing the actions. + rm -rf conftest.dSYM conftest_ipa8_conftest.oo +- eval $as_lineno_stack; test "x$as_lineno_stack" = x && { as_lineno=; unset as_lineno;} ++ eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + as_fn_set_status $ac_retval + + } # ac_fn_c_try_link +@@ -2066,7 +2073,7 @@ ac_fn_c_check_func () + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5 + $as_echo_n "checking for $2... " >&6; } +-if { as_var=$3; eval "test \"\${$as_var+set}\" = set"; }; then : ++if eval \${$3+:} false; then : + $as_echo_n "(cached) " >&6 + else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +@@ -2121,19 +2128,22 @@ fi + eval ac_res=\$$3 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 + $as_echo "$ac_res" >&6; } +- eval $as_lineno_stack; test "x$as_lineno_stack" = x && { as_lineno=; unset as_lineno;} ++ eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + + } # ac_fn_c_check_func + +-# ac_fn_c_check_decl LINENO SYMBOL VAR +-# ------------------------------------ +-# Tests whether SYMBOL is declared, setting cache variable VAR accordingly. ++# ac_fn_c_check_decl LINENO SYMBOL VAR INCLUDES ++# --------------------------------------------- ++# Tests whether SYMBOL is declared in INCLUDES, setting cache variable VAR ++# accordingly. + ac_fn_c_check_decl () + { + as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack +- { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $2 is declared" >&5 +-$as_echo_n "checking whether $2 is declared... " >&6; } +-if { as_var=$3; eval "test \"\${$as_var+set}\" = set"; }; then : ++ as_decl_name=`echo $2|sed 's/ *(.*//'` ++ as_decl_use=`echo $2|sed -e 's/(/((/' -e 's/)/) 0&/' -e 's/,/) 0& (/g'` ++ { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $as_decl_name is declared" >&5 ++$as_echo_n "checking whether $as_decl_name is declared... " >&6; } ++if eval \${$3+:} false; then : + $as_echo_n "(cached) " >&6 + else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +@@ -2142,8 +2152,12 @@ $4 + int + main () + { +-#ifndef $2 +- (void) $2; ++#ifndef $as_decl_name ++#ifdef __cplusplus ++ (void) $as_decl_use; ++#else ++ (void) $as_decl_name; ++#endif + #endif + + ; +@@ -2160,7 +2174,7 @@ fi + eval ac_res=\$$3 + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5 + $as_echo "$ac_res" >&6; } +- eval $as_lineno_stack; test "x$as_lineno_stack" = x && { as_lineno=; unset as_lineno;} ++ eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno + + } # ac_fn_c_check_decl + cat >config.log <<_ACEOF +@@ -2278,11 +2292,9 @@ trap 'exit_status=$? + { + echo + +- cat <<\_ASBOX +-## ---------------- ## ++ $as_echo "## ---------------- ## + ## Cache variables. ## +-## ---------------- ## +-_ASBOX ++## ---------------- ##" + echo + # The following way of writing the cache mishandles newlines in values, + ( +@@ -2316,11 +2328,9 @@ $as_echo "$as_me: WARNING: cache variabl + ) + echo + +- cat <<\_ASBOX +-## ----------------- ## ++ $as_echo "## ----------------- ## + ## Output variables. ## +-## ----------------- ## +-_ASBOX ++## ----------------- ##" + echo + for ac_var in $ac_subst_vars + do +@@ -2333,11 +2343,9 @@ _ASBOX + echo + + if test -n "$ac_subst_files"; then +- cat <<\_ASBOX +-## ------------------- ## ++ $as_echo "## ------------------- ## + ## File substitutions. ## +-## ------------------- ## +-_ASBOX ++## ------------------- ##" + echo + for ac_var in $ac_subst_files + do +@@ -2351,11 +2359,9 @@ _ASBOX + fi + + if test -s confdefs.h; then +- cat <<\_ASBOX +-## ----------- ## ++ $as_echo "## ----------- ## + ## confdefs.h. ## +-## ----------- ## +-_ASBOX ++## ----------- ##" + echo + cat confdefs.h + echo +@@ -2410,7 +2416,12 @@ _ACEOF + ac_site_file1=NONE + ac_site_file2=NONE + if test -n "$CONFIG_SITE"; then +- ac_site_file1=$CONFIG_SITE ++ # We do not want a PATH search for config.site. ++ case $CONFIG_SITE in #(( ++ -*) ac_site_file1=./$CONFIG_SITE;; ++ */*) ac_site_file1=$CONFIG_SITE;; ++ *) ac_site_file1=./$CONFIG_SITE;; ++ esac + elif test "x$prefix" != xNONE; then + ac_site_file1=$prefix/share/config.site + ac_site_file2=$prefix/etc/config.site +@@ -2425,7 +2436,11 @@ do + { $as_echo "$as_me:${as_lineno-$LINENO}: loading site script $ac_site_file" >&5 + $as_echo "$as_me: loading site script $ac_site_file" >&6;} + sed 's/^/| /' "$ac_site_file" >&5 +- . "$ac_site_file" ++ . "$ac_site_file" \ ++ || { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 ++$as_echo "$as_me: error: in \`$ac_pwd':" >&2;} ++as_fn_error $? "failed to load site script $ac_site_file ++See \`config.log' for more details" "$LINENO" 5; } + fi + done + +@@ -2501,7 +2516,7 @@ if $ac_cache_corrupted; then + $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} + { $as_echo "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5 + $as_echo "$as_me: error: changes in the environment can compromise the build" >&2;} +- as_fn_error "run \`make distclean' and/or \`rm $cache_file' and start over" "$LINENO" 5 ++ as_fn_error $? "run \`make distclean' and/or \`rm $cache_file' and start over" "$LINENO" 5 + fi + ## -------------------- ## + ## Main body of script. ## +@@ -2541,7 +2556,7 @@ do + set dummy $ac_prog; ac_word=$2 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 + $as_echo_n "checking for $ac_word... " >&6; } +-if test "${ac_cv_path_fp_prog_find+set}" = set; then : ++if ${ac_cv_path_fp_prog_find+:} false; then : + $as_echo_n "(cached) " >&6 + else + case $fp_prog_find in +@@ -2604,7 +2619,7 @@ $as_echo "$as_me: WARNING: $fp_prog_find + set dummy find; ac_word=$2 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 + $as_echo_n "checking for $ac_word... " >&6; } +-if test "${ac_cv_prog_FindCmd+set}" = set; then : ++if ${ac_cv_prog_FindCmd+:} false; then : + $as_echo_n "(cached) " >&6 + else + if test -n "$FindCmd"; then +@@ -2662,7 +2677,7 @@ rm -f conftest.txt conftest.out + set dummy sort; ac_word=$2 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 + $as_echo_n "checking for $ac_word... " >&6; } +-if test "${ac_cv_path_fp_prog_sort+set}" = set; then : ++if ${ac_cv_path_fp_prog_sort+:} false; then : + $as_echo_n "(cached) " >&6 + else + case $fp_prog_sort in +@@ -2711,7 +2726,7 @@ $as_echo "$as_me: WARNING: $fp_prog_sort + set dummy sort; ac_word=$2 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 + $as_echo_n "checking for $ac_word... " >&6; } +-if test "${ac_cv_prog_SortCmd+set}" = set; then : ++if ${ac_cv_prog_SortCmd+:} false; then : + $as_echo_n "(cached) " >&6 + else + if test -n "$SortCmd"; then +@@ -2776,7 +2791,7 @@ $as_echo "given $PACKAGE_VERSION" >&6; } + elif test -d .git; then + ver_date=`git log -n 1 --date=short --pretty=format:%ci | cut -d ' ' -f 1 | tr -d -` + if echo $ver_date | grep '^[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9]$' 2>&1 >/dev/null; then true; else +- as_fn_error "failed to detect version date: check that git is in your path" "$LINENO" 5 ++ as_fn_error $? "failed to detect version date: check that git is in your path" "$LINENO" 5 + fi + PACKAGE_VERSION=${PACKAGE_VERSION}.$ver_date + { $as_echo "$as_me:${as_lineno-$LINENO}: result: inferred $PACKAGE_VERSION" >&5 +@@ -2785,7 +2800,7 @@ $as_echo "inferred $PACKAGE_VERSION" >&6 + # TODO: Remove this branch after conversion to Git + ver_date=`darcs changes --quiet --no-summary --xml | head -500 | grep 'date=' | sed "s/^.*date='\([0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9]\).*$/\1/g" | ${SortCmd} -n | tail -1` + if echo $ver_date | grep '^[0-9][0-9][0-9][0-9][0-9][0-9][0-9][0-9]$' 2>&1 >/dev/null; then true; else +- as_fn_error "failed to detect version date: check that darcs is in your path" "$LINENO" 5 ++ as_fn_error $? "failed to detect version date: check that darcs is in your path" "$LINENO" 5 + fi + PACKAGE_VERSION=${PACKAGE_VERSION}.$ver_date + { $as_echo "$as_me:${as_lineno-$LINENO}: result: inferred $PACKAGE_VERSION" >&5 +@@ -2816,7 +2831,7 @@ ProjectPatchLevel=`echo $VERSION_TMP | s + case $VERSION_MINOR in + ?) ProjectVersionInt=${VERSION_MAJOR}0${VERSION_MINOR} ;; + ??) ProjectVersionInt=${VERSION_MAJOR}${VERSION_MINOR} ;; +- *) as_fn_error "bad minor version in $PACKAGE_VERSION" "$LINENO" 5 ;; ++ *) as_fn_error $? "bad minor version in $PACKAGE_VERSION" "$LINENO" 5 ;; + esac + + +@@ -2863,7 +2878,7 @@ else + set dummy ghc; ac_word=$2 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 + $as_echo_n "checking for $ac_word... " >&6; } +-if test "${ac_cv_path_GHC+set}" = set; then : ++if ${ac_cv_path_GHC+:} false; then : + $as_echo_n "(cached) " >&6 + else + case $GHC in +@@ -2966,7 +2981,7 @@ $as_echo "$fptools_version_of_ghc" >&6; + + + if test "$GhcMajVersion" = "unknown" -o "$GhcMinVersion" = "unknown"; then +- as_fn_error "Cannot determine the version of $WithGhc. Is it really GHC?" "$LINENO" 5 ++ as_fn_error $? "Cannot determine the version of $WithGhc. Is it really GHC?" "$LINENO" 5 + fi + + GhcMinVersion2=`echo "$GhcMinVersion" | sed 's/^\\(.\\)$/0\\1/'` +@@ -3013,7 +3028,7 @@ fi + + if test "$BootingFromHc" = "NO"; then + if test "$WithGhc" = ""; then +- as_fn_error "GHC is required unless bootstrapping from .hc files." "$LINENO" 5 ++ as_fn_error $? "GHC is required unless bootstrapping from .hc files." "$LINENO" 5 + fi + fp_version1=$GhcVersion; fp_version2=6.12 + fp_save_IFS=$IFS; IFS='.' +@@ -3036,11 +3051,11 @@ do + done + IFS=$fp_save_IFS + if test "$fp_num1" -lt "$fp_num2"; then : +- as_fn_error "GHC version 6.12 or later is required to compile GHC." "$LINENO" 5 ++ as_fn_error $? "GHC version 6.12 or later is required to compile GHC." "$LINENO" 5 + fi + if test `expr $GhcMinVersion % 2` = "1"; then + if test "$EnableBootstrapWithDevelSnaphost" = "NO"; then +- as_fn_error " ++ as_fn_error $? " + $WithGhc is a development snapshot of GHC, version $GhcVersion. + Bootstrapping using this version of GHC is not supported, and may not + work. Use --enable-bootstrap-with-devel-snapshot to try it anyway, +@@ -3125,16 +3140,22 @@ fi + # results in the following code + ac_aux_dir= + for ac_dir in "$srcdir" "$srcdir/.." "$srcdir/../.."; do +- for ac_t in install-sh install.sh shtool; do +- if test -f "$ac_dir/$ac_t"; then +- ac_aux_dir=$ac_dir +- ac_install_sh="$ac_aux_dir/$ac_t -c" +- break 2 +- fi +- done ++ if test -f "$ac_dir/install-sh"; then ++ ac_aux_dir=$ac_dir ++ ac_install_sh="$ac_aux_dir/install-sh -c" ++ break ++ elif test -f "$ac_dir/install.sh"; then ++ ac_aux_dir=$ac_dir ++ ac_install_sh="$ac_aux_dir/install.sh -c" ++ break ++ elif test -f "$ac_dir/shtool"; then ++ ac_aux_dir=$ac_dir ++ ac_install_sh="$ac_aux_dir/shtool install -c" ++ break ++ fi + done + if test -z "$ac_aux_dir"; then +- as_fn_error "cannot find install-sh, install.sh, or shtool in \"$srcdir\" \"$srcdir/..\" \"$srcdir/../..\"" "$LINENO" 5 ++ as_fn_error $? "cannot find install-sh, install.sh, or shtool in \"$srcdir\" \"$srcdir/..\" \"$srcdir/../..\"" "$LINENO" 5 + fi + + # These three variables are undocumented and unsupported, +@@ -3148,27 +3169,27 @@ ac_configure="$SHELL $ac_aux_dir/configu + + # Make sure we can run config.sub. + $SHELL "$ac_aux_dir/config.sub" sun4 >/dev/null 2>&1 || +- as_fn_error "cannot run $SHELL $ac_aux_dir/config.sub" "$LINENO" 5 ++ as_fn_error $? "cannot run $SHELL $ac_aux_dir/config.sub" "$LINENO" 5 + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking build system type" >&5 + $as_echo_n "checking build system type... " >&6; } +-if test "${ac_cv_build+set}" = set; then : ++if ${ac_cv_build+:} false; then : + $as_echo_n "(cached) " >&6 + else + ac_build_alias=$build_alias + test "x$ac_build_alias" = x && + ac_build_alias=`$SHELL "$ac_aux_dir/config.guess"` + test "x$ac_build_alias" = x && +- as_fn_error "cannot guess build type; you must specify one" "$LINENO" 5 ++ as_fn_error $? "cannot guess build type; you must specify one" "$LINENO" 5 + ac_cv_build=`$SHELL "$ac_aux_dir/config.sub" $ac_build_alias` || +- as_fn_error "$SHELL $ac_aux_dir/config.sub $ac_build_alias failed" "$LINENO" 5 ++ as_fn_error $? "$SHELL $ac_aux_dir/config.sub $ac_build_alias failed" "$LINENO" 5 + + fi + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_build" >&5 + $as_echo "$ac_cv_build" >&6; } + case $ac_cv_build in + *-*-*) ;; +-*) as_fn_error "invalid value of canonical build" "$LINENO" 5;; ++*) as_fn_error $? "invalid value of canonical build" "$LINENO" 5;; + esac + build=$ac_cv_build + ac_save_IFS=$IFS; IFS='-' +@@ -3186,14 +3207,14 @@ case $build_os in *\ *) build_os=`echo " + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking host system type" >&5 + $as_echo_n "checking host system type... " >&6; } +-if test "${ac_cv_host+set}" = set; then : ++if ${ac_cv_host+:} false; then : + $as_echo_n "(cached) " >&6 + else + if test "x$host_alias" = x; then + ac_cv_host=$ac_cv_build + else + ac_cv_host=`$SHELL "$ac_aux_dir/config.sub" $host_alias` || +- as_fn_error "$SHELL $ac_aux_dir/config.sub $host_alias failed" "$LINENO" 5 ++ as_fn_error $? "$SHELL $ac_aux_dir/config.sub $host_alias failed" "$LINENO" 5 + fi + + fi +@@ -3201,7 +3222,7 @@ fi + $as_echo "$ac_cv_host" >&6; } + case $ac_cv_host in + *-*-*) ;; +-*) as_fn_error "invalid value of canonical host" "$LINENO" 5;; ++*) as_fn_error $? "invalid value of canonical host" "$LINENO" 5;; + esac + host=$ac_cv_host + ac_save_IFS=$IFS; IFS='-' +@@ -3219,14 +3240,14 @@ case $host_os in *\ *) host_os=`echo "$h + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking target system type" >&5 + $as_echo_n "checking target system type... " >&6; } +-if test "${ac_cv_target+set}" = set; then : ++if ${ac_cv_target+:} false; then : + $as_echo_n "(cached) " >&6 + else + if test "x$target_alias" = x; then + ac_cv_target=$ac_cv_host + else + ac_cv_target=`$SHELL "$ac_aux_dir/config.sub" $target_alias` || +- as_fn_error "$SHELL $ac_aux_dir/config.sub $target_alias failed" "$LINENO" 5 ++ as_fn_error $? "$SHELL $ac_aux_dir/config.sub $target_alias failed" "$LINENO" 5 + fi + + fi +@@ -3234,7 +3255,7 @@ fi + $as_echo "$ac_cv_target" >&6; } + case $ac_cv_target in + *-*-*) ;; +-*) as_fn_error "invalid value of canonical target" "$LINENO" 5;; ++*) as_fn_error $? "invalid value of canonical target" "$LINENO" 5;; + esac + target=$ac_cv_target + ac_save_IFS=$IFS; IFS='-' +@@ -3762,9 +3783,9 @@ fi + $as_echo "$as_me: Building in-tree ghc-pwd" >&6;} + rm -rf utils/ghc-pwd/dist-boot + mkdir utils/ghc-pwd/dist-boot +- if ! "$WithGhc" -v0 -no-user-package-conf -hidir utils/ghc-pwd/dist-boot -odir utils/ghc-pwd/dist-boot -stubdir utils/ghc-pwd/dist-boot --make utils/ghc-pwd/Main.hs -o utils/ghc-pwd/dist-boot/ghc-pwd ++ if ! "$WithGhc" -optl-pthread -v0 -no-user-package-conf -hidir utils/ghc-pwd/dist-boot -odir utils/ghc-pwd/dist-boot -stubdir utils/ghc-pwd/dist-boot --make utils/ghc-pwd/Main.hs -o utils/ghc-pwd/dist-boot/ghc-pwd + then +- as_fn_error "Building ghc-pwd failed" "$LINENO" 5 ++ as_fn_error $? "Building ghc-pwd failed" "$LINENO" 5 + fi + + GHC_PWD=utils/ghc-pwd/dist-boot/ghc-pwd +@@ -3777,12 +3798,12 @@ $as_echo_n "checking for path to top of + hardtop=`echo $hardtop | sed 's|^/tmp_mnt.*\(/local/.*\)$|\1|' | sed 's|^/tmp_mnt/|/|'` + + if ! test -d "$hardtop"; then +- as_fn_error "cannot determine current directory" "$LINENO" 5 ++ as_fn_error $? "cannot determine current directory" "$LINENO" 5 + fi + + case "$hardtop" in + *' '*) +- as_fn_error " ++ as_fn_error $? " + The build system does not support building in a directory + containing space characters. + Suggestion: move the build tree somewhere else." "$LINENO" 5 +@@ -3841,7 +3862,7 @@ $as_echo "$as_me: Making in-tree mingw t + PATH=`pwd`/inplace/mingw/bin:$PATH inplace/mingw/bin/realgcc.exe driver/gcc/gcc.c driver/utils/cwrapper.c driver/utils/getLocation.c -Idriver/utils -o inplace/mingw/bin/gcc.exe + if ! test -e inplace/mingw/bin/gcc.exe + then +- as_fn_error "GHC is required unless bootstrapping from .hc files." "$LINENO" 5 ++ as_fn_error $? "GHC is required unless bootstrapping from .hc files." "$LINENO" 5 + fi + { $as_echo "$as_me:${as_lineno-$LINENO}: In-tree mingw tree created" >&5 + $as_echo "$as_me: In-tree mingw tree created" >&6;} +@@ -4003,7 +4024,7 @@ else + set dummy gcc; ac_word=$2 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 + $as_echo_n "checking for $ac_word... " >&6; } +-if test "${ac_cv_path_CC+set}" = set; then : ++if ${ac_cv_path_CC+:} false; then : + $as_echo_n "(cached) " >&6 + else + case $CC in +@@ -4041,7 +4062,7 @@ fi + + if test -z "$CC" + then +- as_fn_error "cannot find gcc in your PATH, no idea how to link" "$LINENO" 5 ++ as_fn_error $? "cannot find gcc in your PATH, no idea how to link" "$LINENO" 5 + fi + fi + +@@ -4076,7 +4097,7 @@ else + set dummy ld; ac_word=$2 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 + $as_echo_n "checking for $ac_word... " >&6; } +-if test "${ac_cv_path_LD+set}" = set; then : ++if ${ac_cv_path_LD+:} false; then : + $as_echo_n "(cached) " >&6 + else + case $LD in +@@ -4114,7 +4135,7 @@ fi + + if test -z "$LD" + then +- as_fn_error "cannot find ld in your PATH, no idea how to link" "$LINENO" 5 ++ as_fn_error $? "cannot find ld in your PATH, no idea how to link" "$LINENO" 5 + fi + fi + +@@ -4146,7 +4167,7 @@ else + set dummy nm; ac_word=$2 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 + $as_echo_n "checking for $ac_word... " >&6; } +-if test "${ac_cv_path_NM+set}" = set; then : ++if ${ac_cv_path_NM+:} false; then : + $as_echo_n "(cached) " >&6 + else + case $NM in +@@ -4184,7 +4205,7 @@ fi + + if test -z "$NM" + then +- as_fn_error "cannot find nm in your PATH, no idea how to link" "$LINENO" 5 ++ as_fn_error $? "cannot find nm in your PATH, no idea how to link" "$LINENO" 5 + fi + fi + +@@ -4231,7 +4252,7 @@ $as_echo_n "checking Mac OS X deployment + $as_echo "none" >&6; } + else + if test ! -d $MACOSX_DEPLOYMENT_SDK; then +- as_fn_error "Unknown deployment target $FP_MACOSX_DEPLOYMENT_TARGET" "$LINENO" 5 ++ as_fn_error $? "Unknown deployment target $FP_MACOSX_DEPLOYMENT_TARGET" "$LINENO" 5 + fi + { $as_echo "$as_me:${as_lineno-$LINENO}: result: ${MACOSX_DEPLOYMENT_VERSION} (${MACOSX_DEPLOYMENT_SDK})" >&5 + $as_echo "${MACOSX_DEPLOYMENT_VERSION} (${MACOSX_DEPLOYMENT_SDK})" >&6; } +@@ -4254,7 +4275,7 @@ fi + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether #! works in shell scripts" >&5 + $as_echo_n "checking whether #! works in shell scripts... " >&6; } +-if test "${ac_cv_sys_interpreter+set}" = set; then : ++if ${ac_cv_sys_interpreter+:} false; then : + $as_echo_n "(cached) " >&6 + else + echo '#! /bin/cat +@@ -4283,7 +4304,7 @@ cygwin32|mingw32) + set dummy perl; ac_word=$2 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 + $as_echo_n "checking for $ac_word... " >&6; } +-if test "${ac_cv_path_PerlCmd+set}" = set; then : ++if ${ac_cv_path_PerlCmd+:} false; then : + $as_echo_n "(cached) " >&6 + else + case $PerlCmd in +@@ -4329,7 +4350,7 @@ fi + if grep "v5" conftest.out >/dev/null 2>&1; then + : + else +- as_fn_error "your version of perl probably won't work, try upgrading it." "$LINENO" 5 ++ as_fn_error $? "your version of perl probably won't work, try upgrading it." "$LINENO" 5 + fi + rm -fr conftest* + +@@ -4339,7 +4360,7 @@ esac + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking if your perl works in shell scripts" >&5 + $as_echo_n "checking if your perl works in shell scripts... " >&6; } +-if test "${fptools_cv_shebang_perl+set}" = set; then : ++if ${fptools_cv_shebang_perl+:} false; then : + $as_echo_n "(cached) " >&6 + else + echo "#!$PerlCmd"' +@@ -4362,7 +4383,7 @@ $as_echo "$fptools_cv_shebang_perl" >&6; + set dummy python; ac_word=$2 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 + $as_echo_n "checking for $ac_word... " >&6; } +-if test "${ac_cv_path_PythonCmd+set}" = set; then : ++if ${ac_cv_path_PythonCmd+:} false; then : + $as_echo_n "(cached) " >&6 + else + case $PythonCmd in +@@ -4409,7 +4430,7 @@ if test -n "$ac_tool_prefix"; then + set dummy ${ac_tool_prefix}gcc; ac_word=$2 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 + $as_echo_n "checking for $ac_word... " >&6; } +-if test "${ac_cv_prog_CC+set}" = set; then : ++if ${ac_cv_prog_CC+:} false; then : + $as_echo_n "(cached) " >&6 + else + if test -n "$CC"; then +@@ -4449,7 +4470,7 @@ if test -z "$ac_cv_prog_CC"; then + set dummy gcc; ac_word=$2 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 + $as_echo_n "checking for $ac_word... " >&6; } +-if test "${ac_cv_prog_ac_ct_CC+set}" = set; then : ++if ${ac_cv_prog_ac_ct_CC+:} false; then : + $as_echo_n "(cached) " >&6 + else + if test -n "$ac_ct_CC"; then +@@ -4502,7 +4523,7 @@ if test -z "$CC"; then + set dummy ${ac_tool_prefix}cc; ac_word=$2 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 + $as_echo_n "checking for $ac_word... " >&6; } +-if test "${ac_cv_prog_CC+set}" = set; then : ++if ${ac_cv_prog_CC+:} false; then : + $as_echo_n "(cached) " >&6 + else + if test -n "$CC"; then +@@ -4542,7 +4563,7 @@ if test -z "$CC"; then + set dummy cc; ac_word=$2 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 + $as_echo_n "checking for $ac_word... " >&6; } +-if test "${ac_cv_prog_CC+set}" = set; then : ++if ${ac_cv_prog_CC+:} false; then : + $as_echo_n "(cached) " >&6 + else + if test -n "$CC"; then +@@ -4601,7 +4622,7 @@ if test -z "$CC"; then + set dummy $ac_tool_prefix$ac_prog; ac_word=$2 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 + $as_echo_n "checking for $ac_word... " >&6; } +-if test "${ac_cv_prog_CC+set}" = set; then : ++if ${ac_cv_prog_CC+:} false; then : + $as_echo_n "(cached) " >&6 + else + if test -n "$CC"; then +@@ -4645,7 +4666,7 @@ do + set dummy $ac_prog; ac_word=$2 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 + $as_echo_n "checking for $ac_word... " >&6; } +-if test "${ac_cv_prog_ac_ct_CC+set}" = set; then : ++if ${ac_cv_prog_ac_ct_CC+:} false; then : + $as_echo_n "(cached) " >&6 + else + if test -n "$ac_ct_CC"; then +@@ -4699,8 +4720,8 @@ fi + + test -z "$CC" && { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 + $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +-as_fn_error "no acceptable C compiler found in \$PATH +-See \`config.log' for more details." "$LINENO" 5; } ++as_fn_error $? "no acceptable C compiler found in \$PATH ++See \`config.log' for more details" "$LINENO" 5; } + + # Provide some information about the compiler. + $as_echo "$as_me:${as_lineno-$LINENO}: checking for C compiler version" >&5 +@@ -4814,9 +4835,8 @@ sed 's/^/| /' conftest.$ac_ext >&5 + + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 + $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +-{ as_fn_set_status 77 +-as_fn_error "C compiler cannot create executables +-See \`config.log' for more details." "$LINENO" 5; }; } ++as_fn_error 77 "C compiler cannot create executables ++See \`config.log' for more details" "$LINENO" 5; } + else + { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 + $as_echo "yes" >&6; } +@@ -4858,8 +4878,8 @@ done + else + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 + $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +-as_fn_error "cannot compute suffix of executables: cannot compile and link +-See \`config.log' for more details." "$LINENO" 5; } ++as_fn_error $? "cannot compute suffix of executables: cannot compile and link ++See \`config.log' for more details" "$LINENO" 5; } + fi + rm -f conftest conftest$ac_cv_exeext + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_exeext" >&5 +@@ -4916,9 +4936,9 @@ $as_echo "$ac_try_echo"; } >&5 + else + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 + $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +-as_fn_error "cannot run C compiled programs. ++as_fn_error $? "cannot run C compiled programs. + If you meant to cross compile, use \`--host'. +-See \`config.log' for more details." "$LINENO" 5; } ++See \`config.log' for more details" "$LINENO" 5; } + fi + fi + fi +@@ -4929,7 +4949,7 @@ rm -f conftest.$ac_ext conftest$ac_cv_ex + ac_clean_files=$ac_clean_files_save + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for suffix of object files" >&5 + $as_echo_n "checking for suffix of object files... " >&6; } +-if test "${ac_cv_objext+set}" = set; then : ++if ${ac_cv_objext+:} false; then : + $as_echo_n "(cached) " >&6 + else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +@@ -4969,8 +4989,8 @@ sed 's/^/| /' conftest.$ac_ext >&5 + + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 + $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +-as_fn_error "cannot compute suffix of object files: cannot compile +-See \`config.log' for more details." "$LINENO" 5; } ++as_fn_error $? "cannot compute suffix of object files: cannot compile ++See \`config.log' for more details" "$LINENO" 5; } + fi + rm -f conftest.$ac_cv_objext conftest.$ac_ext + fi +@@ -4980,7 +5000,7 @@ OBJEXT=$ac_cv_objext + ac_objext=$OBJEXT + { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are using the GNU C compiler" >&5 + $as_echo_n "checking whether we are using the GNU C compiler... " >&6; } +-if test "${ac_cv_c_compiler_gnu+set}" = set; then : ++if ${ac_cv_c_compiler_gnu+:} false; then : + $as_echo_n "(cached) " >&6 + else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +@@ -5017,7 +5037,7 @@ ac_test_CFLAGS=${CFLAGS+set} + ac_save_CFLAGS=$CFLAGS + { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $CC accepts -g" >&5 + $as_echo_n "checking whether $CC accepts -g... " >&6; } +-if test "${ac_cv_prog_cc_g+set}" = set; then : ++if ${ac_cv_prog_cc_g+:} false; then : + $as_echo_n "(cached) " >&6 + else + ac_save_c_werror_flag=$ac_c_werror_flag +@@ -5095,7 +5115,7 @@ else + fi + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $CC option to accept ISO C89" >&5 + $as_echo_n "checking for $CC option to accept ISO C89... " >&6; } +-if test "${ac_cv_prog_cc_c89+set}" = set; then : ++if ${ac_cv_prog_cc_c89+:} false; then : + $as_echo_n "(cached) " >&6 + else + ac_cv_prog_cc_c89=no +@@ -5193,13 +5213,13 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu + + if test -z "$GCC" + then +- as_fn_error "gcc is required" "$LINENO" 5 ++ as_fn_error $? "gcc is required" "$LINENO" 5 + fi + GccLT34=NO + GccLT46=NO + { $as_echo "$as_me:${as_lineno-$LINENO}: checking version of gcc" >&5 + $as_echo_n "checking version of gcc... " >&6; } +-if test "${fp_cv_gcc_version+set}" = set; then : ++if ${fp_cv_gcc_version+:} false; then : + $as_echo_n "(cached) " >&6 + else + +@@ -5225,7 +5245,7 @@ do + done + IFS=$fp_save_IFS + if test "$fp_num1" -lt "$fp_num2"; then : +- as_fn_error "Need at least gcc version 3.0 (3.4+ recommended)" "$LINENO" 5 ++ as_fn_error $? "Need at least gcc version 3.0 (3.4+ recommended)" "$LINENO" 5 + fi + # 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 +@@ -5467,7 +5487,7 @@ $as_echo "done" >&6; } + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for extra options to pass gcc when compiling via C" >&5 + $as_echo_n "checking for extra options to pass gcc when compiling via C... " >&6; } +-if test "${fp_cv_gcc_extra_opts+set}" = set; then : ++if ${fp_cv_gcc_extra_opts+:} false; then : + $as_echo_n "(cached) " >&6 + else + fp_cv_gcc_extra_opts= +@@ -5514,7 +5534,7 @@ if test -n "$CPP" && test -d "$CPP"; the + CPP= + fi + if test -z "$CPP"; then +- if test "${ac_cv_prog_CPP+set}" = set; then : ++ if ${ac_cv_prog_CPP+:} false; then : + $as_echo_n "(cached) " >&6 + else + # Double quotes because CPP needs to be expanded +@@ -5544,7 +5564,7 @@ else + # Broken: fails on valid input. + continue + fi +-rm -f conftest.err conftest.$ac_ext ++rm -f conftest.err conftest.i conftest.$ac_ext + + # OK, works on sane cases. Now check whether nonexistent headers + # can be detected and how. +@@ -5560,11 +5580,11 @@ else + ac_preproc_ok=: + break + fi +-rm -f conftest.err conftest.$ac_ext ++rm -f conftest.err conftest.i conftest.$ac_ext + + done + # Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. +-rm -f conftest.err conftest.$ac_ext ++rm -f conftest.i conftest.err conftest.$ac_ext + if $ac_preproc_ok; then : + break + fi +@@ -5603,7 +5623,7 @@ else + # Broken: fails on valid input. + continue + fi +-rm -f conftest.err conftest.$ac_ext ++rm -f conftest.err conftest.i conftest.$ac_ext + + # OK, works on sane cases. Now check whether nonexistent headers + # can be detected and how. +@@ -5619,18 +5639,18 @@ else + ac_preproc_ok=: + break + fi +-rm -f conftest.err conftest.$ac_ext ++rm -f conftest.err conftest.i conftest.$ac_ext + + done + # Because of `break', _AC_PREPROC_IFELSE's cleaning code was skipped. +-rm -f conftest.err conftest.$ac_ext ++rm -f conftest.i conftest.err conftest.$ac_ext + if $ac_preproc_ok; then : + + else + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 + $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +-as_fn_error "C preprocessor \"$CPP\" fails sanity check +-See \`config.log' for more details." "$LINENO" 5; } ++as_fn_error $? "C preprocessor \"$CPP\" fails sanity check ++See \`config.log' for more details" "$LINENO" 5; } + fi + + ac_ext=c +@@ -5680,7 +5700,7 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for a working context diff" >&5 + $as_echo_n "checking for a working context diff... " >&6; } +-if test "${fp_cv_context_diff+set}" = set; then : ++if ${fp_cv_context_diff+:} false; then : + $as_echo_n "(cached) " >&6 + else + echo foo > conftest1 +@@ -5697,7 +5717,7 @@ fi + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $fp_cv_context_diff" >&5 + $as_echo "$fp_cv_context_diff" >&6; } + if test x"$fp_cv_context_diff" = xno; then +- as_fn_error "cannot figure out how to do context diffs" "$LINENO" 5 ++ as_fn_error $? "cannot figure out how to do context diffs" "$LINENO" 5 + fi + ContextDiffCmd=$fp_cv_context_diff + +@@ -5721,7 +5741,7 @@ chmod +x install-sh + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for a BSD-compatible install" >&5 + $as_echo_n "checking for a BSD-compatible install... " >&6; } + if test -z "$INSTALL"; then +-if test "${ac_cv_path_install+set}" = set; then : ++if ${ac_cv_path_install+:} false; then : + $as_echo_n "(cached) " >&6 + else + as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +@@ -5806,7 +5826,7 @@ $as_echo "#define HAVE_BIN_SH 1" >>confd + set dummy ar; ac_word=$2 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 + $as_echo_n "checking for $ac_word... " >&6; } +-if test "${ac_cv_path_fp_prog_ar_raw+set}" = set; then : ++if ${ac_cv_path_fp_prog_ar_raw+:} false; then : + $as_echo_n "(cached) " >&6 + else + case $fp_prog_ar_raw in +@@ -5843,7 +5863,7 @@ fi + + + if test -z "$fp_prog_ar_raw"; then +- as_fn_error "cannot find ar in your PATH, no idea how to make a library" "$LINENO" 5 ++ as_fn_error $? "cannot find ar in your PATH, no idea how to make a library" "$LINENO" 5 + fi + fp_prog_ar="$fp_prog_ar_raw" + case $HostPlatform in +@@ -5858,7 +5878,7 @@ esac + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $fp_prog_ar_raw is GNU ar" >&5 + $as_echo_n "checking whether $fp_prog_ar_raw is GNU ar... " >&6; } +-if test "${fp_cv_prog_ar_is_gnu+set}" = set; then : ++if ${fp_cv_prog_ar_is_gnu+:} false; then : + $as_echo_n "(cached) " >&6 + else + if "$fp_prog_ar_raw" --version 2> /dev/null | grep "GNU" > /dev/null 2>&1; then +@@ -5876,7 +5896,7 @@ ArIsGNUAr=`echo $fp_prog_ar_is_gnu | tr + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for ar arguments" >&5 + $as_echo_n "checking for ar arguments... " >&6; } +-if test "${fp_cv_prog_ar_args+set}" = set; then : ++if ${fp_cv_prog_ar_args+:} false; then : + $as_echo_n "(cached) " >&6 + else + +@@ -5896,7 +5916,7 @@ else + done + rm -f conftest* + if test -z "$fp_cv_prog_ar_args"; then +- as_fn_error "cannot figure out how to use your $fp_prog_ar_raw" "$LINENO" 5 ++ as_fn_error $? "cannot figure out how to use your $fp_prog_ar_raw" "$LINENO" 5 + fi + fi + fi +@@ -5913,7 +5933,7 @@ ArArgs="$fp_prog_ar_args" + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $fp_prog_ar_raw supports @file" >&5 + $as_echo_n "checking whether $fp_prog_ar_raw supports @file... " >&6; } +-if test "${fp_cv_prog_ar_supports_atfile+set}" = set; then : ++if ${fp_cv_prog_ar_supports_atfile+:} false; then : + $as_echo_n "(cached) " >&6 + else + +@@ -5942,7 +5962,7 @@ ArSupportsAtFile=`echo $fp_prog_ar_suppo + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether ranlib is needed" >&5 + $as_echo_n "checking whether ranlib is needed... " >&6; } +-if test "${fp_cv_prog_ar_needs_ranlib+set}" = set; then : ++if ${fp_cv_prog_ar_needs_ranlib+:} false; then : + $as_echo_n "(cached) " >&6 + else + if test $fp_prog_ar_is_gnu = yes; then +@@ -5965,7 +5985,7 @@ if test $fp_cv_prog_ar_needs_ranlib = ye + set dummy ${ac_tool_prefix}ranlib; ac_word=$2 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 + $as_echo_n "checking for $ac_word... " >&6; } +-if test "${ac_cv_prog_RANLIB+set}" = set; then : ++if ${ac_cv_prog_RANLIB+:} false; then : + $as_echo_n "(cached) " >&6 + else + if test -n "$RANLIB"; then +@@ -6005,7 +6025,7 @@ if test -z "$ac_cv_prog_RANLIB"; then + set dummy ranlib; ac_word=$2 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 + $as_echo_n "checking for $ac_word... " >&6; } +-if test "${ac_cv_prog_ac_ct_RANLIB+set}" = set; then : ++if ${ac_cv_prog_ac_ct_RANLIB+:} false; then : + $as_echo_n "(cached) " >&6 + else + if test -n "$ac_ct_RANLIB"; then +@@ -6077,7 +6097,7 @@ do + set dummy $ac_prog; ac_word=$2 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 + $as_echo_n "checking for $ac_word... " >&6; } +-if test "${ac_cv_path_SedCmd+set}" = set; then : ++if ${ac_cv_path_SedCmd+:} false; then : + $as_echo_n "(cached) " >&6 + else + case $SedCmd in +@@ -6123,7 +6143,7 @@ test -n "$SedCmd" || SedCmd="sed" + set dummy time; ac_word=$2 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 + $as_echo_n "checking for $ac_word... " >&6; } +-if test "${ac_cv_path_TimeCmd+set}" = set; then : ++if ${ac_cv_path_TimeCmd+:} false; then : + $as_echo_n "(cached) " >&6 + else + case $TimeCmd in +@@ -6166,7 +6186,7 @@ do + set dummy $ac_prog; ac_word=$2 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 + $as_echo_n "checking for $ac_word... " >&6; } +-if test "${ac_cv_path_TarCmd+set}" = set; then : ++if ${ac_cv_path_TarCmd+:} false; then : + $as_echo_n "(cached) " >&6 + else + case $TarCmd in +@@ -6213,7 +6233,7 @@ do + set dummy $ac_prog; ac_word=$2 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 + $as_echo_n "checking for $ac_word... " >&6; } +-if test "${ac_cv_path_PatchCmd+set}" = set; then : ++if ${ac_cv_path_PatchCmd+:} false; then : + $as_echo_n "(cached) " >&6 + else + case $PatchCmd in +@@ -6259,7 +6279,7 @@ HaveDtrace=NO + set dummy dtrace; ac_word=$2 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 + $as_echo_n "checking for $ac_word... " >&6; } +-if test "${ac_cv_path_DtraceCmd+set}" = set; then : ++if ${ac_cv_path_DtraceCmd+:} false; then : + $as_echo_n "(cached) " >&6 + else + case $DtraceCmd in +@@ -6306,7 +6326,7 @@ fi + set dummy HsColour; ac_word=$2 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 + $as_echo_n "checking for $ac_word... " >&6; } +-if test "${ac_cv_path_HSCOLOUR+set}" = set; then : ++if ${ac_cv_path_HSCOLOUR+:} false; then : + $as_echo_n "(cached) " >&6 + else + case $HSCOLOUR in +@@ -6355,7 +6375,7 @@ fi + set dummy xmllint; ac_word=$2 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 + $as_echo_n "checking for $ac_word... " >&6; } +-if test "${ac_cv_path_XmllintCmd+set}" = set; then : ++if ${ac_cv_path_XmllintCmd+:} false; then : + $as_echo_n "(cached) " >&6 + else + case $XmllintCmd in +@@ -6441,7 +6461,7 @@ fi + set dummy xsltproc; ac_word=$2 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 + $as_echo_n "checking for $ac_word... " >&6; } +-if test "${ac_cv_path_XsltprocCmd+set}" = set; then : ++if ${ac_cv_path_XsltprocCmd+:} false; then : + $as_echo_n "(cached) " >&6 + else + case $XsltprocCmd in +@@ -6485,7 +6505,7 @@ fi + if test -n "$XsltprocCmd"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for DocBook XSL stylesheet" >&5 + $as_echo_n "checking for DocBook XSL stylesheet... " >&6; } +-if test "${fp_cv_dir_docbook_xsl+set}" = set; then : ++if ${fp_cv_dir_docbook_xsl+:} false; then : + $as_echo_n "(cached) " >&6 + else + rm -f conftest.xml conftest-book.xml +@@ -6534,7 +6554,7 @@ fi + set dummy dblatex; ac_word=$2 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 + $as_echo_n "checking for $ac_word... " >&6; } +-if test "${ac_cv_path_DblatexCmd+set}" = set; then : ++if ${ac_cv_path_DblatexCmd+:} false; then : + $as_echo_n "(cached) " >&6 + else + case $DblatexCmd in +@@ -6578,7 +6598,7 @@ fi + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for ghc-pkg matching $WithGhc" >&5 + $as_echo_n "checking for ghc-pkg matching $WithGhc... " >&6; } +-if test "${fp_cv_matching_ghc_pkg+set}" = set; then : ++if ${fp_cv_matching_ghc_pkg+:} false; then : + $as_echo_n "(cached) " >&6 + else + +@@ -6591,7 +6611,7 @@ fp_ghc_pkg_guess=`echo $WithGhc | sed -e + if "$fp_ghc_pkg_guess" list > /dev/null 2>&1; then + fp_cv_matching_ghc_pkg=$fp_ghc_pkg_guess + else +- as_fn_error "Cannot find matching ghc-pkg" "$LINENO" 5 ++ as_fn_error $? "Cannot find matching ghc-pkg" "$LINENO" 5 + fi + fi + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $fp_cv_matching_ghc_pkg" >&5 +@@ -6605,7 +6625,7 @@ if test "$BootingFromHc" = "NO"; then + set dummy happy; ac_word=$2 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 + $as_echo_n "checking for $ac_word... " >&6; } +-if test "${ac_cv_path_HappyCmd+set}" = set; then : ++if ${ac_cv_path_HappyCmd+:} false; then : + $as_echo_n "(cached) " >&6 + else + case $HappyCmd in +@@ -6654,7 +6674,7 @@ fi + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for version of happy" >&5 + $as_echo_n "checking for version of happy... " >&6; } +-if test "${fptools_cv_happy_version+set}" = set; then : ++if ${fptools_cv_happy_version+:} false; then : + $as_echo_n "(cached) " >&6 + else + if test x"$HappyCmd" != x; then +@@ -6690,7 +6710,7 @@ do + done + IFS=$fp_save_IFS + if test "$fp_num1" -lt "$fp_num2"; then : +- as_fn_error "Happy version 1.16 or later is required to compile GHC." "$LINENO" 5 ++ as_fn_error $? "Happy version 1.16 or later is required to compile GHC." "$LINENO" 5 + fi + fi + HappyVersion=$fptools_cv_happy_version; +@@ -6704,7 +6724,7 @@ if test "$BootingFromHc" = "NO"; then + set dummy alex; ac_word=$2 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 + $as_echo_n "checking for $ac_word... " >&6; } +-if test "${ac_cv_path_AlexCmd+set}" = set; then : ++if ${ac_cv_path_AlexCmd+:} false; then : + $as_echo_n "(cached) " >&6 + else + case $AlexCmd in +@@ -6751,7 +6771,7 @@ fi + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for version of alex" >&5 + $as_echo_n "checking for version of alex... " >&6; } +-if test "${fptools_cv_alex_version+set}" = set; then : ++if ${fptools_cv_alex_version+:} false; then : + $as_echo_n "(cached) " >&6 + else + if test x"$AlexCmd" != x; then +@@ -6787,7 +6807,7 @@ do + done + IFS=$fp_save_IFS + if test "$fp_num1" -lt "$fp_num2"; then : +- as_fn_error "Alex version 2.1.0 or later is required to compile GHC." "$LINENO" 5 ++ as_fn_error $? "Alex version 2.1.0 or later is required to compile GHC." "$LINENO" 5 + fi + fi + AlexVersion=$fptools_cv_alex_version; +@@ -6801,7 +6821,7 @@ fi; + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for grep that handles long lines and -e" >&5 + $as_echo_n "checking for grep that handles long lines and -e... " >&6; } +-if test "${ac_cv_path_GREP+set}" = set; then : ++if ${ac_cv_path_GREP+:} false; then : + $as_echo_n "(cached) " >&6 + else + if test -z "$GREP"; then +@@ -6850,7 +6870,7 @@ esac + done + IFS=$as_save_IFS + if test -z "$ac_cv_path_GREP"; then +- as_fn_error "no acceptable grep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5 ++ as_fn_error $? "no acceptable grep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5 + fi + else + ac_cv_path_GREP=$GREP +@@ -6864,7 +6884,7 @@ $as_echo "$ac_cv_path_GREP" >&6; } + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for egrep" >&5 + $as_echo_n "checking for egrep... " >&6; } +-if test "${ac_cv_path_EGREP+set}" = set; then : ++if ${ac_cv_path_EGREP+:} false; then : + $as_echo_n "(cached) " >&6 + else + if echo a | $GREP -E '(a|b)' >/dev/null 2>&1 +@@ -6916,7 +6936,7 @@ esac + done + IFS=$as_save_IFS + if test -z "$ac_cv_path_EGREP"; then +- as_fn_error "no acceptable egrep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5 ++ as_fn_error $? "no acceptable egrep could be found in $PATH$PATH_SEPARATOR/usr/xpg4/bin" "$LINENO" 5 + fi + else + ac_cv_path_EGREP=$EGREP +@@ -6931,7 +6951,7 @@ $as_echo "$ac_cv_path_EGREP" >&6; } + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for ANSI C header files" >&5 + $as_echo_n "checking for ANSI C header files... " >&6; } +-if test "${ac_cv_header_stdc+set}" = set; then : ++if ${ac_cv_header_stdc+:} false; then : + $as_echo_n "(cached) " >&6 + else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +@@ -7051,7 +7071,7 @@ if test "$enable_largefile" != no; then + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for special C compiler options needed for large files" >&5 + $as_echo_n "checking for special C compiler options needed for large files... " >&6; } +-if test "${ac_cv_sys_largefile_CC+set}" = set; then : ++if ${ac_cv_sys_largefile_CC+:} false; then : + $as_echo_n "(cached) " >&6 + else + ac_cv_sys_largefile_CC=no +@@ -7102,7 +7122,7 @@ $as_echo "$ac_cv_sys_largefile_CC" >&6; + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for _FILE_OFFSET_BITS value needed for large files" >&5 + $as_echo_n "checking for _FILE_OFFSET_BITS value needed for large files... " >&6; } +-if test "${ac_cv_sys_file_offset_bits+set}" = set; then : ++if ${ac_cv_sys_file_offset_bits+:} false; then : + $as_echo_n "(cached) " >&6 + else + while :; do +@@ -7171,7 +7191,7 @@ rm -rf conftest* + if test $ac_cv_sys_file_offset_bits = unknown; then + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for _LARGE_FILES value needed for large files" >&5 + $as_echo_n "checking for _LARGE_FILES value needed for large files... " >&6; } +-if test "${ac_cv_sys_large_files+set}" = set; then : ++if ${ac_cv_sys_large_files+:} false; then : + $as_echo_n "(cached) " >&6 + else + while :; do +@@ -7248,8 +7268,7 @@ do : + as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` + ac_fn_c_check_header_compile "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default + " +-eval as_val=\$$as_ac_Header +- if test "x$as_val" = x""yes; then : ++if eval test \"x\$"$as_ac_Header"\" = x"yes"; then : + cat >>confdefs.h <<_ACEOF + #define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 + _ACEOF +@@ -7263,8 +7282,7 @@ for ac_header in bfd.h ctype.h dirent.h + do : + as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` + ac_fn_c_check_header_mongrel "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default" +-eval as_val=\$$as_ac_Header +- if test "x$as_val" = x""yes; then : ++if eval test \"x\$"$as_ac_Header"\" = x"yes"; then : + cat >>confdefs.h <<_ACEOF + #define `$as_echo "HAVE_$ac_header" | $as_tr_cpp` 1 + _ACEOF +@@ -7276,7 +7294,7 @@ done + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether time.h and sys/time.h may both be included" >&5 + $as_echo_n "checking whether time.h and sys/time.h may both be included... " >&6; } +-if test "${ac_cv_header_time+set}" = set; then : ++if ${ac_cv_header_time+:} false; then : + $as_echo_n "(cached) " >&6 + else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +@@ -7311,7 +7329,7 @@ fi + + + ac_fn_c_check_type "$LINENO" "long long" "ac_cv_type_long_long" "$ac_includes_default" +-if test "x$ac_cv_type_long_long" = x""yes; then : ++if test "x$ac_cv_type_long_long" = xyes; then : + + cat >>confdefs.h <<_ACEOF + #define HAVE_LONG_LONG 1 +@@ -7327,7 +7345,7 @@ fi + # This bug is HP SR number 8606223364. + { $as_echo "$as_me:${as_lineno-$LINENO}: checking size of char" >&5 + $as_echo_n "checking size of char... " >&6; } +-if test "${ac_cv_sizeof_char+set}" = set; then : ++if ${ac_cv_sizeof_char+:} false; then : + $as_echo_n "(cached) " >&6 + else + if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (char))" "ac_cv_sizeof_char" "$ac_includes_default"; then : +@@ -7336,9 +7354,8 @@ else + if test "$ac_cv_type_char" = yes; then + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 + $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +-{ as_fn_set_status 77 +-as_fn_error "cannot compute sizeof (char) +-See \`config.log' for more details." "$LINENO" 5; }; } ++as_fn_error 77 "cannot compute sizeof (char) ++See \`config.log' for more details" "$LINENO" 5; } + else + ac_cv_sizeof_char=0 + fi +@@ -7361,7 +7378,7 @@ _ACEOF + # This bug is HP SR number 8606223364. + { $as_echo "$as_me:${as_lineno-$LINENO}: checking size of double" >&5 + $as_echo_n "checking size of double... " >&6; } +-if test "${ac_cv_sizeof_double+set}" = set; then : ++if ${ac_cv_sizeof_double+:} false; then : + $as_echo_n "(cached) " >&6 + else + if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (double))" "ac_cv_sizeof_double" "$ac_includes_default"; then : +@@ -7370,9 +7387,8 @@ else + if test "$ac_cv_type_double" = yes; then + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 + $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +-{ as_fn_set_status 77 +-as_fn_error "cannot compute sizeof (double) +-See \`config.log' for more details." "$LINENO" 5; }; } ++as_fn_error 77 "cannot compute sizeof (double) ++See \`config.log' for more details" "$LINENO" 5; } + else + ac_cv_sizeof_double=0 + fi +@@ -7395,7 +7411,7 @@ _ACEOF + # This bug is HP SR number 8606223364. + { $as_echo "$as_me:${as_lineno-$LINENO}: checking size of float" >&5 + $as_echo_n "checking size of float... " >&6; } +-if test "${ac_cv_sizeof_float+set}" = set; then : ++if ${ac_cv_sizeof_float+:} false; then : + $as_echo_n "(cached) " >&6 + else + if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (float))" "ac_cv_sizeof_float" "$ac_includes_default"; then : +@@ -7404,9 +7420,8 @@ else + if test "$ac_cv_type_float" = yes; then + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 + $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +-{ as_fn_set_status 77 +-as_fn_error "cannot compute sizeof (float) +-See \`config.log' for more details." "$LINENO" 5; }; } ++as_fn_error 77 "cannot compute sizeof (float) ++See \`config.log' for more details" "$LINENO" 5; } + else + ac_cv_sizeof_float=0 + fi +@@ -7429,7 +7444,7 @@ _ACEOF + # This bug is HP SR number 8606223364. + { $as_echo "$as_me:${as_lineno-$LINENO}: checking size of int" >&5 + $as_echo_n "checking size of int... " >&6; } +-if test "${ac_cv_sizeof_int+set}" = set; then : ++if ${ac_cv_sizeof_int+:} false; then : + $as_echo_n "(cached) " >&6 + else + if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (int))" "ac_cv_sizeof_int" "$ac_includes_default"; then : +@@ -7438,9 +7453,8 @@ else + if test "$ac_cv_type_int" = yes; then + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 + $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +-{ as_fn_set_status 77 +-as_fn_error "cannot compute sizeof (int) +-See \`config.log' for more details." "$LINENO" 5; }; } ++as_fn_error 77 "cannot compute sizeof (int) ++See \`config.log' for more details" "$LINENO" 5; } + else + ac_cv_sizeof_int=0 + fi +@@ -7463,7 +7477,7 @@ _ACEOF + # This bug is HP SR number 8606223364. + { $as_echo "$as_me:${as_lineno-$LINENO}: checking size of long" >&5 + $as_echo_n "checking size of long... " >&6; } +-if test "${ac_cv_sizeof_long+set}" = set; then : ++if ${ac_cv_sizeof_long+:} false; then : + $as_echo_n "(cached) " >&6 + else + if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (long))" "ac_cv_sizeof_long" "$ac_includes_default"; then : +@@ -7472,9 +7486,8 @@ else + if test "$ac_cv_type_long" = yes; then + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 + $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +-{ as_fn_set_status 77 +-as_fn_error "cannot compute sizeof (long) +-See \`config.log' for more details." "$LINENO" 5; }; } ++as_fn_error 77 "cannot compute sizeof (long) ++See \`config.log' for more details" "$LINENO" 5; } + else + ac_cv_sizeof_long=0 + fi +@@ -7498,7 +7511,7 @@ if test "$ac_cv_type_long_long" = yes; t + # This bug is HP SR number 8606223364. + { $as_echo "$as_me:${as_lineno-$LINENO}: checking size of long long" >&5 + $as_echo_n "checking size of long long... " >&6; } +-if test "${ac_cv_sizeof_long_long+set}" = set; then : ++if ${ac_cv_sizeof_long_long+:} false; then : + $as_echo_n "(cached) " >&6 + else + if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (long long))" "ac_cv_sizeof_long_long" "$ac_includes_default"; then : +@@ -7507,9 +7520,8 @@ else + if test "$ac_cv_type_long_long" = yes; then + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 + $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +-{ as_fn_set_status 77 +-as_fn_error "cannot compute sizeof (long long) +-See \`config.log' for more details." "$LINENO" 5; }; } ++as_fn_error 77 "cannot compute sizeof (long long) ++See \`config.log' for more details" "$LINENO" 5; } + else + ac_cv_sizeof_long_long=0 + fi +@@ -7533,7 +7545,7 @@ fi + # This bug is HP SR number 8606223364. + { $as_echo "$as_me:${as_lineno-$LINENO}: checking size of short" >&5 + $as_echo_n "checking size of short... " >&6; } +-if test "${ac_cv_sizeof_short+set}" = set; then : ++if ${ac_cv_sizeof_short+:} false; then : + $as_echo_n "(cached) " >&6 + else + if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (short))" "ac_cv_sizeof_short" "$ac_includes_default"; then : +@@ -7542,9 +7554,8 @@ else + if test "$ac_cv_type_short" = yes; then + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 + $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +-{ as_fn_set_status 77 +-as_fn_error "cannot compute sizeof (short) +-See \`config.log' for more details." "$LINENO" 5; }; } ++as_fn_error 77 "cannot compute sizeof (short) ++See \`config.log' for more details" "$LINENO" 5; } + else + ac_cv_sizeof_short=0 + fi +@@ -7567,7 +7578,7 @@ _ACEOF + # This bug is HP SR number 8606223364. + { $as_echo "$as_me:${as_lineno-$LINENO}: checking size of unsigned char" >&5 + $as_echo_n "checking size of unsigned char... " >&6; } +-if test "${ac_cv_sizeof_unsigned_char+set}" = set; then : ++if ${ac_cv_sizeof_unsigned_char+:} false; then : + $as_echo_n "(cached) " >&6 + else + if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (unsigned char))" "ac_cv_sizeof_unsigned_char" "$ac_includes_default"; then : +@@ -7576,9 +7587,8 @@ else + if test "$ac_cv_type_unsigned_char" = yes; then + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 + $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +-{ as_fn_set_status 77 +-as_fn_error "cannot compute sizeof (unsigned char) +-See \`config.log' for more details." "$LINENO" 5; }; } ++as_fn_error 77 "cannot compute sizeof (unsigned char) ++See \`config.log' for more details" "$LINENO" 5; } + else + ac_cv_sizeof_unsigned_char=0 + fi +@@ -7601,7 +7611,7 @@ _ACEOF + # This bug is HP SR number 8606223364. + { $as_echo "$as_me:${as_lineno-$LINENO}: checking size of unsigned int" >&5 + $as_echo_n "checking size of unsigned int... " >&6; } +-if test "${ac_cv_sizeof_unsigned_int+set}" = set; then : ++if ${ac_cv_sizeof_unsigned_int+:} false; then : + $as_echo_n "(cached) " >&6 + else + if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (unsigned int))" "ac_cv_sizeof_unsigned_int" "$ac_includes_default"; then : +@@ -7610,9 +7620,8 @@ else + if test "$ac_cv_type_unsigned_int" = yes; then + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 + $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +-{ as_fn_set_status 77 +-as_fn_error "cannot compute sizeof (unsigned int) +-See \`config.log' for more details." "$LINENO" 5; }; } ++as_fn_error 77 "cannot compute sizeof (unsigned int) ++See \`config.log' for more details" "$LINENO" 5; } + else + ac_cv_sizeof_unsigned_int=0 + fi +@@ -7635,7 +7644,7 @@ _ACEOF + # This bug is HP SR number 8606223364. + { $as_echo "$as_me:${as_lineno-$LINENO}: checking size of unsigned long" >&5 + $as_echo_n "checking size of unsigned long... " >&6; } +-if test "${ac_cv_sizeof_unsigned_long+set}" = set; then : ++if ${ac_cv_sizeof_unsigned_long+:} false; then : + $as_echo_n "(cached) " >&6 + else + if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (unsigned long))" "ac_cv_sizeof_unsigned_long" "$ac_includes_default"; then : +@@ -7644,9 +7653,8 @@ else + if test "$ac_cv_type_unsigned_long" = yes; then + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 + $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +-{ as_fn_set_status 77 +-as_fn_error "cannot compute sizeof (unsigned long) +-See \`config.log' for more details." "$LINENO" 5; }; } ++as_fn_error 77 "cannot compute sizeof (unsigned long) ++See \`config.log' for more details" "$LINENO" 5; } + else + ac_cv_sizeof_unsigned_long=0 + fi +@@ -7670,7 +7678,7 @@ if test "$ac_cv_type_long_long" = yes; t + # This bug is HP SR number 8606223364. + { $as_echo "$as_me:${as_lineno-$LINENO}: checking size of unsigned long long" >&5 + $as_echo_n "checking size of unsigned long long... " >&6; } +-if test "${ac_cv_sizeof_unsigned_long_long+set}" = set; then : ++if ${ac_cv_sizeof_unsigned_long_long+:} false; then : + $as_echo_n "(cached) " >&6 + else + if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (unsigned long long))" "ac_cv_sizeof_unsigned_long_long" "$ac_includes_default"; then : +@@ -7679,9 +7687,8 @@ else + if test "$ac_cv_type_unsigned_long_long" = yes; then + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 + $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +-{ as_fn_set_status 77 +-as_fn_error "cannot compute sizeof (unsigned long long) +-See \`config.log' for more details." "$LINENO" 5; }; } ++as_fn_error 77 "cannot compute sizeof (unsigned long long) ++See \`config.log' for more details" "$LINENO" 5; } + else + ac_cv_sizeof_unsigned_long_long=0 + fi +@@ -7705,7 +7712,7 @@ fi + # This bug is HP SR number 8606223364. + { $as_echo "$as_me:${as_lineno-$LINENO}: checking size of unsigned short" >&5 + $as_echo_n "checking size of unsigned short... " >&6; } +-if test "${ac_cv_sizeof_unsigned_short+set}" = set; then : ++if ${ac_cv_sizeof_unsigned_short+:} false; then : + $as_echo_n "(cached) " >&6 + else + if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (unsigned short))" "ac_cv_sizeof_unsigned_short" "$ac_includes_default"; then : +@@ -7714,9 +7721,8 @@ else + if test "$ac_cv_type_unsigned_short" = yes; then + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 + $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +-{ as_fn_set_status 77 +-as_fn_error "cannot compute sizeof (unsigned short) +-See \`config.log' for more details." "$LINENO" 5; }; } ++as_fn_error 77 "cannot compute sizeof (unsigned short) ++See \`config.log' for more details" "$LINENO" 5; } + else + ac_cv_sizeof_unsigned_short=0 + fi +@@ -7739,7 +7745,7 @@ _ACEOF + # This bug is HP SR number 8606223364. + { $as_echo "$as_me:${as_lineno-$LINENO}: checking size of void *" >&5 + $as_echo_n "checking size of void *... " >&6; } +-if test "${ac_cv_sizeof_void_p+set}" = set; then : ++if ${ac_cv_sizeof_void_p+:} false; then : + $as_echo_n "(cached) " >&6 + else + if ac_fn_c_compute_int "$LINENO" "(long int) (sizeof (void *))" "ac_cv_sizeof_void_p" "$ac_includes_default"; then : +@@ -7748,9 +7754,8 @@ else + if test "$ac_cv_type_void_p" = yes; then + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 + $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +-{ as_fn_set_status 77 +-as_fn_error "cannot compute sizeof (void *) +-See \`config.log' for more details." "$LINENO" 5; }; } ++as_fn_error 77 "cannot compute sizeof (void *) ++See \`config.log' for more details" "$LINENO" 5; } + else + ac_cv_sizeof_void_p=0 + fi +@@ -7769,21 +7774,20 @@ _ACEOF + + + ac_fn_c_check_type "$LINENO" "char" "ac_cv_type_char" "$ac_includes_default" +-if test "x$ac_cv_type_char" = x""yes; then : ++if test "x$ac_cv_type_char" = xyes; then : + + fi + { $as_echo "$as_me:${as_lineno-$LINENO}: checking alignment of char" >&5 + $as_echo_n "checking alignment of char... " >&6; } +-if test "${fp_cv_alignment_char+set}" = set; then : ++if ${fp_cv_alignment_char+:} false; then : + $as_echo_n "(cached) " >&6 + else + if test "$ac_cv_type_char" = yes; then + if ac_fn_c_compute_int "$LINENO" "(long) (&((struct { char c; char ty; } *)0)->ty)" "fp_cv_alignment_char" "$ac_includes_default"; then : + + else +- { as_fn_set_status 77 +-as_fn_error "cannot compute alignment (char) +-See \`config.log' for more details." "$LINENO" 5; } ++ as_fn_error 77 "cannot compute alignment (char) ++See \`config.log' for more details." "$LINENO" 5 + fi + + +@@ -7798,21 +7802,20 @@ cat >>confdefs.h <<_ACEOF + _ACEOF + + ac_fn_c_check_type "$LINENO" "double" "ac_cv_type_double" "$ac_includes_default" +-if test "x$ac_cv_type_double" = x""yes; then : ++if test "x$ac_cv_type_double" = xyes; then : + + fi + { $as_echo "$as_me:${as_lineno-$LINENO}: checking alignment of double" >&5 + $as_echo_n "checking alignment of double... " >&6; } +-if test "${fp_cv_alignment_double+set}" = set; then : ++if ${fp_cv_alignment_double+:} false; then : + $as_echo_n "(cached) " >&6 + else + if test "$ac_cv_type_double" = yes; then + if ac_fn_c_compute_int "$LINENO" "(long) (&((struct { char c; double ty; } *)0)->ty)" "fp_cv_alignment_double" "$ac_includes_default"; then : + + else +- { as_fn_set_status 77 +-as_fn_error "cannot compute alignment (double) +-See \`config.log' for more details." "$LINENO" 5; } ++ as_fn_error 77 "cannot compute alignment (double) ++See \`config.log' for more details." "$LINENO" 5 + fi + + +@@ -7827,21 +7830,20 @@ cat >>confdefs.h <<_ACEOF + _ACEOF + + ac_fn_c_check_type "$LINENO" "float" "ac_cv_type_float" "$ac_includes_default" +-if test "x$ac_cv_type_float" = x""yes; then : ++if test "x$ac_cv_type_float" = xyes; then : + + fi + { $as_echo "$as_me:${as_lineno-$LINENO}: checking alignment of float" >&5 + $as_echo_n "checking alignment of float... " >&6; } +-if test "${fp_cv_alignment_float+set}" = set; then : ++if ${fp_cv_alignment_float+:} false; then : + $as_echo_n "(cached) " >&6 + else + if test "$ac_cv_type_float" = yes; then + if ac_fn_c_compute_int "$LINENO" "(long) (&((struct { char c; float ty; } *)0)->ty)" "fp_cv_alignment_float" "$ac_includes_default"; then : + + else +- { as_fn_set_status 77 +-as_fn_error "cannot compute alignment (float) +-See \`config.log' for more details." "$LINENO" 5; } ++ as_fn_error 77 "cannot compute alignment (float) ++See \`config.log' for more details." "$LINENO" 5 + fi + + +@@ -7856,21 +7858,20 @@ cat >>confdefs.h <<_ACEOF + _ACEOF + + ac_fn_c_check_type "$LINENO" "int" "ac_cv_type_int" "$ac_includes_default" +-if test "x$ac_cv_type_int" = x""yes; then : ++if test "x$ac_cv_type_int" = xyes; then : + + fi + { $as_echo "$as_me:${as_lineno-$LINENO}: checking alignment of int" >&5 + $as_echo_n "checking alignment of int... " >&6; } +-if test "${fp_cv_alignment_int+set}" = set; then : ++if ${fp_cv_alignment_int+:} false; then : + $as_echo_n "(cached) " >&6 + else + if test "$ac_cv_type_int" = yes; then + if ac_fn_c_compute_int "$LINENO" "(long) (&((struct { char c; int ty; } *)0)->ty)" "fp_cv_alignment_int" "$ac_includes_default"; then : + + else +- { as_fn_set_status 77 +-as_fn_error "cannot compute alignment (int) +-See \`config.log' for more details." "$LINENO" 5; } ++ as_fn_error 77 "cannot compute alignment (int) ++See \`config.log' for more details." "$LINENO" 5 + fi + + +@@ -7885,21 +7886,20 @@ cat >>confdefs.h <<_ACEOF + _ACEOF + + ac_fn_c_check_type "$LINENO" "long" "ac_cv_type_long" "$ac_includes_default" +-if test "x$ac_cv_type_long" = x""yes; then : ++if test "x$ac_cv_type_long" = xyes; then : + + fi + { $as_echo "$as_me:${as_lineno-$LINENO}: checking alignment of long" >&5 + $as_echo_n "checking alignment of long... " >&6; } +-if test "${fp_cv_alignment_long+set}" = set; then : ++if ${fp_cv_alignment_long+:} false; then : + $as_echo_n "(cached) " >&6 + else + if test "$ac_cv_type_long" = yes; then + if ac_fn_c_compute_int "$LINENO" "(long) (&((struct { char c; long ty; } *)0)->ty)" "fp_cv_alignment_long" "$ac_includes_default"; then : + + else +- { as_fn_set_status 77 +-as_fn_error "cannot compute alignment (long) +-See \`config.log' for more details." "$LINENO" 5; } ++ as_fn_error 77 "cannot compute alignment (long) ++See \`config.log' for more details." "$LINENO" 5 + fi + + +@@ -7915,21 +7915,20 @@ _ACEOF + + if test "$ac_cv_type_long_long" = yes; then + ac_fn_c_check_type "$LINENO" "long long" "ac_cv_type_long_long" "$ac_includes_default" +-if test "x$ac_cv_type_long_long" = x""yes; then : ++if test "x$ac_cv_type_long_long" = xyes; then : + + fi + { $as_echo "$as_me:${as_lineno-$LINENO}: checking alignment of long long" >&5 + $as_echo_n "checking alignment of long long... " >&6; } +-if test "${fp_cv_alignment_long_long+set}" = set; then : ++if ${fp_cv_alignment_long_long+:} false; then : + $as_echo_n "(cached) " >&6 + else + if test "$ac_cv_type_long_long" = yes; then + if ac_fn_c_compute_int "$LINENO" "(long) (&((struct { char c; long long ty; } *)0)->ty)" "fp_cv_alignment_long_long" "$ac_includes_default"; then : + + else +- { as_fn_set_status 77 +-as_fn_error "cannot compute alignment (long long) +-See \`config.log' for more details." "$LINENO" 5; } ++ as_fn_error 77 "cannot compute alignment (long long) ++See \`config.log' for more details." "$LINENO" 5 + fi + + +@@ -7945,21 +7944,20 @@ _ACEOF + + fi + ac_fn_c_check_type "$LINENO" "short" "ac_cv_type_short" "$ac_includes_default" +-if test "x$ac_cv_type_short" = x""yes; then : ++if test "x$ac_cv_type_short" = xyes; then : + + fi + { $as_echo "$as_me:${as_lineno-$LINENO}: checking alignment of short" >&5 + $as_echo_n "checking alignment of short... " >&6; } +-if test "${fp_cv_alignment_short+set}" = set; then : ++if ${fp_cv_alignment_short+:} false; then : + $as_echo_n "(cached) " >&6 + else + if test "$ac_cv_type_short" = yes; then + if ac_fn_c_compute_int "$LINENO" "(long) (&((struct { char c; short ty; } *)0)->ty)" "fp_cv_alignment_short" "$ac_includes_default"; then : + + else +- { as_fn_set_status 77 +-as_fn_error "cannot compute alignment (short) +-See \`config.log' for more details." "$LINENO" 5; } ++ as_fn_error 77 "cannot compute alignment (short) ++See \`config.log' for more details." "$LINENO" 5 + fi + + +@@ -7974,21 +7972,20 @@ cat >>confdefs.h <<_ACEOF + _ACEOF + + ac_fn_c_check_type "$LINENO" "unsigned char" "ac_cv_type_unsigned_char" "$ac_includes_default" +-if test "x$ac_cv_type_unsigned_char" = x""yes; then : ++if test "x$ac_cv_type_unsigned_char" = xyes; then : + + fi + { $as_echo "$as_me:${as_lineno-$LINENO}: checking alignment of unsigned char" >&5 + $as_echo_n "checking alignment of unsigned char... " >&6; } +-if test "${fp_cv_alignment_unsigned_char+set}" = set; then : ++if ${fp_cv_alignment_unsigned_char+:} false; then : + $as_echo_n "(cached) " >&6 + else + if test "$ac_cv_type_unsigned_char" = yes; then + if ac_fn_c_compute_int "$LINENO" "(long) (&((struct { char c; unsigned char ty; } *)0)->ty)" "fp_cv_alignment_unsigned_char" "$ac_includes_default"; then : + + else +- { as_fn_set_status 77 +-as_fn_error "cannot compute alignment (unsigned char) +-See \`config.log' for more details." "$LINENO" 5; } ++ as_fn_error 77 "cannot compute alignment (unsigned char) ++See \`config.log' for more details." "$LINENO" 5 + fi + + +@@ -8003,21 +8000,20 @@ cat >>confdefs.h <<_ACEOF + _ACEOF + + ac_fn_c_check_type "$LINENO" "unsigned int" "ac_cv_type_unsigned_int" "$ac_includes_default" +-if test "x$ac_cv_type_unsigned_int" = x""yes; then : ++if test "x$ac_cv_type_unsigned_int" = xyes; then : + + fi + { $as_echo "$as_me:${as_lineno-$LINENO}: checking alignment of unsigned int" >&5 + $as_echo_n "checking alignment of unsigned int... " >&6; } +-if test "${fp_cv_alignment_unsigned_int+set}" = set; then : ++if ${fp_cv_alignment_unsigned_int+:} false; then : + $as_echo_n "(cached) " >&6 + else + if test "$ac_cv_type_unsigned_int" = yes; then + if ac_fn_c_compute_int "$LINENO" "(long) (&((struct { char c; unsigned int ty; } *)0)->ty)" "fp_cv_alignment_unsigned_int" "$ac_includes_default"; then : + + else +- { as_fn_set_status 77 +-as_fn_error "cannot compute alignment (unsigned int) +-See \`config.log' for more details." "$LINENO" 5; } ++ as_fn_error 77 "cannot compute alignment (unsigned int) ++See \`config.log' for more details." "$LINENO" 5 + fi + + +@@ -8032,21 +8028,20 @@ cat >>confdefs.h <<_ACEOF + _ACEOF + + ac_fn_c_check_type "$LINENO" "unsigned long" "ac_cv_type_unsigned_long" "$ac_includes_default" +-if test "x$ac_cv_type_unsigned_long" = x""yes; then : ++if test "x$ac_cv_type_unsigned_long" = xyes; then : + + fi + { $as_echo "$as_me:${as_lineno-$LINENO}: checking alignment of unsigned long" >&5 + $as_echo_n "checking alignment of unsigned long... " >&6; } +-if test "${fp_cv_alignment_unsigned_long+set}" = set; then : ++if ${fp_cv_alignment_unsigned_long+:} false; then : + $as_echo_n "(cached) " >&6 + else + if test "$ac_cv_type_unsigned_long" = yes; then + if ac_fn_c_compute_int "$LINENO" "(long) (&((struct { char c; unsigned long ty; } *)0)->ty)" "fp_cv_alignment_unsigned_long" "$ac_includes_default"; then : + + else +- { as_fn_set_status 77 +-as_fn_error "cannot compute alignment (unsigned long) +-See \`config.log' for more details." "$LINENO" 5; } ++ as_fn_error 77 "cannot compute alignment (unsigned long) ++See \`config.log' for more details." "$LINENO" 5 + fi + + +@@ -8062,21 +8057,20 @@ _ACEOF + + if test "$ac_cv_type_long_long" = yes; then + ac_fn_c_check_type "$LINENO" "unsigned long long" "ac_cv_type_unsigned_long_long" "$ac_includes_default" +-if test "x$ac_cv_type_unsigned_long_long" = x""yes; then : ++if test "x$ac_cv_type_unsigned_long_long" = xyes; then : + + fi + { $as_echo "$as_me:${as_lineno-$LINENO}: checking alignment of unsigned long long" >&5 + $as_echo_n "checking alignment of unsigned long long... " >&6; } +-if test "${fp_cv_alignment_unsigned_long_long+set}" = set; then : ++if ${fp_cv_alignment_unsigned_long_long+:} false; then : + $as_echo_n "(cached) " >&6 + else + if test "$ac_cv_type_unsigned_long_long" = yes; then + if ac_fn_c_compute_int "$LINENO" "(long) (&((struct { char c; unsigned long long ty; } *)0)->ty)" "fp_cv_alignment_unsigned_long_long" "$ac_includes_default"; then : + + else +- { as_fn_set_status 77 +-as_fn_error "cannot compute alignment (unsigned long long) +-See \`config.log' for more details." "$LINENO" 5; } ++ as_fn_error 77 "cannot compute alignment (unsigned long long) ++See \`config.log' for more details." "$LINENO" 5 + fi + + +@@ -8092,21 +8086,20 @@ _ACEOF + + fi + ac_fn_c_check_type "$LINENO" "unsigned short" "ac_cv_type_unsigned_short" "$ac_includes_default" +-if test "x$ac_cv_type_unsigned_short" = x""yes; then : ++if test "x$ac_cv_type_unsigned_short" = xyes; then : + + fi + { $as_echo "$as_me:${as_lineno-$LINENO}: checking alignment of unsigned short" >&5 + $as_echo_n "checking alignment of unsigned short... " >&6; } +-if test "${fp_cv_alignment_unsigned_short+set}" = set; then : ++if ${fp_cv_alignment_unsigned_short+:} false; then : + $as_echo_n "(cached) " >&6 + else + if test "$ac_cv_type_unsigned_short" = yes; then + if ac_fn_c_compute_int "$LINENO" "(long) (&((struct { char c; unsigned short ty; } *)0)->ty)" "fp_cv_alignment_unsigned_short" "$ac_includes_default"; then : + + else +- { as_fn_set_status 77 +-as_fn_error "cannot compute alignment (unsigned short) +-See \`config.log' for more details." "$LINENO" 5; } ++ as_fn_error 77 "cannot compute alignment (unsigned short) ++See \`config.log' for more details." "$LINENO" 5 + fi + + +@@ -8120,22 +8113,22 @@ cat >>confdefs.h <<_ACEOF + #define ALIGNMENT_UNSIGNED_SHORT $fp_cv_alignment_unsigned_short + _ACEOF + +-ac_fn_c_check_type "$LINENO" "void *" "ac_cv_type_void_p" "$ac_includes_default" +-if test "x$ac_cv_type_void_p" = x""yes; then : ++as_ac_Type=`$as_echo "ac_cv_type_void *" | $as_tr_sh` ++ac_fn_c_check_type "$LINENO" "void *" "$as_ac_Type" "$ac_includes_default" ++if eval test \"x\$"$as_ac_Type"\" = x"yes"; then : + + fi + { $as_echo "$as_me:${as_lineno-$LINENO}: checking alignment of void *" >&5 + $as_echo_n "checking alignment of void *... " >&6; } +-if test "${fp_cv_alignment_void_p+set}" = set; then : ++if ${fp_cv_alignment_void_p+:} false; then : + $as_echo_n "(cached) " >&6 + else + if test "$ac_cv_type_void_p" = yes; then + if ac_fn_c_compute_int "$LINENO" "(long) (&((struct { char c; void * ty; } *)0)->ty)" "fp_cv_alignment_void_p" "$ac_includes_default"; then : + + else +- { as_fn_set_status 77 +-as_fn_error "cannot compute alignment (void *) +-See \`config.log' for more details." "$LINENO" 5; } ++ as_fn_error 77 "cannot compute alignment (void *) ++See \`config.log' for more details." "$LINENO" 5 + fi + + +@@ -8152,7 +8145,7 @@ _ACEOF + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for WinExec" >&5 + $as_echo_n "checking for WinExec... " >&6; } +-if test "${fp_cv_func_WinExec+set}" = set; then : ++if ${fp_cv_func_WinExec+:} false; then : + $as_echo_n "(cached) " >&6 + else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +@@ -8184,7 +8177,7 @@ fi + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for GetModuleFileName" >&5 + $as_echo_n "checking for GetModuleFileName... " >&6; } +-if test "${fp_cv_func_GetModuleFileName+set}" = set; then : ++if ${fp_cv_func_GetModuleFileName+:} false; then : + $as_echo_n "(cached) " >&6 + else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +@@ -8217,7 +8210,7 @@ fi + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking return type of signal handlers" >&5 + $as_echo_n "checking return type of signal handlers... " >&6; } +-if test "${ac_cv_type_signal+set}" = set; then : ++if ${ac_cv_type_signal+:} false; then : + $as_echo_n "(cached) " >&6 + else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +@@ -8258,8 +8251,7 @@ for ac_func in getclock getrusage gettim + do : + as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` + ac_fn_c_check_func "$LINENO" "$ac_func" "$as_ac_var" +-eval as_val=\$$as_ac_var +- if test "x$as_val" = x""yes; then : ++if eval test \"x\$"$as_ac_var"\" = x"yes"; then : + cat >>confdefs.h <<_ACEOF + #define `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1 + _ACEOF +@@ -8271,8 +8263,8 @@ done + if test "$cross_compiling" = yes; then : + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 + $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +-as_fn_error "cannot run test program while cross compiling +-See \`config.log' for more details." "$LINENO" 5; } ++as_fn_error $? "cannot run test program while cross compiling ++See \`config.log' for more details" "$LINENO" 5; } + else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext + /* end confdefs.h. */ +@@ -8302,7 +8294,7 @@ ac_fn_c_check_decl "$LINENO" "ctime_r" " + #define _POSIX_C_SOURCE 199506L + #include + " +-if test "x$ac_cv_have_decl_ctime_r" = x""yes; then : ++if test "x$ac_cv_have_decl_ctime_r" = xyes; then : + ac_have_decl=1 + else + ac_have_decl=0 +@@ -8315,7 +8307,7 @@ _ACEOF + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for closedir in -lmingwex" >&5 + $as_echo_n "checking for closedir in -lmingwex... " >&6; } +-if test "${ac_cv_lib_mingwex_closedir+set}" = set; then : ++if ${ac_cv_lib_mingwex_closedir+:} false; then : + $as_echo_n "(cached) " >&6 + else + ac_check_lib_save_LIBS=$LIBS +@@ -8349,7 +8341,7 @@ LIBS=$ac_check_lib_save_LIBS + fi + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_mingwex_closedir" >&5 + $as_echo "$ac_cv_lib_mingwex_closedir" >&6; } +-if test "x$ac_cv_lib_mingwex_closedir" = x""yes; then : ++if test "x$ac_cv_lib_mingwex_closedir" = xyes; then : + HaveLibMingwEx=YES + else + HaveLibMingwEx=NO +@@ -8365,7 +8357,7 @@ fi + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for atan in -lm" >&5 + $as_echo_n "checking for atan in -lm... " >&6; } +-if test "${ac_cv_lib_m_atan+set}" = set; then : ++if ${ac_cv_lib_m_atan+:} false; then : + $as_echo_n "(cached) " >&6 + else + ac_check_lib_save_LIBS=$LIBS +@@ -8399,7 +8391,7 @@ LIBS=$ac_check_lib_save_LIBS + fi + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_m_atan" >&5 + $as_echo "$ac_cv_lib_m_atan" >&6; } +-if test "x$ac_cv_lib_m_atan" = x""yes; then : ++if test "x$ac_cv_lib_m_atan" = xyes; then : + HaveLibM=YES + else + HaveLibM=NO +@@ -8414,7 +8406,7 @@ fi + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for xmalloc in -liberty" >&5 + $as_echo_n "checking for xmalloc in -liberty... " >&6; } +-if test "${ac_cv_lib_iberty_xmalloc+set}" = set; then : ++if ${ac_cv_lib_iberty_xmalloc+:} false; then : + $as_echo_n "(cached) " >&6 + else + ac_check_lib_save_LIBS=$LIBS +@@ -8448,7 +8440,7 @@ LIBS=$ac_check_lib_save_LIBS + fi + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_iberty_xmalloc" >&5 + $as_echo "$ac_cv_lib_iberty_xmalloc" >&6; } +-if test "x$ac_cv_lib_iberty_xmalloc" = x""yes; then : ++if test "x$ac_cv_lib_iberty_xmalloc" = xyes; then : + cat >>confdefs.h <<_ACEOF + #define HAVE_LIBIBERTY 1 + _ACEOF +@@ -8459,7 +8451,7 @@ fi + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for bfd_uncompress_section_contents in -lbfd" >&5 + $as_echo_n "checking for bfd_uncompress_section_contents in -lbfd... " >&6; } +-if test "${ac_cv_lib_bfd_bfd_uncompress_section_contents+set}" = set; then : ++if ${ac_cv_lib_bfd_bfd_uncompress_section_contents+:} false; then : + $as_echo_n "(cached) " >&6 + else + ac_check_lib_save_LIBS=$LIBS +@@ -8493,7 +8485,7 @@ LIBS=$ac_check_lib_save_LIBS + fi + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_bfd_bfd_uncompress_section_contents" >&5 + $as_echo "$ac_cv_lib_bfd_bfd_uncompress_section_contents" >&6; } +-if test "x$ac_cv_lib_bfd_bfd_uncompress_section_contents" = x""yes; then : ++if test "x$ac_cv_lib_bfd_bfd_uncompress_section_contents" = xyes; then : + cat >>confdefs.h <<_ACEOF + #define HAVE_LIBBFD 1 + _ACEOF +@@ -8507,7 +8499,7 @@ fi + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for dlopen in -ldl" >&5 + $as_echo_n "checking for dlopen in -ldl... " >&6; } +-if test "${ac_cv_lib_dl_dlopen+set}" = set; then : ++if ${ac_cv_lib_dl_dlopen+:} false; then : + $as_echo_n "(cached) " >&6 + else + ac_check_lib_save_LIBS=$LIBS +@@ -8541,7 +8533,7 @@ LIBS=$ac_check_lib_save_LIBS + fi + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_dl_dlopen" >&5 + $as_echo "$ac_cv_lib_dl_dlopen" >&6; } +-if test "x$ac_cv_lib_dl_dlopen" = x""yes; then : ++if test "x$ac_cv_lib_dl_dlopen" = xyes; then : + HaveLibDL=YES + + $as_echo "#define HAVE_LIBDL 1" >>confdefs.h +@@ -8554,11 +8546,22 @@ fi + + + ++ac_fn_c_check_type "$LINENO" "size_t" "ac_cv_type_size_t" "$ac_includes_default" ++if test "x$ac_cv_type_size_t" = xyes; then : ++ ++else ++ ++cat >>confdefs.h <<_ACEOF ++#define size_t unsigned int ++_ACEOF ++ ++fi ++ + # The Ultrix 4.2 mips builtin alloca declared by alloca.h only works + # for constant arguments. Useless! + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for working alloca.h" >&5 + $as_echo_n "checking for working alloca.h... " >&6; } +-if test "${ac_cv_working_alloca_h+set}" = set; then : ++if ${ac_cv_working_alloca_h+:} false; then : + $as_echo_n "(cached) " >&6 + else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +@@ -8591,7 +8594,7 @@ fi + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for alloca" >&5 + $as_echo_n "checking for alloca... " >&6; } +-if test "${ac_cv_func_alloca_works+set}" = set; then : ++if ${ac_cv_func_alloca_works+:} false; then : + $as_echo_n "(cached) " >&6 + else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +@@ -8610,7 +8613,7 @@ else + #pragma alloca + # else + # ifndef alloca /* predefined by HP cc +Olibcalls */ +-char *alloca (); ++void *alloca (size_t); + # endif + # endif + # endif +@@ -8654,7 +8657,7 @@ $as_echo "#define C_ALLOCA 1" >>confdefs + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether \`alloca.c' needs Cray hooks" >&5 + $as_echo_n "checking whether \`alloca.c' needs Cray hooks... " >&6; } +-if test "${ac_cv_os_cray+set}" = set; then : ++if ${ac_cv_os_cray+:} false; then : + $as_echo_n "(cached) " >&6 + else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +@@ -8681,8 +8684,7 @@ if test $ac_cv_os_cray = yes; then + for ac_func in _getb67 GETB67 getb67; do + as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` + ac_fn_c_check_func "$LINENO" "$ac_func" "$as_ac_var" +-eval as_val=\$$as_ac_var +- if test "x$as_val" = x""yes; then : ++if eval test \"x\$"$as_ac_var"\" = x"yes"; then : + + cat >>confdefs.h <<_ACEOF + #define CRAY_STACKSEG_END $ac_func +@@ -8696,7 +8698,7 @@ fi + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking stack direction for C alloca" >&5 + $as_echo_n "checking stack direction for C alloca... " >&6; } +-if test "${ac_cv_c_stack_direction+set}" = set; then : ++if ${ac_cv_c_stack_direction+:} false; then : + $as_echo_n "(cached) " >&6 + else + if test "$cross_compiling" = yes; then : +@@ -8746,7 +8748,7 @@ fi + + + ac_fn_c_check_type "$LINENO" "pid_t" "ac_cv_type_pid_t" "$ac_includes_default" +-if test "x$ac_cv_type_pid_t" = x""yes; then : ++if test "x$ac_cv_type_pid_t" = xyes; then : + + else + +@@ -8759,7 +8761,7 @@ fi + for ac_header in vfork.h + do : + ac_fn_c_check_header_mongrel "$LINENO" "vfork.h" "ac_cv_header_vfork_h" "$ac_includes_default" +-if test "x$ac_cv_header_vfork_h" = x""yes; then : ++if test "x$ac_cv_header_vfork_h" = xyes; then : + cat >>confdefs.h <<_ACEOF + #define HAVE_VFORK_H 1 + _ACEOF +@@ -8772,8 +8774,7 @@ for ac_func in fork vfork + do : + as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` + ac_fn_c_check_func "$LINENO" "$ac_func" "$as_ac_var" +-eval as_val=\$$as_ac_var +- if test "x$as_val" = x""yes; then : ++if eval test \"x\$"$as_ac_var"\" = x"yes"; then : + cat >>confdefs.h <<_ACEOF + #define `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1 + _ACEOF +@@ -8784,7 +8785,7 @@ done + if test "x$ac_cv_func_fork" = xyes; then + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for working fork" >&5 + $as_echo_n "checking for working fork... " >&6; } +-if test "${ac_cv_func_fork_works+set}" = set; then : ++if ${ac_cv_func_fork_works+:} false; then : + $as_echo_n "(cached) " >&6 + else + if test "$cross_compiling" = yes; then : +@@ -8837,7 +8838,7 @@ ac_cv_func_vfork_works=$ac_cv_func_vfork + if test "x$ac_cv_func_vfork" = xyes; then + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for working vfork" >&5 + $as_echo_n "checking for working vfork... " >&6; } +-if test "${ac_cv_func_vfork_works+set}" = set; then : ++if ${ac_cv_func_vfork_works+:} false; then : + $as_echo_n "(cached) " >&6 + else + if test "$cross_compiling" = yes; then : +@@ -8973,7 +8974,7 @@ fi + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for an ANSI C-conforming const" >&5 + $as_echo_n "checking for an ANSI C-conforming const... " >&6; } +-if test "${ac_cv_c_const+set}" = set; then : ++if ${ac_cv_c_const+:} false; then : + $as_echo_n "(cached) " >&6 + else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +@@ -9054,7 +9055,7 @@ fi + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether byte ordering is bigendian" >&5 + $as_echo_n "checking whether byte ordering is bigendian... " >&6; } +-if test "${ac_cv_c_bigendian+set}" = set; then : ++if ${ac_cv_c_bigendian+:} false; then : + $as_echo_n "(cached) " >&6 + else + ac_cv_c_bigendian=unknown +@@ -9272,13 +9273,13 @@ $as_echo "#define AC_APPLE_UNIVERSAL_BUI + + ;; #( + *) +- as_fn_error "unknown endianness ++ as_fn_error $? "unknown endianness + presetting ac_cv_c_bigendian=no (or yes) will help" "$LINENO" 5 ;; + esac + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether float word order is big endian" >&5 + $as_echo_n "checking whether float word order is big endian... " >&6; } +-if test "${fptools_cv_float_word_order_bigendian+set}" = set; then : ++if ${fptools_cv_float_word_order_bigendian+:} false; then : + $as_echo_n "(cached) " >&6 + else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext +@@ -9317,7 +9318,7 @@ $as_echo "#define FLOAT_WORDS_BIGENDIAN + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for nlist in -lelf" >&5 + $as_echo_n "checking for nlist in -lelf... " >&6; } +-if test "${ac_cv_lib_elf_nlist+set}" = set; then : ++if ${ac_cv_lib_elf_nlist+:} false; then : + $as_echo_n "(cached) " >&6 + else + ac_check_lib_save_LIBS=$LIBS +@@ -9351,13 +9352,13 @@ LIBS=$ac_check_lib_save_LIBS + fi + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_elf_nlist" >&5 + $as_echo "$ac_cv_lib_elf_nlist" >&6; } +-if test "x$ac_cv_lib_elf_nlist" = x""yes; then : ++if test "x$ac_cv_lib_elf_nlist" = xyes; then : + LIBS="-lelf $LIBS" + fi + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking leading underscore in symbol names" >&5 + $as_echo_n "checking leading underscore in symbol names... " >&6; } +-if test "${fptools_cv_leading_underscore+set}" = set; then : ++if ${fptools_cv_leading_underscore+:} false; then : + $as_echo_n "(cached) " >&6 + else + +@@ -9428,7 +9429,7 @@ fi + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether ld understands -x" >&5 + $as_echo_n "checking whether ld understands -x... " >&6; } +-if test "${fp_cv_ld_x+set}" = set; then : ++if ${fp_cv_ld_x+:} false; then : + $as_echo_n "(cached) " >&6 + else + echo 'foo() {}' > conftest.c +@@ -9452,7 +9453,7 @@ fi + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether ld is GNU ld" >&5 + $as_echo_n "checking whether ld is GNU ld... " >&6; } +-if test "${fp_cv_gnu_ld+set}" = set; then : ++if ${fp_cv_gnu_ld+:} false; then : + $as_echo_n "(cached) " >&6 + else + if ${LdCmd} --version 2> /dev/null | grep "GNU" > /dev/null 2>&1; then +@@ -9469,7 +9470,7 @@ LdIsGNULd=`echo $fp_cv_gnu_ld | sed 'y/y + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking whether ld understands --build-id" >&5 + $as_echo_n "checking whether ld understands --build-id... " >&6; } +-if test "${fp_cv_ld_build_id+set}" = set; then : ++if ${fp_cv_ld_build_id+:} false; then : + $as_echo_n "(cached) " >&6 + else + echo 'foo() {}' > conftest.c +@@ -9569,7 +9570,7 @@ $as_echo "no" >&6; } + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for clock_gettime in -lrt" >&5 + $as_echo_n "checking for clock_gettime in -lrt... " >&6; } +-if test "${ac_cv_lib_rt_clock_gettime+set}" = set; then : ++if ${ac_cv_lib_rt_clock_gettime+:} false; then : + $as_echo_n "(cached) " >&6 + else + ac_check_lib_save_LIBS=$LIBS +@@ -9603,7 +9604,7 @@ LIBS=$ac_check_lib_save_LIBS + fi + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_rt_clock_gettime" >&5 + $as_echo "$ac_cv_lib_rt_clock_gettime" >&6; } +-if test "x$ac_cv_lib_rt_clock_gettime" = x""yes; then : ++if test "x$ac_cv_lib_rt_clock_gettime" = xyes; then : + cat >>confdefs.h <<_ACEOF + #define HAVE_LIBRT 1 + _ACEOF +@@ -9616,8 +9617,7 @@ for ac_func in clock_gettime timer_creat + do : + as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh` + ac_fn_c_check_func "$LINENO" "$ac_func" "$as_ac_var" +-eval as_val=\$$as_ac_var +- if test "x$as_val" = x""yes; then : ++if eval test \"x\$"$as_ac_var"\" = x"yes"; then : + cat >>confdefs.h <<_ACEOF + #define `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1 + _ACEOF +@@ -9627,14 +9627,14 @@ done + + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for a working timer_create(CLOCK_REALTIME)" >&5 + $as_echo_n "checking for a working timer_create(CLOCK_REALTIME)... " >&6; } +-if test "${fptools_cv_timer_create_works+set}" = set; then : ++if ${fptools_cv_timer_create_works+:} false; then : + $as_echo_n "(cached) " >&6 + else + if test "$cross_compiling" = yes; then : + { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5 + $as_echo "$as_me: error: in \`$ac_pwd':" >&2;} +-as_fn_error "cannot run test program while cross compiling +-See \`config.log' for more details." "$LINENO" 5; } ++as_fn_error $? "cannot run test program while cross compiling ++See \`config.log' for more details" "$LINENO" 5; } + else + cat confdefs.h - <<_ACEOF >conftest.$ac_ext + /* end confdefs.h. */ +@@ -9816,7 +9816,7 @@ rm -f core conftest.err conftest.$ac_obj + for ac_header in sys/eventfd.h + do : + ac_fn_c_check_header_mongrel "$LINENO" "sys/eventfd.h" "ac_cv_header_sys_eventfd_h" "$ac_includes_default" +-if test "x$ac_cv_header_sys_eventfd_h" = x""yes; then : ++if test "x$ac_cv_header_sys_eventfd_h" = xyes; then : + cat >>confdefs.h <<_ACEOF + #define HAVE_SYS_EVENTFD_H 1 + _ACEOF +@@ -9828,7 +9828,7 @@ done + for ac_func in eventfd + do : + ac_fn_c_check_func "$LINENO" "eventfd" "ac_cv_func_eventfd" +-if test "x$ac_cv_func_eventfd" = x""yes; then : ++if test "x$ac_cv_func_eventfd" = xyes; then : + cat >>confdefs.h <<_ACEOF + #define HAVE_EVENTFD 1 + _ACEOF +@@ -9844,7 +9844,7 @@ do + set dummy $ac_prog; ac_word=$2 + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5 + $as_echo_n "checking for $ac_word... " >&6; } +-if test "${ac_cv_path_GTK_CONFIG+set}" = set; then : ++if ${ac_cv_path_GTK_CONFIG+:} false; then : + $as_echo_n "(cached) " >&6 + else + case $GTK_CONFIG in +@@ -9897,7 +9897,7 @@ fi + #Checking for PAPI + { $as_echo "$as_me:${as_lineno-$LINENO}: checking for PAPI_library_init in -lpapi" >&5 + $as_echo_n "checking for PAPI_library_init in -lpapi... " >&6; } +-if test "${ac_cv_lib_papi_PAPI_library_init+set}" = set; then : ++if ${ac_cv_lib_papi_PAPI_library_init+:} false; then : + $as_echo_n "(cached) " >&6 + else + ac_check_lib_save_LIBS=$LIBS +@@ -9931,14 +9931,14 @@ LIBS=$ac_check_lib_save_LIBS + fi + { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_papi_PAPI_library_init" >&5 + $as_echo "$ac_cv_lib_papi_PAPI_library_init" >&6; } +-if test "x$ac_cv_lib_papi_PAPI_library_init" = x""yes; then : ++if test "x$ac_cv_lib_papi_PAPI_library_init" = xyes; then : + HavePapiLib=YES + else + HavePapiLib=NO + fi + + ac_fn_c_check_header_mongrel "$LINENO" "papi.h" "ac_cv_header_papi_h" "$ac_includes_default" +-if test "x$ac_cv_header_papi_h" = x""yes; then : ++if test "x$ac_cv_header_papi_h" = xyes; then : + HavePapiHeader=YES + else + HavePapiHeader=NO +@@ -9951,7 +9951,7 @@ fi + for ac_func in __mingw_vfprintf + do : + ac_fn_c_check_func "$LINENO" "__mingw_vfprintf" "ac_cv_func___mingw_vfprintf" +-if test "x$ac_cv_func___mingw_vfprintf" = x""yes; then : ++if test "x$ac_cv_func___mingw_vfprintf" = xyes; then : + cat >>confdefs.h <<_ACEOF + #define HAVE___MINGW_VFPRINTF 1 + _ACEOF +@@ -10006,7 +10006,7 @@ LIBRARY_ghc_VERSION="$ProjectVersion" + + + if grep ' ' compiler/ghc.cabal.in 2>&1 >/dev/null; then +- as_fn_error "compiler/ghc.cabal.in contains tab characters; please remove them" "$LINENO" 5 ++ as_fn_error $? "compiler/ghc.cabal.in contains tab characters; please remove them" "$LINENO" 5 + fi + + ac_config_files="$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" +@@ -10077,10 +10077,21 @@ $as_echo "$as_me: WARNING: cache variabl + :end' >>confcache + if diff "$cache_file" confcache >/dev/null 2>&1; then :; else + if test -w "$cache_file"; then +- test "x$cache_file" != "x/dev/null" && ++ if test "x$cache_file" != "x/dev/null"; then + { $as_echo "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5 + $as_echo "$as_me: updating cache $cache_file" >&6;} +- cat confcache >$cache_file ++ if test ! -f "$cache_file" || test -h "$cache_file"; then ++ cat confcache >"$cache_file" ++ else ++ case $cache_file in #( ++ */* | ?:*) ++ mv -f confcache "$cache_file"$$ && ++ mv -f "$cache_file"$$ "$cache_file" ;; #( ++ *) ++ mv -f confcache "$cache_file" ;; ++ esac ++ fi ++ fi + else + { $as_echo "$as_me:${as_lineno-$LINENO}: not updating unwritable cache $cache_file" >&5 + $as_echo "$as_me: not updating unwritable cache $cache_file" >&6;} +@@ -10096,6 +10107,7 @@ DEFS=-DHAVE_CONFIG_H + + ac_libobjs= + ac_ltlibobjs= ++U= + for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue + # 1. Remove the extension, and $U if already installed. + ac_script='s/\$U\././;s/\.o$//;s/\.obj$//' +@@ -10112,7 +10124,7 @@ LTLIBOBJS=$ac_ltlibobjs + + + +-: ${CONFIG_STATUS=./config.status} ++: "${CONFIG_STATUS=./config.status}" + ac_write_fail=0 + ac_clean_files_save=$ac_clean_files + ac_clean_files="$ac_clean_files $CONFIG_STATUS" +@@ -10213,6 +10225,7 @@ fi + IFS=" "" $as_nl" + + # Find who we are. Look in the path if we contain no directory separator. ++as_myself= + case $0 in #(( + *[\\/]* ) as_myself=$0 ;; + *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR +@@ -10258,19 +10271,19 @@ export LANGUAGE + (unset CDPATH) >/dev/null 2>&1 && unset CDPATH + + +-# as_fn_error ERROR [LINENO LOG_FD] +-# --------------------------------- ++# as_fn_error STATUS ERROR [LINENO LOG_FD] ++# ---------------------------------------- + # Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are + # provided, also output the error to LOG_FD, referencing LINENO. Then exit the +-# script with status $?, using 1 if that was 0. ++# script with STATUS, using 1 if that was 0. + as_fn_error () + { +- as_status=$?; test $as_status -eq 0 && as_status=1 +- if test "$3"; then +- as_lineno=${as_lineno-"$2"} as_lineno_stack=as_lineno_stack=$as_lineno_stack +- $as_echo "$as_me:${as_lineno-$LINENO}: error: $1" >&$3 ++ as_status=$1; test $as_status -eq 0 && as_status=1 ++ if test "$4"; then ++ as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack ++ $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4 + fi +- $as_echo "$as_me: error: $1" >&2 ++ $as_echo "$as_me: error: $2" >&2 + as_fn_exit $as_status + } # as_fn_error + +@@ -10466,7 +10479,7 @@ $as_echo X"$as_dir" | + test -d "$as_dir" && break + done + test -z "$as_dirs" || eval "mkdir $as_dirs" +- } || test -d "$as_dir" || as_fn_error "cannot create directory $as_dir" ++ } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir" + + + } # as_fn_mkdir_p +@@ -10605,11 +10618,16 @@ ac_need_defaults=: + while test $# != 0 + do + case $1 in +- --*=*) ++ --*=?*) + ac_option=`expr "X$1" : 'X\([^=]*\)='` + ac_optarg=`expr "X$1" : 'X[^=]*=\(.*\)'` + ac_shift=: + ;; ++ --*=) ++ ac_option=`expr "X$1" : 'X\([^=]*\)='` ++ ac_optarg= ++ ac_shift=: ++ ;; + *) + ac_option=$1 + ac_optarg=$2 +@@ -10631,6 +10649,7 @@ do + $ac_shift + case $ac_optarg in + *\'*) ac_optarg=`$as_echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;; ++ '') as_fn_error $? "missing file argument" ;; + esac + as_fn_append CONFIG_FILES " '$ac_optarg'" + ac_need_defaults=false;; +@@ -10643,7 +10662,7 @@ do + ac_need_defaults=false;; + --he | --h) + # Conflict between --help and --header +- as_fn_error "ambiguous option: \`$1' ++ as_fn_error $? "ambiguous option: \`$1' + Try \`$0 --help' for more information.";; + --help | --hel | -h ) + $as_echo "$ac_cs_usage"; exit ;; +@@ -10652,7 +10671,7 @@ Try \`$0 --help' for more information."; + ac_cs_silent=: ;; + + # This is an error. +- -*) as_fn_error "unrecognized option: \`$1' ++ -*) as_fn_error $? "unrecognized option: \`$1' + Try \`$0 --help' for more information." ;; + + *) as_fn_append ac_config_targets " $1" +@@ -10718,7 +10737,7 @@ do + "distrib/configure.ac") CONFIG_FILES="$CONFIG_FILES distrib/configure.ac" ;; + "mk/stamp-h") CONFIG_COMMANDS="$CONFIG_COMMANDS mk/stamp-h" ;; + +- *) as_fn_error "invalid argument: \`$ac_config_target'" "$LINENO" 5;; ++ *) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5;; + esac + done + +@@ -10741,9 +10760,10 @@ fi + # after its creation but before its name has been assigned to `$tmp'. + $debug || + { +- tmp= ++ tmp= ac_tmp= + trap 'exit_status=$? +- { test -z "$tmp" || test ! -d "$tmp" || rm -fr "$tmp"; } && exit $exit_status ++ : "${ac_tmp:=$tmp}" ++ { test ! -d "$ac_tmp" || rm -fr "$ac_tmp"; } && exit $exit_status + ' 0 + trap 'as_fn_exit 1' 1 2 13 15 + } +@@ -10751,12 +10771,13 @@ $debug || + + { + tmp=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` && +- test -n "$tmp" && test -d "$tmp" ++ test -d "$tmp" + } || + { + tmp=./conf$$-$RANDOM + (umask 077 && mkdir "$tmp") +-} || as_fn_error "cannot create a temporary directory in ." "$LINENO" 5 ++} || as_fn_error $? "cannot create a temporary directory in ." "$LINENO" 5 ++ac_tmp=$tmp + + # Set up the scripts for CONFIG_FILES section. + # No need to generate them if there are no CONFIG_FILES. +@@ -10773,12 +10794,12 @@ if test "x$ac_cr" = x; then + fi + ac_cs_awk_cr=`$AWK 'BEGIN { print "a\rb" }' /dev/null` + if test "$ac_cs_awk_cr" = "a${ac_cr}b"; then +- ac_cs_awk_cr='\r' ++ ac_cs_awk_cr='\\r' + else + ac_cs_awk_cr=$ac_cr + fi + +-echo 'BEGIN {' >"$tmp/subs1.awk" && ++echo 'BEGIN {' >"$ac_tmp/subs1.awk" && + _ACEOF + + +@@ -10787,18 +10808,18 @@ _ACEOF + echo "$ac_subst_vars" | sed 's/.*/&!$&$ac_delim/' && + echo "_ACEOF" + } >conf$$subs.sh || +- as_fn_error "could not make $CONFIG_STATUS" "$LINENO" 5 +-ac_delim_num=`echo "$ac_subst_vars" | grep -c '$'` ++ as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 ++ac_delim_num=`echo "$ac_subst_vars" | grep -c '^'` + ac_delim='%!_!# ' + for ac_last_try in false false false false false :; do + . ./conf$$subs.sh || +- as_fn_error "could not make $CONFIG_STATUS" "$LINENO" 5 ++ as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 + + ac_delim_n=`sed -n "s/.*$ac_delim\$/X/p" conf$$subs.awk | grep -c X` + if test $ac_delim_n = $ac_delim_num; then + break + elif $ac_last_try; then +- as_fn_error "could not make $CONFIG_STATUS" "$LINENO" 5 ++ as_fn_error $? "could not make $CONFIG_STATUS" "$LINENO" 5 + else + ac_delim="$ac_delim!$ac_delim _$ac_delim!! " + fi +@@ -10806,7 +10827,7 @@ done + rm -f conf$$subs.sh + + cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 +-cat >>"\$tmp/subs1.awk" <<\\_ACAWK && ++cat >>"\$ac_tmp/subs1.awk" <<\\_ACAWK && + _ACEOF + sed -n ' + h +@@ -10854,7 +10875,7 @@ t delim + rm -f conf$$subs.awk + cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 + _ACAWK +-cat >>"\$tmp/subs1.awk" <<_ACAWK && ++cat >>"\$ac_tmp/subs1.awk" <<_ACAWK && + for (key in S) S_is_set[key] = 1 + FS = "" + +@@ -10886,21 +10907,29 @@ if sed "s/$ac_cr//" < /dev/null > /dev/n + sed "s/$ac_cr\$//; s/$ac_cr/$ac_cs_awk_cr/g" + else + cat +-fi < "$tmp/subs1.awk" > "$tmp/subs.awk" \ +- || as_fn_error "could not setup config files machinery" "$LINENO" 5 ++fi < "$ac_tmp/subs1.awk" > "$ac_tmp/subs.awk" \ ++ || as_fn_error $? "could not setup config files machinery" "$LINENO" 5 + _ACEOF + +-# VPATH may cause trouble with some makes, so we remove $(srcdir), +-# ${srcdir} and @srcdir@ from VPATH if srcdir is ".", strip leading and ++# VPATH may cause trouble with some makes, so we remove sole $(srcdir), ++# ${srcdir} and @srcdir@ entries from VPATH if srcdir is ".", strip leading and + # trailing colons and then remove the whole line if VPATH becomes empty + # (actually we leave an empty line to preserve line numbers). + if test "x$srcdir" = x.; then +- ac_vpsub='/^[ ]*VPATH[ ]*=/{ +-s/:*\$(srcdir):*/:/ +-s/:*\${srcdir}:*/:/ +-s/:*@srcdir@:*/:/ +-s/^\([^=]*=[ ]*\):*/\1/ ++ ac_vpsub='/^[ ]*VPATH[ ]*=[ ]*/{ ++h ++s/// ++s/^/:/ ++s/[ ]*$/:/ ++s/:\$(srcdir):/:/g ++s/:\${srcdir}:/:/g ++s/:@srcdir@:/:/g ++s/^:*// + s/:*$// ++x ++s/\(=[ ]*\).*/\1/ ++G ++s/\n// + s/^[^=]*=[ ]*$// + }' + fi +@@ -10912,7 +10941,7 @@ fi # test -n "$CONFIG_FILES" + # No need to generate them if there are no CONFIG_HEADERS. + # This happens for instance with `./config.status Makefile'. + if test -n "$CONFIG_HEADERS"; then +-cat >"$tmp/defines.awk" <<\_ACAWK || ++cat >"$ac_tmp/defines.awk" <<\_ACAWK || + BEGIN { + _ACEOF + +@@ -10924,11 +10953,11 @@ _ACEOF + # handling of long lines. + ac_delim='%!_!# ' + for ac_last_try in false false :; do +- ac_t=`sed -n "/$ac_delim/p" confdefs.h` +- if test -z "$ac_t"; then ++ ac_tt=`sed -n "/$ac_delim/p" confdefs.h` ++ if test -z "$ac_tt"; then + break + elif $ac_last_try; then +- as_fn_error "could not make $CONFIG_HEADERS" "$LINENO" 5 ++ as_fn_error $? "could not make $CONFIG_HEADERS" "$LINENO" 5 + else + ac_delim="$ac_delim!$ac_delim _$ac_delim!! " + fi +@@ -11013,7 +11042,7 @@ cat >>$CONFIG_STATUS <<_ACEOF || ac_writ + _ACAWK + _ACEOF + cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1 +- as_fn_error "could not setup config headers machinery" "$LINENO" 5 ++ as_fn_error $? "could not setup config headers machinery" "$LINENO" 5 + fi # test -n "$CONFIG_HEADERS" + + +@@ -11026,7 +11055,7 @@ do + esac + case $ac_mode$ac_tag in + :[FHL]*:*);; +- :L* | :C*:*) as_fn_error "invalid tag \`$ac_tag'" "$LINENO" 5;; ++ :L* | :C*:*) as_fn_error $? "invalid tag \`$ac_tag'" "$LINENO" 5;; + :[FH]-) ac_tag=-:-;; + :[FH]*) ac_tag=$ac_tag:$ac_tag.in;; + esac +@@ -11045,7 +11074,7 @@ do + for ac_f + do + case $ac_f in +- -) ac_f="$tmp/stdin";; ++ -) ac_f="$ac_tmp/stdin";; + *) # Look for the file first in the build tree, then in the source tree + # (if the path is not absolute). The absolute path cannot be DOS-style, + # because $ac_f cannot contain `:'. +@@ -11054,7 +11083,7 @@ do + [\\/$]*) false;; + *) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";; + esac || +- as_fn_error "cannot find input file: \`$ac_f'" "$LINENO" 5;; ++ as_fn_error 1 "cannot find input file: \`$ac_f'" "$LINENO" 5;; + esac + case $ac_f in *\'*) ac_f=`$as_echo "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac + as_fn_append ac_file_inputs " '$ac_f'" +@@ -11080,8 +11109,8 @@ $as_echo "$as_me: creating $ac_file" >&6 + esac + + case $ac_tag in +- *:-:* | *:-) cat >"$tmp/stdin" \ +- || as_fn_error "could not create $ac_file" "$LINENO" 5 ;; ++ *:-:* | *:-) cat >"$ac_tmp/stdin" \ ++ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;; + esac + ;; + esac +@@ -11211,23 +11240,24 @@ s&@abs_top_builddir@&$ac_abs_top_builddi + s&@INSTALL@&$ac_INSTALL&;t t + $ac_datarootdir_hack + " +-eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$tmp/subs.awk" >$tmp/out \ +- || as_fn_error "could not create $ac_file" "$LINENO" 5 ++eval sed \"\$ac_sed_extra\" "$ac_file_inputs" | $AWK -f "$ac_tmp/subs.awk" \ ++ >$ac_tmp/out || as_fn_error $? "could not create $ac_file" "$LINENO" 5 + + test -z "$ac_datarootdir_hack$ac_datarootdir_seen" && +- { ac_out=`sed -n '/\${datarootdir}/p' "$tmp/out"`; test -n "$ac_out"; } && +- { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' "$tmp/out"`; test -z "$ac_out"; } && ++ { ac_out=`sed -n '/\${datarootdir}/p' "$ac_tmp/out"`; test -n "$ac_out"; } && ++ { ac_out=`sed -n '/^[ ]*datarootdir[ ]*:*=/p' \ ++ "$ac_tmp/out"`; test -z "$ac_out"; } && + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: $ac_file contains a reference to the variable \`datarootdir' +-which seems to be undefined. Please make sure it is defined." >&5 ++which seems to be undefined. Please make sure it is defined" >&5 + $as_echo "$as_me: WARNING: $ac_file contains a reference to the variable \`datarootdir' +-which seems to be undefined. Please make sure it is defined." >&2;} ++which seems to be undefined. Please make sure it is defined" >&2;} + +- rm -f "$tmp/stdin" ++ rm -f "$ac_tmp/stdin" + case $ac_file in +- -) cat "$tmp/out" && rm -f "$tmp/out";; +- *) rm -f "$ac_file" && mv "$tmp/out" "$ac_file";; ++ -) cat "$ac_tmp/out" && rm -f "$ac_tmp/out";; ++ *) rm -f "$ac_file" && mv "$ac_tmp/out" "$ac_file";; + esac \ +- || as_fn_error "could not create $ac_file" "$LINENO" 5 ++ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 + ;; + :H) + # +@@ -11236,21 +11266,21 @@ which seems to be undefined. Please mak + if test x"$ac_file" != x-; then + { + $as_echo "/* $configure_input */" \ +- && eval '$AWK -f "$tmp/defines.awk"' "$ac_file_inputs" +- } >"$tmp/config.h" \ +- || as_fn_error "could not create $ac_file" "$LINENO" 5 +- if diff "$ac_file" "$tmp/config.h" >/dev/null 2>&1; then ++ && eval '$AWK -f "$ac_tmp/defines.awk"' "$ac_file_inputs" ++ } >"$ac_tmp/config.h" \ ++ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ++ if diff "$ac_file" "$ac_tmp/config.h" >/dev/null 2>&1; then + { $as_echo "$as_me:${as_lineno-$LINENO}: $ac_file is unchanged" >&5 + $as_echo "$as_me: $ac_file is unchanged" >&6;} + else + rm -f "$ac_file" +- mv "$tmp/config.h" "$ac_file" \ +- || as_fn_error "could not create $ac_file" "$LINENO" 5 ++ mv "$ac_tmp/config.h" "$ac_file" \ ++ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 + fi + else + $as_echo "/* $configure_input */" \ +- && eval '$AWK -f "$tmp/defines.awk"' "$ac_file_inputs" \ +- || as_fn_error "could not create -" "$LINENO" 5 ++ && eval '$AWK -f "$ac_tmp/defines.awk"' "$ac_file_inputs" \ ++ || as_fn_error $? "could not create -" "$LINENO" 5 + fi + ;; + +@@ -11272,7 +11302,7 @@ _ACEOF + ac_clean_files=$ac_clean_files_save + + test $ac_write_fail = 0 || +- as_fn_error "write failure creating $CONFIG_STATUS" "$LINENO" 5 ++ as_fn_error $? "write failure creating $CONFIG_STATUS" "$LINENO" 5 + + + # configure is writing to config.log, and then calls config.status. +@@ -11293,7 +11323,7 @@ if test "$no_create" != yes; then + exec 5>>config.log + # Use ||, not &&, to avoid exiting from the if with $? = 1, which + # would make configure fail if this is the last instruction. +- $ac_cs_success || as_fn_exit $? ++ $ac_cs_success || as_fn_exit 1 + fi + if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then + { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5 diff -Nru ghc-7.0.3/debian/patches/do_not_use_epoll_create1 ghc-7.2.1/debian/patches/do_not_use_epoll_create1 --- ghc-7.0.3/debian/patches/do_not_use_epoll_create1 2011-04-09 11:36:49.000000000 +0000 +++ ghc-7.2.1/debian/patches/do_not_use_epoll_create1 1970-01-01 00:00:00.000000000 +0000 @@ -1,41 +0,0 @@ -Index: ghc-7.0.2/libraries/base/System/Event/EPoll.hsc -=================================================================== ---- ghc-7.0.2.orig/libraries/base/System/Event/EPoll.hsc 2011-03-09 21:31:56.000000000 +0530 -+++ ghc-7.0.2/libraries/base/System/Event/EPoll.hsc 2011-03-09 21:31:57.000000000 +0530 -@@ -47,9 +47,7 @@ - import GHC.Real (ceiling, fromIntegral) - import GHC.Show (Show) - import System.Posix.Internals (c_close) --#if !defined(HAVE_EPOLL_CREATE1) - import System.Posix.Internals (setCloseOnExec) --#endif - import System.Posix.Types (Fd(..)) - - import qualified System.Event.Array as A -@@ -159,12 +157,8 @@ - epollCreate :: IO EPollFd - epollCreate = do - fd <- throwErrnoIfMinus1 "epollCreate" $ --#if defined(HAVE_EPOLL_CREATE1) -- c_epoll_create1 (#const EPOLL_CLOEXEC) --#else - c_epoll_create 256 -- argument is ignored - setCloseOnExec fd --#endif - let !epollFd' = EPollFd fd - return epollFd' - -@@ -196,13 +190,8 @@ - fromTimeout Forever = -1 - fromTimeout (Timeout s) = ceiling $ 1000 * s - --#if defined(HAVE_EPOLL_CREATE1) --foreign import ccall unsafe "sys/epoll.h epoll_create1" -- c_epoll_create1 :: CInt -> IO CInt --#else - foreign import ccall unsafe "sys/epoll.h epoll_create" - c_epoll_create :: CInt -> IO CInt --#endif - - foreign import ccall unsafe "sys/epoll.h epoll_ctl" - c_epoll_ctl :: CInt -> CInt -> CInt -> Ptr Event -> IO CInt diff -Nru ghc-7.0.3/debian/patches/getallinfo-nothing-ghci-566331 ghc-7.2.1/debian/patches/getallinfo-nothing-ghci-566331 --- ghc-7.0.3/debian/patches/getallinfo-nothing-ghci-566331 2011-04-09 11:36:49.000000000 +0000 +++ ghc-7.2.1/debian/patches/getallinfo-nothing-ghci-566331 2011-07-30 14:26:14.000000000 +0000 @@ -1,18 +1,18 @@ -Index: ghc-7.0.2/utils/haddock/src/Haddock/Interface/AttachInstances.hs +Index: ghc-7.2.0.20110728/utils/haddock/src/Haddock/Interface/AttachInstances.hs =================================================================== ---- ghc-7.0.2.orig/utils/haddock/src/Haddock/Interface/AttachInstances.hs 2011-02-28 23:40:13.000000000 +0530 -+++ ghc-7.0.2/utils/haddock/src/Haddock/Interface/AttachInstances.hs 2011-03-05 19:05:51.000000000 +0530 -@@ -31,7 +31,9 @@ - import HscTypes (withSession) +--- ghc-7.2.0.20110728.orig/utils/haddock/src/Haddock/Interface/AttachInstances.hs 2011-07-28 19:12:05.000000000 +0200 ++++ ghc-7.2.0.20110728/utils/haddock/src/Haddock/Interface/AttachInstances.hs 2011-07-30 16:26:11.000000000 +0200 +@@ -32,7 +32,9 @@ #endif + import TysPrim( funTyCon ) import MonadUtils (liftIO) +#ifdef GHCI import TcRnDriver (tcRnGetInfo) +#endif - import TypeRep hiding (funTyConName) + import TypeRep import Var hiding (varName) import TyCon -@@ -56,7 +58,11 @@ +@@ -57,7 +59,11 @@ attachToExportItem iface ifaceMap instIfaceMap export = case export of ExportDecl { expItemDecl = L _ (TyClD d) } -> do @@ -24,7 +24,7 @@ let export' = export { expItemInstances = -@@ -95,12 +101,14 @@ +@@ -96,12 +102,14 @@ modName = nameModule name @@ -39,11 +39,11 @@ -------------------------------------------------------------------------------- -Index: ghc-7.0.2/utils/haddock/src/Haddock/Interface/Create.hs +Index: ghc-7.2.0.20110728/utils/haddock/src/Haddock/Interface/Create.hs =================================================================== ---- ghc-7.0.2.orig/utils/haddock/src/Haddock/Interface/Create.hs 2011-02-28 23:40:13.000000000 +0530 -+++ ghc-7.0.2/utils/haddock/src/Haddock/Interface/Create.hs 2011-03-05 19:04:57.000000000 +0530 -@@ -514,7 +514,11 @@ +--- ghc-7.2.0.20110728.orig/utils/haddock/src/Haddock/Interface/Create.hs 2011-07-28 19:12:05.000000000 +0200 ++++ ghc-7.2.0.20110728/utils/haddock/src/Haddock/Interface/Create.hs 2011-07-30 16:25:49.000000000 +0200 +@@ -531,7 +531,11 @@ Nothing -> do -- If we can't find the declaration, it must belong to -- another package diff -Nru ghc-7.0.3/debian/patches/haddock-hardcode-ghc-paths ghc-7.2.1/debian/patches/haddock-hardcode-ghc-paths --- ghc-7.0.3/debian/patches/haddock-hardcode-ghc-paths 2011-04-09 11:36:49.000000000 +0000 +++ ghc-7.2.1/debian/patches/haddock-hardcode-ghc-paths 2011-07-11 09:13:47.000000000 +0000 @@ -37,7 +37,7 @@ getInTreeLibDir #else - return libdir -- from GHC.Paths -+ return "/usr/lib/ghc-@PROJECTVERSION@/" ++ return "/usr/lib/ghc/" #endif xs -> return $ last xs diff -Nru ghc-7.0.3/debian/patches/haddock-no-library ghc-7.2.1/debian/patches/haddock-no-library --- ghc-7.0.3/debian/patches/haddock-no-library 2011-04-09 11:36:49.000000000 +0000 +++ ghc-7.2.1/debian/patches/haddock-no-library 2011-07-30 14:28:32.000000000 +0000 @@ -1,8 +1,8 @@ -Index: ghc-7.0.2/utils/haddock/haddock.cabal +Index: ghc-7.2.0.20110728/utils/haddock/haddock.cabal =================================================================== ---- ghc-7.0.2.orig/utils/haddock/haddock.cabal 2011-03-05 19:06:52.000000000 +0530 -+++ ghc-7.0.2/utils/haddock/haddock.cabal 2011-03-05 19:09:10.000000000 +0530 -@@ -129,68 +129,3 @@ +--- ghc-7.2.0.20110728.orig/utils/haddock/haddock.cabal 2011-07-30 16:26:46.000000000 +0200 ++++ ghc-7.2.0.20110728/utils/haddock/haddock.cabal 2011-07-30 16:28:30.000000000 +0200 +@@ -129,71 +129,6 @@ Haddock.Options Haddock.GhcUtils Haddock.Convert @@ -10,7 +10,7 @@ -library - default-language: Haskell2010 - build-depends: -- base == 4.3.*, +- base >= 4.3 && < 4.5, - filepath, - directory, - pretty, @@ -18,7 +18,7 @@ - array, - xhtml >= 3000.2 && < 3000.3, - Cabal >= 1.10, -- ghc >= 7.0 && < 7.2 +- ghc >= 7.0 && < 7.4 - - if flag(in-ghc-tree) - cpp-options: -DIN_GHC_TREE @@ -71,3 +71,6 @@ - - if flag(in-ghc-tree) - buildable: False + + test-suite html-tests + type: exitcode-stdio-1.0 diff -Nru ghc-7.0.3/debian/patches/kfreebsd-_gnu_source-565818 ghc-7.2.1/debian/patches/kfreebsd-_gnu_source-565818 --- ghc-7.0.3/debian/patches/kfreebsd-_gnu_source-565818 2011-04-09 11:36:49.000000000 +0000 +++ ghc-7.2.1/debian/patches/kfreebsd-_gnu_source-565818 1970-01-01 00:00:00.000000000 +0000 @@ -1,73 +0,0 @@ -Index: ghc-7.0.2/rts/posix/OSThreads.c -=================================================================== ---- ghc-7.0.2.orig/rts/posix/OSThreads.c 2011-02-28 23:40:09.000000000 +0530 -+++ ghc-7.0.2/rts/posix/OSThreads.c 2011-03-05 19:02:06.000000000 +0530 -@@ -7,10 +7,10 @@ - * - * --------------------------------------------------------------------------*/ - --#if defined(__linux__) -+#if defined(__linux__) || defined(__GLIBC__) - /* We want GNU extensions in DEBUG mode for mutex error checking */ - /* We also want the affinity API, which requires _GNU_SOURCE */ --#define _GNU_SOURCE -+#define _GNU_SOURCE 1 - #endif - - #include "PosixSource.h" -Index: ghc-7.0.2/driver/mangler/ghc-asm.lprl -=================================================================== ---- ghc-7.0.2.orig/driver/mangler/ghc-asm.lprl 2011-02-28 23:40:08.000000000 +0530 -+++ ghc-7.0.2/driver/mangler/ghc-asm.lprl 2011-03-05 19:02:06.000000000 +0530 -@@ -216,7 +216,7 @@ - $T_HDR_vector = "\.text\n\t\.align 8\n"; - - #--------------------------------------------------------# -- } elsif ( $TargetPlatform =~ /^x86_64-.*-(linux|openbsd|freebsd|dragonfly|netbsd)$/m ) { -+ } elsif ( $TargetPlatform =~ /^x86_64-.*-(linux|openbsd|freebsd|dragonfly|netbsd|kfreebsdgnu)$/m ) { - - $T_STABBY = 0; # 1 iff .stab things (usually if a.out format) - $T_US = ''; # _ if symbols have an underscore on the front -Index: ghc-7.0.2/rts/Linker.c -=================================================================== ---- ghc-7.0.2.orig/rts/Linker.c 2011-02-28 23:40:08.000000000 +0530 -+++ ghc-7.0.2/rts/Linker.c 2011-03-05 19:04:00.000000000 +0530 -@@ -13,8 +13,8 @@ - /* Linux needs _GNU_SOURCE to get RTLD_DEFAULT from and - MREMAP_MAYMOVE from . - */ --#ifdef __linux__ --#define _GNU_SOURCE -+#if defined(__linux__) || defined(__GLIBC__) -+#define _GNU_SOURCE 1 - #endif - - #include "Rts.h" -@@ -73,7 +73,8 @@ - #if defined(linux_HOST_OS ) || defined(freebsd_HOST_OS) || \ - defined(dragonfly_HOST_OS) || defined(netbsd_HOST_OS ) || \ - defined(openbsd_HOST_OS ) || \ -- ( defined(darwin_HOST_OS ) && !defined(powerpc_HOST_ARCH) ) -+ ( defined(darwin_HOST_OS ) && !defined(powerpc_HOST_ARCH) ) || \ -+ defined(kfreebsdgnu_HOST_OS) \ - /* Don't use mmap on powerpc-apple-darwin as mmap doesn't support - * reallocating but we need to allocate jump islands just after each - * object images. Otherwise relative branches to jump islands can fail -@@ -89,7 +90,7 @@ - - #endif - --#if defined(linux_HOST_OS) || defined(solaris2_HOST_OS) || defined(freebsd_HOST_OS) || defined(dragonfly_HOST_OS) || defined(netbsd_HOST_OS) || defined(openbsd_HOST_OS) -+#if defined(linux_HOST_OS) || defined(solaris2_HOST_OS) || defined(freebsd_HOST_OS) || defined(kfreebsdgnu_HOST_OS) || defined(dragonfly_HOST_OS) || defined(netbsd_HOST_OS) || defined(openbsd_HOST_OS) - # define OBJFORMAT_ELF - # include // regex is already used by dlopen() so this is OK - // to use here without requiring an additional lib -@@ -1590,7 +1591,7 @@ - } else { - if ((W_)result > 0x80000000) { - // oops, we were given memory over 2Gb --#if defined(freebsd_HOST_OS) || defined(dragonfly_HOST_OS) -+#if defined(freebsd_HOST_OS) || defined(kfreebsdgnu_HOST_OS) || defined(dragonfly_HOST_OS) - // Some platforms require MAP_FIXED. This is normally - // a bad idea, because MAP_FIXED will overwrite - // existing mappings. diff -Nru ghc-7.0.3/debian/patches/lpthread-bootstrap-workaround ghc-7.2.1/debian/patches/lpthread-bootstrap-workaround --- ghc-7.0.3/debian/patches/lpthread-bootstrap-workaround 2011-04-09 11:43:29.000000000 +0000 +++ ghc-7.2.1/debian/patches/lpthread-bootstrap-workaround 2011-07-30 14:36:26.000000000 +0000 @@ -1,8 +1,8 @@ -Index: ghc-7.0.3/aclocal.m4 +Index: ghc-7.2.0.20110728/aclocal.m4 =================================================================== ---- ghc-7.0.3.orig/aclocal.m4 2011-04-09 17:11:22.000000000 +0530 -+++ ghc-7.0.3/aclocal.m4 2011-04-09 17:13:24.000000000 +0530 -@@ -1375,7 +1375,7 @@ +--- ghc-7.2.0.20110728.orig/aclocal.m4 2011-07-28 19:12:04.000000000 +0200 ++++ ghc-7.2.0.20110728/aclocal.m4 2011-07-30 16:36:21.000000000 +0200 +@@ -1411,7 +1411,7 @@ dnl except we don't want to have to know what make is called. Sigh. rm -rf utils/ghc-pwd/dist-boot mkdir utils/ghc-pwd/dist-boot diff -Nru ghc-7.0.3/debian/patches/powerpc-compile-616635 ghc-7.2.1/debian/patches/powerpc-compile-616635 --- ghc-7.0.3/debian/patches/powerpc-compile-616635 2011-04-09 11:36:49.000000000 +0000 +++ ghc-7.2.1/debian/patches/powerpc-compile-616635 1970-01-01 00:00:00.000000000 +0000 @@ -1,126 +0,0 @@ -Index: ghc-7.0.2/rts/Linker.c -=================================================================== ---- ghc-7.0.2.orig/rts/Linker.c 2011-03-06 22:22:27.000000000 +1100 -+++ ghc-7.0.2/rts/Linker.c 2011-03-06 22:29:56.000000000 +1100 -@@ -70,12 +70,12 @@ - #include - #endif - --#if defined(linux_HOST_OS ) || defined(freebsd_HOST_OS) || \ -- defined(dragonfly_HOST_OS) || defined(netbsd_HOST_OS ) || \ -- defined(openbsd_HOST_OS ) || \ -- ( defined(darwin_HOST_OS ) && !defined(powerpc_HOST_ARCH) ) || \ -- defined(kfreebsdgnu_HOST_OS) \ --/* Don't use mmap on powerpc-apple-darwin as mmap doesn't support -+#if !defined(powerpc_HOST_ARCH) && \ -+ ( defined(linux_HOST_OS ) || defined(freebsd_HOST_OS) || \ -+ defined(dragonfly_HOST_OS) || defined(netbsd_HOST_OS ) || \ -+ defined(openbsd_HOST_OS ) || defined(darwin_HOST_OS ) || \ -+ defined(kfreebsdgnu_HOST_OS) ) -+/* Don't use mmap on powerpc_HOST_ARCH as mmap doesn't support - * reallocating but we need to allocate jump islands just after each - * object images. Otherwise relative branches to jump islands can fail - * due to 24-bits displacement overflow. -@@ -132,7 +132,7 @@ - static ObjectCode* mkOc( char *path, char *image, int imageSize, - char *archiveMemberName - #ifndef USE_MMAP --#ifdef darwin_HOST_OS -+#ifdef powerpc_HOST_ARCH - , int misalignment - #endif - #endif -@@ -156,7 +156,7 @@ - static int ocGetNames_MachO ( ObjectCode* oc ); - static int ocResolve_MachO ( ObjectCode* oc ); - --#ifndef USE_MMAP -+#if !defined USE_MMAP && defined(darwin_HOST_OS) - static int machoGetMisalignment( FILE * ); - #endif - #if defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH) -@@ -1630,7 +1630,7 @@ - mkOc( char *path, char *image, int imageSize, - char *archiveMemberName - #ifndef USE_MMAP --#ifdef darwin_HOST_OS -+#ifdef powerpc_HOST_ARCH - , int misalignment - #endif - #endif -@@ -1669,7 +1669,7 @@ - oc->proddables = NULL; - - #ifndef USE_MMAP --#ifdef darwin_HOST_OS -+#ifdef powerpc_HOST_ARCH - oc->misalignment = misalignment; - #endif - #endif -@@ -1696,7 +1696,7 @@ - char tmp[12]; - char *gnuFileIndex; - int gnuFileIndexSize; --#if !defined(USE_MMAP) && defined(darwin_HOST_OS) -+#if !defined(USE_MMAP) && defined(powerpc_HOST_ARCH) - int misalignment; - #endif - -@@ -1890,7 +1890,7 @@ - - oc = mkOc(path, image, memberSize, archiveMemberName - #ifndef USE_MMAP --#ifdef darwin_HOST_OS -+#ifdef powerpc_HOST_ARCH - , misalignment - #endif - #endif -@@ -1971,7 +1971,7 @@ - int fd; - #else - FILE *f; --# if defined(darwin_HOST_OS) -+# if defined(powerpc_HOST_ARCH) - int misalignment; - # endif - #endif -@@ -2065,7 +2065,7 @@ - - oc = mkOc(path, image, fileSize, NULL - #ifndef USE_MMAP --#ifdef darwin_HOST_OS -+#ifdef powerpc_HOST_ARCH - , misalignment - #endif - #endif -@@ -2315,7 +2315,7 @@ - int aligned; - #ifndef USE_MMAP - int misalignment = 0; --#ifdef darwin_HOST_OS -+#ifdef powerpc_HOST_ARCH - misalignment = oc->misalignment; - #endif - #endif -@@ -5344,7 +5344,7 @@ - } - #endif - --#ifndef USE_MMAP -+#if !defined USE_MMAP && defined(darwin_HOST_OS) - /* - * Figure out by how much to shift the entire Mach-O file in memory - * when loading so that its single segment ends up 16-byte-aligned -Index: ghc-7.0.2/rts/LinkerInternals.h -=================================================================== ---- ghc-7.0.2.orig/rts/LinkerInternals.h 2011-03-06 22:22:19.000000000 +1100 -+++ ghc-7.0.2/rts/LinkerInternals.h 2011-03-06 22:22:27.000000000 +1100 -@@ -80,7 +80,7 @@ - /* ptr to malloc'd lump of memory holding the obj file */ - char* image; - --#ifdef darwin_HOST_OS -+#ifdef powerpc_HOST_ARCH - /* record by how much image has been deliberately misaligned - after allocation, so that we can use realloc */ - int misalignment; diff -Nru ghc-7.0.3/debian/patches/series ghc-7.2.1/debian/patches/series --- ghc-7.0.3/debian/patches/series 2011-04-09 14:55:15.000000000 +0000 +++ ghc-7.2.1/debian/patches/series 2011-08-23 19:00:09.000000000 +0000 @@ -1,11 +1,9 @@ system-libffi -kfreebsd-_gnu_source-565818 getallinfo-nothing-ghci-566331 haddock-hardcode-ghc-paths use-debian-gen_contents_index haddock-no-library -powerpc-compile-616635 -do_not_use_epoll_create1 lpthread-bootstrap-workaround autoconf haddock-expose-interface-version +debian-changes-7.2.1-1 diff -Nru ghc-7.0.3/debian/patches/system-libffi ghc-7.2.1/debian/patches/system-libffi --- ghc-7.0.3/debian/patches/system-libffi 2011-04-09 11:42:57.000000000 +0000 +++ ghc-7.2.1/debian/patches/system-libffi 2011-07-30 14:23:01.000000000 +0000 @@ -1,10 +1,10 @@ -Index: ghc-7.0.3/rts/ghc.mk +Index: ghc-7.2.0.20110728/rts/ghc.mk =================================================================== ---- ghc-7.0.3.orig/rts/ghc.mk 2011-04-09 17:12:53.000000000 +0530 -+++ ghc-7.0.3/rts/ghc.mk 2011-04-09 17:12:55.000000000 +0530 -@@ -457,15 +457,13 @@ +--- ghc-7.2.0.20110728.orig/rts/ghc.mk 2011-07-28 19:12:04.000000000 +0200 ++++ ghc-7.2.0.20110728/rts/ghc.mk 2011-07-30 16:22:27.000000000 +0200 +@@ -455,15 +455,13 @@ - $(eval $(call build-dependencies,rts,dist,1)) + $(eval $(call dependencies,rts,dist,1)) -$(rts_dist_depfile_c_asm) : libffi/dist-install/build/ffi.h $(DTRACEPROBES_H) - @@ -22,10 +22,10 @@ # ----------------------------------------------------------------------------- # compile dtrace probes if dtrace is supported -Index: ghc-7.0.3/rts/package.conf.in +Index: ghc-7.2.0.20110728/rts/package.conf.in =================================================================== ---- ghc-7.0.3.orig/rts/package.conf.in 2011-04-09 17:12:53.000000000 +0530 -+++ ghc-7.0.3/rts/package.conf.in 2011-04-09 17:12:55.000000000 +0530 +--- ghc-7.2.0.20110728.orig/rts/package.conf.in 2011-07-28 19:12:04.000000000 +0200 ++++ ghc-7.2.0.20110728/rts/package.conf.in 2011-07-30 16:22:27.000000000 +0200 @@ -24,8 +24,9 @@ hs-libraries: "HSrts" @@ -45,11 +45,11 @@ hugs-options: cc-options: -Index: ghc-7.0.3/ghc.mk +Index: ghc-7.2.0.20110728/ghc.mk =================================================================== ---- ghc-7.0.3.orig/ghc.mk 2011-04-09 17:12:53.000000000 +0530 -+++ ghc-7.0.3/ghc.mk 2011-04-09 17:12:55.000000000 +0530 -@@ -439,7 +439,6 @@ +--- ghc-7.2.0.20110728.orig/ghc.mk 2011-07-28 19:12:04.000000000 +0200 ++++ ghc-7.2.0.20110728/ghc.mk 2011-07-30 16:22:59.000000000 +0200 +@@ -449,7 +449,6 @@ # add the final two package.conf dependencies: ghc-prim depends on RTS, # and RTS depends on libffi. libraries/ghc-prim/dist-install/package-data.mk : rts/package.conf.inplace @@ -57,9 +57,9 @@ endif # -------------------------------- -@@ -454,11 +453,6 @@ +@@ -467,11 +466,6 @@ endif - BOOT_LIBS = $(foreach lib,$(STAGE0_PACKAGES),$(libraries/$(lib)_dist-boot_v_LIB)) + BOOT_LIBS = $(foreach lib,$(PACKAGES_STAGE0),$(libraries/$(lib)_dist-boot_v_LIB)) -OTHER_LIBS = libffi/dist-install/build/libHSffi$(v_libsuf) libffi/dist-install/build/HSffi.o -ifeq "$(BuildSharedLibs)" "YES" @@ -69,7 +69,7 @@ # ---------------------------------------- # Special magic for the ghc-prim package -@@ -583,7 +577,6 @@ +@@ -560,7 +554,6 @@ driver/ghci \ driver/ghc \ driver/haddock \ @@ -77,7 +77,7 @@ includes \ rts -@@ -941,11 +934,10 @@ +@@ -865,11 +858,10 @@ # Now we can do the installation install_packages: install_libexecs @@ -90,16 +90,16 @@ "$(INSTALLED_GHC_PKG_REAL)" --force --global-conf "$(INSTALLED_PACKAGE_CONF)" update rts/package.conf.install $(foreach p, $(INSTALLED_PKG_DIRS), \ $(call make-command, \ -@@ -1027,7 +1019,7 @@ +@@ -957,7 +949,7 @@ 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 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 ++ set -e; for i in packages LICENSE compiler ghc rts libraries utils docs 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) -@@ -1106,7 +1098,7 @@ +@@ -1042,7 +1034,7 @@ # # Files to include in source distributions # diff -Nru ghc-7.0.3/debian/patches/use-debian-gen_contents_index ghc-7.2.1/debian/patches/use-debian-gen_contents_index --- ghc-7.0.3/debian/patches/use-debian-gen_contents_index 2011-04-09 11:43:04.000000000 +0000 +++ ghc-7.2.1/debian/patches/use-debian-gen_contents_index 2011-07-30 14:27:15.000000000 +0000 @@ -1,16 +1,16 @@ -Index: ghc-7.0.3/ghc.mk +Index: ghc-7.2.0.20110728/ghc.mk =================================================================== ---- ghc-7.0.3.orig/ghc.mk 2011-04-09 17:12:55.000000000 +0530 -+++ ghc-7.0.3/ghc.mk 2011-04-09 17:13:01.000000000 +0530 -@@ -698,7 +698,6 @@ +--- ghc-7.2.0.20110728.orig/ghc.mk 2011-07-30 16:22:59.000000000 +0200 ++++ ghc-7.2.0.20110728/ghc.mk 2011-07-30 16:27:14.000000000 +0200 +@@ -645,7 +645,6 @@ # Build the Haddock contents and index ifeq "$(HADDOCK_DOCS)" "YES" - libraries/index.html: $(ALL_HADDOCK_FILES) + libraries/index.html: inplace/bin/haddock$(exeext) $(ALL_HADDOCK_FILES) - cd libraries && sh gen_contents_index --inplace + ifeq "$(phase)" "final" $(eval $(call all-target,library_doc_index,libraries/index.html)) - INSTALL_LIBRARY_DOCS += libraries/*.html libraries/*.gif libraries/*.css libraries/*.js - CLEAN_FILES += libraries/doc-index* libraries/haddock*.css \ -@@ -891,12 +890,8 @@ + endif +@@ -815,12 +814,8 @@ $(call INSTALL_DIR,"$(DESTDIR)$(docdir)/html") $(call INSTALL_DOC,$(INSTALL_OPTS),docs/index.html,"$(DESTDIR)$(docdir)/html") ifneq "$(INSTALL_LIBRARY_DOCS)" "" @@ -24,7 +24,7 @@ endif ifneq "$(INSTALL_HTML_DOC_DIRS)" "" for i in $(INSTALL_HTML_DOC_DIRS); do \ -@@ -1003,7 +998,6 @@ +@@ -933,7 +928,6 @@ mk/project.mk \ mk/install.mk.in \ bindist.mk \ diff -Nru ghc-7.0.3/debian/rules ghc-7.2.1/debian/rules --- ghc-7.0.3/debian/rules 2011-06-17 15:30:40.000000000 +0000 +++ ghc-7.2.1/debian/rules 2011-08-02 07:01:39.000000000 +0000 @@ -25,7 +25,7 @@ # confflags += --build $(DEB_BUILD_GNU_TYPE) --host $(DEB_HOST_GNU_TYPE) #endif -ProjectVersion=$(shell awk -F\' "/^PACKAGE_VERSION='[0-9.]+'\$$/ { print \$$2 }" configure) +ProjectVersion=$(shell cat VERSION) GHC=$(firstword $(shell bash -c "type -p ghc")) EXTRA_CONFIGURE_FLAGS=--with-ghc="$(GHC)" @@ -82,6 +82,7 @@ endif # We can't do this with a configure flag in 6.8.1 as libdir is not # defined at the point at which we := it + echo 'ghclibdir := $${libdir}/ghc' >> mk/build.mk echo 'bindir := $${ghclibdir}/bin' >> mk/build.mk echo 'ghclibexecdir := $${ghclibdir}/lib' >> mk/build.mk # docdir doesn't have a configure flag, and unfortunately @@ -120,7 +121,6 @@ # build haddock separately and hard code paths according to install paths mkdir -p debian/haddock-build cp -r utils/haddock debian/haddock-build - sed -i s/@PROJECTVERSION@/$(ProjectVersion)/ debian/haddock-build/haddock/src/Main.hs cd debian/haddock-build/haddock; \ ../../../inplace/bin/ghc-stage2 --make Setup.lhs; \ ./Setup configure --prefix=/usr --with-compiler=../../../inplace/bin/ghc-stage2 \ @@ -140,7 +140,6 @@ dh_testdir dh_testroot dh_prep - dh_installdirs /var/lib/ghc-$(ProjectVersion)/package.conf.d # Install the basic stuff $(MAKE) DESTDIR=$(CURDIR)/debian/tmp install @@ -155,37 +154,36 @@ echo "ghc-prof binary: extra-license-file `cd debian/tmp && echo usr/lib/ghc-*/Cabal-*/Distribution/License.p_hi`" >> debian/tmp/usr/share/lintian/overrides/ghc-prof # Sort out the package.conf files - mkdir -p debian/tmp/var/lib/ghc-$(ProjectVersion) - mv debian/tmp/usr/lib/ghc-$(ProjectVersion)/package.conf.d \ - debian/tmp/var/lib/ghc-$(ProjectVersion)/ - rm debian/tmp/var/lib/ghc-$(ProjectVersion)/package.conf.d/package.cache + mkdir -p debian/tmp/var/lib/ghc + # Old directories for symlink-workaround. Remove once all libraries use new path + mv debian/tmp/usr/lib/ghc/package.conf.d \ + debian/tmp/var/lib/ghc/ + rm debian/tmp/var/lib/ghc/package.conf.d/package.cache chmod +x debian/provided_substvars debian/provided_substvars - sed -ri 's,^haddock-interfaces: /.*?/libraries/,haddock-interfaces: /usr/lib/ghc-doc/haddock/,' debian/tmp/var/lib/ghc-$(ProjectVersion)/package.conf.d/*.conf + sed -ri 's,^haddock-interfaces: /.*?/libraries/,haddock-interfaces: /usr/lib/ghc-doc/haddock/,' debian/tmp/var/lib/ghc/package.conf.d/*.conf # Remove haddock as built within the ghc tree - rm -f debian/tmp/usr/lib/ghc-$(ProjectVersion)/bin/haddock \ - debian/tmp/usr/lib/ghc-$(ProjectVersion)/bin/haddock-$(ProjectVersion) \ - debian/tmp/usr/lib/ghc-$(ProjectVersion)/lib/haddock - rm -rf debian/tmp/usr/lib/ghc-$(ProjectVersion)/html + rm -f debian/tmp/usr/lib/ghc/bin/haddock \ + debian/tmp/usr/lib/ghc/bin/haddock-$(ProjectVersion) \ + debian/tmp/usr/lib/ghc/lib/haddock + rm -rf debian/tmp/usr/lib/ghc/html # Sort out the binaries mkdir -p debian/tmp/usr/bin if inplace/bin/ghc-stage2 --info | grep '"Have interpreter","NO"'; then \ - cd debian/tmp/usr/lib/ghc-$(ProjectVersion) ;rm -f bin/ghci* bin/runghc* bin/runhaskell*; \ + cd debian/tmp/usr/lib/ghc ;rm -f bin/ghci* bin/runghc* bin/runhaskell*; \ fi - cd debian/tmp/usr/lib/ghc-$(ProjectVersion)/bin && \ + cd debian/tmp/usr/lib/ghc/bin && \ for f in *; \ - do ln -s /usr/lib/ghc-$(ProjectVersion)/bin/$$f \ + do ln -s /usr/lib/ghc/bin/$$f \ ../../../bin/$${f}; \ done - sed -i 's,topdir="/usr/lib,topdir="/var/lib,' debian/tmp/usr/lib/ghc-$(ProjectVersion)/bin/ghc-pkg-$(ProjectVersion) + sed -i 's,topdir="/usr/lib,topdir="/var/lib,' debian/tmp/usr/lib/ghc/bin/ghc-pkg-$(ProjectVersion) cd debian/haddock-build/haddock; ./Setup copy --dest=../../tmp - ProjectVersion=$(ProjectVersion) $(MAKE) -f debian/scripts.mk all - # Check if we have a ghci binary - if test -e debian/tmp/usr/bin/ghci-$(ProjectVersion); then \ + if test -e debian/tmp/usr/lib/ghc/bin/ghci-$(ProjectVersion); then \ echo 'ghci=ghc-ghci' >> debian/ghc.substvars ; fi # Add haddock substvars @@ -205,7 +203,7 @@ endif ifeq (ia64,$(DEB_HOST_ARCH)) # Tested and seen to be necessary with 6.12.1 - sed -i "s/exec /unset LC_ALL\nexport LC_CTYPE=en_US\nexec /" debian/tmp/usr/lib/ghc-$(ProjectVersion)/bin/ghc-$(ProjectVersion) + sed -i "s/exec /unset LC_ALL\nexport LC_CTYPE=en_US\nexec /" debian/tmp/usr/lib/ghc/bin/ghc-$(ProjectVersion) endif # manpages @@ -231,7 +229,7 @@ find debian/tmp/usr/bin $(FILES) ! -name haddock > debian/ghc.install # find debian/tmp/usr/share/ghc* $(FILES) >> debian/ghc.install find debian/tmp/usr/share/man $(FILES) >> debian/ghc.install - find debian/tmp/usr/lib/ghc-$(ProjectVersion) $(FILES) ! $(PROF_FILE) ! $(DYNAMIC_FILE) >> debian/ghc.install + find debian/tmp/usr/lib/ghc $(FILES) ! $(PROF_FILE) ! $(DYNAMIC_FILE) >> debian/ghc.install find debian/tmp/var >> debian/ghc.install echo debian/tmp/usr/share/lintian/overrides/ghc >> debian/ghc.install # ghc-prof @@ -250,7 +248,7 @@ endif sed -i s,^debian/tmp,, debian/*.install rm -f debian/ghc.links - echo "/var/lib/ghc-$(ProjectVersion)/package.conf.d /usr/lib/ghc-$(ProjectVersion)/package.conf.d" >> debian/ghc.links + echo "/var/lib/ghc/package.conf.d /usr/lib/ghc/package.conf.d" >> debian/ghc.links touch $@ clean: @@ -263,11 +261,10 @@ $(MAKE) distclean rm -f config.sub config.guess rm -f debian/*.install - rm -f debian/*.1 debian/ghc-pkg.man + rm -f debian/*.1 rm -f debian/ghc.manpages rm -f debian/ghc.links rm -f mk/build.mk - $(MAKE) -f debian/scripts.mk clean rm -rf debian/testghc rm -f ch01.html ch02.html index.html rm -rf debian/haddock-build diff -Nru ghc-7.0.3/debian/scripts.mk ghc-7.2.1/debian/scripts.mk --- ghc-7.0.3/debian/scripts.mk 2011-06-17 15:08:58.000000000 +0000 +++ ghc-7.2.1/debian/scripts.mk 1970-01-01 00:00:00.000000000 +0000 @@ -1,16 +0,0 @@ -#!/usr/bin/make -f - -FILES = debian/ghc.postinst debian/ghc.prerm debian/ghc.triggers -FILES += debian/ghc-doc.postinst debian/gen_contents_index debian/ghc-doc.triggers -FILES += debian/ghc-doc.preinst debian/ghc-pkg.man - -.PHONY: all clean - -all: $(FILES) - -%: %.in - sed "s/@VERSION@/$(ProjectVersion)/" $< > $@ - -clean: - rm -f $(FILES) - diff -Nru ghc-7.0.3/distrib/compare/BuildInfo.hs ghc-7.2.1/distrib/compare/BuildInfo.hs --- ghc-7.0.3/distrib/compare/BuildInfo.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/distrib/compare/BuildInfo.hs 2011-08-07 17:10:05.000000000 +0000 @@ -0,0 +1,59 @@ + +module BuildInfo where + +import Control.Monad.State + +type BIMonad = StateT BuildInfo Maybe + +data BuildInfo = BuildInfo { + biThingVersionMap :: ThingVersionMap, + biThingHashMap :: ThingHashMap, + biMaybeWays :: Maybe Ways + } + deriving Show + +type ThingMap = [(String, String)] +-- Mapping from thing (e.g. "Cabal") to version (e.g. "1.10.0.0") +type ThingVersionMap = ThingMap +-- Mapping from thing (e.g. "Cabal") to ABI hash +-- (e.g. "e1f7c380581d61d42b0360d440cc35ed") +type ThingHashMap = ThingMap +-- The list of ways in the order the build system uses them, e.g. +-- ["v", "p", "dyn"] => we have ".depend-v-p-dyn.haskell" files +type Ways = [String] + +emptyBuildInfo :: Maybe Ways -> BuildInfo +emptyBuildInfo mWays = BuildInfo { + biThingVersionMap = [], + biThingHashMap = [], + biMaybeWays = mWays + } + +addThingMap :: ThingMap -> String -> String -> Maybe ThingMap +addThingMap mapping thing str + = case lookup thing mapping of + Just str' -> + if str == str' + then Just mapping + else Nothing + Nothing -> + Just ((thing, str) : mapping) + +getMaybeWays :: BIMonad (Maybe Ways) +getMaybeWays = do st <- get + return $ biMaybeWays st + +haveThingVersion :: String -> String -> BIMonad () +haveThingVersion thing thingVersion + = do st <- get + case addThingMap (biThingVersionMap st) thing thingVersion of + Nothing -> fail "Inconsistent version" + Just tvm -> put $ st { biThingVersionMap = tvm } + +haveThingHash :: String -> String -> BIMonad () +haveThingHash thing thingHash + = do st <- get + case addThingMap (biThingHashMap st) thing thingHash of + Nothing -> fail "Inconsistent hash" + Just thm -> put $ st { biThingHashMap = thm } + diff -Nru ghc-7.0.3/distrib/compare/Change.hs ghc-7.2.1/distrib/compare/Change.hs --- ghc-7.0.3/distrib/compare/Change.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/distrib/compare/Change.hs 2011-08-07 17:10:05.000000000 +0000 @@ -0,0 +1,43 @@ + +module Change where + +data FileChange = First Change + | Second Change + | Change Change + +data Change = DuplicateFile FilePath + | ExtraFile FilePath + | ExtraWay String + | ExtraThing String + | ThingVersionChanged String String String + | PermissionsChanged FilePath FilePath String String + | FileSizeChanged FilePath FilePath Integer Integer + +isSizeChange :: FileChange -> Bool +isSizeChange (Change (FileSizeChanged {})) = True +isSizeChange _ = False + +pprFileChange :: FileChange -> String +pprFileChange (First p) = "First " ++ pprChange p +pprFileChange (Second p) = "Second " ++ pprChange p +pprFileChange (Change p) = "Change " ++ pprChange p + +pprChange :: Change -> String +pprChange (DuplicateFile fp) = "Duplicate file: " ++ show fp +pprChange (ExtraFile fp) = "Extra file: " ++ show fp +pprChange (ExtraWay w) = "Extra way: " ++ show w +pprChange (ExtraThing t) = "Extra thing: " ++ show t +pprChange (ThingVersionChanged t v1 v2) + = "Version changed for " ++ show t ++ ":\n" + ++ " " ++ v1 ++ " -> " ++ v2 +pprChange (PermissionsChanged fp1 fp2 p1 p2) + = "Permissions changed:\n" + ++ " " ++ show fp1 + ++ " " ++ show fp2 + ++ " " ++ p1 ++ " -> " ++ p2 +pprChange (FileSizeChanged fp1 fp2 s1 s2) + = "Size changed:\n" + ++ " " ++ show fp1 ++ "\n" + ++ " " ++ show fp2 ++ "\n" + ++ " " ++ show s1 ++ " -> " ++ show s2 + diff -Nru ghc-7.0.3/distrib/compare/compare.hs ghc-7.2.1/distrib/compare/compare.hs --- ghc-7.0.3/distrib/compare/compare.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/distrib/compare/compare.hs 2011-08-07 17:10:05.000000000 +0000 @@ -0,0 +1,269 @@ +{-# LANGUAGE PatternGuards #-} + +module Main (main) where + +import Control.Monad.State +import Data.List +import System.Environment + +import BuildInfo +import FilenameDescr +import Change +import Utils +import Tar + +-- TODO: +-- * Check installed trees too +-- * Check hashbangs + +-- Only size changes > sizeAbs are considered an issue +sizeAbs :: Integer +sizeAbs = 1000 + +-- Only a size change of sizePercentage% or more is considered an issue +sizePercentage :: Integer +sizePercentage = 150 + +main :: IO () +main = do args <- getArgs + case args of + [bd1, bd2] -> doit False bd1 bd2 + ["--ignore-size-changes", bd1, bd2] -> doit True bd1 bd2 + _ -> die ["Bad args. Need 2 bindists."] + +doit :: Bool -> FilePath -> FilePath -> IO () +doit ignoreSizeChanges bd1 bd2 + = do tls1 <- readTarLines bd1 + tls2 <- readTarLines bd2 + let mWays1 = findWays tls1 + mWays2 = findWays tls2 + wayDifferences <- case (mWays1, mWays2) of + (Nothing, Nothing) -> + return [] + (Just ways1, Just ways2) -> + return $ diffWays ways1 ways2 + _ -> + die ["One input has ways, but the other doesn't"] + (content1, tvm1) <- dieOnErrors $ mkContents mWays1 tls1 + (content2, tvm2) <- dieOnErrors $ mkContents mWays2 tls2 + let sortedContent1 = sortByFst content1 + sortedContent2 = sortByFst content2 + (nubProbs1, nubbedContent1) = nubContents sortedContent1 + (nubProbs2, nubbedContent2) = nubContents sortedContent2 + differences = compareContent mWays1 nubbedContent1 + mWays2 nubbedContent2 + allProbs = map First nubProbs1 ++ map Second nubProbs2 + ++ diffThingVersionMap tvm1 tvm2 + ++ wayDifferences + ++ differences + wantedProbs = if ignoreSizeChanges + then filter (not . isSizeChange) allProbs + else allProbs + mapM_ (putStrLn . pprFileChange) wantedProbs + +-- *nix bindists have ways. +-- Windows "bindists", install trees, and testsuites don't. +findWays :: [TarLine] -> Maybe Ways +findWays tls = msum $ map f tls + where f tl = case re regex (tlFileName tl) of + Just [dashedWays] -> Just (unSepList '-' dashedWays) + _ -> Nothing + regex = "/libraries/base/dist-install/build/\\.depend-(.*)\\.haskell" + +diffWays :: Ways -> Ways -> [FileChange] +diffWays ws1 ws2 = f (sort ws1) (sort ws2) + where f [] [] = [] + f xs [] = map (First . ExtraWay) xs + f [] ys = map (Second . ExtraWay) ys + f xs@(x : xs') ys@(y : ys') + = case x `compare` y of + LT -> First (ExtraWay x) : f xs' ys + GT -> Second (ExtraWay y) : f xs ys' + EQ -> f xs' ys' + +diffThingVersionMap :: ThingVersionMap -> ThingVersionMap -> [FileChange] +diffThingVersionMap tvm1 tvm2 = f (sortByFst tvm1) (sortByFst tvm2) + where f [] [] = [] + f xs [] = map (First . ExtraThing . fst) xs + f [] ys = map (Second . ExtraThing . fst) ys + f xs@((xt, xv) : xs') ys@((yt, yv) : ys') + = case xt `compare` yt of + LT -> First (ExtraThing xt) : f xs' ys + GT -> Second (ExtraThing yt) : f xs ys' + EQ -> let this = if xv == yv + then [] + else [Change (ThingVersionChanged xt xv yv)] + in this ++ f xs' ys' + +mkContents :: Maybe Ways -> [TarLine] + -> Either Errors ([(FilenameDescr, TarLine)], ThingVersionMap) +mkContents mWays tls + = case runStateT (mapM f tls) (emptyBuildInfo mWays) of + Nothing -> Left ["Can't happen: mkContents: Nothing"] + Just (xs, finalBuildInfo) -> + case concat $ map (checkContent finalBuildInfo) xs of + [] -> Right (xs, biThingVersionMap finalBuildInfo) + errs -> Left errs + where f tl = do fnd <- mkFilePathDescr (tlFileName tl) + return (fnd, tl) + +nubContents :: [(FilenameDescr, TarLine)] + -> ([Change], [(FilenameDescr, TarLine)]) +nubContents [] = ([], []) +nubContents [x] = ([], [x]) +nubContents (x1@(fd1, tl1) : xs@((fd2, _) : _)) + | fd1 == fd2 = (DuplicateFile (tlFileName tl1) : ps, xs') + | otherwise = (ps, x1 : xs') + where (ps, xs') = nubContents xs + +mkFilePathDescr :: FilePath -> BIMonad FilenameDescr +mkFilePathDescr fp + | Just [ghcVersion, _, middle, filename] + <- re ("^ghc-" ++ versionRE ++ "(/.*)?/([^/]*)$") fp + = do haveThingVersion "ghc" ghcVersion + middle' <- mkMiddleDescr middle + filename' <- mkFileNameDescr filename + let fd = FP "ghc-" : VersionOf "ghc" : middle' ++ FP "/" : filename' + return $ normalise fd + | otherwise = return [FP fp] + +mkMiddleDescr :: FilePath -> BIMonad FilenameDescr +mkMiddleDescr middle + -- haddock docs in a Windows installed tree + | Just [thing, thingVersion, _, src] + <- re ("^/doc/html/libraries/([^/]*)-" ++ versionRE ++ "(/src)?$") + middle + = do haveThingVersion thing thingVersion + return [FP "/doc/html/libraries/", + FP thing, FP "-", VersionOf thing, FP src] + `mplus` unchanged + -- libraries in a Windows installed tree + | Just [thing, thingVersion, _, rest] + <- re ("^/lib/([^/]*)-" ++ versionRE ++ "(/.*)?$") + middle + = do haveThingVersion thing thingVersion + return [FP "/lib/", FP thing, FP "-", VersionOf thing, FP rest] + `mplus` unchanged + -- Windows in-tree gcc + | Just [prefix, _, _, gccVersion, _, rest] + <- re ("^(/mingw/(lib(exec)?/gcc/mingw32/|share/gcc-))" ++ versionRE ++ "(/.*)?$") + middle + = do haveThingVersion "gcc" gccVersion + return [FP prefix, VersionOf "gcc", FP rest] + `mplus` unchanged + | otherwise = unchanged + where unchanged = return [FP middle] + +mkFileNameDescr :: FilePath -> BIMonad FilenameDescr +mkFileNameDescr filename + | Just [prog, ghcVersion, _, exe] + <- re ("^(ghc|ghci|ghcii|haddock)-" ++ versionRE ++ "(\\.exe|\\.sh|)$") + filename + = do haveThingVersion "ghc" ghcVersion + return [FP prog, FP "-", VersionOf "ghc", FP exe] + `mplus` unchanged + | Just [thing, thingVersion, _, ghcVersion, _, soDll] + <- re ("^libHS(.*)-" ++ versionRE ++ "-ghc" ++ versionRE ++ "\\.(so|dll|dylib)$") + filename + = do haveThingVersion "ghc" ghcVersion + haveThingVersion thing thingVersion + return [FP "libHS", FP thing, FP "-", VersionOf thing, + FP "-ghc", VersionOf "ghc", FP ".", FP soDll] + `mplus` unchanged + | Just [way, thingVersion, _, soDll] + <- re ("^libHSrts(_.*)?-ghc" ++ versionRE ++ "\\.(so|dll|dylib)$") + filename + = do haveThingVersion "ghc" thingVersion + return [FP "libHSrts", FP way, FP "-ghc", VersionOf "ghc", + FP ".", FP soDll] + `mplus` unchanged + | Just [thingVersion, _, soDll] + <- re ("^libHSffi-ghc" ++ versionRE ++ "\\.(so|dll|dylib)$") + filename + = do haveThingVersion "ghc" thingVersion + return [FP "libHSffi-ghc", VersionOf "ghc", FP ".", FP soDll] + `mplus` unchanged + | Just [thing, thingVersion, _, way] + <- re ("^libHS(.*)-" ++ versionRE ++ "(_.*)?\\.a$") + filename + = do haveThingVersion thing thingVersion + return [FP "libHS", FP thing, FP "-", VersionOf thing, + FP way, FP ".a"] + `mplus` unchanged + | Just [thing, thingVersion, _] + <- re ("^HS(.*)-" ++ versionRE ++ "\\.o$") + filename + = do haveThingVersion thing thingVersion + return [FP "HS", FP thing, FP "-", VersionOf thing, FP ".o"] + `mplus` unchanged + | Just [thing, thingVersion, _, thingHash] + <- re ("^(.*)-" ++ versionRE ++ "-([0-9a-f]{32})\\.conf$") + filename + = do haveThingVersion thing thingVersion + haveThingHash thing thingHash + return [FP thing, FP "-", VersionOf thing, FP "-", HashOf thing, + FP ".conf"] + `mplus` unchanged + | Just [thingVersion, _] + <- re ("^mingw32-gcc-" ++ versionRE ++ "\\.exe$") + filename + = do haveThingVersion "gcc" thingVersion + return [FP "mingw32-gcc-", VersionOf "gcc", FP ".exe"] + `mplus` unchanged + | Just [dashedWays, depType] + <- re "^\\.depend-(.*)\\.(haskell|c_asm)" + filename + = do mWays <- getMaybeWays + if Just (unSepList '-' dashedWays) == mWays + then return [FP ".depend-", Ways, FP ".", FP depType] + else unchanged + | otherwise = unchanged + where unchanged = return [FP filename] + +compareContent :: Maybe Ways -> [(FilenameDescr, TarLine)] + -> Maybe Ways -> [(FilenameDescr, TarLine)] + -> [FileChange] +compareContent mWays1 xs1all mWays2 xs2all + = f xs1all xs2all + where f [] [] = [] + f xs [] = concatMap (mkExtraFile mWays1 mWays2 First . tlFileName . snd) xs + f [] ys = concatMap (mkExtraFile mWays2 mWays1 Second . tlFileName . snd) ys + f xs1@((fd1, tl1) : xs1') xs2@((fd2, tl2) : xs2') + = case fd1 `compare` fd2 of + EQ -> map Change (compareTarLine tl1 tl2) + ++ f xs1' xs2' + LT -> mkExtraFile mWays1 mWays2 First (tlFileName tl1) + ++ f xs1' xs2 + GT -> mkExtraFile mWays2 mWays1 Second (tlFileName tl2) + ++ f xs1 xs2' + mkExtraFile mWaysMe mWaysThem mkFileChange filename + = case (findFileWay filename, mWaysMe, mWaysThem) of + (Just way, Just waysMe, Just waysThem) + | (way `elem` waysMe) && not (way `elem` waysThem) -> [] + _ -> [mkFileChange (ExtraFile filename)] + +findFileWay :: FilePath -> Maybe String +findFileWay fp + | Just [way] <- re "\\.([a-z_]+)_hi$" fp + = Just way + | Just [_, _, way] <- re ("libHS.*-" ++ versionRE ++ "_([a-z_]+).a$") fp + = Just way + | otherwise = Nothing + +compareTarLine :: TarLine -> TarLine -> [Change] +compareTarLine tl1 tl2 + = [ PermissionsChanged fn1 fn2 perms1 perms2 | perms1 /= perms2 ] + ++ [ FileSizeChanged fn1 fn2 size1 size2 | sizeChanged ] + where fn1 = tlFileName tl1 + fn2 = tlFileName tl2 + perms1 = tlPermissions tl1 + perms2 = tlPermissions tl2 + size1 = tlSize tl1 + size2 = tlSize tl2 + sizeChanged = abs (size1 - size2) > sizeAbs + && (((100 * size1) `div` size2) > sizePercentage || + ((100 * size2) `div` size1) > sizePercentage) + +versionRE :: String +versionRE = "([0-9]+(\\.[0-9]+)*)" + diff -Nru ghc-7.0.3/distrib/compare/FilenameDescr.hs ghc-7.2.1/distrib/compare/FilenameDescr.hs --- ghc-7.0.3/distrib/compare/FilenameDescr.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/distrib/compare/FilenameDescr.hs 2011-08-07 17:10:05.000000000 +0000 @@ -0,0 +1,56 @@ + +module FilenameDescr where + +import Data.Either +import Data.List + +import BuildInfo +import Utils +import Tar + +-- We can't just compare plain filenames, because versions numbers of GHC +-- and the libaries will vary. So we use FilenameDescr instead, which +-- abstracts out the version numbers. +type FilenameDescr = [FilenameDescrBit] +data FilenameDescrBit = VersionOf String + | HashOf String + | FP String + | Ways + deriving (Show, Eq, Ord) + +normalise :: FilenameDescr -> FilenameDescr +normalise [] = [] +normalise [x] = [x] +normalise (FP x1 : FP x2 : xs) = normalise (FP (x1 ++ x2) : xs) +normalise (x : xs) = x : normalise xs + +-- Sanity check that the FilenameDescr matches the filename in the tar line +checkContent :: BuildInfo -> (FilenameDescr, TarLine) -> Errors +checkContent buildInfo (fd, tl) + = let fn = tlFileName tl + in case flattenFilenameDescr buildInfo fd of + Right fn' -> + if fn' == fn + then [] + else ["checkContent: Can't happen: filename mismatch: " ++ show fn] + Left errs -> + errs + +flattenFilenameDescr :: BuildInfo -> FilenameDescr + -> Either Errors FilePath +flattenFilenameDescr buildInfo fd = case partitionEithers (map f fd) of + ([], strs) -> Right (concat strs) + (errs, _) -> Left (concat errs) + where f (FP fp) = Right fp + f (VersionOf thing) + = case lookup thing (biThingVersionMap buildInfo) of + Just v -> Right v + Nothing -> Left ["Can't happen: thing has no version in mapping"] + f (HashOf thing) + = case lookup thing (biThingHashMap buildInfo) of + Just v -> Right v + Nothing -> Left ["Can't happen: thing has no hash in mapping"] + f Ways = case biMaybeWays buildInfo of + Just ways -> Right $ intercalate "-" ways + Nothing -> Left ["Can't happen: No ways, but Ways is used"] + diff -Nru ghc-7.0.3/distrib/compare/Makefile ghc-7.2.1/distrib/compare/Makefile --- ghc-7.0.3/distrib/compare/Makefile 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/distrib/compare/Makefile 2011-08-07 17:10:05.000000000 +0000 @@ -0,0 +1,12 @@ + +GHC = ghc + +compare: *.hs + "$(GHC)" -O --make -Wall -Werror $@ + +.PHONY: clean +clean: + rm -f *.o + rm -f *.hi + rm -f compare compare.exe + diff -Nru ghc-7.0.3/distrib/compare/Tar.hs ghc-7.2.1/distrib/compare/Tar.hs --- ghc-7.0.3/distrib/compare/Tar.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/distrib/compare/Tar.hs 2011-08-07 17:10:05.000000000 +0000 @@ -0,0 +1,58 @@ + +module Tar where + +import Data.Either +import Data.List +import System.Exit +import System.Process + +import Utils + +readTarLines :: FilePath -> IO [TarLine] +readTarLines fp + = do (ec, out, err) <- readProcessWithExitCode "tar" ["-jtvf", fp] "" + case (ec, err) of + (ExitSuccess, []) -> + case parseTarLines fp out of + Left errs -> die errs + Right tls -> return tls + _ -> + die ["Failed running tar -jtvf " ++ show fp, + "Exit code: " ++ show ec, + "Stderr: " ++ show err] + +parseTarLines :: FilePath -> String -> Either Errors [TarLine] +parseTarLines fp xs + = case partitionEithers (zipWith (parseTarLine fp) [1..] (lines xs)) of + ([], tls) -> Right tls + (errss, _) -> Left (intercalate [""] errss) + +data TarLine = TarLine { + tlPermissions :: String, + tlUser :: String, + tlGroup :: String, + tlSize :: Integer, + tlDateTime :: String, + tlFileName :: FilePath + } + +parseTarLine :: FilePath -> Int -> String -> Either Errors TarLine +parseTarLine fp line str + = case re "^([^ ]+) ([^ ]+)/([^ ]+) +([0-9]+) ([^ ]+ [^ ]+) ([^ ]+)$" + str of + Just [perms, user, grp, sizeStr, dateTime, filename] -> + case maybeRead sizeStr of + Just size -> + Right $ TarLine { + tlPermissions = perms, + tlUser = user, + tlGroup = grp, + tlSize = size, + tlDateTime = dateTime, + tlFileName = filename + } + _ -> error "Can't happen: Can't parse size" + _ -> + Left ["In " ++ show fp ++ ", at line " ++ show line, + "Tar line doesn't parse: " ++ show str] + diff -Nru ghc-7.0.3/distrib/compare/Utils.hs ghc-7.2.1/distrib/compare/Utils.hs --- ghc-7.0.3/distrib/compare/Utils.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/distrib/compare/Utils.hs 2011-08-07 17:10:05.000000000 +0000 @@ -0,0 +1,40 @@ + +module Utils where + +import Data.Function +import Data.List +import System.Exit +import System.IO +import Text.Regex.Posix + +die :: Errors -> IO a +die errs = do mapM_ (hPutStrLn stderr) errs + exitFailure + +dieOnErrors :: Either Errors a -> IO a +dieOnErrors (Left errs) = die errs +dieOnErrors (Right x) = return x + +type Errors = [String] + +maybeRead :: Read a => String -> Maybe a +maybeRead str = case reads str of + [(x, "")] -> Just x + _ -> Nothing + +re :: String -> String -> Maybe [String] +re r str = case matchM r' str :: Maybe (String, String, String, [String]) of + Just (_, _, _, ms) -> Just ms + Nothing -> Nothing + where r' = makeRegex r :: Regex + +unSepList :: Eq a => a -> [a] -> [[a]] +unSepList x xs = case break (x ==) xs of + (this, _ : xs') -> + this : unSepList x xs' + (this, []) -> + [this] + +sortByFst :: Ord a => [(a, b)] -> [(a, b)] +sortByFst = sortBy (compare `on` fst) + diff -Nru ghc-7.0.3/distrib/configure.ac ghc-7.2.1/distrib/configure.ac --- ghc-7.0.3/distrib/configure.ac 2011-03-26 18:11:24.000000000 +0000 +++ ghc-7.2.1/distrib/configure.ac 2011-08-07 17:11:44.000000000 +0000 @@ -4,7 +4,7 @@ #!/bin/sh # -AC_INIT([The Glorious Glasgow Haskell Compilation System], [7.0.3], [glasgow-haskell-bugs@haskell.org], [ghc]) +AC_INIT([The Glorious Glasgow Haskell Compilation System], [7.2.1], [glasgow-haskell-bugs@haskell.org], [ghc]) FP_BINDIST_GHC_PWD FP_FIND_ROOT @@ -47,15 +47,13 @@ # AC_PATH_PROG(SedCmd,gsed sed,sed) -# -dnl ** How to invoke gcc/cpp ** -# -FP_ARG_WITH_PATH_GNU_PROG([CC], [gcc]) -export CC -WhatGccIsCalled="$CC" -AC_SUBST(WhatGccIsCalled) +XCODE_VERSION() -FP_HAVE_GCC +dnl ** Which gcc to use? +dnl -------------------------------------------------------------- +FIND_GCC() + +FP_GCC_VERSION AC_PROG_CPP # @@ -82,13 +80,15 @@ AC_SUBST(CONF_CPP_OPTS_STAGE1) AC_SUBST(CONF_CPP_OPTS_STAGE2) +FP_SETTINGS + # 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 -Nru ghc-7.0.3/distrib/configure.ac.in ghc-7.2.1/distrib/configure.ac.in --- ghc-7.0.3/distrib/configure.ac.in 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/distrib/configure.ac.in 2011-08-07 17:10:05.000000000 +0000 @@ -47,15 +47,13 @@ # AC_PATH_PROG(SedCmd,gsed sed,sed) -# -dnl ** How to invoke gcc/cpp ** -# -FP_ARG_WITH_PATH_GNU_PROG([CC], [gcc]) -export CC -WhatGccIsCalled="$CC" -AC_SUBST(WhatGccIsCalled) +XCODE_VERSION() -FP_HAVE_GCC +dnl ** Which gcc to use? +dnl -------------------------------------------------------------- +FIND_GCC() + +FP_GCC_VERSION AC_PROG_CPP # @@ -82,13 +80,15 @@ AC_SUBST(CONF_CPP_OPTS_STAGE1) AC_SUBST(CONF_CPP_OPTS_STAGE2) +FP_SETTINGS + # 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 -Nru ghc-7.0.3/distrib/ghc.iss ghc-7.2.1/distrib/ghc.iss --- ghc-7.0.3/distrib/ghc.iss 2011-03-26 18:11:24.000000000 +0000 +++ ghc-7.2.1/distrib/ghc.iss 2011-08-07 17:11:44.000000000 +0000 @@ -2,8 +2,8 @@ [Setup] AppName=GHC -AppVerName=GHC 7.0.3 -DefaultDirName={sd}\ghc\ghc-7.0.3 +AppVerName=GHC 7.2.1 +DefaultDirName={sd}\ghc\ghc-7.2.1 UsePreviousAppDir=no DefaultGroupName=GHC UninstallDisplayIcon={app}\bin\ghci.exe @@ -24,16 +24,16 @@ ; install main payload, license file and icon [Files] -Source: "bindistprep\ghc-7.0.3\*"; DestDir: "{app}"; Flags: recursesubdirs +Source: "bindistprep\ghc-7.2.1\*"; DestDir: "{app}"; Flags: recursesubdirs Source: "distrib\windows-installer-licences.txt"; DestDir: "{app}\doc" Source: "distrib\hsicon.ico"; DestDir: "{app}\icons" ; Start Menu shortcuts [Icons] -Name: "{group}\7.0.3\GHCi"; Filename: "{app}\bin\ghci.exe"; WorkingDir: "{app}\bin" -Name: "{group}\7.0.3\GHC Documentation"; Filename: "{app}\doc\html\index.html" -Name: "{group}\7.0.3\GHC Library Documentation"; Filename: "{app}\doc\html\libraries\index.html" -Name: "{group}\7.0.3\GHC Flag Reference"; Filename: "{app}\doc\html\users_guide\flag-reference.html" +Name: "{group}\7.2.1\GHCi"; Filename: "{app}\bin\ghci.exe"; WorkingDir: "{app}\bin" +Name: "{group}\7.2.1\GHC Documentation"; Filename: "{app}\doc\html\index.html" +Name: "{group}\7.2.1\GHC Library Documentation"; Filename: "{app}\doc\html\libraries\index.html" +Name: "{group}\7.2.1\GHC Flag Reference"; Filename: "{app}\doc\html\users_guide\flag-reference.html" [Registry] ; set up file associations @@ -47,15 +47,15 @@ Root: HKCR; Subkey: "ghc_haskell\shell\open\command"; ValueType: string; ValueName: ""; ValueData: """{app}\bin\ghci.exe"" ""%1"""; Flags: uninsdeletevalue; Tasks: fileassoc\default ; add versioned GHCi entry to right-click menu -Root: HKCR; Subkey: "ghc_haskell\shell\Open with GHCi 7.0.3"; ValueType: none; ValueName: ""; ValueData: ""; Flags: uninsdeletekey; Tasks: fileassoc\addon -Root: HKCR; Subkey: "ghc_haskell\shell\Open with GHCi 7.0.3\command"; ValueType: string; ValueName: ""; ValueData: """{app}\bin\ghci.exe"" ""%1"""; Flags: uninsdeletevalue; Tasks: fileassoc\addon +Root: HKCR; Subkey: "ghc_haskell\shell\Open with GHCi 7.2.1"; ValueType: none; ValueName: ""; ValueData: ""; Flags: uninsdeletekey; Tasks: fileassoc\addon +Root: HKCR; Subkey: "ghc_haskell\shell\Open with GHCi 7.2.1\command"; ValueType: string; ValueName: ""; ValueData: """{app}\bin\ghci.exe"" ""%1"""; Flags: uninsdeletevalue; Tasks: fileassoc\addon ; associate file type with icon Root: HKCR; Subkey: "ghc_haskell\DefaultIcon"; ValueType: string; ValueName: ""; ValueData: "{app}\icons\hsicon.ico"; Tasks: fileassoc\icon ; these flags were always set in the past, by the installer ; some programs may rely on them to find GHC -Root: HKCU; Subkey: "Software\Haskell\GHC\ghc-7.0.3"; ValueType: string; ValueName: "InstallDir"; ValueData: "{app}"; Flags: uninsdeletekey +Root: HKCU; Subkey: "Software\Haskell\GHC\ghc-7.2.1"; ValueType: string; ValueName: "InstallDir"; ValueData: "{app}"; Flags: uninsdeletekey Root: HKCU; Subkey: "Software\Haskell\GHC"; ValueType: string; ValueName: "InstallDir"; ValueData: "{app}"; Flags: uninsdeletevalue ; set the PATH variable, for both GHC and Cabal diff -Nru ghc-7.0.3/distrib/MacOS/GHC-relocatable.pmdoc/index.xml ghc-7.2.1/distrib/MacOS/GHC-relocatable.pmdoc/index.xml --- ghc-7.0.3/distrib/MacOS/GHC-relocatable.pmdoc/index.xml 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/distrib/MacOS/GHC-relocatable.pmdoc/index.xml 2011-08-07 17:10:05.000000000 +0000 @@ -1,4 +1,4 @@ -Glasgow Haskell Compiler/Users/chak/Desktop/Glasgow Haskell Compiler.pkgorg.haskellThe Glasgow Haskell Compiler (GHC) is a state-of-the-art, open source, compiler and interactive environment for the functional language Haskell. GHC supports the entire Haskell 98 language plus a wide variety of extensions. GHC generates fast code, is available on a range of platforms, and includes an extensive set of libraries.build/Release/GHC.framework/Versions/609/ghc/LICENSEGlasgow Haskell Compiler/Users/chak/Desktop/Glasgow Haskell Compiler.pkgorg.haskellThe Glasgow Haskell Compiler (GHC) is a state-of-the-art, open source, compiler and interactive environment for the functional language Haskell. GHC supports the entire Haskell language plus a wide variety of extensions. GHC generates fast code, is available on a range of platforms, and includes an extensive set of libraries.build/Release/GHC.framework/Versions/609/ghc/LICENSEGlasgow Haskell Compiler/Users/bjs/Desktop/Glasgow Haskell Compiler.pkgorg.haskellThe Glasgow Haskell Compiler (GHC) is a state-of-the-art, open source, compiler and interactive environment for the functional language Haskell. GHC supports the entire Haskell 98 language plus a wide variety of extensions. GHC generates fast code, is available on a range of platforms, and includes an extensive set of libraries. For more information, please consult <http://haskell.org/ghc>.installer-docs/lambda-logo.pnginstaller-docs/license.htmlGlasgow Haskell Compiler/Users/bjs/Desktop/Glasgow Haskell Compiler.pkgorg.haskellThe Glasgow Haskell Compiler (GHC) is a state-of-the-art, open source, compiler and interactive environment for the functional language Haskell. GHC supports the entire Haskell language plus a wide variety of extensions. GHC generates fast code, is available on a range of platforms, and includes an extensive set of libraries. For more information, please consult <http://haskell.org/ghc>.installer-docs/lambda-logo.pnginstaller-docs/license.html&2 + exit 1 +} + +[ "$#" -eq 2 ] || die "Bad args. Usage: $0 " + +LINUX_BINDIST=`realpath "$1"` +WINDOWS_BINDIST=`realpath "$2"` + +mkdir docs +cd docs +tar -jxf "$LINUX_BINDIST" +mv ghc* linux +tar -jxf "$WINDOWS_BINDIST" +mv ghc* windows +cd linux +./configure --prefix=`pwd`/inst +make install +cd inst/share/doc/ghc/html/libraries +mv ../../../../../../../windows/doc/html/libraries/Win32-* . +sh gen_contents_index +cd .. +for i in Cabal haddock libraries users_guide +do + tar -jcf ../../../../../../$i.html.tar.bz2 $i +done +cd .. +mv *.pdf *.ps ../../../../.. + diff -Nru ghc-7.0.3/docs/index.html ghc-7.2.1/docs/index.html --- ghc-7.0.3/docs/index.html 2011-03-26 18:11:24.000000000 +0000 +++ ghc-7.2.1/docs/index.html 2011-08-07 17:11:44.000000000 +0000 @@ -39,13 +39,14 @@

  • - GHC API + GHC API

    Documentation for the GHC API.

    • +

    For more information, see the following:

    diff -Nru ghc-7.0.3/docs/index.html.in ghc-7.2.1/docs/index.html.in --- ghc-7.0.3/docs/index.html.in 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/docs/index.html.in 2011-08-07 17:10:05.000000000 +0000 @@ -46,6 +46,7 @@

    +

    For more information, see the following:

    diff -Nru ghc-7.0.3/docs/Makefile ghc-7.2.1/docs/Makefile --- ghc-7.0.3/docs/Makefile 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/docs/Makefile 2011-08-07 17:10:05.000000000 +0000 @@ -1,26 +1,4 @@ +dir = docs TOP = .. -include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/sub-makefile.mk -SUBDIRS = man docbook-cheat-sheet users_guide ext-core storage-mgt - -PAGE = index.html - -install-docs :: $(PAGE) - $(INSTALL_DIR) $(DESTDIR)$(htmldir) - $(INSTALL_DATA) $(INSTALL_OPTS) $(PAGE) $(DESTDIR)$(htmldir) - -.PHONY: binary-dist binary-dist.doc.% - -binary-dist: $(foreach SUBDIR,$(SUBDIRS),binary-dist.doc.$(SUBDIR)) -ifeq "$(WHERE_AM_I)" "" - echo "I don't know where I am" >&2 - exit 1 -endif - echo $(WHERE_AM_I)/Makefile >> $(BIN_DIST_LIST) - echo $(WHERE_AM_I)/$(PAGE) >> $(BIN_DIST_LIST) - -$(foreach SUBDIR,$(SUBDIRS),binary-dist.doc.$(SUBDIR)): \ -binary-dist.doc.%: - $(MAKE) -C $* binary-dist WHERE_AM_I=$(WHERE_AM_I)/$* - -include $(TOP)/mk/target.mk diff -Nru ghc-7.0.3/docs/man/ghc.mk ghc-7.2.1/docs/man/ghc.mk --- ghc-7.0.3/docs/man/ghc.mk 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/docs/man/ghc.mk 2011-08-07 17:10:05.000000000 +0000 @@ -39,7 +39,9 @@ sed 1d $< >> $@ ifeq "$(BUILD_MAN)" "YES" +ifeq "$(phase)" "final" $(eval $(call all-target,docs/man,$(MAN_PATH))) +endif INSTALL_MANPAGES += $(MAN_PATH) diff -Nru ghc-7.0.3/docs/users_guide/6.10.1-notes.xml ghc-7.2.1/docs/users_guide/6.10.1-notes.xml --- ghc-7.0.3/docs/users_guide/6.10.1-notes.xml 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/docs/users_guide/6.10.1-notes.xml 1970-01-01 00:00:00.000000000 +0000 @@ -1,1255 +0,0 @@ - - - Release notes for version 6.10.1 - - - The significant changes to the various parts of the compiler are - listed in the following sections. - - - - User-visible compiler changes - - - - The new QuasiQuotes language extension adds - general quasi-quotation, as described in - "Nice to be Quoted: Quasiquoting for Haskell" - (Geoffrey Mainland, Haskell Workshop 2007). - See for more information. - - - - - The new ViewPatterns language extension allows - "view patterns". The syntax for view patterns - is expression -> pattern in a pattern. - For more information, see . - - - - - GHC already supported (e op) postfix operators, but this - support was enabled by default. Now you need to use the - PostfixOperators language extension if you want it. - See for more information - on postfix operators. - - - - - The new TransformListComp language extension enables - implements generalised list comprehensions, as described in - the paper "Comprehensive comprehensions" (Peyton Jones & - Wadler, Haskell Workshop 2007). - For more information see - . - - - - - If you want to use impredicative types then you now need to - enable the ImpredicativeTypes language extension. - See for more - information. - - - - - FFI change: header files are now not - used when compiling via C. - The flag, - the includes field - in .cabal files, and header files - specified in a foreign import - declaration all have no effect when compiling Haskell - source code. - - This change has important ramifications if you are - calling FFI functions that are defined by macros (or renamed - by macros). If you need to call one of these functions, - then write a C wrapper for the function and call the wrapper - using the FFI instead. In this way, your code will work - with GHC 6.10.1, and will also work - with in older GHCs. - - This change was made for several reasons. - Firstly, now behaves consistently - with , which is important because we - intend to stop compiling via C in the future. Also, we - don't need to worry about the interactions between header - files, or CPP options necessary to expose certain functions - from the system header files (this was becoming quite a - headache). We don't need to worry about needing header - files when inlining FFI calls across module or package - boundaries; calls can now be inlined freely. One downside - is that you don't get a warning from the C compiler when you - call a function via the FFI at the wrong type. - - - Another consequence of this change is that - calling varargs functions (such - as printf) via the FFI no longer works. - It has never been officially supported (the FFI spec outlaws - it), but in GHC 6.10.1 it may now really cause a crash on - certain platforms. Again, to call one of these functions - use appropriate fixed-argument C wrappers. - - - - There is a new languages extension PackageImports which allows - imports to be qualified with the package they should come - from, e.g. - - -import "network" Network.Socket - - - Note that this feature is not intended for general use, it - was added for constructing backwards-compatibility packages - such as the base-3.0.3.0 package. See - for more details. - - - - - In earlier versions of GHC, the recompilation checker didn't - notice changes in other packages meant that recompilation is - needed. This is now handled properly, using MD5 checksums of - the interface ABIs. - - - - - GHC now treats the Unicode "Letter, Other" class as lowercase - letters. This is an arbitrary choice, but better than not - allowing them in identifiers at all. This may be revisited - by Haskell'. - - - - - In addition to the DEPRECATED pragma, you - can now attach arbitrary warnings to declarations with the new - WARNING pragma. See - for more details. - - - - - If GHC is failing due to -Werror, then it - now emits a message telling you so. - - - - - GHC now warns about unrecognised pragmas, as they are often - caused by a typo. The - -fwarn-unrecognised-pragmas controls - whether this warning is emitted. - The warning is enabled by default. - - - - - There is a new flag - -fwarn-dodgy-foreign-imports which controls - a new warning about FFI delcarations of the form - - -foreign import "f" f :: FunPtr t - - - on the grounds that it is probably meant to be - - -foreign import "&f" f :: FunPtr t - - - The warning is enabled by default. - - - - - External core (output only) is working again. - - - - - There is a new flag -dsuppress-uniques that - makes GHC's intermediate core easier to read. This flag cannot - be used when actually generating code. - - - - - There is a new flag -dno-debug-output that - suppresses all of the debug information when running a - compiler built with the DEBUG option. - - - - - A bug in earlier versions of GHC meant that sections didn't - always need to be parenthesised, e.g. - (+ 1, 2) was accepted. This has now been - fixed. - - - - - The -fspec-threshold flag has been replaced - by -fspec-constr-threshold and - -fliberate-case-threshold flags. - The thresholds can be disabled by - -fno-spec-constr-threshold and - -fno-liberate-case-threshold. - - - - - The new flag -fsimplifier-phases - controls the number of simplifier phases run during - optimisation. These are numbered from n to 1 (by default, n=2). - Phase 0 is always run regardless of this flag. - - - - - Simplifier phases can have an arbitrary number of tags - assigned to them, and multiple phases can share the same tags. - The tags can be used as arguments to the new flag - -ddump-simpl-phases - to specify which phases are to be dumped. - - - - For example, - -ddump-simpl-phases=main will dump the - output of phases 2, 1 and 0 of the initial simplifier run - (they all share the "main" tag) while - -ddump-simpl-phases=main:0 - will dump only the output of phase 0 of that run. - - - - At the moment, the supported tags are - main (the main, staged simplifier run (before strictness)), - post-worker-wrapper (after the w/w split), - post-liberate-case (after LiberateCase), and - final (final clean-up run) - - - - The names are somewhat arbitrary and will change in the future. - - - - - The -fno-method-sharing flag is now - dynamic (it used to be static). - - - - - - - Deprecated flags - - - - - The new flag -fwarn-deprecated-flags, - controls whether we warn about deprecated flags and language - extensions. The warning is on by default. - - - - - The following language extensions are now marked as - deprecated; expect them to be removed in a future release: - - - - - RecordPuns - (use NamedFieldPuns instead) - - - - - PatternSignatures - (use ScopedTypeVariables instead) - - - - - - - The following flags are now marked as deprecated; - expect them to be removed in a future release: - - - - - -Onot - (use -O0 instead) - - - - - -Wnot - (use -w instead) - - - - - -frewrite-rules - (use -fenable-rewrite-rules instead) - - - - - -no-link - (use -c instead) - - - - - -recomp - (use -fno-force-recomp instead) - - - - - -no-recomp - (use -fforce-recomp instead) - - - - - -syslib - (use -package instead) - - - - - -fth - (use the TemplateHaskell language - extension instead) - - - - - -ffi, -fffi - (use the ForeignFunctionInterface - extension instead) - - - - - -farrows - (use the Arrows language - extension instead) - - - - - -fgenerics - (use the Generics language - extension instead) - - - - - -fno-implicit-prelude - (use the NoImplicitPrelude language - extension instead) - - - - - -fbang-patterns - (use the BangPatterns language - extension instead) - - - - - -fno-monomorphism-restriction - (use the NoMonomorphismRestriction language - extension instead) - - - - - -fmono-pat-binds - (use the MonoPatBinds language - extension instead) - - - - - -fextended-default-rules - (use the ExtendedDefaultRules language - extension instead) - - - - - -fimplicit-params - (use the ImplicitParams language - extension instead) - - - - - -fscoped-type-variables - (use the ScopedTypeVariables language - extension instead) - - - - - -fparr - (use the PArr language - extension instead) - - - - - -fallow-overlapping-instances - (use the OverlappingInstances language - extension instead) - - - - - -fallow-undecidable-instances - (use the UndecidableInstances language - extension instead) - - - - - -fallow-incoherent-instances - (use the IncoherentInstances language - extension instead) - - - - - -optdep-s - (use -dep-suffix instead) - - - - - -optdep-f - (use -dep-makefile instead) - - - - - -optdep-w - (has no effect) - - - - - -optdep--include-prelude - (use -include-pkg-deps instead) - - - - - -optdep--include-pkg-deps - (use -include-pkg-deps instead) - - - - - -optdep--exclude-module - (use -exclude-module instead) - - - - - -optdep-x - (use -exclude-module instead) - - - - - - - The following flags have been removed: - - - - - -no-link-chk - (has been a no-op since at least 6.0) - - - - - -fruntime-types - (has not been used for years) - - - - - -fhardwire-lib-paths - (use -dynload sysdep) - - - - - - - The -unreg flag, which was used to build - unregisterised code with a registerised compiler, has been - removed. Now you need to build an unregisterised compiler - if you want to build unregisterised code. - - - - - - - GHC API changes - - - - - There is now a Ghc Monad used to carry around GHC's - Session data. This Monad also provides exception handling - functions. - - - - - It is now possible to get the raw characters corresponding to - each token the lexer outputs, and thus to reconstruct the - original file. - - - - - GHCi implicitly brings all exposed modules into scope with - qualified module names. There is a new flag - -fimplicit-import-qualified - that controls this behaviour, so other GHC API clients can - specify whether or not they want it. - - - - - There is now haddock documentation for much of the GHC API. - - - - - - - GHCi changes - - - - - You can now force GHCi to interpret a module, rather than - loading its compiled code, by prepending a * character to its - name, e.g. - - -Prelude> :load *A -Compiling A ( A.hs, interpreted ) -*A> - - - - - By default, GHCi will not print bind results, e.g. - - -Prelude> c <- return 'c' -Prelude> - - - does not print 'c'. Use - -fprint-bind-result if you want the old - behaviour. - - - - - GHCi now uses editline, rather than readline, for input. - This shouldn't affect its behaviour. - - - - - The GHCi prompt history is now saved in - ~/.ghc/ghci_history. - - - - - GHCi now uses libffi to make FFI calls, which means that the - FFI now works in GHCi on a much wider range of platforms - (all those platforms that libffi supports). - - - - - - - Runtime system changes - - - - - The garbage collector can now use multiple threads in parallel. - The new -gn RTS - flag controls it, e.g. run your program with - +RTS -g2 -RTS to use 2 threads. - The option is implied by the - usual option, so normally there will be - no need to specify it separately, although occasionally it - is useful to turn it off with . - Do let us know if you experience strange effects, - especially an increase in GC time when using the parallel GC - (use to measure GC time). - See for more details. - - - - It is now possible to generate a heap profile without - recompiling your program for profiling. Run the program - with to generate a basic heap - profile, and use hp2ps as usual to - convert the heap profile into a .ps file - for viewing. See for more - details. - - - - - If the user presses control-C while running a Haskell program - then the program gets an asynchronous UserInterrupt exception. - - - - - We now ignore SIGPIPE by default. - - - - - The -S and -s RTS flags - now send their output to stderr, rather than - prog.stat, - by default. - - - - - The new -vg RTS flag provides some RTS trace - messages even in the non-debug RTS variants. - - - - - - - runghc - - - - - runghc now uses the compiler that it came with to run the - code, rather than the first compiler that it finds on the - PATH. - - - - - If the program to run does not have a .lhs - extension then runghc now treats it as a .hs - file. In particular, this means that programs without an - extension now work. - - - - - runghc foo will now work if - foo.hs or foo.lhs exists. - - - - - runghc can now take the code to run from stdin. - - - - - - - ghc-pkg - - - - ghc-pkg will refuse to unregister a package on which - other packages depend, unless - the option is also - supplied. - - - - ghc-pkg now has a -no-user-package-conf - flag which instructs it to ignore the user's personal - package.conf. - - - - - ghc-pkg no longer allows you to register two packages that - differ in case only. - - - - - ghc-pkg no longer allows you to register packages which have - unversioned dependencies. - - - - - There is a new command dump which is - similar to describe '*', but in a format - that is designed to be parsable by other tools. - - - - - - - Haddock - - - - - Haddock 2 now comes with GHC. - - - - - - - DPH changes - - - - - DPH is now an extralib. - - - - - There is a new flag -Odph that sets the - flags recommended when using DPH. Currently it is equivalent - to - - -O2 -fno-method-sharing -fdicts-cheap - -fmax-simplifier-iterations20 -fno-spec-constr-threshold - - - - - - There are now flags -fdph-seq and - -fdph-par for selecting which DPH backend - to use. - - - - - The -fflatten flag has been removed. It - never worked and has now been superceded by vectorisation. - - - - - - - Boot Libraries - - - array - - - - Version number 0.2.0.0 (was 0.1.0.0) - - - - - - - base - - - - Version number 4.0.0.0 (was 3.0.2.0) - - - - - We also ship a base version 3.0.3.0, so legacy code should - continue to work. - - - - The Show instance - for Ratio now puts spaces around - the %, as required by Haskell 98. - - - - There is a new module Control.Category. - - - - - >>> is no longer a method of the - Arrow class; instead - Category is a superclass of - Arrow. - - - - - pure is no longer a method of the - Arrow class; use arr - instead. - - - - - Control.Exception now uses extensible - exceptions. The old style of exceptions are still available - in Control.OldException, but we expect to - remove them in a future release. - - - - - There is a new function - System.Exit.exitSuccess :: IO a - analogous to the existing - System.Exit.exitFailure :: IO a. - - - - - There are new functions - Data.Either.lefts :: [Either a b] -> [a], - Data.Either.rights :: [Either a b] -> [b] - and - - Data.Either.partitionEithers :: [Either a b] -> ([a], [b]) - . - - - - - The new function - Data.List.subsequences :: [a] -> [[a]] - gives all sublists of a list, e.g. - - subsequences "abc" == - ["","a","b","ab","c","ac","bc","abc"] - . - - - - - The new function - Data.List.permutations :: [a] -> [[a]] - gives all permutations of a list, e.g. - - permutations "abc" == - ["abc","bac","cba","bca","cab","acb"] - . - - - - - The new functions - Data.Traversable.mapAccumL and - Data.Traversable.mapAccumR generalise their - Data.List counterparts to work on any - Traversable type. - - - - - The new function - Control.Exception.blocked :: IO Bool - tells you whether or not exceptions are blocked (as controlled - by Control.Exception.(un)block). - - - - - There is a new function - traceShow :: Show a => a -> b -> b in - Debug.Trace. - - - - - The type of Control.Monad.forever has - been generalised from - Monad m => m a -> m () to - Monad m => m a -> m b. - - - - - The new value GHC.Exts.maxTupleSize - tells you the largest tuple size that can be used. This is - mostly of use in Template Haskell programs. - - - - - GHC.Exts now exports - Down(..), - groupWith, - sortWith and - the which are used in the desugaring of - generalised comprehensions. - - - - - GHC.Exts no longer exports the - Integer internals. If you want them then - you need to get them directly from the - new integer package. - - - - - The new function GHC.Conc.threadStatus - allows you to ask whether a thread is running, blocked on - an MVar, etc. - - - - - The Data.Generics hierarchy has been - moved to a new package syb. - - - - - The GHC.Prim and - GHC.PrimopWrappers modules have been - moved into a new ghc-prim package. - - - - - - - bytestring - - - - Version number 0.9.0.1.2 (was 0.9.0.1.1) - - - - - - - Cabal - - - - Version number 1.6.0.1 (was 1.2.4.0) - - - - - Many API changes. See the Cabal docs for more information. - - - - - - - containers - - - - Version number 0.2.0.0 (was 0.1.0.2) - - - - - Various result type now use Maybe rather - than allowing any Monad. - - - - - - - directory - - - - Version number 1.0.0.2 (was 1.0.0.1) - - - - - No longer defines the UNICODE CPP symbol for packages that - use it. - - - - - - - editline - - - - This is a new bootlib, version 0.2.1.0. - - - - - - - filepath - - - - Version number 1.1.0.1 (was 1.1.0.0) - - - - - - - ghc-prim - - - - This is a new bootlib, version 0.1.0.0. - - - - - - - haskell98 - - - - Version number 1.0.1.0 (unchanged) - - - - - - - hpc - - - - Version number 0.5.0.2 (was 0.5.0.1) - - - - - - - integer - - - - This is a new bootlib, version 0.1.0.0. - - - - - - - old-locale - - - - Version number 1.0.0.1 (was 1.0.0.0) - - - - - - - old-time - - - - Version number 1.0.0.1 (was 1.0.0.0) - - - - - - - packedstring - - - - Version number 0.1.0.1 (was 0.1.0.0) - - - - - - - pretty - - - - Version number 1.0.1.0 (was 1.0.0.0) - - - - - There is a new combinator - zeroWidthText :: String -> Doc - for printing things like ANSI escape sequences. - - - - - - - process - - - - Version number 1.0.1.0 (was 1.0.0.1) - - - - - The System.Process API has been overhauled. - The new API is a superset of the old API, however. - - - - - - - random - - - - Version number 1.0.0.1 (was 1.0.0.0) - - - - - - - readline - - - - This is no longer a bootlib; editline replaces it. - - - - - - - syb - - - - This is a new bootlib, version 0.1.0.0. - - - - - - - template-haskell - - - - Version number 2.3.0.0 (was 2.2.0.0) - - - - - The datatypes now have support for Word primitives. - - - - - currentModule :: Q String has been - replaced with - location :: Q Loc, where - Loc is a new datatype. - - - - - - - unix - - - - Version number 2.3.1.0 (was 2.3.0.1) - - - - - The System.Posix.Terminal.BaudRate type - now includes B57600 and - B115200 constructors. - - - - - - - Win32 - - - - Version number 2.2.0.0 (was 2.1.1.1) - - - - - No longer defines the UNICODE CPP symbol for packages that - use it. - - - - - - - diff -Nru ghc-7.0.3/docs/users_guide/6.12.1-notes.xml ghc-7.2.1/docs/users_guide/6.12.1-notes.xml --- ghc-7.0.3/docs/users_guide/6.12.1-notes.xml 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/docs/users_guide/6.12.1-notes.xml 1970-01-01 00:00:00.000000000 +0000 @@ -1,1304 +0,0 @@ - - - Release notes for version 6.12.1 - - - The significant changes to the various parts of the compiler are - listed in the following sections. There have also been numerous bug - fixes and performance improvements over the 6.10 branch. - - - - Language changes - - - - The new TupleSections language extension - enables tuple sections, such as (, True). - See for more information. - - - - - - The new MonoLocalBinds language extension - disables type variable generalisation for bindings in - let and where clauses. - - - - - - The new DeriveFunctor, - DeriveFoldable and - DeriveTraversable language extensions - enable deriving for the respective type classes. - See for more information. - - - - - - The new NoNPlusKPatterns language extension - disables n+k patterns. - See for more information. - - - - - - Some improvements have been made to record puns: - - - - - C { A.a } now works, expanding to - C { A.a = a }. - - - - - - -fwarn-unused-matches no longer - warns about bindings introduced by - f (C {..}) = x. - - - - - - The RecordWildCards language - extension implies - DisambiguateRecordFields. - - - - - - - - Declarations such as - - -data T a where - MkT :: forall a. Eq a => { x,y :: !a } -> T a - - - are now only accepted if the extension - TypeOperators is on. - - - - - - It is now possible to define GADT records with class - constraints. The syntax is: - - -data T a where - MkT :: forall a. Eq a => { x,y :: !a } -> T a - - - - - - You can now list multiple GADT constructors with the same type, - e.g.: - - -data T where - A, B :: T - C :: Int -> T - - - - - - It is now possible to use GADT syntax for data families: - - -data instance T [a] where - T1 :: a -> T [a] - - - and make data instances be GADTs: - - -data instance T [a] where - T1 :: Int -> T [Int] - T2 :: a -> b -> T [(a,b)] - - - - - - Record updates can now be used with datatypes containing - existential type variables, provided the fields being altered - do not mention the existential types. - - - - - - The ImpredicativeTypes extension now imples - the RankNTypes extension. - - - - - - The ImpredicativeTypes extension is no - longer enabled by -fglasgow-exts. - - - - - - You can now give multi-line DEPRECATED and - WARNING pragmas: - - -{-# DEPRECATED defaultUserHooks - ["Use simpleUserHooks or autoconfUserHooks, unless you need Cabal-1.2" - , "compatibility in which case you must stick with defaultUserHooks"] - #-} - - - - - - The -#include flag and - INCLUDE pragma are now deprecated and - ignored. Since version 6.10.1, GHC has generated its own C - prototypes for foreign calls, rather than relying on - prototypes from C header files. - - - - - - The threadsafe foreign import safety level - is now deprecated; use safe instead. - - - - - - There is a new FFI calling convention called - prim, which allows calling C-- functions - (see ). - Most users are not expected to need this. - - - - - - - Warnings - - - - A warning is now emitted if an unlifted type is bound in a - lazy pattern (in let or - where clause, or in an irrefutable pattern) - unless it is inside a bang pattern. - This warning is controlled by the - -fwarn-lazy-unlifted-bindings flag. - In a future version of GHC this will be an error. - - - - - - There are two new warnings if a monadic result of type other than - m () is used in a do - block, but its result is not bound. - The flags -fwarn-unused-do-bind - and -fwarn-wrong-do-bind control - these warnings (see ). - - - - - - The new flag -fwarn-dodgy-exports controls - whether an error is given for exporting a type synonym as - T(..). - - - - - - Name shadowing warnings are no longer given for variable names - beginning with an underscore. - - - - - - When -Werror is given, we now pass - -Werror to cpp. - - - - - - - Runtime system - - The following options are all described in - . - - - - - The flag +RTS -N now automatically - determines how many threads to use, based on the number - of CPUs in your machine. - - - - - - The parallel GC now uses the same threads as the mutator, - with the consequence that you can no longer select a - different number of threads to use for GC. - The RTS - option has been removed, except that is - still accepted for backwards compatibility. - - - - The new flag - +RTS -qggen sets - the minimum generation for which parallel garbage collection - is used. Defaults to 1. The flag -qg on - its own disables parallel GC. - - - - - - The new flag +RTS -qbgen - controls load balancing in the parallel GC. - - - - - - The new flag +RTS -qa - uses the OS to set thread affinity (experimental). - - - - - - If you link with the -eventlog flag, then - the new flag +RTS -l generates - prog.eventlog - files, which tools such as ThreadScope can use to show the - behaviour of your program (see ). The - +RTS -D>x output - is also sent to the eventlog file if this option is enabled. - The +RTS -v flag sends eventlog data to - stderr instead. - - - - - - There is a new statistic in the +RTS -s output: - - -SPARKS: 1430 (2 converted, 1427 pruned) - - - This tells you how many sparks (requests for parallel - execution, caused by calls to par) were - created, how many were actually evaluated in parallel - (converted), and how many were found to be already evaluated - and were thus discarded (pruned). Any unaccounted for sparks - are simply discarded at the end of evaluation. - - - - - - - Build system - - - - We now require GHC >= 6.8 to build. - - - - - - We now require that gcc is >= 3.0. - - - - - - In order to generate the parsers, happy >= 1.16 is now - required. The parsers are pre-generated in the source tarball, - so most users will not need Happy. - - - - - - It is now possible to build GHC with a simple, BSD-licensed - Haskell implementation of Integer, instead of the - implementation on top of GMP. To do so, set - INTEGER_LIBRARY to - integer-simple in - mk/build.mk. - - - - - - The build system has been rewritten for the 6.12 series. - See the building guide - for more information. - - - - - - The build system now uses variables like - bindir compatibly with the GNU standard. - - - - - - - Compiler - - - - The "Interface file version" field of the - ghc --info output has been removed, as it - is no longer used by GHC. - - - - - - There is a new "LibDir" field in the - ghc --info output. - - - - - - A field f in the - ghc --info can now be printed with - ghc --print-f, with letters lower-cased - and spaces replaced by dashes. - - - - - - GHC now works (as a 32bit application) on OS X Snow Leopard. - - - - - - The native code generator now works on Sparc Solaris. - - - - - - Haddock interface files are now portable between different - architectures. - - - - - - The new linker flag -eventlog enables the - +RTS -l event logging features. The - -debug flag also enables them. - - - - - - There is a new flag -feager-blackholing - which typically gives better performing code when running - with multiple threads. - See for more - information. - - - - - - There is a new flag -fbuilding-cabal-package - which signals to GHC that it is being run by a build system, - rather than invoked directly. This currently means that GHC - gives different error messages in certain situations. - - - - - - The following flags were static, but are now dynamic: - -fext-core, - -fauto-sccs-on-all-toplevs, - -auto-all, - -no-auto-all, - -fauto-sccs-on-exported-toplevs, - -auto, - -no-auto, - -fauto-sccs-on-individual-cafs, - -caf-all and - -no-caf-all. - - - - - - - GHCi - - - - If the argument to :set prompt starts with - a double quote then it is read with Haskell String syntax, - e.g.: - - -Prelude> :set prompt "Loaded: %s\n> " -Loaded: Prelude -> - - - - - - The arguments to :set set - and :set show can now be tab completed. - - - - - - We inherit some benefits from an upgraded version of haskeline: - - - - - A multitude of new emacs and vi commands. - - - - - - New preference 'historyDuplicates' to prevent storage - of duplicate lines. - - - - - - Support PageUp and PageDown keys. - - - - - - - - - Template Haskell - - - - You can now omit the splice notation for top-level declaration - splices, e.g.: - - -data T = T1 | T2 -deriveMyStuff ''T - - - - - - Splices are now nestable, e.g. you can say - f x = $(g $(h 'x)). - - - - - - It is now possible to splice in types. - - - - - - - Package Handling - - - - Shared libraries are now supported on x86 and x86_64 Linux. - To use shared libraries, use the -dynamic - flag. - See for more information. - - - - - - The new -fno-shared-implib flag can be used - to stop GHC generating the .lib import - library when making a dynamic library. This reduces the disk - space used when you do not need it. - - - - - - Packages can now be identified by a "package ID", which is - based on a hash of the ABIs. The new flag - -package-id allows packages to be - selected by this identifier (see ). Package IDs enable GHC to detect potential - incompatibilities between packages and broken dependencies - much more accurately than before. - - - - - - The new flag --abi-hash, used thus: - - -ghc --abi-hash M1 M2 ... - - - prints the combined hash of all the modules listed. It is - used to make package IDs. - - - - - - You can now give ghc-pkg a - -v0 flag to make it be silent, - -v1 for normal verbosity (the default), - or -v2 or -v for - verbose output. - - - - - - Rather than being a single package.conf file, - package databases now consist of a directory containing one - file per package, and a binary cache of the information. - GHC should be much faster to start up when the package - database grows large. - - - - - - There is a new command ghc-pkg init to - create a package database. - - - - - - There is a new command ghc-pkg dot to - generate a GraphViz graph of the dependencies between - installed packages. - - - - - - There is a new command ghc-pkg recache to - update the package database cache should it become out of - date, or for registering packages manually. - - - - - - - Libraries - - - GHC no longer comes with any extralibs; instead, the - Haskell Platform - will provide a consistent set of additional libraries. - - - - array - - - - Version number 0.3.0.0 (was 0.2.0.0) - - - - - - The Data.Array.Diff module has been moved - to its own package. - - - - - - - base - - - - Version number 4.2.0.0 (was 4.1.0.0) - - - - - - We also ship a base version 3.0.3.2 (was 3.0.3.1), so legacy - code should continue to work. This package is now deprecated, - and will be removed in a future version of GHC. - - - - - - Handle IO now supports automatic character set encoding - and newline translation. For more information, see the - "Unicode encoding/decoding" and "Newline conversion" sections - in the System.IO haddock docs. - - - - - - Lazy I/O now throws an exception if an error is - encountered, in a divergence from the Haskell 98 spec which - requires that errors are discarded (see Section 21.2.2 of - the Haskell 98 report). The exception thrown is the usual - IO exception that would be thrown if the failing IO - operation was performed in the IO monad, and can be caught - by System.IO.Error.catch - or Control.Exception.catch. - - - - - - It is now possible to create your own handles. - For more information, see the - GHC.IO.Handle haddock docs. - - - - - - System.IO now exports two new functions, - openTempFileWithDefaultPermissions and - openBinaryTempFileWithDefaultPermissions. - - - - - - Data.Fixed now provides - Data and Typeable - instances for Fixed, and exports - a number of new types: - E0, Uni, - E1, Deci, - E2, Centi, - E3, Milli, - E9 and Nano. - - - - - - In Control.Exception, - BlockedOnDeadMVar - has been renamed to - BlockedIndefinitelyOnMVar - and BlockedIndefinitely - has been renamed to - BlockedIndefinitelyOnSTM. - - - - - - The Control.OldException module has been - deprecated. - - - - - - System.Posix.Internals.setNonBlockingFD - now takes an additional Bool argument, so - you can turn blocking back on again. - - - - - - A new function eof has been added to - Text.ParserCombinators.ReadP. - - - - - - The Foreign.C.Types.CLDouble type has - been removed. It was never correct, but just a duplicate of - Foreign.C.Types.CDouble. - - - - - - In Data.Data, the - StringRep and - StringConstr constructors have been - removed. The CharRep and - CharConstr constructors should be used - instead. - - - - - - In Data.Data, - mkIntConstr has been deprecated in favour - of the new mkIntegralConstr. - - - - - - In Data.Data, - mkFloatConstr has been deprecated in - favour of the new mkRealConstr. - - - - - - In Data.Data, - mkNorepType has been deprecated in - favour of the new mkNoRepType. - - - - - - - bytestring - - - - Version number 0.9.1.5 (was 0.9.1.4) - - - - - - - Cabal - - - - Version number 1.8.0.0 (was 1.6.0.3) - - - - - - Many API changes. See the Cabal docs for more information. - - - - - - - containers - - - - Version number 0.3.0.0 (was 0.2.0.1) - - - - - - mapAccumRWithKey has been added to - Data.IntMap. - - - - - - A Traversable instance has been added to - Data.IntMap.IntMap. - - - - - - The types of Data.IntMap.intersectionWith - and Data.IntMap.intersectionWithKey have - been changed from - - -intersectionWith :: (a -> b -> a) -> IntMap a -> IntMap b -> IntMap a -intersectionWithKey :: (Key -> a -> b -> a) -> IntMap a -> IntMap b -> IntMap a - - - to - - -intersectionWith :: (a -> b -> c) -> IntMap a -> IntMap b -> IntMap c -intersectionWithKey :: (Key -> a -> b -> c) -> IntMap a -> IntMap b -> IntMap c - - - - - - The types of Data.IntMap.findMin - and Data.IntMap.findMax have - been changed from - - -findMin :: IntMap a -> a -findMax :: IntMap a -> a - - - to - - -findMin :: IntMap a -> (Int,a) -findMax :: IntMap a -> (Int,a) - - - - - - Data.Map now exports - mapAccumRWithKey, - foldrWithKey, - foldlWithKey and - toDescList. - - - - - - Data.Sequence now exports - replicate, - replicateA, - replicateM, - iterateN, - unfoldr, - unfoldl, - scanl, - scanl1, - scanr, - scanr1, - tails, - inits, - takeWhileL, - takeWhileR, - dropWhileL, - dropWhileR, - spanl, - spanr, - breakl, - breakr, - partition, - filter, - sort, - sortBy, - unstableSort, - unstableSortBy, - elemIndexL, - elemIndicesL, - elemIndexR, - elemIndicesR, - findIndexL, - findIndicesL, - findIndexR, - findIndicesR, - foldlWithIndex, - foldrWithIndex, - mapWithIndex, - zip, - zipWith, - zip3, - zipWith3, - zip4 and - zipWith4. - - - - - - - directory - - - - Version number 1.0.1.0 (was 1.0.0.3) - - - - - - A new function copyPermissions has been - added to System.Directory. - - - - - - - - dph - (dph-base, dph-par, dph-prim-interface, dph-prim-par, - dph-prim-seq, dph-seq) - - - - - All the dph packages are version 0.4.0. - - - - - - - extensible-exceptions - - - - Version number 0.1.1.1 (was 0.1.1.0) - - - - - - - filepath - - - - Version number 1.1.0.3 (was 1.1.0.2) - - - - - - The list of characters that are invalid in filenames on - Windows now includes \ (backslash). - - - - - - - ghc-binary - - - - This is an internal package, and should not be used. - - - - - - - ghc-prim - - - - Version number 0.2.0.0 (was 0.1.0.0) - - - - - - - haskell98 - - - - Version number 1.0.1.1 (was 1.0.1.0) - - - - - - - hpc - - - - Version number 0.5.0.4 (was 0.5.0.3) - - - - - - - integer-gmp - - - - Version number 0.2.0.0 (was called integer, version 0.1.0.1) - - - - - - - integer-simple - - - - This is a new boot package, version 0.1.0.0. - - - - - - - old-locale - - - - Version number 1.0.0.2 (was 1.0.0.1) - - - - - - Date and time in ISO8601 format are now separated by - T rather than a space. - - - - - - - old-time - - - - Version number 1.0.0.3 (was 1.0.0.2) - - - - - - - packedstring - - - - This is no longer a boot package. - - - - - - - pretty - - - - Version number 1.0.1.1 (was 1.0.1.0) - - - - - - - process - - - - Version number 1.0.1.2 (was 1.0.1.1) - - - - - - - random - - - - Version number 1.0.0.2 (was 1.0.0.1) - - - - - - - syb - - - - Version number 0.1.0.2 (was 0.1.0.1) - - - - - - - template-haskell - - - - Version number 2.4.0.0 (was 2.3.0.1) - - - - - - Support for inline and - specialise pragmas has been added. - - - - - - Support for bang patterns has been added - - - - - - Support for kind annotations has been added - - - - - - Support for equality constraints has been added - - - - - - Support for type family declarations has been added - - - - - - - time - - - - This is a new boot package, version 1.1.4. - - - - - - - unix - - - - Version number 2.4.0.0 (was 2.3.2.0) - - - - - - System.Posix.IO now exports - fdReadBuf and - fdWriteBuf. - - - - - - System.Posix.Process.executeFile now - returns IO a instead of - IO (). - - - - - - - Win32 - - - - Version number 2.2.0.1 (was 2.2.0.0) - - - - - - System.Win32.File now exports - WIN32_FIND_DATA, - FindData, - getFindDataFileName, - findFirstFile, - findNextFile and - findClose. - - - - - - System.Win32.Info now exports - getCurrentDirectory, - getTemporaryDirectory, - getFullPathName and - searchPath. - - - - - - System.Win32.Types now exports - HRESULT. - - - - - - There is a new module System.Win32.Shell. - - - - - - - diff -Nru ghc-7.0.3/docs/users_guide/6.6-notes.xml ghc-7.2.1/docs/users_guide/6.6-notes.xml --- ghc-7.0.3/docs/users_guide/6.6-notes.xml 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/docs/users_guide/6.6-notes.xml 1970-01-01 00:00:00.000000000 +0000 @@ -1,1718 +0,0 @@ - - - Release notes for version 6.6 - - - User-visible compiler changes - - - - GHC now supports SMP: - when you compile with , you now get - an RTS flag that allows you to specify the - number of OS threads that GHC should use. Defaults to 1. - See and . - - - - - GHC now handles impredicative polymorphism; see . - - - - - There are significant changes to the way scoped type variables work, - and some programs that used to compile may no longer do so. - The new story is documented in . - ( Simon's e-mail - gives some background, but the user manual should be complete (tell - us if not), and - certainly takes precedence if there is any conflict.) - - - - - GHC now supports bang patterns to require a function is strict - in a given argument, e.g. - - f (!x, y) = [x,y] - is equivalent to - - f (x, y) | x `seq` False = undefined - | otherwise = [x,y] - See for more details. - - - - - The restriction that you cannot use two packages together if - they contain a module with the same name has been removed. - In implementation terms, the package name is now included in - every exported symbol name in the object file, so that - modules with the same name in different packages do not - clash. See . - - - - - GHC now treats source files as UTF-8 (ASCII is a strict - subset of UTF-8, so ASCII source files will continue to - work as before). However, invalid UTF-8 sequences are - ignored in comments, so ASCII code with comments in, for - example, Latin-1 will also work. - - - - A way to have Latin-1 source files pre-processed by GHC is - described in . - - - - - GADTs can now use record syntax. Also, if the datatype could - have been declared with Haskell 98 syntax then deriving - clauses are permitted. For more info see . - - - - - There is a new pragma LANGUAGE which allows - extensions to be specified portably, i.e. without having to - resort to the OPTIONS_GHC pragma and giving - GHC-specific options. The arguments to the pragma are the same - extensions that Cabal knows about. More info in - . - - - - - When you use ghc --make, GHC will now take - the executable filename from the name of the file containing - the Main module rather than using - a.out. The .exe - extension is appended on Windows, and it can of course be - overridden with . - - - - - GHC's garbage collector now deals more intelligently with - mutable data, so you mostly no longer need to worry about GC - performance when a lot of memory is taken up by - STArrays, IOArrays, - STRefs or IORefs. - For more details see - trac bug #650. - - - - - GHC now allows more generalisation when typing mutually - recursive bindings, resulting in more programs being accepted. - See for more details. - - - - - The rules for instance declarations have been further relaxed. - You are now permitted to have instances whose heads contain - only type variables, e.g. - - instance C a - and instances whose constraints are not only type variables, - e.g. - - instance C2 Int a => C3 [a] b - For more details, see . - - - - - The following flags (and, where appropriate, their inverses) - used to be static (can only be given on - the command line) but are now dynamic (can also be given in - an OPTIONS_GHC pragma or with - :set in GHCi): - , - , - , - , - , - , - , - , - , - , - , - , - , - , - , - , - , - , - , - , - , - , - , - , - , - , - , - , - , - , - , - , - , - , - , - , - , - , - , - , - , - . - See for more on - the meaning of static and dynamic flags, and - for more on the flags - themselves. - - - - - There is a new flag for overriding the - default behaviour for source files; see - details. - - - - - The - - option is now called - . - (the old name is still accepted for backwards compatibility, - but will be removed in the future). - - - - - The - flag has been removed. - - - - - The flag is - implied by the - flag. - - - - - The directory that the foo_stub.c and - foo_stub.h files are put in can now be - controlled with the flag. - See for more details. - - - - - When the is given, - the equality test performed when pattern matching against an - overloaded numeric literal now uses the - (==) in scope, rather than the one from - Prelude. Likewise, the subtraction and - inequality test performed when pattern matching against - n+k patterns uses the - (-) and (>=) in scope. - - - - - Another change to : - with the exception of the arrow syntax, the types of - functions used by sugar (such as do notation, numeric - literal patterns) need not match the types of the - Prelude functions normally used. - - - - - The InstalledPackageInfo syntax has - changed. Now - instead of extra-libs we have - extra-libraries, - instead of extra-hugs-opts we have - hugs-options, - instead of extra-cc-opts we have - cc-options, - instead of extra-ld-opts we have - ld-options, - and instead of extra-frameworks we have - frameworks. - See for details. - - - - - If you newtype the IO monad, e.g. - - newtype MyIO a = MyIO (IO a) - then GHC will now allow you to have FFI calls return - MyIO t - rather than just - IO t. - See - - - GHC's mechansim for deriving user-defined classes - for newtypes has been further generalised, to multi-parameter type - classes and higher-kinded types. See . - - - - By default, pattern bindings in GHC are now monomorphic. - This means that some valid Haskell 98 programs will get - rejected, but we believe they will be few in number. - To revert to the old behaviour use the - flag. - More details are in . - - - - - GHCi already does more defaulting than Haskell 98 so that, for - example, reverse [] shows a result rather - than giving an ambiguous type variable error. There is now a - flag to use these - defaulting rules with GHC too. - More details are in . - - - - - You can now give both class and instance declarations in - .hs-boot files. More details in - . - - - - - Linear implicit parameters have been scheduled for removal for some - time. In 6.6 we've removed them from the user manual, and they may - well disappear from the compiler itself in 6.6.1. - - - - - If the program is idle for a certain amount of time then GHC - will now take the opportunity to do a major garbage collection. - The amount of idle time that is required before that happens - is controlled by the new -I RTS flag. - There is more detail in . - - - - - It is now possible to control the frequency that the RTS clock - ticks at with the new -V RTS flag. This is - normally handled automatically by other flags, but this flag - is needed if you want to increase the resolution of the time - profiler. - For more details see . - - - - - The old syntax for FFI declarations (deprecated since 5.04) - is no longer accepted. - - - - - The flag, which when used to compile - libraries means executables using the library will be smaller, - can now be used with and hence - can be used by cabal. - See for more information. - - - - - Template Haskell used to have limited support for type signatures in - patterns, but since that design is in flux for Haskell (let alone - Template Haskell), we've removed type signatures in patterns from - Template Haskell. - - - - - GHC now supports postfix operators, as a simple generalisation of - left sections (). - - - - - Parallel arrays, as enabled by -fparr, no - longer work. They'll be coming back shortly, in full glory. - - - - - - - GHCi changes - - - - - GHCi now allows tab completion of in-scope names and modules - on platforms that use readline (i.e. not Windows). - - - - - GHCi now has a :main command that allows - you to call the main function with - command-line arguments. - See for more information. - - - - - GHCi now has :ctags and - :etags commands to generate tags files for - vi-style and emacs-style editors respectively. - See for more information. - - - - - GHCi now has an :edit command which pops - up an editor on the most recently loaded file, or a - specified file. See for - more information. - - - - - GHCi now invokes print by default on the - result of IO actions and bindings at the prompt. This is - occasionally not what you want, so it can be disabled (at - least for bindings) with - :set -fno-print-bind-result. See . - - - - - - Libraries - - Libraries are now divided into core libraries (those that are - necessary to build GHC) and extra libraries. Decoupling the extra - libraries means that they can release independently of GHC - releases, and makes development builds of GHC quicker as they no - longer need to build unnecessary libraries. - - - - The hslibs libraries have finally been removed. - - - - - Core Libraries - - base - - - - Version number 2.1 (was 1.0). - - - - - We now have Read and - Show instances for up to 15-tuples (used - to be up to 5-tuples). - - - - - New module Control.Applicative that - describes a structure intermediate between a functor and - a monad: it provides pure expressions and sequencing, but - no binding. - - - - - Control.Exception now exports - bracketOnError, which behaves like - bracket but only runs the final - action if the main action raised an error. - - - - - There is a new module - Control.Monad.Instances which - provides Monad and - Functor instances for - ((->) r) (were in - mtl's - Control.Monad.Reader), - a Functor instance for - (Either a) (was in mtl's - Control.Monad.Error) and a - Functor instance for - ((,) a) (new). - - - - - The MonadFix instance for - ((->) r) is now in - Control.Monad.Fix (was in - mtl's - Control.Monad.Reader). - - - - - Control.Monad.ST now exports - unsafeSTToIO. - - - - - The HasBounds class has been removed from - Data.Array.Base, and its - bounds method is now in the - IArray class. The - MArray class - has also gained a method getBounds. - - - - - Data.Array.Base now provides an - MArray (STArray s) e (Lazy.ST s) - instance. - - - - - Data.Array.Storable now exports a - function unsafeForeignPtrToStorableArray. - - - - - The new Data.ByteString hierarchy - provides time and space-efficient byte vectors. - The old Data.PackedString module is now - deprecated as a result, although there is not yet a - replacement if you need full unicode support. - - - - - GHC.Exts now provides a function - inline which, provided the RHS is visible - to the compiler, forcibly inlines its argument. - Otherwise, it acts like id. - For more details, see . - - - - - GHC.Exts now provides a function - lazy, where lazy f - behaves like f, except GHC is forced - to believe that it is lazy in its first argument. - For more details, see . - - - - - Data.FiniteMap has been removed - (deprecated since 6.4). Use Data.Map - instead. - - - - - Data.Char now exports - isLetter, - isMark, - isNumber, - isPunctuation, - isSymbol, - isSeparator, - isAsciiUpper, - isAsciiLower and - toTitle. - It also exports a function - generalCategory that tells you the - category of a character in terms of a datatype - GeneralCategory. - - - - - Data.Dynamic now exports a function - dynTypeRep. - - - - - There is a new module Data.Eq which - just exports the Eq class. - Likewise, a new module Data.Ord - exports the Ord class, as well as the - handy comparing function. - - - - - There is a new module Data.Fixed - providing fixed-precision arithmetic. - - - - - There is a new module Data.Foldable - providing a class for foldable datatypes. It gives instances - for Maybe, [] and - Array i. - - - - - There is a new module Data.Traversable - providing a class for data structures that can be traversed - from left to right. It gives instances - for Maybe, [] and - Array i. - - - - - Data.FunctorM has been deprecated; - use Data.Foldable and - Data.Traversable instead. - - - - - The toConstr definitions for tuples in - Data.Generics.Instances now actually - evaluate their arguments to tuples before returning - anything. - - - - - Data.IntMap now exports - notMember, - alter, - mapMaybe, - mapMaybeWithKey, - mapEither and - mapEitherWithKey. - It also has Monoid, - Foldable and Read - instances. - - - - - Data.IntSet now exports - notMember. It also has - Monoid and Read - instances. - - - - - Data.Map now exports - notMember, - alter, - mapMaybe, - mapMaybeWithKey, - mapEither, - mapEitherWithKey, - minView and - maxView. - It also has Monoid, - Traversable, Foldable - and Read instances. - - - - - Data.Set now exports - notMember, - minView and - maxView. - It also has Monoid, - Foldable - and Read instances. - - - - The old, deprecated (since 6.4) interface consisting of - emptySet, - mkSet, - setToList, - unitSet, - elementOf, - isEmptySet, - cardinality, - unionManySets, - minusSet, - mapSet, - intersect, - addToSet and - delFromSet has been removed. - - - - - Data.Monoid no longer contains the - Monoid - instances for Map, - IntMap, Set and - IntSet. They have been moved to their own - modules, as above. The (a -> a) instance - has been replaced with a - Monoid b => Monoid (a -> b) instance. - The module also now exports - Dual, - Endo, - All, - Any, - Sum and - Product types, and - Monoid instances for them. - - - - - There is a new module Data.Sequence - for finite sequences. The Data.Queue - module is now deprecated in favour of this faster, more - featureful replacement. - - - - - Data.Tree now has - Data, Typeable, - Traversable and - Foldable - instances for the - Tree datatype. - - - - - Data.Typeable now uses - , so the - generic instances can be overriden for your own datatypes. - - - - - Debug.Trace now exports - traceShow, which is the same as - trace except its first argument can be - any showable thing rather than being required to be a - string. - - - - - Foreign.C.Types now also defines - CIntPtr, - CUIntPtr, - CIntMax and - CUIntMax. - - - - - Foreign.ForeignPtr now exports - FinalizerEnvPtr, - newForeignPtrEnv and - addForeignPtrFinalizerEnv. - Together, these allow the use of finalizers which are passed - an additional environment parameter. - - - - - Foreign.Marshal.Utils no longer exports - the withObject function, deprecated since - 5.04; use with instead. - - - - - Foreign.Ptr now also defines - IntPtr, - ptrToIntPtr, - intPtrToPtr, - WordPtr, - ptrToWordPtr and - wordPtrToPtr. - - - - - There are now Bounded instances for up to - 15-tuples (used to be up to 4-tuples). - - - - - The Text.Html and - Text.Html.BlockTable modules have now - been removed, with the new html and - xhtml packages providing replacements. - - - - - Text.Read now exports a function - parens which parses a value in an - arbitrary number of parentheses. - - - - - The ForeignPtr datatype has been altered - to make it more efficient. There are also new functions - mallocPlainForeignPtr and - mallocPlainForeignPtrBytes which - do not allow you to attach a finalizer to the - ForeignPtr. - - - - - The Text.Regex and - Text.Regex.Posix modules have been removed. - Instead, use the new regex-compat package - for a drop-in Text.Regex replacement, or - the new library in the new regex-posix - package. - - - - - - - Cabal - - - - Version number 1.1.6 (was 1.1.4). - - - - - Support for JHC, symmetric to the support for the other - implementations, has been added throughout. - - - - - Support for object splitting and building in-place - has been added throughout. - - - - - Added a debianTemplate directory with - templates for building Debian packages from Cabal packages. - - - - - There are now modules - Distribution.Simple.compiler - for each of GHC, NHC, - Hugs and JHC. - The Distribution.Simple.Build and - Distribution.Simple.Install modules have - shrunk correspondingly. - - - - - Distribution.GetOpt is no longer a - visible module. - - - - - Distribution.Simple exports a function - defaultMainArgs, which is identical to - defaultMain except that the arguments are - given as a list of strings rather than being retrieved with - getArgs. - - - - - Distribution.Simple.Configure - no longer exports - LocalBuildInfo, - but does now export - configDependency and - configCompilerAux. - - - - - Distribution.Simple.LocalBuildInfo now - exports mkHaddockDir, - distPref, - srcPref, - autogenModulesDir and - mkIncludeDir. - - - - - Distribution.PackageDescription now - exports haddockName. - - - - - Distribution.Simple.Utils now exports - copyDirectoryRecursiveVerbose, - dirOf, - distPref, - haddockPref and - srcPref. - It no longer exports mkGHCiLibName. - - - - - - - haskell98 - - - - No change (version 1.0). - - - - - - - parsec - - - - Version number 2.0 (was 1.0). - - - - - No other change. - - - - - - - readline - - - - No change (version 1.0). - - - - - - - regex-base - - - - Version 0.71. - - - - - New library that provides common functions for different - regex backends. - - - - - - - regex-compat - - - - Version 0.71. - - - - - New package providing a replacement - Text.Regex module. - - - - - - - regex-posix - - - - Version 0.71. - - - - - A new package providing POSIX regexes. - - - - - - - stm - - - - Version number 2.1 (was 1.0). - - - - - A new module Control.Monad.STM - contains the - MonadPlus instance for - STM and the function - check (both used to be in - Control.Concurrent.STM). - It also re-exports - STM, - atomically, - retry, - orElse and - catchSTM. - - - - - A new module - Control.Concurrent.STM.TArray defines - TArray, a transactional array, and makes - it an instance of MArray. - - - - - Control.Concurrent.STM.TChan now provides - a function newTChanIO, which allows - TChans to be created in the IO monad. - Similarly, Control.Concurrent.STM.TMVar - provides newTMVarIO and - newEmptyTMVarIO, and - Control.Concurrent.STM.TVar exports - newTVarIO. - - - - - Control.Concurrent.STM.TVar exports - registerDelay. - - - - - The Control.Concurrent.STM module has been - updated to re-export all the new modules. - - - - - - - template-haskell - - - - Version number 2.0 (was 1.0). - - - - - A Show instance is now derived for - Info, Fixity and - FixityDirection in - Language.Haskell.TH.Syntax. - - - - - In Language.Haskell.TH.Syntax, there is - a type PkgName and functions - mkPkgName and - pkgString - for dealing with package names. - - - - - The patGE function in - Language.Haskell.TH.Lib now takes the - final expression separately to the list of statements - rather than splitting it off itself. - - - - - - - unix - - - - No change (version 1.0). - - - - - - - Win32 - - - - Version number 2.1 (was 1.0). - - - - - Now maintained by Esa Ilari Vuokko. - - - - - There is a new module - System.Win32.Console - providing an interface to the Windows Console API. - - - - - There is a new module - System.Win32.DebugApi - providing an interface to the Windows DebugApi. - - - - - There is a new module - System.Win32.FileMapping - for working with memory-mapped files. - - - - - There is a new module - System.Win32.SimpleMAPI - for using the Windows mail API. - - - - - There is a new module - System.Win32.Time - for using the Windows time API. - - - - - iNVALID_HANDLE_VALUE has moved from - Graphics.Win32.Misc to - System.Win32.Types. - - - - - System.Win32.File has a new - function getFileInformationByHandle - and associated data types. - - - - - System.Win32.Info has a new - function getSystemInfo and associated - data types. - - - - - System.Win32.Process now has many more - exports. - - - - - System.Win32.Types has new types - LARGE_INTEGER, DDWORD - and SIZE_T. It also has new helper - functions ddwordToDwords and - dwordsToDdword to split and combine - ddwords into high and low components. - - - - - System.Win32 re-exports - System.Win32.FileMapping, - System.Win32.Time - and System.Win32.Console. - - - - - - - - Extra Libraries - - ALUT - - - - Version number 2.0 (was 1.0). - - - - - Sound.ALUT.BuiltInSounds has been removed. - Its Phase and Duration - exports are now exported by - Sound.ALUT.Loaders and its - helloWorld, - sine, - square, - sawtooth, - impulse and - whiteNoise - exports are now constructors of the - Sound.ALUT.Loaders.SoundDataSource - datatype. - - - - - - - arrows - - - - Version number 0.2 (was 0.1). - - - - - Control.Sequence has been removed in - favour of the new Control.Applicative - module in base. - - - - - - - cgi - - - - Version 2006.8.14. - - - - - cgi is a new package, developing on - what used to be Network.CGI in the - network package. - - - - - The Network.CGI.Compat module provides - a similar interface to the old Network.CGI - module, but it uses Text.XHtml rather than - Text.Html. - - - - - - - fgl - - - - Version number 5.3 (was 5.2). - - - - - Data.Graph.Inductive.Graph no longer - exports UContext. - - - - - Data.Graph.Inductive.Graph now exports - delLEdge. - - - - - - - GLUT - - - - Version number remains 2.0. - - - - - In Graphics.UI.GLUT.Initialization, - DisplayMode has a new constructor - WithAuxBuffers and - DisplayCapability has a new constructor - DisplayAux. These represent freeglut-only - features. - - - - - There are new examples in - BOGLGP/Chapter03/OnYourOwn1.hs, - RedBook/AAIndex.hs, - RedBook/AARGB.hs, - RedBook/AccAnti.hs, - RedBook/AccPersp.hs, - RedBook/Alpha3D.hs, - RedBook/DOF.hs, - RedBook/FogIndex.hs, - RedBook/Multisamp.hs, - RedBook/PointP.hs, - RedBook/PolyOff.hs, - RedBook/Stencil.hs, - RedBook/Stroke.hs and - RedBook/Torus.hs, - and the examples in - RedBook/Font.hs and - RedBook/Histogram.hs have been - improved. - - - - - - - haskell-src - - - - No change (version 1.0). - - - - - - - HGL - - - - No change (version 3.1). - - - - - - - html - - - - Version 1.0. - - - - - html is a new package, developing on - what used to be Text.Html and - Text.Html.BlockTable in the - base package. - - - - - Text.Html.BlockTable exports a new - function empty. - - - - - - - HUnit - - - - No change (version 1.1). - - - - - - - mtl - - - - No change (version 1.0). - - - - - - - network - - - - Version number 2.0 (was 1.0). - - - - - Network.CGI has been removed; use the - cgi package instead. - - - - - Network.BSD no longer exports - symlink or readlink; - use - System.Posix.Files.createSymbolicLink and - System.Posix.Files.readSymbolicLink - instead. - - - - - Network.BSD now exports - defaultProtocol. - - - - - Network.Socket.SocketStatus now has a - constructor ConvertedToHandle for sockets - that have been converted to handles. - - - - - Network.Socket.Family now has the - following additional constructors: - AF_NETROM, - AF_BRIDGE, - AF_ATMPVC, - AF_ROSE, - AF_NETBEUI, - AF_SECURITY, - AF_PACKET, - AF_ASH, - AF_ECONET, - AF_ATMSVC, - AF_IRDA, - AF_PPPOX, - AF_WANPIPE and - AF_BLUETOOTH. - - - - - In Network.URI, - parseabsoluteURI has been deprecated with - a new function parseAbsoluteURI taking - its place. - - - - - - - ObjectIO - - - - No change (version 1.0). - - - - - - - OpenAL - - - - Version number 1.3 (was 1.2). - - - - - No other change. - - - - - - - OpenGL - - - - Version number 2.1 (was 2.0). - - - - - No other change. - - - - - - - QuickCheck - - - - No change (version 1.0). - - - - - - - time - - - - Version 1.0. - - - - - time is a new package, for dealing with - dates, times and time intervals. - - - - - - - X11 - - - - Version number 1.2 (was 1.1). - - - - - In Graphics.X11.Xlib.Types, - XGCValues has been renamed - GCValues and - XSetWindowAttributes has been renamed - SetWindowAttributes. - - - - - In Graphics.X11.Xlib.Misc, - allocaXSetWindowAttributes has been - renamed allocaSetWindowAttributes. - - - - - The FontStruct type has moved from - Graphics.X11.Xlib.Types to - Graphics.X11.Xlib.Font. - - - - - The - Point, - Rectangle, - Arc, - Segment and - Color types in - Graphics.X11.Xlib.Types - are now proper datatypes rather than synonyms for tuples. - They all have a Storable instance. - - - - - The Byte and Short - types from Graphics.X11.Xlib.Types have - been removed. - The following type synonyms, which had already been marked - "Backwards compatibility", have also been removed: - ListPoint, - ListRectangle, - ListArc, - ListSegment and - ListColor. - - - - - Eq, - Ord, - Show, - Typeable and - Data are now derived for: - XEvent, - FdSet and - TimeZone in - Graphics.X11.Xlib.Event, - FontStruct in - Graphics.X11.Xlib.Font, - XErrorEvent, - XComposeStatus and - XTextProperty in - Graphics.X11.Xlib.Misc, - Region in - Graphics.X11.Xlib.Region, - Display, - Screen, - Visual, - GC, - GCValues, - SetWindowAttributes, - Point, - Rectangle, - Arc, - Segment and - Color in - Graphics.X11.Xlib.Types. - - - - - - - xhtml - - - - Version 2006.8.14. - - - - - xhtml is a new package, developing on - what used to be Text.Html and - Text.Html.BlockTable in the - base package. - - - - - - - - GHC As A Library - - Version number 6.6. - - - The internal modules of GHC are now available as a library, package - name ghc. - The interface has not been designed with use by other programs - in mind, so expect the API to vary radically in future - releases. - - - An introduction to using the library can be found - on the wiki. - - - - - Internal changes - - - - GHC development now has its own integrated - wiki and bug - tracker. - - - - - GHC has now moved to darcs. See - the - wiki for more details. The sources have moved around a - bit within the tree as a result, most notably the GHC sources - are no longer kept within a ghc/ - subdirectory. - - - - - The native code generator is now capable of compiling loops, - which gets us a big step closer to being able to compile - entirely without gcc on well-supported arches. - - - - - - diff -Nru ghc-7.0.3/docs/users_guide/7.0.1-notes.xml ghc-7.2.1/docs/users_guide/7.0.1-notes.xml --- ghc-7.0.3/docs/users_guide/7.0.1-notes.xml 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/docs/users_guide/7.0.1-notes.xml 1970-01-01 00:00:00.000000000 +0000 @@ -1,1269 +0,0 @@ - - - Release notes for version 7.0.1 - - - The significant changes to the various parts of the compiler are - listed in the following sections. There have also been numerous bug - fixes and performance improvements over the 6.12 branch. - - - - Highlights - - - - GHC now defaults to the Haskell 2010 language standard. - - - - Libraries are not quite so straightforward. By default, GHC - provides access to the base package, - which includes the Haskell 2010 libraries, albeit with a few - minor differences. For those who want to write strictly - standards-conforming code we also provide - the haskell2010 package which provides - the precise APIs specified by Haskell 2010, but because the - module names in this package overlap with those in - the base package it is not possible to - use both haskell2010 - and base at the same time (this also - applies to the array package). Hence to use - the Haskell 2010 libraries you should hide - the base and array - packages, for example with GHCi: - -$ ghci -package haskell2010 -hide-package base -hide-package array - - If you are using Cabal it isn't necessary to - hide base and array - explicitly, just don't include them in your build-depends. - - - - - - The -fglasgow-exts flag has been - deprecated. Individual extensions should be enabled instead. - - - - The GADTs and TypeFamilies - exntensions are no longer enabled by - -fglasgow-exts. - - - - - - On POSIX platforms, there is a new I/O manager based on - epoll/kqueue/poll, which allows multithreaded I/O code to - scale to a much larger number (100k+) of threads. - - - - - - GHC now includes an LLVM code generator. For certain code, - particularly arithmetic heavy code, using the LLVM code - generator can bring some nice performance improvements. - - - - - - The type checker has been overhauled, which means it is now - able to correctly handle interactions between the type system - extensions. - - - - - - The inliner has been overhauled, which should in general - give better performance while reducing unnecessary code-size - explosion. - - - - - - Large parts of the runtime system have been overhauled, in - particular the machinery related to blocking and wakeup of - threads and exception throwing (throwTo). - Several instances of pathological performance have been - fixed, especially where large numbers of threads are - involved. - - - - - - Due to changes in the runtime system, if you are - using Control.Parallel.Strategies from - the parallel package, please upgrade to - at least version 2 (preferably version 3). The - implementation of Strategies - in parallel-1.x will lose parallelism - with GHC 7.0.1. - - - - - - The full Haskell import syntax can now been - used to bring modules into scope in GHCi, e.g. - - -Prelude> import Data.List as L -Prelude Data.List> L.length "foo" -3 - - - - - - GHC now comes with a more recent mingw bundled on Windows, - which includes a fix for windres on Windows 7. - - - - - - There is a new -fno-ghci-sandbox flag, - which stops GHCi running computations in a separate thread. - In particular, this is useful for GLUT on OS X, which only - works if being run on the main thread. - - - - - - - Language changes - - - - GHC now understands the Haskell98 and - Haskell2010 languages. - - - - These get processed before the language extension pragmas, - and define the default sets of extensions that are enabled. - If neither is specified, then the default is - Haskell2010 plus the - MonoPatBinds extension. - - - - - - GHC now supports the DoAndIfThenElse - extension, which is part of the Haskell 2010 standard. - - - - - - Rebinadble syntax now has its own extension, - RebindableSyntax, and thus is no longer - enabled by NoImplicitPrelude. - - - - - - Datatype contexts, such as the Eq a in - - -data Eq a => Set a = NilSet | ConsSet a (Set a) - - - are now treated as an extension - DatatypeContexts (on by default) by GHC. - - - - - - GHC's support for unicode source has been improved, including - removing support for U+22EF for the .. - symbol. See for more details. - - - - - - Pragmas are now reread after preprocessing. In particular, - this means that if a pragma is used to turn CPP on, then other - pragmas can be put in CPP conditionals. - - - - - - The TypeOperators extension now allows - instance heads to use infix syntax. - - - - - - The PackageImports extension now understands - this to mean the current package. - - - - - - The INLINE and NOINLINE - pragmas can now take a CONLIKE modifier, - which indicates that the right hand side is cheap to compute, - and can thus be duplicated more freely. - See for more details. - - - - - - A ForceSpecConstr annotation on a type, e.g. - - -import SpecConstr -{-# ANN type SPEC ForceSpecConstr #-} - - - can be used to force GHC to fully specialise argument of that - type. - - - - - - A NoSpecConstr annotation on a type, e.g. - - -import SpecConstr -{-# ANN type T NoSpecConstr #-} - - - can be used to prevent SpecConstr from specialising on - arguments of that type. - - - - - - There is are two experimental new extensions - AlternativeLayoutRule and - AlternativeLayoutRuleTransitional, - which are for exploring alternative layout rules in Haskell'. - The details are subject to change, so we advise against using - them in real code for now. - - - - - - The NewQualifiedOperators extension has - been deprecated, as it was rejected by the Haskell' committee. - - - - - - - Warnings - - - - There is now a warning for missing type signatures for - polymorphic local bindings, controlled by the new - -fwarn-missing-local-sigs flag. - - - - - - There is now a warning for missing import lists, controlled - by the new -fwarn-missing-import-lists flag. - - - - - - GHC will now warn about SPECIALISE and - UNPACK pragmas that have no effect. - - - - - - The -fwarn-simple-patterns flag has been - removed. The warnings have been merged into the - -fwarn-incomplete-patterns flag. - - - - - - - DLLs - - - - Shared libraries are once again supported on Windows. - - - - - - Shared libraries are now supported on OS X, both on x86 and on - PowerPC. The new -dylib-install-name GHC - flag is used to set the location of the dynamic library. - See for more details. - - - - - - - Runtime system - - - - - For security reasons, by default, the only RTS flag that - programs accept is +RTS --info. If you want - the full range of RTS flags then you need to link with the new - -rtsopts flag. See - for more details. - - - - - - The RTS now exports a function setKeepCAFs - which is important when loading Haskell DLLs dynamically, as - a DLL may refer to CAFs that hae already been GCed. - - - - - - The garbage collector no longer allows you to specify a number - of steps; there are now always 2. The -T - RTS flag has thus been removed. - - - - - - A new RTS flag -H causes the RTS to use a - larger nursery, but without exceeding the amount of memory - that the application is already using. It makes some programs - go slower, but others go faster. - - - - - - GHC now returns memory to the OS, if memory usage peaks and - then drops again. This is mainly useful for long running - processes which normally use very little memory, but - occasionally need a lot of memory for a short period of time. - - - - - - On OS X, eventLog events are now available as DTrace probes. - - - - - - The PAPI support has been improved. The new RTS flag - -a#0x40000000 can be used to tell the RTS - to collect the native PAPI event 0x40000000. - - - - - - - Compiler - - - - GHC now defaults to --make mode, i.e. GHC - will chase dependencies for you automatically by default. - - - - - - GHC now includes an LLVM code generator. - - - This includes a number of new flags: - a flag to tell GHC to use LLVM, -fllvm; - a flag to dump the LLVM input ,-ddump-llvm; - flags to keep the LLVM intermediate files, - -keep-llvm-file and - -keep-llvm-files; - flags to set the location and options for the LLVM optimiser - and compiler, - -pgmlo, - -pgmlc, - -optlo and - -optlc. - The LLVM code generator requires LLVM version 2.7 or later on - your path. - - - - - - It is now possible to use -fno-code with - --make. - - - - - - The new flag -dsuppress-coercions controls - whether GHC prints coercions in core dumps. - - - - - - The new flag -dsuppress-module-prefixes - controls whether GHC prints module qualification prefixes - in core dumps. - - - - - - The inliner has been overhauled. The most significant - user-visible change is that only saturated functions are - inlined, e.g. - - -(.) f g x = f (g x) - - - would only be inlined if (.) is applied to 3 - arguments, while - - -(.) f g = \x -> f (g x) - - - will be inlined if only applied to 2 arguments. - - - - - - The -finline-if-enough-args flag is no - longer supported. - - - - - - Column numbers in warnings and error messages now start at 1, - as is more standard, rather than 0. - - - - - - GHCi now understands most linker scripts. In particular, this - means that GHCi is able to load the C pthread library. - - - - - - The ghc --info output has been updated: - - - It now includes the - location of the global package database, in the - Global Package DB field. - - - It now includes the build, host and target platforms, in the - Build platform, - Host platform and - Target platform fields. - - - It now includes a Have llvm code generator - field. - - - The Win32 DLLs field has been removed. - - - - - - The registerised via-C backend, and the - -fvia-C flag, have been deprecated. The poor - floating-point performance in the x86 native code generator - has now been fixed, so we don't believe there is still any - reason to use the via-C backend. - - - - - - There is now a new flag --supported-extensions, - which currently behaves the same as - --supported-languages. - - - - - - GHC progress output such as - - -[ 1 of 5] Compiling Foo ( Foo.hs, Foo.o ) - - - is now sent to stdout rather than stderr. - - - - - - The new flag -fexpose-all-unfoldings - makes GHC put unfoldings for everything - in the interface file. - - - - - - There are two new flags, -fno-specialise - and -fno-float-in, for disabling the - specialise and float-in passes. - - - - - - The new flag -fstrictness-before=n tells - GHC to run an additional strictness analysis pass - before simplifier phase n. - - - - - - There is a new flag - -funfolding-dict-discount - for tweaking the optimiser's behaviour. - - - - - - The -fspec-inline-join-points flag has been - removed. - - - - - - The -dynload wrapper flag has been - removed. - - - - - - The __HASKELL1__, - __HASKELL98__ and - __CONCURRENT_HASKELL__ symbols are no - longer defined by default when CPPing. - - - - - - - GHCi - - - - GHCi now understands layout in multi-line commands, so - this now works: - - -Prelude> :{ -Prelude| let x = 1 -Prelude| y = 2 in x + y -Prelude| :} -3 - - - - - - - Template Haskell and Quasi-Quoters - - - - It is now possible to quasi-quote patterns with - [p| ... |]. - - - - - - It is no longer necessary to use a $ before the - name of a quasi-quoter, e.g. one can now say - [expr| ... |] rather than - [$expr| ... |]. - - - - - - It is now possible to use a quasi-quoter for types, e.g. - f :: [$qq| ... |] - - - - - - It is now possible to quasi-quote existentials and GADTs. - - - - - - - GHC API - - - - There are now Data and - Typeable instances for the - HsSyn typed. - - - - - - - Libraries - - - array - - - - Version number 0.3.0.2 (was 0.3.0.1) - - - - - - - base - - - - Version number 4.3.0.0 (was 4.2.0.2) - - - - - - There is a new asynchronous exception control API - in Control.Exception, using the - new functions - mask :: ((forall a. IO a -> IO a) -> IO b) -> IO b - and mask_ :: IO a -> IO a - rather than the old - block and unblock. - There are also functions - uninterruptibleMask :: ((forall a. IO a -> IO a) -> IO b) -> IO b - and - getMaskingState :: IO MaskingState, - and a type - MaskingState, as well as - forkIOUnmasked :: IO () -> IO ThreadId - in Control.Concurrent. - - - - - - Control.Monad exports a new function - void :: Functor f => f a -> f (). - - - - - - Data.Tuple exports a new function - swap :: (a,b) -> (b,a). - - - - - - System.IO exports a new function - hGetBufSome :: Handle -> Ptr a -> Int -> IO Int - which is like hGetBuf but can - return short reads. - - - - - - There is a new function - mfilter :: MonadPlus m => (a -> Bool) -> m a -> m a - in - Control.Monad. - - - - - - The Foreign.Marshal module now - exports - unsafeLocalState :: IO a -> a - as specified by Haskell 2010. - - - - - - The - module now exports four new functions specified by - Haskell 2010: - castCUCharToChar :: CUChar -> Char, - castCharToCUChar :: Char -> CUChar, - castCSCharToChar :: CSChar -> Char and - castCharToCSChar :: Char -> CSChar. - - - - - - The Foreign.Marshal.Alloc - module now exports - allocaBytesAligned :: Int -> Int -> (Ptr a -> IO b) -> IO b - for allocating memory with a particular alignment. - - - - - - There is a new function - numSparks :: IO Int - in GHC.Conc. - - - - - - Data.Either.partitionEithers - in now lazier. - - - - - - There is now a Typeable instance for - Data.Unique.Unique. - - - - - - Control.Concurrent.SampleVar.SampleVar - is now an abstract type. - - - - - - There are now - Applicative, - Alternative and - MonadPlus - instances for STM. - - - - - - There are now Applicative, - Monad and - MonadFix - instances for Either. - - - - - - There are now - Ord, - Read and - Show instances for - Newline and - NewlineMode. - - - - - - There is now a Show instance for - TextEncoding. - - - - - - The unGetChan and - isEmptyChan functions in - Control.Concurrent.Chan are now - deprecated. - Control.Concurrent.STM.TChan - should be used instead if you need that - functionality. - - - - - - The Read Integer instance now - matches the standard definition. - - - - - - - base 3 compat - - - - We no longer ship a base 3 compat package - - - - - - - bin-package-db - - - - This is an internal package, and should not be used. - - - - - - - bytestring - - - - Version number 0.9.1.8 (was 0.9.1.7) - - - - - - - Cabal - - - - Version number 1.10.0.0 (was 1.8.0.6) - - - - - - Many API changes. See the Cabal docs for more information. - - - - - - - containers - - - - Version number 0.4.0.0 (was 0.3.0.0) - - - - - - Strictness is now more consistent, with containers - being strict in their elements even in singleton - cases. - - - - - - There is a new function - insertLookupWithKey' in - Data.Map. - - - - - - The foldWithKey function in - Data.Map has been deprecated in - favour of foldrWithKey. - - - - - - - directory - - - - Version number 1.1.0.0 (was 1.0.1.1) - - - - - - The System.Directory module - now exports the Permissions type - abstractly. There are also new functions - setOwnerReadable, - setOwnerWritable, - setOwnerExecutable and - setOwnerSearchable, and - a new value emptyPermissions. - - - - - - - - dph - (dph-base, dph-par, dph-prim-interface, dph-prim-par, - dph-prim-seq, dph-seq) - - - - - The dph packages are no longer shipped with GHC. - - - - - - - extensible-exceptions - - - - Version number 0.1.1.2 (was 0.1.1.1) - - - - - - - filepath - - - - Version number 1.2.0.0 (was 1.1.0.4) - - - - - - The current directory is now "." - rather than "". - - - - - - - ghc-binary - - - - This is an internal package, and should not be used. - - - - - - - ghc-prim - - - - This is an internal package, and should not be used. - - - - - - - haskell98 - - - - Version number 1.1.0.0 (was 1.0.1.1) - - - - - - In the Directory module, the - Permissions type and the - getPermissions and - setPermissions functions are now - different to their equivalents in - base:System.Directory. - - - - - - - haskell2010 - - - - This is a new boot package, version 1.0.0.0. - It is not exposed by default. - - - - - - - hpc - - - - Version number 0.5.0.6 (was 0.5.0.5) - - - - - - - integer-gmp - - - - Version number 0.2.0.2 (was 0.2.0.1) - - - - - - - old-locale - - - - No change (version 1.0.0.2) - - - - - - - old-time - - - - Version number 1.0.0.6 (was 1.0.0.5) - - - - - - - pretty - - - - Version number 1.0.1.2 (was 1.0.1.1) - - - - - - - process - - - - Version number 1.0.1.4 (was 1.0.1.3) - - - - - - - random - - - - Version number 1.0.0.3 (was 1.0.0.2) - - - - - - - syb - - - - The syb package is no longer included with GHC. - - - - - - - template-haskell - - - - Version number 2.5.0.0 (was 2.4.0.1) - - - - - - There is a new type synonym DecsQ - in Language.Haskell.TH.Lib. - - - - - - There is a new StringPrimL - constructor in - Language.Haskell.TH.Syntax.Lit, - and a new helper function - stringPrimL for it in - Language.Haskell.TH.Lib. - - - - - - There is a new function quoteFile - in Language.Haskell.TH.Quote. - - - - - - The - Language.Haskell.TH.Quote.QuasiQuoter - type has two new fields: - quoteType and - quoteDec. - - - - - - There is a new ClassInstance - type in Language.Haskell.TH.Syntax. - The - Language.Haskell.TH.Syntax.Info.ClassI - constructor now includes a value of this type, which - allows instance information to be queried via the - new isClassInstance - and classInstances functions. - There is also a new method - qClassInstances in the - Quasi class. - - - - - - - time - - - - Version number 1.2.0.3 (was 1.1.4) - - - - - - The types provided by the time package now include - Data instances. - - - - - - - unix - - - - Version number 2.4.1.0 (was 2.4.0.2) - - - - - - There are three new helper function in - System.Posix.Error: - throwErrnoPathIfRetry, - throwErrnoPathIfNullRetry and - throwErrnoPathIfMinus1Retry. - - - - - - There are three new functions in - System.Posix.User: - setEffectiveUserID, - setEffectiveGroupID and - setGroups. - - - - - - - diff -Nru ghc-7.0.3/docs/users_guide/7.0.2-notes.xml ghc-7.2.1/docs/users_guide/7.0.2-notes.xml --- ghc-7.0.3/docs/users_guide/7.0.2-notes.xml 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/docs/users_guide/7.0.2-notes.xml 1970-01-01 00:00:00.000000000 +0000 @@ -1,415 +0,0 @@ - - - Release notes for version 7.0.2 - - - The significant changes to the various parts of the compiler - since 7.0.1 are listed in the following sections. - - - - Compiler - - - - The old [$foo| ... |] syntax works again, - but is deprecated. - - - - - - There have been significant improvments to the new type checker. - - - - - - - GHCi - - - - Loading .a libraries is now possible on - all platforms. A .o library will still be - used by preference if both exist. GHCi will no longer warn - about missing .o libraries. - - - - - - We now close .ghci files after reading - them, which on Windows machines allows them to be altered - while GHCi is running. - - - - - - It is now possible to :unset the ghci - variables (args, prog, - prompt, editor and - stop). - - - - - - - Runtime system - - - - DTrace is now supported on Solaris, in addition to OS X. - - - - - - - Build system - - - - - OS X builds on 10.6 now work on both 10.5 and 10.6. - - - - - - Windows installations now include the - libstdc++ DLL. - - - - - - - Haddock - - - - GHC now comes with haddock 2.9.0. - - - - - - GHC now includes hoogle databases for the libraries. - - - - - - - Libraries - - - array - - - - No change (version 0.3.0.2) - - - - - - - base - - - - Version number 4.3.1.0 (was 4.3.0.0) - - - - - - The Unicode support has been improved; in - particular, decoding errors are now detected, - and an exception raised, immediately, rather than - when a buffer gets flushed. - - - - - - Some bugs, including memory leaks and a deadlock, - in the new IO manager on non-Windows have - been fixed. - - - - - - - bin-package-db - - - - This is an internal package, and should not be used. - - - - - - - bytestring - - - - Version number 0.9.1.10 (was 0.9.1.8) - - - - - - - Cabal - - - - Version number 1.10.1.0 (was 1.10.0.0) - - - - - - The error messages given when a program cannot be - found have been improved. - - - - - - The commandParseArgs function, and - the CommandParse type, are now - exported from - Distribution.Simple.Command. - - - - - - - containers - - - - No change (version 0.4.0.0) - - - - - - - directory - - - - No change (version 1.1.0.0) - - - - - - - extensible-exceptions - - - - No change (version 0.1.1.2) - - - - - - - filepath - - - - No change (version 1.2.0.0) - - - - - - - ghc-binary - - - - This is an internal package, and should not be used. - - - - - - - ghc-prim - - - - This is an internal package, and should not be used. - - - - - - - haskell98 - - - - Version number 1.1.0.1 (was 1.1.0.0) - - - - - - - haskell2010 - - - - No change (version 1.0.0.0) - - - - - - - hpc - - - - No change (version 0.5.0.6) - - - - - - - integer-gmp - - - - Version number 0.2.0.3 (was 0.2.0.2) - - - - - - - old-locale - - - - No change (version 1.0.0.2) - - - - - - - old-time - - - - No change (version 1.0.0.6) - - - - - - - pretty - - - - No change (version 1.0.1.2) - - - - - - - process - - - - Version number 1.0.1.5 (was 1.0.1.4) - - - - - - - random - - - - No change (version 1.0.0.3) - - - - - - - template-haskell - - - - No change (version 2.5.0.0) - - - - - - - time - - - - No change (version 1.2.0.3) - - - - - - - unix - - - - Version number 2.4.2.0 (was 2.4.1.0) - - - - - - System.Posix.Signals now exports - reservedSignals, the set of - signals reserved for use by the implementation. - - - - - - - Win32 - - - - No change (version 2.2.0.1) - - - - - - - diff -Nru ghc-7.0.3/docs/users_guide/7.0.3-notes.xml ghc-7.2.1/docs/users_guide/7.0.3-notes.xml --- ghc-7.0.3/docs/users_guide/7.0.3-notes.xml 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/docs/users_guide/7.0.3-notes.xml 1970-01-01 00:00:00.000000000 +0000 @@ -1,77 +0,0 @@ - - - Release notes for version 7.0.3 - - - The significant changes to the various parts of the compiler - since 7.0.2 are listed below. - - - - - - GHC on OS X now works with XCode 4. - - - - - - Object splitting (which gives smaller binaries) is now enabled - on OS X provided you have XCode 3.2 or later. - - - - - - A compiler panic when compiling large files with LLVM has been - fixed. - - - - - - Some bad floating point results on x86 have been fixed. - - - - - - The -read_only_relocs flag is no longer used - on OS X 64, which eliminates some warnings. - - - - - - Some section misnumberings in the documentation have been corrected. - - - - - - The documentation is installed into the correct location by - the Windows installer. - - - - - - The documentation is now included in the OS X installer. - - - - - - Some small documentation tweaks have been made. - - - - - - Some duplicate files have been removed from the bindists. - - - - - - diff -Nru ghc-7.0.3/docs/users_guide/7.2.1-notes.xml ghc-7.2.1/docs/users_guide/7.2.1-notes.xml --- ghc-7.0.3/docs/users_guide/7.2.1-notes.xml 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/docs/users_guide/7.2.1-notes.xml 2011-08-07 17:10:05.000000000 +0000 @@ -0,0 +1,2159 @@ + + + Release notes for version 7.2.1 + + + The significant changes to the various parts of the compiler are + listed in the following sections. There have also been numerous bug + fixes and performance improvements over the 7.0 branch. The 7.2 + branch is intended to be more of a "technology preview" than normal + GHC stable branches. + + + + Highlights + + + + DPH support () has been significantly + improved. + + + + + + A new feature Safe Haskell () + has been implemented. + + + + + + It is now possible to write compiler plugins + (). + + + + + + + Language changes + + + + It is now possible to give classes equality superclasses, + i.e. you can write something like + class (F a ~ b) => C a b where { ... }. + See for more details. + + + + + + The TypeSynonymInstances extension now + correctly requires that instances are valid once the type + synonym is expanded. For example, in order to have + + +instance SomeClass String where + ... + + + you need both TypeSynonymInstances and + FlexibleInstances enabled, as the latter + is necessary for + + +instance SomeClass [Char] where + ... + + + + + + The DatatypeContexts extension (which will + not be in the next Haskell language standard) is now off by + default, and deprecated. It is still enabled by the + Haskell98 and + Haskell2010 languages. + See for more details. + + + + + + There is a new extension + NondecreasingIndentation, which controls + an extension to the layout rule that was previously always + enabled. It is now on by default, and (incorrectly, but for + backwards compatibility) on in Haskell98, + but off in Haskell2010. + + + + + + The new RelaxedLayout extension now + controls a small extension to the layout rule that GHC has + supported unconditionally for some time. It allows explicit + braces to be less indented than implicit braces, without + closing the implicit braces, e.g.: + + +f x = case x of + False -> do + { return x; } + + + parses as + + +f x = case x of + {False -> do + { return x; }} + + + + + + There is a new family of language extensions, collectively + known as "Safe Haskell". This includes notions + of "safe modules", "trusted modules" + and "trusted packages". + See for more details. + + + + The new SafeImports extension extends the + import declaration syntax to take an optional + safe keyword after the + import keyword, e.g. with + + +import safe Network.Socket + + + compilation will only succeed if + Network.Socket is a "trusted" module. + See for more details. + + + + The new Trustworthy extension means that + users of the package are able to declare that this module is + to be trusted, even though GHC can't infer that it is safe. + It implies the SafeImports extension. + See for more details. + + + + The new Safe extension means GHC will + check that a module's code is safe, and that all its imports + are trusted. It implies the SafeImports + extension, although all imports are required to be trusted + anyway. + See for more details. + + + + + + The new extension MonadComprehensions + allows comprehension syntax to be usde with any Monad, not + just lists. e.g. + + +[ x + y | x <- Just 1, y <- Just 2 ] + + + evaluates to Just 3. + See for more details. + + + + + + The new DefaultSignatures extension + allows you to define a default implementation for + a class method that isn't as general as the method's type. + For example, + + +class DefaultValue a where + defaultValue :: a + default defaultValue :: Num a => a + defaultValue = 3 + +instance DefaultValue Int +instance DefaultValue Float +instance DefaultValue Char where + defaultValue = 'x' + + + See for more details. + + + + + + The new DeriveGeneric extension allows + instances of the new GHC.Generics.Generic + class to be derived. Together with the + DefaultSignatures extension this allows + generic programming. + See for more details. + + + + + + The Generics extension has now been + removed. Use the new DefaultSignatures and + DeriveGeneric extensions instead. + The {| curly-pipe bracket |} syntax is thus + no longer recognised. + + + + The -XGenerics flag will give a warning, + but the -fgenerics flag is no longer + accepted. + + + + + + When the new InterruptibleFFI extension is + enabled, it is now possible to annotate FFI imports as + interruptible, e.g. + + +foreign import ccall interruptible + "sleep" :: CUint -> IO CUint + + + in which case for most foreign calls it is possible to + interrupt the foreign call by using throwTo + to throw an exception to the thread making the call. + See for more details. + + + + + + The threadsafe FFI annotation is no longer + supported. Use safe instead. + + + + + + The OverlappingInstances extension used to + allow overlapping instances only when all but the + most specific instance were compiled with + OverlappingInstances. + Now overlap is allowed if either all but + the most specific instance were compiled with + OverlappingInstances, + or if the most specific instance was + compiled with OverlappingInstances. + + + + + + There is a new extension GADTSyntax, + off by default, which permits generalised algebraic data type + syntax for declaring traditional Haskell datatypes. It is + enabled by the GADTs extension. + See for more details. + + + + + + The NewQualifiedOperators extension, which was + deprecated, has now been removed. + + + + + + There are new pragmas VECTORISE, + VECTORISE_SCALAR and + NOVECTORISE for controlling the behaviour + of the vectoriser. + + + + + + Characters in the unicode OtherNumber + category are now treated as being 'digit's, rather than 'other + graphical' characters. + + + + + + + Warnings + + + + The new -fwarn-identities flag warns about + uses of toInteger, + toRational, fromIntegral + and realToFrac which are the identity. + + + + + + The new -fwarn-incomplete-uni-patterns + flag warns about pattern matches in a lambda expression or + pattern binding which could fail, e.g. + + +h = \[] -> 2 +Just k = f y + + + + + + The new -fwarn-missing-local-sigs flag + warns about polymorphic local bindings without type + signatures. The warning includes the inferred type. + + + + + + The new -fwarn-missing-import-lists flag + warns if you use an unqualified import declaration that does + not explicitly list the entities brought into scope. For + example, + + +import X (f) +import Y +import qualified Z + + + will warn about the import of Y, but not + X or Z. The rationale is + that if module Y is later changed to + export something called f, then any + references to f will become ambiguous. + + + + + + + Dumps + + + + The previously-undocumented flag + -ddump-to-file causes the output from the + other -ddump-* flags to be put in + appropriately-named files, rather than printed on stdout. + + + + This now also includes the -ddump-simpl + flag, whose output is put in + file_base_name.dump-simpl. + + + + + + The new -dppr-noprags flag omits the + pragma info in dumps. + + + + + + The new -ddump-rule-rewrites flag + dumps detailed information about all rules that fired + in this module. + + + + + + The new -ddump-vect flag dumps the output + of the vectoriser. + + + + + + The new -ddump-vt-trace flag makes the + vectoriser be very chatty about what it is up to. + + + + + + The new -ddump-core-stats flag prints + a one-line summary of the size of the Core program at the + end of the optimisation pipeline. + + + + + + The new -dppr-case-as-let flag prints + single-alternative case expressions as though they were + strict let expressions. This is helpful when your code + does a lot of unboxing. + + + + + + The new -dsuppress-all flag suppresses + 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. + + + + + + The new -dsuppress-idinfo flag + suppresses 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. + + + + + + The new -dsuppress-type-signatures flag + suppresses the printing of type signatures. + + + + + + The new -dsuppress-type-applications flag + suppresses the printing of type applications. + + + + + + The new -dppr-colsNNN flag sets the width + of debugging output. Use this if your code is wrapping too + much. For example, -dppr-cols200. + + + + + + + Runtime system + + + + + The -k RTS flag, which sets the initial + thread stack size (default 1k), has been renamed + -ki. The old name still works, but may + be removed in a future version of GHC. + + + + There are also new flags -kc, which + sets the stack chunk size (default 32k), and + -kb, which sets the stack chunk buffer + size (default 1k). + + + + + + Profiling reports now use constant width columns, so large + values don't cause the layout to go wrong. + + + + + + The -L RTS flag, which sets the width of + the labels in heap profile graphs, can now also be used when + retainer profiling. + + + + + + The -qw RTS flag is now deprecated. It does + nothing, and will be removed in a future version of GHC. + + + + + + We now keep copies of the argument lists we are passed, so + it is safe for callers of hs_init() to + free the pointers they pass. + + + + + + The archive loader now supports Darwin "fat archives". + + + + + + Linker scripts using INPUT are now supported. + + + + + + The RtsFlags.h header file has finally been + removed; use Rts.h instead. + + + + + + There are some new threadscope event types: + + + + + EVENT_CAPSET_CREATE + Create capability set + + + EVENT_CAPSET_DELETE + Delete capability set + + + EVENT_CAPSET_ASSIGN_CAP + Add capability to capability set + + + EVENT_CAPSET_REMOVE_CAP + Remove capability from capability set + + + EVENT_RTS_IDENTIFIER + RTS name and version + + + EVENT_PROGRAM_ARGS + Program arguments + + + EVENT_PROGRAM_ENV + Program environment variables + + + EVENT_OSPROCESS_PID + Process ID + + + EVENT_OSPROCESS_PPID + Parent process ID + + + + + + + + + + The linker now supports kfreebsdgnu. + + + + + + + Compiler + + + + When using Haskell code as a library, and calling it from + another language, it is no longer necessary to call the + hs_add_root function. + + + + + + The "evil mangler" has been removed, and + registerised compilation via C is no longer supported. + This means that the + -fvia-c, + -fvia-C, + -keep-raw-s-file, + -keep-raw-s-files, + -pgmm, + -optm, + -monly-2-regs, + -monly-3-regs and + -monly-4-regs + flags are now deprecated, and + have no effect. + The -fasm-mangling and + -fno-asm-mangling flags have been removed. + + + + Unregisterised compilation, for architectures for which + there is no native code generator, is still possible, + and still compiles via C. + + + + + + Compiling Objective-C (.m) files is now + supported, assuming your gcc is capable + of compiling them. + + + + + + The new "Safe Haskell" extensions introduce three + new GHC flags: -trust P exposes package + P if it was hidden and considers it a + trusted package; + -distrust P exposes package + P if it was hidden and considers it an + untrusted package; + -distrust-all-packages considers all + packages distrusted unless they are explicitly set to be + trusted by subsequent command-line options. + + + + + + Significant progress has been made on the new code generator, + but it is not yet ready for prime-time. If you want to try + it out, use the -fnew-codegen flag. + + + + + + The Alpha native code generator had bitrotted, so has now + been removed. + + + + + + Running ghc -v ... will no longer pass + -v to gcc. You now need + to use ghc -v4 ... (or higher) instead. + + + + + + The -Odph flag is now equivalent to + -O2 -fsimplifier-phases=3 -fsimplifier-iterations=20. + + + + + + There is a new -fdph-none flag can be used + to specify that no DPH backend should be used. It is now the + default, i.e. -fdph-par or + -fdph-seq need to be explicitly specified + if required. + + + + + + The -n flag has been removed. + + + + + + The -fmethod-sharing flag has been removed. + + + + + + + GHCi + + + + GHCi now has a multiline-input mode, enabled with + :set +m. For example, + + +Prelude> :set +m +Prelude> let x = 3 +Prelude| y = 4 +Prelude| in x + y +7 +Prelude> + + + + + + The new :script command takes a filename + as an argument, and executes each line in that file. It + supports multiline statements if the +m + mode is set. + + + + + + The new :issafe command tells you whether + a module is considered to be trusted or not. + + + + + + When resolving abbreviated GHCi commands, we now prefer + built-in commands to user defined commands. This makes things + more consistent, e.g. :i will always mean + :info, unless :i itself + is defined by the user. + + + + + + The :m +M and import M + GHCi commands now do exactly the same thing. + + + + + + With a new flag -ghci-script you can specify + additional files to be read on startup, in the same way that + .ghci is. + + + + + + + ghc-pkg + + + + There are new ghc-pkg commands trust + and distrust, used for setting the + trustworthiness of packages for Safe Haskell. + See for more details. + + + + + + The new flags + -expand-env-vars, + -expand-pkgroot and + -no-expand-pkgroot + control whether the ${pkgroot}, + ${pkgrooturl} and + ${topdir} variables are expanded + when printing information. + + + + + + The --auto-ghci-libs flag is deprecated, + and will be removed in a future version. + + + + + + + hsc2hs + + + + Cross-compilation is now supported by hsc2hs, for most features. + The new --cross-compile + (or -x) flag enables cross-compilation, + while --cross-safe checks that only + features for which cross-compilation works are used. + See for more details. + + + + + + The new --keep-files + (or -k) flag makes hsc2hs keep the + intermediate files that it generates. + + + + + + + GHC API + + + + GHC now has support for "plugins". This feature + allows you to write a Core-to-Core pass and have it + dynamically linked into an otherwise-unmodified GHC, and run + at a place you specify in the Core optimisation pipeline. + + + + The new + -fplugin=module + flag specifies that module is + to be used as a plugin, and + -fplugin-opt=module:args + allows arguments to be passed to the plugin. + + + + See for more details. + + + + + + Coercions now have their own datatype rather than being + represented as types. They are now value-level things, + rather than type-level things, although the value is zero + bits wide (like the State token). + + + + + + The StmtLR datatype has a new constructor + LastStmt, which holds the final + (expression) statement of all comprehensions and + do-blocks. + + + + + + The printExceptionAndWarnings function + has been deprecated, in favour of the new + printException function. + + + + + + The SrcSpan and SrcLoc + types have been refactored so that the new + RealSrcSpan and + RealSrcLoc types are used when we have a + real location, rather than an "unhelpful" location. + + + + + + The type of defaultErrorHandler has + changed. In particular, this means that you will normally + want to pass it defaultLogAction instead + of defaultDynFlags. + + + + + + Calling withFlattenedDynflags is no longer + necessary, and the function has been removed. + + + + + + Several of the old native code generator modules gained an + Old prefix, when their names clashed with + modules in the new native code generator. + + + + + + + Build System and Infrastructure + + + + GHC development now uses git repositories, rather than darcs + repositories. Instructions for getting source trees are on + the GHC wiki. + + + + The sync-all script, rather than the + darcs-all script, is now used for dealing + with repositories. + + + + + + GHC >= 6.12 is now required to build GHC. + + + + + + Building with gcc 4.6 now works. + + + + + + On Windows, we now bundle gcc 4.5.2-1 (was 4.5.0-1). + + + + + + GHC now works with LLVM 3.0. + + + + + + The location of gcc, and various other settings, is now in a + settings file. The + extra-gcc-opts file is no longer used. + + + + + + It is no longer necessary to set + GhcWithLlvmCodeGen = YES in order to get + llvm support: llvm support is now always enabled. + + + + + + The new code generator is not yet ready for prime-time, but + if you want to experiment with it you can make it the default + by setting + + +GhcStage1DefaultNewCodegen=YES +GhcStage2DefaultNewCodegen=YES +GhcStage3DefaultNewCodegen=YES + + + in your mk/build.mk. + + + + + + Platforms with a vendor of softfloat, such + as armv5tel-softfloat-linux-gnueabi, are + now supported. + + + + + + + Libraries + + + + + Unicode support has generally been improved across + the core libraries. This has a few consequences: + + + + Code that has been using the *CString + functions may need to be corrected to use the + *CAString functions. + + + + Users may now observe strings — particularly + those from the commandline — containing + private-use characters, i.e. those in the range 0xEF00 + to 0xEFFF inclusive. + + + + Programs may now get exceptions when writing strings + in the wrong encoding to (for example) stdout. + + + + + + array + + + + Version number 0.3.0.3 (was 0.3.0.2) + + + + + + + base + + + + Version number 4.4.0.0 (was 4.3.1.0) + + + + + + The Typeable module has been + overhauled. The mkTyCon + function has been deprecated; the preferable fix + is to derive Typeable instead + (see ), + although there is also a replacement + for mkTyCon in the form of a + new function + mkTyCon3, which takes separate + strings for the package, module and name of the + type constructor. + Also, typeRepKey is deprecated, + and both TypeRep + and TyCon now + have Ord instances which means + they can be used as Map keys. + + + + + + The result of gcd 0 0 is now + 0, rather than throwing an exception. + + + + + + The result of minBound `rem` -1 + and minBound `div` -1 is now 0, + rather than throwing an overflow exception. + + + + + + Control.Concurrent now exports + new functions + forkIOWithUnmask, + forkOn, + forkOnWithUnmask, + getNumCapabilities and + threadCapability. + The forkIOUnmasked function has + been deprecated in favour of + forkIOWithUnmask. + + + + The same changes have been made to + GHC.Conc and + GHC.Conc.Sync. + + + + + + Control.Exception exports a new + function allowInterrupt which, when + invoked inside mask, allows a + blocked asynchronous exception to be raised, if one + exists. + + + + + + System.IO.Unsafe now exports + the new function + unsafeDupablePerformIO. + This is a more efficient version of + unsafePerformIO, but may run the + IO action multiple times (currently, in GHC, only + when multiple threads try to evaluate it + simultaneously). + + + + + + System.IO.Error now exports + new functions catchIOError and + tryIOError. + The try and catch + functions are now deprecated. + + + + + + GHC.IO.Encoding now exports three + new TextEncodings: + + + + The fileSystemEncoding encoding + is the Unicode encoding of the current locale, but + allows arbitrary undecodable bytes to be + round-tripped through it. It is used to decode and + encode command line arguments and environment + variables on non-Windows platforms. + + + + The foreignEncoding encoding + is the Unicode encoding of the current locale, but + undecodable bytes are replaced with their closest + visual match. It's used for the + CString marshalling functions in + Foreign.C.String. + + + + In the char8 encoding Unicode + code points are translated to bytes by taking the + code point modulo 256. When decoding, bytes are + translated directly into the equivalent code point. + This encoding is also exported by + System.IO. + + + + + + The functions to make + TextEncodings now have + mk* variants which take a + CodingFailureMode argument. + The new functions, together with what they + generalise, are: + + + + + + + + GHC.IO.Encoding.Latin1 + latin1 + mkLatin1 + + + GHC.IO.Encoding.Latin1 + latin1_checked + mkLatin1_checked + + + GHC.IO.Encoding.UTF8 + utf8 + mkUTF8 + + + GHC.IO.Encoding.UTF8 + utf8_bom + mkUTF8_bom + + + GHC.IO.Encoding.UTF16 + utf16 + mkUTF16 + + + GHC.IO.Encoding.UTF16 + utf16be + mkUTF16be + + + GHC.IO.Encoding.UTF16 + utf16le + mkUTF16le + + + GHC.IO.Encoding.UTF32 + utf32 + mkUTF32 + + + GHC.IO.Encoding.UTF32 + utf32be + mkUTF32be + + + GHC.IO.Encoding.UTF32 + utf32le + mkUTF32le + + + + + + + + Similarly, there are new + mkCodePageEncoding and + mkLocaleEncoding + generalisations of + codePageEncoding and + localeEncoding in + GHC.IO.Encoding.CodePage. + + + + GHC.IO.Encoding.Iconv has + been similarly altered, and now only exports + iconvEncoding, + mkIconvEncoding, + localeEncoding and + mkLocaleEncoding. + + + + + + GHC.IO.Encoding.Types and + GHC.IO.Encoding now export a new + type CodingProgress which + describes the state of a text encoder. The + BufferCodec, + DecodeBuffer and + EncodeBuffer types have also + changed. + + + + + + GHC.IO now exports bracket. + + + + + + GHC.IO.blocked is now deprecated + in favour of + Control.Exception.getMaskingState. + + + + + + GHC.Show now exports two new + helpers, showLitString (analogous + to showLitChar) and + showMultiLineString (which breaks + a string containing newlines characters up into + multiple strings). + + + + + + The type of GHC.IO.FD.openFile + has changed to include a flag for whether to + open the file in non-blocking mode. + + + + + + GHC.IO.Handle.FD now exports a + variant openFileBlocking of + openFile, which opens the file + in blocking mode. + + + + + + The type of + Foreign.Marshal.Utils.maybeNew + has been generalised to + (a -> IO (Ptr b)) -> (Maybe a -> IO (Ptr b)) + + + + + + Foreign.C.Types now exports new + types CUSeconds and + CSUSeconds, corresponding to the + C types useconds_t and + suseconds_t respectively. + + + + + + System.Posix.Internals new exports + new functions peekFilePath + and, on non-Windows platforms, + peekFilePathLen and + c_safe_open. + + + + + + Data.List.inits, + Data.List.tails, + Data.List.intersperse and + Data.List.intersectBy + are now lazier. + + + + + + Data.Char no longer exports + String. + + + + + + Data.String now re-exports + String, + lines, + unlines, + words and + unwords. + + + + + + There is now a Read instance for + Data.Fixed.Fixed a. + + + + + + There are now Eq instances for + Control.Concurrent.Chan.Chan, + Control.Concurrent.QSem.QSem and + Control.Concurrent.QSemN.QSemN. + + + + + + There are now Applicative + instances for + Control.Monad.ST.ST and + Control.Monad.ST.Lazy.ST. + + + + + + There is now a + Typeable instance for + Control.Concurrent.SampleVar.SampleVar. + + + + + + Most of GHC.PArr has been moved + into the dph package. Only the + [::] datatype remains. + + + + + + There is a new module + Control.Monad.Group + for monadic grouping (used for monad comprehensions). + + + + + + There is a new module + Control.Monad.Zip + for monadic zipping (used for monad comprehensions). + + + + + + There is a new internal module + GHC.Foreign which provides + versions of some C string functions generalised + to be usable with any encoding. + + + + + + There is a new internal module + GHC.IO.Encoding.Failure which + provides functionality for specifying how text + encoding and decoding fails. + + + + + + On Windows, there is a new internal module + GHC.Windows which duplicates + part of System.Win32.Types. + + + + + + Some functions have been moved from + GHC.Base down into + GHC.Classes. + + + + + + There are now new internal modules + GHC.Float.ConversionUtils and + GHC.Float.RealFracMethods. + + + + + + The safe parts of the Foreign + module are now in a new module + Foreign.Safe. + Foreign now reexports + all the safe code it used to, as well as + deprecated copies of the unsafe functions. + + + + + + The Foreign.ForeignPtr module + has been split into + Foreign.ForeignPtr.Safe and + Foreign.ForeignPtr.Unsafe. + Foreign.ForeignPtr now + reexports + Foreign.ForeignPtr.Safe and + a deprecated copy of the unsafe function + (unsafeForeignPtrToPtr). + + + + + + The Foreign.Marshal module + has been split into + Foreign.Marshal.Safe and + Foreign.Marshal.Unsafe. + Foreign.Marshal now + reexports + Foreign.Marshal.Safe and + a deprecated copy of the unsafe function + (unsafeLocalState). + + + + + + The Control.Monad.ST module + has been split into + Control.Monad.ST.Safe and + Control.Monad.ST.Unsafe. + Control.Monad.ST now + reexports + Control.Monad.ST.Safe and + deprecated copies of the unsafe functions + (unsafeInterleaveST, + unsafeIOToST and + unsafeSTToIO). + + + + + + The Control.Monad.ST.Lazy module + has been split into + Control.Monad.ST.Lazy.Safe and + Control.Monad.ST.Lazy.Unsafe. + Control.Monad.ST.Lazy now + reexports + Control.Monad.ST.Lazy.Safe and + deprecated copies of the unsafe functions + (unsafeInterleaveST + and unsafeIOToST). + + + + + + The System.Event module has been + renamed GHC.Event. + + + + + + Following the removal of + DatatypeContexts from the + language, the definitions of + Control.Arrow.ArrowMonad, + Array and + Complex and + Ratio have had their + datatype contexts removed. + + + + + + Many modules have been marked + Trustworthy. + + + + + + System.Posix.Internals now + exports a function puts, for + debugging within the base package. + + + + + + The Unicode data is now based on version 6.0.0 (was + 5.1.0) of the Unicode spec. + + + + + + + bin-package-db + + + + This is an internal package, and should not be used. + + + + + + + binary + + + + New package, version 0.5.1.0. + TODO: Bump version + It is not exposed by default. + + + + + + + bytestring + + + + Version number 0.9.2.0 (was 0.9.1.10) + + + + + + There is now an + hPutNonBlocking + function in + Data.ByteString, + Data.ByteString.Char8, + Data.ByteString.Lazy and + Data.ByteString.Lazy.Char8. + + + + + + There are now hPutStrLn + and putStrLn functions in + Data.ByteString.Char8 and + Data.ByteString.Lazy.Char8. + + + + The functions in + Data.ByteString and + Data.ByteString.Lazy + are now deprecated. + + + + + + + Cabal + + + + Version number 1.12.0.0 (was 1.10.2.0) + TODO: Currently we have 1.11.0. The branch needs to + be created. + + + + + + For details of changes to Cabal, please see the + Cabal changelog. + + + + + + + containers + + + + Version number 0.4.1.0 (was 0.4.0.0) + TODO: Bump version + + + + + + Data.Map now exports new + functions foldrWithKey' and + foldlWithKey', which are strict + variants of foldrWithKey and + foldlWithKey respectively. + + + + + + Data.IntMap now exports new + functions insertWith' and + insertWithKey', which are strict + variants of insertWith and + insertWithKey respectively. + + + + + + + directory + + + + Version number 1.1.0.1 (was 1.1.0.0) + + + + + + + extensible-exceptions + + + + Version number 0.1.1.3 (was 0.1.1.2) + + + + + + + filepath + + + + Version number 1.2.0.1 (was 1.2.0.0) + + + + + + The handling of "." as a component in a + FilePath is now more consistent. + See #3975 for more information. + + + + + + + ghc-binary + + + + GHC no longer includes this internal package. + + + + + + + ghc-prim + + + + This is an internal package, and should not be used. + + + + + + + haskell98 + + + + Version number 2.0.0.0 (was 1.1.0.1) + + + + + + It is no longer possible to use the haskell98 + package with the base package, as it now includes the + Prelude and + Numeric modules. The haskell98 + package is therefore now hidden by default. + + + + + + + haskell2010 + + + + Version number 1.1.0.0 (was 1.0.0.0) + + + + + + The splitAt function now + has the correct strictness, as defined by the + report. + + + + + + + hoopl + + + + This is a new package, version 3.8.7.2. + TODO: Bump version number. 3.8.7.1 is on hackage. + + + + + + + hpc + + + + Version number 0.5.1.0 (was 0.5.0.6) + + + + + + A new function catchIO is now + exported by Trace.Hpc.Util. + + + + + + + integer-gmp + + + + Version number 0.3.0.0 (was 0.2.0.2) + + + + + + Now exposes two new modules, + GHC.Integer.Logarithms and + GHC.Integer.Logarithms.Internals. + + + + + + The toInt# function has been + renamed to integerToInt. + + + + + + + old-locale + + + + Version number 1.0.0.3 (was 1.0.0.2) + + + + + + + old-time + + + + Version number 1.0.0.7 (was 1.0.0.6) + + + + + + + pretty + + + + Version number 1.1.0.0 (was 1.0.1.2) + + + + + + There is a new function + sizedText, + which allows you to specify the width that a string + should be considered to have. + + + + + + The Doc type is now an instance + of IsString and + Monoid. + + + + + + + process + + + + Version number 1.1.0.0 (was 1.0.1.4) + + + + + + There is a new function + showCommandForUser in + System.Process which, + given a program and its arguments, + returns a string suitable for pasting + into sh (on POSIX OSs) or cmd.exe (on Windows). + + + + + + There is a new function + interruptProcessGroupOf in + System.Process which + sends an interrupt signal to the process group of + the given process. On Unix systems, it sends the + group the SIGINT signal. + On Windows systems, it generates a + CTRL_BREAK_EVENT and will only + work for processes created using + createProcess with the + create_group flag set. + + + + + + The CreateProcess + constructor, exported by + System.Process.Internals and + System.Process, has a new + Bool field + create_group + which specifies whether a process group should be created. + + + + + + The type of withCEnvironment + on Windows is now more consistent with other + platforms, as the action now takes a + Ptr CWString rather than + Ptr (). + + + + + + + random + + + + GHC no longer includes the random library + + + + + + + template-haskell + + + + Version number 2.6.0.0 (was 2.5.0.0) + + + + + + In Language.Haskell.TH.Syntax + the Exp, Pat + and Type datatypes have new + constructors UnboxedTupE, + UnboxedTupP and + UnboxedTupleT respectively. + There are also new helper functions + unboxedTupleTypeName and + unboxedTupleDataName. + + + + There are corresponding helper functions + unboxedTupE, + unboxedTupP and + unboxedTupleT in + Language.Haskell.TH.Lib. + + + + + + In Language.Haskell.TH.Syntax + the Safety type has a new + constructor Interruptible. + + + + There is a corresponding new value + interruptible :: Safety + in Language.Haskell.TH.Lib. + + + + However, the Threadsafe + constructor and threadsafe + helper have been removed, following the removal + of the feature from GHC. + + + + + + In Language.Haskell.TH.Syntax, + the classInstances function now + has type + Name -> [Type] -> Q [ClassInstance], + and the qClassInstances instance + of the Quasi class now has type + Name -> [Type] -> m [ClassInstance]. + + + + + + There are now helper functions + pprString and + hashParens exported from + Language.Haskell.TH.Ppr. + + + + + + The helper functions + combine, + rename, + genpat, + alpha and + simpleMatch + have been removed from + Language.Haskell.TH.Lib. + + + + + + + time + + + + Version number 1.2.0.5 (was 1.2.0.3) + + + + + + The %-, %_ + and %0 specifiers can now be + used. For example, + + +> parseTime defaultTimeLocale "%-m/%e/%Y" "3/9/2011" :: Maybe Day +Just 2011-03-09 + + + + + + The default year is now correctly in the range + 1969-2068, rather than 1900-1999. + + + + + + Some cases in which an exception was thrown now + correctly return Nothing. + + + + + + + unix + + + + Version number 2.5.0.0 (was 2.4.2.0) + + + + + + In System.Posix.Process + the createProcessGroup + and setProcessGroupID + functions have been deprecated. + + + + There are new functions, which subsume their + functionality, called + createProcessGroupFor, + getProcessGroupIDOf and + setProcessGroupIDOf. + + + + + + In System.Posix.Error, there is a + new variant of + throwErrnoPathIfMinus1Retry + called + throwErrnoPathIfMinus1Retry_, + which returns IO (). + + + + + + + Win32 + + + + Version number 2.2.1.0 (was 2.2.0.2) + + + + + + There are new functions + getProcessId and + c_GetProcessId in + System.Win32.Process. + + + + + + + diff -Nru ghc-7.0.3/docs/users_guide/bugs.xml ghc-7.2.1/docs/users_guide/bugs.xml --- ghc-7.0.3/docs/users_guide/bugs.xml 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/docs/users_guide/bugs.xml 2011-08-07 17:10:05.000000000 +0000 @@ -5,7 +5,7 @@ Haskell 98 vs. Glasgow Haskell: language non-compliance - + GHC vs the Haskell 98 language Haskell 98 language vs GHC @@ -19,11 +19,11 @@ Divergence from Haskell 98 - - + + Lexical syntax - + Certain lexical rules regarding qualified identifiers @@ -36,10 +36,10 @@ - + Context-free syntax - + GHC is a little less strict about the layout rule when used @@ -101,14 +101,14 @@ . See . - + Module system and interface files - + GHC requires the use of hs-boot files to cut the recursive loops among mutually recursive modules as described in . This more of an infelicity - than a bug: the Haskell Report says + than a bug: the Haskell Report says (Section 5.7) "Depending on the Haskell implementation used, separate compilation of mutually recursive modules may require that imported modules contain @@ -141,7 +141,7 @@ - + @@ -251,7 +251,7 @@ the Int type. The fromIntegerfromInteger - function (and hence + function (and hence also fromIntegralfromIntegral ) is a special case when converting to Int. The value of @@ -265,7 +265,7 @@ Negative literals, such as -3, are - specified by (a careful reading of) the Haskell Report as + specified by (a careful reading of) the Haskell Report as meaning Prelude.negate (Prelude.fromInteger 3). So -2147483648 means negate (fromInteger 2147483648). Since fromInteger takes the lower 32 bits of the representation, @@ -302,12 +302,12 @@ - + Divergence from the FFI specification - + hs_init() not allowed @@ -321,7 +321,7 @@ - + @@ -348,7 +348,7 @@ - GHC does not allow you to have a data type with a context + GHC does not allow you to have a data type with a context that mentions type variables that are not data type parameters. For example: @@ -369,10 +369,10 @@ using the standard way to encode recursion via a data type: data U = MkU (U -> Bool) - + russel :: U -> Bool russel u@(MkU p) = not $ p u - + x :: Bool x = russel (MkU russel) @@ -414,7 +414,7 @@ module (whatever that is). - + On Windows, there's a GNU ld/BFD bug whereby it emits bogus PE object files that have more than 0xffff relocations. When GHCi tries to load a package affected by this diff -Nru ghc-7.0.3/docs/users_guide/debugging.xml ghc-7.2.1/docs/users_guide/debugging.xml --- ghc-7.0.3/docs/users_guide/debugging.xml 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/docs/users_guide/debugging.xml 2011-08-07 17:10:05.000000000 +0000 @@ -8,10 +8,10 @@ Dumping out compiler intermediate structures - + dumping GHC intermediates intermediate passes, output - + @@ -24,8 +24,9 @@ a short form…). You can get all of these at once (lots of output) by using , or most of them with - . Some of the most useful ones - are: + . You can prevent them from clogging up + your standard output by passing . + Some of the most useful ones are: @@ -120,7 +121,7 @@ - dumps all rewrite rules specified in this module; + dumps all rewrite rules specified in this module; see . @@ -128,6 +129,39 @@ + : + + + + dumps the names of all rules that fired in this module + + + + + + : + + + + dumps detailed information about all rules that fired in + this module + + + + + + + : + + + + dumps the output of the vectoriser. + + + + + + : @@ -278,7 +312,7 @@ - + : @@ -323,19 +357,30 @@ Make the interface loader be *real* chatty about what it is - upto. + up to. - + - - Make the type checker be *real* chatty about what it is - upto. - + + Make the type checker be *real* chatty about what it is + up to. + + + + + + + + + + Make the vectoriser be *real* chatty about what it is + up to. + @@ -345,7 +390,7 @@ Make the renamer be *real* chatty about what it is - upto. + up to. @@ -380,7 +425,7 @@ - + @@ -393,6 +438,17 @@ + + + + + Print a one-line summary of the size of the Core program + at the end of the optimisation pipeline. + + + + + @@ -421,6 +477,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. + + @@ -428,7 +566,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 @@ -438,12 +576,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 @@ -453,36 +592,39 @@ - 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 -Nru ghc-7.0.3/docs/users_guide/extending_ghc.xml ghc-7.2.1/docs/users_guide/extending_ghc.xml --- ghc-7.0.3/docs/users_guide/extending_ghc.xml 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/docs/users_guide/extending_ghc.xml 2011-08-07 17:10:05.000000000 +0000 @@ -0,0 +1,292 @@ + + + Extending and using GHC as a Library + + GHC exposes its internal APIs to users through the built-in ghc package. It allows you to write programs that leverage GHC's entire compilation driver, in order to analyze or compile Haskell code programmatically. Furthermore, GHC gives users the ability to load compiler plugins during compilation - modules which are allowed to view and change GHC's internal intermediate representation, Core. Plugins are suitable for things like experimental optimizations or analysis, and offer a lower barrier of entry to compiler development for many common cases. + + Furthermore, GHC offers a lightweight annotation mechanism that you can use to annotate your source code with metadata, which you can later inspect with either the compiler API or a compiler plugin. + + + Source annotations + + Annotations are small pragmas that allow you to attach data to identifiers in source code, which are persisted when compiled. These pieces of data can then inspected and utilized when using GHC as a library or writing a compiler plugin. + + + Annotating values + + ANN + + Any expression that has both Typeable and Data instances may be attached to a top-level value + binding using an ANN pragma. In particular, this means you can use ANN + to annotate data constructors (e.g. Just) as well as normal values (e.g. take). + By way of example, to annotate the function foo with the annotation Just "Hello" + you would do this: + + +{-# ANN foo (Just "Hello") #-} +foo = ... + + + + A number of restrictions apply to use of annotations: + + The binder being annotated must be at the top level (i.e. no nested binders) + The binder being annotated must be declared in the current module + The expression you are annotating with must have a type with Typeable and Data instances + The Template Haskell staging restrictions apply to the + expression being annotated with, so for example you cannot run a function from the module being compiled. + + To be precise, the annotation {-# ANN x e #-} is well staged if and only if $(e) would be + (disregarding the usual type restrictions of the splice syntax, and the usual restriction on splicing inside a splice - $([|1|]) is fine as an annotation, albeit redundant). + + + If you feel strongly that any of these restrictions are too onerous, + please give the GHC team a shout. + + + However, apart from these restrictions, many things are allowed, including expressions which are not fully evaluated! + Annotation expressions will be evaluated by the compiler just like Template Haskell splices are. So, this annotation is fine: + + +{-# ANN f SillyAnnotation { foo = (id 10) + $([| 20 |]), bar = 'f } #-} +f = ... + + + + + Annotating types + + ANN type + ANN + + You can annotate types with the ANN pragma by using the type keyword. For example: + + +{-# ANN type Foo (Just "A `Maybe String' annotation") #-} +data Foo = ... + + + + + Annotating modules + + ANN module + ANN + + You can annotate modules with the ANN pragma by using the module keyword. For example: + + +{-# ANN module (Just "A `Maybe String' annotation") #-} + + + + + + + Using GHC as a Library + + The ghc package exposes most of GHC's frontend to users, and thus allows you to write programs that leverage it. This library is actually the same library used by GHC's internal, frontend compilation driver, and thus allows you to write tools that programmatically compile source code and inspect it. Such functionality is useful in order to write things like IDE or refactoring tools. As a simple example, here's a program which compiles a module, much like ghc itself does by default when invoked: + + +import GHC +import GHC.Paths ( libdir ) +import DynFlags ( defaultDynFlags ) + +main = + defaultErrorHandler defaultDynFlags $ do + runGhc (Just libdir) $ do + dflags <- getSessionDynFlags + setSessionDynFlags dflags + target <- guessTarget "test_main.hs" Nothing + setTargets [target] + load LoadAllTargets + + + The argument to runGhc is a bit tricky. GHC needs this to find its libraries, so the argument must refer to the directory that is printed by ghc --print-libdir for the same version of GHC that the program is being compiled with. Above we therefore use the ghc-paths package which provides this for us. + + Compiling it results in: + + +$ cat test_main.hs +main = putStrLn "hi" +$ ghc -package ghc simple_ghc_api.hs +[1 of 1] Compiling Main ( simple_ghc_api.hs, simple_ghc_api.o ) +Linking simple_ghc_api ... +$ ./simple_ghc_api +$ ./test_main +hi +$ + + + For more information on using the API, as well as more samples and references, please see this Haskell.org wiki page. + + + + Compiler Plugins + + GHC has the ability to load compiler plugins at compile time. The feature is similar to the one provided by GCC, and allows users to write plugins that can inspect and modify the compilation pipeline, as well as transform and inspect GHC's intermediate language, Core. Plugins are suitable for experimental analysis or optimization, and require no changes to GHC's source code to use. + + Plugins cannot optimize/inspect C--, nor can they implement things like parser/front-end modifications like GCC. If you feel strongly that any of these restrictions are too onerous, please give the GHC team a shout. + + + Using compiler plugins + + Plugins can be specified on the command line with the option -fplugin=module where module is a module in a registered package that exports a plugin. Arguments can be given to plugins with the command line option -fplugin-opt=module:args, where args are arguments interpreted by the plugin provided by module. + + As an example, in order to load the plugin exported by Foo.Plugin in the package foo-ghc-plugin, and give it the parameter "baz", we would invoke GHC like this: + + +$ ghc -fplugin Foo.Plugin -fplugin-opt Foo.Plugin:baz Test.hs +[1 of 1] Compiling Main ( Test.hs, Test.o ) +Loading package ghc-prim ... linking ... done. +Loading package integer-gmp ... linking ... done. +Loading package base ... linking ... done. +Loading package ffi-1.0 ... linking ... done. +Loading package foo-ghc-plugin-0.1 ... linking ... done. +... +Linking Test ... +$ + + + Since plugins are exported by registered packages, it's safe to put dependencies on them in cabal for example, and specify plugin arguments to GHC through the ghc-options field. + + + + Writing compiler plugins + + Plugins are modules that export at least a single identifier, plugin, of type GhcPlugins.Plugin. All plugins should import GhcPlugins as it defines the interface to the compilation pipeline. + + A Plugin effectively holds a function which installs a compilation pass into the compiler pipeline. By default there is the empty plugin which does nothing, GhcPlugins.defaultPlugin, which you should override with record syntax to specify your installation function. Since the exact fields of the Plugin type are open to change, this is the best way to ensure your plugins will continue to work in the future with minimal interface impact. + + Plugin exports a field, installCoreToDos which is a function of type [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]. A CommandLineOption is effectively just String, and a CoreToDo is basically a function of type Core -> Core. A CoreToDo gives your pass a name and runs it over every compiled module when you invoke GHC. + + As a quick example, here is a simple plugin that just does nothing and just returns the original compilation pipeline, unmodified, and says 'Hello': + + +module DoNothing.Plugin (plugin) where +import GhcPlugins + +plugin :: Plugin +plugin = defaultPlugin { + installCoreToDos = install + } + +install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] +install _ todo = do + reinitializeGlobals + putMsgS "Hello!" + return todo + + + Provided you compiled this plugin and registered it in a package (with cabal for instance,) you can then use it by just specifying -fplugin=DoNothing.Plugin on the command line, and during the compilation you should see GHC say 'Hello'. + + Note carefully the reinitializeGlobals call at the beginning of the installation function. Due to bugs in the windows linker dealing with libghc, this call is necessary to properly ensure compiler plugins have the same global state as GHC at the time of invocation. Without reinitializeGlobals, compiler plugins can crash at runtime because they may require state that hasn't otherwise been initialized. + + In the future, when the linking bugs are fixed, reinitializeGlobals will be deprecated with a warning, and changed to do nothing. + + <literal>CoreToDo</literal> in more detail + + CoreToDo is effectively a data type that describes all the kinds of optimization passes GHC does on Core. There are passes for simplification, CSE, vectorisation, etc. There is a specific case for plugins, CoreDoPluginPass :: String -> PluginPass -> CoreToDo which should be what you always use when inserting your own pass into the pipeline. The first parameter is the name of the plugin, and the second is the pass you wish to insert. + + CoreM is a monad that all of the Core optimizations live and operate inside of. + + A plugin's installation function (install in the above example) takes a list of CoreToDos and returns a list of CoreToDo. Before GHC begins compiling modules, it enumerates all the needed plugins you tell it to load, and runs all of their installation functions, initially on a list of passes that GHC specifies itself. After doing this for every plugin, the final list of passes is given to the optimizer, and are run by simply going over the list in order. + + You should be careful with your installation function, because the list of passes you give back isn't questioned or double checked by GHC at the time of this writing. An installation function like the following: + + +install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] +install _ _ = return [] + + + is certainly valid, but also certainly not what anyone really wants. + + + + Manipulating bindings + + In the last section we saw that besides a name, a CoreDoPluginPass takes a pass of type PluginPass. A PluginPass is a synonym for (ModGuts -> CoreM ModGuts). ModGuts is a type that represents the one module being compiled by GHC at any given time. + + A ModGuts holds all of the module's top level bindings which we can examine. These bindings are of type CoreBind and effectively represent the binding of a name to body of code. Top-level module bindings are part of a ModGuts in the field mg_binds. Implementing a pass that manipulates the top level bindings merely needs to iterate over this field, and return a new ModGuts with an updated mg_binds field. Because this is such a common case, there is a function provided named bindsOnlyPass which lifts a function of type ([CoreBind] -> CoreM [CoreBind]) to type (ModGuts -> CoreM ModGuts). + + Continuing with our example from the last section, we can write a simple plugin that just prints out the name of all the non-recursive bindings in a module it compiles: + + +module SayNames.Plugin (plugin) where +import GhcPlugins + +plugin :: Plugin +plugin = defaultPlugin { + installCoreToDos = install + } + +install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] +install _ todo = do + reinitializeGlobals + return (CoreDoPluginPass "Say name" pass : todo) + +pass :: ModGuts -> CoreM ModGuts +pass = bindsOnlyPass (mapM printBind) + where printBind :: CoreBind -> CoreM CoreBind + printBind bndr@(NonRec b _) = do + putMsgS $ "Non-recursive binding named " ++ showSDoc (ppr b) + return bndr + printBind bndr = return bndr + + + + + Using Annotations + + Previously we discussed annotation pragmas (), which we mentioned could be used to give compiler plugins extra guidance or information. Annotations for a module can be retrieved by a plugin, but you must go through the modules ModGuts in order to get it. Because annotations can be arbitrary instances of Data and Typeable, you need to give a type annotation specifying the proper type of data to retrieve from the interface file, and you need to make sure the annotation type used by your users is the same one your plugin uses. For this reason, we advise distributing annotations as part of the package which also provides compiler plugins if possible. + + To get the annotations of a single binder, you can use `getAnnotations` and specify the proper type. Here's an example that will print out the name of any top-level non-recursive binding with the SomeAnn annotation: + + +{-# LANGUAGE DeriveDataTypeable #-} +module SayAnnNames.Plugin (plugin, SomeAnn) where +import GhcPlugins +import Control.Monad (when) +import Data.Data +import Data.Typeable + +data SomeAnn = SomeAnn deriving (Data, Typeable) + +plugin :: Plugin +plugin = defaultPlugin { + installCoreToDos = install + } + +install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo] +install _ todo = do + reinitializeGlobals + return (CoreDoPluginPass "Say name" pass : todo) + +pass :: ModGuts -> CoreM ModGuts +pass g = mapM_ (printAnn g) (mg_binds g) >> return g + where printAnn :: ModGuts -> CoreBind -> CoreM CoreBind + printAnn guts bndr@(NonRec b _) = do + anns <- annotationsOn guts b :: CoreM [SomeAnn] + when (not $ null anns) $ putMsgS $ "Annotated binding found: " ++ showSDoc (ppr b) + return bndr + printAnn _ bndr = return bndr + +annotationsOn :: Data a => ModGuts -> CoreBndr -> CoreM [a] +annotationsOn guts bndr = do + anns <- getAnnotations deserializeWithData guts + return $ lookupWithDefaultUFM anns [] (varUnique bndr) + + + Please see the GHC API documentation for more about how to use internal APIs, etc. + + + + + + + + diff -Nru ghc-7.0.3/docs/users_guide/ffi-chap.xml ghc-7.2.1/docs/users_guide/ffi-chap.xml --- ghc-7.0.3/docs/users_guide/ffi-chap.xml 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/docs/users_guide/ffi-chap.xml 2011-08-07 17:10:05.000000000 +0000 @@ -6,10 +6,10 @@ Foreign function interface (FFI) - GHC (mostly) conforms to the Haskell 98 Foreign Function Interface - Addendum 1.0, whose definition is available from http://www.haskell.org/. + GHC (mostly) conforms to the Haskell Foreign Function Interface, + whose definition is part of the Haskell Report on http://www.haskell.org/. - To enable FFI support in GHC, give the + FFI support is enabled by default, but can be enabled or disabled explicitly with the flag. GHC implements a number of GHC-specific extensions to the FFI @@ -51,7 +51,7 @@ calling arbitrary IO procedures in some part of the program.) The Haskell FFI already specifies that arguments and results of -foreign imports and exports will be automatically unwrapped if they are +foreign imports and exports will be automatically unwrapped if they are newtypes (Section 3.2 of the FFI addendum). GHC extends the FFI by automatically unwrapping any newtypes that wrap the IO monad itself. More precisely, wherever the FFI specification requires an IO type, GHC will @@ -78,6 +78,88 @@ details see the GHC developer wiki. + + + Interruptible foreign calls + + This concerns the interaction of foreign calls + with Control.Concurrent.throwTo. + Normally when the target of a throwTo is + involved in a foreign call, the exception is not raised + until the call returns, and in the meantime the caller is + blocked. This can result in unresponsiveness, which is + particularly undesirable in the case of user interrupt + (e.g. Control-C). The default behaviour when a Control-C + signal is received (SIGINT on Unix) is to raise + the UserInterrupt exception in the main + thread; if the main thread is blocked in a foreign call at + the time, then the program will not respond to the user + interrupt. + + + + The problem is that it is not possible in general to + interrupt a foreign call safely. However, GHC does provide + a way to interrupt blocking system calls which works for + most system calls on both Unix and Windows. When the + InterruptibleFFI extension is enabled, + a foreign call + can be annotated with interruptible instead + of safe or unsafe: + + +foreign import ccall interruptible + "sleep" :: CUint -> IO CUint + + + interruptible behaves exactly as + safe, except that when + a throwTo is directed at a thread in an + interruptible foreign call, an OS-specific mechanism will be + used to attempt to cause the foreign call to return: + + + + Unix systems + + + The thread making the foreign call is sent + a SIGPIPE signal + using pthread_kill(). This is + usually enough to cause a blocking system call to + return with EINTR (GHC by default + installs an empty signal handler + for SIGPIPE, to override the + default behaviour which is to terminate the process + immediately). + + + + + Windows systems + + + [Vista and later only] The RTS calls the Win32 + function CancelSynchronousIO, + which will cause a blocking I/O operation to return + with the + error ERROR_OPERATION_ABORTED. + + + + + + If the system call is successfully interrupted, it will + return to Haskell whereupon the exception can be raised. Be + especially careful when + using interruptible that the caller of + the foreign function is prepared to deal with the + consequences of the call being interrupted; on Unix it is + good practice to check for EINTR always, + but on Windows it is not typically necessary to + handle ERROR_OPERATION_ABORTED. + + @@ -94,7 +176,7 @@ When GHC compiles a module (say M.hs) - which uses foreign export or + which uses foreign export or foreign import "wrapper", it generates two additional files, M_stub.c and M_stub.h. GHC will automatically compile @@ -143,7 +225,7 @@ ––make, as GHC will automatically link in the correct bits). - + Using your own <literal>main()</literal> Normally, GHC's runtime system provides a @@ -165,18 +247,11 @@ #include "foo_stub.h" #endif -#ifdef __GLASGOW_HASKELL__ -extern void __stginit_Foo ( void ); -#endif - int main(int argc, char *argv[]) { int i; hs_init(&argc, &argv); -#ifdef __GLASGOW_HASKELL__ - hs_add_root(__stginit_Foo); -#endif for (i = 0; i < 5; i++) { printf("%d\n", foo(2500)); @@ -203,26 +278,6 @@ (i.e. those arguments between +RTS...-RTS). - Next, we call - hs_add_rooths_add_root - , a GHC-specific interface which is required to - initialise the Haskell modules in the program. The argument - to hs_add_root should be the name of the - initialization function for the "root" module in your program - - in other words, the module which directly or indirectly - imports all the other Haskell modules in the program. In a - standalone Haskell program the root module is normally - Main, but when you are using Haskell code - from a library it may not be. If your program has multiple - root modules, then you can call - hs_add_root multiple times, one for each - root. The name of the initialization function for module - M is - __stginit_M, and - it may be declared as an external function symbol as in the - code above. Note that the symbol name should be transformed - according to the Z-encoding: - @@ -300,9 +355,6 @@ // Initialize Haskell runtime hs_init(&argc, &argv); - // Tell Haskell about all root modules - hs_add_root(__stginit_Foo); - // do any other initialization here and // return false if there was a problem return HS_BOOL_TRUE; @@ -314,14 +366,14 @@ The initialisation routine, mylib_init, calls - hs_init() and hs_add_root() as + hs_init() as normal to initialise the Haskell runtime, and the corresponding deinitialisation function mylib_end() calls hs_exit() to shut down the runtime. - + Using header files @@ -346,7 +398,7 @@ available when compiling an inlined version of a foreign call, so the compiler is free to inline foreign calls in any context. - + The -#include option is now deprecated, and the include-files field in a Cabal package specification is ignored. @@ -431,17 +483,17 @@ - + Multi-threading and the FFI - + In order to use the FFI in a multi-threaded setting, you must use the option (see ). - + Foreign imports and multi-threading - + When you call a foreign imported function that is annotated as safe (the default), and the program was linked @@ -450,7 +502,7 @@ program was linked without , then the other Haskell threads will be blocked until the call returns. - + This means that if you need to make a foreign call to a function that takes a long time or blocks indefinitely, then you should mark it safe and @@ -476,12 +528,21 @@ threads, but there may be an arbitrary number of foreign calls in progress at any one time, regardless of the +RTS -N value. + + If a call is annotated as interruptible + and the program was multithreaded, the call may be + interrupted in the event that the Haskell thread receives an + exception. The mechanism by which the interrupt occurs + is platform dependent, but is intended to cause blocking + system calls to return immediately with an interrupted error + code. The underlying operating system thread is not to be + destroyed. See for more details. The relationship between Haskell threads and OS threads - + Normally there is no fixed relationship between Haskell threads and OS threads. This means that when you make a foreign call, that call may take place in an unspecified OS @@ -501,17 +562,16 @@ for the Control.Concurrent module. - + Foreign exports and multi-threading - + When the program is linked with , then you may invoke foreign exported functions from multiple OS threads concurrently. The runtime system must be initialised as usual by - calling hs_init() - and hs_add_root, and these calls must + calling hs_init(), and this call must complete before invoking any foreign exported functions. @@ -554,7 +614,7 @@ isn't necessary to ensure that the threads have exited first. (Unofficially, if you want to use this fast and loose version of hs_exit(), then call - shutdownHaskellAndExit() instead). + shutdownHaskellAndExit() instead). diff -Nru ghc-7.0.3/docs/users_guide/flags.xml ghc-7.2.1/docs/users_guide/flags.xml --- ghc-7.0.3/docs/users_guide/flags.xml 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/docs/users_guide/flags.xml 2011-08-07 17:10:05.000000000 +0000 @@ -35,13 +35,7 @@ mode - - - - do a dry run - dynamic - - - - + verbose mode (equivalent to ) dynamic @@ -114,7 +108,7 @@ Which phases to run - + @@ -165,7 +159,7 @@ Alternative modes of operation - + @@ -214,7 +208,7 @@ Redirecting output - + @@ -289,9 +283,9 @@ Keeping intermediate files - + - + @@ -325,13 +319,6 @@ - - or - - retain intermediate .raw_s files - dynamic - - - - retain all intermediate temporary files dynamic @@ -344,7 +331,7 @@ Temporary files - + @@ -447,7 +434,7 @@ - + Recompilation checking @@ -479,7 +466,7 @@ Interactive-mode options - + @@ -500,6 +487,12 @@ - + + Load the given additional .ghci file + static + - + + Enable reading of .ghci files static @@ -522,7 +515,7 @@ Enable usage of Show instances in :print dynamic - + Turn on printing of binding results in GHCi @@ -567,7 +560,7 @@ P Compile to be part of package P - dynamic + static - @@ -612,6 +605,26 @@ dynamic - + + P + Expose package P and set it to be + trusted + static/:set + - + + + P + Expose package P and set it to be + distrusted + static/:set + - + + + + Distrust all packages by default + static/:set + - + @@ -620,7 +633,7 @@ Language options - Language options can be enabled either by a command-line option + Language options can be enabled either by a command-line option , or by a {-# LANGUAGE blah #-} pragma in the file itself. See @@ -649,7 +662,7 @@ - Enable incoherent instances. + Enable incoherent instances. Implies dynamic @@ -675,7 +688,7 @@ - Enable record + Enable record field disambiguation dynamic @@ -689,7 +702,9 @@ - Enable generic classes + Deprecated, does nothing. No longer enables generic classes. + See also GHC's support for + generic programming. dynamic @@ -763,6 +778,13 @@ + + Enable generalised algebraic data type syntax. + + dynamic + + + Enable type families. dynamic @@ -784,7 +806,7 @@ - Enable Template Haskell. + Enable Template Haskell. No longer implied by . dynamic @@ -832,14 +854,7 @@ - - Enable new - qualified operator syntax - dynamic - - - - + Enable explicit universal quantification. Implied by , , @@ -905,6 +920,12 @@ dynamic + + + Enable monad comprehensions. + dynamic + + Enable unlifted FFI types. @@ -912,6 +933,12 @@ + + Enable interruptible FFI. + dynamic + + + Enable liberalised type synonyms. dynamic @@ -978,6 +1005,12 @@ + + Enable deriving for the Generic class. + dynamic + + + Enable newtype deriving. dynamic @@ -997,8 +1030,9 @@ - Enable flexible instances. - dynamic + Enable flexible instances. + Implies + dynamic @@ -1008,6 +1042,12 @@ + + Enable default signatures. + dynamic + + + Enable multi parameter type classes. dynamic @@ -1025,6 +1065,30 @@ dynamic + + + Enable the Safe Haskell Safe mode. + dynamic + + + + + Enable the Safe Haskell Trustworthy mode. + dynamic + + + + + Enable the Safe Haskell Safe Language. + dynamic + + + + + Enable Safe Imports. + dynamic + + @@ -1032,7 +1096,7 @@ Warnings - + @@ -1114,6 +1178,14 @@ + + warn about uses of Prelude numeric conversions that are probably + the identity (and hence could be omitted) + dynamic + + + + warn when the Prelude is implicitly imported dynamic @@ -1128,6 +1200,13 @@ + + warn when a pattern match in a lambda expression or pattern binding could fail + dynamic + + + + warn when a record update could fail dynamic @@ -1150,7 +1229,7 @@ - warn when an import declaration does not explicitly + warn when an import declaration does not explicitly list all the names brought into scope dynamic @@ -1171,6 +1250,13 @@ + + warn about polymorphic local bindings without signatures + dynamic + + + + warn when names are shadowed dynamic @@ -1284,7 +1370,7 @@ - + Individual optimisations @@ -1317,13 +1403,6 @@ - - Share specialisations of overloaded functions (default) - dynamic - - - - Enable eta-reduction. Implied by . dynamic @@ -1464,7 +1543,7 @@ =n - Set to n (default: 3) the maximum number of + Set to n (default: 3) the maximum number of specialisations that will be created for any one function by the SpecConstr transformation static @@ -1535,6 +1614,13 @@ + + Turn off the coercion optimiser + static + - + + + Turn on eager blackholing dynamic @@ -1547,7 +1633,7 @@ Profiling options - + @@ -1600,7 +1686,7 @@ Program coverage options - + @@ -1727,13 +1813,7 @@ Use the native code generator dynamic - -fvia-C - - - - Compile via C - dynamic - -fasm + -fllvm @@ -1935,6 +2015,40 @@ + Plugin options + + + + + + + + Flag + Description + Static/Dynamic + Reverse + + + + + =module + Load a plugin exported by a given module + static + - + + + =module:args + Give arguments to a plugin module; module must be specified with + static + - + + + + + + + + Replacing phases @@ -1982,12 +2096,6 @@ - cmd - Use cmd as the mangler - dynamic - - - - cmd Use cmd as the splitter dynamic @@ -2131,7 +2239,7 @@ Platform-specific options - + @@ -2164,7 +2272,7 @@ - + External core file options @@ -2216,6 +2324,12 @@ - + + Dump to files instead of stdout + dynamic + - + + Dump assembly dynamic @@ -2234,6 +2348,13 @@ - + + Print a one-line summary of the size of the Core program + at the end of the optimisation pipeline + dynamic + - + + Dump output from CPR analysis dynamic @@ -2318,12 +2439,30 @@ - - - Dump rules + + Dump rule firing info dynamic - + + Dump detailed rule firing info + dynamic + - + + + + Dump rules + dynamic + - + + + + Dump vectoriser input and output + dynamic + - + + Dump final simplifier output dynamic @@ -2389,12 +2528,18 @@ dynamic - - - - Trace typechecker - dynamic - - - + + + Trace typechecker + dynamic + - + + + + Trace vectoriser + dynamic + - + Trace renamer @@ -2426,32 +2571,68 @@ - + + 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 - @@ -2507,7 +2688,7 @@ - + Misc compiler options @@ -2547,14 +2728,8 @@ - - - Turn off assembly mangling (use instead) - dynamic - - - - - Turn off the GHCi sandbox. Means computations are run in teh main thread, rather than a forked thread. + Turn off the GHCi sandbox. Means computations are run in the main thread, rather than a forked thread. dynamic - diff -Nru ghc-7.0.3/docs/users_guide/ghci.xml ghc-7.2.1/docs/users_guide/ghci.xml --- ghc-7.0.3/docs/users_guide/ghci.xml 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/docs/users_guide/ghci.xml 2011-08-07 17:10:05.000000000 +0000 @@ -4,7 +4,7 @@ GHCi interpreterGHCi interactiveGHCi - + GHCi The ‘i’ stands for “Interactive” @@ -33,7 +33,7 @@ Loading package integer-gmp ... linking ... done. Loading package base ... linking ... done. Loading package ffi-1.0 ... linking ... done. -Prelude> +Prelude> There may be a short pause while GHCi loads the prelude and @@ -54,12 +54,56 @@ 3 Prelude> let x = 42 in x / 9 4.666666666666667 -Prelude> +Prelude> GHCi interprets the whole line as an expression to evaluate. - The expression may not span several lines - as soon as you press - enter, GHCi will attempt to evaluate it. + The expression may not span several lines - as soon as you press enter, + GHCi will attempt to evaluate it. + + GHCi also has a multiline mode, + :set +m, + which is terminated by an empty line: + + +Prelude> :set +m +Prelude> let x = 42 in x / 9 +Prelude| +4.666666666666667 +Prelude> + + + In Haskell, a let expression is followed + by in. However, in GHCi, since the expression + can also be interpreted in the IO monad, + a let binding with no accompanying + in statement can be signalled by an empty line, + as in the above example. + + Multiline mode is useful when entering monadic + do statements: + + +Control.Monad.State> flip evalStateT 0 $ do +Control.Monad.State| i <- get +Control.Monad.State| lift $ do +Control.Monad.State| putStrLn "Hello World!" +Control.Monad.State| print i +Control.Monad.State| +"Hello World!" +0 +Control.Monad.State> + + + During a multiline interaction, the user can interrupt and + return to the top-level prompt. + + +Prelude> do +Prelude| putStrLn "Hello, World!" +Prelude| ^C +Prelude> + @@ -130,7 +174,7 @@ Modules vs. filenames modulesand filenames filenamesof modules - + Question: How does GHC find the filename which contains module M? Answer: it looks for the file M.hs, or @@ -235,7 +279,7 @@ because the source and everything it depends on is unchanged since the last compilation. - At any time you can use the command + At any time you can use the command :show modules to get a list of the modules currently loaded into GHCi: @@ -258,7 +302,7 @@ *Main> :reload Compiling D ( D.hs, interpreted ) Ok, modules loaded: A, B, C, D. -*Main> +*Main> Note that module D was compiled, but in this instance @@ -385,7 +429,7 @@ Using <literal>do-</literal>notation at the prompt do-notationin GHCi statementsin GHCi - + GHCi actually accepts statements rather than just expressions at the prompt. This means you can bind values and functions to names, and use them in future @@ -410,10 +454,10 @@ it as we did above. If is set then - GHCi will print the result of a statement if and only if: + GHCi will print the result of a statement if and only if: - The statement is not a binding, or it is a monadic binding + The statement is not a binding, or it is a monadic binding (p <- e) that binds exactly one variable. @@ -457,9 +501,9 @@ 3 Prelude> - However, this quickly gets tedious when defining functions + However, this quickly gets tedious when defining functions with multiple clauses, or groups of mutually recursive functions, - because the complete definition has to be given on a single line, + because the complete definition has to be given on a single line, using explicit braces and semicolons instead of layout: Prelude> let { f op n [] = n ; f op n (h:t) = h `op` f op n t } @@ -481,9 +525,9 @@ Such multiline commands can be used with any GHCi command, and the lines between :{ and - :} are simply merged into a single line for + :} are simply merged into a single line for interpretation. That implies that each such group must form a single - valid command when merged, and that no layout rule is used. + valid command when merged, and that no layout rule is used. The main purpose of multiline commands is not to replace module loading but to make definitions in .ghci-files (see ) more readable and maintainable. @@ -527,7 +571,7 @@ - What's really in scope at the prompt? + What's really in scope at the prompt? When you type an expression at the prompt, what identifiers and types are in scope? GHCi provides a flexible @@ -593,7 +637,7 @@ haskell import syntax as well, but this does not support * forms). - :module can also be shortened to + :module can also be shortened to :m. The full syntax of the :module command is: @@ -741,13 +785,13 @@ - + The <literal>it</literal> variable it - + Whenever an expression (or a non-binding statement, to be precise) is typed at the prompt, GHCi implicitly binds its value to the variable it. For example: @@ -760,7 +804,7 @@ What actually happens is that GHCi typechecks the expression, and if it doesn't have an IO type, then it transforms it as follows: an expression - e turns into + e turns into let it = e; print it @@ -831,7 +875,7 @@ rules (Section 4.3.4 of the Haskell 2010 Report) as follows. The standard rules take each group of constraints (C1 a, C2 a, ..., Cn a) for each type variable a, and defaults the - type variable if + type variable if @@ -929,7 +973,7 @@ The ability to set a breakpoint on a function definition or expression in the program. When the function - is called, or the expression evaluated, GHCi suspends + is called, or the expression evaluated, GHCi suspends execution and returns to the prompt, where you can inspect the values of local variables before continuing with the execution. @@ -955,7 +999,7 @@ - + There is currently no support for obtaining a “stack trace”, but the tracing and history features provide a useful second-best, which will often be enough to establish the @@ -963,14 +1007,14 @@ automatically when an exception is thrown, even if it is thrown from within compiled code (see ). - + Breakpoints and inspecting variables - + Let's use quicksort as a running example. Here's the code: -qsort [] = [] +qsort [] = [] qsort (a:as) = qsort left ++ [a] ++ qsort right where (left,right) = (filter (<=a) as, filter (>a) as) @@ -984,7 +1028,7 @@ [1 of 1] Compiling Main ( qsort.hs, interpreted ) Ok, modules loaded: Main. *Main> - + Now, let's set a breakpoint on the right-hand-side of the second equation of qsort: @@ -994,12 +1038,12 @@ Breakpoint 0 activated at qsort.hs:2:15-46 *Main> - + The command :break 2 sets a breakpoint on line 2 of the most recently-loaded module, in this case qsort.hs. Specifically, it picks the leftmost complete subexpression on that line on which to set the - breakpoint, which in this case is the expression + breakpoint, which in this case is the expression (qsort left ++ [a] ++ qsort right). Now, we run the program: @@ -1020,8 +1064,8 @@ location, we can use the :list command: -[qsort.hs:2:15-46] *Main> :list -1 qsort [] = [] +[qsort.hs:2:15-46] *Main> :list +1 qsort [] = [] 2 qsort (a:as) = qsort left ++ [a] ++ qsort right 3 where (left,right) = (filter (<=a) as, filter (>a) as) @@ -1094,7 +1138,7 @@ The flag -fprint-evld-with-show instructs :print to reuse available Show instances when possible. This happens - only when the contents of the variable being inspected + only when the contents of the variable being inspected are completely evaluated. @@ -1130,7 +1174,7 @@ [qsort.hs:2:15-46] *Main> a 8 - + You might find it useful to use Haskell's seq function to evaluate individual thunks rather than evaluating the whole expression with :force. @@ -1161,7 +1205,7 @@ a :: a left :: [a] right :: [a] -[qsort.hs:2:15-46] *Main> +[qsort.hs:2:15-46] *Main> The execution continued at the point it previously stopped, and has @@ -1191,13 +1235,13 @@ :break line :break line column :break module line - :break module line column + :break module line column When a breakpoint is set on a particular line, GHCi sets the breakpoint on the leftmost subexpression that begins and ends on that line. If two - complete subexpressions start at the same + complete subexpressions start at the same column, the longest one is picked. If there is no complete subexpression on the line, then the leftmost expression starting on the line is picked, and failing that the rightmost expression that @@ -1211,7 +1255,7 @@ and doesn't match others. The best advice is to avoid tab characters in your source code altogether (see in ). + />). If the module is omitted, then the most recently-loaded module is used. @@ -1245,7 +1289,7 @@ *Main> :delete 0 *Main> :show breaks [1] Main qsort.hs:2:15-46 - + To delete all breakpoints at once, use :delete *. @@ -1257,7 +1301,7 @@ Single-stepping is a great way to visualise the execution of your program, and it is also a useful tool for identifying the source of a - bug. GHCi offers two variants of stepping. Use + bug. GHCi offers two variants of stepping. Use :step to enable all the breakpoints in the program, and execute until the next breakpoint is reached. Use :steplocal to limit the set @@ -1276,7 +1320,7 @@ expr begins the evaluation of expr in single-stepping mode. If expr is omitted, then it single-steps from - the current breakpoint. :stepover + the current breakpoint. :stepover works similarly. The :list command is particularly useful when @@ -1284,9 +1328,9 @@ [qsort.hs:5:7-47] *Main> :list -4 +4 5 main = print (qsort [8, 4, 0, 3, 1, 23, 11, 18]) -6 +6 [qsort.hs:5:7-47] *Main> @@ -1299,9 +1343,9 @@ [qsort.hs:5:7-47] *Main> :step Stopped at qsort.hs:5:14-46 _result :: [Integer] -4 +4 5 main = print (qsort [8, 4, 0, 3, 1, 23, 11, 18]) -6 +6 [qsort.hs:5:14-46] *Main> @@ -1395,13 +1439,13 @@ *Main> :list qsort -1 qsort [] = [] +1 qsort [] = [] 2 qsort (a:as) = qsort left ++ [a] ++ qsort right 3 where (left,right) = (filter (<=a) as, filter (>a) as) -4 +4 *Main> :b 1 Breakpoint 1 activated at qsort.hs:1:11-12 -*Main> +*Main> and then run a small qsort with @@ -1446,7 +1490,7 @@ _result :: [a] as :: [a] a :: a -[-1: qsort.hs:3:24-38] *Main> +[-1: qsort.hs:3:24-38] *Main> Note that the local variables at each step in the history have been @@ -1488,10 +1532,10 @@ we can't set a breakpoint on it directly. For this reason, GHCi provides the flags -fbreak-on-exception which causes the evaluator to stop when an exception is thrown, and - -fbreak-on-error, which works similarly but stops only on - uncaught exceptions. When stopping at an exception, GHCi will act + -fbreak-on-error, which works similarly but stops only on + uncaught exceptions. When stopping at an exception, GHCi will act just as it does when a breakpoint is hit, with the deviation that it - will not show you any source code location. Due to this, these + will not show you any source code location. Due to this, these commands are only really useful in conjunction with :trace, in order to log the steps leading up to the exception. For example: @@ -1531,15 +1575,15 @@ Example: inspecting functions - It is possible to use the debugger to examine function values. + It is possible to use the debugger to examine function values. When we are at a breakpoint and a function is in scope, the debugger - cannot show - you the source code for it; however, it is possible to get some - information by applying it to some arguments and observing the result. + cannot show + you the source code for it; however, it is possible to get some + information by applying it to some arguments and observing the result. - The process is slightly complicated when the binding is polymorphic. + The process is slightly complicated when the binding is polymorphic. We show the process by means of an example. To keep things simple, we will use the well known map function: @@ -1563,9 +1607,9 @@ f :: a -> b xs :: [a] - GHCi tells us that, among other bindings, f is in scope. - However, its type is not fully known yet, - and thus it is not possible to apply it to any + GHCi tells us that, among other bindings, f is in scope. + However, its type is not fully known yet, + and thus it is not possible to apply it to any arguments. Nevertheless, observe that the type of its first argument is the same as the type of x, and its result type is shared with _result. @@ -1573,12 +1617,12 @@ As we demonstrated earlier (), the - debugger has some intelligence built-in to update the type of - f whenever the types of x or + debugger has some intelligence built-in to update the type of + f whenever the types of x or _result are discovered. So what we do in this scenario is - force x a bit, in order to recover both its type - and the argument part of f. + force x a bit, in order to recover both its type + and the argument part of f. *Main> seq x () *Main> :print x @@ -1587,7 +1631,7 @@ We can check now that as expected, the type of x - has been reconstructed, and with it the + has been reconstructed, and with it the type of f has been too: *Main> :t x @@ -1597,7 +1641,7 @@ From here, we can apply f to any argument of type Integer and observe - the results. + the results. let b = f 10 *Main> :t b @@ -1623,10 +1667,10 @@ *Main> map f [1..5] [Just 1, Just 2, Just 3, Just 4, Just 5] ]]> - In the first application of f, we had to do + In the first application of f, we had to do some more type reconstruction - in order to recover the result type of f. - But after that, we are free to use + in order to recover the result type of f. + But after that, we are free to use f normally. @@ -1647,7 +1691,7 @@ CAF at the prompt again. - Implicit parameters (see ) are only available + Implicit parameters (see ) are only available at the scope of a breakpoint if there is an explicit type signature. @@ -1695,7 +1739,7 @@ GHCi, version 6.8.1: http://www.haskell.org/ghc/ :? for help Loading package base ... linking ... done. Loading package readline-1.0 ... linking ... done. -Prelude> +Prelude> The following command works to load new packages into a @@ -1713,7 +1757,7 @@ Extra libraries librarieswith GHCi - + Extra libraries may be specified on the command line using the normal -llib option. (The term library here refers to @@ -1845,11 +1889,11 @@ modules from packages) only the non-* form of :browse is available. If the ! symbol is appended to the - command, data constructors and class methods will be + command, data constructors and class methods will be listed individually, otherwise, they will only be listed - in the context of their data type or class declaration. - The !-form also annotates the listing - with comments giving possible imports for each group of + in the context of their data type or class declaration. + The !-form also annotates the listing + with comments giving possible imports for each group of entries. Prelude> :browse! Data.Maybe @@ -1917,7 +1961,7 @@ - :continue + :continue :continue Continue the current evaluation, when stopped at a @@ -2023,7 +2067,7 @@ - :delete * | num ... + :delete * | num ... :delete @@ -2051,7 +2095,7 @@ - :etags + :etags See :ctags. @@ -2141,9 +2185,9 @@ the location of its definition in the source. For types and classes, GHCi also summarises instances that mention them. To avoid showing irrelevant information, an instance - is shown only if (a) its head mentions name, + is shown only if (a) its head mentions name, and (b) all the other things mentioned in the instance - are in scope (either qualified or otherwise) as a result of + are in scope (either qualified or otherwise) as a result of a :load or :module commands. @@ -2345,6 +2389,19 @@ + :script n + filename + :script + + + Executes the lines of a file as a series of GHCi commands. This command + is compatible with multiline statements as set by :set +m + + + + + + :set option... :set @@ -2524,7 +2581,7 @@ - :step [expr] + :step [expr] :step @@ -2627,6 +2684,18 @@ + +m + +m + + + Enable parsing of multiline commands. A multiline command + is prompted for when the current input line contains open layout + contexts. + + + + + +r +r CAFsin GHCi @@ -2640,7 +2709,7 @@ top-level expressions to be discarded after each evaluation (they are still retained during a single evaluation). - + This option may help if the evaluated top-level expressions are consuming large amounts of space, or if you need repeatable performance measurements. @@ -2688,7 +2757,7 @@ Prelude> :set -fglasgow-exts - + Any GHC command-line option that is designated as dynamic (see the table in ), may be set using @@ -2743,7 +2812,7 @@ defining useful macros. Placing a .ghci file in a directory with a Haskell project is a useful way to set certain project-wide options so you don't have to type them - everytime you start GHCi: eg. if your project uses GHC extensions + every time you start GHCi: eg. if your project uses GHC extensions and CPP, and has source files in three subdirectories A, B and C, you might put the following lines in .ghci: @@ -2767,7 +2836,7 @@ :def source readFile - With this macro defined in your .ghci + With this macro defined in your .ghci file, you can use :source file to read GHCi commands from file. You can find (and contribute!-) other suggestions for .ghci files on this Haskell @@ -2803,6 +2872,10 @@ + Additional .ghci files can be added + through the option. These are + loaded after the normal .ghci files. + @@ -2833,7 +2906,7 @@ FAQ and Things To Watch Out For - + The interpreter can't load modules with foreign export @@ -2922,8 +2995,8 @@ because this is normally what you want in an interpreter: output appears as it is generated. - - If you want line-buffered behaviour, as in GHC, you can + + If you want line-buffered behaviour, as in GHC, you can start your program thus: main = do { hSetBuffering stdout LineBuffering; ... } diff -Nru ghc-7.0.3/docs/users_guide/glasgow_exts.xml ghc-7.2.1/docs/users_guide/glasgow_exts.xml --- ghc-7.0.3/docs/users_guide/glasgow_exts.xml 2011-03-26 18:10:05.000000000 +0000 +++ ghc-7.2.1/docs/users_guide/glasgow_exts.xml 2011-08-07 17:10:05.000000000 +0000 @@ -3,8 +3,9 @@ language, GHC extensions, GHC As with all known Haskell systems, GHC implements some extensions to -the language. They are all enabled by options; by default GHC -understands only plain Haskell 98. +the language. They can all be enabled or disabled by commandline flags +or language pragmas. By default GHC understands the most recent Haskell +version it supports, plus a handful of extensions. @@ -39,13 +40,12 @@ The language option flags control what variation of the language are - permitted. Leaving out all of them gives you standard Haskell - 98. + permitted. Language options can be controlled in two ways: - Every language option can switched on by a command-line flag "" - (e.g. ), and switched off by the flag ""; + Every language option can switched on by a command-line flag "" + (e.g. ), and switched off by the flag ""; (e.g. ). Language options recognised by Cabal can also be enabled using the LANGUAGE pragma, @@ -55,11 +55,11 @@ The flag - is equivalent to enabling the following extensions: + is equivalent to enabling the following extensions: &what_glasgow_exts_does; - Enabling these options is the only + Enabling these options is the only effect of . - We are trying to move away from this portmanteau flag, + We are trying to move away from this portmanteau flag, and towards enabling features individually. @@ -77,8 +77,8 @@ unboxed version in any case. And if it isn't, we'd like to know about it. -All these primitive data types and operations are exported by the -library GHC.Prim, for which there is +All these primitive data types and operations are exported by the +library GHC.Prim, for which there is detailed online documentation. (This documentation is generated from the file compiler/prelude/primops.txt.pp.) @@ -89,10 +89,10 @@ names you need the extension (). -The primops make extensive use of unboxed types +The primops make extensive use of unboxed types and unboxed tuples, which we briefly summarise here. - + Unboxed types @@ -124,7 +124,7 @@ Primitive (unboxed) types cannot be defined in Haskell, and are therefore built into the language and compiler. Primitive types are always unlifted; that is, a value of a primitive type cannot be -bottom. We use the convention (but it is only a convention) +bottom. We use the convention (but it is only a convention) that primitive types, values, and operations have a # suffix (see ). For some primitive types we have special syntax for literals, also @@ -283,7 +283,7 @@ f x = let (# p,q #) = h x in ..body.. If the types of p and q are not unboxed, -the resulting binding is lazy like any other Haskell pattern binding. The +the resulting binding is lazy like any other Haskell pattern binding. The above example desugars like this: f x = let t = case h x o f{ (# p,q #) -> (p,q) @@ -302,7 +302,7 @@ Syntactic extensions - + Unicode syntax The language @@ -425,24 +425,24 @@ postfix modifier to identifiers. Thus, "x#" is a valid variable, and "T#" is a valid type constructor or data constructor. - The hash sign does not change sematics at all. We tend to use variable - names ending in "#" for unboxed values or types (e.g. Int#), - but there is no requirement to do so; they are just plain ordinary variables. + The hash sign does not change semantics at all. We tend to use variable + names ending in "#" for unboxed values or types (e.g. Int#), + but there is no requirement to do so; they are just plain ordinary variables. Nor does the extension bring anything into scope. - For example, to bring Int# into scope you must - import GHC.Prim (see ); + For example, to bring Int# into scope you must + import GHC.Prim (see ); the extension then allows you to refer to the Int# that is now in scope. The also enables some new forms of literals (see ): - + 'x'# has type Char# "foo"# has type Addr# 3# has type Int#. In general, - any Haskell 98 integer lexeme followed by a # is an Int# literal, e.g. + any Haskell integer lexeme followed by a # is an Int# literal, e.g. -0x3A# as well as 32#. 3## has type Word#. In general, - any non-negative Haskell 98 integer lexeme followed by ## + any non-negative Haskell integer lexeme followed by ## is a Word#. 3.2# has type Float#. 3.2## has type Double# @@ -450,43 +450,6 @@ - - New qualified operator syntax - - A new syntax for referencing qualified operators is - planned to be introduced by Haskell', and is enabled in GHC - with - the - option. In the new syntax, the prefix form of a qualified - operator is - written module.(symbol) - (in Haskell 98 this would - be (module.symbol)), - and the infix form is - written `module.(symbol)` - (in Haskell 98 this would - be `module.symbol`. - For example: - - add x y = Prelude.(+) x y - subtract y = (`Prelude.(-)` y) - - The new form of qualified operators is intended to regularise - the syntax by eliminating odd cases - like Prelude... For example, - when NewQualifiedOperators is on, it is possible to - write the enumerated sequence [Monday..] - without spaces, whereas in Haskell 98 this would be a - reference to the operator ‘.‘ - from module Monday. - - When is on, the old Haskell - 98 syntax for qualified operators is not accepted, so this - option may cause existing Haskell 98 code to break. - - - - @@ -567,7 +530,7 @@ -The auxiliary functions are +The auxiliary functions are @@ -612,10 +575,10 @@ of pattern-matching, guarded equations as case expressions; that is precisely what the compiler does when compiling equations! The reason that Haskell provides guarded equations is because they allow us to write down -the cases we want to consider, one at a time, independently of each other. +the cases we want to consider, one at a time, independently of each other. This structure is hidden in the case version. Two of the right-hand sides are really the same (fail), and the whole expression -tends to become more and more indented. +tends to become more and more indented. @@ -631,9 +594,9 @@ -The semantics should be clear enough. The qualifiers are matched in order. +The semantics should be clear enough. The qualifiers are matched in order. For a <- qualifier, which I call a pattern guard, the -right hand side is evaluated and matched against the pattern on the left. +right hand side is evaluated and matched against the pattern on the left. If the match fails then the whole guard fails and the next equation is tried. If it succeeds, then the appropriate binding takes place, and the next qualifier is matched, in the augmented environment. Unlike list @@ -683,7 +646,7 @@ type Typ - + data TypView = Unit | Arrow Typ Typ @@ -695,7 +658,7 @@ The representation of Typ is held abstract, permitting implementations to use a fancy representation (e.g., hash-consing to manage sharing). -Without view patterns, using this signature a little inconvenient: +Without view patterns, using this signature a little inconvenient: size :: Typ -> Integer size t = case view t of @@ -710,7 +673,7 @@ View patterns permit calling the view function inside the pattern and -matching against the result: +matching against the result: size (view -> Unit) = 1 size (view -> Arrow t1 t2) = size t1 + size t2 @@ -753,7 +716,7 @@ -More precisely, the scoping rules are: +More precisely, the scoping rules are: @@ -771,7 +734,7 @@ example f (f -> 4) = True That is, the scoping is the same as it would be if the curried arguments -were collected into a tuple. +were collected into a tuple. @@ -787,7 +750,7 @@ (y -> x) = e2 } in x -(For some amplification on this design choice see +(For some amplification on this design choice see Trac #4061.) @@ -808,8 +771,8 @@ Haskell 98 Report, add the following: -case v of { (e -> p) -> e1 ; _ -> e2 } - = +case v of { (e -> p) -> e1 ; _ -> e2 } + = case (e v) of { p -> e1 ; _ -> e2 } That is, to match a variable v against a pattern @@ -818,7 +781,7 @@ ), evaluate ( exp v ) and match the result against -pat. +pat. Efficiency: When the same view function is applied in @@ -876,7 +839,7 @@ The do-notation of Haskell 98 does not allow recursive bindings, -that is, the variables bound in a do-expression are visible only in the textually following +that is, the variables bound in a do-expression are visible only in the textually following code block. Compare this to a let-expression, where bound variables are visible in the entire binding group. It turns out that several applications can benefit from recursive bindings in the do-notation. The flag provides the necessary syntactic support. @@ -894,7 +857,7 @@ The background and motivation for recursive do-notation is described in A recursive do for Haskell, by Levent Erkok, John Launchbury, -Haskell Workshop 2002, pages: 29-37. Pittsburgh, Pennsylvania. +Haskell Workshop 2002, pages: 29-37. Pittsburgh, Pennsylvania. The theory behind monadic value recursion is explained further in Erkok's thesis Value Recursion in Monadic Computations. However, note that GHC uses a different syntax than the one described in these documents. @@ -909,38 +872,38 @@ producing a single statement. Similar to a let -statement, the variables bound in the rec are +statement, the variables bound in the rec are visible throughout the rec group, and below it. For example, compare -do { a <- getChar do { a <- getChar - ; let { r1 = f a r2 ; rec { r1 <- f a r2 - ; r2 = g r1 } ; r2 <- g r1 } +do { a <- getChar do { a <- getChar + ; let { r1 = f a r2 ; rec { r1 <- f a r2 + ; r2 = g r1 } ; r2 <- g r1 } ; return (r1 ++ r2) } ; return (r1 ++ r2) } -In both cases, r1 and r2 are +In both cases, r1 and r2 are available both throughout the let or rec block, and in the statements that follow it. The difference is that let is non-monadic, -while rec is monadic. (In Haskell let is +while rec is monadic. (In Haskell let is really letrec, of course.) -The static and dynamic semantics of rec can be described as follows: +The static and dynamic semantics of rec can be described as follows: First, -similar to let-bindings, the rec is broken into +similar to let-bindings, the rec is broken into minimal recursive groups, a process known as segmentation. For example: rec { a <- getChar ===> a <- getChar ; b <- f a c rec { b <- f a c ; c <- f b a ; c <- f b a } - ; putChar c } putChar c + ; putChar c } putChar c The details of segmentation are described in Section 3.2 of A recursive do for Haskell. -Segmentation improves polymorphism, reduces the size of the recursive "knot", and, as the paper +Segmentation improves polymorphism, reduces the size of the recursive "knot", and, as the paper describes, also has a semantic effect (unless the monad satisfies the right-shrinking law). @@ -958,13 +921,13 @@ where vs is a tuple of the variables bound by ss. -The original rec typechecks exactly -when the above desugared version would do so. For example, this means that +The original rec typechecks exactly +when the above desugared version would do so. For example, this means that the variables vs are all monomorphic in the statements following the rec, because they are bound by a lambda. -The mfix function is defined in the MonadFix +The mfix function is defined in the MonadFix class, in Control.Monad.Fix, thus: class Monad m => MonadFix m where @@ -988,14 +951,14 @@ -The following instances of MonadFix are automatically provided: List, Maybe, IO. -Furthermore, the Control.Monad.ST and Control.Monad.ST.Lazy modules provide the instances of the MonadFix class +The following instances of MonadFix are automatically provided: List, Maybe, IO. +Furthermore, the Control.Monad.ST and Control.Monad.ST.Lazy modules provide the instances of the MonadFix class for Haskell's internal state monad (strict and lazy, respectively). Like let and where bindings, -name shadowing is not allowed within a rec; +name shadowing is not allowed within a rec; that is, all the names bound in a single rec must be distinct (Section 3.3 of the paper). @@ -1044,7 +1007,7 @@ example, the following zips together two lists: - [ (x, y) | x <- xs | y <- ys ] + [ (x, y) | x <- xs | y <- ys ] The behavior of parallel list comprehensions follows that of @@ -1057,26 +1020,26 @@ Given a parallel comprehension of the form: - [ e | p1 <- e11, p2 <- e12, ... - | q1 <- e21, q2 <- e22, ... - ... - ] + [ e | p1 <- e11, p2 <- e12, ... + | q1 <- e21, q2 <- e22, ... + ... + ] This will be translated to: - [ e | ((p1,p2), (q1,q2), ...) <- zipN [(p1,p2) | p1 <- e11, p2 <- e12, ...] - [(q1,q2) | q1 <- e21, q2 <- e22, ...] - ... - ] + [ e | ((p1,p2), (q1,q2), ...) <- zipN [(p1,p2) | p1 <- e11, p2 <- e12, ...] + [(q1,q2) | q1 <- e21, q2 <- e22, ...] + ... + ] where `zipN' is the appropriate zip for the given number of branches. - + @@ -1096,7 +1059,7 @@ Comprehensive comprehensions: comprehensions with "order by" and "group by", except that the syntax we use differs slightly from the paper. The extension is enabled with the flag . -Here is an example: +Here is an example: employees = [ ("Simon", "MS", 80) , ("Erik", "MS", 100) @@ -1110,9 +1073,9 @@ , then sortWith by (sum salary) , then take 5 ] -In this example, the list output would take on +In this example, the list output would take on the value: - + [("Yale", 60), ("Ed", 85), ("MS", 180)] @@ -1125,7 +1088,7 @@ all introduced by the (existing) keyword then: - + then f @@ -1133,10 +1096,10 @@ This statement requires that f have the type forall a. [a] -> [a]. You can see an example of its use in the motivating example, as this form is used to apply take 5. - + - - + + @@ -1144,13 +1107,13 @@ This form is similar to the previous one, but allows you to create a function - which will be passed as the first argument to f. As a consequence f must have + which will be passed as the first argument to f. As a consequence f must have the type forall a. (a -> t) -> [a] -> [a]. As you can see - from the type, this function lets f "project out" some information + from the type, this function lets f "project out" some information from the elements of the list it is transforming. - An example is shown in the opening example, where sortWith - is supplied with a function that lets it find out the sum salary + An example is shown in the opening example, where sortWith + is supplied with a function that lets it find out the sum salary for any item in the list comprehension it transforms. @@ -1171,7 +1134,7 @@ at every point after this statement, binders occurring before it in the comprehension refer to lists of possible values, not single values. To help understand this, let's look at an example: - + -- This works similarly to groupWith in GHC.Exts, but doesn't sort its input first groupRuns :: Eq b => (a -> b) -> [a] -> [[a]] @@ -1189,8 +1152,8 @@ [(1, [4, 5, 6]), (2, [4, 5, 6]), (3, [4, 5, 6]), (1, [4, 5, 6]), (2, [4, 5, 6])] - Note that we have used the the function to change the type - of x from a list to its original numeric type. The variable y, in contrast, is left + Note that we have used the the function to change the type + of x from a list to its original numeric type. The variable y, in contrast, is left unchanged from the list form introduced by the grouping. @@ -1203,13 +1166,13 @@ This form of grouping is essentially the same as the one described above. However, since no function to use for the grouping has been supplied it will fall back on the - groupWith function defined in + groupWith function defined in GHC.Exts. This is the form of the group statement that we made use of in the opening example. - - + + @@ -1219,7 +1182,7 @@ With this form of the group statement, f is required to simply have the type forall a. [a] -> [[a]], which will be used to group up the comprehension so far directly. An example of this form is as follows: - + output = [ x | y <- [1..5] @@ -1238,6 +1201,236 @@ + + + + Monad comprehensions + monad comprehensions + + + Monad comprehensions generalise the list comprehension notation, + including parallel comprehensions + () and + transform comprehensions () + to work for any monad. + + + Monad comprehensions support: + + + + + Bindings: + + + +[ x + y | x <- Just 1, y <- Just 2 ] + + + + Bindings are translated with the (>>=) and + return functions to the usual do-notation: + + + +do x <- Just 1 + y <- Just 2 + return (x+y) + + + + + + Guards: + + + +[ x | x <- [1..10], x <= 5 ] + + + + Guards are translated with the guard function, + which requires a MonadPlus instance: + + + +do x <- [1..10] + guard (x <= 5) + return x + + + + + + Transform statements (as with -XTransformListComp): + + + +[ x+y | x <- [1..10], y <- [1..x], then take 2 ] + + + + This translates to: + + + +do (x,y) <- take 2 (do x <- [1..10] + y <- [1..x] + return (x,y)) + return (x+y) + + + + + + Group statements (as with -XTransformListComp): + + + +[ x | x <- [1,1,2,2,3], then group by x ] +[ x | x <- [1,1,2,2,3], then group by x using GHC.Exts.groupWith ] +[ x | x <- [1,1,2,2,3], then group using myGroup ] + + + + The basic then group by e statement is + translated using the mgroupWith function, which + requires a MonadGroup instance, defined in + Control.Monad.Group: + + + +do x <- mgroupWith (do x <- [1,1,2,2,3] + return x) + return x + + + + Note that the type of x is changed by the + grouping statement. + + + + The grouping function can also be defined with the + using keyword. + + + + + + Parallel statements (as with -XParallelListComp): + + + +[ (x+y) | x <- [1..10] + | y <- [11..20] + ] + + + + Parallel statements are translated using the + mzip function, which requires a + MonadZip instance defined in + Control.Monad.Zip: + + + +do (x,y) <- mzip (do x <- [1..10] + return x) + (do y <- [11..20] + return y) + return (x+y) + + + + + + + All these features are enabled by default if the + MonadComprehensions extension is enabled. The types + and more detailed examples on how to use comprehensions are explained + in the previous chapters and . In general you just have + to replace the type [a] with the type + Monad m => m a for monad comprehensions. + + + + Note: Even though most of these examples are using the list monad, + monad comprehensions work for any monad. + The base package offers all necessary instances for + lists, which make MonadComprehensions backward + compatible to built-in, transform and parallel list comprehensions. + + More formally, the desugaring is as follows. We write D[ e | Q] +to mean the desugaring of the monad comprehension [ e | Q]: + +Expressions: e +Declarations: d +Lists of qualifiers: Q,R,S + +-- Basic forms +D[ e | ] = return e +D[ e | p <- e, Q ] = e >>= \p -> D[ e | Q ] +D[ e | e, Q ] = guard e >> \p -> D[ e | Q ] +D[ e | let d, Q ] = let d in D[ e | Q ] + +-- Parallel comprehensions (iterate for multiple parallel branches) +D[ e | (Q | R), S ] = mzip D[ Qv | Q ] D[ Rv | R ] >>= \(Qv,Rv) -> D[ e | S ] + +-- Transform comprehensions +D[ e | Q then f, R ] = f D[ Qv | Q ] >>= \Qv -> D[ e | R ] + +D[ e | Q then f by b, R ] = f (\Qv -> b) D[ Qv | Q ] >>= \Qv -> D[ e | R ] + +D[ e | Q then group using f, R ] = f D[ Qv | Q ] >>= \ys -> + case (fmap selQv1 ys, ..., fmap selQvn ys) of + Qv -> D[ e | R ] + +D[ e | Q then group by b, R ] = D[ e | Q then group by b using mgroupWith, R ] + +D[ e | Q then group by b using f, R ] = f (\Qv -> b) D[ Qv | Q ] >>= \ys -> + case (fmap selQv1 ys, ..., fmap selQvn ys) of + Qv -> D[ e | R ] + +where Qv is the tuple of variables bound by Q (and used subsequently) + selQvi is a selector mapping Qv to the ith component of Qv + +Operator Standard binding Expected type +-------------------------------------------------------------------- +return GHC.Base t1 -> m t2 +(>>=) GHC.Base m1 t1 -> (t2 -> m2 t3) -> m3 t3 +(>>) GHC.Base m1 t1 -> m2 t2 -> m3 t3 +guard Control.Monad t1 -> m t2 +fmap GHC.Base forall a b. (a->b) -> n a -> n b +mgroupWith Control.Monad.Group forall a. (a -> t) -> m1 a -> m2 (n a) +mzip Control.Monad.Zip forall a b. m a -> m b -> m (a,b) + +The comprehension should typecheck when its desugaring would typecheck. + + +Monad comprehensions support rebindable syntax (). +Without rebindable +syntax, the operators from the "standard binding" module are used; with +rebindable syntax, the operators are looked up in the current lexical scope. +For example, parallel comprehensions will be typechecked and desugared +using whatever "mzip" is in scope. + + +The rebindable operators must have the "Expected type" given in the +table above. These types are surprisingly general. For example, you can +use a bind operator with the type + +(>>=) :: T x y a -> (a -> T y z b) -> T x z b + +In the case of transform comprehensions, notice that the groups are +parameterised over some arbitrary type n (provided it +has an fmap, as well as +the comprehension being over an arbitrary monad. + + + @@ -1258,7 +1451,7 @@ hierarchy. It completely defeats that purpose if the literal "1" means "Prelude.fromInteger 1", which is what the Haskell Report specifies. - So the + So the flag causes the following pieces of built-in syntax to refer to whatever is in scope, not the Prelude @@ -1268,16 +1461,16 @@ An integer literal 368 means "fromInteger (368::Integer)", rather than "Prelude.fromInteger (368::Integer)". - + Fractional literals are handed in just the same way, - except that the translation is + except that the translation is fromRational (3.68::Rational). - + The equality test in an overloaded numeric pattern uses whatever (==) is in scope. - + The subtraction operation, and the greater-than-or-equal test, in n+k patterns @@ -1319,7 +1512,7 @@ In all cases (apart from arrow notation), the static semantics should be that of the desugared form, -even if that is a little unexpected. For example, the +even if that is a little unexpected. For example, the static semantics of the literal 368 is exactly that of fromInteger (368::Integer); it's fine for fromInteger to have any of the types: @@ -1330,7 +1523,7 @@ fromInteger :: Integer -> Bool -> Bool - + Be warned: this is an experimental facility, with fewer checks than usual. Use -dcore-lint to typecheck the desugared program. If Core Lint is happy @@ -1418,7 +1611,7 @@ import M data T = MkT { x :: Int } - + ok1 (MkS { x = n }) = n+1 -- Unambiguous ok2 n = MkT { x = n+1 } -- Unambiguous @@ -1437,7 +1630,7 @@ Haskell 98 regards all four as ambiguous, but with the flag, GHC will accept the former two. The rules are precisely the same as those for instance -declarations in Haskell 98, where the method names on the left-hand side +declarations in Haskell 98, where the method names on the left-hand side of the method bindings in an instance declaration refer unambiguously to the method of that class (provided they are in scope at all), even if there are other variables in scope with the same name. @@ -1448,7 +1641,7 @@ Some details: -Field disambiguation can be combined with punning (see ). For exampe: +Field disambiguation can be combined with punning (see ). For example: module Foo where import M @@ -1458,8 +1651,8 @@ -With you can use unqualifed -field names even if the correponding selector is only in scope qualified +With you can use unqualified +field names even if the corresponding selector is only in scope qualified For example, assuming the same module M as in our earlier example, this is legal: module Foo where @@ -1467,7 +1660,7 @@ ok4 (M.MkS { x = n }) = n+1 -- Unambiguous -Since the constructore MkS is only in scope qualified, you must +Since the constructor MkS is only in scope qualified, you must name it M.MkS, but the field x does not need to be qualified even though M.x is in scope but x is not. (In effect, it is qualified by the constructor.) @@ -1507,7 +1700,7 @@ to mean the same pattern as above. That is, in a record pattern, the pattern a expands into the pattern a = -a for the same name a. +a for the same name a. @@ -1518,7 +1711,7 @@ let a = 1 in C {a} -instead of +instead of let a = 1 in C {a = a} @@ -1537,7 +1730,7 @@ Puns can be used wherever record patterns occur (e.g. in -let bindings or at the top-level). +let bindings or at the top-level). @@ -1620,19 +1813,36 @@ -The ".." expands to the missing -in-scope record fields, where "in scope" -includes both unqualified and qualified-only. -Any fields that are not in scope are not filled in. For example +The ".." expands to the missing +in-scope record fields. +Specifically the expansion of "C {..}" includes +f if and only if: + + +f is a record field of constructor C. + + +The record field f is in scope somehow (either qualified or unqualified). + + +In the case of expressions (but not patterns), +the variable f is in scope unqualified, +apart from the binding of the record selector itself. + + +For example module M where data R = R { a,b,c :: Int } module X where - import qualified M( R(a,b) ) - f a b = R { .. } + import M( R(a,c) ) + f b = R { .. } -The {..} expands to {M.a=a,M.b=b}, -omitting c since it is not in scope at all. +The R{..} expands to R{M.a=a}, +omitting b since the record field is not in scope, +and omitting c since the variable c +is not in scope (apart from the binding of the +record selector c, of course). @@ -1657,7 +1867,7 @@ let f = ... infixr 3 `f` -in +in ... and the fixity declaration applies wherever the binding is in scope. @@ -1692,7 +1902,7 @@ import "network" Network.Socket - + would import the module Network.Socket from the package network (any version). This may be used to disambiguate an import when the same module is @@ -1706,6 +1916,25 @@ another, rendering any package-qualified imports broken. + + Safe imports + + With the flag, GHC extends + the import declaration syntax to take an optional safe + keyword after the import keyword. This feature + is part of the Safe Haskell GHC extension. For example: + + +import safe qualified Network.Socket as NS + + + would import the module Network.Socket + with compilation only succeeding if Network.Socket can be + safely imported. For a description of when a import is + considered safe see + + + Summary of stolen syntax @@ -1716,7 +1945,7 @@ "stolen" by language extensions. We use notation and nonterminal names from the Haskell 98 lexical syntax - (see the Haskell 98 Report). + (see the Haskell 98 Report). We only list syntax changes here that might affect existing working programs (i.e. "stolen" syntax). Many of these extensions will also enable new context-free syntax, but in all @@ -1738,7 +1967,7 @@ on. - + The following syntax is stolen: @@ -1830,12 +2059,12 @@ varid{#}, - char#, - string#, - integer#, - float#, - float##, - (#, #), + char#, + string#, + integer#, + float#, + float##, + (#, #), Stolen by: , @@ -1862,7 +2091,7 @@ data T a -- T :: * -> * -Syntactically, the declaration lacks the "= constrs" part. The +Syntactically, the declaration lacks the "= constrs" part. The type can be parameterised over types of any kind, but if the kind is not * then an explicit kind annotation must be used (see ). @@ -1930,7 +2159,7 @@ type T (+) = Int + Int f :: T Either f = Left 3 - + liftA2 :: Arrow (~>) => (a -> b -> c) -> (e ~> a) -> (e ~> b) -> (e ~> c) liftA2 = ... @@ -1968,7 +2197,7 @@ on individual synonym declarations. With the extension, GHC does validity checking on types only after expanding type synonyms. -That means that GHC can be very much more liberal about type synonyms than Haskell 98. +That means that GHC can be very much more liberal about type synonyms than Haskell 98. You can write a forall (including overloading) @@ -1986,7 +2215,7 @@ -If you also use , +If you also use , you can write an unboxed tuple in a type synonym: type Pr = (# Int, Int #) @@ -2000,7 +2229,7 @@ You can apply a type synonym to a forall type: type Foo a = a -> a -> Bool - + f :: Foo (forall b. b->b) After expanding the synonym, f has the legal (in GHC) type: @@ -2014,7 +2243,7 @@ type Generic i o = forall x. i x -> o x type Id x = x - + foo :: Generic Id [] After expanding the synonym, foo has the legal (in GHC) type: @@ -2263,7 +2492,7 @@ inc :: Counter a -> Counter a inc (NewCounter x i d t) = NewCounter - { _this = i x, _inc = i, _display = d, tag = t } + { _this = i x, _inc = i, _display = d, tag = t } display :: Counter a -> IO () display NewCounter{ _this = x, _display = d } = d x @@ -2272,11 +2501,11 @@ Now we can define counters with different underlying implementations: -counterA :: Counter String +counterA :: Counter String counterA = NewCounter { _this = 0, _inc = (1+), _display = print, tag = "A" } -counterB :: Counter String +counterB :: Counter String counterB = NewCounter { _this = "", _inc = ('#':), _display = putStrLn, tag = "B" } @@ -2471,7 +2700,8 @@ Declaring data types with explicit constructor signatures -GHC allows you to declare an algebraic data type by +When the GADTSyntax extension is enabled, +GHC allows you to declare an algebraic data type by giving the type signatures of constructors explicitly. For example: data Maybe a where @@ -2479,16 +2709,16 @@ Just :: a -> Maybe a The form is called a "GADT-style declaration" -because Generalised Algebraic Data Types, described in , +because Generalised Algebraic Data Types, described in , can only be declared using this form. -Notice that GADT-style syntax generalises existential types (). +Notice that GADT-style syntax generalises existential types (). For example, these two declarations are equivalent: data Foo = forall a. MkFoo a (a -> Bool) data Foo' where { MKFoo :: a -> (a->Bool) -> Foo' } -Any data type that can be declared in standard Haskell-98 syntax +Any data type that can be declared in standard Haskell-98 syntax can also be declared using GADT-style syntax. The choice is largely stylistic, but GADT-style declarations differ in one important respect: they treat class constraints on the data constructors differently. @@ -2505,14 +2735,14 @@ insert a (MkSet as) | a `elem` as = MkSet as | otherwise = MkSet (a:as) -A use of MkSet as a constructor (e.g. in the definition of makeSet) +A use of MkSet as a constructor (e.g. in the definition of makeSet) gives rise to a (Eq a) constraint, as you would expect. The new feature is that pattern-matching on MkSet (as in the definition of insert) makes available an (Eq a) context. In implementation terms, the MkSet constructor has a hidden field that stores the (Eq a) dictionary that is passed to MkSet; so when pattern-matching that dictionary becomes available for the right-hand side of the match. -In the example, the equality dictionary is used to satisfy the equality constraint +In the example, the equality dictionary is used to satisfy the equality constraint generated by the call to elem, so that the type of insert itself has no Eq constraint. @@ -2528,36 +2758,36 @@ plus :: NumInst a -> a -> a -> a plus MkNumInst p q = p + q -Here, a value of type NumInst a is equivalent +Here, a value of type NumInst a is equivalent to an explicit (Num a) dictionary. All this applies to constructors declared using the syntax of . -For example, the NumInst data type above could equivalently be declared +For example, the NumInst data type above could equivalently be declared like this: - data NumInst a + data NumInst a = Num a => MkNumInst (NumInst a) -Notice that, unlike the situation when declaring an existential, there is +Notice that, unlike the situation when declaring an existential, there is no forall, because the Num constrains the -data type's universally quantified type variable a. +data type's universally quantified type variable a. A constructor may have both universal and existential type variables: for example, the following two declarations are equivalent: - data T1 a + data T1 a = forall b. (Num a, Eq b) => MkT1 a b data T2 a where MkT2 :: (Num a, Eq b) => a -> b -> T2 a -All this behaviour contrasts with Haskell 98's peculiar treatment of +All this behaviour contrasts with Haskell 98's peculiar treatment of contexts on a data type declaration (Section 4.2.1 of the Haskell 98 Report). In Haskell 98 the definition data Eq a => Set' a = MkSet' [a] -gives MkSet' the same type as MkSet above. But instead of +gives MkSet' the same type as MkSet above. But instead of making available an (Eq a) constraint, pattern-matching on MkSet' requires an (Eq a) constraint! GHC faithfully implements this behaviour, odd though it is. But for GADT-style declarations, @@ -2571,7 +2801,7 @@ The result type of each data constructor must begin with the type constructor being defined. -If the result type of all constructors +If the result type of all constructors has the form T a1 ... an, where a1 ... an are distinct type variables, then the data type is ordinary; otherwise is a generalised data type (). @@ -2589,8 +2819,8 @@ The type signature of -each constructor is independent, and is implicitly universally quantified as usual. -In particular, the type variable(s) in the "data T a where" header +each constructor is independent, and is implicitly universally quantified as usual. +In particular, the type variable(s) in the "data T a where" header have no scope, and different constructors may have different universally-quantified type variables: data T a where -- The 'a' has no scope @@ -2607,7 +2837,7 @@ T1 :: Eq b => b -> b -> T b T2 :: (Show c, Ix c) => c -> [c] -> T c -When patten matching, these constraints are made available to discharge constraints +When pattern matching, these constraints are made available to discharge constraints in the body of the match. For example: f :: T a -> String @@ -2621,8 +2851,8 @@ -Unlike a Haskell-98-style -data type declaration, the type variable(s) in the "data Set a where" header +Unlike a Haskell-98-style +data type declaration, the type variable(s) in the "data Set a where" header have no scope. Indeed, one can write a kind signature instead: data Set :: * -> * where ... @@ -2659,7 +2889,7 @@ Just1 :: a -> Maybe1 a } deriving( Eq, Ord ) - data Maybe2 a = Nothing2 | Just2 a + data Maybe2 a = Nothing2 | Just2 a deriving( Eq, Ord ) @@ -2673,10 +2903,10 @@ Nil :: Foo Here the type variable a does not appear in the result type -of either constructor. +of either constructor. Although it is universally quantified in the type of the constructor, such -a type variable is often called "existential". -Indeed, the above declaration declares precisely the same type as +a type variable is often called "existential". +Indeed, the above declaration declares precisely the same type as the data Foo in . The type may contain a class context too, of course: @@ -2697,23 +2927,23 @@ As usual, for every constructor that has a field f, the type of field f must be the same (modulo alpha conversion). The Child constructor above shows that the signature -may have a context, existentially-quantified variables, and strictness annotations, +may have a context, existentially-quantified variables, and strictness annotations, just as in the non-record case. (NB: the "type" that follows the double-colon is not really a type, because of the record syntax and strictness annotations. A "type" of this form can appear only in a constructor signature.) - -Record updates are allowed with GADT-style declarations, + +Record updates are allowed with GADT-style declarations, only fields that have the following property: the type of the field mentions no existential type variables. - -As in the case of existentials declared using the Haskell-98-like record syntax + +As in the case of existentials declared using the Haskell-98-like record syntax (), record-selector functions are generated only for those fields that have well-typed -selectors. +selectors. Here is the example of that section, in GADT-style syntax: data Counter a where @@ -2733,18 +2963,18 @@ Generalised Algebraic Data Types (GADTs) -Generalised Algebraic Data Types generalise ordinary algebraic data types +Generalised Algebraic Data Types generalise ordinary algebraic data types by allowing constructors to have richer return types. Here is an example: data Term a where Lit :: Int -> Term Int Succ :: Term Int -> Term Int - IsZero :: Term Int -> Term Bool + IsZero :: Term Int -> Term Bool If :: Term Bool -> Term a -> Term a -> Term a Pair :: Term a -> Term b -> Term (a,b) Notice that the return type of the constructors is not always Term a, as is the -case with ordinary data types. This generality allows us to +case with ordinary data types. This generality allows us to write a well-typed eval function for these Terms: @@ -2755,22 +2985,22 @@ eval (If b e1 e2) = if eval b then eval e1 else eval e2 eval (Pair e1 e2) = (eval e1, eval e2) -The key point about GADTs is that pattern matching causes type refinement. +The key point about GADTs is that pattern matching causes type refinement. For example, in the right hand side of the equation eval :: Term a -> a eval (Lit i) = ... the type a is refined to Int. That's the whole point! -A precise specification of the type rules is beyond what this user manual aspires to, +A precise specification of the type rules is beyond what this user manual aspires to, but the design closely follows that described in the paper Simple unification-based type inference for GADTs, (ICFP 2006). -The general principle is this: type refinement is only carried out +The general principle is this: type refinement is only carried out based on user-supplied type annotations. -So if no type signature is supplied for eval, no type refinement happens, +So if no type signature is supplied for eval, no type refinement happens, and lots of obscure error messages will occur. However, the refinement is quite general. For example, if we had: @@ -2790,14 +3020,14 @@ may use different notation to that implemented in GHC. -The rest of this section outlines the extensions to GHC that support GADTs. The extension is enabled with +The rest of this section outlines the extensions to GHC that support GADTs. The extension is enabled with . The flag also sets . -A GADT can only be declared using GADT-style syntax (); +A GADT can only be declared using GADT-style syntax (); the old Haskell-98 syntax for data declarations always declares an ordinary data type. The result type of each constructor must begin with the type constructor being defined, -but for a GADT the arguments to the type constructor can be arbitrary monotypes. +but for a GADT the arguments to the type constructor can be arbitrary monotypes. For example, in the Term data type above, the type of each constructor must end with Term ty, but the ty need not be a type variable (e.g. the Lit @@ -2823,7 +3053,7 @@ Lit { val :: Int } :: Term Int Succ { num :: Term Int } :: Term Int Pred { num :: Term Int } :: Term Int - IsZero { arg :: Term Int } :: Term Bool + IsZero { arg :: Term Int } :: Term Bool Pair { arg1 :: Term a , arg2 :: Term b } :: Term (a,b) @@ -2832,11 +3062,11 @@ , fls :: Term a } :: Term a -However, for GADTs there is the following additional constraint: +However, for GADTs there is the following additional constraint: every constructor that has a field f must have the same result type (modulo alpha conversion) -Hence, in the above example, we cannot merge the num -and arg fields above into a +Hence, in the above example, we cannot merge the num +and arg fields above into a single name. Although their field types are both Term Int, their selector functions actually have different types: @@ -2847,7 +3077,7 @@ -When pattern-matching against data constructors drawn from a GADT, +When pattern-matching against data constructors drawn from a GADT, for example in a case expression, the following rules apply: The type of the scrutinee must be rigid. @@ -2891,12 +3121,12 @@ instance Eq (f a) => Eq (T1 f a) where ... instance Eq (f (f a)) => Eq (T2 f a) where ... -The first of these is obviously fine. The second is still fine, although less obviously. +The first of these is obviously fine. The second is still fine, although less obviously. The third is not Haskell 98, and risks losing termination of instances. GHC takes a conservative position: it accepts the first two, but not the third. The rule is this: -each constraint in the inferred instance context must consist only of type variables, +each constraint in the inferred instance context must consist only of type variables, with no repetitions. @@ -2920,10 +3150,10 @@ Note the following points: -You must supply an explicit context (in the example the context is (Eq a)), +You must supply an explicit context (in the example the context is (Eq a)), exactly as you would in an ordinary instance declaration. -(In contrast, in a deriving clause -attached to a data type declaration, the context is inferred.) +(In contrast, in a deriving clause +attached to a data type declaration, the context is inferred.) @@ -2935,7 +3165,7 @@ Unlike a deriving declaration attached to a data declaration, the instance can be more specific -than the data type (assuming you also use +than the data type (assuming you also use -XFlexibleInstances, ). Consider for example @@ -2950,10 +3180,10 @@ Unlike a deriving -declaration attached to a data declaration, +declaration attached to a data declaration, GHC does not restrict the form of the data type. Instead, GHC simply generates the appropriate boilerplate code for the specified class, and typechecks it. If there is a type error, it is -your problem. (GHC will show you the offending code if it has a type error.) +your problem. (GHC will show you the offending code if it has a type error.) The merit of this is that you can derive instances for GADTs and other exotic data types, providing only that the boilerplate code does indeed typecheck. For example: @@ -2963,8 +3193,8 @@ deriving instance Show (T a) -In this example, you cannot say ... deriving( Show ) on the -data type declaration for T, +In this example, you cannot say ... deriving( Show ) on the +data type declaration for T, because T is a GADT, but you can generate the instance declaration using stand-alone deriving. @@ -2991,10 +3221,10 @@ Deriving clause for extra classes (<literal>Typeable</literal>, <literal>Data</literal>, etc) -Haskell 98 allows the programmer to add "deriving( Eq, Ord )" to a data type -declaration, to generate a standard instance declaration for classes specified in the deriving clause. +Haskell 98 allows the programmer to add "deriving( Eq, Ord )" to a data type +declaration, to generate a standard instance declaration for classes specified in the deriving clause. In Haskell 98, the only classes that may appear in the deriving clause are the standard -classes Eq, Ord, +classes Eq, Ord, Enum, Ix, Bounded, Read, and Show. @@ -3014,28 +3244,34 @@ (Section 7.4 of the paper describes the multiple Typeable classes that are used, and only Typeable1 up to Typeable7 are provided in the library.) -In other cases, there is nothing to stop the programmer writing a TypableX +In other cases, there is nothing to stop the programmer writing a TypeableX class, whose kind suits that of the data type constructor, and then writing the data type instance by hand. - With , you can derive instances of + With , you can derive +instances of the class Generic, defined in +GHC.Generics. You can use these to define generic functions, +as described in . + + + With , you can derive instances of the class Functor, defined in GHC.Base. - With , you can derive instances of + With , you can derive instances of the class Foldable, defined in Data.Foldable. - With , you can derive instances of + With , you can derive instances of the class Traversable, defined in Data.Traversable. -In each case the appropriate class must be in scope before it +In each case the appropriate class must be in scope before it can be mentioned in the deriving clause. @@ -3052,7 +3288,7 @@ example, if you define - newtype Dollars = Dollars Int + newtype Dollars = Dollars Int and you want to use arithmetic on Dollars, you have to @@ -3073,9 +3309,9 @@ Generalising the deriving clause -GHC now permits such instances to be derived instead, +GHC now permits such instances to be derived instead, using the flag , -so one can write +so one can write newtype Dollars = Dollars Int deriving (Eq,Show,Num) @@ -3097,10 +3333,10 @@ transformers, such that - instance Monad m => Monad (State s m) + instance Monad m => Monad (State s m) instance Monad m => Monad (Failure m) -In Haskell 98, we can define a parsing monad by +In Haskell 98, we can define a parsing monad by type Parser tok m a = State [tok] (Failure m) a @@ -3113,9 +3349,9 @@ newtype Parser tok m a = Parser (State [tok] (Failure m) a) deriving Monad -In this case the derived instance declaration is of the form +In this case the derived instance declaration is of the form - instance Monad (State [tok] (Failure m)) => Monad (Parser tok m) + instance Monad (State [tok] (Failure m)) => Monad (Parser tok m) Notice that, since Monad is a constructor class, the @@ -3132,10 +3368,10 @@ clause. For example, given the class - class StateMonad s m | m -> s where ... - instance Monad m => StateMonad s (State s m) where ... + class StateMonad s m | m -> s where ... + instance Monad m => StateMonad s (State s m) where ... -then we can derive an instance of StateMonad for Parsers by +then we can derive an instance of StateMonad for Parsers by newtype Parser tok m a = Parser (State [tok] (Failure m) a) deriving (Monad, StateMonad [tok]) @@ -3165,10 +3401,10 @@ declaration (after expansion of any type synonyms) - newtype T v1...vn = T' (t vk+1...vn) deriving (c1...cm) + newtype T v1...vn = T' (t vk+1...vn) deriving (c1...cm) -where +where The ci are partial applications of @@ -3182,15 +3418,15 @@ The type t is an arbitrary type. - The type variables vk+1...vn do not occur in t, + The type variables vk+1...vn do not occur in t, nor in the ci, and - None of the ci is Read, Show, + None of the ci is Read, Show, Typeable, or Data. These classes should not "look through" the type or its constructor. You can still - derive these classes for a newtype, but it happens in the usual way, not - via this new mechanism. + derive these classes for a newtype, but it happens in the usual way, not + via this new mechanism. Then, for each ci, the derived instance @@ -3198,13 +3434,13 @@ instance ci t => ci (T v1...vk) -As an example which does not work, consider +As an example which does not work, consider - newtype NonMonad m s = NonMonad (State s m s) deriving Monad + newtype NonMonad m s = NonMonad (State s m s) deriving Monad -Here we cannot derive the instance +Here we cannot derive the instance - instance Monad (State s m) => Monad (NonMonad m) + instance Monad (State s m) => Monad (NonMonad m) because the type variable s occurs in State s m, @@ -3220,7 +3456,7 @@ StateMonad class above were instead defined as - class StateMonad m s | m -> s where ... + class StateMonad m s | m -> s where ... then we would not have been able to derive an instance for the @@ -3229,7 +3465,7 @@ instances is most interesting. Lastly, all of this applies only for classes other than -Read, Show, Typeable, +Read, Show, Typeable, and Data, for which the built-in derivation applies (section 4.3.3. of the Haskell Report). (For the standard classes Eq, Ord, @@ -3262,7 +3498,7 @@ Multi-parameter type classes -Multi-parameter type classes are permitted, with flag . +Multi-parameter type classes are permitted, with flag . For example: @@ -3280,11 +3516,11 @@ In Haskell 98 the context of a class declaration (which introduces superclasses) -must be simple; that is, each predicate must consist of a class applied to -type variables. The flag +must be simple; that is, each predicate must consist of a class applied to +type variables. The flag () lifts this restriction, -so that the only restriction on the context in a class declaration is +so that the only restriction on the context in a class declaration is that the class hierarchy must be acyclic. So these class declarations are OK: @@ -3334,13 +3570,54 @@ elem :: Eq a => a -> s a -> Bool The type of elem is illegal in Haskell 98, because it -contains the constraint Eq a, constrains only the +contains the constraint Eq a, constrains only the class type variable (in this case a). GHC lifts this restriction (flag ). + + + +Default signatures + + +Haskell 98 allows you to define a default implementation when declaring a class: + + class Enum a where + enum :: [a] + enum = [] + +The type of the enum method is [a], and +this is also the type of the default method. You can lift this restriction +and give another type to the default method using the flag +. For instance, if you have written a +generic implementation of enumeration in a class GEnum +with method genum in terms of GHC.Generics, +you can specify a default method that uses that generic implementation: + + class Enum a where + enum :: [a] + default enum :: (Generic a, GEnum (Rep a)) => [a] + enum = map to genum + +We reuse the keyword default to signal that a signature +applies to the default method only; when defining instances of the +Enum class, the original type [a] of +enum still applies. When giving an empty instance, however, +the default implementation map to0 genum is filled-in, +and type-checked with the type +(Generic a, GEnum (Rep a)) => [a]. + + + +We use default signatures to simplify generic programming in GHC +(). + + + + @@ -3348,14 +3625,14 @@ Functional dependencies are implemented as described by Mark Jones -in “Type Classes with Functional Dependencies”, Mark P. Jones, -In Proceedings of the 9th European Symposium on Programming, +in “Type Classes with Functional Dependencies”, Mark P. Jones, +In Proceedings of the 9th European Symposium on Programming, ESOP 2000, Berlin, Germany, March 2000, Springer-Verlag LNCS 1782, . -Functional dependencies are introduced by a vertical bar in the syntax of a -class declaration; e.g. +Functional dependencies are introduced by a vertical bar in the syntax of a +class declaration; e.g. class (Monad m) => MonadState s m | m -> s where ... @@ -3366,7 +3643,7 @@ Rules for functional dependencies -In a class declaration, all of the class type variables must be reachable (in the sense +In a class declaration, all of the class type variables must be reachable (in the sense mentioned in ) from the free variables of each method type. For example: @@ -3419,7 +3696,7 @@ from the Hugs user manual, reproduced here (with minor changes) by kind permission of Mark Jones. - + Consider the following class, intended as part of a library for collection types: @@ -3434,7 +3711,7 @@ can be used to represent collections of any equality type), bit sets (which can be used to represent collections of characters), or hash tables (which can be used to represent any collection whose elements have a hash function). Omitting -standard implementation details, this would lead to the following declarations: +standard implementation details, this would lead to the following declarations: instance Eq e => Collects e [e] where ... instance Eq e => Collects e (e -> Bool) where ... @@ -3444,7 +3721,7 @@ All this looks quite promising; we have a class and a range of interesting implementations. Unfortunately, there are some serious problems with the class -declaration. First, the empty function has an ambiguous type: +declaration. First, the empty function has an ambiguous type: empty :: Collects e ce => ce @@ -3458,12 +3735,12 @@ We can sidestep this specific problem by removing the empty member from the class declaration. However, although the remaining members, insert and member, do not have ambiguous types, we still run into problems when we try to use -them. For example, consider the following two functions: +them. For example, consider the following two functions: f x y = insert x . insert y g = f True 'a' -for which GHC infers the following types: +for which GHC infers the following types: f :: (Collects a c, Collects b c) => a -> b -> c -> c g :: (Collects Bool c, Collects Char c) => c -> c @@ -3482,7 +3759,7 @@ Faced with the problems described above, some Haskell programmers might be -tempted to use something like the following version of the class declaration: +tempted to use something like the following version of the class declaration: class Collects e c where empty :: c e @@ -3493,16 +3770,16 @@ used to form the collection type c e, and not over that collection type itself, represented by ce in the original class declaration. This avoids the immediate problems that we mentioned above: empty has type Collects e c => c -e, which is not ambiguous. +e, which is not ambiguous. -The function f from the previous section has a more accurate type: +The function f from the previous section has a more accurate type: f :: (Collects e c) => e -> e -> c e -> c e The function g from the previous section is now rejected with a type error as we would hope because the type of f does not allow the two arguments to have -different types. +different types. This, then, is an example of a multiple parameter class that does actually work quite well in practice, without ambiguity problems. There is, however, a catch. This version of the Collects class is nowhere near @@ -3528,14 +3805,14 @@ in a manuscript [implparam], where they are identified as one point in a general design space for systems of implicit parameterization.). -To start with an abstract example, consider a declaration such as: +To start with an abstract example, consider a declaration such as: class C a b where ... which tells us simply that C can be thought of as a binary relation on types (or type constructors, depending on the kinds of a and b). Extra clauses can be included in the definition of classes to add information about dependencies -between parameters, as in the following examples: +between parameters, as in the following examples: class D a b | a -> b where ... class E a b | a -> b, b -> a where ... @@ -3558,11 +3835,11 @@ definition of E above. Some dependencies that we can write in this notation are redundant, and will be rejected because they don't serve any useful purpose, and may instead indicate an error in the program. Examples of -dependencies like this include a -> a , -a -> a a , +dependencies like this include a -> a , +a -> a a , a -> , etc. There can also be -some redundancy if multiple dependencies are given, as in -a->b, +some redundancy if multiple dependencies are given, as in +a->b, b->c , a->c , and in which some subset implies the remaining dependencies. Examples like this are not treated as errors. Note that dependencies appear only in class @@ -3577,19 +3854,19 @@ instances that are in scope at any given point in the program is consistent with any declared dependencies. For example, the following pair of instance declarations cannot appear together in the same scope because they violate the -dependency for D, even though either one on its own would be acceptable: +dependency for D, even though either one on its own would be acceptable: instance D Bool Int where ... instance D Bool Char where ... -Note also that the following declaration is not allowed, even by itself: +Note also that the following declaration is not allowed, even by itself: instance D [a] b where ... The problem here is that this instance would allow one particular choice of [a] to be associated with more than one choice for b, which contradicts the dependency specified in the definition of D. More generally, this means that, -in any instance of the form: +in any instance of the form: instance D t s where ... @@ -3602,7 +3879,7 @@ more general multiple parameter classes, without ambiguity problems, and with the benefit of more accurate types. To illustrate this, we return to the collection class example, and annotate the original definition of Collects -with a simple dependency: +with a simple dependency: class Collects e ce | ce -> e where empty :: ce @@ -3631,18 +3908,18 @@ Dependencies also help to produce more accurate types for user defined functions, and hence to provide earlier detection of errors, and less cluttered types for programmers to work with. Recall the previous definition for a -function f: +function f: f x y = insert x y = insert x . insert y -for which we originally obtained a type: +for which we originally obtained a type: f :: (Collects a c, Collects b c) => a -> b -> c -> c Given the dependency information that we have for Collects, however, we can deduce that a and b must be equal because they both appear as the second parameter in a Collects constraint with the same first parameter c. Hence we -can infer a shorter and more accurate type for f: +can infer a shorter and more accurate type for f: f :: (Collects a c) => a -> a -> c -> c @@ -3753,7 +4030,7 @@ tvsleft -> tvsright, of the class, every type variable in -S(tvsright) must appear in +S(tvsright) must appear in S(tvsleft), where S is the substitution mapping each type variable in the class declaration to the corresponding type in the instance declaration. @@ -3761,8 +4038,8 @@ These restrictions ensure that context reduction terminates: each reduction step makes the problem smaller by at least one -constructor. Both the Paterson Conditions and the Coverage Condition are lifted -if you give the +constructor. Both the Paterson Conditions and the Coverage Condition are lifted +if you give the flag (). You can find lots of background material about the reason for these restrictions in the paper C4 [a] [a] + instance C4 a a => C4 [a] [a] instance Stateful (ST s) (MutVar s) -- Head can consist of type variables only @@ -3792,7 +4069,7 @@ -- Context assertion no smaller than head instance C a => C a where ... - -- (C b b) has more more occurrences of b than the head + -- (C b b) has more occurrences of b than the head instance C b b => Foo [b] where ... @@ -3850,7 +4127,7 @@ class HasConverter a b | a -> b where convert :: a -> b - + data Foo a = MkFoo a instance (HasConverter a b,Show b) => Show (Foo a) where @@ -3884,7 +4161,7 @@ Nevertheless, GHC allows you to experiment with more liberal rules. If you use the experimental flag --XUndecidableInstances, +-XUndecidableInstances, both the Paterson Conditions and the Coverage Condition (described in ) are lifted. Termination is ensured by having a fixed-depth recursion stack. If you exceed the stack depth you get a @@ -3903,11 +4180,11 @@ should be used to resolve a type-class constraint. This behaviour can be modified by two flags: -XOverlappingInstances - + and -XIncoherentInstances , as this section discusses. Both these -flags are dynamic flags, and can be set on a per-module basis, using +flags are dynamic flags, and can be set on a per-module basis, using an OPTIONS_GHC pragma if desired (). When GHC tries to resolve, say, the constraint C Int Bool, @@ -3921,14 +4198,14 @@ instance context3 => C Int [a] where ... -- (C) instance context4 => C Int [Int] where ... -- (D) -The instances (A) and (B) match the constraint C Int Bool, +The instances (A) and (B) match the constraint C Int Bool, but (C) and (D) do not. When matching, GHC takes no account of the context of the instance declaration (context1 etc). GHC's default behaviour is that exactly one instance must match the -constraint it is trying to resolve. +constraint it is trying to resolve. It is fine for there to be a potential of overlap (by -including both declarations (A) and (B), say); an error is only reported if a +including both declarations (A) and (B), say); an error is only reported if a particular constraint matches more than one. @@ -3948,16 +4225,16 @@ Suppose that from the RHS of f we get the constraint C Int [b]. But GHC does not commit to instance (C), because in a particular -call of f, b might be instantiate +call of f, b might be instantiate to Int, in which case instance (D) would be more specific still. -So GHC rejects the program. +So GHC rejects the program. (If you add the flag , -GHC will instead pick (C), without complaining about +GHC will instead pick (C), without complaining about the problem of subsequent instantiations.) Notice that we gave a type signature to f, so GHC had to -check that f has the specified type. +check that f has the specified type. Suppose instead we do not give a type signature, asking GHC to infer it instead. In this case, GHC will refrain from simplifying the constraint C Int [b] (for the same reason @@ -3965,10 +4242,10 @@ f :: C Int [b] => [b] -> [b] -That postpones the question of which instance to pick to the +That postpones the question of which instance to pick to the call site for f by which time more is known about the type b. -You can write this type signature yourself if you use the +You can write this type signature yourself if you use the flag. @@ -3992,7 +4269,7 @@ (You need to do this.) -Warning: overlapping instances must be used with care. They +Warning: overlapping instances must be used with care. They can give rise to incoherence (ie different instance choices are made in different parts of the program) even without . Consider: @@ -4026,53 +4303,44 @@ instances, and so uses the MyShow [a] instance without complaint. In the call to myshow in main, GHC resolves the MyShow [T] constraint using the overlapping -instance declaration in module Main. As a result, +instance declaration in module Main. As a result, the program prints "Used more specific instance" "Used generic instance" -(An alternative possible behaviour, not currently implemented, +(An alternative possible behaviour, not currently implemented, would be to reject module Help on the grounds that a later instance declaration might overlap the local one.) -The willingness to be overlapped or incoherent is a property of +The willingness to be overlapped or incoherent is a property of the instance declaration itself, controlled by the -presence or otherwise of the +presence or otherwise of the and flags when that module is -being defined. Neither flag is required in a module that imports and uses the -instance declaration. Specifically, during the lookup process: +being defined. Specifically, during the lookup process: -An instance declaration is ignored during the lookup process if (a) a more specific -match is found, and (b) the instance declaration was compiled with -. The flag setting for the -more-specific instance does not matter. +If the constraint being looked up matches two instance declarations IA and IB, +and + +IB is a substitution instance of IA (but not vice versa); +that is, IB is strictly more specific than IA +either IA or IB was compiled with + +then the less-specific instance IA is ignored. Suppose an instance declaration does not match the constraint being looked up, but -does unify with it, so that it might match when the constraint is further +does unify with it, so that it might match when the constraint is further instantiated. Usually GHC will regard this as a reason for not committing to some other constraint. But if the instance declaration was compiled with -, GHC will skip the "does-it-unify?" +, GHC will skip the "does-it-unify?" check for that declaration. -These rules make it possible for a library author to design a library that relies on -overlapping instances without the library client having to know. - - -If an instance declaration is compiled without -, -then that instance can never be overlapped. This could perhaps be -inconvenient. Perhaps the rule should instead say that the -overlapping instance declaration should be compiled in -this way, rather than the overlapped one. Perhaps overlap -at a usage site should be permitted regardless of how the instance declarations -are compiled, if the flag is -used at the usage site. (Mind you, the exact usage site can occasionally be -hard to pin down.) We are interested to receive feedback on these points. +These rules make it possible for a library author to design a library that relies on +overlapping instances without the library client having to know. The flag implies the flag, but not vice versa. @@ -4094,7 +4362,8 @@ a string literal has type (IsString a) => a. -This means that the usual string syntax can be used, e.g., for packed strings + This means that the usual string syntax can be used, e.g., + for ByteString, Text, and other variations of string like types. String literals behave very much like integer literals, i.e., they can be used in both expressions and patterns. If used in a pattern the literal with be replaced by an equality test, in the same @@ -4120,7 +4389,7 @@ Specifically: -Each type in a default declaration must be an +Each type in a default declaration must be an instance of Num or of IsString. @@ -4165,23 +4434,23 @@ Indexed type families are a new GHC extension to - facilitate type-level + facilitate type-level programming. Type families are a generalisation of associated - data types - (“Associated + data types + (“Associated Types with Class”, M. Chakravarty, G. Keller, S. Peyton Jones, and S. Marlow. In Proceedings of “The 32nd Annual ACM SIGPLAN-SIGACT Symposium on Principles of Programming Languages (POPL'05)”, pages 1-13, ACM Press, 2005) and associated type synonyms - (“Type + (“Type Associated Type Synonyms”. M. Chakravarty, G. Keller, and - S. Peyton Jones. + S. Peyton Jones. In Proceedings of “The Tenth ACM SIGPLAN International Conference on Functional Programming”, ACM Press, pages 241-253, 2005). Type families - themselves are described in the paper “Type Checking with Open Type Functions”, T. Schrijvers, - S. Peyton-Jones, + S. Peyton-Jones, M. Chakravarty, and M. Sulzmann, in Proceedings of “ICFP 2008: The 13th ACM SIGPLAN International Conference on Functional Programming”, ACM Press, pages 51-62, 2008. Type families @@ -4190,13 +4459,13 @@ interfaces as well as interfaces with enhanced static information, much like dependent types. They might also be regarded as an alternative to functional dependencies, but provide a more functional style of type-level programming - than the relational style of functional dependencies. + than the relational style of functional dependencies. Indexed type families, or type families for short, are type constructors that represent sets of types. Set members are denoted by supplying the type family constructor with type parameters, which are called type - indices. The + indices. The difference between vanilla parametrised type constructors and family constructors is much like between parametrically polymorphic functions and (ad-hoc polymorphic) methods of type classes. Parametric polymorphic functions @@ -4204,14 +4473,14 @@ behaviour in dependence on the class type parameters. Similarly, vanilla type constructors imply the same data representation for all type instances, but family constructors can have varying representation types for varying type - indices. + indices. Indexed type families come in two flavours: data - families and type synonym + families and type synonym families. They are the indexed family variants of algebraic data types and type synonyms, respectively. The instances of data families - can be data types and newtypes. + can be data types and newtypes. Type families are enabled by the flag . @@ -4225,7 +4494,7 @@ Data families appear in two flavours: (1) they can be defined on the - toplevel + toplevel or (2) they can appear inside type classes (in which case they are known as associated types). The former is the more general variant, as it lacks the requirement for the type-indexes to coincide with the class @@ -4235,11 +4504,11 @@ and then cover the additional constraints placed on associated types. - + Data family declarations - Indexed data families are introduced by a signature, such as + Indexed data families are introduced by a signature, such as data family GMap k :: * -> * @@ -4253,7 +4522,7 @@ Just as with [http://www.haskell.org/ghc/docs/latest/html/users_guide/gadt.html GADT declarations] named arguments are entirely optional, so that we can - declare Array alternatively with + declare Array alternatively with data family Array :: * -> * @@ -4264,7 +4533,7 @@ When a data family is declared as part of a type class, we drop the family special. The GMap - declaration takes the following form + declaration takes the following form class GMapKey k where data GMap k :: * -> * @@ -4275,7 +4544,7 @@ the argument names must be class parameters. Each class parameter may only be used at most once per associated type, but some may be omitted and they may be in an order other than in the class head. Hence, the - following contrived example is admissible: + following contrived example is admissible: class C a b c where data T c a :: * @@ -4284,7 +4553,7 @@ - + Data instance declarations @@ -4298,7 +4567,7 @@ they are fully applied and expand to a type that is itself admissible - exactly as this is required for occurrences of type synonyms in class instance parameters. For example, the Either - instance for GMap is + instance for GMap is data instance GMap (Either a b) v = GMapEither (GMap a v) (GMap b v) @@ -4307,18 +4576,18 @@ Data and newtype instance declarations are only permitted when an - appropriate family declaration is in scope - just as a class instance declaratoin + appropriate family declaration is in scope - just as a class instance declaration requires the class declaration to be visible. Moreover, each instance declaration has to conform to the kind determined by its family declaration. This implies that the number of parameters of an instance declaration matches the arity determined by the kind of the family. - A data family instance declaration can use the full exprssiveness of + A data family instance declaration can use the full expressiveness of ordinary data or newtype declarations: Although, a data family is introduced with - the keyword "data", a data family instance can + the keyword "data", a data family instance can use either data or newtype. For example: data family T a @@ -4346,7 +4615,7 @@ Even if type families are defined as toplevel declarations, functions that perform different computations for different family instances may still need to be defined as methods of type classes. In particular, the - following is not possible: + following is not possible: data family T a data instance T Int = A @@ -4357,7 +4626,7 @@ Instead, you would have to write foo as a class operation, thus: -class C a where +class C a where foo :: T a -> Int instance Foo Int where foo A = 1 @@ -4368,7 +4637,7 @@ Types), it might seem as if a definition, such as the above, should be feasible. However, type families are - in contrast to GADTs - are open; i.e., new instances can always be added, - possibly in other + possibly in other modules. Supporting pattern matching across different data instances would require a form of extensible case construct.) @@ -4379,7 +4648,7 @@ When an associated data family instance is declared within a type class instance, we drop the instance keyword in the family instance. So, the Either instance - for GMap becomes: + for GMap becomes: instance (GMapKey a, GMapKey b) => GMapKey (Either a b) where data GMap (Either a b) v = GMapEither (GMap a v) (GMap b v) @@ -4392,7 +4661,7 @@ which coincides with the only class parameter. Any parameters to the family constructor that do not correspond to class parameters, need to be variables in every instance; here this is the - variable v. + variable v. Instances for an associated family can only appear as part of @@ -4402,7 +4671,7 @@ types can be omitted in class instances. If an associated family instance is omitted, the corresponding instance type is not inhabited; i.e., only diverging expressions, such - as undefined, can assume the type. + as undefined, can assume the type. @@ -4412,13 +4681,13 @@ In the case of multi-parameter type classes, the visibility of class parameters in the right-hand side of associated family instances depends solely on the parameters of the data - family. As an example, consider the simple class declaration + family. As an example, consider the simple class declaration class C a b where data T a Only one of the two class parameters is a parameter to the data - family. Hence, the following instance declaration is invalid: + family. Hence, the following instance declaration is invalid: instance C [c] d where data T [c] = MkT (c, d) -- WRONG!! 'd' is not in scope @@ -4426,7 +4695,7 @@ Here, the right-hand side of the data instance mentions the type variable d that does not occur in its left-hand side. We cannot admit such data instances as they would compromise - type safety. + type safety. @@ -4435,7 +4704,7 @@ Type class instances of instances of data families can be defined as usual, and in particular data instance declarations can - have deriving clauses. For example, we can write + have deriving clauses. For example, we can write data GMap () v = GMapUnit (Maybe v) deriving Show @@ -4452,7 +4721,7 @@ reasons that we cannot define a toplevel function that performs pattern matching on the data constructors of different instances of a single type family. - It would require a form of extensible case construct. + It would require a form of extensible case construct. @@ -4462,7 +4731,7 @@ The instance declarations of a data family used in a single program may not overlap at all, independent of whether they are associated or not. In contrast to type class instances, this is not only a matter - of consistency, but one of type safety. + of consistency, but one of type safety. @@ -4486,7 +4755,7 @@ an export item, these may be either imported or defined in the current module. The treatment of import and export items that explicitly list data constructors, such as GMap(GMapEither), is - analogous. + analogous. @@ -4501,7 +4770,7 @@ type name needs to be prefixed by the keyword type. So for example, when explicitly listing the components of the GMapKey class, we write GMapKey(type - GMap, empty, lookup, insert). + GMap, empty, lookup, insert). @@ -4509,7 +4778,7 @@ Examples Assuming our running GMapKey class example, let us - look at some export lists and their meaning: + look at some export lists and their meaning: module GMap (GMapKey) where...: Exports @@ -4520,14 +4789,14 @@ Exports the class, the associated type GMap and the member functions empty, lookup, - and insert. None of the data constructors is + and insert. None of the data constructors is exported. - + module GMap (GMapKey(..), GMap(..)) where...: As before, but also exports all the data - constructors GMapInt, - GMapChar, + constructors GMapInt, + GMapChar, GMapUnit, GMapPair, and GMapUnit. @@ -4548,7 +4817,7 @@ write GMapKey(type GMap(..)) — i.e., sub-component specifications cannot be nested. To specify GMap's data constructors, you have to list - it separately. + it separately. @@ -4557,7 +4826,7 @@ Family instances are implicitly exported, just like class instances. However, this applies only to the heads of instances, not to the data - constructors an instance defines. + constructors an instance defines. @@ -4584,13 +4853,13 @@ Type family declarations - Indexed type families are introduced by a signature, such as + Indexed type families are introduced by a signature, such as type family Elem c :: * The special family distinguishes family from standard type declarations. The result kind annotation is optional and, as - usual, defaults to * if omitted. An example is + usual, defaults to * if omitted. An example is type family Elem c @@ -4601,13 +4870,13 @@ and it implies that the kind of a type family is not sufficient to determine a family's arity, and hence in general, also insufficient to determine whether a type family application is well formed. As an - example, consider the following declaration: + example, consider the following declaration: -type family F a b :: * -> * -- F's arity is 2, +type family F a b :: * -> * -- F's arity is 2, -- although its overall kind is * -> * -> * -> * Given this declaration the following are examples of well-formed and - malformed types: + malformed types: F Char [Int] -- OK! Kind: * -> * F Char [Int] Bool -- OK! Kind: * @@ -4621,7 +4890,7 @@ When a type family is declared as part of a type class, we drop the family special. The Elem - declaration takes the following form + declaration takes the following form class Collects ce where type Elem ce :: * @@ -4630,7 +4899,7 @@ The argument names of the type family must be class parameters. Each class parameter may only be used at most once per associated type, but some may be omitted and they may be in an order other than in the - class head. Hence, the following contrived example is admissible: + class head. Hence, the following contrived example is admissible: class C a b c where type T c a :: * @@ -4652,7 +4921,7 @@ type synonyms are allowed as long as they are fully applied and expand to a type that is admissible - these are the exact same requirements as for data instances. For example, the [e] instance - for Elem is + for Elem is type instance Elem [e] = e @@ -4668,7 +4937,7 @@ monotype (i.e., it may not include foralls) and after the expansion of all saturated vanilla type synonyms, no synonyms, except family synonyms may remain. Here are some examples of admissible and illegal type - instances: + instances: type family F a :: * type instance F [Int] = Int -- OK! @@ -4689,7 +4958,7 @@ When an associated family instance is declared within a type class instance, we drop the instance keyword in the family instance. So, the [e] instance - for Elem becomes: + for Elem becomes: instance (Eq (Elem [e])) => Collects ([e]) where type Elem [e] = e @@ -4698,7 +4967,7 @@ The most important point about associated family instances is that the type indexes corresponding to class parameters must be identical to the type given in the instance head; here this is [e], - which coincides with the only class parameter. + which coincides with the only class parameter. Instances for an associated family can only appear as part of instances @@ -4707,7 +4976,7 @@ how methods are handled, declarations of associated types can be omitted in class instances. If an associated family instance is omitted, the corresponding instance type is not inhabited; i.e., only diverging - expressions, such as undefined, can assume the type. + expressions, such as undefined, can assume the type. @@ -4722,11 +4991,11 @@ that is the case, the right-hand sides of the instances must also be syntactically equal under the same substitution. This condition is independent of whether the type family is associated or not, and it is - not only a matter of consistency, but one of type safety. + not only a matter of consistency, but one of type safety. Here are two example to illustrate the condition under which overlap - is permitted. + is permitted. type instance F (a, Int) = [a] type instance F (Int, b) = [b] -- overlap permitted @@ -4743,15 +5012,15 @@ In order to guarantee that type inference in the presence of type families decidable, we need to place a number of additional restrictions on the formation of type instance declarations (c.f., - Definition 5 (Relaxed Conditions) of “Type Checking with Open Type Functions”). Instance - declarations have the general form + declarations have the general form type instance F t1 .. tn = t where we require that for every type family application (G s1 - .. sm) in t, + .. sm) in t, s1 .. sm do not contain any type family @@ -4760,7 +5029,7 @@ the total number of symbols (data type constructors and type variables) in s1 .. sm is strictly smaller than - in t1 .. tn, and + in t1 .. tn, and for every type @@ -4774,18 +5043,18 @@ of type inference in the presence of, so called, ''loopy equalities'', such as a ~ [F a], where a recursive occurrence of a type variable is underneath a family application and data - constructor application - see the above mentioned paper for details. + constructor application - see the above mentioned paper for details. If the option is passed to the compiler, the above restrictions are not enforced and it is on the programmer to ensure termination of the normalisation of type families - during type inference. + during type inference. - + Equality constraints Type context can include equality constraints of the form t1 ~ @@ -4793,7 +5062,7 @@ and t2 need to be the same. In the presence of type families, whether two types are equal cannot generally be decided locally. Hence, the contexts of function signatures may include - equality constraints, as in the following example: + equality constraints, as in the following example: sumCollects :: (Collects c1, Collects c2, Elem c1 ~ Elem c2) => c1 -> c2 -> c2 @@ -4802,13 +5071,13 @@ types t1 and t2 of an equality constraint may be arbitrary monotypes; i.e., they may not contain any quantifiers, independent of whether higher-rank types are otherwise - enabled. + enabled. Equality constraints can also appear in class and instance contexts. The former enable a simple translation of programs using functional dependencies into programs using family synonyms instead. The general - idea is to rewrite a class declaration of the form + idea is to rewrite a class declaration of the form class C a b | a -> b @@ -4823,18 +5092,14 @@ essentially giving a name to the functional dependency. In class instances, we define the type instances of FD families in accordance with the class head. Method signatures are not affected by that - process. - - - NB: Equalities in superclass contexts are not fully implemented in - GHC 6.10. + process. - + Type families and instance declarations - Type families require us to extend the rules for - the form of instance heads, which are given + Type families require us to extend the rules for + the form of instance heads, which are given in . Specifically: @@ -4889,9 +5154,9 @@ The context of a type signature The flag lifts the Haskell 98 restriction -that the type-class constraints in a type signature must have the +that the type-class constraints in a type signature must have the form (class type-variable) or -(class (type-variable type-variable ...)). +(class (type-variable type-variable ...)). With these type signatures are perfectly OK @@ -4929,8 +5194,8 @@ A type variable a is "reachable" if it appears in the same constraint as either a type variable free in -type, or another reachable type variable. -A value with a type that does not obey +type, or another reachable type variable. +A value with a type that does not obey this reachability restriction cannot be used without introducing ambiguity; that is why the type is rejected. Here, for example, is an illegal type: @@ -5009,8 +5274,8 @@ Implicit parameters - Implicit parameters are implemented as described in -"Implicit parameters: dynamic scoping with static types", + Implicit parameters are implemented as described in +"Implicit parameters: dynamic scoping with static types", J Lewis, MB Shields, E Meijer, J Launchbury, 27th ACM Symposium on Principles of Programming Languages (POPL'00), Boston, Jan 2000. @@ -5037,7 +5302,7 @@ can support dynamic binding. Basically, we express the use of a dynamically bound variable as a constraint on the type. These constraints lead to types of the form (?x::t') => t, which says "this -function uses a dynamically-bound variable ?x +function uses a dynamically-bound variable ?x of type t'". For example, the following expresses the type of a sort function, implicitly parameterized by a comparison function named cmp. @@ -5047,11 +5312,11 @@ The dynamic binding constraints are just a new form of predicate in the type class system. -An implicit parameter occurs in an expression using the special form ?x, +An implicit parameter occurs in an expression using the special form ?x, where x is -any valid identifier (e.g. ord ?x is a valid expression). +any valid identifier (e.g. ord ?x is a valid expression). Use of this construct also introduces a new -dynamic-binding constraint in the type of the expression. +dynamic-binding constraint in the type of the expression. For example, the following definition shows how we can define an implicitly parameterized sort function in terms of an explicitly parameterized sortBy function: @@ -5084,8 +5349,8 @@ An implicit-parameter type constraint differs from other type class constraints in the following way: All uses of a particular implicit parameter must have -the same type. This means that the type of (?x, ?x) -is (?x::a) => (a,a), and not +the same type. This means that the type of (?x, ?x) +is (?x::a) => (a,a), and not (?x::a, ?x::b) => (a, b), as would be the case for type class constraints. @@ -5110,7 +5375,7 @@ g s = show (read s) Here, g has an ambiguous type, and is rejected, but f -is fine. The binding for ?x at f's call site is +is fine. The binding for ?x at f's call site is quite unambiguous, and fixes the type a. @@ -5130,8 +5395,8 @@ A group of implicit-parameter bindings may occur anywhere a normal group of Haskell -bindings can occur, except at top level. That is, they can occur in a let -(including in a list comprehension, or do-notation, or pattern guards), +bindings can occur, except at top level. That is, they can occur in a let +(including in a list comprehension, or do-notation, or pattern guards), or a where clause. Note the following points: @@ -5139,10 +5404,10 @@ An implicit-parameter binding group must be a collection of simple bindings to implicit-style variables (no function-style bindings, and no type signatures); these bindings are -neither polymorphic or recursive. +neither polymorphic or recursive. -You may not mix implicit-parameter bindings with ordinary bindings in a +You may not mix implicit-parameter bindings with ordinary bindings in a single let expression; use two nested lets instead. (In the case of where you are stuck, since you can't nest where clauses.) @@ -5255,7 +5520,7 @@ Linear implicit parameters are just like ordinary implicit parameters, except that they are "linear"; that is, they cannot be copied, and must be explicitly "split" instead. Linear implicit parameters are -written '%x' instead of '?x'. +written '%x' instead of '?x'. (The '/' in the '%' suggests the split!) @@ -5264,7 +5529,7 @@ import GHC.Exts( Splittable ) data NameSupply = ... - + splitNS :: NameSupply -> (NameSupply, NameSupply) newName :: NameSupply -> Name @@ -5279,7 +5544,7 @@ env' = extend env x x' ...more equations for f... -Notice that the implicit parameter %ns is consumed +Notice that the implicit parameter %ns is consumed once by the call to newName once by the recursive call to f @@ -5313,14 +5578,14 @@ g :: (Splittable a, %ns :: a) => b -> (b,a,a) -The Splittable class is built into GHC. It's exported by module +The Splittable class is built into GHC. It's exported by module GHC.Exts. Other points: - '?x' and '%x' -are entirely distinct implicit parameters: you + '?x' and '%x' +are entirely distinct implicit parameters: you can use them together and they won't interfere with each other. @@ -5353,7 +5618,7 @@ But now the name supply is consumed in three places (the two calls to newName,and the recursive call to f), so -the result is utterly different. Urk! We don't even have +the result is utterly different. Urk! We don't even have the beta rule. @@ -5402,7 +5667,7 @@ Yikes! You may say that this is a good reason to dislike linear implicit parameters -and you'd be right. That is why they are an experimental feature. +and you'd be right. That is why they are an experimental feature. @@ -5415,7 +5680,7 @@ Haskell infers the kind of each type variable. Sometimes it is nice to be able -to give the kind explicitly as (machine-checked) documentation, +to give the kind explicitly as (machine-checked) documentation, just as it is nice to give a type signature for a function. On some occasions, it is essential to do so. For example, in his paper "Restricted Data Types in Haskell" (Haskell Workshop 1999) John Hughes had to define the data type: @@ -5480,9 +5745,9 @@ -GHC's type system supports arbitrary-rank +GHC's type system supports arbitrary-rank explicit universal quantification in -types. +types. For example, all the following types are legal: f1 :: forall a b. a -> b -> a @@ -5616,11 +5881,11 @@ a1 :: T Int a1 = T1 (\xy->x) 3 - + a2, a3 :: Swizzle a2 = MkSwizzle sort a3 = MkSwizzle reverse - + a4 :: MonadT Maybe a4 = let r x = Just x b m k = case m of @@ -5687,7 +5952,7 @@ that x's type has no foralls in it. -What does it mean to "provide" an explicit type for x? You can do that by +What does it mean to "provide" an explicit type for x? You can do that by giving a type signature for x directly, using a pattern type signature (), thus: @@ -5723,10 +5988,10 @@ Implicit quantification -GHC performs implicit quantification as follows. At the top level (only) of +GHC performs implicit quantification as follows. At the top level (only) of user-written types, if and only if there is no explicit forall, GHC finds all the type variables mentioned in the type that are not already -in scope, and universally quantifies them. For example, the following pairs are +in scope, and universally quantifies them. For example, the following pairs are equivalent: f :: a -> a @@ -5771,8 +6036,8 @@ Impredicative polymorphism -GHC supports impredicative polymorphism, -enabled with . +GHC supports impredicative polymorphism, +enabled with . This means that you can call a polymorphic function at a polymorphic type, and parameterise data structures over polymorphic types. For example: @@ -5788,7 +6053,7 @@ The technical details of this extension are described in the paper Boxy types: type inference for higher-rank types and impredicativity, -which appeared at ICFP 2006. +which appeared at ICFP 2006. @@ -5810,9 +6075,9 @@ because of the explicit forall (). The type variables bound by a forall scope over the entire definition of the accompanying value declaration. -In this example, the type variable a scopes over the whole +In this example, the type variable a scopes over the whole definition of f, including over -the type signature for ys. +the type signature for ys. In Haskell 98 it is not possible to declare a type for ys; a major benefit of scoped type variables is that it becomes possible to do so. @@ -5854,7 +6119,7 @@ In Haskell, a programmer-written type signature is implicitly quantified over its free type variables (Section -4.1.2 +4.1.2 of the Haskell Report). Lexically scoped type variables affect this implicit quantification rules as follows: any type variable that is in scope is not universally @@ -5893,11 +6158,11 @@ g (x:xs) = xs ++ [ x :: a ] This program will be rejected, because "a" does not scope -over the definition of "f", so "x::a" +over the definition of "g", so "x::a" means "x::forall a. a" by Haskell's usual implicit quantification rules. - The signature gives a type for a function binding or a bare variable binding, + The signature gives a type for a function binding or a bare variable binding, not a pattern binding. For example: @@ -5907,7 +6172,7 @@ f2 :: forall a. [a] -> [a] f2 = \(x:xs) -> xs ++ [ x :: a ] -- OK - f3 :: forall a. [a] -> [a] + f3 :: forall a. [a] -> [a] Just f3 = Just (\(x:xs) -> xs ++ [ x :: a ]) -- Not OK! The binding for f3 is a pattern binding, and so its type signature @@ -5929,8 +6194,8 @@ f = runST ( (op >>= \(x :: STRef s Int) -> g x) :: forall s. ST s Bool ) -Here, the type signature forall a. ST s Bool brings the -type variable s into scope, in the annotated expression +Here, the type signature forall s. ST s Bool brings the +type variable s into scope, in the annotated expression (op >>= \(x :: STRef s Int) -> g x). @@ -5940,7 +6205,7 @@ Pattern type signatures A type signature may occur in any pattern; this is a pattern type -signature. +signature. For example: -- f and g assume that 'a' is already in scope @@ -5967,7 +6232,7 @@ Here, the pattern signatures for ys and zs are fine, but the one for v is not because b is -not in scope. +not in scope. However, in all patterns other than pattern bindings, a pattern @@ -5990,7 +6255,7 @@ existentially-bound type variable. -When a pattern type signature binds a type variable in this way, GHC insists that the +When a pattern type signature binds a type variable in this way, GHC insists that the type variable is bound to a rigid, or fully-known, type variable. This means that any user-written type signature always stands for a completely known type. @@ -6000,7 +6265,7 @@ could not name existentially-bound type variables in subsequent type signatures. -This is (now) the only situation in which a pattern type +This is (now) the only situation in which a pattern type signature is allowed to mention a lexical variable that is not already in scope. For example, both f and g would be @@ -6010,7 +6275,7 @@ - - + Template Haskell Template Haskell allows you to do compile-time meta-programming in -Haskell. +Haskell. The background to the main technical innovations is discussed in " @@ -6184,23 +6449,23 @@ Template Haskell at http://www.haskell.org/haskellwiki/Template_Haskell, and that is the best place to look for further details. -You may also +You may also consult the online -Haskell library reference material +Haskell library reference material (look for module Language.Haskell.TH). -Many changes to the original design are described in +Many changes to the original design are described in Notes on Template Haskell version 2. Not all of these changes are in GHC, however. - The first example from that paper is set out below () -as a worked example to help get you started. + The first example from that paper is set out below () +as a worked example to help get you started. -The documentation here describes the realisation of Template Haskell in GHC. It is not detailed enough to +The documentation here describes the realisation of Template Haskell in GHC. It is not detailed enough to understand Template Haskell; see the Wiki page. @@ -6224,24 +6489,24 @@ of "$" overrides its meaning as an infix operator, just as "M.x" overrides the meaning of "." as an infix operator. If you want the infix operator, put spaces around it. - A splice can occur in place of + A splice can occur in place of an expression; the spliced expression must have type Q Exp an type; the spliced expression must have type Q Typ - a list of top-level declarations; the spliced expression + a list of top-level declarations; the spliced expression must have type Q [Dec] Note that pattern splices are not supported. - Inside a splice you can can only call functions defined in imported modules, + Inside a splice you can only call functions defined in imported modules, not functions defined elsewhere in the same module. A expression quotation is written in Oxford brackets, thus: - [| ... |], or [e| ... |], - where the "..." is an expression; + [| ... |], or [e| ... |], + where the "..." is an expression; the quotation has type Q Exp. [d| ... |], where the "..." is a list of top-level declarations; the quotation has type Q [Dec]. @@ -6266,17 +6531,17 @@ 'f has type Name, and names the function f. Similarly 'C has type Name and names the data constructor C. In general 'thing interprets thing in an expression context. - + ''T has type Name, and names the type constructor T. That is, ''thing interprets thing in a type context. - + These Names can be used to construct Template Haskell expressions, patterns, declarations etc. They may also be given as an argument to the reify function. - You may omit the $(...) in a top-level declaration splice. + You may omit the $(...) in a top-level declaration splice. Simply writing an expression (rather than a declaration) implies a splice. For example, you can write module Foo where @@ -6295,7 +6560,7 @@ This abbreviation makes top-level declaration slices quieter and less intimidating. - + (Compared to the original paper, there are many differences of detail. The syntax for a declaration splice uses "$" not "splice". @@ -6321,7 +6586,7 @@ You can only run a function at compile time if it is imported from another module that is not part of a mutually-recursive group of modules - that includes the module currently being compiled. Furthermore, all of the modules of + that includes the module currently being compiled. Furthermore, all of the modules of the mutually-recursive group must be reachable by non-SOURCE imports from the module where the splice is to be run. @@ -6343,11 +6608,11 @@ Template Haskell works in any mode (--make, --interactive, - or file-at-a-time). There used to be a restriction to the former two, but that restriction + or file-at-a-time). There used to be a restriction to the former two, but that restriction has been lifted. - + A Template Haskell Worked Example To help you get over the confidence barrier, try out this skeletal worked example. First cut and paste the two modules below into "Main.hs" and "Printf.hs": @@ -6417,7 +6682,7 @@ Using Template Haskell with Profiling profilingwith Template Haskell - + Template Haskell relies on GHC's built-in bytecode compiler and interpreter to run the splice expressions. The bytecode interpreter runs the compiled expression on top of the same runtime on which GHC @@ -6469,11 +6734,11 @@ [quoter| string |]. -The quoter must be the (unqualified) name of an imported -quoter; it cannot be an arbitrary expression. +The quoter must be the (unqualified) name of an imported +quoter; it cannot be an arbitrary expression. -The quoter cannot be "e", +The quoter cannot be "e", "t", "d", or "p", since those overlap with Template Haskell quotations. @@ -6482,7 +6747,7 @@ [quoter|. -The quoted string +The quoted string can be arbitrary, and may contain newlines. @@ -6500,7 +6765,7 @@ -A quoter is a value of type Language.Haskell.TH.Quote.QuasiQuoter, +A quoter is a value of type Language.Haskell.TH.Quote.QuasiQuoter, which is defined thus: data QuasiQuoter = QuasiQuoter { quoteExp :: String -> Q Exp, @@ -6693,7 +6958,7 @@ | proc apat -> cmd where proc is a new keyword. -The variables of the pattern are bound in the body of the +The variables of the pattern are bound in the body of the proc-expression, which is a new sort of thing called a command. The syntax of commands is as follows: @@ -7096,7 +7361,7 @@ Although only GHC implements arrow notation directly, there is also a preprocessor -(available from the +(available from the arrows web page) that translates arrow notation into Haskell 98 for use with other Haskell systems. @@ -7141,7 +7406,7 @@ Bang patterns GHC supports an extension of pattern matching called bang -patterns, written !pat. +patterns, written !pat. Bang patterns are under consideration for Haskell Prime. The Haskell @@ -7149,9 +7414,9 @@ than the material below. -The key change is the addition of a new rule to the +The key change is the addition of a new rule to the semantics of pattern matching in the Haskell 98 report. -Add new bullet 10, saying: Matching the pattern !pat +Add new bullet 10, saying: Matching the pattern !pat against a value v behaves as follows: if v is bottom, the match diverges @@ -7183,13 +7448,13 @@ f2 (!x, y) = [x,y] Here, f2 is strict in x but not in -y. +y. A bang only really has an effect if it precedes a variable or wild-card pattern: f3 !(x,y) = [x,y] f4 (x,y) = [x,y] -Here, f3 and f4 are identical; +Here, f3 and f4 are identical; putting a bang before a pattern that forces evaluation anyway does nothing. @@ -7236,7 +7501,7 @@ g6 x = case f x of { y -> body } g7 x = case f x of { !y -> body } -The functions g5 and g6 mean exactly the same thing. +The functions g5 and g6 mean exactly the same thing. But g7 evaluates (f x), binds y to the result, and then evaluates body. @@ -7266,7 +7531,7 @@ The semantics of Haskell pattern matching is described in -Section 3.17.2 of the Haskell Report. To this description add +Section 3.17.2 of the Haskell Report. To this description add one extra item 10, saying: Matching the pattern !pat against a value v behaves as follows: @@ -7282,13 +7547,13 @@ = v `seq` case v of { pat -> e; _ -> e' } -That leaves let expressions, whose translation is given in +That leaves let expressions, whose translation is given in Section 3.12 of the Haskell Report. -In the translation box, first apply -the following transformation: for each pattern pi that is of -form !qi = ei, transform it to (xi,!qi) = ((),ei), and and replace e0 +In the translation box, first apply +the following transformation: for each pattern pi that is of +form !qi = ei, transform it to (xi,!qi) = ((),ei), and replace e0 by (xi `seq` e0). Then, when none of the left-hand-side patterns have a bang at the top, apply the rules in the existing box. @@ -7416,7 +7681,7 @@ Pragmas all take the form -{-# word ... #-} +{-# word ... #-} where word indicates the type of pragma, and is followed optionally by information specific to that @@ -7426,7 +7691,7 @@ in the following sections; any pragma encountered with an unrecognised word is ignored. The layout rule applies in pragmas, so the closing #-} - should start in a column to the right of the opening {-#. + should start in a column to the right of the opening {-#. Certain pragmas are file-header pragmas: @@ -7436,7 +7701,7 @@ There can be as many file-header pragmas as you please, and they can be - preceded or followed by comments. + preceded or followed by comments. File-header pragmas are read once only, before @@ -7456,7 +7721,7 @@ LANGUAGEpragma pragmaLANGUAGE - The LANGUAGE pragma allows language extensions to be enabled + The LANGUAGE pragma allows language extensions to be enabled in a portable way. It is the intention that all Haskell compilers support the LANGUAGE pragma with the same syntax, although not @@ -7565,7 +7830,7 @@ (a) uses within the defining module, and (b) uses in an export list. The latter reduces spurious complaints within a library - in which one module gathers together and re-exports + in which one module gathers together and re-exports the exports of several others. You can suppress the warnings with the flag @@ -7602,7 +7867,7 @@ The major effect of an INLINE pragma is to declare a function's “cost” to be very low. The normal unfolding machinery will then be very keen to - inline it. However, an INLINE pragma for a + inline it. However, an INLINE pragma for a function "f" has a number of other effects: @@ -7616,13 +7881,13 @@ map (\x -> body) xs In general, GHC only inlines the function if there is some reason (no matter -how slight) to supose that it is useful to do so. +how slight) to suppose that it is useful to do so. -Moreover, GHC will only inline the function if it is fully applied, +Moreover, GHC will only inline the function if it is fully applied, where "fully applied" -means applied to as many arguments as appear (syntactically) +means applied to as many arguments as appear (syntactically) on the LHS of the function definition. For example: @@ -7634,7 +7899,7 @@ {-# INLINE comp2 #-} comp2 f g x = f (g x) -The two functions comp1 and comp2 have the +The two functions comp1 and comp2 have the same semantics, but comp1 will be inlined when applied to two arguments, while comp2 requires three. This might make a big difference if you say @@ -7644,14 +7909,14 @@ which will optimise better than the corresponding use of `comp2`. - + It is useful for GHC to optimise the definition of an -INLINE function f just like any other non-INLINE function, +INLINE function f just like any other non-INLINE function, in case the non-inlined version of f is -ultimately called. But we don't want to inline +ultimately called. But we don't want to inline the optimised version of f; -a major reason for INLINE pragmas is to expose functions +a major reason for INLINE pragmas is to expose functions in f's RHS that have rewrite rules, and it's no good if those functions have been optimised away. @@ -7660,7 +7925,7 @@ So GHC guarantees to inline precisely the code that you wrote, no more and no less. It does this by capturing a copy of the definition of the function to use for inlining (we call this the "inline-RHS"), which it leaves untouched, -while optimising the ordinarly RHS as usual. For externally-visible functions +while optimising the ordinarily RHS as usual. For externally-visible functions the inline-RHS (not the optimised RHS) is recorded in the interface file. @@ -7695,13 +7960,13 @@ {-# INLINE returnUs #-} - See also the NOINLINE () - and INLINABLE () + See also the NOINLINE () + and INLINABLE () pragmas. Note: the HBC compiler doesn't like INLINE pragmas, so if you want your code to be HBC-compatible you'll have to surround - the pragma with C pre-processor directives + the pragma with C pre-processor directives #ifdef __GLASGOW_HASKELL__...#endif. @@ -7759,7 +8024,7 @@ NOINLINE pragma - + NOINLINE NOTINLINE @@ -7778,7 +8043,7 @@ CONLIKE modifier CONLIKE - An INLINE or NOINLINE pragma may have a CONLIKE modifier, + An INLINE or NOINLINE pragma may have a CONLIKE modifier, which affects matching in RULEs (only). See . @@ -7850,82 +8115,6 @@ - - ANN pragmas - - GHC offers the ability to annotate various code constructs with additional - data by using three pragmas. This data can then be inspected at a later date by - using GHC-as-a-library. - - - Annotating values - - ANN - - Any expression that has both Typeable and Data instances may be attached to a top-level value - binding using an ANN pragma. In particular, this means you can use ANN - to annotate data constructors (e.g. Just) as well as normal values (e.g. take). - By way of example, to annotate the function foo with the annotation Just "Hello" - you would do this: - - -{-# ANN foo (Just "Hello") #-} -foo = ... - - - - A number of restrictions apply to use of annotations: - - The binder being annotated must be at the top level (i.e. no nested binders) - The binder being annotated must be declared in the current module - The expression you are annotating with must have a type with Typeable and Data instances - The Template Haskell staging restrictions apply to the - expression being annotated with, so for example you cannot run a function from the module being compiled. - - To be precise, the annotation {-# ANN x e #-} is well staged if and only if $(e) would be - (disregarding the usual type restrictions of the splice syntax, and the usual restriction on splicing inside a splice - $([|1|]) is fine as an annotation, albeit redundant). - - - If you feel strongly that any of these restrictions are too onerous, - please give the GHC team a shout. - - - However, apart from these restrictions, many things are allowed, including expressions which are not fully evaluated! - Annotation expressions will be evaluated by the compiler just like Template Haskell splices are. So, this annotation is fine: - - -{-# ANN f SillyAnnotation { foo = (id 10) + $([| 20 |]), bar = 'f } #-} -f = ... - - - - - Annotating types - - ANN type - ANN - - You can annotate types with the ANN pragma by using the type keyword. For example: - - -{-# ANN type Foo (Just "A `Maybe String' annotation") #-} -data Foo = ... - - - - - Annotating modules - - ANN module - ANN - - You can annotate modules with the ANN pragma by using the module keyword. For example: - - -{-# ANN module (Just "A `Maybe String' annotation") #-} - - - LINE pragma @@ -8008,7 +8197,7 @@ h :: Eq a => a -> a -> a {-# SPECIALISE h :: (Eq a) => [a] -> [a] -> [a] #-} -The last of these examples will generate a +The last of these examples will generate a RULE with a somewhat-complex left-hand side (try it yourself), so it might not fire very well. If you use this kind of specialisation, let us know how well it works. @@ -8017,7 +8206,7 @@ SPECIALIZE INLINE A SPECIALIZE pragma can optionally be followed with a -INLINE or NOINLINE pragma, optionally +INLINE or NOINLINE pragma, optionally followed by a phase, as described in . The INLINE pragma affects the specialised version of the function (only), and applies even if the function is recursive. The motivating @@ -8052,7 +8241,7 @@ Generally, you can only give a SPECIALIZE pragma for a function defined in the same module. However if a function f is given an INLINABLE -pragma at its definition site, then it can subequently be specialised by +pragma at its definition site, then it can subsequently be specialised by importing modules (see ). For example @@ -8103,7 +8292,7 @@ -Obselete SPECIALIZE syntax +Obsolete SPECIALIZE syntax Note: In earlier versions of GHC, it was possible to provide your own specialised function for a given type: @@ -8128,7 +8317,7 @@ Same idea, except for instance declarations. For example: -instance (Eq a) => Eq (Foo a) where { +instance (Eq a) => Eq (Foo a) where { {-# SPECIALIZE instance Eq (Foo [(Int, Bar)]) #-} ... usual stuff ... } @@ -8147,7 +8336,7 @@ UNPACK pragma UNPACK - + The UNPACK indicates to the compiler that it should unpack the contents of a constructor field into the constructor itself, removing a level of indirection. For @@ -8166,7 +8355,11 @@ compiler). Unpacking constructor fields should only be used in - conjunction with , in order to expose + conjunction with in fact, UNPACK + has no effect without , for technical + reasons + (see tick + 5252), in order to expose unfoldings to the compiler so the reboxing can be removed as often as possible. For example: @@ -8227,7 +8420,7 @@ The programmer can specify rewrite rules as part of the source program -(in a pragma). +(in a pragma). Here is an example: @@ -8239,7 +8432,7 @@ Use the debug flag to see what rules fired. If you need more information, then shows you -each individual rule firing in detail. +each individual rule firing and also shows what the code looks like before and after the rewrite. @@ -8360,7 +8553,7 @@ Inside a RULE "forall" is treated as a keyword, regardless of any other flag settings. Furthermore, inside a RULE, the language extension - is automatically enabled; see + is automatically enabled; see . @@ -8368,9 +8561,9 @@ Like other pragmas, RULE pragmas are always checked for scope errors, and -are typechecked. Typechecking means that the LHS and RHS of a rule are typechecked, +are typechecked. Typechecking means that the LHS and RHS of a rule are typechecked, and must have the same type. However, rules are only enabled -if the flag is +if the flag is on (see ). @@ -8393,8 +8586,8 @@ by the flag. This flag is implied by , and may be switched off (as usual) by . -(NB: enabling without -may not do what you expect, though, because without GHC +(NB: enabling without +may not do what you expect, though, because without GHC ignores all optimisation information in interface files; see , .) Note that is an optimisation flag, and @@ -8503,12 +8696,12 @@ g y = y Now g is inlined into h, but f's RULE has -no chance to fire. +no chance to fire. If instead GHC had first inlined g into h then there -would have been a better chance that f's RULE might fire. +would have been a better chance that f's RULE might fire. -The way to get predictable behaviour is to use a NOINLINE +The way to get predictable behaviour is to use a NOINLINE pragma, or an INLINE[phase] pragma, on f, to ensure that it is not inlined until its RULEs have had a chance to fire. @@ -8531,12 +8724,12 @@ {-# INLINE[1] CONLIKE f #-} f x = blah -CONLIKE is a modifier to an INLINE or NOINLINE pragam. It specifies that an application +CONLIKE is a modifier to an INLINE or NOINLINE pragma. It specifies that an application of f to one argument (in general, the number of arguments to the left of the '=' sign) should be considered cheap enough to duplicate, if such a duplication would make rule fire. (The name "CONLIKE" is short for "constructor-like", because constructors certainly have such a property.) -The CONLIKE pragam is a modifier to INLINE/NOINLINE because it really only makes sense to match +The CONLIKE pragma is a modifier to INLINE/NOINLINE because it really only makes sense to match f on the LHS of a rule if you are sure that f is not going to be inlined before the rule has a chance to fire. @@ -8811,7 +9004,7 @@ Use to see the rules that are defined in this module. This includes rules generated by the specialisation pass, but excludes -rules imported from other modules. +rules imported from other modules. @@ -8824,7 +9017,8 @@ - Use to see in great detail what rules are being fired. + Use or +to see in great detail what rules are being fired. If you add you get a still more detailed listing. @@ -8943,7 +9137,7 @@ restrains the strictness analyser. -lazy +unsafeCoerce# allows you to fool the type checker. @@ -8955,257 +9149,223 @@ Generic classes -The ideas behind this extension are described in detail in "Derivable type classes", -Ralf Hinze and Simon Peyton Jones, Haskell Workshop, Montreal Sept 2000, pp94-105. -An example will give the idea: +GHC used to have an implementation of generic classes as defined in the paper +"Derivable type classes", Ralf Hinze and Simon Peyton Jones, Haskell Workshop, +Montreal Sept 2000, pp94-105. These have been removed and replaced by the more +general support for generic programming. - - import Data.Generics + - class Bin a where - toBin :: a -> [Int] - fromBin :: [Int] -> (a, [Int]) - - toBin {| Unit |} Unit = [] - toBin {| a :+: b |} (Inl x) = 0 : toBin x - toBin {| a :+: b |} (Inr y) = 1 : toBin y - toBin {| a :*: b |} (x :*: y) = toBin x ++ toBin y - - fromBin {| Unit |} bs = (Unit, bs) - fromBin {| a :+: b |} (0:bs) = (Inl x, bs') where (x,bs') = fromBin bs - fromBin {| a :+: b |} (1:bs) = (Inr y, bs') where (y,bs') = fromBin bs - fromBin {| a :*: b |} bs = (x :*: y, bs'') where (x,bs' ) = fromBin bs - (y,bs'') = fromBin bs' - - -This class declaration explains how toBin and fromBin -work for arbitrary data types. They do so by giving cases for unit, product, and sum, -which are defined thus in the library module Data.Generics: - - - data Unit = Unit - data a :+: b = Inl a | Inr b - data a :*: b = a :*: b - - -Now you can make a data type into an instance of Bin like this: - - instance (Bin a, Bin b) => Bin (a,b) - instance Bin a => Bin [a] - -That is, just leave off the "where" clause. Of course, you can put in the -where clause and over-ride whichever methods you please. - - - Using generics - To use generics you need to - - - - Use the flags (to enable the - extra syntax and generate extra per-data-type code), - and (to make the - Data.Generics module available. - - - - Import the module Data.Generics from the - syb package. This import brings into - scope the data types Unit, - :*:, and :+:. (You - don't need this import if you don't mention these types - explicitly; for example, if you are simply giving instance - declarations.) - - - + +Generic programming - Changes wrt the paper -Note that the type constructors :+: and :*: -can be written infix (indeed, you can now use -any operator starting in a colon as an infix type constructor). Also note that -the type constructors are not exactly as in the paper (Unit instead of 1, etc). -Finally, note that the syntax of the type patterns in the class declaration -uses "{|" and "|}" brackets; curly braces -alone would ambiguous when they appear on right hand sides (an extension we -anticipate wanting). +Using a combination of +() and + (), +you can easily do datatype-generic +programming using the GHC.Generics framework. This section +gives a very brief overview of how to do it. - - Terminology and restrictions -Terminology. A "generic default method" in a class declaration -is one that is defined using type patterns as above. -A "polymorphic default method" is a default method defined as in Haskell 98. -A "generic class declaration" is a class declaration with at least one -generic default method. +Generic programming support in GHC allows defining classes with methods that +do not need a user specification when instantiating: the method body is +automatically derived by GHC. This is similar to what happens for standard +classes such as Read and Show, for +instance, but now for user-defined classes. - -Restrictions: - - - -Alas, we do not yet implement the stuff about constructor names and -field labels. - - + +Deriving representations - -A generic class can have only one parameter; you can't have a generic -multi-parameter class. - - +The first thing we need is generic representations. The +GHC.Generics module defines a couple of primitive types +that are used to represent Haskell datatypes: - - -A default method must be defined entirely using type patterns, or entirely -without. So this is illegal: - class Foo a where - op :: a -> (a, Bool) - op {| Unit |} Unit = (Unit, True) - op x = (x, False) +-- | Unit: used for constructors without arguments +data U1 p = U1 + +-- | Constants, additional parameters and recursion of kind * +newtype K1 i c p = K1 { unK1 :: c } + +-- | Meta-information (constructor names, etc.) +newtype M1 i c f p = M1 { unM1 :: f p } + +-- | Sums: encode choice between constructors +infixr 5 :+: +data (:+:) f g p = L1 (f p) | R1 (g p) + +-- | Products: encode multiple arguments to constructors +infixr 6 :*: +data (:*:) f g p = f p :*: g p -However it is perfectly OK for some methods of a generic class to have -generic default methods and others to have polymorphic default methods. - - -The type variable(s) in the type pattern for a generic method declaration -scope over the right hand side. So this is legal (note the use of the type variable ``p'' in a type signature on the right hand side: +The Generic class mediates between user-defined datatypes +and their internal representation as a sum-of-products: + - class Foo a where - op :: a -> Bool - op {| p :*: q |} (x :*: y) = op (x :: p) - ... +class Generic a where + -- Encode the representation of a user datatype + type Rep a :: * -> * + -- Convert from the datatype to its representation + from :: a -> (Rep a) x + -- Convert from the representation to the datatype + to :: (Rep a) x -> a + +Instances of this class can be derived by GHC with the + (), and are +necessary to be able to define generic instances automatically. - - -The type patterns in a generic default method must take one of the forms: - - a :+: b - a :*: b - Unit - -where "a" and "b" are type variables. Furthermore, all the type patterns for -a single type constructor (:*:, say) must be identical; they -must use the same type variables. So this is illegal: - - class Foo a where - op :: a -> Bool - op {| a :+: b |} (Inl x) = True - op {| p :+: q |} (Inr y) = False - -The type patterns must be identical, even in equations for different methods of the class. -So this too is illegal: +For example, a user-defined datatype of trees data UserTree a = Node a +(UserTree a) (UserTree a) | Leaf gets the following representation: + - class Foo a where - op1 :: a -> Bool - op1 {| a :*: b |} (x :*: y) = True +instance Generic (UserTree a) where + -- Representation type + type Rep (UserTree a) = + M1 D D1UserTree ( + M1 C C1_0UserTree ( + M1 S NoSelector (K1 P a) + :*: M1 S NoSelector (K1 R (UserTree a)) + :*: M1 S NoSelector (K1 R (UserTree a))) + :+: M1 C C1_1UserTree U1) + + -- Conversion functions + from (Node x l r) = M1 (L1 (M1 (M1 (K1 x) :*: M1 (K1 l) :*: M1 (K1 r)))) + from Leaf = M1 (R1 (M1 U1)) + to (M1 (L1 (M1 (M1 (K1 x) :*: M1 (K1 l) :*: M1 (K1 r))))) = Node x l r + to (M1 (R1 (M1 U1))) = Leaf + +-- Meta-information +data D1UserTree +data C1_0UserTree +data C1_1UserTree + +instance Datatype D1UserTree where + datatypeName _ = "UserTree" + moduleName _ = "Main" - op2 :: a -> Bool - op2 {| p :*: q |} (x :*: y) = False +instance Constructor C1_0UserTree where + conName _ = "Node" + +instance Constructor C1_1UserTree where + conName _ = "Leaf" -(The reason for this restriction is that we gather all the equations for a particular type constructor -into a single generic instance declaration.) + +This representation is generated automatically if a +deriving Generic clause is attached to the datatype. +Standalone deriving can also be +used. - - + + + +Writing generic functions + -A generic method declaration must give a case for each of the three type constructors. +A generic function is defined by creating a class and giving instances for +each of the representation types of GHC.Generics. As an +example we show generic serialization: + +data Bin = O | I + +class GSerialize f where + gput :: f a -> [Bin] + +instance GSerialize U1 where + gput U1 = [] + +instance (GSerialize a, GSerialize b) => GSerialize (a :*: b) where + gput (x :*: y) = gput x ++ gput y + +instance (GSerialize a, GSerialize b) => GSerialize (a :+: b) where + gput (L1 x) = O : gput x + gput (R1 x) = I : gput x + +instance (GSerialize a) => GSerialize (M1 i c a) where + gput (M1 x) = gput x + +instance (Serialize a) => GSerialize (K1 i a) where + gput (K1 x) = put x + + +Typically this class will not be exported, as it only makes sense to have +instances for the representation types. - + + + +Generic defaults - -The type for a generic method can be built only from: - - Function arrows - Type variables - Tuples - Arbitrary types not involving type variables - -Here are some example type signatures for generic methods: +The only thing left to do now is to define a "front-end" class, which is +exposed to the user: + +class Serialize a where + put :: a -> [Bin] + + default put :: (Generic a, GSerialize (Rep a)) => a -> [Bit] + put = gput . from + +Here we use a default signature +to specify that the user does not have to provide an implementation for +put, as long as there is a Generic +instance for the type to instantiate. For the UserTree type, +for instance, the user can just write: + - op1 :: a -> Bool - op2 :: Bool -> (a,Bool) - op3 :: [Int] -> a -> a - op4 :: [a] -> Bool +instance (Serialize a) => Serialize (UserTree a) -Here, op1, op2, op3 are OK, but op4 is rejected, because it has a type variable -inside a list. + +The default method for put is then used, corresponding to the +generic implementation of serialization. + + + + +More information + -This restriction is an implementation restriction: we just haven't got around to -implementing the necessary bidirectional maps over arbitrary type constructors. -It would be relatively easy to add specific type constructors, such as Maybe and list, -to the ones that are allowed. - +For more detail please refer to the +HaskellWiki page +or the original paper: + + -In an instance declaration for a generic class, the idea is that the compiler -will fill in the methods for you, based on the generic templates. However it can only -do so if - - - - The instance type is simple (a type constructor applied to type variables, as in Haskell 98). - - - - - No constructor of the instance type has unboxed fields. - - - -(Of course, these things can only arise if you are already using GHC extensions.) -However, you can still give an instance declarations for types which break these rules, -provided you give explicit code to override any generic default methods. +Jose Pedro Magalhaes, Atze Dijkstra, Johan Jeuring, and Andres Loeh. + + A generic deriving mechanism for Haskell. +Proceedings of the third ACM Haskell symposium on Haskell +(Haskell'2010), pp. 37-48, ACM, 2010. - - - - -The option dumps incomprehensible stuff giving details of -what the compiler does with generic declarations. - +Note: the current support for generic programming in GHC +is preliminary. In particular, we only allow deriving instances for the +Generic class. Support for deriving +Generic1 (and thus enabling generic functions of kind +* -> * such as fmap) will come at a +later stage. - Another example - -Just to finish with, here's another example I rather like: - - class Tag a where - nCons :: a -> Int - nCons {| Unit |} _ = 1 - nCons {| a :*: b |} _ = 1 - nCons {| a :+: b |} _ = nCons (bot::a) + nCons (bot::b) - - tag :: a -> Int - tag {| Unit |} _ = 1 - tag {| a :*: b |} _ = 1 - tag {| a :+: b |} (Inl x) = tag x - tag {| a :+: b |} (Inr y) = nCons (bot::a) + tag y - - - + Control over monomorphism @@ -9217,7 +9377,7 @@ Switching off the dreaded Monomorphism Restriction -Haskell's monomorphism restriction (see +Haskell's monomorphism restriction (see Section 4.5.5 of the Haskell Report) @@ -9232,7 +9392,7 @@ As an experimental change, we are exploring the possibility of - making pattern bindings monomorphic; that is, not generalised at all. + making pattern bindings monomorphic; that is, not generalised at all. A pattern binding is a binding whose LHS has no function arguments, and is not a simple variable. For example: @@ -9252,7 +9412,6 @@ - diff -Nru ghc-7.0.3/docs/users_guide/separate_compilation.xml ghc-7.2.1/docs/users_guide/separate_compilation.xml --- ghc-7.0.3/docs/users_guide/separate_compilation.xml 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/docs/users_guide/separate_compilation.xml 2011-08-07 17:10:05.000000000 +0000 @@ -114,9 +114,9 @@ has been specified, then the object filename is dir/mod.osuf, where mod is the module name with - dots replaced by slashes. GHC will silently create the necessary directory + dots replaced by slashes. GHC will silently create the necessary directory structure underneath dir, if it does not - already exist. + already exist. @@ -273,7 +273,7 @@ If you use ghc --make and you don't use the , the name GHC will choose for the executable will be based on the name of the file - containing the module Main. + containing the module Main. Note that with GHC the Main module doesn't have to be put in file Main.hs. Thus both @@ -433,7 +433,7 @@ - + Keeping Intermediate Files intermediate files, saving @@ -461,9 +461,7 @@ Keep intermediate .hc files when doing .hs-to-.o compilations via C (NOTE: .hc files - aren't generated when using the native code generator, you - may need to use to force them - to be produced). + are only generated by unregisterised compilers). @@ -498,22 +496,6 @@ - , - - - - - - Keep intermediate .raw-s files. - These are the direct output from the C compiler, before - GHC does “assembly mangling” to produce the - .s file. Again, these are not produced - when using the native code generator. - - - - - temporary fileskeeping @@ -711,22 +693,22 @@ This section explains how. Every cycle in the module import graph must be broken by a hs-boot file. - Suppose that modules A.hs and B.hs are Haskell source files, + Suppose that modules A.hs and B.hs are Haskell source files, thus: module A where import B( TB(..) ) - + newtype TA = MkTA Int - + f :: TB -> TA f (MkTB x) = MkTA x module B where import {-# SOURCE #-} A( TA(..) ) - + data TB = MkTB !Int - + g :: TA -> TB g (MkTA x) = MkTB x @@ -768,12 +750,12 @@ ghc -c A.hs-boot -When a hs-boot file A.hs-boot +When a hs-boot file A.hs-boot is compiled, it is checked for scope and type errors. When its parent module A.hs is compiled, the two are compared, and an error is reported if the two are inconsistent. - + Just as compiling A.hs produces an interface file A.hi, and an object file @@ -811,7 +793,7 @@ ghc -M will report an error if a cycle is found. - A module M that is + A module M that is {-# SOURCE #-}-imported in a program will usually also be ordinarily imported elsewhere. If not, ghc --make automatically adds M to the set of modules it tries to @@ -830,9 +812,9 @@ A hs-boot file is written in a subset of Haskell: The module header (including the export list), and import statements, are exactly as in -Haskell, and so are the scoping rules. +Haskell, and so are the scoping rules. Hence, to mention a non-Prelude type or class, you must import it. - + There must be no value declarations, but there can be type signatures for values. For example: @@ -841,7 +823,7 @@ Fixity declarations are exactly as in Haskell. Type synonym declarations are exactly as in Haskell. - A data type declaration can either be given in full, exactly as in Haskell, or it + A data type declaration can either be given in full, exactly as in Haskell, or it can be given abstractly, by omitting the '=' sign and everything that follows. For example: data T a b @@ -853,7 +835,7 @@ You can also write out the constructors but, if you do so, you must write it out precisely as in its real definition. - If you do not write out the constructors, you may need to give a kind + If you do not write out the constructors, you may need to give a kind annotation (), to tell GHC the kind of the type variable, if it is not "*". (In source files, this is worked out from the way the type variable is used in the constructors.) For example: @@ -956,7 +938,7 @@ brought up to date. To bring it up to date, make looks for a rule to do so; one of the preceding suffix rules does the job nicely. These dependencies - can be generated automatically by ghc; see + can be generated automatically by ghc; see @@ -985,7 +967,7 @@ Makefile. In general, ghc -M Foo does the following. - For each module M in the set + For each module M in the set Foo plus all its imports (transitively), it adds to the Makefile: @@ -1008,7 +990,7 @@ (See for details of hi-boot style interface files.) - + If M imports multiple modules, then there will be multiple lines with M.o as the target. @@ -1145,7 +1127,7 @@ be a disaster in practice, so GHC tries to be clever. In particular, if an instance declaration is in the same module as the definition -of any type or class mentioned in the head of the instance declaration +of any type or class mentioned in the head of the instance declaration (the part after the “=>”; see ), then GHC has to visit that interface file anyway. Example: @@ -1196,8 +1178,8 @@ least one orphan rule. An instance declaration in a module M is an orphan instance if - orphan instance - + orphan instance + The class of the instance declaration is not declared in M, and @@ -1209,7 +1191,7 @@ - Only the instance head + Only the instance head counts. In the example above, it is not good enough for C's declaration to be in module A; it must be the declaration of D or T. @@ -1223,9 +1205,9 @@ -If you use the flag , GHC will warn you +If you use the flag , GHC will warn you if you are creating an orphan module. -Like any warning, you can switch the warning off with , +Like any warning, you can switch the warning off with , and will make the compilation fail if the warning is issued. diff -Nru ghc-7.0.3/docs/users_guide/shared_libs.xml ghc-7.2.1/docs/users_guide/shared_libs.xml --- ghc-7.0.3/docs/users_guide/shared_libs.xml 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/docs/users_guide/shared_libs.xml 2011-08-07 17:10:05.000000000 +0000 @@ -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 @@ -24,12 +24,10 @@ - In GHC version 6.12 building shared libraries is supported for Linux on - x86 and x86-64 architectures and there is partial support on Windows (see - ). The crucial difference in support on - Windows is that it is not currently possible to build each Haskell - package as a separate DLL, it is only possible to link an entire Haskell - program as one massive DLL. + In GHC version 6.12 building shared libraries is supported for Linux (on + x86 and x86-64 architectures). GHC version 7.0 adds support on Windows + (see ), FreeBSD and OpenBSD (x86 and x86-64), + Solaris (x86) and Mac OS X (x86 and PowerPC). @@ -59,7 +57,7 @@ that it can be linked against shared library versions of Haskell packages (such as base). The second is when linking, to link against the shared versions of the packages' libraries rather than the static - versions. Obviously this requires that the packages were build with + versions. Obviously this requires that the packages were built with shared libraries. On supported platforms GHC comes with shared libraries for all the core packages, but if you install extra packages (e.g. with Cabal) then they would also have to be built with shared @@ -87,10 +85,7 @@ In particular Haskell shared libraries must be made into packages. You cannot freely assign which modules go in which shared libraries. The Haskell shared libraries must match the package - boundaries. Most of the conventions GHC expects when using packages are - described in . - - + boundaries. The reason for this is that GHC handles references to symbols within the same shared library (or main executable binary) differently from references to symbols between different shared libraries. GHC @@ -118,8 +113,8 @@ Building Haskell code into a shared library is a good way to include Haskell code in a larger mixed-language project. While with static linking it is recommended to use GHC to perform the final link step, - with shared libaries a Haskell library can be treated just like any - other shared libary. The linking can be done using the normal system C + with shared libraries a Haskell library can be treated just like any + other shared library. The linking can be done using the normal system C compiler or linker. @@ -143,7 +138,7 @@ package. The -fPIC flag is required for all code that will end up in a shared library. The -shared flag specifies to make a shared library rather than a program. To make - this clearer we can break this down into separate compliation and link + this clearer we can break this down into separate compilation and link steps: ghc -dynamic -fPIC -c Foo.hs @@ -153,8 +148,6 @@ -dynamic in the link step. That means to statically link the rts all the base libraries into your new shared library. This would make a very big, but standalone shared library. - Indeed this is exactly what we must currently do on Windows where - -dynamic is not yet supported (see ). On most platforms however that would require all the static libraries to have been built with -fPIC so that the code is suitable to include into a shared library and we do not do that at the @@ -176,6 +169,8 @@ The details of how this works varies between platforms, in particular the three major systems: Unix ELF platforms, Windows and Mac OS X. + + Unix On Unix there are two mechanisms. Shared libraries can be installed into standard locations that the dynamic linker knows about. For @@ -184,26 +179,27 @@ is to use a "runtime path" or "rpath" embedded into programs and libraries themselves. These paths can either be absolute paths or on at least Linux and Solaris they can be paths relative to the program or - libary itself. In principle this makes it possible to construct fully + library itself. In principle this makes it possible to construct fully relocatable sets of programs and libraries. GHC has a -dynload linking flag to select the method that is used to find shared libraries at runtime. There are currently - three modes: + two modes: sysdep A system-dependent mode. This is also the default mode. On Unix - ELF systems this embeds rpaths into the shared library or - executable. In particular it uses absolute paths to where the - shared libraries for the rts and each package can be found. - This means the program can immediately be run and it will be - able to find the libraries it needs. However it may not be - suitable for deployment if the libraries are installed in a - different location on another machine. + ELF systems this embeds + RPATH/RUNPATH entries into the + shared library or executable. In particular it uses absolute paths to + where the shared libraries for the rts and each package can be found. + This means the program can immediately be run and it will be able to + find the libraries it needs. However it may not be suitable for + deployment if the libraries are installed in a different location on + another machine. @@ -220,8 +216,7 @@ To use relative paths for dependent libraries on Linux and Solaris you - can use the deploy mode and pass suitable a -rpath - flag to the linker: + can pass a suitable -rpath flag to the linker: ghc -dynamic Main.hs -o main -lfoo -L. -optl-Wl,-rpath,'$ORIGIN' @@ -232,7 +227,24 @@ executable e.g. -optl-Wl,-rpath,'$ORIGIN/lib'. - The standard assumption on Darwin/MacOS X is that dynamic libraries will + This relative path technique can be used with either of the two + -dynload modes, though it makes most sense with the + deploy mode. The difference is that with the + deploy mode, the above example will end up with an ELF + RUNPATH of just $ORIGIN while with + the sysdep mode the RUNPATH will be + $ORIGIN followed by all the library directories of all + the packages that the program depends on (e.g. base + and rts packages etc.) which are typically absolute + paths. The unix tool readelf --dynamic is handy for + inspecting the RPATH/RUNPATH + entries in ELF shared libraries and executables. + + + + Mac OS X + + The standard assumption on Darwin/Mac OS X is that dynamic libraries will be stamped at build time with an "install name", which is the full ultimate install path of the library file. Any libraries or executables that subsequently link against it (even if it hasn't been installed yet) @@ -244,6 +256,7 @@ for you. It automatically sets the install name for dynamic libraries to the absolute path of the ultimate install location. + diff -Nru ghc-7.0.3/docs/users_guide/sooner.xml ghc-7.2.1/docs/users_guide/sooner.xml --- ghc-7.0.3/docs/users_guide/sooner.xml 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/docs/users_guide/sooner.xml 2011-08-07 17:10:05.000000000 +0000 @@ -163,18 +163,6 @@ - Compile via C and crank up GCC: - - The native code-generator is designed to be quick, not - mind-bogglingly clever. Better to let GCC have a go, as it - tries much harder on register allocation, etc. - - So, when we want very fast code, we use: . - - - - Overloaded functions are not your friend: Haskell's overloading (using type classes) is elegant, diff -Nru ghc-7.0.3/docs/users_guide/ug-book.xml.in ghc-7.2.1/docs/users_guide/ug-book.xml.in --- ghc-7.0.3/docs/users_guide/ug-book.xml.in 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/docs/users_guide/ug-book.xml.in 2011-08-07 17:10:05.000000000 +0000 @@ -16,6 +16,7 @@ &sooner; &lang-features; &ffi-chap; +&extending-ghc; &wrong; &utils; &win32-dll; diff -Nru ghc-7.0.3/docs/users_guide/ug-ent.xml ghc-7.2.1/docs/users_guide/ug-ent.xml --- ghc-7.0.3/docs/users_guide/ug-ent.xml 2011-03-26 18:11:24.000000000 +0000 +++ ghc-7.2.1/docs/users_guide/ug-ent.xml 2011-08-07 17:11:44.000000000 +0000 @@ -3,9 +3,7 @@ - - - + @@ -15,6 +13,8 @@ + + @@ -24,6 +24,6 @@ - - + + diff -Nru ghc-7.0.3/docs/users_guide/ug-ent.xml.in ghc-7.2.1/docs/users_guide/ug-ent.xml.in --- ghc-7.0.3/docs/users_guide/ug-ent.xml.in 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/docs/users_guide/ug-ent.xml.in 2011-08-07 17:10:05.000000000 +0000 @@ -3,9 +3,7 @@ - - - + @@ -15,6 +13,8 @@ + + diff -Nru ghc-7.0.3/docs/users_guide/using.xml ghc-7.2.1/docs/users_guide/using.xml --- ghc-7.0.3/docs/users_guide/using.xml 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/docs/users_guide/using.xml 2011-08-07 17:10:05.000000000 +0000 @@ -78,7 +78,7 @@ Options overview - + GHC's behaviour is controlled by options, which for historical reasons are also sometimes referred to as command-line flags or arguments. @@ -86,11 +86,11 @@ Command-line arguments - + structure, command-line command-linearguments argumentscommand-line - + An invocation of GHC takes the following form: @@ -112,7 +112,7 @@ Command line options in source files - + source-file options Sometimes it is useful to make the connection between a @@ -130,7 +130,7 @@ module X where ... - + OPTIONS_GHC is a file-header pragma (see ). @@ -163,7 +163,7 @@ for more details. - + Static, Dynamic, and Mode options staticoptions @@ -204,14 +204,14 @@ - + The flag reference tables () lists the status of each flag. There are a few flags that are static except that they can also be used with GHCi's :set command; these are listed as “static/:set” in the - table. + table. @@ -266,7 +266,7 @@ compiler. - + .ll @@ -336,7 +336,7 @@ more detail in . - + ghc ––make @@ -375,7 +375,7 @@ more details. - + @@ -531,7 +531,7 @@ Using <command>ghc</command> <option>––make</option> separate compilation - + In this mode, GHC will build a multi-module Haskell program by following dependencies from one or more root modules (usually just Main). For example, if your @@ -583,7 +583,7 @@ source. - + Any of the command-line options described in the rest of this chapter can be used with , but note that any options @@ -596,7 +596,7 @@ (say, some auxiliary C code), then the object files can be given on the command line and GHC will include them when linking the executable. - + Note that GHC can only follow dependencies if it has the source file available, so if your program includes a module for which there is no source file, even if you have an object and an @@ -609,7 +609,7 @@ to add directories to the search path (see ). - + Expression evaluation mode @@ -633,7 +633,7 @@ ghc -e Main.main Main.hs - + or we can just use this mode to evaluate expressions in the context of the Prelude: @@ -646,22 +646,22 @@ Batch compiler mode - + In batch mode, GHC will compile one or more source files given on the command line. - + The first phase to run is determined by each input-file suffix, and the last phase is determined by a flag. If no relevant flag is present, then go all the way through to linking. This table summarises: - + - + Phase of the compilation system @@ -677,7 +677,7 @@ - .hs - + C pre-processor (opt.) .hs (with @@ -685,28 +685,28 @@ .hspp - + Haskell compiler .hs , .hc, .s - + C compiler (opt.) .hc or .c .s - + assembler .s .o - + linker other @@ -716,17 +716,17 @@ - + - + Thus, a common invocation would be: ghc -c Foo.hs - + to compile the Haskell source file Foo.hs to an object file Foo.o. @@ -741,7 +741,7 @@ flag turns it on. See for more details. - + Note: The option -E option runs just the pre-processing passes of the compiler, dumping the result in a file. @@ -783,18 +783,6 @@ - - - - - Does a dry-run, i.e. GHC goes through all the motions - of compiling as normal, but does not actually run any - external commands. - - - - - @@ -812,7 +800,7 @@ verify. - + n @@ -824,7 +812,7 @@ argument. Specifying on its own is equivalent to , and the other levels have the following meanings: - + @@ -874,7 +862,7 @@ - + @@ -990,9 +978,11 @@ not enabled by are , + , , , - , and + , + , . @@ -1010,7 +1000,7 @@ : - Makes any warning into a fatal error. Useful so that you don't + Makes any warning into a fatal error. Useful so that you don't miss warnings when doing batch compilation. @@ -1175,6 +1165,21 @@ + : + + + Causes the compiler to emit a warning when a Prelude numeric + conversion converts a type T to the same type T; such calls + are probably no-ops and can be omitted. The functions checked for + are: toInteger, + toRational, + fromIntegral, + and realToFrac. + + + + + : @@ -1200,27 +1205,41 @@ - : + , + : + + incomplete patterns, warning patterns, incomplete - Similarly for incomplete patterns, the functions - g and h below will fail when applied to + The option warns + about places where + a pattern-match might fail at runtime. + The function + g below will fail when applied to non-empty lists, so the compiler will emit a warning about this when is - enabled. - + enabled. g [] = 2 -h = \[] -> 2 - - This option isn't enabled by default because it can be + This option isn't enabled by default because it can be a bit noisy, and it doesn't always indicate a bug in the program. However, it's generally considered good practice - to cover all the cases in your functions. + to cover all the cases in your functions, and it is switched + on by . + + The flag is + similar, except that it + applies only to lambda-expressions and pattern bindings, constructs + that only allow a single pattern: + +h = \[] -> 2 +Just k = f y + + @@ -1269,6 +1288,39 @@ + + : + + missing import lists, warning + import lists, missing + + + + This flag warns if you use an unqualified + import declaration + that does not explicitly list the entities brought into scope. For + example + + +module M where + import X( f ) + import Y + import qualified Z + p x = f x x + + + The flag will warn about the import + of Y but not X + If module Y is later changed to export (say) f, + then the reference to f in M will become + ambiguous. No warning is produced for the import of Z + because extending Z's exports would be unlikely to produce + ambiguity in M. + + + + + : @@ -1287,7 +1339,7 @@ complexFn :: a -> a -> String complexFn x y = ... _simpleFn ... - The idea is that: (a) users of the class will only call complexFn; + The idea is that: (a) users of the class will only call complexFn; never _simpleFn; and (b) instance declarations can define either complexFn or _simpleFn. @@ -1309,11 +1361,25 @@ + : + + + type signatures, missing + + If you use the + flag GHC will warn + you about any polymorphic local bindings. As part of + the warning GHC also reports the inferred type. The + option is off by default. + + + + : shadowing, warning - + This option causes a warning to be emitted whenever an inner-scope value has the same name as an outer-scope value, i.e. the inner value shadows the outer one. This can catch @@ -1334,8 +1400,8 @@ orphan instances, warning orphan rules, warning - - This option causes a warning to be emitted whenever the + + This option causes a warning to be emitted whenever the module contains an "orphan" instance declaration or rewrite rule. An instance declaration is an orphan if it appears in a module in which neither the class nor the type being instanced are declared @@ -1344,7 +1410,7 @@ orphans is called an orphan module. The trouble with orphans is that GHC must pro-actively read the interface files for all orphan modules, just in case their instances or rules - play a role, whether or not the module's interface would otherwise + play a role, whether or not the module's interface would otherwise be of any use. See for details. @@ -1432,8 +1498,8 @@ which are unused. For top-level functions, the warning is only given if the binding is not exported. A definition is regarded as "used" if (a) it is exported, or (b) it is - mentioned in the right hand side of another definition that is used, or (c) the - function it defines begins with an underscore. The last case provides a + mentioned in the right hand side of another definition that is used, or (c) the + function it defines begins with an underscore. The last case provides a way to suppress unused-binding warnings selectively. Notice that a variable is reported as unused even if it appears in the right-hand side of another @@ -1481,7 +1547,7 @@ unused do binding, warning do binding, unused - Report expressions occuring in do and mdo blocks + Report expressions occurring in do and mdo blocks that appear to silently throw information away. For instance do { mapM popInt xs ; return 10 } would report the first statement in the do block as suspicious, @@ -1506,7 +1572,7 @@ apparently erroneous do binding, warning do binding, apparently erroneous - Report expressions occuring in do and mdo blocks + Report expressions occurring in do and mdo blocks that appear to lack a binding. For instance do { return (popInt 10) ; return 10 } would report the first statement in the do block as suspicious, @@ -1632,37 +1698,12 @@ . - - - - : - -Ofile <file> option - optimising, customised - - - (NOTE: not supported since GHC 4.x. Please ask if - you're interested in this.) - - For those who need absolute - control over exactly what options are - used (e.g., compiler writers, sometimes :-), a list of - options can be put in a file and then slurped in with - . - - In that file, comments are of the - #-to-end-of-line variety; blank - lines and most whitespace is ignored. - - Please ask if you are baffled and would like an - example of ! - - We don't use a flag for day-to-day work. We use to get respectable speed; e.g., when we want to measure something. When we want to go for - broke, we tend to use (and we go for + broke, we tend to use (and we go for lots of coffee breaks). The easiest way to see what (etc.) @@ -1817,7 +1858,7 @@ State# token as argument is considered to be single-entry, hence it is considered OK to inline things inside it. This can improve performance of IO and ST monad code, but it - runs the risk of reducing sharing. + runs the risk of reducing sharing. @@ -1881,10 +1922,10 @@ unfolding, controlling - (Default: 45) Governs the maximum size that GHC will + (Default: 45) Governs the maximum size that GHC will allow a function unfolding to be. (An unfolding has a “size” that reflects the cost in terms of - “code bloat” of expanding that unfolding at + “code bloat” of expanding that unfolding at a call site. A bigger function would be assigned a bigger cost.) @@ -1918,10 +1959,10 @@ - + - - &phases; + + &phases; &shared_libs; @@ -1981,7 +2022,7 @@ use GHC to compile and run parallel programs, in we describe the language features that affect parallelism. - + Compile-time options for SMP parallelism @@ -1989,7 +2030,7 @@ linked with the option (see ). Additionally, the following compiler options affect parallelism: - + @@ -2046,7 +2087,7 @@ results you find.. For example, on a dual-core machine we would probably use +RTS -N2 -RTS. - + Omitting x, i.e. +RTS -N -RTS, lets the runtime choose the value of x itself @@ -2106,28 +2147,9 @@ - - - RTS - option - - Migrate a thread to the current CPU when it is woken - up. Normally when a thread is woken up after being - blocked it will be scheduled on the CPU it was running on - last; this option allows the thread to immediately migrate - to the CPU that unblocked it. - - The rationale for allowing this eager migration is - that it tends to move threads that are communicating with - each other onto the same CPU; however there are - pathalogical situations where it turns out to be a poor - strategy. Depending on the communication pattern in your - program, it may or may not be a good idea. - - - + Hints for using SMP parallelism @@ -2183,27 +2205,6 @@ - - : - - (x86 only)-monly-N-regs - option (iX86 only) GHC tries to - “steal” four registers from GCC, for performance - reasons; it almost always works. However, when GCC is - compiling some modules with four stolen registers, it will - crash, probably saying: - - -Foo.hc:533: fixed or forbidden register was spilled. -This may be due to a compiler bug or to impossible asm -statements or clauses. - - - Just give some registers back with - . Try `3' first, then `2'. - If `2' doesn't work, please report the bug to us. - - @@ -2215,14 +2216,14 @@ intermediate code generation - GHC can dump its optimized intermediate code (said to be in “Core” format) + GHC can dump its optimized intermediate code (said to be in “Core” format) to a file as a side-effect of compilation. Non-GHC back-end tools can read and process Core files; these files have the suffix .hcr. The Core format is described in - An External Representation for the GHC Core Language, + An External Representation for the GHC Core Language, and sample tools for manipulating Core files (in Haskell) are available in the extcore package on Hackage. Note that the format of .hcr - files is different from the Core output format that GHC generates + files is different from the Core output format that GHC generates for debugging purposes (), though the two formats appear somewhat similar. The Core format natively supports notes which you can add to diff -Nru ghc-7.0.3/docs/users_guide/utils.xml ghc-7.2.1/docs/users_guide/utils.xml --- ghc-7.0.3/docs/users_guide/utils.xml 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/docs/users_guide/utils.xml 2011-08-07 17:10:05.000000000 +0000 @@ -270,6 +270,34 @@ + -k or + ––keep-files + + Proceed as normal, but do not delete any intermediate files. + + + + + -x or + ––cross-compile + + Activate cross-compilation mode (see ). + + + + + ––cross-safe + + Restrict the .hsc directives to those supported by the + --cross-compile mode (see ). + This should be useful if your .hsc files + must be safely cross-compiled and you wish to keep + non-cross-compilable constructs from creeping into them. + + + + + -? or ––help Display a summary of the available flags and exit successfully. @@ -544,6 +572,29 @@ + + Cross-compilation + + hsc2hs normally operates by creating, compiling, + and running a C program. That approach doesn't work when cross-compiling -- + in this case, the C compiler's generates code for the target machine, + not the host machine. For this situation, there's + a special mode hsc2hs --cross-compile which can generate + the .hs by extracting information from compilations only -- specifically, + whether or not compilation fails. + + + Only a subset of .hsc syntax is supported by + --cross-compile. The following are unsupported: + + #{const_str} + #{let} + #{def} + Custom constructs + + + + diff -Nru ghc-7.0.3/docs/users_guide/win32-dlls.xml ghc-7.2.1/docs/users_guide/win32-dlls.xml --- ghc-7.0.3/docs/users_guide/win32-dlls.xml 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/docs/users_guide/win32-dlls.xml 2011-08-07 17:10:05.000000000 +0000 @@ -23,7 +23,7 @@ Lazy + +#ifdef __GLASGOW_HASKELL__ +{-| +Convert a strict 'ST' computation into a lazy one. The strict state +thread passed to 'strictToLazyST' is not performed until the result of +the lazy state thread it returns is demanded. +-} +strictToLazyST :: ST.ST s a -> ST s a +strictToLazyST m = ST $ \s -> + let + pr = case s of { S# s# -> GHC.ST.liftST m s# } + r = case pr of { GHC.ST.STret _ v -> v } + s' = case pr of { GHC.ST.STret s2# _ -> S# s2# } + in + (r, s') + +{-| +Convert a lazy 'ST' computation into a strict one. +-} +lazyToStrictST :: ST s a -> ST.ST s a +lazyToStrictST (ST m) = GHC.ST.ST $ \s -> + case (m (S# s)) of (a, S# s') -> (# s', a #) +#endif + +-- | A monad transformer embedding lazy state transformers in the 'IO' +-- monad. The 'RealWorld' parameter indicates that the internal state +-- used by the 'ST' computation is a special one supplied by the 'IO' +-- monad, and thus distinct from those used by invocations of 'runST'. +stToIO :: ST RealWorld a -> IO a +stToIO = ST.stToIO . lazyToStrictST + +-- --------------------------------------------------------------------------- +-- Strict <--> Lazy + +#ifdef __GLASGOW_HASKELL__ +unsafeInterleaveST :: ST s a -> ST s a +unsafeInterleaveST = strictToLazyST . ST.unsafeInterleaveST . lazyToStrictST +#endif + +unsafeIOToST :: IO a -> ST s a +unsafeIOToST = strictToLazyST . ST.unsafeIOToST + + diff -Nru ghc-7.0.3/libraries/base/Control/Monad/ST/Lazy/Safe.hs ghc-7.2.1/libraries/base/Control/Monad/ST/Lazy/Safe.hs --- ghc-7.0.3/libraries/base/Control/Monad/ST/Lazy/Safe.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/base/Control/Monad/ST/Lazy/Safe.hs 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,36 @@ +{-# LANGUAGE Trustworthy #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.ST.Lazy.Safe +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : non-portable (requires universal quantification for runST) +-- +-- This module presents an identical interface to "Control.Monad.ST", +-- except that the monad delays evaluation of state operations until +-- a value depending on them is required. +-- +-- Safe API only. +-- +----------------------------------------------------------------------------- + +module Control.Monad.ST.Lazy.Safe ( + -- * The 'ST' monad + ST, + runST, + fixST, + + -- * Converting between strict and lazy 'ST' + strictToLazyST, lazyToStrictST, + + -- * Converting 'ST' To 'IO' + RealWorld, + stToIO, + ) where + +import Control.Monad.ST.Lazy.Imp + diff -Nru ghc-7.0.3/libraries/base/Control/Monad/ST/Lazy/Unsafe.hs ghc-7.2.1/libraries/base/Control/Monad/ST/Lazy/Unsafe.hs --- ghc-7.0.3/libraries/base/Control/Monad/ST/Lazy/Unsafe.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/base/Control/Monad/ST/Lazy/Unsafe.hs 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,26 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.ST.Lazy.Unsafe +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : non-portable (requires universal quantification for runST) +-- +-- This module presents an identical interface to "Control.Monad.ST", +-- except that the monad delays evaluation of state operations until +-- a value depending on them is required. +-- +-- Unsafe API. +-- +----------------------------------------------------------------------------- + +module Control.Monad.ST.Lazy.Unsafe ( + -- * Unsafe operations + unsafeInterleaveST, + unsafeIOToST + ) where + +import Control.Monad.ST.Lazy.Imp + diff -Nru ghc-7.0.3/libraries/base/Control/Monad/ST/Lazy.hs ghc-7.2.1/libraries/base/Control/Monad/ST/Lazy.hs --- ghc-7.0.3/libraries/base/Control/Monad/ST/Lazy.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/Control/Monad/ST/Lazy.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,3 +1,8 @@ +{-# LANGUAGE CPP, SafeImports #-} +#if sh_SAFE_DEFAULT +{-# LANGUAGE Safe #-} +#endif + ----------------------------------------------------------------------------- -- | -- Module : Control.Monad.ST.Lazy @@ -15,136 +20,28 @@ ----------------------------------------------------------------------------- module Control.Monad.ST.Lazy ( - -- * The 'ST' monad - ST, - runST, - fixST, - - -- * Converting between strict and lazy 'ST' - strictToLazyST, lazyToStrictST, - - -- * Converting 'ST' To 'IO' - RealWorld, - stToIO, - - -- * Unsafe operations - unsafeInterleaveST, - unsafeIOToST - ) where - -import Prelude - -import Control.Monad.Fix - -import qualified Control.Monad.ST as ST - -#ifdef __GLASGOW_HASKELL__ -import qualified GHC.ST -import GHC.Base -#endif - -#ifdef __HUGS__ -import Hugs.LazyST + module Control.Monad.ST.Lazy.Safe +#if !sh_SAFE_DEFAULT + -- * Unsafe Functions + , unsafeInterleaveST + , unsafeIOToST #endif + ) where -#ifdef __GLASGOW_HASKELL__ --- | The lazy state-transformer monad. --- A computation of type @'ST' s a@ transforms an internal state indexed --- by @s@, and returns a value of type @a@. --- The @s@ parameter is either --- --- * an unstantiated type variable (inside invocations of 'runST'), or --- --- * 'RealWorld' (inside invocations of 'stToIO'). --- --- It serves to keep the internal states of different invocations of --- 'runST' separate from each other and from invocations of 'stToIO'. --- --- The '>>=' and '>>' operations are not strict in the state. For example, --- --- @'runST' (writeSTRef _|_ v >>= readSTRef _|_ >> return 2) = 2@ -newtype ST s a = ST (State s -> (a, State s)) -data State s = S# (State# s) - -instance Functor (ST s) where - fmap f m = ST $ \ s -> - let - ST m_a = m - (r,new_s) = m_a s - in - (f r,new_s) - -instance Monad (ST s) where - - return a = ST $ \ s -> (a,s) - m >> k = m >>= \ _ -> k - fail s = error s - - (ST m) >>= k - = ST $ \ s -> - let - (r,new_s) = m s - ST k_a = k r - in - k_a new_s - -{-# NOINLINE runST #-} --- | Return the value computed by a state transformer computation. --- The @forall@ ensures that the internal state used by the 'ST' --- computation is inaccessible to the rest of the program. -runST :: (forall s. ST s a) -> a -runST st = case st of ST the_st -> let (r,_) = the_st (S# realWorld#) in r - --- | Allow the result of a state transformer computation to be used (lazily) --- inside the computation. --- Note that if @f@ is strict, @'fixST' f = _|_@. -fixST :: (a -> ST s a) -> ST s a -fixST m = ST (\ s -> - let - ST m_r = m r - (r,s') = m_r s - in - (r,s')) -#endif - -instance MonadFix (ST s) where - mfix = fixST - --- --------------------------------------------------------------------------- --- Strict <--> Lazy - -#ifdef __GLASGOW_HASKELL__ -{-| -Convert a strict 'ST' computation into a lazy one. The strict state -thread passed to 'strictToLazyST' is not performed until the result of -the lazy state thread it returns is demanded. --} -strictToLazyST :: ST.ST s a -> ST s a -strictToLazyST m = ST $ \s -> - let - pr = case s of { S# s# -> GHC.ST.liftST m s# } - r = case pr of { GHC.ST.STret _ v -> v } - s' = case pr of { GHC.ST.STret s2# _ -> S# s2# } - in - (r, s') - -{-| -Convert a lazy 'ST' computation into a strict one. --} -lazyToStrictST :: ST s a -> ST.ST s a -lazyToStrictST (ST m) = GHC.ST.ST $ \s -> - case (m (S# s)) of (a, S# s') -> (# s', a #) +import safe Control.Monad.ST.Lazy.Safe +#if !sh_SAFE_DEFAULT +import qualified Control.Monad.ST.Lazy.Unsafe as U + +{-# DEPRECATED unsafeInterleaveST, unsafeIOToST + "Please import from Control.Monad.ST.Lazy.Unsafe instead; This will be removed in the next release" + #-} +{-# INLINE unsafeInterleaveST #-} unsafeInterleaveST :: ST s a -> ST s a -unsafeInterleaveST = strictToLazyST . ST.unsafeInterleaveST . lazyToStrictST -#endif +unsafeInterleaveST = U.unsafeInterleaveST +{-# INLINE unsafeIOToST #-} unsafeIOToST :: IO a -> ST s a -unsafeIOToST = strictToLazyST . ST.unsafeIOToST +unsafeIOToST = U.unsafeIOToST +#endif --- | A monad transformer embedding lazy state transformers in the 'IO' --- monad. The 'RealWorld' parameter indicates that the internal state --- used by the 'ST' computation is a special one supplied by the 'IO' --- monad, and thus distinct from those used by invocations of 'runST'. -stToIO :: ST RealWorld a -> IO a -stToIO = ST.stToIO . lazyToStrictST diff -Nru ghc-7.0.3/libraries/base/Control/Monad/ST/Safe.hs ghc-7.2.1/libraries/base/Control/Monad/ST/Safe.hs --- ghc-7.0.3/libraries/base/Control/Monad/ST/Safe.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/base/Control/Monad/ST/Safe.hs 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,33 @@ +{-# LANGUAGE Trustworthy #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.ST.Safe +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (requires universal quantification for runST) +-- +-- This library provides support for /strict/ state threads, as +-- described in the PLDI \'94 paper by John Launchbury and Simon Peyton +-- Jones /Lazy Functional State Threads/. +-- +-- Safe API Only. +-- +----------------------------------------------------------------------------- + +module Control.Monad.ST.Safe ( + -- * The 'ST' Monad + ST, -- abstract, instance of Functor, Monad, Typeable. + runST, -- :: (forall s. ST s a) -> a + fixST, -- :: (a -> ST s a) -> ST s a + + -- * Converting 'ST' to 'IO' + RealWorld, -- abstract + stToIO, -- :: ST RealWorld a -> IO a + ) where + +import Control.Monad.ST.Imp + diff -Nru ghc-7.0.3/libraries/base/Control/Monad/ST/Strict.hs ghc-7.2.1/libraries/base/Control/Monad/ST/Strict.hs --- ghc-7.0.3/libraries/base/Control/Monad/ST/Strict.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/Control/Monad/ST/Strict.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,9 +1,13 @@ +{-# LANGUAGE CPP #-} +#if sh_SAFE_DEFAULT +{-# LANGUAGE Safe #-} +#endif ----------------------------------------------------------------------------- -- | -- Module : Control.Monad.ST.Strict -- Copyright : (c) The University of Glasgow 2001 -- License : BSD-style (see the file libraries/base/LICENSE) --- +-- -- Maintainer : libraries@haskell.org -- Stability : provisional -- Portability : non-portable (requires universal quantification for runST) @@ -16,4 +20,9 @@ module Control.Monad.ST ) where +#if sh_SAFE_DEFAULT +import safe Control.Monad.ST +#else import Control.Monad.ST +#endif + diff -Nru ghc-7.0.3/libraries/base/Control/Monad/ST/Unsafe.hs ghc-7.2.1/libraries/base/Control/Monad/ST/Unsafe.hs --- ghc-7.0.3/libraries/base/Control/Monad/ST/Unsafe.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/base/Control/Monad/ST/Unsafe.hs 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,27 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.ST.Unsafe +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (requires universal quantification for runST) +-- +-- This library provides support for /strict/ state threads, as +-- described in the PLDI \'94 paper by John Launchbury and Simon Peyton +-- Jones /Lazy Functional State Threads/. +-- +-- Unsafe API. +-- +----------------------------------------------------------------------------- + +module Control.Monad.ST.Unsafe ( + -- * Unsafe operations + unsafeInterleaveST, + unsafeIOToST, + unsafeSTToIO + ) where + +import Control.Monad.ST.Imp + diff -Nru ghc-7.0.3/libraries/base/Control/Monad/ST.hs ghc-7.2.1/libraries/base/Control/Monad/ST.hs --- ghc-7.0.3/libraries/base/Control/Monad/ST.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/Control/Monad/ST.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,9 +1,14 @@ +{-# LANGUAGE CPP, SafeImports #-} +#if sh_SAFE_DEFAULT +{-# LANGUAGE Safe #-} +#endif + ----------------------------------------------------------------------------- -- | -- Module : Control.Monad.ST -- Copyright : (c) The University of Glasgow 2001 -- License : BSD-style (see the file libraries/base/LICENSE) --- +-- -- Maintainer : libraries@haskell.org -- Stability : experimental -- Portability : non-portable (requires universal quantification for runST) @@ -14,55 +19,35 @@ -- ----------------------------------------------------------------------------- -module Control.Monad.ST - ( - -- * The 'ST' Monad - ST, -- abstract, instance of Functor, Monad, Typeable. - runST, -- :: (forall s. ST s a) -> a - fixST, -- :: (a -> ST s a) -> ST s a - - -- * Converting 'ST' to 'IO' - RealWorld, -- abstract - stToIO, -- :: ST RealWorld a -> IO a - - -- * Unsafe operations - unsafeInterleaveST, -- :: ST s a -> ST s a - unsafeIOToST, -- :: IO a -> ST s a - unsafeSTToIO -- :: ST s a -> IO a - ) where - -#if defined(__GLASGOW_HASKELL__) -import Control.Monad.Fix () -#else -import Control.Monad.Fix +module Control.Monad.ST ( + module Control.Monad.ST.Safe +#if !sh_SAFE_DEFAULT + -- * Unsafe Functions + , unsafeInterleaveST + , unsafeIOToST + , unsafeSTToIO #endif + ) where -#include "Typeable.h" +import safe Control.Monad.ST.Safe -#if defined(__GLASGOW_HASKELL__) -import GHC.ST ( ST, runST, fixST, unsafeInterleaveST ) -import GHC.Base ( RealWorld ) -import GHC.IO ( stToIO, unsafeIOToST, unsafeSTToIO ) -#elif defined(__HUGS__) -import Data.Typeable -import Hugs.ST -import qualified Hugs.LazyST as LazyST -#endif - -#if defined(__HUGS__) -INSTANCE_TYPEABLE2(ST,sTTc,"ST") -INSTANCE_TYPEABLE0(RealWorld,realWorldTc,"RealWorld") +#if !sh_SAFE_DEFAULT +import qualified Control.Monad.ST.Unsafe as U -fixST :: (a -> ST s a) -> ST s a -fixST f = LazyST.lazyToStrictST (LazyST.fixST (LazyST.strictToLazyST . f)) +{-# DEPRECATED unsafeInterleaveST, unsafeIOToST, unsafeSTToIO + "Please import from Control.Monad.ST.Unsafe instead; This will be removed in the next release" + #-} +{-# INLINE unsafeInterleaveST #-} unsafeInterleaveST :: ST s a -> ST s a -unsafeInterleaveST = - LazyST.lazyToStrictST . LazyST.unsafeInterleaveST . LazyST.strictToLazyST -#endif +unsafeInterleaveST = U.unsafeInterleaveST -#if !defined(__GLASGOW_HASKELL__) -instance MonadFix (ST s) where - mfix = fixST +{-# INLINE unsafeIOToST #-} +unsafeIOToST :: IO a -> ST s a +unsafeIOToST = U.unsafeIOToST + +{-# INLINE unsafeSTToIO #-} +unsafeSTToIO :: ST s a -> IO a +unsafeSTToIO = U.unsafeSTToIO #endif diff -Nru ghc-7.0.3/libraries/base/Control/Monad/Zip.hs ghc-7.2.1/libraries/base/Control/Monad/Zip.hs --- ghc-7.0.3/libraries/base/Control/Monad/Zip.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/base/Control/Monad/Zip.hs 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,53 @@ +{-# LANGUAGE Safe #-} +----------------------------------------------------------------------------- +-- | +-- Module : Control.Monad.Zip +-- Copyright : (c) Nils Schweinsberg 2011, +-- (c) George Giorgidze 2011 +-- (c) University Tuebingen 2011 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : portable +-- +-- Monadic zipping (used for monad comprehensions) +-- +----------------------------------------------------------------------------- + +module Control.Monad.Zip where + +import Prelude +import Control.Monad (liftM) + +-- | `MonadZip` type class. Minimal definition: `mzip` or `mzipWith` +-- +-- Instances should satisfy the laws: +-- +-- * Naturality : +-- +-- > liftM (f *** g) (mzip ma mb) = mzip (liftM f ma) (liftM g mb) +-- +-- * Information Preservation: +-- +-- > liftM (const ()) ma = liftM (const ()) mb +-- > ==> +-- > munzip (mzip ma mb) = (ma, mb) +-- +class Monad m => MonadZip m where + + mzip :: m a -> m b -> m (a,b) + mzip = mzipWith (,) + + mzipWith :: (a -> b -> c) -> m a -> m b -> m c + mzipWith f ma mb = liftM (uncurry f) (mzip ma mb) + + munzip :: m (a,b) -> (m a, m b) + munzip mab = (liftM fst mab, liftM snd mab) + -- munzip is a member of the class because sometimes + -- you can implement it more efficiently than the + -- above default code. See Trac #4370 comment by giorgidze + +instance MonadZip [] where + mzip = zip + mzipWith = zipWith + munzip = unzip diff -Nru ghc-7.0.3/libraries/base/Control/Monad.hs ghc-7.2.1/libraries/base/Control/Monad.hs --- ghc-7.0.3/libraries/base/Control/Monad.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/Control/Monad.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,6 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude #-} + ----------------------------------------------------------------------------- -- | -- Module : Control.Monad @@ -188,8 +190,26 @@ -- | @'forever' act@ repeats the action infinitely. forever :: (Monad m) => m a -> m b +{-# INLINABLE forever #-} -- See Note [Make forever INLINABLE] forever a = a >> forever a +{- Note [Make forever INLINABLE] + +If you say x = forever a +you'll get x = a >> a >> a >> a >> ... etc ... +and that can make a massive space leak (see Trac #5205) + +In some monads, where (>>) is expensive, this might be the right +thing, but not in the IO monad. We want to specialise 'forever' for +the IO monad, so that eta expansion happens and there's no space leak. +To achieve this we must make forever INLINABLE, so that it'll get +specialised at call sites. + +Still delicate, though, because it depends on optimisation. But there +really is a space/time tradeoff here, and only optimisation reveals +the "right" answer. +-} + -- | @'void' value@ discards or ignores the result of evaluation, such as the return value of an 'IO' action. void :: Functor f => f a -> f () void = fmap (const ()) diff -Nru ghc-7.0.3/libraries/base/Control/OldException.hs ghc-7.2.1/libraries/base/Control/OldException.hs --- ghc-7.0.3/libraries/base/Control/OldException.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/Control/OldException.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,12 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP + , NoImplicitPrelude + , ForeignFunctionInterface + , ExistentialQuantification + #-} +#ifdef __GLASGOW_HASKELL__ +{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} +#endif #include "Typeable.h" diff -Nru ghc-7.0.3/libraries/base/Data/Bits.hs ghc-7.2.1/libraries/base/Data/Bits.hs --- ghc-7.0.3/libraries/base/Data/Bits.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/Data/Bits.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,6 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude, BangPatterns, MagicHash #-} + ----------------------------------------------------------------------------- -- | -- Module : Data.Bits diff -Nru ghc-7.0.3/libraries/base/Data/Bool.hs ghc-7.2.1/libraries/base/Data/Bool.hs --- ghc-7.0.3/libraries/base/Data/Bool.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/Data/Bool.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,6 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude #-} + ----------------------------------------------------------------------------- -- | -- Module : Data.Bool diff -Nru ghc-7.0.3/libraries/base/Data/Char.hs ghc-7.2.1/libraries/base/Data/Char.hs --- ghc-7.0.3/libraries/base/Data/Char.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/Data/Char.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,6 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude #-} + ----------------------------------------------------------------------------- -- | -- Module : Data.Char @@ -17,8 +19,6 @@ ( Char - , String - -- * Character classification -- | Unicode characters are divided into letters, numbers, marks, -- punctuation, symbols, separators (including spaces) and others diff -Nru ghc-7.0.3/libraries/base/Data/Complex.hs ghc-7.2.1/libraries/base/Data/Complex.hs --- ghc-7.0.3/libraries/base/Data/Complex.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/Data/Complex.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,3 +1,9 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, DeriveDataTypeable #-} +#ifdef __GLASGOW_HASKELL__ +{-# LANGUAGE StandaloneDeriving #-} +#endif + ----------------------------------------------------------------------------- -- | -- Module : Data.Complex @@ -62,7 +68,7 @@ -- For a complex number @z@, @'abs' z@ is a number with the magnitude of @z@, -- but oriented in the positive real direction, whereas @'signum' z@ -- has the phase of @z@, but unit magnitude. -data (RealFloat a) => Complex a +data Complex a = !a :+ !a -- ^ forms a complex number from its real and imaginary -- rectangular components. # if __GLASGOW_HASKELL__ diff -Nru ghc-7.0.3/libraries/base/Data/Data.hs ghc-7.2.1/libraries/base/Data/Data.hs --- ghc-7.0.3/libraries/base/Data/Data.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/Data/Data.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,3 +1,6 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, Rank2Types, ScopedTypeVariables #-} + ----------------------------------------------------------------------------- -- | -- Module : Data.Data @@ -585,7 +588,7 @@ (IntRep, IntConstr i) -> mkIntConstr dt i (FloatRep, FloatConstr f) -> mkRealConstr dt f (CharRep, CharConstr c) -> mkCharConstr dt c - _ -> error "repConstr" + _ -> error "Data.Data.repConstr" @@ -623,7 +626,7 @@ dataTypeConstrs :: DataType -> [Constr] dataTypeConstrs dt = case datarep dt of (AlgRep cons) -> cons - _ -> error "dataTypeConstrs" + _ -> error "Data.Data.dataTypeConstrs" -- | Gets the field labels of a constructor. The list of labels @@ -696,21 +699,21 @@ indexConstr :: DataType -> ConIndex -> Constr indexConstr dt idx = case datarep dt of (AlgRep cs) -> cs !! (idx-1) - _ -> error "indexConstr" + _ -> error "Data.Data.indexConstr" -- | Gets the index of a constructor (algebraic datatypes only) constrIndex :: Constr -> ConIndex constrIndex con = case constrRep con of (AlgConstr idx) -> idx - _ -> error "constrIndex" + _ -> error "Data.Data.constrIndex" -- | Gets the maximum constructor index of an algebraic datatype maxConstrIndex :: DataType -> ConIndex maxConstrIndex dt = case dataTypeRep dt of AlgRep cs -> length cs - _ -> error "maxConstrIndex" + _ -> error "Data.Data.maxConstrIndex" @@ -755,8 +758,8 @@ { datatype = dt , conrep = cr , constring = str - , confields = error "constrFields" - , confixity = error "constrFixity" + , confields = error "Data.Data.confields" + , confixity = error "Data.Data.confixity" } -- | This function is now deprecated. Please use 'mkIntegralConstr' instead. @@ -767,7 +770,7 @@ mkIntegralConstr :: (Integral a) => DataType -> a -> Constr mkIntegralConstr dt i = case datarep dt of IntRep -> mkPrimCon dt (show i) (IntConstr (toInteger i)) - _ -> error "mkIntegralConstr" + _ -> error "Data.Data.mkIntegralConstr" -- | This function is now deprecated. Please use 'mkRealConstr' instead. {-# DEPRECATED mkFloatConstr "Use mkRealConstr instead" #-} @@ -777,7 +780,7 @@ mkRealConstr :: (Real a) => DataType -> a -> Constr mkRealConstr dt f = case datarep dt of FloatRep -> mkPrimCon dt (show f) (FloatConstr (toRational f)) - _ -> error "mkRealConstr" + _ -> error "Data.Data.mkRealConstr" -- | This function is now deprecated. Please use 'mkCharConstr' instead. {-# DEPRECATED mkStringConstr "Use mkCharConstr instead" #-} @@ -786,14 +789,14 @@ case datarep dt of CharRep -> case str of [c] -> mkPrimCon dt (show c) (CharConstr c) - _ -> error "mkStringConstr: input String must contain a single character" - _ -> error "mkStringConstr" + _ -> error "Data.Data.mkStringConstr: input String must contain a single character" + _ -> error "Data.Data.mkStringConstr" -- | Makes a constructor for 'Char'. mkCharConstr :: DataType -> Char -> Constr mkCharConstr dt c = case datarep dt of CharRep -> mkPrimCon dt (show c) (CharConstr c) - _ -> error "mkCharConstr" + _ -> error "Data.Data.mkCharConstr" ------------------------------------------------------------------------------ @@ -878,7 +881,7 @@ gunfold _ z c = case constrIndex c of 1 -> z False 2 -> z True - _ -> error "gunfold" + _ -> error "Data.Data.gunfold(Bool)" dataTypeOf _ = boolDataType @@ -891,7 +894,7 @@ toConstr x = mkCharConstr charType x gunfold _ z c = case constrRep c of (CharConstr x) -> z x - _ -> error "gunfold" + _ -> error "Data.Data.gunfold(Char)" dataTypeOf _ = charType @@ -904,7 +907,7 @@ toConstr = mkRealConstr floatType gunfold _ z c = case constrRep c of (FloatConstr x) -> z (realToFrac x) - _ -> error "gunfold" + _ -> error "Data.Data.gunfold(Float)" dataTypeOf _ = floatType @@ -917,7 +920,7 @@ toConstr = mkRealConstr doubleType gunfold _ z c = case constrRep c of (FloatConstr x) -> z (realToFrac x) - _ -> error "gunfold" + _ -> error "Data.Data.gunfold(Double)" dataTypeOf _ = doubleType @@ -930,7 +933,7 @@ toConstr x = mkIntConstr intType (fromIntegral x) gunfold _ z c = case constrRep c of (IntConstr x) -> z (fromIntegral x) - _ -> error "gunfold" + _ -> error "Data.Data.gunfold(Int)" dataTypeOf _ = intType @@ -943,7 +946,7 @@ toConstr = mkIntConstr integerType gunfold _ z c = case constrRep c of (IntConstr x) -> z x - _ -> error "gunfold" + _ -> error "Data.Data.gunfold(Integer)" dataTypeOf _ = integerType @@ -956,7 +959,7 @@ toConstr x = mkIntConstr int8Type (fromIntegral x) gunfold _ z c = case constrRep c of (IntConstr x) -> z (fromIntegral x) - _ -> error "gunfold" + _ -> error "Data.Data.gunfold(Int8)" dataTypeOf _ = int8Type @@ -969,7 +972,7 @@ toConstr x = mkIntConstr int16Type (fromIntegral x) gunfold _ z c = case constrRep c of (IntConstr x) -> z (fromIntegral x) - _ -> error "gunfold" + _ -> error "Data.Data.gunfold(Int16)" dataTypeOf _ = int16Type @@ -982,7 +985,7 @@ toConstr x = mkIntConstr int32Type (fromIntegral x) gunfold _ z c = case constrRep c of (IntConstr x) -> z (fromIntegral x) - _ -> error "gunfold" + _ -> error "Data.Data.gunfold(Int32)" dataTypeOf _ = int32Type @@ -995,7 +998,7 @@ toConstr x = mkIntConstr int64Type (fromIntegral x) gunfold _ z c = case constrRep c of (IntConstr x) -> z (fromIntegral x) - _ -> error "gunfold" + _ -> error "Data.Data.gunfold(Int64)" dataTypeOf _ = int64Type @@ -1008,7 +1011,7 @@ toConstr x = mkIntConstr wordType (fromIntegral x) gunfold _ z c = case constrRep c of (IntConstr x) -> z (fromIntegral x) - _ -> error "gunfold" + _ -> error "Data.Data.gunfold(Word)" dataTypeOf _ = wordType @@ -1021,7 +1024,7 @@ toConstr x = mkIntConstr word8Type (fromIntegral x) gunfold _ z c = case constrRep c of (IntConstr x) -> z (fromIntegral x) - _ -> error "gunfold" + _ -> error "Data.Data.gunfold(Word8)" dataTypeOf _ = word8Type @@ -1034,7 +1037,7 @@ toConstr x = mkIntConstr word16Type (fromIntegral x) gunfold _ z c = case constrRep c of (IntConstr x) -> z (fromIntegral x) - _ -> error "gunfold" + _ -> error "Data.Data.gunfold(Word16)" dataTypeOf _ = word16Type @@ -1047,7 +1050,7 @@ toConstr x = mkIntConstr word32Type (fromIntegral x) gunfold _ z c = case constrRep c of (IntConstr x) -> z (fromIntegral x) - _ -> error "gunfold" + _ -> error "Data.Data.gunfold(Word32)" dataTypeOf _ = word32Type @@ -1060,7 +1063,7 @@ toConstr x = mkIntConstr word64Type (fromIntegral x) gunfold _ z c = case constrRep c of (IntConstr x) -> z (fromIntegral x) - _ -> error "gunfold" + _ -> error "Data.Data.gunfold(Word64)" dataTypeOf _ = word64Type @@ -1076,7 +1079,7 @@ gfoldl k z (a :% b) = z (:%) `k` a `k` b toConstr _ = ratioConstr gunfold k z c | constrIndex c == 1 = k (k (z (:%))) - gunfold _ _ _ = error "gunfold" + gunfold _ _ _ = error "Data.Data.gunfold(Ratio)" dataTypeOf _ = ratioDataType @@ -1098,7 +1101,7 @@ gunfold k z c = case constrIndex c of 1 -> z [] 2 -> k (k (z (:))) - _ -> error "gunfold" + _ -> error "Data.Data.gunfold(List)" dataTypeOf _ = listDataType dataCast1 f = gcast1 f @@ -1132,7 +1135,7 @@ gunfold k z c = case constrIndex c of 1 -> z Nothing 2 -> k (z Just) - _ -> error "gunfold" + _ -> error "Data.Data.gunfold(Maybe)" dataTypeOf _ = maybeDataType dataCast1 f = gcast1 f @@ -1160,7 +1163,7 @@ 1 -> z LT 2 -> z EQ 3 -> z GT - _ -> error "gunfold" + _ -> error "Data.Data.gunfold(Ordering)" dataTypeOf _ = orderingDataType @@ -1183,7 +1186,7 @@ gunfold k z c = case constrIndex c of 1 -> k (z Left) 2 -> k (z Right) - _ -> error "gunfold" + _ -> error "Data.Data.gunfold(Either)" dataTypeOf _ = eitherDataType dataCast2 f = gcast2 f @@ -1199,7 +1202,7 @@ instance Data () where toConstr () = tuple0Constr gunfold _ z c | constrIndex c == 1 = z () - gunfold _ _ _ = error "gunfold" + gunfold _ _ _ = error "Data.Data.gunfold(unit)" dataTypeOf _ = tuple0DataType @@ -1215,7 +1218,7 @@ gfoldl f z (a,b) = z (,) `f` a `f` b toConstr (_,_) = tuple2Constr gunfold k z c | constrIndex c == 1 = k (k (z (,))) - gunfold _ _ _ = error "gunfold" + gunfold _ _ _ = error "Data.Data.gunfold(tup2)" dataTypeOf _ = tuple2DataType dataCast2 f = gcast2 f @@ -1232,7 +1235,7 @@ gfoldl f z (a,b,c) = z (,,) `f` a `f` b `f` c toConstr (_,_,_) = tuple3Constr gunfold k z c | constrIndex c == 1 = k (k (k (z (,,)))) - gunfold _ _ _ = error "gunfold" + gunfold _ _ _ = error "Data.Data.gunfold(tup3)" dataTypeOf _ = tuple3DataType @@ -1250,7 +1253,7 @@ toConstr (_,_,_,_) = tuple4Constr gunfold k z c = case constrIndex c of 1 -> k (k (k (k (z (,,,))))) - _ -> error "gunfold" + _ -> error "Data.Data.gunfold(tup4)" dataTypeOf _ = tuple4DataType @@ -1268,7 +1271,7 @@ toConstr (_,_,_,_,_) = tuple5Constr gunfold k z c = case constrIndex c of 1 -> k (k (k (k (k (z (,,,,)))))) - _ -> error "gunfold" + _ -> error "Data.Data.gunfold(tup5)" dataTypeOf _ = tuple5DataType @@ -1286,7 +1289,7 @@ toConstr (_,_,_,_,_,_) = tuple6Constr gunfold k z c = case constrIndex c of 1 -> k (k (k (k (k (k (z (,,,,,))))))) - _ -> error "gunfold" + _ -> error "Data.Data.gunfold(tup6)" dataTypeOf _ = tuple6DataType @@ -1305,23 +1308,23 @@ toConstr (_,_,_,_,_,_,_) = tuple7Constr gunfold k z c = case constrIndex c of 1 -> k (k (k (k (k (k (k (z (,,,,,,)))))))) - _ -> error "gunfold" + _ -> error "Data.Data.gunfold(tup7)" dataTypeOf _ = tuple7DataType ------------------------------------------------------------------------------ instance Typeable a => Data (Ptr a) where - toConstr _ = error "toConstr" - gunfold _ _ = error "gunfold" + toConstr _ = error "Data.Data.toConstr(Ptr)" + gunfold _ _ = error "Data.Data.gunfold(Ptr)" dataTypeOf _ = mkNoRepType "GHC.Ptr.Ptr" ------------------------------------------------------------------------------ instance Typeable a => Data (ForeignPtr a) where - toConstr _ = error "toConstr" - gunfold _ _ = error "gunfold" + toConstr _ = error "Data.Data.toConstr(ForeignPtr)" + gunfold _ _ = error "Data.Data.gunfold(ForeignPtr)" dataTypeOf _ = mkNoRepType "GHC.ForeignPtr.ForeignPtr" @@ -1331,7 +1334,7 @@ instance (Typeable a, Data b, Ix a) => Data (Array a b) where gfoldl f z a = z (listArray (bounds a)) `f` (elems a) - toConstr _ = error "toConstr" - gunfold _ _ = error "gunfold" + toConstr _ = error "Data.Data.toConstr(Array)" + gunfold _ _ = error "Data.Data.gunfold(Array)" dataTypeOf _ = mkNoRepType "Data.Array.Array" diff -Nru ghc-7.0.3/libraries/base/Data/Dynamic.hs ghc-7.2.1/libraries/base/Data/Dynamic.hs --- ghc-7.0.3/libraries/base/Data/Dynamic.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/Data/Dynamic.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,9 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude #-} +#ifdef __GLASGOW_HASKELL__ +{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} +#endif + ----------------------------------------------------------------------------- -- | -- Module : Data.Dynamic diff -Nru ghc-7.0.3/libraries/base/Data/Either.hs ghc-7.2.1/libraries/base/Data/Either.hs --- ghc-7.0.3/libraries/base/Data/Either.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/Data/Either.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,9 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude #-} +#ifdef __GLASGOW_HASKELL__ +{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, StandaloneDeriving #-} +#endif + ----------------------------------------------------------------------------- -- | -- Module : Data.Either @@ -30,6 +35,7 @@ #endif import Data.Typeable +import GHC.Generics (Generic) #ifdef __GLASGOW_HASKELL__ {- @@ -47,7 +53,8 @@ used to hold an error value and the 'Right' constructor is used to hold a correct value (mnemonic: \"right\" also means \"correct\"). -} -data Either a b = Left a | Right b deriving (Eq, Ord, Read, Show) +data Either a b = Left a | Right b + deriving (Eq, Ord, Read, Show, Generic) -- | Case analysis for the 'Either' type. -- If the value is @'Left' a@, apply the first function to @a@; diff -Nru ghc-7.0.3/libraries/base/Data/Eq.hs ghc-7.2.1/libraries/base/Data/Eq.hs --- ghc-7.0.3/libraries/base/Data/Eq.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/Data/Eq.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,6 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude #-} + ----------------------------------------------------------------------------- -- | -- Module : Data.Eq diff -Nru ghc-7.0.3/libraries/base/Data/Fixed.hs ghc-7.2.1/libraries/base/Data/Fixed.hs --- ghc-7.0.3/libraries/base/Data/Fixed.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/Data/Fixed.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,5 +1,10 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP #-} {-# OPTIONS -Wall -fno-warn-unused-binds #-} +#ifndef __NHC__ +{-# LANGUAGE DeriveDataTypeable #-} +#endif ----------------------------------------------------------------------------- -- | -- Module : Data.Fixed @@ -35,6 +40,8 @@ ) where import Prelude -- necessary to get dependencies right +import Data.Char +import Data.List #ifndef __NHC__ import Data.Typeable import Data.Data @@ -152,9 +159,30 @@ maxnum = 10 ^ digits fracNum = div (d * maxnum) res +readsFixed :: (HasResolution a) => ReadS (Fixed a) +readsFixed = readsSigned + where readsSigned ('-' : xs) = [ (negate x, rest) + | (x, rest) <- readsUnsigned xs ] + readsSigned xs = readsUnsigned xs + readsUnsigned xs = case span isDigit xs of + ([], _) -> [] + (is, xs') -> + let i = fromInteger (read is) + in case xs' of + '.' : xs'' -> + case span isDigit xs'' of + ([], _) -> [] + (js, xs''') -> + let j = fromInteger (read js) + l = genericLength js :: Integer + in [(i + (j / (10 ^ l)), xs''')] + _ -> [(i, xs')] + instance (HasResolution a) => Show (Fixed a) where show = showFixed False +instance (HasResolution a) => Read (Fixed a) where + readsPrec _ = readsFixed data E0 = E0 #ifndef __NHC__ diff -Nru ghc-7.0.3/libraries/base/Data/Foldable.hs ghc-7.2.1/libraries/base/Data/Foldable.hs --- ghc-7.0.3/libraries/base/Data/Foldable.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/Data/Foldable.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,3 +1,6 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- | -- Module : Data.Foldable @@ -17,43 +20,43 @@ -- for this module. module Data.Foldable ( - -- * Folds - Foldable(..), - -- ** Special biased folds - foldr', - foldl', - foldrM, - foldlM, - -- ** Folding actions - -- *** Applicative actions - traverse_, - for_, - sequenceA_, - asum, - -- *** Monadic actions - mapM_, - forM_, - sequence_, - msum, - -- ** Specialized folds - toList, - concat, - concatMap, - and, - or, - any, - all, - sum, - product, - maximum, - maximumBy, - minimum, - minimumBy, - -- ** Searches - elem, - notElem, - find - ) where + -- * Folds + Foldable(..), + -- ** Special biased folds + foldr', + foldl', + foldrM, + foldlM, + -- ** Folding actions + -- *** Applicative actions + traverse_, + for_, + sequenceA_, + asum, + -- *** Monadic actions + mapM_, + forM_, + sequence_, + msum, + -- ** Specialized folds + toList, + concat, + concatMap, + and, + or, + any, + all, + sum, + product, + maximum, + maximumBy, + minimum, + minimumBy, + -- ** Searches + elem, + notElem, + find + ) where import Prelude hiding (foldl, foldr, foldl1, foldr1, mapM_, sequence_, elem, notElem, concat, concatMap, and, or, any, all, @@ -104,67 +107,69 @@ -- > foldr f z (Node l k r) = foldr f (f k (foldr f z r)) l -- class Foldable t where - -- | Combine the elements of a structure using a monoid. - fold :: Monoid m => t m -> m - fold = foldMap id - - -- | Map each element of the structure to a monoid, - -- and combine the results. - foldMap :: Monoid m => (a -> m) -> t a -> m - foldMap f = foldr (mappend . f) mempty - - -- | Right-associative fold of a structure. - -- - -- @'foldr' f z = 'Prelude.foldr' f z . 'toList'@ - foldr :: (a -> b -> b) -> b -> t a -> b - foldr f z t = appEndo (foldMap (Endo . f) t) z - - -- | Left-associative fold of a structure. - -- - -- @'foldl' f z = 'Prelude.foldl' f z . 'toList'@ - foldl :: (a -> b -> a) -> a -> t b -> a - foldl f z t = appEndo (getDual (foldMap (Dual . Endo . flip f) t)) z - - -- | A variant of 'foldr' that has no base case, - -- and thus may only be applied to non-empty structures. - -- - -- @'foldr1' f = 'Prelude.foldr1' f . 'toList'@ - foldr1 :: (a -> a -> a) -> t a -> a - foldr1 f xs = fromMaybe (error "foldr1: empty structure") - (foldr mf Nothing xs) - where mf x Nothing = Just x - mf x (Just y) = Just (f x y) - - -- | A variant of 'foldl' that has no base case, - -- and thus may only be applied to non-empty structures. - -- - -- @'foldl1' f = 'Prelude.foldl1' f . 'toList'@ - foldl1 :: (a -> a -> a) -> t a -> a - foldl1 f xs = fromMaybe (error "foldl1: empty structure") - (foldl mf Nothing xs) - where mf Nothing y = Just y - mf (Just x) y = Just (f x y) + -- | Combine the elements of a structure using a monoid. + fold :: Monoid m => t m -> m + fold = foldMap id + + -- | Map each element of the structure to a monoid, + -- and combine the results. + foldMap :: Monoid m => (a -> m) -> t a -> m + foldMap f = foldr (mappend . f) mempty + + -- | Right-associative fold of a structure. + -- + -- @'foldr' f z = 'Prelude.foldr' f z . 'toList'@ + foldr :: (a -> b -> b) -> b -> t a -> b + foldr f z t = appEndo (foldMap (Endo . f) t) z + + -- | Left-associative fold of a structure. + -- + -- @'foldl' f z = 'Prelude.foldl' f z . 'toList'@ + foldl :: (a -> b -> a) -> a -> t b -> a + foldl f z t = appEndo (getDual (foldMap (Dual . Endo . flip f) t)) z + + -- | A variant of 'foldr' that has no base case, + -- and thus may only be applied to non-empty structures. + -- + -- @'foldr1' f = 'Prelude.foldr1' f . 'toList'@ + foldr1 :: (a -> a -> a) -> t a -> a + foldr1 f xs = fromMaybe (error "foldr1: empty structure") + (foldr mf Nothing xs) + where + mf x Nothing = Just x + mf x (Just y) = Just (f x y) + + -- | A variant of 'foldl' that has no base case, + -- and thus may only be applied to non-empty structures. + -- + -- @'foldl1' f = 'Prelude.foldl1' f . 'toList'@ + foldl1 :: (a -> a -> a) -> t a -> a + foldl1 f xs = fromMaybe (error "foldl1: empty structure") + (foldl mf Nothing xs) + where + mf Nothing y = Just y + mf (Just x) y = Just (f x y) -- instances for Prelude types instance Foldable Maybe where - foldr _ z Nothing = z - foldr f z (Just x) = f x z + foldr _ z Nothing = z + foldr f z (Just x) = f x z - foldl _ z Nothing = z - foldl f z (Just x) = f z x + foldl _ z Nothing = z + foldl f z (Just x) = f z x instance Foldable [] where - foldr = Prelude.foldr - foldl = Prelude.foldl - foldr1 = Prelude.foldr1 - foldl1 = Prelude.foldl1 + foldr = Prelude.foldr + foldl = Prelude.foldl + foldr1 = Prelude.foldr1 + foldl1 = Prelude.foldl1 instance Ix i => Foldable (Array i) where - foldr f z = Prelude.foldr f z . elems - foldl f z = Prelude.foldl f z . elems - foldr1 f = Prelude.foldr1 f . elems - foldl1 f = Prelude.foldl1 f . elems + foldr f z = Prelude.foldr f z . elems + foldl f z = Prelude.foldl f z . elems + foldr1 f = Prelude.foldr1 f . elems + foldl1 f = Prelude.foldl1 f . elems -- | Fold over the elements of a structure, -- associating to the right, but strictly. diff -Nru ghc-7.0.3/libraries/base/Data/Function.hs ghc-7.2.1/libraries/base/Data/Function.hs --- ghc-7.0.3/libraries/base/Data/Function.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/Data/Function.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,3 +1,4 @@ +{-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | -- Module : Data.Function diff -Nru ghc-7.0.3/libraries/base/Data/Functor.hs ghc-7.2.1/libraries/base/Data/Functor.hs --- ghc-7.0.3/libraries/base/Data/Functor.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/Data/Functor.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,3 +1,6 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- | -- Module : Data.Functor diff -Nru ghc-7.0.3/libraries/base/Data/HashTable.hs ghc-7.2.1/libraries/base/Data/HashTable.hs --- ghc-7.0.3/libraries/base/Data/HashTable.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/Data/HashTable.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,6 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude -funbox-strict-fields -fno-warn-name-shadowing #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude #-} +{-# OPTIONS_GHC -funbox-strict-fields -fno-warn-name-shadowing #-} ----------------------------------------------------------------------------- -- | diff -Nru ghc-7.0.3/libraries/base/Data/Int.hs ghc-7.2.1/libraries/base/Data/Int.hs --- ghc-7.0.3/libraries/base/Data/Int.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/Data/Int.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,6 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude #-} + ----------------------------------------------------------------------------- -- | -- Module : Data.Int diff -Nru ghc-7.0.3/libraries/base/Data/IORef.hs ghc-7.2.1/libraries/base/Data/IORef.hs --- ghc-7.0.3/libraries/base/Data/IORef.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/Data/IORef.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,6 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude, MagicHash, UnboxedTuples #-} + ----------------------------------------------------------------------------- -- | -- Module : Data.IORef @@ -26,6 +28,10 @@ #if !defined(__PARALLEL_HASKELL__) && defined(__GLASGOW_HASKELL__) mkWeakIORef, -- :: IORef a -> IO () -> IO (Weak (IORef a)) #endif + -- ** Memory Model + + -- $memmodel + ) where #ifdef __HUGS__ @@ -35,7 +41,6 @@ #ifdef __GLASGOW_HASKELL__ import GHC.Base import GHC.STRef --- import GHC.IO import GHC.IORef hiding (atomicModifyIORef) import qualified GHC.IORef #if !defined(__PARALLEL_HASKELL__) @@ -54,7 +59,8 @@ #endif #if defined(__GLASGOW_HASKELL__) && !defined(__PARALLEL_HASKELL__) --- |Make a 'Weak' pointer to an 'IORef' +-- |Make a 'Weak' pointer to an 'IORef', using the second argument as a finalizer +-- to run when 'IORef' is garbage-collected mkWeakIORef :: IORef a -> IO () -> IO (Weak (IORef a)) mkWeakIORef r@(IORef (STRef r#)) f = IO $ \s -> case mkWeak# r# r f s of (# s1, w #) -> (# s1, Weak w #) @@ -92,3 +98,43 @@ writeIORef r a' return b #endif + +{- $memmodel + + In a concurrent program, 'IORef' operations may appear out-of-order + to another thread, depending on the memory model of the underlying + processor architecture. For example, on x86, loads can move ahead + of stores, so in the following example: + +> maybePrint :: IORef Bool -> IORef Bool -> IO () +> maybePrint myRef yourRef = do +> writeIORef myRef True +> yourVal <- readIORef yourRef +> unless yourVal $ putStrLn "critical section" +> +> main :: IO () +> main = do +> r1 <- newIORef False +> r2 <- newIORef False +> forkIO $ maybePrint r1 r2 +> forkIO $ maybePrint r2 r1 +> threadDelay 1000000 + + it is possible that the string @"critical section"@ is printed + twice, even though there is no interleaving of the operations of the + two threads that allows that outcome. The memory model of x86 + allows 'readIORef' to happen before the earlier 'writeIORef'. + + The implementation is required to ensure that reordering of memory + operations cannot cause type-correct code to go wrong. In + particular, when inspecting the value read from an 'IORef', the + memory writes that created that value must have occurred from the + point of view of the current therad. + + 'atomicModifyIORef' acts as a barrier to reordering. Multiple + 'atomicModifyIORef' operations occur in strict program order. An + 'atomicModifyIORef' is never observed to take place ahead of any + earlier (in program order) 'IORef' operations, or after any later + 'IORef' operations. + +-} diff -Nru ghc-7.0.3/libraries/base/Data/Ix.hs ghc-7.2.1/libraries/base/Data/Ix.hs --- ghc-7.0.3/libraries/base/Data/Ix.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/Data/Ix.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,3 +1,6 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- | -- Module : Data.Ix diff -Nru ghc-7.0.3/libraries/base/Data/List.hs ghc-7.2.1/libraries/base/Data/List.hs --- ghc-7.0.3/libraries/base/Data/List.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/Data/List.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,6 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude, MagicHash #-} + ----------------------------------------------------------------------------- -- | -- Module : Data.List @@ -410,6 +412,8 @@ -- | The 'intersectBy' function is the non-overloaded version of 'intersect'. intersectBy :: (a -> a -> Bool) -> [a] -> [a] -> [a] +intersectBy _ [] _ = [] +intersectBy _ _ [] = [] intersectBy eq xs ys = [x | x <- xs, any (eq x) ys] -- | The 'intersperse' function takes an element and a list and @@ -420,8 +424,16 @@ intersperse :: a -> [a] -> [a] intersperse _ [] = [] -intersperse _ [x] = [x] -intersperse sep (x:xs) = x : sep : intersperse sep xs +intersperse sep (x:xs) = x : prependToAll sep xs + + +-- Not exported: +-- We want to make every element in the 'intersperse'd list available +-- as soon as possible to avoid space leaks. Experiments suggested that +-- a separate top-level helper is more efficient than a local worker. +prependToAll :: a -> [a] -> [a] +prependToAll _ [] = [] +prependToAll sep (x:xs) = sep : x : prependToAll sep xs -- | 'intercalate' @xs xss@ is equivalent to @('concat' ('intersperse' xs xss))@. -- It inserts the list @xs@ in between the lists in @xss@ and concatenates the @@ -733,19 +745,24 @@ -- -- > inits "abc" == ["","a","ab","abc"] -- +-- Note that 'inits' has the following strictness property: +-- @inits _|_ = [] : _|_@ inits :: [a] -> [[a]] -inits [] = [[]] -inits (x:xs) = [[]] ++ map (x:) (inits xs) +inits xs = [] : case xs of + [] -> [] + x : xs' -> map (x :) (inits xs') -- | The 'tails' function returns all final segments of the argument, -- longest first. For example, -- -- > tails "abc" == ["abc", "bc", "c",""] -- +-- Note that 'tails' has the following strictness property: +-- @tails _|_ = _|_ : _|_@ tails :: [a] -> [[a]] -tails [] = [[]] -tails xxs@(_:xs) = xxs : tails xs - +tails xs = xs : case xs of + [] -> [] + _ : xs' -> tails xs' -- | The 'subsequences' function returns the list of all subsequences of the argument. -- diff -Nru ghc-7.0.3/libraries/base/Data/Maybe.hs ghc-7.2.1/libraries/base/Data/Maybe.hs --- ghc-7.0.3/libraries/base/Data/Maybe.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/Data/Maybe.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,6 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude, DeriveGeneric #-} + ----------------------------------------------------------------------------- -- | -- Module : Data.Maybe @@ -32,6 +34,7 @@ #ifdef __GLASGOW_HASKELL__ import GHC.Base +import GHC.Generics (Generic) #endif #ifdef __NHC__ @@ -64,7 +67,7 @@ -- error monad can be built using the 'Data.Either.Either' type. data Maybe a = Nothing | Just a - deriving (Eq, Ord) + deriving (Eq, Ord, Generic) instance Functor Maybe where fmap _ Nothing = Nothing diff -Nru ghc-7.0.3/libraries/base/Data/Monoid.hs ghc-7.2.1/libraries/base/Data/Monoid.hs --- ghc-7.0.3/libraries/base/Data/Monoid.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/Data/Monoid.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,6 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude #-} + ----------------------------------------------------------------------------- -- | -- Module : Data.Monoid diff -Nru ghc-7.0.3/libraries/base/Data/Ord.hs ghc-7.2.1/libraries/base/Data/Ord.hs --- ghc-7.0.3/libraries/base/Data/Ord.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/Data/Ord.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,6 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude #-} + ----------------------------------------------------------------------------- -- | -- Module : Data.Ord diff -Nru ghc-7.0.3/libraries/base/Data/Ratio.hs ghc-7.2.1/libraries/base/Data/Ratio.hs --- ghc-7.0.3/libraries/base/Data/Ratio.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/Data/Ratio.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,3 +1,6 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- | -- Module : Data.Ratio diff -Nru ghc-7.0.3/libraries/base/Data/STRef/Lazy.hs ghc-7.2.1/libraries/base/Data/STRef/Lazy.hs --- ghc-7.0.3/libraries/base/Data/STRef/Lazy.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/Data/STRef/Lazy.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,3 +1,4 @@ +{-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | -- Module : Data.STRef.Lazy @@ -20,7 +21,7 @@ modifySTRef -- :: STRef s a -> (a -> a) -> ST s () ) where -import Control.Monad.ST.Lazy +import Control.Monad.ST.Lazy.Safe import qualified Data.STRef as ST import Prelude diff -Nru ghc-7.0.3/libraries/base/Data/STRef/Strict.hs ghc-7.2.1/libraries/base/Data/STRef/Strict.hs --- ghc-7.0.3/libraries/base/Data/STRef/Strict.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/Data/STRef/Strict.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,3 +1,4 @@ +{-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | -- Module : Data.STRef.Strict diff -Nru ghc-7.0.3/libraries/base/Data/STRef.hs ghc-7.2.1/libraries/base/Data/STRef.hs --- ghc-7.0.3/libraries/base/Data/STRef.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/Data/STRef.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,3 +1,6 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- | -- Module : Data.STRef diff -Nru ghc-7.0.3/libraries/base/Data/String.hs ghc-7.2.1/libraries/base/Data/String.hs --- ghc-7.0.3/libraries/base/Data/String.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/Data/String.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,6 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude, FlexibleInstances #-} + ----------------------------------------------------------------------------- -- | -- Module : Data.String @@ -9,23 +11,33 @@ -- Stability : experimental -- Portability : portable -- --- Things related to the String type. +-- The @String@ type and associated operations. -- ----------------------------------------------------------------------------- module Data.String ( - IsString(..) + String + , IsString(..) + + -- * Functions on strings + , lines + , words + , unlines + , unwords ) where #ifdef __GLASGOW_HASKELL__ import GHC.Base #endif +import Data.List (lines, words, unlines, unwords) + -- | Class for string-like datastructures; used by the overloaded string -- extension (-foverloaded-strings in GHC). class IsString a where fromString :: String -> a +#ifndef __NHC__ instance IsString [Char] where fromString xs = xs - +#endif diff -Nru ghc-7.0.3/libraries/base/Data/Traversable.hs ghc-7.2.1/libraries/base/Data/Traversable.hs --- ghc-7.0.3/libraries/base/Data/Traversable.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/Data/Traversable.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,3 +1,6 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- | -- Module : Data.Traversable @@ -28,14 +31,14 @@ -- or qualify uses of these function names with an alias for this module. module Data.Traversable ( - Traversable(..), - for, - forM, - mapAccumL, - mapAccumR, - fmapDefault, - foldMapDefault, - ) where + Traversable(..), + for, + forM, + mapAccumL, + mapAccumR, + fmapDefault, + foldMapDefault, + ) where import Prelude hiding (mapM, sequence, foldr) import qualified Prelude (mapM, foldr) @@ -80,41 +83,41 @@ -- ('foldMapDefault'). -- class (Functor t, Foldable t) => Traversable t where - -- | Map each element of a structure to an action, evaluate - -- these actions from left to right, and collect the results. - traverse :: Applicative f => (a -> f b) -> t a -> f (t b) - traverse f = sequenceA . fmap f - - -- | Evaluate each action in the structure from left to right, - -- and collect the results. - sequenceA :: Applicative f => t (f a) -> f (t a) - sequenceA = traverse id - - -- | Map each element of a structure to a monadic action, evaluate - -- these actions from left to right, and collect the results. - mapM :: Monad m => (a -> m b) -> t a -> m (t b) - mapM f = unwrapMonad . traverse (WrapMonad . f) - - -- | Evaluate each monadic action in the structure from left to right, - -- and collect the results. - sequence :: Monad m => t (m a) -> m (t a) - sequence = mapM id + -- | Map each element of a structure to an action, evaluate + -- these actions from left to right, and collect the results. + traverse :: Applicative f => (a -> f b) -> t a -> f (t b) + traverse f = sequenceA . fmap f + + -- | Evaluate each action in the structure from left to right, + -- and collect the results. + sequenceA :: Applicative f => t (f a) -> f (t a) + sequenceA = traverse id + + -- | Map each element of a structure to a monadic action, evaluate + -- these actions from left to right, and collect the results. + mapM :: Monad m => (a -> m b) -> t a -> m (t b) + mapM f = unwrapMonad . traverse (WrapMonad . f) + + -- | Evaluate each monadic action in the structure from left to right, + -- and collect the results. + sequence :: Monad m => t (m a) -> m (t a) + sequence = mapM id -- instances for Prelude types instance Traversable Maybe where - traverse _ Nothing = pure Nothing - traverse f (Just x) = Just <$> f x + traverse _ Nothing = pure Nothing + traverse f (Just x) = Just <$> f x instance Traversable [] where - {-# INLINE traverse #-} -- so that traverse can fuse - traverse f = Prelude.foldr cons_f (pure []) - where cons_f x ys = (:) <$> f x <*> ys + {-# INLINE traverse #-} -- so that traverse can fuse + traverse f = Prelude.foldr cons_f (pure []) + where cons_f x ys = (:) <$> f x <*> ys - mapM = Prelude.mapM + mapM = Prelude.mapM instance Ix i => Traversable (Array i) where - traverse f arr = listArray (bounds arr) `fmap` traverse f (elems arr) + traverse f arr = listArray (bounds arr) `fmap` traverse f (elems arr) -- general functions @@ -132,15 +135,14 @@ newtype StateL s a = StateL { runStateL :: s -> (s, a) } instance Functor (StateL s) where - fmap f (StateL k) = StateL $ \ s -> - let (s', v) = k s in (s', f v) + fmap f (StateL k) = StateL $ \ s -> let (s', v) = k s in (s', f v) instance Applicative (StateL s) where - pure x = StateL (\ s -> (s, x)) - StateL kf <*> StateL kv = StateL $ \ s -> - let (s', f) = kf s - (s'', v) = kv s' - in (s'', f v) + pure x = StateL (\ s -> (s, x)) + StateL kf <*> StateL kv = StateL $ \ s -> + let (s', f) = kf s + (s'', v) = kv s' + in (s'', f v) -- |The 'mapAccumL' function behaves like a combination of 'fmap' -- and 'foldl'; it applies a function to each element of a structure, @@ -153,15 +155,14 @@ newtype StateR s a = StateR { runStateR :: s -> (s, a) } instance Functor (StateR s) where - fmap f (StateR k) = StateR $ \ s -> - let (s', v) = k s in (s', f v) + fmap f (StateR k) = StateR $ \ s -> let (s', v) = k s in (s', f v) instance Applicative (StateR s) where - pure x = StateR (\ s -> (s, x)) - StateR kf <*> StateR kv = StateR $ \ s -> - let (s', v) = kv s - (s'', f) = kf s' - in (s'', f v) + pure x = StateR (\ s -> (s, x)) + StateR kf <*> StateR kv = StateR $ \ s -> + let (s', v) = kv s + (s'', f) = kf s' + in (s'', f v) -- |The 'mapAccumR' function behaves like a combination of 'fmap' -- and 'foldr'; it applies a function to each element of a structure, @@ -170,8 +171,12 @@ mapAccumR :: Traversable t => (a -> b -> (a, c)) -> a -> t b -> (a, t c) mapAccumR f s t = runStateR (traverse (StateR . flip f) t) s --- | This function may be used as a value for `fmap` in a `Functor` instance. +-- | This function may be used as a value for `fmap` in a `Functor` +-- instance, provided that 'traverse' is defined. (Using +-- `fmapDefault` with a `Traversable` instance defined only by +-- 'sequenceA' will result in infinite recursion.) fmapDefault :: Traversable t => (a -> b) -> t a -> t b +{-# INLINE fmapDefault #-} fmapDefault f = getId . traverse (Id . f) -- | This function may be used as a value for `Data.Foldable.foldMap` @@ -184,8 +189,8 @@ newtype Id a = Id { getId :: a } instance Functor Id where - fmap f (Id x) = Id (f x) + fmap f (Id x) = Id (f x) instance Applicative Id where - pure = Id - Id f <*> Id x = Id (f x) + pure = Id + Id f <*> Id x = Id (f x) diff -Nru ghc-7.0.3/libraries/base/Data/Tuple.hs ghc-7.2.1/libraries/base/Data/Tuple.hs --- ghc-7.0.3/libraries/base/Data/Tuple.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/Data/Tuple.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,5 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-} -- XXX -fno-warn-unused-imports needed for the GHC.Tuple import below. Sigh. ----------------------------------------------------------------------------- @@ -44,13 +45,13 @@ import GHC.Base -- We need to depend on GHC.Base so that --- a) so that we get GHC.Bool, GHC.Classes, GHC.Ordering +-- a) so that we get GHC.Classes, GHC.Ordering, GHC.Types -- b) so that GHC.Base.inline is available, which is used -- when expanding instance declarations import GHC.Tuple --- We must import GHC.Tuple, to ensure sure that the +-- We must import GHC.Tuple, to ensure sure that the -- data constructors of `(,)' are in scope when we do -- the standalone deriving instance for Eq (a,b) etc diff -Nru ghc-7.0.3/libraries/base/Data/Typeable/Internal.hs ghc-7.2.1/libraries/base/Data/Typeable/Internal.hs --- ghc-7.0.3/libraries/base/Data/Typeable/Internal.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/base/Data/Typeable/Internal.hs 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,567 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Typeable.Internal +-- Copyright : (c) The University of Glasgow, CWI 2001--2011 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- The representations of the types TyCon and TypeRep, and the +-- function mkTyCon which is used by derived instances of Typeable to +-- construct a TyCon. +-- +----------------------------------------------------------------------------- + +{-# LANGUAGE CPP + , NoImplicitPrelude + , OverlappingInstances + , ScopedTypeVariables + , FlexibleInstances + , MagicHash #-} +#ifdef __GLASGOW_HASKELL__ +{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} +#endif + +module Data.Typeable.Internal ( + TypeRep(..), + TyCon(..), + mkTyCon, + mkTyCon3, + mkTyConApp, + mkAppTy, + typeRepTyCon, + typeOfDefault, + typeOf1Default, + typeOf2Default, + typeOf3Default, + typeOf4Default, + typeOf5Default, + typeOf6Default, + Typeable(..), + Typeable1(..), + Typeable2(..), + Typeable3(..), + Typeable4(..), + Typeable5(..), + Typeable6(..), + Typeable7(..), + mkFunTy, + splitTyConApp, + funResultTy, + typeRepArgs, + showsTypeRep, + tyConString, +#if defined(__GLASGOW_HASKELL__) + listTc, funTc +#endif + ) where + +import GHC.Base +import GHC.Word +import GHC.Show +import GHC.Err (undefined) +import Data.Maybe +import Data.List +import GHC.Num +import GHC.Real +import GHC.IORef +import GHC.IOArray +import GHC.MVar +import GHC.ST ( ST ) +import GHC.STRef ( STRef ) +import GHC.Ptr ( Ptr, FunPtr ) +import GHC.Stable +import GHC.Arr ( Array, STArray ) +import Data.Int + +import GHC.Fingerprint.Type +import {-# SOURCE #-} GHC.Fingerprint + -- loop: GHC.Fingerprint -> Foreign.Ptr -> Data.Typeable + -- Better to break the loop here, because we want non-SOURCE imports + -- of Data.Typeable as much as possible so we can optimise the derived + -- instances. + +-- | A concrete representation of a (monomorphic) type. 'TypeRep' +-- supports reasonably efficient equality. +data TypeRep = TypeRep {-# UNPACK #-} !Fingerprint TyCon [TypeRep] + +-- Compare keys for equality +instance Eq TypeRep where + (TypeRep k1 _ _) == (TypeRep k2 _ _) = k1 == k2 + +instance Ord TypeRep where + (TypeRep k1 _ _) <= (TypeRep k2 _ _) = k1 <= k2 + +-- | An abstract representation of a type constructor. 'TyCon' objects can +-- be built using 'mkTyCon'. +data TyCon = TyCon { + tyConHash :: {-# UNPACK #-} !Fingerprint, + tyConPackage :: String, + tyConModule :: String, + tyConName :: String + } + +instance Eq TyCon where + (TyCon t1 _ _ _) == (TyCon t2 _ _ _) = t1 == t2 + +instance Ord TyCon where + (TyCon k1 _ _ _) <= (TyCon k2 _ _ _) = k1 <= k2 + +----------------- Construction -------------------- + +#include "MachDeps.h" + +-- mkTyCon is an internal function to make it easier for GHC to +-- generate derived instances. GHC precomputes the MD5 hash for the +-- TyCon and passes it as two separate 64-bit values to mkTyCon. The +-- TyCon for a derived Typeable instance will end up being statically +-- allocated. + +#if WORD_SIZE_IN_BITS < 64 +mkTyCon :: Word64# -> Word64# -> String -> String -> String -> TyCon +#else +mkTyCon :: Word# -> Word# -> String -> String -> String -> TyCon +#endif +mkTyCon high# low# pkg modl name + = TyCon (Fingerprint (W64# high#) (W64# low#)) pkg modl name + +-- | Applies a type constructor to a sequence of types +mkTyConApp :: TyCon -> [TypeRep] -> TypeRep +mkTyConApp tc@(TyCon tc_k _ _ _) [] + = TypeRep tc_k tc [] -- optimisation: all derived Typeable instances + -- end up here, and it helps generate smaller + -- code for derived Typeable. +mkTyConApp tc@(TyCon tc_k _ _ _) args + = TypeRep (fingerprintFingerprints (tc_k : arg_ks)) tc args + where + arg_ks = [k | TypeRep k _ _ <- args] + +-- | A special case of 'mkTyConApp', which applies the function +-- type constructor to a pair of types. +mkFunTy :: TypeRep -> TypeRep -> TypeRep +mkFunTy f a = mkTyConApp funTc [f,a] + +-- | Splits a type constructor application +splitTyConApp :: TypeRep -> (TyCon,[TypeRep]) +splitTyConApp (TypeRep _ tc trs) = (tc,trs) + +-- | Applies a type to a function type. Returns: @'Just' u@ if the +-- first argument represents a function of type @t -> u@ and the +-- second argument represents a function of type @t@. Otherwise, +-- returns 'Nothing'. +funResultTy :: TypeRep -> TypeRep -> Maybe TypeRep +funResultTy trFun trArg + = case splitTyConApp trFun of + (tc, [t1,t2]) | tc == funTc && t1 == trArg -> Just t2 + _ -> Nothing + +-- | Adds a TypeRep argument to a TypeRep. +mkAppTy :: TypeRep -> TypeRep -> TypeRep +mkAppTy (TypeRep tr_k tc trs) arg_tr + = let (TypeRep arg_k _ _) = arg_tr + in TypeRep (fingerprintFingerprints [tr_k,arg_k]) tc (trs++[arg_tr]) + +-- | Builds a 'TyCon' object representing a type constructor. An +-- implementation of "Data.Typeable" should ensure that the following holds: +-- +-- > A==A' ^ B==B' ^ C==C' ==> mkTyCon A B C == mkTyCon A' B' C' +-- + +-- +mkTyCon3 :: String -- ^ package name + -> String -- ^ module name + -> String -- ^ the name of the type constructor + -> TyCon -- ^ A unique 'TyCon' object +mkTyCon3 pkg modl name = + TyCon (fingerprintString (unwords [pkg, modl, name])) pkg modl name + +----------------- Observation --------------------- + +-- | Observe the type constructor of a type representation +typeRepTyCon :: TypeRep -> TyCon +typeRepTyCon (TypeRep _ tc _) = tc + +-- | Observe the argument types of a type representation +typeRepArgs :: TypeRep -> [TypeRep] +typeRepArgs (TypeRep _ _ args) = args + +-- | Observe string encoding of a type representation +tyConString :: TyCon -> String +tyConString = tyConName + +------------------------------------------------------------- +-- +-- The Typeable class and friends +-- +------------------------------------------------------------- + +{- Note [Memoising typeOf] +~~~~~~~~~~~~~~~~~~~~~~~~~~ +IMPORTANT: we don't want to recalculate the type-rep once per +call to the dummy argument. This is what went wrong in Trac #3245 +So we help GHC by manually keeping the 'rep' *outside* the value +lambda, thus + + typeOfDefault :: forall t a. (Typeable1 t, Typeable a) => t a -> TypeRep + typeOfDefault = \_ -> rep + where + rep = typeOf1 (undefined :: t a) `mkAppTy` + typeOf (undefined :: a) + +Notice the crucial use of scoped type variables here! +-} + +-- | The class 'Typeable' allows a concrete representation of a type to +-- be calculated. +class Typeable a where + typeOf :: a -> TypeRep + -- ^ Takes a value of type @a@ and returns a concrete representation + -- of that type. The /value/ of the argument should be ignored by + -- any instance of 'Typeable', so that it is safe to pass 'undefined' as + -- the argument. + +-- | Variant for unary type constructors +class Typeable1 t where + typeOf1 :: t a -> TypeRep + +#ifdef __GLASGOW_HASKELL__ +-- | For defining a 'Typeable' instance from any 'Typeable1' instance. +typeOfDefault :: forall t a. (Typeable1 t, Typeable a) => t a -> TypeRep +typeOfDefault = \_ -> rep + where + rep = typeOf1 (undefined :: t a) `mkAppTy` + typeOf (undefined :: a) + -- Note [Memoising typeOf] +#else +-- | For defining a 'Typeable' instance from any 'Typeable1' instance. +typeOfDefault :: (Typeable1 t, Typeable a) => t a -> TypeRep +typeOfDefault x = typeOf1 x `mkAppTy` typeOf (argType x) + where + argType :: t a -> a + argType = undefined +#endif + +-- | Variant for binary type constructors +class Typeable2 t where + typeOf2 :: t a b -> TypeRep + +#ifdef __GLASGOW_HASKELL__ +-- | For defining a 'Typeable1' instance from any 'Typeable2' instance. +typeOf1Default :: forall t a b. (Typeable2 t, Typeable a) => t a b -> TypeRep +typeOf1Default = \_ -> rep + where + rep = typeOf2 (undefined :: t a b) `mkAppTy` + typeOf (undefined :: a) + -- Note [Memoising typeOf] +#else +-- | For defining a 'Typeable1' instance from any 'Typeable2' instance. +typeOf1Default :: (Typeable2 t, Typeable a) => t a b -> TypeRep +typeOf1Default x = typeOf2 x `mkAppTy` typeOf (argType x) + where + argType :: t a b -> a + argType = undefined +#endif + +-- | Variant for 3-ary type constructors +class Typeable3 t where + typeOf3 :: t a b c -> TypeRep + +#ifdef __GLASGOW_HASKELL__ +-- | For defining a 'Typeable2' instance from any 'Typeable3' instance. +typeOf2Default :: forall t a b c. (Typeable3 t, Typeable a) => t a b c -> TypeRep +typeOf2Default = \_ -> rep + where + rep = typeOf3 (undefined :: t a b c) `mkAppTy` + typeOf (undefined :: a) + -- Note [Memoising typeOf] +#else +-- | For defining a 'Typeable2' instance from any 'Typeable3' instance. +typeOf2Default :: (Typeable3 t, Typeable a) => t a b c -> TypeRep +typeOf2Default x = typeOf3 x `mkAppTy` typeOf (argType x) + where + argType :: t a b c -> a + argType = undefined +#endif + +-- | Variant for 4-ary type constructors +class Typeable4 t where + typeOf4 :: t a b c d -> TypeRep + +#ifdef __GLASGOW_HASKELL__ +-- | For defining a 'Typeable3' instance from any 'Typeable4' instance. +typeOf3Default :: forall t a b c d. (Typeable4 t, Typeable a) => t a b c d -> TypeRep +typeOf3Default = \_ -> rep + where + rep = typeOf4 (undefined :: t a b c d) `mkAppTy` + typeOf (undefined :: a) + -- Note [Memoising typeOf] +#else +-- | For defining a 'Typeable3' instance from any 'Typeable4' instance. +typeOf3Default :: (Typeable4 t, Typeable a) => t a b c d -> TypeRep +typeOf3Default x = typeOf4 x `mkAppTy` typeOf (argType x) + where + argType :: t a b c d -> a + argType = undefined +#endif + +-- | Variant for 5-ary type constructors +class Typeable5 t where + typeOf5 :: t a b c d e -> TypeRep + +#ifdef __GLASGOW_HASKELL__ +-- | For defining a 'Typeable4' instance from any 'Typeable5' instance. +typeOf4Default :: forall t a b c d e. (Typeable5 t, Typeable a) => t a b c d e -> TypeRep +typeOf4Default = \_ -> rep + where + rep = typeOf5 (undefined :: t a b c d e) `mkAppTy` + typeOf (undefined :: a) + -- Note [Memoising typeOf] +#else +-- | For defining a 'Typeable4' instance from any 'Typeable5' instance. +typeOf4Default :: (Typeable5 t, Typeable a) => t a b c d e -> TypeRep +typeOf4Default x = typeOf5 x `mkAppTy` typeOf (argType x) + where + argType :: t a b c d e -> a + argType = undefined +#endif + +-- | Variant for 6-ary type constructors +class Typeable6 t where + typeOf6 :: t a b c d e f -> TypeRep + +#ifdef __GLASGOW_HASKELL__ +-- | For defining a 'Typeable5' instance from any 'Typeable6' instance. +typeOf5Default :: forall t a b c d e f. (Typeable6 t, Typeable a) => t a b c d e f -> TypeRep +typeOf5Default = \_ -> rep + where + rep = typeOf6 (undefined :: t a b c d e f) `mkAppTy` + typeOf (undefined :: a) + -- Note [Memoising typeOf] +#else +-- | For defining a 'Typeable5' instance from any 'Typeable6' instance. +typeOf5Default :: (Typeable6 t, Typeable a) => t a b c d e f -> TypeRep +typeOf5Default x = typeOf6 x `mkAppTy` typeOf (argType x) + where + argType :: t a b c d e f -> a + argType = undefined +#endif + +-- | Variant for 7-ary type constructors +class Typeable7 t where + typeOf7 :: t a b c d e f g -> TypeRep + +#ifdef __GLASGOW_HASKELL__ +-- | For defining a 'Typeable6' instance from any 'Typeable7' instance. +typeOf6Default :: forall t a b c d e f g. (Typeable7 t, Typeable a) => t a b c d e f g -> TypeRep +typeOf6Default = \_ -> rep + where + rep = typeOf7 (undefined :: t a b c d e f g) `mkAppTy` + typeOf (undefined :: a) + -- Note [Memoising typeOf] +#else +-- | For defining a 'Typeable6' instance from any 'Typeable7' instance. +typeOf6Default :: (Typeable7 t, Typeable a) => t a b c d e f g -> TypeRep +typeOf6Default x = typeOf7 x `mkAppTy` typeOf (argType x) + where + argType :: t a b c d e f g -> a + argType = undefined +#endif + +#ifdef __GLASGOW_HASKELL__ +-- Given a @Typeable@/n/ instance for an /n/-ary type constructor, +-- define the instances for partial applications. +-- Programmers using non-GHC implementations must do this manually +-- for each type constructor. +-- (The INSTANCE_TYPEABLE/n/ macros in Typeable.h include this.) + +-- | One Typeable instance for all Typeable1 instances +instance (Typeable1 s, Typeable a) + => Typeable (s a) where + typeOf = typeOfDefault + +-- | One Typeable1 instance for all Typeable2 instances +instance (Typeable2 s, Typeable a) + => Typeable1 (s a) where + typeOf1 = typeOf1Default + +-- | One Typeable2 instance for all Typeable3 instances +instance (Typeable3 s, Typeable a) + => Typeable2 (s a) where + typeOf2 = typeOf2Default + +-- | One Typeable3 instance for all Typeable4 instances +instance (Typeable4 s, Typeable a) + => Typeable3 (s a) where + typeOf3 = typeOf3Default + +-- | One Typeable4 instance for all Typeable5 instances +instance (Typeable5 s, Typeable a) + => Typeable4 (s a) where + typeOf4 = typeOf4Default + +-- | One Typeable5 instance for all Typeable6 instances +instance (Typeable6 s, Typeable a) + => Typeable5 (s a) where + typeOf5 = typeOf5Default + +-- | One Typeable6 instance for all Typeable7 instances +instance (Typeable7 s, Typeable a) + => Typeable6 (s a) where + typeOf6 = typeOf6Default + +#endif /* __GLASGOW_HASKELL__ */ + +----------------- Showing TypeReps -------------------- + +instance Show TypeRep where + showsPrec p (TypeRep _ tycon tys) = + case tys of + [] -> showsPrec p tycon + [x] | tycon == listTc -> showChar '[' . shows x . showChar ']' + [a,r] | tycon == funTc -> showParen (p > 8) $ + showsPrec 9 a . + showString " -> " . + showsPrec 8 r + xs | isTupleTyCon tycon -> showTuple xs + | otherwise -> + showParen (p > 9) $ + showsPrec p tycon . + showChar ' ' . + showArgs tys + +showsTypeRep :: TypeRep -> ShowS +showsTypeRep = shows + +instance Show TyCon where + showsPrec _ t = showString (tyConName t) + +isTupleTyCon :: TyCon -> Bool +isTupleTyCon (TyCon _ _ _ ('(':',':_)) = True +isTupleTyCon _ = False + +-- Some (Show.TypeRep) helpers: + +showArgs :: Show a => [a] -> ShowS +showArgs [] = id +showArgs [a] = showsPrec 10 a +showArgs (a:as) = showsPrec 10 a . showString " " . showArgs as + +showTuple :: [TypeRep] -> ShowS +showTuple args = showChar '(' + . (foldr (.) id $ intersperse (showChar ',') + $ map (showsPrec 10) args) + . showChar ')' + +#if defined(__GLASGOW_HASKELL__) +listTc :: TyCon +listTc = typeRepTyCon (typeOf [()]) + +funTc :: TyCon +funTc = mkTyCon3 "ghc-prim" "GHC.Types" "->" +#endif + +------------------------------------------------------------- +-- +-- Instances of the Typeable classes for Prelude types +-- +------------------------------------------------------------- + +#include "Typeable.h" + +INSTANCE_TYPEABLE0((),unitTc,"()") +INSTANCE_TYPEABLE1([],listTc,"[]") +INSTANCE_TYPEABLE1(Maybe,maybeTc,"Maybe") +INSTANCE_TYPEABLE1(Ratio,ratioTc,"Ratio") +#if defined(__GLASGOW_HASKELL__) +{- +TODO: Deriving this instance fails with: +libraries/base/Data/Typeable.hs:589:1: + Can't make a derived instance of `Typeable2 (->)': + The last argument of the instance must be a data or newtype application + In the stand-alone deriving instance for `Typeable2 (->)' +-} +instance Typeable2 (->) where { typeOf2 _ = mkTyConApp funTc [] } +#else +INSTANCE_TYPEABLE2((->),funTc,"->") +#endif +INSTANCE_TYPEABLE1(IO,ioTc,"IO") + +#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__) +-- Types defined in GHC.MVar +INSTANCE_TYPEABLE1(MVar,mvarTc,"MVar" ) +#endif + +INSTANCE_TYPEABLE2(Array,arrayTc,"Array") +INSTANCE_TYPEABLE2(IOArray,iOArrayTc,"IOArray") + +#ifdef __GLASGOW_HASKELL__ +-- Hugs has these too, but their Typeable instances are defined +-- elsewhere to keep this module within Haskell 98. +-- This is important because every invocation of runhugs or ffihugs +-- uses this module via Data.Dynamic. +INSTANCE_TYPEABLE2(ST,stTc,"ST") +INSTANCE_TYPEABLE2(STRef,stRefTc,"STRef") +INSTANCE_TYPEABLE3(STArray,sTArrayTc,"STArray") +#endif + +#ifndef __NHC__ +INSTANCE_TYPEABLE2((,),pairTc,"(,)") +INSTANCE_TYPEABLE3((,,),tup3Tc,"(,,)") +INSTANCE_TYPEABLE4((,,,),tup4Tc,"(,,,)") +INSTANCE_TYPEABLE5((,,,,),tup5Tc,"(,,,,)") +INSTANCE_TYPEABLE6((,,,,,),tup6Tc,"(,,,,,)") +INSTANCE_TYPEABLE7((,,,,,,),tup7Tc,"(,,,,,,)") +#endif /* __NHC__ */ + +INSTANCE_TYPEABLE1(Ptr,ptrTc,"Ptr") +INSTANCE_TYPEABLE1(FunPtr,funPtrTc,"FunPtr") +#ifndef __GLASGOW_HASKELL__ +INSTANCE_TYPEABLE1(ForeignPtr,foreignPtrTc,"ForeignPtr") +#endif +INSTANCE_TYPEABLE1(StablePtr,stablePtrTc,"StablePtr") +INSTANCE_TYPEABLE1(IORef,iORefTc,"IORef") + +------------------------------------------------------- +-- +-- Generate Typeable instances for standard datatypes +-- +------------------------------------------------------- + +INSTANCE_TYPEABLE0(Bool,boolTc,"Bool") +INSTANCE_TYPEABLE0(Char,charTc,"Char") +INSTANCE_TYPEABLE0(Float,floatTc,"Float") +INSTANCE_TYPEABLE0(Double,doubleTc,"Double") +INSTANCE_TYPEABLE0(Int,intTc,"Int") +#ifndef __NHC__ +INSTANCE_TYPEABLE0(Word,wordTc,"Word" ) +#endif +INSTANCE_TYPEABLE0(Integer,integerTc,"Integer") +INSTANCE_TYPEABLE0(Ordering,orderingTc,"Ordering") +#ifndef __GLASGOW_HASKELL__ +INSTANCE_TYPEABLE0(Handle,handleTc,"Handle") +#endif + +INSTANCE_TYPEABLE0(Int8,int8Tc,"Int8") +INSTANCE_TYPEABLE0(Int16,int16Tc,"Int16") +INSTANCE_TYPEABLE0(Int32,int32Tc,"Int32") +INSTANCE_TYPEABLE0(Int64,int64Tc,"Int64") + +INSTANCE_TYPEABLE0(Word8,word8Tc,"Word8" ) +INSTANCE_TYPEABLE0(Word16,word16Tc,"Word16") +INSTANCE_TYPEABLE0(Word32,word32Tc,"Word32") +INSTANCE_TYPEABLE0(Word64,word64Tc,"Word64") + +INSTANCE_TYPEABLE0(TyCon,tyconTc,"TyCon") +INSTANCE_TYPEABLE0(TypeRep,typeRepTc,"TypeRep") + +#ifdef __GLASGOW_HASKELL__ +{- +TODO: This can't be derived currently: +libraries/base/Data/Typeable.hs:674:1: + Can't make a derived instance of `Typeable RealWorld': + The last argument of the instance must be a data or newtype application + In the stand-alone deriving instance for `Typeable RealWorld' +-} +realWorldTc :: TyCon; \ +realWorldTc = mkTyCon3 "ghc-prim" "GHC.Types" "RealWorld"; \ +instance Typeable RealWorld where { typeOf _ = mkTyConApp realWorldTc [] } + +#endif diff -Nru ghc-7.0.3/libraries/base/Data/Typeable/Internal.hs-boot ghc-7.2.1/libraries/base/Data/Typeable/Internal.hs-boot --- ghc-7.0.3/libraries/base/Data/Typeable/Internal.hs-boot 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/base/Data/Typeable/Internal.hs-boot 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,26 @@ +{-# LANGUAGE CPP, NoImplicitPrelude, MagicHash #-} +module Data.Typeable.Internal ( + Typeable(typeOf), + TypeRep, + TyCon, + mkTyCon, + mkTyConApp + ) where + +import GHC.Base + +data TypeRep +data TyCon + +#include "MachDeps.h" + +#if WORD_SIZE_IN_BITS < 64 +mkTyCon :: Word64# -> Word64# -> String -> String -> String -> TyCon +#else +mkTyCon :: Word# -> Word# -> String -> String -> String -> TyCon +#endif + +mkTyConApp :: TyCon -> [TypeRep] -> TypeRep + +class Typeable a where + typeOf :: a -> TypeRep diff -Nru ghc-7.0.3/libraries/base/Data/Typeable.hs ghc-7.2.1/libraries/base/Data/Typeable.hs --- ghc-7.0.3/libraries/base/Data/Typeable.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/Data/Typeable.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,12 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude -XOverlappingInstances -funbox-strict-fields #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP + , NoImplicitPrelude + , OverlappingInstances + , ScopedTypeVariables + , ForeignFunctionInterface + , FlexibleInstances + #-} +{-# OPTIONS_GHC -funbox-strict-fields #-} -- The -XOverlappingInstances flag allows the user to over-ride -- the instances for Typeable given here. In particular, we provide an instance @@ -39,11 +47,14 @@ -- * Type representations TypeRep, -- abstract, instance of: Eq, Show, Typeable - TyCon, -- abstract, instance of: Eq, Show, Typeable showsTypeRep, + TyCon, -- abstract, instance of: Eq, Show, Typeable + tyConString, -- :: TyCon -> String + -- * Construction of type representations mkTyCon, -- :: String -> TyCon + mkTyCon3, -- :: String -> String -> String -> TyCon mkTyConApp, -- :: TyCon -> [TypeRep] -> TypeRep mkAppTy, -- :: TypeRep -> TypeRep -> TypeRep mkFunTy, -- :: TypeRep -> TypeRep -> TypeRep @@ -53,8 +64,8 @@ funResultTy, -- :: TypeRep -> TypeRep -> Maybe TypeRep typeRepTyCon, -- :: TypeRep -> TyCon typeRepArgs, -- :: TypeRep -> [TypeRep] - tyConString, -- :: TyCon -> String - typeRepKey, -- :: TypeRep -> IO Int + typeRepKey, -- :: TypeRep -> IO TypeRepKey + TypeRepKey, -- abstract, instance of Eq, Ord -- * The other Typeable classes -- | /Note:/ The general instances are provided for GHC only. @@ -81,35 +92,21 @@ ) where -import qualified Data.HashTable as HT -import Data.Maybe -import Data.Int -import Data.Word -import Data.List( foldl, intersperse ) +import Data.Typeable.Internal hiding (mkTyCon) + import Unsafe.Coerce +import Data.Maybe #ifdef __GLASGOW_HASKELL__ import GHC.Base -import GHC.Show (Show(..), ShowS, - shows, showString, showChar, showParen) import GHC.Err (undefined) -import GHC.Num (Integer, (+)) -import GHC.Real ( rem, Ratio ) -import GHC.IORef (IORef,newIORef) -import GHC.IO (unsafePerformIO,mask_) - --- These imports are so we can define Typeable instances --- It'd be better to give Typeable instances in the modules themselves --- but they all have to be compiled before Typeable -import GHC.IOArray -import GHC.MVar -import GHC.ST ( ST ) -import GHC.STRef ( STRef ) -import GHC.Ptr ( Ptr, FunPtr ) -import GHC.Stable ( StablePtr, newStablePtr, freeStablePtr, - deRefStablePtr, castStablePtrToPtr, - castPtrToStablePtr ) -import GHC.Arr ( Array, STArray ) + +import GHC.Fingerprint.Type +import {-# SOURCE #-} GHC.Fingerprint + -- loop: GHC.Fingerprint -> Foreign.Ptr -> Data.Typeable + -- Better to break the loop here, because we want non-SOURCE imports + -- of Data.Typeable as much as possible so we can optimise the derived + -- instances. #endif @@ -135,42 +132,14 @@ #include "Typeable.h" -#ifndef __HUGS__ - -------------------------------------------------------------- --- --- Type representations --- -------------------------------------------------------------- - --- | A concrete representation of a (monomorphic) type. 'TypeRep' --- supports reasonably efficient equality. -data TypeRep = TypeRep !Key TyCon [TypeRep] - --- Compare keys for equality -instance Eq TypeRep where - (TypeRep k1 _ _) == (TypeRep k2 _ _) = k1 == k2 - --- | An abstract representation of a type constructor. 'TyCon' objects can --- be built using 'mkTyCon'. -data TyCon = TyCon !Key String - -instance Eq TyCon where - (TyCon t1 _) == (TyCon t2 _) = t1 == t2 -#endif - --- | Returns a unique integer associated with a 'TypeRep'. This can --- be used for making a mapping with TypeReps --- as the keys, for example. It is guaranteed that @t1 == t2@ if and only if --- @typeRepKey t1 == typeRepKey t2@. --- --- It is in the 'IO' monad because the actual value of the key may --- vary from run to run of the program. You should only rely on --- the equality property, not any actual key value. The relative ordering --- of keys has no meaning either. +{-# DEPRECATED typeRepKey "TypeRep itself is now an instance of Ord" #-} +-- | (DEPRECATED) Returns a unique key associated with a 'TypeRep'. +-- This function is deprecated because 'TypeRep' itself is now an +-- instance of 'Ord', so mappings can be made directly with 'TypeRep' +-- as the key. -- -typeRepKey :: TypeRep -> IO Int -typeRepKey (TypeRep (Key i) _ _) = return i +typeRepKey :: TypeRep -> IO TypeRepKey +typeRepKey (TypeRep f _ _) = return (TypeRepKey f) -- -- let fTy = mkTyCon "Foo" in show (mkTyConApp (mkTyCon ",,") @@ -183,340 +152,16 @@ -- sequence of commas, e.g., (mkTyCon ",,,,") returns -- the 5-tuple tycon. ------------------ Construction -------------------- +newtype TypeRepKey = TypeRepKey Fingerprint + deriving (Eq,Ord) --- | Applies a type constructor to a sequence of types -mkTyConApp :: TyCon -> [TypeRep] -> TypeRep -mkTyConApp tc@(TyCon tc_k _) args - = TypeRep (appKeys tc_k arg_ks) tc args - where - arg_ks = [k | TypeRep k _ _ <- args] - --- | A special case of 'mkTyConApp', which applies the function --- type constructor to a pair of types. -mkFunTy :: TypeRep -> TypeRep -> TypeRep -mkFunTy f a = mkTyConApp funTc [f,a] - --- | Splits a type constructor application -splitTyConApp :: TypeRep -> (TyCon,[TypeRep]) -splitTyConApp (TypeRep _ tc trs) = (tc,trs) - --- | Applies a type to a function type. Returns: @'Just' u@ if the --- first argument represents a function of type @t -> u@ and the --- second argument represents a function of type @t@. Otherwise, --- returns 'Nothing'. -funResultTy :: TypeRep -> TypeRep -> Maybe TypeRep -funResultTy trFun trArg - = case splitTyConApp trFun of - (tc, [t1,t2]) | tc == funTc && t1 == trArg -> Just t2 - _ -> Nothing - --- | Adds a TypeRep argument to a TypeRep. -mkAppTy :: TypeRep -> TypeRep -> TypeRep -mkAppTy (TypeRep tr_k tc trs) arg_tr - = let (TypeRep arg_k _ _) = arg_tr - in TypeRep (appKey tr_k arg_k) tc (trs++[arg_tr]) - --- If we enforce the restriction that there is only one --- @TyCon@ for a type & it is shared among all its uses, --- we can map them onto Ints very simply. The benefit is, --- of course, that @TyCon@s can then be compared efficiently. - --- Provided the implementor of other @Typeable@ instances --- takes care of making all the @TyCon@s CAFs (toplevel constants), --- this will work. - --- If this constraint does turn out to be a sore thumb, changing --- the Eq instance for TyCons is trivial. - --- | Builds a 'TyCon' object representing a type constructor. An --- implementation of "Data.Typeable" should ensure that the following holds: --- --- > mkTyCon "a" == mkTyCon "a" --- +----------------- Construction --------------------- -mkTyCon :: String -- ^ the name of the type constructor (should be unique - -- in the program, so it might be wise to use the - -- fully qualified name). +{-# DEPRECATED mkTyCon "either derive Typeable, or use mkTyCon3 instead" #-} +-- | Backwards-compatible API +mkTyCon :: String -- ^ unique string -> TyCon -- ^ A unique 'TyCon' object -mkTyCon str = TyCon (mkTyConKey str) str - ------------------ Observation --------------------- - --- | Observe the type constructor of a type representation -typeRepTyCon :: TypeRep -> TyCon -typeRepTyCon (TypeRep _ tc _) = tc - --- | Observe the argument types of a type representation -typeRepArgs :: TypeRep -> [TypeRep] -typeRepArgs (TypeRep _ _ args) = args - --- | Observe string encoding of a type representation -tyConString :: TyCon -> String -tyConString (TyCon _ str) = str - ------------------ Showing TypeReps -------------------- - -instance Show TypeRep where - showsPrec p (TypeRep _ tycon tys) = - case tys of - [] -> showsPrec p tycon - [x] | tycon == listTc -> showChar '[' . shows x . showChar ']' - [a,r] | tycon == funTc -> showParen (p > 8) $ - showsPrec 9 a . - showString " -> " . - showsPrec 8 r - xs | isTupleTyCon tycon -> showTuple xs - | otherwise -> - showParen (p > 9) $ - showsPrec p tycon . - showChar ' ' . - showArgs tys - -showsTypeRep :: TypeRep -> ShowS -showsTypeRep = shows - -instance Show TyCon where - showsPrec _ (TyCon _ s) = showString s - -isTupleTyCon :: TyCon -> Bool -isTupleTyCon (TyCon _ ('(':',':_)) = True -isTupleTyCon _ = False - --- Some (Show.TypeRep) helpers: - -showArgs :: Show a => [a] -> ShowS -showArgs [] = id -showArgs [a] = showsPrec 10 a -showArgs (a:as) = showsPrec 10 a . showString " " . showArgs as - -showTuple :: [TypeRep] -> ShowS -showTuple args = showChar '(' - . (foldr (.) id $ intersperse (showChar ',') - $ map (showsPrec 10) args) - . showChar ')' - -------------------------------------------------------------- --- --- The Typeable class and friends --- -------------------------------------------------------------- - -{- Note [Memoising typeOf] -~~~~~~~~~~~~~~~~~~~~~~~~~~ -IMPORTANT: we don't want to recalculate the type-rep once per -call to the dummy argument. This is what went wrong in Trac #3245 -So we help GHC by manually keeping the 'rep' *outside* the value -lambda, thus - - typeOfDefault :: forall t a. (Typeable1 t, Typeable a) => t a -> TypeRep - typeOfDefault = \_ -> rep - where - rep = typeOf1 (undefined :: t a) `mkAppTy` - typeOf (undefined :: a) - -Notice the crucial use of scoped type variables here! --} - --- | The class 'Typeable' allows a concrete representation of a type to --- be calculated. -class Typeable a where - typeOf :: a -> TypeRep - -- ^ Takes a value of type @a@ and returns a concrete representation - -- of that type. The /value/ of the argument should be ignored by - -- any instance of 'Typeable', so that it is safe to pass 'undefined' as - -- the argument. - --- | Variant for unary type constructors -class Typeable1 t where - typeOf1 :: t a -> TypeRep - -#ifdef __GLASGOW_HASKELL__ --- | For defining a 'Typeable' instance from any 'Typeable1' instance. -typeOfDefault :: forall t a. (Typeable1 t, Typeable a) => t a -> TypeRep -typeOfDefault = \_ -> rep - where - rep = typeOf1 (undefined :: t a) `mkAppTy` - typeOf (undefined :: a) - -- Note [Memoising typeOf] -#else --- | For defining a 'Typeable' instance from any 'Typeable1' instance. -typeOfDefault :: (Typeable1 t, Typeable a) => t a -> TypeRep -typeOfDefault x = typeOf1 x `mkAppTy` typeOf (argType x) - where - argType :: t a -> a - argType = undefined -#endif - --- | Variant for binary type constructors -class Typeable2 t where - typeOf2 :: t a b -> TypeRep - -#ifdef __GLASGOW_HASKELL__ --- | For defining a 'Typeable1' instance from any 'Typeable2' instance. -typeOf1Default :: forall t a b. (Typeable2 t, Typeable a) => t a b -> TypeRep -typeOf1Default = \_ -> rep - where - rep = typeOf2 (undefined :: t a b) `mkAppTy` - typeOf (undefined :: a) - -- Note [Memoising typeOf] -#else --- | For defining a 'Typeable1' instance from any 'Typeable2' instance. -typeOf1Default :: (Typeable2 t, Typeable a) => t a b -> TypeRep -typeOf1Default x = typeOf2 x `mkAppTy` typeOf (argType x) - where - argType :: t a b -> a - argType = undefined -#endif - --- | Variant for 3-ary type constructors -class Typeable3 t where - typeOf3 :: t a b c -> TypeRep - -#ifdef __GLASGOW_HASKELL__ --- | For defining a 'Typeable2' instance from any 'Typeable3' instance. -typeOf2Default :: forall t a b c. (Typeable3 t, Typeable a) => t a b c -> TypeRep -typeOf2Default = \_ -> rep - where - rep = typeOf3 (undefined :: t a b c) `mkAppTy` - typeOf (undefined :: a) - -- Note [Memoising typeOf] -#else --- | For defining a 'Typeable2' instance from any 'Typeable3' instance. -typeOf2Default :: (Typeable3 t, Typeable a) => t a b c -> TypeRep -typeOf2Default x = typeOf3 x `mkAppTy` typeOf (argType x) - where - argType :: t a b c -> a - argType = undefined -#endif - --- | Variant for 4-ary type constructors -class Typeable4 t where - typeOf4 :: t a b c d -> TypeRep - -#ifdef __GLASGOW_HASKELL__ --- | For defining a 'Typeable3' instance from any 'Typeable4' instance. -typeOf3Default :: forall t a b c d. (Typeable4 t, Typeable a) => t a b c d -> TypeRep -typeOf3Default = \_ -> rep - where - rep = typeOf4 (undefined :: t a b c d) `mkAppTy` - typeOf (undefined :: a) - -- Note [Memoising typeOf] -#else --- | For defining a 'Typeable3' instance from any 'Typeable4' instance. -typeOf3Default :: (Typeable4 t, Typeable a) => t a b c d -> TypeRep -typeOf3Default x = typeOf4 x `mkAppTy` typeOf (argType x) - where - argType :: t a b c d -> a - argType = undefined -#endif - --- | Variant for 5-ary type constructors -class Typeable5 t where - typeOf5 :: t a b c d e -> TypeRep - -#ifdef __GLASGOW_HASKELL__ --- | For defining a 'Typeable4' instance from any 'Typeable5' instance. -typeOf4Default :: forall t a b c d e. (Typeable5 t, Typeable a) => t a b c d e -> TypeRep -typeOf4Default = \_ -> rep - where - rep = typeOf5 (undefined :: t a b c d e) `mkAppTy` - typeOf (undefined :: a) - -- Note [Memoising typeOf] -#else --- | For defining a 'Typeable4' instance from any 'Typeable5' instance. -typeOf4Default :: (Typeable5 t, Typeable a) => t a b c d e -> TypeRep -typeOf4Default x = typeOf5 x `mkAppTy` typeOf (argType x) - where - argType :: t a b c d e -> a - argType = undefined -#endif - --- | Variant for 6-ary type constructors -class Typeable6 t where - typeOf6 :: t a b c d e f -> TypeRep - -#ifdef __GLASGOW_HASKELL__ --- | For defining a 'Typeable5' instance from any 'Typeable6' instance. -typeOf5Default :: forall t a b c d e f. (Typeable6 t, Typeable a) => t a b c d e f -> TypeRep -typeOf5Default = \_ -> rep - where - rep = typeOf6 (undefined :: t a b c d e f) `mkAppTy` - typeOf (undefined :: a) - -- Note [Memoising typeOf] -#else --- | For defining a 'Typeable5' instance from any 'Typeable6' instance. -typeOf5Default :: (Typeable6 t, Typeable a) => t a b c d e f -> TypeRep -typeOf5Default x = typeOf6 x `mkAppTy` typeOf (argType x) - where - argType :: t a b c d e f -> a - argType = undefined -#endif - --- | Variant for 7-ary type constructors -class Typeable7 t where - typeOf7 :: t a b c d e f g -> TypeRep - -#ifdef __GLASGOW_HASKELL__ --- | For defining a 'Typeable6' instance from any 'Typeable7' instance. -typeOf6Default :: forall t a b c d e f g. (Typeable7 t, Typeable a) => t a b c d e f g -> TypeRep -typeOf6Default = \_ -> rep - where - rep = typeOf7 (undefined :: t a b c d e f g) `mkAppTy` - typeOf (undefined :: a) - -- Note [Memoising typeOf] -#else --- | For defining a 'Typeable6' instance from any 'Typeable7' instance. -typeOf6Default :: (Typeable7 t, Typeable a) => t a b c d e f g -> TypeRep -typeOf6Default x = typeOf7 x `mkAppTy` typeOf (argType x) - where - argType :: t a b c d e f g -> a - argType = undefined -#endif - -#ifdef __GLASGOW_HASKELL__ --- Given a @Typeable@/n/ instance for an /n/-ary type constructor, --- define the instances for partial applications. --- Programmers using non-GHC implementations must do this manually --- for each type constructor. --- (The INSTANCE_TYPEABLE/n/ macros in Typeable.h include this.) - --- | One Typeable instance for all Typeable1 instances -instance (Typeable1 s, Typeable a) - => Typeable (s a) where - typeOf = typeOfDefault - --- | One Typeable1 instance for all Typeable2 instances -instance (Typeable2 s, Typeable a) - => Typeable1 (s a) where - typeOf1 = typeOf1Default - --- | One Typeable2 instance for all Typeable3 instances -instance (Typeable3 s, Typeable a) - => Typeable2 (s a) where - typeOf2 = typeOf2Default - --- | One Typeable3 instance for all Typeable4 instances -instance (Typeable4 s, Typeable a) - => Typeable3 (s a) where - typeOf3 = typeOf3Default - --- | One Typeable4 instance for all Typeable5 instances -instance (Typeable5 s, Typeable a) - => Typeable4 (s a) where - typeOf4 = typeOf4Default - --- | One Typeable5 instance for all Typeable6 instances -instance (Typeable6 s, Typeable a) - => Typeable5 (s a) where - typeOf5 = typeOf5Default - --- | One Typeable6 instance for all Typeable7 instances -instance (Typeable7 s, Typeable a) - => Typeable6 (s a) where - typeOf6 = typeOf6Default - -#endif /* __GLASGOW_HASKELL__ */ +mkTyCon name = TyCon (fingerprintString name) "" "" name ------------------------------------------------------------- -- @@ -562,176 +207,3 @@ getArg :: c x -> x getArg = undefined -------------------------------------------------------------- --- --- Instances of the Typeable classes for Prelude types --- -------------------------------------------------------------- - -INSTANCE_TYPEABLE0((),unitTc,"()") -INSTANCE_TYPEABLE1([],listTc,"[]") -INSTANCE_TYPEABLE1(Maybe,maybeTc,"Maybe") -INSTANCE_TYPEABLE1(Ratio,ratioTc,"Ratio") -INSTANCE_TYPEABLE2((->),funTc,"->") -INSTANCE_TYPEABLE1(IO,ioTc,"IO") - -#if defined(__GLASGOW_HASKELL__) || defined(__HUGS__) --- Types defined in GHC.MVar -INSTANCE_TYPEABLE1(MVar,mvarTc,"MVar" ) -#endif - -INSTANCE_TYPEABLE2(Array,arrayTc,"Array") -INSTANCE_TYPEABLE2(IOArray,iOArrayTc,"IOArray") - -#ifdef __GLASGOW_HASKELL__ --- Hugs has these too, but their Typeable instances are defined --- elsewhere to keep this module within Haskell 98. --- This is important because every invocation of runhugs or ffihugs --- uses this module via Data.Dynamic. -INSTANCE_TYPEABLE2(ST,stTc,"ST") -INSTANCE_TYPEABLE2(STRef,stRefTc,"STRef") -INSTANCE_TYPEABLE3(STArray,sTArrayTc,"STArray") -#endif - -#ifndef __NHC__ -INSTANCE_TYPEABLE2((,),pairTc,"(,)") -INSTANCE_TYPEABLE3((,,),tup3Tc,"(,,)") -INSTANCE_TYPEABLE4((,,,),tup4Tc,"(,,,)") -INSTANCE_TYPEABLE5((,,,,),tup5Tc,"(,,,,)") -INSTANCE_TYPEABLE6((,,,,,),tup6Tc,"(,,,,,)") -INSTANCE_TYPEABLE7((,,,,,,),tup7Tc,"(,,,,,,)") -#endif /* __NHC__ */ - -INSTANCE_TYPEABLE1(Ptr,ptrTc,"Ptr") -INSTANCE_TYPEABLE1(FunPtr,funPtrTc,"FunPtr") -#ifndef __GLASGOW_HASKELL__ -INSTANCE_TYPEABLE1(ForeignPtr,foreignPtrTc,"ForeignPtr") -#endif -INSTANCE_TYPEABLE1(StablePtr,stablePtrTc,"StablePtr") -INSTANCE_TYPEABLE1(IORef,iORefTc,"IORef") - -------------------------------------------------------- --- --- Generate Typeable instances for standard datatypes --- -------------------------------------------------------- - -INSTANCE_TYPEABLE0(Bool,boolTc,"Bool") -INSTANCE_TYPEABLE0(Char,charTc,"Char") -INSTANCE_TYPEABLE0(Float,floatTc,"Float") -INSTANCE_TYPEABLE0(Double,doubleTc,"Double") -INSTANCE_TYPEABLE0(Int,intTc,"Int") -#ifndef __NHC__ -INSTANCE_TYPEABLE0(Word,wordTc,"Word" ) -#endif -INSTANCE_TYPEABLE0(Integer,integerTc,"Integer") -INSTANCE_TYPEABLE0(Ordering,orderingTc,"Ordering") -#ifndef __GLASGOW_HASKELL__ -INSTANCE_TYPEABLE0(Handle,handleTc,"Handle") -#endif - -INSTANCE_TYPEABLE0(Int8,int8Tc,"Int8") -INSTANCE_TYPEABLE0(Int16,int16Tc,"Int16") -INSTANCE_TYPEABLE0(Int32,int32Tc,"Int32") -INSTANCE_TYPEABLE0(Int64,int64Tc,"Int64") - -INSTANCE_TYPEABLE0(Word8,word8Tc,"Word8" ) -INSTANCE_TYPEABLE0(Word16,word16Tc,"Word16") -INSTANCE_TYPEABLE0(Word32,word32Tc,"Word32") -INSTANCE_TYPEABLE0(Word64,word64Tc,"Word64") - -INSTANCE_TYPEABLE0(TyCon,tyconTc,"TyCon") -INSTANCE_TYPEABLE0(TypeRep,typeRepTc,"TypeRep") - -#ifdef __GLASGOW_HASKELL__ -INSTANCE_TYPEABLE0(RealWorld,realWorldTc,"RealWorld") -#endif - ---------------------------------------------- --- --- Internals --- ---------------------------------------------- - -#ifndef __HUGS__ -newtype Key = Key Int deriving( Eq ) -#endif - -data KeyPr = KeyPr !Key !Key deriving( Eq ) - -hashKP :: KeyPr -> Int32 -hashKP (KeyPr (Key k1) (Key k2)) = (HT.hashInt k1 + HT.hashInt k2) `rem` HT.prime - -data Cache = Cache { next_key :: !(IORef Key), -- Not used by GHC (calls genSym instead) - tc_tbl :: !(HT.HashTable String Key), - ap_tbl :: !(HT.HashTable KeyPr Key) } - -{-# NOINLINE cache #-} -#ifdef __GLASGOW_HASKELL__ -foreign import ccall unsafe "RtsTypeable.h getOrSetTypeableStore" - getOrSetTypeableStore :: Ptr a -> IO (Ptr a) -#endif - -cache :: Cache -cache = unsafePerformIO $ do - empty_tc_tbl <- HT.new (==) HT.hashString - empty_ap_tbl <- HT.new (==) hashKP - key_loc <- newIORef (Key 1) - let ret = Cache { next_key = key_loc, - tc_tbl = empty_tc_tbl, - ap_tbl = empty_ap_tbl } -#ifdef __GLASGOW_HASKELL__ - mask_ $ do - stable_ref <- newStablePtr ret - let ref = castStablePtrToPtr stable_ref - ref2 <- getOrSetTypeableStore ref - if ref==ref2 - then deRefStablePtr stable_ref - else do - freeStablePtr stable_ref - deRefStablePtr - (castPtrToStablePtr ref2) -#else - return ret -#endif - -newKey :: IORef Key -> IO Key -#ifdef __GLASGOW_HASKELL__ -newKey _ = do i <- genSym; return (Key i) -#else -newKey kloc = do { k@(Key i) <- readIORef kloc ; - writeIORef kloc (Key (i+1)) ; - return k } -#endif - -#ifdef __GLASGOW_HASKELL__ -foreign import ccall unsafe "genSymZh" - genSym :: IO Int -#endif - -mkTyConKey :: String -> Key -mkTyConKey str - = unsafePerformIO $ do - let Cache {next_key = kloc, tc_tbl = tbl} = cache - mb_k <- HT.lookup tbl str - case mb_k of - Just k -> return k - Nothing -> do { k <- newKey kloc ; - HT.insert tbl str k ; - return k } - -appKey :: Key -> Key -> Key -appKey k1 k2 - = unsafePerformIO $ do - let Cache {next_key = kloc, ap_tbl = tbl} = cache - mb_k <- HT.lookup tbl kpr - case mb_k of - Just k -> return k - Nothing -> do { k <- newKey kloc ; - HT.insert tbl kpr k ; - return k } - where - kpr = KeyPr k1 k2 - -appKeys :: Key -> [Key] -> Key -appKeys k ks = foldl appKey k ks diff -Nru ghc-7.0.3/libraries/base/Data/Typeable.hs-boot ghc-7.2.1/libraries/base/Data/Typeable.hs-boot --- ghc-7.0.3/libraries/base/Data/Typeable.hs-boot 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/Data/Typeable.hs-boot 2011-08-07 17:10:07.000000000 +0000 @@ -1,19 +1,9 @@ +{-# LANGUAGE NoImplicitPrelude #-} -{-# OPTIONS_GHC -XNoImplicitPrelude #-} - -module Data.Typeable where +module Data.Typeable (Typeable, mkTyConApp, cast) where import Data.Maybe -import GHC.Base - -data TypeRep -data TyCon - -mkTyCon :: String -> TyCon -mkTyConApp :: TyCon -> [TypeRep] -> TypeRep +import {-# SOURCE #-} Data.Typeable.Internal cast :: (Typeable a, Typeable b) => a -> Maybe b -class Typeable a where - typeOf :: a -> TypeRep - diff -Nru ghc-7.0.3/libraries/base/Data/Unique.hs ghc-7.2.1/libraries/base/Data/Unique.hs --- ghc-7.0.3/libraries/base/Data/Unique.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/Data/Unique.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,3 +1,10 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP #-} + +#ifdef __GLASGOW_HASKELL__ +{-# LANGUAGE MagicHash, DeriveDataTypeable #-} +#endif + ----------------------------------------------------------------------------- -- | -- Module : Data.Unique diff -Nru ghc-7.0.3/libraries/base/Data/Version.hs ghc-7.2.1/libraries/base/Data/Version.hs --- ghc-7.0.3/libraries/base/Data/Version.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/Data/Version.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,3 +1,6 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, DeriveDataTypeable #-} + ----------------------------------------------------------------------------- -- | -- Module : Data.Version diff -Nru ghc-7.0.3/libraries/base/Data/Word.hs ghc-7.2.1/libraries/base/Data/Word.hs --- ghc-7.0.3/libraries/base/Data/Word.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/Data/Word.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,6 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE CPP, NoImplicitPrelude #-} + ----------------------------------------------------------------------------- -- | -- Module : Data.Word diff -Nru ghc-7.0.3/libraries/base/Debug/Trace.hs ghc-7.2.1/libraries/base/Debug/Trace.hs --- ghc-7.0.3/libraries/base/Debug/Trace.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/Debug/Trace.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,3 +1,5 @@ +{-# LANGUAGE CPP, ForeignFunctionInterface #-} + ----------------------------------------------------------------------------- -- | -- Module : Debug.Trace diff -Nru ghc-7.0.3/libraries/base/Foreign/C/Error.hs ghc-7.2.1/libraries/base/Foreign/C/Error.hs --- ghc-7.0.3/libraries/base/Foreign/C/Error.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/Foreign/C/Error.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,7 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude -#include "HsBase.h" #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude, ForeignFunctionInterface #-} +{-# OPTIONS_GHC -#include "HsBase.h" #-} + ----------------------------------------------------------------------------- -- | -- Module : Foreign.C.Error diff -Nru ghc-7.0.3/libraries/base/Foreign/C/String.hs ghc-7.2.1/libraries/base/Foreign/C/String.hs --- ghc-7.0.3/libraries/base/Foreign/C/String.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/Foreign/C/String.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,6 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude #-} + ----------------------------------------------------------------------------- -- | -- Module : Foreign.C.String @@ -22,7 +24,6 @@ ----------------------------------------------------------------------------- module Foreign.C.String ( -- representation of strings in C - -- * C strings CString, -- = Ptr CChar @@ -30,8 +31,14 @@ -- ** Using a locale-dependent encoding +#ifndef __GLASGOW_HASKELL__ -- | Currently these functions are identical to their @CAString@ counterparts; -- eventually they will use an encoding determined by the current locale. +#else + -- | These functions are different from their @CAString@ counterparts + -- in that they will use an encoding determined by the current locale, + -- rather than always assuming ASCII. +#endif -- conversion of C strings into Haskell strings -- @@ -101,10 +108,15 @@ import Data.Word #ifdef __GLASGOW_HASKELL__ +import Control.Monad + import GHC.List import GHC.Real import GHC.Num import GHC.Base + +import {-# SOURCE #-} GHC.IO.Encoding +import qualified GHC.Foreign as GHC #else import Data.Char ( chr, ord ) #define unsafeChr chr @@ -132,12 +144,20 @@ -- | Marshal a NUL terminated C string into a Haskell string. -- peekCString :: CString -> IO String +#ifndef __GLASGOW_HASKELL__ peekCString = peekCAString +#else +peekCString = GHC.peekCString foreignEncoding +#endif -- | Marshal a C string with explicit length into a Haskell string. -- peekCStringLen :: CStringLen -> IO String +#ifndef __GLASGOW_HASKELL__ peekCStringLen = peekCAStringLen +#else +peekCStringLen = GHC.peekCStringLen foreignEncoding +#endif -- | Marshal a Haskell string into a NUL terminated C string. -- @@ -148,7 +168,11 @@ -- 'Foreign.Marshal.Alloc.finalizerFree'. -- newCString :: String -> IO CString +#ifndef __GLASGOW_HASKELL__ newCString = newCAString +#else +newCString = GHC.newCString foreignEncoding +#endif -- | Marshal a Haskell string into a C string (ie, character array) with -- explicit length information. @@ -158,7 +182,11 @@ -- 'Foreign.Marshal.Alloc.finalizerFree'. -- newCStringLen :: String -> IO CStringLen +#ifndef __GLASGOW_HASKELL__ newCStringLen = newCAStringLen +#else +newCStringLen = GHC.newCStringLen foreignEncoding +#endif -- | Marshal a Haskell string into a NUL terminated C string using temporary -- storage. @@ -170,7 +198,11 @@ -- storage must /not/ be used after this. -- withCString :: String -> (CString -> IO a) -> IO a +#ifndef __GLASGOW_HASKELL__ withCString = withCAString +#else +withCString = GHC.withCString foreignEncoding +#endif -- | Marshal a Haskell string into a C string (ie, character array) -- in temporary storage, with explicit length information. @@ -180,14 +212,26 @@ -- storage must /not/ be used after this. -- withCStringLen :: String -> (CStringLen -> IO a) -> IO a +#ifndef __GLASGOW_HASKELL__ withCStringLen = withCAStringLen +#else +withCStringLen = GHC.withCStringLen foreignEncoding +#endif + +#ifndef __GLASGOW_HASKELL__ -- | Determines whether a character can be accurately encoded in a 'CString'. -- Unrepresentable characters are converted to @\'?\'@. -- -- Currently only Latin-1 characters are representable. charIsRepresentable :: Char -> IO Bool charIsRepresentable c = return (ord c < 256) +#else +-- -- | Determines whether a character can be accurately encoded in a 'CString'. +-- -- Unrepresentable characters are converted to '?' or their nearest visual equivalent. +charIsRepresentable :: Char -> IO Bool +charIsRepresentable = GHC.charIsRepresentable foreignEncoding +#endif -- single byte characters -- ---------------------- diff -Nru ghc-7.0.3/libraries/base/Foreign/C/Types.hs ghc-7.2.1/libraries/base/Foreign/C/Types.hs --- ghc-7.0.3/libraries/base/Foreign/C/Types.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/Foreign/C/Types.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,7 +1,16 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP + , NoImplicitPrelude + , MagicHash + , GeneralizedNewtypeDeriving + #-} {-# OPTIONS_GHC -fno-warn-unused-binds #-} +#ifdef __GLASGOW_HASKELL__ +{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} +#endif -- XXX -fno-warn-unused-binds stops us warning about unused constructors, -- but really we should just remove them if we don't want them + ----------------------------------------------------------------------------- -- | -- Module : Foreign.C.Types @@ -41,7 +50,7 @@ -- foreign types, and are instances of -- 'Prelude.Eq', 'Prelude.Ord', 'Prelude.Num', 'Prelude.Read', -- 'Prelude.Show', 'Prelude.Enum', 'Typeable' and 'Storable'. - , CClock, CTime + , CClock, CTime, CUSeconds, CSUSeconds -- extracted from CTime, because we don't want this comment in -- the Haskell 2010 report: @@ -65,13 +74,14 @@ #endif #else -- Exported non-abstractly in nhc98 to fix an interface file problem. - CChar(..), CSChar(..), CUChar(..) - , CShort(..), CUShort(..), CInt(..), CUInt(..) + CChar(..), CSChar(..), CUChar(..) + , CShort(..), CUShort(..), CInt(..), CUInt(..) , CLong(..), CULong(..) - , CPtrdiff(..), CSize(..), CWchar(..), CSigAtomic(..) + , CPtrdiff(..), CSize(..), CWchar(..), CSigAtomic(..) , CLLong(..), CULLong(..) - , CClock(..), CTime(..) - , CFloat(..), CDouble(..), CLDouble(..) + , CClock(..), CTime(..), CUSeconds(..), CSUSeconds(..) + , CFloat(..), CDouble(..), CLDouble(..) + , CIntPtr(..), CUIntPtr(..), CIntMax(..), CUIntMax(..) #endif -- ** Other types @@ -85,7 +95,9 @@ import Data.Bits ( Bits(..) ) import Data.Int ( Int8, Int16, Int32, Int64 ) import Data.Word ( Word8, Word16, Word32, Word64 ) -import {-# SOURCE #-} Data.Typeable (Typeable(typeOf), TyCon, mkTyCon, mkTyConApp) +import {-# SOURCE #-} Data.Typeable + -- loop: Data.Typeable -> Data.List -> Data.Char -> GHC.Unicode + -- -> Foreign.C.Type #ifdef __GLASGOW_HASKELL__ import GHC.Base @@ -206,8 +218,11 @@ -- | Haskell type representing the C @clock_t@ type. ARITHMETIC_TYPE(CClock,tyConCClock,"CClock",HTYPE_CLOCK_T) -- | Haskell type representing the C @time_t@ type. --- ARITHMETIC_TYPE(CTime,tyConCTime,"CTime",HTYPE_TIME_T) +-- | Haskell type representing the C @useconds_t@ type. +ARITHMETIC_TYPE(CUSeconds,tyConCUSeconds,"CUSeconds",HTYPE_USECONDS_T) +-- | Haskell type representing the C @suseconds_t@ type. +ARITHMETIC_TYPE(CSUSeconds,tyConCSUSeconds,"CSUSeconds",HTYPE_SUSECONDS_T) -- FIXME: Implement and provide instances for Eq and Storable -- | Haskell type representing the C @FILE@ type. @@ -278,13 +293,14 @@ #else /* __NHC__ */ import NHC.FFI - ( CChar(..), CSChar(..), CUChar(..) - , CShort(..), CUShort(..), CInt(..), CUInt(..) - , CLong(..), CULong(..), CLLong(..), CULLong(..) - , CPtrdiff(..), CSize(..), CWchar(..), CSigAtomic(..) - , CClock(..), CTime(..) - , CFloat(..), CDouble(..), CLDouble(..) - , CFile, CFpos, CJmpBuf + ( CChar(..), CSChar(..), CUChar(..) + , CShort(..), CUShort(..), CInt(..), CUInt(..) + , CLong(..), CULong(..), CLLong(..), CULLong(..) + , CPtrdiff(..), CSize(..), CWchar(..), CSigAtomic(..) + , CClock(..), CTime(..), CUSeconds(..), CSUSeconds(..) + , CFloat(..), CDouble(..), CLDouble(..) + , CIntPtr(..), CUIntPtr(..), CIntMax(..), CUIntMax(..) + , CFile, CFpos, CJmpBuf , Storable(..) ) import Data.Bits @@ -321,5 +337,9 @@ INSTANCE_BITS(CWchar) INSTANCE_BITS(CSigAtomic) INSTANCE_BITS(CSize) +INSTANCE_BITS(CIntPtr) +INSTANCE_BITS(CUIntPtr) +INSTANCE_BITS(CIntMax) +INSTANCE_BITS(CUIntMax) #endif diff -Nru ghc-7.0.3/libraries/base/Foreign/C.hs ghc-7.2.1/libraries/base/Foreign/C.hs --- ghc-7.0.3/libraries/base/Foreign/C.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/Foreign/C.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,6 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE NoImplicitPrelude #-} + ----------------------------------------------------------------------------- -- | -- Module : Foreign.C diff -Nru ghc-7.0.3/libraries/base/Foreign/Concurrent.hs ghc-7.2.1/libraries/base/Foreign/Concurrent.hs --- ghc-7.0.3/libraries/base/Foreign/Concurrent.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/Foreign/Concurrent.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,6 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude #-} + ----------------------------------------------------------------------------- -- | -- Module : Foreign.Concurrent @@ -28,13 +30,11 @@ ) where #ifdef __GLASGOW_HASKELL__ -import GHC.IO ( IO ) -import GHC.Ptr ( Ptr ) -import GHC.ForeignPtr ( ForeignPtr ) +import GHC.IO ( IO ) +import GHC.Ptr ( Ptr ) +import GHC.ForeignPtr ( ForeignPtr ) import qualified GHC.ForeignPtr -#endif -#ifdef __GLASGOW_HASKELL__ newForeignPtr :: Ptr a -> IO () -> IO (ForeignPtr a) -- ^Turns a plain memory reference into a foreign object by associating -- a finalizer - given by the monadic operation - with the reference. @@ -51,3 +51,4 @@ -- same object. addForeignPtrFinalizer = GHC.ForeignPtr.addForeignPtrConcFinalizer #endif + diff -Nru ghc-7.0.3/libraries/base/Foreign/ForeignPtr/Imp.hs ghc-7.2.1/libraries/base/Foreign/ForeignPtr/Imp.hs --- ghc-7.0.3/libraries/base/Foreign/ForeignPtr/Imp.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/base/Foreign/ForeignPtr/Imp.hs 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,180 @@ +{-# LANGUAGE CPP, NoImplicitPrelude #-} +{-# OPTIONS_HADDOCK hide #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Foreign.ForeignPtr.Imp +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : ffi@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- The 'ForeignPtr' type and operations. This module is part of the +-- Foreign Function Interface (FFI) and will usually be imported via +-- the "Foreign" module. +-- +----------------------------------------------------------------------------- + +module Foreign.ForeignPtr.Imp + ( + -- * Finalised data pointers + ForeignPtr + , FinalizerPtr +#if defined(__HUGS__) || defined(__GLASGOW_HASKELL__) + , FinalizerEnvPtr +#endif + -- ** Basic operations + , newForeignPtr + , newForeignPtr_ + , addForeignPtrFinalizer +#if defined(__HUGS__) || defined(__GLASGOW_HASKELL__) + , newForeignPtrEnv + , addForeignPtrFinalizerEnv +#endif + , withForeignPtr + +#ifdef __GLASGOW_HASKELL__ + , finalizeForeignPtr +#endif + + -- ** Low-level operations + , unsafeForeignPtrToPtr + , touchForeignPtr + , castForeignPtr + + -- ** Allocating managed memory + , mallocForeignPtr + , mallocForeignPtrBytes + , mallocForeignPtrArray + , mallocForeignPtrArray0 + ) + where + +import Foreign.Ptr + +#ifdef __NHC__ +import NHC.FFI + ( ForeignPtr + , FinalizerPtr + , newForeignPtr + , newForeignPtr_ + , addForeignPtrFinalizer + , withForeignPtr + , unsafeForeignPtrToPtr + , touchForeignPtr + , castForeignPtr + , Storable(sizeOf) + , malloc, mallocBytes, finalizerFree + ) +#endif + +#ifdef __HUGS__ +import Hugs.ForeignPtr +#endif + +#ifndef __NHC__ +import Foreign.Storable ( Storable(sizeOf) ) +#endif + +#ifdef __GLASGOW_HASKELL__ +import GHC.Base +import GHC.Num +import GHC.Err ( undefined ) +import GHC.ForeignPtr +#endif + +#if !defined(__NHC__) && !defined(__GLASGOW_HASKELL__) +import Foreign.Marshal.Alloc ( malloc, mallocBytes, finalizerFree ) + +instance Eq (ForeignPtr a) where + p == q = unsafeForeignPtrToPtr p == unsafeForeignPtrToPtr q + +instance Ord (ForeignPtr a) where + compare p q = compare (unsafeForeignPtrToPtr p) (unsafeForeignPtrToPtr q) + +instance Show (ForeignPtr a) where + showsPrec p f = showsPrec p (unsafeForeignPtrToPtr f) +#endif + + +#ifndef __NHC__ +newForeignPtr :: FinalizerPtr a -> Ptr a -> IO (ForeignPtr a) +-- ^Turns a plain memory reference into a foreign pointer, and +-- associates a finalizer with the reference. The finalizer will be +-- executed after the last reference to the foreign object is dropped. +-- There is no guarantee of promptness, however the finalizer will be +-- executed before the program exits. +newForeignPtr finalizer p + = do fObj <- newForeignPtr_ p + addForeignPtrFinalizer finalizer fObj + return fObj + +withForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b +-- ^This is a way to look at the pointer living inside a +-- foreign object. This function takes a function which is +-- applied to that pointer. The resulting 'IO' action is then +-- executed. The foreign object is kept alive at least during +-- the whole action, even if it is not used directly +-- inside. Note that it is not safe to return the pointer from +-- the action and use it after the action completes. All uses +-- of the pointer should be inside the +-- 'withForeignPtr' bracket. The reason for +-- this unsafeness is the same as for +-- 'unsafeForeignPtrToPtr' below: the finalizer +-- may run earlier than expected, because the compiler can only +-- track usage of the 'ForeignPtr' object, not +-- a 'Ptr' object made from it. +-- +-- This function is normally used for marshalling data to +-- or from the object pointed to by the +-- 'ForeignPtr', using the operations from the +-- 'Storable' class. +withForeignPtr fo io + = do r <- io (unsafeForeignPtrToPtr fo) + touchForeignPtr fo + return r +#endif /* ! __NHC__ */ + +#if defined(__HUGS__) || defined(__GLASGOW_HASKELL__) +-- | This variant of 'newForeignPtr' adds a finalizer that expects an +-- environment in addition to the finalized pointer. The environment +-- that will be passed to the finalizer is fixed by the second argument to +-- 'newForeignPtrEnv'. +newForeignPtrEnv :: + FinalizerEnvPtr env a -> Ptr env -> Ptr a -> IO (ForeignPtr a) +newForeignPtrEnv finalizer env p + = do fObj <- newForeignPtr_ p + addForeignPtrFinalizerEnv finalizer env fObj + return fObj +#endif /* __HUGS__ */ + +#ifndef __GLASGOW_HASKELL__ +mallocForeignPtr :: Storable a => IO (ForeignPtr a) +mallocForeignPtr = do + r <- malloc + newForeignPtr finalizerFree r + +mallocForeignPtrBytes :: Int -> IO (ForeignPtr a) +mallocForeignPtrBytes n = do + r <- mallocBytes n + newForeignPtr finalizerFree r +#endif /* !__GLASGOW_HASKELL__ */ + +-- | This function is similar to 'Foreign.Marshal.Array.mallocArray', +-- but yields a memory area that has a finalizer attached that releases +-- the memory area. As with 'mallocForeignPtr', it is not guaranteed that +-- the block of memory was allocated by 'Foreign.Marshal.Alloc.malloc'. +mallocForeignPtrArray :: Storable a => Int -> IO (ForeignPtr a) +mallocForeignPtrArray = doMalloc undefined + where + doMalloc :: Storable b => b -> Int -> IO (ForeignPtr b) + doMalloc dummy size = mallocForeignPtrBytes (size * sizeOf dummy) + +-- | This function is similar to 'Foreign.Marshal.Array.mallocArray0', +-- but yields a memory area that has a finalizer attached that releases +-- the memory area. As with 'mallocForeignPtr', it is not guaranteed that +-- the block of memory was allocated by 'Foreign.Marshal.Alloc.malloc'. +mallocForeignPtrArray0 :: Storable a => Int -> IO (ForeignPtr a) +mallocForeignPtrArray0 size = mallocForeignPtrArray (size + 1) diff -Nru ghc-7.0.3/libraries/base/Foreign/ForeignPtr/Safe.hs ghc-7.2.1/libraries/base/Foreign/ForeignPtr/Safe.hs --- ghc-7.0.3/libraries/base/Foreign/ForeignPtr/Safe.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/base/Foreign/ForeignPtr/Safe.hs 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,55 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Foreign.ForeignPtr.Safe +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : ffi@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- The 'ForeignPtr' type and operations. This module is part of the +-- Foreign Function Interface (FFI) and will usually be imported via +-- the "Foreign" module. +-- +-- Safe API Only. +-- +----------------------------------------------------------------------------- + +module Foreign.ForeignPtr.Safe ( + -- * Finalised data pointers + ForeignPtr + , FinalizerPtr +#if defined(__HUGS__) || defined(__GLASGOW_HASKELL__) + , FinalizerEnvPtr +#endif + -- ** Basic operations + , newForeignPtr + , newForeignPtr_ + , addForeignPtrFinalizer +#if defined(__HUGS__) || defined(__GLASGOW_HASKELL__) + , newForeignPtrEnv + , addForeignPtrFinalizerEnv +#endif + , withForeignPtr + +#ifdef __GLASGOW_HASKELL__ + , finalizeForeignPtr +#endif + + -- ** Low-level operations + , touchForeignPtr + , castForeignPtr + + -- ** Allocating managed memory + , mallocForeignPtr + , mallocForeignPtrBytes + , mallocForeignPtrArray + , mallocForeignPtrArray0 + ) where + +import Foreign.ForeignPtr.Imp + diff -Nru ghc-7.0.3/libraries/base/Foreign/ForeignPtr/Unsafe.hs ghc-7.2.1/libraries/base/Foreign/ForeignPtr/Unsafe.hs --- ghc-7.0.3/libraries/base/Foreign/ForeignPtr/Unsafe.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/base/Foreign/ForeignPtr/Unsafe.hs 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,28 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Foreign.ForeignPtr.Unsafe +-- Copyright : (c) The University of Glasgow 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : ffi@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- The 'ForeignPtr' type and operations. This module is part of the +-- Foreign Function Interface (FFI) and will usually be imported via +-- the "Foreign" module. +-- +-- Unsafe API Only. +-- +----------------------------------------------------------------------------- + +module Foreign.ForeignPtr.Unsafe ( + -- ** Unsafe low-level operations + unsafeForeignPtrToPtr, + ) where + +import Foreign.ForeignPtr.Imp + diff -Nru ghc-7.0.3/libraries/base/Foreign/ForeignPtr.hs ghc-7.2.1/libraries/base/Foreign/ForeignPtr.hs --- ghc-7.0.3/libraries/base/Foreign/ForeignPtr.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/Foreign/ForeignPtr.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,9 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE SafeImports, CPP, NoImplicitPrelude #-} +#if sh_SAFE_DEFAULT +{-# LANGUAGE Trustworthy #-} +#endif +{-# OPTIONS_HADDOCK hide #-} + ----------------------------------------------------------------------------- -- | -- Module : Foreign.ForeignPtr @@ -15,165 +20,23 @@ -- ----------------------------------------------------------------------------- -module Foreign.ForeignPtr - ( - -- * Finalised data pointers - ForeignPtr - , FinalizerPtr -#if defined(__HUGS__) || defined(__GLASGOW_HASKELL__) - , FinalizerEnvPtr -#endif - -- ** Basic operations - , newForeignPtr - , newForeignPtr_ - , addForeignPtrFinalizer -#if defined(__HUGS__) || defined(__GLASGOW_HASKELL__) - , newForeignPtrEnv - , addForeignPtrFinalizerEnv -#endif - , withForeignPtr - -#ifdef __GLASGOW_HASKELL__ - , finalizeForeignPtr -#endif - - -- ** Low-level operations +module Foreign.ForeignPtr ( + module Foreign.ForeignPtr.Safe +#if !sh_SAFE_DEFAULT + -- ** Unsafe low-level operations , unsafeForeignPtrToPtr - , touchForeignPtr - , castForeignPtr - - -- ** Allocating managed memory - , mallocForeignPtr - , mallocForeignPtrBytes - , mallocForeignPtrArray - , mallocForeignPtrArray0 - ) - where - -import Foreign.Ptr - -#ifdef __NHC__ -import NHC.FFI - ( ForeignPtr - , FinalizerPtr - , newForeignPtr - , newForeignPtr_ - , addForeignPtrFinalizer - , withForeignPtr - , unsafeForeignPtrToPtr - , touchForeignPtr - , castForeignPtr - , Storable(sizeOf) - , malloc, mallocBytes, finalizerFree - ) -#endif - -#ifdef __HUGS__ -import Hugs.ForeignPtr #endif + ) where -#ifndef __NHC__ -import Foreign.Storable ( Storable(sizeOf) ) -#endif +import safe Foreign.ForeignPtr.Safe -#ifdef __GLASGOW_HASKELL__ -import GHC.Base --- import GHC.IO -import GHC.Num -import GHC.Err ( undefined ) -import GHC.ForeignPtr +#if !sh_SAFE_DEFAULT +import Foreign.Ptr ( Ptr ) +import qualified Foreign.ForeignPtr.Unsafe as U + +{-# DEPRECATED unsafeForeignPtrToPtr "Use Foreign.ForeignPtr.Unsafe.unsafeForeignPtrToPtr instead; This function will be removed in the next release" #-} +{-# INLINE unsafeForeignPtrToPtr #-} +unsafeForeignPtrToPtr :: ForeignPtr a -> Ptr a +unsafeForeignPtrToPtr = U.unsafeForeignPtrToPtr #endif -#if !defined(__NHC__) && !defined(__GLASGOW_HASKELL__) -import Foreign.Marshal.Alloc ( malloc, mallocBytes, finalizerFree ) - -instance Eq (ForeignPtr a) where - p == q = unsafeForeignPtrToPtr p == unsafeForeignPtrToPtr q - -instance Ord (ForeignPtr a) where - compare p q = compare (unsafeForeignPtrToPtr p) (unsafeForeignPtrToPtr q) - -instance Show (ForeignPtr a) where - showsPrec p f = showsPrec p (unsafeForeignPtrToPtr f) -#endif - - -#ifndef __NHC__ -newForeignPtr :: FinalizerPtr a -> Ptr a -> IO (ForeignPtr a) --- ^Turns a plain memory reference into a foreign pointer, and --- associates a finalizer with the reference. The finalizer will be --- executed after the last reference to the foreign object is dropped. --- There is no guarantee of promptness, however the finalizer will be --- executed before the program exits. -newForeignPtr finalizer p - = do fObj <- newForeignPtr_ p - addForeignPtrFinalizer finalizer fObj - return fObj - -withForeignPtr :: ForeignPtr a -> (Ptr a -> IO b) -> IO b --- ^This is a way to look at the pointer living inside a --- foreign object. This function takes a function which is --- applied to that pointer. The resulting 'IO' action is then --- executed. The foreign object is kept alive at least during --- the whole action, even if it is not used directly --- inside. Note that it is not safe to return the pointer from --- the action and use it after the action completes. All uses --- of the pointer should be inside the --- 'withForeignPtr' bracket. The reason for --- this unsafeness is the same as for --- 'unsafeForeignPtrToPtr' below: the finalizer --- may run earlier than expected, because the compiler can only --- track usage of the 'ForeignPtr' object, not --- a 'Ptr' object made from it. --- --- This function is normally used for marshalling data to --- or from the object pointed to by the --- 'ForeignPtr', using the operations from the --- 'Storable' class. -withForeignPtr fo io - = do r <- io (unsafeForeignPtrToPtr fo) - touchForeignPtr fo - return r -#endif /* ! __NHC__ */ - -#if defined(__HUGS__) || defined(__GLASGOW_HASKELL__) --- | This variant of 'newForeignPtr' adds a finalizer that expects an --- environment in addition to the finalized pointer. The environment --- that will be passed to the finalizer is fixed by the second argument to --- 'newForeignPtrEnv'. -newForeignPtrEnv :: - FinalizerEnvPtr env a -> Ptr env -> Ptr a -> IO (ForeignPtr a) -newForeignPtrEnv finalizer env p - = do fObj <- newForeignPtr_ p - addForeignPtrFinalizerEnv finalizer env fObj - return fObj -#endif /* __HUGS__ */ - -#ifndef __GLASGOW_HASKELL__ -mallocForeignPtr :: Storable a => IO (ForeignPtr a) -mallocForeignPtr = do - r <- malloc - newForeignPtr finalizerFree r - -mallocForeignPtrBytes :: Int -> IO (ForeignPtr a) -mallocForeignPtrBytes n = do - r <- mallocBytes n - newForeignPtr finalizerFree r -#endif /* !__GLASGOW_HASKELL__ */ - --- | This function is similar to 'Foreign.Marshal.Array.mallocArray', --- but yields a memory area that has a finalizer attached that releases --- the memory area. As with 'mallocForeignPtr', it is not guaranteed that --- the block of memory was allocated by 'Foreign.Marshal.Alloc.malloc'. -mallocForeignPtrArray :: Storable a => Int -> IO (ForeignPtr a) -mallocForeignPtrArray = doMalloc undefined - where - doMalloc :: Storable b => b -> Int -> IO (ForeignPtr b) - doMalloc dummy size = mallocForeignPtrBytes (size * sizeOf dummy) - --- | This function is similar to 'Foreign.Marshal.Array.mallocArray0', --- but yields a memory area that has a finalizer attached that releases --- the memory area. As with 'mallocForeignPtr', it is not guaranteed that --- the block of memory was allocated by 'Foreign.Marshal.Alloc.malloc'. -mallocForeignPtrArray0 :: Storable a => Int -> IO (ForeignPtr a) -mallocForeignPtrArray0 size = mallocForeignPtrArray (size + 1) diff -Nru ghc-7.0.3/libraries/base/Foreign/Marshal/Alloc.hs ghc-7.2.1/libraries/base/Foreign/Marshal/Alloc.hs --- ghc-7.0.3/libraries/base/Foreign/Marshal/Alloc.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/Foreign/Marshal/Alloc.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,11 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP + , NoImplicitPrelude + , MagicHash + , UnboxedTuples + , ForeignFunctionInterface + #-} + ----------------------------------------------------------------------------- -- | -- Module : Foreign.Marshal.Alloc @@ -16,8 +23,9 @@ -- foreign functions or to provide space in which compound result values -- are obtained from foreign functions. -- --- If any of the allocation functions fails, a value of 'nullPtr' is --- produced. If 'free' or 'reallocBytes' is applied to a memory area +-- If any of the allocation functions fails, an exception is thrown. +-- In some cases, memory exhaustion may mean the process is terminated. +-- If 'free' or 'reallocBytes' is applied to a memory area -- that has been allocated with 'alloca' or 'allocaBytes', the -- behaviour is undefined. Any further access to memory areas allocated with -- 'alloca' or 'allocaBytes', after the computation that was passed to diff -Nru ghc-7.0.3/libraries/base/Foreign/Marshal/Array.hs ghc-7.2.1/libraries/base/Foreign/Marshal/Array.hs --- ghc-7.0.3/libraries/base/Foreign/Marshal/Array.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/Foreign/Marshal/Array.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,6 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude, MagicHash #-} + ----------------------------------------------------------------------------- -- | -- Module : Foreign.Marshal.Array diff -Nru ghc-7.0.3/libraries/base/Foreign/Marshal/Error.hs ghc-7.2.1/libraries/base/Foreign/Marshal/Error.hs --- ghc-7.0.3/libraries/base/Foreign/Marshal/Error.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/Foreign/Marshal/Error.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,6 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude #-} + ----------------------------------------------------------------------------- -- | -- Module : Foreign.Marshal.Error @@ -37,7 +39,6 @@ #endif import GHC.Base import GHC.Num --- import GHC.IO import GHC.IO.Exception #endif diff -Nru ghc-7.0.3/libraries/base/Foreign/Marshal/Pool.hs ghc-7.2.1/libraries/base/Foreign/Marshal/Pool.hs --- ghc-7.0.3/libraries/base/Foreign/Marshal/Pool.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/Foreign/Marshal/Pool.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,6 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude #-} + -------------------------------------------------------------------------------- -- | -- Module : Foreign.Marshal.Pool diff -Nru ghc-7.0.3/libraries/base/Foreign/Marshal/Safe.hs ghc-7.2.1/libraries/base/Foreign/Marshal/Safe.hs --- ghc-7.0.3/libraries/base/Foreign/Marshal/Safe.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/base/Foreign/Marshal/Safe.hs 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,36 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE CPP, NoImplicitPrelude #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Foreign.Marshal.Safe +-- Copyright : (c) The FFI task force 2003 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : ffi@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Marshalling support +-- +-- Safe API Only. +-- +----------------------------------------------------------------------------- + +module Foreign.Marshal.Safe + ( + -- | The module "Foreign.Marshal.Safe" re-exports the other modules in the + -- @Foreign.Marshal@ hierarchy: + module Foreign.Marshal.Alloc + , module Foreign.Marshal.Array + , module Foreign.Marshal.Error + , module Foreign.Marshal.Pool + , module Foreign.Marshal.Utils + ) where + +import Foreign.Marshal.Alloc +import Foreign.Marshal.Array +import Foreign.Marshal.Error +import Foreign.Marshal.Pool +import Foreign.Marshal.Utils + diff -Nru ghc-7.0.3/libraries/base/Foreign/Marshal/Unsafe.hs ghc-7.2.1/libraries/base/Foreign/Marshal/Unsafe.hs --- ghc-7.0.3/libraries/base/Foreign/Marshal/Unsafe.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/base/Foreign/Marshal/Unsafe.hs 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,49 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Foreign.Marshal.Unsafe +-- Copyright : (c) The FFI task force 2003 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : ffi@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- Marshalling support. Unsafe API. +-- +----------------------------------------------------------------------------- + +module Foreign.Marshal.Unsafe ( + -- * Unsafe functions + unsafeLocalState + ) where + +#ifdef __GLASGOW_HASKELL__ +import GHC.IO +#else +import System.IO.Unsafe +#endif + +{- | +Sometimes an external entity is a pure function, except that it passes +arguments and/or results via pointers. The function +@unsafeLocalState@ permits the packaging of such entities as pure +functions. + +The only IO operations allowed in the IO action passed to +@unsafeLocalState@ are (a) local allocation (@alloca@, @allocaBytes@ +and derived operations such as @withArray@ and @withCString@), and (b) +pointer operations (@Foreign.Storable@ and @Foreign.Ptr@) on the +pointers to local storage, and (c) foreign functions whose only +observable effect is to read and/or write the locally allocated +memory. Passing an IO operation that does not obey these rules +results in undefined behaviour. + +It is expected that this operation will be +replaced in a future revision of Haskell. +-} +unsafeLocalState :: IO a -> a +unsafeLocalState = unsafeDupablePerformIO + diff -Nru ghc-7.0.3/libraries/base/Foreign/Marshal/Utils.hs ghc-7.2.1/libraries/base/Foreign/Marshal/Utils.hs --- ghc-7.0.3/libraries/base/Foreign/Marshal/Utils.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/Foreign/Marshal/Utils.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,6 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude, ForeignFunctionInterface #-} + ----------------------------------------------------------------------------- -- | -- Module : Foreign.Marshal.Utils @@ -117,8 +119,8 @@ -- -- * the 'nullPtr' is used to represent 'Nothing' -- -maybeNew :: ( a -> IO (Ptr a)) - -> (Maybe a -> IO (Ptr a)) +maybeNew :: ( a -> IO (Ptr b)) + -> (Maybe a -> IO (Ptr b)) maybeNew = maybe (return nullPtr) -- |Converts a @withXXX@ combinator into one marshalling a value wrapped diff -Nru ghc-7.0.3/libraries/base/Foreign/Marshal.hs ghc-7.2.1/libraries/base/Foreign/Marshal.hs --- ghc-7.0.3/libraries/base/Foreign/Marshal.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/Foreign/Marshal.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,5 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE CPP, NoImplicitPrelude #-} + ----------------------------------------------------------------------------- -- | -- Module : Foreign.Marshal @@ -15,22 +16,14 @@ module Foreign.Marshal ( - -- | The module "Foreign.Marshal" re-exports the other modules in the + -- | The module "Foreign.Marshal" re-exports the safe content in the -- @Foreign.Marshal@ hierarchy: - module Foreign.Marshal.Alloc - , module Foreign.Marshal.Array - , module Foreign.Marshal.Error - , module Foreign.Marshal.Pool - , module Foreign.Marshal.Utils + module Foreign.Marshal.Safe -- | and provides one function: , unsafeLocalState ) where -import Foreign.Marshal.Alloc -import Foreign.Marshal.Array -import Foreign.Marshal.Error -import Foreign.Marshal.Pool -import Foreign.Marshal.Utils +import Foreign.Marshal.Safe #ifdef __GLASGOW_HASKELL__ import GHC.IO @@ -56,5 +49,9 @@ It is expected that this operation will be replaced in a future revision of Haskell. -} +{-# DEPRECATED unsafeLocalState + "Please import from Foreign.Marshall.Unsafe instead; This will be removed in the next release" + #-} unsafeLocalState :: IO a -> a unsafeLocalState = unsafePerformIO + diff -Nru ghc-7.0.3/libraries/base/Foreign/Ptr.hs ghc-7.2.1/libraries/base/Foreign/Ptr.hs --- ghc-7.0.3/libraries/base/Foreign/Ptr.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/Foreign/Ptr.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,14 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP + , NoImplicitPrelude + , ForeignFunctionInterface + , MagicHash + , GeneralizedNewtypeDeriving + #-} +#ifdef __GLASGOW_HASKELL__ +{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} +#endif + ----------------------------------------------------------------------------- -- | -- Module : Foreign.Ptr @@ -58,7 +68,6 @@ import GHC.Enum import GHC.Word ( Word(..) ) --- import Data.Int import Data.Word #else import Control.Monad ( liftM ) diff -Nru ghc-7.0.3/libraries/base/Foreign/Safe.hs ghc-7.2.1/libraries/base/Foreign/Safe.hs --- ghc-7.0.3/libraries/base/Foreign/Safe.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/base/Foreign/Safe.hs 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,40 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE NoImplicitPrelude #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Foreign.Safe +-- Copyright : (c) The FFI task force 2001 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : ffi@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- A collection of data types, classes, and functions for interfacing +-- with another programming language. +-- +-- Safe API Only. +-- +----------------------------------------------------------------------------- + +module Foreign.Safe + ( module Data.Bits + , module Data.Int + , module Data.Word + , module Foreign.Ptr + , module Foreign.ForeignPtr.Safe + , module Foreign.StablePtr + , module Foreign.Storable + , module Foreign.Marshal.Safe + ) where + +import Data.Bits +import Data.Int +import Data.Word +import Foreign.Ptr +import Foreign.ForeignPtr.Safe +import Foreign.StablePtr +import Foreign.Storable +import Foreign.Marshal.Safe + diff -Nru ghc-7.0.3/libraries/base/Foreign/StablePtr.hs ghc-7.2.1/libraries/base/Foreign/StablePtr.hs --- ghc-7.0.3/libraries/base/Foreign/StablePtr.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/Foreign/StablePtr.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,6 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude #-} + ----------------------------------------------------------------------------- -- | -- Module : Foreign.StablePtr diff -Nru ghc-7.0.3/libraries/base/Foreign/Storable.hs ghc-7.2.1/libraries/base/Foreign/Storable.hs --- ghc-7.0.3/libraries/base/Foreign/Storable.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/Foreign/Storable.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,9 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude, ScopedTypeVariables #-} +#ifdef __GLASGOW_HASKELL__ +{-# LANGUAGE BangPatterns #-} +#endif + ----------------------------------------------------------------------------- -- | -- Module : Foreign.Storable @@ -49,6 +54,9 @@ import GHC.Ptr import GHC.Err import GHC.Base +import GHC.Fingerprint.Type +import Data.Bits +import GHC.Real #else import Data.Int import Data.Word @@ -242,3 +250,37 @@ readInt64OffPtr,writeInt64OffPtr) #endif + +-- XXX: here to avoid orphan instance in GHC.Fingerprint +#ifdef __GLASGOW_HASKELL__ +instance Storable Fingerprint where + sizeOf _ = 16 + alignment _ = 8 + peek = peekFingerprint + poke = pokeFingerprint + +-- peek/poke in fixed BIG-endian 128-bit format +peekFingerprint :: Ptr Fingerprint -> IO Fingerprint +peekFingerprint p0 = do + let peekW64 :: Ptr Word8 -> Int -> Word64 -> IO Word64 + peekW64 _ 0 !i = return i + peekW64 !p !n !i = do + w8 <- peek p + peekW64 (p `plusPtr` 1) (n-1) + ((i `shiftL` 8) .|. fromIntegral w8) + + high <- peekW64 (castPtr p0) 8 0 + low <- peekW64 (castPtr p0 `plusPtr` 8) 8 0 + return (Fingerprint high low) + +pokeFingerprint :: Ptr Fingerprint -> Fingerprint -> IO () +pokeFingerprint p0 (Fingerprint high low) = do + let pokeW64 :: Ptr Word8 -> Int -> Word64 -> IO () + pokeW64 _ 0 _ = return () + pokeW64 p !n !i = do + pokeElemOff p (n-1) (fromIntegral i) + pokeW64 p (n-1) (i `shiftR` 8) + + pokeW64 (castPtr p0) 8 high + pokeW64 (castPtr p0 `plusPtr` 8) 8 low +#endif diff -Nru ghc-7.0.3/libraries/base/Foreign.hs ghc-7.2.1/libraries/base/Foreign.hs --- ghc-7.0.3/libraries/base/Foreign.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/Foreign.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,8 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +#if sh_SAFE_DEFAULT +{-# LANGUAGE Trustworthy #-} +#endif +{-# LANGUAGE NoImplicitPrelude #-} + ----------------------------------------------------------------------------- -- | -- Module : Foreign @@ -24,11 +28,15 @@ , module Foreign.Storable , module Foreign.Marshal +#if !sh_SAFE_DEFAULT + -- * Unsafe Functions + -- | 'unsafePerformIO' is exported here for backwards -- compatibility reasons only. For doing local marshalling in -- the FFI, use 'unsafeLocalState'. For other uses, see -- 'System.IO.Unsafe.unsafePerformIO'. , unsafePerformIO +#endif ) where import Data.Bits @@ -40,4 +48,14 @@ import Foreign.Storable import Foreign.Marshal -import System.IO.Unsafe (unsafePerformIO) +#if !sh_SAFE_DEFAULT +import GHC.IO (IO) +import qualified System.IO.Unsafe (unsafePerformIO) + +{-# DEPRECATED unsafePerformIO "Use System.IO.Unsafe.unsafePerformIO instead; This function will be removed in the next release" #-} + +{-# INLINE unsafePerformIO #-} +unsafePerformIO :: IO a -> a +unsafePerformIO = System.IO.Unsafe.unsafePerformIO +#endif + diff -Nru ghc-7.0.3/libraries/base/GHC/Arr.lhs ghc-7.2.1/libraries/base/GHC/Arr.lhs --- ghc-7.0.3/libraries/base/GHC/Arr.lhs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/Arr.lhs 2011-08-07 17:10:07.000000000 +0000 @@ -1,7 +1,8 @@ \begin{code} +{-# LANGUAGE NoImplicitPrelude, NoBangPatterns, MagicHash, UnboxedTuples #-} {-# OPTIONS_GHC -funbox-strict-fields #-} -{-# LANGUAGE NoImplicitPrelude, NoBangPatterns #-} {-# OPTIONS_HADDOCK hide #-} + ----------------------------------------------------------------------------- -- | -- Module : GHC.Arr @@ -17,7 +18,28 @@ ----------------------------------------------------------------------------- -- #hide -module GHC.Arr where +module GHC.Arr ( + Ix(..), Array(..), STArray(..), + + indexError, hopelessIndexError, + arrEleBottom, array, listArray, + (!), safeRangeSize, negRange, safeIndex, badSafeIndex, + bounds, numElements, numElementsSTArray, indices, elems, + assocs, accumArray, adjust, (//), accum, + amap, ixmap, + eqArray, cmpArray, cmpIntArray, + newSTArray, boundsSTArray, + readSTArray, writeSTArray, + freezeSTArray, thawSTArray, + + -- * Unsafe operations + fill, done, + unsafeArray, unsafeArray', + lessSafeIndex, unsafeAt, unsafeReplace, + unsafeAccumArray, unsafeAccumArray', unsafeAccum, + unsafeReadSTArray, unsafeWriteSTArray, + unsafeFreezeSTArray, unsafeThawSTArray, + ) where import GHC.Enum import GHC.Num @@ -350,17 +372,15 @@ %********************************************************* \begin{code} -type IPr = (Int, Int) - -- | The type of immutable non-strict (boxed) arrays -- with indices in @i@ and elements in @e@. -data Ix i => Array i e - = Array !i -- the lower bound, l - !i -- the upper bound, u - !Int -- a cache of (rangeSize (l,u)) - -- used to make sure an index is - -- really in range - (Array# e) -- The actual elements +data Array i e + = Array !i -- the lower bound, l + !i -- the upper bound, u + !Int -- a cache of (rangeSize (l,u)) + -- used to make sure an index is + -- really in range + (Array# e) -- The actual elements -- | Mutable, boxed, non-strict arrays in the 'ST' monad. The type -- arguments are as follows: diff -Nru ghc-7.0.3/libraries/base/GHC/Base.lhs ghc-7.2.1/libraries/base/GHC/Base.lhs --- ghc-7.0.3/libraries/base/GHC/Base.lhs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/Base.lhs 2011-08-07 17:10:07.000000000 +0000 @@ -62,11 +62,20 @@ Other Prelude modules are much easier with fewer complex dependencies. \begin{code} -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE CPP + , NoImplicitPrelude + , BangPatterns + , ExplicitForAll + , MagicHash + , UnboxedTuples + , ExistentialQuantification + , Rank2Types + #-} -- -fno-warn-orphans is needed for things like: -- Orphan rule: "x# -# x#" ALWAYS forall x# :: Int# -# x# x# = 0 {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_HADDOCK hide #-} + ----------------------------------------------------------------------------- -- | -- Module : GHC.Base @@ -87,9 +96,8 @@ module GHC.Base ( module GHC.Base, - module GHC.Bool, module GHC.Classes, - module GHC.Generics, + module GHC.CString, module GHC.Ordering, module GHC.Types, module GHC.Prim, -- Re-export GHC.Prim and GHC.Err, to avoid lots @@ -98,9 +106,8 @@ where import GHC.Types -import GHC.Bool import GHC.Classes -import GHC.Generics +import GHC.CString import GHC.Ordering import GHC.Prim import {-# SOURCE #-} GHC.Show @@ -146,15 +153,6 @@ build = error "urk" foldr = error "urk" - -unpackCString# :: Addr# -> [Char] -unpackFoldrCString# :: Addr# -> (Char -> a -> a) -> a -> a -unpackAppendCString# :: Addr# -> [Char] -> [Char] -unpackCStringUtf8# :: Addr# -> [Char] -unpackCString# a = error "urk" -unpackFoldrCString# a = error "urk" -unpackAppendCString# a = error "urk" -unpackCStringUtf8# a = error "urk" -} \end{code} @@ -500,26 +498,6 @@ minInt = I# (-0x8000000000000000#) maxInt = I# 0x7FFFFFFFFFFFFFFF# #endif - -instance Eq Int where - (==) = eqInt - (/=) = neInt - -instance Ord Int where - compare = compareInt - (<) = ltInt - (<=) = leInt - (>=) = geInt - (>) = gtInt - -compareInt :: Int -> Int -> Ordering -(I# x#) `compareInt` (I# y#) = compareInt# x# y# - -compareInt# :: Int# -> Int# -> Ordering -compareInt# x# y# - | x# <# y# = LT - | x# ==# y# = EQ - | otherwise = GT \end{code} @@ -631,7 +609,7 @@ m >> k = m >>= \ _ -> k return = returnIO (>>=) = bindIO - fail s = GHC.IO.failIO s + fail s = failIO s returnIO :: a -> IO a returnIO x = IO $ \ s -> (# s, x #) @@ -701,12 +679,6 @@ used in the case of partial applications, etc. \begin{code} -{-# INLINE eqInt #-} -{-# INLINE neInt #-} -{-# INLINE gtInt #-} -{-# INLINE geInt #-} -{-# INLINE ltInt #-} -{-# INLINE leInt #-} {-# INLINE plusInt #-} {-# INLINE minusInt #-} {-# INLINE timesInt #-} @@ -737,14 +709,6 @@ negateInt :: Int -> Int negateInt (I# x) = I# (negateInt# x) -gtInt, geInt, eqInt, neInt, ltInt, leInt :: Int -> Int -> Bool -(I# x) `gtInt` (I# y) = x ># y -(I# x) `geInt` (I# y) = x >=# y -(I# x) `eqInt` (I# y) = x ==# y -(I# x) `neInt` (I# y) = x /=# y -(I# x) `ltInt` (I# y) = x <# y -(I# x) `leInt` (I# y) = x <=# y - {-# RULES "x# ># x#" forall x#. x# ># x# = False "x# >=# x#" forall x#. x# >=# x# = True @@ -758,9 +722,6 @@ "plusFloat x 0.0" forall x#. plusFloat# x# 0.0# = x# "plusFloat 0.0 x" forall x#. plusFloat# 0.0# x# = x# "minusFloat x 0.0" forall x#. minusFloat# x# 0.0# = x# -"minusFloat x x" forall x#. minusFloat# x# x# = 0.0# -"timesFloat x 0.0" forall x#. timesFloat# x# 0.0# = 0.0# -"timesFloat0.0 x" forall x#. timesFloat# 0.0# x# = 0.0# "timesFloat x 1.0" forall x#. timesFloat# x# 1.0# = x# "timesFloat 1.0 x" forall x#. timesFloat# 1.0# x# = x# "divideFloat x 1.0" forall x#. divideFloat# x# 1.0# = x# @@ -788,6 +749,12 @@ "timesDouble x 0.0" forall x#. (*##) x# 0.0## = 0.0## These are tested by num014. + +Similarly for Float (#5178): + +"minusFloat x x" forall x#. minusFloat# x# x# = 0.0# +"timesFloat0.0 x" forall x#. timesFloat# 0.0# x# = 0.0# +"timesFloat x 0.0" forall x#. timesFloat# x# 0.0# = 0.0# -} -- Wrappers for the shift operations. The uncheckedShift# family are @@ -839,106 +806,9 @@ "int2Word2Int" forall x#. int2Word# (word2Int# x#) = x# "word2Int2Word" forall x#. word2Int# (int2Word# x#) = x# #-} -\end{code} - - -%******************************************************** -%* * -\subsection{Unpacking C strings} -%* * -%******************************************************** -This code is needed for virtually all programs, since it's used for -unpacking the strings of error messages. - -\begin{code} -unpackCString# :: Addr# -> [Char] -{-# NOINLINE unpackCString# #-} - -- There's really no point in inlining this, ever, cos - -- the loop doesn't specialise in an interesting - -- But it's pretty small, so there's a danger that - -- it'll be inlined at every literal, which is a waste -unpackCString# addr - = unpack 0# - where - unpack nh - | ch `eqChar#` '\0'# = [] - | otherwise = C# ch : unpack (nh +# 1#) - where - !ch = indexCharOffAddr# addr nh - -unpackAppendCString# :: Addr# -> [Char] -> [Char] -{-# NOINLINE unpackAppendCString# #-} - -- See the NOINLINE note on unpackCString# -unpackAppendCString# addr rest - = unpack 0# - where - unpack nh - | ch `eqChar#` '\0'# = rest - | otherwise = C# ch : unpack (nh +# 1#) - where - !ch = indexCharOffAddr# addr nh - -unpackFoldrCString# :: Addr# -> (Char -> a -> a) -> a -> a - --- Usually the unpack-list rule turns unpackFoldrCString# into unpackCString# - --- It also has a BuiltInRule in PrelRules.lhs: --- unpackFoldrCString# "foo" c (unpackFoldrCString# "baz" c n) --- = unpackFoldrCString# "foobaz" c n - -{-# NOINLINE unpackFoldrCString# #-} --- At one stage I had NOINLINE [0] on the grounds that, unlike --- unpackCString#, there *is* some point in inlining --- unpackFoldrCString#, because we get better code for the --- higher-order function call. BUT there may be a lot of --- literal strings, and making a separate 'unpack' loop for --- each is highly gratuitous. See nofib/real/anna/PrettyPrint. - -unpackFoldrCString# addr f z - = unpack 0# - where - unpack nh - | ch `eqChar#` '\0'# = z - | otherwise = C# ch `f` unpack (nh +# 1#) - where - !ch = indexCharOffAddr# addr nh - -unpackCStringUtf8# :: Addr# -> [Char] -unpackCStringUtf8# addr - = unpack 0# - where - unpack nh - | ch `eqChar#` '\0'# = [] - | ch `leChar#` '\x7F'# = C# ch : unpack (nh +# 1#) - | ch `leChar#` '\xDF'# = - C# (chr# (((ord# ch -# 0xC0#) `uncheckedIShiftL#` 6#) +# - (ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#))) : - unpack (nh +# 2#) - | ch `leChar#` '\xEF'# = - C# (chr# (((ord# ch -# 0xE0#) `uncheckedIShiftL#` 12#) +# - ((ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#) `uncheckedIShiftL#` 6#) +# - (ord# (indexCharOffAddr# addr (nh +# 2#)) -# 0x80#))) : - unpack (nh +# 3#) - | otherwise = - C# (chr# (((ord# ch -# 0xF0#) `uncheckedIShiftL#` 18#) +# - ((ord# (indexCharOffAddr# addr (nh +# 1#)) -# 0x80#) `uncheckedIShiftL#` 12#) +# - ((ord# (indexCharOffAddr# addr (nh +# 2#)) -# 0x80#) `uncheckedIShiftL#` 6#) +# - (ord# (indexCharOffAddr# addr (nh +# 3#)) -# 0x80#))) : - unpack (nh +# 4#) - where - !ch = indexCharOffAddr# addr nh - -unpackNBytes# :: Addr# -> Int# -> [Char] -unpackNBytes# _addr 0# = [] -unpackNBytes# addr len# = unpack [] (len# -# 1#) - where - unpack acc i# - | i# <# 0# = acc - | otherwise = - case indexCharOffAddr# addr i# of - ch -> unpack (C# ch : acc) (i# -# 1#) +-- Rules for C strings (the functions themselves are now in GHC.CString) {-# RULES "unpack" [~1] forall a . unpackCString# a = build (unpackFoldrCString# a) "unpack-list" [1] forall a . unpackFoldrCString# a (:) [] = unpackCString# a @@ -950,6 +820,7 @@ #-} \end{code} + #ifdef __HADDOCK__ \begin{code} -- | A special argument for the 'Control.Monad.ST.ST' type constructor, @@ -958,3 +829,4 @@ data RealWorld \end{code} #endif + diff -Nru ghc-7.0.3/libraries/base/GHC/Classes.hs ghc-7.2.1/libraries/base/GHC/Classes.hs --- ghc-7.0.3/libraries/base/GHC/Classes.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/Classes.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,5 +1,5 @@ - -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude, MagicHash, StandaloneDeriving #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-} -- XXX -fno-warn-unused-imports needed for the GHC.Tuple import below. Sigh. {-# OPTIONS_HADDOCK hide #-} @@ -19,7 +19,6 @@ module GHC.Classes where -import GHC.Bool import GHC.Integer -- GHC.Magic is used in some derived instances import GHC.Magic () @@ -28,6 +27,9 @@ import GHC.Tuple import GHC.Types import GHC.Unit +-- For defining instances for the generic deriving mechanism +import GHC.Generics (Arity(..), Associativity(..), Fixity(..)) + infix 4 ==, /=, <, <=, >=, > infixr 3 && @@ -107,6 +109,16 @@ instance Eq Double where (D# x) == (D# y) = x ==## y +instance Eq Int where + (==) = eqInt + (/=) = neInt + +{-# INLINE eqInt #-} +{-# INLINE neInt #-} +eqInt, neInt :: Int -> Int -> Bool +(I# x) `eqInt` (I# y) = x ==# y +(I# x) `neInt` (I# y) = x /=# y + -- | The 'Ord' class is used for totally ordered datatypes. -- -- Instances of 'Ord' can be derived for any user-defined @@ -224,6 +236,32 @@ (D# x) >= (D# y) = x >=## y (D# x) > (D# y) = x >## y +instance Ord Int where + compare = compareInt + (<) = ltInt + (<=) = leInt + (>=) = geInt + (>) = gtInt + +{-# INLINE gtInt #-} +{-# INLINE geInt #-} +{-# INLINE ltInt #-} +{-# INLINE leInt #-} +gtInt, geInt, ltInt, leInt :: Int -> Int -> Bool +(I# x) `gtInt` (I# y) = x ># y +(I# x) `geInt` (I# y) = x >=# y +(I# x) `ltInt` (I# y) = x <# y +(I# x) `leInt` (I# y) = x <=# y + +compareInt :: Int -> Int -> Ordering +(I# x#) `compareInt` (I# y#) = compareInt# x# y# + +compareInt# :: Int# -> Int# -> Ordering +compareInt# x# y# + | x# <# y# = LT + | x# ==# y# = EQ + | True = GT + -- OK, so they're technically not part of a class...: -- Boolean functions @@ -243,3 +281,17 @@ not True = False not False = True + +------------------------------------------------------------------------ +-- Generic deriving +------------------------------------------------------------------------ + +-- We need instances for some basic datatypes, but some of those use Int, +-- so we have to put the instances here +deriving instance Eq Arity +deriving instance Eq Associativity +deriving instance Eq Fixity + +deriving instance Ord Arity +deriving instance Ord Associativity +deriving instance Ord Fixity diff -Nru ghc-7.0.3/libraries/base/GHC/Conc/IO.hs ghc-7.2.1/libraries/base/GHC/Conc/IO.hs --- ghc-7.0.3/libraries/base/GHC/Conc/IO.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/Conc/IO.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,6 +1,12 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE CPP + , NoImplicitPrelude + , MagicHash + , UnboxedTuples + , ForeignFunctionInterface + #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} {-# OPTIONS_HADDOCK not-home #-} + ----------------------------------------------------------------------------- -- | -- Module : GHC.Conc.IO @@ -59,7 +65,7 @@ asyncWriteBA, ConsoleEvent(..), win32ConsoleHandler, toWin32ConsoleEvent) #else -import qualified System.Event.Thread as Event +import qualified GHC.Event.Thread as Event #endif ensureIOManagerIsRunning :: IO () diff -Nru ghc-7.0.3/libraries/base/GHC/Conc/Signal.hs ghc-7.2.1/libraries/base/GHC/Conc/Signal.hs --- ghc-7.0.3/libraries/base/GHC/Conc/Signal.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/Conc/Signal.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,5 @@ -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude, ForeignFunctionInterface #-} module GHC.Conc.Signal ( Signal @@ -19,8 +20,8 @@ import GHC.Base import GHC.Conc.Sync (forkIO) import GHC.IO (mask_, unsafePerformIO) -import GHC.IOArray (IOArray, boundsIOArray, newIOArray, unsafeReadIOArray, - unsafeWriteIOArray) +import GHC.IOArray (IOArray, boundsIOArray, newIOArray, + unsafeReadIOArray, unsafeWriteIOArray) import GHC.Real (fromIntegral) import GHC.Word (Word8) diff -Nru ghc-7.0.3/libraries/base/GHC/Conc/Sync.lhs ghc-7.2.1/libraries/base/GHC/Conc/Sync.lhs --- ghc-7.0.3/libraries/base/GHC/Conc/Sync.lhs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/Conc/Sync.lhs 2011-08-07 17:10:07.000000000 +0000 @@ -1,7 +1,18 @@ \begin{code} -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE CPP + , NoImplicitPrelude + , BangPatterns + , MagicHash + , UnboxedTuples + , UnliftedFFITypes + , ForeignFunctionInterface + , DeriveDataTypeable + , StandaloneDeriving + , RankNTypes + #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} {-# OPTIONS_HADDOCK not-home #-} + ----------------------------------------------------------------------------- -- | -- Module : GHC.Conc.Sync @@ -30,9 +41,13 @@ -- * Forking and suchlike , forkIO -- :: IO a -> IO ThreadId , forkIOUnmasked - , forkOnIO -- :: Int -> IO a -> IO ThreadId + , forkIOWithUnmask + , forkOn -- :: Int -> IO a -> IO ThreadId + , forkOnIO -- DEPRECATED , forkOnIOUnmasked + , forkOnWithUnmask , numCapabilities -- :: Int + , getNumCapabilities -- :: IO Int , numSparks -- :: IO Int , childHandler -- :: Exception -> IO () , myThreadId -- :: IO ThreadId @@ -46,6 +61,7 @@ , ThreadStatus(..), BlockReason(..) , threadStatus -- :: ThreadId -> IO ThreadStatus + , threadCapability -- * TVars , STM(..) @@ -184,43 +200,104 @@ where action_plus = catchException action childHandler --- | Like 'forkIO', but the child thread is created with asynchronous exceptions --- unmasked (see 'Control.Exception.mask'). +{-# DEPRECATED forkIOUnmasked "use forkIOWithUnmask instead" #-} +-- | This function is deprecated; use 'forkIOWIthUnmask' instead forkIOUnmasked :: IO () -> IO ThreadId forkIOUnmasked io = forkIO (unsafeUnmask io) +-- | Like 'forkIO', but the child thread is passed a function that can +-- be used to unmask asynchronous exceptions. This function is +-- typically used in the following way +-- +-- > ... mask_ $ forkIOWithUnmask $ \unmask -> +-- > catch (unmask ...) handler +-- +-- so that the exception handler in the child thread is established +-- with asynchronous exceptions masked, meanwhile the main body of +-- the child thread is executed in the unmasked state. +-- +-- Note that the unmask function passed to the child thread should +-- only be used in that thread; the behaviour is undefined if it is +-- invoked in a different thread. +-- +forkIOWithUnmask :: ((forall a . IO a -> IO a) -> IO ()) -> IO ThreadId +forkIOWithUnmask io = forkIO (io unsafeUnmask) + {- | -Like 'forkIO', but lets you specify on which CPU the thread is -created. Unlike a `forkIO` thread, a thread created by `forkOnIO` -will stay on the same CPU for its entire lifetime (`forkIO` threads -can migrate between CPUs according to the scheduling policy). -`forkOnIO` is useful for overriding the scheduling policy when you -know in advance how best to distribute the threads. - -The `Int` argument specifies the CPU number; it is interpreted modulo -'numCapabilities' (note that it actually specifies a capability number -rather than a CPU number, but to a first approximation the two are -equivalent). +Like 'forkIO', but lets you specify on which processor the thread +should run. Unlike a `forkIO` thread, a thread created by `forkOn` +will stay on the same processor for its entire lifetime (`forkIO` +threads can migrate between processors according to the scheduling +policy). `forkOn` is useful for overriding the scheduling policy when +you know in advance how best to distribute the threads. + +The `Int` argument specifies a /capability number/ (see +'getNumCapabilities'). Typically capabilities correspond to physical +processors, but the exact behaviour is implementation-dependent. The +value passed to 'forkOn' is interpreted modulo the total number of +capabilities as returned by 'getNumCapabilities'. + +GHC note: the number of capabilities is specified by the @+RTS -N@ +option when the program is started. Capabilities can be fixed to +actual processor cores with @+RTS -qa@ if the underlying operating +system supports that, although in practice this is usually unnecessary +(and may actually degrade perforamnce in some cases - experimentation +is recommended). -} -forkOnIO :: Int -> IO () -> IO ThreadId -forkOnIO (I# cpu) action = IO $ \ s -> +forkOn :: Int -> IO () -> IO ThreadId +forkOn (I# cpu) action = IO $ \ s -> case (forkOn# cpu action_plus s) of (# s1, tid #) -> (# s1, ThreadId tid #) where action_plus = catchException action childHandler --- | Like 'forkOnIO', but the child thread is created with --- asynchronous exceptions unmasked (see 'Control.Exception.mask'). +{-# DEPRECATED forkOnIO "renamed to forkOn" #-} +-- | This function is deprecated; use 'forkOn' instead +forkOnIO :: Int -> IO () -> IO ThreadId +forkOnIO = forkOn + +{-# DEPRECATED forkOnIOUnmasked "use forkOnWithUnmask instead" #-} +-- | This function is deprecated; use 'forkOnWIthUnmask' instead forkOnIOUnmasked :: Int -> IO () -> IO ThreadId -forkOnIOUnmasked cpu io = forkOnIO cpu (unsafeUnmask io) +forkOnIOUnmasked cpu io = forkOn cpu (unsafeUnmask io) + +-- | Like 'forkIOWithUnmask', but the child thread is pinned to the +-- given CPU, as with 'forkOn'. +forkOnWithUnmask :: Int -> ((forall a . IO a -> IO a) -> IO ()) -> IO ThreadId +forkOnWithUnmask cpu io = forkOn cpu (io unsafeUnmask) -- | the value passed to the @+RTS -N@ flag. This is the number of -- Haskell threads that can run truly simultaneously at any given --- time, and is typically set to the number of physical CPU cores on +-- time, and is typically set to the number of physical processor cores on -- the machine. +-- +-- Strictly speaking it is better to use 'getNumCapabilities', because +-- the number of capabilities might vary at runtime. +-- numCapabilities :: Int -numCapabilities = unsafePerformIO $ do - n <- peek n_capabilities - return (fromIntegral n) +numCapabilities = unsafePerformIO $ getNumCapabilities + +{- | +Returns the number of Haskell threads that can run truly +simultaneously (on separate physical processors) at any given time. +The number passed to `forkOn` is interpreted modulo this +value. + +An implementation in which Haskell threads are mapped directly to +OS threads might return the number of physical processor cores in +the machine, and 'forkOn' would be implemented using the OS's +affinity facilities. An implementation that schedules Haskell +threads onto a smaller number of OS threads (like GHC) would return +the number of such OS threads that can be running simultaneously. + +GHC notes: this returns the number passed as the argument to the +@+RTS -N@ flag. In current implementations, the value is fixed +when the program starts and never changes, but it is possible that +in the future the number of capabilities might vary at runtime. +-} +getNumCapabilities :: IO Int +getNumCapabilities = do + n <- peek n_capabilities + return (fromIntegral n) -- | Returns the number of sparks currently in the local spark pool numSparks :: IO Int @@ -274,7 +351,10 @@ If the target thread is currently making a foreign call, then the exception will not be raised (and hence 'throwTo' will not return) until the call has completed. This is the case regardless of whether -the call is inside a 'mask' or not. +the call is inside a 'mask' or not. However, in GHC a foreign call +can be annotated as @interruptible@, in which case a 'throwTo' will +cause the RTS to attempt to cause the call to return; see the GHC +documentation for more details. Important note: the behaviour of 'throwTo' differs from that described in the paper \"Asynchronous exceptions in Haskell\" @@ -293,9 +373,17 @@ allocation occurs. Some loops do not perform any memory allocation inside the loop and therefore cannot be interrupted by a 'throwTo'. -Blocked 'throwTo' is fair: if multiple threads are trying to throw an -exception to the same target thread, they will succeed in FIFO order. - +If the target of 'throwTo' is the calling thread, then the behaviour +is the same as 'Control.Exception.throwIO', except that the exception +is thrown as an asynchronous exception. This means that if there is +an enclosing pure computation, which would be the case if the current +IO operation is inside 'unsafePerformIO' or 'unsafeInterleaveIO', that +computation is not permanently replaced by the exception, but is +suspended as if it had received an asynchronous exception. + +Note that if 'throwTo' is called with the current thread as the +target, the exception will be thrown even if the thread is currently +inside 'mask' or 'uninterruptibleMask'. -} throwTo :: Exception e => ThreadId -> e -> IO () throwTo (ThreadId tid) ex = IO $ \ s -> @@ -390,19 +478,28 @@ threadStatus :: ThreadId -> IO ThreadStatus threadStatus (ThreadId t) = IO $ \s -> case threadStatus# t s of - (# s', stat #) -> (# s', mk_stat (I# stat) #) + (# s', stat, _cap, _locked #) -> (# s', mk_stat (I# stat) #) where -- NB. keep these in sync with includes/Constants.h mk_stat 0 = ThreadRunning mk_stat 1 = ThreadBlocked BlockedOnMVar mk_stat 2 = ThreadBlocked BlockedOnBlackHole - mk_stat 3 = ThreadBlocked BlockedOnException - mk_stat 7 = ThreadBlocked BlockedOnSTM + mk_stat 6 = ThreadBlocked BlockedOnSTM + mk_stat 10 = ThreadBlocked BlockedOnForeignCall mk_stat 11 = ThreadBlocked BlockedOnForeignCall - mk_stat 12 = ThreadBlocked BlockedOnForeignCall + mk_stat 12 = ThreadBlocked BlockedOnException mk_stat 16 = ThreadFinished mk_stat 17 = ThreadDied mk_stat _ = ThreadBlocked BlockedOnOther + +-- | returns the number of the capability on which the thread is currently +-- running, and a boolean indicating whether the thread is locked to +-- that capability or not. A thread is locked to a capability if it +-- was created with @forkOn@. +threadCapability :: ThreadId -> IO (Int, Bool) +threadCapability (ThreadId t) = IO $ \s -> + case threadStatus# t s of + (# s', _, cap#, locked# #) -> (# s', (I# cap#, locked# /=# 0#) #) \end{code} diff -Nru ghc-7.0.3/libraries/base/GHC/Conc/Windows.hs ghc-7.2.1/libraries/base/GHC/Conc/Windows.hs --- ghc-7.0.3/libraries/base/GHC/Conc/Windows.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/Conc/Windows.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,6 +1,8 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE NoImplicitPrelude, MagicHash, UnboxedTuples, ForeignFunctionInterface, + DeriveDataTypeable #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} {-# OPTIONS_HADDOCK not-home #-} + ----------------------------------------------------------------------------- -- | -- Module : GHC.Conc.Windows @@ -40,7 +42,6 @@ import Data.Bits (shiftR) import Data.Maybe (Maybe(..)) import Data.Typeable -import Foreign.C.Error (throwErrno) import GHC.Base import GHC.Conc.Sync import GHC.Enum (Enum) @@ -53,6 +54,7 @@ import GHC.Real (div, fromIntegral) import GHC.Show (Show) import GHC.Word (Word32, Word64) +import GHC.Windows -- ---------------------------------------------------------------------------- -- Thread waiting @@ -104,7 +106,7 @@ threadDelay time | threaded = waitForDelayEvent time | otherwise = IO $ \s -> - case fromIntegral time of { I# time# -> + case time of { I# time# -> case delay# time# s of { s' -> (# s', () #) }} @@ -234,7 +236,7 @@ r <- c_WaitForSingleObject wakeup timeout case r of - 0xffffffff -> do c_maperrno; throwErrno "service_loop" + 0xffffffff -> do throwGetLastError "service_loop" 0 -> do r2 <- c_readIOManagerEvent exit <- @@ -310,15 +312,6 @@ milli_seconds = (micro_seconds + 999) `div` 1000 in return (all, fromIntegral milli_seconds) --- ToDo: this just duplicates part of System.Win32.Types, which isn't --- available yet. We should move some Win32 functionality down here, --- maybe as part of the grand reorganisation of the base package... -type HANDLE = Ptr () -type DWORD = Word32 - -iNFINITE :: DWORD -iNFINITE = 0xFFFFFFFF -- urgh - foreign import ccall unsafe "getIOManagerEvent" -- in the RTS (ThrIOManager.c) c_getIOManagerEvent :: IO HANDLE @@ -328,8 +321,5 @@ foreign import ccall unsafe "sendIOManagerEvent" -- in the RTS (ThrIOManager.c) c_sendIOManagerEvent :: Word32 -> IO () -foreign import ccall unsafe "maperrno" -- in Win32Utils.c - c_maperrno :: IO () - foreign import stdcall "WaitForSingleObject" c_WaitForSingleObject :: HANDLE -> DWORD -> IO DWORD diff -Nru ghc-7.0.3/libraries/base/GHC/Conc.lhs ghc-7.2.1/libraries/base/GHC/Conc.lhs --- ghc-7.0.3/libraries/base/GHC/Conc.lhs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/Conc.lhs 2011-08-07 17:10:07.000000000 +0000 @@ -1,7 +1,8 @@ \begin{code} -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE CPP, NoImplicitPrelude #-} {-# OPTIONS_GHC -fno-warn-missing-signatures #-} {-# OPTIONS_HADDOCK not-home #-} + ----------------------------------------------------------------------------- -- | -- Module : GHC.Conc @@ -30,9 +31,13 @@ -- * Forking and suchlike , forkIO -- :: IO a -> IO ThreadId , forkIOUnmasked + , forkIOWithUnmask + , forkOn , forkOnIO -- :: Int -> IO a -> IO ThreadId , forkOnIOUnmasked + , forkOnWithUnmask , numCapabilities -- :: Int + , getNumCapabilities -- :: IO Int , numSparks -- :: IO Int , childHandler -- :: Exception -> IO () , myThreadId -- :: IO ThreadId @@ -46,6 +51,7 @@ , ThreadStatus(..), BlockReason(..) , threadStatus -- :: ThreadId -> IO ThreadStatus + , threadCapability -- * Waiting , threadDelay -- :: Int -> IO () diff -Nru ghc-7.0.3/libraries/base/GHC/ConsoleHandler.hs ghc-7.2.1/libraries/base/GHC/ConsoleHandler.hs --- ghc-7.0.3/libraries/base/GHC/ConsoleHandler.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/ConsoleHandler.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,6 @@ -{-# OPTIONS_GHC -cpp #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, ForeignFunctionInterface #-} + ----------------------------------------------------------------------------- -- | -- Module : GHC.ConsoleHandler @@ -42,8 +44,6 @@ #ifdef mingw32_HOST_OS import Data.Maybe import GHC.Base -import GHC.Num -import GHC.Real #endif data Handler @@ -148,7 +148,7 @@ "handle is not a file descriptor" Nothing Nothing Just fd -> do throwErrnoIfMinus1Retry_ "flushConsole" $ - flush_console_fd (fromIntegral (fdFD fd)) + flush_console_fd (fdFD fd) foreign import ccall unsafe "consUtils.h flush_input_console__" flush_console_fd :: CInt -> IO CInt diff -Nru ghc-7.0.3/libraries/base/GHC/Constants.hs ghc-7.2.1/libraries/base/GHC/Constants.hs --- ghc-7.0.3/libraries/base/GHC/Constants.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/Constants.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,3 +1,5 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP #-} module GHC.Constants where diff -Nru ghc-7.0.3/libraries/base/GHC/Desugar.hs ghc-7.2.1/libraries/base/GHC/Desugar.hs --- ghc-7.0.3/libraries/base/GHC/Desugar.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/Desugar.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,3 +1,10 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP + , NoImplicitPrelude + , Rank2Types + , ExistentialQuantification + #-} + ----------------------------------------------------------------------------- -- | -- Module : GHC.Desugar diff -Nru ghc-7.0.3/libraries/base/GHC/Enum.lhs ghc-7.2.1/libraries/base/GHC/Enum.lhs --- ghc-7.0.3/libraries/base/GHC/Enum.lhs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/Enum.lhs 2011-08-07 17:10:07.000000000 +0000 @@ -1,5 +1,6 @@ \begin{code} -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude, BangPatterns, MagicHash #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- -- | diff -Nru ghc-7.0.3/libraries/base/GHC/Environment.hs ghc-7.2.1/libraries/base/GHC/Environment.hs --- ghc-7.0.3/libraries/base/GHC/Environment.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/Environment.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,11 +1,43 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, ForeignFunctionInterface #-} module GHC.Environment (getFullArgs) where import Prelude import Foreign import Foreign.C + +#ifdef mingw32_HOST_OS +import GHC.IO (finally) +import GHC.Windows + +-- Ignore the arguments to hs_init on Windows for the sake of Unicode compat +getFullArgs :: IO [String] +getFullArgs = do + p_arg_string <- c_GetCommandLine + alloca $ \p_argc -> do + p_argv <- c_CommandLineToArgv p_arg_string p_argc + if p_argv == nullPtr + then throwGetLastError "getFullArgs" + else flip finally (c_LocalFree p_argv) $ do + argc <- peek p_argc + p_argvs <- peekArray (fromIntegral argc) p_argv + mapM peekCWString p_argvs + +foreign import stdcall unsafe "windows.h GetCommandLineW" + c_GetCommandLine :: IO (Ptr CWString) + +foreign import stdcall unsafe "windows.h CommandLineToArgvW" + c_CommandLineToArgv :: Ptr CWString -> Ptr CInt -> IO (Ptr CWString) + +foreign import stdcall unsafe "Windows.h LocalFree" + c_LocalFree :: Ptr a -> IO (Ptr a) +#else import Control.Monad +import GHC.IO.Encoding +import qualified GHC.Foreign as GHC + getFullArgs :: IO [String] getFullArgs = alloca $ \ p_argc -> @@ -13,8 +45,8 @@ getFullProgArgv p_argc p_argv p <- fromIntegral `liftM` peek p_argc argv <- peek p_argv - peekArray (p - 1) (advancePtr argv 1) >>= mapM peekCString + peekArray (p - 1) (advancePtr argv 1) >>= mapM (GHC.peekCString fileSystemEncoding) foreign import ccall unsafe "getFullProgArgv" getFullProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO () - +#endif diff -Nru ghc-7.0.3/libraries/base/GHC/Err.lhs ghc-7.2.1/libraries/base/GHC/Err.lhs --- ghc-7.0.3/libraries/base/GHC/Err.lhs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/Err.lhs 2011-08-07 17:10:07.000000000 +0000 @@ -1,6 +1,8 @@ \begin{code} -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude #-} {-# OPTIONS_HADDOCK hide #-} + ----------------------------------------------------------------------------- -- | -- Module : GHC.Err diff -Nru ghc-7.0.3/libraries/base/GHC/Err.lhs-boot ghc-7.2.1/libraries/base/GHC/Err.lhs-boot --- ghc-7.0.3/libraries/base/GHC/Err.lhs-boot 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/Err.lhs-boot 2011-08-07 17:10:07.000000000 +0000 @@ -1,5 +1,7 @@ \begin{code} -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude #-} + --------------------------------------------------------------------------- -- Ghc.Err.hs-boot --------------------------------------------------------------------------- diff -Nru ghc-7.0.3/libraries/base/GHC/Event/Array.hs ghc-7.2.1/libraries/base/GHC/Event/Array.hs --- ghc-7.0.3/libraries/base/GHC/Event/Array.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/Event/Array.hs 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,313 @@ +{-# LANGUAGE BangPatterns, CPP, ForeignFunctionInterface, NoImplicitPrelude #-} + +module GHC.Event.Array + ( + Array + , capacity + , clear + , concat + , copy + , duplicate + , empty + , ensureCapacity + , findIndex + , forM_ + , length + , loop + , new + , removeAt + , snoc + , unsafeLoad + , unsafeRead + , unsafeWrite + , useAsPtr + ) where + +import Control.Monad hiding (forM_) +import Data.Bits ((.|.), shiftR) +import Data.IORef (IORef, atomicModifyIORef, newIORef, readIORef, writeIORef) +import Data.Maybe +import Foreign.C.Types (CSize) +import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) +import Foreign.Ptr (Ptr, nullPtr, plusPtr) +import Foreign.Storable (Storable(..)) +import GHC.Base +import GHC.Err (undefined) +import GHC.ForeignPtr (mallocPlainForeignPtrBytes, newForeignPtr_) +import GHC.Num (Num(..)) +import GHC.Real (fromIntegral) +import GHC.Show (show) + +#include "MachDeps.h" + +#define BOUNDS_CHECKING 1 + +#if defined(BOUNDS_CHECKING) +-- This fugly hack is brought by GHC's apparent reluctance to deal +-- with MagicHash and UnboxedTuples when inferring types. Eek! +#define CHECK_BOUNDS(_func_,_len_,_k_) \ +if (_k_) < 0 || (_k_) >= (_len_) then error ("GHC.Event.Array." ++ (_func_) ++ ": bounds error, index " ++ show (_k_) ++ ", capacity " ++ show (_len_)) else +#else +#define CHECK_BOUNDS(_func_,_len_,_k_) +#endif + +-- Invariant: size <= capacity +newtype Array a = Array (IORef (AC a)) + +-- The actual array content. +data AC a = AC + !(ForeignPtr a) -- Elements + !Int -- Number of elements (length) + !Int -- Maximum number of elements (capacity) + +empty :: IO (Array a) +empty = do + p <- newForeignPtr_ nullPtr + Array `fmap` newIORef (AC p 0 0) + +allocArray :: Storable a => Int -> IO (ForeignPtr a) +allocArray n = allocHack undefined + where + allocHack :: Storable a => a -> IO (ForeignPtr a) + allocHack dummy = mallocPlainForeignPtrBytes (n * sizeOf dummy) + +reallocArray :: Storable a => ForeignPtr a -> Int -> Int -> IO (ForeignPtr a) +reallocArray p newSize oldSize = reallocHack undefined p + where + reallocHack :: Storable a => a -> ForeignPtr a -> IO (ForeignPtr a) + reallocHack dummy src = do + let size = sizeOf dummy + dst <- mallocPlainForeignPtrBytes (newSize * size) + withForeignPtr src $ \s -> + when (s /= nullPtr && oldSize > 0) . + withForeignPtr dst $ \d -> do + _ <- memcpy d s (fromIntegral (oldSize * size)) + return () + return dst + +new :: Storable a => Int -> IO (Array a) +new c = do + es <- allocArray cap + fmap Array (newIORef (AC es 0 cap)) + where + cap = firstPowerOf2 c + +duplicate :: Storable a => Array a -> IO (Array a) +duplicate a = dupHack undefined a + where + dupHack :: Storable b => b -> Array b -> IO (Array b) + dupHack dummy (Array ref) = do + AC es len cap <- readIORef ref + ary <- allocArray cap + withForeignPtr ary $ \dest -> + withForeignPtr es $ \src -> do + _ <- memcpy dest src (fromIntegral (len * sizeOf dummy)) + return () + Array `fmap` newIORef (AC ary len cap) + +length :: Array a -> IO Int +length (Array ref) = do + AC _ len _ <- readIORef ref + return len + +capacity :: Array a -> IO Int +capacity (Array ref) = do + AC _ _ cap <- readIORef ref + return cap + +unsafeRead :: Storable a => Array a -> Int -> IO a +unsafeRead (Array ref) ix = do + AC es _ cap <- readIORef ref + CHECK_BOUNDS("unsafeRead",cap,ix) + withForeignPtr es $ \p -> + peekElemOff p ix + +unsafeWrite :: Storable a => Array a -> Int -> a -> IO () +unsafeWrite (Array ref) ix a = do + ac <- readIORef ref + unsafeWrite' ac ix a + +unsafeWrite' :: Storable a => AC a -> Int -> a -> IO () +unsafeWrite' (AC es _ cap) ix a = do + CHECK_BOUNDS("unsafeWrite'",cap,ix) + withForeignPtr es $ \p -> + pokeElemOff p ix a + +unsafeLoad :: Storable a => Array a -> (Ptr a -> Int -> IO Int) -> IO Int +unsafeLoad (Array ref) load = do + AC es _ cap <- readIORef ref + len' <- withForeignPtr es $ \p -> load p cap + writeIORef ref (AC es len' cap) + return len' + +ensureCapacity :: Storable a => Array a -> Int -> IO () +ensureCapacity (Array ref) c = do + ac@(AC _ _ cap) <- readIORef ref + ac'@(AC _ _ cap') <- ensureCapacity' ac c + when (cap' /= cap) $ + writeIORef ref ac' + +ensureCapacity' :: Storable a => AC a -> Int -> IO (AC a) +ensureCapacity' ac@(AC es len cap) c = do + if c > cap + then do + es' <- reallocArray es cap' cap + return (AC es' len cap') + else + return ac + where + cap' = firstPowerOf2 c + +useAsPtr :: Array a -> (Ptr a -> Int -> IO b) -> IO b +useAsPtr (Array ref) f = do + AC es len _ <- readIORef ref + withForeignPtr es $ \p -> f p len + +snoc :: Storable a => Array a -> a -> IO () +snoc (Array ref) e = do + ac@(AC _ len _) <- readIORef ref + let len' = len + 1 + ac'@(AC es _ cap) <- ensureCapacity' ac len' + unsafeWrite' ac' len e + writeIORef ref (AC es len' cap) + +clear :: Storable a => Array a -> IO () +clear (Array ref) = do + !_ <- atomicModifyIORef ref $ \(AC es _ cap) -> + let e = AC es 0 cap in (e, e) + return () + +forM_ :: Storable a => Array a -> (a -> IO ()) -> IO () +forM_ ary g = forHack ary g undefined + where + forHack :: Storable b => Array b -> (b -> IO ()) -> b -> IO () + forHack (Array ref) f dummy = do + AC es len _ <- readIORef ref + let size = sizeOf dummy + offset = len * size + withForeignPtr es $ \p -> do + let go n | n >= offset = return () + | otherwise = do + f =<< peek (p `plusPtr` n) + go (n + size) + go 0 + +loop :: Storable a => Array a -> b -> (b -> a -> IO (b,Bool)) -> IO () +loop ary z g = loopHack ary z g undefined + where + loopHack :: Storable b => Array b -> c -> (c -> b -> IO (c,Bool)) -> b + -> IO () + loopHack (Array ref) y f dummy = do + AC es len _ <- readIORef ref + let size = sizeOf dummy + offset = len * size + withForeignPtr es $ \p -> do + let go n k + | n >= offset = return () + | otherwise = do + (k',cont) <- f k =<< peek (p `plusPtr` n) + when cont $ go (n + size) k' + go 0 y + +findIndex :: Storable a => (a -> Bool) -> Array a -> IO (Maybe (Int,a)) +findIndex = findHack undefined + where + findHack :: Storable b => b -> (b -> Bool) -> Array b -> IO (Maybe (Int,b)) + findHack dummy p (Array ref) = do + AC es len _ <- readIORef ref + let size = sizeOf dummy + offset = len * size + withForeignPtr es $ \ptr -> + let go !n !i + | n >= offset = return Nothing + | otherwise = do + val <- peek (ptr `plusPtr` n) + if p val + then return $ Just (i, val) + else go (n + size) (i + 1) + in go 0 0 + +concat :: Storable a => Array a -> Array a -> IO () +concat (Array d) (Array s) = do + da@(AC _ dlen _) <- readIORef d + sa@(AC _ slen _) <- readIORef s + writeIORef d =<< copy' da dlen sa 0 slen + +-- | Copy part of the source array into the destination array. The +-- destination array is resized if not large enough. +copy :: Storable a => Array a -> Int -> Array a -> Int -> Int -> IO () +copy (Array d) dstart (Array s) sstart maxCount = do + da <- readIORef d + sa <- readIORef s + writeIORef d =<< copy' da dstart sa sstart maxCount + +-- | Copy part of the source array into the destination array. The +-- destination array is resized if not large enough. +copy' :: Storable a => AC a -> Int -> AC a -> Int -> Int -> IO (AC a) +copy' d dstart s sstart maxCount = copyHack d s undefined + where + copyHack :: Storable b => AC b -> AC b -> b -> IO (AC b) + copyHack dac@(AC _ oldLen _) (AC src slen _) dummy = do + when (maxCount < 0 || dstart < 0 || dstart > oldLen || sstart < 0 || + sstart > slen) $ error "copy: bad offsets or lengths" + let size = sizeOf dummy + count = min maxCount (slen - sstart) + if count == 0 + then return dac + else do + AC dst dlen dcap <- ensureCapacity' dac (dstart + count) + withForeignPtr dst $ \dptr -> + withForeignPtr src $ \sptr -> do + _ <- memcpy (dptr `plusPtr` (dstart * size)) + (sptr `plusPtr` (sstart * size)) + (fromIntegral (count * size)) + return $ AC dst (max dlen (dstart + count)) dcap + +removeAt :: Storable a => Array a -> Int -> IO () +removeAt a i = removeHack a undefined + where + removeHack :: Storable b => Array b -> b -> IO () + removeHack (Array ary) dummy = do + AC fp oldLen cap <- readIORef ary + when (i < 0 || i >= oldLen) $ error "removeAt: invalid index" + let size = sizeOf dummy + newLen = oldLen - 1 + when (newLen > 0 && i < newLen) . + withForeignPtr fp $ \ptr -> do + _ <- memmove (ptr `plusPtr` (size * i)) + (ptr `plusPtr` (size * (i+1))) + (fromIntegral (size * (newLen-i))) + return () + writeIORef ary (AC fp newLen cap) + +{-The firstPowerOf2 function works by setting all bits on the right-hand +side of the most significant flagged bit to 1, and then incrementing +the entire value at the end so it "rolls over" to the nearest power of +two. +-} + +-- | Computes the next-highest power of two for a particular integer, +-- @n@. If @n@ is already a power of two, returns @n@. If @n@ is +-- zero, returns zero, even though zero is not a power of two. +firstPowerOf2 :: Int -> Int +firstPowerOf2 !n = + let !n1 = n - 1 + !n2 = n1 .|. (n1 `shiftR` 1) + !n3 = n2 .|. (n2 `shiftR` 2) + !n4 = n3 .|. (n3 `shiftR` 4) + !n5 = n4 .|. (n4 `shiftR` 8) + !n6 = n5 .|. (n5 `shiftR` 16) +#if WORD_SIZE_IN_BITS == 32 + in n6 + 1 +#elif WORD_SIZE_IN_BITS == 64 + !n7 = n6 .|. (n6 `shiftR` 32) + in n7 + 1 +#else +# error firstPowerOf2 not defined on this architecture +#endif + +foreign import ccall unsafe "string.h memcpy" + memcpy :: Ptr a -> Ptr a -> CSize -> IO (Ptr a) + +foreign import ccall unsafe "string.h memmove" + memmove :: Ptr a -> Ptr a -> CSize -> IO (Ptr a) diff -Nru ghc-7.0.3/libraries/base/GHC/Event/Clock.hsc ghc-7.2.1/libraries/base/GHC/Event/Clock.hsc --- ghc-7.0.3/libraries/base/GHC/Event/Clock.hsc 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/Event/Clock.hsc 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,48 @@ +{-# LANGUAGE NoImplicitPrelude, BangPatterns, ForeignFunctionInterface #-} + +module GHC.Event.Clock (getCurrentTime) where + +#include + +import Foreign (Ptr, Storable(..), nullPtr, with) +import Foreign.C.Error (throwErrnoIfMinus1_) +import Foreign.C.Types (CInt, CLong, CTime, CSUSeconds) +import GHC.Base +import GHC.Err +import GHC.Num +import GHC.Real + +-- TODO: Implement this for Windows. + +-- | Return the current time, in seconds since Jan. 1, 1970. +getCurrentTime :: IO Double +getCurrentTime = do + tv <- with (CTimeval 0 0) $ \tvptr -> do + throwErrnoIfMinus1_ "gettimeofday" (gettimeofday tvptr nullPtr) + peek tvptr + let !t = realToFrac (sec tv) + realToFrac (usec tv) / 1000000.0 + return t + +------------------------------------------------------------------------ +-- FFI binding + +data CTimeval = CTimeval + { sec :: {-# UNPACK #-} !CTime + , usec :: {-# UNPACK #-} !CSUSeconds + } + +instance Storable CTimeval where + sizeOf _ = #size struct timeval + alignment _ = alignment (undefined :: CLong) + + peek ptr = do + sec' <- #{peek struct timeval, tv_sec} ptr + usec' <- #{peek struct timeval, tv_usec} ptr + return $ CTimeval sec' usec' + + poke ptr tv = do + #{poke struct timeval, tv_sec} ptr (sec tv) + #{poke struct timeval, tv_usec} ptr (usec tv) + +foreign import ccall unsafe "sys/time.h gettimeofday" gettimeofday + :: Ptr CTimeval -> Ptr () -> IO CInt diff -Nru ghc-7.0.3/libraries/base/GHC/Event/Control.hs ghc-7.2.1/libraries/base/GHC/Event/Control.hs --- ghc-7.0.3/libraries/base/GHC/Event/Control.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/Event/Control.hs 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,214 @@ +{-# LANGUAGE CPP + , ForeignFunctionInterface + , NoImplicitPrelude + , ScopedTypeVariables + , BangPatterns + #-} + +module GHC.Event.Control + ( + -- * Managing the IO manager + Signal + , ControlMessage(..) + , Control + , newControl + , closeControl + -- ** Control message reception + , readControlMessage + -- *** File descriptors + , controlReadFd + , wakeupReadFd + -- ** Control message sending + , sendWakeup + , sendDie + -- * Utilities + , setNonBlockingFD + ) where + +#include "EventConfig.h" + +import Control.Monad (when) +import Foreign.ForeignPtr (ForeignPtr) +import GHC.Base +import GHC.Conc.Signal (Signal) +import GHC.Real (fromIntegral) +import GHC.Show (Show) +import GHC.Word (Word8) +import Foreign.C.Error (throwErrnoIfMinus1_) +import Foreign.C.Types (CInt, CSize) +import Foreign.ForeignPtr (mallocForeignPtrBytes, withForeignPtr) +import Foreign.Marshal (alloca, allocaBytes) +import Foreign.Marshal.Array (allocaArray) +import Foreign.Ptr (castPtr) +import Foreign.Storable (peek, peekElemOff, poke) +import System.Posix.Internals (c_close, c_pipe, c_read, c_write, + setCloseOnExec, setNonBlockingFD) +import System.Posix.Types (Fd) + +#if defined(HAVE_EVENTFD) +import Data.Word (Word64) +import Foreign.C.Error (throwErrnoIfMinus1) +#else +import Foreign.C.Error (eAGAIN, eWOULDBLOCK, getErrno, throwErrno) +#endif + +data ControlMessage = CMsgWakeup + | CMsgDie + | CMsgSignal {-# UNPACK #-} !(ForeignPtr Word8) + {-# UNPACK #-} !Signal + deriving (Eq, Show) + +-- | The structure used to tell the IO manager thread what to do. +data Control = W { + controlReadFd :: {-# UNPACK #-} !Fd + , controlWriteFd :: {-# UNPACK #-} !Fd +#if defined(HAVE_EVENTFD) + , controlEventFd :: {-# UNPACK #-} !Fd +#else + , wakeupReadFd :: {-# UNPACK #-} !Fd + , wakeupWriteFd :: {-# UNPACK #-} !Fd +#endif + } deriving (Show) + +#if defined(HAVE_EVENTFD) +wakeupReadFd :: Control -> Fd +wakeupReadFd = controlEventFd +{-# INLINE wakeupReadFd #-} +#endif + +setNonBlock :: CInt -> IO () +setNonBlock fd = +#if __GLASGOW_HASKELL__ >= 611 + setNonBlockingFD fd True +#else + setNonBlockingFD fd +#endif + +-- | Create the structure (usually a pipe) used for waking up the IO +-- manager thread from another thread. +newControl :: IO Control +newControl = allocaArray 2 $ \fds -> do + let createPipe = do + throwErrnoIfMinus1_ "pipe" $ c_pipe fds + rd <- peekElemOff fds 0 + wr <- peekElemOff fds 1 + -- The write end must be non-blocking, since we may need to + -- poke the event manager from a signal handler. + setNonBlock wr + setCloseOnExec rd + setCloseOnExec wr + return (rd, wr) + (ctrl_rd, ctrl_wr) <- createPipe + c_setIOManagerControlFd ctrl_wr +#if defined(HAVE_EVENTFD) + ev <- throwErrnoIfMinus1 "eventfd" $ c_eventfd 0 0 + setNonBlock ev + setCloseOnExec ev + c_setIOManagerWakeupFd ev +#else + (wake_rd, wake_wr) <- createPipe + c_setIOManagerWakeupFd wake_wr +#endif + return W { controlReadFd = fromIntegral ctrl_rd + , controlWriteFd = fromIntegral ctrl_wr +#if defined(HAVE_EVENTFD) + , controlEventFd = fromIntegral ev +#else + , wakeupReadFd = fromIntegral wake_rd + , wakeupWriteFd = fromIntegral wake_wr +#endif + } + +-- | Close the control structure used by the IO manager thread. +closeControl :: Control -> IO () +closeControl w = do + _ <- c_close . fromIntegral . controlReadFd $ w + _ <- c_close . fromIntegral . controlWriteFd $ w +#if defined(HAVE_EVENTFD) + _ <- c_close . fromIntegral . controlEventFd $ w +#else + _ <- c_close . fromIntegral . wakeupReadFd $ w + _ <- c_close . fromIntegral . wakeupWriteFd $ w +#endif + return () + +io_MANAGER_WAKEUP, io_MANAGER_DIE :: Word8 +io_MANAGER_WAKEUP = 0xff +io_MANAGER_DIE = 0xfe + +foreign import ccall "__hscore_sizeof_siginfo_t" + sizeof_siginfo_t :: CSize + +readControlMessage :: Control -> Fd -> IO ControlMessage +readControlMessage ctrl fd + | fd == wakeupReadFd ctrl = allocaBytes wakeupBufferSize $ \p -> do + throwErrnoIfMinus1_ "readWakeupMessage" $ + c_read (fromIntegral fd) p (fromIntegral wakeupBufferSize) + return CMsgWakeup + | otherwise = + alloca $ \p -> do + throwErrnoIfMinus1_ "readControlMessage" $ + c_read (fromIntegral fd) p 1 + s <- peek p + case s of + -- Wakeup messages shouldn't be sent on the control + -- file descriptor but we handle them anyway. + _ | s == io_MANAGER_WAKEUP -> return CMsgWakeup + _ | s == io_MANAGER_DIE -> return CMsgDie + _ -> do -- Signal + fp <- mallocForeignPtrBytes (fromIntegral sizeof_siginfo_t) + withForeignPtr fp $ \p_siginfo -> do + r <- c_read (fromIntegral fd) (castPtr p_siginfo) + sizeof_siginfo_t + when (r /= fromIntegral sizeof_siginfo_t) $ + error "failed to read siginfo_t" + let !s' = fromIntegral s + return $ CMsgSignal fp s' + + where wakeupBufferSize = +#if defined(HAVE_EVENTFD) + 8 +#else + 4096 +#endif + +sendWakeup :: Control -> IO () +#if defined(HAVE_EVENTFD) +sendWakeup c = alloca $ \p -> do + poke p (1 :: Word64) + throwErrnoIfMinus1_ "sendWakeup" $ + c_write (fromIntegral (controlEventFd c)) (castPtr p) 8 +#else +sendWakeup c = do + n <- sendMessage (wakeupWriteFd c) CMsgWakeup + case n of + _ | n /= -1 -> return () + | otherwise -> do + errno <- getErrno + when (errno /= eAGAIN && errno /= eWOULDBLOCK) $ + throwErrno "sendWakeup" +#endif + +sendDie :: Control -> IO () +sendDie c = throwErrnoIfMinus1_ "sendDie" $ + sendMessage (controlWriteFd c) CMsgDie + +sendMessage :: Fd -> ControlMessage -> IO Int +sendMessage fd msg = alloca $ \p -> do + case msg of + CMsgWakeup -> poke p io_MANAGER_WAKEUP + CMsgDie -> poke p io_MANAGER_DIE + CMsgSignal _fp _s -> error "Signals can only be sent from within the RTS" + fromIntegral `fmap` c_write (fromIntegral fd) p 1 + +#if defined(HAVE_EVENTFD) +foreign import ccall unsafe "sys/eventfd.h eventfd" + c_eventfd :: CInt -> CInt -> IO CInt +#endif + +-- Used to tell the RTS how it can send messages to the I/O manager. +foreign import ccall "setIOManagerControlFd" + c_setIOManagerControlFd :: CInt -> IO () + +foreign import ccall "setIOManagerWakeupFd" + c_setIOManagerWakeupFd :: CInt -> IO () diff -Nru ghc-7.0.3/libraries/base/GHC/Event/EPoll.hsc ghc-7.2.1/libraries/base/GHC/Event/EPoll.hsc --- ghc-7.0.3/libraries/base/GHC/Event/EPoll.hsc 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/Event/EPoll.hsc 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,206 @@ +{-# LANGUAGE CPP + , ForeignFunctionInterface + , GeneralizedNewtypeDeriving + , NoImplicitPrelude + , BangPatterns + #-} + +-- +-- | A binding to the epoll I/O event notification facility +-- +-- epoll is a variant of poll that can be used either as an edge-triggered or +-- a level-triggered interface and scales well to large numbers of watched file +-- descriptors. +-- +-- epoll decouples monitor an fd from the process of registering it. +-- +module GHC.Event.EPoll + ( + new + , available + ) where + +import qualified GHC.Event.Internal as E + +#include "EventConfig.h" +#if !defined(HAVE_EPOLL) +import GHC.Base + +new :: IO E.Backend +new = error "EPoll back end not implemented for this platform" + +available :: Bool +available = False +{-# INLINE available #-} +#else + +#include + +import Control.Monad (when) +import Data.Bits (Bits, (.|.), (.&.)) +import Data.Monoid (Monoid(..)) +import Data.Word (Word32) +import Foreign.C.Error (throwErrnoIfMinus1, throwErrnoIfMinus1_) +import Foreign.C.Types (CInt) +import Foreign.Marshal.Utils (with) +import Foreign.Ptr (Ptr) +import Foreign.Storable (Storable(..)) +import GHC.Base +import GHC.Err (undefined) +import GHC.Num (Num(..)) +import GHC.Real (ceiling, fromIntegral) +import GHC.Show (Show) +import System.Posix.Internals (c_close) +import System.Posix.Internals (setCloseOnExec) +import System.Posix.Types (Fd(..)) + +import qualified GHC.Event.Array as A +import GHC.Event.Internal (Timeout(..)) + +available :: Bool +available = True +{-# INLINE available #-} + +data EPoll = EPoll { + epollFd :: {-# UNPACK #-} !EPollFd + , epollEvents :: {-# UNPACK #-} !(A.Array Event) + } + +-- | Create a new epoll backend. +new :: IO E.Backend +new = do + epfd <- epollCreate + evts <- A.new 64 + let !be = E.backend poll modifyFd delete (EPoll epfd evts) + return be + +delete :: EPoll -> IO () +delete be = do + _ <- c_close . fromEPollFd . epollFd $ be + return () + +-- | Change the set of events we are interested in for a given file +-- descriptor. +modifyFd :: EPoll -> Fd -> E.Event -> E.Event -> IO () +modifyFd ep fd oevt nevt = with (Event (fromEvent nevt) fd) $ + epollControl (epollFd ep) op fd + where op | oevt == mempty = controlOpAdd + | nevt == mempty = controlOpDelete + | otherwise = controlOpModify + +-- | Select a set of file descriptors which are ready for I/O +-- operations and call @f@ for all ready file descriptors, passing the +-- events that are ready. +poll :: EPoll -- ^ state + -> Timeout -- ^ timeout in milliseconds + -> (Fd -> E.Event -> IO ()) -- ^ I/O callback + -> IO () +poll ep timeout f = do + let events = epollEvents ep + + -- Will return zero if the system call was interupted, in which case + -- we just return (and try again later.) + n <- A.unsafeLoad events $ \es cap -> + epollWait (epollFd ep) es cap $ fromTimeout timeout + + when (n > 0) $ do + A.forM_ events $ \e -> f (eventFd e) (toEvent (eventTypes e)) + cap <- A.capacity events + when (cap == n) $ A.ensureCapacity events (2 * cap) + +newtype EPollFd = EPollFd { + fromEPollFd :: CInt + } deriving (Eq, Show) + +data Event = Event { + eventTypes :: EventType + , eventFd :: Fd + } deriving (Show) + +instance Storable Event where + sizeOf _ = #size struct epoll_event + alignment _ = alignment (undefined :: CInt) + + peek ptr = do + ets <- #{peek struct epoll_event, events} ptr + ed <- #{peek struct epoll_event, data.fd} ptr + let !ev = Event (EventType ets) ed + return ev + + poke ptr e = do + #{poke struct epoll_event, events} ptr (unEventType $ eventTypes e) + #{poke struct epoll_event, data.fd} ptr (eventFd e) + +newtype ControlOp = ControlOp CInt + +#{enum ControlOp, ControlOp + , controlOpAdd = EPOLL_CTL_ADD + , controlOpModify = EPOLL_CTL_MOD + , controlOpDelete = EPOLL_CTL_DEL + } + +newtype EventType = EventType { + unEventType :: Word32 + } deriving (Show, Eq, Num, Bits) + +#{enum EventType, EventType + , epollIn = EPOLLIN + , epollOut = EPOLLOUT + , epollErr = EPOLLERR + , epollHup = EPOLLHUP + } + +-- | Create a new epoll context, returning a file descriptor associated with the context. +-- The fd may be used for subsequent calls to this epoll context. +-- +-- The size parameter to epoll_create is a hint about the expected number of handles. +-- +-- The file descriptor returned from epoll_create() should be destroyed via +-- a call to close() after polling is finished +-- +epollCreate :: IO EPollFd +epollCreate = do + fd <- throwErrnoIfMinus1 "epollCreate" $ + c_epoll_create 256 -- argument is ignored + setCloseOnExec fd + let !epollFd' = EPollFd fd + return epollFd' + +epollControl :: EPollFd -> ControlOp -> Fd -> Ptr Event -> IO () +epollControl (EPollFd epfd) (ControlOp op) (Fd fd) event = + throwErrnoIfMinus1_ "epollControl" $ c_epoll_ctl epfd op fd event + +epollWait :: EPollFd -> Ptr Event -> Int -> Int -> IO Int +epollWait (EPollFd epfd) events numEvents timeout = + fmap fromIntegral . + E.throwErrnoIfMinus1NoRetry "epollWait" $ + c_epoll_wait epfd events (fromIntegral numEvents) (fromIntegral timeout) + +fromEvent :: E.Event -> EventType +fromEvent e = remap E.evtRead epollIn .|. + remap E.evtWrite epollOut + where remap evt to + | e `E.eventIs` evt = to + | otherwise = 0 + +toEvent :: EventType -> E.Event +toEvent e = remap (epollIn .|. epollErr .|. epollHup) E.evtRead `mappend` + remap (epollOut .|. epollErr .|. epollHup) E.evtWrite + where remap evt to + | e .&. evt /= 0 = to + | otherwise = mempty + +fromTimeout :: Timeout -> Int +fromTimeout Forever = -1 +fromTimeout (Timeout s) = ceiling $ 1000 * s + +foreign import ccall unsafe "sys/epoll.h epoll_create" + c_epoll_create :: CInt -> IO CInt + +foreign import ccall unsafe "sys/epoll.h epoll_ctl" + c_epoll_ctl :: CInt -> CInt -> CInt -> Ptr Event -> IO CInt + +foreign import ccall safe "sys/epoll.h epoll_wait" + c_epoll_wait :: CInt -> Ptr Event -> CInt -> CInt -> IO CInt + +#endif /* defined(HAVE_EPOLL) */ diff -Nru ghc-7.0.3/libraries/base/GHC/Event/Internal.hs ghc-7.2.1/libraries/base/GHC/Event/Internal.hs --- ghc-7.0.3/libraries/base/GHC/Event/Internal.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/Event/Internal.hs 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,139 @@ +{-# LANGUAGE ExistentialQuantification, NoImplicitPrelude #-} + +module GHC.Event.Internal + ( + -- * Event back end + Backend + , backend + , delete + , poll + , modifyFd + -- * Event type + , Event + , evtRead + , evtWrite + , evtClose + , eventIs + -- * Timeout type + , Timeout(..) + -- * Helpers + , throwErrnoIfMinus1NoRetry + ) where + +import Data.Bits ((.|.), (.&.)) +import Data.List (foldl', intercalate) +import Data.Monoid (Monoid(..)) +import Foreign.C.Error (eINTR, getErrno, throwErrno) +import System.Posix.Types (Fd) +import GHC.Base +import GHC.Num (Num(..)) +import GHC.Show (Show(..)) +import GHC.List (filter, null) + +-- | An I\/O event. +newtype Event = Event Int + deriving (Eq) + +evtNothing :: Event +evtNothing = Event 0 +{-# INLINE evtNothing #-} + +-- | Data is available to be read. +evtRead :: Event +evtRead = Event 1 +{-# INLINE evtRead #-} + +-- | The file descriptor is ready to accept a write. +evtWrite :: Event +evtWrite = Event 2 +{-# INLINE evtWrite #-} + +-- | Another thread closed the file descriptor. +evtClose :: Event +evtClose = Event 4 +{-# INLINE evtClose #-} + +eventIs :: Event -> Event -> Bool +eventIs (Event a) (Event b) = a .&. b /= 0 + +instance Show Event where + show e = '[' : (intercalate "," . filter (not . null) $ + [evtRead `so` "evtRead", + evtWrite `so` "evtWrite", + evtClose `so` "evtClose"]) ++ "]" + where ev `so` disp | e `eventIs` ev = disp + | otherwise = "" + +instance Monoid Event where + mempty = evtNothing + mappend = evtCombine + mconcat = evtConcat + +evtCombine :: Event -> Event -> Event +evtCombine (Event a) (Event b) = Event (a .|. b) +{-# INLINE evtCombine #-} + +evtConcat :: [Event] -> Event +evtConcat = foldl' evtCombine evtNothing +{-# INLINE evtConcat #-} + +-- | A type alias for timeouts, specified in seconds. +data Timeout = Timeout {-# UNPACK #-} !Double + | Forever + deriving (Show) + +-- | Event notification backend. +data Backend = forall a. Backend { + _beState :: !a + + -- | Poll backend for new events. The provided callback is called + -- once per file descriptor with new events. + , _bePoll :: a -- backend state + -> Timeout -- timeout in milliseconds + -> (Fd -> Event -> IO ()) -- I/O callback + -> IO () + + -- | Register, modify, or unregister interest in the given events + -- on the given file descriptor. + , _beModifyFd :: a + -> Fd -- file descriptor + -> Event -- old events to watch for ('mempty' for new) + -> Event -- new events to watch for ('mempty' to delete) + -> IO () + + , _beDelete :: a -> IO () + } + +backend :: (a -> Timeout -> (Fd -> Event -> IO ()) -> IO ()) + -> (a -> Fd -> Event -> Event -> IO ()) + -> (a -> IO ()) + -> a + -> Backend +backend bPoll bModifyFd bDelete state = Backend state bPoll bModifyFd bDelete +{-# INLINE backend #-} + +poll :: Backend -> Timeout -> (Fd -> Event -> IO ()) -> IO () +poll (Backend bState bPoll _ _) = bPoll bState +{-# INLINE poll #-} + +modifyFd :: Backend -> Fd -> Event -> Event -> IO () +modifyFd (Backend bState _ bModifyFd _) = bModifyFd bState +{-# INLINE modifyFd #-} + +delete :: Backend -> IO () +delete (Backend bState _ _ bDelete) = bDelete bState +{-# INLINE delete #-} + +-- | Throw an 'IOError' corresponding to the current value of +-- 'getErrno' if the result value of the 'IO' action is -1 and +-- 'getErrno' is not 'eINTR'. If the result value is -1 and +-- 'getErrno' returns 'eINTR' 0 is returned. Otherwise the result +-- value is returned. +throwErrnoIfMinus1NoRetry :: Num a => String -> IO a -> IO a +throwErrnoIfMinus1NoRetry loc f = do + res <- f + if res == -1 + then do + err <- getErrno + if err == eINTR then return 0 else throwErrno loc + else return res diff -Nru ghc-7.0.3/libraries/base/GHC/Event/IntMap.hs ghc-7.2.1/libraries/base/GHC/Event/IntMap.hs --- ghc-7.0.3/libraries/base/GHC/Event/IntMap.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/Event/IntMap.hs 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,375 @@ +{-# LANGUAGE CPP, MagicHash, NoImplicitPrelude #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.Event.IntMap +-- Copyright : (c) Daan Leijen 2002 +-- (c) Andriy Palamarchuk 2008 +-- License : BSD-style +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- An efficient implementation of maps from integer keys to values. +-- +-- Since many function names (but not the type name) clash with +-- "Prelude" names, this module is usually imported @qualified@, e.g. +-- +-- > import Data.IntMap (IntMap) +-- > import qualified Data.IntMap as IntMap +-- +-- The implementation is based on /big-endian patricia trees/. This data +-- structure performs especially well on binary operations like 'union' +-- and 'intersection'. However, my benchmarks show that it is also +-- (much) faster on insertions and deletions when compared to a generic +-- size-balanced map implementation (see "Data.Map"). +-- +-- * Chris Okasaki and Andy Gill, \"/Fast Mergeable Integer Maps/\", +-- Workshop on ML, September 1998, pages 77-86, +-- +-- +-- * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve +-- Information Coded In Alphanumeric/\", Journal of the ACM, 15(4), +-- October 1968, pages 514-534. +-- +-- Operation comments contain the operation time complexity in +-- the Big-O notation . +-- Many operations have a worst-case complexity of /O(min(n,W))/. +-- This means that the operation can become linear in the number of +-- elements with a maximum of /W/ -- the number of bits in an 'Int' +-- (32 or 64). +----------------------------------------------------------------------------- + +module GHC.Event.IntMap + ( + -- * Map type + IntMap + , Key + + -- * Query + , lookup + , member + + -- * Construction + , empty + + -- * Insertion + , insertWith + + -- * Delete\/Update + , delete + , updateWith + + -- * Traversal + -- ** Fold + , foldWithKey + + -- * Conversion + , keys + ) where + +import Data.Bits + +import Data.Maybe (Maybe(..)) +import GHC.Base hiding (foldr) +import GHC.Num (Num(..)) +import GHC.Real (fromIntegral) +import GHC.Show (Show(showsPrec), showParen, shows, showString) + +#if __GLASGOW_HASKELL__ +import GHC.Word (Word(..)) +#else +import Data.Word +#endif + +-- | A @Nat@ is a natural machine word (an unsigned Int) +type Nat = Word + +natFromInt :: Key -> Nat +natFromInt i = fromIntegral i + +intFromNat :: Nat -> Key +intFromNat w = fromIntegral w + +shiftRL :: Nat -> Key -> Nat +#if __GLASGOW_HASKELL__ +-- GHC: use unboxing to get @shiftRL@ inlined. +shiftRL (W# x) (I# i) = W# (shiftRL# x i) +#else +shiftRL x i = shiftR x i +#endif + +------------------------------------------------------------------------ +-- Types + +-- | A map of integers to values @a@. +data IntMap a = Nil + | Tip {-# UNPACK #-} !Key !a + | Bin {-# UNPACK #-} !Prefix + {-# UNPACK #-} !Mask + !(IntMap a) + !(IntMap a) + +type Prefix = Int +type Mask = Int +type Key = Int + +------------------------------------------------------------------------ +-- Query + +-- | /O(min(n,W))/ Lookup the value at a key in the map. See also +-- 'Data.Map.lookup'. +lookup :: Key -> IntMap a -> Maybe a +lookup k t = let nk = natFromInt k in seq nk (lookupN nk t) + +lookupN :: Nat -> IntMap a -> Maybe a +lookupN k t + = case t of + Bin _ m l r + | zeroN k (natFromInt m) -> lookupN k l + | otherwise -> lookupN k r + Tip kx x + | (k == natFromInt kx) -> Just x + | otherwise -> Nothing + Nil -> Nothing + +-- | /O(min(n,W))/. Is the key a member of the map? +-- +-- > member 5 (fromList [(5,'a'), (3,'b')]) == True +-- > member 1 (fromList [(5,'a'), (3,'b')]) == False + +member :: Key -> IntMap a -> Bool +member k m + = case lookup k m of + Nothing -> False + Just _ -> True + +------------------------------------------------------------------------ +-- Construction + +-- | /O(1)/ The empty map. +-- +-- > empty == fromList [] +-- > size empty == 0 +empty :: IntMap a +empty = Nil + +------------------------------------------------------------------------ +-- Insert + +-- | /O(min(n,W))/ Insert with a function, combining new value and old +-- value. @insertWith f key value mp@ will insert the pair (key, +-- value) into @mp@ if key does not exist in the map. If the key does +-- exist, the function will insert the pair (key, f new_value +-- old_value). The result is a pair where the first element is the +-- old value, if one was present, and the second is the modified map. +insertWith :: (a -> a -> a) -> Key -> a -> IntMap a -> (Maybe a, IntMap a) +insertWith f k x t = case t of + Bin p m l r + | nomatch k p m -> (Nothing, join k (Tip k x) p t) + | zero k m -> let (found, l') = insertWith f k x l + in (found, Bin p m l' r) + | otherwise -> let (found, r') = insertWith f k x r + in (found, Bin p m l r') + Tip ky y + | k == ky -> (Just y, Tip k (f x y)) + | otherwise -> (Nothing, join k (Tip k x) ky t) + Nil -> (Nothing, Tip k x) + + +------------------------------------------------------------------------ +-- Delete/Update + +-- | /O(min(n,W))/. Delete a key and its value from the map. When the +-- key is not a member of the map, the original map is returned. The +-- result is a pair where the first element is the value associated +-- with the deleted key, if one existed, and the second element is the +-- modified map. +delete :: Key -> IntMap a -> (Maybe a, IntMap a) +delete k t = case t of + Bin p m l r + | nomatch k p m -> (Nothing, t) + | zero k m -> let (found, l') = delete k l + in (found, bin p m l' r) + | otherwise -> let (found, r') = delete k r + in (found, bin p m l r') + Tip ky y + | k == ky -> (Just y, Nil) + | otherwise -> (Nothing, t) + Nil -> (Nothing, Nil) + +updateWith :: (a -> Maybe a) -> Key -> IntMap a -> (Maybe a, IntMap a) +updateWith f k t = case t of + Bin p m l r + | nomatch k p m -> (Nothing, t) + | zero k m -> let (found, l') = updateWith f k l + in (found, bin p m l' r) + | otherwise -> let (found, r') = updateWith f k r + in (found, bin p m l r') + Tip ky y + | k == ky -> case (f y) of + Just y' -> (Just y, Tip ky y') + Nothing -> (Just y, Nil) + | otherwise -> (Nothing, t) + Nil -> (Nothing, Nil) +-- | /O(n)/. Fold the keys and values in the map, such that +-- @'foldWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@. +-- For example, +-- +-- > keys map = foldWithKey (\k x ks -> k:ks) [] map +-- +-- > let f k a result = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")" +-- > foldWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (5:a)(3:b)" + +foldWithKey :: (Key -> a -> b -> b) -> b -> IntMap a -> b +foldWithKey f z t + = foldr f z t + +-- | /O(n)/. Convert the map to a list of key\/value pairs. +-- +-- > toList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")] +-- > toList empty == [] + +toList :: IntMap a -> [(Key,a)] +toList t + = foldWithKey (\k x xs -> (k,x):xs) [] t + +foldr :: (Key -> a -> b -> b) -> b -> IntMap a -> b +foldr f z t + = case t of + Bin 0 m l r | m < 0 -> foldr' f (foldr' f z l) r -- put negative numbers before. + Bin _ _ _ _ -> foldr' f z t + Tip k x -> f k x z + Nil -> z + +foldr' :: (Key -> a -> b -> b) -> b -> IntMap a -> b +foldr' f z t + = case t of + Bin _ _ l r -> foldr' f (foldr' f z r) l + Tip k x -> f k x z + Nil -> z + +-- | /O(n)/. Return all keys of the map in ascending order. +-- +-- > keys (fromList [(5,"a"), (3,"b")]) == [3,5] +-- > keys empty == [] + +keys :: IntMap a -> [Key] +keys m + = foldWithKey (\k _ ks -> k:ks) [] m + +------------------------------------------------------------------------ +-- Eq + +instance Eq a => Eq (IntMap a) where + t1 == t2 = equal t1 t2 + t1 /= t2 = nequal t1 t2 + +equal :: Eq a => IntMap a -> IntMap a -> Bool +equal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2) + = (m1 == m2) && (p1 == p2) && (equal l1 l2) && (equal r1 r2) +equal (Tip kx x) (Tip ky y) + = (kx == ky) && (x==y) +equal Nil Nil = True +equal _ _ = False + +nequal :: Eq a => IntMap a -> IntMap a -> Bool +nequal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2) + = (m1 /= m2) || (p1 /= p2) || (nequal l1 l2) || (nequal r1 r2) +nequal (Tip kx x) (Tip ky y) + = (kx /= ky) || (x/=y) +nequal Nil Nil = False +nequal _ _ = True + +instance Show a => Show (IntMap a) where + showsPrec d m = showParen (d > 10) $ + showString "fromList " . shows (toList m) + +------------------------------------------------------------------------ +-- Utility functions + +join :: Prefix -> IntMap a -> Prefix -> IntMap a -> IntMap a +join p1 t1 p2 t2 + | zero p1 m = Bin p m t1 t2 + | otherwise = Bin p m t2 t1 + where + m = branchMask p1 p2 + p = mask p1 m + +-- | @bin@ assures that we never have empty trees within a tree. +bin :: Prefix -> Mask -> IntMap a -> IntMap a -> IntMap a +bin _ _ l Nil = l +bin _ _ Nil r = r +bin p m l r = Bin p m l r + +------------------------------------------------------------------------ +-- Endian independent bit twiddling + +zero :: Key -> Mask -> Bool +zero i m = (natFromInt i) .&. (natFromInt m) == 0 + +nomatch :: Key -> Prefix -> Mask -> Bool +nomatch i p m = (mask i m) /= p + +mask :: Key -> Mask -> Prefix +mask i m = maskW (natFromInt i) (natFromInt m) + +zeroN :: Nat -> Nat -> Bool +zeroN i m = (i .&. m) == 0 + +------------------------------------------------------------------------ +-- Big endian operations + +maskW :: Nat -> Nat -> Prefix +maskW i m = intFromNat (i .&. (complement (m-1) `xor` m)) + +branchMask :: Prefix -> Prefix -> Mask +branchMask p1 p2 + = intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2)) + +{- +Finding the highest bit mask in a word [x] can be done efficiently in +three ways: + +* convert to a floating point value and the mantissa tells us the + [log2(x)] that corresponds with the highest bit position. The mantissa + is retrieved either via the standard C function [frexp] or by some bit + twiddling on IEEE compatible numbers (float). Note that one needs to + use at least [double] precision for an accurate mantissa of 32 bit + numbers. + +* use bit twiddling, a logarithmic sequence of bitwise or's and shifts (bit). + +* use processor specific assembler instruction (asm). + +The most portable way would be [bit], but is it efficient enough? +I have measured the cycle counts of the different methods on an AMD +Athlon-XP 1800 (~ Pentium III 1.8Ghz) using the RDTSC instruction: + +highestBitMask: method cycles + -------------- + frexp 200 + float 33 + bit 11 + asm 12 + +Wow, the bit twiddling is on today's RISC like machines even faster +than a single CISC instruction (BSR)! +-} + +-- | @highestBitMask@ returns a word where only the highest bit is +-- set. It is found by first setting all bits in lower positions than +-- the highest bit and than taking an exclusive or with the original +-- value. Allthough the function may look expensive, GHC compiles +-- this into excellent C code that subsequently compiled into highly +-- efficient machine code. The algorithm is derived from Jorg Arndt's +-- FXT library. +highestBitMask :: Nat -> Nat +highestBitMask x0 + = case (x0 .|. shiftRL x0 1) of + x1 -> case (x1 .|. shiftRL x1 2) of + x2 -> case (x2 .|. shiftRL x2 4) of + x3 -> case (x3 .|. shiftRL x3 8) of + x4 -> case (x4 .|. shiftRL x4 16) of + x5 -> case (x5 .|. shiftRL x5 32) of -- for 64 bit platforms + x6 -> (x6 `xor` (shiftRL x6 1)) diff -Nru ghc-7.0.3/libraries/base/GHC/Event/KQueue.hsc ghc-7.2.1/libraries/base/GHC/Event/KQueue.hsc --- ghc-7.0.3/libraries/base/GHC/Event/KQueue.hsc 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/Event/KQueue.hsc 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,303 @@ +{-# LANGUAGE CPP + , ForeignFunctionInterface + , GeneralizedNewtypeDeriving + , NoImplicitPrelude + , RecordWildCards + , BangPatterns + #-} + +module GHC.Event.KQueue + ( + new + , available + ) where + +import qualified GHC.Event.Internal as E + +#include "EventConfig.h" +#if !defined(HAVE_KQUEUE) +import GHC.Base + +new :: IO E.Backend +new = error "KQueue back end not implemented for this platform" + +available :: Bool +available = False +{-# INLINE available #-} +#else + +import Control.Concurrent.MVar (MVar, newMVar, swapMVar, withMVar) +import Control.Monad (when, unless) +import Data.Bits (Bits(..)) +import Data.Word (Word16, Word32) +import Foreign.C.Error (throwErrnoIfMinus1) +import Foreign.C.Types (CInt, CLong, CTime) +import Foreign.Marshal.Alloc (alloca) +import Foreign.Ptr (Ptr, nullPtr) +import Foreign.Storable (Storable(..)) +import GHC.Base +import GHC.Enum (toEnum) +import GHC.Err (undefined) +import GHC.Num (Num(..)) +import GHC.Real (ceiling, floor, fromIntegral) +import GHC.Show (Show(show)) +import GHC.Event.Internal (Timeout(..)) +import System.Posix.Internals (c_close) +import System.Posix.Types (Fd(..)) +import qualified GHC.Event.Array as A + +#if defined(HAVE_KEVENT64) +import Data.Int (Int64) +import Data.Word (Word64) +import Foreign.C.Types (CUInt) +#else +import Foreign.C.Types (CIntPtr, CUIntPtr) +#endif + +#include +#include +#include + +-- Handle brokenness on some BSD variants, notably OS X up to at least +-- 10.6. If NOTE_EOF isn't available, we have no way to receive a +-- notification from the kernel when we reach EOF on a plain file. +#ifndef NOTE_EOF +# define NOTE_EOF 0 +#endif + +available :: Bool +available = True +{-# INLINE available #-} + +------------------------------------------------------------------------ +-- Exported interface + +data EventQueue = EventQueue { + eqFd :: {-# UNPACK #-} !QueueFd + , eqChanges :: {-# UNPACK #-} !(MVar (A.Array Event)) + , eqEvents :: {-# UNPACK #-} !(A.Array Event) + } + +new :: IO E.Backend +new = do + qfd <- kqueue + changesArr <- A.empty + changes <- newMVar changesArr + events <- A.new 64 + let !be = E.backend poll modifyFd delete (EventQueue qfd changes events) + return be + +delete :: EventQueue -> IO () +delete q = do + _ <- c_close . fromQueueFd . eqFd $ q + return () + +modifyFd :: EventQueue -> Fd -> E.Event -> E.Event -> IO () +modifyFd q fd oevt nevt = withMVar (eqChanges q) $ \ch -> do + let addChange filt flag = A.snoc ch $ event fd filt flag noteEOF + when (oevt `E.eventIs` E.evtRead) $ addChange filterRead flagDelete + when (oevt `E.eventIs` E.evtWrite) $ addChange filterWrite flagDelete + when (nevt `E.eventIs` E.evtRead) $ addChange filterRead flagAdd + when (nevt `E.eventIs` E.evtWrite) $ addChange filterWrite flagAdd + +poll :: EventQueue + -> Timeout + -> (Fd -> E.Event -> IO ()) + -> IO () +poll EventQueue{..} tout f = do + changesArr <- A.empty + changes <- swapMVar eqChanges changesArr + changesLen <- A.length changes + len <- A.length eqEvents + when (changesLen > len) $ A.ensureCapacity eqEvents (2 * changesLen) + n <- A.useAsPtr changes $ \changesPtr chLen -> + A.unsafeLoad eqEvents $ \evPtr evCap -> + withTimeSpec (fromTimeout tout) $ + kevent eqFd changesPtr chLen evPtr evCap + + unless (n == 0) $ do + cap <- A.capacity eqEvents + when (n == cap) $ A.ensureCapacity eqEvents (2 * cap) + A.forM_ eqEvents $ \e -> f (fromIntegral (ident e)) (toEvent (filter e)) + +------------------------------------------------------------------------ +-- FFI binding + +newtype QueueFd = QueueFd { + fromQueueFd :: CInt + } deriving (Eq, Show) + +#if defined(HAVE_KEVENT64) +data Event = KEvent64 { + ident :: {-# UNPACK #-} !Word64 + , filter :: {-# UNPACK #-} !Filter + , flags :: {-# UNPACK #-} !Flag + , fflags :: {-# UNPACK #-} !FFlag + , data_ :: {-# UNPACK #-} !Int64 + , udata :: {-# UNPACK #-} !Word64 + , ext0 :: {-# UNPACK #-} !Word64 + , ext1 :: {-# UNPACK #-} !Word64 + } deriving Show + +event :: Fd -> Filter -> Flag -> FFlag -> Event +event fd filt flag fflag = KEvent64 (fromIntegral fd) filt flag fflag 0 0 0 0 + +instance Storable Event where + sizeOf _ = #size struct kevent64_s + alignment _ = alignment (undefined :: CInt) + + peek ptr = do + ident' <- #{peek struct kevent64_s, ident} ptr + filter' <- #{peek struct kevent64_s, filter} ptr + flags' <- #{peek struct kevent64_s, flags} ptr + fflags' <- #{peek struct kevent64_s, fflags} ptr + data' <- #{peek struct kevent64_s, data} ptr + udata' <- #{peek struct kevent64_s, udata} ptr + ext0' <- #{peek struct kevent64_s, ext[0]} ptr + ext1' <- #{peek struct kevent64_s, ext[1]} ptr + let !ev = KEvent64 ident' (Filter filter') (Flag flags') fflags' data' + udata' ext0' ext1' + return ev + + poke ptr ev = do + #{poke struct kevent64_s, ident} ptr (ident ev) + #{poke struct kevent64_s, filter} ptr (filter ev) + #{poke struct kevent64_s, flags} ptr (flags ev) + #{poke struct kevent64_s, fflags} ptr (fflags ev) + #{poke struct kevent64_s, data} ptr (data_ ev) + #{poke struct kevent64_s, udata} ptr (udata ev) + #{poke struct kevent64_s, ext[0]} ptr (ext0 ev) + #{poke struct kevent64_s, ext[1]} ptr (ext1 ev) +#else +data Event = KEvent { + ident :: {-# UNPACK #-} !CUIntPtr + , filter :: {-# UNPACK #-} !Filter + , flags :: {-# UNPACK #-} !Flag + , fflags :: {-# UNPACK #-} !FFlag + , data_ :: {-# UNPACK #-} !CIntPtr + , udata :: {-# UNPACK #-} !(Ptr ()) + } deriving Show + +event :: Fd -> Filter -> Flag -> FFlag -> Event +event fd filt flag fflag = KEvent (fromIntegral fd) filt flag fflag 0 nullPtr + +instance Storable Event where + sizeOf _ = #size struct kevent + alignment _ = alignment (undefined :: CInt) + + peek ptr = do + ident' <- #{peek struct kevent, ident} ptr + filter' <- #{peek struct kevent, filter} ptr + flags' <- #{peek struct kevent, flags} ptr + fflags' <- #{peek struct kevent, fflags} ptr + data' <- #{peek struct kevent, data} ptr + udata' <- #{peek struct kevent, udata} ptr + let !ev = KEvent ident' (Filter filter') (Flag flags') fflags' data' + udata' + return ev + + poke ptr ev = do + #{poke struct kevent, ident} ptr (ident ev) + #{poke struct kevent, filter} ptr (filter ev) + #{poke struct kevent, flags} ptr (flags ev) + #{poke struct kevent, fflags} ptr (fflags ev) + #{poke struct kevent, data} ptr (data_ ev) + #{poke struct kevent, udata} ptr (udata ev) +#endif + +newtype FFlag = FFlag Word32 + deriving (Eq, Show, Storable) + +#{enum FFlag, FFlag + , noteEOF = NOTE_EOF + } + +newtype Flag = Flag Word16 + deriving (Eq, Show, Storable) + +#{enum Flag, Flag + , flagAdd = EV_ADD + , flagDelete = EV_DELETE + } + +newtype Filter = Filter Word16 + deriving (Bits, Eq, Num, Show, Storable) + +#{enum Filter, Filter + , filterRead = EVFILT_READ + , filterWrite = EVFILT_WRITE + } + +data TimeSpec = TimeSpec { + tv_sec :: {-# UNPACK #-} !CTime + , tv_nsec :: {-# UNPACK #-} !CLong + } + +instance Storable TimeSpec where + sizeOf _ = #size struct timespec + alignment _ = alignment (undefined :: CInt) + + peek ptr = do + tv_sec' <- #{peek struct timespec, tv_sec} ptr + tv_nsec' <- #{peek struct timespec, tv_nsec} ptr + let !ts = TimeSpec tv_sec' tv_nsec' + return ts + + poke ptr ts = do + #{poke struct timespec, tv_sec} ptr (tv_sec ts) + #{poke struct timespec, tv_nsec} ptr (tv_nsec ts) + +kqueue :: IO QueueFd +kqueue = QueueFd `fmap` throwErrnoIfMinus1 "kqueue" c_kqueue + +-- TODO: We cannot retry on EINTR as the timeout would be wrong. +-- Perhaps we should just return without calling any callbacks. +kevent :: QueueFd -> Ptr Event -> Int -> Ptr Event -> Int -> Ptr TimeSpec + -> IO Int +kevent k chs chlen evs evlen ts + = fmap fromIntegral $ E.throwErrnoIfMinus1NoRetry "kevent" $ +#if defined(HAVE_KEVENT64) + c_kevent64 k chs (fromIntegral chlen) evs (fromIntegral evlen) 0 ts +#else + c_kevent k chs (fromIntegral chlen) evs (fromIntegral evlen) ts +#endif + +withTimeSpec :: TimeSpec -> (Ptr TimeSpec -> IO a) -> IO a +withTimeSpec ts f = + if tv_sec ts < 0 then + f nullPtr + else + alloca $ \ptr -> poke ptr ts >> f ptr + +fromTimeout :: Timeout -> TimeSpec +fromTimeout Forever = TimeSpec (-1) (-1) +fromTimeout (Timeout s) = TimeSpec (toEnum sec) (toEnum nanosec) + where + sec :: Int + sec = floor s + + nanosec :: Int + nanosec = ceiling $ (s - fromIntegral sec) * 1000000000 + +toEvent :: Filter -> E.Event +toEvent (Filter f) + | f == (#const EVFILT_READ) = E.evtRead + | f == (#const EVFILT_WRITE) = E.evtWrite + | otherwise = error $ "toEvent: unknown filter " ++ show f + +foreign import ccall unsafe "kqueue" + c_kqueue :: IO CInt + +#if defined(HAVE_KEVENT64) +foreign import ccall safe "kevent64" + c_kevent64 :: QueueFd -> Ptr Event -> CInt -> Ptr Event -> CInt -> CUInt + -> Ptr TimeSpec -> IO CInt +#elif defined(HAVE_KEVENT) +foreign import ccall safe "kevent" + c_kevent :: QueueFd -> Ptr Event -> CInt -> Ptr Event -> CInt + -> Ptr TimeSpec -> IO CInt +#else +#error no kevent system call available!? +#endif + +#endif /* defined(HAVE_KQUEUE) */ diff -Nru ghc-7.0.3/libraries/base/GHC/Event/Manager.hs ghc-7.2.1/libraries/base/GHC/Event/Manager.hs --- ghc-7.0.3/libraries/base/GHC/Event/Manager.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/Event/Manager.hs 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,406 @@ +{-# LANGUAGE BangPatterns + , CPP + , ExistentialQuantification + , NoImplicitPrelude + , RecordWildCards + , TypeSynonymInstances + , FlexibleInstances + #-} + +module GHC.Event.Manager + ( -- * Types + EventManager + + -- * Creation + , new + , newWith + , newDefaultBackend + + -- * Running + , finished + , loop + , step + , shutdown + , cleanup + , wakeManager + + -- * Registering interest in I/O events + , Event + , evtRead + , evtWrite + , IOCallback + , FdKey(keyFd) + , registerFd_ + , registerFd + , unregisterFd_ + , unregisterFd + , closeFd + + -- * Registering interest in timeout events + , TimeoutCallback + , TimeoutKey + , registerTimeout + , updateTimeout + , unregisterTimeout + ) where + +#include "EventConfig.h" + +------------------------------------------------------------------------ +-- Imports + +import Control.Concurrent.MVar (MVar, modifyMVar, newMVar, readMVar) +import Control.Exception (finally) +import Control.Monad ((=<<), forM_, liftM, sequence_, when) +import Data.IORef (IORef, atomicModifyIORef, mkWeakIORef, newIORef, readIORef, + writeIORef) +import Data.Maybe (Maybe(..)) +import Data.Monoid (mappend, mconcat, mempty) +import GHC.Base +import GHC.Conc.Signal (runHandlers) +import GHC.List (filter) +import GHC.Num (Num(..)) +import GHC.Real ((/), fromIntegral ) +import GHC.Show (Show(..)) +import GHC.Event.Clock (getCurrentTime) +import GHC.Event.Control +import GHC.Event.Internal (Backend, Event, evtClose, evtRead, evtWrite, + Timeout(..)) +import GHC.Event.Unique (Unique, UniqueSource, newSource, newUnique) +import System.Posix.Types (Fd) + +import qualified GHC.Event.IntMap as IM +import qualified GHC.Event.Internal as I +import qualified GHC.Event.PSQ as Q + +#if defined(HAVE_KQUEUE) +import qualified GHC.Event.KQueue as KQueue +#elif defined(HAVE_EPOLL) +import qualified GHC.Event.EPoll as EPoll +#elif defined(HAVE_POLL) +import qualified GHC.Event.Poll as Poll +#else +# error not implemented for this operating system +#endif + +------------------------------------------------------------------------ +-- Types + +data FdData = FdData { + fdKey :: {-# UNPACK #-} !FdKey + , fdEvents :: {-# UNPACK #-} !Event + , _fdCallback :: !IOCallback + } + +-- | A file descriptor registration cookie. +data FdKey = FdKey { + keyFd :: {-# UNPACK #-} !Fd + , keyUnique :: {-# UNPACK #-} !Unique + } deriving (Eq, Show) + +-- | Callback invoked on I/O events. +type IOCallback = FdKey -> Event -> IO () + +-- | A timeout registration cookie. +newtype TimeoutKey = TK Unique + deriving (Eq) + +-- | Callback invoked on timeout events. +type TimeoutCallback = IO () + +data State = Created + | Running + | Dying + | Finished + deriving (Eq, Show) + +-- | A priority search queue, with timeouts as priorities. +type TimeoutQueue = Q.PSQ TimeoutCallback + +{- +Instead of directly modifying the 'TimeoutQueue' in +e.g. 'registerTimeout' we keep a list of edits to perform, in the form +of a chain of function closures, and have the I/O manager thread +perform the edits later. This exist to address the following GC +problem: + +Since e.g. 'registerTimeout' doesn't force the evaluation of the +thunks inside the 'emTimeouts' IORef a number of thunks build up +inside the IORef. If the I/O manager thread doesn't evaluate these +thunks soon enough they'll get promoted to the old generation and +become roots for all subsequent minor GCs. + +When the thunks eventually get evaluated they will each create a new +intermediate 'TimeoutQueue' that immediately becomes garbage. Since +the thunks serve as roots until the next major GC these intermediate +'TimeoutQueue's will get copied unnecesarily in the next minor GC, +increasing GC time. This problem is known as "floating garbage". + +Keeping a list of edits doesn't stop this from happening but makes the +amount of data that gets copied smaller. + +TODO: Evaluate the content of the IORef to WHNF on each insert once +this bug is resolved: http://hackage.haskell.org/trac/ghc/ticket/3838 +-} + +-- | An edit to apply to a 'TimeoutQueue'. +type TimeoutEdit = TimeoutQueue -> TimeoutQueue + +-- | The event manager state. +data EventManager = EventManager + { emBackend :: !Backend + , emFds :: {-# UNPACK #-} !(MVar (IM.IntMap [FdData])) + , emTimeouts :: {-# UNPACK #-} !(IORef TimeoutEdit) + , emState :: {-# UNPACK #-} !(IORef State) + , emUniqueSource :: {-# UNPACK #-} !UniqueSource + , emControl :: {-# UNPACK #-} !Control + } + +------------------------------------------------------------------------ +-- Creation + +handleControlEvent :: EventManager -> FdKey -> Event -> IO () +handleControlEvent mgr reg _evt = do + msg <- readControlMessage (emControl mgr) (keyFd reg) + case msg of + CMsgWakeup -> return () + CMsgDie -> writeIORef (emState mgr) Finished + CMsgSignal fp s -> runHandlers fp s + +newDefaultBackend :: IO Backend +#if defined(HAVE_KQUEUE) +newDefaultBackend = KQueue.new +#elif defined(HAVE_EPOLL) +newDefaultBackend = EPoll.new +#elif defined(HAVE_POLL) +newDefaultBackend = Poll.new +#else +newDefaultBackend = error "no back end for this platform" +#endif + +-- | Create a new event manager. +new :: IO EventManager +new = newWith =<< newDefaultBackend + +newWith :: Backend -> IO EventManager +newWith be = do + iofds <- newMVar IM.empty + timeouts <- newIORef id + ctrl <- newControl + state <- newIORef Created + us <- newSource + _ <- mkWeakIORef state $ do + st <- atomicModifyIORef state $ \s -> (Finished, s) + when (st /= Finished) $ do + I.delete be + closeControl ctrl + let mgr = EventManager { emBackend = be + , emFds = iofds + , emTimeouts = timeouts + , emState = state + , emUniqueSource = us + , emControl = ctrl + } + _ <- registerFd_ mgr (handleControlEvent mgr) (controlReadFd ctrl) evtRead + _ <- registerFd_ mgr (handleControlEvent mgr) (wakeupReadFd ctrl) evtRead + return mgr + +-- | Asynchronously shuts down the event manager, if running. +shutdown :: EventManager -> IO () +shutdown mgr = do + state <- atomicModifyIORef (emState mgr) $ \s -> (Dying, s) + when (state == Running) $ sendDie (emControl mgr) + +finished :: EventManager -> IO Bool +finished mgr = (== Finished) `liftM` readIORef (emState mgr) + +cleanup :: EventManager -> IO () +cleanup EventManager{..} = do + writeIORef emState Finished + I.delete emBackend + closeControl emControl + +------------------------------------------------------------------------ +-- Event loop + +-- | Start handling events. This function loops until told to stop, +-- using 'shutdown'. +-- +-- /Note/: This loop can only be run once per 'EventManager', as it +-- closes all of its control resources when it finishes. +loop :: EventManager -> IO () +loop mgr@EventManager{..} = do + state <- atomicModifyIORef emState $ \s -> case s of + Created -> (Running, s) + _ -> (s, s) + case state of + Created -> go Q.empty `finally` cleanup mgr + Dying -> cleanup mgr + _ -> do cleanup mgr + error $ "GHC.Event.Manager.loop: state is already " ++ + show state + where + go q = do (running, q') <- step mgr q + when running $ go q' + +step :: EventManager -> TimeoutQueue -> IO (Bool, TimeoutQueue) +step mgr@EventManager{..} tq = do + (timeout, q') <- mkTimeout tq + I.poll emBackend timeout (onFdEvent mgr) + state <- readIORef emState + state `seq` return (state == Running, q') + where + + -- | Call all expired timer callbacks and return the time to the + -- next timeout. + mkTimeout :: TimeoutQueue -> IO (Timeout, TimeoutQueue) + mkTimeout q = do + now <- getCurrentTime + applyEdits <- atomicModifyIORef emTimeouts $ \f -> (id, f) + let (expired, q'') = let q' = applyEdits q in q' `seq` Q.atMost now q' + sequence_ $ map Q.value expired + let timeout = case Q.minView q'' of + Nothing -> Forever + Just (Q.E _ t _, _) -> + -- This value will always be positive since the call + -- to 'atMost' above removed any timeouts <= 'now' + let t' = t - now in t' `seq` Timeout t' + return (timeout, q'') + +------------------------------------------------------------------------ +-- Registering interest in I/O events + +-- | Register interest in the given events, without waking the event +-- manager thread. The 'Bool' return value indicates whether the +-- event manager ought to be woken. +registerFd_ :: EventManager -> IOCallback -> Fd -> Event + -> IO (FdKey, Bool) +registerFd_ EventManager{..} cb fd evs = do + u <- newUnique emUniqueSource + modifyMVar emFds $ \oldMap -> do + let fd' = fromIntegral fd + reg = FdKey fd u + !fdd = FdData reg evs cb + (!newMap, (oldEvs, newEvs)) = + case IM.insertWith (++) fd' [fdd] oldMap of + (Nothing, n) -> (n, (mempty, evs)) + (Just prev, n) -> (n, pairEvents prev newMap fd') + modify = oldEvs /= newEvs + when modify $ I.modifyFd emBackend fd oldEvs newEvs + return (newMap, (reg, modify)) +{-# INLINE registerFd_ #-} + +-- | @registerFd mgr cb fd evs@ registers interest in the events @evs@ +-- on the file descriptor @fd@. @cb@ is called for each event that +-- occurs. Returns a cookie that can be handed to 'unregisterFd'. +registerFd :: EventManager -> IOCallback -> Fd -> Event -> IO FdKey +registerFd mgr cb fd evs = do + (r, wake) <- registerFd_ mgr cb fd evs + when wake $ wakeManager mgr + return r +{-# INLINE registerFd #-} + +-- | Wake up the event manager. +wakeManager :: EventManager -> IO () +wakeManager mgr = sendWakeup (emControl mgr) + +eventsOf :: [FdData] -> Event +eventsOf = mconcat . map fdEvents + +pairEvents :: [FdData] -> IM.IntMap [FdData] -> Int -> (Event, Event) +pairEvents prev m fd = let l = eventsOf prev + r = case IM.lookup fd m of + Nothing -> mempty + Just fds -> eventsOf fds + in (l, r) + +-- | Drop a previous file descriptor registration, without waking the +-- event manager thread. The return value indicates whether the event +-- manager ought to be woken. +unregisterFd_ :: EventManager -> FdKey -> IO Bool +unregisterFd_ EventManager{..} (FdKey fd u) = + modifyMVar emFds $ \oldMap -> do + let dropReg cbs = case filter ((/= u) . keyUnique . fdKey) cbs of + [] -> Nothing + cbs' -> Just cbs' + fd' = fromIntegral fd + (!newMap, (oldEvs, newEvs)) = + case IM.updateWith dropReg fd' oldMap of + (Nothing, _) -> (oldMap, (mempty, mempty)) + (Just prev, newm) -> (newm, pairEvents prev newm fd') + modify = oldEvs /= newEvs + when modify $ I.modifyFd emBackend fd oldEvs newEvs + return (newMap, modify) + +-- | Drop a previous file descriptor registration. +unregisterFd :: EventManager -> FdKey -> IO () +unregisterFd mgr reg = do + wake <- unregisterFd_ mgr reg + when wake $ wakeManager mgr + +-- | Close a file descriptor in a race-safe way. +closeFd :: EventManager -> (Fd -> IO ()) -> Fd -> IO () +closeFd mgr close fd = do + fds <- modifyMVar (emFds mgr) $ \oldMap -> do + close fd + case IM.delete (fromIntegral fd) oldMap of + (Nothing, _) -> return (oldMap, []) + (Just fds, !newMap) -> do + when (eventsOf fds /= mempty) $ wakeManager mgr + return (newMap, fds) + forM_ fds $ \(FdData reg ev cb) -> cb reg (ev `mappend` evtClose) + +------------------------------------------------------------------------ +-- Registering interest in timeout events + +-- | Register a timeout in the given number of microseconds. The +-- returned 'TimeoutKey' can be used to later unregister or update the +-- timeout. The timeout is automatically unregistered after the given +-- time has passed. +registerTimeout :: EventManager -> Int -> TimeoutCallback -> IO TimeoutKey +registerTimeout mgr us cb = do + !key <- newUnique (emUniqueSource mgr) + if us <= 0 then cb + else do + now <- getCurrentTime + let expTime = fromIntegral us / 1000000.0 + now + + -- We intentionally do not evaluate the modified map to WHNF here. + -- Instead, we leave a thunk inside the IORef and defer its + -- evaluation until mkTimeout in the event loop. This is a + -- workaround for a nasty IORef contention problem that causes the + -- thread-delay benchmark to take 20 seconds instead of 0.2. + atomicModifyIORef (emTimeouts mgr) $ \f -> + let f' = (Q.insert key expTime cb) . f in (f', ()) + wakeManager mgr + return $ TK key + +-- | Unregister an active timeout. +unregisterTimeout :: EventManager -> TimeoutKey -> IO () +unregisterTimeout mgr (TK key) = do + atomicModifyIORef (emTimeouts mgr) $ \f -> + let f' = (Q.delete key) . f in (f', ()) + wakeManager mgr + +-- | Update an active timeout to fire in the given number of +-- microseconds. +updateTimeout :: EventManager -> TimeoutKey -> Int -> IO () +updateTimeout mgr (TK key) us = do + now <- getCurrentTime + let expTime = fromIntegral us / 1000000.0 + now + + atomicModifyIORef (emTimeouts mgr) $ \f -> + let f' = (Q.adjust (const expTime) key) . f in (f', ()) + wakeManager mgr + +------------------------------------------------------------------------ +-- Utilities + +-- | Call the callbacks corresponding to the given file descriptor. +onFdEvent :: EventManager -> Fd -> Event -> IO () +onFdEvent mgr fd evs = do + fds <- readMVar (emFds mgr) + case IM.lookup (fromIntegral fd) fds of + Just cbs -> forM_ cbs $ \(FdData reg ev cb) -> + when (evs `I.eventIs` ev) $ cb reg evs + Nothing -> return () diff -Nru ghc-7.0.3/libraries/base/GHC/Event/Poll.hsc ghc-7.2.1/libraries/base/GHC/Event/Poll.hsc --- ghc-7.0.3/libraries/base/GHC/Event/Poll.hsc 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/Event/Poll.hsc 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,162 @@ +{-# LANGUAGE CPP + , ForeignFunctionInterface + , GeneralizedNewtypeDeriving + , NoImplicitPrelude + , BangPatterns + #-} + +module GHC.Event.Poll + ( + new + , available + ) where + +#include "EventConfig.h" + +#if !defined(HAVE_POLL_H) +import GHC.Base + +new :: IO E.Backend +new = error "Poll back end not implemented for this platform" + +available :: Bool +available = False +{-# INLINE available #-} +#else +#include + +import Control.Concurrent.MVar (MVar, newMVar, swapMVar) +import Control.Monad ((=<<), liftM, liftM2, unless) +import Data.Bits (Bits, (.|.), (.&.)) +import Data.Maybe (Maybe(..)) +import Data.Monoid (Monoid(..)) +import Foreign.C.Types (CInt, CShort, CULong) +import Foreign.Ptr (Ptr) +import Foreign.Storable (Storable(..)) +import GHC.Base +import GHC.Conc.Sync (withMVar) +import GHC.Err (undefined) +import GHC.Num (Num(..)) +import GHC.Real (ceiling, fromIntegral) +import GHC.Show (Show) +import System.Posix.Types (Fd(..)) + +import qualified GHC.Event.Array as A +import qualified GHC.Event.Internal as E + +available :: Bool +available = True +{-# INLINE available #-} + +data Poll = Poll { + pollChanges :: {-# UNPACK #-} !(MVar (A.Array PollFd)) + , pollFd :: {-# UNPACK #-} !(A.Array PollFd) + } + +new :: IO E.Backend +new = E.backend poll modifyFd (\_ -> return ()) `liftM` + liftM2 Poll (newMVar =<< A.empty) A.empty + +modifyFd :: Poll -> Fd -> E.Event -> E.Event -> IO () +modifyFd p fd oevt nevt = + withMVar (pollChanges p) $ \ary -> + A.snoc ary $ PollFd fd (fromEvent nevt) (fromEvent oevt) + +reworkFd :: Poll -> PollFd -> IO () +reworkFd p (PollFd fd npevt opevt) = do + let ary = pollFd p + if opevt == 0 + then A.snoc ary $ PollFd fd npevt 0 + else do + found <- A.findIndex ((== fd) . pfdFd) ary + case found of + Nothing -> error "reworkFd: event not found" + Just (i,_) + | npevt /= 0 -> A.unsafeWrite ary i $ PollFd fd npevt 0 + | otherwise -> A.removeAt ary i + +poll :: Poll + -> E.Timeout + -> (Fd -> E.Event -> IO ()) + -> IO () +poll p tout f = do + let a = pollFd p + mods <- swapMVar (pollChanges p) =<< A.empty + A.forM_ mods (reworkFd p) + n <- A.useAsPtr a $ \ptr len -> E.throwErrnoIfMinus1NoRetry "c_poll" $ + c_poll ptr (fromIntegral len) (fromIntegral (fromTimeout tout)) + unless (n == 0) $ do + A.loop a 0 $ \i e -> do + let r = pfdRevents e + if r /= 0 + then do f (pfdFd e) (toEvent r) + let i' = i + 1 + return (i', i' == n) + else return (i, True) + +fromTimeout :: E.Timeout -> Int +fromTimeout E.Forever = -1 +fromTimeout (E.Timeout s) = ceiling $ 1000 * s + +data PollFd = PollFd { + pfdFd :: {-# UNPACK #-} !Fd + , pfdEvents :: {-# UNPACK #-} !Event + , pfdRevents :: {-# UNPACK #-} !Event + } deriving (Show) + +newtype Event = Event CShort + deriving (Eq, Show, Num, Storable, Bits) + +-- We have to duplicate the whole enum like this in order for the +-- hsc2hs cross-compilation mode to work +#ifdef POLLRDHUP +#{enum Event, Event + , pollIn = POLLIN + , pollOut = POLLOUT + , pollRdHup = POLLRDHUP + , pollErr = POLLERR + , pollHup = POLLHUP + } +#else +#{enum Event, Event + , pollIn = POLLIN + , pollOut = POLLOUT + , pollErr = POLLERR + , pollHup = POLLHUP + } +#endif + +fromEvent :: E.Event -> Event +fromEvent e = remap E.evtRead pollIn .|. + remap E.evtWrite pollOut + where remap evt to + | e `E.eventIs` evt = to + | otherwise = 0 + +toEvent :: Event -> E.Event +toEvent e = remap (pollIn .|. pollErr .|. pollHup) E.evtRead `mappend` + remap (pollOut .|. pollErr .|. pollHup) E.evtWrite + where remap evt to + | e .&. evt /= 0 = to + | otherwise = mempty + +instance Storable PollFd where + sizeOf _ = #size struct pollfd + alignment _ = alignment (undefined :: CInt) + + peek ptr = do + fd <- #{peek struct pollfd, fd} ptr + events <- #{peek struct pollfd, events} ptr + revents <- #{peek struct pollfd, revents} ptr + let !pollFd' = PollFd fd events revents + return pollFd' + + poke ptr p = do + #{poke struct pollfd, fd} ptr (pfdFd p) + #{poke struct pollfd, events} ptr (pfdEvents p) + #{poke struct pollfd, revents} ptr (pfdRevents p) + +foreign import ccall safe "poll.h poll" + c_poll :: Ptr PollFd -> CULong -> CInt -> IO CInt + +#endif /* defined(HAVE_POLL_H) */ diff -Nru ghc-7.0.3/libraries/base/GHC/Event/PSQ.hs ghc-7.2.1/libraries/base/GHC/Event/PSQ.hs --- ghc-7.0.3/libraries/base/GHC/Event/PSQ.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/Event/PSQ.hs 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,483 @@ +{-# LANGUAGE BangPatterns, NoImplicitPrelude #-} + +-- Copyright (c) 2008, Ralf Hinze +-- All rights reserved. +-- +-- Redistribution and use in source and binary forms, with or without +-- modification, are permitted provided that the following conditions +-- are met: +-- +-- * Redistributions of source code must retain the above +-- copyright notice, this list of conditions and the following +-- disclaimer. +-- +-- * Redistributions in binary form must reproduce the above +-- copyright notice, this list of conditions and the following +-- disclaimer in the documentation and/or other materials +-- provided with the distribution. +-- +-- * The names of the contributors may not be used to endorse or +-- promote products derived from this software without specific +-- prior written permission. +-- +-- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +-- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +-- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS +-- FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE +-- COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, +-- INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES +-- (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +-- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +-- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +-- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) +-- ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED +-- OF THE POSSIBILITY OF SUCH DAMAGE. + +-- | A /priority search queue/ (henceforth /queue/) efficiently +-- supports the operations of both a search tree and a priority queue. +-- An 'Elem'ent is a product of a key, a priority, and a +-- value. Elements can be inserted, deleted, modified and queried in +-- logarithmic time, and the element with the least priority can be +-- retrieved in constant time. A queue can be built from a list of +-- elements, sorted by keys, in linear time. +-- +-- This implementation is due to Ralf Hinze with some modifications by +-- Scott Dillard and Johan Tibell. +-- +-- * Hinze, R., /A Simple Implementation Technique for Priority Search +-- Queues/, ICFP 2001, pp. 110-121 +-- +-- +module GHC.Event.PSQ + ( + -- * Binding Type + Elem(..) + , Key + , Prio + + -- * Priority Search Queue Type + , PSQ + + -- * Query + , size + , null + , lookup + + -- * Construction + , empty + , singleton + + -- * Insertion + , insert + + -- * Delete/Update + , delete + , adjust + + -- * Conversion + , toList + , toAscList + , toDescList + , fromList + + -- * Min + , findMin + , deleteMin + , minView + , atMost + ) where + +import Data.Maybe (Maybe(..)) +import GHC.Base +import GHC.Num (Num(..)) +import GHC.Show (Show(showsPrec)) +import GHC.Event.Unique (Unique) + +-- | @E k p@ binds the key @k@ with the priority @p@. +data Elem a = E + { key :: {-# UNPACK #-} !Key + , prio :: {-# UNPACK #-} !Prio + , value :: a + } deriving (Eq, Show) + +------------------------------------------------------------------------ +-- | A mapping from keys @k@ to priorites @p@. + +type Prio = Double +type Key = Unique + +data PSQ a = Void + | Winner {-# UNPACK #-} !(Elem a) + !(LTree a) + {-# UNPACK #-} !Key -- max key + deriving (Eq, Show) + +-- | /O(1)/ The number of elements in a queue. +size :: PSQ a -> Int +size Void = 0 +size (Winner _ lt _) = 1 + size' lt + +-- | /O(1)/ True if the queue is empty. +null :: PSQ a -> Bool +null Void = True +null (Winner _ _ _) = False + +-- | /O(log n)/ The priority and value of a given key, or Nothing if +-- the key is not bound. +lookup :: Key -> PSQ a -> Maybe (Prio, a) +lookup k q = case tourView q of + Null -> Nothing + Single (E k' p v) + | k == k' -> Just (p, v) + | otherwise -> Nothing + tl `Play` tr + | k <= maxKey tl -> lookup k tl + | otherwise -> lookup k tr + +------------------------------------------------------------------------ +-- Construction + +empty :: PSQ a +empty = Void + +-- | /O(1)/ Build a queue with one element. +singleton :: Key -> Prio -> a -> PSQ a +singleton k p v = Winner (E k p v) Start k + +------------------------------------------------------------------------ +-- Insertion + +-- | /O(log n)/ Insert a new key, priority and value in the queue. If +-- the key is already present in the queue, the associated priority +-- and value are replaced with the supplied priority and value. +insert :: Key -> Prio -> a -> PSQ a -> PSQ a +insert k p v q = case q of + Void -> singleton k p v + Winner (E k' p' v') Start _ -> case compare k k' of + LT -> singleton k p v `play` singleton k' p' v' + EQ -> singleton k p v + GT -> singleton k' p' v' `play` singleton k p v + Winner e (RLoser _ e' tl m tr) m' + | k <= m -> insert k p v (Winner e tl m) `play` (Winner e' tr m') + | otherwise -> (Winner e tl m) `play` insert k p v (Winner e' tr m') + Winner e (LLoser _ e' tl m tr) m' + | k <= m -> insert k p v (Winner e' tl m) `play` (Winner e tr m') + | otherwise -> (Winner e' tl m) `play` insert k p v (Winner e tr m') + +------------------------------------------------------------------------ +-- Delete/Update + +-- | /O(log n)/ Delete a key and its priority and value from the +-- queue. When the key is not a member of the queue, the original +-- queue is returned. +delete :: Key -> PSQ a -> PSQ a +delete k q = case q of + Void -> empty + Winner (E k' p v) Start _ + | k == k' -> empty + | otherwise -> singleton k' p v + Winner e (RLoser _ e' tl m tr) m' + | k <= m -> delete k (Winner e tl m) `play` (Winner e' tr m') + | otherwise -> (Winner e tl m) `play` delete k (Winner e' tr m') + Winner e (LLoser _ e' tl m tr) m' + | k <= m -> delete k (Winner e' tl m) `play` (Winner e tr m') + | otherwise -> (Winner e' tl m) `play` delete k (Winner e tr m') + +-- | /O(log n)/ Update a priority at a specific key with the result +-- of the provided function. When the key is not a member of the +-- queue, the original queue is returned. +adjust :: (Prio -> Prio) -> Key -> PSQ a -> PSQ a +adjust f k q0 = go q0 + where + go q = case q of + Void -> empty + Winner (E k' p v) Start _ + | k == k' -> singleton k' (f p) v + | otherwise -> singleton k' p v + Winner e (RLoser _ e' tl m tr) m' + | k <= m -> go (Winner e tl m) `unsafePlay` (Winner e' tr m') + | otherwise -> (Winner e tl m) `unsafePlay` go (Winner e' tr m') + Winner e (LLoser _ e' tl m tr) m' + | k <= m -> go (Winner e' tl m) `unsafePlay` (Winner e tr m') + | otherwise -> (Winner e' tl m) `unsafePlay` go (Winner e tr m') +{-# INLINE adjust #-} + +------------------------------------------------------------------------ +-- Conversion + +-- | /O(n*log n)/ Build a queue from a list of key/priority/value +-- tuples. If the list contains more than one priority and value for +-- the same key, the last priority and value for the key is retained. +fromList :: [Elem a] -> PSQ a +fromList = foldr (\(E k p v) q -> insert k p v q) empty + +-- | /O(n)/ Convert to a list of key/priority/value tuples. +toList :: PSQ a -> [Elem a] +toList = toAscList + +-- | /O(n)/ Convert to an ascending list. +toAscList :: PSQ a -> [Elem a] +toAscList q = seqToList (toAscLists q) + +toAscLists :: PSQ a -> Sequ (Elem a) +toAscLists q = case tourView q of + Null -> emptySequ + Single e -> singleSequ e + tl `Play` tr -> toAscLists tl <> toAscLists tr + +-- | /O(n)/ Convert to a descending list. +toDescList :: PSQ a -> [ Elem a ] +toDescList q = seqToList (toDescLists q) + +toDescLists :: PSQ a -> Sequ (Elem a) +toDescLists q = case tourView q of + Null -> emptySequ + Single e -> singleSequ e + tl `Play` tr -> toDescLists tr <> toDescLists tl + +------------------------------------------------------------------------ +-- Min + +-- | /O(1)/ The element with the lowest priority. +findMin :: PSQ a -> Maybe (Elem a) +findMin Void = Nothing +findMin (Winner e _ _) = Just e + +-- | /O(log n)/ Delete the element with the lowest priority. Returns +-- an empty queue if the queue is empty. +deleteMin :: PSQ a -> PSQ a +deleteMin Void = Void +deleteMin (Winner _ t m) = secondBest t m + +-- | /O(log n)/ Retrieve the binding with the least priority, and the +-- rest of the queue stripped of that binding. +minView :: PSQ a -> Maybe (Elem a, PSQ a) +minView Void = Nothing +minView (Winner e t m) = Just (e, secondBest t m) + +secondBest :: LTree a -> Key -> PSQ a +secondBest Start _ = Void +secondBest (LLoser _ e tl m tr) m' = Winner e tl m `play` secondBest tr m' +secondBest (RLoser _ e tl m tr) m' = secondBest tl m `play` Winner e tr m' + +-- | /O(r*(log n - log r))/ Return a list of elements ordered by +-- key whose priorities are at most @pt@. +atMost :: Prio -> PSQ a -> ([Elem a], PSQ a) +atMost pt q = let (sequ, q') = atMosts pt q + in (seqToList sequ, q') + +atMosts :: Prio -> PSQ a -> (Sequ (Elem a), PSQ a) +atMosts !pt q = case q of + (Winner e _ _) + | prio e > pt -> (emptySequ, q) + Void -> (emptySequ, Void) + Winner e Start _ -> (singleSequ e, Void) + Winner e (RLoser _ e' tl m tr) m' -> + let (sequ, q') = atMosts pt (Winner e tl m) + (sequ', q'') = atMosts pt (Winner e' tr m') + in (sequ <> sequ', q' `play` q'') + Winner e (LLoser _ e' tl m tr) m' -> + let (sequ, q') = atMosts pt (Winner e' tl m) + (sequ', q'') = atMosts pt (Winner e tr m') + in (sequ <> sequ', q' `play` q'') + +------------------------------------------------------------------------ +-- Loser tree + +type Size = Int + +data LTree a = Start + | LLoser {-# UNPACK #-} !Size + {-# UNPACK #-} !(Elem a) + !(LTree a) + {-# UNPACK #-} !Key -- split key + !(LTree a) + | RLoser {-# UNPACK #-} !Size + {-# UNPACK #-} !(Elem a) + !(LTree a) + {-# UNPACK #-} !Key -- split key + !(LTree a) + deriving (Eq, Show) + +size' :: LTree a -> Size +size' Start = 0 +size' (LLoser s _ _ _ _) = s +size' (RLoser s _ _ _ _) = s + +left, right :: LTree a -> LTree a + +left Start = moduleError "left" "empty loser tree" +left (LLoser _ _ tl _ _ ) = tl +left (RLoser _ _ tl _ _ ) = tl + +right Start = moduleError "right" "empty loser tree" +right (LLoser _ _ _ _ tr) = tr +right (RLoser _ _ _ _ tr) = tr + +maxKey :: PSQ a -> Key +maxKey Void = moduleError "maxKey" "empty queue" +maxKey (Winner _ _ m) = m + +lloser, rloser :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a +lloser k p v tl m tr = LLoser (1 + size' tl + size' tr) (E k p v) tl m tr +rloser k p v tl m tr = RLoser (1 + size' tl + size' tr) (E k p v) tl m tr + +------------------------------------------------------------------------ +-- Balancing + +-- | Balance factor +omega :: Int +omega = 4 + +lbalance, rbalance :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a + +lbalance k p v l m r + | size' l + size' r < 2 = lloser k p v l m r + | size' r > omega * size' l = lbalanceLeft k p v l m r + | size' l > omega * size' r = lbalanceRight k p v l m r + | otherwise = lloser k p v l m r + +rbalance k p v l m r + | size' l + size' r < 2 = rloser k p v l m r + | size' r > omega * size' l = rbalanceLeft k p v l m r + | size' l > omega * size' r = rbalanceRight k p v l m r + | otherwise = rloser k p v l m r + +lbalanceLeft :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a +lbalanceLeft k p v l m r + | size' (left r) < size' (right r) = lsingleLeft k p v l m r + | otherwise = ldoubleLeft k p v l m r + +lbalanceRight :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a +lbalanceRight k p v l m r + | size' (left l) > size' (right l) = lsingleRight k p v l m r + | otherwise = ldoubleRight k p v l m r + +rbalanceLeft :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a +rbalanceLeft k p v l m r + | size' (left r) < size' (right r) = rsingleLeft k p v l m r + | otherwise = rdoubleLeft k p v l m r + +rbalanceRight :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a +rbalanceRight k p v l m r + | size' (left l) > size' (right l) = rsingleRight k p v l m r + | otherwise = rdoubleRight k p v l m r + +lsingleLeft :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a +lsingleLeft k1 p1 v1 t1 m1 (LLoser _ (E k2 p2 v2) t2 m2 t3) + | p1 <= p2 = lloser k1 p1 v1 (rloser k2 p2 v2 t1 m1 t2) m2 t3 + | otherwise = lloser k2 p2 v2 (lloser k1 p1 v1 t1 m1 t2) m2 t3 +lsingleLeft k1 p1 v1 t1 m1 (RLoser _ (E k2 p2 v2) t2 m2 t3) = + rloser k2 p2 v2 (lloser k1 p1 v1 t1 m1 t2) m2 t3 +lsingleLeft _ _ _ _ _ _ = moduleError "lsingleLeft" "malformed tree" + +rsingleLeft :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a +rsingleLeft k1 p1 v1 t1 m1 (LLoser _ (E k2 p2 v2) t2 m2 t3) = + rloser k1 p1 v1 (rloser k2 p2 v2 t1 m1 t2) m2 t3 +rsingleLeft k1 p1 v1 t1 m1 (RLoser _ (E k2 p2 v2) t2 m2 t3) = + rloser k2 p2 v2 (rloser k1 p1 v1 t1 m1 t2) m2 t3 +rsingleLeft _ _ _ _ _ _ = moduleError "rsingleLeft" "malformed tree" + +lsingleRight :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a +lsingleRight k1 p1 v1 (LLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 = + lloser k2 p2 v2 t1 m1 (lloser k1 p1 v1 t2 m2 t3) +lsingleRight k1 p1 v1 (RLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 = + lloser k1 p1 v1 t1 m1 (lloser k2 p2 v2 t2 m2 t3) +lsingleRight _ _ _ _ _ _ = moduleError "lsingleRight" "malformed tree" + +rsingleRight :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a +rsingleRight k1 p1 v1 (LLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 = + lloser k2 p2 v2 t1 m1 (rloser k1 p1 v1 t2 m2 t3) +rsingleRight k1 p1 v1 (RLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 + | p1 <= p2 = rloser k1 p1 v1 t1 m1 (lloser k2 p2 v2 t2 m2 t3) + | otherwise = rloser k2 p2 v2 t1 m1 (rloser k1 p1 v1 t2 m2 t3) +rsingleRight _ _ _ _ _ _ = moduleError "rsingleRight" "malformed tree" + +ldoubleLeft :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a +ldoubleLeft k1 p1 v1 t1 m1 (LLoser _ (E k2 p2 v2) t2 m2 t3) = + lsingleLeft k1 p1 v1 t1 m1 (lsingleRight k2 p2 v2 t2 m2 t3) +ldoubleLeft k1 p1 v1 t1 m1 (RLoser _ (E k2 p2 v2) t2 m2 t3) = + lsingleLeft k1 p1 v1 t1 m1 (rsingleRight k2 p2 v2 t2 m2 t3) +ldoubleLeft _ _ _ _ _ _ = moduleError "ldoubleLeft" "malformed tree" + +ldoubleRight :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a +ldoubleRight k1 p1 v1 (LLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 = + lsingleRight k1 p1 v1 (lsingleLeft k2 p2 v2 t1 m1 t2) m2 t3 +ldoubleRight k1 p1 v1 (RLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 = + lsingleRight k1 p1 v1 (rsingleLeft k2 p2 v2 t1 m1 t2) m2 t3 +ldoubleRight _ _ _ _ _ _ = moduleError "ldoubleRight" "malformed tree" + +rdoubleLeft :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a +rdoubleLeft k1 p1 v1 t1 m1 (LLoser _ (E k2 p2 v2) t2 m2 t3) = + rsingleLeft k1 p1 v1 t1 m1 (lsingleRight k2 p2 v2 t2 m2 t3) +rdoubleLeft k1 p1 v1 t1 m1 (RLoser _ (E k2 p2 v2) t2 m2 t3) = + rsingleLeft k1 p1 v1 t1 m1 (rsingleRight k2 p2 v2 t2 m2 t3) +rdoubleLeft _ _ _ _ _ _ = moduleError "rdoubleLeft" "malformed tree" + +rdoubleRight :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a +rdoubleRight k1 p1 v1 (LLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 = + rsingleRight k1 p1 v1 (lsingleLeft k2 p2 v2 t1 m1 t2) m2 t3 +rdoubleRight k1 p1 v1 (RLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 = + rsingleRight k1 p1 v1 (rsingleLeft k2 p2 v2 t1 m1 t2) m2 t3 +rdoubleRight _ _ _ _ _ _ = moduleError "rdoubleRight" "malformed tree" + +-- | Take two pennants and returns a new pennant that is the union of +-- the two with the precondition that the keys in the ï¬rst tree are +-- strictly smaller than the keys in the second tree. +play :: PSQ a -> PSQ a -> PSQ a +Void `play` t' = t' +t `play` Void = t +Winner e@(E k p v) t m `play` Winner e'@(E k' p' v') t' m' + | p <= p' = Winner e (rbalance k' p' v' t m t') m' + | otherwise = Winner e' (lbalance k p v t m t') m' +{-# INLINE play #-} + +-- | A version of 'play' that can be used if the shape of the tree has +-- not changed or if the tree is known to be balanced. +unsafePlay :: PSQ a -> PSQ a -> PSQ a +Void `unsafePlay` t' = t' +t `unsafePlay` Void = t +Winner e@(E k p v) t m `unsafePlay` Winner e'@(E k' p' v') t' m' + | p <= p' = Winner e (rloser k' p' v' t m t') m' + | otherwise = Winner e' (lloser k p v t m t') m' +{-# INLINE unsafePlay #-} + +data TourView a = Null + | Single {-# UNPACK #-} !(Elem a) + | (PSQ a) `Play` (PSQ a) + +tourView :: PSQ a -> TourView a +tourView Void = Null +tourView (Winner e Start _) = Single e +tourView (Winner e (RLoser _ e' tl m tr) m') = + Winner e tl m `Play` Winner e' tr m' +tourView (Winner e (LLoser _ e' tl m tr) m') = + Winner e' tl m `Play` Winner e tr m' + +------------------------------------------------------------------------ +-- Utility functions + +moduleError :: String -> String -> a +moduleError fun msg = error ("GHC.Event.PSQ." ++ fun ++ ':' : ' ' : msg) +{-# NOINLINE moduleError #-} + +------------------------------------------------------------------------ +-- Hughes's efficient sequence type + +newtype Sequ a = Sequ ([a] -> [a]) + +emptySequ :: Sequ a +emptySequ = Sequ (\as -> as) + +singleSequ :: a -> Sequ a +singleSequ a = Sequ (\as -> a : as) + +(<>) :: Sequ a -> Sequ a -> Sequ a +Sequ x1 <> Sequ x2 = Sequ (\as -> x1 (x2 as)) +infixr 5 <> + +seqToList :: Sequ a -> [a] +seqToList (Sequ x) = x [] + +instance Show a => Show (Sequ a) where + showsPrec d a = showsPrec d (seqToList a) diff -Nru ghc-7.0.3/libraries/base/GHC/Event/Thread.hs ghc-7.2.1/libraries/base/GHC/Event/Thread.hs --- ghc-7.0.3/libraries/base/GHC/Event/Thread.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/Event/Thread.hs 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,150 @@ +{-# LANGUAGE BangPatterns, ForeignFunctionInterface, NoImplicitPrelude #-} + +module GHC.Event.Thread + ( getSystemEventManager + , ensureIOManagerIsRunning + , threadWaitRead + , threadWaitWrite + , closeFdWith + , threadDelay + , registerDelay + ) where + +import Data.IORef (IORef, newIORef, readIORef, writeIORef) +import Data.Maybe (Maybe(..)) +import Foreign.C.Error (eBADF, errnoToIOError) +import Foreign.Ptr (Ptr) +import GHC.Base +import GHC.Conc.Sync (TVar, ThreadId, ThreadStatus(..), atomically, forkIO, + labelThread, modifyMVar_, newTVar, sharedCAF, + threadStatus, writeTVar) +import GHC.IO (mask_, onException) +import GHC.IO.Exception (ioError) +import GHC.MVar (MVar, newEmptyMVar, newMVar, putMVar, takeMVar) +import GHC.Event.Internal (eventIs, evtClose) +import GHC.Event.Manager (Event, EventManager, evtRead, evtWrite, loop, + new, registerFd, unregisterFd_, registerTimeout) +import qualified GHC.Event.Manager as M +import System.IO.Unsafe (unsafePerformIO) +import System.Posix.Types (Fd) + +-- | Suspends the current thread for a given number of microseconds +-- (GHC only). +-- +-- There is no guarantee that the thread will be rescheduled promptly +-- when the delay has expired, but the thread will never continue to +-- run /earlier/ than specified. +threadDelay :: Int -> IO () +threadDelay usecs = mask_ $ do + Just mgr <- getSystemEventManager + m <- newEmptyMVar + reg <- registerTimeout mgr usecs (putMVar m ()) + takeMVar m `onException` M.unregisterTimeout mgr reg + +-- | Set the value of returned TVar to True after a given number of +-- microseconds. The caveats associated with threadDelay also apply. +-- +registerDelay :: Int -> IO (TVar Bool) +registerDelay usecs = do + t <- atomically $ newTVar False + Just mgr <- getSystemEventManager + _ <- registerTimeout mgr usecs . atomically $ writeTVar t True + return t + +-- | Block the current thread until data is available to read from the +-- given file descriptor. +-- +-- This will throw an 'IOError' if the file descriptor was closed +-- while this thread was blocked. To safely close a file descriptor +-- that has been used with 'threadWaitRead', use 'closeFdWith'. +threadWaitRead :: Fd -> IO () +threadWaitRead = threadWait evtRead +{-# INLINE threadWaitRead #-} + +-- | Block the current thread until the given file descriptor can +-- accept data to write. +-- +-- This will throw an 'IOError' if the file descriptor was closed +-- while this thread was blocked. To safely close a file descriptor +-- that has been used with 'threadWaitWrite', use 'closeFdWith'. +threadWaitWrite :: Fd -> IO () +threadWaitWrite = threadWait evtWrite +{-# INLINE threadWaitWrite #-} + +-- | Close a file descriptor in a concurrency-safe way. +-- +-- Any threads that are blocked on the file descriptor via +-- 'threadWaitRead' or 'threadWaitWrite' will be unblocked by having +-- IO exceptions thrown. +closeFdWith :: (Fd -> IO ()) -- ^ Action that performs the close. + -> Fd -- ^ File descriptor to close. + -> IO () +closeFdWith close fd = do + Just mgr <- getSystemEventManager + M.closeFd mgr close fd + +threadWait :: Event -> Fd -> IO () +threadWait evt fd = mask_ $ do + m <- newEmptyMVar + Just mgr <- getSystemEventManager + reg <- registerFd mgr (\reg e -> unregisterFd_ mgr reg >> putMVar m e) fd evt + evt' <- takeMVar m `onException` unregisterFd_ mgr reg + if evt' `eventIs` evtClose + then ioError $ errnoToIOError "threadWait" eBADF Nothing Nothing + else return () + +-- | Retrieve the system event manager. +-- +-- This function always returns 'Just' the system event manager when using the +-- threaded RTS and 'Nothing' otherwise. +getSystemEventManager :: IO (Maybe EventManager) +getSystemEventManager = readIORef eventManager + +foreign import ccall unsafe "getOrSetSystemEventThreadEventManagerStore" + getOrSetSystemEventThreadEventManagerStore :: Ptr a -> IO (Ptr a) + +eventManager :: IORef (Maybe EventManager) +eventManager = unsafePerformIO $ do + em <- newIORef Nothing + sharedCAF em getOrSetSystemEventThreadEventManagerStore +{-# NOINLINE eventManager #-} + +foreign import ccall unsafe "getOrSetSystemEventThreadIOManagerThreadStore" + getOrSetSystemEventThreadIOManagerThreadStore :: Ptr a -> IO (Ptr a) + +{-# NOINLINE ioManager #-} +ioManager :: MVar (Maybe ThreadId) +ioManager = unsafePerformIO $ do + m <- newMVar Nothing + sharedCAF m getOrSetSystemEventThreadIOManagerThreadStore + +ensureIOManagerIsRunning :: IO () +ensureIOManagerIsRunning + | not threaded = return () + | otherwise = modifyMVar_ ioManager $ \old -> do + let create = do + !mgr <- new + writeIORef eventManager $ Just mgr + !t <- forkIO $ loop mgr + labelThread t "IOManager" + return $ Just t + case old of + Nothing -> create + st@(Just t) -> do + s <- threadStatus t + case s of + ThreadFinished -> create + ThreadDied -> do + -- Sanity check: if the thread has died, there is a chance + -- that event manager is still alive. This could happend during + -- the fork, for example. In this case we should clean up + -- open pipes and everything else related to the event manager. + -- See #4449 + mem <- readIORef eventManager + _ <- case mem of + Nothing -> return () + Just em -> M.cleanup em + create + _other -> return st + +foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool diff -Nru ghc-7.0.3/libraries/base/GHC/Event/Unique.hs ghc-7.2.1/libraries/base/GHC/Event/Unique.hs --- ghc-7.0.3/libraries/base/GHC/Event/Unique.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/Event/Unique.hs 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,40 @@ +{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving, NoImplicitPrelude #-} +module GHC.Event.Unique + ( + UniqueSource + , Unique(..) + , newSource + , newUnique + ) where + +import Data.Int (Int64) +import GHC.Base +import GHC.Conc.Sync (TVar, atomically, newTVarIO, readTVar, writeTVar) +import GHC.Num (Num(..)) +import GHC.Show (Show(..)) + +-- We used to use IORefs here, but Simon switched us to STM when we +-- found that our use of atomicModifyIORef was subject to a severe RTS +-- performance problem when used in a tight loop from multiple +-- threads: http://hackage.haskell.org/trac/ghc/ticket/3838 +-- +-- There seems to be no performance cost to using a TVar instead. + +newtype UniqueSource = US (TVar Int64) + +newtype Unique = Unique { asInt64 :: Int64 } + deriving (Eq, Ord, Num) + +instance Show Unique where + show = show . asInt64 + +newSource :: IO UniqueSource +newSource = US `fmap` newTVarIO 0 + +newUnique :: UniqueSource -> IO Unique +newUnique (US ref) = atomically $ do + u <- readTVar ref + let !u' = u+1 + writeTVar ref u' + return $ Unique u' +{-# INLINE newUnique #-} diff -Nru ghc-7.0.3/libraries/base/GHC/Event.hs ghc-7.2.1/libraries/base/GHC/Event.hs --- ghc-7.0.3/libraries/base/GHC/Event.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/Event.hs 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,42 @@ +{-# LANGUAGE Trustworthy #-} +-- | This module provides scalable event notification for file +-- descriptors and timeouts. +-- +-- This module should be considered GHC internal. +module GHC.Event + ( -- * Types + EventManager + + -- * Creation + , new + , getSystemEventManager + + -- * Running + , loop + + -- ** Stepwise running + , step + , shutdown + + -- * Registering interest in I/O events + , Event + , evtRead + , evtWrite + , IOCallback + , FdKey(keyFd) + , registerFd + , registerFd_ + , unregisterFd + , unregisterFd_ + , closeFd + + -- * Registering interest in timeout events + , TimeoutCallback + , TimeoutKey + , registerTimeout + , updateTimeout + , unregisterTimeout + ) where + +import GHC.Event.Manager +import GHC.Event.Thread (getSystemEventManager) diff -Nru ghc-7.0.3/libraries/base/GHC/Exception.lhs ghc-7.2.1/libraries/base/GHC/Exception.lhs --- ghc-7.0.3/libraries/base/GHC/Exception.lhs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/Exception.lhs 2011-08-07 17:10:07.000000000 +0000 @@ -1,5 +1,10 @@ \begin{code} -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude + , ExistentialQuantification + , MagicHash + , DeriveDataTypeable + #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- -- | @@ -20,6 +25,7 @@ import Data.Maybe import {-# SOURCE #-} Data.Typeable (Typeable, cast) + -- loop: Data.Typeable -> GHC.Err -> GHC.Exception import GHC.Base import GHC.Show \end{code} @@ -57,7 +63,7 @@ @ThatException@ as exceptions: @ -*Main> throw ThisException `catch` \e -> putStrLn (\"Caught \" ++ show (e :: MyException)) +*Main> throw ThisException \`catch\` \\e -> putStrLn (\"Caught \" ++ show (e :: MyException)) Caught ThisException @ diff -Nru ghc-7.0.3/libraries/base/GHC/Exts.hs ghc-7.2.1/libraries/base/GHC/Exts.hs --- ghc-7.0.3/libraries/base/GHC/Exts.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/Exts.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,3 +1,5 @@ +{-# LANGUAGE MagicHash, UnboxedTuples, DeriveDataTypeable #-} + ----------------------------------------------------------------------------- -- | -- Module : GHC.Exts @@ -58,7 +60,6 @@ import GHC.Magic import GHC.Word import GHC.Int --- import GHC.Float import GHC.Ptr import Data.String import Data.List diff -Nru ghc-7.0.3/libraries/base/GHC/Fingerprint/Type.hs ghc-7.2.1/libraries/base/GHC/Fingerprint/Type.hs --- ghc-7.0.3/libraries/base/GHC/Fingerprint/Type.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/Fingerprint/Type.hs 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,19 @@ +{-# LANGUAGE NoImplicitPrelude #-} +-- ---------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow 2006 +-- +-- Fingerprints for recompilation checking and ABI versioning, and +-- implementing fast comparison of Typeable. +-- +-- ---------------------------------------------------------------------------- + +module GHC.Fingerprint.Type (Fingerprint(..)) where + +import GHC.Base +import GHC.Word + +-- Using 128-bit MD5 fingerprints for now. + +data Fingerprint = Fingerprint {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 + deriving (Eq, Ord) diff -Nru ghc-7.0.3/libraries/base/GHC/Fingerprint.hs ghc-7.2.1/libraries/base/GHC/Fingerprint.hs --- ghc-7.0.3/libraries/base/GHC/Fingerprint.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/Fingerprint.hs 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,75 @@ +{-# LANGUAGE NoImplicitPrelude + , BangPatterns + , ForeignFunctionInterface + , EmptyDataDecls + #-} +-- ---------------------------------------------------------------------------- +-- +-- (c) The University of Glasgow 2006 +-- +-- Fingerprints for recompilation checking and ABI versioning, and +-- implementing fast comparison of Typeable. +-- +-- ---------------------------------------------------------------------------- + +module GHC.Fingerprint ( + Fingerprint(..), fingerprint0, + fingerprintData, + fingerprintString, + fingerprintFingerprints + ) where + +import GHC.IO +import GHC.Base +import GHC.Num +import GHC.List +import GHC.Real +import Foreign +import Foreign.C + +import GHC.Fingerprint.Type + +-- for SIZEOF_STRUCT_MD5CONTEXT: +#include "HsBaseConfig.h" + +-- XXX instance Storable Fingerprint +-- defined in Foreign.Storable to avoid orphan instance + +fingerprint0 :: Fingerprint +fingerprint0 = Fingerprint 0 0 + +fingerprintFingerprints :: [Fingerprint] -> Fingerprint +fingerprintFingerprints fs = unsafeDupablePerformIO $ + withArrayLen fs $ \len p -> do + fingerprintData (castPtr p) (len * sizeOf (head fs)) + +fingerprintData :: Ptr Word8 -> Int -> IO Fingerprint +fingerprintData buf len = do + allocaBytes SIZEOF_STRUCT_MD5CONTEXT $ \pctxt -> do + c_MD5Init pctxt + c_MD5Update pctxt buf (fromIntegral len) + allocaBytes 16 $ \pdigest -> do + c_MD5Final pdigest pctxt + peek (castPtr pdigest :: Ptr Fingerprint) + +-- This is duplicated in compiler/utils/Fingerprint.hsc +fingerprintString :: String -> Fingerprint +fingerprintString str = unsafeDupablePerformIO $ + withArrayLen word8s $ \len p -> + fingerprintData p len + where word8s = concatMap f str + f c = let w32 :: Word32 + w32 = fromIntegral (ord c) + in [fromIntegral (w32 `shiftR` 24), + fromIntegral (w32 `shiftR` 16), + fromIntegral (w32 `shiftR` 8), + fromIntegral w32] + +data MD5Context + +foreign import ccall unsafe "MD5Init" + c_MD5Init :: Ptr MD5Context -> IO () +foreign import ccall unsafe "MD5Update" + c_MD5Update :: Ptr MD5Context -> Ptr Word8 -> CInt -> IO () +foreign import ccall unsafe "MD5Final" + c_MD5Final :: Ptr Word8 -> Ptr MD5Context -> IO () diff -Nru ghc-7.0.3/libraries/base/GHC/Fingerprint.hs-boot ghc-7.2.1/libraries/base/GHC/Fingerprint.hs-boot --- ghc-7.0.3/libraries/base/GHC/Fingerprint.hs-boot 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/Fingerprint.hs-boot 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,12 @@ +{-# LANGUAGE NoImplicitPrelude #-} +module GHC.Fingerprint ( + fingerprintString, + fingerprintFingerprints + ) where + +import GHC.Base +import GHC.Fingerprint.Type + +fingerprintFingerprints :: [Fingerprint] -> Fingerprint +fingerprintString :: String -> Fingerprint + diff -Nru ghc-7.0.3/libraries/base/GHC/Float/ConversionUtils.hs ghc-7.2.1/libraries/base/GHC/Float/ConversionUtils.hs --- ghc-7.0.3/libraries/base/GHC/Float/ConversionUtils.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/Float/ConversionUtils.hs 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,97 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, MagicHash, UnboxedTuples, NoImplicitPrelude #-} +{-# OPTIONS_GHC -O2 #-} +{-# OPTIONS_HADDOCK hide #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.Float.ConversionUtils +-- Copyright : (c) Daniel Fischer 2010 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- Utilities for conversion between Double/Float and Rational +-- +----------------------------------------------------------------------------- + +#include "MachDeps.h" + +-- #hide +module GHC.Float.ConversionUtils ( elimZerosInteger, elimZerosInt# ) where + +import GHC.Base +import GHC.Integer +#if WORD_SIZE_IN_BITS < 64 +import GHC.IntWord64 +#endif + +default () + +#if WORD_SIZE_IN_BITS < 64 + +#define TO64 integerToInt64 + +toByte64# :: Int64# -> Int# +toByte64# i = word2Int# (and# 255## (int2Word# (int64ToInt# i))) + +-- Double mantissae have 53 bits, too much for Int# +elim64# :: Int64# -> Int# -> (# Integer, Int# #) +elim64# n e = + case zeroCount (toByte64# n) of + t | e <=# t -> (# int64ToInteger (uncheckedIShiftRA64# n e), 0# #) + | t <# 8# -> (# int64ToInteger (uncheckedIShiftRA64# n t), e -# t #) + | otherwise -> elim64# (uncheckedIShiftRA64# n 8#) (e -# 8#) + +#else + +#define TO64 integerToInt + +-- Double mantissae fit it Int# +elim64# :: Int# -> Int# -> (# Integer, Int# #) +elim64# = elimZerosInt# + +#endif + +{-# INLINE elimZerosInteger #-} +elimZerosInteger :: Integer -> Int# -> (# Integer, Int# #) +elimZerosInteger m e = elim64# (TO64 m) e + +elimZerosInt# :: Int# -> Int# -> (# Integer, Int# #) +elimZerosInt# n e = + case zeroCount (toByte# n) of + t | e <=# t -> (# smallInteger (uncheckedIShiftRA# n e), 0# #) + | t <# 8# -> (# smallInteger (uncheckedIShiftRA# n t), e -# t #) + | otherwise -> elimZerosInt# (uncheckedIShiftRA# n 8#) (e -# 8#) + +{-# INLINE zeroCount #-} +zeroCount :: Int# -> Int# +zeroCount i = + case zeroCountArr of + BA ba -> indexInt8Array# ba i + +toByte# :: Int# -> Int# +toByte# i = word2Int# (and# 255## (int2Word# i)) + + +data BA = BA ByteArray# + +-- Number of trailing zero bits in a byte +zeroCountArr :: BA +zeroCountArr = + let mkArr s = + case newByteArray# 256# s of + (# s1, mba #) -> + case writeInt8Array# mba 0# 8# s1 of + s2 -> + let fillA step val idx st + | idx <# 256# = case writeInt8Array# mba idx val st of + nx -> fillA step val (idx +# step) nx + | step <# 256# = fillA (2# *# step) (val +# 1#) step st + | otherwise = st + in case fillA 2# 0# 1# s2 of + s3 -> case unsafeFreezeByteArray# mba s3 of + (# _, ba #) -> ba + in case mkArr realWorld# of + b -> BA b diff -Nru ghc-7.0.3/libraries/base/GHC/Float/RealFracMethods.hs ghc-7.2.1/libraries/base/GHC/Float/RealFracMethods.hs --- ghc-7.0.3/libraries/base/GHC/Float/RealFracMethods.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/Float/RealFracMethods.hs 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,342 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, MagicHash, UnboxedTuples, ForeignFunctionInterface, + NoImplicitPrelude #-} +{-# OPTIONS_HADDOCK hide #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.Float.RealFracMethods +-- Copyright : (c) Daniel Fischer 2010 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : cvs-ghc@haskell.org +-- Stability : internal +-- Portability : non-portable (GHC Extensions) +-- +-- Methods for the RealFrac instances for 'Float' and 'Double', +-- with specialised versions for 'Int'. +-- +-- Moved to their own module to not bloat GHC.Float further. +-- +----------------------------------------------------------------------------- + +#include "MachDeps.h" + +-- #hide +module GHC.Float.RealFracMethods + ( -- * Double methods + -- ** Integer results + properFractionDoubleInteger + , truncateDoubleInteger + , floorDoubleInteger + , ceilingDoubleInteger + , roundDoubleInteger + -- ** Int results + , properFractionDoubleInt + , floorDoubleInt + , ceilingDoubleInt + , roundDoubleInt + -- * Double/Int conversions, wrapped primops + , double2Int + , int2Double + -- * Float methods + -- ** Integer results + , properFractionFloatInteger + , truncateFloatInteger + , floorFloatInteger + , ceilingFloatInteger + , roundFloatInteger + -- ** Int results + , properFractionFloatInt + , floorFloatInt + , ceilingFloatInt + , roundFloatInt + -- * Float/Int conversions, wrapped primops + , float2Int + , int2Float + ) where + +import GHC.Integer + +import GHC.Base +import GHC.Num () + +#if WORD_SIZE_IN_BITS < 64 + +import GHC.IntWord64 + +#define TO64 integerToInt64 +#define FROM64 int64ToInteger +#define MINUS64 minusInt64# +#define NEGATE64 negateInt64# + +#else + +#define TO64 integerToInt +#define FROM64 smallInteger +#define MINUS64 ( -# ) +#define NEGATE64 negateInt# + +uncheckedIShiftRA64# :: Int# -> Int# -> Int# +uncheckedIShiftRA64# = uncheckedIShiftRA# + +uncheckedIShiftL64# :: Int# -> Int# -> Int# +uncheckedIShiftL64# = uncheckedIShiftL# + +#endif + +default () + +------------------------------------------------------------------------------ +-- Float Methods -- +------------------------------------------------------------------------------ + +-- Special Functions for Int, nice, easy and fast. +-- They should be small enough to be inlined automatically. + +-- We have to test for ±0.0 to avoid returning -0.0 in the second +-- component of the pair. Unfortunately the branching costs a lot +-- of performance. +properFractionFloatInt :: Float -> (Int, Float) +properFractionFloatInt (F# x) = + if x `eqFloat#` 0.0# + then (I# 0#, F# 0.0#) + else case float2Int# x of + n -> (I# n, F# (x `minusFloat#` int2Float# n)) + +-- truncateFloatInt = float2Int + +floorFloatInt :: Float -> Int +floorFloatInt (F# x) = + case float2Int# x of + n | x `ltFloat#` int2Float# n -> I# (n -# 1#) + | otherwise -> I# n + +ceilingFloatInt :: Float -> Int +ceilingFloatInt (F# x) = + case float2Int# x of + n | int2Float# n `ltFloat#` x -> I# (n +# 1#) + | otherwise -> I# n + +roundFloatInt :: Float -> Int +roundFloatInt x = float2Int (c_rintFloat x) + +-- Functions with Integer results + +-- With the new code generator in GHC 7, the explicit bit-fiddling is +-- slower than the old code for values of small modulus, but when the +-- 'Int' range is left, the bit-fiddling quickly wins big, so we use that. +-- If the methods are called on smallish values, hopefully people go +-- through Int and not larger types. + +-- Note: For negative exponents, we must check the validity of the shift +-- distance for the right shifts of the mantissa. + +{-# INLINE properFractionFloatInteger #-} +properFractionFloatInteger :: Float -> (Integer, Float) +properFractionFloatInteger v@(F# x) = + case decodeFloat_Int# x of + (# m, e #) + | e <# 0# -> + case negateInt# e of + s | s ># 23# -> (0, v) + | m <# 0# -> + case negateInt# (negateInt# m `uncheckedIShiftRA#` s) of + k -> (smallInteger k, + case m -# (k `uncheckedIShiftL#` s) of + r -> F# (encodeFloatInteger (smallInteger r) e)) + | otherwise -> + case m `uncheckedIShiftRL#` s of + k -> (smallInteger k, + case m -# (k `uncheckedIShiftL#` s) of + r -> F# (encodeFloatInteger (smallInteger r) e)) + | otherwise -> (shiftLInteger (smallInteger m) e, F# 0.0#) + +{-# INLINE truncateFloatInteger #-} +truncateFloatInteger :: Float -> Integer +truncateFloatInteger x = + case properFractionFloatInteger x of + (n, _) -> n + +-- floor is easier for negative numbers than truncate, so this gets its +-- own implementation, it's a little faster. +{-# INLINE floorFloatInteger #-} +floorFloatInteger :: Float -> Integer +floorFloatInteger (F# x) = + case decodeFloat_Int# x of + (# m, e #) + | e <# 0# -> + case negateInt# e of + s | s ># 23# -> if m <# 0# then (-1) else 0 + | otherwise -> smallInteger (m `uncheckedIShiftRA#` s) + | otherwise -> shiftLInteger (smallInteger m) e + +-- ceiling x = -floor (-x) +-- If giving this its own implementation is faster at all, +-- it's only marginally so, hence we keep it short. +{-# INLINE ceilingFloatInteger #-} +ceilingFloatInteger :: Float -> Integer +ceilingFloatInteger (F# x) = + negateInteger (floorFloatInteger (F# (negateFloat# x))) + +{-# INLINE roundFloatInteger #-} +roundFloatInteger :: Float -> Integer +roundFloatInteger x = float2Integer (c_rintFloat x) + +------------------------------------------------------------------------------ +-- Double Methods -- +------------------------------------------------------------------------------ + +-- Special Functions for Int, nice, easy and fast. +-- They should be small enough to be inlined automatically. + +-- We have to test for ±0.0 to avoid returning -0.0 in the second +-- component of the pair. Unfortunately the branching costs a lot +-- of performance. +properFractionDoubleInt :: Double -> (Int, Double) +properFractionDoubleInt (D# x) = + if x ==## 0.0## + then (I# 0#, D# 0.0##) + else case double2Int# x of + n -> (I# n, D# (x -## int2Double# n)) + +-- truncateDoubleInt = double2Int + +floorDoubleInt :: Double -> Int +floorDoubleInt (D# x) = + case double2Int# x of + n | x <## int2Double# n -> I# (n -# 1#) + | otherwise -> I# n + +ceilingDoubleInt :: Double -> Int +ceilingDoubleInt (D# x) = + case double2Int# x of + n | int2Double# n <## x -> I# (n +# 1#) + | otherwise -> I# n + +roundDoubleInt :: Double -> Int +roundDoubleInt x = double2Int (c_rintDouble x) + +-- Functions with Integer results + +-- The new Code generator isn't quite as good for the old 'Double' code +-- as for the 'Float' code, so for 'Double' the bit-fiddling also wins +-- when the values have small modulus. + +-- When the exponent is negative, all mantissae have less than 64 bits +-- and the right shifting of sized types is much faster than that of +-- 'Integer's, especially when we can + +-- Note: For negative exponents, we must check the validity of the shift +-- distance for the right shifts of the mantissa. + +{-# INLINE properFractionDoubleInteger #-} +properFractionDoubleInteger :: Double -> (Integer, Double) +properFractionDoubleInteger v@(D# x) = + case decodeDoubleInteger x of + (# m, e #) + | e <# 0# -> + case negateInt# e of + s | s ># 52# -> (0, v) + | m < 0 -> + case TO64 (negateInteger m) of + n -> + case n `uncheckedIShiftRA64#` s of + k -> + (FROM64 (NEGATE64 k), + case MINUS64 n (k `uncheckedIShiftL64#` s) of + r -> + D# (encodeDoubleInteger (FROM64 (NEGATE64 r)) e)) + | otherwise -> + case TO64 m of + n -> + case n `uncheckedIShiftRA64#` s of + k -> (FROM64 k, + case MINUS64 n (k `uncheckedIShiftL64#` s) of + r -> D# (encodeDoubleInteger (FROM64 r) e)) + | otherwise -> (shiftLInteger m e, D# 0.0##) + +{-# INLINE truncateDoubleInteger #-} +truncateDoubleInteger :: Double -> Integer +truncateDoubleInteger x = + case properFractionDoubleInteger x of + (n, _) -> n + +-- floor is easier for negative numbers than truncate, so this gets its +-- own implementation, it's a little faster. +{-# INLINE floorDoubleInteger #-} +floorDoubleInteger :: Double -> Integer +floorDoubleInteger (D# x) = + case decodeDoubleInteger x of + (# m, e #) + | e <# 0# -> + case negateInt# e of + s | s ># 52# -> if m < 0 then (-1) else 0 + | otherwise -> + case TO64 m of + n -> FROM64 (n `uncheckedIShiftRA64#` s) + | otherwise -> shiftLInteger m e + +{-# INLINE ceilingDoubleInteger #-} +ceilingDoubleInteger :: Double -> Integer +ceilingDoubleInteger (D# x) = + negateInteger (floorDoubleInteger (D# (negateDouble# x))) + +{-# INLINE roundDoubleInteger #-} +roundDoubleInteger :: Double -> Integer +roundDoubleInteger x = double2Integer (c_rintDouble x) + +-- Wrappers around double2Int#, int2Double#, float2Int# and int2Float#, +-- we need them here, so we move them from GHC.Float and re-export them +-- explicitly from there. + +double2Int :: Double -> Int +double2Int (D# x) = I# (double2Int# x) + +int2Double :: Int -> Double +int2Double (I# i) = D# (int2Double# i) + +float2Int :: Float -> Int +float2Int (F# x) = I# (float2Int# x) + +int2Float :: Int -> Float +int2Float (I# i) = F# (int2Float# i) + +-- Quicker conversions from 'Double' and 'Float' to 'Integer', +-- assuming the floating point value is integral. +-- +-- Note: Since the value is integral, the exponent can't be less than +-- (-TYP_MANT_DIG), so we need not check the validity of the shift +-- distance for the right shfts here. + +{-# INLINE double2Integer #-} +double2Integer :: Double -> Integer +double2Integer (D# x) = + case decodeDoubleInteger x of + (# m, e #) + | e <# 0# -> + case TO64 m of + n -> FROM64 (n `uncheckedIShiftRA64#` negateInt# e) + | otherwise -> shiftLInteger m e + +{-# INLINE float2Integer #-} +float2Integer :: Float -> Integer +float2Integer (F# x) = + case decodeFloat_Int# x of + (# m, e #) + | e <# 0# -> smallInteger (m `uncheckedIShiftRA#` negateInt# e) + | otherwise -> shiftLInteger (smallInteger m) e + +-- Foreign imports, the rounding is done faster in C when the value +-- isn't integral, so we call out for rounding. For values of large +-- modulus, calling out to C is slower than staying in Haskell, but +-- presumably 'round' is mostly called for values with smaller modulus, +-- when calling out to C is a major win. +-- For all other functions, calling out to C gives at most a marginal +-- speedup for values of small modulus and is much slower than staying +-- in Haskell for values of large modulus, so those are done in Haskell. + +foreign import ccall unsafe "rintDouble" + c_rintDouble :: Double -> Double + +foreign import ccall unsafe "rintFloat" + c_rintFloat :: Float -> Float diff -Nru ghc-7.0.3/libraries/base/GHC/Float.lhs ghc-7.2.1/libraries/base/GHC/Float.lhs --- ghc-7.0.3/libraries/base/GHC/Float.lhs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/Float.lhs 2011-08-07 17:10:07.000000000 +0000 @@ -1,9 +1,16 @@ \begin{code} -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP + , NoImplicitPrelude + , MagicHash + , UnboxedTuples + , ForeignFunctionInterface + #-} -- We believe we could deorphan this module, by moving lots of things -- around, but we haven't got there yet: {-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_HADDOCK hide #-} + ----------------------------------------------------------------------------- -- | -- Module : GHC.Float @@ -21,7 +28,8 @@ #include "ieee-flpt.h" -- #hide -module GHC.Float( module GHC.Float, Float(..), Double(..), Float#, Double# ) +module GHC.Float( module GHC.Float, Float(..), Double(..), Float#, Double# + , double2Int, int2Double, float2Int, int2Float ) where import Data.Maybe @@ -34,6 +42,10 @@ import GHC.Num import GHC.Real import GHC.Arr +import GHC.Float.RealFracMethods +import GHC.Float.ConversionUtils +import GHC.Integer.Logarithms ( integerLogBase# ) +import GHC.Integer.Logarithms.Internals infixr 8 ** \end{code} @@ -182,28 +194,51 @@ fromInteger i = F# (floatFromInteger i) instance Real Float where - toRational x = (m%1)*(b%1)^^n - where (m,n) = decodeFloat x - b = floatRadix x + toRational (F# x#) = + case decodeFloat_Int# x# of + (# m#, e# #) + | e# >=# 0# -> + (smallInteger m# `shiftLInteger` e#) :% 1 + | (int2Word# m# `and#` 1##) `eqWord#` 0## -> + case elimZerosInt# m# (negateInt# e#) of + (# n, d# #) -> n :% shiftLInteger 1 d# + | otherwise -> + smallInteger m# :% shiftLInteger 1 (negateInt# e#) instance Fractional Float where (/) x y = divideFloat x y - fromRational x = fromRat x + fromRational (n:%0) + | n == 0 = 0/0 + | n < 0 = (-1)/0 + | otherwise = 1/0 + fromRational (n:%d) + | n == 0 = encodeFloat 0 0 + | n < 0 = -(fromRat'' minEx mantDigs (-n) d) + | otherwise = fromRat'' minEx mantDigs n d + where + minEx = FLT_MIN_EXP + mantDigs = FLT_MANT_DIG recip x = 1.0 / x -{-# RULES "truncate/Float->Int" truncate = float2Int #-} +-- RULES for Integer and Int +{-# RULES +"properFraction/Float->Integer" properFraction = properFractionFloatInteger +"truncate/Float->Integer" truncate = truncateFloatInteger +"floor/Float->Integer" floor = floorFloatInteger +"ceiling/Float->Integer" ceiling = ceilingFloatInteger +"round/Float->Integer" round = roundFloatInteger +"properFraction/Float->Int" properFraction = properFractionFloatInt +"truncate/Float->Int" truncate = float2Int +"floor/Float->Int" floor = floorFloatInt +"ceiling/Float->Int" ceiling = ceilingFloatInt +"round/Float->Int" round = roundFloatInt + #-} instance RealFrac Float where - {-# SPECIALIZE properFraction :: Float -> (Int, Float) #-} - {-# SPECIALIZE round :: Float -> Int #-} - - {-# SPECIALIZE properFraction :: Float -> (Integer, Float) #-} - {-# SPECIALIZE round :: Float -> Integer #-} - -- ceiling, floor, and truncate are all small - {-# INLINE ceiling #-} - {-# INLINE floor #-} - {-# INLINE truncate #-} + {-# INLINE [1] ceiling #-} + {-# INLINE [1] floor #-} + {-# INLINE [1] truncate #-} -- We assume that FLT_RADIX is 2 so that we can use more efficient code #if FLT_RADIX != 2 @@ -316,13 +351,30 @@ instance Real Double where - toRational x = (m%1)*(b%1)^^n - where (m,n) = decodeFloat x - b = floatRadix x + toRational (D# x#) = + case decodeDoubleInteger x# of + (# m, e# #) + | e# >=# 0# -> + shiftLInteger m e# :% 1 + | (int2Word# (integerToInt m) `and#` 1##) `eqWord#` 0## -> + case elimZerosInteger m (negateInt# e#) of + (# n, d# #) -> n :% shiftLInteger 1 d# + | otherwise -> + m :% shiftLInteger 1 (negateInt# e#) instance Fractional Double where (/) x y = divideDouble x y - fromRational x = fromRat x + fromRational (n:%0) + | n == 0 = 0/0 + | n < 0 = (-1)/0 + | otherwise = 1/0 + fromRational (n:%d) + | n == 0 = encodeFloat 0 0 + | n < 0 = -(fromRat'' minEx mantDigs (-n) d) + | otherwise = fromRat'' minEx mantDigs n d + where + minEx = DBL_MIN_EXP + mantDigs = DBL_MANT_DIG recip x = 1.0 / x instance Floating Double where @@ -346,27 +398,32 @@ acosh x = log (x + (x+1.0) * sqrt ((x-1.0)/(x+1.0))) atanh x = 0.5 * log ((1.0+x) / (1.0-x)) -{-# RULES "truncate/Double->Int" truncate = double2Int #-} +-- RULES for Integer and Int +{-# RULES +"properFraction/Double->Integer" properFraction = properFractionDoubleInteger +"truncate/Double->Integer" truncate = truncateDoubleInteger +"floor/Double->Integer" floor = floorDoubleInteger +"ceiling/Double->Integer" ceiling = ceilingDoubleInteger +"round/Double->Integer" round = roundDoubleInteger +"properFraction/Double->Int" properFraction = properFractionDoubleInt +"truncate/Double->Int" truncate = double2Int +"floor/Double->Int" floor = floorDoubleInt +"ceiling/Double->Int" ceiling = ceilingDoubleInt +"round/Double->Int" round = roundDoubleInt + #-} instance RealFrac Double where - {-# SPECIALIZE properFraction :: Double -> (Int, Double) #-} - {-# SPECIALIZE round :: Double -> Int #-} - - {-# SPECIALIZE properFraction :: Double -> (Integer, Double) #-} - {-# SPECIALIZE round :: Double -> Integer #-} - -- ceiling, floor, and truncate are all small - {-# INLINE ceiling #-} - {-# INLINE floor #-} - {-# INLINE truncate #-} + {-# INLINE [1] ceiling #-} + {-# INLINE [1] floor #-} + {-# INLINE [1] truncate #-} properFraction x = case (decodeFloat x) of { (m,n) -> - let b = floatRadix x in if n >= 0 then - (fromInteger m * fromInteger b ^ n, 0.0) + (fromInteger m * 2 ^ n, 0.0) else - case (quotRem m (b^(negate n))) of { (w,r) -> + case (quotRem m (2^(negate n))) of { (w,r) -> (fromInteger w, encodeFloat r n) } } @@ -595,19 +652,19 @@ -- will have an impossibly low exponent. Adjust for this. (f, e) = let n = minExp - e0 in - if n > 0 then (f0 `div` (b^n), e0+n) else (f0, e0) + if n > 0 then (f0 `quot` (expt b n), e0+n) else (f0, e0) (r, s, mUp, mDn) = if e >= 0 then - let be = b^ e in - if f == b^(p-1) then + let be = expt b e in + if f == expt b (p-1) then (f*be*b*2, 2*b, be*b, be) -- according to Burger and Dybvig else (f*be*2, 2, be, be) else - if e > minExp && f == b^(p-1) then - (f*b*2, b^(-e+1)*2, b, 1) + if e > minExp && f == expt b (p-1) then + (f*b*2, expt b (-e+1)*2, b, 1) else - (f*2, b^(-e)*2, 1, 1) + (f*2, expt b (-e)*2, 1, 1) k :: Int k = let @@ -653,7 +710,7 @@ gen ds rn sN mUpN mDnN = let - (dn, rn') = (rn * base) `divMod` sN + (dn, rn') = (rn * base) `quotRem` sN mUpN' = mUpN * base mDnN' = mDnN * base in @@ -732,8 +789,10 @@ \begin{code} -- | Converts a 'Rational' value into any type in class 'RealFloat'. -{-# SPECIALISE fromRat :: Rational -> Double, - Rational -> Float #-} +{-# RULES +"fromRat/Float" fromRat = (fromRational :: Rational -> Float) +"fromRat/Double" fromRat = (fromRational :: Rational -> Double) + #-} fromRat :: (RealFloat a) => Rational -> a -- Deal with special cases first, delegating the real work to fromRat' @@ -785,27 +844,106 @@ if base == 2 && n >= minExpt && n <= maxExpt then expts!n else - base^n + if base == 10 && n <= maxExpt10 then + expts10!n + else + base^n expts :: Array Int Integer expts = array (minExpt,maxExpt) [(n,2^n) | n <- [minExpt .. maxExpt]] +maxExpt10 :: Int +maxExpt10 = 324 + +expts10 :: Array Int Integer +expts10 = array (minExpt,maxExpt10) [(n,10^n) | n <- [minExpt .. maxExpt10]] + -- Compute the (floor of the) log of i in base b. -- Simplest way would be just divide i by b until it's smaller then b, but that would --- be very slow! We are just slightly more clever. +-- be very slow! We are just slightly more clever, except for base 2, where +-- we take advantage of the representation of Integers. +-- The general case could be improved by a lookup table for +-- approximating the result by integerLog2 i / integerLog2 b. integerLogBase :: Integer -> Integer -> Int integerLogBase b i | i < b = 0 - | otherwise = doDiv (i `div` (b^l)) l - where - -- Try squaring the base first to cut down the number of divisions. - l = 2 * integerLogBase (b*b) i - - doDiv :: Integer -> Int -> Int - doDiv x y - | x < b = y - | otherwise = doDiv (x `div` b) (y+1) + | b == 2 = I# (integerLog2# i) + | otherwise = I# (integerLogBase# b i) + +\end{code} + +Unfortunately, the old conversion code was awfully slow due to +a) a slow integer logarithm +b) repeated calculation of gcd's + +For the case of Rational's coming from a Float or Double via toRational, +we can exploit the fact that the denominator is a power of two, which for +these brings a huge speedup since we need only shift and add instead +of division. + +The below is an adaption of fromRat' for the conversion to +Float or Double exploiting the know floatRadix and avoiding +divisions as much as possible. +\begin{code} +{-# SPECIALISE fromRat'' :: Int -> Int -> Integer -> Integer -> Float, + Int -> Int -> Integer -> Integer -> Double #-} +fromRat'' :: RealFloat a => Int -> Int -> Integer -> Integer -> a +fromRat'' minEx@(I# me#) mantDigs@(I# md#) n d = + case integerLog2IsPowerOf2# d of + (# ld#, pw# #) + | pw# ==# 0# -> + case integerLog2# n of + ln# | ln# ># (ld# +# me#) -> + if ln# <# md# + then encodeFloat (n `shiftL` (I# (md# -# 1# -# ln#))) + (I# (ln# +# 1# -# ld# -# md#)) + else let n' = n `shiftR` (I# (ln# +# 1# -# md#)) + n'' = case roundingMode# n (ln# -# md#) of + 0# -> n' + 2# -> n' + 1 + _ -> case fromInteger n' .&. (1 :: Int) of + 0 -> n' + _ -> n' + 1 + in encodeFloat n'' (I# (ln# -# ld# +# 1# -# md#)) + | otherwise -> + case ld# +# (me# -# md#) of + ld'# | ld'# ># (ln# +# 1#) -> encodeFloat 0 0 + | ld'# ==# (ln# +# 1#) -> + case integerLog2IsPowerOf2# n of + (# _, 0# #) -> encodeFloat 0 0 + (# _, _ #) -> encodeFloat 1 (minEx - mantDigs) + | ld'# <=# 0# -> + encodeFloat n (I# ((me# -# md#) -# ld'#)) + | otherwise -> + let n' = n `shiftR` (I# ld'#) + in case roundingMode# n (ld'# -# 1#) of + 0# -> encodeFloat n' (minEx - mantDigs) + 1# -> if fromInteger n' .&. (1 :: Int) == 0 + then encodeFloat n' (minEx-mantDigs) + else encodeFloat (n' + 1) (minEx-mantDigs) + _ -> encodeFloat (n' + 1) (minEx-mantDigs) + | otherwise -> + let ln = I# (integerLog2# n) + ld = I# ld# + p0 = max minEx (ln - ld) + (n', d') + | p0 < mantDigs = (n `shiftL` (mantDigs - p0), d) + | p0 == mantDigs = (n, d) + | otherwise = (n, d `shiftL` (p0 - mantDigs)) + scale p a b + | p <= minEx-mantDigs = (p,a,b) + | a < (b `shiftL` (mantDigs-1)) = (p-1, a `shiftL` 1, b) + | (b `shiftL` mantDigs) <= a = (p+1, a, b `shiftL` 1) + | otherwise = (p, a, b) + (p', n'', d'') = scale (p0-mantDigs) n' d' + rdq = case n'' `quotRem` d'' of + (q,r) -> case compare (r `shiftL` 1) d'' of + LT -> q + EQ -> if fromInteger q .&. (1 :: Int) == 0 + then q else q+1 + GT -> q+1 + in encodeFloat rdq p' \end{code} @@ -836,12 +974,6 @@ ltFloat (F# x) (F# y) = ltFloat# x y leFloat (F# x) (F# y) = leFloat# x y -float2Int :: Float -> Int -float2Int (F# x) = I# (float2Int# x) - -int2Float :: Int -> Float -int2Float (I# x) = F# (int2Float# x) - expFloat, logFloat, sqrtFloat :: Float -> Float sinFloat, cosFloat, tanFloat :: Float -> Float asinFloat, acosFloat, atanFloat :: Float -> Float @@ -882,12 +1014,6 @@ ltDouble (D# x) (D# y) = x <## y leDouble (D# x) (D# y) = x <=## y -double2Int :: Double -> Int -double2Int (D# x) = I# (double2Int# x) - -int2Double :: Int -> Double -int2Double (I# x) = D# (int2Double# x) - double2Float :: Double -> Float double2Float (D# x) = F# (double2Float# x) diff -Nru ghc-7.0.3/libraries/base/GHC/Foreign.hs ghc-7.2.1/libraries/base/GHC/Foreign.hs --- ghc-7.0.3/libraries/base/GHC/Foreign.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/Foreign.hs 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,257 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude #-} + +----------------------------------------------------------------------------- +-- | +-- Module : GHC.Foreign +-- Copyright : (c) The University of Glasgow, 2008-2011 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- Foreign marshalling support for CStrings with configurable encodings +-- +----------------------------------------------------------------------------- + +module GHC.Foreign ( + -- * C strings with a configurable encoding + + -- conversion of C strings into Haskell strings + -- + peekCString, -- :: TextEncoding -> CString -> IO String + peekCStringLen, -- :: TextEncoding -> CStringLen -> IO String + + -- conversion of Haskell strings into C strings + -- + newCString, -- :: TextEncoding -> String -> IO CString + newCStringLen, -- :: TextEncoding -> String -> IO CStringLen + + -- conversion of Haskell strings into C strings using temporary storage + -- + withCString, -- :: TextEncoding -> String -> (CString -> IO a) -> IO a + withCStringLen, -- :: TextEncoding -> String -> (CStringLen -> IO a) -> IO a + + charIsRepresentable, -- :: TextEncoding -> Char -> IO Bool + ) where + +import Foreign.Marshal.Array +import Foreign.C.Types +import Foreign.Ptr +import Foreign.Storable + +import Data.Word + +-- Imports for the locale-encoding version of marshallers +import Control.Monad + +import Data.Tuple (fst) +import Data.Maybe + +import {-# SOURCE #-} System.Posix.Internals (puts) +import GHC.Show ( show ) + +import Foreign.Marshal.Alloc +import Foreign.ForeignPtr + +import GHC.Err (undefined) +import GHC.List +import GHC.Num +import GHC.Base + +import GHC.IO +import GHC.IO.Exception +import GHC.IO.Buffer +import GHC.IO.Encoding.Failure (surrogatifyRoundtripCharacter, desurrogatifyRoundtripCharacter) +import GHC.IO.Encoding.Types + + +c_DEBUG_DUMP :: Bool +c_DEBUG_DUMP = False + +putDebugMsg :: String -> IO () +putDebugMsg | c_DEBUG_DUMP = puts + | otherwise = const (return ()) + + +-- These definitions are identical to those in Foreign.C.String, but copied in here to avoid a cycle: +type CString = Ptr CChar +type CStringLen = (Ptr CChar, Int) + +-- exported functions +-- ------------------ + +-- | Marshal a NUL terminated C string into a Haskell string. +-- +peekCString :: TextEncoding -> CString -> IO String +peekCString enc cp = do + sz <- lengthArray0 nUL cp + peekEncodedCString enc (cp, sz * cCharSize) + +-- | Marshal a C string with explicit length into a Haskell string. +-- +peekCStringLen :: TextEncoding -> CStringLen -> IO String +peekCStringLen = peekEncodedCString + +-- | Marshal a Haskell string into a NUL terminated C string. +-- +-- * the Haskell string may /not/ contain any NUL characters +-- +-- * new storage is allocated for the C string and must be +-- explicitly freed using 'Foreign.Marshal.Alloc.free' or +-- 'Foreign.Marshal.Alloc.finalizerFree'. +-- +newCString :: TextEncoding -> String -> IO CString +newCString enc = liftM fst . newEncodedCString enc True + +-- | Marshal a Haskell string into a C string (ie, character array) with +-- explicit length information. +-- +-- * new storage is allocated for the C string and must be +-- explicitly freed using 'Foreign.Marshal.Alloc.free' or +-- 'Foreign.Marshal.Alloc.finalizerFree'. +-- +newCStringLen :: TextEncoding -> String -> IO CStringLen +newCStringLen enc = newEncodedCString enc False + +-- | Marshal a Haskell string into a NUL terminated C string using temporary +-- storage. +-- +-- * the Haskell string may /not/ contain any NUL characters +-- +-- * the memory is freed when the subcomputation terminates (either +-- normally or via an exception), so the pointer to the temporary +-- storage must /not/ be used after this. +-- +withCString :: TextEncoding -> String -> (CString -> IO a) -> IO a +withCString enc s act = withEncodedCString enc True s $ \(cp, _sz) -> act cp + +-- | Marshal a Haskell string into a C string (ie, character array) +-- in temporary storage, with explicit length information. +-- +-- * the memory is freed when the subcomputation terminates (either +-- normally or via an exception), so the pointer to the temporary +-- storage must /not/ be used after this. +-- +withCStringLen :: TextEncoding -> String -> (CStringLen -> IO a) -> IO a +withCStringLen enc = withEncodedCString enc False + + +-- | Determines whether a character can be accurately encoded in a 'CString'. +-- +-- Pretty much anyone who uses this function is in a state of sin because +-- whether or not a character is encodable will, in general, depend on the +-- context in which it occurs. +charIsRepresentable :: TextEncoding -> Char -> IO Bool +charIsRepresentable enc c = withCString enc [c] (fmap (== [c]) . peekCString enc) `catchException` (\e -> let _ = e :: IOException in return False) + +-- auxiliary definitions +-- ---------------------- + +-- C's end of string character +nUL :: CChar +nUL = 0 + +-- Size of a CChar in bytes +cCharSize :: Int +cCharSize = sizeOf (undefined :: CChar) + + +{-# INLINE peekEncodedCString #-} +peekEncodedCString :: TextEncoding -- ^ Encoding of CString + -> CStringLen + -> IO String -- ^ String in Haskell terms +peekEncodedCString (TextEncoding { mkTextDecoder = mk_decoder }) (p, sz_bytes) + = bracket mk_decoder close $ \decoder -> do + let chunk_size = sz_bytes `max` 1 -- Decode buffer chunk size in characters: one iteration only for ASCII + from0 <- fmap (\fp -> bufferAdd sz_bytes (emptyBuffer fp sz_bytes ReadBuffer)) $ newForeignPtr_ (castPtr p) + to <- newCharBuffer chunk_size WriteBuffer + + let go iteration from = do + (why, from', to') <- encode decoder from to + if isEmptyBuffer from' + then + -- No input remaining: @why@ will be InputUnderflow, but we don't care + fmap (map desurrogatifyRoundtripCharacter) $ withBuffer to' $ peekArray (bufferElems to') + else do + -- Input remaining: what went wrong? + putDebugMsg ("peekEncodedCString: " ++ show iteration ++ " " ++ show why) + (from'', to'') <- case why of InvalidSequence -> recover decoder from' to' -- These conditions are equally bad because + InputUnderflow -> recover decoder from' to' -- they indicate malformed/truncated input + OutputUnderflow -> return (from', to') -- We will have more space next time round + putDebugMsg ("peekEncodedCString: from " ++ summaryBuffer from ++ " " ++ summaryBuffer from' ++ " " ++ summaryBuffer from'') + putDebugMsg ("peekEncodedCString: to " ++ summaryBuffer to ++ " " ++ summaryBuffer to' ++ " " ++ summaryBuffer to'') + to_chars <- withBuffer to'' $ peekArray (bufferElems to'') + fmap (map desurrogatifyRoundtripCharacter to_chars++) $ go (iteration + 1) from'' + + go (0 :: Int) from0 + +{-# INLINE withEncodedCString #-} +withEncodedCString :: TextEncoding -- ^ Encoding of CString to create + -> Bool -- ^ Null-terminate? + -> String -- ^ String to encode + -> (CStringLen -> IO a) -- ^ Worker that can safely use the allocated memory + -> IO a +withEncodedCString (TextEncoding { mkTextEncoder = mk_encoder }) null_terminate s act + = bracket mk_encoder close $ \encoder -> withArrayLen (map surrogatifyRoundtripCharacter s) $ \sz p -> do + from <- fmap (\fp -> bufferAdd sz (emptyBuffer fp sz ReadBuffer)) $ newForeignPtr_ p + + let go iteration to_sz_bytes = do + putDebugMsg ("withEncodedCString: " ++ show iteration) + allocaBytes to_sz_bytes $ \to_p -> do + mb_res <- tryFillBufferAndCall encoder null_terminate from to_p to_sz_bytes act + case mb_res of + Nothing -> go (iteration + 1) (to_sz_bytes * 2) + Just res -> return res + + -- If the input string is ASCII, this value will ensure we only allocate once + go (0 :: Int) (cCharSize * (sz + 1)) + +{-# INLINE newEncodedCString #-} +newEncodedCString :: TextEncoding -- ^ Encoding of CString to create + -> Bool -- ^ Null-terminate? + -> String -- ^ String to encode + -> IO CStringLen +newEncodedCString (TextEncoding { mkTextEncoder = mk_encoder }) null_terminate s + = bracket mk_encoder close $ \encoder -> withArrayLen (map surrogatifyRoundtripCharacter s) $ \sz p -> do + from <- fmap (\fp -> bufferAdd sz (emptyBuffer fp sz ReadBuffer)) $ newForeignPtr_ p + + let go iteration to_p to_sz_bytes = do + putDebugMsg ("newEncodedCString: " ++ show iteration) + mb_res <- tryFillBufferAndCall encoder null_terminate from to_p to_sz_bytes return + case mb_res of + Nothing -> do + let to_sz_bytes' = to_sz_bytes * 2 + to_p' <- reallocBytes to_p to_sz_bytes' + go (iteration + 1) to_p' to_sz_bytes' + Just res -> return res + + -- If the input string is ASCII, this value will ensure we only allocate once + let to_sz_bytes = cCharSize * (sz + 1) + to_p <- mallocBytes to_sz_bytes + go (0 :: Int) to_p to_sz_bytes + + +tryFillBufferAndCall :: TextEncoder dstate -> Bool -> Buffer Char -> Ptr Word8 -> Int + -> (CStringLen -> IO a) -> IO (Maybe a) +tryFillBufferAndCall encoder null_terminate from0 to_p to_sz_bytes act = do + to_fp <- newForeignPtr_ to_p + go (0 :: Int) (from0, emptyBuffer to_fp to_sz_bytes WriteBuffer) + where + go iteration (from, to) = do + (why, from', to') <- encode encoder from to + putDebugMsg ("tryFillBufferAndCall: " ++ show iteration ++ " " ++ show why ++ " " ++ summaryBuffer from ++ " " ++ summaryBuffer from') + if isEmptyBuffer from' + then if null_terminate && bufferAvailable to' == 0 + then return Nothing -- We had enough for the string but not the terminator: ask the caller for more buffer + else do + -- Awesome, we had enough buffer + let bytes = bufferElems to' + withBuffer to' $ \to_ptr -> do + when null_terminate $ pokeElemOff to_ptr (bufR to') 0 + fmap Just $ act (castPtr to_ptr, bytes) -- NB: the length information is specified as being in *bytes* + else case why of -- We didn't consume all of the input + InputUnderflow -> recover encoder from' to' >>= go (iteration + 1) -- These conditions are equally bad + InvalidSequence -> recover encoder from' to' >>= go (iteration + 1) -- since the input was truncated/invalid + OutputUnderflow -> return Nothing -- Oops, out of buffer during decoding: ask the caller for more diff -Nru ghc-7.0.3/libraries/base/GHC/ForeignPtr.hs ghc-7.2.1/libraries/base/GHC/ForeignPtr.hs --- ghc-7.0.3/libraries/base/GHC/ForeignPtr.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/ForeignPtr.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,5 +1,12 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE CPP + , NoImplicitPrelude + , BangPatterns + , MagicHash + , UnboxedTuples + #-} {-# OPTIONS_HADDOCK hide #-} +{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} + ----------------------------------------------------------------------------- -- | -- Module : GHC.ForeignPtr diff -Nru ghc-7.0.3/libraries/base/GHC/Handle.hs ghc-7.2.1/libraries/base/GHC/Handle.hs --- ghc-7.0.3/libraries/base/GHC/Handle.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/Handle.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,3 +1,4 @@ +{-# LANGUAGE Trustworthy #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- -- | @@ -53,3 +54,4 @@ import GHC.IO.Handle import GHC.IO.Handle.Internals import GHC.IO.Handle.FD + diff -Nru ghc-7.0.3/libraries/base/GHC/Int.hs ghc-7.2.1/libraries/base/GHC/Int.hs --- ghc-7.0.3/libraries/base/GHC/Int.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/Int.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,6 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude, BangPatterns, MagicHash, + StandaloneDeriving #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- -- | @@ -18,8 +20,8 @@ -- #hide module GHC.Int ( - Int8(..), Int16(..), Int32(..), Int64(..), - uncheckedIShiftL64#, uncheckedIShiftRA64# + Int8(..), Int16(..), Int32(..), Int64(..), + uncheckedIShiftL64#, uncheckedIShiftRA64# ) where import Data.Bits @@ -42,6 +44,7 @@ import GHC.Show import GHC.Float () -- for RealFrac methods + ------------------------------------------------------------------------ -- type Int8 ------------------------------------------------------------------------ @@ -65,7 +68,7 @@ signum x | x > 0 = 1 signum 0 = 0 signum _ = -1 - fromInteger i = I8# (narrow8Int# (toInt# i)) + fromInteger i = I8# (narrow8Int# (integerToInt i)) instance Real Int8 where toRational x = toInteger x % 1 @@ -88,28 +91,28 @@ instance Integral Int8 where quot x@(I8# x#) y@(I8# y#) | y == 0 = divZeroError - | x == minBound && y == (-1) = overflowError + | y == (-1) && x == minBound = overflowError -- Note [Order of tests] | otherwise = I8# (narrow8Int# (x# `quotInt#` y#)) - rem x@(I8# x#) y@(I8# y#) + rem (I8# x#) y@(I8# y#) | y == 0 = divZeroError - | x == minBound && y == (-1) = overflowError | otherwise = I8# (narrow8Int# (x# `remInt#` y#)) div x@(I8# x#) y@(I8# y#) | y == 0 = divZeroError - | x == minBound && y == (-1) = overflowError + | y == (-1) && x == minBound = overflowError -- Note [Order of tests] | otherwise = I8# (narrow8Int# (x# `divInt#` y#)) - mod x@(I8# x#) y@(I8# y#) + mod (I8# x#) y@(I8# y#) | y == 0 = divZeroError - | x == minBound && y == (-1) = overflowError | otherwise = I8# (narrow8Int# (x# `modInt#` y#)) quotRem x@(I8# x#) y@(I8# y#) | y == 0 = divZeroError - | x == minBound && y == (-1) = overflowError + -- Note [Order of tests] + | y == (-1) && x == minBound = (overflowError, 0) | otherwise = (I8# (narrow8Int# (x# `quotInt#` y#)), I8# (narrow8Int# (x# `remInt#` y#))) divMod x@(I8# x#) y@(I8# y#) | y == 0 = divZeroError - | x == minBound && y == (-1) = overflowError + -- Note [Order of tests] + | y == (-1) && x == minBound = (overflowError, 0) | otherwise = (I8# (narrow8Int# (x# `divInt#` y#)), I8# (narrow8Int# (x# `modInt#` y#))) toInteger (I8# x#) = smallInteger x# @@ -207,7 +210,7 @@ signum x | x > 0 = 1 signum 0 = 0 signum _ = -1 - fromInteger i = I16# (narrow16Int# (toInt# i)) + fromInteger i = I16# (narrow16Int# (integerToInt i)) instance Real Int16 where toRational x = toInteger x % 1 @@ -230,28 +233,28 @@ instance Integral Int16 where quot x@(I16# x#) y@(I16# y#) | y == 0 = divZeroError - | x == minBound && y == (-1) = overflowError + | y == (-1) && x == minBound = overflowError -- Note [Order of tests] | otherwise = I16# (narrow16Int# (x# `quotInt#` y#)) - rem x@(I16# x#) y@(I16# y#) + rem (I16# x#) y@(I16# y#) | y == 0 = divZeroError - | x == minBound && y == (-1) = overflowError | otherwise = I16# (narrow16Int# (x# `remInt#` y#)) div x@(I16# x#) y@(I16# y#) | y == 0 = divZeroError - | x == minBound && y == (-1) = overflowError + | y == (-1) && x == minBound = overflowError -- Note [Order of tests] | otherwise = I16# (narrow16Int# (x# `divInt#` y#)) - mod x@(I16# x#) y@(I16# y#) + mod (I16# x#) y@(I16# y#) | y == 0 = divZeroError - | x == minBound && y == (-1) = overflowError | otherwise = I16# (narrow16Int# (x# `modInt#` y#)) quotRem x@(I16# x#) y@(I16# y#) | y == 0 = divZeroError - | x == minBound && y == (-1) = overflowError + -- Note [Order of tests] + | y == (-1) && x == minBound = (overflowError, 0) | otherwise = (I16# (narrow16Int# (x# `quotInt#` y#)), I16# (narrow16Int# (x# `remInt#` y#))) divMod x@(I16# x#) y@(I16# y#) | y == 0 = divZeroError - | x == minBound && y == (-1) = overflowError + -- Note [Order of tests] + | y == (-1) && x == minBound = (overflowError, 0) | otherwise = (I16# (narrow16Int# (x# `divInt#` y#)), I16# (narrow16Int# (x# `modInt#` y#))) toInteger (I16# x#) = smallInteger x# @@ -384,28 +387,36 @@ instance Integral Int32 where quot x@(I32# x#) y@(I32# y#) | y == 0 = divZeroError - | x == minBound && y == (-1) = overflowError + | y == (-1) && x == minBound = overflowError -- Note [Order of tests] | otherwise = I32# (x# `quotInt32#` y#) - rem x@(I32# x#) y@(I32# y#) + rem (I32# x#) y@(I32# y#) | y == 0 = divZeroError - | x == minBound && y == (-1) = overflowError + -- The quotRem CPU instruction fails for minBound `quotRem` -1, + -- but minBound `rem` -1 is well-defined (0). We therefore + -- special-case it. + | y == (-1) = 0 | otherwise = I32# (x# `remInt32#` y#) div x@(I32# x#) y@(I32# y#) | y == 0 = divZeroError - | x == minBound && y == (-1) = overflowError + | y == (-1) && x == minBound = overflowError -- Note [Order of tests] | otherwise = I32# (x# `divInt32#` y#) - mod x@(I32# x#) y@(I32# y#) + mod (I32# x#) y@(I32# y#) | y == 0 = divZeroError - | x == minBound && y == (-1) = overflowError + -- The divMod CPU instruction fails for minBound `divMod` -1, + -- but minBound `mod` -1 is well-defined (0). We therefore + -- special-case it. + | y == (-1) = 0 | otherwise = I32# (x# `modInt32#` y#) quotRem x@(I32# x#) y@(I32# y#) | y == 0 = divZeroError - | x == minBound && y == (-1) = overflowError + -- Note [Order of tests] + | y == (-1) && x == minBound = (overflowError, 0) | otherwise = (I32# (x# `quotInt32#` y#), I32# (x# `remInt32#` y#)) divMod x@(I32# x#) y@(I32# y#) | y == 0 = divZeroError - | x == minBound && y == (-1) = overflowError + -- Note [Order of tests] + | y == (-1) && x == minBound = (overflowError, 0) | otherwise = (I32# (x# `divInt32#` y#), I32# (x# `modInt32#` y#)) toInteger x@(I32# x#) @@ -489,7 +500,7 @@ signum x | x > 0 = 1 signum 0 = 0 signum _ = -1 - fromInteger i = I32# (narrow32Int# (toInt# i)) + fromInteger i = I32# (narrow32Int# (integerToInt i)) instance Enum Int32 where succ x @@ -513,28 +524,36 @@ instance Integral Int32 where quot x@(I32# x#) y@(I32# y#) | y == 0 = divZeroError - | x == minBound && y == (-1) = overflowError + | y == (-1) && x == minBound = overflowError -- Note [Order of tests] | otherwise = I32# (narrow32Int# (x# `quotInt#` y#)) - rem x@(I32# x#) y@(I32# y#) + rem (I32# x#) y@(I32# y#) | y == 0 = divZeroError - | x == minBound && y == (-1) = overflowError + -- The quotRem CPU instruction fails for minBound `quotRem` -1, + -- but minBound `rem` -1 is well-defined (0). We therefore + -- special-case it. + | y == (-1) = 0 | otherwise = I32# (narrow32Int# (x# `remInt#` y#)) div x@(I32# x#) y@(I32# y#) | y == 0 = divZeroError - | x == minBound && y == (-1) = overflowError + | y == (-1) && x == minBound = overflowError -- Note [Order of tests] | otherwise = I32# (narrow32Int# (x# `divInt#` y#)) - mod x@(I32# x#) y@(I32# y#) + mod (I32# x#) y@(I32# y#) | y == 0 = divZeroError - | x == minBound && y == (-1) = overflowError + -- The divMod CPU instruction fails for minBound `divMod` -1, + -- but minBound `mod` -1 is well-defined (0). We therefore + -- special-case it. + | y == (-1) = 0 | otherwise = I32# (narrow32Int# (x# `modInt#` y#)) quotRem x@(I32# x#) y@(I32# y#) | y == 0 = divZeroError - | x == minBound && y == (-1) = overflowError + -- Note [Order of tests] + | y == (-1) && x == minBound = (overflowError, 0) | otherwise = (I32# (narrow32Int# (x# `quotInt#` y#)), I32# (narrow32Int# (x# `remInt#` y#))) divMod x@(I32# x#) y@(I32# y#) | y == 0 = divZeroError - | x == minBound && y == (-1) = overflowError + -- Note [Order of tests] + | y == (-1) && x == minBound = (overflowError, 0) | otherwise = (I32# (narrow32Int# (x# `divInt#` y#)), I32# (narrow32Int# (x# `modInt#` y#))) toInteger (I32# x#) = smallInteger x# @@ -672,28 +691,36 @@ instance Integral Int64 where quot x@(I64# x#) y@(I64# y#) | y == 0 = divZeroError - | x == minBound && y == (-1) = overflowError + | y == (-1) && x == minBound = overflowError -- Note [Order of tests] | otherwise = I64# (x# `quotInt64#` y#) - rem x@(I64# x#) y@(I64# y#) + rem (I64# x#) y@(I64# y#) | y == 0 = divZeroError - | x == minBound && y == (-1) = overflowError + -- The quotRem CPU instruction fails for minBound `quotRem` -1, + -- but minBound `rem` -1 is well-defined (0). We therefore + -- special-case it. + | y == (-1) = 0 | otherwise = I64# (x# `remInt64#` y#) div x@(I64# x#) y@(I64# y#) | y == 0 = divZeroError - | x == minBound && y == (-1) = overflowError + | y == (-1) && x == minBound = overflowError -- Note [Order of tests] | otherwise = I64# (x# `divInt64#` y#) - mod x@(I64# x#) y@(I64# y#) + mod (I64# x#) y@(I64# y#) | y == 0 = divZeroError - | x == minBound && y == (-1) = overflowError + -- The divMod CPU instruction fails for minBound `divMod` -1, + -- but minBound `mod` -1 is well-defined (0). We therefore + -- special-case it. + | y == (-1) = 0 | otherwise = I64# (x# `modInt64#` y#) quotRem x@(I64# x#) y@(I64# y#) | y == 0 = divZeroError - | x == minBound && y == (-1) = overflowError + -- Note [Order of tests] + | y == (-1) && x == minBound = (overflowError, 0) | otherwise = (I64# (x# `quotInt64#` y#), I64# (x# `remInt64#` y#)) divMod x@(I64# x#) y@(I64# y#) | y == 0 = divZeroError - | x == minBound && y == (-1) = overflowError + -- Note [Order of tests] + | y == (-1) && x == minBound = (overflowError, 0) | otherwise = (I64# (x# `divInt64#` y#), I64# (x# `modInt64#` y#)) toInteger (I64# x) = int64ToInteger x @@ -788,7 +815,7 @@ signum x | x > 0 = 1 signum 0 = 0 signum _ = -1 - fromInteger i = I64# (toInt# i) + fromInteger i = I64# (integerToInt i) instance Enum Int64 where succ x @@ -805,27 +832,35 @@ instance Integral Int64 where quot x@(I64# x#) y@(I64# y#) | y == 0 = divZeroError - | x == minBound && y == (-1) = overflowError + | y == (-1) && x == minBound = overflowError -- Note [Order of tests] | otherwise = I64# (x# `quotInt#` y#) - rem x@(I64# x#) y@(I64# y#) + rem (I64# x#) y@(I64# y#) | y == 0 = divZeroError - | x == minBound && y == (-1) = overflowError + -- The quotRem CPU instruction fails for minBound `quotRem` -1, + -- but minBound `rem` -1 is well-defined (0). We therefore + -- special-case it. + | y == (-1) = 0 | otherwise = I64# (x# `remInt#` y#) div x@(I64# x#) y@(I64# y#) | y == 0 = divZeroError - | x == minBound && y == (-1) = overflowError + | y == (-1) && x == minBound = overflowError -- Note [Order of tests] | otherwise = I64# (x# `divInt#` y#) - mod x@(I64# x#) y@(I64# y#) + mod (I64# x#) y@(I64# y#) | y == 0 = divZeroError - | x == minBound && y == (-1) = overflowError + -- The divMod CPU instruction fails for minBound `divMod` -1, + -- but minBound `mod` -1 is well-defined (0). We therefore + -- special-case it. + | y == (-1) = 0 | otherwise = I64# (x# `modInt#` y#) quotRem x@(I64# x#) y@(I64# y#) | y == 0 = divZeroError - | x == minBound && y == (-1) = overflowError + -- Note [Order of tests] + | y == (-1) && x == minBound = (overflowError, 0) | otherwise = (I64# (x# `quotInt#` y#), I64# (x# `remInt#` y#)) divMod x@(I64# x#) y@(I64# y#) | y == 0 = divZeroError - | x == minBound && y == (-1) = overflowError + -- Note [Order of tests] + | y == (-1) && x == minBound = (overflowError, 0) | otherwise = (I64# (x# `divInt#` y#), I64# (x# `modInt#` y#)) toInteger (I64# x#) = smallInteger x# @@ -907,3 +942,128 @@ range (m,n) = [m..n] unsafeIndex (m,_) i = fromIntegral i - fromIntegral m inRange (m,n) i = m <= i && i <= n + + +{- +Note [Order of tests] + +Suppose we had a definition like: + + quot x y + | y == 0 = divZeroError + | x == minBound && y == (-1) = overflowError + | otherwise = x `primQuot` y + +Note in particular that the + x == minBound +test comes before the + y == (-1) +test. + +this expands to something like: + + case y of + 0 -> divZeroError + _ -> case x of + -9223372036854775808 -> + case y of + -1 -> overflowError + _ -> x `primQuot` y + _ -> x `primQuot` y + +Now if we have the call (x `quot` 2), and quot gets inlined, then we get: + + case 2 of + 0 -> divZeroError + _ -> case x of + -9223372036854775808 -> + case 2 of + -1 -> overflowError + _ -> x `primQuot` 2 + _ -> x `primQuot` 2 + +which simplifies to: + + case x of + -9223372036854775808 -> x `primQuot` 2 + _ -> x `primQuot` 2 + +Now we have a case with two identical branches, which would be +eliminated (assuming it doesn't affect strictness, which it doesn't in +this case), leaving the desired: + + x `primQuot` 2 + +except in the minBound branch we know what x is, and GHC cleverly does +the division at compile time, giving: + + case x of + -9223372036854775808 -> -4611686018427387904 + _ -> x `primQuot` 2 + +So instead we use a definition like: + + quot x y + | y == 0 = divZeroError + | y == (-1) && x == minBound = overflowError + | otherwise = x `primQuot` y + +which gives us: + + case y of + 0 -> divZeroError + -1 -> + case x of + -9223372036854775808 -> overflowError + _ -> x `primQuot` y + _ -> x `primQuot` y + +for which our call (x `quot` 2) expands to: + + case 2 of + 0 -> divZeroError + -1 -> + case x of + -9223372036854775808 -> overflowError + _ -> x `primQuot` 2 + _ -> x `primQuot` 2 + +which simplifies to: + + x `primQuot` 2 + +as required. + + + +But we now have the same problem with a constant numerator: the call +(2 `quot` y) expands to + + case y of + 0 -> divZeroError + -1 -> + case 2 of + -9223372036854775808 -> overflowError + _ -> 2 `primQuot` y + _ -> 2 `primQuot` y + +which simplifies to: + + case y of + 0 -> divZeroError + -1 -> 2 `primQuot` y + _ -> 2 `primQuot` y + +which simplifies to: + + case y of + 0 -> divZeroError + -1 -> -2 + _ -> 2 `primQuot` y + + +However, constant denominators are more common than constant numerators, +so the + y == (-1) && x == minBound +order gives us better code in the common case. +-} diff -Nru ghc-7.0.3/libraries/base/GHC/IO/BufferedIO.hs ghc-7.2.1/libraries/base/GHC/IO/BufferedIO.hs --- ghc-7.0.3/libraries/base/GHC/IO/BufferedIO.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/IO/BufferedIO.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,7 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude -funbox-strict-fields #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -funbox-strict-fields #-} + ----------------------------------------------------------------------------- -- | -- Module : GHC.IO.BufferedIO @@ -14,16 +17,15 @@ ----------------------------------------------------------------------------- module GHC.IO.BufferedIO ( - BufferedIO(..), - readBuf, readBufNonBlocking, writeBuf, writeBufNonBlocking - ) where + BufferedIO(..), + readBuf, readBufNonBlocking, writeBuf, writeBufNonBlocking + ) where import GHC.Base import GHC.Ptr import Data.Word import GHC.Num import Data.Maybe --- import GHC.IO import GHC.IO.Device as IODevice import GHC.IO.Device as RawIO import GHC.IO.Buffer diff -Nru ghc-7.0.3/libraries/base/GHC/IO/Buffer.hs ghc-7.2.1/libraries/base/GHC/IO/Buffer.hs --- ghc-7.0.3/libraries/base/GHC/IO/Buffer.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/IO/Buffer.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,7 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude -funbox-strict-fields #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude, ForeignFunctionInterface #-} +{-# OPTIONS_GHC -funbox-strict-fields #-} + ----------------------------------------------------------------------------- -- | -- Module : GHC.IO.Buffer diff -Nru ghc-7.0.3/libraries/base/GHC/IO/Device.hs ghc-7.2.1/libraries/base/GHC/IO/Device.hs --- ghc-7.0.3/libraries/base/GHC/IO/Device.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/IO/Device.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,6 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude -XBangPatterns #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude, BangPatterns #-} + ----------------------------------------------------------------------------- -- | -- Module : GHC.IO.Device @@ -14,11 +16,11 @@ ----------------------------------------------------------------------------- module GHC.IO.Device ( - RawIO(..), - IODevice(..), - IODeviceType(..), - SeekMode(..) - ) where + RawIO(..), + IODevice(..), + IODeviceType(..), + SeekMode(..) + ) where #ifdef __GLASGOW_HASKELL__ import GHC.Base diff -Nru ghc-7.0.3/libraries/base/GHC/IO/Encoding/CodePage/Table.hs ghc-7.2.1/libraries/base/GHC/IO/Encoding/CodePage/Table.hs --- ghc-7.0.3/libraries/base/GHC/IO/Encoding/CodePage/Table.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/IO/Encoding/CodePage/Table.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,6 +1,9 @@ -{-# LANGUAGE MagicHash #-} +{-# LANGUAGE CPP, MagicHash, NoImplicitPrelude #-} -- Do not edit this file directly! --- It was generated by the MakeTable.hs script using the following files: +-- It was generated by the MakeTable.hs script using the files below. +-- To regenerate it, run "make" in ../../../../codepages/ +-- +-- Files: -- CP037.TXT -- CP1026.TXT -- CP1250.TXT @@ -35,7 +38,6 @@ import GHC.Prim import GHC.Base import GHC.Word -import GHC.Num data ConvArray a = ConvArray Addr# data CompactArray a b = CompactArray { encoderMax :: !a, diff -Nru ghc-7.0.3/libraries/base/GHC/IO/Encoding/CodePage.hs ghc-7.2.1/libraries/base/GHC/IO/Encoding/CodePage.hs --- ghc-7.0.3/libraries/base/GHC/IO/Encoding/CodePage.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/IO/Encoding/CodePage.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,10 +1,12 @@ -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, BangPatterns, ForeignFunctionInterface, NoImplicitPrelude, + NondecreasingIndentation, MagicHash #-} module GHC.IO.Encoding.CodePage( #if !defined(mingw32_HOST_OS) ) where #else - codePageEncoding, - localeEncoding + codePageEncoding, mkCodePageEncoding, + localeEncoding, mkLocaleEncoding ) where import GHC.Base @@ -13,19 +15,19 @@ import GHC.Enum import GHC.Word import GHC.IO (unsafePerformIO) +import GHC.IO.Encoding.Failure import GHC.IO.Encoding.Types import GHC.IO.Buffer -import GHC.IO.Exception import Data.Bits import Data.Maybe import Data.List (lookup) import GHC.IO.Encoding.CodePage.Table -import GHC.IO.Encoding.Latin1 (latin1) -import GHC.IO.Encoding.UTF8 (utf8) -import GHC.IO.Encoding.UTF16 (utf16le, utf16be) -import GHC.IO.Encoding.UTF32 (utf32le, utf32be) +import GHC.IO.Encoding.Latin1 (mkLatin1) +import GHC.IO.Encoding.UTF8 (mkUTF8) +import GHC.IO.Encoding.UTF16 (mkUTF16le, mkUTF16be) +import GHC.IO.Encoding.UTF32 (mkUTF32le, mkUTF32be) -- note CodePage = UInt which might not work on Win64. But the Win32 package -- also has this issue. @@ -43,43 +45,59 @@ foreign import stdcall unsafe "windows.h GetACP" getACP :: IO Word32 -{-# NOINLINE localeEncoding #-} +{-# NOINLINE currentCodePage #-} +currentCodePage :: Word32 +currentCodePage = unsafePerformIO getCurrentCodePage + localeEncoding :: TextEncoding -localeEncoding = unsafePerformIO $ fmap codePageEncoding getCurrentCodePage - +localeEncoding = mkLocaleEncoding ErrorOnCodingFailure + +mkLocaleEncoding :: CodingFailureMode -> TextEncoding +mkLocaleEncoding cfm = mkCodePageEncoding cfm currentCodePage + codePageEncoding :: Word32 -> TextEncoding -codePageEncoding 65001 = utf8 -codePageEncoding 1200 = utf16le -codePageEncoding 1201 = utf16be -codePageEncoding 12000 = utf32le -codePageEncoding 12001 = utf32be -codePageEncoding cp = maybe latin1 (buildEncoding cp) (lookup cp codePageMap) +codePageEncoding = mkCodePageEncoding ErrorOnCodingFailure -buildEncoding :: Word32 -> CodePageArrays -> TextEncoding -buildEncoding cp SingleByteCP {decoderArray = dec, encoderArray = enc} +mkCodePageEncoding :: CodingFailureMode -> Word32 -> TextEncoding +mkCodePageEncoding cfm 65001 = mkUTF8 cfm +mkCodePageEncoding cfm 1200 = mkUTF16le cfm +mkCodePageEncoding cfm 1201 = mkUTF16be cfm +mkCodePageEncoding cfm 12000 = mkUTF32le cfm +mkCodePageEncoding cfm 12001 = mkUTF32be cfm +mkCodePageEncoding cfm cp = maybe (mkLatin1 cfm) (buildEncoding cfm cp) (lookup cp codePageMap) + +buildEncoding :: CodingFailureMode -> Word32 -> CodePageArrays -> TextEncoding +buildEncoding cfm cp SingleByteCP {decoderArray = dec, encoderArray = enc} = TextEncoding { - textEncodingName = "CP" ++ show cp, - mkTextDecoder = return $ simpleCodec - $ decodeFromSingleByte dec - , mkTextEncoder = return $ simpleCodec $ encodeToSingleByte enc + textEncodingName = "CP" ++ show cp + , mkTextDecoder = return $ simpleCodec (recoverDecode cfm) $ decodeFromSingleByte dec + , mkTextEncoder = return $ simpleCodec (recoverEncode cfm) $ encodeToSingleByte enc } simpleCodec :: (Buffer from -> Buffer to -> IO (Buffer from, Buffer to)) + -> (Buffer from -> Buffer to -> IO (CodingProgress, Buffer from, Buffer to)) -> BufferCodec from to () -simpleCodec f = BufferCodec {encode = f, close = return (), getState = return (), - setState = return } +simpleCodec r f = BufferCodec { + encode = f, + recover = r, + close = return (), + getState = return (), + setState = return + } decodeFromSingleByte :: ConvArray Char -> DecodeBuffer decodeFromSingleByte convArr input@Buffer { bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } output@Buffer { bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } = let - done !ir !ow = return (if ir==iw then input{ bufL=0, bufR=0} - else input{ bufL=ir}, - output {bufR=ow}) + done why !ir !ow = return (why, + if ir==iw then input{ bufL=0, bufR=0} + else input{ bufL=ir}, + output {bufR=ow}) loop !ir !ow - | ow >= os || ir >= iw = done ir ow + | ow >= os = done OutputUnderflow ir ow + | ir >= iw = done InputUnderflow ir ow | otherwise = do b <- readWord8Buf iraw ir let c = lookupConv convArr b @@ -87,7 +105,7 @@ ow' <- writeCharBuf oraw ow c loop (ir+1) ow' where - invalid = if ir > ir0 then done ir ow else ioe_decodingError + invalid = done InvalidSequence ir ow in loop ir0 ow0 encodeToSingleByte :: CompactArray Char Word8 -> EncodeBuffer @@ -97,11 +115,13 @@ input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } = let - done !ir !ow = return (if ir==iw then input { bufL=0, bufR=0 } - else input { bufL=ir }, - output {bufR=ow}) + done why !ir !ow = return (why, + if ir==iw then input { bufL=0, bufR=0 } + else input { bufL=ir }, + output {bufR=ow}) loop !ir !ow - | ow >= os || ir >= iw = done ir ow + | ow >= os = done OutputUnderflow ir ow + | ir >= iw = done InputUnderflow ir ow | otherwise = do (c,ir') <- readCharBuf iraw ir case lookupCompact maxChar indices values c of @@ -111,20 +131,10 @@ writeWord8Buf oraw ow b loop ir' (ow+1) where - invalid = if ir > ir0 then done ir ow else ioe_encodingError + invalid = done InvalidSequence ir ow in loop ir0 ow0 -ioe_decodingError :: IO a -ioe_decodingError = ioException - (IOError Nothing InvalidArgument "codePageEncoding" - "invalid code page byte sequence" Nothing Nothing) - -ioe_encodingError :: IO a -ioe_encodingError = ioException - (IOError Nothing InvalidArgument "codePageEncoding" - "character is not in the code page" Nothing Nothing) - -------------------------------------------- -- Array access functions diff -Nru ghc-7.0.3/libraries/base/GHC/IO/Encoding/Failure.hs ghc-7.2.1/libraries/base/GHC/IO/Encoding/Failure.hs --- ghc-7.0.3/libraries/base/GHC/IO/Encoding/Failure.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/IO/Encoding/Failure.hs 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,174 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude, PatternGuards #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.IO.Encoding.Failure +-- Copyright : (c) The University of Glasgow, 2008-2011 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- Types for specifying how text encoding/decoding fails +-- +----------------------------------------------------------------------------- + +module GHC.IO.Encoding.Failure ( + CodingFailureMode(..), codingFailureModeSuffix, + isSurrogate, + surrogatifyRoundtripCharacter, desurrogatifyRoundtripCharacter, + recoverDecode, recoverEncode + ) where + +import GHC.IO +import GHC.IO.Buffer +import GHC.IO.Exception + +import GHC.Base +import GHC.Word +import GHC.Show +import GHC.Num +import GHC.Real ( fromIntegral ) + +--import System.Posix.Internals + +import Data.Maybe + +-- | The 'CodingFailureMode' is used to construct 'TextEncoding's, and specifies +-- how they handle illegal sequences. +data CodingFailureMode = ErrorOnCodingFailure -- ^ Throw an error when an illegal sequence is encountered + | IgnoreCodingFailure -- ^ Attempt to ignore and recover if an illegal sequence is encountered + | TransliterateCodingFailure -- ^ Replace with the closest visual match upon an illegal sequence + | RoundtripFailure -- ^ Use the private-use escape mechanism to attempt to allow illegal sequences to be roundtripped. + deriving (Show) -- This will only work properly for those encodings which are strict supersets of ASCII in the sense + -- that valid ASCII data is also valid in that encoding. This is not true for e.g. UTF-16, because + -- ASCII characters must be padded to two bytes to retain their meaning. + +-- Note [Roundtripping] +-- ~~~~~~~~~~~~~~~~~~~~ +-- +-- Roundtripping is based on the ideas of PEP383. However, unlike PEP383 we do not wish to use lone surrogate codepoints +-- to escape undecodable bytes, because that may confuse Unicode processing software written in Haskell. Instead, we use +-- the range of private-use characters from 0xEF80 to 0xEFFF designated for "encoding hacks" by the ConScript Unicode Registery. +-- +-- This introduces a technical problem when it comes to encoding back to bytes using iconv. The iconv code will not fail when +-- it tries to encode a private-use character (as it would if trying to encode a surrogate), which means that we won't get a +-- chance to replace it with the byte we originally escaped. +-- +-- To work around this, when filling the buffer to be encoded (in writeBlocks/withEncodedCString/newEncodedCString), we replace +-- the private-use characters with lone surrogates again! Likewise, when reading from a buffer (unpack/unpack_nl/peekEncodedCString) +-- we have to do the inverse process. +-- +-- The user of String should never see these lone surrogates, but it ensures that iconv will throw an error when encountering them. +-- We use lone surrogates in the range 0xDC00 to 0xDCFF for this purpose. + +codingFailureModeSuffix :: CodingFailureMode -> String +codingFailureModeSuffix ErrorOnCodingFailure = "" +codingFailureModeSuffix IgnoreCodingFailure = "//IGNORE" +codingFailureModeSuffix TransliterateCodingFailure = "//TRANSLIT" +codingFailureModeSuffix RoundtripFailure = "//ROUNDTRIP" + +-- | In transliterate mode, we use this character when decoding unknown bytes. +-- +-- This is the defined Unicode replacement character: +unrepresentableChar :: Char +unrepresentableChar = '\xFFFD' + +-- | Some characters are actually "surrogate" codepoints defined for use in UTF-16. We need to signal an +-- invalid character if we detect them when encoding a sequence of 'Char's into 'Word8's because they won't +-- give valid Unicode. +-- +-- We may also need to signal an invalid character if we detect them when encoding a sequence of 'Char's into 'Word8's +-- because the 'RoundtripFailure' mode creates these to round-trip bytes through our internal UTF-16 encoding. +isSurrogate :: Char -> Bool +isSurrogate c = (0xD800 <= x && x <= 0xDBFF) || (0xDC00 <= x && x <= 0xDFFF) + where x = ord c + +-- | We use some private-use characters for roundtripping unknown bytes through a String +isRoundtripEscapeChar :: Char -> Bool +isRoundtripEscapeChar c = 0xEF00 <= x && x < 0xF000 + where x = ord c + +-- | We use some surrogate characters for roundtripping unknown bytes through a String +isRoundtripEscapeSurrogateChar :: Char -> Bool +isRoundtripEscapeSurrogateChar c = 0xDC00 <= x && x < 0xDD00 + where x = ord c + +-- Private use characters (in Strings) --> lone surrogates (in Buffer CharBufElem) +surrogatifyRoundtripCharacter :: Char -> Char +surrogatifyRoundtripCharacter c | isRoundtripEscapeChar c = chr (ord c - 0xEF00 + 0xDC00) + | otherwise = c + +-- Lone surrogates (in Buffer CharBufElem) --> private use characters (in Strings) +desurrogatifyRoundtripCharacter :: Char -> Char +desurrogatifyRoundtripCharacter c | isRoundtripEscapeSurrogateChar c = chr (ord c - 0xDC00 + 0xEF00) + | otherwise = c + +-- Bytes (in Buffer Word8) --> lone surrogates (in Buffer CharBufElem) +escapeToRoundtripCharacterSurrogate :: Word8 -> Char +escapeToRoundtripCharacterSurrogate b + | b < 128 = chr (fromIntegral b) -- Disallow 'smuggling' of ASCII bytes. For roundtripping to work, this assumes encoding is ASCII-superset. + | otherwise = chr (0xDC00 + fromIntegral b) + +-- Lone surrogates (in Buffer CharBufElem) --> bytes (in Buffer Word8) +unescapeRoundtripCharacterSurrogate :: Char -> Maybe Word8 +unescapeRoundtripCharacterSurrogate c + | 0xDC80 <= x && x < 0xDD00 = Just (fromIntegral x) -- Discard high byte + | otherwise = Nothing + where x = ord c + +recoverDecode :: CodingFailureMode -> Buffer Word8 -> Buffer Char -> IO (Buffer Word8, Buffer Char) +recoverDecode cfm input@Buffer{ bufRaw=iraw, bufL=ir, bufR=_ } + output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow } = do + --puts $ "recoverDecode " ++ show ir + case cfm of + ErrorOnCodingFailure -> ioe_decodingError + IgnoreCodingFailure -> return (input { bufL=ir+1 }, output) + TransliterateCodingFailure -> do + ow' <- writeCharBuf oraw ow unrepresentableChar + return (input { bufL=ir+1 }, output { bufR=ow' }) + RoundtripFailure -> do + b <- readWord8Buf iraw ir + ow' <- writeCharBuf oraw ow (escapeToRoundtripCharacterSurrogate b) + return (input { bufL=ir+1 }, output { bufR=ow' }) + +recoverEncode :: CodingFailureMode -> Buffer Char -> Buffer Word8 -> IO (Buffer Char, Buffer Word8) +recoverEncode cfm input@Buffer{ bufRaw=iraw, bufL=ir, bufR=_ } + output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow } = do + (c,ir') <- readCharBuf iraw ir + --puts $ "recoverEncode " ++ show ir ++ " " ++ show ir' + case cfm of + IgnoreCodingFailure -> return (input { bufL=ir' }, output) + TransliterateCodingFailure -> do + if c == '?' + then return (input { bufL=ir' }, output) + else do + -- XXX: evil hack! To implement transliteration, we just poke an + -- ASCII ? into the input buffer and tell the caller to try and decode + -- again. This is *probably* safe given current uses of TextEncoding. + -- + -- The "if" test above ensures we skip if the encoding fails to deal with + -- the ?, though this should never happen in practice as all encodings are + -- in fact capable of reperesenting all ASCII characters. + _ir' <- writeCharBuf iraw ir '?' + return (input, output) + + -- This implementation does not work because e.g. UTF-16 requires 2 bytes to + -- encode a simple ASCII value + --writeWord8Buf oraw ow unrepresentableByte + --return (input { bufL=ir' }, output { bufR=ow+1 }) + RoundtripFailure | Just x <- unescapeRoundtripCharacterSurrogate c -> do + writeWord8Buf oraw ow x + return (input { bufL=ir' }, output { bufR=ow+1 }) + _ -> ioe_encodingError + +ioe_decodingError :: IO a +ioe_decodingError = ioException + (IOError Nothing InvalidArgument "recoverDecode" + "invalid byte sequence" Nothing Nothing) + +ioe_encodingError :: IO a +ioe_encodingError = ioException + (IOError Nothing InvalidArgument "recoverEncode" + "invalid character" Nothing Nothing) diff -Nru ghc-7.0.3/libraries/base/GHC/IO/Encoding/Iconv.hs ghc-7.2.1/libraries/base/GHC/IO/Encoding/Iconv.hs --- ghc-7.0.3/libraries/base/GHC/IO/Encoding/Iconv.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/IO/Encoding/Iconv.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,10 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP + , NoImplicitPrelude + , ForeignFunctionInterface + , NondecreasingIndentation + #-} + ----------------------------------------------------------------------------- -- | -- Module : GHC.IO.Encoding.Iconv @@ -16,12 +22,8 @@ -- #hide module GHC.IO.Encoding.Iconv ( #if !defined(mingw32_HOST_OS) - mkTextEncoding, - latin1, - utf8, - utf16, utf16le, utf16be, - utf32, utf32le, utf32be, - localeEncoding + iconvEncoding, mkIconvEncoding, + localeEncoding, mkLocaleEncoding #endif ) where @@ -30,12 +32,14 @@ #if !defined(mingw32_HOST_OS) -import Foreign hiding (unsafePerformIO) +import Foreign.Safe import Foreign.C import Data.Maybe import GHC.Base import GHC.IO.Buffer +import GHC.IO.Encoding.Failure import GHC.IO.Encoding.Types +import GHC.List (span) import GHC.Num import GHC.Show import GHC.Real @@ -50,54 +54,22 @@ | c_DEBUG_DUMP = puts s | otherwise = return () -puts :: String -> IO () -puts s = do _ <- withCStringLen (s ++ "\n") $ \(p, len) -> - c_write 1 (castPtr p) (fromIntegral len) - return () - -- ----------------------------------------------------------------------------- -- iconv encoders/decoders -{-# NOINLINE latin1 #-} -latin1 :: TextEncoding -latin1 = unsafePerformIO (mkTextEncoding "Latin1") - -{-# NOINLINE utf8 #-} -utf8 :: TextEncoding -utf8 = unsafePerformIO (mkTextEncoding "UTF8") - -{-# NOINLINE utf16 #-} -utf16 :: TextEncoding -utf16 = unsafePerformIO (mkTextEncoding "UTF16") - -{-# NOINLINE utf16le #-} -utf16le :: TextEncoding -utf16le = unsafePerformIO (mkTextEncoding "UTF16LE") - -{-# NOINLINE utf16be #-} -utf16be :: TextEncoding -utf16be = unsafePerformIO (mkTextEncoding "UTF16BE") - -{-# NOINLINE utf32 #-} -utf32 :: TextEncoding -utf32 = unsafePerformIO (mkTextEncoding "UTF32") - -{-# NOINLINE utf32le #-} -utf32le :: TextEncoding -utf32le = unsafePerformIO (mkTextEncoding "UTF32LE") - -{-# NOINLINE utf32be #-} -utf32be :: TextEncoding -utf32be = unsafePerformIO (mkTextEncoding "UTF32BE") - -{-# NOINLINE localeEncoding #-} -localeEncoding :: TextEncoding -localeEncoding = unsafePerformIO $ do +{-# NOINLINE localeEncodingName #-} +localeEncodingName :: String +localeEncodingName = unsafePerformIO $ do -- Use locale_charset() or nl_langinfo(CODESET) to get the encoding -- if we have either of them. cstr <- c_localeEncoding - r <- peekCString cstr - mkTextEncoding r + peekCAString cstr -- Assume charset names are ASCII + +localeEncoding :: TextEncoding +localeEncoding = mkLocaleEncoding ErrorOnCodingFailure + +mkLocaleEncoding :: CodingFailureMode -> TextEncoding +mkLocaleEncoding cfm = unsafePerformIO $ mkIconvEncoding cfm localeEncodingName -- We hope iconv_t is a storable type. It should be, since it has at least the -- value -1, which is a possible return value from iconv_open. @@ -129,39 +101,47 @@ char_shift | charSize == 2 = 1 | otherwise = 2 -mkTextEncoding :: String -> IO TextEncoding -mkTextEncoding charset = do +iconvEncoding :: String -> IO TextEncoding +iconvEncoding = mkIconvEncoding ErrorOnCodingFailure + +mkIconvEncoding :: CodingFailureMode -> String -> IO TextEncoding +mkIconvEncoding cfm charset = do return (TextEncoding { textEncodingName = charset, - mkTextDecoder = newIConv charset haskellChar iconvDecode, - mkTextEncoder = newIConv haskellChar charset iconvEncode}) + mkTextDecoder = newIConv raw_charset (haskellChar ++ suffix) (recoverDecode cfm) iconvDecode, + mkTextEncoder = newIConv haskellChar charset (recoverEncode cfm) iconvEncode}) + where + -- An annoying feature of GNU iconv is that the //PREFIXES only take + -- effect when they appear on the tocode parameter to iconv_open: + (raw_charset, suffix) = span (/= '/') charset newIConv :: String -> String - -> (IConv -> Buffer a -> Buffer b -> IO (Buffer a, Buffer b)) + -> (Buffer a -> Buffer b -> IO (Buffer a, Buffer b)) + -> (IConv -> Buffer a -> Buffer b -> IO (CodingProgress, Buffer a, Buffer b)) -> IO (BufferCodec a b ()) -newIConv from to fn = - withCString from $ \ from_str -> - withCString to $ \ to_str -> do +newIConv from to rec fn = + -- Assume charset names are ASCII + withCAString from $ \ from_str -> + withCAString to $ \ to_str -> do iconvt <- throwErrnoIfMinus1 "mkTextEncoding" $ hs_iconv_open to_str from_str let iclose = throwErrnoIfMinus1_ "Iconv.close" $ hs_iconv_close iconvt return BufferCodec{ encode = fn iconvt, + recover = rec, close = iclose, -- iconv doesn't supply a way to save/restore the state getState = return (), setState = const $ return () } -iconvDecode :: IConv -> Buffer Word8 -> Buffer CharBufElem - -> IO (Buffer Word8, Buffer CharBufElem) +iconvDecode :: IConv -> DecodeBuffer iconvDecode iconv_t ibuf obuf = iconvRecode iconv_t ibuf 0 obuf char_shift -iconvEncode :: IConv -> Buffer CharBufElem -> Buffer Word8 - -> IO (Buffer CharBufElem, Buffer Word8) +iconvEncode :: IConv -> EncodeBuffer iconvEncode iconv_t ibuf obuf = iconvRecode iconv_t ibuf char_shift obuf 0 iconvRecode :: IConv -> Buffer a -> Int -> Buffer b -> Int - -> IO (Buffer a, Buffer b) + -> IO (CodingProgress, Buffer a, Buffer b) iconvRecode iconv_t input@Buffer{ bufRaw=iraw, bufL=ir, bufR=iw, bufSize=_ } iscale output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow, bufSize=os } oscale @@ -190,29 +170,23 @@ iconv_trace ("iconvRecode after, output=" ++ show (summaryBuffer new_output)) if (res /= -1) then do -- all input translated - return (new_input, new_output) + return (InputUnderflow, new_input, new_output) else do errno <- getErrno case errno of - e | e == eINVAL || e == e2BIG - || e == eILSEQ && new_inleft' /= (iw-ir) -> do - iconv_trace ("iconv ignoring error: " ++ show (errnoToIOError "iconv" e Nothing Nothing)) - -- Output overflow is harmless - -- - -- Similarly, we ignore EILSEQ unless we converted no - -- characters. Sometimes iconv reports EILSEQ for a - -- character in the input even when there is no room - -- in the output; in this case we might be about to - -- change the encoding anyway, so the following bytes - -- could very well be in a different encoding. - -- This also helps with pinpointing EILSEQ errors: we - -- don't report it until the rest of the characters in - -- the buffer have been drained. - return (new_input, new_output) - - e -> do - iconv_trace ("iconv returned error: " ++ show (errnoToIOError "iconv" e Nothing Nothing)) - throwErrno "iconvRecoder" - -- illegal sequence, or some other error + e | e == e2BIG -> return (OutputUnderflow, new_input, new_output) + | e == eINVAL -> return (InputUnderflow, new_input, new_output) + -- Sometimes iconv reports EILSEQ for a + -- character in the input even when there is no room + -- in the output; in this case we might be about to + -- change the encoding anyway, so the following bytes + -- could very well be in a different encoding. + -- + -- Because we can only say InvalidSequence if there is at least + -- one element left in the output, we have to special case this. + | e == eILSEQ -> return (if new_outleft' == 0 then OutputUnderflow else InvalidSequence, new_input, new_output) + | otherwise -> do + iconv_trace ("iconv returned error: " ++ show (errnoToIOError "iconv" e Nothing Nothing)) + throwErrno "iconvRecoder" #endif /* !mingw32_HOST_OS */ diff -Nru ghc-7.0.3/libraries/base/GHC/IO/Encoding/Latin1.hs ghc-7.2.1/libraries/base/GHC/IO/Encoding/Latin1.hs --- ghc-7.0.3/libraries/base/GHC/IO/Encoding/Latin1.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/IO/Encoding/Latin1.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,5 +1,10 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude -funbox-strict-fields #-} -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude + , BangPatterns + , NondecreasingIndentation + #-} +{-# OPTIONS_GHC -funbox-strict-fields #-} + ----------------------------------------------------------------------------- -- | -- Module : GHC.IO.Encoding.Latin1 @@ -19,8 +24,8 @@ ----------------------------------------------------------------------------- module GHC.IO.Encoding.Latin1 ( - latin1, - latin1_checked, + latin1, mkLatin1, + latin1_checked, mkLatin1_checked, latin1_decode, latin1_encode, latin1_checked_encode, @@ -30,46 +35,54 @@ import GHC.Real import GHC.Num -- import GHC.IO -import GHC.IO.Exception import GHC.IO.Buffer +import GHC.IO.Encoding.Failure import GHC.IO.Encoding.Types -import Data.Maybe -- ----------------------------------------------------------------------------- -- Latin1 latin1 :: TextEncoding -latin1 = TextEncoding { textEncodingName = "ISO8859-1", - mkTextDecoder = latin1_DF, - mkTextEncoder = latin1_EF } +latin1 = mkLatin1 ErrorOnCodingFailure + +mkLatin1 :: CodingFailureMode -> TextEncoding +mkLatin1 cfm = TextEncoding { textEncodingName = "ISO8859-1", + mkTextDecoder = latin1_DF cfm, + mkTextEncoder = latin1_EF cfm } -latin1_DF :: IO (TextDecoder ()) -latin1_DF = +latin1_DF :: CodingFailureMode -> IO (TextDecoder ()) +latin1_DF cfm = return (BufferCodec { encode = latin1_decode, + recover = recoverDecode cfm, close = return (), getState = return (), setState = const $ return () }) -latin1_EF :: IO (TextEncoder ()) -latin1_EF = +latin1_EF :: CodingFailureMode -> IO (TextEncoder ()) +latin1_EF cfm = return (BufferCodec { encode = latin1_encode, + recover = recoverEncode cfm, close = return (), getState = return (), setState = const $ return () }) latin1_checked :: TextEncoding -latin1_checked = TextEncoding { textEncodingName = "ISO8859-1(checked)", - mkTextDecoder = latin1_DF, - mkTextEncoder = latin1_checked_EF } +latin1_checked = mkLatin1_checked ErrorOnCodingFailure -latin1_checked_EF :: IO (TextEncoder ()) -latin1_checked_EF = +mkLatin1_checked :: CodingFailureMode -> TextEncoding +mkLatin1_checked cfm = TextEncoding { textEncodingName = "ISO8859-1(checked)", + mkTextDecoder = latin1_DF cfm, + mkTextEncoder = latin1_checked_EF cfm } + +latin1_checked_EF :: CodingFailureMode -> IO (TextEncoder ()) +latin1_checked_EF cfm = return (BufferCodec { encode = latin1_checked_encode, + recover = recoverEncode cfm, close = return (), getState = return (), setState = const $ return () @@ -82,16 +95,18 @@ output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } = let loop !ir !ow - | ow >= os || ir >= iw = done ir ow + | ow >= os = done OutputUnderflow ir ow + | ir >= iw = done InputUnderflow ir ow | otherwise = do c0 <- readWord8Buf iraw ir ow' <- writeCharBuf oraw ow (unsafeChr (fromIntegral c0)) loop (ir+1) ow' -- lambda-lifted, to avoid thunks being built in the inner-loop: - done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 } - else input{ bufL=ir }, - output{ bufR=ow }) + done why !ir !ow = return (why, + if ir == iw then input{ bufL=0, bufR=0 } + else input{ bufL=ir }, + output{ bufR=ow }) in loop ir0 ow0 @@ -100,11 +115,13 @@ input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } = let - done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 } - else input{ bufL=ir }, - output{ bufR=ow }) + done why !ir !ow = return (why, + if ir == iw then input{ bufL=0, bufR=0 } + else input{ bufL=ir }, + output{ bufR=ow }) loop !ir !ow - | ow >= os || ir >= iw = done ir ow + | ow >= os = done OutputUnderflow ir ow + | ir >= iw = done InputUnderflow ir ow | otherwise = do (c,ir') <- readCharBuf iraw ir writeWord8Buf oraw ow (fromIntegral (ord c)) @@ -117,22 +134,19 @@ input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } = let - done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 } - else input{ bufL=ir }, - output{ bufR=ow }) + done why !ir !ow = return (why, + if ir == iw then input{ bufL=0, bufR=0 } + else input{ bufL=ir }, + output{ bufR=ow }) loop !ir !ow - | ow >= os || ir >= iw = done ir ow + | ow >= os = done OutputUnderflow ir ow + | ir >= iw = done InputUnderflow ir ow | otherwise = do (c,ir') <- readCharBuf iraw ir if ord c > 0xff then invalid else do writeWord8Buf oraw ow (fromIntegral (ord c)) loop ir' (ow+1) where - invalid = if ir > ir0 then done ir ow else ioe_encodingError + invalid = done InvalidSequence ir ow in loop ir0 ow0 - -ioe_encodingError :: IO a -ioe_encodingError = ioException - (IOError Nothing InvalidArgument "latin1_checked_encode" - "character is out of range for this encoding" Nothing Nothing) diff -Nru ghc-7.0.3/libraries/base/GHC/IO/Encoding/Types.hs ghc-7.2.1/libraries/base/GHC/IO/Encoding/Types.hs --- ghc-7.0.3/libraries/base/GHC/IO/Encoding/Types.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/IO/Encoding/Types.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,7 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude -funbox-strict-fields #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude, ExistentialQuantification #-} +{-# OPTIONS_GHC -funbox-strict-fields #-} + ----------------------------------------------------------------------------- -- | -- Module : GHC.IO.Encoding.Types @@ -18,6 +21,7 @@ TextEncoding(..), TextEncoder, TextDecoder, EncodeBuffer, DecodeBuffer, + CodingProgress(..) ) where import GHC.Base @@ -30,22 +34,41 @@ -- Text encoders/decoders data BufferCodec from to state = BufferCodec { - encode :: Buffer from -> Buffer to -> IO (Buffer from, Buffer to), + encode :: Buffer from -> Buffer to -> IO (CodingProgress, Buffer from, Buffer to), -- ^ The @encode@ function translates elements of the buffer @from@ -- to the buffer @to@. It should translate as many elements as possible -- given the sizes of the buffers, including translating zero elements -- if there is either not enough room in @to@, or @from@ does not -- contain a complete multibyte sequence. - -- - -- @encode@ should raise an exception if, and only if, @from@ - -- begins with an illegal sequence, or the first element of @from@ - -- is not representable in the encoding of @to@. That is, if any - -- elements can be successfully translated before an error is - -- encountered, then @encode@ should translate as much as it can - -- and not throw an exception. This behaviour is used by the IO + -- + -- The fact that as many elements as possible are translated is used by the IO -- library in order to report translation errors at the point they -- actually occur, rather than when the buffer is translated. -- + -- To allow us to use iconv as a BufferCode efficiently, character buffers are + -- defined to contain lone surrogates instead of those private use characters that + -- are used for roundtripping. Thus, Chars poked and peeked from a character buffer + -- must undergo surrogatifyRoundtripCharacter and desurrogatifyRoundtripCharacter + -- respectively. + -- + -- For more information on this, see Note [Roundtripping] in GHC.IO.Encoding.Failure. + + recover :: Buffer from -> Buffer to -> IO (Buffer from, Buffer to), + -- ^ The @recover@ function is used to continue decoding + -- in the presence of invalid or unrepresentable sequences. This includes + -- both those detected by @encode@ returning @InvalidSequence@ and those + -- that occur because the input byte sequence appears to be truncated. + -- + -- Progress will usually be made by skipping the first element of the @from@ + -- buffer. This function should only be called if you are certain that you + -- wish to do this skipping, and if the @to@ buffer has at least one element + -- of free space. + -- + -- @recover@ may raise an exception rather than skipping anything. + -- + -- Currently, some implementations of @recover@ may mutate the input buffer. + -- In particular, this feature is used to implement transliteration. + close :: IO (), -- ^ Resources associated with the encoding may now be released. -- The @encode@ function may not be called again after calling @@ -64,16 +87,16 @@ -- beginning), and if not, whether to use the big or little-endian -- encoding. - setState :: state -> IO() + setState :: state -> IO () -- restore the state of the codec using the state from a previous -- call to 'getState'. } type DecodeBuffer = Buffer Word8 -> Buffer Char - -> IO (Buffer Word8, Buffer Char) + -> IO (CodingProgress, Buffer Word8, Buffer Char) type EncodeBuffer = Buffer Char -> Buffer Word8 - -> IO (Buffer Char, Buffer Word8) + -> IO (CodingProgress, Buffer Char, Buffer Word8) type TextDecoder state = BufferCodec Word8 CharBufElem state type TextEncoder state = BufferCodec CharBufElem Word8 state @@ -88,10 +111,22 @@ textEncodingName :: String, -- ^ a string that can be passed to 'mkTextEncoding' to -- create an equivalent 'TextEncoding'. - mkTextDecoder :: IO (TextDecoder dstate), - mkTextEncoder :: IO (TextEncoder estate) + mkTextDecoder :: IO (TextDecoder dstate), + -- ^ Creates a means of decoding bytes into characters: the result must not + -- be shared between several byte sequences or simultaneously across threads + mkTextEncoder :: IO (TextEncoder estate) + -- ^ Creates a means of encode characters into bytes: the result must not + -- be shared between several character sequences or simultaneously across threads } instance Show TextEncoding where -- | Returns the value of 'textEncodingName' show te = textEncodingName te + +data CodingProgress = InputUnderflow -- ^ Stopped because the input contains insufficient available elements, + -- or all of the input sequence has been sucessfully translated. + | OutputUnderflow -- ^ Stopped because the output contains insufficient free elements + | InvalidSequence -- ^ Stopped because there are sufficient free elements in the output + -- to output at least one encoded ASCII character, but the input contains + -- an invalid or unrepresentable sequence + deriving (Eq, Show) diff -Nru ghc-7.0.3/libraries/base/GHC/IO/Encoding/UTF16.hs ghc-7.2.1/libraries/base/GHC/IO/Encoding/UTF16.hs --- ghc-7.0.3/libraries/base/GHC/IO/Encoding/UTF16.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/IO/Encoding/UTF16.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,5 +1,12 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude -funbox-strict-fields #-} -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP + , NoImplicitPrelude + , BangPatterns + , NondecreasingIndentation + , MagicHash + #-} +{-# OPTIONS_GHC -funbox-strict-fields #-} + ----------------------------------------------------------------------------- -- | -- Module : GHC.IO.Encoding.UTF16 @@ -19,15 +26,15 @@ ----------------------------------------------------------------------------- module GHC.IO.Encoding.UTF16 ( - utf16, + utf16, mkUTF16, utf16_decode, utf16_encode, - utf16be, + utf16be, mkUTF16be, utf16be_decode, utf16be_encode, - utf16le, + utf16le, mkUTF16le, utf16le_decode, utf16le_encode, ) where @@ -36,49 +43,42 @@ import GHC.Real import GHC.Num -- import GHC.IO -import GHC.IO.Exception import GHC.IO.Buffer +import GHC.IO.Encoding.Failure import GHC.IO.Encoding.Types import GHC.Word import Data.Bits import Data.Maybe import GHC.IORef -#if DEBUG -import System.Posix.Internals -import Foreign.C -import GHC.Show -import GHC.Ptr - -puts :: String -> IO () -puts s = do withCStringLen (s++"\n") $ \(p,len) -> - c_write 1 (castPtr p) (fromIntegral len) - return () -#endif - -- ----------------------------------------------------------------------------- -- The UTF-16 codec: either UTF16BE or UTF16LE with a BOM utf16 :: TextEncoding -utf16 = TextEncoding { textEncodingName = "UTF-16", - mkTextDecoder = utf16_DF, - mkTextEncoder = utf16_EF } +utf16 = mkUTF16 ErrorOnCodingFailure + +mkUTF16 :: CodingFailureMode -> TextEncoding +mkUTF16 cfm = TextEncoding { textEncodingName = "UTF-16", + mkTextDecoder = utf16_DF cfm, + mkTextEncoder = utf16_EF cfm } -utf16_DF :: IO (TextDecoder (Maybe DecodeBuffer)) -utf16_DF = do +utf16_DF :: CodingFailureMode -> IO (TextDecoder (Maybe DecodeBuffer)) +utf16_DF cfm = do seen_bom <- newIORef Nothing return (BufferCodec { encode = utf16_decode seen_bom, + recover = recoverDecode cfm, close = return (), getState = readIORef seen_bom, setState = writeIORef seen_bom }) -utf16_EF :: IO (TextEncoder Bool) -utf16_EF = do +utf16_EF :: CodingFailureMode -> IO (TextEncoder Bool) +utf16_EF cfm = do done_bom <- newIORef False return (BufferCodec { encode = utf16_encode done_bom, + recover = recoverEncode cfm, close = return (), getState = readIORef done_bom, setState = writeIORef done_bom @@ -91,7 +91,7 @@ b <- readIORef done_bom if b then utf16_native_encode input output else if os - ow < 2 - then return (input,output) + then return (OutputUnderflow,input,output) else do writeIORef done_bom True writeWord8Buf oraw ow bom1 @@ -107,7 +107,7 @@ case mb of Just decode -> decode input output Nothing -> - if iw - ir < 2 then return (input,output) else do + if iw - ir < 2 then return (InputUnderflow,input,output) else do c0 <- readWord8Buf iraw ir c1 <- readWord8Buf iraw (ir+1) case () of @@ -140,46 +140,56 @@ -- UTF16LE and UTF16BE utf16be :: TextEncoding -utf16be = TextEncoding { textEncodingName = "UTF-16BE", - mkTextDecoder = utf16be_DF, - mkTextEncoder = utf16be_EF } +utf16be = mkUTF16be ErrorOnCodingFailure -utf16be_DF :: IO (TextDecoder ()) -utf16be_DF = +mkUTF16be :: CodingFailureMode -> TextEncoding +mkUTF16be cfm = TextEncoding { textEncodingName = "UTF-16BE", + mkTextDecoder = utf16be_DF cfm, + mkTextEncoder = utf16be_EF cfm } + +utf16be_DF :: CodingFailureMode -> IO (TextDecoder ()) +utf16be_DF cfm = return (BufferCodec { encode = utf16be_decode, + recover = recoverDecode cfm, close = return (), getState = return (), setState = const $ return () }) -utf16be_EF :: IO (TextEncoder ()) -utf16be_EF = +utf16be_EF :: CodingFailureMode -> IO (TextEncoder ()) +utf16be_EF cfm = return (BufferCodec { encode = utf16be_encode, + recover = recoverEncode cfm, close = return (), getState = return (), setState = const $ return () }) utf16le :: TextEncoding -utf16le = TextEncoding { textEncodingName = "UTF16-LE", - mkTextDecoder = utf16le_DF, - mkTextEncoder = utf16le_EF } +utf16le = mkUTF16le ErrorOnCodingFailure + +mkUTF16le :: CodingFailureMode -> TextEncoding +mkUTF16le cfm = TextEncoding { textEncodingName = "UTF16-LE", + mkTextDecoder = utf16le_DF cfm, + mkTextEncoder = utf16le_EF cfm } -utf16le_DF :: IO (TextDecoder ()) -utf16le_DF = +utf16le_DF :: CodingFailureMode -> IO (TextDecoder ()) +utf16le_DF cfm = return (BufferCodec { encode = utf16le_decode, + recover = recoverDecode cfm, close = return (), getState = return (), setState = const $ return () }) -utf16le_EF :: IO (TextEncoder ()) -utf16le_EF = +utf16le_EF :: CodingFailureMode -> IO (TextEncoder ()) +utf16le_EF cfm = return (BufferCodec { encode = utf16le_encode, + recover = recoverEncode cfm, close = return (), getState = return (), setState = const $ return () @@ -192,8 +202,9 @@ output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } = let loop !ir !ow - | ow >= os || ir >= iw = done ir ow - | ir + 1 == iw = done ir ow + | ow >= os = done OutputUnderflow ir ow + | ir >= iw = done InputUnderflow ir ow + | ir + 1 == iw = done InputUnderflow ir ow | otherwise = do c0 <- readWord8Buf iraw ir c1 <- readWord8Buf iraw (ir+1) @@ -201,7 +212,7 @@ if validate1 x1 then do ow' <- writeCharBuf oraw ow (unsafeChr (fromIntegral x1)) loop (ir+2) ow' - else if iw - ir < 4 then done ir ow else do + else if iw - ir < 4 then done InputUnderflow ir ow else do c2 <- readWord8Buf iraw (ir+2) c3 <- readWord8Buf iraw (ir+3) let x2 = fromIntegral c2 `shiftL` 8 + fromIntegral c3 @@ -209,12 +220,13 @@ ow' <- writeCharBuf oraw ow (chr2 x1 x2) loop (ir+4) ow' where - invalid = if ir > ir0 then done ir ow else ioe_decodingError + invalid = done InvalidSequence ir ow -- lambda-lifted, to avoid thunks being built in the inner-loop: - done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 } - else input{ bufL=ir }, - output{ bufR=ow }) + done why !ir !ow = return (why, + if ir == iw then input{ bufL=0, bufR=0 } + else input{ bufL=ir }, + output{ bufR=ow }) in loop ir0 ow0 @@ -224,8 +236,9 @@ output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } = let loop !ir !ow - | ow >= os || ir >= iw = done ir ow - | ir + 1 == iw = done ir ow + | ow >= os = done OutputUnderflow ir ow + | ir >= iw = done InputUnderflow ir ow + | ir + 1 == iw = done InputUnderflow ir ow | otherwise = do c0 <- readWord8Buf iraw ir c1 <- readWord8Buf iraw (ir+1) @@ -233,7 +246,7 @@ if validate1 x1 then do ow' <- writeCharBuf oraw ow (unsafeChr (fromIntegral x1)) loop (ir+2) ow' - else if iw - ir < 4 then done ir ow else do + else if iw - ir < 4 then done InputUnderflow ir ow else do c2 <- readWord8Buf iraw (ir+2) c3 <- readWord8Buf iraw (ir+3) let x2 = fromIntegral c3 `shiftL` 8 + fromIntegral c2 @@ -241,40 +254,37 @@ ow' <- writeCharBuf oraw ow (chr2 x1 x2) loop (ir+4) ow' where - invalid = if ir > ir0 then done ir ow else ioe_decodingError + invalid = done InvalidSequence ir ow -- lambda-lifted, to avoid thunks being built in the inner-loop: - done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 } - else input{ bufL=ir }, - output{ bufR=ow }) + done why !ir !ow = return (why, + if ir == iw then input{ bufL=0, bufR=0 } + else input{ bufL=ir }, + output{ bufR=ow }) in loop ir0 ow0 -ioe_decodingError :: IO a -ioe_decodingError = ioException - (IOError Nothing InvalidArgument "utf16_decode" - "invalid UTF-16 byte sequence" Nothing Nothing) - utf16be_encode :: EncodeBuffer utf16be_encode input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } = let - done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 } - else input{ bufL=ir }, - output{ bufR=ow }) + done why !ir !ow = return (why, + if ir == iw then input{ bufL=0, bufR=0 } + else input{ bufL=ir }, + output{ bufR=ow }) loop !ir !ow - | ir >= iw = done ir ow - | os - ow < 2 = done ir ow + | ir >= iw = done InputUnderflow ir ow + | os - ow < 2 = done OutputUnderflow ir ow | otherwise = do (c,ir') <- readCharBuf iraw ir case ord c of - x | x < 0x10000 -> do + x | x < 0x10000 -> if isSurrogate c then done InvalidSequence ir ow else do writeWord8Buf oraw ow (fromIntegral (x `shiftR` 8)) writeWord8Buf oraw (ow+1) (fromIntegral x) loop ir' (ow+2) | otherwise -> do - if os - ow < 4 then done ir ow else do + if os - ow < 4 then done OutputUnderflow ir ow else do let n1 = x - 0x10000 c1 = fromIntegral (n1 `shiftR` 18 + 0xD8) @@ -296,21 +306,22 @@ input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } = let - done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 } - else input{ bufL=ir }, - output{ bufR=ow }) + done why !ir !ow = return (why, + if ir == iw then input{ bufL=0, bufR=0 } + else input{ bufL=ir }, + output{ bufR=ow }) loop !ir !ow - | ir >= iw = done ir ow - | os - ow < 2 = done ir ow + | ir >= iw = done InputUnderflow ir ow + | os - ow < 2 = done OutputUnderflow ir ow | otherwise = do (c,ir') <- readCharBuf iraw ir case ord c of - x | x < 0x10000 -> do + x | x < 0x10000 -> if isSurrogate c then done InvalidSequence ir ow else do writeWord8Buf oraw ow (fromIntegral x) writeWord8Buf oraw (ow+1) (fromIntegral (x `shiftR` 8)) loop ir' (ow+2) | otherwise -> - if os - ow < 4 then done ir ow else do + if os - ow < 4 then done OutputUnderflow ir ow else do let n1 = x - 0x10000 c1 = fromIntegral (n1 `shiftR` 18 + 0xD8) diff -Nru ghc-7.0.3/libraries/base/GHC/IO/Encoding/UTF32.hs ghc-7.2.1/libraries/base/GHC/IO/Encoding/UTF32.hs --- ghc-7.0.3/libraries/base/GHC/IO/Encoding/UTF32.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/IO/Encoding/UTF32.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,5 +1,11 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude -funbox-strict-fields #-} -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude + , BangPatterns + , NondecreasingIndentation + , MagicHash + #-} +{-# OPTIONS_GHC -funbox-strict-fields #-} + ----------------------------------------------------------------------------- -- | -- Module : GHC.IO.Encoding.UTF32 @@ -19,15 +25,15 @@ ----------------------------------------------------------------------------- module GHC.IO.Encoding.UTF32 ( - utf32, + utf32, mkUTF32, utf32_decode, utf32_encode, - utf32be, + utf32be, mkUTF32be, utf32be_decode, utf32be_encode, - utf32le, + utf32le, mkUTF32le, utf32le_decode, utf32le_encode, ) where @@ -36,8 +42,8 @@ import GHC.Real import GHC.Num -- import GHC.IO -import GHC.IO.Exception import GHC.IO.Buffer +import GHC.IO.Encoding.Failure import GHC.IO.Encoding.Types import GHC.Word import Data.Bits @@ -48,25 +54,30 @@ -- The UTF-32 codec: either UTF-32BE or UTF-32LE with a BOM utf32 :: TextEncoding -utf32 = TextEncoding { textEncodingName = "UTF-32", - mkTextDecoder = utf32_DF, - mkTextEncoder = utf32_EF } +utf32 = mkUTF32 ErrorOnCodingFailure + +mkUTF32 :: CodingFailureMode -> TextEncoding +mkUTF32 cfm = TextEncoding { textEncodingName = "UTF-32", + mkTextDecoder = utf32_DF cfm, + mkTextEncoder = utf32_EF cfm } -utf32_DF :: IO (TextDecoder (Maybe DecodeBuffer)) -utf32_DF = do +utf32_DF :: CodingFailureMode -> IO (TextDecoder (Maybe DecodeBuffer)) +utf32_DF cfm = do seen_bom <- newIORef Nothing return (BufferCodec { encode = utf32_decode seen_bom, + recover = recoverDecode cfm, close = return (), getState = readIORef seen_bom, setState = writeIORef seen_bom }) -utf32_EF :: IO (TextEncoder Bool) -utf32_EF = do +utf32_EF :: CodingFailureMode -> IO (TextEncoder Bool) +utf32_EF cfm = do done_bom <- newIORef False return (BufferCodec { encode = utf32_encode done_bom, + recover = recoverEncode cfm, close = return (), getState = readIORef done_bom, setState = writeIORef done_bom @@ -79,7 +90,7 @@ b <- readIORef done_bom if b then utf32_native_encode input output else if os - ow < 4 - then return (input,output) + then return (OutputUnderflow, input,output) else do writeIORef done_bom True writeWord8Buf oraw ow bom0 @@ -97,7 +108,7 @@ case mb of Just decode -> decode input output Nothing -> - if iw - ir < 4 then return (input,output) else do + if iw - ir < 4 then return (InputUnderflow, input,output) else do c0 <- readWord8Buf iraw ir c1 <- readWord8Buf iraw (ir+1) c2 <- readWord8Buf iraw (ir+2) @@ -131,23 +142,28 @@ -- UTF32LE and UTF32BE utf32be :: TextEncoding -utf32be = TextEncoding { textEncodingName = "UTF-32BE", - mkTextDecoder = utf32be_DF, - mkTextEncoder = utf32be_EF } +utf32be = mkUTF32be ErrorOnCodingFailure + +mkUTF32be :: CodingFailureMode -> TextEncoding +mkUTF32be cfm = TextEncoding { textEncodingName = "UTF-32BE", + mkTextDecoder = utf32be_DF cfm, + mkTextEncoder = utf32be_EF cfm } -utf32be_DF :: IO (TextDecoder ()) -utf32be_DF = +utf32be_DF :: CodingFailureMode -> IO (TextDecoder ()) +utf32be_DF cfm = return (BufferCodec { encode = utf32be_decode, + recover = recoverDecode cfm, close = return (), getState = return (), setState = const $ return () }) -utf32be_EF :: IO (TextEncoder ()) -utf32be_EF = +utf32be_EF :: CodingFailureMode -> IO (TextEncoder ()) +utf32be_EF cfm = return (BufferCodec { encode = utf32be_encode, + recover = recoverEncode cfm, close = return (), getState = return (), setState = const $ return () @@ -155,23 +171,28 @@ utf32le :: TextEncoding -utf32le = TextEncoding { textEncodingName = "UTF-32LE", - mkTextDecoder = utf32le_DF, - mkTextEncoder = utf32le_EF } +utf32le = mkUTF32le ErrorOnCodingFailure -utf32le_DF :: IO (TextDecoder ()) -utf32le_DF = +mkUTF32le :: CodingFailureMode -> TextEncoding +mkUTF32le cfm = TextEncoding { textEncodingName = "UTF-32LE", + mkTextDecoder = utf32le_DF cfm, + mkTextEncoder = utf32le_EF cfm } + +utf32le_DF :: CodingFailureMode -> IO (TextDecoder ()) +utf32le_DF cfm = return (BufferCodec { encode = utf32le_decode, + recover = recoverDecode cfm, close = return (), getState = return (), setState = const $ return () }) -utf32le_EF :: IO (TextEncoder ()) -utf32le_EF = +utf32le_EF :: CodingFailureMode -> IO (TextEncoder ()) +utf32le_EF cfm = return (BufferCodec { encode = utf32le_encode, + recover = recoverEncode cfm, close = return (), getState = return (), setState = const $ return () @@ -184,7 +205,8 @@ output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } = let loop !ir !ow - | ow >= os || iw - ir < 4 = done ir ow + | ow >= os = done OutputUnderflow ir ow + | iw - ir < 4 = done InputUnderflow ir ow | otherwise = do c0 <- readWord8Buf iraw ir c1 <- readWord8Buf iraw (ir+1) @@ -195,12 +217,13 @@ ow' <- writeCharBuf oraw ow x1 loop (ir+4) ow' where - invalid = if ir > ir0 then done ir ow else ioe_decodingError + invalid = done InvalidSequence ir ow -- lambda-lifted, to avoid thunks being built in the inner-loop: - done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 } - else input{ bufL=ir }, - output{ bufR=ow }) + done why !ir !ow = return (why, + if ir == iw then input{ bufL=0, bufR=0 } + else input{ bufL=ir }, + output{ bufR=ow }) in loop ir0 ow0 @@ -210,7 +233,8 @@ output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } = let loop !ir !ow - | ow >= os || iw - ir < 4 = done ir ow + | ow >= os = done OutputUnderflow ir ow + | iw - ir < 4 = done InputUnderflow ir ow | otherwise = do c0 <- readWord8Buf iraw ir c1 <- readWord8Buf iraw (ir+1) @@ -221,39 +245,37 @@ ow' <- writeCharBuf oraw ow x1 loop (ir+4) ow' where - invalid = if ir > ir0 then done ir ow else ioe_decodingError + invalid = done InvalidSequence ir ow -- lambda-lifted, to avoid thunks being built in the inner-loop: - done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 } - else input{ bufL=ir }, - output{ bufR=ow }) + done why !ir !ow = return (why, + if ir == iw then input{ bufL=0, bufR=0 } + else input{ bufL=ir }, + output{ bufR=ow }) in loop ir0 ow0 -ioe_decodingError :: IO a -ioe_decodingError = ioException - (IOError Nothing InvalidArgument "utf32_decode" - "invalid UTF-32 byte sequence" Nothing Nothing) - utf32be_encode :: EncodeBuffer utf32be_encode input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } = let - done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 } - else input{ bufL=ir }, - output{ bufR=ow }) + done why !ir !ow = return (why, + if ir == iw then input{ bufL=0, bufR=0 } + else input{ bufL=ir }, + output{ bufR=ow }) loop !ir !ow - | ir >= iw = done ir ow - | os - ow < 4 = done ir ow + | ir >= iw = done InputUnderflow ir ow + | os - ow < 4 = done OutputUnderflow ir ow | otherwise = do (c,ir') <- readCharBuf iraw ir - let (c0,c1,c2,c3) = ord4 c - writeWord8Buf oraw ow c0 - writeWord8Buf oraw (ow+1) c1 - writeWord8Buf oraw (ow+2) c2 - writeWord8Buf oraw (ow+3) c3 - loop ir' (ow+4) + if isSurrogate c then done InvalidSequence ir ow else do + let (c0,c1,c2,c3) = ord4 c + writeWord8Buf oraw ow c0 + writeWord8Buf oraw (ow+1) c1 + writeWord8Buf oraw (ow+2) c2 + writeWord8Buf oraw (ow+3) c3 + loop ir' (ow+4) in loop ir0 ow0 @@ -262,20 +284,22 @@ input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } = let - done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 } - else input{ bufL=ir }, - output{ bufR=ow }) + done why !ir !ow = return (why, + if ir == iw then input{ bufL=0, bufR=0 } + else input{ bufL=ir }, + output{ bufR=ow }) loop !ir !ow - | ir >= iw = done ir ow - | os - ow < 4 = done ir ow + | ir >= iw = done InputUnderflow ir ow + | os - ow < 4 = done OutputUnderflow ir ow | otherwise = do (c,ir') <- readCharBuf iraw ir - let (c0,c1,c2,c3) = ord4 c - writeWord8Buf oraw ow c3 - writeWord8Buf oraw (ow+1) c2 - writeWord8Buf oraw (ow+2) c1 - writeWord8Buf oraw (ow+3) c0 - loop ir' (ow+4) + if isSurrogate c then done InvalidSequence ir ow else do + let (c0,c1,c2,c3) = ord4 c + writeWord8Buf oraw ow c3 + writeWord8Buf oraw (ow+1) c2 + writeWord8Buf oraw (ow+2) c1 + writeWord8Buf oraw (ow+3) c0 + loop ir' (ow+4) in loop ir0 ow0 diff -Nru ghc-7.0.3/libraries/base/GHC/IO/Encoding/UTF8.hs ghc-7.2.1/libraries/base/GHC/IO/Encoding/UTF8.hs --- ghc-7.0.3/libraries/base/GHC/IO/Encoding/UTF8.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/IO/Encoding/UTF8.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,5 +1,11 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude -funbox-strict-fields #-} -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude + , BangPatterns + , NondecreasingIndentation + , MagicHash + #-} +{-# OPTIONS_GHC -funbox-strict-fields #-} + ----------------------------------------------------------------------------- -- | -- Module : GHC.IO.Encoding.UTF8 @@ -19,8 +25,8 @@ ----------------------------------------------------------------------------- module GHC.IO.Encoding.UTF8 ( - utf8, - utf8_bom, + utf8, mkUTF8, + utf8_bom, mkUTF8_bom ) where import GHC.Base @@ -28,56 +34,66 @@ import GHC.Num import GHC.IORef -- import GHC.IO -import GHC.IO.Exception import GHC.IO.Buffer +import GHC.IO.Encoding.Failure import GHC.IO.Encoding.Types import GHC.Word import Data.Bits -import Data.Maybe utf8 :: TextEncoding -utf8 = TextEncoding { textEncodingName = "UTF-8", - mkTextDecoder = utf8_DF, - mkTextEncoder = utf8_EF } +utf8 = mkUTF8 ErrorOnCodingFailure + +mkUTF8 :: CodingFailureMode -> TextEncoding +mkUTF8 cfm = TextEncoding { textEncodingName = "UTF-8", + mkTextDecoder = utf8_DF cfm, + mkTextEncoder = utf8_EF cfm } + -utf8_DF :: IO (TextDecoder ()) -utf8_DF = +utf8_DF :: CodingFailureMode -> IO (TextDecoder ()) +utf8_DF cfm = return (BufferCodec { encode = utf8_decode, + recover = recoverDecode cfm, close = return (), getState = return (), setState = const $ return () }) -utf8_EF :: IO (TextEncoder ()) -utf8_EF = +utf8_EF :: CodingFailureMode -> IO (TextEncoder ()) +utf8_EF cfm = return (BufferCodec { encode = utf8_encode, + recover = recoverEncode cfm, close = return (), getState = return (), setState = const $ return () }) utf8_bom :: TextEncoding -utf8_bom = TextEncoding { textEncodingName = "UTF-8BOM", - mkTextDecoder = utf8_bom_DF, - mkTextEncoder = utf8_bom_EF } +utf8_bom = mkUTF8_bom ErrorOnCodingFailure -utf8_bom_DF :: IO (TextDecoder Bool) -utf8_bom_DF = do +mkUTF8_bom :: CodingFailureMode -> TextEncoding +mkUTF8_bom cfm = TextEncoding { textEncodingName = "UTF-8BOM", + mkTextDecoder = utf8_bom_DF cfm, + mkTextEncoder = utf8_bom_EF cfm } + +utf8_bom_DF :: CodingFailureMode -> IO (TextDecoder Bool) +utf8_bom_DF cfm = do ref <- newIORef True return (BufferCodec { encode = utf8_bom_decode ref, + recover = recoverDecode cfm, close = return (), getState = readIORef ref, setState = writeIORef ref }) -utf8_bom_EF :: IO (TextEncoder Bool) -utf8_bom_EF = do +utf8_bom_EF :: CodingFailureMode -> IO (TextEncoder Bool) +utf8_bom_EF cfm = do ref <- newIORef True return (BufferCodec { encode = utf8_bom_encode ref, + recover = recoverEncode cfm, close = return (), getState = readIORef ref, setState = writeIORef ref @@ -93,13 +109,13 @@ then utf8_decode input output else do let no_bom = do writeIORef ref False; utf8_decode input output - if iw - ir < 1 then return (input,output) else do + if iw - ir < 1 then return (InputUnderflow,input,output) else do c0 <- readWord8Buf iraw ir if (c0 /= bom0) then no_bom else do - if iw - ir < 2 then return (input,output) else do + if iw - ir < 2 then return (InputUnderflow,input,output) else do c1 <- readWord8Buf iraw (ir+1) if (c1 /= bom1) then no_bom else do - if iw - ir < 3 then return (input,output) else do + if iw - ir < 3 then return (InputUnderflow,input,output) else do c2 <- readWord8Buf iraw (ir+2) if (c2 /= bom2) then no_bom else do -- found a BOM, ignore it and carry on @@ -113,7 +129,7 @@ b <- readIORef ref if not b then utf8_encode input output else if os - ow < 3 - then return (input,output) + then return (OutputUnderflow,input,output) else do writeIORef ref False writeWord8Buf oraw ow bom0 @@ -132,7 +148,8 @@ output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } = let loop !ir !ow - | ow >= os || ir >= iw = done ir ow + | ow >= os = done OutputUnderflow ir ow + | ir >= iw = done InputUnderflow ir ow | otherwise = do c0 <- readWord8Buf iraw ir case c0 of @@ -140,19 +157,19 @@ ow' <- writeCharBuf oraw ow (unsafeChr (fromIntegral c0)) loop (ir+1) ow' | c0 >= 0xc0 && c0 <= 0xdf -> - if iw - ir < 2 then done ir ow else do + if iw - ir < 2 then done InputUnderflow ir ow else do c1 <- readWord8Buf iraw (ir+1) if (c1 < 0x80 || c1 >= 0xc0) then invalid else do ow' <- writeCharBuf oraw ow (chr2 c0 c1) loop (ir+2) ow' | c0 >= 0xe0 && c0 <= 0xef -> case iw - ir of - 1 -> done ir ow + 1 -> done InputUnderflow ir ow 2 -> do -- check for an error even when we don't have -- the full sequence yet (#3341) c1 <- readWord8Buf iraw (ir+1) if not (validate3 c0 c1 0x80) - then invalid else done ir ow + then invalid else done InputUnderflow ir ow _ -> do c1 <- readWord8Buf iraw (ir+1) c2 <- readWord8Buf iraw (ir+2) @@ -161,17 +178,17 @@ loop (ir+3) ow' | c0 >= 0xf0 -> case iw - ir of - 1 -> done ir ow + 1 -> done InputUnderflow ir ow 2 -> do -- check for an error even when we don't have -- the full sequence yet (#3341) c1 <- readWord8Buf iraw (ir+1) if not (validate4 c0 c1 0x80 0x80) - then invalid else done ir ow + then invalid else done InputUnderflow ir ow 3 -> do c1 <- readWord8Buf iraw (ir+1) c2 <- readWord8Buf iraw (ir+2) if not (validate4 c0 c1 c2 0x80) - then invalid else done ir ow + then invalid else done InputUnderflow ir ow _ -> do c1 <- readWord8Buf iraw (ir+1) c2 <- readWord8Buf iraw (ir+2) @@ -182,30 +199,28 @@ | otherwise -> invalid where - invalid = if ir > ir0 then done ir ow else ioe_decodingError + invalid = done InvalidSequence ir ow -- lambda-lifted, to avoid thunks being built in the inner-loop: - done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 } - else input{ bufL=ir }, - output{ bufR=ow }) + done why !ir !ow = return (why, + if ir == iw then input{ bufL=0, bufR=0 } + else input{ bufL=ir }, + output{ bufR=ow }) in loop ir0 ow0 -ioe_decodingError :: IO a -ioe_decodingError = ioException - (IOError Nothing InvalidArgument "utf8_decode" - "invalid UTF-8 byte sequence" Nothing Nothing) - utf8_encode :: EncodeBuffer utf8_encode input@Buffer{ bufRaw=iraw, bufL=ir0, bufR=iw, bufSize=_ } output@Buffer{ bufRaw=oraw, bufL=_, bufR=ow0, bufSize=os } = let - done !ir !ow = return (if ir == iw then input{ bufL=0, bufR=0 } - else input{ bufL=ir }, - output{ bufR=ow }) + done why !ir !ow = return (why, + if ir == iw then input{ bufL=0, bufR=0 } + else input{ bufL=ir }, + output{ bufR=ow }) loop !ir !ow - | ow >= os || ir >= iw = done ir ow + | ow >= os = done OutputUnderflow ir ow + | ir >= iw = done InputUnderflow ir ow | otherwise = do (c,ir') <- readCharBuf iraw ir case ord c of @@ -213,20 +228,20 @@ writeWord8Buf oraw ow (fromIntegral x) loop ir' (ow+1) | x <= 0x07FF -> - if os - ow < 2 then done ir ow else do + if os - ow < 2 then done OutputUnderflow ir ow else do let (c1,c2) = ord2 c writeWord8Buf oraw ow c1 writeWord8Buf oraw (ow+1) c2 loop ir' (ow+2) - | x <= 0xFFFF -> do - if os - ow < 3 then done ir ow else do + | x <= 0xFFFF -> if isSurrogate c then done InvalidSequence ir ow else do + if os - ow < 3 then done OutputUnderflow ir ow else do let (c1,c2,c3) = ord3 c writeWord8Buf oraw ow c1 writeWord8Buf oraw (ow+1) c2 writeWord8Buf oraw (ow+2) c3 loop ir' (ow+3) | otherwise -> do - if os - ow < 4 then done ir ow else do + if os - ow < 4 then done OutputUnderflow ir ow else do let (c1,c2,c3,c4) = ord4 c writeWord8Buf oraw ow c1 writeWord8Buf oraw (ow+1) c2 diff -Nru ghc-7.0.3/libraries/base/GHC/IO/Encoding.hs ghc-7.2.1/libraries/base/GHC/IO/Encoding.hs --- ghc-7.0.3/libraries/base/GHC/IO/Encoding.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/IO/Encoding.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,7 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude -funbox-strict-fields #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude, PatternGuards #-} +{-# OPTIONS_GHC -funbox-strict-fields #-} + ----------------------------------------------------------------------------- -- | -- Module : GHC.IO.Encoding @@ -14,18 +17,20 @@ ----------------------------------------------------------------------------- module GHC.IO.Encoding ( - BufferCodec(..), TextEncoding(..), TextEncoder, TextDecoder, - latin1, latin1_encode, latin1_decode, - utf8, utf8_bom, - utf16, utf16le, utf16be, - utf32, utf32le, utf32be, - localeEncoding, - mkTextEncoding, - ) where + BufferCodec(..), TextEncoding(..), TextEncoder, TextDecoder, CodingProgress(..), + latin1, latin1_encode, latin1_decode, + utf8, utf8_bom, + utf16, utf16le, utf16be, + utf32, utf32le, utf32be, + localeEncoding, fileSystemEncoding, foreignEncoding, + char8, + mkTextEncoding, + ) where import GHC.Base ---import GHC.IO +import GHC.IO.Exception import GHC.IO.Buffer +import GHC.IO.Encoding.Failure import GHC.IO.Encoding.Types import GHC.Word #if !defined(mingw32_HOST_OS) @@ -39,10 +44,8 @@ import qualified GHC.IO.Encoding.UTF16 as UTF16 import qualified GHC.IO.Encoding.UTF32 as UTF32 -#if defined(mingw32_HOST_OS) +import Data.List import Data.Maybe -import GHC.IO.Exception -#endif -- ----------------------------------------------------------------------------- @@ -95,13 +98,44 @@ utf32be = UTF32.utf32be -- | The Unicode encoding of the current locale -localeEncoding :: TextEncoding +localeEncoding :: TextEncoding + +-- | The Unicode encoding of the current locale, but allowing arbitrary +-- undecodable bytes to be round-tripped through it. +-- +-- This 'TextEncoding' is used to decode and encode command line arguments +-- and environment variables on non-Windows platforms. +-- +-- On Windows, this encoding *should not* be used if possible because +-- the use of code pages is deprecated: Strings should be retrieved +-- via the "wide" W-family of UTF-16 APIs instead +fileSystemEncoding :: TextEncoding + +-- | The Unicode encoding of the current locale, but where undecodable +-- bytes are replaced with their closest visual match. Used for +-- the 'CString' marshalling functions in "Foreign.C.String" +foreignEncoding :: TextEncoding + #if !defined(mingw32_HOST_OS) localeEncoding = Iconv.localeEncoding +fileSystemEncoding = Iconv.mkLocaleEncoding RoundtripFailure +foreignEncoding = Iconv.mkLocaleEncoding IgnoreCodingFailure #else localeEncoding = CodePage.localeEncoding +fileSystemEncoding = CodePage.mkLocaleEncoding RoundtripFailure +foreignEncoding = CodePage.mkLocaleEncoding IgnoreCodingFailure #endif +-- | An encoding in which Unicode code points are translated to bytes +-- by taking the code point modulo 256. When decoding, bytes are +-- translated directly into the equivalent code point. +-- +-- This encoding never fails in either direction. However, encoding +-- discards information, so encode followed by decode is not the +-- identity. +char8 :: TextEncoding +char8 = Latin1.latin1 + -- | Look up the named Unicode encoding. May fail with -- -- * 'isDoesNotExistError' if the encoding is unknown @@ -129,27 +163,40 @@ -- @CP@; for example, @\"CP1250\"@. -- mkTextEncoding :: String -> IO TextEncoding -#if !defined(mingw32_HOST_OS) -mkTextEncoding = Iconv.mkTextEncoding +mkTextEncoding e = case mb_coding_failure_mode of + Nothing -> unknown_encoding + Just cfm -> case enc of + "UTF-8" -> return $ UTF8.mkUTF8 cfm + "UTF-16" -> return $ UTF16.mkUTF16 cfm + "UTF-16LE" -> return $ UTF16.mkUTF16le cfm + "UTF-16BE" -> return $ UTF16.mkUTF16be cfm + "UTF-32" -> return $ UTF32.mkUTF32 cfm + "UTF-32LE" -> return $ UTF32.mkUTF32le cfm + "UTF-32BE" -> return $ UTF32.mkUTF32be cfm +#if defined(mingw32_HOST_OS) + 'C':'P':n | [(cp,"")] <- reads n -> return $ CodePage.mkCodePageEncoding cfm cp + _ -> unknown_encoding #else -mkTextEncoding "UTF-8" = return utf8 -mkTextEncoding "UTF-16" = return utf16 -mkTextEncoding "UTF-16LE" = return utf16le -mkTextEncoding "UTF-16BE" = return utf16be -mkTextEncoding "UTF-32" = return utf32 -mkTextEncoding "UTF-32LE" = return utf32le -mkTextEncoding "UTF-32BE" = return utf32be -mkTextEncoding ('C':'P':n) - | [(cp,"")] <- reads n = return $ CodePage.codePageEncoding cp -mkTextEncoding e = ioException - (IOError Nothing NoSuchThing "mkTextEncoding" - ("unknown encoding:" ++ e) Nothing Nothing) + _ -> Iconv.mkIconvEncoding cfm enc #endif + where + -- The only problem with actually documenting //IGNORE and //TRANSLIT as + -- supported suffixes is that they are not necessarily supported with non-GNU iconv + (enc, suffix) = span (/= '/') e + mb_coding_failure_mode = case suffix of + "" -> Just ErrorOnCodingFailure + "//IGNORE" -> Just IgnoreCodingFailure + "//TRANSLIT" -> Just TransliterateCodingFailure + "//ROUNDTRIP" -> Just RoundtripFailure + _ -> Nothing + + unknown_encoding = ioException (IOError Nothing NoSuchThing "mkTextEncoding" + ("unknown encoding:" ++ e) Nothing Nothing) latin1_encode :: CharBuffer -> Buffer Word8 -> IO (CharBuffer, Buffer Word8) -latin1_encode = Latin1.latin1_encode -- unchecked, used for binary +latin1_encode input output = fmap (\(_why,input',output') -> (input',output')) $ Latin1.latin1_encode input output -- unchecked, used for char8 --latin1_encode = unsafePerformIO $ do mkTextEncoder Iconv.latin1 >>= return.encode latin1_decode :: Buffer Word8 -> CharBuffer -> IO (Buffer Word8, CharBuffer) -latin1_decode = Latin1.latin1_decode +latin1_decode input output = fmap (\(_why,input',output') -> (input',output')) $ Latin1.latin1_decode input output --latin1_decode = unsafePerformIO $ do mkTextDecoder Iconv.latin1 >>= return.encode diff -Nru ghc-7.0.3/libraries/base/GHC/IO/Encoding.hs-boot ghc-7.2.1/libraries/base/GHC/IO/Encoding.hs-boot --- ghc-7.0.3/libraries/base/GHC/IO/Encoding.hs-boot 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/IO/Encoding.hs-boot 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,7 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude #-} +module GHC.IO.Encoding where + +import GHC.IO.Encoding.Types + +localeEncoding, fileSystemEncoding, foreignEncoding :: TextEncoding diff -Nru ghc-7.0.3/libraries/base/GHC/IO/Exception.hs ghc-7.2.1/libraries/base/GHC/IO/Exception.hs --- ghc-7.0.3/libraries/base/GHC/IO/Exception.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/IO/Exception.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,6 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude -funbox-strict-fields #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude, DeriveDataTypeable, MagicHash #-} +{-# OPTIONS_GHC -funbox-strict-fields #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- -- | diff -Nru ghc-7.0.3/libraries/base/GHC/IO/Exception.hs-boot ghc-7.2.1/libraries/base/GHC/IO/Exception.hs-boot --- ghc-7.0.3/libraries/base/GHC/IO/Exception.hs-boot 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/IO/Exception.hs-boot 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,5 @@ -{-# OPTIONS -fno-implicit-prelude #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude #-} module GHC.IO.Exception where import GHC.Base diff -Nru ghc-7.0.3/libraries/base/GHC/IO/FD.hs ghc-7.2.1/libraries/base/GHC/IO/FD.hs --- ghc-7.0.3/libraries/base/GHC/IO/FD.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/IO/FD.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,12 +1,19 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude -XBangPatterns #-} +{-# LANGUAGE CPP + , NoImplicitPrelude + , BangPatterns + , ForeignFunctionInterface + , DeriveDataTypeable + #-} +{-# OPTIONS_GHC -fno-warn-identities #-} -- Whether there are identities depends on the platform {-# OPTIONS_HADDOCK hide #-} + ----------------------------------------------------------------------------- -- | -- Module : GHC.IO.FD -- Copyright : (c) The University of Glasgow, 1994-2008 -- License : see libraries/base/LICENSE --- +-- -- Maintainer : libraries@haskell.org -- Stability : internal -- Portability : non-portable @@ -16,12 +23,12 @@ ----------------------------------------------------------------------------- module GHC.IO.FD ( - FD(..), - openFile, mkFD, release, - setNonBlockingMode, - readRawBufferPtr, readRawBufferPtrNoBlock, writeRawBufferPtr, - stdin, stdout, stderr - ) where + FD(..), + openFile, mkFD, release, + setNonBlockingMode, + readRawBufferPtr, readRawBufferPtrNoBlock, writeRawBufferPtr, + stdin, stdout, stderr + ) where import GHC.Base import GHC.Num @@ -40,13 +47,15 @@ import GHC.IO.Device (SeekMode(..), IODeviceType(..)) import GHC.Conc.IO import GHC.IO.Exception +#ifdef mingw32_HOST_OS +import GHC.Windows +#endif import Foreign import Foreign.C import qualified System.Posix.Internals import System.Posix.Internals hiding (FD, setEcho, getEcho) import System.Posix.Types --- import GHC.Ptr c_DEBUG_DUMP :: Bool c_DEBUG_DUMP = False @@ -132,10 +141,14 @@ -- opening files -- | Open a file and make an 'FD' for it. Truncates the file to zero --- size when the `IOMode` is `WriteMode`. Puts the file descriptor --- into non-blocking mode on Unix systems. -openFile :: FilePath -> IOMode -> IO (FD,IODeviceType) -openFile filepath iomode = +-- size when the `IOMode` is `WriteMode`. +openFile + :: FilePath -- ^ file to open + -> IOMode -- ^ mode in which to open the file + -> Bool -- ^ open the file in non-blocking mode? + -> IO (FD,IODeviceType) + +openFile filepath iomode non_blocking = withFilePath filepath $ \ f -> let @@ -155,7 +168,10 @@ binary_flags = 0 #endif - oflags = oflags1 .|. binary_flags + oflags2 = oflags1 .|. binary_flags + + oflags | non_blocking = oflags2 .|. nonblock_flags + | otherwise = oflags2 in do -- the old implementation had a complicated series of three opens, @@ -164,11 +180,12 @@ -- always returns EISDIR if the file is a directory and was opened -- for writing, so I think we're ok with a single open() here... fd <- throwErrnoIfMinus1Retry "openFile" - (c_open f oflags 0o666) + (if non_blocking then c_open f oflags 0o666 + else c_safe_open f oflags 0o666) (fD,fd_type) <- mkFD fd iomode Nothing{-no stat-} False{-not a socket-} - True{-is non-blocking-} + non_blocking `catchAny` \e -> do _ <- c_close fd throwIO e @@ -184,13 +201,14 @@ return (fD,fd_type) std_flags, output_flags, read_flags, write_flags, rw_flags, - append_flags :: CInt -std_flags = o_NONBLOCK .|. o_NOCTTY + append_flags, nonblock_flags :: CInt +std_flags = o_NOCTTY output_flags = std_flags .|. o_CREAT read_flags = std_flags .|. o_RDONLY write_flags = output_flags .|. o_WRONLY rw_flags = output_flags .|. o_RDWR append_flags = write_flags .|. o_APPEND +nonblock_flags = o_NONBLOCK -- | Make a 'FD' from an existing file descriptor. Fails if the FD @@ -603,9 +621,6 @@ -- for this case. We need to detect EPIPE correctly, because it -- shouldn't be reported as an error when it happens on stdout. -foreign import ccall unsafe "maperrno" -- in Win32Utils.c - c_maperrno :: IO () - -- NOTE: "safe" versions of the read/write calls for use by the threaded RTS. -- These calls may block, but that's ok. @@ -648,8 +663,3 @@ foreign import ccall unsafe "unlockFile" unlockFile :: CInt -> IO CInt #endif - -puts :: String -> IO () -puts s = do _ <- withCStringLen s $ \(p,len) -> - c_write 1 (castPtr p) (fromIntegral len) - return () diff -Nru ghc-7.0.3/libraries/base/GHC/IO/Handle/FD.hs ghc-7.2.1/libraries/base/GHC/IO/Handle/FD.hs --- ghc-7.0.3/libraries/base/GHC/IO/Handle/FD.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/IO/Handle/FD.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,6 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude, PatternGuards, ForeignFunctionInterface #-} + ----------------------------------------------------------------------------- -- | -- Module : GHC.IO.Handle.FD @@ -15,7 +17,7 @@ module GHC.IO.Handle.FD ( stdin, stdout, stderr, - openFile, openBinaryFile, + openFile, openBinaryFile, openFileBlocking, mkHandleFromFD, fdToHandle, fdToHandle', isEOF ) where @@ -23,19 +25,16 @@ import GHC.Base import GHC.Show import Data.Maybe --- import Control.Monad import Foreign.C.Types import GHC.MVar import GHC.IO import GHC.IO.Encoding --- import GHC.IO.Exception import GHC.IO.Device as IODevice import GHC.IO.Exception import GHC.IO.IOMode import GHC.IO.Handle import GHC.IO.Handle.Types import GHC.IO.Handle.Internals -import GHC.IO.FD (FD(..)) import qualified GHC.IO.FD as FD import qualified System.Posix.Internals as Posix @@ -89,9 +88,9 @@ -- We have to put the FDs into binary mode on Windows to avoid the newline -- translation that the CRT IO library does. -setBinaryMode :: FD -> IO () +setBinaryMode :: FD.FD -> IO () #ifdef mingw32_HOST_OS -setBinaryMode fd = do _ <- setmode (fdFD fd) True +setBinaryMode fd = do _ <- setmode (FD.fdFD fd) True return () #else setBinaryMode _ = return () @@ -147,7 +146,17 @@ openFile :: FilePath -> IOMode -> IO Handle openFile fp im = catchException - (openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE) + (openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE True) + (\e -> ioError (addFilePathToIOError "openFile" fp e)) + +-- | Like 'openFile', but opens the file in ordinary blocking mode. +-- This can be useful for opening a FIFO for reading: if we open in +-- non-blocking mode then the open will fail if there are no writers, +-- whereas a blocking open will block until a writer appears. +openFileBlocking :: FilePath -> IOMode -> IO Handle +openFileBlocking fp im = + catchException + (openFile' fp im dEFAULT_OPEN_IN_BINARY_MODE False) (\e -> ioError (addFilePathToIOError "openFile" fp e)) -- | Like 'openFile', but open the file in binary mode. @@ -162,18 +171,20 @@ openBinaryFile :: FilePath -> IOMode -> IO Handle openBinaryFile fp m = catchException - (openFile' fp m True) + (openFile' fp m True True) (\e -> ioError (addFilePathToIOError "openBinaryFile" fp e)) -openFile' :: String -> IOMode -> Bool -> IO Handle -openFile' filepath iomode binary = do +openFile' :: String -> IOMode -> Bool -> Bool -> IO Handle +openFile' filepath iomode binary non_blocking = do -- first open the file to get an FD - (fd, fd_type) <- FD.openFile filepath iomode + (fd, fd_type) <- FD.openFile filepath iomode non_blocking let mb_codec = if binary then Nothing else Just localeEncoding -- then use it to make a Handle - mkHandleFromFD fd fd_type filepath iomode True{-non-blocking-} mb_codec + mkHandleFromFD fd fd_type filepath iomode + False {- do not *set* non-blocking mode -} + mb_codec `onException` IODevice.close fd -- NB. don't forget to close the FD if mkHandleFromFD fails, otherwise -- this FD leaks. @@ -186,11 +197,11 @@ -- Converting file descriptors to Handles mkHandleFromFD - :: FD + :: FD.FD -> IODeviceType - -> FilePath -- a string describing this file descriptor (e.g. the filename) + -> FilePath -- a string describing this file descriptor (e.g. the filename) -> IOMode - -> Bool -- non_blocking (*sets* non-blocking mode on the FD) + -> Bool -- *set* non-blocking mode on the FD -> Maybe TextEncoding -> IO Handle diff -Nru ghc-7.0.3/libraries/base/GHC/IO/Handle/FD.hs-boot ghc-7.2.1/libraries/base/GHC/IO/Handle/FD.hs-boot --- ghc-7.0.3/libraries/base/GHC/IO/Handle/FD.hs-boot 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/IO/Handle/FD.hs-boot 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,5 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude #-} module GHC.IO.Handle.FD where import GHC.IO.Handle.Types diff -Nru ghc-7.0.3/libraries/base/GHC/IO/Handle/Internals.hs ghc-7.2.1/libraries/base/GHC/IO/Handle/Internals.hs --- ghc-7.0.3/libraries/base/GHC/IO/Handle/Internals.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/IO/Handle/Internals.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,7 +1,14 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude + , RecordWildCards + , BangPatterns + , PatternGuards + , NondecreasingIndentation + , Rank2Types + #-} {-# OPTIONS_GHC -fno-warn-unused-matches #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# OPTIONS_HADDOCK hide #-} -{-# LANGUAGE NoImplicitPrelude, RecordWildCards, BangPatterns #-} ----------------------------------------------------------------------------- -- | @@ -69,8 +76,7 @@ import Data.Typeable import Control.Monad import Data.Maybe -import Foreign hiding (unsafePerformIO) --- import System.IO.Error +import Foreign.Safe import System.Posix.Internals hiding (FD) import Foreign.C @@ -349,6 +355,38 @@ ("illegal buffer size " ++ showsPrec 9 n []) Nothing Nothing) -- 9 => should be parens'ified. +-- --------------------------------------------------------------------------- +-- Wrapper for Handle encoding/decoding. + +-- The interface for TextEncoding changed so that a TextEncoding doesn't raise +-- an exception if it encounters an invalid sequnce. Furthermore, encoding +-- returns a reason as to why encoding stopped, letting us know if it was due +-- to input/output underflow or an invalid sequence. +-- +-- This code adapts this elaborated interface back to the original TextEncoding +-- interface. +-- +-- FIXME: it is possible that Handle code using the haDecoder/haEncoder fields +-- could be made clearer by using the 'encode' interface directly. I have not +-- looked into this. +-- +-- FIXME: we should use recover to deal with EOF, rather than always throwing an +-- IOException (ioe_invalidCharacter). + +streamEncode :: BufferCodec from to state + -> Buffer from -> Buffer to + -> IO (Buffer from, Buffer to) +streamEncode codec from to = go (from, to) + where + go (from, to) = do + (why, from', to') <- encode codec from to + -- When we are dealing with Handles, we don't care about input/output + -- underflow particularly, and we want to delay errors about invalid + -- sequences as far as possible. + case why of + Encoding.InvalidSequence | bufL from == bufL from' -> recover codec from' to' >>= go + _ -> return (from', to') + -- ----------------------------------------------------------------------------- -- Handle Finalizers @@ -470,7 +508,7 @@ (cbuf',bbuf') <- case haEncoder of Nothing -> latin1_encode cbuf bbuf - Just encoder -> (encode encoder) cbuf bbuf + Just encoder -> (streamEncode encoder) cbuf bbuf debugIO ("writeCharBuffer after encoding: cbuf=" ++ summaryBuffer cbuf' ++ " bbuf=" ++ summaryBuffer bbuf') @@ -531,7 +569,7 @@ -- restore the codec state setState decoder codec_state - (bbuf1,cbuf1) <- (encode decoder) bbuf0 + (bbuf1,cbuf1) <- (streamEncode decoder) bbuf0 cbuf0{ bufL=0, bufR=0, bufSize = bufL cbuf0 } debugIO ("finished, bbuf=" ++ summaryBuffer bbuf1 ++ @@ -795,7 +833,7 @@ Just decoder -> do state <- getState decoder writeIORef haLastDecode (state, bbuf1) - (encode decoder) bbuf1 cbuf + (streamEncode decoder) bbuf1 cbuf debugIO ("readTextDevice after decoding: cbuf=" ++ summaryBuffer cbuf' ++ " bbuf=" ++ summaryBuffer bbuf2) @@ -819,7 +857,7 @@ then ioe_invalidCharacter else return bbuf2 - debugIO ("readTextDevice after reading: bbuf=" ++ summaryBuffer bbuf2) + debugIO ("readTextDevice' after reading: bbuf=" ++ summaryBuffer bbuf2) (bbuf3,cbuf') <- case haDecoder of @@ -829,9 +867,9 @@ Just decoder -> do state <- getState decoder writeIORef haLastDecode (state, bbuf2) - (encode decoder) bbuf2 cbuf + (streamEncode decoder) bbuf2 cbuf - debugIO ("readTextDevice after decoding: cbuf=" ++ summaryBuffer cbuf' ++ + debugIO ("readTextDevice' after decoding: cbuf=" ++ summaryBuffer cbuf' ++ " bbuf=" ++ summaryBuffer bbuf3) writeIORef haByteBuffer bbuf3 @@ -866,7 +904,7 @@ Just decoder -> do state <- getState decoder writeIORef haLastDecode (state, bbuf0) - (encode decoder) bbuf0 cbuf + (streamEncode decoder) bbuf0 cbuf writeIORef haByteBuffer bbuf2 return cbuf' diff -Nru ghc-7.0.3/libraries/base/GHC/IO/Handle/Text.hs ghc-7.2.1/libraries/base/GHC/IO/Handle/Text.hs --- ghc-7.0.3/libraries/base/GHC/IO/Handle/Text.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/IO/Handle/Text.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,7 +1,16 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP + , NoImplicitPrelude + , RecordWildCards + , BangPatterns + , PatternGuards + , NondecreasingIndentation + , MagicHash + , ForeignFunctionInterface + #-} {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# OPTIONS_GHC -fno-warn-unused-matches #-} {-# OPTIONS_HADDOCK hide #-} -{-# LANGUAGE NoImplicitPrelude, RecordWildCards, BangPatterns #-} ----------------------------------------------------------------------------- -- | @@ -19,17 +28,18 @@ -- #hide module GHC.IO.Handle.Text ( - hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr, - commitBuffer', -- hack, see below - hGetBuf, hGetBufSome, hGetBufNonBlocking, hPutBuf, hPutBufNonBlocking, - memcpy, hPutStrLn, - ) where + hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr, + commitBuffer', -- hack, see below + hGetBuf, hGetBufSome, hGetBufNonBlocking, hPutBuf, hPutBufNonBlocking, + memcpy, hPutStrLn, + ) where import GHC.IO import GHC.IO.FD import GHC.IO.Buffer import qualified GHC.IO.BufferedIO as Buffered import GHC.IO.Exception +import GHC.IO.Encoding.Failure (surrogatifyRoundtripCharacter, desurrogatifyRoundtripCharacter) import GHC.Exception import GHC.IO.Handle.Types import GHC.IO.Handle.Internals @@ -39,6 +49,7 @@ import Foreign import Foreign.C +import qualified Control.Exception as Exception import Data.Typeable import System.IO.Error import Data.Maybe @@ -240,12 +251,12 @@ maybeFillReadBuffer :: Handle__ -> CharBuffer -> IO (Maybe CharBuffer) maybeFillReadBuffer handle_ buf - = catch + = Exception.catch (do buf' <- getSomeCharacters handle_ buf return (Just buf') ) - (\e -> do if isEOFError e - then return Nothing + (\e -> do if isEOFError e + then return Nothing else ioError e) -- See GHC.IO.Buffer @@ -270,10 +281,10 @@ else do c1 <- peekElemOff pbuf (i-1) let c = (fromIntegral c1 - 0xd800) * 0x400 + (fromIntegral c2 - 0xdc00) + 0x10000 - unpackRB (unsafeChr c : acc) (i-2) + unpackRB (desurrogatifyRoundtripCharacter (unsafeChr c) : acc) (i-2) #else c <- peekElemOff pbuf i - unpackRB (c:acc) (i-1) + unpackRB (desurrogatifyRoundtripCharacter c:acc) (i-1) #endif in unpackRB acc0 (w-1) @@ -296,7 +307,7 @@ then unpackRB ('\n':acc) (i-2) else unpackRB ('\n':acc) (i-1) else do - unpackRB (c:acc) (i-1) + unpackRB (desurrogatifyRoundtripCharacter c:acc) (i-1) in do c <- peekElemOff pbuf (w-1) if (c == '\r') @@ -370,8 +381,8 @@ lazyReadBuffered :: Handle -> Handle__ -> IO (Handle__, [Char]) lazyReadBuffered h handle_@Handle__{..} = do buf <- readIORef haCharBuffer - catch - (do + Exception.catch + (do buf'@Buffer{..} <- getSomeCharacters handle_ buf lazy_rest <- lazyRead h (s,r) <- if haInputNL == CRLF @@ -576,7 +587,7 @@ else do shoveString n' cs rest | otherwise = do - n' <- writeCharBuf raw n c + n' <- writeCharBuf raw n (surrogatifyRoundtripCharacter c) shoveString n' cs rest in shoveString 0 s (if add_nl then "\n" else "") diff -Nru ghc-7.0.3/libraries/base/GHC/IO/Handle/Types.hs ghc-7.2.1/libraries/base/GHC/IO/Handle/Types.hs --- ghc-7.0.3/libraries/base/GHC/IO/Handle/Types.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/IO/Handle/Types.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,5 +1,12 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude -funbox-strict-fields #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP + , NoImplicitPrelude + , ExistentialQuantification + , DeriveDataTypeable + #-} +{-# OPTIONS_GHC -funbox-strict-fields #-} {-# OPTIONS_HADDOCK hide #-} + ----------------------------------------------------------------------------- -- | -- Module : GHC.IO.Handle.Types diff -Nru ghc-7.0.3/libraries/base/GHC/IO/Handle.hs ghc-7.2.1/libraries/base/GHC/IO/Handle.hs --- ghc-7.0.3/libraries/base/GHC/IO/Handle.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/IO/Handle.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,5 +1,10 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP + , NoImplicitPrelude + , RecordWildCards + , NondecreasingIndentation + #-} {-# OPTIONS_GHC -fno-warn-unused-matches #-} -{-# LANGUAGE NoImplicitPrelude, RecordWildCards #-} ----------------------------------------------------------------------------- -- | @@ -547,7 +552,7 @@ -- | Select binary mode ('True') or text mode ('False') on a open handle. -- (See also 'openBinaryFile'.) -- --- This has the same effect as calling 'hSetEncoding' with 'latin1', together +-- This has the same effect as calling 'hSetEncoding' with 'char8', together -- with 'hSetNewlineMode' with 'noNewlineTranslation'. -- hSetBinaryMode :: Handle -> Bool -> IO () diff -Nru ghc-7.0.3/libraries/base/GHC/IO/Handle.hs-boot ghc-7.2.1/libraries/base/GHC/IO/Handle.hs-boot --- ghc-7.0.3/libraries/base/GHC/IO/Handle.hs-boot 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/IO/Handle.hs-boot 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,5 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude #-} module GHC.IO.Handle where diff -Nru ghc-7.0.3/libraries/base/GHC/IO/IOMode.hs ghc-7.2.1/libraries/base/GHC/IO/IOMode.hs --- ghc-7.0.3/libraries/base/GHC/IO/IOMode.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/IO/IOMode.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,5 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- -- | diff -Nru ghc-7.0.3/libraries/base/GHC/IOArray.hs ghc-7.2.1/libraries/base/GHC/IOArray.hs --- ghc-7.0.3/libraries/base/GHC/IOArray.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/IOArray.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,11 +1,12 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude -funbox-strict-fields #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -funbox-strict-fields #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- -- | -- Module : GHC.IOArray -- Copyright : (c) The University of Glasgow 2008 -- License : see libraries/base/LICENSE --- +-- -- Maintainer : cvs-ghc@haskell.org -- Stability : internal -- Portability : non-portable (GHC Extensions) @@ -15,25 +16,25 @@ ----------------------------------------------------------------------------- module GHC.IOArray ( - IOArray(..), - newIOArray, unsafeReadIOArray, unsafeWriteIOArray, - readIOArray, writeIOArray, - boundsIOArray - ) where + IOArray(..), + newIOArray, unsafeReadIOArray, unsafeWriteIOArray, + readIOArray, writeIOArray, + boundsIOArray + ) where import GHC.Base import GHC.IO import GHC.Arr -- --------------------------------------------------------------------------- --- | An 'IOArray' is a mutable, boxed, non-strict array in the 'IO' monad. +-- | An 'IOArray' is a mutable, boxed, non-strict array in the 'IO' monad. -- The type arguments are as follows: -- -- * @i@: the index type of the array (should be an instance of 'Ix') -- -- * @e@: the element type of the array. -- --- +-- newtype IOArray i e = IOArray (STArray RealWorld i e) @@ -65,5 +66,6 @@ writeIOArray (IOArray marr) i e = stToIO (writeSTArray marr i e) {-# INLINE boundsIOArray #-} -boundsIOArray :: IOArray i e -> (i,i) +boundsIOArray :: IOArray i e -> (i,i) boundsIOArray (IOArray marr) = boundsSTArray marr + diff -Nru ghc-7.0.3/libraries/base/GHC/IOBase.hs ghc-7.2.1/libraries/base/GHC/IOBase.hs --- ghc-7.0.3/libraries/base/GHC/IOBase.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/IOBase.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,6 @@ +{-# LANGUAGE DeriveDataTypeable #-} {-# OPTIONS_HADDOCK hide #-} + ----------------------------------------------------------------------------- -- | -- Module : GHC.IOBase diff -Nru ghc-7.0.3/libraries/base/GHC/IO.hs ghc-7.2.1/libraries/base/GHC/IO.hs --- ghc-7.0.3/libraries/base/GHC/IO.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/IO.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,5 +1,10 @@ +{-# LANGUAGE NoImplicitPrelude + , BangPatterns + , RankNTypes + , MagicHash + , UnboxedTuples + #-} {-# OPTIONS_GHC -funbox-strict-fields #-} -{-# LANGUAGE NoImplicitPrelude, BangPatterns, RankNTypes #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- -- | @@ -17,22 +22,22 @@ -- #hide module GHC.IO ( - IO(..), unIO, failIO, liftIO, - unsafePerformIO, unsafeInterleaveIO, - unsafeDupablePerformIO, unsafeDupableInterleaveIO, - noDuplicate, + IO(..), unIO, failIO, liftIO, + unsafePerformIO, unsafeInterleaveIO, + unsafeDupablePerformIO, unsafeDupableInterleaveIO, + noDuplicate, -- To and from from ST - stToIO, ioToST, unsafeIOToST, unsafeSTToIO, + stToIO, ioToST, unsafeIOToST, unsafeSTToIO, - FilePath, + FilePath, - catchException, catchAny, throwIO, - mask, mask_, uninterruptibleMask, uninterruptibleMask_, - MaskingState(..), getMaskingState, - block, unblock, blocked, unsafeUnmask, - onException, finally, evaluate - ) where + catchException, catchAny, throwIO, + mask, mask_, uninterruptibleMask, uninterruptibleMask_, + MaskingState(..), getMaskingState, + block, unblock, blocked, unsafeUnmask, + onException, bracket, finally, evaluate + ) where import GHC.Base import GHC.ST @@ -159,9 +164,9 @@ unsafePerformIO m = unsafeDupablePerformIO (noDuplicate >> m) {-| -This version of 'unsafePerformIO' is slightly more efficient, +This version of 'unsafePerformIO' is more efficient because it omits the check that the IO is only being performed by a -single thread. Hence, when you write 'unsafeDupablePerformIO', +single thread. Hence, when you use 'unsafeDupablePerformIO', there is a possibility that the IO action may be performed multiple times (on a multiprocessor), and you should therefore ensure that it gives the same results each time. @@ -254,7 +259,7 @@ catchException (IO io) handler = IO $ catch# io handler' where handler' e = case fromException e of Just e' -> unIO (handler e') - Nothing -> raise# e + Nothing -> raiseIO# e catchAny :: IO a -> (forall e . Exception e => e -> IO a) -> IO a catchAny (IO io) handler = IO $ catch# io handler' @@ -337,6 +342,7 @@ 1# -> MaskedUninterruptible _ -> MaskedInterruptible #) +{-# DEPRECATED blocked "use Control.Exception.getMaskingState instead" #-} -- | returns True if asynchronous exceptions are blocked in the -- current thread. blocked :: IO Bool @@ -344,7 +350,7 @@ onException :: IO a -> IO b -> IO a onException io what = io `catchException` \e -> do _ <- what - throw (e :: SomeException) + throwIO (e :: SomeException) -- | Executes an IO computation with asynchronous -- exceptions /masked/. That is, any thread which attempts to raise @@ -426,6 +432,18 @@ MaskedInterruptible -> blockUninterruptible $ io block MaskedUninterruptible -> io id +bracket + :: IO a -- ^ computation to run first (\"acquire resource\") + -> (a -> IO b) -- ^ computation to run last (\"release resource\") + -> (a -> IO c) -- ^ computation to run in-between + -> IO c -- returns the value from the in-between computation +bracket before after thing = + mask $ \restore -> do + a <- before + r <- restore (thing a) `onException` after a + _ <- after a + return r + finally :: IO a -- ^ computation to run first -> IO b -- ^ computation to run afterward (even if an exception -- was raised) @@ -451,4 +469,4 @@ -- > evaluate x = (return $! x) >>= return -- evaluate :: a -> IO a -evaluate a = IO $ \s -> let !va = a in (# s, va #) -- NB. see #2273 +evaluate a = IO $ \s -> seq# a s -- NB. see #2273, #5129 diff -Nru ghc-7.0.3/libraries/base/GHC/IO.hs-boot ghc-7.2.1/libraries/base/GHC/IO.hs-boot --- ghc-7.0.3/libraries/base/GHC/IO.hs-boot 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/IO.hs-boot 2011-08-07 17:10:07.000000000 +0000 @@ -1,3 +1,5 @@ +{-# LANGUAGE NoImplicitPrelude #-} + module GHC.IO where import GHC.Types diff -Nru ghc-7.0.3/libraries/base/GHC/IORef.hs ghc-7.2.1/libraries/base/GHC/IORef.hs --- ghc-7.0.3/libraries/base/GHC/IORef.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/IORef.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,11 +1,13 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude -funbox-strict-fields #-} +{-# LANGUAGE NoImplicitPrelude, MagicHash #-} +{-# OPTIONS_GHC -funbox-strict-fields #-} {-# OPTIONS_HADDOCK hide #-} + ----------------------------------------------------------------------------- -- | -- Module : GHC.IORef -- Copyright : (c) The University of Glasgow 2008 -- License : see libraries/base/LICENSE --- +-- -- Maintainer : cvs-ghc@haskell.org -- Stability : internal -- Portability : non-portable (GHC Extensions) @@ -14,9 +16,9 @@ -- ----------------------------------------------------------------------------- module GHC.IORef ( - IORef(..), - newIORef, readIORef, writeIORef, atomicModifyIORef - ) where + IORef(..), + newIORef, readIORef, writeIORef, atomicModifyIORef + ) where import GHC.Base import GHC.STRef diff -Nru ghc-7.0.3/libraries/base/GHC/List.lhs ghc-7.2.1/libraries/base/GHC/List.lhs --- ghc-7.0.3/libraries/base/GHC/List.lhs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/List.lhs 2011-08-07 17:10:07.000000000 +0000 @@ -1,6 +1,8 @@ \begin{code} -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude, MagicHash #-} {-# OPTIONS_HADDOCK hide #-} + ----------------------------------------------------------------------------- -- | -- Module : GHC.List @@ -335,7 +337,8 @@ -- > splitAt 0 [1,2,3] == ([],[1,2,3]) -- > splitAt (-1) [1,2,3] == ([],[1,2,3]) -- --- It is equivalent to @('take' n xs, 'drop' n xs)@. +-- It is equivalent to @('take' n xs, 'drop' n xs)@ when @n@ is not @_|_@ +-- (@splitAt _|_ xs = _|_@). -- 'splitAt' is an instance of the more general 'Data.List.genericSplitAt', -- in which @n@ may be of any integral type. splitAt :: Int -> [a] -> ([a],[a]) diff -Nru ghc-7.0.3/libraries/base/GHC/MVar.hs ghc-7.2.1/libraries/base/GHC/MVar.hs --- ghc-7.0.3/libraries/base/GHC/MVar.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/MVar.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,11 +1,13 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude -funbox-strict-fields #-} +{-# LANGUAGE NoImplicitPrelude, MagicHash, UnboxedTuples #-} +{-# OPTIONS_GHC -funbox-strict-fields #-} {-# OPTIONS_HADDOCK hide #-} + ----------------------------------------------------------------------------- -- | -- Module : GHC.MVar -- Copyright : (c) The University of Glasgow 2008 -- License : see libraries/base/LICENSE --- +-- -- Maintainer : cvs-ghc@haskell.org -- Stability : internal -- Portability : non-portable (GHC Extensions) @@ -25,11 +27,10 @@ , tryPutMVar -- :: MVar a -> a -> IO Bool , isEmptyMVar -- :: MVar a -> IO Bool , addMVarFinalizer -- :: MVar a -> IO () -> IO () - - ) where + ) where import GHC.Base -import GHC.IO() -- instance Monad IO +import GHC.IO () -- instance Monad IO import Data.Maybe data MVar a = MVar (MVar# RealWorld a) @@ -69,9 +70,9 @@ return mvar -- |Return the contents of the 'MVar'. If the 'MVar' is currently --- empty, 'takeMVar' will wait until it is full. After a 'takeMVar', +-- empty, 'takeMVar' will wait until it is full. After a 'takeMVar', -- the 'MVar' is left empty. --- +-- -- There are two further important properties of 'takeMVar': -- -- * 'takeMVar' is single-wakeup. That is, if there are multiple @@ -131,13 +132,13 @@ -- the MVar may have been filled (or emptied) - so be extremely -- careful when using this operation. Use 'tryTakeMVar' instead if possible. isEmptyMVar :: MVar a -> IO Bool -isEmptyMVar (MVar mv#) = IO $ \ s# -> +isEmptyMVar (MVar mv#) = IO $ \ s# -> case isEmptyMVar# mv# s# of (# s2#, flg #) -> (# s2#, not (flg ==# 0#) #) -- |Add a finalizer to an 'MVar' (GHC only). See "Foreign.ForeignPtr" and -- "System.Mem.Weak" for more about finalizers. addMVarFinalizer :: MVar a -> IO () -> IO () -addMVarFinalizer (MVar m) finalizer = +addMVarFinalizer (MVar m) finalizer = IO $ \s -> case mkWeak# m () finalizer s of { (# s1, _ #) -> (# s1, () #) } diff -Nru ghc-7.0.3/libraries/base/GHC/Num.lhs ghc-7.2.1/libraries/base/GHC/Num.lhs --- ghc-7.0.3/libraries/base/GHC/Num.lhs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/Num.lhs 2011-08-07 17:10:07.000000000 +0000 @@ -1,5 +1,6 @@ \begin{code} -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude, MagicHash, UnboxedTuples #-} -- We believe we could deorphan this module, by moving lots of things -- around, but we haven't got there yet: {-# OPTIONS_GHC -fno-warn-orphans #-} @@ -112,7 +113,7 @@ | otherwise = 1 {-# INLINE fromInteger #-} -- Just to be sure! - fromInteger i = I# (toInt# i) + fromInteger i = I# (integerToInt i) quotRemInt :: Int -> Int -> (Int, Int) quotRemInt a@(I# _) b@(I# _) = (a `quotInt` b, a `remInt` b) @@ -250,7 +251,7 @@ succ x = x + 1 pred x = x - 1 toEnum (I# n) = smallInteger n - fromEnum n = I# (toInt# n) + fromEnum n = I# (integerToInt n) {-# INLINE enumFrom #-} {-# INLINE enumFromThen #-} diff -Nru ghc-7.0.3/libraries/base/GHC/Pack.lhs ghc-7.2.1/libraries/base/GHC/Pack.lhs --- ghc-7.0.3/libraries/base/GHC/Pack.lhs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/Pack.lhs 2011-08-07 17:10:07.000000000 +0000 @@ -1,6 +1,7 @@ \begin{code} -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE NoImplicitPrelude, MagicHash, UnboxedTuples #-} {-# OPTIONS_HADDOCK hide #-} + ----------------------------------------------------------------------------- -- | -- Module : GHC.Pack diff -Nru ghc-7.0.3/libraries/base/GHC/PArr.hs ghc-7.2.1/libraries/base/GHC/PArr.hs --- ghc-7.0.3/libraries/base/GHC/PArr.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/PArr.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,732 +1,29 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE ParallelArrays, MagicHash #-} {-# OPTIONS_GHC -funbox-strict-fields #-} -{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} -{-# LANGUAGE PArr #-} +{-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- -- | -- Module : GHC.PArr --- Copyright : (c) 2001-2002 Manuel M T Chakravarty & Gabriele Keller +-- Copyright : (c) 2001-2011 The Data Parallel Haskell team -- License : see libraries/base/LICENSE -- --- Maintainer : Manuel M. T. Chakravarty +-- Maintainer : cvs-ghc@haskell.org -- Stability : internal -- Portability : non-portable (GHC Extensions) -- --- Basic implementation of Parallel Arrays. --- --- This module has two functions: (1) It defines the interface to the --- parallel array extension of the Prelude and (2) it provides a vanilla --- implementation of parallel arrays that does not require to flatten the --- array code. The implementation is not very optimised. --- ---- DOCU ---------------------------------------------------------------------- --- --- Language: Haskell 98 plus unboxed values and parallel arrays --- --- The semantic difference between standard Haskell arrays (aka "lazy --- arrays") and parallel arrays (aka "strict arrays") is that the evaluation --- of two different elements of a lazy array is independent, whereas in a --- strict array either non or all elements are evaluated. In other words, --- when a parallel array is evaluated to WHNF, all its elements will be --- evaluated to WHNF. The name parallel array indicates that all array --- elements may, in general, be evaluated to WHNF in parallel without any --- need to resort to speculative evaluation. This parallel evaluation --- semantics is also beneficial in the sequential case, as it facilitates --- loop-based array processing as known from classic array-based languages, --- such as Fortran. --- --- The interface of this module is essentially a variant of the list --- component of the Prelude, but also includes some functions (such as --- permutations) that are not provided for lists. The following list --- operations are not supported on parallel arrays, as they would require the --- availability of infinite parallel arrays: `iterate', `repeat', and `cycle'. --- --- The current implementation is quite simple and entirely based on boxed --- arrays. One disadvantage of boxed arrays is that they require to --- immediately initialise all newly allocated arrays with an error thunk to --- keep the garbage collector happy, even if it is guaranteed that the array --- is fully initialised with different values before passing over the --- user-visible interface boundary. Currently, no effort is made to use --- raw memory copy operations to speed things up. --- ---- TODO ---------------------------------------------------------------------- --- --- * We probably want a standard library `PArray' in addition to the prelude --- extension in the same way as the standard library `List' complements the --- list functions from the prelude. --- --- * Currently, functions that emphasis the constructor-based definition of --- lists (such as, head, last, tail, and init) are not supported. --- --- Is it worthwhile to support the string processing functions lines, --- words, unlines, and unwords? (Currently, they are not implemented.) --- --- It can, however, be argued that it would be worthwhile to include them --- for completeness' sake; maybe only in the standard library `PArray'. --- --- * Prescans are often more useful for array programming than scans. Shall --- we include them into the Prelude or the library? --- --- * Due to the use of the iterator `loop', we could define some fusion rules --- in this module. --- --- * We might want to add bounds checks that can be deactivated. --- - -module GHC.PArr ( - -- [::], -- Built-in syntax - - mapP, -- :: (a -> b) -> [:a:] -> [:b:] - (+:+), -- :: [:a:] -> [:a:] -> [:a:] - filterP, -- :: (a -> Bool) -> [:a:] -> [:a:] - concatP, -- :: [:[:a:]:] -> [:a:] - concatMapP, -- :: (a -> [:b:]) -> [:a:] -> [:b:] --- head, last, tail, init, -- it's not wise to use them on arrays - nullP, -- :: [:a:] -> Bool - lengthP, -- :: [:a:] -> Int - (!:), -- :: [:a:] -> Int -> a - foldlP, -- :: (a -> b -> a) -> a -> [:b:] -> a - foldl1P, -- :: (a -> a -> a) -> [:a:] -> a - scanlP, -- :: (a -> b -> a) -> a -> [:b:] -> [:a:] - scanl1P, -- :: (a -> a -> a) -> [:a:] -> [:a:] - foldrP, -- :: (a -> b -> b) -> b -> [:a:] -> b - foldr1P, -- :: (a -> a -> a) -> [:a:] -> a - scanrP, -- :: (a -> b -> b) -> b -> [:a:] -> [:b:] - scanr1P, -- :: (a -> a -> a) -> [:a:] -> [:a:] --- iterate, repeat, -- parallel arrays must be finite - singletonP, -- :: a -> [:a:] - emptyP, -- :: [:a:] - replicateP, -- :: Int -> a -> [:a:] --- cycle, -- parallel arrays must be finite - takeP, -- :: Int -> [:a:] -> [:a:] - dropP, -- :: Int -> [:a:] -> [:a:] - splitAtP, -- :: Int -> [:a:] -> ([:a:],[:a:]) - takeWhileP, -- :: (a -> Bool) -> [:a:] -> [:a:] - dropWhileP, -- :: (a -> Bool) -> [:a:] -> [:a:] - spanP, -- :: (a -> Bool) -> [:a:] -> ([:a:], [:a:]) - breakP, -- :: (a -> Bool) -> [:a:] -> ([:a:], [:a:]) --- lines, words, unlines, unwords, -- is string processing really needed - reverseP, -- :: [:a:] -> [:a:] - andP, -- :: [:Bool:] -> Bool - orP, -- :: [:Bool:] -> Bool - anyP, -- :: (a -> Bool) -> [:a:] -> Bool - allP, -- :: (a -> Bool) -> [:a:] -> Bool - elemP, -- :: (Eq a) => a -> [:a:] -> Bool - notElemP, -- :: (Eq a) => a -> [:a:] -> Bool - lookupP, -- :: (Eq a) => a -> [:(a, b):] -> Maybe b - sumP, -- :: (Num a) => [:a:] -> a - productP, -- :: (Num a) => [:a:] -> a - maximumP, -- :: (Ord a) => [:a:] -> a - minimumP, -- :: (Ord a) => [:a:] -> a - zipP, -- :: [:a:] -> [:b:] -> [:(a, b) :] - zip3P, -- :: [:a:] -> [:b:] -> [:c:] -> [:(a, b, c):] - zipWithP, -- :: (a -> b -> c) -> [:a:] -> [:b:] -> [:c:] - zipWith3P, -- :: (a -> b -> c -> d) -> [:a:]->[:b:]->[:c:]->[:d:] - unzipP, -- :: [:(a, b) :] -> ([:a:], [:b:]) - unzip3P, -- :: [:(a, b, c):] -> ([:a:], [:b:], [:c:]) - - -- overloaded functions - -- - enumFromToP, -- :: Enum a => a -> a -> [:a:] - enumFromThenToP, -- :: Enum a => a -> a -> a -> [:a:] - - -- the following functions are not available on lists - -- - toP, -- :: [a] -> [:a:] - fromP, -- :: [:a:] -> [a] - sliceP, -- :: Int -> Int -> [:e:] -> [:e:] - foldP, -- :: (e -> e -> e) -> e -> [:e:] -> e - fold1P, -- :: (e -> e -> e) -> [:e:] -> e - permuteP, -- :: [:Int:] -> [:e:] -> [:e:] - bpermuteP, -- :: [:Int:] -> [:e:] -> [:e:] - dpermuteP, -- :: [:Int:] -> [:e:] -> [:e:] -> [:e:] - crossP, -- :: [:a:] -> [:b:] -> [:(a, b):] - crossMapP, -- :: [:a:] -> (a -> [:b:]) -> [:(a, b):] - indexOfP -- :: (a -> Bool) -> [:a:] -> [:Int:] -) where - -#ifndef __HADDOCK__ - -import Prelude -import GHC.ST ( ST(..), runST ) -import GHC.Base ( Int#, Array#, Int(I#), MutableArray#, newArray#, - unsafeFreezeArray#, indexArray#, writeArray#, (<#), (>=#) ) +-- #hide +module GHC.PArr where -infixl 9 !: -infixr 5 +:+ -infix 4 `elemP`, `notElemP` +import GHC.Base - --- representation of parallel arrays --- --------------------------------- - --- this rather straight forward implementation maps parallel arrays to the --- internal representation used for standard Haskell arrays in GHC's Prelude --- (EXPORTED ABSTRACTLY) +-- Representation of parallel arrays -- --- * This definition *must* be kept in sync with `TysWiredIn.parrTyCon'! +-- Vanilla representation of parallel Haskell based on standard GHC arrays that is used if the +-- vectorised is /not/ used. -- -data [::] e = PArr Int# (Array# e) - - --- exported operations on parallel arrays --- -------------------------------------- - --- operations corresponding to list operations +-- NB: This definition *must* be kept in sync with `TysWiredIn.parrTyCon'! -- - -mapP :: (a -> b) -> [:a:] -> [:b:] -mapP f = fst . loop (mapEFL f) noAL - -(+:+) :: [:a:] -> [:a:] -> [:a:] -a1 +:+ a2 = fst $ loop (mapEFL sel) noAL (enumFromToP 0 (len1 + len2 - 1)) - -- we can't use the [:x..y:] form here for tedious - -- reasons to do with the typechecker and the fact that - -- `enumFromToP' is defined in the same module - where - len1 = lengthP a1 - len2 = lengthP a2 - -- - sel i | i < len1 = a1!:i - | otherwise = a2!:(i - len1) - -filterP :: (a -> Bool) -> [:a:] -> [:a:] -filterP p = fst . loop (filterEFL p) noAL - -concatP :: [:[:a:]:] -> [:a:] -concatP xss = foldlP (+:+) [::] xss - -concatMapP :: (a -> [:b:]) -> [:a:] -> [:b:] -concatMapP f = concatP . mapP f - --- head, last, tail, init, -- it's not wise to use them on arrays - -nullP :: [:a:] -> Bool -nullP [::] = True -nullP _ = False - -lengthP :: [:a:] -> Int -lengthP (PArr n# _) = I# n# - -(!:) :: [:a:] -> Int -> a -(!:) = indexPArr - -foldlP :: (a -> b -> a) -> a -> [:b:] -> a -foldlP f z = snd . loop (foldEFL (flip f)) z - -foldl1P :: (a -> a -> a) -> [:a:] -> a -foldl1P _ [::] = error "Prelude.foldl1P: empty array" -foldl1P f a = snd $ loopFromTo 1 (lengthP a - 1) (foldEFL f) (a!:0) a - -scanlP :: (a -> b -> a) -> a -> [:b:] -> [:a:] -scanlP f z = fst . loop (scanEFL (flip f)) z - -scanl1P :: (a -> a -> a) -> [:a:] -> [:a:] -scanl1P _ [::] = error "Prelude.scanl1P: empty array" -scanl1P f a = fst $ loopFromTo 1 (lengthP a - 1) (scanEFL f) (a!:0) a - -foldrP :: (a -> b -> b) -> b -> [:a:] -> b -foldrP = error "Prelude.foldrP: not implemented yet" -- FIXME - -foldr1P :: (a -> a -> a) -> [:a:] -> a -foldr1P = error "Prelude.foldr1P: not implemented yet" -- FIXME - -scanrP :: (a -> b -> b) -> b -> [:a:] -> [:b:] -scanrP = error "Prelude.scanrP: not implemented yet" -- FIXME - -scanr1P :: (a -> a -> a) -> [:a:] -> [:a:] -scanr1P = error "Prelude.scanr1P: not implemented yet" -- FIXME - --- iterate, repeat -- parallel arrays must be finite - -singletonP :: a -> [:a:] -{-# INLINE singletonP #-} -singletonP e = replicateP 1 e - -emptyP:: [:a:] -{- NOINLINE emptyP #-} -emptyP = replicateP 0 undefined - - -replicateP :: Int -> a -> [:a:] -{-# INLINE replicateP #-} -replicateP n e = runST (do - marr# <- newArray n e - mkPArr n marr#) - --- cycle -- parallel arrays must be finite - -takeP :: Int -> [:a:] -> [:a:] -takeP n = sliceP 0 (n - 1) - -dropP :: Int -> [:a:] -> [:a:] -dropP n a = sliceP n (lengthP a - 1) a - -splitAtP :: Int -> [:a:] -> ([:a:],[:a:]) -splitAtP n xs = (takeP n xs, dropP n xs) - -takeWhileP :: (a -> Bool) -> [:a:] -> [:a:] -takeWhileP = error "Prelude.takeWhileP: not implemented yet" -- FIXME - -dropWhileP :: (a -> Bool) -> [:a:] -> [:a:] -dropWhileP = error "Prelude.dropWhileP: not implemented yet" -- FIXME - -spanP :: (a -> Bool) -> [:a:] -> ([:a:], [:a:]) -spanP = error "Prelude.spanP: not implemented yet" -- FIXME - -breakP :: (a -> Bool) -> [:a:] -> ([:a:], [:a:]) -breakP p = spanP (not . p) - --- lines, words, unlines, unwords, -- is string processing really needed - -reverseP :: [:a:] -> [:a:] -reverseP a = permuteP (enumFromThenToP (len - 1) (len - 2) 0) a - -- we can't use the [:x, y..z:] form here for tedious - -- reasons to do with the typechecker and the fact that - -- `enumFromThenToP' is defined in the same module - where - len = lengthP a - -andP :: [:Bool:] -> Bool -andP = foldP (&&) True - -orP :: [:Bool:] -> Bool -orP = foldP (||) True - -anyP :: (a -> Bool) -> [:a:] -> Bool -anyP p = orP . mapP p - -allP :: (a -> Bool) -> [:a:] -> Bool -allP p = andP . mapP p - -elemP :: (Eq a) => a -> [:a:] -> Bool -elemP x = anyP (== x) - -notElemP :: (Eq a) => a -> [:a:] -> Bool -notElemP x = allP (/= x) - -lookupP :: (Eq a) => a -> [:(a, b):] -> Maybe b -lookupP = error "Prelude.lookupP: not implemented yet" -- FIXME - -sumP :: (Num a) => [:a:] -> a -sumP = foldP (+) 0 - -productP :: (Num a) => [:a:] -> a -productP = foldP (*) 1 - -maximumP :: (Ord a) => [:a:] -> a -maximumP [::] = error "Prelude.maximumP: empty parallel array" -maximumP xs = fold1P max xs - -minimumP :: (Ord a) => [:a:] -> a -minimumP [::] = error "Prelude.minimumP: empty parallel array" -minimumP xs = fold1P min xs - -zipP :: [:a:] -> [:b:] -> [:(a, b):] -zipP = zipWithP (,) - -zip3P :: [:a:] -> [:b:] -> [:c:] -> [:(a, b, c):] -zip3P = zipWith3P (,,) - -zipWithP :: (a -> b -> c) -> [:a:] -> [:b:] -> [:c:] -zipWithP f a1 a2 = let - len1 = lengthP a1 - len2 = lengthP a2 - len = len1 `min` len2 - in - fst $ loopFromTo 0 (len - 1) combine 0 a1 - where - combine e1 i = (Just $ f e1 (a2!:i), i + 1) - -zipWith3P :: (a -> b -> c -> d) -> [:a:]->[:b:]->[:c:]->[:d:] -zipWith3P f a1 a2 a3 = let - len1 = lengthP a1 - len2 = lengthP a2 - len3 = lengthP a3 - len = len1 `min` len2 `min` len3 - in - fst $ loopFromTo 0 (len - 1) combine 0 a1 - where - combine e1 i = (Just $ f e1 (a2!:i) (a3!:i), i + 1) - -unzipP :: [:(a, b):] -> ([:a:], [:b:]) -unzipP a = (fst $ loop (mapEFL fst) noAL a, fst $ loop (mapEFL snd) noAL a) --- FIXME: these two functions should be optimised using a tupled custom loop -unzip3P :: [:(a, b, c):] -> ([:a:], [:b:], [:c:]) -unzip3P x = (fst $ loop (mapEFL fst3) noAL x, - fst $ loop (mapEFL snd3) noAL x, - fst $ loop (mapEFL trd3) noAL x) - where - fst3 (a, _, _) = a - snd3 (_, b, _) = b - trd3 (_, _, c) = c - --- instances --- - -instance Eq a => Eq [:a:] where - a1 == a2 | lengthP a1 == lengthP a2 = andP (zipWithP (==) a1 a2) - | otherwise = False - -instance Ord a => Ord [:a:] where - compare a1 a2 = case foldlP combineOrdering EQ (zipWithP compare a1 a2) of - EQ | lengthP a1 == lengthP a2 -> EQ - | lengthP a1 < lengthP a2 -> LT - | otherwise -> GT - where - combineOrdering EQ EQ = EQ - combineOrdering EQ other = other - combineOrdering other _ = other - -instance Functor [::] where - fmap = mapP - -instance Monad [::] where - m >>= k = foldrP ((+:+) . k ) [::] m - m >> k = foldrP ((+:+) . const k) [::] m - return x = [:x:] - fail _ = [::] - -instance Show a => Show [:a:] where - showsPrec _ = showPArr . fromP - where - showPArr [] s = "[::]" ++ s - showPArr (x:xs) s = "[:" ++ shows x (showPArr' xs s) - - showPArr' [] s = ":]" ++ s - showPArr' (y:ys) s = ',' : shows y (showPArr' ys s) - -instance Read a => Read [:a:] where - readsPrec _ a = [(toP v, rest) | (v, rest) <- readPArr a] - where - readPArr = readParen False (\r -> do - ("[:",s) <- lex r - readPArr1 s) - readPArr1 s = - (do { (":]", t) <- lex s; return ([], t) }) ++ - (do { (x, t) <- reads s; (xs, u) <- readPArr2 t; return (x:xs, u) }) - - readPArr2 s = - (do { (":]", t) <- lex s; return ([], t) }) ++ - (do { (",", t) <- lex s; (x, u) <- reads t; (xs, v) <- readPArr2 u; - return (x:xs, v) }) - --- overloaded functions --- - --- Ideally, we would like `enumFromToP' and `enumFromThenToP' to be members of --- `Enum'. On the other hand, we really do not want to change `Enum'. Thus, --- for the moment, we hope that the compiler is sufficiently clever to --- properly fuse the following definitions. - -enumFromToP :: Enum a => a -> a -> [:a:] -enumFromToP x0 y0 = mapP toEnum (eftInt (fromEnum x0) (fromEnum y0)) - where - eftInt x y = scanlP (+) x $ replicateP (y - x + 1) 1 - -enumFromThenToP :: Enum a => a -> a -> a -> [:a:] -enumFromThenToP x0 y0 z0 = - mapP toEnum (efttInt (fromEnum x0) (fromEnum y0) (fromEnum z0)) - where - efttInt x y z = scanlP (+) x $ - replicateP (abs (z - x) `div` abs delta + 1) delta - where - delta = y - x - --- the following functions are not available on lists --- - --- create an array from a list (EXPORTED) --- -toP :: [a] -> [:a:] -toP l = fst $ loop store l (replicateP (length l) ()) - where - store _ (x:xs) = (Just x, xs) - --- convert an array to a list (EXPORTED) --- -fromP :: [:a:] -> [a] -fromP a = [a!:i | i <- [0..lengthP a - 1]] - --- cut a subarray out of an array (EXPORTED) --- -sliceP :: Int -> Int -> [:e:] -> [:e:] -sliceP from to a = - fst $ loopFromTo (0 `max` from) (to `min` (lengthP a - 1)) (mapEFL id) noAL a - --- parallel folding (EXPORTED) --- --- * the first argument must be associative; otherwise, the result is undefined --- -foldP :: (e -> e -> e) -> e -> [:e:] -> e -foldP = foldlP - --- parallel folding without explicit neutral (EXPORTED) --- --- * the first argument must be associative; otherwise, the result is undefined --- -fold1P :: (e -> e -> e) -> [:e:] -> e -fold1P = foldl1P - --- permute an array according to the permutation vector in the first argument --- (EXPORTED) --- -permuteP :: [:Int:] -> [:e:] -> [:e:] -permuteP is es - | isLen /= esLen = error "GHC.PArr: arguments must be of the same length" - | otherwise = runST (do - marr <- newArray isLen noElem - permute marr is es - mkPArr isLen marr) - where - noElem = error "GHC.PArr.permuteP: I do not exist!" - -- unlike standard Haskell arrays, this value represents an - -- internal error - isLen = lengthP is - esLen = lengthP es - --- permute an array according to the back-permutation vector in the first --- argument (EXPORTED) --- --- * the permutation vector must represent a surjective function; otherwise, --- the result is undefined --- -bpermuteP :: [:Int:] -> [:e:] -> [:e:] -bpermuteP is es = fst $ loop (mapEFL (es!:)) noAL is - --- permute an array according to the permutation vector in the first --- argument, which need not be surjective (EXPORTED) --- --- * any elements in the result that are not covered by the permutation --- vector assume the value of the corresponding position of the third --- argument --- -dpermuteP :: [:Int:] -> [:e:] -> [:e:] -> [:e:] -dpermuteP is es dft - | isLen /= esLen = error "GHC.PArr: arguments must be of the same length" - | otherwise = runST (do - marr <- newArray dftLen noElem - _ <- trans 0 (isLen - 1) marr dft copyOne noAL - permute marr is es - mkPArr dftLen marr) - where - noElem = error "GHC.PArr.permuteP: I do not exist!" - -- unlike standard Haskell arrays, this value represents an - -- internal error - isLen = lengthP is - esLen = lengthP es - dftLen = lengthP dft - - copyOne e _ = (Just e, noAL) - --- computes the cross combination of two arrays (EXPORTED) --- -crossP :: [:a:] -> [:b:] -> [:(a, b):] -crossP a1 a2 = fst $ loop combine (0, 0) $ replicateP len () - where - len1 = lengthP a1 - len2 = lengthP a2 - len = len1 * len2 - -- - combine _ (i, j) = (Just $ (a1!:i, a2!:j), next) - where - next | (i + 1) == len1 = (0 , j + 1) - | otherwise = (i + 1, j) - -{- An alternative implementation - * The one above is certainly better for flattened code, but here where we - are handling boxed arrays, the trade off is less clear. However, I - think, the above one is still better. - -crossP a1 a2 = let - len1 = lengthP a1 - len2 = lengthP a2 - x1 = concatP $ mapP (replicateP len2) a1 - x2 = concatP $ replicateP len1 a2 - in - zipP x1 x2 - -} - --- |Compute a cross of an array and the arrays produced by the given function --- for the elements of the first array. --- -crossMapP :: [:a:] -> (a -> [:b:]) -> [:(a, b):] -crossMapP a f = let - bs = mapP f a - segd = mapP lengthP bs - as = zipWithP replicateP segd a - in - zipP (concatP as) (concatP bs) - -{- The following may seem more straight forward, but the above is very cheap - with segmented arrays, as `mapP lengthP', `zipP', and `concatP' are - constant time, and `map f' uses the lifted version of `f'. - -crossMapP a f = concatP $ mapP (\x -> mapP ((,) x) (f x)) a - - -} - --- computes an index array for all elements of the second argument for which --- the predicate yields `True' (EXPORTED) --- -indexOfP :: (a -> Bool) -> [:a:] -> [:Int:] -indexOfP p a = fst $ loop calcIdx 0 a - where - calcIdx e idx | p e = (Just idx, idx + 1) - | otherwise = (Nothing , idx ) - - --- auxiliary functions --- ------------------- - --- internally used mutable boxed arrays --- -data MPArr s e = MPArr Int# (MutableArray# s e) - --- allocate a new mutable array that is pre-initialised with a given value --- -newArray :: Int -> e -> ST s (MPArr s e) -{-# INLINE newArray #-} -newArray (I# n#) e = ST $ \s1# -> - case newArray# n# e s1# of { (# s2#, marr# #) -> - (# s2#, MPArr n# marr# #)} - --- convert a mutable array into the external parallel array representation --- -mkPArr :: Int -> MPArr s e -> ST s [:e:] -{-# INLINE mkPArr #-} -mkPArr (I# n#) (MPArr _ marr#) = ST $ \s1# -> - case unsafeFreezeArray# marr# s1# of { (# s2#, arr# #) -> - (# s2#, PArr n# arr# #) } - --- general array iterator --- --- * corresponds to `loopA' from ``Functional Array Fusion'', Chakravarty & --- Keller, ICFP 2001 --- -loop :: (e -> acc -> (Maybe e', acc)) -- mapping & folding, once per element - -> acc -- initial acc value - -> [:e:] -- input array - -> ([:e':], acc) -{-# INLINE loop #-} -loop mf acc arr = loopFromTo 0 (lengthP arr - 1) mf acc arr - --- general array iterator with bounds --- -loopFromTo :: Int -- from index - -> Int -- to index - -> (e -> acc -> (Maybe e', acc)) - -> acc - -> [:e:] - -> ([:e':], acc) -{-# INLINE loopFromTo #-} -loopFromTo from to mf start arr = runST (do - marr <- newArray (to - from + 1) noElem - (n', acc) <- trans from to marr arr mf start - arr' <- mkPArr n' marr - return (arr', acc)) - where - noElem = error "GHC.PArr.loopFromTo: I do not exist!" - -- unlike standard Haskell arrays, this value represents an - -- internal error - --- actual loop body of `loop' --- --- * for this to be really efficient, it has to be translated with the --- constructor specialisation phase "SpecConstr" switched on; as of GHC 5.03 --- this requires an optimisation level of at least -O2 --- -trans :: Int -- index of first elem to process - -> Int -- index of last elem to process - -> MPArr s e' -- destination array - -> [:e:] -- source array - -> (e -> acc -> (Maybe e', acc)) -- mutator - -> acc -- initial accumulator - -> ST s (Int, acc) -- final destination length/final acc -{-# INLINE trans #-} -trans from to marr arr mf start = trans' from 0 start - where - trans' arrOff marrOff acc - | arrOff > to = return (marrOff, acc) - | otherwise = do - let (oe', acc') = mf (arr `indexPArr` arrOff) acc - marrOff' <- case oe' of - Nothing -> return marrOff - Just e' -> do - writeMPArr marr marrOff e' - return $ marrOff + 1 - trans' (arrOff + 1) marrOff' acc' - --- Permute the given elements into the mutable array. --- -permute :: MPArr s e -> [:Int:] -> [:e:] -> ST s () -permute marr is es = perm 0 - where - perm i - | i == n = return () - | otherwise = writeMPArr marr (is!:i) (es!:i) >> perm (i + 1) - where - n = lengthP is - - --- common patterns for using `loop' --- - --- initial value for the accumulator when the accumulator is not needed --- -noAL :: () -noAL = () - --- `loop' mutator maps a function over array elements --- -mapEFL :: (e -> e') -> (e -> () -> (Maybe e', ())) -{-# INLINE mapEFL #-} -mapEFL f = \e _ -> (Just $ f e, ()) - --- `loop' mutator that filter elements according to a predicate --- -filterEFL :: (e -> Bool) -> (e -> () -> (Maybe e, ())) -{-# INLINE filterEFL #-} -filterEFL p = \e _ -> if p e then (Just e, ()) else (Nothing, ()) - --- `loop' mutator for array folding --- -foldEFL :: (e -> acc -> acc) -> (e -> acc -> (Maybe (), acc)) -{-# INLINE foldEFL #-} -foldEFL f = \e a -> (Nothing, f e a) - --- `loop' mutator for array scanning --- -scanEFL :: (e -> acc -> acc) -> (e -> acc -> (Maybe acc, acc)) -{-# INLINE scanEFL #-} -scanEFL f = \e a -> (Just a, f e a) - --- elementary array operations --- - --- unlifted array indexing --- -indexPArr :: [:e:] -> Int -> e -{-# INLINE indexPArr #-} -indexPArr (PArr n# arr#) (I# i#) - | i# >=# 0# && i# <# n# = - case indexArray# arr# i# of (# e #) -> e - | otherwise = error $ "indexPArr: out of bounds parallel array index; " ++ - "idx = " ++ show (I# i#) ++ ", arr len = " - ++ show (I# n#) - --- encapsulate writing into a mutable array into the `ST' monad --- -writeMPArr :: MPArr s e -> Int -> e -> ST s () -{-# INLINE writeMPArr #-} -writeMPArr (MPArr n# marr#) (I# i#) e - | i# >=# 0# && i# <# n# = - ST $ \s# -> - case writeArray# marr# i# e s# of s'# -> (# s'#, () #) - | otherwise = error $ "writeMPArr: out of bounds parallel array index; " ++ - "idx = " ++ show (I# i#) ++ ", arr len = " - ++ show (I# n#) - -#endif /* __HADDOCK__ */ - +data [::] e = PArr !Int (Array# e) diff -Nru ghc-7.0.3/libraries/base/GHC/Ptr.lhs ghc-7.2.1/libraries/base/GHC/Ptr.lhs --- ghc-7.0.3/libraries/base/GHC/Ptr.lhs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/Ptr.lhs 2011-08-07 17:10:07.000000000 +0000 @@ -1,6 +1,7 @@ \begin{code} -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE CPP, NoImplicitPrelude, MagicHash #-} {-# OPTIONS_HADDOCK hide #-} + ----------------------------------------------------------------------------- -- | -- Module : GHC.Ptr @@ -16,7 +17,14 @@ ----------------------------------------------------------------------------- -- #hide -module GHC.Ptr where +module GHC.Ptr ( + Ptr(..), FunPtr(..), + nullPtr, castPtr, plusPtr, alignPtr, minusPtr, + nullFunPtr, castFunPtr, + + -- * Unsafe functions + castFunPtrToPtr, castPtrToFunPtr + ) where import GHC.Base import GHC.Show @@ -155,5 +163,5 @@ instance Show (FunPtr a) where showsPrec p = showsPrec p . castFunPtrToPtr -\end{code} +\end{code} diff -Nru ghc-7.0.3/libraries/base/GHC/Read.lhs ghc-7.2.1/libraries/base/GHC/Read.lhs --- ghc-7.0.3/libraries/base/GHC/Read.lhs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/Read.lhs 2011-08-07 17:10:07.000000000 +0000 @@ -1,6 +1,8 @@ \begin{code} -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude, StandaloneDeriving #-} {-# OPTIONS_HADDOCK hide #-} + ----------------------------------------------------------------------------- -- | -- Module : GHC.Read @@ -71,6 +73,8 @@ import GHC.Show import GHC.Base import GHC.Arr +-- For defining instances for the generic deriving mechanism +import GHC.Generics (Arity(..), Associativity(..), Fixity(..)) \end{code} @@ -679,3 +683,10 @@ readp = readPrec_to_P readPrec minPrec \end{code} +Instances for types of the generic deriving mechanism. + +\begin{code} +deriving instance Read Arity +deriving instance Read Associativity +deriving instance Read Fixity +\end{code} diff -Nru ghc-7.0.3/libraries/base/GHC/Real.lhs ghc-7.2.1/libraries/base/GHC/Real.lhs --- ghc-7.0.3/libraries/base/GHC/Real.lhs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/Real.lhs 2011-08-07 17:10:07.000000000 +0000 @@ -1,5 +1,6 @@ \begin{code} -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude, MagicHash, UnboxedTuples #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- -- | @@ -43,7 +44,7 @@ \begin{code} -- | Rational numbers, with numerator and denominator of some 'Integral' type. -data (Integral a) => Ratio a = !a :% !a deriving (Eq) +data Ratio a = !a :% !a deriving (Eq) -- | Arbitrary-precision rational numbers, represented as a ratio of -- two 'Integer' values. A rational number may be constructed using @@ -245,32 +246,42 @@ a `quot` b | b == 0 = divZeroError - | a == minBound && b == (-1) = overflowError + | b == (-1) && a == minBound = overflowError -- Note [Order of tests] + -- in GHC.Int | otherwise = a `quotInt` b a `rem` b | b == 0 = divZeroError - | a == minBound && b == (-1) = overflowError + -- The quotRem CPU instruction fails for minBound `quotRem` -1, + -- but minBound `rem` -1 is well-defined (0). We therefore + -- special-case it. + | b == (-1) = 0 | otherwise = a `remInt` b a `div` b | b == 0 = divZeroError - | a == minBound && b == (-1) = overflowError + | b == (-1) && a == minBound = overflowError -- Note [Order of tests] + -- in GHC.Int | otherwise = a `divInt` b a `mod` b | b == 0 = divZeroError - | a == minBound && b == (-1) = overflowError + -- The divMod CPU instruction fails for minBound `divMod` -1, + -- but minBound `mod` -1 is well-defined (0). We therefore + -- special-case it. + | b == (-1) = 0 | otherwise = a `modInt` b a `quotRem` b | b == 0 = divZeroError - | a == minBound && b == (-1) = overflowError + -- Note [Order of tests] in GHC.Int + | b == (-1) && a == minBound = (overflowError, 0) | otherwise = a `quotRemInt` b a `divMod` b | b == 0 = divZeroError - | a == minBound && b == (-1) = overflowError + -- Note [Order of tests] in GHC.Int + | b == (-1) && a == minBound = (overflowError, 0) | otherwise = a `divModInt` b \end{code} @@ -514,11 +525,16 @@ in if even e then (nn :% dd) else (negate nn :% dd) ------------------------------------------------------- --- | @'gcd' x y@ is the greatest (positive) integer that divides both @x@ --- and @y@; for example @'gcd' (-3) 6@ = @3@, @'gcd' (-3) (-6)@ = @3@, --- @'gcd' 0 4@ = @4@. @'gcd' 0 0@ raises a runtime error. +-- | @'gcd' x y@ is the non-negative factor of both @x@ and @y@ of which +-- every common factor of @x@ and @y@ is also a factor; for example +-- @'gcd' 4 2 = 2@, @'gcd' (-4) 6 = 2@, @'gcd' 0 4@ = @4@. @'gcd' 0 0@ = @0@. +-- (That is, the common divisor that is \"greatest\" in the divisibility +-- preordering.) +-- +-- Note: Since for signed fixed-width integer types, @'abs' 'minBound' < 0@, +-- the result may be negative if one of the arguments is @'minBound'@ (and +-- necessarily is if the other is @0@ or @'minBound'@) for such types. gcd :: (Integral a) => a -> a -> a -gcd 0 0 = error "Prelude.gcd: gcd 0 0 is undefined" gcd x y = gcd' (abs x) (abs y) where gcd' a 0 = a gcd' a b = gcd' b (a `rem` b) @@ -533,16 +549,11 @@ #ifdef OPTIMISE_INTEGER_GCD_LCM {-# RULES "gcd/Int->Int->Int" gcd = gcdInt -"gcd/Integer->Integer->Integer" gcd = gcdInteger' +"gcd/Integer->Integer->Integer" gcd = gcdInteger "lcm/Integer->Integer->Integer" lcm = lcmInteger #-} -gcdInteger' :: Integer -> Integer -> Integer -gcdInteger' 0 0 = error "GHC.Real.gcdInteger': gcd 0 0 is undefined" -gcdInteger' a b = gcdInteger a b - gcdInt :: Int -> Int -> Int -gcdInt 0 0 = error "GHC.Real.gcdInt: gcd 0 0 is undefined" gcdInt a b = fromIntegral (gcdInteger (fromIntegral a) (fromIntegral b)) #endif diff -Nru ghc-7.0.3/libraries/base/GHC/Show.lhs ghc-7.2.1/libraries/base/GHC/Show.lhs --- ghc-7.0.3/libraries/base/GHC/Show.lhs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/Show.lhs 2011-08-07 17:10:07.000000000 +0000 @@ -1,6 +1,8 @@ \begin{code} -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude, BangPatterns, MagicHash, StandaloneDeriving #-} {-# OPTIONS_HADDOCK hide #-} + ----------------------------------------------------------------------------- -- | -- Module : GHC.Show @@ -23,8 +25,9 @@ -- Instances for Show: (), [], Bool, Ordering, Int, Char -- Show support code - shows, showChar, showString, showParen, showList__, showSpace, - showLitChar, protectEsc, + shows, showChar, showString, showMultiLineString, + showParen, showList__, showSpace, + showLitChar, showLitString, protectEsc, intToDigit, showSignedInt, appPrec, appPrec1, @@ -35,7 +38,9 @@ import GHC.Base import Data.Maybe -import GHC.List ((!!), foldr1) +import GHC.List ((!!), foldr1, break) +-- For defining instances for the generic deriving mechanism +import GHC.Generics (Arity(..), Associativity(..), Fixity(..)) \end{code} @@ -180,14 +185,7 @@ showsPrec _ '\'' = showString "'\\''" showsPrec _ c = showChar '\'' . showLitChar c . showChar '\'' - showList cs = showChar '"' . showl cs - where showl "" s = showChar '"' s - showl ('"':xs) s = showString "\\\"" (showl xs s) - showl (x:xs) s = showLitChar x (showl xs s) - -- Making 's' an explicit parameter makes it clear to GHC - -- that showl has arity 2, which avoids it allocating an extra lambda - -- The sticking point is the recursive call to (showl xs), which - -- it can't figure out would be ok with arity 2. + showList cs = showChar '"' . showLitString cs . showChar '"' instance Show Int where showsPrec = showSignedInt @@ -347,6 +345,35 @@ -- I've done manual eta-expansion here, becuase otherwise it's -- impossible to stop (asciiTab!!ord) getting floated out as an MFE +showLitString :: String -> ShowS +-- | Same as 'showLitChar', but for strings +-- It converts the string to a string using Haskell escape conventions +-- for non-printable characters. Does not add double-quotes around the +-- whole thing; the caller should do that. +-- The main difference from showLitChar (apart from the fact that the +-- argument is a string not a list) is that we must escape double-quotes +showLitString [] s = s +showLitString ('"' : cs) s = showString "\\\"" (showLitString cs s) +showLitString (c : cs) s = showLitChar c (showLitString cs s) + -- Making 's' an explicit parameter makes it clear to GHC that + -- showLitString has arity 2, which avoids it allocating an extra lambda + -- The sticking point is the recursive call to (showLitString cs), which + -- it can't figure out would be ok with arity 2. + +showMultiLineString :: String -> [String] +-- | Like 'showLitString' (expand escape characters using Haskell +-- escape conventions), but +-- * break the string into multiple lines +-- * wrap the entire thing in double quotes +-- Example: @showLitString "hello\ngoodbye\nblah"@ +-- returns @["\"hello\\", "\\goodbye\\", "\\blah\""]@ +showMultiLineString str + = go '\"' str + where + go ch s = case break (== '\n') s of + (l, _:s'@(_:_)) -> (ch : showLitString l "\\") : go '\\' s' + (l, _) -> [ch : showLitString l "\""] + isDec :: Char -> Bool isDec c = c >= '0' && c <= '9' @@ -402,3 +429,11 @@ | otherwise = case chr# (ord# '0'# +# (x# `remInt#` 10#)) of { c# -> itos' (x# `quotInt#` 10#) (C# c# : cs') } \end{code} + +Instances for types of the generic deriving mechanism. + +\begin{code} +deriving instance Show Arity +deriving instance Show Associativity +deriving instance Show Fixity +\end{code} diff -Nru ghc-7.0.3/libraries/base/GHC/Show.lhs-boot ghc-7.2.1/libraries/base/GHC/Show.lhs-boot --- ghc-7.0.3/libraries/base/GHC/Show.lhs-boot 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/Show.lhs-boot 2011-08-07 17:10:07.000000000 +0000 @@ -1,5 +1,6 @@ \begin{code} -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude #-} module GHC.Show (showSignedInt) where diff -Nru ghc-7.0.3/libraries/base/GHC/Stable.lhs ghc-7.2.1/libraries/base/GHC/Stable.lhs --- ghc-7.0.3/libraries/base/GHC/Stable.lhs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/Stable.lhs 2011-08-07 17:10:07.000000000 +0000 @@ -1,6 +1,11 @@ \begin{code} -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE NoImplicitPrelude + , MagicHash + , UnboxedTuples + , ForeignFunctionInterface + #-} {-# OPTIONS_HADDOCK hide #-} + ----------------------------------------------------------------------------- -- | -- Module : GHC.Stable @@ -16,18 +21,17 @@ ----------------------------------------------------------------------------- -- #hide -module GHC.Stable - ( StablePtr(..) - , newStablePtr -- :: a -> IO (StablePtr a) - , deRefStablePtr -- :: StablePtr a -> a - , freeStablePtr -- :: StablePtr a -> IO () - , castStablePtrToPtr -- :: StablePtr a -> Ptr () - , castPtrToStablePtr -- :: Ptr () -> StablePtr a - ) where +module GHC.Stable ( + StablePtr(..), + newStablePtr, -- :: a -> IO (StablePtr a) + deRefStablePtr, -- :: StablePtr a -> a + freeStablePtr, -- :: StablePtr a -> IO () + castStablePtrToPtr, -- :: StablePtr a -> Ptr () + castPtrToStablePtr -- :: Ptr () -> StablePtr a + ) where import GHC.Ptr import GHC.Base --- import GHC.IO ----------------------------------------------------------------------------- -- Stable Pointers @@ -104,4 +108,5 @@ case eqStablePtr# sp1 sp2 of 0# -> False _ -> True + \end{code} diff -Nru ghc-7.0.3/libraries/base/GHC/ST.lhs ghc-7.2.1/libraries/base/GHC/ST.lhs --- ghc-7.0.3/libraries/base/GHC/ST.lhs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/ST.lhs 2011-08-07 17:10:07.000000000 +0000 @@ -1,5 +1,5 @@ \begin{code} -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE NoImplicitPrelude, MagicHash, UnboxedTuples, Rank2Types #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- -- | @@ -16,10 +16,17 @@ ----------------------------------------------------------------------------- -- #hide -module GHC.ST where +module GHC.ST ( + ST(..), STret(..), STRep, + fixST, runST, runSTRep, + + -- * Unsafe functions + liftST, unsafeInterleaveST + ) where import GHC.Base import GHC.Show +import Control.Monad( forever ) default () \end{code} @@ -74,6 +81,9 @@ data STret s a = STret (State# s) a +{-# SPECIALISE forever :: ST s a -> ST s b #-} +-- See Note [Make forever INLINABLE] in Control.Monad + -- liftST is useful when we want a lifted result from an ST computation. See -- fixST below. liftST :: ST s a -> State# s -> STret s a diff -Nru ghc-7.0.3/libraries/base/GHC/Storable.lhs ghc-7.2.1/libraries/base/GHC/Storable.lhs --- ghc-7.0.3/libraries/base/GHC/Storable.lhs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/Storable.lhs 2011-08-07 17:10:07.000000000 +0000 @@ -1,6 +1,8 @@ \begin{code} -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude, MagicHash, UnboxedTuples #-} {-# OPTIONS_HADDOCK hide #-} + ----------------------------------------------------------------------------- -- | -- Module : GHC.Storable @@ -51,7 +53,7 @@ , writeWord64OffPtr ) where -import GHC.Stable ( StablePtr(..) ) +import GHC.Stable ( StablePtr(..) ) import GHC.Int import GHC.Word import GHC.Ptr diff -Nru ghc-7.0.3/libraries/base/GHC/STRef.lhs ghc-7.2.1/libraries/base/GHC/STRef.lhs --- ghc-7.0.3/libraries/base/GHC/STRef.lhs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/STRef.lhs 2011-08-07 17:10:07.000000000 +0000 @@ -1,12 +1,13 @@ \begin{code} -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE NoImplicitPrelude, MagicHash, UnboxedTuples #-} {-# OPTIONS_HADDOCK hide #-} + ----------------------------------------------------------------------------- -- | -- Module : GHC.STRef -- Copyright : (c) The University of Glasgow, 1994-2002 -- License : see libraries/base/LICENSE --- +-- -- Maintainer : cvs-ghc@haskell.org -- Stability : internal -- Portability : non-portable (GHC Extensions) @@ -16,7 +17,10 @@ ----------------------------------------------------------------------------- -- #hide -module GHC.STRef where +module GHC.STRef ( + STRef(..), + newSTRef, readSTRef, writeSTRef + ) where import GHC.ST import GHC.Base @@ -44,4 +48,5 @@ -- Just pointer equality on mutable references: instance Eq (STRef s a) where STRef v1# == STRef v2# = sameMutVar# v1# v2# + \end{code} diff -Nru ghc-7.0.3/libraries/base/GHC/TopHandler.lhs ghc-7.2.1/libraries/base/GHC/TopHandler.lhs --- ghc-7.0.3/libraries/base/GHC/TopHandler.lhs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/TopHandler.lhs 2011-08-07 17:10:07.000000000 +0000 @@ -1,7 +1,15 @@ \begin{code} -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP + , NoImplicitPrelude + , ForeignFunctionInterface + , MagicHash + , UnboxedTuples + , PatternGuards + #-} {-# OPTIONS_GHC -fno-warn-unused-imports #-} {-# OPTIONS_HADDOCK hide #-} + ----------------------------------------------------------------------------- -- | -- Module : GHC.TopHandler @@ -19,10 +27,10 @@ -- #hide module GHC.TopHandler ( - runMainIO, runIO, runIOFastExit, runNonIO, - topHandler, topHandlerFastExit, - reportStackOverflow, reportError, - ) where + runMainIO, runIO, runIOFastExit, runNonIO, + topHandler, topHandlerFastExit, + reportStackOverflow, reportError, + ) where #include "HsBaseConfig.h" diff -Nru ghc-7.0.3/libraries/base/GHC/Unicode.hs ghc-7.2.1/libraries/base/GHC/Unicode.hs --- ghc-7.0.3/libraries/base/GHC/Unicode.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/Unicode.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,6 +1,8 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude, ForeignFunctionInterface #-} {-# OPTIONS -#include "WCsubst.h" #-} {-# OPTIONS_HADDOCK hide #-} + ----------------------------------------------------------------------------- -- | -- Module : GHC.Unicode @@ -19,14 +21,14 @@ -- #hide module GHC.Unicode ( - isAscii, isLatin1, isControl, - isAsciiUpper, isAsciiLower, - isPrint, isSpace, isUpper, - isLower, isAlpha, isDigit, - isOctDigit, isHexDigit, isAlphaNum, - toUpper, toLower, toTitle, - wgencat, - ) where + isAscii, isLatin1, isControl, + isAsciiUpper, isAsciiLower, + isPrint, isSpace, isUpper, + isLower, isAlpha, isDigit, + isOctDigit, isHexDigit, isAlphaNum, + toUpper, toLower, toTitle, + wgencat + ) where import GHC.Base import GHC.Real (fromIntegral) diff -Nru ghc-7.0.3/libraries/base/GHC/Unicode.hs-boot ghc-7.2.1/libraries/base/GHC/Unicode.hs-boot --- ghc-7.0.3/libraries/base/GHC/Unicode.hs-boot 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/Unicode.hs-boot 2011-08-07 17:10:07.000000000 +0000 @@ -1,8 +1,8 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude #-} module GHC.Unicode where -import GHC.Bool import GHC.Types isAscii :: Char -> Bool diff -Nru ghc-7.0.3/libraries/base/GHC/Weak.lhs ghc-7.2.1/libraries/base/GHC/Weak.lhs --- ghc-7.0.3/libraries/base/GHC/Weak.lhs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/Weak.lhs 2011-08-07 17:10:07.000000000 +0000 @@ -1,6 +1,14 @@ \begin{code} -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE CPP + , NoImplicitPrelude + , BangPatterns + , MagicHash + , UnboxedTuples + , DeriveDataTypeable + , StandaloneDeriving + #-} {-# OPTIONS_HADDOCK hide #-} + ----------------------------------------------------------------------------- -- | -- Module : GHC.Weak @@ -16,7 +24,13 @@ ----------------------------------------------------------------------------- -- #hide -module GHC.Weak where +module GHC.Weak ( + Weak(..), + mkWeak, + deRefWeak, + finalize, + runFinalizerBatch + ) where import GHC.Base import Data.Maybe diff -Nru ghc-7.0.3/libraries/base/GHC/Windows.hs ghc-7.2.1/libraries/base/GHC/Windows.hs --- ghc-7.0.3/libraries/base/GHC/Windows.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/Windows.hs 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,48 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude, ForeignFunctionInterface #-} +----------------------------------------------------------------------------- +-- | +-- Module : GHC.Windows +-- Copyright : (c) The University of Glasgow, 2009 +-- License : see libraries/base/LICENSE +-- +-- Maintainer : libraries@haskell.org +-- Stability : internal +-- Portability : non-portable +-- +-- Windows functionality used by several modules. +-- +-- ToDo: this just duplicates part of System.Win32.Types, which isn't +-- available yet. We should move some Win32 functionality down here, +-- maybe as part of the grand reorganisation of the base package... +-- +----------------------------------------------------------------------------- + +module GHC.Windows ( + HANDLE, DWORD, LPTSTR, iNFINITE, + throwGetLastError, c_maperrno + ) where + +import GHC.Base +import GHC.Ptr + +import Data.Word + +import Foreign.C.Error (throwErrno) +import Foreign.C.Types + + +type HANDLE = Ptr () +type DWORD = Word32 + +type LPTSTR = Ptr CWchar + +iNFINITE :: DWORD +iNFINITE = 0xFFFFFFFF -- urgh + +throwGetLastError :: String -> IO a +throwGetLastError where_from = c_maperrno >> throwErrno where_from + +foreign import ccall unsafe "maperrno" -- in Win32Utils.c + c_maperrno :: IO () + diff -Nru ghc-7.0.3/libraries/base/GHC/Word.hs ghc-7.2.1/libraries/base/GHC/Word.hs --- ghc-7.0.3/libraries/base/GHC/Word.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/GHC/Word.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,5 +1,7 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude, BangPatterns, MagicHash #-} {-# OPTIONS_HADDOCK hide #-} + ----------------------------------------------------------------------------- -- | -- Module : GHC.Word diff -Nru ghc-7.0.3/libraries/base/ghc.mk ghc-7.2.1/libraries/base/ghc.mk --- ghc-7.0.3/libraries/base/ghc.mk 2011-03-26 18:10:45.000000000 +0000 +++ ghc-7.2.1/libraries/base/ghc.mk 2011-08-07 17:11:00.000000000 +0000 @@ -1,3 +1,4 @@ libraries/base_PACKAGE = base libraries/base_dist-install_GROUP = libraries +$(if $(filter base,$(PACKAGES_STAGE0)),$(eval $(call build-package,libraries/base,dist-boot,0))) $(eval $(call build-package,libraries/base,dist-install,$(if $(filter base,$(STAGE2_PACKAGES)),2,1))) diff -Nru ghc-7.0.3/libraries/base/.gitignore ghc-7.2.1/libraries/base/.gitignore --- ghc-7.0.3/libraries/base/.gitignore 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/base/.gitignore 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,13 @@ + +# Specific generated files +/GNUmakefile +/autom4te.cache/ +/base.buildinfo +/config.log +/config.status +/configure +/dist-install/ +/ghc.mk +/include/EventConfig.h +/include/HsBaseConfig.h +/include/HsBaseConfig.h.in diff -Nru ghc-7.0.3/libraries/base/include/EventConfig.h ghc-7.2.1/libraries/base/include/EventConfig.h --- ghc-7.0.3/libraries/base/include/EventConfig.h 2011-03-26 18:13:19.000000000 +0000 +++ ghc-7.2.1/libraries/base/include/EventConfig.h 2011-08-07 17:27:22.000000000 +0000 @@ -5,7 +5,7 @@ #define HAVE_EPOLL 1 /* Define to 1 if you have the `epoll_create1' function. */ -#define HAVE_EPOLL_CREATE1 1 +/* #undef HAVE_EPOLL_CREATE1 */ /* Define to 1 if you have the `epoll_ctl' function. */ #define HAVE_EPOLL_CTL 1 diff -Nru ghc-7.0.3/libraries/base/include/HsBaseConfig.h.in ghc-7.2.1/libraries/base/include/HsBaseConfig.h.in --- ghc-7.0.3/libraries/base/include/HsBaseConfig.h.in 2011-03-26 18:10:49.000000000 +0000 +++ ghc-7.2.1/libraries/base/include/HsBaseConfig.h.in 2011-08-07 17:11:05.000000000 +0000 @@ -309,9 +309,6 @@ /* Define if you have epoll support. */ #undef HAVE_EPOLL -/* Define to 1 if you have the `epoll_create1' function. */ -#undef HAVE_EPOLL_CREATE1 - /* Define to 1 if you have the `epoll_ctl' function. */ #undef HAVE_EPOLL_CTL @@ -531,6 +528,9 @@ /* Define to Haskell type for ssize_t */ #undef HTYPE_SSIZE_T +/* Define to Haskell type for suseconds_t */ +#undef HTYPE_SUSECONDS_T + /* Define to Haskell type for tcflag_t */ #undef HTYPE_TCFLAG_T @@ -561,12 +561,12 @@ /* Define to Haskell type for unsigned short */ #undef HTYPE_UNSIGNED_SHORT +/* Define to Haskell type for useconds_t */ +#undef HTYPE_USECONDS_T + /* Define to Haskell type for wchar_t */ #undef HTYPE_WCHAR_T -/* Define to Haskell type for wint_t */ -#undef HTYPE_WINT_T - /* Define to the address where bug reports for this package should be sent. */ #undef PACKAGE_BUGREPORT @@ -585,6 +585,9 @@ /* Define to the version of this package. */ #undef PACKAGE_VERSION +/* The size of `struct MD5Context', as computed by sizeof. */ +#undef SIZEOF_STRUCT_MD5CONTEXT + /* Define to 1 if you have the ANSI C header files. */ #undef STDC_HEADERS diff -Nru ghc-7.0.3/libraries/base/include/HsBase.h ghc-7.2.1/libraries/base/include/HsBase.h --- ghc-7.0.3/libraries/base/include/HsBase.h 2011-03-26 18:10:12.000000000 +0000 +++ ghc-7.2.1/libraries/base/include/HsBase.h 2011-08-07 17:10:07.000000000 +0000 @@ -652,10 +652,17 @@ } #endif /* !defined(__MINGW32__) */ +#if darwin_HOST_OS +// You should not access _environ directly on Darwin in a bundle/shared library. +// See #2458 and http://developer.apple.com/library/mac/#documentation/Darwin/Reference/ManPages/man7/environ.7.html +#include +INLINE char **__hscore_environ() { return *(_NSGetEnviron()); } +#else /* ToDo: write a feature test that doesn't assume 'environ' to * be in scope at link-time. */ extern char** environ; INLINE char **__hscore_environ() { return environ; } +#endif /* lossless conversions between pointers and integral types */ INLINE void * __hscore_from_uintptr(uintptr_t n) { return (void *)n; } diff -Nru ghc-7.0.3/libraries/base/include/md5.h ghc-7.2.1/libraries/base/include/md5.h --- ghc-7.0.3/libraries/base/include/md5.h 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/base/include/md5.h 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,24 @@ +/* MD5 message digest */ +#ifndef _MD5_H +#define _MD5_H + +#include "HsFFI.h" + +typedef HsWord32 word32; +typedef HsWord8 byte; + +struct MD5Context { + word32 buf[4]; + word32 bytes[2]; + word32 in[16]; +}; + +void MD5Init(struct MD5Context *context); +void MD5Update(struct MD5Context *context, byte const *buf, int len); +void MD5Final(byte digest[16], struct MD5Context *context); +void MD5Transform(word32 buf[4], word32 const in[16]); + +#endif /* _MD5_H */ + + + diff -Nru ghc-7.0.3/libraries/base/include/Typeable.h ghc-7.2.1/libraries/base/include/Typeable.h --- ghc-7.0.3/libraries/base/include/Typeable.h 2011-03-26 18:10:12.000000000 +0000 +++ ghc-7.2.1/libraries/base/include/Typeable.h 2011-08-07 17:10:07.000000000 +0000 @@ -14,52 +14,26 @@ #ifndef TYPEABLE_H #define TYPEABLE_H -#define INSTANCE_TYPEABLE0(tycon,tcname,str) \ -tcname :: TyCon; \ -tcname = mkTyCon str; \ -instance Typeable tycon where { typeOf _ = mkTyConApp tcname [] } - #ifdef __GLASGOW_HASKELL__ --- // For GHC, the extra instances follow from general instance declarations --- // defined in Data.Typeable. +-- // For GHC, we can use DeriveDataTypeable + StandaloneDeriving to +-- // generate the instances. -#define INSTANCE_TYPEABLE1(tycon,tcname,str) \ -tcname :: TyCon; \ -tcname = mkTyCon str; \ -instance Typeable1 tycon where { typeOf1 _ = mkTyConApp tcname [] } +#define INSTANCE_TYPEABLE0(tycon,tcname,str) deriving instance Typeable tycon +#define INSTANCE_TYPEABLE1(tycon,tcname,str) deriving instance Typeable1 tycon +#define INSTANCE_TYPEABLE2(tycon,tcname,str) deriving instance Typeable2 tycon +#define INSTANCE_TYPEABLE3(tycon,tcname,str) deriving instance Typeable3 tycon +#define INSTANCE_TYPEABLE4(tycon,tcname,str) deriving instance Typeable4 tycon +#define INSTANCE_TYPEABLE5(tycon,tcname,str) deriving instance Typeable5 tycon +#define INSTANCE_TYPEABLE6(tycon,tcname,str) deriving instance Typeable6 tycon +#define INSTANCE_TYPEABLE7(tycon,tcname,str) deriving instance Typeable7 tycon -#define INSTANCE_TYPEABLE2(tycon,tcname,str) \ -tcname :: TyCon; \ -tcname = mkTyCon str; \ -instance Typeable2 tycon where { typeOf2 _ = mkTyConApp tcname [] } - -#define INSTANCE_TYPEABLE3(tycon,tcname,str) \ -tcname :: TyCon; \ -tcname = mkTyCon str; \ -instance Typeable3 tycon where { typeOf3 _ = mkTyConApp tcname [] } - -#define INSTANCE_TYPEABLE4(tycon,tcname,str) \ -tcname :: TyCon; \ -tcname = mkTyCon str; \ -instance Typeable4 tycon where { typeOf4 _ = mkTyConApp tcname [] } - -#define INSTANCE_TYPEABLE5(tycon,tcname,str) \ -tcname :: TyCon; \ -tcname = mkTyCon str; \ -instance Typeable5 tycon where { typeOf5 _ = mkTyConApp tcname [] } - -#define INSTANCE_TYPEABLE6(tycon,tcname,str) \ -tcname :: TyCon; \ -tcname = mkTyCon str; \ -instance Typeable6 tycon where { typeOf6 _ = mkTyConApp tcname [] } +#else /* !__GLASGOW_HASKELL__ */ -#define INSTANCE_TYPEABLE7(tycon,tcname,str) \ +#define INSTANCE_TYPEABLE0(tycon,tcname,str) \ tcname :: TyCon; \ tcname = mkTyCon str; \ -instance Typeable7 tycon where { typeOf7 _ = mkTyConApp tcname [] } - -#else /* !__GLASGOW_HASKELL__ */ +instance Typeable tycon where { typeOf _ = mkTyConApp tcname [] } #define INSTANCE_TYPEABLE1(tycon,tcname,str) \ tcname = mkTyCon str; \ diff -Nru ghc-7.0.3/libraries/base/Makefile.nhc98 ghc-7.2.1/libraries/base/Makefile.nhc98 --- ghc-7.0.3/libraries/base/Makefile.nhc98 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/Makefile.nhc98 2011-08-07 17:10:07.000000000 +0000 @@ -17,7 +17,7 @@ Data/Ix.hs Data/List.hs Data/Maybe.hs \ Data/Ratio.hs Data/Tuple.hs Data/Word.hs \ Data/HashTable.hs Data/Typeable.hs Data/Dynamic.hs \ - Data/Monoid.hs \ + Data/Monoid.hs Data/String.hs \ Data/Eq.hs Data/Ord.hs Data/Fixed.hs \ Data/Functor.hs Data/Foldable.hs Data/Traversable.hs \ Data/Function.hs \ diff -Nru ghc-7.0.3/libraries/base/NHC/PosixTypes.hsc ghc-7.2.1/libraries/base/NHC/PosixTypes.hsc --- ghc-7.0.3/libraries/base/NHC/PosixTypes.hsc 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/NHC/PosixTypes.hsc 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,6 @@ +{-# LANGUAGE CPP #-} {-# OPTIONS_NHC98 -I/usr/include #-} + ----------------------------------------------------------------------------- -- | -- Module : NHC.PosixTypes diff -Nru ghc-7.0.3/libraries/base/Numeric.hs ghc-7.2.1/libraries/base/Numeric.hs --- ghc-7.0.3/libraries/base/Numeric.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/Numeric.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,6 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude, MagicHash #-} + ----------------------------------------------------------------------------- -- | -- Module : Numeric diff -Nru ghc-7.0.3/libraries/base/Prelude.hs ghc-7.2.1/libraries/base/Prelude.hs --- ghc-7.0.3/libraries/base/Prelude.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/Prelude.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,6 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude -XBangPatterns #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude, BangPatterns #-} + ----------------------------------------------------------------------------- -- | -- Module : Prelude @@ -155,8 +157,6 @@ #ifdef __GLASGOW_HASKELL__ import GHC.Base --- import GHC.IO --- import GHC.IO.Exception import Text.Read import GHC.Enum import GHC.Num diff -Nru ghc-7.0.3/libraries/base/System/Console/GetOpt.hs ghc-7.2.1/libraries/base/System/Console/GetOpt.hs --- ghc-7.0.3/libraries/base/System/Console/GetOpt.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/System/Console/GetOpt.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,3 +1,4 @@ +{-# LANGUAGE Safe #-} ----------------------------------------------------------------------------- -- | -- Module : System.Console.GetOpt diff -Nru ghc-7.0.3/libraries/base/System/CPUTime.hsc ghc-7.2.1/libraries/base/System/CPUTime.hsc --- ghc-7.0.3/libraries/base/System/CPUTime.hsc 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/System/CPUTime.hsc 2011-08-07 17:10:07.000000000 +0000 @@ -1,3 +1,6 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NondecreasingIndentation, ForeignFunctionInterface #-} + ----------------------------------------------------------------------------- -- | -- Module : System.CPUTime @@ -31,7 +34,7 @@ #endif #ifdef __GLASGOW_HASKELL__ -import Foreign hiding (unsafePerformIO) +import Foreign.Safe import Foreign.C #if !defined(CLK_TCK) import System.IO.Unsafe (unsafePerformIO) @@ -99,9 +102,9 @@ let ru_utime = (#ptr struct rusage, ru_utime) p_rusage let ru_stime = (#ptr struct rusage, ru_stime) p_rusage u_sec <- (#peek struct timeval,tv_sec) ru_utime :: IO CTime - u_usec <- (#peek struct timeval,tv_usec) ru_utime :: IO CTime + u_usec <- (#peek struct timeval,tv_usec) ru_utime :: IO CSUSeconds s_sec <- (#peek struct timeval,tv_sec) ru_stime :: IO CTime - s_usec <- (#peek struct timeval,tv_usec) ru_stime :: IO CTime + s_usec <- (#peek struct timeval,tv_usec) ru_stime :: IO CSUSeconds return ((realToInteger u_sec * 1000000 + realToInteger u_usec + realToInteger s_sec * 1000000 + realToInteger s_usec) * 1000000) diff -Nru ghc-7.0.3/libraries/base/System/Environment.hs ghc-7.2.1/libraries/base/System/Environment.hs --- ghc-7.0.3/libraries/base/System/Environment.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/System/Environment.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,3 +1,6 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE CPP, ForeignFunctionInterface #-} + ----------------------------------------------------------------------------- -- | -- Module : System.Environment @@ -29,13 +32,20 @@ import Prelude #ifdef __GLASGOW_HASKELL__ -import Data.List -import Foreign +import Foreign.Safe import Foreign.C import Control.Exception.Base ( bracket ) -import Control.Monad -- import GHC.IO import GHC.IO.Exception +import GHC.IO.Encoding (fileSystemEncoding) +import qualified GHC.Foreign as GHC +import Data.List +#ifdef mingw32_HOST_OS +import GHC.Environment +import GHC.Windows +#else +import Control.Monad +#endif #endif #ifdef __HUGS__ @@ -50,25 +60,78 @@ ) #endif +#ifdef __GLASGOW_HASKELL__ -- --------------------------------------------------------------------------- -- getArgs, getProgName, getEnv +#ifdef mingw32_HOST_OS + +-- Ignore the arguments to hs_init on Windows for the sake of Unicode compat + +getWin32ProgArgv_certainly :: IO [String] +getWin32ProgArgv_certainly = do + mb_argv <- getWin32ProgArgv + case mb_argv of + Nothing -> fmap dropRTSArgs getFullArgs + Just argv -> return argv + +withWin32ProgArgv :: [String] -> IO a -> IO a +withWin32ProgArgv argv act = bracket begin setWin32ProgArgv (\_ -> act) + where + begin = do + mb_old_argv <- getWin32ProgArgv + setWin32ProgArgv (Just argv) + return mb_old_argv + +getWin32ProgArgv :: IO (Maybe [String]) +getWin32ProgArgv = alloca $ \p_argc -> alloca $ \p_argv -> do + c_getWin32ProgArgv p_argc p_argv + argc <- peek p_argc + argv_p <- peek p_argv + if argv_p == nullPtr + then return Nothing + else do + argv_ps <- peekArray (fromIntegral argc) argv_p + fmap Just $ mapM peekCWString argv_ps + +setWin32ProgArgv :: Maybe [String] -> IO () +setWin32ProgArgv Nothing = c_setWin32ProgArgv 0 nullPtr +setWin32ProgArgv (Just argv) = withMany withCWString argv $ \argv_ps -> withArrayLen argv_ps $ \argc argv_p -> do + c_setWin32ProgArgv (fromIntegral argc) argv_p + +foreign import ccall unsafe "getWin32ProgArgv" + c_getWin32ProgArgv :: Ptr CInt -> Ptr (Ptr CWString) -> IO () + +foreign import ccall unsafe "setWin32ProgArgv" + c_setWin32ProgArgv :: CInt -> Ptr CWString -> IO () + +dropRTSArgs :: [String] -> [String] +dropRTSArgs [] = [] +dropRTSArgs ("+RTS":rest) = dropRTSArgs (dropWhile (/= "-RTS") rest) +dropRTSArgs ("--RTS":rest) = rest +dropRTSArgs ("-RTS":rest) = dropRTSArgs rest +dropRTSArgs (arg:rest) = arg : dropRTSArgs rest + +#endif + -- | Computation 'getArgs' returns a list of the program's command -- line arguments (not including the program name). - -#ifdef __GLASGOW_HASKELL__ getArgs :: IO [String] + +#ifdef mingw32_HOST_OS +getArgs = fmap tail getWin32ProgArgv_certainly +#else getArgs = alloca $ \ p_argc -> alloca $ \ p_argv -> do getProgArgv p_argc p_argv p <- fromIntegral `liftM` peek p_argc argv <- peek p_argv - peekArray (p - 1) (advancePtr argv 1) >>= mapM peekCString - + peekArray (p - 1) (advancePtr argv 1) >>= mapM (GHC.peekCString fileSystemEncoding) foreign import ccall unsafe "getProgArgv" getProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO () +#endif {-| Computation 'getProgName' returns the name of the program as it was @@ -81,6 +144,10 @@ is probably really @FOO.EXE@, and that is what 'getProgName' will return. -} getProgName :: IO String +#ifdef mingw32_HOST_OS +-- Ignore the arguments to hs_init on Windows for the sake of Unicode compat +getProgName = fmap (basename . head) getWin32ProgArgv_certainly +#else getProgName = alloca $ \ p_argc -> alloca $ \ p_argv -> do @@ -90,23 +157,24 @@ unpackProgName :: Ptr (Ptr CChar) -> IO String -- argv[0] unpackProgName argv = do - s <- peekElemOff argv 0 >>= peekCString + s <- peekElemOff argv 0 >>= GHC.peekCString fileSystemEncoding return (basename s) - where - basename :: String -> String - basename f = go f f - where - go acc [] = acc - go acc (x:xs) - | isPathSeparator x = go xs xs - | otherwise = go acc xs - - isPathSeparator :: Char -> Bool - isPathSeparator '/' = True -#ifdef mingw32_HOST_OS - isPathSeparator '\\' = True #endif - isPathSeparator _ = False + +basename :: FilePath -> FilePath +basename f = go f f + where + go acc [] = acc + go acc (x:xs) + | isPathSeparator x = go xs xs + | otherwise = go acc xs + + isPathSeparator :: Char -> Bool + isPathSeparator '/' = True +#ifdef mingw32_HOST_OS + isPathSeparator '\\' = True +#endif + isPathSeparator _ = False -- | Computation 'getEnv' @var@ returns the value @@ -118,16 +186,43 @@ -- does not exist. getEnv :: String -> IO String +#ifdef mingw32_HOST_OS +getEnv name = withCWString name $ \s -> try_size s 256 + where + try_size s size = allocaArray (fromIntegral size) $ \p_value -> do + res <- c_GetEnvironmentVariable s p_value size + case res of + 0 -> do + err <- c_GetLastError + if err == eRROR_ENVVAR_NOT_FOUND + then ioe_missingEnvVar name + else throwGetLastError "getEnv" + _ | res > size -> try_size s res -- Rare: size increased between calls to GetEnvironmentVariable + | otherwise -> peekCWString p_value + +eRROR_ENVVAR_NOT_FOUND :: DWORD +eRROR_ENVVAR_NOT_FOUND = 203 + +foreign import stdcall unsafe "windows.h GetLastError" + c_GetLastError:: IO DWORD + +foreign import stdcall unsafe "windows.h GetEnvironmentVariableW" + c_GetEnvironmentVariable :: LPTSTR -> LPTSTR -> DWORD -> IO DWORD +#else getEnv name = withCString name $ \s -> do litstring <- c_getenv s if litstring /= nullPtr - then peekCString litstring - else ioException (IOError Nothing NoSuchThing "getEnv" - "no environment variable" Nothing (Just name)) + then GHC.peekCString fileSystemEncoding litstring + else ioe_missingEnvVar name foreign import ccall unsafe "getenv" c_getenv :: CString -> IO (Ptr CChar) +#endif + +ioe_missingEnvVar :: String -> IO a +ioe_missingEnvVar name = ioException (IOError Nothing NoSuchThing "getEnv" + "no environment variable" Nothing (Just name)) {-| 'withArgs' @args act@ - while executing action @act@, have 'getArgs' @@ -151,48 +246,93 @@ -- the duration of an action. withArgv :: [String] -> IO a -> IO a -withArgv new_args act = do + +#ifdef mingw32_HOST_OS +-- We have to reflect the updated arguments in the RTS-side variables as +-- well, because the RTS still consults them for error messages and the like. +-- If we don't do this then ghc-e005 fails. +withArgv new_args act = withWin32ProgArgv new_args $ withProgArgv new_args act +#else +withArgv = withProgArgv +#endif + +withProgArgv :: [String] -> IO a -> IO a +withProgArgv new_args act = do pName <- System.Environment.getProgName existing_args <- System.Environment.getArgs - bracket (setArgs new_args) - (\argv -> do _ <- setArgs (pName:existing_args) - freeArgv argv) + bracket (setProgArgv new_args) + (\argv -> do _ <- setProgArgv (pName:existing_args) + freeProgArgv argv) (const act) -freeArgv :: Ptr CString -> IO () -freeArgv argv = do +freeProgArgv :: Ptr CString -> IO () +freeProgArgv argv = do size <- lengthArray0 nullPtr argv sequence_ [peek (argv `advancePtr` i) >>= free | i <- [size, size-1 .. 0]] free argv -setArgs :: [String] -> IO (Ptr CString) -setArgs argv = do - vs <- mapM newCString argv >>= newArray0 nullPtr - setArgsPrim (genericLength argv) vs +setProgArgv :: [String] -> IO (Ptr CString) +setProgArgv argv = do + vs <- mapM (GHC.newCString fileSystemEncoding) argv >>= newArray0 nullPtr + c_setProgArgv (genericLength argv) vs return vs foreign import ccall unsafe "setProgArgv" - setArgsPrim :: CInt -> Ptr CString -> IO () + c_setProgArgv :: CInt -> Ptr CString -> IO () -- |'getEnvironment' retrieves the entire environment as a -- list of @(key,value)@ pairs. -- -- If an environment entry does not contain an @\'=\'@ character, -- the @key@ is the whole entry and the @value@ is the empty string. - getEnvironment :: IO [(String, String)] + +#ifdef mingw32_HOST_OS +getEnvironment = bracket c_GetEnvironmentStrings c_FreeEnvironmentStrings $ \pBlock -> + if pBlock == nullPtr then return [] + else go pBlock + where + go pBlock = do + -- The block is terminated by a null byte where there + -- should be an environment variable of the form X=Y + c <- peek pBlock + if c == 0 then return [] + else do + -- Seek the next pair (or terminating null): + pBlock' <- seekNull pBlock False + -- We now know the length in bytes, but ignore it when + -- getting the actual String: + str <- peekCWString pBlock + fmap (divvy str :) $ go pBlock' + + -- Returns pointer to the byte *after* the next null + seekNull pBlock done = do + let pBlock' = pBlock `plusPtr` sizeOf (undefined :: CWchar) + if done then return pBlock' + else do + c <- peek pBlock' + seekNull pBlock' (c == (0 :: Word8 )) + +foreign import stdcall unsafe "windows.h GetEnvironmentStringsW" + c_GetEnvironmentStrings :: IO (Ptr CWchar) + +foreign import stdcall unsafe "windows.h FreeEnvironmentStringsW" + c_FreeEnvironmentStrings :: Ptr CWchar -> IO Bool +#else getEnvironment = do pBlock <- getEnvBlock if pBlock == nullPtr then return [] else do - stuff <- peekArray0 nullPtr pBlock >>= mapM peekCString + stuff <- peekArray0 nullPtr pBlock >>= mapM (GHC.peekCString fileSystemEncoding) return (map divvy stuff) - where - divvy str = - case break (=='=') str of - (xs,[]) -> (xs,[]) -- don't barf (like Posix.getEnvironment) - (name,_:value) -> (name,value) foreign import ccall unsafe "__hscore_environ" getEnvBlock :: IO (Ptr CString) +#endif + +divvy :: String -> (String, String) +divvy str = + case break (=='=') str of + (xs,[]) -> (xs,[]) -- don't barf (like Posix.getEnvironment) + (name,_:value) -> (name,value) #endif /* __GLASGOW_HASKELL__ */ diff -Nru ghc-7.0.3/libraries/base/System/Event/Array.hs ghc-7.2.1/libraries/base/System/Event/Array.hs --- ghc-7.0.3/libraries/base/System/Event/Array.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/System/Event/Array.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,313 +0,0 @@ -{-# LANGUAGE BangPatterns, CPP, ForeignFunctionInterface, NoImplicitPrelude #-} - -module System.Event.Array - ( - Array - , capacity - , clear - , concat - , copy - , duplicate - , empty - , ensureCapacity - , findIndex - , forM_ - , length - , loop - , new - , removeAt - , snoc - , unsafeLoad - , unsafeRead - , unsafeWrite - , useAsPtr - ) where - -import Control.Monad hiding (forM_) -import Data.Bits ((.|.), shiftR) -import Data.IORef (IORef, atomicModifyIORef, newIORef, readIORef, writeIORef) -import Data.Maybe -import Foreign.C.Types (CSize) -import Foreign.ForeignPtr (ForeignPtr, withForeignPtr) -import Foreign.Ptr (Ptr, nullPtr, plusPtr) -import Foreign.Storable (Storable(..)) -import GHC.Base -import GHC.Err (undefined) -import GHC.ForeignPtr (mallocPlainForeignPtrBytes, newForeignPtr_) -import GHC.Num (Num(..)) -import GHC.Real (fromIntegral) -import GHC.Show (show) - -#include "MachDeps.h" - -#define BOUNDS_CHECKING 1 - -#if defined(BOUNDS_CHECKING) --- This fugly hack is brought by GHC's apparent reluctance to deal --- with MagicHash and UnboxedTuples when inferring types. Eek! -#define CHECK_BOUNDS(_func_,_len_,_k_) \ -if (_k_) < 0 || (_k_) >= (_len_) then error ("System.Event.Array." ++ (_func_) ++ ": bounds error, index " ++ show (_k_) ++ ", capacity " ++ show (_len_)) else -#else -#define CHECK_BOUNDS(_func_,_len_,_k_) -#endif - --- Invariant: size <= capacity -newtype Array a = Array (IORef (AC a)) - --- The actual array content. -data AC a = AC - !(ForeignPtr a) -- Elements - !Int -- Number of elements (length) - !Int -- Maximum number of elements (capacity) - -empty :: IO (Array a) -empty = do - p <- newForeignPtr_ nullPtr - Array `fmap` newIORef (AC p 0 0) - -allocArray :: Storable a => Int -> IO (ForeignPtr a) -allocArray n = allocHack undefined - where - allocHack :: Storable a => a -> IO (ForeignPtr a) - allocHack dummy = mallocPlainForeignPtrBytes (n * sizeOf dummy) - -reallocArray :: Storable a => ForeignPtr a -> Int -> Int -> IO (ForeignPtr a) -reallocArray p newSize oldSize = reallocHack undefined p - where - reallocHack :: Storable a => a -> ForeignPtr a -> IO (ForeignPtr a) - reallocHack dummy src = do - let size = sizeOf dummy - dst <- mallocPlainForeignPtrBytes (newSize * size) - withForeignPtr src $ \s -> - when (s /= nullPtr && oldSize > 0) . - withForeignPtr dst $ \d -> do - _ <- memcpy d s (fromIntegral (oldSize * size)) - return () - return dst - -new :: Storable a => Int -> IO (Array a) -new c = do - es <- allocArray cap - fmap Array (newIORef (AC es 0 cap)) - where - cap = firstPowerOf2 c - -duplicate :: Storable a => Array a -> IO (Array a) -duplicate a = dupHack undefined a - where - dupHack :: Storable b => b -> Array b -> IO (Array b) - dupHack dummy (Array ref) = do - AC es len cap <- readIORef ref - ary <- allocArray cap - withForeignPtr ary $ \dest -> - withForeignPtr es $ \src -> do - _ <- memcpy dest src (fromIntegral (len * sizeOf dummy)) - return () - Array `fmap` newIORef (AC ary len cap) - -length :: Array a -> IO Int -length (Array ref) = do - AC _ len _ <- readIORef ref - return len - -capacity :: Array a -> IO Int -capacity (Array ref) = do - AC _ _ cap <- readIORef ref - return cap - -unsafeRead :: Storable a => Array a -> Int -> IO a -unsafeRead (Array ref) ix = do - AC es _ cap <- readIORef ref - CHECK_BOUNDS("unsafeRead",cap,ix) - withForeignPtr es $ \p -> - peekElemOff p ix - -unsafeWrite :: Storable a => Array a -> Int -> a -> IO () -unsafeWrite (Array ref) ix a = do - ac <- readIORef ref - unsafeWrite' ac ix a - -unsafeWrite' :: Storable a => AC a -> Int -> a -> IO () -unsafeWrite' (AC es _ cap) ix a = do - CHECK_BOUNDS("unsafeWrite'",cap,ix) - withForeignPtr es $ \p -> - pokeElemOff p ix a - -unsafeLoad :: Storable a => Array a -> (Ptr a -> Int -> IO Int) -> IO Int -unsafeLoad (Array ref) load = do - AC es _ cap <- readIORef ref - len' <- withForeignPtr es $ \p -> load p cap - writeIORef ref (AC es len' cap) - return len' - -ensureCapacity :: Storable a => Array a -> Int -> IO () -ensureCapacity (Array ref) c = do - ac@(AC _ _ cap) <- readIORef ref - ac'@(AC _ _ cap') <- ensureCapacity' ac c - when (cap' /= cap) $ - writeIORef ref ac' - -ensureCapacity' :: Storable a => AC a -> Int -> IO (AC a) -ensureCapacity' ac@(AC es len cap) c = do - if c > cap - then do - es' <- reallocArray es cap' cap - return (AC es' len cap') - else - return ac - where - cap' = firstPowerOf2 c - -useAsPtr :: Array a -> (Ptr a -> Int -> IO b) -> IO b -useAsPtr (Array ref) f = do - AC es len _ <- readIORef ref - withForeignPtr es $ \p -> f p len - -snoc :: Storable a => Array a -> a -> IO () -snoc (Array ref) e = do - ac@(AC _ len _) <- readIORef ref - let len' = len + 1 - ac'@(AC es _ cap) <- ensureCapacity' ac len' - unsafeWrite' ac' len e - writeIORef ref (AC es len' cap) - -clear :: Storable a => Array a -> IO () -clear (Array ref) = do - !_ <- atomicModifyIORef ref $ \(AC es _ cap) -> - let e = AC es 0 cap in (e, e) - return () - -forM_ :: Storable a => Array a -> (a -> IO ()) -> IO () -forM_ ary g = forHack ary g undefined - where - forHack :: Storable b => Array b -> (b -> IO ()) -> b -> IO () - forHack (Array ref) f dummy = do - AC es len _ <- readIORef ref - let size = sizeOf dummy - offset = len * size - withForeignPtr es $ \p -> do - let go n | n >= offset = return () - | otherwise = do - f =<< peek (p `plusPtr` n) - go (n + size) - go 0 - -loop :: Storable a => Array a -> b -> (b -> a -> IO (b,Bool)) -> IO () -loop ary z g = loopHack ary z g undefined - where - loopHack :: Storable b => Array b -> c -> (c -> b -> IO (c,Bool)) -> b - -> IO () - loopHack (Array ref) y f dummy = do - AC es len _ <- readIORef ref - let size = sizeOf dummy - offset = len * size - withForeignPtr es $ \p -> do - let go n k - | n >= offset = return () - | otherwise = do - (k',cont) <- f k =<< peek (p `plusPtr` n) - when cont $ go (n + size) k' - go 0 y - -findIndex :: Storable a => (a -> Bool) -> Array a -> IO (Maybe (Int,a)) -findIndex = findHack undefined - where - findHack :: Storable b => b -> (b -> Bool) -> Array b -> IO (Maybe (Int,b)) - findHack dummy p (Array ref) = do - AC es len _ <- readIORef ref - let size = sizeOf dummy - offset = len * size - withForeignPtr es $ \ptr -> - let go !n !i - | n >= offset = return Nothing - | otherwise = do - val <- peek (ptr `plusPtr` n) - if p val - then return $ Just (i, val) - else go (n + size) (i + 1) - in go 0 0 - -concat :: Storable a => Array a -> Array a -> IO () -concat (Array d) (Array s) = do - da@(AC _ dlen _) <- readIORef d - sa@(AC _ slen _) <- readIORef s - writeIORef d =<< copy' da dlen sa 0 slen - --- | Copy part of the source array into the destination array. The --- destination array is resized if not large enough. -copy :: Storable a => Array a -> Int -> Array a -> Int -> Int -> IO () -copy (Array d) dstart (Array s) sstart maxCount = do - da <- readIORef d - sa <- readIORef s - writeIORef d =<< copy' da dstart sa sstart maxCount - --- | Copy part of the source array into the destination array. The --- destination array is resized if not large enough. -copy' :: Storable a => AC a -> Int -> AC a -> Int -> Int -> IO (AC a) -copy' d dstart s sstart maxCount = copyHack d s undefined - where - copyHack :: Storable b => AC b -> AC b -> b -> IO (AC b) - copyHack dac@(AC _ oldLen _) (AC src slen _) dummy = do - when (maxCount < 0 || dstart < 0 || dstart > oldLen || sstart < 0 || - sstart > slen) $ error "copy: bad offsets or lengths" - let size = sizeOf dummy - count = min maxCount (slen - sstart) - if count == 0 - then return dac - else do - AC dst dlen dcap <- ensureCapacity' dac (dstart + count) - withForeignPtr dst $ \dptr -> - withForeignPtr src $ \sptr -> do - _ <- memcpy (dptr `plusPtr` (dstart * size)) - (sptr `plusPtr` (sstart * size)) - (fromIntegral (count * size)) - return $ AC dst (max dlen (dstart + count)) dcap - -removeAt :: Storable a => Array a -> Int -> IO () -removeAt a i = removeHack a undefined - where - removeHack :: Storable b => Array b -> b -> IO () - removeHack (Array ary) dummy = do - AC fp oldLen cap <- readIORef ary - when (i < 0 || i >= oldLen) $ error "removeAt: invalid index" - let size = sizeOf dummy - newLen = oldLen - 1 - when (newLen > 0 && i < newLen) . - withForeignPtr fp $ \ptr -> do - _ <- memmove (ptr `plusPtr` (size * i)) - (ptr `plusPtr` (size * (i+1))) - (fromIntegral (size * (newLen-i))) - return () - writeIORef ary (AC fp newLen cap) - -{-The firstPowerOf2 function works by setting all bits on the right-hand -side of the most significant flagged bit to 1, and then incrementing -the entire value at the end so it "rolls over" to the nearest power of -two. --} - --- | Computes the next-highest power of two for a particular integer, --- @n@. If @n@ is already a power of two, returns @n@. If @n@ is --- zero, returns zero, even though zero is not a power of two. -firstPowerOf2 :: Int -> Int -firstPowerOf2 !n = - let !n1 = n - 1 - !n2 = n1 .|. (n1 `shiftR` 1) - !n3 = n2 .|. (n2 `shiftR` 2) - !n4 = n3 .|. (n3 `shiftR` 4) - !n5 = n4 .|. (n4 `shiftR` 8) - !n6 = n5 .|. (n5 `shiftR` 16) -#if WORD_SIZE_IN_BITS == 32 - in n6 + 1 -#elif WORD_SIZE_IN_BITS == 64 - !n7 = n6 .|. (n6 `shiftR` 32) - in n7 + 1 -#else -# error firstPowerOf2 not defined on this architecture -#endif - -foreign import ccall unsafe "string.h memcpy" - memcpy :: Ptr a -> Ptr a -> CSize -> IO (Ptr a) - -foreign import ccall unsafe "string.h memmove" - memmove :: Ptr a -> Ptr a -> CSize -> IO (Ptr a) diff -Nru ghc-7.0.3/libraries/base/System/Event/Clock.hsc ghc-7.2.1/libraries/base/System/Event/Clock.hsc --- ghc-7.0.3/libraries/base/System/Event/Clock.hsc 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/System/Event/Clock.hsc 1970-01-01 00:00:00.000000000 +0000 @@ -1,48 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} - -module System.Event.Clock (getCurrentTime) where - -#include - -import Foreign (Ptr, Storable(..), nullPtr, with) -import Foreign.C.Error (throwErrnoIfMinus1_) -import Foreign.C.Types (CInt, CLong) -import GHC.Base -import GHC.Err -import GHC.Num -import GHC.Real - --- TODO: Implement this for Windows. - --- | Return the current time, in seconds since Jan. 1, 1970. -getCurrentTime :: IO Double -getCurrentTime = do - tv <- with (CTimeval 0 0) $ \tvptr -> do - throwErrnoIfMinus1_ "gettimeofday" (gettimeofday tvptr nullPtr) - peek tvptr - let !t = fromIntegral (sec tv) + fromIntegral (usec tv) / 1000000.0 - return t - ------------------------------------------------------------------------- --- FFI binding - -data CTimeval = CTimeval - { sec :: {-# UNPACK #-} !CLong - , usec :: {-# UNPACK #-} !CLong - } - -instance Storable CTimeval where - sizeOf _ = #size struct timeval - alignment _ = alignment (undefined :: CLong) - - peek ptr = do - sec' <- #{peek struct timeval, tv_sec} ptr - usec' <- #{peek struct timeval, tv_usec} ptr - return $ CTimeval sec' usec' - - poke ptr tv = do - #{poke struct timeval, tv_sec} ptr (sec tv) - #{poke struct timeval, tv_usec} ptr (usec tv) - -foreign import ccall unsafe "sys/time.h gettimeofday" gettimeofday - :: Ptr CTimeval -> Ptr () -> IO CInt diff -Nru ghc-7.0.3/libraries/base/System/Event/Control.hs ghc-7.2.1/libraries/base/System/Event/Control.hs --- ghc-7.0.3/libraries/base/System/Event/Control.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/System/Event/Control.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,210 +0,0 @@ -{-# LANGUAGE CPP, ForeignFunctionInterface, NoImplicitPrelude, - ScopedTypeVariables #-} - -module System.Event.Control - ( - -- * Managing the IO manager - Signal - , ControlMessage(..) - , Control - , newControl - , closeControl - -- ** Control message reception - , readControlMessage - -- *** File descriptors - , controlReadFd - , wakeupReadFd - -- ** Control message sending - , sendWakeup - , sendDie - -- * Utilities - , setNonBlockingFD - ) where - -#include "EventConfig.h" - -import Control.Monad (when) -import Foreign.ForeignPtr (ForeignPtr) -import GHC.Base -import GHC.Conc.Signal (Signal) -import GHC.Real (fromIntegral) -import GHC.Show (Show) -import GHC.Word (Word8) -import Foreign.C.Error (throwErrnoIfMinus1_) -import Foreign.C.Types (CInt, CSize) -import Foreign.ForeignPtr (mallocForeignPtrBytes, withForeignPtr) -import Foreign.Marshal (alloca, allocaBytes) -import Foreign.Marshal.Array (allocaArray) -import Foreign.Ptr (castPtr) -import Foreign.Storable (peek, peekElemOff, poke) -import System.Posix.Internals (c_close, c_pipe, c_read, c_write, - setCloseOnExec, setNonBlockingFD) -import System.Posix.Types (Fd) - -#if defined(HAVE_EVENTFD) -import Data.Word (Word64) -import Foreign.C.Error (throwErrnoIfMinus1) -#else -import Foreign.C.Error (eAGAIN, eWOULDBLOCK, getErrno, throwErrno) -#endif - -data ControlMessage = CMsgWakeup - | CMsgDie - | CMsgSignal {-# UNPACK #-} !(ForeignPtr Word8) - {-# UNPACK #-} !Signal - deriving (Eq, Show) - --- | The structure used to tell the IO manager thread what to do. -data Control = W { - controlReadFd :: {-# UNPACK #-} !Fd - , controlWriteFd :: {-# UNPACK #-} !Fd -#if defined(HAVE_EVENTFD) - , controlEventFd :: {-# UNPACK #-} !Fd -#else - , wakeupReadFd :: {-# UNPACK #-} !Fd - , wakeupWriteFd :: {-# UNPACK #-} !Fd -#endif - } deriving (Show) - -#if defined(HAVE_EVENTFD) -wakeupReadFd :: Control -> Fd -wakeupReadFd = controlEventFd -{-# INLINE wakeupReadFd #-} -#endif - -setNonBlock :: CInt -> IO () -setNonBlock fd = -#if __GLASGOW_HASKELL__ >= 611 - setNonBlockingFD fd True -#else - setNonBlockingFD fd -#endif - --- | Create the structure (usually a pipe) used for waking up the IO --- manager thread from another thread. -newControl :: IO Control -newControl = allocaArray 2 $ \fds -> do - let createPipe = do - throwErrnoIfMinus1_ "pipe" $ c_pipe fds - rd <- peekElemOff fds 0 - wr <- peekElemOff fds 1 - -- The write end must be non-blocking, since we may need to - -- poke the event manager from a signal handler. - setNonBlock wr - setCloseOnExec rd - setCloseOnExec wr - return (rd, wr) - (ctrl_rd, ctrl_wr) <- createPipe - c_setIOManagerControlFd ctrl_wr -#if defined(HAVE_EVENTFD) - ev <- throwErrnoIfMinus1 "eventfd" $ c_eventfd 0 0 - setNonBlock ev - setCloseOnExec ev - c_setIOManagerWakeupFd ev -#else - (wake_rd, wake_wr) <- createPipe - c_setIOManagerWakeupFd wake_wr -#endif - return W { controlReadFd = fromIntegral ctrl_rd - , controlWriteFd = fromIntegral ctrl_wr -#if defined(HAVE_EVENTFD) - , controlEventFd = fromIntegral ev -#else - , wakeupReadFd = fromIntegral wake_rd - , wakeupWriteFd = fromIntegral wake_wr -#endif - } - --- | Close the control structure used by the IO manager thread. -closeControl :: Control -> IO () -closeControl w = do - _ <- c_close . fromIntegral . controlReadFd $ w - _ <- c_close . fromIntegral . controlWriteFd $ w -#if defined(HAVE_EVENTFD) - _ <- c_close . fromIntegral . controlEventFd $ w -#else - _ <- c_close . fromIntegral . wakeupReadFd $ w - _ <- c_close . fromIntegral . wakeupWriteFd $ w -#endif - return () - -io_MANAGER_WAKEUP, io_MANAGER_DIE :: Word8 -io_MANAGER_WAKEUP = 0xff -io_MANAGER_DIE = 0xfe - -foreign import ccall "__hscore_sizeof_siginfo_t" - sizeof_siginfo_t :: CSize - -readControlMessage :: Control -> Fd -> IO ControlMessage -readControlMessage ctrl fd - | fd == wakeupReadFd ctrl = allocaBytes wakeupBufferSize $ \p -> do - throwErrnoIfMinus1_ "readWakeupMessage" $ - c_read (fromIntegral fd) p (fromIntegral wakeupBufferSize) - return CMsgWakeup - | otherwise = - alloca $ \p -> do - throwErrnoIfMinus1_ "readControlMessage" $ - c_read (fromIntegral fd) p 1 - s <- peek p - case s of - -- Wakeup messages shouldn't be sent on the control - -- file descriptor but we handle them anyway. - _ | s == io_MANAGER_WAKEUP -> return CMsgWakeup - _ | s == io_MANAGER_DIE -> return CMsgDie - _ -> do -- Signal - fp <- mallocForeignPtrBytes (fromIntegral sizeof_siginfo_t) - withForeignPtr fp $ \p_siginfo -> do - r <- c_read (fromIntegral fd) (castPtr p_siginfo) - sizeof_siginfo_t - when (r /= fromIntegral sizeof_siginfo_t) $ - error "failed to read siginfo_t" - let !s' = fromIntegral s - return $ CMsgSignal fp s' - - where wakeupBufferSize = -#if defined(HAVE_EVENTFD) - 8 -#else - 4096 -#endif - -sendWakeup :: Control -> IO () -#if defined(HAVE_EVENTFD) -sendWakeup c = alloca $ \p -> do - poke p (1 :: Word64) - throwErrnoIfMinus1_ "sendWakeup" $ - c_write (fromIntegral (controlEventFd c)) (castPtr p) 8 -#else -sendWakeup c = do - n <- sendMessage (wakeupWriteFd c) CMsgWakeup - case n of - _ | n /= -1 -> return () - | otherwise -> do - errno <- getErrno - when (errno /= eAGAIN && errno /= eWOULDBLOCK) $ - throwErrno "sendWakeup" -#endif - -sendDie :: Control -> IO () -sendDie c = throwErrnoIfMinus1_ "sendDie" $ - sendMessage (controlWriteFd c) CMsgDie - -sendMessage :: Fd -> ControlMessage -> IO Int -sendMessage fd msg = alloca $ \p -> do - case msg of - CMsgWakeup -> poke p io_MANAGER_WAKEUP - CMsgDie -> poke p io_MANAGER_DIE - CMsgSignal _fp _s -> error "Signals can only be sent from within the RTS" - fromIntegral `fmap` c_write (fromIntegral fd) p 1 - -#if defined(HAVE_EVENTFD) -foreign import ccall unsafe "sys/eventfd.h eventfd" - c_eventfd :: CInt -> CInt -> IO CInt -#endif - --- Used to tell the RTS how it can send messages to the I/O manager. -foreign import ccall "setIOManagerControlFd" - c_setIOManagerControlFd :: CInt -> IO () - -foreign import ccall "setIOManagerWakeupFd" - c_setIOManagerWakeupFd :: CInt -> IO () diff -Nru ghc-7.0.3/libraries/base/System/Event/EPoll.hsc ghc-7.2.1/libraries/base/System/Event/EPoll.hsc --- ghc-7.0.3/libraries/base/System/Event/EPoll.hsc 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/System/Event/EPoll.hsc 1970-01-01 00:00:00.000000000 +0000 @@ -1,213 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface, GeneralizedNewtypeDeriving, - NoImplicitPrelude #-} - --- --- | A binding to the epoll I/O event notification facility --- --- epoll is a variant of poll that can be used either as an edge-triggered or --- a level-triggered interface and scales well to large numbers of watched file --- descriptors. --- --- epoll decouples monitor an fd from the process of registering it. --- -module System.Event.EPoll - ( - new - , available - ) where - -import qualified System.Event.Internal as E - -#include "EventConfig.h" -#if !defined(HAVE_EPOLL) -import GHC.Base - -new :: IO E.Backend -new = error "EPoll back end not implemented for this platform" - -available :: Bool -available = False -{-# INLINE available #-} -#else - -#include - -import Control.Monad (when) -import Data.Bits (Bits, (.|.), (.&.)) -import Data.Monoid (Monoid(..)) -import Data.Word (Word32) -import Foreign.C.Error (throwErrnoIfMinus1, throwErrnoIfMinus1_) -import Foreign.C.Types (CInt) -import Foreign.Marshal.Utils (with) -import Foreign.Ptr (Ptr) -import Foreign.Storable (Storable(..)) -import GHC.Base -import GHC.Err (undefined) -import GHC.Num (Num(..)) -import GHC.Real (ceiling, fromIntegral) -import GHC.Show (Show) -import System.Posix.Internals (c_close) -#if !defined(HAVE_EPOLL_CREATE1) -import System.Posix.Internals (setCloseOnExec) -#endif -import System.Posix.Types (Fd(..)) - -import qualified System.Event.Array as A -import System.Event.Internal (Timeout(..)) - -available :: Bool -available = True -{-# INLINE available #-} - -data EPoll = EPoll { - epollFd :: {-# UNPACK #-} !EPollFd - , epollEvents :: {-# UNPACK #-} !(A.Array Event) - } - --- | Create a new epoll backend. -new :: IO E.Backend -new = do - epfd <- epollCreate - evts <- A.new 64 - let !be = E.backend poll modifyFd delete (EPoll epfd evts) - return be - -delete :: EPoll -> IO () -delete be = do - _ <- c_close . fromEPollFd . epollFd $ be - return () - --- | Change the set of events we are interested in for a given file --- descriptor. -modifyFd :: EPoll -> Fd -> E.Event -> E.Event -> IO () -modifyFd ep fd oevt nevt = with (Event (fromEvent nevt) fd) $ - epollControl (epollFd ep) op fd - where op | oevt == mempty = controlOpAdd - | nevt == mempty = controlOpDelete - | otherwise = controlOpModify - --- | Select a set of file descriptors which are ready for I/O --- operations and call @f@ for all ready file descriptors, passing the --- events that are ready. -poll :: EPoll -- ^ state - -> Timeout -- ^ timeout in milliseconds - -> (Fd -> E.Event -> IO ()) -- ^ I/O callback - -> IO () -poll ep timeout f = do - let events = epollEvents ep - - -- Will return zero if the system call was interupted, in which case - -- we just return (and try again later.) - n <- A.unsafeLoad events $ \es cap -> - epollWait (epollFd ep) es cap $ fromTimeout timeout - - when (n > 0) $ do - A.forM_ events $ \e -> f (eventFd e) (toEvent (eventTypes e)) - cap <- A.capacity events - when (cap == n) $ A.ensureCapacity events (2 * cap) - -newtype EPollFd = EPollFd { - fromEPollFd :: CInt - } deriving (Eq, Show) - -data Event = Event { - eventTypes :: EventType - , eventFd :: Fd - } deriving (Show) - -instance Storable Event where - sizeOf _ = #size struct epoll_event - alignment _ = alignment (undefined :: CInt) - - peek ptr = do - ets <- #{peek struct epoll_event, events} ptr - ed <- #{peek struct epoll_event, data.fd} ptr - let !ev = Event (EventType ets) ed - return ev - - poke ptr e = do - #{poke struct epoll_event, events} ptr (unEventType $ eventTypes e) - #{poke struct epoll_event, data.fd} ptr (eventFd e) - -newtype ControlOp = ControlOp CInt - -#{enum ControlOp, ControlOp - , controlOpAdd = EPOLL_CTL_ADD - , controlOpModify = EPOLL_CTL_MOD - , controlOpDelete = EPOLL_CTL_DEL - } - -newtype EventType = EventType { - unEventType :: Word32 - } deriving (Show, Eq, Num, Bits) - -#{enum EventType, EventType - , epollIn = EPOLLIN - , epollOut = EPOLLOUT - , epollErr = EPOLLERR - , epollHup = EPOLLHUP - } - --- | Create a new epoll context, returning a file descriptor associated with the context. --- The fd may be used for subsequent calls to this epoll context. --- --- The size parameter to epoll_create is a hint about the expected number of handles. --- --- The file descriptor returned from epoll_create() should be destroyed via --- a call to close() after polling is finished --- -epollCreate :: IO EPollFd -epollCreate = do - fd <- throwErrnoIfMinus1 "epollCreate" $ -#if defined(HAVE_EPOLL_CREATE1) - c_epoll_create1 (#const EPOLL_CLOEXEC) -#else - c_epoll_create 256 -- argument is ignored - setCloseOnExec fd -#endif - let !epollFd' = EPollFd fd - return epollFd' - -epollControl :: EPollFd -> ControlOp -> Fd -> Ptr Event -> IO () -epollControl (EPollFd epfd) (ControlOp op) (Fd fd) event = - throwErrnoIfMinus1_ "epollControl" $ c_epoll_ctl epfd op fd event - -epollWait :: EPollFd -> Ptr Event -> Int -> Int -> IO Int -epollWait (EPollFd epfd) events numEvents timeout = - fmap fromIntegral . - E.throwErrnoIfMinus1NoRetry "epollWait" $ - c_epoll_wait epfd events (fromIntegral numEvents) (fromIntegral timeout) - -fromEvent :: E.Event -> EventType -fromEvent e = remap E.evtRead epollIn .|. - remap E.evtWrite epollOut - where remap evt to - | e `E.eventIs` evt = to - | otherwise = 0 - -toEvent :: EventType -> E.Event -toEvent e = remap (epollIn .|. epollErr .|. epollHup) E.evtRead `mappend` - remap (epollOut .|. epollErr .|. epollHup) E.evtWrite - where remap evt to - | e .&. evt /= 0 = to - | otherwise = mempty - -fromTimeout :: Timeout -> Int -fromTimeout Forever = -1 -fromTimeout (Timeout s) = ceiling $ 1000 * s - -#if defined(HAVE_EPOLL_CREATE1) -foreign import ccall unsafe "sys/epoll.h epoll_create1" - c_epoll_create1 :: CInt -> IO CInt -#else -foreign import ccall unsafe "sys/epoll.h epoll_create" - c_epoll_create :: CInt -> IO CInt -#endif - -foreign import ccall unsafe "sys/epoll.h epoll_ctl" - c_epoll_ctl :: CInt -> CInt -> CInt -> Ptr Event -> IO CInt - -foreign import ccall safe "sys/epoll.h epoll_wait" - c_epoll_wait :: CInt -> Ptr Event -> CInt -> CInt -> IO CInt - -#endif /* defined(HAVE_EPOLL) */ diff -Nru ghc-7.0.3/libraries/base/System/Event/Internal.hs ghc-7.2.1/libraries/base/System/Event/Internal.hs --- ghc-7.0.3/libraries/base/System/Event/Internal.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/System/Event/Internal.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,139 +0,0 @@ -{-# LANGUAGE ExistentialQuantification, NoImplicitPrelude #-} - -module System.Event.Internal - ( - -- * Event back end - Backend - , backend - , delete - , poll - , modifyFd - -- * Event type - , Event - , evtRead - , evtWrite - , evtClose - , eventIs - -- * Timeout type - , Timeout(..) - -- * Helpers - , throwErrnoIfMinus1NoRetry - ) where - -import Data.Bits ((.|.), (.&.)) -import Data.List (foldl', intercalate) -import Data.Monoid (Monoid(..)) -import Foreign.C.Error (eINTR, getErrno, throwErrno) -import System.Posix.Types (Fd) -import GHC.Base -import GHC.Num (Num(..)) -import GHC.Show (Show(..)) -import GHC.List (filter, null) - --- | An I\/O event. -newtype Event = Event Int - deriving (Eq) - -evtNothing :: Event -evtNothing = Event 0 -{-# INLINE evtNothing #-} - --- | Data is available to be read. -evtRead :: Event -evtRead = Event 1 -{-# INLINE evtRead #-} - --- | The file descriptor is ready to accept a write. -evtWrite :: Event -evtWrite = Event 2 -{-# INLINE evtWrite #-} - --- | Another thread closed the file descriptor. -evtClose :: Event -evtClose = Event 4 -{-# INLINE evtClose #-} - -eventIs :: Event -> Event -> Bool -eventIs (Event a) (Event b) = a .&. b /= 0 - -instance Show Event where - show e = '[' : (intercalate "," . filter (not . null) $ - [evtRead `so` "evtRead", - evtWrite `so` "evtWrite", - evtClose `so` "evtClose"]) ++ "]" - where ev `so` disp | e `eventIs` ev = disp - | otherwise = "" - -instance Monoid Event where - mempty = evtNothing - mappend = evtCombine - mconcat = evtConcat - -evtCombine :: Event -> Event -> Event -evtCombine (Event a) (Event b) = Event (a .|. b) -{-# INLINE evtCombine #-} - -evtConcat :: [Event] -> Event -evtConcat = foldl' evtCombine evtNothing -{-# INLINE evtConcat #-} - --- | A type alias for timeouts, specified in seconds. -data Timeout = Timeout {-# UNPACK #-} !Double - | Forever - deriving (Show) - --- | Event notification backend. -data Backend = forall a. Backend { - _beState :: !a - - -- | Poll backend for new events. The provided callback is called - -- once per file descriptor with new events. - , _bePoll :: a -- backend state - -> Timeout -- timeout in milliseconds - -> (Fd -> Event -> IO ()) -- I/O callback - -> IO () - - -- | Register, modify, or unregister interest in the given events - -- on the given file descriptor. - , _beModifyFd :: a - -> Fd -- file descriptor - -> Event -- old events to watch for ('mempty' for new) - -> Event -- new events to watch for ('mempty' to delete) - -> IO () - - , _beDelete :: a -> IO () - } - -backend :: (a -> Timeout -> (Fd -> Event -> IO ()) -> IO ()) - -> (a -> Fd -> Event -> Event -> IO ()) - -> (a -> IO ()) - -> a - -> Backend -backend bPoll bModifyFd bDelete state = Backend state bPoll bModifyFd bDelete -{-# INLINE backend #-} - -poll :: Backend -> Timeout -> (Fd -> Event -> IO ()) -> IO () -poll (Backend bState bPoll _ _) = bPoll bState -{-# INLINE poll #-} - -modifyFd :: Backend -> Fd -> Event -> Event -> IO () -modifyFd (Backend bState _ bModifyFd _) = bModifyFd bState -{-# INLINE modifyFd #-} - -delete :: Backend -> IO () -delete (Backend bState _ _ bDelete) = bDelete bState -{-# INLINE delete #-} - --- | Throw an 'IOError' corresponding to the current value of --- 'getErrno' if the result value of the 'IO' action is -1 and --- 'getErrno' is not 'eINTR'. If the result value is -1 and --- 'getErrno' returns 'eINTR' 0 is returned. Otherwise the result --- value is returned. -throwErrnoIfMinus1NoRetry :: Num a => String -> IO a -> IO a -throwErrnoIfMinus1NoRetry loc f = do - res <- f - if res == -1 - then do - err <- getErrno - if err == eINTR then return 0 else throwErrno loc - else return res diff -Nru ghc-7.0.3/libraries/base/System/Event/IntMap.hs ghc-7.2.1/libraries/base/System/Event/IntMap.hs --- ghc-7.0.3/libraries/base/System/Event/IntMap.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/System/Event/IntMap.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,374 +0,0 @@ -{-# LANGUAGE CPP, MagicHash, NoImplicitPrelude #-} ------------------------------------------------------------------------------ --- | --- Module : System.Event.IntMap --- Copyright : (c) Daan Leijen 2002 --- (c) Andriy Palamarchuk 2008 --- License : BSD-style --- Maintainer : libraries@haskell.org --- Stability : provisional --- Portability : portable --- --- An efficient implementation of maps from integer keys to values. --- --- Since many function names (but not the type name) clash with --- "Prelude" names, this module is usually imported @qualified@, e.g. --- --- > import Data.IntMap (IntMap) --- > import qualified Data.IntMap as IntMap --- --- The implementation is based on /big-endian patricia trees/. This data --- structure performs especially well on binary operations like 'union' --- and 'intersection'. However, my benchmarks show that it is also --- (much) faster on insertions and deletions when compared to a generic --- size-balanced map implementation (see "Data.Map"). --- --- * Chris Okasaki and Andy Gill, \"/Fast Mergeable Integer Maps/\", --- Workshop on ML, September 1998, pages 77-86, --- --- --- * D.R. Morrison, \"/PATRICIA -- Practical Algorithm To Retrieve --- Information Coded In Alphanumeric/\", Journal of the ACM, 15(4), --- October 1968, pages 514-534. --- --- Operation comments contain the operation time complexity in --- the Big-O notation . --- Many operations have a worst-case complexity of /O(min(n,W))/. --- This means that the operation can become linear in the number of --- elements with a maximum of /W/ -- the number of bits in an 'Int' --- (32 or 64). ------------------------------------------------------------------------------ - -module System.Event.IntMap - ( - -- * Map type - IntMap - , Key - - -- * Query - , lookup - , member - - -- * Construction - , empty - - -- * Insertion - , insertWith - - -- * Delete\/Update - , delete - , updateWith - - -- * Traversal - -- ** Fold - , foldWithKey - - -- * Conversion - , keys - ) where - -import Data.Bits - -import Data.Maybe (Maybe(..)) -import GHC.Base hiding (foldr) -import GHC.Num (Num(..)) -import GHC.Real (fromIntegral) -import GHC.Show (Show(showsPrec), showParen, shows, showString) - -#if __GLASGOW_HASKELL__ -import GHC.Word (Word(..)) -#else -import Data.Word -#endif - --- | A @Nat@ is a natural machine word (an unsigned Int) -type Nat = Word - -natFromInt :: Key -> Nat -natFromInt i = fromIntegral i - -intFromNat :: Nat -> Key -intFromNat w = fromIntegral w - -shiftRL :: Nat -> Key -> Nat -#if __GLASGOW_HASKELL__ --- GHC: use unboxing to get @shiftRL@ inlined. -shiftRL (W# x) (I# i) = W# (shiftRL# x i) -#else -shiftRL x i = shiftR x i -#endif - ------------------------------------------------------------------------- --- Types - --- | A map of integers to values @a@. -data IntMap a = Nil - | Tip {-# UNPACK #-} !Key !a - | Bin {-# UNPACK #-} !Prefix - {-# UNPACK #-} !Mask - !(IntMap a) - !(IntMap a) - -type Prefix = Int -type Mask = Int -type Key = Int - ------------------------------------------------------------------------- --- Query - --- | /O(min(n,W))/ Lookup the value at a key in the map. See also --- 'Data.Map.lookup'. -lookup :: Key -> IntMap a -> Maybe a -lookup k t = let nk = natFromInt k in seq nk (lookupN nk t) - -lookupN :: Nat -> IntMap a -> Maybe a -lookupN k t - = case t of - Bin _ m l r - | zeroN k (natFromInt m) -> lookupN k l - | otherwise -> lookupN k r - Tip kx x - | (k == natFromInt kx) -> Just x - | otherwise -> Nothing - Nil -> Nothing - --- | /O(min(n,W))/. Is the key a member of the map? --- --- > member 5 (fromList [(5,'a'), (3,'b')]) == True --- > member 1 (fromList [(5,'a'), (3,'b')]) == False - -member :: Key -> IntMap a -> Bool -member k m - = case lookup k m of - Nothing -> False - Just _ -> True - ------------------------------------------------------------------------- --- Construction - --- | /O(1)/ The empty map. --- --- > empty == fromList [] --- > size empty == 0 -empty :: IntMap a -empty = Nil - ------------------------------------------------------------------------- --- Insert - --- | /O(min(n,W))/ Insert with a function, combining new value and old --- value. @insertWith f key value mp@ will insert the pair (key, --- value) into @mp@ if key does not exist in the map. If the key does --- exist, the function will insert the pair (key, f new_value --- old_value). The result is a pair where the first element is the --- old value, if one was present, and the second is the modified map. -insertWith :: (a -> a -> a) -> Key -> a -> IntMap a -> (Maybe a, IntMap a) -insertWith f k x t = case t of - Bin p m l r - | nomatch k p m -> (Nothing, join k (Tip k x) p t) - | zero k m -> let (found, l') = insertWith f k x l - in (found, Bin p m l' r) - | otherwise -> let (found, r') = insertWith f k x r - in (found, Bin p m l r') - Tip ky y - | k == ky -> (Just y, Tip k (f x y)) - | otherwise -> (Nothing, join k (Tip k x) ky t) - Nil -> (Nothing, Tip k x) - - ------------------------------------------------------------------------- --- Delete/Update - --- | /O(min(n,W))/. Delete a key and its value from the map. When the --- key is not a member of the map, the original map is returned. The --- result is a pair where the first element is the value associated --- with the deleted key, if one existed, and the second element is the --- modified map. -delete :: Key -> IntMap a -> (Maybe a, IntMap a) -delete k t = case t of - Bin p m l r - | nomatch k p m -> (Nothing, t) - | zero k m -> let (found, l') = delete k l - in (found, bin p m l' r) - | otherwise -> let (found, r') = delete k r - in (found, bin p m l r') - Tip ky y - | k == ky -> (Just y, Nil) - | otherwise -> (Nothing, t) - Nil -> (Nothing, Nil) - -updateWith :: (a -> Maybe a) -> Key -> IntMap a -> (Maybe a, IntMap a) -updateWith f k t = case t of - Bin p m l r - | nomatch k p m -> (Nothing, t) - | zero k m -> let (found, l') = updateWith f k l - in (found, bin p m l' r) - | otherwise -> let (found, r') = updateWith f k r - in (found, bin p m l r') - Tip ky y - | k == ky -> case (f y) of - Just y' -> (Just y, Tip ky y') - Nothing -> (Just y, Nil) - | otherwise -> (Nothing, t) - Nil -> (Nothing, Nil) --- | /O(n)/. Fold the keys and values in the map, such that --- @'foldWithKey' f z == 'Prelude.foldr' ('uncurry' f) z . 'toAscList'@. --- For example, --- --- > keys map = foldWithKey (\k x ks -> k:ks) [] map --- --- > let f k a result = result ++ "(" ++ (show k) ++ ":" ++ a ++ ")" --- > foldWithKey f "Map: " (fromList [(5,"a"), (3,"b")]) == "Map: (5:a)(3:b)" - -foldWithKey :: (Key -> a -> b -> b) -> b -> IntMap a -> b -foldWithKey f z t - = foldr f z t - --- | /O(n)/. Convert the map to a list of key\/value pairs. --- --- > toList (fromList [(5,"a"), (3,"b")]) == [(3,"b"), (5,"a")] --- > toList empty == [] - -toList :: IntMap a -> [(Key,a)] -toList t - = foldWithKey (\k x xs -> (k,x):xs) [] t - -foldr :: (Key -> a -> b -> b) -> b -> IntMap a -> b -foldr f z t - = case t of - Bin 0 m l r | m < 0 -> foldr' f (foldr' f z l) r -- put negative numbers before. - Bin _ _ _ _ -> foldr' f z t - Tip k x -> f k x z - Nil -> z - -foldr' :: (Key -> a -> b -> b) -> b -> IntMap a -> b -foldr' f z t - = case t of - Bin _ _ l r -> foldr' f (foldr' f z r) l - Tip k x -> f k x z - Nil -> z - --- | /O(n)/. Return all keys of the map in ascending order. --- --- > keys (fromList [(5,"a"), (3,"b")]) == [3,5] --- > keys empty == [] - -keys :: IntMap a -> [Key] -keys m - = foldWithKey (\k _ ks -> k:ks) [] m - ------------------------------------------------------------------------- --- Eq - -instance Eq a => Eq (IntMap a) where - t1 == t2 = equal t1 t2 - t1 /= t2 = nequal t1 t2 - -equal :: Eq a => IntMap a -> IntMap a -> Bool -equal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2) - = (m1 == m2) && (p1 == p2) && (equal l1 l2) && (equal r1 r2) -equal (Tip kx x) (Tip ky y) - = (kx == ky) && (x==y) -equal Nil Nil = True -equal _ _ = False - -nequal :: Eq a => IntMap a -> IntMap a -> Bool -nequal (Bin p1 m1 l1 r1) (Bin p2 m2 l2 r2) - = (m1 /= m2) || (p1 /= p2) || (nequal l1 l2) || (nequal r1 r2) -nequal (Tip kx x) (Tip ky y) - = (kx /= ky) || (x/=y) -nequal Nil Nil = False -nequal _ _ = True - -instance Show a => Show (IntMap a) where - showsPrec d m = showParen (d > 10) $ - showString "fromList " . shows (toList m) - ------------------------------------------------------------------------- --- Utility functions - -join :: Prefix -> IntMap a -> Prefix -> IntMap a -> IntMap a -join p1 t1 p2 t2 - | zero p1 m = Bin p m t1 t2 - | otherwise = Bin p m t2 t1 - where - m = branchMask p1 p2 - p = mask p1 m - --- | @bin@ assures that we never have empty trees within a tree. -bin :: Prefix -> Mask -> IntMap a -> IntMap a -> IntMap a -bin _ _ l Nil = l -bin _ _ Nil r = r -bin p m l r = Bin p m l r - ------------------------------------------------------------------------- --- Endian independent bit twiddling - -zero :: Key -> Mask -> Bool -zero i m = (natFromInt i) .&. (natFromInt m) == 0 - -nomatch :: Key -> Prefix -> Mask -> Bool -nomatch i p m = (mask i m) /= p - -mask :: Key -> Mask -> Prefix -mask i m = maskW (natFromInt i) (natFromInt m) - -zeroN :: Nat -> Nat -> Bool -zeroN i m = (i .&. m) == 0 - ------------------------------------------------------------------------- --- Big endian operations - -maskW :: Nat -> Nat -> Prefix -maskW i m = intFromNat (i .&. (complement (m-1) `xor` m)) - -branchMask :: Prefix -> Prefix -> Mask -branchMask p1 p2 - = intFromNat (highestBitMask (natFromInt p1 `xor` natFromInt p2)) - -{- -Finding the highest bit mask in a word [x] can be done efficiently in -three ways: - -* convert to a floating point value and the mantissa tells us the - [log2(x)] that corresponds with the highest bit position. The mantissa - is retrieved either via the standard C function [frexp] or by some bit - twiddling on IEEE compatible numbers (float). Note that one needs to - use at least [double] precision for an accurate mantissa of 32 bit - numbers. - -* use bit twiddling, a logarithmic sequence of bitwise or's and shifts (bit). - -* use processor specific assembler instruction (asm). - -The most portable way would be [bit], but is it efficient enough? -I have measured the cycle counts of the different methods on an AMD -Athlon-XP 1800 (~ Pentium III 1.8Ghz) using the RDTSC instruction: - -highestBitMask: method cycles - -------------- - frexp 200 - float 33 - bit 11 - asm 12 - -Wow, the bit twiddling is on today's RISC like machines even faster -than a single CISC instruction (BSR)! --} - --- | @highestBitMask@ returns a word where only the highest bit is --- set. It is found by first setting all bits in lower positions than --- the highest bit and than taking an exclusive or with the original --- value. Allthough the function may look expensive, GHC compiles --- this into excellent C code that subsequently compiled into highly --- efficient machine code. The algorithm is derived from Jorg Arndt's --- FXT library. -highestBitMask :: Nat -> Nat -highestBitMask x0 - = case (x0 .|. shiftRL x0 1) of - x1 -> case (x1 .|. shiftRL x1 2) of - x2 -> case (x2 .|. shiftRL x2 4) of - x3 -> case (x3 .|. shiftRL x3 8) of - x4 -> case (x4 .|. shiftRL x4 16) of - x5 -> case (x5 .|. shiftRL x5 32) of -- for 64 bit platforms - x6 -> (x6 `xor` (shiftRL x6 1)) diff -Nru ghc-7.0.3/libraries/base/System/Event/KQueue.hsc ghc-7.2.1/libraries/base/System/Event/KQueue.hsc --- ghc-7.0.3/libraries/base/System/Event/KQueue.hsc 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/System/Event/KQueue.hsc 1970-01-01 00:00:00.000000000 +0000 @@ -1,298 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface, GeneralizedNewtypeDeriving, - NoImplicitPrelude, RecordWildCards #-} - -module System.Event.KQueue - ( - new - , available - ) where - -import qualified System.Event.Internal as E - -#include "EventConfig.h" -#if !defined(HAVE_KQUEUE) -import GHC.Base - -new :: IO E.Backend -new = error "KQueue back end not implemented for this platform" - -available :: Bool -available = False -{-# INLINE available #-} -#else - -import Control.Concurrent.MVar (MVar, newMVar, swapMVar, withMVar) -import Control.Monad (when, unless) -import Data.Bits (Bits(..)) -import Data.Word (Word16, Word32) -import Foreign.C.Error (throwErrnoIfMinus1) -import Foreign.C.Types (CInt, CLong, CTime) -import Foreign.Marshal.Alloc (alloca) -import Foreign.Ptr (Ptr, nullPtr) -import Foreign.Storable (Storable(..)) -import GHC.Base -import GHC.Enum (toEnum) -import GHC.Err (undefined) -import GHC.Num (Num(..)) -import GHC.Real (ceiling, floor, fromIntegral) -import GHC.Show (Show(show)) -import System.Event.Internal (Timeout(..)) -import System.Posix.Internals (c_close) -import System.Posix.Types (Fd(..)) -import qualified System.Event.Array as A - -#if defined(HAVE_KEVENT64) -import Data.Int (Int64) -import Data.Word (Word64) -import Foreign.C.Types (CUInt) -#else -import Foreign.C.Types (CIntPtr, CUIntPtr) -#endif - -#include -#include -#include - --- Handle brokenness on some BSD variants, notably OS X up to at least --- 10.6. If NOTE_EOF isn't available, we have no way to receive a --- notification from the kernel when we reach EOF on a plain file. -#ifndef NOTE_EOF -# define NOTE_EOF 0 -#endif - -available :: Bool -available = True -{-# INLINE available #-} - ------------------------------------------------------------------------- --- Exported interface - -data EventQueue = EventQueue { - eqFd :: {-# UNPACK #-} !QueueFd - , eqChanges :: {-# UNPACK #-} !(MVar (A.Array Event)) - , eqEvents :: {-# UNPACK #-} !(A.Array Event) - } - -new :: IO E.Backend -new = do - qfd <- kqueue - changesArr <- A.empty - changes <- newMVar changesArr - events <- A.new 64 - let !be = E.backend poll modifyFd delete (EventQueue qfd changes events) - return be - -delete :: EventQueue -> IO () -delete q = do - _ <- c_close . fromQueueFd . eqFd $ q - return () - -modifyFd :: EventQueue -> Fd -> E.Event -> E.Event -> IO () -modifyFd q fd oevt nevt = withMVar (eqChanges q) $ \ch -> do - let addChange filt flag = A.snoc ch $ event fd filt flag noteEOF - when (oevt `E.eventIs` E.evtRead) $ addChange filterRead flagDelete - when (oevt `E.eventIs` E.evtWrite) $ addChange filterWrite flagDelete - when (nevt `E.eventIs` E.evtRead) $ addChange filterRead flagAdd - when (nevt `E.eventIs` E.evtWrite) $ addChange filterWrite flagAdd - -poll :: EventQueue - -> Timeout - -> (Fd -> E.Event -> IO ()) - -> IO () -poll EventQueue{..} tout f = do - changesArr <- A.empty - changes <- swapMVar eqChanges changesArr - changesLen <- A.length changes - len <- A.length eqEvents - when (changesLen > len) $ A.ensureCapacity eqEvents (2 * changesLen) - n <- A.useAsPtr changes $ \changesPtr chLen -> - A.unsafeLoad eqEvents $ \evPtr evCap -> - withTimeSpec (fromTimeout tout) $ - kevent eqFd changesPtr chLen evPtr evCap - - unless (n == 0) $ do - cap <- A.capacity eqEvents - when (n == cap) $ A.ensureCapacity eqEvents (2 * cap) - A.forM_ eqEvents $ \e -> f (fromIntegral (ident e)) (toEvent (filter e)) - ------------------------------------------------------------------------- --- FFI binding - -newtype QueueFd = QueueFd { - fromQueueFd :: CInt - } deriving (Eq, Show) - -#if defined(HAVE_KEVENT64) -data Event = KEvent64 { - ident :: {-# UNPACK #-} !Word64 - , filter :: {-# UNPACK #-} !Filter - , flags :: {-# UNPACK #-} !Flag - , fflags :: {-# UNPACK #-} !FFlag - , data_ :: {-# UNPACK #-} !Int64 - , udata :: {-# UNPACK #-} !Word64 - , ext0 :: {-# UNPACK #-} !Word64 - , ext1 :: {-# UNPACK #-} !Word64 - } deriving Show - -event :: Fd -> Filter -> Flag -> FFlag -> Event -event fd filt flag fflag = KEvent64 (fromIntegral fd) filt flag fflag 0 0 0 0 - -instance Storable Event where - sizeOf _ = #size struct kevent64_s - alignment _ = alignment (undefined :: CInt) - - peek ptr = do - ident' <- #{peek struct kevent64_s, ident} ptr - filter' <- #{peek struct kevent64_s, filter} ptr - flags' <- #{peek struct kevent64_s, flags} ptr - fflags' <- #{peek struct kevent64_s, fflags} ptr - data' <- #{peek struct kevent64_s, data} ptr - udata' <- #{peek struct kevent64_s, udata} ptr - ext0' <- #{peek struct kevent64_s, ext[0]} ptr - ext1' <- #{peek struct kevent64_s, ext[1]} ptr - let !ev = KEvent64 ident' (Filter filter') (Flag flags') fflags' data' - udata' ext0' ext1' - return ev - - poke ptr ev = do - #{poke struct kevent64_s, ident} ptr (ident ev) - #{poke struct kevent64_s, filter} ptr (filter ev) - #{poke struct kevent64_s, flags} ptr (flags ev) - #{poke struct kevent64_s, fflags} ptr (fflags ev) - #{poke struct kevent64_s, data} ptr (data_ ev) - #{poke struct kevent64_s, udata} ptr (udata ev) - #{poke struct kevent64_s, ext[0]} ptr (ext0 ev) - #{poke struct kevent64_s, ext[1]} ptr (ext1 ev) -#else -data Event = KEvent { - ident :: {-# UNPACK #-} !CUIntPtr - , filter :: {-# UNPACK #-} !Filter - , flags :: {-# UNPACK #-} !Flag - , fflags :: {-# UNPACK #-} !FFlag - , data_ :: {-# UNPACK #-} !CIntPtr - , udata :: {-# UNPACK #-} !(Ptr ()) - } deriving Show - -event :: Fd -> Filter -> Flag -> FFlag -> Event -event fd filt flag fflag = KEvent (fromIntegral fd) filt flag fflag 0 nullPtr - -instance Storable Event where - sizeOf _ = #size struct kevent - alignment _ = alignment (undefined :: CInt) - - peek ptr = do - ident' <- #{peek struct kevent, ident} ptr - filter' <- #{peek struct kevent, filter} ptr - flags' <- #{peek struct kevent, flags} ptr - fflags' <- #{peek struct kevent, fflags} ptr - data' <- #{peek struct kevent, data} ptr - udata' <- #{peek struct kevent, udata} ptr - let !ev = KEvent ident' (Filter filter') (Flag flags') fflags' data' - udata' - return ev - - poke ptr ev = do - #{poke struct kevent, ident} ptr (ident ev) - #{poke struct kevent, filter} ptr (filter ev) - #{poke struct kevent, flags} ptr (flags ev) - #{poke struct kevent, fflags} ptr (fflags ev) - #{poke struct kevent, data} ptr (data_ ev) - #{poke struct kevent, udata} ptr (udata ev) -#endif - -newtype FFlag = FFlag Word32 - deriving (Eq, Show, Storable) - -#{enum FFlag, FFlag - , noteEOF = NOTE_EOF - } - -newtype Flag = Flag Word16 - deriving (Eq, Show, Storable) - -#{enum Flag, Flag - , flagAdd = EV_ADD - , flagDelete = EV_DELETE - } - -newtype Filter = Filter Word16 - deriving (Bits, Eq, Num, Show, Storable) - -#{enum Filter, Filter - , filterRead = EVFILT_READ - , filterWrite = EVFILT_WRITE - } - -data TimeSpec = TimeSpec { - tv_sec :: {-# UNPACK #-} !CTime - , tv_nsec :: {-# UNPACK #-} !CLong - } - -instance Storable TimeSpec where - sizeOf _ = #size struct timespec - alignment _ = alignment (undefined :: CInt) - - peek ptr = do - tv_sec' <- #{peek struct timespec, tv_sec} ptr - tv_nsec' <- #{peek struct timespec, tv_nsec} ptr - let !ts = TimeSpec tv_sec' tv_nsec' - return ts - - poke ptr ts = do - #{poke struct timespec, tv_sec} ptr (tv_sec ts) - #{poke struct timespec, tv_nsec} ptr (tv_nsec ts) - -kqueue :: IO QueueFd -kqueue = QueueFd `fmap` throwErrnoIfMinus1 "kqueue" c_kqueue - --- TODO: We cannot retry on EINTR as the timeout would be wrong. --- Perhaps we should just return without calling any callbacks. -kevent :: QueueFd -> Ptr Event -> Int -> Ptr Event -> Int -> Ptr TimeSpec - -> IO Int -kevent k chs chlen evs evlen ts - = fmap fromIntegral $ E.throwErrnoIfMinus1NoRetry "kevent" $ -#if defined(HAVE_KEVENT64) - c_kevent64 k chs (fromIntegral chlen) evs (fromIntegral evlen) 0 ts -#else - c_kevent k chs (fromIntegral chlen) evs (fromIntegral evlen) ts -#endif - -withTimeSpec :: TimeSpec -> (Ptr TimeSpec -> IO a) -> IO a -withTimeSpec ts f = - if tv_sec ts < 0 then - f nullPtr - else - alloca $ \ptr -> poke ptr ts >> f ptr - -fromTimeout :: Timeout -> TimeSpec -fromTimeout Forever = TimeSpec (-1) (-1) -fromTimeout (Timeout s) = TimeSpec (toEnum sec) (toEnum nanosec) - where - sec :: Int - sec = floor s - - nanosec :: Int - nanosec = ceiling $ (s - fromIntegral sec) * 1000000000 - -toEvent :: Filter -> E.Event -toEvent (Filter f) - | f == (#const EVFILT_READ) = E.evtRead - | f == (#const EVFILT_WRITE) = E.evtWrite - | otherwise = error $ "toEvent: unknown filter " ++ show f - -foreign import ccall unsafe "kqueue" - c_kqueue :: IO CInt - -#if defined(HAVE_KEVENT64) -foreign import ccall safe "kevent64" - c_kevent64 :: QueueFd -> Ptr Event -> CInt -> Ptr Event -> CInt -> CUInt - -> Ptr TimeSpec -> IO CInt -#elif defined(HAVE_KEVENT) -foreign import ccall safe "kevent" - c_kevent :: QueueFd -> Ptr Event -> CInt -> Ptr Event -> CInt - -> Ptr TimeSpec -> IO CInt -#else -#error no kevent system call available!? -#endif - -#endif /* defined(HAVE_KQUEUE) */ diff -Nru ghc-7.0.3/libraries/base/System/Event/Manager.hs ghc-7.2.1/libraries/base/System/Event/Manager.hs --- ghc-7.0.3/libraries/base/System/Event/Manager.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/System/Event/Manager.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,402 +0,0 @@ -{-# LANGUAGE BangPatterns, CPP, ExistentialQuantification, NoImplicitPrelude, - RecordWildCards, TypeSynonymInstances #-} -module System.Event.Manager - ( -- * Types - EventManager - - -- * Creation - , new - , newWith - , newDefaultBackend - - -- * Running - , finished - , loop - , step - , shutdown - , cleanup - , wakeManager - - -- * Registering interest in I/O events - , Event - , evtRead - , evtWrite - , IOCallback - , FdKey(keyFd) - , registerFd_ - , registerFd - , unregisterFd_ - , unregisterFd - , closeFd - - -- * Registering interest in timeout events - , TimeoutCallback - , TimeoutKey - , registerTimeout - , updateTimeout - , unregisterTimeout - ) where - -#include "EventConfig.h" - ------------------------------------------------------------------------- --- Imports - -import Control.Concurrent.MVar (MVar, modifyMVar, newMVar, readMVar) -import Control.Exception (finally) -import Control.Monad ((=<<), forM_, liftM, sequence_, when) -import Data.IORef (IORef, atomicModifyIORef, mkWeakIORef, newIORef, readIORef, - writeIORef) -import Data.Maybe (Maybe(..)) -import Data.Monoid (mappend, mconcat, mempty) -import GHC.Base -import GHC.Conc.Signal (runHandlers) -import GHC.List (filter) -import GHC.Num (Num(..)) -import GHC.Real ((/), fromIntegral ) -import GHC.Show (Show(..)) -import System.Event.Clock (getCurrentTime) -import System.Event.Control -import System.Event.Internal (Backend, Event, evtClose, evtRead, evtWrite, - Timeout(..)) -import System.Event.Unique (Unique, UniqueSource, newSource, newUnique) -import System.Posix.Types (Fd) - -import qualified System.Event.IntMap as IM -import qualified System.Event.Internal as I -import qualified System.Event.PSQ as Q - -#if defined(HAVE_KQUEUE) -import qualified System.Event.KQueue as KQueue -#elif defined(HAVE_EPOLL) -import qualified System.Event.EPoll as EPoll -#elif defined(HAVE_POLL) -import qualified System.Event.Poll as Poll -#else -# error not implemented for this operating system -#endif - ------------------------------------------------------------------------- --- Types - -data FdData = FdData { - fdKey :: {-# UNPACK #-} !FdKey - , fdEvents :: {-# UNPACK #-} !Event - , _fdCallback :: !IOCallback - } deriving (Show) - --- | A file descriptor registration cookie. -data FdKey = FdKey { - keyFd :: {-# UNPACK #-} !Fd - , keyUnique :: {-# UNPACK #-} !Unique - } deriving (Eq, Show) - --- | Callback invoked on I/O events. -type IOCallback = FdKey -> Event -> IO () - -instance Show IOCallback where - show _ = "IOCallback" - --- | A timeout registration cookie. -newtype TimeoutKey = TK Unique - deriving (Eq) - --- | Callback invoked on timeout events. -type TimeoutCallback = IO () - -data State = Created - | Running - | Dying - | Finished - deriving (Eq, Show) - --- | A priority search queue, with timeouts as priorities. -type TimeoutQueue = Q.PSQ TimeoutCallback - -{- -Instead of directly modifying the 'TimeoutQueue' in -e.g. 'registerTimeout' we keep a list of edits to perform, in the form -of a chain of function closures, and have the I/O manager thread -perform the edits later. This exist to address the following GC -problem: - -Since e.g. 'registerTimeout' doesn't force the evaluation of the -thunks inside the 'emTimeouts' IORef a number of thunks build up -inside the IORef. If the I/O manager thread doesn't evaluate these -thunks soon enough they'll get promoted to the old generation and -become roots for all subsequent minor GCs. - -When the thunks eventually get evaluated they will each create a new -intermediate 'TimeoutQueue' that immediately becomes garbage. Since -the thunks serve as roots until the next major GC these intermediate -'TimeoutQueue's will get copied unnecesarily in the next minor GC, -increasing GC time. This problem is known as "floating garbage". - -Keeping a list of edits doesn't stop this from happening but makes the -amount of data that gets copied smaller. - -TODO: Evaluate the content of the IORef to WHNF on each insert once -this bug is resolved: http://hackage.haskell.org/trac/ghc/ticket/3838 --} - --- | An edit to apply to a 'TimeoutQueue'. -type TimeoutEdit = TimeoutQueue -> TimeoutQueue - --- | The event manager state. -data EventManager = EventManager - { emBackend :: !Backend - , emFds :: {-# UNPACK #-} !(MVar (IM.IntMap [FdData])) - , emTimeouts :: {-# UNPACK #-} !(IORef TimeoutEdit) - , emState :: {-# UNPACK #-} !(IORef State) - , emUniqueSource :: {-# UNPACK #-} !UniqueSource - , emControl :: {-# UNPACK #-} !Control - } - ------------------------------------------------------------------------- --- Creation - -handleControlEvent :: EventManager -> FdKey -> Event -> IO () -handleControlEvent mgr reg _evt = do - msg <- readControlMessage (emControl mgr) (keyFd reg) - case msg of - CMsgWakeup -> return () - CMsgDie -> writeIORef (emState mgr) Finished - CMsgSignal fp s -> runHandlers fp s - -newDefaultBackend :: IO Backend -#if defined(HAVE_KQUEUE) -newDefaultBackend = KQueue.new -#elif defined(HAVE_EPOLL) -newDefaultBackend = EPoll.new -#elif defined(HAVE_POLL) -newDefaultBackend = Poll.new -#else -newDefaultBackend = error "no back end for this platform" -#endif - --- | Create a new event manager. -new :: IO EventManager -new = newWith =<< newDefaultBackend - -newWith :: Backend -> IO EventManager -newWith be = do - iofds <- newMVar IM.empty - timeouts <- newIORef id - ctrl <- newControl - state <- newIORef Created - us <- newSource - _ <- mkWeakIORef state $ do - st <- atomicModifyIORef state $ \s -> (Finished, s) - when (st /= Finished) $ do - I.delete be - closeControl ctrl - let mgr = EventManager { emBackend = be - , emFds = iofds - , emTimeouts = timeouts - , emState = state - , emUniqueSource = us - , emControl = ctrl - } - _ <- registerFd_ mgr (handleControlEvent mgr) (controlReadFd ctrl) evtRead - _ <- registerFd_ mgr (handleControlEvent mgr) (wakeupReadFd ctrl) evtRead - return mgr - --- | Asynchronously shuts down the event manager, if running. -shutdown :: EventManager -> IO () -shutdown mgr = do - state <- atomicModifyIORef (emState mgr) $ \s -> (Dying, s) - when (state == Running) $ sendDie (emControl mgr) - -finished :: EventManager -> IO Bool -finished mgr = (== Finished) `liftM` readIORef (emState mgr) - -cleanup :: EventManager -> IO () -cleanup EventManager{..} = do - writeIORef emState Finished - I.delete emBackend - closeControl emControl - ------------------------------------------------------------------------- --- Event loop - --- | Start handling events. This function loops until told to stop, --- using 'shutdown'. --- --- /Note/: This loop can only be run once per 'EventManager', as it --- closes all of its control resources when it finishes. -loop :: EventManager -> IO () -loop mgr@EventManager{..} = do - state <- atomicModifyIORef emState $ \s -> case s of - Created -> (Running, s) - _ -> (s, s) - case state of - Created -> go Q.empty `finally` cleanup mgr - Dying -> cleanup mgr - _ -> do cleanup mgr - error $ "System.Event.Manager.loop: state is already " ++ - show state - where - go q = do (running, q') <- step mgr q - when running $ go q' - -step :: EventManager -> TimeoutQueue -> IO (Bool, TimeoutQueue) -step mgr@EventManager{..} tq = do - (timeout, q') <- mkTimeout tq - I.poll emBackend timeout (onFdEvent mgr) - state <- readIORef emState - state `seq` return (state == Running, q') - where - - -- | Call all expired timer callbacks and return the time to the - -- next timeout. - mkTimeout :: TimeoutQueue -> IO (Timeout, TimeoutQueue) - mkTimeout q = do - now <- getCurrentTime - applyEdits <- atomicModifyIORef emTimeouts $ \f -> (id, f) - let (expired, q'') = let q' = applyEdits q in q' `seq` Q.atMost now q' - sequence_ $ map Q.value expired - let timeout = case Q.minView q'' of - Nothing -> Forever - Just (Q.E _ t _, _) -> - -- This value will always be positive since the call - -- to 'atMost' above removed any timeouts <= 'now' - let t' = t - now in t' `seq` Timeout t' - return (timeout, q'') - ------------------------------------------------------------------------- --- Registering interest in I/O events - --- | Register interest in the given events, without waking the event --- manager thread. The 'Bool' return value indicates whether the --- event manager ought to be woken. -registerFd_ :: EventManager -> IOCallback -> Fd -> Event - -> IO (FdKey, Bool) -registerFd_ EventManager{..} cb fd evs = do - u <- newUnique emUniqueSource - modifyMVar emFds $ \oldMap -> do - let fd' = fromIntegral fd - reg = FdKey fd u - !fdd = FdData reg evs cb - (!newMap, (oldEvs, newEvs)) = - case IM.insertWith (++) fd' [fdd] oldMap of - (Nothing, n) -> (n, (mempty, evs)) - (Just prev, n) -> (n, pairEvents prev newMap fd') - modify = oldEvs /= newEvs - when modify $ I.modifyFd emBackend fd oldEvs newEvs - return (newMap, (reg, modify)) -{-# INLINE registerFd_ #-} - --- | @registerFd mgr cb fd evs@ registers interest in the events @evs@ --- on the file descriptor @fd@. @cb@ is called for each event that --- occurs. Returns a cookie that can be handed to 'unregisterFd'. -registerFd :: EventManager -> IOCallback -> Fd -> Event -> IO FdKey -registerFd mgr cb fd evs = do - (r, wake) <- registerFd_ mgr cb fd evs - when wake $ wakeManager mgr - return r -{-# INLINE registerFd #-} - --- | Wake up the event manager. -wakeManager :: EventManager -> IO () -wakeManager mgr = sendWakeup (emControl mgr) - -eventsOf :: [FdData] -> Event -eventsOf = mconcat . map fdEvents - -pairEvents :: [FdData] -> IM.IntMap [FdData] -> Int -> (Event, Event) -pairEvents prev m fd = let l = eventsOf prev - r = case IM.lookup fd m of - Nothing -> mempty - Just fds -> eventsOf fds - in (l, r) - --- | Drop a previous file descriptor registration, without waking the --- event manager thread. The return value indicates whether the event --- manager ought to be woken. -unregisterFd_ :: EventManager -> FdKey -> IO Bool -unregisterFd_ EventManager{..} (FdKey fd u) = - modifyMVar emFds $ \oldMap -> do - let dropReg cbs = case filter ((/= u) . keyUnique . fdKey) cbs of - [] -> Nothing - cbs' -> Just cbs' - fd' = fromIntegral fd - (!newMap, (oldEvs, newEvs)) = - case IM.updateWith dropReg fd' oldMap of - (Nothing, _) -> (oldMap, (mempty, mempty)) - (Just prev, newm) -> (newm, pairEvents prev newm fd') - modify = oldEvs /= newEvs - when modify $ I.modifyFd emBackend fd oldEvs newEvs - return (newMap, modify) - --- | Drop a previous file descriptor registration. -unregisterFd :: EventManager -> FdKey -> IO () -unregisterFd mgr reg = do - wake <- unregisterFd_ mgr reg - when wake $ wakeManager mgr - --- | Close a file descriptor in a race-safe way. -closeFd :: EventManager -> (Fd -> IO ()) -> Fd -> IO () -closeFd mgr close fd = do - fds <- modifyMVar (emFds mgr) $ \oldMap -> do - close fd - case IM.delete (fromIntegral fd) oldMap of - (Nothing, _) -> return (oldMap, []) - (Just fds, !newMap) -> do - when (eventsOf fds /= mempty) $ wakeManager mgr - return (newMap, fds) - forM_ fds $ \(FdData reg ev cb) -> cb reg (ev `mappend` evtClose) - ------------------------------------------------------------------------- --- Registering interest in timeout events - --- | Register a timeout in the given number of microseconds. The --- returned 'TimeoutKey' can be used to later unregister or update the --- timeout. The timeout is automatically unregistered after the given --- time has passed. -registerTimeout :: EventManager -> Int -> TimeoutCallback -> IO TimeoutKey -registerTimeout mgr us cb = do - !key <- newUnique (emUniqueSource mgr) - if us <= 0 then cb - else do - now <- getCurrentTime - let expTime = fromIntegral us / 1000000.0 + now - - -- We intentionally do not evaluate the modified map to WHNF here. - -- Instead, we leave a thunk inside the IORef and defer its - -- evaluation until mkTimeout in the event loop. This is a - -- workaround for a nasty IORef contention problem that causes the - -- thread-delay benchmark to take 20 seconds instead of 0.2. - atomicModifyIORef (emTimeouts mgr) $ \f -> - let f' = (Q.insert key expTime cb) . f in (f', ()) - wakeManager mgr - return $ TK key - --- | Unregister an active timeout. -unregisterTimeout :: EventManager -> TimeoutKey -> IO () -unregisterTimeout mgr (TK key) = do - atomicModifyIORef (emTimeouts mgr) $ \f -> - let f' = (Q.delete key) . f in (f', ()) - wakeManager mgr - --- | Update an active timeout to fire in the given number of --- microseconds. -updateTimeout :: EventManager -> TimeoutKey -> Int -> IO () -updateTimeout mgr (TK key) us = do - now <- getCurrentTime - let expTime = fromIntegral us / 1000000.0 + now - - atomicModifyIORef (emTimeouts mgr) $ \f -> - let f' = (Q.adjust (const expTime) key) . f in (f', ()) - wakeManager mgr - ------------------------------------------------------------------------- --- Utilities - --- | Call the callbacks corresponding to the given file descriptor. -onFdEvent :: EventManager -> Fd -> Event -> IO () -onFdEvent mgr fd evs = do - fds <- readMVar (emFds mgr) - case IM.lookup (fromIntegral fd) fds of - Just cbs -> forM_ cbs $ \(FdData reg ev cb) -> - when (evs `I.eventIs` ev) $ cb reg evs - Nothing -> return () diff -Nru ghc-7.0.3/libraries/base/System/Event/Poll.hsc ghc-7.2.1/libraries/base/System/Event/Poll.hsc --- ghc-7.0.3/libraries/base/System/Event/Poll.hsc 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/System/Event/Poll.hsc 1970-01-01 00:00:00.000000000 +0000 @@ -1,149 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface, GeneralizedNewtypeDeriving, - NoImplicitPrelude #-} - -module System.Event.Poll - ( - new - , available - ) where - -#include "EventConfig.h" - -#if !defined(HAVE_POLL_H) -import GHC.Base - -new :: IO E.Backend -new = error "Poll back end not implemented for this platform" - -available :: Bool -available = False -{-# INLINE available #-} -#else -#include - -import Control.Concurrent.MVar (MVar, newMVar, swapMVar) -import Control.Monad ((=<<), liftM, liftM2, unless) -import Data.Bits (Bits, (.|.), (.&.)) -import Data.Maybe (Maybe(..)) -import Data.Monoid (Monoid(..)) -import Foreign.C.Types (CInt, CShort, CULong) -import Foreign.Ptr (Ptr) -import Foreign.Storable (Storable(..)) -import GHC.Base -import GHC.Conc.Sync (withMVar) -import GHC.Err (undefined) -import GHC.Num (Num(..)) -import GHC.Real (ceiling, fromIntegral) -import GHC.Show (Show) -import System.Posix.Types (Fd(..)) - -import qualified System.Event.Array as A -import qualified System.Event.Internal as E - -available :: Bool -available = True -{-# INLINE available #-} - -data Poll = Poll { - pollChanges :: {-# UNPACK #-} !(MVar (A.Array PollFd)) - , pollFd :: {-# UNPACK #-} !(A.Array PollFd) - } - -new :: IO E.Backend -new = E.backend poll modifyFd (\_ -> return ()) `liftM` - liftM2 Poll (newMVar =<< A.empty) A.empty - -modifyFd :: Poll -> Fd -> E.Event -> E.Event -> IO () -modifyFd p fd oevt nevt = - withMVar (pollChanges p) $ \ary -> - A.snoc ary $ PollFd fd (fromEvent nevt) (fromEvent oevt) - -reworkFd :: Poll -> PollFd -> IO () -reworkFd p (PollFd fd npevt opevt) = do - let ary = pollFd p - if opevt == 0 - then A.snoc ary $ PollFd fd npevt 0 - else do - found <- A.findIndex ((== fd) . pfdFd) ary - case found of - Nothing -> error "reworkFd: event not found" - Just (i,_) - | npevt /= 0 -> A.unsafeWrite ary i $ PollFd fd npevt 0 - | otherwise -> A.removeAt ary i - -poll :: Poll - -> E.Timeout - -> (Fd -> E.Event -> IO ()) - -> IO () -poll p tout f = do - let a = pollFd p - mods <- swapMVar (pollChanges p) =<< A.empty - A.forM_ mods (reworkFd p) - n <- A.useAsPtr a $ \ptr len -> E.throwErrnoIfMinus1NoRetry "c_poll" $ - c_poll ptr (fromIntegral len) (fromIntegral (fromTimeout tout)) - unless (n == 0) $ do - A.loop a 0 $ \i e -> do - let r = pfdRevents e - if r /= 0 - then do f (pfdFd e) (toEvent r) - let i' = i + 1 - return (i', i' == n) - else return (i, True) - -fromTimeout :: E.Timeout -> Int -fromTimeout E.Forever = -1 -fromTimeout (E.Timeout s) = ceiling $ 1000 * s - -data PollFd = PollFd { - pfdFd :: {-# UNPACK #-} !Fd - , pfdEvents :: {-# UNPACK #-} !Event - , pfdRevents :: {-# UNPACK #-} !Event - } deriving (Show) - -newtype Event = Event CShort - deriving (Eq, Show, Num, Storable, Bits) - -#{enum Event, Event - , pollIn = POLLIN - , pollOut = POLLOUT -#ifdef POLLRDHUP - , pollRdHup = POLLRDHUP -#endif - , pollErr = POLLERR - , pollHup = POLLHUP - } - -fromEvent :: E.Event -> Event -fromEvent e = remap E.evtRead pollIn .|. - remap E.evtWrite pollOut - where remap evt to - | e `E.eventIs` evt = to - | otherwise = 0 - -toEvent :: Event -> E.Event -toEvent e = remap (pollIn .|. pollErr .|. pollHup) E.evtRead `mappend` - remap (pollOut .|. pollErr .|. pollHup) E.evtWrite - where remap evt to - | e .&. evt /= 0 = to - | otherwise = mempty - -instance Storable PollFd where - sizeOf _ = #size struct pollfd - alignment _ = alignment (undefined :: CInt) - - peek ptr = do - fd <- #{peek struct pollfd, fd} ptr - events <- #{peek struct pollfd, events} ptr - revents <- #{peek struct pollfd, revents} ptr - let !pollFd' = PollFd fd events revents - return pollFd' - - poke ptr p = do - #{poke struct pollfd, fd} ptr (pfdFd p) - #{poke struct pollfd, events} ptr (pfdEvents p) - #{poke struct pollfd, revents} ptr (pfdRevents p) - -foreign import ccall safe "poll.h poll" - c_poll :: Ptr PollFd -> CULong -> CInt -> IO CInt - -#endif /* defined(HAVE_POLL_H) */ diff -Nru ghc-7.0.3/libraries/base/System/Event/PSQ.hs ghc-7.2.1/libraries/base/System/Event/PSQ.hs --- ghc-7.0.3/libraries/base/System/Event/PSQ.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/System/Event/PSQ.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,483 +0,0 @@ -{-# LANGUAGE BangPatterns, NoImplicitPrelude #-} - --- Copyright (c) 2008, Ralf Hinze --- All rights reserved. --- --- Redistribution and use in source and binary forms, with or without --- modification, are permitted provided that the following conditions --- are met: --- --- * Redistributions of source code must retain the above --- copyright notice, this list of conditions and the following --- disclaimer. --- --- * Redistributions in binary form must reproduce the above --- copyright notice, this list of conditions and the following --- disclaimer in the documentation and/or other materials --- provided with the distribution. --- --- * The names of the contributors may not be used to endorse or --- promote products derived from this software without specific --- prior written permission. --- --- THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS --- "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT --- LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS --- FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE --- COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, --- INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES --- (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR --- SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) --- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, --- STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) --- ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED --- OF THE POSSIBILITY OF SUCH DAMAGE. - --- | A /priority search queue/ (henceforth /queue/) efficiently --- supports the operations of both a search tree and a priority queue. --- An 'Elem'ent is a product of a key, a priority, and a --- value. Elements can be inserted, deleted, modified and queried in --- logarithmic time, and the element with the least priority can be --- retrieved in constant time. A queue can be built from a list of --- elements, sorted by keys, in linear time. --- --- This implementation is due to Ralf Hinze with some modifications by --- Scott Dillard and Johan Tibell. --- --- * Hinze, R., /A Simple Implementation Technique for Priority Search --- Queues/, ICFP 2001, pp. 110-121 --- --- -module System.Event.PSQ - ( - -- * Binding Type - Elem(..) - , Key - , Prio - - -- * Priority Search Queue Type - , PSQ - - -- * Query - , size - , null - , lookup - - -- * Construction - , empty - , singleton - - -- * Insertion - , insert - - -- * Delete/Update - , delete - , adjust - - -- * Conversion - , toList - , toAscList - , toDescList - , fromList - - -- * Min - , findMin - , deleteMin - , minView - , atMost - ) where - -import Data.Maybe (Maybe(..)) -import GHC.Base -import GHC.Num (Num(..)) -import GHC.Show (Show(showsPrec)) -import System.Event.Unique (Unique) - --- | @E k p@ binds the key @k@ with the priority @p@. -data Elem a = E - { key :: {-# UNPACK #-} !Key - , prio :: {-# UNPACK #-} !Prio - , value :: a - } deriving (Eq, Show) - ------------------------------------------------------------------------- --- | A mapping from keys @k@ to priorites @p@. - -type Prio = Double -type Key = Unique - -data PSQ a = Void - | Winner {-# UNPACK #-} !(Elem a) - !(LTree a) - {-# UNPACK #-} !Key -- max key - deriving (Eq, Show) - --- | /O(1)/ The number of elements in a queue. -size :: PSQ a -> Int -size Void = 0 -size (Winner _ lt _) = 1 + size' lt - --- | /O(1)/ True if the queue is empty. -null :: PSQ a -> Bool -null Void = True -null (Winner _ _ _) = False - --- | /O(log n)/ The priority and value of a given key, or Nothing if --- the key is not bound. -lookup :: Key -> PSQ a -> Maybe (Prio, a) -lookup k q = case tourView q of - Null -> Nothing - Single (E k' p v) - | k == k' -> Just (p, v) - | otherwise -> Nothing - tl `Play` tr - | k <= maxKey tl -> lookup k tl - | otherwise -> lookup k tr - ------------------------------------------------------------------------- --- Construction - -empty :: PSQ a -empty = Void - --- | /O(1)/ Build a queue with one element. -singleton :: Key -> Prio -> a -> PSQ a -singleton k p v = Winner (E k p v) Start k - ------------------------------------------------------------------------- --- Insertion - --- | /O(log n)/ Insert a new key, priority and value in the queue. If --- the key is already present in the queue, the associated priority --- and value are replaced with the supplied priority and value. -insert :: Key -> Prio -> a -> PSQ a -> PSQ a -insert k p v q = case q of - Void -> singleton k p v - Winner (E k' p' v') Start _ -> case compare k k' of - LT -> singleton k p v `play` singleton k' p' v' - EQ -> singleton k p v - GT -> singleton k' p' v' `play` singleton k p v - Winner e (RLoser _ e' tl m tr) m' - | k <= m -> insert k p v (Winner e tl m) `play` (Winner e' tr m') - | otherwise -> (Winner e tl m) `play` insert k p v (Winner e' tr m') - Winner e (LLoser _ e' tl m tr) m' - | k <= m -> insert k p v (Winner e' tl m) `play` (Winner e tr m') - | otherwise -> (Winner e' tl m) `play` insert k p v (Winner e tr m') - ------------------------------------------------------------------------- --- Delete/Update - --- | /O(log n)/ Delete a key and its priority and value from the --- queue. When the key is not a member of the queue, the original --- queue is returned. -delete :: Key -> PSQ a -> PSQ a -delete k q = case q of - Void -> empty - Winner (E k' p v) Start _ - | k == k' -> empty - | otherwise -> singleton k' p v - Winner e (RLoser _ e' tl m tr) m' - | k <= m -> delete k (Winner e tl m) `play` (Winner e' tr m') - | otherwise -> (Winner e tl m) `play` delete k (Winner e' tr m') - Winner e (LLoser _ e' tl m tr) m' - | k <= m -> delete k (Winner e' tl m) `play` (Winner e tr m') - | otherwise -> (Winner e' tl m) `play` delete k (Winner e tr m') - --- | /O(log n)/ Update a priority at a specific key with the result --- of the provided function. When the key is not a member of the --- queue, the original queue is returned. -adjust :: (Prio -> Prio) -> Key -> PSQ a -> PSQ a -adjust f k q0 = go q0 - where - go q = case q of - Void -> empty - Winner (E k' p v) Start _ - | k == k' -> singleton k' (f p) v - | otherwise -> singleton k' p v - Winner e (RLoser _ e' tl m tr) m' - | k <= m -> go (Winner e tl m) `unsafePlay` (Winner e' tr m') - | otherwise -> (Winner e tl m) `unsafePlay` go (Winner e' tr m') - Winner e (LLoser _ e' tl m tr) m' - | k <= m -> go (Winner e' tl m) `unsafePlay` (Winner e tr m') - | otherwise -> (Winner e' tl m) `unsafePlay` go (Winner e tr m') -{-# INLINE adjust #-} - ------------------------------------------------------------------------- --- Conversion - --- | /O(n*log n)/ Build a queue from a list of key/priority/value --- tuples. If the list contains more than one priority and value for --- the same key, the last priority and value for the key is retained. -fromList :: [Elem a] -> PSQ a -fromList = foldr (\(E k p v) q -> insert k p v q) empty - --- | /O(n)/ Convert to a list of key/priority/value tuples. -toList :: PSQ a -> [Elem a] -toList = toAscList - --- | /O(n)/ Convert to an ascending list. -toAscList :: PSQ a -> [Elem a] -toAscList q = seqToList (toAscLists q) - -toAscLists :: PSQ a -> Sequ (Elem a) -toAscLists q = case tourView q of - Null -> emptySequ - Single e -> singleSequ e - tl `Play` tr -> toAscLists tl <> toAscLists tr - --- | /O(n)/ Convert to a descending list. -toDescList :: PSQ a -> [ Elem a ] -toDescList q = seqToList (toDescLists q) - -toDescLists :: PSQ a -> Sequ (Elem a) -toDescLists q = case tourView q of - Null -> emptySequ - Single e -> singleSequ e - tl `Play` tr -> toDescLists tr <> toDescLists tl - ------------------------------------------------------------------------- --- Min - --- | /O(1)/ The element with the lowest priority. -findMin :: PSQ a -> Maybe (Elem a) -findMin Void = Nothing -findMin (Winner e _ _) = Just e - --- | /O(log n)/ Delete the element with the lowest priority. Returns --- an empty queue if the queue is empty. -deleteMin :: PSQ a -> PSQ a -deleteMin Void = Void -deleteMin (Winner _ t m) = secondBest t m - --- | /O(log n)/ Retrieve the binding with the least priority, and the --- rest of the queue stripped of that binding. -minView :: PSQ a -> Maybe (Elem a, PSQ a) -minView Void = Nothing -minView (Winner e t m) = Just (e, secondBest t m) - -secondBest :: LTree a -> Key -> PSQ a -secondBest Start _ = Void -secondBest (LLoser _ e tl m tr) m' = Winner e tl m `play` secondBest tr m' -secondBest (RLoser _ e tl m tr) m' = secondBest tl m `play` Winner e tr m' - --- | /O(r*(log n - log r))/ Return a list of elements ordered by --- key whose priorities are at most @pt@. -atMost :: Prio -> PSQ a -> ([Elem a], PSQ a) -atMost pt q = let (sequ, q') = atMosts pt q - in (seqToList sequ, q') - -atMosts :: Prio -> PSQ a -> (Sequ (Elem a), PSQ a) -atMosts !pt q = case q of - (Winner e _ _) - | prio e > pt -> (emptySequ, q) - Void -> (emptySequ, Void) - Winner e Start _ -> (singleSequ e, Void) - Winner e (RLoser _ e' tl m tr) m' -> - let (sequ, q') = atMosts pt (Winner e tl m) - (sequ', q'') = atMosts pt (Winner e' tr m') - in (sequ <> sequ', q' `play` q'') - Winner e (LLoser _ e' tl m tr) m' -> - let (sequ, q') = atMosts pt (Winner e' tl m) - (sequ', q'') = atMosts pt (Winner e tr m') - in (sequ <> sequ', q' `play` q'') - ------------------------------------------------------------------------- --- Loser tree - -type Size = Int - -data LTree a = Start - | LLoser {-# UNPACK #-} !Size - {-# UNPACK #-} !(Elem a) - !(LTree a) - {-# UNPACK #-} !Key -- split key - !(LTree a) - | RLoser {-# UNPACK #-} !Size - {-# UNPACK #-} !(Elem a) - !(LTree a) - {-# UNPACK #-} !Key -- split key - !(LTree a) - deriving (Eq, Show) - -size' :: LTree a -> Size -size' Start = 0 -size' (LLoser s _ _ _ _) = s -size' (RLoser s _ _ _ _) = s - -left, right :: LTree a -> LTree a - -left Start = moduleError "left" "empty loser tree" -left (LLoser _ _ tl _ _ ) = tl -left (RLoser _ _ tl _ _ ) = tl - -right Start = moduleError "right" "empty loser tree" -right (LLoser _ _ _ _ tr) = tr -right (RLoser _ _ _ _ tr) = tr - -maxKey :: PSQ a -> Key -maxKey Void = moduleError "maxKey" "empty queue" -maxKey (Winner _ _ m) = m - -lloser, rloser :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a -lloser k p v tl m tr = LLoser (1 + size' tl + size' tr) (E k p v) tl m tr -rloser k p v tl m tr = RLoser (1 + size' tl + size' tr) (E k p v) tl m tr - ------------------------------------------------------------------------- --- Balancing - --- | Balance factor -omega :: Int -omega = 4 - -lbalance, rbalance :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a - -lbalance k p v l m r - | size' l + size' r < 2 = lloser k p v l m r - | size' r > omega * size' l = lbalanceLeft k p v l m r - | size' l > omega * size' r = lbalanceRight k p v l m r - | otherwise = lloser k p v l m r - -rbalance k p v l m r - | size' l + size' r < 2 = rloser k p v l m r - | size' r > omega * size' l = rbalanceLeft k p v l m r - | size' l > omega * size' r = rbalanceRight k p v l m r - | otherwise = rloser k p v l m r - -lbalanceLeft :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a -lbalanceLeft k p v l m r - | size' (left r) < size' (right r) = lsingleLeft k p v l m r - | otherwise = ldoubleLeft k p v l m r - -lbalanceRight :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a -lbalanceRight k p v l m r - | size' (left l) > size' (right l) = lsingleRight k p v l m r - | otherwise = ldoubleRight k p v l m r - -rbalanceLeft :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a -rbalanceLeft k p v l m r - | size' (left r) < size' (right r) = rsingleLeft k p v l m r - | otherwise = rdoubleLeft k p v l m r - -rbalanceRight :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a -rbalanceRight k p v l m r - | size' (left l) > size' (right l) = rsingleRight k p v l m r - | otherwise = rdoubleRight k p v l m r - -lsingleLeft :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a -lsingleLeft k1 p1 v1 t1 m1 (LLoser _ (E k2 p2 v2) t2 m2 t3) - | p1 <= p2 = lloser k1 p1 v1 (rloser k2 p2 v2 t1 m1 t2) m2 t3 - | otherwise = lloser k2 p2 v2 (lloser k1 p1 v1 t1 m1 t2) m2 t3 -lsingleLeft k1 p1 v1 t1 m1 (RLoser _ (E k2 p2 v2) t2 m2 t3) = - rloser k2 p2 v2 (lloser k1 p1 v1 t1 m1 t2) m2 t3 -lsingleLeft _ _ _ _ _ _ = moduleError "lsingleLeft" "malformed tree" - -rsingleLeft :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a -rsingleLeft k1 p1 v1 t1 m1 (LLoser _ (E k2 p2 v2) t2 m2 t3) = - rloser k1 p1 v1 (rloser k2 p2 v2 t1 m1 t2) m2 t3 -rsingleLeft k1 p1 v1 t1 m1 (RLoser _ (E k2 p2 v2) t2 m2 t3) = - rloser k2 p2 v2 (rloser k1 p1 v1 t1 m1 t2) m2 t3 -rsingleLeft _ _ _ _ _ _ = moduleError "rsingleLeft" "malformed tree" - -lsingleRight :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a -lsingleRight k1 p1 v1 (LLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 = - lloser k2 p2 v2 t1 m1 (lloser k1 p1 v1 t2 m2 t3) -lsingleRight k1 p1 v1 (RLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 = - lloser k1 p1 v1 t1 m1 (lloser k2 p2 v2 t2 m2 t3) -lsingleRight _ _ _ _ _ _ = moduleError "lsingleRight" "malformed tree" - -rsingleRight :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a -rsingleRight k1 p1 v1 (LLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 = - lloser k2 p2 v2 t1 m1 (rloser k1 p1 v1 t2 m2 t3) -rsingleRight k1 p1 v1 (RLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 - | p1 <= p2 = rloser k1 p1 v1 t1 m1 (lloser k2 p2 v2 t2 m2 t3) - | otherwise = rloser k2 p2 v2 t1 m1 (rloser k1 p1 v1 t2 m2 t3) -rsingleRight _ _ _ _ _ _ = moduleError "rsingleRight" "malformed tree" - -ldoubleLeft :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a -ldoubleLeft k1 p1 v1 t1 m1 (LLoser _ (E k2 p2 v2) t2 m2 t3) = - lsingleLeft k1 p1 v1 t1 m1 (lsingleRight k2 p2 v2 t2 m2 t3) -ldoubleLeft k1 p1 v1 t1 m1 (RLoser _ (E k2 p2 v2) t2 m2 t3) = - lsingleLeft k1 p1 v1 t1 m1 (rsingleRight k2 p2 v2 t2 m2 t3) -ldoubleLeft _ _ _ _ _ _ = moduleError "ldoubleLeft" "malformed tree" - -ldoubleRight :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a -ldoubleRight k1 p1 v1 (LLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 = - lsingleRight k1 p1 v1 (lsingleLeft k2 p2 v2 t1 m1 t2) m2 t3 -ldoubleRight k1 p1 v1 (RLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 = - lsingleRight k1 p1 v1 (rsingleLeft k2 p2 v2 t1 m1 t2) m2 t3 -ldoubleRight _ _ _ _ _ _ = moduleError "ldoubleRight" "malformed tree" - -rdoubleLeft :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a -rdoubleLeft k1 p1 v1 t1 m1 (LLoser _ (E k2 p2 v2) t2 m2 t3) = - rsingleLeft k1 p1 v1 t1 m1 (lsingleRight k2 p2 v2 t2 m2 t3) -rdoubleLeft k1 p1 v1 t1 m1 (RLoser _ (E k2 p2 v2) t2 m2 t3) = - rsingleLeft k1 p1 v1 t1 m1 (rsingleRight k2 p2 v2 t2 m2 t3) -rdoubleLeft _ _ _ _ _ _ = moduleError "rdoubleLeft" "malformed tree" - -rdoubleRight :: Key -> Prio -> a -> LTree a -> Key -> LTree a -> LTree a -rdoubleRight k1 p1 v1 (LLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 = - rsingleRight k1 p1 v1 (lsingleLeft k2 p2 v2 t1 m1 t2) m2 t3 -rdoubleRight k1 p1 v1 (RLoser _ (E k2 p2 v2) t1 m1 t2) m2 t3 = - rsingleRight k1 p1 v1 (rsingleLeft k2 p2 v2 t1 m1 t2) m2 t3 -rdoubleRight _ _ _ _ _ _ = moduleError "rdoubleRight" "malformed tree" - --- | Take two pennants and returns a new pennant that is the union of --- the two with the precondition that the keys in the ï¬rst tree are --- strictly smaller than the keys in the second tree. -play :: PSQ a -> PSQ a -> PSQ a -Void `play` t' = t' -t `play` Void = t -Winner e@(E k p v) t m `play` Winner e'@(E k' p' v') t' m' - | p <= p' = Winner e (rbalance k' p' v' t m t') m' - | otherwise = Winner e' (lbalance k p v t m t') m' -{-# INLINE play #-} - --- | A version of 'play' that can be used if the shape of the tree has --- not changed or if the tree is known to be balanced. -unsafePlay :: PSQ a -> PSQ a -> PSQ a -Void `unsafePlay` t' = t' -t `unsafePlay` Void = t -Winner e@(E k p v) t m `unsafePlay` Winner e'@(E k' p' v') t' m' - | p <= p' = Winner e (rloser k' p' v' t m t') m' - | otherwise = Winner e' (lloser k p v t m t') m' -{-# INLINE unsafePlay #-} - -data TourView a = Null - | Single {-# UNPACK #-} !(Elem a) - | (PSQ a) `Play` (PSQ a) - -tourView :: PSQ a -> TourView a -tourView Void = Null -tourView (Winner e Start _) = Single e -tourView (Winner e (RLoser _ e' tl m tr) m') = - Winner e tl m `Play` Winner e' tr m' -tourView (Winner e (LLoser _ e' tl m tr) m') = - Winner e' tl m `Play` Winner e tr m' - ------------------------------------------------------------------------- --- Utility functions - -moduleError :: String -> String -> a -moduleError fun msg = error ("System.Event.PSQ." ++ fun ++ ':' : ' ' : msg) -{-# NOINLINE moduleError #-} - ------------------------------------------------------------------------- --- Hughes's efficient sequence type - -newtype Sequ a = Sequ ([a] -> [a]) - -emptySequ :: Sequ a -emptySequ = Sequ (\as -> as) - -singleSequ :: a -> Sequ a -singleSequ a = Sequ (\as -> a : as) - -(<>) :: Sequ a -> Sequ a -> Sequ a -Sequ x1 <> Sequ x2 = Sequ (\as -> x1 (x2 as)) -infixr 5 <> - -seqToList :: Sequ a -> [a] -seqToList (Sequ x) = x [] - -instance Show a => Show (Sequ a) where - showsPrec d a = showsPrec d (seqToList a) diff -Nru ghc-7.0.3/libraries/base/System/Event/Thread.hs ghc-7.2.1/libraries/base/System/Event/Thread.hs --- ghc-7.0.3/libraries/base/System/Event/Thread.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/System/Event/Thread.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,143 +0,0 @@ -{-# LANGUAGE BangPatterns, ForeignFunctionInterface, NoImplicitPrelude #-} - -module System.Event.Thread - ( - ensureIOManagerIsRunning - , threadWaitRead - , threadWaitWrite - , closeFdWith - , threadDelay - , registerDelay - ) where - -import Data.IORef (IORef, newIORef, readIORef, writeIORef) -import Data.Maybe (Maybe(..)) -import Foreign.C.Error (eBADF, errnoToIOError) -import Foreign.Ptr (Ptr) -import GHC.Base -import GHC.Conc.Sync (TVar, ThreadId, ThreadStatus(..), atomically, forkIO, - labelThread, modifyMVar_, newTVar, sharedCAF, - threadStatus, writeTVar) -import GHC.IO (mask_, onException) -import GHC.IO.Exception (ioError) -import GHC.MVar (MVar, newEmptyMVar, newMVar, putMVar, takeMVar) -import System.Event.Internal (eventIs, evtClose) -import System.Event.Manager (Event, EventManager, evtRead, evtWrite, loop, - new, registerFd, unregisterFd_, registerTimeout) -import qualified System.Event.Manager as M -import System.IO.Unsafe (unsafePerformIO) -import System.Posix.Types (Fd) - --- | Suspends the current thread for a given number of microseconds --- (GHC only). --- --- There is no guarantee that the thread will be rescheduled promptly --- when the delay has expired, but the thread will never continue to --- run /earlier/ than specified. -threadDelay :: Int -> IO () -threadDelay usecs = mask_ $ do - Just mgr <- readIORef eventManager - m <- newEmptyMVar - reg <- registerTimeout mgr usecs (putMVar m ()) - takeMVar m `onException` M.unregisterTimeout mgr reg - --- | Set the value of returned TVar to True after a given number of --- microseconds. The caveats associated with threadDelay also apply. --- -registerDelay :: Int -> IO (TVar Bool) -registerDelay usecs = do - t <- atomically $ newTVar False - Just mgr <- readIORef eventManager - _ <- registerTimeout mgr usecs . atomically $ writeTVar t True - return t - --- | Block the current thread until data is available to read from the --- given file descriptor. --- --- This will throw an 'IOError' if the file descriptor was closed --- while this thread was blocked. To safely close a file descriptor --- that has been used with 'threadWaitRead', use 'closeFdWith'. -threadWaitRead :: Fd -> IO () -threadWaitRead = threadWait evtRead -{-# INLINE threadWaitRead #-} - --- | Block the current thread until the given file descriptor can --- accept data to write. --- --- This will throw an 'IOError' if the file descriptor was closed --- while this thread was blocked. To safely close a file descriptor --- that has been used with 'threadWaitWrite', use 'closeFdWith'. -threadWaitWrite :: Fd -> IO () -threadWaitWrite = threadWait evtWrite -{-# INLINE threadWaitWrite #-} - --- | Close a file descriptor in a concurrency-safe way. --- --- Any threads that are blocked on the file descriptor via --- 'threadWaitRead' or 'threadWaitWrite' will be unblocked by having --- IO exceptions thrown. -closeFdWith :: (Fd -> IO ()) -- ^ Action that performs the close. - -> Fd -- ^ File descriptor to close. - -> IO () -closeFdWith close fd = do - Just mgr <- readIORef eventManager - M.closeFd mgr close fd - -threadWait :: Event -> Fd -> IO () -threadWait evt fd = mask_ $ do - m <- newEmptyMVar - Just mgr <- readIORef eventManager - reg <- registerFd mgr (\reg e -> unregisterFd_ mgr reg >> putMVar m e) fd evt - evt' <- takeMVar m `onException` unregisterFd_ mgr reg - if evt' `eventIs` evtClose - then ioError $ errnoToIOError "threadWait" eBADF Nothing Nothing - else return () - -foreign import ccall unsafe "getOrSetSystemEventThreadEventManagerStore" - getOrSetSystemEventThreadEventManagerStore :: Ptr a -> IO (Ptr a) - -eventManager :: IORef (Maybe EventManager) -eventManager = unsafePerformIO $ do - em <- newIORef Nothing - sharedCAF em getOrSetSystemEventThreadEventManagerStore -{-# NOINLINE eventManager #-} - -foreign import ccall unsafe "getOrSetSystemEventThreadIOManagerThreadStore" - getOrSetSystemEventThreadIOManagerThreadStore :: Ptr a -> IO (Ptr a) - -{-# NOINLINE ioManager #-} -ioManager :: MVar (Maybe ThreadId) -ioManager = unsafePerformIO $ do - m <- newMVar Nothing - sharedCAF m getOrSetSystemEventThreadIOManagerThreadStore - -ensureIOManagerIsRunning :: IO () -ensureIOManagerIsRunning - | not threaded = return () - | otherwise = modifyMVar_ ioManager $ \old -> do - let create = do - !mgr <- new - writeIORef eventManager $ Just mgr - !t <- forkIO $ loop mgr - labelThread t "IOManager" - return $ Just t - case old of - Nothing -> create - st@(Just t) -> do - s <- threadStatus t - case s of - ThreadFinished -> create - ThreadDied -> do - -- Sanity check: if the thread has died, there is a chance - -- that event manager is still alive. This could happend during - -- the fork, for example. In this case we should clean up - -- open pipes and everything else related to the event manager. - -- See #4449 - mem <- readIORef eventManager - _ <- case mem of - Nothing -> return () - Just em -> M.cleanup em - create - _other -> return st - -foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool diff -Nru ghc-7.0.3/libraries/base/System/Event/Unique.hs ghc-7.2.1/libraries/base/System/Event/Unique.hs --- ghc-7.0.3/libraries/base/System/Event/Unique.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/System/Event/Unique.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,40 +0,0 @@ -{-# LANGUAGE BangPatterns, GeneralizedNewtypeDeriving, NoImplicitPrelude #-} -module System.Event.Unique - ( - UniqueSource - , Unique(..) - , newSource - , newUnique - ) where - -import Data.Int (Int64) -import GHC.Base -import GHC.Conc.Sync (TVar, atomically, newTVarIO, readTVar, writeTVar) -import GHC.Num (Num(..)) -import GHC.Show (Show(..)) - --- We used to use IORefs here, but Simon switched us to STM when we --- found that our use of atomicModifyIORef was subject to a severe RTS --- performance problem when used in a tight loop from multiple --- threads: http://hackage.haskell.org/trac/ghc/ticket/3838 --- --- There seems to be no performance cost to using a TVar instead. - -newtype UniqueSource = US (TVar Int64) - -newtype Unique = Unique { asInt64 :: Int64 } - deriving (Eq, Ord, Num) - -instance Show Unique where - show = show . asInt64 - -newSource :: IO UniqueSource -newSource = US `fmap` newTVarIO 0 - -newUnique :: UniqueSource -> IO Unique -newUnique (US ref) = atomically $ do - u <- readTVar ref - let !u' = u+1 - writeTVar ref u' - return $ Unique u' -{-# INLINE newUnique #-} diff -Nru ghc-7.0.3/libraries/base/System/Event.hs ghc-7.2.1/libraries/base/System/Event.hs --- ghc-7.0.3/libraries/base/System/Event.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/System/Event.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,39 +0,0 @@ --- | This module provides scalable event notification for file --- descriptors and timeouts. --- --- This module should be considered GHC internal. -module System.Event - ( -- * Types - EventManager - - -- * Creation - , new - - -- * Running - , loop - - -- ** Stepwise running - , step - , shutdown - - -- * Registering interest in I/O events - , Event - , evtRead - , evtWrite - , IOCallback - , FdKey(keyFd) - , registerFd - , registerFd_ - , unregisterFd - , unregisterFd_ - , closeFd - - -- * Registering interest in timeout events - , TimeoutCallback - , TimeoutKey - , registerTimeout - , updateTimeout - , unregisterTimeout - ) where - -import System.Event.Manager diff -Nru ghc-7.0.3/libraries/base/System/Exit.hs ghc-7.2.1/libraries/base/System/Exit.hs --- ghc-7.0.3/libraries/base/System/Exit.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/System/Exit.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,3 +1,6 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- | -- Module : System.Exit diff -Nru ghc-7.0.3/libraries/base/System/Info.hs ghc-7.2.1/libraries/base/System/Info.hs --- ghc-7.0.3/libraries/base/System/Info.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/System/Info.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,3 +1,6 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- | -- Module : System.Info diff -Nru ghc-7.0.3/libraries/base/System/IO/Error.hs ghc-7.2.1/libraries/base/System/IO/Error.hs --- ghc-7.0.3/libraries/base/System/IO/Error.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/System/IO/Error.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,5 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude #-} ----------------------------------------------------------------------------- -- | @@ -76,7 +77,9 @@ ioError, -- :: IOError -> IO a + catchIOError, -- :: IO a -> (IOError -> IO a) -> IO a catch, -- :: IO a -> (IOError -> IO a) -> IO a + tryIOError, -- :: IO a -> IO (Either IOError a) try, -- :: IO a -> IO (Either IOError a) modifyIOError, -- :: (IOError -> IOError) -> IO a -> IO a @@ -128,13 +131,20 @@ import Control.Monad (MonadPlus(mplus)) #endif --- | The construct 'try' @comp@ exposes IO errors which occur within a +-- | The construct 'tryIOError' @comp@ exposes IO errors which occur within a -- computation, and which are not fully handled. -- -- Non-I\/O exceptions are not caught by this variant; to catch all -- exceptions, use 'Control.Exception.try' from "Control.Exception". +tryIOError :: IO a -> IO (Either IOError a) +tryIOError f = catch (do r <- f + return (Right r)) + (return . Left) #ifndef __NHC__ +{-# DEPRECATED try "Please use the new exceptions variant, Control.Exception.try" #-} +-- | The 'try' function is deprecated. Please use the new exceptions +-- variant, 'Control.Exception.try' from "Control.Exception", instead. try :: IO a -> IO (Either IOError a) try f = catch (do r <- f return (Right r)) @@ -436,14 +446,16 @@ #endif #ifndef __HUGS__ --- | The 'catch' function establishes a handler that receives any 'IOError' --- raised in the action protected by 'catch'. An 'IOError' is caught by --- the most recent handler established by 'catch'. These handlers are +-- | The 'catchIOError' function establishes a handler that receives any +-- 'IOError' raised in the action protected by 'catchIOError'. +-- An 'IOError' is caught by +-- the most recent handler established by one of the exception handling +-- functions. These handlers are -- not selective: all 'IOError's are caught. Exception propagation -- must be explicitly provided in a handler by re-raising any unwanted -- exceptions. For example, in -- --- > f = catch g (\e -> if IO.isEOFError e then return [] else ioError e) +-- > f = catchIOError g (\e -> if IO.isEOFError e then return [] else ioError e) -- -- the function @f@ returns @[]@ when an end-of-file exception -- (cf. 'System.IO.Error.isEOFError') occurs in @g@; otherwise, the @@ -454,6 +466,12 @@ -- -- Non-I\/O exceptions are not caught by this variant; to catch all -- exceptions, use 'Control.Exception.catch' from "Control.Exception". +catchIOError :: IO a -> (IOError -> IO a) -> IO a +catchIOError = New.catch + +{-# DEPRECATED catch "Please use the new exceptions variant, Control.Exception.catch" #-} +-- | The 'catch' function is deprecated. Please use the new exceptions +-- variant, 'Control.Exception.catch' from "Control.Exception", instead. catch :: IO a -> (IOError -> IO a) -> IO a catch = New.catch #endif /* !__HUGS__ */ diff -Nru ghc-7.0.3/libraries/base/System/IO/Unsafe.hs ghc-7.2.1/libraries/base/System/IO/Unsafe.hs --- ghc-7.0.3/libraries/base/System/IO/Unsafe.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/System/IO/Unsafe.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,5 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE CPP, NoImplicitPrelude #-} + ----------------------------------------------------------------------------- -- | -- Module : System.IO.Unsafe @@ -16,18 +17,21 @@ module System.IO.Unsafe ( -- * Unsafe 'System.IO.IO' operations unsafePerformIO, -- :: IO a -> a + unsafeDupablePerformIO, -- :: IO a -> a unsafeInterleaveIO, -- :: IO a -> IO a ) where #ifdef __GLASGOW_HASKELL__ -import GHC.IO (unsafePerformIO, unsafeInterleaveIO) +import GHC.IO (unsafePerformIO, unsafeInterleaveIO, unsafeDupablePerformIO) #endif #ifdef __HUGS__ import Hugs.IOExts (unsafePerformIO, unsafeInterleaveIO) +unsafeDupablePerformIO = unsafePerformIO #endif #ifdef __NHC__ import NHC.Internal (unsafePerformIO, unsafeInterleaveIO) +unsafeDupablePerformIO = unsafePerformIO #endif diff -Nru ghc-7.0.3/libraries/base/System/IO.hs ghc-7.2.1/libraries/base/System/IO.hs --- ghc-7.0.3/libraries/base/System/IO.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/System/IO.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,6 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude #-} + ----------------------------------------------------------------------------- -- | -- Module : System.IO @@ -200,6 +202,7 @@ utf16, utf16le, utf16be, utf32, utf32le, utf32be, localeEncoding, + char8, mkTextEncoding, #endif @@ -244,7 +247,7 @@ #ifdef __GLASGOW_HASKELL__ import GHC.Base -import GHC.IO hiding ( onException ) +import GHC.IO hiding ( bracket, onException ) import GHC.IO.IOMode import GHC.IO.Handle.FD import qualified GHC.IO.FD as FD diff -Nru ghc-7.0.3/libraries/base/System/Mem/StableName.hs ghc-7.2.1/libraries/base/System/Mem/StableName.hs --- ghc-7.0.3/libraries/base/System/Mem/StableName.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/System/Mem/StableName.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,3 +1,13 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP #-} +#ifdef __GLASGOW_HASKELL__ +{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} +{-# LANGUAGE MagicHash #-} +#if !defined(__PARALLEL_HASKELL__) +{-# LANGUAGE UnboxedTuples #-} +#endif +#endif + ----------------------------------------------------------------------------- -- | -- Module : System.Mem.StableName diff -Nru ghc-7.0.3/libraries/base/System/Mem/Weak.hs ghc-7.2.1/libraries/base/System/Mem/Weak.hs --- ghc-7.0.3/libraries/base/System/Mem/Weak.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/System/Mem/Weak.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,3 +1,6 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- | -- Module : System.Mem.Weak @@ -67,16 +70,12 @@ -- $precise ) where -import Data.Maybe (Maybe(..)) - #ifdef __HUGS__ import Hugs.Weak import Prelude #endif #ifdef __GLASGOW_HASKELL__ -import GHC.Base (return) -import GHC.Types (IO) import GHC.Weak #endif diff -Nru ghc-7.0.3/libraries/base/System/Mem.hs ghc-7.2.1/libraries/base/System/Mem.hs --- ghc-7.0.3/libraries/base/System/Mem.hs 2011-03-26 18:10:11.000000000 +0000 +++ ghc-7.2.1/libraries/base/System/Mem.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,3 +1,10 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE CPP #-} + +#ifdef __GLASGOW_HASKELL__ +{-# LANGUAGE ForeignFunctionInterface #-} +#endif + ----------------------------------------------------------------------------- -- | -- Module : System.Mem diff -Nru ghc-7.0.3/libraries/base/System/Posix/Internals.hs ghc-7.2.1/libraries/base/System/Posix/Internals.hs --- ghc-7.0.3/libraries/base/System/Posix/Internals.hs 2011-03-26 18:10:12.000000000 +0000 +++ ghc-7.2.1/libraries/base/System/Posix/Internals.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,5 +1,5 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} -{-# OPTIONS_GHC -fno-warn-unused-binds #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude, ForeignFunctionInterface #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- @@ -52,6 +52,10 @@ import GHC.IO.IOMode import GHC.IO.Exception import GHC.IO.Device +#ifndef mingw32_HOST_OS +import {-# SOURCE #-} GHC.IO.Encoding (fileSystemEncoding) +import qualified GHC.Foreign as GHC +#endif #elif __HUGS__ import Hugs.Prelude (IOException(..), IOErrorType(..)) import Hugs.IO (IOMode(..)) @@ -66,6 +70,18 @@ {-# CFILES cbits/PrelIOUtils.c cbits/consUtils.c #-} #endif + +-- --------------------------------------------------------------------------- +-- Debugging the base package + +puts :: String -> IO () +puts s = withCAStringLen (s ++ "\n") $ \(p, len) -> do + -- In reality should be withCString, but assume ASCII to avoid loop + -- if this is called by GHC.Foreign + _ <- c_write 1 (castPtr p) (fromIntegral len) + return () + + -- --------------------------------------------------------------------------- -- Types @@ -172,10 +188,26 @@ #ifdef mingw32_HOST_OS withFilePath :: FilePath -> (CWString -> IO a) -> IO a -withFilePath = withCWString +withFilePath = withCWString + +peekFilePath :: CWString -> IO FilePath +peekFilePath = peekCWString #else + withFilePath :: FilePath -> (CString -> IO a) -> IO a +peekFilePath :: CString -> IO FilePath +peekFilePathLen :: CStringLen -> IO FilePath + +#if __GLASGOW_HASKELL__ +withFilePath = GHC.withCString fileSystemEncoding +peekFilePath = GHC.peekCString fileSystemEncoding +peekFilePathLen = GHC.peekCStringLen fileSystemEncoding +#else withFilePath = withCString +peekFilePath = peekCString +peekFilePathLen = peekCStringLen +#endif + #endif -- --------------------------------------------------------------------------- @@ -396,6 +428,9 @@ foreign import ccall unsafe "HsBase.h __hscore_open" c_open :: CFilePath -> CInt -> CMode -> IO CInt +foreign import ccall safe "HsBase.h __hscore_open" + c_safe_open :: CFilePath -> CInt -> CMode -> IO CInt + foreign import ccall unsafe "HsBase.h read" c_read :: CInt -> Ptr Word8 -> CSize -> IO CSsize diff -Nru ghc-7.0.3/libraries/base/System/Posix/Internals.hs-boot ghc-7.2.1/libraries/base/System/Posix/Internals.hs-boot --- ghc-7.0.3/libraries/base/System/Posix/Internals.hs-boot 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/base/System/Posix/Internals.hs-boot 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,8 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE NoImplicitPrelude #-} +module System.Posix.Internals where + +import GHC.IO +import GHC.Base + +puts :: String -> IO () diff -Nru ghc-7.0.3/libraries/base/System/Posix/Types.hs ghc-7.2.1/libraries/base/System/Posix/Types.hs --- ghc-7.0.3/libraries/base/System/Posix/Types.hs 2011-03-26 18:10:12.000000000 +0000 +++ ghc-7.2.1/libraries/base/System/Posix/Types.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,5 +1,13 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} -{-# OPTIONS_GHC -fno-warn-unused-binds #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP + , NoImplicitPrelude + , MagicHash + , GeneralizedNewtypeDeriving + #-} +#ifdef __GLASGOW_HASKELL__ +{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} +#endif + ----------------------------------------------------------------------------- -- | -- Module : System.Posix.Types diff -Nru ghc-7.0.3/libraries/base/System/Timeout.hs ghc-7.2.1/libraries/base/System/Timeout.hs --- ghc-7.0.3/libraries/base/System/Timeout.hs 2011-03-26 18:10:12.000000000 +0000 +++ ghc-7.2.1/libraries/base/System/Timeout.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,3 +1,9 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP #-} +#ifdef __GLASGOW_HASKELL__ +{-# LANGUAGE DeriveDataTypeable, StandaloneDeriving #-} +#endif + ------------------------------------------------------------------------------- -- | -- Module : System.Timeout @@ -32,7 +38,7 @@ -- interrupt the running IO computation when the timeout has -- expired. -data Timeout = Timeout Unique deriving Eq +newtype Timeout = Timeout Unique deriving Eq INSTANCE_TYPEABLE0(Timeout,timeoutTc,"Timeout") instance Show Timeout where diff -Nru ghc-7.0.3/libraries/base/tests/all.T ghc-7.2.1/libraries/base/tests/all.T --- ghc-7.0.3/libraries/base/tests/all.T 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/base/tests/all.T 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,7 @@ + +test('readFloat', exit_code(1), compile_and_run, ['']) +test('enumDouble', normal, compile_and_run, ['']) +test('enumRatio', normal, compile_and_run, ['']) +test('tempfiles', normal, compile_and_run, ['']) +test('fixed', normal, compile_and_run, ['']) +test('quotOverflow', normal, compile_and_run, ['']) diff -Nru ghc-7.0.3/libraries/base/tests/enumDouble.hs ghc-7.2.1/libraries/base/tests/enumDouble.hs --- ghc-7.0.3/libraries/base/tests/enumDouble.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/base/tests/enumDouble.hs 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,3 @@ + +main :: IO () +main = print (succ (1.0e20 :: Double)) diff -Nru ghc-7.0.3/libraries/base/tests/enumDouble.stdout ghc-7.2.1/libraries/base/tests/enumDouble.stdout --- ghc-7.0.3/libraries/base/tests/enumDouble.stdout 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/base/tests/enumDouble.stdout 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1 @@ +1.0e20 diff -Nru ghc-7.0.3/libraries/base/tests/enumRatio.hs ghc-7.2.1/libraries/base/tests/enumRatio.hs --- ghc-7.0.3/libraries/base/tests/enumRatio.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/base/tests/enumRatio.hs 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,3 @@ + +import Data.Ratio +main = print [ 1, 4%(3::Int) .. 1 ] diff -Nru ghc-7.0.3/libraries/base/tests/enumRatio.stdout ghc-7.2.1/libraries/base/tests/enumRatio.stdout --- ghc-7.0.3/libraries/base/tests/enumRatio.stdout 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/base/tests/enumRatio.stdout 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1 @@ +[1 % 1] diff -Nru ghc-7.0.3/libraries/base/tests/fixed.hs ghc-7.2.1/libraries/base/tests/fixed.hs --- ghc-7.0.3/libraries/base/tests/fixed.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/base/tests/fixed.hs 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,19 @@ +{-# OPTIONS_GHC -Wall -Werror #-} + +module Main where + +import Data.Fixed + +nums :: Fractional a => [a] +nums = [0,7,7.1,7.01,7.9,7.09,5 + 7,3.2 - 7.8,5.75 * (-2)] + +main :: IO () +main = do mapM_ putStrLn $ doit (nums :: [Micro]) + mapM_ putStrLn $ doit (nums :: [Pico]) + +doit :: HasResolution a => [Fixed a] -> [String] +doit xs = [ showFun (signFun x) + | showFun <- [show, showFixed True] + , signFun <- [id, negate] + , x <- xs ] + diff -Nru ghc-7.0.3/libraries/base/tests/fixed.stdout ghc-7.2.1/libraries/base/tests/fixed.stdout --- ghc-7.0.3/libraries/base/tests/fixed.stdout 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/base/tests/fixed.stdout 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,72 @@ +0.000000 +7.000000 +7.100000 +7.010000 +7.900000 +7.090000 +12.000000 +-4.600000 +-11.500000 +0.000000 +-7.000000 +-7.100000 +-7.010000 +-7.900000 +-7.090000 +-12.000000 +4.600000 +11.500000 +0 +7 +7.1 +7.01 +7.9 +7.09 +12 +-4.6 +-11.5 +0 +-7 +-7.1 +-7.01 +-7.9 +-7.09 +-12 +4.6 +11.5 +0.000000000000 +7.000000000000 +7.100000000000 +7.010000000000 +7.900000000000 +7.090000000000 +12.000000000000 +-4.600000000000 +-11.500000000000 +0.000000000000 +-7.000000000000 +-7.100000000000 +-7.010000000000 +-7.900000000000 +-7.090000000000 +-12.000000000000 +4.600000000000 +11.500000000000 +0 +7 +7.1 +7.01 +7.9 +7.09 +12 +-4.6 +-11.5 +0 +-7 +-7.1 +-7.01 +-7.9 +-7.09 +-12 +4.6 +11.5 diff -Nru ghc-7.0.3/libraries/base/tests/Makefile ghc-7.2.1/libraries/base/tests/Makefile --- ghc-7.0.3/libraries/base/tests/Makefile 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/base/tests/Makefile 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,7 @@ +# This Makefile runs the tests using GHC's testsuite framework. It +# assumes the package is part of a GHC build tree with the testsuite +# installed in ../../../testsuite. + +TOP=../../../testsuite +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff -Nru ghc-7.0.3/libraries/base/tests/quotOverflow.hs ghc-7.2.1/libraries/base/tests/quotOverflow.hs --- ghc-7.0.3/libraries/base/tests/quotOverflow.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/base/tests/quotOverflow.hs 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,33 @@ + +import Control.Exception as E + +import Data.Int + +main :: IO () +main = do putStrLn "Int8" + mapM_ p =<< (f :: IO [Either Int8 String]) + putStrLn "Int16" + mapM_ p =<< (f :: IO [Either Int16 String]) + putStrLn "Int32" + mapM_ p =<< (f :: IO [Either Int32 String]) + putStrLn "Int64" + mapM_ p =<< (f :: IO [Either Int64 String]) + putStrLn "Int" + mapM_ p =<< (f :: IO [Either Int String]) + where p (Left x) = print x + p (Right e) = putStrLn e + +f :: (Integral a, Bounded a) => IO [Either a String] +f = sequence [ g (minBound `div` (-1)), + g (minBound `mod` (-1)), + g (case minBound `divMod` (-1) of (x, _) -> x), + g (case minBound `divMod` (-1) of (_, x) -> x), + g (minBound `quot` (-1)), + g (minBound `rem` (-1)), + g (case minBound `quotRem` (-1) of (x, _) -> x), + g (case minBound `quotRem` (-1) of (_, x) -> x) ] + where g x = do x' <- evaluate x + return (Left x') + `E.catch` + \e -> return (Right (show (e :: SomeException))) + diff -Nru ghc-7.0.3/libraries/base/tests/quotOverflow.stdout ghc-7.2.1/libraries/base/tests/quotOverflow.stdout --- ghc-7.0.3/libraries/base/tests/quotOverflow.stdout 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/base/tests/quotOverflow.stdout 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,45 @@ +Int8 +arithmetic overflow +0 +arithmetic overflow +0 +arithmetic overflow +0 +arithmetic overflow +0 +Int16 +arithmetic overflow +0 +arithmetic overflow +0 +arithmetic overflow +0 +arithmetic overflow +0 +Int32 +arithmetic overflow +0 +arithmetic overflow +0 +arithmetic overflow +0 +arithmetic overflow +0 +Int64 +arithmetic overflow +0 +arithmetic overflow +0 +arithmetic overflow +0 +arithmetic overflow +0 +Int +arithmetic overflow +0 +arithmetic overflow +0 +arithmetic overflow +0 +arithmetic overflow +0 diff -Nru ghc-7.0.3/libraries/base/tests/readFloat.hs ghc-7.2.1/libraries/base/tests/readFloat.hs --- ghc-7.0.3/libraries/base/tests/readFloat.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/base/tests/readFloat.hs 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,5 @@ + +import Numeric + +main :: IO () +main = putStrLn $ showFloat (read "" :: Float) "" diff -Nru ghc-7.0.3/libraries/base/tests/readFloat.stderr ghc-7.2.1/libraries/base/tests/readFloat.stderr --- ghc-7.0.3/libraries/base/tests/readFloat.stderr 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/base/tests/readFloat.stderr 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1 @@ +readFloat: Prelude.read: no parse diff -Nru ghc-7.0.3/libraries/base/tests/tempfiles.hs ghc-7.2.1/libraries/base/tests/tempfiles.hs --- ghc-7.0.3/libraries/base/tests/tempfiles.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/base/tests/tempfiles.hs 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,36 @@ + +import Control.Exception +import Data.List +import System.FilePath +import System.Directory +import System.IO + +-- Checks that openTempFile returns filenames with the right structure +main :: IO () +main = do + fp0 <- otf ".no_prefix.hs" + print (".hs" `isSuffixOf` fp0) + print (".no_prefix" `isPrefixOf` takeFileName fp0) + + fp1 <- otf "no_suffix" + print (not ('.' `elem` fp1)) + print ("no_suffix" `isPrefixOf` takeFileName fp1) + + fp2 <- otf "one_suffix.hs" + print (".hs" `isSuffixOf` fp2) + print ("one_suffix" `isPrefixOf` takeFileName fp2) + + fp3 <- otf "two_suffixes.hs.blah" + print (".blah" `isSuffixOf` fp3) + print ("two_suffixes.hs" `isPrefixOf` takeFileName fp3) + +otf :: FilePath -> IO FilePath +otf fp = do putStrLn fp + bracket (openTempFile "." fp) + (\(fp', h) -> do hClose h + removeFile fp') + (\(fp', _) -> case fp' of + '.' : '/' : fp'' -> return fp'' + '.' : '\\' : fp'' -> return fp'' + _ -> return fp') + diff -Nru ghc-7.0.3/libraries/base/tests/tempfiles.stdout ghc-7.2.1/libraries/base/tests/tempfiles.stdout --- ghc-7.0.3/libraries/base/tests/tempfiles.stdout 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/base/tests/tempfiles.stdout 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,12 @@ +.no_prefix.hs +True +True +no_suffix +True +True +one_suffix.hs +True +True +two_suffixes.hs.blah +True +True diff -Nru ghc-7.0.3/libraries/base/Text/ParserCombinators/ReadP.hs ghc-7.2.1/libraries/base/Text/ParserCombinators/ReadP.hs --- ghc-7.0.3/libraries/base/Text/ParserCombinators/ReadP.hs 2011-03-26 18:10:12.000000000 +0000 +++ ghc-7.2.1/libraries/base/Text/ParserCombinators/ReadP.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,12 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude #-} +#ifndef __NHC__ +{-# LANGUAGE Rank2Types #-} +#endif +#ifdef __GLASGOW_HASKELL__ +{-# LANGUAGE MagicHash #-} +#endif + ----------------------------------------------------------------------------- -- | -- Module : Text.ParserCombinators.ReadP diff -Nru ghc-7.0.3/libraries/base/Text/ParserCombinators/ReadPrec.hs ghc-7.2.1/libraries/base/Text/ParserCombinators/ReadPrec.hs --- ghc-7.0.3/libraries/base/Text/ParserCombinators/ReadPrec.hs 2011-03-26 18:10:12.000000000 +0000 +++ ghc-7.2.1/libraries/base/Text/ParserCombinators/ReadPrec.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,6 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude #-} + ----------------------------------------------------------------------------- -- | -- Module : Text.ParserCombinators.ReadPrec diff -Nru ghc-7.0.3/libraries/base/Text/Printf.hs ghc-7.2.1/libraries/base/Text/Printf.hs --- ghc-7.0.3/libraries/base/Text/Printf.hs 2011-03-26 18:10:12.000000000 +0000 +++ ghc-7.2.1/libraries/base/Text/Printf.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,3 +1,6 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE CPP #-} + ----------------------------------------------------------------------------- -- | -- Module : Text.Printf diff -Nru ghc-7.0.3/libraries/base/Text/Read/Lex.hs ghc-7.2.1/libraries/base/Text/Read/Lex.hs --- ghc-7.0.3/libraries/base/Text/Read/Lex.hs 2011-03-26 18:10:12.000000000 +0000 +++ ghc-7.2.1/libraries/base/Text/Read/Lex.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,6 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude #-} + ----------------------------------------------------------------------------- -- | -- Module : Text.Read.Lex diff -Nru ghc-7.0.3/libraries/base/Text/Read.hs ghc-7.2.1/libraries/base/Text/Read.hs --- ghc-7.0.3/libraries/base/Text/Read.hs 2011-03-26 18:10:12.000000000 +0000 +++ ghc-7.2.1/libraries/base/Text/Read.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,6 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE CPP, NoImplicitPrelude #-} + ----------------------------------------------------------------------------- -- | -- Module : Text.Read diff -Nru ghc-7.0.3/libraries/base/Text/Show/Functions.hs ghc-7.2.1/libraries/base/Text/Show/Functions.hs --- ghc-7.0.3/libraries/base/Text/Show/Functions.hs 2011-03-26 18:10:12.000000000 +0000 +++ ghc-7.2.1/libraries/base/Text/Show/Functions.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,5 +1,8 @@ +{-# LANGUAGE Safe #-} +{-# LANGUAGE CPP #-} -- This module deliberately declares orphan instances: {-# OPTIONS_GHC -fno-warn-orphans #-} + ----------------------------------------------------------------------------- -- | -- Module : Text.Show.Functions diff -Nru ghc-7.0.3/libraries/base/Text/Show.hs ghc-7.2.1/libraries/base/Text/Show.hs --- ghc-7.0.3/libraries/base/Text/Show.hs 2011-03-26 18:10:12.000000000 +0000 +++ ghc-7.2.1/libraries/base/Text/Show.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,6 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE CPP, NoImplicitPrelude #-} + ----------------------------------------------------------------------------- -- | -- Module : Text.Show diff -Nru ghc-7.0.3/libraries/base/Unsafe/Coerce.hs ghc-7.2.1/libraries/base/Unsafe/Coerce.hs --- ghc-7.0.3/libraries/base/Unsafe/Coerce.hs 2011-03-26 18:10:12.000000000 +0000 +++ ghc-7.2.1/libraries/base/Unsafe/Coerce.hs 2011-08-07 17:10:07.000000000 +0000 @@ -1,4 +1,5 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude #-} +{-# LANGUAGE CPP, NoImplicitPrelude, MagicHash #-} + ----------------------------------------------------------------------------- -- | -- Module : Unsafe.Coerce diff -Nru ghc-7.0.3/libraries/binary/benchmarks/Benchmark.hs ghc-7.2.1/libraries/binary/benchmarks/Benchmark.hs --- ghc-7.0.3/libraries/binary/benchmarks/Benchmark.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/binary/benchmarks/Benchmark.hs 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,1461 @@ +{-# LANGUAGE BangPatterns #-} +module Main (main) where + +import qualified Data.ByteString.Lazy as L +import Data.Binary +import Data.Binary.Put +import Data.Binary.Get + +import Control.Exception +import System.CPUTime +import Numeric +import Text.Printf +import System.Environment + +import MemBench + +data Endian + = Big + | Little + | Host + deriving (Eq,Ord,Show) + +main :: IO () +main = do + mb <- getArgs >>= readIO . head + memBench (mb*10) + putStrLn "" + putStrLn "Binary (de)serialisation benchmarks:" + + -- do bytewise + sequence_ + [ test wordSize chunkSize Host mb + | wordSize <- [1] + , chunkSize <- [16] --1,2,4,8,16] + ] + + -- now Word16 .. Word64 + sequence_ + [ test wordSize chunkSize end mb + | wordSize <- [2,4,8] + , chunkSize <- [16] + , end <- [Host] -- ,Big,Little] + ] + +------------------------------------------------------------------------ + +time :: IO a -> IO Double +time action = do + start <- getCPUTime + action + end <- getCPUTime + return $! (fromIntegral (end - start)) / (10^12) + +------------------------------------------------------------------------ + +test :: Int -> Int -> Endian -> Int -> IO () +test wordSize chunkSize end mb = do + let bytes :: Int + bytes = mb * 2^20 + iterations = bytes `div` wordSize + bs = runPut (doPut wordSize chunkSize end iterations) + sum = runGet (doGet wordSize chunkSize end iterations) bs + + case (chunkSize,end) of (1,Host) -> putStrLn "" ; _ -> return () + + printf "%dMB of Word%-2d in chunks of %2d (%6s endian): " + (mb :: Int) (8 * wordSize :: Int) (chunkSize :: Int) (show end) + + putSeconds <- time $ evaluate (L.length bs) + getSeconds <- time $ evaluate sum +-- print (L.length bs, sum) + let putThroughput = fromIntegral mb / putSeconds + getThroughput = fromIntegral mb / getSeconds + + printf "%6.1f MB/s write, %6.1f MB/s read, %5.1f get/put-ratio\n" + putThroughput + getThroughput + (getThroughput/putThroughput) + +------------------------------------------------------------------------ + +doPut :: Int -> Int -> Endian -> Int -> Put +doPut wordSize chunkSize end = case (wordSize, chunkSize, end) of + (1, 1,_) -> putWord8N1 + (1, 2,_) -> putWord8N2 + (1, 4,_) -> putWord8N4 + (1, 8,_) -> putWord8N8 + (1, 16, _) -> putWord8N16 + + (2, 1, Big) -> putWord16N1Big + (2, 2, Big) -> putWord16N2Big + (2, 4, Big) -> putWord16N4Big + (2, 8, Big) -> putWord16N8Big + (2, 16, Big) -> putWord16N16Big + (2, 1, Little) -> putWord16N1Little + (2, 2, Little) -> putWord16N2Little + (2, 4, Little) -> putWord16N4Little + (2, 8, Little) -> putWord16N8Little + (2, 16, Little) -> putWord16N16Little + (2, 1, Host) -> putWord16N1Host + (2, 2, Host) -> putWord16N2Host + (2, 4, Host) -> putWord16N4Host + (2, 8, Host) -> putWord16N8Host + (2, 16, Host) -> putWord16N16Host + + (4, 1, Big) -> putWord32N1Big + (4, 2, Big) -> putWord32N2Big + (4, 4, Big) -> putWord32N4Big + (4, 8, Big) -> putWord32N8Big + (4, 16, Big) -> putWord32N16Big + (4, 1, Little) -> putWord32N1Little + (4, 2, Little) -> putWord32N2Little + (4, 4, Little) -> putWord32N4Little + (4, 8, Little) -> putWord32N8Little + (4, 16, Little) -> putWord32N16Little + (4, 1, Host) -> putWord32N1Host + (4, 2, Host) -> putWord32N2Host + (4, 4, Host) -> putWord32N4Host + (4, 8, Host) -> putWord32N8Host + (4, 16, Host) -> putWord32N16Host + + (8, 1, Host) -> putWord64N1Host + (8, 2, Host) -> putWord64N2Host + (8, 4, Host) -> putWord64N4Host + (8, 8, Host) -> putWord64N8Host + (8, 16, Host) -> putWord64N16Host + (8, 1, Big) -> putWord64N1Big + (8, 2, Big) -> putWord64N2Big + (8, 4, Big) -> putWord64N4Big + (8, 8, Big) -> putWord64N8Big + (8, 16, Big) -> putWord64N16Big + (8, 1, Little) -> putWord64N1Little + (8, 2, Little) -> putWord64N2Little + (8, 4, Little) -> putWord64N4Little + (8, 8, Little) -> putWord64N8Little + (8, 16, Little) -> putWord64N16Little + +------------------------------------------------------------------------ + +doGet :: Int -> Int -> Endian -> Int -> Get Int +doGet wordSize chunkSize end = + case (wordSize, chunkSize, end) of + (1, 1,_) -> fmap fromIntegral . getWord8N1 + (1, 2,_) -> fmap fromIntegral . getWord8N2 + (1, 4,_) -> fmap fromIntegral . getWord8N4 + (1, 8,_) -> fmap fromIntegral . getWord8N8 + (1, 16,_) -> fmap fromIntegral . getWord8N16 + + (2, 1,Big) -> fmap fromIntegral . getWord16N1Big + (2, 2,Big) -> fmap fromIntegral . getWord16N2Big + (2, 4,Big) -> fmap fromIntegral . getWord16N4Big + (2, 8,Big) -> fmap fromIntegral . getWord16N8Big + (2, 16,Big) -> fmap fromIntegral . getWord16N16Big + (2, 1,Little) -> fmap fromIntegral . getWord16N1Little + (2, 2,Little) -> fmap fromIntegral . getWord16N2Little + (2, 4,Little) -> fmap fromIntegral . getWord16N4Little + (2, 8,Little) -> fmap fromIntegral . getWord16N8Little + (2, 16,Little) -> fmap fromIntegral . getWord16N16Little + (2, 1,Host) -> fmap fromIntegral . getWord16N1Host + (2, 2,Host) -> fmap fromIntegral . getWord16N2Host + (2, 4,Host) -> fmap fromIntegral . getWord16N4Host + (2, 8,Host) -> fmap fromIntegral . getWord16N8Host + (2, 16,Host) -> fmap fromIntegral . getWord16N16Host + + (4, 1,Big) -> fmap fromIntegral . getWord32N1Big + (4, 2,Big) -> fmap fromIntegral . getWord32N2Big + (4, 4,Big) -> fmap fromIntegral . getWord32N4Big + (4, 8,Big) -> fmap fromIntegral . getWord32N8Big + (4, 16,Big) -> fmap fromIntegral . getWord32N16Big + (4, 1,Little) -> fmap fromIntegral . getWord32N1Little + (4, 2,Little) -> fmap fromIntegral . getWord32N2Little + (4, 4,Little) -> fmap fromIntegral . getWord32N4Little + (4, 8,Little) -> fmap fromIntegral . getWord32N8Little + (4, 16,Little) -> fmap fromIntegral . getWord32N16Little + (4, 1,Host) -> fmap fromIntegral . getWord32N1Host + (4, 2,Host) -> fmap fromIntegral . getWord32N2Host + (4, 4,Host) -> fmap fromIntegral . getWord32N4Host + (4, 8,Host) -> fmap fromIntegral . getWord32N8Host + (4, 16,Host) -> fmap fromIntegral . getWord32N16Host + + (8, 1,Host) -> fmap fromIntegral . getWord64N1Host + (8, 2,Host) -> fmap fromIntegral . getWord64N2Host + (8, 4,Host) -> fmap fromIntegral . getWord64N4Host + (8, 8,Host) -> fmap fromIntegral . getWord64N8Host + (8, 16,Host) -> fmap fromIntegral . getWord64N16Host + (8, 1,Big) -> fmap fromIntegral . getWord64N1Big + (8, 2,Big) -> fmap fromIntegral . getWord64N2Big + (8, 4,Big) -> fmap fromIntegral . getWord64N4Big + (8, 8,Big) -> fmap fromIntegral . getWord64N8Big + (8, 16,Big) -> fmap fromIntegral . getWord64N16Big + (8, 1,Little) -> fmap fromIntegral . getWord64N1Little + (8, 2,Little) -> fmap fromIntegral . getWord64N2Little + (8, 4,Little) -> fmap fromIntegral . getWord64N4Little + (8, 8,Little) -> fmap fromIntegral . getWord64N8Little + (8, 16,Little) -> fmap fromIntegral . getWord64N16Little + +------------------------------------------------------------------------ + +putWord8N1 bytes = loop 0 0 + where loop :: Word8 -> Int -> Put + loop !s !n | n == bytes = return () + | otherwise = do putWord8 s + loop (s+1) (n+1) + +putWord8N2 = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord8 (s+0) + putWord8 (s+1) + loop (s+2) (n-2) + +putWord8N4 = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord8 (s+0) + putWord8 (s+1) + putWord8 (s+2) + putWord8 (s+3) + loop (s+4) (n-4) + +putWord8N8 = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord8 (s+0) + putWord8 (s+1) + putWord8 (s+2) + putWord8 (s+3) + putWord8 (s+4) + putWord8 (s+5) + putWord8 (s+6) + putWord8 (s+7) + loop (s+8) (n-8) + +putWord8N16 = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord8 (s+0) + putWord8 (s+1) + putWord8 (s+2) + putWord8 (s+3) + putWord8 (s+4) + putWord8 (s+5) + putWord8 (s+6) + putWord8 (s+7) + putWord8 (s+8) + putWord8 (s+9) + putWord8 (s+10) + putWord8 (s+11) + putWord8 (s+12) + putWord8 (s+13) + putWord8 (s+14) + putWord8 (s+15) + loop (s+16) (n-16) + +------------------------------------------------------------------------ +-- Big endian, word16 writes + +putWord16N1Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord16be (s+0) + loop (s+1) (n-1) + +putWord16N2Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord16be (s+0) + putWord16be (s+1) + loop (s+2) (n-2) + +putWord16N4Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord16be (s+0) + putWord16be (s+1) + putWord16be (s+2) + putWord16be (s+3) + loop (s+4) (n-4) + +putWord16N8Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord16be (s+0) + putWord16be (s+1) + putWord16be (s+2) + putWord16be (s+3) + putWord16be (s+4) + putWord16be (s+5) + putWord16be (s+6) + putWord16be (s+7) + loop (s+8) (n-8) + +putWord16N16Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord16be (s+0) + putWord16be (s+1) + putWord16be (s+2) + putWord16be (s+3) + putWord16be (s+4) + putWord16be (s+5) + putWord16be (s+6) + putWord16be (s+7) + putWord16be (s+8) + putWord16be (s+9) + putWord16be (s+10) + putWord16be (s+11) + putWord16be (s+12) + putWord16be (s+13) + putWord16be (s+14) + putWord16be (s+15) + loop (s+16) (n-16) + +------------------------------------------------------------------------ +-- Little endian, word16 writes + +putWord16N1Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord16le (s+0) + loop (s+1) (n-1) + +putWord16N2Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord16le (s+0) + putWord16le (s+1) + loop (s+2) (n-2) + +putWord16N4Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord16le (s+0) + putWord16le (s+1) + putWord16le (s+2) + putWord16le (s+3) + loop (s+4) (n-4) + +putWord16N8Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord16le (s+0) + putWord16le (s+1) + putWord16le (s+2) + putWord16le (s+3) + putWord16le (s+4) + putWord16le (s+5) + putWord16le (s+6) + putWord16le (s+7) + loop (s+8) (n-8) + +putWord16N16Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord16le (s+0) + putWord16le (s+1) + putWord16le (s+2) + putWord16le (s+3) + putWord16le (s+4) + putWord16le (s+5) + putWord16le (s+6) + putWord16le (s+7) + putWord16le (s+8) + putWord16le (s+9) + putWord16le (s+10) + putWord16le (s+11) + putWord16le (s+12) + putWord16le (s+13) + putWord16le (s+14) + putWord16le (s+15) + loop (s+16) (n-16) + +------------------------------------------------------------------------ +-- Host endian, unaligned, word16 writes + +putWord16N1Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord16host (s+0) + loop (s+1) (n-1) + +putWord16N2Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord16host (s+0) + putWord16host (s+1) + loop (s+2) (n-2) + +putWord16N4Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord16host (s+0) + putWord16host (s+1) + putWord16host (s+2) + putWord16host (s+3) + loop (s+4) (n-4) + +putWord16N8Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord16host (s+0) + putWord16host (s+1) + putWord16host (s+2) + putWord16host (s+3) + putWord16host (s+4) + putWord16host (s+5) + putWord16host (s+6) + putWord16host (s+7) + loop (s+8) (n-8) + +putWord16N16Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord16host (s+0) + putWord16host (s+1) + putWord16host (s+2) + putWord16host (s+3) + putWord16host (s+4) + putWord16host (s+5) + putWord16host (s+6) + putWord16host (s+7) + putWord16host (s+8) + putWord16host (s+9) + putWord16host (s+10) + putWord16host (s+11) + putWord16host (s+12) + putWord16host (s+13) + putWord16host (s+14) + putWord16host (s+15) + loop (s+16) (n-16) + +------------------------------------------------------------------------ + +putWord32N1Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord32be (s+0) + loop (s+1) (n-1) + +putWord32N2Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord32be (s+0) + putWord32be (s+1) + loop (s+2) (n-2) + +putWord32N4Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord32be (s+0) + putWord32be (s+1) + putWord32be (s+2) + putWord32be (s+3) + loop (s+4) (n-4) + +putWord32N8Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord32be (s+0) + putWord32be (s+1) + putWord32be (s+2) + putWord32be (s+3) + putWord32be (s+4) + putWord32be (s+5) + putWord32be (s+6) + putWord32be (s+7) + loop (s+8) (n-8) + +putWord32N16Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord32be (s+0) + putWord32be (s+1) + putWord32be (s+2) + putWord32be (s+3) + putWord32be (s+4) + putWord32be (s+5) + putWord32be (s+6) + putWord32be (s+7) + putWord32be (s+8) + putWord32be (s+9) + putWord32be (s+10) + putWord32be (s+11) + putWord32be (s+12) + putWord32be (s+13) + putWord32be (s+14) + putWord32be (s+15) + loop (s+16) (n-16) + +------------------------------------------------------------------------ + +putWord32N1Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord32le (s+0) + loop (s+1) (n-1) + +putWord32N2Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord32le (s+0) + putWord32le (s+1) + loop (s+2) (n-2) + +putWord32N4Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord32le (s+0) + putWord32le (s+1) + putWord32le (s+2) + putWord32le (s+3) + loop (s+4) (n-4) + +putWord32N8Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord32le (s+0) + putWord32le (s+1) + putWord32le (s+2) + putWord32le (s+3) + putWord32le (s+4) + putWord32le (s+5) + putWord32le (s+6) + putWord32le (s+7) + loop (s+8) (n-8) + +putWord32N16Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord32le (s+0) + putWord32le (s+1) + putWord32le (s+2) + putWord32le (s+3) + putWord32le (s+4) + putWord32le (s+5) + putWord32le (s+6) + putWord32le (s+7) + putWord32le (s+8) + putWord32le (s+9) + putWord32le (s+10) + putWord32le (s+11) + putWord32le (s+12) + putWord32le (s+13) + putWord32le (s+14) + putWord32le (s+15) + loop (s+16) (n-16) + +------------------------------------------------------------------------ + +putWord32N1Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord32host (s+0) + loop (s+1) (n-1) + +putWord32N2Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord32host (s+0) + putWord32host (s+1) + loop (s+2) (n-2) + +putWord32N4Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord32host (s+0) + putWord32host (s+1) + putWord32host (s+2) + putWord32host (s+3) + loop (s+4) (n-4) + +putWord32N8Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord32host (s+0) + putWord32host (s+1) + putWord32host (s+2) + putWord32host (s+3) + putWord32host (s+4) + putWord32host (s+5) + putWord32host (s+6) + putWord32host (s+7) + loop (s+8) (n-8) + +putWord32N16Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord32host (s+0) + putWord32host (s+1) + putWord32host (s+2) + putWord32host (s+3) + putWord32host (s+4) + putWord32host (s+5) + putWord32host (s+6) + putWord32host (s+7) + putWord32host (s+8) + putWord32host (s+9) + putWord32host (s+10) + putWord32host (s+11) + putWord32host (s+12) + putWord32host (s+13) + putWord32host (s+14) + putWord32host (s+15) + loop (s+16) (n-16) + +------------------------------------------------------------------------ + +putWord64N1Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord64be (s+0) + loop (s+1) (n-1) + +putWord64N2Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord64be (s+0) + putWord64be (s+1) + loop (s+2) (n-2) + +putWord64N4Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord64be (s+0) + putWord64be (s+1) + putWord64be (s+2) + putWord64be (s+3) + loop (s+4) (n-4) + +putWord64N8Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord64be (s+0) + putWord64be (s+1) + putWord64be (s+2) + putWord64be (s+3) + putWord64be (s+4) + putWord64be (s+5) + putWord64be (s+6) + putWord64be (s+7) + loop (s+8) (n-8) + +putWord64N16Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord64be (s+0) + putWord64be (s+1) + putWord64be (s+2) + putWord64be (s+3) + putWord64be (s+4) + putWord64be (s+5) + putWord64be (s+6) + putWord64be (s+7) + putWord64be (s+8) + putWord64be (s+9) + putWord64be (s+10) + putWord64be (s+11) + putWord64be (s+12) + putWord64be (s+13) + putWord64be (s+14) + putWord64be (s+15) + loop (s+16) (n-16) + +------------------------------------------------------------------------ + +putWord64N1Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord64le (s+0) + loop (s+1) (n-1) + +putWord64N2Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord64le (s+0) + putWord64le (s+1) + loop (s+2) (n-2) + +putWord64N4Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord64le (s+0) + putWord64le (s+1) + putWord64le (s+2) + putWord64le (s+3) + loop (s+4) (n-4) + +putWord64N8Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord64le (s+0) + putWord64le (s+1) + putWord64le (s+2) + putWord64le (s+3) + putWord64le (s+4) + putWord64le (s+5) + putWord64le (s+6) + putWord64le (s+7) + loop (s+8) (n-8) + +putWord64N16Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord64le (s+0) + putWord64le (s+1) + putWord64le (s+2) + putWord64le (s+3) + putWord64le (s+4) + putWord64le (s+5) + putWord64le (s+6) + putWord64le (s+7) + putWord64le (s+8) + putWord64le (s+9) + putWord64le (s+10) + putWord64le (s+11) + putWord64le (s+12) + putWord64le (s+13) + putWord64le (s+14) + putWord64le (s+15) + loop (s+16) (n-16) + +------------------------------------------------------------------------ + +putWord64N1Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord64host (s+0) + loop (s+1) (n-1) + +putWord64N2Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord64host (s+0) + putWord64host (s+1) + loop (s+2) (n-2) + +putWord64N4Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord64host (s+0) + putWord64host (s+1) + putWord64host (s+2) + putWord64host (s+3) + loop (s+4) (n-4) + +putWord64N8Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord64host (s+0) + putWord64host (s+1) + putWord64host (s+2) + putWord64host (s+3) + putWord64host (s+4) + putWord64host (s+5) + putWord64host (s+6) + putWord64host (s+7) + loop (s+8) (n-8) + +putWord64N16Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = return () + loop s n = do + putWord64host (s+0) + putWord64host (s+1) + putWord64host (s+2) + putWord64host (s+3) + putWord64host (s+4) + putWord64host (s+5) + putWord64host (s+6) + putWord64host (s+7) + putWord64host (s+8) + putWord64host (s+9) + putWord64host (s+10) + putWord64host (s+11) + putWord64host (s+12) + putWord64host (s+13) + putWord64host (s+14) + putWord64host (s+15) + loop (s+16) (n-16) + +------------------------------------------------------------------------ +------------------------------------------------------------------------ + +getWord8N1 = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord8 + loop (s+s0) (n-1) + +getWord8N2 = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord8 + s1 <- getWord8 + loop (s+s0+s1) (n-2) + +getWord8N4 = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord8 + s1 <- getWord8 + s2 <- getWord8 + s3 <- getWord8 + loop (s+s0+s1+s2+s3) (n-4) + +getWord8N8 = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord8 + s1 <- getWord8 + s2 <- getWord8 + s3 <- getWord8 + s4 <- getWord8 + s5 <- getWord8 + s6 <- getWord8 + s7 <- getWord8 + loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8) + +getWord8N16 = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord8 + s1 <- getWord8 + s2 <- getWord8 + s3 <- getWord8 + s4 <- getWord8 + s5 <- getWord8 + s6 <- getWord8 + s7 <- getWord8 + s8 <- getWord8 + s9 <- getWord8 + s10 <- getWord8 + s11 <- getWord8 + s12 <- getWord8 + s13 <- getWord8 + s14 <- getWord8 + s15 <- getWord8 + loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16) + +------------------------------------------------------------------------ + +getWord16N1Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord16be + loop (s+s0) (n-1) + +getWord16N2Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord16be + s1 <- getWord16be + loop (s+s0+s1) (n-2) + +getWord16N4Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord16be + s1 <- getWord16be + s2 <- getWord16be + s3 <- getWord16be + loop (s+s0+s1+s2+s3) (n-4) + +getWord16N8Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord16be + s1 <- getWord16be + s2 <- getWord16be + s3 <- getWord16be + s4 <- getWord16be + s5 <- getWord16be + s6 <- getWord16be + s7 <- getWord16be + loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8) + +getWord16N16Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord16be + s1 <- getWord16be + s2 <- getWord16be + s3 <- getWord16be + s4 <- getWord16be + s5 <- getWord16be + s6 <- getWord16be + s7 <- getWord16be + s8 <- getWord16be + s9 <- getWord16be + s10 <- getWord16be + s11 <- getWord16be + s12 <- getWord16be + s13 <- getWord16be + s14 <- getWord16be + s15 <- getWord16be + loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16) + +------------------------------------------------------------------------ + +getWord16N1Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord16le + loop (s+s0) (n-1) + +getWord16N2Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord16le + s1 <- getWord16le + loop (s+s0+s1) (n-2) + +getWord16N4Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord16le + s1 <- getWord16le + s2 <- getWord16le + s3 <- getWord16le + loop (s+s0+s1+s2+s3) (n-4) + +getWord16N8Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord16le + s1 <- getWord16le + s2 <- getWord16le + s3 <- getWord16le + s4 <- getWord16le + s5 <- getWord16le + s6 <- getWord16le + s7 <- getWord16le + loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8) + +getWord16N16Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord16le + s1 <- getWord16le + s2 <- getWord16le + s3 <- getWord16le + s4 <- getWord16le + s5 <- getWord16le + s6 <- getWord16le + s7 <- getWord16le + s8 <- getWord16le + s9 <- getWord16le + s10 <- getWord16le + s11 <- getWord16le + s12 <- getWord16le + s13 <- getWord16le + s14 <- getWord16le + s15 <- getWord16le + loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16) + +------------------------------------------------------------------------ + +getWord16N1Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord16host + loop (s+s0) (n-1) + +getWord16N2Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord16host + s1 <- getWord16host + loop (s+s0+s1) (n-2) + +getWord16N4Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord16host + s1 <- getWord16host + s2 <- getWord16host + s3 <- getWord16host + loop (s+s0+s1+s2+s3) (n-4) + +getWord16N8Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord16host + s1 <- getWord16host + s2 <- getWord16host + s3 <- getWord16host + s4 <- getWord16host + s5 <- getWord16host + s6 <- getWord16host + s7 <- getWord16host + loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8) + +getWord16N16Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord16host + s1 <- getWord16host + s2 <- getWord16host + s3 <- getWord16host + s4 <- getWord16host + s5 <- getWord16host + s6 <- getWord16host + s7 <- getWord16host + s8 <- getWord16host + s9 <- getWord16host + s10 <- getWord16host + s11 <- getWord16host + s12 <- getWord16host + s13 <- getWord16host + s14 <- getWord16host + s15 <- getWord16host + loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16) + +------------------------------------------------------------------------ + +getWord32N1Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord32be + loop (s+s0) (n-1) + +getWord32N2Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord32be + s1 <- getWord32be + loop (s+s0+s1) (n-2) + +getWord32N4Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord32be + s1 <- getWord32be + s2 <- getWord32be + s3 <- getWord32be + loop (s+s0+s1+s2+s3) (n-4) + +getWord32N8Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord32be + s1 <- getWord32be + s2 <- getWord32be + s3 <- getWord32be + s4 <- getWord32be + s5 <- getWord32be + s6 <- getWord32be + s7 <- getWord32be + loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8) + +-- getWordhostN16 = loop 0 +getWord32N16Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord32be + s1 <- getWord32be + s2 <- getWord32be + s3 <- getWord32be + s4 <- getWord32be + s5 <- getWord32be + s6 <- getWord32be + s7 <- getWord32be + s8 <- getWord32be + s9 <- getWord32be + s10 <- getWord32be + s11 <- getWord32be + s12 <- getWord32be + s13 <- getWord32be + s14 <- getWord32be + s15 <- getWord32be + loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16) + +------------------------------------------------------------------------ + +getWord32N1Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord32le + loop (s+s0) (n-1) + +getWord32N2Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord32le + s1 <- getWord32le + loop (s+s0+s1) (n-2) + +getWord32N4Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord32le + s1 <- getWord32le + s2 <- getWord32le + s3 <- getWord32le + loop (s+s0+s1+s2+s3) (n-4) + +getWord32N8Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord32le + s1 <- getWord32le + s2 <- getWord32le + s3 <- getWord32le + s4 <- getWord32le + s5 <- getWord32le + s6 <- getWord32le + s7 <- getWord32le + loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8) + +-- getWordhostN16 = loop 0 +getWord32N16Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord32le + s1 <- getWord32le + s2 <- getWord32le + s3 <- getWord32le + s4 <- getWord32le + s5 <- getWord32le + s6 <- getWord32le + s7 <- getWord32le + s8 <- getWord32le + s9 <- getWord32le + s10 <- getWord32le + s11 <- getWord32le + s12 <- getWord32le + s13 <- getWord32le + s14 <- getWord32le + s15 <- getWord32le + loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16) + +------------------------------------------------------------------------ + +getWord32N1Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord32host + loop (s+s0) (n-1) + +getWord32N2Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord32host + s1 <- getWord32host + loop (s+s0+s1) (n-2) + +getWord32N4Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord32host + s1 <- getWord32host + s2 <- getWord32host + s3 <- getWord32host + loop (s+s0+s1+s2+s3) (n-4) + +getWord32N8Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord32host + s1 <- getWord32host + s2 <- getWord32host + s3 <- getWord32host + s4 <- getWord32host + s5 <- getWord32host + s6 <- getWord32host + s7 <- getWord32host + loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8) + +-- getWordhostN16 = loop 0 +getWord32N16Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord32host + s1 <- getWord32host + s2 <- getWord32host + s3 <- getWord32host + s4 <- getWord32host + s5 <- getWord32host + s6 <- getWord32host + s7 <- getWord32host + s8 <- getWord32host + s9 <- getWord32host + s10 <- getWord32host + s11 <- getWord32host + s12 <- getWord32host + s13 <- getWord32host + s14 <- getWord32host + s15 <- getWord32host + loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16) + +------------------------------------------------------------------------ + +getWord64N1Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord64be + loop (s+s0) (n-1) + +getWord64N2Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord64be + s1 <- getWord64be + loop (s+s0+s1) (n-2) + +getWord64N4Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord64be + s1 <- getWord64be + s2 <- getWord64be + s3 <- getWord64be + loop (s+s0+s1+s2+s3) (n-4) + +getWord64N8Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord64be + s1 <- getWord64be + s2 <- getWord64be + s3 <- getWord64be + s4 <- getWord64be + s5 <- getWord64be + s6 <- getWord64be + s7 <- getWord64be + loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8) + +getWord64N16Big = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord64be + s1 <- getWord64be + s2 <- getWord64be + s3 <- getWord64be + s4 <- getWord64be + s5 <- getWord64be + s6 <- getWord64be + s7 <- getWord64be + s8 <- getWord64be + s9 <- getWord64be + s10 <- getWord64be + s11 <- getWord64be + s12 <- getWord64be + s13 <- getWord64be + s14 <- getWord64be + s15 <- getWord64be + loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16) + +------------------------------------------------------------------------ + +getWord64N1Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord64le + loop (s+s0) (n-1) + +getWord64N2Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord64le + s1 <- getWord64le + loop (s+s0+s1) (n-2) + +getWord64N4Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord64le + s1 <- getWord64le + s2 <- getWord64le + s3 <- getWord64le + loop (s+s0+s1+s2+s3) (n-4) + +getWord64N8Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord64le + s1 <- getWord64le + s2 <- getWord64le + s3 <- getWord64le + s4 <- getWord64le + s5 <- getWord64le + s6 <- getWord64le + s7 <- getWord64le + loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8) + +getWord64N16Little = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord64le + s1 <- getWord64le + s2 <- getWord64le + s3 <- getWord64le + s4 <- getWord64le + s5 <- getWord64le + s6 <- getWord64le + s7 <- getWord64le + s8 <- getWord64le + s9 <- getWord64le + s10 <- getWord64le + s11 <- getWord64le + s12 <- getWord64le + s13 <- getWord64le + s14 <- getWord64le + s15 <- getWord64le + loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16) + +------------------------------------------------------------------------ + +getWord64N1Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord64host + loop (s+s0) (n-1) + +getWord64N2Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord64host + s1 <- getWord64host + loop (s+s0+s1) (n-2) + +getWord64N4Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord64host + s1 <- getWord64host + s2 <- getWord64host + s3 <- getWord64host + loop (s+s0+s1+s2+s3) (n-4) + +getWord64N8Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord64host + s1 <- getWord64host + s2 <- getWord64host + s3 <- getWord64host + s4 <- getWord64host + s5 <- getWord64host + s6 <- getWord64host + s7 <- getWord64host + loop (s+s0+s1+s2+s3+s4+s5+s6+s7) (n-8) + +getWord64N16Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop s 0 = return s + loop s n = do + s0 <- getWord64host + s1 <- getWord64host + s2 <- getWord64host + s3 <- getWord64host + s4 <- getWord64host + s5 <- getWord64host + s6 <- getWord64host + s7 <- getWord64host + s8 <- getWord64host + s9 <- getWord64host + s10 <- getWord64host + s11 <- getWord64host + s12 <- getWord64host + s13 <- getWord64host + s14 <- getWord64host + s15 <- getWord64host + loop (s+s0+s1+s2+s3+s4+s5+s6+s7+s9+s10+s11+s12+s13+s14+s15) (n-16) diff -Nru ghc-7.0.3/libraries/binary/benchmarks/Builder.hs ghc-7.2.1/libraries/binary/benchmarks/Builder.hs --- ghc-7.0.3/libraries/binary/benchmarks/Builder.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/binary/benchmarks/Builder.hs 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,196 @@ +{-# LANGUAGE CPP, ExistentialQuantification #-} + +#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) +#include "MachDeps.h" +#endif + +module Main (main) where + +import Control.DeepSeq +import Control.Exception (evaluate) +import Control.Monad.Trans (liftIO) +import Criterion.Config +import Criterion.Main hiding (run) +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as C +import qualified Data.ByteString.Lazy as L +import Data.Char (ord) +import Data.Monoid (Monoid(mappend, mempty)) +import Data.Word (Word8) + +import Data.Binary.Builder + +instance NFData S.ByteString + +data B = forall a. NFData a => B a + +instance NFData B where + rnf (B b) = rnf b + +main :: IO () +main = defaultMainWith defaultConfig + (liftIO . evaluate $ rnf [B word8s, B smallByteString, B largeByteString]) + [ -- Test GHC loop optimization of continuation based code. + bench "[Word8]" $ whnf (run . fromWord8s) word8s + + -- Test bounds check merging + , bench "bounds/[Word8]" $ whnf (run . from4Word8s) word8s + + , bench "small ByteString" $ whnf (run . fromByteString) smallByteString + , bench "large ByteString" $ whnf (run . fromByteString) largeByteString + , bench "length-prefixed ByteString" $ whnf (run . lengthPrefixedBS) + smallByteString + + , bgroup "Host endian" + [ bench "1MB of Word8 in chunks of 16" $ whnf (run . putWord8N16) n + , bench "1MB of Word16 in chunks of 16" $ whnf (run . putWord16N16Host) + (n `div` 2) + , bench "1MB of Word32 in chunks of 16" $ whnf (run . putWord32N16Host) + (n `div` 4) + , bench "1MB of Word64 in chunks of 16" $ whnf (run . putWord64N16Host) + (n `div` 8) + ] + ] + where + run = L.length . toLazyByteString + n = 1 * (2 ^ (20 :: Int)) -- one MB + +-- Input data + +word8s :: [Word8] +word8s = replicate 10000 $ fromIntegral $ ord 'a' +{-# NOINLINE word8s #-} + +smallByteString :: S.ByteString +smallByteString = C.pack "abcdefghi" + +largeByteString :: S.ByteString +largeByteString = S.pack word8s + +------------------------------------------------------------------------ +-- Benchmarks + +fromWord8s :: [Word8] -> Builder +fromWord8s [] = mempty +fromWord8s (x:xs) = singleton x <> fromWord8s xs + +from4Word8s :: [Word8] -> Builder +from4Word8s [] = mempty +from4Word8s (x:xs) = singleton x <> singleton x <> singleton x <> singleton x <> + from4Word8s xs + +-- Write 100 short, length-prefixed ByteStrings. +lengthPrefixedBS :: S.ByteString -> Builder +lengthPrefixedBS bs = loop 100 + where loop n | n `seq` False = undefined + loop 0 = mempty + loop n = +#if WORD_SIZE_IN_BITS == 32 + putWord32be (fromIntegral $ S.length bs) <> +#elif WORD_SIZE_IN_BITS == 64 + putWord64be (fromIntegral $ S.length bs) <> +#else +# error Unsupported platform +#endif + fromByteString bs <> + loop (n-1) + +putWord8N16 :: Int -> Builder +putWord8N16 = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = mempty + loop s n = + singleton (s+0) <> + singleton (s+1) <> + singleton (s+2) <> + singleton (s+3) <> + singleton (s+4) <> + singleton (s+5) <> + singleton (s+6) <> + singleton (s+7) <> + singleton (s+8) <> + singleton (s+9) <> + singleton (s+10) <> + singleton (s+11) <> + singleton (s+12) <> + singleton (s+13) <> + singleton (s+14) <> + singleton (s+15) <> + loop (s+16) (n-16) + +putWord16N16Host :: Int -> Builder +putWord16N16Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = mempty + loop s n = + putWord16host (s+0) <> + putWord16host (s+1) <> + putWord16host (s+2) <> + putWord16host (s+3) <> + putWord16host (s+4) <> + putWord16host (s+5) <> + putWord16host (s+6) <> + putWord16host (s+7) <> + putWord16host (s+8) <> + putWord16host (s+9) <> + putWord16host (s+10) <> + putWord16host (s+11) <> + putWord16host (s+12) <> + putWord16host (s+13) <> + putWord16host (s+14) <> + putWord16host (s+15) <> + loop (s+16) (n-16) + +putWord32N16Host :: Int -> Builder +putWord32N16Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = mempty + loop s n = + putWord32host (s+0) <> + putWord32host (s+1) <> + putWord32host (s+2) <> + putWord32host (s+3) <> + putWord32host (s+4) <> + putWord32host (s+5) <> + putWord32host (s+6) <> + putWord32host (s+7) <> + putWord32host (s+8) <> + putWord32host (s+9) <> + putWord32host (s+10) <> + putWord32host (s+11) <> + putWord32host (s+12) <> + putWord32host (s+13) <> + putWord32host (s+14) <> + putWord32host (s+15) <> + loop (s+16) (n-16) + +putWord64N16Host :: Int -> Builder +putWord64N16Host = loop 0 + where loop s n | s `seq` n `seq` False = undefined + loop _ 0 = mempty + loop s n = + putWord64host (s+0) <> + putWord64host (s+1) <> + putWord64host (s+2) <> + putWord64host (s+3) <> + putWord64host (s+4) <> + putWord64host (s+5) <> + putWord64host (s+6) <> + putWord64host (s+7) <> + putWord64host (s+8) <> + putWord64host (s+9) <> + putWord64host (s+10) <> + putWord64host (s+11) <> + putWord64host (s+12) <> + putWord64host (s+13) <> + putWord64host (s+14) <> + putWord64host (s+15) <> + loop (s+16) (n-16) + +------------------------------------------------------------------------ +-- Utilities + +infixr 6 <> + +(<>) :: Monoid m => m -> m -> m +(<>) = mappend diff -Nru ghc-7.0.3/libraries/binary/benchmarks/CBenchmark.c ghc-7.2.1/libraries/binary/benchmarks/CBenchmark.c --- ghc-7.0.3/libraries/binary/benchmarks/CBenchmark.c 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/binary/benchmarks/CBenchmark.c 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,39 @@ +#include "CBenchmark.h" + +void bytewrite(unsigned char *a, int bytes) { + unsigned char n = 0; + int i = 0; + int iterations = bytes; + while (i < iterations) { + a[i++] = n++; + } +} + +unsigned char byteread(unsigned char *a, int bytes) { + unsigned char n = 0; + int i = 0; + int iterations = bytes; + while (i < iterations) { + n += a[i++]; + } + return n; +} + +void wordwrite(unsigned long *a, int bytes) { + unsigned long n = 0; + int i = 0; + int iterations = bytes / sizeof(unsigned long) ; + while (i < iterations) { + a[i++] = n++; + } +} + +unsigned int wordread(unsigned long *a, int bytes) { + unsigned long n = 0; + int i = 0; + int iterations = bytes / sizeof(unsigned long); + while (i < iterations) { + n += a[i++]; + } + return n; +} diff -Nru ghc-7.0.3/libraries/binary/benchmarks/CBenchmark.h ghc-7.2.1/libraries/binary/benchmarks/CBenchmark.h --- ghc-7.0.3/libraries/binary/benchmarks/CBenchmark.h 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/binary/benchmarks/CBenchmark.h 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,4 @@ +void bytewrite(unsigned char *a, int bytes); +unsigned char byteread(unsigned char *a, int bytes); +void wordwrite(unsigned long *a, int bytes); +unsigned int wordread(unsigned long *a, int bytes); diff -Nru ghc-7.0.3/libraries/binary/benchmarks/Makefile ghc-7.2.1/libraries/binary/benchmarks/Makefile --- ghc-7.0.3/libraries/binary/benchmarks/Makefile 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/binary/benchmarks/Makefile 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,23 @@ +ghc := ghc +ghc-flags := +programs := builder bench + +.PHONY: all +all: $(programs) + +builder: Builder.hs + $(ghc) $(ghc-flags) --make -O2 Builder.hs -o $@ -fforce-recomp -i../src + +bench: Benchmark.hs MemBench.hs CBenchmark.o + $(ghc) $(ghc-flags) --make -O2 -fliberate-case-threshold=1000 -fasm Benchmark.hs CBenchmark.o -o $@ -fforce-recomp -i../src + +.PHONY: run-bench +run-bench: bench + ./bench 100 + +CBenchmark.o: CBenchmark.c + $(ghc) -c -optc -O3 $< -o $@ + +.PHONY: clean +clean: + rm -f *.o *.hi $(programs) diff -Nru ghc-7.0.3/libraries/binary/benchmarks/MemBench.hs ghc-7.2.1/libraries/binary/benchmarks/MemBench.hs --- ghc-7.0.3/libraries/binary/benchmarks/MemBench.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/binary/benchmarks/MemBench.hs 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,85 @@ +{-# LANGUAGE ForeignFunctionInterface, BangPatterns #-} +module MemBench (memBench) where + +import Foreign +import Foreign.C + +import Control.Exception +import System.CPUTime +import Numeric + +memBench :: Int -> IO () +memBench mb = do + let bytes = mb * 2^20 + allocaBytes bytes $ \ptr -> do + let bench label test = do + seconds <- time $ test (castPtr ptr) (fromIntegral bytes) + let throughput = fromIntegral mb / seconds + putStrLn $ show mb ++ "MB of " ++ label + ++ " in " ++ showFFloat (Just 3) seconds "s, at: " + ++ showFFloat (Just 1) throughput "MB/s" + bench "setup " c_wordwrite + putStrLn "" + putStrLn "C memory throughput benchmarks:" + bench "bytes written" c_bytewrite + bench "bytes read " c_byteread + bench "words written" c_wordwrite + bench "words read " c_wordread + putStrLn "" + putStrLn "Haskell memory throughput benchmarks:" + bench "bytes written" hs_bytewrite + bench "bytes read " hs_byteread + bench "words written" hs_wordwrite + bench "words read " hs_wordread + +hs_bytewrite :: Ptr CUChar -> Int -> IO () +hs_bytewrite !ptr bytes = loop 0 0 + where iterations = bytes + loop :: Int -> CUChar -> IO () + loop !i !n | i == iterations = return () + | otherwise = do pokeByteOff ptr i n + loop (i+1) (n+1) + +hs_byteread :: Ptr CUChar -> Int -> IO CUChar +hs_byteread !ptr bytes = loop 0 0 + where iterations = bytes + loop :: Int -> CUChar -> IO CUChar + loop !i !n | i == iterations = return n + | otherwise = do x <- peekByteOff ptr i + loop (i+1) (n+x) + +hs_wordwrite :: Ptr CULong -> Int -> IO () +hs_wordwrite !ptr bytes = loop 0 0 + where iterations = bytes `div` sizeOf (undefined :: CULong) + loop :: Int -> CULong -> IO () + loop !i !n | i == iterations = return () + | otherwise = do pokeByteOff ptr i n + loop (i+1) (n+1) + +hs_wordread :: Ptr CULong -> Int -> IO CULong +hs_wordread !ptr bytes = loop 0 0 + where iterations = bytes `div` sizeOf (undefined :: CULong) + loop :: Int -> CULong -> IO CULong + loop !i !n | i == iterations = return n + | otherwise = do x <- peekByteOff ptr i + loop (i+1) (n+x) + + +foreign import ccall unsafe "CBenchmark.h byteread" + c_byteread :: Ptr CUChar -> CInt -> IO () + +foreign import ccall unsafe "CBenchmark.h bytewrite" + c_bytewrite :: Ptr CUChar -> CInt -> IO () + +foreign import ccall unsafe "CBenchmark.h wordread" + c_wordread :: Ptr CUInt -> CInt -> IO () + +foreign import ccall unsafe "CBenchmark.h wordwrite" + c_wordwrite :: Ptr CUInt -> CInt -> IO () + +time :: IO a -> IO Double +time action = do + start <- getCPUTime + action + end <- getCPUTime + return $! (fromIntegral (end - start)) / (10^12) diff -Nru ghc-7.0.3/libraries/binary/binary.cabal ghc-7.2.1/libraries/binary/binary.cabal --- ghc-7.0.3/libraries/binary/binary.cabal 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/binary/binary.cabal 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,61 @@ +name: binary +version: 0.5.0.2 +license: BSD3 +license-file: LICENSE +author: Lennart Kolmodin +maintainer: Lennart Kolmodin, Don Stewart +homepage: http://code.haskell.org/binary/ +description: Efficient, pure binary serialisation using lazy ByteStrings. + Haskell values may be encoded to and from binary formats, + written to disk as binary, or sent over the network. + Serialisation speeds of over 1 G\/sec have been observed, + so this library should be suitable for high performance + scenarios. +synopsis: Binary serialisation for Haskell values using lazy ByteStrings +category: Data, Parsing +stability: provisional +build-type: Simple +cabal-version: >= 1.2 +tested-with: GHC ==6.4.2, GHC ==6.6.1, GHC ==6.8.0, GHC ==6.10.1 +extra-source-files: README index.html + +flag bytestring-in-base +flag split-base +flag applicative-in-base + +library + if flag(bytestring-in-base) + -- bytestring was in base-2.0 and 2.1.1 + build-depends: base >= 2.0 && < 2.2 + cpp-options: -DBYTESTRING_IN_BASE + else + -- in base 1.0 and 3.0 bytestring is a separate package + build-depends: base < 2.0 || >= 3, bytestring >= 0.9 + + if flag(split-base) + build-depends: base >= 3.0, containers, array + else + build-depends: base < 3.0 + + if flag(applicative-in-base) + build-depends: base >= 2.0 + cpp-options: -DAPPLICATIVE_IN_BASE + else + build-depends: base < 2.0 + hs-source-dirs: src + + exposed-modules: Data.Binary, + Data.Binary.Put, + Data.Binary.Get, + Data.Binary.Builder + Data.Binary.Builder.Internal + + other-modules: Data.Binary.Builder.Base + + extensions: CPP, + FlexibleContexts + + ghc-options: -O2 -Wall -fliberate-case-threshold=1000 + +-- if impl(ghc < 6.5) +-- ghc-options: -fallow-undecidable-instances diff -Nru ghc-7.0.3/libraries/binary/docs/hcar/binary-Lb.tex ghc-7.2.1/libraries/binary/docs/hcar/binary-Lb.tex --- ghc-7.0.3/libraries/binary/docs/hcar/binary-Lb.tex 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/binary/docs/hcar/binary-Lb.tex 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,48 @@ +\begin{hcarentry}{binary} +\label{binary} +\report{Lennart Kolmodin} +\status{active} +\participants{Duncan Coutts, Don Stewart, Binary Strike Team} +\makeheader + +The Binary Strike Team is pleased to announce yet a release of a new, +pure, efficient binary serialisation library. + +The `binary' package provides efficient serialisation of Haskell values +to and from lazy ByteStrings. ByteStrings constructed this way may then +be written to disk, written to the network, or further processed (e.g. +stored in memory directly, or compressed in memory with zlib or bzlib). + +The binary library has been heavily tuned for performance, particularly for +writing speed. Throughput of up to 160M/s has been achieved in practice, and +in general speed is on par or better than NewBinary, with the advantage of a +pure interface. Efforts are underway to improve performance still further. +Plans are also taking shape for a parser combinator library on top of +binary, for bit parsing and foreign structure parsing (e.g. network +protocols). + +Data.Derive~\cref{derive} has support for automatically generating Binary +instances, allowing to read and write your data structures with little fuzz. + +Binary was developed by a team of 8 during the Haskell Hackathon in Oxford +2007, and since then has about 15 people contributed code and many more +given feedback and cheerleading on \verb|#haskell|. + +The package is cabalized and available through Hackage~\cref{hackagedb}. +% to editors: ref. to cabal? + +\FurtherReading +\begin{compactitem} +\item Homepage + + \url{http://code.haskell.org/binary/} +\item Hackage + + \url{http://hackage.haskell.org/cgi-bin/hackage-scripts/package/binary} +\item Development version + + \texttt{darcs get --partial} + + \url{http://code.haskell.org/binary} +\end{compactitem} +\end{hcarentry} diff -Nru ghc-7.0.3/libraries/binary/ghc.mk ghc-7.2.1/libraries/binary/ghc.mk --- ghc-7.0.3/libraries/binary/ghc.mk 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/binary/ghc.mk 2011-08-07 17:11:00.000000000 +0000 @@ -0,0 +1,4 @@ +libraries/binary_PACKAGE = binary +libraries/binary_dist-install_GROUP = libraries +$(if $(filter binary,$(PACKAGES_STAGE0)),$(eval $(call build-package,libraries/binary,dist-boot,0))) +$(eval $(call build-package,libraries/binary,dist-install,$(if $(filter binary,$(STAGE2_PACKAGES)),2,1))) diff -Nru ghc-7.0.3/libraries/binary/.gitignore ghc-7.2.1/libraries/binary/.gitignore --- ghc-7.0.3/libraries/binary/.gitignore 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/binary/.gitignore 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,10 @@ +*.hi +*.o +*.p_hi +*.prof +*.tix +.hpc/ +/benchmarks/bench +/benchmarks/builder +/dist/* +/tests/qc diff -Nru ghc-7.0.3/libraries/binary/GNUmakefile ghc-7.2.1/libraries/binary/GNUmakefile --- ghc-7.0.3/libraries/binary/GNUmakefile 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/binary/GNUmakefile 2011-08-07 17:11:00.000000000 +0000 @@ -0,0 +1,4 @@ +dir = libraries/binary +TOP = ../.. +include $(TOP)/mk/sub-makefile.mk +FAST_MAKE_OPTS += stage=0 diff -Nru ghc-7.0.3/libraries/binary/index.html ghc-7.2.1/libraries/binary/index.html --- ghc-7.0.3/libraries/binary/index.html 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/binary/index.html 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,161 @@ + + + + + + Data.Binary - efficient, pure binary serialisation for Haskell + + + + + +
    + +

    Data.Binary

    + +
    + +

    About

    +

    + Data.Binary is a library for high performance binary serialisation + of Haskell data. It uses the + ByteString library to achieve efficient, lazy reading and + writing of structures in binary format. +

    + +

    + Chris Eidhof writes on his use of Data.Binary implementing a + full-text search engine: +

    + 
    +   "The communication with Sphinx is done using a quite low-level binary
+    protocol, but Data.Binary saved the day: it made it very easy for us
+    to parse all the binary things. Especially the use of the Get and
+    Put monads are a big improvement over the manual reading and keeping
+    track of positions, as is done in the PHP/Python clients."
+
    + +

    Example

    + For example, to serialise an interpreter's abstract syntax tree to + binary format: +
    import Data.Binary
+import Control.Monad
+import Codec.Compression.GZip
+
+-- A Haskell AST structure
+data Exp = IntE Int
+         | OpE  String Exp Exp
+   deriving Eq
+
+-- An instance of Binary to encode and decode an Exp in binary
+instance Binary Exp where
+     put (IntE i)          = put (0 :: Word8) >> put i
+     put (OpE s e1 e2)     = put (1 :: Word8) >> put s >> put e1 >> put e2
+     get = do tag <- getWord8
+              case tag of
+                  0 -> liftM  IntE get
+                  1 -> liftM3 OpE  get get get
+
+-- A test expression
+e = OpE "*" (IntE 7) (OpE "/" (IntE 4) (IntE 2))
+
+-- Serialise and compress with gzip, then decompress and deserialise
+main = do
+    let t  = compress (encode e)
+    print t
+    let e' = decode (decompress t)
+    print (e == e')
+
    + +

    Download

    + + + +

    stable release

    + + + + + + + + + + + +
    + binary 0.4.2 + (Apr 2008)
    + binary 0.4.1 + (Oct 2007)
    + binary 0.4 + (Oct 2007)
    + binary 0.3 + (Mar 2007)
    + binary 0.2 + (Jan 2007)
    +

    development branch

    + + +
    + darcs get http://code.haskell.org/binary +
    +
    + +

    Download

    + + +

    Project Activity

    + +
    + binary commit statistics +
    + +

    Starring...

    + + The Binary Strike Force +
      +
    • Lennart Kolmodin
      • +
    • Duncan Coutts
      • +
    • Don Stewart
      • +
    • Spencer Janssen
      • +
    • David Himmelstrup
      • +
    • Björn Bringert
      • +
    • Ross Paterson
      • +
    • Einar Karttunen
      • +
    • John Meacham
      • +
    • Ulf Norell
      • +
    • Bryan O'Sullivan
      • +
    • Tomasz Zielonka
      • +
    • Florian Weimer
      • +
    • Judah Jacobson
      • +
    + +
    + +covered by HPC +built with Cabal +tested with QuickCheck + +
    + + + + + + diff -Nru ghc-7.0.3/libraries/binary/LICENSE ghc-7.2.1/libraries/binary/LICENSE --- ghc-7.0.3/libraries/binary/LICENSE 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/binary/LICENSE 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,30 @@ +Copyright (c) Lennart Kolmodin + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE CONTRIBUTORS ``AS IS'' AND ANY EXPRESS +OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED +WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE +DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE FOR +ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, +STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN +ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE +POSSIBILITY OF SUCH DAMAGE. diff -Nru ghc-7.0.3/libraries/binary/README ghc-7.2.1/libraries/binary/README --- ghc-7.0.3/libraries/binary/README 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/binary/README 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,74 @@ + + binary: efficient, pure binary serialisation using lazy ByteStrings +------------------------------------------------------------------------ + +The 'binary' package provides Data.Binary, containing the Binary class, +and associated methods, for serialising values to and from lazy +ByteStrings. + +A key feature of 'binary' is that the interface is both pure, and efficient. + +The 'binary' package is portable to GHC and Hugs. + +Building: + + runhaskell Setup.lhs configure + runhaskell Setup.lhs build + runhaskell Setup.lhs install + +First: + import Data.Binary + +and then write an instance of Binary for the type you wish to serialise. +More information in the haddock documentation. + +Deriving: + +It is possible to mechanically derive new instances of Binary for your +types, if they support the Data and Typeable classes. A script is +provided in tools/derive. Here's an example of its use. + + $ cd binary + $ cd tools/derive + + $ ghci -fglasgow-exts BinaryDerive.hs + + *BinaryDerive> :l Example.hs + + *Main> deriveM (undefined :: Drinks) + + instance Binary Main.Drinks where + put (Beer a) = putWord8 0 >> put a + put Coffee = putWord8 1 + put Tea = putWord8 2 + put EnergyDrink = putWord8 3 + put Water = putWord8 4 + put Wine = putWord8 5 + put Whisky = putWord8 6 + get = do + tag_ <- getWord8 + case tag_ of + 0 -> get >>= \a -> return (Beer a) + 1 -> return Coffee + 2 -> return Tea + 3 -> return EnergyDrink + 4 -> return Water + 5 -> return Wine + 6 -> return Whisky + +Contributors: + + Lennart Kolmodin + Duncan Coutts + Don Stewart + Spencer Janssen + David Himmelstrup + Björn Bringert + Ross Paterson + Einar Karttunen + John Meacham + Ulf Norell + Tomasz Zielonka + Stefan Karrmann + Bryan O'Sullivan + Florian Weimer diff -Nru ghc-7.0.3/libraries/binary/Setup.lhs ghc-7.2.1/libraries/binary/Setup.lhs --- ghc-7.0.3/libraries/binary/Setup.lhs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/binary/Setup.lhs 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff -Nru ghc-7.0.3/libraries/binary/src/Data/Binary/Builder/Base.hs ghc-7.2.1/libraries/binary/src/Data/Binary/Builder/Base.hs --- ghc-7.0.3/libraries/binary/src/Data/Binary/Builder/Base.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/binary/src/Data/Binary/Builder/Base.hs 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,509 @@ +{-# LANGUAGE BangPatterns, CPP, MagicHash #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Binary.Builder.Base +-- Copyright : Lennart Kolmodin, Ross Paterson +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Lennart Kolmodin +-- Stability : experimental +-- Portability : portable to Hugs and GHC +-- +-- A module exporting types and functions that are shared by +-- 'Data.Binary.Builder' and 'Data.Binary.Builder.Internal'. +-- +----------------------------------------------------------------------------- + +#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) +#include "MachDeps.h" +#endif + +module Data.Binary.Builder.Base ( + -- * The Builder type + Builder + , toLazyByteString + + -- * Constructing Builders + , empty + , singleton + , append + , fromByteString -- :: S.ByteString -> Builder + , fromLazyByteString -- :: L.ByteString -> Builder + + -- * Flushing the buffer state + , flush + + -- * Derived Builders + -- ** Big-endian writes + , putWord16be -- :: Word16 -> Builder + , putWord32be -- :: Word32 -> Builder + , putWord64be -- :: Word64 -> Builder + + -- ** Little-endian writes + , putWord16le -- :: Word16 -> Builder + , putWord32le -- :: Word32 -> Builder + , putWord64le -- :: Word64 -> Builder + + -- ** Host-endian, unaligned writes + , putWordhost -- :: Word -> Builder + , putWord16host -- :: Word16 -> Builder + , putWord32host -- :: Word32 -> Builder + , putWord64host -- :: Word64 -> Builder + + -- ** Unicode + , putCharUtf8 + + -- * Low-level construction of Builders + , writeN + , writeAtMost + ) where + +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import Data.Monoid +import Data.Word +import Foreign + +#ifdef BYTESTRING_IN_BASE +import Data.ByteString.Base (inlinePerformIO) +import qualified Data.ByteString.Base as S +import qualified Data.ByteString.Lazy.Base as L +#else +import Data.ByteString.Internal (inlinePerformIO) +import qualified Data.ByteString.Internal as S +import qualified Data.ByteString.Lazy.Internal as L +#endif + +#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) +import GHC.Base +import GHC.Word (Word32(..),Word16(..),Word64(..)) +# if WORD_SIZE_IN_BITS < 64 +import GHC.Word (uncheckedShiftRL64#) +# endif +#endif + +------------------------------------------------------------------------ + +-- | A 'Builder' is an efficient way to build lazy 'L.ByteString's. +-- There are several functions for constructing 'Builder's, but only one +-- to inspect them: to extract any data, you have to turn them into lazy +-- 'L.ByteString's using 'toLazyByteString'. +-- +-- Internally, a 'Builder' constructs a lazy 'L.Bytestring' by filling byte +-- arrays piece by piece. As each buffer is filled, it is \'popped\' +-- off, to become a new chunk of the resulting lazy 'L.ByteString'. +-- All this is hidden from the user of the 'Builder'. + +newtype Builder = Builder { + runBuilder :: (Buffer -> IO L.ByteString) + -> Buffer + -> IO L.ByteString + } + +instance Monoid Builder where + mempty = empty + {-# INLINE mempty #-} + mappend = append + {-# INLINE mappend #-} + mconcat = foldr mappend mempty + {-# INLINE mconcat #-} + +------------------------------------------------------------------------ + +-- | /O(1)./ The empty Builder, satisfying +-- +-- * @'toLazyByteString' 'empty' = 'L.empty'@ +-- +empty :: Builder +empty = Builder (\ k b -> k b) +{-# INLINE empty #-} + +-- | /O(1)./ A Builder taking a single byte, satisfying +-- +-- * @'toLazyByteString' ('singleton' b) = 'L.singleton' b@ +-- +singleton :: Word8 -> Builder +singleton = writeN 1 . flip poke +{-# INLINE singleton #-} + +------------------------------------------------------------------------ + +-- | /O(1)./ The concatenation of two Builders, an associative operation +-- with identity 'empty', satisfying +-- +-- * @'toLazyByteString' ('append' x y) = 'L.append' ('toLazyByteString' x) ('toLazyByteString' y)@ +-- +append :: Builder -> Builder -> Builder +append (Builder f) (Builder g) = Builder (f . g) +{-# INLINE [0] append #-} + +-- | /O(1)./ A Builder taking a 'S.ByteString', satisfying +-- +-- * @'toLazyByteString' ('fromByteString' bs) = 'L.fromChunks' [bs]@ +-- +fromByteString :: S.ByteString -> Builder +fromByteString bs + | S.null bs = empty + | otherwise = flush `append` mapBuilder (L.Chunk bs) +{-# INLINE fromByteString #-} + +-- | /O(1)./ A Builder taking a lazy 'L.ByteString', satisfying +-- +-- * @'toLazyByteString' ('fromLazyByteString' bs) = bs@ +-- +fromLazyByteString :: L.ByteString -> Builder +fromLazyByteString bss = flush `append` mapBuilder (bss `L.append`) +{-# INLINE fromLazyByteString #-} + +------------------------------------------------------------------------ + +-- Our internal buffer type +data Buffer = Buffer {-# UNPACK #-} !(ForeignPtr Word8) + {-# UNPACK #-} !Int -- offset + {-# UNPACK #-} !Int -- used bytes + {-# UNPACK #-} !Int -- length left + +------------------------------------------------------------------------ + +-- | /O(n)./ Extract a lazy 'L.ByteString' from a 'Builder'. +-- The construction work takes place if and when the relevant part of +-- the lazy 'L.ByteString' is demanded. +-- +toLazyByteString :: Builder -> L.ByteString +toLazyByteString m = unsafePerformIO $ do + buf <- newBuffer defaultSize + runBuilder (m `append` flush) (const (return L.Empty)) buf +{-# INLINE toLazyByteString #-} + +-- | /O(1)./ Pop the 'S.ByteString' we have constructed so far, if any, +-- yielding a new chunk in the result lazy 'L.ByteString'. +flush :: Builder +flush = Builder $ \ k buf@(Buffer p o u l) -> + if u == 0 -- Invariant (from Data.ByteString.Lazy) + then k buf + else let !b = Buffer p (o+u) 0 l + !bs = S.PS p o u + in return $! L.Chunk bs (inlinePerformIO (k b)) + +------------------------------------------------------------------------ + +-- +-- copied from Data.ByteString.Lazy +-- +defaultSize :: Int +defaultSize = 32 * k - overhead + where k = 1024 + overhead = 2 * sizeOf (undefined :: Int) + +------------------------------------------------------------------------ + +-- | Sequence an IO operation on the buffer +withBuffer :: (Buffer -> IO Buffer) -> Builder +withBuffer f = Builder $ \ k buf -> f buf >>= k +{-# INLINE withBuffer #-} + +-- | Get the size of the buffer +withSize :: (Int -> Builder) -> Builder +withSize f = Builder $ \ k buf@(Buffer _ _ _ l) -> + runBuilder (f l) k buf + +-- | Map the resulting list of bytestrings. +mapBuilder :: (L.ByteString -> L.ByteString) -> Builder +mapBuilder f = Builder (fmap f .) + +------------------------------------------------------------------------ + +-- | Ensure that there are at least @n@ many bytes available. +ensureFree :: Int -> Builder +ensureFree n = n `seq` withSize $ \ l -> + if n <= l then empty else + flush `append` withBuffer (const (newBuffer (max n defaultSize))) +{-# INLINE [0] ensureFree #-} + +-- | Ensure that @n@ bytes are available, and then use @f@ to write at +-- most @n@ bytes into memory. @f@ must return the actual number of +-- bytes written. +writeAtMost :: Int -> (Ptr Word8 -> IO Int) -> Builder +writeAtMost n f = ensureFree n `append` withBuffer (writeBuffer f) +{-# INLINE [0] writeAtMost #-} + +-- | Ensure that @n@ bytes are available, and then use @f@ to write +-- exactly @n@ bytes into memory. +writeN :: Int -> (Ptr Word8 -> IO ()) -> Builder +writeN n f = writeAtMost n (\ p -> f p >> return n) +{-# INLINE writeN #-} + +writeBuffer :: (Ptr Word8 -> IO Int) -> Buffer -> IO Buffer +writeBuffer f (Buffer fp o u l) = do + n <- withForeignPtr fp (\p -> f (p `plusPtr` (o+u))) + return $! Buffer fp o (u+n) (l-n) +{-# INLINE writeBuffer #-} + +newBuffer :: Int -> IO Buffer +newBuffer size = do + fp <- S.mallocByteString size + return $! Buffer fp 0 0 size +{-# INLINE newBuffer #-} + +------------------------------------------------------------------------ + +-- +-- We rely on the fromIntegral to do the right masking for us. +-- The inlining here is critical, and can be worth 4x performance +-- + +-- | Write a Word16 in big endian format +putWord16be :: Word16 -> Builder +putWord16be w = writeN 2 $ \p -> do + poke p (fromIntegral (shiftr_w16 w 8) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (w) :: Word8) +{-# INLINE putWord16be #-} + +-- | Write a Word16 in little endian format +putWord16le :: Word16 -> Builder +putWord16le w = writeN 2 $ \p -> do + poke p (fromIntegral (w) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (shiftr_w16 w 8) :: Word8) +{-# INLINE putWord16le #-} + +-- putWord16le w16 = writeN 2 (\p -> poke (castPtr p) w16) + +-- | Write a Word32 in big endian format +putWord32be :: Word32 -> Builder +putWord32be w = writeN 4 $ \p -> do + poke p (fromIntegral (shiftr_w32 w 24) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 w 16) :: Word8) + poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 w 8) :: Word8) + poke (p `plusPtr` 3) (fromIntegral (w) :: Word8) +{-# INLINE putWord32be #-} + +-- +-- a data type to tag Put/Check. writes construct these which are then +-- inlined and flattened. matching Checks will be more robust with rules. +-- + +-- | Write a Word32 in little endian format +putWord32le :: Word32 -> Builder +putWord32le w = writeN 4 $ \p -> do + poke p (fromIntegral (w) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 w 8) :: Word8) + poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 w 16) :: Word8) + poke (p `plusPtr` 3) (fromIntegral (shiftr_w32 w 24) :: Word8) +{-# INLINE putWord32le #-} + +-- on a little endian machine: +-- putWord32le w32 = writeN 4 (\p -> poke (castPtr p) w32) + +-- | Write a Word64 in big endian format +putWord64be :: Word64 -> Builder +#if WORD_SIZE_IN_BITS < 64 +-- +-- To avoid expensive 64 bit shifts on 32 bit machines, we cast to +-- Word32, and write that +-- +putWord64be w = + let a = fromIntegral (shiftr_w64 w 32) :: Word32 + b = fromIntegral w :: Word32 + in writeN 8 $ \p -> do + poke p (fromIntegral (shiftr_w32 a 24) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 a 16) :: Word8) + poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 a 8) :: Word8) + poke (p `plusPtr` 3) (fromIntegral (a) :: Word8) + poke (p `plusPtr` 4) (fromIntegral (shiftr_w32 b 24) :: Word8) + poke (p `plusPtr` 5) (fromIntegral (shiftr_w32 b 16) :: Word8) + poke (p `plusPtr` 6) (fromIntegral (shiftr_w32 b 8) :: Word8) + poke (p `plusPtr` 7) (fromIntegral (b) :: Word8) +#else +putWord64be w = writeN 8 $ \p -> do + poke p (fromIntegral (shiftr_w64 w 56) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (shiftr_w64 w 48) :: Word8) + poke (p `plusPtr` 2) (fromIntegral (shiftr_w64 w 40) :: Word8) + poke (p `plusPtr` 3) (fromIntegral (shiftr_w64 w 32) :: Word8) + poke (p `plusPtr` 4) (fromIntegral (shiftr_w64 w 24) :: Word8) + poke (p `plusPtr` 5) (fromIntegral (shiftr_w64 w 16) :: Word8) + poke (p `plusPtr` 6) (fromIntegral (shiftr_w64 w 8) :: Word8) + poke (p `plusPtr` 7) (fromIntegral (w) :: Word8) +#endif +{-# INLINE putWord64be #-} + +-- | Write a Word64 in little endian format +putWord64le :: Word64 -> Builder + +#if WORD_SIZE_IN_BITS < 64 +putWord64le w = + let b = fromIntegral (shiftr_w64 w 32) :: Word32 + a = fromIntegral w :: Word32 + in writeN 8 $ \p -> do + poke (p) (fromIntegral (a) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (shiftr_w32 a 8) :: Word8) + poke (p `plusPtr` 2) (fromIntegral (shiftr_w32 a 16) :: Word8) + poke (p `plusPtr` 3) (fromIntegral (shiftr_w32 a 24) :: Word8) + poke (p `plusPtr` 4) (fromIntegral (b) :: Word8) + poke (p `plusPtr` 5) (fromIntegral (shiftr_w32 b 8) :: Word8) + poke (p `plusPtr` 6) (fromIntegral (shiftr_w32 b 16) :: Word8) + poke (p `plusPtr` 7) (fromIntegral (shiftr_w32 b 24) :: Word8) +#else +putWord64le w = writeN 8 $ \p -> do + poke p (fromIntegral (w) :: Word8) + poke (p `plusPtr` 1) (fromIntegral (shiftr_w64 w 8) :: Word8) + poke (p `plusPtr` 2) (fromIntegral (shiftr_w64 w 16) :: Word8) + poke (p `plusPtr` 3) (fromIntegral (shiftr_w64 w 24) :: Word8) + poke (p `plusPtr` 4) (fromIntegral (shiftr_w64 w 32) :: Word8) + poke (p `plusPtr` 5) (fromIntegral (shiftr_w64 w 40) :: Word8) + poke (p `plusPtr` 6) (fromIntegral (shiftr_w64 w 48) :: Word8) + poke (p `plusPtr` 7) (fromIntegral (shiftr_w64 w 56) :: Word8) +#endif +{-# INLINE putWord64le #-} + +-- on a little endian machine: +-- putWord64le w64 = writeN 8 (\p -> poke (castPtr p) w64) + +------------------------------------------------------------------------ +-- Unaligned, word size ops + +-- | /O(1)./ A Builder taking a single native machine word. The word is +-- written in host order, host endian form, for the machine you're on. +-- On a 64 bit machine the Word is an 8 byte value, on a 32 bit machine, +-- 4 bytes. Values written this way are not portable to +-- different endian or word sized machines, without conversion. +-- +putWordhost :: Word -> Builder +putWordhost w = + writeN (sizeOf (undefined :: Word)) (\p -> poke (castPtr p) w) +{-# INLINE putWordhost #-} + +-- | Write a Word16 in native host order and host endianness. +-- 2 bytes will be written, unaligned. +putWord16host :: Word16 -> Builder +putWord16host w16 = + writeN (sizeOf (undefined :: Word16)) (\p -> poke (castPtr p) w16) +{-# INLINE putWord16host #-} + +-- | Write a Word32 in native host order and host endianness. +-- 4 bytes will be written, unaligned. +putWord32host :: Word32 -> Builder +putWord32host w32 = + writeN (sizeOf (undefined :: Word32)) (\p -> poke (castPtr p) w32) +{-# INLINE putWord32host #-} + +-- | Write a Word64 in native host order. +-- On a 32 bit machine we write two host order Word32s, in big endian form. +-- 8 bytes will be written, unaligned. +putWord64host :: Word64 -> Builder +putWord64host w = + writeN (sizeOf (undefined :: Word64)) (\p -> poke (castPtr p) w) +{-# INLINE putWord64host #-} + +------------------------------------------------------------------------ +-- Unicode + +-- Code lifted from the text package by Bryan O'Sullivan. + +-- | Write a character using UTF-8 encoding. +putCharUtf8 :: Char -> Builder +putCharUtf8 x = writeAtMost 4 $ \ p -> case undefined of + _ | n <= 0x7F -> poke p c >> return 1 + | n <= 0x07FF -> do + poke p a2 + poke (p `plusPtr` 1) b2 + return 2 + | n <= 0xFFFF -> do + poke p a3 + poke (p `plusPtr` 1) b3 + poke (p `plusPtr` 2) c3 + return 3 + | otherwise -> do + poke p a4 + poke (p `plusPtr` 1) b4 + poke (p `plusPtr` 2) c4 + poke (p `plusPtr` 3) d4 + return 4 + where + n = ord x + c = fromIntegral n + (a2,b2) = ord2 x + (a3,b3,c3) = ord3 x + (a4,b4,c4,d4) = ord4 x + +ord2 :: Char -> (Word8,Word8) +ord2 c = (x1,x2) + where + n = ord c + x1 = fromIntegral $ (n `shiftR` 6) + 0xC0 + x2 = fromIntegral $ (n .&. 0x3F) + 0x80 + +ord3 :: Char -> (Word8,Word8,Word8) +ord3 c = (x1,x2,x3) + where + n = ord c + x1 = fromIntegral $ (n `shiftR` 12) + 0xE0 + x2 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80 + x3 = fromIntegral $ (n .&. 0x3F) + 0x80 + +ord4 :: Char -> (Word8,Word8,Word8,Word8) +ord4 c = (x1,x2,x3,x4) + where + n = ord c + x1 = fromIntegral $ (n `shiftR` 18) + 0xF0 + x2 = fromIntegral $ ((n `shiftR` 12) .&. 0x3F) + 0x80 + x3 = fromIntegral $ ((n `shiftR` 6) .&. 0x3F) + 0x80 + x4 = fromIntegral $ (n .&. 0x3F) + 0x80 + +------------------------------------------------------------------------ +-- Unchecked shifts + +{-# INLINE shiftr_w16 #-} +shiftr_w16 :: Word16 -> Int -> Word16 +{-# INLINE shiftr_w32 #-} +shiftr_w32 :: Word32 -> Int -> Word32 +{-# INLINE shiftr_w64 #-} +shiftr_w64 :: Word64 -> Int -> Word64 + +#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) +shiftr_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftRL#` i) +shiftr_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftRL#` i) + +# if WORD_SIZE_IN_BITS < 64 +shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL64#` i) +# else +shiftr_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftRL#` i) +# endif + +#else +shiftr_w16 = shiftR +shiftr_w32 = shiftR +shiftr_w64 = shiftR +#endif + +------------------------------------------------------------------------ +-- Some nice rules for Builder + +#if __GLASGOW_HASKELL__ >= 700 +-- In versions of GHC prior to 7.0 these rules would make GHC believe +-- that 'writeN' and 'ensureFree' are recursive and the rules wouldn't +-- fire. +{-# RULES + +"append/writeAtMost" forall a b (f::Ptr Word8 -> IO Int) + (g::Ptr Word8 -> IO Int) ws. + append (writeAtMost a f) (append (writeAtMost b g) ws) = + append (writeAtMost (a+b) (\p -> f p >>= \n -> + g (p `plusPtr` n) >>= \m -> + let s = n+m in s `seq` return s)) ws + +"writeAtMost/writeAtMost" forall a b (f::Ptr Word8 -> IO Int) + (g::Ptr Word8 -> IO Int). + append (writeAtMost a f) (writeAtMost b g) = + writeAtMost (a+b) (\p -> f p >>= \n -> + g (p `plusPtr` n) >>= \m -> + let s = n+m in s `seq` return s) + +"ensureFree/ensureFree" forall a b . + append (ensureFree a) (ensureFree b) = ensureFree (max a b) + +"flush/flush" + append flush flush = flush + + #-} +#endif diff -Nru ghc-7.0.3/libraries/binary/src/Data/Binary/Builder/Internal.hs ghc-7.2.1/libraries/binary/src/Data/Binary/Builder/Internal.hs --- ghc-7.0.3/libraries/binary/src/Data/Binary/Builder/Internal.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/binary/src/Data/Binary/Builder/Internal.hs 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,24 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Binary.Builder.Internal +-- Copyright : Lennart Kolmodin, Ross Paterson +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Lennart Kolmodin +-- Stability : experimental +-- Portability : portable to Hugs and GHC +-- +-- A module containing semi-public 'Builder' internals that exposes +-- low level construction functions. Modules which extend the +-- 'Builder' system will need to use this module while ideally most +-- users will be able to make do with the public interface modules. +-- +----------------------------------------------------------------------------- + +module Data.Binary.Builder.Internal ( + -- * Low-level construction of Builders + writeN + , writeAtMost + ) where + +import Data.Binary.Builder.Base diff -Nru ghc-7.0.3/libraries/binary/src/Data/Binary/Builder.hs ghc-7.2.1/libraries/binary/src/Data/Binary/Builder.hs --- ghc-7.0.3/libraries/binary/src/Data/Binary/Builder.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/binary/src/Data/Binary/Builder.hs 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,53 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Binary.Builder +-- Copyright : Lennart Kolmodin, Ross Paterson +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Lennart Kolmodin +-- Stability : experimental +-- Portability : portable to Hugs and GHC +-- +-- Efficient construction of lazy bytestrings. +-- +----------------------------------------------------------------------------- + +module Data.Binary.Builder ( + + -- * The Builder type + Builder + , toLazyByteString + + -- * Constructing Builders + , empty + , singleton + , append + , fromByteString -- :: S.ByteString -> Builder + , fromLazyByteString -- :: L.ByteString -> Builder + + -- * Flushing the buffer state + , flush + + -- * Derived Builders + -- ** Big-endian writes + , putWord16be -- :: Word16 -> Builder + , putWord32be -- :: Word32 -> Builder + , putWord64be -- :: Word64 -> Builder + + -- ** Little-endian writes + , putWord16le -- :: Word16 -> Builder + , putWord32le -- :: Word32 -> Builder + , putWord64le -- :: Word64 -> Builder + + -- ** Host-endian, unaligned writes + , putWordhost -- :: Word -> Builder + , putWord16host -- :: Word16 -> Builder + , putWord32host -- :: Word32 -> Builder + , putWord64host -- :: Word64 -> Builder + + -- ** Unicode + , putCharUtf8 + + ) where + +import Data.Binary.Builder.Base diff -Nru ghc-7.0.3/libraries/binary/src/Data/Binary/Get.hs ghc-7.2.1/libraries/binary/src/Data/Binary/Get.hs --- ghc-7.0.3/libraries/binary/src/Data/Binary/Get.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/binary/src/Data/Binary/Get.hs 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,547 @@ +{-# LANGUAGE CPP, MagicHash, UnboxedTuples #-} +-- MagicHash, UnboxedTuples for unboxed shifts + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Binary.Get +-- Copyright : Lennart Kolmodin +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Lennart Kolmodin +-- Stability : experimental +-- Portability : portable to Hugs and GHC. +-- +-- The Get monad. A monad for efficiently building structures from +-- encoded lazy ByteStrings +-- +----------------------------------------------------------------------------- + +#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) +#include "MachDeps.h" +#endif + +module Data.Binary.Get ( + + -- * The Get type + Get + , runGet + , runGetState + + -- * Parsing + , skip + , uncheckedSkip + , lookAhead + , lookAheadM + , lookAheadE + , uncheckedLookAhead + + -- * Utility + , bytesRead + , getBytes + , remaining + , isEmpty + + -- * Parsing particular types + , getWord8 + + -- ** ByteStrings + , getByteString + , getLazyByteString + , getLazyByteStringNul + , getRemainingLazyByteString + + -- ** Big-endian reads + , getWord16be + , getWord32be + , getWord64be + + -- ** Little-endian reads + , getWord16le + , getWord32le + , getWord64le + + -- ** Host-endian, unaligned reads + , getWordhost + , getWord16host + , getWord32host + , getWord64host + + ) where + +import Control.Monad (when,liftM,ap) +import Control.Monad.Fix +import Data.Maybe (isNothing) + +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as L + +#ifdef BYTESTRING_IN_BASE +import qualified Data.ByteString.Base as B +#else +import qualified Data.ByteString.Internal as B +import qualified Data.ByteString.Lazy.Internal as L +#endif + +#ifdef APPLICATIVE_IN_BASE +import Control.Applicative (Applicative(..)) +#endif + +import Foreign + +-- used by splitAtST +import Control.Monad.ST +import Data.STRef + +#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) +import GHC.Base +import GHC.Word +import GHC.Int +#endif + +-- | The parse state +data S = S {-# UNPACK #-} !B.ByteString -- current chunk + L.ByteString -- the rest of the input + {-# UNPACK #-} !Int64 -- bytes read + +-- | The Get monad is just a State monad carrying around the input ByteString +-- We treat it as a strict state monad. +newtype Get a = Get { unGet :: S -> (# a, S #) } + +instance Functor Get where + fmap f m = Get (\s -> case unGet m s of + (# a, s' #) -> (# f a, s' #)) + {-# INLINE fmap #-} + +#ifdef APPLICATIVE_IN_BASE +instance Applicative Get where + pure = return + (<*>) = ap +#endif + +-- Definition directly from Control.Monad.State.Strict +instance Monad Get where + return a = Get $ \s -> (# a, s #) + {-# INLINE return #-} + + m >>= k = Get $ \s -> case unGet m s of + (# a, s' #) -> unGet (k a) s' + {-# INLINE (>>=) #-} + + fail = failDesc + +instance MonadFix Get where + mfix f = Get $ \s -> let (a,s') = case unGet (f a) s of + (# a', s'' #) -> (a',s'') + in (# a,s' #) + +------------------------------------------------------------------------ + +get :: Get S +get = Get $ \s -> (# s, s #) + +put :: S -> Get () +put s = Get $ \_ -> (# (), s #) + +------------------------------------------------------------------------ +-- +-- dons, GHC 6.10: explicit inlining disabled, was killing performance. +-- Without it, GHC seems to do just fine. And we get similar +-- performance with 6.8.2 anyway. +-- + +initState :: L.ByteString -> S +initState xs = mkState xs 0 +{- INLINE initState -} + +{- +initState (B.LPS xs) = + case xs of + [] -> S B.empty L.empty 0 + (x:xs') -> S x (B.LPS xs') 0 +-} + +#ifndef BYTESTRING_IN_BASE +mkState :: L.ByteString -> Int64 -> S +mkState l = case l of + L.Empty -> S B.empty L.empty + L.Chunk x xs -> S x xs +{- INLINE mkState -} + +#else +mkState :: L.ByteString -> Int64 -> S +mkState (B.LPS xs) = + case xs of + [] -> S B.empty L.empty + (x:xs') -> S x (B.LPS xs') +#endif + +-- | Run the Get monad applies a 'get'-based parser on the input ByteString +runGet :: Get a -> L.ByteString -> a +runGet m str = case unGet m (initState str) of (# a, _ #) -> a + +-- | Run the Get monad applies a 'get'-based parser on the input +-- ByteString. Additional to the result of get it returns the number of +-- consumed bytes and the rest of the input. +runGetState :: Get a -> L.ByteString -> Int64 -> (a, L.ByteString, Int64) +runGetState m str off = + case unGet m (mkState str off) of + (# a, ~(S s ss newOff) #) -> (a, s `join` ss, newOff) + +------------------------------------------------------------------------ + +failDesc :: String -> Get a +failDesc err = do + S _ _ bytes <- get + Get (error (err ++ ". Failed reading at byte position " ++ show bytes)) + +-- | Skip ahead @n@ bytes. Fails if fewer than @n@ bytes are available. +skip :: Int -> Get () +skip n = readN (fromIntegral n) (const ()) + +-- | Skip ahead @n@ bytes. No error if there isn't enough bytes. +uncheckedSkip :: Int64 -> Get () +uncheckedSkip n = do + S s ss bytes <- get + if fromIntegral (B.length s) >= n + then put (S (B.drop (fromIntegral n) s) ss (bytes + n)) + else do + let rest = L.drop (n - fromIntegral (B.length s)) ss + put $! mkState rest (bytes + n) + +-- | Run @ga@, but return without consuming its input. +-- Fails if @ga@ fails. +lookAhead :: Get a -> Get a +lookAhead ga = do + s <- get + a <- ga + put s + return a + +-- | Like 'lookAhead', but consume the input if @gma@ returns 'Just _'. +-- Fails if @gma@ fails. +lookAheadM :: Get (Maybe a) -> Get (Maybe a) +lookAheadM gma = do + s <- get + ma <- gma + when (isNothing ma) $ + put s + return ma + +-- | Like 'lookAhead', but consume the input if @gea@ returns 'Right _'. +-- Fails if @gea@ fails. +lookAheadE :: Get (Either a b) -> Get (Either a b) +lookAheadE gea = do + s <- get + ea <- gea + case ea of + Left _ -> put s + _ -> return () + return ea + +-- | Get the next up to @n@ bytes as a lazy ByteString, without consuming them. +uncheckedLookAhead :: Int64 -> Get L.ByteString +uncheckedLookAhead n = do + S s ss _ <- get + if n <= fromIntegral (B.length s) + then return (L.fromChunks [B.take (fromIntegral n) s]) + else return $ L.take n (s `join` ss) + +------------------------------------------------------------------------ +-- Utility + +-- | Get the total number of bytes read to this point. +bytesRead :: Get Int64 +bytesRead = do + S _ _ b <- get + return b + +-- | Get the number of remaining unparsed bytes. +-- Useful for checking whether all input has been consumed. +-- Note that this forces the rest of the input. +remaining :: Get Int64 +remaining = do + S s ss _ <- get + return (fromIntegral (B.length s) + L.length ss) + +-- | Test whether all input has been consumed, +-- i.e. there are no remaining unparsed bytes. +isEmpty :: Get Bool +isEmpty = do + S s ss _ <- get + return (B.null s && L.null ss) + +------------------------------------------------------------------------ +-- Utility with ByteStrings + +-- | An efficient 'get' method for strict ByteStrings. Fails if fewer +-- than @n@ bytes are left in the input. +getByteString :: Int -> Get B.ByteString +getByteString n = readN n id +{-# INLINE getByteString #-} + +-- | An efficient 'get' method for lazy ByteStrings. Does not fail if fewer than +-- @n@ bytes are left in the input. +getLazyByteString :: Int64 -> Get L.ByteString +getLazyByteString n = do + S s ss bytes <- get + let big = s `join` ss + case splitAtST n big of + (consume, rest) -> do put $ mkState rest (bytes + n) + return consume +{-# INLINE getLazyByteString #-} + +-- | Get a lazy ByteString that is terminated with a NUL byte. Fails +-- if it reaches the end of input without hitting a NUL. +getLazyByteStringNul :: Get L.ByteString +getLazyByteStringNul = do + S s ss bytes <- get + let big = s `join` ss + (consume, t) = L.break (== 0) big + (h, rest) = L.splitAt 1 t + if L.null h + then fail "too few bytes" + else do + put $ mkState rest (bytes + L.length consume + 1) + return consume +{-# INLINE getLazyByteStringNul #-} + +-- | Get the remaining bytes as a lazy ByteString +getRemainingLazyByteString :: Get L.ByteString +getRemainingLazyByteString = do + S s ss _ <- get + return (s `join` ss) + +------------------------------------------------------------------------ +-- Helpers + +-- | Pull @n@ bytes from the input, as a strict ByteString. +getBytes :: Int -> Get B.ByteString +getBytes n = do + S s ss bytes <- get + if n <= B.length s + then do let (consume,rest) = B.splitAt n s + put $! S rest ss (bytes + fromIntegral n) + return $! consume + else + case L.splitAt (fromIntegral n) (s `join` ss) of + (consuming, rest) -> + do let now = B.concat . L.toChunks $ consuming + put $! mkState rest (bytes + fromIntegral n) + -- forces the next chunk before this one is returned + if (B.length now < n) + then + fail "too few bytes" + else + return now +{- INLINE getBytes -} +-- ^ important + +#ifndef BYTESTRING_IN_BASE +join :: B.ByteString -> L.ByteString -> L.ByteString +join bb lb + | B.null bb = lb + | otherwise = L.Chunk bb lb + +#else +join :: B.ByteString -> L.ByteString -> L.ByteString +join bb (B.LPS lb) + | B.null bb = B.LPS lb + | otherwise = B.LPS (bb:lb) +#endif + -- don't use L.append, it's strict in it's second argument :/ +{- INLINE join -} + +-- | Split a ByteString. If the first result is consumed before the -- +-- second, this runs in constant heap space. +-- +-- You must force the returned tuple for that to work, e.g. +-- +-- > case splitAtST n xs of +-- > (ys,zs) -> consume ys ... consume zs +-- +splitAtST :: Int64 -> L.ByteString -> (L.ByteString, L.ByteString) +splitAtST i ps | i <= 0 = (L.empty, ps) +#ifndef BYTESTRING_IN_BASE +splitAtST i ps = runST ( + do r <- newSTRef undefined + xs <- first r i ps + ys <- unsafeInterleaveST (readSTRef r) + return (xs, ys)) + + where + first :: STRef s L.ByteString -> Int64 -> L.ByteString -> ST s L.ByteString + first r 0 xs@(L.Chunk _ _) = writeSTRef r xs >> return L.Empty + first r _ L.Empty = writeSTRef r L.Empty >> return L.Empty + + first r n (L.Chunk x xs) + | n < l = do writeSTRef r (L.Chunk (B.drop (fromIntegral n) x) xs) + return $ L.Chunk (B.take (fromIntegral n) x) L.Empty + | otherwise = do writeSTRef r (L.drop (n - l) xs) + liftM (L.Chunk x) $ unsafeInterleaveST (first r (n - l) xs) + where + l = fromIntegral (B.length x) +#else +splitAtST i (B.LPS ps) = runST ( + do r <- newSTRef undefined + xs <- first r i ps + ys <- unsafeInterleaveST (readSTRef r) + return (B.LPS xs, B.LPS ys)) + + where first r 0 xs = writeSTRef r xs >> return [] + first r _ [] = writeSTRef r [] >> return [] + first r n (x:xs) + | n < l = do writeSTRef r (B.drop (fromIntegral n) x : xs) + return [B.take (fromIntegral n) x] + | otherwise = do writeSTRef r (L.toChunks (L.drop (n - l) (B.LPS xs))) + fmap (x:) $ unsafeInterleaveST (first r (n - l) xs) + + where l = fromIntegral (B.length x) +#endif +{- INLINE splitAtST -} + +-- Pull n bytes from the input, and apply a parser to those bytes, +-- yielding a value. If less than @n@ bytes are available, fail with an +-- error. This wraps @getBytes@. +readN :: Int -> (B.ByteString -> a) -> Get a +readN n f = fmap f $ getBytes n +{- INLINE readN -} +-- ^ important + +------------------------------------------------------------------------ +-- Primtives + +-- helper, get a raw Ptr onto a strict ByteString copied out of the +-- underlying lazy byteString. So many indirections from the raw parser +-- state that my head hurts... + +getPtr :: Storable a => Int -> Get a +getPtr n = do + (fp,o,_) <- readN n B.toForeignPtr + return . B.inlinePerformIO $ withForeignPtr fp $ \p -> peek (castPtr $ p `plusPtr` o) +{- INLINE getPtr -} + +------------------------------------------------------------------------ + +-- | Read a Word8 from the monad state +getWord8 :: Get Word8 +getWord8 = getPtr (sizeOf (undefined :: Word8)) +{- INLINE getWord8 -} + +-- | Read a Word16 in big endian format +getWord16be :: Get Word16 +getWord16be = do + s <- readN 2 id + return $! (fromIntegral (s `B.index` 0) `shiftl_w16` 8) .|. + (fromIntegral (s `B.index` 1)) +{- INLINE getWord16be -} + +-- | Read a Word16 in little endian format +getWord16le :: Get Word16 +getWord16le = do + s <- readN 2 id + return $! (fromIntegral (s `B.index` 1) `shiftl_w16` 8) .|. + (fromIntegral (s `B.index` 0) ) +{- INLINE getWord16le -} + +-- | Read a Word32 in big endian format +getWord32be :: Get Word32 +getWord32be = do + s <- readN 4 id + return $! (fromIntegral (s `B.index` 0) `shiftl_w32` 24) .|. + (fromIntegral (s `B.index` 1) `shiftl_w32` 16) .|. + (fromIntegral (s `B.index` 2) `shiftl_w32` 8) .|. + (fromIntegral (s `B.index` 3) ) +{- INLINE getWord32be -} + +-- | Read a Word32 in little endian format +getWord32le :: Get Word32 +getWord32le = do + s <- readN 4 id + return $! (fromIntegral (s `B.index` 3) `shiftl_w32` 24) .|. + (fromIntegral (s `B.index` 2) `shiftl_w32` 16) .|. + (fromIntegral (s `B.index` 1) `shiftl_w32` 8) .|. + (fromIntegral (s `B.index` 0) ) +{- INLINE getWord32le -} + +-- | Read a Word64 in big endian format +getWord64be :: Get Word64 +getWord64be = do + s <- readN 8 id + return $! (fromIntegral (s `B.index` 0) `shiftl_w64` 56) .|. + (fromIntegral (s `B.index` 1) `shiftl_w64` 48) .|. + (fromIntegral (s `B.index` 2) `shiftl_w64` 40) .|. + (fromIntegral (s `B.index` 3) `shiftl_w64` 32) .|. + (fromIntegral (s `B.index` 4) `shiftl_w64` 24) .|. + (fromIntegral (s `B.index` 5) `shiftl_w64` 16) .|. + (fromIntegral (s `B.index` 6) `shiftl_w64` 8) .|. + (fromIntegral (s `B.index` 7) ) +{- INLINE getWord64be -} + +-- | Read a Word64 in little endian format +getWord64le :: Get Word64 +getWord64le = do + s <- readN 8 id + return $! (fromIntegral (s `B.index` 7) `shiftl_w64` 56) .|. + (fromIntegral (s `B.index` 6) `shiftl_w64` 48) .|. + (fromIntegral (s `B.index` 5) `shiftl_w64` 40) .|. + (fromIntegral (s `B.index` 4) `shiftl_w64` 32) .|. + (fromIntegral (s `B.index` 3) `shiftl_w64` 24) .|. + (fromIntegral (s `B.index` 2) `shiftl_w64` 16) .|. + (fromIntegral (s `B.index` 1) `shiftl_w64` 8) .|. + (fromIntegral (s `B.index` 0) ) +{- INLINE getWord64le -} + +------------------------------------------------------------------------ +-- Host-endian reads + +-- | /O(1)./ Read a single native machine word. The word is read in +-- host order, host endian form, for the machine you're on. On a 64 bit +-- machine the Word is an 8 byte value, on a 32 bit machine, 4 bytes. +getWordhost :: Get Word +getWordhost = getPtr (sizeOf (undefined :: Word)) +{- INLINE getWordhost -} + +-- | /O(1)./ Read a 2 byte Word16 in native host order and host endianness. +getWord16host :: Get Word16 +getWord16host = getPtr (sizeOf (undefined :: Word16)) +{- INLINE getWord16host -} + +-- | /O(1)./ Read a Word32 in native host order and host endianness. +getWord32host :: Get Word32 +getWord32host = getPtr (sizeOf (undefined :: Word32)) +{- INLINE getWord32host -} + +-- | /O(1)./ Read a Word64 in native host order and host endianess. +getWord64host :: Get Word64 +getWord64host = getPtr (sizeOf (undefined :: Word64)) +{- INLINE getWord64host -} + +------------------------------------------------------------------------ +-- Unchecked shifts + +shiftl_w16 :: Word16 -> Int -> Word16 +shiftl_w32 :: Word32 -> Int -> Word32 +shiftl_w64 :: Word64 -> Int -> Word64 + +#if defined(__GLASGOW_HASKELL__) && !defined(__HADDOCK__) +shiftl_w16 (W16# w) (I# i) = W16# (w `uncheckedShiftL#` i) +shiftl_w32 (W32# w) (I# i) = W32# (w `uncheckedShiftL#` i) + +#if WORD_SIZE_IN_BITS < 64 +shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL64#` i) + +#if __GLASGOW_HASKELL__ <= 606 +-- Exported by GHC.Word in GHC 6.8 and higher +foreign import ccall unsafe "stg_uncheckedShiftL64" + uncheckedShiftL64# :: Word64# -> Int# -> Word64# +#endif + +#else +shiftl_w64 (W64# w) (I# i) = W64# (w `uncheckedShiftL#` i) +#endif + +#else +shiftl_w16 = shiftL +shiftl_w32 = shiftL +shiftl_w64 = shiftL +#endif diff -Nru ghc-7.0.3/libraries/binary/src/Data/Binary/Put.hs ghc-7.2.1/libraries/binary/src/Data/Binary/Put.hs --- ghc-7.0.3/libraries/binary/src/Data/Binary/Put.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/binary/src/Data/Binary/Put.hs 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,217 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- | +-- Module : Data.Binary.Put +-- Copyright : Lennart Kolmodin +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Lennart Kolmodin +-- Stability : stable +-- Portability : Portable to Hugs and GHC. Requires MPTCs +-- +-- The Put monad. A monad for efficiently constructing lazy bytestrings. +-- +----------------------------------------------------------------------------- + +module Data.Binary.Put ( + + -- * The Put type + Put + , PutM(..) + , runPut + , runPutM + , putBuilder + , execPut + + -- * Flushing the implicit parse state + , flush + + -- * Primitives + , putWord8 + , putByteString + , putLazyByteString + + -- * Big-endian primitives + , putWord16be + , putWord32be + , putWord64be + + -- * Little-endian primitives + , putWord16le + , putWord32le + , putWord64le + + -- * Host-endian, unaligned writes + , putWordhost -- :: Word -> Put + , putWord16host -- :: Word16 -> Put + , putWord32host -- :: Word32 -> Put + , putWord64host -- :: Word64 -> Put + + ) where + +import Data.Monoid +import Data.Binary.Builder (Builder, toLazyByteString) +import qualified Data.Binary.Builder as B + +import Data.Word +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L + +#ifdef APPLICATIVE_IN_BASE +import Control.Applicative +#endif + + +------------------------------------------------------------------------ + +-- XXX Strict in buffer only. +data PairS a = PairS a !Builder + +sndS :: PairS a -> Builder +sndS (PairS _ b) = b + +-- | The PutM type. A Writer monad over the efficient Builder monoid. +newtype PutM a = Put { unPut :: PairS a } + +-- | Put merely lifts Builder into a Writer monad, applied to (). +type Put = PutM () + +instance Functor PutM where + fmap f m = Put $ let PairS a w = unPut m in PairS (f a) w + {-# INLINE fmap #-} + +#ifdef APPLICATIVE_IN_BASE +instance Applicative PutM where + pure = return + m <*> k = Put $ + let PairS f w = unPut m + PairS x w' = unPut k + in PairS (f x) (w `mappend` w') +#endif + +-- Standard Writer monad, with aggressive inlining +instance Monad PutM where + return a = Put $ PairS a mempty + {-# INLINE return #-} + + m >>= k = Put $ + let PairS a w = unPut m + PairS b w' = unPut (k a) + in PairS b (w `mappend` w') + {-# INLINE (>>=) #-} + + m >> k = Put $ + let PairS _ w = unPut m + PairS b w' = unPut k + in PairS b (w `mappend` w') + {-# INLINE (>>) #-} + +tell :: Builder -> Put +tell b = Put $ PairS () b +{-# INLINE tell #-} + +putBuilder :: Builder -> Put +putBuilder = tell +{-# INLINE putBuilder #-} + +-- | Run the 'Put' monad +execPut :: PutM a -> Builder +execPut = sndS . unPut +{-# INLINE execPut #-} + +-- | Run the 'Put' monad with a serialiser +runPut :: Put -> L.ByteString +runPut = toLazyByteString . sndS . unPut +{-# INLINE runPut #-} + +-- | Run the 'Put' monad with a serialiser and get its result +runPutM :: PutM a -> (a, L.ByteString) +runPutM (Put (PairS f s)) = (f, toLazyByteString s) +{-# INLINE runPutM #-} + +------------------------------------------------------------------------ + +-- | Pop the ByteString we have constructed so far, if any, yielding a +-- new chunk in the result ByteString. +flush :: Put +flush = tell B.flush +{-# INLINE flush #-} + +-- | Efficiently write a byte into the output buffer +putWord8 :: Word8 -> Put +putWord8 = tell . B.singleton +{-# INLINE putWord8 #-} + +-- | An efficient primitive to write a strict ByteString into the output buffer. +-- It flushes the current buffer, and writes the argument into a new chunk. +putByteString :: S.ByteString -> Put +putByteString = tell . B.fromByteString +{-# INLINE putByteString #-} + +-- | Write a lazy ByteString efficiently, simply appending the lazy +-- ByteString chunks to the output buffer +putLazyByteString :: L.ByteString -> Put +putLazyByteString = tell . B.fromLazyByteString +{-# INLINE putLazyByteString #-} + +-- | Write a Word16 in big endian format +putWord16be :: Word16 -> Put +putWord16be = tell . B.putWord16be +{-# INLINE putWord16be #-} + +-- | Write a Word16 in little endian format +putWord16le :: Word16 -> Put +putWord16le = tell . B.putWord16le +{-# INLINE putWord16le #-} + +-- | Write a Word32 in big endian format +putWord32be :: Word32 -> Put +putWord32be = tell . B.putWord32be +{-# INLINE putWord32be #-} + +-- | Write a Word32 in little endian format +putWord32le :: Word32 -> Put +putWord32le = tell . B.putWord32le +{-# INLINE putWord32le #-} + +-- | Write a Word64 in big endian format +putWord64be :: Word64 -> Put +putWord64be = tell . B.putWord64be +{-# INLINE putWord64be #-} + +-- | Write a Word64 in little endian format +putWord64le :: Word64 -> Put +putWord64le = tell . B.putWord64le +{-# INLINE putWord64le #-} + +------------------------------------------------------------------------ + +-- | /O(1)./ Write a single native machine word. The word is +-- written in host order, host endian form, for the machine you're on. +-- On a 64 bit machine the Word is an 8 byte value, on a 32 bit machine, +-- 4 bytes. Values written this way are not portable to +-- different endian or word sized machines, without conversion. +-- +putWordhost :: Word -> Put +putWordhost = tell . B.putWordhost +{-# INLINE putWordhost #-} + +-- | /O(1)./ Write a Word16 in native host order and host endianness. +-- For portability issues see @putWordhost@. +putWord16host :: Word16 -> Put +putWord16host = tell . B.putWord16host +{-# INLINE putWord16host #-} + +-- | /O(1)./ Write a Word32 in native host order and host endianness. +-- For portability issues see @putWordhost@. +putWord32host :: Word32 -> Put +putWord32host = tell . B.putWord32host +{-# INLINE putWord32host #-} + +-- | /O(1)./ Write a Word64 in native host order +-- On a 32 bit machine we write two host order Word32s, in big endian form. +-- For portability issues see @putWordhost@. +putWord64host :: Word64 -> Put +putWord64host = tell . B.putWord64host +{-# INLINE putWord64host #-} diff -Nru ghc-7.0.3/libraries/binary/src/Data/Binary.hs ghc-7.2.1/libraries/binary/src/Data/Binary.hs --- ghc-7.0.3/libraries/binary/src/Data/Binary.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/binary/src/Data/Binary.hs 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,718 @@ +{-# LANGUAGE CPP, FlexibleInstances, FlexibleContexts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Data.Binary +-- Copyright : Lennart Kolmodin +-- License : BSD3-style (see LICENSE) +-- +-- Maintainer : Lennart Kolmodin +-- Stability : unstable +-- Portability : portable to Hugs and GHC. Requires the FFI and some flexible instances +-- +-- Binary serialisation of Haskell values to and from lazy ByteStrings. +-- The Binary library provides methods for encoding Haskell values as +-- streams of bytes directly in memory. The resulting @ByteString@ can +-- then be written to disk, sent over the network, or futher processed +-- (for example, compressed with gzip). +-- +-- The 'Binary' package is notable in that it provides both pure, and +-- high performance serialisation. +-- +-- Values are always encoded in network order (big endian) form, and +-- encoded data should be portable across machine endianess, word size, +-- or compiler version. For example, data encoded using the Binary class +-- could be written from GHC, and read back in Hugs. +-- +----------------------------------------------------------------------------- + +module Data.Binary ( + + -- * The Binary class + Binary(..) + + -- $example + + -- * The Get and Put monads + , Get + , Put + + -- * Useful helpers for writing instances + , putWord8 + , getWord8 + + -- * Binary serialisation + , encode -- :: Binary a => a -> ByteString + , decode -- :: Binary a => ByteString -> a + + -- * IO functions for serialisation + , encodeFile -- :: Binary a => FilePath -> a -> IO () + , decodeFile -- :: Binary a => FilePath -> IO a + +-- Lazy put and get +-- , lazyPut +-- , lazyGet + + , module Data.Word -- useful + + ) where + +import Data.Word + +import Data.Binary.Put +import Data.Binary.Get + +import Control.Monad +import Foreign + +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as L + +import Data.Char (chr,ord) +import Data.List (unfoldr) + +-- And needed for the instances: +import qualified Data.ByteString as B +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.IntMap as IntMap +import qualified Data.IntSet as IntSet +import qualified Data.Ratio as R + +import qualified Data.Tree as T + +import Data.Array.Unboxed + +-- +-- This isn't available in older Hugs or older GHC +-- +#if __GLASGOW_HASKELL__ >= 606 +import qualified Data.Sequence as Seq +import qualified Data.Foldable as Fold +#endif + +------------------------------------------------------------------------ + +-- | The @Binary@ class provides 'put' and 'get', methods to encode and +-- decode a Haskell value to a lazy ByteString. It mirrors the Read and +-- Show classes for textual representation of Haskell types, and is +-- suitable for serialising Haskell values to disk, over the network. +-- +-- For parsing and generating simple external binary formats (e.g. C +-- structures), Binary may be used, but in general is not suitable +-- for complex protocols. Instead use the Put and Get primitives +-- directly. +-- +-- Instances of Binary should satisfy the following property: +-- +-- > decode . encode == id +-- +-- That is, the 'get' and 'put' methods should be the inverse of each +-- other. A range of instances are provided for basic Haskell types. +-- +class Binary t where + -- | Encode a value in the Put monad. + put :: t -> Put + -- | Decode a value in the Get monad + get :: Get t + +-- $example +-- To serialise a custom type, an instance of Binary for that type is +-- required. For example, suppose we have a data structure: +-- +-- > data Exp = IntE Int +-- > | OpE String Exp Exp +-- > deriving Show +-- +-- We can encode values of this type into bytestrings using the +-- following instance, which proceeds by recursively breaking down the +-- structure to serialise: +-- +-- > instance Binary Exp where +-- > put (IntE i) = do put (0 :: Word8) +-- > put i +-- > put (OpE s e1 e2) = do put (1 :: Word8) +-- > put s +-- > put e1 +-- > put e2 +-- > +-- > get = do t <- get :: Get Word8 +-- > case t of +-- > 0 -> do i <- get +-- > return (IntE i) +-- > 1 -> do s <- get +-- > e1 <- get +-- > e2 <- get +-- > return (OpE s e1 e2) +-- +-- Note how we write an initial tag byte to indicate each variant of the +-- data type. +-- +-- We can simplify the writing of 'get' instances using monadic +-- combinators: +-- +-- > get = do tag <- getWord8 +-- > case tag of +-- > 0 -> liftM IntE get +-- > 1 -> liftM3 OpE get get get +-- +-- The generation of Binary instances has been automated by a script +-- using Scrap Your Boilerplate generics. Use the script here: +-- . +-- +-- To derive the instance for a type, load this script into GHCi, and +-- bring your type into scope. Your type can then have its Binary +-- instances derived as follows: +-- +-- > $ ghci -fglasgow-exts BinaryDerive.hs +-- > *BinaryDerive> :l Example.hs +-- > *Main> deriveM (undefined :: Drinks) +-- > +-- > instance Binary Main.Drinks where +-- > put (Beer a) = putWord8 0 >> put a +-- > put Coffee = putWord8 1 +-- > put Tea = putWord8 2 +-- > put EnergyDrink = putWord8 3 +-- > put Water = putWord8 4 +-- > put Wine = putWord8 5 +-- > put Whisky = putWord8 6 +-- > get = do +-- > tag_ <- getWord8 +-- > case tag_ of +-- > 0 -> get >>= \a -> return (Beer a) +-- > 1 -> return Coffee +-- > 2 -> return Tea +-- > 3 -> return EnergyDrink +-- > 4 -> return Water +-- > 5 -> return Wine +-- > 6 -> return Whisky +-- > +-- +-- To serialise this to a bytestring, we use 'encode', which packs the +-- data structure into a binary format, in a lazy bytestring +-- +-- > > let e = OpE "*" (IntE 7) (OpE "/" (IntE 4) (IntE 2)) +-- > > let v = encode e +-- +-- Where 'v' is a binary encoded data structure. To reconstruct the +-- original data, we use 'decode' +-- +-- > > decode v :: Exp +-- > OpE "*" (IntE 7) (OpE "/" (IntE 4) (IntE 2)) +-- +-- The lazy ByteString that results from 'encode' can be written to +-- disk, and read from disk using Data.ByteString.Lazy IO functions, +-- such as hPutStr or writeFile: +-- +-- > > writeFile "/tmp/exp.txt" (encode e) +-- +-- And read back with: +-- +-- > > readFile "/tmp/exp.txt" >>= return . decode :: IO Exp +-- > OpE "*" (IntE 7) (OpE "/" (IntE 4) (IntE 2)) +-- +-- We can also directly serialise a value to and from a Handle, or a file: +-- +-- > > v <- decodeFile "/tmp/exp.txt" :: IO Exp +-- > OpE "*" (IntE 7) (OpE "/" (IntE 4) (IntE 2)) +-- +-- And write a value to disk +-- +-- > > encodeFile "/tmp/a.txt" v +-- + +------------------------------------------------------------------------ +-- Wrappers to run the underlying monad + +-- | Encode a value using binary serialisation to a lazy ByteString. +-- +encode :: Binary a => a -> ByteString +encode = runPut . put +{-# INLINE encode #-} + +-- | Decode a value from a lazy ByteString, reconstructing the original structure. +-- +decode :: Binary a => ByteString -> a +decode = runGet get + +------------------------------------------------------------------------ +-- Convenience IO operations + +-- | Lazily serialise a value to a file +-- +-- This is just a convenience function, it's defined simply as: +-- +-- > encodeFile f = B.writeFile f . encode +-- +-- So for example if you wanted to compress as well, you could use: +-- +-- > B.writeFile f . compress . encode +-- +encodeFile :: Binary a => FilePath -> a -> IO () +encodeFile f v = L.writeFile f (encode v) + +-- | Lazily reconstruct a value previously written to a file. +-- +-- This is just a convenience function, it's defined simply as: +-- +-- > decodeFile f = return . decode =<< B.readFile f +-- +-- So for example if you wanted to decompress as well, you could use: +-- +-- > return . decode . decompress =<< B.readFile f +-- +-- After contructing the data from the input file, 'decodeFile' checks +-- if the file is empty, and in doing so will force the associated file +-- handle closed, if it is indeed empty. If the file is not empty, +-- it is up to the decoding instance to consume the rest of the data, +-- or otherwise finalise the resource. +-- +decodeFile :: Binary a => FilePath -> IO a +decodeFile f = do + s <- L.readFile f + return $ runGet (do v <- get + m <- isEmpty + m `seq` return v) s + +-- needs bytestring 0.9.1.x to work + +------------------------------------------------------------------------ +-- Lazy put and get + +-- lazyPut :: (Binary a) => a -> Put +-- lazyPut a = put (encode a) + +-- lazyGet :: (Binary a) => Get a +-- lazyGet = fmap decode get + +------------------------------------------------------------------------ +-- Simple instances + +-- The () type need never be written to disk: values of singleton type +-- can be reconstructed from the type alone +instance Binary () where + put () = return () + get = return () + +-- Bools are encoded as a byte in the range 0 .. 1 +instance Binary Bool where + put = putWord8 . fromIntegral . fromEnum + get = liftM (toEnum . fromIntegral) getWord8 + +-- Values of type 'Ordering' are encoded as a byte in the range 0 .. 2 +instance Binary Ordering where + put = putWord8 . fromIntegral . fromEnum + get = liftM (toEnum . fromIntegral) getWord8 + +------------------------------------------------------------------------ +-- Words and Ints + +-- Words8s are written as bytes +instance Binary Word8 where + put = putWord8 + get = getWord8 + +-- Words16s are written as 2 bytes in big-endian (network) order +instance Binary Word16 where + put = putWord16be + get = getWord16be + +-- Words32s are written as 4 bytes in big-endian (network) order +instance Binary Word32 where + put = putWord32be + get = getWord32be + +-- Words64s are written as 8 bytes in big-endian (network) order +instance Binary Word64 where + put = putWord64be + get = getWord64be + +-- Int8s are written as a single byte. +instance Binary Int8 where + put i = put (fromIntegral i :: Word8) + get = liftM fromIntegral (get :: Get Word8) + +-- Int16s are written as a 2 bytes in big endian format +instance Binary Int16 where + put i = put (fromIntegral i :: Word16) + get = liftM fromIntegral (get :: Get Word16) + +-- Int32s are written as a 4 bytes in big endian format +instance Binary Int32 where + put i = put (fromIntegral i :: Word32) + get = liftM fromIntegral (get :: Get Word32) + +-- Int64s are written as a 4 bytes in big endian format +instance Binary Int64 where + put i = put (fromIntegral i :: Word64) + get = liftM fromIntegral (get :: Get Word64) + +------------------------------------------------------------------------ + +-- Words are are written as Word64s, that is, 8 bytes in big endian format +instance Binary Word where + put i = put (fromIntegral i :: Word64) + get = liftM fromIntegral (get :: Get Word64) + +-- Ints are are written as Int64s, that is, 8 bytes in big endian format +instance Binary Int where + put i = put (fromIntegral i :: Int64) + get = liftM fromIntegral (get :: Get Int64) + +------------------------------------------------------------------------ +-- +-- Portable, and pretty efficient, serialisation of Integer +-- + +-- Fixed-size type for a subset of Integer +type SmallInt = Int32 + +-- Integers are encoded in two ways: if they fit inside a SmallInt, +-- they're written as a byte tag, and that value. If the Integer value +-- is too large to fit in a SmallInt, it is written as a byte array, +-- along with a sign and length field. + +instance Binary Integer where + + {-# INLINE put #-} + put n | n >= lo && n <= hi = do + putWord8 0 + put (fromIntegral n :: SmallInt) -- fast path + where + lo = fromIntegral (minBound :: SmallInt) :: Integer + hi = fromIntegral (maxBound :: SmallInt) :: Integer + + put n = do + putWord8 1 + put sign + put (unroll (abs n)) -- unroll the bytes + where + sign = fromIntegral (signum n) :: Word8 + + {-# INLINE get #-} + get = do + tag <- get :: Get Word8 + case tag of + 0 -> liftM fromIntegral (get :: Get SmallInt) + _ -> do sign <- get + bytes <- get + let v = roll bytes + return $! if sign == (1 :: Word8) then v else - v + +-- +-- Fold and unfold an Integer to and from a list of its bytes +-- +unroll :: Integer -> [Word8] +unroll = unfoldr step + where + step 0 = Nothing + step i = Just (fromIntegral i, i `shiftR` 8) + +roll :: [Word8] -> Integer +roll = foldr unstep 0 + where + unstep b a = a `shiftL` 8 .|. fromIntegral b + +{- + +-- +-- An efficient, raw serialisation for Integer (GHC only) +-- + +-- TODO This instance is not architecture portable. GMP stores numbers as +-- arrays of machine sized words, so the byte format is not portable across +-- architectures with different endianess and word size. + +import Data.ByteString.Base (toForeignPtr,unsafePackAddress, memcpy) +import GHC.Base hiding (ord, chr) +import GHC.Prim +import GHC.Ptr (Ptr(..)) +import GHC.IOBase (IO(..)) + +instance Binary Integer where + put (S# i) = putWord8 0 >> put (I# i) + put (J# s ba) = do + putWord8 1 + put (I# s) + put (BA ba) + + get = do + b <- getWord8 + case b of + 0 -> do (I# i#) <- get + return (S# i#) + _ -> do (I# s#) <- get + (BA a#) <- get + return (J# s# a#) + +instance Binary ByteArray where + + -- Pretty safe. + put (BA ba) = + let sz = sizeofByteArray# ba -- (primitive) in *bytes* + addr = byteArrayContents# ba + bs = unsafePackAddress (I# sz) addr + in put bs -- write as a ByteString. easy, yay! + + -- Pretty scary. Should be quick though + get = do + (fp, off, n@(I# sz)) <- liftM toForeignPtr get -- so decode a ByteString + assert (off == 0) $ return $ unsafePerformIO $ do + (MBA arr) <- newByteArray sz -- and copy it into a ByteArray# + let to = byteArrayContents# (unsafeCoerce# arr) -- urk, is this safe? + withForeignPtr fp $ \from -> memcpy (Ptr to) from (fromIntegral n) + freezeByteArray arr + +-- wrapper for ByteArray# +data ByteArray = BA {-# UNPACK #-} !ByteArray# +data MBA = MBA {-# UNPACK #-} !(MutableByteArray# RealWorld) + +newByteArray :: Int# -> IO MBA +newByteArray sz = IO $ \s -> + case newPinnedByteArray# sz s of { (# s', arr #) -> + (# s', MBA arr #) } + +freezeByteArray :: MutableByteArray# RealWorld -> IO ByteArray +freezeByteArray arr = IO $ \s -> + case unsafeFreezeByteArray# arr s of { (# s', arr' #) -> + (# s', BA arr' #) } + +-} + +instance (Binary a,Integral a) => Binary (R.Ratio a) where + put r = put (R.numerator r) >> put (R.denominator r) + get = liftM2 (R.%) get get + +------------------------------------------------------------------------ + +-- Char is serialised as UTF-8 +instance Binary Char where + put a | c <= 0x7f = put (fromIntegral c :: Word8) + | c <= 0x7ff = do put (0xc0 .|. y) + put (0x80 .|. z) + | c <= 0xffff = do put (0xe0 .|. x) + put (0x80 .|. y) + put (0x80 .|. z) + | c <= 0x10ffff = do put (0xf0 .|. w) + put (0x80 .|. x) + put (0x80 .|. y) + put (0x80 .|. z) + | otherwise = error "Not a valid Unicode code point" + where + c = ord a + z, y, x, w :: Word8 + z = fromIntegral (c .&. 0x3f) + y = fromIntegral (shiftR c 6 .&. 0x3f) + x = fromIntegral (shiftR c 12 .&. 0x3f) + w = fromIntegral (shiftR c 18 .&. 0x7) + + get = do + let getByte = liftM (fromIntegral :: Word8 -> Int) get + shiftL6 = flip shiftL 6 :: Int -> Int + w <- getByte + r <- case () of + _ | w < 0x80 -> return w + | w < 0xe0 -> do + x <- liftM (xor 0x80) getByte + return (x .|. shiftL6 (xor 0xc0 w)) + | w < 0xf0 -> do + x <- liftM (xor 0x80) getByte + y <- liftM (xor 0x80) getByte + return (y .|. shiftL6 (x .|. shiftL6 + (xor 0xe0 w))) + | otherwise -> do + x <- liftM (xor 0x80) getByte + y <- liftM (xor 0x80) getByte + z <- liftM (xor 0x80) getByte + return (z .|. shiftL6 (y .|. shiftL6 + (x .|. shiftL6 (xor 0xf0 w)))) + return $! chr r + +------------------------------------------------------------------------ +-- Instances for the first few tuples + +instance (Binary a, Binary b) => Binary (a,b) where + put (a,b) = put a >> put b + get = liftM2 (,) get get + +instance (Binary a, Binary b, Binary c) => Binary (a,b,c) where + put (a,b,c) = put a >> put b >> put c + get = liftM3 (,,) get get get + +instance (Binary a, Binary b, Binary c, Binary d) => Binary (a,b,c,d) where + put (a,b,c,d) = put a >> put b >> put c >> put d + get = liftM4 (,,,) get get get get + +instance (Binary a, Binary b, Binary c, Binary d, Binary e) => Binary (a,b,c,d,e) where + put (a,b,c,d,e) = put a >> put b >> put c >> put d >> put e + get = liftM5 (,,,,) get get get get get + +-- +-- and now just recurse: +-- + +instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f) + => Binary (a,b,c,d,e,f) where + put (a,b,c,d,e,f) = put (a,(b,c,d,e,f)) + get = do (a,(b,c,d,e,f)) <- get ; return (a,b,c,d,e,f) + +instance (Binary a, Binary b, Binary c, Binary d, Binary e, Binary f, Binary g) + => Binary (a,b,c,d,e,f,g) where + put (a,b,c,d,e,f,g) = put (a,(b,c,d,e,f,g)) + get = do (a,(b,c,d,e,f,g)) <- get ; return (a,b,c,d,e,f,g) + +instance (Binary a, Binary b, Binary c, Binary d, Binary e, + Binary f, Binary g, Binary h) + => Binary (a,b,c,d,e,f,g,h) where + put (a,b,c,d,e,f,g,h) = put (a,(b,c,d,e,f,g,h)) + get = do (a,(b,c,d,e,f,g,h)) <- get ; return (a,b,c,d,e,f,g,h) + +instance (Binary a, Binary b, Binary c, Binary d, Binary e, + Binary f, Binary g, Binary h, Binary i) + => Binary (a,b,c,d,e,f,g,h,i) where + put (a,b,c,d,e,f,g,h,i) = put (a,(b,c,d,e,f,g,h,i)) + get = do (a,(b,c,d,e,f,g,h,i)) <- get ; return (a,b,c,d,e,f,g,h,i) + +instance (Binary a, Binary b, Binary c, Binary d, Binary e, + Binary f, Binary g, Binary h, Binary i, Binary j) + => Binary (a,b,c,d,e,f,g,h,i,j) where + put (a,b,c,d,e,f,g,h,i,j) = put (a,(b,c,d,e,f,g,h,i,j)) + get = do (a,(b,c,d,e,f,g,h,i,j)) <- get ; return (a,b,c,d,e,f,g,h,i,j) + +------------------------------------------------------------------------ +-- Container types + +instance Binary a => Binary [a] where + put l = put (length l) >> mapM_ put l + get = do n <- get :: Get Int + getMany n + +-- | 'getMany n' get 'n' elements in order, without blowing the stack. +getMany :: Binary a => Int -> Get [a] +getMany n = go [] n + where + go xs 0 = return $! reverse xs + go xs i = do x <- get + -- we must seq x to avoid stack overflows due to laziness in + -- (>>=) + x `seq` go (x:xs) (i-1) +{-# INLINE getMany #-} + +instance (Binary a) => Binary (Maybe a) where + put Nothing = putWord8 0 + put (Just x) = putWord8 1 >> put x + get = do + w <- getWord8 + case w of + 0 -> return Nothing + _ -> liftM Just get + +instance (Binary a, Binary b) => Binary (Either a b) where + put (Left a) = putWord8 0 >> put a + put (Right b) = putWord8 1 >> put b + get = do + w <- getWord8 + case w of + 0 -> liftM Left get + _ -> liftM Right get + +------------------------------------------------------------------------ +-- ByteStrings (have specially efficient instances) + +instance Binary B.ByteString where + put bs = do put (B.length bs) + putByteString bs + get = get >>= getByteString + +-- +-- Using old versions of fps, this is a type synonym, and non portable +-- +-- Requires 'flexible instances' +-- +instance Binary ByteString where + put bs = do put (fromIntegral (L.length bs) :: Int) + putLazyByteString bs + get = get >>= getLazyByteString + +------------------------------------------------------------------------ +-- Maps and Sets + +instance (Ord a, Binary a) => Binary (Set.Set a) where + put s = put (Set.size s) >> mapM_ put (Set.toAscList s) + get = liftM Set.fromDistinctAscList get + +instance (Ord k, Binary k, Binary e) => Binary (Map.Map k e) where + put m = put (Map.size m) >> mapM_ put (Map.toAscList m) + get = liftM Map.fromDistinctAscList get + +instance Binary IntSet.IntSet where + put s = put (IntSet.size s) >> mapM_ put (IntSet.toAscList s) + get = liftM IntSet.fromDistinctAscList get + +instance (Binary e) => Binary (IntMap.IntMap e) where + put m = put (IntMap.size m) >> mapM_ put (IntMap.toAscList m) + get = liftM IntMap.fromDistinctAscList get + +------------------------------------------------------------------------ +-- Queues and Sequences + +#if __GLASGOW_HASKELL__ >= 606 +-- +-- This is valid Hugs, but you need the most recent Hugs +-- + +instance (Binary e) => Binary (Seq.Seq e) where + put s = put (Seq.length s) >> Fold.mapM_ put s + get = do n <- get :: Get Int + rep Seq.empty n get + where rep xs 0 _ = return $! xs + rep xs n g = xs `seq` n `seq` do + x <- g + rep (xs Seq.|> x) (n-1) g + +#endif + +------------------------------------------------------------------------ +-- Floating point + +instance Binary Double where + put d = put (decodeFloat d) + get = liftM2 encodeFloat get get + +instance Binary Float where + put f = put (decodeFloat f) + get = liftM2 encodeFloat get get + +------------------------------------------------------------------------ +-- Trees + +instance (Binary e) => Binary (T.Tree e) where + put (T.Node r s) = put r >> put s + get = liftM2 T.Node get get + +------------------------------------------------------------------------ +-- Arrays + +instance (Binary i, Ix i, Binary e) => Binary (Array i e) where + put a = do + put (bounds a) + put (rangeSize $ bounds a) -- write the length + mapM_ put (elems a) -- now the elems. + get = do + bs <- get + n <- get -- read the length + xs <- getMany n -- now the elems. + return (listArray bs xs) + +-- +-- The IArray UArray e constraint is non portable. Requires flexible instances +-- +instance (Binary i, Ix i, Binary e, IArray UArray e) => Binary (UArray i e) where + put a = do + put (bounds a) + put (rangeSize $ bounds a) -- now write the length + mapM_ put (elems a) + get = do + bs <- get + n <- get + xs <- getMany n + return (listArray bs xs) diff -Nru ghc-7.0.3/libraries/binary/tests/Makefile ghc-7.2.1/libraries/binary/tests/Makefile --- ghc-7.0.3/libraries/binary/tests/Makefile 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/binary/tests/Makefile 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,16 @@ +all: compiled + +interpreted: + runhaskell QC.hs 1000 + +compiled: + ghc --make -fhpc -O QC.hs -o qc -threaded -package QuickCheck-1.2.0.1 -i../src + ./qc 500 + +hugs: + runhugs -98 QC.hs + +clean: + rm -f *.o *.hi qc *.tix *~ + +.PHONY: clean diff -Nru ghc-7.0.3/libraries/binary/tests/Parallel.hs ghc-7.2.1/libraries/binary/tests/Parallel.hs --- ghc-7.0.3/libraries/binary/tests/Parallel.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/binary/tests/Parallel.hs 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,147 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Test.QuickCheck.Parallel +-- Copyright : (c) Don Stewart 2006 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : dons@cse.unsw.edu.au +-- Stability : experimental +-- Portability : non-portable (uses Control.Exception, Control.Concurrent) +-- +-- A parallel batch driver for running QuickCheck on threaded or SMP systems. +-- See the /Example.hs/ file for a complete overview. +-- + +module Parallel ( + pRun, + pDet, + pNon + ) where + +import Test.QuickCheck +import Data.List +import Control.Concurrent +import Control.Exception hiding (evaluate) +import System.Random +import System.IO (hFlush,stdout) +import Text.Printf + +type Name = String +type Depth = Int +type Test = (Name, Depth -> IO String) + +-- | Run a list of QuickCheck properties in parallel chunks, using +-- 'n' Haskell threads (first argument), and test to a depth of 'd' +-- (second argument). Compile your application with '-threaded' and run +-- with the SMP runtime's '-N4' (or however many OS threads you want to +-- donate), for best results. +-- +-- > import Test.QuickCheck.Parallel +-- > +-- > do n <- getArgs >>= readIO . head +-- > pRun n 1000 [ ("sort1", pDet prop_sort1) ] +-- +-- Will run 'n' threads over the property list, to depth 1000. +-- +pRun :: Int -> Int -> [Test] -> IO () +pRun n depth tests = do + chan <- newChan + ps <- getChanContents chan + work <- newMVar tests + + forM_ [1..n] $ forkIO . thread work chan + + let wait xs i + | i >= n = return () -- done + | otherwise = case xs of + Nothing : xs -> wait xs $! i+1 + Just s : xs -> putStr s >> hFlush stdout >> wait xs i + wait ps 0 + + where + thread :: MVar [Test] -> Chan (Maybe String) -> Int -> IO () + thread work chan me = loop + where + loop = do + job <- modifyMVar work $ \jobs -> return $ case jobs of + [] -> ([], Nothing) + (j:js) -> (js, Just j) + case job of + Nothing -> writeChan chan Nothing -- done + Just (name,prop) -> do + v <- prop depth + writeChan chan . Just $ printf "%d: %-25s: %s" me name v + loop + + +-- | Wrap a property, and run it on a deterministic set of data +pDet :: Testable a => a -> Int -> IO String +pDet a n = mycheck Det defaultConfig + { configMaxTest = n + , configEvery = \n args -> unlines args } a + +-- | Wrap a property, and run it on a non-deterministic set of data +pNon :: Testable a => a -> Int -> IO String +pNon a n = mycheck NonDet defaultConfig + { configMaxTest = n + , configEvery = \n args -> unlines args } a + +data Mode = Det | NonDet + +------------------------------------------------------------------------ + +mycheck :: Testable a => Mode -> Config -> a -> IO String +mycheck Det config a = do + let rnd = mkStdGen 99 -- deterministic + mytests config (evaluate a) rnd 0 0 [] + +mycheck NonDet config a = do + rnd <- newStdGen -- different each run + mytests config (evaluate a) rnd 0 0 [] + +mytests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO String +mytests config gen rnd0 ntest nfail stamps + | ntest == configMaxTest config = do done "OK," ntest stamps + | nfail == configMaxFail config = do done "Arguments exhausted after" ntest stamps + | otherwise = do + case ok result of + Nothing -> + mytests config gen rnd1 ntest (nfail+1) stamps + Just True -> + mytests config gen rnd1 (ntest+1) nfail (stamp result:stamps) + Just False -> + return ( "Falsifiable after " + ++ show ntest + ++ " tests:\n" + ++ unlines (arguments result) + ) + where + result = generate (configSize config ntest) rnd2 gen + (rnd1,rnd2) = split rnd0 + +done :: String -> Int -> [[String]] -> IO String +done mesg ntest stamps = + return ( mesg ++ " " ++ show ntest ++ " tests" ++ table ) + where + table = display + . map entry + . reverse + . sort + . map pairLength + . group + . sort + . filter (not . null) + $ stamps + + display [] = ".\n" + display [x] = " (" ++ x ++ ").\n" + display xs = ".\n" ++ unlines (map (++ ".") xs) + + pairLength xss@(xs:_) = (length xss, xs) + entry (n, xs) = percentage n ntest + ++ " " + ++ concat (intersperse ", " xs) + + percentage n m = show ((100 * n) `div` m) ++ "%" + +forM_ = flip mapM_ diff -Nru ghc-7.0.3/libraries/binary/tests/QC.hs ghc-7.2.1/libraries/binary/tests/QC.hs --- ghc-7.0.3/libraries/binary/tests/QC.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/binary/tests/QC.hs 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,244 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +module Main where + +import Data.Binary +import Data.Binary.Put +import Data.Binary.Get + +import Parallel + +import qualified Data.ByteString as B +import qualified Data.ByteString.Internal as B +import qualified Data.ByteString.Unsafe as B +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Internal as L +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.IntMap as IntMap +import qualified Data.IntSet as IntSet + +import Data.Array (Array) +import Data.Array.IArray +import Data.Array.Unboxed (UArray) + +import qualified Control.OldException as C (catch,evaluate) +import Control.Monad +import Foreign +import System.Environment +import System.IO +import System.IO.Unsafe + +import Test.QuickCheck hiding (test) +import QuickCheckUtils +import Text.Printf + +-- import qualified Data.Sequence as Seq + +------------------------------------------------------------------------ + +roundTrip :: (Eq a, Binary a) => a -> (L.ByteString -> L.ByteString) -> Bool +roundTrip a f = a == + {-# SCC "decode.refragment.encode" #-} decode (f (encode a)) + +roundTripWith put get x = + forAll positiveList $ \xs -> + x == runGet get (refragment xs (runPut (put x))) + +-- make sure that a test fails +errorish :: B a +errorish a = unsafePerformIO $ + C.catch (do C.evaluate a + return False) + (\_ -> return True) + +-- low level ones: + +prop_Word16be = roundTripWith putWord16be getWord16be +prop_Word16le = roundTripWith putWord16le getWord16le +prop_Word16host = roundTripWith putWord16host getWord16host + +prop_Word32be = roundTripWith putWord32be getWord32be +prop_Word32le = roundTripWith putWord32le getWord32le +prop_Word32host = roundTripWith putWord32host getWord32host + +prop_Word64be = roundTripWith putWord64be getWord64be +prop_Word64le = roundTripWith putWord64le getWord64le +prop_Word64host = roundTripWith putWord64host getWord64host + +prop_Wordhost = roundTripWith putWordhost getWordhost + +-- read too much: + +prop_bookworm x = errorish $ x == a && x /= b + where + (a,b) = decode (encode x) + +-- sanity: + +invariant_lbs :: L.ByteString -> Bool +invariant_lbs (L.Empty) = True +invariant_lbs (L.Chunk x xs) = not (B.null x) && invariant_lbs xs + +prop_invariant :: (Binary a) => a -> Bool +prop_invariant = invariant_lbs . encode + +-- be lazy! + +-- doesn't do fair testing of lazy put/get. +-- tons of untested cases + +-- lazyTrip :: (Binary a, Eq a) => a -> Property +-- lazyTrip a = forAll positiveList $ \xs -> +-- a == (runGet lazyGet . refragment xs . runPut . lazyPut $ a) + +-- refragment a lazy bytestring's chunks +refragment :: [Int] -> L.ByteString -> L.ByteString +refragment [] lps = lps +refragment (x:xs) lps = + let x' = fromIntegral . (+1) . abs $ x + rest = refragment xs (L.drop x' lps) in + L.append (L.fromChunks [B.concat . L.toChunks . L.take x' $ lps]) rest + +-- check identity of refragmentation +prop_refragment lps xs = lps == refragment xs lps + +-- check that refragmention still hold invariant +prop_refragment_inv lps xs = invariant_lbs $ refragment xs lps + +main :: IO () +main = do + hSetBuffering stdout NoBuffering + s <- getArgs + let x = if null s then 100 else read (head s) + pRun 2 x tests + +{- +run :: [(String, Int -> IO ())] -> IO () +run tests = do + x <- getArgs + let n = if null x then 100 else read . head $ x + mapM_ (\(s,a) -> printf "%-50s" s >> a n) tests +-} + +------------------------------------------------------------------------ + +type T a = a -> Property +type B a = a -> Bool + +p :: Testable a => a -> Int -> IO String +p = pNon + +test :: (Eq a, Binary a) => a -> Property +test a = forAll positiveList (roundTrip a . refragment) + +positiveList :: Gen [Int] +positiveList = fmap (filter (/=0) . map abs) $ arbitrary + +-- tests :: [(String, Int -> IO String)] +tests = +-- utils + [ ("refragment id", p prop_refragment ) + , ("refragment invariant", p prop_refragment_inv ) + +-- boundaries + , ("read to much", p (prop_bookworm :: B Word8 )) + +-- Primitives + , ("Word16be", p prop_Word16be) + , ("Word16le", p prop_Word16le) + , ("Word16host", p prop_Word16host) + , ("Word32be", p prop_Word32be) + , ("Word32le", p prop_Word32le) + , ("Word32host", p prop_Word32host) + , ("Word64be", p prop_Word64be) + , ("Word64le", p prop_Word64le) + , ("Word64host", p prop_Word64host) + , ("Wordhost", p prop_Wordhost) + +-- higher level ones using the Binary class + ,("()", p (test :: T () )) + ,("Bool", p (test :: T Bool )) + ,("Ordering", p (test :: T Ordering )) + + ,("Word8", p (test :: T Word8 )) + ,("Word16", p (test :: T Word16 )) + ,("Word32", p (test :: T Word32 )) + ,("Word64", p (test :: T Word64 )) + + ,("Int8", p (test :: T Int8 )) + ,("Int16", p (test :: T Int16 )) + ,("Int32", p (test :: T Int32 )) + ,("Int64", p (test :: T Int64 )) + + ,("Word", p (test :: T Word )) + ,("Int", p (test :: T Int )) + ,("Integer", p (test :: T Integer )) + + ,("Float", p (test :: T Float )) + ,("Double", p (test :: T Double )) + + ,("Char", p (test :: T Char )) + + ,("[()]", p (test :: T [()] )) + ,("[Word8]", p (test :: T [Word8] )) + ,("[Word32]", p (test :: T [Word32] )) + ,("[Word64]", p (test :: T [Word64] )) + ,("[Word]", p (test :: T [Word] )) + ,("[Int]", p (test :: T [Int] )) + ,("[Integer]", p (test :: T [Integer] )) + ,("String", p (test :: T String )) + + ,("((), ())", p (test :: T ((), ()) )) + ,("(Word8, Word32)", p (test :: T (Word8, Word32) )) + ,("(Int8, Int32)", p (test :: T (Int8, Int32) )) + ,("(Int32, [Int])", p (test :: T (Int32, [Int]) )) + + ,("Maybe Int8", p (test :: T (Maybe Int8) )) + ,("Either Int8 Int16", p (test :: T (Either Int8 Int16) )) + + ,("(Maybe Word8, Bool, [Int], Either Bool Word8)", + p (test :: T (Maybe Word8, Bool, [Int], Either Bool Word8) )) + + ,("(Int, ByteString)", p (test :: T (Int, B.ByteString) )) +-- ,("Lazy (Int, ByteString)", p (lazyTrip :: T (Int, B.ByteString) )) + ,("[(Int, ByteString)]", p (test :: T [(Int, B.ByteString)] )) +-- ,("Lazy [(Int, ByteString)]", p (lazyTrip :: T [(Int, B.ByteString)] )) + + +-- ,("Lazy IntMap", p (lazyTrip :: T IntSet.IntSet )) + ,("IntSet", p (test :: T IntSet.IntSet )) + ,("IntMap ByteString", p (test :: T (IntMap.IntMap B.ByteString) )) + + ,("B.ByteString", p (test :: T B.ByteString )) + ,("L.ByteString", p (test :: T L.ByteString )) + + ,("B.ByteString invariant", p (prop_invariant :: B B.ByteString )) + ,("[B.ByteString] invariant", p (prop_invariant :: B [B.ByteString] )) + ,("L.ByteString invariant", p (prop_invariant :: B L.ByteString )) + ,("[L.ByteString] invariant", p (prop_invariant :: B [L.ByteString] )) + ,("IntMap invariant", p (prop_invariant :: B (IntMap.IntMap B.ByteString) )) + + ,("Set Word32", p (test :: T (Set.Set Word32) )) + ,("Map Word16 Int", p (test :: T (Map.Map Word16 Int) )) + + ,("(Maybe Int64, Bool, [Int])", p (test :: T (Maybe Int64, Bool, [Int]))) + +{- +-- +-- Big tuples lack an Arbitrary instance in Hugs/QuickCheck +-- + + ,("(Maybe Word16, Bool, [Int], Either Bool Word16, Int)", + p (test :: T (Maybe Word16, Bool, [Int], Either Bool Word16, Int) )) + + ,("(Maybe Word32, Bool, [Int], Either Bool Word32, Int, Int)", p (roundTrip :: (Maybe Word32, Bool, [Int], Either Bool Word32, Int, Int) -> Bool)) + + ,("(Maybe Word64, Bool, [Int], Either Bool Word64, Int, Int, Int)", p (roundTrip :: (Maybe Word64, Bool, [Int], Either Bool Word64, Int, Int, Int) -> Bool)) +-} + +-- GHC only: +-- ,("Sequence", p (roundTrip :: Seq.Seq Int64 -> Bool)) + +-- Obsolete +-- ,("ensureLeft/Fail", mytest (shouldFail (decode L.empty :: Either ParseError Int))) + ] diff -Nru ghc-7.0.3/libraries/binary/tests/QuickCheckUtils.hs ghc-7.2.1/libraries/binary/tests/QuickCheckUtils.hs --- ghc-7.0.3/libraries/binary/tests/QuickCheckUtils.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/binary/tests/QuickCheckUtils.hs 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,258 @@ +{-# OPTIONS_GHC -fglasgow-exts #-} +-- +-- Uses multi-param type classes +-- +module QuickCheckUtils where + +import Control.Monad + +import Test.QuickCheck.Batch +import Test.QuickCheck +import Text.Show.Functions + +import qualified Data.ByteString as B +import qualified Data.ByteString.Unsafe as B +import qualified Data.ByteString.Internal as B +import qualified Data.ByteString.Lazy as L +import qualified Data.Map as Map +import qualified Data.Set as Set +import qualified Data.IntMap as IntMap +import qualified Data.IntSet as IntSet + +import qualified Control.Exception as C (evaluate) + +import Control.Monad ( liftM2 ) +import Data.Char +import Data.List +import Data.Word +import Data.Int +import System.Random +import System.IO + +-- import Control.Concurrent +import System.Mem +import System.CPUTime +import Text.Printf + +import qualified Data.ByteString as P +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Internal as L + +-- import qualified Data.Sequence as Seq + +-- Enable this to get verbose test output. Including the actual tests. +debug = False + +mytest :: Testable a => a -> Int -> IO () +mytest a n = mycheck defaultConfig + { configMaxTest=n + , configEvery= \n args -> if debug then show n ++ ":\n" ++ unlines args else [] } a + +mycheck :: Testable a => Config -> a -> IO () +mycheck config a = do + rnd <- newStdGen + performGC -- >> threadDelay 100 + t <- mytests config (evaluate a) rnd 0 0 [] 0 -- 0 + printf " %0.3f seconds\n" (t :: Double) + hFlush stdout + +time :: a -> IO (a , Double) +time a = do + start <- getCPUTime + v <- C.evaluate a + v `seq` return () + end <- getCPUTime + return (v, ( (fromIntegral (end - start)) / (10^12))) + +mytests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> Double -> IO Double +mytests config gen rnd0 ntest nfail stamps t0 + | ntest == configMaxTest config = do done "OK," ntest stamps + return t0 + + | nfail == configMaxFail config = do done "Arguments exhausted after" ntest stamps + return t0 + + | otherwise = do + (result,t1) <- time (generate (configSize config ntest) rnd2 gen) + + putStr (configEvery config ntest (arguments result)) >> hFlush stdout + case ok result of + Nothing -> + mytests config gen rnd1 ntest (nfail+1) stamps (t0 + t1) + Just True -> + mytests config gen rnd1 (ntest+1) nfail (stamp result:stamps) (t0 + t1) + Just False -> do + putStr ( "Falsifiable after " + ++ show ntest + ++ " tests:\n" + ++ unlines (arguments result) + ) >> hFlush stdout + return t0 + + where + (rnd1,rnd2) = split rnd0 + +done :: String -> Int -> [[String]] -> IO () +done mesg ntest stamps = putStr ( mesg ++ " " ++ show ntest ++ " tests" ++ table ) + where + table = display + . map entry + . reverse + . sort + . map pairLength + . group + . sort + . filter (not . null) + $ stamps + + display [] = ". " + display [x] = " (" ++ x ++ "). " + display xs = ".\n" ++ unlines (map (++ ".") xs) + + pairLength xss@(xs:_) = (length xss, xs) + entry (n, xs) = percentage n ntest + ++ " " + ++ concat (intersperse ", " xs) + + percentage n m = show ((100 * n) `div` m) ++ "%" + +------------------------------------------------------------------------ + +instance Random Word8 where + randomR = integralRandomR + random = randomR (minBound,maxBound) + +instance Random Int8 where + randomR = integralRandomR + random = randomR (minBound,maxBound) + +instance Random Word16 where + randomR = integralRandomR + random = randomR (minBound,maxBound) + +instance Random Int16 where + randomR = integralRandomR + random = randomR (minBound,maxBound) + +instance Random Word where + randomR = integralRandomR + random = randomR (minBound,maxBound) + +instance Random Word32 where + randomR = integralRandomR + random = randomR (minBound,maxBound) + +instance Random Int32 where + randomR = integralRandomR + random = randomR (minBound,maxBound) + +instance Random Word64 where + randomR = integralRandomR + random = randomR (minBound,maxBound) + +instance Random Int64 where + randomR = integralRandomR + random = randomR (minBound,maxBound) + +------------------------------------------------------------------------ + +integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g) +integralRandomR (a,b) g = case randomR (fromIntegral a :: Integer, + fromIntegral b :: Integer) g of + (x,g) -> (fromIntegral x, g) + +------------------------------------------------------------------------ + +instance Arbitrary Word8 where + arbitrary = choose (0, 2^8-1) + coarbitrary w = variant 0 + +instance Arbitrary Word16 where + arbitrary = choose (0, 2^16-1) + coarbitrary = undefined + +instance Arbitrary Word32 where +-- arbitrary = choose (0, 2^32-1) + arbitrary = choose (minBound, maxBound) + coarbitrary = undefined + +instance Arbitrary Word64 where +-- arbitrary = choose (0, 2^64-1) + arbitrary = choose (minBound, maxBound) + coarbitrary = undefined + +instance Arbitrary Int8 where +-- arbitrary = choose (0, 2^8-1) + arbitrary = choose (minBound, maxBound) + coarbitrary w = variant 0 + +instance Arbitrary Int16 where +-- arbitrary = choose (0, 2^16-1) + arbitrary = choose (minBound, maxBound) + coarbitrary = undefined + +instance Arbitrary Int32 where +-- arbitrary = choose (0, 2^32-1) + arbitrary = choose (minBound, maxBound) + coarbitrary = undefined + +instance Arbitrary Int64 where +-- arbitrary = choose (0, 2^64-1) + arbitrary = choose (minBound, maxBound) + coarbitrary = undefined + +instance Arbitrary Word where + arbitrary = choose (minBound, maxBound) + coarbitrary w = variant 0 + +------------------------------------------------------------------------ + +instance Arbitrary Char where + arbitrary = choose (maxBound, minBound) + coarbitrary = undefined + +{- +instance Arbitrary a => Arbitrary (Maybe a) where + arbitrary = oneof [ return Nothing, liftM Just arbitrary] + coarbitrary = undefined + -} + +instance Arbitrary Ordering where + arbitrary = oneof [ return LT,return GT,return EQ ] + coarbitrary = undefined + +{- +instance (Arbitrary a, Arbitrary b) => Arbitrary (Either a b) where + arbitrary = oneof [ liftM Left arbitrary, liftM Right arbitrary] + coarbitrary = undefined + -} + +instance Arbitrary IntSet.IntSet where + arbitrary = fmap IntSet.fromList arbitrary + coarbitrary = undefined + +instance (Arbitrary e) => Arbitrary (IntMap.IntMap e) where + arbitrary = fmap IntMap.fromList arbitrary + coarbitrary = undefined + +instance (Arbitrary a, Ord a) => Arbitrary (Set.Set a) where + arbitrary = fmap Set.fromList arbitrary + coarbitrary = undefined + +instance (Arbitrary a, Ord a, Arbitrary b) => Arbitrary (Map.Map a b) where + arbitrary = fmap Map.fromList arbitrary + coarbitrary = undefined + +{- +instance (Arbitrary a) => Arbitrary (Seq.Seq a) where + arbitrary = fmap Seq.fromList arbitrary + coarbitrary = undefined +-} + +instance Arbitrary L.ByteString where + arbitrary = arbitrary >>= return . L.fromChunks . filter (not. B.null) -- maintain the invariant. + coarbitrary s = coarbitrary (L.unpack s) + +instance Arbitrary B.ByteString where + arbitrary = B.pack `fmap` arbitrary + coarbitrary s = coarbitrary (B.unpack s) diff -Nru ghc-7.0.3/libraries/binary/TODO ghc-7.2.1/libraries/binary/TODO --- ghc-7.0.3/libraries/binary/TODO 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/binary/TODO 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,28 @@ +layer handling: + + bit packing + state parameters + string pools + + reading structures from the end of a stream, seek/tell behaviour + +seek based protocols are too hard. + hGetContents/ interleaving. + +user requests: + + get remaining bytestring after a runGet + + some kind of lookahead, or restoring parsing state, or something with + equal functionality. make it another layer on top? + + getLazyByteString takes an Int, which in Haskell98 is only guarantied to + be 29 bits, ie. 512 mb. + maybe we should have a readN64 for allowing reading of larger stuff? + (which could be implemented with readN on 64bit machines) + reference: bringerts tar archive decoder would be limitid to 0.5GB + files, alt. 2GB in GHC + +SYB-deriving + +investigate the UArray instance, it does not seem to compile in GHC 6.4 diff -Nru ghc-7.0.3/libraries/binary/tools/derive/BinaryDerive.hs ghc-7.2.1/libraries/binary/tools/derive/BinaryDerive.hs --- ghc-7.0.3/libraries/binary/tools/derive/BinaryDerive.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/binary/tools/derive/BinaryDerive.hs 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,57 @@ +{-# OPTIONS -fglasgow-exts #-} + +module BinaryDerive where + +import Data.Generics +import Data.List + +deriveM :: (Typeable a, Data a) => a -> IO () +deriveM (a :: a) = mapM_ putStrLn . lines $ derive (undefined :: a) + +derive :: (Typeable a, Data a) => a -> String +derive x = + "instance " ++ context ++ "Binary " ++ inst ++ " where\n" ++ + concat putDefs ++ getDefs + where + context + | nTypeChildren > 0 = + wrap (join ", " (map ("Binary "++) typeLetters)) ++ " => " + | otherwise = "" + inst = wrap $ tyConString typeName ++ concatMap (" "++) typeLetters + wrap x = if nTypeChildren > 0 then "("++x++")" else x + join sep lst = concat $ intersperse sep lst + nTypeChildren = length typeChildren + typeLetters = take nTypeChildren manyLetters + manyLetters = map (:[]) ['a'..'z'] + (typeName,typeChildren) = splitTyConApp (typeOf x) + constrs :: [(Int, (String, Int))] + constrs = zip [0..] $ map gen $ dataTypeConstrs (dataTypeOf x) + gen con = ( showConstr con + , length $ gmapQ undefined $ fromConstr con `asTypeOf` x + ) + putDefs = map ((++"\n") . putDef) constrs + putDef (n, (name, ps)) = + let wrap = if ps /= 0 then ("("++) . (++")") else id + pattern = name ++ concatMap (' ':) (take ps manyLetters) + in + " put " ++ wrap pattern ++" = " + ++ concat [ "putWord8 " ++ show n | length constrs > 1 ] + ++ concat [ " >> " | length constrs > 1 && ps > 0 ] + ++ concat [ "return ()" | length constrs == 1 && ps == 0 ] + ++ join " >> " (map ("put "++) (take ps manyLetters)) + getDefs = + (if length constrs > 1 + then " get = do\n tag_ <- getWord8\n case tag_ of\n" + else " get =") + ++ concatMap ((++"\n")) (map getDef constrs) ++ + (if length constrs > 1 + then " _ -> fail \"no parse\"" + else "" + ) + getDef (n, (name, ps)) = + let wrap = if ps /= 0 then ("("++) . (++")") else id + in + concat [ " " ++ show n ++ " ->" | length constrs > 1 ] + ++ concatMap (\x -> " get >>= \\"++x++" ->") (take ps manyLetters) + ++ " return " + ++ wrap (name ++ concatMap (" "++) (take ps manyLetters)) diff -Nru ghc-7.0.3/libraries/binary/tools/derive/Example.hs ghc-7.2.1/libraries/binary/tools/derive/Example.hs --- ghc-7.0.3/libraries/binary/tools/derive/Example.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/binary/tools/derive/Example.hs 2011-08-07 17:10:07.000000000 +0000 @@ -0,0 +1,68 @@ + +import Data.Generics + +import Data.Binary + +import BinaryDerive + +data Foo = Bar + deriving (Typeable, Data, Show, Eq) + +instance Binary Main.Foo where + put Bar = return () + get = return Bar + +data Color = RGB Int Int Int + | CMYK Int Int Int Int + deriving (Typeable, Data, Show, Eq) + +instance Binary Main.Color where + put (RGB a b c) = putWord8 0 >> put a >> put b >> put c + put (CMYK a b c d) = putWord8 1 >> put a >> put b >> put c >> put d + get = do + tag_ <- getWord8 + case tag_ of + 0 -> get >>= \a -> get >>= \b -> get >>= \c -> return (RGB a b c) + 1 -> get >>= \a -> get >>= \b -> get >>= \c -> get >>= \d -> return (CMYK a b c d) + +data Computer = Laptop { weight :: Int } + | Desktop { speed :: Int, memory :: Int } + deriving (Typeable, Data, Show, Eq) + +instance Binary Main.Computer where + put (Laptop a) = putWord8 0 >> put a + put (Desktop a b) = putWord8 1 >> put a >> put b + get = do + tag_ <- getWord8 + case tag_ of + 0 -> get >>= \a -> return (Laptop a) + 1 -> get >>= \a -> get >>= \b -> return (Desktop a b) + +-- | All drinks mankind will ever need +data Drinks = Beer Bool{-ale?-} + | Coffee + | Tea + | EnergyDrink + | Water + | Wine + | Whisky + deriving (Typeable, Data, Show, Eq) + +instance Binary Main.Drinks where + put (Beer a) = putWord8 0 >> put a + put Coffee = putWord8 1 + put Tea = putWord8 2 + put EnergyDrink = putWord8 3 + put Water = putWord8 4 + put Wine = putWord8 5 + put Whisky = putWord8 6 + get = do + tag_ <- getWord8 + case tag_ of + 0 -> get >>= \a -> return (Beer a) + 1 -> return Coffee + 2 -> return Tea + 3 -> return EnergyDrink + 4 -> return Water + 5 -> return Wine + 6 -> return Whisky diff -Nru ghc-7.0.3/libraries/bin-package-db/bin-package-db.cabal ghc-7.2.1/libraries/bin-package-db/bin-package-db.cabal --- ghc-7.0.3/libraries/bin-package-db/bin-package-db.cabal 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/libraries/bin-package-db/bin-package-db.cabal 2011-08-07 17:10:05.000000000 +0000 @@ -24,8 +24,8 @@ else build-depends: base >= 4 && < 5 - build-depends: ghc-binary == 0.5.*, - Cabal >= 1.8 && < 1.11 + build-depends: binary == 0.5.*, + Cabal >= 1.8 && < 1.14 extensions: CPP } diff -Nru ghc-7.0.3/libraries/bin-package-db/Distribution/InstalledPackageInfo/Binary.hs ghc-7.2.1/libraries/bin-package-db/Distribution/InstalledPackageInfo/Binary.hs --- ghc-7.0.3/libraries/bin-package-db/Distribution/InstalledPackageInfo/Binary.hs 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/libraries/bin-package-db/Distribution/InstalledPackageInfo/Binary.hs 2011-08-07 17:10:05.000000000 +0000 @@ -59,11 +59,13 @@ put (stability ipi) put (homepage ipi) put (pkgUrl ipi) + put (synopsis ipi) put (description ipi) put (category ipi) put (exposed ipi) put (exposedModules ipi) put (hiddenModules ipi) + put (trusted ipi) put (importDirs ipi) put (libraryDirs ipi) put (hsLibraries ipi) @@ -91,11 +93,13 @@ stability <- get homepage <- get pkgUrl <- get + synopsis <- get description <- get category <- get exposed <- get exposedModules <- get hiddenModules <- get + trusted <- get importDirs <- get libraryDirs <- get hsLibraries <- get diff -Nru ghc-7.0.3/libraries/bin-package-db/ghc.mk ghc-7.2.1/libraries/bin-package-db/ghc.mk --- ghc-7.0.3/libraries/bin-package-db/ghc.mk 2011-03-26 18:10:45.000000000 +0000 +++ ghc-7.2.1/libraries/bin-package-db/ghc.mk 2011-08-07 17:11:00.000000000 +0000 @@ -1,3 +1,4 @@ libraries/bin-package-db_PACKAGE = bin-package-db libraries/bin-package-db_dist-install_GROUP = libraries +$(if $(filter bin-package-db,$(PACKAGES_STAGE0)),$(eval $(call build-package,libraries/bin-package-db,dist-boot,0))) $(eval $(call build-package,libraries/bin-package-db,dist-install,$(if $(filter bin-package-db,$(STAGE2_PACKAGES)),2,1))) diff -Nru ghc-7.0.3/libraries/bytestring/bytestring.cabal ghc-7.2.1/libraries/bytestring/bytestring.cabal --- ghc-7.0.3/libraries/bytestring/bytestring.cabal 2011-03-26 18:10:12.000000000 +0000 +++ ghc-7.2.1/libraries/bytestring/bytestring.cabal 2011-08-07 17:10:07.000000000 +0000 @@ -1,5 +1,5 @@ Name: bytestring -Version: 0.9.1.10 +Version: 0.9.2.0 Synopsis: Fast, packed, strict and lazy byte arrays with a list interface Description: A time and space-efficient implementation of byte vectors using @@ -19,15 +19,15 @@ (c) Duncan Coutts 2006-2009, (c) David Roundy 2003-2005. Author: Don Stewart, Duncan Coutts -Maintainer: dons@galois.com, duncan@haskell.org +Maintainer: dons00@gmail.com, duncan@community.haskell.org Homepage: http://www.cse.unsw.edu.au/~dons/fps.html -Tested-With: GHC==6.12.0, GHC==6.10.4, GHC ==6.8.2, GHC==6.6.1, GHC==6.4.2 +Tested-With: GHC==7.0.2, GHC==6.12.3, GHC==6.10.4, GHC ==6.8.2 Build-Type: Simple -Cabal-Version: >= 1.2.3 +Cabal-Version: >= 1.8 extra-source-files: README TODO library - build-depends: base < 5 + build-depends: base >= 3 && < 5 if impl(ghc >= 6.10) build-depends: ghc-prim, base >= 4 @@ -56,10 +56,8 @@ ghc-options: -Wall -fno-warn-orphans -O2 -funbox-strict-fields - -fno-method-sharing -fmax-simplifier-iterations10 - if impl(ghc >= 6.6) - ghc-options: -fdicts-cheap + -fdicts-cheap c-sources: cbits/fpstring.c include-dirs: include @@ -67,6 +65,27 @@ install-includes: fpstring.h nhc98-options: -K4M -K3M - if impl(ghc <= 6.4.2) - cc-options: -DSLOW_FOREIGN_PTR +-- QC properties, with GHC RULES disabled +test-suite prop-compiled + type: exitcode-stdio-1.0 + main-is: Properties.hs + hs-source-dirs: . tests + build-depends: base, random, directory, + QuickCheck >= 2.3 && < 3 + if impl(ghc >= 6.10) + build-depends: ghc-prim + c-sources: cbits/fpstring.c + include-dirs: include + if impl(ghc >= 6.10) + ghc-options: -fno-enable-rewrite-rules + else + ghc-options: -fno-rewrite-rules + if impl(ghc) + extensions: UnliftedFFITypes, + MagicHash, + UnboxedTuples, + DeriveDataTypeable + ScopedTypeVariables + if impl(ghc >= 6.11) + extensions: NamedFieldPuns diff -Nru ghc-7.0.3/libraries/bytestring/Data/ByteString/Char8.hs ghc-7.2.1/libraries/bytestring/Data/ByteString/Char8.hs --- ghc-7.0.3/libraries/bytestring/Data/ByteString/Char8.hs 2011-03-26 18:10:12.000000000 +0000 +++ ghc-7.2.1/libraries/bytestring/Data/ByteString/Char8.hs 2011-08-07 17:10:07.000000000 +0000 @@ -208,6 +208,7 @@ hGet, -- :: Handle -> Int -> IO ByteString hGetNonBlocking, -- :: Handle -> Int -> IO ByteString hPut, -- :: Handle -> ByteString -> IO () + hPutNonBlocking, -- :: Handle -> ByteString -> IO ByteString hPutStr, -- :: Handle -> ByteString -> IO () hPutStrLn, -- :: Handle -> ByteString -> IO () @@ -236,9 +237,9 @@ ,sort,isPrefixOf,isSuffixOf,isInfixOf ,findSubstring,findSubstrings,breakSubstring,copy,group - ,getLine, getContents, putStr, putStrLn, interact - ,hGetContents, hGet, hPut, hPutStr, hPutStrLn - ,hGetLine, hGetNonBlocking + ,getLine, getContents, putStr, interact + ,hGetContents, hGet, hPut, hPutStr + ,hGetLine, hGetNonBlocking, hPutNonBlocking ,packCString,packCStringLen ,useAsCString,useAsCStringLen ) @@ -249,7 +250,7 @@ import Data.Char ( isSpace ) import qualified Data.List as List (intersperse) -import System.IO (openFile,hClose,hFileSize,IOMode(..)) +import System.IO (Handle,stdout,openFile,hClose,hFileSize,IOMode(..)) #ifndef __NHC__ import Control.Exception (bracket) #else @@ -269,7 +270,7 @@ import GHC.ST (ST(..)) #endif -#if __GLASGOW_HASKELL__ >= 608 +#if MIN_VERSION_base(3,0,0) import Data.String (IsString(..)) #endif @@ -285,7 +286,7 @@ singleton = B.singleton . c2w {-# INLINE singleton #-} -#if __GLASGOW_HASKELL__ >= 608 +#if MIN_VERSION_base(3,0,0) instance IsString ByteString where fromString = pack {-# INLINE fromString #-} @@ -544,15 +545,12 @@ {-# INLINE [1] break #-} #endif -#if __GLASGOW_HASKELL__ >= 606 --- This RULE LHS is not allowed by ghc-6.4 {-# RULES "ByteString specialise break (x==)" forall x. break ((==) x) = breakChar x "ByteString specialise break (==x)" forall x. break (==x) = breakChar x #-} -#endif -- INTERNAL: @@ -1039,3 +1037,13 @@ appendFile f txt = bracket (openFile f AppendMode) hClose (\h -> hPut h txt) + +-- | Write a ByteString to a handle, appending a newline byte +hPutStrLn :: Handle -> ByteString -> IO () +hPutStrLn h ps + | length ps < 1024 = hPut h (ps `B.snoc` 0x0a) + | otherwise = hPut h ps >> hPut h (B.singleton (0x0a)) -- don't copy + +-- | Write a ByteString to stdout, appending a newline byte +putStrLn :: ByteString -> IO () +putStrLn = hPutStrLn stdout diff -Nru ghc-7.0.3/libraries/bytestring/Data/ByteString/Internal.hs ghc-7.2.1/libraries/bytestring/Data/ByteString/Internal.hs --- ghc-7.0.3/libraries/bytestring/Data/ByteString/Internal.hs 2011-03-26 18:10:12.000000000 +0000 +++ ghc-7.2.1/libraries/bytestring/Data/ByteString/Internal.hs 2011-08-07 17:10:07.000000000 +0000 @@ -93,23 +93,21 @@ #endif #if __GLASGOW_HASKELL__ >= 611 import GHC.IO (unsafeDupablePerformIO) -#elif __GLASGOW_HASKELL__ >= 608 -import GHC.IOBase (unsafeDupablePerformIO) #else -import GHC.IOBase (unsafePerformIO) +import GHC.IOBase (unsafeDupablePerformIO) #endif #else import Data.Char (chr) import System.IO.Unsafe (unsafePerformIO) #endif -#if __GLASGOW_HASKELL__ >= 605 && !defined(SLOW_FOREIGN_PTR) +#ifdef __GLASGOW_HASKELL__ import GHC.ForeignPtr (mallocPlainForeignPtrBytes) #else import Foreign.ForeignPtr (mallocForeignPtrBytes) #endif -#if __GLASGOW_HASKELL__>=605 +#ifdef __GLASGOW_HASKELL__ import GHC.ForeignPtr (ForeignPtr(ForeignPtr)) import GHC.Base (nullAddr#) #else @@ -190,7 +188,7 @@ -- | The 0 pointer. Used to indicate the empty Bytestring. nullForeignPtr :: ForeignPtr Word8 -#if __GLASGOW_HASKELL__>=605 +#ifdef __GLASGOW_HASKELL__ nullForeignPtr = ForeignPtr nullAddr# undefined --TODO: should ForeignPtrContents be strict? #else nullForeignPtr = unsafePerformIO $ newForeignPtr_ nullPtr @@ -226,8 +224,8 @@ unsafeCreate l f = unsafeDupablePerformIO (create l f) {-# INLINE unsafeCreate #-} -#if !defined(__GLASGOW_HASKELL__) || __GLASGOW_HASKELL__ < 608 --- for Hugs +#ifndef __GLASGOW_HASKELL__ +-- for Hugs, NHC etc unsafeDupablePerformIO :: IO a -> a unsafeDupablePerformIO = unsafePerformIO #endif @@ -269,11 +267,11 @@ memcpy p' (p `plusPtr` off) (fromIntegral l') return $! (ps, res) --- | Wrapper of mallocForeignPtrBytes with faster implementation --- for GHC 6.5 builds newer than 06/06/06 +-- | Wrapper of 'mallocForeignPtrBytes' with faster implementation for GHC +-- mallocByteString :: Int -> IO (ForeignPtr a) mallocByteString l = do -#if __GLASGOW_HASKELL__ >= 605 && !defined(SLOW_FOREIGN_PTR) +#ifdef __GLASGOW_HASKELL__ mallocPlainForeignPtrBytes l #else mallocForeignPtrBytes l diff -Nru ghc-7.0.3/libraries/bytestring/Data/ByteString/Lazy/Char8.hs ghc-7.2.1/libraries/bytestring/Data/ByteString/Lazy/Char8.hs --- ghc-7.0.3/libraries/bytestring/Data/ByteString/Lazy/Char8.hs 2011-03-26 18:10:12.000000000 +0000 +++ ghc-7.2.1/libraries/bytestring/Data/ByteString/Lazy/Char8.hs 2011-08-07 17:10:07.000000000 +0000 @@ -172,6 +172,9 @@ hGet, -- :: Handle -> Int64 -> IO ByteString hGetNonBlocking, -- :: Handle -> Int64 -> IO ByteString hPut, -- :: Handle -> ByteString -> IO () + hPutNonBlocking, -- :: Handle -> ByteString -> IO ByteString + hPutStr, -- :: Handle -> ByteString -> IO () + hPutStrLn, -- :: Handle -> ByteString -> IO () ) where @@ -181,8 +184,8 @@ ,empty,null,length,tail,init,append,reverse,transpose,cycle ,concat,take,drop,splitAt,intercalate,isPrefixOf,group,inits,tails,copy ,hGetContents, hGet, hPut, getContents - ,hGetNonBlocking - ,putStr, putStrLn, interact) + ,hGetNonBlocking, hPutNonBlocking + ,putStr, hPutStr, interact) -- Functions we need to wrap. import qualified Data.ByteString.Lazy as L @@ -203,7 +206,7 @@ ,readFile,writeFile,appendFile,replicate,getContents,getLine,putStr,putStrLn ,zip,zipWith,unzip,notElem,repeat,iterate,interact,cycle) -import System.IO (hClose,openFile,IOMode(..)) +import System.IO (Handle,stdout,hClose,openFile,IOMode(..)) #ifndef __NHC__ import Control.Exception (bracket) #else @@ -854,6 +857,16 @@ (\hdl -> hPut hdl txt) +-- | Write a ByteString to a handle, appending a newline byte +-- +hPutStrLn :: Handle -> ByteString -> IO () +hPutStrLn h ps = hPut h ps >> hPut h (L.singleton 0x0a) + +-- | Write a ByteString to stdout, appending a newline byte +putStrLn :: ByteString -> IO () +putStrLn = hPutStrLn stdout + + -- --------------------------------------------------------------------- -- Internal utilities diff -Nru ghc-7.0.3/libraries/bytestring/Data/ByteString/Lazy.hs ghc-7.2.1/libraries/bytestring/Data/ByteString/Lazy.hs --- ghc-7.0.3/libraries/bytestring/Data/ByteString/Lazy.hs 2011-03-26 18:10:12.000000000 +0000 +++ ghc-7.2.1/libraries/bytestring/Data/ByteString/Lazy.hs 2011-08-07 17:10:07.000000000 +0000 @@ -190,6 +190,7 @@ hGet, -- :: Handle -> Int -> IO ByteString hGetNonBlocking, -- :: Handle -> Int -> IO ByteString hPut, -- :: Handle -> ByteString -> IO () + hPutNonBlocking, -- :: Handle -> ByteString -> IO ByteString hPutStr, -- :: Handle -> ByteString -> IO () ) where @@ -1249,7 +1250,12 @@ -- | hGetNonBlocking is similar to 'hGet', except that it will never block -- waiting for data to become available, instead it returns only whatever data --- is available. +-- is available. If there is no data available to be read, 'hGetNonBlocking' +-- returns 'empty'. +-- +-- Note: on Windows and with Haskell implementation other than GHC, this +-- function does not work correctly; it behaves identically to 'hGet'. +-- #if defined(__GLASGOW_HASKELL__) hGetNonBlocking :: Handle -> Int -> IO ByteString hGetNonBlocking = hGetNonBlockingN defaultChunkSize @@ -1285,6 +1291,23 @@ hPut :: Handle -> ByteString -> IO () hPut h cs = foldrChunks (\c rest -> S.hPut h c >> rest) (return ()) cs +-- | Similar to 'hPut' except that it will never block. Instead it returns +-- any tail that did not get written. This tail may be 'empty' in the case that +-- the whole string was written, or the whole original string if nothing was +-- written. Partial writes are also possible. +-- +-- Note: on Windows and with Haskell implementation other than GHC, this +-- function does not work correctly; it behaves identically to 'hPut'. +-- +hPutNonBlocking :: Handle -> ByteString -> IO ByteString +hPutNonBlocking _ Empty = return Empty +hPutNonBlocking h bs@(Chunk c cs) = do + c' <- S.hPutNonBlocking h c + case S.length c' of + l' | l' == S.length c -> hPutNonBlocking h cs + 0 -> return bs + _ -> return (Chunk c' cs) + -- | A synonym for @hPut@, for compatibility -- hPutStr :: Handle -> ByteString -> IO () @@ -1299,6 +1322,10 @@ putStrLn :: ByteString -> IO () putStrLn ps = hPut stdout ps >> hPut stdout (singleton 0x0a) +{-# DEPRECATED putStrLn + "Use Data.ByteString.Lazy.Char8.putStrLn instead. (Functions that rely on ASCII encodings belong in Data.ByteString.Lazy.Char8)" + #-} + -- | The interact function takes a function of type @ByteString -> ByteString@ -- as its argument. The entire input from the standard input device is passed -- to this function as its argument, and the resulting string is output on the diff -Nru ghc-7.0.3/libraries/bytestring/Data/ByteString.hs ghc-7.2.1/libraries/bytestring/Data/ByteString.hs --- ghc-7.0.3/libraries/bytestring/Data/ByteString.hs 2011-03-26 18:10:12.000000000 +0000 +++ ghc-7.2.1/libraries/bytestring/Data/ByteString.hs 2011-08-07 17:10:07.000000000 +0000 @@ -197,6 +197,7 @@ hGetSome, -- :: Handle -> Int -> IO ByteString hGetNonBlocking, -- :: Handle -> Int -> IO ByteString hPut, -- :: Handle -> ByteString -> IO () + hPutNonBlocking, -- :: Handle -> ByteString -> IO ByteString hPutStr, -- :: Handle -> ByteString -> IO () hPutStrLn, -- :: Handle -> ByteString -> IO () @@ -256,7 +257,7 @@ #if defined(__GLASGOW_HASKELL__) -import System.IO (hGetBufNonBlocking) +import System.IO (hGetBufNonBlocking, hPutBufNonBlocking) #if MIN_VERSION_base(4,3,0) import System.IO (hGetBufSome) @@ -270,7 +271,7 @@ import GHC.IO.Handle.Types import GHC.IO.Buffer import GHC.IO.BufferedIO as Buffered -import GHC.IO hiding (finally) +import GHC.IO (stToIO, unsafePerformIO) import Data.Char (ord) import Foreign.Marshal.Utils (copyBytes) #else @@ -989,15 +990,12 @@ {-# INLINE [1] break #-} #endif -#if __GLASGOW_HASKELL__ >= 606 --- This RULE LHS is not allowed by ghc-6.4 {-# RULES "ByteString specialise break (x==)" forall x. break ((==) x) = breakByte x "ByteString specialise break (==x)" forall x. break (==x) = breakByte x #-} -#endif -- INTERNAL: @@ -1045,15 +1043,12 @@ else go p (i+1) {-# INLINE spanByte #-} -#if __GLASGOW_HASKELL__ >= 606 --- This RULE LHS is not allowed by ghc-6.4 {-# RULES "ByteString specialise span (x==)" forall x. span ((==) x) = spanByte x "ByteString specialise span (==x)" forall x. span (==x) = spanByte x #-} -#endif -- | 'spanEnd' behaves like 'span' but from the end of the 'ByteString'. -- We have @@ -1901,6 +1896,24 @@ hPut _ (PS _ _ 0) = return () hPut h (PS ps s l) = withForeignPtr ps $ \p-> hPutBuf h (p `plusPtr` s) l +-- | Similar to 'hPut' except that it will never block. Instead it returns +-- any tail that did not get written. This tail may be 'empty' in the case that +-- the whole string was written, or the whole original string if nothing was +-- written. Partial writes are also possible. +-- +-- Note: on Windows and with Haskell implementation other than GHC, this +-- function does not work correctly; it behaves identically to 'hPut'. +-- +#if defined(__GLASGOW_HASKELL__) +hPutNonBlocking :: Handle -> ByteString -> IO ByteString +hPutNonBlocking h bs@(PS ps s l) = do + bytesWritten <- withForeignPtr ps $ \p-> hPutBufNonBlocking h (p `plusPtr` s) l + return $! drop bytesWritten bs +#else +hPutNonBlocking :: Handle -> B.ByteString -> IO Int +hPutNonBlocking h bs = hPut h bs >> return empty +#endif + -- | A synonym for @hPut@, for compatibility hPutStr :: Handle -> ByteString -> IO () hPutStr = hPut @@ -1919,6 +1932,13 @@ putStrLn :: ByteString -> IO () putStrLn = hPutStrLn stdout +{-# DEPRECATED hPutStrLn + "Use Data.ByteString.Char8.hPutStrLn instead. (Functions that rely on ASCII encodings belong in Data.ByteString.Char8)" + #-} +{-# DEPRECATED putStrLn + "Use Data.ByteString.Char8.putStrLn instead. (Functions that rely on ASCII encodings belong in Data.ByteString.Char8)" + #-} + ------------------------------------------------------------------------ -- Low level IO @@ -1939,9 +1959,13 @@ | i == 0 = return empty | otherwise = illegalBufferSize h "hGet" i --- | hGetNonBlocking is identical to 'hGet', except that it will never --- block waiting for data to become available. If there is no data --- available to be read, 'hGetNonBlocking' returns 'null'. +-- | hGetNonBlocking is similar to 'hGet', except that it will never block +-- waiting for data to become available, instead it returns only whatever data +-- is available. If there is no data available to be read, 'hGetNonBlocking' +-- returns 'empty'. +-- +-- Note: on Windows and with Haskell implementation other than GHC, this +-- function does not work correctly; it behaves identically to 'hGet'. -- hGetNonBlocking :: Handle -> Int -> IO ByteString #if defined(__GLASGOW_HASKELL__) diff -Nru ghc-7.0.3/libraries/bytestring/ghc.mk ghc-7.2.1/libraries/bytestring/ghc.mk --- ghc-7.0.3/libraries/bytestring/ghc.mk 2011-03-26 18:10:45.000000000 +0000 +++ ghc-7.2.1/libraries/bytestring/ghc.mk 2011-08-07 17:11:00.000000000 +0000 @@ -1,3 +1,4 @@ libraries/bytestring_PACKAGE = bytestring libraries/bytestring_dist-install_GROUP = libraries +$(if $(filter bytestring,$(PACKAGES_STAGE0)),$(eval $(call build-package,libraries/bytestring,dist-boot,0))) $(eval $(call build-package,libraries/bytestring,dist-install,$(if $(filter bytestring,$(STAGE2_PACKAGES)),2,1))) diff -Nru ghc-7.0.3/libraries/bytestring/tests/Properties.hs ghc-7.2.1/libraries/bytestring/tests/Properties.hs --- ghc-7.0.3/libraries/bytestring/tests/Properties.hs 2011-03-26 18:10:12.000000000 +0000 +++ ghc-7.2.1/libraries/bytestring/tests/Properties.hs 2011-08-07 17:10:07.000000000 +0000 @@ -72,7 +72,8 @@ prop_anyCC = D.any `eq2` C.any prop_appendCC = D.append `eq2` C.append prop_breakCC = D.break `eq2` C.break -prop_concatMapCC = D.concatMap `eq2` C.concatMap +prop_concatMapCC = adjustSize (min 50) $ + D.concatMap `eq2` C.concatMap prop_consCC = D.cons `eq2` C.cons prop_unconsCC = D.uncons `eq1` C.uncons prop_countCC = D.count `eq2` C.count @@ -84,7 +85,8 @@ prop_findIndicesCC = D.findIndices `eq2` C.findIndices prop_isPrefixOfCC = D.isPrefixOf `eq2` C.isPrefixOf prop_mapCC = D.map `eq2` C.map -prop_replicateCC = D.replicate `eq2` C.replicate +prop_replicateCC = forAll arbitrarySizedIntegral $ + D.replicate `eq2` C.replicate prop_snocCC = D.snoc `eq2` C.snoc prop_spanCC = D.span `eq2` C.span prop_splitCC = D.split `eq2` C.split @@ -138,7 +140,8 @@ -- ByteString.Lazy <=> ByteString -- -prop_concatBP = L.concat `eq1` P.concat +prop_concatBP = adjustSize (`div` 2) $ + L.concat `eq1` P.concat prop_nullBP = L.null `eq1` P.null prop_reverseBP = L.reverse `eq1` P.reverse @@ -150,7 +153,8 @@ prop_anyBP = L.any `eq2` P.any prop_appendBP = L.append `eq2` P.append prop_breakBP = L.break `eq2` P.break -prop_concatMapBP = L.concatMap `eq2` P.concatMap +prop_concatMapBP = adjustSize (`div` 4) $ + L.concatMap `eq2` P.concatMap prop_consBP = L.cons `eq2` P.cons prop_consBP' = L.cons' `eq2` P.cons prop_consLP' = LC.cons' `eq2` P.cons @@ -164,7 +168,8 @@ prop_findIndicesBP = L.findIndices `eq2` P.findIndices prop_isPrefixOfBP = L.isPrefixOf `eq2` P.isPrefixOf prop_mapBP = L.map `eq2` P.map -prop_replicateBP = L.replicate `eq2` P.replicate +prop_replicateBP = forAll arbitrarySizedIntegral $ + L.replicate `eq2` P.replicate prop_snocBP = L.snoc `eq2` P.snoc prop_spanBP = L.span `eq2` P.span prop_splitBP = L.split `eq2` P.split @@ -221,36 +226,51 @@ (L.mapAccumL :: (X -> W -> (X,W)) -> X -> B -> (X, B)) (P.mapAccumL :: (X -> W -> (X,W)) -> X -> P -> (X, P)) -prop_unfoldrBP = eq3 +prop_unfoldrBP = + forAll arbitrarySizedIntegral $ + eq3 ((\n f a -> L.take (fromIntegral n) $ L.unfoldr f a) :: Int -> (X -> Maybe (W,X)) -> X -> B) ((\n f a -> fst $ P.unfoldrN n f a) :: Int -> (X -> Maybe (W,X)) -> X -> P) -prop_unfoldr2BP = eq2 +prop_unfoldr2BP = + forAll arbitrarySizedIntegral $ \n -> + forAll arbitrarySizedIntegral $ \a -> + eq2 ((\n a -> P.take (n*100) $ P.unfoldr (\x -> if x <= (n*100) then Just (fromIntegral x, x + 1) else Nothing) a) :: Int -> Int -> P) ((\n a -> fst $ P.unfoldrN (n*100) (\x -> if x <= (n*100) then Just (fromIntegral x, x + 1) else Nothing) a) :: Int -> Int -> P) + n a -prop_unfoldr2CP = eq2 +prop_unfoldr2CP = + forAll arbitrarySizedIntegral $ \n -> + forAll arbitrarySizedIntegral $ \a -> + eq2 ((\n a -> C.take (n*100) $ C.unfoldr (\x -> if x <= (n*100) then Just (chr (x `mod` 256), x + 1) else Nothing) a) :: Int -> Int -> P) ((\n a -> fst $ C.unfoldrN (n*100) (\x -> if x <= (n*100) then Just (chr (x `mod` 256), x + 1) else Nothing) a) :: Int -> Int -> P) + n a -prop_unfoldrLC = eq3 +prop_unfoldrLC = + forAll arbitrarySizedIntegral $ + eq3 ((\n f a -> LC.take (fromIntegral n) $ LC.unfoldr f a) :: Int -> (X -> Maybe (Char,X)) -> X -> B) ((\n f a -> fst $ C.unfoldrN n f a) :: Int -> (X -> Maybe (Char,X)) -> X -> P) -prop_cycleLC a = not (LC.null a) ==> eq1 +prop_cycleLC a = + not (LC.null a) ==> + forAll arbitrarySizedIntegral $ + eq1 ((\n -> LC.take (fromIntegral n) $ LC.cycle a ) :: Int -> B) @@ -260,31 +280,41 @@ ) :: Int -> B) -prop_iterateLC = eq3 +prop_iterateLC = + forAll arbitrarySizedIntegral $ + eq3 ((\n f a -> LC.take (fromIntegral n) $ LC.iterate f a) :: Int -> (Char -> Char) -> Char -> B) ((\n f a -> fst $ C.unfoldrN n (\a -> Just (f a, f a)) a) :: Int -> (Char -> Char) -> Char -> P) -prop_iterateLC_2 = eq3 +prop_iterateLC_2 = + forAll arbitrarySizedIntegral $ + eq3 ((\n f a -> LC.take (fromIntegral n) $ LC.iterate f a) :: Int -> (Char -> Char) -> Char -> B) ((\n f a -> LC.take (fromIntegral n) $ LC.unfoldr (\a -> Just (f a, f a)) a) :: Int -> (Char -> Char) -> Char -> B) -prop_iterateL = eq3 +prop_iterateL = + forAll arbitrarySizedIntegral $ + eq3 ((\n f a -> L.take (fromIntegral n) $ L.iterate f a) :: Int -> (W -> W) -> W -> B) ((\n f a -> fst $ P.unfoldrN n (\a -> Just (f a, f a)) a) :: Int -> (W -> W) -> W -> P) -prop_repeatLC = eq2 +prop_repeatLC = + forAll arbitrarySizedIntegral $ + eq2 ((\n a -> LC.take (fromIntegral n) $ LC.repeat a) :: Int -> Char -> B) ((\n a -> fst $ C.unfoldrN n (\a -> Just (a, a)) a) :: Int -> Char -> P) -prop_repeatL = eq2 +prop_repeatL = + forAll arbitrarySizedIntegral $ + eq2 ((\n a -> L.take (fromIntegral n) $ L.repeat a) :: Int -> W -> B) ((\n a -> fst $ @@ -294,7 +324,8 @@ -- properties comparing ByteString.Lazy `eq1` List -- -prop_concatBL = L.concat `eq1` (concat :: [[W]] -> [W]) +prop_concatBL = adjustSize (`div` 2) $ + L.concat `eq1` (concat :: [[W]] -> [W]) prop_lengthBL = L.length `eq1` (length :: [W] -> Int) prop_nullBL = L.null `eq1` (null :: [W] -> Bool) prop_reverseBL = L.reverse `eq1` (reverse :: [W] -> [W]) @@ -306,7 +337,8 @@ prop_anyBL = L.any `eq2` (any :: (W -> Bool) -> [W] -> Bool) prop_appendBL = L.append `eq2` ((++) :: [W] -> [W] -> [W]) prop_breakBL = L.break `eq2` (break :: (W -> Bool) -> [W] -> ([W],[W])) -prop_concatMapBL = L.concatMap `eq2` (concatMap :: (W -> [W]) -> [W] -> [W]) +prop_concatMapBL = adjustSize (`div` 2) $ + L.concatMap `eq2` (concatMap :: (W -> [W]) -> [W] -> [W]) prop_consBL = L.cons `eq2` ((:) :: W -> [W] -> [W]) prop_dropBL = L.drop `eq2` (drop :: Int -> [W] -> [W]) prop_dropWhileBL = L.dropWhile `eq2` (dropWhile :: (W -> Bool) -> [W] -> [W]) @@ -316,7 +348,8 @@ prop_findIndexBL = L.findIndex `eq2` (findIndex :: (W -> Bool) -> [W] -> Maybe Int) prop_isPrefixOfBL = L.isPrefixOf `eq2` (isPrefixOf:: [W] -> [W] -> Bool) prop_mapBL = L.map `eq2` (map :: (W -> W) -> [W] -> [W]) -prop_replicateBL = L.replicate `eq2` (replicate :: Int -> W -> [W]) +prop_replicateBL = forAll arbitrarySizedIntegral $ + L.replicate `eq2` (replicate :: Int -> W -> [W]) prop_snocBL = L.snoc `eq2` ((\xs x -> xs ++ [x]) :: [W] -> W -> [W]) prop_spanBL = L.span `eq2` (span :: (W -> Bool) -> [W] -> ([W],[W])) prop_splitAtBL = L.splitAt `eq2` (splitAt :: Int -> [W] -> ([W],[W])) @@ -369,7 +402,9 @@ (C.mapAccumR :: (X -> Char -> (X,Char)) -> X -> P -> (X, P)) ( mapAccumR :: (X -> Char -> (X,Char)) -> X -> [Char] -> (X, [Char])) -prop_unfoldrBL = eq3 +prop_unfoldrBL = + forAll arbitrarySizedIntegral $ + eq3 ((\n f a -> L.take (fromIntegral n) $ L.unfoldr f a) :: Int -> (X -> Maybe (W,X)) -> X -> B) ((\n f a -> take n $ @@ -386,12 +421,14 @@ prop_groupPL = P.group `eq1` (group :: [W] -> [[W]]) prop_initsPL = P.inits `eq1` (inits :: [W] -> [[W]]) prop_tailsPL = P.tails `eq1` (tails :: [W] -> [[W]]) -prop_concatPL = P.concat `eq1` (concat :: [[W]] -> [W]) +prop_concatPL = adjustSize (`div` 2) $ + P.concat `eq1` (concat :: [[W]] -> [W]) prop_allPL = P.all `eq2` (all :: (W -> Bool) -> [W] -> Bool) prop_anyPL = P.any `eq2` (any :: (W -> Bool) -> [W] -> Bool) prop_appendPL = P.append `eq2` ((++) :: [W] -> [W] -> [W]) prop_breakPL = P.break `eq2` (break :: (W -> Bool) -> [W] -> ([W],[W])) -prop_concatMapPL = P.concatMap `eq2` (concatMap :: (W -> [W]) -> [W] -> [W]) +prop_concatMapPL = adjustSize (`div` 2) $ + P.concatMap `eq2` (concatMap :: (W -> [W]) -> [W] -> [W]) prop_consPL = P.cons `eq2` ((:) :: W -> [W] -> [W]) prop_dropPL = P.drop `eq2` (drop :: Int -> [W] -> [W]) prop_dropWhilePL = P.dropWhile `eq2` (dropWhile :: (W -> Bool) -> [W] -> [W]) @@ -410,9 +447,10 @@ prop_findPL = P.find `eq2` (find :: (W -> Bool) -> [W] -> Maybe W) prop_findIndexPL = P.findIndex `eq2` (findIndex :: (W -> Bool) -> [W] -> Maybe Int) prop_isPrefixOfPL = P.isPrefixOf`eq2` (isPrefixOf:: [W] -> [W] -> Bool) -prop_isInfixOfPL = P.isInfixOf`eq2` (isInfixOf:: [W] -> [W] -> Bool) +prop_isInfixOfPL = P.isInfixOf `eq2` (isInfixOf:: [W] -> [W] -> Bool) prop_mapPL = P.map `eq2` (map :: (W -> W) -> [W] -> [W]) -prop_replicatePL = P.replicate `eq2` (replicate :: Int -> W -> [W]) +prop_replicatePL = forAll arbitrarySizedIntegral $ + P.replicate `eq2` (replicate :: Int -> W -> [W]) prop_snocPL = P.snoc `eq2` ((\xs x -> xs ++ [x]) :: [W] -> W -> [W]) prop_spanPL = P.span `eq2` (span :: (W -> Bool) -> [W] -> ([W],[W])) prop_splitAtPL = P.splitAt `eq2` (splitAt :: Int -> [W] -> ([W],[W])) @@ -478,7 +516,9 @@ prop_mapAccumRPL= eq3 (P.mapAccumR :: (X -> W -> (X,W)) -> X -> P -> (X, P)) ( mapAccumR :: (X -> W -> (X,W)) -> X -> [W] -> (X, [W])) -prop_unfoldrPL = eq3 +prop_unfoldrPL = + forAll arbitrarySizedIntegral $ + eq3 ((\n f a -> fst $ P.unfoldrN n f a) :: Int -> (X -> Maybe (W,X)) -> X -> P) ((\n f a -> take n $ @@ -605,7 +645,8 @@ prop_concat1 xs = (concat [xs,xs]) == (unpack $ L.concat [pack xs, pack xs]) prop_concat2 xs = (concat [xs,[]]) == (unpack $ L.concat [pack xs, pack []]) -prop_concat3 xss = L.concat (map pack xss) == pack (concat xss) +prop_concat3 xss = adjustSize (`div` 2) $ + L.concat (map pack xss) == pack (concat xss) prop_concatMap xs = L.concatMap L.singleton xs == (pack . concatMap (:[]) . unpack) xs @@ -615,15 +656,16 @@ prop_maximum xs = (not (null xs)) ==> (maximum xs) == (L.maximum ( pack xs )) prop_minimum xs = (not (null xs)) ==> (minimum xs) == (L.minimum ( pack xs )) -prop_replicate1 n c = - (n >= 0) ==> unpack (L.replicate (fromIntegral n) c) == replicate n c +prop_replicate1 c = + forAll arbitrarySizedIntegral $ \(Positive n) -> + unpack (L.replicate (fromIntegral n) c) == replicate n c prop_replicate2 c = unpack (L.replicate 0 c) == replicate 0 c prop_take1 i xs = L.take (fromIntegral i) (pack xs) == pack (take i xs) prop_drop1 i xs = L.drop (fromIntegral i) (pack xs) == pack (drop i xs) -prop_splitAt i xs = collect (i >= 0 && i < length xs) $ +prop_splitAt i xs = --collect (i >= 0 && i < length xs) $ L.splitAt (fromIntegral i) (pack xs) == let (a,b) = splitAt i xs in (pack a, pack b) prop_takeWhile f xs = L.takeWhile f (pack xs) == pack (takeWhile f xs) @@ -1094,10 +1136,11 @@ -- prop_linesBB' xs = (C.unpack . C.unlines' . C.lines' . C.pack) xs == (xs) -} -prop_unfoldrBB c n = - (fst $ C.unfoldrN n fn c) == (C.pack $ take n $ unfoldr fn c) - where - fn x = Just (x, chr (ord x + 1)) +prop_unfoldrBB c = + forAll arbitrarySizedIntegral $ \n -> + (fst $ C.unfoldrN n fn c) == (C.pack $ take n $ unfoldr fn c) + where + fn x = Just (x, chr (ord x + 1)) prop_prefixBB xs ys = isPrefixOf xs ys == (P.pack xs `P.isPrefixOf` P.pack ys) prop_suffixBB xs ys = isSuffixOf xs ys == (P.pack xs `P.isSuffixOf` P.pack ys) @@ -1152,8 +1195,10 @@ (x,y) | P.null y -> Nothing | otherwise -> Just (P.length x) -prop_replicate1BB n c = P.unpack (P.replicate n c) == replicate n c -prop_replicate2BB n c = P.replicate n c == fst (P.unfoldrN n (\u -> Just (u,u)) c) +prop_replicate1BB c = forAll arbitrarySizedIntegral $ \n -> + P.unpack (P.replicate n c) == replicate n c +prop_replicate2BB c = forAll arbitrarySizedIntegral $ \n -> + P.replicate n c == fst (P.unfoldrN n (\u -> Just (u,u)) c) prop_replicate3BB c = P.unpack (P.replicate 0 c) == replicate 0 c @@ -1418,7 +1463,7 @@ -- Unsafe functions -- Test unsafePackAddress -prop_unsafePackAddress x = unsafePerformIO $ do +prop_unsafePackAddress (CByteString x) = unsafePerformIO $ do let (p,_,_) = P.toForeignPtr (x `P.snoc` 0) y <- withForeignPtr p $ \(Ptr addr) -> P.unsafePackAddress addr @@ -1461,11 +1506,11 @@ | i <- [0.. n-1] ] return (and y) -prop_packCString x = unsafePerformIO $ do +prop_packCString (CByteString x) = unsafePerformIO $ do y <- P.useAsCString x $ P.unsafePackCString return (y == x) -prop_packCString_safe x = unsafePerformIO $ do +prop_packCString_safe (CByteString x) = unsafePerformIO $ do y <- P.useAsCString x $ P.packCString return (y == x) @@ -1477,7 +1522,7 @@ y <- P.useAsCStringLen x $ P.packCStringLen return (y == x && P.length y == P.length x) -prop_packMallocCString x = unsafePerformIO $ do +prop_packMallocCString (CByteString x) = unsafePerformIO $ do let (fp,_,_) = P.toForeignPtr x ptr <- mallocArray0 (P.length x) :: IO (Ptr Word8) diff -Nru ghc-7.0.3/libraries/bytestring/tests/QuickCheckUtils.hs ghc-7.2.1/libraries/bytestring/tests/QuickCheckUtils.hs --- ghc-7.0.3/libraries/bytestring/tests/QuickCheckUtils.hs 2011-03-26 18:10:12.000000000 +0000 +++ ghc-7.2.1/libraries/bytestring/tests/QuickCheckUtils.hs 2011-08-07 17:10:07.000000000 +0000 @@ -4,7 +4,6 @@ -- module QuickCheckUtils where -import Test.QuickCheck.Batch import Test.QuickCheck import Text.Show.Functions @@ -16,6 +15,7 @@ import Data.Int import System.Random import System.IO +import Foreign.C (CChar) import Data.ByteString.Fusion import qualified Data.ByteString as P @@ -25,6 +25,13 @@ import qualified Data.ByteString.Char8 as PC import qualified Data.ByteString.Lazy.Char8 as LC +------------------------------------------------------------------------ + +adjustSize :: Testable prop => (Int -> Int) -> prop -> Property +adjustSize f p = sized $ \sz -> resize (f sz) (property p) + +------------------------------------------------------------------------ + {- -- HUGS needs: @@ -53,129 +60,28 @@ -} --- Enable this to get verbose test output. Including the actual tests. -debug = False - mytest :: Testable a => a -> Int -> IO (Bool, Int) -mytest a n = mycheck defaultConfig - { configMaxTest=n - , configEvery= \n args -> if debug then show n ++ ":\n" ++ unlines args else [] } a - -mycheck :: Testable a => Config -> a -> IO (Bool, Int) -mycheck config a = - do rnd <- newStdGen - mytests config (evaluate a) rnd 0 0 [] - -{- -mytests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO () -mytests config gen rnd0 ntest nfail stamps - | ntest == configMaxTest config = do done "OK," ntest stamps - | nfail == configMaxFail config = do done "Arguments exhausted after" ntest stamps - | otherwise = - do putStr (configEvery config ntest (arguments result)) >> hFlush stdout - case ok result of - Nothing -> - mytests config gen rnd1 ntest (nfail+1) stamps - Just True -> - mytests config gen rnd1 (ntest+1) nfail (stamp result:stamps) - Just False -> - putStr ( "Falsifiable after " - ++ show ntest - ++ " tests:\n" - ++ unlines (arguments result) - ) >> hFlush stdout - where - result = generate (configSize config ntest) rnd2 gen - (rnd1,rnd2) = split rnd0 --} - -mytests :: Config -> Gen Result -> StdGen -> Int -> Int -> [[String]] -> IO (Bool, Int) -mytests config gen rnd0 ntest nfail stamps - | ntest == configMaxTest config = done "OK," ntest stamps >> return (True, ntest) - | nfail == configMaxFail config = done "Arguments exhausted after" ntest stamps >> return (True, ntest) - | otherwise = - do putStr (configEvery config ntest (arguments result)) >> hFlush stdout - case ok result of - Nothing -> - mytests config gen rnd1 ntest (nfail+1) stamps - Just True -> - mytests config gen rnd1 (ntest+1) nfail (stamp result:stamps) - Just False -> - putStr ( "Falsifiable after " - ++ show ntest - ++ " tests:\n" - ++ unlines (arguments result) - ) >> hFlush stdout >> return (False, ntest) - where - result = generate (configSize config ntest) rnd2 gen - (rnd1,rnd2) = split rnd0 - -done :: String -> Int -> [[String]] -> IO () -done mesg ntest stamps = - do putStr ( mesg ++ " " ++ show ntest ++ " tests" ++ table ) - where - table = display - . map entry - . reverse - . sort - . map pairLength - . group - . sort - . filter (not . null) - $ stamps - - display [] = ".\n" - display [x] = " (" ++ x ++ ").\n" - display xs = ".\n" ++ unlines (map (++ ".") xs) - - pairLength xss@(xs:_) = (length xss, xs) - entry (n, xs) = percentage n ntest - ++ " " - ++ concat (intersperse ", " xs) - - percentage n m = show ((100 * n) `div` m) ++ "%" +mytest p n = do + result <- quickCheckWithResult testArgs p + case result of + Success {} -> return (True, numTests result) + _ -> return (False, numTests result) + where + testArgs = stdArgs { + maxSuccess = n + --chatty = ... if we want to increase verbosity + } ------------------------------------------------------------------------ -instance Arbitrary Char where - arbitrary = choose ('\0','\255') - coarbitrary c = variant (ord c `rem` 4) - -{- -instance (Arbitrary a, Arbitrary b) => Arbitrary (PairS a b) where - arbitrary = liftM2 (:*:) arbitrary arbitrary - coarbitrary (a :*: b) = coarbitrary a . coarbitrary b --} - -instance Arbitrary Word8 where - arbitrary = choose (97, 105) - coarbitrary c = variant (fromIntegral ((fromIntegral c) `rem` 4)) - -instance Arbitrary Int64 where - arbitrary = sized $ \n -> choose (-fromIntegral n,fromIntegral n) - coarbitrary n = variant (fromIntegral (if n >= 0 then 2*n else 2*(-n) + 1)) - -{- -instance Arbitrary a => Arbitrary (MaybeS a) where - arbitrary = do a <- arbitrary ; elements [NothingS, JustS a] - coarbitrary NothingS = variant 0 - coarbitrary _ = variant 1 -- ok? --} - -{- -instance Arbitrary Char where - arbitrary = choose ('\0', '\255') -- since we have to test words, unlines too - coarbitrary c = variant (ord c `rem` 16) - -instance Arbitrary Word8 where - arbitrary = choose (minBound, maxBound) - coarbitrary c = variant (fromIntegral ((fromIntegral c) `rem` 16)) --} - instance Random Word8 where randomR = integralRandomR random = randomR (minBound,maxBound) +instance Random CChar where + randomR = integralRandomR + random = randomR (minBound,maxBound) + instance Random Int64 where randomR = integralRandomR random = randomR (minBound,maxBound) @@ -186,13 +92,33 @@ (x,g) -> (fromIntegral x, g) instance Arbitrary L.ByteString where - arbitrary = arbitrary >>= return . L.checkInvariant . L.fromChunks . filter (not. P.null) -- maintain the invariant. - coarbitrary s = coarbitrary (L.unpack s) + arbitrary = return . L.checkInvariant + . L.fromChunks + . filter (not. P.null) -- maintain the invariant. + =<< arbitrary + +instance CoArbitrary L.ByteString where + coarbitrary s = coarbitrary (L.unpack s) instance Arbitrary P.ByteString where arbitrary = P.pack `fmap` arbitrary + +instance CoArbitrary P.ByteString where coarbitrary s = coarbitrary (P.unpack s) + +newtype CByteString = CByteString P.ByteString + deriving Show + +instance Arbitrary CByteString where + arbitrary = fmap (CByteString . P.pack . map fromCChar) arbitrary + where + fromCChar :: CChar -> Word8 + fromCChar = fromIntegral + +instance Arbitrary CChar where + arbitrary = oneof [choose (-128,-1), choose (1,127)] + ------------------------------------------------------------------------ -- -- We're doing two forms of testing here. Firstly, model based testing. diff -Nru ghc-7.0.3/libraries/bytestring/TODO ghc-7.2.1/libraries/bytestring/TODO --- ghc-7.0.3/libraries/bytestring/TODO 2011-03-26 18:10:12.000000000 +0000 +++ ghc-7.2.1/libraries/bytestring/TODO 2011-08-07 17:10:07.000000000 +0000 @@ -28,21 +28,6 @@ * unchunk, Data.ByteString.Lazy -> [Data.ByteString] - and that'd work for any Lazy.ByteString, not just hGetContents >>= lines -* consider if lazy hGetContents should use non-blocking reads. This should - allow messaging style applications (eg communication over pipes, sockets) - to use lazy ByteStrings. I think that at the moment since we demand 64k - it'd just block. With a messaging style app you've got to be careful not - to demand more data than is available, hence using non-blocking read - should do the right thing. And in the disk file case it doesn't change - anything anyway, you can always get a full chunk. - -* think about lazy hGetContents and IO exceptions - -* consider dropping map' as ghc-6.5 optimises map much better so there's now - little difference between them (15% rather than 40%) and with the new fusion - system we may be able to get even closer. Look at the benchmarks for filter' - to see if we can do the same there. - * It might be nice to have a trim MutableByteArray primitive that can release the tail of an array back to the GC. This would save copying in cases where we choose to realloc to save space. This combined with GC-movable strings diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Cabal.cabal ghc-7.2.1/libraries/Cabal/cabal/Cabal.cabal --- ghc-7.0.3/libraries/Cabal/cabal/Cabal.cabal 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Cabal.cabal 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,163 @@ +Name: Cabal +Version: 1.12.0 +Copyright: 2003-2006, Isaac Jones + 2005-2011, Duncan Coutts +License: BSD3 +License-File: LICENSE +Author: Isaac Jones + Duncan Coutts +Maintainer: cabal-devel@haskell.org +Homepage: http://www.haskell.org/cabal/ +bug-reports: http://hackage.haskell.org/trac/hackage/ +Synopsis: A framework for packaging Haskell software +Description: + The Haskell Common Architecture for Building Applications and + Libraries: a framework defining a common interface for authors to more + easily build their Haskell applications in a portable way. + . + The Haskell Cabal is part of a larger infrastructure for distributing, + organizing, and cataloging Haskell libraries and tools. +Category: Distribution +cabal-version: >=1.10 +Build-Type: Custom +-- Even though we do use the default Setup.lhs it's vital to bootstrapping +-- that we build Setup.lhs using our own local Cabal source code. + +Extra-Source-Files: + README changelog + +source-repository head + type: darcs + location: http://darcs.haskell.org/cabal/ + +Flag base4 + Description: Choose the even newer, even smaller, split-up base package. + +Flag base3 + Description: Choose the new smaller, split-up base package. + +Library + build-depends: base >= 2 && < 5, + filepath >= 1 && < 1.3 + if flag(base4) { build-depends: base >= 4 } else { build-depends: base < 4 } + if flag(base3) { build-depends: base >= 3 } else { build-depends: base < 3 } + if flag(base3) + Build-Depends: directory >= 1 && < 1.2, + process >= 1 && < 1.2, + old-time >= 1 && < 1.1, + containers >= 0.1 && < 0.5, + array >= 0.1 && < 0.4, + pretty >= 1 && < 1.2 + + if !os(windows) + Build-Depends: unix >= 2.0 && < 2.6 + + ghc-options: -Wall -fno-ignore-asserts + if impl(ghc >= 6.8) + ghc-options: -fwarn-tabs + nhc98-Options: -K4M + + Exposed-Modules: + Distribution.Compiler, + Distribution.InstalledPackageInfo, + Distribution.License, + Distribution.Make, + Distribution.ModuleName, + Distribution.Package, + Distribution.PackageDescription, + Distribution.PackageDescription.Configuration, + Distribution.PackageDescription.Parse, + Distribution.PackageDescription.Check, + Distribution.PackageDescription.PrettyPrint, + Distribution.ParseUtils, + Distribution.ReadE, + Distribution.Simple, + Distribution.Simple.Build, + Distribution.Simple.Build.Macros, + Distribution.Simple.Build.PathsModule, + Distribution.Simple.BuildPaths, + Distribution.Simple.Command, + Distribution.Simple.Compiler, + Distribution.Simple.Configure, + Distribution.Simple.GHC, + Distribution.Simple.LHC, + Distribution.Simple.Haddock, + Distribution.Simple.Hpc, + Distribution.Simple.Hugs, + Distribution.Simple.Install, + Distribution.Simple.InstallDirs, + Distribution.Simple.JHC, + Distribution.Simple.LocalBuildInfo, + Distribution.Simple.NHC, + Distribution.Simple.PackageIndex, + Distribution.Simple.PreProcess, + Distribution.Simple.PreProcess.Unlit, + Distribution.Simple.Program, + Distribution.Simple.Program.Ar, + Distribution.Simple.Program.Builtin, + Distribution.Simple.Program.Db, + Distribution.Simple.Program.HcPkg, + Distribution.Simple.Program.Ld, + Distribution.Simple.Program.Run, + Distribution.Simple.Program.Script, + Distribution.Simple.Program.Types, + Distribution.Simple.Register, + Distribution.Simple.Setup, + Distribution.Simple.SrcDist, + Distribution.Simple.Test, + Distribution.Simple.UHC, + Distribution.Simple.UserHooks, + Distribution.Simple.Utils, + Distribution.System, + Distribution.TestSuite, + Distribution.Text, + Distribution.Verbosity, + Distribution.Version, + Distribution.Compat.ReadP, + Language.Haskell.Extension + + Other-Modules: + Distribution.GetOpt, + Distribution.Compat.Exception, + Distribution.Compat.CopyFile, + Distribution.Compat.TempFile, + Distribution.Simple.GHC.IPI641, + Distribution.Simple.GHC.IPI642, + Paths_Cabal + + Default-Language: Haskell98 + Default-Extensions: CPP + +test-suite unit-tests + type: exitcode-stdio-1.0 + main-is: suite.hs + other-modules: PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check, + PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check, + PackageTests.BuildDeps.InternalLibrary0.Check, + PackageTests.BuildDeps.InternalLibrary1.Check, + PackageTests.BuildDeps.InternalLibrary2.Check, + PackageTests.BuildDeps.InternalLibrary3.Check, + PackageTests.BuildDeps.InternalLibrary4.Check, + PackageTests.BuildDeps.TargetSpecificDeps1.Check, + PackageTests.BuildDeps.TargetSpecificDeps2.Check, + PackageTests.BuildDeps.TargetSpecificDeps3.Check, + PackageTests.BuildDeps.SameDepsAllRound.Check, + PackageTests.TestStanza.Check, + PackageTests.TestSuiteExeV10.Check, + PackageTests.PackageTester + hs-source-dirs: tests + build-depends: + base, + test-framework, + test-framework-quickcheck2, + test-framework-hunit, + HUnit, + QuickCheck >= 2.1.0.1, + Cabal, + process, + directory, + filepath, + extensible-exceptions, + bytestring, + unix + Default-Language: Haskell98 diff -Nru ghc-7.0.3/libraries/Cabal/cabal/changelog ghc-7.2.1/libraries/Cabal/cabal/changelog --- ghc-7.0.3/libraries/Cabal/cabal/changelog 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/changelog 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,385 @@ +-*-change-log-*- + +1.11.x (current development version) + +1.10.0.x (next stable release version) + +1.10.2.0 Duncan Coutts June 2011 + * Include test suites in cabal sdist + * Fix for conditionals in test suite stanzas in .cabal files + * Fix permissions of directories created during install + * Fix for global builds when $HOME env var is not set + +1.10.1.0 Duncan Coutts February 2011 + * Improved error messages when test suites are not enabled + * Template parameters allowed in test --test-option(s) flag + * Improved documentation of the test feature + * Relaxed QA check on cabal-version when using test-suite sections + * haddock command now allows both --hoogle and --html at the same time + * Find ghc-version-specific instances of the hsc2hs program + * Preserve file executable permissions in sdist tarballs + * Pass gcc location and flags to ./configure scripts + * Get default gcc flags from ghc + +1.10.0.0 Duncan Coutts November 2010 + * New cabal test feature + * Initial support for UHC + * New default-language and other-languages fields (e.g. Haskell98/2010) + * New default-extensions and other-extensions fields + * Deprecated extensions field (for packages using cabal-version >=1.10) + * Cabal-version field must now only be of the form ">= x.y" + * Removed deprecated --copy-prefix= feature + * Auto-reconfigure when .cabal file changes + * Workaround for haddock overwriting .hi and .o files when using TH + * Extra cpp flags used with hsc2hs and c2hs (-D${os}_BUILD_OS etc) + * New cpp define VERSION_ gives string version of dependencies + * User guide source now in markdown format for easier editing + * Improved checks and error messages for C libraries and headers + * Removed BSD4 from the list of suggested licenses + * Updated list of known language extensions + * Fix for include paths to allow C code to import FFI stub.h files + * Fix for intra-package dependencies on OSX + * Stricter checks on various bits of .cabal file syntax + * Minor fixes for c2hs + +1.8.0.6 Duncan Coutts June 2010 + * Fix 'register --global/--user' + +1.8.0.4 Duncan Coutts March 2010 + * Set dylib-install-name for dynalic libs on OSX + * Stricter configure check that compiler supports a package's extensions + * More configure-time warnings + * Hugs can compile Cabal lib again + * Default datadir now follows prefix on Windows + * Support for finding installed packages for hugs + * Cabal version macros now have proper parenthesis + * Reverted change to filter out deps of non-buildable components + * Fix for registering implace when using a specific package db + * Fix mismatch between $os and $arch path template variables + * Fix for finding ar.exe on Windows, always pick ghc's version + * Fix for intra-package dependencies with ghc-6.12 + +1.8.0.2 Duncan Coutts December 2009 + * Support for GHC-6.12 + * New unique installed package IDs which use a package hash + * Allow executables to depend on the lib within the same package + * Dependencies for each component apply only to that component + (previously applied to all the other components too) + * Added new known license MIT and versioned GPL and LGPL + * More liberal package version range syntax + * Package registration files are now UTF8 + * Support for LHC and JHC-0.7.2 + * Deprecated RecordPuns extension in favour of NamedFieldPuns + * Deprecated PatternSignatures extension in favor of ScopedTypeVariables + * New VersionRange semantic view as a sequence of intervals + * Improved package quality checks + * Minor simplification in a couple Setup.hs hooks + * Beginnings of a unit level testsuite using QuickCheck + * Various bug fixes + * Various internal cleanups + +1.6.0.2 Duncan Coutts February 2009 + * New configure-time check for C headers and libraries + * Added language extensions present in ghc-6.10 + * Added support for NamedFieldPuns extension in ghc-6.8 + * Fix in configure step for ghc-6.6 on Windows + * Fix warnings in Path_pkgname.hs module on Windows + * Fix for exotic flags in ld-options field + * Fix for using pkg-config in a package with a lib and an executable + * Fix for building haddock docs for exes that use the Paths module + * Fix for installing header files in subdirectories + * Fix for the case of building profiling libs but not ordinary libs + * Fix read-only attribute of installed files on Windows + * Ignore ghc -threaded flag when profiling in ghc-6.8 and older + +1.6.0.1 Duncan Coutts October 2008 + * Export a compat function to help alex and happy + +1.6.0.0 Duncan Coutts October 2008 + * Support for ghc-6.10 + * Source control repositories can now be specified in .cabal files + * Bug report URLs can be now specified in .cabal files + * Wildcards now allowed in data-files and extra-source-files fields + * New syntactic sugar for dependencies "build-depends: foo ==1.2.*" + * New cabal_macros.h provides macros to test versions of dependencies + * Relocatable bindists now possible on unix via env vars + * New 'exposed' field allows packages to be not exposed by default + * Install dir flags can now use $os and $arch variables + * New --builddir flag allows multiple builds from a single sources dir + * cc-options now only apply to .c files, not for -fvia-C + * cc-options are not longer propagated to dependent packages + * The cpp/cc/ld-options fields no longer use ',' as a separator + * hsc2hs is now called using gcc instead of using ghc as gcc + * New api for manipulating sets and graphs of packages + * Internal api improvements and code cleanups + * Minor improvements to the user guide + * Miscellaneous minor bug fixes + +1.4.0.2 Duncan Coutts August 2008 + * Fix executable stripping default + * Fix striping exes on OSX that export dynamic symbols (like ghc) + * Correct the order of arguments given by --prog-options= + * Fix corner case with overlapping user and global packages + * Fix for modules that use pre-processing and .hs-boot files + * Clarify some points in the user guide and readme text + * Fix verbosity flags passed to sub-command like haddock + * Fix sdist --snapshot + * Allow meta-packages that contain no modules or C code + * Make the generated Paths module -Wall clean on Windows + +1.4.0.1 Duncan Coutts June 2008 + * Fix a bug which caused '.' to always be in the sources search path + * Haddock-2.2 and later do now support the --hoogle flag + +1.4.0.0 Duncan Coutts June 2008 + * Rewritten command line handling support + * Command line completion with bash + * Better support for Haddock 2 + * Improved support for nhc98 + * Removed support for ghc-6.2 + * Haddock markup in .lhs files now supported + * Default colour scheme for highlighted source code + * Default prefix for --user installs is now $HOME/.cabal + * All .cabal files are treaded as UTF-8 and must be valid + * Many checks added for common mistakes + * New --package-db= option for specific package databases + * Many internal changes to support cabal-install + * Stricter parsing for version strings, eg dissalows "1.05" + * Improved user guide introduction + * Programatica support removed + * New options --program-prefix/suffix allows eg versioned programs + * Support packages that use .hs-boot files + * Fix sdist for Main modules that require preprocessing + * New configure -O flag with optimisation level 0--2 + * Provide access to "x-" extension fields through the Cabal api + * Added check for broken installed packages + * Added warning about using inconsistent versions of dependencies + * Strip binary executable files by default with an option to disable + * New options to add site-specific include and library search paths + * Lift the restriction that libraries must have exposed-modules + * Many bugs fixed. + * Many internal structural improvements and code cleanups + +1.2.4.0 Duncan Coutts June 2008 + * Released with GHC 6.8.3 + * Backported several fixes and minor improvements from Cabal-1.4 + * Use a default colour scheme for sources with hscolour >=1.9 + * Support --hyperlink-source for Haddock >= 2.0 + * Fix for running in a non-writable directory + * Add OSX -framework arguments when linking executables + * Updates to the user guide + * Allow build-tools names to include + and _ + * Export autoconfUserHooks and simpleUserHooks + * Export ccLdOptionsBuildInfo for Setup.hs scripts + * Export unionBuildInfo and make BuildInfo an instance of Monoid + * Fix to allow the 'main-is' module to use a pre-processor + +1.2.3.0 Duncan Coutts Nov 2007 + * Released with GHC 6.8.2 + * Includes full list of GHC language extensions + * Fix infamous "dist/conftest.c" bug + * Fix configure --interfacedir= + * Find ld.exe on Windows correctly + * Export PreProcessor constructor and mkSimplePreProcessor + * Fix minor bug in unlit code + * Fix some markup in the haddock docs + +1.2.2.0 Duncan Coutts Nov 2007 + * Released with GHC 6.8.1 + * Support haddock-2.0 + * Support building DSOs with GHC + * Require reconfiguring if the .cabal file has changed + * Fix os(windows) configuration test + * Fix building documentation + * Fix building packages on Solaris + * Other minor bug fixes + +1.2.1 Duncan Coutts Oct 2007 + * To be included in GHC 6.8.1 + * New field "cpp-options" used when preprocessing Haskell modules + * Fixes for hsc2hs when using ghc + * C source code gets compiled with -O2 by default + * OS aliases, to allow os(windows) rather than requiring os(mingw32) + * Fix cleaning of 'stub' files + * Fix cabal-setup, command line ui that replaces "runhaskell Setup.hs" + * Build docs even when dependent packages docs are missing + * Allow the --html-dir to be specified at configure time + * Fix building with ghc-6.2 + * Other minor bug fixes and build fixes + +1.2.0 Duncan Coutts Sept 2007 + * To be included in GHC 6.8.x + * New configurations feature + * Can make haddock docs link to hilighted sources (with hscolour) + * New flag to allow linking to haddock docs on the web + * Supports pkg-config + * New field "build-tools" for tool dependencies + * Improved c2hs support + * Preprocessor output no longer clutters source dirs + * Seperate "includes" and "install-includes" fields + * Makefile command to generate makefiles for building libs with GHC + * New --docdir configure flag + * Generic --with-prog --prog-args configure flags + * Better default installation paths on Windows + * Install paths can be specified relative to each other + * License files now installed + * Initial support for NHC (incomplete) + * Consistent treatment of verbosity + * Reduced verbosity of configure step by default + * Improved helpfulness of output messages + * Help output now clearer and fits in 80 columns + * New setup register --gen-pkg-config flag for distros + * Major internal refactoring, hooks api has changed + * Dozens of bug fixes + +1.1.6.2 Duncan Coutts May 2007 + * Released with GHC 6.6.1 + * Handle windows text file encoding for .cabal files + * Fix compiling a executable for profiling that uses Template Haskell + * Other minor bug fixes and user guide clarifications + +1.1.6.1 Duncan Coutts Oct 2006 + * fix unlit code + * fix escaping in register.sh + +1.1.6 Duncan Coutts Oct 2006 + * Released with GHC 6.6 + * Added support for hoogle + * Allow profiling and normal builds of libs to be chosen indepentantly + * Default installation directories on Win32 changed + * Register haddock docs with ghc-pkg + * Get haddock to make hyperlinks to dependent package docs + * Added BangPatterns language extension + * Various bug fixes + +1.1.4 Duncan Coutts May 2006 + * Released with GHC 6.4.2 + * Better support for packages that need to install header files + * cabal-setup added, but not installed by default yet + * Implemented "setup register --inplace" + * Have packages exposed by default with ghc-6.2 + * It is no longer necessary to run 'configure' before 'clean' or 'sdist' + * Added support for ghc's -split-objs + * Initial support for JHC + * Ignore extension fields in .cabal files (fields begining with "x-") + * Some changes to command hooks API to improve consistency + * Hugs support improvements + * Added GeneralisedNewtypeDeriving language extension + * Added cabal-version field + * Support hidden modules with haddock + * Internal code refactoring + * More bug fixes + +1.1.3 Isaac Jones Sept 2005 + * WARNING: Interfaces not documented in the user's guide may + change in future releases. + * Move building of GHCi .o libs to the build phase rather than + register phase. (from Duncan Coutts) + * Use .tar.gz for source package extension + * Uses GHC instead of cpphs if the latter is not available + * Added experimental "command hooks" which completely override the + default behavior of a command. + * Some bugfixes + +1.1.1 Isaac Jones July 2005 + * WARNING: Interfaces not documented in the user's guide may + change in future releases. + * Handles recursive modules for GHC 6.2 and GHC 6.4. + * Added "setup test" command (Used with UserHook) + * implemented handling of _stub.{c,h,o} files + * Added support for profiling + * Changed install prefix of libraries (pref/pkgname-version + to prefix/pkgname-version/compname-version) + * Added pattern guards as a language extension + * Moved some functionality to Language.Haskell.Extension + * Register / unregister .bat files for windows + * Exposed more of the API + * Added support for the hide-all-packages flag in GHC > 6.4 + * Several bug fixes + +1.0 Isaac Jones March 11 2005 + * Released with GHC 6.4, Hugs March 2005, and nhc98 1.18 + * Some sanity checking + +0.5 Isaac Jones Wed Feb 19 2005 + * WARNING: this is a pre-release and the interfaces are still + likely to change until we reach a 1.0 release. + * Hooks interfaces changed + * Added preprocessors to user hooks + * No more executable-modules or hidden-modules. Use + "other-modules" instead. + * Certain fields moved into BuildInfo, much refactoring + * extra-libs -> extra-libraries + * Added --gen-script to configure and unconfigure. + * modules-ghc (etc) now ghc-modules (etc) + * added new fields including "synopsis" + * Lots of bug fixes + * spaces can sometimes be used instead of commas + * A user manual has appeared (Thanks, ross!) + * for ghc 6.4, configures versionsed depends properly + * more features to ./setup haddock + +0.4 Isaac Jones Sun Jan 16 2005 + + * Much thanks to all the awesome fptools hackers who have been + working hard to build the Haskell Cabal! + + * Interface Changes: + + ** WARNING: this is a pre-release and the interfaces are still + likely to change until we reach a 1.0 release. + + ** Instead of Package.description, you should name your + description files .cabal. In particular, we suggest + that you name it .cabal, but this is not enforced + (yet). Multiple .cabal files in the same directory is an error, + at least for now. + + ** ./setup install --install-prefix is gone. Use ./setup copy + --copy-prefix instead. + + ** The "Modules" field is gone. Use "hidden-modules", + "exposed-modules", and "executable-modules". + + ** Build-depends is now a package-only field, and can't go into + executable stanzas. Build-depends is a package-to-package + relationship. + + ** Some new fields. Use the Source. + + * New Features + + ** Cabal is now included as a package in the CVS version of + fptools. That means it'll be released as "-package Cabal" in + future versions of the compilers, and if you are a bleeding-edge + user, you can grab it from the CVS repository with the compilers. + + ** Hugs compatibility and NHC98 compatibility should both be + improved. + + ** Hooks Interface / Autoconf compatibility: Most of the hooks + interface is hidden for now, because it's not finalized. I have + exposed only "defaultMainWithHooks" and "defaultUserHooks". This + allows you to use a ./configure script to preprocess + "foo.buildinfo", which gets merged with "foo.cabal". In future + releases, we'll expose UserHooks, but we're definitely going to + change the interface to those. The interface to the two functions + I've exposed should stay the same, though. + + ** ./setup haddock is a baby feature which pre-processes the + source code with hscpp and runs haddock on it. This is brand new + and hardly tested, so you get to knock it around and see what you + think. + + ** Some commands now actually implement verbosity. + + ** The preprocessors have been tested a bit more, and seem to work + OK. Please give feedback if you use these. + +0.3 Isaac Jones Sun Jan 16 2005 + * Unstable snapshot release + * From now on, stable releases are even. + +0.2 Isaac Jones + + * Adds more HUGS support and preprocessor support. diff -Nru ghc-7.0.3/libraries/Cabal/cabal/DefaultSetup.hs ghc-7.2.1/libraries/Cabal/cabal/DefaultSetup.hs --- ghc-7.0.3/libraries/Cabal/cabal/DefaultSetup.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/DefaultSetup.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/Compat/CopyFile.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/Compat/CopyFile.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/Compat/CopyFile.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/Compat/CopyFile.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,115 @@ +{-# OPTIONS -cpp #-} +-- OPTIONS required for ghc-6.4.x compat, and must appear first +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -cpp #-} +{-# OPTIONS_NHC98 -cpp #-} +{-# OPTIONS_JHC -fcpp #-} +-- #hide +module Distribution.Compat.CopyFile ( + copyFile, + copyOrdinaryFile, + copyExecutableFile, + setFileOrdinary, + setFileExecutable, + setDirOrdinary, + ) where + +#ifdef __GLASGOW_HASKELL__ + +import Control.Monad + ( when ) +import Control.Exception + ( bracket, bracketOnError ) +import Distribution.Compat.Exception + ( catchIO ) +#if __GLASGOW_HASKELL__ >= 608 +import Distribution.Compat.Exception + ( throwIOIO ) +import System.IO.Error + ( ioeSetLocation ) +#endif +import System.Directory + ( renameFile, removeFile ) +import Distribution.Compat.TempFile + ( openBinaryTempFile ) +import System.FilePath + ( takeDirectory ) +import System.IO + ( openBinaryFile, IOMode(ReadMode), hClose, hGetBuf, hPutBuf ) +import Foreign + ( allocaBytes ) +#endif /* __GLASGOW_HASKELL__ */ + +#ifndef mingw32_HOST_OS +#if __GLASGOW_HASKELL__ >= 611 +import System.Posix.Internals (withFilePath) +#else +import Foreign.C (withCString) +#endif +import System.Posix.Types + ( FileMode ) +import System.Posix.Internals + ( c_chmod ) +#if __GLASGOW_HASKELL__ >= 608 +import Foreign.C + ( throwErrnoPathIfMinus1_ ) +#else +import Foreign.C + ( throwErrnoIfMinus1_ ) +#endif +#endif /* mingw32_HOST_OS */ + +copyOrdinaryFile, copyExecutableFile :: FilePath -> FilePath -> IO () +copyOrdinaryFile src dest = copyFile src dest >> setFileOrdinary dest +copyExecutableFile src dest = copyFile src dest >> setFileExecutable dest + +setFileOrdinary, setFileExecutable, setDirOrdinary :: FilePath -> IO () +#ifndef mingw32_HOST_OS +setFileOrdinary path = setFileMode path 0o644 -- file perms -rw-r--r-- +setFileExecutable path = setFileMode path 0o755 -- file perms -rwxr-xr-x + +setFileMode :: FilePath -> FileMode -> IO () +setFileMode name m = +#if __GLASGOW_HASKELL__ >= 611 + withFilePath name $ \s -> do +#else + withCString name $ \s -> do +#endif +#if __GLASGOW_HASKELL__ >= 608 + throwErrnoPathIfMinus1_ "setFileMode" name (c_chmod s m) +#else + throwErrnoIfMinus1_ name (c_chmod s m) +#endif +#else +setFileOrdinary _ = return () +setFileExecutable _ = return () +#endif +-- This happens to be true on Unix and currently on Windows too: +setDirOrdinary = setFileExecutable + +copyFile :: FilePath -> FilePath -> IO () +#ifdef __GLASGOW_HASKELL__ +copyFile fromFPath toFPath = + copy +#if __GLASGOW_HASKELL__ >= 608 + `catchIO` (\ioe -> throwIOIO (ioeSetLocation ioe "copyFile")) +#endif + where copy = bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom -> + bracketOnError openTmp cleanTmp $ \(tmpFPath, hTmp) -> + do allocaBytes bufferSize $ copyContents hFrom hTmp + hClose hTmp + renameFile tmpFPath toFPath + openTmp = openBinaryTempFile (takeDirectory toFPath) ".copyFile.tmp" + cleanTmp (tmpFPath, hTmp) = do + hClose hTmp `catchIO` \_ -> return () + removeFile tmpFPath `catchIO` \_ -> return () + bufferSize = 4096 + + copyContents hFrom hTo buffer = do + count <- hGetBuf hFrom buffer bufferSize + when (count > 0) $ do + hPutBuf hTo buffer count + copyContents hFrom hTo buffer +#else +copyFile fromFPath toFPath = readFile fromFPath >>= writeFile toFPath +#endif diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/Compat/Exception.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/Compat/Exception.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/Compat/Exception.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/Compat/Exception.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,61 @@ +{-# OPTIONS -cpp #-} +-- OPTIONS required for ghc-6.4.x compat, and must appear first +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -cpp #-} +{-# OPTIONS_NHC98 -cpp #-} +{-# OPTIONS_JHC -fcpp #-} + +#if !(defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 610)) +#define NEW_EXCEPTION +#endif + +module Distribution.Compat.Exception ( + Exception.IOException, + onException, + catchIO, + catchExit, + throwIOIO, + tryIO, + ) where + +import System.Exit +import qualified Control.Exception as Exception + +onException :: IO a -> IO b -> IO a +#ifdef NEW_EXCEPTION +onException = Exception.onException +#else +onException io what = io `Exception.catch` \e -> do what + Exception.throw e +#endif + +throwIOIO :: Exception.IOException -> IO a +#ifdef NEW_EXCEPTION +throwIOIO = Exception.throwIO +#else +throwIOIO = Exception.throwIO . Exception.IOException +#endif + +tryIO :: IO a -> IO (Either Exception.IOException a) +#ifdef NEW_EXCEPTION +tryIO = Exception.try +#else +tryIO = Exception.tryJust Exception.ioErrors +#endif + +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +#ifdef NEW_EXCEPTION +catchIO = Exception.catch +#else +catchIO = Exception.catchJust Exception.ioErrors +#endif + +catchExit :: IO a -> (ExitCode -> IO a) -> IO a +#ifdef NEW_EXCEPTION +catchExit = Exception.catch +#else +catchExit = Exception.catchJust exitExceptions + where exitExceptions (Exception.ExitException ee) = Just ee + exitExceptions _ = Nothing +#endif + diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/Compat/ReadP.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/Compat/ReadP.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/Compat/ReadP.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/Compat/ReadP.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,470 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Compat.ReadP +-- Copyright : (c) The University of Glasgow 2002 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Portability : portable +-- +-- This is a library of parser combinators, originally written by Koen Claessen. +-- It parses all alternatives in parallel, so it never keeps hold of +-- the beginning of the input string, a common source of space leaks with +-- other parsers. The '(+++)' choice combinator is genuinely commutative; +-- it makes no difference which branch is \"shorter\". +-- +-- See also Koen's paper /Parallel Parsing Processes/ +-- (). +-- +-- This version of ReadP has been locally hacked to make it H98, by +-- Martin Sjögren +-- +----------------------------------------------------------------------------- + +module Distribution.Compat.ReadP + ( + -- * The 'ReadP' type + ReadP, -- :: * -> *; instance Functor, Monad, MonadPlus + + -- * Primitive operations + get, -- :: ReadP Char + look, -- :: ReadP String + (+++), -- :: ReadP a -> ReadP a -> ReadP a + (<++), -- :: ReadP a -> ReadP a -> ReadP a + gather, -- :: ReadP a -> ReadP (String, a) + + -- * Other operations + pfail, -- :: ReadP a + satisfy, -- :: (Char -> Bool) -> ReadP Char + char, -- :: Char -> ReadP Char + string, -- :: String -> ReadP String + munch, -- :: (Char -> Bool) -> ReadP String + munch1, -- :: (Char -> Bool) -> ReadP String + skipSpaces, -- :: ReadP () + choice, -- :: [ReadP a] -> ReadP a + count, -- :: Int -> ReadP a -> ReadP [a] + between, -- :: ReadP open -> ReadP close -> ReadP a -> ReadP a + option, -- :: a -> ReadP a -> ReadP a + optional, -- :: ReadP a -> ReadP () + many, -- :: ReadP a -> ReadP [a] + many1, -- :: ReadP a -> ReadP [a] + skipMany, -- :: ReadP a -> ReadP () + skipMany1, -- :: ReadP a -> ReadP () + sepBy, -- :: ReadP a -> ReadP sep -> ReadP [a] + sepBy1, -- :: ReadP a -> ReadP sep -> ReadP [a] + endBy, -- :: ReadP a -> ReadP sep -> ReadP [a] + endBy1, -- :: ReadP a -> ReadP sep -> ReadP [a] + chainr, -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a + chainl, -- :: ReadP a -> ReadP (a -> a -> a) -> a -> ReadP a + chainl1, -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a + chainr1, -- :: ReadP a -> ReadP (a -> a -> a) -> ReadP a + manyTill, -- :: ReadP a -> ReadP end -> ReadP [a] + + -- * Running a parser + ReadS, -- :: *; = String -> [(a,String)] + readP_to_S, -- :: ReadP a -> ReadS a + readS_to_P -- :: ReadS a -> ReadP a + + -- * Properties + -- $properties + ) + where + +import Control.Monad( MonadPlus(..), liftM2 ) +import Data.Char (isSpace) + +infixr 5 +++, <++ + +-- --------------------------------------------------------------------------- +-- The P type +-- is representation type -- should be kept abstract + +data P s a + = Get (s -> P s a) + | Look ([s] -> P s a) + | Fail + | Result a (P s a) + | Final [(a,[s])] -- invariant: list is non-empty! + +-- Monad, MonadPlus + +instance Monad (P s) where + return x = Result x Fail + + (Get f) >>= k = Get (\c -> f c >>= k) + (Look f) >>= k = Look (\s -> f s >>= k) + Fail >>= _ = Fail + (Result x p) >>= k = k x `mplus` (p >>= k) + (Final r) >>= k = final [ys' | (x,s) <- r, ys' <- run (k x) s] + + fail _ = Fail + +instance MonadPlus (P s) where + mzero = Fail + + -- most common case: two gets are combined + Get f1 `mplus` Get f2 = Get (\c -> f1 c `mplus` f2 c) + + -- results are delivered as soon as possible + Result x p `mplus` q = Result x (p `mplus` q) + p `mplus` Result x q = Result x (p `mplus` q) + + -- fail disappears + Fail `mplus` p = p + p `mplus` Fail = p + + -- two finals are combined + -- final + look becomes one look and one final (=optimization) + -- final + sthg else becomes one look and one final + Final r `mplus` Final t = Final (r ++ t) + Final r `mplus` Look f = Look (\s -> Final (r ++ run (f s) s)) + Final r `mplus` p = Look (\s -> Final (r ++ run p s)) + Look f `mplus` Final r = Look (\s -> Final (run (f s) s ++ r)) + p `mplus` Final r = Look (\s -> Final (run p s ++ r)) + + -- two looks are combined (=optimization) + -- look + sthg else floats upwards + Look f `mplus` Look g = Look (\s -> f s `mplus` g s) + Look f `mplus` p = Look (\s -> f s `mplus` p) + p `mplus` Look f = Look (\s -> p `mplus` f s) + +-- --------------------------------------------------------------------------- +-- The ReadP type + +newtype Parser r s a = R ((a -> P s r) -> P s r) +type ReadP r a = Parser r Char a + +-- Functor, Monad, MonadPlus + +instance Functor (Parser r s) where + fmap h (R f) = R (\k -> f (k . h)) + +instance Monad (Parser r s) where + return x = R (\k -> k x) + fail _ = R (\_ -> Fail) + R m >>= f = R (\k -> m (\a -> let R m' = f a in m' k)) + +--instance MonadPlus (Parser r s) where +-- mzero = pfail +-- mplus = (+++) + +-- --------------------------------------------------------------------------- +-- Operations over P + +final :: [(a,[s])] -> P s a +-- Maintains invariant for Final constructor +final [] = Fail +final r = Final r + +run :: P c a -> ([c] -> [(a, [c])]) +run (Get f) (c:s) = run (f c) s +run (Look f) s = run (f s) s +run (Result x p) s = (x,s) : run p s +run (Final r) _ = r +run _ _ = [] + +-- --------------------------------------------------------------------------- +-- Operations over ReadP + +get :: ReadP r Char +-- ^ Consumes and returns the next character. +-- Fails if there is no input left. +get = R Get + +look :: ReadP r String +-- ^ Look-ahead: returns the part of the input that is left, without +-- consuming it. +look = R Look + +pfail :: ReadP r a +-- ^ Always fails. +pfail = R (\_ -> Fail) + +(+++) :: ReadP r a -> ReadP r a -> ReadP r a +-- ^ Symmetric choice. +R f1 +++ R f2 = R (\k -> f1 k `mplus` f2 k) + +(<++) :: ReadP a a -> ReadP r a -> ReadP r a +-- ^ Local, exclusive, left-biased choice: If left parser +-- locally produces any result at all, then right parser is +-- not used. +R f <++ q = + do s <- look + probe (f return) s 0 + where + probe (Get f') (c:s) n = probe (f' c) s (n+1 :: Int) + probe (Look f') s n = probe (f' s) s n + probe p@(Result _ _) _ n = discard n >> R (p >>=) + probe (Final r) _ _ = R (Final r >>=) + probe _ _ _ = q + + discard 0 = return () + discard n = get >> discard (n-1 :: Int) + +gather :: ReadP (String -> P Char r) a -> ReadP r (String, a) +-- ^ Transforms a parser into one that does the same, but +-- in addition returns the exact characters read. +-- IMPORTANT NOTE: 'gather' gives a runtime error if its first argument +-- is built using any occurrences of readS_to_P. +gather (R m) = + R (\k -> gath id (m (\a -> return (\s -> k (s,a))))) + where + gath l (Get f) = Get (\c -> gath (l.(c:)) (f c)) + gath _ Fail = Fail + gath l (Look f) = Look (\s -> gath l (f s)) + gath l (Result k p) = k (l []) `mplus` gath l p + gath _ (Final _) = error "do not use readS_to_P in gather!" + +-- --------------------------------------------------------------------------- +-- Derived operations + +satisfy :: (Char -> Bool) -> ReadP r Char +-- ^ Consumes and returns the next character, if it satisfies the +-- specified predicate. +satisfy p = do c <- get; if p c then return c else pfail + +char :: Char -> ReadP r Char +-- ^ Parses and returns the specified character. +char c = satisfy (c ==) + +string :: String -> ReadP r String +-- ^ Parses and returns the specified string. +string this = do s <- look; scan this s + where + scan [] _ = do return this + scan (x:xs) (y:ys) | x == y = do get >> scan xs ys + scan _ _ = do pfail + +munch :: (Char -> Bool) -> ReadP r String +-- ^ Parses the first zero or more characters satisfying the predicate. +munch p = + do s <- look + scan s + where + scan (c:cs) | p c = do _ <- get; s <- scan cs; return (c:s) + scan _ = do return "" + +munch1 :: (Char -> Bool) -> ReadP r String +-- ^ Parses the first one or more characters satisfying the predicate. +munch1 p = + do c <- get + if p c then do s <- munch p; return (c:s) + else pfail + +choice :: [ReadP r a] -> ReadP r a +-- ^ Combines all parsers in the specified list. +choice [] = pfail +choice [p] = p +choice (p:ps) = p +++ choice ps + +skipSpaces :: ReadP r () +-- ^ Skips all whitespace. +skipSpaces = + do s <- look + skip s + where + skip (c:s) | isSpace c = do _ <- get; skip s + skip _ = do return () + +count :: Int -> ReadP r a -> ReadP r [a] +-- ^ @ count n p @ parses @n@ occurrences of @p@ in sequence. A list of +-- results is returned. +count n p = sequence (replicate n p) + +between :: ReadP r open -> ReadP r close -> ReadP r a -> ReadP r a +-- ^ @ between open close p @ parses @open@, followed by @p@ and finally +-- @close@. Only the value of @p@ is returned. +between open close p = do _ <- open + x <- p + _ <- close + return x + +option :: a -> ReadP r a -> ReadP r a +-- ^ @option x p@ will either parse @p@ or return @x@ without consuming +-- any input. +option x p = p +++ return x + +optional :: ReadP r a -> ReadP r () +-- ^ @optional p@ optionally parses @p@ and always returns @()@. +optional p = (p >> return ()) +++ return () + +many :: ReadP r a -> ReadP r [a] +-- ^ Parses zero or more occurrences of the given parser. +many p = return [] +++ many1 p + +many1 :: ReadP r a -> ReadP r [a] +-- ^ Parses one or more occurrences of the given parser. +many1 p = liftM2 (:) p (many p) + +skipMany :: ReadP r a -> ReadP r () +-- ^ Like 'many', but discards the result. +skipMany p = many p >> return () + +skipMany1 :: ReadP r a -> ReadP r () +-- ^ Like 'many1', but discards the result. +skipMany1 p = p >> skipMany p + +sepBy :: ReadP r a -> ReadP r sep -> ReadP r [a] +-- ^ @sepBy p sep@ parses zero or more occurrences of @p@, separated by @sep@. +-- Returns a list of values returned by @p@. +sepBy p sep = sepBy1 p sep +++ return [] + +sepBy1 :: ReadP r a -> ReadP r sep -> ReadP r [a] +-- ^ @sepBy1 p sep@ parses one or more occurrences of @p@, separated by @sep@. +-- Returns a list of values returned by @p@. +sepBy1 p sep = liftM2 (:) p (many (sep >> p)) + +endBy :: ReadP r a -> ReadP r sep -> ReadP r [a] +-- ^ @endBy p sep@ parses zero or more occurrences of @p@, separated and ended +-- by @sep@. +endBy p sep = many (do x <- p ; _ <- sep ; return x) + +endBy1 :: ReadP r a -> ReadP r sep -> ReadP r [a] +-- ^ @endBy p sep@ parses one or more occurrences of @p@, separated and ended +-- by @sep@. +endBy1 p sep = many1 (do x <- p ; _ <- sep ; return x) + +chainr :: ReadP r a -> ReadP r (a -> a -> a) -> a -> ReadP r a +-- ^ @chainr p op x@ parses zero or more occurrences of @p@, separated by @op@. +-- Returns a value produced by a /right/ associative application of all +-- functions returned by @op@. If there are no occurrences of @p@, @x@ is +-- returned. +chainr p op x = chainr1 p op +++ return x + +chainl :: ReadP r a -> ReadP r (a -> a -> a) -> a -> ReadP r a +-- ^ @chainl p op x@ parses zero or more occurrences of @p@, separated by @op@. +-- Returns a value produced by a /left/ associative application of all +-- functions returned by @op@. If there are no occurrences of @p@, @x@ is +-- returned. +chainl p op x = chainl1 p op +++ return x + +chainr1 :: ReadP r a -> ReadP r (a -> a -> a) -> ReadP r a +-- ^ Like 'chainr', but parses one or more occurrences of @p@. +chainr1 p op = scan + where scan = p >>= rest + rest x = do f <- op + y <- scan + return (f x y) + +++ return x + +chainl1 :: ReadP r a -> ReadP r (a -> a -> a) -> ReadP r a +-- ^ Like 'chainl', but parses one or more occurrences of @p@. +chainl1 p op = p >>= rest + where rest x = do f <- op + y <- p + rest (f x y) + +++ return x + +manyTill :: ReadP r a -> ReadP [a] end -> ReadP r [a] +-- ^ @manyTill p end@ parses zero or more occurrences of @p@, until @end@ +-- succeeds. Returns a list of values returned by @p@. +manyTill p end = scan + where scan = (end >> return []) <++ (liftM2 (:) p scan) + +-- --------------------------------------------------------------------------- +-- Converting between ReadP and Read + +readP_to_S :: ReadP a a -> ReadS a +-- ^ Converts a parser into a Haskell ReadS-style function. +-- This is the main way in which you can \"run\" a 'ReadP' parser: +-- the expanded type is +-- @ readP_to_S :: ReadP a -> String -> [(a,String)] @ +readP_to_S (R f) = run (f return) + +readS_to_P :: ReadS a -> ReadP r a +-- ^ Converts a Haskell ReadS-style function into a parser. +-- Warning: This introduces local backtracking in the resulting +-- parser, and therefore a possible inefficiency. +readS_to_P r = + R (\k -> Look (\s -> final [bs'' | (a,s') <- r s, bs'' <- run (k a) s'])) + +-- --------------------------------------------------------------------------- +-- QuickCheck properties that hold for the combinators + +{- $properties +The following are QuickCheck specifications of what the combinators do. +These can be seen as formal specifications of the behavior of the +combinators. + +We use bags to give semantics to the combinators. + +> type Bag a = [a] + +Equality on bags does not care about the order of elements. + +> (=~) :: Ord a => Bag a -> Bag a -> Bool +> xs =~ ys = sort xs == sort ys + +A special equality operator to avoid unresolved overloading +when testing the properties. + +> (=~.) :: Bag (Int,String) -> Bag (Int,String) -> Bool +> (=~.) = (=~) + +Here follow the properties: + +> prop_Get_Nil = +> readP_to_S get [] =~ [] +> +> prop_Get_Cons c s = +> readP_to_S get (c:s) =~ [(c,s)] +> +> prop_Look s = +> readP_to_S look s =~ [(s,s)] +> +> prop_Fail s = +> readP_to_S pfail s =~. [] +> +> prop_Return x s = +> readP_to_S (return x) s =~. [(x,s)] +> +> prop_Bind p k s = +> readP_to_S (p >>= k) s =~. +> [ ys'' +> | (x,s') <- readP_to_S p s +> , ys'' <- readP_to_S (k (x::Int)) s' +> ] +> +> prop_Plus p q s = +> readP_to_S (p +++ q) s =~. +> (readP_to_S p s ++ readP_to_S q s) +> +> prop_LeftPlus p q s = +> readP_to_S (p <++ q) s =~. +> (readP_to_S p s +<+ readP_to_S q s) +> where +> [] +<+ ys = ys +> xs +<+ _ = xs +> +> prop_Gather s = +> forAll readPWithoutReadS $ \p -> +> readP_to_S (gather p) s =~ +> [ ((pre,x::Int),s') +> | (x,s') <- readP_to_S p s +> , let pre = take (length s - length s') s +> ] +> +> prop_String_Yes this s = +> readP_to_S (string this) (this ++ s) =~ +> [(this,s)] +> +> prop_String_Maybe this s = +> readP_to_S (string this) s =~ +> [(this, drop (length this) s) | this `isPrefixOf` s] +> +> prop_Munch p s = +> readP_to_S (munch p) s =~ +> [(takeWhile p s, dropWhile p s)] +> +> prop_Munch1 p s = +> readP_to_S (munch1 p) s =~ +> [(res,s') | let (res,s') = (takeWhile p s, dropWhile p s), not (null res)] +> +> prop_Choice ps s = +> readP_to_S (choice ps) s =~. +> readP_to_S (foldr (+++) pfail ps) s +> +> prop_ReadS r s = +> readP_to_S (readS_to_P r) s =~. r s +-} + diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/Compat/TempFile.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/Compat/TempFile.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/Compat/TempFile.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/Compat/TempFile.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,204 @@ +{-# OPTIONS -cpp #-} +-- OPTIONS required for ghc-6.4.x compat, and must appear first +{-# LANGUAGE CPP #-} +{-# OPTIONS_GHC -cpp #-} +{-# OPTIONS_NHC98 -cpp #-} +{-# OPTIONS_JHC -fcpp #-} +-- #hide +module Distribution.Compat.TempFile ( + openTempFile, + openBinaryTempFile, + openNewBinaryFile, + createTempDirectory, + ) where + + +import System.FilePath (()) +import Foreign.C (eEXIST) + +#if __NHC__ || __HUGS__ +import System.IO (openFile, openBinaryFile, + Handle, IOMode(ReadWriteMode)) +import System.Directory (doesFileExist) +import System.FilePath ((<.>), splitExtension) +import System.IO.Error (try, isAlreadyExistsError) +#else +import System.IO (Handle, openTempFile, openBinaryTempFile) +import Data.Bits ((.|.)) +import System.Posix.Internals (c_open, c_close, o_CREAT, o_EXCL, o_RDWR, + o_BINARY, o_NONBLOCK, o_NOCTTY) +import System.IO.Error (isAlreadyExistsError) +#if __GLASGOW_HASKELL__ >= 611 +import System.Posix.Internals (withFilePath) +#else +import Foreign.C (withCString) +#endif +import Foreign.C (CInt) +#if __GLASGOW_HASKELL__ >= 611 +import GHC.IO.Handle.FD (fdToHandle) +#else +import GHC.Handle (fdToHandle) +#endif +import Distribution.Compat.Exception (onException, tryIO) +#endif +import Foreign.C (getErrno, errnoToIOError) + +#if __NHC__ +import System.Posix.Types (CPid(..)) +foreign import ccall unsafe "getpid" c_getpid :: IO CPid +#else +import System.Posix.Internals (c_getpid) +#endif + +#ifdef mingw32_HOST_OS +import System.Directory ( createDirectory ) +#else +import qualified System.Posix +#endif + +-- ------------------------------------------------------------ +-- * temporary files +-- ------------------------------------------------------------ + +-- This is here for Haskell implementations that do not come with +-- System.IO.openTempFile. This includes nhc-1.20, hugs-2006.9. +-- TODO: Not sure about jhc + +#if __NHC__ || __HUGS__ +-- use a temporary filename that doesn't already exist. +-- NB. *not* secure (we don't atomically lock the tmp file we get) +openTempFile :: FilePath -> String -> IO (FilePath, Handle) +openTempFile tmp_dir template + = do x <- getProcessID + findTempName x + where + (templateBase, templateExt) = splitExtension template + findTempName :: Int -> IO (FilePath, Handle) + findTempName x + = do let path = tmp_dir (templateBase ++ "-" ++ show x) <.> templateExt + b <- doesFileExist path + if b then findTempName (x+1) + else do hnd <- openFile path ReadWriteMode + return (path, hnd) + +openBinaryTempFile :: FilePath -> String -> IO (FilePath, Handle) +openBinaryTempFile tmp_dir template + = do x <- getProcessID + findTempName x + where + (templateBase, templateExt) = splitExtension template + findTempName :: Int -> IO (FilePath, Handle) + findTempName x + = do let path = tmp_dir (templateBase ++ "-" ++ show x) <.> templateExt + b <- doesFileExist path + if b then findTempName (x+1) + else do hnd <- openBinaryFile path ReadWriteMode + return (path, hnd) + +openNewBinaryFile :: FilePath -> String -> IO (FilePath, Handle) +openNewBinaryFile = openBinaryTempFile + +getProcessID :: IO Int +getProcessID = fmap fromIntegral c_getpid +#else +-- This is a copy/paste of the openBinaryTempFile definition, but +-- if uses 666 rather than 600 for the permissions. The base library +-- needs to be changed to make this better. +openNewBinaryFile :: FilePath -> String -> IO (FilePath, Handle) +openNewBinaryFile dir template = do + pid <- c_getpid + findTempName pid + where + -- We split off the last extension, so we can use .foo.ext files + -- for temporary files (hidden on Unix OSes). Unfortunately we're + -- below filepath in the hierarchy here. + (prefix,suffix) = + case break (== '.') $ reverse template of + -- First case: template contains no '.'s. Just re-reverse it. + (rev_suffix, "") -> (reverse rev_suffix, "") + -- Second case: template contains at least one '.'. Strip the + -- dot from the prefix and prepend it to the suffix (if we don't + -- do this, the unique number will get added after the '.' and + -- thus be part of the extension, which is wrong.) + (rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix) + -- Otherwise, something is wrong, because (break (== '.')) should + -- always return a pair with either the empty string or a string + -- beginning with '.' as the second component. + _ -> error "bug in System.IO.openTempFile" + + oflags = rw_flags .|. o_EXCL .|. o_BINARY + +#if __GLASGOW_HASKELL__ < 611 + withFilePath = withCString +#endif + + findTempName x = do + fd <- withFilePath filepath $ \ f -> + c_open f oflags 0o666 + if fd < 0 + then do + errno <- getErrno + if errno == eEXIST + then findTempName (x+1) + else ioError (errnoToIOError "openNewBinaryFile" errno Nothing (Just dir)) + else do + -- TODO: We want to tell fdToHandle what the filepath is, + -- as any exceptions etc will only be able to report the + -- fd currently + h <- +#if __GLASGOW_HASKELL__ >= 609 + fdToHandle fd +#elif __GLASGOW_HASKELL__ <= 606 && defined(mingw32_HOST_OS) + -- fdToHandle is borked on Windows with ghc-6.6.x + openFd (fromIntegral fd) Nothing False filepath + ReadWriteMode True +#else + fdToHandle (fromIntegral fd) +#endif + `onException` c_close fd + return (filepath, h) + where + filename = prefix ++ show x ++ suffix + filepath = dir `combine` filename + + -- FIXME: bits copied from System.FilePath + combine a b + | null b = a + | null a = b + | last a == pathSeparator = a ++ b + | otherwise = a ++ [pathSeparator] ++ b + +-- FIXME: Should use filepath library +pathSeparator :: Char +#ifdef mingw32_HOST_OS +pathSeparator = '\\' +#else +pathSeparator = '/' +#endif + +-- FIXME: Copied from GHC.Handle +std_flags, output_flags, rw_flags :: CInt +std_flags = o_NONBLOCK .|. o_NOCTTY +output_flags = std_flags .|. o_CREAT +rw_flags = output_flags .|. o_RDWR +#endif + +createTempDirectory :: FilePath -> String -> IO FilePath +createTempDirectory dir template = do + pid <- c_getpid + findTempName pid + where + findTempName x = do + let dirpath = dir template ++ "-" ++ show x + r <- tryIO $ mkPrivateDir dirpath + case r of + Right _ -> return dirpath + Left e | isAlreadyExistsError e -> findTempName (x+1) + | otherwise -> ioError e + +mkPrivateDir :: String -> IO () +#ifdef mingw32_HOST_OS +mkPrivateDir s = createDirectory s +#else +mkPrivateDir s = System.Posix.createDirectory s 0o700 +#endif diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/Compiler.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/Compiler.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/Compiler.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/Compiler.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,158 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Compiler +-- Copyright : Isaac Jones 2003-2004 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This has an enumeration of the various compilers that Cabal knows about. It +-- also specifies the default compiler. Sadly you'll often see code that does +-- case analysis on this compiler flavour enumeration like: +-- +-- > case compilerFlavor comp of +-- > GHC -> GHC.getInstalledPackages verbosity packageDb progconf +-- > JHC -> JHC.getInstalledPackages verbosity packageDb progconf +-- +-- Obviously it would be better to use the proper 'Compiler' abstraction +-- because that would keep all the compiler-specific code together. +-- Unfortunately we cannot make this change yet without breaking the +-- 'UserHooks' api, which would break all custom @Setup.hs@ files, so for the +-- moment we just have to live with this deficiency. If you're interested, see +-- ticket #50. + +{- All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.Compiler ( + -- * Compiler flavor + CompilerFlavor(..), + buildCompilerFlavor, + defaultCompilerFlavor, + parseCompilerFlavorCompat, + + -- * Compiler id + CompilerId(..), + ) where + +import Distribution.Version (Version(..)) + +import qualified System.Info (compilerName) +import Distribution.Text (Text(..), display) +import qualified Distribution.Compat.ReadP as Parse +import qualified Text.PrettyPrint as Disp +import Text.PrettyPrint ((<>)) + +import qualified Data.Char as Char (toLower, isDigit, isAlphaNum) +import Control.Monad (when) + +data CompilerFlavor = GHC | NHC | YHC | Hugs | HBC | Helium | JHC | LHC | UHC + | OtherCompiler String + deriving (Show, Read, Eq, Ord) + +knownCompilerFlavors :: [CompilerFlavor] +knownCompilerFlavors = [GHC, NHC, YHC, Hugs, HBC, Helium, JHC, LHC, UHC] + +instance Text CompilerFlavor where + disp (OtherCompiler name) = Disp.text name + disp NHC = Disp.text "nhc98" + disp other = Disp.text (lowercase (show other)) + + parse = do + comp <- Parse.munch1 Char.isAlphaNum + when (all Char.isDigit comp) Parse.pfail + return (classifyCompilerFlavor comp) + +classifyCompilerFlavor :: String -> CompilerFlavor +classifyCompilerFlavor s = + case lookup (lowercase s) compilerMap of + Just compiler -> compiler + Nothing -> OtherCompiler s + where + compilerMap = [ (display compiler, compiler) + | compiler <- knownCompilerFlavors ] + + +--TODO: In some future release, remove 'parseCompilerFlavorCompat' and use +-- ordinary 'parse'. Also add ("nhc", NHC) to the above 'compilerMap'. + +-- | Like 'classifyCompilerFlavor' but compatible with the old ReadS parser. +-- +-- It is compatible in the sense that it accepts only the same strings, +-- eg "GHC" but not "ghc". However other strings get mapped to 'OtherCompiler'. +-- The point of this is that we do not allow extra valid values that would +-- upset older Cabal versions that had a stricter parser however we cope with +-- new values more gracefully so that we'll be able to introduce new value in +-- future without breaking things so much. +-- +parseCompilerFlavorCompat :: Parse.ReadP r CompilerFlavor +parseCompilerFlavorCompat = do + comp <- Parse.munch1 Char.isAlphaNum + when (all Char.isDigit comp) Parse.pfail + case lookup comp compilerMap of + Just compiler -> return compiler + Nothing -> return (OtherCompiler comp) + where + compilerMap = [ (show compiler, compiler) + | compiler <- knownCompilerFlavors + , compiler /= YHC ] + +buildCompilerFlavor :: CompilerFlavor +buildCompilerFlavor = classifyCompilerFlavor System.Info.compilerName + +-- | The default compiler flavour to pick when compiling stuff. This defaults +-- to the compiler used to build the Cabal lib. +-- +-- However if it's not a recognised compiler then it's 'Nothing' and the user +-- will have to specify which compiler they want. +-- +defaultCompilerFlavor :: Maybe CompilerFlavor +defaultCompilerFlavor = case buildCompilerFlavor of + OtherCompiler _ -> Nothing + _ -> Just buildCompilerFlavor + +-- ------------------------------------------------------------ +-- * Compiler Id +-- ------------------------------------------------------------ + +data CompilerId = CompilerId CompilerFlavor Version + deriving (Eq, Ord, Read, Show) + +instance Text CompilerId where + disp (CompilerId f (Version [] _)) = disp f + disp (CompilerId f v) = disp f <> Disp.char '-' <> disp v + + parse = do + flavour <- parse + version <- (Parse.char '-' >> parse) Parse.<++ return (Version [] []) + return (CompilerId flavour version) + +lowercase :: String -> String +lowercase = map Char.toLower diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/GetOpt.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/GetOpt.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/GetOpt.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/GetOpt.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,335 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.GetOpt +-- Copyright : (c) Sven Panne 2002-2005 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Portability : portable +-- +-- This library provides facilities for parsing the command-line options +-- in a standalone program. It is essentially a Haskell port of the GNU +-- @getopt@ library. +-- +----------------------------------------------------------------------------- + +{- +Sven Panne Oct. 1996 (small +changes Dec. 1997) + +Two rather obscure features are missing: The Bash 2.0 non-option hack +(if you don't already know it, you probably don't want to hear about +it...) and the recognition of long options with a single dash +(e.g. '-help' is recognised as '--help', as long as there is no short +option 'h'). + +Other differences between GNU's getopt and this implementation: + +* To enforce a coherent description of options and arguments, there + are explanation fields in the option/argument descriptor. + +* Error messages are now more informative, but no longer POSIX + compliant... :-( + +And a final Haskell advertisement: The GNU C implementation uses well +over 1100 lines, we need only 195 here, including a 46 line example! +:-) +-} + +-- #hide +module Distribution.GetOpt ( + -- * GetOpt + getOpt, getOpt', + usageInfo, + ArgOrder(..), + OptDescr(..), + ArgDescr(..), + + -- * Example + + -- $example +) where + +import Data.List ( isPrefixOf, intersperse, find ) + +-- |What to do with options following non-options +data ArgOrder a + = RequireOrder -- ^ no option processing after first non-option + | Permute -- ^ freely intersperse options and non-options + | ReturnInOrder (String -> a) -- ^ wrap non-options into options + +{-| +Each 'OptDescr' describes a single option. + +The arguments to 'Option' are: + +* list of short option characters + +* list of long option strings (without \"--\") + +* argument descriptor + +* explanation of option for user +-} +data OptDescr a = -- description of a single options: + Option [Char] -- list of short option characters + [String] -- list of long option strings (without "--") + (ArgDescr a) -- argument descriptor + String -- explanation of option for user + +-- |Describes whether an option takes an argument or not, and if so +-- how the argument is injected into a value of type @a@. +data ArgDescr a + = NoArg a -- ^ no argument expected + | ReqArg (String -> a) String -- ^ option requires argument + | OptArg (Maybe String -> a) String -- ^ optional argument + +data OptKind a -- kind of cmd line arg (internal use only): + = Opt a -- an option + | UnreqOpt String -- an un-recognized option + | NonOpt String -- a non-option + | EndOfOpts -- end-of-options marker (i.e. "--") + | OptErr String -- something went wrong... + +-- | Return a string describing the usage of a command, derived from +-- the header (first argument) and the options described by the +-- second argument. +usageInfo :: String -- header + -> [OptDescr a] -- option descriptors + -> String -- nicely formatted decription of options +usageInfo header optDescr = unlines (header:table) + where (ss,ls,ds) = unzip3 [ (sepBy ", " (map (fmtShort ad) sos) + ,concatMap (fmtLong ad) (take 1 los) + ,d) + | Option sos los ad d <- optDescr ] + ssWidth = (maximum . map length) ss + lsWidth = (maximum . map length) ls + dsWidth = 30 `max` (80 - (ssWidth + lsWidth + 3)) + table = [ " " ++ padTo ssWidth so' ++ + " " ++ padTo lsWidth lo' ++ + " " ++ d' + | (so,lo,d) <- zip3 ss ls ds + , (so',lo',d') <- fmtOpt dsWidth so lo d ] + padTo n x = take n (x ++ repeat ' ') + sepBy s = concat . intersperse s + +fmtOpt :: Int -> String -> String -> String -> [(String, String, String)] +fmtOpt descrWidth so lo descr = + case wrapText descrWidth descr of + [] -> [(so,lo,"")] + (d:ds) -> (so,lo,d) : [ ("","",d') | d' <- ds ] + +fmtShort :: ArgDescr a -> Char -> String +fmtShort (NoArg _ ) so = "-" ++ [so] +fmtShort (ReqArg _ _) so = "-" ++ [so] +fmtShort (OptArg _ _) so = "-" ++ [so] + +fmtLong :: ArgDescr a -> String -> String +fmtLong (NoArg _ ) lo = "--" ++ lo +fmtLong (ReqArg _ ad) lo = "--" ++ lo ++ "=" ++ ad +fmtLong (OptArg _ ad) lo = "--" ++ lo ++ "[=" ++ ad ++ "]" + +wrapText :: Int -> String -> [String] +wrapText width = map unwords . wrap 0 [] . words + where wrap :: Int -> [String] -> [String] -> [[String]] + wrap 0 [] (w:ws) + | length w + 1 > width + = wrap (length w) [w] ws + wrap col line (w:ws) + | col + length w + 1 > width + = reverse line : wrap 0 [] (w:ws) + wrap col line (w:ws) + = let col' = col + length w + 1 + in wrap col' (w:line) ws + wrap _ [] [] = [] + wrap _ line [] = [reverse line] + +{-| +Process the command-line, and return the list of values that matched +(and those that didn\'t). The arguments are: + +* The order requirements (see 'ArgOrder') + +* The option descriptions (see 'OptDescr') + +* The actual command line arguments (presumably got from + 'System.Environment.getArgs'). + +'getOpt' returns a triple consisting of the option arguments, a list +of non-options, and a list of error messages. +-} +getOpt :: ArgOrder a -- non-option handling + -> [OptDescr a] -- option descriptors + -> [String] -- the command-line arguments + -> ([a],[String],[String]) -- (options,non-options,error messages) +getOpt ordering optDescr args = (os,xs,es ++ map errUnrec us) + where (os,xs,us,es) = getOpt' ordering optDescr args + +{-| +This is almost the same as 'getOpt', but returns a quadruple +consisting of the option arguments, a list of non-options, a list of +unrecognized options, and a list of error messages. +-} +getOpt' :: ArgOrder a -- non-option handling + -> [OptDescr a] -- option descriptors + -> [String] -- the command-line arguments + -> ([a],[String], [String] ,[String]) -- (options,non-options,unrecognized,error messages) +getOpt' _ _ [] = ([],[],[],[]) +getOpt' ordering optDescr (arg:args) = procNextOpt opt ordering + where procNextOpt (Opt o) _ = (o:os,xs,us,es) + procNextOpt (UnreqOpt u) _ = (os,xs,u:us,es) + procNextOpt (NonOpt x) RequireOrder = ([],x:rest,[],[]) + procNextOpt (NonOpt x) Permute = (os,x:xs,us,es) + procNextOpt (NonOpt x) (ReturnInOrder f) = (f x :os, xs,us,es) + procNextOpt EndOfOpts RequireOrder = ([],rest,[],[]) + procNextOpt EndOfOpts Permute = ([],rest,[],[]) + procNextOpt EndOfOpts (ReturnInOrder f) = (map f rest,[],[],[]) + procNextOpt (OptErr e) _ = (os,xs,us,e:es) + + (opt,rest) = getNext arg args optDescr + (os,xs,us,es) = getOpt' ordering optDescr rest + +-- take a look at the next cmd line arg and decide what to do with it +getNext :: String -> [String] -> [OptDescr a] -> (OptKind a,[String]) +getNext ('-':'-':[]) rest _ = (EndOfOpts,rest) +getNext ('-':'-':xs) rest optDescr = longOpt xs rest optDescr +getNext ('-': x :xs) rest optDescr = shortOpt x xs rest optDescr +getNext a rest _ = (NonOpt a,rest) + +-- handle long option +longOpt :: String -> [String] -> [OptDescr a] -> (OptKind a,[String]) +longOpt ls rs optDescr = long ads arg rs + where (opt,arg) = break (=='=') ls + getWith p = [ o | o@(Option _ xs _ _) <- optDescr + , find (p opt) xs /= Nothing] + exact = getWith (==) + options = if null exact then getWith isPrefixOf else exact + ads = [ ad | Option _ _ ad _ <- options ] + optStr = ("--"++opt) + + long (_:_:_) _ rest = (errAmbig options optStr,rest) + long [NoArg a ] [] rest = (Opt a,rest) + long [NoArg _ ] ('=':_) rest = (errNoArg optStr,rest) + long [ReqArg _ d] [] [] = (errReq d optStr,[]) + long [ReqArg f _] [] (r:rest) = (Opt (f r),rest) + long [ReqArg f _] ('=':xs) rest = (Opt (f xs),rest) + long [OptArg f _] [] rest = (Opt (f Nothing),rest) + long [OptArg f _] ('=':xs) rest = (Opt (f (Just xs)),rest) + long _ _ rest = (UnreqOpt ("--"++ls),rest) + +-- handle short option +shortOpt :: Char -> String -> [String] -> [OptDescr a] -> (OptKind a,[String]) +shortOpt y ys rs optDescr = short ads ys rs + where options = [ o | o@(Option ss _ _ _) <- optDescr, s <- ss, y == s ] + ads = [ ad | Option _ _ ad _ <- options ] + optStr = '-':[y] + + short (_:_:_) _ rest = (errAmbig options optStr,rest) + short (NoArg a :_) [] rest = (Opt a,rest) + short (NoArg a :_) xs rest = (Opt a,('-':xs):rest) + short (ReqArg _ d:_) [] [] = (errReq d optStr,[]) + short (ReqArg f _:_) [] (r:rest) = (Opt (f r),rest) + short (ReqArg f _:_) xs rest = (Opt (f xs),rest) + short (OptArg f _:_) [] rest = (Opt (f Nothing),rest) + short (OptArg f _:_) xs rest = (Opt (f (Just xs)),rest) + short [] [] rest = (UnreqOpt optStr,rest) + short [] xs rest = (UnreqOpt (optStr++xs),rest) + +-- miscellaneous error formatting + +errAmbig :: [OptDescr a] -> String -> OptKind a +errAmbig ods optStr = OptErr (usageInfo header ods) + where header = "option `" ++ optStr ++ "' is ambiguous; could be one of:" + +errReq :: String -> String -> OptKind a +errReq d optStr = OptErr ("option `" ++ optStr ++ "' requires an argument " ++ d ++ "\n") + +errUnrec :: String -> String +errUnrec optStr = "unrecognized option `" ++ optStr ++ "'\n" + +errNoArg :: String -> OptKind a +errNoArg optStr = OptErr ("option `" ++ optStr ++ "' doesn't allow an argument\n") + +{- +----------------------------------------------------------------------------------------- +-- and here a small and hopefully enlightening example: + +data Flag = Verbose | Version | Name String | Output String | Arg String deriving Show + +options :: [OptDescr Flag] +options = + [Option ['v'] ["verbose"] (NoArg Verbose) "verbosely list files", + Option ['V','?'] ["version","release"] (NoArg Version) "show version info", + Option ['o'] ["output"] (OptArg out "FILE") "use FILE for dump", + Option ['n'] ["name"] (ReqArg Name "USER") "only dump USER's files"] + +out :: Maybe String -> Flag +out Nothing = Output "stdout" +out (Just o) = Output o + +test :: ArgOrder Flag -> [String] -> String +test order cmdline = case getOpt order options cmdline of + (o,n,[] ) -> "options=" ++ show o ++ " args=" ++ show n ++ "\n" + (_,_,errs) -> concat errs ++ usageInfo header options + where header = "Usage: foobar [OPTION...] files..." + +-- example runs: +-- putStr (test RequireOrder ["foo","-v"]) +-- ==> options=[] args=["foo", "-v"] +-- putStr (test Permute ["foo","-v"]) +-- ==> options=[Verbose] args=["foo"] +-- putStr (test (ReturnInOrder Arg) ["foo","-v"]) +-- ==> options=[Arg "foo", Verbose] args=[] +-- putStr (test Permute ["foo","--","-v"]) +-- ==> options=[] args=["foo", "-v"] +-- putStr (test Permute ["-?o","--name","bar","--na=baz"]) +-- ==> options=[Version, Output "stdout", Name "bar", Name "baz"] args=[] +-- putStr (test Permute ["--ver","foo"]) +-- ==> option `--ver' is ambiguous; could be one of: +-- -v --verbose verbosely list files +-- -V, -? --version, --release show version info +-- Usage: foobar [OPTION...] files... +-- -v --verbose verbosely list files +-- -V, -? --version, --release show version info +-- -o[FILE] --output[=FILE] use FILE for dump +-- -n USER --name=USER only dump USER's files +----------------------------------------------------------------------------------------- +-} + +{- $example + +To hopefully illuminate the role of the different data +structures, here\'s the command-line options for a (very simple) +compiler: + +> module Opts where +> +> import Distribution.GetOpt +> import Data.Maybe ( fromMaybe ) +> +> data Flag +> = Verbose | Version +> | Input String | Output String | LibDir String +> deriving Show +> +> options :: [OptDescr Flag] +> options = +> [ Option ['v'] ["verbose"] (NoArg Verbose) "chatty output on stderr" +> , Option ['V','?'] ["version"] (NoArg Version) "show version number" +> , Option ['o'] ["output"] (OptArg outp "FILE") "output FILE" +> , Option ['c'] [] (OptArg inp "FILE") "input FILE" +> , Option ['L'] ["libdir"] (ReqArg LibDir "DIR") "library directory" +> ] +> +> inp,outp :: Maybe String -> Flag +> outp = Output . fromMaybe "stdout" +> inp = Input . fromMaybe "stdin" +> +> compilerOpts :: [String] -> IO ([Flag], [String]) +> compilerOpts argv = +> case getOpt Permute options argv of +> (o,n,[] ) -> return (o,n) +> (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options)) +> where header = "Usage: ic [OPTION...] files..." + +-} diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/InstalledPackageInfo.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/InstalledPackageInfo.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/InstalledPackageInfo.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/InstalledPackageInfo.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,294 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.InstalledPackageInfo +-- Copyright : (c) The University of Glasgow 2004 +-- +-- Maintainer : libraries@haskell.org +-- Portability : portable +-- +-- This is the information about an /installed/ package that +-- is communicated to the @ghc-pkg@ program in order to register +-- a package. @ghc-pkg@ now consumes this package format (as of version +-- 6.4). This is specific to GHC at the moment. +-- +-- The @.cabal@ file format is for describing a package that is not yet +-- installed. It has a lot of flexibility, like conditionals and dependency +-- ranges. As such, that format is not at all suitable for describing a package +-- that has already been built and installed. By the time we get to that stage, +-- we have resolved all conditionals and resolved dependency version +-- constraints to exact versions of dependent packages. So, this module defines +-- the 'InstalledPackageInfo' data structure that contains all the info we keep +-- about an installed package. There is a parser and pretty printer. The +-- textual format is rather simpler than the @.cabal@ format: there are no +-- sections, for example. + +{- All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of the University nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +-- This module is meant to be local-only to Distribution... + +module Distribution.InstalledPackageInfo ( + InstalledPackageInfo_(..), InstalledPackageInfo, + ParseResult(..), PError(..), PWarning, + emptyInstalledPackageInfo, + parseInstalledPackageInfo, + showInstalledPackageInfo, + showInstalledPackageInfoField, + fieldsInstalledPackageInfo, + ) where + +import Distribution.ParseUtils + ( FieldDescr(..), ParseResult(..), PError(..), PWarning + , simpleField, listField, parseLicenseQ + , showFields, showSingleNamedField, parseFieldsFlat + , parseFilePathQ, parseTokenQ, parseModuleNameQ, parsePackageNameQ + , showFilePath, showToken, boolField, parseOptVersion + , parseFreeText, showFreeText ) +import Distribution.License ( License(..) ) +import Distribution.Package + ( PackageName(..), PackageIdentifier(..), PackageId, InstalledPackageId(..) + , packageName, packageVersion ) +import qualified Distribution.Package as Package + ( Package(..) ) +import Distribution.ModuleName + ( ModuleName ) +import Distribution.Version + ( Version(..) ) +import Distribution.Text + ( Text(disp, parse) ) + +-- ----------------------------------------------------------------------------- +-- The InstalledPackageInfo type + +data InstalledPackageInfo_ m + = InstalledPackageInfo { + -- these parts are exactly the same as PackageDescription + installedPackageId :: InstalledPackageId, + sourcePackageId :: PackageId, + license :: License, + copyright :: String, + maintainer :: String, + author :: String, + stability :: String, + homepage :: String, + pkgUrl :: String, + synopsis :: String, + description :: String, + category :: String, + -- these parts are required by an installed package only: + exposed :: Bool, + exposedModules :: [m], + hiddenModules :: [m], + trusted :: Bool, + importDirs :: [FilePath], -- contain sources in case of Hugs + libraryDirs :: [FilePath], + hsLibraries :: [String], + extraLibraries :: [String], + extraGHCiLibraries:: [String], -- overrides extraLibraries for GHCi + includeDirs :: [FilePath], + includes :: [String], + depends :: [InstalledPackageId], + hugsOptions :: [String], + ccOptions :: [String], + ldOptions :: [String], + frameworkDirs :: [FilePath], + frameworks :: [String], + haddockInterfaces :: [FilePath], + haddockHTMLs :: [FilePath] + } + deriving (Read, Show) + +instance Package.Package (InstalledPackageInfo_ str) where + packageId = sourcePackageId + +type InstalledPackageInfo = InstalledPackageInfo_ ModuleName + +emptyInstalledPackageInfo :: InstalledPackageInfo_ m +emptyInstalledPackageInfo + = InstalledPackageInfo { + installedPackageId = InstalledPackageId "", + sourcePackageId = PackageIdentifier (PackageName "") noVersion, + license = AllRightsReserved, + copyright = "", + maintainer = "", + author = "", + stability = "", + homepage = "", + pkgUrl = "", + synopsis = "", + description = "", + category = "", + exposed = False, + exposedModules = [], + hiddenModules = [], + trusted = False, + importDirs = [], + libraryDirs = [], + hsLibraries = [], + extraLibraries = [], + extraGHCiLibraries= [], + includeDirs = [], + includes = [], + depends = [], + hugsOptions = [], + ccOptions = [], + ldOptions = [], + frameworkDirs = [], + frameworks = [], + haddockInterfaces = [], + haddockHTMLs = [] + } + +noVersion :: Version +noVersion = Version{ versionBranch=[], versionTags=[] } + +-- ----------------------------------------------------------------------------- +-- Parsing + +parseInstalledPackageInfo :: String -> ParseResult InstalledPackageInfo +parseInstalledPackageInfo = + parseFieldsFlat fieldsInstalledPackageInfo emptyInstalledPackageInfo + +-- ----------------------------------------------------------------------------- +-- Pretty-printing + +showInstalledPackageInfo :: InstalledPackageInfo -> String +showInstalledPackageInfo = showFields fieldsInstalledPackageInfo + +showInstalledPackageInfoField :: String -> Maybe (InstalledPackageInfo -> String) +showInstalledPackageInfoField = showSingleNamedField fieldsInstalledPackageInfo + +-- ----------------------------------------------------------------------------- +-- Description of the fields, for parsing/printing + +fieldsInstalledPackageInfo :: [FieldDescr InstalledPackageInfo] +fieldsInstalledPackageInfo = basicFieldDescrs ++ installedFieldDescrs + +basicFieldDescrs :: [FieldDescr InstalledPackageInfo] +basicFieldDescrs = + [ simpleField "name" + disp parsePackageNameQ + packageName (\name pkg -> pkg{sourcePackageId=(sourcePackageId pkg){pkgName=name}}) + , simpleField "version" + disp parseOptVersion + packageVersion (\ver pkg -> pkg{sourcePackageId=(sourcePackageId pkg){pkgVersion=ver}}) + , simpleField "id" + disp parse + installedPackageId (\ipid pkg -> pkg{installedPackageId=ipid}) + , simpleField "license" + disp parseLicenseQ + license (\l pkg -> pkg{license=l}) + , simpleField "copyright" + showFreeText parseFreeText + copyright (\val pkg -> pkg{copyright=val}) + , simpleField "maintainer" + showFreeText parseFreeText + maintainer (\val pkg -> pkg{maintainer=val}) + , simpleField "stability" + showFreeText parseFreeText + stability (\val pkg -> pkg{stability=val}) + , simpleField "homepage" + showFreeText parseFreeText + homepage (\val pkg -> pkg{homepage=val}) + , simpleField "package-url" + showFreeText parseFreeText + pkgUrl (\val pkg -> pkg{pkgUrl=val}) + , simpleField "synopsis" + showFreeText parseFreeText + synopsis (\val pkg -> pkg{synopsis=val}) + , simpleField "description" + showFreeText parseFreeText + description (\val pkg -> pkg{description=val}) + , simpleField "category" + showFreeText parseFreeText + category (\val pkg -> pkg{category=val}) + , simpleField "author" + showFreeText parseFreeText + author (\val pkg -> pkg{author=val}) + ] + +installedFieldDescrs :: [FieldDescr InstalledPackageInfo] +installedFieldDescrs = [ + boolField "exposed" + exposed (\val pkg -> pkg{exposed=val}) + , listField "exposed-modules" + disp parseModuleNameQ + exposedModules (\xs pkg -> pkg{exposedModules=xs}) + , listField "hidden-modules" + disp parseModuleNameQ + hiddenModules (\xs pkg -> pkg{hiddenModules=xs}) + , boolField "trusted" + trusted (\val pkg -> pkg{trusted=val}) + , listField "import-dirs" + showFilePath parseFilePathQ + importDirs (\xs pkg -> pkg{importDirs=xs}) + , listField "library-dirs" + showFilePath parseFilePathQ + libraryDirs (\xs pkg -> pkg{libraryDirs=xs}) + , listField "hs-libraries" + showFilePath parseTokenQ + hsLibraries (\xs pkg -> pkg{hsLibraries=xs}) + , listField "extra-libraries" + showToken parseTokenQ + extraLibraries (\xs pkg -> pkg{extraLibraries=xs}) + , listField "extra-ghci-libraries" + showToken parseTokenQ + extraGHCiLibraries (\xs pkg -> pkg{extraGHCiLibraries=xs}) + , listField "include-dirs" + showFilePath parseFilePathQ + includeDirs (\xs pkg -> pkg{includeDirs=xs}) + , listField "includes" + showFilePath parseFilePathQ + includes (\xs pkg -> pkg{includes=xs}) + , listField "depends" + disp parse + depends (\xs pkg -> pkg{depends=xs}) + , listField "hugs-options" + showToken parseTokenQ + hugsOptions (\path pkg -> pkg{hugsOptions=path}) + , listField "cc-options" + showToken parseTokenQ + ccOptions (\path pkg -> pkg{ccOptions=path}) + , listField "ld-options" + showToken parseTokenQ + ldOptions (\path pkg -> pkg{ldOptions=path}) + , listField "framework-dirs" + showFilePath parseFilePathQ + frameworkDirs (\xs pkg -> pkg{frameworkDirs=xs}) + , listField "frameworks" + showToken parseTokenQ + frameworks (\xs pkg -> pkg{frameworks=xs}) + , listField "haddock-interfaces" + showFilePath parseFilePathQ + haddockInterfaces (\xs pkg -> pkg{haddockInterfaces=xs}) + , listField "haddock-html" + showFilePath parseFilePathQ + haddockHTMLs (\xs pkg -> pkg{haddockHTMLs=xs}) + ] diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/License.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/License.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/License.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/License.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,138 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.License +-- Copyright : Isaac Jones 2003-2005 +-- Duncan Coutts 2008 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- The License datatype. For more information about these and other +-- open-source licenses, you may visit . +-- +-- The @.cabal@ file allows you to specify a license file. Of course you can +-- use any license you like but people often pick common open source licenses +-- and it's useful if we can automatically recognise that (eg so we can display +-- it on the hackage web pages). So you can also specify the license itself in +-- the @.cabal@ file from a short enumeration defined in this module. It +-- includes 'GPL', 'LGPL' and 'BSD3' licenses. + +{- All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.License ( + License(..), + knownLicenses, + ) where + +import Distribution.Version (Version(Version)) + +import Distribution.Text (Text(..), display) +import qualified Distribution.Compat.ReadP as Parse +import qualified Text.PrettyPrint as Disp +import Text.PrettyPrint ((<>)) +import qualified Data.Char as Char (isAlphaNum) + +-- |This datatype indicates the license under which your package is +-- released. It is also wise to add your license to each source file +-- using the license-file field. The 'AllRightsReserved' constructor +-- is not actually a license, but states that you are not giving +-- anyone else a license to use or distribute your work. The comments +-- below are general guidelines. Please read the licenses themselves +-- and consult a lawyer if you are unsure of your rights to release +-- the software. +-- +data License = + +--TODO: * remove BSD4 + + -- | GNU Public License. Source code must accompany alterations. + GPL (Maybe Version) + + -- | Lesser GPL, Less restrictive than GPL, useful for libraries. + | LGPL (Maybe Version) + + -- | 3-clause BSD license, newer, no advertising clause. Very free license. + | BSD3 + + -- | 4-clause BSD license, older, with advertising clause. You almost + -- certainly want to use the BSD3 license instead. + | BSD4 + + -- | The MIT license, similar to the BSD3. Very free license. + | MIT + + -- | Holder makes no claim to ownership, least restrictive license. + | PublicDomain + + -- | No rights are granted to others. Undistributable. Most restrictive. + | AllRightsReserved + + -- | Some other license. + | OtherLicense + + -- | Not a recognised license. + -- Allows us to deal with future extensions more gracefully. + | UnknownLicense String + deriving (Read, Show, Eq) + +knownLicenses :: [License] +knownLicenses = [ GPL unversioned, GPL (version [2]), GPL (version [3]) + , LGPL unversioned, LGPL (version [2,1]), LGPL (version [3]) + , BSD3, MIT + , PublicDomain, AllRightsReserved, OtherLicense] + where + unversioned = Nothing + version v = Just (Version v []) + +instance Text License where + disp (GPL version) = Disp.text "GPL" <> dispOptVersion version + disp (LGPL version) = Disp.text "LGPL" <> dispOptVersion version + disp (UnknownLicense other) = Disp.text other + disp other = Disp.text (show other) + + parse = do + name <- Parse.munch1 (\c -> Char.isAlphaNum c && c /= '-') + version <- Parse.option Nothing (Parse.char '-' >> fmap Just parse) + return $! case (name, version :: Maybe Version) of + ("GPL", _ ) -> GPL version + ("LGPL", _ ) -> LGPL version + ("BSD3", Nothing) -> BSD3 + ("BSD4", Nothing) -> BSD4 + ("MIT", Nothing) -> MIT + ("PublicDomain", Nothing) -> PublicDomain + ("AllRightsReserved", Nothing) -> AllRightsReserved + ("OtherLicense", Nothing) -> OtherLicense + _ -> UnknownLicense $ name + ++ maybe "" (('-':) . display) version + +dispOptVersion :: Maybe Version -> Disp.Doc +dispOptVersion Nothing = Disp.empty +dispOptVersion (Just v) = Disp.char '-' <> disp v diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/Make.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/Make.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/Make.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/Make.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,213 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Make +-- Copyright : Martin Sjögren 2004 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is an alternative build system that delegates everything to the @make@ +-- program. All the commands just end up calling @make@ with appropriate +-- arguments. The intention was to allow preexisting packages that used +-- makefiles to be wrapped into Cabal packages. In practice essentially all +-- such packages were converted over to the \"Simple\" build system instead. +-- Consequently this module is not used much and it certainly only sees cursory +-- maintenance and no testing. Perhaps at some point we should stop pretending +-- that it works. +-- +-- Uses the parsed command-line from "Distribution.Simple.Setup" in order to build +-- Haskell tools using a backend build system based on make. Obviously we +-- assume that there is a configure script, and that after the ConfigCmd has +-- been run, there is a Makefile. Further assumptions: +-- +-- [ConfigCmd] We assume the configure script accepts +-- @--with-hc@, +-- @--with-hc-pkg@, +-- @--prefix@, +-- @--bindir@, +-- @--libdir@, +-- @--libexecdir@, +-- @--datadir@. +-- +-- [BuildCmd] We assume that the default Makefile target will build everything. +-- +-- [InstallCmd] We assume there is an @install@ target. Note that we assume that +-- this does *not* register the package! +-- +-- [CopyCmd] We assume there is a @copy@ target, and a variable @$(destdir)@. +-- The @copy@ target should probably just invoke @make install@ +-- recursively (e.g. @$(MAKE) install prefix=$(destdir)\/$(prefix) +-- bindir=$(destdir)\/$(bindir)@. The reason we can\'t invoke @make +-- install@ directly here is that we don\'t know the value of @$(prefix)@. +-- +-- [SDistCmd] We assume there is a @dist@ target. +-- +-- [RegisterCmd] We assume there is a @register@ target and a variable @$(user)@. +-- +-- [UnregisterCmd] We assume there is an @unregister@ target. +-- +-- [HaddockCmd] We assume there is a @docs@ or @doc@ target. + + +-- copy : +-- $(MAKE) install prefix=$(destdir)/$(prefix) \ +-- bindir=$(destdir)/$(bindir) \ + +{- All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.Make ( + module Distribution.Package, + License(..), Version(..), + defaultMain, defaultMainArgs, defaultMainNoRead + ) where + +-- local +import Distribution.Compat.Exception +import Distribution.Package --must not specify imports, since we're exporting moule. +import Distribution.Simple.Program(defaultProgramConfiguration) +import Distribution.PackageDescription +import Distribution.Simple.Setup +import Distribution.Simple.Command + +import Distribution.Simple.Utils (rawSystemExit, cabalVersion) + +import Distribution.License (License(..)) +import Distribution.Version + ( Version(..) ) +import Distribution.Text + ( display ) + +import System.Environment (getArgs, getProgName) +import Data.List (intersperse) +import System.Exit + +defaultMain :: IO () +defaultMain = getArgs >>= defaultMainArgs + +defaultMainArgs :: [String] -> IO () +defaultMainArgs = defaultMainHelper + +{-# DEPRECATED defaultMainNoRead "it ignores its PackageDescription arg" #-} +defaultMainNoRead :: PackageDescription -> IO () +defaultMainNoRead = const defaultMain + +defaultMainHelper :: [String] -> IO () +defaultMainHelper args = + case commandsRun globalCommand commands args of + CommandHelp help -> printHelp help + CommandList opts -> printOptionsList opts + CommandErrors errs -> printErrors errs + CommandReadyToGo (flags, commandParse) -> + case commandParse of + _ | fromFlag (globalVersion flags) -> printVersion + | fromFlag (globalNumericVersion flags) -> printNumericVersion + CommandHelp help -> printHelp help + CommandList opts -> printOptionsList opts + CommandErrors errs -> printErrors errs + CommandReadyToGo action -> action + + where + printHelp help = getProgName >>= putStr . help + printOptionsList = putStr . unlines + printErrors errs = do + putStr (concat (intersperse "\n" errs)) + exitWith (ExitFailure 1) + printNumericVersion = putStrLn $ display cabalVersion + printVersion = putStrLn $ "Cabal library version " + ++ display cabalVersion + + progs = defaultProgramConfiguration + commands = + [configureCommand progs `commandAddAction` configureAction + ,buildCommand progs `commandAddAction` buildAction + ,installCommand `commandAddAction` installAction + ,copyCommand `commandAddAction` copyAction + ,haddockCommand `commandAddAction` haddockAction + ,cleanCommand `commandAddAction` cleanAction + ,sdistCommand `commandAddAction` sdistAction + ,registerCommand `commandAddAction` registerAction + ,unregisterCommand `commandAddAction` unregisterAction + ] + +configureAction :: ConfigFlags -> [String] -> IO () +configureAction flags args = do + noExtraFlags args + let verbosity = fromFlag (configVerbosity flags) + rawSystemExit verbosity "sh" $ + "configure" + : configureArgs backwardsCompatHack flags + where backwardsCompatHack = True + +copyAction :: CopyFlags -> [String] -> IO () +copyAction flags args = do + noExtraFlags args + let destArgs = case fromFlag $ copyDest flags of + NoCopyDest -> ["install"] + CopyTo path -> ["copy", "destdir=" ++ path] + rawSystemExit (fromFlag $ copyVerbosity flags) "make" destArgs + +installAction :: InstallFlags -> [String] -> IO () +installAction flags args = do + noExtraFlags args + rawSystemExit (fromFlag $ installVerbosity flags) "make" ["install"] + rawSystemExit (fromFlag $ installVerbosity flags) "make" ["register"] + +haddockAction :: HaddockFlags -> [String] -> IO () +haddockAction flags args = do + noExtraFlags args + rawSystemExit (fromFlag $ haddockVerbosity flags) "make" ["docs"] + `catchIO` \_ -> + rawSystemExit (fromFlag $ haddockVerbosity flags) "make" ["doc"] + +buildAction :: BuildFlags -> [String] -> IO () +buildAction flags args = do + noExtraFlags args + rawSystemExit (fromFlag $ buildVerbosity flags) "make" [] + +cleanAction :: CleanFlags -> [String] -> IO () +cleanAction flags args = do + noExtraFlags args + rawSystemExit (fromFlag $ cleanVerbosity flags) "make" ["clean"] + +sdistAction :: SDistFlags -> [String] -> IO () +sdistAction flags args = do + noExtraFlags args + rawSystemExit (fromFlag $ sDistVerbosity flags) "make" ["dist"] + +registerAction :: RegisterFlags -> [String] -> IO () +registerAction flags args = do + noExtraFlags args + rawSystemExit (fromFlag $ regVerbosity flags) "make" ["register"] + +unregisterAction :: RegisterFlags -> [String] -> IO () +unregisterAction flags args = do + noExtraFlags args + rawSystemExit (fromFlag $ regVerbosity flags) "make" ["unregister"] diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/ModuleName.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/ModuleName.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/ModuleName.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/ModuleName.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,130 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.ModuleName +-- Copyright : Duncan Coutts 2008 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Data type for Haskell module names. + +{- All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.ModuleName ( + ModuleName, + fromString, + components, + toFilePath, + main, + simple, + ) where + +import Distribution.Text + ( Text(..) ) + +import qualified Distribution.Compat.ReadP as Parse +import qualified Text.PrettyPrint as Disp +import qualified Data.Char as Char + ( isAlphaNum, isUpper ) +import System.FilePath + ( pathSeparator ) +import Data.List + ( intersperse ) + +-- | A valid Haskell module name. +-- +newtype ModuleName = ModuleName [String] + deriving (Eq, Ord, Read, Show) + +instance Text ModuleName where + disp (ModuleName ms) = + Disp.hcat (intersperse (Disp.char '.') (map Disp.text ms)) + + parse = do + ms <- Parse.sepBy1 component (Parse.char '.') + return (ModuleName ms) + + where + component = do + c <- Parse.satisfy Char.isUpper + cs <- Parse.munch validModuleChar + return (c:cs) + +validModuleChar :: Char -> Bool +validModuleChar c = Char.isAlphaNum c || c == '_' || c == '\'' + +validModuleComponent :: String -> Bool +validModuleComponent [] = False +validModuleComponent (c:cs) = Char.isUpper c + && all validModuleChar cs + +{-# DEPRECATED simple "use ModuleName.fromString instead" #-} +simple :: String -> ModuleName +simple str = ModuleName [str] + +-- | Construct a 'ModuleName' from a valid module name 'String'. +-- +-- This is just a convenience function intended for valid module strings. It is +-- an error if it is used with a string that is not a valid module name. If you +-- are parsing user input then use 'Distribution.Text.simpleParse' instead. +-- +fromString :: String -> ModuleName +fromString string + | all validModuleComponent components' = ModuleName components' + | otherwise = error badName + + where + components' = split string + badName = "ModuleName.fromString: invalid module name " ++ show string + + split cs = case break (=='.') cs of + (chunk,[]) -> chunk : [] + (chunk,_:rest) -> chunk : split rest + +-- | The module name @Main@. +-- +main :: ModuleName +main = ModuleName ["Main"] + +-- | The individual components of a hierarchical module name. For example +-- +-- > components (fromString "A.B.C") = ["A", "B", "C"] +-- +components :: ModuleName -> [String] +components (ModuleName ms) = ms + +-- | Convert a module name to a file path, but without any file extension. +-- For example: +-- +-- > toFilePath (fromString "A.B.C") = "A/B/C" +-- +toFilePath :: ModuleName -> FilePath +toFilePath = concat . intersperse [pathSeparator] . components diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/PackageDescription/Check.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/PackageDescription/Check.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/PackageDescription/Check.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/PackageDescription/Check.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,1441 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.PackageDescription.Check +-- Copyright : Lennart Kolmodin 2008 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This has code for checking for various problems in packages. There is one +-- set of checks that just looks at a 'PackageDescription' in isolation and +-- another set of checks that also looks at files in the package. Some of the +-- checks are basic sanity checks, others are portability standards that we'd +-- like to encourage. There is a 'PackageCheck' type that distinguishes the +-- different kinds of check so we can see which ones are appropriate to report +-- in different situations. This code gets uses when configuring a package when +-- we consider only basic problems. The higher standard is uses when when +-- preparing a source tarball and by hackage when uploading new packages. The +-- reason for this is that we want to hold packages that are expected to be +-- distributed to a higher standard than packages that are only ever expected +-- to be used on the author's own environment. + +{- All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.PackageDescription.Check ( + -- * Package Checking + PackageCheck(..), + checkPackage, + checkConfiguredPackage, + + -- ** Checking package contents + checkPackageFiles, + checkPackageContent, + CheckPackageContentOps(..), + checkPackageFileNames, + ) where + +import Data.Maybe + ( isNothing, isJust, catMaybes, maybeToList, fromMaybe ) +import Data.List (sort, group, isPrefixOf, nub, find) +import Control.Monad + ( filterM, liftM ) +import qualified System.Directory as System + ( doesFileExist, doesDirectoryExist ) + +import Distribution.Package ( pkgName ) +import Distribution.PackageDescription +import Distribution.PackageDescription.Configuration + ( flattenPackageDescription, finalizePackageDescription ) +import Distribution.Compiler + ( CompilerFlavor(..), buildCompilerFlavor, CompilerId(..) ) +import Distribution.System + ( OS(..), Arch(..), buildPlatform ) +import Distribution.License + ( License(..), knownLicenses ) +import Distribution.Simple.Utils + ( cabalVersion, intercalate, parseFileGlob, FileGlob(..), lowercase ) + +import Distribution.Version + ( Version(..) + , VersionRange(..), foldVersionRange' + , anyVersion, noVersion, thisVersion, laterVersion, earlierVersion + , orLaterVersion, orEarlierVersion + , unionVersionRanges, intersectVersionRanges + , asVersionIntervals, UpperBound(..), isNoVersion ) +import Distribution.Package + ( PackageName(PackageName), packageName, packageVersion + , Dependency(..) ) + +import Distribution.Text + ( display, disp ) +import qualified Text.PrettyPrint as Disp +import Text.PrettyPrint ((<>), (<+>)) + +import qualified Language.Haskell.Extension as Extension (deprecatedExtensions) +import Language.Haskell.Extension + ( Language(UnknownLanguage), knownLanguages, Extension(..), KnownExtension(..) ) +import System.FilePath + ( (), takeExtension, isRelative, isAbsolute + , splitDirectories, splitPath ) +import System.FilePath.Windows as FilePath.Windows + ( isValid ) + +-- | Results of some kind of failed package check. +-- +-- There are a range of severities, from merely dubious to totally insane. +-- All of them come with a human readable explanation. In future we may augment +-- them with more machine readable explanations, for example to help an IDE +-- suggest automatic corrections. +-- +data PackageCheck = + + -- | This package description is no good. There's no way it's going to + -- build sensibly. This should give an error at configure time. + PackageBuildImpossible { explanation :: String } + + -- | A problem that is likely to affect building the package, or an + -- issue that we'd like every package author to be aware of, even if + -- the package is never distributed. + | PackageBuildWarning { explanation :: String } + + -- | An issue that might not be a problem for the package author but + -- might be annoying or determental when the package is distributed to + -- users. We should encourage distributed packages to be free from these + -- issues, but occasionally there are justifiable reasons so we cannot + -- ban them entirely. + | PackageDistSuspicious { explanation :: String } + + -- | An issue that is ok in the author's environment but is almost + -- certain to be a portability problem for other environments. We can + -- quite legitimately refuse to publicly distribute packages with these + -- problems. + | PackageDistInexcusable { explanation :: String } + +instance Show PackageCheck where + show notice = explanation notice + +check :: Bool -> PackageCheck -> Maybe PackageCheck +check False _ = Nothing +check True pc = Just pc + +-- ------------------------------------------------------------ +-- * Standard checks +-- ------------------------------------------------------------ + +-- | Check for common mistakes and problems in package descriptions. +-- +-- This is the standard collection of checks covering all apsects except +-- for checks that require looking at files within the package. For those +-- see 'checkPackageFiles'. +-- +-- It requires the 'GenericPackageDescription' and optionally a particular +-- configuration of that package. If you pass 'Nothing' then we just check +-- a version of the generic description using 'flattenPackageDescription'. +-- +checkPackage :: GenericPackageDescription + -> Maybe PackageDescription + -> [PackageCheck] +checkPackage gpkg mpkg = + checkConfiguredPackage pkg + ++ checkConditionals gpkg + ++ checkPackageVersions gpkg + where + pkg = fromMaybe (flattenPackageDescription gpkg) mpkg + +--TODO: make this variant go away +-- we should alwaws know the GenericPackageDescription +checkConfiguredPackage :: PackageDescription -> [PackageCheck] +checkConfiguredPackage pkg = + checkSanity pkg + ++ checkFields pkg + ++ checkLicense pkg + ++ checkSourceRepos pkg + ++ checkGhcOptions pkg + ++ checkCCOptions pkg + ++ checkPaths pkg + ++ checkCabalVersion pkg + + +-- ------------------------------------------------------------ +-- * Basic sanity checks +-- ------------------------------------------------------------ + +-- | Check that this package description is sane. +-- +checkSanity :: PackageDescription -> [PackageCheck] +checkSanity pkg = + catMaybes [ + + check (null . (\(PackageName n) -> n) . packageName $ pkg) $ + PackageBuildImpossible "No 'name' field." + + , check (null . versionBranch . packageVersion $ pkg) $ + PackageBuildImpossible "No 'version' field." + + , check (null (executables pkg) && isNothing (library pkg)) $ + PackageBuildImpossible + "No executables and no library found. Nothing to do." + + , check (not (null exeDuplicates)) $ + PackageBuildImpossible $ "Duplicate executable sections " + ++ commaSep exeDuplicates + , check (not (null testDuplicates)) $ + PackageBuildImpossible $ "Duplicate test sections " + ++ commaSep testDuplicates + + --TODO: this seems to duplicate a check on the testsuites + , check (not (null testsThatAreExes)) $ + PackageBuildImpossible $ "These test sections share names with executable sections: " + ++ commaSep testsThatAreExes + ] + --TODO: check for name clashes case insensitively: windows file systems cannot cope. + + ++ maybe [] checkLibrary (library pkg) + ++ concatMap checkExecutable (executables pkg) + ++ concatMap (checkTestSuite pkg) (testSuites pkg) + + ++ catMaybes [ + + check (specVersion pkg > cabalVersion) $ + PackageBuildImpossible $ + "This package description follows version " + ++ display (specVersion pkg) ++ " of the Cabal specification. This " + ++ "tool only supports up to version " ++ display cabalVersion ++ "." + ] + where + exeNames = map exeName $ executables pkg + testNames = map testName $ testSuites pkg + exeDuplicates = dups exeNames + testDuplicates = dups testNames + testsThatAreExes = filter (flip elem exeNames) testNames + +checkLibrary :: Library -> [PackageCheck] +checkLibrary lib = + catMaybes [ + + check (not (null moduleDuplicates)) $ + PackageBuildWarning $ + "Duplicate modules in library: " + ++ commaSep (map display moduleDuplicates) + ] + + where + moduleDuplicates = dups (libModules lib) + +checkExecutable :: Executable -> [PackageCheck] +checkExecutable exe = + catMaybes [ + + check (null (modulePath exe)) $ + PackageBuildImpossible $ + "No 'Main-Is' field found for executable " ++ exeName exe + + , check (not (null (modulePath exe)) + && takeExtension (modulePath exe) `notElem` [".hs", ".lhs"]) $ + PackageBuildImpossible $ + "The 'Main-Is' field must specify a '.hs' or '.lhs' file " + ++ "(even if it is generated by a preprocessor)." + + , check (not (null moduleDuplicates)) $ + PackageBuildWarning $ + "Duplicate modules in executable '" ++ exeName exe ++ "': " + ++ commaSep (map display moduleDuplicates) + ] + where + moduleDuplicates = dups (exeModules exe) + +checkTestSuite :: PackageDescription -> TestSuite -> [PackageCheck] +checkTestSuite pkg test = + catMaybes [ + + case testInterface test of + TestSuiteUnsupported tt@(TestTypeUnknown _ _) -> Just $ + PackageBuildWarning $ + quote (display tt) ++ " is not a known type of test suite. " + ++ "The known test suite types are: " + ++ commaSep (map display knownTestTypes) + + TestSuiteUnsupported tt -> Just $ + PackageBuildWarning $ + quote (display tt) ++ " is not a supported test suite version. " + ++ "The known test suite types are: " + ++ commaSep (map display knownTestTypes) + _ -> Nothing + + , check (not $ null moduleDuplicates) $ + PackageBuildWarning $ + "Duplicate modules in test suite '" ++ testName test ++ "': " + ++ commaSep (map display moduleDuplicates) + + , check mainIsWrongExt $ + PackageBuildImpossible $ + "The 'main-is' field must specify a '.hs' or '.lhs' file " + ++ "(even if it is generated by a preprocessor)." + + , check exeNameClash $ + PackageBuildImpossible $ + "The test suite " ++ testName test + ++ " has the same name as an executable." + + , check libNameClash $ + PackageBuildImpossible $ + "The test suite " ++ testName test + ++ " has the same name as the package." + ] + where + moduleDuplicates = dups $ testModules test + + mainIsWrongExt = case testInterface test of + TestSuiteExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"] + _ -> False + + exeNameClash = testName test `elem` [ exeName exe | exe <- executables pkg ] + libNameClash = testName test `elem` [ libName + | _lib <- maybeToList (library pkg) + , let PackageName libName = + pkgName (package pkg) ] + +-- ------------------------------------------------------------ +-- * Additional pure checks +-- ------------------------------------------------------------ + +checkFields :: PackageDescription -> [PackageCheck] +checkFields pkg = + catMaybes [ + + check (not . FilePath.Windows.isValid . display . packageName $ pkg) $ + PackageDistInexcusable $ + "Unfortunately, the package name '" ++ display (packageName pkg) + ++ "' is one of the reserved system file names on Windows. Many tools " + ++ "need to convert package names to file names so using this name " + ++ "would cause problems." + + , check (isNothing (buildType pkg)) $ + PackageBuildWarning $ + "No 'build-type' specified. If you do not need a custom Setup.hs or " + ++ "./configure script then use 'build-type: Simple'." + + , case buildType pkg of + Just (UnknownBuildType unknown) -> Just $ + PackageBuildWarning $ + quote unknown ++ " is not a known 'build-type'. " + ++ "The known build types are: " + ++ commaSep (map display knownBuildTypes) + _ -> Nothing + + , check (not (null unknownCompilers)) $ + PackageBuildWarning $ + "Unknown compiler " ++ commaSep (map quote unknownCompilers) + ++ " in 'tested-with' field." + + , check (not (null unknownLanguages)) $ + PackageBuildWarning $ + "Unknown languages: " ++ commaSep unknownLanguages + + , check (not (null unknownExtensions)) $ + PackageBuildWarning $ + "Unknown extensions: " ++ commaSep unknownExtensions + + , check (not (null languagesUsedAsExtensions)) $ + PackageBuildWarning $ + "Languages listed as extensions: " + ++ commaSep languagesUsedAsExtensions + ++ ". Languages must be specified in either the 'default-language' " + ++ " or the 'other-languages' field." + + , check (not (null deprecatedExtensions)) $ + PackageDistSuspicious $ + "Deprecated extensions: " + ++ commaSep (map (quote . display . fst) deprecatedExtensions) + ++ ". " ++ intercalate " " + [ "Instead of '" ++ display ext + ++ "' use '" ++ display replacement ++ "'." + | (ext, Just replacement) <- deprecatedExtensions ] + + , check (null (category pkg)) $ + PackageDistSuspicious "No 'category' field." + + , check (null (maintainer pkg)) $ + PackageDistSuspicious "No 'maintainer' field." + + , check (null (synopsis pkg) && null (description pkg)) $ + PackageDistInexcusable $ "No 'synopsis' or 'description' field." + + , check (null (description pkg) && not (null (synopsis pkg))) $ + PackageDistSuspicious "No 'description' field." + + , check (null (synopsis pkg) && not (null (description pkg))) $ + PackageDistSuspicious "No 'synopsis' field." + + --TODO: recommend the bug reports url, author and homepage fields + --TODO: recommend not using the stability field + --TODO: recommend specifying a source repo + + , check (length (synopsis pkg) >= 80) $ + PackageDistSuspicious + "The 'synopsis' field is rather long (max 80 chars is recommended)." + + -- check use of impossible constraints "tested-with: GHC== 6.10 && ==6.12" + , check (not (null testedWithImpossibleRanges)) $ + PackageDistInexcusable $ + "Invalid 'tested-with' version range: " + ++ commaSep (map display testedWithImpossibleRanges) + ++ ". To indicate that you have tested a package with multiple " + ++ "different versions of the same compiler use multiple entries, " + ++ "for example 'tested-with: GHC==6.10.4, GHC==6.12.3' and not " + ++ "'tested-with: GHC==6.10.4 && ==6.12.3'." + ] + where + unknownCompilers = [ name | (OtherCompiler name, _) <- testedWith pkg ] + unknownLanguages = [ name | bi <- allBuildInfo pkg + , UnknownLanguage name <- allLanguages bi ] + unknownExtensions = [ name | bi <- allBuildInfo pkg + , UnknownExtension name <- allExtensions bi + , name `notElem` map display knownLanguages ] + deprecatedExtensions = nub $ catMaybes + [ find ((==ext) . fst) Extension.deprecatedExtensions + | bi <- allBuildInfo pkg + , ext <- allExtensions bi ] + languagesUsedAsExtensions = + [ name | bi <- allBuildInfo pkg + , UnknownExtension name <- allExtensions bi + , name `elem` map display knownLanguages ] + + testedWithImpossibleRanges = + [ Dependency (PackageName (display compiler)) vr + | (compiler, vr) <- testedWith pkg + , isNoVersion vr ] + + +checkLicense :: PackageDescription -> [PackageCheck] +checkLicense pkg = + catMaybes [ + + check (license pkg == AllRightsReserved) $ + PackageDistInexcusable + "The 'license' field is missing or specified as AllRightsReserved." + + , case license pkg of + UnknownLicense l -> Just $ + PackageBuildWarning $ + quote ("license: " ++ l) ++ " is not a recognised license. The " + ++ "known licenses are: " + ++ commaSep (map display knownLicenses) + _ -> Nothing + + , check (license pkg == BSD4) $ + PackageDistSuspicious $ + "Using 'license: BSD4' is almost always a misunderstanding. 'BSD4' " + ++ "refers to the old 4-clause BSD license with the advertising " + ++ "clause. 'BSD3' refers the new 3-clause BSD license." + + , case unknownLicenseVersion (license pkg) of + Just knownVersions -> Just $ + PackageDistSuspicious $ + "'license: " ++ display (license pkg) ++ "' is not a known " + ++ "version of that license. The known versions are " + ++ commaSep (map display knownVersions) + ++ ". If this is not a mistake and you think it should be a known " + ++ "version then please file a ticket." + _ -> Nothing + + , check (license pkg `notElem` [AllRightsReserved, PublicDomain] + -- AllRightsReserved and PublicDomain are not strictly + -- licenses so don't need license files. + && null (licenseFile pkg)) $ + PackageDistSuspicious "A 'license-file' is not specified." + ] + where + unknownLicenseVersion (GPL (Just v)) + | v `notElem` knownVersions = Just knownVersions + where knownVersions = [ v' | GPL (Just v') <- knownLicenses ] + unknownLicenseVersion (LGPL (Just v)) + | v `notElem` knownVersions = Just knownVersions + where knownVersions = [ v' | LGPL (Just v') <- knownLicenses ] + unknownLicenseVersion _ = Nothing + +checkSourceRepos :: PackageDescription -> [PackageCheck] +checkSourceRepos pkg = + catMaybes $ concat [[ + + case repoKind repo of + RepoKindUnknown kind -> Just $ PackageDistInexcusable $ + quote kind ++ " is not a recognised kind of source-repository. " + ++ "The repo kind is usually 'head' or 'this'" + _ -> Nothing + + , check (repoType repo == Nothing) $ + PackageDistInexcusable + "The source-repository 'type' is a required field." + + , check (repoLocation repo == Nothing) $ + PackageDistInexcusable + "The source-repository 'location' is a required field." + + , check (repoType repo == Just CVS && repoModule repo == Nothing) $ + PackageDistInexcusable + "For a CVS source-repository, the 'module' is a required field." + + , check (repoKind repo == RepoThis && repoTag repo == Nothing) $ + PackageDistInexcusable $ + "For the 'this' kind of source-repository, the 'tag' is a required " + ++ "field. It should specify the tag corresponding to this version " + ++ "or release of the package." + + , check (maybe False System.FilePath.isAbsolute (repoSubdir repo)) $ + PackageDistInexcusable + "The 'subdir' field of a source-repository must be a relative path." + ] + | repo <- sourceRepos pkg ] + +--TODO: check location looks like a URL for some repo types. + +checkGhcOptions :: PackageDescription -> [PackageCheck] +checkGhcOptions pkg = + catMaybes [ + + check has_WerrorWall $ + PackageDistInexcusable $ + "'ghc-options: -Wall -Werror' makes the package very easy to " + ++ "break with future GHC versions because new GHC versions often " + ++ "add new warnings. Use just 'ghc-options: -Wall' instead." + + , check (not has_WerrorWall && has_Werror) $ + PackageDistSuspicious $ + "'ghc-options: -Werror' makes the package easy to " + ++ "break with future GHC versions because new GHC versions often " + ++ "add new warnings." + + , checkFlags ["-fasm"] $ + PackageDistInexcusable $ + "'ghc-options: -fasm' is unnecessary and will not work on CPU " + ++ "architectures other than x86, x86-64, ppc or sparc." + + , checkFlags ["-fvia-C"] $ + PackageDistSuspicious $ + "'ghc-options: -fvia-C' is usually unnecessary. If your package " + ++ "needs -via-C for correctness rather than performance then it " + ++ "is using the FFI incorrectly and will probably not work with GHC " + ++ "6.10 or later." + + , checkFlags ["-fhpc"] $ + PackageDistInexcusable $ + "'ghc-options: -fhpc' is not appropriate for a distributed package." + + , check (any ("-d" `isPrefixOf`) all_ghc_options) $ + PackageDistInexcusable $ + "'ghc-options: -d*' debug flags are not appropriate for a distributed package." + + , checkFlags ["-prof"] $ + PackageBuildWarning $ + "'ghc-options: -prof' is not necessary and will lead to problems " + ++ "when used on a library. Use the configure flag " + ++ "--enable-library-profiling and/or --enable-executable-profiling." + + , checkFlags ["-o"] $ + PackageBuildWarning $ + "'ghc-options: -o' is not needed. The output files are named automatically." + + , checkFlags ["-hide-package"] $ + PackageBuildWarning $ + "'ghc-options: -hide-package' is never needed. Cabal hides all packages." + + , checkFlags ["--make"] $ + PackageBuildWarning $ + "'ghc-options: --make' is never needed. Cabal uses this automatically." + + , checkFlags ["-main-is"] $ + PackageDistSuspicious $ + "'ghc-options: -main-is' is not portable." + + , checkFlags ["-O0", "-Onot"] $ + PackageDistSuspicious $ + "'ghc-options: -O0' is not needed. Use the --disable-optimization configure flag." + + , checkFlags [ "-O", "-O1"] $ + PackageDistInexcusable $ + "'ghc-options: -O' is not needed. Cabal automatically adds the '-O' flag. " + ++ "Setting it yourself interferes with the --disable-optimization flag." + + , checkFlags ["-O2"] $ + PackageDistSuspicious $ + "'ghc-options: -O2' is rarely needed. Check that it is giving a real benefit " + ++ "and not just imposing longer compile times on your users." + + , checkFlags ["-split-objs"] $ + PackageBuildWarning $ + "'ghc-options: -split-objs' is not needed. Use the --enable-split-objs configure flag." + + , checkFlags ["-optl-Wl,-s", "-optl-s"] $ + PackageDistInexcusable $ + "'ghc-options: -optl-Wl,-s' is not needed and is not portable to all" + ++ " operating systems. Cabal 1.4 and later automatically strip" + ++ " executables. Cabal also has a flag --disable-executable-stripping" + ++ " which is necessary when building packages for some Linux" + ++ " distributions and using '-optl-Wl,-s' prevents that from working." + + , checkFlags ["-fglasgow-exts"] $ + PackageDistSuspicious $ + "Instead of 'ghc-options: -fglasgow-exts' it is preferable to use the 'extensions' field." + + , check ("-threaded" `elem` lib_ghc_options) $ + PackageDistSuspicious $ + "'ghc-options: -threaded' has no effect for libraries. It should " + ++ "only be used for executables." + + , checkAlternatives "ghc-options" "extensions" + [ (flag, display extension) | flag <- all_ghc_options + , Just extension <- [ghcExtension flag] ] + + , checkAlternatives "ghc-options" "extensions" + [ (flag, extension) | flag@('-':'X':extension) <- all_ghc_options ] + + , checkAlternatives "ghc-options" "cpp-options" $ + [ (flag, flag) | flag@('-':'D':_) <- all_ghc_options ] + ++ [ (flag, flag) | flag@('-':'U':_) <- all_ghc_options ] + + , checkAlternatives "ghc-options" "include-dirs" + [ (flag, dir) | flag@('-':'I':dir) <- all_ghc_options ] + + , checkAlternatives "ghc-options" "extra-libraries" + [ (flag, lib) | flag@('-':'l':lib) <- all_ghc_options ] + + , checkAlternatives "ghc-options" "extra-lib-dirs" + [ (flag, dir) | flag@('-':'L':dir) <- all_ghc_options ] + ] + + where + has_WerrorWall = flip any ghc_options $ \opts -> + "-Werror" `elem` opts + && ("-Wall" `elem` opts || "-W" `elem` opts) + has_Werror = any (\opts -> "-Werror" `elem` opts) ghc_options + + ghc_options = [ strs | bi <- allBuildInfo pkg + , (GHC, strs) <- options bi ] + all_ghc_options = concat ghc_options + lib_ghc_options = maybe [] (hcOptions GHC . libBuildInfo) (library pkg) + + checkFlags :: [String] -> PackageCheck -> Maybe PackageCheck + checkFlags flags = check (any (`elem` flags) all_ghc_options) + + ghcExtension ('-':'f':name) = case name of + "allow-overlapping-instances" -> Just (EnableExtension OverlappingInstances) + "no-allow-overlapping-instances" -> Just (DisableExtension OverlappingInstances) + "th" -> Just (EnableExtension TemplateHaskell) + "no-th" -> Just (DisableExtension TemplateHaskell) + "ffi" -> Just (EnableExtension ForeignFunctionInterface) + "no-ffi" -> Just (DisableExtension ForeignFunctionInterface) + "fi" -> Just (EnableExtension ForeignFunctionInterface) + "no-fi" -> Just (DisableExtension ForeignFunctionInterface) + "monomorphism-restriction" -> Just (EnableExtension MonomorphismRestriction) + "no-monomorphism-restriction" -> Just (DisableExtension MonomorphismRestriction) + "mono-pat-binds" -> Just (EnableExtension MonoPatBinds) + "no-mono-pat-binds" -> Just (DisableExtension MonoPatBinds) + "allow-undecidable-instances" -> Just (EnableExtension UndecidableInstances) + "no-allow-undecidable-instances" -> Just (DisableExtension UndecidableInstances) + "allow-incoherent-instances" -> Just (EnableExtension IncoherentInstances) + "no-allow-incoherent-instances" -> Just (DisableExtension IncoherentInstances) + "arrows" -> Just (EnableExtension Arrows) + "no-arrows" -> Just (DisableExtension Arrows) + "generics" -> Just (EnableExtension Generics) + "no-generics" -> Just (DisableExtension Generics) + "implicit-prelude" -> Just (EnableExtension ImplicitPrelude) + "no-implicit-prelude" -> Just (DisableExtension ImplicitPrelude) + "implicit-params" -> Just (EnableExtension ImplicitParams) + "no-implicit-params" -> Just (DisableExtension ImplicitParams) + "bang-patterns" -> Just (EnableExtension BangPatterns) + "no-bang-patterns" -> Just (DisableExtension BangPatterns) + "scoped-type-variables" -> Just (EnableExtension ScopedTypeVariables) + "no-scoped-type-variables" -> Just (DisableExtension ScopedTypeVariables) + "extended-default-rules" -> Just (EnableExtension ExtendedDefaultRules) + "no-extended-default-rules" -> Just (DisableExtension ExtendedDefaultRules) + _ -> Nothing + ghcExtension "-cpp" = Just (EnableExtension CPP) + ghcExtension _ = Nothing + +checkCCOptions :: PackageDescription -> [PackageCheck] +checkCCOptions pkg = + catMaybes [ + + checkAlternatives "cc-options" "include-dirs" + [ (flag, dir) | flag@('-':'I':dir) <- all_ccOptions ] + + , checkAlternatives "cc-options" "extra-libraries" + [ (flag, lib) | flag@('-':'l':lib) <- all_ccOptions ] + + , checkAlternatives "cc-options" "extra-lib-dirs" + [ (flag, dir) | flag@('-':'L':dir) <- all_ccOptions ] + + , checkAlternatives "ld-options" "extra-libraries" + [ (flag, lib) | flag@('-':'l':lib) <- all_ldOptions ] + + , checkAlternatives "ld-options" "extra-lib-dirs" + [ (flag, dir) | flag@('-':'L':dir) <- all_ldOptions ] + + , checkCCFlags [ "-O", "-Os", "-O0", "-O1", "-O2", "-O3" ] $ + PackageDistSuspicious $ + "'cc-options: -O[n]' is generally not needed. When building with " + ++ " optimisations Cabal automatically adds '-O2' for C code. " + ++ "Setting it yourself interferes with the --disable-optimization " + ++ "flag." + ] + + where all_ccOptions = [ opts | bi <- allBuildInfo pkg + , opts <- ccOptions bi ] + all_ldOptions = [ opts | bi <- allBuildInfo pkg + , opts <- ldOptions bi ] + + checkCCFlags :: [String] -> PackageCheck -> Maybe PackageCheck + checkCCFlags flags = check (any (`elem` flags) all_ccOptions) + +checkAlternatives :: String -> String -> [(String, String)] -> Maybe PackageCheck +checkAlternatives badField goodField flags = + check (not (null badFlags)) $ + PackageBuildWarning $ + "Instead of " ++ quote (badField ++ ": " ++ unwords badFlags) + ++ " use " ++ quote (goodField ++ ": " ++ unwords goodFlags) + + where (badFlags, goodFlags) = unzip flags + +checkPaths :: PackageDescription -> [PackageCheck] +checkPaths pkg = + [ PackageBuildWarning $ + quote (kind ++ ": " ++ path) + ++ " is a relative path outside of the source tree. " + ++ "This will not work when generating a tarball with 'sdist'." + | (path, kind) <- relPaths ++ absPaths + , isOutsideTree path ] + ++ + [ PackageDistInexcusable $ + quote (kind ++ ": " ++ path) ++ " is an absolute directory." + | (path, kind) <- relPaths + , isAbsolute path ] + ++ + [ PackageDistInexcusable $ + quote (kind ++ ": " ++ path) ++ " points inside the 'dist' " + ++ "directory. This is not reliable because the location of this " + ++ "directory is configurable by the user (or package manager). In " + ++ "addition the layout of the 'dist' directory is subject to change " + ++ "in future versions of Cabal." + | (path, kind) <- relPaths ++ absPaths + , isInsideDist path ] + ++ + [ PackageDistInexcusable $ + "The 'ghc-options' contains the path '" ++ path ++ "' which points " + ++ "inside the 'dist' directory. This is not reliable because the " + ++ "location of this directory is configurable by the user (or package " + ++ "manager). In addition the layout of the 'dist' directory is subject " + ++ "to change in future versions of Cabal." + | bi <- allBuildInfo pkg + , (GHC, flags) <- options bi + , path <- flags + , isInsideDist path ] + where + isOutsideTree path = case splitDirectories path of + "..":_ -> True + ".":"..":_ -> True + _ -> False + isInsideDist path = case map lowercase (splitDirectories path) of + "dist" :_ -> True + ".":"dist":_ -> True + _ -> False + -- paths that must be relative + relPaths = + [ (path, "extra-src-files") | path <- extraSrcFiles pkg ] + ++ [ (path, "extra-tmp-files") | path <- extraTmpFiles pkg ] + ++ [ (path, "data-files") | path <- dataFiles pkg ] + ++ [ (path, "data-dir") | path <- [dataDir pkg]] + ++ concat + [ [ (path, "c-sources") | path <- cSources bi ] + ++ [ (path, "install-includes") | path <- installIncludes bi ] + ++ [ (path, "hs-source-dirs") | path <- hsSourceDirs bi ] + | bi <- allBuildInfo pkg ] + -- paths that are allowed to be absolute + absPaths = concat + [ [ (path, "includes") | path <- includes bi ] + ++ [ (path, "include-dirs") | path <- includeDirs bi ] + ++ [ (path, "extra-lib-dirs") | path <- extraLibDirs bi ] + | bi <- allBuildInfo pkg ] + +--TODO: check sets of paths that would be interpreted differently between unix +-- and windows, ie case-sensitive or insensitive. Things that might clash, or +-- conversely be distinguished. + +--TODO: use the tar path checks on all the above paths + +-- | Check that the package declares the version in the @\"cabal-version\"@ +-- field correctly. +-- +checkCabalVersion :: PackageDescription -> [PackageCheck] +checkCabalVersion pkg = + catMaybes [ + + -- check syntax of cabal-version field + check (specVersion pkg >= Version [1,10] [] + && not simpleSpecVersionRangeSyntax) $ + PackageBuildWarning $ + "Packages relying on Cabal 1.10 or later must only specify a " + ++ "version range of the form 'cabal-version: >= x.y'. Use " + ++ "'cabal-version: >= " ++ display (specVersion pkg) ++ "'." + + -- check syntax of cabal-version field + , check (specVersion pkg < Version [1,9] [] + && not simpleSpecVersionRangeSyntax) $ + PackageDistSuspicious $ + "It is recommended that the 'cabal-version' field only specify a " + ++ "version range of the form '>= x.y'. Use " + ++ "'cabal-version: >= " ++ display (specVersion pkg) ++ "'. " + ++ "Tools based on Cabal 1.10 and later will ignore upper bounds." + + -- check syntax of cabal-version field + , checkVersion [1,12] simpleSpecVersionSyntax $ + PackageBuildWarning $ + "With Cabal 1.10 or earlier, the 'cabal-version' field must use " + ++ "range syntax rather than a simple version number. Use " + ++ "'cabal-version: >= " ++ display (specVersion pkg) ++ "'." + + -- check use of test suite sections + , checkVersion [1,8] (not (null $ testSuites pkg)) $ + PackageDistInexcusable $ + "The 'test-suite' section is new in Cabal 1.10. " + ++ "Unfortunately it messes up the parser in older Cabal versions " + ++ "so you must specify at least 'cabal-version: >= 1.8', but note" + ++ "that only Cabal 1.10 and later can actually run such test suites." + + -- check use of default-language field + -- note that we do not need to do an equivalent check for the + -- other-language field since that one does not change behaviour + , checkVersion [1,10] (any isJust (buildInfoField defaultLanguage)) $ + PackageBuildWarning $ + "To use the 'default-language' field the package needs to specify " + ++ "at least 'cabal-version: >= 1.10'." + + , check (specVersion pkg >= Version [1,10] [] + && (any isNothing (buildInfoField defaultLanguage))) $ + PackageBuildWarning $ + "Packages using 'cabal-version: >= 1.10' must specify the " + ++ "'default-language' field for each component (e.g. Haskell98 or " + ++ "Haskell2010). If a component uses different languages in " + ++ "different modules then list the other ones in the " + ++ "'other-languages' field." + + -- check use of default-extensions field + -- don't need to do the equivalent check for other-extensions + , checkVersion [1,10] (any (not . null) (buildInfoField defaultExtensions)) $ + PackageBuildWarning $ + "To use the 'default-extensions' field the package needs to specify " + ++ "at least 'cabal-version: >= 1.10'." + + -- check use of extensions field + , check (specVersion pkg >= Version [1,10] [] + && (any (not . null) (buildInfoField oldExtensions))) $ + PackageBuildWarning $ + "For packages using 'cabal-version: >= 1.10' the 'extensions' " + ++ "field is deprecated. The new 'default-extensions' field lists " + ++ "extensions that are used in all modules in the component, while " + ++ "the 'other-extensions' field lists extensions that are used in " + ++ "some modules, e.g. via the {-# LANGUAGE #-} pragma." + + -- check use of "foo (>= 1.0 && < 1.4) || >=1.8 " version-range syntax + , checkVersion [1,8] (not (null versionRangeExpressions)) $ + PackageDistInexcusable $ + "The package uses full version-range expressions " + ++ "in a 'build-depends' field: " + ++ commaSep (map displayRawDependency versionRangeExpressions) + ++ ". To use this new syntax the package needs to specify at least " + ++ "'cabal-version: >= 1.8'. Alternatively, if broader compatibility " + ++ "is important, then convert to conjunctive normal form, and use " + ++ "multiple 'build-depends:' lines, one conjunct per line." + + -- check use of "build-depends: foo == 1.*" syntax + , checkVersion [1,6] (not (null depsUsingWildcardSyntax)) $ + PackageDistInexcusable $ + "The package uses wildcard syntax in the 'build-depends' field: " + ++ commaSep (map display depsUsingWildcardSyntax) + ++ ". To use this new syntax the package need to specify at least " + ++ "'cabal-version: >= 1.6'. Alternatively, if broader compatability " + ++ "is important then use: " ++ commaSep + [ display (Dependency name (eliminateWildcardSyntax versionRange)) + | Dependency name versionRange <- depsUsingWildcardSyntax ] + + -- check use of "tested-with: GHC (>= 1.0 && < 1.4) || >=1.8 " syntax + , checkVersion [1,8] (not (null testedWithVersionRangeExpressions)) $ + PackageDistInexcusable $ + "The package uses full version-range expressions " + ++ "in a 'tested-with' field: " + ++ commaSep (map displayRawDependency testedWithVersionRangeExpressions) + ++ ". To use this new syntax the package needs to specify at least " + ++ "'cabal-version: >= 1.8'." + + -- check use of "tested-with: GHC == 6.12.*" syntax + , checkVersion [1,6] (not (null testedWithUsingWildcardSyntax)) $ + PackageDistInexcusable $ + "The package uses wildcard syntax in the 'tested-with' field: " + ++ commaSep (map display testedWithUsingWildcardSyntax) + ++ ". To use this new syntax the package need to specify at least " + ++ "'cabal-version: >= 1.6'. Alternatively, if broader compatability " + ++ "is important then use: " ++ commaSep + [ display (Dependency name (eliminateWildcardSyntax versionRange)) + | Dependency name versionRange <- testedWithUsingWildcardSyntax ] + + -- check use of "data-files: data/*.txt" syntax + , checkVersion [1,6] (not (null dataFilesUsingGlobSyntax)) $ + PackageDistInexcusable $ + "Using wildcards like " + ++ commaSep (map quote $ take 3 dataFilesUsingGlobSyntax) + ++ " in the 'data-files' field requires 'cabal-version: >= 1.6'. " + ++ "Alternatively if you require compatability with earlier Cabal " + ++ "versions then list all the files explicitly." + + -- check use of "extra-source-files: mk/*.in" syntax + , checkVersion [1,6] (not (null extraSrcFilesUsingGlobSyntax)) $ + PackageDistInexcusable $ + "Using wildcards like " + ++ commaSep (map quote $ take 3 extraSrcFilesUsingGlobSyntax) + ++ " in the 'extra-source-files' field requires " + ++ "'cabal-version: >= 1.6'. Alternatively if you require " + ++ "compatability with earlier Cabal versions then list all the files " + ++ "explicitly." + + -- check use of "source-repository" section + , checkVersion [1,6] (not (null (sourceRepos pkg))) $ + PackageDistInexcusable $ + "The 'source-repository' section is new in Cabal 1.6. " + ++ "Unfortunately it messes up the parser in earlier Cabal versions " + ++ "so you need to specify 'cabal-version: >= 1.6'." + + -- check for new licenses + , checkVersion [1,4] (license pkg `notElem` compatLicenses) $ + PackageDistInexcusable $ + "Unfortunately the license " ++ quote (display (license pkg)) + ++ " messes up the parser in earlier Cabal versions so you need to " + ++ "specify 'cabal-version: >= 1.4'. Alternatively if you require " + ++ "compatability with earlier Cabal versions then use 'OtherLicense'." + + -- check for new language extensions + , checkVersion [1,2,3] (not (null mentionedExtensionsThatNeedCabal12)) $ + PackageDistInexcusable $ + "Unfortunately the language extensions " + ++ commaSep (map (quote . display) mentionedExtensionsThatNeedCabal12) + ++ " break the parser in earlier Cabal versions so you need to " + ++ "specify 'cabal-version: >= 1.2.3'. Alternatively if you require " + ++ "compatability with earlier Cabal versions then you may be able to " + ++ "use an equivalent compiler-specific flag." + + , checkVersion [1,4] (not (null mentionedExtensionsThatNeedCabal14)) $ + PackageDistInexcusable $ + "Unfortunately the language extensions " + ++ commaSep (map (quote . display) mentionedExtensionsThatNeedCabal14) + ++ " break the parser in earlier Cabal versions so you need to " + ++ "specify 'cabal-version: >= 1.4'. Alternatively if you require " + ++ "compatability with earlier Cabal versions then you may be able to " + ++ "use an equivalent compiler-specific flag." + ] + where + -- Perform a check on packages that use a version of the spec less than + -- the version given. This is for cases where a new Cabal version adds + -- a new feature and we want to check that it is not used prior to that + -- version. + checkVersion :: [Int] -> Bool -> PackageCheck -> Maybe PackageCheck + checkVersion ver cond pc + | specVersion pkg >= Version ver [] = Nothing + | otherwise = check cond pc + + buildInfoField field = map field (allBuildInfo pkg) + dataFilesUsingGlobSyntax = filter usesGlobSyntax (dataFiles pkg) + extraSrcFilesUsingGlobSyntax = filter usesGlobSyntax (extraSrcFiles pkg) + usesGlobSyntax str = case parseFileGlob str of + Just (FileGlob _ _) -> True + _ -> False + + versionRangeExpressions = + [ dep | dep@(Dependency _ vr) <- buildDepends pkg + , usesNewVersionRangeSyntax vr ] + + testedWithVersionRangeExpressions = + [ Dependency (PackageName (display compiler)) vr + | (compiler, vr) <- testedWith pkg + , usesNewVersionRangeSyntax vr ] + + simpleSpecVersionRangeSyntax = + either (const True) + (foldVersionRange' + True + (\_ -> False) + (\_ -> False) (\_ -> False) + (\_ -> True) -- >= + (\_ -> False) + (\_ _ -> False) + (\_ _ -> False) (\_ _ -> False) + id) + (specVersionRaw pkg) + + -- is the cabal-version field a simple version number, rather than a range + simpleSpecVersionSyntax = + either (const True) (const False) (specVersionRaw pkg) + + usesNewVersionRangeSyntax :: VersionRange -> Bool + usesNewVersionRangeSyntax = + (> 2) -- uses the new syntax if depth is more than 2 + . foldVersionRange' + (1 :: Int) + (const 1) + (const 1) (const 1) + (const 1) (const 1) + (const (const 1)) + (+) (+) + (const 3) -- uses new ()'s syntax + + depsUsingWildcardSyntax = [ dep | dep@(Dependency _ vr) <- buildDepends pkg + , usesWildcardSyntax vr ] + + testedWithUsingWildcardSyntax = [ Dependency (PackageName (display compiler)) vr + | (compiler, vr) <- testedWith pkg + , usesWildcardSyntax vr ] + + usesWildcardSyntax :: VersionRange -> Bool + usesWildcardSyntax = + foldVersionRange' + False (const False) + (const False) (const False) + (const False) (const False) + (\_ _ -> True) -- the wildcard case + (||) (||) id + + eliminateWildcardSyntax = + foldVersionRange' + anyVersion thisVersion + laterVersion earlierVersion + orLaterVersion orEarlierVersion + (\v v' -> intersectVersionRanges (orLaterVersion v) (earlierVersion v')) + intersectVersionRanges unionVersionRanges id + + compatLicenses = [ GPL Nothing, LGPL Nothing, BSD3, BSD4 + , PublicDomain, AllRightsReserved, OtherLicense ] + + mentionedExtensions = [ ext | bi <- allBuildInfo pkg + , ext <- allExtensions bi ] + mentionedExtensionsThatNeedCabal12 = + nub (filter (`elem` compatExtensionsExtra) mentionedExtensions) + + -- As of Cabal-1.4 we can add new extensions without worrying about + -- breaking old versions of cabal. + mentionedExtensionsThatNeedCabal14 = + nub (filter (`notElem` compatExtensions) mentionedExtensions) + + -- The known extensions in Cabal-1.2.3 + compatExtensions = + map EnableExtension + [ OverlappingInstances, UndecidableInstances, IncoherentInstances + , RecursiveDo, ParallelListComp, MultiParamTypeClasses + , FunctionalDependencies, Rank2Types + , RankNTypes, PolymorphicComponents, ExistentialQuantification + , ScopedTypeVariables, ImplicitParams, FlexibleContexts + , FlexibleInstances, EmptyDataDecls, CPP, BangPatterns + , TypeSynonymInstances, TemplateHaskell, ForeignFunctionInterface + , Arrows, Generics, NamedFieldPuns, PatternGuards + , GeneralizedNewtypeDeriving, ExtensibleRecords, RestrictedTypeSynonyms + , HereDocuments] ++ + map DisableExtension + [MonomorphismRestriction, ImplicitPrelude] ++ + compatExtensionsExtra + + -- The extra known extensions in Cabal-1.2.3 vs Cabal-1.1.6 + -- (Cabal-1.1.6 came with ghc-6.6. Cabal-1.2 came with ghc-6.8) + compatExtensionsExtra = + map EnableExtension + [ KindSignatures, MagicHash, TypeFamilies, StandaloneDeriving + , UnicodeSyntax, PatternSignatures, UnliftedFFITypes, LiberalTypeSynonyms + , TypeOperators, RecordWildCards, RecordPuns, DisambiguateRecordFields + , OverloadedStrings, GADTs, RelaxedPolyRec + , ExtendedDefaultRules, UnboxedTuples, DeriveDataTypeable + , ConstrainedClassMethods + ] ++ + map DisableExtension + [MonoPatBinds] + +-- | A variation on the normal 'Text' instance, shows any ()'s in the original +-- textual syntax. We need to show these otherwise it's confusing to users when +-- we complain of their presense but do not pretty print them! +-- +displayRawVersionRange :: VersionRange -> String +displayRawVersionRange = + Disp.render + . fst + . foldVersionRange' -- precedence: + -- All the same as the usual pretty printer, except for the parens + ( Disp.text "-any" , 0 :: Int) + (\v -> (Disp.text "==" <> disp v , 0)) + (\v -> (Disp.char '>' <> disp v , 0)) + (\v -> (Disp.char '<' <> disp v , 0)) + (\v -> (Disp.text ">=" <> disp v , 0)) + (\v -> (Disp.text "<=" <> disp v , 0)) + (\v _ -> (Disp.text "==" <> dispWild v , 0)) + (\(r1, p1) (r2, p2) -> (punct 2 p1 r1 <+> Disp.text "||" <+> punct 2 p2 r2 , 2)) + (\(r1, p1) (r2, p2) -> (punct 1 p1 r1 <+> Disp.text "&&" <+> punct 1 p2 r2 , 1)) + (\(r, _ ) -> (Disp.parens r, 0)) -- parens + + where + dispWild (Version b _) = + Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int b)) + <> Disp.text ".*" + punct p p' | p < p' = Disp.parens + | otherwise = id + +displayRawDependency :: Dependency -> String +displayRawDependency (Dependency pkg vr) = + display pkg ++ " " ++ displayRawVersionRange vr + + +-- ------------------------------------------------------------ +-- * Checks on the GenericPackageDescription +-- ------------------------------------------------------------ + +-- | Check the build-depends fields for any weirdness or bad practise. +-- +checkPackageVersions :: GenericPackageDescription -> [PackageCheck] +checkPackageVersions pkg = + catMaybes [ + + -- Check that the version of base is bounded above. + -- For example this bans "build-depends: base >= 3". + -- It should probably be "build-depends: base >= 3 && < 4" + -- which is the same as "build-depends: base == 3.*" + check (not (boundedAbove baseDependency)) $ + PackageDistInexcusable $ + "The dependency 'build-depends: base' does not specify an upper " + ++ "bound on the version number. Each major release of the 'base' " + ++ "package changes the API in various ways and most packages will " + ++ "need some changes to compile with it. The recommended practise " + ++ "is to specify an upper bound on the version of the 'base' " + ++ "package. This ensures your package will continue to build when a " + ++ "new major version of the 'base' package is released. If you are " + ++ "not sure what upper bound to use then use the next major " + ++ "version. For example if you have tested your package with 'base' " + ++ "version 2 and 3 then use 'build-depends: base >= 2 && < 4'." + + ] + where + -- TODO: What we really want to do is test if there exists any + -- configuration in which the base version is unboudned above. + -- However that's a bit tricky because there are many possible + -- configurations. As a cheap easy and safe approximation we will + -- pick a single "typical" configuration and check if that has an + -- open upper bound. To get a typical configuration we finalise + -- using no package index and the current platform. + finalised = finalizePackageDescription + [] (const True) buildPlatform + (CompilerId buildCompilerFlavor (Version [] [])) + [] pkg + baseDependency = case finalised of + Right (pkg', _) | not (null baseDeps) -> + foldr intersectVersionRanges anyVersion baseDeps + where + baseDeps = + [ vr | Dependency (PackageName "base") vr <- buildDepends pkg' ] + + -- Just in case finalizePackageDescription fails for any reason, + -- or if the package doesn't depend on the base package at all, + -- then we will just skip the check, since boundedAbove noVersion = True + _ -> noVersion + + boundedAbove :: VersionRange -> Bool + boundedAbove vr = case asVersionIntervals vr of + [] -> True -- this is the inconsistent version range. + intervals -> case last intervals of + (_, UpperBound _ _) -> True + (_, NoUpperBound ) -> False + + +checkConditionals :: GenericPackageDescription -> [PackageCheck] +checkConditionals pkg = + catMaybes [ + + check (not $ null unknownOSs) $ + PackageDistInexcusable $ + "Unknown operating system name " + ++ commaSep (map quote unknownOSs) + + , check (not $ null unknownArches) $ + PackageDistInexcusable $ + "Unknown architecture name " + ++ commaSep (map quote unknownArches) + + , check (not $ null unknownImpls) $ + PackageDistInexcusable $ + "Unknown compiler name " + ++ commaSep (map quote unknownImpls) + ] + where + unknownOSs = [ os | OS (OtherOS os) <- conditions ] + unknownArches = [ arch | Arch (OtherArch arch) <- conditions ] + unknownImpls = [ impl | Impl (OtherCompiler impl) _ <- conditions ] + conditions = maybe [] freeVars (condLibrary pkg) + ++ concatMap (freeVars . snd) (condExecutables pkg) + freeVars (CondNode _ _ ifs) = concatMap compfv ifs + compfv (c, ct, mct) = condfv c ++ freeVars ct ++ maybe [] freeVars mct + condfv c = case c of + Var v -> [v] + Lit _ -> [] + CNot c1 -> condfv c1 + COr c1 c2 -> condfv c1 ++ condfv c2 + CAnd c1 c2 -> condfv c1 ++ condfv c2 + +-- ------------------------------------------------------------ +-- * Checks involving files in the package +-- ------------------------------------------------------------ + +-- | Sanity check things that requires IO. It looks at the files in the +-- package and expects to find the package unpacked in at the given filepath. +-- +checkPackageFiles :: PackageDescription -> FilePath -> IO [PackageCheck] +checkPackageFiles pkg root = checkPackageContent checkFilesIO pkg + where + checkFilesIO = CheckPackageContentOps { + doesFileExist = System.doesFileExist . relative, + doesDirectoryExist = System.doesDirectoryExist . relative + } + relative path = root path + +-- | A record of operations needed to check the contents of packages. +-- Used by 'checkPackageContent'. +-- +data CheckPackageContentOps m = CheckPackageContentOps { + doesFileExist :: FilePath -> m Bool, + doesDirectoryExist :: FilePath -> m Bool + } + +-- | Sanity check things that requires looking at files in the package. +-- This is a generalised version of 'checkPackageFiles' that can work in any +-- monad for which you can provide 'CheckPackageContentOps' operations. +-- +-- The point of this extra generality is to allow doing checks in some virtual +-- file system, for example a tarball in memory. +-- +checkPackageContent :: Monad m => CheckPackageContentOps m + -> PackageDescription + -> m [PackageCheck] +checkPackageContent ops pkg = do + licenseError <- checkLicenseExists ops pkg + setupError <- checkSetupExists ops pkg + configureError <- checkConfigureExists ops pkg + localPathErrors <- checkLocalPathsExist ops pkg + vcsLocation <- checkMissingVcsInfo ops pkg + + return $ catMaybes [licenseError, setupError, configureError] + ++ localPathErrors + ++ vcsLocation + +checkLicenseExists :: Monad m => CheckPackageContentOps m + -> PackageDescription + -> m (Maybe PackageCheck) +checkLicenseExists ops pkg + | null (licenseFile pkg) = return Nothing + | otherwise = do + exists <- doesFileExist ops file + return $ check (not exists) $ + PackageBuildWarning $ + "The 'license-file' field refers to the file " ++ quote file + ++ " which does not exist." + + where + file = licenseFile pkg + +checkSetupExists :: Monad m => CheckPackageContentOps m + -> PackageDescription + -> m (Maybe PackageCheck) +checkSetupExists ops _ = do + hsexists <- doesFileExist ops "Setup.hs" + lhsexists <- doesFileExist ops "Setup.lhs" + return $ check (not hsexists && not lhsexists) $ + PackageDistInexcusable $ + "The package is missing a Setup.hs or Setup.lhs script." + +checkConfigureExists :: Monad m => CheckPackageContentOps m + -> PackageDescription + -> m (Maybe PackageCheck) +checkConfigureExists ops PackageDescription { buildType = Just Configure } = do + exists <- doesFileExist ops "configure" + return $ check (not exists) $ + PackageBuildWarning $ + "The 'build-type' is 'Configure' but there is no 'configure' script." +checkConfigureExists _ _ = return Nothing + +checkLocalPathsExist :: Monad m => CheckPackageContentOps m + -> PackageDescription + -> m [PackageCheck] +checkLocalPathsExist ops pkg = do + let dirs = [ (dir, kind) + | bi <- allBuildInfo pkg + , (dir, kind) <- + [ (dir, "extra-lib-dirs") | dir <- extraLibDirs bi ] + ++ [ (dir, "include-dirs") | dir <- includeDirs bi ] + ++ [ (dir, "hs-source-dirs") | dir <- hsSourceDirs bi ] + , isRelative dir ] + missing <- filterM (liftM not . doesDirectoryExist ops . fst) dirs + return [ PackageBuildWarning { + explanation = quote (kind ++ ": " ++ dir) + ++ " directory does not exist." + } + | (dir, kind) <- missing ] + +checkMissingVcsInfo :: Monad m => CheckPackageContentOps m + -> PackageDescription + -> m [PackageCheck] +checkMissingVcsInfo ops pkg | null (sourceRepos pkg) = do + vcsInUse <- liftM or $ mapM (doesDirectoryExist ops) repoDirnames + if vcsInUse + then return [ PackageDistSuspicious message ] + else return [] + where + repoDirnames = [ dirname | repo <- knownRepoTypes + , dirname <- repoTypeDirname repo ] + message = "When distributing packages it is encouraged to specify source " + ++ "control information in the .cabal file using one or more " + ++ "'source-repository' sections. See the Cabal user guide for " + ++ "details." + +checkMissingVcsInfo _ _ = return [] + +repoTypeDirname :: RepoType -> [FilePath] +repoTypeDirname Darcs = ["_darcs"] +repoTypeDirname Git = [".git"] +repoTypeDirname SVN = [".svn"] +repoTypeDirname CVS = ["CVS"] +repoTypeDirname Mercurial = [".hg"] +repoTypeDirname GnuArch = [".arch-params"] +repoTypeDirname Bazaar = [".bzr"] +repoTypeDirname Monotone = ["_MTN"] +repoTypeDirname _ = [] + +-- ------------------------------------------------------------ +-- * Checks involving files in the package +-- ------------------------------------------------------------ + +-- | Check the names of all files in a package for portability problems. This +-- should be done for example when creating or validating a package tarball. +-- +checkPackageFileNames :: [FilePath] -> [PackageCheck] +checkPackageFileNames files = + (take 1 . catMaybes . map checkWindowsPath $ files) + ++ (take 1 . catMaybes . map checkTarPath $ files) + -- If we get any of these checks triggering then we're likely to get + -- many, and that's probably not helpful, so return at most one. + +checkWindowsPath :: FilePath -> Maybe PackageCheck +checkWindowsPath path = + check (not $ FilePath.Windows.isValid path') $ + PackageDistInexcusable $ + "Unfortunately, the file " ++ quote path ++ " is not a valid file " + ++ "name on Windows which would cause portability problems for this " + ++ "package. Windows file names cannot contain any of the characters " + ++ "\":*?<>|\" and there are a few reserved names including \"aux\", " + ++ "\"nul\", \"con\", \"prn\", \"com1-9\", \"lpt1-9\" and \"clock$\"." + where + path' = ".\\" ++ path + -- force a relative name to catch invalid file names like "f:oo" which + -- otherwise parse as file "oo" in the current directory on the 'f' drive. + +-- | Check a file name is valid for the portable POSIX tar format. +-- +-- The POSIX tar format has a restriction on the length of file names. It is +-- unfortunately not a simple restriction like a maximum length. The exact +-- restriction is that either the whole path be 100 characters or less, or it +-- be possible to split the path on a directory separator such that the first +-- part is 155 characters or less and the second part 100 characters or less. +-- +checkTarPath :: FilePath -> Maybe PackageCheck +checkTarPath path + | length path > 255 = Just longPath + | otherwise = case pack nameMax (reverse (splitPath path)) of + Left err -> Just err + Right [] -> Nothing + Right (first:rest) -> case pack prefixMax remainder of + Left err -> Just err + Right [] -> Nothing + Right (_:_) -> Just noSplit + where + -- drop the '/' between the name and prefix: + remainder = init first : rest + + where + nameMax, prefixMax :: Int + nameMax = 100 + prefixMax = 155 + + pack _ [] = Left emptyName + pack maxLen (c:cs) + | n > maxLen = Left longName + | otherwise = Right (pack' maxLen n cs) + where n = length c + + pack' maxLen n (c:cs) + | n' <= maxLen = pack' maxLen n' cs + where n' = n + length c + pack' _ _ cs = cs + + longPath = PackageDistInexcusable $ + "The following file name is too long to store in a portable POSIX " + ++ "format tar archive. The maximum length is 255 ASCII characters.\n" + ++ "The file in question is:\n " ++ path + longName = PackageDistInexcusable $ + "The following file name is too long to store in a portable POSIX " + ++ "format tar archive. The maximum length for the name part (including " + ++ "extension) is 100 ASCII characters. The maximum length for any " + ++ "individual directory component is 155.\n" + ++ "The file in question is:\n " ++ path + noSplit = PackageDistInexcusable $ + "The following file name is too long to store in a portable POSIX " + ++ "format tar archive. While the total length is less than 255 ASCII " + ++ "characters, there are unfortunately further restrictions. It has to " + ++ "be possible to split the file path on a directory separator into " + ++ "two parts such that the first part fits in 155 characters or less " + ++ "and the second part fits in 100 characters or less. Basically you " + ++ "have to make the file name or directory names shorter, or you could " + ++ "split a long directory name into nested subdirectories with shorter " + ++ "names.\nThe file in question is:\n " ++ path + emptyName = PackageDistInexcusable $ + "Encountered a file with an empty name, something is very wrong! " + ++ "Files with an empty name cannot be stored in a tar archive or in " + ++ "standard file systems." + +-- ------------------------------------------------------------ +-- * Utils +-- ------------------------------------------------------------ + +quote :: String -> String +quote s = "'" ++ s ++ "'" + +commaSep :: [String] -> String +commaSep = intercalate ", " + +dups :: Ord a => [a] -> [a] +dups xs = [ x | (x:_:_) <- group (sort xs) ] diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/PackageDescription/Configuration.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/PackageDescription/Configuration.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/PackageDescription/Configuration.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/PackageDescription/Configuration.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,618 @@ +{-# OPTIONS -cpp #-} +-- OPTIONS required for ghc-6.4.x compat, and must appear first +{-# LANGUAGE CPP #-} +-- -fno-warn-deprecations for use of Map.foldWithKey +{-# OPTIONS_GHC -cpp -fno-warn-deprecations #-} +{-# OPTIONS_NHC98 -cpp #-} +{-# OPTIONS_JHC -fcpp #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Configuration +-- Copyright : Thomas Schilling, 2007 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is about the cabal configurations feature. It exports +-- 'finalizePackageDescription' and 'flattenPackageDescription' which are +-- functions for converting 'GenericPackageDescription's down to +-- 'PackageDescription's. It has code for working with the tree of conditions +-- and resolving or flattening conditions. + +{- All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.PackageDescription.Configuration ( + finalizePackageDescription, + flattenPackageDescription, + + -- Utils + parseCondition, + freeVars, + mapCondTree, + mapTreeData, + mapTreeConds, + mapTreeConstrs, + ) where + +import Distribution.Package + ( PackageName, Dependency(..) ) +import Distribution.PackageDescription + ( GenericPackageDescription(..), PackageDescription(..) + , Library(..), Executable(..), BuildInfo(..) + , Flag(..), FlagName(..), FlagAssignment + , CondTree(..), ConfVar(..), Condition(..), TestSuite(..) ) +import Distribution.Version + ( VersionRange, anyVersion, intersectVersionRanges, withinRange ) +import Distribution.Compiler + ( CompilerId(CompilerId) ) +import Distribution.System + ( Platform(..), OS, Arch ) +import Distribution.Simple.Utils + ( currentDir, lowercase ) + +import Distribution.Text + ( Text(parse) ) +import Distribution.Compat.ReadP as ReadP hiding ( char ) +import Control.Arrow (first) +import qualified Distribution.Compat.ReadP as ReadP ( char ) + +import Data.Char ( isAlphaNum ) +import Data.Maybe ( catMaybes, maybeToList ) +import Data.Map ( Map, fromListWith, toList ) +import qualified Data.Map as Map +import Data.Monoid + +#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ < 606) +import qualified Text.Read as R +import qualified Text.Read.Lex as L +#endif + +------------------------------------------------------------------------------ + +-- | Simplify the condition and return its free variables. +simplifyCondition :: Condition c + -> (c -> Either d Bool) -- ^ (partial) variable assignment + -> (Condition d, [d]) +simplifyCondition cond i = fv . walk $ cond + where + walk cnd = case cnd of + Var v -> either Var Lit (i v) + Lit b -> Lit b + CNot c -> case walk c of + Lit True -> Lit False + Lit False -> Lit True + c' -> CNot c' + COr c d -> case (walk c, walk d) of + (Lit False, d') -> d' + (Lit True, _) -> Lit True + (c', Lit False) -> c' + (_, Lit True) -> Lit True + (c',d') -> COr c' d' + CAnd c d -> case (walk c, walk d) of + (Lit False, _) -> Lit False + (Lit True, d') -> d' + (_, Lit False) -> Lit False + (c', Lit True) -> c' + (c',d') -> CAnd c' d' + -- gather free vars + fv c = (c, fv' c) + fv' c = case c of + Var v -> [v] + Lit _ -> [] + CNot c' -> fv' c' + COr c1 c2 -> fv' c1 ++ fv' c2 + CAnd c1 c2 -> fv' c1 ++ fv' c2 + +-- | Simplify a configuration condition using the os and arch names. Returns +-- the names of all the flags occurring in the condition. +simplifyWithSysParams :: OS -> Arch -> CompilerId -> Condition ConfVar + -> (Condition FlagName, [FlagName]) +simplifyWithSysParams os arch (CompilerId comp compVer) cond = (cond', flags) + where + (cond', flags) = simplifyCondition cond interp + interp (OS os') = Right $ os' == os + interp (Arch arch') = Right $ arch' == arch + interp (Impl comp' vr) = Right $ comp' == comp + && compVer `withinRange` vr + interp (Flag f) = Left f + +-- TODO: Add instances and check +-- +-- prop_sC_idempotent cond a o = cond' == cond'' +-- where +-- cond' = simplifyCondition cond a o +-- cond'' = simplifyCondition cond' a o +-- +-- prop_sC_noLits cond a o = isLit res || not (hasLits res) +-- where +-- res = simplifyCondition cond a o +-- hasLits (Lit _) = True +-- hasLits (CNot c) = hasLits c +-- hasLits (COr l r) = hasLits l || hasLits r +-- hasLits (CAnd l r) = hasLits l || hasLits r +-- hasLits _ = False +-- + +-- | Parse a configuration condition from a string. +parseCondition :: ReadP r (Condition ConfVar) +parseCondition = condOr + where + condOr = sepBy1 condAnd (oper "||") >>= return . foldl1 COr + condAnd = sepBy1 cond (oper "&&")>>= return . foldl1 CAnd + cond = sp >> (boolLiteral +++ inparens condOr +++ notCond +++ osCond + +++ archCond +++ flagCond +++ implCond ) + inparens = between (ReadP.char '(' >> sp) (sp >> ReadP.char ')' >> sp) + notCond = ReadP.char '!' >> sp >> cond >>= return . CNot + osCond = string "os" >> sp >> inparens osIdent >>= return . Var + archCond = string "arch" >> sp >> inparens archIdent >>= return . Var + flagCond = string "flag" >> sp >> inparens flagIdent >>= return . Var + implCond = string "impl" >> sp >> inparens implIdent >>= return . Var + boolLiteral = fmap Lit parse + archIdent = fmap Arch parse + osIdent = fmap OS parse + flagIdent = fmap (Flag . FlagName . lowercase) (munch1 isIdentChar) + isIdentChar c = isAlphaNum c || c == '_' || c == '-' + oper s = sp >> string s >> sp + sp = skipSpaces + implIdent = do i <- parse + vr <- sp >> option anyVersion parse + return $ Impl i vr + +------------------------------------------------------------------------------ + +mapCondTree :: (a -> b) -> (c -> d) -> (Condition v -> Condition w) + -> CondTree v c a -> CondTree w d b +mapCondTree fa fc fcnd (CondNode a c ifs) = + CondNode (fa a) (fc c) (map g ifs) + where + g (cnd, t, me) = (fcnd cnd, mapCondTree fa fc fcnd t, + fmap (mapCondTree fa fc fcnd) me) + +mapTreeConstrs :: (c -> d) -> CondTree v c a -> CondTree v d a +mapTreeConstrs f = mapCondTree id f id + +mapTreeConds :: (Condition v -> Condition w) -> CondTree v c a -> CondTree w c a +mapTreeConds f = mapCondTree id id f + +mapTreeData :: (a -> b) -> CondTree v c a -> CondTree v c b +mapTreeData f = mapCondTree f id id + +-- | Result of dependency test. Isomorphic to @Maybe d@ but renamed for +-- clarity. +data DepTestRslt d = DepOk | MissingDeps d + +instance Monoid d => Monoid (DepTestRslt d) where + mempty = DepOk + mappend DepOk x = x + mappend x DepOk = x + mappend (MissingDeps d) (MissingDeps d') = MissingDeps (d `mappend` d') + + +data BT a = BTN a | BTB (BT a) (BT a) -- very simple binary tree + + +-- | Try to find a flag assignment that satisfies the constaints of all trees. +-- +-- Returns either the missing dependencies, or a tuple containing the +-- resulting data, the associated dependencies, and the chosen flag +-- assignments. +-- +-- In case of failure, the _smallest_ number of of missing dependencies is +-- returned. [TODO: Could also be specified with a function argument.] +-- +-- TODO: The current algorithm is rather naive. A better approach would be to: +-- +-- * Rule out possible paths, by taking a look at the associated dependencies. +-- +-- * Infer the required values for the conditions of these paths, and +-- calculate the required domains for the variables used in these +-- conditions. Then picking a flag assignment would be linear (I guess). +-- +-- This would require some sort of SAT solving, though, thus it's not +-- implemented unless we really need it. +-- +resolveWithFlags :: + [(FlagName,[Bool])] + -- ^ Domain for each flag name, will be tested in order. + -> OS -- ^ OS as returned by Distribution.System.buildOS + -> Arch -- ^ Arch as returned by Distribution.System.buildArch + -> CompilerId -- ^ Compiler flavour + version + -> [Dependency] -- ^ Additional constraints + -> [CondTree ConfVar [Dependency] PDTagged] + -> ([Dependency] -> DepTestRslt [Dependency]) -- ^ Dependency test function. + -> Either [Dependency] (TargetSet PDTagged, FlagAssignment) + -- ^ Either the missing dependencies (error case), or a pair of + -- (set of build targets with dependencies, chosen flag assignments) +resolveWithFlags dom os arch impl constrs trees checkDeps = + case try dom [] of + Right r -> Right r + Left dbt -> Left $ findShortest dbt + where + extraConstrs = toDepMap constrs + + -- simplify trees by (partially) evaluating all conditions and converting + -- dependencies to dependency maps. + simplifiedTrees = map ( mapTreeConstrs toDepMap -- convert to maps + . mapTreeConds (fst . simplifyWithSysParams os arch impl)) + trees + + -- @try@ recursively tries all possible flag assignments in the domain and + -- either succeeds or returns a binary tree with the missing dependencies + -- encountered in each run. Since the tree is constructed lazily, we + -- avoid some computation overhead in the successful case. + try [] flags = + let targetSet = TargetSet $ flip map simplifiedTrees $ + -- apply additional constraints to all dependencies + first (`constrainBy` extraConstrs) . + simplifyCondTree (env flags) + deps = overallDependencies targetSet + in case checkDeps (fromDepMap deps) of + DepOk -> Right (targetSet, flags) + MissingDeps mds -> Left (BTN mds) + + try ((n, vals):rest) flags = + tryAll $ map (\v -> try rest ((n, v):flags)) vals + + tryAll = foldr mp mz + + -- special version of `mplus' for our local purposes + mp (Left xs) (Left ys) = (Left (BTB xs ys)) + mp (Left _) m@(Right _) = m + mp m@(Right _) _ = m + + -- `mzero' + mz = Left (BTN []) + + env flags flag = (maybe (Left flag) Right . lookup flag) flags + + -- for the error case we inspect our lazy tree of missing dependencies and + -- pick the shortest list of missing dependencies + findShortest (BTN x) = x + findShortest (BTB lt rt) = + let l = findShortest lt + r = findShortest rt + in case (l,r) of + ([], xs) -> xs -- [] is too short + (xs, []) -> xs + ([x], _) -> [x] -- single elem is optimum + (_, [x]) -> [x] + (xs, ys) -> if lazyLengthCmp xs ys + then xs else ys + -- lazy variant of @\xs ys -> length xs <= length ys@ + lazyLengthCmp [] _ = True + lazyLengthCmp _ [] = False + lazyLengthCmp (_:xs) (_:ys) = lazyLengthCmp xs ys + +-- | A map of dependencies. Newtyped since the default monoid instance is not +-- appropriate. The monoid instance uses 'intersectVersionRanges'. +newtype DependencyMap = DependencyMap { unDependencyMap :: Map PackageName VersionRange } +#if !defined(__GLASGOW_HASKELL__) || (__GLASGOW_HASKELL__ >= 606) + deriving (Show, Read) +#else +-- The Show/Read instance for Data.Map in ghc-6.4 is useless +-- so we have to re-implement it here: +instance Show DependencyMap where + showsPrec d (DependencyMap m) = + showParen (d > 10) (showString "DependencyMap" . shows (M.toList m)) + +instance Read DependencyMap where + readPrec = parens $ R.prec 10 $ do + R.Ident "DependencyMap" <- R.lexP + xs <- R.readPrec + return (DependencyMap (M.fromList xs)) + where parens :: R.ReadPrec a -> R.ReadPrec a + parens p = optional + where + optional = p R.+++ mandatory + mandatory = paren optional + + paren :: R.ReadPrec a -> R.ReadPrec a + paren p = do L.Punc "(" <- R.lexP + x <- R.reset p + L.Punc ")" <- R.lexP + return x + + readListPrec = R.readListPrecDefault +#endif + +instance Monoid DependencyMap where + mempty = DependencyMap Map.empty + (DependencyMap a) `mappend` (DependencyMap b) = + DependencyMap (Map.unionWith intersectVersionRanges a b) + +toDepMap :: [Dependency] -> DependencyMap +toDepMap ds = + DependencyMap $ fromListWith intersectVersionRanges [ (p,vr) | Dependency p vr <- ds ] + +fromDepMap :: DependencyMap -> [Dependency] +fromDepMap m = [ Dependency p vr | (p,vr) <- toList (unDependencyMap m) ] + +simplifyCondTree :: (Monoid a, Monoid d) => + (v -> Either v Bool) + -> CondTree v d a + -> (d, a) +simplifyCondTree env (CondNode a d ifs) = + foldr mappend (d, a) $ catMaybes $ map simplifyIf ifs + where + simplifyIf (cnd, t, me) = + case simplifyCondition cnd env of + (Lit True, _) -> Just $ simplifyCondTree env t + (Lit False, _) -> fmap (simplifyCondTree env) me + _ -> error $ "Environment not defined for all free vars" + +-- | Flatten a CondTree. This will resolve the CondTree by taking all +-- possible paths into account. Note that since branches represent exclusive +-- choices this may not result in a \"sane\" result. +ignoreConditions :: (Monoid a, Monoid c) => CondTree v c a -> (a, c) +ignoreConditions (CondNode a c ifs) = (a, c) `mappend` mconcat (concatMap f ifs) + where f (_, t, me) = ignoreConditions t + : maybeToList (fmap ignoreConditions me) + +freeVars :: CondTree ConfVar c a -> [FlagName] +freeVars t = [ f | Flag f <- freeVars' t ] + where + freeVars' (CondNode _ _ ifs) = concatMap compfv ifs + compfv (c, ct, mct) = condfv c ++ freeVars' ct ++ maybe [] freeVars' mct + condfv c = case c of + Var v -> [v] + Lit _ -> [] + CNot c' -> condfv c' + COr c1 c2 -> condfv c1 ++ condfv c2 + CAnd c1 c2 -> condfv c1 ++ condfv c2 + + +------------------------------------------------------------------------------ + +-- | A set of targets with their package dependencies +newtype TargetSet a = TargetSet [(DependencyMap, a)] + +-- | Combine the target-specific dependencies in a TargetSet to give the +-- dependencies for the package as a whole. +overallDependencies :: TargetSet PDTagged -> DependencyMap +overallDependencies (TargetSet targets) = mconcat depss + where + (depss, _) = unzip $ filter (removeDisabledTests . snd) targets + removeDisabledTests :: PDTagged -> Bool + removeDisabledTests (Lib _) = True + removeDisabledTests (Exe _ _) = True + removeDisabledTests (Test _ t) = testEnabled t + removeDisabledTests PDNull = True + +-- Apply extra constraints to a dependency map. +-- Combines dependencies where the result will only contain keys from the left +-- (first) map. If a key also exists in the right map, both constraints will +-- be intersected. +constrainBy :: DependencyMap -- ^ Input map + -> DependencyMap -- ^ Extra constraints + -> DependencyMap +constrainBy left extra = + DependencyMap $ + Map.foldWithKey tightenConstraint (unDependencyMap left) + (unDependencyMap extra) + where tightenConstraint n c l = + case Map.lookup n l of + Nothing -> l + Just vr -> Map.insert n (intersectVersionRanges vr c) l + +-- | Collect up the targets in a TargetSet of tagged targets, storing the +-- dependencies as we go. +flattenTaggedTargets :: TargetSet PDTagged -> + (Maybe Library, [(String, Executable)], [(String, TestSuite)]) +flattenTaggedTargets (TargetSet targets) = foldr untag (Nothing, [], []) targets + where + untag (_, Lib _) (Just _, _, _) = bug "Only one library expected" + untag (deps, Lib l) (Nothing, exes, tests) = (Just l', exes, tests) + where + l' = l { + libBuildInfo = (libBuildInfo l) { targetBuildDepends = fromDepMap deps } + } + untag (deps, Exe n e) (mlib, exes, tests) + | any ((== n) . fst) exes = bug "Exe with same name found" + | any ((== n) . fst) tests = bug "Test sharing name of exe found" + | otherwise = (mlib, exes ++ [(n, e')], tests) + where + e' = e { + buildInfo = (buildInfo e) { targetBuildDepends = fromDepMap deps } + } + untag (deps, Test n t) (mlib, exes, tests) + | any ((== n) . fst) tests = bug "Test with same name found" + | any ((== n) . fst) exes = bug "Test sharing name of exe found" + | otherwise = (mlib, exes, tests ++ [(n, t')]) + where + t' = t { + testBuildInfo = (testBuildInfo t) + { targetBuildDepends = fromDepMap deps } + } + untag (_, PDNull) x = x -- actually this should not happen, but let's be liberal + + +------------------------------------------------------------------------------ +-- Convert GenericPackageDescription to PackageDescription +-- + +data PDTagged = Lib Library | Exe String Executable | Test String TestSuite | PDNull deriving Show + +instance Monoid PDTagged where + mempty = PDNull + PDNull `mappend` x = x + x `mappend` PDNull = x + Lib l `mappend` Lib l' = Lib (l `mappend` l') + Exe n e `mappend` Exe n' e' | n == n' = Exe n (e `mappend` e') + Test n t `mappend` Test n' t' | n == n' = Test n (t `mappend` t') + _ `mappend` _ = bug "Cannot combine incompatible tags" + +-- | Create a package description with all configurations resolved. +-- +-- This function takes a `GenericPackageDescription` and several environment +-- parameters and tries to generate `PackageDescription` by finding a flag +-- assignment that result in satisfiable dependencies. +-- +-- It takes as inputs a not necessarily complete specifications of flags +-- assignments, an optional package index as well as platform parameters. If +-- some flags are not assigned explicitly, this function will try to pick an +-- assignment that causes this function to succeed. The package index is +-- optional since on some platforms we cannot determine which packages have +-- been installed before. When no package index is supplied, every dependency +-- is assumed to be satisfiable, therefore all not explicitly assigned flags +-- will get their default values. +-- +-- This function will fail if it cannot find a flag assignment that leads to +-- satisfiable dependencies. (It will not try alternative assignments for +-- explicitly specified flags.) In case of failure it will return a /minimum/ +-- number of dependencies that could not be satisfied. On success, it will +-- return the package description and the full flag assignment chosen. +-- +finalizePackageDescription :: + FlagAssignment -- ^ Explicitly specified flag assignments + -> (Dependency -> Bool) -- ^ Is a given depenency satisfiable from the set of available packages? + -- If this is unknown then use True. + -> Platform -- ^ The 'Arch' and 'OS' + -> CompilerId -- ^ Compiler + Version + -> [Dependency] -- ^ Additional constraints + -> GenericPackageDescription + -> Either [Dependency] + (PackageDescription, FlagAssignment) + -- ^ Either missing dependencies or the resolved package + -- description along with the flag assignments chosen. +finalizePackageDescription userflags satisfyDep (Platform arch os) impl constraints + (GenericPackageDescription pkg flags mlib0 exes0 tests0) = + case resolveFlags of + Right ((mlib, exes', tests'), targetSet, flagVals) -> + Right ( pkg { library = mlib + , executables = exes' + , testSuites = tests' + , buildDepends = fromDepMap (overallDependencies targetSet) + --TODO: we need to find a way to avoid pulling in deps + -- for non-buildable components. However cannot simply + -- filter at this stage, since if the package were not + -- available we would have failed already. + } + , flagVals ) + + Left missing -> Left missing + where + -- Combine lib, exes, and tests into one list of @CondTree@s with tagged data + condTrees = maybeToList (fmap (mapTreeData Lib) mlib0 ) + ++ map (\(name,tree) -> mapTreeData (Exe name) tree) exes0 + ++ map (\(name,tree) -> mapTreeData (Test name) tree) tests0 + + resolveFlags = + case resolveWithFlags flagChoices os arch impl constraints condTrees check of + Right (targetSet, fs) -> + let (mlib, exes, tests) = flattenTaggedTargets targetSet in + Right ( (fmap libFillInDefaults mlib, + map (\(n,e) -> (exeFillInDefaults e) { exeName = n }) exes, + map (\(n,t) -> (testFillInDefaults t) { testName = n }) tests), + targetSet, fs) + Left missing -> Left missing + + flagChoices = map (\(MkFlag n _ d manual) -> (n, d2c manual n d)) flags + d2c manual n b = case lookup n userflags of + Just val -> [val] + Nothing + | manual -> [b] + | otherwise -> [b, not b] + --flagDefaults = map (\(n,x:_) -> (n,x)) flagChoices + check ds = if all satisfyDep ds + then DepOk + else MissingDeps $ filter (not . satisfyDep) ds + +{- +let tst_p = (CondNode [1::Int] [Distribution.Package.Dependency "a" AnyVersion] []) +let tst_p2 = (CondNode [1::Int] [Distribution.Package.Dependency "a" (EarlierVersion (Version [1,0] [])), Distribution.Package.Dependency "a" (LaterVersion (Version [2,0] []))] []) + +let p_index = Distribution.Simple.PackageIndex.fromList [Distribution.Package.PackageIdentifier "a" (Version [0,5] []), Distribution.Package.PackageIdentifier "a" (Version [2,5] [])] +let look = not . null . Distribution.Simple.PackageIndex.lookupDependency p_index +let looks ds = mconcat $ map (\d -> if look d then DepOk else MissingDeps [d]) ds +resolveWithFlags [] Distribution.System.Linux Distribution.System.I386 (Distribution.Compiler.GHC,Version [6,8,2] []) [tst_p] looks ===> Right ... +resolveWithFlags [] Distribution.System.Linux Distribution.System.I386 (Distribution.Compiler.GHC,Version [6,8,2] []) [tst_p2] looks ===> Left ... +-} + +-- | Flatten a generic package description by ignoring all conditions and just +-- join the field descriptors into on package description. Note, however, +-- that this may lead to inconsistent field values, since all values are +-- joined into one field, which may not be possible in the original package +-- description, due to the use of exclusive choices (if ... else ...). +-- +-- TODO: One particularly tricky case is defaulting. In the original package +-- description, e.g., the source directory might either be the default or a +-- certain, explicitly set path. Since defaults are filled in only after the +-- package has been resolved and when no explicit value has been set, the +-- default path will be missing from the package description returned by this +-- function. +flattenPackageDescription :: GenericPackageDescription -> PackageDescription +flattenPackageDescription (GenericPackageDescription pkg _ mlib0 exes0 tests0) = + pkg { library = mlib + , executables = reverse exes + , testSuites = reverse tests + , buildDepends = ldeps ++ reverse edeps ++ reverse tdeps + } + where + (mlib, ldeps) = case mlib0 of + Just lib -> let (l,ds) = ignoreConditions lib in + (Just (libFillInDefaults l), ds) + Nothing -> (Nothing, []) + (exes, edeps) = foldr flattenExe ([],[]) exes0 + (tests, tdeps) = foldr flattenTst ([],[]) tests0 + flattenExe (n, t) (es, ds) = + let (e, ds') = ignoreConditions t in + ( (exeFillInDefaults $ e { exeName = n }) : es, ds' ++ ds ) + flattenTst (n, t) (es, ds) = + let (e, ds') = ignoreConditions t in + ( (testFillInDefaults $ e { testName = n }) : es, ds' ++ ds ) + +-- This is in fact rather a hack. The original version just overrode the +-- default values, however, when adding conditions we had to switch to a +-- modifier-based approach. There, nothing is ever overwritten, but only +-- joined together. +-- +-- This is the cleanest way i could think of, that doesn't require +-- changing all field parsing functions to return modifiers instead. +libFillInDefaults :: Library -> Library +libFillInDefaults lib@(Library { libBuildInfo = bi }) = + lib { libBuildInfo = biFillInDefaults bi } + +exeFillInDefaults :: Executable -> Executable +exeFillInDefaults exe@(Executable { buildInfo = bi }) = + exe { buildInfo = biFillInDefaults bi } + +testFillInDefaults :: TestSuite -> TestSuite +testFillInDefaults tst@(TestSuite { testBuildInfo = bi }) = + tst { testBuildInfo = biFillInDefaults bi } + +biFillInDefaults :: BuildInfo -> BuildInfo +biFillInDefaults bi = + if null (hsSourceDirs bi) + then bi { hsSourceDirs = [currentDir] } + else bi + +bug :: String -> a +bug msg = error $ msg ++ ". Consider this a bug." diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/PackageDescription/Parse.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/PackageDescription/Parse.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/PackageDescription/Parse.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/PackageDescription/Parse.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,1074 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.PackageDescription.Parse +-- Copyright : Isaac Jones 2003-2005 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This defined parsers and partial pretty printers for the @.cabal@ format. +-- Some of the complexity in this module is due to the fact that we have to be +-- backwards compatible with old @.cabal@ files, so there's code to translate +-- into the newer structure. + +{- All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.PackageDescription.Parse ( + -- * Package descriptions + readPackageDescription, + writePackageDescription, + parsePackageDescription, + showPackageDescription, + + -- ** Parsing + ParseResult(..), + FieldDescr(..), + LineNo, + + -- ** Supplementary build information + readHookedBuildInfo, + parseHookedBuildInfo, + writeHookedBuildInfo, + showHookedBuildInfo, + + pkgDescrFieldDescrs, + libFieldDescrs, + executableFieldDescrs, + binfoFieldDescrs, + sourceRepoFieldDescrs, + testSuiteFieldDescrs, + flagFieldDescrs + ) where + +import Data.Char (isSpace) +import Data.Maybe (listToMaybe, isJust) +import Data.Monoid ( Monoid(..) ) +import Data.List (nub, unfoldr, partition, (\\)) +import Control.Monad (liftM, foldM, when, unless) +import System.Directory (doesFileExist) + +import Distribution.Text + ( Text(disp, parse), display, simpleParse ) +import Distribution.Compat.ReadP + ((+++), option) +import Text.PrettyPrint.HughesPJ + +import Distribution.ParseUtils hiding (parseFields) +import Distribution.PackageDescription +import Distribution.Package + ( PackageIdentifier(..), Dependency(..), packageName, packageVersion ) +import Distribution.ModuleName ( ModuleName ) +import Distribution.Version + ( Version(Version), orLaterVersion + , LowerBound(..), asVersionIntervals ) +import Distribution.Verbosity (Verbosity) +import Distribution.Compiler (CompilerFlavor(..)) +import Distribution.PackageDescription.Configuration (parseCondition, freeVars) +import Distribution.Simple.Utils + ( die, dieWithLocation, warn, intercalate, lowercase, cabalVersion + , withFileContents, withUTF8FileContents + , writeFileAtomic, writeUTF8File ) + + +-- ----------------------------------------------------------------------------- +-- The PackageDescription type + +pkgDescrFieldDescrs :: [FieldDescr PackageDescription] +pkgDescrFieldDescrs = + [ simpleField "name" + disp parse + packageName (\name pkg -> pkg{package=(package pkg){pkgName=name}}) + , simpleField "version" + disp parse + packageVersion (\ver pkg -> pkg{package=(package pkg){pkgVersion=ver}}) + , simpleField "cabal-version" + (either disp disp) (liftM Left parse +++ liftM Right parse) + specVersionRaw (\v pkg -> pkg{specVersionRaw=v}) + , simpleField "build-type" + (maybe empty disp) (fmap Just parse) + buildType (\t pkg -> pkg{buildType=t}) + , simpleField "license" + disp parseLicenseQ + license (\l pkg -> pkg{license=l}) + , simpleField "license-file" + showFilePath parseFilePathQ + licenseFile (\l pkg -> pkg{licenseFile=l}) + , simpleField "copyright" + showFreeText parseFreeText + copyright (\val pkg -> pkg{copyright=val}) + , simpleField "maintainer" + showFreeText parseFreeText + maintainer (\val pkg -> pkg{maintainer=val}) + , commaListField "build-depends" + disp parse + buildDepends (\xs pkg -> pkg{buildDepends=xs}) + , simpleField "stability" + showFreeText parseFreeText + stability (\val pkg -> pkg{stability=val}) + , simpleField "homepage" + showFreeText parseFreeText + homepage (\val pkg -> pkg{homepage=val}) + , simpleField "package-url" + showFreeText parseFreeText + pkgUrl (\val pkg -> pkg{pkgUrl=val}) + , simpleField "bug-reports" + showFreeText parseFreeText + bugReports (\val pkg -> pkg{bugReports=val}) + , simpleField "synopsis" + showFreeText parseFreeText + synopsis (\val pkg -> pkg{synopsis=val}) + , simpleField "description" + showFreeText parseFreeText + description (\val pkg -> pkg{description=val}) + , simpleField "category" + showFreeText parseFreeText + category (\val pkg -> pkg{category=val}) + , simpleField "author" + showFreeText parseFreeText + author (\val pkg -> pkg{author=val}) + , listField "tested-with" + showTestedWith parseTestedWithQ + testedWith (\val pkg -> pkg{testedWith=val}) + , listField "data-files" + showFilePath parseFilePathQ + dataFiles (\val pkg -> pkg{dataFiles=val}) + , simpleField "data-dir" + showFilePath parseFilePathQ + dataDir (\val pkg -> pkg{dataDir=val}) + , listField "extra-source-files" + showFilePath parseFilePathQ + extraSrcFiles (\val pkg -> pkg{extraSrcFiles=val}) + , listField "extra-tmp-files" + showFilePath parseFilePathQ + extraTmpFiles (\val pkg -> pkg{extraTmpFiles=val}) + ] + +-- | Store any fields beginning with "x-" in the customFields field of +-- a PackageDescription. All other fields will generate a warning. +storeXFieldsPD :: UnrecFieldParser PackageDescription +storeXFieldsPD (f@('x':'-':_),val) pkg = Just pkg{ customFieldsPD = + (customFieldsPD pkg) ++ [(f,val)]} +storeXFieldsPD _ _ = Nothing + +-- --------------------------------------------------------------------------- +-- The Library type + +libFieldDescrs :: [FieldDescr Library] +libFieldDescrs = + [ listField "exposed-modules" disp parseModuleNameQ + exposedModules (\mods lib -> lib{exposedModules=mods}) + + , boolField "exposed" + libExposed (\val lib -> lib{libExposed=val}) + ] ++ map biToLib binfoFieldDescrs + where biToLib = liftField libBuildInfo (\bi lib -> lib{libBuildInfo=bi}) + +storeXFieldsLib :: UnrecFieldParser Library +storeXFieldsLib (f@('x':'-':_), val) l@(Library { libBuildInfo = bi }) = + Just $ l {libBuildInfo = bi{ customFieldsBI = (customFieldsBI bi) ++ [(f,val)]}} +storeXFieldsLib _ _ = Nothing + +-- --------------------------------------------------------------------------- +-- The Executable type + + +executableFieldDescrs :: [FieldDescr Executable] +executableFieldDescrs = + [ -- note ordering: configuration must come first, for + -- showPackageDescription. + simpleField "executable" + showToken parseTokenQ + exeName (\xs exe -> exe{exeName=xs}) + , simpleField "main-is" + showFilePath parseFilePathQ + modulePath (\xs exe -> exe{modulePath=xs}) + ] + ++ map biToExe binfoFieldDescrs + where biToExe = liftField buildInfo (\bi exe -> exe{buildInfo=bi}) + +storeXFieldsExe :: UnrecFieldParser Executable +storeXFieldsExe (f@('x':'-':_), val) e@(Executable { buildInfo = bi }) = + Just $ e {buildInfo = bi{ customFieldsBI = (f,val):(customFieldsBI bi)}} +storeXFieldsExe _ _ = Nothing + +-- --------------------------------------------------------------------------- +-- The TestSuite type + +-- | An intermediate type just used for parsing the test-suite stanza. +-- After validation it is converted into the proper 'TestSuite' type. +data TestSuiteStanza = TestSuiteStanza { + testStanzaTestType :: Maybe TestType, + testStanzaMainIs :: Maybe FilePath, + testStanzaTestModule :: Maybe ModuleName, + testStanzaBuildInfo :: BuildInfo + } + +emptyTestStanza :: TestSuiteStanza +emptyTestStanza = TestSuiteStanza Nothing Nothing Nothing mempty + +testSuiteFieldDescrs :: [FieldDescr TestSuiteStanza] +testSuiteFieldDescrs = + [ simpleField "type" + (maybe empty disp) (fmap Just parse) + testStanzaTestType (\x suite -> suite { testStanzaTestType = x }) + , simpleField "main-is" + (maybe empty showFilePath) (fmap Just parseFilePathQ) + testStanzaMainIs (\x suite -> suite { testStanzaMainIs = x }) + , simpleField "test-module" + (maybe empty disp) (fmap Just parseModuleNameQ) + testStanzaTestModule (\x suite -> suite { testStanzaTestModule = x }) + ] + ++ map biToTest binfoFieldDescrs + where + biToTest = liftField testStanzaBuildInfo + (\bi suite -> suite { testStanzaBuildInfo = bi }) + +storeXFieldsTest :: UnrecFieldParser TestSuiteStanza +storeXFieldsTest (f@('x':'-':_), val) t@(TestSuiteStanza { testStanzaBuildInfo = bi }) = + Just $ t {testStanzaBuildInfo = bi{ customFieldsBI = (f,val):(customFieldsBI bi)}} +storeXFieldsTest _ _ = Nothing + +validateTestSuite :: LineNo -> TestSuiteStanza -> ParseResult TestSuite +validateTestSuite line stanza = + case testStanzaTestType stanza of + Nothing -> return $ + emptyTestSuite { testBuildInfo = testStanzaBuildInfo stanza } + + Just tt@(TestTypeUnknown _ _) -> + return emptyTestSuite { + testInterface = TestSuiteUnsupported tt, + testBuildInfo = testStanzaBuildInfo stanza + } + + Just tt | tt `notElem` knownTestTypes -> + return emptyTestSuite { + testInterface = TestSuiteUnsupported tt, + testBuildInfo = testStanzaBuildInfo stanza + } + + Just tt@(TestTypeExe ver) -> + case testStanzaMainIs stanza of + Nothing -> syntaxError line (missingField "main-is" tt) + Just file -> do + when (isJust (testStanzaTestModule stanza)) $ + warning (extraField "test-module" tt) + return emptyTestSuite { + testInterface = TestSuiteExeV10 ver file, + testBuildInfo = testStanzaBuildInfo stanza + } + + Just tt@(TestTypeLib ver) -> + case testStanzaTestModule stanza of + Nothing -> syntaxError line (missingField "test-module" tt) + Just module_ -> do + when (isJust (testStanzaMainIs stanza)) $ + warning (extraField "main-is" tt) + return emptyTestSuite { + testInterface = TestSuiteLibV09 ver module_, + testBuildInfo = testStanzaBuildInfo stanza + } + + where + missingField name tt = "The '" ++ name ++ "' field is required for the " + ++ display tt ++ " test suite type." + + extraField name tt = "The '" ++ name ++ "' field is not used for the '" + ++ display tt ++ "' test suite type." + + +-- --------------------------------------------------------------------------- +-- The BuildInfo type + + +binfoFieldDescrs :: [FieldDescr BuildInfo] +binfoFieldDescrs = + [ boolField "buildable" + buildable (\val binfo -> binfo{buildable=val}) + , commaListField "build-tools" + disp parseBuildTool + buildTools (\xs binfo -> binfo{buildTools=xs}) + , spaceListField "cpp-options" + showToken parseTokenQ' + cppOptions (\val binfo -> binfo{cppOptions=val}) + , spaceListField "cc-options" + showToken parseTokenQ' + ccOptions (\val binfo -> binfo{ccOptions=val}) + , spaceListField "ld-options" + showToken parseTokenQ' + ldOptions (\val binfo -> binfo{ldOptions=val}) + , commaListField "pkgconfig-depends" + disp parsePkgconfigDependency + pkgconfigDepends (\xs binfo -> binfo{pkgconfigDepends=xs}) + , listField "frameworks" + showToken parseTokenQ + frameworks (\val binfo -> binfo{frameworks=val}) + , listField "c-sources" + showFilePath parseFilePathQ + cSources (\paths binfo -> binfo{cSources=paths}) + + , simpleField "default-language" + (maybe empty disp) (option Nothing (fmap Just parseLanguageQ)) + defaultLanguage (\lang binfo -> binfo{defaultLanguage=lang}) + , listField "other-languages" + disp parseLanguageQ + otherLanguages (\langs binfo -> binfo{otherLanguages=langs}) + , listField "default-extensions" + disp parseExtensionQ + defaultExtensions (\exts binfo -> binfo{defaultExtensions=exts}) + , listField "other-extensions" + disp parseExtensionQ + otherExtensions (\exts binfo -> binfo{otherExtensions=exts}) + , listField "extensions" + disp parseExtensionQ + oldExtensions (\exts binfo -> binfo{oldExtensions=exts}) + + , listField "extra-libraries" + showToken parseTokenQ + extraLibs (\xs binfo -> binfo{extraLibs=xs}) + , listField "extra-lib-dirs" + showFilePath parseFilePathQ + extraLibDirs (\xs binfo -> binfo{extraLibDirs=xs}) + , listField "includes" + showFilePath parseFilePathQ + includes (\paths binfo -> binfo{includes=paths}) + , listField "install-includes" + showFilePath parseFilePathQ + installIncludes (\paths binfo -> binfo{installIncludes=paths}) + , listField "include-dirs" + showFilePath parseFilePathQ + includeDirs (\paths binfo -> binfo{includeDirs=paths}) + , listField "hs-source-dirs" + showFilePath parseFilePathQ + hsSourceDirs (\paths binfo -> binfo{hsSourceDirs=paths}) + , listField "other-modules" + disp parseModuleNameQ + otherModules (\val binfo -> binfo{otherModules=val}) + , listField "ghc-prof-options" + text parseTokenQ + ghcProfOptions (\val binfo -> binfo{ghcProfOptions=val}) + , listField "ghc-shared-options" + text parseTokenQ + ghcSharedOptions (\val binfo -> binfo{ghcSharedOptions=val}) + , optsField "ghc-options" GHC + options (\path binfo -> binfo{options=path}) + , optsField "hugs-options" Hugs + options (\path binfo -> binfo{options=path}) + , optsField "nhc98-options" NHC + options (\path binfo -> binfo{options=path}) + , optsField "jhc-options" JHC + options (\path binfo -> binfo{options=path}) + ] + +storeXFieldsBI :: UnrecFieldParser BuildInfo +storeXFieldsBI (f@('x':'-':_),val) bi = Just bi{ customFieldsBI = (f,val):(customFieldsBI bi) } +storeXFieldsBI _ _ = Nothing + +------------------------------------------------------------------------------ + +flagFieldDescrs :: [FieldDescr Flag] +flagFieldDescrs = + [ simpleField "description" + showFreeText parseFreeText + flagDescription (\val fl -> fl{ flagDescription = val }) + , boolField "default" + flagDefault (\val fl -> fl{ flagDefault = val }) + , boolField "manual" + flagManual (\val fl -> fl{ flagManual = val }) + ] + +------------------------------------------------------------------------------ + +sourceRepoFieldDescrs :: [FieldDescr SourceRepo] +sourceRepoFieldDescrs = + [ simpleField "type" + (maybe empty disp) (fmap Just parse) + repoType (\val repo -> repo { repoType = val }) + , simpleField "location" + (maybe empty showFreeText) (fmap Just parseFreeText) + repoLocation (\val repo -> repo { repoLocation = val }) + , simpleField "module" + (maybe empty showToken) (fmap Just parseTokenQ) + repoModule (\val repo -> repo { repoModule = val }) + , simpleField "branch" + (maybe empty showToken) (fmap Just parseTokenQ) + repoBranch (\val repo -> repo { repoBranch = val }) + , simpleField "tag" + (maybe empty showToken) (fmap Just parseTokenQ) + repoTag (\val repo -> repo { repoTag = val }) + , simpleField "subdir" + (maybe empty showFilePath) (fmap Just parseFilePathQ) + repoSubdir (\val repo -> repo { repoSubdir = val }) + ] + +-- --------------------------------------------------------------- +-- Parsing + +-- | Given a parser and a filename, return the parse of the file, +-- after checking if the file exists. +readAndParseFile :: (FilePath -> (String -> IO a) -> IO a) + -> (String -> ParseResult a) + -> Verbosity + -> FilePath -> IO a +readAndParseFile withFileContents' parser verbosity fpath = do + exists <- doesFileExist fpath + when (not exists) (die $ "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue.") + withFileContents' fpath $ \str -> case parser str of + ParseFailed e -> do + let (line, message) = locatedErrorMsg e + dieWithLocation fpath line message + ParseOk warnings x -> do + mapM_ (warn verbosity . showPWarning fpath) $ reverse warnings + return x + +readHookedBuildInfo :: Verbosity -> FilePath -> IO HookedBuildInfo +readHookedBuildInfo = + readAndParseFile withFileContents parseHookedBuildInfo + +-- |Parse the given package file. +readPackageDescription :: Verbosity -> FilePath -> IO GenericPackageDescription +readPackageDescription = + readAndParseFile withUTF8FileContents parsePackageDescription + +stanzas :: [Field] -> [[Field]] +stanzas [] = [] +stanzas (f:fields) = (f:this) : stanzas rest + where + (this, rest) = break isStanzaHeader fields + +isStanzaHeader :: Field -> Bool +isStanzaHeader (F _ f _) = f == "executable" +isStanzaHeader _ = False + +------------------------------------------------------------------------------ + + +mapSimpleFields :: (Field -> ParseResult Field) -> [Field] + -> ParseResult [Field] +mapSimpleFields f fs = mapM walk fs + where + walk fld@(F _ _ _) = f fld + walk (IfBlock l c fs1 fs2) = do + fs1' <- mapM walk fs1 + fs2' <- mapM walk fs2 + return (IfBlock l c fs1' fs2') + walk (Section ln n l fs1) = do + fs1' <- mapM walk fs1 + return (Section ln n l fs1') + +-- prop_isMapM fs = mapSimpleFields return fs == return fs + + +-- names of fields that represents dependencies, thus consrca +constraintFieldNames :: [String] +constraintFieldNames = ["build-depends"] + +-- Possible refactoring would be to have modifiers be explicit about what +-- they add and define an accessor that specifies what the dependencies +-- are. This way we would completely reuse the parsing knowledge from the +-- field descriptor. +parseConstraint :: Field -> ParseResult [Dependency] +parseConstraint (F l n v) + | n == "build-depends" = runP l n (parseCommaList parse) v +parseConstraint f = bug $ "Constraint was expected (got: " ++ show f ++ ")" + +{- +headerFieldNames :: [String] +headerFieldNames = filter (\n -> not (n `elem` constraintFieldNames)) + . map fieldName $ pkgDescrFieldDescrs +-} + +libFieldNames :: [String] +libFieldNames = map fieldName libFieldDescrs + ++ buildInfoNames ++ constraintFieldNames + +-- exeFieldNames :: [String] +-- exeFieldNames = map fieldName executableFieldDescrs +-- ++ buildInfoNames + +buildInfoNames :: [String] +buildInfoNames = map fieldName binfoFieldDescrs + ++ map fst deprecatedFieldsBuildInfo + +-- A minimal implementation of the StateT monad transformer to avoid depending +-- on the 'mtl' package. +newtype StT s m a = StT { runStT :: s -> m (a,s) } + +instance Monad m => Monad (StT s m) where + return a = StT (\s -> return (a,s)) + StT f >>= g = StT $ \s -> do + (a,s') <- f s + runStT (g a) s' + +get :: Monad m => StT s m s +get = StT $ \s -> return (s, s) + +modify :: Monad m => (s -> s) -> StT s m () +modify f = StT $ \s -> return ((),f s) + +lift :: Monad m => m a -> StT s m a +lift m = StT $ \s -> m >>= \a -> return (a,s) + +evalStT :: Monad m => StT s m a -> s -> m a +evalStT st s = runStT st s >>= return . fst + +-- Our monad for parsing a list/tree of fields. +-- +-- The state represents the remaining fields to be processed. +type PM a = StT [Field] ParseResult a + + + +-- return look-ahead field or nothing if we're at the end of the file +peekField :: PM (Maybe Field) +peekField = get >>= return . listToMaybe + +-- Unconditionally discard the first field in our state. Will error when it +-- reaches end of file. (Yes, that's evil.) +skipField :: PM () +skipField = modify tail + +--FIXME: this should take a ByteString, not a String. We have to be able to +-- decode UTF8 and handle the BOM. + +-- | Parses the given file into a 'GenericPackageDescription'. +-- +-- In Cabal 1.2 the syntax for package descriptions was changed to a format +-- with sections and possibly indented property descriptions. +parsePackageDescription :: String -> ParseResult GenericPackageDescription +parsePackageDescription file = do + + -- This function is quite complex because it needs to be able to parse + -- both pre-Cabal-1.2 and post-Cabal-1.2 files. Additionally, it contains + -- a lot of parser-related noise since we do not want to depend on Parsec. + -- + -- If we detect an pre-1.2 file we implicitly convert it to post-1.2 + -- style. See 'sectionizeFields' below for details about the conversion. + + fields0 <- readFields file `catchParseError` \err -> + let tabs = findIndentTabs file in + case err of + -- In case of a TabsError report them all at once. + TabsError tabLineNo -> reportTabsError + -- but only report the ones including and following + -- the one that caused the actual error + [ t | t@(lineNo',_) <- tabs + , lineNo' >= tabLineNo ] + _ -> parseFail err + + let cabalVersionNeeded = + head $ [ minVersionBound versionRange + | Just versionRange <- [ simpleParse v + | F _ "cabal-version" v <- fields0 ] ] + ++ [Version [0] []] + minVersionBound versionRange = + case asVersionIntervals versionRange of + [] -> Version [0] [] + ((LowerBound version _, _):_) -> version + + handleFutureVersionParseFailure cabalVersionNeeded $ do + + let sf = sectionizeFields fields0 -- ensure 1.2 format + + -- figure out and warn about deprecated stuff (warnings are collected + -- inside our parsing monad) + fields <- mapSimpleFields deprecField sf + + -- Our parsing monad takes the not-yet-parsed fields as its state. + -- After each successful parse we remove the field from the state + -- ('skipField') and move on to the next one. + -- + -- Things are complicated a bit, because fields take a tree-like + -- structure -- they can be sections or "if"/"else" conditionals. + + flip evalStT fields $ do + + -- The header consists of all simple fields up to the first section + -- (flag, library, executable). + header_fields <- getHeader [] + + -- Parses just the header fields and stores them in a + -- 'PackageDescription'. Note that our final result is a + -- 'GenericPackageDescription'; for pragmatic reasons we just store + -- the partially filled-out 'PackageDescription' inside the + -- 'GenericPackageDescription'. + pkg <- lift $ parseFields pkgDescrFieldDescrs + storeXFieldsPD + emptyPackageDescription + header_fields + + -- 'getBody' assumes that the remaining fields only consist of + -- flags, lib and exe sections. + (repos, flags, mlib, exes, tests) <- getBody + warnIfRest -- warn if getBody did not parse up to the last field. + -- warn about using old/new syntax with wrong cabal-version: + maybeWarnCabalVersion (not $ oldSyntax fields0) pkg + checkForUndefinedFlags flags mlib exes tests + return $ GenericPackageDescription + pkg { sourceRepos = repos } + flags mlib exes tests + + where + oldSyntax flds = all isSimpleField flds + reportTabsError tabs = + syntaxError (fst (head tabs)) $ + "Do not use tabs for indentation (use spaces instead)\n" + ++ " Tabs were used at (line,column): " ++ show tabs + + maybeWarnCabalVersion newsyntax pkg + | newsyntax && specVersion pkg < Version [1,2] [] + = lift $ warning $ + "A package using section syntax must specify at least\n" + ++ "'cabal-version: >= 1.2'." + + maybeWarnCabalVersion newsyntax pkg + | not newsyntax && specVersion pkg >= Version [1,2] [] + = lift $ warning $ + "A package using 'cabal-version: " + ++ displaySpecVersion (specVersionRaw pkg) + ++ "' must use section syntax. See the Cabal user guide for details." + where + displaySpecVersion (Left version) = display version + displaySpecVersion (Right versionRange) = + case asVersionIntervals versionRange of + [] {- impossible -} -> display versionRange + ((LowerBound version _, _):_) -> display (orLaterVersion version) + + maybeWarnCabalVersion _ _ = return () + + + handleFutureVersionParseFailure cabalVersionNeeded parseBody = + (unless versionOk (warning message) >> parseBody) + `catchParseError` \parseError -> case parseError of + TabsError _ -> parseFail parseError + _ | versionOk -> parseFail parseError + | otherwise -> fail message + where versionOk = cabalVersionNeeded <= cabalVersion + message = "This package requires at least Cabal version " + ++ display cabalVersionNeeded + + -- "Sectionize" an old-style Cabal file. A sectionized file has: + -- + -- * all global fields at the beginning, followed by + -- + -- * all flag declarations, followed by + -- + -- * an optional library section, and an arbitrary number of executable + -- sections (in any order). + -- + -- The current implementatition just gathers all library-specific fields + -- in a library section and wraps all executable stanzas in an executable + -- section. + sectionizeFields :: [Field] -> [Field] + sectionizeFields fs + | oldSyntax fs = + let + -- "build-depends" is a local field now. To be backwards + -- compatible, we still allow it as a global field in old-style + -- package description files and translate it to a local field by + -- adding it to every non-empty section + (hdr0, exes0) = break ((=="executable") . fName) fs + (hdr, libfs0) = partition (not . (`elem` libFieldNames) . fName) hdr0 + + (deps, libfs) = partition ((== "build-depends") . fName) + libfs0 + + exes = unfoldr toExe exes0 + toExe [] = Nothing + toExe (F l e n : r) + | e == "executable" = + let (efs, r') = break ((=="executable") . fName) r + in Just (Section l "executable" n (deps ++ efs), r') + toExe _ = bug "unexpeced input to 'toExe'" + in + hdr ++ + (if null libfs then [] + else [Section (lineNo (head libfs)) "library" "" (deps ++ libfs)]) + ++ exes + | otherwise = fs + + isSimpleField (F _ _ _) = True + isSimpleField _ = False + + -- warn if there's something at the end of the file + warnIfRest :: PM () + warnIfRest = do + s <- get + case s of + [] -> return () + _ -> lift $ warning "Ignoring trailing declarations." -- add line no. + + -- all simple fields at the beginning of the file are (considered) header + -- fields + getHeader :: [Field] -> PM [Field] + getHeader acc = peekField >>= \mf -> case mf of + Just f@(F _ _ _) -> skipField >> getHeader (f:acc) + _ -> return (reverse acc) + + -- + -- body ::= { repo | flag | library | executable | test }+ -- at most one lib + -- + -- The body consists of an optional sequence of declarations of flags and + -- an arbitrary number of executables and at most one library. + getBody :: PM ([SourceRepo], [Flag] + ,Maybe (CondTree ConfVar [Dependency] Library) + ,[(String, CondTree ConfVar [Dependency] Executable)] + ,[(String, CondTree ConfVar [Dependency] TestSuite)]) + getBody = peekField >>= \mf -> case mf of + Just (Section line_no sec_type sec_label sec_fields) + | sec_type == "executable" -> do + when (null sec_label) $ lift $ syntaxError line_no + "'executable' needs one argument (the executable's name)" + exename <- lift $ runP line_no "executable" parseTokenQ sec_label + flds <- collectFields parseExeFields sec_fields + skipField + (repos, flags, lib, exes, tests) <- getBody + return (repos, flags, lib, (exename, flds): exes, tests) + + | sec_type == "test-suite" -> do + when (null sec_label) $ lift $ syntaxError line_no + "'test-suite' needs one argument (the test suite's name)" + testname <- lift $ runP line_no "test" parseTokenQ sec_label + flds <- collectFields (parseTestFields line_no) sec_fields + + -- Check that a valid test suite type has been chosen. A type + -- field may be given inside a conditional block, so we must + -- check for that before complaining that a type field has not + -- been given. The test suite must always have a valid type, so + -- we need to check both the 'then' and 'else' blocks, though + -- the blocks need not have the same type. + let checkTestType ts ct = + let ts' = mappend ts $ condTreeData ct + -- If a conditional has only a 'then' block and no + -- 'else' block, then it cannot have a valid type + -- in every branch, unless the type is specified at + -- a higher level in the tree. + checkComponent (_, _, Nothing) = False + -- If a conditional has a 'then' block and an 'else' + -- block, both must specify a test type, unless the + -- type is specified higher in the tree. + checkComponent (_, t, Just e) = + checkTestType ts' t && checkTestType ts' e + -- Does the current node specify a test type? + hasTestType = testInterface ts' + /= testInterface emptyTestSuite + components = condTreeComponents ct + -- If the current level of the tree specifies a type, + -- then we are done. If not, then one of the conditional + -- branches below the current node must specify a type. + -- Each node may have multiple immediate children; we + -- only one need one to specify a type because the + -- configure step uses 'mappend' to join together the + -- results of flag resolution. + in hasTestType || (any checkComponent components) + if checkTestType emptyTestSuite flds + then do + skipField + (repos, flags, lib, exes, tests) <- getBody + return (repos, flags, lib, exes, (testname, flds) : tests) + else lift $ syntaxError line_no $ + "Test suite \"" ++ testname + ++ "\" is missing required field \"type\" or the field " + ++ "is not present in all conditional branches. The " + ++ "available test types are: " + ++ intercalate ", " (map display knownTestTypes) + + | sec_type == "library" -> do + when (not (null sec_label)) $ lift $ + syntaxError line_no "'library' expects no argument" + flds <- collectFields parseLibFields sec_fields + skipField + (repos, flags, lib, exes, tests) <- getBody + when (isJust lib) $ lift $ syntaxError line_no + "There can only be one library section in a package description." + return (repos, flags, Just flds, exes, tests) + + | sec_type == "flag" -> do + when (null sec_label) $ lift $ + syntaxError line_no "'flag' needs one argument (the flag's name)" + flag <- lift $ parseFields + flagFieldDescrs + warnUnrec + (MkFlag (FlagName (lowercase sec_label)) "" True False) + sec_fields + skipField + (repos, flags, lib, exes, tests) <- getBody + return (repos, flag:flags, lib, exes, tests) + + | sec_type == "source-repository" -> do + when (null sec_label) $ lift $ syntaxError line_no $ + "'source-repository' needs one argument, " + ++ "the repo kind which is usually 'head' or 'this'" + kind <- case simpleParse sec_label of + Just kind -> return kind + Nothing -> lift $ syntaxError line_no $ + "could not parse repo kind: " ++ sec_label + repo <- lift $ parseFields + sourceRepoFieldDescrs + warnUnrec + (SourceRepo { + repoKind = kind, + repoType = Nothing, + repoLocation = Nothing, + repoModule = Nothing, + repoBranch = Nothing, + repoTag = Nothing, + repoSubdir = Nothing + }) + sec_fields + skipField + (repos, flags, lib, exes, tests) <- getBody + return (repo:repos, flags, lib, exes, tests) + + | otherwise -> do + lift $ warning $ "Ignoring unknown section type: " ++ sec_type + skipField + getBody + Just f -> do + _ <- lift $ syntaxError (lineNo f) $ + "Construct not supported at this position: " ++ show f + skipField + getBody + Nothing -> return ([], [], Nothing, [], []) + + -- Extracts all fields in a block and returns a 'CondTree'. + -- + -- We have to recurse down into conditionals and we treat fields that + -- describe dependencies specially. + collectFields :: ([Field] -> PM a) -> [Field] + -> PM (CondTree ConfVar [Dependency] a) + collectFields parser allflds = do + + let simplFlds = [ F l n v | F l n v <- allflds ] + condFlds = [ f | f@(IfBlock _ _ _ _) <- allflds ] + + let (depFlds, dataFlds) = partition isConstraint simplFlds + + a <- parser dataFlds + deps <- liftM concat . mapM (lift . parseConstraint) $ depFlds + + ifs <- mapM processIfs condFlds + + return (CondNode a deps ifs) + where + isConstraint (F _ n _) = n `elem` constraintFieldNames + isConstraint _ = False + + processIfs (IfBlock l c t e) = do + cnd <- lift $ runP l "if" parseCondition c + t' <- collectFields parser t + e' <- case e of + [] -> return Nothing + es -> do fs <- collectFields parser es + return (Just fs) + return (cnd, t', e') + processIfs _ = bug "processIfs called with wrong field type" + + parseLibFields :: [Field] -> PM Library + parseLibFields = lift . parseFields libFieldDescrs storeXFieldsLib emptyLibrary + + -- Note: we don't parse the "executable" field here, hence the tail hack. + parseExeFields :: [Field] -> PM Executable + parseExeFields = lift . parseFields (tail executableFieldDescrs) storeXFieldsExe emptyExecutable + + parseTestFields :: LineNo -> [Field] -> PM TestSuite + parseTestFields line fields = do + x <- lift $ parseFields testSuiteFieldDescrs storeXFieldsTest + emptyTestStanza fields + lift $ validateTestSuite line x + + checkForUndefinedFlags :: + [Flag] -> + Maybe (CondTree ConfVar [Dependency] Library) -> + [(String, CondTree ConfVar [Dependency] Executable)] -> + [(String, CondTree ConfVar [Dependency] TestSuite)] -> + PM () + checkForUndefinedFlags flags mlib exes tests = do + let definedFlags = map flagName flags + maybe (return ()) (checkCondTreeFlags definedFlags) mlib + mapM_ (checkCondTreeFlags definedFlags . snd) exes + mapM_ (checkCondTreeFlags definedFlags . snd) tests + + checkCondTreeFlags :: [FlagName] -> CondTree ConfVar c a -> PM () + checkCondTreeFlags definedFlags ct = do + let fv = nub $ freeVars ct + when (not . all (`elem` definedFlags) $ fv) $ + fail $ "These flags are used without having been defined: " + ++ intercalate ", " [ n | FlagName n <- fv \\ definedFlags ] + + +-- | Parse a list of fields, given a list of field descriptions, +-- a structure to accumulate the parsed fields, and a function +-- that can decide what to do with fields which don't match any +-- of the field descriptions. +parseFields :: [FieldDescr a] -- ^ descriptions of fields we know how to + -- parse + -> UnrecFieldParser a -- ^ possibly do something with + -- unrecognized fields + -> a -- ^ accumulator + -> [Field] -- ^ fields to be parsed + -> ParseResult a +parseFields descrs unrec ini fields = + do (a, unknowns) <- foldM (parseField descrs unrec) (ini, []) fields + when (not (null unknowns)) $ do + warning $ render $ + text "Unknown fields:" <+> + commaSep (map (\(l,u) -> u ++ " (line " ++ show l ++ ")") + (reverse unknowns)) + $+$ + text "Fields allowed in this section:" $$ + nest 4 (commaSep $ map fieldName descrs) + return a + where + commaSep = fsep . punctuate comma . map text + +parseField :: [FieldDescr a] -- ^ list of parseable fields + -> UnrecFieldParser a -- ^ possibly do something with + -- unrecognized fields + -> (a,[(Int,String)]) -- ^ accumulated result and warnings + -> Field -- ^ the field to be parsed + -> ParseResult (a, [(Int,String)]) +parseField ((FieldDescr name _ parser):fields) unrec (a, us) (F line f val) + | name == f = parser line val a >>= \a' -> return (a',us) + | otherwise = parseField fields unrec (a,us) (F line f val) +parseField [] unrec (a,us) (F l f val) = return $ + case unrec (f,val) a of -- no fields matched, see if the 'unrec' + Just a' -> (a',us) -- function wants to do anything with it + Nothing -> (a, ((l,f):us)) +parseField _ _ _ _ = bug "'parseField' called on a non-field" + +deprecatedFields :: [(String,String)] +deprecatedFields = + deprecatedFieldsPkgDescr ++ deprecatedFieldsBuildInfo + +deprecatedFieldsPkgDescr :: [(String,String)] +deprecatedFieldsPkgDescr = [ ("other-files", "extra-source-files") ] + +deprecatedFieldsBuildInfo :: [(String,String)] +deprecatedFieldsBuildInfo = [ ("hs-source-dir","hs-source-dirs") ] + +-- Handle deprecated fields +deprecField :: Field -> ParseResult Field +deprecField (F line fld val) = do + fld' <- case lookup fld deprecatedFields of + Nothing -> return fld + Just newName -> do + warning $ "The field \"" ++ fld + ++ "\" is deprecated, please use \"" ++ newName ++ "\"" + return newName + return (F line fld' val) +deprecField _ = bug "'deprecField' called on a non-field" + + +parseHookedBuildInfo :: String -> ParseResult HookedBuildInfo +parseHookedBuildInfo inp = do + fields <- readFields inp + let ss@(mLibFields:exes) = stanzas fields + mLib <- parseLib mLibFields + biExes <- mapM parseExe (maybe ss (const exes) mLib) + return (mLib, biExes) + where + parseLib :: [Field] -> ParseResult (Maybe BuildInfo) + parseLib (bi@((F _ inFieldName _):_)) + | lowercase inFieldName /= "executable" = liftM Just (parseBI bi) + parseLib _ = return Nothing + + parseExe :: [Field] -> ParseResult (String, BuildInfo) + parseExe ((F line inFieldName mName):bi) + | lowercase inFieldName == "executable" + = do bis <- parseBI bi + return (mName, bis) + | otherwise = syntaxError line "expecting 'executable' at top of stanza" + parseExe (_:_) = bug "`parseExe' called on a non-field" + parseExe [] = syntaxError 0 "error in parsing buildinfo file. Expected executable stanza" + + parseBI st = parseFields binfoFieldDescrs storeXFieldsBI emptyBuildInfo st + +-- --------------------------------------------------------------------------- +-- Pretty printing + +writePackageDescription :: FilePath -> PackageDescription -> IO () +writePackageDescription fpath pkg = writeUTF8File fpath (showPackageDescription pkg) + +--TODO: make this use section syntax +-- add equivalent for GenericPackageDescription +showPackageDescription :: PackageDescription -> String +showPackageDescription pkg = render $ + ppPackage pkg + $$ ppCustomFields (customFieldsPD pkg) + $$ (case library pkg of + Nothing -> empty + Just lib -> ppLibrary lib) + $$ vcat [ space $$ ppExecutable exe | exe <- executables pkg ] + where + ppPackage = ppFields pkgDescrFieldDescrs + ppLibrary = ppFields libFieldDescrs + ppExecutable = ppFields executableFieldDescrs + +ppCustomFields :: [(String,String)] -> Doc +ppCustomFields flds = vcat (map ppCustomField flds) + +ppCustomField :: (String,String) -> Doc +ppCustomField (name,val) = text name <> colon <+> showFreeText val + +writeHookedBuildInfo :: FilePath -> HookedBuildInfo -> IO () +writeHookedBuildInfo fpath = writeFileAtomic fpath . showHookedBuildInfo + +showHookedBuildInfo :: HookedBuildInfo -> String +showHookedBuildInfo (mb_lib_bi, ex_bis) = render $ + (case mb_lib_bi of + Nothing -> empty + Just bi -> ppBuildInfo bi) + $$ vcat [ space + $$ text "executable:" <+> text name + $$ ppBuildInfo bi + | (name, bi) <- ex_bis ] + where + ppBuildInfo bi = ppFields binfoFieldDescrs bi + $$ ppCustomFields (customFieldsBI bi) + +-- replace all tabs used as indentation with whitespace, also return where +-- tabs were found +findIndentTabs :: String -> [(Int,Int)] +findIndentTabs = concatMap checkLine + . zip [1..] + . lines + where + checkLine (lineno, l) = + let (indent, _content) = span isSpace l + tabCols = map fst . filter ((== '\t') . snd) . zip [0..] + addLineNo = map (\col -> (lineno,col)) + in addLineNo (tabCols indent) + +--test_findIndentTabs = findIndentTabs $ unlines $ +-- [ "foo", " bar", " \t baz", "\t biz\t", "\t\t \t mib" ] + +bug :: String -> a +bug msg = error $ msg ++ ". Consider this a bug." diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/PackageDescription/PrettyPrint.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/PackageDescription/PrettyPrint.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/PackageDescription/PrettyPrint.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/PackageDescription/PrettyPrint.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,238 @@ +----------------------------------------------------------------------------- +-- +-- Module : Distribution.PackageDescription.PrettyPrint +-- Copyright : Jürgen Nicklisch-Franken 2010 +-- License : AllRightsReserved +-- +-- Maintainer : cabal-devel@haskell.org +-- Stability : provisional +-- Portability : portable +-- +-- | Pretty printing for cabal files +-- +----------------------------------------------------------------------------- +{- All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.PackageDescription.PrettyPrint ( + writeGenericPackageDescription, + showGenericPackageDescription, +) where + +import Distribution.PackageDescription + ( TestSuite(..), TestSuiteInterface(..), testType + , SourceRepo(..), + customFieldsBI, CondTree(..), Condition(..), + FlagName(..), ConfVar(..), Executable(..), Library(..), + Flag(..), PackageDescription(..), + GenericPackageDescription(..)) +import Text.PrettyPrint + (hsep, comma, punctuate, fsep, parens, char, nest, empty, + isEmpty, ($$), (<+>), colon, (<>), text, vcat, ($+$), Doc, render) +import Distribution.Simple.Utils (writeUTF8File) +import Distribution.ParseUtils (showFreeText, FieldDescr(..)) +import Distribution.PackageDescription.Parse (pkgDescrFieldDescrs,binfoFieldDescrs,libFieldDescrs, + sourceRepoFieldDescrs) +import Distribution.Package (Dependency(..)) +import Distribution.Text (Text(..)) +import Data.Maybe (isJust, fromJust, isNothing) + +indentWith :: Int +indentWith = 4 + +-- | Recompile with false for regression testing +simplifiedPrinting :: Bool +simplifiedPrinting = False + +-- | Writes a .cabal file from a generic package description +writeGenericPackageDescription :: FilePath -> GenericPackageDescription -> IO () +writeGenericPackageDescription fpath pkg = writeUTF8File fpath (showGenericPackageDescription pkg) + +-- | Writes a generic package description to a string +showGenericPackageDescription :: GenericPackageDescription -> String +showGenericPackageDescription = render . ppGenericPackageDescription + +ppGenericPackageDescription :: GenericPackageDescription -> Doc +ppGenericPackageDescription gpd = + ppPackageDescription (packageDescription gpd) + $+$ ppGenPackageFlags (genPackageFlags gpd) + $+$ ppLibrary (condLibrary gpd) + $+$ ppExecutables (condExecutables gpd) + $+$ ppTestSuites (condTestSuites gpd) + +ppPackageDescription :: PackageDescription -> Doc +ppPackageDescription pd = ppFields pkgDescrFieldDescrs pd + $+$ ppCustomFields (customFieldsPD pd) + $+$ ppSourceRepos (sourceRepos pd) + +ppSourceRepos :: [SourceRepo] -> Doc +ppSourceRepos [] = empty +ppSourceRepos (hd:tl) = ppSourceRepo hd $+$ ppSourceRepos tl + +ppSourceRepo :: SourceRepo -> Doc +ppSourceRepo repo = + emptyLine $ text "source-repository" <+> disp (repoKind repo) $+$ + (nest indentWith (ppFields sourceRepoFieldDescrs' repo)) + where + sourceRepoFieldDescrs' = [fd | fd <- sourceRepoFieldDescrs, fieldName fd /= "kind"] + +ppFields :: [FieldDescr a] -> a -> Doc +ppFields fields x = + vcat [ ppField name (getter x) + | FieldDescr name getter _ <- fields] + +ppField :: String -> Doc -> Doc +ppField name fielddoc | isEmpty fielddoc = empty + | otherwise = text name <> colon <+> fielddoc + +ppDiffFields :: [FieldDescr a] -> a -> a -> Doc +ppDiffFields fields x y = + vcat [ ppField name (getter x) + | FieldDescr name getter _ <- fields, + render (getter x) /= render (getter y)] + +ppCustomFields :: [(String,String)] -> Doc +ppCustomFields flds = vcat [ppCustomField f | f <- flds] + +ppCustomField :: (String,String) -> Doc +ppCustomField (name,val) = text name <> colon <+> showFreeText val + +ppGenPackageFlags :: [Flag] -> Doc +ppGenPackageFlags flds = vcat [ppFlag f | f <- flds] + +ppFlag :: Flag -> Doc +ppFlag (MkFlag name desc dflt manual) = + emptyLine $ text "flag" <+> ppFlagName name $+$ + (nest indentWith ((if null desc + then empty + else text "Description: " <+> showFreeText desc) $+$ + (if dflt then empty else text "Default: False") $+$ + (if manual then text "Manual: True" else empty))) + +ppLibrary :: (Maybe (CondTree ConfVar [Dependency] Library)) -> Doc +ppLibrary Nothing = empty +ppLibrary (Just condTree) = + emptyLine $ text "library" $+$ nest indentWith (ppCondTree condTree Nothing ppLib) + where + ppLib lib Nothing = ppFields libFieldDescrs lib + $$ ppCustomFields (customFieldsBI (libBuildInfo lib)) + ppLib lib (Just plib) = ppDiffFields libFieldDescrs lib plib + $$ ppCustomFields (customFieldsBI (libBuildInfo lib)) + +ppExecutables :: [(String, CondTree ConfVar [Dependency] Executable)] -> Doc +ppExecutables exes = + vcat [emptyLine $ text ("executable " ++ n) + $+$ nest indentWith (ppCondTree condTree Nothing ppExe)| (n,condTree) <- exes] + where + ppExe (Executable _ modulePath' buildInfo') Nothing = + (if modulePath' == "" then empty else text "main-is:" <+> text modulePath') + $+$ ppFields binfoFieldDescrs buildInfo' + $+$ ppCustomFields (customFieldsBI buildInfo') + ppExe (Executable _ modulePath' buildInfo') + (Just (Executable _ modulePath2 buildInfo2)) = + (if modulePath' == "" || modulePath' == modulePath2 + then empty else text "main-is:" <+> text modulePath') + $+$ ppDiffFields binfoFieldDescrs buildInfo' buildInfo2 + $+$ ppCustomFields (customFieldsBI buildInfo') + +ppTestSuites :: [(String, CondTree ConfVar [Dependency] TestSuite)] -> Doc +ppTestSuites suites = + emptyLine $ vcat [ text ("test-suite " ++ n) + $+$ nest indentWith (ppCondTree condTree Nothing ppTestSuite) + | (n,condTree) <- suites] + where + ppTestSuite testsuite Nothing = + text "type:" <+> disp (testType testsuite) + $+$ maybe empty (\f -> text "main-is:" <+> text f) + (testSuiteMainIs testsuite) + $+$ maybe empty (\m -> text "test-module:" <+> disp m) + (testSuiteModule testsuite) + $+$ ppFields binfoFieldDescrs (testBuildInfo testsuite) + $+$ ppCustomFields (customFieldsBI (testBuildInfo testsuite)) + + ppTestSuite (TestSuite _ _ buildInfo' _) + (Just (TestSuite _ _ buildInfo2 _)) = + ppDiffFields binfoFieldDescrs buildInfo' buildInfo2 + $+$ ppCustomFields (customFieldsBI buildInfo') + + testSuiteMainIs test = case testInterface test of + TestSuiteExeV10 _ f -> Just f + _ -> Nothing + + testSuiteModule test = case testInterface test of + TestSuiteLibV09 _ m -> Just m + _ -> Nothing + +ppCondition :: Condition ConfVar -> Doc +ppCondition (Var x) = ppConfVar x +ppCondition (Lit b) = text (show b) +ppCondition (CNot c) = char '!' <> (ppCondition c) +ppCondition (COr c1 c2) = parens (hsep [ppCondition c1, text "||" + <+> ppCondition c2]) +ppCondition (CAnd c1 c2) = parens (hsep [ppCondition c1, text "&&" + <+> ppCondition c2]) +ppConfVar :: ConfVar -> Doc +ppConfVar (OS os) = text "os" <> parens (disp os) +ppConfVar (Arch arch) = text "arch" <> parens (disp arch) +ppConfVar (Flag name) = text "flag" <> parens (ppFlagName name) +ppConfVar (Impl c v) = text "impl" <> parens (disp c <+> disp v) + +ppFlagName :: FlagName -> Doc +ppFlagName (FlagName name) = text name + +ppCondTree :: CondTree ConfVar [Dependency] a -> Maybe a -> (a -> Maybe a -> Doc) -> Doc +ppCondTree ct@(CondNode it deps ifs) mbIt ppIt = + let res = ppDeps deps + $+$ (vcat $ map ppIf ifs) + $+$ ppIt it mbIt + in if isJust mbIt && isEmpty res + then ppCondTree ct Nothing ppIt + else res + where + ppIf (c,thenTree,mElseTree) = + ((emptyLine $ text "if" <+> ppCondition c) $$ + nest indentWith (ppCondTree thenTree + (if simplifiedPrinting then (Just it) else Nothing) ppIt)) + $+$ (if isNothing mElseTree + then empty + else text "else" + $$ nest indentWith (ppCondTree (fromJust mElseTree) + (if simplifiedPrinting then (Just it) else Nothing) ppIt)) + +ppDeps :: [Dependency] -> Doc +ppDeps [] = empty +ppDeps deps = + text "build-depends:" <+> fsep (punctuate comma (map disp deps)) + +emptyLine :: Doc -> Doc +emptyLine d = text " " $+$ d + + + diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/PackageDescription.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/PackageDescription.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/PackageDescription.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/PackageDescription.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,895 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.PackageDescription +-- Copyright : Isaac Jones 2003-2005 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This defines the data structure for the @.cabal@ file format. There are +-- several parts to this structure. It has top level info and then 'Library', +-- 'Executable', and 'TestSuite' sections each of which have associated +-- 'BuildInfo' data that's used to build the library, exe, or test. To further +-- complicate things there is both a 'PackageDescription' and a +-- 'GenericPackageDescription'. This distinction relates to cabal +-- configurations. When we initially read a @.cabal@ file we get a +-- 'GenericPackageDescription' which has all the conditional sections. +-- Before actually building a package we have to decide +-- on each conditional. Once we've done that we get a 'PackageDescription'. +-- It was done this way initially to avoid breaking too much stuff when the +-- feature was introduced. It could probably do with being rationalised at some +-- point to make it simpler. + +{- All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.PackageDescription ( + -- * Package descriptions + PackageDescription(..), + emptyPackageDescription, + specVersion, + descCabalVersion, + BuildType(..), + knownBuildTypes, + + -- ** Libraries + Library(..), + emptyLibrary, + withLib, + hasLibs, + libModules, + + -- ** Executables + Executable(..), + emptyExecutable, + withExe, + hasExes, + exeModules, + + -- * Tests + TestSuite(..), + TestSuiteInterface(..), + TestType(..), + testType, + knownTestTypes, + emptyTestSuite, + hasTests, + withTest, + testModules, + enabledTests, + + -- * Build information + BuildInfo(..), + emptyBuildInfo, + allBuildInfo, + allLanguages, + allExtensions, + usedExtensions, + hcOptions, + + -- ** Supplementary build information + HookedBuildInfo, + emptyHookedBuildInfo, + updatePackageDescription, + + -- * package configuration + GenericPackageDescription(..), + Flag(..), FlagName(..), FlagAssignment, + CondTree(..), ConfVar(..), Condition(..), + + -- * Source repositories + SourceRepo(..), + RepoKind(..), + RepoType(..), + knownRepoTypes, + ) where + +import Data.List (nub, intersperse) +import Data.Maybe (maybeToList) +import Data.Monoid (Monoid(mempty, mappend)) +import Control.Monad (MonadPlus(mplus)) +import Text.PrettyPrint.HughesPJ as Disp +import qualified Distribution.Compat.ReadP as Parse +import qualified Data.Char as Char (isAlphaNum, isDigit, toLower) + +import Distribution.Package + ( PackageName(PackageName), PackageIdentifier(PackageIdentifier) + , Dependency, Package(..) ) +import Distribution.ModuleName ( ModuleName ) +import Distribution.Version + ( Version(Version), VersionRange, anyVersion, orLaterVersion + , asVersionIntervals, LowerBound(..) ) +import Distribution.License (License(AllRightsReserved)) +import Distribution.Compiler (CompilerFlavor) +import Distribution.System (OS, Arch) +import Distribution.Text + ( Text(..), display ) +import Language.Haskell.Extension + ( Language, Extension ) + +-- ----------------------------------------------------------------------------- +-- The PackageDescription type + +-- | This data type is the internal representation of the file @pkg.cabal@. +-- It contains two kinds of information about the package: information +-- which is needed for all packages, such as the package name and version, and +-- information which is needed for the simple build system only, such as +-- the compiler options and library name. +-- +data PackageDescription + = PackageDescription { + -- the following are required by all packages: + package :: PackageIdentifier, + license :: License, + licenseFile :: FilePath, + copyright :: String, + maintainer :: String, + author :: String, + stability :: String, + testedWith :: [(CompilerFlavor,VersionRange)], + homepage :: String, + pkgUrl :: String, + bugReports :: String, + sourceRepos :: [SourceRepo], + synopsis :: String, -- ^A one-line summary of this package + description :: String, -- ^A more verbose description of this package + category :: String, + customFieldsPD :: [(String,String)], -- ^Custom fields starting + -- with x-, stored in a + -- simple assoc-list. + buildDepends :: [Dependency], + -- | The version of the Cabal spec that this package description uses. + -- For historical reasons this is specified with a version range but + -- only ranges of the form @>= v@ make sense. We are in the process of + -- transitioning to specifying just a single version, not a range. + specVersionRaw :: Either Version VersionRange, + buildType :: Maybe BuildType, + -- components + library :: Maybe Library, + executables :: [Executable], + testSuites :: [TestSuite], + dataFiles :: [FilePath], + dataDir :: FilePath, + extraSrcFiles :: [FilePath], + extraTmpFiles :: [FilePath] + } + deriving (Show, Read, Eq) + +instance Package PackageDescription where + packageId = package + +-- | The version of the Cabal spec that this package should be interpreted +-- against. +-- +-- Historically we used a version range but we are switching to using a single +-- version. Currently we accept either. This function converts into a single +-- version by ignoring upper bounds in the version range. +-- +specVersion :: PackageDescription -> Version +specVersion pkg = case specVersionRaw pkg of + Left version -> version + Right versionRange -> case asVersionIntervals versionRange of + [] -> Version [0] [] + ((LowerBound version _, _):_) -> version + +-- | The range of versions of the Cabal tools that this package is intended to +-- work with. +-- +-- This function is deprecated and should not be used for new purposes, only to +-- support old packages that rely on the old interpretation. +-- +descCabalVersion :: PackageDescription -> VersionRange +descCabalVersion pkg = case specVersionRaw pkg of + Left version -> orLaterVersion version + Right versionRange -> versionRange +{-# DEPRECATED descCabalVersion "Use specVersion instead" #-} + +emptyPackageDescription :: PackageDescription +emptyPackageDescription + = PackageDescription { + package = PackageIdentifier (PackageName "") + (Version [] []), + license = AllRightsReserved, + licenseFile = "", + specVersionRaw = Right anyVersion, + buildType = Nothing, + copyright = "", + maintainer = "", + author = "", + stability = "", + testedWith = [], + buildDepends = [], + homepage = "", + pkgUrl = "", + bugReports = "", + sourceRepos = [], + synopsis = "", + description = "", + category = "", + customFieldsPD = [], + library = Nothing, + executables = [], + testSuites = [], + dataFiles = [], + dataDir = "", + extraSrcFiles = [], + extraTmpFiles = [] + } + +-- | The type of build system used by this package. +data BuildType + = Simple -- ^ calls @Distribution.Simple.defaultMain@ + | Configure -- ^ calls @Distribution.Simple.defaultMainWithHooks defaultUserHooks@, + -- which invokes @configure@ to generate additional build + -- information used by later phases. + | Make -- ^ calls @Distribution.Make.defaultMain@ + | Custom -- ^ uses user-supplied @Setup.hs@ or @Setup.lhs@ (default) + | UnknownBuildType String + -- ^ a package that uses an unknown build type cannot actually + -- be built. Doing it this way rather than just giving a + -- parse error means we get better error messages and allows + -- you to inspect the rest of the package description. + deriving (Show, Read, Eq) + +knownBuildTypes :: [BuildType] +knownBuildTypes = [Simple, Configure, Make, Custom] + +instance Text BuildType where + disp (UnknownBuildType other) = Disp.text other + disp other = Disp.text (show other) + + parse = do + name <- Parse.munch1 Char.isAlphaNum + return $ case name of + "Simple" -> Simple + "Configure" -> Configure + "Custom" -> Custom + "Make" -> Make + _ -> UnknownBuildType name + +-- --------------------------------------------------------------------------- +-- The Library type + +data Library = Library { + exposedModules :: [ModuleName], + libExposed :: Bool, -- ^ Is the lib to be exposed by default? + libBuildInfo :: BuildInfo + } + deriving (Show, Eq, Read) + +instance Monoid Library where + mempty = Library { + exposedModules = mempty, + libExposed = True, + libBuildInfo = mempty + } + mappend a b = Library { + exposedModules = combine exposedModules, + libExposed = libExposed a && libExposed b, -- so False propagates + libBuildInfo = combine libBuildInfo + } + where combine field = field a `mappend` field b + +emptyLibrary :: Library +emptyLibrary = mempty + +-- |does this package have any libraries? +hasLibs :: PackageDescription -> Bool +hasLibs p = maybe False (buildable . libBuildInfo) (library p) + +-- |'Maybe' version of 'hasLibs' +maybeHasLibs :: PackageDescription -> Maybe Library +maybeHasLibs p = + library p >>= \lib -> if buildable (libBuildInfo lib) + then Just lib + else Nothing + +-- |If the package description has a library section, call the given +-- function with the library build info as argument. +withLib :: PackageDescription -> (Library -> IO ()) -> IO () +withLib pkg_descr f = + maybe (return ()) f (maybeHasLibs pkg_descr) + +-- | Get all the module names from the library (exposed and internal modules) +libModules :: Library -> [ModuleName] +libModules lib = exposedModules lib + ++ otherModules (libBuildInfo lib) + +-- --------------------------------------------------------------------------- +-- The Executable type + +data Executable = Executable { + exeName :: String, + modulePath :: FilePath, + buildInfo :: BuildInfo + } + deriving (Show, Read, Eq) + +instance Monoid Executable where + mempty = Executable { + exeName = mempty, + modulePath = mempty, + buildInfo = mempty + } + mappend a b = Executable{ + exeName = combine' exeName, + modulePath = combine modulePath, + buildInfo = combine buildInfo + } + where combine field = field a `mappend` field b + combine' field = case (field a, field b) of + ("","") -> "" + ("", x) -> x + (x, "") -> x + (x, y) -> error $ "Ambiguous values for executable field: '" + ++ x ++ "' and '" ++ y ++ "'" + +emptyExecutable :: Executable +emptyExecutable = mempty + +-- |does this package have any executables? +hasExes :: PackageDescription -> Bool +hasExes p = any (buildable . buildInfo) (executables p) + +-- | Perform the action on each buildable 'Executable' in the package +-- description. +withExe :: PackageDescription -> (Executable -> IO ()) -> IO () +withExe pkg_descr f = + sequence_ [f exe | exe <- executables pkg_descr, buildable (buildInfo exe)] + +-- | Get all the module names from an exe +exeModules :: Executable -> [ModuleName] +exeModules exe = otherModules (buildInfo exe) + +-- --------------------------------------------------------------------------- +-- The TestSuite type + +-- | A \"test-suite\" stanza in a cabal file. +-- +data TestSuite = TestSuite { + testName :: String, + testInterface :: TestSuiteInterface, + testBuildInfo :: BuildInfo, + testEnabled :: Bool + -- TODO: By having a 'testEnabled' field in the PackageDescription, we + -- are mixing build status information (i.e., arguments to 'configure') + -- with static package description information. This is undesirable, but + -- a better solution is waiting on the next overhaul to the + -- GenericPackageDescription -> PackageDescription resolution process. + } + deriving (Show, Read, Eq) + +-- | The test suite interfaces that are currently defined. Each test suite must +-- specify which interface it supports. +-- +-- More interfaces may be defined in future, either new revisions or totally +-- new interfaces. +-- +data TestSuiteInterface = + + -- | Test interface \"exitcode-stdio-1.0\". The test-suite takes the form + -- of an executable. It returns a zero exit code for success, non-zero for + -- failure. The stdout and stderr channels may be logged. It takes no + -- command line parameters and nothing on stdin. + -- + TestSuiteExeV10 Version FilePath + + -- | Test interface \"detailed-0.9\". The test-suite takes the form of a + -- library containing a designated module that exports \"tests :: [Test]\". + -- + | TestSuiteLibV09 Version ModuleName + + -- | A test suite that does not conform to one of the above interfaces for + -- the given reason (e.g. unknown test type). + -- + | TestSuiteUnsupported TestType + deriving (Eq, Read, Show) + +instance Monoid TestSuite where + mempty = TestSuite { + testName = mempty, + testInterface = mempty, + testBuildInfo = mempty, + testEnabled = False + } + + mappend a b = TestSuite { + testName = combine' testName, + testInterface = combine testInterface, + testBuildInfo = combine testBuildInfo, + testEnabled = if testEnabled a then True else testEnabled b + } + where combine field = field a `mappend` field b + combine' f = case (f a, f b) of + ("", x) -> x + (x, "") -> x + (x, y) -> error "Ambiguous values for test field: '" + ++ x ++ "' and '" ++ y ++ "'" + +instance Monoid TestSuiteInterface where + mempty = TestSuiteUnsupported (TestTypeUnknown mempty (Version [] [])) + mappend a (TestSuiteUnsupported _) = a + mappend _ b = b + +emptyTestSuite :: TestSuite +emptyTestSuite = mempty + +-- | Does this package have any test suites? +hasTests :: PackageDescription -> Bool +hasTests = any (buildable . testBuildInfo) . testSuites + +-- | Get all the enabled test suites from a package. +enabledTests :: PackageDescription -> [TestSuite] +enabledTests = filter testEnabled . testSuites + +-- | Perform an action on each buildable 'TestSuite' in a package. +withTest :: PackageDescription -> (TestSuite -> IO ()) -> IO () +withTest pkg_descr f = + mapM_ f $ filter (buildable . testBuildInfo) $ enabledTests pkg_descr + +-- | Get all the module names from a test suite. +testModules :: TestSuite -> [ModuleName] +testModules test = (case testInterface test of + TestSuiteLibV09 _ m -> [m] + _ -> []) + ++ otherModules (testBuildInfo test) + +-- | The \"test-type\" field in the test suite stanza. +-- +data TestType = TestTypeExe Version -- ^ \"type: exitcode-stdio-x.y\" + | TestTypeLib Version -- ^ \"type: detailed-x.y\" + | TestTypeUnknown String Version -- ^ Some unknown test type e.g. \"type: foo\" + deriving (Show, Read, Eq) + +knownTestTypes :: [TestType] +knownTestTypes = [ TestTypeExe (Version [1,0] []) + -- 'detailed-0.9' test type is disabled in Cabal-1.10.x + -- needs more work on the details of the library interface + {- , TestTypeLib (Version [0,9] []) -} ] + +instance Text TestType where + disp (TestTypeExe ver) = text "exitcode-stdio-" <> disp ver + disp (TestTypeLib ver) = text "detailed-" <> disp ver + disp (TestTypeUnknown name ver) = text name <> char '-' <> disp ver + + parse = do + cs <- Parse.sepBy1 component (Parse.char '-') + _ <- Parse.char '-' + ver <- parse + let name = concat (intersperse "-" cs) + return $! case lowercase name of + "exitcode-stdio" -> TestTypeExe ver + "detailed" -> TestTypeLib ver + _ -> TestTypeUnknown name ver + + where + component = do + cs <- Parse.munch1 Char.isAlphaNum + if all Char.isDigit cs then Parse.pfail else return cs + -- each component must contain an alphabetic character, to avoid + -- ambiguity in identifiers like foo-1 (the 1 is the version number). + +testType :: TestSuite -> TestType +testType test = case testInterface test of + TestSuiteExeV10 ver _ -> TestTypeExe ver + TestSuiteLibV09 ver _ -> TestTypeLib ver + TestSuiteUnsupported testtype -> testtype + +-- --------------------------------------------------------------------------- +-- The BuildInfo type + +-- Consider refactoring into executable and library versions. +data BuildInfo = BuildInfo { + buildable :: Bool, -- ^ component is buildable here + buildTools :: [Dependency], -- ^ tools needed to build this bit + cppOptions :: [String], -- ^ options for pre-processing Haskell code + ccOptions :: [String], -- ^ options for C compiler + ldOptions :: [String], -- ^ options for linker + pkgconfigDepends :: [Dependency], -- ^ pkg-config packages that are used + frameworks :: [String], -- ^support frameworks for Mac OS X + cSources :: [FilePath], + hsSourceDirs :: [FilePath], -- ^ where to look for the haskell module hierarchy + otherModules :: [ModuleName], -- ^ non-exposed or non-main modules + + defaultLanguage :: Maybe Language,-- ^ language used when not explicitly specified + otherLanguages :: [Language], -- ^ other languages used within the package + defaultExtensions :: [Extension], -- ^ language extensions used by all modules + otherExtensions :: [Extension], -- ^ other language extensions used within the package + oldExtensions :: [Extension], -- ^ the old extensions field, treated same as 'defaultExtensions' + + extraLibs :: [String], -- ^ what libraries to link with when compiling a program that uses your package + extraLibDirs :: [String], + includeDirs :: [FilePath], -- ^directories to find .h files + includes :: [FilePath], -- ^ The .h files to be found in includeDirs + installIncludes :: [FilePath], -- ^ .h files to install with the package + options :: [(CompilerFlavor,[String])], + ghcProfOptions :: [String], + ghcSharedOptions :: [String], + customFieldsBI :: [(String,String)], -- ^Custom fields starting + -- with x-, stored in a + -- simple assoc-list. + targetBuildDepends :: [Dependency] -- ^ Dependencies specific to a library or executable target + } + deriving (Show,Read,Eq) + +instance Monoid BuildInfo where + mempty = BuildInfo { + buildable = True, + buildTools = [], + cppOptions = [], + ccOptions = [], + ldOptions = [], + pkgconfigDepends = [], + frameworks = [], + cSources = [], + hsSourceDirs = [], + otherModules = [], + defaultLanguage = Nothing, + otherLanguages = [], + defaultExtensions = [], + otherExtensions = [], + oldExtensions = [], + extraLibs = [], + extraLibDirs = [], + includeDirs = [], + includes = [], + installIncludes = [], + options = [], + ghcProfOptions = [], + ghcSharedOptions = [], + customFieldsBI = [], + targetBuildDepends = [] + } + mappend a b = BuildInfo { + buildable = buildable a && buildable b, + buildTools = combine buildTools, + cppOptions = combine cppOptions, + ccOptions = combine ccOptions, + ldOptions = combine ldOptions, + pkgconfigDepends = combine pkgconfigDepends, + frameworks = combineNub frameworks, + cSources = combineNub cSources, + hsSourceDirs = combineNub hsSourceDirs, + otherModules = combineNub otherModules, + defaultLanguage = combineMby defaultLanguage, + otherLanguages = combineNub otherLanguages, + defaultExtensions = combineNub defaultExtensions, + otherExtensions = combineNub otherExtensions, + oldExtensions = combineNub oldExtensions, + extraLibs = combine extraLibs, + extraLibDirs = combineNub extraLibDirs, + includeDirs = combineNub includeDirs, + includes = combineNub includes, + installIncludes = combineNub installIncludes, + options = combine options, + ghcProfOptions = combine ghcProfOptions, + ghcSharedOptions = combine ghcSharedOptions, + customFieldsBI = combine customFieldsBI, + targetBuildDepends = combineNub targetBuildDepends + } + where + combine field = field a `mappend` field b + combineNub field = nub (combine field) + combineMby field = field b `mplus` field a + +emptyBuildInfo :: BuildInfo +emptyBuildInfo = mempty + +-- | The 'BuildInfo' for the library (if there is one and it's buildable), and +-- all buildable executables and test suites. Useful for gathering dependencies. +allBuildInfo :: PackageDescription -> [BuildInfo] +allBuildInfo pkg_descr = [ bi | Just lib <- [library pkg_descr] + , let bi = libBuildInfo lib + , buildable bi ] + ++ [ bi | exe <- executables pkg_descr + , let bi = buildInfo exe + , buildable bi ] + ++ [ bi | tst <- testSuites pkg_descr + , let bi = testBuildInfo tst + , buildable bi + , testEnabled tst ] + --FIXME: many of the places where this is used, we actually want to look at + -- unbuildable bits too, probably need separate functions + +-- | The 'Language's used by this component +-- +allLanguages :: BuildInfo -> [Language] +allLanguages bi = maybeToList (defaultLanguage bi) + ++ otherLanguages bi + +-- | The 'Extension's that are used somewhere by this component +-- +allExtensions :: BuildInfo -> [Extension] +allExtensions bi = usedExtensions bi + ++ otherExtensions bi + +-- | The 'Extensions' that are used by all modules in this component +-- +usedExtensions :: BuildInfo -> [Extension] +usedExtensions bi = oldExtensions bi + ++ defaultExtensions bi + +type HookedBuildInfo = (Maybe BuildInfo, [(String, BuildInfo)]) + +emptyHookedBuildInfo :: HookedBuildInfo +emptyHookedBuildInfo = (Nothing, []) + +-- |Select options for a particular Haskell compiler. +hcOptions :: CompilerFlavor -> BuildInfo -> [String] +hcOptions hc bi = [ opt | (hc',opts) <- options bi + , hc' == hc + , opt <- opts ] + +-- ------------------------------------------------------------ +-- * Source repos +-- ------------------------------------------------------------ + +-- | Information about the source revision control system for a package. +-- +-- When specifying a repo it is useful to know the meaning or intention of the +-- information as doing so enables automation. There are two obvious common +-- purposes: one is to find the repo for the latest development version, the +-- other is to find the repo for this specific release. The 'ReopKind' +-- specifies which one we mean (or another custom one). +-- +-- A package can specify one or the other kind or both. Most will specify just +-- a head repo but some may want to specify a repo to reconstruct the sources +-- for this package release. +-- +-- The required information is the 'RepoType' which tells us if it's using +-- 'Darcs', 'Git' for example. The 'repoLocation' and other details are +-- interpreted according to the repo type. +-- +data SourceRepo = SourceRepo { + -- | The kind of repo. This field is required. + repoKind :: RepoKind, + + -- | The type of the source repository system for this repo, eg 'Darcs' or + -- 'Git'. This field is required. + repoType :: Maybe RepoType, + + -- | The location of the repository. For most 'RepoType's this is a URL. + -- This field is required. + repoLocation :: Maybe String, + + -- | 'CVS' can put multiple \"modules\" on one server and requires a + -- module name in addition to the location to identify a particular repo. + -- Logically this is part of the location but unfortunately has to be + -- specified separately. This field is required for the 'CVS' 'RepoType' and + -- should not be given otherwise. + repoModule :: Maybe String, + + -- | The name or identifier of the branch, if any. Many source control + -- systems have the notion of multiple branches in a repo that exist in the + -- same location. For example 'Git' and 'CVS' use this while systems like + -- 'Darcs' use different locations for different branches. This field is + -- optional but should be used if necessary to identify the sources, + -- especially for the 'RepoThis' repo kind. + repoBranch :: Maybe String, + + -- | The tag identify a particular state of the repository. This should be + -- given for the 'RepoThis' repo kind and not for 'RepoHead' kind. + -- + repoTag :: Maybe String, + + -- | Some repositories contain multiple projects in different subdirectories + -- This field specifies the subdirectory where this packages sources can be + -- found, eg the subdirectory containing the @.cabal@ file. It is interpreted + -- relative to the root of the repository. This field is optional. If not + -- given the default is \".\" ie no subdirectory. + repoSubdir :: Maybe FilePath +} + deriving (Eq, Read, Show) + +-- | What this repo info is for, what it represents. +-- +data RepoKind = + -- | The repository for the \"head\" or development version of the project. + -- This repo is where we should track the latest development activity or + -- the usual repo people should get to contribute patches. + RepoHead + + -- | The repository containing the sources for this exact package version + -- or release. For this kind of repo a tag should be given to give enough + -- information to re-create the exact sources. + | RepoThis + + | RepoKindUnknown String + deriving (Eq, Ord, Read, Show) + +-- | An enumeration of common source control systems. The fields used in the +-- 'SourceRepo' depend on the type of repo. The tools and methods used to +-- obtain and track the repo depend on the repo type. +-- +data RepoType = Darcs | Git | SVN | CVS + | Mercurial | GnuArch | Bazaar | Monotone + | OtherRepoType String + deriving (Eq, Ord, Read, Show) + +knownRepoTypes :: [RepoType] +knownRepoTypes = [Darcs, Git, SVN, CVS + ,Mercurial, GnuArch, Bazaar, Monotone] + +repoTypeAliases :: RepoType -> [String] +repoTypeAliases Bazaar = ["bzr"] +repoTypeAliases Mercurial = ["hg"] +repoTypeAliases GnuArch = ["arch"] +repoTypeAliases _ = [] + +instance Text RepoKind where + disp RepoHead = Disp.text "head" + disp RepoThis = Disp.text "this" + disp (RepoKindUnknown other) = Disp.text other + + parse = do + name <- ident + return $ case lowercase name of + "head" -> RepoHead + "this" -> RepoThis + _ -> RepoKindUnknown name + +instance Text RepoType where + disp (OtherRepoType other) = Disp.text other + disp other = Disp.text (lowercase (show other)) + parse = fmap classifyRepoType ident + +classifyRepoType :: String -> RepoType +classifyRepoType s = + case lookup (lowercase s) repoTypeMap of + Just repoType' -> repoType' + Nothing -> OtherRepoType s + where + repoTypeMap = [ (name, repoType') + | repoType' <- knownRepoTypes + , name <- display repoType' : repoTypeAliases repoType' ] + +ident :: Parse.ReadP r String +ident = Parse.munch1 (\c -> Char.isAlphaNum c || c == '_' || c == '-') + +lowercase :: String -> String +lowercase = map Char.toLower + +-- ------------------------------------------------------------ +-- * Utils +-- ------------------------------------------------------------ + +updatePackageDescription :: HookedBuildInfo -> PackageDescription -> PackageDescription +updatePackageDescription (mb_lib_bi, exe_bi) p + = p{ executables = updateExecutables exe_bi (executables p) + , library = updateLibrary mb_lib_bi (library p) + } + where + updateLibrary :: Maybe BuildInfo -> Maybe Library -> Maybe Library + updateLibrary (Just bi) (Just lib) = Just (lib{libBuildInfo = bi `mappend` libBuildInfo lib}) + updateLibrary Nothing mb_lib = mb_lib + updateLibrary (Just _) Nothing = Nothing + + updateExecutables :: [(String, BuildInfo)] -- ^[(exeName, new buildinfo)] + -> [Executable] -- ^list of executables to update + -> [Executable] -- ^list with exeNames updated + updateExecutables exe_bi' executables' = foldr updateExecutable executables' exe_bi' + + updateExecutable :: (String, BuildInfo) -- ^(exeName, new buildinfo) + -> [Executable] -- ^list of executables to update + -> [Executable] -- ^libst with exeName updated + updateExecutable _ [] = [] + updateExecutable exe_bi'@(name,bi) (exe:exes) + | exeName exe == name = exe{buildInfo = bi `mappend` buildInfo exe} : exes + | otherwise = exe : updateExecutable exe_bi' exes + +-- --------------------------------------------------------------------------- +-- The GenericPackageDescription type + +data GenericPackageDescription = + GenericPackageDescription { + packageDescription :: PackageDescription, + genPackageFlags :: [Flag], + condLibrary :: Maybe (CondTree ConfVar [Dependency] Library), + condExecutables :: [(String, CondTree ConfVar [Dependency] Executable)], + condTestSuites :: [(String, CondTree ConfVar [Dependency] TestSuite)] + } + deriving (Show, Eq) + +instance Package GenericPackageDescription where + packageId = packageId . packageDescription + +--TODO: make PackageDescription an instance of Text. + +-- | A flag can represent a feature to be included, or a way of linking +-- a target against its dependencies, or in fact whatever you can think of. +data Flag = MkFlag + { flagName :: FlagName + , flagDescription :: String + , flagDefault :: Bool + , flagManual :: Bool + } + deriving (Show, Eq) + +-- | A 'FlagName' is the name of a user-defined configuration flag +newtype FlagName = FlagName String + deriving (Eq, Ord, Show, Read) + +-- | A 'FlagAssignment' is a total or partial mapping of 'FlagName's to +-- 'Bool' flag values. It represents the flags chosen by the user or +-- discovered during configuration. For example @--flags=foo --flags=-bar@ +-- becomes @[("foo", True), ("bar", False)]@ +-- +type FlagAssignment = [(FlagName, Bool)] + +-- | A @ConfVar@ represents the variable type used. +data ConfVar = OS OS + | Arch Arch + | Flag FlagName + | Impl CompilerFlavor VersionRange + deriving (Eq, Show) + +--instance Text ConfVar where +-- disp (OS os) = "os(" ++ display os ++ ")" +-- disp (Arch arch) = "arch(" ++ display arch ++ ")" +-- disp (Flag (ConfFlag f)) = "flag(" ++ f ++ ")" +-- disp (Impl c v) = "impl(" ++ display c +-- ++ " " ++ display v ++ ")" + +-- | A boolean expression parameterized over the variable type used. +data Condition c = Var c + | Lit Bool + | CNot (Condition c) + | COr (Condition c) (Condition c) + | CAnd (Condition c) (Condition c) + deriving (Show, Eq) + +--instance Text c => Text (Condition c) where +-- disp (Var x) = text (show x) +-- disp (Lit b) = text (show b) +-- disp (CNot c) = char '!' <> parens (ppCond c) +-- disp (COr c1 c2) = parens $ sep [ppCond c1, text "||" <+> ppCond c2] +-- disp (CAnd c1 c2) = parens $ sep [ppCond c1, text "&&" <+> ppCond c2] + +data CondTree v c a = CondNode + { condTreeData :: a + , condTreeConstraints :: c + , condTreeComponents :: [( Condition v + , CondTree v c a + , Maybe (CondTree v c a))] + } + deriving (Show, Eq) + +--instance (Text v, Text c) => Text (CondTree v c a) where +-- disp (CondNode _dat cs ifs) = +-- (text "build-depends: " <+> +-- disp cs) +-- $+$ +-- (vcat $ map ppIf ifs) +-- where +-- ppIf (c,thenTree,mElseTree) = +-- ((text "if" <+> ppCond c <> colon) $$ +-- nest 2 (ppCondTree thenTree disp)) +-- $+$ (maybe empty (\t -> text "else: " $$ nest 2 (ppCondTree t disp)) +-- mElseTree) diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/Package.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/Package.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/Package.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/Package.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,193 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Package +-- Copyright : Isaac Jones 2003-2004 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Defines a package identifier along with a parser and pretty printer for it. +-- 'PackageIdentifier's consist of a name and an exact version. It also defines +-- a 'Dependency' data type. A dependency is a package name and a version +-- range, like @\"foo >= 1.2 && < 2\"@. + +{- All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.Package ( + -- * Package ids + PackageName(..), + PackageIdentifier(..), + PackageId, + + -- * Installed package identifiers + InstalledPackageId(..), + + -- * Package source dependencies + Dependency(..), + thisPackageVersion, + notThisPackageVersion, + simplifyDependency, + + -- * Package classes + Package(..), packageName, packageVersion, + PackageFixedDeps(..), + ) where + +import Distribution.Version + ( Version(..), VersionRange, anyVersion, thisVersion + , notThisVersion, simplifyVersionRange ) + +import Distribution.Text (Text(..)) +import qualified Distribution.Compat.ReadP as Parse +import Distribution.Compat.ReadP ((<++)) +import qualified Text.PrettyPrint as Disp +import Text.PrettyPrint ((<>), (<+>), text) +import qualified Data.Char as Char ( isDigit, isAlphaNum ) +import Data.List ( intersperse ) + +newtype PackageName = PackageName String + deriving (Read, Show, Eq, Ord) + +instance Text PackageName where + disp (PackageName n) = Disp.text n + parse = do + ns <- Parse.sepBy1 component (Parse.char '-') + return (PackageName (concat (intersperse "-" ns))) + where + component = do + cs <- Parse.munch1 Char.isAlphaNum + if all Char.isDigit cs then Parse.pfail else return cs + -- each component must contain an alphabetic character, to avoid + -- ambiguity in identifiers like foo-1 (the 1 is the version number). + +-- | Type alias so we can use the shorter name PackageId. +type PackageId = PackageIdentifier + +-- | The name and version of a package. +data PackageIdentifier + = PackageIdentifier { + pkgName :: PackageName, -- ^The name of this package, eg. foo + pkgVersion :: Version -- ^the version of this package, eg 1.2 + } + deriving (Read, Show, Eq, Ord) + +instance Text PackageIdentifier where + disp (PackageIdentifier n v) = case v of + Version [] _ -> disp n -- if no version, don't show version. + _ -> disp n <> Disp.char '-' <> disp v + + parse = do + n <- parse + v <- (Parse.char '-' >> parse) <++ return (Version [] []) + return (PackageIdentifier n v) + +-- ------------------------------------------------------------ +-- * Installed Package Ids +-- ------------------------------------------------------------ + +-- | An InstalledPackageId uniquely identifies an instance of an installed package. +-- There can be at most one package with a given 'InstalledPackageId' +-- in a package database, or overlay of databases. +-- +newtype InstalledPackageId = InstalledPackageId String + deriving (Read,Show,Eq,Ord) + +instance Text InstalledPackageId where + disp (InstalledPackageId str) = text str + + parse = InstalledPackageId `fmap` Parse.munch1 abi_char + where abi_char c = Char.isAlphaNum c || c `elem` ":-_." + +-- ------------------------------------------------------------ +-- * Package source dependencies +-- ------------------------------------------------------------ + +-- | Describes a dependency on a source package (API) +-- +data Dependency = Dependency PackageName VersionRange + deriving (Read, Show, Eq) + +instance Text Dependency where + disp (Dependency name ver) = + disp name <+> disp ver + + parse = do name <- parse + Parse.skipSpaces + ver <- parse <++ return anyVersion + Parse.skipSpaces + return (Dependency name ver) + +thisPackageVersion :: PackageIdentifier -> Dependency +thisPackageVersion (PackageIdentifier n v) = + Dependency n (thisVersion v) + +notThisPackageVersion :: PackageIdentifier -> Dependency +notThisPackageVersion (PackageIdentifier n v) = + Dependency n (notThisVersion v) + +-- | Simplify the 'VersionRange' expression in a 'Dependency'. +-- See 'simplifyVersionRange'. +-- +simplifyDependency :: Dependency -> Dependency +simplifyDependency (Dependency name range) = + Dependency name (simplifyVersionRange range) + +-- | Class of things that have a 'PackageIdentifier' +-- +-- Types in this class are all notions of a package. This allows us to have +-- different types for the different phases that packages go though, from +-- simple name\/id, package description, configured or installed packages. +-- +-- Not all kinds of packages can be uniquely identified by a +-- 'PackageIdentifier'. In particular, installed packages cannot, there may be +-- many installed instances of the same source package. +-- +class Package pkg where + packageId :: pkg -> PackageIdentifier + +packageName :: Package pkg => pkg -> PackageName +packageName = pkgName . packageId + +packageVersion :: Package pkg => pkg -> Version +packageVersion = pkgVersion . packageId + +instance Package PackageIdentifier where + packageId = id + +-- | Subclass of packages that have specific versioned dependencies. +-- +-- So for example a not-yet-configured package has dependencies on version +-- ranges, not specific versions. A configured or an already installed package +-- depends on exact versions. Some operations or data structures (like +-- dependency graphs) only make sense on this subclass of package types. +-- +class Package pkg => PackageFixedDeps pkg where + depends :: pkg -> [PackageIdentifier] diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/ParseUtils.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/ParseUtils.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/ParseUtils.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/ParseUtils.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,715 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.ParseUtils +-- Copyright : (c) The University of Glasgow 2004 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Utilities for parsing 'PackageDescription' and 'InstalledPackageInfo'. +-- +-- The @.cabal@ file format is not trivial, especially with the introduction +-- of configurations and the section syntax that goes with that. This module +-- has a bunch of parsing functions that is used by the @.cabal@ parser and a +-- couple others. It has the parsing framework code and also little parsers for +-- many of the formats we get in various @.cabal@ file fields, like module +-- names, comma separated lists etc. + +{- All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of the University nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +-- This module is meant to be local-only to Distribution... + +-- #hide +module Distribution.ParseUtils ( + LineNo, PError(..), PWarning(..), locatedErrorMsg, syntaxError, warning, + runP, runE, ParseResult(..), catchParseError, parseFail, showPWarning, + Field(..), fName, lineNo, + FieldDescr(..), ppField, ppFields, readFields, readFieldsFlat, + showFields, showSingleNamedField, parseFields, parseFieldsFlat, + parseFilePathQ, parseTokenQ, parseTokenQ', + parseModuleNameQ, parseBuildTool, parsePkgconfigDependency, + parseOptVersion, parsePackageNameQ, parseVersionRangeQ, + parseTestedWithQ, parseLicenseQ, parseLanguageQ, parseExtensionQ, + parseSepList, parseCommaList, parseOptCommaList, + showFilePath, showToken, showTestedWith, showFreeText, parseFreeText, + field, simpleField, listField, spaceListField, commaListField, + optsField, liftField, boolField, parseQuoted, + + UnrecFieldParser, warnUnrec, ignoreUnrec, + ) where + +import Distribution.Compiler (CompilerFlavor, parseCompilerFlavorCompat) +import Distribution.License +import Distribution.Version + ( Version(..), VersionRange, anyVersion ) +import Distribution.Package ( PackageName(..), Dependency(..) ) +import Distribution.ModuleName (ModuleName) +import Distribution.Compat.ReadP as ReadP hiding (get) +import Distribution.ReadE +import Distribution.Text + ( Text(..) ) +import Distribution.Simple.Utils + ( comparing, intercalate, lowercase, normaliseLineEndings ) +import Language.Haskell.Extension + ( Language, Extension ) + +import Text.PrettyPrint.HughesPJ hiding (braces) +import Data.Char (isSpace, toLower, isAlphaNum, isDigit) +import Data.Maybe (fromMaybe) +import Data.Tree as Tree (Tree(..), flatten) +import qualified Data.Map as Map +import Control.Monad (foldM) +import System.FilePath (normalise) +import Data.List (sortBy) + +-- ----------------------------------------------------------------------------- + +type LineNo = Int + +data PError = AmbigousParse String LineNo + | NoParse String LineNo + | TabsError LineNo + | FromString String (Maybe LineNo) + deriving Show + +data PWarning = PWarning String + | UTFWarning LineNo String + deriving Show + +showPWarning :: FilePath -> PWarning -> String +showPWarning fpath (PWarning msg) = + normalise fpath ++ ": " ++ msg +showPWarning fpath (UTFWarning line fname) = + normalise fpath ++ ":" ++ show line + ++ ": Invalid UTF-8 text in the '" ++ fname ++ "' field." + +data ParseResult a = ParseFailed PError | ParseOk [PWarning] a + deriving Show + +instance Monad ParseResult where + return x = ParseOk [] x + ParseFailed err >>= _ = ParseFailed err + ParseOk ws x >>= f = case f x of + ParseFailed err -> ParseFailed err + ParseOk ws' x' -> ParseOk (ws'++ws) x' + fail s = ParseFailed (FromString s Nothing) + +catchParseError :: ParseResult a -> (PError -> ParseResult a) + -> ParseResult a +p@(ParseOk _ _) `catchParseError` _ = p +ParseFailed e `catchParseError` k = k e + +parseFail :: PError -> ParseResult a +parseFail = ParseFailed + +runP :: LineNo -> String -> ReadP a a -> String -> ParseResult a +runP line fieldname p s = + case [ x | (x,"") <- results ] of + [a] -> ParseOk (utf8Warnings line fieldname s) a + --TODO: what is this double parse thing all about? + -- Can't we just do the all isSpace test the first time? + [] -> case [ x | (x,ys) <- results, all isSpace ys ] of + [a] -> ParseOk (utf8Warnings line fieldname s) a + [] -> ParseFailed (NoParse fieldname line) + _ -> ParseFailed (AmbigousParse fieldname line) + _ -> ParseFailed (AmbigousParse fieldname line) + where results = readP_to_S p s + +runE :: LineNo -> String -> ReadE a -> String -> ParseResult a +runE line fieldname p s = + case runReadE p s of + Right a -> ParseOk (utf8Warnings line fieldname s) a + Left e -> syntaxError line $ + "Parse of field '" ++ fieldname ++ "' failed (" ++ e ++ "): " ++ s + +utf8Warnings :: LineNo -> String -> String -> [PWarning] +utf8Warnings line fieldname s = + take 1 [ UTFWarning n fieldname + | (n,l) <- zip [line..] (lines s) + , '\xfffd' `elem` l ] + +locatedErrorMsg :: PError -> (Maybe LineNo, String) +locatedErrorMsg (AmbigousParse f n) = (Just n, "Ambiguous parse in field '"++f++"'.") +locatedErrorMsg (NoParse f n) = (Just n, "Parse of field '"++f++"' failed.") +locatedErrorMsg (TabsError n) = (Just n, "Tab used as indentation.") +locatedErrorMsg (FromString s n) = (n, s) + +syntaxError :: LineNo -> String -> ParseResult a +syntaxError n s = ParseFailed $ FromString s (Just n) + +tabsError :: LineNo -> ParseResult a +tabsError ln = ParseFailed $ TabsError ln + +warning :: String -> ParseResult () +warning s = ParseOk [PWarning s] () + +-- | Field descriptor. The parameter @a@ parameterizes over where the field's +-- value is stored in. +data FieldDescr a + = FieldDescr + { fieldName :: String + , fieldGet :: a -> Doc + , fieldSet :: LineNo -> String -> a -> ParseResult a + -- ^ @fieldSet n str x@ Parses the field value from the given input + -- string @str@ and stores the result in @x@ if the parse was + -- successful. Otherwise, reports an error on line number @n@. + } + +field :: String -> (a -> Doc) -> (ReadP a a) -> FieldDescr a +field name showF readF = + FieldDescr name showF (\line val _st -> runP line name readF val) + +-- Lift a field descriptor storing into an 'a' to a field descriptor storing +-- into a 'b'. +liftField :: (b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b +liftField get set (FieldDescr name showF parseF) + = FieldDescr name (\b -> showF (get b)) + (\line str b -> do + a <- parseF line str (get b) + return (set a b)) + +-- Parser combinator for simple fields. Takes a field name, a pretty printer, +-- a parser function, an accessor, and a setter, returns a FieldDescr over the +-- compoid structure. +simpleField :: String -> (a -> Doc) -> (ReadP a a) + -> (b -> a) -> (a -> b -> b) -> FieldDescr b +simpleField name showF readF get set + = liftField get set $ field name showF readF + +commaListField :: String -> (a -> Doc) -> (ReadP [a] a) + -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b +commaListField name showF readF get set = + liftField get set' $ + field name (fsep . punctuate comma . map showF) (parseCommaList readF) + where + set' xs b = set (get b ++ xs) b + +spaceListField :: String -> (a -> Doc) -> (ReadP [a] a) + -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b +spaceListField name showF readF get set = + liftField get set' $ + field name (fsep . map showF) (parseSpaceList readF) + where + set' xs b = set (get b ++ xs) b + +listField :: String -> (a -> Doc) -> (ReadP [a] a) + -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b +listField name showF readF get set = + liftField get set' $ + field name (fsep . map showF) (parseOptCommaList readF) + where + set' xs b = set (get b ++ xs) b + +optsField :: String -> CompilerFlavor -> (b -> [(CompilerFlavor,[String])]) -> ([(CompilerFlavor,[String])] -> b -> b) -> FieldDescr b +optsField name flavor get set = + liftField (fromMaybe [] . lookup flavor . get) + (\opts b -> set (reorder (update flavor opts (get b))) b) $ + field name (hsep . map text) + (sepBy parseTokenQ' (munch1 isSpace)) + where + update _ opts l | all null opts = l --empty opts as if no opts + update f opts [] = [(f,opts)] + update f opts ((f',opts'):rest) + | f == f' = (f, opts' ++ opts) : rest + | otherwise = (f',opts') : update f opts rest + reorder = sortBy (comparing fst) + +-- TODO: this is a bit smelly hack. It's because we want to parse bool fields +-- liberally but not accept new parses. We cannot do that with ReadP +-- because it does not support warnings. We need a new parser framwork! +boolField :: String -> (b -> Bool) -> (Bool -> b -> b) -> FieldDescr b +boolField name get set = liftField get set (FieldDescr name showF readF) + where + showF = text . show + readF line str _ + | str == "True" = ParseOk [] True + | str == "False" = ParseOk [] False + | lstr == "true" = ParseOk [caseWarning] True + | lstr == "false" = ParseOk [caseWarning] False + | otherwise = ParseFailed (NoParse name line) + where + lstr = lowercase str + caseWarning = PWarning $ + "The '" ++ name ++ "' field is case sensitive, use 'True' or 'False'." + +ppFields :: [FieldDescr a] -> a -> Doc +ppFields fields x = vcat [ ppField name (getter x) + | FieldDescr name getter _ <- fields] + +ppField :: String -> Doc -> Doc +ppField name fielddoc = text name <> colon <+> fielddoc + +showFields :: [FieldDescr a] -> a -> String +showFields fields = render . ($+$ text "") . ppFields fields + +showSingleNamedField :: [FieldDescr a] -> String -> Maybe (a -> String) +showSingleNamedField fields f = + case [ get | (FieldDescr f' get _) <- fields, f' == f ] of + [] -> Nothing + (get:_) -> Just (render . ppField f . get) + +parseFields :: [FieldDescr a] -> a -> String -> ParseResult a +parseFields fields initial = \str -> + readFields str >>= accumFields fields initial + +parseFieldsFlat :: [FieldDescr a] -> a -> String -> ParseResult a +parseFieldsFlat fields initial = \str -> + readFieldsFlat str >>= accumFields fields initial + +accumFields :: [FieldDescr a] -> a -> [Field] -> ParseResult a +accumFields fields = foldM setField + where + fieldMap = Map.fromList + [ (name, f) | f@(FieldDescr name _ _) <- fields ] + setField accum (F line name value) = case Map.lookup name fieldMap of + Just (FieldDescr _ _ set) -> set line value accum + Nothing -> do + warning ("Unrecognized field " ++ name ++ " on line " ++ show line) + return accum + setField accum f = do + warning ("Unrecognized stanza on line " ++ show (lineNo f)) + return accum + +-- | The type of a function which, given a name-value pair of an +-- unrecognized field, and the current structure being built, +-- decides whether to incorporate the unrecognized field +-- (by returning Just x, where x is a possibly modified version +-- of the structure being built), or not (by returning Nothing). +type UnrecFieldParser a = (String,String) -> a -> Maybe a + +-- | A default unrecognized field parser which simply returns Nothing, +-- i.e. ignores all unrecognized fields, so warnings will be generated. +warnUnrec :: UnrecFieldParser a +warnUnrec _ _ = Nothing + +-- | A default unrecognized field parser which silently (i.e. no +-- warnings will be generated) ignores unrecognized fields, by +-- returning the structure being built unmodified. +ignoreUnrec :: UnrecFieldParser a +ignoreUnrec _ x = Just x + +------------------------------------------------------------------------------ + +-- The data type for our three syntactic categories +data Field + = F LineNo String String + -- ^ A regular @: @ field + | Section LineNo String String [Field] + -- ^ A section with a name and possible parameter. The syntactic + -- structure is: + -- + -- @ + -- { + -- * + -- } + -- @ + | IfBlock LineNo String [Field] [Field] + -- ^ A conditional block with an optional else branch: + -- + -- @ + -- if { + -- * + -- } else { + -- * + -- } + -- @ + deriving (Show + ,Eq) -- for testing + +lineNo :: Field -> LineNo +lineNo (F n _ _) = n +lineNo (Section n _ _ _) = n +lineNo (IfBlock n _ _ _) = n + +fName :: Field -> String +fName (F _ n _) = n +fName (Section _ n _ _) = n +fName _ = error "fname: not a field or section" + +readFields :: String -> ParseResult [Field] +readFields input = ifelse + =<< mapM (mkField 0) + =<< mkTree tokens + + where ls = (lines . normaliseLineEndings) input + tokens = (concatMap tokeniseLine . trimLines) ls + +readFieldsFlat :: String -> ParseResult [Field] +readFieldsFlat input = mapM (mkField 0) + =<< mkTree tokens + where ls = (lines . normaliseLineEndings) input + tokens = (concatMap tokeniseLineFlat . trimLines) ls + +-- attach line number and determine indentation +trimLines :: [String] -> [(LineNo, Indent, HasTabs, String)] +trimLines ls = [ (lineno, indent, hastabs, (trimTrailing l')) + | (lineno, l) <- zip [1..] ls + , let (sps, l') = span isSpace l + indent = length sps + hastabs = '\t' `elem` sps + , validLine l' ] + where validLine ('-':'-':_) = False -- Comment + validLine [] = False -- blank line + validLine _ = True + +-- | We parse generically based on indent level and braces '{' '}'. To do that +-- we split into lines and then '{' '}' tokens and other spans within a line. +data Token = + -- | The 'Line' token is for bits that /start/ a line, eg: + -- + -- > "\n blah blah { blah" + -- + -- tokenises to: + -- + -- > [Line n 2 False "blah blah", OpenBracket, Span n "blah"] + -- + -- so lines are the only ones that can have nested layout, since they + -- have a known indentation level. + -- + -- eg: we can't have this: + -- + -- > if ... { + -- > } else + -- > other + -- + -- because other cannot nest under else, since else doesn't start a line + -- so cannot have nested layout. It'd have to be: + -- + -- > if ... { + -- > } + -- > else + -- > other + -- + -- but that's not so common, people would normally use layout or + -- brackets not both in a single @if else@ construct. + -- + -- > if ... { foo : bar } + -- > else + -- > other + -- + -- this is ok + Line LineNo Indent HasTabs String + | Span LineNo String -- ^ span in a line, following brackets + | OpenBracket LineNo | CloseBracket LineNo + +type Indent = Int +type HasTabs = Bool + +-- | Tokenise a single line, splitting on '{' '}' and the spans inbetween. +-- Also trims leading & trailing space on those spans within the line. +tokeniseLine :: (LineNo, Indent, HasTabs, String) -> [Token] +tokeniseLine (n0, i, t, l) = case split n0 l of + (Span _ l':ss) -> Line n0 i t l' :ss + cs -> cs + where split _ "" = [] + split n s = case span (\c -> c /='}' && c /= '{') s of + ("", '{' : s') -> OpenBracket n : split n s' + (w , '{' : s') -> mkspan n w (OpenBracket n : split n s') + ("", '}' : s') -> CloseBracket n : split n s' + (w , '}' : s') -> mkspan n w (CloseBracket n : split n s') + (w , _) -> mkspan n w [] + + mkspan n s ss | null s' = ss + | otherwise = Span n s' : ss + where s' = trimTrailing (trimLeading s) + +tokeniseLineFlat :: (LineNo, Indent, HasTabs, String) -> [Token] +tokeniseLineFlat (n0, i, t, l) + | null l' = [] + | otherwise = [Line n0 i t l'] + where + l' = trimTrailing (trimLeading l) + +trimLeading, trimTrailing :: String -> String +trimLeading = dropWhile isSpace +trimTrailing = reverse . dropWhile isSpace . reverse + + +type SyntaxTree = Tree (LineNo, HasTabs, String) + +-- | Parse the stream of tokens into a tree of them, based on indent \/ layout +mkTree :: [Token] -> ParseResult [SyntaxTree] +mkTree toks = + layout 0 [] toks >>= \(trees, trailing) -> case trailing of + [] -> return trees + OpenBracket n:_ -> syntaxError n "mismatched backets, unexpected {" + CloseBracket n:_ -> syntaxError n "mismatched backets, unexpected }" + -- the following two should never happen: + Span n l :_ -> syntaxError n $ "unexpected span: " ++ show l + Line n _ _ l :_ -> syntaxError n $ "unexpected line: " ++ show l + + +-- | Parse the stream of tokens into a tree of them, based on indent +-- This parse state expect to be in a layout context, though possibly +-- nested within a braces context so we may still encounter closing braces. +layout :: Indent -- ^ indent level of the parent\/previous line + -> [SyntaxTree] -- ^ accumulating param, trees in this level + -> [Token] -- ^ remaining tokens + -> ParseResult ([SyntaxTree], [Token]) + -- ^ collected trees on this level and trailing tokens +layout _ a [] = return (reverse a, []) +layout i a (s@(Line _ i' _ _):ss) | i' < i = return (reverse a, s:ss) +layout i a (Line n _ t l:OpenBracket n':ss) = do + (sub, ss') <- braces n' [] ss + layout i (Node (n,t,l) sub:a) ss' + +layout i a (Span n l:OpenBracket n':ss) = do + (sub, ss') <- braces n' [] ss + layout i (Node (n,False,l) sub:a) ss' + +-- look ahead to see if following lines are more indented, giving a sub-tree +layout i a (Line n i' t l:ss) = do + lookahead <- layout (i'+1) [] ss + case lookahead of + ([], _) -> layout i (Node (n,t,l) [] :a) ss + (ts, ss') -> layout i (Node (n,t,l) ts :a) ss' + +layout _ _ ( OpenBracket n :_) = syntaxError n $ "unexpected '{'" +layout _ a (s@(CloseBracket _):ss) = return (reverse a, s:ss) +layout _ _ ( Span n l : _) = syntaxError n $ "unexpected span: " + ++ show l + +-- | Parse the stream of tokens into a tree of them, based on explicit braces +-- This parse state expects to find a closing bracket. +braces :: LineNo -- ^ line of the '{', used for error messages + -> [SyntaxTree] -- ^ accumulating param, trees in this level + -> [Token] -- ^ remaining tokens + -> ParseResult ([SyntaxTree],[Token]) + -- ^ collected trees on this level and trailing tokens +braces m a (Line n _ t l:OpenBracket n':ss) = do + (sub, ss') <- braces n' [] ss + braces m (Node (n,t,l) sub:a) ss' + +braces m a (Span n l:OpenBracket n':ss) = do + (sub, ss') <- braces n' [] ss + braces m (Node (n,False,l) sub:a) ss' + +braces m a (Line n i t l:ss) = do + lookahead <- layout (i+1) [] ss + case lookahead of + ([], _) -> braces m (Node (n,t,l) [] :a) ss + (ts, ss') -> braces m (Node (n,t,l) ts :a) ss' + +braces m a (Span n l:ss) = braces m (Node (n,False,l) []:a) ss +braces _ a (CloseBracket _:ss) = return (reverse a, ss) +braces n _ [] = syntaxError n $ "opening brace '{'" + ++ "has no matching closing brace '}'" +braces _ _ (OpenBracket n:_) = syntaxError n "unexpected '{'" + +-- | Convert the parse tree into the Field AST +-- Also check for dodgy uses of tabs in indentation. +mkField :: Int -> SyntaxTree -> ParseResult Field +mkField d (Node (n,t,_) _) | d >= 1 && t = tabsError n +mkField d (Node (n,_,l) ts) = case span (\c -> isAlphaNum c || c == '-') l of + ([], _) -> syntaxError n $ "unrecognised field or section: " ++ show l + (name, rest) -> case trimLeading rest of + (':':rest') -> do let followingLines = concatMap Tree.flatten ts + tabs = not (null [()| (_,True,_) <- followingLines ]) + if tabs && d >= 1 + then tabsError n + else return $ F n (map toLower name) + (fieldValue rest' followingLines) + rest' -> do ts' <- mapM (mkField (d+1)) ts + return (Section n (map toLower name) rest' ts') + where fieldValue firstLine followingLines = + let firstLine' = trimLeading firstLine + followingLines' = map (\(_,_,s) -> stripDot s) followingLines + allLines | null firstLine' = followingLines' + | otherwise = firstLine' : followingLines' + in intercalate "\n" allLines + stripDot "." = "" + stripDot s = s + +-- | Convert if/then/else 'Section's to 'IfBlock's +ifelse :: [Field] -> ParseResult [Field] +ifelse [] = return [] +ifelse (Section n "if" cond thenpart + :Section _ "else" as elsepart:fs) + | null cond = syntaxError n "'if' with missing condition" + | null thenpart = syntaxError n "'then' branch of 'if' is empty" + | not (null as) = syntaxError n "'else' takes no arguments" + | null elsepart = syntaxError n "'else' branch of 'if' is empty" + | otherwise = do tp <- ifelse thenpart + ep <- ifelse elsepart + fs' <- ifelse fs + return (IfBlock n cond tp ep:fs') +ifelse (Section n "if" cond thenpart:fs) + | null cond = syntaxError n "'if' with missing condition" + | null thenpart = syntaxError n "'then' branch of 'if' is empty" + | otherwise = do tp <- ifelse thenpart + fs' <- ifelse fs + return (IfBlock n cond tp []:fs') +ifelse (Section n "else" _ _:_) = syntaxError n "stray 'else' with no preceding 'if'" +ifelse (Section n s a fs':fs) = do fs'' <- ifelse fs' + fs''' <- ifelse fs + return (Section n s a fs'' : fs''') +ifelse (f:fs) = do fs' <- ifelse fs + return (f : fs') + +------------------------------------------------------------------------------ + +-- |parse a module name +parseModuleNameQ :: ReadP r ModuleName +parseModuleNameQ = parseQuoted parse <++ parse + +parseFilePathQ :: ReadP r FilePath +parseFilePathQ = parseTokenQ + -- removed until normalise is no longer broken, was: + -- liftM normalise parseTokenQ + +parseBuildTool :: ReadP r Dependency +parseBuildTool = do name <- parseBuildToolNameQ + skipSpaces + ver <- parseVersionRangeQ <++ return anyVersion + skipSpaces + return $ Dependency name ver + +parseBuildToolNameQ :: ReadP r PackageName +parseBuildToolNameQ = parseQuoted parseBuildToolName <++ parseBuildToolName + +-- like parsePackageName but accepts symbols in components +parseBuildToolName :: ReadP r PackageName +parseBuildToolName = do ns <- sepBy1 component (ReadP.char '-') + return (PackageName (intercalate "-" ns)) + where component = do + cs <- munch1 (\c -> isAlphaNum c || c == '+' || c == '_') + if all isDigit cs then pfail else return cs + +-- pkg-config allows versions and other letters in package names, +-- eg "gtk+-2.0" is a valid pkg-config package _name_. +-- It then has a package version number like 2.10.13 +parsePkgconfigDependency :: ReadP r Dependency +parsePkgconfigDependency = do name <- munch1 (\c -> isAlphaNum c || c `elem` "+-._") + skipSpaces + ver <- parseVersionRangeQ <++ return anyVersion + skipSpaces + return $ Dependency (PackageName name) ver + +parsePackageNameQ :: ReadP r PackageName +parsePackageNameQ = parseQuoted parse <++ parse + +parseVersionRangeQ :: ReadP r VersionRange +parseVersionRangeQ = parseQuoted parse <++ parse + +parseOptVersion :: ReadP r Version +parseOptVersion = parseQuoted ver <++ ver + where ver :: ReadP r Version + ver = parse <++ return noVersion + noVersion = Version{ versionBranch=[], versionTags=[] } + +parseTestedWithQ :: ReadP r (CompilerFlavor,VersionRange) +parseTestedWithQ = parseQuoted tw <++ tw + where + tw :: ReadP r (CompilerFlavor,VersionRange) + tw = do compiler <- parseCompilerFlavorCompat + skipSpaces + version <- parse <++ return anyVersion + skipSpaces + return (compiler,version) + +parseLicenseQ :: ReadP r License +parseLicenseQ = parseQuoted parse <++ parse + +-- urgh, we can't define optQuotes :: ReadP r a -> ReadP r a +-- because the "compat" version of ReadP isn't quite powerful enough. In +-- particular, the type of <++ is ReadP r r -> ReadP r a -> ReadP r a +-- Hence the trick above to make 'lic' polymorphic. + +parseLanguageQ :: ReadP r Language +parseLanguageQ = parseQuoted parse <++ parse + +parseExtensionQ :: ReadP r Extension +parseExtensionQ = parseQuoted parse <++ parse + +parseHaskellString :: ReadP r String +parseHaskellString = readS_to_P reads + +parseTokenQ :: ReadP r String +parseTokenQ = parseHaskellString <++ munch1 (\x -> not (isSpace x) && x /= ',') + +parseTokenQ' :: ReadP r String +parseTokenQ' = parseHaskellString <++ munch1 (\x -> not (isSpace x)) + +parseSepList :: ReadP r b + -> ReadP r a -- ^The parser for the stuff between commas + -> ReadP r [a] +parseSepList sepr p = sepBy p separator + where separator = skipSpaces >> sepr >> skipSpaces + +parseSpaceList :: ReadP r a -- ^The parser for the stuff between commas + -> ReadP r [a] +parseSpaceList p = sepBy p skipSpaces + +parseCommaList :: ReadP r a -- ^The parser for the stuff between commas + -> ReadP r [a] +parseCommaList = parseSepList (ReadP.char ',') + +parseOptCommaList :: ReadP r a -- ^The parser for the stuff between commas + -> ReadP r [a] +parseOptCommaList = parseSepList (optional (ReadP.char ',')) + +parseQuoted :: ReadP r a -> ReadP r a +parseQuoted p = between (ReadP.char '"') (ReadP.char '"') p + +parseFreeText :: ReadP.ReadP s String +parseFreeText = ReadP.munch (const True) + +-- -------------------------------------------- +-- ** Pretty printing + +showFilePath :: FilePath -> Doc +showFilePath = showToken + +showToken :: String -> Doc +showToken str + | not (any dodgy str) && + not (null str) = text str + | otherwise = text (show str) + where dodgy c = isSpace c || c == ',' + +showTestedWith :: (CompilerFlavor,VersionRange) -> Doc +showTestedWith (compiler, version) = text (show compiler) <+> disp version + +-- | Pretty-print free-format text, ensuring that it is vertically aligned, +-- and with blank lines replaced by dots for correct re-parsing. +showFreeText :: String -> Doc +showFreeText "" = empty +showFreeText ('\n' :r) = text " " $+$ text "." $+$ showFreeText r +showFreeText s = vcat [text (if null l then "." else l) | l <- lines_ s] + +-- | 'lines_' breaks a string up into a list of strings at newline +-- characters. The resulting strings do not contain newlines. +lines_ :: String -> [String] +lines_ [] = [""] +lines_ s = let (l, s') = break (== '\n') s + in l : case s' of + [] -> [] + (_:s'') -> lines_ s'' diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/ReadE.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/ReadE.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/ReadE.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/ReadE.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,81 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.ReadE +-- Copyright : Jose Iborra 2008 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Simple parsing with failure + +{- Copyright (c) 2007, Jose Iborra +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.ReadE ( + -- * ReadE + ReadE(..), succeedReadE, failReadE, + -- * Projections + parseReadE, readEOrFail, + readP_to_E + ) where + +import Distribution.Compat.ReadP +import Data.Char ( isSpace ) + +-- | Parser with simple error reporting +newtype ReadE a = ReadE {runReadE :: String -> Either ErrorMsg a} +type ErrorMsg = String + +instance Functor ReadE where + fmap f (ReadE p) = ReadE $ \txt -> case p txt of + Right a -> Right (f a) + Left err -> Left err + +succeedReadE :: (String -> a) -> ReadE a +succeedReadE f = ReadE (Right . f) + +failReadE :: ErrorMsg -> ReadE a +failReadE = ReadE . const Left + +parseReadE :: ReadE a -> ReadP r a +parseReadE (ReadE p) = do + txt <- look + either fail return (p txt) + +readEOrFail :: ReadE a -> (String -> a) +readEOrFail r = either error id . runReadE r + +readP_to_E :: (String -> ErrorMsg) -> ReadP a a -> ReadE a +readP_to_E err r = + ReadE $ \txt -> case [ p | (p, s) <- readP_to_S r txt + , all isSpace s ] + of [] -> Left (err txt) + (p:_) -> Right p diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/Build/Macros.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/Build/Macros.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/Build/Macros.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/Build/Macros.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,57 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Build.Macros +-- Copyright : Simon Marlow 2008 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Generate cabal_macros.h - CPP macros for package version testing +-- +-- When using CPP you get +-- +-- > VERSION_ +-- > MIN_VERSION_(A,B,C) +-- +-- for each /package/ in @build-depends@, which is true if the version of +-- /package/ in use is @>= A.B.C@, using the normal ordering on version +-- numbers. +-- +module Distribution.Simple.Build.Macros ( + generate + ) where + +import Distribution.Package + ( PackageIdentifier(PackageIdentifier) ) +import Distribution.Version + ( Version(versionBranch) ) +import Distribution.PackageDescription + ( PackageDescription ) +import Distribution.Simple.LocalBuildInfo + ( LocalBuildInfo, externalPackageDeps ) +import Distribution.Text + ( display ) + +-- ------------------------------------------------------------ +-- * Generate cabal_macros.h +-- ------------------------------------------------------------ + +generate :: PackageDescription -> LocalBuildInfo -> String +generate _pkg_descr lbi = concat $ + "/* DO NOT EDIT: This file is automatically generated by Cabal */\n\n" : + [ concat + ["/* package ",display pkgid," */\n" + ,"#define VERSION_",pkgname," ",show (display version),"\n" + ,"#define MIN_VERSION_",pkgname,"(major1,major2,minor) (\\\n" + ," (major1) < ",major1," || \\\n" + ," (major1) == ",major1," && (major2) < ",major2," || \\\n" + ," (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")" + ,"\n\n" + ] + | (_, pkgid@(PackageIdentifier name version)) <- externalPackageDeps lbi + , let (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0) + pkgname = map fixchar (display name) + ] + where fixchar '-' = '_' + fixchar c = c + diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/Build/PathsModule.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/Build/PathsModule.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/Build/PathsModule.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/Build/PathsModule.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,258 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Build.Macros +-- Copyright : Isaac Jones 2003-2005, +-- Ross Paterson 2006, +-- Duncan Coutts 2007-2008 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Generating the Paths_pkgname module. +-- +-- This is a module that Cabal generates for the benefit of packages. It +-- enables them to find their version number and find any installed data files +-- at runtime. This code should probably be split off into another module. +-- +module Distribution.Simple.Build.PathsModule ( + generate, pkgPathEnvVar + ) where + +import Distribution.System + ( OS(Windows), buildOS ) +import Distribution.Simple.Compiler + ( CompilerFlavor(..), compilerFlavor, compilerVersion ) +import Distribution.Package + ( packageId, packageName, packageVersion ) +import Distribution.PackageDescription + ( PackageDescription(..), hasLibs ) +import Distribution.Simple.LocalBuildInfo + ( LocalBuildInfo(..), InstallDirs(..) + , absoluteInstallDirs, prefixRelativeInstallDirs ) +import Distribution.Simple.Setup ( CopyDest(NoCopyDest) ) +import Distribution.Simple.BuildPaths + ( autogenModuleName ) +import Distribution.Text + ( display ) +import Distribution.Version + ( Version(..), orLaterVersion, withinRange ) + +import System.FilePath + ( pathSeparator ) +import Data.Maybe + ( fromJust, isNothing ) + +-- ------------------------------------------------------------ +-- * Building Paths_.hs +-- ------------------------------------------------------------ + +generate :: PackageDescription -> LocalBuildInfo -> String +generate pkg_descr lbi = + let pragmas + | absolute || isHugs = "" + | supports_language_pragma = + "{-# LANGUAGE ForeignFunctionInterface #-}\n" + | otherwise = + "{-# OPTIONS_GHC -fffi #-}\n"++ + "{-# OPTIONS_JHC -fffi #-}\n" + + foreign_imports + | absolute = "" + | isHugs = "import System.Environment\n" + | otherwise = + "import Foreign\n"++ + "import Foreign.C\n" + + header = + pragmas++ + "module " ++ display paths_modulename ++ " (\n"++ + " version,\n"++ + " getBinDir, getLibDir, getDataDir, getLibexecDir,\n"++ + " getDataFileName\n"++ + " ) where\n"++ + "\n"++ + foreign_imports++ + "import qualified Control.Exception as Exception\n"++ + "import Data.Version (Version(..))\n"++ + "import System.Environment (getEnv)"++ + "\n"++ + "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n"++ + "catchIO = Exception.catch\n" ++ + "\n"++ + "\nversion :: Version"++ + "\nversion = " ++ show (packageVersion pkg_descr) + + body + | absolute = + "\nbindir, libdir, datadir, libexecdir :: FilePath\n"++ + "\nbindir = " ++ show flat_bindir ++ + "\nlibdir = " ++ show flat_libdir ++ + "\ndatadir = " ++ show flat_datadir ++ + "\nlibexecdir = " ++ show flat_libexecdir ++ + "\n"++ + "\ngetBinDir, getLibDir, getDataDir, getLibexecDir :: IO FilePath\n"++ + "getBinDir = "++mkGetEnvOr "bindir" "return bindir"++"\n"++ + "getLibDir = "++mkGetEnvOr "libdir" "return libdir"++"\n"++ + "getDataDir = "++mkGetEnvOr "datadir" "return datadir"++"\n"++ + "getLibexecDir = "++mkGetEnvOr "libexecdir" "return libexecdir"++"\n"++ + "\n"++ + "getDataFileName :: FilePath -> IO FilePath\n"++ + "getDataFileName name = do\n"++ + " dir <- getDataDir\n"++ + " return (dir ++ "++path_sep++" ++ name)\n" + | otherwise = + "\nprefix, bindirrel :: FilePath" ++ + "\nprefix = " ++ show flat_prefix ++ + "\nbindirrel = " ++ show (fromJust flat_bindirrel) ++ + "\n\n"++ + "getBinDir :: IO FilePath\n"++ + "getBinDir = getPrefixDirRel bindirrel\n\n"++ + "getLibDir :: IO FilePath\n"++ + "getLibDir = "++mkGetDir flat_libdir flat_libdirrel++"\n\n"++ + "getDataDir :: IO FilePath\n"++ + "getDataDir = "++ mkGetEnvOr "datadir" + (mkGetDir flat_datadir flat_datadirrel)++"\n\n"++ + "getLibexecDir :: IO FilePath\n"++ + "getLibexecDir = "++mkGetDir flat_libexecdir flat_libexecdirrel++"\n\n"++ + "getDataFileName :: FilePath -> IO FilePath\n"++ + "getDataFileName name = do\n"++ + " dir <- getDataDir\n"++ + " return (dir `joinFileName` name)\n"++ + "\n"++ + get_prefix_stuff++ + "\n"++ + filename_stuff + in header++body + + where + InstallDirs { + prefix = flat_prefix, + bindir = flat_bindir, + libdir = flat_libdir, + datadir = flat_datadir, + libexecdir = flat_libexecdir + } = absoluteInstallDirs pkg_descr lbi NoCopyDest + InstallDirs { + bindir = flat_bindirrel, + libdir = flat_libdirrel, + datadir = flat_datadirrel, + libexecdir = flat_libexecdirrel, + progdir = flat_progdirrel + } = prefixRelativeInstallDirs (packageId pkg_descr) lbi + + mkGetDir _ (Just dirrel) = "getPrefixDirRel " ++ show dirrel + mkGetDir dir Nothing = "return " ++ show dir + + mkGetEnvOr var expr = "catchIO (getEnv \""++var'++"\")"++ + " (\\_ -> "++expr++")" + where var' = pkgPathEnvVar pkg_descr var + + -- In several cases we cannot make relocatable installations + absolute = + hasLibs pkg_descr -- we can only make progs relocatable + || isNothing flat_bindirrel -- if the bin dir is an absolute path + || (isHugs && isNothing flat_progdirrel) + || not (supportsRelocatableProgs (compilerFlavor (compiler lbi))) + + supportsRelocatableProgs Hugs = True + supportsRelocatableProgs GHC = case buildOS of + Windows -> True + _ -> False + supportsRelocatableProgs _ = False + + paths_modulename = autogenModuleName pkg_descr + + isHugs = compilerFlavor (compiler lbi) == Hugs + get_prefix_stuff + | isHugs = "progdirrel :: String\n"++ + "progdirrel = "++show (fromJust flat_progdirrel)++"\n\n"++ + get_prefix_hugs + | otherwise = get_prefix_win32 + + path_sep = show [pathSeparator] + + supports_language_pragma = + compilerFlavor (compiler lbi) == GHC && + (compilerVersion (compiler lbi) + `withinRange` orLaterVersion (Version [6,6,1] [])) + +-- | Generates the name of the environment variable controlling the path +-- component of interest. +pkgPathEnvVar :: PackageDescription + -> String -- ^ path component; one of \"bindir\", \"libdir\", + -- \"datadir\" or \"libexecdir\" + -> String -- ^ environment variable name +pkgPathEnvVar pkg_descr var = + showPkgName (packageName pkg_descr) ++ "_" ++ var + where + showPkgName = map fixchar . display + fixchar '-' = '_' + fixchar c = c + +get_prefix_win32 :: String +get_prefix_win32 = + "getPrefixDirRel :: FilePath -> IO FilePath\n"++ + "getPrefixDirRel dirRel = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.\n"++ + " where\n"++ + " try_size size = allocaArray (fromIntegral size) $ \\buf -> do\n"++ + " ret <- c_GetModuleFileName nullPtr buf size\n"++ + " case ret of\n"++ + " 0 -> return (prefix `joinFileName` dirRel)\n"++ + " _ | ret < size -> do\n"++ + " exePath <- peekCWString buf\n"++ + " let (bindir,_) = splitFileName exePath\n"++ + " return ((bindir `minusFileName` bindirrel) `joinFileName` dirRel)\n"++ + " | otherwise -> try_size (size * 2)\n"++ + "\n"++ + "foreign import stdcall unsafe \"windows.h GetModuleFileNameW\"\n"++ + " c_GetModuleFileName :: Ptr () -> CWString -> Int32 -> IO Int32\n" + + +get_prefix_hugs :: String +get_prefix_hugs = + "getPrefixDirRel :: FilePath -> IO FilePath\n"++ + "getPrefixDirRel dirRel = do\n"++ + " mainPath <- getProgName\n"++ + " let (progPath,_) = splitFileName mainPath\n"++ + " let (progdir,_) = splitFileName progPath\n"++ + " return ((progdir `minusFileName` progdirrel) `joinFileName` dirRel)\n" + +filename_stuff :: String +filename_stuff = + "minusFileName :: FilePath -> String -> FilePath\n"++ + "minusFileName dir \"\" = dir\n"++ + "minusFileName dir \".\" = dir\n"++ + "minusFileName dir suffix =\n"++ + " minusFileName (fst (splitFileName dir)) (fst (splitFileName suffix))\n"++ + "\n"++ + "joinFileName :: String -> String -> FilePath\n"++ + "joinFileName \"\" fname = fname\n"++ + "joinFileName \".\" fname = fname\n"++ + "joinFileName dir \"\" = dir\n"++ + "joinFileName dir fname\n"++ + " | isPathSeparator (last dir) = dir++fname\n"++ + " | otherwise = dir++pathSeparator:fname\n"++ + "\n"++ + "splitFileName :: FilePath -> (String, String)\n"++ + "splitFileName p = (reverse (path2++drive), reverse fname)\n"++ + " where\n"++ + " (path,drive) = case p of\n"++ + " (c:':':p') -> (reverse p',[':',c])\n"++ + " _ -> (reverse p ,\"\")\n"++ + " (fname,path1) = break isPathSeparator path\n"++ + " path2 = case path1 of\n"++ + " [] -> \".\"\n"++ + " [_] -> path1 -- don't remove the trailing slash if \n"++ + " -- there is only one character\n"++ + " (c:path') | isPathSeparator c -> path'\n"++ + " _ -> path1\n"++ + "\n"++ + "pathSeparator :: Char\n"++ + (case buildOS of + Windows -> "pathSeparator = '\\\\'\n" + _ -> "pathSeparator = '/'\n") ++ + "\n"++ + "isPathSeparator :: Char -> Bool\n"++ + (case buildOS of + Windows -> "isPathSeparator c = c == '/' || c == '\\\\'\n" + _ -> "isPathSeparator c = c == '/'\n") diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/Build.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/Build.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/Build.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/Build.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,274 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Build +-- Copyright : Isaac Jones 2003-2005, +-- Ross Paterson 2006, +-- Duncan Coutts 2007-2008 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is the entry point to actually building the modules in a package. It +-- doesn't actually do much itself, most of the work is delegated to +-- compiler-specific actions. It does do some non-compiler specific bits like +-- running pre-processors. +-- + +{- Copyright (c) 2003-2005, Isaac Jones +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.Simple.Build ( + build, + + initialBuildSteps, + writeAutogenFiles, + ) where + +import qualified Distribution.Simple.GHC as GHC +import qualified Distribution.Simple.JHC as JHC +import qualified Distribution.Simple.LHC as LHC +import qualified Distribution.Simple.NHC as NHC +import qualified Distribution.Simple.Hugs as Hugs +import qualified Distribution.Simple.UHC as UHC + +import qualified Distribution.Simple.Build.Macros as Build.Macros +import qualified Distribution.Simple.Build.PathsModule as Build.PathsModule + +import Distribution.Package + ( Package(..), PackageName(..), PackageIdentifier(..) + , thisPackageVersion ) +import Distribution.Simple.Compiler + ( CompilerFlavor(..), compilerFlavor, PackageDB(..) ) +import Distribution.PackageDescription + ( PackageDescription(..), BuildInfo(..), Library(..), Executable(..) + , TestSuite(..), TestSuiteInterface(..) ) +import qualified Distribution.InstalledPackageInfo as IPI +import qualified Distribution.ModuleName as ModuleName + +import Distribution.Simple.Setup + ( BuildFlags(..), fromFlag ) +import Distribution.Simple.PreProcess + ( preprocessComponent, PPSuffixHandler ) +import Distribution.Simple.LocalBuildInfo + ( LocalBuildInfo(compiler, buildDir, withPackageDB) + , Component(..), ComponentLocalBuildInfo(..), withComponentsLBI + , inplacePackageId ) +import Distribution.Simple.BuildPaths + ( autogenModulesDir, autogenModuleName, cppHeaderName ) +import Distribution.Simple.Register + ( registerPackage, inplaceInstalledPackageInfo ) +import Distribution.Simple.Test ( stubFilePath, stubName ) +import Distribution.Simple.Utils + ( createDirectoryIfMissingVerbose, rewriteFile + , die, info, setupMessage ) + +import Distribution.Verbosity + ( Verbosity ) +import Distribution.Text + ( display ) + +import Data.Maybe + ( maybeToList ) +import Control.Monad + ( unless ) +import System.FilePath + ( (), (<.>) ) +import System.Directory + ( getCurrentDirectory ) + +-- ----------------------------------------------------------------------------- +-- |Build the libraries and executables in this package. + +build :: PackageDescription -- ^ Mostly information from the .cabal file + -> LocalBuildInfo -- ^ Configuration information + -> BuildFlags -- ^ Flags that the user passed to build + -> [ PPSuffixHandler ] -- ^ preprocessors to run before compiling + -> IO () +build pkg_descr lbi flags suffixes = do + let distPref = fromFlag (buildDistPref flags) + verbosity = fromFlag (buildVerbosity flags) + initialBuildSteps distPref pkg_descr lbi verbosity + setupMessage verbosity "Building" (packageId pkg_descr) + + internalPackageDB <- createInternalPackageDB distPref + + let pre c = preprocessComponent pkg_descr c lbi False verbosity suffixes + lbi' = lbi {withPackageDB = withPackageDB lbi ++ [internalPackageDB]} + -- Use the internal package DB for the exes. + withComponentsLBI pkg_descr lbi $ \comp clbi -> do + pre comp + case comp of + CLib lib -> do + info verbosity "Building library..." + buildLib verbosity pkg_descr lbi lib clbi + + -- Register the library in-place, so exes can depend + -- on internally defined libraries. + pwd <- getCurrentDirectory + let installedPkgInfo = + (inplaceInstalledPackageInfo pwd distPref pkg_descr lib lbi clbi) { + -- The inplace registration uses the "-inplace" suffix, + -- not an ABI hash. + IPI.installedPackageId = inplacePackageId (packageId installedPkgInfo) + } + registerPackage verbosity + installedPkgInfo pkg_descr lbi True -- True meaning inplace + (withPackageDB lbi ++ [internalPackageDB]) + + CExe exe -> do + info verbosity $ "Building executable " ++ exeName exe ++ "..." + buildExe verbosity pkg_descr lbi' exe clbi + + CTest test -> do + case testInterface test of + TestSuiteExeV10 _ f -> do + let exe = Executable + { exeName = testName test + , modulePath = f + , buildInfo = testBuildInfo test + } + info verbosity $ "Building test suite " ++ testName test ++ "..." + buildExe verbosity pkg_descr lbi' exe clbi + TestSuiteLibV09 _ m -> do + pwd <- getCurrentDirectory + let lib = Library + { exposedModules = [ m ] + , libExposed = True + , libBuildInfo = testBuildInfo test + } + pkg = pkg_descr + { package = (package pkg_descr) + { pkgName = PackageName $ testName test + } + , buildDepends = targetBuildDepends $ testBuildInfo test + , executables = [] + , testSuites = [] + , library = Just lib + } + ipi = (inplaceInstalledPackageInfo + pwd distPref pkg lib lbi clbi) + { IPI.installedPackageId = inplacePackageId $ packageId ipi + } + testDir = buildDir lbi' stubName test + stubName test ++ "-tmp" + testLibDep = thisPackageVersion $ package pkg + exe = Executable + { exeName = stubName test + , modulePath = stubFilePath test + , buildInfo = (testBuildInfo test) + { hsSourceDirs = [ testDir ] + , targetBuildDepends = testLibDep + : (targetBuildDepends $ testBuildInfo test) + } + } + -- | The stub executable needs a new 'ComponentLocalBuildInfo' + -- that exposes the relevant test suite library. + exeClbi = clbi + { componentPackageDeps = + (IPI.installedPackageId ipi, packageId ipi) + : (filter (\(_, x) -> let PackageName name = pkgName x in name == "Cabal" || name == "base") + $ componentPackageDeps clbi) + } + info verbosity $ "Building test suite " ++ testName test ++ "..." + buildLib verbosity pkg lbi' lib clbi + registerPackage verbosity ipi pkg lbi' True $ withPackageDB lbi' + buildExe verbosity pkg_descr lbi' exe exeClbi + TestSuiteUnsupported tt -> die $ "No support for building test suite " + ++ "type " ++ display tt + +-- | Initialize a new package db file for libraries defined +-- internally to the package. +createInternalPackageDB :: FilePath -> IO PackageDB +createInternalPackageDB distPref = do + let dbFile = distPref "package.conf.inplace" + packageDB = SpecificPackageDB dbFile + writeFile dbFile "[]" + return packageDB + +-- TODO: build separate libs in separate dirs so that we can build +-- multiple libs, e.g. for 'LibTest' library-style testsuites +buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo + -> Library -> ComponentLocalBuildInfo -> IO () +buildLib verbosity pkg_descr lbi lib clbi = + case compilerFlavor (compiler lbi) of + GHC -> GHC.buildLib verbosity pkg_descr lbi lib clbi + JHC -> JHC.buildLib verbosity pkg_descr lbi lib clbi + LHC -> LHC.buildLib verbosity pkg_descr lbi lib clbi + Hugs -> Hugs.buildLib verbosity pkg_descr lbi lib clbi + NHC -> NHC.buildLib verbosity pkg_descr lbi lib clbi + UHC -> UHC.buildLib verbosity pkg_descr lbi lib clbi + _ -> die "Building is not supported with this compiler." + +buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo + -> Executable -> ComponentLocalBuildInfo -> IO () +buildExe verbosity pkg_descr lbi exe clbi = + case compilerFlavor (compiler lbi) of + GHC -> GHC.buildExe verbosity pkg_descr lbi exe clbi + JHC -> JHC.buildExe verbosity pkg_descr lbi exe clbi + LHC -> LHC.buildExe verbosity pkg_descr lbi exe clbi + Hugs -> Hugs.buildExe verbosity pkg_descr lbi exe clbi + NHC -> NHC.buildExe verbosity pkg_descr lbi exe clbi + UHC -> UHC.buildExe verbosity pkg_descr lbi exe clbi + _ -> die "Building is not supported with this compiler." + +initialBuildSteps :: FilePath -- ^"dist" prefix + -> PackageDescription -- ^mostly information from the .cabal file + -> LocalBuildInfo -- ^Configuration information + -> Verbosity -- ^The verbosity to use + -> IO () +initialBuildSteps _distPref pkg_descr lbi verbosity = do + -- check that there's something to build + let buildInfos = + map libBuildInfo (maybeToList (library pkg_descr)) ++ + map buildInfo (executables pkg_descr) + unless (any buildable buildInfos) $ do + let name = display (packageId pkg_descr) + die ("Package " ++ name ++ " can't be built on this system.") + + createDirectoryIfMissingVerbose verbosity True (buildDir lbi) + + writeAutogenFiles verbosity pkg_descr lbi + +-- | Generate and write out the Paths_.hs and cabal_macros.h files +-- +writeAutogenFiles :: Verbosity + -> PackageDescription + -> LocalBuildInfo + -> IO () +writeAutogenFiles verbosity pkg lbi = do + createDirectoryIfMissingVerbose verbosity True (autogenModulesDir lbi) + + let pathsModulePath = autogenModulesDir lbi + ModuleName.toFilePath (autogenModuleName pkg) <.> "hs" + rewriteFile pathsModulePath (Build.PathsModule.generate pkg lbi) + + let cppHeaderPath = autogenModulesDir lbi cppHeaderName + rewriteFile cppHeaderPath (Build.Macros.generate pkg lbi) diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/BuildPaths.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/BuildPaths.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/BuildPaths.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/BuildPaths.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,150 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.BuildPaths +-- Copyright : Isaac Jones 2003-2004, +-- Duncan Coutts 2008 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- A bunch of dirs, paths and file names used for intermediate build steps. +-- + +{- All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.Simple.BuildPaths ( + defaultDistPref, srcPref, + hscolourPref, haddockPref, + autogenModulesDir, + + autogenModuleName, + cppHeaderName, + haddockName, + + mkLibName, + mkProfLibName, + mkSharedLibName, + + exeExtension, + objExtension, + dllExtension, + + ) where + + +import System.FilePath ((), (<.>)) + +import Distribution.Package + ( PackageIdentifier, packageName ) +import Distribution.ModuleName (ModuleName) +import qualified Distribution.ModuleName as ModuleName +import Distribution.Compiler + ( CompilerId(..) ) +import Distribution.PackageDescription (PackageDescription) +import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(buildDir)) +import Distribution.Simple.Setup (defaultDistPref) +import Distribution.Text + ( display ) +import Distribution.System (OS(..), buildOS) + +-- --------------------------------------------------------------------------- +-- Build directories and files + +srcPref :: FilePath -> FilePath +srcPref distPref = distPref "src" + +hscolourPref :: FilePath -> PackageDescription -> FilePath +hscolourPref = haddockPref + +haddockPref :: FilePath -> PackageDescription -> FilePath +haddockPref distPref pkg_descr + = distPref "doc" "html" display (packageName pkg_descr) + +-- |The directory in which we put auto-generated modules +autogenModulesDir :: LocalBuildInfo -> String +autogenModulesDir lbi = buildDir lbi "autogen" + +cppHeaderName :: String +cppHeaderName = "cabal_macros.h" + +-- |The name of the auto-generated module associated with a package +autogenModuleName :: PackageDescription -> ModuleName +autogenModuleName pkg_descr = + ModuleName.fromString $ + "Paths_" ++ map fixchar (display (packageName pkg_descr)) + where fixchar '-' = '_' + fixchar c = c + +haddockName :: PackageDescription -> FilePath +haddockName pkg_descr = display (packageName pkg_descr) <.> "haddock" + +-- --------------------------------------------------------------------------- +-- Library file names + +mkLibName :: PackageIdentifier -> String +mkLibName lib = "libHS" ++ display lib <.> "a" + +mkProfLibName :: PackageIdentifier -> String +mkProfLibName lib = "libHS" ++ display lib ++ "_p" <.> "a" + +-- Implement proper name mangling for dynamical shared objects +-- libHS- +-- e.g. libHSbase-2.1-ghc6.6.1.so +mkSharedLibName :: PackageIdentifier -> CompilerId -> String +mkSharedLibName lib (CompilerId compilerFlavor compilerVersion) + = "libHS" ++ display lib ++ "-" ++ comp <.> dllExtension + where comp = display compilerFlavor ++ display compilerVersion + +-- ------------------------------------------------------------ +-- * Platform file extensions +-- ------------------------------------------------------------ + +-- ToDo: This should be determined via autoconf (AC_EXEEXT) +-- | Extension for executable files +-- (typically @\"\"@ on Unix and @\"exe\"@ on Windows or OS\/2) +exeExtension :: String +exeExtension = case buildOS of + Windows -> "exe" + _ -> "" + +-- ToDo: This should be determined via autoconf (AC_OBJEXT) +-- | Extension for object files. For GHC and NHC the extension is @\"o\"@. +-- Hugs uses either @\"o\"@ or @\"obj\"@ depending on the used C compiler. +objExtension :: String +objExtension = "o" + +-- | Extension for dynamically linked (or shared) libraries +-- (typically @\"so\"@ on Unix and @\"dll\"@ on Windows) +dllExtension :: String +dllExtension = case buildOS of + Windows -> "dll" + OSX -> "dylib" + _ -> "so" diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/Command.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/Command.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/Command.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/Command.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,545 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Command +-- Copyright : Duncan Coutts 2007 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is to do with command line handling. The Cabal command line is +-- organised into a number of named sub-commands (much like darcs). The +-- 'CommandUI' abstraction represents one of these sub-commands, with a name, +-- description, a set of flags. Commands can be associated with actions and +-- run. It handles some common stuff automatically, like the @--help@ and +-- command line completion flags. It is designed to allow other tools make +-- derived commands. This feature is used heavily in @cabal-install@. + +{- All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.Simple.Command ( + + -- * Command interface + CommandUI(..), + commandShowOptions, + CommandParse(..), + commandParseArgs, + + -- ** Constructing commands + ShowOrParseArgs(..), + makeCommand, + + -- ** Associating actions with commands + Command, + commandAddAction, + noExtraFlags, + + -- ** Running commands + commandsRun, + +-- * Option Fields + OptionField(..), Name, + +-- ** Constructing Option Fields + option, multiOption, + +-- ** Liftings & Projections + liftOption, viewAsFieldDescr, + +-- * Option Descriptions + OptDescr(..), Description, SFlags, LFlags, OptFlags, ArgPlaceHolder, + +-- ** OptDescr 'smart' constructors + MkOptDescr, + reqArg, reqArg', optArg, optArg', noArg, + boolOpt, boolOpt', choiceOpt, choiceOptFromEnum + + ) where + +import Control.Monad +import Data.Char (isAlpha, toLower) +import Data.List (sortBy) +import Data.Maybe +import Data.Monoid +import qualified Distribution.GetOpt as GetOpt +import Distribution.Text + ( Text(disp, parse) ) +import Distribution.ParseUtils +import Distribution.ReadE +import Distribution.Simple.Utils (die, intercalate) +import Text.PrettyPrint.HughesPJ ( punctuate, cat, comma, text, empty) + +data CommandUI flags = CommandUI { + -- | The name of the command as it would be entered on the command line. + -- For example @\"build\"@. + commandName :: String, + -- | A short, one line description of the command to use in help texts. + commandSynopsis :: String, + -- | The useage line summary for this command + commandUsage :: String -> String, + -- | Additional explanation of the command to use in help texts. + commandDescription :: Maybe (String -> String), + -- | Initial \/ empty flags + commandDefaultFlags :: flags, + -- | All the Option fields for this command + commandOptions :: ShowOrParseArgs -> [OptionField flags] + } + +data ShowOrParseArgs = ShowArgs | ParseArgs + +type Name = String +type Description = String + +-- | We usually have a datatype for storing configuration values, where +-- every field stores a configuration option, and the user sets +-- the value either via command line flags or a configuration file. +-- An individual OptionField models such a field, and we usually +-- build a list of options associated to a configuration datatype. +data OptionField a = OptionField { + optionName :: Name, + optionDescr :: [OptDescr a] } + +-- | An OptionField takes one or more OptDescrs, describing the command line interface for the field. +data OptDescr a = ReqArg Description OptFlags ArgPlaceHolder (ReadE (a->a)) (a -> [String]) + | OptArg Description OptFlags ArgPlaceHolder (ReadE (a->a)) (a->a) (a -> [Maybe String]) + | ChoiceOpt [(Description, OptFlags, a->a, a -> Bool)] + | BoolOpt Description OptFlags{-True-} OptFlags{-False-} (Bool -> a -> a) (a-> Maybe Bool) + +-- | Short command line option strings +type SFlags = [Char] +-- | Long command line option strings +type LFlags = [String] +type OptFlags = (SFlags,LFlags) +type ArgPlaceHolder = String + + +-- | Create an option taking a single OptDescr. +-- No explicit Name is given for the Option, the name is the first LFlag given. +option :: SFlags -> LFlags -> Description -> get -> set -> MkOptDescr get set a -> OptionField a +option sf lf@(n:_) d get set arg = OptionField n [arg sf lf d get set] +option _ _ _ _ _ _ = error "Distribution.command.option: An OptionField must have at least one LFlag" + +-- | Create an option taking several OptDescrs. +-- You will have to give the flags and description individually to the OptDescr constructor. +multiOption :: Name -> get -> set + -> [get -> set -> OptDescr a] -- ^MkOptDescr constructors partially applied to flags and description. + -> OptionField a +multiOption n get set args = OptionField n [arg get set | arg <- args] + +type MkOptDescr get set a = SFlags -> LFlags -> Description -> get -> set -> OptDescr a + +-- | Create a string-valued command line interface. +reqArg :: Monoid b => ArgPlaceHolder -> ReadE b -> (b -> [String]) + -> MkOptDescr (a -> b) (b -> a -> a) a +reqArg ad mkflag showflag sf lf d get set = + ReqArg d (sf,lf) ad (fmap (\a b -> set (get b `mappend` a) b) mkflag) (showflag . get) + +-- | Create a string-valued command line interface with a default value. +optArg :: Monoid b => ArgPlaceHolder -> ReadE b -> b -> (b -> [Maybe String]) + -> MkOptDescr (a -> b) (b -> a -> a) a +optArg ad mkflag def showflag sf lf d get set = + OptArg d (sf,lf) ad (fmap (\a b -> set (get b `mappend` a) b) mkflag) + (\b -> set (get b `mappend` def) b) + (showflag . get) + +-- | (String -> a) variant of "reqArg" +reqArg' :: Monoid b => ArgPlaceHolder -> (String -> b) -> (b -> [String]) + -> MkOptDescr (a -> b) (b -> a -> a) a +reqArg' ad mkflag showflag = + reqArg ad (succeedReadE mkflag) showflag + +-- | (String -> a) variant of "optArg" +optArg' :: Monoid b => ArgPlaceHolder -> (Maybe String -> b) -> (b -> [Maybe String]) + -> MkOptDescr (a -> b) (b -> a -> a) a +optArg' ad mkflag showflag = + optArg ad (succeedReadE (mkflag . Just)) def showflag + where def = mkflag Nothing + +noArg :: (Eq b, Monoid b) => b -> MkOptDescr (a -> b) (b -> a -> a) a +noArg flag sf lf d = choiceOpt [(flag, (sf,lf), d)] sf lf d + +boolOpt :: (b -> Maybe Bool) -> (Bool -> b) -> SFlags -> SFlags -> MkOptDescr (a -> b) (b -> a -> a) a +boolOpt g s sfT sfF _sf _lf@(n:_) d get set = + BoolOpt d (sfT, ["enable-"++n]) (sfF, ["disable-"++n]) (set.s) (g.get) +boolOpt _ _ _ _ _ _ _ _ _ = error "Distribution.Simple.Setup.boolOpt: unreachable" + +boolOpt' :: (b -> Maybe Bool) -> (Bool -> b) -> OptFlags -> OptFlags -> MkOptDescr (a -> b) (b -> a -> a) a +boolOpt' g s ffT ffF _sf _lf d get set = BoolOpt d ffT ffF (set.s) (g . get) + +-- | create a Choice option +choiceOpt :: Eq b => [(b,OptFlags,Description)] -> MkOptDescr (a -> b) (b -> a -> a) a +choiceOpt aa_ff _sf _lf _d get set = ChoiceOpt alts + where alts = [(d,flags, set alt, (==alt) . get) | (alt,flags,d) <- aa_ff] + +-- | create a Choice option out of an enumeration type. +-- As long flags, the Show output is used. As short flags, the first character +-- which does not conflict with a previous one is used. +choiceOptFromEnum :: (Bounded b, Enum b, Show b, Eq b) => MkOptDescr (a -> b) (b -> a -> a) a +choiceOptFromEnum _sf _lf d get = choiceOpt [ (x, (sf, [map toLower $ show x]), d') + | (x, sf) <- sflags' + , let d' = d ++ show x] + _sf _lf d get + where sflags' = foldl f [] [firstOne..] + f prev x = let prevflags = concatMap snd prev in + prev ++ take 1 [(x, [toLower sf]) | sf <- show x, isAlpha sf + , toLower sf `notElem` prevflags] + firstOne = minBound `asTypeOf` get undefined + +commandGetOpts :: ShowOrParseArgs -> CommandUI flags -> [GetOpt.OptDescr (flags -> flags)] +commandGetOpts showOrParse command = + concatMap viewAsGetOpt (commandOptions command showOrParse) + +viewAsGetOpt :: OptionField a -> [GetOpt.OptDescr (a->a)] +viewAsGetOpt (OptionField _n aa) = concatMap optDescrToGetOpt aa + where + optDescrToGetOpt (ReqArg d (cs,ss) arg_desc set _) = + [GetOpt.Option cs ss (GetOpt.ReqArg set' arg_desc) d] + where set' = readEOrFail set + optDescrToGetOpt (OptArg d (cs,ss) arg_desc set def _) = + [GetOpt.Option cs ss (GetOpt.OptArg set' arg_desc) d] + where set' Nothing = def + set' (Just txt) = readEOrFail set txt + optDescrToGetOpt (ChoiceOpt alts) = + [GetOpt.Option sf lf (GetOpt.NoArg set) d | (d,(sf,lf),set,_) <- alts ] + optDescrToGetOpt (BoolOpt d (sfT,lfT) (sfF, lfF) set _) = + [ GetOpt.Option sfT lfT (GetOpt.NoArg (set True)) ("Enable " ++ d) + , GetOpt.Option sfF lfF (GetOpt.NoArg (set False)) ("Disable " ++ d) ] + +-- | to view as a FieldDescr, we sort the list of interfaces (Req > Bool > Choice > Opt) and consider only the first one. +viewAsFieldDescr :: OptionField a -> FieldDescr a +viewAsFieldDescr (OptionField _n []) = error "Distribution.command.viewAsFieldDescr: unexpected" +viewAsFieldDescr (OptionField n dd) = FieldDescr n get set + where optDescr = head $ sortBy cmp dd + ReqArg{} `cmp` ReqArg{} = EQ + ReqArg{} `cmp` _ = GT + BoolOpt{} `cmp` ReqArg{} = LT + BoolOpt{} `cmp` BoolOpt{} = EQ + BoolOpt{} `cmp` _ = GT + ChoiceOpt{} `cmp` ReqArg{} = LT + ChoiceOpt{} `cmp` BoolOpt{} = LT + ChoiceOpt{} `cmp` ChoiceOpt{} = EQ + ChoiceOpt{} `cmp` _ = GT + OptArg{} `cmp` OptArg{} = EQ + OptArg{} `cmp` _ = LT + get t = case optDescr of + ReqArg _ _ _ _ ppr -> + (cat . punctuate comma . map text . ppr) t + OptArg _ _ _ _ _ ppr -> + case ppr t of + [] -> empty + (Nothing : _) -> text "True" + (Just a : _) -> text a + ChoiceOpt alts -> + fromMaybe empty $ listToMaybe + [ text lf | (_,(_,lf:_), _,enabled) <- alts, enabled t] + BoolOpt _ _ _ _ enabled -> (maybe empty disp . enabled) t + set line val a = + case optDescr of + ReqArg _ _ _ readE _ -> ($ a) `liftM` runE line n readE val + -- We parse for a single value instead of a list, + -- as one can't really implement parseList :: ReadE a -> ReadE [a] + -- with the current ReadE definition + ChoiceOpt{} -> case getChoiceByLongFlag optDescr val of + Just f -> return (f a) + _ -> syntaxError line val + BoolOpt _ _ _ setV _ -> (`setV` a) `liftM` runP line n parse val + OptArg _ _ _ _readE _ _ -> -- The behaviour in this case is not clear, and it has no use so far, + -- so we avoid future surprises by not implementing it. + error "Command.optionToFieldDescr: feature not implemented" + +getChoiceByLongFlag :: OptDescr b -> String -> Maybe (b->b) +getChoiceByLongFlag (ChoiceOpt alts) val = listToMaybe [ set | (_,(_sf,lf:_), set, _) <- alts + , lf == val] + +getChoiceByLongFlag _ _ = error "Distribution.command.getChoiceByLongFlag: expected a choice option" + +getCurrentChoice :: OptDescr a -> a -> [String] +getCurrentChoice (ChoiceOpt alts) a = + [ lf | (_,(_sf,lf:_), _, currentChoice) <- alts, currentChoice a] + +getCurrentChoice _ _ = error "Command.getChoice: expected a Choice OptDescr" + + +liftOption :: (b -> a) -> (a -> (b -> b)) -> OptionField a -> OptionField b +liftOption get' set' opt = opt { optionDescr = liftOptDescr get' set' `map` optionDescr opt} + + +liftOptDescr :: (b -> a) -> (a -> (b -> b)) -> OptDescr a -> OptDescr b +liftOptDescr get' set' (ChoiceOpt opts) = + ChoiceOpt [ (d, ff, liftSet get' set' set , (get . get')) + | (d, ff, set, get) <- opts] + +liftOptDescr get' set' (OptArg d ff ad set def get) = + OptArg d ff ad (liftSet get' set' `fmap` set) (liftSet get' set' def) (get . get') + +liftOptDescr get' set' (ReqArg d ff ad set get) = + ReqArg d ff ad (liftSet get' set' `fmap` set) (get . get') + +liftOptDescr get' set' (BoolOpt d ffT ffF set get) = + BoolOpt d ffT ffF (liftSet get' set' . set) (get . get') + +liftSet :: (b -> a) -> (a -> (b -> b)) -> (a -> a) -> b -> b +liftSet get' set' set x = set' (set $ get' x) x + +-- | Show flags in the standard long option command line format +commandShowOptions :: CommandUI flags -> flags -> [String] +commandShowOptions command v = concat + [ showOptDescr v od | o <- commandOptions command ParseArgs + , od <- optionDescr o] + where + showOptDescr :: a -> OptDescr a -> [String] + showOptDescr x (BoolOpt _ (_,lfT:_) (_,lfF:_) _ enabled) + = case enabled x of + Nothing -> [] + Just True -> ["--" ++ lfT] + Just False -> ["--" ++ lfF] + showOptDescr x c@ChoiceOpt{} + = ["--" ++ val | val <- getCurrentChoice c x] + showOptDescr x (ReqArg _ (_ssff,lf:_) _ _ showflag) + = [ "--"++lf++"="++flag + | flag <- showflag x ] + showOptDescr x (OptArg _ (_ssff,lf:_) _ _ _ showflag) + = [ case flag of + Just s -> "--"++lf++"="++s + Nothing -> "--"++lf + | flag <- showflag x ] + showOptDescr _ _ + = error "Distribution.Simple.Command.showOptDescr: unreachable" + + +commandListOptions :: CommandUI flags -> [String] +commandListOptions command = + concatMap listOption $ + addCommonFlags ShowArgs $ -- This is a slight hack, we don't want + -- "--list-options" showing up in the + -- list options output, so use ShowArgs + commandGetOpts ShowArgs command + where + listOption (GetOpt.Option shortNames longNames _ _) = + [ "-" ++ [name] | name <- shortNames ] + ++ [ "--" ++ name | name <- longNames ] + +-- | The help text for this command with descriptions of all the options. +commandHelp :: CommandUI flags -> String -> String +commandHelp command pname = + commandUsage command pname + ++ (GetOpt.usageInfo "" + . addCommonFlags ShowArgs + $ commandGetOpts ShowArgs command) + ++ case commandDescription command of + Nothing -> "" + Just desc -> '\n': desc pname + +-- | Make a Command from standard 'GetOpt' options. +makeCommand :: String -- ^ name + -> String -- ^ short description + -> Maybe (String -> String) -- ^ long description + -> flags -- ^ initial\/empty flags + -> (ShowOrParseArgs -> [OptionField flags]) -- ^ options + -> CommandUI flags +makeCommand name shortDesc longDesc defaultFlags options = + CommandUI { + commandName = name, + commandSynopsis = shortDesc, + commandDescription = longDesc, + commandUsage = usage, + commandDefaultFlags = defaultFlags, + commandOptions = options + } + where usage pname = "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n\n" + ++ "Flags for " ++ name ++ ":" + +-- | Common flags that apply to every command +data CommonFlag = HelpFlag | ListOptionsFlag + +commonFlags :: ShowOrParseArgs -> [GetOpt.OptDescr CommonFlag] +commonFlags showOrParseArgs = case showOrParseArgs of + ShowArgs -> [help] + ParseArgs -> [help, list] + where + help = GetOpt.Option helpShortFlags ["help"] (GetOpt.NoArg HelpFlag) + "Show this help text" + helpShortFlags = case showOrParseArgs of + ShowArgs -> ['h'] + ParseArgs -> ['h', '?'] + list = GetOpt.Option [] ["list-options"] (GetOpt.NoArg ListOptionsFlag) + "Print a list of command line flags" + +addCommonFlags :: ShowOrParseArgs + -> [GetOpt.OptDescr a] + -> [GetOpt.OptDescr (Either CommonFlag a)] +addCommonFlags showOrParseArgs options = + map (fmapOptDesc Left) (commonFlags showOrParseArgs) + ++ map (fmapOptDesc Right) options + where fmapOptDesc f (GetOpt.Option s l d m) = + GetOpt.Option s l (fmapArgDesc f d) m + fmapArgDesc f (GetOpt.NoArg a) = GetOpt.NoArg (f a) + fmapArgDesc f (GetOpt.ReqArg s d) = GetOpt.ReqArg (f . s) d + fmapArgDesc f (GetOpt.OptArg s d) = GetOpt.OptArg (f . s) d + +-- | Parse a bunch of command line arguments +-- +commandParseArgs :: CommandUI flags + -> Bool -- ^ Is the command a global or subcommand? + -> [String] + -> CommandParse (flags -> flags, [String]) +commandParseArgs command global args = + let options = addCommonFlags ParseArgs + $ commandGetOpts ParseArgs command + order | global = GetOpt.RequireOrder + | otherwise = GetOpt.Permute + in case GetOpt.getOpt' order options args of + (flags, _, _, _) + | any listFlag flags -> CommandList (commandListOptions command) + | any helpFlag flags -> CommandHelp (commandHelp command) + where listFlag (Left ListOptionsFlag) = True; listFlag _ = False + helpFlag (Left HelpFlag) = True; helpFlag _ = False + (flags, opts, opts', []) + | global || null opts' -> CommandReadyToGo (accum flags, mix opts opts') + | otherwise -> CommandErrors (unrecognised opts') + (_, _, _, errs) -> CommandErrors errs + + where -- Note: It is crucial to use reverse function composition here or to + -- reverse the flags here as we want to process the flags left to right + -- but data flow in function compsition is right to left. + accum flags = foldr (flip (.)) id [ f | Right f <- flags ] + unrecognised opts = [ "unrecognized option `" ++ opt ++ "'\n" + | opt <- opts ] + -- For unrecognised global flags we put them in the position just after + -- the command, if there is one. This gives us a chance to parse them + -- as sub-command rather than global flags. + mix [] ys = ys + mix (x:xs) ys = x:ys++xs + +data CommandParse flags = CommandHelp (String -> String) + | CommandList [String] + | CommandErrors [String] + | CommandReadyToGo flags +instance Functor CommandParse where + fmap _ (CommandHelp help) = CommandHelp help + fmap _ (CommandList opts) = CommandList opts + fmap _ (CommandErrors errs) = CommandErrors errs + fmap f (CommandReadyToGo flags) = CommandReadyToGo (f flags) + + +data Command action = Command String String ([String] -> CommandParse action) + +commandAddAction :: CommandUI flags + -> (flags -> [String] -> action) + -> Command action +commandAddAction command action = + Command (commandName command) + (commandSynopsis command) + (fmap (uncurry applyDefaultArgs) + . commandParseArgs command False) + + where applyDefaultArgs mkflags args = + let flags = mkflags (commandDefaultFlags command) + in action flags args + +commandsRun :: CommandUI a + -> [Command action] + -> [String] + -> CommandParse (a, CommandParse action) +commandsRun globalCommand commands args = + case commandParseArgs globalCommand' True args of + CommandHelp help -> CommandHelp help + CommandList opts -> CommandList (opts ++ commandNames) + CommandErrors errs -> CommandErrors errs + CommandReadyToGo (mkflags, args') -> case args' of + ("help":cmdArgs) -> handleHelpCommand cmdArgs + (name:cmdArgs) -> case lookupCommand name of + [Command _ _ action] -> CommandReadyToGo (flags, action cmdArgs) + _ -> CommandReadyToGo (flags, badCommand name) + [] -> CommandReadyToGo (flags, noCommand) + where flags = mkflags (commandDefaultFlags globalCommand) + + where + lookupCommand cname = [ cmd | cmd@(Command cname' _ _) <- commands' + , cname'==cname ] + noCommand = CommandErrors ["no command given (try --help)\n"] + badCommand cname = CommandErrors ["unrecognised command: " ++ cname + ++ " (try --help)\n"] + commands' = commands ++ [commandAddAction helpCommandUI undefined] + commandNames = [ name | Command name _ _ <- commands' ] + globalCommand' = globalCommand { + commandUsage = \pname -> + (case commandUsage globalCommand pname of + "" -> "" + original -> original ++ "\n") + ++ "Usage: " ++ pname ++ " COMMAND [FLAGS]\n" + ++ " or: " ++ pname ++ " [GLOBAL FLAGS]\n\n" + ++ "Global flags:", + commandDescription = Just $ \pname -> + "Commands:\n" + ++ unlines [ " " ++ align name ++ " " ++ description + | Command name description _ <- commands' ] + ++ case commandDescription globalCommand of + Nothing -> "" + Just desc -> '\n': desc pname + } + where maxlen = maximum [ length name | Command name _ _ <- commands' ] + align str = str ++ replicate (maxlen - length str) ' ' + + -- A bit of a hack: support "prog help" as a synonym of "prog --help" + -- furthermore, support "prog help command" as "prog command --help" + handleHelpCommand cmdArgs = + case commandParseArgs helpCommandUI True cmdArgs of + CommandHelp help -> CommandHelp help + CommandList list -> CommandList (list ++ commandNames) + CommandErrors _ -> CommandHelp globalHelp + CommandReadyToGo (_,[]) -> CommandHelp globalHelp + CommandReadyToGo (_,(name:cmdArgs')) -> + case lookupCommand name of + [Command _ _ action] -> + case action ("--help":cmdArgs') of + CommandHelp help -> CommandHelp help + CommandList _ -> CommandList [] + _ -> CommandHelp globalHelp + _ -> badCommand name + + where globalHelp = commandHelp globalCommand' + helpCommandUI = + (makeCommand "help" "Help about commands" Nothing () (const [])) { + commandUsage = \pname -> + "Usage: " ++ pname ++ " help [FLAGS]\n" + ++ " or: " ++ pname ++ " help COMMAND [FLAGS]\n\n" + ++ "Flags for help:" + } + +-- | Utility function, many commands do not accept additional flags. This +-- action fails with a helpful error message if the user supplies any extra. +-- +noExtraFlags :: [String] -> IO () +noExtraFlags [] = return () +noExtraFlags extraFlags = + die $ "Unrecognised flags: " ++ intercalate ", " extraFlags +--TODO: eliminate this function and turn it into a variant on commandAddAction +-- instead like commandAddActionNoArgs that doesn't supply the [String] diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/Compiler.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/Compiler.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/Compiler.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/Compiler.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,194 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Compiler +-- Copyright : Isaac Jones 2003-2004 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This should be a much more sophisticated abstraction than it is. Currently +-- it's just a bit of data about the compiler, like it's flavour and name and +-- version. The reason it's just data is because currently it has to be in +-- 'Read' and 'Show' so it can be saved along with the 'LocalBuildInfo'. The +-- only interesting bit of info it contains is a mapping between language +-- extensions and compiler command line flags. This module also defines a +-- 'PackageDB' type which is used to refer to package databases. Most compilers +-- only know about a single global package collection but GHC has a global and +-- per-user one and it lets you create arbitrary other package databases. We do +-- not yet fully support this latter feature. + +{- All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.Simple.Compiler ( + -- * Haskell implementations + module Distribution.Compiler, + Compiler(..), + showCompilerId, compilerFlavor, compilerVersion, + + -- * Support for package databases + PackageDB(..), + PackageDBStack, + registrationPackageDB, + + -- * Support for optimisation levels + OptimisationLevel(..), + flagToOptimisationLevel, + + -- * Support for language extensions + Flag, + languageToFlags, + unsupportedLanguages, + extensionsToFlags, + unsupportedExtensions + ) where + +import Distribution.Compiler +import Distribution.Version (Version(..)) +import Distribution.Text (display) +import Language.Haskell.Extension (Language(Haskell98), Extension) + +import Data.List (nub) +import Data.Maybe (catMaybes, isNothing) + +data Compiler = Compiler { + compilerId :: CompilerId, + compilerLanguages :: [(Language, Flag)], + compilerExtensions :: [(Extension, Flag)] + } + deriving (Show, Read) + +showCompilerId :: Compiler -> String +showCompilerId = display . compilerId + +compilerFlavor :: Compiler -> CompilerFlavor +compilerFlavor = (\(CompilerId f _) -> f) . compilerId + +compilerVersion :: Compiler -> Version +compilerVersion = (\(CompilerId _ v) -> v) . compilerId + +-- ------------------------------------------------------------ +-- * Package databases +-- ------------------------------------------------------------ + +-- |Some compilers have a notion of a database of available packages. +-- For some there is just one global db of packages, other compilers +-- support a per-user or an arbitrary db specified at some location in +-- the file system. This can be used to build isloated environments of +-- packages, for example to build a collection of related packages +-- without installing them globally. +-- +data PackageDB = GlobalPackageDB + | UserPackageDB + | SpecificPackageDB FilePath + deriving (Eq, Ord, Show, Read) + +-- | We typically get packages from several databases, and stack them +-- together. This type lets us be explicit about that stacking. For example +-- typical stacks include: +-- +-- > [GlobalPackageDB] +-- > [GlobalPackageDB, UserPackageDB] +-- > [GlobalPackageDB, SpecificPackageDB "package.conf.inplace"] +-- +-- Note that the 'GlobalPackageDB' is invariably at the bottom since it +-- contains the rts, base and other special compiler-specific packages. +-- +-- We are not restricted to using just the above combinations. In particular +-- we can use several custom package dbs and the user package db together. +-- +-- When it comes to writing, the top most (last) package is used. +-- +type PackageDBStack = [PackageDB] + +-- | Return the package that we should register into. This is the package db at +-- the top of the stack. +-- +registrationPackageDB :: PackageDBStack -> PackageDB +registrationPackageDB [] = error "internal error: empty package db set" +registrationPackageDB dbs = last dbs + +-- ------------------------------------------------------------ +-- * Optimisation levels +-- ------------------------------------------------------------ + +-- | Some compilers support optimising. Some have different levels. +-- For compliers that do not the level is just capped to the level +-- they do support. +-- +data OptimisationLevel = NoOptimisation + | NormalOptimisation + | MaximumOptimisation + deriving (Eq, Show, Read, Enum, Bounded) + +flagToOptimisationLevel :: Maybe String -> OptimisationLevel +flagToOptimisationLevel Nothing = NormalOptimisation +flagToOptimisationLevel (Just s) = case reads s of + [(i, "")] + | i >= fromEnum (minBound :: OptimisationLevel) + && i <= fromEnum (maxBound :: OptimisationLevel) + -> toEnum i + | otherwise -> error $ "Bad optimisation level: " ++ show i + ++ ". Valid values are 0..2" + _ -> error $ "Can't parse optimisation level " ++ s + +-- ------------------------------------------------------------ +-- * Languages and Extensions +-- ------------------------------------------------------------ + +unsupportedLanguages :: Compiler -> [Language] -> [Language] +unsupportedLanguages comp langs = + [ lang | lang <- langs + , isNothing (languageToFlag comp lang) ] + +languageToFlags :: Compiler -> Maybe Language -> [Flag] +languageToFlags comp = filter (not . null) + . catMaybes . map (languageToFlag comp) + . maybe [Haskell98] (\x->[x]) + +languageToFlag :: Compiler -> Language -> Maybe Flag +languageToFlag comp ext = lookup ext (compilerLanguages comp) + + +-- |For the given compiler, return the extensions it does not support. +unsupportedExtensions :: Compiler -> [Extension] -> [Extension] +unsupportedExtensions comp exts = + [ ext | ext <- exts + , isNothing (extensionToFlag comp ext) ] + +type Flag = String + +-- |For the given compiler, return the flags for the supported extensions. +extensionsToFlags :: Compiler -> [Extension] -> [Flag] +extensionsToFlags comp = nub . filter (not . null) + . catMaybes . map (extensionToFlag comp) + +extensionToFlag :: Compiler -> Extension -> Maybe Flag +extensionToFlag comp ext = lookup ext (compilerExtensions comp) diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/Configure.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/Configure.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/Configure.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/Configure.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,1036 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Configure +-- Copyright : Isaac Jones 2003-2005 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This deals with the /configure/ phase. It provides the 'configure' action +-- which is given the package description and configure flags. It then tries +-- to: configure the compiler; resolves any conditionals in the package +-- description; resolve the package dependencies; check if all the extensions +-- used by this package are supported by the compiler; check that all the build +-- tools are available (including version checks if appropriate); checks for +-- any required @pkg-config@ packages (updating the 'BuildInfo' with the +-- results) +-- +-- Then based on all this it saves the info in the 'LocalBuildInfo' and writes +-- it out to the @dist\/setup-config@ file. It also displays various details to +-- the user, the amount of information displayed depending on the verbosity +-- level. + +{- All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.Simple.Configure (configure, + writePersistBuildConfig, + getPersistBuildConfig, + checkPersistBuildConfigOutdated, + maybeGetPersistBuildConfig, + localBuildInfoFile, + getInstalledPackages, + configCompiler, configCompilerAux, + ccLdOptionsBuildInfo, + tryGetConfigStateFile, + checkForeignDeps, + ) + where + +import Distribution.Simple.Compiler + ( CompilerFlavor(..), Compiler(compilerId), compilerFlavor, compilerVersion + , showCompilerId, unsupportedLanguages, unsupportedExtensions + , PackageDB(..), PackageDBStack ) +import Distribution.Package + ( PackageName(PackageName), PackageIdentifier(..), PackageId + , packageName, packageVersion, Package(..) + , Dependency(Dependency), simplifyDependency + , InstalledPackageId(..) ) +import Distribution.InstalledPackageInfo as Installed + ( InstalledPackageInfo, InstalledPackageInfo_(..) + , emptyInstalledPackageInfo ) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.PackageIndex (PackageIndex) +import Distribution.PackageDescription as PD + ( PackageDescription(..), specVersion, GenericPackageDescription(..) + , Library(..), hasLibs, Executable(..), BuildInfo(..), allExtensions + , HookedBuildInfo, updatePackageDescription, allBuildInfo + , FlagName(..), TestSuite(..) ) +import Distribution.PackageDescription.Configuration + ( finalizePackageDescription, mapTreeData ) +import Distribution.PackageDescription.Check + ( PackageCheck(..), checkPackage, checkPackageFiles ) +import Distribution.Simple.Hpc ( enableCoverage ) +import Distribution.Simple.Program + ( Program(..), ProgramLocation(..), ConfiguredProgram(..) + , ProgramConfiguration, defaultProgramConfiguration + , configureAllKnownPrograms, knownPrograms, lookupKnownProgram, addKnownProgram + , userSpecifyArgss, userSpecifyPaths + , requireProgram, requireProgramVersion + , pkgConfigProgram, gccProgram, rawSystemProgramStdoutConf ) +import Distribution.Simple.Setup + ( ConfigFlags(..), CopyDest(..), fromFlag, fromFlagOrDefault, flagToMaybe ) +import Distribution.Simple.InstallDirs + ( InstallDirs(..), defaultInstallDirs, combineInstallDirs ) +import Distribution.Simple.LocalBuildInfo + ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) + , absoluteInstallDirs, prefixRelativeInstallDirs, inplacePackageId + , allComponentsBy, Component(..), foldComponent, ComponentName(..) ) +import Distribution.Simple.BuildPaths + ( autogenModulesDir ) +import Distribution.Simple.Utils + ( die, warn, info, setupMessage, createDirectoryIfMissingVerbose + , intercalate, cabalVersion + , withFileContents, writeFileAtomic + , withTempFile ) +import Distribution.System + ( OS(..), buildOS, buildPlatform ) +import Distribution.Version + ( Version(..), anyVersion, orLaterVersion, withinRange, isAnyVersion ) +import Distribution.Verbosity + ( Verbosity, lessVerbose ) + +import qualified Distribution.Simple.GHC as GHC +import qualified Distribution.Simple.JHC as JHC +import qualified Distribution.Simple.LHC as LHC +import qualified Distribution.Simple.NHC as NHC +import qualified Distribution.Simple.Hugs as Hugs +import qualified Distribution.Simple.UHC as UHC + +import Control.Monad + ( when, unless, foldM, filterM, forM ) +import Data.List + ( nub, partition, isPrefixOf, inits, find ) +import Data.Maybe + ( isNothing, catMaybes, mapMaybe ) +import Data.Monoid + ( Monoid(..) ) +import Data.Graph + ( SCC(..), graphFromEdges, transposeG, vertices, stronglyConnCompR ) +import System.Directory + ( doesFileExist, getModificationTime, createDirectoryIfMissing, getTemporaryDirectory ) +import System.Exit + ( ExitCode(..), exitWith ) +import System.FilePath + ( (), isAbsolute ) +import qualified System.Info + ( compilerName, compilerVersion ) +import System.IO + ( hPutStrLn, stderr, hClose ) +import Distribution.Text + ( Text(disp), display, simpleParse ) +import Text.PrettyPrint.HughesPJ + ( comma, punctuate, render, nest, sep ) +import Distribution.Compat.Exception ( catchExit, catchIO ) + +import Prelude hiding (catch) + +tryGetConfigStateFile :: (Read a) => FilePath -> IO (Either String a) +tryGetConfigStateFile filename = do + exists <- doesFileExist filename + if not exists + then return (Left missing) + else withFileContents filename $ \str -> + case lines str of + [headder, rest] -> case checkHeader headder of + Just msg -> return (Left msg) + Nothing -> case reads rest of + [(bi,_)] -> return (Right bi) + _ -> return (Left cantParse) + _ -> return (Left cantParse) + where + checkHeader :: String -> Maybe String + checkHeader header = case parseHeader header of + Just (cabalId, compId) + | cabalId + == currentCabalId -> Nothing + | otherwise -> Just (badVersion cabalId compId) + Nothing -> Just cantParse + + missing = "Run the 'configure' command first." + cantParse = "Saved package config file seems to be corrupt. " + ++ "Try re-running the 'configure' command." + badVersion cabalId compId + = "You need to re-run the 'configure' command. " + ++ "The version of Cabal being used has changed (was " + ++ display cabalId ++ ", now " + ++ display currentCabalId ++ ")." + ++ badcompiler compId + badcompiler compId | compId == currentCompilerId = "" + | otherwise + = " Additionally the compiler is different (was " + ++ display compId ++ ", now " + ++ display currentCompilerId + ++ ") which is probably the cause of the problem." + +-- internal function +tryGetPersistBuildConfig :: FilePath -> IO (Either String LocalBuildInfo) +tryGetPersistBuildConfig distPref + = tryGetConfigStateFile (localBuildInfoFile distPref) + +-- |Read the 'localBuildInfoFile'. Error if it doesn't exist. Also +-- fail if the file containing LocalBuildInfo is older than the .cabal +-- file, indicating that a re-configure is required. +getPersistBuildConfig :: FilePath -> IO LocalBuildInfo +getPersistBuildConfig distPref = do + lbi <- tryGetPersistBuildConfig distPref + either die return lbi + +-- |Try to read the 'localBuildInfoFile'. +maybeGetPersistBuildConfig :: FilePath -> IO (Maybe LocalBuildInfo) +maybeGetPersistBuildConfig distPref = do + lbi <- tryGetPersistBuildConfig distPref + return $ either (const Nothing) Just lbi + +-- |After running configure, output the 'LocalBuildInfo' to the +-- 'localBuildInfoFile'. +writePersistBuildConfig :: FilePath -> LocalBuildInfo -> IO () +writePersistBuildConfig distPref lbi = do + createDirectoryIfMissing False distPref + writeFileAtomic (localBuildInfoFile distPref) + (showHeader pkgid ++ '\n' : show lbi) + where + pkgid = packageId (localPkgDescr lbi) + +showHeader :: PackageIdentifier -> String +showHeader pkgid = + "Saved package config for " ++ display pkgid + ++ " written by " ++ display currentCabalId + ++ " using " ++ display currentCompilerId + where + +currentCabalId :: PackageIdentifier +currentCabalId = PackageIdentifier (PackageName "Cabal") cabalVersion + +currentCompilerId :: PackageIdentifier +currentCompilerId = PackageIdentifier (PackageName System.Info.compilerName) + System.Info.compilerVersion + +parseHeader :: String -> Maybe (PackageIdentifier, PackageIdentifier) +parseHeader header = case words header of + ["Saved", "package", "config", "for", pkgid, + "written", "by", cabalid, "using", compilerid] + -> case (simpleParse pkgid :: Maybe PackageIdentifier, + simpleParse cabalid, + simpleParse compilerid) of + (Just _, + Just cabalid', + Just compilerid') -> Just (cabalid', compilerid') + _ -> Nothing + _ -> Nothing + +-- |Check that localBuildInfoFile is up-to-date with respect to the +-- .cabal file. +checkPersistBuildConfigOutdated :: FilePath -> FilePath -> IO Bool +checkPersistBuildConfigOutdated distPref pkg_descr_file = do + t0 <- getModificationTime pkg_descr_file + t1 <- getModificationTime $ localBuildInfoFile distPref + return (t0 > t1) + +-- |@dist\/setup-config@ +localBuildInfoFile :: FilePath -> FilePath +localBuildInfoFile distPref = distPref "setup-config" + +-- ----------------------------------------------------------------------------- +-- * Configuration +-- ----------------------------------------------------------------------------- + +-- |Perform the \"@.\/setup configure@\" action. +-- Returns the @.setup-config@ file. +configure :: (GenericPackageDescription, HookedBuildInfo) + -> ConfigFlags -> IO LocalBuildInfo +configure (pkg_descr0, pbi) cfg + = do let distPref = fromFlag (configDistPref cfg) + buildDir' = distPref "build" + verbosity = fromFlag (configVerbosity cfg) + + setupMessage verbosity "Configuring" (packageId pkg_descr0) + + createDirectoryIfMissingVerbose (lessVerbose verbosity) True distPref + + let programsConfig = userSpecifyArgss (configProgramArgs cfg) + . userSpecifyPaths (configProgramPaths cfg) + $ configPrograms cfg + userInstall = fromFlag (configUserInstall cfg) + packageDbs = implicitPackageDbStack userInstall + (flagToMaybe $ configPackageDB cfg) + + -- detect compiler + (comp, programsConfig') <- configCompiler + (flagToMaybe $ configHcFlavor cfg) + (flagToMaybe $ configHcPath cfg) (flagToMaybe $ configHcPkg cfg) + programsConfig (lessVerbose verbosity) + let version = compilerVersion comp + flavor = compilerFlavor comp + + -- Create a PackageIndex that makes *any libraries that might be* + -- defined internally to this package look like installed packages, in + -- case an executable should refer to any of them as dependencies. + -- + -- It must be *any libraries that might be* defined rather than the + -- actual definitions, because these depend on conditionals in the .cabal + -- file, and we haven't resolved them yet. finalizePackageDescription + -- does the resolution of conditionals, and it takes internalPackageSet + -- as part of its input. + -- + -- Currently a package can define no more than one library (which has + -- the same name as the package) but we could extend this later. + -- If we later allowed private internal libraries, then here we would + -- need to pre-scan the conditional data to make a list of all private + -- libraries that could possibly be defined by the .cabal file. + let pid = packageId pkg_descr0 + internalPackage = emptyInstalledPackageInfo { + --TODO: should use a per-compiler method to map the source + -- package ID into an installed package id we can use + -- for the internal package set. The open-codes use of + -- InstalledPackageId . display here is a hack. + Installed.installedPackageId = InstalledPackageId $ display $ pid, + Installed.sourcePackageId = pid + } + internalPackageSet = PackageIndex.fromList [internalPackage] + installedPackageSet <- getInstalledPackages (lessVerbose verbosity) comp + packageDbs programsConfig' + + let -- Constraint test function for the solver + dependencySatisfiable = + not . null . PackageIndex.lookupDependency pkgs' + where + pkgs' = PackageIndex.insert internalPackage installedPackageSet + enableTest t = t { testEnabled = fromFlag (configTests cfg) } + flaggedTests = map (\(n, t) -> (n, mapTreeData enableTest t)) + (condTestSuites pkg_descr0) + pkg_descr0'' = pkg_descr0 { condTestSuites = flaggedTests } + + (pkg_descr0', flags) <- + case finalizePackageDescription + (configConfigurationsFlags cfg) + dependencySatisfiable + Distribution.System.buildPlatform + (compilerId comp) + (configConstraints cfg) + pkg_descr0'' + of Right r -> return r + Left missing -> + die $ "At least the following dependencies are missing:\n" + ++ (render . nest 4 . sep . punctuate comma + . map (disp . simplifyDependency) + $ missing) + + -- add extra include/lib dirs as specified in cfg + -- we do it here so that those get checked too + let pkg_descr = + enableCoverage (fromFlag (configLibCoverage cfg)) distPref + $ addExtraIncludeLibDirs pkg_descr0' + + when (not (null flags)) $ + info verbosity $ "Flags chosen: " + ++ intercalate ", " [ name ++ "=" ++ display value + | (FlagName name, value) <- flags ] + + checkPackageProblems verbosity pkg_descr0 + (updatePackageDescription pbi pkg_descr) + + let selectDependencies = + (\xs -> ([ x | Left x <- xs ], [ x | Right x <- xs ])) + . map (selectDependency internalPackageSet installedPackageSet) + + (failedDeps, allPkgDeps) = selectDependencies (buildDepends pkg_descr) + + internalPkgDeps = [ pkgid | InternalDependency _ pkgid <- allPkgDeps ] + externalPkgDeps = [ pkg | ExternalDependency _ pkg <- allPkgDeps ] + + when (not (null internalPkgDeps) && not (newPackageDepsBehaviour pkg_descr)) $ + die $ "The field 'build-depends: " + ++ intercalate ", " (map (display . packageName) internalPkgDeps) + ++ "' refers to a library which is defined within the same " + ++ "package. To use this feature the package must specify at " + ++ "least 'cabal-version: >= 1.8'." + + reportFailedDependencies failedDeps + reportSelectedDependencies verbosity allPkgDeps + + packageDependsIndex <- + case PackageIndex.dependencyClosure installedPackageSet + (map Installed.installedPackageId externalPkgDeps) of + Left packageDependsIndex -> return packageDependsIndex + Right broken -> + die $ "The following installed packages are broken because other" + ++ " packages they depend on are missing. These broken " + ++ "packages must be rebuilt before they can be used.\n" + ++ unlines [ "package " + ++ display (packageId pkg) + ++ " is broken due to missing package " + ++ intercalate ", " (map display deps) + | (pkg, deps) <- broken ] + + let pseudoTopPkg = emptyInstalledPackageInfo { + Installed.installedPackageId = InstalledPackageId (display (packageId pkg_descr)), + Installed.sourcePackageId = packageId pkg_descr, + Installed.depends = map Installed.installedPackageId externalPkgDeps + } + case PackageIndex.dependencyInconsistencies + . PackageIndex.insert pseudoTopPkg + $ packageDependsIndex of + [] -> return () + inconsistencies -> + warn verbosity $ + "This package indirectly depends on multiple versions of the same " + ++ "package. This is highly likely to cause a compile failure.\n" + ++ unlines [ "package " ++ display pkg ++ " requires " + ++ display (PackageIdentifier name ver) + | (name, uses) <- inconsistencies + , (pkg, ver) <- uses ] + + -- installation directories + defaultDirs <- defaultInstallDirs flavor userInstall (hasLibs pkg_descr) + let installDirs = combineInstallDirs fromFlagOrDefault + defaultDirs (configInstallDirs cfg) + + -- check languages and extensions + let langlist = nub $ catMaybes $ map defaultLanguage (allBuildInfo pkg_descr) + let langs = unsupportedLanguages comp langlist + when (not (null langs)) $ + die $ "The package " ++ display (packageId pkg_descr0) + ++ " requires the following languages which are not " + ++ "supported by " ++ display (compilerId comp) ++ ": " + ++ intercalate ", " (map display langs) + let extlist = nub $ concatMap allExtensions (allBuildInfo pkg_descr) + let exts = unsupportedExtensions comp extlist + when (not (null exts)) $ + die $ "The package " ++ display (packageId pkg_descr0) + ++ " requires the following language extensions which are not " + ++ "supported by " ++ display (compilerId comp) ++ ": " + ++ intercalate ", " (map display exts) + + -- configured known/required programs & build tools + let requiredBuildTools = concatMap buildTools (allBuildInfo pkg_descr) + + -- add all exes built by this package ("internal exes") to the program + -- conf; this makes the namespace of build-tools include intrapackage + -- references to executables + let programsConfig'' = foldr (addInternalExe buildDir') programsConfig' + (executables pkg_descr) + + programsConfig''' <- + configureAllKnownPrograms (lessVerbose verbosity) programsConfig'' + >>= configureRequiredPrograms verbosity requiredBuildTools + + (pkg_descr', programsConfig'''') <- + configurePkgconfigPackages verbosity pkg_descr programsConfig''' + + split_objs <- + if not (fromFlag $ configSplitObjs cfg) + then return False + else case flavor of + GHC | version >= Version [6,5] [] -> return True + _ -> do warn verbosity + ("this compiler does not support " ++ + "--enable-split-objs; ignoring") + return False + + -- The allPkgDeps contains all the package deps for the whole package + -- but we need to select the subset for this specific component. + -- we just take the subset for the package names this component + -- needs. Note, this only works because we cannot yet depend on two + -- versions of the same package. + let configLib lib = configComponent (libBuildInfo lib) + configExe exe = (exeName exe, configComponent (buildInfo exe)) + configTest test = (testName test, + configComponent(testBuildInfo test)) + configComponent bi = ComponentLocalBuildInfo { + componentPackageDeps = + if newPackageDepsBehaviour pkg_descr' + then [ (installedPackageId pkg, packageId pkg) + | pkg <- selectSubset bi externalPkgDeps ] + ++ [ (inplacePackageId pkgid, pkgid) + | pkgid <- selectSubset bi internalPkgDeps ] + else [ (installedPackageId pkg, packageId pkg) + | pkg <- externalPkgDeps ] + } + selectSubset :: Package pkg => BuildInfo -> [pkg] -> [pkg] + selectSubset bi pkgs = + [ pkg | pkg <- pkgs, packageName pkg `elem` names ] + where + names = [ name | Dependency name _ <- targetBuildDepends bi ] + + -- Obtains the intrapackage dependencies for the given component + let ipDeps component = + mapMaybe exeDepToComp (buildTools bi) + ++ mapMaybe libDepToComp (targetBuildDepends bi) + where + bi = foldComponent libBuildInfo buildInfo testBuildInfo component + exeDepToComp (Dependency (PackageName name) _) = + CExe `fmap` find ((==) name . exeName) + (executables pkg_descr') + libDepToComp (Dependency pn _) + | pn `elem` map packageName internalPkgDeps = + CLib `fmap` library pkg_descr' + libDepToComp _ = Nothing + + let sccs = (stronglyConnCompR . map lkup . vertices . transposeG) g + where (g, lkup, _) = graphFromEdges + $ allComponentsBy pkg_descr' + $ \c -> (c, key c, map key (ipDeps c)) + key = foldComponent (const "library") exeName testName + + -- check for cycles in the dependency graph + buildOrder <- forM sccs $ \scc -> case scc of + AcyclicSCC (c,_,_) -> return (foldComponent (const CLibName) + (CExeName . exeName) + (CTestName . testName) + c) + CyclicSCC vs -> + die $ "Found cycle in intrapackage dependency graph:\n " + ++ intercalate " depends on " + (map (\(_,k,_) -> "'" ++ k ++ "'") (vs ++ [head vs])) + + let lbi = LocalBuildInfo { + configFlags = cfg, + extraConfigArgs = [], -- Currently configure does not + -- take extra args, but if it + -- did they would go here. + installDirTemplates = installDirs, + compiler = comp, + buildDir = buildDir', + scratchDir = fromFlagOrDefault + (distPref "scratch") + (configScratchDir cfg), + libraryConfig = configLib `fmap` library pkg_descr', + executableConfigs = configExe `fmap` executables pkg_descr', + testSuiteConfigs = configTest `fmap` testSuites pkg_descr', + compBuildOrder = buildOrder, + installedPkgs = packageDependsIndex, + pkgDescrFile = Nothing, + localPkgDescr = pkg_descr', + withPrograms = programsConfig'''', + withVanillaLib = fromFlag $ configVanillaLib cfg, + withProfLib = fromFlag $ configProfLib cfg, + withSharedLib = fromFlag $ configSharedLib cfg, + withDynExe = fromFlag $ configDynExe cfg, + withProfExe = fromFlag $ configProfExe cfg, + withOptimization = fromFlag $ configOptimization cfg, + withGHCiLib = fromFlag $ configGHCiLib cfg, + splitObjs = split_objs, + stripExes = fromFlag $ configStripExes cfg, + withPackageDB = packageDbs, + progPrefix = fromFlag $ configProgPrefix cfg, + progSuffix = fromFlag $ configProgSuffix cfg + } + + let dirs = absoluteInstallDirs pkg_descr lbi NoCopyDest + relative = prefixRelativeInstallDirs (packageId pkg_descr) lbi + + unless (isAbsolute (prefix dirs)) $ die $ + "expected an absolute directory name for --prefix: " ++ prefix dirs + + info verbosity $ "Using " ++ display currentCabalId + ++ " compiled by " ++ display currentCompilerId + info verbosity $ "Using compiler: " ++ showCompilerId comp + info verbosity $ "Using install prefix: " ++ prefix dirs + + let dirinfo name dir isPrefixRelative = + info verbosity $ name ++ " installed in: " ++ dir ++ relNote + where relNote = case buildOS of + Windows | not (hasLibs pkg_descr) + && isNothing isPrefixRelative + -> " (fixed location)" + _ -> "" + + dirinfo "Binaries" (bindir dirs) (bindir relative) + dirinfo "Libraries" (libdir dirs) (libdir relative) + dirinfo "Private binaries" (libexecdir dirs) (libexecdir relative) + dirinfo "Data files" (datadir dirs) (datadir relative) + dirinfo "Documentation" (docdir dirs) (docdir relative) + + sequence_ [ reportProgram verbosity prog configuredProg + | (prog, configuredProg) <- knownPrograms programsConfig'''' ] + + return lbi + + where + addInternalExe bd exe = + let nm = exeName exe in + addKnownProgram Program { + programName = nm, + programFindLocation = \_ -> return $ Just $ bd nm nm, + programFindVersion = \_ _ -> return Nothing, + programPostConf = \_ _ -> return [] + } + + addExtraIncludeLibDirs pkg_descr = + let extraBi = mempty { extraLibDirs = configExtraLibDirs cfg + , PD.includeDirs = configExtraIncludeDirs cfg} + modifyLib l = l{ libBuildInfo = libBuildInfo l `mappend` extraBi } + modifyExecutable e = e{ buildInfo = buildInfo e `mappend` extraBi} + in pkg_descr{ library = modifyLib `fmap` library pkg_descr + , executables = modifyExecutable `map` executables pkg_descr} + +-- ----------------------------------------------------------------------------- +-- Configuring package dependencies + +reportProgram :: Verbosity -> Program -> Maybe ConfiguredProgram -> IO () +reportProgram verbosity prog Nothing + = info verbosity $ "No " ++ programName prog ++ " found" +reportProgram verbosity prog (Just configuredProg) + = info verbosity $ "Using " ++ programName prog ++ version ++ location + where location = case programLocation configuredProg of + FoundOnSystem p -> " found on system at: " ++ p + UserSpecified p -> " given by user at: " ++ p + version = case programVersion configuredProg of + Nothing -> "" + Just v -> " version " ++ display v + +hackageUrl :: String +hackageUrl = "http://hackage.haskell.org/package/" + +data ResolvedDependency = ExternalDependency Dependency InstalledPackageInfo + | InternalDependency Dependency PackageId -- should be a lib name + +data FailedDependency = DependencyNotExists PackageName + | DependencyNoVersion Dependency + +-- | Test for a package dependency and record the version we have installed. +selectDependency :: PackageIndex -- ^ Internally defined packages + -> PackageIndex -- ^ Installed packages + -> Dependency + -> Either FailedDependency ResolvedDependency +selectDependency internalIndex installedIndex + dep@(Dependency pkgname vr) = + -- If the dependency specification matches anything in the internal package + -- index, then we prefer that match to anything in the second. + -- For example: + -- + -- Name: MyLibrary + -- Version: 0.1 + -- Library + -- .. + -- Executable my-exec + -- build-depends: MyLibrary + -- + -- We want "build-depends: MyLibrary" always to match the internal library + -- even if there is a newer installed library "MyLibrary-0.2". + -- However, "build-depends: MyLibrary >= 0.2" should match the installed one. + case PackageIndex.lookupPackageName internalIndex pkgname of + [(_,[pkg])] | packageVersion pkg `withinRange` vr + -> Right $ InternalDependency dep (packageId pkg) + + _ -> case PackageIndex.lookupDependency installedIndex dep of + [] -> Left $ DependencyNotExists pkgname + pkgs -> Right $ ExternalDependency dep $ + -- by default we just pick the latest + case last pkgs of + (_ver, instances) -> head instances -- the first preference + +reportSelectedDependencies :: Verbosity + -> [ResolvedDependency] -> IO () +reportSelectedDependencies verbosity deps = + info verbosity $ unlines + [ "Dependency " ++ display (simplifyDependency dep) + ++ ": using " ++ display pkgid + | resolved <- deps + , let (dep, pkgid) = case resolved of + ExternalDependency dep' pkg' -> (dep', packageId pkg') + InternalDependency dep' pkgid' -> (dep', pkgid') ] + +reportFailedDependencies :: [FailedDependency] -> IO () +reportFailedDependencies [] = return () +reportFailedDependencies failed = + die (intercalate "\n\n" (map reportFailedDependency failed)) + + where + reportFailedDependency (DependencyNotExists pkgname) = + "there is no version of " ++ display pkgname ++ " installed.\n" + ++ "Perhaps you need to download and install it from\n" + ++ hackageUrl ++ display pkgname ++ "?" + + reportFailedDependency (DependencyNoVersion dep) = + "cannot satisfy dependency " ++ display (simplifyDependency dep) ++ "\n" + +getInstalledPackages :: Verbosity -> Compiler + -> PackageDBStack -> ProgramConfiguration + -> IO PackageIndex +getInstalledPackages verbosity comp packageDBs progconf = do + info verbosity "Reading installed packages..." + case compilerFlavor comp of + GHC -> GHC.getInstalledPackages verbosity packageDBs progconf + Hugs->Hugs.getInstalledPackages verbosity packageDBs progconf + JHC -> JHC.getInstalledPackages verbosity packageDBs progconf + LHC -> LHC.getInstalledPackages verbosity packageDBs progconf + NHC -> NHC.getInstalledPackages verbosity packageDBs progconf + UHC -> UHC.getInstalledPackages verbosity comp packageDBs progconf + flv -> die $ "don't know how to find the installed packages for " + ++ display flv + +-- | Currently the user interface specifies the package dbs to use with just a +-- single valued option, a 'PackageDB'. However internally we represent the +-- stack of 'PackageDB's explictly as a list. This function converts encodes +-- the package db stack implicit in a single packagedb. +-- +implicitPackageDbStack :: Bool -> Maybe PackageDB -> PackageDBStack +implicitPackageDbStack userInstall maybePackageDB + | userInstall = GlobalPackageDB : UserPackageDB : extra + | otherwise = GlobalPackageDB : extra + where + extra = case maybePackageDB of + Just (SpecificPackageDB db) -> [SpecificPackageDB db] + _ -> [] + +newPackageDepsBehaviourMinVersion :: Version +newPackageDepsBehaviourMinVersion = Version { versionBranch = [1,7,1], versionTags = [] } + +-- In older cabal versions, there was only one set of package dependencies for +-- the whole package. In this version, we can have separate dependencies per +-- target, but we only enable this behaviour if the minimum cabal version +-- specified is >= a certain minimum. Otherwise, for compatibility we use the +-- old behaviour. +newPackageDepsBehaviour :: PackageDescription -> Bool +newPackageDepsBehaviour pkg = + specVersion pkg >= newPackageDepsBehaviourMinVersion + +-- ----------------------------------------------------------------------------- +-- Configuring program dependencies + +configureRequiredPrograms :: Verbosity -> [Dependency] -> ProgramConfiguration -> IO ProgramConfiguration +configureRequiredPrograms verbosity deps conf = + foldM (configureRequiredProgram verbosity) conf deps + +configureRequiredProgram :: Verbosity -> ProgramConfiguration -> Dependency -> IO ProgramConfiguration +configureRequiredProgram verbosity conf (Dependency (PackageName progName) verRange) = + case lookupKnownProgram progName conf of + Nothing -> die ("Unknown build tool " ++ progName) + Just prog + -- requireProgramVersion always requires the program have a version + -- but if the user says "build-depends: foo" ie no version constraint + -- then we should not fail if we cannot discover the program version. + | verRange == anyVersion -> do + (_, conf') <- requireProgram verbosity prog conf + return conf' + | otherwise -> do + (_, _, conf') <- requireProgramVersion verbosity prog verRange conf + return conf' + +-- ----------------------------------------------------------------------------- +-- Configuring pkg-config package dependencies + +configurePkgconfigPackages :: Verbosity -> PackageDescription + -> ProgramConfiguration + -> IO (PackageDescription, ProgramConfiguration) +configurePkgconfigPackages verbosity pkg_descr conf + | null allpkgs = return (pkg_descr, conf) + | otherwise = do + (_, _, conf') <- requireProgramVersion + (lessVerbose verbosity) pkgConfigProgram + (orLaterVersion $ Version [0,9,0] []) conf + mapM_ requirePkg allpkgs + lib' <- updateLibrary (library pkg_descr) + exes' <- mapM updateExecutable (executables pkg_descr) + let pkg_descr' = pkg_descr { library = lib', executables = exes' } + return (pkg_descr', conf') + + where + allpkgs = concatMap pkgconfigDepends (allBuildInfo pkg_descr) + pkgconfig = rawSystemProgramStdoutConf (lessVerbose verbosity) + pkgConfigProgram conf + + requirePkg dep@(Dependency (PackageName pkg) range) = do + version <- pkgconfig ["--modversion", pkg] + `catchIO` (\_ -> die notFound) + `catchExit` (\_ -> die notFound) + case simpleParse version of + Nothing -> die "parsing output of pkg-config --modversion failed" + Just v | not (withinRange v range) -> die (badVersion v) + | otherwise -> info verbosity (depSatisfied v) + where + notFound = "The pkg-config package " ++ pkg ++ versionRequirement + ++ " is required but it could not be found." + badVersion v = "The pkg-config package " ++ pkg ++ versionRequirement + ++ " is required but the version installed on the" + ++ " system is version " ++ display v + depSatisfied v = "Dependency " ++ display dep + ++ ": using version " ++ display v + + versionRequirement + | isAnyVersion range = "" + | otherwise = " version " ++ display range + + updateLibrary Nothing = return Nothing + updateLibrary (Just lib) = do + bi <- pkgconfigBuildInfo (pkgconfigDepends (libBuildInfo lib)) + return $ Just lib { libBuildInfo = libBuildInfo lib `mappend` bi } + + updateExecutable exe = do + bi <- pkgconfigBuildInfo (pkgconfigDepends (buildInfo exe)) + return exe { buildInfo = buildInfo exe `mappend` bi } + + pkgconfigBuildInfo :: [Dependency] -> IO BuildInfo + pkgconfigBuildInfo [] = return mempty + pkgconfigBuildInfo pkgdeps = do + let pkgs = nub [ display pkg | Dependency pkg _ <- pkgdeps ] + ccflags <- pkgconfig ("--cflags" : pkgs) + ldflags <- pkgconfig ("--libs" : pkgs) + return (ccLdOptionsBuildInfo (words ccflags) (words ldflags)) + +-- | Makes a 'BuildInfo' from C compiler and linker flags. +-- +-- This can be used with the output from configuration programs like pkg-config +-- and similar package-specific programs like mysql-config, freealut-config etc. +-- For example: +-- +-- > ccflags <- rawSystemProgramStdoutConf verbosity prog conf ["--cflags"] +-- > ldflags <- rawSystemProgramStdoutConf verbosity prog conf ["--libs"] +-- > return (ccldOptionsBuildInfo (words ccflags) (words ldflags)) +-- +ccLdOptionsBuildInfo :: [String] -> [String] -> BuildInfo +ccLdOptionsBuildInfo cflags ldflags = + let (includeDirs', cflags') = partition ("-I" `isPrefixOf`) cflags + (extraLibs', ldflags') = partition ("-l" `isPrefixOf`) ldflags + (extraLibDirs', ldflags'') = partition ("-L" `isPrefixOf`) ldflags' + in mempty { + PD.includeDirs = map (drop 2) includeDirs', + PD.extraLibs = map (drop 2) extraLibs', + PD.extraLibDirs = map (drop 2) extraLibDirs', + PD.ccOptions = cflags', + PD.ldOptions = ldflags'' + } + +-- ----------------------------------------------------------------------------- +-- Determining the compiler details + +configCompilerAux :: ConfigFlags -> IO (Compiler, ProgramConfiguration) +configCompilerAux cfg = configCompiler (flagToMaybe $ configHcFlavor cfg) + (flagToMaybe $ configHcPath cfg) + (flagToMaybe $ configHcPkg cfg) + programsConfig + (fromFlag (configVerbosity cfg)) + where + programsConfig = userSpecifyArgss (configProgramArgs cfg) + . userSpecifyPaths (configProgramPaths cfg) + $ defaultProgramConfiguration + +configCompiler :: Maybe CompilerFlavor -> Maybe FilePath -> Maybe FilePath + -> ProgramConfiguration -> Verbosity + -> IO (Compiler, ProgramConfiguration) +configCompiler Nothing _ _ _ _ = die "Unknown compiler" +configCompiler (Just hcFlavor) hcPath hcPkg conf verbosity = do + case hcFlavor of + GHC -> GHC.configure verbosity hcPath hcPkg conf + JHC -> JHC.configure verbosity hcPath hcPkg conf + LHC -> do (_,ghcConf) <- GHC.configure verbosity Nothing hcPkg conf + LHC.configure verbosity hcPath Nothing ghcConf + Hugs -> Hugs.configure verbosity hcPath hcPkg conf + NHC -> NHC.configure verbosity hcPath hcPkg conf + UHC -> UHC.configure verbosity hcPath hcPkg conf + _ -> die "Unknown compiler" + + +-- Try to build a test C program which includes every header and links every +-- lib. If that fails, try to narrow it down by preprocessing (only) and linking +-- with individual headers and libs. If none is the obvious culprit then give a +-- generic error message. +-- TODO: produce a log file from the compiler errors, if any. +checkForeignDeps :: PackageDescription -> LocalBuildInfo -> Verbosity -> IO () +checkForeignDeps pkg lbi verbosity = do + ifBuildsWith allHeaders (commonCcArgs ++ makeLdArgs allLibs) -- I'm feeling lucky + (return ()) + (do missingLibs <- findMissingLibs + missingHdr <- findOffendingHdr + explainErrors missingHdr missingLibs) + where + allHeaders = collectField PD.includes + allLibs = collectField PD.extraLibs + + ifBuildsWith headers args success failure = do + ok <- builds (makeProgram headers) args + if ok then success else failure + + findOffendingHdr = + ifBuildsWith allHeaders ccArgs + (return Nothing) + (go . tail . inits $ allHeaders) + where + go [] = return Nothing -- cannot happen + go (hdrs:hdrsInits) = + -- Try just preprocessing first + ifBuildsWith hdrs cppArgs + -- If that works, try compiling too + (ifBuildsWith hdrs ccArgs + (go hdrsInits) + (return . Just . Right . last $ hdrs)) + (return . Just . Left . last $ hdrs) + + cppArgs = "-E":commonCppArgs -- preprocess only + ccArgs = "-c":commonCcArgs -- don't try to link + + findMissingLibs = ifBuildsWith [] (makeLdArgs allLibs) + (return []) + (filterM (fmap not . libExists) allLibs) + + libExists lib = builds (makeProgram []) (makeLdArgs [lib]) + + commonCppArgs = hcDefines (compiler lbi) + ++ [ "-I" ++ autogenModulesDir lbi ] + ++ [ "-I" ++ dir | dir <- collectField PD.includeDirs ] + ++ ["-I."] + ++ collectField PD.cppOptions + ++ collectField PD.ccOptions + ++ [ "-I" ++ dir + | dep <- deps + , dir <- Installed.includeDirs dep ] + ++ [ opt + | dep <- deps + , opt <- Installed.ccOptions dep ] + + commonCcArgs = commonCppArgs + ++ collectField PD.ccOptions + ++ [ opt + | dep <- deps + , opt <- Installed.ccOptions dep ] + + commonLdArgs = [ "-L" ++ dir | dir <- collectField PD.extraLibDirs ] + ++ collectField PD.ldOptions + ++ [ "-L" ++ dir + | dep <- deps + , dir <- Installed.libraryDirs dep ] + --TODO: do we also need dependent packages' ld options? + makeLdArgs libs = [ "-l"++lib | lib <- libs ] ++ commonLdArgs + + makeProgram hdrs = unlines $ + [ "#include \"" ++ hdr ++ "\"" | hdr <- hdrs ] ++ + ["int main(int argc, char** argv) { return 0; }"] + + collectField f = concatMap f allBi + allBi = allBuildInfo pkg + deps = PackageIndex.topologicalOrder (installedPkgs lbi) + + builds program args = do + tempDir <- getTemporaryDirectory + withTempFile tempDir ".c" $ \cName cHnd -> + withTempFile tempDir "" $ \oNname oHnd -> do + hPutStrLn cHnd program + hClose cHnd + hClose oHnd + _ <- rawSystemProgramStdoutConf verbosity + gccProgram (withPrograms lbi) (cName:"-o":oNname:args) + return True + `catchIO` (\_ -> return False) + `catchExit` (\_ -> return False) + + explainErrors Nothing [] = return () -- should be impossible! + explainErrors hdr libs = die $ unlines $ + [ if plural + then "Missing dependencies on foreign libraries:" + else "Missing dependency on a foreign library:" + | missing ] + ++ case hdr of + Just (Left h) -> ["* Missing (or bad) header file: " ++ h ] + _ -> [] + ++ case libs of + [] -> [] + [lib] -> ["* Missing C library: " ++ lib] + _ -> ["* Missing C libraries: " ++ intercalate ", " libs] + ++ [if plural then messagePlural else messageSingular | missing] + ++ case hdr of + Just (Left _) -> [ headerCppMessage ] + Just (Right h) -> [ (if missing then "* " else "") + ++ "Bad header file: " ++ h + , headerCcMessage ] + _ -> [] + + where + plural = length libs >= 2 + -- Is there something missing? (as opposed to broken) + missing = not (null libs) + || case hdr of Just (Left _) -> True; _ -> False + + messageSingular = + "This problem can usually be solved by installing the system " + ++ "package that provides this library (you may need the " + ++ "\"-dev\" version). If the library is already installed " + ++ "but in a non-standard location then you can use the flags " + ++ "--extra-include-dirs= and --extra-lib-dirs= to specify " + ++ "where it is." + messagePlural = + "This problem can usually be solved by installing the system " + ++ "packages that provide these libraries (you may need the " + ++ "\"-dev\" versions). If the libraries are already installed " + ++ "but in a non-standard location then you can use the flags " + ++ "--extra-include-dirs= and --extra-lib-dirs= to specify " + ++ "where they are." + headerCppMessage = + "If the header file does exist, it may contain errors that " + ++ "are caught by the C compiler at the preprocessing stage. " + ++ "In this case you can re-run configure with the verbosity " + ++ "flag -v3 to see the error messages." + headerCcMessage = + "The header file contains a compile error. " + ++ "You can re-run configure with the verbosity flag " + ++ "-v3 to see the error messages from the C compiler." + + --FIXME: share this with the PreProcessor module + hcDefines :: Compiler -> [String] + hcDefines comp = + case compilerFlavor comp of + GHC -> ["-D__GLASGOW_HASKELL__=" ++ versionInt version] + JHC -> ["-D__JHC__=" ++ versionInt version] + NHC -> ["-D__NHC__=" ++ versionInt version] + Hugs -> ["-D__HUGS__"] + _ -> [] + where + version = compilerVersion comp + -- TODO: move this into the compiler abstraction + -- FIXME: this forces GHC's crazy 4.8.2 -> 408 convention on all + -- the other compilers. Check if that's really what they want. + versionInt :: Version -> String + versionInt (Version { versionBranch = [] }) = "1" + versionInt (Version { versionBranch = [n] }) = show n + versionInt (Version { versionBranch = n1:n2:_ }) + = -- 6.8.x -> 608 + -- 6.10.x -> 610 + let s1 = show n1 + s2 = show n2 + middle = case s2 of + _ : _ : _ -> "" + _ -> "0" + in s1 ++ middle ++ s2 + +-- | Output package check warnings and errors. Exit if any errors. +checkPackageProblems :: Verbosity + -> GenericPackageDescription + -> PackageDescription + -> IO () +checkPackageProblems verbosity gpkg pkg = do + ioChecks <- checkPackageFiles pkg "." + let pureChecks = checkPackage gpkg (Just pkg) + errors = [ e | PackageBuildImpossible e <- pureChecks ++ ioChecks ] + warnings = [ w | PackageBuildWarning w <- pureChecks ++ ioChecks ] + if null errors + then mapM_ (warn verbosity) warnings + else do mapM_ (hPutStrLn stderr . ("Error: " ++)) errors + exitWith (ExitFailure 1) diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/GHC/IPI641.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/GHC/IPI641.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/GHC/IPI641.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/GHC/IPI641.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,129 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.GHC.IPI641 +-- Copyright : (c) The University of Glasgow 2004 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- + +{- All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of the University nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.Simple.GHC.IPI641 ( + InstalledPackageInfo, + toCurrent, + ) where + +import qualified Distribution.InstalledPackageInfo as Current +import qualified Distribution.Package as Current hiding (depends) +import Distribution.Text (display) + +import Distribution.Simple.GHC.IPI642 + ( PackageIdentifier, convertPackageId + , License, convertLicense, convertModuleName ) + +-- | This is the InstalledPackageInfo type used by ghc-6.4 and 6.4.1. +-- +-- It's here purely for the 'Read' instance so that we can read the package +-- database used by those ghc versions. It is a little hacky to read the +-- package db directly, but we do need the info and until ghc-6.9 there was +-- no better method. +-- +-- In ghc-6.4.2 the format changed a bit. See "Distribution.Simple.GHC.IPI642" +-- +data InstalledPackageInfo = InstalledPackageInfo { + package :: PackageIdentifier, + license :: License, + copyright :: String, + maintainer :: String, + author :: String, + stability :: String, + homepage :: String, + pkgUrl :: String, + description :: String, + category :: String, + exposed :: Bool, + exposedModules :: [String], + hiddenModules :: [String], + importDirs :: [FilePath], + libraryDirs :: [FilePath], + hsLibraries :: [String], + extraLibraries :: [String], + includeDirs :: [FilePath], + includes :: [String], + depends :: [PackageIdentifier], + hugsOptions :: [String], + ccOptions :: [String], + ldOptions :: [String], + frameworkDirs :: [FilePath], + frameworks :: [String], + haddockInterfaces :: [FilePath], + haddockHTMLs :: [FilePath] + } + deriving Read + +mkInstalledPackageId :: Current.PackageIdentifier -> Current.InstalledPackageId +mkInstalledPackageId = Current.InstalledPackageId . display + +toCurrent :: InstalledPackageInfo -> Current.InstalledPackageInfo +toCurrent ipi@InstalledPackageInfo{} = Current.InstalledPackageInfo { + Current.installedPackageId = mkInstalledPackageId (convertPackageId (package ipi)), + Current.sourcePackageId = convertPackageId (package ipi), + Current.license = convertLicense (license ipi), + Current.copyright = copyright ipi, + Current.maintainer = maintainer ipi, + Current.author = author ipi, + Current.stability = stability ipi, + Current.homepage = homepage ipi, + Current.pkgUrl = pkgUrl ipi, + Current.synopsis = "", + Current.description = description ipi, + Current.category = category ipi, + Current.exposed = exposed ipi, + Current.exposedModules = map convertModuleName (exposedModules ipi), + Current.hiddenModules = map convertModuleName (hiddenModules ipi), + Current.trusted = False, + Current.importDirs = importDirs ipi, + Current.libraryDirs = libraryDirs ipi, + Current.hsLibraries = hsLibraries ipi, + Current.extraLibraries = extraLibraries ipi, + Current.extraGHCiLibraries = [], + Current.includeDirs = includeDirs ipi, + Current.includes = includes ipi, + Current.depends = map (mkInstalledPackageId.convertPackageId) (depends ipi), + Current.hugsOptions = hugsOptions ipi, + Current.ccOptions = ccOptions ipi, + Current.ldOptions = ldOptions ipi, + Current.frameworkDirs = frameworkDirs ipi, + Current.frameworks = frameworks ipi, + Current.haddockInterfaces = haddockInterfaces ipi, + Current.haddockHTMLs = haddockHTMLs ipi + } diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/GHC/IPI642.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/GHC/IPI642.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/GHC/IPI642.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/GHC/IPI642.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,164 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.GHC.IPI642 +-- Copyright : (c) The University of Glasgow 2004 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- + +{- All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of the University nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.Simple.GHC.IPI642 ( + InstalledPackageInfo, + toCurrent, + + -- Don't use these, they're only for conversion purposes + PackageIdentifier, convertPackageId, + License, convertLicense, + convertModuleName + ) where + +import qualified Distribution.InstalledPackageInfo as Current +import qualified Distribution.Package as Current hiding (depends) +import qualified Distribution.License as Current + +import Distribution.Version (Version) +import Distribution.ModuleName (ModuleName) +import Distribution.Text (simpleParse,display) + +import Data.Maybe + +-- | This is the InstalledPackageInfo type used by ghc-6.4.2 and later. +-- +-- It's here purely for the 'Read' instance so that we can read the package +-- database used by those ghc versions. It is a little hacky to read the +-- package db directly, but we do need the info and until ghc-6.9 there was +-- no better method. +-- +-- In ghc-6.4.1 and before the format was slightly different. +-- See "Distribution.Simple.GHC.IPI642" +-- +data InstalledPackageInfo = InstalledPackageInfo { + package :: PackageIdentifier, + license :: License, + copyright :: String, + maintainer :: String, + author :: String, + stability :: String, + homepage :: String, + pkgUrl :: String, + description :: String, + category :: String, + exposed :: Bool, + exposedModules :: [String], + hiddenModules :: [String], + importDirs :: [FilePath], + libraryDirs :: [FilePath], + hsLibraries :: [String], + extraLibraries :: [String], + extraGHCiLibraries:: [String], + includeDirs :: [FilePath], + includes :: [String], + depends :: [PackageIdentifier], + hugsOptions :: [String], + ccOptions :: [String], + ldOptions :: [String], + frameworkDirs :: [FilePath], + frameworks :: [String], + haddockInterfaces :: [FilePath], + haddockHTMLs :: [FilePath] + } + deriving Read + +data PackageIdentifier = PackageIdentifier { + pkgName :: String, + pkgVersion :: Version + } + deriving Read + +data License = GPL | LGPL | BSD3 | BSD4 + | PublicDomain | AllRightsReserved | OtherLicense + deriving Read + +convertPackageId :: PackageIdentifier -> Current.PackageIdentifier +convertPackageId PackageIdentifier { pkgName = n, pkgVersion = v } = + Current.PackageIdentifier (Current.PackageName n) v + +mkInstalledPackageId :: Current.PackageIdentifier -> Current.InstalledPackageId +mkInstalledPackageId = Current.InstalledPackageId . display + +convertModuleName :: String -> ModuleName +convertModuleName s = fromJust $ simpleParse s + +convertLicense :: License -> Current.License +convertLicense GPL = Current.GPL Nothing +convertLicense LGPL = Current.LGPL Nothing +convertLicense BSD3 = Current.BSD3 +convertLicense BSD4 = Current.BSD4 +convertLicense PublicDomain = Current.PublicDomain +convertLicense AllRightsReserved = Current.AllRightsReserved +convertLicense OtherLicense = Current.OtherLicense + +toCurrent :: InstalledPackageInfo -> Current.InstalledPackageInfo +toCurrent ipi@InstalledPackageInfo{} = Current.InstalledPackageInfo { + Current.installedPackageId = mkInstalledPackageId (convertPackageId (package ipi)), + Current.sourcePackageId = convertPackageId (package ipi), + Current.license = convertLicense (license ipi), + Current.copyright = copyright ipi, + Current.maintainer = maintainer ipi, + Current.author = author ipi, + Current.stability = stability ipi, + Current.homepage = homepage ipi, + Current.pkgUrl = pkgUrl ipi, + Current.synopsis = "", + Current.description = description ipi, + Current.category = category ipi, + Current.exposed = exposed ipi, + Current.exposedModules = map convertModuleName (exposedModules ipi), + Current.hiddenModules = map convertModuleName (hiddenModules ipi), + Current.trusted = False, + Current.importDirs = importDirs ipi, + Current.libraryDirs = libraryDirs ipi, + Current.hsLibraries = hsLibraries ipi, + Current.extraLibraries = extraLibraries ipi, + Current.extraGHCiLibraries = extraGHCiLibraries ipi, + Current.includeDirs = includeDirs ipi, + Current.includes = includes ipi, + Current.depends = map (mkInstalledPackageId.convertPackageId) (depends ipi), + Current.hugsOptions = hugsOptions ipi, + Current.ccOptions = ccOptions ipi, + Current.ldOptions = ldOptions ipi, + Current.frameworkDirs = frameworkDirs ipi, + Current.frameworks = frameworks ipi, + Current.haddockInterfaces = haddockInterfaces ipi, + Current.haddockHTMLs = haddockHTMLs ipi + } diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/GHC.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/GHC.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/GHC.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/GHC.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,1079 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.GHC +-- Copyright : Isaac Jones 2003-2007 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is a fairly large module. It contains most of the GHC-specific code for +-- configuring, building and installing packages. It also exports a function +-- for finding out what packages are already installed. Configuring involves +-- finding the @ghc@ and @ghc-pkg@ programs, finding what language extensions +-- this version of ghc supports and returning a 'Compiler' value. +-- +-- 'getInstalledPackages' involves calling the @ghc-pkg@ program to find out +-- what packages are installed. +-- +-- Building is somewhat complex as there is quite a bit of information to take +-- into account. We have to build libs and programs, possibly for profiling and +-- shared libs. We have to support building libraries that will be usable by +-- GHCi and also ghc's @-split-objs@ feature. We have to compile any C files +-- using ghc. Linking, especially for @split-objs@ is remarkably complex, +-- partly because there tend to be 1,000's of @.o@ files and this can often be +-- more than we can pass to the @ld@ or @ar@ programs in one go. +-- +-- Installing for libs and exes involves finding the right files and copying +-- them to the right places. One of the more tricky things about this module is +-- remembering the layout of files in the build directory (which is not +-- explicitly documented) and thus what search dirs are used for various kinds +-- of files. + +{- Copyright (c) 2003-2005, Isaac Jones +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modiication, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.Simple.GHC ( + configure, getInstalledPackages, + buildLib, buildExe, + installLib, installExe, + libAbiHash, + registerPackage, + ghcOptions, + ghcVerbosityOptions, + ghcPackageDbOptions, + ghcLibDir, + ) where + +import qualified Distribution.Simple.GHC.IPI641 as IPI641 +import qualified Distribution.Simple.GHC.IPI642 as IPI642 +import Distribution.PackageDescription as PD + ( PackageDescription(..), BuildInfo(..), Executable(..) + , Library(..), libModules, hcOptions, usedExtensions, allExtensions ) +import Distribution.InstalledPackageInfo + ( InstalledPackageInfo ) +import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo + ( InstalledPackageInfo_(..) ) +import Distribution.Simple.PackageIndex (PackageIndex) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.LocalBuildInfo + ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) + , absoluteInstallDirs ) +import Distribution.Simple.InstallDirs hiding ( absoluteInstallDirs ) +import Distribution.Simple.BuildPaths +import Distribution.Simple.Utils +import Distribution.Package + ( PackageIdentifier, Package(..), PackageName(..) ) +import qualified Distribution.ModuleName as ModuleName +import Distribution.Simple.Program + ( Program(..), ConfiguredProgram(..), ProgramConfiguration, ProgArg + , ProgramLocation(..), rawSystemProgram, rawSystemProgramConf + , rawSystemProgramStdout, rawSystemProgramStdoutConf + , requireProgramVersion, requireProgram, getProgramOutput + , userMaybeSpecifyPath, programPath, lookupProgram, addKnownProgram + , ghcProgram, ghcPkgProgram, hsc2hsProgram + , arProgram, ranlibProgram, ldProgram + , gccProgram, stripProgram ) +import qualified Distribution.Simple.Program.HcPkg as HcPkg +import qualified Distribution.Simple.Program.Ar as Ar +import qualified Distribution.Simple.Program.Ld as Ld +import Distribution.Simple.Compiler + ( CompilerFlavor(..), CompilerId(..), Compiler(..), compilerVersion + , OptimisationLevel(..), PackageDB(..), PackageDBStack + , Flag, languageToFlags, extensionsToFlags ) +import Distribution.Version + ( Version(..), anyVersion, orLaterVersion ) +import Distribution.System + ( OS(..), buildOS ) +import Distribution.Verbosity +import Distribution.Text + ( display, simpleParse ) +import Language.Haskell.Extension (Language(..), Extension(..), KnownExtension(..)) + +import Control.Monad ( unless, when, liftM ) +import Data.Char ( isSpace ) +import Data.List +import Data.Maybe ( catMaybes ) +import Data.Monoid ( Monoid(..) ) +import System.Directory + ( removeFile, getDirectoryContents, doesFileExist + , getTemporaryDirectory ) +import System.FilePath ( (), (<.>), takeExtension, + takeDirectory, replaceExtension, splitExtension ) +import System.IO (hClose, hPutStrLn) +import Distribution.Compat.Exception (catchExit, catchIO) + +-- ----------------------------------------------------------------------------- +-- Configuring + +configure :: Verbosity -> Maybe FilePath -> Maybe FilePath + -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration) +configure verbosity hcPath hcPkgPath conf0 = do + + (ghcProg, ghcVersion, conf1) <- + requireProgramVersion verbosity ghcProgram + (orLaterVersion (Version [6,4] [])) + (userMaybeSpecifyPath "ghc" hcPath conf0) + + -- This is slightly tricky, we have to configure ghc first, then we use the + -- location of ghc to help find ghc-pkg in the case that the user did not + -- specify the location of ghc-pkg directly: + (ghcPkgProg, ghcPkgVersion, conf2) <- + requireProgramVersion verbosity ghcPkgProgram { + programFindLocation = guessGhcPkgFromGhcPath ghcProg + } + anyVersion (userMaybeSpecifyPath "ghc-pkg" hcPkgPath conf1) + + when (ghcVersion /= ghcPkgVersion) $ die $ + "Version mismatch between ghc and ghc-pkg: " + ++ programPath ghcProg ++ " is version " ++ display ghcVersion ++ " " + ++ programPath ghcPkgProg ++ " is version " ++ display ghcPkgVersion + + -- Likewise we try to find the matching hsc2hs program. + let hsc2hsProgram' = hsc2hsProgram { + programFindLocation = guessHsc2hsFromGhcPath ghcProg + } + conf3 = addKnownProgram hsc2hsProgram' conf2 + + languages <- getLanguages verbosity ghcProg + extensions <- getExtensions verbosity ghcProg + + ghcInfo <- if ghcVersion >= Version [6,7] [] + then do xs <- getProgramOutput verbosity ghcProg ["--info"] + case reads xs of + [(i, ss)] + | all isSpace ss -> + return i + _ -> + die "Can't parse --info output of GHC" + else return [] + + let comp = Compiler { + compilerId = CompilerId GHC ghcVersion, + compilerLanguages = languages, + compilerExtensions = extensions + } + conf4 = configureToolchain ghcProg ghcInfo conf3 -- configure gcc and ld + return (comp, conf4) + +-- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find +-- the corresponding tool; e.g. if the tool is ghc-pkg, we try looking +-- for a versioned or unversioned ghc-pkg in the same dir, that is: +-- +-- > /usr/local/bin/ghc-pkg-ghc-6.6.1(.exe) +-- > /usr/local/bin/ghc-pkg-6.6.1(.exe) +-- > /usr/local/bin/ghc-pkg(.exe) +-- +guessToolFromGhcPath :: FilePath -> ConfiguredProgram -> Verbosity + -> IO (Maybe FilePath) +guessToolFromGhcPath tool ghcProg verbosity + = do let path = programPath ghcProg + dir = takeDirectory path + versionSuffix = takeVersionSuffix (dropExeExtension path) + guessNormal = dir tool <.> exeExtension + guessGhcVersioned = dir (tool ++ "-ghc" ++ versionSuffix) <.> exeExtension + guessVersioned = dir (tool ++ versionSuffix) <.> exeExtension + guesses | null versionSuffix = [guessNormal] + | otherwise = [guessGhcVersioned, + guessVersioned, + guessNormal] + info verbosity $ "looking for tool " ++ show tool ++ " near compiler in " ++ dir + exists <- mapM doesFileExist guesses + case [ file | (file, True) <- zip guesses exists ] of + [] -> return Nothing + (fp:_) -> do info verbosity $ "found " ++ tool ++ " in " ++ fp + return (Just fp) + + where takeVersionSuffix :: FilePath -> String + takeVersionSuffix = reverse . takeWhile (`elem ` "0123456789.-") . reverse + + dropExeExtension :: FilePath -> FilePath + dropExeExtension filepath = + case splitExtension filepath of + (filepath', extension) | extension == exeExtension -> filepath' + | otherwise -> filepath + +-- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a +-- corresponding ghc-pkg, we try looking for both a versioned and unversioned +-- ghc-pkg in the same dir, that is: +-- +-- > /usr/local/bin/ghc-pkg-ghc-6.6.1(.exe) +-- > /usr/local/bin/ghc-pkg-6.6.1(.exe) +-- > /usr/local/bin/ghc-pkg(.exe) +-- +guessGhcPkgFromGhcPath :: ConfiguredProgram -> Verbosity -> IO (Maybe FilePath) +guessGhcPkgFromGhcPath = guessToolFromGhcPath "ghc-pkg" + +-- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a +-- corresponding hsc2hs, we try looking for both a versioned and unversioned +-- hsc2hs in the same dir, that is: +-- +-- > /usr/local/bin/hsc2hs-ghc-6.6.1(.exe) +-- > /usr/local/bin/hsc2hs-6.6.1(.exe) +-- > /usr/local/bin/hsc2hs(.exe) +-- +guessHsc2hsFromGhcPath :: ConfiguredProgram -> Verbosity -> IO (Maybe FilePath) +guessHsc2hsFromGhcPath = guessToolFromGhcPath "hsc2hs" + +-- | Adjust the way we find and configure gcc and ld +-- +configureToolchain :: ConfiguredProgram -> [(String, String)] + -> ProgramConfiguration + -> ProgramConfiguration +configureToolchain ghcProg ghcInfo = + addKnownProgram gccProgram { + programFindLocation = findProg gccProgram + [ if ghcVersion >= Version [6,12] [] + then mingwBinDir "gcc.exe" + else baseDir "gcc.exe" ], + programPostConf = configureGcc + } + . addKnownProgram ldProgram { + programFindLocation = findProg ldProgram + [ if ghcVersion >= Version [6,12] [] + then mingwBinDir "ld.exe" + else libDir "ld.exe" ], + programPostConf = configureLd + } + . addKnownProgram arProgram { + programFindLocation = findProg arProgram + [ if ghcVersion >= Version [6,12] [] + then mingwBinDir "ar.exe" + else libDir "ar.exe" ] + } + where + Just ghcVersion = programVersion ghcProg + compilerDir = takeDirectory (programPath ghcProg) + baseDir = takeDirectory compilerDir + mingwBinDir = baseDir "mingw" "bin" + libDir = baseDir "gcc-lib" + includeDir = baseDir "include" "mingw" + isWindows = case buildOS of Windows -> True; _ -> False + + -- on Windows finding and configuring ghc's gcc and ld is a bit special + findProg :: Program -> [FilePath] -> Verbosity -> IO (Maybe FilePath) + findProg prog locations + | isWindows = \verbosity -> look locations verbosity + | otherwise = programFindLocation prog + where + look [] verbosity = do + warn verbosity ("Couldn't find " ++ programName prog ++ " where I expected it. Trying the search path.") + programFindLocation prog verbosity + look (f:fs) verbosity = do + exists <- doesFileExist f + if exists then return (Just f) + else look fs verbosity + + ccFlags = getFlags "C compiler flags" + gccLinkerFlags = getFlags "Gcc Linker flags" + ldLinkerFlags = getFlags "Ld Linker flags" + + getFlags key = case lookup key ghcInfo of + Nothing -> [] + Just flags -> + case reads flags of + [(args, "")] -> args + _ -> [] -- XXX Should should be an error really + + configureGcc :: Verbosity -> ConfiguredProgram -> IO [ProgArg] + configureGcc v cp = liftM (++ (ccFlags ++ gccLinkerFlags)) + $ configureGcc' v cp + + configureGcc' :: Verbosity -> ConfiguredProgram -> IO [ProgArg] + configureGcc' + | isWindows = \_ gccProg -> case programLocation gccProg of + -- if it's found on system then it means we're using the result + -- of programFindLocation above rather than a user-supplied path + -- Pre GHC 6.12, that meant we should add these flags to tell + -- ghc's gcc where it lives and thus where gcc can find its + -- various files: + FoundOnSystem {} + | ghcVersion < Version [6,11] [] -> + return ["-B" ++ libDir, "-I" ++ includeDir] + _ -> return [] + | otherwise = \_ _ -> return [] + + configureLd :: Verbosity -> ConfiguredProgram -> IO [ProgArg] + configureLd v cp = liftM (++ ldLinkerFlags) $ configureLd' v cp + + -- we need to find out if ld supports the -x flag + configureLd' :: Verbosity -> ConfiguredProgram -> IO [ProgArg] + configureLd' verbosity ldProg = do + tempDir <- getTemporaryDirectory + ldx <- withTempFile tempDir ".c" $ \testcfile testchnd -> + withTempFile tempDir ".o" $ \testofile testohnd -> do + hPutStrLn testchnd "int foo() {}" + hClose testchnd; hClose testohnd + rawSystemProgram verbosity ghcProg ["-c", testcfile, + "-o", testofile] + withTempFile tempDir ".o" $ \testofile' testohnd' -> + do + hClose testohnd' + _ <- rawSystemProgramStdout verbosity ldProg + ["-x", "-r", testofile, "-o", testofile'] + return True + `catchIO` (\_ -> return False) + `catchExit` (\_ -> return False) + if ldx + then return ["-x"] + else return [] + +getLanguages :: Verbosity -> ConfiguredProgram -> IO [(Language, Flag)] +getLanguages _ ghcProg + -- TODO: should be using --supported-languages rather than hard coding + | ghcVersion >= Version [7] [] = return [(Haskell98, "-XHaskell98") + ,(Haskell2010, "-XHaskell2010")] + | otherwise = return [(Haskell98, "")] + where + Just ghcVersion = programVersion ghcProg + +getExtensions :: Verbosity -> ConfiguredProgram -> IO [(Extension, Flag)] +getExtensions verbosity ghcProg + | ghcVersion >= Version [6,7] [] = do + + str <- rawSystemStdout verbosity (programPath ghcProg) + ["--supported-languages"] + let extStrs = if ghcVersion >= Version [7] [] + then lines str + else -- Older GHCs only gave us either Foo or NoFoo, + -- so we have to work out the other one ourselves + [ extStr'' + | extStr <- lines str + , let extStr' = case extStr of + 'N' : 'o' : xs -> xs + _ -> "No" ++ extStr + , extStr'' <- [extStr, extStr'] + ] + let extensions0 = [ (ext, "-X" ++ display ext) + | Just ext <- map simpleParse extStrs ] + extensions1 = if ghcVersion >= Version [6,8] [] && + ghcVersion < Version [6,10] [] + then -- ghc-6.8 introduced RecordPuns however it + -- should have been NamedFieldPuns. We now + -- encourage packages to use NamedFieldPuns + -- so for compatability we fake support for + -- it in ghc-6.8 by making it an alias for + -- the old RecordPuns extension. + (EnableExtension NamedFieldPuns, "-XRecordPuns") : + (DisableExtension NamedFieldPuns, "-XNoRecordPuns") : + extensions0 + else extensions0 + extensions2 = if ghcVersion < Version [7,1] [] + then -- ghc-7.2 split NondecreasingIndentation off + -- into a proper extension. Before that it + -- was always on. + (EnableExtension NondecreasingIndentation, "") : + (DisableExtension NondecreasingIndentation, "") : + extensions1 + else extensions1 + return extensions2 + + | otherwise = return oldLanguageExtensions + + where + Just ghcVersion = programVersion ghcProg + +-- | For GHC 6.6.x and earlier, the mapping from supported extensions to flags +oldLanguageExtensions :: [(Extension, Flag)] +oldLanguageExtensions = + let doFlag (f, (enable, disable)) = [(EnableExtension f, enable), + (DisableExtension f, disable)] + fglasgowExts = ("-fglasgow-exts", + "") -- This is wrong, but we don't want to turn + -- all the extensions off when asked to just + -- turn one off + fFlag flag = ("-f" ++ flag, "-fno-" ++ flag) + in concatMap doFlag + [(OverlappingInstances , fFlag "allow-overlapping-instances") + ,(TypeSynonymInstances , fglasgowExts) + ,(TemplateHaskell , fFlag "th") + ,(ForeignFunctionInterface , fFlag "ffi") + ,(MonomorphismRestriction , fFlag "monomorphism-restriction") + ,(MonoPatBinds , fFlag "mono-pat-binds") + ,(UndecidableInstances , fFlag "allow-undecidable-instances") + ,(IncoherentInstances , fFlag "allow-incoherent-instances") + ,(Arrows , fFlag "arrows") + ,(Generics , fFlag "generics") + ,(ImplicitPrelude , fFlag "implicit-prelude") + ,(ImplicitParams , fFlag "implicit-params") + ,(CPP , ("-cpp", ""{- Wrong -})) + ,(BangPatterns , fFlag "bang-patterns") + ,(KindSignatures , fglasgowExts) + ,(RecursiveDo , fglasgowExts) + ,(ParallelListComp , fglasgowExts) + ,(MultiParamTypeClasses , fglasgowExts) + ,(FunctionalDependencies , fglasgowExts) + ,(Rank2Types , fglasgowExts) + ,(RankNTypes , fglasgowExts) + ,(PolymorphicComponents , fglasgowExts) + ,(ExistentialQuantification , fglasgowExts) + ,(ScopedTypeVariables , fFlag "scoped-type-variables") + ,(FlexibleContexts , fglasgowExts) + ,(FlexibleInstances , fglasgowExts) + ,(EmptyDataDecls , fglasgowExts) + ,(PatternGuards , fglasgowExts) + ,(GeneralizedNewtypeDeriving , fglasgowExts) + ,(MagicHash , fglasgowExts) + ,(UnicodeSyntax , fglasgowExts) + ,(PatternSignatures , fglasgowExts) + ,(UnliftedFFITypes , fglasgowExts) + ,(LiberalTypeSynonyms , fglasgowExts) + ,(TypeOperators , fglasgowExts) + ,(GADTs , fglasgowExts) + ,(RelaxedPolyRec , fglasgowExts) + ,(ExtendedDefaultRules , fFlag "extended-default-rules") + ,(UnboxedTuples , fglasgowExts) + ,(DeriveDataTypeable , fglasgowExts) + ,(ConstrainedClassMethods , fglasgowExts) + ] + +getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration + -> IO PackageIndex +getInstalledPackages verbosity packagedbs conf = do + checkPackageDbStack packagedbs + pkgss <- getInstalledPackages' verbosity packagedbs conf + topDir <- ghcLibDir' verbosity ghcProg + let indexes = [ PackageIndex.fromList (map (substTopDir topDir) pkgs) + | (_, pkgs) <- pkgss ] + return $! hackRtsPackage (mconcat indexes) + + where + -- On Windows, various fields have $topdir/foo rather than full + -- paths. We need to substitute the right value in so that when + -- we, for example, call gcc, we have proper paths to give it + Just ghcProg = lookupProgram ghcProgram conf + + hackRtsPackage index = + case PackageIndex.lookupPackageName index (PackageName "rts") of + [(_,[rts])] + -> PackageIndex.insert (removeMingwIncludeDir rts) index + _ -> index -- No (or multiple) ghc rts package is registered!! + -- Feh, whatever, the ghc testsuite does some crazy stuff. + +ghcLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath +ghcLibDir verbosity lbi = + (reverse . dropWhile isSpace . reverse) `fmap` + rawSystemProgramStdoutConf verbosity ghcProgram (withPrograms lbi) ["--print-libdir"] + +ghcLibDir' :: Verbosity -> ConfiguredProgram -> IO FilePath +ghcLibDir' verbosity ghcProg = + (reverse . dropWhile isSpace . reverse) `fmap` + rawSystemProgramStdout verbosity ghcProg ["--print-libdir"] + +checkPackageDbStack :: PackageDBStack -> IO () +checkPackageDbStack (GlobalPackageDB:rest) + | GlobalPackageDB `notElem` rest = return () +checkPackageDbStack _ = + die $ "GHC.getInstalledPackages: the global package db must be " + ++ "specified first and cannot be specified multiple times" + +-- GHC < 6.10 put "$topdir/include/mingw" in rts's installDirs. This +-- breaks when you want to use a different gcc, so we need to filter +-- it out. +removeMingwIncludeDir :: InstalledPackageInfo -> InstalledPackageInfo +removeMingwIncludeDir pkg = + let ids = InstalledPackageInfo.includeDirs pkg + ids' = filter (not . ("mingw" `isSuffixOf`)) ids + in pkg { InstalledPackageInfo.includeDirs = ids' } + +-- | Get the packages from specific PackageDBs, not cumulative. +-- +getInstalledPackages' :: Verbosity -> [PackageDB] -> ProgramConfiguration + -> IO [(PackageDB, [InstalledPackageInfo])] +getInstalledPackages' verbosity packagedbs conf + | ghcVersion >= Version [6,9] [] = + sequence + [ do pkgs <- HcPkg.dump verbosity ghcPkgProg packagedb + return (packagedb, pkgs) + | packagedb <- packagedbs ] + + where + Just ghcPkgProg = lookupProgram ghcPkgProgram conf + Just ghcProg = lookupProgram ghcProgram conf + Just ghcVersion = programVersion ghcProg + +getInstalledPackages' verbosity packagedbs conf = do + str <- rawSystemProgramStdoutConf verbosity ghcPkgProgram conf ["list"] + let pkgFiles = [ init line | line <- lines str, last line == ':' ] + dbFile packagedb = case (packagedb, pkgFiles) of + (GlobalPackageDB, global:_) -> return $ Just global + (UserPackageDB, _global:user:_) -> return $ Just user + (UserPackageDB, _global:_) -> return $ Nothing + (SpecificPackageDB specific, _) -> return $ Just specific + _ -> die "cannot read ghc-pkg package listing" + pkgFiles' <- mapM dbFile packagedbs + sequence [ withFileContents file $ \content -> do + pkgs <- readPackages file content + return (db, pkgs) + | (db , Just file) <- zip packagedbs pkgFiles' ] + where + -- Depending on the version of ghc we use a different type's Read + -- instance to parse the package file and then convert. + -- It's a bit yuck. But that's what we get for using Read/Show. + readPackages + | ghcVersion >= Version [6,4,2] [] + = \file content -> case reads content of + [(pkgs, _)] -> return (map IPI642.toCurrent pkgs) + _ -> failToRead file + | otherwise + = \file content -> case reads content of + [(pkgs, _)] -> return (map IPI641.toCurrent pkgs) + _ -> failToRead file + Just ghcProg = lookupProgram ghcProgram conf + Just ghcVersion = programVersion ghcProg + failToRead file = die $ "cannot read ghc package database " ++ file + +substTopDir :: FilePath -> InstalledPackageInfo -> InstalledPackageInfo +substTopDir topDir ipo + = ipo { + InstalledPackageInfo.importDirs + = map f (InstalledPackageInfo.importDirs ipo), + InstalledPackageInfo.libraryDirs + = map f (InstalledPackageInfo.libraryDirs ipo), + InstalledPackageInfo.includeDirs + = map f (InstalledPackageInfo.includeDirs ipo), + InstalledPackageInfo.frameworkDirs + = map f (InstalledPackageInfo.frameworkDirs ipo), + InstalledPackageInfo.haddockInterfaces + = map f (InstalledPackageInfo.haddockInterfaces ipo), + InstalledPackageInfo.haddockHTMLs + = map f (InstalledPackageInfo.haddockHTMLs ipo) + } + where f ('$':'t':'o':'p':'d':'i':'r':rest) = topDir ++ rest + f x = x + +-- ----------------------------------------------------------------------------- +-- Building + +-- | Build a library with GHC. +-- +buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo + -> Library -> ComponentLocalBuildInfo -> IO () +buildLib verbosity pkg_descr lbi lib clbi = do + let pref = buildDir lbi + pkgid = packageId pkg_descr + runGhcProg = rawSystemProgramConf verbosity ghcProgram (withPrograms lbi) + ifVanillaLib forceVanilla = when (forceVanilla || withVanillaLib lbi) + ifProfLib = when (withProfLib lbi) + ifSharedLib = when (withSharedLib lbi) + ifGHCiLib = when (withGHCiLib lbi && withVanillaLib lbi) + comp = compiler lbi + + libBi <- hackThreadedFlag verbosity + comp (withProfLib lbi) (libBuildInfo lib) + + let libTargetDir = pref + forceVanillaLib = EnableExtension TemplateHaskell `elem` allExtensions libBi + -- TH always needs vanilla libs, even when building for profiling + + createDirectoryIfMissingVerbose verbosity True libTargetDir + -- TODO: do we need to put hs-boot files into place for mutually recurive modules? + let ghcArgs = + "--make" + : ["-package-name", display pkgid ] + ++ constructGHCCmdLine lbi libBi clbi libTargetDir verbosity + ++ map display (libModules lib) + ghcArgsProf = ghcArgs + ++ ["-prof", + "-hisuf", "p_hi", + "-osuf", "p_o" + ] + ++ ghcProfOptions libBi + ghcArgsShared = ghcArgs + ++ ["-dynamic", + "-hisuf", "dyn_hi", + "-osuf", "dyn_o", "-fPIC" + ] + ++ ghcSharedOptions libBi + unless (null (libModules lib)) $ + do ifVanillaLib forceVanillaLib (runGhcProg ghcArgs) + ifProfLib (runGhcProg ghcArgsProf) + ifSharedLib (runGhcProg ghcArgsShared) + + -- build any C sources + unless (null (cSources libBi)) $ do + info verbosity "Building C Sources..." + sequence_ [do let (odir,args) = constructCcCmdLine lbi libBi clbi pref + filename verbosity + False + (withProfLib lbi) + createDirectoryIfMissingVerbose verbosity True odir + runGhcProg args + ifSharedLib (runGhcProg (args ++ ["-fPIC", "-osuf dyn_o"])) + | filename <- cSources libBi] + + -- link: + info verbosity "Linking..." + let cObjs = map (`replaceExtension` objExtension) (cSources libBi) + cSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension)) (cSources libBi) + vanillaLibFilePath = libTargetDir mkLibName pkgid + profileLibFilePath = libTargetDir mkProfLibName pkgid + sharedLibFilePath = libTargetDir mkSharedLibName pkgid + (compilerId (compiler lbi)) + ghciLibFilePath = libTargetDir mkGHCiLibName pkgid + libInstallPath = libdir $ absoluteInstallDirs pkg_descr lbi NoCopyDest + sharedLibInstallPath = libInstallPath mkSharedLibName pkgid + (compilerId (compiler lbi)) + + stubObjs <- fmap catMaybes $ sequence + [ findFileWithExtension [objExtension] [libTargetDir] + (ModuleName.toFilePath x ++"_stub") + | x <- libModules lib ] + stubProfObjs <- fmap catMaybes $ sequence + [ findFileWithExtension ["p_" ++ objExtension] [libTargetDir] + (ModuleName.toFilePath x ++"_stub") + | x <- libModules lib ] + stubSharedObjs <- fmap catMaybes $ sequence + [ findFileWithExtension ["dyn_" ++ objExtension] [libTargetDir] + (ModuleName.toFilePath x ++"_stub") + | x <- libModules lib ] + + hObjs <- getHaskellObjects lib lbi + pref objExtension True + hProfObjs <- + if (withProfLib lbi) + then getHaskellObjects lib lbi + pref ("p_" ++ objExtension) True + else return [] + hSharedObjs <- + if (withSharedLib lbi) + then getHaskellObjects lib lbi + pref ("dyn_" ++ objExtension) False + else return [] + + unless (null hObjs && null cObjs && null stubObjs) $ do + -- first remove library files if they exists + sequence_ + [ removeFile libFilePath `catchIO` \_ -> return () + | libFilePath <- [vanillaLibFilePath, profileLibFilePath + ,sharedLibFilePath, ghciLibFilePath] ] + + let staticObjectFiles = + hObjs + ++ map (pref ) cObjs + ++ stubObjs + profObjectFiles = + hProfObjs + ++ map (pref ) cObjs + ++ stubProfObjs + ghciObjFiles = + hObjs + ++ map (pref ) cObjs + ++ stubObjs + dynamicObjectFiles = + hSharedObjs + ++ map (pref ) cSharedObjs + ++ stubSharedObjs + -- After the relocation lib is created we invoke ghc -shared + -- with the dependencies spelled out as -package arguments + -- and ghc invokes the linker with the proper library paths + ghcSharedLinkArgs = + [ "-no-auto-link-packages", + "-shared", + "-dynamic", + "-o", sharedLibFilePath ] + -- For dynamic libs, Mac OS/X needs to know the install location + -- at build time. + ++ (if buildOS == OSX + then ["-dylib-install-name", sharedLibInstallPath] + else []) + ++ dynamicObjectFiles + ++ ["-package-name", display pkgid ] + ++ ghcPackageFlags lbi clbi + ++ ["-l"++extraLib | extraLib <- extraLibs libBi] + ++ ["-L"++extraLibDir | extraLibDir <- extraLibDirs libBi] + + ifVanillaLib False $ do + (arProg, _) <- requireProgram verbosity arProgram (withPrograms lbi) + Ar.createArLibArchive verbosity arProg + vanillaLibFilePath staticObjectFiles + + ifProfLib $ do + (arProg, _) <- requireProgram verbosity arProgram (withPrograms lbi) + Ar.createArLibArchive verbosity arProg + profileLibFilePath profObjectFiles + + ifGHCiLib $ do + (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi) + Ld.combineObjectFiles verbosity ldProg + ghciLibFilePath ghciObjFiles + + ifSharedLib $ + runGhcProg ghcSharedLinkArgs + + +-- | Build an executable with GHC. +-- +buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo + -> Executable -> ComponentLocalBuildInfo -> IO () +buildExe verbosity _pkg_descr lbi + exe@Executable { exeName = exeName', modulePath = modPath } clbi = do + let pref = buildDir lbi + runGhcProg = rawSystemProgramConf verbosity ghcProgram (withPrograms lbi) + + exeBi <- hackThreadedFlag verbosity + (compiler lbi) (withProfExe lbi) (buildInfo exe) + + -- exeNameReal, the name that GHC really uses (with .exe on Windows) + let exeNameReal = exeName' <.> + (if null $ takeExtension exeName' then exeExtension else "") + + let targetDir = pref exeName' + let exeDir = targetDir (exeName' ++ "-tmp") + createDirectoryIfMissingVerbose verbosity True targetDir + createDirectoryIfMissingVerbose verbosity True exeDir + -- TODO: do we need to put hs-boot files into place for mutually recursive modules? + -- FIX: what about exeName.hi-boot? + + -- build executables + unless (null (cSources exeBi)) $ do + info verbosity "Building C Sources." + sequence_ [do let (odir,args) = constructCcCmdLine lbi exeBi clbi + exeDir filename verbosity + (withDynExe lbi) (withProfExe lbi) + createDirectoryIfMissingVerbose verbosity True odir + runGhcProg args + | filename <- cSources exeBi] + + srcMainFile <- findFile (exeDir : hsSourceDirs exeBi) modPath + + let cObjs = map (`replaceExtension` objExtension) (cSources exeBi) + let binArgs linkExe dynExe profExe = + "--make" + : (if linkExe + then ["-o", targetDir exeNameReal] + else ["-c"]) + ++ constructGHCCmdLine lbi exeBi clbi exeDir verbosity + ++ [exeDir x | x <- cObjs] + ++ [srcMainFile] + ++ ["-optl" ++ opt | opt <- PD.ldOptions exeBi] + ++ ["-l"++lib | lib <- extraLibs exeBi] + ++ ["-L"++libDir | libDir <- extraLibDirs exeBi] + ++ concat [["-framework", f] | f <- PD.frameworks exeBi] + ++ if dynExe + then ["-dynamic"] + else [] + ++ if profExe + then ["-prof", + "-hisuf", "p_hi", + "-osuf", "p_o" + ] ++ ghcProfOptions exeBi + else [] + + -- For building exe's for profiling that use TH we actually + -- have to build twice, once without profiling and the again + -- with profiling. This is because the code that TH needs to + -- run at compile time needs to be the vanilla ABI so it can + -- be loaded up and run by the compiler. + when (withProfExe lbi && EnableExtension TemplateHaskell `elem` allExtensions exeBi) + (runGhcProg (binArgs False (withDynExe lbi) False)) + + runGhcProg (binArgs True (withDynExe lbi) (withProfExe lbi)) + +-- | Filter the "-threaded" flag when profiling as it does not +-- work with ghc-6.8 and older. +hackThreadedFlag :: Verbosity -> Compiler -> Bool -> BuildInfo -> IO BuildInfo +hackThreadedFlag verbosity comp prof bi + | not mustFilterThreaded = return bi + | otherwise = do + warn verbosity $ "The ghc flag '-threaded' is not compatible with " + ++ "profiling in ghc-6.8 and older. It will be disabled." + return bi { options = filterHcOptions (/= "-threaded") (options bi) } + where + mustFilterThreaded = prof && compilerVersion comp < Version [6, 10] [] + && "-threaded" `elem` hcOptions GHC bi + filterHcOptions p hcoptss = + [ (hc, if hc == GHC then filter p opts else opts) + | (hc, opts) <- hcoptss ] + +-- when using -split-objs, we need to search for object files in the +-- Module_split directory for each module. +getHaskellObjects :: Library -> LocalBuildInfo + -> FilePath -> String -> Bool -> IO [FilePath] +getHaskellObjects lib lbi pref wanted_obj_ext allow_split_objs + | splitObjs lbi && allow_split_objs = do + let splitSuffix = if compilerVersion (compiler lbi) < + Version [6, 11] [] + then "_split" + else "_" ++ wanted_obj_ext ++ "_split" + dirs = [ pref (ModuleName.toFilePath x ++ splitSuffix) + | x <- libModules lib ] + objss <- mapM getDirectoryContents dirs + let objs = [ dir obj + | (objs',dir) <- zip objss dirs, obj <- objs', + let obj_ext = takeExtension obj, + '.':wanted_obj_ext == obj_ext ] + return objs + | otherwise = + return [ pref ModuleName.toFilePath x <.> wanted_obj_ext + | x <- libModules lib ] + +-- | Extracts a String representing a hash of the ABI of a built +-- library. It can fail if the library has not yet been built. +-- +libAbiHash :: Verbosity -> PackageDescription -> LocalBuildInfo + -> Library -> ComponentLocalBuildInfo -> IO String +libAbiHash verbosity pkg_descr lbi lib clbi = do + libBi <- hackThreadedFlag verbosity + (compiler lbi) (withProfLib lbi) (libBuildInfo lib) + let + ghcArgs = + "--abi-hash" + : ["-package-name", display (packageId pkg_descr) ] + ++ constructGHCCmdLine lbi libBi clbi (buildDir lbi) verbosity + ++ map display (exposedModules lib) + -- + rawSystemProgramStdoutConf verbosity ghcProgram (withPrograms lbi) ghcArgs + + +constructGHCCmdLine + :: LocalBuildInfo + -> BuildInfo + -> ComponentLocalBuildInfo + -> FilePath + -> Verbosity + -> [String] +constructGHCCmdLine lbi bi clbi odir verbosity = + ghcVerbosityOptions verbosity + -- Unsupported extensions have already been checked by configure + ++ ghcOptions lbi bi clbi odir + +ghcVerbosityOptions :: Verbosity -> [String] +ghcVerbosityOptions verbosity + | verbosity >= deafening = ["-v"] + | verbosity >= normal = [] + | otherwise = ["-w", "-v0"] + +ghcOptions :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo + -> FilePath -> [String] +ghcOptions lbi bi clbi odir + = ["-hide-all-packages"] + ++ ["-fbuilding-cabal-package" | ghcVer >= Version [6,11] [] ] + ++ ghcPackageDbOptions (withPackageDB lbi) + ++ ["-split-objs" | splitObjs lbi ] + ++ ["-i"] + ++ ["-i" ++ odir] + ++ ["-i" ++ l | l <- nub (hsSourceDirs bi)] + ++ ["-i" ++ autogenModulesDir lbi] + ++ ["-I" ++ autogenModulesDir lbi] + ++ ["-I" ++ odir] + ++ ["-I" ++ dir | dir <- PD.includeDirs bi] + ++ ["-optP" ++ opt | opt <- cppOptions bi] + ++ [ "-optP-include", "-optP"++ (autogenModulesDir lbi cppHeaderName) ] + ++ [ "-#include \"" ++ inc ++ "\"" | ghcVer < Version [6,11] [] + , inc <- PD.includes bi ] + ++ [ "-odir", odir, "-hidir", odir ] + ++ concat [ ["-stubdir", odir] | ghcVer >= Version [6,8] [] ] + ++ ghcPackageFlags lbi clbi + ++ (case withOptimization lbi of + NoOptimisation -> [] + NormalOptimisation -> ["-O"] + MaximumOptimisation -> ["-O2"]) + ++ hcOptions GHC bi + ++ languageToFlags (compiler lbi) (defaultLanguage bi) + ++ extensionsToFlags (compiler lbi) (usedExtensions bi) + where + ghcVer = compilerVersion (compiler lbi) + +ghcPackageFlags :: LocalBuildInfo -> ComponentLocalBuildInfo -> [String] +ghcPackageFlags lbi clbi + | ghcVer >= Version [6,11] [] + = concat [ ["-package-id", display ipkgid] + | (ipkgid, _) <- componentPackageDeps clbi ] + + | otherwise = concat [ ["-package", display pkgid] + | (_, pkgid) <- componentPackageDeps clbi ] + where + ghcVer = compilerVersion (compiler lbi) + +ghcPackageDbOptions :: PackageDBStack -> [String] +ghcPackageDbOptions dbstack = case dbstack of + (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs + (GlobalPackageDB:dbs) -> "-no-user-package-conf" + : concatMap specific dbs + _ -> ierror + where + specific (SpecificPackageDB db) = [ "-package-conf", db ] + specific _ = ierror + ierror = error ("internal error: unexpected package db stack: " ++ show dbstack) + +constructCcCmdLine :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo + -> FilePath -> FilePath -> Verbosity -> Bool -> Bool + ->(FilePath,[String]) +constructCcCmdLine lbi bi clbi pref filename verbosity dynamic profiling + = let odir | compilerVersion (compiler lbi) >= Version [6,4,1] [] = pref + | otherwise = pref takeDirectory filename + -- ghc 6.4.1 fixed a bug in -odir handling + -- for C compilations. + in + (odir, + ghcCcOptions lbi bi clbi odir + ++ (if verbosity >= deafening then ["-v"] else []) + ++ ["-c",filename] + -- Note: When building with profiling enabled, we pass the -prof + -- option to ghc here when compiling C code, so that the PROFILING + -- macro gets defined. The macro is used in ghc's Rts.h in the + -- definitions of closure layouts (Closures.h). + ++ ["-dynamic" | dynamic] + ++ ["-prof" | profiling]) + +ghcCcOptions :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo + -> FilePath -> [String] +ghcCcOptions lbi bi clbi odir + = ["-I" ++ dir | dir <- odir : PD.includeDirs bi] + ++ ghcPackageDbOptions (withPackageDB lbi) + ++ ghcPackageFlags lbi clbi + ++ ["-optc" ++ opt | opt <- PD.ccOptions bi] + ++ (case withOptimization lbi of + NoOptimisation -> [] + _ -> ["-optc-O2"]) + ++ ["-odir", odir] + +mkGHCiLibName :: PackageIdentifier -> String +mkGHCiLibName lib = "HS" ++ display lib <.> "o" + +-- ----------------------------------------------------------------------------- +-- Installing + +-- |Install executables for GHC. +installExe :: Verbosity + -> LocalBuildInfo + -> InstallDirs FilePath -- ^Where to copy the files to + -> FilePath -- ^Build location + -> (FilePath, FilePath) -- ^Executable (prefix,suffix) + -> PackageDescription + -> Executable + -> IO () +installExe verbosity lbi installDirs buildPref (progprefix, progsuffix) _pkg exe = do + let binDir = bindir installDirs + createDirectoryIfMissingVerbose verbosity True binDir + let exeFileName = exeName exe <.> exeExtension + fixedExeBaseName = progprefix ++ exeName exe ++ progsuffix + installBinary dest = do + installExecutableFile verbosity + (buildPref exeName exe exeFileName) + (dest <.> exeExtension) + stripExe verbosity lbi exeFileName (dest <.> exeExtension) + installBinary (binDir fixedExeBaseName) + +stripExe :: Verbosity -> LocalBuildInfo -> FilePath -> FilePath -> IO () +stripExe verbosity lbi name path = when (stripExes lbi) $ + case lookupProgram stripProgram (withPrograms lbi) of + Just strip -> rawSystemProgram verbosity strip args + Nothing -> unless (buildOS == Windows) $ + -- Don't bother warning on windows, we don't expect them to + -- have the strip program anyway. + warn verbosity $ "Unable to strip executable '" ++ name + ++ "' (missing the 'strip' program)" + where + args = path : case buildOS of + OSX -> ["-x"] -- By default, stripping the ghc binary on at least + -- some OS X installations causes: + -- HSbase-3.0.o: unknown symbol `_environ'" + -- The -x flag fixes that. + _ -> [] + +-- |Install for ghc, .hi, .a and, if --with-ghci given, .o +installLib :: Verbosity + -> LocalBuildInfo + -> FilePath -- ^install location + -> FilePath -- ^install location for dynamic librarys + -> FilePath -- ^Build location + -> PackageDescription + -> Library + -> IO () +installLib verbosity lbi targetDir dynlibTargetDir builtDir pkg lib = do + -- copy .hi files over: + let copyHelper installFun src dst n = do + createDirectoryIfMissingVerbose verbosity True dst + installFun verbosity (src n) (dst n) + copy = copyHelper installOrdinaryFile + copyShared = copyHelper installExecutableFile + copyModuleFiles ext = + findModuleFiles [builtDir] [ext] (libModules lib) + >>= installOrdinaryFiles verbosity targetDir + ifVanilla $ copyModuleFiles "hi" + ifProf $ copyModuleFiles "p_hi" + ifShared $ copyModuleFiles "dyn_hi" + + -- copy the built library files over: + ifVanilla $ copy builtDir targetDir vanillaLibName + ifProf $ copy builtDir targetDir profileLibName + ifGHCi $ copy builtDir targetDir ghciLibName + ifShared $ copyShared builtDir dynlibTargetDir sharedLibName + + -- run ranlib if necessary: + ifVanilla $ updateLibArchive verbosity lbi + (targetDir vanillaLibName) + ifProf $ updateLibArchive verbosity lbi + (targetDir profileLibName) + + where + vanillaLibName = mkLibName pkgid + profileLibName = mkProfLibName pkgid + ghciLibName = mkGHCiLibName pkgid + sharedLibName = mkSharedLibName pkgid (compilerId (compiler lbi)) + + pkgid = packageId pkg + + hasLib = not $ null (libModules lib) + && null (cSources (libBuildInfo lib)) + ifVanilla = when (hasLib && withVanillaLib lbi) + ifProf = when (hasLib && withProfLib lbi) + ifGHCi = when (hasLib && withGHCiLib lbi) + ifShared = when (hasLib && withSharedLib lbi) + +-- | On MacOS X we have to call @ranlib@ to regenerate the archive index after +-- copying. This is because the silly MacOS X linker checks that the archive +-- index is not older than the file itself, which means simply +-- copying/installing the file breaks it!! +-- +updateLibArchive :: Verbosity -> LocalBuildInfo -> FilePath -> IO () +updateLibArchive verbosity lbi path + | buildOS == OSX = do + (ranlib, _) <- requireProgram verbosity ranlibProgram (withPrograms lbi) + rawSystemProgram verbosity ranlib [path] + | otherwise = return () + + +-- ----------------------------------------------------------------------------- +-- Registering + +registerPackage + :: Verbosity + -> InstalledPackageInfo + -> PackageDescription + -> LocalBuildInfo + -> Bool + -> PackageDBStack + -> IO () +registerPackage verbosity installedPkgInfo _pkg lbi _inplace packageDbs = do + let Just ghcPkg = lookupProgram ghcPkgProgram (withPrograms lbi) + HcPkg.reregister verbosity ghcPkg packageDbs (Right installedPkgInfo) diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/Haddock.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/Haddock.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/Haddock.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/Haddock.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,629 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Haddock +-- Copyright : Isaac Jones 2003-2005 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module deals with the @haddock@ and @hscolour@ commands. Sadly this is +-- a rather complicated module. It deals with two versions of haddock (0.x and +-- 2.x). It has to do pre-processing for haddock 0.x which involves +-- \'unlit\'ing and using @-DHADDOCK@ for any source code that uses @cpp@. It +-- uses information about installed packages (from @ghc-pkg@) to find the +-- locations of documentation for dependent packages, so it can create links. +-- +-- The @hscolour@ support allows generating html versions of the original +-- source, with coloured syntax highlighting. + +{- All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.Simple.Haddock ( + haddock, hscolour + ) where + +-- local +import Distribution.Package + ( PackageIdentifier, Package(..), packageName ) +import qualified Distribution.ModuleName as ModuleName +import Distribution.PackageDescription as PD + ( PackageDescription(..), BuildInfo(..), allExtensions + , Library(..), hasLibs, Executable(..) ) +import Distribution.Simple.Compiler + ( Compiler(..), compilerVersion ) +import Distribution.Simple.GHC ( ghcLibDir ) +import Distribution.Simple.Program + ( ConfiguredProgram(..), requireProgramVersion + , rawSystemProgram, rawSystemProgramStdout + , hscolourProgram, haddockProgram ) +import Distribution.Simple.PreProcess (ppCpp', ppUnlit + , PPSuffixHandler, runSimplePreProcessor + , preprocessComponent) +import Distribution.Simple.Setup + ( defaultHscolourFlags, Flag(..), flagToMaybe, fromFlag + , HaddockFlags(..), HscolourFlags(..) ) +import Distribution.Simple.Build (initialBuildSteps) +import Distribution.Simple.InstallDirs (InstallDirs(..), PathTemplate, + PathTemplateVariable(..), + toPathTemplate, fromPathTemplate, + substPathTemplate, + initialPathTemplateEnv) +import Distribution.Simple.LocalBuildInfo + ( LocalBuildInfo(..), externalPackageDeps + , Component(..), ComponentLocalBuildInfo(..), withComponentsLBI ) +import Distribution.Simple.BuildPaths ( haddockName, + hscolourPref, autogenModulesDir, + ) +import Distribution.Simple.PackageIndex (dependencyClosure) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo + ( InstalledPackageInfo_(..) ) +import Distribution.InstalledPackageInfo + ( InstalledPackageInfo ) +import Distribution.Simple.Utils + ( die, warn, notice, intercalate, setupMessage + , createDirectoryIfMissingVerbose, withTempFile, copyFileVerbose + , withTempDirectory + , findFileWithExtension, findFile ) +import Distribution.Simple.GHC (ghcOptions) +import Distribution.Text + ( display, simpleParse ) + +import Distribution.Verbosity +import Language.Haskell.Extension +-- Base +import System.Directory(removeFile, doesFileExist, createDirectoryIfMissing) + +import Control.Monad ( when, guard ) +import Control.Exception (assert) +import Data.Monoid +import Data.Maybe ( fromMaybe, listToMaybe ) + +import System.FilePath((), (<.>), splitFileName, splitExtension, + normalise, splitPath, joinPath) +import System.IO (hClose, hPutStrLn) +import Distribution.Version + +-- Types + +-- | record that represents the arguments to the haddock executable, a product monoid. +data HaddockArgs = HaddockArgs { + argInterfaceFile :: Flag FilePath, -- ^ path of the interface file, relative to argOutputDir, required. + argPackageName :: Flag PackageIdentifier, -- ^ package name, required. + argHideModules :: (All,[ModuleName.ModuleName]), -- ^ (hide modules ?, modules to hide) + argIgnoreExports :: Any, -- ^ ingore export lists in modules? + argLinkSource :: Flag (Template,Template), -- ^ (template for modules, template for symbols) + argCssFile :: Flag FilePath, -- ^ optinal custom css file. + argVerbose :: Any, + argOutput :: Flag [Output], -- ^ Html or Hoogle doc or both? required. + argInterfaces :: [(FilePath, Maybe FilePath)], -- ^ [(interface file, path to the html docs for links)] + argOutputDir :: Directory, -- ^ where to generate the documentation. + argTitle :: Flag String, -- ^ page's title, required. + argPrologue :: Flag String, -- ^ prologue text, required. + argGhcFlags :: [String], -- ^ additional flags to pass to ghc for haddock-2 + argGhcLibDir :: Flag FilePath, -- ^ to find the correct ghc, required by haddock-2. + argTargets :: [FilePath] -- ^ modules to process. +} + +-- | the FilePath of a directory, it's a monoid under () +newtype Directory = Dir { unDir' :: FilePath } deriving (Read,Show,Eq,Ord) + +unDir :: Directory -> FilePath +unDir = joinPath . filter (\p -> p /="./" && p /= ".") . splitPath . unDir' + +type Template = String + +data Output = Html | Hoogle + +-- -------------------------------------------------------------------------- +-- Haddock support + +haddock :: PackageDescription -> LocalBuildInfo -> [PPSuffixHandler] -> HaddockFlags -> IO () +haddock pkg_descr _ _ haddockFlags + | not (hasLibs pkg_descr) + && not (fromFlag $ haddockExecutables haddockFlags) = + warn (fromFlag $ haddockVerbosity haddockFlags) $ + "No documentation was generated as this package does not contain " + ++ "a library. Perhaps you want to use the --executables flag." + +haddock pkg_descr lbi suffixes flags = do + + setupMessage verbosity "Running Haddock for" (packageId pkg_descr) + (confHaddock, version, _) <- + requireProgramVersion verbosity haddockProgram + (orLaterVersion (Version [0,6] [])) (withPrograms lbi) + + -- various sanity checks + let isVersion2 = version >= Version [2,0] [] + + when ( flag haddockHoogle + && version > Version [2] [] + && version < Version [2,2] []) $ + die "haddock 2.0 and 2.1 do not support the --hoogle flag." + + when (flag haddockHscolour && version < Version [0,8] []) $ + die "haddock --hyperlink-source requires Haddock version 0.8 or later" + + when isVersion2 $ do + haddockGhcVersionStr <- rawSystemProgramStdout verbosity confHaddock + ["--ghc-version"] + case simpleParse haddockGhcVersionStr of + Nothing -> die "Could not get GHC version from Haddock" + Just haddockGhcVersion + | haddockGhcVersion == ghcVersion -> return () + | otherwise -> die $ + "Haddock's internal GHC version must match the configured " + ++ "GHC version.\n" + ++ "The GHC version is " ++ display ghcVersion ++ " but " + ++ "haddock is using GHC version " ++ display haddockGhcVersion + where ghcVersion = compilerVersion (compiler lbi) + + -- the tools match the requests, we can proceed + + initialBuildSteps (flag haddockDistPref) pkg_descr lbi verbosity + + when (flag haddockHscolour) $ hscolour' pkg_descr lbi suffixes $ + defaultHscolourFlags `mappend` haddockToHscolour flags + + args <- fmap mconcat . sequence $ + [ getInterfaces verbosity lbi (flagToMaybe (haddockHtmlLocation flags)) + , getGhcLibDir verbosity lbi isVersion2 ] + ++ map return + [ fromFlags flags + , fromPackageDescription pkg_descr ] + + let pre c = preprocessComponent pkg_descr c lbi False verbosity suffixes + withComponentsLBI pkg_descr lbi $ \comp clbi -> do + pre comp + case comp of + CLib lib -> do + withTempDirectory verbosity (buildDir lbi) "tmp" $ \tmp -> do + let bi = libBuildInfo lib + libArgs <- fromLibrary tmp lbi lib clbi + libArgs' <- prepareSources verbosity tmp + lbi isVersion2 bi (args `mappend` libArgs) + runHaddock verbosity confHaddock libArgs' + CExe exe -> when (flag haddockExecutables) $ do + withTempDirectory verbosity (buildDir lbi) "tmp" $ \tmp -> do + let bi = buildInfo exe + exeArgs <- fromExecutable tmp lbi exe clbi + exeArgs' <- prepareSources verbosity tmp + lbi isVersion2 bi (args `mappend` exeArgs) + runHaddock verbosity confHaddock exeArgs' + _ -> return () + where + verbosity = flag haddockVerbosity + flag f = fromFlag $ f flags + +-- | performs cpp and unlit preprocessing where needed on the files in +-- | argTargets, which must have an .hs or .lhs extension. +prepareSources :: Verbosity + -> FilePath + -> LocalBuildInfo + -> Bool -- haddock == 2.* + -> BuildInfo + -> HaddockArgs + -> IO HaddockArgs +prepareSources verbosity tmp lbi isVersion2 bi args@HaddockArgs{argTargets=files} = + mapM (mockPP tmp) files >>= \targets -> return args {argTargets=targets} + where + mockPP pref file = do + let (filePref, fileName) = splitFileName file + targetDir = pref filePref + targetFile = targetDir fileName + (targetFileNoext, targetFileExt) = splitExtension $ targetFile + hsFile = targetFileNoext <.> "hs" + + assert (targetFileExt `elem` [".lhs",".hs"]) $ return () + + createDirectoryIfMissing True targetDir + + if needsCpp + then do + runSimplePreProcessor (ppCpp' defines bi lbi) + file targetFile verbosity + else + copyFileVerbose verbosity file targetFile + + when (targetFileExt == ".lhs") $ do + runSimplePreProcessor ppUnlit targetFile hsFile verbosity + removeFile targetFile + + return hsFile + needsCpp = EnableExtension CPP `elem` allExtensions bi + defines | isVersion2 = [] + | otherwise = ["-D__HADDOCK__"] + +-------------------------------------------------------------------------------------------------- +-- constributions to HaddockArgs + +fromFlags :: HaddockFlags -> HaddockArgs +fromFlags flags = + mempty { + argHideModules = (maybe mempty (All . not) $ flagToMaybe (haddockInternal flags), mempty), + argLinkSource = if fromFlag (haddockHscolour flags) + then Flag ("src/%{MODULE/./-}.html" + ,"src/%{MODULE/./-}.html#%{NAME}") + else NoFlag, + argCssFile = haddockCss flags, + argVerbose = maybe mempty (Any . (>= deafening)) . flagToMaybe $ haddockVerbosity flags, + argOutput = + Flag $ case [ Html | Flag True <- [haddockHtml flags] ] ++ + [ Hoogle | Flag True <- [haddockHoogle flags] ] + of [] -> [ Html ] + os -> os, + argOutputDir = maybe mempty Dir . flagToMaybe $ haddockDistPref flags + } + +fromPackageDescription :: PackageDescription -> HaddockArgs +fromPackageDescription pkg_descr = + mempty { + argInterfaceFile = Flag $ haddockName pkg_descr, + argPackageName = Flag $ packageId $ pkg_descr, + argOutputDir = Dir $ "doc" "html" display (packageName pkg_descr), + argPrologue = Flag $ if null desc then synopsis pkg_descr else desc, + argTitle = Flag $ showPkg ++ subtitle + } + where + desc = PD.description pkg_descr + showPkg = display (packageId pkg_descr) + subtitle | null (synopsis pkg_descr) = "" + | otherwise = ": " ++ synopsis pkg_descr + +fromLibrary :: FilePath + -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo + -> IO HaddockArgs +fromLibrary tmp lbi lib clbi = + do inFiles <- map snd `fmap` getLibSourceFiles lbi lib + return $ mempty { + argHideModules = (mempty,otherModules $ bi), + argGhcFlags = ghcOptions lbi bi clbi (buildDir lbi) + -- Noooooooooo!!!!!111 + -- haddock stomps on our precious .hi + -- and .o files. Workaround by telling + -- haddock to write them elsewhere. + ++ [ "-odir", tmp, "-hidir", tmp + , "-stubdir", tmp ], + argTargets = inFiles + } + where + bi = libBuildInfo lib + +fromExecutable :: FilePath + -> LocalBuildInfo -> Executable -> ComponentLocalBuildInfo + -> IO HaddockArgs +fromExecutable tmp lbi exe clbi = + do inFiles <- map snd `fmap` getExeSourceFiles lbi exe + return $ mempty { + argGhcFlags = ghcOptions lbi bi clbi (buildDir lbi) + -- Noooooooooo!!!!!111 + -- haddock stomps on our precious .hi + -- and .o files. Workaround by telling + -- haddock to write them elsewhere. + ++ [ "-odir", tmp, "-hidir", tmp + , "-stubdir", tmp ], + argOutputDir = Dir (exeName exe), + argTitle = Flag (exeName exe), + argTargets = inFiles + } + where + bi = buildInfo exe + +getInterfaces :: Verbosity + -> LocalBuildInfo + -> Maybe String -- ^ template for html location + -> IO HaddockArgs +getInterfaces verbosity lbi location = do + let htmlTemplate = fmap toPathTemplate $ location + (packageFlags, warnings) <- haddockPackageFlags lbi htmlTemplate + maybe (return ()) (warn verbosity) warnings + return $ mempty { + argInterfaces = packageFlags + } + +getGhcLibDir :: Verbosity -> LocalBuildInfo + -> Bool -- ^ are we using haddock-2.x ? + -> IO HaddockArgs +getGhcLibDir verbosity lbi isVersion2 + | isVersion2 = + do l <- ghcLibDir verbosity lbi + return $ mempty { argGhcLibDir = Flag l } + | otherwise = + return mempty + +---------------------------------------------------------------------------------------------- + +-- | Call haddock with the specified arguments. +runHaddock :: Verbosity -> ConfiguredProgram -> HaddockArgs -> IO () +runHaddock verbosity confHaddock args = do + let haddockVersion = fromMaybe (error "unable to determine haddock version") + (programVersion confHaddock) + renderArgs verbosity haddockVersion args $ \(flags,result)-> do + + rawSystemProgram verbosity confHaddock flags + + notice verbosity $ "Documentation created: " ++ result + + +renderArgs :: Verbosity + -> Version + -> HaddockArgs + -> (([[Char]], FilePath) -> IO a) + -> IO a +renderArgs verbosity version args k = do + createDirectoryIfMissingVerbose verbosity True outputDir + withTempFile outputDir "haddock-prolog.txt" $ \prologFileName h -> do + do + hPutStrLn h $ fromFlag $ argPrologue args + hClose h + let pflag = (:[]).("--prologue="++) $ prologFileName + k $ (pflag ++ renderPureArgs version args, result) + where + isVersion2 = version >= Version [2,0] [] + outputDir = (unDir $ argOutputDir args) + result = intercalate ", " + . map (\o -> outputDir + case o of + Html -> "index.html" + Hoogle -> pkgstr <.> "txt") + $ arg argOutput + where + pkgstr | isVersion2 = display $ packageName pkgid + | otherwise = display pkgid + pkgid = arg argPackageName + arg f = fromFlag $ f args + +renderPureArgs :: Version -> HaddockArgs -> [[Char]] +renderPureArgs version args = concat + [ + (:[]) . (\f -> "--dump-interface="++ unDir (argOutputDir args) f) + . fromFlag . argInterfaceFile $ args, + (\pkgName -> if isVersion2 + then ["--optghc=-package-name", "--optghc=" ++ pkgName] + else ["--package=" ++ pkgName]) . display . fromFlag . argPackageName $ args, + (\(All b,xs) -> bool (map (("--hide=" ++). display) xs) [] b) . argHideModules $ args, + bool ["--ignore-all-exports"] [] . getAny . argIgnoreExports $ args, + maybe [] (\(m,e) -> ["--source-module=" ++ m + ,"--source-entity=" ++ e]) . flagToMaybe . argLinkSource $ args, + maybe [] ((:[]).("--css="++)) . flagToMaybe . argCssFile $ args, + bool [] [verbosityFlag] . getAny . argVerbose $ args, + map (\o -> case o of Hoogle -> "--hoogle"; Html -> "--html") . fromFlag . argOutput $ args, + renderInterfaces . argInterfaces $ args, + (:[]).("--odir="++) . unDir . argOutputDir $ args, + (:[]).("--title="++) . (bool (++" (internal documentation)") id (getAny $ argIgnoreExports args)) + . fromFlag . argTitle $ args, + bool id (const []) isVersion2 . map ("--optghc=" ++) . argGhcFlags $ args, + maybe [] (\l -> ["-B"++l]) $ guard isVersion2 >> flagToMaybe (argGhcLibDir args), -- error if isVersion2 and Nothing? + argTargets $ args + ] + where + renderInterfaces = map (\(i,mh) -> "--read-interface=" ++ maybe "" (++",") mh ++ i) + bool a b c = if c then a else b + isVersion2 = version >= Version [2,0] [] + isVersion2_5 = version >= Version [2,5] [] + verbosityFlag + | isVersion2_5 = "--verbosity=1" + | otherwise = "--verbose" + +----------------------------------------------------------------------------------------------------------- + +haddockPackageFlags :: LocalBuildInfo + -> Maybe PathTemplate + -> IO ([(FilePath,Maybe FilePath)], Maybe String) +haddockPackageFlags lbi htmlTemplate = do + let allPkgs = installedPkgs lbi + directDeps = map fst (externalPackageDeps lbi) + transitiveDeps <- case dependencyClosure allPkgs directDeps of + Left x -> return x + Right _ -> die "Can't find transitive deps for haddock" + interfaces <- sequence + [ case interfaceAndHtmlPath ipkg of + Nothing -> return (Left (packageId ipkg)) + Just (interface, html) -> do + exists <- doesFileExist interface + if exists + then return (Right (interface, html)) + else return (Left (packageId ipkg)) + | ipkg <- PackageIndex.allPackages transitiveDeps ] + + let missing = [ pkgid | Left pkgid <- interfaces ] + warning = "The documentation for the following packages are not " + ++ "installed. No links will be generated to these packages: " + ++ intercalate ", " (map display missing) + flags = [ (interface, if null html then Nothing else Just html) + | Right (interface, html) <- interfaces ] + + return (flags, if null missing then Nothing else Just warning) + + where + interfaceAndHtmlPath :: InstalledPackageInfo -> Maybe (FilePath, FilePath) + interfaceAndHtmlPath pkg = do + interface <- listToMaybe (InstalledPackageInfo.haddockInterfaces pkg) + html <- case htmlTemplate of + Nothing -> listToMaybe (InstalledPackageInfo.haddockHTMLs pkg) + Just htmlPathTemplate -> Just (expandTemplateVars htmlPathTemplate) + return (interface, html) + + where expandTemplateVars = fromPathTemplate . substPathTemplate env + env = (PrefixVar, prefix (installDirTemplates lbi)) + : initialPathTemplateEnv (packageId pkg) (compilerId (compiler lbi)) + +-- -------------------------------------------------------------------------- +-- hscolour support + +hscolour :: PackageDescription -> LocalBuildInfo -> [PPSuffixHandler] -> HscolourFlags -> IO () +hscolour pkg_descr lbi suffixes flags = do + -- we preprocess even if hscolour won't be found on the machine + -- will this upset someone? + initialBuildSteps distPref pkg_descr lbi verbosity + hscolour' pkg_descr lbi suffixes flags + where + verbosity = fromFlag (hscolourVerbosity flags) + distPref = fromFlag $ hscolourDistPref flags + +hscolour' :: PackageDescription + -> LocalBuildInfo + -> [PPSuffixHandler] + -> HscolourFlags + -> IO () +hscolour' pkg_descr lbi suffixes flags = do + let distPref = fromFlag $ hscolourDistPref flags + (hscolourProg, _, _) <- + requireProgramVersion + verbosity hscolourProgram + (orLaterVersion (Version [1,8] [])) (withPrograms lbi) + + setupMessage verbosity "Running hscolour for" (packageId pkg_descr) + createDirectoryIfMissingVerbose verbosity True $ hscolourPref distPref pkg_descr + + let pre c = preprocessComponent pkg_descr c lbi False verbosity suffixes + withComponentsLBI pkg_descr lbi $ \comp _ -> do + pre comp + case comp of + CLib lib -> do + let outputDir = hscolourPref distPref pkg_descr "src" + runHsColour hscolourProg outputDir =<< getLibSourceFiles lbi lib + CExe exe | fromFlag (hscolourExecutables flags) -> do + let outputDir = hscolourPref distPref pkg_descr exeName exe "src" + runHsColour hscolourProg outputDir =<< getExeSourceFiles lbi exe + _ -> return () + where + stylesheet = flagToMaybe (hscolourCSS flags) + + verbosity = fromFlag (hscolourVerbosity flags) + + runHsColour prog outputDir moduleFiles = do + createDirectoryIfMissingVerbose verbosity True outputDir + + case stylesheet of -- copy the CSS file + Nothing | programVersion prog >= Just (Version [1,9] []) -> + rawSystemProgram verbosity prog + ["-print-css", "-o" ++ outputDir "hscolour.css"] + | otherwise -> return () + Just s -> copyFileVerbose verbosity s (outputDir "hscolour.css") + + flip mapM_ moduleFiles $ \(m, inFile) -> + rawSystemProgram verbosity prog + ["-css", "-anchor", "-o" ++ outFile m, inFile] + where + outFile m = outputDir intercalate "-" (ModuleName.components m) <.> "html" + +haddockToHscolour :: HaddockFlags -> HscolourFlags +haddockToHscolour flags = + HscolourFlags { + hscolourCSS = haddockHscolourCss flags, + hscolourExecutables = haddockExecutables flags, + hscolourVerbosity = haddockVerbosity flags, + hscolourDistPref = haddockDistPref flags + } +---------------------------------------------------------------------------------------------- +-- TODO these should be moved elsewhere. + +getLibSourceFiles :: LocalBuildInfo + -> Library + -> IO [(ModuleName.ModuleName, FilePath)] +getLibSourceFiles lbi lib = getSourceFiles searchpaths modules + where + bi = libBuildInfo lib + modules = PD.exposedModules lib ++ otherModules bi + searchpaths = autogenModulesDir lbi : buildDir lbi : hsSourceDirs bi + +getExeSourceFiles :: LocalBuildInfo + -> Executable + -> IO [(ModuleName.ModuleName, FilePath)] +getExeSourceFiles lbi exe = do + moduleFiles <- getSourceFiles searchpaths modules + srcMainPath <- findFile (hsSourceDirs bi) (modulePath exe) + return ((ModuleName.main, srcMainPath) : moduleFiles) + where + bi = buildInfo exe + modules = otherModules bi + searchpaths = autogenModulesDir lbi : exeBuildDir lbi exe : hsSourceDirs bi + +getSourceFiles :: [FilePath] + -> [ModuleName.ModuleName] + -> IO [(ModuleName.ModuleName, FilePath)] +getSourceFiles dirs modules = flip mapM modules $ \m -> fmap ((,) m) $ + findFileWithExtension ["hs", "lhs"] dirs (ModuleName.toFilePath m) + >>= maybe (notFound m) (return . normalise) + where + notFound module_ = die $ "can't find source for module " ++ display module_ + +-- | The directory where we put build results for an executable +exeBuildDir :: LocalBuildInfo -> Executable -> FilePath +exeBuildDir lbi exe = buildDir lbi exeName exe exeName exe ++ "-tmp" + +--------------------------------------------------------------------------------------------- + + + + +-- boilerplate monoid instance. +instance Monoid HaddockArgs where + mempty = HaddockArgs { + argInterfaceFile = mempty, + argPackageName = mempty, + argHideModules = mempty, + argIgnoreExports = mempty, + argLinkSource = mempty, + argCssFile = mempty, + argVerbose = mempty, + argOutput = mempty, + argInterfaces = mempty, + argOutputDir = mempty, + argTitle = mempty, + argPrologue = mempty, + argGhcFlags = mempty, + argGhcLibDir = mempty, + argTargets = mempty + } + mappend a b = HaddockArgs { + argInterfaceFile = mult argInterfaceFile, + argPackageName = mult argPackageName, + argHideModules = mult argHideModules, + argIgnoreExports = mult argIgnoreExports, + argLinkSource = mult argLinkSource, + argCssFile = mult argCssFile, + argVerbose = mult argVerbose, + argOutput = mult argOutput, + argInterfaces = mult argInterfaces, + argOutputDir = mult argOutputDir, + argTitle = mult argTitle, + argPrologue = mult argPrologue, + argGhcFlags = mult argGhcFlags, + argGhcLibDir = mult argGhcLibDir, + argTargets = mult argTargets + } + where mult f = f a `mappend` f b + +instance Monoid Directory where + mempty = Dir "." + mappend (Dir m) (Dir n) = Dir $ m n diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/Hpc.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/Hpc.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/Hpc.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/Hpc.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,185 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Hpc +-- Copyright : Thomas Tuegel 2011 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module provides functions for locating various HPC-related paths and +-- a function for adding the necessary options to a PackageDescription to +-- build test suites with HPC enabled. + +{- All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.Simple.Hpc + ( hpcDir + , enableCoverage + , tixDir + , tixFilePath + , doHpcMarkup + , findTixFiles + ) where + +import Control.Exception ( bracket ) +import Control.Monad ( unless, when ) +import Distribution.Compiler ( CompilerFlavor(..) ) +import Distribution.ModuleName ( main ) +import Distribution.PackageDescription + ( BuildInfo(..) + , Library(..) + , PackageDescription(..) + , TestSuite(..) + , testModules + ) +import Distribution.Simple.Utils ( die, notice ) +import Distribution.Text +import Distribution.Verbosity ( Verbosity() ) +import System.Directory ( doesFileExist, getDirectoryContents, removeFile ) +import System.Exit ( ExitCode(..) ) +import System.FilePath +import System.IO ( hClose, IOMode(..), openFile, openTempFile ) +import System.Process ( runProcess, waitForProcess ) + +-- ------------------------------------------------------------------------- +-- Haskell Program Coverage + +-- | Conditionally enable Haskell Program Coverage by adding the necessary +-- GHC options to a PackageDescription. +-- +-- TODO: do this differently in the build stage by constructing local build +-- info, not by modifying the original PackageDescription. +-- +enableCoverage :: Bool -- ^ Enable coverage? + -> String -- ^ \"dist/\" prefix + -> PackageDescription + -> PackageDescription +enableCoverage False _ x = x +enableCoverage True distPref p = + p { library = fmap enableLibCoverage (library p) + , testSuites = map enableTestCoverage (testSuites p) + } + where + enableBICoverage name oldBI = + let oldOptions = options oldBI + oldGHCOpts = lookup GHC oldOptions + newGHCOpts = case oldGHCOpts of + Just xs -> (GHC, hpcOpts ++ xs) + _ -> (GHC, hpcOpts) + newOptions = (:) newGHCOpts $ filter ((== GHC) . fst) oldOptions + hpcOpts = ["-fhpc", "-hpcdir", hpcDir distPref name] + in oldBI { options = newOptions } + enableLibCoverage l = + l { libBuildInfo = enableBICoverage (display $ package p) + (libBuildInfo l) + } + enableTestCoverage t = + t { testBuildInfo = enableBICoverage (testName t) (testBuildInfo t) } + +hpcDir :: FilePath -- ^ \"dist/\" prefix + -> FilePath -- ^ Component subdirectory name + -> FilePath -- ^ Directory containing component's HPC .mix files +hpcDir distPref name = distPref "hpc" name + +tixDir :: FilePath -- ^ \"dist/\" prefix + -> TestSuite -- ^ Test suite + -> FilePath -- ^ Directory containing test suite's .tix files +tixDir distPref suite = distPref "test" testName suite + +-- | Path to the .tix file containing a test suite's sum statistics. +tixFilePath :: FilePath -- ^ \"dist/\" prefix + -> TestSuite -- ^ Test suite + -> FilePath -- Path to test suite's .tix file +tixFilePath distPref suite = tixDir distPref suite testName suite <.> "tix" + +-- | Returns a list of all the .tix files in a test suite's .tix file +-- directory. Returned paths are the complete relative path to each file. +findTixFiles :: FilePath -- ^ \"dist/\" prefix + -> TestSuite -- ^ Test suite + -> IO [FilePath] -- ^ All .tix files belonging to test suite +findTixFiles distPref suite = do + files <- getDirectoryContents $ tixDir distPref suite + let tixFiles = flip filter files $ \x -> takeExtension x == ".tix" + return $ map (tixDir distPref suite ) tixFiles + +-- | Generate the HTML markup for a test suite. +doHpcMarkup :: Verbosity + -> FilePath -- ^ \"dist/\" prefix + -> String -- ^ Library name + -> TestSuite + -> IO () +doHpcMarkup verbosity distPref libName suite = do + tixFiles <- findTixFiles distPref suite + when (not $ null tixFiles) $ do + let hpcOptions = map (\x -> "--exclude=" ++ display x) excluded + unionOptions = [ "sum" + , "--union" + , "--output=" ++ tixFilePath distPref suite + ] + ++ hpcOptions ++ tixFiles + markupOptions = [ "markup" + , tixFilePath distPref suite + , "--hpcdir=" ++ hpcDir distPref libName + , "--destdir=" ++ tixDir distPref suite + ] + ++ hpcOptions + excluded = testModules suite ++ [ main ] + --TODO: use standard process utilities from D.S.Utils + runHpc opts h = runProcess "hpc" opts Nothing Nothing Nothing + (Just h) (Just h) + bracket (openHpcTemp $ tixDir distPref suite) deleteIfExists + $ \hpcOut -> do + hUnion <- openFile hpcOut AppendMode + procUnion <- runHpc unionOptions hUnion + exitUnion <- waitForProcess procUnion + success <- case exitUnion of + ExitSuccess -> do + hMarkup <- openFile hpcOut AppendMode + procMarkup <- runHpc markupOptions hMarkup + exitMarkup <- waitForProcess procMarkup + case exitMarkup of + ExitSuccess -> return True + _ -> return False + _ -> return False + unless success $ do + errs <- readFile hpcOut + die $ "HPC failed:\n" ++ errs + when success $ notice verbosity + $ "Test coverage report written to " + ++ tixDir distPref suite "hpc_index" + <.> "html" + return () + where openHpcTemp dir = do + (f, h) <- openTempFile dir $ "cabal-test-hpc-" <.> "log" + hClose h >> return f + deleteIfExists path = do + exists <- doesFileExist path + when exists $ removeFile path diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/Hugs.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/Hugs.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/Hugs.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/Hugs.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,632 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Hugs +-- Copyright : Isaac Jones 2003-2006 +-- Duncan Coutts 2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module contains most of the NHC-specific code for configuring, building +-- and installing packages. + +{- Copyright (c) 2003-2005, Isaac Jones +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.Simple.Hugs ( + configure, + getInstalledPackages, + buildLib, + buildExe, + install, + registerPackage, + ) where + +import Distribution.Package + ( PackageName, PackageIdentifier(..), InstalledPackageId(..) + , packageName ) +import Distribution.InstalledPackageInfo + ( InstalledPackageInfo, emptyInstalledPackageInfo + , InstalledPackageInfo_( InstalledPackageInfo, installedPackageId + , sourcePackageId ) + , parseInstalledPackageInfo, showInstalledPackageInfo ) +import Distribution.PackageDescription + ( PackageDescription(..), BuildInfo(..), hcOptions, allExtensions + , Executable(..), withExe, Library(..), withLib, libModules ) +import Distribution.ModuleName (ModuleName) +import qualified Distribution.ModuleName as ModuleName +import Distribution.Simple.Compiler + ( CompilerFlavor(..), CompilerId(..) + , Compiler(..), Flag, languageToFlags, extensionsToFlags + , PackageDB(..), PackageDBStack ) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.PackageIndex (PackageIndex) +import Distribution.Simple.Program + ( Program(programFindVersion) + , ProgramConfiguration, userMaybeSpecifyPath + , requireProgram, requireProgramVersion + , rawSystemProgramConf, programPath + , ffihugsProgram, hugsProgram ) +import Distribution.Version + ( Version(..), orLaterVersion ) +import Distribution.Simple.PreProcess ( ppCpp, runSimplePreProcessor ) +import Distribution.Simple.PreProcess.Unlit + ( unlit ) +import Distribution.Simple.LocalBuildInfo + ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) + , InstallDirs(..), absoluteInstallDirs ) +import Distribution.Simple.BuildPaths + ( autogenModuleName, autogenModulesDir, + dllExtension ) +import Distribution.Simple.Setup + ( CopyDest(..) ) +import Distribution.Simple.Utils + ( createDirectoryIfMissingVerbose + , installOrdinaryFiles, setFileExecutable + , withUTF8FileContents, writeFileAtomic, writeUTF8File + , copyFileVerbose, findFile, findFileWithExtension, findModuleFiles + , rawSystemStdInOut + , die, info, notice ) +import Language.Haskell.Extension + ( Language(Haskell98), Extension(..), KnownExtension(..) ) +import System.FilePath ( (), takeExtension, (<.>), + searchPathSeparator, normalise, takeDirectory ) +import Distribution.System + ( OS(..), buildOS ) +import Distribution.Text + ( display, simpleParse ) +import Distribution.ParseUtils + ( ParseResult(..) ) +import Distribution.Verbosity + +import Data.Char ( isSpace ) +import Data.Maybe ( mapMaybe, catMaybes ) +import Data.Monoid ( Monoid(..) ) +import Control.Monad ( unless, when, filterM ) +import Data.List ( nub, sort, isSuffixOf ) +import System.Directory + ( doesFileExist, doesDirectoryExist, getDirectoryContents + , removeDirectoryRecursive, getHomeDirectory ) +import System.Exit + ( ExitCode(ExitSuccess) ) +import Distribution.Compat.Exception + +-- ----------------------------------------------------------------------------- +-- Configuring + +configure :: Verbosity -> Maybe FilePath -> Maybe FilePath + -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration) +configure verbosity hcPath _hcPkgPath conf = do + + (_ffihugsProg, conf') <- requireProgram verbosity ffihugsProgram + (userMaybeSpecifyPath "ffihugs" hcPath conf) + (_hugsProg, version, conf'') + <- requireProgramVersion verbosity hugsProgram' + (orLaterVersion (Version [2006] [])) conf' + + let comp = Compiler { + compilerId = CompilerId Hugs version, + compilerLanguages = hugsLanguages, + compilerExtensions = hugsLanguageExtensions + } + return (comp, conf'') + + where + hugsProgram' = hugsProgram { programFindVersion = getVersion } + +getVersion :: Verbosity -> FilePath -> IO (Maybe Version) +getVersion verbosity hugsPath = do + (output, _err, exit) <- rawSystemStdInOut verbosity hugsPath [] + (Just (":quit", False)) False + if exit == ExitSuccess + then return $! findVersion output + else return Nothing + + where + findVersion output = do + (monthStr, yearStr) <- selectWords output + year <- convertYear yearStr + month <- convertMonth monthStr + return (Version [year, month] []) + + selectWords output = + case [ (month, year) + | [_,_,"Version:", month, year,_] <- map words (lines output) ] of + [(month, year)] -> Just (month, year) + _ -> Nothing + convertYear year = case reads year of + [(y, [])] | y >= 1999 && y < 2020 -> Just y + _ -> Nothing + convertMonth month = lookup month (zip months [1..]) + months = [ "January", "February", "March", "April", "May", "June", "July" + , "August", "September", "October", "November", "December" ] + +hugsLanguages :: [(Language, Flag)] +hugsLanguages = [(Haskell98, "")] --default is 98 mode + +-- | The flags for the supported extensions +hugsLanguageExtensions :: [(Extension, Flag)] +hugsLanguageExtensions = + let doFlag (f, (enable, disable)) = [(EnableExtension f, enable), + (DisableExtension f, disable)] + alwaysOn = ("", ""{- wrong -}) + ext98 = ("-98", ""{- wrong -}) + in concatMap doFlag + [(OverlappingInstances , ("+o", "-o")) + ,(IncoherentInstances , ("+oO", "-O")) + ,(HereDocuments , ("+H", "-H")) + ,(TypeSynonymInstances , ext98) + ,(RecursiveDo , ext98) + ,(ParallelListComp , ext98) + ,(MultiParamTypeClasses , ext98) + ,(FunctionalDependencies , ext98) + ,(Rank2Types , ext98) + ,(PolymorphicComponents , ext98) + ,(ExistentialQuantification , ext98) + ,(ScopedTypeVariables , ext98) + ,(ImplicitParams , ext98) + ,(ExtensibleRecords , ext98) + ,(RestrictedTypeSynonyms , ext98) + ,(FlexibleContexts , ext98) + ,(FlexibleInstances , ext98) + ,(ForeignFunctionInterface , alwaysOn) + ,(EmptyDataDecls , alwaysOn) + ,(CPP , alwaysOn) + ] + +getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration + -> IO PackageIndex +getInstalledPackages verbosity packagedbs conf = do + homedir <- getHomeDirectory + (hugsProg, _) <- requireProgram verbosity hugsProgram conf + let hugsbindir = takeDirectory (programPath hugsProg) + hugslibdir = takeDirectory hugsbindir "lib" "hugs" + dbdirs = nub (concatMap (packageDbPaths homedir hugslibdir) packagedbs) + indexes <- mapM getIndividualDBPackages dbdirs + return $! mconcat indexes + + where + getIndividualDBPackages :: FilePath -> IO PackageIndex + getIndividualDBPackages dbdir = do + pkgdirs <- getPackageDbDirs dbdir + pkgs <- sequence [ getInstalledPackage pkgname pkgdir + | (pkgname, pkgdir) <- pkgdirs ] + let pkgs' = map setInstalledPackageId (catMaybes pkgs) + return (PackageIndex.fromList pkgs') + +packageDbPaths :: FilePath -> FilePath -> PackageDB -> [FilePath] +packageDbPaths home hugslibdir db = case db of + GlobalPackageDB -> [ hugslibdir "packages" + , "/usr/local/lib/hugs/packages" ] + UserPackageDB -> [ home "lib/hugs/packages" ] + SpecificPackageDB path -> [ path ] + +getPackageDbDirs :: FilePath -> IO [(PackageName, FilePath)] +getPackageDbDirs dbdir = do + dbexists <- doesDirectoryExist dbdir + if not dbexists + then return [] + else do + entries <- getDirectoryContents dbdir + pkgdirs <- sequence + [ do pkgdirExists <- doesDirectoryExist pkgdir + return (pkgname, pkgdir, pkgdirExists) + | (entry, Just pkgname) <- [ (entry, simpleParse entry) + | entry <- entries ] + , let pkgdir = dbdir entry ] + return [ (pkgname, pkgdir) | (pkgname, pkgdir, True) <- pkgdirs ] + +getInstalledPackage :: PackageName -> FilePath -> IO (Maybe InstalledPackageInfo) +getInstalledPackage pkgname pkgdir = do + let pkgconfFile = pkgdir "package.conf" + pkgconfExists <- doesFileExist pkgconfFile + + let pathsModule = pkgdir ("Paths_" ++ display pkgname) <.> "hs" + pathsModuleExists <- doesFileExist pathsModule + + case () of + _ | pkgconfExists -> getFullInstalledPackageInfo pkgname pkgconfFile + | pathsModuleExists -> getPhonyInstalledPackageInfo pkgname pathsModule + | otherwise -> return Nothing + +getFullInstalledPackageInfo :: PackageName -> FilePath + -> IO (Maybe InstalledPackageInfo) +getFullInstalledPackageInfo pkgname pkgconfFile = + withUTF8FileContents pkgconfFile $ \contents -> + case parseInstalledPackageInfo contents of + ParseOk _ pkginfo | packageName pkginfo == pkgname + -> return (Just pkginfo) + _ -> return Nothing + +-- | This is a backup option for existing versions of Hugs which do not supply +-- proper installed package info files for the bundled libs. Instead we look +-- for the Paths_pkgname.hs file and extract the package version from that. +-- We don't know any other details for such packages, in particular we pretend +-- that they have no dependencies. +-- +getPhonyInstalledPackageInfo :: PackageName -> FilePath + -> IO (Maybe InstalledPackageInfo) +getPhonyInstalledPackageInfo pkgname pathsModule = do + content <- readFile pathsModule + case extractVersion content of + Nothing -> return Nothing + Just version -> return (Just pkginfo) + where + pkgid = PackageIdentifier pkgname version + pkginfo = emptyInstalledPackageInfo { sourcePackageId = pkgid } + where + -- search through the Paths_pkgname.hs file, looking for a line like: + -- + -- > version = Version {versionBranch = [2,0], versionTags = []} + -- + -- and parse it using 'Read'. Yes we are that evil. + -- + extractVersion content = + case [ version + | ("version":"=":rest) <- map words (lines content) + , (version, []) <- reads (concat rest) ] of + [version] -> Just version + _ -> Nothing + +-- Older installed package info files did not have the installedPackageId +-- field, so if it is missing then we fill it as the source package ID. +setInstalledPackageId :: InstalledPackageInfo -> InstalledPackageInfo +setInstalledPackageId pkginfo@InstalledPackageInfo { + installedPackageId = InstalledPackageId "", + sourcePackageId = pkgid + } + = pkginfo { + --TODO use a proper named function for the conversion + -- from source package id to installed package id + installedPackageId = InstalledPackageId (display pkgid) + } +setInstalledPackageId pkginfo = pkginfo + +-- ----------------------------------------------------------------------------- +-- Building + +-- |Building a package for Hugs. +buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo + -> Library -> ComponentLocalBuildInfo -> IO () +buildLib verbosity pkg_descr lbi lib _clbi = do + let pref = scratchDir lbi + createDirectoryIfMissingVerbose verbosity True pref + copyFileVerbose verbosity (autogenModulesDir lbi paths_modulename) + (pref paths_modulename) + compileBuildInfo verbosity pref [] (libModules lib) (libBuildInfo lib) lbi + where + paths_modulename = ModuleName.toFilePath (autogenModuleName pkg_descr) + <.> ".hs" + --TODO: switch to using autogenModulesDir as a search dir, rather than + -- always copying the file over. + +-- |Building an executable for Hugs. +buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo + -> Executable -> ComponentLocalBuildInfo -> IO () +buildExe verbosity pkg_descr lbi + exe@Executable {modulePath=mainPath, buildInfo=bi} _clbi = do + let pref = scratchDir lbi + createDirectoryIfMissingVerbose verbosity True pref + + let destDir = pref "programs" + let exeMods = otherModules bi + srcMainFile <- findFile (hsSourceDirs bi) mainPath + let exeDir = destDir exeName exe + let destMainFile = exeDir hugsMainFilename exe + copyModule verbosity (EnableExtension CPP `elem` allExtensions bi) bi lbi srcMainFile destMainFile + let destPathsFile = exeDir paths_modulename + copyFileVerbose verbosity (autogenModulesDir lbi paths_modulename) + destPathsFile + compileBuildInfo verbosity exeDir + (maybe [] (hsSourceDirs . libBuildInfo) (library pkg_descr)) exeMods bi lbi + compileFiles verbosity bi lbi exeDir [destMainFile, destPathsFile] + + where + paths_modulename = ModuleName.toFilePath (autogenModuleName pkg_descr) + <.> ".hs" + +compileBuildInfo :: Verbosity + -> FilePath -- ^output directory + -> [FilePath] -- ^library source dirs, if building exes + -> [ModuleName] -- ^Modules + -> BuildInfo + -> LocalBuildInfo + -> IO () +--TODO: should not be using mLibSrcDirs at all +compileBuildInfo verbosity destDir mLibSrcDirs mods bi lbi = do + -- Pass 1: copy or cpp files from build directory to scratch directory + let useCpp = EnableExtension CPP `elem` allExtensions bi + let srcDir = buildDir lbi + srcDirs = nub $ srcDir : hsSourceDirs bi ++ mLibSrcDirs + info verbosity $ "Source directories: " ++ show srcDirs + flip mapM_ mods $ \ m -> do + fs <- findFileWithExtension suffixes srcDirs (ModuleName.toFilePath m) + case fs of + Nothing -> + die ("can't find source for module " ++ display m) + Just srcFile -> do + let ext = takeExtension srcFile + copyModule verbosity useCpp bi lbi srcFile + (destDir ModuleName.toFilePath m <.> ext) + -- Pass 2: compile foreign stubs in scratch directory + stubsFileLists <- fmap catMaybes $ sequence + [ findFileWithExtension suffixes [destDir] (ModuleName.toFilePath modu) + | modu <- mods] + compileFiles verbosity bi lbi destDir stubsFileLists + +suffixes :: [String] +suffixes = ["hs", "lhs"] + +-- Copy or cpp a file from the source directory to the build directory. +copyModule :: Verbosity -> Bool -> BuildInfo -> LocalBuildInfo -> FilePath -> FilePath -> IO () +copyModule verbosity cppAll bi lbi srcFile destFile = do + createDirectoryIfMissingVerbose verbosity True (takeDirectory destFile) + (exts, opts, _) <- getOptionsFromSource srcFile + let ghcOpts = [ op | (GHC, ops) <- opts, op <- ops ] + if cppAll || EnableExtension CPP `elem` exts || "-cpp" `elem` ghcOpts then do + runSimplePreProcessor (ppCpp bi lbi) srcFile destFile verbosity + return () + else + copyFileVerbose verbosity srcFile destFile + +compileFiles :: Verbosity -> BuildInfo -> LocalBuildInfo -> FilePath -> [FilePath] -> IO () +compileFiles verbosity bi lbi modDir fileList = do + ffiFileList <- filterM testFFI fileList + unless (null ffiFileList) $ do + notice verbosity "Compiling FFI stubs" + mapM_ (compileFFI verbosity bi lbi modDir) ffiFileList + +-- Only compile FFI stubs for a file if it contains some FFI stuff +testFFI :: FilePath -> IO Bool +testFFI file = + withHaskellFile file $ \inp -> + return $! "foreign" `elem` symbols (stripComments False inp) + +compileFFI :: Verbosity -> BuildInfo -> LocalBuildInfo -> FilePath -> FilePath -> IO () +compileFFI verbosity bi lbi modDir file = do + (_, opts, file_incs) <- getOptionsFromSource file + let ghcOpts = [ op | (GHC, ops) <- opts, op <- ops ] + let pkg_incs = ["\"" ++ inc ++ "\"" | inc <- includes bi] + let incs = nub (sort (file_incs ++ includeOpts ghcOpts ++ pkg_incs)) + let pathFlag = "-P" ++ modDir ++ [searchPathSeparator] + let hugsArgs = "-98" : pathFlag : map ("-i" ++) incs + cfiles <- getCFiles file + let cArgs = + ["-I" ++ dir | dir <- includeDirs bi] ++ + ccOptions bi ++ + cfiles ++ + ["-L" ++ dir | dir <- extraLibDirs bi] ++ + ldOptions bi ++ + ["-l" ++ lib | lib <- extraLibs bi] ++ + concat [["-framework", f] | f <- frameworks bi] + rawSystemProgramConf verbosity ffihugsProgram (withPrograms lbi) + (hugsArgs ++ file : cArgs) + +includeOpts :: [String] -> [String] +includeOpts [] = [] +includeOpts ("-#include" : arg : opts) = arg : includeOpts opts +includeOpts (_ : opts) = includeOpts opts + +-- get C file names from CFILES pragmas throughout the source file +getCFiles :: FilePath -> IO [String] +getCFiles file = + withHaskellFile file $ \inp -> + let cfiles = + [ normalise cfile + | "{-#" : "CFILES" : rest <- map words + $ lines + $ stripComments True inp + , last rest == "#-}" + , cfile <- init rest] + in seq (length cfiles) (return cfiles) + +-- List of terminal symbols in a source file. +symbols :: String -> [String] +symbols cs = case lex cs of + (sym, cs'):_ | not (null sym) -> sym : symbols cs' + _ -> [] + +-- Get the non-literate source of a Haskell module. +withHaskellFile :: FilePath -> (String -> IO a) -> IO a +withHaskellFile file action = + withUTF8FileContents file $ \text -> + if ".lhs" `isSuffixOf` file + then either action die (unlit file text) + else action text + +-- ------------------------------------------------------------ +-- * options in source files +-- ------------------------------------------------------------ + +-- |Read the initial part of a source file, before any Haskell code, +-- and return the contents of any LANGUAGE, OPTIONS and INCLUDE pragmas. +getOptionsFromSource + :: FilePath + -> IO ([Extension], -- LANGUAGE pragma, if any + [(CompilerFlavor,[String])], -- OPTIONS_FOO pragmas + [String] -- INCLUDE pragmas + ) +getOptionsFromSource file = + withHaskellFile file $ + (return $!) + . foldr appendOptions ([],[],[]) . map getOptions + . takeWhileJust . map getPragma + . filter textLine . map (dropWhile isSpace) . lines + . stripComments True + + where textLine [] = False + textLine ('#':_) = False + textLine _ = True + + getPragma :: String -> Maybe [String] + getPragma line = case words line of + ("{-#" : rest) | last rest == "#-}" -> Just (init rest) + _ -> Nothing + + getOptions ("OPTIONS":opts) = ([], [(GHC, opts)], []) + getOptions ("OPTIONS_GHC":opts) = ([], [(GHC, opts)], []) + getOptions ("OPTIONS_NHC98":opts) = ([], [(NHC, opts)], []) + getOptions ("OPTIONS_HUGS":opts) = ([], [(Hugs, opts)], []) + getOptions ("LANGUAGE":ws) = (mapMaybe readExtension ws, [], []) + where readExtension :: String -> Maybe Extension + readExtension w = case reads w of + [(ext, "")] -> Just ext + [(ext, ",")] -> Just ext + _ -> Nothing + getOptions ("INCLUDE":ws) = ([], [], ws) + getOptions _ = ([], [], []) + + appendOptions (exts, opts, incs) (exts', opts', incs') + = (exts++exts', opts++opts', incs++incs') + +-- takeWhileJust f = map fromJust . takeWhile isJust +takeWhileJust :: [Maybe a] -> [a] +takeWhileJust (Just x:xs) = x : takeWhileJust xs +takeWhileJust _ = [] + +-- |Strip comments from Haskell source. +stripComments + :: Bool -- ^ preserve pragmas? + -> String -- ^ input source text + -> String +stripComments keepPragmas = stripCommentsLevel 0 + where stripCommentsLevel :: Int -> String -> String + stripCommentsLevel 0 ('"':cs) = '"':copyString cs + stripCommentsLevel 0 ('-':'-':cs) = -- FIX: symbols like --> + stripCommentsLevel 0 (dropWhile (/= '\n') cs) + stripCommentsLevel 0 ('{':'-':'#':cs) + | keepPragmas = '{' : '-' : '#' : copyPragma cs + stripCommentsLevel n ('{':'-':cs) = stripCommentsLevel (n+1) cs + stripCommentsLevel 0 (c:cs) = c : stripCommentsLevel 0 cs + stripCommentsLevel n ('-':'}':cs) = stripCommentsLevel (n-1) cs + stripCommentsLevel n (_:cs) = stripCommentsLevel n cs + stripCommentsLevel _ [] = [] + + copyString ('\\':c:cs) = '\\' : c : copyString cs + copyString ('"':cs) = '"' : stripCommentsLevel 0 cs + copyString (c:cs) = c : copyString cs + copyString [] = [] + + copyPragma ('#':'-':'}':cs) = '#' : '-' : '}' : stripCommentsLevel 0 cs + copyPragma (c:cs) = c : copyPragma cs + copyPragma [] = [] + +-- ----------------------------------------------------------------------------- +-- |Install for Hugs. +-- For install, copy-prefix = prefix, but for copy they're different. +-- The library goes in \\/lib\/hugs\/packages\/\ +-- (i.e. \\/lib\/hugs\/packages\/\ on the target system). +-- Each executable goes in \\/lib\/hugs\/programs\/\ +-- (i.e. \\/lib\/hugs\/programs\/\ on the target system) +-- with a script \\/bin\/\ pointing at +-- \\/lib\/hugs\/programs\/\. +install + :: Verbosity -- ^verbosity + -> LocalBuildInfo + -> FilePath -- ^Library install location + -> FilePath -- ^Program install location + -> FilePath -- ^Executable install location + -> FilePath -- ^Program location on target system + -> FilePath -- ^Build location + -> (FilePath,FilePath) -- ^Executable (prefix,suffix) + -> PackageDescription + -> IO () +--FIXME: this script should be generated at build time, just installed at this stage +install verbosity lbi libDir installProgDir binDir targetProgDir buildPref (progprefix,progsuffix) pkg_descr = do + removeDirectoryRecursive libDir `catchIO` \_ -> return () + withLib pkg_descr $ \ lib -> + findModuleFiles [buildPref] hugsInstallSuffixes (libModules lib) + >>= installOrdinaryFiles verbosity libDir + let buildProgDir = buildPref "programs" + when (any (buildable . buildInfo) (executables pkg_descr)) $ + createDirectoryIfMissingVerbose verbosity True binDir + withExe pkg_descr $ \ exe -> do + let bi = buildInfo exe + let theBuildDir = buildProgDir exeName exe + let installDir = installProgDir exeName exe + let targetDir = targetProgDir exeName exe + removeDirectoryRecursive installDir `catchIO` \_ -> return () + findModuleFiles [theBuildDir] hugsInstallSuffixes + (ModuleName.main : autogenModuleName pkg_descr + : otherModules (buildInfo exe)) + >>= installOrdinaryFiles verbosity installDir + let targetName = "\"" ++ (targetDir hugsMainFilename exe) ++ "\"" + let hugsOptions = hcOptions Hugs (buildInfo exe) + ++ languageToFlags (compiler lbi) (defaultLanguage bi) + ++ extensionsToFlags (compiler lbi) (allExtensions bi) + --TODO: also need to consider options, extensions etc of deps + -- see ticket #43 + let baseExeFile = progprefix ++ (exeName exe) ++ progsuffix + let exeFile = case buildOS of + Windows -> binDir baseExeFile <.> ".bat" + _ -> binDir baseExeFile + let script = case buildOS of + Windows -> + let args = hugsOptions ++ [targetName, "%*"] + in unlines ["@echo off", + unwords ("runhugs" : args)] + _ -> + let args = hugsOptions ++ [targetName, "\"$@\""] + in unlines ["#! /bin/sh", + unwords ("runhugs" : args)] + writeFileAtomic exeFile script + setFileExecutable exeFile + +hugsInstallSuffixes :: [String] +hugsInstallSuffixes = [".hs", ".lhs", dllExtension] + +-- |Filename used by Hugs for the main module of an executable. +-- This is a simple filename, so that Hugs will look for any auxiliary +-- modules it uses relative to the directory it's in. +hugsMainFilename :: Executable -> FilePath +hugsMainFilename exe = "Main" <.> ext + where ext = takeExtension (modulePath exe) + +-- ----------------------------------------------------------------------------- +-- Registering + +registerPackage + :: Verbosity + -> InstalledPackageInfo + -> PackageDescription + -> LocalBuildInfo + -> Bool + -> PackageDBStack + -> IO () +registerPackage verbosity installedPkgInfo pkg lbi inplace _packageDbs = do + --TODO: prefer to have it based on the packageDbs, but how do we know + -- the package subdir based on the name? the user can set crazy libsubdir + let installDirs = absoluteInstallDirs pkg lbi NoCopyDest + pkgdir | inplace = buildDir lbi + | otherwise = libdir installDirs + createDirectoryIfMissingVerbose verbosity True pkgdir + writeUTF8File (pkgdir "package.conf") + (showInstalledPackageInfo installedPkgInfo) diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/InstallDirs.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/InstallDirs.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/InstallDirs.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/InstallDirs.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,600 @@ +{-# LANGUAGE CPP, ForeignFunctionInterface #-} +{-# OPTIONS_NHC98 -cpp #-} +{-# OPTIONS_JHC -fcpp -fffi #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.InstallDirs +-- Copyright : Isaac Jones 2003-2004 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This manages everything to do with where files get installed (though does +-- not get involved with actually doing any installation). It provides an +-- 'InstallDirs' type which is a set of directories for where to install +-- things. It also handles the fact that we use templates in these install +-- dirs. For example most install dirs are relative to some @$prefix@ and by +-- changing the prefix all other dirs still end up changed appropriately. So it +-- provides a 'PathTemplate' type and functions for substituting for these +-- templates. + +{- All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.Simple.InstallDirs ( + InstallDirs(..), + InstallDirTemplates, + defaultInstallDirs, + combineInstallDirs, + absoluteInstallDirs, + CopyDest(..), + prefixRelativeInstallDirs, + substituteInstallDirTemplates, + + PathTemplate, + PathTemplateVariable(..), + toPathTemplate, + fromPathTemplate, + substPathTemplate, + initialPathTemplateEnv, + platformTemplateEnv, + compilerTemplateEnv, + packageTemplateEnv, + installDirsTemplateEnv, + ) where + + +import Data.List (isPrefixOf) +import Data.Maybe (fromMaybe) +import Data.Monoid (Monoid(..)) +import System.Directory (getAppUserDataDirectory) +import System.FilePath ((), isPathSeparator, pathSeparator) +#if __HUGS__ || __GLASGOW_HASKELL__ > 606 +import System.FilePath (dropDrive) +#endif + +import Distribution.Package + ( PackageIdentifier, packageName, packageVersion ) +import Distribution.System + ( OS(..), buildOS, Platform(..), buildPlatform ) +import Distribution.Compiler + ( CompilerId, CompilerFlavor(..) ) +import Distribution.Text + ( display ) + +#if mingw32_HOST_OS || mingw32_TARGET_OS +import Foreign +import Foreign.C +#endif + +-- --------------------------------------------------------------------------- +-- Instalation directories + + +-- | The directories where we will install files for packages. +-- +-- We have several different directories for different types of files since +-- many systems have conventions whereby different types of files in a package +-- are installed in different direcotries. This is particularly the case on +-- unix style systems. +-- +data InstallDirs dir = InstallDirs { + prefix :: dir, + bindir :: dir, + libdir :: dir, + libsubdir :: dir, + dynlibdir :: dir, + libexecdir :: dir, + progdir :: dir, + includedir :: dir, + datadir :: dir, + datasubdir :: dir, + docdir :: dir, + mandir :: dir, + htmldir :: dir, + haddockdir :: dir + } deriving (Read, Show) + +instance Functor InstallDirs where + fmap f dirs = InstallDirs { + prefix = f (prefix dirs), + bindir = f (bindir dirs), + libdir = f (libdir dirs), + libsubdir = f (libsubdir dirs), + dynlibdir = f (dynlibdir dirs), + libexecdir = f (libexecdir dirs), + progdir = f (progdir dirs), + includedir = f (includedir dirs), + datadir = f (datadir dirs), + datasubdir = f (datasubdir dirs), + docdir = f (docdir dirs), + mandir = f (mandir dirs), + htmldir = f (htmldir dirs), + haddockdir = f (haddockdir dirs) + } + +instance Monoid dir => Monoid (InstallDirs dir) where + mempty = InstallDirs { + prefix = mempty, + bindir = mempty, + libdir = mempty, + libsubdir = mempty, + dynlibdir = mempty, + libexecdir = mempty, + progdir = mempty, + includedir = mempty, + datadir = mempty, + datasubdir = mempty, + docdir = mempty, + mandir = mempty, + htmldir = mempty, + haddockdir = mempty + } + mappend = combineInstallDirs mappend + +combineInstallDirs :: (a -> b -> c) + -> InstallDirs a + -> InstallDirs b + -> InstallDirs c +combineInstallDirs combine a b = InstallDirs { + prefix = prefix a `combine` prefix b, + bindir = bindir a `combine` bindir b, + libdir = libdir a `combine` libdir b, + libsubdir = libsubdir a `combine` libsubdir b, + dynlibdir = dynlibdir a `combine` dynlibdir b, + libexecdir = libexecdir a `combine` libexecdir b, + progdir = progdir a `combine` progdir b, + includedir = includedir a `combine` includedir b, + datadir = datadir a `combine` datadir b, + datasubdir = datasubdir a `combine` datasubdir b, + docdir = docdir a `combine` docdir b, + mandir = mandir a `combine` mandir b, + htmldir = htmldir a `combine` htmldir b, + haddockdir = haddockdir a `combine` haddockdir b + } + +appendSubdirs :: (a -> a -> a) -> InstallDirs a -> InstallDirs a +appendSubdirs append dirs = dirs { + libdir = libdir dirs `append` libsubdir dirs, + datadir = datadir dirs `append` datasubdir dirs, + libsubdir = error "internal error InstallDirs.libsubdir", + datasubdir = error "internal error InstallDirs.datasubdir" + } + +-- | The installation directories in terms of 'PathTemplate's that contain +-- variables. +-- +-- The defaults for most of the directories are relative to each other, in +-- particular they are all relative to a single prefix. This makes it +-- convenient for the user to override the default installation directory +-- by only having to specify --prefix=... rather than overriding each +-- individually. This is done by allowing $-style variables in the dirs. +-- These are expanded by textual substituion (see 'substPathTemplate'). +-- +-- A few of these installation directories are split into two components, the +-- dir and subdir. The full installation path is formed by combining the two +-- together with @\/@. The reason for this is compatibility with other unix +-- build systems which also support @--libdir@ and @--datadir@. We would like +-- users to be able to configure @--libdir=\/usr\/lib64@ for example but +-- because by default we want to support installing multiple versions of +-- packages and building the same package for multiple compilers we append the +-- libsubdir to get: @\/usr\/lib64\/$pkgid\/$compiler@. +-- +-- An additional complication is the need to support relocatable packages on +-- systems which support such things, like Windows. +-- +type InstallDirTemplates = InstallDirs PathTemplate + +-- --------------------------------------------------------------------------- +-- Default installation directories + +defaultInstallDirs :: CompilerFlavor -> Bool -> Bool -> IO InstallDirTemplates +defaultInstallDirs comp userInstall _hasLibs = do + installPrefix <- + if userInstall + then getAppUserDataDirectory "cabal" + else case buildOS of + Windows -> do windowsProgramFilesDir <- getWindowsProgramFilesDir + return (windowsProgramFilesDir "Haskell") + _ -> return "/usr/local" + installLibDir <- + case buildOS of + Windows -> return "$prefix" + _ -> case comp of + LHC | userInstall -> getAppUserDataDirectory "lhc" + _ -> return ("$prefix" "lib") + return $ fmap toPathTemplate $ InstallDirs { + prefix = installPrefix, + bindir = "$prefix" "bin", + libdir = installLibDir, + libsubdir = case comp of + Hugs -> "hugs" "packages" "$pkg" + JHC -> "$compiler" + LHC -> "$compiler" + UHC -> "$pkgid" + _other -> "$pkgid" "$compiler", + dynlibdir = "$libdir", + libexecdir = case buildOS of + Windows -> "$prefix" "$pkgid" + _other -> "$prefix" "libexec", + progdir = "$libdir" "hugs" "programs", + includedir = "$libdir" "$libsubdir" "include", + datadir = case buildOS of + Windows -> "$prefix" + _other -> "$prefix" "share", + datasubdir = "$pkgid", + docdir = "$datadir" "doc" "$pkgid", + mandir = "$datadir" "man", + htmldir = "$docdir" "html", + haddockdir = "$htmldir" + } + +-- --------------------------------------------------------------------------- +-- Converting directories, absolute or prefix-relative + +-- | Substitute the install dir templates into each other. +-- +-- To prevent cyclic substitutions, only some variables are allowed in +-- particular dir templates. If out of scope vars are present, they are not +-- substituted for. Checking for any remaining unsubstituted vars can be done +-- as a subsequent operation. +-- +-- The reason it is done this way is so that in 'prefixRelativeInstallDirs' we +-- can replace 'prefix' with the 'PrefixVar' and get resulting +-- 'PathTemplate's that still have the 'PrefixVar' in them. Doing this makes it +-- each to check which paths are relative to the $prefix. +-- +substituteInstallDirTemplates :: PathTemplateEnv + -> InstallDirTemplates -> InstallDirTemplates +substituteInstallDirTemplates env dirs = dirs' + where + dirs' = InstallDirs { + -- So this specifies exactly which vars are allowed in each template + prefix = subst prefix [], + bindir = subst bindir [prefixVar], + libdir = subst libdir [prefixVar, bindirVar], + libsubdir = subst libsubdir [], + dynlibdir = subst dynlibdir [prefixVar, bindirVar, libdirVar], + libexecdir = subst libexecdir prefixBinLibVars, + progdir = subst progdir prefixBinLibVars, + includedir = subst includedir prefixBinLibVars, + datadir = subst datadir prefixBinLibVars, + datasubdir = subst datasubdir [], + docdir = subst docdir prefixBinLibDataVars, + mandir = subst mandir (prefixBinLibDataVars ++ [docdirVar]), + htmldir = subst htmldir (prefixBinLibDataVars ++ [docdirVar]), + haddockdir = subst haddockdir (prefixBinLibDataVars ++ + [docdirVar, htmldirVar]) + } + subst dir env' = substPathTemplate (env'++env) (dir dirs) + + prefixVar = (PrefixVar, prefix dirs') + bindirVar = (BindirVar, bindir dirs') + libdirVar = (LibdirVar, libdir dirs') + libsubdirVar = (LibsubdirVar, libsubdir dirs') + datadirVar = (DatadirVar, datadir dirs') + datasubdirVar = (DatasubdirVar, datasubdir dirs') + docdirVar = (DocdirVar, docdir dirs') + htmldirVar = (HtmldirVar, htmldir dirs') + prefixBinLibVars = [prefixVar, bindirVar, libdirVar, libsubdirVar] + prefixBinLibDataVars = prefixBinLibVars ++ [datadirVar, datasubdirVar] + +-- | Convert from abstract install directories to actual absolute ones by +-- substituting for all the variables in the abstract paths, to get real +-- absolute path. +absoluteInstallDirs :: PackageIdentifier -> CompilerId -> CopyDest + -> InstallDirs PathTemplate + -> InstallDirs FilePath +absoluteInstallDirs pkgId compilerId copydest dirs = + (case copydest of + CopyTo destdir -> fmap ((destdir ) . dropDrive) + _ -> id) + . appendSubdirs () + . fmap fromPathTemplate + $ substituteInstallDirTemplates env dirs + where + env = initialPathTemplateEnv pkgId compilerId + + +-- |The location prefix for the /copy/ command. +data CopyDest + = NoCopyDest + | CopyTo FilePath + deriving (Eq, Show) + +-- | Check which of the paths are relative to the installation $prefix. +-- +-- If any of the paths are not relative, ie they are absolute paths, then it +-- prevents us from making a relocatable package (also known as a \"prefix +-- independent\" package). +-- +prefixRelativeInstallDirs :: PackageIdentifier -> CompilerId + -> InstallDirTemplates + -> InstallDirs (Maybe FilePath) +prefixRelativeInstallDirs pkgId compilerId dirs = + fmap relative + . appendSubdirs combinePathTemplate + $ -- substitute the path template into each other, except that we map + -- \$prefix back to $prefix. We're trying to end up with templates that + -- mention no vars except $prefix. + substituteInstallDirTemplates env dirs { + prefix = PathTemplate [Variable PrefixVar] + } + where + env = initialPathTemplateEnv pkgId compilerId + + -- If it starts with $prefix then it's relative and produce the relative + -- path by stripping off $prefix/ or $prefix + relative dir = case dir of + PathTemplate cs -> fmap (fromPathTemplate . PathTemplate) (relative' cs) + relative' (Variable PrefixVar : Ordinary (s:rest) : rest') + | isPathSeparator s = Just (Ordinary rest : rest') + relative' (Variable PrefixVar : rest) = Just rest + relative' _ = Nothing + +-- --------------------------------------------------------------------------- +-- Path templates + +-- | An abstract path, posibly containing variables that need to be +-- substituted for to get a real 'FilePath'. +-- +newtype PathTemplate = PathTemplate [PathComponent] + +data PathComponent = + Ordinary FilePath + | Variable PathTemplateVariable + deriving Eq + +data PathTemplateVariable = + PrefixVar -- ^ The @$prefix@ path variable + | BindirVar -- ^ The @$bindir@ path variable + | LibdirVar -- ^ The @$libdir@ path variable + | LibsubdirVar -- ^ The @$libsubdir@ path variable + | DatadirVar -- ^ The @$datadir@ path variable + | DatasubdirVar -- ^ The @$datasubdir@ path variable + | DocdirVar -- ^ The @$docdir@ path variable + | HtmldirVar -- ^ The @$htmldir@ path variable + | PkgNameVar -- ^ The @$pkg@ package name path variable + | PkgVerVar -- ^ The @$version@ package version path variable + | PkgIdVar -- ^ The @$pkgid@ package Id path variable, eg @foo-1.0@ + | CompilerVar -- ^ The compiler name and version, eg @ghc-6.6.1@ + | OSVar -- ^ The operating system name, eg @windows@ or @linux@ + | ArchVar -- ^ The cpu architecture name, eg @i386@ or @x86_64@ + | ExecutableNameVar -- ^ The executable name; used in shell wrappers + | TestSuiteNameVar -- ^ The name of the test suite being run + | TestSuiteResultVar -- ^ The result of the test suite being run, eg @pass@, @fail@, or @error@. + deriving Eq + +type PathTemplateEnv = [(PathTemplateVariable, PathTemplate)] + +-- | Convert a 'FilePath' to a 'PathTemplate' including any template vars. +-- +toPathTemplate :: FilePath -> PathTemplate +toPathTemplate = PathTemplate . read + +-- | Convert back to a path, any remaining vars are included +-- +fromPathTemplate :: PathTemplate -> FilePath +fromPathTemplate (PathTemplate template) = show template + +combinePathTemplate :: PathTemplate -> PathTemplate -> PathTemplate +combinePathTemplate (PathTemplate t1) (PathTemplate t2) = + PathTemplate (t1 ++ [Ordinary [pathSeparator]] ++ t2) + +substPathTemplate :: PathTemplateEnv -> PathTemplate -> PathTemplate +substPathTemplate environment (PathTemplate template) = + PathTemplate (concatMap subst template) + + where subst component@(Ordinary _) = [component] + subst component@(Variable variable) = + case lookup variable environment of + Just (PathTemplate components) -> components + Nothing -> [component] + +-- | The initial environment has all the static stuff but no paths +initialPathTemplateEnv :: PackageIdentifier -> CompilerId -> PathTemplateEnv +initialPathTemplateEnv pkgId compilerId = + packageTemplateEnv pkgId + ++ compilerTemplateEnv compilerId + ++ platformTemplateEnv buildPlatform -- platform should be param if we want + -- to do cross-platform configuation + +packageTemplateEnv :: PackageIdentifier -> PathTemplateEnv +packageTemplateEnv pkgId = + [(PkgNameVar, PathTemplate [Ordinary $ display (packageName pkgId)]) + ,(PkgVerVar, PathTemplate [Ordinary $ display (packageVersion pkgId)]) + ,(PkgIdVar, PathTemplate [Ordinary $ display pkgId]) + ] + +compilerTemplateEnv :: CompilerId -> PathTemplateEnv +compilerTemplateEnv compilerId = + [(CompilerVar, PathTemplate [Ordinary $ display compilerId]) + ] + +platformTemplateEnv :: Platform -> PathTemplateEnv +platformTemplateEnv (Platform arch os) = + [(OSVar, PathTemplate [Ordinary $ display os]) + ,(ArchVar, PathTemplate [Ordinary $ display arch]) + ] + +installDirsTemplateEnv :: InstallDirs PathTemplate -> PathTemplateEnv +installDirsTemplateEnv dirs = + [(PrefixVar, prefix dirs) + ,(BindirVar, bindir dirs) + ,(LibdirVar, libdir dirs) + ,(LibsubdirVar, libsubdir dirs) + ,(DatadirVar, datadir dirs) + ,(DatasubdirVar, datasubdir dirs) + ,(DocdirVar, docdir dirs) + ,(HtmldirVar, htmldir dirs) + ] + + +-- --------------------------------------------------------------------------- +-- Parsing and showing path templates: + +-- The textual format is that of an ordinary Haskell String, eg +-- "$prefix/bin" +-- and this gets parsed to the internal representation as a sequence of path +-- spans which are either strings or variables, eg: +-- PathTemplate [Variable PrefixVar, Ordinary "/bin" ] + +instance Show PathTemplateVariable where + show PrefixVar = "prefix" + show BindirVar = "bindir" + show LibdirVar = "libdir" + show LibsubdirVar = "libsubdir" + show DatadirVar = "datadir" + show DatasubdirVar = "datasubdir" + show DocdirVar = "docdir" + show HtmldirVar = "htmldir" + show PkgNameVar = "pkg" + show PkgVerVar = "version" + show PkgIdVar = "pkgid" + show CompilerVar = "compiler" + show OSVar = "os" + show ArchVar = "arch" + show ExecutableNameVar = "executablename" + show TestSuiteNameVar = "test-suite" + show TestSuiteResultVar = "result" + +instance Read PathTemplateVariable where + readsPrec _ s = + take 1 + [ (var, drop (length varStr) s) + | (varStr, var) <- vars + , varStr `isPrefixOf` s ] + where vars = [("prefix", PrefixVar) + ,("bindir", BindirVar) + ,("libdir", LibdirVar) + ,("libsubdir", LibsubdirVar) + ,("datadir", DatadirVar) + ,("datasubdir", DatasubdirVar) + ,("docdir", DocdirVar) + ,("htmldir", HtmldirVar) + ,("pkgid", PkgIdVar) + ,("pkg", PkgNameVar) + ,("version", PkgVerVar) + ,("compiler", CompilerVar) + ,("os", OSVar) + ,("arch", ArchVar) + ,("executablename", ExecutableNameVar) + ,("test-suite", TestSuiteNameVar) + ,("result", TestSuiteResultVar)] + +instance Show PathComponent where + show (Ordinary path) = path + show (Variable var) = '$':show var + showList = foldr (\x -> (shows x .)) id + +instance Read PathComponent where + -- for some reason we colapse multiple $ symbols here + readsPrec _ = lex0 + where lex0 [] = [] + lex0 ('$':'$':s') = lex0 ('$':s') + lex0 ('$':s') = case [ (Variable var, s'') + | (var, s'') <- reads s' ] of + [] -> lex1 "$" s' + ok -> ok + lex0 s' = lex1 [] s' + lex1 "" "" = [] + lex1 acc "" = [(Ordinary (reverse acc), "")] + lex1 acc ('$':'$':s) = lex1 acc ('$':s) + lex1 acc ('$':s) = [(Ordinary (reverse acc), '$':s)] + lex1 acc (c:s) = lex1 (c:acc) s + readList [] = [([],"")] + readList s = [ (component:components, s'') + | (component, s') <- reads s + , (components, s'') <- readList s' ] + +instance Show PathTemplate where + show (PathTemplate template) = show (show template) + +instance Read PathTemplate where + readsPrec p s = [ (PathTemplate template, s') + | (path, s') <- readsPrec p s + , (template, "") <- reads path ] + +-- --------------------------------------------------------------------------- +-- Internal utilities + +getWindowsProgramFilesDir :: IO FilePath +getWindowsProgramFilesDir = do +#if mingw32_HOST_OS || mingw32_TARGET_OS + m <- shGetFolderPath csidl_PROGRAM_FILES +#else + let m = Nothing +#endif + return (fromMaybe "C:\\Program Files" m) + +#if mingw32_HOST_OS || mingw32_TARGET_OS +shGetFolderPath :: CInt -> IO (Maybe FilePath) +shGetFolderPath n = +# if __HUGS__ + return Nothing +# else + allocaArray long_path_size $ \pPath -> do + r <- c_SHGetFolderPath nullPtr n nullPtr 0 pPath + if (r /= 0) + then return Nothing + else do s <- peekCWString pPath; return (Just s) + where + long_path_size = 1024 -- MAX_PATH is 260, this should be plenty +# endif + +csidl_PROGRAM_FILES :: CInt +csidl_PROGRAM_FILES = 0x0026 +-- csidl_PROGRAM_FILES_COMMON :: CInt +-- csidl_PROGRAM_FILES_COMMON = 0x002b + +foreign import stdcall unsafe "shlobj.h SHGetFolderPathW" + c_SHGetFolderPath :: Ptr () + -> CInt + -> Ptr () + -> CInt + -> CWString + -> IO CInt +#endif + +#if !(__HUGS__ || __GLASGOW_HASKELL__ > 606) +-- Compat: this function only appears in FilePath > 1.0 +-- (which at the time of writing is unreleased) +dropDrive :: FilePath -> FilePath +dropDrive (c:cs) | isPathSeparator c = cs +dropDrive (_:':':c:cs) | isWindows + && isPathSeparator c = cs -- path with drive letter +dropDrive (_:':':cs) | isWindows = cs +dropDrive cs = cs + +isWindows :: Bool +isWindows = case buildOS of + Windows -> True + _ -> False +#endif diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/Install.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/Install.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/Install.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/Install.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,214 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Install +-- Copyright : Isaac Jones 2003-2004 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is the entry point into installing a built package. Performs the +-- \"@.\/setup install@\" and \"@.\/setup copy@\" actions. It moves files into +-- place based on the prefix argument. It does the generic bits and then calls +-- compiler-specific functions to do the rest. + +{- All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.Simple.Install ( + install, + ) where + +import Distribution.PackageDescription ( + PackageDescription(..), BuildInfo(..), Library(..), + hasLibs, withLib, hasExes, withExe ) +import Distribution.Package (Package(..)) +import Distribution.Simple.LocalBuildInfo ( + LocalBuildInfo(..), InstallDirs(..), absoluteInstallDirs, + substPathTemplate) +import Distribution.Simple.BuildPaths (haddockName, haddockPref) +import Distribution.Simple.Utils + ( createDirectoryIfMissingVerbose, installDirectoryContents + , installOrdinaryFile, die, info, notice, matchDirFileGlob ) +import Distribution.Simple.Compiler + ( CompilerFlavor(..), compilerFlavor ) +import Distribution.Simple.Setup (CopyFlags(..), CopyDest(..), fromFlag) + +import qualified Distribution.Simple.GHC as GHC +import qualified Distribution.Simple.NHC as NHC +import qualified Distribution.Simple.JHC as JHC +import qualified Distribution.Simple.LHC as LHC +import qualified Distribution.Simple.Hugs as Hugs +import qualified Distribution.Simple.UHC as UHC + +import Control.Monad (when, unless) +import System.Directory + ( doesDirectoryExist, doesFileExist ) +import System.FilePath + ( takeFileName, takeDirectory, (), isAbsolute ) + +import Distribution.Verbosity +import Distribution.Text + ( display ) + +-- |Perform the \"@.\/setup install@\" and \"@.\/setup copy@\" +-- actions. Move files into place based on the prefix argument. FIX: +-- nhc isn't implemented yet. + +install :: PackageDescription -- ^information from the .cabal file + -> LocalBuildInfo -- ^information from the configure step + -> CopyFlags -- ^flags sent to copy or install + -> IO () +install pkg_descr lbi flags = do + let distPref = fromFlag (copyDistPref flags) + verbosity = fromFlag (copyVerbosity flags) + copydest = fromFlag (copyDest flags) + installDirs@(InstallDirs { + bindir = binPref, + libdir = libPref, +-- dynlibdir = dynlibPref, --see TODO below + datadir = dataPref, + progdir = progPref, + docdir = docPref, + htmldir = htmlPref, + haddockdir = interfacePref, + includedir = incPref}) + = absoluteInstallDirs pkg_descr lbi copydest + + --TODO: decide if we need the user to be able to control the libdir + -- for shared libs independently of the one for static libs. If so + -- it should also have a flag in the command line UI + -- For the moment use dynlibdir = libdir + dynlibPref = libPref + progPrefixPref = substPathTemplate (packageId pkg_descr) lbi (progPrefix lbi) + progSuffixPref = substPathTemplate (packageId pkg_descr) lbi (progSuffix lbi) + + docExists <- doesDirectoryExist $ haddockPref distPref pkg_descr + info verbosity ("directory " ++ haddockPref distPref pkg_descr ++ + " does exist: " ++ show docExists) + + installDataFiles verbosity pkg_descr dataPref + + when docExists $ do + createDirectoryIfMissingVerbose verbosity True htmlPref + installDirectoryContents verbosity + (haddockPref distPref pkg_descr) htmlPref + -- setPermissionsRecursive [Read] htmlPref + -- The haddock interface file actually already got installed + -- in the recursive copy, but now we install it where we actually + -- want it to be (normally the same place). We could remove the + -- copy in htmlPref first. + let haddockInterfaceFileSrc = haddockPref distPref pkg_descr + haddockName pkg_descr + haddockInterfaceFileDest = interfacePref haddockName pkg_descr + -- We only generate the haddock interface file for libs, So if the + -- package consists only of executables there will not be one: + exists <- doesFileExist haddockInterfaceFileSrc + when exists $ do + createDirectoryIfMissingVerbose verbosity True interfacePref + installOrdinaryFile verbosity haddockInterfaceFileSrc + haddockInterfaceFileDest + + let lfile = licenseFile pkg_descr + unless (null lfile) $ do + createDirectoryIfMissingVerbose verbosity True docPref + installOrdinaryFile verbosity lfile (docPref takeFileName lfile) + + let buildPref = buildDir lbi + when (hasLibs pkg_descr) $ + notice verbosity ("Installing library in " ++ libPref) + when (hasExes pkg_descr) $ + notice verbosity ("Installing executable(s) in " ++ binPref) + + -- install include files for all compilers - they may be needed to compile + -- haskell files (using the CPP extension) + when (hasLibs pkg_descr) $ installIncludeFiles verbosity pkg_descr incPref + + case compilerFlavor (compiler lbi) of + GHC -> do withLib pkg_descr $ + GHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr + withExe pkg_descr $ + GHC.installExe verbosity lbi installDirs buildPref (progPrefixPref, progSuffixPref) pkg_descr + LHC -> do withLib pkg_descr $ + LHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr + withExe pkg_descr $ + LHC.installExe verbosity lbi installDirs buildPref (progPrefixPref, progSuffixPref) pkg_descr + JHC -> do withLib pkg_descr $ + JHC.installLib verbosity libPref buildPref pkg_descr + withExe pkg_descr $ + JHC.installExe verbosity binPref buildPref (progPrefixPref, progSuffixPref) pkg_descr + Hugs -> do + let targetProgPref = progdir (absoluteInstallDirs pkg_descr lbi NoCopyDest) + let scratchPref = scratchDir lbi + Hugs.install verbosity lbi libPref progPref binPref targetProgPref scratchPref (progPrefixPref, progSuffixPref) pkg_descr + NHC -> do withLib pkg_descr $ NHC.installLib verbosity libPref buildPref (packageId pkg_descr) + withExe pkg_descr $ NHC.installExe verbosity binPref buildPref (progPrefixPref, progSuffixPref) + UHC -> do withLib pkg_descr $ UHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr + _ -> die $ "installing with " + ++ display (compilerFlavor (compiler lbi)) + ++ " is not implemented" + return () + -- register step should be performed by caller. + +-- | Install the files listed in data-files +-- +installDataFiles :: Verbosity -> PackageDescription -> FilePath -> IO () +installDataFiles verbosity pkg_descr destDataDir = + flip mapM_ (dataFiles pkg_descr) $ \ file -> do + let srcDataDir = dataDir pkg_descr + files <- matchDirFileGlob srcDataDir file + let dir = takeDirectory file + createDirectoryIfMissingVerbose verbosity True (destDataDir dir) + sequence_ [ installOrdinaryFile verbosity (srcDataDir file') + (destDataDir file') + | file' <- files ] + +-- | Install the files listed in install-includes +-- +installIncludeFiles :: Verbosity -> PackageDescription -> FilePath -> IO () +installIncludeFiles verbosity + PackageDescription { library = Just lib } destIncludeDir = do + + incs <- mapM (findInc relincdirs) (installIncludes lbi) + sequence_ + [ do createDirectoryIfMissingVerbose verbosity True destDir + installOrdinaryFile verbosity srcFile destFile + | (relFile, srcFile) <- incs + , let destFile = destIncludeDir relFile + destDir = takeDirectory destFile ] + where + relincdirs = "." : filter (not.isAbsolute) (includeDirs lbi) + lbi = libBuildInfo lib + + findInc [] file = die ("can't find include file " ++ file) + findInc (dir:dirs) file = do + let path = dir file + exists <- doesFileExist path + if exists then return (file, path) else findInc dirs file +installIncludeFiles _ _ _ = die "installIncludeFiles: Can't happen?" diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/JHC.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/JHC.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/JHC.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/JHC.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,221 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.JHC +-- Copyright : Isaac Jones 2003-2006 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module contains most of the JHC-specific code for configuring, building +-- and installing packages. + +{- +Copyright (c) 2009, Henning Thielemann +Copyright (c) 2003-2005, Isaac Jones +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.Simple.JHC ( + configure, getInstalledPackages, + buildLib, buildExe, + installLib, installExe + ) where + +import Distribution.PackageDescription as PD + ( PackageDescription(..), BuildInfo(..), Executable(..) + , Library(..), libModules, hcOptions, usedExtensions ) +import Distribution.InstalledPackageInfo + ( emptyInstalledPackageInfo, ) +import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo +import Distribution.Simple.PackageIndex (PackageIndex) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.LocalBuildInfo + ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) ) +import Distribution.Simple.BuildPaths + ( autogenModulesDir, exeExtension ) +import Distribution.Simple.Compiler + ( CompilerFlavor(..), CompilerId(..), Compiler(..) + , PackageDBStack, Flag, languageToFlags, extensionsToFlags ) +import Language.Haskell.Extension + ( Language(Haskell98), Extension(..), KnownExtension(..)) +import Distribution.Simple.Program + ( ConfiguredProgram(..), jhcProgram, ProgramConfiguration + , userMaybeSpecifyPath, requireProgramVersion, lookupProgram + , rawSystemProgram, rawSystemProgramStdoutConf ) +import Distribution.Version + ( Version(..), orLaterVersion ) +import Distribution.Package + ( Package(..), InstalledPackageId(InstalledPackageId), + pkgName, pkgVersion, ) +import Distribution.Simple.Utils + ( createDirectoryIfMissingVerbose, writeFileAtomic + , installOrdinaryFile, installExecutableFile + , intercalate ) +import System.FilePath ( () ) +import Distribution.Verbosity +import Distribution.Text + ( Text(parse), display ) +import Distribution.Compat.ReadP + ( readP_to_S, string, skipSpaces ) + +import Data.List ( nub ) +import Data.Char ( isSpace ) +import Data.Maybe ( fromMaybe ) + + +-- ----------------------------------------------------------------------------- +-- Configuring + +configure :: Verbosity -> Maybe FilePath -> Maybe FilePath + -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration) +configure verbosity hcPath _hcPkgPath conf = do + + (jhcProg, _, conf') <- requireProgramVersion verbosity + jhcProgram (orLaterVersion (Version [0,7,2] [])) + (userMaybeSpecifyPath "jhc" hcPath conf) + + let Just version = programVersion jhcProg + comp = Compiler { + compilerId = CompilerId JHC version, + compilerLanguages = jhcLanguages, + compilerExtensions = jhcLanguageExtensions + } + return (comp, conf') + +jhcLanguages :: [(Language, Flag)] +jhcLanguages = [(Haskell98, "")] + +-- | The flags for the supported extensions +jhcLanguageExtensions :: [(Extension, Flag)] +jhcLanguageExtensions = + [(EnableExtension TypeSynonymInstances , "") + ,(DisableExtension TypeSynonymInstances , "") + ,(EnableExtension ForeignFunctionInterface , "") + ,(DisableExtension ForeignFunctionInterface , "") + ,(EnableExtension ImplicitPrelude , "") -- Wrong + ,(DisableExtension ImplicitPrelude , "--noprelude") + ,(EnableExtension CPP , "-fcpp") + ,(DisableExtension CPP , "-fno-cpp") + ] + +getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration + -> IO PackageIndex +getInstalledPackages verbosity _packageDBs conf = do + -- jhc --list-libraries lists all available libraries. + -- How shall I find out, whether they are global or local + -- without checking all files and locations? + str <- rawSystemProgramStdoutConf verbosity jhcProgram conf ["--list-libraries"] + let pCheck :: [(a, String)] -> [a] + pCheck rs = [ r | (r,s) <- rs, all isSpace s ] + let parseLine ln = + pCheck (readP_to_S + (skipSpaces >> string "Name:" >> skipSpaces >> parse) ln) + return $ + PackageIndex.fromList $ + map (\p -> emptyInstalledPackageInfo { + InstalledPackageInfo.installedPackageId = + InstalledPackageId (display p), + InstalledPackageInfo.sourcePackageId = p + }) $ + concatMap parseLine $ + lines str + +-- ----------------------------------------------------------------------------- +-- Building + +-- | Building a package for JHC. +-- Currently C source files are not supported. +buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo + -> Library -> ComponentLocalBuildInfo -> IO () +buildLib verbosity pkg_descr lbi lib clbi = do + let Just jhcProg = lookupProgram jhcProgram (withPrograms lbi) + let libBi = libBuildInfo lib + let args = constructJHCCmdLine lbi libBi clbi (buildDir lbi) verbosity + let pkgid = display (packageId pkg_descr) + pfile = buildDir lbi "jhc-pkg.conf" + hlfile= buildDir lbi (pkgid ++ ".hl") + writeFileAtomic pfile $ jhcPkgConf pkg_descr + rawSystemProgram verbosity jhcProg $ + ["--build-hl="++pfile, "-o", hlfile] ++ + args ++ map display (libModules lib) + +-- | Building an executable for JHC. +-- Currently C source files are not supported. +buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo + -> Executable -> ComponentLocalBuildInfo -> IO () +buildExe verbosity _pkg_descr lbi exe clbi = do + let Just jhcProg = lookupProgram jhcProgram (withPrograms lbi) + let exeBi = buildInfo exe + let out = buildDir lbi exeName exe + let args = constructJHCCmdLine lbi exeBi clbi (buildDir lbi) verbosity + rawSystemProgram verbosity jhcProg (["-o",out] ++ args ++ [modulePath exe]) + +constructJHCCmdLine :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo + -> FilePath -> Verbosity -> [String] +constructJHCCmdLine lbi bi clbi _odir verbosity = + (if verbosity >= deafening then ["-v"] else []) + ++ hcOptions JHC bi + ++ languageToFlags (compiler lbi) (defaultLanguage bi) + ++ extensionsToFlags (compiler lbi) (usedExtensions bi) + ++ ["--noauto","-i-"] + ++ concat [["-i", l] | l <- nub (hsSourceDirs bi)] + ++ ["-i", autogenModulesDir lbi] + ++ ["-optc" ++ opt | opt <- PD.ccOptions bi] + -- It would be better if JHC would accept package names with versions, + -- but JHC-0.7.2 doesn't accept this. + -- Thus, we have to strip the version with 'pkgName'. + ++ (concat [ ["-p", display (pkgName pkgid)] + | (_, pkgid) <- componentPackageDeps clbi ]) + +jhcPkgConf :: PackageDescription -> String +jhcPkgConf pd = + let sline name sel = name ++ ": "++sel pd + lib = fromMaybe (error "no library available") . library + comma = intercalate "," . map display + in unlines [sline "name" (display . pkgName . packageId) + ,sline "version" (display . pkgVersion . packageId) + ,sline "exposed-modules" (comma . PD.exposedModules . lib) + ,sline "hidden-modules" (comma . otherModules . libBuildInfo . lib) + ] + +installLib :: Verbosity -> FilePath -> FilePath -> PackageDescription -> Library -> IO () +installLib verb dest build_dir pkg_descr _ = do + let p = display (packageId pkg_descr)++".hl" + createDirectoryIfMissingVerbose verb True dest + installOrdinaryFile verb (build_dir p) (dest p) + +installExe :: Verbosity -> FilePath -> FilePath -> (FilePath,FilePath) -> PackageDescription -> Executable -> IO () +installExe verb dest build_dir (progprefix,progsuffix) _ exe = do + let exe_name = exeName exe + src = exe_name exeExtension + out = (progprefix ++ exe_name ++ progsuffix) exeExtension + createDirectoryIfMissingVerbose verb True dest + installExecutableFile verb (build_dir src) (dest out) + diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/LHC.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/LHC.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/LHC.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/LHC.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,805 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.LHC +-- Copyright : Isaac Jones 2003-2007 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is a fairly large module. It contains most of the GHC-specific code for +-- configuring, building and installing packages. It also exports a function +-- for finding out what packages are already installed. Configuring involves +-- finding the @ghc@ and @ghc-pkg@ programs, finding what language extensions +-- this version of ghc supports and returning a 'Compiler' value. +-- +-- 'getInstalledPackages' involves calling the @ghc-pkg@ program to find out +-- what packages are installed. +-- +-- Building is somewhat complex as there is quite a bit of information to take +-- into account. We have to build libs and programs, possibly for profiling and +-- shared libs. We have to support building libraries that will be usable by +-- GHCi and also ghc's @-split-objs@ feature. We have to compile any C files +-- using ghc. Linking, especially for @split-objs@ is remarkably complex, +-- partly because there tend to be 1,000's of @.o@ files and this can often be +-- more than we can pass to the @ld@ or @ar@ programs in one go. +-- +-- Installing for libs and exes involves finding the right files and copying +-- them to the right places. One of the more tricky things about this module is +-- remembering the layout of files in the build directory (which is not +-- explicitly documented) and thus what search dirs are used for various kinds +-- of files. + +{- Copyright (c) 2003-2005, Isaac Jones +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modiication, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.Simple.LHC ( + configure, getInstalledPackages, + buildLib, buildExe, + installLib, installExe, + registerPackage, + ghcOptions, + ghcVerbosityOptions + ) where + +import Distribution.PackageDescription as PD + ( PackageDescription(..), BuildInfo(..), Executable(..) + , Library(..), libModules, hcOptions, usedExtensions, allExtensions ) +import Distribution.InstalledPackageInfo + ( InstalledPackageInfo + , parseInstalledPackageInfo ) +import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo + ( InstalledPackageInfo_(..) ) +import Distribution.Simple.PackageIndex +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.ParseUtils ( ParseResult(..) ) +import Distribution.Simple.LocalBuildInfo + ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) ) +import Distribution.Simple.InstallDirs +import Distribution.Simple.BuildPaths +import Distribution.Simple.Utils +import Distribution.Package + ( PackageIdentifier, Package(..) ) +import qualified Distribution.ModuleName as ModuleName +import Distribution.Simple.Program + ( Program(..), ConfiguredProgram(..), ProgramConfiguration, ProgArg + , ProgramLocation(..), rawSystemProgram, rawSystemProgramConf + , rawSystemProgramStdout, rawSystemProgramStdoutConf + , requireProgramVersion + , userMaybeSpecifyPath, programPath, lookupProgram, addKnownProgram + , arProgram, ranlibProgram, ldProgram + , gccProgram, stripProgram + , lhcProgram, lhcPkgProgram ) +import qualified Distribution.Simple.Program.HcPkg as HcPkg +import Distribution.Simple.Compiler + ( CompilerFlavor(..), CompilerId(..), Compiler(..), compilerVersion + , OptimisationLevel(..), PackageDB(..), PackageDBStack + , Flag, languageToFlags, extensionsToFlags ) +import Distribution.Version + ( Version(..), orLaterVersion ) +import Distribution.System + ( OS(..), buildOS ) +import Distribution.Verbosity +import Distribution.Text + ( display, simpleParse ) +import Language.Haskell.Extension + ( Language(Haskell98), Extension(..), KnownExtension(..) ) + +import Control.Monad ( unless, when ) +import Data.List +import Data.Maybe ( catMaybes ) +import Data.Monoid ( Monoid(..) ) +import System.Directory ( removeFile, renameFile, + getDirectoryContents, doesFileExist, + getTemporaryDirectory ) +import System.FilePath ( (), (<.>), takeExtension, + takeDirectory, replaceExtension ) +import System.IO (hClose, hPutStrLn) +import Distribution.Compat.Exception (catchExit, catchIO) + +-- ----------------------------------------------------------------------------- +-- Configuring + +configure :: Verbosity -> Maybe FilePath -> Maybe FilePath + -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration) +configure verbosity hcPath hcPkgPath conf = do + + (lhcProg, lhcVersion, conf') <- + requireProgramVersion verbosity lhcProgram + (orLaterVersion (Version [0,7] [])) + (userMaybeSpecifyPath "lhc" hcPath conf) + + (lhcPkgProg, lhcPkgVersion, conf'') <- + requireProgramVersion verbosity lhcPkgProgram + (orLaterVersion (Version [0,7] [])) + (userMaybeSpecifyPath "lhc-pkg" hcPkgPath conf') + + when (lhcVersion /= lhcPkgVersion) $ die $ + "Version mismatch between lhc and lhc-pkg: " + ++ programPath lhcProg ++ " is version " ++ display lhcVersion ++ " " + ++ programPath lhcPkgProg ++ " is version " ++ display lhcPkgVersion + + languages <- getLanguages verbosity lhcProg + extensions <- getExtensions verbosity lhcProg + + let comp = Compiler { + compilerId = CompilerId LHC lhcVersion, + compilerLanguages = languages, + compilerExtensions = extensions + } + conf''' = configureToolchain lhcProg conf'' -- configure gcc and ld + return (comp, conf''') + +-- | Adjust the way we find and configure gcc and ld +-- +configureToolchain :: ConfiguredProgram -> ProgramConfiguration + -> ProgramConfiguration +configureToolchain lhcProg = + addKnownProgram gccProgram { + programFindLocation = findProg gccProgram (baseDir "gcc.exe"), + programPostConf = configureGcc + } + . addKnownProgram ldProgram { + programFindLocation = findProg ldProgram (libDir "ld.exe"), + programPostConf = configureLd + } + where + compilerDir = takeDirectory (programPath lhcProg) + baseDir = takeDirectory compilerDir + libDir = baseDir "gcc-lib" + includeDir = baseDir "include" "mingw" + isWindows = case buildOS of Windows -> True; _ -> False + + -- on Windows finding and configuring ghc's gcc and ld is a bit special + findProg :: Program -> FilePath -> Verbosity -> IO (Maybe FilePath) + findProg prog location | isWindows = \verbosity -> do + exists <- doesFileExist location + if exists then return (Just location) + else do warn verbosity ("Couldn't find " ++ programName prog ++ " where I expected it. Trying the search path.") + programFindLocation prog verbosity + | otherwise = programFindLocation prog + + configureGcc :: Verbosity -> ConfiguredProgram -> IO [ProgArg] + configureGcc + | isWindows = \_ gccProg -> case programLocation gccProg of + -- if it's found on system then it means we're using the result + -- of programFindLocation above rather than a user-supplied path + -- that means we should add this extra flag to tell ghc's gcc + -- where it lives and thus where gcc can find its various files: + FoundOnSystem {} -> return ["-B" ++ libDir, "-I" ++ includeDir] + UserSpecified {} -> return [] + | otherwise = \_ _ -> return [] + + -- we need to find out if ld supports the -x flag + configureLd :: Verbosity -> ConfiguredProgram -> IO [ProgArg] + configureLd verbosity ldProg = do + tempDir <- getTemporaryDirectory + ldx <- withTempFile tempDir ".c" $ \testcfile testchnd -> + withTempFile tempDir ".o" $ \testofile testohnd -> do + hPutStrLn testchnd "int foo() {}" + hClose testchnd; hClose testohnd + rawSystemProgram verbosity lhcProg ["-c", testcfile, + "-o", testofile] + withTempFile tempDir ".o" $ \testofile' testohnd' -> + do + hClose testohnd' + _ <- rawSystemProgramStdout verbosity ldProg + ["-x", "-r", testofile, "-o", testofile'] + return True + `catchIO` (\_ -> return False) + `catchExit` (\_ -> return False) + if ldx + then return ["-x"] + else return [] + +getLanguages :: Verbosity -> ConfiguredProgram -> IO [(Language, Flag)] +getLanguages _ _ = return [(Haskell98, "")] +--FIXME: does lhc support -XHaskell98 flag? from what version? + +getExtensions :: Verbosity -> ConfiguredProgram -> IO [(Extension, Flag)] +getExtensions verbosity lhcProg = do + exts <- rawSystemStdout verbosity (programPath lhcProg) + ["--supported-languages"] + -- GHC has the annoying habit of inverting some of the extensions + -- so we have to try parsing ("No" ++ ghcExtensionName) first + let readExtension str = do + ext <- simpleParse ("No" ++ str) + case ext of + UnknownExtension _ -> simpleParse str + _ -> return ext + return $ [ (ext, "-X" ++ display ext) + | Just ext <- map readExtension (lines exts) ] + +getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration + -> IO PackageIndex +getInstalledPackages verbosity packagedbs conf = do + checkPackageDbStack packagedbs + pkgss <- getInstalledPackages' verbosity packagedbs conf + let indexes = [ PackageIndex.fromList (map (substTopDir topDir) pkgs) + | (_, pkgs) <- pkgss ] + return $! (mconcat indexes) + + where + -- On Windows, various fields have $topdir/foo rather than full + -- paths. We need to substitute the right value in so that when + -- we, for example, call gcc, we have proper paths to give it + Just ghcProg = lookupProgram lhcProgram conf + compilerDir = takeDirectory (programPath ghcProg) + topDir = takeDirectory compilerDir + +checkPackageDbStack :: PackageDBStack -> IO () +checkPackageDbStack (GlobalPackageDB:rest) + | GlobalPackageDB `notElem` rest = return () +checkPackageDbStack _ = + die $ "GHC.getInstalledPackages: the global package db must be " + ++ "specified first and cannot be specified multiple times" + +-- | Get the packages from specific PackageDBs, not cumulative. +-- +getInstalledPackages' :: Verbosity -> [PackageDB] -> ProgramConfiguration + -> IO [(PackageDB, [InstalledPackageInfo])] +getInstalledPackages' verbosity packagedbs conf + = + sequence + [ do str <- rawSystemProgramStdoutConf verbosity lhcPkgProgram conf + ["dump", packageDbGhcPkgFlag packagedb] + `catchExit` \_ -> die $ "ghc-pkg dump failed" + case parsePackages str of + Left ok -> return (packagedb, ok) + _ -> die "failed to parse output of 'ghc-pkg dump'" + | packagedb <- packagedbs ] + + where + parsePackages str = + let parsed = map parseInstalledPackageInfo (splitPkgs str) + in case [ msg | ParseFailed msg <- parsed ] of + [] -> Left [ pkg | ParseOk _ pkg <- parsed ] + msgs -> Right msgs + + splitPkgs :: String -> [String] + splitPkgs = map unlines . splitWith ("---" ==) . lines + where + splitWith :: (a -> Bool) -> [a] -> [[a]] + splitWith p xs = ys : case zs of + [] -> [] + _:ws -> splitWith p ws + where (ys,zs) = break p xs + + packageDbGhcPkgFlag GlobalPackageDB = "--global" + packageDbGhcPkgFlag UserPackageDB = "--user" + packageDbGhcPkgFlag (SpecificPackageDB path) = "--package-conf=" ++ path + + +substTopDir :: FilePath -> InstalledPackageInfo -> InstalledPackageInfo +substTopDir topDir ipo + = ipo { + InstalledPackageInfo.importDirs + = map f (InstalledPackageInfo.importDirs ipo), + InstalledPackageInfo.libraryDirs + = map f (InstalledPackageInfo.libraryDirs ipo), + InstalledPackageInfo.includeDirs + = map f (InstalledPackageInfo.includeDirs ipo), + InstalledPackageInfo.frameworkDirs + = map f (InstalledPackageInfo.frameworkDirs ipo), + InstalledPackageInfo.haddockInterfaces + = map f (InstalledPackageInfo.haddockInterfaces ipo), + InstalledPackageInfo.haddockHTMLs + = map f (InstalledPackageInfo.haddockHTMLs ipo) + } + where f ('$':'t':'o':'p':'d':'i':'r':rest) = topDir ++ rest + f x = x + +-- ----------------------------------------------------------------------------- +-- Building + +-- | Build a library with LHC. +-- +buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo + -> Library -> ComponentLocalBuildInfo -> IO () +buildLib verbosity pkg_descr lbi lib clbi = do + let pref = buildDir lbi + pkgid = packageId pkg_descr + runGhcProg = rawSystemProgramConf verbosity lhcProgram (withPrograms lbi) + ifVanillaLib forceVanilla = when (forceVanilla || withVanillaLib lbi) + ifProfLib = when (withProfLib lbi) + ifSharedLib = when (withSharedLib lbi) + ifGHCiLib = when (withGHCiLib lbi && withVanillaLib lbi) + + libBi <- hackThreadedFlag verbosity + (compiler lbi) (withProfLib lbi) (libBuildInfo lib) + + let libTargetDir = pref + forceVanillaLib = EnableExtension TemplateHaskell `elem` allExtensions libBi + -- TH always needs vanilla libs, even when building for profiling + + createDirectoryIfMissingVerbose verbosity True libTargetDir + -- TODO: do we need to put hs-boot files into place for mutually recurive modules? + let ghcArgs = + ["-package-name", display pkgid ] + ++ constructGHCCmdLine lbi libBi clbi libTargetDir verbosity + ++ map display (libModules lib) + lhcWrap x = ["--build-library", "--ghc-opts=" ++ unwords x] + ghcArgsProf = ghcArgs + ++ ["-prof", + "-hisuf", "p_hi", + "-osuf", "p_o" + ] + ++ ghcProfOptions libBi + ghcArgsShared = ghcArgs + ++ ["-dynamic", + "-hisuf", "dyn_hi", + "-osuf", "dyn_o", "-fPIC" + ] + ++ ghcSharedOptions libBi + unless (null (libModules lib)) $ + do ifVanillaLib forceVanillaLib (runGhcProg $ lhcWrap ghcArgs) + ifProfLib (runGhcProg $ lhcWrap ghcArgsProf) + ifSharedLib (runGhcProg $ lhcWrap ghcArgsShared) + + -- build any C sources + unless (null (cSources libBi)) $ do + info verbosity "Building C Sources..." + sequence_ [do let (odir,args) = constructCcCmdLine lbi libBi clbi pref + filename verbosity + createDirectoryIfMissingVerbose verbosity True odir + runGhcProg args + ifSharedLib (runGhcProg (args ++ ["-fPIC", "-osuf dyn_o"])) + | filename <- cSources libBi] + + -- link: + info verbosity "Linking..." + let cObjs = map (`replaceExtension` objExtension) (cSources libBi) + cSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension)) (cSources libBi) + vanillaLibFilePath = libTargetDir mkLibName pkgid + profileLibFilePath = libTargetDir mkProfLibName pkgid + sharedLibFilePath = libTargetDir mkSharedLibName pkgid + (compilerId (compiler lbi)) + ghciLibFilePath = libTargetDir mkGHCiLibName pkgid + + stubObjs <- fmap catMaybes $ sequence + [ findFileWithExtension [objExtension] [libTargetDir] + (ModuleName.toFilePath x ++"_stub") + | x <- libModules lib ] + stubProfObjs <- fmap catMaybes $ sequence + [ findFileWithExtension ["p_" ++ objExtension] [libTargetDir] + (ModuleName.toFilePath x ++"_stub") + | x <- libModules lib ] + stubSharedObjs <- fmap catMaybes $ sequence + [ findFileWithExtension ["dyn_" ++ objExtension] [libTargetDir] + (ModuleName.toFilePath x ++"_stub") + | x <- libModules lib ] + + hObjs <- getHaskellObjects lib lbi + pref objExtension True + hProfObjs <- + if (withProfLib lbi) + then getHaskellObjects lib lbi + pref ("p_" ++ objExtension) True + else return [] + hSharedObjs <- + if (withSharedLib lbi) + then getHaskellObjects lib lbi + pref ("dyn_" ++ objExtension) False + else return [] + + unless (null hObjs && null cObjs && null stubObjs) $ do + -- first remove library files if they exists + sequence_ + [ removeFile libFilePath `catchIO` \_ -> return () + | libFilePath <- [vanillaLibFilePath, profileLibFilePath + ,sharedLibFilePath, ghciLibFilePath] ] + + let arVerbosity | verbosity >= deafening = "v" + | verbosity >= normal = "" + | otherwise = "c" + arArgs = ["q"++ arVerbosity] + ++ [vanillaLibFilePath] + arObjArgs = + hObjs + ++ map (pref ) cObjs + ++ stubObjs + arProfArgs = ["q"++ arVerbosity] + ++ [profileLibFilePath] + arProfObjArgs = + hProfObjs + ++ map (pref ) cObjs + ++ stubProfObjs + ldArgs = ["-r"] + ++ ["-o", ghciLibFilePath <.> "tmp"] + ldObjArgs = + hObjs + ++ map (pref ) cObjs + ++ stubObjs + ghcSharedObjArgs = + hSharedObjs + ++ map (pref ) cSharedObjs + ++ stubSharedObjs + -- After the relocation lib is created we invoke ghc -shared + -- with the dependencies spelled out as -package arguments + -- and ghc invokes the linker with the proper library paths + ghcSharedLinkArgs = + [ "-no-auto-link-packages", + "-shared", + "-dynamic", + "-o", sharedLibFilePath ] + ++ ghcSharedObjArgs + ++ ["-package-name", display pkgid ] + ++ ghcPackageFlags lbi clbi + ++ ["-l"++extraLib | extraLib <- extraLibs libBi] + ++ ["-L"++extraLibDir | extraLibDir <- extraLibDirs libBi] + + runLd ldLibName args = do + exists <- doesFileExist ldLibName + -- This method is called iteratively by xargs. The + -- output goes to .tmp, and any existing file + -- named is included when linking. The + -- output is renamed to . + rawSystemProgramConf verbosity ldProgram (withPrograms lbi) + (args ++ if exists then [ldLibName] else []) + renameFile (ldLibName <.> "tmp") ldLibName + + runAr = rawSystemProgramConf verbosity arProgram (withPrograms lbi) + + --TODO: discover this at configure time or runtime on unix + -- The value is 32k on Windows and posix specifies a minimum of 4k + -- but all sensible unixes use more than 4k. + -- we could use getSysVar ArgumentLimit but that's in the unix lib + maxCommandLineSize = 30 * 1024 + + ifVanillaLib False $ xargs maxCommandLineSize + runAr arArgs arObjArgs + + ifProfLib $ xargs maxCommandLineSize + runAr arProfArgs arProfObjArgs + + ifGHCiLib $ xargs maxCommandLineSize + (runLd ghciLibFilePath) ldArgs ldObjArgs + + ifSharedLib $ runGhcProg ghcSharedLinkArgs + + +-- | Build an executable with LHC. +-- +buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo + -> Executable -> ComponentLocalBuildInfo -> IO () +buildExe verbosity _pkg_descr lbi + exe@Executable { exeName = exeName', modulePath = modPath } clbi = do + let pref = buildDir lbi + runGhcProg = rawSystemProgramConf verbosity lhcProgram (withPrograms lbi) + + exeBi <- hackThreadedFlag verbosity + (compiler lbi) (withProfExe lbi) (buildInfo exe) + + -- exeNameReal, the name that GHC really uses (with .exe on Windows) + let exeNameReal = exeName' <.> + (if null $ takeExtension exeName' then exeExtension else "") + + let targetDir = pref exeName' + let exeDir = targetDir (exeName' ++ "-tmp") + createDirectoryIfMissingVerbose verbosity True targetDir + createDirectoryIfMissingVerbose verbosity True exeDir + -- TODO: do we need to put hs-boot files into place for mutually recursive modules? + -- FIX: what about exeName.hi-boot? + + -- build executables + unless (null (cSources exeBi)) $ do + info verbosity "Building C Sources." + sequence_ [do let (odir,args) = constructCcCmdLine lbi exeBi clbi + exeDir filename verbosity + createDirectoryIfMissingVerbose verbosity True odir + runGhcProg args + | filename <- cSources exeBi] + + srcMainFile <- findFile (exeDir : hsSourceDirs exeBi) modPath + + let cObjs = map (`replaceExtension` objExtension) (cSources exeBi) + let lhcWrap x = ("--ghc-opts\"":x) ++ ["\""] + let binArgs linkExe profExe = + (if linkExe + then ["-o", targetDir exeNameReal] + else ["-c"]) + ++ constructGHCCmdLine lbi exeBi clbi exeDir verbosity + ++ [exeDir x | x <- cObjs] + ++ [srcMainFile] + ++ ["-optl" ++ opt | opt <- PD.ldOptions exeBi] + ++ ["-l"++lib | lib <- extraLibs exeBi] + ++ ["-L"++libDir | libDir <- extraLibDirs exeBi] + ++ concat [["-framework", f] | f <- PD.frameworks exeBi] + ++ if profExe + then ["-prof", + "-hisuf", "p_hi", + "-osuf", "p_o" + ] ++ ghcProfOptions exeBi + else [] + + -- For building exe's for profiling that use TH we actually + -- have to build twice, once without profiling and the again + -- with profiling. This is because the code that TH needs to + -- run at compile time needs to be the vanilla ABI so it can + -- be loaded up and run by the compiler. + when (withProfExe lbi && EnableExtension TemplateHaskell `elem` allExtensions exeBi) + (runGhcProg $ lhcWrap (binArgs False False)) + + runGhcProg (binArgs True (withProfExe lbi)) + +-- | Filter the "-threaded" flag when profiling as it does not +-- work with ghc-6.8 and older. +hackThreadedFlag :: Verbosity -> Compiler -> Bool -> BuildInfo -> IO BuildInfo +hackThreadedFlag verbosity comp prof bi + | not mustFilterThreaded = return bi + | otherwise = do + warn verbosity $ "The ghc flag '-threaded' is not compatible with " + ++ "profiling in ghc-6.8 and older. It will be disabled." + return bi { options = filterHcOptions (/= "-threaded") (options bi) } + where + mustFilterThreaded = prof && compilerVersion comp < Version [6, 10] [] + && "-threaded" `elem` hcOptions GHC bi + filterHcOptions p hcoptss = + [ (hc, if hc == GHC then filter p opts else opts) + | (hc, opts) <- hcoptss ] + +-- when using -split-objs, we need to search for object files in the +-- Module_split directory for each module. +getHaskellObjects :: Library -> LocalBuildInfo + -> FilePath -> String -> Bool -> IO [FilePath] +getHaskellObjects lib lbi pref wanted_obj_ext allow_split_objs + | splitObjs lbi && allow_split_objs = do + let dirs = [ pref (ModuleName.toFilePath x ++ "_split") + | x <- libModules lib ] + objss <- mapM getDirectoryContents dirs + let objs = [ dir obj + | (objs',dir) <- zip objss dirs, obj <- objs', + let obj_ext = takeExtension obj, + '.':wanted_obj_ext == obj_ext ] + return objs + | otherwise = + return [ pref ModuleName.toFilePath x <.> wanted_obj_ext + | x <- libModules lib ] + + +constructGHCCmdLine + :: LocalBuildInfo + -> BuildInfo + -> ComponentLocalBuildInfo + -> FilePath + -> Verbosity + -> [String] +constructGHCCmdLine lbi bi clbi odir verbosity = + ["--make"] + ++ ghcVerbosityOptions verbosity + -- Unsupported extensions have already been checked by configure + ++ ghcOptions lbi bi clbi odir + +ghcVerbosityOptions :: Verbosity -> [String] +ghcVerbosityOptions verbosity + | verbosity >= deafening = ["-v"] + | verbosity >= normal = [] + | otherwise = ["-w", "-v0"] + +ghcOptions :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo + -> FilePath -> [String] +ghcOptions lbi bi clbi odir + = ["-hide-all-packages"] + ++ ghcPackageDbOptions (withPackageDB lbi) + ++ (if splitObjs lbi then ["-split-objs"] else []) + ++ ["-i"] + ++ ["-i" ++ odir] + ++ ["-i" ++ l | l <- nub (hsSourceDirs bi)] + ++ ["-i" ++ autogenModulesDir lbi] + ++ ["-I" ++ autogenModulesDir lbi] + ++ ["-I" ++ odir] + ++ ["-I" ++ dir | dir <- PD.includeDirs bi] + ++ ["-optP" ++ opt | opt <- cppOptions bi] + ++ [ "-optP-include", "-optP"++ (autogenModulesDir lbi cppHeaderName) ] + ++ [ "-#include \"" ++ inc ++ "\"" | inc <- PD.includes bi ] + ++ [ "-odir", odir, "-hidir", odir ] + ++ (if compilerVersion c >= Version [6,8] [] + then ["-stubdir", odir] else []) + ++ ghcPackageFlags lbi clbi + ++ (case withOptimization lbi of + NoOptimisation -> [] + NormalOptimisation -> ["-O"] + MaximumOptimisation -> ["-O2"]) + ++ hcOptions GHC bi + ++ languageToFlags c (defaultLanguage bi) + ++ extensionsToFlags c (usedExtensions bi) + where c = compiler lbi + +ghcPackageFlags :: LocalBuildInfo -> ComponentLocalBuildInfo -> [String] +ghcPackageFlags lbi clbi + | ghcVer >= Version [6,11] [] + = concat [ ["-package-id", display ipkgid] + | (ipkgid, _) <- componentPackageDeps clbi ] + + | otherwise = concat [ ["-package", display pkgid] + | (_, pkgid) <- componentPackageDeps clbi ] + where + ghcVer = compilerVersion (compiler lbi) + +ghcPackageDbOptions :: PackageDBStack -> [String] +ghcPackageDbOptions dbstack = case dbstack of + (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs + (GlobalPackageDB:dbs) -> "-no-user-package-conf" + : concatMap specific dbs + _ -> ierror + where + specific (SpecificPackageDB db) = [ "-package-conf", db ] + specific _ = ierror + ierror = error ("internal error: unexpected package db stack: " ++ show dbstack) + +constructCcCmdLine :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo + -> FilePath -> FilePath -> Verbosity -> (FilePath,[String]) +constructCcCmdLine lbi bi clbi pref filename verbosity + = let odir | compilerVersion (compiler lbi) >= Version [6,4,1] [] = pref + | otherwise = pref takeDirectory filename + -- ghc 6.4.1 fixed a bug in -odir handling + -- for C compilations. + in + (odir, + ghcCcOptions lbi bi clbi odir + ++ (if verbosity >= deafening then ["-v"] else []) + ++ ["-c",filename]) + + +ghcCcOptions :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo + -> FilePath -> [String] +ghcCcOptions lbi bi clbi odir + = ["-I" ++ dir | dir <- PD.includeDirs bi] + ++ ghcPackageDbOptions (withPackageDB lbi) + ++ ghcPackageFlags lbi clbi + ++ ["-optc" ++ opt | opt <- PD.ccOptions bi] + ++ (case withOptimization lbi of + NoOptimisation -> [] + _ -> ["-optc-O2"]) + ++ ["-odir", odir] + +mkGHCiLibName :: PackageIdentifier -> String +mkGHCiLibName lib = "HS" ++ display lib <.> "o" + +-- ----------------------------------------------------------------------------- +-- Installing + +-- |Install executables for GHC. +installExe :: Verbosity + -> LocalBuildInfo + -> InstallDirs FilePath -- ^Where to copy the files to + -> FilePath -- ^Build location + -> (FilePath, FilePath) -- ^Executable (prefix,suffix) + -> PackageDescription + -> Executable + -> IO () +installExe verbosity lbi installDirs buildPref (progprefix, progsuffix) _pkg exe = do + let binDir = bindir installDirs + createDirectoryIfMissingVerbose verbosity True binDir + let exeFileName = exeName exe <.> exeExtension + fixedExeBaseName = progprefix ++ exeName exe ++ progsuffix + installBinary dest = do + installExecutableFile verbosity + (buildPref exeName exe exeFileName) + (dest <.> exeExtension) + stripExe verbosity lbi exeFileName (dest <.> exeExtension) + installBinary (binDir fixedExeBaseName) + +stripExe :: Verbosity -> LocalBuildInfo -> FilePath -> FilePath -> IO () +stripExe verbosity lbi name path = when (stripExes lbi) $ + case lookupProgram stripProgram (withPrograms lbi) of + Just strip -> rawSystemProgram verbosity strip args + Nothing -> unless (buildOS == Windows) $ + -- Don't bother warning on windows, we don't expect them to + -- have the strip program anyway. + warn verbosity $ "Unable to strip executable '" ++ name + ++ "' (missing the 'strip' program)" + where + args = path : case buildOS of + OSX -> ["-x"] -- By default, stripping the ghc binary on at least + -- some OS X installations causes: + -- HSbase-3.0.o: unknown symbol `_environ'" + -- The -x flag fixes that. + _ -> [] + +-- |Install for ghc, .hi, .a and, if --with-ghci given, .o +installLib :: Verbosity + -> LocalBuildInfo + -> FilePath -- ^install location + -> FilePath -- ^install location for dynamic librarys + -> FilePath -- ^Build location + -> PackageDescription + -> Library + -> IO () +installLib verbosity lbi targetDir dynlibTargetDir builtDir pkg lib = do + -- copy .hi files over: + let copy src dst n = do + createDirectoryIfMissingVerbose verbosity True dst + installOrdinaryFile verbosity (src n) (dst n) + copyModuleFiles ext = + findModuleFiles [builtDir] [ext] (libModules lib) + >>= installOrdinaryFiles verbosity targetDir + ifVanilla $ copyModuleFiles "hi" + ifProf $ copyModuleFiles "p_hi" + hcrFiles <- findModuleFiles (builtDir : hsSourceDirs (libBuildInfo lib)) ["hcr"] (libModules lib) + flip mapM_ hcrFiles $ \(srcBase, srcFile) -> runLhc ["--install-library", srcBase srcFile] + + -- copy the built library files over: + ifVanilla $ copy builtDir targetDir vanillaLibName + ifProf $ copy builtDir targetDir profileLibName + ifGHCi $ copy builtDir targetDir ghciLibName + ifShared $ copy builtDir dynlibTargetDir sharedLibName + + -- run ranlib if necessary: + ifVanilla $ updateLibArchive verbosity lbi + (targetDir vanillaLibName) + ifProf $ updateLibArchive verbosity lbi + (targetDir profileLibName) + + where + vanillaLibName = mkLibName pkgid + profileLibName = mkProfLibName pkgid + ghciLibName = mkGHCiLibName pkgid + sharedLibName = mkSharedLibName pkgid (compilerId (compiler lbi)) + + pkgid = packageId pkg + + hasLib = not $ null (libModules lib) + && null (cSources (libBuildInfo lib)) + ifVanilla = when (hasLib && withVanillaLib lbi) + ifProf = when (hasLib && withProfLib lbi) + ifGHCi = when (hasLib && withGHCiLib lbi) + ifShared = when (hasLib && withSharedLib lbi) + + runLhc = rawSystemProgramConf verbosity lhcProgram (withPrograms lbi) + +-- | use @ranlib@ or @ar -s@ to build an index. This is necessary on systems +-- like MacOS X. If we can't find those, don't worry too much about it. +-- +updateLibArchive :: Verbosity -> LocalBuildInfo -> FilePath -> IO () +updateLibArchive verbosity lbi path = + case lookupProgram ranlibProgram (withPrograms lbi) of + Just ranlib -> rawSystemProgram verbosity ranlib [path] + Nothing -> case lookupProgram arProgram (withPrograms lbi) of + Just ar -> rawSystemProgram verbosity ar ["-s", path] + Nothing -> warn verbosity $ + "Unable to generate a symbol index for the static " + ++ "library '" ++ path + ++ "' (missing the 'ranlib' and 'ar' programs)" + +-- ----------------------------------------------------------------------------- +-- Registering + +registerPackage + :: Verbosity + -> InstalledPackageInfo + -> PackageDescription + -> LocalBuildInfo + -> Bool + -> PackageDBStack + -> IO () +registerPackage verbosity installedPkgInfo _pkg lbi _inplace packageDbs = do + let Just lhcPkg = lookupProgram lhcPkgProgram (withPrograms lbi) + HcPkg.reregister verbosity lhcPkg packageDbs (Right installedPkgInfo) diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/LocalBuildInfo.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/LocalBuildInfo.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/LocalBuildInfo.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/LocalBuildInfo.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,306 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.LocalBuildInfo +-- Copyright : Isaac Jones 2003-2004 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Once a package has been configured we have resolved conditionals and +-- dependencies, configured the compiler and other needed external programs. +-- The 'LocalBuildInfo' is used to hold all this information. It holds the +-- install dirs, the compiler, the exact package dependencies, the configured +-- programs, the package database to use and a bunch of miscellaneous configure +-- flags. It gets saved and reloaded from a file (@dist\/setup-config@). It gets +-- passed in to very many subsequent build actions. + +{- All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.Simple.LocalBuildInfo ( + LocalBuildInfo(..), + externalPackageDeps, + inplacePackageId, + + -- * Buildable package components + Component(..), + foldComponent, + allComponentsBy, + ComponentName(..), + ComponentLocalBuildInfo(..), + withComponentsLBI, + withLibLBI, + withExeLBI, + withTestLBI, + + -- * Installation directories + module Distribution.Simple.InstallDirs, + absoluteInstallDirs, prefixRelativeInstallDirs, + substPathTemplate + ) where + + +import Distribution.Simple.InstallDirs hiding (absoluteInstallDirs, + prefixRelativeInstallDirs, + substPathTemplate, ) +import qualified Distribution.Simple.InstallDirs as InstallDirs +import Distribution.Simple.Program (ProgramConfiguration) +import Distribution.PackageDescription + ( PackageDescription(..), withLib, Library(libBuildInfo), withExe + , Executable(exeName, buildInfo), withTest, TestSuite(..) + , BuildInfo(buildable) ) +import Distribution.Package + ( PackageId, Package(..), InstalledPackageId(..) ) +import Distribution.Simple.Compiler + ( Compiler(..), PackageDBStack, OptimisationLevel ) +import Distribution.Simple.PackageIndex + ( PackageIndex ) +import Distribution.Simple.Utils + ( die ) +import Distribution.Simple.Setup + ( ConfigFlags ) +import Distribution.Text + ( display ) + +import Data.List (nub, find) + +-- | Data cached after configuration step. See also +-- 'Distribution.Simple.Setup.ConfigFlags'. +data LocalBuildInfo = LocalBuildInfo { + configFlags :: ConfigFlags, + -- ^ Options passed to the configuration step. + -- Needed to re-run configuration when .cabal is out of date + extraConfigArgs :: [String], + -- ^ Extra args on the command line for the configuration step. + -- Needed to re-run configuration when .cabal is out of date + installDirTemplates :: InstallDirTemplates, + -- ^ The installation directories for the various differnt + -- kinds of files + --TODO: inplaceDirTemplates :: InstallDirs FilePath + compiler :: Compiler, + -- ^ The compiler we're building with + buildDir :: FilePath, + -- ^ Where to build the package. + --TODO: eliminate hugs's scratchDir, use builddir + scratchDir :: FilePath, + -- ^ Where to put the result of the Hugs build. + libraryConfig :: Maybe ComponentLocalBuildInfo, + executableConfigs :: [(String, ComponentLocalBuildInfo)], + compBuildOrder :: [ComponentName], + -- ^ All the components to build, ordered by topological sort + -- over the intrapackage dependency graph + testSuiteConfigs :: [(String, ComponentLocalBuildInfo)], + installedPkgs :: PackageIndex, + -- ^ All the info about the installed packages that the + -- current package depends on (directly or indirectly). + pkgDescrFile :: Maybe FilePath, + -- ^ the filename containing the .cabal file, if available + localPkgDescr :: PackageDescription, + -- ^ The resolved package description, that does not contain + -- any conditionals. + withPrograms :: ProgramConfiguration, -- ^Location and args for all programs + withPackageDB :: PackageDBStack, -- ^What package database to use, global\/user + withVanillaLib:: Bool, -- ^Whether to build normal libs. + withProfLib :: Bool, -- ^Whether to build profiling versions of libs. + withSharedLib :: Bool, -- ^Whether to build shared versions of libs. + withDynExe :: Bool, -- ^Whether to link executables dynamically + withProfExe :: Bool, -- ^Whether to build executables for profiling. + withOptimization :: OptimisationLevel, -- ^Whether to build with optimization (if available). + withGHCiLib :: Bool, -- ^Whether to build libs suitable for use with GHCi. + splitObjs :: Bool, -- ^Use -split-objs with GHC, if available + stripExes :: Bool, -- ^Whether to strip executables during install + progPrefix :: PathTemplate, -- ^Prefix to be prepended to installed executables + progSuffix :: PathTemplate -- ^Suffix to be appended to installed executables + } deriving (Read, Show) + +-- | External package dependencies for the package as a whole, the union of the +-- individual 'targetPackageDeps'. +externalPackageDeps :: LocalBuildInfo -> [(InstalledPackageId, PackageId)] +externalPackageDeps lbi = nub $ + -- TODO: what about non-buildable components? + maybe [] componentPackageDeps (libraryConfig lbi) + ++ concatMap (componentPackageDeps . snd) (executableConfigs lbi) + +-- | The installed package Id we use for local packages registered in the local +-- package db. This is what is used for intra-package deps between components. +-- +inplacePackageId :: PackageId -> InstalledPackageId +inplacePackageId pkgid = InstalledPackageId (display pkgid ++ "-inplace") + +-- ----------------------------------------------------------------------------- +-- Buildable components + +data Component = CLib Library + | CExe Executable + | CTest TestSuite + deriving (Show, Eq, Read) + +data ComponentName = CLibName -- currently only a single lib + | CExeName String + | CTestName String + deriving (Show, Eq, Read) + +data ComponentLocalBuildInfo = ComponentLocalBuildInfo { + -- | Resolved internal and external package dependencies for this component. + -- The 'BuildInfo' specifies a set of build dependencies that must be + -- satisfied in terms of version ranges. This field fixes those dependencies + -- to the specific versions available on this machine for this compiler. + componentPackageDeps :: [(InstalledPackageId, PackageId)] + } + deriving (Read, Show) + +foldComponent :: (Library -> a) + -> (Executable -> a) + -> (TestSuite -> a) + -> Component + -> a +foldComponent f _ _ (CLib lib) = f lib +foldComponent _ f _ (CExe exe) = f exe +foldComponent _ _ f (CTest tst) = f tst + +-- | Obtains all components (libs, exes, or test suites), transformed by the +-- given function. Useful for gathering dependencies with component context. +allComponentsBy :: PackageDescription + -> (Component -> a) + -> [a] +allComponentsBy pkg_descr f = + [ f (CLib lib) | Just lib <- [library pkg_descr] + , buildable (libBuildInfo lib) ] + ++ [ f (CExe exe) | exe <- executables pkg_descr + , buildable (buildInfo exe) ] + ++ [ f (CTest tst) | tst <- testSuites pkg_descr + , buildable (testBuildInfo tst) + , testEnabled tst ] + +-- |If the package description has a library section, call the given +-- function with the library build info as argument. Extended version of +-- 'withLib' that also gives corresponding build info. +withLibLBI :: PackageDescription -> LocalBuildInfo + -> (Library -> ComponentLocalBuildInfo -> IO ()) -> IO () +withLibLBI pkg_descr lbi f = withLib pkg_descr $ \lib -> + case libraryConfig lbi of + Just clbi -> f lib clbi + Nothing -> die missingLibConf + +-- | Perform the action on each buildable 'Executable' in the package +-- description. Extended version of 'withExe' that also gives corresponding +-- build info. +withExeLBI :: PackageDescription -> LocalBuildInfo + -> (Executable -> ComponentLocalBuildInfo -> IO ()) -> IO () +withExeLBI pkg_descr lbi f = withExe pkg_descr $ \exe -> + case lookup (exeName exe) (executableConfigs lbi) of + Just clbi -> f exe clbi + Nothing -> die (missingExeConf (exeName exe)) + +withTestLBI :: PackageDescription -> LocalBuildInfo + -> (TestSuite -> ComponentLocalBuildInfo -> IO ()) -> IO () +withTestLBI pkg_descr lbi f = withTest pkg_descr $ \test -> + case lookup (testName test) (testSuiteConfigs lbi) of + Just clbi -> f test clbi + Nothing -> die (missingTestConf (testName test)) + +-- | Perform the action on each buildable 'Library' or 'Executable' (Component) +-- in the PackageDescription, subject to the build order specified by the +-- 'compBuildOrder' field of the given 'LocalBuildInfo' +withComponentsLBI :: PackageDescription -> LocalBuildInfo + -> (Component -> ComponentLocalBuildInfo -> IO ()) + -> IO () +withComponentsLBI pkg_descr lbi f = mapM_ compF (compBuildOrder lbi) + where + compF CLibName = + case library pkg_descr of + Nothing -> die missinglib + Just lib -> case libraryConfig lbi of + Nothing -> die missingLibConf + Just clbi -> f (CLib lib) clbi + where + missinglib = "internal error: component list includes a library " + ++ "but the package description contains no library" + + compF (CExeName name) = + case find (\exe -> exeName exe == name) (executables pkg_descr) of + Nothing -> die missingexe + Just exe -> case lookup name (executableConfigs lbi) of + Nothing -> die (missingExeConf name) + Just clbi -> f (CExe exe) clbi + where + missingexe = "internal error: component list includes an executable " + ++ name ++ " but the package contains no such executable." + + compF (CTestName name) = + case find (\tst -> testName tst == name) (testSuites pkg_descr) of + Nothing -> die missingtest + Just tst -> case lookup name (testSuiteConfigs lbi) of + Nothing -> die (missingTestConf name) + Just clbi -> f (CTest tst) clbi + where + missingtest = "internal error: component list includes a test suite " + ++ name ++ " but the package contains no such test suite." + +missingLibConf :: String +missingExeConf, missingTestConf :: String -> String + +missingLibConf = "internal error: the package contains a library " + ++ "but there is no corresponding configuration data" +missingExeConf name = "internal error: the package contains an executable " + ++ name ++ " but there is no corresponding configuration data" +missingTestConf name = "internal error: the package contains a test suite " + ++ name ++ " but there is no corresponding configuration data" + + +-- ----------------------------------------------------------------------------- +-- Wrappers for a couple functions from InstallDirs + +-- |See 'InstallDirs.absoluteInstallDirs' +absoluteInstallDirs :: PackageDescription -> LocalBuildInfo -> CopyDest + -> InstallDirs FilePath +absoluteInstallDirs pkg lbi copydest = + InstallDirs.absoluteInstallDirs + (packageId pkg) + (compilerId (compiler lbi)) + copydest + (installDirTemplates lbi) + +-- |See 'InstallDirs.prefixRelativeInstallDirs' +prefixRelativeInstallDirs :: PackageId -> LocalBuildInfo + -> InstallDirs (Maybe FilePath) +prefixRelativeInstallDirs pkg_descr lbi = + InstallDirs.prefixRelativeInstallDirs + (packageId pkg_descr) + (compilerId (compiler lbi)) + (installDirTemplates lbi) + +substPathTemplate :: PackageId -> LocalBuildInfo + -> PathTemplate -> FilePath +substPathTemplate pkgid lbi = fromPathTemplate + . ( InstallDirs.substPathTemplate env ) + where env = initialPathTemplateEnv + pkgid + (compilerId (compiler lbi)) diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/NHC.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/NHC.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/NHC.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/NHC.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,424 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.NHC +-- Copyright : Isaac Jones 2003-2006 +-- Duncan Coutts 2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module contains most of the NHC-specific code for configuring, building +-- and installing packages. + +{- Copyright (c) 2003-2005, Isaac Jones +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.Simple.NHC ( + configure, + getInstalledPackages, + buildLib, + buildExe, + installLib, + installExe, + ) where + +import Distribution.Package + ( PackageName, PackageIdentifier(..), InstalledPackageId(..) + , packageId, packageName ) +import Distribution.InstalledPackageInfo + ( InstalledPackageInfo + , InstalledPackageInfo_( InstalledPackageInfo, installedPackageId + , sourcePackageId ) + , emptyInstalledPackageInfo, parseInstalledPackageInfo ) +import Distribution.PackageDescription + ( PackageDescription(..), BuildInfo(..), Library(..), Executable(..) + , hcOptions, usedExtensions ) +import Distribution.ModuleName (ModuleName) +import qualified Distribution.ModuleName as ModuleName +import Distribution.Simple.LocalBuildInfo + ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) ) +import Distribution.Simple.BuildPaths + ( mkLibName, objExtension, exeExtension ) +import Distribution.Simple.Compiler + ( CompilerFlavor(..), CompilerId(..), Compiler(..) + , Flag, languageToFlags, extensionsToFlags + , PackageDB(..), PackageDBStack ) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.PackageIndex (PackageIndex) +import Language.Haskell.Extension + ( Language(Haskell98), Extension(..), KnownExtension(..) ) +import Distribution.Simple.Program + ( ProgramConfiguration, userMaybeSpecifyPath, programPath + , requireProgram, requireProgramVersion, lookupProgram + , nhcProgram, hmakeProgram, ldProgram, arProgram + , rawSystemProgramConf ) +import Distribution.Simple.Utils + ( die, info, findFileWithExtension, findModuleFiles + , installOrdinaryFile, installExecutableFile, installOrdinaryFiles + , createDirectoryIfMissingVerbose, withUTF8FileContents ) +import Distribution.Version + ( Version(..), orLaterVersion ) +import Distribution.Verbosity +import Distribution.Text + ( display, simpleParse ) +import Distribution.ParseUtils + ( ParseResult(..) ) + +import System.FilePath + ( (), (<.>), normalise, takeDirectory, dropExtension ) +import System.Directory + ( doesFileExist, doesDirectoryExist, getDirectoryContents + , removeFile, getHomeDirectory ) + +import Data.Char ( toLower ) +import Data.List ( nub ) +import Data.Maybe ( catMaybes ) +import Data.Monoid ( Monoid(..) ) +import Control.Monad ( when, unless ) +import Distribution.Compat.Exception + +-- ----------------------------------------------------------------------------- +-- Configuring + +configure :: Verbosity -> Maybe FilePath -> Maybe FilePath + -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration) +configure verbosity hcPath _hcPkgPath conf = do + + (_nhcProg, nhcVersion, conf') <- + requireProgramVersion verbosity nhcProgram + (orLaterVersion (Version [1,20] [])) + (userMaybeSpecifyPath "nhc98" hcPath conf) + + (_hmakeProg, _hmakeVersion, conf'') <- + requireProgramVersion verbosity hmakeProgram + (orLaterVersion (Version [3,13] [])) conf' + (_ldProg, conf''') <- requireProgram verbosity ldProgram conf'' + (_arProg, conf'''') <- requireProgram verbosity arProgram conf''' + + --TODO: put this stuff in a monad so we can say just: + -- requireProgram hmakeProgram (orLaterVersion (Version [3,13] [])) + -- requireProgram ldProgram anyVersion + -- requireProgram ldPrograrProgramam anyVersion + -- unless (null (cSources bi)) $ requireProgram ccProgram anyVersion + + let comp = Compiler { + compilerId = CompilerId NHC nhcVersion, + compilerLanguages = nhcLanguages, + compilerExtensions = nhcLanguageExtensions + } + return (comp, conf'''') + +nhcLanguages :: [(Language, Flag)] +nhcLanguages = [(Haskell98, "-98")] + +-- | The flags for the supported extensions +nhcLanguageExtensions :: [(Extension, Flag)] +nhcLanguageExtensions = + -- TODO: pattern guards in 1.20 + -- NHC doesn't enforce the monomorphism restriction at all. + -- Technically it therefore doesn't support MonomorphismRestriction, + -- but that would mean it doesn't support Haskell98, so we pretend + -- that it does. + [(EnableExtension MonomorphismRestriction, "") + ,(DisableExtension MonomorphismRestriction, "") + -- Similarly, I assume the FFI is always on + ,(EnableExtension ForeignFunctionInterface, "") + ,(DisableExtension ForeignFunctionInterface, "") + -- Similarly, I assume existential quantification is always on + ,(EnableExtension ExistentialQuantification, "") + ,(DisableExtension ExistentialQuantification, "") + -- Similarly, I assume empty data decls is always on + ,(EnableExtension EmptyDataDecls, "") + ,(DisableExtension EmptyDataDecls, "") + ,(EnableExtension NamedFieldPuns, "-puns") + ,(DisableExtension NamedFieldPuns, "-nopuns") + -- CPP can't actually be turned off, but we pretend that it can + ,(EnableExtension CPP, "-cpp") + ,(DisableExtension CPP, "") + ] + +getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration + -> IO PackageIndex +getInstalledPackages verbosity packagedbs conf = do + homedir <- getHomeDirectory + (nhcProg, _) <- requireProgram verbosity nhcProgram conf + let bindir = takeDirectory (programPath nhcProg) + incdir = takeDirectory bindir "include" "nhc98" + dbdirs = nub (concatMap (packageDbPaths homedir incdir) packagedbs) + indexes <- mapM getIndividualDBPackages dbdirs + return $! mconcat indexes + + where + getIndividualDBPackages :: FilePath -> IO PackageIndex + getIndividualDBPackages dbdir = do + pkgdirs <- getPackageDbDirs dbdir + pkgs <- sequence [ getInstalledPackage pkgname pkgdir + | (pkgname, pkgdir) <- pkgdirs ] + let pkgs' = map setInstalledPackageId (catMaybes pkgs) + return (PackageIndex.fromList pkgs') + +packageDbPaths :: FilePath -> FilePath -> PackageDB -> [FilePath] +packageDbPaths _home incdir db = case db of + GlobalPackageDB -> [ incdir "packages" ] + UserPackageDB -> [] --TODO any standard per-user db? + SpecificPackageDB path -> [ path ] + +getPackageDbDirs :: FilePath -> IO [(PackageName, FilePath)] +getPackageDbDirs dbdir = do + dbexists <- doesDirectoryExist dbdir + if not dbexists + then return [] + else do + entries <- getDirectoryContents dbdir + pkgdirs <- sequence + [ do pkgdirExists <- doesDirectoryExist pkgdir + return (pkgname, pkgdir, pkgdirExists) + | (entry, Just pkgname) <- [ (entry, simpleParse entry) + | entry <- entries ] + , let pkgdir = dbdir entry ] + return [ (pkgname, pkgdir) | (pkgname, pkgdir, True) <- pkgdirs ] + +getInstalledPackage :: PackageName -> FilePath -> IO (Maybe InstalledPackageInfo) +getInstalledPackage pkgname pkgdir = do + let pkgconfFile = pkgdir "package.conf" + pkgconfExists <- doesFileExist pkgconfFile + + let cabalFile = pkgdir <.> "cabal" + cabalExists <- doesFileExist cabalFile + + case () of + _ | pkgconfExists -> getFullInstalledPackageInfo pkgname pkgconfFile + | cabalExists -> getPhonyInstalledPackageInfo pkgname cabalFile + | otherwise -> return Nothing + +getFullInstalledPackageInfo :: PackageName -> FilePath + -> IO (Maybe InstalledPackageInfo) +getFullInstalledPackageInfo pkgname pkgconfFile = + withUTF8FileContents pkgconfFile $ \contents -> + case parseInstalledPackageInfo contents of + ParseOk _ pkginfo | packageName pkginfo == pkgname + -> return (Just pkginfo) + _ -> return Nothing + +-- | This is a backup option for existing versions of nhc98 which do not supply +-- proper installed package info files for the bundled libs. Instead we look +-- for the .cabal file and extract the package version from that. +-- We don't know any other details for such packages, in particular we pretend +-- that they have no dependencies. +-- +getPhonyInstalledPackageInfo :: PackageName -> FilePath + -> IO (Maybe InstalledPackageInfo) +getPhonyInstalledPackageInfo pkgname pathsModule = do + content <- readFile pathsModule + case extractVersion content of + Nothing -> return Nothing + Just version -> return (Just pkginfo) + where + pkgid = PackageIdentifier pkgname version + pkginfo = emptyInstalledPackageInfo { sourcePackageId = pkgid } + where + -- search through the .cabal file, looking for a line like: + -- + -- > version: 2.0 + -- + extractVersion :: String -> Maybe Version + extractVersion content = + case catMaybes (map extractVersionLine (lines content)) of + [version] -> Just version + _ -> Nothing + extractVersionLine :: String -> Maybe Version + extractVersionLine line = + case words line of + [versionTag, ":", versionStr] + | map toLower versionTag == "version" -> simpleParse versionStr + [versionTag, versionStr] + | map toLower versionTag == "version:" -> simpleParse versionStr + _ -> Nothing + +-- Older installed package info files did not have the installedPackageId +-- field, so if it is missing then we fill it as the source package ID. +setInstalledPackageId :: InstalledPackageInfo -> InstalledPackageInfo +setInstalledPackageId pkginfo@InstalledPackageInfo { + installedPackageId = InstalledPackageId "", + sourcePackageId = pkgid + } + = pkginfo { + --TODO use a proper named function for the conversion + -- from source package id to installed package id + installedPackageId = InstalledPackageId (display pkgid) + } +setInstalledPackageId pkginfo = pkginfo + +-- ----------------------------------------------------------------------------- +-- Building + +-- |FIX: For now, the target must contain a main module. Not used +-- ATM. Re-add later. +buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo + -> Library -> ComponentLocalBuildInfo -> IO () +buildLib verbosity pkg_descr lbi lib clbi = do + let conf = withPrograms lbi + Just nhcProg = lookupProgram nhcProgram conf + let bi = libBuildInfo lib + modules = exposedModules lib ++ otherModules bi + -- Unsupported extensions have already been checked by configure + languageFlags = languageToFlags (compiler lbi) (defaultLanguage bi) + ++ extensionsToFlags (compiler lbi) (usedExtensions bi) + inFiles <- getModulePaths lbi bi modules + let targetDir = buildDir lbi + srcDirs = nub (map takeDirectory inFiles) + destDirs = map (targetDir ) srcDirs + mapM_ (createDirectoryIfMissingVerbose verbosity True) destDirs + rawSystemProgramConf verbosity hmakeProgram conf $ + ["-hc=" ++ programPath nhcProg] + ++ nhcVerbosityOptions verbosity + ++ ["-d", targetDir, "-hidir", targetDir] + ++ maybe [] (hcOptions NHC . libBuildInfo) + (library pkg_descr) + ++ languageFlags + ++ concat [ ["-package", display (packageName pkgid) ] + | (_, pkgid) <- componentPackageDeps clbi ] + ++ inFiles +{- + -- build any C sources + unless (null (cSources bi)) $ do + info verbosity "Building C Sources..." + let commonCcArgs = (if verbosity >= deafening then ["-v"] else []) + ++ ["-I" ++ dir | dir <- includeDirs bi] + ++ [opt | opt <- ccOptions bi] + ++ (if withOptimization lbi then ["-O2"] else []) + flip mapM_ (cSources bi) $ \cfile -> do + let ofile = targetDir cfile `replaceExtension` objExtension + createDirectoryIfMissingVerbose verbosity True (takeDirectory ofile) + rawSystemProgramConf verbosity hmakeProgram conf + (commonCcArgs ++ ["-c", cfile, "-o", ofile]) +-} + -- link: + info verbosity "Linking..." + let --cObjs = [ targetDir cFile `replaceExtension` objExtension + -- | cFile <- cSources bi ] + libFilePath = targetDir mkLibName (packageId pkg_descr) + hObjs = [ targetDir ModuleName.toFilePath m <.> objExtension + | m <- modules ] + + unless (null hObjs {-&& null cObjs-}) $ do + -- first remove library if it exists + removeFile libFilePath `catchIO` \_ -> return () + + let arVerbosity | verbosity >= deafening = "v" + | verbosity >= normal = "" + | otherwise = "c" + + rawSystemProgramConf verbosity arProgram (withPrograms lbi) $ + ["q"++ arVerbosity, libFilePath] + ++ hObjs +-- ++ cObjs + +-- | Building an executable for NHC. +buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo + -> Executable -> ComponentLocalBuildInfo -> IO () +buildExe verbosity pkg_descr lbi exe clbi = do + let conf = withPrograms lbi + Just nhcProg = lookupProgram nhcProgram conf + when (dropExtension (modulePath exe) /= exeName exe) $ + die $ "hmake does not support exe names that do not match the name of " + ++ "the 'main-is' file. You will have to rename your executable to " + ++ show (dropExtension (modulePath exe)) + let bi = buildInfo exe + modules = otherModules bi + -- Unsupported extensions have already been checked by configure + languageFlags = languageToFlags (compiler lbi) (defaultLanguage bi) + ++ extensionsToFlags (compiler lbi) (usedExtensions bi) + inFiles <- getModulePaths lbi bi modules + let targetDir = buildDir lbi exeName exe + exeDir = targetDir (exeName exe ++ "-tmp") + srcDirs = nub (map takeDirectory (modulePath exe : inFiles)) + destDirs = map (exeDir ) srcDirs + mapM_ (createDirectoryIfMissingVerbose verbosity True) destDirs + rawSystemProgramConf verbosity hmakeProgram conf $ + ["-hc=" ++ programPath nhcProg] + ++ nhcVerbosityOptions verbosity + ++ ["-d", targetDir, "-hidir", targetDir] + ++ maybe [] (hcOptions NHC . libBuildInfo) + (library pkg_descr) + ++ languageFlags + ++ concat [ ["-package", display (packageName pkgid) ] + | (_, pkgid) <- componentPackageDeps clbi ] + ++ inFiles + ++ [exeName exe] + +nhcVerbosityOptions :: Verbosity -> [String] +nhcVerbosityOptions verbosity + | verbosity >= deafening = ["-v"] + | verbosity >= normal = [] + | otherwise = ["-q"] + +--TODO: where to put this? it's duplicated in .Simple too +getModulePaths :: LocalBuildInfo -> BuildInfo -> [ModuleName] -> IO [FilePath] +getModulePaths lbi bi modules = sequence + [ findFileWithExtension ["hs", "lhs"] (buildDir lbi : hsSourceDirs bi) + (ModuleName.toFilePath module_) >>= maybe (notFound module_) (return . normalise) + | module_ <- modules ] + where notFound module_ = die $ "can't find source for module " ++ display module_ + +-- ----------------------------------------------------------------------------- +-- Installing + +-- |Install executables for NHC. +installExe :: Verbosity -- ^verbosity + -> FilePath -- ^install location + -> FilePath -- ^Build location + -> (FilePath, FilePath) -- ^Executable (prefix,suffix) + -> Executable + -> IO () +installExe verbosity pref buildPref (progprefix,progsuffix) exe + = do createDirectoryIfMissingVerbose verbosity True pref + let exeBaseName = exeName exe + exeFileName = exeBaseName <.> exeExtension + fixedExeFileName = (progprefix ++ exeBaseName ++ progsuffix) <.> exeExtension + installExecutableFile verbosity + (buildPref exeBaseName exeFileName) + (pref fixedExeFileName) + +-- |Install for nhc98: .hi and .a files +installLib :: Verbosity -- ^verbosity + -> FilePath -- ^install location + -> FilePath -- ^Build location + -> PackageIdentifier + -> Library + -> IO () +installLib verbosity pref buildPref pkgid lib + = do let bi = libBuildInfo lib + modules = exposedModules lib ++ otherModules bi + findModuleFiles [buildPref] ["hi"] modules + >>= installOrdinaryFiles verbosity pref + let libName = mkLibName pkgid + installOrdinaryFile verbosity (buildPref libName) (pref libName) diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/PackageIndex.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/PackageIndex.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/PackageIndex.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/PackageIndex.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,562 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.PackageIndex +-- Copyright : (c) David Himmelstrup 2005, +-- Bjorn Bringert 2007, +-- Duncan Coutts 2008-2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- An index of packages. +-- +module Distribution.Simple.PackageIndex ( + -- * Package index data type + PackageIndex, + + -- * Creating an index + fromList, + + -- * Updates + merge, + + insert, + + deleteInstalledPackageId, + deleteSourcePackageId, + deletePackageName, +-- deleteDependency, + + -- * Queries + + -- ** Precise lookups + lookupInstalledPackageId, + lookupSourcePackageId, + lookupPackageName, + lookupDependency, + + -- ** Case-insensitive searches + searchByName, + SearchResult(..), + searchByNameSubstring, + + -- ** Bulk queries + allPackages, + allPackagesByName, + + -- ** Special queries + brokenPackages, + dependencyClosure, + reverseDependencyClosure, + topologicalOrder, + reverseTopologicalOrder, + dependencyInconsistencies, + dependencyCycles, + dependencyGraph, + moduleNameIndex, + ) where + +import Prelude hiding (lookup) +import Control.Exception (assert) +import qualified Data.Map as Map +import Data.Map (Map) +import qualified Data.Tree as Tree +import qualified Data.Graph as Graph +import qualified Data.Array as Array +import Data.Array ((!)) +import Data.List as List + ( null, foldl', sort + , groupBy, sortBy, find, isInfixOf, nubBy, deleteBy, deleteFirstsBy ) +import Data.Monoid (Monoid(..)) +import Data.Maybe (isNothing, fromMaybe) + +import Distribution.Package + ( PackageName(..), PackageId + , Package(..), packageName, packageVersion + , Dependency(Dependency)--, --PackageFixedDeps(..) + , InstalledPackageId(..) ) +import Distribution.ModuleName + ( ModuleName ) +import Distribution.InstalledPackageInfo + ( InstalledPackageInfo, installedPackageId ) +import qualified Distribution.InstalledPackageInfo as IPI +import Distribution.Version + ( Version, withinRange ) +import Distribution.Simple.Utils (lowercase, comparing, equating) + + +-- | The collection of information about packages from one or more 'PackageDB's. +-- +-- Packages are uniquely identified in by their 'InstalledPackageId', they can +-- also be effeciently looked up by package name or by name and version. +-- +data PackageIndex = PackageIndex + -- The primary index. Each InstalledPackageInfo record is uniquely identified + -- by its InstalledPackageId. + -- + !(Map InstalledPackageId InstalledPackageInfo) + + -- This auxillary index maps package names (case-sensitively) to all the + -- versions and instances of that package. This allows us to find all + -- versions satisfying a dependency. + -- + -- It is a three-level index. The first level is the package name, + -- the second is the package version and the final level is instances + -- of the same package version. These are unique by InstalledPackageId + -- and are kept in preference order. + -- + !(Map PackageName (Map Version [InstalledPackageInfo])) + + deriving (Show, Read) + +instance Monoid PackageIndex where + mempty = PackageIndex Map.empty Map.empty + mappend = merge + --save one mappend with empty in the common case: + mconcat [] = mempty + mconcat xs = foldr1 mappend xs + +invariant :: PackageIndex -> Bool +invariant (PackageIndex pids pnames) = + map installedPackageId (Map.elems pids) + == sort + [ assert pinstOk (installedPackageId pinst) + | (pname, pvers) <- Map.toList pnames + , let pversOk = not (Map.null pvers) + , (pver, pinsts) <- assert pversOk $ Map.toList pvers + , let pinsts' = sortBy (comparing installedPackageId) pinsts + pinstsOk = all (\g -> length g == 1) + (groupBy (equating installedPackageId) pinsts') + , pinst <- assert pinstsOk $ pinsts' + , let pinstOk = packageName pinst == pname + && packageVersion pinst == pver + ] + + +-- +-- * Internal helpers +-- + +mkPackageIndex :: Map InstalledPackageId InstalledPackageInfo + -> Map PackageName (Map Version [InstalledPackageInfo]) + -> PackageIndex +mkPackageIndex pids pnames = assert (invariant index) index + where index = PackageIndex pids pnames + + +-- +-- * Construction +-- + +-- | Build an index out of a bunch of packages. +-- +-- If there are duplicates by 'InstalledPackageId' then later ones mask earlier +-- ones. +-- +fromList :: [InstalledPackageInfo] -> PackageIndex +fromList pkgs = mkPackageIndex pids pnames + where + pids = Map.fromList [ (installedPackageId pkg, pkg) | pkg <- pkgs ] + pnames = + Map.fromList + [ (packageName (head pkgsN), pvers) + | pkgsN <- groupBy (equating packageName) + . sortBy (comparing packageId) + $ pkgs + , let pvers = + Map.fromList + [ (packageVersion (head pkgsNV), + nubBy (equating installedPackageId) (reverse pkgsNV)) + | pkgsNV <- groupBy (equating packageVersion) pkgsN + ] + ] + +-- +-- * Updates +-- + +-- | Merge two indexes. +-- +-- Packages from the second mask packages from the first if they have the exact +-- same 'InstalledPackageId'. +-- +-- For packages with the same source 'PackageId', packages from the second are +-- \"preferred\" over those from the first. Being preferred means they are top +-- result when we do a lookup by source 'PackageId'. This is the mechanism we +-- use to prefer user packages over global packages. +-- +merge :: PackageIndex -> PackageIndex -> PackageIndex +merge (PackageIndex pids1 pnames1) (PackageIndex pids2 pnames2) = + mkPackageIndex (Map.union pids1 pids2) + (Map.unionWith (Map.unionWith mergeBuckets) pnames1 pnames2) + where + -- Packages in the second list mask those in the first, however preferred + -- packages go first in the list. + mergeBuckets xs ys = ys ++ (xs \\ ys) + (\\) = deleteFirstsBy (equating installedPackageId) + + +-- | Inserts a single package into the index. +-- +-- This is equivalent to (but slightly quicker than) using 'mappend' or +-- 'merge' with a singleton index. +-- +insert :: InstalledPackageInfo -> PackageIndex -> PackageIndex +insert pkg (PackageIndex pids pnames) = + mkPackageIndex pids' pnames' + + where + pids' = Map.insert (installedPackageId pkg) pkg pids + pnames' = insertPackageName pnames + insertPackageName = + Map.insertWith' (\_ -> insertPackageVersion) + (packageName pkg) + (Map.singleton (packageVersion pkg) [pkg]) + + insertPackageVersion = + Map.insertWith' (\_ -> insertPackageInstance) + (packageVersion pkg) [pkg] + + insertPackageInstance pkgs = + pkg : deleteBy (equating installedPackageId) pkg pkgs + + +-- | Removes a single installed package from the index. +-- +deleteInstalledPackageId :: InstalledPackageId -> PackageIndex -> PackageIndex +deleteInstalledPackageId ipkgid original@(PackageIndex pids pnames) = + case Map.updateLookupWithKey (\_ _ -> Nothing) ipkgid pids of + (Nothing, _) -> original + (Just spkgid, pids') -> mkPackageIndex pids' + (deletePkgName spkgid pnames) + + where + deletePkgName spkgid = + Map.update (deletePkgVersion spkgid) (packageName spkgid) + + deletePkgVersion spkgid = + (\m -> if Map.null m then Nothing else Just m) + . Map.update deletePkgInstance (packageVersion spkgid) + + deletePkgInstance = + (\xs -> if List.null xs then Nothing else Just xs) + . List.deleteBy (\_ pkg -> installedPackageId pkg == ipkgid) undefined + + +-- | Removes all packages with this source 'PackageId' from the index. +-- +deleteSourcePackageId :: PackageId -> PackageIndex -> PackageIndex +deleteSourcePackageId pkgid original@(PackageIndex pids pnames) = + case Map.lookup (packageName pkgid) pnames of + Nothing -> original + Just pvers -> case Map.lookup (packageVersion pkgid) pvers of + Nothing -> original + Just pkgs -> mkPackageIndex + (foldl' (flip (Map.delete . installedPackageId)) pids pkgs) + (deletePkgName pnames) + where + deletePkgName = + Map.update deletePkgVersion (packageName pkgid) + + deletePkgVersion = + (\m -> if Map.null m then Nothing else Just m) + . Map.delete (packageVersion pkgid) + + +-- | Removes all packages with this (case-sensitive) name from the index. +-- +deletePackageName :: PackageName -> PackageIndex -> PackageIndex +deletePackageName name original@(PackageIndex pids pnames) = + case Map.lookup name pnames of + Nothing -> original + Just pvers -> mkPackageIndex + (foldl' (flip (Map.delete . installedPackageId)) pids + (concat (Map.elems pvers))) + (Map.delete name pnames) + +{- +-- | Removes all packages satisfying this dependency from the index. +-- +deleteDependency :: Dependency -> PackageIndex -> PackageIndex +deleteDependency (Dependency name verstionRange) = + delete' name (\pkg -> packageVersion pkg `withinRange` verstionRange) +-} + +-- +-- * Bulk queries +-- + +-- | Get all the packages from the index. +-- +allPackages :: PackageIndex -> [InstalledPackageInfo] +allPackages (PackageIndex pids _) = Map.elems pids + +-- | Get all the packages from the index. +-- +-- They are grouped by package name, case-sensitively. +-- +allPackagesByName :: PackageIndex -> [[InstalledPackageInfo]] +allPackagesByName (PackageIndex _ pnames) = + concatMap Map.elems (Map.elems pnames) + +-- +-- * Lookups +-- + +-- | Does a lookup by source package id (name & version). +-- +-- Since multiple package DBs mask each other by 'InstalledPackageId', +-- then we get back at most one package. +-- +lookupInstalledPackageId :: PackageIndex -> InstalledPackageId + -> Maybe InstalledPackageInfo +lookupInstalledPackageId (PackageIndex pids _) pid = Map.lookup pid pids + + +-- | Does a lookup by source package id (name & version). +-- +-- There can be multiple installed packages with the same source 'PackageId' +-- but different 'InstalledPackageId'. They are returned in order of +-- preference, with the most preferred first. +-- +lookupSourcePackageId :: PackageIndex -> PackageId -> [InstalledPackageInfo] +lookupSourcePackageId (PackageIndex _ pnames) pkgid = + case Map.lookup (packageName pkgid) pnames of + Nothing -> [] + Just pvers -> case Map.lookup (packageVersion pkgid) pvers of + Nothing -> [] + Just pkgs -> pkgs -- in preference order + + +-- | Does a lookup by source package name. +-- +lookupPackageName :: PackageIndex -> PackageName + -> [(Version, [InstalledPackageInfo])] +lookupPackageName (PackageIndex _ pnames) name = + case Map.lookup name pnames of + Nothing -> [] + Just pvers -> Map.toList pvers + + +-- | Does a lookup by source package name and a range of versions. +-- +-- We get back any number of versions of the specified package name, all +-- satisfying the version range constraint. +-- +lookupDependency :: PackageIndex -> Dependency + -> [(Version, [InstalledPackageInfo])] +lookupDependency (PackageIndex _ pnames) (Dependency name versionRange) = + case Map.lookup name pnames of + Nothing -> [] + Just pvers -> [ entry + | entry@(ver, _) <- Map.toList pvers + , ver `withinRange` versionRange ] + +-- +-- * Case insensitive name lookups +-- + +-- | Does a case-insensitive search by package name. +-- +-- If there is only one package that compares case-insentiviely to this name +-- then the search is unambiguous and we get back all versions of that package. +-- If several match case-insentiviely but one matches exactly then it is also +-- unambiguous. +-- +-- If however several match case-insentiviely and none match exactly then we +-- have an ambiguous result, and we get back all the versions of all the +-- packages. The list of ambiguous results is split by exact package name. So +-- it is a non-empty list of non-empty lists. +-- +searchByName :: PackageIndex -> String -> SearchResult [InstalledPackageInfo] +searchByName (PackageIndex _ pnames) name = + case [ pkgs | pkgs@(PackageName name',_) <- Map.toList pnames + , lowercase name' == lname ] of + [] -> None + [(_,pvers)] -> Unambiguous (concat (Map.elems pvers)) + pkgss -> case find ((PackageName name==) . fst) pkgss of + Just (_,pvers) -> Unambiguous (concat (Map.elems pvers)) + Nothing -> Ambiguous (map (concat . Map.elems . snd) pkgss) + where lname = lowercase name + +data SearchResult a = None | Unambiguous a | Ambiguous [a] + +-- | Does a case-insensitive substring search by package name. +-- +-- That is, all packages that contain the given string in their name. +-- +searchByNameSubstring :: PackageIndex -> String -> [InstalledPackageInfo] +searchByNameSubstring (PackageIndex _ pnames) searchterm = + [ pkg + | (PackageName name, pvers) <- Map.toList pnames + , lsearchterm `isInfixOf` lowercase name + , pkgs <- Map.elems pvers + , pkg <- pkgs ] + where lsearchterm = lowercase searchterm + + +-- +-- * Special queries +-- + +-- None of the stuff below depends on the internal representation of the index. +-- + +-- | Find if there are any cycles in the dependency graph. If there are no +-- cycles the result is @[]@. +-- +-- This actually computes the strongly connected components. So it gives us a +-- list of groups of packages where within each group they all depend on each +-- other, directly or indirectly. +-- +dependencyCycles :: PackageIndex -> [[InstalledPackageInfo]] +dependencyCycles index = + [ vs | Graph.CyclicSCC vs <- Graph.stronglyConnComp adjacencyList ] + where + adjacencyList = [ (pkg, installedPackageId pkg, IPI.depends pkg) + | pkg <- allPackages index ] + + +-- | All packages that have immediate dependencies that are not in the index. +-- +-- Returns such packages along with the dependencies that they're missing. +-- +brokenPackages :: PackageIndex -> [(InstalledPackageInfo, [InstalledPackageId])] +brokenPackages index = + [ (pkg, missing) + | pkg <- allPackages index + , let missing = [ pkg' | pkg' <- IPI.depends pkg + , isNothing (lookupInstalledPackageId index pkg') ] + , not (null missing) ] + + +-- | Tries to take the transitive closure of the package dependencies. +-- +-- If the transitive closure is complete then it returns that subset of the +-- index. Otherwise it returns the broken packages as in 'brokenPackages'. +-- +-- * Note that if the result is @Right []@ it is because at least one of +-- the original given 'PackageId's do not occur in the index. +-- +dependencyClosure :: PackageIndex + -> [InstalledPackageId] + -> Either PackageIndex + [(InstalledPackageInfo, [InstalledPackageId])] +dependencyClosure index pkgids0 = case closure mempty [] pkgids0 of + (completed, []) -> Left completed + (completed, _) -> Right (brokenPackages completed) + where + closure completed failed [] = (completed, failed) + closure completed failed (pkgid:pkgids) = case lookupInstalledPackageId index pkgid of + Nothing -> closure completed (pkgid:failed) pkgids + Just pkg -> case lookupInstalledPackageId completed (installedPackageId pkg) of + Just _ -> closure completed failed pkgids + Nothing -> closure completed' failed pkgids' + where completed' = insert pkg completed + pkgids' = IPI.depends pkg ++ pkgids + +-- | Takes the transitive closure of the packages reverse dependencies. +-- +-- * The given 'PackageId's must be in the index. +-- +reverseDependencyClosure :: PackageIndex + -> [InstalledPackageId] + -> [InstalledPackageInfo] +reverseDependencyClosure index = + map vertexToPkg + . concatMap Tree.flatten + . Graph.dfs reverseDepGraph + . map (fromMaybe noSuchPkgId . pkgIdToVertex) + + where + (depGraph, vertexToPkg, pkgIdToVertex) = dependencyGraph index + reverseDepGraph = Graph.transposeG depGraph + noSuchPkgId = error "reverseDependencyClosure: package is not in the graph" + +topologicalOrder :: PackageIndex -> [InstalledPackageInfo] +topologicalOrder index = map toPkgId + . Graph.topSort + $ graph + where (graph, toPkgId, _) = dependencyGraph index + +reverseTopologicalOrder :: PackageIndex -> [InstalledPackageInfo] +reverseTopologicalOrder index = map toPkgId + . Graph.topSort + . Graph.transposeG + $ graph + where (graph, toPkgId, _) = dependencyGraph index + +-- | Builds a graph of the package dependencies. +-- +-- Dependencies on other packages that are not in the index are discarded. +-- You can check if there are any such dependencies with 'brokenPackages'. +-- +dependencyGraph :: PackageIndex + -> (Graph.Graph, + Graph.Vertex -> InstalledPackageInfo, + InstalledPackageId -> Maybe Graph.Vertex) +dependencyGraph index = (graph, vertex_to_pkg, id_to_vertex) + where + graph = Array.listArray bounds + [ [ v | Just v <- map id_to_vertex (IPI.depends pkg) ] + | pkg <- pkgs ] + + pkgs = sortBy (comparing packageId) (allPackages index) + vertices = zip (map installedPackageId pkgs) [0..] + vertex_map = Map.fromList vertices + id_to_vertex pid = Map.lookup pid vertex_map + + vertex_to_pkg vertex = pkgTable ! vertex + + pkgTable = Array.listArray bounds pkgs + topBound = length pkgs - 1 + bounds = (0, topBound) + +-- | Given a package index where we assume we want to use all the packages +-- (use 'dependencyClosure' if you need to get such a index subset) find out +-- if the dependencies within it use consistent versions of each package. +-- Return all cases where multiple packages depend on different versions of +-- some other package. +-- +-- Each element in the result is a package name along with the packages that +-- depend on it and the versions they require. These are guaranteed to be +-- distinct. +-- +dependencyInconsistencies :: PackageIndex + -> [(PackageName, [(PackageId, Version)])] +dependencyInconsistencies index = + [ (name, [ (pid,packageVersion dep) | (dep,pids) <- uses, pid <- pids]) + | (name, ipid_map) <- Map.toList inverseIndex + , let uses = Map.elems ipid_map + , reallyIsInconsistent (map fst uses) ] + + where -- for each PackageName, + -- for each package with that name, + -- the InstalledPackageInfo and the package Ids of packages + -- that depend on it. + inverseIndex :: Map PackageName + (Map InstalledPackageId + (InstalledPackageInfo, [PackageId])) + inverseIndex = Map.fromListWith (Map.unionWith (\(a,b) (_,b') -> (a,b++b'))) + [ (packageName dep, + Map.fromList [(ipid,(dep,[packageId pkg]))]) + | pkg <- allPackages index + , ipid <- IPI.depends pkg + , Just dep <- [lookupInstalledPackageId index ipid] + ] + + reallyIsInconsistent :: [InstalledPackageInfo] -> Bool + reallyIsInconsistent [] = False + reallyIsInconsistent [_p] = False + reallyIsInconsistent [p1, p2] = + installedPackageId p1 `notElem` IPI.depends p2 + && installedPackageId p2 `notElem` IPI.depends p1 + reallyIsInconsistent _ = True + + +moduleNameIndex :: PackageIndex -> Map ModuleName [InstalledPackageInfo] +moduleNameIndex index = + Map.fromListWith (++) + [ (moduleName, [pkg]) + | pkg <- allPackages index + , moduleName <- IPI.exposedModules pkg ] diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/PreProcess/Unlit.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/PreProcess/Unlit.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/PreProcess/Unlit.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/PreProcess/Unlit.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,165 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.PreProcess.Unlit +-- Copyright : ... +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Remove the \"literal\" markups from a Haskell source file, including +-- \"@>@\", \"@\\begin{code}@\", \"@\\end{code}@\", and \"@#@\" + +-- This version is interesting because instead of striping comment lines, it +-- turns them into "-- " style comments. This allows using haddock markup +-- in literate scripts without having to use "> --" prefix. + +module Distribution.Simple.PreProcess.Unlit (unlit,plain) where + +import Data.Char +import Data.List + +data Classified = BirdTrack String | Blank String | Ordinary String + | Line !Int String | CPP String + | BeginCode | EndCode + -- output only: + | Error String | Comment String + +-- | No unliteration. +plain :: String -> String -> String +plain _ hs = hs + +classify :: String -> Classified +classify ('>':s) = BirdTrack s +classify ('#':s) = case tokens s of + (line:file:_) | all isDigit line + && length file >= 2 + && head file == '"' + && last file == '"' + -> Line (read line) (tail (init file)) + _ -> CPP s + where tokens = unfoldr $ \str -> case lex str of + (t@(_:_), str'):_ -> Just (t, str') + _ -> Nothing +classify ('\\':s) + | "begin{code}" `isPrefixOf` s = BeginCode + | "end{code}" `isPrefixOf` s = EndCode +classify s | all isSpace s = Blank s +classify s = Ordinary s + +-- So the weird exception for comment indenting is to make things work with +-- haddock, see classifyAndCheckForBirdTracks below. +unclassify :: Bool -> Classified -> String +unclassify _ (BirdTrack s) = ' ':s +unclassify _ (Blank s) = s +unclassify _ (Ordinary s) = s +unclassify _ (Line n file) = "# " ++ show n ++ " " ++ show file +unclassify _ (CPP s) = '#':s +unclassify True (Comment "") = " --" +unclassify True (Comment s) = " -- " ++ s +unclassify False (Comment "") = "--" +unclassify False (Comment s) = "-- " ++ s +unclassify _ _ = internalError + +-- | 'unlit' takes a filename (for error reports), and transforms the +-- given string, to eliminate the literate comments from the program text. +unlit :: FilePath -> String -> Either String String +unlit file input = + let (usesBirdTracks, classified) = classifyAndCheckForBirdTracks + . inlines + $ input + in either (Left . unlines . map (unclassify usesBirdTracks)) + Right + . checkErrors + . reclassify + $ classified + + where + -- So haddock requires comments and code to align, since it treats comments + -- as following the layout rule. This is a pain for us since bird track + -- style literate code typically gets indented by two since ">" is replaced + -- by " " and people usually use one additional space of indent ie + -- "> then the code". On the other hand we cannot just go and indent all + -- the comments by two since that does not work for latex style literate + -- code. So the hacky solution we use here is that if we see any bird track + -- style code then we'll indent all comments by two, otherwise by none. + -- Of course this will not work for mixed latex/bird track .lhs files but + -- nobody does that, it's silly and specifically recommended against in the + -- H98 unlit spec. + -- + classifyAndCheckForBirdTracks = + flip mapAccumL False $ \seenBirdTrack line -> + let classification = classify line + in (seenBirdTrack || isBirdTrack classification, classification) + + isBirdTrack (BirdTrack _) = True + isBirdTrack _ = False + + checkErrors ls = case [ e | Error e <- ls ] of + [] -> Left ls + (message:_) -> Right (f ++ ":" ++ show n ++ ": " ++ message) + where (f, n) = errorPos file 1 ls + errorPos f n [] = (f, n) + errorPos f n (Error _:_) = (f, n) + errorPos _ _ (Line n' f':ls) = errorPos f' n' ls + errorPos f n (_ :ls) = errorPos f (n+1) ls + +-- Here we model a state machine, with each state represented by +-- a local function. We only have four states (well, five, +-- if you count the error state), but the rules +-- to transition between then are not so simple. +-- Would it be simpler to have more states? +-- +-- Each state represents the type of line that was last read +-- i.e. are we in a comment section, or a latex-code section, +-- or a bird-code section, etc? +reclassify :: [Classified] -> [Classified] +reclassify = blank -- begin in blank state + where + latex [] = [] + latex (EndCode :ls) = Blank "" : comment ls + latex (BeginCode :_ ) = [Error "\\begin{code} in code section"] + latex (BirdTrack l:ls) = Ordinary ('>':l) : latex ls + latex ( l:ls) = l : latex ls + + blank [] = [] + blank (EndCode :_ ) = [Error "\\end{code} without \\begin{code}"] + blank (BeginCode :ls) = Blank "" : latex ls + blank (BirdTrack l:ls) = BirdTrack l : bird ls + blank (Ordinary l:ls) = Comment l : comment ls + blank ( l:ls) = l : blank ls + + bird [] = [] + bird (EndCode :_ ) = [Error "\\end{code} without \\begin{code}"] + bird (BeginCode :ls) = Blank "" : latex ls + bird (Blank l :ls) = Blank l : blank ls + bird (Ordinary _:_ ) = [Error "program line before comment line"] + bird ( l:ls) = l : bird ls + + comment [] = [] + comment (EndCode :_ ) = [Error "\\end{code} without \\begin{code}"] + comment (BeginCode :ls) = Blank "" : latex ls + comment (CPP l :ls) = CPP l : comment ls + comment (BirdTrack _:_ ) = [Error "comment line before program line"] + -- a blank line and another ordinary line following a comment + -- will be treated as continuing the comment. Otherwise it's + -- then end of the comment, with a blank line. + comment (Blank l:ls@(Ordinary _:_)) = Comment l : comment ls + comment (Blank l:ls) = Blank l : blank ls + comment (Line n f :ls) = Line n f : comment ls + comment (Ordinary l:ls) = Comment l : comment ls + comment (Comment _: _) = internalError + comment (Error _: _) = internalError + +-- Re-implementation of 'lines', for better efficiency (but decreased laziness). +-- Also, importantly, accepts non-standard DOS and Mac line ending characters. +inlines :: String -> [String] +inlines xs = lines' xs id + where + lines' [] acc = [acc []] + lines' ('\^M':'\n':s) acc = acc [] : lines' s id -- DOS + lines' ('\^M':s) acc = acc [] : lines' s id -- MacOS + lines' ('\n':s) acc = acc [] : lines' s id -- Unix + lines' (c:s) acc = lines' s (acc . (c:)) + +internalError :: a +internalError = error "unlit: internal error" diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/PreProcess.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/PreProcess.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/PreProcess.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/PreProcess.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,596 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.PreProcess +-- Copyright : (c) 2003-2005, Isaac Jones, Malcolm Wallace +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This defines a 'PreProcessor' abstraction which represents a pre-processor +-- that can transform one kind of file into another. There is also a +-- 'PPSuffixHandler' which is a combination of a file extension and a function +-- for configuring a 'PreProcessor'. It defines a bunch of known built-in +-- preprocessors like @cpp@, @cpphs@, @c2hs@, @hsc2hs@, @happy@, @alex@ etc and +-- lists them in 'knownSuffixHandlers'. On top of this it provides a function +-- for actually preprocessing some sources given a bunch of known suffix +-- handlers. This module is not as good as it could be, it could really do with +-- a rewrite to address some of the problems we have with pre-processors. + +{- Copyright (c) 2003-2005, Isaac Jones, Malcolm Wallace +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.Simple.PreProcess (preprocessComponent, knownSuffixHandlers, + ppSuffixes, PPSuffixHandler, PreProcessor(..), + mkSimplePreProcessor, runSimplePreProcessor, + ppCpp, ppCpp', ppGreenCard, ppC2hs, ppHsc2hs, + ppHappy, ppAlex, ppUnlit + ) + where + + +import Control.Monad +import Distribution.Simple.PreProcess.Unlit (unlit) +import Distribution.Package + ( Package(..), PackageName(..) ) +import qualified Distribution.ModuleName as ModuleName +import Distribution.PackageDescription as PD + ( PackageDescription(..), BuildInfo(..) + , Executable(..) + , Library(..), libModules + , TestSuite(..), testModules + , TestSuiteInterface(..) ) +import qualified Distribution.InstalledPackageInfo as Installed + ( InstalledPackageInfo_(..) ) +import qualified Distribution.Simple.PackageIndex as PackageIndex +import Distribution.Simple.Compiler + ( CompilerFlavor(..), Compiler(..), compilerFlavor, compilerVersion ) +import Distribution.Simple.LocalBuildInfo + ( LocalBuildInfo(..), Component(..) ) +import Distribution.Simple.BuildPaths (autogenModulesDir,cppHeaderName) +import Distribution.Simple.Utils + ( createDirectoryIfMissingVerbose, withUTF8FileContents, writeUTF8File + , die, setupMessage, intercalate, copyFileVerbose + , findFileWithExtension, findFileWithExtension' ) +import Distribution.Simple.Program + ( Program(..), ConfiguredProgram(..), programPath + , lookupProgram, requireProgram, requireProgramVersion + , rawSystemProgramConf, rawSystemProgram + , greencardProgram, cpphsProgram, hsc2hsProgram, c2hsProgram + , happyProgram, alexProgram, haddockProgram, ghcProgram, gccProgram ) +import Distribution.Simple.Test ( writeSimpleTestStub, stubFilePath, stubName ) +import Distribution.System + ( OS(OSX, Windows), buildOS ) +import Distribution.Text +import Distribution.Version + ( Version(..), anyVersion, orLaterVersion ) +import Distribution.Verbosity + +import Data.Maybe (fromMaybe) +import Data.List (nub) +import System.Directory (getModificationTime, doesFileExist) +import System.Info (os, arch) +import System.FilePath (splitExtension, dropExtensions, (), (<.>), + takeDirectory, normalise, replaceExtension) + +-- |The interface to a preprocessor, which may be implemented using an +-- external program, but need not be. The arguments are the name of +-- the input file, the name of the output file and a verbosity level. +-- Here is a simple example that merely prepends a comment to the given +-- source file: +-- +-- > ppTestHandler :: PreProcessor +-- > ppTestHandler = +-- > PreProcessor { +-- > platformIndependent = True, +-- > runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> +-- > do info verbosity (inFile++" has been preprocessed to "++outFile) +-- > stuff <- readFile inFile +-- > writeFile outFile ("-- preprocessed as a test\n\n" ++ stuff) +-- > return ExitSuccess +-- +-- We split the input and output file names into a base directory and the +-- rest of the file name. The input base dir is the path in the list of search +-- dirs that this file was found in. The output base dir is the build dir where +-- all the generated source files are put. +-- +-- The reason for splitting it up this way is that some pre-processors don't +-- simply generate one output .hs file from one input file but have +-- dependencies on other genereated files (notably c2hs, where building one +-- .hs file may require reading other .chi files, and then compiling the .hs +-- file may require reading a generated .h file). In these cases the generated +-- files need to embed relative path names to each other (eg the generated .hs +-- file mentions the .h file in the FFI imports). This path must be relative to +-- the base directory where the genereated files are located, it cannot be +-- relative to the top level of the build tree because the compilers do not +-- look for .h files relative to there, ie we do not use \"-I .\", instead we +-- use \"-I dist\/build\" (or whatever dist dir has been set by the user) +-- +-- Most pre-processors do not care of course, so mkSimplePreProcessor and +-- runSimplePreProcessor functions handle the simple case. +-- +data PreProcessor = PreProcessor { + + -- Is the output of the pre-processor platform independent? eg happy output + -- is portable haskell but c2hs's output is platform dependent. + -- This matters since only platform independent generated code can be + -- inlcuded into a source tarball. + platformIndependent :: Bool, + + -- TODO: deal with pre-processors that have implementaion dependent output + -- eg alex and happy have --ghc flags. However we can't really inlcude + -- ghc-specific code into supposedly portable source tarballs. + + runPreProcessor :: (FilePath, FilePath) -- Location of the source file relative to a base dir + -> (FilePath, FilePath) -- Output file name, relative to an output base dir + -> Verbosity -- verbosity + -> IO () -- Should exit if the preprocessor fails + } + +mkSimplePreProcessor :: (FilePath -> FilePath -> Verbosity -> IO ()) + -> (FilePath, FilePath) + -> (FilePath, FilePath) -> Verbosity -> IO () +mkSimplePreProcessor simplePP + (inBaseDir, inRelativeFile) + (outBaseDir, outRelativeFile) verbosity = simplePP inFile outFile verbosity + where inFile = normalise (inBaseDir inRelativeFile) + outFile = normalise (outBaseDir outRelativeFile) + +runSimplePreProcessor :: PreProcessor -> FilePath -> FilePath -> Verbosity + -> IO () +runSimplePreProcessor pp inFile outFile verbosity = + runPreProcessor pp (".", inFile) (".", outFile) verbosity + +-- |A preprocessor for turning non-Haskell files with the given extension +-- into plain Haskell source files. +type PPSuffixHandler + = (String, BuildInfo -> LocalBuildInfo -> PreProcessor) + +-- | Apply preprocessors to the sources from 'hsSourceDirs' for a given +-- component (lib, exe, or test suite). +preprocessComponent :: PackageDescription + -> Component + -> LocalBuildInfo + -> Bool + -> Verbosity + -> [PPSuffixHandler] + -> IO () +preprocessComponent pd comp lbi isSrcDist verbosity handlers = case comp of + (CLib lib@Library{ libBuildInfo = bi }) -> do + let dirs = hsSourceDirs bi ++ [autogenModulesDir lbi] + setupMessage verbosity "Preprocessing library" (packageId pd) + forM_ (map ModuleName.toFilePath $ libModules lib) $ + pre dirs (buildDir lbi) (localHandlers bi) + (CExe exe@Executable { buildInfo = bi, exeName = nm }) -> do + let exeDir = buildDir lbi nm nm ++ "-tmp" + dirs = hsSourceDirs bi ++ [autogenModulesDir lbi] + setupMessage verbosity ("Preprocessing executable '" ++ nm ++ "' for") (packageId pd) + forM_ (map ModuleName.toFilePath $ otherModules bi) $ + pre dirs exeDir (localHandlers bi) + pre (hsSourceDirs bi) exeDir (localHandlers bi) $ + dropExtensions (modulePath exe) + CTest test@TestSuite{ testName = nm } -> do + setupMessage verbosity ("Preprocessing test suite '" ++ nm ++ "' for") (packageId pd) + case testInterface test of + TestSuiteExeV10 _ f -> + preProcessTest test f $ buildDir lbi testName test + testName test ++ "-tmp" + TestSuiteLibV09 _ _ -> do + let testDir = buildDir lbi stubName test + stubName test ++ "-tmp" + writeSimpleTestStub test testDir + preProcessTest test (stubFilePath test) testDir + TestSuiteUnsupported tt -> die $ "No support for preprocessing test " + ++ "suite type " ++ display tt + where + builtinSuffixes + | NHC == compilerFlavor (compiler lbi) = ["hs", "lhs", "gc"] + | otherwise = ["hs", "lhs"] + localHandlers bi = [(ext, h bi lbi) | (ext, h) <- handlers] + pre dirs dir lhndlrs fp = + preprocessFile dirs dir isSrcDist fp verbosity builtinSuffixes lhndlrs + preProcessTest test exePath testDir = do + let bi = testBuildInfo test + biHandlers = localHandlers bi + sourceDirs = hsSourceDirs bi ++ [ autogenModulesDir lbi ] + sequence_ [ preprocessFile sourceDirs (buildDir lbi) isSrcDist + (ModuleName.toFilePath modu) verbosity builtinSuffixes + biHandlers + | modu <- testModules test ] + preprocessFile (testDir : (hsSourceDirs bi)) testDir isSrcDist + (dropExtensions $ exePath) verbosity + builtinSuffixes biHandlers + +--TODO: try to list all the modules that could not be found +-- not just the first one. It's annoying and slow due to the need +-- to reconfigure after editing the .cabal file each time. + +-- |Find the first extension of the file that exists, and preprocess it +-- if required. +preprocessFile + :: [FilePath] -- ^source directories + -> FilePath -- ^build directory + -> Bool -- ^preprocess for sdist + -> FilePath -- ^module file name + -> Verbosity -- ^verbosity + -> [String] -- ^builtin suffixes + -> [(String, PreProcessor)] -- ^possible preprocessors + -> IO () +preprocessFile searchLoc buildLoc forSDist baseFile verbosity builtinSuffixes handlers = do + -- look for files in the various source dirs with this module name + -- and a file extension of a known preprocessor + psrcFiles <- findFileWithExtension' (map fst handlers) searchLoc baseFile + case psrcFiles of + -- no preprocessor file exists, look for an ordinary source file + -- just to make sure one actually exists at all for this module. + -- Note: by looking in the target/output build dir too, we allow + -- source files to appear magically in the target build dir without + -- any corresponding "real" source file. This lets custom Setup.hs + -- files generate source modules directly into the build dir without + -- the rest of the build system being aware of it (somewhat dodgy) + Nothing -> do + bsrcFiles <- findFileWithExtension builtinSuffixes (buildLoc : searchLoc) baseFile + case bsrcFiles of + Nothing -> die $ "can't find source for " ++ baseFile + ++ " in " ++ intercalate ", " searchLoc + _ -> return () + -- found a pre-processable file in one of the source dirs + Just (psrcLoc, psrcRelFile) -> do + let (srcStem, ext) = splitExtension psrcRelFile + psrcFile = psrcLoc psrcRelFile + pp = fromMaybe (error "Internal error in preProcess module: Just expected") + (lookup (tailNotNull ext) handlers) + -- Preprocessing files for 'sdist' is different from preprocessing + -- for 'build'. When preprocessing for sdist we preprocess to + -- avoid that the user has to have the preprocessors available. + -- ATM, we don't have a way to specify which files are to be + -- preprocessed and which not, so for sdist we only process + -- platform independent files and put them into the 'buildLoc' + -- (which we assume is set to the temp. directory that will become + -- the tarball). + --TODO: eliminate sdist variant, just supply different handlers + when (not forSDist || forSDist && platformIndependent pp) $ do + -- look for existing pre-processed source file in the dest dir to + -- see if we really have to re-run the preprocessor. + ppsrcFiles <- findFileWithExtension builtinSuffixes [buildLoc] baseFile + recomp <- case ppsrcFiles of + Nothing -> return True + Just ppsrcFile -> do + btime <- getModificationTime ppsrcFile + ptime <- getModificationTime psrcFile + return (btime < ptime) + when recomp $ do + let destDir = buildLoc dirName srcStem + createDirectoryIfMissingVerbose verbosity True destDir + runPreProcessorWithHsBootHack pp + (psrcLoc, psrcRelFile) + (buildLoc, srcStem <.> "hs") + + where + dirName = takeDirectory + tailNotNull [] = [] + tailNotNull x = tail x + + -- FIXME: This is a somewhat nasty hack. GHC requires that hs-boot files + -- be in the same place as the hs files, so if we put the hs file in dist/ + -- then we need to copy the hs-boot file there too. This should probably be + -- done another way. Possibly we should also be looking for .lhs-boot + -- files, but I think that preprocessors only produce .hs files. + runPreProcessorWithHsBootHack pp + (inBaseDir, inRelativeFile) + (outBaseDir, outRelativeFile) = do + runPreProcessor pp + (inBaseDir, inRelativeFile) + (outBaseDir, outRelativeFile) verbosity + + exists <- doesFileExist inBoot + when exists $ copyFileVerbose verbosity inBoot outBoot + + where + inBoot = replaceExtension inFile "hs-boot" + outBoot = replaceExtension outFile "hs-boot" + + inFile = normalise (inBaseDir inRelativeFile) + outFile = normalise (outBaseDir outRelativeFile) + +-- ------------------------------------------------------------ +-- * known preprocessors +-- ------------------------------------------------------------ + +ppGreenCard :: BuildInfo -> LocalBuildInfo -> PreProcessor +ppGreenCard _ lbi + = PreProcessor { + platformIndependent = False, + runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> + rawSystemProgramConf verbosity greencardProgram (withPrograms lbi) + (["-tffi", "-o" ++ outFile, inFile]) + } + +-- This one is useful for preprocessors that can't handle literate source. +-- We also need a way to chain preprocessors. +ppUnlit :: PreProcessor +ppUnlit = + PreProcessor { + platformIndependent = True, + runPreProcessor = mkSimplePreProcessor $ \inFile outFile _verbosity -> + withUTF8FileContents inFile $ \contents -> + either (writeUTF8File outFile) die (unlit inFile contents) + } + +ppCpp :: BuildInfo -> LocalBuildInfo -> PreProcessor +ppCpp = ppCpp' [] + +ppCpp' :: [String] -> BuildInfo -> LocalBuildInfo -> PreProcessor +ppCpp' extraArgs bi lbi = + case compilerFlavor (compiler lbi) of + GHC -> ppGhcCpp (cppArgs ++ extraArgs) bi lbi + _ -> ppCpphs (cppArgs ++ extraArgs) bi lbi + + where cppArgs = getCppOptions bi lbi + +ppGhcCpp :: [String] -> BuildInfo -> LocalBuildInfo -> PreProcessor +ppGhcCpp extraArgs _bi lbi = + PreProcessor { + platformIndependent = False, + runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do + (ghcProg, ghcVersion, _) <- requireProgramVersion verbosity + ghcProgram anyVersion (withPrograms lbi) + rawSystemProgram verbosity ghcProg $ + ["-E", "-cpp"] + -- This is a bit of an ugly hack. We're going to + -- unlit the file ourselves later on if appropriate, + -- so we need GHC not to unlit it now or it'll get + -- double-unlitted. In the future we might switch to + -- using cpphs --unlit instead. + ++ (if ghcVersion >= Version [6,6] [] then ["-x", "hs"] else []) + ++ (if use_optP_P lbi then ["-optP-P"] else []) + ++ [ "-optP-include", "-optP"++ (autogenModulesDir lbi cppHeaderName) ] + ++ ["-o", outFile, inFile] + ++ extraArgs + } + +ppCpphs :: [String] -> BuildInfo -> LocalBuildInfo -> PreProcessor +ppCpphs extraArgs _bi lbi = + PreProcessor { + platformIndependent = False, + runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do + (cpphsProg, cpphsVersion, _) <- requireProgramVersion verbosity + cpphsProgram anyVersion (withPrograms lbi) + rawSystemProgram verbosity cpphsProg $ + ("-O" ++ outFile) : inFile + : "--noline" : "--strip" + : (if cpphsVersion >= Version [1,6] [] + then ["--include="++ (autogenModulesDir lbi cppHeaderName)] + else []) + ++ extraArgs + } + +-- Haddock versions before 0.8 choke on #line and #file pragmas. Those +-- pragmas are necessary for correct links when we preprocess. So use +-- -optP-P only if the Haddock version is prior to 0.8. +use_optP_P :: LocalBuildInfo -> Bool +use_optP_P lbi + = case lookupProgram haddockProgram (withPrograms lbi) of + Just (ConfiguredProgram { programVersion = Just version }) + | version >= Version [0,8] [] -> False + _ -> True + +ppHsc2hs :: BuildInfo -> LocalBuildInfo -> PreProcessor +ppHsc2hs bi lbi = + PreProcessor { + platformIndependent = False, + runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do + (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi) + rawSystemProgramConf verbosity hsc2hsProgram (withPrograms lbi) $ + [ "--cc=" ++ programPath gccProg + , "--ld=" ++ programPath gccProg ] + + -- Additional gcc options + ++ [ "--cflag=" ++ opt | opt <- programDefaultArgs gccProg + ++ programOverrideArgs gccProg ] + ++ [ "--lflag=" ++ opt | opt <- programDefaultArgs gccProg + ++ programOverrideArgs gccProg ] + + -- OSX frameworks: + ++ [ what ++ "=-F" ++ opt + | isOSX + , opt <- nub (concatMap Installed.frameworkDirs pkgs) + , what <- ["--cflag", "--lflag"] ] + ++ [ "--lflag=" ++ arg + | isOSX + , opt <- PD.frameworks bi ++ concatMap Installed.frameworks pkgs + , arg <- ["-framework", opt] ] + + -- Note that on ELF systems, wherever we use -L, we must also use -R + -- because presumably that -L dir is not on the normal path for the + -- system's dynamic linker. This is needed because hsc2hs works by + -- compiling a C program and then running it. + + ++ [ "--cflag=" ++ opt | opt <- hcDefines (compiler lbi) ] + ++ [ "--cflag=" ++ opt | opt <- sysDefines ] + + -- Options from the current package: + ++ [ "--cflag=-I" ++ dir | dir <- PD.includeDirs bi ] + ++ [ "--cflag=" ++ opt | opt <- PD.ccOptions bi + ++ PD.cppOptions bi ] + ++ [ "--lflag=-L" ++ opt | opt <- PD.extraLibDirs bi ] + ++ [ "--lflag=-Wl,-R," ++ opt | isELF + , opt <- PD.extraLibDirs bi ] + ++ [ "--lflag=-l" ++ opt | opt <- PD.extraLibs bi ] + ++ [ "--lflag=" ++ opt | opt <- PD.ldOptions bi ] + + -- Options from dependent packages + ++ [ "--cflag=" ++ opt + | pkg <- pkgs + , opt <- [ "-I" ++ opt | opt <- Installed.includeDirs pkg ] + ++ [ opt | opt <- Installed.ccOptions pkg ] + ++ [ "-I" ++ autogenModulesDir lbi, + "-include", autogenModulesDir lbi cppHeaderName ] ] + ++ [ "--lflag=" ++ opt + | pkg <- pkgs + , opt <- [ "-L" ++ opt | opt <- Installed.libraryDirs pkg ] + ++ [ "-Wl,-R," ++ opt | isELF + , opt <- Installed.libraryDirs pkg ] + ++ [ "-l" ++ opt | opt <- Installed.extraLibraries pkg ] + ++ [ opt | opt <- Installed.ldOptions pkg ] ] + ++ ["-o", outFile, inFile] + } + where + pkgs = PackageIndex.topologicalOrder (packageHacks (installedPkgs lbi)) + isOSX = case buildOS of OSX -> True; _ -> False + isELF = case buildOS of OSX -> False; Windows -> False; _ -> True; + packageHacks = case compilerFlavor (compiler lbi) of + GHC -> hackRtsPackage + _ -> id + -- We don't link in the actual Haskell libraries of our dependencies, so + -- the -u flags in the ldOptions of the rts package mean linking fails on + -- OS X (it's ld is a tad stricter than gnu ld). Thus we remove the + -- ldOptions for GHC's rts package: + hackRtsPackage index = + case PackageIndex.lookupPackageName index (PackageName "rts") of + [(_, [rts])] + -> PackageIndex.insert rts { Installed.ldOptions = [] } index + _ -> error "No (or multiple) ghc rts package is registered!!" + + +ppC2hs :: BuildInfo -> LocalBuildInfo -> PreProcessor +ppC2hs bi lbi = + PreProcessor { + platformIndependent = False, + runPreProcessor = \(inBaseDir, inRelativeFile) + (outBaseDir, outRelativeFile) verbosity -> do + (c2hsProg, _, _) <- requireProgramVersion verbosity + c2hsProgram (orLaterVersion (Version [0,15] [])) + (withPrograms lbi) + (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi) + rawSystemProgram verbosity c2hsProg $ + + -- Options from the current package: + [ "--cpp=" ++ programPath gccProg, "--cppopts=-E" ] + ++ [ "--cppopts=" ++ opt | opt <- getCppOptions bi lbi ] + ++ [ "--include=" ++ outBaseDir ] + + -- Options from dependent packages + ++ [ "--cppopts=" ++ opt + | pkg <- pkgs + , opt <- [ "-I" ++ opt | opt <- Installed.includeDirs pkg ] + ++ [ opt | opt@('-':c:_) <- Installed.ccOptions pkg + , c `elem` "DIU" ] ] + --TODO: install .chi files for packages, so we can --include + -- those dirs here, for the dependencies + + -- input and output files + ++ [ "--output-dir=" ++ outBaseDir + , "--output=" ++ outRelativeFile + , inBaseDir inRelativeFile ] + } + where + pkgs = PackageIndex.topologicalOrder (installedPkgs lbi) + +--TODO: perhaps use this with hsc2hs too +--TODO: remove cc-options from cpphs for cabal-version: >= 1.10 +getCppOptions :: BuildInfo -> LocalBuildInfo -> [String] +getCppOptions bi lbi + = hcDefines (compiler lbi) + ++ sysDefines + ++ cppOptions bi + ++ ["-I" ++ dir | dir <- PD.includeDirs bi] + ++ [opt | opt@('-':c:_) <- PD.ccOptions bi, c `elem` "DIU"] + +sysDefines :: [String] +sysDefines = ["-D" ++ os ++ "_" ++ loc ++ "_OS" | loc <- locations] + ++ ["-D" ++ arch ++ "_" ++ loc ++ "_ARCH" | loc <- locations] + where + locations = ["BUILD", "HOST"] + +hcDefines :: Compiler -> [String] +hcDefines comp = + case compilerFlavor comp of + GHC -> ["-D__GLASGOW_HASKELL__=" ++ versionInt version] + JHC -> ["-D__JHC__=" ++ versionInt version] + NHC -> ["-D__NHC__=" ++ versionInt version] + Hugs -> ["-D__HUGS__"] + _ -> [] + where version = compilerVersion comp + +-- TODO: move this into the compiler abstraction +-- FIXME: this forces GHC's crazy 4.8.2 -> 408 convention on all the other +-- compilers. Check if that's really what they want. +versionInt :: Version -> String +versionInt (Version { versionBranch = [] }) = "1" +versionInt (Version { versionBranch = [n] }) = show n +versionInt (Version { versionBranch = n1:n2:_ }) + = -- 6.8.x -> 608 + -- 6.10.x -> 610 + let s1 = show n1 + s2 = show n2 + middle = case s2 of + _ : _ : _ -> "" + _ -> "0" + in s1 ++ middle ++ s2 + +ppHappy :: BuildInfo -> LocalBuildInfo -> PreProcessor +ppHappy _ lbi = pp { platformIndependent = True } + where pp = standardPP lbi happyProgram (hcFlags hc) + hc = compilerFlavor (compiler lbi) + hcFlags GHC = ["-agc"] + hcFlags _ = [] + +ppAlex :: BuildInfo -> LocalBuildInfo -> PreProcessor +ppAlex _ lbi = pp { platformIndependent = True } + where pp = standardPP lbi alexProgram (hcFlags hc) + hc = compilerFlavor (compiler lbi) + hcFlags GHC = ["-g"] + hcFlags _ = [] + +standardPP :: LocalBuildInfo -> Program -> [String] -> PreProcessor +standardPP lbi prog args = + PreProcessor { + platformIndependent = False, + runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> + rawSystemProgramConf verbosity prog (withPrograms lbi) + (args ++ ["-o", outFile, inFile]) + } + +-- |Convenience function; get the suffixes of these preprocessors. +ppSuffixes :: [ PPSuffixHandler ] -> [String] +ppSuffixes = map fst + +-- |Standard preprocessors: GreenCard, c2hs, hsc2hs, happy, alex and cpphs. +knownSuffixHandlers :: [ PPSuffixHandler ] +knownSuffixHandlers = + [ ("gc", ppGreenCard) + , ("chs", ppC2hs) + , ("hsc", ppHsc2hs) + , ("x", ppAlex) + , ("y", ppHappy) + , ("ly", ppHappy) + , ("cpphs", ppCpp) + ] diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/Program/Ar.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/Program/Ar.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/Program/Ar.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/Program/Ar.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,70 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Program.Ar +-- Copyright : Duncan Coutts 2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module provides an library interface to the @ar@ program. + +module Distribution.Simple.Program.Ar ( + createArLibArchive, + multiStageProgramInvocation, + ) where + +import Distribution.Simple.Program.Types + ( ConfiguredProgram(..) ) +import Distribution.Simple.Program.Run + ( programInvocation, multiStageProgramInvocation + , runProgramInvocation ) +import Distribution.System + ( OS(..), buildOS ) +import Distribution.Verbosity + ( Verbosity, deafening, verbose ) + +-- | Call @ar@ to create a library archive from a bunch of object files. +-- +createArLibArchive :: Verbosity -> ConfiguredProgram + -> FilePath -> [FilePath] -> IO () +createArLibArchive verbosity ar target files = + + -- The args to use with "ar" are actually rather subtle and system-dependent. + -- In particular we have the following issues: + -- + -- -- On OS X, "ar q" does not make an archive index. Archives with no + -- index cannot be used. + -- + -- -- GNU "ar r" will not let us add duplicate objects, only "ar q" lets us + -- do that. We have duplicates because of modules like "A.M" and "B.M" + -- both make an object file "M.o" and ar does not consider the directory. + -- + -- Our solution is to use "ar r" in the simple case when one call is enough. + -- When we need to call ar multiple times we use "ar q" and for the last + -- call on OSX we use "ar qs" so that it'll make the index. + + let simpleArgs = case buildOS of + OSX -> ["-r", "-s"] + _ -> ["-r"] + + initialArgs = ["-q"] + finalArgs = case buildOS of + OSX -> ["-q", "-s"] + _ -> ["-q"] + + extraArgs = verbosityOpts verbosity ++ [target] + + simple = programInvocation ar (simpleArgs ++ extraArgs) + initial = programInvocation ar (initialArgs ++ extraArgs) + middle = initial + final = programInvocation ar (finalArgs ++ extraArgs) + + in sequence_ + [ runProgramInvocation verbosity inv + | inv <- multiStageProgramInvocation + simple (initial, middle, final) files ] + + where + verbosityOpts v | v >= deafening = ["-v"] + | v >= verbose = [] + | otherwise = ["-c"] diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/Program/Builtin.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/Program/Builtin.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/Program/Builtin.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/Program/Builtin.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,259 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Program.Builtin +-- Copyright : Isaac Jones 2006, Duncan Coutts 2007-2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- The module defines all the known built-in 'Program's. +-- +-- Where possible we try to find their version numbers. +-- +module Distribution.Simple.Program.Builtin ( + + -- * The collection of unconfigured and configured progams + builtinPrograms, + + -- * Programs that Cabal knows about + ghcProgram, + ghcPkgProgram, + lhcProgram, + lhcPkgProgram, + nhcProgram, + hmakeProgram, + jhcProgram, + hugsProgram, + ffihugsProgram, + uhcProgram, + gccProgram, + ranlibProgram, + arProgram, + stripProgram, + happyProgram, + alexProgram, + hsc2hsProgram, + c2hsProgram, + cpphsProgram, + hscolourProgram, + haddockProgram, + greencardProgram, + ldProgram, + tarProgram, + cppProgram, + pkgConfigProgram, + ) where + +import Distribution.Simple.Program.Types + ( Program(..), simpleProgram ) +import Distribution.Simple.Utils + ( findProgramLocation, findProgramVersion ) + +-- ------------------------------------------------------------ +-- * Known programs +-- ------------------------------------------------------------ + +-- | The default list of programs. +-- These programs are typically used internally to Cabal. +builtinPrograms :: [Program] +builtinPrograms = + [ + -- compilers and related progs + ghcProgram + , ghcPkgProgram + , hugsProgram + , ffihugsProgram + , nhcProgram + , hmakeProgram + , jhcProgram + , lhcProgram + , lhcPkgProgram + , uhcProgram + -- preprocessors + , hscolourProgram + , haddockProgram + , happyProgram + , alexProgram + , hsc2hsProgram + , c2hsProgram + , cpphsProgram + , greencardProgram + -- platform toolchain + , gccProgram + , ranlibProgram + , arProgram + , stripProgram + , ldProgram + , tarProgram + -- configuration tools + , pkgConfigProgram + ] + +ghcProgram :: Program +ghcProgram = (simpleProgram "ghc") { + programFindVersion = findProgramVersion "--numeric-version" id + } + +ghcPkgProgram :: Program +ghcPkgProgram = (simpleProgram "ghc-pkg") { + programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "ghc-pkg --version" gives a string like + -- "GHC package manager version 6.4.1" + case words str of + (_:_:_:_:ver:_) -> ver + _ -> "" + } + +lhcProgram :: Program +lhcProgram = (simpleProgram "lhc") { + programFindVersion = findProgramVersion "--numeric-version" id + } + +lhcPkgProgram :: Program +lhcPkgProgram = (simpleProgram "lhc-pkg") { + programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "lhc-pkg --version" gives a string like + -- "LHC package manager version 0.7" + case words str of + (_:_:_:_:ver:_) -> ver + _ -> "" + } + +nhcProgram :: Program +nhcProgram = (simpleProgram "nhc98") { + programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "nhc98 --version" gives a string like + -- "/usr/local/bin/nhc98: v1.20 (2007-11-22)" + case words str of + (_:('v':ver):_) -> ver + _ -> "" + } + +hmakeProgram :: Program +hmakeProgram = (simpleProgram "hmake") { + programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "hmake --version" gives a string line + -- "/usr/local/bin/hmake: 3.13 (2006-11-01)" + case words str of + (_:ver:_) -> ver + _ -> "" + } + +jhcProgram :: Program +jhcProgram = (simpleProgram "jhc") { + programFindVersion = findProgramVersion "--version" $ \str -> + -- invoking "jhc --version" gives a string like + -- "jhc 0.3.20080208 (wubgipkamcep-2) + -- compiled by ghc-6.8 on a x86_64 running linux" + case words str of + (_:ver:_) -> ver + _ -> "" + } + +uhcProgram :: Program +uhcProgram = (simpleProgram "uhc") { + programFindVersion = findProgramVersion "--version-dotted" id + } + + +-- AArgh! Finding the version of hugs or ffihugs is almost impossible. +hugsProgram :: Program +hugsProgram = simpleProgram "hugs" + +ffihugsProgram :: Program +ffihugsProgram = simpleProgram "ffihugs" + +happyProgram :: Program +happyProgram = (simpleProgram "happy") { + programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "happy --version" gives a string like + -- "Happy Version 1.16 Copyright (c) ...." + case words str of + (_:_:ver:_) -> ver + _ -> "" + } + +alexProgram :: Program +alexProgram = (simpleProgram "alex") { + programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "alex --version" gives a string like + -- "Alex version 2.1.0, (c) 2003 Chris Dornan and Simon Marlow" + case words str of + (_:_:ver:_) -> takeWhile (`elem` ('.':['0'..'9'])) ver + _ -> "" + } + +gccProgram :: Program +gccProgram = (simpleProgram "gcc") { + programFindVersion = findProgramVersion "-dumpversion" id + } + +ranlibProgram :: Program +ranlibProgram = simpleProgram "ranlib" + +arProgram :: Program +arProgram = simpleProgram "ar" + +stripProgram :: Program +stripProgram = simpleProgram "strip" + +hsc2hsProgram :: Program +hsc2hsProgram = (simpleProgram "hsc2hs") { + programFindVersion = + findProgramVersion "--version" $ \str -> + -- Invoking "hsc2hs --version" gives a string like "hsc2hs version 0.66" + case words str of + (_:_:ver:_) -> ver + _ -> "" + } + +c2hsProgram :: Program +c2hsProgram = (simpleProgram "c2hs") { + programFindVersion = findProgramVersion "--numeric-version" id + } + +cpphsProgram :: Program +cpphsProgram = (simpleProgram "cpphs") { + programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "cpphs --version" gives a string like "cpphs 1.3" + case words str of + (_:ver:_) -> ver + _ -> "" + } + +hscolourProgram :: Program +hscolourProgram = (simpleProgram "hscolour") { + programFindLocation = \v -> findProgramLocation v "HsColour", + programFindVersion = findProgramVersion "-version" $ \str -> + -- Invoking "HsColour -version" gives a string like "HsColour 1.7" + case words str of + (_:ver:_) -> ver + _ -> "" + } + +haddockProgram :: Program +haddockProgram = (simpleProgram "haddock") { + programFindVersion = findProgramVersion "--version" $ \str -> + -- Invoking "haddock --version" gives a string like + -- "Haddock version 0.8, (c) Simon Marlow 2006" + case words str of + (_:_:ver:_) -> takeWhile (`elem` ('.':['0'..'9'])) ver + _ -> "" + } + +greencardProgram :: Program +greencardProgram = simpleProgram "greencard" + +ldProgram :: Program +ldProgram = simpleProgram "ld" + +tarProgram :: Program +tarProgram = simpleProgram "tar" + +cppProgram :: Program +cppProgram = simpleProgram "cpp" + +pkgConfigProgram :: Program +pkgConfigProgram = (simpleProgram "pkg-config") { + programFindVersion = findProgramVersion "--version" id + } diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/Program/Db.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/Program/Db.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/Program/Db.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/Program/Db.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,409 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Program.Db +-- Copyright : Isaac Jones 2006, Duncan Coutts 2007-2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This provides a 'ProgramDb' type which holds configured and not-yet +-- configured programs. It is the parameter to lots of actions elsewhere in +-- Cabal that need to look up and run programs. If we had a Cabal monad, +-- the 'ProgramDb' would probably be a reader or state component of it. +-- +-- One nice thing about using it is that any program that is +-- registered with Cabal will get some \"configure\" and \".cabal\" +-- helpers like --with-foo-args --foo-path= and extra-foo-args. +-- +-- There's also a hook for adding programs in a Setup.lhs script. See +-- hookedPrograms in 'Distribution.Simple.UserHooks'. This gives a +-- hook user the ability to get the above flags and such so that they +-- don't have to write all the PATH logic inside Setup.lhs. + +module Distribution.Simple.Program.Db ( + -- * The collection of configured programs we can run + ProgramDb, + emptyProgramDb, + defaultProgramDb, + restoreProgramDb, + + -- ** Query and manipulate the program db + addKnownProgram, + addKnownPrograms, + lookupKnownProgram, + knownPrograms, + userSpecifyPath, + userSpecifyPaths, + userMaybeSpecifyPath, + userSpecifyArgs, + userSpecifyArgss, + userSpecifiedArgs, + lookupProgram, + updateProgram, + + -- ** Query and manipulate the program db + configureProgram, + configureAllKnownPrograms, + reconfigurePrograms, + requireProgram, + requireProgramVersion, + + ) where + +import Distribution.Simple.Program.Types + ( Program(..), ProgArg, ConfiguredProgram(..), ProgramLocation(..) ) +import Distribution.Simple.Program.Builtin + ( builtinPrograms ) +import Distribution.Simple.Utils + ( die, findProgramLocation ) +import Distribution.Version + ( Version, VersionRange, isAnyVersion, withinRange ) +import Distribution.Text + ( display ) +import Distribution.Verbosity + ( Verbosity ) + +import Data.List + ( foldl' ) +import Data.Maybe + ( catMaybes ) +import qualified Data.Map as Map +import Control.Monad + ( join, foldM ) +import System.Directory + ( doesFileExist ) + + +-- ------------------------------------------------------------ +-- * Programs database +-- ------------------------------------------------------------ + +-- | The configuration is a collection of information about programs. It +-- contains information both about configured programs and also about programs +-- that we are yet to configure. +-- +-- The idea is that we start from a collection of unconfigured programs and one +-- by one we try to configure them at which point we move them into the +-- configured collection. For unconfigured programs we record not just the +-- 'Program' but also any user-provided arguments and location for the program. +data ProgramDb = ProgramDb { + unconfiguredProgs :: UnconfiguredProgs, + configuredProgs :: ConfiguredProgs + } + +type UnconfiguredProgram = (Program, Maybe FilePath, [ProgArg]) +type UnconfiguredProgs = Map.Map String UnconfiguredProgram +type ConfiguredProgs = Map.Map String ConfiguredProgram + + +emptyProgramDb :: ProgramDb +emptyProgramDb = ProgramDb Map.empty Map.empty + + +defaultProgramDb :: ProgramDb +defaultProgramDb = restoreProgramDb builtinPrograms emptyProgramDb + + +-- internal helpers: +updateUnconfiguredProgs :: (UnconfiguredProgs -> UnconfiguredProgs) + -> ProgramDb -> ProgramDb +updateUnconfiguredProgs update conf = + conf { unconfiguredProgs = update (unconfiguredProgs conf) } + +updateConfiguredProgs :: (ConfiguredProgs -> ConfiguredProgs) + -> ProgramDb -> ProgramDb +updateConfiguredProgs update conf = + conf { configuredProgs = update (configuredProgs conf) } + + +-- Read & Show instances are based on listToFM +-- Note that we only serialise the configured part of the database, this is +-- because we don't need the unconfigured part after the configure stage, and +-- additionally because we cannot read/show 'Program' as it contains functions. +instance Show ProgramDb where + show = show . Map.toAscList . configuredProgs + +instance Read ProgramDb where + readsPrec p s = + [ (emptyProgramDb { configuredProgs = Map.fromList s' }, r) + | (s', r) <- readsPrec p s ] + + +-- | The Read\/Show instance does not preserve all the unconfigured 'Programs' +-- because 'Program' is not in Read\/Show because it contains functions. So to +-- fully restore a deserialised 'ProgramDb' use this function to add +-- back all the known 'Program's. +-- +-- * It does not add the default programs, but you probably want them, use +-- 'builtinPrograms' in addition to any extra you might need. +-- +restoreProgramDb :: [Program] -> ProgramDb -> ProgramDb +restoreProgramDb = addKnownPrograms + + +-- ------------------------------- +-- Managing unconfigured programs + +-- | Add a known program that we may configure later +-- +addKnownProgram :: Program -> ProgramDb -> ProgramDb +addKnownProgram prog = updateUnconfiguredProgs $ + Map.insertWith combine (programName prog) (prog, Nothing, []) + where combine _ (_, path, args) = (prog, path, args) + + +addKnownPrograms :: [Program] -> ProgramDb -> ProgramDb +addKnownPrograms progs conf = foldl' (flip addKnownProgram) conf progs + + +lookupKnownProgram :: String -> ProgramDb -> Maybe Program +lookupKnownProgram name = + fmap (\(p,_,_)->p) . Map.lookup name . unconfiguredProgs + + +knownPrograms :: ProgramDb -> [(Program, Maybe ConfiguredProgram)] +knownPrograms conf = + [ (p,p') | (p,_,_) <- Map.elems (unconfiguredProgs conf) + , let p' = Map.lookup (programName p) (configuredProgs conf) ] + + +-- |User-specify this path. Basically override any path information +-- for this program in the configuration. If it's not a known +-- program ignore it. +-- +userSpecifyPath :: String -- ^Program name + -> FilePath -- ^user-specified path to the program + -> ProgramDb -> ProgramDb +userSpecifyPath name path = updateUnconfiguredProgs $ + flip Map.update name $ \(prog, _, args) -> Just (prog, Just path, args) + + +userMaybeSpecifyPath :: String -> Maybe FilePath + -> ProgramDb -> ProgramDb +userMaybeSpecifyPath _ Nothing conf = conf +userMaybeSpecifyPath name (Just path) conf = userSpecifyPath name path conf + + +-- |User-specify the arguments for this program. Basically override +-- any args information for this program in the configuration. If it's +-- not a known program, ignore it.. +userSpecifyArgs :: String -- ^Program name + -> [ProgArg] -- ^user-specified args + -> ProgramDb + -> ProgramDb +userSpecifyArgs name args' = + updateUnconfiguredProgs + (flip Map.update name $ + \(prog, path, args) -> Just (prog, path, args ++ args')) + . updateConfiguredProgs + (flip Map.update name $ + \prog -> Just prog { programOverrideArgs = programOverrideArgs prog + ++ args' }) + + +-- | Like 'userSpecifyPath' but for a list of progs and their paths. +-- +userSpecifyPaths :: [(String, FilePath)] + -> ProgramDb + -> ProgramDb +userSpecifyPaths paths conf = + foldl' (\conf' (prog, path) -> userSpecifyPath prog path conf') conf paths + + +-- | Like 'userSpecifyPath' but for a list of progs and their args. +-- +userSpecifyArgss :: [(String, [ProgArg])] + -> ProgramDb + -> ProgramDb +userSpecifyArgss argss conf = + foldl' (\conf' (prog, args) -> userSpecifyArgs prog args conf') conf argss + + +-- | Get the path that has been previously specified for a program, if any. +-- +userSpecifiedPath :: Program -> ProgramDb -> Maybe FilePath +userSpecifiedPath prog = + join . fmap (\(_,p,_)->p) . Map.lookup (programName prog) . unconfiguredProgs + + +-- | Get any extra args that have been previously specified for a program. +-- +userSpecifiedArgs :: Program -> ProgramDb -> [ProgArg] +userSpecifiedArgs prog = + maybe [] (\(_,_,as)->as) . Map.lookup (programName prog) . unconfiguredProgs + + +-- ----------------------------- +-- Managing configured programs + +-- | Try to find a configured program +lookupProgram :: Program -> ProgramDb -> Maybe ConfiguredProgram +lookupProgram prog = Map.lookup (programName prog) . configuredProgs + + +-- | Update a configured program in the database. +updateProgram :: ConfiguredProgram -> ProgramDb + -> ProgramDb +updateProgram prog = updateConfiguredProgs $ + Map.insert (programId prog) prog + + +-- --------------------------- +-- Configuring known programs + +-- | Try to configure a specific program. If the program is already included in +-- the colleciton of unconfigured programs then we use any user-supplied +-- location and arguments. If the program gets configured sucessfully it gets +-- added to the configured collection. +-- +-- Note that it is not a failure if the program cannot be configured. It's only +-- a failure if the user supplied a location and the program could not be found +-- at that location. +-- +-- The reason for it not being a failure at this stage is that we don't know up +-- front all the programs we will need, so we try to configure them all. +-- To verify that a program was actually sucessfully configured use +-- 'requireProgram'. +-- +configureProgram :: Verbosity + -> Program + -> ProgramDb + -> IO ProgramDb +configureProgram verbosity prog conf = do + let name = programName prog + maybeLocation <- case userSpecifiedPath prog conf of + Nothing -> programFindLocation prog verbosity + >>= return . fmap FoundOnSystem + Just path -> do + absolute <- doesFileExist path + if absolute + then return (Just (UserSpecified path)) + else findProgramLocation verbosity path + >>= maybe (die notFound) (return . Just . UserSpecified) + where notFound = "Cannot find the program '" ++ name ++ "' at '" + ++ path ++ "' or on the path" + case maybeLocation of + Nothing -> return conf + Just location -> do + version <- programFindVersion prog verbosity (locationPath location) + let configuredProg = ConfiguredProgram { + programId = name, + programVersion = version, + programDefaultArgs = [], + programOverrideArgs = userSpecifiedArgs prog conf, + programLocation = location + } + extraArgs <- programPostConf prog verbosity configuredProg + let configuredProg' = configuredProg { + programDefaultArgs = extraArgs + } + return (updateConfiguredProgs (Map.insert name configuredProg') conf) + + +-- | Configure a bunch of programs using 'configureProgram'. Just a 'foldM'. +-- +configurePrograms :: Verbosity + -> [Program] + -> ProgramDb + -> IO ProgramDb +configurePrograms verbosity progs conf = + foldM (flip (configureProgram verbosity)) conf progs + + +-- | Try to configure all the known programs that have not yet been configured. +-- +configureAllKnownPrograms :: Verbosity + -> ProgramDb + -> IO ProgramDb +configureAllKnownPrograms verbosity conf = + configurePrograms verbosity + [ prog | (prog,_,_) <- Map.elems notYetConfigured ] conf + where + notYetConfigured = unconfiguredProgs conf + `Map.difference` configuredProgs conf + + +-- | reconfigure a bunch of programs given new user-specified args. It takes +-- the same inputs as 'userSpecifyPath' and 'userSpecifyArgs' and for all progs +-- with a new path it calls 'configureProgram'. +-- +reconfigurePrograms :: Verbosity + -> [(String, FilePath)] + -> [(String, [ProgArg])] + -> ProgramDb + -> IO ProgramDb +reconfigurePrograms verbosity paths argss conf = do + configurePrograms verbosity progs + . userSpecifyPaths paths + . userSpecifyArgss argss + $ conf + + where + progs = catMaybes [ lookupKnownProgram name conf | (name,_) <- paths ] + + +-- | Check that a program is configured and available to be run. +-- +-- It raises an exception if the program could not be configured, otherwise +-- it returns the configured program. +-- +requireProgram :: Verbosity -> Program -> ProgramDb + -> IO (ConfiguredProgram, ProgramDb) +requireProgram verbosity prog conf = do + + -- If it's not already been configured, try to configure it now + conf' <- case lookupProgram prog conf of + Nothing -> configureProgram verbosity prog conf + Just _ -> return conf + + case lookupProgram prog conf' of + Nothing -> die notFound + Just configuredProg -> return (configuredProg, conf') + + where notFound = "The program " ++ programName prog + ++ " is required but it could not be found." + + +-- | Check that a program is configured and available to be run. +-- +-- Additionally check that the version of the program number is suitable and +-- return it. For example you could require 'AnyVersion' or +-- @'orLaterVersion' ('Version' [1,0] [])@ +-- +-- It raises an exception if the program could not be configured or the version +-- is unsuitable, otherwise it returns the configured program and its version +-- number. +-- +requireProgramVersion :: Verbosity -> Program -> VersionRange + -> ProgramDb + -> IO (ConfiguredProgram, Version, ProgramDb) +requireProgramVersion verbosity prog range conf = do + + -- If it's not already been configured, try to configure it now + conf' <- case lookupProgram prog conf of + Nothing -> configureProgram verbosity prog conf + Just _ -> return conf + + case lookupProgram prog conf' of + Nothing -> die notFound + Just configuredProg@ConfiguredProgram { programLocation = location } -> + case programVersion configuredProg of + Just version + | withinRange version range -> return (configuredProg, version, conf') + | otherwise -> die (badVersion version location) + Nothing -> die (noVersion location) + + where notFound = "The program " + ++ programName prog ++ versionRequirement + ++ " is required but it could not be found." + badVersion v l = "The program " + ++ programName prog ++ versionRequirement + ++ " is required but the version found at " + ++ locationPath l ++ " is version " ++ display v + noVersion l = "The program " + ++ programName prog ++ versionRequirement + ++ " is required but the version of " + ++ locationPath l ++ " could not be determined." + versionRequirement + | isAnyVersion range = "" + | otherwise = " version " ++ display range diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/Program/HcPkg.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/Program/HcPkg.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/Program/HcPkg.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/Program/HcPkg.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,338 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Program.HcPkg +-- Copyright : Duncan Coutts 2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module provides an library interface to the @hc-pkg@ program. +-- Currently only GHC and LHC have hc-pkg programs. + +module Distribution.Simple.Program.HcPkg ( + register, + reregister, + unregister, + expose, + hide, + dump, + + -- * Program invocations + registerInvocation, + reregisterInvocation, + unregisterInvocation, + exposeInvocation, + hideInvocation, + dumpInvocation, + ) where + +import Distribution.Package + ( PackageId, InstalledPackageId(..) ) +import Distribution.InstalledPackageInfo + ( InstalledPackageInfo, InstalledPackageInfo_(..) + , showInstalledPackageInfo + , emptyInstalledPackageInfo, fieldsInstalledPackageInfo ) +import Distribution.ParseUtils +import Distribution.Simple.Compiler + ( PackageDB(..), PackageDBStack ) +import Distribution.Simple.Program.Types + ( ConfiguredProgram(programId, programVersion) ) +import Distribution.Simple.Program.Run + ( ProgramInvocation(..), IOEncoding(..), programInvocation + , runProgramInvocation, getProgramInvocationOutput ) +import Distribution.Version + ( Version(..) ) +import Distribution.Text + ( display ) +import Distribution.Simple.Utils + ( die ) +import Distribution.Verbosity + ( Verbosity, deafening, silent ) +import Distribution.Compat.Exception + ( catchExit ) + +import Data.Char + ( isSpace ) +import Data.Maybe + ( fromMaybe ) +import Data.List + ( stripPrefix ) +import System.FilePath as FilePath + ( (), splitPath, splitDirectories, joinPath, isPathSeparator ) +import qualified System.FilePath.Posix as FilePath.Posix + + +-- | Call @hc-pkg@ to register a package. +-- +-- > hc-pkg register {filename | -} [--user | --global | --package-conf] +-- +register :: Verbosity -> ConfiguredProgram -> PackageDBStack + -> Either FilePath + InstalledPackageInfo + -> IO () +register verbosity hcPkg packagedb pkgFile = + runProgramInvocation verbosity + (registerInvocation hcPkg verbosity packagedb pkgFile) + + +-- | Call @hc-pkg@ to re-register a package. +-- +-- > hc-pkg register {filename | -} [--user | --global | --package-conf] +-- +reregister :: Verbosity -> ConfiguredProgram -> PackageDBStack + -> Either FilePath + InstalledPackageInfo + -> IO () +reregister verbosity hcPkg packagedb pkgFile = + runProgramInvocation verbosity + (reregisterInvocation hcPkg verbosity packagedb pkgFile) + + +-- | Call @hc-pkg@ to unregister a package +-- +-- > hc-pkg unregister [pkgid] [--user | --global | --package-conf] +-- +unregister :: Verbosity -> ConfiguredProgram -> PackageDB -> PackageId -> IO () +unregister verbosity hcPkg packagedb pkgid = + runProgramInvocation verbosity + (unregisterInvocation hcPkg verbosity packagedb pkgid) + + +-- | Call @hc-pkg@ to expose a package. +-- +-- > hc-pkg expose [pkgid] [--user | --global | --package-conf] +-- +expose :: Verbosity -> ConfiguredProgram -> PackageDB -> PackageId -> IO () +expose verbosity hcPkg packagedb pkgid = + runProgramInvocation verbosity + (exposeInvocation hcPkg verbosity packagedb pkgid) + + +-- | Call @hc-pkg@ to expose a package. +-- +-- > hc-pkg expose [pkgid] [--user | --global | --package-conf] +-- +hide :: Verbosity -> ConfiguredProgram -> PackageDB -> PackageId -> IO () +hide verbosity hcPkg packagedb pkgid = + runProgramInvocation verbosity + (hideInvocation hcPkg verbosity packagedb pkgid) + + +-- | Call @hc-pkg@ to get all the installed packages. +-- +dump :: Verbosity -> ConfiguredProgram -> PackageDB -> IO [InstalledPackageInfo] +dump verbosity hcPkg packagedb = do + + output <- getProgramInvocationOutput verbosity + (dumpInvocation hcPkg verbosity packagedb) + `catchExit` \_ -> die $ programId hcPkg ++ " dump failed" + + case parsePackages output of + Left ok -> return ok + _ -> die $ "failed to parse output of '" + ++ programId hcPkg ++ " dump'" + + where + parsePackages str = + let parsed = map parseInstalledPackageInfo' (splitPkgs str) + in case [ msg | ParseFailed msg <- parsed ] of + [] -> Left [ setInstalledPackageId + . maybe id mungePackagePaths pkgroot + $ pkg + | ParseOk _ (pkgroot, pkg) <- parsed ] + msgs -> Right msgs + + parseInstalledPackageInfo' = + parseFieldsFlat fields (Nothing, emptyInstalledPackageInfo) + where + fields = liftFieldFst pkgrootField + : map liftFieldSnd fieldsInstalledPackageInfo + + pkgrootField = + simpleField "pkgroot" + showFilePath parseFilePathQ + (fromMaybe "") (\x _ -> Just x) + + liftFieldFst = liftField fst (\x (_x,y) -> (x,y)) + liftFieldSnd = liftField snd (\y (x,_y) -> (x,y)) + + --TODO: this could be a lot faster. We're doing normaliseLineEndings twice + -- and converting back and forth with lines/unlines. + splitPkgs :: String -> [String] + splitPkgs = checkEmpty . map unlines . splitWith ("---" ==) . lines + where + -- Handle the case of there being no packages at all. + checkEmpty [s] | all isSpace s = [] + checkEmpty ss = ss + + splitWith :: (a -> Bool) -> [a] -> [[a]] + splitWith p xs = ys : case zs of + [] -> [] + _:ws -> splitWith p ws + where (ys,zs) = break p xs + +mungePackagePaths :: FilePath -> InstalledPackageInfo -> InstalledPackageInfo +-- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec +-- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html) +-- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}. +-- The "pkgroot" is the directory containing the package database. +mungePackagePaths pkgroot pkginfo = + pkginfo { + importDirs = mungePaths (importDirs pkginfo), + includeDirs = mungePaths (includeDirs pkginfo), + libraryDirs = mungePaths (libraryDirs pkginfo), + frameworkDirs = mungePaths (frameworkDirs pkginfo), + haddockInterfaces = mungePaths (haddockInterfaces pkginfo), + haddockHTMLs = mungeUrls (haddockHTMLs pkginfo) + } + where + mungePaths = map mungePath + mungeUrls = map mungeUrl + + mungePath p = case stripVarPrefix "${pkgroot}" p of + Just p' -> pkgroot p' + Nothing -> p + + mungeUrl p = case stripVarPrefix "${pkgrooturl}" p of + Just p' -> toUrlPath pkgroot p' + Nothing -> p + + toUrlPath r p = "file:///" + -- URLs always use posix style '/' separators: + ++ FilePath.Posix.joinPath (r : FilePath.splitDirectories p) + + stripVarPrefix var p = + case splitPath p of + (root:path') -> case stripPrefix var root of + Just [sep] | isPathSeparator sep -> Just (joinPath path') + _ -> Nothing + _ -> Nothing + + +-- Older installed package info files did not have the installedPackageId +-- field, so if it is missing then we fill it as the source package ID. +setInstalledPackageId :: InstalledPackageInfo -> InstalledPackageInfo +setInstalledPackageId pkginfo@InstalledPackageInfo { + installedPackageId = InstalledPackageId "", + sourcePackageId = pkgid + } + = pkginfo { + --TODO use a proper named function for the conversion + -- from source package id to installed package id + installedPackageId = InstalledPackageId (display pkgid) + } +setInstalledPackageId pkginfo = pkginfo + + +-------------------------- +-- The program invocations +-- + +registerInvocation, reregisterInvocation + :: ConfiguredProgram -> Verbosity -> PackageDBStack + -> Either FilePath InstalledPackageInfo + -> ProgramInvocation +registerInvocation = registerInvocation' "register" +reregisterInvocation = registerInvocation' "update" + + +registerInvocation' :: String + -> ConfiguredProgram -> Verbosity -> PackageDBStack + -> Either FilePath InstalledPackageInfo + -> ProgramInvocation +registerInvocation' cmdname hcPkg verbosity packagedbs (Left pkgFile) = + programInvocation hcPkg args + where + args = [cmdname, pkgFile] + ++ (if legacyVersion hcPkg + then [packageDbOpts (last packagedbs)] + else packageDbStackOpts packagedbs) + ++ verbosityOpts hcPkg verbosity + +registerInvocation' cmdname hcPkg verbosity packagedbs (Right pkgInfo) = + (programInvocation hcPkg args) { + progInvokeInput = Just (showInstalledPackageInfo pkgInfo), + progInvokeInputEncoding = IOEncodingUTF8 + } + where + args = [cmdname, "-"] + ++ (if legacyVersion hcPkg + then [packageDbOpts (last packagedbs)] + else packageDbStackOpts packagedbs) + ++ verbosityOpts hcPkg verbosity + + +unregisterInvocation :: ConfiguredProgram + -> Verbosity -> PackageDB -> PackageId + -> ProgramInvocation +unregisterInvocation hcPkg verbosity packagedb pkgid = + programInvocation hcPkg $ + ["unregister", packageDbOpts packagedb, display pkgid] + ++ verbosityOpts hcPkg verbosity + + +exposeInvocation :: ConfiguredProgram + -> Verbosity -> PackageDB -> PackageId -> ProgramInvocation +exposeInvocation hcPkg verbosity packagedb pkgid = + programInvocation hcPkg $ + ["expose", packageDbOpts packagedb, display pkgid] + ++ verbosityOpts hcPkg verbosity + + +hideInvocation :: ConfiguredProgram + -> Verbosity -> PackageDB -> PackageId -> ProgramInvocation +hideInvocation hcPkg verbosity packagedb pkgid = + programInvocation hcPkg $ + ["hide", packageDbOpts packagedb, display pkgid] + ++ verbosityOpts hcPkg verbosity + + +dumpInvocation :: ConfiguredProgram + -> Verbosity -> PackageDB -> ProgramInvocation +dumpInvocation hcPkg _verbosity packagedb = + (programInvocation hcPkg args) { + progInvokeOutputEncoding = IOEncodingUTF8 + } + where + args = ["dump", packageDbOpts packagedb] + ++ verbosityOpts hcPkg silent + -- We use verbosity level 'silent' because it is important that we + -- do not contaminate the output with info/debug messages. + + +packageDbStackOpts :: PackageDBStack -> [String] +packageDbStackOpts dbstack = case dbstack of + (GlobalPackageDB:UserPackageDB:dbs) -> "--global" + : "--user" + : map specific dbs + (GlobalPackageDB:dbs) -> "--global" + : "--no-user-package-conf" + : map specific dbs + _ -> ierror + where + specific (SpecificPackageDB db) = "--package-conf=" ++ db + specific _ = ierror + ierror :: a + ierror = error ("internal error: unexpected package db stack: " ++ show dbstack) + +packageDbOpts :: PackageDB -> String +packageDbOpts GlobalPackageDB = "--global" +packageDbOpts UserPackageDB = "--user" +packageDbOpts (SpecificPackageDB db) = "--package-conf=" ++ db + +verbosityOpts :: ConfiguredProgram -> Verbosity -> [String] +verbosityOpts hcPkg v + + -- ghc-pkg < 6.11 does not support -v + | programId hcPkg == "ghc-pkg" + && programVersion hcPkg < Just (Version [6,11] []) + = [] + + | v >= deafening = ["-v2"] + | v == silent = ["-v0"] + | otherwise = [] + +-- Handle quirks in ghc-pkg 6.8 and older +legacyVersion :: ConfiguredProgram -> Bool +legacyVersion hcPkg = programId hcPkg == "ghc-pkg" + && programVersion hcPkg < Just (Version [6,9] []) diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/Program/Ld.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/Program/Ld.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/Program/Ld.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/Program/Ld.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,62 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Program.Ld +-- Copyright : Duncan Coutts 2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module provides an library interface to the @ld@ linker program. + +module Distribution.Simple.Program.Ld ( + combineObjectFiles, + ) where + +import Distribution.Simple.Program.Types + ( ConfiguredProgram(..) ) +import Distribution.Simple.Program.Run + ( programInvocation, multiStageProgramInvocation + , runProgramInvocation ) +import Distribution.Verbosity + ( Verbosity ) + +import System.Directory + ( renameFile ) +import System.FilePath + ( (<.>) ) + +-- | Call @ld -r@ to link a bunch of object files together. +-- +combineObjectFiles :: Verbosity -> ConfiguredProgram + -> FilePath -> [FilePath] -> IO () +combineObjectFiles verbosity ld target files = + + -- Unlike "ar", the "ld" tool is not designed to be used with xargs. That is, + -- if we have more object files than fit on a single command line then we + -- have a slight problem. What we have to do is link files in batches into + -- a temp object file and then include that one in the next batch. + + let simpleArgs = ["-r", "-o", target] + + initialArgs = ["-r", "-o", target] + middleArgs = ["-r", "-o", target, tmpfile] + finalArgs = middleArgs + + simple = programInvocation ld simpleArgs + initial = programInvocation ld initialArgs + middle = programInvocation ld middleArgs + final = programInvocation ld finalArgs + + invocations = multiStageProgramInvocation + simple (initial, middle, final) files + + in run invocations + + where + tmpfile = target <.> "tmp" -- perhaps should use a proper temp file + + run [] = return () + run [inv] = runProgramInvocation verbosity inv + run (inv:invs) = do runProgramInvocation verbosity inv + renameFile target tmpfile + run invs diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/Program/Run.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/Program/Run.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/Program/Run.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/Program/Run.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,218 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Program.Run +-- Copyright : Duncan Coutts 2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module provides a data type for program invocations and functions to +-- run them. + +module Distribution.Simple.Program.Run ( + ProgramInvocation(..), + IOEncoding(..), + emptyProgramInvocation, + simpleProgramInvocation, + programInvocation, + multiStageProgramInvocation, + + runProgramInvocation, + getProgramInvocationOutput, + + ) where + +import Distribution.Simple.Program.Types + ( ConfiguredProgram(..), programPath ) +import Distribution.Simple.Utils + ( die, rawSystemExit, rawSystemStdInOut + , toUTF8, fromUTF8, normaliseLineEndings ) +import Distribution.Verbosity + ( Verbosity ) + +import Data.List + ( foldl', unfoldr ) +import Control.Monad + ( when ) +import System.Exit + ( ExitCode(..) ) + +-- | Represents a specific invocation of a specific program. +-- +-- This is used as an intermediate type between deciding how to call a program +-- and actually doing it. This provides the opportunity to the caller to +-- adjust how the program will be called. These invocations can either be run +-- directly or turned into shell or batch scripts. +-- +data ProgramInvocation = ProgramInvocation { + progInvokePath :: FilePath, + progInvokeArgs :: [String], + progInvokeEnv :: [(String, String)], + progInvokeCwd :: Maybe FilePath, + progInvokeInput :: Maybe String, + progInvokeInputEncoding :: IOEncoding, + progInvokeOutputEncoding :: IOEncoding + } + +data IOEncoding = IOEncodingText -- locale mode text + | IOEncodingUTF8 -- always utf8 + +emptyProgramInvocation :: ProgramInvocation +emptyProgramInvocation = + ProgramInvocation { + progInvokePath = "", + progInvokeArgs = [], + progInvokeEnv = [], + progInvokeCwd = Nothing, + progInvokeInput = Nothing, + progInvokeInputEncoding = IOEncodingText, + progInvokeOutputEncoding = IOEncodingText + } + +simpleProgramInvocation :: FilePath -> [String] -> ProgramInvocation +simpleProgramInvocation path args = + emptyProgramInvocation { + progInvokePath = path, + progInvokeArgs = args + } + +programInvocation :: ConfiguredProgram -> [String] -> ProgramInvocation +programInvocation prog args = + emptyProgramInvocation { + progInvokePath = programPath prog, + progInvokeArgs = programDefaultArgs prog + ++ args + ++ programOverrideArgs prog + } + + +runProgramInvocation :: Verbosity -> ProgramInvocation -> IO () +runProgramInvocation verbosity + ProgramInvocation { + progInvokePath = path, + progInvokeArgs = args, + progInvokeEnv = [], + progInvokeCwd = Nothing, + progInvokeInput = Nothing + } = + rawSystemExit verbosity path args + +runProgramInvocation verbosity + ProgramInvocation { + progInvokePath = path, + progInvokeArgs = args, + progInvokeEnv = [], + progInvokeCwd = Nothing, + progInvokeInput = Just inputStr, + progInvokeInputEncoding = encoding + } = do + (_, errors, exitCode) <- rawSystemStdInOut verbosity + path args + (Just input) False + when (exitCode /= ExitSuccess) $ + die errors + where + input = case encoding of + IOEncodingText -> (inputStr, False) + IOEncodingUTF8 -> (toUTF8 inputStr, True) -- use binary mode for utf8 + +runProgramInvocation _ _ = + die "runProgramInvocation: not yet implemented for this form of invocation" + + +getProgramInvocationOutput :: Verbosity -> ProgramInvocation -> IO String +getProgramInvocationOutput verbosity + ProgramInvocation { + progInvokePath = path, + progInvokeArgs = args, + progInvokeEnv = [], + progInvokeCwd = Nothing, + progInvokeInput = Nothing, + progInvokeOutputEncoding = encoding + } = do + let utf8 = case encoding of IOEncodingUTF8 -> True; _ -> False + decode | utf8 = fromUTF8 . normaliseLineEndings + | otherwise = id + (output, errors, exitCode) <- rawSystemStdInOut verbosity + path args + Nothing utf8 + when (exitCode /= ExitSuccess) $ + die errors + return (decode output) + + +getProgramInvocationOutput _ _ = + die "getProgramInvocationOutput: not yet implemented for this form of invocation" + + +-- | Like the unix xargs program. Useful for when we've got very long command +-- lines that might overflow an OS limit on command line length and so you +-- need to invoke a command multiple times to get all the args in. +-- +-- It takes four template invocations corresponding to the simple, initial, +-- middle and last invocations. If the number of args given is small enough +-- that we can get away with just a single invocation then the simple one is +-- used: +-- +-- > $ simple args +-- +-- If the number of args given means that we need to use multiple invocations +-- then the templates for the initial, middle and last invocations are used: +-- +-- > $ initial args_0 +-- > $ middle args_1 +-- > $ middle args_2 +-- > ... +-- > $ final args_n +-- +multiStageProgramInvocation + :: ProgramInvocation + -> (ProgramInvocation, ProgramInvocation, ProgramInvocation) + -> [String] + -> [ProgramInvocation] +multiStageProgramInvocation simple (initial, middle, final) args = + + let argSize inv = length (progInvokePath inv) + + foldl' (\s a -> length a + 1 + s) 1 (progInvokeArgs inv) + fixedArgSize = maximum (map argSize [simple, initial, middle, final]) + chunkSize = maxCommandLineSize - fixedArgSize + + in case splitChunks chunkSize args of + [] -> [ simple ] + + [c] -> [ simple `appendArgs` c ] + + [c,c'] -> [ initial `appendArgs` c ] + ++ [ final `appendArgs` c'] + + (c:cs) -> [ initial `appendArgs` c ] + ++ [ middle `appendArgs` c'| c' <- init cs ] + ++ [ final `appendArgs` c'| let c' = last cs ] + + where + inv `appendArgs` as = inv { progInvokeArgs = progInvokeArgs inv ++ as } + + splitChunks len = unfoldr $ \s -> + if null s then Nothing + else Just (chunk len s) + + chunk len (s:_) | length s >= len = error toolong + chunk len ss = chunk' [] len ss + + chunk' acc _ [] = (reverse acc,[]) + chunk' acc len (s:ss) + | len' < len = chunk' (s:acc) (len-len'-1) ss + | otherwise = (reverse acc, s:ss) + where len' = length s + + toolong = "multiStageProgramInvocation: a single program arg is larger " + ++ "than the maximum command line length!" + + +--FIXME: discover this at configure time or runtime on unix +-- The value is 32k on Windows and posix specifies a minimum of 4k +-- but all sensible unixes use more than 4k. +-- we could use getSysVar ArgumentLimit but that's in the unix lib +-- +maxCommandLineSize :: Int +maxCommandLineSize = 30 * 1024 diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/Program/Script.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/Program/Script.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/Program/Script.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/Program/Script.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,105 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Program.Script +-- Copyright : Duncan Coutts 2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module provides an library interface to the @hc-pkg@ program. +-- Currently only GHC and LHC have hc-pkg programs. + +module Distribution.Simple.Program.Script ( + + invocationAsSystemScript, + invocationAsShellScript, + invocationAsBatchFile, + ) where + +import Distribution.Simple.Program.Run + ( ProgramInvocation(..) ) +import Distribution.System + ( OS(..) ) + +import Data.Maybe + ( maybeToList ) + +-- | Generate a system script, either POSIX shell script or Windows batch file +-- as appropriate for the given system. +-- +invocationAsSystemScript :: OS -> ProgramInvocation -> String +invocationAsSystemScript Windows = invocationAsBatchFile +invocationAsSystemScript _ = invocationAsShellScript + + +-- | Generate a POSIX shell script that invokes a program. +-- +invocationAsShellScript :: ProgramInvocation -> String +invocationAsShellScript + ProgramInvocation { + progInvokePath = path, + progInvokeArgs = args, + progInvokeEnv = envExtra, + progInvokeCwd = mcwd, + progInvokeInput = minput + } = unlines $ + [ "#!/bin/sh" ] + ++ [ "export " ++ var ++ "=" ++ quote val + | (var,val) <- envExtra ] + ++ [ "cd " ++ quote cwd | cwd <- maybeToList mcwd ] + ++ [ (case minput of + Nothing -> "" + Just input -> "echo " ++ quote input ++ " | ") + ++ unwords (map quote $ path : args) ++ " \"$@\""] + + where + quote :: String -> String + quote s = "'" ++ escape s ++ "'" + + escape [] = [] + escape ('\'':cs) = "'\\''" ++ escape cs + escape (c :cs) = c : escape cs + + +-- | Generate a Windows batch file that invokes a program. +-- +invocationAsBatchFile :: ProgramInvocation -> String +invocationAsBatchFile + ProgramInvocation { + progInvokePath = path, + progInvokeArgs = args, + progInvokeEnv = envExtra, + progInvokeCwd = mcwd, + progInvokeInput = minput + } = unlines $ + [ "@echo off" ] + ++ [ "set " ++ var ++ "=" ++ escape val | (var,val) <- envExtra ] + ++ [ "cd \"" ++ cwd ++ "\"" | cwd <- maybeToList mcwd ] + ++ case minput of + Nothing -> + [ path ++ concatMap (' ':) args ] + + Just input -> + [ "(" ] + ++ [ "echo " ++ escape line | line <- lines input ] + ++ [ ") | " + ++ "\"" ++ path ++ "\"" + ++ concatMap (\arg -> ' ':quote arg) args ] + + where + quote :: String -> String + quote s = "\"" ++ escapeQ s ++ "\"" + + escapeQ [] = [] + escapeQ ('"':cs) = "\"\"\"" ++ escapeQ cs + escapeQ (c :cs) = c : escapeQ cs + + escape [] = [] + escape ('|':cs) = "^|" ++ escape cs + escape ('<':cs) = "^<" ++ escape cs + escape ('>':cs) = "^>" ++ escape cs + escape ('&':cs) = "^&" ++ escape cs + escape ('(':cs) = "^(" ++ escape cs + escape (')':cs) = "^)" ++ escape cs + escape ('^':cs) = "^^" ++ escape cs + escape (c :cs) = c : escape cs diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/Program/Types.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/Program/Types.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/Program/Types.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/Program/Types.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,122 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Program.Types +-- Copyright : Isaac Jones 2006, Duncan Coutts 2007-2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This provides an abstraction which deals with configuring and running +-- programs. A 'Program' is a static notion of a known program. A +-- 'ConfiguredProgram' is a 'Program' that has been found on the current +-- machine and is ready to be run (possibly with some user-supplied default +-- args). Configuring a program involves finding its location and if necessary +-- finding its version. There's reasonable default behavior for trying to find +-- \"foo\" in PATH, being able to override its location, etc. +-- +module Distribution.Simple.Program.Types ( + -- * Program and functions for constructing them + Program(..), + internalProgram, + simpleProgram, + + -- * Configured program and related functions + ConfiguredProgram(..), + programPath, + ProgArg, + ProgramLocation(..), + ) where + +import Data.List (nub) +import System.FilePath (()) + +import Distribution.Simple.Utils + ( findProgramLocation, findFirstFile ) +import Distribution.Version + ( Version ) +import Distribution.Verbosity + ( Verbosity ) + +-- | Represents a program which can be configured. +data Program = Program { + -- | The simple name of the program, eg. ghc + programName :: String, + + -- | A function to search for the program if it's location was not + -- specified by the user. Usually this will just be a + programFindLocation :: Verbosity -> IO (Maybe FilePath), + + -- | Try to find the version of the program. For many programs this is + -- not possible or is not necessary so it's ok to return Nothing. + programFindVersion :: Verbosity -> FilePath -> IO (Maybe Version), + + -- | A function to do any additional configuration after we have + -- located the program (and perhaps identified its version). It is + -- allowed to return additional flags that will be passed to the + -- program on every invocation. + programPostConf :: Verbosity -> ConfiguredProgram -> IO [ProgArg] + } + +type ProgArg = String + +data ConfiguredProgram = ConfiguredProgram { + -- | Just the name again + programId :: String, + + -- | The version of this program, if it is known. + programVersion :: Maybe Version, + + -- | Default command-line args for this program. + -- These flags will appear first on the command line, so they can be + -- overridden by subsequent flags. + programDefaultArgs :: [String], + + -- | Override command-line args for this program. + -- These flags will appear last on the command line, so they override + -- all earlier flags. + programOverrideArgs :: [String], + + -- | Location of the program. eg. @\/usr\/bin\/ghc-6.4@ + programLocation :: ProgramLocation + } deriving (Read, Show, Eq) + +-- | Where a program was found. Also tells us whether it's specifed by user or +-- not. This includes not just the path, but the program as well. +data ProgramLocation + = UserSpecified { locationPath :: FilePath } + -- ^The user gave the path to this program, + -- eg. --ghc-path=\/usr\/bin\/ghc-6.6 + | FoundOnSystem { locationPath :: FilePath } + -- ^The location of the program, as located by searching PATH. + deriving (Read, Show, Eq) + +-- | The full path of a configured program. +programPath :: ConfiguredProgram -> FilePath +programPath = locationPath . programLocation + +-- | Make a simple named program. +-- +-- By default we'll just search for it in the path and not try to find the +-- version name. You can override these behaviours if necessary, eg: +-- +-- > simpleProgram "foo" { programFindLocation = ... , programFindVersion ... } +-- +simpleProgram :: String -> Program +simpleProgram name = Program { + programName = name, + programFindLocation = \v -> findProgramLocation v name, + programFindVersion = \_ _ -> return Nothing, + programPostConf = \_ _ -> return [] + } + +-- | Make a simple 'internal' program; that is, one that was built as an +-- executable already and is expected to be found in the build directory +internalProgram :: [FilePath] -> String -> Program +internalProgram paths name = Program { + programName = name, + programFindLocation = \_v -> + findFirstFile id [ path name | path <- nub paths ], + programFindVersion = \_ _ -> return Nothing, + programPostConf = \_ _ -> return [] + } + diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/Program.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/Program.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/Program.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/Program.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,217 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Program +-- Copyright : Isaac Jones 2006, Duncan Coutts 2007-2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This provides an abstraction which deals with configuring and running +-- programs. A 'Program' is a static notion of a known program. A +-- 'ConfiguredProgram' is a 'Program' that has been found on the current +-- machine and is ready to be run (possibly with some user-supplied default +-- args). Configuring a program involves finding its location and if necessary +-- finding its version. There is also a 'ProgramConfiguration' type which holds +-- configured and not-yet configured programs. It is the parameter to lots of +-- actions elsewhere in Cabal that need to look up and run programs. If we had +-- a Cabal monad, the 'ProgramConfiguration' would probably be a reader or +-- state component of it. +-- +-- The module also defines all the known built-in 'Program's and the +-- 'defaultProgramConfiguration' which contains them all. +-- +-- One nice thing about using it is that any program that is +-- registered with Cabal will get some \"configure\" and \".cabal\" +-- helpers like --with-foo-args --foo-path= and extra-foo-args. +-- +-- There's also good default behavior for trying to find \"foo\" in +-- PATH, being able to override its location, etc. +-- +-- There's also a hook for adding programs in a Setup.lhs script. See +-- hookedPrograms in 'Distribution.Simple.UserHooks'. This gives a +-- hook user the ability to get the above flags and such so that they +-- don't have to write all the PATH logic inside Setup.lhs. + +module Distribution.Simple.Program ( + -- * Program and functions for constructing them + Program(..) + , simpleProgram + , findProgramLocation + , findProgramVersion + + -- * Configured program and related functions + , ConfiguredProgram(..) + , programPath + , ProgArg + , ProgramLocation(..) + , runProgram + , getProgramOutput + + -- * Program invocations + , ProgramInvocation(..) + , emptyProgramInvocation + , simpleProgramInvocation + , programInvocation + , runProgramInvocation + , getProgramInvocationOutput + + -- * The collection of unconfigured and configured progams + , builtinPrograms + + -- * The collection of configured programs we can run + , ProgramConfiguration + , emptyProgramConfiguration + , defaultProgramConfiguration + , restoreProgramConfiguration + , addKnownProgram + , addKnownPrograms + , lookupKnownProgram + , knownPrograms + , userSpecifyPath + , userSpecifyPaths + , userMaybeSpecifyPath + , userSpecifyArgs + , userSpecifyArgss + , userSpecifiedArgs + , lookupProgram + , updateProgram + , configureProgram + , configureAllKnownPrograms + , reconfigurePrograms + , requireProgram + , requireProgramVersion + , runDbProgram + , getDbProgramOutput + + -- * Programs that Cabal knows about + , ghcProgram + , ghcPkgProgram + , lhcProgram + , lhcPkgProgram + , nhcProgram + , hmakeProgram + , jhcProgram + , hugsProgram + , ffihugsProgram + , uhcProgram + , gccProgram + , ranlibProgram + , arProgram + , stripProgram + , happyProgram + , alexProgram + , hsc2hsProgram + , c2hsProgram + , cpphsProgram + , hscolourProgram + , haddockProgram + , greencardProgram + , ldProgram + , tarProgram + , cppProgram + , pkgConfigProgram + + -- * deprecated + , rawSystemProgram + , rawSystemProgramStdout + , rawSystemProgramConf + , rawSystemProgramStdoutConf + , findProgramOnPath + + ) where + +import Distribution.Simple.Program.Types +import Distribution.Simple.Program.Run +import Distribution.Simple.Program.Db +import Distribution.Simple.Program.Builtin + +import Distribution.Simple.Utils + ( die, findProgramLocation, findProgramVersion ) +import Distribution.Verbosity + ( Verbosity ) + + +-- | Runs the given configured program. +-- +runProgram :: Verbosity -- ^Verbosity + -> ConfiguredProgram -- ^The program to run + -> [ProgArg] -- ^Any /extra/ arguments to add + -> IO () +runProgram verbosity prog args = + runProgramInvocation verbosity (programInvocation prog args) + + +-- | Runs the given configured program and gets the output. +-- +getProgramOutput :: Verbosity -- ^Verbosity + -> ConfiguredProgram -- ^The program to run + -> [ProgArg] -- ^Any /extra/ arguments to add + -> IO String +getProgramOutput verbosity prog args = + getProgramInvocationOutput verbosity (programInvocation prog args) + + +-- | Looks up the given program in the program database and runs it. +-- +runDbProgram :: Verbosity -- ^verbosity + -> Program -- ^The program to run + -> ProgramDb -- ^look up the program here + -> [ProgArg] -- ^Any /extra/ arguments to add + -> IO () +runDbProgram verbosity prog programDb args = + case lookupProgram prog programDb of + Nothing -> die notFound + Just configuredProg -> runProgram verbosity configuredProg args + where + notFound = "The program " ++ programName prog + ++ " is required but it could not be found" + +-- | Looks up the given program in the program database and runs it. +-- +getDbProgramOutput :: Verbosity -- ^verbosity + -> Program -- ^The program to run + -> ProgramDb -- ^look up the program here + -> [ProgArg] -- ^Any /extra/ arguments to add + -> IO String +getDbProgramOutput verbosity prog programDb args = + case lookupProgram prog programDb of + Nothing -> die notFound + Just configuredProg -> getProgramOutput verbosity configuredProg args + where + notFound = "The program " ++ programName prog + ++ " is required but it could not be found" + + +--------------------- +-- Deprecated aliases +-- + +rawSystemProgram :: Verbosity -> ConfiguredProgram + -> [ProgArg] -> IO () +rawSystemProgram = runProgram + +rawSystemProgramStdout :: Verbosity -> ConfiguredProgram + -> [ProgArg] -> IO String +rawSystemProgramStdout = getProgramOutput + +rawSystemProgramConf :: Verbosity -> Program -> ProgramConfiguration + -> [ProgArg] -> IO () +rawSystemProgramConf = runDbProgram + +rawSystemProgramStdoutConf :: Verbosity -> Program -> ProgramConfiguration + -> [ProgArg] -> IO String +rawSystemProgramStdoutConf = getDbProgramOutput + +type ProgramConfiguration = ProgramDb + +emptyProgramConfiguration, defaultProgramConfiguration :: ProgramConfiguration +emptyProgramConfiguration = emptyProgramDb +defaultProgramConfiguration = defaultProgramDb + +restoreProgramConfiguration :: [Program] -> ProgramConfiguration + -> ProgramConfiguration +restoreProgramConfiguration = restoreProgramDb + +{-# DEPRECATED findProgramOnPath "use findProgramLocation instead" #-} +findProgramOnPath :: String -> Verbosity -> IO (Maybe FilePath) +findProgramOnPath = flip findProgramLocation diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/Register.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/Register.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/Register.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/Register.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,390 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Register +-- Copyright : Isaac Jones 2003-2004 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module deals with registering and unregistering packages. There are a +-- couple ways it can do this, one is to do it directly. Another is to generate +-- a script that can be run later to do it. The idea here being that the user +-- is shielded from the details of what command to use for package registration +-- for a particular compiler. In practice this aspect was not especially +-- popular so we also provide a way to simply generate the package registration +-- file which then must be manually passed to @ghc-pkg@. It is possible to +-- generate registration information for where the package is to be installed, +-- or alternatively to register the package inplace in the build tree. The +-- latter is occasionally handy, and will become more important when we try to +-- build multi-package systems. +-- +-- This module does not delegate anything to the per-compiler modules but just +-- mixes it all in in this module, which is rather unsatisfactory. The script +-- generation and the unregister feature are not well used or tested. + +{- Copyright (c) 2003-2004, Isaac Jones +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.Simple.Register ( + register, + unregister, + + registerPackage, + generateRegistrationInfo, + inplaceInstalledPackageInfo, + absoluteInstalledPackageInfo, + generalInstalledPackageInfo, + ) where + +import Distribution.Simple.LocalBuildInfo + ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) + , InstallDirs(..), absoluteInstallDirs ) +import Distribution.Simple.BuildPaths (haddockName) +import qualified Distribution.Simple.GHC as GHC +import qualified Distribution.Simple.LHC as LHC +import qualified Distribution.Simple.Hugs as Hugs +import qualified Distribution.Simple.UHC as UHC +import Distribution.Simple.Compiler + ( compilerVersion, CompilerFlavor(..), compilerFlavor + , PackageDBStack, registrationPackageDB ) +import Distribution.Simple.Program + ( ConfiguredProgram, runProgramInvocation + , requireProgram, lookupProgram, ghcPkgProgram, lhcPkgProgram ) +import Distribution.Simple.Program.Script + ( invocationAsSystemScript ) +import qualified Distribution.Simple.Program.HcPkg as HcPkg +import Distribution.Simple.Setup + ( RegisterFlags(..), CopyDest(..) + , fromFlag, fromFlagOrDefault, flagToMaybe ) +import Distribution.PackageDescription + ( PackageDescription(..), Library(..), BuildInfo(..), hcOptions ) +import Distribution.Package + ( Package(..), packageName, InstalledPackageId(..) ) +import Distribution.InstalledPackageInfo + ( InstalledPackageInfo, InstalledPackageInfo_(InstalledPackageInfo) + , showInstalledPackageInfo ) +import qualified Distribution.InstalledPackageInfo as IPI +import Distribution.Simple.Utils + ( writeUTF8File, writeFileAtomic, setFileExecutable + , die, notice, setupMessage ) +import Distribution.System + ( OS(..), buildOS ) +import Distribution.Text + ( display ) +import Distribution.Version ( Version(..) ) +import Distribution.Verbosity as Verbosity + ( Verbosity, normal ) +import Distribution.Compat.Exception + ( tryIO ) + +import System.FilePath ((), (<.>), isAbsolute) +import System.Directory + ( getCurrentDirectory, removeDirectoryRecursive ) + +import Data.Maybe + ( isJust, fromMaybe, maybeToList ) +import Data.List + ( partition, nub ) + + +-- ----------------------------------------------------------------------------- +-- Registration + +register :: PackageDescription -> LocalBuildInfo + -> RegisterFlags -- ^Install in the user's database?; verbose + -> IO () +register pkg@PackageDescription { library = Just lib } + lbi@LocalBuildInfo { libraryConfig = Just clbi } regFlags + = do + + installedPkgInfo <- generateRegistrationInfo + verbosity pkg lib lbi clbi inplace distPref + + -- Three different modes: + case () of + _ | modeGenerateRegFile -> writeRegistrationFile installedPkgInfo + | modeGenerateRegScript -> writeRegisterScript installedPkgInfo + | otherwise -> registerPackage verbosity + installedPkgInfo pkg lbi inplace packageDbs + + where + modeGenerateRegFile = isJust (flagToMaybe (regGenPkgConf regFlags)) + regFile = fromMaybe (display (packageId pkg) <.> "conf") + (fromFlag (regGenPkgConf regFlags)) + + modeGenerateRegScript = fromFlag (regGenScript regFlags) + + inplace = fromFlag (regInPlace regFlags) + -- FIXME: there's really no guarantee this will work. + -- registering into a totally different db stack can + -- fail if dependencies cannot be satisfied. + packageDbs = nub $ withPackageDB lbi + ++ maybeToList (flagToMaybe (regPackageDB regFlags)) + distPref = fromFlag (regDistPref regFlags) + verbosity = fromFlag (regVerbosity regFlags) + + writeRegistrationFile installedPkgInfo = do + notice verbosity ("Creating package registration file: " ++ regFile) + writeUTF8File regFile (showInstalledPackageInfo installedPkgInfo) + + writeRegisterScript installedPkgInfo = + case compilerFlavor (compiler lbi) of + GHC -> do (ghcPkg, _) <- requireProgram verbosity ghcPkgProgram (withPrograms lbi) + writeHcPkgRegisterScript verbosity installedPkgInfo ghcPkg packageDbs + LHC -> do (lhcPkg, _) <- requireProgram verbosity lhcPkgProgram (withPrograms lbi) + writeHcPkgRegisterScript verbosity installedPkgInfo lhcPkg packageDbs + Hugs -> notice verbosity "Registration scripts not needed for hugs" + JHC -> notice verbosity "Registration scripts not needed for jhc" + NHC -> notice verbosity "Registration scripts not needed for nhc98" + UHC -> notice verbosity "Registration scripts not needed for uhc" + _ -> die "Registration scripts are not implemented for this compiler" + +register _ _ regFlags = notice verbosity "No package to register" + where + verbosity = fromFlag (regVerbosity regFlags) + + +generateRegistrationInfo :: Verbosity + -> PackageDescription + -> Library + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> Bool + -> FilePath + -> IO InstalledPackageInfo +generateRegistrationInfo verbosity pkg lib lbi clbi inplace distPref = do + --TODO: eliminate pwd! + pwd <- getCurrentDirectory + + --TODO: the method of setting the InstalledPackageId is compiler specific + -- this aspect should be delegated to a per-compiler helper. + let comp = compiler lbi + ipid <- + case compilerFlavor comp of + GHC | compilerVersion comp >= Version [6,11] [] -> do + s <- GHC.libAbiHash verbosity pkg lbi lib clbi + return (InstalledPackageId (display (packageId pkg) ++ '-':s)) + _other -> do + return (InstalledPackageId (display (packageId pkg))) + + let installedPkgInfo + | inplace = inplaceInstalledPackageInfo pwd distPref + pkg lib lbi clbi + | otherwise = absoluteInstalledPackageInfo + pkg lib lbi clbi + + return installedPkgInfo{ IPI.installedPackageId = ipid } + + +registerPackage :: Verbosity + -> InstalledPackageInfo + -> PackageDescription + -> LocalBuildInfo + -> Bool + -> PackageDBStack + -> IO () +registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs = do + setupMessage verbosity "Registering" (packageId pkg) + case compilerFlavor (compiler lbi) of + GHC -> GHC.registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs + LHC -> LHC.registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs + Hugs -> Hugs.registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs + UHC -> UHC.registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs + JHC -> notice verbosity "Registering for jhc (nothing to do)" + NHC -> notice verbosity "Registering for nhc98 (nothing to do)" + _ -> die "Registering is not implemented for this compiler" + + +writeHcPkgRegisterScript :: Verbosity + -> InstalledPackageInfo + -> ConfiguredProgram + -> PackageDBStack + -> IO () +writeHcPkgRegisterScript verbosity installedPkgInfo hcPkg packageDbs = do + let invocation = HcPkg.reregisterInvocation hcPkg Verbosity.normal + packageDbs (Right installedPkgInfo) + regScript = invocationAsSystemScript buildOS invocation + + notice verbosity ("Creating package registration script: " ++ regScriptFileName) + writeUTF8File regScriptFileName regScript + setFileExecutable regScriptFileName + +regScriptFileName :: FilePath +regScriptFileName = case buildOS of + Windows -> "register.bat" + _ -> "register.sh" + + +-- ----------------------------------------------------------------------------- +-- Making the InstalledPackageInfo + +-- | Construct 'InstalledPackageInfo' for a library in a package, given a set +-- of installation directories. +-- +generalInstalledPackageInfo + :: ([FilePath] -> [FilePath]) -- ^ Translate relative include dir paths to + -- absolute paths. + -> PackageDescription + -> Library + -> ComponentLocalBuildInfo + -> InstallDirs FilePath + -> InstalledPackageInfo +generalInstalledPackageInfo adjustRelIncDirs pkg lib clbi installDirs = + InstalledPackageInfo { + --TODO: do not open-code this conversion from PackageId to InstalledPackageId + IPI.installedPackageId = InstalledPackageId (display (packageId pkg)), + IPI.sourcePackageId = packageId pkg, + IPI.license = license pkg, + IPI.copyright = copyright pkg, + IPI.maintainer = maintainer pkg, + IPI.author = author pkg, + IPI.stability = stability pkg, + IPI.homepage = homepage pkg, + IPI.pkgUrl = pkgUrl pkg, + IPI.synopsis = synopsis pkg, + IPI.description = description pkg, + IPI.category = category pkg, + IPI.exposed = libExposed lib, + IPI.exposedModules = exposedModules lib, + IPI.hiddenModules = otherModules bi, + IPI.trusted = False, + IPI.importDirs = [ libdir installDirs | hasModules ], + IPI.libraryDirs = if hasLibrary + then libdir installDirs : extraLibDirs bi + else extraLibDirs bi, + IPI.hsLibraries = [ "HS" ++ display (packageId pkg) | hasLibrary ], + IPI.extraLibraries = extraLibs bi, + IPI.extraGHCiLibraries = [], + IPI.includeDirs = absinc ++ adjustRelIncDirs relinc, + IPI.includes = includes bi, + IPI.depends = map fst (componentPackageDeps clbi), + IPI.hugsOptions = hcOptions Hugs bi, + IPI.ccOptions = [], -- Note. NOT ccOptions bi! + -- We don't want cc-options to be propagated + -- to C compilations in other packages. + IPI.ldOptions = ldOptions bi, + IPI.frameworkDirs = [], + IPI.frameworks = frameworks bi, + IPI.haddockInterfaces = [haddockdir installDirs haddockName pkg], + IPI.haddockHTMLs = [htmldir installDirs] + } + where + bi = libBuildInfo lib + (absinc, relinc) = partition isAbsolute (includeDirs bi) + hasModules = not $ null (exposedModules lib) + && null (otherModules bi) + hasLibrary = hasModules || not (null (cSources bi)) + + +-- | Construct 'InstalledPackageInfo' for a library that is inplace in the +-- build tree. +-- +-- This function knows about the layout of inplace packages. +-- +inplaceInstalledPackageInfo :: FilePath -- ^ top of the build tree + -> FilePath -- ^ location of the dist tree + -> PackageDescription + -> Library + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> InstalledPackageInfo +inplaceInstalledPackageInfo inplaceDir distPref pkg lib lbi clbi = + generalInstalledPackageInfo adjustReativeIncludeDirs pkg lib clbi installDirs + where + adjustReativeIncludeDirs = map (inplaceDir ) + installDirs = + (absoluteInstallDirs pkg lbi NoCopyDest) { + libdir = inplaceDir buildDir lbi, + datadir = inplaceDir, + datasubdir = distPref, + docdir = inplaceDocdir, + htmldir = inplaceHtmldir, + haddockdir = inplaceHtmldir + } + inplaceDocdir = inplaceDir distPref "doc" + inplaceHtmldir = inplaceDocdir "html" display (packageName pkg) + + +-- | Construct 'InstalledPackageInfo' for the final install location of a +-- library package. +-- +-- This function knows about the layout of installed packages. +-- +absoluteInstalledPackageInfo :: PackageDescription + -> Library + -> LocalBuildInfo + -> ComponentLocalBuildInfo + -> InstalledPackageInfo +absoluteInstalledPackageInfo pkg lib lbi clbi = + generalInstalledPackageInfo adjustReativeIncludeDirs pkg lib clbi installDirs + where + -- For installed packages we install all include files into one dir, + -- whereas in the build tree they may live in multiple local dirs. + adjustReativeIncludeDirs _ + | null (installIncludes bi) = [] + | otherwise = [includedir installDirs] + bi = libBuildInfo lib + installDirs = absoluteInstallDirs pkg lbi NoCopyDest + +-- ----------------------------------------------------------------------------- +-- Unregistration + +unregister :: PackageDescription -> LocalBuildInfo -> RegisterFlags -> IO () +unregister pkg lbi regFlags = do + let pkgid = packageId pkg + genScript = fromFlag (regGenScript regFlags) + verbosity = fromFlag (regVerbosity regFlags) + packageDb = fromFlagOrDefault (registrationPackageDB (withPackageDB lbi)) + (regPackageDB regFlags) + installDirs = absoluteInstallDirs pkg lbi NoCopyDest + setupMessage verbosity "Unregistering" pkgid + case compilerFlavor (compiler lbi) of + GHC -> + let Just ghcPkg = lookupProgram ghcPkgProgram (withPrograms lbi) + invocation = HcPkg.unregisterInvocation ghcPkg Verbosity.normal + packageDb pkgid + in if genScript + then writeFileAtomic unregScriptFileName + (invocationAsSystemScript buildOS invocation) + else runProgramInvocation verbosity invocation + Hugs -> do + _ <- tryIO $ removeDirectoryRecursive (libdir installDirs) + return () + NHC -> do + _ <- tryIO $ removeDirectoryRecursive (libdir installDirs) + return () + _ -> + die ("only unregistering with GHC and Hugs is implemented") + +unregScriptFileName :: FilePath +unregScriptFileName = case buildOS of + Windows -> "unregister.bat" + _ -> "unregister.sh" diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/Setup.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/Setup.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/Setup.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/Setup.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,1584 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Setup +-- Copyright : Isaac Jones 2003-2004 +-- Duncan Coutts 2007 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is a big module, but not very complicated. The code is very regular +-- and repetitive. It defines the command line interface for all the Cabal +-- commands. For each command (like @configure@, @build@ etc) it defines a type +-- that holds all the flags, the default set of flags and a 'CommandUI' that +-- maps command line flags to and from the corresponding flags type. +-- +-- All the flags types are instances of 'Monoid', see +-- +-- for an explanation. +-- +-- The types defined here get used in the front end and especially in +-- @cabal-install@ which has to do quite a bit of manipulating sets of command +-- line flags. +-- +-- This is actually relatively nice, it works quite well. The main change it +-- needs is to unify it with the code for managing sets of fields that can be +-- read and written from files. This would allow us to save configure flags in +-- config files. + +{- All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.Simple.Setup ( + + GlobalFlags(..), emptyGlobalFlags, defaultGlobalFlags, globalCommand, + ConfigFlags(..), emptyConfigFlags, defaultConfigFlags, configureCommand, + CopyFlags(..), emptyCopyFlags, defaultCopyFlags, copyCommand, + InstallFlags(..), emptyInstallFlags, defaultInstallFlags, installCommand, + HaddockFlags(..), emptyHaddockFlags, defaultHaddockFlags, haddockCommand, + HscolourFlags(..), emptyHscolourFlags, defaultHscolourFlags, hscolourCommand, + BuildFlags(..), emptyBuildFlags, defaultBuildFlags, buildCommand, + buildVerbose, + CleanFlags(..), emptyCleanFlags, defaultCleanFlags, cleanCommand, + RegisterFlags(..), emptyRegisterFlags, defaultRegisterFlags, registerCommand, + unregisterCommand, + SDistFlags(..), emptySDistFlags, defaultSDistFlags, sdistCommand, + TestFlags(..), emptyTestFlags, defaultTestFlags, testCommand, + TestShowDetails(..), + CopyDest(..), + configureArgs, configureOptions, configureCCompiler, configureLinker, + installDirsOptions, + + defaultDistPref, + + Flag(..), + toFlag, + fromFlag, + fromFlagOrDefault, + flagToMaybe, + flagToList, + boolOpt, boolOpt', trueArg, falseArg, optionVerbosity ) where + +import Distribution.Compiler () +import Distribution.ReadE +import Distribution.Text + ( Text(..), display ) +import qualified Distribution.Compat.ReadP as Parse +import qualified Text.PrettyPrint as Disp +import Distribution.Package ( Dependency(..) ) +import Distribution.PackageDescription + ( FlagName(..), FlagAssignment ) +import Distribution.Simple.Command hiding (boolOpt, boolOpt') +import qualified Distribution.Simple.Command as Command +import Distribution.Simple.Compiler + ( CompilerFlavor(..), defaultCompilerFlavor, PackageDB(..) + , OptimisationLevel(..), flagToOptimisationLevel ) +import Distribution.Simple.Utils + ( wrapLine, lowercase, intercalate ) +import Distribution.Simple.Program (Program(..), ProgramConfiguration, + requireProgram, + programInvocation, progInvokePath, progInvokeArgs, + knownPrograms, + addKnownProgram, emptyProgramConfiguration, + haddockProgram, ghcProgram, gccProgram, ldProgram) +import Distribution.Simple.InstallDirs + ( InstallDirs(..), CopyDest(..), + PathTemplate, toPathTemplate, fromPathTemplate ) +import Distribution.Verbosity + +import Data.List ( sort ) +import Data.Char ( isSpace, isAlpha ) +import Data.Monoid ( Monoid(..) ) + +-- FIXME Not sure where this should live +defaultDistPref :: FilePath +defaultDistPref = "dist" + +-- ------------------------------------------------------------ +-- * Flag type +-- ------------------------------------------------------------ + +-- | All flags are monoids, they come in two flavours: +-- +-- 1. list flags eg +-- +-- > --ghc-option=foo --ghc-option=bar +-- +-- gives us all the values ["foo", "bar"] +-- +-- 2. singular value flags, eg: +-- +-- > --enable-foo --disable-foo +-- +-- gives us Just False +-- So this Flag type is for the latter singular kind of flag. +-- Its monoid instance gives us the behaviour where it starts out as +-- 'NoFlag' and later flags override earlier ones. +-- +data Flag a = Flag a | NoFlag deriving (Show, Read, Eq) + +instance Functor Flag where + fmap f (Flag x) = Flag (f x) + fmap _ NoFlag = NoFlag + +instance Monoid (Flag a) where + mempty = NoFlag + _ `mappend` f@(Flag _) = f + f `mappend` NoFlag = f + +instance Bounded a => Bounded (Flag a) where + minBound = toFlag minBound + maxBound = toFlag maxBound + +instance Enum a => Enum (Flag a) where + fromEnum = fromEnum . fromFlag + toEnum = toFlag . toEnum + enumFrom (Flag a) = map toFlag . enumFrom $ a + enumFrom _ = [] + enumFromThen (Flag a) (Flag b) = toFlag `map` enumFromThen a b + enumFromThen _ _ = [] + enumFromTo (Flag a) (Flag b) = toFlag `map` enumFromTo a b + enumFromTo _ _ = [] + enumFromThenTo (Flag a) (Flag b) (Flag c) = toFlag `map` enumFromThenTo a b c + enumFromThenTo _ _ _ = [] + +toFlag :: a -> Flag a +toFlag = Flag + +fromFlag :: Flag a -> a +fromFlag (Flag x) = x +fromFlag NoFlag = error "fromFlag NoFlag. Use fromFlagOrDefault" + +fromFlagOrDefault :: a -> Flag a -> a +fromFlagOrDefault _ (Flag x) = x +fromFlagOrDefault def NoFlag = def + +flagToMaybe :: Flag a -> Maybe a +flagToMaybe (Flag x) = Just x +flagToMaybe NoFlag = Nothing + +flagToList :: Flag a -> [a] +flagToList (Flag x) = [x] +flagToList NoFlag = [] + +-- ------------------------------------------------------------ +-- * Global flags +-- ------------------------------------------------------------ + +-- In fact since individual flags types are monoids and these are just sets of +-- flags then they are also monoids pointwise. This turns out to be really +-- useful. The mempty is the set of empty flags and mappend allows us to +-- override specific flags. For example we can start with default flags and +-- override with the ones we get from a file or the command line, or both. + +-- | Flags that apply at the top level, not to any sub-command. +data GlobalFlags = GlobalFlags { + globalVersion :: Flag Bool, + globalNumericVersion :: Flag Bool + } + +defaultGlobalFlags :: GlobalFlags +defaultGlobalFlags = GlobalFlags { + globalVersion = Flag False, + globalNumericVersion = Flag False + } + +globalCommand :: CommandUI GlobalFlags +globalCommand = CommandUI { + commandName = "", + commandSynopsis = "", + commandUsage = \_ -> + "This Setup program uses the Haskell Cabal Infrastructure.\n" + ++ "See http://www.haskell.org/cabal/ for more information.\n", + commandDescription = Just $ \pname -> + "For more information about a command use\n" + ++ " " ++ pname ++ " COMMAND --help\n\n" + ++ "Typical steps for installing Cabal packages:\n" + ++ concat [ " " ++ pname ++ " " ++ x ++ "\n" + | x <- ["configure", "build", "install"]], + commandDefaultFlags = defaultGlobalFlags, + commandOptions = \_ -> + [option ['V'] ["version"] + "Print version information" + globalVersion (\v flags -> flags { globalVersion = v }) + trueArg + ,option [] ["numeric-version"] + "Print just the version number" + globalNumericVersion (\v flags -> flags { globalNumericVersion = v }) + trueArg + ] + } + +emptyGlobalFlags :: GlobalFlags +emptyGlobalFlags = mempty + +instance Monoid GlobalFlags where + mempty = GlobalFlags { + globalVersion = mempty, + globalNumericVersion = mempty + } + mappend a b = GlobalFlags { + globalVersion = combine globalVersion, + globalNumericVersion = combine globalNumericVersion + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * Config flags +-- ------------------------------------------------------------ + +-- | Flags to @configure@ command +data ConfigFlags = ConfigFlags { + --FIXME: the configPrograms is only here to pass info through to configure + -- because the type of configure is constrained by the UserHooks. + -- when we change UserHooks next we should pass the initial + -- ProgramConfiguration directly and not via ConfigFlags + configPrograms :: ProgramConfiguration, -- ^All programs that cabal may run + + configProgramPaths :: [(String, FilePath)], -- ^user specifed programs paths + configProgramArgs :: [(String, [String])], -- ^user specifed programs args + configHcFlavor :: Flag CompilerFlavor, -- ^The \"flavor\" of the compiler, sugh as GHC or Hugs. + configHcPath :: Flag FilePath, -- ^given compiler location + configHcPkg :: Flag FilePath, -- ^given hc-pkg location + configVanillaLib :: Flag Bool, -- ^Enable vanilla library + configProfLib :: Flag Bool, -- ^Enable profiling in the library + configSharedLib :: Flag Bool, -- ^Build shared library + configDynExe :: Flag Bool, -- ^Enable dynamic linking of the executables. + configProfExe :: Flag Bool, -- ^Enable profiling in the executables. + configConfigureArgs :: [String], -- ^Extra arguments to @configure@ + configOptimization :: Flag OptimisationLevel, -- ^Enable optimization. + configProgPrefix :: Flag PathTemplate, -- ^Installed executable prefix. + configProgSuffix :: Flag PathTemplate, -- ^Installed executable suffix. + configInstallDirs :: InstallDirs (Flag PathTemplate), -- ^Installation paths + configScratchDir :: Flag FilePath, + configExtraLibDirs :: [FilePath], -- ^ path to search for extra libraries + configExtraIncludeDirs :: [FilePath], -- ^ path to search for header files + + configDistPref :: Flag FilePath, -- ^"dist" prefix + configVerbosity :: Flag Verbosity, -- ^verbosity level + configUserInstall :: Flag Bool, -- ^The --user\/--global flag + configPackageDB :: Flag PackageDB, -- ^Which package DB to use + configGHCiLib :: Flag Bool, -- ^Enable compiling library for GHCi + configSplitObjs :: Flag Bool, -- ^Enable -split-objs with GHC + configStripExes :: Flag Bool, -- ^Enable executable stripping + configConstraints :: [Dependency], -- ^Additional constraints for + -- dependencies + configConfigurationsFlags :: FlagAssignment, + configTests :: Flag Bool, -- ^Enable test suite compilation + configLibCoverage :: Flag Bool -- ^ Enable test suite program coverage + } + deriving (Read,Show) + +defaultConfigFlags :: ProgramConfiguration -> ConfigFlags +defaultConfigFlags progConf = emptyConfigFlags { + configPrograms = progConf, + configHcFlavor = maybe NoFlag Flag defaultCompilerFlavor, + configVanillaLib = Flag True, + configProfLib = Flag False, + configSharedLib = Flag False, + configDynExe = Flag False, + configProfExe = Flag False, + configOptimization = Flag NormalOptimisation, + configProgPrefix = Flag (toPathTemplate ""), + configProgSuffix = Flag (toPathTemplate ""), + configDistPref = Flag defaultDistPref, + configVerbosity = Flag normal, + configUserInstall = Flag False, --TODO: reverse this + configGHCiLib = Flag True, + configSplitObjs = Flag False, -- takes longer, so turn off by default + configStripExes = Flag True, + configTests = Flag False, + configLibCoverage = Flag False + } + +configureCommand :: ProgramConfiguration -> CommandUI ConfigFlags +configureCommand progConf = makeCommand name shortDesc longDesc defaultFlags options + where + name = "configure" + shortDesc = "Prepare to build the package." + longDesc = Just (\_ -> programFlagsDescription progConf) + defaultFlags = defaultConfigFlags progConf + options showOrParseArgs = + configureOptions showOrParseArgs + ++ programConfigurationPaths progConf showOrParseArgs + configProgramPaths (\v fs -> fs { configProgramPaths = v }) + ++ programConfigurationOptions progConf showOrParseArgs + configProgramArgs (\v fs -> fs { configProgramArgs = v }) + + +configureOptions :: ShowOrParseArgs -> [OptionField ConfigFlags] +configureOptions showOrParseArgs = + [optionVerbosity configVerbosity (\v flags -> flags { configVerbosity = v }) + ,optionDistPref + configDistPref (\d flags -> flags { configDistPref = d }) + showOrParseArgs + + ,option [] ["compiler"] "compiler" + configHcFlavor (\v flags -> flags { configHcFlavor = v }) + (choiceOpt [ (Flag GHC, ("g", ["ghc"]), "compile with GHC") + , (Flag NHC, ([] , ["nhc98"]), "compile with NHC") + , (Flag JHC, ([] , ["jhc"]), "compile with JHC") + , (Flag LHC, ([] , ["lhc"]), "compile with LHC") + , (Flag Hugs,([] , ["hugs"]), "compile with Hugs") + , (Flag UHC, ([] , ["uhc"]), "compile with UHC")]) + + ,option "w" ["with-compiler"] + "give the path to a particular compiler" + configHcPath (\v flags -> flags { configHcPath = v }) + (reqArgFlag "PATH") + + ,option "" ["with-hc-pkg"] + "give the path to the package tool" + configHcPkg (\v flags -> flags { configHcPkg = v }) + (reqArgFlag "PATH") + ] + ++ map liftInstallDirs installDirsOptions + ++ [option "b" ["scratchdir"] + "directory to receive the built package (hugs-only)" + configScratchDir (\v flags -> flags { configScratchDir = v }) + (reqArgFlag "DIR") + --TODO: eliminate scratchdir flag + + ,option "" ["program-prefix"] + "prefix to be applied to installed executables" + configProgPrefix + (\v flags -> flags { configProgPrefix = v }) + (reqPathTemplateArgFlag "PREFIX") + + ,option "" ["program-suffix"] + "suffix to be applied to installed executables" + configProgSuffix (\v flags -> flags { configProgSuffix = v } ) + (reqPathTemplateArgFlag "SUFFIX") + + ,option "" ["library-vanilla"] + "Vanilla libraries" + configVanillaLib (\v flags -> flags { configVanillaLib = v }) + (boolOpt [] []) + + ,option "p" ["library-profiling"] + "Library profiling" + configProfLib (\v flags -> flags { configProfLib = v }) + (boolOpt "p" []) + + ,option "" ["shared"] + "Shared library" + configSharedLib (\v flags -> flags { configSharedLib = v }) + (boolOpt [] []) + + ,option "" ["executable-dynamic"] + "Executable dynamic linking" + configDynExe (\v flags -> flags { configDynExe = v }) + (boolOpt [] []) + + ,option "" ["executable-profiling"] + "Executable profiling" + configProfExe (\v flags -> flags { configProfExe = v }) + (boolOpt [] []) + + ,multiOption "optimization" + configOptimization (\v flags -> flags { configOptimization = v }) + [optArg' "n" (Flag . flagToOptimisationLevel) + (\f -> case f of + Flag NoOptimisation -> [] + Flag NormalOptimisation -> [Nothing] + Flag MaximumOptimisation -> [Just "2"] + _ -> []) + "O" ["enable-optimization","enable-optimisation"] + "Build with optimization (n is 0--2, default is 1)", + noArg (Flag NoOptimisation) [] + ["disable-optimization","disable-optimisation"] + "Build without optimization" + ] + + ,option "" ["library-for-ghci"] + "compile library for use with GHCi" + configGHCiLib (\v flags -> flags { configGHCiLib = v }) + (boolOpt [] []) + + ,option "" ["split-objs"] + "split library into smaller objects to reduce binary sizes (GHC 6.6+)" + configSplitObjs (\v flags -> flags { configSplitObjs = v }) + (boolOpt [] []) + + ,option "" ["executable-stripping"] + "strip executables upon installation to reduce binary sizes" + configStripExes (\v flags -> flags { configStripExes = v }) + (boolOpt [] []) + + ,option "" ["configure-option"] + "Extra option for configure" + configConfigureArgs (\v flags -> flags { configConfigureArgs = v }) + (reqArg' "OPT" (\x -> [x]) id) + + ,option "" ["user-install"] + "doing a per-user installation" + configUserInstall (\v flags -> flags { configUserInstall = v }) + (boolOpt' ([],["user"]) ([], ["global"])) + + ,option "" ["package-db"] + "Use a specific package database (to satisfy dependencies and register in)" + configPackageDB (\v flags -> flags { configPackageDB = v }) + (reqArg' "PATH" (Flag . SpecificPackageDB) + (\f -> case f of + Flag (SpecificPackageDB db) -> [db] + _ -> [])) + + ,option "f" ["flags"] + "Force values for the given flags in Cabal conditionals in the .cabal file. E.g., --flags=\"debug -usebytestrings\" forces the flag \"debug\" to true and \"usebytestrings\" to false." + configConfigurationsFlags (\v flags -> flags { configConfigurationsFlags = v }) + (reqArg' "FLAGS" readFlagList showFlagList) + + ,option "" ["extra-include-dirs"] + "A list of directories to search for header files" + configExtraIncludeDirs (\v flags -> flags {configExtraIncludeDirs = v}) + (reqArg' "PATH" (\x -> [x]) id) + + ,option "" ["extra-lib-dirs"] + "A list of directories to search for external libraries" + configExtraLibDirs (\v flags -> flags {configExtraLibDirs = v}) + (reqArg' "PATH" (\x -> [x]) id) + ,option "" ["constraint"] + "A list of additional constraints on the dependencies." + configConstraints (\v flags -> flags { configConstraints = v}) + (reqArg "DEPENDENCY" + (readP_to_E (const "dependency expected") ((\x -> [x]) `fmap` parse)) + (map (\x -> display x))) + ,option "" ["tests"] + "dependency checking and compilation for test suites listed in the package description file." + configTests (\v flags -> flags { configTests = v }) + (boolOpt [] []) + ,option "" ["library-coverage"] + "build library and test suites with Haskell Program Coverage enabled. (GHC only)" + configLibCoverage (\v flags -> flags { configLibCoverage = v }) + (boolOpt [] []) + ] + where + readFlagList :: String -> FlagAssignment + readFlagList = map tagWithValue . words + where tagWithValue ('-':fname) = (FlagName (lowercase fname), False) + tagWithValue fname = (FlagName (lowercase fname), True) + + showFlagList :: FlagAssignment -> [String] + showFlagList fs = [ if not set then '-':fname else fname + | (FlagName fname, set) <- fs] + + liftInstallDirs = + liftOption configInstallDirs (\v flags -> flags { configInstallDirs = v }) + + reqPathTemplateArgFlag title _sf _lf d get set = + reqArgFlag title _sf _lf d + (fmap fromPathTemplate . get) (set . fmap toPathTemplate) + +installDirsOptions :: [OptionField (InstallDirs (Flag PathTemplate))] +installDirsOptions = + [ option "" ["prefix"] + "bake this prefix in preparation of installation" + prefix (\v flags -> flags { prefix = v }) + installDirArg + + , option "" ["bindir"] + "installation directory for executables" + bindir (\v flags -> flags { bindir = v }) + installDirArg + + , option "" ["libdir"] + "installation directory for libraries" + libdir (\v flags -> flags { libdir = v }) + installDirArg + + , option "" ["libsubdir"] + "subdirectory of libdir in which libs are installed" + libsubdir (\v flags -> flags { libsubdir = v }) + installDirArg + + , option "" ["libexecdir"] + "installation directory for program executables" + libexecdir (\v flags -> flags { libexecdir = v }) + installDirArg + + , option "" ["datadir"] + "installation directory for read-only data" + datadir (\v flags -> flags { datadir = v }) + installDirArg + + , option "" ["datasubdir"] + "subdirectory of datadir in which data files are installed" + datasubdir (\v flags -> flags { datasubdir = v }) + installDirArg + + , option "" ["docdir"] + "installation directory for documentation" + docdir (\v flags -> flags { docdir = v }) + installDirArg + + , option "" ["htmldir"] + "installation directory for HTML documentation" + htmldir (\v flags -> flags { htmldir = v }) + installDirArg + + , option "" ["haddockdir"] + "installation directory for haddock interfaces" + haddockdir (\v flags -> flags { haddockdir = v }) + installDirArg + ] + where + installDirArg _sf _lf d get set = + reqArgFlag "DIR" _sf _lf d + (fmap fromPathTemplate . get) (set . fmap toPathTemplate) + +emptyConfigFlags :: ConfigFlags +emptyConfigFlags = mempty + +instance Monoid ConfigFlags where + mempty = ConfigFlags { + configPrograms = error "FIXME: remove configPrograms", + configProgramPaths = mempty, + configProgramArgs = mempty, + configHcFlavor = mempty, + configHcPath = mempty, + configHcPkg = mempty, + configVanillaLib = mempty, + configProfLib = mempty, + configSharedLib = mempty, + configDynExe = mempty, + configProfExe = mempty, + configConfigureArgs = mempty, + configOptimization = mempty, + configProgPrefix = mempty, + configProgSuffix = mempty, + configInstallDirs = mempty, + configScratchDir = mempty, + configDistPref = mempty, + configVerbosity = mempty, + configUserInstall = mempty, + configPackageDB = mempty, + configGHCiLib = mempty, + configSplitObjs = mempty, + configStripExes = mempty, + configExtraLibDirs = mempty, + configConstraints = mempty, + configExtraIncludeDirs = mempty, + configConfigurationsFlags = mempty, + configTests = mempty, + configLibCoverage = mempty + } + mappend a b = ConfigFlags { + configPrograms = configPrograms b, + configProgramPaths = combine configProgramPaths, + configProgramArgs = combine configProgramArgs, + configHcFlavor = combine configHcFlavor, + configHcPath = combine configHcPath, + configHcPkg = combine configHcPkg, + configVanillaLib = combine configVanillaLib, + configProfLib = combine configProfLib, + configSharedLib = combine configSharedLib, + configDynExe = combine configDynExe, + configProfExe = combine configProfExe, + configConfigureArgs = combine configConfigureArgs, + configOptimization = combine configOptimization, + configProgPrefix = combine configProgPrefix, + configProgSuffix = combine configProgSuffix, + configInstallDirs = combine configInstallDirs, + configScratchDir = combine configScratchDir, + configDistPref = combine configDistPref, + configVerbosity = combine configVerbosity, + configUserInstall = combine configUserInstall, + configPackageDB = combine configPackageDB, + configGHCiLib = combine configGHCiLib, + configSplitObjs = combine configSplitObjs, + configStripExes = combine configStripExes, + configExtraLibDirs = combine configExtraLibDirs, + configConstraints = combine configConstraints, + configExtraIncludeDirs = combine configExtraIncludeDirs, + configConfigurationsFlags = combine configConfigurationsFlags, + configTests = combine configTests, + configLibCoverage = combine configLibCoverage + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * Copy flags +-- ------------------------------------------------------------ + +-- | Flags to @copy@: (destdir, copy-prefix (backwards compat), verbosity) +data CopyFlags = CopyFlags { + copyDest :: Flag CopyDest, + copyDistPref :: Flag FilePath, + copyVerbosity :: Flag Verbosity + } + deriving Show + +defaultCopyFlags :: CopyFlags +defaultCopyFlags = CopyFlags { + copyDest = Flag NoCopyDest, + copyDistPref = Flag defaultDistPref, + copyVerbosity = Flag normal + } + +copyCommand :: CommandUI CopyFlags +copyCommand = makeCommand name shortDesc longDesc defaultCopyFlags options + where + name = "copy" + shortDesc = "Copy the files into the install locations." + longDesc = Just $ \_ -> + "Does not call register, and allows a prefix at install time\n" + ++ "Without the --destdir flag, configure determines location.\n" + options showOrParseArgs = + [optionVerbosity copyVerbosity (\v flags -> flags { copyVerbosity = v }) + + ,optionDistPref + copyDistPref (\d flags -> flags { copyDistPref = d }) + showOrParseArgs + + ,option "" ["destdir"] + "directory to copy files to, prepended to installation directories" + copyDest (\v flags -> flags { copyDest = v }) + (reqArg "DIR" (succeedReadE (Flag . CopyTo)) + (\f -> case f of Flag (CopyTo p) -> [p]; _ -> [])) + ] + +emptyCopyFlags :: CopyFlags +emptyCopyFlags = mempty + +instance Monoid CopyFlags where + mempty = CopyFlags { + copyDest = mempty, + copyDistPref = mempty, + copyVerbosity = mempty + } + mappend a b = CopyFlags { + copyDest = combine copyDest, + copyDistPref = combine copyDistPref, + copyVerbosity = combine copyVerbosity + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * Install flags +-- ------------------------------------------------------------ + +-- | Flags to @install@: (package db, verbosity) +data InstallFlags = InstallFlags { + installPackageDB :: Flag PackageDB, + installDistPref :: Flag FilePath, + installUseWrapper :: Flag Bool, + installInPlace :: Flag Bool, + installVerbosity :: Flag Verbosity + } + deriving Show + +defaultInstallFlags :: InstallFlags +defaultInstallFlags = InstallFlags { + installPackageDB = NoFlag, + installDistPref = Flag defaultDistPref, + installUseWrapper = Flag False, + installInPlace = Flag False, + installVerbosity = Flag normal + } + +installCommand :: CommandUI InstallFlags +installCommand = makeCommand name shortDesc longDesc defaultInstallFlags options + where + name = "install" + shortDesc = "Copy the files into the install locations. Run register." + longDesc = Just $ \_ -> + "Unlike the copy command, install calls the register command.\n" + ++ "If you want to install into a location that is not what was\n" + ++ "specified in the configure step, use the copy command.\n" + options showOrParseArgs = + [optionVerbosity installVerbosity (\v flags -> flags { installVerbosity = v }) + ,optionDistPref + installDistPref (\d flags -> flags { installDistPref = d }) + showOrParseArgs + + ,option "" ["inplace"] + "install the package in the install subdirectory of the dist prefix, so it can be used without being installed" + installInPlace (\v flags -> flags { installInPlace = v }) + trueArg + + ,option "" ["shell-wrappers"] + "using shell script wrappers around executables" + installUseWrapper (\v flags -> flags { installUseWrapper = v }) + (boolOpt [] []) + + ,option "" ["package-db"] "" + installPackageDB (\v flags -> flags { installPackageDB = v }) + (choiceOpt [ (Flag UserPackageDB, ([],["user"]), + "upon configuration register this package in the user's local package database") + , (Flag GlobalPackageDB, ([],["global"]), + "(default) upon configuration register this package in the system-wide package database")]) + ] + +emptyInstallFlags :: InstallFlags +emptyInstallFlags = mempty + +instance Monoid InstallFlags where + mempty = InstallFlags{ + installPackageDB = mempty, + installDistPref = mempty, + installUseWrapper = mempty, + installInPlace = mempty, + installVerbosity = mempty + } + mappend a b = InstallFlags{ + installPackageDB = combine installPackageDB, + installDistPref = combine installDistPref, + installUseWrapper = combine installUseWrapper, + installInPlace = combine installInPlace, + installVerbosity = combine installVerbosity + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * SDist flags +-- ------------------------------------------------------------ + +-- | Flags to @sdist@: (snapshot, verbosity) +data SDistFlags = SDistFlags { + sDistSnapshot :: Flag Bool, + sDistDirectory :: Flag FilePath, + sDistDistPref :: Flag FilePath, + sDistVerbosity :: Flag Verbosity + } + deriving Show + +defaultSDistFlags :: SDistFlags +defaultSDistFlags = SDistFlags { + sDistSnapshot = Flag False, + sDistDirectory = mempty, + sDistDistPref = Flag defaultDistPref, + sDistVerbosity = Flag normal + } + +sdistCommand :: CommandUI SDistFlags +sdistCommand = makeCommand name shortDesc longDesc defaultSDistFlags options + where + name = "sdist" + shortDesc = "Generate a source distribution file (.tar.gz)." + longDesc = Nothing + options showOrParseArgs = + [optionVerbosity sDistVerbosity (\v flags -> flags { sDistVerbosity = v }) + ,optionDistPref + sDistDistPref (\d flags -> flags { sDistDistPref = d }) + showOrParseArgs + + ,option "" ["snapshot"] + "Produce a snapshot source distribution" + sDistSnapshot (\v flags -> flags { sDistSnapshot = v }) + trueArg + + ,option "" ["output-directory"] + "Generate a source distribution in the given directory" + sDistDirectory (\v flags -> flags { sDistDirectory = v }) + (reqArgFlag "DIR") + ] + +emptySDistFlags :: SDistFlags +emptySDistFlags = mempty + +instance Monoid SDistFlags where + mempty = SDistFlags { + sDistSnapshot = mempty, + sDistDirectory = mempty, + sDistDistPref = mempty, + sDistVerbosity = mempty + } + mappend a b = SDistFlags { + sDistSnapshot = combine sDistSnapshot, + sDistDirectory = combine sDistDirectory, + sDistDistPref = combine sDistDistPref, + sDistVerbosity = combine sDistVerbosity + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * Register flags +-- ------------------------------------------------------------ + +-- | Flags to @register@ and @unregister@: (user package, gen-script, +-- in-place, verbosity) +data RegisterFlags = RegisterFlags { + regPackageDB :: Flag PackageDB, + regGenScript :: Flag Bool, + regGenPkgConf :: Flag (Maybe FilePath), + regInPlace :: Flag Bool, + regDistPref :: Flag FilePath, + regVerbosity :: Flag Verbosity + } + deriving Show + +defaultRegisterFlags :: RegisterFlags +defaultRegisterFlags = RegisterFlags { + regPackageDB = NoFlag, + regGenScript = Flag False, + regGenPkgConf = NoFlag, + regInPlace = Flag False, + regDistPref = Flag defaultDistPref, + regVerbosity = Flag normal + } + +registerCommand :: CommandUI RegisterFlags +registerCommand = makeCommand name shortDesc longDesc defaultRegisterFlags options + where + name = "register" + shortDesc = "Register this package with the compiler." + longDesc = Nothing + options showOrParseArgs = + [optionVerbosity regVerbosity (\v flags -> flags { regVerbosity = v }) + ,optionDistPref + regDistPref (\d flags -> flags { regDistPref = d }) + showOrParseArgs + + ,option "" ["packageDB"] "" + regPackageDB (\v flags -> flags { regPackageDB = v }) + (choiceOpt [ (Flag UserPackageDB, ([],["user"]), + "upon registration, register this package in the user's local package database") + , (Flag GlobalPackageDB, ([],["global"]), + "(default)upon registration, register this package in the system-wide package database")]) + + ,option "" ["inplace"] + "register the package in the build location, so it can be used without being installed" + regInPlace (\v flags -> flags { regInPlace = v }) + trueArg + + ,option "" ["gen-script"] + "instead of registering, generate a script to register later" + regGenScript (\v flags -> flags { regGenScript = v }) + trueArg + + ,option "" ["gen-pkg-config"] + "instead of registering, generate a package registration file" + regGenPkgConf (\v flags -> flags { regGenPkgConf = v }) + (optArg' "PKG" Flag flagToList) + ] + +unregisterCommand :: CommandUI RegisterFlags +unregisterCommand = makeCommand name shortDesc longDesc defaultRegisterFlags options + where + name = "unregister" + shortDesc = "Unregister this package with the compiler." + longDesc = Nothing + options showOrParseArgs = + [optionVerbosity regVerbosity (\v flags -> flags { regVerbosity = v }) + ,optionDistPref + regDistPref (\d flags -> flags { regDistPref = d }) + showOrParseArgs + + ,option "" ["user"] "" + regPackageDB (\v flags -> flags { regPackageDB = v }) + (choiceOpt [ (Flag UserPackageDB, ([],["user"]), + "unregister this package in the user's local package database") + , (Flag GlobalPackageDB, ([],["global"]), + "(default) unregister this package in the system-wide package database")]) + + ,option "" ["gen-script"] + "Instead of performing the unregister command, generate a script to unregister later" + regGenScript (\v flags -> flags { regGenScript = v }) + trueArg + ] + +emptyRegisterFlags :: RegisterFlags +emptyRegisterFlags = mempty + +instance Monoid RegisterFlags where + mempty = RegisterFlags { + regPackageDB = mempty, + regGenScript = mempty, + regGenPkgConf = mempty, + regInPlace = mempty, + regDistPref = mempty, + regVerbosity = mempty + } + mappend a b = RegisterFlags { + regPackageDB = combine regPackageDB, + regGenScript = combine regGenScript, + regGenPkgConf = combine regGenPkgConf, + regInPlace = combine regInPlace, + regDistPref = combine regDistPref, + regVerbosity = combine regVerbosity + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * HsColour flags +-- ------------------------------------------------------------ + +data HscolourFlags = HscolourFlags { + hscolourCSS :: Flag FilePath, + hscolourExecutables :: Flag Bool, + hscolourDistPref :: Flag FilePath, + hscolourVerbosity :: Flag Verbosity + } + deriving Show + +emptyHscolourFlags :: HscolourFlags +emptyHscolourFlags = mempty + +defaultHscolourFlags :: HscolourFlags +defaultHscolourFlags = HscolourFlags { + hscolourCSS = NoFlag, + hscolourExecutables = Flag False, + hscolourDistPref = Flag defaultDistPref, + hscolourVerbosity = Flag normal + } + +instance Monoid HscolourFlags where + mempty = HscolourFlags { + hscolourCSS = mempty, + hscolourExecutables = mempty, + hscolourDistPref = mempty, + hscolourVerbosity = mempty + } + mappend a b = HscolourFlags { + hscolourCSS = combine hscolourCSS, + hscolourExecutables = combine hscolourExecutables, + hscolourDistPref = combine hscolourDistPref, + hscolourVerbosity = combine hscolourVerbosity + } + where combine field = field a `mappend` field b + +hscolourCommand :: CommandUI HscolourFlags +hscolourCommand = makeCommand name shortDesc longDesc defaultHscolourFlags options + where + name = "hscolour" + shortDesc = "Generate HsColour colourised code, in HTML format." + longDesc = Just (\_ -> "Requires hscolour.\n") + options showOrParseArgs = + [optionVerbosity hscolourVerbosity (\v flags -> flags { hscolourVerbosity = v }) + ,optionDistPref + hscolourDistPref (\d flags -> flags { hscolourDistPref = d }) + showOrParseArgs + + ,option "" ["executables"] + "Run hscolour for Executables targets" + hscolourExecutables (\v flags -> flags { hscolourExecutables = v }) + trueArg + + ,option "" ["css"] + "Use a cascading style sheet" + hscolourCSS (\v flags -> flags { hscolourCSS = v }) + (reqArgFlag "PATH") + ] + +-- ------------------------------------------------------------ +-- * Haddock flags +-- ------------------------------------------------------------ + +data HaddockFlags = HaddockFlags { + haddockProgramPaths :: [(String, FilePath)], + haddockProgramArgs :: [(String, [String])], + haddockHoogle :: Flag Bool, + haddockHtml :: Flag Bool, + haddockHtmlLocation :: Flag String, + haddockExecutables :: Flag Bool, + haddockInternal :: Flag Bool, + haddockCss :: Flag FilePath, + haddockHscolour :: Flag Bool, + haddockHscolourCss :: Flag FilePath, + haddockDistPref :: Flag FilePath, + haddockVerbosity :: Flag Verbosity + } + deriving Show + +defaultHaddockFlags :: HaddockFlags +defaultHaddockFlags = HaddockFlags { + haddockProgramPaths = mempty, + haddockProgramArgs = [], + haddockHoogle = Flag False, + haddockHtml = Flag False, + haddockHtmlLocation = NoFlag, + haddockExecutables = Flag False, + haddockInternal = Flag False, + haddockCss = NoFlag, + haddockHscolour = Flag False, + haddockHscolourCss = NoFlag, + haddockDistPref = Flag defaultDistPref, + haddockVerbosity = Flag normal + } + +haddockCommand :: CommandUI HaddockFlags +haddockCommand = makeCommand name shortDesc longDesc defaultHaddockFlags options + where + name = "haddock" + shortDesc = "Generate Haddock HTML documentation." + longDesc = Just $ \_ -> "Requires the program haddock, either version 0.x or 2.x.\n" + options showOrParseArgs = + [optionVerbosity haddockVerbosity (\v flags -> flags { haddockVerbosity = v }) + ,optionDistPref + haddockDistPref (\d flags -> flags { haddockDistPref = d }) + showOrParseArgs + + ,option "" ["hoogle"] + "Generate a hoogle database" + haddockHoogle (\v flags -> flags { haddockHoogle = v }) + trueArg + + ,option "" ["html"] + "Generate HTML documentation (the default)" + haddockHtml (\v flags -> flags { haddockHtml = v }) + trueArg + + ,option "" ["html-location"] + "Location of HTML documentation for pre-requisite packages" + haddockHtmlLocation (\v flags -> flags { haddockHtmlLocation = v }) + (reqArgFlag "URL") + + ,option "" ["executables"] + "Run haddock for Executables targets" + haddockExecutables (\v flags -> flags { haddockExecutables = v }) + trueArg + + ,option "" ["internal"] + "Run haddock for internal modules and include all symbols" + haddockInternal (\v flags -> flags { haddockInternal = v }) + trueArg + + ,option "" ["css"] + "Use PATH as the haddock stylesheet" + haddockCss (\v flags -> flags { haddockCss = v }) + (reqArgFlag "PATH") + + ,option "" ["hyperlink-source","hyperlink-sources"] + "Hyperlink the documentation to the source code (using HsColour)" + haddockHscolour (\v flags -> flags { haddockHscolour = v }) + trueArg + + ,option "" ["hscolour-css"] + "Use PATH as the HsColour stylesheet" + haddockHscolourCss (\v flags -> flags { haddockHscolourCss = v }) + (reqArgFlag "PATH") + ] + ++ programConfigurationPaths progConf ParseArgs + haddockProgramPaths (\v flags -> flags { haddockProgramPaths = v}) + ++ programConfigurationOptions progConf ParseArgs + haddockProgramArgs (\v flags -> flags { haddockProgramArgs = v}) + progConf = addKnownProgram haddockProgram + $ addKnownProgram ghcProgram + $ emptyProgramConfiguration + +emptyHaddockFlags :: HaddockFlags +emptyHaddockFlags = mempty + +instance Monoid HaddockFlags where + mempty = HaddockFlags { + haddockProgramPaths = mempty, + haddockProgramArgs = mempty, + haddockHoogle = mempty, + haddockHtml = mempty, + haddockHtmlLocation = mempty, + haddockExecutables = mempty, + haddockInternal = mempty, + haddockCss = mempty, + haddockHscolour = mempty, + haddockHscolourCss = mempty, + haddockDistPref = mempty, + haddockVerbosity = mempty + } + mappend a b = HaddockFlags { + haddockProgramPaths = combine haddockProgramPaths, + haddockProgramArgs = combine haddockProgramArgs, + haddockHoogle = combine haddockHoogle, + haddockHtml = combine haddockHoogle, + haddockHtmlLocation = combine haddockHtmlLocation, + haddockExecutables = combine haddockExecutables, + haddockInternal = combine haddockInternal, + haddockCss = combine haddockCss, + haddockHscolour = combine haddockHscolour, + haddockHscolourCss = combine haddockHscolourCss, + haddockDistPref = combine haddockDistPref, + haddockVerbosity = combine haddockVerbosity + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * Clean flags +-- ------------------------------------------------------------ + +data CleanFlags = CleanFlags { + cleanSaveConf :: Flag Bool, + cleanDistPref :: Flag FilePath, + cleanVerbosity :: Flag Verbosity + } + deriving Show + +defaultCleanFlags :: CleanFlags +defaultCleanFlags = CleanFlags { + cleanSaveConf = Flag False, + cleanDistPref = Flag defaultDistPref, + cleanVerbosity = Flag normal + } + +cleanCommand :: CommandUI CleanFlags +cleanCommand = makeCommand name shortDesc longDesc defaultCleanFlags options + where + name = "clean" + shortDesc = "Clean up after a build." + longDesc = Just (\_ -> "Removes .hi, .o, preprocessed sources, etc.\n") + options showOrParseArgs = + [optionVerbosity cleanVerbosity (\v flags -> flags { cleanVerbosity = v }) + ,optionDistPref + cleanDistPref (\d flags -> flags { cleanDistPref = d }) + showOrParseArgs + + ,option "s" ["save-configure"] + "Do not remove the configuration file (dist/setup-config) during cleaning. Saves need to reconfigure." + cleanSaveConf (\v flags -> flags { cleanSaveConf = v }) + trueArg + ] + +emptyCleanFlags :: CleanFlags +emptyCleanFlags = mempty + +instance Monoid CleanFlags where + mempty = CleanFlags { + cleanSaveConf = mempty, + cleanDistPref = mempty, + cleanVerbosity = mempty + } + mappend a b = CleanFlags { + cleanSaveConf = combine cleanSaveConf, + cleanDistPref = combine cleanDistPref, + cleanVerbosity = combine cleanVerbosity + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * Build flags +-- ------------------------------------------------------------ + +data BuildFlags = BuildFlags { + buildProgramPaths :: [(String, FilePath)], + buildProgramArgs :: [(String, [String])], + buildDistPref :: Flag FilePath, + buildVerbosity :: Flag Verbosity + } + deriving Show + +{-# DEPRECATED buildVerbose "Use buildVerbosity instead" #-} +buildVerbose :: BuildFlags -> Verbosity +buildVerbose = fromFlagOrDefault normal . buildVerbosity + +defaultBuildFlags :: BuildFlags +defaultBuildFlags = BuildFlags { + buildProgramPaths = mempty, + buildProgramArgs = [], + buildDistPref = Flag defaultDistPref, + buildVerbosity = Flag normal + } + +buildCommand :: ProgramConfiguration -> CommandUI BuildFlags +buildCommand progConf = makeCommand name shortDesc longDesc defaultBuildFlags options + where + name = "build" + shortDesc = "Make this package ready for installation." + longDesc = Nothing + options showOrParseArgs = + optionVerbosity buildVerbosity (\v flags -> flags { buildVerbosity = v }) + : optionDistPref + buildDistPref (\d flags -> flags { buildDistPref = d }) + showOrParseArgs + + : programConfigurationPaths progConf showOrParseArgs + buildProgramPaths (\v flags -> flags { buildProgramPaths = v}) + + ++ programConfigurationOptions progConf showOrParseArgs + buildProgramArgs (\v flags -> flags { buildProgramArgs = v}) + +emptyBuildFlags :: BuildFlags +emptyBuildFlags = mempty + +instance Monoid BuildFlags where + mempty = BuildFlags { + buildProgramPaths = mempty, + buildProgramArgs = mempty, + buildVerbosity = mempty, + buildDistPref = mempty + } + mappend a b = BuildFlags { + buildProgramPaths = combine buildProgramPaths, + buildProgramArgs = combine buildProgramArgs, + buildVerbosity = combine buildVerbosity, + buildDistPref = combine buildDistPref + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * Test flags +-- ------------------------------------------------------------ + +data TestShowDetails = Never | Failures | Always + deriving (Eq, Ord, Enum, Bounded, Show) + +knownTestShowDetails :: [TestShowDetails] +knownTestShowDetails = [minBound..maxBound] + +instance Text TestShowDetails where + disp = Disp.text . lowercase . show + + parse = maybe Parse.pfail return . classify =<< ident + where + ident = Parse.munch1 (\c -> isAlpha c || c == '_' || c == '-') + classify str = lookup (lowercase str) enumMap + enumMap :: [(String, TestShowDetails)] + enumMap = [ (display x, x) + | x <- knownTestShowDetails ] + +--TODO: do we need this instance? +instance Monoid TestShowDetails where + mempty = Never + mappend a b = if a < b then b else a + +data TestFlags = TestFlags { + testDistPref :: Flag FilePath, + testVerbosity :: Flag Verbosity, + testHumanLog :: Flag PathTemplate, + testMachineLog :: Flag PathTemplate, + testShowDetails :: Flag TestShowDetails, + testKeepTix :: Flag Bool, + --TODO: eliminate the test list and pass it directly as positional args to the testHook + testList :: Flag [String], + -- TODO: think about if/how options are passed to test exes + testOptions :: Flag [PathTemplate] + } + +defaultTestFlags :: TestFlags +defaultTestFlags = TestFlags { + testDistPref = Flag defaultDistPref, + testVerbosity = Flag normal, + testHumanLog = toFlag $ toPathTemplate $ "$pkgid-$test-suite.log", + testMachineLog = toFlag $ toPathTemplate $ "$pkgid.log", + testShowDetails = toFlag Failures, + testKeepTix = toFlag False, + testList = Flag [], + testOptions = Flag [] + } + +testCommand :: CommandUI TestFlags +testCommand = makeCommand name shortDesc longDesc defaultTestFlags options + where + name = "test" + shortDesc = "Run the test suite, if any (configure with UserHooks)." + longDesc = Nothing + options showOrParseArgs = + [ optionVerbosity testVerbosity (\v flags -> flags { testVerbosity = v }) + , optionDistPref + testDistPref (\d flags -> flags { testDistPref = d }) + showOrParseArgs + , option [] ["log"] + ("Log all test suite results to file (name template can use " + ++ "$pkgid, $compiler, $os, $arch, $test-suite, $result)") + testHumanLog (\v flags -> flags { testHumanLog = v }) + (reqArg' "TEMPLATE" + (toFlag . toPathTemplate) + (flagToList . fmap fromPathTemplate)) + , option [] ["machine-log"] + ("Produce a machine-readable log file (name template can use " + ++ "$pkgid, $compiler, $os, $arch, $result)") + testMachineLog (\v flags -> flags { testMachineLog = v }) + (reqArg' "TEMPLATE" + (toFlag . toPathTemplate) + (flagToList . fmap fromPathTemplate)) + , option [] ["show-details"] + ("'always': always show results of individual test cases. " + ++ "'never': never show results of individual test cases. " + ++ "'failures': show results of failing test cases.") + testShowDetails (\v flags -> flags { testShowDetails = v }) + (reqArg "FILTER" + (readP_to_E (\_ -> "--show-details flag expects one of " + ++ intercalate ", " + (map display knownTestShowDetails)) + (fmap toFlag parse)) + (flagToList . fmap display)) + , option [] ["keep-tix-files"] + "keep .tix files for HPC between test runs" + testKeepTix (\v flags -> flags { testKeepTix = v}) + trueArg + , option [] ["test-options"] + ("give extra options to test executables " + ++ "(name templates can use $pkgid, $compiler, " + ++ "$os, $arch, $test-suite)") + testOptions (\v flags -> flags { testOptions = v }) + (reqArg' "TEMPLATES" (toFlag . map toPathTemplate . splitArgs) + (map fromPathTemplate . fromFlagOrDefault [])) + , option [] ["test-option"] + ("give extra option to test executables " + ++ "(no need to quote options containing spaces, " + ++ "name template can use $pkgid, $compiler, " + ++ "$os, $arch, $test-suite)") + testOptions (\v flags -> flags { testOptions = v }) + (reqArg' "TEMPLATE" (\x -> toFlag [toPathTemplate x]) + (map fromPathTemplate . fromFlagOrDefault [])) + ] + +emptyTestFlags :: TestFlags +emptyTestFlags = mempty + +instance Monoid TestFlags where + mempty = TestFlags { + testDistPref = mempty, + testVerbosity = mempty, + testHumanLog = mempty, + testMachineLog = mempty, + testShowDetails = mempty, + testKeepTix = mempty, + testList = mempty, + testOptions = mempty + } + mappend a b = TestFlags { + testDistPref = combine testDistPref, + testVerbosity = combine testVerbosity, + testHumanLog = combine testHumanLog, + testMachineLog = combine testMachineLog, + testShowDetails = combine testShowDetails, + testKeepTix = combine testKeepTix, + testList = combine testList, + testOptions = combine testOptions + } + where combine field = field a `mappend` field b + +-- ------------------------------------------------------------ +-- * Shared options utils +-- ------------------------------------------------------------ + +programFlagsDescription :: ProgramConfiguration -> String +programFlagsDescription progConf = + "The flags --with-PROG and --PROG-option(s) can be used with" + ++ " the following programs:" + ++ (concatMap (\line -> "\n " ++ unwords line) . wrapLine 77 . sort) + [ programName prog | (prog, _) <- knownPrograms progConf ] + ++ "\n" + +programConfigurationPaths + :: ProgramConfiguration + -> ShowOrParseArgs + -> (flags -> [(String, FilePath)]) + -> ([(String, FilePath)] -> (flags -> flags)) + -> [OptionField flags] +programConfigurationPaths progConf showOrParseArgs get set = + case showOrParseArgs of + -- we don't want a verbose help text list so we just show a generic one: + ShowArgs -> [withProgramPath "PROG"] + ParseArgs -> map (withProgramPath . programName . fst) (knownPrograms progConf) + where + withProgramPath prog = + option "" ["with-" ++ prog] + ("give the path to " ++ prog) + get set + (reqArg' "PATH" (\path -> [(prog, path)]) + (\progPaths -> [ path | (prog', path) <- progPaths, prog==prog' ])) + +programConfigurationOptions + :: ProgramConfiguration + -> ShowOrParseArgs + -> (flags -> [(String, [String])]) + -> ([(String, [String])] -> (flags -> flags)) + -> [OptionField flags] +programConfigurationOptions progConf showOrParseArgs get set = + case showOrParseArgs of + -- we don't want a verbose help text list so we just show a generic one: + ShowArgs -> [programOptions "PROG", programOption "PROG"] + ParseArgs -> map (programOptions . programName . fst) (knownPrograms progConf) + ++ map (programOption . programName . fst) (knownPrograms progConf) + where + programOptions prog = + option "" [prog ++ "-options"] + ("give extra options to " ++ prog) + get set + (reqArg' "OPTS" (\args -> [(prog, splitArgs args)]) (const [])) + + programOption prog = + option "" [prog ++ "-option"] + ("give an extra option to " ++ prog ++ + " (no need to quote options containing spaces)") + get set + (reqArg' "OPT" (\arg -> [(prog, [arg])]) + (\progArgs -> concat [ args | (prog', args) <- progArgs, prog==prog' ])) + + +-- ------------------------------------------------------------ +-- * GetOpt Utils +-- ------------------------------------------------------------ + +boolOpt :: SFlags -> SFlags -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a +boolOpt = Command.boolOpt flagToMaybe Flag + +boolOpt' :: OptFlags -> OptFlags -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a +boolOpt' = Command.boolOpt' flagToMaybe Flag + +trueArg, falseArg :: SFlags -> LFlags -> Description -> (b -> Flag Bool) -> + (Flag Bool -> (b -> b)) -> OptDescr b +trueArg = noArg (Flag True) +falseArg = noArg (Flag False) + +reqArgFlag :: ArgPlaceHolder -> SFlags -> LFlags -> Description -> + (b -> Flag String) -> (Flag String -> b -> b) -> OptDescr b +reqArgFlag ad = reqArg ad (succeedReadE Flag) flagToList + +optionDistPref :: (flags -> Flag FilePath) + -> (Flag FilePath -> flags -> flags) + -> ShowOrParseArgs + -> OptionField flags +optionDistPref get set = \showOrParseArgs -> + option "" (distPrefFlagName showOrParseArgs) + ( "The directory where Cabal puts generated build files " + ++ "(default " ++ defaultDistPref ++ ")") + get set + (reqArgFlag "DIR") + where + distPrefFlagName ShowArgs = ["builddir"] + distPrefFlagName ParseArgs = ["builddir", "distdir", "distpref"] + +optionVerbosity :: (flags -> Flag Verbosity) + -> (Flag Verbosity -> flags -> flags) + -> OptionField flags +optionVerbosity get set = + option "v" ["verbose"] + "Control verbosity (n is 0--3, default verbosity level is 1)" + get set + (optArg "n" (fmap Flag flagToVerbosity) + (Flag verbose) -- default Value if no n is given + (fmap (Just . showForCabal) . flagToList)) + +-- ------------------------------------------------------------ +-- * Other Utils +-- ------------------------------------------------------------ + +-- | Arguments to pass to a @configure@ script, e.g. generated by +-- @autoconf@. +configureArgs :: Bool -> ConfigFlags -> [String] +configureArgs bcHack flags + = hc_flag + ++ optFlag "with-hc-pkg" configHcPkg + ++ optFlag' "prefix" prefix + ++ optFlag' "bindir" bindir + ++ optFlag' "libdir" libdir + ++ optFlag' "libexecdir" libexecdir + ++ optFlag' "datadir" datadir + ++ configConfigureArgs flags + where + hc_flag = case (configHcFlavor flags, configHcPath flags) of + (_, Flag hc_path) -> [hc_flag_name ++ hc_path] + (Flag hc, NoFlag) -> [hc_flag_name ++ display hc] + (NoFlag,NoFlag) -> [] + hc_flag_name + --TODO kill off thic bc hack when defaultUserHooks is removed. + | bcHack = "--with-hc=" + | otherwise = "--with-compiler=" + optFlag name config_field = case config_field flags of + Flag p -> ["--" ++ name ++ "=" ++ p] + NoFlag -> [] + optFlag' name config_field = optFlag name (fmap fromPathTemplate + . config_field + . configInstallDirs) + +configureCCompiler :: Verbosity -> ProgramConfiguration -> IO (FilePath, [String]) +configureCCompiler verbosity lbi = configureProg verbosity lbi gccProgram + +configureLinker :: Verbosity -> ProgramConfiguration -> IO (FilePath, [String]) +configureLinker verbosity lbi = configureProg verbosity lbi ldProgram + +configureProg :: Verbosity -> ProgramConfiguration -> Program -> IO (FilePath, [String]) +configureProg verbosity programConfig prog = do + (p, _) <- requireProgram verbosity prog programConfig + let pInv = programInvocation p [] + return (progInvokePath pInv, progInvokeArgs pInv) + +-- | Helper function to split a string into a list of arguments. +-- It's supposed to handle quoted things sensibly, eg: +-- +-- > splitArgs "--foo=\"C:\Program Files\Bar\" --baz" +-- > = ["--foo=C:\Program Files\Bar", "--baz"] +-- +splitArgs :: String -> [String] +splitArgs = space [] + where + space :: String -> String -> [String] + space w [] = word w [] + space w ( c :s) + | isSpace c = word w (space [] s) + space w ('"':s) = string w s + space w s = nonstring w s + + string :: String -> String -> [String] + string w [] = word w [] + string w ('"':s) = space w s + string w ( c :s) = string (c:w) s + + nonstring :: String -> String -> [String] + nonstring w [] = word w [] + nonstring w ('"':s) = string w s + nonstring w ( c :s) = space (c:w) s + + word [] s = s + word w s = reverse w : s + +-- The test cases kinda have to be rewritten from the ground up... :/ +--hunitTests :: [Test] +--hunitTests = +-- let m = [("ghc", GHC), ("nhc98", NHC), ("hugs", Hugs)] +-- (flags, commands', unkFlags, ers) +-- = getOpt Permute options ["configure", "foobar", "--prefix=/foo", "--ghc", "--nhc98", "--hugs", "--with-compiler=/comp", "--unknown1", "--unknown2", "--install-prefix=/foo", "--user", "--global"] +-- in [TestLabel "very basic option parsing" $ TestList [ +-- "getOpt flags" ~: "failed" ~: +-- [Prefix "/foo", GhcFlag, NhcFlag, HugsFlag, +-- WithCompiler "/comp", InstPrefix "/foo", UserFlag, GlobalFlag] +-- ~=? flags, +-- "getOpt commands" ~: "failed" ~: ["configure", "foobar"] ~=? commands', +-- "getOpt unknown opts" ~: "failed" ~: +-- ["--unknown1", "--unknown2"] ~=? unkFlags, +-- "getOpt errors" ~: "failed" ~: [] ~=? ers], +-- +-- TestLabel "test location of various compilers" $ TestList +-- ["configure parsing for prefix and compiler flag" ~: "failed" ~: +-- (Right (ConfigCmd (Just comp, Nothing, Just "/usr/local"), [])) +-- ~=? (parseArgs ["--prefix=/usr/local", "--"++name, "configure"]) +-- | (name, comp) <- m], +-- +-- TestLabel "find the package tool" $ TestList +-- ["configure parsing for prefix comp flag, withcompiler" ~: "failed" ~: +-- (Right (ConfigCmd (Just comp, Just "/foo/comp", Just "/usr/local"), [])) +-- ~=? (parseArgs ["--prefix=/usr/local", "--"++name, +-- "--with-compiler=/foo/comp", "configure"]) +-- | (name, comp) <- m], +-- +-- TestLabel "simpler commands" $ TestList +-- [flag ~: "failed" ~: (Right (flagCmd, [])) ~=? (parseArgs [flag]) +-- | (flag, flagCmd) <- [("build", BuildCmd), +-- ("install", InstallCmd Nothing False), +-- ("sdist", SDistCmd), +-- ("register", RegisterCmd False)] +-- ] +-- ] + +{- Testing ideas: + * IO to look for hugs and hugs-pkg (which hugs, etc) + * quickCheck to test permutations of arguments + * what other options can we over-ride with a command-line flag? +-} diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/SrcDist.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/SrcDist.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/SrcDist.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/SrcDist.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,418 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.SrcDist +-- Copyright : Simon Marlow 2004 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This handles the @sdist@ command. The module exports an 'sdist' action but +-- also some of the phases that make it up so that other tools can use just the +-- bits they need. In particular the preparation of the tree of files to go +-- into the source tarball is separated from actually building the source +-- tarball. +-- +-- The 'createArchive' action uses the external @tar@ program and assumes that +-- it accepts the @-z@ flag. Neither of these assumptions are valid on Windows. +-- The 'sdist' action now also does some distribution QA checks. + +{- Copyright (c) 2003-2004, Simon Marlow +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +-- NOTE: FIX: we don't have a great way of testing this module, since +-- we can't easily look inside a tarball once its created. + +module Distribution.Simple.SrcDist ( + -- * The top level action + sdist, + + -- ** Parts of 'sdist' + printPackageProblems, + prepareTree, + createArchive, + + -- ** Snaphots + prepareSnapshotTree, + snapshotPackage, + snapshotVersion, + dateToSnapshotNumber, + ) where + +import Distribution.PackageDescription + ( PackageDescription(..), BuildInfo(..), Executable(..), Library(..) + , TestSuite(..), TestSuiteInterface(..) ) +import Distribution.PackageDescription.Check + ( PackageCheck(..), checkConfiguredPackage, checkPackageFiles ) +import Distribution.Package + ( PackageIdentifier(pkgVersion), Package(..), packageVersion ) +import Distribution.ModuleName (ModuleName) +import qualified Distribution.ModuleName as ModuleName +import Distribution.Version + ( Version(versionBranch) ) +import Distribution.Simple.Utils + ( createDirectoryIfMissingVerbose, withUTF8FileContents, writeUTF8File + , installOrdinaryFile, installOrdinaryFiles, setFileExecutable + , findFile, findFileWithExtension, matchFileGlob + , withTempDirectory, defaultPackageDesc + , die, warn, notice, setupMessage ) +import Distribution.Simple.Setup (SDistFlags(..), fromFlag, flagToMaybe) +import Distribution.Simple.PreProcess (PPSuffixHandler, ppSuffixes, preprocessComponent) +import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..), withComponentsLBI ) +import Distribution.Simple.BuildPaths ( autogenModuleName ) +import Distribution.Simple.Program ( defaultProgramConfiguration, requireProgram, + rawSystemProgram, tarProgram ) +import Distribution.Text + ( display ) + +import Control.Monad(when, unless) +import Data.Char (toLower) +import Data.List (partition, isPrefixOf) +import Data.Maybe (isNothing, catMaybes) +import System.Time (getClockTime, toCalendarTime, CalendarTime(..)) +import System.Directory + ( doesFileExist, Permissions(executable), getPermissions ) +import Distribution.Verbosity (Verbosity) +import System.FilePath + ( (), (<.>), takeDirectory, dropExtension, isAbsolute ) + +-- |Create a source distribution. +sdist :: PackageDescription -- ^information from the tarball + -> Maybe LocalBuildInfo -- ^Information from configure + -> SDistFlags -- ^verbosity & snapshot + -> (FilePath -> FilePath) -- ^build prefix (temp dir) + -> [PPSuffixHandler] -- ^ extra preprocessors (includes suffixes) + -> IO () +sdist pkg mb_lbi flags mkTmpDir pps = do + + -- do some QA + printPackageProblems verbosity pkg + + when (isNothing mb_lbi) $ + warn verbosity "Cannot run preprocessors. Run 'configure' command first." + + date <- toCalendarTime =<< getClockTime + let pkg' | snapshot = snapshotPackage date pkg + | otherwise = pkg + + case flagToMaybe (sDistDirectory flags) of + Just targetDir -> do + generateSourceDir targetDir pkg' + notice verbosity $ "Source directory created: " ++ targetDir + + Nothing -> do + createDirectoryIfMissingVerbose verbosity True tmpTargetDir + withTempDirectory verbosity tmpTargetDir "sdist." $ \tmpDir -> do + let targetDir = tmpDir tarBallName pkg' + generateSourceDir targetDir pkg' + targzFile <- createArchive verbosity pkg' mb_lbi tmpDir targetPref + notice verbosity $ "Source tarball created: " ++ targzFile + + where + generateSourceDir targetDir pkg' = do + + setupMessage verbosity "Building source dist for" (packageId pkg') + prepareTree verbosity pkg' mb_lbi distPref targetDir pps + when snapshot $ + overwriteSnapshotPackageDesc verbosity pkg' targetDir + + verbosity = fromFlag (sDistVerbosity flags) + snapshot = fromFlag (sDistSnapshot flags) + + distPref = fromFlag $ sDistDistPref flags + targetPref = distPref + tmpTargetDir = mkTmpDir distPref + + +-- |Prepare a directory tree of source files. +prepareTree :: Verbosity -- ^verbosity + -> PackageDescription -- ^info from the cabal file + -> Maybe LocalBuildInfo + -> FilePath -- ^dist dir + -> FilePath -- ^source tree to populate + -> [PPSuffixHandler] -- ^extra preprocessors (includes suffixes) + -> IO () +prepareTree verbosity pkg_descr0 mb_lbi distPref targetDir pps = do + createDirectoryIfMissingVerbose verbosity True targetDir + + -- maybe move the library files into place + withLib $ \Library { exposedModules = modules, libBuildInfo = libBi } -> + prepareDir verbosity pkg_descr distPref targetDir pps modules libBi + + -- move the executables into place + withExe $ \Executable { modulePath = mainPath, buildInfo = exeBi } -> do + prepareDir verbosity pkg_descr distPref targetDir pps [] exeBi + srcMainFile <- do + ppFile <- findFileWithExtension (ppSuffixes pps) (hsSourceDirs exeBi) (dropExtension mainPath) + case ppFile of + Nothing -> findFile (hsSourceDirs exeBi) mainPath + Just pp -> return pp + copyFileTo verbosity targetDir srcMainFile + + -- move the test suites into place + withTest $ \t -> do + let bi = testBuildInfo t + prep = prepareDir verbosity pkg_descr distPref targetDir pps + case testInterface t of + TestSuiteExeV10 _ mainPath -> do + prep [] bi + srcMainFile <- do + ppFile <- findFileWithExtension (ppSuffixes pps) + (hsSourceDirs bi) + (dropExtension mainPath) + case ppFile of + Nothing -> findFile (hsSourceDirs bi) mainPath + Just pp -> return pp + copyFileTo verbosity targetDir srcMainFile + TestSuiteLibV09 _ m -> do + prep [m] bi + TestSuiteUnsupported tp -> die $ "Unsupported test suite type: " ++ show tp + + flip mapM_ (dataFiles pkg_descr) $ \ filename -> do + files <- matchFileGlob (dataDir pkg_descr filename) + let dir = takeDirectory (dataDir pkg_descr filename) + createDirectoryIfMissingVerbose verbosity True (targetDir dir) + sequence_ [ installOrdinaryFile verbosity file (targetDir file) + | file <- files ] + + when (not (null (licenseFile pkg_descr))) $ + copyFileTo verbosity targetDir (licenseFile pkg_descr) + flip mapM_ (extraSrcFiles pkg_descr) $ \ fpath -> do + files <- matchFileGlob fpath + sequence_ + [ do copyFileTo verbosity targetDir file + -- preserve executable bit on extra-src-files like ./configure + perms <- getPermissions file + when (executable perms) --only checks user x bit + (setFileExecutable (targetDir file)) + | file <- files ] + + -- copy the install-include files + withLib $ \ l -> do + let lbi = libBuildInfo l + relincdirs = "." : filter (not.isAbsolute) (includeDirs lbi) + incs <- mapM (findInc relincdirs) (installIncludes lbi) + flip mapM_ incs $ \(_,fpath) -> + copyFileTo verbosity targetDir fpath + + -- if the package was configured then we can run platform independent + -- pre-processors and include those generated files + case mb_lbi of + Just lbi | not (null pps) -> do + let lbi' = lbi{ buildDir = targetDir buildDir lbi } + withComponentsLBI pkg_descr lbi' $ \c _ -> + preprocessComponent pkg_descr c lbi' True verbosity pps + _ -> return () + + -- setup isn't listed in the description file. + hsExists <- doesFileExist "Setup.hs" + lhsExists <- doesFileExist "Setup.lhs" + if hsExists then copyFileTo verbosity targetDir "Setup.hs" + else if lhsExists then copyFileTo verbosity targetDir "Setup.lhs" + else writeUTF8File (targetDir "Setup.hs") $ unlines [ + "import Distribution.Simple", + "main = defaultMain"] + -- the description file itself + descFile <- defaultPackageDesc verbosity + installOrdinaryFile verbosity descFile (targetDir descFile) + + where + pkg_descr = mapAllBuildInfo filterAutogenModule pkg_descr0 + filterAutogenModule bi = bi { + otherModules = filter (/=autogenModule) (otherModules bi) + } + autogenModule = autogenModuleName pkg_descr0 + + findInc [] f = die ("can't find include file " ++ f) + findInc (d:ds) f = do + let path = (d f) + b <- doesFileExist path + if b then return (f,path) else findInc ds f + + -- We have to deal with all libs and executables, so we have local + -- versions of these functions that ignore the 'buildable' attribute: + withLib action = maybe (return ()) action (library pkg_descr) + withExe action = mapM_ action (executables pkg_descr) + withTest action = mapM_ action (testSuites pkg_descr) + +-- | Prepare a directory tree of source files for a snapshot version. +-- It is expected that the appropriate snapshot version has already been set +-- in the package description, eg using 'snapshotPackage' or 'snapshotVersion'. +-- +prepareSnapshotTree :: Verbosity -- ^verbosity + -> PackageDescription -- ^info from the cabal file + -> Maybe LocalBuildInfo + -> FilePath -- ^dist dir + -> FilePath -- ^source tree to populate + -> [PPSuffixHandler] -- ^extra preprocessors (includes suffixes) + -> IO () +prepareSnapshotTree verbosity pkg mb_lbi distPref targetDir pps = do + prepareTree verbosity pkg mb_lbi distPref targetDir pps + overwriteSnapshotPackageDesc verbosity pkg targetDir + +overwriteSnapshotPackageDesc :: Verbosity -- ^verbosity + -> PackageDescription -- ^info from the cabal file + -> FilePath -- ^source tree + -> IO () +overwriteSnapshotPackageDesc verbosity pkg targetDir = do + -- We could just writePackageDescription targetDescFile pkg_descr, + -- but that would lose comments and formatting. + descFile <- defaultPackageDesc verbosity + withUTF8FileContents descFile $ + writeUTF8File (targetDir descFile) + . unlines . map (replaceVersion (packageVersion pkg)) . lines + + where + replaceVersion :: Version -> String -> String + replaceVersion version line + | "version:" `isPrefixOf` map toLower line + = "version: " ++ display version + | otherwise = line + +-- | Modifies a 'PackageDescription' by appending a snapshot number +-- corresponding to the given date. +-- +snapshotPackage :: CalendarTime -> PackageDescription -> PackageDescription +snapshotPackage date pkg = + pkg { + package = pkgid { pkgVersion = snapshotVersion date (pkgVersion pkgid) } + } + where pkgid = packageId pkg + +-- | Modifies a 'Version' by appending a snapshot number corresponding +-- to the given date. +-- +snapshotVersion :: CalendarTime -> Version -> Version +snapshotVersion date version = version { + versionBranch = versionBranch version + ++ [dateToSnapshotNumber date] + } + +-- | Given a date produce a corresponding integer representation. +-- For example given a date @18/03/2008@ produce the number @20080318@. +-- +dateToSnapshotNumber :: CalendarTime -> Int +dateToSnapshotNumber date = year * 10000 + + month * 100 + + day + where + year = ctYear date + month = fromEnum (ctMonth date) + 1 + day = ctDay date + +-- |Create an archive from a tree of source files, and clean up the tree. +createArchive :: Verbosity -- ^verbosity + -> PackageDescription -- ^info from cabal file + -> Maybe LocalBuildInfo -- ^info from configure + -> FilePath -- ^source tree to archive + -> FilePath -- ^name of archive to create + -> IO FilePath + +createArchive verbosity pkg_descr mb_lbi tmpDir targetPref = do + let tarBallFilePath = targetPref tarBallName pkg_descr <.> "tar.gz" + + (tarProg, _) <- requireProgram verbosity tarProgram + (maybe defaultProgramConfiguration withPrograms mb_lbi) + + -- Hmm: I could well be skating on thinner ice here by using the -C option (=> GNU tar-specific?) + -- [The prev. solution used pipes and sub-command sequences to set up the paths correctly, + -- which is problematic in a Windows setting.] + rawSystemProgram verbosity tarProg + ["-C", tmpDir, "-czf", tarBallFilePath, tarBallName pkg_descr] + return tarBallFilePath + +-- |Move the sources into place based on buildInfo +prepareDir :: Verbosity -- ^verbosity + -> PackageDescription -- ^info from the cabal file + -> FilePath -- ^dist dir + -> FilePath -- ^TargetPrefix + -> [PPSuffixHandler] -- ^ extra preprocessors (includes suffixes) + -> [ModuleName] -- ^Exposed modules + -> BuildInfo + -> IO () +prepareDir verbosity _pkg _distPref inPref pps modules bi + = do let searchDirs = hsSourceDirs bi + sources <- sequence + [ let file = ModuleName.toFilePath module_ + in findFileWithExtension suffixes searchDirs file + >>= maybe (notFound module_) return + | module_ <- modules ++ otherModules bi ] + bootFiles <- sequence + [ let file = ModuleName.toFilePath module_ + fileExts = ["hs-boot", "lhs-boot"] + in findFileWithExtension fileExts (hsSourceDirs bi) file + | module_ <- modules ++ otherModules bi ] + + let allSources = sources ++ catMaybes bootFiles ++ cSources bi + installOrdinaryFiles verbosity inPref (zip (repeat []) allSources) + + where suffixes = ppSuffixes pps ++ ["hs", "lhs"] + notFound m = die $ "Error: Could not find module: " ++ display m + ++ " with any suffix: " ++ show suffixes + +copyFileTo :: Verbosity -> FilePath -> FilePath -> IO () +copyFileTo verbosity dir file = do + let targetFile = dir file + createDirectoryIfMissingVerbose verbosity True (takeDirectory targetFile) + installOrdinaryFile verbosity file targetFile + +printPackageProblems :: Verbosity -> PackageDescription -> IO () +printPackageProblems verbosity pkg_descr = do + ioChecks <- checkPackageFiles pkg_descr "." + let pureChecks = checkConfiguredPackage pkg_descr + isDistError (PackageDistSuspicious _) = False + isDistError _ = True + (errors, warnings) = partition isDistError (pureChecks ++ ioChecks) + unless (null errors) $ + notice verbosity $ "Distribution quality errors:\n" + ++ unlines (map explanation errors) + unless (null warnings) $ + notice verbosity $ "Distribution quality warnings:\n" + ++ unlines (map explanation warnings) + unless (null errors) $ + notice verbosity + "Note: the public hackage server would reject this package." + +------------------------------------------------------------ + +-- | The name of the tarball without extension +-- +tarBallName :: PackageDescription -> String +tarBallName = display . packageId + +mapAllBuildInfo :: (BuildInfo -> BuildInfo) + -> (PackageDescription -> PackageDescription) +mapAllBuildInfo f pkg = pkg { + library = fmap mapLibBi (library pkg), + executables = fmap mapExeBi (executables pkg) + } + where + mapLibBi lib = lib { libBuildInfo = f (libBuildInfo lib) } + mapExeBi exe = exe { buildInfo = f (buildInfo exe) } diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/Test.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/Test.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/Test.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/Test.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,486 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Test +-- Copyright : Thomas Tuegel 2010 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is the entry point into testing a built package. It performs the +-- \"@.\/setup test@\" action. It runs test suites designated in the package +-- description and reports on the results. + +{- All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.Simple.Test + ( test + , runTests + , writeSimpleTestStub + , stubFilePath + , stubName + , PackageLog(..) + , TestSuiteLog(..) + , Case(..) + , suitePassed, suiteFailed, suiteError + ) where + +import Distribution.Compat.TempFile ( openTempFile ) +import Distribution.ModuleName ( ModuleName ) +import Distribution.Package + ( PackageId ) +import qualified Distribution.PackageDescription as PD + ( PackageDescription(..), BuildInfo(buildable) + , TestSuite(..) + , TestSuiteInterface(..), testType, hasTests ) +import Distribution.Simple.Build.PathsModule ( pkgPathEnvVar ) +import Distribution.Simple.BuildPaths ( exeExtension ) +import Distribution.Simple.Compiler ( Compiler(..), CompilerId ) +import Distribution.Simple.Hpc ( doHpcMarkup, findTixFiles, tixDir ) +import Distribution.Simple.InstallDirs + ( fromPathTemplate, initialPathTemplateEnv, PathTemplateVariable(..) + , substPathTemplate , toPathTemplate, PathTemplate ) +import qualified Distribution.Simple.LocalBuildInfo as LBI + ( LocalBuildInfo(..) ) +import Distribution.Simple.Setup ( TestFlags(..), TestShowDetails(..), fromFlag ) +import Distribution.Simple.Utils ( die, notice ) +import qualified Distribution.TestSuite as TestSuite + ( Test, Result(..), ImpureTestable(..), TestOptions(..), Options(..) ) +import Distribution.Text +import Distribution.Verbosity ( normal, Verbosity ) +import Distribution.System ( buildPlatform, Platform ) + +import Control.Exception ( bracket ) +import Control.Monad ( when, liftM, unless, filterM ) +import Data.Char ( toUpper ) +import Data.Monoid ( mempty ) +import System.Directory + ( createDirectoryIfMissing, doesFileExist, getCurrentDirectory + , removeFile, getDirectoryContents ) +import System.Environment ( getEnvironment ) +import System.Exit ( ExitCode(..), exitFailure, exitWith ) +import System.FilePath ( (), (<.>) ) +import System.IO ( hClose, IOMode(..), openFile ) +import System.Process ( runProcess, waitForProcess ) + +-- | Logs all test results for a package, broken down first by test suite and +-- then by test case. +data PackageLog = PackageLog + { package :: PackageId + , compiler :: CompilerId + , platform :: Platform + , testSuites :: [TestSuiteLog] + } + deriving (Read, Show, Eq) + +-- | A 'PackageLog' with package and platform information specified. +localPackageLog :: PD.PackageDescription -> LBI.LocalBuildInfo -> PackageLog +localPackageLog pkg_descr lbi = PackageLog + { package = PD.package pkg_descr + , compiler = compilerId $ LBI.compiler lbi + , platform = buildPlatform + , testSuites = [] + } + +-- | Logs test suite results, itemized by test case. +data TestSuiteLog = TestSuiteLog + { name :: String + , cases :: [Case] + , logFile :: FilePath -- path to human-readable log file + } + deriving (Read, Show, Eq) + +data Case = Case + { caseName :: String + , caseOptions :: TestSuite.Options + , caseResult :: TestSuite.Result + } + deriving (Read, Show, Eq) + +getTestOptions :: TestSuite.Test -> TestSuiteLog -> IO TestSuite.Options +getTestOptions t l = + case filter ((== TestSuite.name t) . caseName) (cases l) of + (x:_) -> return $ caseOptions x + _ -> TestSuite.defaultOptions t + +-- | From a 'TestSuiteLog', determine if the test suite passed. +suitePassed :: TestSuiteLog -> Bool +suitePassed = all (== TestSuite.Pass) . map caseResult . cases + +-- | From a 'TestSuiteLog', determine if the test suite failed. +suiteFailed :: TestSuiteLog -> Bool +suiteFailed = any isFail . map caseResult . cases + where isFail (TestSuite.Fail _) = True + isFail _ = False + +-- | From a 'TestSuiteLog', determine if the test suite encountered errors. +suiteError :: TestSuiteLog -> Bool +suiteError = any isError . map caseResult . cases + where isError (TestSuite.Error _) = True + isError _ = False + +-- | Run a test executable, logging the output and generating the appropriate +-- summary messages. +testController :: TestFlags + -- ^ flags Cabal was invoked with + -> PD.PackageDescription + -- ^ description of package the test suite belongs to + -> LBI.LocalBuildInfo + -- ^ information from the configure step + -> PD.TestSuite + -- ^ TestSuite being tested + -> (FilePath -> String) + -- ^ prepare standard input for test executable + -> FilePath -- ^ executable name + -> (ExitCode -> String -> TestSuiteLog) + -- ^ generator for the TestSuiteLog + -> (TestSuiteLog -> FilePath) + -- ^ generator for final human-readable log filename + -> IO TestSuiteLog +testController flags pkg_descr lbi suite preTest cmd postTest logNamer = do + let distPref = fromFlag $ testDistPref flags + verbosity = fromFlag $ testVerbosity flags + testLogDir = distPref "test" + optionTemplates = fromFlag $ testOptions flags + options = map (testOption pkg_descr lbi suite) optionTemplates + + pwd <- getCurrentDirectory + existingEnv <- getEnvironment + let dataDirPath = pwd PD.dataDir pkg_descr + shellEnv = Just $ (pkgPathEnvVar pkg_descr "datadir", dataDirPath) + : ("HPCTIXDIR", pwd tixDir distPref suite) + : existingEnv + + bracket (openCabalTemp testLogDir) deleteIfExists $ \tempLog -> + bracket (openCabalTemp testLogDir) deleteIfExists $ \tempInput -> do + + -- Create directory for HPC files. + createDirectoryIfMissing True $ tixDir distPref suite + + -- Remove old .tix files if appropriate. + tixFiles <- findTixFiles distPref suite + unless (fromFlag $ testKeepTix flags) + $ mapM_ deleteIfExists tixFiles + + -- Write summary notices indicating start of test suite + notice verbosity $ summarizeSuiteStart $ PD.testName suite + appendFile tempLog $ summarizeSuiteStart $ PD.testName suite + + -- Prepare standard input for test executable + appendFile tempInput $ preTest tempInput + + -- Run test executable + exit <- do + hLog <- openFile tempLog AppendMode + hIn <- openFile tempInput ReadMode + -- these handles get closed by runProcess + proc <- runProcess cmd options Nothing shellEnv + (Just hIn) (Just hLog) (Just hLog) + waitForProcess proc + + -- Generate TestSuiteLog from executable exit code and a machine- + -- readable test log + suiteLog <- readFile tempInput >>= return . postTest exit + + -- Generate final log file name + let finalLogName = testLogDir logNamer suiteLog + suiteLog' = suiteLog { logFile = finalLogName } + + -- Write summary notice to log file indicating end of test suite + appendFile tempLog $ summarizeSuiteFinish suiteLog' + + -- Append contents of temporary log file to the final human- + -- readable log file + readFile tempLog >>= appendFile (logFile suiteLog') + + -- Show the contents of the human-readable log file on the terminal + -- if there is a failure and/or detailed output is requested + let details = fromFlag $ testShowDetails flags + whenPrinting = when $ (details > Never) + && (not (suitePassed suiteLog) || details == Always) + && verbosity >= normal + whenPrinting $ readFile (logFile suiteLog') >>= + putStr . unlines . map (">>> " ++) . lines + + -- Write summary notice to terminal indicating end of test suite + notice verbosity $ summarizeSuiteFinish suiteLog' + + doHpcMarkup verbosity distPref (display $ PD.package pkg_descr) suite + + return suiteLog' + where + deleteIfExists file = do + exists <- doesFileExist file + when exists $ removeFile file + + openCabalTemp testLogDir = do + (f, h) <- openTempFile testLogDir $ "cabal-test-" <.> "log" + hClose h >> return f + + +-- |Perform the \"@.\/setup test@\" action. +test :: PD.PackageDescription -- ^information from the .cabal file + -> LBI.LocalBuildInfo -- ^information from the configure step + -> TestFlags -- ^flags sent to test + -> IO () +test pkg_descr lbi flags = do + let verbosity = fromFlag $ testVerbosity flags + humanTemplate = fromFlag $ testHumanLog flags + machineTemplate = fromFlag $ testMachineLog flags + distPref = fromFlag $ testDistPref flags + testLogDir = distPref "test" + testNames = fromFlag $ testList flags + pkgTests = PD.testSuites pkg_descr + enabledTests = [ t | t <- pkgTests + , PD.testEnabled t + , PD.buildable (PD.testBuildInfo t) ] + + doTest :: (PD.TestSuite, Maybe TestSuiteLog) -> IO TestSuiteLog + doTest (suite, mLog) = do + let testLogPath = testSuiteLogPath humanTemplate pkg_descr lbi + go pre cmd post = testController flags pkg_descr lbi suite + pre cmd post testLogPath + case PD.testInterface suite of + PD.TestSuiteExeV10 _ _ -> do + let cmd = LBI.buildDir lbi PD.testName suite + PD.testName suite <.> exeExtension + preTest _ = "" + postTest exit _ = + let r = case exit of + ExitSuccess -> TestSuite.Pass + ExitFailure c -> TestSuite.Fail + $ "exit code: " ++ show c + in TestSuiteLog + { name = PD.testName suite + , cases = [Case (PD.testName suite) mempty r] + , logFile = "" + } + go preTest cmd postTest + + PD.TestSuiteLibV09 _ _ -> do + let cmd = LBI.buildDir lbi stubName suite + stubName suite <.> exeExtension + oldLog = case mLog of + Nothing -> TestSuiteLog + { name = PD.testName suite + , cases = [] + , logFile = [] + } + Just l -> l + preTest f = show $ oldLog { logFile = f } + postTest _ = read + go preTest cmd postTest + + _ -> return TestSuiteLog + { name = PD.testName suite + , cases = [Case (PD.testName suite) mempty + $ TestSuite.Error $ "No support for running " + ++ "test suite type: " + ++ show (disp $ PD.testType suite)] + , logFile = "" + } + + when (not $ PD.hasTests pkg_descr) $ do + notice verbosity "Package has no test suites." + exitWith ExitSuccess + + when (PD.hasTests pkg_descr && null enabledTests) $ + die $ "No test suites enabled. Did you remember to configure with " + ++ "\'--enable-tests\'?" + + testsToRun <- case testNames of + [] -> return $ zip enabledTests $ repeat Nothing + names -> flip mapM names $ \tName -> + let testMap = zip enabledNames enabledTests + enabledNames = map PD.testName enabledTests + allNames = map PD.testName pkgTests + in case lookup tName testMap of + Just t -> return (t, Nothing) + _ | tName `elem` allNames -> + die $ "Package configured with test suite " + ++ tName ++ " disabled." + | otherwise -> die $ "no such test: " ++ tName + + createDirectoryIfMissing True testLogDir + + -- Delete ordinary files from test log directory. + getDirectoryContents testLogDir + >>= filterM doesFileExist . map (testLogDir ) + >>= mapM_ removeFile + + let totalSuites = length testsToRun + notice verbosity $ "Running " ++ show totalSuites ++ " test suites..." + suites <- mapM doTest testsToRun + let packageLog = (localPackageLog pkg_descr lbi) { testSuites = suites } + packageLogFile = () testLogDir + $ packageLogPath machineTemplate pkg_descr lbi + allOk <- summarizePackage verbosity packageLog + writeFile packageLogFile $ show packageLog + unless allOk exitFailure + +-- | Print a summary to the console after all test suites have been run +-- indicating the number of successful test suites and cases. Returns 'True' if +-- all test suites passed and 'False' otherwise. +summarizePackage :: Verbosity -> PackageLog -> IO Bool +summarizePackage verbosity packageLog = do + let cases' = map caseResult $ concatMap cases $ testSuites packageLog + passedCases = length $ filter (== TestSuite.Pass) cases' + totalCases = length cases' + passedSuites = length $ filter suitePassed $ testSuites packageLog + totalSuites = length $ testSuites packageLog + notice verbosity $ show passedSuites ++ " of " ++ show totalSuites + ++ " test suites (" ++ show passedCases ++ " of " + ++ show totalCases ++ " test cases) passed." + return $! passedSuites == totalSuites + +-- | Print a summary of a single test case's result to the console, supressing +-- output for certain verbosity or test filter levels. +summarizeCase :: Verbosity -> TestShowDetails -> Case -> IO () +summarizeCase verbosity details t = + when shouldPrint $ notice verbosity $ "Test case " ++ caseName t + ++ ": " ++ show (caseResult t) + where shouldPrint = (details > Never) && (notPassed || details == Always) + notPassed = caseResult t /= TestSuite.Pass + +-- | Print a summary of the test suite's results on the console, suppressing +-- output for certain verbosity or test filter levels. +summarizeSuiteFinish :: TestSuiteLog -> String +summarizeSuiteFinish testLog = unlines + [ "Test suite " ++ name testLog ++ ": " ++ resStr + , "Test suite logged to: " ++ logFile testLog + ] + where resStr = map toUpper (resultString testLog) + +summarizeSuiteStart :: String -> String +summarizeSuiteStart n = "Test suite " ++ n ++ ": RUNNING...\n" + +resultString :: TestSuiteLog -> String +resultString l | suiteError l = "error" + | suiteFailed l = "fail" + | otherwise = "pass" + +testSuiteLogPath :: PathTemplate + -> PD.PackageDescription + -> LBI.LocalBuildInfo + -> TestSuiteLog + -> FilePath +testSuiteLogPath template pkg_descr lbi testLog = + fromPathTemplate $ substPathTemplate env template + where + env = initialPathTemplateEnv + (PD.package pkg_descr) (compilerId $ LBI.compiler lbi) + ++ [ (TestSuiteNameVar, toPathTemplate $ name testLog) + , (TestSuiteResultVar, result) + ] + result = toPathTemplate $ resultString testLog + +-- TODO: This is abusing the notion of a 'PathTemplate'. The result +-- isn't neccesarily a path. +testOption :: PD.PackageDescription + -> LBI.LocalBuildInfo + -> PD.TestSuite + -> PathTemplate + -> String +testOption pkg_descr lbi suite template = + fromPathTemplate $ substPathTemplate env template + where + env = initialPathTemplateEnv + (PD.package pkg_descr) (compilerId $ LBI.compiler lbi) ++ + [(TestSuiteNameVar, toPathTemplate $ PD.testName suite)] + +packageLogPath :: PathTemplate + -> PD.PackageDescription + -> LBI.LocalBuildInfo + -> FilePath +packageLogPath template pkg_descr lbi = + fromPathTemplate $ substPathTemplate env template + where + env = initialPathTemplateEnv + (PD.package pkg_descr) (compilerId $ LBI.compiler lbi) + +-- | The filename of the source file for the stub executable associated with a +-- library 'TestSuite'. +stubFilePath :: PD.TestSuite -> FilePath +stubFilePath t = stubName t <.> "hs" + +-- | The name of the stub executable associated with a library 'TestSuite'. +stubName :: PD.TestSuite -> FilePath +stubName t = PD.testName t ++ "Stub" + +-- | Write the source file for a library 'TestSuite' stub executable. +writeSimpleTestStub :: PD.TestSuite -- ^ library 'TestSuite' for which a stub + -- is being created + -> FilePath -- ^ path to directory where stub source + -- should be located + -> IO () +writeSimpleTestStub t dir = do + createDirectoryIfMissing True dir + let filename = dir stubFilePath t + PD.TestSuiteLibV09 _ m = PD.testInterface t + writeFile filename $ simpleTestStub m + +-- | Source code for library test suite stub executable +simpleTestStub :: ModuleName -> String +simpleTestStub m = unlines + [ "module Main ( main ) where" + , "import Control.Monad ( liftM )" + , "import Distribution.Simple.Test ( runTests )" + , "import " ++ show (disp m) ++ " ( tests )" + , "main :: IO ()" + , "main = runTests tests" + ] + +-- | The test runner used in library "TestSuite" stub executables. Runs a list +-- of 'Test's. An executable calling this function is meant to be invoked as +-- the child of a Cabal process during @.\/setup test@. A 'TestSuiteLog', +-- provided by Cabal, is read from the standard input; it supplies the name of +-- the test suite and the location of the machine-readable test suite log file. +-- Human-readable log information is written to the standard output for capture +-- by the calling Cabal process. +runTests :: [TestSuite.Test] -> IO () +runTests tests = do + testLogIn <- liftM read getContents + let go :: TestSuite.Test -> IO Case + go t = do + o <- getTestOptions t testLogIn + r <- TestSuite.runM t o + let ret = Case + { caseName = TestSuite.name t + , caseOptions = o + , caseResult = r + } + summarizeCase normal Always ret + return ret + cases' <- mapM go tests + let testLog = testLogIn { cases = cases'} + writeFile (logFile testLog) $ show testLog + when (suiteError testLog) $ exitWith $ ExitFailure 2 + when (suiteFailed testLog) $ exitWith $ ExitFailure 1 + exitWith ExitSuccess diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/UHC.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/UHC.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/UHC.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/UHC.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,300 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.UHC +-- Copyright : Andres Loeh 2009 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module contains most of the UHC-specific code for configuring, building +-- and installing packages. +-- +-- Thanks to the authors of the other implementation-specific files, in +-- particular to Isaac Jones, Duncan Coutts and Henning Thielemann, for +-- inspiration on how to design this module. + +{- +Copyright (c) 2009, Andres Loeh +Copyright (c) 2003-2005, Isaac Jones +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.Simple.UHC ( + configure, getInstalledPackages, + buildLib, buildExe, installLib, registerPackage + ) where + +import Control.Monad +import Data.List +import Distribution.Compat.ReadP +import Distribution.InstalledPackageInfo +import Distribution.Package +import Distribution.PackageDescription +import Distribution.Simple.BuildPaths +import Distribution.Simple.Compiler as C +import Distribution.Simple.LocalBuildInfo +import Distribution.Simple.PackageIndex +import Distribution.Simple.Program +import Distribution.Simple.Utils +import Distribution.Text +import Distribution.Verbosity +import Distribution.Version +import Language.Haskell.Extension +import System.Directory +import System.FilePath + +-- ----------------------------------------------------------------------------- +-- Configuring + +configure :: Verbosity -> Maybe FilePath -> Maybe FilePath + -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration) +configure verbosity hcPath _hcPkgPath conf = do + + (_uhcProg, uhcVersion, conf') <- + requireProgramVersion verbosity uhcProgram + (orLaterVersion (Version [1,0,2] [])) + (userMaybeSpecifyPath "uhc" hcPath conf) + + let comp = Compiler { + compilerId = CompilerId UHC uhcVersion, + compilerLanguages = uhcLanguages, + compilerExtensions = uhcLanguageExtensions + } + return (comp, conf') + +uhcLanguages :: [(Language, C.Flag)] +uhcLanguages = [(Haskell98, "")] + +-- | The flags for the supported extensions. +uhcLanguageExtensions :: [(Extension, C.Flag)] +uhcLanguageExtensions = + let doFlag (f, (enable, disable)) = [(EnableExtension f, enable), + (DisableExtension f, disable)] + alwaysOn = ("", ""{- wrong -}) + in concatMap doFlag + [(CPP, ("--cpp", ""{- wrong -})), + (PolymorphicComponents, alwaysOn), + (ExistentialQuantification, alwaysOn), + (ForeignFunctionInterface, alwaysOn), + (UndecidableInstances, alwaysOn), + (MultiParamTypeClasses, alwaysOn), + (Rank2Types, alwaysOn), + (PatternSignatures, alwaysOn), + (EmptyDataDecls, alwaysOn), + (ImplicitPrelude, ("", "--no-prelude"{- wrong -})), + (TypeOperators, alwaysOn), + (OverlappingInstances, alwaysOn), + (FlexibleInstances, alwaysOn)] + +getInstalledPackages :: Verbosity -> Compiler -> PackageDBStack -> ProgramConfiguration + -> IO PackageIndex +getInstalledPackages verbosity comp packagedbs conf = do + let compilerid = compilerId comp + systemPkgDir <- rawSystemProgramStdoutConf verbosity uhcProgram conf ["--meta-pkgdir-system"] + userPkgDir <- getUserPackageDir + let pkgDirs = nub (concatMap (packageDbPaths userPkgDir systemPkgDir) packagedbs) + -- putStrLn $ "pkgdirs: " ++ show pkgDirs + -- call to "lines" necessary, because pkgdir contains an extra newline at the end + pkgs <- liftM (map addBuiltinVersions . concat) . + mapM (\ d -> getDirectoryContents d >>= filterM (isPkgDir (display compilerid) d)) . + concatMap lines $ pkgDirs + -- putStrLn $ "pkgs: " ++ show pkgs + let iPkgs = + map mkInstalledPackageInfo $ + concatMap parsePackage $ + pkgs + -- putStrLn $ "installed pkgs: " ++ show iPkgs + return (fromList iPkgs) + +getUserPackageDir :: IO FilePath +getUserPackageDir = + do + homeDir <- getHomeDirectory + return $ homeDir ".cabal" "lib" -- TODO: determine in some other way + +packageDbPaths :: FilePath -> FilePath -> PackageDB -> [FilePath] +packageDbPaths user system db = + case db of + GlobalPackageDB -> [ system ] + UserPackageDB -> [ user ] + SpecificPackageDB path -> [ path ] + +-- | Hack to add version numbers to UHC-builtin packages. This should sooner or +-- later be fixed on the UHC side. +addBuiltinVersions :: String -> String +{- +addBuiltinVersions "uhcbase" = "uhcbase-1.0" +addBuiltinVersions "base" = "base-3.0" +addBuiltinVersions "array" = "array-0.2" +-} +addBuiltinVersions xs = xs + +-- | Name of the installed package config file. +installedPkgConfig :: String +installedPkgConfig = "installed-pkg-config" + +-- | Check if a certain dir contains a valid package. Currently, we are +-- looking only for the presence of an installed package configuration. +-- TODO: Actually make use of the information provided in the file. +isPkgDir :: String -> String -> String -> IO Bool +isPkgDir _ _ ('.' : _) = return False -- ignore files starting with a . +isPkgDir c dir xs = do + let candidate = dir uhcPackageDir xs c + -- putStrLn $ "trying: " ++ candidate + doesFileExist (candidate installedPkgConfig) + +parsePackage :: String -> [PackageId] +parsePackage x = map fst (filter (\ (_,y) -> null y) (readP_to_S parse x)) + +-- | Create a trivial package info from a directory name. +mkInstalledPackageInfo :: PackageId -> InstalledPackageInfo +mkInstalledPackageInfo p = emptyInstalledPackageInfo + { installedPackageId = InstalledPackageId (display p), + sourcePackageId = p } + + +-- ----------------------------------------------------------------------------- +-- Building + +buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo + -> Library -> ComponentLocalBuildInfo -> IO () +buildLib verbosity pkg_descr lbi lib clbi = do + + systemPkgDir <- rawSystemProgramStdoutConf verbosity uhcProgram (withPrograms lbi) ["--meta-pkgdir-system"] + userPkgDir <- getUserPackageDir + let runUhcProg = rawSystemProgramConf verbosity uhcProgram (withPrograms lbi) + let uhcArgs = -- set package name + ["--pkg-build=" ++ display (packageId pkg_descr)] + -- common flags lib/exe + ++ constructUHCCmdLine userPkgDir systemPkgDir + lbi (libBuildInfo lib) clbi + (buildDir lbi) verbosity + -- source files + -- suboptimal: UHC does not understand module names, so + -- we replace periods by path separators + ++ map (map (\ c -> if c == '.' then pathSeparator else c)) + (map display (libModules lib)) + + runUhcProg uhcArgs + + return () + +buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo + -> Executable -> ComponentLocalBuildInfo -> IO () +buildExe verbosity _pkg_descr lbi exe clbi = do + systemPkgDir <- rawSystemProgramStdoutConf verbosity uhcProgram (withPrograms lbi) ["--meta-pkgdir-system"] + userPkgDir <- getUserPackageDir + let runUhcProg = rawSystemProgramConf verbosity uhcProgram (withPrograms lbi) + let uhcArgs = -- common flags lib/exe + constructUHCCmdLine userPkgDir systemPkgDir + lbi (buildInfo exe) clbi + (buildDir lbi) verbosity + -- output file + ++ ["--output", buildDir lbi exeName exe] + -- main source module + ++ [modulePath exe] + runUhcProg uhcArgs + +constructUHCCmdLine :: FilePath -> FilePath + -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo + -> FilePath -> Verbosity -> [String] +constructUHCCmdLine user system lbi bi clbi odir verbosity = + -- verbosity + (if verbosity >= deafening then ["-v4"] + else if verbosity >= normal then [] + else ["-v0"]) + ++ hcOptions UHC bi + -- flags for language extensions + ++ languageToFlags (compiler lbi) (defaultLanguage bi) + ++ extensionsToFlags (compiler lbi) (usedExtensions bi) + -- packages + ++ ["--hide-all-packages"] + ++ uhcPackageDbOptions user system (withPackageDB lbi) + ++ ["--package=uhcbase"] + ++ ["--package=" ++ display (pkgName pkgid) | (_, pkgid) <- componentPackageDeps clbi ] + -- search paths + ++ ["-i" ++ odir] + ++ ["-i" ++ l | l <- nub (hsSourceDirs bi)] + ++ ["-i" ++ autogenModulesDir lbi] + -- output path + ++ ["--odir=" ++ odir] + -- optimization + ++ (case withOptimization lbi of + NoOptimisation -> ["-O0"] + NormalOptimisation -> ["-O1"] + MaximumOptimisation -> ["-O2"]) + +uhcPackageDbOptions :: FilePath -> FilePath -> PackageDBStack -> [String] +uhcPackageDbOptions user system db = map (\ x -> "--pkg-searchpath=" ++ x) + (concatMap (packageDbPaths user system) db) + +-- ----------------------------------------------------------------------------- +-- Installation + +installLib :: Verbosity -> LocalBuildInfo + -> FilePath -> FilePath -> FilePath + -> PackageDescription -> Library -> IO () +installLib verbosity _lbi targetDir _dynlibTargetDir builtDir pkg _library = do + -- putStrLn $ "dest: " ++ targetDir + -- putStrLn $ "built: " ++ builtDir + installDirectoryContents verbosity (builtDir display (packageId pkg)) targetDir + +-- currently hardcoded UHC code generator and variant to use +uhcTarget, uhcTargetVariant :: String +uhcTarget = "bc" +uhcTargetVariant = "plain" + +-- root directory for a package in UHC +uhcPackageDir :: String -> String -> FilePath +uhcPackageSubDir :: String -> FilePath +uhcPackageDir pkgid compilerid = pkgid uhcPackageSubDir compilerid +uhcPackageSubDir compilerid = compilerid uhcTarget uhcTargetVariant + +-- ----------------------------------------------------------------------------- +-- Registering + +registerPackage + :: Verbosity + -> InstalledPackageInfo + -> PackageDescription + -> LocalBuildInfo + -> Bool + -> PackageDBStack + -> IO () +registerPackage verbosity installedPkgInfo pkg lbi inplace _packageDbs = do + let installDirs = absoluteInstallDirs pkg lbi NoCopyDest + pkgdir | inplace = buildDir lbi uhcPackageDir (display pkgid) (display compilerid) + | otherwise = libdir installDirs uhcPackageSubDir (display compilerid) + createDirectoryIfMissingVerbose verbosity True pkgdir + writeUTF8File (pkgdir installedPkgConfig) + (showInstalledPackageInfo installedPkgInfo) + where + pkgid = packageId pkg + compilerid = compilerId (compiler lbi) diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/UserHooks.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/UserHooks.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/UserHooks.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/UserHooks.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,220 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.UserHooks +-- Copyright : Isaac Jones 2003-2005 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This defines the API that @Setup.hs@ scripts can use to customise the way +-- the build works. This module just defines the 'UserHooks' type. The +-- predefined sets of hooks that implement the @Simple@, @Make@ and @Configure@ +-- build systems are defined in "Distribution.Simple". The 'UserHooks' is a big +-- record of functions. There are 3 for each action, a pre, post and the action +-- itself. There are few other miscellaneous hooks, ones to extend the set of +-- programs and preprocessors and one to override the function used to read the +-- @.cabal@ file. +-- +-- This hooks type is widely agreed to not be the right solution. Partly this +-- is because changes to it usually break custom @Setup.hs@ files and yet many +-- internal code changes do require changes to the hooks. For example we cannot +-- pass any extra parameters to most of the functions that implement the +-- various phases because it would involve changing the types of the +-- corresponding hook. At some point it will have to be replaced. + +{- All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.Simple.UserHooks ( + UserHooks(..), Args, + emptyUserHooks, + ) where + +import Distribution.PackageDescription + (PackageDescription, GenericPackageDescription, + HookedBuildInfo, emptyHookedBuildInfo) +import Distribution.Simple.Program (Program) +import Distribution.Simple.Command (noExtraFlags) +import Distribution.Simple.PreProcess (PPSuffixHandler) +import Distribution.Simple.Setup + (ConfigFlags, BuildFlags, CleanFlags, CopyFlags, + InstallFlags, SDistFlags, RegisterFlags, HscolourFlags, + HaddockFlags, TestFlags) +import Distribution.Simple.LocalBuildInfo (LocalBuildInfo) + +type Args = [String] + +-- | Hooks allow authors to add specific functionality before and after a +-- command is run, and also to specify additional preprocessors. +-- +-- * WARNING: The hooks interface is under rather constant flux as we try to +-- understand users needs. Setup files that depend on this interface may +-- break in future releases. +data UserHooks = UserHooks { + + -- | Used for @.\/setup test@ + runTests :: Args -> Bool -> PackageDescription -> LocalBuildInfo -> IO (), + -- | Read the description file + readDesc :: IO (Maybe GenericPackageDescription), + -- | Custom preprocessors in addition to and overriding 'knownSuffixHandlers'. + hookedPreProcessors :: [ PPSuffixHandler ], + -- | These programs are detected at configure time. Arguments for them are + -- added to the configure command. + hookedPrograms :: [Program], + + -- |Hook to run before configure command + preConf :: Args -> ConfigFlags -> IO HookedBuildInfo, + -- |Over-ride this hook to get different behavior during configure. + confHook :: (GenericPackageDescription, HookedBuildInfo) + -> ConfigFlags -> IO LocalBuildInfo, + -- |Hook to run after configure command + postConf :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO (), + + -- |Hook to run before build command. Second arg indicates verbosity level. + preBuild :: Args -> BuildFlags -> IO HookedBuildInfo, + + -- |Over-ride this hook to gbet different behavior during build. + buildHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO (), + -- |Hook to run after build command. Second arg indicates verbosity level. + postBuild :: Args -> BuildFlags -> PackageDescription -> LocalBuildInfo -> IO (), + + -- |Hook to run before clean command. Second arg indicates verbosity level. + preClean :: Args -> CleanFlags -> IO HookedBuildInfo, + -- |Over-ride this hook to get different behavior during clean. + cleanHook :: PackageDescription -> () -> UserHooks -> CleanFlags -> IO (), + -- |Hook to run after clean command. Second arg indicates verbosity level. + postClean :: Args -> CleanFlags -> PackageDescription -> () -> IO (), + + -- |Hook to run before copy command + preCopy :: Args -> CopyFlags -> IO HookedBuildInfo, + -- |Over-ride this hook to get different behavior during copy. + copyHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> CopyFlags -> IO (), + -- |Hook to run after copy command + postCopy :: Args -> CopyFlags -> PackageDescription -> LocalBuildInfo -> IO (), + + -- |Hook to run before install command + preInst :: Args -> InstallFlags -> IO HookedBuildInfo, + + -- |Over-ride this hook to get different behavior during install. + instHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> InstallFlags -> IO (), + -- |Hook to run after install command. postInst should be run + -- on the target, not on the build machine. + postInst :: Args -> InstallFlags -> PackageDescription -> LocalBuildInfo -> IO (), + + -- |Hook to run before sdist command. Second arg indicates verbosity level. + preSDist :: Args -> SDistFlags -> IO HookedBuildInfo, + -- |Over-ride this hook to get different behavior during sdist. + sDistHook :: PackageDescription -> Maybe LocalBuildInfo -> UserHooks -> SDistFlags -> IO (), + -- |Hook to run after sdist command. Second arg indicates verbosity level. + postSDist :: Args -> SDistFlags -> PackageDescription -> Maybe LocalBuildInfo -> IO (), + + -- |Hook to run before register command + preReg :: Args -> RegisterFlags -> IO HookedBuildInfo, + -- |Over-ride this hook to get different behavior during registration. + regHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO (), + -- |Hook to run after register command + postReg :: Args -> RegisterFlags -> PackageDescription -> LocalBuildInfo -> IO (), + + -- |Hook to run before unregister command + preUnreg :: Args -> RegisterFlags -> IO HookedBuildInfo, + -- |Over-ride this hook to get different behavior during registration. + unregHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO (), + -- |Hook to run after unregister command + postUnreg :: Args -> RegisterFlags -> PackageDescription -> LocalBuildInfo -> IO (), + + -- |Hook to run before hscolour command. Second arg indicates verbosity level. + preHscolour :: Args -> HscolourFlags -> IO HookedBuildInfo, + -- |Over-ride this hook to get different behavior during hscolour. + hscolourHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> HscolourFlags -> IO (), + -- |Hook to run after hscolour command. Second arg indicates verbosity level. + postHscolour :: Args -> HscolourFlags -> PackageDescription -> LocalBuildInfo -> IO (), + + -- |Hook to run before haddock command. Second arg indicates verbosity level. + preHaddock :: Args -> HaddockFlags -> IO HookedBuildInfo, + -- |Over-ride this hook to get different behavior during haddock. + haddockHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> HaddockFlags -> IO (), + -- |Hook to run after haddock command. Second arg indicates verbosity level. + postHaddock :: Args -> HaddockFlags -> PackageDescription -> LocalBuildInfo -> IO (), + + -- |Hook to run before test command. + preTest :: Args -> TestFlags -> IO HookedBuildInfo, + -- |Over-ride this hook to get different behavior during test. + testHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> TestFlags -> IO (), + -- |Hook to run after test command. + postTest :: Args -> TestFlags -> PackageDescription -> LocalBuildInfo -> IO () + } + +{-# DEPRECATED runTests "Please use the new testing interface instead!" #-} + +-- |Empty 'UserHooks' which do nothing. +emptyUserHooks :: UserHooks +emptyUserHooks + = UserHooks { + runTests = ru, + readDesc = return Nothing, + hookedPreProcessors = [], + hookedPrograms = [], + preConf = rn, + confHook = (\_ _ -> return (error "No local build info generated during configure. Over-ride empty configure hook.")), + postConf = ru, + preBuild = rn, + buildHook = ru, + postBuild = ru, + preClean = rn, + cleanHook = ru, + postClean = ru, + preCopy = rn, + copyHook = ru, + postCopy = ru, + preInst = rn, + instHook = ru, + postInst = ru, + preSDist = rn, + sDistHook = ru, + postSDist = ru, + preReg = rn, + regHook = ru, + postReg = ru, + preUnreg = rn, + unregHook = ru, + postUnreg = ru, + preHscolour = rn, + hscolourHook = ru, + postHscolour = ru, + preHaddock = rn, + haddockHook = ru, + postHaddock = ru, + preTest = \_ _ -> return emptyHookedBuildInfo, -- same as rn, but without + -- noExtraFlags + testHook = ru, + postTest = ru + } + where rn args _ = noExtraFlags args >> return emptyHookedBuildInfo + ru _ _ _ _ = return () diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/Utils.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/Utils.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple/Utils.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple/Utils.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,1131 @@ +{-# LANGUAGE CPP, ForeignFunctionInterface #-} +{-# OPTIONS_NHC98 -cpp #-} +{-# OPTIONS_JHC -fcpp -fffi #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple.Utils +-- Copyright : Isaac Jones, Simon Marlow 2003-2004 +-- portions Copyright (c) 2007, Galois Inc. +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- A large and somewhat miscellaneous collection of utility functions used +-- throughout the rest of the Cabal lib and in other tools that use the Cabal +-- lib like @cabal-install@. It has a very simple set of logging actions. It +-- has low level functions for running programs, a bunch of wrappers for +-- various directory and file functions that do extra logging. + +{- All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.Simple.Utils ( + cabalVersion, + + -- * logging and errors + die, + dieWithLocation, + topHandler, + warn, notice, setupMessage, info, debug, + chattyTry, + + -- * running programs + rawSystemExit, + rawSystemExitWithEnv, + rawSystemStdout, + rawSystemStdInOut, + maybeExit, + xargs, + findProgramLocation, + findProgramVersion, + + -- * copying files + smartCopySources, + createDirectoryIfMissingVerbose, + copyFileVerbose, + copyDirectoryRecursiveVerbose, + copyFiles, + + -- * installing files + installOrdinaryFile, + installExecutableFile, + installOrdinaryFiles, + installDirectoryContents, + + -- * File permissions + setFileOrdinary, + setFileExecutable, + + -- * file names + currentDir, + + -- * finding files + findFile, + findFirstFile, + findFileWithExtension, + findFileWithExtension', + findModuleFile, + findModuleFiles, + getDirectoryContentsRecursive, + + -- * simple file globbing + matchFileGlob, + matchDirFileGlob, + parseFileGlob, + FileGlob(..), + + -- * temp files and dirs + withTempFile, + withTempDirectory, + + -- * .cabal and .buildinfo files + defaultPackageDesc, + findPackageDesc, + defaultHookedPackageDesc, + findHookedPackageDesc, + + -- * reading and writing files safely + withFileContents, + writeFileAtomic, + rewriteFile, + + -- * Unicode + fromUTF8, + toUTF8, + readUTF8File, + withUTF8FileContents, + writeUTF8File, + normaliseLineEndings, + + -- * generic utils + equating, + comparing, + isInfixOf, + intercalate, + lowercase, + wrapText, + wrapLine, + ) where + +import Control.Monad + ( when, unless, filterM ) +#ifdef __GLASGOW_HASKELL__ +import Control.Concurrent.MVar + ( newEmptyMVar, putMVar, takeMVar ) +#endif +import Data.List + ( nub, unfoldr, isPrefixOf, tails, intersperse ) +import Data.Char as Char + ( toLower, chr, ord ) +import Data.Bits + ( Bits((.|.), (.&.), shiftL, shiftR) ) + +import System.Directory + ( getDirectoryContents, doesDirectoryExist, doesFileExist, removeFile + , findExecutable ) +import System.Environment + ( getProgName ) +import System.Cmd + ( rawSystem ) +import System.Exit + ( exitWith, ExitCode(..) ) +import System.FilePath + ( normalise, (), (<.>), takeDirectory, splitFileName + , splitExtension, splitExtensions, splitDirectories ) +import System.Directory + ( createDirectory, renameFile, removeDirectoryRecursive ) +import System.IO + ( Handle, openFile, openBinaryFile, IOMode(ReadMode), hSetBinaryMode + , hGetContents, stderr, stdout, hPutStr, hFlush, hClose ) +import System.IO.Error as IO.Error + ( isDoesNotExistError, isAlreadyExistsError + , ioeSetFileName, ioeGetFileName, ioeGetErrorString ) +#if !(defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 608)) +import System.IO.Error + ( ioeSetLocation, ioeGetLocation ) +#endif +import System.IO.Unsafe + ( unsafeInterleaveIO ) +import qualified Control.Exception as Exception + +import Distribution.Text + ( display, simpleParse ) +import Distribution.Package + ( PackageIdentifier ) +import Distribution.ModuleName (ModuleName) +import qualified Distribution.ModuleName as ModuleName +import Distribution.Version + (Version(..)) + +import Control.Exception (evaluate) +import System.Process (runProcess) + +#ifdef __GLASGOW_HASKELL__ +import Control.Concurrent (forkIO) +import System.Process (runInteractiveProcess, waitForProcess) +#else +import System.Cmd (system) +import System.Directory (getTemporaryDirectory) +#endif + +import Distribution.Compat.CopyFile + ( copyFile, copyOrdinaryFile, copyExecutableFile + , setFileOrdinary, setFileExecutable, setDirOrdinary ) +import Distribution.Compat.TempFile + ( openTempFile, openNewBinaryFile, createTempDirectory ) +import Distribution.Compat.Exception + ( IOException, throwIOIO, tryIO, catchIO, catchExit, onException ) +import Distribution.Verbosity + +#ifdef VERSION_base +import qualified Paths_Cabal (version) +#endif + +-- We only get our own version number when we're building with ourselves +cabalVersion :: Version +#if defined(VERSION_base) +cabalVersion = Paths_Cabal.version +#elif defined(CABAL_VERSION) +cabalVersion = Version [CABAL_VERSION] [] +#else +cabalVersion = Version [1,9999] [] --used when bootstrapping +#endif + +-- ---------------------------------------------------------------------------- +-- Exception and logging utils + +dieWithLocation :: FilePath -> Maybe Int -> String -> IO a +dieWithLocation filename lineno msg = + ioError . setLocation lineno + . flip ioeSetFileName (normalise filename) + $ userError msg + where +#if defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 608) + setLocation _ err = err +#else + setLocation Nothing err = err + setLocation (Just n) err = ioeSetLocation err (show n) +#endif + +die :: String -> IO a +die msg = ioError (userError msg) + +topHandler :: IO a -> IO a +topHandler prog = catchIO prog handle + where + handle ioe = do + hFlush stdout + pname <- getProgName + hPutStr stderr (mesage pname) + exitWith (ExitFailure 1) + where + mesage pname = wrapText (pname ++ ": " ++ file ++ detail) + file = case ioeGetFileName ioe of + Nothing -> "" + Just path -> path ++ location ++ ": " +#if defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 608) + location = "" +#else + location = case ioeGetLocation ioe of + l@(n:_) | n >= '0' && n <= '9' -> ':' : l + _ -> "" +#endif + detail = ioeGetErrorString ioe + +-- | Non fatal conditions that may be indicative of an error or problem. +-- +-- We display these at the 'normal' verbosity level. +-- +warn :: Verbosity -> String -> IO () +warn verbosity msg = + when (verbosity >= normal) $ do + hFlush stdout + hPutStr stderr (wrapText ("Warning: " ++ msg)) + +-- | Useful status messages. +-- +-- We display these at the 'normal' verbosity level. +-- +-- This is for the ordinary helpful status messages that users see. Just +-- enough information to know that things are working but not floods of detail. +-- +notice :: Verbosity -> String -> IO () +notice verbosity msg = + when (verbosity >= normal) $ + putStr (wrapText msg) + +setupMessage :: Verbosity -> String -> PackageIdentifier -> IO () +setupMessage verbosity msg pkgid = + notice verbosity (msg ++ ' ': display pkgid ++ "...") + +-- | More detail on the operation of some action. +-- +-- We display these messages when the verbosity level is 'verbose' +-- +info :: Verbosity -> String -> IO () +info verbosity msg = + when (verbosity >= verbose) $ + putStr (wrapText msg) + +-- | Detailed internal debugging information +-- +-- We display these messages when the verbosity level is 'deafening' +-- +debug :: Verbosity -> String -> IO () +debug verbosity msg = + when (verbosity >= deafening) $ do + putStr (wrapText msg) + hFlush stdout + +-- | Perform an IO action, catching any IO exceptions and printing an error +-- if one occurs. +chattyTry :: String -- ^ a description of the action we were attempting + -> IO () -- ^ the action itself + -> IO () +chattyTry desc action = + catchIO action $ \exception -> + putStrLn $ "Error while " ++ desc ++ ": " ++ show exception + +-- ----------------------------------------------------------------------------- +-- Helper functions + +-- | Wraps text to the default line width. Existing newlines are preserved. +wrapText :: String -> String +wrapText = unlines + . concatMap (map unwords + . wrapLine 79 + . words) + . lines + +-- | Wraps a list of words to a list of lines of words of a particular width. +wrapLine :: Int -> [String] -> [[String]] +wrapLine width = wrap 0 [] + where wrap :: Int -> [String] -> [String] -> [[String]] + wrap 0 [] (w:ws) + | length w + 1 > width + = wrap (length w) [w] ws + wrap col line (w:ws) + | col + length w + 1 > width + = reverse line : wrap 0 [] (w:ws) + wrap col line (w:ws) + = let col' = col + length w + 1 + in wrap col' (w:line) ws + wrap _ [] [] = [] + wrap _ line [] = [reverse line] + +-- ----------------------------------------------------------------------------- +-- rawSystem variants +maybeExit :: IO ExitCode -> IO () +maybeExit cmd = do + res <- cmd + unless (res == ExitSuccess) $ exitWith res + +printRawCommandAndArgs :: Verbosity -> FilePath -> [String] -> IO () +printRawCommandAndArgs verbosity path args + | verbosity >= deafening = print (path, args) + | verbosity >= verbose = putStrLn $ unwords (path : args) + | otherwise = return () + +printRawCommandAndArgsAndEnv :: Verbosity + -> FilePath + -> [String] + -> [(String, String)] + -> IO () +printRawCommandAndArgsAndEnv verbosity path args env + | verbosity >= deafening = do putStrLn ("Environment: " ++ show env) + print (path, args) + | verbosity >= verbose = putStrLn $ unwords (path : args) + | otherwise = return () + +-- Exit with the same exitcode if the subcommand fails +rawSystemExit :: Verbosity -> FilePath -> [String] -> IO () +rawSystemExit verbosity path args = do + printRawCommandAndArgs verbosity path args + hFlush stdout + exitcode <- rawSystem path args + unless (exitcode == ExitSuccess) $ do + debug verbosity $ path ++ " returned " ++ show exitcode + exitWith exitcode + +rawSystemExitWithEnv :: Verbosity + -> FilePath + -> [String] + -> [(String, String)] + -> IO () +rawSystemExitWithEnv verbosity path args env = do + printRawCommandAndArgsAndEnv verbosity path args env + hFlush stdout + ph <- runProcess path args Nothing (Just env) Nothing Nothing Nothing + exitcode <- waitForProcess ph + unless (exitcode == ExitSuccess) $ do + debug verbosity $ path ++ " returned " ++ show exitcode + exitWith exitcode + +-- | Run a command and return its output. +-- +-- The output is assumed to be text in the locale encoding. +-- +rawSystemStdout :: Verbosity -> FilePath -> [String] -> IO String +rawSystemStdout verbosity path args = do + (output, errors, exitCode) <- rawSystemStdInOut verbosity path args + Nothing False + when (exitCode /= ExitSuccess) $ + die errors + return output + +-- | Run a command and return its output, errors and exit status. Optionally +-- also supply some input. Also provides control over whether the binary/text +-- mode of the input and output. +-- +rawSystemStdInOut :: Verbosity + -> FilePath -> [String] + -> Maybe (String, Bool) -- ^ input text and binary mode + -> Bool -- ^ output in binary mode + -> IO (String, String, ExitCode) -- ^ output, errors, exit +rawSystemStdInOut verbosity path args input outputBinary = do + printRawCommandAndArgs verbosity path args + +#ifdef __GLASGOW_HASKELL__ + Exception.bracket + (runInteractiveProcess path args Nothing Nothing) + (\(inh,outh,errh,_) -> hClose inh >> hClose outh >> hClose errh) + $ \(inh,outh,errh,pid) -> do + + -- output mode depends on what the caller wants + hSetBinaryMode outh outputBinary + -- but the errors are always assumed to be text (in the current locale) + hSetBinaryMode errh False + + -- fork off a couple threads to pull on the stderr and stdout + -- so if the process writes to stderr we do not block. + + err <- hGetContents errh + out <- hGetContents outh + + mv <- newEmptyMVar + let force str = (evaluate (length str) >> return ()) + `Exception.finally` putMVar mv () + --TODO: handle exceptions like text decoding. + _ <- forkIO $ force out + _ <- forkIO $ force err + + -- push all the input, if any + case input of + Nothing -> return () + Just (inputStr, inputBinary) -> do + -- input mode depends on what the caller wants + hSetBinaryMode inh inputBinary + hPutStr inh inputStr + hClose inh + --TODO: this probably fails if the process refuses to consume + -- or if it closes stdin (eg if it exits) + + -- wait for both to finish, in either order + takeMVar mv + takeMVar mv + + -- wait for the program to terminate + exitcode <- waitForProcess pid + unless (exitcode == ExitSuccess) $ + debug verbosity $ path ++ " returned " ++ show exitcode + ++ if null err then "" else + " with error message:\n" ++ err + + return (out, err, exitcode) +#else + tmpDir <- getTemporaryDirectory + withTempFile tmpDir ".cmd.stdout" $ \outName outHandle -> + withTempFile tmpDir ".cmd.stdin" $ \inName inHandle -> do + hClose outHandle + + case input of + Nothing -> return () + Just (inputStr, inputBinary) -> do + hSetBinaryMode inHandle inputBinary + hPutStr inHandle inputStr + hClose inHandle + + let quote name = "'" ++ name ++ "'" + cmd = unwords (map quote (path:args)) + ++ " <" ++ quote inName + ++ " >" ++ quote outName + exitcode <- system cmd + + unless (exitcode == ExitSuccess) $ + debug verbosity $ path ++ " returned " ++ show exitcode + + Exception.bracket (openFile outName ReadMode) hClose $ \hnd -> do + hSetBinaryMode hnd outputBinary + output <- hGetContents hnd + length output `seq` return (output, "", exitcode) +#endif + + +-- | Look for a program on the path. +findProgramLocation :: Verbosity -> FilePath -> IO (Maybe FilePath) +findProgramLocation verbosity prog = do + debug verbosity $ "searching for " ++ prog ++ " in path." + res <- findExecutable prog + case res of + Nothing -> debug verbosity ("Cannot find " ++ prog ++ " on the path") + Just path -> debug verbosity ("found " ++ prog ++ " at "++ path) + return res + + +-- | Look for a program and try to find it's version number. It can accept +-- either an absolute path or the name of a program binary, in which case we +-- will look for the program on the path. +-- +findProgramVersion :: String -- ^ version args + -> (String -> String) -- ^ function to select version + -- number from program output + -> Verbosity + -> FilePath -- ^ location + -> IO (Maybe Version) +findProgramVersion versionArg selectVersion verbosity path = do + str <- rawSystemStdout verbosity path [versionArg] + `catchIO` (\_ -> return "") + `catchExit` (\_ -> return "") + let version :: Maybe Version + version = simpleParse (selectVersion str) + case version of + Nothing -> warn verbosity $ "cannot determine version of " ++ path + ++ " :\n" ++ show str + Just v -> debug verbosity $ path ++ " is version " ++ display v + return version + + +-- | Like the unix xargs program. Useful for when we've got very long command +-- lines that might overflow an OS limit on command line length and so you +-- need to invoke a command multiple times to get all the args in. +-- +-- Use it with either of the rawSystem variants above. For example: +-- +-- > xargs (32*1024) (rawSystemExit verbosity) prog fixedArgs bigArgs +-- +xargs :: Int -> ([String] -> IO ()) + -> [String] -> [String] -> IO () +xargs maxSize rawSystemFun fixedArgs bigArgs = + let fixedArgSize = sum (map length fixedArgs) + length fixedArgs + chunkSize = maxSize - fixedArgSize + in mapM_ (rawSystemFun . (fixedArgs ++)) (chunks chunkSize bigArgs) + + where chunks len = unfoldr $ \s -> + if null s then Nothing + else Just (chunk [] len s) + + chunk acc _ [] = (reverse acc,[]) + chunk acc len (s:ss) + | len' < len = chunk (s:acc) (len-len'-1) ss + | otherwise = (reverse acc, s:ss) + where len' = length s + +-- ------------------------------------------------------------ +-- * File Utilities +-- ------------------------------------------------------------ + +---------------- +-- Finding files + +-- | Find a file by looking in a search path. The file path must match exactly. +-- +findFile :: [FilePath] -- ^search locations + -> FilePath -- ^File Name + -> IO FilePath +findFile searchPath fileName = + findFirstFile id + [ path fileName + | path <- nub searchPath] + >>= maybe (die $ fileName ++ " doesn't exist") return + +-- | Find a file by looking in a search path with one of a list of possible +-- file extensions. The file base name should be given and it will be tried +-- with each of the extensions in each element of the search path. +-- +findFileWithExtension :: [String] + -> [FilePath] + -> FilePath + -> IO (Maybe FilePath) +findFileWithExtension extensions searchPath baseName = + findFirstFile id + [ path baseName <.> ext + | path <- nub searchPath + , ext <- nub extensions ] + +-- | Like 'findFileWithExtension' but returns which element of the search path +-- the file was found in, and the file path relative to that base directory. +-- +findFileWithExtension' :: [String] + -> [FilePath] + -> FilePath + -> IO (Maybe (FilePath, FilePath)) +findFileWithExtension' extensions searchPath baseName = + findFirstFile (uncurry ()) + [ (path, baseName <.> ext) + | path <- nub searchPath + , ext <- nub extensions ] + +findFirstFile :: (a -> FilePath) -> [a] -> IO (Maybe a) +findFirstFile file = findFirst + where findFirst [] = return Nothing + findFirst (x:xs) = do exists <- doesFileExist (file x) + if exists + then return (Just x) + else findFirst xs + +-- | Finds the files corresponding to a list of Haskell module names. +-- +-- As 'findModuleFile' but for a list of module names. +-- +findModuleFiles :: [FilePath] -- ^ build prefix (location of objects) + -> [String] -- ^ search suffixes + -> [ModuleName] -- ^ modules + -> IO [(FilePath, FilePath)] +findModuleFiles searchPath extensions moduleNames = + mapM (findModuleFile searchPath extensions) moduleNames + +-- | Find the file corresponding to a Haskell module name. +-- +-- This is similar to 'findFileWithExtension'' but specialised to a module +-- name. The function fails if the file corresponding to the module is missing. +-- +findModuleFile :: [FilePath] -- ^ build prefix (location of objects) + -> [String] -- ^ search suffixes + -> ModuleName -- ^ module + -> IO (FilePath, FilePath) +findModuleFile searchPath extensions moduleName = + maybe notFound return + =<< findFileWithExtension' extensions searchPath + (ModuleName.toFilePath moduleName) + where + notFound = die $ "Error: Could not find module: " ++ display moduleName + ++ " with any suffix: " ++ show extensions + ++ " in the search path: " ++ show searchPath + +-- | List all the files in a directory and all subdirectories. +-- +-- The order places files in sub-directories after all the files in their +-- parent directories. The list is generated lazily so is not well defined if +-- the source directory structure changes before the list is used. +-- +getDirectoryContentsRecursive :: FilePath -> IO [FilePath] +getDirectoryContentsRecursive topdir = recurseDirectories [""] + where + recurseDirectories :: [FilePath] -> IO [FilePath] + recurseDirectories [] = return [] + recurseDirectories (dir:dirs) = unsafeInterleaveIO $ do + (files, dirs') <- collect [] [] =<< getDirectoryContents (topdir dir) + files' <- recurseDirectories (dirs' ++ dirs) + return (files ++ files') + + where + collect files dirs' [] = return (reverse files, reverse dirs') + collect files dirs' (entry:entries) | ignore entry + = collect files dirs' entries + collect files dirs' (entry:entries) = do + let dirEntry = dir entry + isDirectory <- doesDirectoryExist (topdir dirEntry) + if isDirectory + then collect files (dirEntry:dirs') entries + else collect (dirEntry:files) dirs' entries + + ignore ['.'] = True + ignore ['.', '.'] = True + ignore _ = False + +---------------- +-- File globbing + +data FileGlob + -- | No glob at all, just an ordinary file + = NoGlob FilePath + + -- | dir prefix and extension, like @\"foo\/bar\/\*.baz\"@ corresponds to + -- @FileGlob \"foo\/bar\" \".baz\"@ + | FileGlob FilePath String + +parseFileGlob :: FilePath -> Maybe FileGlob +parseFileGlob filepath = case splitExtensions filepath of + (filepath', ext) -> case splitFileName filepath' of + (dir, "*") | '*' `elem` dir + || '*' `elem` ext + || null ext -> Nothing + | null dir -> Just (FileGlob "." ext) + | otherwise -> Just (FileGlob dir ext) + _ | '*' `elem` filepath -> Nothing + | otherwise -> Just (NoGlob filepath) + +matchFileGlob :: FilePath -> IO [FilePath] +matchFileGlob = matchDirFileGlob "." + +matchDirFileGlob :: FilePath -> FilePath -> IO [FilePath] +matchDirFileGlob dir filepath = case parseFileGlob filepath of + Nothing -> die $ "invalid file glob '" ++ filepath + ++ "'. Wildcards '*' are only allowed in place of the file" + ++ " name, not in the directory name or file extension." + ++ " If a wildcard is used it must be with an file extension." + Just (NoGlob filepath') -> return [filepath'] + Just (FileGlob dir' ext) -> do + files <- getDirectoryContents (dir dir') + case [ dir' file + | file <- files + , let (name, ext') = splitExtensions file + , not (null name) && ext' == ext ] of + [] -> die $ "filepath wildcard '" ++ filepath + ++ "' does not match any files." + matches -> return matches + +---------------------------------------- +-- Copying and installing files and dirs + +-- | Same as 'createDirectoryIfMissing' but logs at higher verbosity levels. +-- +createDirectoryIfMissingVerbose :: Verbosity + -> Bool -- ^ Create its parents too? + -> FilePath + -> IO () +createDirectoryIfMissingVerbose verbosity create_parents path0 + | create_parents = createDirs (parents path0) + | otherwise = createDirs (take 1 (parents path0)) + where + parents = reverse . scanl1 () . splitDirectories . normalise + + createDirs [] = return () + createDirs (dir:[]) = createDir dir throwIOIO + createDirs (dir:dirs) = + createDir dir $ \_ -> do + createDirs dirs + createDir dir throwIOIO + + createDir :: FilePath -> (IOException -> IO ()) -> IO () + createDir dir notExistHandler = do + r <- tryIO $ createDirectoryVerbose verbosity dir + case (r :: Either IOException ()) of + Right () -> return () + Left e + | isDoesNotExistError e -> notExistHandler e + -- createDirectory (and indeed POSIX mkdir) does not distinguish + -- between a dir already existing and a file already existing. So we + -- check for it here. Unfortunately there is a slight race condition + -- here, but we think it is benign. It could report an exeption in + -- the case that the dir did exist but another process deletes the + -- directory and creates a file in its place before we can check + -- that the directory did indeed exist. + | isAlreadyExistsError e -> (do + isDir <- doesDirectoryExist dir + if isDir then return () + else throwIOIO e + ) `catchIO` ((\_ -> return ()) :: IOException -> IO ()) + | otherwise -> throwIOIO e + +createDirectoryVerbose :: Verbosity -> FilePath -> IO () +createDirectoryVerbose verbosity dir = do + info verbosity $ "creating " ++ dir + createDirectory dir + setDirOrdinary dir + +-- | Copies a file without copying file permissions. The target file is created +-- with default permissions. Any existing target file is replaced. +-- +-- At higher verbosity levels it logs an info message. +-- +copyFileVerbose :: Verbosity -> FilePath -> FilePath -> IO () +copyFileVerbose verbosity src dest = do + info verbosity ("copy " ++ src ++ " to " ++ dest) + copyFile src dest + +-- | Install an ordinary file. This is like a file copy but the permissions +-- are set appropriately for an installed file. On Unix it is \"-rw-r--r--\" +-- while on Windows it uses the default permissions for the target directory. +-- +installOrdinaryFile :: Verbosity -> FilePath -> FilePath -> IO () +installOrdinaryFile verbosity src dest = do + info verbosity ("Installing " ++ src ++ " to " ++ dest) + copyOrdinaryFile src dest + +-- | Install an executable file. This is like a file copy but the permissions +-- are set appropriately for an installed file. On Unix it is \"-rwxr-xr-x\" +-- while on Windows it uses the default permissions for the target directory. +-- +installExecutableFile :: Verbosity -> FilePath -> FilePath -> IO () +installExecutableFile verbosity src dest = do + info verbosity ("Installing executable " ++ src ++ " to " ++ dest) + copyExecutableFile src dest + +-- | Copies a bunch of files to a target directory, preserving the directory +-- structure in the target location. The target directories are created if they +-- do not exist. +-- +-- The files are identified by a pair of base directory and a path relative to +-- that base. It is only the relative part that is preserved in the +-- destination. +-- +-- For example: +-- +-- > copyFiles normal "dist/src" +-- > [("", "src/Foo.hs"), ("dist/build/", "src/Bar.hs")] +-- +-- This would copy \"src\/Foo.hs\" to \"dist\/src\/src\/Foo.hs\" and +-- copy \"dist\/build\/src\/Bar.hs\" to \"dist\/src\/src\/Bar.hs\". +-- +-- This operation is not atomic. Any IO failure during the copy (including any +-- missing source files) leaves the target in an unknown state so it is best to +-- use it with a freshly created directory so that it can be simply deleted if +-- anything goes wrong. +-- +copyFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO () +copyFiles verbosity targetDir srcFiles = do + + -- Create parent directories for everything + let dirs = map (targetDir ) . nub . map (takeDirectory . snd) $ srcFiles + mapM_ (createDirectoryIfMissingVerbose verbosity True) dirs + + -- Copy all the files + sequence_ [ let src = srcBase srcFile + dest = targetDir srcFile + in copyFileVerbose verbosity src dest + | (srcBase, srcFile) <- srcFiles ] + +-- | This is like 'copyFiles' but uses 'installOrdinaryFile'. +-- +installOrdinaryFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO () +installOrdinaryFiles verbosity targetDir srcFiles = do + + -- Create parent directories for everything + let dirs = map (targetDir ) . nub . map (takeDirectory . snd) $ srcFiles + mapM_ (createDirectoryIfMissingVerbose verbosity True) dirs + + -- Copy all the files + sequence_ [ let src = srcBase srcFile + dest = targetDir srcFile + in installOrdinaryFile verbosity src dest + | (srcBase, srcFile) <- srcFiles ] + +-- | This installs all the files in a directory to a target location, +-- preserving the directory layout. All the files are assumed to be ordinary +-- rather than executable files. +-- +installDirectoryContents :: Verbosity -> FilePath -> FilePath -> IO () +installDirectoryContents verbosity srcDir destDir = do + info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.") + srcFiles <- getDirectoryContentsRecursive srcDir + installOrdinaryFiles verbosity destDir [ (srcDir, f) | f <- srcFiles ] + +--------------------------------- +-- Deprecated file copy functions + +{-# DEPRECATED smartCopySources + "Use findModuleFiles and copyFiles or installOrdinaryFiles" #-} +smartCopySources :: Verbosity -> [FilePath] -> FilePath + -> [ModuleName] -> [String] -> IO () +smartCopySources verbosity searchPath targetDir moduleNames extensions = + findModuleFiles searchPath extensions moduleNames + >>= copyFiles verbosity targetDir + +{-# DEPRECATED copyDirectoryRecursiveVerbose + "You probably want installDirectoryContents instead" #-} +copyDirectoryRecursiveVerbose :: Verbosity -> FilePath -> FilePath -> IO () +copyDirectoryRecursiveVerbose verbosity srcDir destDir = do + info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.") + srcFiles <- getDirectoryContentsRecursive srcDir + copyFiles verbosity destDir [ (srcDir, f) | f <- srcFiles ] + +--------------------------- +-- Temporary files and dirs + +-- | Use a temporary filename that doesn't already exist. +-- +withTempFile :: FilePath -- ^ Temp dir to create the file in + -> String -- ^ File name template. See 'openTempFile'. + -> (FilePath -> Handle -> IO a) -> IO a +withTempFile tmpDir template action = + Exception.bracket + (openTempFile tmpDir template) + (\(name, handle) -> hClose handle >> removeFile name) + (uncurry action) + +-- | Create and use a temporary directory. +-- +-- Creates a new temporary directory inside the given directory, making use +-- of the template. The temp directory is deleted after use. For example: +-- +-- > withTempDirectory verbosity "src" "sdist." $ \tmpDir -> do ... +-- +-- The @tmpDir@ will be a new subdirectory of the given directory, e.g. +-- @src/sdist.342@. +-- +withTempDirectory :: Verbosity -> FilePath -> String -> (FilePath -> IO a) -> IO a +withTempDirectory _verbosity targetDir template = + Exception.bracket + (createTempDirectory targetDir template) + (removeDirectoryRecursive) + +----------------------------------- +-- Safely reading and writing files + +-- | Gets the contents of a file, but guarantee that it gets closed. +-- +-- The file is read lazily but if it is not fully consumed by the action then +-- the remaining input is truncated and the file is closed. +-- +withFileContents :: FilePath -> (String -> IO a) -> IO a +withFileContents name action = + Exception.bracket (openFile name ReadMode) hClose + (\hnd -> hGetContents hnd >>= action) + +-- | Writes a file atomically. +-- +-- The file is either written sucessfully or an IO exception is raised and +-- the original file is left unchanged. +-- +-- On windows it is not possible to delete a file that is open by a process. +-- This case will give an IO exception but the atomic property is not affected. +-- +writeFileAtomic :: FilePath -> String -> IO () +writeFileAtomic targetFile content = do + (tmpFile, tmpHandle) <- openNewBinaryFile targetDir template + do hPutStr tmpHandle content + hClose tmpHandle + renameFile tmpFile targetFile + `onException` do hClose tmpHandle + removeFile tmpFile + where + template = targetName <.> "tmp" + targetDir | null targetDir_ = currentDir + | otherwise = targetDir_ + --TODO: remove this when takeDirectory/splitFileName is fixed + -- to always return a valid dir + (targetDir_,targetName) = splitFileName targetFile + +-- | Write a file but only if it would have new content. If we would be writing +-- the same as the existing content then leave the file as is so that we do not +-- update the file's modification time. +-- +rewriteFile :: FilePath -> String -> IO () +rewriteFile path newContent = + flip catchIO mightNotExist $ do + existingContent <- readFile path + _ <- evaluate (length existingContent) + unless (existingContent == newContent) $ + writeFileAtomic path newContent + where + mightNotExist e | isDoesNotExistError e = writeFileAtomic path newContent + | otherwise = ioError e + +-- | The path name that represents the current directory. +-- In Unix, it's @\".\"@, but this is system-specific. +-- (E.g. AmigaOS uses the empty string @\"\"@ for the current directory.) +currentDir :: FilePath +currentDir = "." + +-- ------------------------------------------------------------ +-- * Finding the description file +-- ------------------------------------------------------------ + +-- |Package description file (/pkgname/@.cabal@) +defaultPackageDesc :: Verbosity -> IO FilePath +defaultPackageDesc _verbosity = findPackageDesc currentDir + +-- |Find a package description file in the given directory. Looks for +-- @.cabal@ files. +findPackageDesc :: FilePath -- ^Where to look + -> IO FilePath -- ^.cabal +findPackageDesc dir + = do files <- getDirectoryContents dir + -- to make sure we do not mistake a ~/.cabal/ dir for a .cabal + -- file we filter to exclude dirs and null base file names: + cabalFiles <- filterM doesFileExist + [ dir file + | file <- files + , let (name, ext) = splitExtension file + , not (null name) && ext == ".cabal" ] + case cabalFiles of + [] -> noDesc + [cabalFile] -> return cabalFile + multiple -> multiDesc multiple + + where + noDesc :: IO a + noDesc = die $ "No cabal file found.\n" + ++ "Please create a package description file .cabal" + + multiDesc :: [String] -> IO a + multiDesc l = die $ "Multiple cabal files found.\n" + ++ "Please use only one of: " + ++ show l + +-- |Optional auxiliary package information file (/pkgname/@.buildinfo@) +defaultHookedPackageDesc :: IO (Maybe FilePath) +defaultHookedPackageDesc = findHookedPackageDesc currentDir + +-- |Find auxiliary package information in the given directory. +-- Looks for @.buildinfo@ files. +findHookedPackageDesc + :: FilePath -- ^Directory to search + -> IO (Maybe FilePath) -- ^/dir/@\/@/pkgname/@.buildinfo@, if present +findHookedPackageDesc dir = do + files <- getDirectoryContents dir + buildInfoFiles <- filterM doesFileExist + [ dir file + | file <- files + , let (name, ext) = splitExtension file + , not (null name) && ext == buildInfoExt ] + case buildInfoFiles of + [] -> return Nothing + [f] -> return (Just f) + _ -> die ("Multiple files with extension " ++ buildInfoExt) + +buildInfoExt :: String +buildInfoExt = ".buildinfo" + +-- ------------------------------------------------------------ +-- * Unicode stuff +-- ------------------------------------------------------------ + +-- This is a modification of the UTF8 code from gtk2hs and the +-- utf8-string package. + +fromUTF8 :: String -> String +fromUTF8 [] = [] +fromUTF8 (c:cs) + | c <= '\x7F' = c : fromUTF8 cs + | c <= '\xBF' = replacementChar : fromUTF8 cs + | c <= '\xDF' = twoBytes c cs + | c <= '\xEF' = moreBytes 3 0x800 cs (ord c .&. 0xF) + | c <= '\xF7' = moreBytes 4 0x10000 cs (ord c .&. 0x7) + | c <= '\xFB' = moreBytes 5 0x200000 cs (ord c .&. 0x3) + | c <= '\xFD' = moreBytes 6 0x4000000 cs (ord c .&. 0x1) + | otherwise = replacementChar : fromUTF8 cs + where + twoBytes c0 (c1:cs') + | ord c1 .&. 0xC0 == 0x80 + = let d = ((ord c0 .&. 0x1F) `shiftL` 6) + .|. (ord c1 .&. 0x3F) + in if d >= 0x80 + then chr d : fromUTF8 cs' + else replacementChar : fromUTF8 cs' + twoBytes _ cs' = replacementChar : fromUTF8 cs' + + moreBytes :: Int -> Int -> [Char] -> Int -> [Char] + moreBytes 1 overlong cs' acc + | overlong <= acc && acc <= 0x10FFFF + && (acc < 0xD800 || 0xDFFF < acc) + && (acc < 0xFFFE || 0xFFFF < acc) + = chr acc : fromUTF8 cs' + + | otherwise + = replacementChar : fromUTF8 cs' + + moreBytes byteCount overlong (cn:cs') acc + | ord cn .&. 0xC0 == 0x80 + = moreBytes (byteCount-1) overlong cs' + ((acc `shiftL` 6) .|. ord cn .&. 0x3F) + + moreBytes _ _ cs' _ + = replacementChar : fromUTF8 cs' + + replacementChar = '\xfffd' + +toUTF8 :: String -> String +toUTF8 [] = [] +toUTF8 (c:cs) + | c <= '\x07F' = c + : toUTF8 cs + | c <= '\x7FF' = chr (0xC0 .|. (w `shiftR` 6)) + : chr (0x80 .|. (w .&. 0x3F)) + : toUTF8 cs + | c <= '\xFFFF'= chr (0xE0 .|. (w `shiftR` 12)) + : chr (0x80 .|. ((w `shiftR` 6) .&. 0x3F)) + : chr (0x80 .|. (w .&. 0x3F)) + : toUTF8 cs + | otherwise = chr (0xf0 .|. (w `shiftR` 18)) + : chr (0x80 .|. ((w `shiftR` 12) .&. 0x3F)) + : chr (0x80 .|. ((w `shiftR` 6) .&. 0x3F)) + : chr (0x80 .|. (w .&. 0x3F)) + : toUTF8 cs + where w = ord c + +-- | Ignore a Unicode byte order mark (BOM) at the beginning of the input +-- +ignoreBOM :: String -> String +ignoreBOM ('\xFEFF':string) = string +ignoreBOM string = string + +-- | Reads a UTF8 encoded text file as a Unicode String +-- +-- Reads lazily using ordinary 'readFile'. +-- +readUTF8File :: FilePath -> IO String +readUTF8File f = fmap (ignoreBOM . fromUTF8) + . hGetContents =<< openBinaryFile f ReadMode + +-- | Reads a UTF8 encoded text file as a Unicode String +-- +-- Same behaviour as 'withFileContents'. +-- +withUTF8FileContents :: FilePath -> (String -> IO a) -> IO a +withUTF8FileContents name action = + Exception.bracket + (openBinaryFile name ReadMode) + hClose + (\hnd -> hGetContents hnd >>= action . ignoreBOM . fromUTF8) + +-- | Writes a Unicode String as a UTF8 encoded text file. +-- +-- Uses 'writeFileAtomic', so provides the same guarantees. +-- +writeUTF8File :: FilePath -> String -> IO () +writeUTF8File path = writeFileAtomic path . toUTF8 + +-- | Fix different systems silly line ending conventions +normaliseLineEndings :: String -> String +normaliseLineEndings [] = [] +normaliseLineEndings ('\r':'\n':s) = '\n' : normaliseLineEndings s -- windows +normaliseLineEndings ('\r':s) = '\n' : normaliseLineEndings s -- old osx +normaliseLineEndings ( c :s) = c : normaliseLineEndings s + +-- ------------------------------------------------------------ +-- * Common utils +-- ------------------------------------------------------------ + +equating :: Eq a => (b -> a) -> b -> b -> Bool +equating p x y = p x == p y + +comparing :: Ord a => (b -> a) -> b -> b -> Ordering +comparing p x y = p x `compare` p y + +isInfixOf :: String -> String -> Bool +isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack) + +intercalate :: [a] -> [[a]] -> [a] +intercalate sep = concat . intersperse sep + +lowercase :: String -> String +lowercase = map Char.toLower diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/Simple.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/Simple.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,677 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Simple +-- Copyright : Isaac Jones 2003-2005 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This is the command line front end to the Simple build system. When given +-- the parsed command-line args and package information, is able to perform +-- basic commands like configure, build, install, register, etc. +-- +-- This module exports the main functions that Setup.hs scripts use. It +-- re-exports the 'UserHooks' type, the standard entry points like +-- 'defaultMain' and 'defaultMainWithHooks' and the predefined sets of +-- 'UserHooks' that custom @Setup.hs@ scripts can extend to add their own +-- behaviour. +-- +-- This module isn't called \"Simple\" because it's simple. Far from +-- it. It's called \"Simple\" because it does complicated things to +-- simple software. +-- +-- The original idea was that there could be different build systems that all +-- presented the same compatible command line interfaces. There is still a +-- "Distribution.Make" system but in practice no packages use it. + +{- All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +{- +Work around this warning: +libraries/Cabal/Distribution/Simple.hs:78:0: + Warning: In the use of `runTests' + (imported from Distribution.Simple.UserHooks): + Deprecated: "Please use the new testing interface instead!" +-} +{-# OPTIONS_GHC -fno-warn-deprecations #-} + +module Distribution.Simple ( + module Distribution.Package, + module Distribution.Version, + module Distribution.License, + module Distribution.Simple.Compiler, + module Language.Haskell.Extension, + -- * Simple interface + defaultMain, defaultMainNoRead, defaultMainArgs, + -- * Customization + UserHooks(..), Args, + defaultMainWithHooks, defaultMainWithHooksArgs, + -- ** Standard sets of hooks + simpleUserHooks, + autoconfUserHooks, + defaultUserHooks, emptyUserHooks, + -- ** Utils + defaultHookedPackageDesc + ) where + +-- local +import Distribution.Simple.Compiler hiding (Flag) +import Distribution.Simple.UserHooks +import Distribution.Package --must not specify imports, since we're exporting moule. +import Distribution.PackageDescription + ( PackageDescription(..), GenericPackageDescription, Executable(..) + , updatePackageDescription, hasLibs + , HookedBuildInfo, emptyHookedBuildInfo ) +import Distribution.PackageDescription.Parse + ( readPackageDescription, readHookedBuildInfo ) +import Distribution.PackageDescription.Configuration + ( flattenPackageDescription ) +import Distribution.Simple.Program + ( defaultProgramConfiguration, addKnownPrograms, builtinPrograms + , restoreProgramConfiguration, reconfigurePrograms ) +import Distribution.Simple.PreProcess (knownSuffixHandlers, PPSuffixHandler) +import Distribution.Simple.Setup +import Distribution.Simple.Command + +import Distribution.Simple.Build ( build ) +import Distribution.Simple.SrcDist ( sdist ) +import Distribution.Simple.Register + ( register, unregister ) + +import Distribution.Simple.Configure + ( getPersistBuildConfig, maybeGetPersistBuildConfig + , writePersistBuildConfig, checkPersistBuildConfigOutdated + , configure, checkForeignDeps ) + +import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) ) +import Distribution.Simple.BuildPaths ( srcPref) +import Distribution.Simple.Test (test) +import Distribution.Simple.Install (install) +import Distribution.Simple.Haddock (haddock, hscolour) +import Distribution.Simple.Utils + (die, notice, info, warn, setupMessage, chattyTry, + defaultPackageDesc, defaultHookedPackageDesc, + rawSystemExitWithEnv, cabalVersion, topHandler ) +import Distribution.System + ( OS(..), buildOS ) +import Distribution.Verbosity +import Language.Haskell.Extension +import Distribution.Version +import Distribution.License +import Distribution.Text + ( display ) + +-- Base +import System.Environment(getArgs, getProgName, getEnvironment) +import System.Directory(removeFile, doesFileExist, + doesDirectoryExist, removeDirectoryRecursive) +import System.Exit +import System.IO.Error (isDoesNotExistError) +import Distribution.Compat.Exception (catchIO, throwIOIO) + +import Control.Monad (when) +import Data.List (intersperse, unionBy, nub, (\\)) + +-- | A simple implementation of @main@ for a Cabal setup script. +-- It reads the package description file using IO, and performs the +-- action specified on the command line. +defaultMain :: IO () +defaultMain = getArgs >>= defaultMainHelper simpleUserHooks + +-- | A version of 'defaultMain' that is passed the command line +-- arguments, rather than getting them from the environment. +defaultMainArgs :: [String] -> IO () +defaultMainArgs = defaultMainHelper simpleUserHooks + +-- | A customizable version of 'defaultMain'. +defaultMainWithHooks :: UserHooks -> IO () +defaultMainWithHooks hooks = getArgs >>= defaultMainHelper hooks + +-- | A customizable version of 'defaultMain' that also takes the command +-- line arguments. +defaultMainWithHooksArgs :: UserHooks -> [String] -> IO () +defaultMainWithHooksArgs = defaultMainHelper + +-- | Like 'defaultMain', but accepts the package description as input +-- rather than using IO to read it. +defaultMainNoRead :: GenericPackageDescription -> IO () +defaultMainNoRead pkg_descr = + getArgs >>= + defaultMainHelper simpleUserHooks { readDesc = return (Just pkg_descr) } + +defaultMainHelper :: UserHooks -> Args -> IO () +defaultMainHelper hooks args = topHandler $ + case commandsRun globalCommand commands args of + CommandHelp help -> printHelp help + CommandList opts -> printOptionsList opts + CommandErrors errs -> printErrors errs + CommandReadyToGo (flags, commandParse) -> + case commandParse of + _ | fromFlag (globalVersion flags) -> printVersion + | fromFlag (globalNumericVersion flags) -> printNumericVersion + CommandHelp help -> printHelp help + CommandList opts -> printOptionsList opts + CommandErrors errs -> printErrors errs + CommandReadyToGo action -> action + + where + printHelp help = getProgName >>= putStr . help + printOptionsList = putStr . unlines + printErrors errs = do + putStr (concat (intersperse "\n" errs)) + exitWith (ExitFailure 1) + printNumericVersion = putStrLn $ display cabalVersion + printVersion = putStrLn $ "Cabal library version " + ++ display cabalVersion + + progs = addKnownPrograms (hookedPrograms hooks) defaultProgramConfiguration + commands = + [configureCommand progs `commandAddAction` \fs as -> + configureAction hooks fs as >> return () + ,buildCommand progs `commandAddAction` buildAction hooks + ,installCommand `commandAddAction` installAction hooks + ,copyCommand `commandAddAction` copyAction hooks + ,haddockCommand `commandAddAction` haddockAction hooks + ,cleanCommand `commandAddAction` cleanAction hooks + ,sdistCommand `commandAddAction` sdistAction hooks + ,hscolourCommand `commandAddAction` hscolourAction hooks + ,registerCommand `commandAddAction` registerAction hooks + ,unregisterCommand `commandAddAction` unregisterAction hooks + ,testCommand `commandAddAction` testAction hooks + ] + +-- | Combine the preprocessors in the given hooks with the +-- preprocessors built into cabal. +allSuffixHandlers :: UserHooks + -> [PPSuffixHandler] +allSuffixHandlers hooks + = overridesPP (hookedPreProcessors hooks) knownSuffixHandlers + where + overridesPP :: [PPSuffixHandler] -> [PPSuffixHandler] -> [PPSuffixHandler] + overridesPP = unionBy (\x y -> fst x == fst y) + +configureAction :: UserHooks -> ConfigFlags -> Args -> IO LocalBuildInfo +configureAction hooks flags args = do + let distPref = fromFlag $ configDistPref flags + pbi <- preConf hooks args flags + + (mb_pd_file, pkg_descr0) <- confPkgDescr + + -- get_pkg_descr (configVerbosity flags') + --let pkg_descr = updatePackageDescription pbi pkg_descr0 + let epkg_descr = (pkg_descr0, pbi) + + --(warns, ers) <- sanityCheckPackage pkg_descr + --errorOut (configVerbosity flags') warns ers + + localbuildinfo0 <- confHook hooks epkg_descr flags + + -- remember the .cabal filename if we know it + -- and all the extra command line args + let localbuildinfo = localbuildinfo0 { + pkgDescrFile = mb_pd_file, + extraConfigArgs = args + } + writePersistBuildConfig distPref localbuildinfo + + let pkg_descr = localPkgDescr localbuildinfo + postConf hooks args flags pkg_descr localbuildinfo + return localbuildinfo + where + verbosity = fromFlag (configVerbosity flags) + confPkgDescr :: IO (Maybe FilePath, GenericPackageDescription) + confPkgDescr = do + mdescr <- readDesc hooks + case mdescr of + Just descr -> return (Nothing, descr) + Nothing -> do + pdfile <- defaultPackageDesc verbosity + descr <- readPackageDescription verbosity pdfile + return (Just pdfile, descr) + +buildAction :: UserHooks -> BuildFlags -> Args -> IO () +buildAction hooks flags args = do + let distPref = fromFlag $ buildDistPref flags + verbosity = fromFlag $ buildVerbosity flags + + lbi <- getBuildConfig hooks verbosity distPref + progs <- reconfigurePrograms verbosity + (buildProgramPaths flags) + (buildProgramArgs flags) + (withPrograms lbi) + + hookedAction preBuild buildHook postBuild + (return lbi { withPrograms = progs }) + hooks flags args + +hscolourAction :: UserHooks -> HscolourFlags -> Args -> IO () +hscolourAction hooks flags args + = do let distPref = fromFlag $ hscolourDistPref flags + verbosity = fromFlag $ hscolourVerbosity flags + hookedAction preHscolour hscolourHook postHscolour + (getBuildConfig hooks verbosity distPref) + hooks flags args + +haddockAction :: UserHooks -> HaddockFlags -> Args -> IO () +haddockAction hooks flags args = do + let distPref = fromFlag $ haddockDistPref flags + verbosity = fromFlag $ haddockVerbosity flags + + lbi <- getBuildConfig hooks verbosity distPref + progs <- reconfigurePrograms verbosity + (haddockProgramPaths flags) + (haddockProgramArgs flags) + (withPrograms lbi) + + hookedAction preHaddock haddockHook postHaddock + (return lbi { withPrograms = progs }) + hooks flags args + +cleanAction :: UserHooks -> CleanFlags -> Args -> IO () +cleanAction hooks flags args = do + pbi <- preClean hooks args flags + + pdfile <- defaultPackageDesc verbosity + ppd <- readPackageDescription verbosity pdfile + let pkg_descr0 = flattenPackageDescription ppd + -- We don't sanity check for clean as an error + -- here would prevent cleaning: + --sanityCheckHookedBuildInfo pkg_descr0 pbi + let pkg_descr = updatePackageDescription pbi pkg_descr0 + + cleanHook hooks pkg_descr () hooks flags + postClean hooks args flags pkg_descr () + where verbosity = fromFlag (cleanVerbosity flags) + +copyAction :: UserHooks -> CopyFlags -> Args -> IO () +copyAction hooks flags args + = do let distPref = fromFlag $ copyDistPref flags + verbosity = fromFlag $ copyVerbosity flags + hookedAction preCopy copyHook postCopy + (getBuildConfig hooks verbosity distPref) + hooks flags args + +installAction :: UserHooks -> InstallFlags -> Args -> IO () +installAction hooks flags args + = do let distPref = fromFlag $ installDistPref flags + verbosity = fromFlag $ installVerbosity flags + hookedAction preInst instHook postInst + (getBuildConfig hooks verbosity distPref) + hooks flags args + +sdistAction :: UserHooks -> SDistFlags -> Args -> IO () +sdistAction hooks flags args = do + let distPref = fromFlag $ sDistDistPref flags + pbi <- preSDist hooks args flags + + mlbi <- maybeGetPersistBuildConfig distPref + pdfile <- defaultPackageDesc verbosity + ppd <- readPackageDescription verbosity pdfile + let pkg_descr0 = flattenPackageDescription ppd + sanityCheckHookedBuildInfo pkg_descr0 pbi + let pkg_descr = updatePackageDescription pbi pkg_descr0 + + sDistHook hooks pkg_descr mlbi hooks flags + postSDist hooks args flags pkg_descr mlbi + where verbosity = fromFlag (sDistVerbosity flags) + +testAction :: UserHooks -> TestFlags -> Args -> IO () +testAction hooks flags args = do + let distPref = fromFlag $ testDistPref flags + verbosity = fromFlag $ testVerbosity flags + localBuildInfo <- getBuildConfig hooks verbosity distPref + let pkg_descr = localPkgDescr localBuildInfo + -- It is safe to do 'runTests' before the new test handler because the + -- default action is a no-op and if the package uses the old test interface + -- the new handler will find no tests. + runTests hooks args False pkg_descr localBuildInfo + --FIXME: this is a hack, passing the args inside the flags + -- it's because the args to not get passed to the main test hook + let flags' = flags { testList = Flag args } + hookedAction preTest testHook postTest + (getBuildConfig hooks verbosity distPref) + hooks flags' args + +registerAction :: UserHooks -> RegisterFlags -> Args -> IO () +registerAction hooks flags args + = do let distPref = fromFlag $ regDistPref flags + verbosity = fromFlag $ regVerbosity flags + hookedAction preReg regHook postReg + (getBuildConfig hooks verbosity distPref) + hooks flags args + +unregisterAction :: UserHooks -> RegisterFlags -> Args -> IO () +unregisterAction hooks flags args + = do let distPref = fromFlag $ regDistPref flags + verbosity = fromFlag $ regVerbosity flags + hookedAction preUnreg unregHook postUnreg + (getBuildConfig hooks verbosity distPref) + hooks flags args + +hookedAction :: (UserHooks -> Args -> flags -> IO HookedBuildInfo) + -> (UserHooks -> PackageDescription -> LocalBuildInfo + -> UserHooks -> flags -> IO ()) + -> (UserHooks -> Args -> flags -> PackageDescription + -> LocalBuildInfo -> IO ()) + -> IO LocalBuildInfo + -> UserHooks -> flags -> Args -> IO () +hookedAction pre_hook cmd_hook post_hook get_build_config hooks flags args = do + pbi <- pre_hook hooks args flags + localbuildinfo <- get_build_config + let pkg_descr0 = localPkgDescr localbuildinfo + --pkg_descr0 <- get_pkg_descr (get_verbose flags) + sanityCheckHookedBuildInfo pkg_descr0 pbi + let pkg_descr = updatePackageDescription pbi pkg_descr0 + -- TODO: should we write the modified package descr back to the + -- localbuildinfo? + cmd_hook hooks pkg_descr localbuildinfo hooks flags + post_hook hooks args flags pkg_descr localbuildinfo + +sanityCheckHookedBuildInfo :: PackageDescription -> HookedBuildInfo -> IO () +sanityCheckHookedBuildInfo PackageDescription { library = Nothing } (Just _,_) + = die $ "The buildinfo contains info for a library, " + ++ "but the package does not have a library." + +sanityCheckHookedBuildInfo pkg_descr (_, hookExes) + | not (null nonExistant) + = die $ "The buildinfo contains info for an executable called '" + ++ head nonExistant ++ "' but the package does not have a " + ++ "executable with that name." + where + pkgExeNames = nub (map exeName (executables pkg_descr)) + hookExeNames = nub (map fst hookExes) + nonExistant = hookExeNames \\ pkgExeNames + +sanityCheckHookedBuildInfo _ _ = return () + + +getBuildConfig :: UserHooks -> Verbosity -> FilePath -> IO LocalBuildInfo +getBuildConfig hooks verbosity distPref = do + lbi_wo_programs <- getPersistBuildConfig distPref + -- Restore info about unconfigured programs, since it is not serialized + let lbi = lbi_wo_programs { + withPrograms = restoreProgramConfiguration + (builtinPrograms ++ hookedPrograms hooks) + (withPrograms lbi_wo_programs) + } + + case pkgDescrFile lbi of + Nothing -> return lbi + Just pkg_descr_file -> do + outdated <- checkPersistBuildConfigOutdated distPref pkg_descr_file + if outdated + then reconfigure pkg_descr_file lbi + else return lbi + + where + reconfigure :: FilePath -> LocalBuildInfo -> IO LocalBuildInfo + reconfigure pkg_descr_file lbi = do + notice verbosity $ pkg_descr_file ++ " has been changed. " + ++ "Re-configuring with most recently used options. " + ++ "If this fails, please run configure manually.\n" + let cFlags = configFlags lbi + let cFlags' = cFlags { + -- Since the list of unconfigured programs is not serialized, + -- restore it to the same value as normally used at the beginning + -- of a conigure run: + configPrograms = restoreProgramConfiguration + (builtinPrograms ++ hookedPrograms hooks) + (configPrograms cFlags), + + -- Use the current, not saved verbosity level: + configVerbosity = Flag verbosity + } + configureAction hooks cFlags' (extraConfigArgs lbi) + + +-- -------------------------------------------------------------------------- +-- Cleaning + +clean :: PackageDescription -> CleanFlags -> IO () +clean pkg_descr flags = do + let distPref = fromFlag $ cleanDistPref flags + notice verbosity "cleaning..." + + maybeConfig <- if fromFlag (cleanSaveConf flags) + then maybeGetPersistBuildConfig distPref + else return Nothing + + -- remove the whole dist/ directory rather than tracking exactly what files + -- we created in there. + chattyTry "removing dist/" $ do + exists <- doesDirectoryExist distPref + when exists (removeDirectoryRecursive distPref) + + -- Any extra files the user wants to remove + mapM_ removeFileOrDirectory (extraTmpFiles pkg_descr) + + -- If the user wanted to save the config, write it back + maybe (return ()) (writePersistBuildConfig distPref) maybeConfig + + where + removeFileOrDirectory :: FilePath -> IO () + removeFileOrDirectory fname = do + isDir <- doesDirectoryExist fname + isFile <- doesFileExist fname + if isDir then removeDirectoryRecursive fname + else if isFile then removeFile fname + else return () + verbosity = fromFlag (cleanVerbosity flags) + +-- -------------------------------------------------------------------------- +-- Default hooks + +-- | Hooks that correspond to a plain instantiation of the +-- \"simple\" build system +simpleUserHooks :: UserHooks +simpleUserHooks = + emptyUserHooks { + confHook = configure, + postConf = finalChecks, + buildHook = defaultBuildHook, + copyHook = \desc lbi _ f -> install desc lbi f, -- has correct 'copy' behavior with params + testHook = defaultTestHook, + instHook = defaultInstallHook, + sDistHook = \p l h f -> sdist p l f srcPref (allSuffixHandlers h), + cleanHook = \p _ _ f -> clean p f, + hscolourHook = \p l h f -> hscolour p l (allSuffixHandlers h) f, + haddockHook = \p l h f -> haddock p l (allSuffixHandlers h) f, + regHook = defaultRegHook, + unregHook = \p l _ f -> unregister p l f + } + where + finalChecks _args flags pkg_descr lbi = + checkForeignDeps pkg_descr lbi (lessVerbose verbosity) + where + verbosity = fromFlag (configVerbosity flags) + +-- | Basic autoconf 'UserHooks': +-- +-- * 'postConf' runs @.\/configure@, if present. +-- +-- * the pre-hooks 'preBuild', 'preClean', 'preCopy', 'preInst', +-- 'preReg' and 'preUnreg' read additional build information from +-- /package/@.buildinfo@, if present. +-- +-- Thus @configure@ can use local system information to generate +-- /package/@.buildinfo@ and possibly other files. + +{-# DEPRECATED defaultUserHooks + "Use simpleUserHooks or autoconfUserHooks, unless you need Cabal-1.2\n compatibility in which case you must stick with defaultUserHooks" #-} +defaultUserHooks :: UserHooks +defaultUserHooks = autoconfUserHooks { + confHook = \pkg flags -> do + let verbosity = fromFlag (configVerbosity flags) + warn verbosity $ + "defaultUserHooks in Setup script is deprecated." + confHook autoconfUserHooks pkg flags, + postConf = oldCompatPostConf + } + -- This is the annoying old version that only runs configure if it exists. + -- It's here for compatibility with existing Setup.hs scripts. See: + -- http://hackage.haskell.org/trac/hackage/ticket/165 + where oldCompatPostConf args flags pkg_descr lbi + = do let verbosity = fromFlag (configVerbosity flags) + noExtraFlags args + confExists <- doesFileExist "configure" + when confExists $ + runConfigureScript verbosity + backwardsCompatHack flags lbi + + pbi <- getHookedBuildInfo verbosity + sanityCheckHookedBuildInfo pkg_descr pbi + let pkg_descr' = updatePackageDescription pbi pkg_descr + postConf simpleUserHooks args flags pkg_descr' lbi + + backwardsCompatHack = True + +autoconfUserHooks :: UserHooks +autoconfUserHooks + = simpleUserHooks + { + postConf = defaultPostConf, + preBuild = readHook buildVerbosity, + preClean = readHook cleanVerbosity, + preCopy = readHook copyVerbosity, + preInst = readHook installVerbosity, + preHscolour = readHook hscolourVerbosity, + preHaddock = readHook haddockVerbosity, + preReg = readHook regVerbosity, + preUnreg = readHook regVerbosity + } + where defaultPostConf :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO () + defaultPostConf args flags pkg_descr lbi + = do let verbosity = fromFlag (configVerbosity flags) + noExtraFlags args + confExists <- doesFileExist "configure" + if confExists + then runConfigureScript verbosity + backwardsCompatHack flags lbi + else die "configure script not found." + + pbi <- getHookedBuildInfo verbosity + sanityCheckHookedBuildInfo pkg_descr pbi + let pkg_descr' = updatePackageDescription pbi pkg_descr + postConf simpleUserHooks args flags pkg_descr' lbi + + backwardsCompatHack = False + + readHook :: (a -> Flag Verbosity) -> Args -> a -> IO HookedBuildInfo + readHook get_verbosity a flags = do + noExtraFlags a + getHookedBuildInfo verbosity + where + verbosity = fromFlag (get_verbosity flags) + +runConfigureScript :: Verbosity -> Bool -> ConfigFlags -> LocalBuildInfo + -> IO () +runConfigureScript verbosity backwardsCompatHack flags lbi = do + + env <- getEnvironment + let programConfig = withPrograms lbi + (ccProg, ccFlags) <- configureCCompiler verbosity programConfig + -- The C compiler's compilation and linker flags (e.g. + -- "C compiler flags" and "Gcc Linker flags" from GHC) have already + -- been merged into ccFlags, so we set both CFLAGS and LDFLAGS + -- to ccFlags + -- We don't try and tell configure which ld to use, as we don't have + -- a way to pass its flags too + let env' = appendToEnvironment ("CFLAGS", unwords ccFlags) + env + args' = args ++ ["--with-gcc=" ++ ccProg] + handleNoWindowsSH $ + rawSystemExitWithEnv verbosity "sh" args' env' + + where + args = "configure" : configureArgs backwardsCompatHack flags + + appendToEnvironment (key, val) [] = [(key, val)] + appendToEnvironment (key, val) (kv@(k, v) : rest) + | key == k = (key, v ++ " " ++ val) : rest + | otherwise = kv : appendToEnvironment (key, val) rest + + handleNoWindowsSH action + | buildOS /= Windows + = action + + | otherwise + = action + `catchIO` \ioe -> if isDoesNotExistError ioe + then die notFoundMsg + else throwIOIO ioe + + notFoundMsg = "The package has a './configure' script. This requires a " + ++ "Unix compatibility toolchain such as MinGW+MSYS or Cygwin." + +getHookedBuildInfo :: Verbosity -> IO HookedBuildInfo +getHookedBuildInfo verbosity = do + maybe_infoFile <- defaultHookedPackageDesc + case maybe_infoFile of + Nothing -> return emptyHookedBuildInfo + Just infoFile -> do + info verbosity $ "Reading parameters from " ++ infoFile + readHookedBuildInfo verbosity infoFile + +defaultTestHook :: PackageDescription -> LocalBuildInfo + -> UserHooks -> TestFlags -> IO () +defaultTestHook pkg_descr localbuildinfo _ flags = + test pkg_descr localbuildinfo flags + +defaultInstallHook :: PackageDescription -> LocalBuildInfo + -> UserHooks -> InstallFlags -> IO () +defaultInstallHook pkg_descr localbuildinfo _ flags = do + let copyFlags = defaultCopyFlags { + copyDistPref = installDistPref flags, + copyDest = toFlag NoCopyDest, + copyVerbosity = installVerbosity flags + } + install pkg_descr localbuildinfo copyFlags + let registerFlags = defaultRegisterFlags { + regDistPref = installDistPref flags, + regInPlace = installInPlace flags, + regPackageDB = installPackageDB flags, + regVerbosity = installVerbosity flags + } + when (hasLibs pkg_descr) $ register pkg_descr localbuildinfo registerFlags + +defaultBuildHook :: PackageDescription -> LocalBuildInfo + -> UserHooks -> BuildFlags -> IO () +defaultBuildHook pkg_descr localbuildinfo hooks flags = + build pkg_descr localbuildinfo flags (allSuffixHandlers hooks) + +defaultRegHook :: PackageDescription -> LocalBuildInfo + -> UserHooks -> RegisterFlags -> IO () +defaultRegHook pkg_descr localbuildinfo _ flags = + if hasLibs pkg_descr + then register pkg_descr localbuildinfo flags + else setupMessage verbosity + "Package contains no library to register:" (packageId pkg_descr) + where verbosity = fromFlag (regVerbosity flags) diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/System.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/System.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/System.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/System.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,179 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.System +-- Copyright : Duncan Coutts 2007-2008 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Cabal often needs to do slightly different things on specific platforms. You +-- probably know about the 'System.Info.os' however using that is very +-- inconvenient because it is a string and different Haskell implementations +-- do not agree on using the same strings for the same platforms! (In +-- particular see the controversy over \"windows\" vs \"ming32\"). So to make it +-- more consistent and easy to use we have an 'OS' enumeration. +-- +module Distribution.System ( + -- * Operating System + OS(..), + buildOS, + + -- * Machine Architecture + Arch(..), + buildArch, + + -- * Platform is a pair of arch and OS + Platform(..), + buildPlatform, + ) where + +import qualified System.Info (os, arch) +import qualified Data.Char as Char (toLower, isAlphaNum) + +import Distribution.Text (Text(..), display) +import qualified Distribution.Compat.ReadP as Parse +import qualified Text.PrettyPrint as Disp +import Text.PrettyPrint ((<>)) + +-- | How strict to be when classifying strings into the 'OS' and 'Arch' enums. +-- +-- The reason we have multiple ways to do the classification is because there +-- are two situations where we need to do it. +-- +-- For parsing os and arch names in .cabal files we really want everyone to be +-- referring to the same or or arch by the same name. Variety is not a virtue +-- in this case. We don't mind about case though. +-- +-- For the System.Info.os\/arch different Haskell implementations use different +-- names for the same or\/arch. Also they tend to distinguish versions of an +-- os\/arch which we just don't care about. +-- +-- The 'Compat' classification allows us to recognise aliases that are already +-- in common use but it allows us to distinguish them from the canonical name +-- which enables us to warn about such deprecated aliases. +-- +data ClassificationStrictness = Permissive | Compat | Strict + +-- ------------------------------------------------------------ +-- * Operating System +-- ------------------------------------------------------------ + +data OS = Linux | Windows | OSX -- teir 1 desktop OSs + | FreeBSD | OpenBSD | NetBSD -- other free unix OSs + | Solaris | AIX | HPUX | IRIX -- ageing Unix OSs + | HaLVM -- bare metal / VMs / hypervisors + | OtherOS String + deriving (Eq, Ord, Show, Read) + +--TODO: decide how to handle Android and iOS. +-- They are like Linux and OSX but with some differences. +-- Should they be separate from linux/osx, or a subtype? +-- e.g. should we have os(linux) && os(android) true simultaneously? + +knownOSs :: [OS] +knownOSs = [Linux, Windows, OSX + ,FreeBSD, OpenBSD, NetBSD + ,Solaris, AIX, HPUX, IRIX + ,HaLVM] + +osAliases :: ClassificationStrictness -> OS -> [String] +osAliases Permissive Windows = ["mingw32", "cygwin32"] +osAliases Compat Windows = ["mingw32", "win32"] +osAliases _ OSX = ["darwin"] +osAliases Permissive FreeBSD = ["kfreebsdgnu"] +osAliases Permissive Solaris = ["solaris2"] +osAliases _ _ = [] + +instance Text OS where + disp (OtherOS name) = Disp.text name + disp other = Disp.text (lowercase (show other)) + + parse = fmap (classifyOS Compat) ident + +classifyOS :: ClassificationStrictness -> String -> OS +classifyOS strictness s = + case lookup (lowercase s) osMap of + Just os -> os + Nothing -> OtherOS s + where + osMap = [ (name, os) + | os <- knownOSs + , name <- display os : osAliases strictness os ] + +buildOS :: OS +buildOS = classifyOS Permissive System.Info.os + +-- ------------------------------------------------------------ +-- * Machine Architecture +-- ------------------------------------------------------------ + +data Arch = I386 | X86_64 | PPC | PPC64 | Sparc + | Arm | Mips | SH + | IA64 | S390 + | Alpha | Hppa | Rs6000 + | M68k | Vax + | OtherArch String + deriving (Eq, Ord, Show, Read) + +knownArches :: [Arch] +knownArches = [I386, X86_64, PPC, PPC64, Sparc + ,Arm, Mips, SH + ,IA64, S390 + ,Alpha, Hppa, Rs6000 + ,M68k, Vax] + +archAliases :: ClassificationStrictness -> Arch -> [String] +archAliases Strict _ = [] +archAliases Compat _ = [] +archAliases _ PPC = ["powerpc"] +archAliases _ PPC64 = ["powerpc64"] +archAliases _ Sparc = ["sparc64", "sun4"] +archAliases _ Mips = ["mipsel", "mipseb"] +archAliases _ Arm = ["armeb", "armel"] +archAliases _ _ = [] + +instance Text Arch where + disp (OtherArch name) = Disp.text name + disp other = Disp.text (lowercase (show other)) + + parse = fmap (classifyArch Strict) ident + +classifyArch :: ClassificationStrictness -> String -> Arch +classifyArch strictness s = + case lookup (lowercase s) archMap of + Just arch -> arch + Nothing -> OtherArch s + where + archMap = [ (name, arch) + | arch <- knownArches + , name <- display arch : archAliases strictness arch ] + +buildArch :: Arch +buildArch = classifyArch Permissive System.Info.arch + +-- ------------------------------------------------------------ +-- * Platform +-- ------------------------------------------------------------ + +data Platform = Platform Arch OS + deriving (Eq, Ord, Show, Read) + +instance Text Platform where + disp (Platform arch os) = disp arch <> Disp.char '-' <> disp os + parse = do + arch <- parse + _ <- Parse.char '-' + os <- parse + return (Platform arch os) + +buildPlatform :: Platform +buildPlatform = Platform buildArch buildOS + +-- Utils: + +ident :: Parse.ReadP r String +ident = Parse.munch1 (\c -> Char.isAlphaNum c || c == '_' || c == '-') + --TODO: probably should disallow starting with a number + +lowercase :: String -> String +lowercase = map Char.toLower diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/TestSuite.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/TestSuite.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/TestSuite.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/TestSuite.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,310 @@ +{-# LANGUAGE CPP, ExistentialQuantification #-} +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.TestSuite +-- Copyright : Thomas Tuegel 2010 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This module defines the detailed test suite interface which makes it +-- possible to expose individual tests to Cabal or other test agents. + +{- All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +#if !(defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 610)) +#define NEW_EXCEPTION +#endif + +module Distribution.TestSuite + ( -- * Example + -- $example + -- * Options + Options(..) + , lookupOption + , TestOptions(..) + -- * Tests + , Test + , pure, impure + , Result(..) + , ImpureTestable(..) + , PureTestable(..) + ) where + +#ifdef NEW_EXCEPTION +import Control.Exception ( evaluate, catch, throw, SomeException, fromException ) +#else +import Control.Exception ( evaluate, catch, throw, Exception(IOException) ) +#endif + +--TODO: it is totally unreasonable that we have to import things from GHC.* here. +-- see ghc ticket #3517 +#ifdef __GLASGOW_HASKELL__ +#if __GLASGOW_HASKELL__ >= 612 +import GHC.IO.Exception ( IOErrorType(Interrupted) ) +#else +import GHC.IOBase ( IOErrorType(Interrupted) ) +#endif +import System.IO.Error ( ioeGetErrorType ) +#endif + +import Data.List ( unionBy ) +import Data.Monoid ( Monoid(..) ) +import Data.Typeable ( TypeRep ) +import Prelude hiding ( catch ) + +-- | 'Options' are provided to pass options to test runners, making tests +-- reproducable. Each option is a @('String', 'String')@ of the form +-- @(Name, Value)@. Use 'mappend' to combine sets of 'Options'; if the same +-- option is given different values, the value from the left argument of +-- 'mappend' will be used. +newtype Options = Options [(String, String)] + deriving (Read, Show, Eq) + +instance Monoid Options where + mempty = Options [] + mappend (Options a) (Options b) = Options $ unionBy (equating fst) a b + where + equating p x y = p x == p y + + +class TestOptions t where + -- | The name of the test. + name :: t -> String + + -- | A list of the options a test recognizes. The name and 'TypeRep' are + -- provided so that test agents can ensure that user-specified options are + -- correctly typed. + options :: t -> [(String, TypeRep)] + + -- | The default options for a test. Test frameworks should provide a new + -- random seed, if appropriate. + defaultOptions :: t -> IO Options + + -- | Try to parse the provided options. Return the names of unparsable + -- options. This allows test agents to detect bad user-specified options. + check :: t -> Options -> [String] + +-- | Read an option from the specified set of 'Options'. It is an error to +-- lookup an option that has not been specified. For this reason, test agents +-- should 'mappend' any 'Options' against the 'defaultOptions' for a test, so +-- the default value specified by the test framework will be used for any +-- otherwise-unspecified options. +lookupOption :: Read r => String -> Options -> r +lookupOption n (Options opts) = + case lookup n opts of + Just str -> read str + Nothing -> error $ "test option not specified: " ++ n + +data Result + = Pass -- ^ indicates a successful test + | Fail String -- ^ indicates a test completed unsuccessfully; + -- the 'String' value should be a human-readable message + -- indicating how the test failed. + | Error String -- ^ indicates a test that could not be + -- completed due to some error; the test framework + -- should provide a message indicating the + -- nature of the error. + deriving (Read, Show, Eq) + +-- | Class abstracting impure tests. Test frameworks should implement this +-- class only as a last resort for test types which actually require 'IO'. +-- In particular, tests that simply require pseudo-random number generation can +-- be implemented as pure tests. +class TestOptions t => ImpureTestable t where + -- | Runs an impure test and returns the result. Test frameworks + -- implementing this class are responsible for converting any exceptions to + -- the correct 'Result' value. + runM :: t -> Options -> IO Result + +-- | Class abstracting pure tests. Test frameworks should prefer to implement +-- this class over 'ImpureTestable'. A default instance exists so that any pure +-- test can be lifted into an impure test; when lifted, any exceptions are +-- automatically caught. Test agents that lift pure tests themselves must +-- handle exceptions. +class TestOptions t => PureTestable t where + -- | The result of a pure test. + run :: t -> Options -> Result + +-- | 'Test' is a wrapper for pure and impure tests so that lists containing +-- arbitrary test types can be constructed. +data Test + = forall p. PureTestable p => PureTest p + | forall i. ImpureTestable i => ImpureTest i + +-- | A convenient function for wrapping pure tests into 'Test's. +pure :: PureTestable p => p -> Test +pure = PureTest + +-- | A convenient function for wrapping impure tests into 'Test's. +impure :: ImpureTestable i => i -> Test +impure = ImpureTest + +instance TestOptions Test where + name (PureTest p) = name p + name (ImpureTest i) = name i + + options (PureTest p) = options p + options (ImpureTest i) = options i + + defaultOptions (PureTest p) = defaultOptions p + defaultOptions (ImpureTest p) = defaultOptions p + + check (PureTest p) = check p + check (ImpureTest p) = check p + +instance ImpureTestable Test where + runM (PureTest p) o = catch (evaluate $ run p o) handler + + -- Because we have to handle old and new style exceptions, GHC and non-GHC + -- this code is totally horrible and really fragile. Has to be tested with + -- lots of ghc versions to check it is right, and with non-ghc too. :-( +#ifdef NEW_EXCEPTION + where + handler :: SomeException -> IO Result + handler e = case fromException e of + Just ioe | isInterruptedError ioe -> throw e + _ -> return (Error (show e)) +#else + where + handler :: Exception -> IO Result + handler e = case e of + IOException ioe | isInterruptedError ioe -> throw e + _ -> return (Error (show e)) +#endif + + -- We do not want to catch control-C here, but only GHC + -- defines the Interrupted exception type! (ticket #3517) + isInterruptedError ioe = +#ifdef __GLASGOW_HASKELL__ + ioeGetErrorType ioe == Interrupted +#else + False +#endif + + runM (ImpureTest i) o = runM i o + +-- $example +-- The following terms are used carefully throughout this file: +-- +-- [test interface] The interface provided by this module. +-- +-- [test agent] A program used by package users to coordinates the running +-- of tests and the reporting of their results. +-- +-- [test framework] A package used by software authors to specify tests, +-- such as QuickCheck or HUnit. +-- +-- Test frameworks are obligated to supply, at least, instances of the +-- 'TestOptions' and 'ImpureTestable' classes. It is preferred that test +-- frameworks implement 'PureTestable' whenever possible, so that test agents +-- have an assurance that tests can be safely run in parallel. +-- +-- Test agents that allow the user to specify options should avoid setting +-- options not listed by the 'options' method. Test agents should use 'check' +-- before running tests with non-default options. Test frameworks must +-- implement a 'check' function that attempts to parse the given options safely. +-- +-- The packages cabal-test-hunit, cabal-test-quickcheck1, and +-- cabal-test-quickcheck2 provide simple interfaces to these popular test +-- frameworks. An example from cabal-test-quickcheck2 is shown below. A +-- better implementation would eliminate the console output from QuickCheck\'s +-- built-in runner and provide an instance of 'PureTestable' instead of +-- 'ImpureTestable'. +-- +-- > import Control.Monad (liftM) +-- > import Data.Maybe (catMaybes, fromJust, maybe) +-- > import Data.Typeable (Typeable(..)) +-- > import qualified Distribution.TestSuite as Cabal +-- > import System.Random (newStdGen, next, StdGen) +-- > import qualified Test.QuickCheck as QC +-- > +-- > data QCTest = forall prop. QC.Testable prop => QCTest String prop +-- > +-- > test :: QC.Testable prop => String -> prop -> Cabal.Test +-- > test n p = Cabal.impure $ QCTest n p +-- > +-- > instance Cabal.TestOptions QCTest where +-- > name (QCTest n _) = n +-- > +-- > options _ = +-- > [ ("std-gen", typeOf (undefined :: String)) +-- > , ("max-success", typeOf (undefined :: Int)) +-- > , ("max-discard", typeOf (undefined :: Int)) +-- > , ("size", typeOf (undefined :: Int)) +-- > ] +-- > +-- > defaultOptions _ = do +-- > rng <- newStdGen +-- > return $ Cabal.Options $ +-- > [ ("std-gen", show rng) +-- > , ("max-success", show $ QC.maxSuccess QC.stdArgs) +-- > , ("max-discard", show $ QC.maxDiscard QC.stdArgs) +-- > , ("size", show $ QC.maxSize QC.stdArgs) +-- > ] +-- > +-- > check t (Cabal.Options opts) = catMaybes +-- > [ maybeNothing "max-success" ([] :: [(Int, String)]) +-- > , maybeNothing "max-discard" ([] :: [(Int, String)]) +-- > , maybeNothing "size" ([] :: [(Int, String)]) +-- > ] +-- > -- There is no need to check the parsability of "std-gen" +-- > -- because the Read instance for StdGen always succeeds. +-- > where +-- > maybeNothing n x = +-- > maybe Nothing (\str -> +-- > if reads str == x then Just n else Nothing) +-- > $ lookup n opts +-- > +-- > instance Cabal.ImpureTestable QCTest where +-- > runM (QCTest _ prop) o = +-- > catch go (return . Cabal.Error . show) +-- > where +-- > go = do +-- > result <- QC.quickCheckWithResult args prop +-- > return $ case result of +-- > QC.Success {} -> Cabal.Pass +-- > QC.GaveUp {}-> +-- > Cabal.Fail $ "gave up after " +-- > ++ show (QC.numTests result) +-- > ++ " tests" +-- > QC.Failure {} -> Cabal.Fail $ QC.reason result +-- > QC.NoExpectedFailure {} -> +-- > Cabal.Fail "passed (expected failure)" +-- > args = QC.Args +-- > { QC.replay = Just +-- > ( Cabal.lookupOption "std-gen" o +-- > , Cabal.lookupOption "size" o +-- > ) +-- > , QC.maxSuccess = Cabal.lookupOption "max-success" o +-- > , QC.maxDiscard = Cabal.lookupOption "max-discard" o +-- > , QC.maxSize = Cabal.lookupOption "size" o +-- > } diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/Text.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/Text.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/Text.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/Text.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,68 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Text +-- Copyright : Duncan Coutts 2007 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- This defines a 'Text' class which is a bit like the 'Read' and 'Show' +-- classes. The difference is that is uses a modern pretty printer and parser +-- system and the format is not expected to be Haskell concrete syntax but +-- rather the external human readable representation used by Cabal. +-- +module Distribution.Text ( + Text(..), + display, + simpleParse, + ) where + +import qualified Distribution.Compat.ReadP as Parse +import qualified Text.PrettyPrint as Disp + +import Data.Version (Version(Version)) +import qualified Data.Char as Char (isDigit, isAlphaNum, isSpace) + +class Text a where + disp :: a -> Disp.Doc + parse :: Parse.ReadP r a + +display :: Text a => a -> String +display = Disp.renderStyle style . disp + where style = Disp.Style { + Disp.mode = Disp.PageMode, + Disp.lineLength = 79, + Disp.ribbonsPerLine = 1.0 + } + +simpleParse :: Text a => String -> Maybe a +simpleParse str = case [ p | (p, s) <- Parse.readP_to_S parse str + , all Char.isSpace s ] of + [] -> Nothing + (p:_) -> Just p + +-- ----------------------------------------------------------------------------- +-- Instances for types from the base package + +instance Text Bool where + disp = Disp.text . show + parse = Parse.choice [ (Parse.string "True" Parse.+++ + Parse.string "true") >> return True + , (Parse.string "False" Parse.+++ + Parse.string "false") >> return False ] + +instance Text Version where + disp (Version branch _tags) -- Death to version tags!! + = Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int branch)) + + parse = do + branch <- Parse.sepBy1 digits (Parse.char '.') + tags <- Parse.many (Parse.char '-' >> Parse.munch1 Char.isAlphaNum) + return (Version branch tags) --TODO: should we ignore the tags? + where + digits = do + first <- Parse.satisfy Char.isDigit + if first == '0' + then return 0 + else do rest <- Parse.munch Char.isDigit + return (read (first : rest)) diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/Verbosity.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/Verbosity.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/Verbosity.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/Verbosity.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,113 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Verbosity +-- Copyright : Ian Lynagh 2007 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- A simple 'Verbosity' type with associated utilities. There are 4 standard +-- verbosity levels from 'silent', 'normal', 'verbose' up to 'deafening'. This +-- is used for deciding what logging messages to print. + +-- Verbosity for Cabal functions + +{- Copyright (c) 2007, Ian Lynagh +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.Verbosity ( + -- * Verbosity + Verbosity, + silent, normal, verbose, deafening, + moreVerbose, lessVerbose, + intToVerbosity, flagToVerbosity, + showForCabal, showForGHC + ) where + +import Data.List (elemIndex) +import Distribution.ReadE + +data Verbosity = Silent | Normal | Verbose | Deafening + deriving (Show, Read, Eq, Ord, Enum, Bounded) + +-- We shouldn't print /anything/ unless an error occurs in silent mode +silent :: Verbosity +silent = Silent + +-- Print stuff we want to see by default +normal :: Verbosity +normal = Normal + +-- Be more verbose about what's going on +verbose :: Verbosity +verbose = Verbose + +-- Not only are we verbose ourselves (perhaps even noisier than when +-- being "verbose"), but we tell everything we run to be verbose too +deafening :: Verbosity +deafening = Deafening + +moreVerbose :: Verbosity -> Verbosity +moreVerbose Silent = Silent --silent should stay silent +moreVerbose Normal = Verbose +moreVerbose Verbose = Deafening +moreVerbose Deafening = Deafening + +lessVerbose :: Verbosity -> Verbosity +lessVerbose Deafening = Deafening +lessVerbose Verbose = Normal +lessVerbose Normal = Silent +lessVerbose Silent = Silent + +intToVerbosity :: Int -> Maybe Verbosity +intToVerbosity 0 = Just Silent +intToVerbosity 1 = Just Normal +intToVerbosity 2 = Just Verbose +intToVerbosity 3 = Just Deafening +intToVerbosity _ = Nothing + +flagToVerbosity :: ReadE Verbosity +flagToVerbosity = ReadE $ \s -> + case reads s of + [(i, "")] -> + case intToVerbosity i of + Just v -> Right v + Nothing -> Left ("Bad verbosity: " ++ show i ++ + ". Valid values are 0..3") + _ -> Left ("Can't parse verbosity " ++ s) + +showForCabal, showForGHC :: Verbosity -> String + +showForCabal v = maybe (error "unknown verbosity") show $ + elemIndex v [silent,normal,verbose,deafening] +showForGHC v = maybe (error "unknown verbosity") show $ + elemIndex v [silent,normal,__,verbose,deafening] + where __ = silent -- this will be always ignored by elemIndex diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Distribution/Version.hs ghc-7.2.1/libraries/Cabal/cabal/Distribution/Version.hs --- ghc-7.0.3/libraries/Cabal/cabal/Distribution/Version.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Distribution/Version.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,742 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Distribution.Version +-- Copyright : Isaac Jones, Simon Marlow 2003-2004 +-- Duncan Coutts 2008 +-- +-- Maintainer : cabal-devel@haskell.org +-- Portability : portable +-- +-- Exports the 'Version' type along with a parser and pretty printer. A version +-- is something like @\"1.3.3\"@. It also defines the 'VersionRange' data +-- types. Version ranges are like @\">= 1.2 && < 2\"@. + +{- Copyright (c) 2003-2004, Isaac Jones +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Distribution.Version ( + -- * Package versions + Version(..), + + -- * Version ranges + VersionRange(..), + + -- ** Constructing + anyVersion, noVersion, + thisVersion, notThisVersion, + laterVersion, earlierVersion, + orLaterVersion, orEarlierVersion, + unionVersionRanges, intersectVersionRanges, + withinVersion, + betweenVersionsInclusive, + + -- ** Inspection + withinRange, + isAnyVersion, + isNoVersion, + isSpecificVersion, + simplifyVersionRange, + foldVersionRange, + foldVersionRange', + + -- * Version intervals view + asVersionIntervals, + VersionInterval, + LowerBound(..), + UpperBound(..), + Bound(..), + + -- ** 'VersionIntervals' abstract type + -- | The 'VersionIntervals' type and the accompanying functions are exposed + -- primarily for completeness and testing purposes. In practice + -- 'asVersionIntervals' is the main function to use to + -- view a 'VersionRange' as a bunch of 'VersionInterval's. + -- + VersionIntervals, + toVersionIntervals, + fromVersionIntervals, + withinIntervals, + versionIntervals, + mkVersionIntervals, + unionVersionIntervals, + intersectVersionIntervals, + + ) where + +import Data.Version ( Version(..) ) + +import Distribution.Text ( Text(..) ) +import qualified Distribution.Compat.ReadP as Parse +import Distribution.Compat.ReadP ((+++)) +import qualified Text.PrettyPrint as Disp +import Text.PrettyPrint ((<>), (<+>)) +import qualified Data.Char as Char (isDigit) +import Control.Exception (assert) + +-- ----------------------------------------------------------------------------- +-- Version ranges + +-- Todo: maybe move this to Distribution.Package.Version? +-- (package-specific versioning scheme). + +data VersionRange + = AnyVersion + | ThisVersion Version -- = version + | LaterVersion Version -- > version (NB. not >=) + | EarlierVersion Version -- < version + | WildcardVersion Version -- == ver.* (same as >= ver && < ver+1) + | UnionVersionRanges VersionRange VersionRange + | IntersectVersionRanges VersionRange VersionRange + | VersionRangeParens VersionRange -- just '(exp)' parentheses syntax + deriving (Show,Read,Eq) + +{-# DEPRECATED AnyVersion "Use 'anyVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} +{-# DEPRECATED ThisVersion "use 'thisVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} +{-# DEPRECATED LaterVersion "use 'laterVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} +{-# DEPRECATED EarlierVersion "use 'earlierVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} +{-# DEPRECATED WildcardVersion "use 'anyVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} +{-# DEPRECATED UnionVersionRanges "use 'unionVersionRanges', 'foldVersionRange' or 'asVersionIntervals'" #-} +{-# DEPRECATED IntersectVersionRanges "use 'intersectVersionRanges', 'foldVersionRange' or 'asVersionIntervals'" #-} + +-- | The version range @-any@. That is, a version range containing all +-- versions. +-- +-- > withinRange v anyVersion = True +-- +anyVersion :: VersionRange +anyVersion = AnyVersion + +-- | The empty version range, that is a version range containing no versions. +-- +-- This can be constructed using any unsatisfiable version range expression, +-- for example @> 1 && < 1@. +-- +-- > withinRange v anyVersion = False +-- +noVersion :: VersionRange +noVersion = IntersectVersionRanges (LaterVersion v) (EarlierVersion v) + where v = Version [1] [] + +-- | The version range @== v@ +-- +-- > withinRange v' (thisVersion v) = v' == v +-- +thisVersion :: Version -> VersionRange +thisVersion = ThisVersion + +-- | The version range @< v || > v@ +-- +-- > withinRange v' (notThisVersion v) = v' /= v +-- +notThisVersion :: Version -> VersionRange +notThisVersion v = UnionVersionRanges (EarlierVersion v) (LaterVersion v) + +-- | The version range @> v@ +-- +-- > withinRange v' (laterVersion v) = v' > v +-- +laterVersion :: Version -> VersionRange +laterVersion = LaterVersion + +-- | The version range @>= v@ +-- +-- > withinRange v' (orLaterVersion v) = v' >= v +-- +orLaterVersion :: Version -> VersionRange +orLaterVersion v = UnionVersionRanges (ThisVersion v) (LaterVersion v) + +-- | The version range @< v@ +-- +-- > withinRange v' (earlierVersion v) = v' < v +-- +earlierVersion :: Version -> VersionRange +earlierVersion = EarlierVersion + +-- | The version range @<= v@ +-- +-- > withinRange v' (orEarlierVersion v) = v' <= v +-- +orEarlierVersion :: Version -> VersionRange +orEarlierVersion v = UnionVersionRanges (ThisVersion v) (EarlierVersion v) + +-- | The version range @vr1 || vr2@ +-- +-- > withinRange v' (unionVersionRanges vr1 vr2) +-- > = withinRange v' vr1 || withinRange v' vr2 +-- +unionVersionRanges :: VersionRange -> VersionRange -> VersionRange +unionVersionRanges = UnionVersionRanges + +-- | The version range @vr1 && vr2@ +-- +-- > withinRange v' (intersectVersionRanges vr1 vr2) +-- > = withinRange v' vr1 && withinRange v' vr2 +-- +intersectVersionRanges :: VersionRange -> VersionRange -> VersionRange +intersectVersionRanges = IntersectVersionRanges + +-- | The version range @== v.*@. +-- +-- For example, for version @1.2@, the version range @== 1.2.*@ is the same as +-- @>= 1.2 && < 1.3@ +-- +-- > withinRange v' (laterVersion v) = v' >= v && v' < upper v +-- > where +-- > upper (Version lower t) = Version (init lower ++ [last lower + 1]) t +-- +withinVersion :: Version -> VersionRange +withinVersion = WildcardVersion + +-- | The version range @>= v1 && <= v2@. +-- +-- In practice this is not very useful because we normally use inclusive lower +-- bounds and exclusive upper bounds. +-- +-- > withinRange v' (laterVersion v) = v' > v +-- +betweenVersionsInclusive :: Version -> Version -> VersionRange +betweenVersionsInclusive v1 v2 = + IntersectVersionRanges (orLaterVersion v1) (orEarlierVersion v2) + +{-# DEPRECATED betweenVersionsInclusive + "In practice this is not very useful because we normally use inclusive lower bounds and exclusive upper bounds" + #-} + +-- | Fold over the basic syntactic structure of a 'VersionRange'. +-- +-- This provides a syntacic view of the expression defining the version range. +-- The syntactic sugar @\">= v\"@, @\"<= v\"@ and @\"== v.*\"@ is presented +-- in terms of the other basic syntax. +-- +-- For a semantic view use 'asVersionIntervals'. +-- +foldVersionRange :: a -- ^ @\"-any\"@ version + -> (Version -> a) -- ^ @\"== v\"@ + -> (Version -> a) -- ^ @\"> v\"@ + -> (Version -> a) -- ^ @\"< v\"@ + -> (a -> a -> a) -- ^ @\"_ || _\"@ union + -> (a -> a -> a) -- ^ @\"_ && _\"@ intersection + -> VersionRange -> a +foldVersionRange anyv this later earlier union intersect = fold + where + fold AnyVersion = anyv + fold (ThisVersion v) = this v + fold (LaterVersion v) = later v + fold (EarlierVersion v) = earlier v + fold (WildcardVersion v) = fold (wildcard v) + fold (UnionVersionRanges v1 v2) = union (fold v1) (fold v2) + fold (IntersectVersionRanges v1 v2) = intersect (fold v1) (fold v2) + fold (VersionRangeParens v) = fold v + + wildcard v = intersectVersionRanges + (orLaterVersion v) + (earlierVersion (wildcardUpperBound v)) + +-- | An extended variant of 'foldVersionRange' that also provides a view of +-- in which the syntactic sugar @\">= v\"@, @\"<= v\"@ and @\"== v.*\"@ is presented +-- explicitly rather than in terms of the other basic syntax. +-- +foldVersionRange' :: a -- ^ @\"-any\"@ version + -> (Version -> a) -- ^ @\"== v\"@ + -> (Version -> a) -- ^ @\"> v\"@ + -> (Version -> a) -- ^ @\"< v\"@ + -> (Version -> a) -- ^ @\">= v\"@ + -> (Version -> a) -- ^ @\"<= v\"@ + -> (Version -> Version -> a) -- ^ @\"== v.*\"@ wildcard. The + -- function is passed the + -- inclusive lower bound and the + -- exclusive upper bounds of the + -- range defined by the wildcard. + -> (a -> a -> a) -- ^ @\"_ || _\"@ union + -> (a -> a -> a) -- ^ @\"_ && _\"@ intersection + -> (a -> a) -- ^ @\"(_)\"@ parentheses + -> VersionRange -> a +foldVersionRange' anyv this later earlier orLater orEarlier + wildcard union intersect parens = fold + where + fold AnyVersion = anyv + fold (ThisVersion v) = this v + fold (LaterVersion v) = later v + fold (EarlierVersion v) = earlier v + + fold (UnionVersionRanges (ThisVersion v) + (LaterVersion v')) | v==v' = orLater v + fold (UnionVersionRanges (LaterVersion v) + (ThisVersion v')) | v==v' = orLater v + fold (UnionVersionRanges (ThisVersion v) + (EarlierVersion v')) | v==v' = orEarlier v + fold (UnionVersionRanges (EarlierVersion v) + (ThisVersion v')) | v==v' = orEarlier v + + fold (WildcardVersion v) = wildcard v (wildcardUpperBound v) + fold (UnionVersionRanges v1 v2) = union (fold v1) (fold v2) + fold (IntersectVersionRanges v1 v2) = intersect (fold v1) (fold v2) + fold (VersionRangeParens v) = parens (fold v) + + +-- | Does this version fall within the given range? +-- +-- This is the evaluation function for the 'VersionRange' type. +-- +withinRange :: Version -> VersionRange -> Bool +withinRange v = foldVersionRange + True + (\v' -> versionBranch v == versionBranch v') + (\v' -> versionBranch v > versionBranch v') + (\v' -> versionBranch v < versionBranch v') + (||) + (&&) + +-- | View a 'VersionRange' as a union of intervals. +-- +-- This provides a canonical view of the semantics of a 'VersionRange' as +-- opposed to the syntax of the expression used to define it. For the syntactic +-- view use 'foldVersionRange'. +-- +-- Each interval is non-empty. The sequence is in increasing order and no +-- intervals overlap or touch. Therefore only the first and last can be +-- unbounded. The sequence can be empty if the range is empty +-- (e.g. a range expression like @< 1 && > 2@). +-- +-- Other checks are trivial to implement using this view. For example: +-- +-- > isNoVersion vr | [] <- asVersionIntervals vr = True +-- > | otherwise = False +-- +-- > isSpecificVersion vr +-- > | [(LowerBound v InclusiveBound +-- > ,UpperBound v' InclusiveBound)] <- asVersionIntervals vr +-- > , v == v' = Just v +-- > | otherwise = Nothing +-- +asVersionIntervals :: VersionRange -> [VersionInterval] +asVersionIntervals = versionIntervals . toVersionIntervals + +-- | Does this 'VersionRange' place any restriction on the 'Version' or is it +-- in fact equivalent to 'AnyVersion'. +-- +-- Note this is a semantic check, not simply a syntactic check. So for example +-- the following is @True@ (for all @v@). +-- +-- > isAnyVersion (EarlierVersion v `UnionVersionRanges` orLaterVersion v) +-- +isAnyVersion :: VersionRange -> Bool +isAnyVersion vr = case asVersionIntervals vr of + [(LowerBound v InclusiveBound, NoUpperBound)] | isVersion0 v -> True + _ -> False + +-- | This is the converse of 'isAnyVersion'. It check if the version range is +-- empty, if there is no possible version that satisfies the version range. +-- +-- For example this is @True@ (for all @v@): +-- +-- > isNoVersion (EarlierVersion v `IntersectVersionRanges` LaterVersion v) +-- +isNoVersion :: VersionRange -> Bool +isNoVersion vr = case asVersionIntervals vr of + [] -> True + _ -> False + +-- | Is this version range in fact just a specific version? +-- +-- For example the version range @\">= 3 && <= 3\"@ contains only the version +-- @3@. +-- +isSpecificVersion :: VersionRange -> Maybe Version +isSpecificVersion vr = case asVersionIntervals vr of + [(LowerBound v InclusiveBound + ,UpperBound v' InclusiveBound)] + | v == v' -> Just v + _ -> Nothing + +-- | Simplify a 'VersionRange' expression. For non-empty version ranges +-- this produces a canonical form. Empty or inconsistent version ranges +-- are left as-is because that provides more information. +-- +-- If you need a canonical form use +-- @fromVersionIntervals . toVersionIntervals@ +-- +-- It satisfies the following properties: +-- +-- > withinRange v (simplifyVersionRange r) = withinRange v r +-- +-- > withinRange v r = withinRange v r' +-- > ==> simplifyVersionRange r = simplifyVersionRange r' +-- > || isNoVersion r +-- > || isNoVersion r' +-- +simplifyVersionRange :: VersionRange -> VersionRange +simplifyVersionRange vr + -- If the version range is inconsistent then we just return the + -- original since that has more information than ">1 && < 1", which + -- is the canonical inconsistent version range. + | null (versionIntervals vi) = vr + | otherwise = fromVersionIntervals vi + where + vi = toVersionIntervals vr + +---------------------------- +-- Wildcard range utilities +-- + +wildcardUpperBound :: Version -> Version +wildcardUpperBound (Version lowerBound ts) = (Version upperBound ts) + where + upperBound = init lowerBound ++ [last lowerBound + 1] + +isWildcardRange :: Version -> Version -> Bool +isWildcardRange (Version branch1 _) (Version branch2 _) = check branch1 branch2 + where check (n:[]) (m:[]) | n+1 == m = True + check (n:ns) (m:ms) | n == m = check ns ms + check _ _ = False + +------------------ +-- Intervals view +-- + +-- | A complementary representation of a 'VersionRange'. Instead of a boolean +-- version predicate it uses an increasing sequence of non-overlapping, +-- non-empty intervals. +-- +-- The key point is that this representation gives a canonical representation +-- for the semantics of 'VersionRange's. This makes it easier to check things +-- like whether a version range is empty, covers all versions, or requires a +-- certain minimum or maximum version. It also makes it easy to check equality +-- or containment. It also makes it easier to identify \'simple\' version +-- predicates for translation into foreign packaging systems that do not +-- support complex version range expressions. +-- +newtype VersionIntervals = VersionIntervals [VersionInterval] + deriving (Eq, Show) + +-- | Inspect the list of version intervals. +-- +versionIntervals :: VersionIntervals -> [VersionInterval] +versionIntervals (VersionIntervals is) = is + +type VersionInterval = (LowerBound, UpperBound) +data LowerBound = LowerBound Version !Bound deriving (Eq, Show) +data UpperBound = NoUpperBound | UpperBound Version !Bound deriving (Eq, Show) +data Bound = ExclusiveBound | InclusiveBound deriving (Eq, Show) + +minLowerBound :: LowerBound +minLowerBound = LowerBound (Version [0] []) InclusiveBound + +isVersion0 :: Version -> Bool +isVersion0 (Version [0] _) = True +isVersion0 _ = False + +instance Ord LowerBound where + LowerBound ver bound <= LowerBound ver' bound' = case compare ver ver' of + LT -> True + EQ -> not (bound == ExclusiveBound && bound' == InclusiveBound) + GT -> False + +instance Ord UpperBound where + _ <= NoUpperBound = True + NoUpperBound <= UpperBound _ _ = False + UpperBound ver bound <= UpperBound ver' bound' = case compare ver ver' of + LT -> True + EQ -> not (bound == InclusiveBound && bound' == ExclusiveBound) + GT -> False + +invariant :: VersionIntervals -> Bool +invariant (VersionIntervals intervals) = all validInterval intervals + && all doesNotTouch' adjacentIntervals + where + doesNotTouch' :: (VersionInterval, VersionInterval) -> Bool + doesNotTouch' ((_,u), (l',_)) = doesNotTouch u l' + + adjacentIntervals :: [(VersionInterval, VersionInterval)] + adjacentIntervals + | null intervals = [] + | otherwise = zip intervals (tail intervals) + +checkInvariant :: VersionIntervals -> VersionIntervals +checkInvariant is = assert (invariant is) is + +-- | Directly construct a 'VersionIntervals' from a list of intervals. +-- +-- Each interval must be non-empty. The sequence must be in increasing order +-- and no invervals may overlap or touch. If any of these conditions are not +-- satisfied the function returns @Nothing@. +-- +mkVersionIntervals :: [VersionInterval] -> Maybe VersionIntervals +mkVersionIntervals intervals + | invariant (VersionIntervals intervals) = Just (VersionIntervals intervals) + | otherwise = Nothing + +validVersion :: Version -> Bool +validVersion (Version [] _) = False +validVersion (Version vs _) = all (>=0) vs + +validInterval :: (LowerBound, UpperBound) -> Bool +validInterval i@(l, u) = validLower l && validUpper u && nonEmpty i + where + validLower (LowerBound v _) = validVersion v + validUpper NoUpperBound = True + validUpper (UpperBound v _) = validVersion v + +-- Check an interval is non-empty +-- +nonEmpty :: VersionInterval -> Bool +nonEmpty (_, NoUpperBound ) = True +nonEmpty (LowerBound l lb, UpperBound u ub) = + (l < u) || (l == u && lb == InclusiveBound && ub == InclusiveBound) + +-- Check an upper bound does not intersect, or even touch a lower bound: +-- +-- ---| or ---) but not ---] or ---) or ---] +-- |--- (--- (--- [--- [--- +-- +doesNotTouch :: UpperBound -> LowerBound -> Bool +doesNotTouch NoUpperBound _ = False +doesNotTouch (UpperBound u ub) (LowerBound l lb) = + u < l + || (u == l && ub == ExclusiveBound && lb == ExclusiveBound) + +-- | Check an upper bound does not intersect a lower bound: +-- +-- ---| or ---) or ---] or ---) but not ---] +-- |--- (--- (--- [--- [--- +-- +doesNotIntersect :: UpperBound -> LowerBound -> Bool +doesNotIntersect NoUpperBound _ = False +doesNotIntersect (UpperBound u ub) (LowerBound l lb) = + u < l + || (u == l && not (ub == InclusiveBound && lb == InclusiveBound)) + +-- | Test if a version falls within the version intervals. +-- +-- It exists mostly for completeness and testing. It satisfies the following +-- properties: +-- +-- > withinIntervals v (toVersionIntervals vr) = withinRange v vr +-- > withinIntervals v ivs = withinRange v (fromVersionIntervals ivs) +-- +withinIntervals :: Version -> VersionIntervals -> Bool +withinIntervals v (VersionIntervals intervals) = any withinInterval intervals + where + withinInterval (lowerBound, upperBound) = withinLower lowerBound + && withinUpper upperBound + withinLower (LowerBound v' ExclusiveBound) = v' < v + withinLower (LowerBound v' InclusiveBound) = v' <= v + + withinUpper NoUpperBound = True + withinUpper (UpperBound v' ExclusiveBound) = v' > v + withinUpper (UpperBound v' InclusiveBound) = v' >= v + +-- | Convert a 'VersionRange' to a sequence of version intervals. +-- +toVersionIntervals :: VersionRange -> VersionIntervals +toVersionIntervals = foldVersionRange + ( chkIvl (minLowerBound, NoUpperBound)) + (\v -> chkIvl (LowerBound v InclusiveBound, UpperBound v InclusiveBound)) + (\v -> chkIvl (LowerBound v ExclusiveBound, NoUpperBound)) + (\v -> if isVersion0 v then VersionIntervals [] else + chkIvl (minLowerBound, UpperBound v ExclusiveBound)) + unionVersionIntervals + intersectVersionIntervals + where + chkIvl interval = checkInvariant (VersionIntervals [interval]) + +-- | Convert a 'VersionIntervals' value back into a 'VersionRange' expression +-- representing the version intervals. +-- +fromVersionIntervals :: VersionIntervals -> VersionRange +fromVersionIntervals (VersionIntervals []) = noVersion +fromVersionIntervals (VersionIntervals intervals) = + foldr1 UnionVersionRanges [ interval l u | (l, u) <- intervals ] + + where + interval (LowerBound v InclusiveBound) + (UpperBound v' InclusiveBound) | v == v' + = ThisVersion v + interval (LowerBound v InclusiveBound) + (UpperBound v' ExclusiveBound) | isWildcardRange v v' + = WildcardVersion v + interval l u = lowerBound l `intersectVersionRanges'` upperBound u + + lowerBound (LowerBound v InclusiveBound) + | isVersion0 v = AnyVersion + | otherwise = orLaterVersion v + lowerBound (LowerBound v ExclusiveBound) = LaterVersion v + + upperBound NoUpperBound = AnyVersion + upperBound (UpperBound v InclusiveBound) = orEarlierVersion v + upperBound (UpperBound v ExclusiveBound) = EarlierVersion v + + intersectVersionRanges' vr AnyVersion = vr + intersectVersionRanges' AnyVersion vr = vr + intersectVersionRanges' vr vr' = IntersectVersionRanges vr vr' + +unionVersionIntervals :: VersionIntervals -> VersionIntervals + -> VersionIntervals +unionVersionIntervals (VersionIntervals is0) (VersionIntervals is'0) = + checkInvariant (VersionIntervals (union is0 is'0)) + where + union is [] = is + union [] is' = is' + union (i:is) (i':is') = case unionInterval i i' of + Left Nothing -> i : union is (i' :is') + Left (Just i'') -> union is (i'':is') + Right Nothing -> i' : union (i :is) is' + Right (Just i'') -> union (i'':is) is' + +unionInterval :: VersionInterval -> VersionInterval + -> Either (Maybe VersionInterval) (Maybe VersionInterval) +unionInterval (lower , upper ) (lower', upper') + + -- Non-intersecting intervals with the left interval ending first + | upper `doesNotTouch` lower' = Left Nothing + + -- Non-intersecting intervals with the right interval first + | upper' `doesNotTouch` lower = Right Nothing + + -- Complete or partial overlap, with the left interval ending first + | upper <= upper' = lowerBound `seq` + Left (Just (lowerBound, upper')) + + -- Complete or partial overlap, with the left interval ending first + | otherwise = lowerBound `seq` + Right (Just (lowerBound, upper)) + where + lowerBound = min lower lower' + +intersectVersionIntervals :: VersionIntervals -> VersionIntervals + -> VersionIntervals +intersectVersionIntervals (VersionIntervals is0) (VersionIntervals is'0) = + checkInvariant (VersionIntervals (intersect is0 is'0)) + where + intersect _ [] = [] + intersect [] _ = [] + intersect (i:is) (i':is') = case intersectInterval i i' of + Left Nothing -> intersect is (i':is') + Left (Just i'') -> i'' : intersect is (i':is') + Right Nothing -> intersect (i:is) is' + Right (Just i'') -> i'' : intersect (i:is) is' + +intersectInterval :: VersionInterval -> VersionInterval + -> Either (Maybe VersionInterval) (Maybe VersionInterval) +intersectInterval (lower , upper ) (lower', upper') + + -- Non-intersecting intervals with the left interval ending first + | upper `doesNotIntersect` lower' = Left Nothing + + -- Non-intersecting intervals with the right interval first + | upper' `doesNotIntersect` lower = Right Nothing + + -- Complete or partial overlap, with the left interval ending first + | upper <= upper' = lowerBound `seq` + Left (Just (lowerBound, upper)) + + -- Complete or partial overlap, with the right interval ending first + | otherwise = lowerBound `seq` + Right (Just (lowerBound, upper')) + where + lowerBound = max lower lower' + +------------------------------- +-- Parsing and pretty printing +-- + +instance Text VersionRange where + disp = fst + . foldVersionRange' -- precedence: + ( Disp.text "-any" , 0 :: Int) + (\v -> (Disp.text "==" <> disp v , 0)) + (\v -> (Disp.char '>' <> disp v , 0)) + (\v -> (Disp.char '<' <> disp v , 0)) + (\v -> (Disp.text ">=" <> disp v , 0)) + (\v -> (Disp.text "<=" <> disp v , 0)) + (\v _ -> (Disp.text "==" <> dispWild v , 0)) + (\(r1, p1) (r2, p2) -> (punct 2 p1 r1 <+> Disp.text "||" <+> punct 2 p2 r2 , 2)) + (\(r1, p1) (r2, p2) -> (punct 1 p1 r1 <+> Disp.text "&&" <+> punct 1 p2 r2 , 1)) + (\(r, p) -> (Disp.parens r, p)) + + where dispWild (Version b _) = + Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int b)) + <> Disp.text ".*" + punct p p' | p < p' = Disp.parens + | otherwise = id + + parse = expr + where + expr = do Parse.skipSpaces + t <- term + Parse.skipSpaces + (do _ <- Parse.string "||" + Parse.skipSpaces + e <- expr + return (UnionVersionRanges t e) + +++ + return t) + term = do f <- factor + Parse.skipSpaces + (do _ <- Parse.string "&&" + Parse.skipSpaces + t <- term + return (IntersectVersionRanges f t) + +++ + return f) + factor = Parse.choice $ parens expr + : parseAnyVersion + : parseWildcardRange + : map parseRangeOp rangeOps + parseAnyVersion = Parse.string "-any" >> return AnyVersion + + parseWildcardRange = do + _ <- Parse.string "==" + Parse.skipSpaces + branch <- Parse.sepBy1 digits (Parse.char '.') + _ <- Parse.char '.' + _ <- Parse.char '*' + return (WildcardVersion (Version branch [])) + + parens p = Parse.between (Parse.char '(' >> Parse.skipSpaces) + (Parse.char ')' >> Parse.skipSpaces) + (do a <- p + Parse.skipSpaces + return (VersionRangeParens a)) + + digits = do + first <- Parse.satisfy Char.isDigit + if first == '0' + then return 0 + else do rest <- Parse.munch Char.isDigit + return (read (first : rest)) + + parseRangeOp (s,f) = Parse.string s >> Parse.skipSpaces >> fmap f parse + rangeOps = [ ("<", EarlierVersion), + ("<=", orEarlierVersion), + (">", LaterVersion), + (">=", orLaterVersion), + ("==", ThisVersion) ] diff -Nru ghc-7.0.3/libraries/Cabal/cabal/doc/Cabal.css ghc-7.2.1/libraries/Cabal/cabal/doc/Cabal.css --- ghc-7.0.3/libraries/Cabal/cabal/doc/Cabal.css 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/doc/Cabal.css 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,39 @@ +div { + font-family: sans-serif; + color: black; + background: white +} + +h1, h2, h3, h4, h5, h6, p.title { color: #005A9C } + +h1 { font: 170% sans-serif } +h2 { font: 140% sans-serif } +h3 { font: 120% sans-serif } +h4 { font: bold 100% sans-serif } +h5 { font: italic 100% sans-serif } +h6 { font: small-caps 100% sans-serif } + +pre { + font-family: monospace; + border-width: 1px; + border-style: solid; + padding: 0.3em +} + +pre.screen { color: #006400 } +pre.programlisting { color: maroon } + +div.example { + margin: 1ex 0em; + border: solid #412e25 1px; + padding: 0ex 0.4em +} + +div.example, div.example-contents { + background-color: #fffcf5 +} + +a:link { color: #0000C8 } +a:hover { background: #FFFFA8 } +a:active { color: #D00000 } +a:visited { color: #680098 } diff -Nru ghc-7.0.3/libraries/Cabal/cabal/doc/developing-packages.markdown ghc-7.2.1/libraries/Cabal/cabal/doc/developing-packages.markdown --- ghc-7.0.3/libraries/Cabal/cabal/doc/developing-packages.markdown 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/doc/developing-packages.markdown 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,1447 @@ +% Cabal User Guide + +# Developing packages # + +The Cabal package is the unit of distribution. When installed, its +purpose is to make available: + + * One or more Haskell programs. + + * At most one library, exposing a number of Haskell modules. + +However having both a library and executables in a package does not work +very well; if the executables depend on the library, they must +explicitly list all the modules they directly or indirectly import from +that library. Fortunately, starting with Cabal 1.8.0.4, executables can +also declare the package that they are in as a dependency, and Cabal +will treat them as if they were in another package that dependended on +the library. + +Internally, the package may consist of much more than a bunch of Haskell +modules: it may also have C source code and header files, source code +meant for preprocessing, documentation, test cases, auxiliary tools etc. + +A package is identified by a globally-unique _package name_, which +consists of one or more alphanumeric words separated by hyphens. To +avoid ambiguity, each of these words should contain at least one letter. +Chaos will result if two distinct packages with the same name are +installed on the same system. A particular version of the package is +distinguished by a _version number_, consisting of a sequence of one or +more integers separated by dots. These can be combined to form a single +text string called the _package ID_, using a hyphen to separate the name +from the version, e.g. "`HUnit-1.1`". + +Note: Packages are not part of the Haskell language; they simply +populate the hierarchical space of module names. In GHC 6.6 and later a +program may contain multiple modules with the same name if they come +from separate packages; in all other current Haskell systems packages +may not overlap in the modules they provide, including hidden modules. + +## Creating a package ## + +Suppose you have a directory hierarchy containing the source files that +make up your package. You will need to add two more files to the root +directory of the package: + +_package_`.cabal` + +: a Unicode UTF-8 text file containing a package description. + For details of the syntax of this file, see the [section on package + descriptions](#package-descriptions). + +`Setup.hs` + +: a single-module Haskell program to perform various setup tasks (with + the interface described in the section on [building and installing + packages](#building-and-installing-a-package)). This module should + import only modules that will be present in all Haskell + implementations, including modules of the Cabal library. In most + cases it will be trivial, calling on the Cabal library to do most of + the work. + +Once you have these, you can create a source bundle of this directory +for distribution. Building of the package is discussed in the section on +[building and installing packages](#building-and-installing-a-package). + +One of the purposes of Cabal is to make it easier to build a package +with different Haskell implementations. So it provides abstractions of +features present in different Haskell implementations and wherever +possible it is best to take advantage of these to increase portability. +Where necessary however it is possible to use specific features of +specific implementations. For example one of the pieces of information a +package author can put in the package's `.cabal` file is what language +extensions the code uses. This is far preferable to specifying flags for +a specific compiler as it allows Cabal to pick the right flags for the +Haskell implementation that the user picks. It also allows Cabal to +figure out if the language extension is even supported by the Haskell +implementation that the user picks. Where compiler-specific options are +needed however, there is an "escape hatch" available. The developer can +specify implementation-specific options and more generally there is a +configuration mechanism to customise many aspects of how a package is +built depending on the Haskell implementation, the Operating system, +computer architecture and user-specified configuration flags. + +~~~~~~~~~~~~~~~~ +name: Foo +version: 1.0 + +library + build-depends: base + exposed-modules: Foo + extensions: ForeignFunctionInterface + ghc-options: -Wall + nhc98-options: -K4m + if os(windows) + build-depends: Win32 +~~~~~~~~~~~~~~~~ + +#### Example: A package containing a simple library #### + +The HUnit package contains a file `HUnit.cabal` containing: + +~~~~~~~~~~~~~~~~ +name: HUnit +version: 1.1.1 +synopsis: A unit testing framework for Haskell +homepage: http://hunit.sourceforge.net/ +category: Testing +author: Dean Herington +license: BSD3 +license-file: LICENSE +cabal-version: >= 1.10 +build-type: Simple + +library + build-depends: base >= 2 && < 4 + exposed-modules: Test.HUnit.Base, Test.HUnit.Lang, + Test.HUnit.Terminal, Test.HUnit.Text, Test.HUnit + default-extensions: CPP +~~~~~~~~~~~~~~~~ + +and the following `Setup.hs`: + +~~~~~~~~~~~~~~~~ +import Distribution.Simple +main = defaultMain +~~~~~~~~~~~~~~~~ + +#### Example: A package containing executable programs #### + +~~~~~~~~~~~~~~~~ +name: TestPackage +version: 0.0 +synopsis: Small package with two programs +author: Angela Author +license: BSD3 +build-type: Simple +cabal-version: >= 1.2 + +executable program1 + build-depends: HUnit + main-is: Main.hs + hs-source-dirs: prog1 + +executable program2 + main-is: Main.hs + build-depends: HUnit + hs-source-dirs: prog2 + other-modules: Utils +~~~~~~~~~~~~~~~~ + +with `Setup.hs` the same as above. + +#### Example: A package containing a library and executable programs #### + +~~~~~~~~~~~~~~~~ +name: TestPackage +version: 0.0 +synopsis: Package with library and two programs +license: BSD3 +author: Angela Author +build-type: Simple +cabal-version: >= 1.2 + +library + build-depends: HUnit + exposed-modules: A, B, C + +executable program1 + main-is: Main.hs + hs-source-dirs: prog1 + other-modules: A, B + +executable program2 + main-is: Main.hs + hs-source-dirs: prog2 + other-modules: A, C, Utils +~~~~~~~~~~~~~~~~ + +with `Setup.hs` the same as above. Note that any library modules +required (directly or indirectly) by an executable must be listed again. + +The trivial setup script used in these examples uses the _simple build +infrastructure_ provided by the Cabal library (see +[Distribution.Simple][dist-simple]). The simplicity lies in its +interface rather that its implementation. It automatically handles +preprocessing with standard preprocessors, and builds packages for all +the Haskell implementations (except nhc98, for now). + +The simple build infrastructure can also handle packages where building +is governed by system-dependent parameters, if you specify a little more +(see the section on [system-dependent +parameters](#system-dependent-parameters)). A few packages require [more +elaborate solutions](#complex-packages). + +## Package descriptions ## + +The package description file must have a name ending in "`.cabal`". It +must be a Unicode text file encoded using valid UTF-8. There must be +exactly one such file in the directory. The first part of the name is +usually the package name, and some of the tools that operate on Cabal +packages require this. + +In the package description file, lines whose first non-whitespace characters +are "`--`" are treated as comments and ignored. + +This file should contain of a number global property descriptions and +several sections. + +* The [global properties](#package-properties) describe the package as a + whole, such as name, license, author, etc. + +* Optionally, a number of _configuration flags_ can be declared. These + can be used to enable or disable certain features of a package. (see + the section on [configurations](#configurations)). + +* The (optional) library section specifies the [library + properties](#library) and relevant [build + information](#build-information). + +* Following is an arbitrary number of executable sections + which describe an [executable program](#executable) and relevant + [build information](#build-information). + +Each section consists of a number of property descriptions +in the form of field/value pairs, with a syntax roughly like mail +message headers. + +* Case is not significant in field names, but is significant in field + values. + +* To continue a field value, indent the next line relative to the field + name. + +* Field names may be indented, but all field values in the same section + must use the same indentation. + +* Tabs are *not* allowed as indentation characters due to a missing + standard interpretation of tab width. + +* To get a blank line in a field value, use an indented "`.`" + +The syntax of the value depends on the field. Field types include: + +_token_, _filename_, _directory_ +: Either a sequence of one or more non-space non-comma characters, or + a quoted string in Haskell 98 lexical syntax. Unless otherwise + stated, relative filenames and directories are interpreted from the + package root directory. + +_freeform_, _URL_, _address_ +: An arbitrary, uninterpreted string. + +_identifier_ +: A letter followed by zero or more alphanumerics or underscores. + +_compiler_ +: A compiler flavor (one of: `GHC`, `NHC`, `YHC`, `Hugs`, `HBC`, + `Helium`, `JHC`, or `LHC`) followed by a version range. For + example, `GHC ==6.10.3`, or `LHC >=0.6 && <0.8`. + +### Modules and preprocessors ### + +Haskell module names listed in the `exposed-modules` and `other-modules` +fields may correspond to Haskell source files, i.e. with names ending in +"`.hs`" or "`.lhs`", or to inputs for various Haskell preprocessors. The +simple build infrastructure understands the extensions: + +* `.gc` ([greencard][]) +* `.chs` ([c2hs][]) +* `.hsc` (`hsc2hs`) +* `.y` and `.ly` ([happy][]) +* `.x` ([alex][]) +* `.cpphs` ([cpphs][]) + +When building, Cabal will automatically run the appropriate preprocessor +and compile the Haskell module it produces. + +Some fields take lists of values, which are optionally separated by commas, except for the +`build-depends` field, where the commas are mandatory. + +Some fields are marked as required. All others are optional, and unless +otherwise specified have empty default values. + +### Package properties ### + +These fields may occur in the first top-level properties section and +describe the package as a whole: + +`name:` _package-name_ (required) +: The unique name of the [package](#packages), without the version + number. + +`version:` _numbers_ (required) +: The package version number, usually consisting of a sequence of + natural numbers separated by dots. + +`cabal-version:` _>= x.y_ +: The version of the Cabal specification that this package description uses. + The Cabal specification does slowly evolve, intoducing new features and + occasionally changing the meaning of existing features. By specifying + which version of the spec you are using it enables programs which process + the package description to know what syntax to expect and what each part + means. + + For historical reasons this is always expressed using _>=_ version range + syntax. No other kinds of version range make sense, in particular upper + bounds do not make sense. In future this field will specify just a version + number, rather than a version range. + + The version number you specify will affect both compatability and + behaviour. Most tools (including the Cabal libray and cabal program) + understand a range of versions of the Cabal specification. Older tools + will of course only work with older versions of the Cabal specification. + Most of the time, tools that are too old will recognise this fact and + produce a suitable error message. + + As for behaviour, new versions of the Cabal spec can change the meaning + of existing syntax. This means if you want to take advantage of the new + meaning or behaviour then you must specify the newer Cabal version. + Tools are expected to use the meaning and behaviour appropriate to the + version given in the package description. + + In particular, the syntax of package descriptions changed significantly + with Cabal version 1.2 and the `cabal-version` field is now required. + Files written in the old syntax are still recognized, so if you require + compatability with very old Cabal versions then you may write your package + description file using the old syntax. Please consult the user's guide of + an older Cabal version for a description of that syntax. + +`build-type:` _identifier_ +: The type of build used by this package. Build types are the + constructors of the [BuildType][] type, defaulting to `Custom`. If + this field is given a value other than `Custom`, some tools such as + `cabal-install` will be able to build the package without using the + setup script. So if you are just using the default `Setup.hs` then + set the build type as `Simple`. + +`license:` _identifier_ (default: `AllRightsReserved`) +: The type of license under which this package is distributed. + License names are the constants of the [License][dist-license] type. + +`license-file:` _filename_ +: The name of a file containing the precise license for this package. + It will be installed with the package. + +`copyright:` _freeform_ +: The content of a copyright notice, typically the name of the holder + of the copyright on the package and the year(s) from which copyright + is claimed. For example: `Copyright: (c) 2006-2007 Joe Bloggs` + +`author:` _freeform_ +: The original author of the package. + + Remember that `.cabal` files are Unicode, using the UTF-8 encoding. + +`maintainer:` _address_ +: The current maintainer or maintainers of the package. This is an e-mail address to which users should send bug + reports, feature requests and patches. + +`stability:` _freeform_ +: The stability level of the package, e.g. `alpha`, `experimental`, `provisional`, + `stable`. + +`homepage:` _URL_ +: The package homepage. + +`bug-reports:` _URL_ +: The URL where users should direct bug reports. This would normally be either: + + * A `mailto:` URL, eg for a person or a mailing list. + + * An `http:` (or `https:`) URL for an online bug tracking system. + + For example Cabal itself uses a web-based bug tracking system + + ~~~~~~~~~~~~~~~~ + bug-reports: http://hackage.haskell.org/trac/hackage/ + ~~~~~~~~~~~~~~~~ + +`package-url:` _URL_ +: The location of a source bundle for the package. The distribution + should be a Cabal package. + +`synopsis:` _freeform_ +: A very short description of the package, for use in a table of + packages. This is your headline, so keep it short (one line) but as + informative as possible. Save space by not including the package + name or saying it's written in Haskell. + +`description:` _freeform_ +: Description of the package. This may be several paragraphs, and + should be aimed at a Haskell programmer who has never heard of your + package before. + + For library packages, this field is used as prologue text by [`setup + haddock`](#setup-haddock), and thus may contain the same markup as + [haddock][] documentation comments. + +`category:` _freeform_ +: A classification category for future use by the package catalogue [Hackage]. These + categories have not yet been specified, but the upper levels of the + module hierarchy make a good start. + +`tested-with:` _compiler list_ +: A list of compilers and versions against which the package has been + tested (or at least built). + +`data-files:` _filename list_ +: A list of files to be installed for run-time use by the package. + This is useful for packages that use a large amount of static data, + such as tables of values or code templates. Cabal provides a way to + [find these files at + run-time](#accessing-data-files-from-package-code). + + A limited form of `*` wildcards in file names, for example + `data-files: images/*.png` matches all the `.png` files in the + `images` directory. + + The limitation is that `*` wildcards are only allowed in place of + the file name, not in the directory name or file extension. In + particular, wildcards do not include directories contents + recursively. Furthermore, if a wildcard is used it must be used with + an extension, so `data-files: data/*` is not allowed. When matching + a wildcard plus extension, a file's full extension must match + exactly, so `*.gz` matches `foo.gz` but not `foo.tar.gz`. A wildcard + that does not match any files is an error. + + The reason for providing only a very limited form of wildcard is to + concisely express the common case of a large number of related files + of the same file type without making it too easy to accidentally + include unwanted files. + +`data-dir:` _directory_ +: The directory where Cabal looks for data files to install, relative + to the source directory. By default, Cabal will look in the source + directory itself. + +`extra-source-files:` _filename list_ +: A list of additional files to be included in source distributions + built with [`setup sdist`](#setup-sdist). As with `data-files` it + can use a limited form of `*` wildcards in file names. + +`extra-tmp-files:` _filename list_ +: A list of additional files or directories to be removed by [`setup + clean`](#setup-clean). These would typically be additional files + created by additional hooks, such as the scheme described in the + section on [system-dependent parameters](#system-dependent-parameters). + +### Library ### + +The library section should contain the following fields: + +`exposed-modules:` _identifier list_ (required if this package contains a library) +: A list of modules added by this package. + +`exposed:` _boolean_ (default: `True`) +: Some Haskell compilers (notably GHC) support the notion of packages + being "exposed" or "hidden" which means the modules they provide can + be easily imported without always having to specify which package + they come from. However this only works effectively if the modules + provided by all exposed packages do not overlap (otherwise a module + import would be ambiguous). + + Almost all new libraries use hierarchical module names that do not + clash, so it is very uncommon to have to use this field. However it + may be necessary to set `exposed: False` for some old libraries that + use a flat module namespace or where it is known that the exposed + modules would clash with other common modules. + +The library section may also contain build information fields (see the +section on [build information](#build-information)). + + +### Executables ### + +Executable sections (if present) describe executable programs contained +in the package and must have an argument after the section label, which +defines the name of the executable. This is a freeform argument but may +not contain spaces. + +The executable may be described using the following fields, as well as +build information fields (see the section on [build +information](#build-information)). + +`main-is:` _filename_ (required) +: The name of the `.hs` or `.lhs` file containing the `Main` module. Note that it is the + `.hs` filename that must be listed, even if that file is generated + using a preprocessor. The source file must be relative to one of the + directories listed in `hs-source-dirs`. + +### Test suites ### + +Test suite sections (if present) describe package test suites and must have an +argument after the section label, which defines the name of the test suite. +This is a freeform argument, but may not contain spaces. It should be unique +among the names of the package's other test suites, the package's executables, +and the package itself. Using test suite sections requires at least Cabal +version 1.9.2. + +The test suite may be described using the following fields, as well as build +information fields (see the section on [build +information](#build-information)). + +`type:` _interface_ (required) +: The interface type and version of the test suite. Cabal supports two test + suite interfaces, called `exitcode-stdio-1.0` and `detailed-1.0`. Each of + these types may require or disallow other fields as described below. + +Test suites using the `exitcode-stdio-1.0` interface are executables +that indicate test failure with a non-zero exit code when run; they may provide +human-readable log information through the standard output and error channels. +This interface is provided primarily for compatibility with existing test +suites; it is preferred that new test suites be written for the `detailed-1.0` +interface. The `exitcode-stdio-1.0` type requires the `main-is` field. + +`main-is:` _filename_ (required: `exitcode-stdio-1.0`, disallowed: `detailed-1.0`) +: The name of the `.hs` or `.lhs` file containing the `Main` module. Note that it is the + `.hs` filename that must be listed, even if that file is generated + using a preprocessor. The source file must be relative to one of the + directories listed in `hs-source-dirs`. This field is analogous to the + `main-is` field of an executable section. + +Test suites using the `detailed-1.0` interface are modules exporting the symbol +`tests :: [Test]`. The `Test` type is exported by the module +`Distribution.TestSuite` provided by Cabal. For more details, see the example below. + +The `detailed-1.0` interface allows Cabal and other test agents to inspect a +test suite's results case by case, producing detailed human- and +machine-readable log files. The `detailed-1.0` interface requires the +`test-module` field. + +`test-module:` _identifier_ (required: `detailed-1.0`, disallowed: `exitcode-stdio-1.0`) +: The module exporting the `tests` symbol. + +#### Example: Package using `exitcode-stdio-1.0` interface #### + +The example package description and executable source file below demonstrate +the use of the `exitcode-stdio-1.0` interface. For brevity, the example package +does not include a library or any normal executables, but a real package would +be required to have at least one library or executable. + +foo.cabal: + +~~~~~~~~~~~~~~~~ +Name: foo +Version: 1.0 +License: BSD3 +Cabal-Version: >= 1.9.2 +Build-Type: Simple + +Test-Suite test-foo + type: exitcode-stdio-1.0 + main-is: test-foo.hs + build-depends: base +~~~~~~~~~~~~~~~~ + +test-foo.hs: + +~~~~~~~~~~~~~~~~ +module Main where + +import System.Exit (exitFailure) + +main = do + putStrLn "This test always fails!" + exitFailure +~~~~~~~~~~~~~~~~ + +#### Example: Package using `detailed-1.0` interface #### + +The example package description and test module source file below demonstrate +the use of the `detailed-1.0` interface. For brevity, the example package does +note include a library or any normal executables, but a real package would be +required to have at least one library or executable. The test module below +also develops a simple implementation of the interface set by +`Distribution.TestSuite`, but in actual usage the implementation would be +provided by the library that provides the testing facility. + +bar.cabal: + +~~~~~~~~~~~~~~~~ +Name: bar +Version: 1.0 +License: BSD3 +Cabal-Version: >= 1.9.2 +Build-Type: Simple + +Test-Suite test-bar + type: detailed-1.0 + test-module: Test.Bar + build-depends: base, Cabal >= 1.9.2 +~~~~~~~~~~~~~~~~ + +Test/Bar.hs: + +~~~~~~~~~~~~~~~~ +{-# LANGUAGE FlexibleInstances #-} +module Test.Bar ( tests ) where + +import Distribution.TestSuite + +instance TestOptions (String, Bool) where + name = fst + options = const [] + defaultOptions _ = return (Options []) + check _ _ = [] + +instance PureTestable (String, Bool) where + run (name, result) _ | result == True = Pass + | result == False = Fail (name ++ " failed!") + +test :: (String, Bool) -> Test +test = pure + +-- In actual usage, the instances 'TestOptions (String, Bool)' and +-- 'PureTestable (String, Bool)', as well as the function 'test', would be +-- provided by the test framework. + +tests :: [Test] +tests = + [ test ("bar-1", True) + , test ("bar-2", False) + ] +~~~~~~~~~~~~~~~~ + +### Build information ### + +The following fields may be optionally present in a library or +executable section, and give information for the building of the +corresponding library or executable. See also the sections on +[system-dependent parameters](#system-dependent-parameters) and +[configurations](#configurations) for a way to supply system-dependent +values for these fields. + +`build-depends:` _package list_ +: A list of packages needed to build this one. Each package can be + annotated with a version constraint. + + Version constraints use the operators `==, >=, >, <, <=` and a + version number. Multiple constraints can be combined using `&&` or + `||`. If no version constraint is specified, any version is assumed + to be acceptable. For example: + + ~~~~~~~~~~~~~~~~ + library + build-depends: + base >= 2, + foo >= 1.2 && < 1.3, + bar + ~~~~~~~~~~~~~~~~ + + Dependencies like `foo >= 1.2 && < 1.3` turn out to be very common + because it is recommended practise for package versions to + correspond to API versions. As of Cabal 1.6, there is a special + syntax to support this use: + + ~~~~~~~~~~~~~~~~ + build-depends: foo ==1.2.* + ~~~~~~~~~~~~~~~~ + + It is only syntactic sugar. It is exactly equivalent to `foo >= 1.2 && < 1.3`. + + Note: Prior to Cabal 1.8, build-depends specified in each section + were global to all sections. This was unintentional, but some packages + were written to depend on it, so if you need your build-depends to + be local to each section, you must specify at least + `Cabal-Version: >= 1.8` in your `.cabal` file. + +`other-modules:` _identifier list_ +: A list of modules used by the component but not exposed to users. + For a library component, these would be hidden modules of the + library. For an executable, these would be auxiliary modules to be + linked with the file named in the `main-is` field. + + Note: Every module in the package *must* be listed in one of + `other-modules`, `exposed-modules` or `main-is` fields. + +`hs-source-dirs:` _directory list_ (default: "`.`") +: Root directories for the module hierarchy. + + For backwards compatibility, the old variant `hs-source-dir` is also + recognized. + +`extensions:` _identifier list_ +: A list of Haskell extensions used by every module. Extension names + are the constructors of the [Extension][extension] type. These + determine corresponding compiler options. In particular, `CPP` specifies that + Haskell source files are to be preprocessed with a C preprocessor. + + Extensions used only by one module may be specified by placing a + `LANGUAGE` pragma in the source file affected, e.g.: + + ~~~~~~~~~~~~~~~~ + {-# LANGUAGE CPP, MultiParamTypeClasses #-} + ~~~~~~~~~~~~~~~~ + + Note: GHC versions prior to 6.6 do not support the `LANGUAGE` pragma. + +`build-tools:` _program list_ +: A list of programs, possibly annotated with versions, needed to + build this package, e.g. `c2hs >= 0.15, cpphs`.If no version + constraint is specified, any version is assumed to be acceptable. + +`buildable:` _boolean_ (default: `True`) +: Is the component buildable? Like some of the other fields below, + this field is more useful with the slightly more elaborate form of + the simple build infrastructure described in the section on + [system-dependent parameters](#system-dependent-parameters). + +`ghc-options:` _token list_ +: Additional options for GHC. You can often achieve the same effect + using the `extensions` field, which is preferred. + + Options required only by one module may be specified by placing an + `OPTIONS_GHC` pragma in the source file affected. + +`ghc-prof-options:` _token list_ +: Additional options for GHC when the package is built with profiling + enabled. + +`ghc-shared-options:` _token list_ +: Additional options for GHC when the package is built as shared library. + +`hugs-options:` _token list_ +: Additional options for Hugs. You can often achieve the same effect + using the `extensions` field, which is preferred. + + Options required only by one module may be specified by placing an + `OPTIONS_HUGS` pragma in the source file affected. + +`nhc98-options:` _token list_ +: Additional options for nhc98. You can often achieve the same effect + using the `extensions` field, which is preferred. + + Options required only by one module may be specified by placing an + `OPTIONS_NHC98` pragma in the source file affected. + +`includes:` _filename list_ +: A list of header files to be included in any compilations via C. + This field applies to both header files that are already installed + on the system and to those coming with the package to be installed. + These files typically contain function prototypes for foreign + imports used by the package. + +`install-includes:` _filename list_ +: A list of header files from this package to be installed into + `$libdir/includes` when the package is installed. Files listed in + `install-includes:` should be found in relative to the top of the + source tree or relative to one of the directories listed in + `include-dirs`. + + `install-includes` is typically used to name header files that + contain prototypes for foreign imports used in Haskell code in this + package, for which the C implementations are also provided with the + package. Note that to include them when compiling the package + itself, they need to be listed in the `includes:` field as well. + +`include-dirs:` _directory list_ +: A list of directories to search for header files, when preprocessing + with `c2hs`, `hsc2hs`, `ffihugs`, `cpphs` or the C preprocessor, and + also when compiling via C. + +`c-sources:` _filename list_ +: A list of C source files to be compiled and linked with the Haskell files. + + If you use this field, you should also name the C files in `CFILES` + pragmas in the Haskell source files that use them, e.g.: `{-# CFILES + dir/file1.c dir/file2.c #-}` These are ignored by the compilers, but + needed by Hugs. + +`extra-libraries:` _token list_ +: A list of extra libraries to link with. + +`extra-lib-dirs:` _directory list_ +: A list of directories to search for libraries. + +`cc-options:` _token list_ +: Command-line arguments to be passed to the C compiler. Since the + arguments are compiler-dependent, this field is more useful with the + setup described in the section on [system-dependent + parameters](#system-dependent-parameters). + +`ld-options:` _token list_ +: Command-line arguments to be passed to the linker. Since the + arguments are compiler-dependent, this field is more useful with the + setup described in the section on [system-dependent + parameters](#system-dependent-parameters)>. + +`pkgconfig-depends:` _package list_ +: A list of [pkg-config][] packages, needed to build this package. + They can be annotated with versions, e.g. `gtk+-2.0 >= 2.10, cairo + >= 1.0`. If no version constraint is specified, any version is + assumed to be acceptable. Cabal uses `pkg-config` to find if the + packages are available on the system and to find the extra + compilation and linker options needed to use the packages. + + If you need to bind to a C library that supports `pkg-config` (use + `pkg-config --list-all` to find out if it is supported) then it is + much preferable to use this field rather than hard code options into + the other fields. + +`frameworks:` _token list_ +: On Darwin/MacOS X, a list of frameworks to link to. See Apple's + developer documentation for more details on frameworks. This entry + is ignored on all other platforms. + +### Configurations ### + +Library and executable sections may include conditional +blocks, which test for various system parameters and +configuration flags. The flags mechanism is rather generic, +but most of the time a flag represents certain feature, that +can be switched on or off by the package user. +Here is an example package description file using +configurations: + +#### Example: A package containing a library and executable programs #### + +~~~~~~~~~~~~~~~~ +Name: Test1 +Version: 0.0.1 +Cabal-Version: >= 1.2 +License: BSD3 +Author: Jane Doe +Synopsis: Test package to test configurations +Category: Example + +Flag Debug + Description: Enable debug support + Default: False + +Flag WebFrontend + Description: Include API for web frontend. + -- Cabal checks if the configuration is possible, first + -- with this flag set to True and if not it tries with False + +Library + Build-Depends: base + Exposed-Modules: Testing.Test1 + Extensions: CPP + + if flag(debug) + GHC-Options: -DDEBUG + if !os(windows) + CC-Options: "-DDEBUG" + else + CC-Options: "-DNDEBUG" + + if flag(webfrontend) + Build-Depends: cgi > 0.42 + Other-Modules: Testing.WebStuff + +Executable test1 + Main-is: T1.hs + Other-Modules: Testing.Test1 + Build-Depends: base + + if flag(debug) + CC-Options: "-DDEBUG" + GHC-Options: -DDEBUG +~~~~~~~~~~~~~~~~ + +#### Layout #### + +Flags, conditionals, library and executable sections use layout to +indicate structure. This is very similar to the Haskell layout rule. +Entries in a section have to all be indented to the same level which +must be more than the section header. Tabs are not allowed to be used +for indentation. + +As an alternative to using layout you can also use explicit braces `{}`. +In this case the indentation of entries in a section does not matter, +though different fields within a block must be on different lines. Here +is a bit of the above example again, using braces: + +#### Example: Using explicit braces rather than indentation for layout #### + +~~~~~~~~~~~~~~~~ +Name: Test1 +Version: 0.0.1 +Cabal-Version: >= 1.2 +License: BSD3 +Author: Jane Doe +Synopsis: Test package to test configurations +Category: Example + +Flag Debug { + Description: Enable debug support + Default: False +} + +Library { + Build-Depends: base + Exposed-Modules: Testing.Test1 + Extensions: CPP + if flag(debug) { + GHC-Options: -DDEBUG + if !os(windows) { + CC-Options: "-DDEBUG" + } else { + CC-Options: "-DNDEBUG" + } + } +} +~~~~~~~~~~~~~~~~ + +#### Configuration Flags #### + +A flag section takes the flag name as an argument and may contain the +following fields. + +`description:` _freeform_ +: The description of this flag. + +`default:` _boolean_ (default: `True`) +: The default value of this flag. + + Note that this value may be [overridden in several + ways](#controlling-flag-assignments"). The rationale for having + flags default to True is that users usually want new features as + soon as they are available. Flags representing features that are not + (yet) recommended for most users (such as experimental features or + debugging support) should therefore explicitly override the default + to False. + +`manual:` _boolean_ (default: `False`) +: By default, Cabal will first try to satisfy dependencies with the + default flag value and then, if that is not possible, with the + negated value. However, if the flag is manual, then the default + value (which can be overridden by commandline flags) will be used. + +#### Conditional Blocks #### + +Conditional blocks may appear anywhere inside a library or executable +section. They have to follow rather strict formatting rules. +Conditional blocks must always be of the shape + +~~~~~~~~~~~~~~~~ + `if `_condition_ + _property-descriptions-or-conditionals*_ +~~~~~~~~~~~~~~~~ + +or + +~~~~~~~~~~~~~~~~ + `if `_condition_ + _property-descriptions-or-conditionals*_ + `else` + _property-descriptions-or-conditionals*_ +~~~~~~~~~~~~~~~~ + +Note that the `if` and the condition have to be all on the same line. + +#### Conditions #### + +Conditions can be formed using boolean tests and the boolean operators +`||` (disjunction / logical "or"), `&&` (conjunction / logical "and"), +or `!` (negation / logical "not"). The unary `!` takes highest +precedence, `||` takes lowest. Precedence levels may be overridden +through the use of parentheses. For example, `os(darwin) && !arch(i386) +|| os(freebsd)` is equivalent to `(os(darwin) && !(arch(i386))) || +os(freebsd)`. + +The following tests are currently supported. + +`os(`_name_`)` +: Tests if the current operating system is _name_. The argument is + tested against `System.Info.os` on the target system. There is + unfortunately some disagreement between Haskell implementations + about the standard values of `System.Info.os`. Cabal canonicalises + it so that in particular `os(windows)` works on all implementations. + If the canonicalised os names match, this test evaluates to true, + otherwise false. The match is case-insensitive. + +`arch(`_name_`)` +: Tests if the current architecture is _name_. The argument is + matched against `System.Info.arch` on the target system. If the arch + names match, this test evaluates to true, otherwise false. The match + is case-insensitive. + +`impl(`_compiler_`)` +: Tests for the configured Haskell implementation. An optional version + constraint may be specified (for example `impl(ghc >= 6.6.1)`). If + the configured implementation is of the right type and matches the + version constraint, then this evaluates to true, otherwise false. + The match is case-insensitive. + +`flag(`_name_`)` +: Evaluates to the current assignment of the flag of the given name. + Flag names are case insensitive. Testing for flags that have not + been introduced with a flag section is an error. + +`true` +: Constant value true. + +`false` +: Constant value false. + +#### Resolution of Conditions and Flags #### + +If a package descriptions specifies configuration flags the package user +can [control these in several ways](#controlling-flag-assignments). If +the user does not fix the value of a flag, Cabal will try to find a flag +assignment in the following way. + + * For each flag specified, it will assign its default value, evaluate + all conditions with this flag assignment, and check if all + dependencies can be satisfied. If this check succeeded, the package + will be configured with those flag assignments. + + * If dependencies were missing, the last flag (as by the order in + which the flags were introduced in the package description) is tried + with its alternative value and so on. This continues until either + an assignment is found where all dependencies can be satisfied, or + all possible flag assignments have been tried. + +To put it another way, Cabal does a complete backtracking search to find +a satisfiable package configuration. It is only the dependencies +specified in the `build-depends` field in conditional blocks that +determine if a particular flag assignment is satisfiable (`build-tools` +are not considered). The order of the declaration and the default value +of the flags determines the search order. Flags overridden on the +command line fix the assignment of that flag, so no backtracking will be +tried for that flag. + +If no suitable flag assignment could be found, the configuration phase +will fail and a list of missing dependencies will be printed. Note that +this resolution process is exponential in the worst case (i.e., in the +case where dependencies cannot be satisfied). There are some +optimizations applied internally, but the overall complexity remains +unchanged. + +### Meaning of field values when using conditionals ### + +During the configuration phase, a flag assignment is chosen, all +conditionals are evaluated, and the package description is combined into +a flat package descriptions. If the same field both inside a conditional +and outside then they are combined using the following rules. + + + * Boolean fields are combined using conjunction (logical "and"). + + * List fields are combined by appending the inner items to the outer + items, for example + + ~~~~~~~~~~~~~~~~ + Extensions: CPP + if impl(ghc) || impl(hugs) + Extensions: MultiParamTypeClasses + ~~~~~~~~~~~~~~~~ + + when compiled using Hugs or GHC will be combined to + + ~~~~~~~~~~~~~~~~ + Extensions: CPP, MultiParamTypeClasses + ~~~~~~~~~~~~~~~~ + + Similarly, if two conditional sections appear at the same nesting + level, properties specified in the latter will come after properties + specified in the former. + + * All other fields must not be specified in ambiguous ways. For + example + + ~~~~~~~~~~~~~~~~ + Main-is: Main.hs + if flag(useothermain) + Main-is: OtherMain.hs + ~~~~~~~~~~~~~~~~ + + will lead to an error. Instead use + + ~~~~~~~~~~~~~~~~ + if flag(useothermain) + Main-is: OtherMain.hs + else + Main-is: Main.hs + ~~~~~~~~~~~~~~~~ + +### Source Repositories ### + +It is often useful to be able to specify a source revision control +repository for a package. Cabal lets you specifying this information in +a relatively structured form which enables other tools to interpret and +make effective use of the information. For example the information +should be sufficient for an automatic tool to checkout the sources. + +Cabal supports specifying different information for various common +source control systems. Obviously not all automated tools will support +all source control systems. + +Cabal supports specifying repositories for different use cases. By +declaring which case we mean automated tools can be more useful. There +are currently two kinds defined: + + * The `head` kind refers to the latest development branch of the + package. This may be used for example to track activity of a project + or as an indication to outside developers what sources to get for + making new contributions. + + * The `this` kind refers to the branch and tag of a repository that + contains the sources for this version or release of a package. For most + source control systems this involves specifying a tag, id or hash of + some form and perhaps a branch. The purpose is to be able to + reconstruct the sources corresponding to a particular package + version. This might be used to indicate what sources to get if + someone needs to fix a bug in an older branch that is no longer an + active head branch. + +You can specify one kind or the other or both. As an example here are +the repositories for the Cabal library. Note that the `this` kind of +repo specifies a tag. + +~~~~~~~~~~~~~~~~ +source-repository head + type: darcs + location: http://darcs.haskell.org/cabal/ + +source-repository this + type: darcs + location: http://darcs.haskell.org/cabal-branches/cabal-1.6/ + tag: 1.6.1 +~~~~~~~~~~~~~~~~ + +The exact fields are as follows: + +`type:` _token_ +: The name of the source control system used for this repository. The + currently recognised types are: + + * `darcs` + * `git` + * `svn` + * `cvs` + * `mercurial` (or alias `hg`) + * `bazaar` (or alias `bzr`) + * `arch` + * `monotone` + + This field is required. + +`location:` _URL_ +: The location of the repository. The exact form of this field depends + on the repository type. For example: + + * for darcs: `http://code.haskell.org/foo/` + * for git: `git://github.com/foo/bar.git` + * for CVS: `anoncvs@cvs.foo.org:/cvs` + + This field is required. + +`module:` _token_ +: CVS requires a named module, as each CVS server can host multiple + named repositories. + + This field is required for the CVS repo type and should not be used + otherwise. + +`branch:` _token_ +: Many source control systems support the notion of a branch, as a + distinct concept from having repositories in separate locations. For + example CVS, SVN and git use branches while for darcs uses different + locations for different branches. If you need to specify a branch to + identify a your repository then specify it in this field. + + This field is optional. + +`tag:` _token_ +: A tag identifies a particular state of a source repository. The tag + can be used with a `this` repo kind to identify the state of a repo + corresponding to a particular package version or release. The exact + form of the tag depends on the repository type. + + This field is required for the `this` repo kind. + +`subdir:` _directory_ +: Some projects put the sources for multiple packages under a single + source repository. This field lets you specify the relative path + from the root of the repository to the top directory for the + package, ie the directory containing the package's `.cabal` file. + + This field is optional. It default to empty which corresponds to the + root directory of the repository. + +## Accessing data files from package code ## + +The placement on the target system of files listed in the `data-files` +field varies between systems, and in some cases one can even move +packages around after installation (see [prefix +independence](#prefix-independence)). To enable packages to find these +files in a portable way, Cabal generates a module called +`Paths_`_pkgname_ (with any hyphens in _pkgname_ replaced by +underscores) during building, so that it may be imported by modules of +the package. This module defines a function + +~~~~~~~~~~~~~~~ +getDataFileName :: FilePath -> IO FilePath +~~~~~~~~~~~~~~~ + +If the argument is a filename listed in the `data-files` field, the +result is the name of the corresponding file on the system on which the +program is running. + +Note: If you decide to import the `Paths_`_pkgname_ module then it +*must* be listed in the `other-modules` field just like any other module +in your package. + +The `Paths_`_pkgname_ module is not platform independent so it does not +get included in the source tarballs generated by `sdist`. + +### Accessing the package version ### + +The aforementioned auto generated `Paths_`_pkgname_ module also +exports the constant `version ::` [Version][data-version] which is +defined as the version of your package as specified in the `version` +field. + +## System-dependent parameters ## + +For some packages, especially those interfacing with C libraries, +implementation details and the build procedure depend on the build +environment. A variant of the simple build infrastructure (the +`build-type` `Configure`) handles many such situations using a slightly +longer `Setup.hs`: + +~~~~~~~~~~~~~~~~ +import Distribution.Simple +main = defaultMainWithHooks autoconfUserHooks +~~~~~~~~~~~~~~~~ + +Most packages, however, would probably do better with +[configurations](#configurations). + +This program differs from `defaultMain` in two ways: + +* The package root directory must contain a shell script called + `configure`. The configure step will run the script. This `configure` + script may be produced by [autoconf][] or may be hand-written. The + `configure` script typically discovers information about the system + and records it for later steps, e.g. by generating system-dependent + header files for inclusion in C source files and preprocessed Haskell + source files. (Clearly this won't work for Windows without MSYS or + Cygwin: other ideas are needed.) + +* If the package root directory contains a file called + _package_`.buildinfo` after the configuration step, subsequent steps + will read it to obtain additional settings for [build + information](#build-information) fields,to be merged with the ones + given in the `.cabal` file. In particular, this file may be generated + by the `configure` script mentioned above, allowing these settings to + vary depending on the build environment. + + The build information file should have the following structure: + + > _buildinfo_ + > + > `executable:` _name_ + > _buildinfo_ + > + > `executable:` _name_ + > _buildinfo_ + > ... + + where each _buildinfo_ consists of settings of fields listed in the + section on [build information](#build-information). The first one (if + present) relates to the library, while each of the others relate to + the named executable. (The names must match the package description, + but you don't have to have entries for all of them.) + +Neither of these files is required. If they are absent, this setup +script is equivalent to `defaultMain`. + +#### Example: Using autoconf #### + +This example is for people familiar with the [autoconf][] tools. + +In the X11 package, the file `configure.ac` contains: + +~~~~~~~~~~~~~~~~ +AC_INIT([Haskell X11 package], [1.1], [libraries@haskell.org], [X11]) + +# Safety check: Ensure that we are in the correct source directory. +AC_CONFIG_SRCDIR([X11.cabal]) + +# Header file to place defines in +AC_CONFIG_HEADERS([include/HsX11Config.h]) + +# Check for X11 include paths and libraries +AC_PATH_XTRA +AC_TRY_CPP([#include ],,[no_x=yes]) + +# Build the package if we found X11 stuff +if test "$no_x" = yes +then BUILD_PACKAGE_BOOL=False +else BUILD_PACKAGE_BOOL=True +fi +AC_SUBST([BUILD_PACKAGE_BOOL]) + +AC_CONFIG_FILES([X11.buildinfo]) +AC_OUTPUT +~~~~~~~~~~~~~~~~ + +Then the setup script will run the `configure` script, which checks for +the presence of the X11 libraries and substitutes for variables in the +file `X11.buildinfo.in`: + +~~~~~~~~~~~~~~~~ +buildable: @BUILD_PACKAGE_BOOL@ +cc-options: @X_CFLAGS@ +ld-options: @X_LIBS@ +~~~~~~~~~~~~~~~~ + +This generates a file `X11.buildinfo` supplying the parameters needed by +later stages: + +~~~~~~~~~~~~~~~~ +buildable: True +cc-options: -I/usr/X11R6/include +ld-options: -L/usr/X11R6/lib +~~~~~~~~~~~~~~~~ + +The `configure` script also generates a header file +`include/HsX11Config.h` containing C preprocessor defines recording the +results of various tests. This file may be included by C source files +and preprocessed Haskell source files in the package. + +Note: Packages using these features will also need to list +additional files such as `configure`, +templates for `.buildinfo` files, files named +only in `.buildinfo` files, header files and +so on in the `extra-source-files` field, +to ensure that they are included in source distributions. +They should also list files and directories generated by +`configure` in the +`extra-tmp-files` field to ensure that they +are removed by `setup clean`. + +## Conditional compilation ## + +Sometimes you want to write code that works with more than one version +of a dependency. You can specify a range of versions for the depenency +in the `build-depends`, but how do you then write the code that can use +different versions of the API? + +Haskell lets you preprocess your code using the C preprocessor (either +the real C preprocessor, or `cpphs`). To enable this, add `extensions: +CPP` to your package description. When using CPP, Cabal provides some +pre-defined macros to let you test the version of dependent packages; +for example, suppose your package works with either version 3 or version +4 of the `base` package, you could select the available version in your +Haskell modules like this: + +~~~~~~~~~~~~~~~~ +#if MIN_VERSION_base(4,0,0) +... code that works with base-4 ... +#else +... code that works with base-3 ... +#endif +~~~~~~~~~~~~~~~~ + +In general, Cabal supplies a macro `MIN_VERSION_`_`package`_`_(A,B,C)` +for each package depended on via `build-depends`. This macro is true if +the actual version of the package in use is greater than or equal to +`A.B.C` (using the conventional ordering on version numbers, which is +lexicographic on the sequence, but numeric on each component, so for +example 1.2.0 is greater than 1.0.3). + +Cabal places the definitions of these macros into an +automatically-generated header file, which is included when +preprocessing Haskell source code by passing options to the C +preprocessor. + +## More complex packages ## + +For packages that don't fit the simple schemes described above, you have +a few options: + + * You can customize the simple build infrastructure using _hooks_. + These allow you to perform additional actions before and after each + command is run, and also to specify additional preprocessors. See + `UserHooks` in [Distribution.Simple][dist-simple] for the details, + but note that this interface is experimental, and likely to change + in future releases. + + * You could delegate all the work to `make`, though this is unlikely + to be very portable. Cabal supports this with the `build-type` + `Make` and a trivial setup library [Distribution.Make][dist-make], + which simply parses the command line arguments and invokes `make`. + Here `Setup.hs` looks like + + ~~~~~~~~~~~~~~~~ + import Distribution.Make + main = defaultMain + ~~~~~~~~~~~~~~~~ + + The root directory of the package should contain a `configure` + script, and, after that has run, a `Makefile` with a default target + that builds the package, plus targets `install`, `register`, + `unregister`, `clean`, `dist` and `docs`. Some options to commands + are passed through as follows: + + * The `--with-hc-pkg`, `--prefix`, `--bindir`, `--libdir`, + `--datadir` and `--libexecdir` options to the `configure` + command are passed on to the `configure` script. In addition the + value of the `--with-compiler` option is passed in a `--with-hc` + option and all options specified with `--configure-option=` are + passed on. + + * The `--destdir` option to the `copy` command becomes a setting + of a `destdir` variable on the invocation of `make copy`. The + supplied `Makefile` should provide a `copy` target, which will + probably look like this: + + ~~~~~~~~~~~~~~~~ + copy : + $(MAKE) install prefix=$(destdir)/$(prefix) \ + bindir=$(destdir)/$(bindir) \ + libdir=$(destdir)/$(libdir) \ + datadir=$(destdir)/$(datadir) \ + libexecdir=$(destdir)/$(libexecdir) + ~~~~~~~~~~~~~~~~ + + * You can write your own setup script conforming to the interface + described in the section on [building and installing + packages](#building-and-installing-a-package), possibly using the + Cabal library for part of the work. One option is to copy the + source of `Distribution.Simple`, and alter it for your needs. + Good luck. + + + +[dist-simple]: ../libraries/Cabal/Distribution-Simple.html +[dist-make]: ../libraries/Cabal/Distribution-Make.html +[dist-license]: ../libraries/Cabal/Distribution-License.html#t:License +[extension]: ../libraries/Cabal/Language-Haskell-Extension.html#t:Extension +[BuildType]: ../libraries/Cabal/Distribution-PackageDescription.html#t:BuildType +[data-version]: http://hackage.haskell.org/packages/archive/base/latest/doc/html/Data-Version.html +[alex]: http://www.haskell.org/alex/ +[autoconf]: http://www.gnu.org/software/autoconf/ +[c2hs]: http://www.cse.unsw.edu.au/~chak/haskell/c2hs/ +[cpphs]: http://www.haskell.org/cpphs/ +[greencard]: http://www.haskell.org/greencard/ +[haddock]: http://www.haskell.org/haddock/ +[HsColour]: http://www.cs.york.ac.uk/fp/darcs/hscolour/ +[happy]: http://www.haskell.org/happy/ +[Hackage]: http://hackage.haskell.org/ +[pkg-config]: http://pkg-config.freedesktop.org/ diff -Nru ghc-7.0.3/libraries/Cabal/cabal/doc/index.markdown ghc-7.2.1/libraries/Cabal/cabal/doc/index.markdown --- ghc-7.0.3/libraries/Cabal/cabal/doc/index.markdown 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/doc/index.markdown 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,169 @@ +% Cabal User Guide + +Cabal is package system for [Haskell] software. + +Cabal specifies a standard way in which Haskell libraries and +applications can be packaged so that it is easy for consumers to use +them, or re-package them, regardless of the Haskell implementation or +installation platform. + +Cabal defines a common interface -- the _Cabal package_ -- between +package authors, builders and users. There is a library to help package +authors implement this interface, and a tool to enable developers, +builders and users to work with Cabal packages. + +# Contents # + + * [Introduction](#introduction) + - [What's in a package](#whats-in-a-package) + - [A tool for working with packages](#a-tool-for-working-with-packages) + * [Developing packages](developing-packages.html) + - [Package descriptions](developing-packages.html#package-descriptions) + + [Package properties](developing-packages.html#package-properties) + + [Library](developing-packages.html#library) + + [Executables](developing-packages.html#executables) + + [Test suites](developing-packages.html#test-suites) + + [Build information](developing-packages.html#build-information) + + [Configurations](developing-packages.html#configurations) + + [Source Repositories](developing-packages.html#source-repositories) + - [Accessing data files from package code](developing-packages.html#accessing-data-files-from-package-code) + + [Accessing the package version](developing-packages.html#accessing-the-package-version) + - [System-dependent parameters](developing-packages.html#system-dependent-parameters) + - [Conditional compilation](developing-packages.html#conditional-compilation) + - [More complex packages](developing-packages.html#more-complex-packages) + * [Building and installing packages](installing-packages.html) + - [Building and installing a system package](installing-packages.html#building-and-installing-a-system-package) + - [Building and installing a user package](installing-packages.html#building-and-installing-a-user-package) + - [Creating a binary package](installing-packages.html#creating-a-binary-package) + - [setup configure](installing-packages.html#setup-configure) + + [Programs used for building](installing-packages.html#programs-used-for-building) + + [Installation paths](installing-packages.html#installation-paths) + + [Controlling Flag Assignments](installing-packages.html#controlling-flag-assignments) + + [Building Test Suites](installing-packages.html#building-test-suites) + + [Miscellaneous options](installing-packages.html#miscellaneous-options) + - [setup build](installing-packages.html#setup-build) + - [setup haddock](installing-packages.html#setup-haddock) + - [setup hscolour](installing-packages.html#setup-hscolour) + - [setup install](installing-packages.html#setup-install) + - [setup copy](installing-packages.html#setup-copy) + - [setup register](installing-packages.html#setup-register) + - [setup unregister](installing-packages.html#setup-unregister) + - [setup clean](installing-packages.html#setup-clean) + - [setup test](installing-packages.html#setup-test) + - [setup sdist](installing-packages.html#setup-sdist) + * [Reporting bugs and deficiencies](misc.html#reporting-bugs-and-deficiencies) + * [Stability of Cabal interfaces](misc.html#stability-of-cabal-interfaces) + - [Cabal file format](misc.html#cabal-file-format) + - [Command-line interface](misc.html#command-line-interface) + + [Very Stable Command-line interfaces](misc.html#very-stable-command-line-interfaces) + + [Stable Command-line interfaces](misc.html#stable-command-line-interfaces) + + [Unstable command-line](misc.html#unstable-command-line) + - [Functions and Types](misc.html#functions-and-types) + + [Very Stable API](misc.html#very-stable-api) + + [Semi-stable API](misc.html#semi-stable-api) + + [Unstable API](#unstable-api) + - [Hackage](misc.html#hackage) + +# Introduction # + +Cabal is package system for Haskell software. The point of a packaging +system is to enable software developers and users to easily distribute, +use and reuse software. A good packaging system makes it easier for +developers to get their software into the hands of users, but equally +importantly it makes it easier for software developers to be able to +reuse software components written by other developers. + +Packaging systems deal with packages and with Cabal we call them _Cabal +packages_. The Cabal package is the unit of distribution. Every Cabal +package has a name and a version number which are used to identify the +package, e.g. `filepath-1.0`. + +Cabal packages are source based and are typically (but not necessarily) +portable to many platforms and Haskell implementations. The Cabal +package format is designed to make it possible to translate into other +formats, including binary packages for various systems. + +When distributed, Cabal packages use the standard compressed tarball +format, with the file extension `.tar.gz`, e.g. `filepath-1.0.tar.gz`. + +Note that packages are not part of the Haskell language, but most +Haskell implementations have some notion of package, and Cabal supports +most Haskell implementations. + + +## What's in a package ## + +A Cabal package consists of: + + * Haskell software, including libraries, executables and tests + * meta-data about the package in a standard human and machine + readable format (the "`.cabal`" file) + * a standard interface to build the package (the "`Setup.hs`" file) + +The `.cabal` file contains information about the package, supplied by +the package author. Some of this information is used for identifying and +managing the package when it comes to distribution. + +For the majority of packages it is possible to supply enough information +in the `.cabal` file so that it can be built without the package author +needing to write any extra build system scripts. For complex packages it +may be necessary to add code to the `Setup.hs` file. + +Here is an example `foo.cabal` for a very simple Haskell library that +exposes one Haskell module called `Data.Foo`: + +~~~~~~~~~~~~~~~~ +name: foo +version: 1.0 +build-type: Simple +cabal-version: >= 1.2 + +library + exposed-modules: Data.Foo + build-depends: base >= 3 && < 5 +~~~~~~~~~~~~~~~~ + +For full details on what goes in the `.cabal` and `Setup.hs` files, and +for all the other features provided by the build system, see the section +on [developing packages](developing-packages.html). + + +## A tool for working with packages ## + +There is a command line tool, called `cabal`, that users and developers +can use to install Cabal packages. It can be used for both local +packages and for packages available remotely over the network. + +Developers can use the tool with packages in local directories, e.g. + +~~~~~~~~~~~~~~~~ +cd foo/ +cabal install +~~~~~~~~~~~~~~~~ + +Developers and users can use the tool to install packages from remote +Cabal package archives. By default, the `cabal` tool is configured to +use the centeralised Haskell community archive called [Hackage] but it +is possible to use it with any other suitable archive. + +~~~~~~~~~~~~~~~~ +cabal install xmonad +~~~~~~~~~~~~~~~~ + +This will install the `xmonad` package plus all of its dependencies. + +Cabal provides a number of ways for a user to customise how and where a +package is installed. They can decide where a package will be installed, +which Haskell implementation to use and whether to build optimised code +or build with the ability to profile code. It is not expected that users +will have to modify any of the information in the `.cabal` file. + +For full details, see the section on [building and installing +packages](installing-packages.html). + +Note that `cabal` is not the only tool for working with Cabal packages. +Due to the standardised format and a library for reading `.cabal` files, +there are several other special-purpose tools. + +[Haskell]: http://www.haskell.org/ +[Hackage]: http://hackage.haskell.org/ diff -Nru ghc-7.0.3/libraries/Cabal/cabal/doc/installing-packages.markdown ghc-7.2.1/libraries/Cabal/cabal/doc/installing-packages.markdown --- ghc-7.0.3/libraries/Cabal/cabal/doc/installing-packages.markdown 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/doc/installing-packages.markdown 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,809 @@ +% Cabal User Guide + + +# Building and installing packages # + +After you've unpacked a Cabal package, you can build it by moving into +the root directory of the package and using the `Setup.hs` or +`Setup.lhs` script there: + +> `_runhaskell_ Setup.hs` [_command_] [_option_...] + +The _command_ argument selects a particular step in the build/install +process. You can also get a summary of the command syntax with + +> `runhaskell Setup.hs --help` + +## Building and installing a system package ## + +~~~~~~~~~~~~~~~~ +runhaskell Setup.hs configure --ghc +runhaskell Setup.hs build +runhaskell Setup.hs install +~~~~~~~~~~~~~~~~ + +The first line readies the system to build the tool using GHC; for +example, it checks that GHC exists on the system. The second line +performs the actual building, while the last both copies the build +results to some permanent place and registers the package with GHC. + +## Building and installing a user package ## + +~~~~~~~~~~~~~~~~ +runhaskell Setup.hs configure --user +runhaskell Setup.hs build +runhaskell Setup.hs install +~~~~~~~~~~~~~~~~ + +The package is installed under the user's home directory and is +registered in the user's package database (`--user`). + +## Creating a binary package ## + +When creating binary packages (e.g. for RedHat or Debian) one needs to +create a tarball that can be sent to another system for unpacking in the +root directory: + +~~~~~~~~~~~~~~~~ +runhaskell Setup.hs configure --prefix=/usr +runhaskell Setup.hs build +runhaskell Setup.hs copy --destdir=/tmp/mypkg +tar -czf mypkg.tar.gz /tmp/mypkg/ +~~~~~~~~~~~~~~~~ + +If the package contains a library, you need two additional steps: + +~~~~~~~~~~~~~~~~ +runhaskell Setup.hs register --gen-script +runhaskell Setup.hs unregister --gen-script +~~~~~~~~~~~~~~~~ + +This creates shell scripts `register.sh` and `unregister.sh`, which must +also be sent to the target system. After unpacking there, the package +must be registered by running the `register.sh` script. The +`unregister.sh` script would be used in the uninstall procedure of the +package. Similar steps may be used for creating binary packages for +Windows. + + +The following options are understood by all commands: + +`--help`, `-h` or `-?` +: List the available options for the command. + +`--verbose=`_n_ or `-v`_n_ +: Set the verbosity level (0-3). The normal level is 1; a missing _n_ + defaults to 2. + +The various commands and the additional options they support are +described below. In the simple build infrastructure, any other options +will be reported as errors. + +## setup configure ## + +Prepare to build the package. Typically, this step checks that the +target platform is capable of building the package, and discovers +platform-specific features that are needed during the build. + +The user may also adjust the behaviour of later stages using the options +listed in the following subsections. In the simple build +infrastructure, the values supplied via these options are recorded in a +private file read by later stages. + +If a user-supplied `configure` script is run (see the section on +[system-dependent parameters](#system-dependent-parameters) or on +[complex packages](#complex-packages)), it is passed the +`--with-hc-pkg`, `--prefix`, `--bindir`, `--libdir`, `--datadir` and +`--libexecdir` options. In addition the value of the `--with-compiler` +option is passed in a `--with-hc` option and all options specified with +`--configure-option=` are passed on. + +### Programs used for building ### + +The following options govern the programs used to process the source +files of a package: + +`--ghc` or `-g`, `--nhc`, `--jhc`, `--hugs` +: Specify which Haskell implementation to use to build the package. + At most one of these flags may be given. If none is given, the + implementation under which the setup script was compiled or + interpreted is used. + +`--with-compiler=`_path_ or `-w`_path_ +: Specify the path to a particular compiler. If given, this must match + the implementation selected above. The default is to search for the + usual name of the selected implementation. + + This flag also sets the default value of the `--with-hc-pkg` option + to the package tool for this compiler. Check the output of `setup + configure -v` to ensure that it finds the right package tool (or use + `--with-hc-pkg` explicitly). + + +`--with-hc-pkg=`_path_ +: Specify the path to the package tool, e.g. `ghc-pkg`. The package + tool must be compatible with the compiler specified by + `--with-compiler`. If this option is omitted, the default value is + determined from the compiler selected. + +`--with-`_`prog`_`=`_path_ +: Specify the path to the program _prog_. Any program known to Cabal + can be used in place of _prog_. It can either be a fully path or the + name of a program that can be found on the program search path. For + example: `--with-ghc=ghc-6.6.1` or + `--with-cpphs=/usr/local/bin/cpphs`. + +`--`_`prog`_`-options=`_options_ +: Specify additional options to the program _prog_. Any program known + to Cabal can be used in place of _prog_. For example: + `--alex-options="--template=mytemplatedir/"`. The _options_ is split + into program options based on spaces. Any options containing embeded + spaced need to be quoted, for example + `--foo-options='--bar="C:\Program File\Bar"'`. As an alternative + that takes only one option at a time but avoids the need to quote, + use `--`_`prog`_`-option` instead. + +`--`_`prog`_`-option=`_option_ +: Specify a single additional option to the program _prog_. For + passing an option that contain embeded spaces, such as a file name + with embeded spaces, using this rather than `--`_`prog`_`-options` + means you do not need an additional level of quoting. Of course if + you are using a command shell you may still need to quote, for + example `--foo-options="--bar=C:\Program File\Bar"`. + +All of the options passed with either `--`_`prog`_`-options` or +`--`_`prog`_`-option` are passed in the order they were specified on the +configure command line. + +### Installation paths ### + +The following options govern the location of installed files from a +package: + +`--prefix=`_dir_ +: The root of the installation. For example for a global install you + might use `/usr/local` on a Unix system, or `C:\Program Files` on a + Windows system. The other installation paths are usually + subdirectories of _prefix_, but they don't have to be. + + In the simple build system, _dir_ may contain the following path + variables: `$pkgid`, `$pkg`, `$version`, `$compiler`, `$os`, + `$arch` + +`--bindir=`_dir_ +: Executables that the user might invoke are installed here. + + In the simple build system, _dir_ may contain the following path + variables: `$prefix`, `$pkgid`, `$pkg`, `$version`, `$compiler`, + `$os`, `$arch` + +`--libdir=`_dir_ +: Object-code libraries are installed here. + + In the simple build system, _dir_ may contain the following path + variables: `$prefix`, `$bindir`, `$pkgid`, `$pkg`, `$version`, + `$compiler`, `$os`, `$arch` + +`--libexecdir=`_dir_ +: Executables that are not expected to be invoked directly by the user + are installed here. + + In the simple build system, _dir_ may contain the following path + variables: `$prefix`, `$bindir`, `$libdir`, `$libsubdir`, `$pkgid`, + `$pkg`, `$version`, `$compiler`, `$os`, `$arch` + +`--datadir`=_dir_ +: Architecture-independent data files are installed here. + + In the simple build system, _dir_ may contain the following path + variables: `$prefix`, `$bindir`, `$libdir`, `$libsubdir`, `$pkgid`, `$pkg`, + `$version`, `$compiler`, `$os`, `$arch` + +In addition the simple build system supports the following installation path options: + +`--libsubdir=`_dir_ +: A subdirectory of _libdir_ in which libraries are actually + installed. For example, in the simple build system on Unix, the + default _libdir_ is `/usr/local/lib`, and _libsubdir_ contains the + package identifier and compiler, e.g. `mypkg-0.2/ghc-6.4`, so + libraries would be installed in `/usr/local/lib/mypkg-0.2/ghc-6.4`. + + _dir_ may contain the following path variables: `$pkgid`, `$pkg`, + `$version`, `$compiler`, `$os`, `$arch` + +`--datasubdir=`_dir_ +: A subdirectory of _datadir_ in which data files are actually + installed. + + _dir_ may contain the following path variables: `$pkgid`, `$pkg`, + `$version`, `$compiler`, `$os`, `$arch` + +`--docdir=`_dir_ +: Documentation files are installed relative to this directory. + + _dir_ may contain the following path variables: `$prefix`, `$bindir`, + `$libdir`, `$libsubdir`, `$datadir`, `$datasubdir`, `$pkgid`, `$pkg`, + `$version`, `$compiler`, `$os`, `$arch` + +`--htmldir=`_dir_ +: HTML documentation files are installed relative to this directory. + + _dir_ may contain the following path variables: `$prefix`, `$bindir`, + `$libdir`, `$libsubdir`, `$datadir`, `$datasubdir`, `$docdir`, `$pkgid`, + `$pkg`, `$version`, `$compiler`, `$os`, `$arch` + +`--program-prefix=`_prefix_ +: Prepend _prefix_ to installed program names. + + _prefix_ may contain the following path variables: `$pkgid`, `$pkg`, + `$version`, `$compiler`, `$os`, `$arch` + +`--program-suffix=`_suffix_ +: Append _suffix_ to installed program names. The most obvious use for + this is to append the program's version number to make it possible + to install several versions of a program at once: + `--program-suffix='$version'`. + + _suffix_ may contain the following path variables: `$pkgid`, `$pkg`, + `$version`, `$compiler`, `$os`, `$arch` + +#### Path variables in the simple build system #### + +For the simple build system, there are a number of variables that can be +used when specifying installation paths. The defaults are also specified +in terms of these variables. A number of the variables are actually for +other paths, like `$prefix`. This allows paths to be specified relative +to each other rather than as absolute paths, which is important for +building relocatable packages (see [prefix +independence](#prefix-independence)). + +`$prefix` +: The path variable that stands for the root of the installation. For + an installation to be relocatable, all other instllation paths must + be relative to the `$prefix` variable. + +`$bindir` +: The path variable that expands to the path given by the `--bindir` + configure option (or the default). + +`$libdir` +: As above but for `--libdir` + +`$libsubdir` +: As above but for `--libsubdir` + +`$datadir` +: As above but for `--datadir` + +`$datasubdir` +: As above but for `--datasubdir` + +`$docdir` +: As above but for `--docdir` + +`$pkgid` +: The name and version of the package, eg `mypkg-0.2` + +`$pkg` +: The name of the package, eg `mypkg` + +`$version` +: The version of the package, eg `0.2` + +`$compiler` +: The compiler being used to build the package, eg `ghc-6.6.1` + +`$os` +: The operating system of the computer being used to build the + package, eg `linux`, `windows`, `osx`, `freebsd` or `solaris` + +`$arch` +: The architecture of the computer being used to build the package, eg + `i386`, `x86_64`, `ppc` or `sparc` + +#### Paths in the simple build system #### + +For the simple build system, the following defaults apply: + +Option Windows Default Unix Default +------- ---------------- ------------- +`--prefix` (global) `C:\Program Files\Haskell` `/usr/local` +`--prefix` (per-user) `C:\Documents And Settings\user\Application Data\cabal` `$HOME/.cabal` +`--bindir` `$prefix\bin` `$prefix/bin` +`--libdir` `$prefix` `$prefix/lib` +`--libsubdir` (Hugs) `hugs\packages\$pkg` `hugs/packages/$pkg` +`--libsubdir` (others) `$pkgid\$compiler` `$pkgid/$compiler` +`--libexecdir` `$prefix\$pkgid` `$prefix/libexec` +`--datadir` (executable) `$prefix` `$prefix/share` +`--datadir` (library) `C:\Program Files\Haskell` `$prefix/share` +`--datasubdir` `$pkgid` `$pkgid` +`--docdir` `$prefix\doc\$pkgid` `$datadir/doc/$pkgid` +`--htmldir` `$docdir\html` `$docdir/html` +`--program-prefix` (empty) (empty) +`--program-suffix` (empty) (empty) + + +#### Prefix-independence #### + +On Windows, and when using Hugs on any system, it is possible to obtain +the pathname of the running program. This means that we can construct an +installable executable package that is independent of its absolute +install location. The executable can find its auxiliary files by finding +its own path and knowing the location of the other files relative to +`$bindir`. Prefix-independence is particularly +useful: it means the user can choose the install location (i.e. the +value of `$prefix`) at install-time, rather than +having to bake the path into the binary when it is built. + +In order to achieve this, we require that for an executable on Windows, +all of `$bindir`, `$libdir`, `$datadir` and `$libexecdir` begin with +`$prefix`. If this is not the case then the compiled executable will +have baked-in all absolute paths. + +The application need do nothing special to achieve prefix-independence. +If it finds any files using `getDataFileName` and the [other functions +provided for the purpose](#accessing-data-files-from-package-code), the +files will be accessed relative to the location of the current +executable. + +A library cannot (currently) be prefix-independent, because it will be +linked into an executable whose file system location bears no relation +to the library package. + +### Controlling Flag Assignments ### + +Flag assignments (see the [resolution of conditions and +flags](#resolution-of-conditions-and-flags)) can be controlled with the +followingcommand line options. + +`-f` _flagname_ or `-f` `-`_flagname_ +: Force the specified flag to `true` or `false` (if preceded with a `-`). Later + specifications for the same flags will override earlier, i.e., + specifying `-fdebug -f-debug` is equivalent to `-f-debug` + +`--flags=`_flagspecs_ +: Same as `-f`, but allows specifying multiple flag assignments at + once. The parameter is a space-separated list of flag names (to + force a flag to `true`), optionally preceded by a `-` (to force a + flag to `false`). For example, `--flags="debug -feature1 feature2"` is + equivalent to `-fdebug -f-feature1 -ffeature2`. + +### Building Test Suites ### + +`--enable-tests` +: Build the test suites defined in the package description file during the + `build` stage. Check for dependencies required by the test suites. If the + package is configured with this option, it will be possible to run the test + suites with the `test` command after the package is built. + +`--disable-tests` +: (default) Do not build any test suites during the `build` stage. + Do not check for dependencies required only by the test suites. It will not + be possible to invoke the `test` command without reconfiguring the package. + +### Miscellaneous options ## + +`--user` +: Does a per-user installation. This changes the [default installation + prefix](#paths-in-the-simple-build-system). It also allow + dependencies to be satisfied by the user's package database, in + addition to the global database. This also implies a default of + `--user` for any subsequent `install` command, as packages + registered in the global database should not depend on packages + registered in a user's database. + +`--global` +: (default) Does a global installation. In this case package + dependencies must be satisfied by the global package database. All + packages in the user's package database will be ignored. Typically + the final instllation step will require administrative privileges. + +`--package-db=`_db_ +: Allows package dependencies to be satisfied from this additional + package database _db_ in addition to the global package database. + All packages in the user's package database will be ignored. The + interpretation of _db_ is implementation-specific. Typically it will + be a file or directory. Not all implementations support arbitrary + package databases. + +`--enable-optimization`[=_n_] or `-O`[_n_] +: (default) Build with optimization flags (if available). This is + appropriate for production use, taking more time to build faster + libraries and programs. + + The optional _n_ value is the optimisation level. Some compilers + support multiple optimisation levels. The range is 0 to 2. Level 0 + is equivalent to `--disable-optimization`, level 1 is the default if + no _n_ parameter is given. Level 2 is higher optimisation if the + compiler supports it. Level 2 is likely to lead to longer compile + times and bigger generated code. + +`--disable-optimization` +: Build without optimization. This is suited for development: building + will be quicker, but the resulting library or programs will be slower. + +`--enable-library-profiling` or `-p` +: Request that an additional version of the library with profiling + features enabled be built and installed (only for implementations + that support profiling). + +`--disable-library-profiling` +: (default) Do not generate an additional profiling version of the + library. + +`--enable-executable-profiling` +: Any executables generated should have profiling enabled (only for + implementations that support profiling). For this to work, all + libraries used by these executables must also have been built with + profiling support. + +`--disable-executable-profiling` +: (default) Do not enable profiling in generated executables. + +`--enable-library-vanilla` +: (default) Build ordinary libraries (as opposed to profiling + libraries). This is independent of the `--enable-library-profiling` + option. If you enable both, you get both. + +`--disable-library-vanilla` +: Do not build ordinary libraries. This is useful in conjunction with + `--enable-library-profiling` to build only profiling libraries, + rather than profiling and ordinary libraries. + +`--enable-library-for-ghci` +: (default) Build libraries suitable for use with GHCi. + +`--disable-library-for-ghci` +: Not all platforms support GHCi and indeed on some platforms, trying + to build GHCi libs fails. In such cases this flag can be used as a + workaround. + +`--enable-split-objs` +: Use the GHC `-split-objs` feature when building the library. This + reduces the final size of the executables that use the library by + allowing them to link with only the bits that they use rather than + the entire library. The downside is that building the library takes + longer and uses considerably more memory. + +`--disable-split-objs` +: (default) Do not use the GHC `-split-objs` feature. This makes + building the library quicker but the final executables that use the + library will be larger. + +`--enable-executable-stripping` +: (default) When installing binary executable programs, run the + `strip` program on the binary. This can considerably reduce the size + of the executable binary file. It does this by removing debugging + information and symbols. While such extra information is useful for + debugging C programs with traditional debuggers it is rarely helpful + for debugging binaries produced by Haskell compilers. + + Not all Haskell implementations generate native binaries. For such + implementations this option has no effect. + +`--disable-executable-stripping` +: Do not strip binary executables during installation. You might want + to use this option if you need to debug a program using gdb, for + example if you want to debug the C parts of a program containing + both Haskell and C code. Another reason is if your are building a + package for a system which has a policy of managing the stripping + itself (such as some linux distributions). + +`--enable-shared` +: Build shared library. This implies a seperate compiler run to + generate position independent code as required on most platforms. + +`--disable-shared` +: (default) Do not build shared library. + +`--configure-option=`_str_ +: An extra option to an external `configure` script, if one is used + (see the section on [system-dependent + parameters](#system-dependent-parameters)). There can be several of + these options. + +`--extra-include-dirs`[=_dir_] +: An extra directory to search for C header files. You can use this + flag multiple times to get a list of directories. + + You might need to use this flag if you have standard system header + files in a non-standard location that is not mentioned in the + package's `.cabal` file. Using this option has the same affect as + appending the directory _dir_ to the `include-dirs` field in each + library and executable in the package's `.cabal` file. The advantage + of course is that you do not have to modify the package at all. + These extra directories will be used while building the package and + for libraries it is also saved in the package registration + information and used when compiling modules that use the library. + +`--extra-lib-dirs`[=_dir_] +: An extra directory to search for system libraries files. You can use + this flag multiple times to get a list of directories. + + You might need to use this flag if you have standard system + libraries in a non-standard location that is not mentioned in the + package's `.cabal` file. Using this option has the same affect as + appending the directory _dir_ to the `extra-lib-dirs` field in each + library and executable in the package's `.cabal` file. The advantage + of course is that you do not have to modify the package at all. + These extra directories will be used while building the package and + for libraries it is also saved in the package registration + information and used when compiling modules that use the library. + +In the simple build infrastructure, an additional option is recognized: + +`--scratchdir=`_dir_ +: Specify the directory into which the Hugs output will be placed + (default: `dist/scratch`). + +## setup build ## + +Perform any preprocessing or compilation needed to make this package ready for installation. + +This command takes the following options: + +--_prog_-options=_options_, --_prog_-option=_option_ +: These are mostly the same as the [options configure + step](#setup-configure). Unlike the options specified at the + configure step, any program options specified at the build step are + not persistent but are used for that invocation only. They options + specified at the build step are in addition not in replacement of + any options specified at the configure step. + +## setup haddock ## + +Build the documentation for the package using [haddock][]. By default, +only the documentation for the exposed modules is generated (but see the +`--executables` and `--internal` flags below). + +This command takes the following options: + +`--hoogle` +: Generate a file `dist/doc/html/`_pkgid_`.txt`, which can be + converted by [Hoogle](http://www.haskell.org/hoogle/) into a + database for searching. This is equivalent to running [haddock][] + with the `--hoogle` flag. + +`--html-location=`_url_ +: Specify a template for the location of HTML documentation for + prerequisite packages. The substitutions ([see + listing](#paths-in-the-simple-build-system)) are applied to the + template to obtain a location for each package, which will be used + by hyperlinks in the generated documentation. For example, the + following command generates links pointing at [Hackage] pages: + + > setup haddock --html-location='http://hackage.haskell.org/packages/archive/$pkg/latest/doc/html' + + Here the argument is quoted to prevent substitution by the shell. If + this option is omitted, the location for each package is obtained + using the package tool (e.g. `ghc-pkg`). + +`--executables` +: Also run [haddock][] for the modules of all the executable programs. + By default [haddock][] is run only on the exported modules. + +`--internal` +: Run [haddock][] for the all modules, including unexposed ones, and + make [haddock][] generate documentation for unexported symbols as + well. + +`--css=`_path_ +: The argument _path_ denotes a CSS file, which is passed to + [haddock][] and used to set the style of the generated + documentation. This is only needed to override the default style + that [haddock][] uses. + +`--hyperlink-source` +: Generate [haddock][] documentation integrated with [HsColour][]. + First, [HsColour][] is run to generate colourised code. Then + [haddock][] is run to generate HTML documentation. Each entity + shown in the documentation is linked to its definition in the + colourised code. + +`--hscolour-css=`_path_ +: The argument _path_ denotes a CSS file, which is passed to [HsColour][] as in + + > runhaskell Setup.hs hscolour --css=_path_ + +## setup hscolour ## + +Produce colourised code in HTML format using [HsColour][]. Colourised +code for exported modules is put in `dist/doc/html/`_pkgid_`/src`. + +This command takes the following options: + +`--executables` +: Also run [HsColour][] on the sources of all executable programs. + Colourised code is put in `dist/doc/html/`_pkgid_/_executable_`/src`. + +`--css=`_path_ +: Use the given CSS file for the generated HTML files. The CSS file + defines the colours used to colourise code. Note that this copies + the given CSS file to the directory with the generated HTML files + (renamed to `hscolour.css`) rather than linking to it. + +## setup install ## + +Copy the files into the install locations and (for library packages) +register the package with the compiler, i.e. make the modules it +contains available to programs. + +The [install locations](#installation-paths) are determined by options +to `setup configure`. + +This command takes the following options: + +`--global` +: Register this package in the system-wide database. (This is the + default, unless the `--user` option was supplied to the `configure` + command.) + +`--user` +: Register this package in the user's local package database. (This is + the default if the `--user` option was supplied to the `configure` + command.) + +## setup copy ## + +Copy the files without registering them. This command is mainly of use +to those creating binary packages. + +This command takes the following option: + +`--destdir=`_path_ + +Specify the directory under which to place installed files. If this is +not given, then the root directory is assumed. + +## setup register ## + +Register this package with the compiler, i.e. make the modules it +contains available to programs. This only makes sense for library +packages. Note that the `install` command incorporates this action. The +main use of this separate command is in the post-installation step for a +binary package. + +This command takes the following options: + +`--global` +: Register this package in the system-wide database. (This is the default.) + + +`--user` +: Register this package in the user's local package database. + + +`--gen-script` +: Instead of registering the package, generate a script containing + commands to perform the registration. On Unix, this file is called + `register.sh`, on Windows, `register.bat`. This script might be + included in a binary bundle, to be run after the bundle is unpacked + on the target system. + +`--gen-pkg-config`[=_path_] +: Instead of registering the package, generate a package registration + file. This only applies to compilers that support package + registration files which at the moment is only GHC. The file should + be used with the compiler's mechanism for registering packages. This + option is mainly intended for packaging systems. If possible use the + `--gen-script` option instead since it is more portable across + Haskell implementations. The _path_ is + optional and can be used to specify a particular output file to + generate. Otherwise, by default the file is the package name and + version with a `.conf` extension. + +`--inplace` +: Registers the package for use directly from the build tree, without + needing to install it. This can be useful for testing: there's no + need to install the package after modifying it, just recompile and + test. + + This flag does not create a build-tree-local package database. It + still registers the package in one of the user or global databases. + + However, there are some caveats. It only works with GHC + (currently). It only works if your package doesn't depend on having + any supplemental files installed --- plain Haskell libraries should + be fine. + +## setup unregister ## + +Deregister this package with the compiler. + +This command takes the following options: + +`--global` +: Deregister this package in the system-wide database. (This is the default.) + +`--user` +: Deregister this package in the user's local package database. + +`--gen-script` +: Instead of deregistering the package, generate a script containing + commands to perform the deregistration. On Unix, this file is + called `unregister.sh`, on Windows, `unregister.bat`. This script + might be included in a binary bundle, to be run on the target + system. + +## setup clean ## + +Remove any local files created during the `configure`, `build`, +`haddock`, `register` or `unregister` steps, and also any files and +directories listed in the `extra-tmp-files` field. + +This command takes the following options: + +`--save-configure` or `-s` +: Keeps the configuration information so it is not necessary to run + the configure step again before building. + +## setup test ## + +Run the test suites specified in the package description file. Aside from +the following flags, Cabal accepts the name of one or more test suites on the +command line after `test`. When supplied, Cabal will run only the named test +suites, otherwise, Cabal will run all test suites in the package. + +`--builddir=`_dir_ +: The directory where Cabal puts generated build files (default: `dist`). + Test logs will be located in the `test` subdirectory. + +`--human-log=`_path_ +: The template used to name human-readable test logs; the path is relative + to `dist/test`. By default, logs are named according to the template + `$pkgid-$test-suite.log`, so that each test suite will be logged to its own + human-readable log file. Template variables allowed are: `$pkgid`, + `$compiler`, `$os`, `$arch`, `$test-suite`, and `$result`. + +`--machine-log=`_path_ +: The path to the machine-readable log, relative to `dist/test`. The default + template is `$pkgid.log`. Template variables allowed are: `$pkgid`, + `$compiler`, `$os`, `$arch`, and `$result`. + +`--show-details=`_filter_ +: Determines if the results of individual test cases are shown on the + terminal. May be `always` (always show), `never` (never show), or + `failures` (show only the test cases of failing test suites). + +`--test-options=`_options_ +: Give extra options to the test executables. + +`--test-option=`_option_ +: give an extra option to the test executables. There is no need to quote + options containing spaces because a single option is assumed, so options + will not be split on spaces. + +## setup sdist ## + +Create a system- and compiler-independent source distribution in a file +_package_-_version_`.tar.gz` in the `dist` subdirectory, for +distribution to package builders. When unpacked, the commands listed in +this section will be available. + +The files placed in this distribution are the package description file, +the setup script, the sources of the modules named in the package +description file, and files named in the `license-file`, `main-is`, +`c-sources`, `data-files` and `extra-source-files` fields. + +This command takes the following option: + +`--snapshot` +: Append today's date (in "YYYYMMDD" format) to the version number for + the generated source package. The original package is unaffected. + + +[dist-simple]: ../libraries/Cabal/Distribution-Simple.html +[dist-make]: ../libraries/Cabal/Distribution-Make.html +[dist-license]: ../libraries/Cabal/Distribution-License.html#t:License +[extension]: ../libraries/Cabal/Language-Haskell-Extension.html#t:Extension +[BuildType]: ../libraries/Cabal/Distribution-PackageDescription.html#t:BuildType +[alex]: http://www.haskell.org/alex/ +[autoconf]: http://www.gnu.org/software/autoconf/ +[c2hs]: http://www.cse.unsw.edu.au/~chak/haskell/c2hs/ +[cpphs]: http://www.haskell.org/cpphs/ +[greencard]: http://www.haskell.org/greencard/ +[haddock]: http://www.haskell.org/haddock/ +[HsColour]: http://www.cs.york.ac.uk/fp/darcs/hscolour/ +[happy]: http://www.haskell.org/happy/ +[Hackage]: http://hackage.haskell.org/ +[pkg-config]: http://pkg-config.freedesktop.org/ diff -Nru ghc-7.0.3/libraries/Cabal/cabal/doc/misc.markdown ghc-7.2.1/libraries/Cabal/cabal/doc/misc.markdown --- ghc-7.0.3/libraries/Cabal/cabal/doc/misc.markdown 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/doc/misc.markdown 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,109 @@ +% Cabal User Guide + +# Reporting bugs and deficiencies # + +Please report any flaws or feature requests in the [bug tracker][]. + +For general discussion or queries email the libraries mailing list +. There is also a development mailing list +. + +[bug tracker]: http://hackage.haskell.org/trac/hackage/ + +# Stability of Cabal interfaces # + +The Cabal library and related infrastructure is still under active +development. New features are being added and limitations and bugs are +being fixed. This requires internal changes and often user visible +changes as well. We therefor cannot promise complete future-proof +stability, at least not without halting all development work. + +This section documents the aspects of the Cabal interface that we can +promise to keep stable and which bits are subject to change. + +## Cabal file format ## + +This is backwards compatible and mostly forwards compatible. New fields +can be added without breaking older versions of Cabal. Fields can be +deprecated without breaking older packages. + +## Command-line interface ## + +### Very Stable Command-line interfaces ### + +* `./setup configure` + * `--prefix` + * `--user` + * `--ghc`, `--hugs` + * `--verbose` + * `--prefix` + +* `./setup build` +* `./setup install` +* `./setup register` +* `./setup copy` + +### Stable Command-line interfaces ### + +### Unstable command-line ### + +## Functions and Types ## + +The Cabal library follows the [Package Versioning Policy][PVP]. This +means that within a stable major release, for example 1.2.x, there will +be no incompatible API changes. But minor versions increments, for +example 1.2.3, indicate compatible API additions. + +The Package Versioning Policy does not require any API guarantees +between major releases, for example between 1.2.x and 1.4.x. In practise +of course not everything changes between major releases. Some parts of +the API are more prone to change than others. The rest of this section +gives some informal advice on what level of API stability you can expect +between major releases. + +[PVP]: http://haskell.org/haskellwiki/Package_versioning_policy + +### Very Stable API ### + +* `defaultMain` + +* `defaultMainWithHooks defaultUserHooks` + + But regular `defaultMainWithHooks` isn't stable since `UserHooks` + changes. + +### Semi-stable API ### + +* `UserHooks` The hooks API will change in the future + +* `Distribution.*` is mostly declarative information about packages and + is somewhat stable. + +### Unstable API ### + +Everything under `Distribution.Simple.*` has no stability guarantee. + +## Hackage ## + +The index format is a partly stable interface. It consists of a tar.gz +file that contains directories with `.cabal` files in. In future it may +contain more kinds of files so do not assume every file is a `.cabal` +file. Incompatible revisions to the format would involve bumping the +name of the index file, i.e., `00-index.tar.gz`, `01-index.tar.gz` etc. + + +[dist-simple]: ../libraries/Cabal/Distribution-Simple.html +[dist-make]: ../libraries/Cabal/Distribution-Make.html +[dist-license]: ../libraries/Cabal/Distribution-License.html#t:License +[extension]: ../libraries/Cabal/Language-Haskell-Extension.html#t:Extension +[BuildType]: ../libraries/Cabal/Distribution-PackageDescription.html#t:BuildType +[alex]: http://www.haskell.org/alex/ +[autoconf]: http://www.gnu.org/software/autoconf/ +[c2hs]: http://www.cse.unsw.edu.au/~chak/haskell/c2hs/ +[cpphs]: http://www.haskell.org/cpphs/ +[greencard]: http://www.haskell.org/greencard/ +[haddock]: http://www.haskell.org/haddock/ +[HsColour]: http://www.cs.york.ac.uk/fp/darcs/hscolour/ +[happy]: http://www.haskell.org/happy/ +[HackageDB]: http://hackage.haskell.org/ +[pkg-config]: http://pkg-config.freedesktop.org/ diff -Nru ghc-7.0.3/libraries/Cabal/cabal/ghc.mk ghc-7.2.1/libraries/Cabal/cabal/ghc.mk --- ghc-7.0.3/libraries/Cabal/cabal/ghc.mk 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/ghc.mk 2011-08-07 17:11:00.000000000 +0000 @@ -0,0 +1,4 @@ +libraries/Cabal/cabal_PACKAGE = Cabal +libraries/Cabal/cabal_dist-install_GROUP = libraries +$(if $(filter Cabal/cabal,$(PACKAGES_STAGE0)),$(eval $(call build-package,libraries/Cabal/cabal,dist-boot,0))) +$(eval $(call build-package,libraries/Cabal/cabal,dist-install,$(if $(filter Cabal/cabal,$(STAGE2_PACKAGES)),2,1))) diff -Nru ghc-7.0.3/libraries/Cabal/cabal/GNUmakefile ghc-7.2.1/libraries/Cabal/cabal/GNUmakefile --- ghc-7.0.3/libraries/Cabal/cabal/GNUmakefile 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/GNUmakefile 2011-08-07 17:11:00.000000000 +0000 @@ -0,0 +1,4 @@ +dir = libraries/Cabal/cabal +TOP = ../../.. +include $(TOP)/mk/sub-makefile.mk +FAST_MAKE_OPTS += stage=0 diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Language/Haskell/Extension.hs ghc-7.2.1/libraries/Cabal/cabal/Language/Haskell/Extension.hs --- ghc-7.0.3/libraries/Cabal/cabal/Language/Haskell/Extension.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Language/Haskell/Extension.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,516 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Language.Haskell.Extension +-- Copyright : Isaac Jones 2003-2004 +-- +-- Maintainer : libraries@haskell.org +-- Portability : portable +-- +-- Haskell language dialects and extensions + +{- All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} + +module Language.Haskell.Extension ( + Language(..), + knownLanguages, + + Extension(..), + KnownExtension(..), + knownExtensions, + deprecatedExtensions + ) where + +import Distribution.Text (Text(..)) +import qualified Distribution.Compat.ReadP as Parse +import qualified Text.PrettyPrint as Disp +import qualified Data.Char as Char (isAlphaNum) +import Data.Array (Array, accumArray, bounds, Ix(inRange), (!)) + +-- ------------------------------------------------------------ +-- * Language +-- ------------------------------------------------------------ + +-- | This represents a Haskell language dialect. +-- +-- Language 'Extension's are interpreted relative to one of these base +-- languages. +-- +data Language = + + -- | The Haskell 98 language as defined by the Haskell 98 report. + -- + Haskell98 + + -- | The Haskell 2010 language as defined by the Haskell 2010 report. + -- + | Haskell2010 + + -- | An unknown language, identified by its name. + | UnknownLanguage String + deriving (Show, Read, Eq) + +knownLanguages :: [Language] +knownLanguages = [Haskell98, Haskell2010] + +instance Text Language where + disp (UnknownLanguage other) = Disp.text other + disp other = Disp.text (show other) + + parse = do + lang <- Parse.munch1 Char.isAlphaNum + return (classifyLanguage lang) + +classifyLanguage :: String -> Language +classifyLanguage = \str -> case lookup str langTable of + Just lang -> lang + Nothing -> UnknownLanguage str + where + langTable = [ (show lang, lang) + | lang <- knownLanguages ] + +-- ------------------------------------------------------------ +-- * Extension +-- ------------------------------------------------------------ + +-- Note: if you add a new 'KnownExtension': +-- +-- * also add it to the Distribution.Simple.X.languageExtensions lists +-- (where X is each compiler: GHC, JHC, Hugs, NHC) +-- +-- | This represents language extensions beyond a base 'Language' definition +-- (such as 'Haskell98') that are supported by some implementations, usually +-- in some special mode. +-- +-- Where applicable, references are given to an implementation's +-- official documentation, e.g. \"GHC § 7.2.1\" for an extension +-- documented in section 7.2.1 of the GHC User's Guide. + +data Extension = + -- | Enable a known extension + EnableExtension KnownExtension + + -- | Disable a known extension + | DisableExtension KnownExtension + + -- | An unknown extension, identified by the name of its @LANGUAGE@ + -- pragma. + | UnknownExtension String + + deriving (Show, Read, Eq) + +data KnownExtension = + + -- | [GHC § 7.6.3.4] Allow overlapping class instances, + -- provided there is a unique most specific instance for each use. + OverlappingInstances + + -- | [GHC § 7.6.3.3] Ignore structural rules guaranteeing the + -- termination of class instance resolution. Termination is + -- guaranteed by a fixed-depth recursion stack, and compilation + -- may fail if this depth is exceeded. + | UndecidableInstances + + -- | [GHC § 7.6.3.4] Implies 'OverlappingInstances'. Allow the + -- implementation to choose an instance even when it is possible + -- that further instantiation of types will lead to a more specific + -- instance being applicable. + | IncoherentInstances + + -- | [GHC § 7.3.8] Allows recursive bindings in @do@ blocks, + -- using the @rec@ keyword. + | DoRec + + -- | [GHC § 7.3.8.2] Deprecated in GHC. Allows recursive bindings + -- using @mdo@, a variant of @do@. @DoRec@ provides a different, + -- preferred syntax. + | RecursiveDo + + -- | [GHC § 7.3.9] Provide syntax for writing list + -- comprehensions which iterate over several lists together, like + -- the 'zipWith' family of functions. + | ParallelListComp + + -- | [GHC § 7.6.1.1] Allow multiple parameters in a type class. + | MultiParamTypeClasses + + -- | [GHC § 7.17] Enable the dreaded monomorphism restriction. + | MonomorphismRestriction + + -- | [GHC § 7.6.2] Allow a specification attached to a + -- multi-parameter type class which indicates that some parameters + -- are entirely determined by others. The implementation will check + -- that this property holds for the declared instances, and will use + -- this property to reduce ambiguity in instance resolution. + | FunctionalDependencies + + -- | [GHC § 7.8.5] Like 'RankNTypes' but does not allow a + -- higher-rank type to itself appear on the left of a function + -- arrow. + | Rank2Types + + -- | [GHC § 7.8.5] Allow a universally-quantified type to occur on + -- the left of a function arrow. + | RankNTypes + + -- | [GHC § 7.8.5] Allow data constructors to have polymorphic + -- arguments. Unlike 'RankNTypes', does not allow this for ordinary + -- functions. + | PolymorphicComponents + + -- | [GHC § 7.4.4] Allow existentially-quantified data constructors. + | ExistentialQuantification + + -- | [GHC § 7.8.7] Cause a type variable in a signature, which has an + -- explicit @forall@ quantifier, to scope over the definition of the + -- accompanying value declaration. + | ScopedTypeVariables + + -- | Deprecated, use 'ScopedTypeVariables' instead. + | PatternSignatures + + -- | [GHC § 7.8.3] Enable implicit function parameters with dynamic + -- scope. + | ImplicitParams + + -- | [GHC § 7.8.2] Relax some restrictions on the form of the context + -- of a type signature. + | FlexibleContexts + + -- | [GHC § 7.6.3.2] Relax some restrictions on the form of the + -- context of an instance declaration. + | FlexibleInstances + + -- | [GHC § 7.4.1] Allow data type declarations with no constructors. + | EmptyDataDecls + + -- | [GHC § 4.10.3] Run the C preprocessor on Haskell source code. + | CPP + + -- | [GHC § 7.8.4] Allow an explicit kind signature giving the kind of + -- types over which a type variable ranges. + | KindSignatures + + -- | [GHC § 7.11] Enable a form of pattern which forces evaluation + -- before an attempted match, and a form of strict @let@/@where@ + -- binding. + | BangPatterns + + -- | [GHC § 7.6.3.1] Allow type synonyms in instance heads. + | TypeSynonymInstances + + -- | [GHC § 7.9] Enable Template Haskell, a system for compile-time + -- metaprogramming. + | TemplateHaskell + + -- | [GHC § 8] Enable the Foreign Function Interface. In GHC, + -- implements the standard Haskell 98 Foreign Function Interface + -- Addendum, plus some GHC-specific extensions. + | ForeignFunctionInterface + + -- | [GHC § 7.10] Enable arrow notation. + | Arrows + + -- | [GHC § 7.16] Enable generic type classes, with default instances + -- defined in terms of the algebraic structure of a type. + | Generics + + -- | [GHC § 7.3.11] Enable the implicit importing of the module + -- @Prelude@. When disabled, when desugaring certain built-in syntax + -- into ordinary identifiers, use whatever is in scope rather than the + -- @Prelude@ -- version. + | ImplicitPrelude + + -- | [GHC § 7.3.15] Enable syntax for implicitly binding local names + -- corresponding to the field names of a record. Puns bind specific + -- names, unlike 'RecordWildCards'. + | NamedFieldPuns + + -- | [GHC § 7.3.5] Enable a form of guard which matches a pattern and + -- binds variables. + | PatternGuards + + -- | [GHC § 7.5.4] Allow a type declared with @newtype@ to use + -- @deriving@ for any class with an instance for the underlying type. + | GeneralizedNewtypeDeriving + + -- | [Hugs § 7.1] Enable the \"Trex\" extensible records system. + | ExtensibleRecords + + -- | [Hugs § 7.2] Enable type synonyms which are transparent in + -- some definitions and opaque elsewhere, as a way of implementing + -- abstract datatypes. + | RestrictedTypeSynonyms + + -- | [Hugs § 7.3] Enable an alternate syntax for string literals, + -- with string templating. + | HereDocuments + + -- | [GHC § 7.3.2] Allow the character @#@ as a postfix modifier on + -- identifiers. Also enables literal syntax for unboxed values. + | MagicHash + + -- | [GHC § 7.7] Allow data types and type synonyms which are + -- indexed by types, i.e. ad-hoc polymorphism for types. + | TypeFamilies + + -- | [GHC § 7.5.2] Allow a standalone declaration which invokes the + -- type class @deriving@ mechanism. + | StandaloneDeriving + + -- | [GHC § 7.3.1] Allow certain Unicode characters to stand for + -- certain ASCII character sequences, e.g. keywords and punctuation. + | UnicodeSyntax + + -- | [GHC § 8.1.1] Allow the use of unboxed types as foreign types, + -- e.g. in @foreign import@ and @foreign export@. + | UnliftedFFITypes + + -- | [GHC § 7.4.3] Defer validity checking of types until after + -- expanding type synonyms, relaxing the constraints on how synonyms + -- may be used. + | LiberalTypeSynonyms + + -- | [GHC § 7.4.2] Allow the name of a type constructor, type class, + -- or type variable to be an infix operator. + | TypeOperators + +--PArr -- not ready yet, and will probably be renamed to ParallelArrays + + -- | [GHC § 7.3.16] Enable syntax for implicitly binding local names + -- corresponding to the field names of a record. A wildcard binds + -- all unmentioned names, unlike 'NamedFieldPuns'. + | RecordWildCards + + -- | Deprecated, use 'NamedFieldPuns' instead. + | RecordPuns + + -- | [GHC § 7.3.14] Allow a record field name to be disambiguated + -- by the type of the record it's in. + | DisambiguateRecordFields + + -- | [GHC § 7.6.4] Enable overloading of string literals using a + -- type class, much like integer literals. + | OverloadedStrings + + -- | [GHC § 7.4.6] Enable generalized algebraic data types, in + -- which type variables may be instantiated on a per-constructor + -- basis. Implies GADTSyntax. + | GADTs + + -- | Enable GADT syntax for declaring ordinary algebraic datatypes. + | GADTSyntax + + -- | [GHC § 7.17.2] Make pattern bindings monomorphic. + | MonoPatBinds + + -- | [GHC § 7.8.8] Relax the requirements on mutually-recursive + -- polymorphic functions. + | RelaxedPolyRec + + -- | [GHC § 2.4.5] Allow default instantiation of polymorphic + -- types in more situations. + | ExtendedDefaultRules + + -- | [GHC § 7.2.2] Enable unboxed tuples. + | UnboxedTuples + + -- | [GHC § 7.5.3] Enable @deriving@ for classes + -- @Data.Typeable.Typeable@ and @Data.Generics.Data@. + | DeriveDataTypeable + + -- | [GHC § 7.6.1.3] Allow a class method's type to place + -- additional constraints on a class type variable. + | ConstrainedClassMethods + + -- | [GHC § 7.3.18] Allow imports to be qualified by the package + -- name the module is intended to be imported from, e.g. + -- + -- > import "network" Network.Socket + | PackageImports + + -- | [GHC § 7.8.6] Deprecated in GHC 6.12 and will be removed in + -- GHC 7. Allow a type variable to be instantiated at a + -- polymorphic type. + | ImpredicativeTypes + + -- | [GHC § 7.3.3] Change the syntax for qualified infix + -- operators. + | NewQualifiedOperators + + -- | [GHC § 7.3.12] Relax the interpretation of left operator + -- sections to allow unary postfix operators. + | PostfixOperators + + -- | [GHC § 7.9.5] Enable quasi-quotation, a mechanism for defining + -- new concrete syntax for expressions and patterns. + | QuasiQuotes + + -- | [GHC § 7.3.10] Enable generalized list comprehensions, + -- supporting operations such as sorting and grouping. + | TransformListComp + + -- | [GHC § 7.3.6] Enable view patterns, which match a value by + -- applying a function and matching on the result. + | ViewPatterns + + -- | Allow concrete XML syntax to be used in expressions and patterns, + -- as per the Haskell Server Pages extension language: + -- . The ideas behind it are + -- discussed in the paper \"Haskell Server Pages through Dynamic Loading\" + -- by Niklas Broberg, from Haskell Workshop '05. + | XmlSyntax + + -- | Allow regular pattern matching over lists, as discussed in the + -- paper \"Regular Expression Patterns\" by Niklas Broberg, Andreas Farre + -- and Josef Svenningsson, from ICFP '04. + | RegularPatterns + + -- | Enables the use of tuple sections, e.g. @(, True)@ desugars into + -- @\x -> (x, True)@. + | TupleSections + + -- | Allows GHC primops, written in C--, to be imported into a Haskell + -- file. + | GHCForeignImportPrim + + -- | Support for patterns of the form @n + k@, where @k@ is an + -- integer literal. + | NPlusKPatterns + + -- | Improve the layout rule when @if@ expressions are used in a @do@ + -- block. + | DoAndIfThenElse + + -- | Makes much of the Haskell sugar be desugared into calls to the + -- function with a particular name that is in scope. + | RebindableSyntax + + -- | Make @forall@ a keyword in types, which can be used to give the + -- generalisation explicitly. + | ExplicitForAll + + -- | Allow contexts to be put on datatypes, e.g. the @Eq a@ in + -- @data Eq a => Set a = NilSet | ConsSet a (Set a)@. + | DatatypeContexts + + -- | Local (@let@ and @where@) bindings are monomorphic. + | MonoLocalBinds + + -- | Enable @deriving@ for the @Data.Functor.Functor@ class. + | DeriveFunctor + + -- | Enable @deriving@ for the @Data.Traversable.Traversable@ class. + | DeriveTraversable + + -- | Enable @deriving@ for the @Data.Foldable.Foldable@ class. + | DeriveFoldable + + -- | Enable non-decreasing indentation for 'do' blocks. + | NondecreasingIndentation + + deriving (Show, Read, Eq, Enum, Bounded) + +{-# DEPRECATED knownExtensions + "KnownExtension is an instance of Enum and Bounded, use those instead." #-} +knownExtensions :: [KnownExtension] +knownExtensions = [minBound..maxBound] + +-- | Extensions that have been deprecated, possibly paired with another +-- extension that replaces it. +-- +deprecatedExtensions :: [(Extension, Maybe Extension)] +deprecatedExtensions = + [ (EnableExtension RecordPuns, Just (EnableExtension NamedFieldPuns)) + , (EnableExtension PatternSignatures, Just (EnableExtension ScopedTypeVariables)) + ] +-- NOTE: when adding deprecated extensions that have new alternatives +-- we must be careful to make sure that the deprecation messages are +-- valid. We must not recomend aliases that cannot be used with older +-- compilers, perhaps by adding support in Cabal to translate the new +-- name to the old one for older compilers. Otherwise we are in danger +-- of the scenario in ticket #689. + +instance Text Extension where + disp (UnknownExtension other) = Disp.text other + disp (EnableExtension ke) = Disp.text (show ke) + disp (DisableExtension ke) = Disp.text ("No" ++ show ke) + + parse = do + extension <- Parse.munch1 Char.isAlphaNum + return (classifyExtension extension) + +instance Text KnownExtension where + disp ke = Disp.text (show ke) + + parse = do + extension <- Parse.munch1 Char.isAlphaNum + case classifyKnownExtension extension of + Just ke -> + return ke + Nothing -> + fail ("Can't parse " ++ show extension ++ " as KnownExtension") + +classifyExtension :: String -> Extension +classifyExtension string + = case classifyKnownExtension string of + Just ext -> EnableExtension ext + Nothing -> + case string of + 'N':'o':string' -> + case classifyKnownExtension string' of + Just ext -> DisableExtension ext + Nothing -> UnknownExtension string + _ -> UnknownExtension string + +-- | 'read' for 'KnownExtension's is really really slow so for the Text +-- instance +-- what we do is make a simple table indexed off the first letter in the +-- extension name. The extension names actually cover the range @'A'-'Z'@ +-- pretty densely and the biggest bucket is 7 so it's not too bad. We just do +-- a linear search within each bucket. +-- +-- This gives an order of magnitude improvement in parsing speed, and it'll +-- also allow us to do case insensitive matches in future if we prefer. +-- +classifyKnownExtension :: String -> Maybe KnownExtension +classifyKnownExtension "" = Nothing +classifyKnownExtension string@(c : _) + | inRange (bounds knownExtensionTable) c + = lookup string (knownExtensionTable ! c) + | otherwise = Nothing + +knownExtensionTable :: Array Char [(String, KnownExtension)] +knownExtensionTable = + accumArray (flip (:)) [] ('A', 'Z') + [ (head str, (str, extension)) + | extension <- [toEnum 0 ..] + , let str = show extension ] + diff -Nru ghc-7.0.3/libraries/Cabal/cabal/LICENSE ghc-7.2.1/libraries/Cabal/cabal/LICENSE --- ghc-7.0.3/libraries/Cabal/cabal/LICENSE 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/LICENSE 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,33 @@ +Copyright (c) 2003-2008, Isaac Jones, Simon Marlow, Martin Sjögren, + Bjorn Bringert, Krasimir Angelov, + Malcolm Wallace, Ross Patterson, Ian Lynagh, + Duncan Coutts, Thomas Schilling +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Isaac Jones nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Makefile ghc-7.2.1/libraries/Cabal/cabal/Makefile --- ghc-7.0.3/libraries/Cabal/cabal/Makefile 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Makefile 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,130 @@ + +VERSION=1.11.2 + +#KIND=devel +KIND=rc +#KIND=cabal-latest + +PREFIX=/usr/local +HC=ghc +GHCFLAGS=-Wall + +all: build + +# build the library itself + +SOURCES=Distribution/*.hs Distribution/Simple/*.hs Distribution/PackageDescription/*.hs Distribution/Simple/GHC/*.hs Distribution/Simple/Build/*.hs Distribution/Compat/*.hs Distribution/Simple/Program/*.hs +CONFIG_STAMP=dist/setup-config +BUILD_STAMP=dist/build/libHSCabal-$(VERSION).a +HADDOCK_STAMP=dist/doc/html/Cabal/index.html +USERGUIDE_STAMP=dist/doc/users-guide/index.html +SDIST_STAMP=dist/Cabal-$(VERSION).tar.gz +DISTLOC=dist/release +DIST_STAMP=$(DISTLOC)/Cabal-$(VERSION).tar.gz + +COMMA=, + +setup: $(SOURCES) Setup.hs + -mkdir -p dist/setup + $(HC) $(GHCFLAGS) --make -i. -odir dist/setup -hidir dist/setup Setup.hs -o setup + +Setup-nhc: + hmake -nhc98 -package base -prelude Setup + +$(CONFIG_STAMP): setup Cabal.cabal + ./setup configure --with-compiler=$(HC) --prefix=$(PREFIX) + +build: $(BUILD_STAMP) +$(BUILD_STAMP): $(CONFIG_STAMP) $(SOURCES) + ./setup build + +install: $(BUILD_STAMP) + ./setup install + +hugsbootstrap: + rm -rf dist/tmp dist/hugs + mkdir -p dist/tmp + mkdir dist/hugs + cp -r Distribution dist/tmp + hugs-package dist/tmp dist/hugs + cp Setup.lhs Cabal.cabal dist/hugs + +hugsinstall: hugsbootstrap + cd dist/hugs && ./Setup.lhs configure --hugs + cd dist/hugs && ./Setup.lhs build + cd dist/hugs && ./Setup.lhs install + +# documentation... + +haddock: $(HADDOCK_STAMP) +$(HADDOCK_STAMP) : $(CONFIG_STAMP) $(BUILD_STAMP) + ./setup haddock + +PANDOC=pandoc +PANDOC_OPTIONS= \ + --standalone \ + --smart \ + --css=$(PANDOC_HTML_CSS) +PANDOC_HTML_OUTDIR=dist/doc/users-guide +PANDOC_HTML_CSS=Cabal.css + +users-guide: $(USERGUIDE_STAMP) doc/*.markdown +$(USERGUIDE_STAMP): doc/*.markdown + mkdir -p $(PANDOC_HTML_OUTDIR) + for file in $^; do $(PANDOC) $(PANDOC_OPTIONS) --from=markdown --to=html --output $(PANDOC_HTML_OUTDIR)/$$(basename $${file} .markdown).html $${file}; done + cp doc/$(PANDOC_HTML_CSS) $(PANDOC_HTML_OUTDIR) + +docs: haddock users-guide + +clean: + rm -rf dist/ + rm -f setup + +# testing... + +moduleTest: tests/ModuleTest.hs tests/PackageDescriptionTests.hs + mkdir -p dist/test + $(HC) --make -Wall -DDEBUG -odir dist/test -hidir dist/test \ + -itests tests/ModuleTest.hs -o moduleTest + +#tests: moduleTest clean +# cd tests/A && $(MAKE) clean +# cd tests/HUnit-1.0 && $(MAKE) clean +# cd tests/A && $(MAKE) +# cd tests/HUnit-1.0 && $(MAKE) + +#check: +# rm -f moduleTest +# $(MAKE) moduleTest +# ./moduleTest + +# distribution... + +$(SDIST_STAMP) : $(BUILD_STAMP) + ./setup sdist + +dist: $(DIST_STAMP) +$(DIST_STAMP) : $(HADDOCK_STAMP) $(USERGUIDE_STAMP) $(SDIST_STAMP) + rm -rf $(DISTLOC) + mkdir $(DISTLOC) + tar -xzf $(SDIST_STAMP) -C $(DISTLOC)/ + mkdir $(DISTLOC)/Cabal-$(VERSION)/doc + cp -r dist/doc/html $(DISTLOC)/Cabal-$(VERSION)/doc/API + cp -r dist/doc/users-guide $(DISTLOC)/Cabal-$(VERSION)/doc/ + cp changelog $(DISTLOC)/Cabal-$(VERSION)/ + tar -C $(DISTLOC) -c Cabal-$(VERSION) -zf $(DISTLOC)/Cabal-$(VERSION).tar.gz + mv $(DISTLOC)/Cabal-$(VERSION)/doc $(DISTLOC)/ + mv $(DISTLOC)/Cabal-$(VERSION)/changelog $(DISTLOC)/ + rm -r $(DISTLOC)/Cabal-$(VERSION)/ + @echo "Cabal tarball built: $(DIST_STAMP)" + @echo "Release fileset prepared: $(DISTLOC)/" + +release: $(DIST_STAMP) + scp -r $(DISTLOC) haskell.org:/srv/web/haskell.org/cabal/release/cabal-$(VERSION) + ssh haskell.org 'cd /srv/web/haskell.org/cabal/release && rm -f $(KIND) && ln -s cabal-$(VERSION) $(KIND)' + +# tags... + +TAGSSRCDIRS = Distribution Language +tags TAGS: $(SOURCES) + find $(TAGSSRCDIRS) -name \*.\*hs | xargs hasktags diff -Nru ghc-7.0.3/libraries/Cabal/cabal/prologue.txt ghc-7.2.1/libraries/Cabal/cabal/prologue.txt --- ghc-7.0.3/libraries/Cabal/cabal/prologue.txt 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/prologue.txt 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,7 @@ +The Haskell Cabal is the Common Architecture for Building Applications +and Libraries. It is a framework which defines a common interface for +authors to more easily build their applications in a portable way. The +Haskell Cabal is meant to be a part of a larger infrastructure for +distributing, organizing, and cataloging Haskell Libraries and +Tools. For more information, please see: +. diff -Nru ghc-7.0.3/libraries/Cabal/cabal/README ghc-7.2.1/libraries/Cabal/cabal/README --- ghc-7.0.3/libraries/Cabal/cabal/README 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/README 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,168 @@ +The Cabal library package +========================= + +[Cabal home page](http://www.haskell.org/cabal/) + +If you also want the `cabal` command line program then you need +the `cabal-install` package in addition to this library. + + +Installation instructions for the Cabal library +=============================================== + +Installing as a user (no root or administer access) +--------------------------------------------------- + + ghc --make Setup + ./Setup configure --user + ./Setup build + ./Setup install + +Note the use of the `--user` flag at the configure step. + +Compiling Setup rather than using `runghc Setup` is much faster and works on +Windows. For all packages other than Cabal itself it is fine to use `runghc`. + +This will install into `$HOME/.cabal/` on unix and into +`$Documents and Settings\$User\Application Data\cabal\` on Windows +If you want to install elsewhere use the `--prefix=` flag at the +configure step. + + +Installing as root / Administrator +---------------------------------- + + ghc --make Setup + ./Setup configure + ./Setup build + sudo ./Setup install + +Compiling Setup rather than using `runghc Setup` is much faster and works on +Windows. For all packages other than Cabal itself it is fine to use `runghc`. + +This will install into `/usr/local` on unix and on Windows it will +install into `$ProgramFiles/Haskell`. If you want to install +elsewhere use the `--prefix=` flag at the configure step. + + +Working with older versions of GHC and Cabal +============================================ + +It is recommended just to leave any pre-existing version of Cabal +installed. In particular it is *essential* to keep the version that +came with GHC itself since other installed packages need it (eg the +"ghc" api package). + +Prior to GHC 6.4.2 however, GHC didn't deal particularly well with +having multiple versions of packages installed at once. So if you +are using GHC 6.4.1 or older and you have an older version of Cabal +installed, you probably just want to remove it: + + ghc-pkg unregister Cabal + +or if you had Cabal installed just for your user account then: + + ghc-pkg unregister Cabal --user + + +The `filepath` dependency +========================= + +Cabal now uses the `filepath` package so that must be installed first. +GHC-6.6.1 and later come with `filepath` however earlier versions do not by +default. If you do not already have `filepath` then you need to install it. You +can use any existing version of Cabal to do that. If you have neither Cabal or +filepath then it is slightly harder but still possible. + +Unpack Cabal and filepath into separate directories. For example: + + tar -xzf filepath-1.1.0.0.tar.gz + tar -xzf Cabal-1.6.0.0.tar.gz + + # rename to make the following instructions simpler: + mv filepath-1.1.0.0/ filepath/ + mv Cabal-1.6.0.0/ Cabal/ + + cd Cabal + ghc -i../filepath -cpp --make Setup.hs -o ../filepath/setup + cd ../filepath/ + ./setup configure --user + ./setup build + ./setup install + +This installs filepath so you are then in a position to install Cabal by the +normal method. + + +More Information +================ + +Please see the web site for the [user guide] and API documentation. +There is some more information available on the [development wiki]. + +[user guide]: http://www.haskell.org/cabal/ +[development wiki]: http://hackage.haskell.org/trac/hackage/ + + +Bugs +======= + +Please report bugs and wish-list items in our [bug tracker]. + +[bug tracker]: http://hackage.haskell.org/trac/hackage/ + + +Your Help +--------- + +To help us in the next round of development work it would be +enormously helpful to know from our users what their most pressing +problems are with Cabal and Hackage. You probably have a favourite +Cabal bug or limitation. Take a look at our [bug tracker]. Make sure +the problem is reported there and properly described. Comment on the +ticket to tell us how much of a problem the bug is for you. Add +yourself to the ticket's cc list so we can discuss requirements and +keep you informed on progress. For feature requests it is very +helpful if there is a description of how you would expect to +interact with the new feature. + + +Code +======= + +You can get the code from the web page; the version control system we +use is very open and welcoming to new developers. + +You can get the main development branch: + +> darcs get --partial http://darcs.haskell.org/cabal + +and you can get the stable 1.6 branch: + +> darcs get --partial http://darcs.haskell.org/cabal-branches/cabal-1.6 + + +Credits +======= + +Cabal Coders (in alphabetical order): + +- Krasimir Angelov +- Bjorn Bringert +- Duncan Coutts +- Isaac Jones +- David Himmelstrup (Lemmih) +- Simon Marlow +- Ross Patterson +- Thomas Schilling +- Martin Sjögren +- Malcolm Wallace +- and nearly 30 other people have contributed occasional patches + +Cabal spec: + +- Isaac Jones +- Simon Marlow +- Ross Patterson +- Simon Peyton Jones +- Malcolm Wallace diff -Nru ghc-7.0.3/libraries/Cabal/cabal/runTests.sh ghc-7.2.1/libraries/Cabal/cabal/runTests.sh --- ghc-7.0.3/libraries/Cabal/cabal/runTests.sh 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/runTests.sh 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,21 @@ +#!/bin/sh + +HCBASE=/usr/bin/ +HC=$HCBASE/ghc +GHCFLAGS='--make -Wall -fno-warn-unused-matches -cpp' +ISPOSIX=-DHAVE_UNIX_PACKAGE + +rm -f moduleTest +mkdir -p dist/debug +echo Building... +$HC $GHCFLAGS $ISPOSIX -DDEBUG -odir dist/debug -hidir dist/debug -idist/debug/:.:tests/HUnit-1.0/src tests/ModuleTest.hs -o moduleTest 2> stderr +RES=$? +if [ $RES != 0 ] +then + cat stderr >&2 + exit $RES +fi +echo Running... +./moduleTest +echo Done + diff -Nru ghc-7.0.3/libraries/Cabal/cabal/Setup.hs ghc-7.2.1/libraries/Cabal/cabal/Setup.hs --- ghc-7.0.3/libraries/Cabal/cabal/Setup.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/Setup.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,10 @@ +import Distribution.Simple +main :: IO () +main = defaultMain + +-- Although this looks like the Simple build type, it is in fact vital that +-- we use this Setup.hs because it'll get compiled against the local copy +-- of the Cabal lib, thus enabling Cabal to bootstrap itself without relying +-- on any previous installation. This also means we can use any new features +-- immediately because we never have to worry about building Cabal with an +-- older version of itself. diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/hackage/check.sh ghc-7.2.1/libraries/Cabal/cabal/tests/hackage/check.sh --- ghc-7.0.3/libraries/Cabal/cabal/tests/hackage/check.sh 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/hackage/check.sh 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,25 @@ +#!/bin/sh + +base_version=1.4.0.2 +test_version=1.5.6 + +for setup in archive/*/*/Setup.hs archive/*/*/Setup.lhs; do + + pkgname=$(basename ${setup}) + + if test $(wc -w < ${setup}) -gt 21; then + if ghc -package Cabal-${base_version} -S ${setup} -o /dev/null 2> /dev/null; then + + if ghc -package Cabal-${test_version} -S ${setup} -o /dev/null 2> /dev/null; then + echo "OK ${setup}" + else + echo "FAIL ${setup} does not compile with Cabal-${test_version}" + fi + else + echo "OK ${setup} (does not compile with Cabal-${base_version})" + fi + else + echo "trivial ${setup}" + fi + +done diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/hackage/download.sh ghc-7.2.1/libraries/Cabal/cabal/tests/hackage/download.sh --- ghc-7.0.3/libraries/Cabal/cabal/tests/hackage/download.sh 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/hackage/download.sh 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,19 @@ +#!/bin/sh + +if test ! -f archive/archive.tar; then + + wget http://hackage.haskell.org/cgi-bin/hackage-scripts/archive.tar + mkdir -p archive + mv archive.tar archive/ + tar -C archive -xf archive/archive.tar + +fi + +if test ! -f archive/00-index.tar.gz; then + + wget http://hackage.haskell.org/packages/archive/00-index.tar.gz + mkdir -p archive + mv 00-index.tar.gz archive/ + tar -C archive -xzf archive/00-index.tar.gz + +fi diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/hackage/unpack.sh ghc-7.2.1/libraries/Cabal/cabal/tests/hackage/unpack.sh --- ghc-7.0.3/libraries/Cabal/cabal/tests/hackage/unpack.sh 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/hackage/unpack.sh 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,16 @@ +#!/bin/sh + +for tarball in archive/*/*/*.tar.gz; do + + pkgdir=$(dirname ${tarball}) + pkgname=$(basename ${tarball} .tar.gz) + + if tar -tzf ${tarball} ${pkgname}/Setup.hs 2> /dev/null; then + tar -xzf ${tarball} ${pkgname}/Setup.hs -O > ${pkgdir}/Setup.hs + elif tar -tzf ${tarball} ${pkgname}/Setup.lhs 2> /dev/null; then + tar -xzf ${tarball} ${pkgname}/Setup.lhs -O > ${pkgdir}/Setup.lhs + else + echo "${pkgname} has no Setup.hs or .lhs at all!!?!" + fi + +done diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/misc/ghc-supported-languages.hs ghc-7.2.1/libraries/Cabal/cabal/tests/misc/ghc-supported-languages.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/misc/ghc-supported-languages.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/misc/ghc-supported-languages.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,99 @@ +-- | A test program to check that ghc has got all of its extensions registered +-- +module Main where + +import Language.Haskell.Extension +import Distribution.Text +import Distribution.Simple.Utils +import Distribution.Verbosity + +import Data.List ((\\)) +import Data.Maybe +import Control.Applicative +import Control.Monad +import System.Environment +import System.Exit + +-- | A list of GHC extensions that are deliberately not registered, +-- e.g. due to being experimental and not ready for public consumption +-- +exceptions = map readExtension + [ "PArr" -- still classed as experimental, will be renamed and registered + ] + +checkProblems :: [Extension] -> [String] +checkProblems implemented = + + let unregistered = + [ ext | ext <- implemented -- extensions that ghc knows about + , not (registered ext) -- but that are not registered + , ext `notElem` exceptions ] -- except for the exceptions + + -- check if someone has forgotten to update the exceptions list... + + -- exceptions that are not implemented + badExceptions = exceptions \\ implemented + + -- exceptions that are now registered + badExceptions' = filter registered exceptions + + in catMaybes + [ check unregistered $ unlines + [ "The following extensions are known to GHC but are not in the " + , "extension registry in Language.Haskell.Extension." + , " " ++ intercalate "\n " (map display unregistered) + , "If these extensions are ready for public consumption then they " + , "should be registered. If they are still experimental and you " + , "think they are not ready to be registered then please add them " + , "to the exceptions list in this test program along with an " + , "explanation." + ] + , check badExceptions $ unlines + [ "Error in the extension exception list. The following extensions" + , "are listed as exceptions but are not even implemented by GHC:" + , " " ++ intercalate "\n " (map display badExceptions) + , "Please fix this test program by correcting the list of" + , "exceptions." + ] + , check badExceptions' $ unlines + [ "Error in the extension exception list. The following extensions" + , "are listed as exceptions to registration but they are in fact" + , "now registered in Language.Haskell.Extension:" + , " " ++ intercalate "\n " (map display badExceptions') + , "Please fix this test program by correcting the list of" + , "exceptions." + ] + ] + where + registered (UnknownExtension _) = False + registered _ = True + + check [] _ = Nothing + check _ i = Just i + + +main = topHandler $ do + [ghcPath] <- getArgs + exts <- getExtensions ghcPath + let problems = checkProblems exts + putStrLn (intercalate "\n" problems) + if null problems + then exitSuccess + else exitFailure + +getExtensions :: FilePath -> IO [Extension] +getExtensions ghcPath = + map readExtension . lines + <$> rawSystemStdout normal ghcPath ["--supported-languages"] + +readExtension :: String -> Extension +readExtension str = handleNoParse $ do + -- GHC defines extensions in a positive way, Cabal defines them + -- relative to H98 so we try parsing ("No" ++ extName) first + ext <- simpleParse ("No" ++ str) + case ext of + UnknownExtension _ -> simpleParse str + _ -> return ext + where + handleNoParse :: Maybe Extension -> Extension + handleNoParse = fromMaybe (error $ "unparsable extension " ++ show str) diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Check.hs ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Check.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Check.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Check.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,15 @@ +module PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check where + +import Test.HUnit +import PackageTests.PackageTester +import System.FilePath +import Data.List + + +suite :: Test +suite = TestCase $ do + let spec = PackageSpec ("PackageTests" "BuildDeps" "GlobalBuildDepsNotAdditive1") [] + result <- cabal_build spec + assertEqual "cabal build should fail - see test-log.txt" False (successful result) + assertBool "cabal error should be \"Failed to load interface for `Prelude'\"" $ + "Failed to load interface for `Prelude'" `isInfixOf` outputText result diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/GlobalBuildDepsNotAdditive1.cabal ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/GlobalBuildDepsNotAdditive1.cabal --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/GlobalBuildDepsNotAdditive1.cabal 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/GlobalBuildDepsNotAdditive1.cabal 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,20 @@ +name: GlobalBuildDepsNotAdditive1 +version: 0.1 +license: BSD3 +cabal-version: >= 1.6 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + If you specify 'base' in the global build dependencies, then define + a library without base, it fails to find 'base' for the library. + +--------------------------------------- + +build-depends: base + +Library + exposed-modules: MyLibrary + build-depends: bytestring, old-time diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/MyLibrary.hs ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/MyLibrary.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/MyLibrary.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/MyLibrary.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc" + C.putStrLn $ C.pack text diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Setup.hs ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Setup.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Setup.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Setup.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Check.hs ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Check.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Check.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Check.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,15 @@ +module PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check where + +import Test.HUnit +import PackageTests.PackageTester +import System.FilePath +import Data.List + + +suite :: Test +suite = TestCase $ do + let spec = PackageSpec ("PackageTests" "BuildDeps" "GlobalBuildDepsNotAdditive2") [] + result <- cabal_build spec + assertEqual "cabal build should fail - see test-log.txt" False (successful result) + assertBool "cabal error should be \"Failed to load interface for `Prelude'\"" $ + "Failed to load interface for `Prelude'" `isInfixOf` outputText result diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/GlobalBuildDepsNotAdditive2.cabal ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/GlobalBuildDepsNotAdditive2.cabal --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/GlobalBuildDepsNotAdditive2.cabal 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/GlobalBuildDepsNotAdditive2.cabal 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,20 @@ +name: GlobalBuildDepsNotAdditive1 +version: 0.1 +license: BSD3 +cabal-version: >= 1.6 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + If you specify 'base' in the global build dependencies, then define + an executable without base, it fails to find 'base' for the executable + +--------------------------------------- + +build-depends: base + +Executable lemon + main-is: lemon.hs + build-depends: bytestring, old-time diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/lemon.hs ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/lemon.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/lemon.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/lemon.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,7 @@ +import qualified Data.ByteString.Char8 as C +import System.Time + +main = do + getClockTime + let text = "lemon" + C.putStrLn $ C.pack text diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Setup.hs ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Setup.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Setup.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Setup.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Check.hs ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Check.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Check.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Check.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,20 @@ +module PackageTests.BuildDeps.InternalLibrary0.Check where + +import Test.HUnit +import PackageTests.PackageTester +import Control.Monad +import System.FilePath +import Data.Version +import Data.List (isInfixOf, intercalate) + + +suite :: Version -> Test +suite cabalVersion = TestCase $ do + let spec = PackageSpec ("PackageTests" "BuildDeps" "InternalLibrary0") [] + result <- cabal_build spec + assertEqual "cabal build should fail" False (successful result) + when (cabalVersion >= Version [1, 7] []) $ do + -- In 1.7 it should tell you how to enable the desired behaviour. + assertEqual "error should say 'library which is defined within the same package.'" True $ + "library which is defined within the same package." `isInfixOf` (intercalate " " $ lines $ outputText result) + diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/my.cabal ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/my.cabal --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/my.cabal 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/my.cabal 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,24 @@ +name: InternalLibrary0 +version: 0.1 +license: BSD3 +cabal-version: >= 1.6 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + Check that with 'cabal-version:' containing versions less than 1.7, we do *not* + have the new behaviour to allow executables to refer to the library defined + in the same module. + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring, old-time + +Executable lemon + main-is: lemon.hs + hs-source-dirs: programs + build-depends: base, bytestring, old-time, InternalLibrary0 diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/MyLibrary.hs ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/MyLibrary.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/MyLibrary.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/MyLibrary.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc" + C.putStrLn $ C.pack text diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/programs/lemon.hs ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/programs/lemon.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/programs/lemon.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/programs/lemon.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,6 @@ +import System.Time +import MyLibrary + +main = do + getClockTime + myLibFunc diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Setup.hs ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Setup.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Setup.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Setup.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Check.hs ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Check.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Check.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Check.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,12 @@ +module PackageTests.BuildDeps.InternalLibrary1.Check where + +import Test.HUnit +import PackageTests.PackageTester +import System.FilePath + + +suite :: Test +suite = TestCase $ do + let spec = PackageSpec ("PackageTests" "BuildDeps" "InternalLibrary1") [] + result <- cabal_build spec + assertEqual "cabal build should succeed - see test-log.txt" True (successful result) diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/my.cabal ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/my.cabal --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/my.cabal 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/my.cabal 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,23 @@ +name: InternalLibrary1 +version: 0.1 +license: BSD3 +cabal-version: >= 1.7.1 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + Check for the new (in >= 1.7.1) ability to allow executables to refer to + the library defined in the same module. + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring, old-time + +Executable lemon + main-is: lemon.hs + hs-source-dirs: programs + build-depends: base, bytestring, old-time, InternalLibrary1 diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/MyLibrary.hs ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/MyLibrary.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/MyLibrary.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/MyLibrary.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc" + C.putStrLn $ C.pack text diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/programs/lemon.hs ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/programs/lemon.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/programs/lemon.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/programs/lemon.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,6 @@ +import System.Time +import MyLibrary + +main = do + getClockTime + myLibFunc diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Setup.hs ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Setup.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Setup.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Setup.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Check.hs ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Check.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Check.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Check.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,24 @@ +module PackageTests.BuildDeps.InternalLibrary2.Check where + +import Test.HUnit +import PackageTests.PackageTester +import System.FilePath +import qualified Data.ByteString.Char8 as C + + +suite :: Test +suite = TestCase $ do + let spec = PackageSpec ("PackageTests" "BuildDeps" "InternalLibrary2") [] + let specTI = PackageSpec (directory spec "to-install") [] + + unregister "InternalLibrary2" + iResult <- cabal_install specTI + assertEqual "cabal install should succeed - see to-install/test-log.txt" True (successful iResult) + bResult <- cabal_build spec + assertEqual "cabal build should succeed - see test-log.txt" True (successful bResult) + unregister "InternalLibrary2" + + (_, _, output) <- run (Just $ directory spec) "dist/build/lemon/lemon" [] + C.appendFile (directory spec "test-log.txt") (C.pack $ "\ndist/build/lemon/lemon\n"++output) + assertEqual "executable should have linked with the internal library" "myLibFunc internal" (concat $ lines output) + diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/my.cabal ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/my.cabal --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/my.cabal 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/my.cabal 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,23 @@ +name: InternalLibrary2 +version: 0.1 +license: BSD3 +cabal-version: >= 1.7.1 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + This test is to make sure that the internal library is preferred by ghc to + an installed one of the same name and version. + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring, old-time + +Executable lemon + main-is: lemon.hs + hs-source-dirs: programs + build-depends: base, bytestring, old-time, InternalLibrary2 diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/MyLibrary.hs ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/MyLibrary.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/MyLibrary.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/MyLibrary.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc internal" + C.putStrLn $ C.pack text diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/programs/lemon.hs ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/programs/lemon.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/programs/lemon.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/programs/lemon.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,6 @@ +import System.Time +import MyLibrary + +main = do + getClockTime + myLibFunc diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Setup.hs ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Setup.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Setup.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Setup.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/my.cabal ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/my.cabal --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/my.cabal 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/my.cabal 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,18 @@ +name: InternalLibrary2 +version: 0.1 +license: BSD3 +cabal-version: >= 1.6 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + This test is to make sure that the internal library is preferred by ghc to + an installed one of the same name and version. + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring, old-time diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/MyLibrary.hs ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/MyLibrary.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/MyLibrary.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/MyLibrary.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc installed" + C.putStrLn $ C.pack text diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/Setup.hs ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/Setup.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/Setup.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/Setup.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Check.hs ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Check.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Check.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Check.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,24 @@ +module PackageTests.BuildDeps.InternalLibrary3.Check where + +import Test.HUnit +import PackageTests.PackageTester +import System.FilePath +import qualified Data.ByteString.Char8 as C + + +suite :: Test +suite = TestCase $ do + let spec = PackageSpec ("PackageTests" "BuildDeps" "InternalLibrary3") [] + let specTI = PackageSpec (directory spec "to-install") [] + + unregister "InternalLibrary3" + iResult <- cabal_install specTI + assertEqual "cabal install should succeed - see to-install/test-log.txt" True (successful iResult) + bResult <- cabal_build spec + assertEqual "cabal build should succeed - see test-log.txt" True (successful bResult) + unregister "InternalLibrary3" + + (_, _, output) <- run (Just $ directory spec) "dist/build/lemon/lemon" [] + C.appendFile (directory spec "test-log.txt") (C.pack $ "\ndist/build/lemon/lemon\n"++output) + assertEqual "executable should have linked with the internal library" "myLibFunc internal" (concat $ lines output) + diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/my.cabal ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/my.cabal --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/my.cabal 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/my.cabal 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,23 @@ +name: InternalLibrary3 +version: 0.1 +license: BSD3 +cabal-version: >= 1.7.1 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + This test is to make sure that the internal library is preferred by ghc to + an installed one of the same name, but a *newer* version. + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring, old-time + +Executable lemon + main-is: lemon.hs + hs-source-dirs: programs + build-depends: base, bytestring, old-time, InternalLibrary3 diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/MyLibrary.hs ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/MyLibrary.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/MyLibrary.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/MyLibrary.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc internal" + C.putStrLn $ C.pack text diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/programs/lemon.hs ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/programs/lemon.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/programs/lemon.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/programs/lemon.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,6 @@ +import System.Time +import MyLibrary + +main = do + getClockTime + myLibFunc diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Setup.hs ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Setup.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Setup.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Setup.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/my.cabal ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/my.cabal --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/my.cabal 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/my.cabal 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,18 @@ +name: InternalLibrary3 +version: 0.2 +license: BSD3 +cabal-version: >= 1.6 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + This test is to make sure that the internal library is preferred by ghc to + an installed one of the same name but a *newer* version. + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring, old-time diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/MyLibrary.hs ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/MyLibrary.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/MyLibrary.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/MyLibrary.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc installed" + C.putStrLn $ C.pack text diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/Setup.hs ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/Setup.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/Setup.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/Setup.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Check.hs ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Check.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Check.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Check.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,24 @@ +module PackageTests.BuildDeps.InternalLibrary4.Check where + +import Test.HUnit +import PackageTests.PackageTester +import System.FilePath +import qualified Data.ByteString.Char8 as C + + +suite :: Test +suite = TestCase $ do + let spec = PackageSpec ("PackageTests" "BuildDeps" "InternalLibrary4") [] + let specTI = PackageSpec (directory spec "to-install") [] + + unregister "InternalLibrary4" + iResult <- cabal_install specTI + assertEqual "cabal install should succeed - see to-install/test-log.txt" True (successful iResult) + bResult <- cabal_build spec + assertEqual "cabal build should succeed - see test-log.txt" True (successful bResult) + unregister "InternalLibrary4" + + (_, _, output) <- run (Just $ directory spec) "dist/build/lemon/lemon" [] + C.appendFile (directory spec "test-log.txt") (C.pack $ "\ndist/build/lemon/lemon\n"++output) + assertEqual "executable should have linked with the installed library" "myLibFunc installed" (concat $ lines output) + diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/my.cabal ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/my.cabal --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/my.cabal 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/my.cabal 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,23 @@ +name: InternalLibrary4 +version: 0.1 +license: BSD3 +cabal-version: >= 1.7.1 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + This test is to make sure that we can explicitly say we want InternalLibrary4-0.2 + and it will give us the *installed* version 0.2 instead of the internal 0.1. + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring, old-time + +Executable lemon + main-is: lemon.hs + hs-source-dirs: programs + build-depends: base, bytestring, old-time, InternalLibrary4 >= 0.2 diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/MyLibrary.hs ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/MyLibrary.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/MyLibrary.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/MyLibrary.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc internal" + C.putStrLn $ C.pack text diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/programs/lemon.hs ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/programs/lemon.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/programs/lemon.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/programs/lemon.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,6 @@ +import System.Time +import MyLibrary + +main = do + getClockTime + myLibFunc diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Setup.hs ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Setup.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Setup.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Setup.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/my.cabal ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/my.cabal --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/my.cabal 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/my.cabal 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,18 @@ +name: InternalLibrary4 +version: 0.2 +license: BSD3 +cabal-version: >= 1.6 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + This test is to make sure that the internal library is preferred by ghc to + an installed one of the same name but a *newer* version. + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring, old-time diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/MyLibrary.hs ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/MyLibrary.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/MyLibrary.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/MyLibrary.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc installed" + C.putStrLn $ C.pack text diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/Setup.hs ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/Setup.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/Setup.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/Setup.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Check.hs ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Check.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Check.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Check.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,12 @@ +module PackageTests.BuildDeps.SameDepsAllRound.Check where + +import Test.HUnit +import PackageTests.PackageTester +import System.FilePath + + +suite :: Test +suite = TestCase $ do + let spec = PackageSpec ("PackageTests" "BuildDeps" "SameDepsAllRound") [] + result <- cabal_build spec + assertEqual "cabal build should succeed - see test-log.txt" True (successful result) diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/lemon.hs ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/lemon.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/lemon.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/lemon.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,7 @@ +import qualified Data.ByteString.Char8 as C +import System.Time + +main = do + getClockTime + let text = "lemon" + C.putStrLn $ C.pack text diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/MyLibrary.hs ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/MyLibrary.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/MyLibrary.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/MyLibrary.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc" + C.putStrLn $ C.pack text diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/pineapple.hs ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/pineapple.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/pineapple.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/pineapple.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,7 @@ +import qualified Data.ByteString.Char8 as C +import System.Time + +main = do + getClockTime + let text = "pineapple" + C.putStrLn $ C.pack text diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/SameDepsAllRound.cabal ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/SameDepsAllRound.cabal --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/SameDepsAllRound.cabal 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/SameDepsAllRound.cabal 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,31 @@ +name: SameDepsAllRound +version: 0.1 +license: BSD3 +cabal-version: >= 1.6 +author: Stephen Blackheath +stability: stable +synopsis: Same dependencies all round +category: PackageTests +build-type: Simple + +description: + Check for the "old build-dep behaviour" namely that we get the same + package dependencies on all build targets, even if different ones + were specified for different targets + . + Here all .hs files use the three packages mentioned, so this shows + that build-depends is not target-specific. This is the behaviour + we want when cabal-version contains versions less than 1.7. + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring + +Executable lemon + main-is: lemon.hs + build-depends: old-time + +Executable pineapple + main-is: pineapple.hs diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Setup.hs ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Setup.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Setup.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Setup.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Check.hs ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Check.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Check.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Check.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,18 @@ +module PackageTests.BuildDeps.TargetSpecificDeps1.Check where + +import Test.HUnit +import PackageTests.PackageTester +import System.FilePath +import Data.List + + +suite :: Test +suite = TestCase $ do + let spec = PackageSpec ("PackageTests" "BuildDeps" "TargetSpecificDeps1") [] + result <- cabal_build spec + assertEqual "cabal build should fail - see test-log.txt" False (successful result) + assertBool "error should be in MyLibrary.hs" $ + "MyLibrary.hs:" `isInfixOf` outputText result + assertBool "error should be \"Could not find module `System.Time\"" $ + "Could not find module `System.Time'" `isInfixOf` + (intercalate " " $ lines $ outputText result) diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/lemon.hs ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/lemon.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/lemon.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/lemon.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,7 @@ +import qualified Data.ByteString.Char8 as C +import System.Time + +main = do + getClockTime + let text = "lemon" + C.putStrLn $ C.pack text diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/my.cabal ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/my.cabal --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/my.cabal 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/my.cabal 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,22 @@ +name: TargetSpecificDeps1 +version: 0.1 +license: BSD3 +cabal-version: >= 1.7.1 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + Check for the new build-dep behaviour, where build-depends are + handled specifically for each target + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring + +Executable lemon + main-is: lemon.hs + build-depends: base, bytestring, old-time diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/MyLibrary.hs ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/MyLibrary.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/MyLibrary.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/MyLibrary.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc" + C.putStrLn $ C.pack text diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Setup.hs ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Setup.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Setup.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Setup.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Check.hs ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Check.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Check.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Check.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,13 @@ +module PackageTests.BuildDeps.TargetSpecificDeps2.Check where + +import Test.HUnit +import PackageTests.PackageTester +import System.FilePath +import Data.List + + +suite :: Test +suite = TestCase $ do + let spec = PackageSpec ("PackageTests" "BuildDeps" "TargetSpecificDeps2") [] + result <- cabal_build spec + assertEqual "cabal build should succeed - see test-log.txt" True (successful result) diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/lemon.hs ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/lemon.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/lemon.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/lemon.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,5 @@ +import qualified Data.ByteString.Char8 as C + +main = do + let text = "lemon" + C.putStrLn $ C.pack text diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/my.cabal ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/my.cabal --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/my.cabal 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/my.cabal 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,24 @@ +name: TargetSpecificDeps1 +version: 0.1 +license: BSD3 +cabal-version: >= 1.7.1 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + Check for the new build-dep behaviour, where build-depends are + handled specifically for each target + This one is a control against TargetSpecificDeps1 - it is correct and should + succeed. + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring, old-time + +Executable lemon + main-is: lemon.hs + build-depends: base, bytestring diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/MyLibrary.hs ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/MyLibrary.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/MyLibrary.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/MyLibrary.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc" + C.putStrLn $ C.pack text diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Setup.hs ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Setup.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Setup.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Setup.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Check.hs ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Check.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Check.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Check.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,17 @@ +module PackageTests.BuildDeps.TargetSpecificDeps3.Check where + +import Test.HUnit +import PackageTests.PackageTester +import System.FilePath +import Data.List + + +suite :: Test +suite = TestCase $ do + let spec = PackageSpec ("PackageTests" "BuildDeps" "TargetSpecificDeps3") [] + result <- cabal_build spec + assertEqual "cabal build should fail - see test-log.txt" False (successful result) + assertBool "error should be in lemon.hs" $ + "lemon.hs:" `isInfixOf` outputText result + assertBool "error should be \"Could not find module `System.Time\"" $ + "Could not find module `System.Time'" `isInfixOf` (intercalate " " $ lines $ outputText result) diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,7 @@ +import qualified Data.ByteString.Char8 as C +import System.Time + +main = do + getClockTime + let text = "lemon" + C.putStrLn $ C.pack text diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/my.cabal ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/my.cabal --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/my.cabal 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/my.cabal 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,22 @@ +name: test +version: 0.1 +license: BSD3 +cabal-version: >= 1.7.1 +author: Stephen Blackheath +stability: stable +category: PackageTests +build-type: Simple + +description: + Check for the new build-dep behaviour, where build-depends are + handled specifically for each target + +--------------------------------------- + +Library + exposed-modules: MyLibrary + build-depends: base, bytestring, old-time + +Executable lemon + main-is: lemon.hs + build-depends: base, bytestring diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/MyLibrary.hs ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/MyLibrary.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/MyLibrary.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/MyLibrary.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,10 @@ +module MyLibrary where + +import qualified Data.ByteString.Char8 as C +import System.Time + +myLibFunc :: IO () +myLibFunc = do + getClockTime + let text = "myLibFunc" + C.putStrLn $ C.pack text diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Setup.hs ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Setup.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Setup.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Setup.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/PackageTester.hs ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/PackageTester.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/PackageTester.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/PackageTester.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,192 @@ +module PackageTests.PackageTester ( + PackageSpec(..), + Success(..), + Result(..), + cabal_configure, + cabal_build, + cabal_test, + cabal_install, + unregister, + run + ) where + +import qualified Control.Exception.Extensible as E +import System.Directory +import System.FilePath +import System.IO +import System.Posix.IO +import System.Process +import System.Exit +import Control.Concurrent.Chan +import Control.Concurrent.MVar +import Control.Concurrent +import Control.Monad +import Data.List +import Data.Maybe +import qualified Data.ByteString.Char8 as C + + +data PackageSpec = + PackageSpec { + directory :: FilePath, + configOpts :: [String] + } + +data Success = Failure | ConfigureSuccess | BuildSuccess | InstallSuccess | TestSuccess deriving (Eq, Show) + +data Result = Result { + successful :: Bool, + success :: Success, + outputText :: String + } + deriving Show + +nullResult :: Result +nullResult = Result True Failure "" + +recordRun :: (String, ExitCode, String) -> Success -> Result -> Result +recordRun (cmd, exitCode, exeOutput) thisSucc res = + res { + successful = successful res && exitCode == ExitSuccess, + success = if exitCode == ExitSuccess then thisSucc + else success res, + outputText = + (if null $ outputText res then "" else outputText res ++ "\n") ++ + cmd ++ "\n" ++ exeOutput + } + +cabal_configure :: PackageSpec -> IO Result +cabal_configure spec = do + res <- doCabalConfigure spec + record spec res + return res + +doCabalConfigure :: PackageSpec -> IO Result +doCabalConfigure spec = do + cleanResult@(_, _, cleanOutput) <- cabal spec ["clean"] + requireSuccess cleanResult + res <- cabal spec $ ["configure", "--user"] ++ configOpts spec + return $ recordRun res ConfigureSuccess nullResult + +doCabalBuild :: PackageSpec -> IO Result +doCabalBuild spec = do + configResult <- doCabalConfigure spec + if successful configResult + then do + res <- cabal spec ["build"] + return $ recordRun res BuildSuccess configResult + else + return configResult + +cabal_build :: PackageSpec -> IO Result +cabal_build spec = do + res <- doCabalBuild spec + record spec res + return res + +unregister :: String -> IO () +unregister libraryName = do + res@(_, _, output) <- run Nothing "ghc-pkg" ["unregister", "--user", libraryName] + if "cannot find package" `isInfixOf` output + then return () + else requireSuccess res + +-- | Install this library in the user area +cabal_install :: PackageSpec -> IO Result +cabal_install spec = do + buildResult <- doCabalBuild spec + res <- if successful buildResult + then do + res <- cabal spec ["install"] + return $ recordRun res InstallSuccess buildResult + else + return buildResult + record spec res + return res + +cabal_test :: PackageSpec -> IO Result +cabal_test spec = do + res <- cabal spec ["test"] + let r = recordRun res TestSuccess nullResult + record spec r + return r + +-- | Returns the command that was issued, the return code, and hte output text +cabal :: PackageSpec -> [String] -> IO (String, ExitCode, String) +cabal spec cabalArgs = do + wd <- getCurrentDirectory + r <- run (Just $ directory spec) "ghc" + [ "--make" + , "-fhpc" + , "-package-conf " ++ wd "../dist/package.conf.inplace" + , "Setup.hs" + ] + requireSuccess r + run (Just $ directory spec) (wd directory spec "Setup") cabalArgs + +-- | Returns the command that was issued, the return code, and hte output text +run :: Maybe FilePath -> String -> [String] -> IO (String, ExitCode, String) +run cwd cmd args = do + -- Posix-specific + (outf, outf0) <- createPipe + (errf, errf0) <- createPipe + outh <- fdToHandle outf + outh0 <- fdToHandle outf0 + errh <- fdToHandle errf + errh0 <- fdToHandle errf0 + pid <- runProcess cmd args cwd Nothing Nothing (Just outh0) (Just errh0) + + {- + -- ghc-6.10.1 specific + (Just inh, Just outh, Just errh, pid) <- + createProcess (proc cmd args){ std_in = CreatePipe, + std_out = CreatePipe, + std_err = CreatePipe, + cwd = cwd } + hClose inh -- done with stdin + -} + + -- fork off a thread to start consuming the output + outChan <- newChan + forkIO $ suckH outChan outh + forkIO $ suckH outChan errh + + output <- suckChan outChan + + hClose outh + hClose errh + + -- wait on the process + ex <- waitForProcess pid + let fullCmd = intercalate " " $ cmd:args + return ("\"" ++ fullCmd ++ "\" in " ++ fromMaybe "" cwd, + ex, output) + where + suckH chan h = do + eof <- hIsEOF h + if eof + then writeChan chan Nothing + else do + c <- hGetChar h + writeChan chan $ Just c + suckH chan h + suckChan chan = sc' chan 2 [] + where + sc' _ 0 acc = return $ reverse acc + sc' chan eofs acc = do + mC <- readChan chan + case mC of + Just c -> sc' chan eofs (c:acc) + Nothing -> sc' chan (eofs-1) acc + +requireSuccess :: (String, ExitCode, String) -> IO () +requireSuccess (cmd, exitCode, output) = do + case exitCode of + ExitSuccess -> return () + ExitFailure r -> do + ioError $ userError $ "Command " ++ cmd ++ " failed." + +record :: PackageSpec -> Result -> IO () +record spec res = do + C.writeFile (directory spec "test-log.txt") (C.pack $ outputText res) + diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/TestStanza/Check.hs ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/TestStanza/Check.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/TestStanza/Check.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/TestStanza/Check.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,57 @@ +module PackageTests.TestStanza.Check where + +import Test.HUnit +import System.FilePath +import PackageTests.PackageTester +import Data.List (isInfixOf, intercalate) +import Distribution.Version +import Distribution.PackageDescription.Parse + ( readPackageDescription ) +import Distribution.PackageDescription.Configuration + ( finalizePackageDescription ) +import Distribution.Package + ( PackageIdentifier(..), PackageName(..), Dependency(..) ) +import Distribution.PackageDescription + ( PackageDescription(..), BuildInfo(..), TestSuite(..), Library(..) + , TestSuiteInterface(..) + , TestType(..), emptyPackageDescription, emptyBuildInfo, emptyLibrary + , emptyTestSuite, BuildType(..) ) +import Distribution.Verbosity (silent) +import Distribution.License (License(..)) +import Distribution.ModuleName (fromString) +import Distribution.System (buildPlatform) +import Distribution.Compiler + ( CompilerId(..), CompilerFlavor(..) ) +import Distribution.Text + +suite :: Version -> Test +suite cabalVersion = TestCase $ do + let directory = "PackageTests" "TestStanza" + pdFile = directory "my" <.> "cabal" + spec = PackageSpec directory [] + result <- cabal_configure spec + let message = "cabal configure should recognize test section" + test = "unknown section type" + `isInfixOf` + (intercalate " " $ lines $ outputText result) + assertEqual message False test + genPD <- readPackageDescription silent pdFile + let compiler = CompilerId GHC $ Version [6, 12, 2] [] + anyV = intersectVersionRanges anyVersion anyVersion + anticipatedTestSuite = emptyTestSuite + { testName = "dummy" + , testInterface = TestSuiteExeV10 (Version [1,0] []) "dummy.hs" + , testBuildInfo = emptyBuildInfo + { targetBuildDepends = + [ Dependency (PackageName "base") anyVersion ] + , hsSourceDirs = ["."] + } + , testEnabled = False + } + case finalizePackageDescription [] (const True) buildPlatform compiler [] genPD of + Left xs -> let depMessage = "should not have missing dependencies:\n" ++ + (unlines $ map (show . disp) xs) + in assertEqual depMessage True False + Right (f, _) -> let gotTest = head $ testSuites f + in assertEqual "parsed test-suite stanza does not match anticipated" + gotTest anticipatedTestSuite diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/TestStanza/my.cabal ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/TestStanza/my.cabal --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/TestStanza/my.cabal 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/TestStanza/my.cabal 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,19 @@ +name: TestStanza +version: 0.1 +license: BSD3 +author: Thomas Tuegel +stability: stable +category: PackageTests +build-type: Simple + +description: + Check that Cabal recognizes the Test stanza defined below. + +Library + exposed-modules: MyLibrary + build-depends: base + +test-suite dummy + main-is: dummy.hs + type: exitcode-stdio-1.0 + build-depends: base \ No newline at end of file diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/TestStanza/Setup.hs ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/TestStanza/Setup.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/TestStanza/Setup.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/TestStanza/Setup.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/TestSuiteExeV10/Check.hs ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/TestSuiteExeV10/Check.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/TestSuiteExeV10/Check.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/TestSuiteExeV10/Check.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,47 @@ +module PackageTests.TestSuiteExeV10.Check + ( checkTest + , checkTestWithHpc + ) where + +import Distribution.PackageDescription ( TestSuite(..), emptyTestSuite ) +import Distribution.Simple.Hpc +import Distribution.Version +import Test.HUnit +import System.Directory +import System.FilePath +import PackageTests.PackageTester + +dir :: FilePath +dir = "PackageTests" "TestSuiteExeV10" + +checkTest :: Version -> Test +checkTest cabalVersion = TestCase $ do + let spec = PackageSpec dir ["--enable-tests"] + buildResult <- cabal_build spec + let buildMessage = "\'setup build\' should succeed" + assertEqual buildMessage True $ successful buildResult + testResult <- cabal_test spec + let testMessage = "\'setup test\' should succeed" + assertEqual testMessage True $ successful testResult + +checkTestWithHpc :: Version -> Test +checkTestWithHpc cabalVersion = TestCase $ do + let spec = PackageSpec dir [ "--enable-tests" + , "--enable-library-coverage" + ] + buildResult <- cabal_build spec + let buildMessage = "\'setup build\' should succeed" + assertEqual buildMessage True $ successful buildResult + testResult <- cabal_test spec + let testMessage = "\'setup test\' should succeed" + assertEqual testMessage True $ successful testResult + let dummy = emptyTestSuite { testName = "test-Foo" } + tixFile = tixFilePath (dir "dist") dummy + tixFileMessage = ".tix file should exist" + markupDir = tixDir (dir "dist") dummy + markupFile = markupDir "hpc_index" <.> "html" + markupFileMessage = "HPC markup file should exist" + tixFileExists <- doesFileExist tixFile + assertEqual tixFileMessage True tixFileExists + markupFileExists <- doesFileExist markupFile + assertEqual markupFileMessage True markupFileExists diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/TestSuiteExeV10/Foo.hs ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/TestSuiteExeV10/Foo.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/TestSuiteExeV10/Foo.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/TestSuiteExeV10/Foo.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,4 @@ +module Foo where + +fooTest :: [String] -> Bool +fooTest _ = True diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/TestSuiteExeV10/my.cabal ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/TestSuiteExeV10/my.cabal --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/TestSuiteExeV10/my.cabal 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/TestSuiteExeV10/my.cabal 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,15 @@ +name: my +version: 0.1 +license: BSD3 +cabal-version: >= 1.9.2 +build-type: Simple + +library + exposed-modules: Foo + build-depends: base + +test-suite test-Foo + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: test-Foo.hs + build-depends: base, my diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/TestSuiteExeV10/Setup.hs ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/TestSuiteExeV10/Setup.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/TestSuiteExeV10/Setup.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/TestSuiteExeV10/Setup.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/TestSuiteExeV10/tests/test-Foo.hs ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/TestSuiteExeV10/tests/test-Foo.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/PackageTests/TestSuiteExeV10/tests/test-Foo.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/PackageTests/TestSuiteExeV10/tests/test-Foo.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,8 @@ +module Main where + +import Foo +import System.Exit + +main :: IO () +main | fooTest [] = exitSuccess + | otherwise = exitFailure diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/README ghc-7.2.1/libraries/Cabal/cabal/tests/README --- ghc-7.0.3/libraries/Cabal/cabal/tests/README 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/README 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,14 @@ +Building and running the test suite +=================================== + +You can build and run the test suite by running: + + cabal configure && cabal build + cd tests + cabal configure --package-db=../dist/package.conf.inplace \ + --constraint='Cabal == 1.9.1' + cabal build + ./dist/build/suite/suite + +Replace the Cabal constraint with whatever the current development +version of Cabal. diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/Setup.hs ghc-7.2.1/libraries/Cabal/cabal/tests/Setup.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/Setup.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/Setup.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,3 @@ +import Distribution.Simple +main = defaultMain + diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/suite.cabal ghc-7.2.1/libraries/Cabal/cabal/tests/suite.cabal --- ghc-7.0.3/libraries/Cabal/cabal/tests/suite.cabal 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/suite.cabal 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,30 @@ +name: suite +version: 0.1 +license: BSD3 +author: Stephen Blackheath +stability: stable +synopsis: test suite for cabal +category: Distribution +build-type: Simple +cabal-version: >= 1.6 +description: + A test suite for cabal. Run it often, maintain it, add tests to it, + and it will work for you. + +Executable suite + main-is: suite.hs + build-depends: + base, + test-framework, + test-framework-quickcheck2, + test-framework-hunit, + HUnit, + QuickCheck >= 2.1.0.1, + Cabal, + filepath, + process, + directory, + extensible-exceptions, + bytestring, + unix + diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/suite.hs ghc-7.2.1/libraries/Cabal/cabal/tests/suite.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/suite.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/suite.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,66 @@ +-- The intention is that this will be the new unit test framework. +-- Please add any working tests here. This file should do nothing +-- but import tests from other modules. +-- +-- Stephen Blackheath, 2009 + +module Main where + +import Test.Framework +import Test.Framework.Providers.HUnit +import Test.Framework.Providers.QuickCheck2 +import qualified Test.HUnit as HUnit +import PackageTests.BuildDeps.SameDepsAllRound.Check +import PackageTests.BuildDeps.TargetSpecificDeps1.Check +import PackageTests.BuildDeps.TargetSpecificDeps1.Check +import PackageTests.BuildDeps.TargetSpecificDeps2.Check +import PackageTests.BuildDeps.TargetSpecificDeps3.Check +import PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check +import PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check +import PackageTests.BuildDeps.InternalLibrary0.Check +import PackageTests.BuildDeps.InternalLibrary1.Check +import PackageTests.BuildDeps.InternalLibrary2.Check +import PackageTests.BuildDeps.InternalLibrary3.Check +import PackageTests.BuildDeps.InternalLibrary4.Check +import PackageTests.TestStanza.Check +import PackageTests.TestSuiteExeV10.Check +import Distribution.Text (display) +import Distribution.Simple.Utils (cabalVersion) +import Data.Version +import System.Directory + +hunit :: TestName -> HUnit.Test -> Test +hunit name test = testGroup name $ hUnitTestToTests test + +tests :: Version -> [Test] +tests cabalVersion = [ + hunit "PackageTests/BuildDeps/SameDepsAllRound/" PackageTests.BuildDeps.SameDepsAllRound.Check.suite, + hunit "PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/" PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check.suite, + hunit "PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/" PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check.suite, + hunit "PackageTests/BuildDeps/InternalLibrary0/" (PackageTests.BuildDeps.InternalLibrary0.Check.suite cabalVersion), + hunit "PackageTests/TestStanza/" (PackageTests.TestStanza.Check.suite cabalVersion), + -- ^ The Test stanza test will eventually be required + -- only for higher versions. + hunit "PackageTests/TestSuiteExeV10/Test" + (PackageTests.TestSuiteExeV10.Check.checkTest cabalVersion), + hunit "PackageTests/TestSuiteExeV10/TestWithHpc" + (PackageTests.TestSuiteExeV10.Check.checkTestWithHpc cabalVersion) + ] ++ + -- These tests are only required to pass on cabal version >= 1.7 + (if cabalVersion >= Version [1, 7] [] + then [ + hunit "PackageTests/BuildDeps/TargetSpecificDeps1/" PackageTests.BuildDeps.TargetSpecificDeps1.Check.suite, + hunit "PackageTests/BuildDeps/TargetSpecificDeps2/" PackageTests.BuildDeps.TargetSpecificDeps2.Check.suite, + hunit "PackageTests/BuildDeps/TargetSpecificDeps3/" PackageTests.BuildDeps.TargetSpecificDeps3.Check.suite, + hunit "PackageTests/BuildDeps/InternalLibrary1/" PackageTests.BuildDeps.InternalLibrary1.Check.suite, + hunit "PackageTests/BuildDeps/InternalLibrary2/" PackageTests.BuildDeps.InternalLibrary2.Check.suite, + hunit "PackageTests/BuildDeps/InternalLibrary3/" PackageTests.BuildDeps.InternalLibrary3.Check.suite, + hunit "PackageTests/BuildDeps/InternalLibrary4/" PackageTests.BuildDeps.InternalLibrary4.Check.suite + ] + else []) + +main = do + putStrLn $ "Cabal test suite - testing cabal version "++display cabalVersion + setCurrentDirectory "tests" + defaultMain (tests cabalVersion) + diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/A/A.cabal ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/A/A.cabal --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/A/A.cabal 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/A/A.cabal 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,23 @@ +Name: test +cabal-version: > 1.1 +Version: 1.0 +copyright: filler for test suite +maintainer: Isaac Jones +synopsis: this package is really awesome. +Build-Depends: base +Other-Modules: B.A +Exposed-Modules: A +C-Sources: hello.c, c_src/hello.c +Extensions: ForeignFunctionInterface +x-darcs-repo: http://darcs.haskell.org/tmp +unknown-field: Filler. + +Executable: testA +Other-Modules: A +Main-is: MainA.hs +C-Sources: c_src/hello.c +Extensions: OverlappingInstances + +Executable: testB +Other-Modules: B.A +Main-is: B/MainB.hs diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/A/A.hs ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/A/A.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/A/A.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/A/A.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,4 @@ +module A where +a = 42 :: Int + +main2 = print a diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/A/B/A.lhs ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/A/B/A.lhs --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/A/B/A.lhs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/A/B/A.lhs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,4 @@ +> module B.A where +> a = 42 :: Int + +> main = print a diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/A/B/MainB.hs ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/A/B/MainB.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/A/B/MainB.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/A/B/MainB.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,5 @@ +module Main where + +import A + +main = print a diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/A/c_src/hello.c ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/A/c_src/hello.c --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/A/c_src/hello.c 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/A/c_src/hello.c 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1 @@ +int foo () {return 9;} diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/A/hello.c ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/A/hello.c --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/A/hello.c 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/A/hello.c 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1 @@ +int main () {return 9;} diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/A/MainA.hs ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/A/MainA.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/A/MainA.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/A/MainA.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,5 @@ +module Main where + +import A + +main = print a diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/A/Makefile ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/A/Makefile --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/A/Makefile 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/A/Makefile 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1 @@ +include ../Tests.mk diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/A/Setup.lhs ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/A/Setup.lhs --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/A/Setup.lhs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/A/Setup.lhs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,8 @@ +#!/usr/bin/env runhaskell + +> module Main where + +> import Distribution.Simple + +> main :: IO () +> main = defaultMain diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/buildInfo/buildinfo2.buildinfo ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/buildInfo/buildinfo2.buildinfo --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/buildInfo/buildinfo2.buildinfo 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/buildInfo/buildinfo2.buildinfo 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,5 @@ +Executable: exe1 +Buildable: True + +Executable: exe2 +Buildable: True diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/buildInfo/buildinfo2.cabal ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/buildInfo/buildinfo2.cabal --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/buildInfo/buildinfo2.cabal 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/buildInfo/buildinfo2.cabal 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,19 @@ +Name: buildinfo2 +Version: 0.0 +License: GPL +License-file: COPYING +Build-Depends: base +Author: Evgeny Chukreev +Copyright: Evgeny Chukreev (C) 2005 +Maintainer: Evgeny Chukreev +Synopsis: Buildinfo testcase +Description: + Buildinfo testcase + +Executable: exe1 +Main-is: exe1.hs +HS-source-dirs: src + +Executable: exe2 +Main-is: exe2.hs +HS-source-dirs: src diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/buildInfo/Makefile ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/buildInfo/Makefile --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/buildInfo/Makefile 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/buildInfo/Makefile 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1 @@ +include ../Tests.mk diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/buildInfo/Setup.lhs ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/buildInfo/Setup.lhs --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/buildInfo/Setup.lhs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/buildInfo/Setup.lhs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,5 @@ +#!/usr/bin/runhaskell + +> import Distribution.Simple +> main = defaultMainWithHooks defaultUserHooks + diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/buildInfo/src/exe1.hs ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/buildInfo/src/exe1.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/buildInfo/src/exe1.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/buildInfo/src/exe1.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,4 @@ +module Main () where + +main :: IO () +main = return () diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/buildInfo/src/exe2.hs ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/buildInfo/src/exe2.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/buildInfo/src/exe2.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/buildInfo/src/exe2.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,4 @@ +module Main () where + +main :: IO () +main = return () diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/dataDir/dataDir.cabal ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/dataDir/dataDir.cabal --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/dataDir/dataDir.cabal 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/dataDir/dataDir.cabal 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,13 @@ +name: test +version: 0.1 +build-type: Simple +cabal-version: >= 1.2 +data-files: data-file + +-- This test passes if running the below executeable doesn't return an +-- 'exitFailure' status code. + +executable exe + main-is: Exe.hs +-- other-modules: Paths_test + build-depends: base, directory diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/dataDir/Exe.hs ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/dataDir/Exe.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/dataDir/Exe.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/dataDir/Exe.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,17 @@ +module Main where + +import Control.Monad (unless) +import Paths_test (getDataFileName) +import System.Directory (doesFileExist) +import System.Exit (exitFailure) +import System.IO (putStrLn) + +main :: IO () +main = do + fname <- getDataFileName "data-file" + exists <- doesFileExist fname + if exists + then return () + else do putStrLn "Failure." + print fname + exitFailure diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/depOnLib/libs/A.hs ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/depOnLib/libs/A.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/depOnLib/libs/A.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/depOnLib/libs/A.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,4 @@ +module A where + +a :: Char +a = 'a' diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/depOnLib/mains/Main.hs ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/depOnLib/mains/Main.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/depOnLib/mains/Main.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/depOnLib/mains/Main.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,4 @@ +module Main where +import A + +main = putStrLn "Hello, cabal." \ No newline at end of file diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/depOnLib/Makefile ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/depOnLib/Makefile --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/depOnLib/Makefile 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/depOnLib/Makefile 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1 @@ +include ../Tests.mk diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/depOnLib/Setup.lhs ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/depOnLib/Setup.lhs --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/depOnLib/Setup.lhs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/depOnLib/Setup.lhs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,8 @@ +#!/usr/bin/runhugs + +> module Main where + +> import Distribution.Simple + +> main :: IO () +> main = defaultMain diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/depOnLib/test.cabal ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/depOnLib/test.cabal --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/depOnLib/test.cabal 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/depOnLib/test.cabal 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,13 @@ +Name: test +Version: 1.0 +hs-source-dir: libs +copyright: filler for test suite +maintainer: filler for test suite +synopsis: filler for test suite +build-depends: base +exposed-modules: A + +Executable: mainForA +Other-Modules: Main, A +hs-source-dirs: mains, libs +Main-is: Main.hs diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/exeWithC/a.c ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/exeWithC/a.c --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/exeWithC/a.c 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/exeWithC/a.c 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1 @@ +int foo(int v) { return 2*v; } diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/exeWithC/Makefile ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/exeWithC/Makefile --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/exeWithC/Makefile 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/exeWithC/Makefile 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1 @@ +include ../Tests.mk diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/exeWithC/Setup.lhs ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/exeWithC/Setup.lhs --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/exeWithC/Setup.lhs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/exeWithC/Setup.lhs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,2 @@ +> import Distribution.Simple +> main = defaultMainWithHooks defaultUserHooks diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/exeWithC/test.hs ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/exeWithC/test.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/exeWithC/test.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/exeWithC/test.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,4 @@ +{-# CFILES a.c #-} +foreign import ccall unsafe "foo" foo :: Int -> Int + +main = print $ foo 6 diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/exeWithC/tt.cabal ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/exeWithC/tt.cabal --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/exeWithC/tt.cabal 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/exeWithC/tt.cabal 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,13 @@ +Name: tt +Version: 0.0 +Copyright: Einar Karttunen +Maintainer: Isaac Jones +Synopsis: Provided as a test. +License: BSD3 +Author: This Test Case Contributed by: Einar Karttunen Thanks! +Build-Depends: base + +Executable: tt +Main-Is: test.hs +C-Sources: a.c +Extensions: ForeignFunctionInterface diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/ffi-bin/main.cabal ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/ffi-bin/main.cabal --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/ffi-bin/main.cabal 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/ffi-bin/main.cabal 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,6 @@ +Name: test-bin +Build-Depends: base, testffi +Version: 0.0 + +Executable: test +Main-Is: Main.hs diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/ffi-bin/Main.hs ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/ffi-bin/Main.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/ffi-bin/Main.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/ffi-bin/Main.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,7 @@ +module Main where + +import TestFFI + +main :: IO () +main = putStrLn "test" + diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/ffi-bin/Makefile ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/ffi-bin/Makefile --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/ffi-bin/Makefile 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/ffi-bin/Makefile 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1 @@ +include ../Tests.mk diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/ffi-bin/Setup.lhs ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/ffi-bin/Setup.lhs --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/ffi-bin/Setup.lhs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/ffi-bin/Setup.lhs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,4 @@ +#! /usr/bin/env runhaskell + +> import Distribution.Simple +> main = defaultMain diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/ffi-package/Makefile ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/ffi-package/Makefile --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/ffi-package/Makefile 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/ffi-package/Makefile 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1 @@ +include ../Tests.mk diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/ffi-package/Setup.lhs ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/ffi-package/Setup.lhs --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/ffi-package/Setup.lhs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/ffi-package/Setup.lhs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,4 @@ +#! /usr/bin/env runhugs + +> import Distribution.Simple +> main = defaultMain diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/ffi-package/src/TestFFI.hs ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/ffi-package/src/TestFFI.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/ffi-package/src/TestFFI.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/ffi-package/src/TestFFI.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,8 @@ +module TestFFI where + +import Foreign + +type Action = IO () + +foreign import ccall "wrapper" + mkAction :: Action -> IO (FunPtr Action) diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/ffi-package/testffi.cabal ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/ffi-package/testffi.cabal --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/ffi-package/testffi.cabal 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/ffi-package/testffi.cabal 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,10 @@ +Name: testffi +Version: 0.0 +Build-Depends: base +hs-source-dir: src +Exposed-modules: TestFFI +Extensions: ForeignFunctionInterface + +executable: foo +main-is: TestFFIExe.hs +Extensions: ForeignFunctionInterface diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/ffi-package/TestFFIExe.hs ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/ffi-package/TestFFIExe.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/ffi-package/TestFFIExe.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/ffi-package/TestFFIExe.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,11 @@ +module Main where + +import Foreign + +type Action = IO () + +foreign import ccall "wrapper" + mkAction :: Action -> IO (FunPtr Action) + +main :: IO () +main = return () diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/preprocess/preprocess.cabal ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/preprocess/preprocess.cabal --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/preprocess/preprocess.cabal 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/preprocess/preprocess.cabal 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,9 @@ +-- The point of this test is to check that the c2hs pre-processed .hs sources +-- end up in dist/build and that the happy one stays in the src dir. +-- Also, the happy one should be included into the sdist tarball. + +name: preprocess +version: 0.0 +build-depends: base +hs-source-dirs: src +exposed-modules: C2HsExample, HappyExample diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/preprocess/src/C2HsExample.chs ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/preprocess/src/C2HsExample.chs --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/preprocess/src/C2HsExample.chs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/preprocess/src/C2HsExample.chs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,3 @@ +module C2HsExample where + +-- we don't actually need anything diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/preprocess/src/HappyExample.y ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/preprocess/src/HappyExample.y --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/preprocess/src/HappyExample.y 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/preprocess/src/HappyExample.y 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,92 @@ +{ +module HappyExample where +import Data.Char +} + +%name calc +%tokentype { Token } +%expect 0 + + +%token + let { TokenLet } + in { TokenIn } + int { TokenInt $$ } + var { TokenVar $$ } + '=' { TokenEq } + '+' { TokenPlus } + '-' { TokenMinus } + '*' { TokenTimes } + '/' { TokenDiv } + '(' { TokenOB } + ')' { TokenCB } + + +%% + +Exp :: { Exp } +Exp : let var '=' Exp in Exp { Let $2 $4 $6 } + | Exp1 { Exp1 $1 } + +Exp1 : Exp1 '+' Term { Plus $1 $3 } + | Exp1 '-' Term { Minus $1 $3 } + | Term { Term $1 } + +Term : Term '*' Factor { Times $1 $3 } + | Term '/' Factor { Div $1 $3 } + | Factor { Factor $1 } + +Factor : int { Int $1 } + | var { Var $1 } + | '(' Exp ')' { Brack $2 } + + +{ + +happyError :: [Token] -> a +happyError _ = error ("Parse error\n") + + +data Exp = Let String Exp Exp | Exp1 Exp1 +data Exp1 = Plus Exp1 Term | Minus Exp1 Term | Term Term +data Term = Times Term Factor | Div Term Factor | Factor Factor +data Factor = Int Int | Var String | Brack Exp + + +data Token + = TokenLet + | TokenIn + | TokenInt Int + | TokenVar String + | TokenEq + | TokenPlus + | TokenMinus + | TokenTimes + | TokenDiv + | TokenOB + | TokenCB + +lexer :: String -> [Token] +lexer [] = [] +lexer (c:cs) + | isSpace c = lexer cs + | isAlpha c = lexVar (c:cs) + | isDigit c = lexNum (c:cs) +lexer ('=':cs) = TokenEq : lexer cs +lexer ('+':cs) = TokenPlus : lexer cs +lexer ('-':cs) = TokenMinus : lexer cs +lexer ('*':cs) = TokenTimes : lexer cs +lexer ('/':cs) = TokenDiv : lexer cs +lexer ('(':cs) = TokenOB : lexer cs +lexer (')':cs) = TokenCB : lexer cs + +lexNum cs = TokenInt (read num) : lexer rest + where (num,rest) = span isDigit cs + +lexVar cs = + case span isAlpha cs of + ("let",rest) -> TokenLet : lexer rest + ("in",rest) -> TokenIn : lexer rest + (var,rest) -> TokenVar var : lexer rest + +} diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/recursive/A.hi-boot ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/recursive/A.hi-boot --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/recursive/A.hi-boot 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/recursive/A.hi-boot 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,2 @@ +module A where +newtype TA = MkTA GHC.Base.Int diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/recursive/A.hs ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/recursive/A.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/recursive/A.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/recursive/A.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,8 @@ +module A where + +import B( TB(..) ) + +newtype TA = MkTA Int + +f :: TB -> TA +f (MkTB x) = MkTA x diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/recursive/A.hs-boot ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/recursive/A.hs-boot --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/recursive/A.hs-boot 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/recursive/A.hs-boot 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,2 @@ +module A where +newtype TA = MkTA Int diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/recursive/B.hs ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/recursive/B.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/recursive/B.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/recursive/B.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,8 @@ +module B where +import {-# SOURCE #-} A( TA(..) ) + +data TB = MkTB !Int + +g :: TA -> TB +g (MkTA x) = MkTB x + diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/recursive/C.hs ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/recursive/C.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/recursive/C.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/recursive/C.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,6 @@ +module Main where +import B +import A -- FIX: GHC doesn't seem to figure out this dependency?! + +main :: IO () +main = let f = g in putStrLn "C" diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/recursive/Makefile ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/recursive/Makefile --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/recursive/Makefile 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/recursive/Makefile 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1 @@ +include ../Tests.mk diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/recursive/recursive.cabal ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/recursive/recursive.cabal --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/recursive/recursive.cabal 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/recursive/recursive.cabal 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,11 @@ +name: recursive +build-depends: base +version: 1.0 +copyright: filler for test suite +maintainer: Isaac Jones +synopsis: this package is really awesome. +Exposed-Modules: A, B + +Executable: testExe +Main-is: C.hs +other-modules: A, B diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/recursive/Setup.lhs ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/recursive/Setup.lhs --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/recursive/Setup.lhs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/recursive/Setup.lhs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,8 @@ +#!/usr/bin/env runhaskell + +> module Main where + +> import Distribution.Simple + +> main :: IO () +> main = defaultMain diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/sdist/Exe1.hs ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/sdist/Exe1.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/sdist/Exe1.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/sdist/Exe1.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1 @@ +main = print "exe1" diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/sdist/Exe2.hs ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/sdist/Exe2.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/sdist/Exe2.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/sdist/Exe2.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1 @@ +main = print "exe2" diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/sdist/sdist.cabal ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/sdist/sdist.cabal --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/sdist/sdist.cabal 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/sdist/sdist.cabal 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,19 @@ +Name: test +Version: 0.1 +Build-Type: Simple +Cabal-Version: >=1.2 + +-- http://hackage.haskell.org/trac/hackage/ticket/257 +-- This is a test to make sure we're including all sections into the sdist +-- irrespective of the buildable status. +-- So the test passes if the tarball includes both Exe1.hs and Exe2.hs + +Executable exe1 + Main-Is: Exe1.hs + Build-Depends: base + +Executable exe2 + Main-Is: Exe2.hs + Build-Depends: base + if !os(linux) + Buildable: False diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/twoMains/MainA.hs ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/twoMains/MainA.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/twoMains/MainA.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/twoMains/MainA.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,9 @@ +module Main where + +import System.Environment (getArgs) +import Control.Monad (when) + +main = do print 'a' + args <- getArgs + let isB = head args + when (isB /= "isA") (error "A is not A!") diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/twoMains/MainB.hs ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/twoMains/MainB.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/twoMains/MainB.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/twoMains/MainB.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,9 @@ +module Main where + +import System.Environment (getArgs) +import Control.Monad (when) + +main = do print 'b' + args <- getArgs + let isB = head args + when (isB /= "isB") (error "B is not B!") diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/twoMains/Makefile ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/twoMains/Makefile --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/twoMains/Makefile 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/twoMains/Makefile 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1 @@ +include ../Tests.mk diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/twoMains/Setup.lhs ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/twoMains/Setup.lhs --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/twoMains/Setup.lhs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/twoMains/Setup.lhs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,8 @@ +#!/usr/bin/runhugs + +> module Main where + +> import Distribution.Simple + +> main :: IO () +> main = defaultMain diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/twoMains/test.cabal ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/twoMains/test.cabal --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/twoMains/test.cabal 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/twoMains/test.cabal 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,14 @@ +Name: test +Version: 1.0 +copyright: filler for test suite +maintainer: filler for test suite +build-depends: base +synopsis: filler for test suite + +Executable: testA +Other-Modules: MainA +Main-is: MainA.hs + +Executable: testB +Other-Modules: MainB +Main-is: MainB.hs diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/wash2hs/CHANGES ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/wash2hs/CHANGES --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/wash2hs/CHANGES 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/wash2hs/CHANGES 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,5 @@ +* 20031112 + added JSP-style string escape: + <%= my nice haskell code %> + is mapped to + text (my nice haskell code) diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/wash2hs/hs/WASHClean.hs ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/wash2hs/hs/WASHClean.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/wash2hs/hs/WASHClean.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/wash2hs/hs/WASHClean.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,58 @@ +module WASHClean where + +import Data.Char + +import WASHData + +data CM a = CM ([String] -> a) +instance Monad CM where -- Reader monad + return x = CM (const x) + m >>= f = CM (\strs -> + case m of + CM mfun -> + case f (mfun strs) of + CM ffun -> + ffun strs) + +class Clean n where + clean :: n -> CM n + +cleanCodeFragList :: [CodeFrag] -> [CodeFrag] +cleanCodeFragList = map g + where g (EFrag el) = EFrag (cleanElement el) + g (CFrag cs) = CFrag (cleanContentList cs) + g cf = cf + +cleanElement :: Element -> Element +cleanElement e@Element{elemName = en, elemContent = ec} = + if en == "pre" + then e + else let ec' = cleanContentList ec in + e{elemContent = ec'} + +cleanContentList :: [Content] -> [Content] +cleanContentList = remove . map g . combine + where g c = case c of CElement{celem = el} -> CElement{celem = cleanElement el} + CText{ctext = et} -> CText{ctext = et { textString = cleanText (textString et) }} + CCode{ccode = ec} -> CCode{ccode = cleanCodeFragList ec} + _ -> c + combine (CText {ctext = t1} : CText {ctext = t2} : rest ) = + combine (CText {ctext = Text {textString = textString t1++ textString t2, textMode = textMode t1}} : rest) + combine (x : xs) = x : combine xs + combine [] = [] + remove (CText{ctext = tt} : rest) | textString tt == " " = remove rest + -- remove (CText{ctext = tt} : rest@(CElement{} : _)) = CText{ctext = dropRight tt} : remove rest + -- remove (e@CElement{} : (CText{ctext = tt} : rest)) = e : remove (CText{ctext = dropLeft tt} : rest) + remove (x : rest) = x : remove rest + remove [] = [] + +cleanText "" = "" +cleanText xs@[x] | isSpace x = " " + | otherwise = xs +cleanText (x : ys@(y : _)) | isSpace x = if isSpace y + then cleanText ys + else ' ' : cleanText ys + | otherwise = x : cleanText ys + +dropRight tt = tt { textString = reverse (dropWhile isSpace (reverse (textString tt))) } +dropLeft tt = tt { textString = dropWhile isSpace (textString tt) } diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/wash2hs/hs/WASHData.hs ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/wash2hs/hs/WASHData.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/wash2hs/hs/WASHData.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/wash2hs/hs/WASHData.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,74 @@ +module WASHData -- derived from HSPData + ( File (..) + , Mode (..) + , Element (..) + , Text (..) + , Content (..) + , CodeFrag (..) + , Attribute (..) + , AttrValue (..) + ) +where { + + +-- Data type. + +data File = File { + fcode :: [CodeFrag], + topElem :: Element + } deriving Show; + +data Mode = V | S | F + deriving (Eq,Show); + +data Element = Element + { elemMode :: Mode + , elemName :: String + , elemAttrs :: [Attribute] + , elemContent :: [Content] + , elemEmptyTag :: Bool } + deriving Show; + +data Text = Text + { textMode :: Mode + , textString :: String + } + deriving Show; + +data Content + = CElement { celem :: Element } + | CText { ctext :: Text } + | CReference { creference :: Text } + | CPI { cpi :: String } + | CComment { ccomment :: String } + | CCode { ccode :: [CodeFrag] } + deriving Show; + +data CodeFrag + = HFrag String + | EFrag Element + | HSFrag String + | CFrag [Content] + | AFrag [Attribute] + | VFrag String + deriving Show; + +data Attribute + = Attribute + { attrMode :: Mode + , attrName :: String + , attrValue :: AttrValue } + | AttrPattern + { attrPattern :: String } + deriving Show; + +data AttrValue + = AText String + | ACode String + deriving Show; + +data Reference = Reference String deriving Show; + + + +} diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/wash2hs/hs/WASHExpression.hs ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/wash2hs/hs/WASHExpression.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/wash2hs/hs/WASHExpression.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/wash2hs/hs/WASHExpression.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,158 @@ +module WASHExpression where + +import Control.Monad + +import WASHFlags +import qualified WASHUtil +import WASHData +import WASHOut + +code :: FLAGS -> [CodeFrag] -> ShowS +code flags [] = id +code flags (x:xs) = code' flags x . code flags xs + +code' :: FLAGS -> CodeFrag -> ShowS +code' flags (HFrag h) = + showString h +code' flags (EFrag e) = + runOut $ element flags e +code' flags (CFrag cnts) = + showChar '(' . + runOut (contents flags [] cnts) . + showChar ')' +code' flags (AFrag attrs) = + showChar '(' . + WASHUtil.itemList (attribute flags) "CGI.empty" " >> " attrs . + showChar ')' +code' flags (VFrag var) = + id +code' flags _ = error "Unknown type: code" + +outMode :: Mode -> Out () +outMode = outShowS . showMode + +showMode :: Mode -> ShowS +showMode V = id +showMode S = showString "_T" +showMode F = showString "_S" + +element :: FLAGS -> Element -> Out [String] +element flags (Element mode nm ats cnt et) = + do outChar '(' + outString "CGI." + outString nm + when (generateBT flags) $ outMode mode + outChar '(' + outShowS $ attributes flags ats + rvs <- contents flags [] cnt + outString "))" + return rvs + +outRVS :: [String] -> Out () +outRVS [] = outString "()" +outRVS (x:xs) = + do outChar '(' + outString x + mapM_ g xs + outChar ')' + where g x = do { outChar ','; outString x; } + +outRVSpat :: [String] -> Out () +outRVSpat [] = outString "(_)" +outRVSpat xs = outRVS xs + +contents :: FLAGS -> [String] -> [Content] -> Out [String] +contents flags inRVS cts = + case cts of + [] -> + do outString "return" + outRVS inRVS + return inRVS + ct:cts -> + do rvs <- content flags ct + case rvs of + [] -> + case (cts, inRVS) of + ([],[]) -> + return [] + _ -> + do outString " >> " + contents flags inRVS cts + _ -> + case (cts, inRVS) of + ([],[]) -> + return rvs + _ -> + do outString " >>= \\ " + outRVSpat rvs + outString " -> " + contents flags (rvs ++ inRVS) cts + +content :: FLAGS -> Content -> Out [String] +content flags (CElement elem) = + element flags elem +content flags (CText txt) = + do text flags txt + return [] +content flags (CCode (VFrag var:c)) = + do outShowS $ (showChar '(' . code flags c . showChar ')') + return [var] +content flags (CCode c) = + do outShowS $ (showChar '(' . code flags c . showChar ')') + return [] +content flags (CComment cc) = + do outShowS $ (showString "return (const () " . shows cc . showChar ')') + return [] +content flags (CReference txt) = + do text flags txt + return [] +content flags c = + error $ "Unknown type: content -- " ++ (show c) + +text :: FLAGS -> Text -> Out [String] +text flags txt = + do outString "CGI.rawtext" + when (generateBT flags) $ outMode (textMode txt) + outChar ' ' + outs (textString txt) + return [] + +attributes :: FLAGS -> [Attribute] -> ShowS +attributes flags atts = + f atts + where + f [] = id + f (att:atts) = + attribute flags att . + showString " >> " . + f atts + +attribute :: FLAGS -> Attribute -> ShowS +attribute flags (Attribute m n v) = + showString "(CGI.attr" . + (if generateBT flags then (attrvalueBT m v) else id) . + showChar ' ' . + shows n . + showString " " . + attrvalue v . + showString ")" +attribute flags (AttrPattern pat) = + showString "( " . + showString pat . + showString " )" +attribute flags a = error $ "Unknown type: attribute -- " ++ (show a) + +attrvalue :: AttrValue -> ShowS +attrvalue (AText t) = + shows t +attrvalue (ACode c) = + showString "( " . + showString c . + showString " )" +attrvalue a = error $ "Unknown type: attrvalue -- " ++ (show a) + +attrvalueBT :: Mode -> AttrValue -> ShowS +attrvalueBT V _ = id +attrvalueBT m (AText _) = showMode m . showChar 'S' +attrvalueBT m (ACode _) = showMode m . showChar 'D' +attrvalueBT m a = error $ "Unknown type: attrvalueBT -- " ++ (show a) diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/wash2hs/hs/WASHFlags.hs ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/wash2hs/hs/WASHFlags.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/wash2hs/hs/WASHFlags.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/wash2hs/hs/WASHFlags.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,7 @@ +module WASHFlags where +-- +flags0 = FLAGS { generateBT = False } + +data FLAGS = FLAGS { generateBT :: Bool } + + diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/wash2hs/hs/WASHGenerator.hs ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/wash2hs/hs/WASHGenerator.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/wash2hs/hs/WASHGenerator.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/wash2hs/hs/WASHGenerator.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,57 @@ +module WASHGenerator (preprocess, preprocessPIPE) where { + +import Data.List; +import System.IO; + +import WASHData ; +import Parsec hiding (try) ; +import qualified WASHParser ; +import qualified WASHExpression ; +import qualified WASHClean ; +import WASHFlags ; + +-- import Trace; + +preprocess :: FLAGS -> String -> String -> String -> IO (); +preprocess flags srcName dstName globalDefs = + bracket (openFile srcName ReadMode) + (\ srcHandle -> hClose srcHandle) + (\ srcHandle -> + bracket (openFile dstName WriteMode) + (\ dstHandle -> hClose dstHandle) + (\ dstHandle -> + preprocessPIPE flags srcName srcHandle dstHandle globalDefs)); + + +preprocessPIPE :: FLAGS -> String -> Handle -> Handle -> String -> IO (); +preprocessPIPE flags srcName srcHandle dstHandle globalDefs = do { + input <- hGetContents srcHandle; + let { parsing = parse WASHParser.washfile srcName input }; + case parsing of { + Left error -> ioError $ userError $ show error; + Right washfile -> + hPutStrLn dstHandle (postprocess $ file flags globalDefs washfile ""); + }; +}; + +file :: FLAGS -> String -> [CodeFrag] -> ShowS ; +file flags globalDefs fcode = + WASHExpression.code flags (WASHClean.cleanCodeFragList fcode) . + showString globalDefs . + showString "\n" + ; + +imports :: [String] -> String ; +imports is = concat $ map (\m -> "import " ++ m ++ ";\n") is ; + +postprocess :: String -> String ; +postprocess = unlines . postprocess' . lines ; + +postprocess' :: [String] -> [String] ; +postprocess' [] = [] ; +postprocess' xs'@(x:xs) = + if "import" `isPrefixOf` x + then "import qualified CGI" : xs' + else x : postprocess' xs ; + +} diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/wash2hs/hs/WASHMain.hs ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/wash2hs/hs/WASHMain.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/wash2hs/hs/WASHMain.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/wash2hs/hs/WASHMain.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,36 @@ +module Main where + +-- ghc --make WASHMain -package text -o WASHMain + +import System.IO +import Data.List +import System +import WASHGenerator +import WASHFlags + +main = + do args <- getArgs + runPreprocessor flags0 args + +runPreprocessor flags [washfile] = + if ".wash" `isSuffixOf` washfile + then + preprocess flags washfile (take (length washfile - 5) washfile ++ ".hs") "" + else + preprocess flags + (washfile ++ ".wash") + (washfile ++ ".hs") + "" +runPreprocessor flags [washfile, hsfile] = + preprocess flags (washfile) (hsfile) "" +runPreprocessor flags [originalFile, washfile, hsfile] = + preprocess flags (washfile) (hsfile) "" +runPreprocessor flags [] = + preprocessPIPE flags "" stdin stdout "" +runPreprocessor flags args = + do progName <- getProgName + hPutStrLn stderr ("Usage: " ++ progName ++ " washfile [hsfile]") + hPutStrLn stderr (" or: " ++ progName ++ " originalFile infile outfile") + hPutStrLn stderr (" or: " ++ progName) + hPutStrLn stderr (" to run as pipe processor") + hPutStrLn stderr ("Actual arguments: " ++ show args) diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/wash2hs/hs/WASHOut.hs ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/wash2hs/hs/WASHOut.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/wash2hs/hs/WASHOut.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/wash2hs/hs/WASHOut.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,30 @@ +module WASHOut where + +-- output monad + +data Out a = Out a ShowS + +instance Monad Out where + return a = Out a id + m >>= f = case m of + Out x shw1 -> + case f x of + Out y shw2 -> + Out y (shw1 . shw2) + +runOut :: Out a -> ShowS +runOut (Out a shw) = shw + +wrapper = (Out () .) + +outString :: String -> Out () +outString = wrapper showString + +outChar :: Char -> Out () +outChar = wrapper showChar + +outs :: Show a => a -> Out () +outs = wrapper shows + +outShowS :: ShowS -> Out () +outShowS = Out () diff -Nru ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/wash2hs/hs/WASHParser.hs ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/wash2hs/hs/WASHParser.hs --- ghc-7.0.3/libraries/Cabal/cabal/tests/systemTests/wash2hs/hs/WASHParser.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/cabal/tests/systemTests/wash2hs/hs/WASHParser.hs 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,541 @@ +module WASHParser ( xmlfile, washfile ) where { + +import Data.Char ; +import Parsec hiding (letter) ; +import WASHData; +import WASHUtil; + + +notImplemented = char '\xff' >> return undefined + "something that isn't implemented yet"; + +f <$> p = do { x <- p; return $ f x; }; + +testParser p s = + case parse (do { x <- p; eof; return x; }) "bla" s of { + Left x -> print x; + Right y -> print y; + }; + +washfile :: Parser [CodeFrag] ; +washfile = + do code <- hBody + eof + return $ code + ; + +setMode :: Bool -> Mode ; +setMode toplevel = if toplevel then S else F ; + +-- The numbers given for each parser identify the section and +-- grammar production within the XML 1.0 definition (W3C +-- REC-xml-19980210). + + +-- 2.1 / 1 +xmlfile :: Parser File; +xmlfile = do { + prolog; + code <- option [] (do { + hs <- haskell; + s0; + return hs + }); + elem <- element True; + many misc; + eof; + return $ File { fcode = code, topElem = elem }; +}; + + +-- 2.2 / 2 +char' = (char '\t' <|> char '\n' <|> char '\r' <|> + satisfy (>= ' ')) "character"; + + +-- 2.3 / 3 +s = (try $ many1 (char ' ' <|> char '\t' <|> + char '\r' <|> char '\n')) "whitespace"; +s0 = option "" s; +{- +s0 = (try $ many (char ' ' <|> char '\t' <|> + char '\r' <|> char '\n')) "optional whitespace"; +-} + +-- 2.3 / 4 +nameChar = letter <|> digit <|> char '.' <|> char '-' <|> + char '_' <|> char ':' <|> combiningChar <|> extender; + + +-- 2.3 / 5 +name :: Parser String; +name = do { + c <- letter <|> char '_' <|> char ':'; + cs <- many nameChar; + return $ c:cs; +} "name"; + + +-- 2.3 / 6 +names :: Parser [String]; +names = sepBy1 name s; + + +-- 2.3 / 7 +nmtoken :: Parser String; +nmtoken = many1 nameChar "nmtoken"; + + +-- 2.3 / 8 +nmtokens :: Parser [String]; +nmtokens = sepBy1 name s; + + +-- 2.3 / 10 +attValue :: Parser AttrValue; +attValue = (((AText . concat) <$> ( + between (char '\"') (char '\"') (many (p '\"')) + <|> between (char '\'') (char '\'') (many (p '\'')) )) + <|> ACode <$> haskellAttr) "attvalue" +where { + p end = (\x -> [x]) <$> satisfy (f end) <|> reference; + f end = \c -> c /= '<' && c /= '&' && c /= end; +}; + +-- 2.3 / 11 +systemLiteral = do{ + char '\''; + sl <- many (satisfy (\c -> c /= '\'')); + char '\''; + return sl; +} <|> do{ + char '\"'; + sl <- many (satisfy (\c -> c /= '\"')); + char '\"'; + return sl; +}; + +-- 2.3 / 12 +pubidLiteral = do { + char '\''; + sl <- many (pubidChar False); + char '\''; + return sl; +} <|> do{ + char '\"'; + sl <- many (pubidChar True); + char '\"'; + return sl; +}; + +-- 2.3 / 13 +pubidChar w = satisfy (\c -> c >= 'A' && c <= 'Z' + || c >= 'a' && c <= 'z' + || c >= '0' && c <= '9' + || c `elem` " \n\r-()+,./:=?;!*#@$_%" + || w && c == '\''); + +-- 2.4 / 14 +charData :: Bool -> Parser Text; +charData toplevel = + do { s <- many1 charData'; return $ Text (setMode toplevel) $ concat s; } + "#PCDATA"; + +charData' :: Parser String; +charData' = do { + c <- satisfy f; + return [c]; +} <|> do { + string "]]"; + c <- satisfy (\c -> f c && c /= '>'); + return $ ']':']':[c]; +} +where { + f c = c /= '<' && c /= '&' && c /= ']'; +}; + + +-- 2.5 / 15 +comment :: Parser String; +comment = do { + try $ string " - stripCommentsLevel 0 (dropWhile (/= '\n') cs) - stripCommentsLevel 0 ('{':'-':'#':cs) - | keepPragmas = '{' : '-' : '#' : copyPragma cs - stripCommentsLevel n ('{':'-':cs) = stripCommentsLevel (n+1) cs - stripCommentsLevel 0 (c:cs) = c : stripCommentsLevel 0 cs - stripCommentsLevel n ('-':'}':cs) = stripCommentsLevel (n-1) cs - stripCommentsLevel n (_:cs) = stripCommentsLevel n cs - stripCommentsLevel _ [] = [] - - copyString ('\\':c:cs) = '\\' : c : copyString cs - copyString ('"':cs) = '"' : stripCommentsLevel 0 cs - copyString (c:cs) = c : copyString cs - copyString [] = [] - - copyPragma ('#':'-':'}':cs) = '#' : '-' : '}' : stripCommentsLevel 0 cs - copyPragma (c:cs) = c : copyPragma cs - copyPragma [] = [] - --- ----------------------------------------------------------------------------- --- |Install for Hugs. --- For install, copy-prefix = prefix, but for copy they're different. --- The library goes in \\/lib\/hugs\/packages\/\ --- (i.e. \\/lib\/hugs\/packages\/\ on the target system). --- Each executable goes in \\/lib\/hugs\/programs\/\ --- (i.e. \\/lib\/hugs\/programs\/\ on the target system) --- with a script \\/bin\/\ pointing at --- \\/lib\/hugs\/programs\/\. -install - :: Verbosity -- ^verbosity - -> LocalBuildInfo - -> FilePath -- ^Library install location - -> FilePath -- ^Program install location - -> FilePath -- ^Executable install location - -> FilePath -- ^Program location on target system - -> FilePath -- ^Build location - -> (FilePath,FilePath) -- ^Executable (prefix,suffix) - -> PackageDescription - -> IO () ---FIXME: this script should be generated at build time, just installed at this stage -install verbosity lbi libDir installProgDir binDir targetProgDir buildPref (progprefix,progsuffix) pkg_descr = do - removeDirectoryRecursive libDir `catchIO` \_ -> return () - withLib pkg_descr $ \ lib -> - findModuleFiles [buildPref] hugsInstallSuffixes (libModules lib) - >>= installOrdinaryFiles verbosity libDir - let buildProgDir = buildPref "programs" - when (any (buildable . buildInfo) (executables pkg_descr)) $ - createDirectoryIfMissingVerbose verbosity True binDir - withExe pkg_descr $ \ exe -> do - let bi = buildInfo exe - let theBuildDir = buildProgDir exeName exe - let installDir = installProgDir exeName exe - let targetDir = targetProgDir exeName exe - removeDirectoryRecursive installDir `catchIO` \_ -> return () - findModuleFiles [theBuildDir] hugsInstallSuffixes - (ModuleName.main : autogenModuleName pkg_descr - : otherModules (buildInfo exe)) - >>= installOrdinaryFiles verbosity installDir - let targetName = "\"" ++ (targetDir hugsMainFilename exe) ++ "\"" - let hugsOptions = hcOptions Hugs (buildInfo exe) - ++ languageToFlags (compiler lbi) (defaultLanguage bi) - ++ extensionsToFlags (compiler lbi) (allExtensions bi) - let baseExeFile = progprefix ++ (exeName exe) ++ progsuffix - let exeFile = case buildOS of - Windows -> binDir baseExeFile <.> ".bat" - _ -> binDir baseExeFile - let script = case buildOS of - Windows -> - let args = hugsOptions ++ [targetName, "%*"] - in unlines ["@echo off", - unwords ("runhugs" : args)] - _ -> - let args = hugsOptions ++ [targetName, "\"$@\""] - in unlines ["#! /bin/sh", - unwords ("runhugs" : args)] - writeFileAtomic exeFile script - setFileExecutable exeFile - -hugsInstallSuffixes :: [String] -hugsInstallSuffixes = [".hs", ".lhs", dllExtension] - --- |Filename used by Hugs for the main module of an executable. --- This is a simple filename, so that Hugs will look for any auxiliary --- modules it uses relative to the directory it's in. -hugsMainFilename :: Executable -> FilePath -hugsMainFilename exe = "Main" <.> ext - where ext = takeExtension (modulePath exe) - --- ----------------------------------------------------------------------------- --- Registering - -registerPackage - :: Verbosity - -> InstalledPackageInfo - -> PackageDescription - -> LocalBuildInfo - -> Bool - -> PackageDBStack - -> IO () -registerPackage verbosity installedPkgInfo pkg lbi inplace _packageDbs = do - --TODO: prefer to have it based on the packageDbs, but how do we know - -- the package subdir based on the name? the user can set crazy libsubdir - let installDirs = absoluteInstallDirs pkg lbi NoCopyDest - pkgdir | inplace = buildDir lbi - | otherwise = libdir installDirs - createDirectoryIfMissingVerbose verbosity True pkgdir - writeUTF8File (pkgdir "package.conf") - (showInstalledPackageInfo installedPkgInfo) diff -Nru ghc-7.0.3/libraries/Cabal/Distribution/Simple/InstallDirs.hs ghc-7.2.1/libraries/Cabal/Distribution/Simple/InstallDirs.hs --- ghc-7.0.3/libraries/Cabal/Distribution/Simple/InstallDirs.hs 2011-03-26 18:10:12.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/Distribution/Simple/InstallDirs.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,598 +0,0 @@ -{-# LANGUAGE CPP, ForeignFunctionInterface #-} -{-# OPTIONS_NHC98 -cpp #-} -{-# OPTIONS_JHC -fcpp -fffi #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.InstallDirs --- Copyright : Isaac Jones 2003-2004 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This manages everything to do with where files get installed (though does --- not get involved with actually doing any installation). It provides an --- 'InstallDirs' type which is a set of directories for where to install --- things. It also handles the fact that we use templates in these install --- dirs. For example most install dirs are relative to some @$prefix@ and by --- changing the prefix all other dirs still end up changed appropriately. So it --- provides a 'PathTemplate' type and functions for substituting for these --- templates. - -{- All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - -module Distribution.Simple.InstallDirs ( - InstallDirs(..), - InstallDirTemplates, - defaultInstallDirs, - combineInstallDirs, - absoluteInstallDirs, - CopyDest(..), - prefixRelativeInstallDirs, - substituteInstallDirTemplates, - - PathTemplate, - PathTemplateVariable(..), - toPathTemplate, - fromPathTemplate, - substPathTemplate, - initialPathTemplateEnv, - platformTemplateEnv, - compilerTemplateEnv, - packageTemplateEnv, - installDirsTemplateEnv, - ) where - - -import Data.List (isPrefixOf) -import Data.Maybe (fromMaybe) -import Data.Monoid (Monoid(..)) -import System.Directory (getAppUserDataDirectory) -import System.FilePath ((), isPathSeparator, pathSeparator) -#if __HUGS__ || __GLASGOW_HASKELL__ > 606 -import System.FilePath (dropDrive) -#endif - -import Distribution.Package - ( PackageIdentifier, packageName, packageVersion ) -import Distribution.System - ( OS(..), buildOS, Platform(..), buildPlatform ) -import Distribution.Compiler - ( CompilerId, CompilerFlavor(..) ) -import Distribution.Text - ( display ) - -#if mingw32_HOST_OS || mingw32_TARGET_OS -import Foreign -import Foreign.C -#endif - --- --------------------------------------------------------------------------- --- Instalation directories - - --- | The directories where we will install files for packages. --- --- We have several different directories for different types of files since --- many systems have conventions whereby different types of files in a package --- are installed in different direcotries. This is particularly the case on --- unix style systems. --- -data InstallDirs dir = InstallDirs { - prefix :: dir, - bindir :: dir, - libdir :: dir, - libsubdir :: dir, - dynlibdir :: dir, - libexecdir :: dir, - progdir :: dir, - includedir :: dir, - datadir :: dir, - datasubdir :: dir, - docdir :: dir, - mandir :: dir, - htmldir :: dir, - haddockdir :: dir - } deriving (Read, Show) - -instance Functor InstallDirs where - fmap f dirs = InstallDirs { - prefix = f (prefix dirs), - bindir = f (bindir dirs), - libdir = f (libdir dirs), - libsubdir = f (libsubdir dirs), - dynlibdir = f (dynlibdir dirs), - libexecdir = f (libexecdir dirs), - progdir = f (progdir dirs), - includedir = f (includedir dirs), - datadir = f (datadir dirs), - datasubdir = f (datasubdir dirs), - docdir = f (docdir dirs), - mandir = f (mandir dirs), - htmldir = f (htmldir dirs), - haddockdir = f (haddockdir dirs) - } - -instance Monoid dir => Monoid (InstallDirs dir) where - mempty = InstallDirs { - prefix = mempty, - bindir = mempty, - libdir = mempty, - libsubdir = mempty, - dynlibdir = mempty, - libexecdir = mempty, - progdir = mempty, - includedir = mempty, - datadir = mempty, - datasubdir = mempty, - docdir = mempty, - mandir = mempty, - htmldir = mempty, - haddockdir = mempty - } - mappend = combineInstallDirs mappend - -combineInstallDirs :: (a -> b -> c) - -> InstallDirs a - -> InstallDirs b - -> InstallDirs c -combineInstallDirs combine a b = InstallDirs { - prefix = prefix a `combine` prefix b, - bindir = bindir a `combine` bindir b, - libdir = libdir a `combine` libdir b, - libsubdir = libsubdir a `combine` libsubdir b, - dynlibdir = dynlibdir a `combine` dynlibdir b, - libexecdir = libexecdir a `combine` libexecdir b, - progdir = progdir a `combine` progdir b, - includedir = includedir a `combine` includedir b, - datadir = datadir a `combine` datadir b, - datasubdir = datasubdir a `combine` datasubdir b, - docdir = docdir a `combine` docdir b, - mandir = mandir a `combine` mandir b, - htmldir = htmldir a `combine` htmldir b, - haddockdir = haddockdir a `combine` haddockdir b - } - -appendSubdirs :: (a -> a -> a) -> InstallDirs a -> InstallDirs a -appendSubdirs append dirs = dirs { - libdir = libdir dirs `append` libsubdir dirs, - datadir = datadir dirs `append` datasubdir dirs, - libsubdir = error "internal error InstallDirs.libsubdir", - datasubdir = error "internal error InstallDirs.datasubdir" - } - --- | The installation directories in terms of 'PathTemplate's that contain --- variables. --- --- The defaults for most of the directories are relative to each other, in --- particular they are all relative to a single prefix. This makes it --- convenient for the user to override the default installation directory --- by only having to specify --prefix=... rather than overriding each --- individually. This is done by allowing $-style variables in the dirs. --- These are expanded by textual substituion (see 'substPathTemplate'). --- --- A few of these installation directories are split into two components, the --- dir and subdir. The full installation path is formed by combining the two --- together with @\/@. The reason for this is compatibility with other unix --- build systems which also support @--libdir@ and @--datadir@. We would like --- users to be able to configure @--libdir=\/usr\/lib64@ for example but --- because by default we want to support installing multiple versions of --- packages and building the same package for multiple compilers we append the --- libsubdir to get: @\/usr\/lib64\/$pkgid\/$compiler@. --- --- An additional complication is the need to support relocatable packages on --- systems which support such things, like Windows. --- -type InstallDirTemplates = InstallDirs PathTemplate - --- --------------------------------------------------------------------------- --- Default installation directories - -defaultInstallDirs :: CompilerFlavor -> Bool -> Bool -> IO InstallDirTemplates -defaultInstallDirs comp userInstall _hasLibs = do - windowsProgramFilesDir <- getWindowsProgramFilesDir - userInstallPrefix <- getAppUserDataDirectory "cabal" - lhcPrefix <- getAppUserDataDirectory "lhc" - return $ fmap toPathTemplate $ InstallDirs { - prefix = if userInstall - then userInstallPrefix - else case buildOS of - Windows -> windowsProgramFilesDir "Haskell" - _other -> "/usr/local", - bindir = "$prefix" "bin", - libdir = case buildOS of - Windows -> "$prefix" - _other -> case comp of - LHC | userInstall -> lhcPrefix - _ -> "$prefix" "lib", - libsubdir = case comp of - Hugs -> "hugs" "packages" "$pkg" - JHC -> "$compiler" - LHC -> "$compiler" - UHC -> "$pkgid" - _other -> "$pkgid" "$compiler", - dynlibdir = "$libdir", - libexecdir = case buildOS of - Windows -> "$prefix" "$pkgid" - _other -> "$prefix" "libexec", - progdir = "$libdir" "hugs" "programs", - includedir = "$libdir" "$libsubdir" "include", - datadir = case buildOS of - Windows -> "$prefix" - _other -> "$prefix" "share", - datasubdir = "$pkgid", - docdir = "$datadir" "doc" "$pkgid", - mandir = "$datadir" "man", - htmldir = "$docdir" "html", - haddockdir = "$htmldir" - } - --- --------------------------------------------------------------------------- --- Converting directories, absolute or prefix-relative - --- | Substitute the install dir templates into each other. --- --- To prevent cyclic substitutions, only some variables are allowed in --- particular dir templates. If out of scope vars are present, they are not --- substituted for. Checking for any remaining unsubstituted vars can be done --- as a subsequent operation. --- --- The reason it is done this way is so that in 'prefixRelativeInstallDirs' we --- can replace 'prefix' with the 'PrefixVar' and get resulting --- 'PathTemplate's that still have the 'PrefixVar' in them. Doing this makes it --- each to check which paths are relative to the $prefix. --- -substituteInstallDirTemplates :: PathTemplateEnv - -> InstallDirTemplates -> InstallDirTemplates -substituteInstallDirTemplates env dirs = dirs' - where - dirs' = InstallDirs { - -- So this specifies exactly which vars are allowed in each template - prefix = subst prefix [], - bindir = subst bindir [prefixVar], - libdir = subst libdir [prefixVar, bindirVar], - libsubdir = subst libsubdir [], - dynlibdir = subst dynlibdir [prefixVar, bindirVar, libdirVar], - libexecdir = subst libexecdir prefixBinLibVars, - progdir = subst progdir prefixBinLibVars, - includedir = subst includedir prefixBinLibVars, - datadir = subst datadir prefixBinLibVars, - datasubdir = subst datasubdir [], - docdir = subst docdir prefixBinLibDataVars, - mandir = subst mandir (prefixBinLibDataVars ++ [docdirVar]), - htmldir = subst htmldir (prefixBinLibDataVars ++ [docdirVar]), - haddockdir = subst haddockdir (prefixBinLibDataVars ++ - [docdirVar, htmldirVar]) - } - subst dir env' = substPathTemplate (env'++env) (dir dirs) - - prefixVar = (PrefixVar, prefix dirs') - bindirVar = (BindirVar, bindir dirs') - libdirVar = (LibdirVar, libdir dirs') - libsubdirVar = (LibsubdirVar, libsubdir dirs') - datadirVar = (DatadirVar, datadir dirs') - datasubdirVar = (DatasubdirVar, datasubdir dirs') - docdirVar = (DocdirVar, docdir dirs') - htmldirVar = (HtmldirVar, htmldir dirs') - prefixBinLibVars = [prefixVar, bindirVar, libdirVar, libsubdirVar] - prefixBinLibDataVars = prefixBinLibVars ++ [datadirVar, datasubdirVar] - --- | Convert from abstract install directories to actual absolute ones by --- substituting for all the variables in the abstract paths, to get real --- absolute path. -absoluteInstallDirs :: PackageIdentifier -> CompilerId -> CopyDest - -> InstallDirs PathTemplate - -> InstallDirs FilePath -absoluteInstallDirs pkgId compilerId copydest dirs = - (case copydest of - CopyTo destdir -> fmap ((destdir ) . dropDrive) - _ -> id) - . appendSubdirs () - . fmap fromPathTemplate - $ substituteInstallDirTemplates env dirs - where - env = initialPathTemplateEnv pkgId compilerId - - --- |The location prefix for the /copy/ command. -data CopyDest - = NoCopyDest - | CopyTo FilePath - deriving (Eq, Show) - --- | Check which of the paths are relative to the installation $prefix. --- --- If any of the paths are not relative, ie they are absolute paths, then it --- prevents us from making a relocatable package (also known as a \"prefix --- independent\" package). --- -prefixRelativeInstallDirs :: PackageIdentifier -> CompilerId - -> InstallDirTemplates - -> InstallDirs (Maybe FilePath) -prefixRelativeInstallDirs pkgId compilerId dirs = - fmap relative - . appendSubdirs combinePathTemplate - $ -- substitute the path template into each other, except that we map - -- \$prefix back to $prefix. We're trying to end up with templates that - -- mention no vars except $prefix. - substituteInstallDirTemplates env dirs { - prefix = PathTemplate [Variable PrefixVar] - } - where - env = initialPathTemplateEnv pkgId compilerId - - -- If it starts with $prefix then it's relative and produce the relative - -- path by stripping off $prefix/ or $prefix - relative dir = case dir of - PathTemplate cs -> fmap (fromPathTemplate . PathTemplate) (relative' cs) - relative' (Variable PrefixVar : Ordinary (s:rest) : rest') - | isPathSeparator s = Just (Ordinary rest : rest') - relative' (Variable PrefixVar : rest) = Just rest - relative' _ = Nothing - --- --------------------------------------------------------------------------- --- Path templates - --- | An abstract path, posibly containing variables that need to be --- substituted for to get a real 'FilePath'. --- -newtype PathTemplate = PathTemplate [PathComponent] - -data PathComponent = - Ordinary FilePath - | Variable PathTemplateVariable - deriving Eq - -data PathTemplateVariable = - PrefixVar -- ^ The @$prefix@ path variable - | BindirVar -- ^ The @$bindir@ path variable - | LibdirVar -- ^ The @$libdir@ path variable - | LibsubdirVar -- ^ The @$libsubdir@ path variable - | DatadirVar -- ^ The @$datadir@ path variable - | DatasubdirVar -- ^ The @$datasubdir@ path variable - | DocdirVar -- ^ The @$docdir@ path variable - | HtmldirVar -- ^ The @$htmldir@ path variable - | PkgNameVar -- ^ The @$pkg@ package name path variable - | PkgVerVar -- ^ The @$version@ package version path variable - | PkgIdVar -- ^ The @$pkgid@ package Id path variable, eg @foo-1.0@ - | CompilerVar -- ^ The compiler name and version, eg @ghc-6.6.1@ - | OSVar -- ^ The operating system name, eg @windows@ or @linux@ - | ArchVar -- ^ The cpu architecture name, eg @i386@ or @x86_64@ - | ExecutableNameVar -- ^ The executable name; used in shell wrappers - | TestSuiteNameVar -- ^ The name of the test suite being run - | TestSuiteResultVar -- ^ The result of the test suite being run, eg @pass@, @fail@, or @error@. - deriving Eq - -type PathTemplateEnv = [(PathTemplateVariable, PathTemplate)] - --- | Convert a 'FilePath' to a 'PathTemplate' including any template vars. --- -toPathTemplate :: FilePath -> PathTemplate -toPathTemplate = PathTemplate . read - --- | Convert back to a path, any remaining vars are included --- -fromPathTemplate :: PathTemplate -> FilePath -fromPathTemplate (PathTemplate template) = show template - -combinePathTemplate :: PathTemplate -> PathTemplate -> PathTemplate -combinePathTemplate (PathTemplate t1) (PathTemplate t2) = - PathTemplate (t1 ++ [Ordinary [pathSeparator]] ++ t2) - -substPathTemplate :: PathTemplateEnv -> PathTemplate -> PathTemplate -substPathTemplate environment (PathTemplate template) = - PathTemplate (concatMap subst template) - - where subst component@(Ordinary _) = [component] - subst component@(Variable variable) = - case lookup variable environment of - Just (PathTemplate components) -> components - Nothing -> [component] - --- | The initial environment has all the static stuff but no paths -initialPathTemplateEnv :: PackageIdentifier -> CompilerId -> PathTemplateEnv -initialPathTemplateEnv pkgId compilerId = - packageTemplateEnv pkgId - ++ compilerTemplateEnv compilerId - ++ platformTemplateEnv buildPlatform -- platform should be param if we want - -- to do cross-platform configuation - -packageTemplateEnv :: PackageIdentifier -> PathTemplateEnv -packageTemplateEnv pkgId = - [(PkgNameVar, PathTemplate [Ordinary $ display (packageName pkgId)]) - ,(PkgVerVar, PathTemplate [Ordinary $ display (packageVersion pkgId)]) - ,(PkgIdVar, PathTemplate [Ordinary $ display pkgId]) - ] - -compilerTemplateEnv :: CompilerId -> PathTemplateEnv -compilerTemplateEnv compilerId = - [(CompilerVar, PathTemplate [Ordinary $ display compilerId]) - ] - -platformTemplateEnv :: Platform -> PathTemplateEnv -platformTemplateEnv (Platform arch os) = - [(OSVar, PathTemplate [Ordinary $ display os]) - ,(ArchVar, PathTemplate [Ordinary $ display arch]) - ] - -installDirsTemplateEnv :: InstallDirs PathTemplate -> PathTemplateEnv -installDirsTemplateEnv dirs = - [(PrefixVar, prefix dirs) - ,(BindirVar, bindir dirs) - ,(LibdirVar, libdir dirs) - ,(LibsubdirVar, libsubdir dirs) - ,(DatadirVar, datadir dirs) - ,(DatasubdirVar, datasubdir dirs) - ,(DocdirVar, docdir dirs) - ,(HtmldirVar, htmldir dirs) - ] - - --- --------------------------------------------------------------------------- --- Parsing and showing path templates: - --- The textual format is that of an ordinary Haskell String, eg --- "$prefix/bin" --- and this gets parsed to the internal representation as a sequence of path --- spans which are either strings or variables, eg: --- PathTemplate [Variable PrefixVar, Ordinary "/bin" ] - -instance Show PathTemplateVariable where - show PrefixVar = "prefix" - show BindirVar = "bindir" - show LibdirVar = "libdir" - show LibsubdirVar = "libsubdir" - show DatadirVar = "datadir" - show DatasubdirVar = "datasubdir" - show DocdirVar = "docdir" - show HtmldirVar = "htmldir" - show PkgNameVar = "pkg" - show PkgVerVar = "version" - show PkgIdVar = "pkgid" - show CompilerVar = "compiler" - show OSVar = "os" - show ArchVar = "arch" - show ExecutableNameVar = "executablename" - show TestSuiteNameVar = "test-suite" - show TestSuiteResultVar = "result" - -instance Read PathTemplateVariable where - readsPrec _ s = - take 1 - [ (var, drop (length varStr) s) - | (varStr, var) <- vars - , varStr `isPrefixOf` s ] - where vars = [("prefix", PrefixVar) - ,("bindir", BindirVar) - ,("libdir", LibdirVar) - ,("libsubdir", LibsubdirVar) - ,("datadir", DatadirVar) - ,("datasubdir", DatasubdirVar) - ,("docdir", DocdirVar) - ,("htmldir", HtmldirVar) - ,("pkgid", PkgIdVar) - ,("pkg", PkgNameVar) - ,("version", PkgVerVar) - ,("compiler", CompilerVar) - ,("os", OSVar) - ,("arch", ArchVar) - ,("executablename", ExecutableNameVar) - ,("test-suite", TestSuiteNameVar) - ,("result", TestSuiteResultVar)] - -instance Show PathComponent where - show (Ordinary path) = path - show (Variable var) = '$':show var - showList = foldr (\x -> (shows x .)) id - -instance Read PathComponent where - -- for some reason we colapse multiple $ symbols here - readsPrec _ = lex0 - where lex0 [] = [] - lex0 ('$':'$':s') = lex0 ('$':s') - lex0 ('$':s') = case [ (Variable var, s'') - | (var, s'') <- reads s' ] of - [] -> lex1 "$" s' - ok -> ok - lex0 s' = lex1 [] s' - lex1 "" "" = [] - lex1 acc "" = [(Ordinary (reverse acc), "")] - lex1 acc ('$':'$':s) = lex1 acc ('$':s) - lex1 acc ('$':s) = [(Ordinary (reverse acc), '$':s)] - lex1 acc (c:s) = lex1 (c:acc) s - readList [] = [([],"")] - readList s = [ (component:components, s'') - | (component, s') <- reads s - , (components, s'') <- readList s' ] - -instance Show PathTemplate where - show (PathTemplate template) = show (show template) - -instance Read PathTemplate where - readsPrec p s = [ (PathTemplate template, s') - | (path, s') <- readsPrec p s - , (template, "") <- reads path ] - --- --------------------------------------------------------------------------- --- Internal utilities - -getWindowsProgramFilesDir :: IO FilePath -getWindowsProgramFilesDir = do -#if mingw32_HOST_OS || mingw32_TARGET_OS - m <- shGetFolderPath csidl_PROGRAM_FILES -#else - let m = Nothing -#endif - return (fromMaybe "C:\\Program Files" m) - -#if mingw32_HOST_OS || mingw32_TARGET_OS -shGetFolderPath :: CInt -> IO (Maybe FilePath) -shGetFolderPath n = -# if __HUGS__ - return Nothing -# else - allocaBytes long_path_size $ \pPath -> do - r <- c_SHGetFolderPath nullPtr n nullPtr 0 pPath - if (r /= 0) - then return Nothing - else do s <- peekCString pPath; return (Just s) - where - long_path_size = 1024 -# endif - -csidl_PROGRAM_FILES :: CInt -csidl_PROGRAM_FILES = 0x0026 --- csidl_PROGRAM_FILES_COMMON :: CInt --- csidl_PROGRAM_FILES_COMMON = 0x002b - -foreign import stdcall unsafe "shlobj.h SHGetFolderPathA" - c_SHGetFolderPath :: Ptr () - -> CInt - -> Ptr () - -> CInt - -> CString - -> IO CInt -#endif - -#if !(__HUGS__ || __GLASGOW_HASKELL__ > 606) --- Compat: this function only appears in FilePath > 1.0 --- (which at the time of writing is unreleased) -dropDrive :: FilePath -> FilePath -dropDrive (c:cs) | isPathSeparator c = cs -dropDrive (_:':':c:cs) | isWindows - && isPathSeparator c = cs -- path with drive letter -dropDrive (_:':':cs) | isWindows = cs -dropDrive cs = cs - -isWindows :: Bool -isWindows = case buildOS of - Windows -> True - _ -> False -#endif diff -Nru ghc-7.0.3/libraries/Cabal/Distribution/Simple/Install.hs ghc-7.2.1/libraries/Cabal/Distribution/Simple/Install.hs --- ghc-7.0.3/libraries/Cabal/Distribution/Simple/Install.hs 2011-03-26 18:10:12.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/Distribution/Simple/Install.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,214 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Install --- Copyright : Isaac Jones 2003-2004 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This is the entry point into installing a built package. Performs the --- \"@.\/setup install@\" and \"@.\/setup copy@\" actions. It moves files into --- place based on the prefix argument. It does the generic bits and then calls --- compiler-specific functions to do the rest. - -{- All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - -module Distribution.Simple.Install ( - install, - ) where - -import Distribution.PackageDescription ( - PackageDescription(..), BuildInfo(..), Library(..), - hasLibs, withLib, hasExes, withExe ) -import Distribution.Package (Package(..)) -import Distribution.Simple.LocalBuildInfo ( - LocalBuildInfo(..), InstallDirs(..), absoluteInstallDirs, - substPathTemplate) -import Distribution.Simple.BuildPaths (haddockName, haddockPref) -import Distribution.Simple.Utils - ( createDirectoryIfMissingVerbose, installDirectoryContents - , installOrdinaryFile, die, info, notice, matchDirFileGlob ) -import Distribution.Simple.Compiler - ( CompilerFlavor(..), compilerFlavor ) -import Distribution.Simple.Setup (CopyFlags(..), CopyDest(..), fromFlag) - -import qualified Distribution.Simple.GHC as GHC -import qualified Distribution.Simple.NHC as NHC -import qualified Distribution.Simple.JHC as JHC -import qualified Distribution.Simple.LHC as LHC -import qualified Distribution.Simple.Hugs as Hugs -import qualified Distribution.Simple.UHC as UHC - -import Control.Monad (when, unless) -import System.Directory - ( doesDirectoryExist, doesFileExist ) -import System.FilePath - ( takeFileName, takeDirectory, (), isAbsolute ) - -import Distribution.Verbosity -import Distribution.Text - ( display ) - --- |Perform the \"@.\/setup install@\" and \"@.\/setup copy@\" --- actions. Move files into place based on the prefix argument. FIX: --- nhc isn't implemented yet. - -install :: PackageDescription -- ^information from the .cabal file - -> LocalBuildInfo -- ^information from the configure step - -> CopyFlags -- ^flags sent to copy or install - -> IO () -install pkg_descr lbi flags = do - let distPref = fromFlag (copyDistPref flags) - verbosity = fromFlag (copyVerbosity flags) - copydest = fromFlag (copyDest flags) - installDirs@(InstallDirs { - bindir = binPref, - libdir = libPref, --- dynlibdir = dynlibPref, --see TODO below - datadir = dataPref, - progdir = progPref, - docdir = docPref, - htmldir = htmlPref, - haddockdir = interfacePref, - includedir = incPref}) - = absoluteInstallDirs pkg_descr lbi copydest - - --TODO: decide if we need the user to be able to control the libdir - -- for shared libs independently of the one for static libs. If so - -- it should also have a flag in the command line UI - -- For the moment use dynlibdir = libdir - dynlibPref = libPref - progPrefixPref = substPathTemplate (packageId pkg_descr) lbi (progPrefix lbi) - progSuffixPref = substPathTemplate (packageId pkg_descr) lbi (progSuffix lbi) - - docExists <- doesDirectoryExist $ haddockPref distPref pkg_descr - info verbosity ("directory " ++ haddockPref distPref pkg_descr ++ - " does exist: " ++ show docExists) - - installDataFiles verbosity pkg_descr dataPref - - when docExists $ do - createDirectoryIfMissingVerbose verbosity True htmlPref - installDirectoryContents verbosity - (haddockPref distPref pkg_descr) htmlPref - -- setPermissionsRecursive [Read] htmlPref - -- The haddock interface file actually already got installed - -- in the recursive copy, but now we install it where we actually - -- want it to be (normally the same place). We could remove the - -- copy in htmlPref first. - let haddockInterfaceFileSrc = haddockPref distPref pkg_descr - haddockName pkg_descr - haddockInterfaceFileDest = interfacePref haddockName pkg_descr - -- We only generate the haddock interface file for libs, So if the - -- package consists only of executables there will not be one: - exists <- doesFileExist haddockInterfaceFileSrc - when exists $ do - createDirectoryIfMissingVerbose verbosity True interfacePref - installOrdinaryFile verbosity haddockInterfaceFileSrc - haddockInterfaceFileDest - - let lfile = licenseFile pkg_descr - unless (null lfile) $ do - createDirectoryIfMissingVerbose verbosity True docPref - installOrdinaryFile verbosity lfile (docPref takeFileName lfile) - - let buildPref = buildDir lbi - when (hasLibs pkg_descr) $ - notice verbosity ("Installing library in " ++ libPref) - when (hasExes pkg_descr) $ - notice verbosity ("Installing executable(s) in " ++ binPref) - - -- install include files for all compilers - they may be needed to compile - -- haskell files (using the CPP extension) - when (hasLibs pkg_descr) $ installIncludeFiles verbosity pkg_descr incPref - - case compilerFlavor (compiler lbi) of - GHC -> do withLib pkg_descr $ - GHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr - withExe pkg_descr $ - GHC.installExe verbosity lbi installDirs buildPref (progPrefixPref, progSuffixPref) pkg_descr - LHC -> do withLib pkg_descr $ - LHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr - withExe pkg_descr $ - LHC.installExe verbosity lbi installDirs buildPref (progPrefixPref, progSuffixPref) pkg_descr - JHC -> do withLib pkg_descr $ - JHC.installLib verbosity libPref buildPref pkg_descr - withExe pkg_descr $ - JHC.installExe verbosity binPref buildPref (progPrefixPref, progSuffixPref) pkg_descr - Hugs -> do - let targetProgPref = progdir (absoluteInstallDirs pkg_descr lbi NoCopyDest) - let scratchPref = scratchDir lbi - Hugs.install verbosity lbi libPref progPref binPref targetProgPref scratchPref (progPrefixPref, progSuffixPref) pkg_descr - NHC -> do withLib pkg_descr $ NHC.installLib verbosity libPref buildPref (packageId pkg_descr) - withExe pkg_descr $ NHC.installExe verbosity binPref buildPref (progPrefixPref, progSuffixPref) - UHC -> do withLib pkg_descr $ UHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr - _ -> die $ "installing with " - ++ display (compilerFlavor (compiler lbi)) - ++ " is not implemented" - return () - -- register step should be performed by caller. - --- | Install the files listed in data-files --- -installDataFiles :: Verbosity -> PackageDescription -> FilePath -> IO () -installDataFiles verbosity pkg_descr destDataDir = - flip mapM_ (dataFiles pkg_descr) $ \ file -> do - let srcDataDir = dataDir pkg_descr - files <- matchDirFileGlob srcDataDir file - let dir = takeDirectory file - createDirectoryIfMissingVerbose verbosity True (destDataDir dir) - sequence_ [ installOrdinaryFile verbosity (srcDataDir file') - (destDataDir file') - | file' <- files ] - --- | Install the files listed in install-includes --- -installIncludeFiles :: Verbosity -> PackageDescription -> FilePath -> IO () -installIncludeFiles verbosity - PackageDescription { library = Just lib } destIncludeDir = do - - incs <- mapM (findInc relincdirs) (installIncludes lbi) - sequence_ - [ do createDirectoryIfMissingVerbose verbosity True destDir - installOrdinaryFile verbosity srcFile destFile - | (relFile, srcFile) <- incs - , let destFile = destIncludeDir relFile - destDir = takeDirectory destFile ] - where - relincdirs = "." : filter (not.isAbsolute) (includeDirs lbi) - lbi = libBuildInfo lib - - findInc [] file = die ("can't find include file " ++ file) - findInc (dir:dirs) file = do - let path = dir file - exists <- doesFileExist path - if exists then return (file, path) else findInc dirs file -installIncludeFiles _ _ _ = die "installIncludeFiles: Can't happen?" diff -Nru ghc-7.0.3/libraries/Cabal/Distribution/Simple/JHC.hs ghc-7.2.1/libraries/Cabal/Distribution/Simple/JHC.hs --- ghc-7.0.3/libraries/Cabal/Distribution/Simple/JHC.hs 2011-03-26 18:10:12.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/Distribution/Simple/JHC.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,217 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.JHC --- Copyright : Isaac Jones 2003-2006 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This module contains most of the JHC-specific code for configuring, building --- and installing packages. - -{- -Copyright (c) 2009, Henning Thielemann -Copyright (c) 2003-2005, Isaac Jones -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - -module Distribution.Simple.JHC ( - configure, getInstalledPackages, - buildLib, buildExe, - installLib, installExe - ) where - -import Distribution.PackageDescription as PD - ( PackageDescription(..), BuildInfo(..), Executable(..) - , Library(..), libModules, hcOptions, usedExtensions ) -import Distribution.InstalledPackageInfo - ( emptyInstalledPackageInfo, ) -import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo -import Distribution.Simple.PackageIndex (PackageIndex) -import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Simple.LocalBuildInfo - ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) ) -import Distribution.Simple.BuildPaths - ( autogenModulesDir, exeExtension ) -import Distribution.Simple.Compiler - ( CompilerFlavor(..), CompilerId(..), Compiler(..) - , PackageDBStack, Flag, languageToFlags, extensionsToFlags ) -import Language.Haskell.Extension - ( Language(Haskell98), Extension(..)) -import Distribution.Simple.Program - ( ConfiguredProgram(..), jhcProgram, ProgramConfiguration - , userMaybeSpecifyPath, requireProgramVersion, lookupProgram - , rawSystemProgram, rawSystemProgramStdoutConf ) -import Distribution.Version - ( Version(..), orLaterVersion ) -import Distribution.Package - ( Package(..), InstalledPackageId(InstalledPackageId), - pkgName, pkgVersion, ) -import Distribution.Simple.Utils - ( createDirectoryIfMissingVerbose, writeFileAtomic - , installOrdinaryFile, installExecutableFile - , intercalate ) -import System.FilePath ( () ) -import Distribution.Verbosity -import Distribution.Text - ( Text(parse), display ) -import Distribution.Compat.ReadP - ( readP_to_S, string, skipSpaces ) - -import Data.List ( nub ) -import Data.Char ( isSpace ) -import Data.Maybe ( fromMaybe ) - - --- ----------------------------------------------------------------------------- --- Configuring - -configure :: Verbosity -> Maybe FilePath -> Maybe FilePath - -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration) -configure verbosity hcPath _hcPkgPath conf = do - - (jhcProg, _, conf') <- requireProgramVersion verbosity - jhcProgram (orLaterVersion (Version [0,7,2] [])) - (userMaybeSpecifyPath "jhc" hcPath conf) - - let Just version = programVersion jhcProg - comp = Compiler { - compilerId = CompilerId JHC version, - compilerLanguages = jhcLanguages, - compilerExtensions = jhcLanguageExtensions - } - return (comp, conf') - -jhcLanguages :: [(Language, Flag)] -jhcLanguages = [(Haskell98, "")] - --- | The flags for the supported extensions -jhcLanguageExtensions :: [(Extension, Flag)] -jhcLanguageExtensions = - [(TypeSynonymInstances , "") - ,(ForeignFunctionInterface , "") - ,(NoImplicitPrelude , "--noprelude") - ,(CPP , "-fcpp") - ] - -getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration - -> IO PackageIndex -getInstalledPackages verbosity _packageDBs conf = do - -- jhc --list-libraries lists all available libraries. - -- How shall I find out, whether they are global or local - -- without checking all files and locations? - str <- rawSystemProgramStdoutConf verbosity jhcProgram conf ["--list-libraries"] - let pCheck :: [(a, String)] -> [a] - pCheck rs = [ r | (r,s) <- rs, all isSpace s ] - let parseLine ln = - pCheck (readP_to_S - (skipSpaces >> string "Name:" >> skipSpaces >> parse) ln) - return $ - PackageIndex.fromList $ - map (\p -> emptyInstalledPackageInfo { - InstalledPackageInfo.installedPackageId = - InstalledPackageId (display p), - InstalledPackageInfo.sourcePackageId = p - }) $ - concatMap parseLine $ - lines str - --- ----------------------------------------------------------------------------- --- Building - --- | Building a package for JHC. --- Currently C source files are not supported. -buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo - -> Library -> ComponentLocalBuildInfo -> IO () -buildLib verbosity pkg_descr lbi lib clbi = do - let Just jhcProg = lookupProgram jhcProgram (withPrograms lbi) - let libBi = libBuildInfo lib - let args = constructJHCCmdLine lbi libBi clbi (buildDir lbi) verbosity - let pkgid = display (packageId pkg_descr) - pfile = buildDir lbi "jhc-pkg.conf" - hlfile= buildDir lbi (pkgid ++ ".hl") - writeFileAtomic pfile $ jhcPkgConf pkg_descr - rawSystemProgram verbosity jhcProg $ - ["--build-hl="++pfile, "-o", hlfile] ++ - args ++ map display (libModules lib) - --- | Building an executable for JHC. --- Currently C source files are not supported. -buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo - -> Executable -> ComponentLocalBuildInfo -> IO () -buildExe verbosity _pkg_descr lbi exe clbi = do - let Just jhcProg = lookupProgram jhcProgram (withPrograms lbi) - let exeBi = buildInfo exe - let out = buildDir lbi exeName exe - let args = constructJHCCmdLine lbi exeBi clbi (buildDir lbi) verbosity - rawSystemProgram verbosity jhcProg (["-o",out] ++ args ++ [modulePath exe]) - -constructJHCCmdLine :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo - -> FilePath -> Verbosity -> [String] -constructJHCCmdLine lbi bi clbi _odir verbosity = - (if verbosity >= deafening then ["-v"] else []) - ++ hcOptions JHC bi - ++ languageToFlags (compiler lbi) (defaultLanguage bi) - ++ extensionsToFlags (compiler lbi) (usedExtensions bi) - ++ ["--noauto","-i-"] - ++ concat [["-i", l] | l <- nub (hsSourceDirs bi)] - ++ ["-i", autogenModulesDir lbi] - ++ ["-optc" ++ opt | opt <- PD.ccOptions bi] - -- It would be better if JHC would accept package names with versions, - -- but JHC-0.7.2 doesn't accept this. - -- Thus, we have to strip the version with 'pkgName'. - ++ (concat [ ["-p", display (pkgName pkgid)] - | (_, pkgid) <- componentPackageDeps clbi ]) - -jhcPkgConf :: PackageDescription -> String -jhcPkgConf pd = - let sline name sel = name ++ ": "++sel pd - lib = fromMaybe (error "no library available") . library - comma = intercalate "," . map display - in unlines [sline "name" (display . pkgName . packageId) - ,sline "version" (display . pkgVersion . packageId) - ,sline "exposed-modules" (comma . PD.exposedModules . lib) - ,sline "hidden-modules" (comma . otherModules . libBuildInfo . lib) - ] - -installLib :: Verbosity -> FilePath -> FilePath -> PackageDescription -> Library -> IO () -installLib verb dest build_dir pkg_descr _ = do - let p = display (packageId pkg_descr)++".hl" - createDirectoryIfMissingVerbose verb True dest - installOrdinaryFile verb (build_dir p) (dest p) - -installExe :: Verbosity -> FilePath -> FilePath -> (FilePath,FilePath) -> PackageDescription -> Executable -> IO () -installExe verb dest build_dir (progprefix,progsuffix) _ exe = do - let exe_name = exeName exe - src = exe_name exeExtension - out = (progprefix ++ exe_name ++ progsuffix) exeExtension - createDirectoryIfMissingVerbose verb True dest - installExecutableFile verb (build_dir src) (dest out) - diff -Nru ghc-7.0.3/libraries/Cabal/Distribution/Simple/LHC.hs ghc-7.2.1/libraries/Cabal/Distribution/Simple/LHC.hs --- ghc-7.0.3/libraries/Cabal/Distribution/Simple/LHC.hs 2011-03-26 18:10:12.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/Distribution/Simple/LHC.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,805 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.LHC --- Copyright : Isaac Jones 2003-2007 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This is a fairly large module. It contains most of the GHC-specific code for --- configuring, building and installing packages. It also exports a function --- for finding out what packages are already installed. Configuring involves --- finding the @ghc@ and @ghc-pkg@ programs, finding what language extensions --- this version of ghc supports and returning a 'Compiler' value. --- --- 'getInstalledPackages' involves calling the @ghc-pkg@ program to find out --- what packages are installed. --- --- Building is somewhat complex as there is quite a bit of information to take --- into account. We have to build libs and programs, possibly for profiling and --- shared libs. We have to support building libraries that will be usable by --- GHCi and also ghc's @-split-objs@ feature. We have to compile any C files --- using ghc. Linking, especially for @split-objs@ is remarkably complex, --- partly because there tend to be 1,000's of @.o@ files and this can often be --- more than we can pass to the @ld@ or @ar@ programs in one go. --- --- Installing for libs and exes involves finding the right files and copying --- them to the right places. One of the more tricky things about this module is --- remembering the layout of files in the build directory (which is not --- explicitly documented) and thus what search dirs are used for various kinds --- of files. - -{- Copyright (c) 2003-2005, Isaac Jones -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modiication, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - -module Distribution.Simple.LHC ( - configure, getInstalledPackages, - buildLib, buildExe, - installLib, installExe, - registerPackage, - ghcOptions, - ghcVerbosityOptions - ) where - -import Distribution.PackageDescription as PD - ( PackageDescription(..), BuildInfo(..), Executable(..) - , Library(..), libModules, hcOptions, usedExtensions, allExtensions ) -import Distribution.InstalledPackageInfo - ( InstalledPackageInfo - , parseInstalledPackageInfo ) -import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo - ( InstalledPackageInfo_(..) ) -import Distribution.Simple.PackageIndex -import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.ParseUtils ( ParseResult(..) ) -import Distribution.Simple.LocalBuildInfo - ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) ) -import Distribution.Simple.InstallDirs -import Distribution.Simple.BuildPaths -import Distribution.Simple.Utils -import Distribution.Package - ( PackageIdentifier, Package(..) ) -import qualified Distribution.ModuleName as ModuleName -import Distribution.Simple.Program - ( Program(..), ConfiguredProgram(..), ProgramConfiguration, ProgArg - , ProgramLocation(..), rawSystemProgram, rawSystemProgramConf - , rawSystemProgramStdout, rawSystemProgramStdoutConf - , requireProgramVersion - , userMaybeSpecifyPath, programPath, lookupProgram, addKnownProgram - , arProgram, ranlibProgram, ldProgram - , gccProgram, stripProgram - , lhcProgram, lhcPkgProgram ) -import qualified Distribution.Simple.Program.HcPkg as HcPkg -import Distribution.Simple.Compiler - ( CompilerFlavor(..), CompilerId(..), Compiler(..), compilerVersion - , OptimisationLevel(..), PackageDB(..), PackageDBStack - , Flag, languageToFlags, extensionsToFlags ) -import Distribution.Version - ( Version(..), orLaterVersion ) -import Distribution.System - ( OS(..), buildOS ) -import Distribution.Verbosity -import Distribution.Text - ( display, simpleParse ) -import Language.Haskell.Extension - ( Language(Haskell98), Extension(..) ) - -import Control.Monad ( unless, when ) -import Data.List -import Data.Maybe ( catMaybes ) -import Data.Monoid ( Monoid(..) ) -import System.Directory ( removeFile, renameFile, - getDirectoryContents, doesFileExist, - getTemporaryDirectory ) -import System.FilePath ( (), (<.>), takeExtension, - takeDirectory, replaceExtension ) -import System.IO (hClose, hPutStrLn) -import Distribution.Compat.Exception (catchExit, catchIO) - --- ----------------------------------------------------------------------------- --- Configuring - -configure :: Verbosity -> Maybe FilePath -> Maybe FilePath - -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration) -configure verbosity hcPath hcPkgPath conf = do - - (lhcProg, lhcVersion, conf') <- - requireProgramVersion verbosity lhcProgram - (orLaterVersion (Version [0,7] [])) - (userMaybeSpecifyPath "lhc" hcPath conf) - - (lhcPkgProg, lhcPkgVersion, conf'') <- - requireProgramVersion verbosity lhcPkgProgram - (orLaterVersion (Version [0,7] [])) - (userMaybeSpecifyPath "lhc-pkg" hcPkgPath conf') - - when (lhcVersion /= lhcPkgVersion) $ die $ - "Version mismatch between lhc and lhc-pkg: " - ++ programPath lhcProg ++ " is version " ++ display lhcVersion ++ " " - ++ programPath lhcPkgProg ++ " is version " ++ display lhcPkgVersion - - languages <- getLanguages verbosity lhcProg - extensions <- getExtensions verbosity lhcProg - - let comp = Compiler { - compilerId = CompilerId LHC lhcVersion, - compilerLanguages = languages, - compilerExtensions = extensions - } - conf''' = configureToolchain lhcProg conf'' -- configure gcc and ld - return (comp, conf''') - --- | Adjust the way we find and configure gcc and ld --- -configureToolchain :: ConfiguredProgram -> ProgramConfiguration - -> ProgramConfiguration -configureToolchain lhcProg = - addKnownProgram gccProgram { - programFindLocation = findProg gccProgram (baseDir "gcc.exe"), - programPostConf = configureGcc - } - . addKnownProgram ldProgram { - programFindLocation = findProg ldProgram (libDir "ld.exe"), - programPostConf = configureLd - } - where - compilerDir = takeDirectory (programPath lhcProg) - baseDir = takeDirectory compilerDir - libDir = baseDir "gcc-lib" - includeDir = baseDir "include" "mingw" - isWindows = case buildOS of Windows -> True; _ -> False - - -- on Windows finding and configuring ghc's gcc and ld is a bit special - findProg :: Program -> FilePath -> Verbosity -> IO (Maybe FilePath) - findProg prog location | isWindows = \verbosity -> do - exists <- doesFileExist location - if exists then return (Just location) - else do warn verbosity ("Couldn't find " ++ programName prog ++ " where I expected it. Trying the search path.") - programFindLocation prog verbosity - | otherwise = programFindLocation prog - - configureGcc :: Verbosity -> ConfiguredProgram -> IO [ProgArg] - configureGcc - | isWindows = \_ gccProg -> case programLocation gccProg of - -- if it's found on system then it means we're using the result - -- of programFindLocation above rather than a user-supplied path - -- that means we should add this extra flag to tell ghc's gcc - -- where it lives and thus where gcc can find its various files: - FoundOnSystem {} -> return ["-B" ++ libDir, "-I" ++ includeDir] - UserSpecified {} -> return [] - | otherwise = \_ _ -> return [] - - -- we need to find out if ld supports the -x flag - configureLd :: Verbosity -> ConfiguredProgram -> IO [ProgArg] - configureLd verbosity ldProg = do - tempDir <- getTemporaryDirectory - ldx <- withTempFile tempDir ".c" $ \testcfile testchnd -> - withTempFile tempDir ".o" $ \testofile testohnd -> do - hPutStrLn testchnd "int foo() {}" - hClose testchnd; hClose testohnd - rawSystemProgram verbosity lhcProg ["-c", testcfile, - "-o", testofile] - withTempFile tempDir ".o" $ \testofile' testohnd' -> - do - hClose testohnd' - _ <- rawSystemProgramStdout verbosity ldProg - ["-x", "-r", testofile, "-o", testofile'] - return True - `catchIO` (\_ -> return False) - `catchExit` (\_ -> return False) - if ldx - then return ["-x"] - else return [] - -getLanguages :: Verbosity -> ConfiguredProgram -> IO [(Language, Flag)] -getLanguages _ _ = return [(Haskell98, "")] ---FIXME: does lhc support -XHaskell98 flag? from what version? - -getExtensions :: Verbosity -> ConfiguredProgram -> IO [(Extension, Flag)] -getExtensions verbosity lhcProg = do - exts <- rawSystemStdout verbosity (programPath lhcProg) - ["--supported-languages"] - -- GHC has the annoying habit of inverting some of the extensions - -- so we have to try parsing ("No" ++ ghcExtensionName) first - let readExtension str = do - ext <- simpleParse ("No" ++ str) - case ext of - UnknownExtension _ -> simpleParse str - _ -> return ext - return $ [ (ext, "-X" ++ display ext) - | Just ext <- map readExtension (lines exts) ] - -getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration - -> IO PackageIndex -getInstalledPackages verbosity packagedbs conf = do - checkPackageDbStack packagedbs - pkgss <- getInstalledPackages' verbosity packagedbs conf - let indexes = [ PackageIndex.fromList (map (substTopDir topDir) pkgs) - | (_, pkgs) <- pkgss ] - return $! (mconcat indexes) - - where - -- On Windows, various fields have $topdir/foo rather than full - -- paths. We need to substitute the right value in so that when - -- we, for example, call gcc, we have proper paths to give it - Just ghcProg = lookupProgram lhcProgram conf - compilerDir = takeDirectory (programPath ghcProg) - topDir = takeDirectory compilerDir - -checkPackageDbStack :: PackageDBStack -> IO () -checkPackageDbStack (GlobalPackageDB:rest) - | GlobalPackageDB `notElem` rest = return () -checkPackageDbStack _ = - die $ "GHC.getInstalledPackages: the global package db must be " - ++ "specified first and cannot be specified multiple times" - --- | Get the packages from specific PackageDBs, not cumulative. --- -getInstalledPackages' :: Verbosity -> [PackageDB] -> ProgramConfiguration - -> IO [(PackageDB, [InstalledPackageInfo])] -getInstalledPackages' verbosity packagedbs conf - = - sequence - [ do str <- rawSystemProgramStdoutConf verbosity lhcPkgProgram conf - ["dump", packageDbGhcPkgFlag packagedb] - `catchExit` \_ -> die $ "ghc-pkg dump failed" - case parsePackages str of - Left ok -> return (packagedb, ok) - _ -> die "failed to parse output of 'ghc-pkg dump'" - | packagedb <- packagedbs ] - - where - parsePackages str = - let parsed = map parseInstalledPackageInfo (splitPkgs str) - in case [ msg | ParseFailed msg <- parsed ] of - [] -> Left [ pkg | ParseOk _ pkg <- parsed ] - msgs -> Right msgs - - splitPkgs :: String -> [String] - splitPkgs = map unlines . splitWith ("---" ==) . lines - where - splitWith :: (a -> Bool) -> [a] -> [[a]] - splitWith p xs = ys : case zs of - [] -> [] - _:ws -> splitWith p ws - where (ys,zs) = break p xs - - packageDbGhcPkgFlag GlobalPackageDB = "--global" - packageDbGhcPkgFlag UserPackageDB = "--user" - packageDbGhcPkgFlag (SpecificPackageDB path) = "--package-conf=" ++ path - - -substTopDir :: FilePath -> InstalledPackageInfo -> InstalledPackageInfo -substTopDir topDir ipo - = ipo { - InstalledPackageInfo.importDirs - = map f (InstalledPackageInfo.importDirs ipo), - InstalledPackageInfo.libraryDirs - = map f (InstalledPackageInfo.libraryDirs ipo), - InstalledPackageInfo.includeDirs - = map f (InstalledPackageInfo.includeDirs ipo), - InstalledPackageInfo.frameworkDirs - = map f (InstalledPackageInfo.frameworkDirs ipo), - InstalledPackageInfo.haddockInterfaces - = map f (InstalledPackageInfo.haddockInterfaces ipo), - InstalledPackageInfo.haddockHTMLs - = map f (InstalledPackageInfo.haddockHTMLs ipo) - } - where f ('$':'t':'o':'p':'d':'i':'r':rest) = topDir ++ rest - f x = x - --- ----------------------------------------------------------------------------- --- Building - --- | Build a library with LHC. --- -buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo - -> Library -> ComponentLocalBuildInfo -> IO () -buildLib verbosity pkg_descr lbi lib clbi = do - let pref = buildDir lbi - pkgid = packageId pkg_descr - runGhcProg = rawSystemProgramConf verbosity lhcProgram (withPrograms lbi) - ifVanillaLib forceVanilla = when (forceVanilla || withVanillaLib lbi) - ifProfLib = when (withProfLib lbi) - ifSharedLib = when (withSharedLib lbi) - ifGHCiLib = when (withGHCiLib lbi && withVanillaLib lbi) - - libBi <- hackThreadedFlag verbosity - (compiler lbi) (withProfLib lbi) (libBuildInfo lib) - - let libTargetDir = pref - forceVanillaLib = TemplateHaskell `elem` allExtensions libBi - -- TH always needs vanilla libs, even when building for profiling - - createDirectoryIfMissingVerbose verbosity True libTargetDir - -- TODO: do we need to put hs-boot files into place for mutually recurive modules? - let ghcArgs = - ["-package-name", display pkgid ] - ++ constructGHCCmdLine lbi libBi clbi libTargetDir verbosity - ++ map display (libModules lib) - lhcWrap x = ["--build-library", "--ghc-opts=" ++ unwords x] - ghcArgsProf = ghcArgs - ++ ["-prof", - "-hisuf", "p_hi", - "-osuf", "p_o" - ] - ++ ghcProfOptions libBi - ghcArgsShared = ghcArgs - ++ ["-dynamic", - "-hisuf", "dyn_hi", - "-osuf", "dyn_o", "-fPIC" - ] - ++ ghcSharedOptions libBi - unless (null (libModules lib)) $ - do ifVanillaLib forceVanillaLib (runGhcProg $ lhcWrap ghcArgs) - ifProfLib (runGhcProg $ lhcWrap ghcArgsProf) - ifSharedLib (runGhcProg $ lhcWrap ghcArgsShared) - - -- build any C sources - unless (null (cSources libBi)) $ do - info verbosity "Building C Sources..." - sequence_ [do let (odir,args) = constructCcCmdLine lbi libBi clbi pref - filename verbosity - createDirectoryIfMissingVerbose verbosity True odir - runGhcProg args - ifSharedLib (runGhcProg (args ++ ["-fPIC", "-osuf dyn_o"])) - | filename <- cSources libBi] - - -- link: - info verbosity "Linking..." - let cObjs = map (`replaceExtension` objExtension) (cSources libBi) - cSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension)) (cSources libBi) - vanillaLibFilePath = libTargetDir mkLibName pkgid - profileLibFilePath = libTargetDir mkProfLibName pkgid - sharedLibFilePath = libTargetDir mkSharedLibName pkgid - (compilerId (compiler lbi)) - ghciLibFilePath = libTargetDir mkGHCiLibName pkgid - - stubObjs <- fmap catMaybes $ sequence - [ findFileWithExtension [objExtension] [libTargetDir] - (ModuleName.toFilePath x ++"_stub") - | x <- libModules lib ] - stubProfObjs <- fmap catMaybes $ sequence - [ findFileWithExtension ["p_" ++ objExtension] [libTargetDir] - (ModuleName.toFilePath x ++"_stub") - | x <- libModules lib ] - stubSharedObjs <- fmap catMaybes $ sequence - [ findFileWithExtension ["dyn_" ++ objExtension] [libTargetDir] - (ModuleName.toFilePath x ++"_stub") - | x <- libModules lib ] - - hObjs <- getHaskellObjects lib lbi - pref objExtension True - hProfObjs <- - if (withProfLib lbi) - then getHaskellObjects lib lbi - pref ("p_" ++ objExtension) True - else return [] - hSharedObjs <- - if (withSharedLib lbi) - then getHaskellObjects lib lbi - pref ("dyn_" ++ objExtension) False - else return [] - - unless (null hObjs && null cObjs && null stubObjs) $ do - -- first remove library files if they exists - sequence_ - [ removeFile libFilePath `catchIO` \_ -> return () - | libFilePath <- [vanillaLibFilePath, profileLibFilePath - ,sharedLibFilePath, ghciLibFilePath] ] - - let arVerbosity | verbosity >= deafening = "v" - | verbosity >= normal = "" - | otherwise = "c" - arArgs = ["q"++ arVerbosity] - ++ [vanillaLibFilePath] - arObjArgs = - hObjs - ++ map (pref ) cObjs - ++ stubObjs - arProfArgs = ["q"++ arVerbosity] - ++ [profileLibFilePath] - arProfObjArgs = - hProfObjs - ++ map (pref ) cObjs - ++ stubProfObjs - ldArgs = ["-r"] - ++ ["-o", ghciLibFilePath <.> "tmp"] - ldObjArgs = - hObjs - ++ map (pref ) cObjs - ++ stubObjs - ghcSharedObjArgs = - hSharedObjs - ++ map (pref ) cSharedObjs - ++ stubSharedObjs - -- After the relocation lib is created we invoke ghc -shared - -- with the dependencies spelled out as -package arguments - -- and ghc invokes the linker with the proper library paths - ghcSharedLinkArgs = - [ "-no-auto-link-packages", - "-shared", - "-dynamic", - "-o", sharedLibFilePath ] - ++ ghcSharedObjArgs - ++ ["-package-name", display pkgid ] - ++ ghcPackageFlags lbi clbi - ++ ["-l"++extraLib | extraLib <- extraLibs libBi] - ++ ["-L"++extraLibDir | extraLibDir <- extraLibDirs libBi] - - runLd ldLibName args = do - exists <- doesFileExist ldLibName - -- This method is called iteratively by xargs. The - -- output goes to .tmp, and any existing file - -- named is included when linking. The - -- output is renamed to . - rawSystemProgramConf verbosity ldProgram (withPrograms lbi) - (args ++ if exists then [ldLibName] else []) - renameFile (ldLibName <.> "tmp") ldLibName - - runAr = rawSystemProgramConf verbosity arProgram (withPrograms lbi) - - --TODO: discover this at configure time or runtime on unix - -- The value is 32k on Windows and posix specifies a minimum of 4k - -- but all sensible unixes use more than 4k. - -- we could use getSysVar ArgumentLimit but that's in the unix lib - maxCommandLineSize = 30 * 1024 - - ifVanillaLib False $ xargs maxCommandLineSize - runAr arArgs arObjArgs - - ifProfLib $ xargs maxCommandLineSize - runAr arProfArgs arProfObjArgs - - ifGHCiLib $ xargs maxCommandLineSize - (runLd ghciLibFilePath) ldArgs ldObjArgs - - ifSharedLib $ runGhcProg ghcSharedLinkArgs - - --- | Build an executable with LHC. --- -buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo - -> Executable -> ComponentLocalBuildInfo -> IO () -buildExe verbosity _pkg_descr lbi - exe@Executable { exeName = exeName', modulePath = modPath } clbi = do - let pref = buildDir lbi - runGhcProg = rawSystemProgramConf verbosity lhcProgram (withPrograms lbi) - - exeBi <- hackThreadedFlag verbosity - (compiler lbi) (withProfExe lbi) (buildInfo exe) - - -- exeNameReal, the name that GHC really uses (with .exe on Windows) - let exeNameReal = exeName' <.> - (if null $ takeExtension exeName' then exeExtension else "") - - let targetDir = pref exeName' - let exeDir = targetDir (exeName' ++ "-tmp") - createDirectoryIfMissingVerbose verbosity True targetDir - createDirectoryIfMissingVerbose verbosity True exeDir - -- TODO: do we need to put hs-boot files into place for mutually recursive modules? - -- FIX: what about exeName.hi-boot? - - -- build executables - unless (null (cSources exeBi)) $ do - info verbosity "Building C Sources." - sequence_ [do let (odir,args) = constructCcCmdLine lbi exeBi clbi - exeDir filename verbosity - createDirectoryIfMissingVerbose verbosity True odir - runGhcProg args - | filename <- cSources exeBi] - - srcMainFile <- findFile (exeDir : hsSourceDirs exeBi) modPath - - let cObjs = map (`replaceExtension` objExtension) (cSources exeBi) - let lhcWrap x = ("--ghc-opts\"":x) ++ ["\""] - let binArgs linkExe profExe = - (if linkExe - then ["-o", targetDir exeNameReal] - else ["-c"]) - ++ constructGHCCmdLine lbi exeBi clbi exeDir verbosity - ++ [exeDir x | x <- cObjs] - ++ [srcMainFile] - ++ ["-optl" ++ opt | opt <- PD.ldOptions exeBi] - ++ ["-l"++lib | lib <- extraLibs exeBi] - ++ ["-L"++libDir | libDir <- extraLibDirs exeBi] - ++ concat [["-framework", f] | f <- PD.frameworks exeBi] - ++ if profExe - then ["-prof", - "-hisuf", "p_hi", - "-osuf", "p_o" - ] ++ ghcProfOptions exeBi - else [] - - -- For building exe's for profiling that use TH we actually - -- have to build twice, once without profiling and the again - -- with profiling. This is because the code that TH needs to - -- run at compile time needs to be the vanilla ABI so it can - -- be loaded up and run by the compiler. - when (withProfExe lbi && TemplateHaskell `elem` allExtensions exeBi) - (runGhcProg $ lhcWrap (binArgs False False)) - - runGhcProg (binArgs True (withProfExe lbi)) - --- | Filter the "-threaded" flag when profiling as it does not --- work with ghc-6.8 and older. -hackThreadedFlag :: Verbosity -> Compiler -> Bool -> BuildInfo -> IO BuildInfo -hackThreadedFlag verbosity comp prof bi - | not mustFilterThreaded = return bi - | otherwise = do - warn verbosity $ "The ghc flag '-threaded' is not compatible with " - ++ "profiling in ghc-6.8 and older. It will be disabled." - return bi { options = filterHcOptions (/= "-threaded") (options bi) } - where - mustFilterThreaded = prof && compilerVersion comp < Version [6, 10] [] - && "-threaded" `elem` hcOptions GHC bi - filterHcOptions p hcoptss = - [ (hc, if hc == GHC then filter p opts else opts) - | (hc, opts) <- hcoptss ] - --- when using -split-objs, we need to search for object files in the --- Module_split directory for each module. -getHaskellObjects :: Library -> LocalBuildInfo - -> FilePath -> String -> Bool -> IO [FilePath] -getHaskellObjects lib lbi pref wanted_obj_ext allow_split_objs - | splitObjs lbi && allow_split_objs = do - let dirs = [ pref (ModuleName.toFilePath x ++ "_split") - | x <- libModules lib ] - objss <- mapM getDirectoryContents dirs - let objs = [ dir obj - | (objs',dir) <- zip objss dirs, obj <- objs', - let obj_ext = takeExtension obj, - '.':wanted_obj_ext == obj_ext ] - return objs - | otherwise = - return [ pref ModuleName.toFilePath x <.> wanted_obj_ext - | x <- libModules lib ] - - -constructGHCCmdLine - :: LocalBuildInfo - -> BuildInfo - -> ComponentLocalBuildInfo - -> FilePath - -> Verbosity - -> [String] -constructGHCCmdLine lbi bi clbi odir verbosity = - ["--make"] - ++ ghcVerbosityOptions verbosity - -- Unsupported extensions have already been checked by configure - ++ ghcOptions lbi bi clbi odir - -ghcVerbosityOptions :: Verbosity -> [String] -ghcVerbosityOptions verbosity - | verbosity >= deafening = ["-v"] - | verbosity >= normal = [] - | otherwise = ["-w", "-v0"] - -ghcOptions :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo - -> FilePath -> [String] -ghcOptions lbi bi clbi odir - = ["-hide-all-packages"] - ++ ghcPackageDbOptions (withPackageDB lbi) - ++ (if splitObjs lbi then ["-split-objs"] else []) - ++ ["-i"] - ++ ["-i" ++ odir] - ++ ["-i" ++ l | l <- nub (hsSourceDirs bi)] - ++ ["-i" ++ autogenModulesDir lbi] - ++ ["-I" ++ autogenModulesDir lbi] - ++ ["-I" ++ odir] - ++ ["-I" ++ dir | dir <- PD.includeDirs bi] - ++ ["-optP" ++ opt | opt <- cppOptions bi] - ++ [ "-optP-include", "-optP"++ (autogenModulesDir lbi cppHeaderName) ] - ++ [ "-#include \"" ++ inc ++ "\"" | inc <- PD.includes bi ] - ++ [ "-odir", odir, "-hidir", odir ] - ++ (if compilerVersion c >= Version [6,8] [] - then ["-stubdir", odir] else []) - ++ ghcPackageFlags lbi clbi - ++ (case withOptimization lbi of - NoOptimisation -> [] - NormalOptimisation -> ["-O"] - MaximumOptimisation -> ["-O2"]) - ++ hcOptions GHC bi - ++ languageToFlags c (defaultLanguage bi) - ++ extensionsToFlags c (usedExtensions bi) - where c = compiler lbi - -ghcPackageFlags :: LocalBuildInfo -> ComponentLocalBuildInfo -> [String] -ghcPackageFlags lbi clbi - | ghcVer >= Version [6,11] [] - = concat [ ["-package-id", display ipkgid] - | (ipkgid, _) <- componentPackageDeps clbi ] - - | otherwise = concat [ ["-package", display pkgid] - | (_, pkgid) <- componentPackageDeps clbi ] - where - ghcVer = compilerVersion (compiler lbi) - -ghcPackageDbOptions :: PackageDBStack -> [String] -ghcPackageDbOptions dbstack = case dbstack of - (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs - (GlobalPackageDB:dbs) -> "-no-user-package-conf" - : concatMap specific dbs - _ -> ierror - where - specific (SpecificPackageDB db) = [ "-package-conf", db ] - specific _ = ierror - ierror = error ("internal error: unexpected package db stack: " ++ show dbstack) - -constructCcCmdLine :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo - -> FilePath -> FilePath -> Verbosity -> (FilePath,[String]) -constructCcCmdLine lbi bi clbi pref filename verbosity - = let odir | compilerVersion (compiler lbi) >= Version [6,4,1] [] = pref - | otherwise = pref takeDirectory filename - -- ghc 6.4.1 fixed a bug in -odir handling - -- for C compilations. - in - (odir, - ghcCcOptions lbi bi clbi odir - ++ (if verbosity >= deafening then ["-v"] else []) - ++ ["-c",filename]) - - -ghcCcOptions :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo - -> FilePath -> [String] -ghcCcOptions lbi bi clbi odir - = ["-I" ++ dir | dir <- PD.includeDirs bi] - ++ ghcPackageDbOptions (withPackageDB lbi) - ++ ghcPackageFlags lbi clbi - ++ ["-optc" ++ opt | opt <- PD.ccOptions bi] - ++ (case withOptimization lbi of - NoOptimisation -> [] - _ -> ["-optc-O2"]) - ++ ["-odir", odir] - -mkGHCiLibName :: PackageIdentifier -> String -mkGHCiLibName lib = "HS" ++ display lib <.> "o" - --- ----------------------------------------------------------------------------- --- Installing - --- |Install executables for GHC. -installExe :: Verbosity - -> LocalBuildInfo - -> InstallDirs FilePath -- ^Where to copy the files to - -> FilePath -- ^Build location - -> (FilePath, FilePath) -- ^Executable (prefix,suffix) - -> PackageDescription - -> Executable - -> IO () -installExe verbosity lbi installDirs buildPref (progprefix, progsuffix) _pkg exe = do - let binDir = bindir installDirs - createDirectoryIfMissingVerbose verbosity True binDir - let exeFileName = exeName exe <.> exeExtension - fixedExeBaseName = progprefix ++ exeName exe ++ progsuffix - installBinary dest = do - installExecutableFile verbosity - (buildPref exeName exe exeFileName) - (dest <.> exeExtension) - stripExe verbosity lbi exeFileName (dest <.> exeExtension) - installBinary (binDir fixedExeBaseName) - -stripExe :: Verbosity -> LocalBuildInfo -> FilePath -> FilePath -> IO () -stripExe verbosity lbi name path = when (stripExes lbi) $ - case lookupProgram stripProgram (withPrograms lbi) of - Just strip -> rawSystemProgram verbosity strip args - Nothing -> unless (buildOS == Windows) $ - -- Don't bother warning on windows, we don't expect them to - -- have the strip program anyway. - warn verbosity $ "Unable to strip executable '" ++ name - ++ "' (missing the 'strip' program)" - where - args = path : case buildOS of - OSX -> ["-x"] -- By default, stripping the ghc binary on at least - -- some OS X installations causes: - -- HSbase-3.0.o: unknown symbol `_environ'" - -- The -x flag fixes that. - _ -> [] - --- |Install for ghc, .hi, .a and, if --with-ghci given, .o -installLib :: Verbosity - -> LocalBuildInfo - -> FilePath -- ^install location - -> FilePath -- ^install location for dynamic librarys - -> FilePath -- ^Build location - -> PackageDescription - -> Library - -> IO () -installLib verbosity lbi targetDir dynlibTargetDir builtDir pkg lib = do - -- copy .hi files over: - let copy src dst n = do - createDirectoryIfMissingVerbose verbosity True dst - installOrdinaryFile verbosity (src n) (dst n) - copyModuleFiles ext = - findModuleFiles [builtDir] [ext] (libModules lib) - >>= installOrdinaryFiles verbosity targetDir - ifVanilla $ copyModuleFiles "hi" - ifProf $ copyModuleFiles "p_hi" - hcrFiles <- findModuleFiles (builtDir : hsSourceDirs (libBuildInfo lib)) ["hcr"] (libModules lib) - flip mapM_ hcrFiles $ \(srcBase, srcFile) -> runLhc ["--install-library", srcBase srcFile] - - -- copy the built library files over: - ifVanilla $ copy builtDir targetDir vanillaLibName - ifProf $ copy builtDir targetDir profileLibName - ifGHCi $ copy builtDir targetDir ghciLibName - ifShared $ copy builtDir dynlibTargetDir sharedLibName - - -- run ranlib if necessary: - ifVanilla $ updateLibArchive verbosity lbi - (targetDir vanillaLibName) - ifProf $ updateLibArchive verbosity lbi - (targetDir profileLibName) - - where - vanillaLibName = mkLibName pkgid - profileLibName = mkProfLibName pkgid - ghciLibName = mkGHCiLibName pkgid - sharedLibName = mkSharedLibName pkgid (compilerId (compiler lbi)) - - pkgid = packageId pkg - - hasLib = not $ null (libModules lib) - && null (cSources (libBuildInfo lib)) - ifVanilla = when (hasLib && withVanillaLib lbi) - ifProf = when (hasLib && withProfLib lbi) - ifGHCi = when (hasLib && withGHCiLib lbi) - ifShared = when (hasLib && withSharedLib lbi) - - runLhc = rawSystemProgramConf verbosity lhcProgram (withPrograms lbi) - --- | use @ranlib@ or @ar -s@ to build an index. This is necessary on systems --- like MacOS X. If we can't find those, don't worry too much about it. --- -updateLibArchive :: Verbosity -> LocalBuildInfo -> FilePath -> IO () -updateLibArchive verbosity lbi path = - case lookupProgram ranlibProgram (withPrograms lbi) of - Just ranlib -> rawSystemProgram verbosity ranlib [path] - Nothing -> case lookupProgram arProgram (withPrograms lbi) of - Just ar -> rawSystemProgram verbosity ar ["-s", path] - Nothing -> warn verbosity $ - "Unable to generate a symbol index for the static " - ++ "library '" ++ path - ++ "' (missing the 'ranlib' and 'ar' programs)" - --- ----------------------------------------------------------------------------- --- Registering - -registerPackage - :: Verbosity - -> InstalledPackageInfo - -> PackageDescription - -> LocalBuildInfo - -> Bool - -> PackageDBStack - -> IO () -registerPackage verbosity installedPkgInfo _pkg lbi _inplace packageDbs = do - let Just lhcPkg = lookupProgram lhcPkgProgram (withPrograms lbi) - HcPkg.reregister verbosity lhcPkg packageDbs (Right installedPkgInfo) diff -Nru ghc-7.0.3/libraries/Cabal/Distribution/Simple/LocalBuildInfo.hs ghc-7.2.1/libraries/Cabal/Distribution/Simple/LocalBuildInfo.hs --- ghc-7.0.3/libraries/Cabal/Distribution/Simple/LocalBuildInfo.hs 2011-03-26 18:10:12.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/Distribution/Simple/LocalBuildInfo.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,214 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.LocalBuildInfo --- Copyright : Isaac Jones 2003-2004 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Once a package has been configured we have resolved conditionals and --- dependencies, configured the compiler and other needed external programs. --- The 'LocalBuildInfo' is used to hold all this information. It holds the --- install dirs, the compiler, the exact package dependencies, the configured --- programs, the package database to use and a bunch of miscellaneous configure --- flags. It gets saved and reloaded from a file (@dist\/setup-config@). It gets --- passed in to very many subsequent build actions. - -{- All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - -module Distribution.Simple.LocalBuildInfo ( - LocalBuildInfo(..), - externalPackageDeps, - inplacePackageId, - withLibLBI, - withExeLBI, - withTestLBI, - ComponentLocalBuildInfo(..), - -- * Installation directories - module Distribution.Simple.InstallDirs, - absoluteInstallDirs, prefixRelativeInstallDirs, - substPathTemplate - ) where - - -import Distribution.Simple.InstallDirs hiding (absoluteInstallDirs, - prefixRelativeInstallDirs, - substPathTemplate, ) -import qualified Distribution.Simple.InstallDirs as InstallDirs -import Distribution.Simple.Program (ProgramConfiguration) -import Distribution.PackageDescription - ( PackageDescription(..), withLib, Library, withExe - , Executable(exeName), withTest, TestSuite(..) ) -import Distribution.Package - ( PackageId, Package(..), InstalledPackageId(..) ) -import Distribution.Simple.Compiler - ( Compiler(..), PackageDBStack, OptimisationLevel ) -import Distribution.Simple.PackageIndex - ( PackageIndex ) -import Distribution.Simple.Utils - ( die ) -import Distribution.Simple.Setup - ( ConfigFlags ) -import Distribution.Text - ( display ) - -import Data.List (nub) - --- | Data cached after configuration step. See also --- 'Distribution.Simple.Setup.ConfigFlags'. -data LocalBuildInfo = LocalBuildInfo { - configFlags :: ConfigFlags, - -- ^ Options passed to the configuration step. - -- Needed to re-run configuration when .cabal is out of date - extraConfigArgs :: [String], - -- ^ Extra args on the command line for the configuration step. - -- Needed to re-run configuration when .cabal is out of date - installDirTemplates :: InstallDirTemplates, - -- ^ The installation directories for the various differnt - -- kinds of files - --TODO: inplaceDirTemplates :: InstallDirs FilePath - compiler :: Compiler, - -- ^ The compiler we're building with - buildDir :: FilePath, - -- ^ Where to build the package. - --TODO: eliminate hugs's scratchDir, use builddir - scratchDir :: FilePath, - -- ^ Where to put the result of the Hugs build. - libraryConfig :: Maybe ComponentLocalBuildInfo, - executableConfigs :: [(String, ComponentLocalBuildInfo)], - testSuiteConfigs :: [(String, ComponentLocalBuildInfo)], - installedPkgs :: PackageIndex, - -- ^ All the info about the installed packages that the - -- current package depends on (directly or indirectly). - pkgDescrFile :: Maybe FilePath, - -- ^ the filename containing the .cabal file, if available - localPkgDescr :: PackageDescription, - -- ^ The resolved package description, that does not contain - -- any conditionals. - withPrograms :: ProgramConfiguration, -- ^Location and args for all programs - withPackageDB :: PackageDBStack, -- ^What package database to use, global\/user - withVanillaLib:: Bool, -- ^Whether to build normal libs. - withProfLib :: Bool, -- ^Whether to build profiling versions of libs. - withSharedLib :: Bool, -- ^Whether to build shared versions of libs. - withProfExe :: Bool, -- ^Whether to build executables for profiling. - withOptimization :: OptimisationLevel, -- ^Whether to build with optimization (if available). - withGHCiLib :: Bool, -- ^Whether to build libs suitable for use with GHCi. - splitObjs :: Bool, -- ^Use -split-objs with GHC, if available - stripExes :: Bool, -- ^Whether to strip executables during install - progPrefix :: PathTemplate, -- ^Prefix to be prepended to installed executables - progSuffix :: PathTemplate -- ^Suffix to be appended to installed executables - } deriving (Read, Show) - -data ComponentLocalBuildInfo = ComponentLocalBuildInfo { - -- | Resolved internal and external package dependencies for this component. - -- The 'BuildInfo' specifies a set of build dependencies that must be - -- satisfied in terms of version ranges. This field fixes those dependencies - -- to the specific versions available on this machine for this compiler. - componentPackageDeps :: [(InstalledPackageId, PackageId)] - } - deriving (Read, Show) - --- | External package dependencies for the package as a whole, the union of the --- individual 'targetPackageDeps'. -externalPackageDeps :: LocalBuildInfo -> [(InstalledPackageId, PackageId)] -externalPackageDeps lbi = nub $ - -- TODO: what about non-buildable components? - maybe [] componentPackageDeps (libraryConfig lbi) - ++ concatMap (componentPackageDeps . snd) (executableConfigs lbi) - --- | The installed package Id we use for local packages registered in the local --- package db. This is what is used for intra-package deps between components. --- -inplacePackageId :: PackageId -> InstalledPackageId -inplacePackageId pkgid = InstalledPackageId (display pkgid ++ "-inplace") - --- |If the package description has a library section, call the given --- function with the library build info as argument. Extended version of --- 'withLib' that also gives corresponding build info. -withLibLBI :: PackageDescription -> LocalBuildInfo - -> (Library -> ComponentLocalBuildInfo -> IO ()) -> IO () -withLibLBI pkg_descr lbi f = withLib pkg_descr $ \lib -> - case libraryConfig lbi of - Just clbi -> f lib clbi - Nothing -> die $ "internal error: the package contains a library " - ++ "but there is no corresponding configuration data" - --- | Perform the action on each buildable 'Executable' in the package --- description. Extended version of 'withExe' that also gives corresponding --- build info. -withExeLBI :: PackageDescription -> LocalBuildInfo - -> (Executable -> ComponentLocalBuildInfo -> IO ()) -> IO () -withExeLBI pkg_descr lbi f = withExe pkg_descr $ \exe -> - case lookup (exeName exe) (executableConfigs lbi) of - Just clbi -> f exe clbi - Nothing -> die $ "internal error: the package contains an executable " - ++ exeName exe ++ " but there is no corresponding " - ++ "configuration data" - -withTestLBI :: PackageDescription -> LocalBuildInfo - -> (TestSuite -> ComponentLocalBuildInfo -> IO ()) -> IO () -withTestLBI pkg_descr lbi f = - let wrapper test = case lookup (testName test) (testSuiteConfigs lbi) of - Just clbi -> f test clbi - Nothing -> die $ "internal error: the package contains a test suite " - ++ testName test ++ " but there is no corresponding " - ++ "configuration data" - in withTest pkg_descr wrapper - --- ----------------------------------------------------------------------------- --- Wrappers for a couple functions from InstallDirs - --- |See 'InstallDirs.absoluteInstallDirs' -absoluteInstallDirs :: PackageDescription -> LocalBuildInfo -> CopyDest - -> InstallDirs FilePath -absoluteInstallDirs pkg lbi copydest = - InstallDirs.absoluteInstallDirs - (packageId pkg) - (compilerId (compiler lbi)) - copydest - (installDirTemplates lbi) - --- |See 'InstallDirs.prefixRelativeInstallDirs' -prefixRelativeInstallDirs :: PackageId -> LocalBuildInfo - -> InstallDirs (Maybe FilePath) -prefixRelativeInstallDirs pkg_descr lbi = - InstallDirs.prefixRelativeInstallDirs - (packageId pkg_descr) - (compilerId (compiler lbi)) - (installDirTemplates lbi) - -substPathTemplate :: PackageId -> LocalBuildInfo - -> PathTemplate -> FilePath -substPathTemplate pkgid lbi = fromPathTemplate - . ( InstallDirs.substPathTemplate env ) - where env = initialPathTemplateEnv - pkgid - (compilerId (compiler lbi)) diff -Nru ghc-7.0.3/libraries/Cabal/Distribution/Simple/NHC.hs ghc-7.2.1/libraries/Cabal/Distribution/Simple/NHC.hs --- ghc-7.0.3/libraries/Cabal/Distribution/Simple/NHC.hs 2011-03-26 18:10:12.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/Distribution/Simple/NHC.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,411 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.NHC --- Copyright : Isaac Jones 2003-2006 --- Duncan Coutts 2009 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This module contains most of the NHC-specific code for configuring, building --- and installing packages. - -{- Copyright (c) 2003-2005, Isaac Jones -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - -module Distribution.Simple.NHC ( - configure, - getInstalledPackages, - buildLib, - buildExe, - installLib, - installExe, - ) where - -import Distribution.Package - ( PackageName, PackageIdentifier(..), InstalledPackageId(..) - , packageId, packageName ) -import Distribution.InstalledPackageInfo - ( InstalledPackageInfo - , InstalledPackageInfo_( InstalledPackageInfo, installedPackageId - , sourcePackageId ) - , emptyInstalledPackageInfo, parseInstalledPackageInfo ) -import Distribution.PackageDescription - ( PackageDescription(..), BuildInfo(..), Library(..), Executable(..) - , hcOptions, usedExtensions ) -import Distribution.ModuleName (ModuleName) -import qualified Distribution.ModuleName as ModuleName -import Distribution.Simple.LocalBuildInfo - ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) ) -import Distribution.Simple.BuildPaths - ( mkLibName, objExtension, exeExtension ) -import Distribution.Simple.Compiler - ( CompilerFlavor(..), CompilerId(..), Compiler(..) - , Flag, languageToFlags, extensionsToFlags - , PackageDB(..), PackageDBStack ) -import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Simple.PackageIndex (PackageIndex) -import Language.Haskell.Extension - ( Language(Haskell98), Extension(..) ) -import Distribution.Simple.Program - ( ProgramConfiguration, userMaybeSpecifyPath, programPath - , requireProgram, requireProgramVersion, lookupProgram - , nhcProgram, hmakeProgram, ldProgram, arProgram - , rawSystemProgramConf ) -import Distribution.Simple.Utils - ( die, info, findFileWithExtension, findModuleFiles - , installOrdinaryFile, installExecutableFile, installOrdinaryFiles - , createDirectoryIfMissingVerbose, withUTF8FileContents ) -import Distribution.Version - ( Version(..), orLaterVersion ) -import Distribution.Verbosity -import Distribution.Text - ( display, simpleParse ) -import Distribution.ParseUtils - ( ParseResult(..) ) - -import System.FilePath - ( (), (<.>), normalise, takeDirectory, dropExtension ) -import System.Directory - ( doesFileExist, doesDirectoryExist, getDirectoryContents - , removeFile, getHomeDirectory ) - -import Data.Char ( toLower ) -import Data.List ( nub ) -import Data.Maybe ( catMaybes ) -import Data.Monoid ( Monoid(..) ) -import Control.Monad ( when, unless ) -import Distribution.Compat.Exception - --- ----------------------------------------------------------------------------- --- Configuring - -configure :: Verbosity -> Maybe FilePath -> Maybe FilePath - -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration) -configure verbosity hcPath _hcPkgPath conf = do - - (_nhcProg, nhcVersion, conf') <- - requireProgramVersion verbosity nhcProgram - (orLaterVersion (Version [1,20] [])) - (userMaybeSpecifyPath "nhc98" hcPath conf) - - (_hmakeProg, _hmakeVersion, conf'') <- - requireProgramVersion verbosity hmakeProgram - (orLaterVersion (Version [3,13] [])) conf' - (_ldProg, conf''') <- requireProgram verbosity ldProgram conf'' - (_arProg, conf'''') <- requireProgram verbosity arProgram conf''' - - --TODO: put this stuff in a monad so we can say just: - -- requireProgram hmakeProgram (orLaterVersion (Version [3,13] [])) - -- requireProgram ldProgram anyVersion - -- requireProgram ldPrograrProgramam anyVersion - -- unless (null (cSources bi)) $ requireProgram ccProgram anyVersion - - let comp = Compiler { - compilerId = CompilerId NHC nhcVersion, - compilerLanguages = nhcLanguages, - compilerExtensions = nhcLanguageExtensions - } - return (comp, conf'''') - -nhcLanguages :: [(Language, Flag)] -nhcLanguages = [(Haskell98, "-98")] - --- | The flags for the supported extensions -nhcLanguageExtensions :: [(Extension, Flag)] -nhcLanguageExtensions = - -- NHC doesn't enforce the monomorphism restriction at all. - -- TODO: pattern guards in 1.20 - [(NoMonomorphismRestriction, "") - ,(ForeignFunctionInterface, "") - ,(ExistentialQuantification, "") - ,(EmptyDataDecls, "") - ,(NamedFieldPuns, "-puns") - ,(CPP, "-cpp") - ] - -getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration - -> IO PackageIndex -getInstalledPackages verbosity packagedbs conf = do - homedir <- getHomeDirectory - (nhcProg, _) <- requireProgram verbosity nhcProgram conf - let bindir = takeDirectory (programPath nhcProg) - incdir = takeDirectory bindir "include" "nhc98" - dbdirs = nub (concatMap (packageDbPaths homedir incdir) packagedbs) - indexes <- mapM getIndividualDBPackages dbdirs - return $! mconcat indexes - - where - getIndividualDBPackages :: FilePath -> IO PackageIndex - getIndividualDBPackages dbdir = do - pkgdirs <- getPackageDbDirs dbdir - pkgs <- sequence [ getInstalledPackage pkgname pkgdir - | (pkgname, pkgdir) <- pkgdirs ] - let pkgs' = map setInstalledPackageId (catMaybes pkgs) - return (PackageIndex.fromList pkgs') - -packageDbPaths :: FilePath -> FilePath -> PackageDB -> [FilePath] -packageDbPaths _home incdir db = case db of - GlobalPackageDB -> [ incdir "packages" ] - UserPackageDB -> [] --TODO any standard per-user db? - SpecificPackageDB path -> [ path ] - -getPackageDbDirs :: FilePath -> IO [(PackageName, FilePath)] -getPackageDbDirs dbdir = do - dbexists <- doesDirectoryExist dbdir - if not dbexists - then return [] - else do - entries <- getDirectoryContents dbdir - pkgdirs <- sequence - [ do pkgdirExists <- doesDirectoryExist pkgdir - return (pkgname, pkgdir, pkgdirExists) - | (entry, Just pkgname) <- [ (entry, simpleParse entry) - | entry <- entries ] - , let pkgdir = dbdir entry ] - return [ (pkgname, pkgdir) | (pkgname, pkgdir, True) <- pkgdirs ] - -getInstalledPackage :: PackageName -> FilePath -> IO (Maybe InstalledPackageInfo) -getInstalledPackage pkgname pkgdir = do - let pkgconfFile = pkgdir "package.conf" - pkgconfExists <- doesFileExist pkgconfFile - - let cabalFile = pkgdir <.> "cabal" - cabalExists <- doesFileExist cabalFile - - case () of - _ | pkgconfExists -> getFullInstalledPackageInfo pkgname pkgconfFile - | cabalExists -> getPhonyInstalledPackageInfo pkgname cabalFile - | otherwise -> return Nothing - -getFullInstalledPackageInfo :: PackageName -> FilePath - -> IO (Maybe InstalledPackageInfo) -getFullInstalledPackageInfo pkgname pkgconfFile = - withUTF8FileContents pkgconfFile $ \contents -> - case parseInstalledPackageInfo contents of - ParseOk _ pkginfo | packageName pkginfo == pkgname - -> return (Just pkginfo) - _ -> return Nothing - --- | This is a backup option for existing versions of nhc98 which do not supply --- proper installed package info files for the bundled libs. Instead we look --- for the .cabal file and extract the package version from that. --- We don't know any other details for such packages, in particular we pretend --- that they have no dependencies. --- -getPhonyInstalledPackageInfo :: PackageName -> FilePath - -> IO (Maybe InstalledPackageInfo) -getPhonyInstalledPackageInfo pkgname pathsModule = do - content <- readFile pathsModule - case extractVersion content of - Nothing -> return Nothing - Just version -> return (Just pkginfo) - where - pkgid = PackageIdentifier pkgname version - pkginfo = emptyInstalledPackageInfo { sourcePackageId = pkgid } - where - -- search through the .cabal file, looking for a line like: - -- - -- > version: 2.0 - -- - extractVersion :: String -> Maybe Version - extractVersion content = - case catMaybes (map extractVersionLine (lines content)) of - [version] -> Just version - _ -> Nothing - extractVersionLine :: String -> Maybe Version - extractVersionLine line = - case words line of - [versionTag, ":", versionStr] - | map toLower versionTag == "version" -> simpleParse versionStr - [versionTag, versionStr] - | map toLower versionTag == "version:" -> simpleParse versionStr - _ -> Nothing - --- Older installed package info files did not have the installedPackageId --- field, so if it is missing then we fill it as the source package ID. -setInstalledPackageId :: InstalledPackageInfo -> InstalledPackageInfo -setInstalledPackageId pkginfo@InstalledPackageInfo { - installedPackageId = InstalledPackageId "", - sourcePackageId = pkgid - } - = pkginfo { - --TODO use a proper named function for the conversion - -- from source package id to installed package id - installedPackageId = InstalledPackageId (display pkgid) - } -setInstalledPackageId pkginfo = pkginfo - --- ----------------------------------------------------------------------------- --- Building - --- |FIX: For now, the target must contain a main module. Not used --- ATM. Re-add later. -buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo - -> Library -> ComponentLocalBuildInfo -> IO () -buildLib verbosity pkg_descr lbi lib clbi = do - let conf = withPrograms lbi - Just nhcProg = lookupProgram nhcProgram conf - let bi = libBuildInfo lib - modules = exposedModules lib ++ otherModules bi - -- Unsupported extensions have already been checked by configure - languageFlags = languageToFlags (compiler lbi) (defaultLanguage bi) - ++ extensionsToFlags (compiler lbi) (usedExtensions bi) - inFiles <- getModulePaths lbi bi modules - let targetDir = buildDir lbi - srcDirs = nub (map takeDirectory inFiles) - destDirs = map (targetDir ) srcDirs - mapM_ (createDirectoryIfMissingVerbose verbosity True) destDirs - rawSystemProgramConf verbosity hmakeProgram conf $ - ["-hc=" ++ programPath nhcProg] - ++ nhcVerbosityOptions verbosity - ++ ["-d", targetDir, "-hidir", targetDir] - ++ maybe [] (hcOptions NHC . libBuildInfo) - (library pkg_descr) - ++ languageFlags - ++ concat [ ["-package", display (packageName pkgid) ] - | (_, pkgid) <- componentPackageDeps clbi ] - ++ inFiles -{- - -- build any C sources - unless (null (cSources bi)) $ do - info verbosity "Building C Sources..." - let commonCcArgs = (if verbosity >= deafening then ["-v"] else []) - ++ ["-I" ++ dir | dir <- includeDirs bi] - ++ [opt | opt <- ccOptions bi] - ++ (if withOptimization lbi then ["-O2"] else []) - flip mapM_ (cSources bi) $ \cfile -> do - let ofile = targetDir cfile `replaceExtension` objExtension - createDirectoryIfMissingVerbose verbosity True (takeDirectory ofile) - rawSystemProgramConf verbosity hmakeProgram conf - (commonCcArgs ++ ["-c", cfile, "-o", ofile]) --} - -- link: - info verbosity "Linking..." - let --cObjs = [ targetDir cFile `replaceExtension` objExtension - -- | cFile <- cSources bi ] - libFilePath = targetDir mkLibName (packageId pkg_descr) - hObjs = [ targetDir ModuleName.toFilePath m <.> objExtension - | m <- modules ] - - unless (null hObjs {-&& null cObjs-}) $ do - -- first remove library if it exists - removeFile libFilePath `catchIO` \_ -> return () - - let arVerbosity | verbosity >= deafening = "v" - | verbosity >= normal = "" - | otherwise = "c" - - rawSystemProgramConf verbosity arProgram (withPrograms lbi) $ - ["q"++ arVerbosity, libFilePath] - ++ hObjs --- ++ cObjs - --- | Building an executable for NHC. -buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo - -> Executable -> ComponentLocalBuildInfo -> IO () -buildExe verbosity pkg_descr lbi exe clbi = do - let conf = withPrograms lbi - Just nhcProg = lookupProgram nhcProgram conf - when (dropExtension (modulePath exe) /= exeName exe) $ - die $ "hmake does not support exe names that do not match the name of " - ++ "the 'main-is' file. You will have to rename your executable to " - ++ show (dropExtension (modulePath exe)) - let bi = buildInfo exe - modules = otherModules bi - -- Unsupported extensions have already been checked by configure - languageFlags = languageToFlags (compiler lbi) (defaultLanguage bi) - ++ extensionsToFlags (compiler lbi) (usedExtensions bi) - inFiles <- getModulePaths lbi bi modules - let targetDir = buildDir lbi exeName exe - exeDir = targetDir (exeName exe ++ "-tmp") - srcDirs = nub (map takeDirectory (modulePath exe : inFiles)) - destDirs = map (exeDir ) srcDirs - mapM_ (createDirectoryIfMissingVerbose verbosity True) destDirs - rawSystemProgramConf verbosity hmakeProgram conf $ - ["-hc=" ++ programPath nhcProg] - ++ nhcVerbosityOptions verbosity - ++ ["-d", targetDir, "-hidir", targetDir] - ++ maybe [] (hcOptions NHC . libBuildInfo) - (library pkg_descr) - ++ languageFlags - ++ concat [ ["-package", display (packageName pkgid) ] - | (_, pkgid) <- componentPackageDeps clbi ] - ++ inFiles - ++ [exeName exe] - -nhcVerbosityOptions :: Verbosity -> [String] -nhcVerbosityOptions verbosity - | verbosity >= deafening = ["-v"] - | verbosity >= normal = [] - | otherwise = ["-q"] - ---TODO: where to put this? it's duplicated in .Simple too -getModulePaths :: LocalBuildInfo -> BuildInfo -> [ModuleName] -> IO [FilePath] -getModulePaths lbi bi modules = sequence - [ findFileWithExtension ["hs", "lhs"] (buildDir lbi : hsSourceDirs bi) - (ModuleName.toFilePath module_) >>= maybe (notFound module_) (return . normalise) - | module_ <- modules ] - where notFound module_ = die $ "can't find source for module " ++ display module_ - --- ----------------------------------------------------------------------------- --- Installing - --- |Install executables for NHC. -installExe :: Verbosity -- ^verbosity - -> FilePath -- ^install location - -> FilePath -- ^Build location - -> (FilePath, FilePath) -- ^Executable (prefix,suffix) - -> Executable - -> IO () -installExe verbosity pref buildPref (progprefix,progsuffix) exe - = do createDirectoryIfMissingVerbose verbosity True pref - let exeBaseName = exeName exe - exeFileName = exeBaseName <.> exeExtension - fixedExeFileName = (progprefix ++ exeBaseName ++ progsuffix) <.> exeExtension - installExecutableFile verbosity - (buildPref exeBaseName exeFileName) - (pref fixedExeFileName) - --- |Install for nhc98: .hi and .a files -installLib :: Verbosity -- ^verbosity - -> FilePath -- ^install location - -> FilePath -- ^Build location - -> PackageIdentifier - -> Library - -> IO () -installLib verbosity pref buildPref pkgid lib - = do let bi = libBuildInfo lib - modules = exposedModules lib ++ otherModules bi - findModuleFiles [buildPref] ["hi"] modules - >>= installOrdinaryFiles verbosity pref - let libName = mkLibName pkgid - installOrdinaryFile verbosity (buildPref libName) (pref libName) diff -Nru ghc-7.0.3/libraries/Cabal/Distribution/Simple/PackageIndex.hs ghc-7.2.1/libraries/Cabal/Distribution/Simple/PackageIndex.hs --- ghc-7.0.3/libraries/Cabal/Distribution/Simple/PackageIndex.hs 2011-03-26 18:10:12.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/Distribution/Simple/PackageIndex.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,562 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.PackageIndex --- Copyright : (c) David Himmelstrup 2005, --- Bjorn Bringert 2007, --- Duncan Coutts 2008-2009 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- An index of packages. --- -module Distribution.Simple.PackageIndex ( - -- * Package index data type - PackageIndex, - - -- * Creating an index - fromList, - - -- * Updates - merge, - - insert, - - deleteInstalledPackageId, - deleteSourcePackageId, - deletePackageName, --- deleteDependency, - - -- * Queries - - -- ** Precise lookups - lookupInstalledPackageId, - lookupSourcePackageId, - lookupPackageName, - lookupDependency, - - -- ** Case-insensitive searches - searchByName, - SearchResult(..), - searchByNameSubstring, - - -- ** Bulk queries - allPackages, - allPackagesByName, - - -- ** Special queries - brokenPackages, - dependencyClosure, - reverseDependencyClosure, - topologicalOrder, - reverseTopologicalOrder, - dependencyInconsistencies, - dependencyCycles, - dependencyGraph, - moduleNameIndex, - ) where - -import Prelude hiding (lookup) -import Control.Exception (assert) -import qualified Data.Map as Map -import Data.Map (Map) -import qualified Data.Tree as Tree -import qualified Data.Graph as Graph -import qualified Data.Array as Array -import Data.Array ((!)) -import Data.List as List - ( null, foldl', sort - , groupBy, sortBy, find, isInfixOf, nubBy, deleteBy, deleteFirstsBy ) -import Data.Monoid (Monoid(..)) -import Data.Maybe (isNothing, fromMaybe) - -import Distribution.Package - ( PackageName(..), PackageId - , Package(..), packageName, packageVersion - , Dependency(Dependency)--, --PackageFixedDeps(..) - , InstalledPackageId(..) ) -import Distribution.ModuleName - ( ModuleName ) -import Distribution.InstalledPackageInfo - ( InstalledPackageInfo, installedPackageId ) -import qualified Distribution.InstalledPackageInfo as IPI -import Distribution.Version - ( Version, withinRange ) -import Distribution.Simple.Utils (lowercase, comparing, equating) - - --- | The collection of information about packages from one or more 'PackageDB's. --- --- Packages are uniquely identified in by their 'InstalledPackageId', they can --- also be effeciently looked up by package name or by name and version. --- -data PackageIndex = PackageIndex - -- The primary index. Each InstalledPackageInfo record is uniquely identified - -- by its InstalledPackageId. - -- - !(Map InstalledPackageId InstalledPackageInfo) - - -- This auxillary index maps package names (case-sensitively) to all the - -- versions and instances of that package. This allows us to find all - -- versions satisfying a dependency. - -- - -- It is a three-level index. The first level is the package name, - -- the second is the package version and the final level is instances - -- of the same package version. These are unique by InstalledPackageId - -- and are kept in preference order. - -- - !(Map PackageName (Map Version [InstalledPackageInfo])) - - deriving (Show, Read) - -instance Monoid PackageIndex where - mempty = PackageIndex Map.empty Map.empty - mappend = merge - --save one mappend with empty in the common case: - mconcat [] = mempty - mconcat xs = foldr1 mappend xs - -invariant :: PackageIndex -> Bool -invariant (PackageIndex pids pnames) = - map installedPackageId (Map.elems pids) - == sort - [ assert pinstOk (installedPackageId pinst) - | (pname, pvers) <- Map.toList pnames - , let pversOk = not (Map.null pvers) - , (pver, pinsts) <- assert pversOk $ Map.toList pvers - , let pinsts' = sortBy (comparing installedPackageId) pinsts - pinstsOk = all (\g -> length g == 1) - (groupBy (equating installedPackageId) pinsts') - , pinst <- assert pinstsOk $ pinsts' - , let pinstOk = packageName pinst == pname - && packageVersion pinst == pver - ] - - --- --- * Internal helpers --- - -mkPackageIndex :: Map InstalledPackageId InstalledPackageInfo - -> Map PackageName (Map Version [InstalledPackageInfo]) - -> PackageIndex -mkPackageIndex pids pnames = assert (invariant index) index - where index = PackageIndex pids pnames - - --- --- * Construction --- - --- | Build an index out of a bunch of packages. --- --- If there are duplicates by 'InstalledPackageId' then later ones mask earlier --- ones. --- -fromList :: [InstalledPackageInfo] -> PackageIndex -fromList pkgs = mkPackageIndex pids pnames - where - pids = Map.fromList [ (installedPackageId pkg, pkg) | pkg <- pkgs ] - pnames = - Map.fromList - [ (packageName (head pkgsN), pvers) - | pkgsN <- groupBy (equating packageName) - . sortBy (comparing packageId) - $ pkgs - , let pvers = - Map.fromList - [ (packageVersion (head pkgsNV), - nubBy (equating installedPackageId) (reverse pkgsNV)) - | pkgsNV <- groupBy (equating packageVersion) pkgsN - ] - ] - --- --- * Updates --- - --- | Merge two indexes. --- --- Packages from the second mask packages from the first if they have the exact --- same 'InstalledPackageId'. --- --- For packages with the same source 'PackageId', packages from the second are --- \"preferred\" over those from the first. Being preferred means they are top --- result when we do a lookup by source 'PackageId'. This is the mechanism we --- use to prefer user packages over global packages. --- -merge :: PackageIndex -> PackageIndex -> PackageIndex -merge (PackageIndex pids1 pnames1) (PackageIndex pids2 pnames2) = - mkPackageIndex (Map.union pids1 pids2) - (Map.unionWith (Map.unionWith mergeBuckets) pnames1 pnames2) - where - -- Packages in the second list mask those in the first, however preferred - -- packages go first in the list. - mergeBuckets xs ys = ys ++ (xs \\ ys) - (\\) = deleteFirstsBy (equating installedPackageId) - - --- | Inserts a single package into the index. --- --- This is equivalent to (but slightly quicker than) using 'mappend' or --- 'merge' with a singleton index. --- -insert :: InstalledPackageInfo -> PackageIndex -> PackageIndex -insert pkg (PackageIndex pids pnames) = - mkPackageIndex pids' pnames' - - where - pids' = Map.insert (installedPackageId pkg) pkg pids - pnames' = insertPackageName pnames - insertPackageName = - Map.insertWith' (\_ -> insertPackageVersion) - (packageName pkg) - (Map.singleton (packageVersion pkg) [pkg]) - - insertPackageVersion = - Map.insertWith' (\_ -> insertPackageInstance) - (packageVersion pkg) [pkg] - - insertPackageInstance pkgs = - pkg : deleteBy (equating installedPackageId) pkg pkgs - - --- | Removes a single installed package from the index. --- -deleteInstalledPackageId :: InstalledPackageId -> PackageIndex -> PackageIndex -deleteInstalledPackageId ipkgid original@(PackageIndex pids pnames) = - case Map.updateLookupWithKey (\_ _ -> Nothing) ipkgid pids of - (Nothing, _) -> original - (Just spkgid, pids') -> mkPackageIndex pids' - (deletePkgName spkgid pnames) - - where - deletePkgName spkgid = - Map.update (deletePkgVersion spkgid) (packageName spkgid) - - deletePkgVersion spkgid = - (\m -> if Map.null m then Nothing else Just m) - . Map.update deletePkgInstance (packageVersion spkgid) - - deletePkgInstance = - (\xs -> if List.null xs then Nothing else Just xs) - . List.deleteBy (\_ pkg -> installedPackageId pkg == ipkgid) undefined - - --- | Removes all packages with this source 'PackageId' from the index. --- -deleteSourcePackageId :: PackageId -> PackageIndex -> PackageIndex -deleteSourcePackageId pkgid original@(PackageIndex pids pnames) = - case Map.lookup (packageName pkgid) pnames of - Nothing -> original - Just pvers -> case Map.lookup (packageVersion pkgid) pvers of - Nothing -> original - Just pkgs -> mkPackageIndex - (foldl' (flip (Map.delete . installedPackageId)) pids pkgs) - (deletePkgName pnames) - where - deletePkgName = - Map.update deletePkgVersion (packageName pkgid) - - deletePkgVersion = - (\m -> if Map.null m then Nothing else Just m) - . Map.delete (packageVersion pkgid) - - --- | Removes all packages with this (case-sensitive) name from the index. --- -deletePackageName :: PackageName -> PackageIndex -> PackageIndex -deletePackageName name original@(PackageIndex pids pnames) = - case Map.lookup name pnames of - Nothing -> original - Just pvers -> mkPackageIndex - (foldl' (flip (Map.delete . installedPackageId)) pids - (concat (Map.elems pvers))) - (Map.delete name pnames) - -{- --- | Removes all packages satisfying this dependency from the index. --- -deleteDependency :: Dependency -> PackageIndex -> PackageIndex -deleteDependency (Dependency name verstionRange) = - delete' name (\pkg -> packageVersion pkg `withinRange` verstionRange) --} - --- --- * Bulk queries --- - --- | Get all the packages from the index. --- -allPackages :: PackageIndex -> [InstalledPackageInfo] -allPackages (PackageIndex pids _) = Map.elems pids - --- | Get all the packages from the index. --- --- They are grouped by package name, case-sensitively. --- -allPackagesByName :: PackageIndex -> [[InstalledPackageInfo]] -allPackagesByName (PackageIndex _ pnames) = - concatMap Map.elems (Map.elems pnames) - --- --- * Lookups --- - --- | Does a lookup by source package id (name & version). --- --- Since multiple package DBs mask each other by 'InstalledPackageId', --- then we get back at most one package. --- -lookupInstalledPackageId :: PackageIndex -> InstalledPackageId - -> Maybe InstalledPackageInfo -lookupInstalledPackageId (PackageIndex pids _) pid = Map.lookup pid pids - - --- | Does a lookup by source package id (name & version). --- --- There can be multiple installed packages with the same source 'PackageId' --- but different 'InstalledPackageId'. They are returned in order of --- preference, with the most preferred first. --- -lookupSourcePackageId :: PackageIndex -> PackageId -> [InstalledPackageInfo] -lookupSourcePackageId (PackageIndex _ pnames) pkgid = - case Map.lookup (packageName pkgid) pnames of - Nothing -> [] - Just pvers -> case Map.lookup (packageVersion pkgid) pvers of - Nothing -> [] - Just pkgs -> pkgs -- in preference order - - --- | Does a lookup by source package name. --- -lookupPackageName :: PackageIndex -> PackageName - -> [(Version, [InstalledPackageInfo])] -lookupPackageName (PackageIndex _ pnames) name = - case Map.lookup name pnames of - Nothing -> [] - Just pvers -> Map.toList pvers - - --- | Does a lookup by source package name and a range of versions. --- --- We get back any number of versions of the specified package name, all --- satisfying the version range constraint. --- -lookupDependency :: PackageIndex -> Dependency - -> [(Version, [InstalledPackageInfo])] -lookupDependency (PackageIndex _ pnames) (Dependency name versionRange) = - case Map.lookup name pnames of - Nothing -> [] - Just pvers -> [ entry - | entry@(ver, _) <- Map.toList pvers - , ver `withinRange` versionRange ] - --- --- * Case insensitive name lookups --- - --- | Does a case-insensitive search by package name. --- --- If there is only one package that compares case-insentiviely to this name --- then the search is unambiguous and we get back all versions of that package. --- If several match case-insentiviely but one matches exactly then it is also --- unambiguous. --- --- If however several match case-insentiviely and none match exactly then we --- have an ambiguous result, and we get back all the versions of all the --- packages. The list of ambiguous results is split by exact package name. So --- it is a non-empty list of non-empty lists. --- -searchByName :: PackageIndex -> String -> SearchResult [InstalledPackageInfo] -searchByName (PackageIndex _ pnames) name = - case [ pkgs | pkgs@(PackageName name',_) <- Map.toList pnames - , lowercase name' == lname ] of - [] -> None - [(_,pvers)] -> Unambiguous (concat (Map.elems pvers)) - pkgss -> case find ((PackageName name==) . fst) pkgss of - Just (_,pvers) -> Unambiguous (concat (Map.elems pvers)) - Nothing -> Ambiguous (map (concat . Map.elems . snd) pkgss) - where lname = lowercase name - -data SearchResult a = None | Unambiguous a | Ambiguous [a] - --- | Does a case-insensitive substring search by package name. --- --- That is, all packages that contain the given string in their name. --- -searchByNameSubstring :: PackageIndex -> String -> [InstalledPackageInfo] -searchByNameSubstring (PackageIndex _ pnames) searchterm = - [ pkg - | (PackageName name, pvers) <- Map.toList pnames - , lsearchterm `isInfixOf` lowercase name - , pkgs <- Map.elems pvers - , pkg <- pkgs ] - where lsearchterm = lowercase searchterm - - --- --- * Special queries --- - --- None of the stuff below depends on the internal representation of the index. --- - --- | Find if there are any cycles in the dependency graph. If there are no --- cycles the result is @[]@. --- --- This actually computes the strongly connected components. So it gives us a --- list of groups of packages where within each group they all depend on each --- other, directly or indirectly. --- -dependencyCycles :: PackageIndex -> [[InstalledPackageInfo]] -dependencyCycles index = - [ vs | Graph.CyclicSCC vs <- Graph.stronglyConnComp adjacencyList ] - where - adjacencyList = [ (pkg, installedPackageId pkg, IPI.depends pkg) - | pkg <- allPackages index ] - - --- | All packages that have immediate dependencies that are not in the index. --- --- Returns such packages along with the dependencies that they're missing. --- -brokenPackages :: PackageIndex -> [(InstalledPackageInfo, [InstalledPackageId])] -brokenPackages index = - [ (pkg, missing) - | pkg <- allPackages index - , let missing = [ pkg' | pkg' <- IPI.depends pkg - , isNothing (lookupInstalledPackageId index pkg') ] - , not (null missing) ] - - --- | Tries to take the transitive closure of the package dependencies. --- --- If the transitive closure is complete then it returns that subset of the --- index. Otherwise it returns the broken packages as in 'brokenPackages'. --- --- * Note that if the result is @Right []@ it is because at least one of --- the original given 'PackageId's do not occur in the index. --- -dependencyClosure :: PackageIndex - -> [InstalledPackageId] - -> Either PackageIndex - [(InstalledPackageInfo, [InstalledPackageId])] -dependencyClosure index pkgids0 = case closure mempty [] pkgids0 of - (completed, []) -> Left completed - (completed, _) -> Right (brokenPackages completed) - where - closure completed failed [] = (completed, failed) - closure completed failed (pkgid:pkgids) = case lookupInstalledPackageId index pkgid of - Nothing -> closure completed (pkgid:failed) pkgids - Just pkg -> case lookupInstalledPackageId completed (installedPackageId pkg) of - Just _ -> closure completed failed pkgids - Nothing -> closure completed' failed pkgids' - where completed' = insert pkg completed - pkgids' = IPI.depends pkg ++ pkgids - --- | Takes the transitive closure of the packages reverse dependencies. --- --- * The given 'PackageId's must be in the index. --- -reverseDependencyClosure :: PackageIndex - -> [InstalledPackageId] - -> [InstalledPackageInfo] -reverseDependencyClosure index = - map vertexToPkg - . concatMap Tree.flatten - . Graph.dfs reverseDepGraph - . map (fromMaybe noSuchPkgId . pkgIdToVertex) - - where - (depGraph, vertexToPkg, pkgIdToVertex) = dependencyGraph index - reverseDepGraph = Graph.transposeG depGraph - noSuchPkgId = error "reverseDependencyClosure: package is not in the graph" - -topologicalOrder :: PackageIndex -> [InstalledPackageInfo] -topologicalOrder index = map toPkgId - . Graph.topSort - $ graph - where (graph, toPkgId, _) = dependencyGraph index - -reverseTopologicalOrder :: PackageIndex -> [InstalledPackageInfo] -reverseTopologicalOrder index = map toPkgId - . Graph.topSort - . Graph.transposeG - $ graph - where (graph, toPkgId, _) = dependencyGraph index - --- | Builds a graph of the package dependencies. --- --- Dependencies on other packages that are not in the index are discarded. --- You can check if there are any such dependencies with 'brokenPackages'. --- -dependencyGraph :: PackageIndex - -> (Graph.Graph, - Graph.Vertex -> InstalledPackageInfo, - InstalledPackageId -> Maybe Graph.Vertex) -dependencyGraph index = (graph, vertex_to_pkg, id_to_vertex) - where - graph = Array.listArray bounds - [ [ v | Just v <- map id_to_vertex (IPI.depends pkg) ] - | pkg <- pkgs ] - - pkgs = sortBy (comparing packageId) (allPackages index) - vertices = zip (map installedPackageId pkgs) [0..] - vertex_map = Map.fromList vertices - id_to_vertex pid = Map.lookup pid vertex_map - - vertex_to_pkg vertex = pkgTable ! vertex - - pkgTable = Array.listArray bounds pkgs - topBound = length pkgs - 1 - bounds = (0, topBound) - --- | Given a package index where we assume we want to use all the packages --- (use 'dependencyClosure' if you need to get such a index subset) find out --- if the dependencies within it use consistent versions of each package. --- Return all cases where multiple packages depend on different versions of --- some other package. --- --- Each element in the result is a package name along with the packages that --- depend on it and the versions they require. These are guaranteed to be --- distinct. --- -dependencyInconsistencies :: PackageIndex - -> [(PackageName, [(PackageId, Version)])] -dependencyInconsistencies index = - [ (name, [ (pid,packageVersion dep) | (dep,pids) <- uses, pid <- pids]) - | (name, ipid_map) <- Map.toList inverseIndex - , let uses = Map.elems ipid_map - , reallyIsInconsistent (map fst uses) ] - - where -- for each PackageName, - -- for each package with that name, - -- the InstalledPackageInfo and the package Ids of packages - -- that depend on it. - inverseIndex :: Map PackageName - (Map InstalledPackageId - (InstalledPackageInfo, [PackageId])) - inverseIndex = Map.fromListWith (Map.unionWith (\(a,b) (_,b') -> (a,b++b'))) - [ (packageName dep, - Map.fromList [(ipid,(dep,[packageId pkg]))]) - | pkg <- allPackages index - , ipid <- IPI.depends pkg - , Just dep <- [lookupInstalledPackageId index ipid] - ] - - reallyIsInconsistent :: [InstalledPackageInfo] -> Bool - reallyIsInconsistent [] = False - reallyIsInconsistent [_p] = False - reallyIsInconsistent [p1, p2] = - installedPackageId p1 `notElem` IPI.depends p2 - && installedPackageId p2 `notElem` IPI.depends p1 - reallyIsInconsistent _ = True - - -moduleNameIndex :: PackageIndex -> Map ModuleName [InstalledPackageInfo] -moduleNameIndex index = - Map.fromListWith (++) - [ (moduleName, [pkg]) - | pkg <- allPackages index - , moduleName <- IPI.exposedModules pkg ] diff -Nru ghc-7.0.3/libraries/Cabal/Distribution/Simple/PreProcess/Unlit.hs ghc-7.2.1/libraries/Cabal/Distribution/Simple/PreProcess/Unlit.hs --- ghc-7.0.3/libraries/Cabal/Distribution/Simple/PreProcess/Unlit.hs 2011-03-26 18:10:12.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/Distribution/Simple/PreProcess/Unlit.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,165 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.PreProcess.Unlit --- Copyright : ... --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Remove the \"literal\" markups from a Haskell source file, including --- \"@>@\", \"@\\begin{code}@\", \"@\\end{code}@\", and \"@#@\" - --- This version is interesting because instead of striping comment lines, it --- turns them into "-- " style comments. This allows using haddock markup --- in literate scripts without having to use "> --" prefix. - -module Distribution.Simple.PreProcess.Unlit (unlit,plain) where - -import Data.Char -import Data.List - -data Classified = BirdTrack String | Blank String | Ordinary String - | Line !Int String | CPP String - | BeginCode | EndCode - -- output only: - | Error String | Comment String - --- | No unliteration. -plain :: String -> String -> String -plain _ hs = hs - -classify :: String -> Classified -classify ('>':s) = BirdTrack s -classify ('#':s) = case tokens s of - (line:file:_) | all isDigit line - && length file >= 2 - && head file == '"' - && last file == '"' - -> Line (read line) (tail (init file)) - _ -> CPP s - where tokens = unfoldr $ \str -> case lex str of - (t@(_:_), str'):_ -> Just (t, str') - _ -> Nothing -classify ('\\':s) - | "begin{code}" `isPrefixOf` s = BeginCode - | "end{code}" `isPrefixOf` s = EndCode -classify s | all isSpace s = Blank s -classify s = Ordinary s - --- So the weird exception for comment indenting is to make things work with --- haddock, see classifyAndCheckForBirdTracks below. -unclassify :: Bool -> Classified -> String -unclassify _ (BirdTrack s) = ' ':s -unclassify _ (Blank s) = s -unclassify _ (Ordinary s) = s -unclassify _ (Line n file) = "# " ++ show n ++ " " ++ show file -unclassify _ (CPP s) = '#':s -unclassify True (Comment "") = " --" -unclassify True (Comment s) = " -- " ++ s -unclassify False (Comment "") = "--" -unclassify False (Comment s) = "-- " ++ s -unclassify _ _ = internalError - --- | 'unlit' takes a filename (for error reports), and transforms the --- given string, to eliminate the literate comments from the program text. -unlit :: FilePath -> String -> Either String String -unlit file input = - let (usesBirdTracks, classified) = classifyAndCheckForBirdTracks - . inlines - $ input - in either (Left . unlines . map (unclassify usesBirdTracks)) - Right - . checkErrors - . reclassify - $ classified - - where - -- So haddock requires comments and code to align, since it treats comments - -- as following the layout rule. This is a pain for us since bird track - -- style literate code typically gets indented by two since ">" is replaced - -- by " " and people usually use one additional space of indent ie - -- "> then the code". On the other hand we cannot just go and indent all - -- the comments by two since that does not work for latex style literate - -- code. So the hacky solution we use here is that if we see any bird track - -- style code then we'll indent all comments by two, otherwise by none. - -- Of course this will not work for mixed latex/bird track .lhs files but - -- nobody does that, it's silly and specifically recommended against in the - -- H98 unlit spec. - -- - classifyAndCheckForBirdTracks = - flip mapAccumL False $ \seenBirdTrack line -> - let classification = classify line - in (seenBirdTrack || isBirdTrack classification, classification) - - isBirdTrack (BirdTrack _) = True - isBirdTrack _ = False - - checkErrors ls = case [ e | Error e <- ls ] of - [] -> Left ls - (message:_) -> Right (f ++ ":" ++ show n ++ ": " ++ message) - where (f, n) = errorPos file 1 ls - errorPos f n [] = (f, n) - errorPos f n (Error _:_) = (f, n) - errorPos _ _ (Line n' f':ls) = errorPos f' n' ls - errorPos f n (_ :ls) = errorPos f (n+1) ls - --- Here we model a state machine, with each state represented by --- a local function. We only have four states (well, five, --- if you count the error state), but the rules --- to transition between then are not so simple. --- Would it be simpler to have more states? --- --- Each state represents the type of line that was last read --- i.e. are we in a comment section, or a latex-code section, --- or a bird-code section, etc? -reclassify :: [Classified] -> [Classified] -reclassify = blank -- begin in blank state - where - latex [] = [] - latex (EndCode :ls) = Blank "" : comment ls - latex (BeginCode :_ ) = [Error "\\begin{code} in code section"] - latex (BirdTrack l:ls) = Ordinary ('>':l) : latex ls - latex ( l:ls) = l : latex ls - - blank [] = [] - blank (EndCode :_ ) = [Error "\\end{code} without \\begin{code}"] - blank (BeginCode :ls) = Blank "" : latex ls - blank (BirdTrack l:ls) = BirdTrack l : bird ls - blank (Ordinary l:ls) = Comment l : comment ls - blank ( l:ls) = l : blank ls - - bird [] = [] - bird (EndCode :_ ) = [Error "\\end{code} without \\begin{code}"] - bird (BeginCode :ls) = Blank "" : latex ls - bird (Blank l :ls) = Blank l : blank ls - bird (Ordinary _:_ ) = [Error "program line before comment line"] - bird ( l:ls) = l : bird ls - - comment [] = [] - comment (EndCode :_ ) = [Error "\\end{code} without \\begin{code}"] - comment (BeginCode :ls) = Blank "" : latex ls - comment (CPP l :ls) = CPP l : comment ls - comment (BirdTrack _:_ ) = [Error "comment line before program line"] - -- a blank line and another ordinary line following a comment - -- will be treated as continuing the comment. Otherwise it's - -- then end of the comment, with a blank line. - comment (Blank l:ls@(Ordinary _:_)) = Comment l : comment ls - comment (Blank l:ls) = Blank l : blank ls - comment (Line n f :ls) = Line n f : comment ls - comment (Ordinary l:ls) = Comment l : comment ls - comment (Comment _: _) = internalError - comment (Error _: _) = internalError - --- Re-implementation of 'lines', for better efficiency (but decreased laziness). --- Also, importantly, accepts non-standard DOS and Mac line ending characters. -inlines :: String -> [String] -inlines xs = lines' xs id - where - lines' [] acc = [acc []] - lines' ('\^M':'\n':s) acc = acc [] : lines' s id -- DOS - lines' ('\^M':s) acc = acc [] : lines' s id -- MacOS - lines' ('\n':s) acc = acc [] : lines' s id -- Unix - lines' (c:s) acc = lines' s (acc . (c:)) - -internalError :: a -internalError = error "unlit: internal error" diff -Nru ghc-7.0.3/libraries/Cabal/Distribution/Simple/PreProcess.hs ghc-7.2.1/libraries/Cabal/Distribution/Simple/PreProcess.hs --- ghc-7.0.3/libraries/Cabal/Distribution/Simple/PreProcess.hs 2011-03-26 18:10:12.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/Distribution/Simple/PreProcess.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,598 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.PreProcess --- Copyright : (c) 2003-2005, Isaac Jones, Malcolm Wallace --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This defines a 'PreProcessor' abstraction which represents a pre-processor --- that can transform one kind of file into another. There is also a --- 'PPSuffixHandler' which is a combination of a file extension and a function --- for configuring a 'PreProcessor'. It defines a bunch of known built-in --- preprocessors like @cpp@, @cpphs@, @c2hs@, @hsc2hs@, @happy@, @alex@ etc and --- lists them in 'knownSuffixHandlers'. On top of this it provides a function --- for actually preprocessing some sources given a bunch of known suffix --- handlers. This module is not as good as it could be, it could really do with --- a rewrite to address some of the problems we have with pre-processors. - -{- Copyright (c) 2003-2005, Isaac Jones, Malcolm Wallace -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - -module Distribution.Simple.PreProcess (preprocessSources, knownSuffixHandlers, - ppSuffixes, PPSuffixHandler, PreProcessor(..), - mkSimplePreProcessor, runSimplePreProcessor, - ppCpp, ppCpp', ppGreenCard, ppC2hs, ppHsc2hs, - ppHappy, ppAlex, ppUnlit - ) - where - - -import Distribution.Simple.PreProcess.Unlit (unlit) -import Distribution.Package - ( Package(..), PackageName(..) ) -import qualified Distribution.ModuleName as ModuleName -import Distribution.PackageDescription as PD - ( PackageDescription(..), BuildInfo(..), Executable(..), withExe - , Library(..), withLib, libModules - , TestSuite(..), withTest, testModules - , TestSuiteInterface(..) ) -import qualified Distribution.InstalledPackageInfo as Installed - ( InstalledPackageInfo_(..) ) -import qualified Distribution.Simple.PackageIndex as PackageIndex -import Distribution.Simple.Compiler - ( CompilerFlavor(..), Compiler(..), compilerFlavor, compilerVersion ) -import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..)) -import Distribution.Simple.BuildPaths (autogenModulesDir,cppHeaderName) -import Distribution.Simple.Utils - ( createDirectoryIfMissingVerbose, withUTF8FileContents, writeUTF8File - , die, setupMessage, intercalate, copyFileVerbose - , findFileWithExtension, findFileWithExtension' ) -import Distribution.Simple.Program - ( Program(..), ConfiguredProgram(..), programPath - , lookupProgram, requireProgram, requireProgramVersion - , rawSystemProgramConf, rawSystemProgram - , greencardProgram, cpphsProgram, hsc2hsProgram, c2hsProgram - , happyProgram, alexProgram, haddockProgram, ghcProgram, gccProgram ) -import Distribution.Simple.Test ( writeSimpleTestStub, stubFilePath, stubName ) -import Distribution.System - ( OS(OSX, Windows), buildOS ) -import Distribution.Text -import Distribution.Version - ( Version(..), anyVersion, orLaterVersion ) -import Distribution.Verbosity - -import Control.Monad (when, unless) -import Data.Maybe (fromMaybe) -import Data.List (nub) -import System.Directory (getModificationTime, doesFileExist) -import System.Info (os, arch) -import System.FilePath (splitExtension, dropExtensions, (), (<.>), - takeDirectory, normalise, replaceExtension) - --- |The interface to a preprocessor, which may be implemented using an --- external program, but need not be. The arguments are the name of --- the input file, the name of the output file and a verbosity level. --- Here is a simple example that merely prepends a comment to the given --- source file: --- --- > ppTestHandler :: PreProcessor --- > ppTestHandler = --- > PreProcessor { --- > platformIndependent = True, --- > runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> --- > do info verbosity (inFile++" has been preprocessed to "++outFile) --- > stuff <- readFile inFile --- > writeFile outFile ("-- preprocessed as a test\n\n" ++ stuff) --- > return ExitSuccess --- --- We split the input and output file names into a base directory and the --- rest of the file name. The input base dir is the path in the list of search --- dirs that this file was found in. The output base dir is the build dir where --- all the generated source files are put. --- --- The reason for splitting it up this way is that some pre-processors don't --- simply generate one output .hs file from one input file but have --- dependencies on other genereated files (notably c2hs, where building one --- .hs file may require reading other .chi files, and then compiling the .hs --- file may require reading a generated .h file). In these cases the generated --- files need to embed relative path names to each other (eg the generated .hs --- file mentions the .h file in the FFI imports). This path must be relative to --- the base directory where the genereated files are located, it cannot be --- relative to the top level of the build tree because the compilers do not --- look for .h files relative to there, ie we do not use \"-I .\", instead we --- use \"-I dist\/build\" (or whatever dist dir has been set by the user) --- --- Most pre-processors do not care of course, so mkSimplePreProcessor and --- runSimplePreProcessor functions handle the simple case. --- -data PreProcessor = PreProcessor { - - -- Is the output of the pre-processor platform independent? eg happy output - -- is portable haskell but c2hs's output is platform dependent. - -- This matters since only platform independent generated code can be - -- inlcuded into a source tarball. - platformIndependent :: Bool, - - -- TODO: deal with pre-processors that have implementaion dependent output - -- eg alex and happy have --ghc flags. However we can't really inlcude - -- ghc-specific code into supposedly portable source tarballs. - - runPreProcessor :: (FilePath, FilePath) -- Location of the source file relative to a base dir - -> (FilePath, FilePath) -- Output file name, relative to an output base dir - -> Verbosity -- verbosity - -> IO () -- Should exit if the preprocessor fails - } - -mkSimplePreProcessor :: (FilePath -> FilePath -> Verbosity -> IO ()) - -> (FilePath, FilePath) - -> (FilePath, FilePath) -> Verbosity -> IO () -mkSimplePreProcessor simplePP - (inBaseDir, inRelativeFile) - (outBaseDir, outRelativeFile) verbosity = simplePP inFile outFile verbosity - where inFile = normalise (inBaseDir inRelativeFile) - outFile = normalise (outBaseDir outRelativeFile) - -runSimplePreProcessor :: PreProcessor -> FilePath -> FilePath -> Verbosity - -> IO () -runSimplePreProcessor pp inFile outFile verbosity = - runPreProcessor pp (".", inFile) (".", outFile) verbosity - --- |A preprocessor for turning non-Haskell files with the given extension --- into plain Haskell source files. -type PPSuffixHandler - = (String, BuildInfo -> LocalBuildInfo -> PreProcessor) - --- |Apply preprocessors to the sources from 'hsSourceDirs', to obtain --- a Haskell source file for each module. -preprocessSources :: PackageDescription - -> LocalBuildInfo - -> Bool -- ^ Build for SDist - -> Verbosity -- ^ verbosity - -> [PPSuffixHandler] -- ^ preprocessors to try - -> IO () - -preprocessSources pkg_descr lbi forSDist verbosity handlers = do - withLib pkg_descr $ \ lib -> do - setupMessage verbosity "Preprocessing library" (packageId pkg_descr) - let bi = libBuildInfo lib - let biHandlers = localHandlers bi - sequence_ [ preprocessFile (hsSourceDirs bi ++ [autogenModulesDir lbi]) (buildDir lbi) forSDist - (ModuleName.toFilePath modu) verbosity - builtinSuffixes biHandlers - | modu <- libModules lib ] - unless (null (executables pkg_descr)) $ - setupMessage verbosity "Preprocessing executables for" (packageId pkg_descr) - withExe pkg_descr $ \ theExe -> do - let bi = buildInfo theExe - let biHandlers = localHandlers bi - let exeDir = buildDir lbi exeName theExe exeName theExe ++ "-tmp" - sequence_ [ preprocessFile (hsSourceDirs bi ++ [autogenModulesDir lbi]) exeDir forSDist - (ModuleName.toFilePath modu) verbosity - builtinSuffixes biHandlers - | modu <- otherModules bi] - preprocessFile (hsSourceDirs bi) exeDir forSDist - (dropExtensions (modulePath theExe)) - verbosity builtinSuffixes biHandlers - unless (null (testSuites pkg_descr)) $ - setupMessage verbosity "Preprocessing test suites for" (packageId pkg_descr) - withTest pkg_descr $ \test -> case testInterface test of - TestSuiteExeV10 _ f -> - preProcessTest test f $ buildDir lbi testName test - testName test ++ "-tmp" - TestSuiteLibV09 _ _ -> do - let testDir = buildDir lbi stubName test - stubName test ++ "-tmp" - writeSimpleTestStub test testDir - preProcessTest test (stubFilePath test) testDir - TestSuiteUnsupported tt -> die $ "No support for preprocessing test " - ++ "suite type " ++ display tt - where hc = compilerFlavor (compiler lbi) - builtinSuffixes - | hc == NHC = ["hs", "lhs", "gc"] - | otherwise = ["hs", "lhs"] - localHandlers bi = [(ext, h bi lbi) | (ext, h) <- handlers] - preProcessTest test exePath testDir = do - let bi = testBuildInfo test - biHandlers = localHandlers bi - sourceDirs = hsSourceDirs bi ++ [ autogenModulesDir lbi ] - sequence_ [ preprocessFile sourceDirs (buildDir lbi) forSDist - (ModuleName.toFilePath modu) verbosity builtinSuffixes - biHandlers - | modu <- testModules test ] - preprocessFile (testDir : (hsSourceDirs bi)) testDir forSDist - (dropExtensions $ exePath) verbosity - builtinSuffixes biHandlers - ---TODO: try to list all the modules that could not be found --- not just the first one. It's annoying and slow due to the need --- to reconfigure after editing the .cabal file each time. - --- |Find the first extension of the file that exists, and preprocess it --- if required. -preprocessFile - :: [FilePath] -- ^source directories - -> FilePath -- ^build directory - -> Bool -- ^preprocess for sdist - -> FilePath -- ^module file name - -> Verbosity -- ^verbosity - -> [String] -- ^builtin suffixes - -> [(String, PreProcessor)] -- ^possible preprocessors - -> IO () -preprocessFile searchLoc buildLoc forSDist baseFile verbosity builtinSuffixes handlers = do - -- look for files in the various source dirs with this module name - -- and a file extension of a known preprocessor - psrcFiles <- findFileWithExtension' (map fst handlers) searchLoc baseFile - case psrcFiles of - -- no preprocessor file exists, look for an ordinary source file - -- just to make sure one actually exists at all for this module. - -- Note: by looking in the target/output build dir too, we allow - -- source files to appear magically in the target build dir without - -- any corresponding "real" source file. This lets custom Setup.hs - -- files generate source modules directly into the build dir without - -- the rest of the build system being aware of it (somewhat dodgy) - Nothing -> do - bsrcFiles <- findFileWithExtension builtinSuffixes (buildLoc : searchLoc) baseFile - case bsrcFiles of - Nothing -> die $ "can't find source for " ++ baseFile - ++ " in " ++ intercalate ", " searchLoc - _ -> return () - -- found a pre-processable file in one of the source dirs - Just (psrcLoc, psrcRelFile) -> do - let (srcStem, ext) = splitExtension psrcRelFile - psrcFile = psrcLoc psrcRelFile - pp = fromMaybe (error "Internal error in preProcess module: Just expected") - (lookup (tailNotNull ext) handlers) - -- Preprocessing files for 'sdist' is different from preprocessing - -- for 'build'. When preprocessing for sdist we preprocess to - -- avoid that the user has to have the preprocessors available. - -- ATM, we don't have a way to specify which files are to be - -- preprocessed and which not, so for sdist we only process - -- platform independent files and put them into the 'buildLoc' - -- (which we assume is set to the temp. directory that will become - -- the tarball). - --TODO: eliminate sdist variant, just supply different handlers - when (not forSDist || forSDist && platformIndependent pp) $ do - -- look for existing pre-processed source file in the dest dir to - -- see if we really have to re-run the preprocessor. - ppsrcFiles <- findFileWithExtension builtinSuffixes [buildLoc] baseFile - recomp <- case ppsrcFiles of - Nothing -> return True - Just ppsrcFile -> do - btime <- getModificationTime ppsrcFile - ptime <- getModificationTime psrcFile - return (btime < ptime) - when recomp $ do - let destDir = buildLoc dirName srcStem - createDirectoryIfMissingVerbose verbosity True destDir - runPreProcessorWithHsBootHack pp - (psrcLoc, psrcRelFile) - (buildLoc, srcStem <.> "hs") - - where - dirName = takeDirectory - tailNotNull [] = [] - tailNotNull x = tail x - - -- FIXME: This is a somewhat nasty hack. GHC requires that hs-boot files - -- be in the same place as the hs files, so if we put the hs file in dist/ - -- then we need to copy the hs-boot file there too. This should probably be - -- done another way. Possibly we should also be looking for .lhs-boot - -- files, but I think that preprocessors only produce .hs files. - runPreProcessorWithHsBootHack pp - (inBaseDir, inRelativeFile) - (outBaseDir, outRelativeFile) = do - runPreProcessor pp - (inBaseDir, inRelativeFile) - (outBaseDir, outRelativeFile) verbosity - - exists <- doesFileExist inBoot - when exists $ copyFileVerbose verbosity inBoot outBoot - - where - inBoot = replaceExtension inFile "hs-boot" - outBoot = replaceExtension outFile "hs-boot" - - inFile = normalise (inBaseDir inRelativeFile) - outFile = normalise (outBaseDir outRelativeFile) - --- ------------------------------------------------------------ --- * known preprocessors --- ------------------------------------------------------------ - -ppGreenCard :: BuildInfo -> LocalBuildInfo -> PreProcessor -ppGreenCard _ lbi - = PreProcessor { - platformIndependent = False, - runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> - rawSystemProgramConf verbosity greencardProgram (withPrograms lbi) - (["-tffi", "-o" ++ outFile, inFile]) - } - --- This one is useful for preprocessors that can't handle literate source. --- We also need a way to chain preprocessors. -ppUnlit :: PreProcessor -ppUnlit = - PreProcessor { - platformIndependent = True, - runPreProcessor = mkSimplePreProcessor $ \inFile outFile _verbosity -> - withUTF8FileContents inFile $ \contents -> - either (writeUTF8File outFile) die (unlit inFile contents) - } - -ppCpp :: BuildInfo -> LocalBuildInfo -> PreProcessor -ppCpp = ppCpp' [] - -ppCpp' :: [String] -> BuildInfo -> LocalBuildInfo -> PreProcessor -ppCpp' extraArgs bi lbi = - case compilerFlavor (compiler lbi) of - GHC -> ppGhcCpp (cppArgs ++ extraArgs) bi lbi - _ -> ppCpphs (cppArgs ++ extraArgs) bi lbi - - where cppArgs = getCppOptions bi lbi - -ppGhcCpp :: [String] -> BuildInfo -> LocalBuildInfo -> PreProcessor -ppGhcCpp extraArgs _bi lbi = - PreProcessor { - platformIndependent = False, - runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do - (ghcProg, ghcVersion, _) <- requireProgramVersion verbosity - ghcProgram anyVersion (withPrograms lbi) - rawSystemProgram verbosity ghcProg $ - ["-E", "-cpp"] - -- This is a bit of an ugly hack. We're going to - -- unlit the file ourselves later on if appropriate, - -- so we need GHC not to unlit it now or it'll get - -- double-unlitted. In the future we might switch to - -- using cpphs --unlit instead. - ++ (if ghcVersion >= Version [6,6] [] then ["-x", "hs"] else []) - ++ (if use_optP_P lbi then ["-optP-P"] else []) - ++ [ "-optP-include", "-optP"++ (autogenModulesDir lbi cppHeaderName) ] - ++ ["-o", outFile, inFile] - ++ extraArgs - } - -ppCpphs :: [String] -> BuildInfo -> LocalBuildInfo -> PreProcessor -ppCpphs extraArgs _bi lbi = - PreProcessor { - platformIndependent = False, - runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do - (cpphsProg, cpphsVersion, _) <- requireProgramVersion verbosity - cpphsProgram anyVersion (withPrograms lbi) - rawSystemProgram verbosity cpphsProg $ - ("-O" ++ outFile) : inFile - : "--noline" : "--strip" - : (if cpphsVersion >= Version [1,6] [] - then ["--include="++ (autogenModulesDir lbi cppHeaderName)] - else []) - ++ extraArgs - } - --- Haddock versions before 0.8 choke on #line and #file pragmas. Those --- pragmas are necessary for correct links when we preprocess. So use --- -optP-P only if the Haddock version is prior to 0.8. -use_optP_P :: LocalBuildInfo -> Bool -use_optP_P lbi - = case lookupProgram haddockProgram (withPrograms lbi) of - Just (ConfiguredProgram { programVersion = Just version }) - | version >= Version [0,8] [] -> False - _ -> True - -ppHsc2hs :: BuildInfo -> LocalBuildInfo -> PreProcessor -ppHsc2hs bi lbi = - PreProcessor { - platformIndependent = False, - runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do - (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi) - rawSystemProgramConf verbosity hsc2hsProgram (withPrograms lbi) $ - [ "--cc=" ++ programPath gccProg - , "--ld=" ++ programPath gccProg ] - - -- Additional gcc options - ++ [ "--cflag=" ++ opt | opt <- programDefaultArgs gccProg - ++ programOverrideArgs gccProg ] - ++ [ "--lflag=" ++ opt | opt <- programDefaultArgs gccProg - ++ programOverrideArgs gccProg ] - - -- OSX frameworks: - ++ [ what ++ "=-F" ++ opt - | isOSX - , opt <- nub (concatMap Installed.frameworkDirs pkgs) - , what <- ["--cflag", "--lflag"] ] - ++ [ "--lflag=" ++ arg - | isOSX - , opt <- PD.frameworks bi ++ concatMap Installed.frameworks pkgs - , arg <- ["-framework", opt] ] - - -- Note that on ELF systems, wherever we use -L, we must also use -R - -- because presumably that -L dir is not on the normal path for the - -- system's dynamic linker. This is needed because hsc2hs works by - -- compiling a C program and then running it. - - ++ [ "--cflag=" ++ opt | opt <- hcDefines (compiler lbi) ] - ++ [ "--cflag=" ++ opt | opt <- sysDefines ] - - -- Options from the current package: - ++ [ "--cflag=-I" ++ dir | dir <- PD.includeDirs bi ] - ++ [ "--cflag=" ++ opt | opt <- PD.ccOptions bi - ++ PD.cppOptions bi ] - ++ [ "--lflag=-L" ++ opt | opt <- PD.extraLibDirs bi ] - ++ [ "--lflag=-Wl,-R," ++ opt | isELF - , opt <- PD.extraLibDirs bi ] - ++ [ "--lflag=-l" ++ opt | opt <- PD.extraLibs bi ] - ++ [ "--lflag=" ++ opt | opt <- PD.ldOptions bi ] - - -- Options from dependent packages - ++ [ "--cflag=" ++ opt - | pkg <- pkgs - , opt <- [ "-I" ++ opt | opt <- Installed.includeDirs pkg ] - ++ [ opt | opt <- Installed.ccOptions pkg ] ] - ++ [ "--lflag=" ++ opt - | pkg <- pkgs - , opt <- [ "-L" ++ opt | opt <- Installed.libraryDirs pkg ] - ++ [ "-Wl,-R," ++ opt | isELF - , opt <- Installed.libraryDirs pkg ] - ++ [ "-l" ++ opt | opt <- Installed.extraLibraries pkg ] - ++ [ opt | opt <- Installed.ldOptions pkg ] ] - ++ ["-o", outFile, inFile] - } - where - pkgs = PackageIndex.topologicalOrder (packageHacks (installedPkgs lbi)) - isOSX = case buildOS of OSX -> True; _ -> False - isELF = case buildOS of OSX -> False; Windows -> False; _ -> True; - packageHacks = case compilerFlavor (compiler lbi) of - GHC -> hackRtsPackage - _ -> id - -- We don't link in the actual Haskell libraries of our dependencies, so - -- the -u flags in the ldOptions of the rts package mean linking fails on - -- OS X (it's ld is a tad stricter than gnu ld). Thus we remove the - -- ldOptions for GHC's rts package: - hackRtsPackage index = - case PackageIndex.lookupPackageName index (PackageName "rts") of - [(_, [rts])] - -> PackageIndex.insert rts { Installed.ldOptions = [] } index - _ -> error "No (or multiple) ghc rts package is registered!!" - - -ppC2hs :: BuildInfo -> LocalBuildInfo -> PreProcessor -ppC2hs bi lbi = - PreProcessor { - platformIndependent = False, - runPreProcessor = \(inBaseDir, inRelativeFile) - (outBaseDir, outRelativeFile) verbosity -> do - (c2hsProg, _, _) <- requireProgramVersion verbosity - c2hsProgram (orLaterVersion (Version [0,15] [])) - (withPrograms lbi) - (gccProg, _) <- requireProgram verbosity gccProgram (withPrograms lbi) - rawSystemProgram verbosity c2hsProg $ - - -- Options from the current package: - [ "--cpp=" ++ programPath gccProg, "--cppopts=-E" ] - ++ [ "--cppopts=" ++ opt | opt <- getCppOptions bi lbi ] - ++ [ "--include=" ++ outBaseDir ] - - -- Options from dependent packages - ++ [ "--cppopts=" ++ opt - | pkg <- pkgs - , opt <- [ "-I" ++ opt | opt <- Installed.includeDirs pkg ] - ++ [ opt | opt@('-':c:_) <- Installed.ccOptions pkg - , c `elem` "DIU" ] ] - --TODO: install .chi files for packages, so we can --include - -- those dirs here, for the dependencies - - -- input and output files - ++ [ "--output-dir=" ++ outBaseDir - , "--output=" ++ outRelativeFile - , inBaseDir inRelativeFile ] - } - where - pkgs = PackageIndex.topologicalOrder (installedPkgs lbi) - ---TODO: perhaps use this with hsc2hs too ---TODO: remove cc-options from cpphs for cabal-version: >= 1.10 -getCppOptions :: BuildInfo -> LocalBuildInfo -> [String] -getCppOptions bi lbi - = hcDefines (compiler lbi) - ++ sysDefines - ++ cppOptions bi - ++ ["-I" ++ dir | dir <- PD.includeDirs bi] - ++ [opt | opt@('-':c:_) <- PD.ccOptions bi, c `elem` "DIU"] - -sysDefines :: [String] -sysDefines = ["-D" ++ os ++ "_" ++ loc ++ "_OS" | loc <- locations] - ++ ["-D" ++ arch ++ "_" ++ loc ++ "_ARCH" | loc <- locations] - where - locations = ["BUILD", "HOST"] - -hcDefines :: Compiler -> [String] -hcDefines comp = - case compilerFlavor comp of - GHC -> ["-D__GLASGOW_HASKELL__=" ++ versionInt version] - JHC -> ["-D__JHC__=" ++ versionInt version] - NHC -> ["-D__NHC__=" ++ versionInt version] - Hugs -> ["-D__HUGS__"] - _ -> [] - where version = compilerVersion comp - --- TODO: move this into the compiler abstraction --- FIXME: this forces GHC's crazy 4.8.2 -> 408 convention on all the other --- compilers. Check if that's really what they want. -versionInt :: Version -> String -versionInt (Version { versionBranch = [] }) = "1" -versionInt (Version { versionBranch = [n] }) = show n -versionInt (Version { versionBranch = n1:n2:_ }) - = -- 6.8.x -> 608 - -- 6.10.x -> 610 - let s1 = show n1 - s2 = show n2 - middle = case s2 of - _ : _ : _ -> "" - _ -> "0" - in s1 ++ middle ++ s2 - -ppHappy :: BuildInfo -> LocalBuildInfo -> PreProcessor -ppHappy _ lbi = pp { platformIndependent = True } - where pp = standardPP lbi happyProgram (hcFlags hc) - hc = compilerFlavor (compiler lbi) - hcFlags GHC = ["-agc"] - hcFlags _ = [] - -ppAlex :: BuildInfo -> LocalBuildInfo -> PreProcessor -ppAlex _ lbi = pp { platformIndependent = True } - where pp = standardPP lbi alexProgram (hcFlags hc) - hc = compilerFlavor (compiler lbi) - hcFlags GHC = ["-g"] - hcFlags _ = [] - -standardPP :: LocalBuildInfo -> Program -> [String] -> PreProcessor -standardPP lbi prog args = - PreProcessor { - platformIndependent = False, - runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> - rawSystemProgramConf verbosity prog (withPrograms lbi) - (args ++ ["-o", outFile, inFile]) - } - --- |Convenience function; get the suffixes of these preprocessors. -ppSuffixes :: [ PPSuffixHandler ] -> [String] -ppSuffixes = map fst - --- |Standard preprocessors: GreenCard, c2hs, hsc2hs, happy, alex and cpphs. -knownSuffixHandlers :: [ PPSuffixHandler ] -knownSuffixHandlers = - [ ("gc", ppGreenCard) - , ("chs", ppC2hs) - , ("hsc", ppHsc2hs) - , ("x", ppAlex) - , ("y", ppHappy) - , ("ly", ppHappy) - , ("cpphs", ppCpp) - ] diff -Nru ghc-7.0.3/libraries/Cabal/Distribution/Simple/Program/Ar.hs ghc-7.2.1/libraries/Cabal/Distribution/Simple/Program/Ar.hs --- ghc-7.0.3/libraries/Cabal/Distribution/Simple/Program/Ar.hs 2011-03-26 18:10:12.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/Distribution/Simple/Program/Ar.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,70 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Program.Ar --- Copyright : Duncan Coutts 2009 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This module provides an library interface to the @ar@ program. - -module Distribution.Simple.Program.Ar ( - createArLibArchive, - multiStageProgramInvocation, - ) where - -import Distribution.Simple.Program.Types - ( ConfiguredProgram(..) ) -import Distribution.Simple.Program.Run - ( programInvocation, multiStageProgramInvocation - , runProgramInvocation ) -import Distribution.System - ( OS(..), buildOS ) -import Distribution.Verbosity - ( Verbosity, deafening, verbose ) - --- | Call @ar@ to create a library archive from a bunch of object files. --- -createArLibArchive :: Verbosity -> ConfiguredProgram - -> FilePath -> [FilePath] -> IO () -createArLibArchive verbosity ar target files = - - -- The args to use with "ar" are actually rather subtle and system-dependent. - -- In particular we have the following issues: - -- - -- -- On OS X, "ar q" does not make an archive index. Archives with no - -- index cannot be used. - -- - -- -- GNU "ar r" will not let us add duplicate objects, only "ar q" lets us - -- do that. We have duplicates because of modules like "A.M" and "B.M" - -- both make an object file "M.o" and ar does not consider the directory. - -- - -- Our solution is to use "ar r" in the simple case when one call is enough. - -- When we need to call ar multiple times we use "ar q" and for the last - -- call on OSX we use "ar qs" so that it'll make the index. - - let simpleArgs = case buildOS of - OSX -> ["-r", "-s"] - _ -> ["-r"] - - initialArgs = ["-q"] - finalArgs = case buildOS of - OSX -> ["-q", "-s"] - _ -> ["-q"] - - extraArgs = verbosityOpts verbosity ++ [target] - - simple = programInvocation ar (simpleArgs ++ extraArgs) - initial = programInvocation ar (initialArgs ++ extraArgs) - middle = initial - final = programInvocation ar (finalArgs ++ extraArgs) - - in sequence_ - [ runProgramInvocation verbosity inv - | inv <- multiStageProgramInvocation - simple (initial, middle, final) files ] - - where - verbosityOpts v | v >= deafening = ["-v"] - | v >= verbose = [] - | otherwise = ["-c"] diff -Nru ghc-7.0.3/libraries/Cabal/Distribution/Simple/Program/Builtin.hs ghc-7.2.1/libraries/Cabal/Distribution/Simple/Program/Builtin.hs --- ghc-7.0.3/libraries/Cabal/Distribution/Simple/Program/Builtin.hs 2011-03-26 18:10:12.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/Distribution/Simple/Program/Builtin.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,259 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Program.Builtin --- Copyright : Isaac Jones 2006, Duncan Coutts 2007-2009 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- The module defines all the known built-in 'Program's. --- --- Where possible we try to find their version numbers. --- -module Distribution.Simple.Program.Builtin ( - - -- * The collection of unconfigured and configured progams - builtinPrograms, - - -- * Programs that Cabal knows about - ghcProgram, - ghcPkgProgram, - lhcProgram, - lhcPkgProgram, - nhcProgram, - hmakeProgram, - jhcProgram, - hugsProgram, - ffihugsProgram, - uhcProgram, - gccProgram, - ranlibProgram, - arProgram, - stripProgram, - happyProgram, - alexProgram, - hsc2hsProgram, - c2hsProgram, - cpphsProgram, - hscolourProgram, - haddockProgram, - greencardProgram, - ldProgram, - tarProgram, - cppProgram, - pkgConfigProgram, - ) where - -import Distribution.Simple.Program.Types - ( Program(..), simpleProgram ) -import Distribution.Simple.Utils - ( findProgramLocation, findProgramVersion ) - --- ------------------------------------------------------------ --- * Known programs --- ------------------------------------------------------------ - --- | The default list of programs. --- These programs are typically used internally to Cabal. -builtinPrograms :: [Program] -builtinPrograms = - [ - -- compilers and related progs - ghcProgram - , ghcPkgProgram - , hugsProgram - , ffihugsProgram - , nhcProgram - , hmakeProgram - , jhcProgram - , lhcProgram - , lhcPkgProgram - , uhcProgram - -- preprocessors - , hscolourProgram - , haddockProgram - , happyProgram - , alexProgram - , hsc2hsProgram - , c2hsProgram - , cpphsProgram - , greencardProgram - -- platform toolchain - , gccProgram - , ranlibProgram - , arProgram - , stripProgram - , ldProgram - , tarProgram - -- configuration tools - , pkgConfigProgram - ] - -ghcProgram :: Program -ghcProgram = (simpleProgram "ghc") { - programFindVersion = findProgramVersion "--numeric-version" id - } - -ghcPkgProgram :: Program -ghcPkgProgram = (simpleProgram "ghc-pkg") { - programFindVersion = findProgramVersion "--version" $ \str -> - -- Invoking "ghc-pkg --version" gives a string like - -- "GHC package manager version 6.4.1" - case words str of - (_:_:_:_:ver:_) -> ver - _ -> "" - } - -lhcProgram :: Program -lhcProgram = (simpleProgram "lhc") { - programFindVersion = findProgramVersion "--numeric-version" id - } - -lhcPkgProgram :: Program -lhcPkgProgram = (simpleProgram "lhc-pkg") { - programFindVersion = findProgramVersion "--version" $ \str -> - -- Invoking "lhc-pkg --version" gives a string like - -- "LHC package manager version 0.7" - case words str of - (_:_:_:_:ver:_) -> ver - _ -> "" - } - -nhcProgram :: Program -nhcProgram = (simpleProgram "nhc98") { - programFindVersion = findProgramVersion "--version" $ \str -> - -- Invoking "nhc98 --version" gives a string like - -- "/usr/local/bin/nhc98: v1.20 (2007-11-22)" - case words str of - (_:('v':ver):_) -> ver - _ -> "" - } - -hmakeProgram :: Program -hmakeProgram = (simpleProgram "hmake") { - programFindVersion = findProgramVersion "--version" $ \str -> - -- Invoking "hmake --version" gives a string line - -- "/usr/local/bin/hmake: 3.13 (2006-11-01)" - case words str of - (_:ver:_) -> ver - _ -> "" - } - -jhcProgram :: Program -jhcProgram = (simpleProgram "jhc") { - programFindVersion = findProgramVersion "--version" $ \str -> - -- invoking "jhc --version" gives a string like - -- "jhc 0.3.20080208 (wubgipkamcep-2) - -- compiled by ghc-6.8 on a x86_64 running linux" - case words str of - (_:ver:_) -> ver - _ -> "" - } - -uhcProgram :: Program -uhcProgram = (simpleProgram "uhc") { - programFindVersion = findProgramVersion "--version-dotted" id - } - - --- AArgh! Finding the version of hugs or ffihugs is almost impossible. -hugsProgram :: Program -hugsProgram = simpleProgram "hugs" - -ffihugsProgram :: Program -ffihugsProgram = simpleProgram "ffihugs" - -happyProgram :: Program -happyProgram = (simpleProgram "happy") { - programFindVersion = findProgramVersion "--version" $ \str -> - -- Invoking "happy --version" gives a string like - -- "Happy Version 1.16 Copyright (c) ...." - case words str of - (_:_:ver:_) -> ver - _ -> "" - } - -alexProgram :: Program -alexProgram = (simpleProgram "alex") { - programFindVersion = findProgramVersion "--version" $ \str -> - -- Invoking "alex --version" gives a string like - -- "Alex version 2.1.0, (c) 2003 Chris Dornan and Simon Marlow" - case words str of - (_:_:ver:_) -> takeWhile (`elem` ('.':['0'..'9'])) ver - _ -> "" - } - -gccProgram :: Program -gccProgram = (simpleProgram "gcc") { - programFindVersion = findProgramVersion "-dumpversion" id - } - -ranlibProgram :: Program -ranlibProgram = simpleProgram "ranlib" - -arProgram :: Program -arProgram = simpleProgram "ar" - -stripProgram :: Program -stripProgram = simpleProgram "strip" - -hsc2hsProgram :: Program -hsc2hsProgram = (simpleProgram "hsc2hs") { - programFindVersion = - findProgramVersion "--version" $ \str -> - -- Invoking "hsc2hs --version" gives a string like "hsc2hs version 0.66" - case words str of - (_:_:ver:_) -> ver - _ -> "" - } - -c2hsProgram :: Program -c2hsProgram = (simpleProgram "c2hs") { - programFindVersion = findProgramVersion "--numeric-version" id - } - -cpphsProgram :: Program -cpphsProgram = (simpleProgram "cpphs") { - programFindVersion = findProgramVersion "--version" $ \str -> - -- Invoking "cpphs --version" gives a string like "cpphs 1.3" - case words str of - (_:ver:_) -> ver - _ -> "" - } - -hscolourProgram :: Program -hscolourProgram = (simpleProgram "hscolour") { - programFindLocation = \v -> findProgramLocation v "HsColour", - programFindVersion = findProgramVersion "-version" $ \str -> - -- Invoking "HsColour -version" gives a string like "HsColour 1.7" - case words str of - (_:ver:_) -> ver - _ -> "" - } - -haddockProgram :: Program -haddockProgram = (simpleProgram "haddock") { - programFindVersion = findProgramVersion "--version" $ \str -> - -- Invoking "haddock --version" gives a string like - -- "Haddock version 0.8, (c) Simon Marlow 2006" - case words str of - (_:_:ver:_) -> takeWhile (`elem` ('.':['0'..'9'])) ver - _ -> "" - } - -greencardProgram :: Program -greencardProgram = simpleProgram "greencard" - -ldProgram :: Program -ldProgram = simpleProgram "ld" - -tarProgram :: Program -tarProgram = simpleProgram "tar" - -cppProgram :: Program -cppProgram = simpleProgram "cpp" - -pkgConfigProgram :: Program -pkgConfigProgram = (simpleProgram "pkg-config") { - programFindVersion = findProgramVersion "--version" id - } diff -Nru ghc-7.0.3/libraries/Cabal/Distribution/Simple/Program/Db.hs ghc-7.2.1/libraries/Cabal/Distribution/Simple/Program/Db.hs --- ghc-7.0.3/libraries/Cabal/Distribution/Simple/Program/Db.hs 2011-03-26 18:10:12.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/Distribution/Simple/Program/Db.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,409 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Program.Db --- Copyright : Isaac Jones 2006, Duncan Coutts 2007-2009 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This provides a 'ProgramDb' type which holds configured and not-yet --- configured programs. It is the parameter to lots of actions elsewhere in --- Cabal that need to look up and run programs. If we had a Cabal monad, --- the 'ProgramDb' would probably be a reader or state component of it. --- --- One nice thing about using it is that any program that is --- registered with Cabal will get some \"configure\" and \".cabal\" --- helpers like --with-foo-args --foo-path= and extra-foo-args. --- --- There's also a hook for adding programs in a Setup.lhs script. See --- hookedPrograms in 'Distribution.Simple.UserHooks'. This gives a --- hook user the ability to get the above flags and such so that they --- don't have to write all the PATH logic inside Setup.lhs. - -module Distribution.Simple.Program.Db ( - -- * The collection of configured programs we can run - ProgramDb, - emptyProgramDb, - defaultProgramDb, - restoreProgramDb, - - -- ** Query and manipulate the program db - addKnownProgram, - addKnownPrograms, - lookupKnownProgram, - knownPrograms, - userSpecifyPath, - userSpecifyPaths, - userMaybeSpecifyPath, - userSpecifyArgs, - userSpecifyArgss, - userSpecifiedArgs, - lookupProgram, - updateProgram, - - -- ** Query and manipulate the program db - configureProgram, - configureAllKnownPrograms, - reconfigurePrograms, - requireProgram, - requireProgramVersion, - - ) where - -import Distribution.Simple.Program.Types - ( Program(..), ProgArg, ConfiguredProgram(..), ProgramLocation(..) ) -import Distribution.Simple.Program.Builtin - ( builtinPrograms ) -import Distribution.Simple.Utils - ( die, findProgramLocation ) -import Distribution.Version - ( Version, VersionRange, isAnyVersion, withinRange ) -import Distribution.Text - ( display ) -import Distribution.Verbosity - ( Verbosity ) - -import Data.List - ( foldl' ) -import Data.Maybe - ( catMaybes ) -import qualified Data.Map as Map -import Control.Monad - ( join, foldM ) -import System.Directory - ( doesFileExist ) - - --- ------------------------------------------------------------ --- * Programs database --- ------------------------------------------------------------ - --- | The configuration is a collection of information about programs. It --- contains information both about configured programs and also about programs --- that we are yet to configure. --- --- The idea is that we start from a collection of unconfigured programs and one --- by one we try to configure them at which point we move them into the --- configured collection. For unconfigured programs we record not just the --- 'Program' but also any user-provided arguments and location for the program. -data ProgramDb = ProgramDb { - unconfiguredProgs :: UnconfiguredProgs, - configuredProgs :: ConfiguredProgs - } - -type UnconfiguredProgram = (Program, Maybe FilePath, [ProgArg]) -type UnconfiguredProgs = Map.Map String UnconfiguredProgram -type ConfiguredProgs = Map.Map String ConfiguredProgram - - -emptyProgramDb :: ProgramDb -emptyProgramDb = ProgramDb Map.empty Map.empty - - -defaultProgramDb :: ProgramDb -defaultProgramDb = restoreProgramDb builtinPrograms emptyProgramDb - - --- internal helpers: -updateUnconfiguredProgs :: (UnconfiguredProgs -> UnconfiguredProgs) - -> ProgramDb -> ProgramDb -updateUnconfiguredProgs update conf = - conf { unconfiguredProgs = update (unconfiguredProgs conf) } - -updateConfiguredProgs :: (ConfiguredProgs -> ConfiguredProgs) - -> ProgramDb -> ProgramDb -updateConfiguredProgs update conf = - conf { configuredProgs = update (configuredProgs conf) } - - --- Read & Show instances are based on listToFM --- Note that we only serialise the configured part of the database, this is --- because we don't need the unconfigured part after the configure stage, and --- additionally because we cannot read/show 'Program' as it contains functions. -instance Show ProgramDb where - show = show . Map.toAscList . configuredProgs - -instance Read ProgramDb where - readsPrec p s = - [ (emptyProgramDb { configuredProgs = Map.fromList s' }, r) - | (s', r) <- readsPrec p s ] - - --- | The Read\/Show instance does not preserve all the unconfigured 'Programs' --- because 'Program' is not in Read\/Show because it contains functions. So to --- fully restore a deserialised 'ProgramDb' use this function to add --- back all the known 'Program's. --- --- * It does not add the default programs, but you probably want them, use --- 'builtinPrograms' in addition to any extra you might need. --- -restoreProgramDb :: [Program] -> ProgramDb -> ProgramDb -restoreProgramDb = addKnownPrograms - - --- ------------------------------- --- Managing unconfigured programs - --- | Add a known program that we may configure later --- -addKnownProgram :: Program -> ProgramDb -> ProgramDb -addKnownProgram prog = updateUnconfiguredProgs $ - Map.insertWith combine (programName prog) (prog, Nothing, []) - where combine _ (_, path, args) = (prog, path, args) - - -addKnownPrograms :: [Program] -> ProgramDb -> ProgramDb -addKnownPrograms progs conf = foldl' (flip addKnownProgram) conf progs - - -lookupKnownProgram :: String -> ProgramDb -> Maybe Program -lookupKnownProgram name = - fmap (\(p,_,_)->p) . Map.lookup name . unconfiguredProgs - - -knownPrograms :: ProgramDb -> [(Program, Maybe ConfiguredProgram)] -knownPrograms conf = - [ (p,p') | (p,_,_) <- Map.elems (unconfiguredProgs conf) - , let p' = Map.lookup (programName p) (configuredProgs conf) ] - - --- |User-specify this path. Basically override any path information --- for this program in the configuration. If it's not a known --- program ignore it. --- -userSpecifyPath :: String -- ^Program name - -> FilePath -- ^user-specified path to the program - -> ProgramDb -> ProgramDb -userSpecifyPath name path = updateUnconfiguredProgs $ - flip Map.update name $ \(prog, _, args) -> Just (prog, Just path, args) - - -userMaybeSpecifyPath :: String -> Maybe FilePath - -> ProgramDb -> ProgramDb -userMaybeSpecifyPath _ Nothing conf = conf -userMaybeSpecifyPath name (Just path) conf = userSpecifyPath name path conf - - --- |User-specify the arguments for this program. Basically override --- any args information for this program in the configuration. If it's --- not a known program, ignore it.. -userSpecifyArgs :: String -- ^Program name - -> [ProgArg] -- ^user-specified args - -> ProgramDb - -> ProgramDb -userSpecifyArgs name args' = - updateUnconfiguredProgs - (flip Map.update name $ - \(prog, path, args) -> Just (prog, path, args ++ args')) - . updateConfiguredProgs - (flip Map.update name $ - \prog -> Just prog { programOverrideArgs = programOverrideArgs prog - ++ args' }) - - --- | Like 'userSpecifyPath' but for a list of progs and their paths. --- -userSpecifyPaths :: [(String, FilePath)] - -> ProgramDb - -> ProgramDb -userSpecifyPaths paths conf = - foldl' (\conf' (prog, path) -> userSpecifyPath prog path conf') conf paths - - --- | Like 'userSpecifyPath' but for a list of progs and their args. --- -userSpecifyArgss :: [(String, [ProgArg])] - -> ProgramDb - -> ProgramDb -userSpecifyArgss argss conf = - foldl' (\conf' (prog, args) -> userSpecifyArgs prog args conf') conf argss - - --- | Get the path that has been previously specified for a program, if any. --- -userSpecifiedPath :: Program -> ProgramDb -> Maybe FilePath -userSpecifiedPath prog = - join . fmap (\(_,p,_)->p) . Map.lookup (programName prog) . unconfiguredProgs - - --- | Get any extra args that have been previously specified for a program. --- -userSpecifiedArgs :: Program -> ProgramDb -> [ProgArg] -userSpecifiedArgs prog = - maybe [] (\(_,_,as)->as) . Map.lookup (programName prog) . unconfiguredProgs - - --- ----------------------------- --- Managing configured programs - --- | Try to find a configured program -lookupProgram :: Program -> ProgramDb -> Maybe ConfiguredProgram -lookupProgram prog = Map.lookup (programName prog) . configuredProgs - - --- | Update a configured program in the database. -updateProgram :: ConfiguredProgram -> ProgramDb - -> ProgramDb -updateProgram prog = updateConfiguredProgs $ - Map.insert (programId prog) prog - - --- --------------------------- --- Configuring known programs - --- | Try to configure a specific program. If the program is already included in --- the colleciton of unconfigured programs then we use any user-supplied --- location and arguments. If the program gets configured sucessfully it gets --- added to the configured collection. --- --- Note that it is not a failure if the program cannot be configured. It's only --- a failure if the user supplied a location and the program could not be found --- at that location. --- --- The reason for it not being a failure at this stage is that we don't know up --- front all the programs we will need, so we try to configure them all. --- To verify that a program was actually sucessfully configured use --- 'requireProgram'. --- -configureProgram :: Verbosity - -> Program - -> ProgramDb - -> IO ProgramDb -configureProgram verbosity prog conf = do - let name = programName prog - maybeLocation <- case userSpecifiedPath prog conf of - Nothing -> programFindLocation prog verbosity - >>= return . fmap FoundOnSystem - Just path -> do - absolute <- doesFileExist path - if absolute - then return (Just (UserSpecified path)) - else findProgramLocation verbosity path - >>= maybe (die notFound) (return . Just . UserSpecified) - where notFound = "Cannot find the program '" ++ name ++ "' at '" - ++ path ++ "' or on the path" - case maybeLocation of - Nothing -> return conf - Just location -> do - version <- programFindVersion prog verbosity (locationPath location) - let configuredProg = ConfiguredProgram { - programId = name, - programVersion = version, - programDefaultArgs = [], - programOverrideArgs = userSpecifiedArgs prog conf, - programLocation = location - } - extraArgs <- programPostConf prog verbosity configuredProg - let configuredProg' = configuredProg { - programDefaultArgs = extraArgs - } - return (updateConfiguredProgs (Map.insert name configuredProg') conf) - - --- | Configure a bunch of programs using 'configureProgram'. Just a 'foldM'. --- -configurePrograms :: Verbosity - -> [Program] - -> ProgramDb - -> IO ProgramDb -configurePrograms verbosity progs conf = - foldM (flip (configureProgram verbosity)) conf progs - - --- | Try to configure all the known programs that have not yet been configured. --- -configureAllKnownPrograms :: Verbosity - -> ProgramDb - -> IO ProgramDb -configureAllKnownPrograms verbosity conf = - configurePrograms verbosity - [ prog | (prog,_,_) <- Map.elems notYetConfigured ] conf - where - notYetConfigured = unconfiguredProgs conf - `Map.difference` configuredProgs conf - - --- | reconfigure a bunch of programs given new user-specified args. It takes --- the same inputs as 'userSpecifyPath' and 'userSpecifyArgs' and for all progs --- with a new path it calls 'configureProgram'. --- -reconfigurePrograms :: Verbosity - -> [(String, FilePath)] - -> [(String, [ProgArg])] - -> ProgramDb - -> IO ProgramDb -reconfigurePrograms verbosity paths argss conf = do - configurePrograms verbosity progs - . userSpecifyPaths paths - . userSpecifyArgss argss - $ conf - - where - progs = catMaybes [ lookupKnownProgram name conf | (name,_) <- paths ] - - --- | Check that a program is configured and available to be run. --- --- It raises an exception if the program could not be configured, otherwise --- it returns the configured program. --- -requireProgram :: Verbosity -> Program -> ProgramDb - -> IO (ConfiguredProgram, ProgramDb) -requireProgram verbosity prog conf = do - - -- If it's not already been configured, try to configure it now - conf' <- case lookupProgram prog conf of - Nothing -> configureProgram verbosity prog conf - Just _ -> return conf - - case lookupProgram prog conf' of - Nothing -> die notFound - Just configuredProg -> return (configuredProg, conf') - - where notFound = "The program " ++ programName prog - ++ " is required but it could not be found." - - --- | Check that a program is configured and available to be run. --- --- Additionally check that the version of the program number is suitable and --- return it. For example you could require 'AnyVersion' or --- @'orLaterVersion' ('Version' [1,0] [])@ --- --- It raises an exception if the program could not be configured or the version --- is unsuitable, otherwise it returns the configured program and its version --- number. --- -requireProgramVersion :: Verbosity -> Program -> VersionRange - -> ProgramDb - -> IO (ConfiguredProgram, Version, ProgramDb) -requireProgramVersion verbosity prog range conf = do - - -- If it's not already been configured, try to configure it now - conf' <- case lookupProgram prog conf of - Nothing -> configureProgram verbosity prog conf - Just _ -> return conf - - case lookupProgram prog conf' of - Nothing -> die notFound - Just configuredProg@ConfiguredProgram { programLocation = location } -> - case programVersion configuredProg of - Just version - | withinRange version range -> return (configuredProg, version, conf') - | otherwise -> die (badVersion version location) - Nothing -> die (noVersion location) - - where notFound = "The program " - ++ programName prog ++ versionRequirement - ++ " is required but it could not be found." - badVersion v l = "The program " - ++ programName prog ++ versionRequirement - ++ " is required but the version found at " - ++ locationPath l ++ " is version " ++ display v - noVersion l = "The program " - ++ programName prog ++ versionRequirement - ++ " is required but the version of " - ++ locationPath l ++ " could not be determined." - versionRequirement - | isAnyVersion range = "" - | otherwise = " version " ++ display range diff -Nru ghc-7.0.3/libraries/Cabal/Distribution/Simple/Program/HcPkg.hs ghc-7.2.1/libraries/Cabal/Distribution/Simple/Program/HcPkg.hs --- ghc-7.0.3/libraries/Cabal/Distribution/Simple/Program/HcPkg.hs 2011-03-26 18:10:12.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/Distribution/Simple/Program/HcPkg.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,277 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Program.HcPkg --- Copyright : Duncan Coutts 2009 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This module provides an library interface to the @hc-pkg@ program. --- Currently only GHC and LHC have hc-pkg programs. - -module Distribution.Simple.Program.HcPkg ( - register, - reregister, - unregister, - expose, - hide, - dump, - - -- * Program invocations - registerInvocation, - reregisterInvocation, - unregisterInvocation, - exposeInvocation, - hideInvocation, - dumpInvocation, - ) where - -import Distribution.Package - ( PackageId, InstalledPackageId(..) ) -import Distribution.InstalledPackageInfo - ( InstalledPackageInfo, InstalledPackageInfo_(..) - , showInstalledPackageInfo, parseInstalledPackageInfo ) -import Distribution.ParseUtils - ( ParseResult(..) ) -import Distribution.Simple.Compiler - ( PackageDB(..), PackageDBStack ) -import Distribution.Simple.Program.Types - ( ConfiguredProgram(programId, programVersion) ) -import Distribution.Simple.Program.Run - ( ProgramInvocation(..), IOEncoding(..), programInvocation - , runProgramInvocation, getProgramInvocationOutput ) -import Distribution.Version - ( Version(..) ) -import Distribution.Text - ( display ) -import Distribution.Simple.Utils - ( die ) -import Distribution.Verbosity - ( Verbosity, deafening, silent ) -import Distribution.Compat.Exception - ( catchExit ) - -import Data.Char - ( isSpace ) -import Control.Monad - ( liftM ) - --- | Call @hc-pkg@ to register a package. --- --- > hc-pkg register {filename | -} [--user | --global | --package-conf] --- -register :: Verbosity -> ConfiguredProgram -> PackageDBStack - -> Either FilePath - InstalledPackageInfo - -> IO () -register verbosity hcPkg packagedb pkgFile = - runProgramInvocation verbosity - (registerInvocation hcPkg verbosity packagedb pkgFile) - - --- | Call @hc-pkg@ to re-register a package. --- --- > hc-pkg register {filename | -} [--user | --global | --package-conf] --- -reregister :: Verbosity -> ConfiguredProgram -> PackageDBStack - -> Either FilePath - InstalledPackageInfo - -> IO () -reregister verbosity hcPkg packagedb pkgFile = - runProgramInvocation verbosity - (reregisterInvocation hcPkg verbosity packagedb pkgFile) - - --- | Call @hc-pkg@ to unregister a package --- --- > hc-pkg unregister [pkgid] [--user | --global | --package-conf] --- -unregister :: Verbosity -> ConfiguredProgram -> PackageDB -> PackageId -> IO () -unregister verbosity hcPkg packagedb pkgid = - runProgramInvocation verbosity - (unregisterInvocation hcPkg verbosity packagedb pkgid) - - --- | Call @hc-pkg@ to expose a package. --- --- > hc-pkg expose [pkgid] [--user | --global | --package-conf] --- -expose :: Verbosity -> ConfiguredProgram -> PackageDB -> PackageId -> IO () -expose verbosity hcPkg packagedb pkgid = - runProgramInvocation verbosity - (exposeInvocation hcPkg verbosity packagedb pkgid) - - --- | Call @hc-pkg@ to expose a package. --- --- > hc-pkg expose [pkgid] [--user | --global | --package-conf] --- -hide :: Verbosity -> ConfiguredProgram -> PackageDB -> PackageId -> IO () -hide verbosity hcPkg packagedb pkgid = - runProgramInvocation verbosity - (hideInvocation hcPkg verbosity packagedb pkgid) - - --- | Call @hc-pkg@ to get all the installed packages. --- -dump :: Verbosity -> ConfiguredProgram -> PackageDB -> IO [InstalledPackageInfo] -dump verbosity hcPkg packagedb = do - - output <- getProgramInvocationOutput verbosity - (dumpInvocation hcPkg verbosity packagedb) - `catchExit` \_ -> die $ programId hcPkg ++ " dump failed" - - case parsePackages output of - Left ok -> return ok - _ -> die $ "failed to parse output of '" - ++ programId hcPkg ++ " dump'" - - where - parsePackages str = - let parse = liftM setInstalledPackageId . parseInstalledPackageInfo - parsed = map parse (splitPkgs str) - in case [ msg | ParseFailed msg <- parsed ] of - [] -> Left [ pkg | ParseOk _ pkg <- parsed ] - msgs -> Right msgs - - --TODO: this could be a lot faster. We're doing normaliseLineEndings twice - -- and converting back and forth with lines/unlines. - splitPkgs :: String -> [String] - splitPkgs = checkEmpty . map unlines . splitWith ("---" ==) . lines - where - -- Handle the case of there being no packages at all. - checkEmpty [s] | all isSpace s = [] - checkEmpty ss = ss - - splitWith :: (a -> Bool) -> [a] -> [[a]] - splitWith p xs = ys : case zs of - [] -> [] - _:ws -> splitWith p ws - where (ys,zs) = break p xs - - --- Older installed package info files did not have the installedPackageId --- field, so if it is missing then we fill it as the source package ID. -setInstalledPackageId :: InstalledPackageInfo -> InstalledPackageInfo -setInstalledPackageId pkginfo@InstalledPackageInfo { - installedPackageId = InstalledPackageId "", - sourcePackageId = pkgid - } - = pkginfo { - --TODO use a proper named function for the conversion - -- from source package id to installed package id - installedPackageId = InstalledPackageId (display pkgid) - } -setInstalledPackageId pkginfo = pkginfo - - --------------------------- --- The program invocations --- - -registerInvocation, reregisterInvocation - :: ConfiguredProgram -> Verbosity -> PackageDBStack - -> Either FilePath InstalledPackageInfo - -> ProgramInvocation -registerInvocation = registerInvocation' "register" -reregisterInvocation = registerInvocation' "update" - - -registerInvocation' :: String - -> ConfiguredProgram -> Verbosity -> PackageDBStack - -> Either FilePath InstalledPackageInfo - -> ProgramInvocation -registerInvocation' cmdname hcPkg verbosity packagedbs (Left pkgFile) = - programInvocation hcPkg args - where - args = [cmdname, pkgFile] - ++ (if legacyVersion hcPkg - then [packageDbOpts (last packagedbs)] - else packageDbStackOpts packagedbs) - ++ verbosityOpts hcPkg verbosity - -registerInvocation' cmdname hcPkg verbosity packagedbs (Right pkgInfo) = - (programInvocation hcPkg args) { - progInvokeInput = Just (showInstalledPackageInfo pkgInfo), - progInvokeInputEncoding = IOEncodingUTF8 - } - where - args = [cmdname, "-"] - ++ (if legacyVersion hcPkg - then [packageDbOpts (last packagedbs)] - else packageDbStackOpts packagedbs) - ++ verbosityOpts hcPkg verbosity - - -unregisterInvocation :: ConfiguredProgram - -> Verbosity -> PackageDB -> PackageId - -> ProgramInvocation -unregisterInvocation hcPkg verbosity packagedb pkgid = - programInvocation hcPkg $ - ["unregister", packageDbOpts packagedb, display pkgid] - ++ verbosityOpts hcPkg verbosity - - -exposeInvocation :: ConfiguredProgram - -> Verbosity -> PackageDB -> PackageId -> ProgramInvocation -exposeInvocation hcPkg verbosity packagedb pkgid = - programInvocation hcPkg $ - ["expose", packageDbOpts packagedb, display pkgid] - ++ verbosityOpts hcPkg verbosity - - -hideInvocation :: ConfiguredProgram - -> Verbosity -> PackageDB -> PackageId -> ProgramInvocation -hideInvocation hcPkg verbosity packagedb pkgid = - programInvocation hcPkg $ - ["hide", packageDbOpts packagedb, display pkgid] - ++ verbosityOpts hcPkg verbosity - - -dumpInvocation :: ConfiguredProgram - -> Verbosity -> PackageDB -> ProgramInvocation -dumpInvocation hcPkg verbosity packagedb = - (programInvocation hcPkg args) { - progInvokeOutputEncoding = IOEncodingUTF8 - } - where - args = ["dump", packageDbOpts packagedb] - ++ verbosityOpts hcPkg verbosity - - -packageDbStackOpts :: PackageDBStack -> [String] -packageDbStackOpts dbstack = case dbstack of - (GlobalPackageDB:UserPackageDB:dbs) -> "--global" - : "--user" - : map specific dbs - (GlobalPackageDB:dbs) -> "--global" - : "--no-user-package-conf" - : map specific dbs - _ -> ierror - where - specific (SpecificPackageDB db) = "--package-conf=" ++ db - specific _ = ierror - ierror :: a - ierror = error ("internal error: unexpected package db stack: " ++ show dbstack) - -packageDbOpts :: PackageDB -> String -packageDbOpts GlobalPackageDB = "--global" -packageDbOpts UserPackageDB = "--user" -packageDbOpts (SpecificPackageDB db) = "--package-conf=" ++ db - -verbosityOpts :: ConfiguredProgram -> Verbosity -> [String] -verbosityOpts hcPkg v - - -- ghc-pkg < 6.11 does not support -v - | programId hcPkg == "ghc-pkg" - && programVersion hcPkg < Just (Version [6,11] []) - = [] - - | v >= deafening = ["-v2"] - | v == silent = ["-v0"] - | otherwise = [] - --- Handle quirks in ghc-pkg 6.8 and older -legacyVersion :: ConfiguredProgram -> Bool -legacyVersion hcPkg = programId hcPkg == "ghc-pkg" - && programVersion hcPkg < Just (Version [6,9] []) diff -Nru ghc-7.0.3/libraries/Cabal/Distribution/Simple/Program/Ld.hs ghc-7.2.1/libraries/Cabal/Distribution/Simple/Program/Ld.hs --- ghc-7.0.3/libraries/Cabal/Distribution/Simple/Program/Ld.hs 2011-03-26 18:10:12.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/Distribution/Simple/Program/Ld.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,62 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Program.Ld --- Copyright : Duncan Coutts 2009 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This module provides an library interface to the @ld@ linker program. - -module Distribution.Simple.Program.Ld ( - combineObjectFiles, - ) where - -import Distribution.Simple.Program.Types - ( ConfiguredProgram(..) ) -import Distribution.Simple.Program.Run - ( programInvocation, multiStageProgramInvocation - , runProgramInvocation ) -import Distribution.Verbosity - ( Verbosity ) - -import System.Directory - ( renameFile ) -import System.FilePath - ( (<.>) ) - --- | Call @ld -r@ to link a bunch of object files together. --- -combineObjectFiles :: Verbosity -> ConfiguredProgram - -> FilePath -> [FilePath] -> IO () -combineObjectFiles verbosity ld target files = - - -- Unlike "ar", the "ld" tool is not designed to be used with xargs. That is, - -- if we have more object files than fit on a single command line then we - -- have a slight problem. What we have to do is link files in batches into - -- a temp object file and then include that one in the next batch. - - let simpleArgs = ["-r", "-o", target] - - initialArgs = ["-r", "-o", target] - middleArgs = ["-r", "-o", target, tmpfile] - finalArgs = middleArgs - - simple = programInvocation ld simpleArgs - initial = programInvocation ld initialArgs - middle = programInvocation ld middleArgs - final = programInvocation ld finalArgs - - invocations = multiStageProgramInvocation - simple (initial, middle, final) files - - in run invocations - - where - tmpfile = target <.> "tmp" -- perhaps should use a proper temp file - - run [] = return () - run [inv] = runProgramInvocation verbosity inv - run (inv:invs) = do runProgramInvocation verbosity inv - renameFile target tmpfile - run invs diff -Nru ghc-7.0.3/libraries/Cabal/Distribution/Simple/Program/Run.hs ghc-7.2.1/libraries/Cabal/Distribution/Simple/Program/Run.hs --- ghc-7.0.3/libraries/Cabal/Distribution/Simple/Program/Run.hs 2011-03-26 18:10:12.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/Distribution/Simple/Program/Run.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,218 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Program.Run --- Copyright : Duncan Coutts 2009 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This module provides a data type for program invocations and functions to --- run them. - -module Distribution.Simple.Program.Run ( - ProgramInvocation(..), - IOEncoding(..), - emptyProgramInvocation, - simpleProgramInvocation, - programInvocation, - multiStageProgramInvocation, - - runProgramInvocation, - getProgramInvocationOutput, - - ) where - -import Distribution.Simple.Program.Types - ( ConfiguredProgram(..), programPath ) -import Distribution.Simple.Utils - ( die, rawSystemExit, rawSystemStdInOut - , toUTF8, fromUTF8, normaliseLineEndings ) -import Distribution.Verbosity - ( Verbosity ) - -import Data.List - ( foldl', unfoldr ) -import Control.Monad - ( when ) -import System.Exit - ( ExitCode(..) ) - --- | Represents a specific invocation of a specific program. --- --- This is used as an intermediate type between deciding how to call a program --- and actually doing it. This provides the opportunity to the caller to --- adjust how the program will be called. These invocations can either be run --- directly or turned into shell or batch scripts. --- -data ProgramInvocation = ProgramInvocation { - progInvokePath :: FilePath, - progInvokeArgs :: [String], - progInvokeEnv :: [(String, String)], - progInvokeCwd :: Maybe FilePath, - progInvokeInput :: Maybe String, - progInvokeInputEncoding :: IOEncoding, - progInvokeOutputEncoding :: IOEncoding - } - -data IOEncoding = IOEncodingText -- locale mode text - | IOEncodingUTF8 -- always utf8 - -emptyProgramInvocation :: ProgramInvocation -emptyProgramInvocation = - ProgramInvocation { - progInvokePath = "", - progInvokeArgs = [], - progInvokeEnv = [], - progInvokeCwd = Nothing, - progInvokeInput = Nothing, - progInvokeInputEncoding = IOEncodingText, - progInvokeOutputEncoding = IOEncodingText - } - -simpleProgramInvocation :: FilePath -> [String] -> ProgramInvocation -simpleProgramInvocation path args = - emptyProgramInvocation { - progInvokePath = path, - progInvokeArgs = args - } - -programInvocation :: ConfiguredProgram -> [String] -> ProgramInvocation -programInvocation prog args = - emptyProgramInvocation { - progInvokePath = programPath prog, - progInvokeArgs = programDefaultArgs prog - ++ args - ++ programOverrideArgs prog - } - - -runProgramInvocation :: Verbosity -> ProgramInvocation -> IO () -runProgramInvocation verbosity - ProgramInvocation { - progInvokePath = path, - progInvokeArgs = args, - progInvokeEnv = [], - progInvokeCwd = Nothing, - progInvokeInput = Nothing - } = - rawSystemExit verbosity path args - -runProgramInvocation verbosity - ProgramInvocation { - progInvokePath = path, - progInvokeArgs = args, - progInvokeEnv = [], - progInvokeCwd = Nothing, - progInvokeInput = Just inputStr, - progInvokeInputEncoding = encoding - } = do - (_, errors, exitCode) <- rawSystemStdInOut verbosity - path args - (Just input) False - when (exitCode /= ExitSuccess) $ - die errors - where - input = case encoding of - IOEncodingText -> (inputStr, False) - IOEncodingUTF8 -> (toUTF8 inputStr, True) -- use binary mode for utf8 - -runProgramInvocation _ _ = - die "runProgramInvocation: not yet implemented for this form of invocation" - - -getProgramInvocationOutput :: Verbosity -> ProgramInvocation -> IO String -getProgramInvocationOutput verbosity - ProgramInvocation { - progInvokePath = path, - progInvokeArgs = args, - progInvokeEnv = [], - progInvokeCwd = Nothing, - progInvokeInput = Nothing, - progInvokeOutputEncoding = encoding - } = do - let utf8 = case encoding of IOEncodingUTF8 -> True; _ -> False - decode | utf8 = fromUTF8 . normaliseLineEndings - | otherwise = id - (output, errors, exitCode) <- rawSystemStdInOut verbosity - path args - Nothing utf8 - when (exitCode /= ExitSuccess) $ - die errors - return (decode output) - - -getProgramInvocationOutput _ _ = - die "getProgramInvocationOutput: not yet implemented for this form of invocation" - - --- | Like the unix xargs program. Useful for when we've got very long command --- lines that might overflow an OS limit on command line length and so you --- need to invoke a command multiple times to get all the args in. --- --- It takes four template invocations corresponding to the simple, initial, --- middle and last invocations. If the number of args given is small enough --- that we can get away with just a single invocation then the simple one is --- used: --- --- > $ simple args --- --- If the number of args given means that we need to use multiple invocations --- then the templates for the initial, middle and last invocations are used: --- --- > $ initial args_0 --- > $ middle args_1 --- > $ middle args_2 --- > ... --- > $ final args_n --- -multiStageProgramInvocation - :: ProgramInvocation - -> (ProgramInvocation, ProgramInvocation, ProgramInvocation) - -> [String] - -> [ProgramInvocation] -multiStageProgramInvocation simple (initial, middle, final) args = - - let argSize inv = length (progInvokePath inv) - + foldl' (\s a -> length a + 1 + s) 1 (progInvokeArgs inv) - fixedArgSize = maximum (map argSize [simple, initial, middle, final]) - chunkSize = maxCommandLineSize - fixedArgSize - - in case splitChunks chunkSize args of - [] -> [ simple ] - - [c] -> [ simple `appendArgs` c ] - - [c,c'] -> [ initial `appendArgs` c ] - ++ [ final `appendArgs` c'] - - (c:cs) -> [ initial `appendArgs` c ] - ++ [ middle `appendArgs` c'| c' <- init cs ] - ++ [ final `appendArgs` c'| let c' = last cs ] - - where - inv `appendArgs` as = inv { progInvokeArgs = progInvokeArgs inv ++ as } - - splitChunks len = unfoldr $ \s -> - if null s then Nothing - else Just (chunk len s) - - chunk len (s:_) | length s >= len = error toolong - chunk len ss = chunk' [] len ss - - chunk' acc _ [] = (reverse acc,[]) - chunk' acc len (s:ss) - | len' < len = chunk' (s:acc) (len-len'-1) ss - | otherwise = (reverse acc, s:ss) - where len' = length s - - toolong = "multiStageProgramInvocation: a single program arg is larger " - ++ "than the maximum command line length!" - - ---FIXME: discover this at configure time or runtime on unix --- The value is 32k on Windows and posix specifies a minimum of 4k --- but all sensible unixes use more than 4k. --- we could use getSysVar ArgumentLimit but that's in the unix lib --- -maxCommandLineSize :: Int -maxCommandLineSize = 30 * 1024 diff -Nru ghc-7.0.3/libraries/Cabal/Distribution/Simple/Program/Script.hs ghc-7.2.1/libraries/Cabal/Distribution/Simple/Program/Script.hs --- ghc-7.0.3/libraries/Cabal/Distribution/Simple/Program/Script.hs 2011-03-26 18:10:12.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/Distribution/Simple/Program/Script.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,105 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Program.Script --- Copyright : Duncan Coutts 2009 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This module provides an library interface to the @hc-pkg@ program. --- Currently only GHC and LHC have hc-pkg programs. - -module Distribution.Simple.Program.Script ( - - invocationAsSystemScript, - invocationAsShellScript, - invocationAsBatchFile, - ) where - -import Distribution.Simple.Program.Run - ( ProgramInvocation(..) ) -import Distribution.System - ( OS(..) ) - -import Data.Maybe - ( maybeToList ) - --- | Generate a system script, either POSIX shell script or Windows batch file --- as appropriate for the given system. --- -invocationAsSystemScript :: OS -> ProgramInvocation -> String -invocationAsSystemScript Windows = invocationAsBatchFile -invocationAsSystemScript _ = invocationAsShellScript - - --- | Generate a POSIX shell script that invokes a program. --- -invocationAsShellScript :: ProgramInvocation -> String -invocationAsShellScript - ProgramInvocation { - progInvokePath = path, - progInvokeArgs = args, - progInvokeEnv = envExtra, - progInvokeCwd = mcwd, - progInvokeInput = minput - } = unlines $ - [ "#!/bin/sh" ] - ++ [ "export " ++ var ++ "=" ++ quote val - | (var,val) <- envExtra ] - ++ [ "cd " ++ quote cwd | cwd <- maybeToList mcwd ] - ++ [ (case minput of - Nothing -> "" - Just input -> "echo " ++ quote input ++ " | ") - ++ unwords (map quote $ path : args) ++ " \"$@\""] - - where - quote :: String -> String - quote s = "'" ++ escape s ++ "'" - - escape [] = [] - escape ('\'':cs) = "'\\''" ++ escape cs - escape (c :cs) = c : escape cs - - --- | Generate a Windows batch file that invokes a program. --- -invocationAsBatchFile :: ProgramInvocation -> String -invocationAsBatchFile - ProgramInvocation { - progInvokePath = path, - progInvokeArgs = args, - progInvokeEnv = envExtra, - progInvokeCwd = mcwd, - progInvokeInput = minput - } = unlines $ - [ "@echo off" ] - ++ [ "set " ++ var ++ "=" ++ escape val | (var,val) <- envExtra ] - ++ [ "cd \"" ++ cwd ++ "\"" | cwd <- maybeToList mcwd ] - ++ case minput of - Nothing -> - [ path ++ concatMap (' ':) args ] - - Just input -> - [ "(" ] - ++ [ "echo " ++ escape line | line <- lines input ] - ++ [ ") | " - ++ "\"" ++ path ++ "\"" - ++ concatMap (\arg -> ' ':quote arg) args ] - - where - quote :: String -> String - quote s = "\"" ++ escapeQ s ++ "\"" - - escapeQ [] = [] - escapeQ ('"':cs) = "\"\"\"" ++ escapeQ cs - escapeQ (c :cs) = c : escapeQ cs - - escape [] = [] - escape ('|':cs) = "^|" ++ escape cs - escape ('<':cs) = "^<" ++ escape cs - escape ('>':cs) = "^>" ++ escape cs - escape ('&':cs) = "^&" ++ escape cs - escape ('(':cs) = "^(" ++ escape cs - escape (')':cs) = "^)" ++ escape cs - escape ('^':cs) = "^^" ++ escape cs - escape (c :cs) = c : escape cs diff -Nru ghc-7.0.3/libraries/Cabal/Distribution/Simple/Program/Types.hs ghc-7.2.1/libraries/Cabal/Distribution/Simple/Program/Types.hs --- ghc-7.0.3/libraries/Cabal/Distribution/Simple/Program/Types.hs 2011-03-26 18:10:12.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/Distribution/Simple/Program/Types.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,106 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Program.Types --- Copyright : Isaac Jones 2006, Duncan Coutts 2007-2009 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This provides an abstraction which deals with configuring and running --- programs. A 'Program' is a static notion of a known program. A --- 'ConfiguredProgram' is a 'Program' that has been found on the current --- machine and is ready to be run (possibly with some user-supplied default --- args). Configuring a program involves finding its location and if necessary --- finding its version. There's reasonable default behavior for trying to find --- \"foo\" in PATH, being able to override its location, etc. --- -module Distribution.Simple.Program.Types ( - -- * Program and functions for constructing them - Program(..), - simpleProgram, - - -- * Configured program and related functions - ConfiguredProgram(..), - programPath, - ProgArg, - ProgramLocation(..), - ) where - -import Distribution.Simple.Utils - ( findProgramLocation ) -import Distribution.Version - ( Version ) -import Distribution.Verbosity - ( Verbosity ) - --- | Represents a program which can be configured. -data Program = Program { - -- | The simple name of the program, eg. ghc - programName :: String, - - -- | A function to search for the program if it's location was not - -- specified by the user. Usually this will just be a - programFindLocation :: Verbosity -> IO (Maybe FilePath), - - -- | Try to find the version of the program. For many programs this is - -- not possible or is not necessary so it's ok to return Nothing. - programFindVersion :: Verbosity -> FilePath -> IO (Maybe Version), - - -- | A function to do any additional configuration after we have - -- located the program (and perhaps identified its version). It is - -- allowed to return additional flags that will be passed to the - -- program on every invocation. - programPostConf :: Verbosity -> ConfiguredProgram -> IO [ProgArg] - } - -type ProgArg = String - -data ConfiguredProgram = ConfiguredProgram { - -- | Just the name again - programId :: String, - - -- | The version of this program, if it is known. - programVersion :: Maybe Version, - - -- | Default command-line args for this program. - -- These flags will appear first on the command line, so they can be - -- overridden by subsequent flags. - programDefaultArgs :: [String], - - -- | Override command-line args for this program. - -- These flags will appear last on the command line, so they override - -- all earlier flags. - programOverrideArgs :: [String], - - -- | Location of the program. eg. @\/usr\/bin\/ghc-6.4@ - programLocation :: ProgramLocation - } deriving (Read, Show, Eq) - --- | Where a program was found. Also tells us whether it's specifed by user or --- not. This includes not just the path, but the program as well. -data ProgramLocation - = UserSpecified { locationPath :: FilePath } - -- ^The user gave the path to this program, - -- eg. --ghc-path=\/usr\/bin\/ghc-6.6 - | FoundOnSystem { locationPath :: FilePath } - -- ^The location of the program, as located by searching PATH. - deriving (Read, Show, Eq) - --- | The full path of a configured program. -programPath :: ConfiguredProgram -> FilePath -programPath = locationPath . programLocation - --- | Make a simple named program. --- --- By default we'll just search for it in the path and not try to find the --- version name. You can override these behaviours if necessary, eg: --- --- > simpleProgram "foo" { programFindLocation = ... , programFindVersion ... } --- -simpleProgram :: String -> Program -simpleProgram name = Program { - programName = name, - programFindLocation = \v -> findProgramLocation v name, - programFindVersion = \_ _ -> return Nothing, - programPostConf = \_ _ -> return [] - } diff -Nru ghc-7.0.3/libraries/Cabal/Distribution/Simple/Program.hs ghc-7.2.1/libraries/Cabal/Distribution/Simple/Program.hs --- ghc-7.0.3/libraries/Cabal/Distribution/Simple/Program.hs 2011-03-26 18:10:12.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/Distribution/Simple/Program.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,217 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Program --- Copyright : Isaac Jones 2006, Duncan Coutts 2007-2009 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This provides an abstraction which deals with configuring and running --- programs. A 'Program' is a static notion of a known program. A --- 'ConfiguredProgram' is a 'Program' that has been found on the current --- machine and is ready to be run (possibly with some user-supplied default --- args). Configuring a program involves finding its location and if necessary --- finding its version. There is also a 'ProgramConfiguration' type which holds --- configured and not-yet configured programs. It is the parameter to lots of --- actions elsewhere in Cabal that need to look up and run programs. If we had --- a Cabal monad, the 'ProgramConfiguration' would probably be a reader or --- state component of it. --- --- The module also defines all the known built-in 'Program's and the --- 'defaultProgramConfiguration' which contains them all. --- --- One nice thing about using it is that any program that is --- registered with Cabal will get some \"configure\" and \".cabal\" --- helpers like --with-foo-args --foo-path= and extra-foo-args. --- --- There's also good default behavior for trying to find \"foo\" in --- PATH, being able to override its location, etc. --- --- There's also a hook for adding programs in a Setup.lhs script. See --- hookedPrograms in 'Distribution.Simple.UserHooks'. This gives a --- hook user the ability to get the above flags and such so that they --- don't have to write all the PATH logic inside Setup.lhs. - -module Distribution.Simple.Program ( - -- * Program and functions for constructing them - Program(..) - , simpleProgram - , findProgramLocation - , findProgramVersion - - -- * Configured program and related functions - , ConfiguredProgram(..) - , programPath - , ProgArg - , ProgramLocation(..) - , runProgram - , getProgramOutput - - -- * Program invocations - , ProgramInvocation(..) - , emptyProgramInvocation - , simpleProgramInvocation - , programInvocation - , runProgramInvocation - , getProgramInvocationOutput - - -- * The collection of unconfigured and configured progams - , builtinPrograms - - -- * The collection of configured programs we can run - , ProgramConfiguration - , emptyProgramConfiguration - , defaultProgramConfiguration - , restoreProgramConfiguration - , addKnownProgram - , addKnownPrograms - , lookupKnownProgram - , knownPrograms - , userSpecifyPath - , userSpecifyPaths - , userMaybeSpecifyPath - , userSpecifyArgs - , userSpecifyArgss - , userSpecifiedArgs - , lookupProgram - , updateProgram - , configureProgram - , configureAllKnownPrograms - , reconfigurePrograms - , requireProgram - , requireProgramVersion - , runDbProgram - , getDbProgramOutput - - -- * Programs that Cabal knows about - , ghcProgram - , ghcPkgProgram - , lhcProgram - , lhcPkgProgram - , nhcProgram - , hmakeProgram - , jhcProgram - , hugsProgram - , ffihugsProgram - , uhcProgram - , gccProgram - , ranlibProgram - , arProgram - , stripProgram - , happyProgram - , alexProgram - , hsc2hsProgram - , c2hsProgram - , cpphsProgram - , hscolourProgram - , haddockProgram - , greencardProgram - , ldProgram - , tarProgram - , cppProgram - , pkgConfigProgram - - -- * deprecated - , rawSystemProgram - , rawSystemProgramStdout - , rawSystemProgramConf - , rawSystemProgramStdoutConf - , findProgramOnPath - - ) where - -import Distribution.Simple.Program.Types -import Distribution.Simple.Program.Run -import Distribution.Simple.Program.Db -import Distribution.Simple.Program.Builtin - -import Distribution.Simple.Utils - ( die, findProgramLocation, findProgramVersion ) -import Distribution.Verbosity - ( Verbosity ) - - --- | Runs the given configured program. --- -runProgram :: Verbosity -- ^Verbosity - -> ConfiguredProgram -- ^The program to run - -> [ProgArg] -- ^Any /extra/ arguments to add - -> IO () -runProgram verbosity prog args = - runProgramInvocation verbosity (programInvocation prog args) - - --- | Runs the given configured program and gets the output. --- -getProgramOutput :: Verbosity -- ^Verbosity - -> ConfiguredProgram -- ^The program to run - -> [ProgArg] -- ^Any /extra/ arguments to add - -> IO String -getProgramOutput verbosity prog args = - getProgramInvocationOutput verbosity (programInvocation prog args) - - --- | Looks up the given program in the program database and runs it. --- -runDbProgram :: Verbosity -- ^verbosity - -> Program -- ^The program to run - -> ProgramDb -- ^look up the program here - -> [ProgArg] -- ^Any /extra/ arguments to add - -> IO () -runDbProgram verbosity prog programDb args = - case lookupProgram prog programDb of - Nothing -> die notFound - Just configuredProg -> runProgram verbosity configuredProg args - where - notFound = "The program " ++ programName prog - ++ " is required but it could not be found" - --- | Looks up the given program in the program database and runs it. --- -getDbProgramOutput :: Verbosity -- ^verbosity - -> Program -- ^The program to run - -> ProgramDb -- ^look up the program here - -> [ProgArg] -- ^Any /extra/ arguments to add - -> IO String -getDbProgramOutput verbosity prog programDb args = - case lookupProgram prog programDb of - Nothing -> die notFound - Just configuredProg -> getProgramOutput verbosity configuredProg args - where - notFound = "The program " ++ programName prog - ++ " is required but it could not be found" - - ---------------------- --- Deprecated aliases --- - -rawSystemProgram :: Verbosity -> ConfiguredProgram - -> [ProgArg] -> IO () -rawSystemProgram = runProgram - -rawSystemProgramStdout :: Verbosity -> ConfiguredProgram - -> [ProgArg] -> IO String -rawSystemProgramStdout = getProgramOutput - -rawSystemProgramConf :: Verbosity -> Program -> ProgramConfiguration - -> [ProgArg] -> IO () -rawSystemProgramConf = runDbProgram - -rawSystemProgramStdoutConf :: Verbosity -> Program -> ProgramConfiguration - -> [ProgArg] -> IO String -rawSystemProgramStdoutConf = getDbProgramOutput - -type ProgramConfiguration = ProgramDb - -emptyProgramConfiguration, defaultProgramConfiguration :: ProgramConfiguration -emptyProgramConfiguration = emptyProgramDb -defaultProgramConfiguration = defaultProgramDb - -restoreProgramConfiguration :: [Program] -> ProgramConfiguration - -> ProgramConfiguration -restoreProgramConfiguration = restoreProgramDb - -{-# DEPRECATED findProgramOnPath "use findProgramLocation instead" #-} -findProgramOnPath :: String -> Verbosity -> IO (Maybe FilePath) -findProgramOnPath = flip findProgramLocation diff -Nru ghc-7.0.3/libraries/Cabal/Distribution/Simple/Register.hs ghc-7.2.1/libraries/Cabal/Distribution/Simple/Register.hs --- ghc-7.0.3/libraries/Cabal/Distribution/Simple/Register.hs 2011-03-26 18:10:12.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/Distribution/Simple/Register.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,389 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Register --- Copyright : Isaac Jones 2003-2004 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This module deals with registering and unregistering packages. There are a --- couple ways it can do this, one is to do it directly. Another is to generate --- a script that can be run later to do it. The idea here being that the user --- is shielded from the details of what command to use for package registration --- for a particular compiler. In practice this aspect was not especially --- popular so we also provide a way to simply generate the package registration --- file which then must be manually passed to @ghc-pkg@. It is possible to --- generate registration information for where the package is to be installed, --- or alternatively to register the package inplace in the build tree. The --- latter is occasionally handy, and will become more important when we try to --- build multi-package systems. --- --- This module does not delegate anything to the per-compiler modules but just --- mixes it all in in this module, which is rather unsatisfactory. The script --- generation and the unregister feature are not well used or tested. - -{- Copyright (c) 2003-2004, Isaac Jones -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - -module Distribution.Simple.Register ( - register, - unregister, - - registerPackage, - generateRegistrationInfo, - inplaceInstalledPackageInfo, - absoluteInstalledPackageInfo, - generalInstalledPackageInfo, - ) where - -import Distribution.Simple.LocalBuildInfo - ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) - , InstallDirs(..), absoluteInstallDirs ) -import Distribution.Simple.BuildPaths (haddockName) -import qualified Distribution.Simple.GHC as GHC -import qualified Distribution.Simple.LHC as LHC -import qualified Distribution.Simple.Hugs as Hugs -import qualified Distribution.Simple.UHC as UHC -import Distribution.Simple.Compiler - ( compilerVersion, CompilerFlavor(..), compilerFlavor - , PackageDBStack, registrationPackageDB ) -import Distribution.Simple.Program - ( ConfiguredProgram, runProgramInvocation - , requireProgram, lookupProgram, ghcPkgProgram, lhcPkgProgram ) -import Distribution.Simple.Program.Script - ( invocationAsSystemScript ) -import qualified Distribution.Simple.Program.HcPkg as HcPkg -import Distribution.Simple.Setup - ( RegisterFlags(..), CopyDest(..) - , fromFlag, fromFlagOrDefault, flagToMaybe ) -import Distribution.PackageDescription - ( PackageDescription(..), Library(..), BuildInfo(..), hcOptions ) -import Distribution.Package - ( Package(..), packageName, InstalledPackageId(..) ) -import Distribution.InstalledPackageInfo - ( InstalledPackageInfo, InstalledPackageInfo_(InstalledPackageInfo) - , showInstalledPackageInfo ) -import qualified Distribution.InstalledPackageInfo as IPI -import Distribution.Simple.Utils - ( writeUTF8File, writeFileAtomic - , die, notice, setupMessage ) -import Distribution.System - ( OS(..), buildOS ) -import Distribution.Text - ( display ) -import Distribution.Version ( Version(..) ) -import Distribution.Verbosity as Verbosity - ( Verbosity, normal ) -import Distribution.Compat.CopyFile - ( setFileExecutable ) - -import System.FilePath ((), (<.>), isAbsolute) -import System.Directory - ( getCurrentDirectory, removeDirectoryRecursive ) -import System.IO.Error (try) - -import Data.Maybe - ( isJust, fromMaybe, maybeToList ) -import Data.List - ( partition, nub ) - - --- ----------------------------------------------------------------------------- --- Registration - -register :: PackageDescription -> LocalBuildInfo - -> RegisterFlags -- ^Install in the user's database?; verbose - -> IO () -register pkg@PackageDescription { library = Just lib } - lbi@LocalBuildInfo { libraryConfig = Just clbi } regFlags - = do - - installedPkgInfo <- generateRegistrationInfo - verbosity pkg lib lbi clbi inplace distPref - - -- Three different modes: - case () of - _ | modeGenerateRegFile -> writeRegistrationFile installedPkgInfo - | modeGenerateRegScript -> writeRegisterScript installedPkgInfo - | otherwise -> registerPackage verbosity - installedPkgInfo pkg lbi inplace packageDbs - - where - modeGenerateRegFile = isJust (flagToMaybe (regGenPkgConf regFlags)) - regFile = fromMaybe (display (packageId pkg) <.> "conf") - (fromFlag (regGenPkgConf regFlags)) - - modeGenerateRegScript = fromFlag (regGenScript regFlags) - - inplace = fromFlag (regInPlace regFlags) - -- FIXME: there's really no guarantee this will work. - -- registering into a totally different db stack can - -- fail if dependencies cannot be satisfied. - packageDbs = nub $ withPackageDB lbi - ++ maybeToList (flagToMaybe (regPackageDB regFlags)) - distPref = fromFlag (regDistPref regFlags) - verbosity = fromFlag (regVerbosity regFlags) - - writeRegistrationFile installedPkgInfo = do - notice verbosity ("Creating package registration file: " ++ regFile) - writeUTF8File regFile (showInstalledPackageInfo installedPkgInfo) - - writeRegisterScript installedPkgInfo = - case compilerFlavor (compiler lbi) of - GHC -> do (ghcPkg, _) <- requireProgram verbosity ghcPkgProgram (withPrograms lbi) - writeHcPkgRegisterScript verbosity installedPkgInfo ghcPkg packageDbs - LHC -> do (lhcPkg, _) <- requireProgram verbosity lhcPkgProgram (withPrograms lbi) - writeHcPkgRegisterScript verbosity installedPkgInfo lhcPkg packageDbs - Hugs -> notice verbosity "Registration scripts not needed for hugs" - JHC -> notice verbosity "Registration scripts not needed for jhc" - NHC -> notice verbosity "Registration scripts not needed for nhc98" - UHC -> notice verbosity "Registration scripts not needed for uhc" - _ -> die "Registration scripts are not implemented for this compiler" - -register _ _ regFlags = notice verbosity "No package to register" - where - verbosity = fromFlag (regVerbosity regFlags) - - -generateRegistrationInfo :: Verbosity - -> PackageDescription - -> Library - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> Bool - -> FilePath - -> IO InstalledPackageInfo -generateRegistrationInfo verbosity pkg lib lbi clbi inplace distPref = do - --TODO: eliminate pwd! - pwd <- getCurrentDirectory - - --TODO: the method of setting the InstalledPackageId is compiler specific - -- this aspect should be delegated to a per-compiler helper. - let comp = compiler lbi - ipid <- - case compilerFlavor comp of - GHC | compilerVersion comp >= Version [6,11] [] -> do - s <- GHC.libAbiHash verbosity pkg lbi lib clbi - return (InstalledPackageId (display (packageId pkg) ++ '-':s)) - _other -> do - return (InstalledPackageId (display (packageId pkg))) - - let installedPkgInfo - | inplace = inplaceInstalledPackageInfo pwd distPref - pkg lib lbi clbi - | otherwise = absoluteInstalledPackageInfo - pkg lib lbi clbi - - return installedPkgInfo{ IPI.installedPackageId = ipid } - - -registerPackage :: Verbosity - -> InstalledPackageInfo - -> PackageDescription - -> LocalBuildInfo - -> Bool - -> PackageDBStack - -> IO () -registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs = do - setupMessage verbosity "Registering" (packageId pkg) - case compilerFlavor (compiler lbi) of - GHC -> GHC.registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs - LHC -> LHC.registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs - Hugs -> Hugs.registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs - UHC -> UHC.registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs - JHC -> notice verbosity "Registering for jhc (nothing to do)" - NHC -> notice verbosity "Registering for nhc98 (nothing to do)" - _ -> die "Registering is not implemented for this compiler" - - -writeHcPkgRegisterScript :: Verbosity - -> InstalledPackageInfo - -> ConfiguredProgram - -> PackageDBStack - -> IO () -writeHcPkgRegisterScript verbosity installedPkgInfo hcPkg packageDbs = do - let invocation = HcPkg.reregisterInvocation hcPkg Verbosity.normal - packageDbs (Right installedPkgInfo) - regScript = invocationAsSystemScript buildOS invocation - - notice verbosity ("Creating package registration script: " ++ regScriptFileName) - writeUTF8File regScriptFileName regScript - setFileExecutable regScriptFileName - -regScriptFileName :: FilePath -regScriptFileName = case buildOS of - Windows -> "register.bat" - _ -> "register.sh" - - --- ----------------------------------------------------------------------------- --- Making the InstalledPackageInfo - --- | Construct 'InstalledPackageInfo' for a library in a package, given a set --- of installation directories. --- -generalInstalledPackageInfo - :: ([FilePath] -> [FilePath]) -- ^ Translate relative include dir paths to - -- absolute paths. - -> PackageDescription - -> Library - -> ComponentLocalBuildInfo - -> InstallDirs FilePath - -> InstalledPackageInfo -generalInstalledPackageInfo adjustRelIncDirs pkg lib clbi installDirs = - InstalledPackageInfo { - --TODO: do not open-code this conversion from PackageId to InstalledPackageId - IPI.installedPackageId = InstalledPackageId (display (packageId pkg)), - IPI.sourcePackageId = packageId pkg, - IPI.license = license pkg, - IPI.copyright = copyright pkg, - IPI.maintainer = maintainer pkg, - IPI.author = author pkg, - IPI.stability = stability pkg, - IPI.homepage = homepage pkg, - IPI.pkgUrl = pkgUrl pkg, - IPI.description = description pkg, - IPI.category = category pkg, - IPI.exposed = libExposed lib, - IPI.exposedModules = exposedModules lib, - IPI.hiddenModules = otherModules bi, - IPI.importDirs = [ libdir installDirs | hasModules ], - IPI.libraryDirs = if hasLibrary - then libdir installDirs : extraLibDirs bi - else extraLibDirs bi, - IPI.hsLibraries = [ "HS" ++ display (packageId pkg) | hasLibrary ], - IPI.extraLibraries = extraLibs bi, - IPI.extraGHCiLibraries = [], - IPI.includeDirs = absinc ++ adjustRelIncDirs relinc, - IPI.includes = includes bi, - IPI.depends = map fst (componentPackageDeps clbi), - IPI.hugsOptions = hcOptions Hugs bi, - IPI.ccOptions = [], -- Note. NOT ccOptions bi! - -- We don't want cc-options to be propagated - -- to C compilations in other packages. - IPI.ldOptions = ldOptions bi, - IPI.frameworkDirs = [], - IPI.frameworks = frameworks bi, - IPI.haddockInterfaces = [haddockdir installDirs haddockName pkg], - IPI.haddockHTMLs = [htmldir installDirs] - } - where - bi = libBuildInfo lib - (absinc, relinc) = partition isAbsolute (includeDirs bi) - hasModules = not $ null (exposedModules lib) - && null (otherModules bi) - hasLibrary = hasModules || not (null (cSources bi)) - - --- | Construct 'InstalledPackageInfo' for a library that is inplace in the --- build tree. --- --- This function knows about the layout of inplace packages. --- -inplaceInstalledPackageInfo :: FilePath -- ^ top of the build tree - -> FilePath -- ^ location of the dist tree - -> PackageDescription - -> Library - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> InstalledPackageInfo -inplaceInstalledPackageInfo inplaceDir distPref pkg lib lbi clbi = - generalInstalledPackageInfo adjustReativeIncludeDirs pkg lib clbi installDirs - where - adjustReativeIncludeDirs = map (inplaceDir ) - installDirs = - (absoluteInstallDirs pkg lbi NoCopyDest) { - libdir = inplaceDir buildDir lbi, - datadir = inplaceDir, - datasubdir = distPref, - docdir = inplaceDocdir, - htmldir = inplaceHtmldir, - haddockdir = inplaceHtmldir - } - inplaceDocdir = inplaceDir distPref "doc" - inplaceHtmldir = inplaceDocdir "html" display (packageName pkg) - - --- | Construct 'InstalledPackageInfo' for the final install location of a --- library package. --- --- This function knows about the layout of installed packages. --- -absoluteInstalledPackageInfo :: PackageDescription - -> Library - -> LocalBuildInfo - -> ComponentLocalBuildInfo - -> InstalledPackageInfo -absoluteInstalledPackageInfo pkg lib lbi clbi = - generalInstalledPackageInfo adjustReativeIncludeDirs pkg lib clbi installDirs - where - -- For installed packages we install all include files into one dir, - -- whereas in the build tree they may live in multiple local dirs. - adjustReativeIncludeDirs _ - | null (installIncludes bi) = [] - | otherwise = [includedir installDirs] - bi = libBuildInfo lib - installDirs = absoluteInstallDirs pkg lbi NoCopyDest - --- ----------------------------------------------------------------------------- --- Unregistration - -unregister :: PackageDescription -> LocalBuildInfo -> RegisterFlags -> IO () -unregister pkg lbi regFlags = do - let pkgid = packageId pkg - genScript = fromFlag (regGenScript regFlags) - verbosity = fromFlag (regVerbosity regFlags) - packageDb = fromFlagOrDefault (registrationPackageDB (withPackageDB lbi)) - (regPackageDB regFlags) - installDirs = absoluteInstallDirs pkg lbi NoCopyDest - setupMessage verbosity "Unregistering" pkgid - case compilerFlavor (compiler lbi) of - GHC -> - let Just ghcPkg = lookupProgram ghcPkgProgram (withPrograms lbi) - invocation = HcPkg.unregisterInvocation ghcPkg Verbosity.normal - packageDb pkgid - in if genScript - then writeFileAtomic unregScriptFileName - (invocationAsSystemScript buildOS invocation) - else runProgramInvocation verbosity invocation - Hugs -> do - _ <- try $ removeDirectoryRecursive (libdir installDirs) - return () - NHC -> do - _ <- try $ removeDirectoryRecursive (libdir installDirs) - return () - _ -> - die ("only unregistering with GHC and Hugs is implemented") - -unregScriptFileName :: FilePath -unregScriptFileName = case buildOS of - Windows -> "unregister.bat" - _ -> "unregister.sh" diff -Nru ghc-7.0.3/libraries/Cabal/Distribution/Simple/Setup.hs ghc-7.2.1/libraries/Cabal/Distribution/Simple/Setup.hs --- ghc-7.0.3/libraries/Cabal/Distribution/Simple/Setup.hs 2011-03-26 18:10:12.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/Distribution/Simple/Setup.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,1549 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Setup --- Copyright : Isaac Jones 2003-2004 --- Duncan Coutts 2007 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This is a big module, but not very complicated. The code is very regular --- and repetitive. It defines the command line interface for all the Cabal --- commands. For each command (like @configure@, @build@ etc) it defines a type --- that holds all the flags, the default set of flags and a 'CommandUI' that --- maps command line flags to and from the corresponding flags type. --- --- All the flags types are instances of 'Monoid', see --- --- for an explanation. --- --- The types defined here get used in the front end and especially in --- @cabal-install@ which has to do quite a bit of manipulating sets of command --- line flags. --- --- This is actually relatively nice, it works quite well. The main change it --- needs is to unify it with the code for managing sets of fields that can be --- read and written from files. This would allow us to save configure flags in --- config files. - -{- All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - -module Distribution.Simple.Setup ( - - GlobalFlags(..), emptyGlobalFlags, defaultGlobalFlags, globalCommand, - ConfigFlags(..), emptyConfigFlags, defaultConfigFlags, configureCommand, - CopyFlags(..), emptyCopyFlags, defaultCopyFlags, copyCommand, - InstallFlags(..), emptyInstallFlags, defaultInstallFlags, installCommand, - HaddockFlags(..), emptyHaddockFlags, defaultHaddockFlags, haddockCommand, - HscolourFlags(..), emptyHscolourFlags, defaultHscolourFlags, hscolourCommand, - BuildFlags(..), emptyBuildFlags, defaultBuildFlags, buildCommand, - buildVerbose, - CleanFlags(..), emptyCleanFlags, defaultCleanFlags, cleanCommand, - RegisterFlags(..), emptyRegisterFlags, defaultRegisterFlags, registerCommand, - unregisterCommand, - SDistFlags(..), emptySDistFlags, defaultSDistFlags, sdistCommand, - TestFlags(..), emptyTestFlags, defaultTestFlags, testCommand, - TestShowDetails(..), - CopyDest(..), - configureArgs, configureOptions, configureCCompiler, configureLinker, - installDirsOptions, - - defaultDistPref, - - Flag(..), - toFlag, - fromFlag, - fromFlagOrDefault, - flagToMaybe, - flagToList, - boolOpt, boolOpt', trueArg, falseArg, optionVerbosity ) where - -import Distribution.Compiler () -import Distribution.ReadE -import Distribution.Text - ( Text(..), display ) -import qualified Distribution.Compat.ReadP as Parse -import qualified Text.PrettyPrint as Disp -import Distribution.Package ( Dependency(..) ) -import Distribution.PackageDescription - ( FlagName(..), FlagAssignment ) -import Distribution.Simple.Command hiding (boolOpt, boolOpt') -import qualified Distribution.Simple.Command as Command -import Distribution.Simple.Compiler - ( CompilerFlavor(..), defaultCompilerFlavor, PackageDB(..) - , OptimisationLevel(..), flagToOptimisationLevel ) -import Distribution.Simple.Utils - ( wrapLine, lowercase, intercalate ) -import Distribution.Simple.Program (Program(..), ProgramConfiguration, - requireProgram, - programInvocation, progInvokePath, progInvokeArgs, - knownPrograms, - addKnownProgram, emptyProgramConfiguration, - haddockProgram, ghcProgram, gccProgram, ldProgram) -import Distribution.Simple.InstallDirs - ( InstallDirs(..), CopyDest(..), - PathTemplate, toPathTemplate, fromPathTemplate ) -import Distribution.Verbosity - -import Data.List ( sort ) -import Data.Char ( isSpace, isAlpha ) -import Data.Monoid ( Monoid(..) ) - --- FIXME Not sure where this should live -defaultDistPref :: FilePath -defaultDistPref = "dist" - --- ------------------------------------------------------------ --- * Flag type --- ------------------------------------------------------------ - --- | All flags are monoids, they come in two flavours: --- --- 1. list flags eg --- --- > --ghc-option=foo --ghc-option=bar --- --- gives us all the values ["foo", "bar"] --- --- 2. singular value flags, eg: --- --- > --enable-foo --disable-foo --- --- gives us Just False --- So this Flag type is for the latter singular kind of flag. --- Its monoid instance gives us the behaviour where it starts out as --- 'NoFlag' and later flags override earlier ones. --- -data Flag a = Flag a | NoFlag deriving (Show, Read, Eq) - -instance Functor Flag where - fmap f (Flag x) = Flag (f x) - fmap _ NoFlag = NoFlag - -instance Monoid (Flag a) where - mempty = NoFlag - _ `mappend` f@(Flag _) = f - f `mappend` NoFlag = f - -instance Bounded a => Bounded (Flag a) where - minBound = toFlag minBound - maxBound = toFlag maxBound - -instance Enum a => Enum (Flag a) where - fromEnum = fromEnum . fromFlag - toEnum = toFlag . toEnum - enumFrom (Flag a) = map toFlag . enumFrom $ a - enumFrom _ = [] - enumFromThen (Flag a) (Flag b) = toFlag `map` enumFromThen a b - enumFromThen _ _ = [] - enumFromTo (Flag a) (Flag b) = toFlag `map` enumFromTo a b - enumFromTo _ _ = [] - enumFromThenTo (Flag a) (Flag b) (Flag c) = toFlag `map` enumFromThenTo a b c - enumFromThenTo _ _ _ = [] - -toFlag :: a -> Flag a -toFlag = Flag - -fromFlag :: Flag a -> a -fromFlag (Flag x) = x -fromFlag NoFlag = error "fromFlag NoFlag. Use fromFlagOrDefault" - -fromFlagOrDefault :: a -> Flag a -> a -fromFlagOrDefault _ (Flag x) = x -fromFlagOrDefault def NoFlag = def - -flagToMaybe :: Flag a -> Maybe a -flagToMaybe (Flag x) = Just x -flagToMaybe NoFlag = Nothing - -flagToList :: Flag a -> [a] -flagToList (Flag x) = [x] -flagToList NoFlag = [] - --- ------------------------------------------------------------ --- * Global flags --- ------------------------------------------------------------ - --- In fact since individual flags types are monoids and these are just sets of --- flags then they are also monoids pointwise. This turns out to be really --- useful. The mempty is the set of empty flags and mappend allows us to --- override specific flags. For example we can start with default flags and --- override with the ones we get from a file or the command line, or both. - --- | Flags that apply at the top level, not to any sub-command. -data GlobalFlags = GlobalFlags { - globalVersion :: Flag Bool, - globalNumericVersion :: Flag Bool - } - -defaultGlobalFlags :: GlobalFlags -defaultGlobalFlags = GlobalFlags { - globalVersion = Flag False, - globalNumericVersion = Flag False - } - -globalCommand :: CommandUI GlobalFlags -globalCommand = CommandUI { - commandName = "", - commandSynopsis = "", - commandUsage = \_ -> - "This Setup program uses the Haskell Cabal Infrastructure.\n" - ++ "See http://www.haskell.org/cabal/ for more information.\n", - commandDescription = Just $ \pname -> - "For more information about a command use\n" - ++ " " ++ pname ++ " COMMAND --help\n\n" - ++ "Typical steps for installing Cabal packages:\n" - ++ concat [ " " ++ pname ++ " " ++ x ++ "\n" - | x <- ["configure", "build", "install"]], - commandDefaultFlags = defaultGlobalFlags, - commandOptions = \_ -> - [option ['V'] ["version"] - "Print version information" - globalVersion (\v flags -> flags { globalVersion = v }) - trueArg - ,option [] ["numeric-version"] - "Print just the version number" - globalNumericVersion (\v flags -> flags { globalNumericVersion = v }) - trueArg - ] - } - -emptyGlobalFlags :: GlobalFlags -emptyGlobalFlags = mempty - -instance Monoid GlobalFlags where - mempty = GlobalFlags { - globalVersion = mempty, - globalNumericVersion = mempty - } - mappend a b = GlobalFlags { - globalVersion = combine globalVersion, - globalNumericVersion = combine globalNumericVersion - } - where combine field = field a `mappend` field b - --- ------------------------------------------------------------ --- * Config flags --- ------------------------------------------------------------ - --- | Flags to @configure@ command -data ConfigFlags = ConfigFlags { - --FIXME: the configPrograms is only here to pass info through to configure - -- because the type of configure is constrained by the UserHooks. - -- when we change UserHooks next we should pass the initial - -- ProgramConfiguration directly and not via ConfigFlags - configPrograms :: ProgramConfiguration, -- ^All programs that cabal may run - - configProgramPaths :: [(String, FilePath)], -- ^user specifed programs paths - configProgramArgs :: [(String, [String])], -- ^user specifed programs args - configHcFlavor :: Flag CompilerFlavor, -- ^The \"flavor\" of the compiler, sugh as GHC or Hugs. - configHcPath :: Flag FilePath, -- ^given compiler location - configHcPkg :: Flag FilePath, -- ^given hc-pkg location - configVanillaLib :: Flag Bool, -- ^Enable vanilla library - configProfLib :: Flag Bool, -- ^Enable profiling in the library - configSharedLib :: Flag Bool, -- ^Build shared library - configProfExe :: Flag Bool, -- ^Enable profiling in the executables. - configConfigureArgs :: [String], -- ^Extra arguments to @configure@ - configOptimization :: Flag OptimisationLevel, -- ^Enable optimization. - configProgPrefix :: Flag PathTemplate, -- ^Installed executable prefix. - configProgSuffix :: Flag PathTemplate, -- ^Installed executable suffix. - configInstallDirs :: InstallDirs (Flag PathTemplate), -- ^Installation paths - configScratchDir :: Flag FilePath, - configExtraLibDirs :: [FilePath], -- ^ path to search for extra libraries - configExtraIncludeDirs :: [FilePath], -- ^ path to search for header files - - configDistPref :: Flag FilePath, -- ^"dist" prefix - configVerbosity :: Flag Verbosity, -- ^verbosity level - configUserInstall :: Flag Bool, -- ^The --user\/--global flag - configPackageDB :: Flag PackageDB, -- ^Which package DB to use - configGHCiLib :: Flag Bool, -- ^Enable compiling library for GHCi - configSplitObjs :: Flag Bool, -- ^Enable -split-objs with GHC - configStripExes :: Flag Bool, -- ^Enable executable stripping - configConstraints :: [Dependency], -- ^Additional constraints for - -- dependencies - configConfigurationsFlags :: FlagAssignment, - configTests :: Flag Bool -- ^Enable test suite compilation - } - deriving (Read,Show) - -defaultConfigFlags :: ProgramConfiguration -> ConfigFlags -defaultConfigFlags progConf = emptyConfigFlags { - configPrograms = progConf, - configHcFlavor = maybe NoFlag Flag defaultCompilerFlavor, - configVanillaLib = Flag True, - configProfLib = Flag False, - configSharedLib = Flag False, - configProfExe = Flag False, - configOptimization = Flag NormalOptimisation, - configProgPrefix = Flag (toPathTemplate ""), - configProgSuffix = Flag (toPathTemplate ""), - configDistPref = Flag defaultDistPref, - configVerbosity = Flag normal, - configUserInstall = Flag False, --TODO: reverse this - configGHCiLib = Flag True, - configSplitObjs = Flag False, -- takes longer, so turn off by default - configStripExes = Flag True, - configTests = Flag False - } - -configureCommand :: ProgramConfiguration -> CommandUI ConfigFlags -configureCommand progConf = makeCommand name shortDesc longDesc defaultFlags options - where - name = "configure" - shortDesc = "Prepare to build the package." - longDesc = Just (\_ -> programFlagsDescription progConf) - defaultFlags = defaultConfigFlags progConf - options showOrParseArgs = - configureOptions showOrParseArgs - ++ programConfigurationPaths progConf showOrParseArgs - configProgramPaths (\v fs -> fs { configProgramPaths = v }) - ++ programConfigurationOptions progConf showOrParseArgs - configProgramArgs (\v fs -> fs { configProgramArgs = v }) - - -configureOptions :: ShowOrParseArgs -> [OptionField ConfigFlags] -configureOptions showOrParseArgs = - [optionVerbosity configVerbosity (\v flags -> flags { configVerbosity = v }) - ,optionDistPref - configDistPref (\d flags -> flags { configDistPref = d }) - showOrParseArgs - - ,option [] ["compiler"] "compiler" - configHcFlavor (\v flags -> flags { configHcFlavor = v }) - (choiceOpt [ (Flag GHC, ("g", ["ghc"]), "compile with GHC") - , (Flag NHC, ([] , ["nhc98"]), "compile with NHC") - , (Flag JHC, ([] , ["jhc"]), "compile with JHC") - , (Flag LHC, ([] , ["lhc"]), "compile with LHC") - , (Flag Hugs,([] , ["hugs"]), "compile with Hugs") - , (Flag UHC, ([] , ["uhc"]), "compile with UHC")]) - - ,option "w" ["with-compiler"] - "give the path to a particular compiler" - configHcPath (\v flags -> flags { configHcPath = v }) - (reqArgFlag "PATH") - - ,option "" ["with-hc-pkg"] - "give the path to the package tool" - configHcPkg (\v flags -> flags { configHcPkg = v }) - (reqArgFlag "PATH") - ] - ++ map liftInstallDirs installDirsOptions - ++ [option "b" ["scratchdir"] - "directory to receive the built package (hugs-only)" - configScratchDir (\v flags -> flags { configScratchDir = v }) - (reqArgFlag "DIR") - --TODO: eliminate scratchdir flag - - ,option "" ["program-prefix"] - "prefix to be applied to installed executables" - configProgPrefix - (\v flags -> flags { configProgPrefix = v }) - (reqPathTemplateArgFlag "PREFIX") - - ,option "" ["program-suffix"] - "suffix to be applied to installed executables" - configProgSuffix (\v flags -> flags { configProgSuffix = v } ) - (reqPathTemplateArgFlag "SUFFIX") - - ,option "" ["library-vanilla"] - "Vanilla libraries" - configVanillaLib (\v flags -> flags { configVanillaLib = v }) - (boolOpt [] []) - - ,option "p" ["library-profiling"] - "Library profiling" - configProfLib (\v flags -> flags { configProfLib = v }) - (boolOpt "p" []) - - ,option "" ["shared"] - "Shared library" - configSharedLib (\v flags -> flags { configSharedLib = v }) - (boolOpt [] []) - - ,option "" ["executable-profiling"] - "Executable profiling" - configProfExe (\v flags -> flags { configProfExe = v }) - (boolOpt [] []) - ,multiOption "optimization" - configOptimization (\v flags -> flags { configOptimization = v }) - [optArg' "n" (Flag . flagToOptimisationLevel) - (\f -> case f of - Flag NoOptimisation -> [] - Flag NormalOptimisation -> [Nothing] - Flag MaximumOptimisation -> [Just "2"] - _ -> []) - "O" ["enable-optimization","enable-optimisation"] - "Build with optimization (n is 0--2, default is 1)", - noArg (Flag NoOptimisation) [] - ["disable-optimization","disable-optimisation"] - "Build without optimization" - ] - - ,option "" ["library-for-ghci"] - "compile library for use with GHCi" - configGHCiLib (\v flags -> flags { configGHCiLib = v }) - (boolOpt [] []) - - ,option "" ["split-objs"] - "split library into smaller objects to reduce binary sizes (GHC 6.6+)" - configSplitObjs (\v flags -> flags { configSplitObjs = v }) - (boolOpt [] []) - - ,option "" ["executable-stripping"] - "strip executables upon installation to reduce binary sizes" - configStripExes (\v flags -> flags { configStripExes = v }) - (boolOpt [] []) - - ,option "" ["configure-option"] - "Extra option for configure" - configConfigureArgs (\v flags -> flags { configConfigureArgs = v }) - (reqArg' "OPT" (\x -> [x]) id) - - ,option "" ["user-install"] - "doing a per-user installation" - configUserInstall (\v flags -> flags { configUserInstall = v }) - (boolOpt' ([],["user"]) ([], ["global"])) - - ,option "" ["package-db"] - "Use a specific package database (to satisfy dependencies and register in)" - configPackageDB (\v flags -> flags { configPackageDB = v }) - (reqArg' "PATH" (Flag . SpecificPackageDB) - (\f -> case f of - Flag (SpecificPackageDB db) -> [db] - _ -> [])) - - ,option "f" ["flags"] - "Force values for the given flags in Cabal conditionals in the .cabal file. E.g., --flags=\"debug -usebytestrings\" forces the flag \"debug\" to true and \"usebytestrings\" to false." - configConfigurationsFlags (\v flags -> flags { configConfigurationsFlags = v }) - (reqArg' "FLAGS" readFlagList showFlagList) - - ,option "" ["extra-include-dirs"] - "A list of directories to search for header files" - configExtraIncludeDirs (\v flags -> flags {configExtraIncludeDirs = v}) - (reqArg' "PATH" (\x -> [x]) id) - - ,option "" ["extra-lib-dirs"] - "A list of directories to search for external libraries" - configExtraLibDirs (\v flags -> flags {configExtraLibDirs = v}) - (reqArg' "PATH" (\x -> [x]) id) - ,option "" ["constraint"] - "A list of additional constraints on the dependencies." - configConstraints (\v flags -> flags { configConstraints = v}) - (reqArg "DEPENDENCY" - (readP_to_E (const "dependency expected") ((\x -> [x]) `fmap` parse)) - (map (\x -> display x))) - ,option "" ["tests"] - "dependency checking and compilation for test suites listed in the package description file." - configTests (\v flags -> flags { configTests = v }) - (boolOpt [] []) - ] - where - readFlagList :: String -> FlagAssignment - readFlagList = map tagWithValue . words - where tagWithValue ('-':fname) = (FlagName (lowercase fname), False) - tagWithValue fname = (FlagName (lowercase fname), True) - - showFlagList :: FlagAssignment -> [String] - showFlagList fs = [ if not set then '-':fname else fname - | (FlagName fname, set) <- fs] - - liftInstallDirs = - liftOption configInstallDirs (\v flags -> flags { configInstallDirs = v }) - - reqPathTemplateArgFlag title _sf _lf d get set = - reqArgFlag title _sf _lf d - (fmap fromPathTemplate . get) (set . fmap toPathTemplate) - -installDirsOptions :: [OptionField (InstallDirs (Flag PathTemplate))] -installDirsOptions = - [ option "" ["prefix"] - "bake this prefix in preparation of installation" - prefix (\v flags -> flags { prefix = v }) - installDirArg - - , option "" ["bindir"] - "installation directory for executables" - bindir (\v flags -> flags { bindir = v }) - installDirArg - - , option "" ["libdir"] - "installation directory for libraries" - libdir (\v flags -> flags { libdir = v }) - installDirArg - - , option "" ["libsubdir"] - "subdirectory of libdir in which libs are installed" - libsubdir (\v flags -> flags { libsubdir = v }) - installDirArg - - , option "" ["libexecdir"] - "installation directory for program executables" - libexecdir (\v flags -> flags { libexecdir = v }) - installDirArg - - , option "" ["datadir"] - "installation directory for read-only data" - datadir (\v flags -> flags { datadir = v }) - installDirArg - - , option "" ["datasubdir"] - "subdirectory of datadir in which data files are installed" - datasubdir (\v flags -> flags { datasubdir = v }) - installDirArg - - , option "" ["docdir"] - "installation directory for documentation" - docdir (\v flags -> flags { docdir = v }) - installDirArg - - , option "" ["htmldir"] - "installation directory for HTML documentation" - htmldir (\v flags -> flags { htmldir = v }) - installDirArg - - , option "" ["haddockdir"] - "installation directory for haddock interfaces" - haddockdir (\v flags -> flags { haddockdir = v }) - installDirArg - ] - where - installDirArg _sf _lf d get set = - reqArgFlag "DIR" _sf _lf d - (fmap fromPathTemplate . get) (set . fmap toPathTemplate) - -emptyConfigFlags :: ConfigFlags -emptyConfigFlags = mempty - -instance Monoid ConfigFlags where - mempty = ConfigFlags { - configPrograms = error "FIXME: remove configPrograms", - configProgramPaths = mempty, - configProgramArgs = mempty, - configHcFlavor = mempty, - configHcPath = mempty, - configHcPkg = mempty, - configVanillaLib = mempty, - configProfLib = mempty, - configSharedLib = mempty, - configProfExe = mempty, - configConfigureArgs = mempty, - configOptimization = mempty, - configProgPrefix = mempty, - configProgSuffix = mempty, - configInstallDirs = mempty, - configScratchDir = mempty, - configDistPref = mempty, - configVerbosity = mempty, - configUserInstall = mempty, - configPackageDB = mempty, - configGHCiLib = mempty, - configSplitObjs = mempty, - configStripExes = mempty, - configExtraLibDirs = mempty, - configConstraints = mempty, - configExtraIncludeDirs = mempty, - configConfigurationsFlags = mempty, - configTests = mempty - } - mappend a b = ConfigFlags { - configPrograms = configPrograms b, - configProgramPaths = combine configProgramPaths, - configProgramArgs = combine configProgramArgs, - configHcFlavor = combine configHcFlavor, - configHcPath = combine configHcPath, - configHcPkg = combine configHcPkg, - configVanillaLib = combine configVanillaLib, - configProfLib = combine configProfLib, - configSharedLib = combine configSharedLib, - configProfExe = combine configProfExe, - configConfigureArgs = combine configConfigureArgs, - configOptimization = combine configOptimization, - configProgPrefix = combine configProgPrefix, - configProgSuffix = combine configProgSuffix, - configInstallDirs = combine configInstallDirs, - configScratchDir = combine configScratchDir, - configDistPref = combine configDistPref, - configVerbosity = combine configVerbosity, - configUserInstall = combine configUserInstall, - configPackageDB = combine configPackageDB, - configGHCiLib = combine configGHCiLib, - configSplitObjs = combine configSplitObjs, - configStripExes = combine configStripExes, - configExtraLibDirs = combine configExtraLibDirs, - configConstraints = combine configConstraints, - configExtraIncludeDirs = combine configExtraIncludeDirs, - configConfigurationsFlags = combine configConfigurationsFlags, - configTests = combine configTests - } - where combine field = field a `mappend` field b - --- ------------------------------------------------------------ --- * Copy flags --- ------------------------------------------------------------ - --- | Flags to @copy@: (destdir, copy-prefix (backwards compat), verbosity) -data CopyFlags = CopyFlags { - copyDest :: Flag CopyDest, - copyDistPref :: Flag FilePath, - copyVerbosity :: Flag Verbosity - } - deriving Show - -defaultCopyFlags :: CopyFlags -defaultCopyFlags = CopyFlags { - copyDest = Flag NoCopyDest, - copyDistPref = Flag defaultDistPref, - copyVerbosity = Flag normal - } - -copyCommand :: CommandUI CopyFlags -copyCommand = makeCommand name shortDesc longDesc defaultCopyFlags options - where - name = "copy" - shortDesc = "Copy the files into the install locations." - longDesc = Just $ \_ -> - "Does not call register, and allows a prefix at install time\n" - ++ "Without the --destdir flag, configure determines location.\n" - options showOrParseArgs = - [optionVerbosity copyVerbosity (\v flags -> flags { copyVerbosity = v }) - - ,optionDistPref - copyDistPref (\d flags -> flags { copyDistPref = d }) - showOrParseArgs - - ,option "" ["destdir"] - "directory to copy files to, prepended to installation directories" - copyDest (\v flags -> flags { copyDest = v }) - (reqArg "DIR" (succeedReadE (Flag . CopyTo)) - (\f -> case f of Flag (CopyTo p) -> [p]; _ -> [])) - ] - -emptyCopyFlags :: CopyFlags -emptyCopyFlags = mempty - -instance Monoid CopyFlags where - mempty = CopyFlags { - copyDest = mempty, - copyDistPref = mempty, - copyVerbosity = mempty - } - mappend a b = CopyFlags { - copyDest = combine copyDest, - copyDistPref = combine copyDistPref, - copyVerbosity = combine copyVerbosity - } - where combine field = field a `mappend` field b - --- ------------------------------------------------------------ --- * Install flags --- ------------------------------------------------------------ - --- | Flags to @install@: (package db, verbosity) -data InstallFlags = InstallFlags { - installPackageDB :: Flag PackageDB, - installDistPref :: Flag FilePath, - installUseWrapper :: Flag Bool, - installInPlace :: Flag Bool, - installVerbosity :: Flag Verbosity - } - deriving Show - -defaultInstallFlags :: InstallFlags -defaultInstallFlags = InstallFlags { - installPackageDB = NoFlag, - installDistPref = Flag defaultDistPref, - installUseWrapper = Flag False, - installInPlace = Flag False, - installVerbosity = Flag normal - } - -installCommand :: CommandUI InstallFlags -installCommand = makeCommand name shortDesc longDesc defaultInstallFlags options - where - name = "install" - shortDesc = "Copy the files into the install locations. Run register." - longDesc = Just $ \_ -> - "Unlike the copy command, install calls the register command.\n" - ++ "If you want to install into a location that is not what was\n" - ++ "specified in the configure step, use the copy command.\n" - options showOrParseArgs = - [optionVerbosity installVerbosity (\v flags -> flags { installVerbosity = v }) - ,optionDistPref - installDistPref (\d flags -> flags { installDistPref = d }) - showOrParseArgs - - ,option "" ["inplace"] - "install the package in the install subdirectory of the dist prefix, so it can be used without being installed" - installInPlace (\v flags -> flags { installInPlace = v }) - trueArg - - ,option "" ["shell-wrappers"] - "using shell script wrappers around executables" - installUseWrapper (\v flags -> flags { installUseWrapper = v }) - (boolOpt [] []) - - ,option "" ["package-db"] "" - installPackageDB (\v flags -> flags { installPackageDB = v }) - (choiceOpt [ (Flag UserPackageDB, ([],["user"]), - "upon configuration register this package in the user's local package database") - , (Flag GlobalPackageDB, ([],["global"]), - "(default) upon configuration register this package in the system-wide package database")]) - ] - -emptyInstallFlags :: InstallFlags -emptyInstallFlags = mempty - -instance Monoid InstallFlags where - mempty = InstallFlags{ - installPackageDB = mempty, - installDistPref = mempty, - installUseWrapper = mempty, - installInPlace = mempty, - installVerbosity = mempty - } - mappend a b = InstallFlags{ - installPackageDB = combine installPackageDB, - installDistPref = combine installDistPref, - installUseWrapper = combine installUseWrapper, - installInPlace = combine installInPlace, - installVerbosity = combine installVerbosity - } - where combine field = field a `mappend` field b - --- ------------------------------------------------------------ --- * SDist flags --- ------------------------------------------------------------ - --- | Flags to @sdist@: (snapshot, verbosity) -data SDistFlags = SDistFlags { - sDistSnapshot :: Flag Bool, - sDistDistPref :: Flag FilePath, - sDistVerbosity :: Flag Verbosity - } - deriving Show - -defaultSDistFlags :: SDistFlags -defaultSDistFlags = SDistFlags { - sDistSnapshot = Flag False, - sDistDistPref = Flag defaultDistPref, - sDistVerbosity = Flag normal - } - -sdistCommand :: CommandUI SDistFlags -sdistCommand = makeCommand name shortDesc longDesc defaultSDistFlags options - where - name = "sdist" - shortDesc = "Generate a source distribution file (.tar.gz)." - longDesc = Nothing - options showOrParseArgs = - [optionVerbosity sDistVerbosity (\v flags -> flags { sDistVerbosity = v }) - ,optionDistPref - sDistDistPref (\d flags -> flags { sDistDistPref = d }) - showOrParseArgs - - ,option "" ["snapshot"] - "Produce a snapshot source distribution" - sDistSnapshot (\v flags -> flags { sDistSnapshot = v }) - trueArg - ] - -emptySDistFlags :: SDistFlags -emptySDistFlags = mempty - -instance Monoid SDistFlags where - mempty = SDistFlags { - sDistSnapshot = mempty, - sDistDistPref = mempty, - sDistVerbosity = mempty - } - mappend a b = SDistFlags { - sDistSnapshot = combine sDistSnapshot, - sDistDistPref = combine sDistDistPref, - sDistVerbosity = combine sDistVerbosity - } - where combine field = field a `mappend` field b - --- ------------------------------------------------------------ --- * Register flags --- ------------------------------------------------------------ - --- | Flags to @register@ and @unregister@: (user package, gen-script, --- in-place, verbosity) -data RegisterFlags = RegisterFlags { - regPackageDB :: Flag PackageDB, - regGenScript :: Flag Bool, - regGenPkgConf :: Flag (Maybe FilePath), - regInPlace :: Flag Bool, - regDistPref :: Flag FilePath, - regVerbosity :: Flag Verbosity - } - deriving Show - -defaultRegisterFlags :: RegisterFlags -defaultRegisterFlags = RegisterFlags { - regPackageDB = NoFlag, - regGenScript = Flag False, - regGenPkgConf = NoFlag, - regInPlace = Flag False, - regDistPref = Flag defaultDistPref, - regVerbosity = Flag normal - } - -registerCommand :: CommandUI RegisterFlags -registerCommand = makeCommand name shortDesc longDesc defaultRegisterFlags options - where - name = "register" - shortDesc = "Register this package with the compiler." - longDesc = Nothing - options showOrParseArgs = - [optionVerbosity regVerbosity (\v flags -> flags { regVerbosity = v }) - ,optionDistPref - regDistPref (\d flags -> flags { regDistPref = d }) - showOrParseArgs - - ,option "" ["packageDB"] "" - regPackageDB (\v flags -> flags { regPackageDB = v }) - (choiceOpt [ (Flag UserPackageDB, ([],["user"]), - "upon registration, register this package in the user's local package database") - , (Flag GlobalPackageDB, ([],["global"]), - "(default)upon registration, register this package in the system-wide package database")]) - - ,option "" ["inplace"] - "register the package in the build location, so it can be used without being installed" - regInPlace (\v flags -> flags { regInPlace = v }) - trueArg - - ,option "" ["gen-script"] - "instead of registering, generate a script to register later" - regGenScript (\v flags -> flags { regGenScript = v }) - trueArg - - ,option "" ["gen-pkg-config"] - "instead of registering, generate a package registration file" - regGenPkgConf (\v flags -> flags { regGenPkgConf = v }) - (optArg' "PKG" Flag flagToList) - ] - -unregisterCommand :: CommandUI RegisterFlags -unregisterCommand = makeCommand name shortDesc longDesc defaultRegisterFlags options - where - name = "unregister" - shortDesc = "Unregister this package with the compiler." - longDesc = Nothing - options showOrParseArgs = - [optionVerbosity regVerbosity (\v flags -> flags { regVerbosity = v }) - ,optionDistPref - regDistPref (\d flags -> flags { regDistPref = d }) - showOrParseArgs - - ,option "" ["user"] "" - regPackageDB (\v flags -> flags { regPackageDB = v }) - (choiceOpt [ (Flag UserPackageDB, ([],["user"]), - "unregister this package in the user's local package database") - , (Flag GlobalPackageDB, ([],["global"]), - "(default) unregister this package in the system-wide package database")]) - - ,option "" ["gen-script"] - "Instead of performing the unregister command, generate a script to unregister later" - regGenScript (\v flags -> flags { regGenScript = v }) - trueArg - ] - -emptyRegisterFlags :: RegisterFlags -emptyRegisterFlags = mempty - -instance Monoid RegisterFlags where - mempty = RegisterFlags { - regPackageDB = mempty, - regGenScript = mempty, - regGenPkgConf = mempty, - regInPlace = mempty, - regDistPref = mempty, - regVerbosity = mempty - } - mappend a b = RegisterFlags { - regPackageDB = combine regPackageDB, - regGenScript = combine regGenScript, - regGenPkgConf = combine regGenPkgConf, - regInPlace = combine regInPlace, - regDistPref = combine regDistPref, - regVerbosity = combine regVerbosity - } - where combine field = field a `mappend` field b - --- ------------------------------------------------------------ --- * HsColour flags --- ------------------------------------------------------------ - -data HscolourFlags = HscolourFlags { - hscolourCSS :: Flag FilePath, - hscolourExecutables :: Flag Bool, - hscolourDistPref :: Flag FilePath, - hscolourVerbosity :: Flag Verbosity - } - deriving Show - -emptyHscolourFlags :: HscolourFlags -emptyHscolourFlags = mempty - -defaultHscolourFlags :: HscolourFlags -defaultHscolourFlags = HscolourFlags { - hscolourCSS = NoFlag, - hscolourExecutables = Flag False, - hscolourDistPref = Flag defaultDistPref, - hscolourVerbosity = Flag normal - } - -instance Monoid HscolourFlags where - mempty = HscolourFlags { - hscolourCSS = mempty, - hscolourExecutables = mempty, - hscolourDistPref = mempty, - hscolourVerbosity = mempty - } - mappend a b = HscolourFlags { - hscolourCSS = combine hscolourCSS, - hscolourExecutables = combine hscolourExecutables, - hscolourDistPref = combine hscolourDistPref, - hscolourVerbosity = combine hscolourVerbosity - } - where combine field = field a `mappend` field b - -hscolourCommand :: CommandUI HscolourFlags -hscolourCommand = makeCommand name shortDesc longDesc defaultHscolourFlags options - where - name = "hscolour" - shortDesc = "Generate HsColour colourised code, in HTML format." - longDesc = Just (\_ -> "Requires hscolour.\n") - options showOrParseArgs = - [optionVerbosity hscolourVerbosity (\v flags -> flags { hscolourVerbosity = v }) - ,optionDistPref - hscolourDistPref (\d flags -> flags { hscolourDistPref = d }) - showOrParseArgs - - ,option "" ["executables"] - "Run hscolour for Executables targets" - hscolourExecutables (\v flags -> flags { hscolourExecutables = v }) - trueArg - - ,option "" ["css"] - "Use a cascading style sheet" - hscolourCSS (\v flags -> flags { hscolourCSS = v }) - (reqArgFlag "PATH") - ] - --- ------------------------------------------------------------ --- * Haddock flags --- ------------------------------------------------------------ - -data HaddockFlags = HaddockFlags { - haddockProgramPaths :: [(String, FilePath)], - haddockProgramArgs :: [(String, [String])], - haddockHoogle :: Flag Bool, - haddockHtml :: Flag Bool, - haddockHtmlLocation :: Flag String, - haddockExecutables :: Flag Bool, - haddockInternal :: Flag Bool, - haddockCss :: Flag FilePath, - haddockHscolour :: Flag Bool, - haddockHscolourCss :: Flag FilePath, - haddockDistPref :: Flag FilePath, - haddockVerbosity :: Flag Verbosity - } - deriving Show - -defaultHaddockFlags :: HaddockFlags -defaultHaddockFlags = HaddockFlags { - haddockProgramPaths = mempty, - haddockProgramArgs = [], - haddockHoogle = Flag False, - haddockHtml = Flag False, - haddockHtmlLocation = NoFlag, - haddockExecutables = Flag False, - haddockInternal = Flag False, - haddockCss = NoFlag, - haddockHscolour = Flag False, - haddockHscolourCss = NoFlag, - haddockDistPref = Flag defaultDistPref, - haddockVerbosity = Flag normal - } - -haddockCommand :: CommandUI HaddockFlags -haddockCommand = makeCommand name shortDesc longDesc defaultHaddockFlags options - where - name = "haddock" - shortDesc = "Generate Haddock HTML documentation." - longDesc = Just $ \_ -> "Requires the program haddock, either version 0.x or 2.x.\n" - options showOrParseArgs = - [optionVerbosity haddockVerbosity (\v flags -> flags { haddockVerbosity = v }) - ,optionDistPref - haddockDistPref (\d flags -> flags { haddockDistPref = d }) - showOrParseArgs - - ,option "" ["hoogle"] - "Generate a hoogle database" - haddockHoogle (\v flags -> flags { haddockHoogle = v }) - trueArg - - ,option "" ["html"] - "Generate HTML documentation (the default)" - haddockHtml (\v flags -> flags { haddockHtml = v }) - trueArg - - ,option "" ["html-location"] - "Location of HTML documentation for pre-requisite packages" - haddockHtmlLocation (\v flags -> flags { haddockHtmlLocation = v }) - (reqArgFlag "URL") - - ,option "" ["executables"] - "Run haddock for Executables targets" - haddockExecutables (\v flags -> flags { haddockExecutables = v }) - trueArg - - ,option "" ["internal"] - "Run haddock for internal modules and include all symbols" - haddockInternal (\v flags -> flags { haddockInternal = v }) - trueArg - - ,option "" ["css"] - "Use PATH as the haddock stylesheet" - haddockCss (\v flags -> flags { haddockCss = v }) - (reqArgFlag "PATH") - - ,option "" ["hyperlink-source","hyperlink-sources"] - "Hyperlink the documentation to the source code (using HsColour)" - haddockHscolour (\v flags -> flags { haddockHscolour = v }) - trueArg - - ,option "" ["hscolour-css"] - "Use PATH as the HsColour stylesheet" - haddockHscolourCss (\v flags -> flags { haddockHscolourCss = v }) - (reqArgFlag "PATH") - ] - ++ programConfigurationPaths progConf ParseArgs - haddockProgramPaths (\v flags -> flags { haddockProgramPaths = v}) - ++ programConfigurationOptions progConf ParseArgs - haddockProgramArgs (\v flags -> flags { haddockProgramArgs = v}) - progConf = addKnownProgram haddockProgram - $ addKnownProgram ghcProgram - $ emptyProgramConfiguration - -emptyHaddockFlags :: HaddockFlags -emptyHaddockFlags = mempty - -instance Monoid HaddockFlags where - mempty = HaddockFlags { - haddockProgramPaths = mempty, - haddockProgramArgs = mempty, - haddockHoogle = mempty, - haddockHtml = mempty, - haddockHtmlLocation = mempty, - haddockExecutables = mempty, - haddockInternal = mempty, - haddockCss = mempty, - haddockHscolour = mempty, - haddockHscolourCss = mempty, - haddockDistPref = mempty, - haddockVerbosity = mempty - } - mappend a b = HaddockFlags { - haddockProgramPaths = combine haddockProgramPaths, - haddockProgramArgs = combine haddockProgramArgs, - haddockHoogle = combine haddockHoogle, - haddockHtml = combine haddockHoogle, - haddockHtmlLocation = combine haddockHtmlLocation, - haddockExecutables = combine haddockExecutables, - haddockInternal = combine haddockInternal, - haddockCss = combine haddockCss, - haddockHscolour = combine haddockHscolour, - haddockHscolourCss = combine haddockHscolourCss, - haddockDistPref = combine haddockDistPref, - haddockVerbosity = combine haddockVerbosity - } - where combine field = field a `mappend` field b - --- ------------------------------------------------------------ --- * Clean flags --- ------------------------------------------------------------ - -data CleanFlags = CleanFlags { - cleanSaveConf :: Flag Bool, - cleanDistPref :: Flag FilePath, - cleanVerbosity :: Flag Verbosity - } - deriving Show - -defaultCleanFlags :: CleanFlags -defaultCleanFlags = CleanFlags { - cleanSaveConf = Flag False, - cleanDistPref = Flag defaultDistPref, - cleanVerbosity = Flag normal - } - -cleanCommand :: CommandUI CleanFlags -cleanCommand = makeCommand name shortDesc longDesc defaultCleanFlags options - where - name = "clean" - shortDesc = "Clean up after a build." - longDesc = Just (\_ -> "Removes .hi, .o, preprocessed sources, etc.\n") - options showOrParseArgs = - [optionVerbosity cleanVerbosity (\v flags -> flags { cleanVerbosity = v }) - ,optionDistPref - cleanDistPref (\d flags -> flags { cleanDistPref = d }) - showOrParseArgs - - ,option "s" ["save-configure"] - "Do not remove the configuration file (dist/setup-config) during cleaning. Saves need to reconfigure." - cleanSaveConf (\v flags -> flags { cleanSaveConf = v }) - trueArg - ] - -emptyCleanFlags :: CleanFlags -emptyCleanFlags = mempty - -instance Monoid CleanFlags where - mempty = CleanFlags { - cleanSaveConf = mempty, - cleanDistPref = mempty, - cleanVerbosity = mempty - } - mappend a b = CleanFlags { - cleanSaveConf = combine cleanSaveConf, - cleanDistPref = combine cleanDistPref, - cleanVerbosity = combine cleanVerbosity - } - where combine field = field a `mappend` field b - --- ------------------------------------------------------------ --- * Build flags --- ------------------------------------------------------------ - -data BuildFlags = BuildFlags { - buildProgramPaths :: [(String, FilePath)], - buildProgramArgs :: [(String, [String])], - buildDistPref :: Flag FilePath, - buildVerbosity :: Flag Verbosity - } - deriving Show - -{-# DEPRECATED buildVerbose "Use buildVerbosity instead" #-} -buildVerbose :: BuildFlags -> Verbosity -buildVerbose = fromFlagOrDefault normal . buildVerbosity - -defaultBuildFlags :: BuildFlags -defaultBuildFlags = BuildFlags { - buildProgramPaths = mempty, - buildProgramArgs = [], - buildDistPref = Flag defaultDistPref, - buildVerbosity = Flag normal - } - -buildCommand :: ProgramConfiguration -> CommandUI BuildFlags -buildCommand progConf = makeCommand name shortDesc longDesc defaultBuildFlags options - where - name = "build" - shortDesc = "Make this package ready for installation." - longDesc = Nothing - options showOrParseArgs = - optionVerbosity buildVerbosity (\v flags -> flags { buildVerbosity = v }) - : optionDistPref - buildDistPref (\d flags -> flags { buildDistPref = d }) - showOrParseArgs - - : programConfigurationPaths progConf showOrParseArgs - buildProgramPaths (\v flags -> flags { buildProgramPaths = v}) - - ++ programConfigurationOptions progConf showOrParseArgs - buildProgramArgs (\v flags -> flags { buildProgramArgs = v}) - -emptyBuildFlags :: BuildFlags -emptyBuildFlags = mempty - -instance Monoid BuildFlags where - mempty = BuildFlags { - buildProgramPaths = mempty, - buildProgramArgs = mempty, - buildVerbosity = mempty, - buildDistPref = mempty - } - mappend a b = BuildFlags { - buildProgramPaths = combine buildProgramPaths, - buildProgramArgs = combine buildProgramArgs, - buildVerbosity = combine buildVerbosity, - buildDistPref = combine buildDistPref - } - where combine field = field a `mappend` field b - --- ------------------------------------------------------------ --- * Test flags --- ------------------------------------------------------------ - -data TestShowDetails = Never | Failures | Always - deriving (Eq, Ord, Enum, Bounded, Show) - -knownTestShowDetails :: [TestShowDetails] -knownTestShowDetails = [minBound..maxBound] - -instance Text TestShowDetails where - disp = Disp.text . lowercase . show - - parse = maybe Parse.pfail return . classify =<< ident - where - ident = Parse.munch1 (\c -> isAlpha c || c == '_' || c == '-') - classify str = lookup (lowercase str) enumMap - enumMap :: [(String, TestShowDetails)] - enumMap = [ (display x, x) - | x <- knownTestShowDetails ] - ---TODO: do we need this instance? -instance Monoid TestShowDetails where - mempty = Never - mappend a b = if a < b then b else a - -data TestFlags = TestFlags { - testDistPref :: Flag FilePath, - testVerbosity :: Flag Verbosity, - testHumanLog :: Flag PathTemplate, - testMachineLog :: Flag PathTemplate, - testShowDetails :: Flag TestShowDetails, - --TODO: eliminate the test list and pass it directly as positional args to the testHook - testList :: Flag [String], - -- TODO: think about if/how options are passed to test exes - testOptions :: Flag [PathTemplate] - } - -defaultTestFlags :: TestFlags -defaultTestFlags = TestFlags { - testDistPref = Flag defaultDistPref, - testVerbosity = Flag normal, - testHumanLog = toFlag $ toPathTemplate $ "$pkgid-$test-suite.log", - testMachineLog = toFlag $ toPathTemplate $ "$pkgid.log", - testShowDetails = toFlag Failures, - testList = Flag [], - testOptions = Flag [] - } - -testCommand :: CommandUI TestFlags -testCommand = makeCommand name shortDesc longDesc defaultTestFlags options - where - name = "test" - shortDesc = "Run the test suite, if any (configure with UserHooks)." - longDesc = Nothing - options showOrParseArgs = - [ optionVerbosity testVerbosity (\v flags -> flags { testVerbosity = v }) - , optionDistPref - testDistPref (\d flags -> flags { testDistPref = d }) - showOrParseArgs - , option [] ["log"] - ("Log all test suite results to file (name template can use " - ++ "$pkgid, $compiler, $os, $arch, $test-suite, $result)") - testHumanLog (\v flags -> flags { testHumanLog = v }) - (reqArg' "TEMPLATE" - (toFlag . toPathTemplate) - (flagToList . fmap fromPathTemplate)) - , option [] ["machine-log"] - ("Produce a machine-readable log file (name template can use " - ++ "$pkgid, $compiler, $os, $arch, $result)") - testMachineLog (\v flags -> flags { testMachineLog = v }) - (reqArg' "TEMPLATE" - (toFlag . toPathTemplate) - (flagToList . fmap fromPathTemplate)) - , option [] ["show-details"] - ("'always': always show results of individual test cases. " - ++ "'never': never show results of individual test cases. " - ++ "'failures': show results of failing test cases.") - testShowDetails (\v flags -> flags { testShowDetails = v }) - (reqArg "FILTER" - (readP_to_E (\_ -> "--show-details flag expects one of " - ++ intercalate ", " - (map display knownTestShowDetails)) - (fmap toFlag parse)) - (flagToList . fmap display)) - , option [] ["test-options"] - ("give extra options to test executables " - ++ "(name templates can use $pkgid, $compiler, " - ++ "$os, $arch, $test-suite)") - testOptions (\v flags -> flags { testOptions = v }) - (reqArg' "TEMPLATES" (toFlag . map toPathTemplate . splitArgs) - (map fromPathTemplate . fromFlagOrDefault [])) - , option [] ["test-option"] - ("give extra option to test executables " - ++ "(no need to quote options containing spaces, " - ++ "name template can use $pkgid, $compiler, " - ++ "$os, $arch, $test-suite)") - testOptions (\v flags -> flags { testOptions = v }) - (reqArg' "TEMPLATE" (\x -> toFlag [toPathTemplate x]) - (map fromPathTemplate . fromFlagOrDefault [])) - ] - -emptyTestFlags :: TestFlags -emptyTestFlags = mempty - -instance Monoid TestFlags where - mempty = TestFlags { - testDistPref = mempty, - testVerbosity = mempty, - testHumanLog = mempty, - testMachineLog = mempty, - testShowDetails = mempty, - testList = mempty, - testOptions = mempty - } - mappend a b = TestFlags { - testDistPref = combine testDistPref, - testVerbosity = combine testVerbosity, - testHumanLog = combine testHumanLog, - testMachineLog = combine testMachineLog, - testShowDetails = combine testShowDetails, - testList = combine testList, - testOptions = combine testOptions - } - where combine field = field a `mappend` field b - --- ------------------------------------------------------------ --- * Shared options utils --- ------------------------------------------------------------ - -programFlagsDescription :: ProgramConfiguration -> String -programFlagsDescription progConf = - "The flags --with-PROG and --PROG-option(s) can be used with" - ++ " the following programs:" - ++ (concatMap (\line -> "\n " ++ unwords line) . wrapLine 77 . sort) - [ programName prog | (prog, _) <- knownPrograms progConf ] - ++ "\n" - -programConfigurationPaths - :: ProgramConfiguration - -> ShowOrParseArgs - -> (flags -> [(String, FilePath)]) - -> ([(String, FilePath)] -> (flags -> flags)) - -> [OptionField flags] -programConfigurationPaths progConf showOrParseArgs get set = - case showOrParseArgs of - -- we don't want a verbose help text list so we just show a generic one: - ShowArgs -> [withProgramPath "PROG"] - ParseArgs -> map (withProgramPath . programName . fst) (knownPrograms progConf) - where - withProgramPath prog = - option "" ["with-" ++ prog] - ("give the path to " ++ prog) - get set - (reqArg' "PATH" (\path -> [(prog, path)]) - (\progPaths -> [ path | (prog', path) <- progPaths, prog==prog' ])) - -programConfigurationOptions - :: ProgramConfiguration - -> ShowOrParseArgs - -> (flags -> [(String, [String])]) - -> ([(String, [String])] -> (flags -> flags)) - -> [OptionField flags] -programConfigurationOptions progConf showOrParseArgs get set = - case showOrParseArgs of - -- we don't want a verbose help text list so we just show a generic one: - ShowArgs -> [programOptions "PROG", programOption "PROG"] - ParseArgs -> map (programOptions . programName . fst) (knownPrograms progConf) - ++ map (programOption . programName . fst) (knownPrograms progConf) - where - programOptions prog = - option "" [prog ++ "-options"] - ("give extra options to " ++ prog) - get set - (reqArg' "OPTS" (\args -> [(prog, splitArgs args)]) (const [])) - - programOption prog = - option "" [prog ++ "-option"] - ("give an extra option to " ++ prog ++ - " (no need to quote options containing spaces)") - get set - (reqArg' "OPT" (\arg -> [(prog, [arg])]) - (\progArgs -> concat [ args | (prog', args) <- progArgs, prog==prog' ])) - - --- ------------------------------------------------------------ --- * GetOpt Utils --- ------------------------------------------------------------ - -boolOpt :: SFlags -> SFlags -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a -boolOpt = Command.boolOpt flagToMaybe Flag - -boolOpt' :: OptFlags -> OptFlags -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a -boolOpt' = Command.boolOpt' flagToMaybe Flag - -trueArg, falseArg :: SFlags -> LFlags -> Description -> (b -> Flag Bool) -> - (Flag Bool -> (b -> b)) -> OptDescr b -trueArg = noArg (Flag True) -falseArg = noArg (Flag False) - -reqArgFlag :: ArgPlaceHolder -> SFlags -> LFlags -> Description -> - (b -> Flag String) -> (Flag String -> b -> b) -> OptDescr b -reqArgFlag ad = reqArg ad (succeedReadE Flag) flagToList - -optionDistPref :: (flags -> Flag FilePath) - -> (Flag FilePath -> flags -> flags) - -> ShowOrParseArgs - -> OptionField flags -optionDistPref get set = \showOrParseArgs -> - option "" (distPrefFlagName showOrParseArgs) - ( "The directory where Cabal puts generated build files " - ++ "(default " ++ defaultDistPref ++ ")") - get set - (reqArgFlag "DIR") - where - distPrefFlagName ShowArgs = ["builddir"] - distPrefFlagName ParseArgs = ["builddir", "distdir", "distpref"] - -optionVerbosity :: (flags -> Flag Verbosity) - -> (Flag Verbosity -> flags -> flags) - -> OptionField flags -optionVerbosity get set = - option "v" ["verbose"] - "Control verbosity (n is 0--3, default verbosity level is 1)" - get set - (optArg "n" (fmap Flag flagToVerbosity) - (Flag verbose) -- default Value if no n is given - (fmap (Just . showForCabal) . flagToList)) - --- ------------------------------------------------------------ --- * Other Utils --- ------------------------------------------------------------ - --- | Arguments to pass to a @configure@ script, e.g. generated by --- @autoconf@. -configureArgs :: Bool -> ConfigFlags -> [String] -configureArgs bcHack flags - = hc_flag - ++ optFlag "with-hc-pkg" configHcPkg - ++ optFlag' "prefix" prefix - ++ optFlag' "bindir" bindir - ++ optFlag' "libdir" libdir - ++ optFlag' "libexecdir" libexecdir - ++ optFlag' "datadir" datadir - ++ configConfigureArgs flags - where - hc_flag = case (configHcFlavor flags, configHcPath flags) of - (_, Flag hc_path) -> [hc_flag_name ++ hc_path] - (Flag hc, NoFlag) -> [hc_flag_name ++ display hc] - (NoFlag,NoFlag) -> [] - hc_flag_name - --TODO kill off thic bc hack when defaultUserHooks is removed. - | bcHack = "--with-hc=" - | otherwise = "--with-compiler=" - optFlag name config_field = case config_field flags of - Flag p -> ["--" ++ name ++ "=" ++ p] - NoFlag -> [] - optFlag' name config_field = optFlag name (fmap fromPathTemplate - . config_field - . configInstallDirs) - -configureCCompiler :: Verbosity -> ProgramConfiguration -> IO (FilePath, [String]) -configureCCompiler verbosity lbi = configureProg verbosity lbi gccProgram - -configureLinker :: Verbosity -> ProgramConfiguration -> IO (FilePath, [String]) -configureLinker verbosity lbi = configureProg verbosity lbi ldProgram - -configureProg :: Verbosity -> ProgramConfiguration -> Program -> IO (FilePath, [String]) -configureProg verbosity programConfig prog = do - (p, _) <- requireProgram verbosity prog programConfig - let pInv = programInvocation p [] - return (progInvokePath pInv, progInvokeArgs pInv) - --- | Helper function to split a string into a list of arguments. --- It's supposed to handle quoted things sensibly, eg: --- --- > splitArgs "--foo=\"C:\Program Files\Bar\" --baz" --- > = ["--foo=C:\Program Files\Bar", "--baz"] --- -splitArgs :: String -> [String] -splitArgs = space [] - where - space :: String -> String -> [String] - space w [] = word w [] - space w ( c :s) - | isSpace c = word w (space [] s) - space w ('"':s) = string w s - space w s = nonstring w s - - string :: String -> String -> [String] - string w [] = word w [] - string w ('"':s) = space w s - string w ( c :s) = string (c:w) s - - nonstring :: String -> String -> [String] - nonstring w [] = word w [] - nonstring w ('"':s) = string w s - nonstring w ( c :s) = space (c:w) s - - word [] s = s - word w s = reverse w : s - --- The test cases kinda have to be rewritten from the ground up... :/ ---hunitTests :: [Test] ---hunitTests = --- let m = [("ghc", GHC), ("nhc98", NHC), ("hugs", Hugs)] --- (flags, commands', unkFlags, ers) --- = getOpt Permute options ["configure", "foobar", "--prefix=/foo", "--ghc", "--nhc98", "--hugs", "--with-compiler=/comp", "--unknown1", "--unknown2", "--install-prefix=/foo", "--user", "--global"] --- in [TestLabel "very basic option parsing" $ TestList [ --- "getOpt flags" ~: "failed" ~: --- [Prefix "/foo", GhcFlag, NhcFlag, HugsFlag, --- WithCompiler "/comp", InstPrefix "/foo", UserFlag, GlobalFlag] --- ~=? flags, --- "getOpt commands" ~: "failed" ~: ["configure", "foobar"] ~=? commands', --- "getOpt unknown opts" ~: "failed" ~: --- ["--unknown1", "--unknown2"] ~=? unkFlags, --- "getOpt errors" ~: "failed" ~: [] ~=? ers], --- --- TestLabel "test location of various compilers" $ TestList --- ["configure parsing for prefix and compiler flag" ~: "failed" ~: --- (Right (ConfigCmd (Just comp, Nothing, Just "/usr/local"), [])) --- ~=? (parseArgs ["--prefix=/usr/local", "--"++name, "configure"]) --- | (name, comp) <- m], --- --- TestLabel "find the package tool" $ TestList --- ["configure parsing for prefix comp flag, withcompiler" ~: "failed" ~: --- (Right (ConfigCmd (Just comp, Just "/foo/comp", Just "/usr/local"), [])) --- ~=? (parseArgs ["--prefix=/usr/local", "--"++name, --- "--with-compiler=/foo/comp", "configure"]) --- | (name, comp) <- m], --- --- TestLabel "simpler commands" $ TestList --- [flag ~: "failed" ~: (Right (flagCmd, [])) ~=? (parseArgs [flag]) --- | (flag, flagCmd) <- [("build", BuildCmd), --- ("install", InstallCmd Nothing False), --- ("sdist", SDistCmd), --- ("register", RegisterCmd False)] --- ] --- ] - -{- Testing ideas: - * IO to look for hugs and hugs-pkg (which hugs, etc) - * quickCheck to test permutations of arguments - * what other options can we over-ride with a command-line flag? --} diff -Nru ghc-7.0.3/libraries/Cabal/Distribution/Simple/SrcDist.hs ghc-7.2.1/libraries/Cabal/Distribution/Simple/SrcDist.hs --- ghc-7.0.3/libraries/Cabal/Distribution/Simple/SrcDist.hs 2011-03-26 18:10:12.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/Distribution/Simple/SrcDist.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,384 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.SrcDist --- Copyright : Simon Marlow 2004 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This handles the @sdist@ command. The module exports an 'sdist' action but --- also some of the phases that make it up so that other tools can use just the --- bits they need. In particular the preparation of the tree of files to go --- into the source tarball is separated from actually building the source --- tarball. --- --- The 'createArchive' action uses the external @tar@ program and assumes that --- it accepts the @-z@ flag. Neither of these assumptions are valid on Windows. --- The 'sdist' action now also does some distribution QA checks. - -{- Copyright (c) 2003-2004, Simon Marlow -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - --- NOTE: FIX: we don't have a great way of testing this module, since --- we can't easily look inside a tarball once its created. - -module Distribution.Simple.SrcDist ( - -- * The top level action - sdist, - - -- ** Parts of 'sdist' - printPackageProblems, - prepareTree, - createArchive, - - -- ** Snaphots - prepareSnapshotTree, - snapshotPackage, - snapshotVersion, - dateToSnapshotNumber, - ) where - -import Distribution.PackageDescription - ( PackageDescription(..), BuildInfo(..), Executable(..), Library(..) ) -import Distribution.PackageDescription.Check - ( PackageCheck(..), checkConfiguredPackage, checkPackageFiles ) -import Distribution.Package - ( PackageIdentifier(pkgVersion), Package(..), packageVersion ) -import Distribution.ModuleName (ModuleName) -import qualified Distribution.ModuleName as ModuleName -import Distribution.Version - ( Version(versionBranch) ) -import Distribution.Simple.Utils - ( createDirectoryIfMissingVerbose, withUTF8FileContents, writeUTF8File - , installOrdinaryFile, installOrdinaryFiles - , findFile, findFileWithExtension, matchFileGlob - , withTempDirectory, defaultPackageDesc - , die, warn, notice, setupMessage ) -import Distribution.Simple.Setup (SDistFlags(..), fromFlag) -import Distribution.Simple.PreProcess (PPSuffixHandler, ppSuffixes, preprocessSources) -import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) ) -import Distribution.Simple.BuildPaths ( autogenModuleName ) -import Distribution.Simple.Program ( defaultProgramConfiguration, requireProgram, - rawSystemProgram, tarProgram ) -import Distribution.Text - ( display ) - -import Control.Monad(when, unless) -import Data.Char (toLower) -import Data.List (partition, isPrefixOf) -import Data.Maybe (isNothing, catMaybes) -import System.Time (getClockTime, toCalendarTime, CalendarTime(..)) -import System.Directory - ( doesFileExist, Permissions(executable), getPermissions ) -import Distribution.Compat.CopyFile (setFileExecutable) -import Distribution.Verbosity (Verbosity) -import System.FilePath - ( (), (<.>), takeDirectory, dropExtension, isAbsolute ) - --- |Create a source distribution. -sdist :: PackageDescription -- ^information from the tarball - -> Maybe LocalBuildInfo -- ^Information from configure - -> SDistFlags -- ^verbosity & snapshot - -> (FilePath -> FilePath) -- ^build prefix (temp dir) - -> [PPSuffixHandler] -- ^ extra preprocessors (includes suffixes) - -> IO () -sdist pkg mb_lbi flags mkTmpDir pps = do - let distPref = fromFlag $ sDistDistPref flags - targetPref = distPref - tmpTargetDir = mkTmpDir distPref - - -- do some QA - printPackageProblems verbosity pkg - - when (isNothing mb_lbi) $ - warn verbosity "Cannot run preprocessors. Run 'configure' command first." - - createDirectoryIfMissingVerbose verbosity True tmpTargetDir - withTempDirectory verbosity tmpTargetDir "sdist." $ \tmpDir -> do - - date <- toCalendarTime =<< getClockTime - let pkg' | snapshot = snapshotPackage date pkg - | otherwise = pkg - setupMessage verbosity "Building source dist for" (packageId pkg') - - -- FIXME This looks a bit suspicious. Should createArchive be passed - -- the result of prepareSnapshotTree/prepareTree? - _ <- if snapshot - then prepareSnapshotTree verbosity pkg' mb_lbi distPref tmpDir pps - else prepareTree verbosity pkg' mb_lbi distPref tmpDir pps - targzFile <- createArchive verbosity pkg' mb_lbi tmpDir targetPref - notice verbosity $ "Source tarball created: " ++ targzFile - - where - verbosity = fromFlag (sDistVerbosity flags) - snapshot = fromFlag (sDistSnapshot flags) - --- |Prepare a directory tree of source files. -prepareTree :: Verbosity -- ^verbosity - -> PackageDescription -- ^info from the cabal file - -> Maybe LocalBuildInfo - -> FilePath -- ^dist dir - -> FilePath -- ^source tree to populate - -> [PPSuffixHandler] -- ^extra preprocessors (includes suffixes) - -> IO FilePath -- ^the name of the dir created and populated - -prepareTree verbosity pkg_descr0 mb_lbi distPref tmpDir pps = do - let targetDir = tmpDir tarBallName pkg_descr - createDirectoryIfMissingVerbose verbosity True targetDir - -- maybe move the library files into place - withLib $ \Library { exposedModules = modules, libBuildInfo = libBi } -> - prepareDir verbosity pkg_descr distPref targetDir pps modules libBi - -- move the executables into place - withExe $ \Executable { modulePath = mainPath, buildInfo = exeBi } -> do - prepareDir verbosity pkg_descr distPref targetDir pps [] exeBi - srcMainFile <- do - ppFile <- findFileWithExtension (ppSuffixes pps) (hsSourceDirs exeBi) (dropExtension mainPath) - case ppFile of - Nothing -> findFile (hsSourceDirs exeBi) mainPath - Just pp -> return pp - copyFileTo verbosity targetDir srcMainFile - flip mapM_ (dataFiles pkg_descr) $ \ filename -> do - files <- matchFileGlob (dataDir pkg_descr filename) - let dir = takeDirectory (dataDir pkg_descr filename) - createDirectoryIfMissingVerbose verbosity True (targetDir dir) - sequence_ [ installOrdinaryFile verbosity file (targetDir file) - | file <- files ] - - when (not (null (licenseFile pkg_descr))) $ - copyFileTo verbosity targetDir (licenseFile pkg_descr) - flip mapM_ (extraSrcFiles pkg_descr) $ \ fpath -> do - files <- matchFileGlob fpath - sequence_ - [ do copyFileTo verbosity targetDir file - -- preserve executable bit on extra-src-files like ./configure - perms <- getPermissions file - when (executable perms) --only checks user x bit - (setFileExecutable (targetDir file)) - | file <- files ] - - -- copy the install-include files - withLib $ \ l -> do - let lbi = libBuildInfo l - relincdirs = "." : filter (not.isAbsolute) (includeDirs lbi) - incs <- mapM (findInc relincdirs) (installIncludes lbi) - flip mapM_ incs $ \(_,fpath) -> - copyFileTo verbosity targetDir fpath - - -- if the package was configured then we can run platform independent - -- pre-processors and include those generated files - case mb_lbi of - Just lbi | not (null pps) - -> preprocessSources pkg_descr (lbi { buildDir = targetDir buildDir lbi }) - True verbosity pps - _ -> return () - - -- setup isn't listed in the description file. - hsExists <- doesFileExist "Setup.hs" - lhsExists <- doesFileExist "Setup.lhs" - if hsExists then copyFileTo verbosity targetDir "Setup.hs" - else if lhsExists then copyFileTo verbosity targetDir "Setup.lhs" - else writeUTF8File (targetDir "Setup.hs") $ unlines [ - "import Distribution.Simple", - "main = defaultMain"] - -- the description file itself - descFile <- defaultPackageDesc verbosity - installOrdinaryFile verbosity descFile (targetDir descFile) - return targetDir - - where - pkg_descr = mapAllBuildInfo filterAutogenModule pkg_descr0 - filterAutogenModule bi = bi { - otherModules = filter (/=autogenModule) (otherModules bi) - } - autogenModule = autogenModuleName pkg_descr0 - - findInc [] f = die ("can't find include file " ++ f) - findInc (d:ds) f = do - let path = (d f) - b <- doesFileExist path - if b then return (f,path) else findInc ds f - - -- We have to deal with all libs and executables, so we have local - -- versions of these functions that ignore the 'buildable' attribute: - withLib action = maybe (return ()) action (library pkg_descr) - withExe action = mapM_ action (executables pkg_descr) - --- | Prepare a directory tree of source files for a snapshot version. --- It is expected that the appropriate snapshot version has already been set --- in the package description, eg using 'snapshotPackage' or 'snapshotVersion'. --- -prepareSnapshotTree :: Verbosity -- ^verbosity - -> PackageDescription -- ^info from the cabal file - -> Maybe LocalBuildInfo - -> FilePath -- ^dist dir - -> FilePath -- ^source tree to populate - -> [PPSuffixHandler] -- ^extra preprocessors (includes suffixes) - -> IO FilePath -- ^the resulting temp dir -prepareSnapshotTree verbosity pkg mb_lbi distPref tmpDir pps = do - targetDir <- prepareTree verbosity pkg mb_lbi distPref tmpDir pps - overwriteSnapshotPackageDesc (packageVersion pkg) targetDir - return targetDir - - where - overwriteSnapshotPackageDesc version targetDir = do - -- We could just writePackageDescription targetDescFile pkg_descr, - -- but that would lose comments and formatting. - descFile <- defaultPackageDesc verbosity - withUTF8FileContents descFile $ - writeUTF8File (targetDir descFile) - . unlines . map (replaceVersion version) . lines - - replaceVersion :: Version -> String -> String - replaceVersion version line - | "version:" `isPrefixOf` map toLower line - = "version: " ++ display version - | otherwise = line - --- | Modifies a 'PackageDescription' by appending a snapshot number --- corresponding to the given date. --- -snapshotPackage :: CalendarTime -> PackageDescription -> PackageDescription -snapshotPackage date pkg = - pkg { - package = pkgid { pkgVersion = snapshotVersion date (pkgVersion pkgid) } - } - where pkgid = packageId pkg - --- | Modifies a 'Version' by appending a snapshot number corresponding --- to the given date. --- -snapshotVersion :: CalendarTime -> Version -> Version -snapshotVersion date version = version { - versionBranch = versionBranch version - ++ [dateToSnapshotNumber date] - } - --- | Given a date produce a corresponding integer representation. --- For example given a date @18/03/2008@ produce the number @20080318@. --- -dateToSnapshotNumber :: CalendarTime -> Int -dateToSnapshotNumber date = year * 10000 - + month * 100 - + day - where - year = ctYear date - month = fromEnum (ctMonth date) + 1 - day = ctDay date - --- |Create an archive from a tree of source files, and clean up the tree. -createArchive :: Verbosity -- ^verbosity - -> PackageDescription -- ^info from cabal file - -> Maybe LocalBuildInfo -- ^info from configure - -> FilePath -- ^source tree to archive - -> FilePath -- ^name of archive to create - -> IO FilePath - -createArchive verbosity pkg_descr mb_lbi tmpDir targetPref = do - let tarBallFilePath = targetPref tarBallName pkg_descr <.> "tar.gz" - - (tarProg, _) <- requireProgram verbosity tarProgram - (maybe defaultProgramConfiguration withPrograms mb_lbi) - - -- Hmm: I could well be skating on thinner ice here by using the -C option (=> GNU tar-specific?) - -- [The prev. solution used pipes and sub-command sequences to set up the paths correctly, - -- which is problematic in a Windows setting.] - rawSystemProgram verbosity tarProg - ["-C", tmpDir, "-czf", tarBallFilePath, tarBallName pkg_descr] - return tarBallFilePath - --- |Move the sources into place based on buildInfo -prepareDir :: Verbosity -- ^verbosity - -> PackageDescription -- ^info from the cabal file - -> FilePath -- ^dist dir - -> FilePath -- ^TargetPrefix - -> [PPSuffixHandler] -- ^ extra preprocessors (includes suffixes) - -> [ModuleName] -- ^Exposed modules - -> BuildInfo - -> IO () -prepareDir verbosity _pkg _distPref inPref pps modules bi - = do let searchDirs = hsSourceDirs bi - sources <- sequence - [ let file = ModuleName.toFilePath module_ - in findFileWithExtension suffixes searchDirs file - >>= maybe (notFound module_) return - | module_ <- modules ++ otherModules bi ] - bootFiles <- sequence - [ let file = ModuleName.toFilePath module_ - fileExts = ["hs-boot", "lhs-boot"] - in findFileWithExtension fileExts (hsSourceDirs bi) file - | module_ <- modules ++ otherModules bi ] - - let allSources = sources ++ catMaybes bootFiles ++ cSources bi - installOrdinaryFiles verbosity inPref (zip (repeat []) allSources) - - where suffixes = ppSuffixes pps ++ ["hs", "lhs"] - notFound m = die $ "Error: Could not find module: " ++ display m - ++ " with any suffix: " ++ show suffixes - -copyFileTo :: Verbosity -> FilePath -> FilePath -> IO () -copyFileTo verbosity dir file = do - let targetFile = dir file - createDirectoryIfMissingVerbose verbosity True (takeDirectory targetFile) - installOrdinaryFile verbosity file targetFile - -printPackageProblems :: Verbosity -> PackageDescription -> IO () -printPackageProblems verbosity pkg_descr = do - ioChecks <- checkPackageFiles pkg_descr "." - let pureChecks = checkConfiguredPackage pkg_descr - isDistError (PackageDistSuspicious _) = False - isDistError _ = True - (errors, warnings) = partition isDistError (pureChecks ++ ioChecks) - unless (null errors) $ - notice verbosity $ "Distribution quality errors:\n" - ++ unlines (map explanation errors) - unless (null warnings) $ - notice verbosity $ "Distribution quality warnings:\n" - ++ unlines (map explanation warnings) - unless (null errors) $ - notice verbosity - "Note: the public hackage server would reject this package." - ------------------------------------------------------------- - --- | The name of the tarball without extension --- -tarBallName :: PackageDescription -> String -tarBallName = display . packageId - -mapAllBuildInfo :: (BuildInfo -> BuildInfo) - -> (PackageDescription -> PackageDescription) -mapAllBuildInfo f pkg = pkg { - library = fmap mapLibBi (library pkg), - executables = fmap mapExeBi (executables pkg) - } - where - mapLibBi lib = lib { libBuildInfo = f (libBuildInfo lib) } - mapExeBi exe = exe { buildInfo = f (buildInfo exe) } diff -Nru ghc-7.0.3/libraries/Cabal/Distribution/Simple/Test.hs ghc-7.2.1/libraries/Cabal/Distribution/Simple/Test.hs --- ghc-7.0.3/libraries/Cabal/Distribution/Simple/Test.hs 2011-03-26 18:10:12.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/Distribution/Simple/Test.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,466 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Test --- Copyright : Thomas Tuegel 2010 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This is the entry point into testing a built package. It performs the --- \"@.\/setup test@\" action. It runs test suites designated in the package --- description and reports on the results. - -{- All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - -module Distribution.Simple.Test - ( test - , runTests - , writeSimpleTestStub - , stubFilePath - , stubName - , PackageLog(..) - , TestSuiteLog(..) - , Case(..) - , suitePassed, suiteFailed, suiteError - ) where - -import Distribution.Compat.TempFile ( openTempFile ) -import Distribution.ModuleName ( ModuleName ) -import Distribution.Package - ( PackageId ) -import qualified Distribution.PackageDescription as PD - ( PackageDescription(..), TestSuite(..) - , TestSuiteInterface(..), testType, hasTests ) -import Distribution.Simple.Build.PathsModule ( pkgPathEnvVar ) -import Distribution.Simple.BuildPaths ( exeExtension ) -import Distribution.Simple.Compiler ( Compiler(..), CompilerId ) -import Distribution.Simple.InstallDirs - ( fromPathTemplate, initialPathTemplateEnv, PathTemplateVariable(..) - , substPathTemplate , toPathTemplate, PathTemplate ) -import qualified Distribution.Simple.LocalBuildInfo as LBI - ( LocalBuildInfo(..) ) -import Distribution.Simple.Setup ( TestFlags(..), TestShowDetails(..), fromFlag ) -import Distribution.Simple.Utils ( die, notice ) -import qualified Distribution.TestSuite as TestSuite - ( Test, Result(..), ImpureTestable(..), TestOptions(..), Options(..) ) -import Distribution.Text -import Distribution.Verbosity ( normal, Verbosity ) -import Distribution.System ( buildPlatform, Platform ) - -import Control.Exception ( bracket ) -import Control.Monad ( when, liftM, unless ) -import Data.Char ( toUpper ) -import Data.Monoid ( mempty ) -import System.Directory - ( createDirectoryIfMissing, doesFileExist, getCurrentDirectory - , removeFile ) -import System.Environment ( getEnvironment ) -import System.Exit ( ExitCode(..), exitFailure, exitSuccess, exitWith ) -import System.FilePath ( (), (<.>) ) -import System.IO ( hClose, IOMode(..), openFile ) -import System.Process ( runProcess, waitForProcess ) - --- | Logs all test results for a package, broken down first by test suite and --- then by test case. -data PackageLog = PackageLog - { package :: PackageId - , compiler :: CompilerId - , platform :: Platform - , testSuites :: [TestSuiteLog] - } - deriving (Read, Show, Eq) - --- | A 'PackageLog' with package and platform information specified. -localPackageLog :: PD.PackageDescription -> LBI.LocalBuildInfo -> PackageLog -localPackageLog pkg_descr lbi = PackageLog - { package = PD.package pkg_descr - , compiler = compilerId $ LBI.compiler lbi - , platform = buildPlatform - , testSuites = [] - } - --- | Logs test suite results, itemized by test case. -data TestSuiteLog = TestSuiteLog - { name :: String - , cases :: [Case] - , logFile :: FilePath -- path to human-readable log file - } - deriving (Read, Show, Eq) - -data Case = Case - { caseName :: String - , caseOptions :: TestSuite.Options - , caseResult :: TestSuite.Result - } - deriving (Read, Show, Eq) - -getTestOptions :: TestSuite.Test -> TestSuiteLog -> IO TestSuite.Options -getTestOptions t l = - case filter ((== TestSuite.name t) . caseName) (cases l) of - (x:_) -> return $ caseOptions x - _ -> TestSuite.defaultOptions t - --- | From a 'TestSuiteLog', determine if the test suite passed. -suitePassed :: TestSuiteLog -> Bool -suitePassed = all (== TestSuite.Pass) . map caseResult . cases - --- | From a 'TestSuiteLog', determine if the test suite failed. -suiteFailed :: TestSuiteLog -> Bool -suiteFailed = any isFail . map caseResult . cases - where isFail (TestSuite.Fail _) = True - isFail _ = False - --- | From a 'TestSuiteLog', determine if the test suite encountered errors. -suiteError :: TestSuiteLog -> Bool -suiteError = any isError . map caseResult . cases - where isError (TestSuite.Error _) = True - isError _ = False - --- | Run a test executable, logging the output and generating the appropriate --- summary messages. -testController :: TestFlags - -- ^ flags Cabal was invoked with - -> PD.PackageDescription - -- ^ description of package the test suite belongs to - -> LBI.LocalBuildInfo - -- ^ information from the configure step - -> PD.TestSuite - -- ^ TestSuite being tested - -> (FilePath -> String) - -- ^ prepare standard input for test executable - -> FilePath -- ^ executable name - -> (ExitCode -> String -> TestSuiteLog) - -- ^ generator for the TestSuiteLog - -> (TestSuiteLog -> FilePath) - -- ^ generator for final human-readable log filename - -> IO TestSuiteLog -testController flags pkg_descr lbi suite preTest cmd postTest logNamer = do - let distPref = fromFlag $ testDistPref flags - verbosity = fromFlag $ testVerbosity flags - testLogDir = distPref "test" - optionTemplates = fromFlag $ testOptions flags - options = map (testOption pkg_descr lbi suite) optionTemplates - - pwd <- getCurrentDirectory - existingEnv <- getEnvironment - let dataDirPath = pwd PD.dataDir pkg_descr - shellEnv = Just $ (pkgPathEnvVar pkg_descr "datadir", dataDirPath) - : existingEnv - - bracket (openCabalTemp testLogDir) deleteIfExists $ \tempLog -> - bracket (openCabalTemp testLogDir) deleteIfExists $ \tempInput -> do - - -- Write summary notices indicating start of test suite - notice verbosity $ summarizeSuiteStart $ PD.testName suite - appendFile tempLog $ summarizeSuiteStart $ PD.testName suite - - -- Prepare standard input for test executable - appendFile tempInput $ preTest tempInput - - -- Run test executable - exit <- do - hLog <- openFile tempLog AppendMode - hIn <- openFile tempInput ReadMode - -- these handles get closed by runProcess - proc <- runProcess cmd options Nothing shellEnv - (Just hIn) (Just hLog) (Just hLog) - waitForProcess proc - - -- Generate TestSuiteLog from executable exit code and a machine- - -- readable test log - suiteLog <- readFile tempInput >>= return . postTest exit - - -- Generate final log file name - let finalLogName = testLogDir logNamer suiteLog - suiteLog' = suiteLog { logFile = finalLogName } - - -- Write summary notice to log file indicating end of test suite - appendFile tempLog $ summarizeSuiteFinish suiteLog' - - -- Append contents of temporary log file to the final human- - -- readable log file - readFile tempLog >>= appendFile (logFile suiteLog') - - -- Show the contents of the human-readable log file on the terminal - -- if there is a failure and/or detailed output is requested - let details = fromFlag $ testShowDetails flags - whenPrinting = when $ (details > Never) - && (not (suitePassed suiteLog) || details == Always) - && verbosity >= normal - whenPrinting $ readFile (logFile suiteLog') >>= - putStr . unlines . map (">>> " ++) . lines - - -- Write summary notice to terminal indicating end of test suite - notice verbosity $ summarizeSuiteFinish suiteLog' - - return suiteLog' - where - deleteIfExists file = do - exists <- doesFileExist file - when exists $ removeFile file - - openCabalTemp testLogDir = do - (f, h) <- openTempFile testLogDir $ "cabal-test-" <.> "log" - hClose h >> return f - - --- |Perform the \"@.\/setup test@\" action. -test :: PD.PackageDescription -- ^information from the .cabal file - -> LBI.LocalBuildInfo -- ^information from the configure step - -> TestFlags -- ^flags sent to test - -> IO () -test pkg_descr lbi flags = do - let verbosity = fromFlag $ testVerbosity flags - humanTemplate = fromFlag $ testHumanLog flags - machineTemplate = fromFlag $ testMachineLog flags - distPref = fromFlag $ testDistPref flags - testLogDir = distPref "test" - testNames = fromFlag $ testList flags - pkgTests = PD.testSuites pkg_descr - enabledTests = filter PD.testEnabled pkgTests - - doTest :: (PD.TestSuite, Maybe TestSuiteLog) -> IO TestSuiteLog - doTest (suite, mLog) = do - let testLogPath = testSuiteLogPath humanTemplate pkg_descr lbi - go pre cmd post = testController flags pkg_descr lbi suite - pre cmd post testLogPath - case PD.testInterface suite of - PD.TestSuiteExeV10 _ _ -> do - let cmd = LBI.buildDir lbi PD.testName suite - PD.testName suite <.> exeExtension - preTest _ = "" - postTest exit _ = - let r = case exit of - ExitSuccess -> TestSuite.Pass - ExitFailure c -> TestSuite.Fail - $ "exit code: " ++ show c - in TestSuiteLog - { name = PD.testName suite - , cases = [Case (PD.testName suite) mempty r] - , logFile = "" - } - go preTest cmd postTest - - PD.TestSuiteLibV09 _ _ -> do - let cmd = LBI.buildDir lbi stubName suite - stubName suite <.> exeExtension - oldLog = case mLog of - Nothing -> TestSuiteLog - { name = PD.testName suite - , cases = [] - , logFile = [] - } - Just l -> l - preTest f = show $ oldLog { logFile = f } - postTest _ = read - go preTest cmd postTest - - _ -> return TestSuiteLog - { name = PD.testName suite - , cases = [Case (PD.testName suite) mempty - $ TestSuite.Error $ "No support for running " - ++ "test suite type: " - ++ show (disp $ PD.testType suite)] - , logFile = "" - } - - when (not $ PD.hasTests pkg_descr) $ do - notice verbosity "Package has no test suites." - exitSuccess - - when (PD.hasTests pkg_descr && null enabledTests) $ - die $ "No test suites enabled. Did you remember to configure with " - ++ "\'--enable-tests\'?" - - testsToRun <- case testNames of - [] -> return $ zip enabledTests $ repeat Nothing - names -> flip mapM names $ \tName -> - let testMap = zip enabledNames enabledTests - enabledNames = map PD.testName enabledTests - allNames = map PD.testName pkgTests - in case lookup tName testMap of - Just t -> return (t, Nothing) - _ | tName `elem` allNames -> - die $ "Package configured with test suite " - ++ tName ++ " disabled." - | otherwise -> die $ "no such test: " ++ tName - - createDirectoryIfMissing True testLogDir - - let totalSuites = length testsToRun - notice verbosity $ "Running " ++ show totalSuites ++ " test suites..." - suites <- mapM doTest testsToRun - let packageLog = (localPackageLog pkg_descr lbi) { testSuites = suites } - packageLogFile = () testLogDir - $ packageLogPath machineTemplate pkg_descr lbi - allOk <- summarizePackage verbosity packageLog - writeFile packageLogFile $ show packageLog - unless allOk exitFailure - --- | Print a summary to the console after all test suites have been run --- indicating the number of successful test suites and cases. Returns 'True' if --- all test suites passed and 'False' otherwise. -summarizePackage :: Verbosity -> PackageLog -> IO Bool -summarizePackage verbosity packageLog = do - let cases' = map caseResult $ concatMap cases $ testSuites packageLog - passedCases = length $ filter (== TestSuite.Pass) cases' - totalCases = length cases' - passedSuites = length $ filter suitePassed $ testSuites packageLog - totalSuites = length $ testSuites packageLog - notice verbosity $ show passedSuites ++ " of " ++ show totalSuites - ++ " test suites (" ++ show passedCases ++ " of " - ++ show totalCases ++ " test cases) passed." - return $! passedSuites == totalSuites - --- | Print a summary of a single test case's result to the console, supressing --- output for certain verbosity or test filter levels. -summarizeCase :: Verbosity -> TestShowDetails -> Case -> IO () -summarizeCase verbosity details t = - when shouldPrint $ notice verbosity $ "Test case " ++ caseName t - ++ ": " ++ show (caseResult t) - where shouldPrint = (details > Never) && (notPassed || details == Always) - notPassed = caseResult t /= TestSuite.Pass - --- | Print a summary of the test suite's results on the console, suppressing --- output for certain verbosity or test filter levels. -summarizeSuiteFinish :: TestSuiteLog -> String -summarizeSuiteFinish testLog = unlines - [ "Test suite " ++ name testLog ++ ": " ++ resStr - , "Test suite logged to: " ++ logFile testLog - ] - where resStr = map toUpper (resultString testLog) - -summarizeSuiteStart :: String -> String -summarizeSuiteStart n = "Test suite " ++ n ++ ": RUNNING...\n" - -resultString :: TestSuiteLog -> String -resultString l | suiteError l = "error" - | suiteFailed l = "fail" - | otherwise = "pass" - -testSuiteLogPath :: PathTemplate - -> PD.PackageDescription - -> LBI.LocalBuildInfo - -> TestSuiteLog - -> FilePath -testSuiteLogPath template pkg_descr lbi testLog = - fromPathTemplate $ substPathTemplate env template - where - env = initialPathTemplateEnv - (PD.package pkg_descr) (compilerId $ LBI.compiler lbi) - ++ [ (TestSuiteNameVar, toPathTemplate $ name testLog) - , (TestSuiteResultVar, result) - ] - result = toPathTemplate $ resultString testLog - --- TODO: This is abusing the notion of a 'PathTemplate'. The result --- isn't neccesarily a path. -testOption :: PD.PackageDescription - -> LBI.LocalBuildInfo - -> PD.TestSuite - -> PathTemplate - -> String -testOption pkg_descr lbi suite template = - fromPathTemplate $ substPathTemplate env template - where - env = initialPathTemplateEnv - (PD.package pkg_descr) (compilerId $ LBI.compiler lbi) ++ - [(TestSuiteNameVar, toPathTemplate $ PD.testName suite)] - -packageLogPath :: PathTemplate - -> PD.PackageDescription - -> LBI.LocalBuildInfo - -> FilePath -packageLogPath template pkg_descr lbi = - fromPathTemplate $ substPathTemplate env template - where - env = initialPathTemplateEnv - (PD.package pkg_descr) (compilerId $ LBI.compiler lbi) - --- | The filename of the source file for the stub executable associated with a --- library 'TestSuite'. -stubFilePath :: PD.TestSuite -> FilePath -stubFilePath t = stubName t <.> "hs" - --- | The name of the stub executable associated with a library 'TestSuite'. -stubName :: PD.TestSuite -> FilePath -stubName t = PD.testName t ++ "Stub" - --- | Write the source file for a library 'TestSuite' stub executable. -writeSimpleTestStub :: PD.TestSuite -- ^ library 'TestSuite' for which a stub - -- is being created - -> FilePath -- ^ path to directory where stub source - -- should be located - -> IO () -writeSimpleTestStub t dir = do - createDirectoryIfMissing True dir - let filename = dir stubFilePath t - PD.TestSuiteLibV09 _ m = PD.testInterface t - writeFile filename $ simpleTestStub m - --- | Source code for library test suite stub executable -simpleTestStub :: ModuleName -> String -simpleTestStub m = unlines - [ "module Main ( main ) where" - , "import Control.Monad ( liftM )" - , "import Distribution.Simple.Test ( runTests )" - , "import " ++ show (disp m) ++ " ( tests )" - , "main :: IO ()" - , "main = runTests tests" - ] - --- | The test runner used in library "TestSuite" stub executables. Runs a list --- of 'Test's. An executable calling this function is meant to be invoked as --- the child of a Cabal process during @.\/setup test@. A 'TestSuiteLog', --- provided by Cabal, is read from the standard input; it supplies the name of --- the test suite and the location of the machine-readable test suite log file. --- Human-readable log information is written to the standard output for capture --- by the calling Cabal process. -runTests :: [TestSuite.Test] -> IO () -runTests tests = do - testLogIn <- liftM read getContents - let go :: TestSuite.Test -> IO Case - go t = do - o <- getTestOptions t testLogIn - r <- TestSuite.runM t o - let ret = Case - { caseName = TestSuite.name t - , caseOptions = o - , caseResult = r - } - summarizeCase normal Always ret - return ret - cases' <- mapM go tests - let testLog = testLogIn { cases = cases'} - writeFile (logFile testLog) $ show testLog - when (suiteError testLog) $ exitWith $ ExitFailure 2 - when (suiteFailed testLog) $ exitWith $ ExitFailure 1 - exitWith ExitSuccess diff -Nru ghc-7.0.3/libraries/Cabal/Distribution/Simple/UHC.hs ghc-7.2.1/libraries/Cabal/Distribution/Simple/UHC.hs --- ghc-7.0.3/libraries/Cabal/Distribution/Simple/UHC.hs 2011-03-26 18:10:12.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/Distribution/Simple/UHC.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,296 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.UHC --- Copyright : Andres Loeh 2009 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This module contains most of the UHC-specific code for configuring, building --- and installing packages. --- --- Thanks to the authors of the other implementation-specific files, in --- particular to Isaac Jones, Duncan Coutts and Henning Thielemann, for --- inspiration on how to design this module. - -{- -Copyright (c) 2009, Andres Loeh -Copyright (c) 2003-2005, Isaac Jones -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - -module Distribution.Simple.UHC ( - configure, getInstalledPackages, - buildLib, buildExe, installLib, registerPackage - ) where - -import Control.Monad -import Data.List -import Distribution.Compat.ReadP -import Distribution.InstalledPackageInfo -import Distribution.Package -import Distribution.PackageDescription -import Distribution.Simple.BuildPaths -import Distribution.Simple.Compiler as C -import Distribution.Simple.LocalBuildInfo -import Distribution.Simple.PackageIndex -import Distribution.Simple.Program -import Distribution.Simple.Utils -import Distribution.Text -import Distribution.Verbosity -import Distribution.Version -import Language.Haskell.Extension -import System.Directory -import System.FilePath - --- ----------------------------------------------------------------------------- --- Configuring - -configure :: Verbosity -> Maybe FilePath -> Maybe FilePath - -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration) -configure verbosity hcPath _hcPkgPath conf = do - - (_uhcProg, uhcVersion, conf') <- - requireProgramVersion verbosity uhcProgram - (orLaterVersion (Version [1,0,2] [])) - (userMaybeSpecifyPath "uhc" hcPath conf) - - let comp = Compiler { - compilerId = CompilerId UHC uhcVersion, - compilerLanguages = uhcLanguages, - compilerExtensions = uhcLanguageExtensions - } - return (comp, conf') - -uhcLanguages :: [(Language, C.Flag)] -uhcLanguages = [(Haskell98, "")] - --- | The flags for the supported extensions. -uhcLanguageExtensions :: [(Extension, C.Flag)] -uhcLanguageExtensions = - [(CPP, "--cpp"), - (PolymorphicComponents, ""), - (ExistentialQuantification, ""), - (ForeignFunctionInterface, ""), - (UndecidableInstances, ""), - (MultiParamTypeClasses, ""), - (Rank2Types, ""), - (PatternSignatures, ""), - (EmptyDataDecls, ""), - (NoImplicitPrelude, "--no-prelude"), - (TypeOperators, ""), - (OverlappingInstances, ""), - (FlexibleInstances, "")] - -getInstalledPackages :: Verbosity -> Compiler -> PackageDBStack -> ProgramConfiguration - -> IO PackageIndex -getInstalledPackages verbosity comp packagedbs conf = do - let compilerid = compilerId comp - systemPkgDir <- rawSystemProgramStdoutConf verbosity uhcProgram conf ["--meta-pkgdir-system"] - userPkgDir <- getUserPackageDir - let pkgDirs = nub (concatMap (packageDbPaths userPkgDir systemPkgDir) packagedbs) - -- putStrLn $ "pkgdirs: " ++ show pkgDirs - -- call to "lines" necessary, because pkgdir contains an extra newline at the end - pkgs <- liftM (map addBuiltinVersions . concat) . - mapM (\ d -> getDirectoryContents d >>= filterM (isPkgDir (display compilerid) d)) . - concatMap lines $ pkgDirs - -- putStrLn $ "pkgs: " ++ show pkgs - let iPkgs = - map mkInstalledPackageInfo $ - concatMap parsePackage $ - pkgs - -- putStrLn $ "installed pkgs: " ++ show iPkgs - return (fromList iPkgs) - -getUserPackageDir :: IO FilePath -getUserPackageDir = - do - homeDir <- getHomeDirectory - return $ homeDir ".cabal" "lib" -- TODO: determine in some other way - -packageDbPaths :: FilePath -> FilePath -> PackageDB -> [FilePath] -packageDbPaths user system db = - case db of - GlobalPackageDB -> [ system ] - UserPackageDB -> [ user ] - SpecificPackageDB path -> [ path ] - --- | Hack to add version numbers to UHC-builtin packages. This should sooner or --- later be fixed on the UHC side. -addBuiltinVersions :: String -> String -{- -addBuiltinVersions "uhcbase" = "uhcbase-1.0" -addBuiltinVersions "base" = "base-3.0" -addBuiltinVersions "array" = "array-0.2" --} -addBuiltinVersions xs = xs - --- | Name of the installed package config file. -installedPkgConfig :: String -installedPkgConfig = "installed-pkg-config" - --- | Check if a certain dir contains a valid package. Currently, we are --- looking only for the presence of an installed package configuration. --- TODO: Actually make use of the information provided in the file. -isPkgDir :: String -> String -> String -> IO Bool -isPkgDir _ _ ('.' : _) = return False -- ignore files starting with a . -isPkgDir c dir xs = do - let candidate = dir uhcPackageDir xs c - -- putStrLn $ "trying: " ++ candidate - doesFileExist (candidate installedPkgConfig) - -parsePackage :: String -> [PackageId] -parsePackage x = map fst (filter (\ (_,y) -> null y) (readP_to_S parse x)) - --- | Create a trivial package info from a directory name. -mkInstalledPackageInfo :: PackageId -> InstalledPackageInfo -mkInstalledPackageInfo p = emptyInstalledPackageInfo - { installedPackageId = InstalledPackageId (display p), - sourcePackageId = p } - - --- ----------------------------------------------------------------------------- --- Building - -buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo - -> Library -> ComponentLocalBuildInfo -> IO () -buildLib verbosity pkg_descr lbi lib clbi = do - - systemPkgDir <- rawSystemProgramStdoutConf verbosity uhcProgram (withPrograms lbi) ["--meta-pkgdir-system"] - userPkgDir <- getUserPackageDir - let runUhcProg = rawSystemProgramConf verbosity uhcProgram (withPrograms lbi) - let uhcArgs = -- set package name - ["--pkg-build=" ++ display (packageId pkg_descr)] - -- common flags lib/exe - ++ constructUHCCmdLine userPkgDir systemPkgDir - lbi (libBuildInfo lib) clbi - (buildDir lbi) verbosity - -- source files - -- suboptimal: UHC does not understand module names, so - -- we replace periods by path separators - ++ map (map (\ c -> if c == '.' then pathSeparator else c)) - (map display (libModules lib)) - - runUhcProg uhcArgs - - return () - -buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo - -> Executable -> ComponentLocalBuildInfo -> IO () -buildExe verbosity _pkg_descr lbi exe clbi = do - systemPkgDir <- rawSystemProgramStdoutConf verbosity uhcProgram (withPrograms lbi) ["--meta-pkgdir-system"] - userPkgDir <- getUserPackageDir - let runUhcProg = rawSystemProgramConf verbosity uhcProgram (withPrograms lbi) - let uhcArgs = -- common flags lib/exe - constructUHCCmdLine userPkgDir systemPkgDir - lbi (buildInfo exe) clbi - (buildDir lbi) verbosity - -- output file - ++ ["--output", buildDir lbi exeName exe] - -- main source module - ++ [modulePath exe] - runUhcProg uhcArgs - -constructUHCCmdLine :: FilePath -> FilePath - -> LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo - -> FilePath -> Verbosity -> [String] -constructUHCCmdLine user system lbi bi clbi odir verbosity = - -- verbosity - (if verbosity >= deafening then ["-v4"] - else if verbosity >= normal then [] - else ["-v0"]) - ++ hcOptions UHC bi - -- flags for language extensions - ++ languageToFlags (compiler lbi) (defaultLanguage bi) - ++ extensionsToFlags (compiler lbi) (usedExtensions bi) - -- packages - ++ ["--hide-all-packages"] - ++ uhcPackageDbOptions user system (withPackageDB lbi) - ++ ["--package=uhcbase"] - ++ ["--package=" ++ display (pkgName pkgid) | (_, pkgid) <- componentPackageDeps clbi ] - -- search paths - ++ ["-i" ++ odir] - ++ ["-i" ++ l | l <- nub (hsSourceDirs bi)] - ++ ["-i" ++ autogenModulesDir lbi] - -- output path - ++ ["--odir=" ++ odir] - -- optimization - ++ (case withOptimization lbi of - NoOptimisation -> ["-O0"] - NormalOptimisation -> ["-O1"] - MaximumOptimisation -> ["-O2"]) - -uhcPackageDbOptions :: FilePath -> FilePath -> PackageDBStack -> [String] -uhcPackageDbOptions user system db = map (\ x -> "--pkg-searchpath=" ++ x) - (concatMap (packageDbPaths user system) db) - --- ----------------------------------------------------------------------------- --- Installation - -installLib :: Verbosity -> LocalBuildInfo - -> FilePath -> FilePath -> FilePath - -> PackageDescription -> Library -> IO () -installLib verbosity _lbi targetDir _dynlibTargetDir builtDir pkg _library = do - -- putStrLn $ "dest: " ++ targetDir - -- putStrLn $ "built: " ++ builtDir - installDirectoryContents verbosity (builtDir display (packageId pkg)) targetDir - --- currently hardcoded UHC code generator and variant to use -uhcTarget, uhcTargetVariant :: String -uhcTarget = "bc" -uhcTargetVariant = "plain" - --- root directory for a package in UHC -uhcPackageDir :: String -> String -> FilePath -uhcPackageSubDir :: String -> FilePath -uhcPackageDir pkgid compilerid = pkgid uhcPackageSubDir compilerid -uhcPackageSubDir compilerid = compilerid uhcTarget uhcTargetVariant - --- ----------------------------------------------------------------------------- --- Registering - -registerPackage - :: Verbosity - -> InstalledPackageInfo - -> PackageDescription - -> LocalBuildInfo - -> Bool - -> PackageDBStack - -> IO () -registerPackage verbosity installedPkgInfo pkg lbi inplace _packageDbs = do - let installDirs = absoluteInstallDirs pkg lbi NoCopyDest - pkgdir | inplace = buildDir lbi uhcPackageDir (display pkgid) (display compilerid) - | otherwise = libdir installDirs uhcPackageSubDir (display compilerid) - createDirectoryIfMissingVerbose verbosity True pkgdir - writeUTF8File (pkgdir installedPkgConfig) - (showInstalledPackageInfo installedPkgInfo) - where - pkgid = packageId pkg - compilerid = compilerId (compiler lbi) diff -Nru ghc-7.0.3/libraries/Cabal/Distribution/Simple/UserHooks.hs ghc-7.2.1/libraries/Cabal/Distribution/Simple/UserHooks.hs --- ghc-7.0.3/libraries/Cabal/Distribution/Simple/UserHooks.hs 2011-03-26 18:10:12.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/Distribution/Simple/UserHooks.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,220 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.UserHooks --- Copyright : Isaac Jones 2003-2005 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This defines the API that @Setup.hs@ scripts can use to customise the way --- the build works. This module just defines the 'UserHooks' type. The --- predefined sets of hooks that implement the @Simple@, @Make@ and @Configure@ --- build systems are defined in "Distribution.Simple". The 'UserHooks' is a big --- record of functions. There are 3 for each action, a pre, post and the action --- itself. There are few other miscellaneous hooks, ones to extend the set of --- programs and preprocessors and one to override the function used to read the --- @.cabal@ file. --- --- This hooks type is widely agreed to not be the right solution. Partly this --- is because changes to it usually break custom @Setup.hs@ files and yet many --- internal code changes do require changes to the hooks. For example we cannot --- pass any extra parameters to most of the functions that implement the --- various phases because it would involve changing the types of the --- corresponding hook. At some point it will have to be replaced. - -{- All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - -module Distribution.Simple.UserHooks ( - UserHooks(..), Args, - emptyUserHooks, - ) where - -import Distribution.PackageDescription - (PackageDescription, GenericPackageDescription, - HookedBuildInfo, emptyHookedBuildInfo) -import Distribution.Simple.Program (Program) -import Distribution.Simple.Command (noExtraFlags) -import Distribution.Simple.PreProcess (PPSuffixHandler) -import Distribution.Simple.Setup - (ConfigFlags, BuildFlags, CleanFlags, CopyFlags, - InstallFlags, SDistFlags, RegisterFlags, HscolourFlags, - HaddockFlags, TestFlags) -import Distribution.Simple.LocalBuildInfo (LocalBuildInfo) - -type Args = [String] - --- | Hooks allow authors to add specific functionality before and after a --- command is run, and also to specify additional preprocessors. --- --- * WARNING: The hooks interface is under rather constant flux as we try to --- understand users needs. Setup files that depend on this interface may --- break in future releases. -data UserHooks = UserHooks { - - -- | Used for @.\/setup test@ - runTests :: Args -> Bool -> PackageDescription -> LocalBuildInfo -> IO (), - -- | Read the description file - readDesc :: IO (Maybe GenericPackageDescription), - -- | Custom preprocessors in addition to and overriding 'knownSuffixHandlers'. - hookedPreProcessors :: [ PPSuffixHandler ], - -- | These programs are detected at configure time. Arguments for them are - -- added to the configure command. - hookedPrograms :: [Program], - - -- |Hook to run before configure command - preConf :: Args -> ConfigFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during configure. - confHook :: (GenericPackageDescription, HookedBuildInfo) - -> ConfigFlags -> IO LocalBuildInfo, - -- |Hook to run after configure command - postConf :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before build command. Second arg indicates verbosity level. - preBuild :: Args -> BuildFlags -> IO HookedBuildInfo, - - -- |Over-ride this hook to gbet different behavior during build. - buildHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> BuildFlags -> IO (), - -- |Hook to run after build command. Second arg indicates verbosity level. - postBuild :: Args -> BuildFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before clean command. Second arg indicates verbosity level. - preClean :: Args -> CleanFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during clean. - cleanHook :: PackageDescription -> () -> UserHooks -> CleanFlags -> IO (), - -- |Hook to run after clean command. Second arg indicates verbosity level. - postClean :: Args -> CleanFlags -> PackageDescription -> () -> IO (), - - -- |Hook to run before copy command - preCopy :: Args -> CopyFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during copy. - copyHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> CopyFlags -> IO (), - -- |Hook to run after copy command - postCopy :: Args -> CopyFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before install command - preInst :: Args -> InstallFlags -> IO HookedBuildInfo, - - -- |Over-ride this hook to get different behavior during install. - instHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> InstallFlags -> IO (), - -- |Hook to run after install command. postInst should be run - -- on the target, not on the build machine. - postInst :: Args -> InstallFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before sdist command. Second arg indicates verbosity level. - preSDist :: Args -> SDistFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during sdist. - sDistHook :: PackageDescription -> Maybe LocalBuildInfo -> UserHooks -> SDistFlags -> IO (), - -- |Hook to run after sdist command. Second arg indicates verbosity level. - postSDist :: Args -> SDistFlags -> PackageDescription -> Maybe LocalBuildInfo -> IO (), - - -- |Hook to run before register command - preReg :: Args -> RegisterFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during registration. - regHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO (), - -- |Hook to run after register command - postReg :: Args -> RegisterFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before unregister command - preUnreg :: Args -> RegisterFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during registration. - unregHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO (), - -- |Hook to run after unregister command - postUnreg :: Args -> RegisterFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before hscolour command. Second arg indicates verbosity level. - preHscolour :: Args -> HscolourFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during hscolour. - hscolourHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> HscolourFlags -> IO (), - -- |Hook to run after hscolour command. Second arg indicates verbosity level. - postHscolour :: Args -> HscolourFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before haddock command. Second arg indicates verbosity level. - preHaddock :: Args -> HaddockFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during haddock. - haddockHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> HaddockFlags -> IO (), - -- |Hook to run after haddock command. Second arg indicates verbosity level. - postHaddock :: Args -> HaddockFlags -> PackageDescription -> LocalBuildInfo -> IO (), - - -- |Hook to run before test command. - preTest :: Args -> TestFlags -> IO HookedBuildInfo, - -- |Over-ride this hook to get different behavior during test. - testHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> TestFlags -> IO (), - -- |Hook to run after test command. - postTest :: Args -> TestFlags -> PackageDescription -> LocalBuildInfo -> IO () - } - -{-# DEPRECATED runTests "Please use the new testing interface instead!" #-} - --- |Empty 'UserHooks' which do nothing. -emptyUserHooks :: UserHooks -emptyUserHooks - = UserHooks { - runTests = ru, - readDesc = return Nothing, - hookedPreProcessors = [], - hookedPrograms = [], - preConf = rn, - confHook = (\_ _ -> return (error "No local build info generated during configure. Over-ride empty configure hook.")), - postConf = ru, - preBuild = rn, - buildHook = ru, - postBuild = ru, - preClean = rn, - cleanHook = ru, - postClean = ru, - preCopy = rn, - copyHook = ru, - postCopy = ru, - preInst = rn, - instHook = ru, - postInst = ru, - preSDist = rn, - sDistHook = ru, - postSDist = ru, - preReg = rn, - regHook = ru, - postReg = ru, - preUnreg = rn, - unregHook = ru, - postUnreg = ru, - preHscolour = rn, - hscolourHook = ru, - postHscolour = ru, - preHaddock = rn, - haddockHook = ru, - postHaddock = ru, - preTest = \_ _ -> return emptyHookedBuildInfo, -- same as rn, but without - -- noExtraFlags - testHook = ru, - postTest = ru - } - where rn args _ = noExtraFlags args >> return emptyHookedBuildInfo - ru _ _ _ _ = return () diff -Nru ghc-7.0.3/libraries/Cabal/Distribution/Simple/Utils.hs ghc-7.2.1/libraries/Cabal/Distribution/Simple/Utils.hs --- ghc-7.0.3/libraries/Cabal/Distribution/Simple/Utils.hs 2011-03-26 18:10:12.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/Distribution/Simple/Utils.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,1086 +0,0 @@ -{-# LANGUAGE CPP, ForeignFunctionInterface #-} -{-# OPTIONS_NHC98 -cpp #-} -{-# OPTIONS_JHC -fcpp -fffi #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple.Utils --- Copyright : Isaac Jones, Simon Marlow 2003-2004 --- portions Copyright (c) 2007, Galois Inc. --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- A large and somewhat miscellaneous collection of utility functions used --- throughout the rest of the Cabal lib and in other tools that use the Cabal --- lib like @cabal-install@. It has a very simple set of logging actions. It --- has low level functions for running programs, a bunch of wrappers for --- various directory and file functions that do extra logging. - -{- All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - -module Distribution.Simple.Utils ( - cabalVersion, - - -- * logging and errors - die, - dieWithLocation, - topHandler, - warn, notice, setupMessage, info, debug, - chattyTry, - - -- * running programs - rawSystemExit, - rawSystemExitWithEnv, - rawSystemStdout, - rawSystemStdInOut, - maybeExit, - xargs, - findProgramLocation, - findProgramVersion, - - -- * copying files - smartCopySources, - createDirectoryIfMissingVerbose, - copyFileVerbose, - copyDirectoryRecursiveVerbose, - copyFiles, - - -- * installing files - installOrdinaryFile, - installExecutableFile, - installOrdinaryFiles, - installDirectoryContents, - - -- * file names - currentDir, - - -- * finding files - findFile, - findFileWithExtension, - findFileWithExtension', - findModuleFile, - findModuleFiles, - getDirectoryContentsRecursive, - - -- * simple file globbing - matchFileGlob, - matchDirFileGlob, - parseFileGlob, - FileGlob(..), - - -- * temp files and dirs - withTempFile, - withTempDirectory, - - -- * .cabal and .buildinfo files - defaultPackageDesc, - findPackageDesc, - defaultHookedPackageDesc, - findHookedPackageDesc, - - -- * reading and writing files safely - withFileContents, - writeFileAtomic, - rewriteFile, - - -- * Unicode - fromUTF8, - toUTF8, - readUTF8File, - withUTF8FileContents, - writeUTF8File, - normaliseLineEndings, - - -- * generic utils - equating, - comparing, - isInfixOf, - intercalate, - lowercase, - wrapText, - wrapLine, - ) where - -import Control.Monad - ( when, unless, filterM ) -#ifdef __GLASGOW_HASKELL__ -import Control.Concurrent.MVar - ( newEmptyMVar, putMVar, takeMVar ) -#endif -import Data.List - ( nub, unfoldr, isPrefixOf, tails, intersperse ) -import Data.Char as Char - ( toLower, chr, ord ) -import Data.Bits - ( Bits((.|.), (.&.), shiftL, shiftR) ) - -import System.Directory - ( getDirectoryContents, doesDirectoryExist, doesFileExist, removeFile - , findExecutable ) -import System.Environment - ( getProgName ) -import System.Cmd - ( rawSystem ) -import System.Exit - ( exitWith, ExitCode(..) ) -import System.FilePath - ( normalise, (), (<.>), takeDirectory, splitFileName - , splitExtension, splitExtensions ) -import System.Directory - ( createDirectoryIfMissing, renameFile, removeDirectoryRecursive ) -import System.IO - ( Handle, openFile, openBinaryFile, IOMode(ReadMode), hSetBinaryMode - , hGetContents, stderr, stdout, hPutStr, hFlush, hClose ) -import System.IO.Error as IO.Error - ( isDoesNotExistError, ioeSetFileName, ioeGetFileName, ioeGetErrorString ) -#if !(defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 608)) -import System.IO.Error - ( ioeSetLocation, ioeGetLocation ) -#endif -import System.IO.Unsafe - ( unsafeInterleaveIO ) -import qualified Control.Exception as Exception - -import Distribution.Text - ( display, simpleParse ) -import Distribution.Package - ( PackageIdentifier ) -import Distribution.ModuleName (ModuleName) -import qualified Distribution.ModuleName as ModuleName -import Distribution.Version - (Version(..)) - -import Control.Exception (evaluate) -import System.Process (runProcess) - -#ifdef __GLASGOW_HASKELL__ -import Control.Concurrent (forkIO) -import System.Process (runInteractiveProcess, waitForProcess) -#else -import System.Cmd (system) -import System.Directory (getTemporaryDirectory) -#endif - -import Distribution.Compat.CopyFile - ( copyFile, copyOrdinaryFile, copyExecutableFile ) -import Distribution.Compat.TempFile - ( openTempFile, openNewBinaryFile, createTempDirectory ) -import Distribution.Compat.Exception - ( catchIO, catchExit, onException ) -import Distribution.Verbosity - -#ifdef VERSION_base -import qualified Paths_Cabal (version) -#endif - --- We only get our own version number when we're building with ourselves -cabalVersion :: Version -#if defined(VERSION_base) -cabalVersion = Paths_Cabal.version -#elif defined(CABAL_VERSION) -cabalVersion = Version [CABAL_VERSION] [] -#else -cabalVersion = Version [1,9999] [] --used when bootstrapping -#endif - --- ---------------------------------------------------------------------------- --- Exception and logging utils - -dieWithLocation :: FilePath -> Maybe Int -> String -> IO a -dieWithLocation filename lineno msg = - ioError . setLocation lineno - . flip ioeSetFileName (normalise filename) - $ userError msg - where -#if defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 608) - setLocation _ err = err -#else - setLocation Nothing err = err - setLocation (Just n) err = ioeSetLocation err (show n) -#endif - -die :: String -> IO a -die msg = ioError (userError msg) - -topHandler :: IO a -> IO a -topHandler prog = catch prog handle - where - handle ioe = do - hFlush stdout - pname <- getProgName - hPutStr stderr (mesage pname) - exitWith (ExitFailure 1) - where - mesage pname = wrapText (pname ++ ": " ++ file ++ detail) - file = case ioeGetFileName ioe of - Nothing -> "" - Just path -> path ++ location ++ ": " -#if defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 608) - location = "" -#else - location = case ioeGetLocation ioe of - l@(n:_) | n >= '0' && n <= '9' -> ':' : l - _ -> "" -#endif - detail = ioeGetErrorString ioe - --- | Non fatal conditions that may be indicative of an error or problem. --- --- We display these at the 'normal' verbosity level. --- -warn :: Verbosity -> String -> IO () -warn verbosity msg = - when (verbosity >= normal) $ do - hFlush stdout - hPutStr stderr (wrapText ("Warning: " ++ msg)) - --- | Useful status messages. --- --- We display these at the 'normal' verbosity level. --- --- This is for the ordinary helpful status messages that users see. Just --- enough information to know that things are working but not floods of detail. --- -notice :: Verbosity -> String -> IO () -notice verbosity msg = - when (verbosity >= normal) $ - putStr (wrapText msg) - -setupMessage :: Verbosity -> String -> PackageIdentifier -> IO () -setupMessage verbosity msg pkgid = - notice verbosity (msg ++ ' ': display pkgid ++ "...") - --- | More detail on the operation of some action. --- --- We display these messages when the verbosity level is 'verbose' --- -info :: Verbosity -> String -> IO () -info verbosity msg = - when (verbosity >= verbose) $ - putStr (wrapText msg) - --- | Detailed internal debugging information --- --- We display these messages when the verbosity level is 'deafening' --- -debug :: Verbosity -> String -> IO () -debug verbosity msg = - when (verbosity >= deafening) $ do - putStr (wrapText msg) - hFlush stdout - --- | Perform an IO action, catching any IO exceptions and printing an error --- if one occurs. -chattyTry :: String -- ^ a description of the action we were attempting - -> IO () -- ^ the action itself - -> IO () -chattyTry desc action = - catchIO action $ \exception -> - putStrLn $ "Error while " ++ desc ++ ": " ++ show exception - --- ----------------------------------------------------------------------------- --- Helper functions - --- | Wraps text to the default line width. Existing newlines are preserved. -wrapText :: String -> String -wrapText = unlines - . concatMap (map unwords - . wrapLine 79 - . words) - . lines - --- | Wraps a list of words to a list of lines of words of a particular width. -wrapLine :: Int -> [String] -> [[String]] -wrapLine width = wrap 0 [] - where wrap :: Int -> [String] -> [String] -> [[String]] - wrap 0 [] (w:ws) - | length w + 1 > width - = wrap (length w) [w] ws - wrap col line (w:ws) - | col + length w + 1 > width - = reverse line : wrap 0 [] (w:ws) - wrap col line (w:ws) - = let col' = col + length w + 1 - in wrap col' (w:line) ws - wrap _ [] [] = [] - wrap _ line [] = [reverse line] - --- ----------------------------------------------------------------------------- --- rawSystem variants -maybeExit :: IO ExitCode -> IO () -maybeExit cmd = do - res <- cmd - unless (res == ExitSuccess) $ exitWith res - -printRawCommandAndArgs :: Verbosity -> FilePath -> [String] -> IO () -printRawCommandAndArgs verbosity path args - | verbosity >= deafening = print (path, args) - | verbosity >= verbose = putStrLn $ unwords (path : args) - | otherwise = return () - -printRawCommandAndArgsAndEnv :: Verbosity - -> FilePath - -> [String] - -> [(String, String)] - -> IO () -printRawCommandAndArgsAndEnv verbosity path args env - | verbosity >= deafening = do putStrLn ("Environment: " ++ show env) - print (path, args) - | verbosity >= verbose = putStrLn $ unwords (path : args) - | otherwise = return () - --- Exit with the same exitcode if the subcommand fails -rawSystemExit :: Verbosity -> FilePath -> [String] -> IO () -rawSystemExit verbosity path args = do - printRawCommandAndArgs verbosity path args - hFlush stdout - exitcode <- rawSystem path args - unless (exitcode == ExitSuccess) $ do - debug verbosity $ path ++ " returned " ++ show exitcode - exitWith exitcode - -rawSystemExitWithEnv :: Verbosity - -> FilePath - -> [String] - -> [(String, String)] - -> IO () -rawSystemExitWithEnv verbosity path args env = do - printRawCommandAndArgsAndEnv verbosity path args env - hFlush stdout - ph <- runProcess path args Nothing (Just env) Nothing Nothing Nothing - exitcode <- waitForProcess ph - unless (exitcode == ExitSuccess) $ do - debug verbosity $ path ++ " returned " ++ show exitcode - exitWith exitcode - --- | Run a command and return its output. --- --- The output is assumed to be text in the locale encoding. --- -rawSystemStdout :: Verbosity -> FilePath -> [String] -> IO String -rawSystemStdout verbosity path args = do - (output, errors, exitCode) <- rawSystemStdInOut verbosity path args - Nothing False - when (exitCode /= ExitSuccess) $ - die errors - return output - --- | Run a command and return its output, errors and exit status. Optionally --- also supply some input. Also provides control over whether the binary/text --- mode of the input and output. --- -rawSystemStdInOut :: Verbosity - -> FilePath -> [String] - -> Maybe (String, Bool) -- ^ input text and binary mode - -> Bool -- ^ output in binary mode - -> IO (String, String, ExitCode) -- ^ output, errors, exit -rawSystemStdInOut verbosity path args input outputBinary = do - printRawCommandAndArgs verbosity path args - -#ifdef __GLASGOW_HASKELL__ - Exception.bracket - (runInteractiveProcess path args Nothing Nothing) - (\(inh,outh,errh,_) -> hClose inh >> hClose outh >> hClose errh) - $ \(inh,outh,errh,pid) -> do - - -- output mode depends on what the caller wants - hSetBinaryMode outh outputBinary - -- but the errors are always assumed to be text (in the current locale) - hSetBinaryMode errh False - - -- fork off a couple threads to pull on the stderr and stdout - -- so if the process writes to stderr we do not block. - - err <- hGetContents errh - out <- hGetContents outh - - mv <- newEmptyMVar - let force str = (evaluate (length str) >> return ()) - `Exception.finally` putMVar mv () - --TODO: handle exceptions like text decoding. - _ <- forkIO $ force out - _ <- forkIO $ force err - - -- push all the input, if any - case input of - Nothing -> return () - Just (inputStr, inputBinary) -> do - -- input mode depends on what the caller wants - hSetBinaryMode inh inputBinary - hPutStr inh inputStr - hClose inh - --TODO: this probably fails if the process refuses to consume - -- or if it closes stdin (eg if it exits) - - -- wait for both to finish, in either order - takeMVar mv - takeMVar mv - - -- wait for the program to terminate - exitcode <- waitForProcess pid - unless (exitcode == ExitSuccess) $ - debug verbosity $ path ++ " returned " ++ show exitcode - ++ if null err then "" else - " with error message:\n" ++ err - - return (out, err, exitcode) -#else - tmpDir <- getTemporaryDirectory - withTempFile tmpDir ".cmd.stdout" $ \outName outHandle -> - withTempFile tmpDir ".cmd.stdin" $ \inName inHandle -> do - hClose outHandle - - case input of - Nothing -> return () - Just (inputStr, inputBinary) -> do - hSetBinaryMode inHandle inputBinary - hPutStr inHandle inputStr - hClose inHandle - - let quote name = "'" ++ name ++ "'" - cmd = unwords (map quote (path:args)) - ++ " <" ++ quote inName - ++ " >" ++ quote outName - exitcode <- system cmd - - unless (exitcode == ExitSuccess) $ - debug verbosity $ path ++ " returned " ++ show exitcode - - Exception.bracket (openFile outName ReadMode) hClose $ \hnd -> do - hSetBinaryMode hnd outputBinary - output <- hGetContents hnd - length output `seq` return (output, "", exitcode) -#endif - - --- | Look for a program on the path. -findProgramLocation :: Verbosity -> FilePath -> IO (Maybe FilePath) -findProgramLocation verbosity prog = do - debug verbosity $ "searching for " ++ prog ++ " in path." - res <- findExecutable prog - case res of - Nothing -> debug verbosity ("Cannot find " ++ prog ++ " on the path") - Just path -> debug verbosity ("found " ++ prog ++ " at "++ path) - return res - - --- | Look for a program and try to find it's version number. It can accept --- either an absolute path or the name of a program binary, in which case we --- will look for the program on the path. --- -findProgramVersion :: String -- ^ version args - -> (String -> String) -- ^ function to select version - -- number from program output - -> Verbosity - -> FilePath -- ^ location - -> IO (Maybe Version) -findProgramVersion versionArg selectVersion verbosity path = do - str <- rawSystemStdout verbosity path [versionArg] - `catchIO` (\_ -> return "") - `catchExit` (\_ -> return "") - let version :: Maybe Version - version = simpleParse (selectVersion str) - case version of - Nothing -> warn verbosity $ "cannot determine version of " ++ path - ++ " :\n" ++ show str - Just v -> debug verbosity $ path ++ " is version " ++ display v - return version - - --- | Like the unix xargs program. Useful for when we've got very long command --- lines that might overflow an OS limit on command line length and so you --- need to invoke a command multiple times to get all the args in. --- --- Use it with either of the rawSystem variants above. For example: --- --- > xargs (32*1024) (rawSystemExit verbosity) prog fixedArgs bigArgs --- -xargs :: Int -> ([String] -> IO ()) - -> [String] -> [String] -> IO () -xargs maxSize rawSystemFun fixedArgs bigArgs = - let fixedArgSize = sum (map length fixedArgs) + length fixedArgs - chunkSize = maxSize - fixedArgSize - in mapM_ (rawSystemFun . (fixedArgs ++)) (chunks chunkSize bigArgs) - - where chunks len = unfoldr $ \s -> - if null s then Nothing - else Just (chunk [] len s) - - chunk acc _ [] = (reverse acc,[]) - chunk acc len (s:ss) - | len' < len = chunk (s:acc) (len-len'-1) ss - | otherwise = (reverse acc, s:ss) - where len' = length s - --- ------------------------------------------------------------ --- * File Utilities --- ------------------------------------------------------------ - ----------------- --- Finding files - --- | Find a file by looking in a search path. The file path must match exactly. --- -findFile :: [FilePath] -- ^search locations - -> FilePath -- ^File Name - -> IO FilePath -findFile searchPath fileName = - findFirstFile id - [ path fileName - | path <- nub searchPath] - >>= maybe (die $ fileName ++ " doesn't exist") return - --- | Find a file by looking in a search path with one of a list of possible --- file extensions. The file base name should be given and it will be tried --- with each of the extensions in each element of the search path. --- -findFileWithExtension :: [String] - -> [FilePath] - -> FilePath - -> IO (Maybe FilePath) -findFileWithExtension extensions searchPath baseName = - findFirstFile id - [ path baseName <.> ext - | path <- nub searchPath - , ext <- nub extensions ] - --- | Like 'findFileWithExtension' but returns which element of the search path --- the file was found in, and the file path relative to that base directory. --- -findFileWithExtension' :: [String] - -> [FilePath] - -> FilePath - -> IO (Maybe (FilePath, FilePath)) -findFileWithExtension' extensions searchPath baseName = - findFirstFile (uncurry ()) - [ (path, baseName <.> ext) - | path <- nub searchPath - , ext <- nub extensions ] - -findFirstFile :: (a -> FilePath) -> [a] -> IO (Maybe a) -findFirstFile file = findFirst - where findFirst [] = return Nothing - findFirst (x:xs) = do exists <- doesFileExist (file x) - if exists - then return (Just x) - else findFirst xs - --- | Finds the files corresponding to a list of Haskell module names. --- --- As 'findModuleFile' but for a list of module names. --- -findModuleFiles :: [FilePath] -- ^ build prefix (location of objects) - -> [String] -- ^ search suffixes - -> [ModuleName] -- ^ modules - -> IO [(FilePath, FilePath)] -findModuleFiles searchPath extensions moduleNames = - mapM (findModuleFile searchPath extensions) moduleNames - --- | Find the file corresponding to a Haskell module name. --- --- This is similar to 'findFileWithExtension'' but specialised to a module --- name. The function fails if the file corresponding to the module is missing. --- -findModuleFile :: [FilePath] -- ^ build prefix (location of objects) - -> [String] -- ^ search suffixes - -> ModuleName -- ^ module - -> IO (FilePath, FilePath) -findModuleFile searchPath extensions moduleName = - maybe notFound return - =<< findFileWithExtension' extensions searchPath - (ModuleName.toFilePath moduleName) - where - notFound = die $ "Error: Could not find module: " ++ display moduleName - ++ " with any suffix: " ++ show extensions - ++ " in the search path: " ++ show searchPath - --- | List all the files in a directory and all subdirectories. --- --- The order places files in sub-directories after all the files in their --- parent directories. The list is generated lazily so is not well defined if --- the source directory structure changes before the list is used. --- -getDirectoryContentsRecursive :: FilePath -> IO [FilePath] -getDirectoryContentsRecursive topdir = recurseDirectories [""] - where - recurseDirectories :: [FilePath] -> IO [FilePath] - recurseDirectories [] = return [] - recurseDirectories (dir:dirs) = unsafeInterleaveIO $ do - (files, dirs') <- collect [] [] =<< getDirectoryContents (topdir dir) - files' <- recurseDirectories (dirs' ++ dirs) - return (files ++ files') - - where - collect files dirs' [] = return (reverse files, reverse dirs') - collect files dirs' (entry:entries) | ignore entry - = collect files dirs' entries - collect files dirs' (entry:entries) = do - let dirEntry = dir entry - isDirectory <- doesDirectoryExist (topdir dirEntry) - if isDirectory - then collect files (dirEntry:dirs') entries - else collect (dirEntry:files) dirs' entries - - ignore ['.'] = True - ignore ['.', '.'] = True - ignore _ = False - ----------------- --- File globbing - -data FileGlob - -- | No glob at all, just an ordinary file - = NoGlob FilePath - - -- | dir prefix and extension, like @\"foo\/bar\/\*.baz\"@ corresponds to - -- @FileGlob \"foo\/bar\" \".baz\"@ - | FileGlob FilePath String - -parseFileGlob :: FilePath -> Maybe FileGlob -parseFileGlob filepath = case splitExtensions filepath of - (filepath', ext) -> case splitFileName filepath' of - (dir, "*") | '*' `elem` dir - || '*' `elem` ext - || null ext -> Nothing - | null dir -> Just (FileGlob "." ext) - | otherwise -> Just (FileGlob dir ext) - _ | '*' `elem` filepath -> Nothing - | otherwise -> Just (NoGlob filepath) - -matchFileGlob :: FilePath -> IO [FilePath] -matchFileGlob = matchDirFileGlob "." - -matchDirFileGlob :: FilePath -> FilePath -> IO [FilePath] -matchDirFileGlob dir filepath = case parseFileGlob filepath of - Nothing -> die $ "invalid file glob '" ++ filepath - ++ "'. Wildcards '*' are only allowed in place of the file" - ++ " name, not in the directory name or file extension." - ++ " If a wildcard is used it must be with an file extension." - Just (NoGlob filepath') -> return [filepath'] - Just (FileGlob dir' ext) -> do - files <- getDirectoryContents (dir dir') - case [ dir' file - | file <- files - , let (name, ext') = splitExtensions file - , not (null name) && ext' == ext ] of - [] -> die $ "filepath wildcard '" ++ filepath - ++ "' does not match any files." - matches -> return matches - ----------------------------------------- --- Copying and installing files and dirs - --- | Same as 'createDirectoryIfMissing' but logs at higher verbosity levels. --- -createDirectoryIfMissingVerbose :: Verbosity -> Bool -> FilePath -> IO () -createDirectoryIfMissingVerbose verbosity parentsToo dir = do - let msgParents = if parentsToo then " (and its parents)" else "" - info verbosity ("Creating " ++ dir ++ msgParents) - createDirectoryIfMissing parentsToo dir - --- | Copies a file without copying file permissions. The target file is created --- with default permissions. Any existing target file is replaced. --- --- At higher verbosity levels it logs an info message. --- -copyFileVerbose :: Verbosity -> FilePath -> FilePath -> IO () -copyFileVerbose verbosity src dest = do - info verbosity ("copy " ++ src ++ " to " ++ dest) - copyFile src dest - --- | Install an ordinary file. This is like a file copy but the permissions --- are set appropriately for an installed file. On Unix it is \"-rw-r--r--\" --- while on Windows it uses the default permissions for the target directory. --- -installOrdinaryFile :: Verbosity -> FilePath -> FilePath -> IO () -installOrdinaryFile verbosity src dest = do - info verbosity ("Installing " ++ src ++ " to " ++ dest) - copyOrdinaryFile src dest - --- | Install an executable file. This is like a file copy but the permissions --- are set appropriately for an installed file. On Unix it is \"-rwxr-xr-x\" --- while on Windows it uses the default permissions for the target directory. --- -installExecutableFile :: Verbosity -> FilePath -> FilePath -> IO () -installExecutableFile verbosity src dest = do - info verbosity ("Installing executable " ++ src ++ " to " ++ dest) - copyExecutableFile src dest - --- | Copies a bunch of files to a target directory, preserving the directory --- structure in the target location. The target directories are created if they --- do not exist. --- --- The files are identified by a pair of base directory and a path relative to --- that base. It is only the relative part that is preserved in the --- destination. --- --- For example: --- --- > copyFiles normal "dist/src" --- > [("", "src/Foo.hs"), ("dist/build/", "src/Bar.hs")] --- --- This would copy \"src\/Foo.hs\" to \"dist\/src\/src\/Foo.hs\" and --- copy \"dist\/build\/src\/Bar.hs\" to \"dist\/src\/src\/Bar.hs\". --- --- This operation is not atomic. Any IO failure during the copy (including any --- missing source files) leaves the target in an unknown state so it is best to --- use it with a freshly created directory so that it can be simply deleted if --- anything goes wrong. --- -copyFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO () -copyFiles verbosity targetDir srcFiles = do - - -- Create parent directories for everything - let dirs = map (targetDir ) . nub . map (takeDirectory . snd) $ srcFiles - mapM_ (createDirectoryIfMissingVerbose verbosity True) dirs - - -- Copy all the files - sequence_ [ let src = srcBase srcFile - dest = targetDir srcFile - in copyFileVerbose verbosity src dest - | (srcBase, srcFile) <- srcFiles ] - --- | This is like 'copyFiles' but uses 'installOrdinaryFile'. --- -installOrdinaryFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO () -installOrdinaryFiles verbosity targetDir srcFiles = do - - -- Create parent directories for everything - let dirs = map (targetDir ) . nub . map (takeDirectory . snd) $ srcFiles - mapM_ (createDirectoryIfMissingVerbose verbosity True) dirs - - -- Copy all the files - sequence_ [ let src = srcBase srcFile - dest = targetDir srcFile - in installOrdinaryFile verbosity src dest - | (srcBase, srcFile) <- srcFiles ] - --- | This installs all the files in a directory to a target location, --- preserving the directory layout. All the files are assumed to be ordinary --- rather than executable files. --- -installDirectoryContents :: Verbosity -> FilePath -> FilePath -> IO () -installDirectoryContents verbosity srcDir destDir = do - info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.") - srcFiles <- getDirectoryContentsRecursive srcDir - installOrdinaryFiles verbosity destDir [ (srcDir, f) | f <- srcFiles ] - ---------------------------------- --- Deprecated file copy functions - -{-# DEPRECATED smartCopySources - "Use findModuleFiles and copyFiles or installOrdinaryFiles" #-} -smartCopySources :: Verbosity -> [FilePath] -> FilePath - -> [ModuleName] -> [String] -> IO () -smartCopySources verbosity searchPath targetDir moduleNames extensions = - findModuleFiles searchPath extensions moduleNames - >>= copyFiles verbosity targetDir - -{-# DEPRECATED copyDirectoryRecursiveVerbose - "You probably want installDirectoryContents instead" #-} -copyDirectoryRecursiveVerbose :: Verbosity -> FilePath -> FilePath -> IO () -copyDirectoryRecursiveVerbose verbosity srcDir destDir = do - info verbosity ("copy directory '" ++ srcDir ++ "' to '" ++ destDir ++ "'.") - srcFiles <- getDirectoryContentsRecursive srcDir - copyFiles verbosity destDir [ (srcDir, f) | f <- srcFiles ] - ---------------------------- --- Temporary files and dirs - --- | Use a temporary filename that doesn't already exist. --- -withTempFile :: FilePath -- ^ Temp dir to create the file in - -> String -- ^ File name template. See 'openTempFile'. - -> (FilePath -> Handle -> IO a) -> IO a -withTempFile tmpDir template action = - Exception.bracket - (openTempFile tmpDir template) - (\(name, handle) -> hClose handle >> removeFile name) - (uncurry action) - --- | Create and use a temporary directory. --- --- Creates a new temporary directory inside the given directory, making use --- of the template. The temp directory is deleted after use. For example: --- --- > withTempDirectory verbosity "src" "sdist." $ \tmpDir -> do ... --- --- The @tmpDir@ will be a new subdirectory of the given directory, e.g. --- @src/sdist.342@. --- -withTempDirectory :: Verbosity -> FilePath -> String -> (FilePath -> IO a) -> IO a -withTempDirectory _verbosity targetDir template = - Exception.bracket - (createTempDirectory targetDir template) - (removeDirectoryRecursive) - ------------------------------------ --- Safely reading and writing files - --- | Gets the contents of a file, but guarantee that it gets closed. --- --- The file is read lazily but if it is not fully consumed by the action then --- the remaining input is truncated and the file is closed. --- -withFileContents :: FilePath -> (String -> IO a) -> IO a -withFileContents name action = - Exception.bracket (openFile name ReadMode) hClose - (\hnd -> hGetContents hnd >>= action) - --- | Writes a file atomically. --- --- The file is either written sucessfully or an IO exception is raised and --- the original file is left unchanged. --- --- On windows it is not possible to delete a file that is open by a process. --- This case will give an IO exception but the atomic property is not affected. --- -writeFileAtomic :: FilePath -> String -> IO () -writeFileAtomic targetFile content = do - (tmpFile, tmpHandle) <- openNewBinaryFile targetDir template - do hPutStr tmpHandle content - hClose tmpHandle - renameFile tmpFile targetFile - `onException` do hClose tmpHandle - removeFile tmpFile - where - template = targetName <.> "tmp" - targetDir | null targetDir_ = currentDir - | otherwise = targetDir_ - --TODO: remove this when takeDirectory/splitFileName is fixed - -- to always return a valid dir - (targetDir_,targetName) = splitFileName targetFile - --- | Write a file but only if it would have new content. If we would be writing --- the same as the existing content then leave the file as is so that we do not --- update the file's modification time. --- -rewriteFile :: FilePath -> String -> IO () -rewriteFile path newContent = - flip catch mightNotExist $ do - existingContent <- readFile path - _ <- evaluate (length existingContent) - unless (existingContent == newContent) $ - writeFileAtomic path newContent - where - mightNotExist e | isDoesNotExistError e = writeFileAtomic path newContent - | otherwise = ioError e - --- | The path name that represents the current directory. --- In Unix, it's @\".\"@, but this is system-specific. --- (E.g. AmigaOS uses the empty string @\"\"@ for the current directory.) -currentDir :: FilePath -currentDir = "." - --- ------------------------------------------------------------ --- * Finding the description file --- ------------------------------------------------------------ - --- |Package description file (/pkgname/@.cabal@) -defaultPackageDesc :: Verbosity -> IO FilePath -defaultPackageDesc _verbosity = findPackageDesc currentDir - --- |Find a package description file in the given directory. Looks for --- @.cabal@ files. -findPackageDesc :: FilePath -- ^Where to look - -> IO FilePath -- ^.cabal -findPackageDesc dir - = do files <- getDirectoryContents dir - -- to make sure we do not mistake a ~/.cabal/ dir for a .cabal - -- file we filter to exclude dirs and null base file names: - cabalFiles <- filterM doesFileExist - [ dir file - | file <- files - , let (name, ext) = splitExtension file - , not (null name) && ext == ".cabal" ] - case cabalFiles of - [] -> noDesc - [cabalFile] -> return cabalFile - multiple -> multiDesc multiple - - where - noDesc :: IO a - noDesc = die $ "No cabal file found.\n" - ++ "Please create a package description file .cabal" - - multiDesc :: [String] -> IO a - multiDesc l = die $ "Multiple cabal files found.\n" - ++ "Please use only one of: " - ++ show l - --- |Optional auxiliary package information file (/pkgname/@.buildinfo@) -defaultHookedPackageDesc :: IO (Maybe FilePath) -defaultHookedPackageDesc = findHookedPackageDesc currentDir - --- |Find auxiliary package information in the given directory. --- Looks for @.buildinfo@ files. -findHookedPackageDesc - :: FilePath -- ^Directory to search - -> IO (Maybe FilePath) -- ^/dir/@\/@/pkgname/@.buildinfo@, if present -findHookedPackageDesc dir = do - files <- getDirectoryContents dir - buildInfoFiles <- filterM doesFileExist - [ dir file - | file <- files - , let (name, ext) = splitExtension file - , not (null name) && ext == buildInfoExt ] - case buildInfoFiles of - [] -> return Nothing - [f] -> return (Just f) - _ -> die ("Multiple files with extension " ++ buildInfoExt) - -buildInfoExt :: String -buildInfoExt = ".buildinfo" - --- ------------------------------------------------------------ --- * Unicode stuff --- ------------------------------------------------------------ - --- This is a modification of the UTF8 code from gtk2hs and the --- utf8-string package. - -fromUTF8 :: String -> String -fromUTF8 [] = [] -fromUTF8 (c:cs) - | c <= '\x7F' = c : fromUTF8 cs - | c <= '\xBF' = replacementChar : fromUTF8 cs - | c <= '\xDF' = twoBytes c cs - | c <= '\xEF' = moreBytes 3 0x800 cs (ord c .&. 0xF) - | c <= '\xF7' = moreBytes 4 0x10000 cs (ord c .&. 0x7) - | c <= '\xFB' = moreBytes 5 0x200000 cs (ord c .&. 0x3) - | c <= '\xFD' = moreBytes 6 0x4000000 cs (ord c .&. 0x1) - | otherwise = replacementChar : fromUTF8 cs - where - twoBytes c0 (c1:cs') - | ord c1 .&. 0xC0 == 0x80 - = let d = ((ord c0 .&. 0x1F) `shiftL` 6) - .|. (ord c1 .&. 0x3F) - in if d >= 0x80 - then chr d : fromUTF8 cs' - else replacementChar : fromUTF8 cs' - twoBytes _ cs' = replacementChar : fromUTF8 cs' - - moreBytes :: Int -> Int -> [Char] -> Int -> [Char] - moreBytes 1 overlong cs' acc - | overlong <= acc && acc <= 0x10FFFF - && (acc < 0xD800 || 0xDFFF < acc) - && (acc < 0xFFFE || 0xFFFF < acc) - = chr acc : fromUTF8 cs' - - | otherwise - = replacementChar : fromUTF8 cs' - - moreBytes byteCount overlong (cn:cs') acc - | ord cn .&. 0xC0 == 0x80 - = moreBytes (byteCount-1) overlong cs' - ((acc `shiftL` 6) .|. ord cn .&. 0x3F) - - moreBytes _ _ cs' _ - = replacementChar : fromUTF8 cs' - - replacementChar = '\xfffd' - -toUTF8 :: String -> String -toUTF8 [] = [] -toUTF8 (c:cs) - | c <= '\x07F' = c - : toUTF8 cs - | c <= '\x7FF' = chr (0xC0 .|. (w `shiftR` 6)) - : chr (0x80 .|. (w .&. 0x3F)) - : toUTF8 cs - | c <= '\xFFFF'= chr (0xE0 .|. (w `shiftR` 12)) - : chr (0x80 .|. ((w `shiftR` 6) .&. 0x3F)) - : chr (0x80 .|. (w .&. 0x3F)) - : toUTF8 cs - | otherwise = chr (0xf0 .|. (w `shiftR` 18)) - : chr (0x80 .|. ((w `shiftR` 12) .&. 0x3F)) - : chr (0x80 .|. ((w `shiftR` 6) .&. 0x3F)) - : chr (0x80 .|. (w .&. 0x3F)) - : toUTF8 cs - where w = ord c - --- | Ignore a Unicode byte order mark (BOM) at the beginning of the input --- -ignoreBOM :: String -> String -ignoreBOM ('\xFEFF':string) = string -ignoreBOM string = string - --- | Reads a UTF8 encoded text file as a Unicode String --- --- Reads lazily using ordinary 'readFile'. --- -readUTF8File :: FilePath -> IO String -readUTF8File f = fmap (ignoreBOM . fromUTF8) - . hGetContents =<< openBinaryFile f ReadMode - --- | Reads a UTF8 encoded text file as a Unicode String --- --- Same behaviour as 'withFileContents'. --- -withUTF8FileContents :: FilePath -> (String -> IO a) -> IO a -withUTF8FileContents name action = - Exception.bracket - (openBinaryFile name ReadMode) - hClose - (\hnd -> hGetContents hnd >>= action . ignoreBOM . fromUTF8) - --- | Writes a Unicode String as a UTF8 encoded text file. --- --- Uses 'writeFileAtomic', so provides the same guarantees. --- -writeUTF8File :: FilePath -> String -> IO () -writeUTF8File path = writeFileAtomic path . toUTF8 - --- | Fix different systems silly line ending conventions -normaliseLineEndings :: String -> String -normaliseLineEndings [] = [] -normaliseLineEndings ('\r':'\n':s) = '\n' : normaliseLineEndings s -- windows -normaliseLineEndings ('\r':s) = '\n' : normaliseLineEndings s -- old osx -normaliseLineEndings ( c :s) = c : normaliseLineEndings s - --- ------------------------------------------------------------ --- * Common utils --- ------------------------------------------------------------ - -equating :: Eq a => (b -> a) -> b -> b -> Bool -equating p x y = p x == p y - -comparing :: Ord a => (b -> a) -> b -> b -> Ordering -comparing p x y = p x `compare` p y - -isInfixOf :: String -> String -> Bool -isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack) - -intercalate :: [a] -> [[a]] -> [a] -intercalate sep = concat . intersperse sep - -lowercase :: String -> String -lowercase = map Char.toLower diff -Nru ghc-7.0.3/libraries/Cabal/Distribution/Simple.hs ghc-7.2.1/libraries/Cabal/Distribution/Simple.hs --- ghc-7.0.3/libraries/Cabal/Distribution/Simple.hs 2011-03-26 18:10:12.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/Distribution/Simple.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,652 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Simple --- Copyright : Isaac Jones 2003-2005 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This is the command line front end to the Simple build system. When given --- the parsed command-line args and package information, is able to perform --- basic commands like configure, build, install, register, etc. --- --- This module exports the main functions that Setup.hs scripts use. It --- re-exports the 'UserHooks' type, the standard entry points like --- 'defaultMain' and 'defaultMainWithHooks' and the predefined sets of --- 'UserHooks' that custom @Setup.hs@ scripts can extend to add their own --- behaviour. --- --- This module isn't called \"Simple\" because it's simple. Far from --- it. It's called \"Simple\" because it does complicated things to --- simple software. --- --- The original idea was that there could be different build systems that all --- presented the same compatible command line interfaces. There is still a --- "Distribution.Make" system but in practice no packages use it. - -{- All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - -{- -Work around this warning: -libraries/Cabal/Distribution/Simple.hs:78:0: - Warning: In the use of `runTests' - (imported from Distribution.Simple.UserHooks): - Deprecated: "Please use the new testing interface instead!" --} -{-# OPTIONS_GHC -fno-warn-deprecations #-} - -module Distribution.Simple ( - module Distribution.Package, - module Distribution.Version, - module Distribution.License, - module Distribution.Simple.Compiler, - module Language.Haskell.Extension, - -- * Simple interface - defaultMain, defaultMainNoRead, defaultMainArgs, - -- * Customization - UserHooks(..), Args, - defaultMainWithHooks, defaultMainWithHooksArgs, - -- ** Standard sets of hooks - simpleUserHooks, - autoconfUserHooks, - defaultUserHooks, emptyUserHooks, - -- ** Utils - defaultHookedPackageDesc - ) where - --- local -import Distribution.Simple.Compiler hiding (Flag) -import Distribution.Simple.UserHooks -import Distribution.Package --must not specify imports, since we're exporting moule. -import Distribution.PackageDescription - ( PackageDescription(..), GenericPackageDescription - , updatePackageDescription, hasLibs - , HookedBuildInfo, emptyHookedBuildInfo ) -import Distribution.PackageDescription.Parse - ( readPackageDescription, readHookedBuildInfo ) -import Distribution.PackageDescription.Configuration - ( flattenPackageDescription ) -import Distribution.Simple.Program - ( defaultProgramConfiguration, addKnownPrograms, builtinPrograms - , restoreProgramConfiguration, reconfigurePrograms ) -import Distribution.Simple.PreProcess (knownSuffixHandlers, PPSuffixHandler) -import Distribution.Simple.Setup -import Distribution.Simple.Command - -import Distribution.Simple.Build ( build ) -import Distribution.Simple.SrcDist ( sdist ) -import Distribution.Simple.Register - ( register, unregister ) - -import Distribution.Simple.Configure - ( getPersistBuildConfig, maybeGetPersistBuildConfig - , writePersistBuildConfig, checkPersistBuildConfigOutdated - , configure, checkForeignDeps ) - -import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) ) -import Distribution.Simple.BuildPaths ( srcPref) -import Distribution.Simple.Test (test) -import Distribution.Simple.Install (install) -import Distribution.Simple.Haddock (haddock, hscolour) -import Distribution.Simple.Utils - (die, notice, info, warn, setupMessage, chattyTry, - defaultPackageDesc, defaultHookedPackageDesc, - rawSystemExitWithEnv, cabalVersion, topHandler ) -import Distribution.System - ( OS(..), buildOS ) -import Distribution.Verbosity -import Language.Haskell.Extension -import Distribution.Version -import Distribution.License -import Distribution.Text - ( display ) - --- Base -import System.Environment(getArgs, getProgName, getEnvironment) -import System.Directory(removeFile, doesFileExist, - doesDirectoryExist, removeDirectoryRecursive) -import System.Exit -import System.IO.Error (isDoesNotExistError) -import Distribution.Compat.Exception (catchIO, throwIOIO) - -import Control.Monad (when) -import Data.List (intersperse, unionBy) - --- | A simple implementation of @main@ for a Cabal setup script. --- It reads the package description file using IO, and performs the --- action specified on the command line. -defaultMain :: IO () -defaultMain = getArgs >>= defaultMainHelper simpleUserHooks - --- | A version of 'defaultMain' that is passed the command line --- arguments, rather than getting them from the environment. -defaultMainArgs :: [String] -> IO () -defaultMainArgs = defaultMainHelper simpleUserHooks - --- | A customizable version of 'defaultMain'. -defaultMainWithHooks :: UserHooks -> IO () -defaultMainWithHooks hooks = getArgs >>= defaultMainHelper hooks - --- | A customizable version of 'defaultMain' that also takes the command --- line arguments. -defaultMainWithHooksArgs :: UserHooks -> [String] -> IO () -defaultMainWithHooksArgs = defaultMainHelper - --- | Like 'defaultMain', but accepts the package description as input --- rather than using IO to read it. -defaultMainNoRead :: GenericPackageDescription -> IO () -defaultMainNoRead pkg_descr = - getArgs >>= - defaultMainHelper simpleUserHooks { readDesc = return (Just pkg_descr) } - -defaultMainHelper :: UserHooks -> Args -> IO () -defaultMainHelper hooks args = topHandler $ - case commandsRun globalCommand commands args of - CommandHelp help -> printHelp help - CommandList opts -> printOptionsList opts - CommandErrors errs -> printErrors errs - CommandReadyToGo (flags, commandParse) -> - case commandParse of - _ | fromFlag (globalVersion flags) -> printVersion - | fromFlag (globalNumericVersion flags) -> printNumericVersion - CommandHelp help -> printHelp help - CommandList opts -> printOptionsList opts - CommandErrors errs -> printErrors errs - CommandReadyToGo action -> action - - where - printHelp help = getProgName >>= putStr . help - printOptionsList = putStr . unlines - printErrors errs = do - putStr (concat (intersperse "\n" errs)) - exitWith (ExitFailure 1) - printNumericVersion = putStrLn $ display cabalVersion - printVersion = putStrLn $ "Cabal library version " - ++ display cabalVersion - - progs = addKnownPrograms (hookedPrograms hooks) defaultProgramConfiguration - commands = - [configureCommand progs `commandAddAction` \fs as -> - configureAction hooks fs as >> return () - ,buildCommand progs `commandAddAction` buildAction hooks - ,installCommand `commandAddAction` installAction hooks - ,copyCommand `commandAddAction` copyAction hooks - ,haddockCommand `commandAddAction` haddockAction hooks - ,cleanCommand `commandAddAction` cleanAction hooks - ,sdistCommand `commandAddAction` sdistAction hooks - ,hscolourCommand `commandAddAction` hscolourAction hooks - ,registerCommand `commandAddAction` registerAction hooks - ,unregisterCommand `commandAddAction` unregisterAction hooks - ,testCommand `commandAddAction` testAction hooks - ] - --- | Combine the preprocessors in the given hooks with the --- preprocessors built into cabal. -allSuffixHandlers :: UserHooks - -> [PPSuffixHandler] -allSuffixHandlers hooks - = overridesPP (hookedPreProcessors hooks) knownSuffixHandlers - where - overridesPP :: [PPSuffixHandler] -> [PPSuffixHandler] -> [PPSuffixHandler] - overridesPP = unionBy (\x y -> fst x == fst y) - -configureAction :: UserHooks -> ConfigFlags -> Args -> IO LocalBuildInfo -configureAction hooks flags args = do - let distPref = fromFlag $ configDistPref flags - pbi <- preConf hooks args flags - - (mb_pd_file, pkg_descr0) <- confPkgDescr - - -- get_pkg_descr (configVerbosity flags') - --let pkg_descr = updatePackageDescription pbi pkg_descr0 - let epkg_descr = (pkg_descr0, pbi) - - --(warns, ers) <- sanityCheckPackage pkg_descr - --errorOut (configVerbosity flags') warns ers - - localbuildinfo0 <- confHook hooks epkg_descr flags - - -- remember the .cabal filename if we know it - -- and all the extra command line args - let localbuildinfo = localbuildinfo0 { - pkgDescrFile = mb_pd_file, - extraConfigArgs = args - } - writePersistBuildConfig distPref localbuildinfo - - let pkg_descr = localPkgDescr localbuildinfo - postConf hooks args flags pkg_descr localbuildinfo - return localbuildinfo - where - verbosity = fromFlag (configVerbosity flags) - confPkgDescr :: IO (Maybe FilePath, GenericPackageDescription) - confPkgDescr = do - mdescr <- readDesc hooks - case mdescr of - Just descr -> return (Nothing, descr) - Nothing -> do - pdfile <- defaultPackageDesc verbosity - descr <- readPackageDescription verbosity pdfile - return (Just pdfile, descr) - -buildAction :: UserHooks -> BuildFlags -> Args -> IO () -buildAction hooks flags args = do - let distPref = fromFlag $ buildDistPref flags - verbosity = fromFlag $ buildVerbosity flags - - lbi <- getBuildConfig hooks verbosity distPref - progs <- reconfigurePrograms verbosity - (buildProgramPaths flags) - (buildProgramArgs flags) - (withPrograms lbi) - - hookedAction preBuild buildHook postBuild - (return lbi { withPrograms = progs }) - hooks flags args - -hscolourAction :: UserHooks -> HscolourFlags -> Args -> IO () -hscolourAction hooks flags args - = do let distPref = fromFlag $ hscolourDistPref flags - verbosity = fromFlag $ hscolourVerbosity flags - hookedAction preHscolour hscolourHook postHscolour - (getBuildConfig hooks verbosity distPref) - hooks flags args - -haddockAction :: UserHooks -> HaddockFlags -> Args -> IO () -haddockAction hooks flags args = do - let distPref = fromFlag $ haddockDistPref flags - verbosity = fromFlag $ haddockVerbosity flags - - lbi <- getBuildConfig hooks verbosity distPref - progs <- reconfigurePrograms verbosity - (haddockProgramPaths flags) - (haddockProgramArgs flags) - (withPrograms lbi) - - hookedAction preHaddock haddockHook postHaddock - (return lbi { withPrograms = progs }) - hooks flags args - -cleanAction :: UserHooks -> CleanFlags -> Args -> IO () -cleanAction hooks flags args = do - pbi <- preClean hooks args flags - - pdfile <- defaultPackageDesc verbosity - ppd <- readPackageDescription verbosity pdfile - let pkg_descr0 = flattenPackageDescription ppd - let pkg_descr = updatePackageDescription pbi pkg_descr0 - - cleanHook hooks pkg_descr () hooks flags - postClean hooks args flags pkg_descr () - where verbosity = fromFlag (cleanVerbosity flags) - -copyAction :: UserHooks -> CopyFlags -> Args -> IO () -copyAction hooks flags args - = do let distPref = fromFlag $ copyDistPref flags - verbosity = fromFlag $ copyVerbosity flags - hookedAction preCopy copyHook postCopy - (getBuildConfig hooks verbosity distPref) - hooks flags args - -installAction :: UserHooks -> InstallFlags -> Args -> IO () -installAction hooks flags args - = do let distPref = fromFlag $ installDistPref flags - verbosity = fromFlag $ installVerbosity flags - hookedAction preInst instHook postInst - (getBuildConfig hooks verbosity distPref) - hooks flags args - -sdistAction :: UserHooks -> SDistFlags -> Args -> IO () -sdistAction hooks flags args = do - let distPref = fromFlag $ sDistDistPref flags - pbi <- preSDist hooks args flags - - mlbi <- maybeGetPersistBuildConfig distPref - pdfile <- defaultPackageDesc verbosity - ppd <- readPackageDescription verbosity pdfile - let pkg_descr0 = flattenPackageDescription ppd - let pkg_descr = updatePackageDescription pbi pkg_descr0 - - sDistHook hooks pkg_descr mlbi hooks flags - postSDist hooks args flags pkg_descr mlbi - where verbosity = fromFlag (sDistVerbosity flags) - -testAction :: UserHooks -> TestFlags -> Args -> IO () -testAction hooks flags args = do - let distPref = fromFlag $ testDistPref flags - verbosity = fromFlag $ testVerbosity flags - localBuildInfo <- getBuildConfig hooks verbosity distPref - let pkg_descr = localPkgDescr localBuildInfo - -- It is safe to do 'runTests' before the new test handler because the - -- default action is a no-op and if the package uses the old test interface - -- the new handler will find no tests. - runTests hooks args False pkg_descr localBuildInfo - --FIXME: this is a hack, passing the args inside the flags - -- it's because the args to not get passed to the main test hook - let flags' = flags { testList = Flag args } - hookedAction preTest testHook postTest - (getBuildConfig hooks verbosity distPref) - hooks flags' args - -registerAction :: UserHooks -> RegisterFlags -> Args -> IO () -registerAction hooks flags args - = do let distPref = fromFlag $ regDistPref flags - verbosity = fromFlag $ regVerbosity flags - hookedAction preReg regHook postReg - (getBuildConfig hooks verbosity distPref) - hooks flags args - -unregisterAction :: UserHooks -> RegisterFlags -> Args -> IO () -unregisterAction hooks flags args - = do let distPref = fromFlag $ regDistPref flags - verbosity = fromFlag $ regVerbosity flags - hookedAction preUnreg unregHook postUnreg - (getBuildConfig hooks verbosity distPref) - hooks flags args - -hookedAction :: (UserHooks -> Args -> flags -> IO HookedBuildInfo) - -> (UserHooks -> PackageDescription -> LocalBuildInfo - -> UserHooks -> flags -> IO ()) - -> (UserHooks -> Args -> flags -> PackageDescription - -> LocalBuildInfo -> IO ()) - -> IO LocalBuildInfo - -> UserHooks -> flags -> Args -> IO () -hookedAction pre_hook cmd_hook post_hook get_build_config hooks flags args = do - pbi <- pre_hook hooks args flags - localbuildinfo <- get_build_config - let pkg_descr0 = localPkgDescr localbuildinfo - --pkg_descr0 <- get_pkg_descr (get_verbose flags) - let pkg_descr = updatePackageDescription pbi pkg_descr0 - -- TODO: should we write the modified package descr back to the - -- localbuildinfo? - cmd_hook hooks pkg_descr localbuildinfo hooks flags - post_hook hooks args flags pkg_descr localbuildinfo - -getBuildConfig :: UserHooks -> Verbosity -> FilePath -> IO LocalBuildInfo -getBuildConfig hooks verbosity distPref = do - lbi_wo_programs <- getPersistBuildConfig distPref - -- Restore info about unconfigured programs, since it is not serialized - let lbi = lbi_wo_programs { - withPrograms = restoreProgramConfiguration - (builtinPrograms ++ hookedPrograms hooks) - (withPrograms lbi_wo_programs) - } - - case pkgDescrFile lbi of - Nothing -> return lbi - Just pkg_descr_file -> do - outdated <- checkPersistBuildConfigOutdated distPref pkg_descr_file - if outdated - then reconfigure pkg_descr_file lbi - else return lbi - - where - reconfigure :: FilePath -> LocalBuildInfo -> IO LocalBuildInfo - reconfigure pkg_descr_file lbi = do - notice verbosity $ pkg_descr_file ++ " has been changed. " - ++ "Re-configuring with most recently used options. " - ++ "If this fails, please run configure manually.\n" - let cFlags = configFlags lbi - let cFlags' = cFlags { - -- Since the list of unconfigured programs is not serialized, - -- restore it to the same value as normally used at the beginning - -- of a conigure run: - configPrograms = restoreProgramConfiguration - (builtinPrograms ++ hookedPrograms hooks) - (configPrograms cFlags), - - -- Use the current, not saved verbosity level: - configVerbosity = Flag verbosity - } - configureAction hooks cFlags' (extraConfigArgs lbi) - - --- -------------------------------------------------------------------------- --- Cleaning - -clean :: PackageDescription -> CleanFlags -> IO () -clean pkg_descr flags = do - let distPref = fromFlag $ cleanDistPref flags - notice verbosity "cleaning..." - - maybeConfig <- if fromFlag (cleanSaveConf flags) - then maybeGetPersistBuildConfig distPref - else return Nothing - - -- remove the whole dist/ directory rather than tracking exactly what files - -- we created in there. - chattyTry "removing dist/" $ do - exists <- doesDirectoryExist distPref - when exists (removeDirectoryRecursive distPref) - - -- Any extra files the user wants to remove - mapM_ removeFileOrDirectory (extraTmpFiles pkg_descr) - - -- If the user wanted to save the config, write it back - maybe (return ()) (writePersistBuildConfig distPref) maybeConfig - - where - removeFileOrDirectory :: FilePath -> IO () - removeFileOrDirectory fname = do - isDir <- doesDirectoryExist fname - isFile <- doesFileExist fname - if isDir then removeDirectoryRecursive fname - else if isFile then removeFile fname - else return () - verbosity = fromFlag (cleanVerbosity flags) - --- -------------------------------------------------------------------------- --- Default hooks - --- | Hooks that correspond to a plain instantiation of the --- \"simple\" build system -simpleUserHooks :: UserHooks -simpleUserHooks = - emptyUserHooks { - confHook = configure, - postConf = finalChecks, - buildHook = defaultBuildHook, - copyHook = \desc lbi _ f -> install desc lbi f, -- has correct 'copy' behavior with params - testHook = defaultTestHook, - instHook = defaultInstallHook, - sDistHook = \p l h f -> sdist p l f srcPref (allSuffixHandlers h), - cleanHook = \p _ _ f -> clean p f, - hscolourHook = \p l h f -> hscolour p l (allSuffixHandlers h) f, - haddockHook = \p l h f -> haddock p l (allSuffixHandlers h) f, - regHook = defaultRegHook, - unregHook = \p l _ f -> unregister p l f - } - where - finalChecks _args flags pkg_descr lbi = - checkForeignDeps pkg_descr lbi (lessVerbose verbosity) - where - verbosity = fromFlag (configVerbosity flags) - --- | Basic autoconf 'UserHooks': --- --- * 'postConf' runs @.\/configure@, if present. --- --- * the pre-hooks 'preBuild', 'preClean', 'preCopy', 'preInst', --- 'preReg' and 'preUnreg' read additional build information from --- /package/@.buildinfo@, if present. --- --- Thus @configure@ can use local system information to generate --- /package/@.buildinfo@ and possibly other files. - -{-# DEPRECATED defaultUserHooks - "Use simpleUserHooks or autoconfUserHooks, unless you need Cabal-1.2\n compatibility in which case you must stick with defaultUserHooks" #-} -defaultUserHooks :: UserHooks -defaultUserHooks = autoconfUserHooks { - confHook = \pkg flags -> do - let verbosity = fromFlag (configVerbosity flags) - warn verbosity $ - "defaultUserHooks in Setup script is deprecated." - confHook autoconfUserHooks pkg flags, - postConf = oldCompatPostConf - } - -- This is the annoying old version that only runs configure if it exists. - -- It's here for compatibility with existing Setup.hs scripts. See: - -- http://hackage.haskell.org/trac/hackage/ticket/165 - where oldCompatPostConf args flags pkg_descr lbi - = do let verbosity = fromFlag (configVerbosity flags) - noExtraFlags args - confExists <- doesFileExist "configure" - when confExists $ - runConfigureScript verbosity - backwardsCompatHack flags lbi - - pbi <- getHookedBuildInfo verbosity - let pkg_descr' = updatePackageDescription pbi pkg_descr - postConf simpleUserHooks args flags pkg_descr' lbi - - backwardsCompatHack = True - -autoconfUserHooks :: UserHooks -autoconfUserHooks - = simpleUserHooks - { - postConf = defaultPostConf, - preBuild = readHook buildVerbosity, - preClean = readHook cleanVerbosity, - preCopy = readHook copyVerbosity, - preInst = readHook installVerbosity, - preHscolour = readHook hscolourVerbosity, - preHaddock = readHook haddockVerbosity, - preReg = readHook regVerbosity, - preUnreg = readHook regVerbosity - } - where defaultPostConf :: Args -> ConfigFlags -> PackageDescription -> LocalBuildInfo -> IO () - defaultPostConf args flags pkg_descr lbi - = do let verbosity = fromFlag (configVerbosity flags) - noExtraFlags args - confExists <- doesFileExist "configure" - if confExists - then runConfigureScript verbosity - backwardsCompatHack flags lbi - else die "configure script not found." - - pbi <- getHookedBuildInfo verbosity - let pkg_descr' = updatePackageDescription pbi pkg_descr - postConf simpleUserHooks args flags pkg_descr' lbi - - backwardsCompatHack = False - - readHook :: (a -> Flag Verbosity) -> Args -> a -> IO HookedBuildInfo - readHook get_verbosity a flags = do - noExtraFlags a - getHookedBuildInfo verbosity - where - verbosity = fromFlag (get_verbosity flags) - -runConfigureScript :: Verbosity -> Bool -> ConfigFlags -> LocalBuildInfo - -> IO () -runConfigureScript verbosity backwardsCompatHack flags lbi = do - - env <- getEnvironment - let programConfig = withPrograms lbi - (ccProg, ccFlags) <- configureCCompiler verbosity programConfig - -- The C compiler's compilation and linker flags (e.g. - -- "C compiler flags" and "Gcc Linker flags" from GHC) have already - -- been merged into ccFlags, so we set both CFLAGS and LDFLAGS - -- to ccFlags - -- We don't try and tell configure which ld to use, as we don't have - -- a way to pass its flags too - let env' = appendToEnvironment ("CFLAGS", unwords ccFlags) - env - args' = args ++ ["--with-gcc=" ++ ccProg] - handleNoWindowsSH $ - rawSystemExitWithEnv verbosity "sh" args' env' - - where - args = "configure" : configureArgs backwardsCompatHack flags - - appendToEnvironment (key, val) [] = [(key, val)] - appendToEnvironment (key, val) (kv@(k, v) : rest) - | key == k = (key, v ++ " " ++ val) : rest - | otherwise = kv : appendToEnvironment (key, val) rest - - handleNoWindowsSH action - | buildOS /= Windows - = action - - | otherwise - = action - `catchIO` \ioe -> if isDoesNotExistError ioe - then die notFoundMsg - else throwIOIO ioe - - notFoundMsg = "The package has a './configure' script. This requires a " - ++ "Unix compatibility toolchain such as MinGW+MSYS or Cygwin." - -getHookedBuildInfo :: Verbosity -> IO HookedBuildInfo -getHookedBuildInfo verbosity = do - maybe_infoFile <- defaultHookedPackageDesc - case maybe_infoFile of - Nothing -> return emptyHookedBuildInfo - Just infoFile -> do - info verbosity $ "Reading parameters from " ++ infoFile - readHookedBuildInfo verbosity infoFile - -defaultTestHook :: PackageDescription -> LocalBuildInfo - -> UserHooks -> TestFlags -> IO () -defaultTestHook pkg_descr localbuildinfo _ flags = - test pkg_descr localbuildinfo flags - -defaultInstallHook :: PackageDescription -> LocalBuildInfo - -> UserHooks -> InstallFlags -> IO () -defaultInstallHook pkg_descr localbuildinfo _ flags = do - let copyFlags = defaultCopyFlags { - copyDistPref = installDistPref flags, - copyDest = toFlag NoCopyDest, - copyVerbosity = installVerbosity flags - } - install pkg_descr localbuildinfo copyFlags - let registerFlags = defaultRegisterFlags { - regDistPref = installDistPref flags, - regInPlace = installInPlace flags, - regPackageDB = installPackageDB flags, - regVerbosity = installVerbosity flags - } - when (hasLibs pkg_descr) $ register pkg_descr localbuildinfo registerFlags - -defaultBuildHook :: PackageDescription -> LocalBuildInfo - -> UserHooks -> BuildFlags -> IO () -defaultBuildHook pkg_descr localbuildinfo hooks flags = - build pkg_descr localbuildinfo flags (allSuffixHandlers hooks) - -defaultRegHook :: PackageDescription -> LocalBuildInfo - -> UserHooks -> RegisterFlags -> IO () -defaultRegHook pkg_descr localbuildinfo _ flags = - if hasLibs pkg_descr - then register pkg_descr localbuildinfo flags - else setupMessage verbosity - "Package contains no library to register:" (packageId pkg_descr) - where verbosity = fromFlag (regVerbosity flags) diff -Nru ghc-7.0.3/libraries/Cabal/Distribution/System.hs ghc-7.2.1/libraries/Cabal/Distribution/System.hs --- ghc-7.0.3/libraries/Cabal/Distribution/System.hs 2011-03-26 18:10:12.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/Distribution/System.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,172 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.System --- Copyright : Duncan Coutts 2007-2008 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Cabal often needs to do slightly different things on specific platforms. You --- probably know about the 'System.Info.os' however using that is very --- inconvenient because it is a string and different Haskell implementations --- do not agree on using the same strings for the same platforms! (In --- particular see the controversy over \"windows\" vs \"ming32\"). So to make it --- more consistent and easy to use we have an 'OS' enumeration. --- -module Distribution.System ( - -- * Operating System - OS(..), - buildOS, - - -- * Machine Architecture - Arch(..), - buildArch, - - -- * Platform is a pair of arch and OS - Platform(..), - buildPlatform, - ) where - -import qualified System.Info (os, arch) -import qualified Data.Char as Char (toLower, isAlphaNum) - -import Distribution.Text (Text(..), display) -import qualified Distribution.Compat.ReadP as Parse -import qualified Text.PrettyPrint as Disp -import Text.PrettyPrint ((<>)) - --- | How strict to be when classifying strings into the 'OS' and 'Arch' enums. --- --- The reason we have multiple ways to do the classification is because there --- are two situations where we need to do it. --- --- For parsing os and arch names in .cabal files we really want everyone to be --- referring to the same or or arch by the same name. Variety is not a virtue --- in this case. We don't mind about case though. --- --- For the System.Info.os\/arch different Haskell implementations use different --- names for the same or\/arch. Also they tend to distinguish versions of an --- os\/arch which we just don't care about. --- --- The 'Compat' classification allows us to recognise aliases that are already --- in common use but it allows us to distinguish them from the canonical name --- which enables us to warn about such deprecated aliases. --- -data ClassificationStrictness = Permissive | Compat | Strict - --- ------------------------------------------------------------ --- * Operating System --- ------------------------------------------------------------ - -data OS = Linux | Windows | OSX - | FreeBSD | OpenBSD | NetBSD - | Solaris | AIX | HPUX | IRIX - | OtherOS String - deriving (Eq, Ord, Show, Read) - -knownOSs :: [OS] -knownOSs = [Linux, Windows, OSX - ,FreeBSD, OpenBSD, NetBSD - ,Solaris, AIX, HPUX, IRIX] - -osAliases :: ClassificationStrictness -> OS -> [String] -osAliases Permissive Windows = ["mingw32", "cygwin32"] -osAliases Compat Windows = ["mingw32", "win32"] -osAliases _ OSX = ["darwin"] -osAliases Permissive FreeBSD = ["kfreebsdgnu"] -osAliases Permissive Solaris = ["solaris2"] -osAliases _ _ = [] - -instance Text OS where - disp (OtherOS name) = Disp.text name - disp other = Disp.text (lowercase (show other)) - - parse = fmap (classifyOS Compat) ident - -classifyOS :: ClassificationStrictness -> String -> OS -classifyOS strictness s = - case lookup (lowercase s) osMap of - Just os -> os - Nothing -> OtherOS s - where - osMap = [ (name, os) - | os <- knownOSs - , name <- display os : osAliases strictness os ] - -buildOS :: OS -buildOS = classifyOS Permissive System.Info.os - --- ------------------------------------------------------------ --- * Machine Architecture --- ------------------------------------------------------------ - -data Arch = I386 | X86_64 | PPC | PPC64 | Sparc - | Arm | Mips | SH - | IA64 | S390 - | Alpha | Hppa | Rs6000 - | M68k | Vax - | OtherArch String - deriving (Eq, Ord, Show, Read) - -knownArches :: [Arch] -knownArches = [I386, X86_64, PPC, PPC64, Sparc - ,Arm, Mips, SH - ,IA64, S390 - ,Alpha, Hppa, Rs6000 - ,M68k, Vax] - -archAliases :: ClassificationStrictness -> Arch -> [String] -archAliases Strict _ = [] -archAliases Compat _ = [] -archAliases _ PPC = ["powerpc"] -archAliases _ PPC64 = ["powerpc64"] -archAliases _ Sparc = ["sparc64", "sun4"] -archAliases _ Mips = ["mipsel", "mipseb"] -archAliases _ Arm = ["armeb", "armel"] -archAliases _ _ = [] - -instance Text Arch where - disp (OtherArch name) = Disp.text name - disp other = Disp.text (lowercase (show other)) - - parse = fmap (classifyArch Strict) ident - -classifyArch :: ClassificationStrictness -> String -> Arch -classifyArch strictness s = - case lookup (lowercase s) archMap of - Just arch -> arch - Nothing -> OtherArch s - where - archMap = [ (name, arch) - | arch <- knownArches - , name <- display arch : archAliases strictness arch ] - -buildArch :: Arch -buildArch = classifyArch Permissive System.Info.arch - --- ------------------------------------------------------------ --- * Platform --- ------------------------------------------------------------ - -data Platform = Platform Arch OS - deriving (Eq, Ord, Show, Read) - -instance Text Platform where - disp (Platform arch os) = disp arch <> Disp.char '-' <> disp os - parse = do - arch <- parse - _ <- Parse.char '-' - os <- parse - return (Platform arch os) - -buildPlatform :: Platform -buildPlatform = Platform buildArch buildOS - --- Utils: - -ident :: Parse.ReadP r String -ident = Parse.munch1 (\c -> Char.isAlphaNum c || c == '_' || c == '-') - --TODO: probably should disallow starting with a number - -lowercase :: String -> String -lowercase = map Char.toLower diff -Nru ghc-7.0.3/libraries/Cabal/Distribution/TestSuite.hs ghc-7.2.1/libraries/Cabal/Distribution/TestSuite.hs --- ghc-7.0.3/libraries/Cabal/Distribution/TestSuite.hs 2011-03-26 18:10:12.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/Distribution/TestSuite.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,310 +0,0 @@ -{-# LANGUAGE CPP, ExistentialQuantification #-} ------------------------------------------------------------------------------ --- | --- Module : Distribution.TestSuite --- Copyright : Thomas Tuegel 2010 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This module defines the detailed test suite interface which makes it --- possible to expose individual tests to Cabal or other test agents. - -{- All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - -#if !(defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 610)) -#define NEW_EXCEPTION -#endif - -module Distribution.TestSuite - ( -- * Example - -- $example - -- * Options - Options(..) - , lookupOption - , TestOptions(..) - -- * Tests - , Test - , pure, impure - , Result(..) - , ImpureTestable(..) - , PureTestable(..) - ) where - -#ifdef NEW_EXCEPTION -import Control.Exception ( evaluate, catch, throw, SomeException, fromException ) -#else -import Control.Exception ( evaluate, catch, throw, Exception(IOException) ) -#endif - ---TODO: it is totally unreasonable that we have to import things from GHC.* here. --- see ghc ticket #3517 -#ifdef __GLASGOW_HASKELL__ -#if __GLASGOW_HASKELL__ >= 612 -import GHC.IO.Exception ( IOErrorType(Interrupted) ) -#else -import GHC.IOBase ( IOErrorType(Interrupted) ) -#endif -import System.IO.Error ( ioeGetErrorType ) -#endif - -import Data.List ( unionBy ) -import Data.Monoid ( Monoid(..) ) -import Data.Typeable ( TypeRep ) -import Prelude hiding ( catch ) - --- | 'Options' are provided to pass options to test runners, making tests --- reproducable. Each option is a @('String', 'String')@ of the form --- @(Name, Value)@. Use 'mappend' to combine sets of 'Options'; if the same --- option is given different values, the value from the left argument of --- 'mappend' will be used. -newtype Options = Options [(String, String)] - deriving (Read, Show, Eq) - -instance Monoid Options where - mempty = Options [] - mappend (Options a) (Options b) = Options $ unionBy (equating fst) a b - where - equating p x y = p x == p y - - -class TestOptions t where - -- | The name of the test. - name :: t -> String - - -- | A list of the options a test recognizes. The name and 'TypeRep' are - -- provided so that test agents can ensure that user-specified options are - -- correctly typed. - options :: t -> [(String, TypeRep)] - - -- | The default options for a test. Test frameworks should provide a new - -- random seed, if appropriate. - defaultOptions :: t -> IO Options - - -- | Try to parse the provided options. Return the names of unparsable - -- options. This allows test agents to detect bad user-specified options. - check :: t -> Options -> [String] - --- | Read an option from the specified set of 'Options'. It is an error to --- lookup an option that has not been specified. For this reason, test agents --- should 'mappend' any 'Options' against the 'defaultOptions' for a test, so --- the default value specified by the test framework will be used for any --- otherwise-unspecified options. -lookupOption :: Read r => String -> Options -> r -lookupOption n (Options opts) = - case lookup n opts of - Just str -> read str - Nothing -> error $ "test option not specified: " ++ n - -data Result - = Pass -- ^ indicates a successful test - | Fail String -- ^ indicates a test completed unsuccessfully; - -- the 'String' value should be a human-readable message - -- indicating how the test failed. - | Error String -- ^ indicates a test that could not be - -- completed due to some error; the test framework - -- should provide a message indicating the - -- nature of the error. - deriving (Read, Show, Eq) - --- | Class abstracting impure tests. Test frameworks should implement this --- class only as a last resort for test types which actually require 'IO'. --- In particular, tests that simply require pseudo-random number generation can --- be implemented as pure tests. -class TestOptions t => ImpureTestable t where - -- | Runs an impure test and returns the result. Test frameworks - -- implementing this class are responsible for converting any exceptions to - -- the correct 'Result' value. - runM :: t -> Options -> IO Result - --- | Class abstracting pure tests. Test frameworks should prefer to implement --- this class over 'ImpureTestable'. A default instance exists so that any pure --- test can be lifted into an impure test; when lifted, any exceptions are --- automatically caught. Test agents that lift pure tests themselves must --- handle exceptions. -class TestOptions t => PureTestable t where - -- | The result of a pure test. - run :: t -> Options -> Result - --- | 'Test' is a wrapper for pure and impure tests so that lists containing --- arbitrary test types can be constructed. -data Test - = forall p. PureTestable p => PureTest p - | forall i. ImpureTestable i => ImpureTest i - --- | A convenient function for wrapping pure tests into 'Test's. -pure :: PureTestable p => p -> Test -pure = PureTest - --- | A convenient function for wrapping impure tests into 'Test's. -impure :: ImpureTestable i => i -> Test -impure = ImpureTest - -instance TestOptions Test where - name (PureTest p) = name p - name (ImpureTest i) = name i - - options (PureTest p) = options p - options (ImpureTest i) = options i - - defaultOptions (PureTest p) = defaultOptions p - defaultOptions (ImpureTest p) = defaultOptions p - - check (PureTest p) = check p - check (ImpureTest p) = check p - -instance ImpureTestable Test where - runM (PureTest p) o = catch (evaluate $ run p o) handler - - -- Because we have to handle old and new style exceptions, GHC and non-GHC - -- this code is totally horrible and really fragile. Has to be tested with - -- lots of ghc versions to check it is right, and with non-ghc too. :-( -#ifdef NEW_EXCEPTION - where - handler :: SomeException -> IO Result - handler e = case fromException e of - Just ioe | isInterruptedError ioe -> throw e - _ -> return (Error (show e)) -#else - where - handler :: Exception -> IO Result - handler e = case e of - IOException ioe | isInterruptedError ioe -> throw e - _ -> return (Error (show e)) -#endif - - -- We do not want to catch control-C here, but only GHC - -- defines the Interrupted exception type! (ticket #3517) - isInterruptedError ioe = -#ifdef __GLASGOW_HASKELL__ - ioeGetErrorType ioe == Interrupted -#else - False -#endif - - runM (ImpureTest i) o = runM i o - --- $example --- The following terms are used carefully throughout this file: --- --- [test interface] The interface provided by this module. --- --- [test agent] A program used by package users to coordinates the running --- of tests and the reporting of their results. --- --- [test framework] A package used by software authors to specify tests, --- such as QuickCheck or HUnit. --- --- Test frameworks are obligated to supply, at least, instances of the --- 'TestOptions' and 'ImpureTestable' classes. It is preferred that test --- frameworks implement 'PureTestable' whenever possible, so that test agents --- have an assurance that tests can be safely run in parallel. --- --- Test agents that allow the user to specify options should avoid setting --- options not listed by the 'options' method. Test agents should use 'check' --- before running tests with non-default options. Test frameworks must --- implement a 'check' function that attempts to parse the given options safely. --- --- The packages cabal-test-hunit, cabal-test-quickcheck1, and --- cabal-test-quickcheck2 provide simple interfaces to these popular test --- frameworks. An example from cabal-test-quickcheck2 is shown below. A --- better implementation would eliminate the console output from QuickCheck\'s --- built-in runner and provide an instance of 'PureTestable' instead of --- 'ImpureTestable'. --- --- > import Control.Monad (liftM) --- > import Data.Maybe (catMaybes, fromJust, maybe) --- > import Data.Typeable (Typeable(..)) --- > import qualified Distribution.TestSuite as Cabal --- > import System.Random (newStdGen, next, StdGen) --- > import qualified Test.QuickCheck as QC --- > --- > data QCTest = forall prop. QC.Testable prop => QCTest String prop --- > --- > test :: QC.Testable prop => String -> prop -> Cabal.Test --- > test n p = Cabal.impure $ QCTest n p --- > --- > instance Cabal.TestOptions QCTest where --- > name (QCTest n _) = n --- > --- > options _ = --- > [ ("std-gen", typeOf (undefined :: String)) --- > , ("max-success", typeOf (undefined :: Int)) --- > , ("max-discard", typeOf (undefined :: Int)) --- > , ("size", typeOf (undefined :: Int)) --- > ] --- > --- > defaultOptions _ = do --- > rng <- newStdGen --- > return $ Cabal.Options $ --- > [ ("std-gen", show rng) --- > , ("max-success", show $ QC.maxSuccess QC.stdArgs) --- > , ("max-discard", show $ QC.maxDiscard QC.stdArgs) --- > , ("size", show $ QC.maxSize QC.stdArgs) --- > ] --- > --- > check t (Cabal.Options opts) = catMaybes --- > [ maybeNothing "max-success" ([] :: [(Int, String)]) --- > , maybeNothing "max-discard" ([] :: [(Int, String)]) --- > , maybeNothing "size" ([] :: [(Int, String)]) --- > ] --- > -- There is no need to check the parsability of "std-gen" --- > -- because the Read instance for StdGen always succeeds. --- > where --- > maybeNothing n x = --- > maybe Nothing (\str -> --- > if reads str == x then Just n else Nothing) --- > $ lookup n opts --- > --- > instance Cabal.ImpureTestable QCTest where --- > runM (QCTest _ prop) o = --- > catch go (return . Cabal.Error . show) --- > where --- > go = do --- > result <- QC.quickCheckWithResult args prop --- > return $ case result of --- > QC.Success {} -> Cabal.Pass --- > QC.GaveUp {}-> --- > Cabal.Fail $ "gave up after " --- > ++ show (QC.numTests result) --- > ++ " tests" --- > QC.Failure {} -> Cabal.Fail $ QC.reason result --- > QC.NoExpectedFailure {} -> --- > Cabal.Fail "passed (expected failure)" --- > args = QC.Args --- > { QC.replay = Just --- > ( Cabal.lookupOption "std-gen" o --- > , Cabal.lookupOption "size" o --- > ) --- > , QC.maxSuccess = Cabal.lookupOption "max-success" o --- > , QC.maxDiscard = Cabal.lookupOption "max-discard" o --- > , QC.maxSize = Cabal.lookupOption "size" o --- > } diff -Nru ghc-7.0.3/libraries/Cabal/Distribution/Text.hs ghc-7.2.1/libraries/Cabal/Distribution/Text.hs --- ghc-7.0.3/libraries/Cabal/Distribution/Text.hs 2011-03-26 18:10:12.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/Distribution/Text.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,68 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Text --- Copyright : Duncan Coutts 2007 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- This defines a 'Text' class which is a bit like the 'Read' and 'Show' --- classes. The difference is that is uses a modern pretty printer and parser --- system and the format is not expected to be Haskell concrete syntax but --- rather the external human readable representation used by Cabal. --- -module Distribution.Text ( - Text(..), - display, - simpleParse, - ) where - -import qualified Distribution.Compat.ReadP as Parse -import qualified Text.PrettyPrint as Disp - -import Data.Version (Version(Version)) -import qualified Data.Char as Char (isDigit, isAlphaNum, isSpace) - -class Text a where - disp :: a -> Disp.Doc - parse :: Parse.ReadP r a - -display :: Text a => a -> String -display = Disp.renderStyle style . disp - where style = Disp.Style { - Disp.mode = Disp.PageMode, - Disp.lineLength = 79, - Disp.ribbonsPerLine = 1.0 - } - -simpleParse :: Text a => String -> Maybe a -simpleParse str = case [ p | (p, s) <- Parse.readP_to_S parse str - , all Char.isSpace s ] of - [] -> Nothing - (p:_) -> Just p - --- ----------------------------------------------------------------------------- --- Instances for types from the base package - -instance Text Bool where - disp = Disp.text . show - parse = Parse.choice [ (Parse.string "True" Parse.+++ - Parse.string "true") >> return True - , (Parse.string "False" Parse.+++ - Parse.string "false") >> return False ] - -instance Text Version where - disp (Version branch _tags) -- Do not display the tags - = Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int branch)) - - parse = do - branch <- Parse.sepBy1 digits (Parse.char '.') - tags <- Parse.many (Parse.char '-' >> Parse.munch1 Char.isAlphaNum) - return (Version branch tags) - where - digits = do - first <- Parse.satisfy Char.isDigit - if first == '0' - then return 0 - else do rest <- Parse.munch Char.isDigit - return (read (first : rest)) diff -Nru ghc-7.0.3/libraries/Cabal/Distribution/Verbosity.hs ghc-7.2.1/libraries/Cabal/Distribution/Verbosity.hs --- ghc-7.0.3/libraries/Cabal/Distribution/Verbosity.hs 2011-03-26 18:10:12.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/Distribution/Verbosity.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,113 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Verbosity --- Copyright : Ian Lynagh 2007 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- A simple 'Verbosity' type with associated utilities. There are 4 standard --- verbosity levels from 'silent', 'normal', 'verbose' up to 'deafening'. This --- is used for deciding what logging messages to print. - --- Verbosity for Cabal functions - -{- Copyright (c) 2007, Ian Lynagh -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - -module Distribution.Verbosity ( - -- * Verbosity - Verbosity, - silent, normal, verbose, deafening, - moreVerbose, lessVerbose, - intToVerbosity, flagToVerbosity, - showForCabal, showForGHC - ) where - -import Data.List (elemIndex) -import Distribution.ReadE - -data Verbosity = Silent | Normal | Verbose | Deafening - deriving (Show, Read, Eq, Ord, Enum, Bounded) - --- We shouldn't print /anything/ unless an error occurs in silent mode -silent :: Verbosity -silent = Silent - --- Print stuff we want to see by default -normal :: Verbosity -normal = Normal - --- Be more verbose about what's going on -verbose :: Verbosity -verbose = Verbose - --- Not only are we verbose ourselves (perhaps even noisier than when --- being "verbose"), but we tell everything we run to be verbose too -deafening :: Verbosity -deafening = Deafening - -moreVerbose :: Verbosity -> Verbosity -moreVerbose Silent = Silent --silent should stay silent -moreVerbose Normal = Verbose -moreVerbose Verbose = Deafening -moreVerbose Deafening = Deafening - -lessVerbose :: Verbosity -> Verbosity -lessVerbose Deafening = Deafening -lessVerbose Verbose = Normal -lessVerbose Normal = Silent -lessVerbose Silent = Silent - -intToVerbosity :: Int -> Maybe Verbosity -intToVerbosity 0 = Just Silent -intToVerbosity 1 = Just Normal -intToVerbosity 2 = Just Verbose -intToVerbosity 3 = Just Deafening -intToVerbosity _ = Nothing - -flagToVerbosity :: ReadE Verbosity -flagToVerbosity = ReadE $ \s -> - case reads s of - [(i, "")] -> - case intToVerbosity i of - Just v -> Right v - Nothing -> Left ("Bad verbosity: " ++ show i ++ - ". Valid values are 0..3") - _ -> Left ("Can't parse verbosity " ++ s) - -showForCabal, showForGHC :: Verbosity -> String - -showForCabal v = maybe (error "unknown verbosity") show $ - elemIndex v [silent,normal,verbose,deafening] -showForGHC v = maybe (error "unknown verbosity") show $ - elemIndex v [silent,normal,__,verbose,deafening] - where __ = silent -- this will be always ignored by elemIndex diff -Nru ghc-7.0.3/libraries/Cabal/Distribution/Version.hs ghc-7.2.1/libraries/Cabal/Distribution/Version.hs --- ghc-7.0.3/libraries/Cabal/Distribution/Version.hs 2011-03-26 18:10:12.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/Distribution/Version.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,742 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Distribution.Version --- Copyright : Isaac Jones, Simon Marlow 2003-2004 --- Duncan Coutts 2008 --- --- Maintainer : cabal-devel@haskell.org --- Portability : portable --- --- Exports the 'Version' type along with a parser and pretty printer. A version --- is something like @\"1.3.3\"@. It also defines the 'VersionRange' data --- types. Version ranges are like @\">= 1.2 && < 2\"@. - -{- Copyright (c) 2003-2004, Isaac Jones -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - -module Distribution.Version ( - -- * Package versions - Version(..), - - -- * Version ranges - VersionRange(..), - - -- ** Constructing - anyVersion, noVersion, - thisVersion, notThisVersion, - laterVersion, earlierVersion, - orLaterVersion, orEarlierVersion, - unionVersionRanges, intersectVersionRanges, - withinVersion, - betweenVersionsInclusive, - - -- ** Inspection - withinRange, - isAnyVersion, - isNoVersion, - isSpecificVersion, - simplifyVersionRange, - foldVersionRange, - foldVersionRange', - - -- * Version intervals view - asVersionIntervals, - VersionInterval, - LowerBound(..), - UpperBound(..), - Bound(..), - - -- ** 'VersionIntervals' abstract type - -- | The 'VersionIntervals' type and the accompanying functions are exposed - -- primarily for completeness and testing purposes. In practice - -- 'asVersionIntervals' is the main function to use to - -- view a 'VersionRange' as a bunch of 'VersionInterval's. - -- - VersionIntervals, - toVersionIntervals, - fromVersionIntervals, - withinIntervals, - versionIntervals, - mkVersionIntervals, - unionVersionIntervals, - intersectVersionIntervals, - - ) where - -import Data.Version ( Version(..) ) - -import Distribution.Text ( Text(..) ) -import qualified Distribution.Compat.ReadP as Parse -import Distribution.Compat.ReadP ((+++)) -import qualified Text.PrettyPrint as Disp -import Text.PrettyPrint ((<>), (<+>)) -import qualified Data.Char as Char (isDigit) -import Control.Exception (assert) - --- ----------------------------------------------------------------------------- --- Version ranges - --- Todo: maybe move this to Distribution.Package.Version? --- (package-specific versioning scheme). - -data VersionRange - = AnyVersion - | ThisVersion Version -- = version - | LaterVersion Version -- > version (NB. not >=) - | EarlierVersion Version -- < version - | WildcardVersion Version -- == ver.* (same as >= ver && < ver+1) - | UnionVersionRanges VersionRange VersionRange - | IntersectVersionRanges VersionRange VersionRange - | VersionRangeParens VersionRange -- just '(exp)' parentheses syntax - deriving (Show,Read,Eq) - -{-# DEPRECATED AnyVersion "Use 'anyVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} -{-# DEPRECATED ThisVersion "use 'thisVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} -{-# DEPRECATED LaterVersion "use 'laterVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} -{-# DEPRECATED EarlierVersion "use 'earlierVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} -{-# DEPRECATED WildcardVersion "use 'anyVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} -{-# DEPRECATED UnionVersionRanges "use 'unionVersionRanges', 'foldVersionRange' or 'asVersionIntervals'" #-} -{-# DEPRECATED IntersectVersionRanges "use 'intersectVersionRanges', 'foldVersionRange' or 'asVersionIntervals'" #-} - --- | The version range @-any@. That is, a version range containing all --- versions. --- --- > withinRange v anyVersion = True --- -anyVersion :: VersionRange -anyVersion = AnyVersion - --- | The empty version range, that is a version range containing no versions. --- --- This can be constructed using any unsatisfiable version range expression, --- for example @> 1 && < 1@. --- --- > withinRange v anyVersion = False --- -noVersion :: VersionRange -noVersion = IntersectVersionRanges (LaterVersion v) (EarlierVersion v) - where v = Version [1] [] - --- | The version range @== v@ --- --- > withinRange v' (thisVersion v) = v' == v --- -thisVersion :: Version -> VersionRange -thisVersion = ThisVersion - --- | The version range @< v || > v@ --- --- > withinRange v' (notThisVersion v) = v' /= v --- -notThisVersion :: Version -> VersionRange -notThisVersion v = UnionVersionRanges (EarlierVersion v) (LaterVersion v) - --- | The version range @> v@ --- --- > withinRange v' (laterVersion v) = v' > v --- -laterVersion :: Version -> VersionRange -laterVersion = LaterVersion - --- | The version range @>= v@ --- --- > withinRange v' (orLaterVersion v) = v' >= v --- -orLaterVersion :: Version -> VersionRange -orLaterVersion v = UnionVersionRanges (ThisVersion v) (LaterVersion v) - --- | The version range @< v@ --- --- > withinRange v' (earlierVersion v) = v' < v --- -earlierVersion :: Version -> VersionRange -earlierVersion = EarlierVersion - --- | The version range @<= v@ --- --- > withinRange v' (orEarlierVersion v) = v' <= v --- -orEarlierVersion :: Version -> VersionRange -orEarlierVersion v = UnionVersionRanges (ThisVersion v) (EarlierVersion v) - --- | The version range @vr1 || vr2@ --- --- > withinRange v' (unionVersionRanges vr1 vr2) --- > = withinRange v' vr1 || withinRange v' vr2 --- -unionVersionRanges :: VersionRange -> VersionRange -> VersionRange -unionVersionRanges = UnionVersionRanges - --- | The version range @vr1 && vr2@ --- --- > withinRange v' (intersectVersionRanges vr1 vr2) --- > = withinRange v' vr1 && withinRange v' vr2 --- -intersectVersionRanges :: VersionRange -> VersionRange -> VersionRange -intersectVersionRanges = IntersectVersionRanges - --- | The version range @== v.*@. --- --- For example, for version @1.2@, the version range @== 1.2.*@ is the same as --- @>= 1.2 && < 1.3@ --- --- > withinRange v' (laterVersion v) = v' >= v && v' < upper v --- > where --- > upper (Version lower t) = Version (init lower ++ [last lower + 1]) t --- -withinVersion :: Version -> VersionRange -withinVersion = WildcardVersion - --- | The version range @>= v1 && <= v2@. --- --- In practice this is not very useful because we normally use inclusive lower --- bounds and exclusive upper bounds. --- --- > withinRange v' (laterVersion v) = v' > v --- -betweenVersionsInclusive :: Version -> Version -> VersionRange -betweenVersionsInclusive v1 v2 = - IntersectVersionRanges (orLaterVersion v1) (orEarlierVersion v2) - -{-# DEPRECATED betweenVersionsInclusive - "In practice this is not very useful because we normally use inclusive lower bounds and exclusive upper bounds" - #-} - --- | Fold over the basic syntactic structure of a 'VersionRange'. --- --- This provides a syntacic view of the expression defining the version range. --- The syntactic sugar @\">= v\"@, @\"<= v\"@ and @\"== v.*\"@ is presented --- in terms of the other basic syntax. --- --- For a semantic view use 'asVersionIntervals'. --- -foldVersionRange :: a -- ^ @\"-any\"@ version - -> (Version -> a) -- ^ @\"== v\"@ - -> (Version -> a) -- ^ @\"> v\"@ - -> (Version -> a) -- ^ @\"< v\"@ - -> (a -> a -> a) -- ^ @\"_ || _\"@ union - -> (a -> a -> a) -- ^ @\"_ && _\"@ intersection - -> VersionRange -> a -foldVersionRange anyv this later earlier union intersect = fold - where - fold AnyVersion = anyv - fold (ThisVersion v) = this v - fold (LaterVersion v) = later v - fold (EarlierVersion v) = earlier v - fold (WildcardVersion v) = fold (wildcard v) - fold (UnionVersionRanges v1 v2) = union (fold v1) (fold v2) - fold (IntersectVersionRanges v1 v2) = intersect (fold v1) (fold v2) - fold (VersionRangeParens v) = fold v - - wildcard v = intersectVersionRanges - (orLaterVersion v) - (earlierVersion (wildcardUpperBound v)) - --- | An extended variant of 'foldVersionRange' that also provides a view of --- in which the syntactic sugar @\">= v\"@, @\"<= v\"@ and @\"== v.*\"@ is presented --- explicitly rather than in terms of the other basic syntax. --- -foldVersionRange' :: a -- ^ @\"-any\"@ version - -> (Version -> a) -- ^ @\"== v\"@ - -> (Version -> a) -- ^ @\"> v\"@ - -> (Version -> a) -- ^ @\"< v\"@ - -> (Version -> a) -- ^ @\">= v\"@ - -> (Version -> a) -- ^ @\"<= v\"@ - -> (Version -> Version -> a) -- ^ @\"== v.*\"@ wildcard. The - -- function is passed the - -- inclusive lower bound and the - -- exclusive upper bounds of the - -- range defined by the wildcard. - -> (a -> a -> a) -- ^ @\"_ || _\"@ union - -> (a -> a -> a) -- ^ @\"_ && _\"@ intersection - -> (a -> a) -- ^ @\"(_)\"@ parentheses - -> VersionRange -> a -foldVersionRange' anyv this later earlier orLater orEarlier - wildcard union intersect parens = fold - where - fold AnyVersion = anyv - fold (ThisVersion v) = this v - fold (LaterVersion v) = later v - fold (EarlierVersion v) = earlier v - - fold (UnionVersionRanges (ThisVersion v) - (LaterVersion v')) | v==v' = orLater v - fold (UnionVersionRanges (LaterVersion v) - (ThisVersion v')) | v==v' = orLater v - fold (UnionVersionRanges (ThisVersion v) - (EarlierVersion v')) | v==v' = orEarlier v - fold (UnionVersionRanges (EarlierVersion v) - (ThisVersion v')) | v==v' = orEarlier v - - fold (WildcardVersion v) = wildcard v (wildcardUpperBound v) - fold (UnionVersionRanges v1 v2) = union (fold v1) (fold v2) - fold (IntersectVersionRanges v1 v2) = intersect (fold v1) (fold v2) - fold (VersionRangeParens v) = parens (fold v) - - --- | Does this version fall within the given range? --- --- This is the evaluation function for the 'VersionRange' type. --- -withinRange :: Version -> VersionRange -> Bool -withinRange v = foldVersionRange - True - (\v' -> versionBranch v == versionBranch v') - (\v' -> versionBranch v > versionBranch v') - (\v' -> versionBranch v < versionBranch v') - (||) - (&&) - --- | View a 'VersionRange' as a union of intervals. --- --- This provides a canonical view of the semantics of a 'VersionRange' as --- opposed to the syntax of the expression used to define it. For the syntactic --- view use 'foldVersionRange'. --- --- Each interval is non-empty. The sequence is in increasing order and no --- intervals overlap or touch. Therefore only the first and last can be --- unbounded. The sequence can be empty if the range is empty --- (e.g. a range expression like @< 1 && > 2@). --- --- Other checks are trivial to implement using this view. For example: --- --- > isNoVersion vr | [] <- asVersionIntervals vr = True --- > | otherwise = False --- --- > isSpecificVersion vr --- > | [(LowerBound v InclusiveBound --- > ,UpperBound v' InclusiveBound)] <- asVersionIntervals vr --- > , v == v' = Just v --- > | otherwise = Nothing --- -asVersionIntervals :: VersionRange -> [VersionInterval] -asVersionIntervals = versionIntervals . toVersionIntervals - --- | Does this 'VersionRange' place any restriction on the 'Version' or is it --- in fact equivalent to 'AnyVersion'. --- --- Note this is a semantic check, not simply a syntactic check. So for example --- the following is @True@ (for all @v@). --- --- > isAnyVersion (EarlierVersion v `UnionVersionRanges` orLaterVersion v) --- -isAnyVersion :: VersionRange -> Bool -isAnyVersion vr = case asVersionIntervals vr of - [(LowerBound v InclusiveBound, NoUpperBound)] | isVersion0 v -> True - _ -> False - --- | This is the converse of 'isAnyVersion'. It check if the version range is --- empty, if there is no possible version that satisfies the version range. --- --- For example this is @True@ (for all @v@): --- --- > isNoVersion (EarlierVersion v `IntersectVersionRanges` LaterVersion v) --- -isNoVersion :: VersionRange -> Bool -isNoVersion vr = case asVersionIntervals vr of - [] -> True - _ -> False - --- | Is this version range in fact just a specific version? --- --- For example the version range @\">= 3 && <= 3\"@ contains only the version --- @3@. --- -isSpecificVersion :: VersionRange -> Maybe Version -isSpecificVersion vr = case asVersionIntervals vr of - [(LowerBound v InclusiveBound - ,UpperBound v' InclusiveBound)] - | v == v' -> Just v - _ -> Nothing - --- | Simplify a 'VersionRange' expression. For non-empty version ranges --- this produces a canonical form. Empty or inconsistent version ranges --- are left as-is because that provides more information. --- --- If you need a canonical form use --- @fromVersionIntervals . toVersionIntervals@ --- --- It satisfies the following properties: --- --- > withinRange v (simplifyVersionRange r) = withinRange v r --- --- > withinRange v r = withinRange v r' --- > ==> simplifyVersionRange r = simplifyVersionRange r' --- > || isNoVersion r --- > || isNoVersion r' --- -simplifyVersionRange :: VersionRange -> VersionRange -simplifyVersionRange vr - -- If the version range is inconsistent then we just return the - -- original since that has more information than ">1 && < 1", which - -- is the canonical inconsistent version range. - | null (versionIntervals vi) = vr - | otherwise = fromVersionIntervals vi - where - vi = toVersionIntervals vr - ----------------------------- --- Wildcard range utilities --- - -wildcardUpperBound :: Version -> Version -wildcardUpperBound (Version lowerBound ts) = (Version upperBound ts) - where - upperBound = init lowerBound ++ [last lowerBound + 1] - -isWildcardRange :: Version -> Version -> Bool -isWildcardRange (Version branch1 _) (Version branch2 _) = check branch1 branch2 - where check (n:[]) (m:[]) | n+1 == m = True - check (n:ns) (m:ms) | n == m = check ns ms - check _ _ = False - ------------------- --- Intervals view --- - --- | A complementary representation of a 'VersionRange'. Instead of a boolean --- version predicate it uses an increasing sequence of non-overlapping, --- non-empty intervals. --- --- The key point is that this representation gives a canonical representation --- for the semantics of 'VersionRange's. This makes it easier to check things --- like whether a version range is empty, covers all versions, or requires a --- certain minimum or maximum version. It also makes it easy to check equality --- or containment. It also makes it easier to identify \'simple\' version --- predicates for translation into foreign packaging systems that do not --- support complex version range expressions. --- -newtype VersionIntervals = VersionIntervals [VersionInterval] - deriving (Eq, Show) - --- | Inspect the list of version intervals. --- -versionIntervals :: VersionIntervals -> [VersionInterval] -versionIntervals (VersionIntervals is) = is - -type VersionInterval = (LowerBound, UpperBound) -data LowerBound = LowerBound Version !Bound deriving (Eq, Show) -data UpperBound = NoUpperBound | UpperBound Version !Bound deriving (Eq, Show) -data Bound = ExclusiveBound | InclusiveBound deriving (Eq, Show) - -minLowerBound :: LowerBound -minLowerBound = LowerBound (Version [0] []) InclusiveBound - -isVersion0 :: Version -> Bool -isVersion0 (Version [0] _) = True -isVersion0 _ = False - -instance Ord LowerBound where - LowerBound ver bound <= LowerBound ver' bound' = case compare ver ver' of - LT -> True - EQ -> not (bound == ExclusiveBound && bound' == InclusiveBound) - GT -> False - -instance Ord UpperBound where - _ <= NoUpperBound = True - NoUpperBound <= UpperBound _ _ = False - UpperBound ver bound <= UpperBound ver' bound' = case compare ver ver' of - LT -> True - EQ -> not (bound == InclusiveBound && bound' == ExclusiveBound) - GT -> False - -invariant :: VersionIntervals -> Bool -invariant (VersionIntervals intervals) = all validInterval intervals - && all doesNotTouch' adjacentIntervals - where - doesNotTouch' :: (VersionInterval, VersionInterval) -> Bool - doesNotTouch' ((_,u), (l',_)) = doesNotTouch u l' - - adjacentIntervals :: [(VersionInterval, VersionInterval)] - adjacentIntervals - | null intervals = [] - | otherwise = zip intervals (tail intervals) - -checkInvariant :: VersionIntervals -> VersionIntervals -checkInvariant is = assert (invariant is) is - --- | Directly construct a 'VersionIntervals' from a list of intervals. --- --- Each interval must be non-empty. The sequence must be in increasing order --- and no invervals may overlap or touch. If any of these conditions are not --- satisfied the function returns @Nothing@. --- -mkVersionIntervals :: [VersionInterval] -> Maybe VersionIntervals -mkVersionIntervals intervals - | invariant (VersionIntervals intervals) = Just (VersionIntervals intervals) - | otherwise = Nothing - -validVersion :: Version -> Bool -validVersion (Version [] _) = False -validVersion (Version vs _) = all (>=0) vs - -validInterval :: (LowerBound, UpperBound) -> Bool -validInterval i@(l, u) = validLower l && validUpper u && nonEmpty i - where - validLower (LowerBound v _) = validVersion v - validUpper NoUpperBound = True - validUpper (UpperBound v _) = validVersion v - --- Check an interval is non-empty --- -nonEmpty :: VersionInterval -> Bool -nonEmpty (_, NoUpperBound ) = True -nonEmpty (LowerBound l lb, UpperBound u ub) = - (l < u) || (l == u && lb == InclusiveBound && ub == InclusiveBound) - --- Check an upper bound does not intersect, or even touch a lower bound: --- --- ---| or ---) but not ---] or ---) or ---] --- |--- (--- (--- [--- [--- --- -doesNotTouch :: UpperBound -> LowerBound -> Bool -doesNotTouch NoUpperBound _ = False -doesNotTouch (UpperBound u ub) (LowerBound l lb) = - u < l - || (u == l && ub == ExclusiveBound && lb == ExclusiveBound) - --- | Check an upper bound does not intersect a lower bound: --- --- ---| or ---) or ---] or ---) but not ---] --- |--- (--- (--- [--- [--- --- -doesNotIntersect :: UpperBound -> LowerBound -> Bool -doesNotIntersect NoUpperBound _ = False -doesNotIntersect (UpperBound u ub) (LowerBound l lb) = - u < l - || (u == l && not (ub == InclusiveBound && lb == InclusiveBound)) - --- | Test if a version falls within the version intervals. --- --- It exists mostly for completeness and testing. It satisfies the following --- properties: --- --- > withinIntervals v (toVersionIntervals vr) = withinRange v vr --- > withinIntervals v ivs = withinRange v (fromVersionIntervals ivs) --- -withinIntervals :: Version -> VersionIntervals -> Bool -withinIntervals v (VersionIntervals intervals) = any withinInterval intervals - where - withinInterval (lowerBound, upperBound) = withinLower lowerBound - && withinUpper upperBound - withinLower (LowerBound v' ExclusiveBound) = v' < v - withinLower (LowerBound v' InclusiveBound) = v' <= v - - withinUpper NoUpperBound = True - withinUpper (UpperBound v' ExclusiveBound) = v' > v - withinUpper (UpperBound v' InclusiveBound) = v' >= v - --- | Convert a 'VersionRange' to a sequence of version intervals. --- -toVersionIntervals :: VersionRange -> VersionIntervals -toVersionIntervals = foldVersionRange - ( chkIvl (minLowerBound, NoUpperBound)) - (\v -> chkIvl (LowerBound v InclusiveBound, UpperBound v InclusiveBound)) - (\v -> chkIvl (LowerBound v ExclusiveBound, NoUpperBound)) - (\v -> if isVersion0 v then VersionIntervals [] else - chkIvl (minLowerBound, UpperBound v ExclusiveBound)) - unionVersionIntervals - intersectVersionIntervals - where - chkIvl interval = checkInvariant (VersionIntervals [interval]) - --- | Convert a 'VersionIntervals' value back into a 'VersionRange' expression --- representing the version intervals. --- -fromVersionIntervals :: VersionIntervals -> VersionRange -fromVersionIntervals (VersionIntervals []) = noVersion -fromVersionIntervals (VersionIntervals intervals) = - foldr1 UnionVersionRanges [ interval l u | (l, u) <- intervals ] - - where - interval (LowerBound v InclusiveBound) - (UpperBound v' InclusiveBound) | v == v' - = ThisVersion v - interval (LowerBound v InclusiveBound) - (UpperBound v' ExclusiveBound) | isWildcardRange v v' - = WildcardVersion v - interval l u = lowerBound l `intersectVersionRanges'` upperBound u - - lowerBound (LowerBound v InclusiveBound) - | isVersion0 v = AnyVersion - | otherwise = orLaterVersion v - lowerBound (LowerBound v ExclusiveBound) = LaterVersion v - - upperBound NoUpperBound = AnyVersion - upperBound (UpperBound v InclusiveBound) = orEarlierVersion v - upperBound (UpperBound v ExclusiveBound) = EarlierVersion v - - intersectVersionRanges' vr AnyVersion = vr - intersectVersionRanges' AnyVersion vr = vr - intersectVersionRanges' vr vr' = IntersectVersionRanges vr vr' - -unionVersionIntervals :: VersionIntervals -> VersionIntervals - -> VersionIntervals -unionVersionIntervals (VersionIntervals is0) (VersionIntervals is'0) = - checkInvariant (VersionIntervals (union is0 is'0)) - where - union is [] = is - union [] is' = is' - union (i:is) (i':is') = case unionInterval i i' of - Left Nothing -> i : union is (i' :is') - Left (Just i'') -> union is (i'':is') - Right Nothing -> i' : union (i :is) is' - Right (Just i'') -> union (i'':is) is' - -unionInterval :: VersionInterval -> VersionInterval - -> Either (Maybe VersionInterval) (Maybe VersionInterval) -unionInterval (lower , upper ) (lower', upper') - - -- Non-intersecting intervals with the left interval ending first - | upper `doesNotTouch` lower' = Left Nothing - - -- Non-intersecting intervals with the right interval first - | upper' `doesNotTouch` lower = Right Nothing - - -- Complete or partial overlap, with the left interval ending first - | upper <= upper' = lowerBound `seq` - Left (Just (lowerBound, upper')) - - -- Complete or partial overlap, with the left interval ending first - | otherwise = lowerBound `seq` - Right (Just (lowerBound, upper)) - where - lowerBound = min lower lower' - -intersectVersionIntervals :: VersionIntervals -> VersionIntervals - -> VersionIntervals -intersectVersionIntervals (VersionIntervals is0) (VersionIntervals is'0) = - checkInvariant (VersionIntervals (intersect is0 is'0)) - where - intersect _ [] = [] - intersect [] _ = [] - intersect (i:is) (i':is') = case intersectInterval i i' of - Left Nothing -> intersect is (i':is') - Left (Just i'') -> i'' : intersect is (i':is') - Right Nothing -> intersect (i:is) is' - Right (Just i'') -> i'' : intersect (i:is) is' - -intersectInterval :: VersionInterval -> VersionInterval - -> Either (Maybe VersionInterval) (Maybe VersionInterval) -intersectInterval (lower , upper ) (lower', upper') - - -- Non-intersecting intervals with the left interval ending first - | upper `doesNotIntersect` lower' = Left Nothing - - -- Non-intersecting intervals with the right interval first - | upper' `doesNotIntersect` lower = Right Nothing - - -- Complete or partial overlap, with the left interval ending first - | upper <= upper' = lowerBound `seq` - Left (Just (lowerBound, upper)) - - -- Complete or partial overlap, with the right interval ending first - | otherwise = lowerBound `seq` - Right (Just (lowerBound, upper')) - where - lowerBound = max lower lower' - -------------------------------- --- Parsing and pretty printing --- - -instance Text VersionRange where - disp = fst - . foldVersionRange' -- precedence: - ( Disp.text "-any" , 0 :: Int) - (\v -> (Disp.text "==" <> disp v , 0)) - (\v -> (Disp.char '>' <> disp v , 0)) - (\v -> (Disp.char '<' <> disp v , 0)) - (\v -> (Disp.text ">=" <> disp v , 0)) - (\v -> (Disp.text "<=" <> disp v , 0)) - (\v _ -> (Disp.text "==" <> dispWild v , 0)) - (\(r1, p1) (r2, p2) -> (punct 2 p1 r1 <+> Disp.text "||" <+> punct 2 p2 r2 , 2)) - (\(r1, p1) (r2, p2) -> (punct 1 p1 r1 <+> Disp.text "&&" <+> punct 1 p2 r2 , 1)) - id - - where dispWild (Version b _) = - Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int b)) - <> Disp.text ".*" - punct p p' | p < p' = Disp.parens - | otherwise = id - - parse = expr - where - expr = do Parse.skipSpaces - t <- term - Parse.skipSpaces - (do _ <- Parse.string "||" - Parse.skipSpaces - e <- expr - return (UnionVersionRanges t e) - +++ - return t) - term = do f <- factor - Parse.skipSpaces - (do _ <- Parse.string "&&" - Parse.skipSpaces - t <- term - return (IntersectVersionRanges f t) - +++ - return f) - factor = Parse.choice $ parens expr - : parseAnyVersion - : parseWildcardRange - : map parseRangeOp rangeOps - parseAnyVersion = Parse.string "-any" >> return AnyVersion - - parseWildcardRange = do - _ <- Parse.string "==" - Parse.skipSpaces - branch <- Parse.sepBy1 digits (Parse.char '.') - _ <- Parse.char '.' - _ <- Parse.char '*' - return (WildcardVersion (Version branch [])) - - parens p = Parse.between (Parse.char '(' >> Parse.skipSpaces) - (Parse.char ')' >> Parse.skipSpaces) - (do a <- p - Parse.skipSpaces - return (VersionRangeParens a)) - - digits = do - first <- Parse.satisfy Char.isDigit - if first == '0' - then return 0 - else do rest <- Parse.munch Char.isDigit - return (read (first : rest)) - - parseRangeOp (s,f) = Parse.string s >> Parse.skipSpaces >> fmap f parse - rangeOps = [ ("<", EarlierVersion), - ("<=", orEarlierVersion), - (">", LaterVersion), - (">=", orLaterVersion), - ("==", ThisVersion) ] diff -Nru ghc-7.0.3/libraries/Cabal/doc/Cabal.css ghc-7.2.1/libraries/Cabal/doc/Cabal.css --- ghc-7.0.3/libraries/Cabal/doc/Cabal.css 2011-03-26 18:10:12.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/doc/Cabal.css 1970-01-01 00:00:00.000000000 +0000 @@ -1,39 +0,0 @@ -div { - font-family: sans-serif; - color: black; - background: white -} - -h1, h2, h3, h4, h5, h6, p.title { color: #005A9C } - -h1 { font: 170% sans-serif } -h2 { font: 140% sans-serif } -h3 { font: 120% sans-serif } -h4 { font: bold 100% sans-serif } -h5 { font: italic 100% sans-serif } -h6 { font: small-caps 100% sans-serif } - -pre { - font-family: monospace; - border-width: 1px; - border-style: solid; - padding: 0.3em -} - -pre.screen { color: #006400 } -pre.programlisting { color: maroon } - -div.example { - margin: 1ex 0em; - border: solid #412e25 1px; - padding: 0ex 0.4em -} - -div.example, div.example-contents { - background-color: #fffcf5 -} - -a:link { color: #0000C8 } -a:hover { background: #FFFFA8 } -a:active { color: #D00000 } -a:visited { color: #680098 } diff -Nru ghc-7.0.3/libraries/Cabal/doc/Cabal.markdown ghc-7.2.1/libraries/Cabal/doc/Cabal.markdown --- ghc-7.0.3/libraries/Cabal/doc/Cabal.markdown 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/doc/Cabal.markdown 1970-01-01 00:00:00.000000000 +0000 @@ -1,2410 +0,0 @@ -% Cabal User Guide - -Cabal aims to simplify the distribution of -[Haskell](http://www.haskell.org/) software. It does this by specifying -a number of interfaces between package authors, builders and users, as -well as providing a library implementing these interfaces. - - * [Introduction](#introduction) - * [Packages](#packages) - * [Creating a package](#creating-a-package) - - [Package descriptions](#package-descriptions) - + [Package properties](#package-properties) - + [Library](#library) - + [Executables](#executables) - + [Test suites](#test-suites) - + [Build information](#build-information) - + [Configurations](#configurations) - + [Source Repositories](#source-repositories) - - [Accessing data files from package code](#accessing-data-files-from-package-code) - - [System-dependent parameters](#system-dependent-parameters) - - [Conditional compilation](#conditional-compilation) - - [More complex packages](#more-complex-packages) - * [Building and installing a package](#building-and-installing-a-package) - - [Building and installing a system package](#building-and-installing-a-system-package) - - [Building and installing a user package](#building-and-installing-a-user-package) - - [Creating a binary package](#creating-a-binary-package) - - [setup configure](#setup-configure) - + [Programs used for building](#programs-used-for-building) - + [Installation paths](#installation-paths) - + [Controlling Flag Assignments](#controlling-flag-assignments) - + [Building Test Suites](#building-test-suites) - + [Miscellaneous options](#miscellaneous-options) - - [setup build](#setup-build) - - [setup haddock](#setup-haddock) - - [setup hscolour](#setup-hscolour) - - [setup install](#setup-install) - - [setup copy](#setup-copy) - - [setup register](#setup-register) - - [setup unregister](#setup-unregister) - - [setup clean](#setup-clean) - - [setup test](#setup-test) - - [setup sdist](#setup-sdist) - * [Reporting bugs and deficiencies](#reporting-bugs-and-deficiencies) - * [Stability of Cabal interfaces](#stability-of-cabal-interfaces) - - [Cabal file format](#cabal-file-format) - - [Command-line interface](#command-line-interface) - + [Very Stable Command-line interfaces](#very-stable-command-line-interfaces) - + [Stable Command-line interfaces](#stable-command-line-interfaces) - + [Unstable command-line](#unstable-command-line) - - [Functions and Types](#functions-and-types) - + [Very Stable API](#very-stable-api) - + [Semi-stable API](#semi-stable-api) - + [Unstable API](#unstable-api) - - [Hackage](#hackage) - -# Introduction # - -Developers write Cabal packages. These can be for libraries or -executables. This involves writing the code obviously and also creating -a `.cabal` file. The .cabal file contains some information about the -package. Some of this information is needed to actually build the -package and some is just useful for identifying the package when it -comes to distribution. - -~~~~~~~~~~~~~~~~ -name: Foo -version: 1.0 - -library - build-depends: base - exposed-modules: Foo -~~~~~~~~~~~~~~~~ - -Users install Cabal packages so they can use them. It is not expected -that users will have to modify any of the information in the `.cabal` -file. Cabal does provide a number of ways for a user to customise how -and where a package is installed. They can decide where a package will -be installed, which Haskell implementation to use and whether to build -optimised code or build with the ability to profile code. - -~~~~~~~~~~~~~~~~ -tar -xzf Foo-1.0.tar.gz -cd Foo-1.0 -runhaskell Setup configure --with-compiler=ghc-6.4.2 --user -runhaskell Setup build -runhaskell Setup install -~~~~~~~~~~~~~~~~ - -One of the purposes of Cabal is to make it easier to build a package -with different Haskell implementations. So it provides abstractions of -features present in different Haskell implementations and wherever -possible it is best to take advantage of these to increase portability. -Where necessary however it is possible to use specific features of -specific implementations. For example one of the pieces of information a -package author can put in the package's `.cabal` file is what language -extensions the code uses. This is far preferable to specifying flags for -a specific compiler as it allows Cabal to pick the right flags for the -Haskell implementation that the user picks. It also allows Cabal to -figure out if the language extension is even supported by the Haskell -implementation that the user picks. Where compiler-specific options are -needed however, there is an "escape hatch" available. The developer can -specify implementation-specific options and more generally there is a -configuration mechanism to customise many aspects of how a package is -built depending on the Haskell implementation, the Operating system, -computer architecture and user-specified configuration flags. - -~~~~~~~~~~~~~~~~ -name: Foo -version: 1.0 - -library - build-depends: base - exposed-modules: Foo - extensions: ForeignFunctionInterface - ghc-options: -Wall - nhc98-options: -K4m - if os(windows) - build-depends: Win32 -~~~~~~~~~~~~~~~~ - -# Packages # - -A _package_ is the unit of distribution for the Cabal. Its purpose, -when installed, is to make available either or both of: - -* One or more Haskell programs. - -* A library, exposing a number of Haskell modules. A library may also - contain _hidden_ modules, which are used internally but not - available to clients.[^hugs] - -[^hugs]: Hugs doesn't support module hiding. - -However having both a library and executables in a package does not work -very well; if the executables depend on the library, they must -explicitly list all the modules they directly or indirectly import from -that library. Fortunately, starting with Cabal 1.8.0.4, executables can -also declare the package that they are in as a dependency, and Cabal -will treat them as if they were in another package that dependended on -the library. - -Internally, the package may consist of much more than a bunch of Haskell -modules: it may also have C source code and header files, source code -meant for preprocessing, documentation, test cases, auxiliary tools etc. - -A package is identified by a globally-unique _package name_, which -consists of one or more alphanumeric words separated by hyphens. To -avoid ambiguity, each of these words should contain at least one letter. -Chaos will result if two distinct packages with the same name are -installed on the same system, but there is not yet a mechanism for -allocating these names. A particular version of the package is -distinguished by a _version number_, consisting of a sequence of one or -more integers separated by dots. These can be combined to form a single -text string called the _package ID_, using a hyphen to separate the name -from the version, e.g. "`HUnit-1.1`". - -Note: Packages are not part of the Haskell language; they simply -populate the hierarchical space of module names. In GHC 6.6 and later a -program may contain multiple modules with the same name if they come -from separate packages; in all other current Haskell systems packages -may not overlap in the modules they provide, including hidden modules. - -# Creating a package # - -Suppose you have a directory hierarchy containing the source files that -make up your package. You will need to add two more files to the root -directory of the package: - -_package_`.cabal` - -: a Unicode UTF-8 text file containing a package description (for - details of the syntax of this file, see the [package description - section](#package-descriptions)) - -`Setup.hs` or `Setup.lhs` - -: a single-module Haskell program to perform various setup tasks (with - the interface described in the section on [building and installing - packages](#building-and-installing-a-package)). This module should - import only modules that will be present in all Haskell - implementations, including modules of the Cabal library. In most - cases it will be trivial, calling on the Cabal library to do most of - the work. - -Once you have these, you can create a source bundle of this directory -for distribution. Building of the package is discussed in the section on -[building and installing packages](#building-and-installing-a-package). - -#### Example: A package containing a simple library #### - -The HUnit package contains a file `HUnit.cabal` containing: - -~~~~~~~~~~~~~~~~ -Name:HUnit -Version:1.1.1 -Cabal-Version: >= 1.2 -License:BSD3 -License-File:LICENSE -Author:Dean Herington -Homepage:http://hunit.sourceforge.net/ -Category:Testing -Synopsis:A unit testing framework for Haskell - -Library - Build-Depends:base - Exposed-modules: - Test.HUnit.Base, Test.HUnit.Lang, Test.HUnit.Terminal, - Test.HUnit.Text, Test.HUnit - Extensions:CPP -~~~~~~~~~~~~~~~~ - -and the following `Setup.hs`: - -~~~~~~~~~~~~~~~~ -import Distribution.Simple -main = defaultMain -~~~~~~~~~~~~~~~~ - -#### Example: A package containing executable programs #### - -~~~~~~~~~~~~~~~~ -Name: TestPackage -Version: 0.0 -Cabal-Version: >= 1.2 -License: BSD3 -Author: Angela Author -Synopsis: Small package with two programs -Build-Type: Simple - -Executable program1 - Build-Depends: HUnit - Main-Is: Main.hs - Hs-Source-Dirs: prog1 - -Executable program2 - Main-Is: Main.hs - Build-Depends: HUnit - Hs-Source-Dirs: prog2 - Other-Modules: Utils -~~~~~~~~~~~~~~~~ - -with `Setup.hs` the same as above. - -#### Example: A package containing a library and executable programs #### - -~~~~~~~~~~~~~~~~ -Name: TestPackage -Version: 0.0 -Cabal-Version: >= 1.2 -License: BSD3 -Author: Angela Author -Synopsis: Package with library and two programs -Build-Type: Simple - -Library - Build-Depends: HUnit - Exposed-Modules: A, B, C - -Executable program1 - Main-Is: Main.hs - Hs-Source-Dirs: prog1 - Other-Modules: A, B - -Executable program2 - Main-Is: Main.hs - Hs-Source-Dirs: prog2 - Other-Modules: A, C, Utils -~~~~~~~~~~~~~~~~ - -with `Setup.hs` the same as above. Note that any library modules -required (directly or indirectly) by an executable must be listed again. - -The trivial setup script used in these examples uses the _simple build -infrastructure_ provided by the Cabal library (see -[Distribution.Simple][dist-simple]). The simplicity lies in its -interface rather that its implementation. It automatically handles -preprocessing with standard preprocessors, and builds packages for all -the Haskell implementations (except nhc98, for now). - -The simple build infrastructure can also handle packages where building -is governed by system-dependent parameters, if you specify a little more -(see the section on [system-dependent -parameters](#system-dependent-parameters)). A few packages require [more -elaborate solutions](#complex-packages). - -## Package descriptions ## - -The package description file must have a name ending in "`.cabal`". It -must be a Unicode text file encoded using valid UTF-8. There must be -exactly one such file in the directory. The first part of the name is -usually the package name, and some of the tools that operate on Cabal -packages require this. - -In the package description file, lines whose first non-whitespace characters -are "`--`" are treated as comments and ignored. - -This file should contain of a number global property descriptions and -several sections. - -* The [global properties](#package-properties) describe the package as a - whole, such as name, license, author, etc. - -* Optionally, a number of _configuration flags_ can be declared. These - can be used to enable or disable certain features of a package. (see - the section on [configurations](#configurations)). - -* The (optional) library section specifies the [library - properties](#library) and relevant [build - information](#build-information). - -* Following is an arbitrary number of executable sections - which describe an [executable program](#executable) and relevant - [build information](#build-information). - -Each section consists of a number of property descriptions -in the form of field/value pairs, with a syntax roughly like mail -message headers. - -* Case is not significant in field names, but is significant in field - values. - -* To continue a field value, indent the next line relative to the field - name. - -* Field names may be indented, but all field values in the same section - must use the same indentation. - -* Tabs are *not* allowed as indentation characters due to a missing - standard interpretation of tab width. - -* To get a blank line in a field value, use an indented "`.`" - -The syntax of the value depends on the field. Field types include: - -_token_, _filename_, _directory_ -: Either a sequence of one or more non-space non-comma characters, or - a quoted string in Haskell 98 lexical syntax. Unless otherwise - stated, relative filenames and directories are interpreted from the - package root directory. - -_freeform_, _URL_, _address_ -: An arbitrary, uninterpreted string. - -_identifier_ -: A letter followed by zero or more alphanumerics or underscores. - -_compiler_ -: A compiler flavor (one of: `GHC`, `NHC`, `YHC`, `Hugs`, `HBC`, - `Helium`, `JHC`, or `LHC`) followed by a version range. For - example, `GHC ==6.10.3`, or `LHC >=0.6 && <0.8`. - -### Modules and preprocessors ### - -Haskell module names listed in the `exposed-modules` and `other-modules` -fields may correspond to Haskell source files, i.e. with names ending in -"`.hs`" or "`.lhs`", or to inputs for various Haskell preprocessors. The -simple build infrastructure understands the extensions: - -* `.gc` ([greencard][]) -* `.chs` ([c2hs][]) -* `.hsc` (`hsc2hs`) -* `.y` and `.ly` ([happy][]) -* `.x` ([alex][]) -* `.cpphs` ([cpphs][]) - -When building, Cabal will automatically run the appropriate preprocessor -and compile the Haskell module it produces. - -Some fields take lists of values, which are optionally separated by commas, except for the -`build-depends` field, where the commas are mandatory. - -Some fields are marked as required. All others are optional, and unless -otherwise specified have empty default values. - -### Package properties ### - -These fields may occur in the first top-level properties section and -describe the package as a whole: - -`name:` _package-name_ (required) -: The unique name of the [package](#packages), without the version - number. - -`version:` _numbers_ (required) -: The package version number, usually consisting of a sequence of - natural numbers separated by dots. - -`cabal-version:` _>= x.y_ -: The version of the Cabal specification that this package description uses. - The Cabal specification does slowly evolve, intoducing new features and - occasionally changing the meaning of existing features. By specifying - which version of the spec you are using it enables programs which process - the package description to know what syntax to expect and what each part - means. - - For historical reasons this is always expressed using _>=_ version range - syntax. No other kinds of version range make sense, in particular upper - bounds do not make sense. In future this field will specify just a version - number, rather than a version range. - - The version number you specify will affect both compatability and - behaviour. Most tools (including the Cabal libray and cabal program) - understand a range of versions of the Cabal specification. Older tools - will of course only work with older versions of the Cabal specification. - Most of the time, tools that are too old will recognise this fact and - produce a suitable error message. - - As for behaviour, new versions of the Cabal spec can change the meaning - of existing syntax. This means if you want to take advantage of the new - meaning or behaviour then you must specify the newer Cabal version. - Tools are expected to use the meaning and behaviour appropriate to the - version given in the package description. - - In particular, the syntax of package descriptions changed significantly - with Cabal version 1.2 and the `cabal-version` field is now required. - Files written in the old syntax are still recognized, so if you require - compatability with very old Cabal versions then you may write your package - description file using the old syntax. Please consult the user's guide of - an older Cabal version for a description of that syntax. - -`build-type:` _identifier_ -: The type of build used by this package. Build types are the - constructors of the [BuildType][] type, defaulting to `Custom`. If - this field is given a value other than `Custom`, some tools such as - `cabal-install` will be able to build the package without using the - setup script. So if you are just using the default `Setup.hs` then - set the build type as `Simple`. - -`license:` _identifier_ (default: `AllRightsReserved`) -: The type of license under which this package is distributed. - License names are the constants of the [License][dist-license] type. - -`license-file:` _filename_ -: The name of a file containing the precise license for this package. - It will be installed with the package. - -`copyright:` _freeform_ -: The content of a copyright notice, typically the name of the holder - of the copyright on the package and the year(s) from which copyright - is claimed. For example: `Copyright: (c) 2006-2007 Joe Bloggs` - -`author:` _freeform_ -: The original author of the package. - - Remember that `.cabal` files are Unicode, using the UTF-8 encoding. - -`maintainer:` _address_ -: The current maintainer or maintainers of the package. This is an e-mail address to which users should send bug - reports, feature requests and patches. - -`stability:` _freeform_ -: The stability level of the package, e.g. `alpha`, `experimental`, `provisional`, - `stable`. - -`homepage:` _URL_ -: The package homepage. - -`bug-reports:` _URL_ -: The URL where users should direct bug reports. This would normally be either: - - * A `mailto:` URL, eg for a person or a mailing list. - - * An `http:` (or `https:`) URL for an online bug tracking system. - - For example Cabal itself uses a web-based bug tracking system - - ~~~~~~~~~~~~~~~~ - bug-reports: http://hackage.haskell.org/trac/hackage/ - ~~~~~~~~~~~~~~~~ - -`package-url:` _URL_ -: The location of a source bundle for the package. The distribution - should be a Cabal package. - -`synopsis:` _freeform_ -: A very short description of the package, for use in a table of - packages. This is your headline, so keep it short (one line) but as - informative as possible. Save space by not including the package - name or saying it's written in Haskell. - -`description:` _freeform_ -: Description of the package. This may be several paragraphs, and - should be aimed at a Haskell programmer who has never heard of your - package before. - - For library packages, this field is used as prologue text by [`setup - haddock`](#setup-haddock), and thus may contain the same markup as - [haddock][] documentation comments. - -`category:` _freeform_ -: A classification category for future use by the package catalogue _Hackage_. These - categories have not yet been specified, but the upper levels of the - module hierarchy make a good start. - -`tested-with:` _compiler list_ -: A list of compilers and versions against which the package has been - tested (or at least built). - -`data-files:` _filename list_ -: A list of files to be installed for run-time use by the package. - This is useful for packages that use a large amount of static data, - such as tables of values or code templates. Cabal provides a way to - [find these files at - run-time](#accessing-data-files-from-package-code). - - A limited form of `*` wildcards in file names, for example - `data-files: images/*.png` matches all the `.png` files in the - `images` directory. - - The limitation is that `*` wildcards are only allowed in place of - the file name, not in the directory name or file extension. In - particular, wildcards do not include directories contents - recursively. Furthermore, if a wildcard is used it must be used with - an extension, so `data-files: data/*` is not allowed. When matching - a wildcard plus extension, a file's full extension must match - exactly, so `*.gz` matches `foo.gz` but not `foo.tar.gz`. A wildcard - that does not match any files is an error. - - The reason for providing only a very limited form of wildcard is to - concisely express the common case of a large number of related files - of the same file type without making it too easy to accidentally - include unwanted files. - -`data-dir:` _directory_ -: The directory where Cabal looks for data files to install, relative - to the source directory. By default, Cabal will look in the source - directory itself. - -`extra-source-files:` _filename list_ -: A list of additional files to be included in source distributions - built with [`setup sdist`](#setup-sdist). As with `data-files` it - can use a limited form of `*` wildcards in file names. - -`extra-tmp-files:` _filename list_ -: A list of additional files or directories to be removed by [`setup - clean`](#setup-clean). These would typically be additional files - created by additional hooks, such as the scheme described in the - section on [system-dependent parameters](#system-dependent-parameters). - -### Library ### - -The library section should contain the following fields: - -`exposed-modules:` _identifier list_ (required if this package contains a library) -: A list of modules added by this package. - -`exposed:` _boolean_ (default: `True`) -: Some Haskell compilers (notably GHC) support the notion of packages - being "exposed" or "hidden" which means the modules they provide can - be easily imported without always having to specify which package - they come from. However this only works effectively if the modules - provided by all exposed packages do not overlap (otherwise a module - import would be ambiguous). - - Almost all new libraries use hierarchical module names that do not - clash, so it is very uncommon to have to use this field. However it - may be necessary to set `exposed: False` for some old libraries that - use a flat module namespace or where it is known that the exposed - modules would clash with other common modules. - -The library section may also contain build information fields (see the -section on [build information](#build-information)). - - -### Executables ### - -Executable sections (if present) describe executable programs contained -in the package and must have an argument after the section label, which -defines the name of the executable. This is a freeform argument but may -not contain spaces. - -The executable may be described using the following fields, as well as -build information fields (see the section on [build -information](#build-information)). - -`main-is:` _filename_ (required) -: The name of the `.hs` or `.lhs` file containing the `Main` module. Note that it is the - `.hs` filename that must be listed, even if that file is generated - using a preprocessor. The source file must be relative to one of the - directories listed in `hs-source-dirs`. - -### Test suites ### - -Test suite sections (if present) describe package test suites and must have an -argument after the section label, which defines the name of the test suite. -This is a freeform argument, but may not contain spaces. It should be unique -among the names of the package's other test suites, the package's executables, -and the package itself. Using test suite sections requires at least Cabal -version 1.9.2. - -The test suite may be described using the following fields, as well as build -information fields (see the section on [build -information](#build-information)). - -`type:` _interface_ (required) -: The interface type and version of the test suite. Cabal supports two test - suite interfaces, called `exitcode-stdio-1.0` and `detailed-1.0`. Each of - these types may require or disallow other fields as described below. - -Test suites using the `exitcode-stdio-1.0` interface are executables -that indicate test failure with a non-zero exit code when run; they may provide -human-readable log information through the standard output and error channels. -This interface is provided primarily for compatibility with existing test -suites; it is preferred that new test suites be written for the `detailed-1.0` -interface. The `exitcode-stdio-1.0` type requires the `main-is` field. - -`main-is:` _filename_ (required: `exitcode-stdio-1.0`, disallowed: `detailed-1.0`) -: The name of the `.hs` or `.lhs` file containing the `Main` module. Note that it is the - `.hs` filename that must be listed, even if that file is generated - using a preprocessor. The source file must be relative to one of the - directories listed in `hs-source-dirs`. This field is analogous to the - `main-is` field of an executable section. - -Test suites using the `detailed-1.0` interface are modules exporting the symbol -`tests :: [Test]`. The `Test` type is exported by the module -`Distribution.TestSuite` provided by Cabal. For more details, see the example below. - -The `detailed-1.0` interface allows Cabal and other test agents to inspect a -test suite's results case by case, producing detailed human- and -machine-readable log files. The `detailed-1.0` interface requires the -`test-module` field. - -`test-module:` _identifier_ (required: `detailed-1.0`, disallowed: `exitcode-stdio-1.0`) -: The module exporting the `tests` symbol. - -#### Example: Package using `exitcode-stdio-1.0` interface #### - -The example package description and executable source file below demonstrate -the use of the `exitcode-stdio-1.0` interface. For brevity, the example package -does not include a library or any normal executables, but a real package would -be required to have at least one library or executable. - -foo.cabal: - -~~~~~~~~~~~~~~~~ -Name: foo -Version: 1.0 -License: BSD3 -Cabal-Version: >= 1.9.2 -Build-Type: Simple - -Test-Suite test-foo - type: exitcode-stdio-1.0 - main-is: test-foo.hs - build-depends: base -~~~~~~~~~~~~~~~~ - -test-foo.hs: - -~~~~~~~~~~~~~~~~ -module Main where - -import System.Exit (exitFailure) - -main = do - putStrLn "This test always fails!" - exitFailure -~~~~~~~~~~~~~~~~ - -#### Example: Package using `detailed-1.0` interface #### - -The example package description and test module source file below demonstrate -the use of the `detailed-1.0` interface. For brevity, the example package does -note include a library or any normal executables, but a real package would be -required to have at least one library or executable. The test module below -also develops a simple implementation of the interface set by -`Distribution.TestSuite`, but in actual usage the implementation would be -provided by the library that provides the testing facility. - -bar.cabal: - -~~~~~~~~~~~~~~~~ -Name: bar -Version: 1.0 -License: BSD3 -Cabal-Version: >= 1.9.2 -Build-Type: Simple - -Test-Suite test-bar - type: detailed-1.0 - test-module: Test.Bar - build-depends: base, Cabal >= 1.9.2 -~~~~~~~~~~~~~~~~ - -Test/Bar.hs: - -~~~~~~~~~~~~~~~~ -{-# LANGUAGE FlexibleInstances #-} -module Test.Bar ( tests ) where - -import Distribution.TestSuite - -instance TestOptions (String, Bool) where - name = fst - options = const [] - defaultOptions _ = return (Options []) - check _ _ = [] - -instance PureTestable (String, Bool) where - run (name, result) _ | result == True = Pass - | result == False = Fail (name ++ " failed!") - -test :: (String, Bool) -> Test -test = pure - --- In actual usage, the instances 'TestOptions (String, Bool)' and --- 'PureTestable (String, Bool)', as well as the function 'test', would be --- provided by the test framework. - -tests :: [Test] -tests = - [ test ("bar-1", True) - , test ("bar-2", False) - ] -~~~~~~~~~~~~~~~~ - -### Build information ### - -The following fields may be optionally present in a library or -executable section, and give information for the building of the -corresponding library or executable. See also the sections on -[system-dependent parameters](#system-dependent-parameters) and -[configurations](#configurations) for a way to supply system-dependent -values for these fields. - -`build-depends:` _package list_ -: A list of packages needed to build this one. Each package can be - annotated with a version constraint. - - Version constraints use the operators `==, >=, >, <, <=` and a - version number. Multiple constraints can be combined using `&&` or - `||`. If no version constraint is specified, any version is assumed - to be acceptable. For example: - - ~~~~~~~~~~~~~~~~ - library - build-depends: - base >= 2, - foo >= 1.2 && < 1.3, - bar - ~~~~~~~~~~~~~~~~ - - Dependencies like `foo >= 1.2 && < 1.3` turn out to be very common - because it is recommended practise for package versions to - correspond to API versions. As of Cabal 1.6, there is a special - syntax to support this use: - - ~~~~~~~~~~~~~~~~ - build-depends: foo ==1.2.* - ~~~~~~~~~~~~~~~~ - - It is only syntactic sugar. It is exactly equivalent to `foo >= 1.2 && < 1.3`. - - Note: Prior to Cabal 1.8, build-depends specified in each section - were global to all sections. This was unintentional, but some packages - were written to depend on it, so if you need your build-depends to - be local to each section, you must specify at least - `Cabal-Version: >= 1.8` in your `.cabal` file. - -`other-modules:` _identifier list_ -: A list of modules used by the component but not exposed to users. - For a library component, these would be hidden modules of the - library. For an executable, these would be auxiliary modules to be - linked with the file named in the `main-is` field. - - Note: Every module in the package *must* be listed in one of - `other-modules`, `exposed-modules` or `main-is` fields. - -`hs-source-dirs:` _directory list_ (default: "`.`") -: Root directories for the module hierarchy. - - For backwards compatibility, the old variant `hs-source-dir` is also - recognized. - -`extensions:` _identifier list_ -: A list of Haskell extensions used by every module. Extension names - are the constructors of the [Extension][extension] type. These - determine corresponding compiler options. In particular, `CPP` specifies that - Haskell source files are to be preprocessed with a C preprocessor. - - Extensions used only by one module may be specified by placing a - `LANGUAGE` pragma in the source file affected, e.g.: - - ~~~~~~~~~~~~~~~~ - {-# LANGUAGE CPP, MultiParamTypeClasses #-} - ~~~~~~~~~~~~~~~~ - - Note: GHC versions prior to 6.6 do not support the `LANGUAGE` pragma. - -`build-tools:` _program list_ -: A list of programs, possibly annotated with versions, needed to - build this package, e.g. `c2hs >= 0.15, cpphs`.If no version - constraint is specified, any version is assumed to be acceptable. - -`buildable:` _boolean_ (default: `True`) -: Is the component buildable? Like some of the other fields below, - this field is more useful with the slightly more elaborate form of - the simple build infrastructure described in the section on - [system-dependent parameters](#system-dependent-parameters). - -`ghc-options:` _token list_ -: Additional options for GHC. You can often achieve the same effect - using the `extensions` field, which is preferred. - - Options required only by one module may be specified by placing an - `OPTIONS_GHC` pragma in the source file affected. - -`ghc-prof-options:` _token list_ -: Additional options for GHC when the package is built with profiling - enabled. - -`ghc-shared-options:` _token list_ -: Additional options for GHC when the package is built as shared library. - -`hugs-options:` _token list_ -: Additional options for Hugs. You can often achieve the same effect - using the `extensions` field, which is preferred. - - Options required only by one module may be specified by placing an - `OPTIONS_HUGS` pragma in the source file affected. - -`nhc98-options:` _token list_ -: Additional options for nhc98. You can often achieve the same effect - using the `extensions` field, which is preferred. - - Options required only by one module may be specified by placing an - `OPTIONS_NHC98` pragma in the source file affected. - -`includes:` _filename list_ -: A list of header files to be included in any compilations via C. - This field applies to both header files that are already installed - on the system and to those coming with the package to be installed. - These files typically contain function prototypes for foreign - imports used by the package. - -`install-includes:` _filename list_ -: A list of header files from this package to be installed into - `$libdir/includes` when the package is installed. Files listed in - `install-includes:` should be found in relative to the top of the - source tree or relative to one of the directories listed in - `include-dirs`. - - `install-includes` is typically used to name header files that - contain prototypes for foreign imports used in Haskell code in this - package, for which the C implementations are also provided with the - package. Note that to include them when compiling the package - itself, they need to be listed in the `includes:` field as well. - -`include-dirs:` _directory list_ -: A list of directories to search for header files, when preprocessing - with `c2hs`, `hsc2hs`, `ffihugs`, `cpphs` or the C preprocessor, and - also when compiling via C. - -`c-sources:` _filename list_ -: A list of C source files to be compiled and linked with the Haskell files. - - If you use this field, you should also name the C files in `CFILES` - pragmas in the Haskell source files that use them, e.g.: `{-# CFILES - dir/file1.c dir/file2.c #-}` These are ignored by the compilers, but - needed by Hugs. - -`extra-libraries:` _token list_ -: A list of extra libraries to link with. - -`extra-lib-dirs:` _directory list_ -: A list of directories to search for libraries. - -`cc-options:` _token list_ -: Command-line arguments to be passed to the C compiler. Since the - arguments are compiler-dependent, this field is more useful with the - setup described in the section on [system-dependent - parameters](#system-dependent-parameters). - -`ld-options:` _token list_ -: Command-line arguments to be passed to the linker. Since the - arguments are compiler-dependent, this field is more useful with the - setup described in the section on [system-dependent - parameters](#system-dependent-parameters)>. - -`pkgconfig-depends:` _package list_ -: A list of [pkg-config][] packages, needed to build this package. - They can be annotated with versions, e.g. `gtk+-2.0 >= 2.10, cairo - >= 1.0`. If no version constraint is specified, any version is - assumed to be acceptable. Cabal uses `pkg-config` to find if the - packages are available on the system and to find the extra - compilation and linker options needed to use the packages. - - If you need to bind to a C library that supports `pkg-config` (use - `pkg-config --list-all` to find out if it is supported) then it is - much preferable to use this field rather than hard code options into - the other fields. - -`frameworks:` _token list_ -: On Darwin/MacOS X, a list of frameworks to link to. See Apple's - developer documentation for more details on frameworks. This entry - is ignored on all other platforms. - -### Configurations ### - -Library and executable sections may include conditional -blocks, which test for various system parameters and -configuration flags. The flags mechanism is rather generic, -but most of the time a flag represents certain feature, that -can be switched on or off by the package user. -Here is an example package description file using -configurations: - -#### Example: A package containing a library and executable programs #### - -~~~~~~~~~~~~~~~~ -Name: Test1 -Version: 0.0.1 -Cabal-Version: >= 1.2 -License: BSD3 -Author: Jane Doe -Synopsis: Test package to test configurations -Category: Example - -Flag Debug - Description: Enable debug support - Default: False - -Flag WebFrontend - Description: Include API for web frontend. - -- Cabal checks if the configuration is possible, first - -- with this flag set to True and if not it tries with False - -Library - Build-Depends: base - Exposed-Modules: Testing.Test1 - Extensions: CPP - - if flag(debug) - GHC-Options: -DDEBUG - if !os(windows) - CC-Options: "-DDEBUG" - else - CC-Options: "-DNDEBUG" - - if flag(webfrontend) - Build-Depends: cgi > 0.42 - Other-Modules: Testing.WebStuff - -Executable test1 - Main-is: T1.hs - Other-Modules: Testing.Test1 - Build-Depends: base - - if flag(debug) - CC-Options: "-DDEBUG" - GHC-Options: -DDEBUG -~~~~~~~~~~~~~~~~ - -#### Layout #### - -Flags, conditionals, library and executable sections use layout to -indicate structure. This is very similar to the Haskell layout rule. -Entries in a section have to all be indented to the same level which -must be more than the section header. Tabs are not allowed to be used -for indentation. - -As an alternative to using layout you can also use explicit braces `{}`. -In this case the indentation of entries in a section does not matter, -though different fields within a block must be on different lines. Here -is a bit of the above example again, using braces: - -#### Example: Using explicit braces rather than indentation for layout #### - -~~~~~~~~~~~~~~~~ -Name: Test1 -Version: 0.0.1 -Cabal-Version: >= 1.2 -License: BSD3 -Author: Jane Doe -Synopsis: Test package to test configurations -Category: Example - -Flag Debug { - Description: Enable debug support - Default: False -} - -Library { - Build-Depends: base - Exposed-Modules: Testing.Test1 - Extensions: CPP - if flag(debug) { - GHC-Options: -DDEBUG - if !os(windows) { - CC-Options: "-DDEBUG" - } else { - CC-Options: "-DNDEBUG" - } - } -} -~~~~~~~~~~~~~~~~ - -#### Configuration Flags #### - -A flag section takes the flag name as an argument and may contain the -following fields. - -`description:` _freeform_ -: The description of this flag. - -`default:` _boolean_ (default: `True`) -: The default value of this flag. - - Note that this value may be [overridden in several - ways](#controlling-flag-assignments"). The rationale for having - flags default to True is that users usually want new features as - soon as they are available. Flags representing features that are not - (yet) recommended for most users (such as experimental features or - debugging support) should therefore explicitly override the default - to False. - -`manual:` _boolean_ (default: `False`) -: By default, Cabal will first try to satisfy dependencies with the - default flag value and then, if that is not possible, with the - negated value. However, if the flag is manual, then the default - value (which can be overridden by commandline flags) will be used. - -#### Conditional Blocks #### - -Conditional blocks may appear anywhere inside a library or executable -section. They have to follow rather strict formatting rules. -Conditional blocks must always be of the shape - -~~~~~~~~~~~~~~~~ - `if `_condition_ - _property-descriptions-or-conditionals*_ -~~~~~~~~~~~~~~~~ - -or - -~~~~~~~~~~~~~~~~ - `if `_condition_ - _property-descriptions-or-conditionals*_ - `else` - _property-descriptions-or-conditionals*_ -~~~~~~~~~~~~~~~~ - -Note that the `if` and the condition have to be all on the same line. - -#### Conditions #### - -Conditions can be formed using boolean tests and the boolean operators -`||` (disjunction / logical "or"), `&&` (conjunction / logical "and"), -or `!` (negation / logical "not"). The unary `!` takes highest -precedence, `||` takes lowest. Precedence levels may be overridden -through the use of parentheses. For example, `os(darwin) && !arch(i386) -|| os(freebsd)` is equivalent to `(os(darwin) && !(arch(i386))) || -os(freebsd)`. - -The following tests are currently supported. - -`os(`_name_`)` -: Tests if the current operating system is _name_. The argument is - tested against `System.Info.os` on the target system. There is - unfortunately some disagreement between Haskell implementations - about the standard values of `System.Info.os`. Cabal canonicalises - it so that in particular `os(windows)` works on all implementations. - If the canonicalised os names match, this test evaluates to true, - otherwise false. The match is case-insensitive. - -`arch(`_name_`)` -: Tests if the current architecture is _name_. The argument is - matched against `System.Info.arch` on the target system. If the arch - names match, this test evaluates to true, otherwise false. The match - is case-insensitive. - -`impl(`_compiler_`)` -: Tests for the configured Haskell implementation. An optional version - constraint may be specified (for example `impl(ghc >= 6.6.1)`). If - the configured implementation is of the right type and matches the - version constraint, then this evaluates to true, otherwise false. - The match is case-insensitive. - -`flag(`_name_`)` -: Evaluates to the current assignment of the flag of the given name. - Flag names are case insensitive. Testing for flags that have not - been introduced with a flag section is an error. - -`true` -: Constant value true. - -`false` -: Constant value false. - -#### Resolution of Conditions and Flags #### - -If a package descriptions specifies configuration flags the package user -can [control these in several ways](#controlling-flag-assignments). If -the user does not fix the value of a flag, Cabal will try to find a flag -assignment in the following way. - - * For each flag specified, it will assign its default value, evaluate - all conditions with this flag assignment, and check if all - dependencies can be satisfied. If this check succeeded, the package - will be configured with those flag assignments. - - * If dependencies were missing, the last flag (as by the order in - which the flags were introduced in the package description) is tried - with its alternative value and so on. This continues until either - an assignment is found where all dependencies can be satisfied, or - all possible flag assignments have been tried. - -To put it another way, Cabal does a complete backtracking search to find -a satisfiable package configuration. It is only the dependencies -specified in the `build-depends` field in conditional blocks that -determine if a particular flag assignment is satisfiable (`build-tools` -are not considered). The order of the declaration and the default value -of the flags determines the search order. Flags overridden on the -command line fix the assignment of that flag, so no backtracking will be -tried for that flag. - -If no suitable flag assignment could be found, the configuration phase -will fail and a list of missing dependencies will be printed. Note that -this resolution process is exponential in the worst case (i.e., in the -case where dependencies cannot be satisfied). There are some -optimizations applied internally, but the overall complexity remains -unchanged. - -### Meaning of field values when using conditionals ### - -During the configuration phase, a flag assignment is chosen, all -conditionals are evaluated, and the package description is combined into -a flat package descriptions. If the same field both inside a conditional -and outside then they are combined using the following rules. - - - * Boolean fields are combined using conjunction (logical "and"). - - * List fields are combined by appending the inner items to the outer - items, for example - - ~~~~~~~~~~~~~~~~ - Extensions: CPP - if impl(ghc) || impl(hugs) - Extensions: MultiParamTypeClasses - ~~~~~~~~~~~~~~~~ - - when compiled using Hugs or GHC will be combined to - - ~~~~~~~~~~~~~~~~ - Extensions: CPP, MultiParamTypeClasses - ~~~~~~~~~~~~~~~~ - - Similarly, if two conditional sections appear at the same nesting - level, properties specified in the latter will come after properties - specified in the former. - - * All other fields must not be specified in ambiguous ways. For - example - - ~~~~~~~~~~~~~~~~ - Main-is: Main.hs - if flag(useothermain) - Main-is: OtherMain.hs - ~~~~~~~~~~~~~~~~ - - will lead to an error. Instead use - - ~~~~~~~~~~~~~~~~ - if flag(useothermain) - Main-is: OtherMain.hs - else - Main-is: Main.hs - ~~~~~~~~~~~~~~~~ - -### Source Repositories ### - -It is often useful to be able to specify a source revision control -repository for a package. Cabal lets you specifying this information in -a relatively structured form which enables other tools to interpret and -make effective use of the information. For example the information -should be sufficient for an automatic tool to checkout the sources. - -Cabal supports specifying different information for various common -source control systems. Obviously not all automated tools will support -all source control systems. - -Cabal supports specifying repositories for different use cases. By -declaring which case we mean automated tools can be more useful. There -are currently two kinds defined: - - * The `head` kind refers to the latest development branch of the - package. This may be used for example to track activity of a project - or as an indication to outside developers what sources to get for - making new contributions. - - * The `this` kind refers to the branch and tag of a repository that - contains the sources for this version or release of a package. For most - source control systems this involves specifying a tag, id or hash of - some form and perhaps a branch. The purpose is to be able to - reconstruct the sources corresponding to a particular package - version. This might be used to indicate what sources to get if - someone needs to fix a bug in an older branch that is no longer an - active head branch. - -You can specify one kind or the other or both. As an example here are -the repositories for the Cabal library. Note that the `this` kind of -repo specifies a tag. - -~~~~~~~~~~~~~~~~ -source-repository head - type: darcs - location: http://darcs.haskell.org/cabal/ - -source-repository this - type: darcs - location: http://darcs.haskell.org/cabal-branches/cabal-1.6/ - tag: 1.6.1 -~~~~~~~~~~~~~~~~ - -The exact fields are as follows: - -`type:` _token_ -: The name of the source control system used for this repository. The - currently recognised types are: - - * `darcs` - * `git` - * `svn` - * `cvs` - * `mercurial` (or alias `hg`) - * `bazaar` (or alias `bzr`) - * `arch` - * `monotone` - - This field is required. - -`location:` _URL_ -: The location of the repository. The exact form of this field depends - on the repository type. For example: - - * for darcs: `http://code.haskell.org/foo/` - * for git: `git://github.com/foo/bar.git` - * for CVS: `anoncvs@cvs.foo.org:/cvs` - - This field is required. - -`module:` _token_ -: CVS requires a named module, as each CVS server can host multiple - named repositories. - - This field is required for the CVS repo type and should not be used - otherwise. - -`branch:` _token_ -: Many source control systems support the notion of a branch, as a - distinct concept from having repositories in separate locations. For - example CVS, SVN and git use branches while for darcs uses different - locations for different branches. If you need to specify a branch to - identify a your repository then specify it in this field. - - This field is optional. - -`tag:` _token_ -: A tag identifies a particular state of a source repository. The tag - can be used with a `this` repo kind to identify the state of a repo - corresponding to a particular package version or release. The exact - form of the tag depends on the repository type. - - This field is required for the `this` repo kind. - -`subdir:` _directory_ -: Some projects put the sources for multiple packages under a single - source repository. This field lets you specify the relative path - from the root of the repository to the top directory for the - package, ie the directory containing the package's `.cabal` file. - - This field is optional. It default to empty which corresponds to the - root directory of the repository. - -## Accessing data files from package code ## - -The placement on the target system of files listed in the `data-files` -field varies between systems, and in some cases one can even move -packages around after installation (see [prefix -independence](#prefix-independence)). To enable packages to find these -files in a portable way, Cabal generates a module called -`Paths_`_pkgname_ (with any hyphens in _pkgname_ replaced by -underscores) during building, so that it may be imported by modules of -the package. This module defines a function - -~~~~~~~~~~~~~~~ -getDataFileName :: FilePath -> IO FilePath -~~~~~~~~~~~~~~~ - -If the argument is a filename listed in the `data-files` field, the -result is the name of the corresponding file on the system on which the -program is running. - -Note: If you decide to import the `Paths_`_pkgname_ module then it -*must* be listed in the `other-modules` field just like any other module -in your package. - -The `Paths_`_pkgname_ module is not platform independent so it does not -get included in the source tarballs generated by `sdist`. - -## System-dependent parameters ## - -For some packages, especially those interfacing with C libraries, -implementation details and the build procedure depend on the build -environment. A variant of the simple build infrastructure (the -`build-type` `Configure`) handles many such situations using a slightly -longer `Setup.hs`: - -~~~~~~~~~~~~~~~~ -import Distribution.Simple -main = defaultMainWithHooks autoconfUserHooks -~~~~~~~~~~~~~~~~ - -Most packages, however, would probably do better with -[configurations](#configurations). - -This program differs from `defaultMain` in two ways: - -* The package root directory must contain a shell script called - `configure`. The configure step will run the script. This `configure` - script may be produced by [autoconf][] or may be hand-written. The - `configure` script typically discovers information about the system - and records it for later steps, e.g. by generating system-dependent - header files for inclusion in C source files and preprocessed Haskell - source files. (Clearly this won't work for Windows without MSYS or - Cygwin: other ideas are needed.) - -* If the package root directory contains a file called - _package_`.buildinfo` after the configuration step, subsequent steps - will read it to obtain additional settings for [build - information](#build-information) fields,to be merged with the ones - given in the `.cabal` file. In particular, this file may be generated - by the `configure` script mentioned above, allowing these settings to - vary depending on the build environment. - - The build information file should have the following structure: - - > _buildinfo_ - > - > `executable:` _name_ - > _buildinfo_ - > - > `executable:` _name_ - > _buildinfo_ - > ... - - where each _buildinfo_ consists of settings of fields listed in the - section on [build information](#build-information). The first one (if - present) relates to the library, while each of the others relate to - the named executable. (The names must match the package description, - but you don't have to have entries for all of them.) - -Neither of these files is required. If they are absent, this setup -script is equivalent to `defaultMain`. - -#### Example: Using autoconf #### - -This example is for people familiar with the [autoconf][] tools. - -In the X11 package, the file `configure.ac` contains: - -~~~~~~~~~~~~~~~~ -AC_INIT([Haskell X11 package], [1.1], [libraries@haskell.org], [X11]) - -# Safety check: Ensure that we are in the correct source directory. -AC_CONFIG_SRCDIR([X11.cabal]) - -# Header file to place defines in -AC_CONFIG_HEADERS([include/HsX11Config.h]) - -# Check for X11 include paths and libraries -AC_PATH_XTRA -AC_TRY_CPP([#include ],,[no_x=yes]) - -# Build the package if we found X11 stuff -if test "$no_x" = yes -then BUILD_PACKAGE_BOOL=False -else BUILD_PACKAGE_BOOL=True -fi -AC_SUBST([BUILD_PACKAGE_BOOL]) - -AC_CONFIG_FILES([X11.buildinfo]) -AC_OUTPUT -~~~~~~~~~~~~~~~~ - -Then the setup script will run the `configure` script, which checks for -the presence of the X11 libraries and substitutes for variables in the -file `X11.buildinfo.in`: - -~~~~~~~~~~~~~~~~ -buildable: @BUILD_PACKAGE_BOOL@ -cc-options: @X_CFLAGS@ -ld-options: @X_LIBS@ -~~~~~~~~~~~~~~~~ - -This generates a file `X11.buildinfo` supplying the parameters needed by -later stages: - -~~~~~~~~~~~~~~~~ -buildable: True -cc-options: -I/usr/X11R6/include -ld-options: -L/usr/X11R6/lib -~~~~~~~~~~~~~~~~ - -The `configure` script also generates a header file -`include/HsX11Config.h` containing C preprocessor defines recording the -results of various tests. This file may be included by C source files -and preprocessed Haskell source files in the package. - -Note: Packages using these features will also need to list -additional files such as `configure`, -templates for `.buildinfo` files, files named -only in `.buildinfo` files, header files and -so on in the `extra-source-files` field, -to ensure that they are included in source distributions. -They should also list files and directories generated by -`configure` in the -`extra-tmp-files` field to ensure that they -are removed by `setup clean`. - -## Conditional compilation ## - -Sometimes you want to write code that works with more than one version -of a dependency. You can specify a range of versions for the depenency -in the `build-depends`, but how do you then write the code that can use -different versions of the API? - -Haskell lets you preprocess your code using the C preprocessor (either -the real C preprocessor, or `cpphs`). To enable this, add `extensions: -CPP` to your package description. When using CPP, Cabal provides some -pre-defined macros to let you test the version of dependent packages; -for example, suppose your package works with either version 3 or version -4 of the `base` package, you could select the available version in your -Haskell modules like this: - -~~~~~~~~~~~~~~~~ -#if MIN_VERSION_base(4,0,0) -... code that works with base-4 ... -#else -... code that works with base-3 ... -#endif -~~~~~~~~~~~~~~~~ - -In general, Cabal supplies a macro `MIN_VERSION_`_`package`_`_(A,B,C)` -for each package depended on via `build-depends`. This macro is true if -the actual version of the package in use is greater than or equal to -`A.B.C` (using the conventional ordering on version numbers, which is -lexicographic on the sequence, but numeric on each component, so for -example 1.2.0 is greater than 1.0.3). - -Cabal places the definitions of these macros into an -automatically-generated header file, which is included when -preprocessing Haskell source code by passing options to the C -preprocessor. - -## More complex packages ## - -For packages that don't fit the simple schemes described above, you have -a few options: - - * You can customize the simple build infrastructure using _hooks_. - These allow you to perform additional actions before and after each - command is run, and also to specify additional preprocessors. See - `UserHooks` in [Distribution.Simple][dist-simple] for the details, - but note that this interface is experimental, and likely to change - in future releases. - - * You could delegate all the work to `make`, though this is unlikely - to be very portable. Cabal supports this with the `build-type` - `Make` and a trivial setup library [Distribution.Make][dist-make], - which simply parses the command line arguments and invokes `make`. - Here `Setup.hs` looks like - - ~~~~~~~~~~~~~~~~ - import Distribution.Make - main = defaultMain - ~~~~~~~~~~~~~~~~ - - The root directory of the package should contain a `configure` - script, and, after that has run, a `Makefile` with a default target - that builds the package, plus targets `install`, `register`, - `unregister`, `clean`, `dist` and `docs`. Some options to commands - are passed through as follows: - - * The `--with-hc-pkg`, `--prefix`, `--bindir`, `--libdir`, - `--datadir` and `--libexecdir` options to the `configure` - command are passed on to the `configure` script. In addition the - value of the `--with-compiler` option is passed in a `--with-hc` - option and all options specified with `--configure-option=` are - passed on. - - * The `--destdir` option to the `copy` command becomes a setting - of a `destdir` variable on the invocation of `make copy`. The - supplied `Makefile` should provide a `copy` target, which will - probably look like this: - - ~~~~~~~~~~~~~~~~ - copy : - $(MAKE) install prefix=$(destdir)/$(prefix) \ - bindir=$(destdir)/$(bindir) \ - libdir=$(destdir)/$(libdir) \ - datadir=$(destdir)/$(datadir) \ - libexecdir=$(destdir)/$(libexecdir) - ~~~~~~~~~~~~~~~~ - - * You can write your own setup script conforming to the interface - described in the section on [building and installing - packages](#building-and-installing-a-package), possibly using the - Cabal library for part of the work. One option is to copy the - source of `Distribution.Simple`, and alter it for your needs. - Good luck. - -# Building and installing a package # - -After you've unpacked a Cabal package, you can build it by moving into -the root directory of the package and using the `Setup.hs` or -`Setup.lhs` script there: - -> `_runhaskell_ Setup.hs` [_command_] [_option_...] - -The _command_ argument selects a particular step in the build/install -process. You can also get a summary of the command syntax with - -> `runhaskell Setup.hs --help` - -## Building and installing a system package ## - -~~~~~~~~~~~~~~~~ -runhaskell Setup.hs configure --ghc -runhaskell Setup.hs build -runhaskell Setup.hs install -~~~~~~~~~~~~~~~~ - -The first line readies the system to build the tool using GHC; for -example, it checks that GHC exists on the system. The second line -performs the actual building, while the last both copies the build -results to some permanent place and registers the package with GHC. - -## Building and installing a user package ## - -~~~~~~~~~~~~~~~~ -runhaskell Setup.hs configure --user -runhaskell Setup.hs build -runhaskell Setup.hs install -~~~~~~~~~~~~~~~~ - -The package is installed under the user's home directory and is -registered in the user's package database (`--user`). - -## Creating a binary package ## - -When creating binary packages (e.g. for RedHat or Debian) one needs to -create a tarball that can be sent to another system for unpacking in the -root directory: - -~~~~~~~~~~~~~~~~ -runhaskell Setup.hs configure --prefix=/usr -runhaskell Setup.hs build -runhaskell Setup.hs copy --destdir=/tmp/mypkg -tar -czf mypkg.tar.gz /tmp/mypkg/ -~~~~~~~~~~~~~~~~ - -If the package contains a library, you need two additional steps: - -~~~~~~~~~~~~~~~~ -runhaskell Setup.hs register --gen-script -runhaskell Setup.hs unregister --gen-script -~~~~~~~~~~~~~~~~ - -This creates shell scripts `register.sh` and `unregister.sh`, which must -also be sent to the target system. After unpacking there, the package -must be registered by running the `register.sh` script. The -`unregister.sh` script would be used in the uninstall procedure of the -package. Similar steps may be used for creating binary packages for -Windows. - - -The following options are understood by all commands: - -`--help`, `-h` or `-?` -: List the available options for the command. - -`--verbose=`_n_ or `-v`_n_ -: Set the verbosity level (0-3). The normal level is 1; a missing _n_ - defaults to 2. - -The various commands and the additional options they support are -described below. In the simple build infrastructure, any other options -will be reported as errors. - -## setup configure ## - -Prepare to build the package. Typically, this step checks that the -target platform is capable of building the package, and discovers -platform-specific features that are needed during the build. - -The user may also adjust the behaviour of later stages using the options -listed in the following subsections. In the simple build -infrastructure, the values supplied via these options are recorded in a -private file read by later stages. - -If a user-supplied `configure` script is run (see the section on -[system-dependent parameters](#system-dependent-parameters) or on -[complex packages](#complex-packages)), it is passed the -`--with-hc-pkg`, `--prefix`, `--bindir`, `--libdir`, `--datadir` and -`--libexecdir` options. In addition the value of the `--with-compiler` -option is passed in a `--with-hc` option and all options specified with -`--configure-option=` are passed on. - -### Programs used for building ### - -The following options govern the programs used to process the source -files of a package: - -`--ghc` or `-g`, `--nhc`, `--jhc`, `--hugs` -: Specify which Haskell implementation to use to build the package. - At most one of these flags may be given. If none is given, the - implementation under which the setup script was compiled or - interpreted is used. - -`--with-compiler=`_path_ or `-w`_path_ -: Specify the path to a particular compiler. If given, this must match - the implementation selected above. The default is to search for the - usual name of the selected implementation. - - This flag also sets the default value of the `--with-hc-pkg` option - to the package tool for this compiler. Check the output of `setup - configure -v` to ensure that it finds the right package tool (or use - `--with-hc-pkg` explicitly). - - -`--with-hc-pkg=`_path_ -: Specify the path to the package tool, e.g. `ghc-pkg`. The package - tool must be compatible with the compiler specified by - `--with-compiler`. If this option is omitted, the default value is - determined from the compiler selected. - -`--with-`_`prog`_`=`_path_ -: Specify the path to the program _prog_. Any program known to Cabal - can be used in place of _prog_. It can either be a fully path or the - name of a program that can be found on the program search path. For - example: `--with-ghc=ghc-6.6.1` or - `--with-cpphs=/usr/local/bin/cpphs`. - -`--`_`prog`_`-options=`_options_ -: Specify additional options to the program _prog_. Any program known - to Cabal can be used in place of _prog_. For example: - `--alex-options="--template=mytemplatedir/"`. The _options_ is split - into program options based on spaces. Any options containing embeded - spaced need to be quoted, for example - `--foo-options='--bar="C:\Program File\Bar"'`. As an alternative - that takes only one option at a time but avoids the need to quote, - use `--`_`prog`_`-option` instead. - -`--`_`prog`_`-option=`_option_ -: Specify a single additional option to the program _prog_. For - passing an option that contain embeded spaces, such as a file name - with embeded spaces, using this rather than `--`_`prog`_`-options` - means you do not need an additional level of quoting. Of course if - you are using a command shell you may still need to quote, for - example `--foo-options="--bar=C:\Program File\Bar"`. - -All of the options passed with either `--`_`prog`_`-options` or -`--`_`prog`_`-option` are passed in the order they were specified on the -configure command line. - -### Installation paths ### - -The following options govern the location of installed files from a -package: - -`--prefix=`_dir_ -: The root of the installation. For example for a global install you - might use `/usr/local` on a Unix system, or `C:\Program Files` on a - Windows system. The other installation paths are usually - subdirectories of _prefix_, but they don't have to be. - - In the simple build system, _dir_ may contain the following path - variables: `$pkgid`, `$pkg`, `$version`, `$compiler`, `$os`, - `$arch` - -`--bindir=`_dir_ -: Executables that the user might invoke are installed here. - - In the simple build system, _dir_ may contain the following path - variables: `$prefix`, `$pkgid`, `$pkg`, `$version`, `$compiler`, - `$os`, `$arch` - -`--libdir=`_dir_ -: Object-code libraries are installed here. - - In the simple build system, _dir_ may contain the following path - variables: `$prefix`, `$bindir`, `$pkgid`, `$pkg`, `$version`, - `$compiler`, `$os`, `$arch` - -`--libexecdir=`_dir_ -: Executables that are not expected to be invoked directly by the user - are installed here. - - In the simple build system, _dir_ may contain the following path - variables: `$prefix`, `$bindir`, `$libdir`, `$libsubdir`, `$pkgid`, - `$pkg`, `$version`, `$compiler`, `$os`, `$arch` - -`--datadir`=_dir_ -: Architecture-independent data files are installed here. - - In the simple build system, _dir_ may contain the following path - variables: `$prefix`, `$bindir`, `$libdir`, `$libsubdir`, `$pkgid`, `$pkg`, - `$version`, `$compiler`, `$os`, `$arch` - -In addition the simple build system supports the following installation path options: - -`--libsubdir=`_dir_ -: A subdirectory of _libdir_ in which libraries are actually - installed. For example, in the simple build system on Unix, the - default _libdir_ is `/usr/local/lib`, and _libsubdir_ contains the - package identifier and compiler, e.g. `mypkg-0.2/ghc-6.4`, so - libraries would be installed in `/usr/local/lib/mypkg-0.2/ghc-6.4`. - - _dir_ may contain the following path variables: `$pkgid`, `$pkg`, - `$version`, `$compiler`, `$os`, `$arch` - -`--datasubdir=`_dir_ -: A subdirectory of _datadir_ in which data files are actually - installed. - - _dir_ may contain the following path variables: `$pkgid`, `$pkg`, - `$version`, `$compiler`, `$os`, `$arch` - -`--docdir=`_dir_ -: Documentation files are installed relative to this directory. - - _dir_ may contain the following path variables: `$prefix`, `$bindir`, - `$libdir`, `$libsubdir`, `$datadir`, `$datasubdir`, `$pkgid`, `$pkg`, - `$version`, `$compiler`, `$os`, `$arch` - -`--htmldir=`_dir_ -: HTML documentation files are installed relative to this directory. - - _dir_ may contain the following path variables: `$prefix`, `$bindir`, - `$libdir`, `$libsubdir`, `$datadir`, `$datasubdir`, `$docdir`, `$pkgid`, - `$pkg`, `$version`, `$compiler`, `$os`, `$arch` - -`--program-prefix=`_prefix_ -: Prepend _prefix_ to installed program names. - - _prefix_ may contain the following path variables: `$pkgid`, `$pkg`, - `$version`, `$compiler`, `$os`, `$arch` - -`--program-suffix=`_suffix_ -: Append _suffix_ to installed program names. The most obvious use for - this is to append the program's version number to make it possible - to install several versions of a program at once: - `--program-suffix='$version'`. - - _suffix_ may contain the following path variables: `$pkgid`, `$pkg`, - `$version`, `$compiler`, `$os`, `$arch` - -#### Path variables in the simple build system #### - -For the simple build system, there are a number of variables that can be -used when specifying installation paths. The defaults are also specified -in terms of these variables. A number of the variables are actually for -other paths, like `$prefix`. This allows paths to be specified relative -to each other rather than as absolute paths, which is important for -building relocatable packages (see [prefix -independence](#prefix-independence)). - -`$prefix` -: The path variable that stands for the root of the installation. For - an installation to be relocatable, all other instllation paths must - be relative to the `$prefix` variable. - -`$bindir` -: The path variable that expands to the path given by the `--bindir` - configure option (or the default). - -`$libdir` -: As above but for `--libdir` - -`$libsubdir` -: As above but for `--libsubdir` - -`$datadir` -: As above but for `--datadir` - -`$datasubdir` -: As above but for `--datasubdir` - -`$docdir` -: As above but for `--docdir` - -`$pkgid` -: The name and version of the package, eg `mypkg-0.2` - -`$pkg` -: The name of the package, eg `mypkg` - -`$version` -: The version of the package, eg `0.2` - -`$compiler` -: The compiler being used to build the package, eg `ghc-6.6.1` - -`$os` -: The operating system of the computer being used to build the - package, eg `linux`, `windows`, `osx`, `freebsd` or `solaris` - -`$arch` -: The architecture of the computer being used to build the package, eg - `i386`, `x86_64`, `ppc` or `sparc` - -#### Paths in the simple build system #### - -For the simple build system, the following defaults apply: - -Option Windows Default Unix Default -------- ---------------- ------------- -`--prefix` (global) `C:\Program Files\Haskell` `/usr/local` -`--prefix` (per-user) `C:\Documents And Settings\user\Application Data\cabal` `$HOME/.cabal` -`--bindir` `$prefix\bin` `$prefix/bin` -`--libdir` `$prefix` `$prefix/lib` -`--libsubdir` (Hugs) `hugs\packages\$pkg` `hugs/packages/$pkg` -`--libsubdir` (others) `$pkgid\$compiler` `$pkgid/$compiler` -`--libexecdir` `$prefix\$pkgid` `$prefix/libexec` -`--datadir` (executable) `$prefix` `$prefix/share` -`--datadir` (library) `C:\Program Files\Haskell` `$prefix/share` -`--datasubdir` `$pkgid` `$pkgid` -`--docdir` `$prefix\doc\$pkgid` `$datadir/doc/$pkgid` -`--htmldir` `$docdir\html` `$docdir/html` -`--program-prefix` (empty) (empty) -`--program-suffix` (empty) (empty) - - -#### Prefix-independence #### - -On Windows, and when using Hugs on any system, it is possible to obtain -the pathname of the running program. This means that we can construct an -installable executable package that is independent of its absolute -install location. The executable can find its auxiliary files by finding -its own path and knowing the location of the other files relative to -`$bindir`. Prefix-independence is particularly -useful: it means the user can choose the install location (i.e. the -value of `$prefix`) at install-time, rather than -having to bake the path into the binary when it is built. - -In order to achieve this, we require that for an executable on Windows, -all of `$bindir`, `$libdir`, `$datadir` and `$libexecdir` begin with -`$prefix`. If this is not the case then the compiled executable will -have baked-in all absolute paths. - -The application need do nothing special to achieve prefix-independence. -If it finds any files using `getDataFileName` and the [other functions -provided for the purpose](#accessing-data-files-from-package-code), the -files will be accessed relative to the location of the current -executable. - -A library cannot (currently) be prefix-independent, because it will be -linked into an executable whose file system location bears no relation -to the library package. - -### Controlling Flag Assignments ### - -Flag assignments (see the [resolution of conditions and -flags](#resolution-of-conditions-and-flags)) can be controlled with the -followingcommand line options. - -`-f` _flagname_ or `-f` `-`_flagname_ -: Force the specified flag to `true` or `false` (if preceded with a `-`). Later - specifications for the same flags will override earlier, i.e., - specifying `-fdebug -f-debug` is equivalent to `-f-debug` - -`--flags=`_flagspecs_ -: Same as `-f`, but allows specifying multiple flag assignments at - once. The parameter is a space-separated list of flag names (to - force a flag to `true`), optionally preceded by a `-` (to force a - flag to `false`). For example, `--flags="debug -feature1 feature2"` is - equivalent to `-fdebug -f-feature1 -ffeature2`. - -### Building Test Suites ### - -`--enable-tests` -: Build the test suites defined in the package description file during the - `build` stage. Check for dependencies required by the test suites. If the - package is configured with this option, it will be possible to run the test - suites with the `test` command after the package is built. - -`--disable-tests` -: (default) Do not build any test suites during the `build` stage. - Do not check for dependencies required only by the test suites. It will not - be possible to invoke the `test` command without reconfiguring the package. - -### Miscellaneous options ## - -`--user` -: Does a per-user installation. This changes the [default installation - prefix](#paths-in-the-simple-build-system). It also allow - dependencies to be satisfied by the user's package database, in - addition to the global database. This also implies a default of - `--user` for any subsequent `install` command, as packages - registered in the global database should not depend on packages - registered in a user's database. - -`--global` -: (default) Does a global installation. In this case package - dependencies must be satisfied by the global package database. All - packages in the user's package database will be ignored. Typically - the final instllation step will require administrative privileges. - -`--package-db=`_db_ -: Allows package dependencies to be satisfied from this additional - package database _db_ in addition to the global package database. - All packages in the user's package database will be ignored. The - interpretation of _db_ is implementation-specific. Typically it will - be a file or directory. Not all implementations support arbitrary - package databases. - -`--enable-optimization`[=_n_] or `-O`[_n_] -: (default) Build with optimization flags (if available). This is - appropriate for production use, taking more time to build faster - libraries and programs. - - The optional _n_ value is the optimisation level. Some compilers - support multiple optimisation levels. The range is 0 to 2. Level 0 - is equivalent to `--disable-optimization`, level 1 is the default if - no _n_ parameter is given. Level 2 is higher optimisation if the - compiler supports it. Level 2 is likely to lead to longer compile - times and bigger generated code. - -`--disable-optimization` -: Build without optimization. This is suited for development: building - will be quicker, but the resulting library or programs will be slower. - -`--enable-library-profiling` or `-p` -: Request that an additional version of the library with profiling - features enabled be built and installed (only for implementations - that support profiling). - -`--disable-library-profiling` -: (default) Do not generate an additional profiling version of the - library. - -`--enable-executable-profiling` -: Any executables generated should have profiling enabled (only for - implementations that support profiling). For this to work, all - libraries used by these executables must also have been built with - profiling support. - -`--disable-executable-profiling` -: (default) Do not enable profiling in generated executables. - -`--enable-library-vanilla` -: (default) Build ordinary libraries (as opposed to profiling - libraries). This is independent of the `--enable-library-profiling` - option. If you enable both, you get both. - -`--disable-library-vanilla` -: Do not build ordinary libraries. This is useful in conjunction with - `--enable-library-profiling` to build only profiling libraries, - rather than profiling and ordinary libraries. - -`--enable-library-for-ghci` -: (default) Build libraries suitable for use with GHCi. - -`--disable-library-for-ghci` -: Not all platforms support GHCi and indeed on some platforms, trying - to build GHCi libs fails. In such cases this flag can be used as a - workaround. - -`--enable-split-objs` -: Use the GHC `-split-objs` feature when building the library. This - reduces the final size of the executables that use the library by - allowing them to link with only the bits that they use rather than - the entire library. The downside is that building the library takes - longer and uses considerably more memory. - -`--disable-split-objs` -: (default) Do not use the GHC `-split-objs` feature. This makes - building the library quicker but the final executables that use the - library will be larger. - -`--enable-executable-stripping` -: (default) When installing binary executable programs, run the - `strip` program on the binary. This can considerably reduce the size - of the executable binary file. It does this by removing debugging - information and symbols. While such extra information is useful for - debugging C programs with traditional debuggers it is rarely helpful - for debugging binaries produced by Haskell compilers. - - Not all Haskell implementations generate native binaries. For such - implementations this option has no effect. - -`--disable-executable-stripping` -: Do not strip binary executables during installation. You might want - to use this option if you need to debug a program using gdb, for - example if you want to debug the C parts of a program containing - both Haskell and C code. Another reason is if your are building a - package for a system which has a policy of managing the stripping - itself (such as some linux distributions). - -`--enable-shared` -: Build shared library. This implies a seperate compiler run to - generate position independent code as required on most platforms. - -`--disable-shared` -: (default) Do not build shared library. - -`--configure-option=`_str_ -: An extra option to an external `configure` script, if one is used - (see the section on [system-dependent - parameters](#system-dependent-parameters)). There can be several of - these options. - -`--extra-include-dirs`[=_dir_] -: An extra directory to search for C header files. You can use this - flag multiple times to get a list of directories. - - You might need to use this flag if you have standard system header - files in a non-standard location that is not mentioned in the - package's `.cabal` file. Using this option has the same affect as - appending the directory _dir_ to the `include-dirs` field in each - library and executable in the package's `.cabal` file. The advantage - of course is that you do not have to modify the package at all. - These extra directories will be used while building the package and - for libraries it is also saved in the package registration - information and used when compiling modules that use the library. - -`--extra-lib-dirs`[=_dir_] -: An extra directory to search for system libraries files. You can use - this flag multiple times to get a list of directories. - - You might need to use this flag if you have standard system - libraries in a non-standard location that is not mentioned in the - package's `.cabal` file. Using this option has the same affect as - appending the directory _dir_ to the `extra-lib-dirs` field in each - library and executable in the package's `.cabal` file. The advantage - of course is that you do not have to modify the package at all. - These extra directories will be used while building the package and - for libraries it is also saved in the package registration - information and used when compiling modules that use the library. - -In the simple build infrastructure, an additional option is recognized: - -`--scratchdir=`_dir_ -: Specify the directory into which the Hugs output will be placed - (default: `dist/scratch`). - -## setup build ## - -Perform any preprocessing or compilation needed to make this package ready for installation. - -This command takes the following options: - ---_prog_-options=_options_, --_prog_-option=_option_ -: These are mostly the same as the [options configure - step](#setup-configure). Unlike the options specified at the - configure step, any program options specified at the build step are - not persistent but are used for that invocation only. They options - specified at the build step are in addition not in replacement of - any options specified at the configure step. - -## setup haddock ## - -Build the documentation for the package using [haddock][]. By default, -only the documentation for the exposed modules is generated (but see the -`--executables` and `--internal` flags below). - -This command takes the following options: - -`--hoogle` -: Generate a file `dist/doc/html/`_pkgid_`.txt`, which can be - converted by [Hoogle](http://www.haskell.org/hoogle/) into a - database for searching. This is equivalent to running [haddock][] - with the `--hoogle` flag. - -`--html-location=`_url_ -: Specify a template for the location of HTML documentation for - prerequisite packages. The substitutions ([see - listing](#paths-in-the-simple-build-system)) are applied to the - template to obtain a location for each package, which will be used - by hyperlinks in the generated documentation. For example, the - following command generates links pointing at [HackageDB][] pages: - - > setup haddock --html-location='http://hackage.haskell.org/packages/archive/$pkg/latest/doc/html' - - Here the argument is quoted to prevent substitution by the shell. If - this option is omitted, the location for each package is obtained - using the package tool (e.g. `ghc-pkg`). - -`--executables` -: Also run [haddock][] for the modules of all the executable programs. - By default [haddock][] is run only on the exported modules. - -`--internal` -: Run [haddock][] for the all modules, including unexposed ones, and - make [haddock][] generate documentation for unexported symbols as - well. - -`--css=`_path_ -: The argument _path_ denotes a CSS file, which is passed to - [haddock][] and used to set the style of the generated - documentation. This is only needed to override the default style - that [haddock][] uses. - -`--hyperlink-source` -: Generate [haddock][] documentation integrated with [HsColour][]. - First, [HsColour][] is run to generate colourised code. Then - [haddock][] is run to generate HTML documentation. Each entity - shown in the documentation is linked to its definition in the - colourised code. - -`--hscolour-css=`_path_ -: The argument _path_ denotes a CSS file, which is passed to [HsColour][] as in - - > runhaskell Setup.hs hscolour --css=_path_ - -## setup hscolour ## - -Produce colourised code in HTML format using [HsColour][]. Colourised -code for exported modules is put in `dist/doc/html/`_pkgid_`/src`. - -This command takes the following options: - -`--executables` -: Also run [HsColour][] on the sources of all executable programs. - Colourised code is put in `dist/doc/html/`_pkgid_/_executable_`/src`. - -`--css=`_path_ -: Use the given CSS file for the generated HTML files. The CSS file - defines the colours used to colourise code. Note that this copies - the given CSS file to the directory with the generated HTML files - (renamed to `hscolour.css`) rather than linking to it. - -## setup install ## - -Copy the files into the install locations and (for library packages) -register the package with the compiler, i.e. make the modules it -contains available to programs. - -The [install locations](#installation-paths) are determined by options -to `setup configure`. - -This command takes the following options: - -`--global` -: Register this package in the system-wide database. (This is the - default, unless the `--user` option was supplied to the `configure` - command.) - -`--user` -: Register this package in the user's local package database. (This is - the default if the `--user` option was supplied to the `configure` - command.) - -## setup copy ## - -Copy the files without registering them. This command is mainly of use -to those creating binary packages. - -This command takes the following option: - -`--destdir=`_path_ - -Specify the directory under which to place installed files. If this is -not given, then the root directory is assumed. - -## setup register ## - -Register this package with the compiler, i.e. make the modules it -contains available to programs. This only makes sense for library -packages. Note that the `install` command incorporates this action. The -main use of this separate command is in the post-installation step for a -binary package. - -This command takes the following options: - -`--global` -: Register this package in the system-wide database. (This is the default.) - - -`--user` -: Register this package in the user's local package database. - - -`--gen-script` -: Instead of registering the package, generate a script containing - commands to perform the registration. On Unix, this file is called - `register.sh`, on Windows, `register.bat`. This script might be - included in a binary bundle, to be run after the bundle is unpacked - on the target system. - -`--gen-pkg-config`[=_path_] -: Instead of registering the package, generate a package registration - file. This only applies to compilers that support package - registration files which at the moment is only GHC. The file should - be used with the compiler's mechanism for registering packages. This - option is mainly intended for packaging systems. If possible use the - `--gen-script` option instead since it is more portable across - Haskell implementations. The _path_ is - optional and can be used to specify a particular output file to - generate. Otherwise, by default the file is the package name and - version with a `.conf` extension. - -`--inplace` -: Registers the package for use directly from the build tree, without - needing to install it. This can be useful for testing: there's no - need to install the package after modifying it, just recompile and - test. - - This flag does not create a build-tree-local package database. It - still registers the package in one of the user or global databases. - - However, there are some caveats. It only works with GHC - (currently). It only works if your package doesn't depend on having - any supplemental files installed --- plain Haskell libraries should - be fine. - -## setup unregister ## - -Deregister this package with the compiler. - -This command takes the following options: - -`--global` -: Deregister this package in the system-wide database. (This is the default.) - -`--user` -: Deregister this package in the user's local package database. - -`--gen-script` -: Instead of deregistering the package, generate a script containing - commands to perform the deregistration. On Unix, this file is - called `unregister.sh`, on Windows, `unregister.bat`. This script - might be included in a binary bundle, to be run on the target - system. - -## setup clean ## - -Remove any local files created during the `configure`, `build`, -`haddock`, `register` or `unregister` steps, and also any files and -directories listed in the `extra-tmp-files` field. - -This command takes the following options: - -`--save-configure` or `-s` -: Keeps the configuration information so it is not necessary to run - the configure step again before building. - -## setup test ## - -Run the test suites specified in the package description file. Aside from -the following flags, Cabal accepts the name of one or more test suites on the -command line after `test`. When supplied, Cabal will run only the named test -suites, otherwise, Cabal will run all test suites in the package. - -`--builddir=`_dir_ -: The directory where Cabal puts generated build files (default: `dist`). - Test logs will be located in the `test` subdirectory. - -`--human-log=`_path_ -: The template used to name human-readable test logs; the path is relative - to `dist/test`. By default, logs are named according to the template - `$pkgid-$test-suite.log`, so that each test suite will be logged to its own - human-readable log file. Template variables allowed are: `$pkgid`, - `$compiler`, `$os`, `$arch`, `$test-suite`, and `$result`. - -`--machine-log=`_path_ -: The path to the machine-readable log, relative to `dist/test`. The default - template is `$pkgid.log`. Template variables allowed are: `$pkgid`, - `$compiler`, `$os`, `$arch`, and `$result`. - -`--show-details=`_filter_ -: Determines if the results of individual test cases are shown on the - terminal. May be `always` (always show), `never` (never show), or - `failures` (show only the test cases of failing test suites). - -`--test-options=`_options_ -: Give extra options to the test executables. - -`--test-option=`_option_ -: give an extra option to the test executables. There is no need to quote - options containing spaces because a single option is assumed, so options - will not be split on spaces. - -## setup sdist ## - -Create a system- and compiler-independent source distribution in a file -_package_-_version_`.tar.gz` in the `dist` subdirectory, for -distribution to package builders. When unpacked, the commands listed in -this section will be available. - -The files placed in this distribution are the package description file, -the setup script, the sources of the modules named in the package -description file, and files named in the `license-file`, `main-is`, -`c-sources`, `data-files` and `extra-source-files` fields. - -This command takes the following option: - -`--snapshot` -: Append today's date (in "YYYYMMDD" format) to the version number for - the generated source package. The original package is unaffected. - -# Reporting bugs and deficiencies # - -Please report any flaws or feature requests in the [bug tracker][]. - -For general discussion or queries email the libraries mailing list -. There is also a development mailing list -. - -[bug tracker]: http://hackage.haskell.org/trac/hackage/ - -# Stability of Cabal interfaces # - -The Cabal library and related infrastructure is still under active -development. New features are being added and limitations and bugs are -being fixed. This requires internal changes and often user visible -changes as well. We therefor cannot promise complete future-proof -stability, at least not without halting all development work. - -This section documents the aspects of the Cabal interface that we can -promise to keep stable and which bits are subject to change. - -## Cabal file format ## - -This is backwards compatible and mostly forwards compatible. New fields -can be added without breaking older versions of Cabal. Fields can be -deprecated without breaking older packages. - -## Command-line interface ## - -### Very Stable Command-line interfaces ### - -* `./setup configure` - * `--prefix` - * `--user` - * `--ghc`, `--hugs` - * `--verbose` - * `--prefix` - -* `./setup build` -* `./setup install` -* `./setup register` -* `./setup copy` - -### Stable Command-line interfaces ### - -### Unstable command-line ### - -## Functions and Types ## - -The Cabal library follows the [Package Versioning Policy][PVP]. This -means that within a stable major release, for example 1.2.x, there will -be no incompatible API changes. But minor versions increments, for -example 1.2.3, indicate compatible API additions. - -The Package Versioning Policy does not require any API guarantees -between major releases, for example between 1.2.x and 1.4.x. In practise -of course not everything changes between major releases. Some parts of -the API are more prone to change than others. The rest of this section -gives some informal advice on what level of API stability you can expect -between major releases. - -[PVP]: http://haskell.org/haskellwiki/Package_versioning_policy - -### Very Stable API ### - -* `defaultMain` - -* `defaultMainWithHooks defaultUserHooks` - - But regular `defaultMainWithHooks` isn't stable since `UserHooks` - changes. - -### Semi-stable API ### - -* `UserHooks` The hooks API will change in the future - -* `Distribution.*` is mostly declarative information about packages and - is somewhat stable. - -### Unstable API ### - -Everything under `Distribution.Simple.*` has no stability guarantee. - -## Hackage ## - -The index format is a partly stable interface. It consists of a tar.gz -file that contains directories with `.cabal` files in. In future it may -contain more kinds of files so do not assume every file is a `.cabal` -file. Incompatible revisions to the format would involve bumping the -name of the index file, i.e., `00-index.tar.gz`, `01-index.tar.gz` etc. - - -[dist-simple]: ../libraries/Cabal/Distribution-Simple.html -[dist-make]: ../libraries/Cabal/Distribution-Make.html -[dist-license]: ../libraries/Cabal/Distribution-License.html#t:License -[extension]: ../libraries/Cabal/Language-Haskell-Extension.html#t:Extension -[BuildType]: ../libraries/Cabal/Distribution-PackageDescription.html#t:BuildType -[alex]: http://www.haskell.org/alex/ -[autoconf]: http://www.gnu.org/software/autoconf/ -[c2hs]: http://www.cse.unsw.edu.au/~chak/haskell/c2hs/ -[cpphs]: http://www.haskell.org/cpphs/ -[greencard]: http://www.haskell.org/greencard/ -[haddock]: http://www.haskell.org/haddock/ -[HsColour]: http://www.cs.york.ac.uk/fp/darcs/hscolour/ -[happy]: http://www.haskell.org/happy/ -[HackageDB]: http://hackage.haskell.org/ -[pkg-config]: http://pkg-config.freedesktop.org/ diff -Nru ghc-7.0.3/libraries/Cabal/doc/Cabal.xml ghc-7.2.1/libraries/Cabal/doc/Cabal.xml --- ghc-7.0.3/libraries/Cabal/doc/Cabal.xml 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/doc/Cabal.xml 1970-01-01 00:00:00.000000000 +0000 @@ -1,3715 +0,0 @@ - -Distribution.Simple'> - Distribution.Make'> - License'> - Extension'> - BuildType'> - alex'> - autoconf'> - c2hs'> - cpphs'> - greencard'> - haddock'> - HsColour'> - happy'> - HackageDB'> - pkg-config'> - ]> - -
    - Common Architecture for Building Applications and Libraries - User's Guide - - - Cabal aims to simplify the - distribution of Haskell - software. It does this by specifying a number of interfaces between - package authors, builders and users, as well as providing a library - implementing these interfaces. - - - - Introduction - - Developers write Cabal packages. These can be for libraries or - executables. This involves writing the code obviously and also creating a - .cabal file. The .cabal file contains some information - about the package. Some of this information is needed to actually build - the package and some is just useful for identifying the package when it - comes to distribution. - - -name: Foo -version: 1.0 - -library - build-depends: base - exposed-modules: Foo - - - Users install Cabal packages so they can use them. It is not expected - that users will have to modify any of the information in the - .cabal file. Cabal does provide a number of ways for - a user to customise how and where a package is installed. They can decide - where a package will be installed, which Haskell implementation to use - and whether to build optimised code or build with the ability to profile - code. - - -tar -xzf Foo-1.0.tar.gz -cd Foo-1.0 -runhaskell Setup configure --with-compiler=ghc-6.4.2 --user -runhaskell Setup build -runhaskell Setup install - - - One of the purposes of Cabal is to make it easier to build a package with - different Haskell implementations. So it provides abstractions of - features present in different Haskell implementations and wherever - possible it is best to take advantage of these to increase portability. - Where necessary however it is possible to use specific features of - specific implementations. For example one of the pieces of information a - package author can put in the package's .cabal file is - what language extensions the code uses. This is far preferable to - specifying flags for a specific compiler as it allows Cabal to pick the - right flags for the Haskell implementation that the user picks. It also - allows Cabal to figure out if the language extension is even supported by - the Haskell implementation that the user picks. Where compiler-specific - options are needed however, there is an "escape hatch" available. The - developer can specify implementation-specific options and more generally - there is a configuration mechanism to customise many aspects of how a - package is built depending on the Haskell implementation, the Operating - system, computer architecture and user-specified configuration flags. - - -name: Foo -version: 1.0 - -library - build-depends: base - exposed-modules: Foo - extensions: ForeignFunctionInterface - ghc-options: -Wall - nhc98-options: -K4m - if os(windows) - build-depends: Win32 - - - - - Packages - - A package is the unit of distribution - for the Cabal. Its purpose, when installed, is to make available - either or both of: - - - A library, exposing a number of Haskell modules. A library - may also contain hidden modules, which - are used internally but not available to clients. - Hugs doesn't support module hiding. - - - - - - One or more Haskell programs. - - - However having both a library and executables in a package - does not work very well; if the executables depend on the library, - they must explicitly list all the modules they directly or - indirectly import from that library. - - Internally, the package may consist of much more than a - bunch of Haskell modules: it may also have C source code and - header files, source code meant for preprocessing, documentation, - test cases, auxiliary tools etc. - - A package is identified by a globally-unique - package name, which consists of one or - more alphanumeric words separated by hyphens. To avoid ambiguity, - each of these words should contain at least one letter. - Chaos will result if two distinct packages with the - same name are installed on the same system, but there is not - yet a mechanism for allocating these names. - A particular version of the package is distinguished by a - version number, consisting of a sequence - of one or more integers separated by dots. These can be combined - to form a single text string called the package - ID, using a hyphen to separate the name from the - version, e.g. HUnit-1.1. - - - Packages are not part of the Haskell language; - they simply populate the hierarchical space of module names. - In GHC 6.6 and later a program may contain multiple modules - with the same name if they come from separate packages; in all - other current Haskell systems packages may not overlap in the - modules they provide, including hidden modules. - - - - - Creating a package - - Suppose you have a directory hierarchy containing the source - files that make up your package. You will need to add two more - files to the root directory of the package: - - - - package.cabal - - - a Unicode UTF-8 text file containing a package description - (for details of the syntax of this file, see - ) - - - - - - Setup.hs or - Setup.lhs - - - a single-module Haskell program to perform various - setup tasks (with the interface described in - ). This module should import only - modules that will be present in all Haskell implementations, - including modules of the Cabal library. In most cases it - will be trivial, calling on the Cabal library to do most of - the work. - - - - Once you have these, you can create a source bundle of this - directory for distribution. Building of the package is discussed in - . - - - A package containing a simple library - The HUnit package contains a file HUnit.cabal - containing: - -Name: HUnit -Version: 1.1.1 -Cabal-Version: >= 1.2 -License: BSD3 -License-File: LICENSE -Author: Dean Herington -Homepage: http://hunit.sourceforge.net/ -Category: Testing -Synopsis: A unit testing framework for Haskell - -Library - Build-Depends: base - Exposed-modules: - Test.HUnit.Base, Test.HUnit.Lang, Test.HUnit.Terminal, - Test.HUnit.Text, Test.HUnit - Extensions: CPP - - and the following Setup.hs: - -import Distribution.Simple -main = defaultMain - - - - A package containing executable programs - -Name: TestPackage -Version: 0.0 -Cabal-Version: >= 1.2 -License: BSD3 -Author: Angela Author -Synopsis: Small package with two programs -Build-Type: Simple - -Executable program1 - Build-Depends: HUnit - Main-Is: Main.hs - Hs-Source-Dirs: prog1 - -Executable program2 - Main-Is: Main.hs - Build-Depends: HUnit - Hs-Source-Dirs: prog2 - Other-Modules: Utils - - with Setup.hs the same as above. - - - - A package containing a library and executable programs - -Name: TestPackage -Version: 0.0 -Cabal-Version: >= 1.2 -License: BSD3 -Author: Angela Author -Synopsis: Package with library and two programs -Build-Type: Simple - -Library - Build-Depends: HUnit - Exposed-Modules: A, B, C - -Executable program1 - Main-Is: Main.hs - Hs-Source-Dirs: prog1 - Other-Modules: A, B - -Executable program2 - Main-Is: Main.hs - Hs-Source-Dirs: prog2 - Other-Modules: A, C, Utils - - with Setup.hs the same as above. - Note that any library modules required (directly or indirectly) - by an executable must be listed again. - - - The trivial setup script used in these examples uses - the simple build infrastructure - provided by the Cabal library (see &Simple;). - The simplicity lies in its interface rather that its implementation. - It automatically handles preprocessing with standard preprocessors, - and builds packages for all the Haskell implementations (except - nhc98, for now). - - The simple build infrastructure can also handle packages - where building is governed by system-dependent parameters, - if you specify a little more (see ). - A few packages require more elaborate solutions - (see ). - - - Package descriptions - - The package description file must have a name ending in - .cabal. It must be a Unicode text - file encoded using valid UTF-8. There must be exactly - one such file in the directory. The first part of the name is - usually the package name, and some of the tools that operate - on Cabal packages require this. - - In the package description file, lines whose first - non-whitespace characters - are -- are treated as comments - and ignored. - - This file should contain of a number global property - descriptions and several sections. - - - - The global properties describe the package as a whole, - such as name, license, author, etc. (see ). - - - Optionally, a number of configuration - flags can be declared. These can be used to - enable or disable certain features of a package. (see ). - - - The (optional) library section specifies the library - properties (see ) and relevant build - information (see ). - - - Following is an arbitrary number of executable sections - which describe an executable program and (see ) relevant build information (see ). - - - - Each section consists of a number of property descriptions - in the form of field/value pairs, with a syntax roughly like mail - message headers. - - - Case is not significant in field names, - but is significant in field values. - - - To continue a field value, indent the next line - relative to the field name. - - - Field names may be indented, but all field values in - the same section must use the same indentation. - - - Tabs are not allowed as - indentation characters due to a missing standard - interpretation of tab width. - - - To get a blank line in a field value, use an indented - . - - - The syntax of the value depends on the field. Field types - include: - - - - - token - - - filename - - - directory - - - Either a sequence of one or more non-space non-comma - characters, or a quoted string in Haskell 98 lexical syntax. - Unless otherwise stated, relative filenames and directories - are interpreted from the package root directory. - - - - - - freeform - - - URL - - - address - - - An arbitrary, uninterpreted string. - - - - - - identifier - - - A letter followed by zero or more alphanumerics - or underscores. - - - - - - compiler - - - A compiler flavor (one - of: GHC, NHC, - YHC, Hugs, - HBC, Helium, - JHC, or LHC) - followed by a version range. For example, - GHC ==6.10.3, - or LHC >=0.6 && <0.8. - - - - - - - Modules and preprocessors - Haskell module names listed in the - exposed-modules and - other-modules fields may - correspond to Haskell source files, i.e. with names - ending in .hs or - .lhs, or to inputs for - various Haskell preprocessors. - The simple build infrastructure understands the extensions - .gc (&Greencard;), - .chs (&C2hs;), - .hsc (hsc2hs), - .y and - .ly (&Happy;), - .x (&Alex;) - and - .cpphs (&Cpphs;). - When building, Cabal will automatically run the appropriate - preprocessor and compile the Haskell module it produces. - - - Some fields take lists of values, which - are optionally separated by commas, except for the - build-depends field, where the commas are - mandatory. - - Some fields are marked as required. All others are optional, - and unless otherwise specified have empty default values. - - - Package properties - - These fields may occur in the first top-level properties - section and describe the package as a whole: - - - - - name: package-name - (required) - - - The unique name of the package - (see ), without the version - number. - - - - - - version: numbers - (required) - - - The package version number, usually consisting of a - sequence of natural numbers separated by dots. - - - - - - cabal-version: >, <=, etc. & numbers - - - The version of Cabal required for this package. - Since, with Cabal version 1.2 the syntax of package - descriptions has changed, this is now a required field. - List the field early in your .cabal - file so that it will appear as a syntax error before any - others, since old versions of Cabal unfortunately do not - recognize this field. - For compatibility, files written in the old syntax - are still recognized. Thus if you don't require - features introduced with or after Cabal version 1.2, you - may write your package description file using the old - syntax. Please consult the user's guide of that Cabal - version for a description of that syntax. - - - - - - build-type: identifier - - - The type of build used by this package. - Build types are the constructors of the &BuildType; type, - defaulting to Custom. - If this field is given a value other than - Custom, some tools such as - cabal-install will be able to - build the package without using the setup script. So if you are - just using the default Setup.hs then set - the build type as Simple. - - - - - - license: identifier - (default: AllRightsReserved) - - - The type of license under which this package is - distributed. License names are the constants of the - &License; type. - - - - - - license-file: - filename - - - The name of a file containing the precise license - for this package. It will be installed with the package. - - - - - - - copyright: - freeform - - - The content of a copyright notice, typically the - name of the holder of the copyright on the package and - the year(s) from which copyright is claimed. - For example: - Copyright: (c) 2006-2007 Joe Bloggs - - - - - - - author: - freeform - - - The original author of the package. - - - - - - maintainer: - address - - - The current maintainer or maintainers of the package. - This is an e-mail address to which users should send bug - reports, feature requests and patches. - - - - - - stability: - freeform - - - The stability level of the package, e.g. - alpha, experimental, - provisional, - stable. - - - - - - homepage: URL - - - The package homepage. - - - - - - bug-reports: URL - - - - The URL where users should direct bug reports. This would - normally be either: - - - - A mailto: URL, eg for a person or a - mailing list. - - - - - An http: (or https:) - URL for an online bug tracking system. - - - - For example Cabal itself uses a web-based bug tracking system - bug-reports: http://hackage.haskell.org/trac/hackage/ - - - - - - - package-url: URL - - - The location of a source bundle for the package. - The distribution should be a Cabal package. - - - - - - synopsis: - freeform - - - A very short description of the package, for use in - a table of packages. This is your headline, so keep - it short (one line) but as informative as possible. - Save space by not including the package name or saying - it's written in Haskell. - - - - - - description: - freeform - - - Description of the package. This may be several - paragraphs, and should be aimed at a Haskell programmer - who has never heard of your package before. - - For library packages, this field is used as - prologue text by setup haddock - (see ), and thus may - contain the same markup as &Haddock; documentation - comments. - - - - - - category: - freeform - - - A classification category for future use by the - package catalogue Hackage. These - categories have not yet been specified, but the upper - levels of the module hierarchy make a good start. - - - - - - tested-with: - compiler list - - - A list of compilers and versions against which the - package has been tested (or at least built). - - - - - - data-files: - filename list - - - A list of files to be installed for run-time use by - the package. This is useful for packages that use a - large amount of static data, such as tables of values - or code templates. For details on how to find these - files at run-time, see - . - - A limited form of * wildcards in file names, - for example data-files: images/*.png matches - all the .png files in the - images directory. - - - The limitation is that * wildcards are only - allowed in place of the file name, not in the directory name or - file extension. In particular, wildcards do not include - directories contents recursively. Furthermore, if a wildcard is - used it must be used with an extension, so data-files: - data/* is not allowed. When matching a wildcard plus - extension, a file's full extension must match exactly, so - *.gz matches foo.gz but - not foo.tar.gz. A wildcard that does not - match any files is an error. - - - The reason for providing only a very limited form of wildcard - is to concisely express the common case of a large number of - related files of the same file type without making it too easy - to accidentally include unwanted files. - - - - - - - data-dir: - directory - - - The directory where Cabal looks for data files to install, - relative to the source directory. By default, Cabal will look - in the source directory itself. - - - - - - extra-source-files: - filename list - - - A list of additional files to be included in source - distributions built with setup sdist - (see ). - As with data-files it can use a limited - form of * wildcards in file names. - - - - - - extra-tmp-files: - filename list - - - A list of additional files or directories to be - removed by setup clean - (see ). - These would typically be additional files created by - additional hooks, such as the scheme described in - . - - - - - - - Library - - The library section should contain the following - fields: - - - - - exposed-modules: - identifier list - (required if this package contains a library) - - - A list of modules added by this package. - - - - - - exposed: boolean - (default: True) - - - - Some Haskell compilers (notably GHC) support the notion of - packages being exposed or hidden - which means the modules they provide can be easily imported - without always having to specify which package they come from. - However this only works effectively if the modules provided by - all exposed packages do not overlap (otherwise a module import - would be ambiguous). - - - Almost all new libraries use hierarchical module names that do - not clash, so it is very uncommon to have to use this field. - However it may be necessary to set exposed: - False for some old libraries that use a flat module - namespace or where it is known that the exposed modules would - clash with other common modules. - - - - - - - The library section may also contain build information fields - (see ). - - - - Executables - - Executable sections (if present) describe executable - programs contained in the package and must have an argument - after the section label, which defines the name of the - executable. This is a freeform argument but may not contain - spaces. - - The executable may be described using the following - fields, as well as build information fields (see ). - - - - - main-is: filename - (required) - - - The name of the .hs or - .lhs file containing the - Main module. Note that it is the - .hs filename that must be listed, even if - that file is generated using a preprocessor. The source - file must be relative to one of the directories listed in - hs-source-dirs. - - - - - - - - - Build information - - The following fields may be optionally present in a - library or executable section, and give information for the - building of the corresponding library or executable. See also - and - for a way to supply system-dependent values for these - fields. - - - - - build-depends: - package list - - - A list of packages needed to build this one. Each package - can be annotated with a version constraint. - - - Version constraints use the operators ==, >=, >, - <, <= and a version number. Multiple - constraints can be combined using && - or ||. If no version constraint is - specified, any version is assumed to be acceptable. - For example: - - -library - build-depends: - base >= 2, - foo >= 1.2 && < 1.3, - bar - - - Dependencies like foo >= 1.2 && < 1.3 turn - out to be very common because it is recommended practise for - package versions to correspond to API versions. There is a - special syntax to support this use: - - build-depends: foo ==1.2.* - - It is only syntactic sugar. It is exactly equivalent to - foo >= 1.2 && < 1.3. - - - - - - - other-modules: - identifier list - - - A list of modules used by the component - but not exposed to users. For a library component, these - would be hidden modules of the library. For an executable, - these would be auxiliary modules to be linked with the - file named in the main-is field. - - Every module in the package must be - listed in one of other-modules, - exposed-modules or - main-is fields. - - - - - - - - hs-source-dirs: - directory list - (default: .) - - - Root directories for the module hierarchy. - - For backwards compatibility, the old variant - hs-source-dir is also recognized. - - - - - extensions: - identifier list - - - A list of Haskell extensions used by every module. - Extension names are the constructors of the &Extension; type. - These determine corresponding compiler options. - In particular, CPP specifies that - Haskell source files are to be preprocessed with a - C preprocessor. - - Extensions used only by one module may be specified - by placing a LANGUAGE pragma in the - source file affected, e.g.: - {-# LANGUAGE CPP, MultiParamTypeClasses #-} - - GHC versions prior to 6.6 do not support the - LANGUAGE pragma. - - - - - - - build-tools: - program list - - - A list of programs, possibly annotated with versions, - needed to build this package, - e.g. c2hs > 0.15, cpphs. - If no version constraint is specified, any version is - assumed to be acceptable. - - - - - - buildable: boolean - (default: True) - - - Is the component buildable? - Like some of the other fields below, this field is - more useful with the slightly more elaborate form of - the simple build infrastructure described in - . - - - - - - ghc-options: - token list - - - Additional options for GHC. You can often achieve - the same effect using the extensions - field, which is preferred. - - Options required only by one module may be specified - by placing an OPTIONS_GHC pragma in the - source file affected. - - - - - - ghc-prof-options: - token list - - - Additional options for GHC when the package is built - with profiling enabled. - - - - - - ghc-shared-options: - token list - - - Additional options for GHC when the package is - built as shared library. - - - - - - hugs-options: - token list - - - Additional options for Hugs. You can often achieve - the same effect using the extensions - field, which is preferred. - - Options required only by one module may be specified - by placing an OPTIONS_HUGS pragma in the - source file affected. - - - - - - nhc98-options: - token list - - - Additional options for nhc98. You can often achieve - the same effect using the extensions - field, which is preferred. - - Options required only by one module may be specified - by placing an OPTIONS_NHC98 pragma in the - source file affected. - - Warning: Cabal does not currently support building - libraries or executables with nhc98 anyway. - - - - - - includes: - filename list - - - A list of header files to be included in any - compilations via C. This field applies to both header - files that are already installed on the system and to - those coming with the package to be installed. These files - typically contain function prototypes for foreign imports - used by the package. - - - - - - install-includes: - filename list - - - A list of header files from this package to be - installed into - $libdir/includes when the package - is installed. Files listed in - install-includes: should be found in - relative to the top of the source tree or relative to one of the - directories listed in include-dirs. - - install-includes is typically - used to name header files that contain prototypes for - foreign imports used in Haskell code in this package, - for which the C implementations are also provided with - the package. Note that to include them when compiling - the package itself, they need to be listed in the - includes: field as well. - - - - - - include-dirs: - directory list - - - A list of directories to search for header files, - when preprocessing with c2hs, - hsc2hs, ffihugs, - cpphs or the C preprocessor, - and also when compiling via C. - - - - - - c-sources: - filename list - - - A list of C source files to be compiled - and linked with the Haskell files. - - If you use this field, you should also name the - C files in CFILES pragmas in the - Haskell source files that use them, e.g.: - {-# CFILES dir/file1.c dir/file2.c #-} - These are ignored by the compilers, but needed by Hugs. - - - - - - extra-libraries: - token list - - - A list of extra libraries to link with. - - - - - - extra-lib-dirs: - directory list - - - A list of directories to search for libraries. - - - - - - cc-options: - token list - - - Command-line arguments to be passed to the C compiler. - Since the arguments are compiler-dependent, this field - is more useful with the setup described in - . - - - - - - ld-options: - token list - - - Command-line arguments to be passed to the linker. - Since the arguments are compiler-dependent, this field - is more useful with the setup described in - . - - - - - - pkgconfig-depends: - package list - - - A list of &PkgConfig; packages, needed to build this - package. They can be annotated with versions, - e.g. gtk+-2.0 >= 2.10, cairo >= 1.0. - If no version constraint is specified, any version is - assumed to be acceptable. Cabal uses - pkg-config to find if the packages are - available on the system and to find the extra compilation and - linker options needed to use the packages. - - If you need to bind to a C library that supports - pkg-config (use - pkg-config --list-all to find out if it is - supported) then it is much preferable to use this field rather - than hard code options into the other fields. - - - - - - - frameworks: - token list - - - On Darwin/MacOS X, a list of frameworks to link to. - See Apple's developer documentation for more details - on frameworks. This entry is ignored on all other - platforms. - - - - - - - Configurations - Library and executable sections may include conditional - blocks, which test for various system parameters and - configuration flags. The flags mechanism is rather generic, - but most of the time a flag represents certain feature, that - can be switched on or off by the package user. - Here is an example package description file using - configurations: - - A package containing a library and executable programs - - Name: Test1 -Version: 0.0.1 -Cabal-Version: >= 1.2 -License: BSD3 -Author: Jane Doe -Synopsis: Test package to test configurations -Category: Example - -Flag Debug - Description: Enable debug support - Default: False - -Flag WebFrontend - Description: Include API for web frontend. - -- Cabal checks if the configuration is possible, first - -- with this flag set to True and if not it tries with False - -Library - Build-Depends: base - Exposed-Modules: Testing.Test1 - Extensions: CPP - - if flag(debug) - GHC-Options: -DDEBUG - if !os(windows) - CC-Options: "-DDEBUG" - else - CC-Options: "-DNDEBUG" - - if flag(webfrontend) - Build-Depends: cgi > 0.42 - Other-Modules: Testing.WebStuff - -Executable test1 - Main-is: T1.hs - Other-Modules: Testing.Test1 - Build-Depends: base - - if flag(debug) - CC-Options: "-DDEBUG" - GHC-Options: -DDEBUG - - - - Layout - Flags, conditionals, library and executable sections use layout to - indicate structure. This is very similar to the Haskell layout rule. - Entries in a section have to all be indented to the same level which must - be more than the section header. Tabs are not allowed to be used for - indentation. - - As an alternative to using layout you can also use explicit braces - {}. In this case the indentation of entries in a - section does not matter, though different fields within a block must be - on different lines. Here is a bit of the above example again, using - braces: - - Using explicit braces rather than indentation for layout - - Name: Test1 -Version: 0.0.1 -Cabal-Version: >= 1.2 -License: BSD3 -Author: Jane Doe -Synopsis: Test package to test configurations -Category: Example - -Flag Debug { - Description: Enable debug support - Default: False -} - -Library { - Build-Depends: base - Exposed-Modules: Testing.Test1 - Extensions: CPP - if flag(debug) { - GHC-Options: -DDEBUG - if !os(windows) { - CC-Options: "-DDEBUG" - } else { - CC-Options: "-DNDEBUG" - } - } -} - - - - - Configuration Flags - A flag section takes the flag name as an argument and - may contain the following fields. - - - - description: - freeform - - - The description of this flag. - - - - - default: - boolean - (default: True) - - - The default value of this flag. - Note that this value may be overridden in several - ways (see ). The - rationale for having flags default to True is that users - usually want new features as soon as they are available. - Flags representing features that are not (yet) - recommended for most users (such as experimental - features or debugging support) should therefore - explicitly override the default to False. - - - - - manual: - boolean - (default: False) - - - By default, Cabal will first try to satisfy - dependencies with the default flag value and then, - if that is not possible, with the negated value. - However, if the flag is manual, then the default - value (which can be overridden by commandline flags) - will be used. - - - - - - Conditional Blocks - Conditional blocks may appear anywhere inside a - library or executable section. They have to follow rather - strict formatting rules. - Conditional blocks must always be of the shape - - if condition - property-descriptions-or-conditionals* - or - - if condition - property-descriptions-or-conditionals* - else - property-descriptions-or-conditionals* - - - Note that the if and the condition have to - be all on the same line. - - - - Conditions - Conditions can be formed using boolean tests and the - boolean operators || (disjunction / - logical "or"), && (conjunction / - logical "and"), or ! (negation / logical - "not"). The unary ! takes highest - precedence, || takes lowest. Precedence - levels may be overridden through the use of parentheses. - For example, os(darwin) && !arch(i386) || os(freebsd) - is equivalent to (os(darwin) && !(arch(i386))) || os(freebsd). - - The following tests are currently supported. - - - - os( - name - ) - - - Tests if the current operating system is - name. The argument is tested - against System.Info.os on - the target system. There is unfortunately some disagreement - between Haskell implementations about the standard values of - System.Info.os. Cabal canonicalises it so - that in particular os(windows) works on all - implementations. If the canonicalised os names match, this test - evaluates to true, otherwise false. The match is - case-insensitive. - - - - - arch( - name - ) - - - Tests if the current architecture is - name. The argument is matched - against System.Info.arch on the target system. - If the arch names match, this test evaluates to true, - otherwise false. The match is case-insensitive. - - - - - impl( - compiler - ) - - - Tests for the configured Haskell implementation. An optional - version constraint may be specified (for example - impl(ghc >= 6.6.1)). If the - configured implementation is of the right type and matches the - version constraint, then this evaluates to true, - otherwise false. The match is case-insensitive. - - - - flag( - name - ) - - - Evaluates to the current assignment of the flag of - the given name. Flag names are case insensitive. - Testing for flags that have not been introduced with a - flag section is an error. - - - - - true - - - Constant value true. - - - - - false - - - Constant value false. - - - - - - - Resolution of Conditions and Flags - If a package descriptions specifies configuration flags - the package user can control these in several ways (see - ). If the user does not fix the - value of a flag, Cabal will try to find a flag assignment in the - following way. - - - For each flag specified, it will assign its default - value, evaluate all conditions with this flag assignment, - and check if all dependencies can be satisfied. If this - check succeeded, the package will be configured with those - flag assignments. - - - If dependencies were missing, the last flag (as by - the order in which the flags were introduced in the - package description) is tried with its alternative value - and so on. This continues until either an assignment is - found where all dependencies can be satisfied, or all - possible flag assignments have been tried. - - - - To put it another way, Cabal does a complete backtracking - search to find a satisfiable package configuration. It is only the - dependencies specified in the build-depends field - in conditional blocks that determine if a particular flag assignment - is satisfiable (build-tools are not considered). - The order of the declaration and the default value of the flags - determines the search order. Flags overridden on the command line fix - the assignment of that flag, so no backtracking will be tried for - that flag. - - If no suitable flag assignment could be found, the - configuration phase will fail and a list of missing - dependencies will be printed. Note that this resolution - process is exponential in the worst case (i.e., in the case - where dependencies cannot be satisfied). There are some - optimizations applied internally, but the overall complexity - remains unchanged. - - - Meaning of field values when using conditionals - During the configuration phase, a flag assignment is - chosen, all conditionals are evaluated, and the package description - is combined into a flat package descriptions. If the same field - both inside a conditional and outside then they are combined using - the following rules. - - - Boolean fields are combined using conjunction - (logical "and"). - - - List fields are combined by appending the inner - items to the outer items, for example - Extensions: CPP -if impl(ghc) || impl(hugs) - Extensions: MultiParamTypeClasses - - when compiled using Hugs or GHC will be combined to - Extensions: CPP, MultiParamTypeClasses - - Similarly, if two conditional sections appear at the - same nesting level, properties specified in the latter - will come after properties specified in the former. - - - All other fields must not be specified in ambiguous ways. For example - Main-is: Main.hs -if flag(useothermain) - Main-is: OtherMain.hs - - will lead to an error. Instead use - if flag(useothermain) - Main-is: OtherMain.hs -else - Main-is: Main.hs - - - - - - - - Source Repositories - - It is often useful to be able to specify a source revision control - repository for a package. Cabal lets you specifying this information - in a relatively structured form which enables other tools to - interpret and make effective use of the information. For example the - information should be sufficient for an automatic tool to checkout - the sources. - - - Cabal supports specifying different information for various common - source control systems. Obviously not all automated tools will - support all source control systems. - - - Cabal supports specifying repositories for different use cases. By - declaring which case we mean automated tools can be more useful. - There are currently two kinds defined: - - - - The head kind refers to the - latest development branch of the package. This may be used for - example to track activity of a project or as an indication to - outside developers what sources to get for making new - contributions. - - - - - The this kind refers to the - branch and tag of a repository that contains the sources for this - version or release of a package. For most source control systems - this involves specifying a tag, id or hash of some form and - perhaps a branch. The purpose is to be able to reconstruct the - sources corresponding to a particular package version. This might - be used to indicate what sources to get if someone needs to fix a - bug in an older branch that is no longer an active head branch. - - - - - - You can specify one kind or the other or both. As an example here are - the repositories for the Cabal library. Note that the - this kind of repo specifies a tag. - -source-repository head - type: darcs - location: http://darcs.haskell.org/cabal/ - -source-repository this - type: darcs - location: http://darcs.haskell.org/cabal-branches/cabal-1.6/ - tag: 1.6.1 - - - - The exact fields are as follows: - - - - - type: - token - - - - The name of the source control system used for this repository. - The currently recognised types are: - - darcs - git - svn - cvs - mercurial (or alias hg) - bazaar (or alias bzr) - arch - monotone - - - - This field is required. - - - - - - location: - URL - - - - The location of the repository. The exact form of this field - depends on the repository type. For example: - - - for darcs: http://code.haskell.org/foo/ - - - for git: git://github.com/foo/bar.git - - - for CVS: anoncvs@cvs.foo.org:/cvs - - - - - This field is required. - - - - - - module: - token - - - - CVS requires a named module, as each CVS server can host multiple - named repositories. - - - This field is required for the CVS repo type and should not be - used otherwise. - - - - - - branch: - token - - - - Many source control systems support the notion of a branch, - as a distinct concept from having repositories in separate - locations. For example CVS, SVN and git use branches while for - darcs uses different locations for different branches. If you - need to specify a branch to identify a your repository - then specify it in this field. - - - This field is optional. - - - - - - tag: - token - - - - A tag identifies a particular state of a source repository. The - tag can be used with a this repo kind to - identify the state of a repo corresponding to a particular - package version or release. The exact form of the tag depends on - the repository type. - - - This field is required for the this repo kind. - - - - - - subdir: - directory - - - - Some projects put the sources for multiple packages under a - single source repository. This field lets you specify the - relative path from the root of the repository to the top - directory for the package, ie the directory containing the - package's .cabal file. - - - This field is optional. It default to empty which corresponds to - the root directory of the repository. - - - - - - - - - Accessing data files from package code - The placement on the target system of files listed in the - data-files field varies between systems, and in - some cases one can even move packages around after installation - (see ). To enable packages - to find these files in a portable way, Cabal generates a module - called Paths_pkgname - (with any hyphens in pkgname replaced - by underscores) during building, so that it may be imported by - modules of the package. This module defines a function - getDataFileName :: FilePath -> IO FilePath - If the argument is a filename listed in the - data-files field, the result is the name - of the corresponding file on the system on which the program - is running. - - If you decide to import the - Paths_pkgname module then - it must be listed in the - other-modules field just like any other module in - your package. - - The Paths_pkgname - module is not platform independent so it does not get included in the - source tarballs generated by sdist. - - - - - - System-dependent parameters - - For some packages, especially those interfacing with C - libraries, implementation details and the build procedure depend - on the build environment. A variant of the simple build - infrastructure (the build-type - Configure) handles many such situations using - a slightly longer Setup.hs: - -import Distribution.Simple -main = defaultMainWithHooks autoconfUserHooks - - Most packages, however, would probably do better with - configurations (see ). - - This program differs from defaultMain - in two ways: - - - The package root directory must contain a shell script called - configure. The configure step will run the - script. This configure script may - be produced by &Autoconf; or may be hand-written. The - configure script typically - discovers information about the system and records it for - later steps, e.g. by generating system-dependent header files - for inclusion in C source files and preprocessed Haskell - source files. (Clearly this won't work for Windows without - MSYS or Cygwin: other ideas are needed.) - - - - If the package root directory contains a file called - package.buildinfo - after the configuration step, subsequent steps will read it - to obtain additional settings for build information fields - (see ), to be merged with the - ones given in the .cabal file. - In particular, this file may be generated by the - configure script mentioned above, - allowing these settings to vary depending on the build - environment. - - The build information file should have the following - structure: - -buildinfo - -executable: name -buildinfo - -executable: name -buildinfo - -... - where each buildinfo consists - of settings of fields listed in . - The first one (if present) relates to the library, while each - of the others relate to the named executable. (The names - must match the package description, but you don't have to - have entries for all of them.) - - - - - Neither of these files is required. If they are absent, this - setup script is equivalent to defaultMain. - - - Using autoconf - - (This example is for people familiar with the &Autoconf; - tools.) - - In the X11 package, the file configure.ac - contains: - -AC_INIT([Haskell X11 package], [1.1], [libraries@haskell.org], [X11]) - -# Safety check: Ensure that we are in the correct source directory. -AC_CONFIG_SRCDIR([X11.cabal]) - -# Header file to place defines in -AC_CONFIG_HEADERS([include/HsX11Config.h]) - -# Check for X11 include paths and libraries -AC_PATH_XTRA -AC_TRY_CPP([#include <X11/Xlib.h>],,[no_x=yes]) - -# Build the package if we found X11 stuff -if test "$no_x" = yes -then BUILD_PACKAGE_BOOL=False -else BUILD_PACKAGE_BOOL=True -fi -AC_SUBST([BUILD_PACKAGE_BOOL]) - -AC_CONFIG_FILES([X11.buildinfo]) -AC_OUTPUT - - Then the setup script will run the - configure script, which checks for the - presence of the X11 libraries and substitutes for variables - in the file X11.buildinfo.in: - -buildable: @BUILD_PACKAGE_BOOL@ -cc-options: @X_CFLAGS@ -ld-options: @X_LIBS@ - - This generates a file X11.buildinfo - supplying the parameters needed by later stages: - -buildable: True -cc-options: -I/usr/X11R6/include -ld-options: -L/usr/X11R6/lib - - The configure script also generates - a header file include/HsX11Config.h - containing C preprocessor defines recording the results of - various tests. This file may be included by C source files - and preprocessed Haskell source files in the package. - - - - Packages using these features will also need to list - additional files such as configure, - templates for .buildinfo files, files named - only in .buildinfo files, header files and - so on in the extra-source-files field, - to ensure that they are included in source distributions. - They should also list files and directories generated by - configure in the - extra-tmp-files field to ensure that they - are removed by setup clean. - - - - - Conditional compilation - - Sometimes you want to write code that works with more than - one version of a dependency. You can specify a range of - versions for the depenency in - the build-depends, but how do you then write - the code that can use different versions of the API? - - Haskell lets you preprocess your code using the C - preprocessor (either the real C preprocessor, or - cpphs). To enable this, - add extensions: CPP to your package - description. When using CPP, Cabal provides some pre-defined - macros to let you test the version of dependent packages; for - example, suppose your package works with either version 3 or - version 4 of the base package, you could - select the available version in your Haskell modules like - this: - -#if MIN_VERSION_base(4,0,0) -... code that works with base-4 ... -#else -... code that works with base-3 ... -#endif - -In general, Cabal supplies a - macro MIN_VERSION_package(A,B,C) - for each package depended on via build-depends. - This macro is true if the actual version of the package in use is - greater than or equal to A.B.C (using the - conventional ordering on version numbers, which is lexicographic on - the sequence, but numeric on each component, so for example 1.2.0 is - greater than 1.0.3). - - Cabal places the definitions of these macros into an - automatically-generated header file, which is included when - preprocessing Haskell source code by passing options to the C - preprocessor. - - - - More complex packages - - For packages that don't fit the simple schemes described above, - you have a few options: - - - - You can customize the simple build infrastructure - using hooks. These allow you to - perform additional actions before and after each command is - run, and also to specify additional preprocessors. See - UserHooks in &Simple; for the details, - but note that this interface is experimental, and likely to - change in future releases. - - - - You could delegate all the work to make, - though this is unlikely to be very portable. - Cabal supports this with the build-type - Make and a trivial setup library &Make;, - which simply parses the command line arguments and invokes - make. Here Setup.hs - looks like - -import Distribution.Make -main = defaultMain - - The root directory of the package should contain - a configure script, and, after - that has run, a Makefile with a - default target that builds the package, plus targets - install, register, - unregister, clean, - dist and docs. - Some options to commands are passed through as follows: - - - - The , - , , - , - and options to the - configure command are passed on to - the configure script. - In addition the value of the - option is passed in a option and - all options specified with = - are passed on. - - - - the --destdir option to the - copy command becomes a setting of a - destdir variable on the invocation of - make copy. The supplied - Makefile should provide a - copy target, which will probably - look like this: - -copy : - $(MAKE) install prefix=$(destdir)/$(prefix) \ - bindir=$(destdir)/$(bindir) \ - libdir=$(destdir)/$(libdir) \ - datadir=$(destdir)/$(datadir) \ - libexecdir=$(destdir)/$(libexecdir) - - - - - - - - You can write your own setup script conforming to the - interface of , possibly using - the Cabal library for part of the work. One option is to - copy the source of Distribution.Simple, - and alter it for your needs. Good luck. - - - - - - - Building and installing a package - After you've unpacked a Cabal package, you can build it - by moving into the root directory of the package and using the - Setup.hs or Setup.lhs - script there: - - runhaskell Setup.hs - command - option - - where runhaskell might be - runhugs, runghc or - runnhc. The command - argument selects a particular step in the build/install process. - You can also get a summary of the command syntax with - - runhaskell Setup.hs - - - - Building and installing a system package - -runhaskell Setup.hs configure --ghc -runhaskell Setup.hs build -runhaskell Setup.hs install - The first line readies the system to build the tool using GHC; - for example, it checks that GHC exists on the system. The second - line performs the actual building, while the last both copies - the build results to some permanent place and registers the - package with GHC. - - - - Building and installing a user package - -runhaskell Setup.hs configure --user -runhaskell Setup.hs build -runhaskell Setup.hs install - The package is installed under the user's home directory - and is registered in the user's package database - (). - - - - Creating a binary package - When creating binary packages (e.g. for RedHat or - Debian) one needs to create a tarball that can be sent to - another system for unpacking in the root directory: - -runhaskell Setup.hs configure --prefix=/usr -runhaskell Setup.hs build -runhaskell Setup.hs copy --destdir=/tmp/mypkg -tar -czf mypkg.tar.gz /tmp/mypkg/ - - If the package contains a library, you need two additional - steps: - -runhaskell Setup.hs register --gen-script -runhaskell Setup.hs unregister --gen-script - This creates shell scripts register.sh - and unregister.sh, which must also be sent - to the target system. After unpacking there, the package must be - registered by running the register.sh script. - The unregister.sh script would be used - in the uninstall procedure of the package. Similar steps may - be used for creating binary packages for Windows. - - - The following options are understood by all commands: - - - - , or - - - - List the available options for the command. - - - - - - =n or - n - - - Set the verbosity level (0-3). The normal level is 1; - a missing n defaults to 2. - - - - - The various commands and the additional options they support - are described below. In the simple build infrastructure, any - other options will be reported as errors. - - - setup configure - Prepare to build the package. Typically, this step checks - that the target platform is capable of building the package, - and discovers platform-specific features that are needed during - the build. - - The user may also adjust the behaviour of later stages using - the options listed in the following subsections. In the simple - build infrastructure, the values supplied via these options are - recorded in a private file read by later stages. - - If a user-supplied configure - script is run (see - or ), it is passed the - , - , , - , and - options. - In addition the value of the - option is passed in a option and - all options specified with = - are passed on. - - - Programs used for building - - The following options govern the programs used to process - the source files of a package: - - - - or - - - - - Specify which Haskell implementation to use to build - the package. At most one of these flags may be given. - If none is given, the implementation under which the setup - script was compiled or interpreted is used. - - - - - =path - or path - - Specify the path to a particular compiler. If given, - this must match the implementation selected above. - The default is to search for the usual name of the - selected implementation. - This flag also sets the default value of the - option to the package tool - for this compiler. - Check the output of setup configure -v - to ensure that it finds the right package tool (or use - explicitly). - - - - - =path - - Specify the path to the package tool, e.g. - ghc-pkg. - The package tool must be compatible with the compiler - specified by . - If this option is omitted, the default value is determined - from the compiler selected. - - - - - =path - - Specify the path to the program prog. - Any program known to Cabal can be used in place of - prog. It can either be a fully - path or the name of a program that can be found on the program - search path. For example: - or . - - - - - =options - - Specify additional options to the program prog. - Any program known to Cabal can be used in place of - prog. For example: - . - The options is split into program options - based on spaces. Any options containing embeded spaced need to - be quoted, for example - --foo-options='--bar="C:\Program File\Bar"'. As an - alternative that takes only one option at a time but avoids the - need to quote, use - instead. - - - - - - =option - - Specify a single additional option to the program - prog. - For passing an option that contain embeded spaces, such as a file - name with embeded spaces, using this rather than - means you - do not need an additional level of quoting. Of course if - you are using a command shell you may still need to quote, for - example --foo-options="--bar=C:\Program File\Bar". - - - - - All of the options passed with either - or - are passed - in the order they were specified on the configure command line. - - - - - - Installation paths - - The following options govern the location of installed files - from a package: - - - - =dir - - The root of the installation. For example for a global - install you might use - /usr/local on a Unix system, or - C:\Program Files on a Windows system. - The other installation paths are usually subdirectories of - prefix, but they don't have - to be. - In the simple build system, dir - may contain the following path variables: - $pkgid, - $pkg, - $version, - $compiler, - $os, - $arch - - - - - - =dir - - Executables that the user might invoke are installed here. - In the simple build system, dir - may contain the following path variables: - $prefix, - $pkgid, - $pkg, - $version, - $compiler, - $os, - $arch - - - - - - =dir - - Object-code libraries are installed here. - In the simple build system, dir - may contain the following path variables: - $prefix, - $bindir, - $pkgid, - $pkg, - $version, - $compiler, - $os, - $arch - - - - - - =dir - - Executables that are not expected to be invoked - directly by the user are installed here. - In the simple build system, dir - may contain the following path variables: - $prefix, - $bindir, - $libdir, - $libsubdir, - $pkgid, - $pkg, - $version, - $compiler, - $os, - $arch - - - - - - =dir - - Architecture-independent data files are installed - here. - In the simple build system, dir - may contain the following path variables: - $prefix, - $bindir, - $libdir, - $libsubdir, - $pkgid, - $pkg, - $version, - $compiler, - $os, - $arch - - - - - - In addition the simple build system supports the following - installation path options: - - - - =dir - - A subdirectory of libdir - in which libraries are actually installed. For example, - in the simple build system on Unix, the default - libdir is - /usr/local/lib, and - libsubdir contains the package - identifier and compiler, - e.g. mypkg-0.2/ghc-6.4, so libraries - would be installed in - /usr/local/lib/mypkg-0.2/ghc-6.4. - - dir may contain the following path - variables: - $pkgid, - $pkg, - $version, - $compiler, - $os, - $arch - - - - - - =dir - - A subdirectory of datadir - in which data files are actually installed. - - dir may contain the following path - variables: - $pkgid, - $pkg, - $version, - $compiler, - $os, - $arch - - - - - - =dir - - Documentation files are installed relative to this directory. - - dir may contain the following path - variables: - $prefix, - $bindir, - $libdir, - $libsubdir, - $datadir, - $datasubdir, - $pkgid, - $pkg, - $version, - $compiler, - $os, - $arch - - - - - - =dir - - HTML documentation files are installed relative to this directory. - - dir may contain the following path - variables: - $prefix, - $bindir, - $libdir, - $libsubdir, - $datadir, - $datasubdir, - $docdir, - $pkgid, - $pkg, - $version, - $compiler, - $os, - $arch - - - - - - =prefix - - Prepend prefix to installed program names. - - prefix may contain the following path - variables: - $pkgid, - $pkg, - $version, - $compiler, - $os, - $arch - - - - - - =suffix - - Append suffix to installed program names. The - most obvious use for this is to append the program's version number to make it - possible to install several versions of a program at once: - --program-suffix='$version'. - - suffix may contain the following path - variables: - $pkgid, - $pkg, - $version, - $compiler, - $os, - $arch - - - - - - - - Path variables in the simple build system - - For the simple build system, there are a number of variables - that can be used when specifying installation paths. The defaults - are also specified in terms of these variables. A number of the - variables are actually for other paths, like - $prefix. This allows paths to be specified - relative to each other rather than as absolute paths, which is - important for building relocatable packages (see - ). - - - - $prefix - - The path variable that stands for the root of the - installation. - For an installation to be relocatable, all other - instllation paths must be relative to the - $prefix variable. - - - - - $bindir - - The path variable that expands to the path given by - the configure option (or the - default). - - - - - $libdir - - As above but for - - - - - $libsubdir - - As above but for - - - - - $datadir - - As above but for - - - - - $datasubdir - - As above but for - - - - - $docdir - - As above but for - - - - - $pkgid - - The name and version of the package, eg - mypkg-0.2 - - - - - $pkg - - The name of the package, eg - mypkg - - - - - $version - - The version of the package, eg - 0.2 - - - - - $compiler - - The compiler being used to build the package, eg - ghc-6.6.1 - - - - - $os - - The operating system of the computer being used to build - the package, eg linux, - windows, osx, - freebsd or solaris - - - - - $arch - - The architecture of the computer being used to build the - package, eg i386, x86_64, - ppc or sparc - - - - - - - - Paths in the simple build system - - For the simple build system, the following defaults - apply: - - - - - - - - - - Option - Windows Default - Unix Default - - - - - --prefix (global installs with the - --global flag) - C:\Program Files\Haskell - /usr/local - - - --prefix (per-user installs with - the --user flag) - C:\Documents And Settings\user\Application Data\cabal - $HOME/.cabal - - - - --bindir - $prefix\bin - $prefix/bin - - - - --libdir - $prefix - $prefix/lib - - - - --libsubdir (Hugs) - hugs\packages\$pkg - hugs/packages/$pkg - - - - --libsubdir (others) - $pkgid\$compiler - $pkgid/$compiler - - - - --libexecdir - $prefix\$pkgid - $prefix/libexec - - - - --datadir (executable) - $prefix - $prefix/share - - - - --datadir (library) - C:\Program Files\Haskell - $prefix/share - - - - --datasubdir - $pkgid - $pkgid - - - - --docdir - $prefix\doc\$pkgid - $datadir/doc/$pkgid - - - - --htmldir - $docdir\html - $docdir/html - - - - --program-prefix - (empty) - (empty) - - - - --program-suffix - (empty) - (empty) - - - - - - - - Prefix-independence - - On Windows, and when using Hugs on any system, it is - possible to obtain the pathname of the running program. - This means that we can construct an installable executable - package that is independent of its absolute install location. - The executable can find its auxiliary files by finding its - own path and knowing the location of the other files relative - to bindir. Prefix-independence is - particularly useful: it means the user can choose the install - location (i.e. the value of prefix) - at install-time, rather than having to bake the path into - the binary when it is built. - - In order to achieve this, we require - that for an executable on Windows, all - of bindir, - libdir, - datadir and - libexecdir begin with - $prefix. If this is not the case - then the compiled executable will have baked in - all absolute paths. - - The application need do nothing special to achieve - prefix-independence. If it finds any files using - getDataFileName and the other functions - provided for the purpose (see ), - the files will be accessed relative to the location of the - current executable. - - A library cannot (currently) be prefix-independent, - because it will be linked into an executable whose - file system location bears no relation to the library - package. - - - - - Controlling Flag Assignments - Flag assignments (see ) can be - controlled with the following command line options. - - - flagname or - -flagname - - Force the specified flag to - true or false (if - preceded with a -). Later - specifications for the same flags will override earlier, - i.e., specifying -fdebug -f-debug is - equivalent to -f-debug - - - - =flagspecs - - Same as , but allows specifying - multiple flag assignments at once. The parameter is a - space-separated list of flag names (to force a flag to - true), optionally preceded by a - - (to force a flag to - false). For example, - --flags="debug -feature1 feature2" is - equivalent to -fdebug -f-feature1 - -ffeature2. - - - - - - - - Miscellaneous options - - - - - - Does a per-user installation. This changes the default - installation prefix (see ). - It also allow dependencies to be satisfied by the user's - package database, in addition to the global database. - - This also implies a default of - for any subsequent install command, - as packages registered in the global database should not - depend on packages registered in a user's database. - - - - - - - (default) Does a global installation. In this case - package dependencies must be satisfied by the global - package database. All packages in the user's package database - will be ignored. Typically the final instllation step will - require administrative privileges. - - - - - =db - - Allows package dependencies to be satisfied from this - additional package database db in - addition to the global package database. All packages in the - user's package database will be ignored. The interpretation - of db is implementation-specific. - Typically it will be a file or directory. Not all - implementations support arbitrary package databases. - - - - - - [=n] or [n] - - (default) Build with optimization flags (if available). - This is appropriate for production use, taking more time - to build faster libraries and programs. - - The optional n value is the - optimisation level. Some compilers support multiple - optimisation levels. The range is 0 to 2. Level 0 is - equivalent to , - level 1 is the default if no n - parameter is given. Level 2 is higher optimisation if the - compiler supports it. Level 2 is likely to lead to longer - compile times and bigger generated code. - - - - - - - - Build without optimization. This is suited for - development: building will be quicker, but the resulting - library or programs will be slower. - - - - - or - - - Request that an additional version of the library - with profiling features enabled be built and installed - (only for implementations that support profiling). - - - - - - - (default) Do not generate an additional profiling - version of the library. - - - - - - - Any executables generated should have profiling enabled - (only for implementations that support profiling). For this - to work, all libraries used by these executables must also - have been built with profiling support. - - - - - - - (default) Do not enable profiling in generated - executables. - - - - - - - (default) Build ordinary libraries (as opposed to profiling - libraries). This is independent of the - option. If you - enable both, you get both. - - - - - - - Do not build ordinary libraries. This is useful - in conjunction with - to build only profiling libraries, rather than profiling and - ordinary libraries. - - - - - - - (default) Build libraries suitable for use with GHCi. - - - - - - - Not all platforms support GHCi and indeed on some - platforms, trying to build GHCi libs fails. In such cases - this flag can be used as a workaround. - - - - - - - Use the GHC feature when - building the library. This reduces the final size of the - executables that use the library by allowing them to link with - only the bits that they use rather than the entire library. - The downside is that building the library takes longer and uses - considerably more memory. - - - - - - - (default) Do not use the GHC - feature. This makes building the library quicker but the final - executables that use the library will be larger. - - - - - - - - (default) When installing binary executable programs, run the - strip program on the binary. This can - considerably reduce the size of the executable binary file. It - does this by removing debugging information and symbols. While - such extra information is useful for debugging C programs with - traditional debuggers it is rarely helpful for debugging - binaries produced by Haskell compilers. - - - Not all Haskell implementations generate native binaries. For - such implementations this option has no effect. - - - - - - - - - Do not strip binary executables during installation. You - might want to use this option if you need to debug a program - using gdb, for example if you want to debug the C parts of a - program containing both Haskell and C code. Another reason is - if your are building a package for a system which has a policy - of managing the stripping itself (such as some linux - distributions). - - - - - - - - Build shared library. This implies a seperate - compiler run to generate position independent code as - required on most platforms. - - - - - - - - (default) Do not build shared library. - - - - - - =str - - An extra option to an external - configure script, - if one is used (see ). - There can be several of these options. - - - - - - [=dir] - - - An extra directory to search for C header files. You can use - this flag multiple times to get a list of directories. - - - You might need to use this flag if you have standard system - header files in a non-standard location that is not mentioned - in the package's .cabal file. Using this - option has the same affect as appending the directory - dir to the - include-dirs field in each library and - executable in the package's .cabal file. - The advantage of course is that you do not have to modify the - package at all. These extra directories will be used while - building the package and for libraries it is also saved in the - package registration information and used when compiling - modules that use the library. - - - - - - - [=dir] - - - An extra directory to search for system libraries files. You - can use this flag multiple times to get a list of directories. - - - You might need to use this flag if you have standard system - libraries in a non-standard location that is not mentioned - in the package's .cabal file. Using this - option has the same affect as appending the directory - dir to the - extra-lib-dirs field in each library and - executable in the package's .cabal file. - The advantage of course is that you do not have to modify the - package at all. These extra directories will be used while - building the package and for libraries it is also saved in the - package registration information and used when compiling - modules that use the library. - - - - - - - In the simple build infrastructure, an additional option - is recognized: - - - =dir - - Specify the directory into which the Hugs output will be - placed (default: dist/scratch). - - - - - - - - - - setup build - Perform any preprocessing or compilation needed to make this - package ready for installation. - - This command takes the following options: - - - - =options - =option - - These are mostly the same as the options configure step (see - ). Unlike the options - specified at the configure step, any program options specified at - the build step are not persistent but are used for that - invocation only. They options specified at the build step are in - addition not in replacement of any options specified at the - configure step. - - - - - - - - - setup makefile - Generate a Makefile that may be used - to compile the Haskell modules to object code. - This command is currently only supported when building libraries, - and only if the compiler is GHC. - - The makefile command replaces part of the work done by - setup build. The sequence of commands would - typically be: - -runhaskell Setup.hs makefile -make -runhaskell Setup.hs build - - where setup makefile does the preprocessing, - make compiles the Haskell modules, and - setup build performs any final steps, such as - building the library archives. - - The Makefile does not use GHC's --make - flag to compile the modules, instead it compiles modules one at - a time, using dependency information generated by GHC's - -M flag. There are two reasons you might - therefore want to use setup makefile: - - - - You want to build in parallel using make -j. - Currently, setup build on its own does not support - building in parallel. - - - You want to build an individual module, pass extra - flags to a compilation, or do other non-standard things that - setup build does not support. - - - - - This command takes the following options: - - - - =filename or - filename - - Specify the output file (default Makefile). - - - - - - - - setup haddock - Build the documentation for the package using &Haddock;. By - default, only the documentation for the exposed modules is generated - (see ). - - This command takes the following options: - - - - - - Generate a file - dist/doc/html/pkgid.txt, - which can be converted by - Hoogle - into a database for searching. This is - equivalent to running &Haddock; with the flag. - - - - - - =url - - Specify a template for the location of HTML documentation - for prerequisite packages. The substitutions listed in - are applied to the template - to obtain a location for each package, which will be used - by hyperlinks in the generated documentation. For example, - the following command generates links pointing at &HackageDB; - pages: - setup haddock --html-location='http://hackage.haskell.org/packages/archive/$pkg/latest/doc/html' - Here the argument is quoted to prevent substitution - by the shell. - If this option is omitted, the location for each package - is obtained using the package tool (e.g. - ghc-pkg). - - - - - - - Also run &Haddock; for the modules of all the executable - programs. By default &Haddock; is run only on the exported - modules. - - - - - - - Run &Haddock; for the all modules, including unexposed ones, and - make &Haddock; generate documentation for unexported symbols - as well. - - - - - =path - - The argument path denotes a CSS - file, which is passed to &Haddock; and used to set the style of - the generated documentation. This is only needed to override the - default style that &Haddock; uses. - - - - - - - - Generate &Haddock; documentation integrated with &HsColour;. - First, &HsColour; is run to generate colourised code. - Then &Haddock; is run to generate HTML documentation. Each - entity shown in the documentation is linked to its definition in - the colourised code. - - - - - =path - - The argument path denotes a CSS - file, which is passed to &HsColour; as in - -runhaskell Setup.hs hscolour --css=path - - - - - - - - setup hscolour - Produce colourised code in HTML format using &HsColour;. - Colourised code for exported modules is put in - dist/doc/html/pkgid/src. - - This command takes the following options: - - - - - - Also run &HsColour; on the sources of all executable - programs. Colourised code is put in - dist/doc/html/pkgid/executable/src. - - - - - =path - - Copy the CSS file from path to - dist/doc/html/pkgid/src/hscolour.css - for exported modules, or to - dist/doc/html/pkgid/executable/src/hscolour.css - for executable programs. The CSS file defines the actual colours - used to colourise code. Note that the - hscolour.css file is required for the code - to be actually colourised. - - - - - - - setup install - Copy the files into the install locations and (for library - packages) register the package with the compiler, i.e. make the - modules it contains available to programs. - - The install locations are determined by options to - setup configure - (see ). - - This command takes the following options: - - - - - - Register this package in the system-wide database. - (This is the default, unless the - option was supplied to the configure - command.) - - - - - - - Register this package in the user's local package database. - (This is the default if the - option was supplied to the configure - command.) - - - - - - - setup copy - Copy the files without registering them. This command - is mainly of use to those creating binary packages. - - This command takes the following option: - - - - =path - - Specify the directory under which to place - installed files. If this is not given, then the root - directory is assumed. - - - - - - - setup register - Register this package with the compiler, i.e. make the - modules it contains available to programs. This only makes sense - for library packages. Note that the install - command incorporates this action. The main use of this - separate command is in the post-installation step for a binary - package. - - This command takes the following options: - - - - - - Register this package in the system-wide database. - (This is the default.) - - - - - - - Register this package in the user's local package - database. - - - - - - - Instead of registering the package, generate a script - containing commands to perform the registration. On Unix, - this file is called register.sh, on - Windows, register.bat. This script - might be included in a binary bundle, to be run after the - bundle is unpacked on the target system. - - - - - =[path] - - Instead of registering the package, generate a package - registration file. This only applies to compilers that support - package registration files which at the moment is only GHC. - The file should be used with the compiler's mechanism for - registering packages. - This option is mainly intended for packaging systems. If - possible use the option instead - since it is more portable across Haskell implementations. - The path is optional and can be - used to specify a particular output file to generate. Otherwise, - by default the file is the package name and version with a - .conf extension. - - - - - - - Registers the package for use directly from the - build tree, without needing to install it. This can be - useful for testing: there's no need to install the package - after modifying it, just recompile and test. - - This flag does not create a build-tree-local package - database. It still registers the package in one of the - user or global databases. - - However, there are some caveats. It only works with - GHC (currently). It only works if your package doesn't - depend on having any supplemental files installed - plain - Haskell libraries should be fine. - - - - - - - setup unregister - Deregister this package with the compiler. - - This command takes the following options: - - - - - - Deregister this package in the system-wide database. - (This is the default.) - - - - - - - Deregister this package in the user's local package - database. - - - - - - - Instead of deregistering the package, generate a script - containing commands to perform the deregistration. On Unix, - this file is called unregister.sh, on - Windows, unregister.bat. This script - might be included in a binary bundle, to be run on the - target system. - - - - - - - setup clean - Remove any local files created during the - configure, build, - haddock, register or - unregister steps, and also any files and - directories listed in the extra-tmp-files - field. - - This command takes the following options: - - - - or - - Keeps the configuration information so it is not necessary - to run the configure step again before building. - - - - - - - setup test - - Run the test suite specified by the - runTests field of - Distribution.Simple.UserHooks. See &Simple; - for information about creating hooks and using - defaultMainWithHooks. - - - - - setup sdist - Create a system- and compiler-independent source distribution - in a file - package-version.tar.gz - in the dist subdirectory, for distribution - to package builders. When unpacked, the commands listed in this - section will be available. - - The files placed in this distribution are the package - description file, the setup script, the sources of the modules - named in the package description file, and files named in the - license-file, main-is, - c-sources, data-files and - extra-source-files fields. - - This command takes the following option: - - - - - - Append today's date - (in YYYYMMDD form) to the version - number for the generated source package. The original - package is unaffected. - - - - - - - - Reporting bugs and deficiencies - - Please report any flaws or feature requests in the - bug - tracker. - - - For general discussion or queries email the libraries mailing list - libraries@haskell.org. There is also a development mailing - list cabal-devel@haskell.org. - - - - - Stability of Cabal interfaces - - The Cabal library and related infrastructure is still under active - development. New features are being added and limitations and bugs are - being fixed. This requires internal changes and often user visible - changes as well. We therefor cannot promise complete future-proof - stability, at least not without halting all development work. - - This section documents the aspects of the Cabal interface that we can - promise to keep stable and which bits are subject to change. - - - Cabal file format - - This is backwards compatible and mostly forwards compatible. - New fields can be added without breaking older versions of Cabal. - Fields can be deprecated without breaking older packages. - - - - - Command-line interface - - Very Stable Command-line interfaces - - - - - ./setup configure - - --prefix - --user - --ghc, --hugs - --verbose - --prefix - - - - ./setup build - ./setup install - ./setup register - ./setup copy - - - - - Stable Command-line interfaces - - - - - Unstable command-line - - - - - - Functions and Types - - The Cabal library follows the Package - Versioning Policy. This means that within a stable major - release, for example 1.2.x, there will be no incompatible API changes. - But minor versions increments, for example 1.2.3, indicate compatible - API additions. - - - - The Package Versioning Policy does not require any API guarantees - between major releases, for example between 1.2.x and 1.4.x. In - practise of course not everything changes between major releases. Some - parts of the API are more prone to change than others. The rest of this - section gives some informal advice on what level of API stability you - can expect between major releases. - - - - Very Stable API - - defaultMain - - - defaultMainWithHooks defaultUserHooks - - - But regular defaultMainWithHooks isn't stable - since UserHooks changes. - - - - - - - Semi-stable API - - - - UserHooks The hooks API will change in the - future - - - Distribution.* - is mostly declarative information about packages and is somewhat - stable. - - - - - - - Unstable API - - Everything under - Distribution.Simple.* - has no stability guarantee. - - - - - - Hackage - - The index format is a partly stable interface. It consists of a tar.gz - file that contains directories with .cabal files - in. In future it may contain more kinds of files so do not assume every - file is a .cabal file. Incompatible revisions to - the format would involve bumping the name of the index file, i.e., - 00-index.tar.gz, - 01-index.tar.gz etc. - - - - - -
    diff -Nru ghc-7.0.3/libraries/Cabal/doc/ghc.mk ghc-7.2.1/libraries/Cabal/doc/ghc.mk --- ghc-7.0.3/libraries/Cabal/doc/ghc.mk 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/doc/ghc.mk 1970-01-01 00:00:00.000000000 +0000 @@ -1,5 +0,0 @@ - -libraries/Cabal/doc_DOCBOOK_SOURCES := $(wildcard libraries/Cabal/doc/*.xml) - -$(eval $(call docbook,libraries/Cabal/doc,Cabal)) - diff -Nru ghc-7.0.3/libraries/Cabal/doc/Makefile ghc-7.2.1/libraries/Cabal/doc/Makefile --- ghc-7.0.3/libraries/Cabal/doc/Makefile 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/doc/Makefile 1970-01-01 00:00:00.000000000 +0000 @@ -1,32 +0,0 @@ -TOP = ../../.. - -ifeq "$(findstring boilerplate.mk, $(wildcard $(TOP)/mk/*))" "" -# ---------------------------------------------------------------------------- -# Standalone Makefile: - -.PHONY: all - -all: Cabal.pdf - -Cabal.pdf: Cabal.xml - docbook2pdf Cabal.xml - -clean: - rm -fr *~ API users-guide Cabal.pdf Cabal.dvi semantic.cache - -else # boilerplate.mk exists -# ---------------------------------------------------------------------------- -# GHC build tree Makefile: - -include $(TOP)/mk/boilerplate.mk - -DOC_SUBDIR=libraries/Cabal/doc -XML_DOC = Cabal -INSTALL_XML_DOC = $(XML_DOC) - -binary-dist: - @: - -include $(TOP)/mk/target.mk - -endif diff -Nru ghc-7.0.3/libraries/Cabal/ghc.mk ghc-7.2.1/libraries/Cabal/ghc.mk --- ghc-7.0.3/libraries/Cabal/ghc.mk 2011-03-26 18:10:45.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/ghc.mk 1970-01-01 00:00:00.000000000 +0000 @@ -1,3 +0,0 @@ -libraries/Cabal_PACKAGE = Cabal -libraries/Cabal_dist-install_GROUP = libraries -$(eval $(call build-package,libraries/Cabal,dist-install,$(if $(filter Cabal,$(STAGE2_PACKAGES)),2,1))) diff -Nru ghc-7.0.3/libraries/Cabal/ghc-packages ghc-7.2.1/libraries/Cabal/ghc-packages --- ghc-7.0.3/libraries/Cabal/ghc-packages 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/ghc-packages 2011-08-07 17:10:08.000000000 +0000 @@ -0,0 +1,2 @@ +cabal + diff -Nru ghc-7.0.3/libraries/Cabal/GNUmakefile ghc-7.2.1/libraries/Cabal/GNUmakefile --- ghc-7.0.3/libraries/Cabal/GNUmakefile 2011-03-26 18:10:45.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/GNUmakefile 1970-01-01 00:00:00.000000000 +0000 @@ -1,4 +0,0 @@ -dir = libraries/Cabal -TOP = ../.. -include $(TOP)/mk/sub-makefile.mk -FAST_MAKE_OPTS += stage=0 diff -Nru ghc-7.0.3/libraries/Cabal/Language/Haskell/Extension.hs ghc-7.2.1/libraries/Cabal/Language/Haskell/Extension.hs --- ghc-7.0.3/libraries/Cabal/Language/Haskell/Extension.hs 2011-03-26 18:10:12.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/Language/Haskell/Extension.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,547 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Language.Haskell.Extension --- Copyright : Isaac Jones 2003-2004 --- --- Maintainer : libraries@haskell.org --- Portability : portable --- --- Haskell language dialects and extensions - -{- All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Isaac Jones nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} - -module Language.Haskell.Extension ( - Language(..), - knownLanguages, - - Extension(..), - knownExtensions, - deprecatedExtensions - ) where - -import Distribution.Text (Text(..)) -import qualified Distribution.Compat.ReadP as Parse -import qualified Text.PrettyPrint as Disp -import qualified Data.Char as Char (isAlphaNum) -import Data.Array (Array, accumArray, bounds, Ix(inRange), (!)) - --- ------------------------------------------------------------ --- * Language --- ------------------------------------------------------------ - --- | This represents a Haskell language dialect. --- --- Language 'Extension's are interpreted relative to one of these base --- languages. --- -data Language = - - -- | The Haskell 98 language as defined by the Haskell 98 report. - -- - Haskell98 - - -- | The Haskell 2010 language as defined by the Haskell 2010 report. - -- - | Haskell2010 - - -- | An unknown language, identified by its name. - | UnknownLanguage String - deriving (Show, Read, Eq) - -knownLanguages :: [Language] -knownLanguages = [Haskell98, Haskell2010] - -instance Text Language where - disp (UnknownLanguage other) = Disp.text other - disp other = Disp.text (show other) - - parse = do - lang <- Parse.munch1 Char.isAlphaNum - return (classifyLanguage lang) - -classifyLanguage :: String -> Language -classifyLanguage = \str -> case lookup str langTable of - Just lang -> lang - Nothing -> UnknownLanguage str - where - langTable = [ (show lang, lang) - | lang <- knownLanguages ] - --- ------------------------------------------------------------ --- * Extension --- ------------------------------------------------------------ - --- Note: if you add a new 'Extension': --- --- * also add it to the Distribution.Simple.X.languageExtensions lists --- (where X is each compiler: GHC, JHC, Hugs, NHC) --- --- * also to the 'knownExtensions' list below. - --- | This represents language extensions beyond a base 'Language' definition --- (such as 'Haskell98') that are supported by some implementations, usually --- in some special mode. --- --- Where applicable, references are given to an implementation's --- official documentation, e.g. \"GHC § 7.2.1\" for an extension --- documented in section 7.2.1 of the GHC User's Guide. - -data Extension = - - -- | [GHC § 7.6.3.4] Allow overlapping class instances, - -- provided there is a unique most specific instance for each use. - OverlappingInstances - - -- | [GHC § 7.6.3.3] Ignore structural rules guaranteeing the - -- termination of class instance resolution. Termination is - -- guaranteed by a fixed-depth recursion stack, and compilation - -- may fail if this depth is exceeded. - | UndecidableInstances - - -- | [GHC § 7.6.3.4] Implies 'OverlappingInstances'. Allow the - -- implementation to choose an instance even when it is possible - -- that further instantiation of types will lead to a more specific - -- instance being applicable. - | IncoherentInstances - - -- | [GHC § 7.3.8] Allows recursive bindings in @do@ blocks, - -- using the @rec@ keyword. - | DoRec - - -- | [GHC § 7.3.8.2] Deprecated in GHC. Allows recursive bindings - -- using @mdo@, a variant of @do@. @DoRec@ provides a different, - -- preferred syntax. - | RecursiveDo - - -- | [GHC § 7.3.9] Provide syntax for writing list - -- comprehensions which iterate over several lists together, like - -- the 'zipWith' family of functions. - | ParallelListComp - - -- | [GHC § 7.6.1.1] Allow multiple parameters in a type class. - | MultiParamTypeClasses - - -- | [GHC § 7.17] Disable the dreaded monomorphism restriction. - | NoMonomorphismRestriction - - -- | [GHC § 7.6.2] Allow a specification attached to a - -- multi-parameter type class which indicates that some parameters - -- are entirely determined by others. The implementation will check - -- that this property holds for the declared instances, and will use - -- this property to reduce ambiguity in instance resolution. - | FunctionalDependencies - - -- | [GHC § 7.8.5] Like 'RankNTypes' but does not allow a - -- higher-rank type to itself appear on the left of a function - -- arrow. - | Rank2Types - - -- | [GHC § 7.8.5] Allow a universally-quantified type to occur on - -- the left of a function arrow. - | RankNTypes - - -- | [GHC § 7.8.5] Allow data constructors to have polymorphic - -- arguments. Unlike 'RankNTypes', does not allow this for ordinary - -- functions. - | PolymorphicComponents - - -- | [GHC § 7.4.4] Allow existentially-quantified data constructors. - | ExistentialQuantification - - -- | [GHC § 7.8.7] Cause a type variable in a signature, which has an - -- explicit @forall@ quantifier, to scope over the definition of the - -- accompanying value declaration. - | ScopedTypeVariables - - -- | Deprecated, use 'ScopedTypeVariables' instead. - | PatternSignatures - - -- | [GHC § 7.8.3] Enable implicit function parameters with dynamic - -- scope. - | ImplicitParams - - -- | [GHC § 7.8.2] Relax some restrictions on the form of the context - -- of a type signature. - | FlexibleContexts - - -- | [GHC § 7.6.3.2] Relax some restrictions on the form of the - -- context of an instance declaration. - | FlexibleInstances - - -- | [GHC § 7.4.1] Allow data type declarations with no constructors. - | EmptyDataDecls - - -- | [GHC § 4.10.3] Run the C preprocessor on Haskell source code. - | CPP - - -- | [GHC § 7.8.4] Allow an explicit kind signature giving the kind of - -- types over which a type variable ranges. - | KindSignatures - - -- | [GHC § 7.11] Enable a form of pattern which forces evaluation - -- before an attempted match, and a form of strict @let@/@where@ - -- binding. - | BangPatterns - - -- | [GHC § 7.6.3.1] Allow type synonyms in instance heads. - | TypeSynonymInstances - - -- | [GHC § 7.9] Enable Template Haskell, a system for compile-time - -- metaprogramming. - | TemplateHaskell - - -- | [GHC § 8] Enable the Foreign Function Interface. In GHC, - -- implements the standard Haskell 98 Foreign Function Interface - -- Addendum, plus some GHC-specific extensions. - | ForeignFunctionInterface - - -- | [GHC § 7.10] Enable arrow notation. - | Arrows - - -- | [GHC § 7.16] Enable generic type classes, with default instances - -- defined in terms of the algebraic structure of a type. - | Generics - - -- | [GHC § 7.3.11] Disable the implicit importing of the module - -- @Prelude@. When desugaring certain built-in syntax into ordinary - -- identifiers, use whatever is in scope rather than the @Prelude@ - -- version. - | NoImplicitPrelude - - -- | [GHC § 7.3.15] Enable syntax for implicitly binding local names - -- corresponding to the field names of a record. Puns bind specific - -- names, unlike 'RecordWildCards'. - | NamedFieldPuns - - -- | [GHC § 7.3.5] Enable a form of guard which matches a pattern and - -- binds variables. - | PatternGuards - - -- | [GHC § 7.5.4] Allow a type declared with @newtype@ to use - -- @deriving@ for any class with an instance for the underlying type. - | GeneralizedNewtypeDeriving - - -- | [Hugs § 7.1] Enable the \"Trex\" extensible records system. - | ExtensibleRecords - - -- | [Hugs § 7.2] Enable type synonyms which are transparent in - -- some definitions and opaque elsewhere, as a way of implementing - -- abstract datatypes. - | RestrictedTypeSynonyms - - -- | [Hugs § 7.3] Enable an alternate syntax for string literals, - -- with string templating. - | HereDocuments - - -- | [GHC § 7.3.2] Allow the character @#@ as a postfix modifier on - -- identifiers. Also enables literal syntax for unboxed values. - | MagicHash - - -- | [GHC § 7.7] Allow data types and type synonyms which are - -- indexed by types, i.e. ad-hoc polymorphism for types. - | TypeFamilies - - -- | [GHC § 7.5.2] Allow a standalone declaration which invokes the - -- type class @deriving@ mechanism. - | StandaloneDeriving - - -- | [GHC § 7.3.1] Allow certain Unicode characters to stand for - -- certain ASCII character sequences, e.g. keywords and punctuation. - | UnicodeSyntax - - -- | [GHC § 8.1.1] Allow the use of unboxed types as foreign types, - -- e.g. in @foreign import@ and @foreign export@. - | UnliftedFFITypes - - -- | [GHC § 7.4.3] Defer validity checking of types until after - -- expanding type synonyms, relaxing the constraints on how synonyms - -- may be used. - | LiberalTypeSynonyms - - -- | [GHC § 7.4.2] Allow the name of a type constructor, type class, - -- or type variable to be an infix operator. - | TypeOperators - ---PArr -- not ready yet, and will probably be renamed to ParallelArrays - - -- | [GHC § 7.3.16] Enable syntax for implicitly binding local names - -- corresponding to the field names of a record. A wildcard binds - -- all unmentioned names, unlike 'NamedFieldPuns'. - | RecordWildCards - - -- | Deprecated, use 'NamedFieldPuns' instead. - | RecordPuns - - -- | [GHC § 7.3.14] Allow a record field name to be disambiguated - -- by the type of the record it's in. - | DisambiguateRecordFields - - -- | [GHC § 7.6.4] Enable overloading of string literals using a - -- type class, much like integer literals. - | OverloadedStrings - - -- | [GHC § 7.4.6] Enable generalized algebraic data types, in - -- which type variables may be instantiated on a per-constructor - -- basis. Enables \"GADT syntax\" which can be used to declare - -- GADTs as well as ordinary algebraic types. - | GADTs - - -- | [GHC § 7.17.2] Allow pattern bindings to be polymorphic. - | NoMonoPatBinds - - -- | [GHC § 7.8.8] Relax the requirements on mutually-recursive - -- polymorphic functions. - | RelaxedPolyRec - - -- | [GHC § 2.4.5] Allow default instantiation of polymorphic - -- types in more situations. - | ExtendedDefaultRules - - -- | [GHC § 7.2.2] Enable unboxed tuples. - | UnboxedTuples - - -- | [GHC § 7.5.3] Enable @deriving@ for classes - -- @Data.Typeable.Typeable@ and @Data.Generics.Data@. - | DeriveDataTypeable - - -- | [GHC § 7.6.1.3] Allow a class method's type to place - -- additional constraints on a class type variable. - | ConstrainedClassMethods - - -- | [GHC § 7.3.18] Allow imports to be qualified by the package - -- name the module is intended to be imported from, e.g. - -- - -- > import "network" Network.Socket - | PackageImports - - -- | [GHC § 7.8.6] Deprecated in GHC 6.12 and will be removed in - -- GHC 7. Allow a type variable to be instantiated at a - -- polymorphic type. - | ImpredicativeTypes - - -- | [GHC § 7.3.3] Change the syntax for qualified infix - -- operators. - | NewQualifiedOperators - - -- | [GHC § 7.3.12] Relax the interpretation of left operator - -- sections to allow unary postfix operators. - | PostfixOperators - - -- | [GHC § 7.9.5] Enable quasi-quotation, a mechanism for defining - -- new concrete syntax for expressions and patterns. - | QuasiQuotes - - -- | [GHC § 7.3.10] Enable generalized list comprehensions, - -- supporting operations such as sorting and grouping. - | TransformListComp - - -- | [GHC § 7.3.6] Enable view patterns, which match a value by - -- applying a function and matching on the result. - | ViewPatterns - - -- | Allow concrete XML syntax to be used in expressions and patterns, - -- as per the Haskell Server Pages extension language: - -- . The ideas behind it are - -- discussed in the paper \"Haskell Server Pages through Dynamic Loading\" - -- by Niklas Broberg, from Haskell Workshop '05. - | XmlSyntax - - -- | Allow regular pattern matching over lists, as discussed in the - -- paper \"Regular Expression Patterns\" by Niklas Broberg, Andreas Farre - -- and Josef Svenningsson, from ICFP '04. - | RegularPatterns - - -- | Enables the use of tuple sections, e.g. @(, True)@ desugars into - -- @\x -> (x, True)@. - | TupleSections - - -- | Allows GHC primops, written in C--, to be imported into a Haskell - -- file. - | GHCForeignImportPrim - - -- | Support for patterns of the form @n + k@, where @k@ is an - -- integer literal. - | NPlusKPatterns - - -- | Improve the layout rule when @if@ expressions are used in a @do@ - -- block. - | DoAndIfThenElse - - -- | Makes much of the Haskell sugar be desugared into calls to the - -- function with a particular name that is in scope. - | RebindableSyntax - - -- | Make @forall@ a keyword in types, which can be used to give the - -- generalisation explicitly. - | ExplicitForAll - - -- | Allow contexts to be put on datatypes, e.g. the @Eq a@ in - -- @data Eq a => Set a = NilSet | ConsSet a (Set a)@. - | DatatypeContexts - - -- | Local (@let@ and @where@) bindings are monomorphic. - | MonoLocalBinds - - -- | Enable @deriving@ for the @Data.Functor.Functor@ class. - | DeriveFunctor - - -- | Enable @deriving@ for the @Data.Traversable.Traversable@ class. - | DeriveTraversable - - -- | Enable @deriving@ for the @Data.Foldable.Foldable@ class. - | DeriveFoldable - - -- | An unknown extension, identified by the name of its @LANGUAGE@ - -- pragma. - | UnknownExtension String - deriving (Show, Read, Eq) - --- | Extensions that have been deprecated, possibly paired with another --- extension that replaces it. --- -deprecatedExtensions :: [(Extension, Maybe Extension)] -deprecatedExtensions = - [ (RecordPuns, Just NamedFieldPuns) - , (PatternSignatures, Just ScopedTypeVariables) - ] - -knownExtensions :: [Extension] -knownExtensions = - [ OverlappingInstances - , UndecidableInstances - , IncoherentInstances - , DoRec - , RecursiveDo - , ParallelListComp - , MultiParamTypeClasses - , NoMonomorphismRestriction - , FunctionalDependencies - , Rank2Types - , RankNTypes - , PolymorphicComponents - , ExistentialQuantification - , ScopedTypeVariables - , ImplicitParams - , FlexibleContexts - , FlexibleInstances - , EmptyDataDecls - , CPP - - , KindSignatures - , BangPatterns - , TypeSynonymInstances - , TemplateHaskell - , ForeignFunctionInterface - , Arrows - , Generics - , NoImplicitPrelude - , NamedFieldPuns - , PatternGuards - , GeneralizedNewtypeDeriving - - , ExtensibleRecords - , RestrictedTypeSynonyms - , HereDocuments - , MagicHash - , TypeFamilies - , StandaloneDeriving - - , UnicodeSyntax - , PatternSignatures - , UnliftedFFITypes - , LiberalTypeSynonyms - , TypeOperators ---PArr -- not ready yet, and will probably be renamed to ParallelArrays - , RecordWildCards - , RecordPuns - , DisambiguateRecordFields - , OverloadedStrings - , GADTs - , NoMonoPatBinds - , RelaxedPolyRec - , ExtendedDefaultRules - , UnboxedTuples - , DeriveDataTypeable - , ConstrainedClassMethods - , PackageImports - , ImpredicativeTypes - , NewQualifiedOperators - , PostfixOperators - , QuasiQuotes - , TransformListComp - , ViewPatterns - , XmlSyntax - , RegularPatterns - - , TupleSections - , GHCForeignImportPrim - , NPlusKPatterns - , DoAndIfThenElse - , RebindableSyntax - , ExplicitForAll - , DatatypeContexts - , MonoLocalBinds - , DeriveFunctor - , DeriveTraversable - , DeriveFoldable - ] - -instance Text Extension where - disp (UnknownExtension other) = Disp.text other - disp other = Disp.text (show other) - - parse = do - extension <- Parse.munch1 Char.isAlphaNum - return (classifyExtension extension) - --- | 'read' for 'Extension's is really really slow so for the Text instance --- what we do is make a simple table indexed off the first letter in the --- extension name. The extension names actually cover the range @'A'-'Z'@ --- pretty densely and the biggest bucket is 7 so it's not too bad. We just do --- a linear search within each bucket. --- --- This gives an order of magnitude improvement in parsing speed, and it'll --- also allow us to do case insensitive matches in future if we prefer. --- -classifyExtension :: String -> Extension -classifyExtension string@(c:_) - | inRange (bounds extensionTable) c - = case lookup string (extensionTable ! c) of - Just extension -> extension - Nothing -> UnknownExtension string -classifyExtension string = UnknownExtension string - -extensionTable :: Array Char [(String, Extension)] -extensionTable = - accumArray (flip (:)) [] ('A', 'Z') - [ (head str, (str, extension)) - | extension <- knownExtensions - , let str = show extension ] diff -Nru ghc-7.0.3/libraries/Cabal/LICENSE ghc-7.2.1/libraries/Cabal/LICENSE --- ghc-7.0.3/libraries/Cabal/LICENSE 2011-03-26 18:10:12.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/LICENSE 2011-08-07 17:10:08.000000000 +0000 @@ -1,7 +1,7 @@ -Copyright (c) 2003-2008, Isaac Jones, Simon Marlow, Martin Sjögren, - Bjorn Bringert, Krasimir Angelov, - Malcolm Wallace, Ross Patterson, Ian Lynagh, - Duncan Coutts, Thomas Schilling +Copyright (c) 2011, Duncan Coutts and Ian Lynagh. + +See */LICENSE for the copyright holders of the subcomponents. + All rights reserved. Redistribution and use in source and binary forms, with or without diff -Nru ghc-7.0.3/libraries/Cabal/Makefile ghc-7.2.1/libraries/Cabal/Makefile --- ghc-7.0.3/libraries/Cabal/Makefile 2011-03-26 18:10:12.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/Makefile 1970-01-01 00:00:00.000000000 +0000 @@ -1,130 +0,0 @@ - -VERSION=1.10.1.0 - -#KIND=devel -KIND=rc -#KIND=latest - -PREFIX=/usr/local -HC=ghc -GHCFLAGS=-Wall - -all: build - -# build the library itself - -SOURCES=Distribution/*.hs Distribution/Simple/*.hs Distribution/PackageDescription/*.hs Distribution/Simple/GHC/*.hs Distribution/Simple/Build/*.hs Distribution/Compat/*.hs Distribution/Simple/Program/*.hs -CONFIG_STAMP=dist/setup-config -BUILD_STAMP=dist/build/libHSCabal-$(VERSION).a -HADDOCK_STAMP=dist/doc/html/Cabal/index.html -USERGUIDE_STAMP=dist/doc/users-guide/index.html -SDIST_STAMP=dist/Cabal-$(VERSION).tar.gz -DISTLOC=dist/release -DIST_STAMP=$(DISTLOC)/Cabal-$(VERSION).tar.gz - -COMMA=, - -setup: $(SOURCES) Setup.hs - -mkdir -p dist/setup - $(HC) $(GHCFLAGS) --make -i. -odir dist/setup -hidir dist/setup Setup.hs -o setup - -Setup-nhc: - hmake -nhc98 -package base -prelude Setup - -$(CONFIG_STAMP): setup Cabal.cabal - ./setup configure --with-compiler=$(HC) --prefix=$(PREFIX) - -build: $(BUILD_STAMP) -$(BUILD_STAMP): $(CONFIG_STAMP) $(SOURCES) - ./setup build - -install: $(BUILD_STAMP) - ./setup install - -hugsbootstrap: - rm -rf dist/tmp dist/hugs - mkdir -p dist/tmp - mkdir dist/hugs - cp -r Distribution dist/tmp - hugs-package dist/tmp dist/hugs - cp Setup.lhs Cabal.cabal dist/hugs - -hugsinstall: hugsbootstrap - cd dist/hugs && ./Setup.lhs configure --hugs - cd dist/hugs && ./Setup.lhs build - cd dist/hugs && ./Setup.lhs install - -# documentation... - -haddock: $(HADDOCK_STAMP) -$(HADDOCK_STAMP) : $(CONFIG_STAMP) $(BUILD_STAMP) - ./setup haddock - -PANDOC=pandoc -PANDOC_OPTIONS= \ - --standalone \ - --smart \ - --css=$(PANDOC_HTML_CSS) -PANDOC_HTML_OUTDIR=dist/doc/users-guide/ -PANDOC_HTML_CSS=Cabal.css - -users-guide: $(USERGUIDE_STAMP) -$(USERGUIDE_STAMP) : doc/Cabal.markdown - mkdir -p dist/doc/users-guide/ - $(PANDOC) $(PANDOC_OPTIONS) --from=markdown --to=html $< --output $@ - cp doc/$(PANDOC_HTML_CSS) $(PANDOC_HTML_OUTDIR) - -docs: haddock users-guide - -clean: - rm -rf dist/ - rm -f setup - -# testing... - -moduleTest: tests/ModuleTest.hs tests/PackageDescriptionTests.hs - mkdir -p dist/test - $(HC) --make -Wall -DDEBUG -odir dist/test -hidir dist/test \ - -itests tests/ModuleTest.hs -o moduleTest - -#tests: moduleTest clean -# cd tests/A && $(MAKE) clean -# cd tests/HUnit-1.0 && $(MAKE) clean -# cd tests/A && $(MAKE) -# cd tests/HUnit-1.0 && $(MAKE) - -#check: -# rm -f moduleTest -# $(MAKE) moduleTest -# ./moduleTest - -# distribution... - -$(SDIST_STAMP) : $(BUILD_STAMP) - ./setup sdist - -dist: $(DIST_STAMP) -$(DIST_STAMP) : $(HADDOCK_STAMP) $(USERGUIDE_STAMP) $(SDIST_STAMP) - rm -rf $(DISTLOC) - mkdir $(DISTLOC) - tar -xzf $(SDIST_STAMP) -C $(DISTLOC)/ - mkdir $(DISTLOC)/Cabal-$(VERSION)/doc - cp -r dist/doc/html $(DISTLOC)/Cabal-$(VERSION)/doc/API - cp -r dist/doc/users-guide $(DISTLOC)/Cabal-$(VERSION)/doc/ - cp changelog $(DISTLOC)/Cabal-$(VERSION)/ - tar -C $(DISTLOC) -c Cabal-$(VERSION) -zf $(DISTLOC)/Cabal-$(VERSION).tar.gz - mv $(DISTLOC)/Cabal-$(VERSION)/doc $(DISTLOC)/ - mv $(DISTLOC)/Cabal-$(VERSION)/changelog $(DISTLOC)/ - rm -r $(DISTLOC)/Cabal-$(VERSION)/ - @echo "Cabal tarball built: $(DIST_STAMP)" - @echo "Release fileset prepared: $(DISTLOC)/" - -release: $(DIST_STAMP) - scp -r $(DISTLOC) www.haskell.org:/home/haskell/cabal/release/cabal-$(VERSION) - ssh www.haskell.org 'cd /home/haskell/cabal/release && rm -f $(KIND) && ln -s cabal-$(VERSION) $(KIND)' - -# tags... - -TAGSSRCDIRS = Distribution Language -tags TAGS: $(SOURCES) - find $(TAGSSRCDIRS) -name \*.\*hs | xargs hasktags diff -Nru ghc-7.0.3/libraries/Cabal/prologue.txt ghc-7.2.1/libraries/Cabal/prologue.txt --- ghc-7.0.3/libraries/Cabal/prologue.txt 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/prologue.txt 1970-01-01 00:00:00.000000000 +0000 @@ -1,7 +0,0 @@ -The Haskell Cabal is the Common Architecture for Building Applications -and Libraries. It is a framework which defines a common interface for -authors to more easily build their applications in a portable way. The -Haskell Cabal is meant to be a part of a larger infrastructure for -distributing, organizing, and cataloging Haskell Libraries and -Tools. For more information, please see: -. diff -Nru ghc-7.0.3/libraries/Cabal/README ghc-7.2.1/libraries/Cabal/README --- ghc-7.0.3/libraries/Cabal/README 2011-03-26 18:10:12.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/README 2011-08-07 17:10:08.000000000 +0000 @@ -1,168 +1,8 @@ -The Cabal library package -========================= +This Cabal darcs repository contains multiple packages: -[Cabal home page](http://www.haskell.org/cabal/) + * cabal/ -- the Cabal library package + * cabal-install/ -- the cabal-install package containing the 'cabal' tool. -If you also want the `cabal` command line program then you need -the `cabal-install` package in addition to this library. +See the README in each subdir for more details. - -Installation instructions for the Cabal library -=============================================== - -Installing as a user (no root or administer access) ---------------------------------------------------- - - ghc --make Setup - ./Setup configure --user - ./Setup build - ./Setup install - -Note the use of the `--user` flag at the configure step. - -Compiling Setup rather than using `runghc Setup` is much faster and works on -Windows. For all packages other than Cabal itself it is fine to use `runghc`. - -This will install into `$HOME/.cabal/` on unix and into -`$Documents and Settings\$User\Application Data\cabal\` on Windows -If you want to install elsewhere use the `--prefix=` flag at the -configure step. - - -Installing as root / Administrator ----------------------------------- - - ghc --make Setup - ./Setup configure - ./Setup build - sudo ./Setup install - -Compiling Setup rather than using `runghc Setup` is much faster and works on -Windows. For all packages other than Cabal itself it is fine to use `runghc`. - -This will install into `/usr/local` on unix and on Windows it will -install into `$ProgramFiles/Haskell`. If you want to install -elsewhere use the `--prefix=` flag at the configure step. - - -Working with older versions of GHC and Cabal -============================================ - -It is recommended just to leave any pre-existing version of Cabal -installed. In particular it is *essential* to keep the version that -came with GHC itself since other installed packages need it (eg the -"ghc" api package). - -Prior to GHC 6.4.2 however, GHC didn't deal particularly well with -having multiple versions of packages installed at once. So if you -are using GHC 6.4.1 or older and you have an older version of Cabal -installed, you probably just want to remove it: - - ghc-pkg unregister Cabal - -or if you had Cabal installed just for your user account then: - - ghc-pkg unregister Cabal --user - - -The `filepath` dependency -========================= - -Cabal now uses the `filepath` package so that must be installed first. -GHC-6.6.1 and later come with `filepath` however earlier versions do not by -default. If you do not already have `filepath` then you need to install it. You -can use any existing version of Cabal to do that. If you have neither Cabal or -filepath then it is slightly harder but still possible. - -Unpack Cabal and filepath into separate directories. For example: - - tar -xzf filepath-1.1.0.0.tar.gz - tar -xzf Cabal-1.6.0.0.tar.gz - - # rename to make the following instructions simpler: - mv filepath-1.1.0.0/ filepath/ - mv Cabal-1.6.0.0/ Cabal/ - - cd Cabal - ghc -i../filepath -cpp --make Setup.hs -o ../filepath/setup - cd ../filepath/ - ./setup configure --user - ./setup build - ./setup install - -This installs filepath so you are then in a position to install Cabal by the -normal method. - - -More Information -================ - -Please see the web site for the [user guide] and API documentation. -There is some more information available on the [development wiki]. - -[user guide]: http://www.haskell.org/cabal/ -[development wiki]: http://hackage.haskell.org/trac/hackage/ - - -Bugs -======= - -Please report bugs and wish-list items in our [bug tracker]. - -[bug tracker]: http://hackage.haskell.org/trac/hackage/ - - -Your Help ---------- - -To help us in the next round of development work it would be -enormously helpful to know from our users what their most pressing -problems are with Cabal and Hackage. You probably have a favourite -Cabal bug or limitation. Take a look at our [bug tracker]. Make sure -the problem is reported there and properly described. Comment on the -ticket to tell us how much of a problem the bug is for you. Add -yourself to the ticket's cc list so we can discuss requirements and -keep you informed on progress. For feature requests it is very -helpful if there is a description of how you would expect to -interact with the new feature. - - -Code -======= - -You can get the code from the web page; the version control system we -use is very open and welcoming to new developers. - -You can get the main development branch: - -> darcs get --partial http://darcs.haskell.org/cabal - -and you can get the stable 1.6 branch: - -> darcs get --partial http://darcs.haskell.org/cabal-branches/cabal-1.6 - - -Credits -======= - -Cabal Coders (in alphabetical order): - -- Krasimir Angelov -- Bjorn Bringert -- Duncan Coutts -- Isaac Jones -- David Himmelstrup (Lemmih) -- Simon Marlow -- Ross Patterson -- Thomas Schilling -- Martin Sjögren -- Malcolm Wallace -- and nearly 30 other people have contributed occasional patches - -Cabal spec: - -- Isaac Jones -- Simon Marlow -- Ross Patterson -- Simon Peyton Jones -- Malcolm Wallace +The canonical upstream repo lives at http://darcs.haskell.org/cabal/ diff -Nru ghc-7.0.3/libraries/Cabal/runTests.sh ghc-7.2.1/libraries/Cabal/runTests.sh --- ghc-7.0.3/libraries/Cabal/runTests.sh 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/runTests.sh 1970-01-01 00:00:00.000000000 +0000 @@ -1,21 +0,0 @@ -#!/bin/sh - -HCBASE=/usr/bin/ -HC=$HCBASE/ghc -GHCFLAGS='--make -Wall -fno-warn-unused-matches -cpp' -ISPOSIX=-DHAVE_UNIX_PACKAGE - -rm -f moduleTest -mkdir -p dist/debug -echo Building... -$HC $GHCFLAGS $ISPOSIX -DDEBUG -odir dist/debug -hidir dist/debug -idist/debug/:.:tests/HUnit-1.0/src tests/ModuleTest.hs -o moduleTest 2> stderr -RES=$? -if [ $RES != 0 ] -then - cat stderr >&2 - exit $RES -fi -echo Running... -./moduleTest -echo Done - diff -Nru ghc-7.0.3/libraries/Cabal/Setup.hs ghc-7.2.1/libraries/Cabal/Setup.hs --- ghc-7.0.3/libraries/Cabal/Setup.hs 2011-03-26 18:10:12.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/Setup.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,10 +0,0 @@ -import Distribution.Simple -main :: IO () -main = defaultMain - --- Although this looks like the Simple build type, it is in fact vital that --- we use this Setup.hs because it'll get compiled against the local copy --- of the Cabal lib, thus enabling Cabal to bootstrap itself without relying --- on any previous installation. This also means we can use any new features --- immediately because we never have to worry about building Cabal with an --- older version of itself. diff -Nru ghc-7.0.3/libraries/Cabal/tests/hackage/check.sh ghc-7.2.1/libraries/Cabal/tests/hackage/check.sh --- ghc-7.0.3/libraries/Cabal/tests/hackage/check.sh 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/hackage/check.sh 1970-01-01 00:00:00.000000000 +0000 @@ -1,25 +0,0 @@ -#!/bin/sh - -base_version=1.4.0.2 -test_version=1.5.6 - -for setup in archive/*/*/Setup.hs archive/*/*/Setup.lhs; do - - pkgname=$(basename ${setup}) - - if test $(wc -w < ${setup}) -gt 21; then - if ghc -package Cabal-${base_version} -S ${setup} -o /dev/null 2> /dev/null; then - - if ghc -package Cabal-${test_version} -S ${setup} -o /dev/null 2> /dev/null; then - echo "OK ${setup}" - else - echo "FAIL ${setup} does not compile with Cabal-${test_version}" - fi - else - echo "OK ${setup} (does not compile with Cabal-${base_version})" - fi - else - echo "trivial ${setup}" - fi - -done diff -Nru ghc-7.0.3/libraries/Cabal/tests/hackage/download.sh ghc-7.2.1/libraries/Cabal/tests/hackage/download.sh --- ghc-7.0.3/libraries/Cabal/tests/hackage/download.sh 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/hackage/download.sh 1970-01-01 00:00:00.000000000 +0000 @@ -1,19 +0,0 @@ -#!/bin/sh - -if test ! -f archive/archive.tar; then - - wget http://hackage.haskell.org/cgi-bin/hackage-scripts/archive.tar - mkdir -p archive - mv archive.tar archive/ - tar -C archive -xf archive/archive.tar - -fi - -if test ! -f archive/00-index.tar.gz; then - - wget http://hackage.haskell.org/packages/archive/00-index.tar.gz - mkdir -p archive - mv 00-index.tar.gz archive/ - tar -C archive -xzf archive/00-index.tar.gz - -fi diff -Nru ghc-7.0.3/libraries/Cabal/tests/hackage/unpack.sh ghc-7.2.1/libraries/Cabal/tests/hackage/unpack.sh --- ghc-7.0.3/libraries/Cabal/tests/hackage/unpack.sh 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/hackage/unpack.sh 1970-01-01 00:00:00.000000000 +0000 @@ -1,16 +0,0 @@ -#!/bin/sh - -for tarball in archive/*/*/*.tar.gz; do - - pkgdir=$(dirname ${tarball}) - pkgname=$(basename ${tarball} .tar.gz) - - if tar -tzf ${tarball} ${pkgname}/Setup.hs 2> /dev/null; then - tar -xzf ${tarball} ${pkgname}/Setup.hs -O > ${pkgdir}/Setup.hs - elif tar -tzf ${tarball} ${pkgname}/Setup.lhs 2> /dev/null; then - tar -xzf ${tarball} ${pkgname}/Setup.lhs -O > ${pkgdir}/Setup.lhs - else - echo "${pkgname} has no Setup.hs or .lhs at all!!?!" - fi - -done diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Check.hs ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Check.hs --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Check.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Check.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,15 +0,0 @@ -module PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check where - -import Test.HUnit -import PackageTests.PackageTester -import System.FilePath -import Data.List - - -suite :: Test -suite = TestCase $ do - let spec = PackageSpec ("PackageTests" "BuildDeps" "GlobalBuildDepsNotAdditive1") [] - result <- cabal_build spec - assertEqual "cabal build should fail - see test-log.txt" False (successful result) - assertBool "cabal error should be \"Failed to load interface for `Prelude'\"" $ - "Failed to load interface for `Prelude'" `isInfixOf` outputText result diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/GlobalBuildDepsNotAdditive1.cabal ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/GlobalBuildDepsNotAdditive1.cabal --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/GlobalBuildDepsNotAdditive1.cabal 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/GlobalBuildDepsNotAdditive1.cabal 1970-01-01 00:00:00.000000000 +0000 @@ -1,20 +0,0 @@ -name: GlobalBuildDepsNotAdditive1 -version: 0.1 -license: BSD3 -cabal-version: >= 1.6 -author: Stephen Blackheath -stability: stable -category: PackageTests -build-type: Simple - -description: - If you specify 'base' in the global build dependencies, then define - a library without base, it fails to find 'base' for the library. - ---------------------------------------- - -build-depends: base - -Library - exposed-modules: MyLibrary - build-depends: bytestring, old-time diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/MyLibrary.hs ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/MyLibrary.hs --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/MyLibrary.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/MyLibrary.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,10 +0,0 @@ -module MyLibrary where - -import qualified Data.ByteString.Char8 as C -import System.Time - -myLibFunc :: IO () -myLibFunc = do - getClockTime - let text = "myLibFunc" - C.putStrLn $ C.pack text diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Setup.hs ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Setup.hs --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Setup.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Setup.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,3 +0,0 @@ -import Distribution.Simple -main = defaultMain - diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Check.hs ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Check.hs --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Check.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Check.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,15 +0,0 @@ -module PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check where - -import Test.HUnit -import PackageTests.PackageTester -import System.FilePath -import Data.List - - -suite :: Test -suite = TestCase $ do - let spec = PackageSpec ("PackageTests" "BuildDeps" "GlobalBuildDepsNotAdditive2") [] - result <- cabal_build spec - assertEqual "cabal build should fail - see test-log.txt" False (successful result) - assertBool "cabal error should be \"Failed to load interface for `Prelude'\"" $ - "Failed to load interface for `Prelude'" `isInfixOf` outputText result diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/GlobalBuildDepsNotAdditive2.cabal ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/GlobalBuildDepsNotAdditive2.cabal --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/GlobalBuildDepsNotAdditive2.cabal 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/GlobalBuildDepsNotAdditive2.cabal 1970-01-01 00:00:00.000000000 +0000 @@ -1,20 +0,0 @@ -name: GlobalBuildDepsNotAdditive1 -version: 0.1 -license: BSD3 -cabal-version: >= 1.6 -author: Stephen Blackheath -stability: stable -category: PackageTests -build-type: Simple - -description: - If you specify 'base' in the global build dependencies, then define - an executable without base, it fails to find 'base' for the executable - ---------------------------------------- - -build-depends: base - -Executable lemon - main-is: lemon.hs - build-depends: bytestring, old-time diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/lemon.hs ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/lemon.hs --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/lemon.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/lemon.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,7 +0,0 @@ -import qualified Data.ByteString.Char8 as C -import System.Time - -main = do - getClockTime - let text = "lemon" - C.putStrLn $ C.pack text diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Setup.hs ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Setup.hs --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Setup.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Setup.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,3 +0,0 @@ -import Distribution.Simple -main = defaultMain - diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Check.hs ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Check.hs --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Check.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Check.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,20 +0,0 @@ -module PackageTests.BuildDeps.InternalLibrary0.Check where - -import Test.HUnit -import PackageTests.PackageTester -import Control.Monad -import System.FilePath -import Data.Version -import Data.List (isInfixOf, intercalate) - - -suite :: Version -> Test -suite cabalVersion = TestCase $ do - let spec = PackageSpec ("PackageTests" "BuildDeps" "InternalLibrary0") [] - result <- cabal_build spec - assertEqual "cabal build should fail" False (successful result) - when (cabalVersion >= Version [1, 7] []) $ do - -- In 1.7 it should tell you how to enable the desired behaviour. - assertEqual "error should say 'library which is defined within the same package.'" True $ - "library which is defined within the same package." `isInfixOf` (intercalate " " $ lines $ outputText result) - diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/my.cabal ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/my.cabal --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/my.cabal 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/my.cabal 1970-01-01 00:00:00.000000000 +0000 @@ -1,24 +0,0 @@ -name: InternalLibrary0 -version: 0.1 -license: BSD3 -cabal-version: >= 1.6 -author: Stephen Blackheath -stability: stable -category: PackageTests -build-type: Simple - -description: - Check that with 'cabal-version:' containing versions less than 1.7, we do *not* - have the new behaviour to allow executables to refer to the library defined - in the same module. - ---------------------------------------- - -Library - exposed-modules: MyLibrary - build-depends: base, bytestring, old-time - -Executable lemon - main-is: lemon.hs - hs-source-dirs: programs - build-depends: base, bytestring, old-time, InternalLibrary0 diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/MyLibrary.hs ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/MyLibrary.hs --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/MyLibrary.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/MyLibrary.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,10 +0,0 @@ -module MyLibrary where - -import qualified Data.ByteString.Char8 as C -import System.Time - -myLibFunc :: IO () -myLibFunc = do - getClockTime - let text = "myLibFunc" - C.putStrLn $ C.pack text diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/programs/lemon.hs ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/programs/lemon.hs --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/programs/lemon.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/programs/lemon.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,6 +0,0 @@ -import System.Time -import MyLibrary - -main = do - getClockTime - myLibFunc diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Setup.hs ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Setup.hs --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Setup.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Setup.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,3 +0,0 @@ -import Distribution.Simple -main = defaultMain - diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Check.hs ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Check.hs --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Check.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Check.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,12 +0,0 @@ -module PackageTests.BuildDeps.InternalLibrary1.Check where - -import Test.HUnit -import PackageTests.PackageTester -import System.FilePath - - -suite :: Test -suite = TestCase $ do - let spec = PackageSpec ("PackageTests" "BuildDeps" "InternalLibrary1") [] - result <- cabal_build spec - assertEqual "cabal build should succeed - see test-log.txt" True (successful result) diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/my.cabal ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/my.cabal --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/my.cabal 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/my.cabal 1970-01-01 00:00:00.000000000 +0000 @@ -1,23 +0,0 @@ -name: InternalLibrary1 -version: 0.1 -license: BSD3 -cabal-version: >= 1.7.1 -author: Stephen Blackheath -stability: stable -category: PackageTests -build-type: Simple - -description: - Check for the new (in >= 1.7.1) ability to allow executables to refer to - the library defined in the same module. - ---------------------------------------- - -Library - exposed-modules: MyLibrary - build-depends: base, bytestring, old-time - -Executable lemon - main-is: lemon.hs - hs-source-dirs: programs - build-depends: base, bytestring, old-time, InternalLibrary1 diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/MyLibrary.hs ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/MyLibrary.hs --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/MyLibrary.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/MyLibrary.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,10 +0,0 @@ -module MyLibrary where - -import qualified Data.ByteString.Char8 as C -import System.Time - -myLibFunc :: IO () -myLibFunc = do - getClockTime - let text = "myLibFunc" - C.putStrLn $ C.pack text diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/programs/lemon.hs ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/programs/lemon.hs --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/programs/lemon.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/programs/lemon.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,6 +0,0 @@ -import System.Time -import MyLibrary - -main = do - getClockTime - myLibFunc diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Setup.hs ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Setup.hs --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Setup.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Setup.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,3 +0,0 @@ -import Distribution.Simple -main = defaultMain - diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Check.hs ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Check.hs --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Check.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Check.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,24 +0,0 @@ -module PackageTests.BuildDeps.InternalLibrary2.Check where - -import Test.HUnit -import PackageTests.PackageTester -import System.FilePath -import qualified Data.ByteString.Char8 as C - - -suite :: Test -suite = TestCase $ do - let spec = PackageSpec ("PackageTests" "BuildDeps" "InternalLibrary2") [] - let specTI = PackageSpec (directory spec "to-install") [] - - unregister "InternalLibrary2" - iResult <- cabal_install specTI - assertEqual "cabal install should succeed - see to-install/test-log.txt" True (successful iResult) - bResult <- cabal_build spec - assertEqual "cabal build should succeed - see test-log.txt" True (successful bResult) - unregister "InternalLibrary2" - - (_, _, output) <- run (Just $ directory spec) "dist/build/lemon/lemon" [] - C.appendFile (directory spec "test-log.txt") (C.pack $ "\ndist/build/lemon/lemon\n"++output) - assertEqual "executable should have linked with the internal library" "myLibFunc internal" (concat $ lines output) - diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/my.cabal ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/my.cabal --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/my.cabal 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/my.cabal 1970-01-01 00:00:00.000000000 +0000 @@ -1,23 +0,0 @@ -name: InternalLibrary2 -version: 0.1 -license: BSD3 -cabal-version: >= 1.7.1 -author: Stephen Blackheath -stability: stable -category: PackageTests -build-type: Simple - -description: - This test is to make sure that the internal library is preferred by ghc to - an installed one of the same name and version. - ---------------------------------------- - -Library - exposed-modules: MyLibrary - build-depends: base, bytestring, old-time - -Executable lemon - main-is: lemon.hs - hs-source-dirs: programs - build-depends: base, bytestring, old-time, InternalLibrary2 diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/MyLibrary.hs ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/MyLibrary.hs --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/MyLibrary.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/MyLibrary.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,10 +0,0 @@ -module MyLibrary where - -import qualified Data.ByteString.Char8 as C -import System.Time - -myLibFunc :: IO () -myLibFunc = do - getClockTime - let text = "myLibFunc internal" - C.putStrLn $ C.pack text diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/programs/lemon.hs ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/programs/lemon.hs --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/programs/lemon.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/programs/lemon.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,6 +0,0 @@ -import System.Time -import MyLibrary - -main = do - getClockTime - myLibFunc diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Setup.hs ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Setup.hs --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Setup.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Setup.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,3 +0,0 @@ -import Distribution.Simple -main = defaultMain - diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/my.cabal ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/my.cabal --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/my.cabal 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/my.cabal 1970-01-01 00:00:00.000000000 +0000 @@ -1,18 +0,0 @@ -name: InternalLibrary2 -version: 0.1 -license: BSD3 -cabal-version: >= 1.6 -author: Stephen Blackheath -stability: stable -category: PackageTests -build-type: Simple - -description: - This test is to make sure that the internal library is preferred by ghc to - an installed one of the same name and version. - ---------------------------------------- - -Library - exposed-modules: MyLibrary - build-depends: base, bytestring, old-time diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/MyLibrary.hs ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/MyLibrary.hs --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/MyLibrary.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/MyLibrary.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,10 +0,0 @@ -module MyLibrary where - -import qualified Data.ByteString.Char8 as C -import System.Time - -myLibFunc :: IO () -myLibFunc = do - getClockTime - let text = "myLibFunc installed" - C.putStrLn $ C.pack text diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/Setup.hs ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/Setup.hs --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/Setup.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/Setup.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,3 +0,0 @@ -import Distribution.Simple -main = defaultMain - diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Check.hs ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Check.hs --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Check.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Check.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,24 +0,0 @@ -module PackageTests.BuildDeps.InternalLibrary3.Check where - -import Test.HUnit -import PackageTests.PackageTester -import System.FilePath -import qualified Data.ByteString.Char8 as C - - -suite :: Test -suite = TestCase $ do - let spec = PackageSpec ("PackageTests" "BuildDeps" "InternalLibrary3") [] - let specTI = PackageSpec (directory spec "to-install") [] - - unregister "InternalLibrary3" - iResult <- cabal_install specTI - assertEqual "cabal install should succeed - see to-install/test-log.txt" True (successful iResult) - bResult <- cabal_build spec - assertEqual "cabal build should succeed - see test-log.txt" True (successful bResult) - unregister "InternalLibrary3" - - (_, _, output) <- run (Just $ directory spec) "dist/build/lemon/lemon" [] - C.appendFile (directory spec "test-log.txt") (C.pack $ "\ndist/build/lemon/lemon\n"++output) - assertEqual "executable should have linked with the internal library" "myLibFunc internal" (concat $ lines output) - diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/my.cabal ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/my.cabal --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/my.cabal 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/my.cabal 1970-01-01 00:00:00.000000000 +0000 @@ -1,23 +0,0 @@ -name: InternalLibrary3 -version: 0.1 -license: BSD3 -cabal-version: >= 1.7.1 -author: Stephen Blackheath -stability: stable -category: PackageTests -build-type: Simple - -description: - This test is to make sure that the internal library is preferred by ghc to - an installed one of the same name, but a *newer* version. - ---------------------------------------- - -Library - exposed-modules: MyLibrary - build-depends: base, bytestring, old-time - -Executable lemon - main-is: lemon.hs - hs-source-dirs: programs - build-depends: base, bytestring, old-time, InternalLibrary3 diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/MyLibrary.hs ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/MyLibrary.hs --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/MyLibrary.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/MyLibrary.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,10 +0,0 @@ -module MyLibrary where - -import qualified Data.ByteString.Char8 as C -import System.Time - -myLibFunc :: IO () -myLibFunc = do - getClockTime - let text = "myLibFunc internal" - C.putStrLn $ C.pack text diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/programs/lemon.hs ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/programs/lemon.hs --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/programs/lemon.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/programs/lemon.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,6 +0,0 @@ -import System.Time -import MyLibrary - -main = do - getClockTime - myLibFunc diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Setup.hs ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Setup.hs --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Setup.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Setup.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,3 +0,0 @@ -import Distribution.Simple -main = defaultMain - diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/my.cabal ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/my.cabal --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/my.cabal 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/my.cabal 1970-01-01 00:00:00.000000000 +0000 @@ -1,18 +0,0 @@ -name: InternalLibrary3 -version: 0.2 -license: BSD3 -cabal-version: >= 1.6 -author: Stephen Blackheath -stability: stable -category: PackageTests -build-type: Simple - -description: - This test is to make sure that the internal library is preferred by ghc to - an installed one of the same name but a *newer* version. - ---------------------------------------- - -Library - exposed-modules: MyLibrary - build-depends: base, bytestring, old-time diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/MyLibrary.hs ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/MyLibrary.hs --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/MyLibrary.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/MyLibrary.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,10 +0,0 @@ -module MyLibrary where - -import qualified Data.ByteString.Char8 as C -import System.Time - -myLibFunc :: IO () -myLibFunc = do - getClockTime - let text = "myLibFunc installed" - C.putStrLn $ C.pack text diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/Setup.hs ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/Setup.hs --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/Setup.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/Setup.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,3 +0,0 @@ -import Distribution.Simple -main = defaultMain - diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Check.hs ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Check.hs --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Check.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Check.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,24 +0,0 @@ -module PackageTests.BuildDeps.InternalLibrary4.Check where - -import Test.HUnit -import PackageTests.PackageTester -import System.FilePath -import qualified Data.ByteString.Char8 as C - - -suite :: Test -suite = TestCase $ do - let spec = PackageSpec ("PackageTests" "BuildDeps" "InternalLibrary4") [] - let specTI = PackageSpec (directory spec "to-install") [] - - unregister "InternalLibrary4" - iResult <- cabal_install specTI - assertEqual "cabal install should succeed - see to-install/test-log.txt" True (successful iResult) - bResult <- cabal_build spec - assertEqual "cabal build should succeed - see test-log.txt" True (successful bResult) - unregister "InternalLibrary4" - - (_, _, output) <- run (Just $ directory spec) "dist/build/lemon/lemon" [] - C.appendFile (directory spec "test-log.txt") (C.pack $ "\ndist/build/lemon/lemon\n"++output) - assertEqual "executable should have linked with the installed library" "myLibFunc installed" (concat $ lines output) - diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/my.cabal ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/my.cabal --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/my.cabal 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/my.cabal 1970-01-01 00:00:00.000000000 +0000 @@ -1,23 +0,0 @@ -name: InternalLibrary4 -version: 0.1 -license: BSD3 -cabal-version: >= 1.7.1 -author: Stephen Blackheath -stability: stable -category: PackageTests -build-type: Simple - -description: - This test is to make sure that we can explicitly say we want InternalLibrary4-0.2 - and it will give us the *installed* version 0.2 instead of the internal 0.1. - ---------------------------------------- - -Library - exposed-modules: MyLibrary - build-depends: base, bytestring, old-time - -Executable lemon - main-is: lemon.hs - hs-source-dirs: programs - build-depends: base, bytestring, old-time, InternalLibrary4 >= 0.2 diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/MyLibrary.hs ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/MyLibrary.hs --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/MyLibrary.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/MyLibrary.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,10 +0,0 @@ -module MyLibrary where - -import qualified Data.ByteString.Char8 as C -import System.Time - -myLibFunc :: IO () -myLibFunc = do - getClockTime - let text = "myLibFunc internal" - C.putStrLn $ C.pack text diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/programs/lemon.hs ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/programs/lemon.hs --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/programs/lemon.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/programs/lemon.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,6 +0,0 @@ -import System.Time -import MyLibrary - -main = do - getClockTime - myLibFunc diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Setup.hs ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Setup.hs --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Setup.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Setup.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,3 +0,0 @@ -import Distribution.Simple -main = defaultMain - diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/my.cabal ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/my.cabal --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/my.cabal 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/my.cabal 1970-01-01 00:00:00.000000000 +0000 @@ -1,18 +0,0 @@ -name: InternalLibrary4 -version: 0.2 -license: BSD3 -cabal-version: >= 1.6 -author: Stephen Blackheath -stability: stable -category: PackageTests -build-type: Simple - -description: - This test is to make sure that the internal library is preferred by ghc to - an installed one of the same name but a *newer* version. - ---------------------------------------- - -Library - exposed-modules: MyLibrary - build-depends: base, bytestring, old-time diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/MyLibrary.hs ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/MyLibrary.hs --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/MyLibrary.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/MyLibrary.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,10 +0,0 @@ -module MyLibrary where - -import qualified Data.ByteString.Char8 as C -import System.Time - -myLibFunc :: IO () -myLibFunc = do - getClockTime - let text = "myLibFunc installed" - C.putStrLn $ C.pack text diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/Setup.hs ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/Setup.hs --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/Setup.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/Setup.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,3 +0,0 @@ -import Distribution.Simple -main = defaultMain - diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Check.hs ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Check.hs --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Check.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Check.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,12 +0,0 @@ -module PackageTests.BuildDeps.SameDepsAllRound.Check where - -import Test.HUnit -import PackageTests.PackageTester -import System.FilePath - - -suite :: Test -suite = TestCase $ do - let spec = PackageSpec ("PackageTests" "BuildDeps" "SameDepsAllRound") [] - result <- cabal_build spec - assertEqual "cabal build should succeed - see test-log.txt" True (successful result) diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/lemon.hs ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/lemon.hs --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/lemon.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/lemon.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,7 +0,0 @@ -import qualified Data.ByteString.Char8 as C -import System.Time - -main = do - getClockTime - let text = "lemon" - C.putStrLn $ C.pack text diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/MyLibrary.hs ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/MyLibrary.hs --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/MyLibrary.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/MyLibrary.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,10 +0,0 @@ -module MyLibrary where - -import qualified Data.ByteString.Char8 as C -import System.Time - -myLibFunc :: IO () -myLibFunc = do - getClockTime - let text = "myLibFunc" - C.putStrLn $ C.pack text diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/pineapple.hs ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/pineapple.hs --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/pineapple.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/pineapple.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,7 +0,0 @@ -import qualified Data.ByteString.Char8 as C -import System.Time - -main = do - getClockTime - let text = "pineapple" - C.putStrLn $ C.pack text diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/SameDepsAllRound.cabal ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/SameDepsAllRound.cabal --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/SameDepsAllRound.cabal 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/SameDepsAllRound.cabal 1970-01-01 00:00:00.000000000 +0000 @@ -1,31 +0,0 @@ -name: SameDepsAllRound -version: 0.1 -license: BSD3 -cabal-version: >= 1.6 -author: Stephen Blackheath -stability: stable -synopsis: Same dependencies all round -category: PackageTests -build-type: Simple - -description: - Check for the "old build-dep behaviour" namely that we get the same - package dependencies on all build targets, even if different ones - were specified for different targets - . - Here all .hs files use the three packages mentioned, so this shows - that build-depends is not target-specific. This is the behaviour - we want when cabal-version contains versions less than 1.7. - ---------------------------------------- - -Library - exposed-modules: MyLibrary - build-depends: base, bytestring - -Executable lemon - main-is: lemon.hs - build-depends: old-time - -Executable pineapple - main-is: pineapple.hs diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Setup.hs ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Setup.hs --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Setup.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Setup.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,3 +0,0 @@ -import Distribution.Simple -main = defaultMain - diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Check.hs ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Check.hs --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Check.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Check.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,18 +0,0 @@ -module PackageTests.BuildDeps.TargetSpecificDeps1.Check where - -import Test.HUnit -import PackageTests.PackageTester -import System.FilePath -import Data.List - - -suite :: Test -suite = TestCase $ do - let spec = PackageSpec ("PackageTests" "BuildDeps" "TargetSpecificDeps1") [] - result <- cabal_build spec - assertEqual "cabal build should fail - see test-log.txt" False (successful result) - assertBool "error should be in MyLibrary.hs" $ - "MyLibrary.hs:" `isInfixOf` outputText result - assertBool "error should be \"Could not find module `System.Time\"" $ - "Could not find module `System.Time'" `isInfixOf` - (intercalate " " $ lines $ outputText result) diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/lemon.hs ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/lemon.hs --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/lemon.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/lemon.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,7 +0,0 @@ -import qualified Data.ByteString.Char8 as C -import System.Time - -main = do - getClockTime - let text = "lemon" - C.putStrLn $ C.pack text diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/my.cabal ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/my.cabal --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/my.cabal 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/my.cabal 1970-01-01 00:00:00.000000000 +0000 @@ -1,22 +0,0 @@ -name: TargetSpecificDeps1 -version: 0.1 -license: BSD3 -cabal-version: >= 1.7.1 -author: Stephen Blackheath -stability: stable -category: PackageTests -build-type: Simple - -description: - Check for the new build-dep behaviour, where build-depends are - handled specifically for each target - ---------------------------------------- - -Library - exposed-modules: MyLibrary - build-depends: base, bytestring - -Executable lemon - main-is: lemon.hs - build-depends: base, bytestring, old-time diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/MyLibrary.hs ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/MyLibrary.hs --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/MyLibrary.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/MyLibrary.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,10 +0,0 @@ -module MyLibrary where - -import qualified Data.ByteString.Char8 as C -import System.Time - -myLibFunc :: IO () -myLibFunc = do - getClockTime - let text = "myLibFunc" - C.putStrLn $ C.pack text diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Setup.hs ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Setup.hs --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Setup.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Setup.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,3 +0,0 @@ -import Distribution.Simple -main = defaultMain - diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Check.hs ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Check.hs --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Check.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Check.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,13 +0,0 @@ -module PackageTests.BuildDeps.TargetSpecificDeps2.Check where - -import Test.HUnit -import PackageTests.PackageTester -import System.FilePath -import Data.List - - -suite :: Test -suite = TestCase $ do - let spec = PackageSpec ("PackageTests" "BuildDeps" "TargetSpecificDeps2") [] - result <- cabal_build spec - assertEqual "cabal build should succeed - see test-log.txt" True (successful result) diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/lemon.hs ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/lemon.hs --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/lemon.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/lemon.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,5 +0,0 @@ -import qualified Data.ByteString.Char8 as C - -main = do - let text = "lemon" - C.putStrLn $ C.pack text diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/my.cabal ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/my.cabal --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/my.cabal 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/my.cabal 1970-01-01 00:00:00.000000000 +0000 @@ -1,24 +0,0 @@ -name: TargetSpecificDeps1 -version: 0.1 -license: BSD3 -cabal-version: >= 1.7.1 -author: Stephen Blackheath -stability: stable -category: PackageTests -build-type: Simple - -description: - Check for the new build-dep behaviour, where build-depends are - handled specifically for each target - This one is a control against TargetSpecificDeps1 - it is correct and should - succeed. - ---------------------------------------- - -Library - exposed-modules: MyLibrary - build-depends: base, bytestring, old-time - -Executable lemon - main-is: lemon.hs - build-depends: base, bytestring diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/MyLibrary.hs ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/MyLibrary.hs --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/MyLibrary.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/MyLibrary.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,10 +0,0 @@ -module MyLibrary where - -import qualified Data.ByteString.Char8 as C -import System.Time - -myLibFunc :: IO () -myLibFunc = do - getClockTime - let text = "myLibFunc" - C.putStrLn $ C.pack text diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Setup.hs ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Setup.hs --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Setup.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Setup.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,3 +0,0 @@ -import Distribution.Simple -main = defaultMain - diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Check.hs ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Check.hs --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Check.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Check.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,17 +0,0 @@ -module PackageTests.BuildDeps.TargetSpecificDeps3.Check where - -import Test.HUnit -import PackageTests.PackageTester -import System.FilePath -import Data.List - - -suite :: Test -suite = TestCase $ do - let spec = PackageSpec ("PackageTests" "BuildDeps" "TargetSpecificDeps3") [] - result <- cabal_build spec - assertEqual "cabal build should fail - see test-log.txt" False (successful result) - assertBool "error should be in lemon.hs" $ - "lemon.hs:" `isInfixOf` outputText result - assertBool "error should be \"Could not find module `System.Time\"" $ - "Could not find module `System.Time'" `isInfixOf` (intercalate " " $ lines $ outputText result) diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,7 +0,0 @@ -import qualified Data.ByteString.Char8 as C -import System.Time - -main = do - getClockTime - let text = "lemon" - C.putStrLn $ C.pack text diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/my.cabal ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/my.cabal --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/my.cabal 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/my.cabal 1970-01-01 00:00:00.000000000 +0000 @@ -1,22 +0,0 @@ -name: test -version: 0.1 -license: BSD3 -cabal-version: >= 1.7.1 -author: Stephen Blackheath -stability: stable -category: PackageTests -build-type: Simple - -description: - Check for the new build-dep behaviour, where build-depends are - handled specifically for each target - ---------------------------------------- - -Library - exposed-modules: MyLibrary - build-depends: base, bytestring, old-time - -Executable lemon - main-is: lemon.hs - build-depends: base, bytestring diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/MyLibrary.hs ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/MyLibrary.hs --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/MyLibrary.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/MyLibrary.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,10 +0,0 @@ -module MyLibrary where - -import qualified Data.ByteString.Char8 as C -import System.Time - -myLibFunc :: IO () -myLibFunc = do - getClockTime - let text = "myLibFunc" - C.putStrLn $ C.pack text diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Setup.hs ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Setup.hs --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Setup.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Setup.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,3 +0,0 @@ -import Distribution.Simple -main = defaultMain - diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/PackageTester.hs ghc-7.2.1/libraries/Cabal/tests/PackageTests/PackageTester.hs --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/PackageTester.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/PackageTester.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,176 +0,0 @@ -module PackageTests.PackageTester ( - PackageSpec(..), - Success(..), - Result(..), - cabal_configure, - cabal_build, - cabal_install, - unregister, - run - ) where - -import qualified Control.Exception.Extensible as E -import System.Directory -import System.FilePath -import System.IO -import System.Posix.IO -import System.Process -import System.Exit -import Control.Concurrent.Chan -import Control.Concurrent.MVar -import Control.Concurrent -import Control.Monad -import Data.List -import Data.Maybe -import qualified Data.ByteString.Char8 as C - - -data PackageSpec = - PackageSpec { - directory :: FilePath, - configOpts :: [String] - } - -data Success = Failure | ConfigureSuccess | BuildSuccess | InstallSuccess deriving (Eq, Show) - -data Result = Result { - successful :: Bool, - success :: Success, - outputText :: String - } - deriving Show - -nullResult :: Result -nullResult = Result True Failure "" - -recordRun :: (String, ExitCode, String) -> Success -> Result -> Result -recordRun (cmd, exitCode, exeOutput) thisSucc res = - res { - successful = successful res && exitCode == ExitSuccess, - success = if exitCode == ExitSuccess then thisSucc - else success res, - outputText = - (if null $ outputText res then "" else outputText res ++ "\n") ++ - cmd ++ "\n" ++ exeOutput - } - -cabal_configure :: PackageSpec -> IO Result -cabal_configure spec = do - res <- doCabalConfigure spec - record spec res - return res - -doCabalConfigure :: PackageSpec -> IO Result -doCabalConfigure spec = do - cleanResult@(_, _, cleanOutput) <- cabal spec ["clean"] - requireSuccess cleanResult - res <- cabal spec $ ["configure", "--user"] ++ configOpts spec - return $ recordRun res ConfigureSuccess nullResult - -doCabalBuild :: PackageSpec -> IO Result -doCabalBuild spec = do - configResult <- doCabalConfigure spec - if successful configResult - then do - res <- cabal spec ["build"] - return $ recordRun res BuildSuccess configResult - else - return configResult - -cabal_build :: PackageSpec -> IO Result -cabal_build spec = do - res <- doCabalBuild spec - record spec res - return res - -unregister :: String -> IO () -unregister libraryName = do - res@(_, _, output) <- run Nothing "ghc-pkg" ["unregister", "--user", libraryName] - if "cannot find package" `isInfixOf` output - then return () - else requireSuccess res - --- | Install this library in the user area -cabal_install :: PackageSpec -> IO Result -cabal_install spec = do - buildResult <- doCabalBuild spec - res <- if successful buildResult - then do - res <- cabal spec ["install"] - return $ recordRun res InstallSuccess buildResult - else - return buildResult - record spec res - return res - --- | Returns the command that was issued, the return code, and hte output text -cabal :: PackageSpec -> [String] -> IO (String, ExitCode, String) -cabal spec cabalArgs = - run (Just $ directory spec) "runghc" (["Setup.hs"] ++ cabalArgs) - --- | Returns the command that was issued, the return code, and hte output text -run :: Maybe FilePath -> String -> [String] -> IO (String, ExitCode, String) -run cwd cmd args = do - -- Posix-specific - (outf, outf0) <- createPipe - (errf, errf0) <- createPipe - outh <- fdToHandle outf - outh0 <- fdToHandle outf0 - errh <- fdToHandle errf - errh0 <- fdToHandle errf0 - pid <- runProcess cmd args cwd Nothing Nothing (Just outh0) (Just errh0) - - {- - -- ghc-6.10.1 specific - (Just inh, Just outh, Just errh, pid) <- - createProcess (proc cmd args){ std_in = CreatePipe, - std_out = CreatePipe, - std_err = CreatePipe, - cwd = cwd } - hClose inh -- done with stdin - -} - - -- fork off a thread to start consuming the output - outChan <- newChan - forkIO $ suckH outChan outh - forkIO $ suckH outChan errh - - output <- suckChan outChan - - hClose outh - hClose errh - - -- wait on the process - ex <- waitForProcess pid - let fullCmd = intercalate " " $ cmd:args - return ("\"" ++ fullCmd ++ "\" in " ++ fromMaybe "" cwd, - ex, output) - where - suckH chan h = do - eof <- hIsEOF h - if eof - then writeChan chan Nothing - else do - c <- hGetChar h - writeChan chan $ Just c - suckH chan h - suckChan chan = sc' chan 2 [] - where - sc' _ 0 acc = return $ reverse acc - sc' chan eofs acc = do - mC <- readChan chan - case mC of - Just c -> sc' chan eofs (c:acc) - Nothing -> sc' chan (eofs-1) acc - -requireSuccess :: (String, ExitCode, String) -> IO () -requireSuccess (cmd, exitCode, output) = do - case exitCode of - ExitSuccess -> return () - ExitFailure r -> do - ioError $ userError $ "Command " ++ cmd ++ " failed." - -record :: PackageSpec -> Result -> IO () -record spec res = do - C.writeFile (directory spec "test-log.txt") (C.pack $ outputText res) - diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/TestStanza/Check.hs ghc-7.2.1/libraries/Cabal/tests/PackageTests/TestStanza/Check.hs --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/TestStanza/Check.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/TestStanza/Check.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,57 +0,0 @@ -module PackageTests.TestStanza.Check where - -import Test.HUnit -import System.FilePath -import PackageTests.PackageTester -import Data.List (isInfixOf, intercalate) -import Distribution.Version -import Distribution.PackageDescription.Parse - ( readPackageDescription ) -import Distribution.PackageDescription.Configuration - ( finalizePackageDescription ) -import Distribution.Package - ( PackageIdentifier(..), PackageName(..), Dependency(..) ) -import Distribution.PackageDescription - ( PackageDescription(..), BuildInfo(..), TestSuite(..), Library(..) - , TestSuiteInterface(..) - , TestType(..), emptyPackageDescription, emptyBuildInfo, emptyLibrary - , emptyTestSuite, BuildType(..) ) -import Distribution.Verbosity (silent) -import Distribution.License (License(..)) -import Distribution.ModuleName (fromString) -import Distribution.System (buildPlatform) -import Distribution.Compiler - ( CompilerId(..), CompilerFlavor(..) ) -import Distribution.Text - -suite :: Version -> Test -suite cabalVersion = TestCase $ do - let directory = "PackageTests" "TestStanza" - pdFile = directory "my" <.> "cabal" - spec = PackageSpec directory [] - result <- cabal_configure spec - let message = "cabal configure should recognize test section" - test = "unknown section type" - `isInfixOf` - (intercalate " " $ lines $ outputText result) - assertEqual message False test - genPD <- readPackageDescription silent pdFile - let compiler = CompilerId GHC $ Version [6, 12, 2] [] - anyV = intersectVersionRanges anyVersion anyVersion - anticipatedTestSuite = emptyTestSuite - { testName = "dummy" - , testInterface = TestSuiteExeV10 (Version [1,0] []) "dummy.hs" - , testBuildInfo = emptyBuildInfo - { targetBuildDepends = - [ Dependency (PackageName "base") anyVersion ] - , hsSourceDirs = ["."] - } - , testEnabled = False - } - case finalizePackageDescription [] (const True) buildPlatform compiler [] genPD of - Left xs -> let depMessage = "should not have missing dependencies:\n" ++ - (unlines $ map (show . disp) xs) - in assertEqual depMessage True False - Right (f, _) -> let gotTest = head $ testSuites f - in assertEqual "parsed test-suite stanza does not match anticipated" - gotTest anticipatedTestSuite diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/TestStanza/my.cabal ghc-7.2.1/libraries/Cabal/tests/PackageTests/TestStanza/my.cabal --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/TestStanza/my.cabal 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/TestStanza/my.cabal 1970-01-01 00:00:00.000000000 +0000 @@ -1,19 +0,0 @@ -name: TestStanza -version: 0.1 -license: BSD3 -author: Thomas Tuegel -stability: stable -category: PackageTests -build-type: Simple - -description: - Check that Cabal recognizes the Test stanza defined below. - -Library - exposed-modules: MyLibrary - build-depends: base - -test-suite dummy - main-is: dummy.hs - type: exitcode-stdio-1.0 - build-depends: base \ No newline at end of file diff -Nru ghc-7.0.3/libraries/Cabal/tests/PackageTests/TestStanza/Setup.hs ghc-7.2.1/libraries/Cabal/tests/PackageTests/TestStanza/Setup.hs --- ghc-7.0.3/libraries/Cabal/tests/PackageTests/TestStanza/Setup.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/PackageTests/TestStanza/Setup.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,3 +0,0 @@ -import Distribution.Simple -main = defaultMain - diff -Nru ghc-7.0.3/libraries/Cabal/tests/README ghc-7.2.1/libraries/Cabal/tests/README --- ghc-7.0.3/libraries/Cabal/tests/README 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/README 1970-01-01 00:00:00.000000000 +0000 @@ -1,14 +0,0 @@ -Building and running the test suite -=================================== - -You can build and run the test suite by running: - - cabal configure && cabal build - cd tests - cabal configure --package-db=../dist/package.conf.inplace \ - --constraint='Cabal == 1.9.1' - cabal build - ./dist/build/suite/suite - -Replace the Cabal constraint with whatever the current development -version of Cabal. diff -Nru ghc-7.0.3/libraries/Cabal/tests/Setup.hs ghc-7.2.1/libraries/Cabal/tests/Setup.hs --- ghc-7.0.3/libraries/Cabal/tests/Setup.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/Setup.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,3 +0,0 @@ -import Distribution.Simple -main = defaultMain - diff -Nru ghc-7.0.3/libraries/Cabal/tests/suite.cabal ghc-7.2.1/libraries/Cabal/tests/suite.cabal --- ghc-7.0.3/libraries/Cabal/tests/suite.cabal 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/suite.cabal 1970-01-01 00:00:00.000000000 +0000 @@ -1,30 +0,0 @@ -name: suite -version: 0.1 -license: BSD3 -author: Stephen Blackheath -stability: stable -synopsis: test suite for cabal -category: Distribution -build-type: Simple -cabal-version: >= 1.6 -description: - A test suite for cabal. Run it often, maintain it, add tests to it, - and it will work for you. - -Executable suite - main-is: suite.hs - build-depends: - base, - test-framework, - test-framework-quickcheck2, - test-framework-hunit, - HUnit, - QuickCheck >= 2.1.0.1, - Cabal, - filepath, - process, - directory, - extensible-exceptions, - bytestring, - unix - diff -Nru ghc-7.0.3/libraries/Cabal/tests/suite.hs ghc-7.2.1/libraries/Cabal/tests/suite.hs --- ghc-7.0.3/libraries/Cabal/tests/suite.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/suite.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,62 +0,0 @@ --- The intention is that this will be the new unit test framework. --- Please add any working tests here. This file should do nothing --- but import tests from other modules. --- --- Stephen Blackheath, 2009 - -module Main where - -import Test.Framework -import Test.Framework.Providers.HUnit -import Test.Framework.Providers.QuickCheck2 -import qualified Test.HUnit as HUnit -import PackageTests.BuildDeps.SameDepsAllRound.Check -import PackageTests.BuildDeps.TargetSpecificDeps1.Check -import PackageTests.BuildDeps.TargetSpecificDeps1.Check -import PackageTests.BuildDeps.TargetSpecificDeps2.Check -import PackageTests.BuildDeps.TargetSpecificDeps3.Check -import PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check -import PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check -import PackageTests.BuildDeps.InternalLibrary0.Check -import PackageTests.BuildDeps.InternalLibrary1.Check -import PackageTests.BuildDeps.InternalLibrary2.Check -import PackageTests.BuildDeps.InternalLibrary3.Check -import PackageTests.BuildDeps.InternalLibrary4.Check -import PackageTests.TestStanza.Check -import Distribution.Text (display) -import Distribution.Simple.Utils (cabalVersion) -import Data.Version -import System.Directory - -hunit :: TestName -> HUnit.Test -> Test -hunit name test = testGroup name $ hUnitTestToTests test - -tests :: Version -> [Test] -tests cabalVersion = [ - hunit "PackageTests/BuildDeps/SameDepsAllRound/" PackageTests.BuildDeps.SameDepsAllRound.Check.suite, - hunit "PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/" PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check.suite, - hunit "PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/" PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check.suite, - hunit "PackageTests/BuildDeps/InternalLibrary0/" (PackageTests.BuildDeps.InternalLibrary0.Check.suite cabalVersion), - hunit "PackageTests/TestStanza/" - (PackageTests.TestStanza.Check.suite cabalVersion) - -- ^ The Test stanza test will eventually be required - -- only for higher versions. - ] ++ - -- These tests are only required to pass on cabal version >= 1.7 - (if cabalVersion >= Version [1, 7] [] - then [ - hunit "PackageTests/BuildDeps/TargetSpecificDeps1/" PackageTests.BuildDeps.TargetSpecificDeps1.Check.suite, - hunit "PackageTests/BuildDeps/TargetSpecificDeps2/" PackageTests.BuildDeps.TargetSpecificDeps2.Check.suite, - hunit "PackageTests/BuildDeps/TargetSpecificDeps3/" PackageTests.BuildDeps.TargetSpecificDeps3.Check.suite, - hunit "PackageTests/BuildDeps/InternalLibrary1/" PackageTests.BuildDeps.InternalLibrary1.Check.suite, - hunit "PackageTests/BuildDeps/InternalLibrary2/" PackageTests.BuildDeps.InternalLibrary2.Check.suite, - hunit "PackageTests/BuildDeps/InternalLibrary3/" PackageTests.BuildDeps.InternalLibrary3.Check.suite, - hunit "PackageTests/BuildDeps/InternalLibrary4/" PackageTests.BuildDeps.InternalLibrary4.Check.suite - ] - else []) - -main = do - putStrLn $ "Cabal test suite - testing cabal version "++display cabalVersion - setCurrentDirectory "tests" - defaultMain (tests cabalVersion) - diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/A/A.cabal ghc-7.2.1/libraries/Cabal/tests/systemTests/A/A.cabal --- ghc-7.0.3/libraries/Cabal/tests/systemTests/A/A.cabal 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/A/A.cabal 1970-01-01 00:00:00.000000000 +0000 @@ -1,23 +0,0 @@ -Name: test -cabal-version: > 1.1 -Version: 1.0 -copyright: filler for test suite -maintainer: Isaac Jones -synopsis: this package is really awesome. -Build-Depends: base -Other-Modules: B.A -Exposed-Modules: A -C-Sources: hello.c, c_src/hello.c -Extensions: ForeignFunctionInterface -x-darcs-repo: http://darcs.haskell.org/tmp -unknown-field: Filler. - -Executable: testA -Other-Modules: A -Main-is: MainA.hs -C-Sources: c_src/hello.c -Extensions: OverlappingInstances - -Executable: testB -Other-Modules: B.A -Main-is: B/MainB.hs diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/A/A.hs ghc-7.2.1/libraries/Cabal/tests/systemTests/A/A.hs --- ghc-7.0.3/libraries/Cabal/tests/systemTests/A/A.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/A/A.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,4 +0,0 @@ -module A where -a = 42 :: Int - -main2 = print a diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/A/B/A.lhs ghc-7.2.1/libraries/Cabal/tests/systemTests/A/B/A.lhs --- ghc-7.0.3/libraries/Cabal/tests/systemTests/A/B/A.lhs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/A/B/A.lhs 1970-01-01 00:00:00.000000000 +0000 @@ -1,4 +0,0 @@ -> module B.A where -> a = 42 :: Int - -> main = print a diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/A/B/MainB.hs ghc-7.2.1/libraries/Cabal/tests/systemTests/A/B/MainB.hs --- ghc-7.0.3/libraries/Cabal/tests/systemTests/A/B/MainB.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/A/B/MainB.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,5 +0,0 @@ -module Main where - -import A - -main = print a diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/A/c_src/hello.c ghc-7.2.1/libraries/Cabal/tests/systemTests/A/c_src/hello.c --- ghc-7.0.3/libraries/Cabal/tests/systemTests/A/c_src/hello.c 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/A/c_src/hello.c 1970-01-01 00:00:00.000000000 +0000 @@ -1 +0,0 @@ -int foo () {return 9;} diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/A/hello.c ghc-7.2.1/libraries/Cabal/tests/systemTests/A/hello.c --- ghc-7.0.3/libraries/Cabal/tests/systemTests/A/hello.c 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/A/hello.c 1970-01-01 00:00:00.000000000 +0000 @@ -1 +0,0 @@ -int main () {return 9;} diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/A/MainA.hs ghc-7.2.1/libraries/Cabal/tests/systemTests/A/MainA.hs --- ghc-7.0.3/libraries/Cabal/tests/systemTests/A/MainA.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/A/MainA.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,5 +0,0 @@ -module Main where - -import A - -main = print a diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/A/Makefile ghc-7.2.1/libraries/Cabal/tests/systemTests/A/Makefile --- ghc-7.0.3/libraries/Cabal/tests/systemTests/A/Makefile 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/A/Makefile 1970-01-01 00:00:00.000000000 +0000 @@ -1 +0,0 @@ -include ../Tests.mk diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/A/Setup.lhs ghc-7.2.1/libraries/Cabal/tests/systemTests/A/Setup.lhs --- ghc-7.0.3/libraries/Cabal/tests/systemTests/A/Setup.lhs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/A/Setup.lhs 1970-01-01 00:00:00.000000000 +0000 @@ -1,8 +0,0 @@ -#!/usr/bin/env runhaskell - -> module Main where - -> import Distribution.Simple - -> main :: IO () -> main = defaultMain diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/buildInfo/buildinfo2.buildinfo ghc-7.2.1/libraries/Cabal/tests/systemTests/buildInfo/buildinfo2.buildinfo --- ghc-7.0.3/libraries/Cabal/tests/systemTests/buildInfo/buildinfo2.buildinfo 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/buildInfo/buildinfo2.buildinfo 1970-01-01 00:00:00.000000000 +0000 @@ -1,5 +0,0 @@ -Executable: exe1 -Buildable: True - -Executable: exe2 -Buildable: True diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/buildInfo/buildinfo2.cabal ghc-7.2.1/libraries/Cabal/tests/systemTests/buildInfo/buildinfo2.cabal --- ghc-7.0.3/libraries/Cabal/tests/systemTests/buildInfo/buildinfo2.cabal 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/buildInfo/buildinfo2.cabal 1970-01-01 00:00:00.000000000 +0000 @@ -1,19 +0,0 @@ -Name: buildinfo2 -Version: 0.0 -License: GPL -License-file: COPYING -Build-Depends: base -Author: Evgeny Chukreev -Copyright: Evgeny Chukreev (C) 2005 -Maintainer: Evgeny Chukreev -Synopsis: Buildinfo testcase -Description: - Buildinfo testcase - -Executable: exe1 -Main-is: exe1.hs -HS-source-dirs: src - -Executable: exe2 -Main-is: exe2.hs -HS-source-dirs: src diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/buildInfo/Makefile ghc-7.2.1/libraries/Cabal/tests/systemTests/buildInfo/Makefile --- ghc-7.0.3/libraries/Cabal/tests/systemTests/buildInfo/Makefile 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/buildInfo/Makefile 1970-01-01 00:00:00.000000000 +0000 @@ -1 +0,0 @@ -include ../Tests.mk diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/buildInfo/Setup.lhs ghc-7.2.1/libraries/Cabal/tests/systemTests/buildInfo/Setup.lhs --- ghc-7.0.3/libraries/Cabal/tests/systemTests/buildInfo/Setup.lhs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/buildInfo/Setup.lhs 1970-01-01 00:00:00.000000000 +0000 @@ -1,5 +0,0 @@ -#!/usr/bin/runhaskell - -> import Distribution.Simple -> main = defaultMainWithHooks defaultUserHooks - diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/buildInfo/src/exe1.hs ghc-7.2.1/libraries/Cabal/tests/systemTests/buildInfo/src/exe1.hs --- ghc-7.0.3/libraries/Cabal/tests/systemTests/buildInfo/src/exe1.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/buildInfo/src/exe1.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,4 +0,0 @@ -module Main () where - -main :: IO () -main = return () diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/buildInfo/src/exe2.hs ghc-7.2.1/libraries/Cabal/tests/systemTests/buildInfo/src/exe2.hs --- ghc-7.0.3/libraries/Cabal/tests/systemTests/buildInfo/src/exe2.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/buildInfo/src/exe2.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,4 +0,0 @@ -module Main () where - -main :: IO () -main = return () diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/dataDir/dataDir.cabal ghc-7.2.1/libraries/Cabal/tests/systemTests/dataDir/dataDir.cabal --- ghc-7.0.3/libraries/Cabal/tests/systemTests/dataDir/dataDir.cabal 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/dataDir/dataDir.cabal 1970-01-01 00:00:00.000000000 +0000 @@ -1,13 +0,0 @@ -name: test -version: 0.1 -build-type: Simple -cabal-version: >= 1.2 -data-files: data-file - --- This test passes if running the below executeable doesn't return an --- 'exitFailure' status code. - -executable exe - main-is: Exe.hs --- other-modules: Paths_test - build-depends: base, directory diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/dataDir/Exe.hs ghc-7.2.1/libraries/Cabal/tests/systemTests/dataDir/Exe.hs --- ghc-7.0.3/libraries/Cabal/tests/systemTests/dataDir/Exe.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/dataDir/Exe.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,17 +0,0 @@ -module Main where - -import Control.Monad (unless) -import Paths_test (getDataFileName) -import System.Directory (doesFileExist) -import System.Exit (exitFailure) -import System.IO (putStrLn) - -main :: IO () -main = do - fname <- getDataFileName "data-file" - exists <- doesFileExist fname - if exists - then return () - else do putStrLn "Failure." - print fname - exitFailure diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/depOnLib/libs/A.hs ghc-7.2.1/libraries/Cabal/tests/systemTests/depOnLib/libs/A.hs --- ghc-7.0.3/libraries/Cabal/tests/systemTests/depOnLib/libs/A.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/depOnLib/libs/A.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,4 +0,0 @@ -module A where - -a :: Char -a = 'a' diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/depOnLib/mains/Main.hs ghc-7.2.1/libraries/Cabal/tests/systemTests/depOnLib/mains/Main.hs --- ghc-7.0.3/libraries/Cabal/tests/systemTests/depOnLib/mains/Main.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/depOnLib/mains/Main.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,4 +0,0 @@ -module Main where -import A - -main = putStrLn "Hello, cabal." \ No newline at end of file diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/depOnLib/Makefile ghc-7.2.1/libraries/Cabal/tests/systemTests/depOnLib/Makefile --- ghc-7.0.3/libraries/Cabal/tests/systemTests/depOnLib/Makefile 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/depOnLib/Makefile 1970-01-01 00:00:00.000000000 +0000 @@ -1 +0,0 @@ -include ../Tests.mk diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/depOnLib/Setup.lhs ghc-7.2.1/libraries/Cabal/tests/systemTests/depOnLib/Setup.lhs --- ghc-7.0.3/libraries/Cabal/tests/systemTests/depOnLib/Setup.lhs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/depOnLib/Setup.lhs 1970-01-01 00:00:00.000000000 +0000 @@ -1,8 +0,0 @@ -#!/usr/bin/runhugs - -> module Main where - -> import Distribution.Simple - -> main :: IO () -> main = defaultMain diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/depOnLib/test.cabal ghc-7.2.1/libraries/Cabal/tests/systemTests/depOnLib/test.cabal --- ghc-7.0.3/libraries/Cabal/tests/systemTests/depOnLib/test.cabal 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/depOnLib/test.cabal 1970-01-01 00:00:00.000000000 +0000 @@ -1,13 +0,0 @@ -Name: test -Version: 1.0 -hs-source-dir: libs -copyright: filler for test suite -maintainer: filler for test suite -synopsis: filler for test suite -build-depends: base -exposed-modules: A - -Executable: mainForA -Other-Modules: Main, A -hs-source-dirs: mains, libs -Main-is: Main.hs diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/exeWithC/a.c ghc-7.2.1/libraries/Cabal/tests/systemTests/exeWithC/a.c --- ghc-7.0.3/libraries/Cabal/tests/systemTests/exeWithC/a.c 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/exeWithC/a.c 1970-01-01 00:00:00.000000000 +0000 @@ -1 +0,0 @@ -int foo(int v) { return 2*v; } diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/exeWithC/Makefile ghc-7.2.1/libraries/Cabal/tests/systemTests/exeWithC/Makefile --- ghc-7.0.3/libraries/Cabal/tests/systemTests/exeWithC/Makefile 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/exeWithC/Makefile 1970-01-01 00:00:00.000000000 +0000 @@ -1 +0,0 @@ -include ../Tests.mk diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/exeWithC/Setup.lhs ghc-7.2.1/libraries/Cabal/tests/systemTests/exeWithC/Setup.lhs --- ghc-7.0.3/libraries/Cabal/tests/systemTests/exeWithC/Setup.lhs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/exeWithC/Setup.lhs 1970-01-01 00:00:00.000000000 +0000 @@ -1,2 +0,0 @@ -> import Distribution.Simple -> main = defaultMainWithHooks defaultUserHooks diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/exeWithC/test.hs ghc-7.2.1/libraries/Cabal/tests/systemTests/exeWithC/test.hs --- ghc-7.0.3/libraries/Cabal/tests/systemTests/exeWithC/test.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/exeWithC/test.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,4 +0,0 @@ -{-# CFILES a.c #-} -foreign import ccall unsafe "foo" foo :: Int -> Int - -main = print $ foo 6 diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/exeWithC/tt.cabal ghc-7.2.1/libraries/Cabal/tests/systemTests/exeWithC/tt.cabal --- ghc-7.0.3/libraries/Cabal/tests/systemTests/exeWithC/tt.cabal 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/exeWithC/tt.cabal 1970-01-01 00:00:00.000000000 +0000 @@ -1,13 +0,0 @@ -Name: tt -Version: 0.0 -Copyright: Einar Karttunen -Maintainer: Isaac Jones -Synopsis: Provided as a test. -License: BSD3 -Author: This Test Case Contributed by: Einar Karttunen Thanks! -Build-Depends: base - -Executable: tt -Main-Is: test.hs -C-Sources: a.c -Extensions: ForeignFunctionInterface diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/ffi-bin/main.cabal ghc-7.2.1/libraries/Cabal/tests/systemTests/ffi-bin/main.cabal --- ghc-7.0.3/libraries/Cabal/tests/systemTests/ffi-bin/main.cabal 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/ffi-bin/main.cabal 1970-01-01 00:00:00.000000000 +0000 @@ -1,6 +0,0 @@ -Name: test-bin -Build-Depends: base, testffi -Version: 0.0 - -Executable: test -Main-Is: Main.hs diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/ffi-bin/Main.hs ghc-7.2.1/libraries/Cabal/tests/systemTests/ffi-bin/Main.hs --- ghc-7.0.3/libraries/Cabal/tests/systemTests/ffi-bin/Main.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/ffi-bin/Main.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,7 +0,0 @@ -module Main where - -import TestFFI - -main :: IO () -main = putStrLn "test" - diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/ffi-bin/Makefile ghc-7.2.1/libraries/Cabal/tests/systemTests/ffi-bin/Makefile --- ghc-7.0.3/libraries/Cabal/tests/systemTests/ffi-bin/Makefile 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/ffi-bin/Makefile 1970-01-01 00:00:00.000000000 +0000 @@ -1 +0,0 @@ -include ../Tests.mk diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/ffi-bin/Setup.lhs ghc-7.2.1/libraries/Cabal/tests/systemTests/ffi-bin/Setup.lhs --- ghc-7.0.3/libraries/Cabal/tests/systemTests/ffi-bin/Setup.lhs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/ffi-bin/Setup.lhs 1970-01-01 00:00:00.000000000 +0000 @@ -1,4 +0,0 @@ -#! /usr/bin/env runhaskell - -> import Distribution.Simple -> main = defaultMain diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/ffi-package/Makefile ghc-7.2.1/libraries/Cabal/tests/systemTests/ffi-package/Makefile --- ghc-7.0.3/libraries/Cabal/tests/systemTests/ffi-package/Makefile 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/ffi-package/Makefile 1970-01-01 00:00:00.000000000 +0000 @@ -1 +0,0 @@ -include ../Tests.mk diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/ffi-package/Setup.lhs ghc-7.2.1/libraries/Cabal/tests/systemTests/ffi-package/Setup.lhs --- ghc-7.0.3/libraries/Cabal/tests/systemTests/ffi-package/Setup.lhs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/ffi-package/Setup.lhs 1970-01-01 00:00:00.000000000 +0000 @@ -1,4 +0,0 @@ -#! /usr/bin/env runhugs - -> import Distribution.Simple -> main = defaultMain diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/ffi-package/src/TestFFI.hs ghc-7.2.1/libraries/Cabal/tests/systemTests/ffi-package/src/TestFFI.hs --- ghc-7.0.3/libraries/Cabal/tests/systemTests/ffi-package/src/TestFFI.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/ffi-package/src/TestFFI.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,8 +0,0 @@ -module TestFFI where - -import Foreign - -type Action = IO () - -foreign import ccall "wrapper" - mkAction :: Action -> IO (FunPtr Action) diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/ffi-package/testffi.cabal ghc-7.2.1/libraries/Cabal/tests/systemTests/ffi-package/testffi.cabal --- ghc-7.0.3/libraries/Cabal/tests/systemTests/ffi-package/testffi.cabal 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/ffi-package/testffi.cabal 1970-01-01 00:00:00.000000000 +0000 @@ -1,10 +0,0 @@ -Name: testffi -Version: 0.0 -Build-Depends: base -hs-source-dir: src -Exposed-modules: TestFFI -Extensions: ForeignFunctionInterface - -executable: foo -main-is: TestFFIExe.hs -Extensions: ForeignFunctionInterface diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/ffi-package/TestFFIExe.hs ghc-7.2.1/libraries/Cabal/tests/systemTests/ffi-package/TestFFIExe.hs --- ghc-7.0.3/libraries/Cabal/tests/systemTests/ffi-package/TestFFIExe.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/ffi-package/TestFFIExe.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,11 +0,0 @@ -module Main where - -import Foreign - -type Action = IO () - -foreign import ccall "wrapper" - mkAction :: Action -> IO (FunPtr Action) - -main :: IO () -main = return () diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/preprocess/preprocess.cabal ghc-7.2.1/libraries/Cabal/tests/systemTests/preprocess/preprocess.cabal --- ghc-7.0.3/libraries/Cabal/tests/systemTests/preprocess/preprocess.cabal 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/preprocess/preprocess.cabal 1970-01-01 00:00:00.000000000 +0000 @@ -1,9 +0,0 @@ --- The point of this test is to check that the c2hs pre-processed .hs sources --- end up in dist/build and that the happy one stays in the src dir. --- Also, the happy one should be included into the sdist tarball. - -name: preprocess -version: 0.0 -build-depends: base -hs-source-dirs: src -exposed-modules: C2HsExample, HappyExample diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/preprocess/src/C2HsExample.chs ghc-7.2.1/libraries/Cabal/tests/systemTests/preprocess/src/C2HsExample.chs --- ghc-7.0.3/libraries/Cabal/tests/systemTests/preprocess/src/C2HsExample.chs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/preprocess/src/C2HsExample.chs 1970-01-01 00:00:00.000000000 +0000 @@ -1,3 +0,0 @@ -module C2HsExample where - --- we don't actually need anything diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/preprocess/src/HappyExample.y ghc-7.2.1/libraries/Cabal/tests/systemTests/preprocess/src/HappyExample.y --- ghc-7.0.3/libraries/Cabal/tests/systemTests/preprocess/src/HappyExample.y 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/preprocess/src/HappyExample.y 1970-01-01 00:00:00.000000000 +0000 @@ -1,92 +0,0 @@ -{ -module HappyExample where -import Data.Char -} - -%name calc -%tokentype { Token } -%expect 0 - - -%token - let { TokenLet } - in { TokenIn } - int { TokenInt $$ } - var { TokenVar $$ } - '=' { TokenEq } - '+' { TokenPlus } - '-' { TokenMinus } - '*' { TokenTimes } - '/' { TokenDiv } - '(' { TokenOB } - ')' { TokenCB } - - -%% - -Exp :: { Exp } -Exp : let var '=' Exp in Exp { Let $2 $4 $6 } - | Exp1 { Exp1 $1 } - -Exp1 : Exp1 '+' Term { Plus $1 $3 } - | Exp1 '-' Term { Minus $1 $3 } - | Term { Term $1 } - -Term : Term '*' Factor { Times $1 $3 } - | Term '/' Factor { Div $1 $3 } - | Factor { Factor $1 } - -Factor : int { Int $1 } - | var { Var $1 } - | '(' Exp ')' { Brack $2 } - - -{ - -happyError :: [Token] -> a -happyError _ = error ("Parse error\n") - - -data Exp = Let String Exp Exp | Exp1 Exp1 -data Exp1 = Plus Exp1 Term | Minus Exp1 Term | Term Term -data Term = Times Term Factor | Div Term Factor | Factor Factor -data Factor = Int Int | Var String | Brack Exp - - -data Token - = TokenLet - | TokenIn - | TokenInt Int - | TokenVar String - | TokenEq - | TokenPlus - | TokenMinus - | TokenTimes - | TokenDiv - | TokenOB - | TokenCB - -lexer :: String -> [Token] -lexer [] = [] -lexer (c:cs) - | isSpace c = lexer cs - | isAlpha c = lexVar (c:cs) - | isDigit c = lexNum (c:cs) -lexer ('=':cs) = TokenEq : lexer cs -lexer ('+':cs) = TokenPlus : lexer cs -lexer ('-':cs) = TokenMinus : lexer cs -lexer ('*':cs) = TokenTimes : lexer cs -lexer ('/':cs) = TokenDiv : lexer cs -lexer ('(':cs) = TokenOB : lexer cs -lexer (')':cs) = TokenCB : lexer cs - -lexNum cs = TokenInt (read num) : lexer rest - where (num,rest) = span isDigit cs - -lexVar cs = - case span isAlpha cs of - ("let",rest) -> TokenLet : lexer rest - ("in",rest) -> TokenIn : lexer rest - (var,rest) -> TokenVar var : lexer rest - -} diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/recursive/A.hi-boot ghc-7.2.1/libraries/Cabal/tests/systemTests/recursive/A.hi-boot --- ghc-7.0.3/libraries/Cabal/tests/systemTests/recursive/A.hi-boot 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/recursive/A.hi-boot 1970-01-01 00:00:00.000000000 +0000 @@ -1,2 +0,0 @@ -module A where -newtype TA = MkTA GHC.Base.Int diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/recursive/A.hs ghc-7.2.1/libraries/Cabal/tests/systemTests/recursive/A.hs --- ghc-7.0.3/libraries/Cabal/tests/systemTests/recursive/A.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/recursive/A.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,8 +0,0 @@ -module A where - -import B( TB(..) ) - -newtype TA = MkTA Int - -f :: TB -> TA -f (MkTB x) = MkTA x diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/recursive/A.hs-boot ghc-7.2.1/libraries/Cabal/tests/systemTests/recursive/A.hs-boot --- ghc-7.0.3/libraries/Cabal/tests/systemTests/recursive/A.hs-boot 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/recursive/A.hs-boot 1970-01-01 00:00:00.000000000 +0000 @@ -1,2 +0,0 @@ -module A where -newtype TA = MkTA Int diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/recursive/B.hs ghc-7.2.1/libraries/Cabal/tests/systemTests/recursive/B.hs --- ghc-7.0.3/libraries/Cabal/tests/systemTests/recursive/B.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/recursive/B.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,8 +0,0 @@ -module B where -import {-# SOURCE #-} A( TA(..) ) - -data TB = MkTB !Int - -g :: TA -> TB -g (MkTA x) = MkTB x - diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/recursive/C.hs ghc-7.2.1/libraries/Cabal/tests/systemTests/recursive/C.hs --- ghc-7.0.3/libraries/Cabal/tests/systemTests/recursive/C.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/recursive/C.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,6 +0,0 @@ -module Main where -import B -import A -- FIX: GHC doesn't seem to figure out this dependency?! - -main :: IO () -main = let f = g in putStrLn "C" diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/recursive/Makefile ghc-7.2.1/libraries/Cabal/tests/systemTests/recursive/Makefile --- ghc-7.0.3/libraries/Cabal/tests/systemTests/recursive/Makefile 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/recursive/Makefile 1970-01-01 00:00:00.000000000 +0000 @@ -1 +0,0 @@ -include ../Tests.mk diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/recursive/recursive.cabal ghc-7.2.1/libraries/Cabal/tests/systemTests/recursive/recursive.cabal --- ghc-7.0.3/libraries/Cabal/tests/systemTests/recursive/recursive.cabal 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/recursive/recursive.cabal 1970-01-01 00:00:00.000000000 +0000 @@ -1,11 +0,0 @@ -name: recursive -build-depends: base -version: 1.0 -copyright: filler for test suite -maintainer: Isaac Jones -synopsis: this package is really awesome. -Exposed-Modules: A, B - -Executable: testExe -Main-is: C.hs -other-modules: A, B diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/recursive/Setup.lhs ghc-7.2.1/libraries/Cabal/tests/systemTests/recursive/Setup.lhs --- ghc-7.0.3/libraries/Cabal/tests/systemTests/recursive/Setup.lhs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/recursive/Setup.lhs 1970-01-01 00:00:00.000000000 +0000 @@ -1,8 +0,0 @@ -#!/usr/bin/env runhaskell - -> module Main where - -> import Distribution.Simple - -> main :: IO () -> main = defaultMain diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/sdist/Exe1.hs ghc-7.2.1/libraries/Cabal/tests/systemTests/sdist/Exe1.hs --- ghc-7.0.3/libraries/Cabal/tests/systemTests/sdist/Exe1.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/sdist/Exe1.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1 +0,0 @@ -main = print "exe1" diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/sdist/Exe2.hs ghc-7.2.1/libraries/Cabal/tests/systemTests/sdist/Exe2.hs --- ghc-7.0.3/libraries/Cabal/tests/systemTests/sdist/Exe2.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/sdist/Exe2.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1 +0,0 @@ -main = print "exe2" diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/sdist/sdist.cabal ghc-7.2.1/libraries/Cabal/tests/systemTests/sdist/sdist.cabal --- ghc-7.0.3/libraries/Cabal/tests/systemTests/sdist/sdist.cabal 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/sdist/sdist.cabal 1970-01-01 00:00:00.000000000 +0000 @@ -1,19 +0,0 @@ -Name: test -Version: 0.1 -Build-Type: Simple -Cabal-Version: >=1.2 - --- http://hackage.haskell.org/trac/hackage/ticket/257 --- This is a test to make sure we're including all sections into the sdist --- irrespective of the buildable status. --- So the test passes if the tarball includes both Exe1.hs and Exe2.hs - -Executable exe1 - Main-Is: Exe1.hs - Build-Depends: base - -Executable exe2 - Main-Is: Exe2.hs - Build-Depends: base - if !os(linux) - Buildable: False diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/twoMains/MainA.hs ghc-7.2.1/libraries/Cabal/tests/systemTests/twoMains/MainA.hs --- ghc-7.0.3/libraries/Cabal/tests/systemTests/twoMains/MainA.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/twoMains/MainA.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,9 +0,0 @@ -module Main where - -import System.Environment (getArgs) -import Control.Monad (when) - -main = do print 'a' - args <- getArgs - let isB = head args - when (isB /= "isA") (error "A is not A!") diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/twoMains/MainB.hs ghc-7.2.1/libraries/Cabal/tests/systemTests/twoMains/MainB.hs --- ghc-7.0.3/libraries/Cabal/tests/systemTests/twoMains/MainB.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/twoMains/MainB.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,9 +0,0 @@ -module Main where - -import System.Environment (getArgs) -import Control.Monad (when) - -main = do print 'b' - args <- getArgs - let isB = head args - when (isB /= "isB") (error "B is not B!") diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/twoMains/Makefile ghc-7.2.1/libraries/Cabal/tests/systemTests/twoMains/Makefile --- ghc-7.0.3/libraries/Cabal/tests/systemTests/twoMains/Makefile 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/twoMains/Makefile 1970-01-01 00:00:00.000000000 +0000 @@ -1 +0,0 @@ -include ../Tests.mk diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/twoMains/Setup.lhs ghc-7.2.1/libraries/Cabal/tests/systemTests/twoMains/Setup.lhs --- ghc-7.0.3/libraries/Cabal/tests/systemTests/twoMains/Setup.lhs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/twoMains/Setup.lhs 1970-01-01 00:00:00.000000000 +0000 @@ -1,8 +0,0 @@ -#!/usr/bin/runhugs - -> module Main where - -> import Distribution.Simple - -> main :: IO () -> main = defaultMain diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/twoMains/test.cabal ghc-7.2.1/libraries/Cabal/tests/systemTests/twoMains/test.cabal --- ghc-7.0.3/libraries/Cabal/tests/systemTests/twoMains/test.cabal 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/twoMains/test.cabal 1970-01-01 00:00:00.000000000 +0000 @@ -1,14 +0,0 @@ -Name: test -Version: 1.0 -copyright: filler for test suite -maintainer: filler for test suite -build-depends: base -synopsis: filler for test suite - -Executable: testA -Other-Modules: MainA -Main-is: MainA.hs - -Executable: testB -Other-Modules: MainB -Main-is: MainB.hs diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/wash2hs/CHANGES ghc-7.2.1/libraries/Cabal/tests/systemTests/wash2hs/CHANGES --- ghc-7.0.3/libraries/Cabal/tests/systemTests/wash2hs/CHANGES 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/wash2hs/CHANGES 1970-01-01 00:00:00.000000000 +0000 @@ -1,5 +0,0 @@ -* 20031112 - added JSP-style string escape: - <%= my nice haskell code %> - is mapped to - text (my nice haskell code) diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/wash2hs/hs/WASHClean.hs ghc-7.2.1/libraries/Cabal/tests/systemTests/wash2hs/hs/WASHClean.hs --- ghc-7.0.3/libraries/Cabal/tests/systemTests/wash2hs/hs/WASHClean.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/wash2hs/hs/WASHClean.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,58 +0,0 @@ -module WASHClean where - -import Data.Char - -import WASHData - -data CM a = CM ([String] -> a) -instance Monad CM where -- Reader monad - return x = CM (const x) - m >>= f = CM (\strs -> - case m of - CM mfun -> - case f (mfun strs) of - CM ffun -> - ffun strs) - -class Clean n where - clean :: n -> CM n - -cleanCodeFragList :: [CodeFrag] -> [CodeFrag] -cleanCodeFragList = map g - where g (EFrag el) = EFrag (cleanElement el) - g (CFrag cs) = CFrag (cleanContentList cs) - g cf = cf - -cleanElement :: Element -> Element -cleanElement e@Element{elemName = en, elemContent = ec} = - if en == "pre" - then e - else let ec' = cleanContentList ec in - e{elemContent = ec'} - -cleanContentList :: [Content] -> [Content] -cleanContentList = remove . map g . combine - where g c = case c of CElement{celem = el} -> CElement{celem = cleanElement el} - CText{ctext = et} -> CText{ctext = et { textString = cleanText (textString et) }} - CCode{ccode = ec} -> CCode{ccode = cleanCodeFragList ec} - _ -> c - combine (CText {ctext = t1} : CText {ctext = t2} : rest ) = - combine (CText {ctext = Text {textString = textString t1++ textString t2, textMode = textMode t1}} : rest) - combine (x : xs) = x : combine xs - combine [] = [] - remove (CText{ctext = tt} : rest) | textString tt == " " = remove rest - -- remove (CText{ctext = tt} : rest@(CElement{} : _)) = CText{ctext = dropRight tt} : remove rest - -- remove (e@CElement{} : (CText{ctext = tt} : rest)) = e : remove (CText{ctext = dropLeft tt} : rest) - remove (x : rest) = x : remove rest - remove [] = [] - -cleanText "" = "" -cleanText xs@[x] | isSpace x = " " - | otherwise = xs -cleanText (x : ys@(y : _)) | isSpace x = if isSpace y - then cleanText ys - else ' ' : cleanText ys - | otherwise = x : cleanText ys - -dropRight tt = tt { textString = reverse (dropWhile isSpace (reverse (textString tt))) } -dropLeft tt = tt { textString = dropWhile isSpace (textString tt) } diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/wash2hs/hs/WASHData.hs ghc-7.2.1/libraries/Cabal/tests/systemTests/wash2hs/hs/WASHData.hs --- ghc-7.0.3/libraries/Cabal/tests/systemTests/wash2hs/hs/WASHData.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/wash2hs/hs/WASHData.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,74 +0,0 @@ -module WASHData -- derived from HSPData - ( File (..) - , Mode (..) - , Element (..) - , Text (..) - , Content (..) - , CodeFrag (..) - , Attribute (..) - , AttrValue (..) - ) -where { - - --- Data type. - -data File = File { - fcode :: [CodeFrag], - topElem :: Element - } deriving Show; - -data Mode = V | S | F - deriving (Eq,Show); - -data Element = Element - { elemMode :: Mode - , elemName :: String - , elemAttrs :: [Attribute] - , elemContent :: [Content] - , elemEmptyTag :: Bool } - deriving Show; - -data Text = Text - { textMode :: Mode - , textString :: String - } - deriving Show; - -data Content - = CElement { celem :: Element } - | CText { ctext :: Text } - | CReference { creference :: Text } - | CPI { cpi :: String } - | CComment { ccomment :: String } - | CCode { ccode :: [CodeFrag] } - deriving Show; - -data CodeFrag - = HFrag String - | EFrag Element - | HSFrag String - | CFrag [Content] - | AFrag [Attribute] - | VFrag String - deriving Show; - -data Attribute - = Attribute - { attrMode :: Mode - , attrName :: String - , attrValue :: AttrValue } - | AttrPattern - { attrPattern :: String } - deriving Show; - -data AttrValue - = AText String - | ACode String - deriving Show; - -data Reference = Reference String deriving Show; - - - -} diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/wash2hs/hs/WASHExpression.hs ghc-7.2.1/libraries/Cabal/tests/systemTests/wash2hs/hs/WASHExpression.hs --- ghc-7.0.3/libraries/Cabal/tests/systemTests/wash2hs/hs/WASHExpression.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/wash2hs/hs/WASHExpression.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,158 +0,0 @@ -module WASHExpression where - -import Control.Monad - -import WASHFlags -import qualified WASHUtil -import WASHData -import WASHOut - -code :: FLAGS -> [CodeFrag] -> ShowS -code flags [] = id -code flags (x:xs) = code' flags x . code flags xs - -code' :: FLAGS -> CodeFrag -> ShowS -code' flags (HFrag h) = - showString h -code' flags (EFrag e) = - runOut $ element flags e -code' flags (CFrag cnts) = - showChar '(' . - runOut (contents flags [] cnts) . - showChar ')' -code' flags (AFrag attrs) = - showChar '(' . - WASHUtil.itemList (attribute flags) "CGI.empty" " >> " attrs . - showChar ')' -code' flags (VFrag var) = - id -code' flags _ = error "Unknown type: code" - -outMode :: Mode -> Out () -outMode = outShowS . showMode - -showMode :: Mode -> ShowS -showMode V = id -showMode S = showString "_T" -showMode F = showString "_S" - -element :: FLAGS -> Element -> Out [String] -element flags (Element mode nm ats cnt et) = - do outChar '(' - outString "CGI." - outString nm - when (generateBT flags) $ outMode mode - outChar '(' - outShowS $ attributes flags ats - rvs <- contents flags [] cnt - outString "))" - return rvs - -outRVS :: [String] -> Out () -outRVS [] = outString "()" -outRVS (x:xs) = - do outChar '(' - outString x - mapM_ g xs - outChar ')' - where g x = do { outChar ','; outString x; } - -outRVSpat :: [String] -> Out () -outRVSpat [] = outString "(_)" -outRVSpat xs = outRVS xs - -contents :: FLAGS -> [String] -> [Content] -> Out [String] -contents flags inRVS cts = - case cts of - [] -> - do outString "return" - outRVS inRVS - return inRVS - ct:cts -> - do rvs <- content flags ct - case rvs of - [] -> - case (cts, inRVS) of - ([],[]) -> - return [] - _ -> - do outString " >> " - contents flags inRVS cts - _ -> - case (cts, inRVS) of - ([],[]) -> - return rvs - _ -> - do outString " >>= \\ " - outRVSpat rvs - outString " -> " - contents flags (rvs ++ inRVS) cts - -content :: FLAGS -> Content -> Out [String] -content flags (CElement elem) = - element flags elem -content flags (CText txt) = - do text flags txt - return [] -content flags (CCode (VFrag var:c)) = - do outShowS $ (showChar '(' . code flags c . showChar ')') - return [var] -content flags (CCode c) = - do outShowS $ (showChar '(' . code flags c . showChar ')') - return [] -content flags (CComment cc) = - do outShowS $ (showString "return (const () " . shows cc . showChar ')') - return [] -content flags (CReference txt) = - do text flags txt - return [] -content flags c = - error $ "Unknown type: content -- " ++ (show c) - -text :: FLAGS -> Text -> Out [String] -text flags txt = - do outString "CGI.rawtext" - when (generateBT flags) $ outMode (textMode txt) - outChar ' ' - outs (textString txt) - return [] - -attributes :: FLAGS -> [Attribute] -> ShowS -attributes flags atts = - f atts - where - f [] = id - f (att:atts) = - attribute flags att . - showString " >> " . - f atts - -attribute :: FLAGS -> Attribute -> ShowS -attribute flags (Attribute m n v) = - showString "(CGI.attr" . - (if generateBT flags then (attrvalueBT m v) else id) . - showChar ' ' . - shows n . - showString " " . - attrvalue v . - showString ")" -attribute flags (AttrPattern pat) = - showString "( " . - showString pat . - showString " )" -attribute flags a = error $ "Unknown type: attribute -- " ++ (show a) - -attrvalue :: AttrValue -> ShowS -attrvalue (AText t) = - shows t -attrvalue (ACode c) = - showString "( " . - showString c . - showString " )" -attrvalue a = error $ "Unknown type: attrvalue -- " ++ (show a) - -attrvalueBT :: Mode -> AttrValue -> ShowS -attrvalueBT V _ = id -attrvalueBT m (AText _) = showMode m . showChar 'S' -attrvalueBT m (ACode _) = showMode m . showChar 'D' -attrvalueBT m a = error $ "Unknown type: attrvalueBT -- " ++ (show a) diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/wash2hs/hs/WASHFlags.hs ghc-7.2.1/libraries/Cabal/tests/systemTests/wash2hs/hs/WASHFlags.hs --- ghc-7.0.3/libraries/Cabal/tests/systemTests/wash2hs/hs/WASHFlags.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/wash2hs/hs/WASHFlags.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,7 +0,0 @@ -module WASHFlags where --- -flags0 = FLAGS { generateBT = False } - -data FLAGS = FLAGS { generateBT :: Bool } - - diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/wash2hs/hs/WASHGenerator.hs ghc-7.2.1/libraries/Cabal/tests/systemTests/wash2hs/hs/WASHGenerator.hs --- ghc-7.0.3/libraries/Cabal/tests/systemTests/wash2hs/hs/WASHGenerator.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/wash2hs/hs/WASHGenerator.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,57 +0,0 @@ -module WASHGenerator (preprocess, preprocessPIPE) where { - -import Data.List; -import System.IO; - -import WASHData ; -import Parsec hiding (try) ; -import qualified WASHParser ; -import qualified WASHExpression ; -import qualified WASHClean ; -import WASHFlags ; - --- import Trace; - -preprocess :: FLAGS -> String -> String -> String -> IO (); -preprocess flags srcName dstName globalDefs = - bracket (openFile srcName ReadMode) - (\ srcHandle -> hClose srcHandle) - (\ srcHandle -> - bracket (openFile dstName WriteMode) - (\ dstHandle -> hClose dstHandle) - (\ dstHandle -> - preprocessPIPE flags srcName srcHandle dstHandle globalDefs)); - - -preprocessPIPE :: FLAGS -> String -> Handle -> Handle -> String -> IO (); -preprocessPIPE flags srcName srcHandle dstHandle globalDefs = do { - input <- hGetContents srcHandle; - let { parsing = parse WASHParser.washfile srcName input }; - case parsing of { - Left error -> ioError $ userError $ show error; - Right washfile -> - hPutStrLn dstHandle (postprocess $ file flags globalDefs washfile ""); - }; -}; - -file :: FLAGS -> String -> [CodeFrag] -> ShowS ; -file flags globalDefs fcode = - WASHExpression.code flags (WASHClean.cleanCodeFragList fcode) . - showString globalDefs . - showString "\n" - ; - -imports :: [String] -> String ; -imports is = concat $ map (\m -> "import " ++ m ++ ";\n") is ; - -postprocess :: String -> String ; -postprocess = unlines . postprocess' . lines ; - -postprocess' :: [String] -> [String] ; -postprocess' [] = [] ; -postprocess' xs'@(x:xs) = - if "import" `isPrefixOf` x - then "import qualified CGI" : xs' - else x : postprocess' xs ; - -} diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/wash2hs/hs/WASHMain.hs ghc-7.2.1/libraries/Cabal/tests/systemTests/wash2hs/hs/WASHMain.hs --- ghc-7.0.3/libraries/Cabal/tests/systemTests/wash2hs/hs/WASHMain.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/wash2hs/hs/WASHMain.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,36 +0,0 @@ -module Main where - --- ghc --make WASHMain -package text -o WASHMain - -import System.IO -import Data.List -import System -import WASHGenerator -import WASHFlags - -main = - do args <- getArgs - runPreprocessor flags0 args - -runPreprocessor flags [washfile] = - if ".wash" `isSuffixOf` washfile - then - preprocess flags washfile (take (length washfile - 5) washfile ++ ".hs") "" - else - preprocess flags - (washfile ++ ".wash") - (washfile ++ ".hs") - "" -runPreprocessor flags [washfile, hsfile] = - preprocess flags (washfile) (hsfile) "" -runPreprocessor flags [originalFile, washfile, hsfile] = - preprocess flags (washfile) (hsfile) "" -runPreprocessor flags [] = - preprocessPIPE flags "" stdin stdout "" -runPreprocessor flags args = - do progName <- getProgName - hPutStrLn stderr ("Usage: " ++ progName ++ " washfile [hsfile]") - hPutStrLn stderr (" or: " ++ progName ++ " originalFile infile outfile") - hPutStrLn stderr (" or: " ++ progName) - hPutStrLn stderr (" to run as pipe processor") - hPutStrLn stderr ("Actual arguments: " ++ show args) diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/wash2hs/hs/WASHOut.hs ghc-7.2.1/libraries/Cabal/tests/systemTests/wash2hs/hs/WASHOut.hs --- ghc-7.0.3/libraries/Cabal/tests/systemTests/wash2hs/hs/WASHOut.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/wash2hs/hs/WASHOut.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,30 +0,0 @@ -module WASHOut where - --- output monad - -data Out a = Out a ShowS - -instance Monad Out where - return a = Out a id - m >>= f = case m of - Out x shw1 -> - case f x of - Out y shw2 -> - Out y (shw1 . shw2) - -runOut :: Out a -> ShowS -runOut (Out a shw) = shw - -wrapper = (Out () .) - -outString :: String -> Out () -outString = wrapper showString - -outChar :: Char -> Out () -outChar = wrapper showChar - -outs :: Show a => a -> Out () -outs = wrapper shows - -outShowS :: ShowS -> Out () -outShowS = Out () diff -Nru ghc-7.0.3/libraries/Cabal/tests/systemTests/wash2hs/hs/WASHParser.hs ghc-7.2.1/libraries/Cabal/tests/systemTests/wash2hs/hs/WASHParser.hs --- ghc-7.0.3/libraries/Cabal/tests/systemTests/wash2hs/hs/WASHParser.hs 2011-03-26 18:10:13.000000000 +0000 +++ ghc-7.2.1/libraries/Cabal/tests/systemTests/wash2hs/hs/WASHParser.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,541 +0,0 @@ -module WASHParser ( xmlfile, washfile ) where { - -import Data.Char ; -import Parsec hiding (letter) ; -import WASHData; -import WASHUtil; - - -notImplemented = char '\xff' >> return undefined - "something that isn't implemented yet"; - -f <$> p = do { x <- p; return $ f x; }; - -testParser p s = - case parse (do { x <- p; eof; return x; }) "bla" s of { - Left x -> print x; - Right y -> print y; - }; - -washfile :: Parser [CodeFrag] ; -washfile = - do code <- hBody - eof - return $ code - ; - -setMode :: Bool -> Mode ; -setMode toplevel = if toplevel then S else F ; - --- The numbers given for each parser identify the section and --- grammar production within the XML 1.0 definition (W3C --- REC-xml-19980210). - - --- 2.1 / 1 -xmlfile :: Parser File; -xmlfile = do { - prolog; - code <- option [] (do { - hs <- haskell; - s0; - return hs - }); - elem <- element True; - many misc; - eof; - return $ File { fcode = code, topElem = elem }; -}; - - --- 2.2 / 2 -char' = (char '\t' <|> char '\n' <|> char '\r' <|> - satisfy (>= ' ')) "character"; - - --- 2.3 / 3 -s = (try $ many1 (char ' ' <|> char '\t' <|> - char '\r' <|> char '\n')) "whitespace"; -s0 = option "" s; -{- -s0 = (try $ many (char ' ' <|> char '\t' <|> - char '\r' <|> char '\n')) "optional whitespace"; --} - --- 2.3 / 4 -nameChar = letter <|> digit <|> char '.' <|> char '-' <|> - char '_' <|> char ':' <|> combiningChar <|> extender; - - --- 2.3 / 5 -name :: Parser String; -name = do { - c <- letter <|> char '_' <|> char ':'; - cs <- many nameChar; - return $ c:cs; -} "name"; - - --- 2.3 / 6 -names :: Parser [String]; -names = sepBy1 name s; - - --- 2.3 / 7 -nmtoken :: Parser String; -nmtoken = many1 nameChar "nmtoken"; - - --- 2.3 / 8 -nmtokens :: Parser [String]; -nmtokens = sepBy1 name s; - - --- 2.3 / 10 -attValue :: Parser AttrValue; -attValue = (((AText . concat) <$> ( - between (char '\"') (char '\"') (many (p '\"')) - <|> between (char '\'') (char '\'') (many (p '\'')) )) - <|> ACode <$> haskellAttr) "attvalue" -where { - p end = (\x -> [x]) <$> satisfy (f end) <|> reference; - f end = \c -> c /= '<' && c /= '&' && c /= end; -}; - --- 2.3 / 11 -systemLiteral = do{ - char '\''; - sl <- many (satisfy (\c -> c /= '\'')); - char '\''; - return sl; -} <|> do{ - char '\"'; - sl <- many (satisfy (\c -> c /= '\"')); - char '\"'; - return sl; -}; - --- 2.3 / 12 -pubidLiteral = do { - char '\''; - sl <- many (pubidChar False); - char '\''; - return sl; -} <|> do{ - char '\"'; - sl <- many (pubidChar True); - char '\"'; - return sl; -}; - --- 2.3 / 13 -pubidChar w = satisfy (\c -> c >= 'A' && c <= 'Z' - || c >= 'a' && c <= 'z' - || c >= '0' && c <= '9' - || c `elem` " \n\r-()+,./:=?;!*#@$_%" - || w && c == '\''); - --- 2.4 / 14 -charData :: Bool -> Parser Text; -charData toplevel = - do { s <- many1 charData'; return $ Text (setMode toplevel) $ concat s; } - "#PCDATA"; - -charData' :: Parser String; -charData' = do { - c <- satisfy f; - return [c]; -} <|> do { - string "]]"; - c <- satisfy (\c -> f c && c /= '>'); - return $ ']':']':[c]; -} -where { - f c = c /= '<' && c /= '&' && c /= ']'; -}; - - --- 2.5 / 15 -comment :: Parser String; -comment = do { - try $ string " +
    + + +
    Overall merit choices are:
    A. Good paper. I will champion it at the PC meeting.
    B. OK paper, but I will not champion it.
    C. Weak paper, though I will not fight strongly against it.
    D. Serious problems. I will argue to reject this paper.
    Expertise choices are:
    X. I am an expert in the subject area of this paper.
    Y. I am knowledgeable in the area, though not an expert.
    Z. I am not an expert. My evaluation is that of an informed outsider.
    + diff -Nru ghc-7.0.3/libraries/hoopl/paper/latex.mk ghc-7.2.1/libraries/hoopl/paper/latex.mk --- ghc-7.0.3/libraries/hoopl/paper/latex.mk 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/paper/latex.mk 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,18 @@ +LATEX=latex +DVIPS=dvips + +%.dvi: %.tex + $LATEX '\scrollmode \input '"$stem" + ltxcount=3 + while egrep -s 'Rerun (LaTeX|to get cross-references right|to get citations correct)' $stem.log && + [ $ltxcount -gt 0 ] + do + $LATEX '\scrollmode \input '"$stem" + ltxcount=`expr $ltxcount - 1` + done + +%.ps: %.dvi + $DVIPS -Ppdf -o $target $stem.dvi +%.pdf: %.dvi + $DVIPS -Ppdf -o"| ps2pdf13 - $target" $prereq + diff -Nru ghc-7.0.3/libraries/hoopl/paper/Makefile ghc-7.2.1/libraries/hoopl/paper/Makefile --- ghc-7.0.3/libraries/hoopl/paper/Makefile 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/paper/Makefile 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,63 @@ +# General makefile for Latex stuff + +.SUFFIXES: .tib .verb .tex .fig .dvi .ps + +MAIN = dfopt + +# Styles are in papers/styles +TEXINPUTS := .:../styles//:$(TEXINPUTS) + +# Bibliographies are in papers/bibs +BIBINPUTS := .:../bibs//:$(BIBINPUTS) + +default: comb1.tex iterf.tex pairf.tex dg.tex cprop.tex + [ -r "$(MAIN)du.tex" ] && chmod +w $(MAIN)du.tex + ./defuse < $(MAIN).tex > $(MAIN)du.tex + chmod -w $(MAIN)du.tex + latex $(MAIN).tex +# bibtex $(MAIN) + latex $(MAIN).tex + latex $(MAIN).tex + dvips -f -P pdf < $(MAIN).dvi > $(MAIN).ps + ps2pdf $(MAIN).ps + + + +esc: + latex escMeets.tex + bibtex escMeets + dvips -f < escMeets.dvi > escMeets.ps + +bib: + bibtex $(MAIN) + +pdf: + latex $(MAIN).tex + bibtex $(MAIN) + latex $(MAIN).tex + pdflatex $(MAIN).tex + +ps: + latex $(MAIN).tex + bibtex $(MAIN) + latex $(MAIN).tex + latex $(MAIN).tex + dvips -t a4 $(MAIN).dvi -o $(MAIN).ps + +clean-ps: + clean-ps imp*.ps + +HOOPL=../src/Compiler/Hoopl + +comb1.tex iterf.tex pairf.tex: ./xsource $(HOOPL)/Combinators.hs + lua ./xsource $(HOOPL)/Combinators.hs + +dg.tex: ./xsource $(HOOPL)/Dataflow.hs + lua ./xsource $(HOOPL)/Dataflow.hs + +CLIENT=../testing +CPROPS=$(CLIENT)/ConstProp.hs $(CLIENT)/Simplify.hs $(CLIENT)/Test.hs + +cprop.tex: ./xsource $(CPROPS) + lua ./xsource $(CPROPS) + diff -Nru ghc-7.0.3/libraries/hoopl/paper/mkfile ghc-7.2.1/libraries/hoopl/paper/mkfile --- ghc-7.0.3/libraries/hoopl/paper/mkfile 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/paper/mkfile 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,82 @@ +<./latex.mk +<./spell.mk +<./bbl.$USER.mk +<./bitly.$USER.mk + + +LASTPAGE=13 # final draft has extra page + +TGT=dfopt + +all:V: $TGT.pdf $TGT.ps hoopl10-supplement.bitly hoopl10.bitly +old:V: popl-index.bitly +bib:V: $TGT.bbl +bibfile:V: $TGT.bib +dvi:V: $TGT.dvi +pdf:V: $TGT.pdf +ps:V: $TGT.ps +bbl:V: bib +xdvi:V: $TGT.dvi + sht=`xwininfo -root | awk '$1 == "Height:" { print $2 }'` + swd=`xwininfo -root | awk '$1 == "Width:" { print $2 }'` + swd=`expr $swd - 120` # more room + xdvi -s 5 -geometry =$(expr $swd / 2)x$(expr $sht - 20)+78+2 $prereq + + +tag:VQ: $TGT.tex + tag=`$HOME/bin/md5words -trim $prereq | tr -d "'" | tr -cs a-zA-Z0-9 - | sed s/-*$//` + echo git tag $tag + git tag $tag + +dfopt.dvi: dfopt.bbl code.sty timestamp.tex dfoptdu.tex cprop.tex comb1.tex iterf.tex pairf.tex dg.tex cat.tex + +dfoptdu.tex: cprop.tex comb1.tex iterf.tex pairf.tex dg.tex node.tex + +$TGT.pdf: $TGT.dvi + dvips -Ppdf -o"|ps2pdf - $target" -pp 1-$LASTPAGE $prereq + +$TGT.ps: $TGT.dvi + dvips -Ppdf -o "$target" -pp 1-$LASTPAGE $prereq + +$HOME/www/pubs/hoopl10-supplement.pdf: $TGT.dvi + dvips -Ppdf -o"|ps2pdf - $target" -pp `expr $LASTPAGE + 1`- $prereq + +$HOME/www/pubs/hoopl10.pdf: $TGT.dvi + dvips -Ppdf -o"|ps2pdf - $target" $prereq + +timestamp.tex: $TGT.tex + date=`stat -c "%y" $prereq` + signature="" + if [ -x $HOME/bin/md5words ]; then + words="`md5words -trim $prereq`" + signature=" [MD5: \\mbox{$words}]" + else + words="(could not compute signature words)" + fi + date -d "$date" "+\def\mdfivestamp{\\rlap{\\textbf{%a %e %b %Y, %l:%M %p$signature}}}\def\mdfivewords{$words}" > $target + + + +%du.tex:D: defuse %.tex hsprelude + [ -r "$target" ] && chmod +w $target + ./defuse '\^' < $stem.tex > $target + chmod -w $target + + +CLIENT=../testing +CPROPS=ConstProp Simplify Test + +cprop.tex:D: ./xsource ${CPROPS:%=$CLIENT/%.hs} + lua $prereq > $target + +HOOPL=../src/Compiler/Hoopl + +comb1.tex iterf.tex pairf.tex:D: ./xsource $HOOPL/Combinators.hs + lua $prereq + +dfoptdu.tex: fptype.tex bodyfun.tex block.tex + +dfoptdu.tex: bodyfun.tex fptype.tex update.tex fpimp.tex txfb.tex + +txfb.tex block.tex cat.tex bodyfun.tex update.tex fptype.tex fpimp.tex dg.tex node.tex:D: ./xsource $HOOPL/Dataflow.hs + lua ./xsource -4 $HOOPL/Dataflow.hs diff -Nru ghc-7.0.3/libraries/hoopl/paper/NOTES ghc-7.2.1/libraries/hoopl/paper/NOTES --- ghc-7.0.3/libraries/hoopl/paper/NOTES 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/paper/NOTES 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,197 @@ +Notes 18 March 2010 +~~~~~~~~~~~~~~~~~~~ + + * John and Norman are not convinced that the ChangeFlag 'tfb_cha' is + being updated correctly when facts change. Because block IDs are + added to 'tfb_bids' incrementally, we are worried that a fact at + label L could be made to climb by a predecessor, but that this + change wouldn't be noted by updateFact unless the block labelled L + had already been visited. We spent a good 20 minutes on this + question, which right there is indicative of a problem. The + computation of the fixed point needs to be manifestly correct. + Perhaps tfb_bids should be initialized all at one go, and perhaps + it should be given type 'BlockId -> Bool'? + + * The 'nodeGraph' function, together with the supporting case of + OCFlag and IsOC, are a bit eye-popping. A good explanation + should be a high priority. Also, it would be good to be able to + say in the paper whether GHC -O is able to eliminate the IsOC + type-class dictionaries. Finally, it is probably also worth + noting that if Haskell had Sorts as in the Omega language, this + issue might not arise. + + * Similarly, the new type-class constraints in GFTR are worth + noting, and the same questions arise about dictionaries. + + * Norman has a few ideas to tidy the implementation of gftGraph. + He will try them out, and if he likes them, will send them on. + + * The >>> arrow has but one use. We suggest a local binding: + + blocks_once :: Blocks n -> Trans (TxFactBase n f) (TxFactBase n f) + blocks_once = foldr ((>>>) . block_once) idTrans + where (t1 >>> t2) f = t1 f >>= t2 + + * Does the "it's a bit disgusting..." comment still apply? + + + + + + + +Notes March 2010 +~~~~~~~~~~~~~~~~ +Normans comment on draft so far: + +- Revisit introduction + +- Still skeptical about blockId function + +- GMany: does the list have to be non-empty? + Could we have GMany b1 [] b2? + +- Distinction between invariants that hold on "finished graphs" + and ones that hold on graphs under construction. + +- Consider (GUnit b) :: Graph C C, can successors(b) include b's + own BlockId? No. + +- If you ask for successors(x) can you get any pointer into x? + Answer no. + Simon says: you can can only get a loop in g_blocks. A singleton + block can't be a loop. + +- Client knows about nodes. Our job is to lift to blocks and graphs. + + +* I would love to simplify the Graph type, further, but I don't know + how. In particular, we seem to *need* a function of type + lift :: n e x -> Graph n e x + to use when the client's rewriting function says Nothing. + + But that forces the slightly + +* Talking to John, we agreed that a common use of Hoopl will be to + analyse full graphs, to get a full mapping (BlockId -> fact), for + the *internal* nodes of the graph, not just its out-edges. Inded + for a full graph (eg a procedure body) there wil *be* no out-edges. + + So maybe we want + data Graph n e x where + ... + GMany { + g_entry :: Block n e C, + g_blocks :: FullGraph n, + ...} + + where + newtype FullGraph n = FG [Block n C C] + + And the client might define a procedure thus: + + data Procedure = Proc BlockId -- Entry point + (FullGraph CmmNode) + + Now we may imagine + GFT_FullGraph n f = GFT (FullGraph n) + and the client interface might be exposed for FullGraph. + Meanwhile, the recursive invocations of the analysis still + work on Graphs. + + So a FullGraph would be a fourth kind of entity (as well as + nodes, blocks, graphs), albeit one that is not an instance of + Edges. + +That would make the signature of analyseAndRewrite look like this: + +analyseAndRewrite + :: forall n f. Edges n + => RewritingDepth + -> DataflowLattice f + -> ForwardTransfers n f + -> ForwardRewrites n f + -> GFT_FullGraph n f + +where + GFT_FullGraph n f = FullGraph n -> InFactC f -> + +* Incidentally, eleveating FullGraph in this way would let + us switch to BlockEnv or whatever else we wanted if that + proved convenient. + +* Maybe FullGraph should be Graph, and Graph should be PGraph (for + partial graph), or SubGraph. + +* I was thinking how to do dead-block elimination. Given a fact + (B17 -> Dead), how can I rewrite the block with label B17 to + an empty graph? I'd like to write + rewrite fact_fun (Label b) + | fact_fun b == Dead = Just (GUnit (BUnit b `BCat` unreachable)) + | otherwise = Nothing + + So what is "unreachable :: Block". I suppose it's a new constructor + of the Block type, that eats all its downstream fellows: + + data Block n e x where + BUnr :: Block n O x + ...as before... + + It's a bit like the GNil constructor, which is there primarily + to allow us to rewrite a node to a no-op. + + Its a bit tiresome that it has be be in Block not Graph, but + we still need that Label. + + +Ideas +~~~~~ +"Optimization" encompasses: + - substitution informed by equational reasoning (about states) + - removal of redundant code, as justified by reasoning about + continuations + +"Code motion" is achieved by inserting redundant code, +thereby making original code redundant, which in turn +can be removed. + +Technique +~~~~~~~~~ +No single technique; the secret sauce is how we combine things: + - Zipper CFG + - Disctinct representations for construction and analyis of CFGs + - Maximum use of polymorphism + - Type classes to make notation resemble prior art + - Transfer equations coded in dragon-book style + - Fixed points courtesy Lerner, Grove, and Chambers (2002) + +Contribution +~~~~~~~~~~~~ +We make dataflow optimization easy to think about and easy to build: + + * Ideas that reconcile the ad-hoc 'optimization zoo' found in the + dragon book with methods of reasoning long understood by functional + programmers. + + * Design and implementation that make it not just possible but *easy* + to use dataflow techniques in your compiler. + + + +--------------------------------- +Working title: Dataflow Optimization Made Simple + +Note: By decomposing 'optimizations' into smaller units, we simplify. +'induction-variable elimination' is *not* an atomic thing! + + +--------------------------------- +Vague Outline +1. Intro +2. Short example +3. Logical view of optimization +4. Clients (examples, including type class declarations) +5. Graphs +6. Fixed-point computation; the dataflow monad +7. Discussion + diff -Nru ghc-7.0.3/libraries/hoopl/paper/notes-relatedwork ghc-7.2.1/libraries/hoopl/paper/notes-relatedwork --- ghc-7.0.3/libraries/hoopl/paper/notes-relatedwork 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/paper/notes-relatedwork 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,57 @@ +Soot: + +3 kinds of analyses: + - fwd, bwd, fwd with different results on different branches + +Abstracted over flowgraph (abstract DirectedGraph class) + +Requires a new, annoying constructor for each analysis that calls ... doAnalysis() + +Lattice join and _copy_ -- b/c it's _required_ to be mutable + +No interleaving + +Most useful reading: http://www.brics.dk/SootGuide/ + + + +CIL: + +Not abstracted over flowgraph + +Complicated interface that can affect how the analysis iterates +over the graph. + +No interleaving + +Most useful reading: +http://docs.camlcity.org/docs/godipkg/3.10/godi-cil/doc/godi-cil/html/api/Dataflow.ForwardsTransfer.html + + +Whirlwind: +Interleaving, of course. +Implementation much like our earlier efforts: +a complicated mix of interleaving and recursive rewriting, +with dynamic checks that the client returns correct graphs. +Representation of the transformations is generated by interleaved analysis and +transformation, +then the generated transformations are applied; +all of this is simpler in our story b/c we have immutable graphs. +No optimization fuel. + +analyze-implementation.diesel - 284 non-comment, non-blank loc +analysis.diesel - 30 non-comment, non-blank loc +analysis-action.diesel - 45 non-comment, non-blank loc +analysis-graph.diesel - 79 non-comment, non-blank loc +analysis-info.diesel - 4 non-comment, non-blank loc +analyze.diesel - 20 non-comment, non-blank loc + +core of implementation is about 500 non-comment, non-blank loc + + + +LLVM: + +Pass manager -- there's a lot of support for gathering passes + and ordering them effectively, but I don't see anything + that might be termed a dataflow framework diff -Nru ghc-7.0.3/libraries/hoopl/paper/old-implementation-sections.tex ghc-7.2.1/libraries/hoopl/paper/old-implementation-sections.tex --- ghc-7.0.3/libraries/hoopl/paper/old-implementation-sections.tex 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/paper/old-implementation-sections.tex 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,344 @@ +\section{The Dataflow Engine} +\seclabel{engine} +\seclabel{dfengine} +\simon{Need a linking sentence like ``So far we have discussed clients of +our library. Now we turn our attention to the implementation of the +library itself.'' Yes, you'll want to use different vocabulary!} + +The dataflow engine is implemented in two layers. +The lower layer is the \emph{dataflow monad}. +It~keeps track of the values of dataflow facts as the engine iterates. +The upper layer is divided into four parts: +a forward solver, a forward rewriter, +a backward solver, and a backward rewriter. + +Despite the implicit claim in the title of this paper, +the dataflow engine is not simple. +The benefit of our design is that the \emph{interface} to the dataflow +engine (lattice, transfer functions, rewriting functions) is simple, +and as shown above, compiler passes written \emph{using} the engine +are very simple indeed. +But~the engine itself is complex. + +Most of the complexity in the dataflow engine arises because we +implement the ambitious algorithm of +\citet{lerner-grove-chambers:2002}, who write +\begin{quote} +\emph{Previous efforts to exploit [the mutually beneficial +interactions of dataflow analyses] either (1)~iteratively performed +each individual analysis until no further improvements are discovered +or (2)~developed [handwritten] ``super-analyses'' that manually +combine conceptually separate analyses. We have devised a new approach +that allows analyses to be defined independently while still enabling +them to be combined automatically and profitably. Our approach avoids +the loss of precision associated with iterating individual analyses +and the implementation difficulties of manually writing a +super-analysis.} +\end{quote} +Adapting this work to a purely functional setting results in an +implementation that is significantly simpler than the original. +We~sketch that implementation below. + + +%% Note that the dataflow engine is the only part of the system that is +%% hard to get right---this is where all the hair is. +%% Prime benefit of our system is that once this is right, everything is +%% easy (and indeed is just logic, strongest postcondition, or weakest +%% precondition). +%% + + + +\subsection{The dataflow monad} + +The primary purpose of the dataflow monad is to keep track of +dataflow facts as the engine iterates. +Dataflow facts are found in three places: +\begin{itemize} +\item +There is a dataflow fact associated with every labelled basic block in +the current graph; +the dataflow monad maintains this association in a finite map. +The functions @getFact@ and @setFact@ query and update this map. +\item +The current graph may be a subgraph of a larger graph, in which case a +forward dataflow pass may produce dataflow facts that flow to labelled +blocks that are outside the current graph. +These facts must be retained and propagated even if the current graph +is abandoned; such facts are added with @addLastOutFact@ and recovered +with @bareLastOuts@. +\item +Finally, a foraward dataflow pass over a subgraph may propagate a fact forward by +``falling off the end;'' such a fact is set with @setExitFact@ and +recovered with @getExitFact@. +\end{itemize} +In addition to keeping track of facts, +the dataflow monad provides a number of other facilities to manage +changes in state as graphs are rewritten and facts climb the dataflow +lattice: +\begin{itemize} +\item +The monad keeps track of whether any fact has changed. +\item +It provides a @subanalysis@ function which makes it possible to + analyze a subgraph using the current set of facts, then discard any + changes in state that may have resulted from the analysis of the + subgraph. +\item +It provides a supply of fresh @BlockId@s, which are available for use +by rewrite functions. +\item +It tracks the supply of \emph{optimization fuel}. +As~shown below, when fuel runs out, the dataflow engine stops +calling rewriting functions, effectively halting optimization. +Binary search on the size of the fuel supply enables the compiler to +identify unsound rewrites quickly \cite{whalley:isolation}. +\end{itemize} + + +\subsection{The dataflow engine} + +In implementing the dataflow engine, our primary tactic has been to +minimize the amount of duplicate or near-duplicate code. +To~that end, \emph{the dataflow engine implements only composed +analysis and transformation}. +Pure analysis is implemented as a special case in which no node is +ever rewritten. +As explained by \citet{lerner-grove-chambers:2002}, a~composed +analysis is implemented in two phases: +\begin{itemize} +\item +In the first phase, when a rewrite function proposes to replace a +node, the replacement graph is analyzed recursively, and the results +of that analysis are used as the new dataflow +fact(s) flowing out of the original node. +But \emph{the original node is not replaced}; indeed, the replacement +graph is abandoned, and only the facts remain. +If,~during iteration, the original node is analyzed again, perhaps +with a more conservative input fact, the rewrite function may propose +a different replacement or even no replacement at all. +This phase is called the \emph{solver}. +The solve computes a fixed point of the dataflow analysis +\emph{as if} nodes were replaced, while avoiding ever replacing a node +unsafely. +\item +Once the solver is complete, the resulting fixed point is sound, +and the facts in the fixed point are used by the second phase in which +each replacement proposed by a rewriting function is actually +performed. +This phase is called the \emph{rewriter}. +\end{itemize} + +In \citeyear{ramsey-dias:applicative-flow-graph}, two of us +\citeauthor{ramsey-dias:applicative-flow-graph} presented +implementations in Objective Caml of a backward solver and rewriter. +Here, then, as a complement, we sketch implementations of the forward +solver and rewriter used in~GHC. \simon{Oh! thinks the reader... so this +paper is just a rehash in Haskell of your earlier work? Can we +say somethign like ``See Related work for the substantial differences +between this paper and our ealier work''?} + + +\begin{itemize} +\item +@fwd_pure_anal@ is @forward_sol@ passed the @squash@ function +@\ _ _ -> Nothing@. +It ignores its rewrite, depth, and fuel parameters. +\item +The internal @solve@ function is higher-order in the parameter +@finish@, which extracts from the dataflow monad either the unique +exit fact or the set of @LastOuts@, depending on context. +\item +The function @set_or_save@ calls @setFact@ for @BlockId@s located +within graph~@g@ and calls @addLastOutFact@ for @BlockId@s located +outside graph~@g@. +\end{itemize} + + + + +\section{Implementing graphs} +\seclabel{graphs} + +Our optimizer represents each procedure using a control-flow graph. +Our representation of control-flow graphs is +\begin{itemize} +\item +Purely applicative, which makes it exceptionally easy to compose +analyses and transformations as described in \secref{engine} +\item +Polymorphic, which enables us not only to reuse the graph for +different low-level intermediate languages, but which forces us to +distinguish generally useful dataflow algorithms from particular +realizations in~GHC +\item +Based on Huet's \citeyearpar{huet:zipper} \emph{zipper}, +which makes it easy to adapt existing code improvements written in +imperative style +\end{itemize} +\citet{dias-ramsey:applicative-flow-graph} present our design in +detail, as well as discussing alternatives, advantages, and +disadvantages. +In~this paper we give a high-level view of the data structure, and we +emphasize a significant refinement: the introduction of polymorphism. + +\subsection{Basic data structure} + +A~basic block is a sequence beginning with a first node, continuing +with zero or more middle nodes, and ending in a last node. +A~first node contains only a unique identifier of type @BlockId@; the +types of middle and last nodes are parameters. +At~any given moment, the dataflow engine may \emph{focus} on a +particular edge, in which case +it holds the source of that edge plus a +list of its predecessors all the way back to the first node, +and +it holds the sink of that edge plus a +list of its successors all the way forward to the last node. +These values have types @ZHead m@ and @ZTail m l@, where @m@~and~@l@ +are the types of middle and last nodes: +\begin{code} +data ZHead m = ZFirst BlockId + | ZHead (ZHead m) m +data ZTail m l = ZLast (ZLast l) | ZTail m (ZTail m l) +\end{code} +The type @ZLast l@ extends~@l@ with an additional case, @LastExit@, +which represents a subgraph that ends not in a control transfer but by +``falling off the end.'' + +We~``modify'' a block by creating a new head and tail; to ``insert'', +``remove'', or ``mutate'' a node typically requires a couple of +allocations +\cite{dias-ramsey:applicative-flow-graph}. +With these operations it is easy to recast imperative graph-rewriting +code into a pure functional form. + + +When we are not focusing on a particular edge, we represent a basic +block by pairing its first node (a~@BlockId@ with a @ZTail@): +\begin{code} +data Block m l = Block BlockId (ZTail m l) +\end{code} +An entire graph is represented as a finite map from @BlockId@ to +block, together with the ID of the entry node:\footnote +{The representation of @BlockId@ is chosen so that not only is + it efficient to create an infinite supply of @BlockId@s, but finite + maps with @BlockId@ keys can be implemented using a Patricia tree, + which is even more efficient than a balanced binary tree + \cite{okasaki-gill:integer-map}.} +\begin{code} +data Graph m l = + Graph { g_entry :: BlockId + , g_blocks :: BlockEnv (Block m l) } +\end{code} +%% +%% A~graph has a single \emph{entry} and at most one \emph{default exit}. +%% A~graph has a default exit, which we abbreviate just ``exit'', only if +%% control can ``fall off the end.'' +%% A~graph has no exit if control leaves the graph only by an explicit +%% procedure return or tail call; +%% for example, the graph for a whole procedure has no exit. +%% The most common use of a single-entry, single-exit flow graph is as a +%% replacement for a middle node during code improvement. + +%% Each control-flow graph is represented as a finite map from @BlockId@ to +%% basic block, together with a distinguished @BlockId@ that marks the entry +%% node. +%% When a graph is ``being modified'', +%% we \emph{focus} on one internal edge of one basic block. +%% The focus is represented by a pair. +%% One element of the pair points to the +%% source of the edge, which is linked to its predecessor, and so on up +%% to the block's first node. +%% The other element of the pair points to the +%% sink of the edge, which is linked to its successor, and so on down +%% to the block's last node. + +\subsection{Realization in GHC} + +The two significant differences between the applicative flow graph +used in Quick~{\PAL} \cite{dias-ramsey:applicative-flow-graph} and the +refined version described in this paper are that the new version is +polymorphic, and the new version stores properties in separate finite +maps, not in mutable property lists. +%We use finite maps in order to avoid mutable reference cells, which +%require that computations be done in the @IO@~monad. +The change from propertly lists to finite maps is inconsequential, +affecting the algorithms in only minor ways and the structure of the +code not at all. +The change from a monomorphic to a polymorphic control-flow graph, by +contrast, has far-reaching implications. + +Types related to control flow graph are polymorphic in two parameters: +the type of middle nodes and the type of last nodes.\footnote +{We considered abstracting over types associated with first nodes as + well, but we preferred to restrict first nodes so that a first node + carries a @BlockId@ and only a @BlockId@. + This design gives us fewer type parameters and + therefore fewer higher-order functions associated with those + parameters. + Because we can always use a finite map to associate data with + each first node, we don't lose any expressive power.} +This design militates toward a modular implementation, +in which the implementation of the dataflow engine is +decoupled from the representation of computations at individual nodes. +\begin{itemize} +\item +Module @ZipCfg@ exports data structures and algorithms that are +independent of the type of middle and last nodes. +However, in order to enable other algorithms to change the flow graph +without knowing the representation of a last node, @ZipCfg@ exports a +@LastNode@ type class which all last nodes must support. +Ths @LastNode@ type class expresses the minimum required of a type +that claims to repesent a control transfer: +it must be possible to +create a last node that branches unconditionally to a given @BlockId@ (goto); +to test to see if a last node is an unconditional branch, and if so, to +what target; +and to observe what @BlockIds@ designate possible successors of a last +node. +Operations that observe successors are extended to basic +blocks of type @Block m l@ and to values of type @ZTail m l@. + +@ZipCfg@ exports a number of basic algorithms on graphs, including the +splicing algorithms described by +\citet{ramsey-dias:applicative-flow-graph}. +The most important algorithm is postorder depth-first-search +traversal, which orders the basic blocks in a way such that iterative +dataflow analyses converge quickly. +As~a benevolent side effect, this traversal also prunes unreachable +code from the graph. +\item +Module @ZipCfgCmmRep@ depends on @ZipCfg@, but not the converse. +It~exports definitions of the middle- and last-node types needed to +represent GHC's low-level intermediate code, @Cmm@. +For convenience, it also exports instantiations of graph types, +and it exports instance declarations that make it easy to walk @Cmm@ +nodes and find out what registers and stack slots are defined and +used. +\item +The \emph{representation} exported by +@ZipCfg@ and @ZipCfgCmmRep@ is useful primarily +for \emph{analyzing} flow graphs. +To~\emph{construct} a flow graph we use ``smart constructors'' which +produce monadic functions from graphs to graphs. +Using these constructors, GHC's front end creates large graphs by +composing smaller ones. + +The smart constructors are inspired by Hughes's \citeyearpar{hughes:novel-lists} +representation of lists. +They are similar to the functions of type +@zgraph -> zgraph@ described by +\citet{ramsey-dias:applicative-flow-graph}, +but in our Haskell implementation, the function type is monadic and is +hidden from clients. +A~monadic type is necessary in order to plumb through an infinite supply +of @BlockId@ values. +When a client \emph{wants} to use a @BlockId@, for example, to translate +structured control flow into conditional and unconditional branches, +the graph-construction interface provides a constructor of type +analogous to $(\mathtt{BlockId} \arrow \mathit{graph}) \arrow \mathit{graph}$. +%% , as described in the companion paper. +%% \cite{dias-peyton:refactoring}. +\end{itemize} + diff -Nru ghc-7.0.3/libraries/hoopl/paper/onepage.tex ghc-7.2.1/libraries/hoopl/paper/onepage.tex --- ghc-7.0.3/libraries/hoopl/paper/onepage.tex 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/paper/onepage.tex 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,610 @@ +\documentclass[twocolumn]{article} +\usepackage{vmargin,mathpartir,times,mathptm,graphicx} +% l2h substitution PAL C-- +\renewcommand{\ttdefault}{aett} + + +\setcounter{secnumdepth}{0} + +\usepackage{verbatim} % allows to define \begin{smallcode} +\newenvironment{code}{\par\unskip\kern-6pt \small\verbatim}{\endverbatim} +\newenvironment{smallcode}{\par\unskip\footnotesize\verbatim}{\endverbatim} +%\newenvironment{fuzzcode}[1]{\par\unskip\hfuzz=#1 \verbatim}{\endverbatim} +%\newenvironment{smallfuzzcode}[1]{\par\unskip\small\hfuzz=#1 \verbatim}{\endverbatim} + +\newcommand{\PAL}{\mbox{C\ttfamily-{}-}} +\newcommand\lrtl{\mbox{$\lambda$-RTL}} +% l2h substitution lrtl lambda-RTL +\setpapersize{USletter} +% left top right bottom +\setmarginsrb{0.93in}{0.5in}{0.93in}{0.4in} + {\headheight}{\headsep}{\footheight}{\footskip} +\columnsep=23pt + +\pagestyle{headings} +\makeatletter +\let\nrlist\@listi +\def\@listi{\nrlist\parsep=0.5\parsep + \itemsep=0.5\itemsep\topsep=0.5\topsep + \parskip=0.5\parskip} +\let\@listI\@listi +\def\@oddhead{\hfil\smash{\raisebox{-10pt}{ +\large +\begin{tabular}{c} +\Large {Hoopl} in four pages\\Norman Ramsey, Tufts University +\\(joint work with Jo\~ao Dias and Simon Peyton Jones)\vrule width 0pt +height 0pt depth 8pt +\end{tabular}}}\hfil} +\def\@oddfoot{\hfil\thepage\hfil} +\makeatother + +\makeatletter +\newcommand\mysection[1]{% + \par + \vskip 0.5\baselineskip plus 2pt minus 1pt + \noindent{\raggedright\textbf{#1}} + \par + \vskip 0.3\baselineskip plus 2pt minus 1pt + \@afterindentfalse +} + +\newcommand\triple[3]{\ensuremath{#1\;\{#2\}\;#3}} +\newcommand\implies{\Rightarrow} +\renewcommand\wp{\ensuremath{\mathit{wlp}}} +\let\wlp=\wp +\renewcommand\sp{\ensuremath{\mathit{sp}}} + +\renewcommand\mysection[1]{% + \@startsection{section}{1}{\z@}{-0.5\baselineskip plus -2pt minus -1pt}% + {0.3\baselineskip plus 2pt minus 1pt}% + {\normalfont\raggedright\bfseries}} + +\makeatother + + +\parindent=0pt +\parskip=2pt plus3pt + +\newenvironment{twolist}{\itemize}{\enditemize} + +\input{diagrams} + +\begin{document} + +\mysection*{Background} + +In my student days I didn't care for dataflow analysis or +optimization. +Dataflow analysis was full of bit vectors and $\cap$~and~$\cup$ +symbols and funny words like ``gen'' and ``kill.'' +Optimization was even more chaotic: more bit vectors, plus +special-purpose, pointwise, stateful program transformations that +didn't seem to have anything to do with anything else (or each other). + +Two things changed my mind: in 2002, Sorin Lerner, David Grove, and Craig +Chambers published a landmark paper which, among other things, showed +me a uniform way to think about program analysis and transformation; +and in 2004, after several years wrestling with traditional, mutable +representations of programs, John Dias and I had the idea of using an +\emph{applicative} control-flow graph based on Huet's zipper. +The applicative control-flow graph turned out to make it almost +trivial to implement the big innovation of Lerner, Grove, and +Chambers: speculative rewriting. +The key idea is an analogy between dataflow analysis and program +logic. + +\mysection*{Program logic} + +Compilers might be ugly, but semantics can be beautiful. +The rock on which we build is Tony Hoare's axiomatic semantics, +also known as ``Hoare logic,'' +where +\begin{mathpar} +\triple P S Q +\end{mathpar} +says that if we execute command~$S$ in any state satisfying precondition~$P$, and +if it terminates, the final state satisfies postcondition~$Q$. +Tony laid out axioms and inference rules for this judgment, of which +the most suggestive are the strengthening and weakening rules: +\begin{mathpar} +\inferrule{P \implies P' \\ \triple {P'} S Q} +{\triple P S Q} + +\inferrule{\triple P S {Q'} \\ Q' \implies Q \\ } +{\triple P S Q} +\end{mathpar} +These rules suggest there could be a \emph{best} +postcondition~$Q$---the one that implies all the others---and likewise +a \emph{best} precondition~$P$. +In fact they are Bob Floyd's + \emph{strongest verifiable consequent} (now called ``strongest postcondition'') +and Dijkstra's weakest (liberal) precondition. +And the most natural thing in the world is to try to turn Hoare's +relation into a function: to \emph{compute} \wp~or~\sp. +Unfortunately, in the presence of loops, these computations don't +terminate. +Dijkstra and Hoare got around the problem by forcing the programmer to +write down a \emph{loop invariant}: +\begin{mathpar} +\inferrule{\triple {I \land B} S I} +{\triple I {\mbox{\texttt{while} $B$ \texttt{do} $S$}} {I \land \lnot B}} +\end{mathpar} +Without a loop invariant, this approach seemed like a dead end---but +it isn't. + +\mysection*{Dataflow analysis as program logic} + +Dataflow analysis typically talks about ``states'' (sometimes +represented as bit vectors) and ``transfer functions.'' +I~follow Lerner, Grove, and Chambers, who talk about ``dataflow facts.'' +The connection with program logic is simple but breathtaking:\footnote +{As stated here, the connection is \emph{over} simple. More anon.} +\begin{itemize} +\item +A dataflow fact \emph{stands for} a logical formula. +Even better, every logical formula can be \emph{approximated} by a +dataflow fact. +\item +The transfer function for a forward dataflow analysis is a homomorphic +image of \sp\ on the dataflow fact. +And the transfer function for a backward dataflow analysis is a homomorphic +image of \wlp\ on the dataflow fact. +\end{itemize} +In other words, \emph{dataflow analysis is simply predicate + transformers applied to an impoverished program logic}.\footnote +{I'm sure David Schmidt means something similar when he says that + dataflow analysis is model checking of abstract interpretation, but + since I've never been able to understand any of those papers, + I~can't prove~it.} +A~``transfer function'' is a Curried function that takes program code + as an argument and returns a \emph{fact transformer}. + +\newcommand\embed{\mathcal E} +\renewcommand\approx{\mathcal A} + +% \newarrow{impliedBy} {<=}==== + +\kern-2\baselineskip + +\begin{center} +\begin{diagram} +P' & \lImplies & P & \rTo^{\sp} & Q' & \rImplies & Q \\ + & \luTo^{\embed} & \dTo ^ \approx & & & \ruTo^\embed & \\ + & & f & \rTo^{\mbox{transfer}} & f' & & \\ +\end{diagram} +\end{center} + +Because of loops, there's a little more to it than that: +\begin{itemize} +\item +We associate a logical variable with each basic block, +and on each basic block + we run the fact transformers and get out an equation relating logical + variables. +In the presence of loops, the equations are mutually recursive. +\item +We solve the recursive equations \emph{constructively}, through the +method of successive approximations. +If we use a work-list method, +the analogy with iterative dataflow analysis is exact. +\end{itemize} + + + +This observation has two important consequences: +\begin{enumerate} +\item +\label{cbottom} +The representation of dataflow facts, unlike that of +logical formulas, \emph{must} include a bottom element. +\item +\label{cterm} +Unlike the language of formulas, +the language of dataflow facts must be sufficiently impoverished that +there are no infinite ascending chains. +\end{enumerate} +Consequence~\ref{cbottom} gives us a starting point for the method of +successive approximations; consequence~\ref{cterm} ensures it terminates. + + +\mysection*{The genesis of Hoopl} + +Here's why I've spent five years on this problem: +\begin{quote} +\emph{If +the analogy between program logic and dataflow analysis holds up, +we should be able to create optimizers that are powerful, fun to +build, easy to get right, and that are part of an intellectually +coherent family of program transformations. +} +\end{quote} +I've refined this notion into three hypotheses. + +\emph{Hypothesis~\#1\quad} +Having a good story changes the way we should think +about dataflow analysis: +\begin{itemize} +\item +Instead of thinking about bit vectors, sets, mutation, gen, kill, and +all that, we should think about \emph{transforming dataflow facts}, +which represent logical formulas. +Using a pure functional language and ``wholemeal programming'' as +advocated by Richard Bird, we can write the code the way we think +about problems. +\item +There are only two analyses: weakest preconditions and strongest +postconditions. +And there are an infinite number of ways to approximate formulas. +These approximations will be the source of the next 700 dataflow +analyses. +\end{itemize} + +\emph{Hypothesis~\#2\quad} +The classical optimizations, which appear to be such a mess, can +be better understood as being composed from just three +transformations: +\begin{itemize} +\item +Substitution of equals for equals +\item +Elimination of redundant assignments +\item +\emph{Introduction} of redundant assignment +\end{itemize} +Substitution needs no introduction. +A~redundant assignment is the imperative analog of a let-bound +variable that does not appear free in the body: the binding can be +eliminated. +Redundant assignments are \emph{introduced} to enable the first two +transformations. +The simplest example is ``code motion.'' + + +\emph{Hypothesis~\#3\quad} +We should change the way we +code: +\begin{itemize} +\item +If we understand predicate transformers, transfer functions should be +easy to write. +\item +If that diagram really commutes, it should be possible to \emph{test} +that it commutes. +\item +If we can pull our head out of the bit vectors and the other details, +it should be possible to tell beautiful new stories about all the old +optimizations. +\end{itemize} + +To investigate these hypotheses, John Dias, Simon Peyton Jones, and~I +have created a reusable library called \emph{Hoopl:} a Higher Order +OPtimization Library. +Hoopl is intended for classical optimization of \emph{imperative} code +such as low-level intermediate code or machine instructions. +An~analysis or optimization written using Hoopl is a \emph{client}. + +\mysection*{Representing control-flow graphs} + +Authors of clients should be free to think great thoughts about +predicate transformers and fact transformers. +Hoopl keeps track of which predicates flow where. +To~simplify this process we \emph{statically type} the units of the IR +being optimized: +\begin{itemize} +\item +The target of \emph{any} control transfer must be labelled with a +unique \texttt{Label}. +A~labelled node may have any number of predecessors (including zero), +but it has exactly one successor. +In~a typical IR, a labelled node will contain \emph{only} the label. +\item +An ordinary computational node does no control flow; it has +exactly one predecessor and exactly one successor. +This case is the most common and is the simplest for the client, +because it reduces most directly to predicate transformers. +\item +A control-flow node has a unique predecessor, but it may have many +successors. +Such nodes includes calls, returns, and all forms of goto +(conditional, unconditional, and computed). +\emph{Every} successor must be a labelled node; Hoopl does not permit +``fallthrough.'' +\end{itemize} + +\subsection{Nodes, blocks and graphs; open and closed} + +Every node is \emph{open or closed at entry} +and \emph{open or closed at exit}. +An \emph{open} point is one at which control may implicitly ``fall through;'' +to transfer control at a \emph{closed} point requires an explicit +control-transfer instruction. + +A~sequence of nodes is well typed only if whenever two nodes follow +one another in the sequence, both nodes are open at the point where +they touch. +Such a sequence is called a \emph{block} and can be written using +these constructors: +\begin{code} +data O -- Open +data C -- Closed + +data Block n e x where + BFirst :: n C O -> Block n C O + BMiddle :: n O O -> Block n O O + BLast :: n O C -> Block n O C + BCat :: Block n e O -> Block n O x -> Block n e x +\end{code} +Blocks come in four shapes: open/open, open/closed, closed/open, and +closed/closed. +A~closed/closed block is a \emph{basic block} and cannot be further +extended with \texttt{BCat}. +Basic blocks are \emph{not} living dinosaurs; they are a fundamental +consequence of controlling predecessors and successors. + +In honor of their position within a basic block, +a closed/open node is called a \emph{first node}; +an open/open node is called a \emph{middle node}; +and +an open/closed node is called a \emph{last node}. + + +A \emph{control-flow graph} is a collection of blocks. +Graphs also come in four shapes: +\begin{code} +data Graph n e x where + GNil :: Graph n O O + GUnit :: Block n O O -> Graph n O O + GMany :: MaybeO e (Block n O C) + -> Map Label (Block n C C) + -> MaybeO x (Block n C O) + -> Graph n e x + +data MaybeO ex t where + JustO :: t -> MaybeO O t + NothingO :: MaybeO C t +\end{code} +Most blocks are closed/closed; a graph may contain at most one +open/closed \emph{entry sequence} and at most one closed/open +\emph{exit sequence}. +Also, an open/open sequence of middle nodes forms a graph +(by~\texttt{GUnit} or \texttt{GNil}). + + + +Our implementation exploits the fact that the shape of every node and +block is known \emph{statically} from the context in which it occurs. +But our analysis and rewriting functions are all polymorphic in the +shape. + +\mysection*{Dataflow passes} + +Each dataflow analysis begins with a lattice of dataflow facts. +Hoopl proper does not need to know how to embed a fact into the +language of logical formulas or how to approximate a logical formula +by a fact. +It~needs only to be able to start at the bottom and to take the least +upper bound of a pair of facts. +(When it does take the least upper bound, however, it needs to know if +something changed.) +\begin{smallcode} +data DataflowLattice f = DataflowLattice + { fact_bot :: f + , fact_extend :: JoinFun f + } +type JoinFun f + = Label -> OldFact f -> NewFact f -> (ChangeFlag, f) + -- the label argument is for debugging purposes only +newtype OldFact f = OldFact f +newtype NewFact f = NewFact f + +data ChangeFlag = NoChange | SomeChange +\end{smallcode} + +A forward transfer function takes a node of any shape and returns a +fact transformer: +\begin{code} +type FwdTransfer n f + = forall e x. n e x -> f -> Fact x f + +type family Fact x f :: * +type instance Fact C f = FactBase f +type instance Fact O f = f + +type FactBase f = Map Label f +\end{code} +The type definition uses a new feature of Haskell called \emph{type + families}. +A~type family is a type-level function; this one says that the + transfer function for a node that is open at the exit (and so has a + single successor) returns a single fact~\texttt{f}. +But the transfer function for a node that is \emph{closed} at the exit + could have multiple successors, so it returns a finite map from + successors' labels to facts. +This map is called a \emph{fact base}. + +Clients can also \emph{rewrite} nodes: +\begin{smallcode} +type FwdRewrite n f + = forall e x. n e x -> f -> Maybe (FwdRes n f e x) +data FwdRes n f e x = FwdRes (AGraph n e x) (FwdRewrite n f) + -- result of a rewrite is a new graph and + -- a (possibly) new rewrite function +\end{smallcode} +If justified by the incoming fact, a rewrite function can +\emph{replace} a node with a graph, subject only to the requirement +that in any execution in which the incoming fact holds, the graph is +observationally equivalent to the node it replaces. +Rewrite functions implement all three kinds of transformations. + +Combine all three and you get a \emph{forward dataflow pass}: +\begin{code} +data FwdPass n f + = FwdPass { fp_lattice :: DataflowLattice f + , fp_transfer :: FwdTransfer n f + , fp_rewrite :: FwdRewrite n f } +\end{code} +What Hoopl does for you is captured in one function: +\begin{smallcode} +analyzeAndRewriteFwd + :: (Edges n, LabelsPtr entries) + => FwdPass n f + -> entries + -> Graph n e x + -> Fact e f + -> FuelMonad (Graph n e x, FactBase f, MaybeO x f) +\end{smallcode} +This function takes a forward pass, a graph with entry points, +and an incoming fact or fact~base. +It returns a rewritten graph, the fact associated with each label in +the rewritten graph, and if the graph is open at the exit, the fact +flowing out that exit. + +Backward dataflow passes use the same lattice type and appropriate +types for transfer and rewrite functions. + +\mysection*{Creating a client} + +To create an analysis or optimization, you +\begin{enumerate} +\item +Decide on a set of dataflow facts and identify what logical formulas +they approximate. +\item +Write the transfer function as the homomorphic image of the predicate + transformer \wp~or~\sp. +\item +Possibly create a rewrite function that exploits the dataflow fact to +make code-improving transformations. +\end{enumerate} +One beautiful aspect of this approach is that once you have chosen +a representation of nodes, \emph{there is only one correct way to + write \wp~and~\sp}. +You can therefore build a deep understanding of these predicate +transformers and how to approximate them. +Perhaps one day we'll have automated tests or even proofs, such as +Sorin Lerner has developed at UCSD. + +\mysection*{The critical bit I left out} + +Dataflow analysis does \emph{more} than classical program logic: +it can reason about \emph{paths}. +Classical Hoare logic gives a predicate about states, and the +predicate applies to any state that the machine can be in at a +particular program point, \emph{no matter what path it took to get + there}. +In~the jargon of dataflow analysis, anything analogous to Hoare logic +is an ``all-paths problem.'' +There are also ``any-paths problems,'' such as \emph{reachability}: +can a particular node be reached from the entry point? Or~from some +other node. + +To decide the redundancy of an assignment to variable~$x$, we solve a ``backwards +any-path problem:'' is there any path from the assignment to a +\emph{use} of~$x$ such that the path is not cut by any other +assignment to~$x$. + +As far as I know, it is not known if there is an analogy between path +problems and program logic. +I'm~keenly interested in this question. +I~find it telling that while we have a name for the set of paths +leaving a program +point---the point's \emph{continuation}---I don't know if we have a name +for the set of paths \emph{reaching} a program point. +Dataflow analyses can reason about history and about the future. +How~can we connect this reasoning to program semantics? + + +\mysection*{An example: dominators} + +If \emph{every} path from the entry to +label \texttt{L} must pass through another label \texttt{D}, +\texttt{D} \emph{dominates} \texttt{L}. +\texttt{D} is called a \emph{dominator} of \texttt{L}. +There are efficient special-purpose +algorithms for computing dominators, but we can also compute +dominators through a forward dataflow analysis. +The analysis is beautifully simple; it is based on an unpublished +paper by Cooper, Harvey, and Kennedy, who showed that their $O(N^2)$ version +outperforms the classical $O(E\;\log N)$ algorithm of Lengauer and +Tarjan. +\begin{enumerate} +\item +The dataflow fact at a point is a list of all the labels that dominate +the point: +\begin{code} +type DPath = [Label] -- path in dominator tree +\end{code} +The list is ordered such that every label is dominated by all its +successors. +The predicate associated with the dataflow fact is not a logical +formula; it is an assertion about the set of all paths from the entry to +the point at which the fact applies. + +The analysis requires a bottom element that is not a list; +bottom corresponds to an assertion that a node that is not reachable +from the entry, i.e., no path exists from the entry to that node. +The bottom element is added by type \texttt{WithBot}: +\begin{code} +type Doms = WithBot DPath +\end{code} +\item +The transfer function is simple: given a first node, it adds the label +to the head of the list. +Transfer for a middle node is the identity, and +transfer for a last node distributes the fact to its successors: +\begin{code} +domFirst n = (entryLabel n :) +domMiddle _ = id +domLast = distributeFact + +distributeFact :: Edges n => n O C -> f -> FactBase f +distributeFact n f + = mkFactBase [ (l, f) | l <- successors n ] +\end{code} +\item +The interesting part is the join function: +given two paths, it returns the longest common suffix: +\begin{code} +extend :: JoinFun DPath +extend _ (OldFact l) (NewFact l') + = (changeIf (l `lengthDiffers` j), j) + where j = lcs l l' + lcs :: [Label] -> [Label] -> [Label] + ... +\end{code} +The \texttt{WithBot} type comes with a lifting function that returns +\texttt{JoinFun~Doms}. +\end{enumerate} + +\subsection{Example results from dominator analysis} + +The program is insertation sort, with two nested loops: +\begin{smallcode} + a := 0 + goto L1 +L1: + if (a != d) then goto L2 else goto L3 +L6: + c[b] := e + goto L1 +L2: + a := (a + 1) + b := (a - 1) + e := c[b] + goto L4 +L4: + if ((b != 0) && (c[(b - 1)] > e)) then goto L5 else goto L6 +L5: + c[b] := c[(b - 1)] + b := (b - 1) + goto L4 +L3: +\end{smallcode} + +\centerline{% +\includegraphics[scale=0.4]{dom.eps}% +} + + +\end{document} + diff -Nru ghc-7.0.3/libraries/hoopl/paper/proto-response.txt ghc-7.2.1/libraries/hoopl/paper/proto-response.txt --- ghc-7.0.3/libraries/hoopl/paper/proto-response.txt 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/paper/proto-response.txt 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,87 @@ + * We apologize for missing definitions of types, functions, and data + structures. Since the submission deadline we have corrected some + of these faults, but regardless of whether the paper is accepted + we would be very grateful for a referee to point out other places + where information is missing. + + * We need to say something about Schmidt's paper. + + * We agree with reviewer #1 that our paper is about solid + engineering; we do not claim to have made a breakthrough. To an + engineer, 'appears straightforward' is a high compliment. In the + design of software and systems, one wishes always to build the + simplest system possible. A simple design usually seems obvious + only in retrospect. Certainly we believe that the interfaces + described in the paper are substantially simpler than the + interfaces we described in 2005, and we believe that this + simplification required substantial intellectual effort. But + perhaps others could have adapted the 2005 paper to something + equally simple with less effort. + + * We are sorry to have given the impression that the library is + conceived just to serve GHC and its intermediate language. We + have worked hard to make our library polymorphic so that it can be + used with *any* intermediate language, provided only that the + language distinguishes control transfers and provides a means to + follow control-flow edges. We hope soon to use the library with + representations of machine instructions for the various platforms + GHC supports. + + It is true that the *implementation* of the library depends on + GHC's internals in a few inessential ways, of which the most + important is probably that it uses an efficient implementation of + integer maps developed by Chris Okasaki and Andy Gill. + + * We're not sure what Reviewer #3 would accept as evidence for a + library's fitness for general purposes. This evaluation is + especially important as we make no claim to theoretical novelty + and no claim to enable analyses that cannot be implemented using + other methods. Our claim is that using our library, it is much + *easier* to implement analyses and transformations than it is + using other compiler infrastructures (e.g., SUIF or vpo, to name + two with which we are familiar). In order to substantiate this + claim, we included examples of analyses and optimizations which + are already known, so that readers can compare our code with code + written for their favorite compiler. + + To be extra confident in the correctness of the examples, we also + included *only* examples which have been implemented and tested as + part of GHC's back end. This decision may have influenced the + reviewer's impression that the library is not fit for general + purposes. + + * Along with Reviewer #2, we felt that section 7 was not properly + explained. In the process of developing a better explanation, we + have rewritten the dataflow engine twice. We have also rewritten + every part of section 7 except the part on 'optimization fuel'. + It would be unfair to ask referees to evaluate this new material, + but we feel constrained to let the referees know that whether the + paper is accepted at ICFP or is submitted to another venue, the + section 7 in the submission they have evaluated will not appear. + + * To reviewer #1: if register pressure could be approximated by, + e.g., the number of live variables, then it would be a + straightforward matter to write a dataflow pass that removes + redundant reloads when the number of live variables is small. In + fact our back end takes the opposite approach: we optimistically + insert a reload of $x$ only in front of the *first* use of $x$ + (explaining why we use dataflow and not a syntactic + transfomration). If register pressure leads to a spill, $x$ might + be spilled preferentially because we know that that value of $x$ + is already on the stack, and thus only a reloead is needed. (We + say 'might' because our register-allocation guru, who would know + for sure, is on his honeymoon.) + +If the paper is accepted, our priorities will be: + + 1. To make sure all missing definitions and explanations are + accounted for, so that readers can understand the code easily. + + 2. To provide a suitable scholarly account of the relationship with + Schmidt's work and with abstract interpretation more generally. + + 3. To work extra hard on the description of the new implementation + (Section 7) since that will not have been reviewed by the program + committee. + + 4. Anything else? diff -Nru ghc-7.0.3/libraries/hoopl/paper/refs.txt ghc-7.2.1/libraries/hoopl/paper/refs.txt --- ghc-7.0.3/libraries/hoopl/paper/refs.txt 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/paper/refs.txt 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,78 @@ +Andrew W. Appel. 1998. Modern Compiler Implementation. Cambridge +University Press, Cambridge, UK. Available in three editions: C, Java, and ML. + +John Cocke and Ken Kennedy. 1977. An algorithm for +reduction of operator strength. Communications of the ACM, 20(11): 850--856. + +Keith D. Cooper, Timothy J. Harvey, and Ken +Kennedy. 2001. A simple, fast dominance algorithm. Technical report, Rice +University. Unpublished report available from http://www.hipersoft.rice.edu/ +grads/publications/dom14.pdf. + +Patrick Cousot and Radhia Cousot. 1977 (January). +Abstract interpretation: A unified lattice model for static analysis of +programs by construction or approximation of fixpoints. In Conference Record of +the 4th ACM Symposium on Principles of Programming Languages, pages 238--252. + +Patrick Cousot and Radhia Cousot. 1979 (January). +Systematic design of program analysis frameworks. In Conference Record of the +6th Annual ACM Symposium on Principles of Programming Languages, pages 269--282. + +John B. Kam and Jeffrey D. Ullman. 1976. Global data flow +analysis and iterative algorithms. Journal of the ACM, 23(1):158--171. + +John B. Kam and Jeffrey D. Ullman. 1977. Monotone data +flow analysis frameworks. Acta Informatica, 7:305--317. + +Gary A. Kildall. 1973 (October). A unified approach to global +program optimization. In Conference Record of the ACM Symposium on Principles +of Programming Languages, pages 194--206. + +Jens Knoop, Oliver Ruething, and Bernhard +Steffen. 1992. Lazy code motion. Proceedings of the ACM SIGPLAN '92 Conference +on Programming Language Design and Implementation, in SIGPLAN Notices, 27 +(7):224--234. + +Sorin Lerner, David Grove, and Craig +Chambers. 2002 (January). Composing dataflow analyses and transformations. +Conference Record of the 29th Annual ACM Symposium on Principles of Programming +Languages, in SIGPLAN Notices, 31 (1):270--282. + +Thomas J. Marlowe and Barbara G. Ryder. 1990. +Properties of data flow frameworks: a unified model. Acta Informatica, 28 +(2):121--163. + +Steven S. Muchnick. 1997. Advanced compiler design and +implementation. Morgan Kaufmann, San Mateo, CA. + +Necula, McPeak, Rahul, and Weimer George C. Necula, Scott +McPeak, Shree Prakash Rahul, and Westley Weimer. 2002. CIL: Intermediate +language and tools for analysis and transformation of C programs. In CC '02: +Proceedings of the 11th International Conference on Compiler Construction, +pages 213--228. + +Norman Ramsey and João Dias. 2005 (September). An +applicative control-flow graph based on Huet's zipper. In ACM SIGPLAN Workshop +on ML, pages 101--122. + +Colin Runciman. 2010 (June). Finding and increasing PRS +candidates. Reduceron Memo 50, www.cs.york.ac.uk/fp/reduceron. + +David A. Schmidt. 1998. Data flow analysis is model checking of +abstract interpretations. In ACM, editor, Conference Record of the 25th Annual +ACM Symposium on Principles of Programming Languages, pages 38--48. + +Bernhard Steffen. 1991. Data flow analysis as model checking. In +TACS '91: Proceedings of the International Conference on Theoretical Aspects of +Computer Software, pages 346--365. + +Vallée-Rai, Gagnon, Hendren, Lam, Pominville, and +Sundaresan Raja Vallée-Rai, Etienne Gagnon, Laurie J. Hendren, Patrick Lam, +Patrice Pominville, and Vijay Sundaresan. 2000. Optimizing Java bytecode using +the Soot framework: Is it feasible? In CC '00: Proceedings of the 9th +International Conference on Compiler Construction, pages 18--34. + +David B. Whalley. 1994 (September). Automatic isolation of +compiler errors. ACM Transactions on Programming Languages and Systems, 16 +(5):1648--1659. + diff -Nru ghc-7.0.3/libraries/hoopl/paper/Rew.hs ghc-7.2.1/libraries/hoopl/paper/Rew.hs --- ghc-7.0.3/libraries/hoopl/paper/Rew.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/paper/Rew.hs 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,46 @@ +module Rew +where + +data Rew a = No + | Mk a + | Then (Rew a) (Rew a) + | Iter (Rew a) + +rewrite :: Rew (node -> fact -> Maybe graph) + -> node -> fact -> Maybe (graph, Rew (node -> fact -> Maybe graph)) +rewrite_direct rs n f = rew rs + where rew No = Nothing + rew (Mk r) = + case r n f of Nothing -> Nothing + Just g -> Just (g, No) + rew (r1 `Then` r2) = + case rew r1 of + Nothing -> rew r2 + Just (g, r1') -> Just (g, r1' `Then` r2) + rew (Iter r) = + case rew r of + Nothing -> Nothing + Just (g, r') -> Just (g, r' `Then` Iter r) + +rewrite rs node f = rew rs Just Nothing + where + rew No j n = n + rew (Mk r) j n = + case r node f of Nothing -> n + Just g -> j (g, No) + rew (r1 `Then` r2) j n = rew r1 (j . add r2) (rew r2 j n) + rew (Iter r) j n = rew r (j . add (Iter r)) n + add tail (g, r) = (g, r `Then` tail) + +rewritem :: Monad m => Rew (node -> fact -> m (Maybe graph)) + -> node -> fact -> m (Maybe (graph, Rew (node -> fact -> m (Maybe graph)))) +rewritem rs node f = rew rs (return . Just) (return Nothing) + where + rew No j n = n + rew (Mk r) j n = do mg <- r node f + case mg of Nothing -> n + Just g -> j (g, No) + rew (r1 `Then` r2) j n = rew r1 (j . add r2) (rew r2 j n) + rew (Iter r) j n = rew r (j . add (Iter r)) n + add tail (g, r) = (g, r `Then` tail) + diff -Nru ghc-7.0.3/libraries/hoopl/paper/spell.mk ghc-7.2.1/libraries/hoopl/paper/spell.mk --- ghc-7.0.3/libraries/hoopl/paper/spell.mk 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/paper/spell.mk 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,21 @@ +%-spell:V: %.nw + PATH=/usr/lib/noweb:/usr/local/noweb/lib:$PATH + markup $prereq | + sed -e '/^@begin code/,/^@end code/d' -e '/^@quote/,/@endquote/d' | + unmarkup | + strip-tex-markup | + sed '/^\\begin{verbatim}/,/^\\end{verbatim}/d' | + # detex -l | spell +okwords.sort | grep -v '[:,&.]' | grep -v '^[0-9A-Z]*$' + (sed 's/^/*/' $HOME/okwords.txt; sed 's/^/^/') | ispell -t -a | + sed '/^[*+]/d;/^$/d;s/[0-9][0-9 ]*[0-9]/9/;s/ *[0-9][0-9]*//' | sort -uf + +%-texspell:V: %.tex + strip-tex-markup $prereq | + sed -e '/^\\begin{verbatim}/,/^\\end{verbatim}/d' \ + -e '/^\\begin{code}/,/^\\end{code}/d' \ + -e '/^\\begin{smallverbatim}/,/^\\end{smallverbatim}/d' \ + -e '/^\\begin{smallcode}/,/^\\end{smallcode}/d' \ + -e '/^\\begin{numberedcode}/,/^\\end{numberedcode}/d' | + (sed 's/^/*/' $HOME/okwords.txt; sed 's/^/^/') | ispell -t -a | + sed '/^[*+]/d;/^$/d;s/[0-9][0-9 ]*[0-9]/9/;s/ *[0-9][0-9]*//' | sort -uf + diff -Nru ghc-7.0.3/libraries/hoopl/paper/TODO ghc-7.2.1/libraries/hoopl/paper/TODO --- ghc-7.0.3/libraries/hoopl/paper/TODO 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/paper/TODO 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,26 @@ +HOOPL: + - get Simon to review Lerner, Ullman & Kam, Kildall + - implementation section: why? + . really exists + . not insane + . dramatically simpler than original & other implementations + . can see some of the idea + - massive failure of parallel structure between sections 3 and 6 + (three bullets) + - Hypothesis: + + if {P} s --> s' by rewrite, and {P} s {Q} and {P} s' {Q'}, then + Q \sqsubseteq Q' + + if s {Q} --> s' by rewrite, and {P} s {Q} and {P'} s' {Q}, then + P' \sqsubseteq P + + Why do we care? Is this a theorem? A requirement? Do we want + implication (in the logic) and not a lattic op? How does + implication translate to lattice ops, anyway? (disjunction ~ join) + + + +DFOPT: if any extra room, restore Davidson reference! + then: 'to reduce register pressure' + then: 2nd dataflow paper diff -Nru ghc-7.0.3/libraries/hoopl/paper/xsource ghc-7.2.1/libraries/hoopl/paper/xsource --- ghc-7.0.3/libraries/hoopl/paper/xsource 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/paper/xsource 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,75 @@ +#!/usr/bin/env lua + +local shift = '^' -- prefix of blanks to remove + +if arg[1] and arg[1]:find '^%-%d+$' then + shift = '^' .. string.rep(' ', -tonumber(arg[1])) + table.remove(arg, 1) +end + +local outputs = { } -- map filename to list of lines +setmetatable(outputs, { __index = function(t, k) local u = {}; t[k] = u; return u end }) + +local function add_modified_line(lines, l) + if l:find '%{ fact_name%s+=' + or l:find '^%s*%-%- See Note ' + then + return + end + l = l:gsub('%s*%-%- Note %[.*$', '') + l = l:gsub('%s*%-%- I do not understand.*$', '') + l = l:gsub('^(%s*),( fact_bot)', '%1{%2') +-- l = l:gsub('^(%s*, fact_join = .*)$', '%1 }') + l = l:gsub('%s*%-%-%s%^.*$', '') + l = l:gsub('CheckpointMonad', 'CkpointMonad') + return table.insert(lines, l) +end + + +local function shift_left(l, n) + l = l:gsub('^' .. string.rep(' ', n), '') + return l +end + +for _, file in ipairs(arg) do + local outfile, distance + for l in io.lines(file) do + local action, filename, n = l:match '^%s*%-%-%s%@%s+(%w+)%s+(%S+)%s+%-(%d+)%s*$' + if not n then + action, filename = l:match '^%s*%-%-%s%@%s+(%w+)%s+(%S+)%s*$' + n = action and 0 + end + if action == 'start' then + assert(outfile == nil and distance == nil) + outfile, distance = filename, n + elseif action == 'stop' or action == 'end' then + assert(outfile, '@stop without @start: ' .. l) + assert(outfile == filename, l .. 'does not match @start ' .. outfile) + outfile, distance = nil, nil + elseif action ~= nil then + error("Unknown action '" .. action .. "' in line " .. l) + else + if outfile then + add_modified_line(outputs[outfile], shift_left(l, distance)) + end + end + end +end + +for file, lines in pairs(outputs) do + local f = assert(io.open(file, 'w')) + local do_shift = true + for _, l in ipairs(lines) do + if not l:find(shift) then + do_shift = false + break + end + end + for _, l in ipairs(lines) do + f:write(do_shift and l:gsub(shift, '') or l, '\n') + end + f:close() +end + + + \ No newline at end of file diff -Nru ghc-7.0.3/libraries/hoopl/private/authors-response ghc-7.2.1/libraries/hoopl/private/authors-response --- ghc-7.0.3/libraries/hoopl/private/authors-response 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/private/authors-response 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,56 @@ +We agree with the reviewers on almost all points. However, we draw +a more positive conclusion from these points than the reviewers imply: + + * We agree with reviewer #1 that our paper is about solid + engineering, a subject that is often valued at ICFP. + + As engineers, we take reviewer #2's comment 'appears + straightforward' as a high compliment. A simple design can be + surprisingly difficult to achieve; it is often obvious only in + retrospect. We believe that the interfaces described in the paper + are substantially simpler than the interfaces we described in + 2005, and unlike the interfaces in the 2005 paper, they are + reusable. + + * The impression that our library is conceived just to serve GHC + represents a misleading failure of our presentation. We + specifically made our library *polymorphic* so that it can be used + with *any* intermediate language, provided only that the language + distinguishes control transfers and provides a means to follow + control-flow edges. We hope soon to use the library with + representations of machine instructions. + + * We hope Reviewer #3 may reconsider whether our library is fit for + general purposes. We make no claim to theoretical novelty and no + claim to enable analyses that cannot be implemented using other + methods. Our claim is that using our library, it is much *easier* + to implement dataflow analyses and transformations than it is + using other compiler infrastructures (e.g., SUIF or vpo, to name + two with which we are familiar). In substantiating this claim, we + chose examples of analyses and optimizations that are already + known, so that readers can compare our code with code written for + their favorite compilers. + + To be sure the examples are right, we chose *only* examples that + have been implemented and tested in GHC. This choice may have + influenced the reviewer's impression that the library is not fit + for general purposes. + +There are many faults in the paper. If the paper is accepted, + + 1. We will make sure all missing definitions and explanations are + accounted for, so that readers can understand the code easily. + + 2. We will rewrite Section 7 completely. (We have already done so, + but since it would be unfair to ask the reviewers to base a + decision on work done since the deadline, we say no more here.) + + 3. We will provide a suitable scholarly account of the relationship + with Schmidt's work and with abstract interpretation more generally. + +To reviewer #1: if register pressure could be approximated by, +e.g., the number of live variables, then it would be a +straightforward matter to write a dataflow pass that removes +redundant reloads when the number of live variables is small. +It would require a forward pass to mark the redundant reloads and a +backward pass to remove them. diff -Nru ghc-7.0.3/libraries/hoopl/private/icfp09.reviews ghc-7.2.1/libraries/hoopl/private/icfp09.reviews --- ghc-7.0.3/libraries/hoopl/private/icfp09.reviews 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/private/icfp09.reviews 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,186 @@ +Dear Prof. Norman Ramsey: + +Final versions of the reviews for your submission + + Dataflow Optimization Made Simple + +are at the bottom of this mail. I hope you will find them +useful. + +Please note that in some cases these reviews have been +updated since the author response period. Also, additional +reviews may have been received after the response period +ended; if this was the case, the committee took note of the +fact that you did not have the opportunity to respond to +them. + +Again, if you have any additional questions, please feel free +to contact me. + + +Sincerely, +Andrew Tolmach +PC Chair + +============================================================================ +ICFP 2009 Reviews for Submission #8 +============================================================================ + +Title: Dataflow Optimization Made Simple + +Authors: Norman Ramsey, Joao Dias and Simon Peyton Jones +============================================================================ + REVIEWER #1 +============================================================================ + + +--------------------------------------------------------------------------- +Comments +--------------------------------------------------------------------------- + +The authors present "a Haskell library that makes it easy for compiler writers +to implement program transformations based on dataflow analyses". + +Although the main goal of the paper is interesting, I think that the authors' +proposal is not so general as claimed in the abstract (and +expected for a general Haskell library). + +>From a theoretical point of view, it does not introduce anything really new +(the theoretical basis comes from a POPL'02 paper by Lerner, Grove, and +Chambers). + +>From a practical point of view, I find the following drawbacks: + +1.- Although a general purpose library is claimed to be given, +the development focuses on some few (already known) program analyses +and optimizations which are defined and described for C--, +a particular compiler-target intermediate language +which (as far as I know) is not widely used. +Actually, at the end of the abstract it is said that +this library is the "workhorse of a new backend for GHC". + +2.- Many types, functions and data structures are not defined in the paper. +For instance, the types VarSet or Middle (together with some data constructors +like MidAssign, CmmLocal, CmmLoad, etc., and defined functions like aTx, noTx, +etc.) in Figures 3 to 7 seem to be part of the types which are used +in the current implementation of GHC (this is explicit for Middle as one can +read in the but last paragraph of the second column in page 5) or in a full +description of the library which is not available anywhere (at least I found +no link to any additional information about them). This makes the code in +Figures 3 to 7 more difficult to read and understand and, again, more difficult + +to generalize to compilers of other programming languages different from C— + +3.- It is unclear to me how the optimization of the target code is achieved +by using the proposed functions. The focus is on the dataflow graph but +nothing is said about how this graph is obtained from the unoptimized code +and how an optimized target code is obtained from the transformed/rewritten +graph. + +Overall, the paper is very well-written. I also find interesting the +ideas dropped in the Conclusions, and have no doubt that FP can export +many ideas and techniques for optimizing compilers of more 'traditional' +programming languages. However, I failed to see how the proposed +library helps to achieve this since, in my opinion, it +seems to be conceived just to serve the GHC compiler. + +============================================================================ + REVIEWER #2 +============================================================================ + + +--------------------------------------------------------------------------- +Comments +--------------------------------------------------------------------------- + +This paper presents a Haskell library for implementing a general +dataflow analysis and optimization through examples and describes +its implementation. + +The introductory part of sections 1 - 6 contains a nice introduction +to dataflow optimization, and convincing argument on ease of +developing variety of dataflow optimizers using the presented +library. However, the presented library appears to be a +straightforward porting of Ramsey and Dias's dataflow infrastructure +based on applicative representation of control flow graph based on +Huet's Zipper. Data representation and the structures of the +optimization engine appears to be quite similar, and it is unclear +what the new technical contributions are. In addition, the description +of the dataflow engine in Section 7 of is not very clear due to lack +of proper explanation. For example, readers would have some difficulty +in understanding the importance and relevance of the data types such +as "Block", "ZTail" and "Zhead" unless they were already familiar with +the underlying Zipper style representation of control flow graph with +the corresponding definitions (ie, "block", "head" and "tail") given +in Ramsey and Dias's original article. + +I understand that sometimes republishing a workshop paper in ICFP +would be appropriate especially when the workshop is limit visibility, +but this may not be the case. The audience of ML workshop +significantly overlap with those of ICFP and that the proceeding of ML +2005 has been published in Elsevier's Electronic Notes in Theoretical +Computer Science, which is widely available and archival publication. + +As such, I doubt that this paper contains enough original contribution +appropriate for publication in ICFP 2009. + +============================================================================ + REVIEWER #3 +============================================================================ + + +--------------------------------------------------------------------------- +Comments +--------------------------------------------------------------------------- + +This paper describes the design and Haskell implementation of a generic library +for dataflow analysis and code transformations. Examples of classic dataflow +analyses expressed using the library are shown and appear remarkably compact. + +A distinguishing feature of this library is that it supports combined analysis +and transformation, whereas the result of the analysis anticipates the effect +of the code transformation. This follows the approach proposed by Lerner et al +in 2002. It is pointed out that this enables combining several +analysis/transformation passes in one, but no example is given. The only +example given where analyze&transform gives better results than +analyze-then-transform is dead code elimination by liveness analysis, but as +noted in footnote 1 it was already known how to achieve the same result using a +standard analyze-only dataflow solver. + +80% of the paper describe the library and its use. The remaining 20% read more +like a lecture on dataflow analysis, presented as inference of (certain classes +of) logical assertions. I wasn't completely convinced by this presentation, +which I found less penetrating than D. Schmidt's famous "Data flow analysis is +model checking of abstract interpretations". More generally, it is surprising +that abstract interpretation is mentioned nowhere in this paper. + +All in all, this is a well-written paper describing a very solid piece of +compiler engineering, but I didn't see a breakthrough. + +Minor comments: + +The example in section 4 is a bit mysterious. Once the set of variables live +across a function call has been computed (by a standard liveness analysis), it +is a simple syntactic transformation to insert a spill after each definition +(of one of those variables) and a reload before each use; no further dataflow +analyses are needed. Yes, this can give less precise results than the proposed +approach if there are multiple definitions of a variable, some live across a +call and some not (can this happen in GHC's intermediate code?). But, still, +the hard part about spilling and reloading is to eliminate multiple reloads in +areas of code where register pressure is low, e.g. + + x = ... + + spill(x) + + ... + + reload(x) + + y = ... x ... + + // do not reload(x) again if register pressure is low + + z = ... x ... + +I didn't see whether / how the proposed approach could do this. diff -Nru ghc-7.0.3/libraries/hoopl/private/popl10-reviews.txt ghc-7.2.1/libraries/hoopl/private/popl10-reviews.txt --- ghc-7.0.3/libraries/hoopl/private/popl10-reviews.txt 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/private/popl10-reviews.txt 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,302 @@ +=========================================================================== + POPL 2010 Review #28A + Updated Saturday 25 Jul 2009 8:03:25am PDT +--------------------------------------------------------------------------- + Paper #28: Hoopl: Dataflow Optimization Made Simple +--------------------------------------------------------------------------- + + Overall merit: B. OK paper, but I will not champion + it. + Reviewer expertise: Z. I am an informed outsider of the + area. + + ===== Paper summary ===== + +The paper presents an approach to specifying and combining data flow analyses. The authors do program analysis by solving equations, they relate assertions via weakest liberal preconditions and strongest postconditions, and they combine analyses and transformations using the POPL 2002 paper by Lerner, Grove, and Chambers. The entire framework is written in a functional, nonimperative style that uses zippers and a dataflow monad, and is polymorphic in the underlying representations. + + ===== Comments for author ===== + +The paper reads more like a pearl than a research paper. The paper combines "everything we know" into an elegant system for program analysis and optimization. + +The examples of analyses and transformations are admirably short, and the paper gives several examples of how they apply to programs. + +The main difficulty that has been overcome by the authors is doing the design of the system in a way puts together many ideas in a neat and seamless way. + +Question: do you have experimental results that show that the quality of the produced code can compete with that of state-of-the-art compilers? + +=========================================================================== + POPL 2010 Review #28B + Updated Saturday 1 Aug 2009 9:46:50am PDT +--------------------------------------------------------------------------- + Paper #28: Hoopl: Dataflow Optimization Made Simple +--------------------------------------------------------------------------- + + Overall merit: C. Weak paper, though I will not fight + strongly against it. + Reviewer expertise: Y. I am knowledgeable in the area, + though not an expert. + + ===== Paper summary ===== + +The paper presents the interface of an Haskell generic library for dataflow analysis combined with code transformations, in the style of Lerner, Grove and Chambers (POPL 2002). + +The approach is illustrated by very compact implementations of two classic analyses (available variables and liveness) and a less common (and harder to follow) analysis+transformation for the insertion of spill and reload instructions. + + ===== Comments for author ===== + +All in all, this is a very solid piece of compiler engineering, and the paper is well written . But there are essentially no new principles in this paper. The only really novel aspect of this work ("analyze and transform" instead of "analyze then transform") is taken from Lerner et al. The use of an applicative "zipper" to represent the CFG scores some points for originality but was already published by the first two authors in a workshop paper (ENTCS 148(2)). + +The authors also claim as an achievement the simplicity of their API, but I'm not convinced: for dataflow analysis at least, simpler interfaces could be obtained by throwing away the distinction between "first", "middle" and "last" nodes and working on a CFG of individual instructions [1]. See for example the presentations of Kildall's dataflow equation solver by Klein and Nipkow [2] and by Coupet-Grimal and Delobel [3], both of which were also mechanically proved correct. + +I was excited, at first, by the extended example on insertion of reload and spill instructions, because this is an isse that is not well treated in compiler textbooks. In the end, I was a bit disappointed: I had the feeling that the proposed approach doesn't work significantly better than the trivial approach of inserting a spill after every definition and a reload before every use for each variable that couldn't be allocated to a register. Isn't the proposed approach overengineered? + +Minor remarks: + +Page 3, col 2, "the analysis shows nothing about x, which we notate x = bottom". This explanation of bottom sounds wrong. Thinking in terms of abstract interpretation, k denotes the singleton set of values {k}, top the set of all values, and bot the empty set of values. Knowing x = bottom at the end of the analysis really means something very strong about x, namely that all its definitions are unreachable. + +References: + +[1] Jens Knoop, Dirk Koschützki and Bernhard Steffen. + "Basic-Block Graphs: Living Dinosaurs?". + Proc. Compiler Construction '98, LNCS 1383, 1998. + +[2] Gerwin Klein and Tobias Nipkow. + "Verified bytecode verifiers". + Theor. Comp. Sci 298, 2003. + +[3] Solange Coupet-Grimal and William Delobel. + "A Uniform and Certified Approach for Two Static Analyses". + Types for Proofs and Programs, International Workshop, TYPES 2004. + LNCS 3839, 2006. + +=========================================================================== + POPL 2010 Review #28C + Updated Friday 11 Sep 2009 6:15:44pm PDT +--------------------------------------------------------------------------- + Paper #28: Hoopl: Dataflow Optimization Made Simple +--------------------------------------------------------------------------- + + Overall merit: C. Weak paper, though I will not fight + strongly against it. + Reviewer expertise: Y. I am knowledgeable in the area, + though not an expert. + + ===== Paper summary ===== + +The paper presents a data flow analysis and program transformation framework. The framework, Hoopl, is implemented as a Haskell library that compiler writers can use to implement optimizations. The paper presents examples of actual analyses and transformations in the context of the Glasgow Haskell compiler, and outlines the implementation of the dataflow engine, which is the main part of Hoopl. + + ===== Comments for author ===== + +It is hard to pinpoint exactly the technical contribution of this paper. On one hand, it appears to be a beautifully engineered implementation of a data flow analysis framework but there is little comparison with other similar frameworks and at this point little evidence that this is the "right" design with the right compromise between expressiveness and generality. The paper is also an improvement over Ramsey and Dias's work but the improvements are scattered here and there. Finally the paper, I feel, is hard to appreciate without some familiarity with the GHC backend. Some of the code has to be elided and some of the code presented uses the actual GHC datatypes (which is good in some sense but also adds some unneeded complexity to the examples). + +A couple of specific comments/questions: + +- can you explain in more detail the reasons for implementing the rewriting in two steps: first a speculative step and then a step that commits it. Is that because the intermediate results of the analysis are unsound and that soundness is only achieved when the analysis reaches a fixed point? + +- can you provide more detail on how the optimization fuel is used for debugging + +=========================================================================== + POPL 2010 Review #28D + Updated Tuesday 15 Sep 2009 5:36:29am PDT +--------------------------------------------------------------------------- + Paper #28: Hoopl: Dataflow Optimization Made Simple +--------------------------------------------------------------------------- + + Overall merit: B. OK paper, but I will not champion + it. + Reviewer expertise: Y. I am knowledgeable in the area, + though not an expert. + + ===== Paper summary ===== + +This paper describes Hoopl, a dataflow optimization tool. The paper +first analyzes general properties and principles underlying various +dataflow analysis for low-level code languages through examples, and +identifies major components of a general dataflow optimizer: (1) a +dataflow fact lattice, (2) a transfer function that computes a dataflow +fact of a program point from the preceding (depending of the direction +of the analysis) dataflow facts, (3) a rewrite function that replaces a +node in a control flow graph based on dataflow facts. Based on this +analysis, the paper introduces Hoopl as a generic dataflow optimizer +through type signatures of Hoopl functions, and describes their +functionality. Hoopl takes a dataflow fact lattice (i.e. types and +associated operations), a transfer function, a rewriter, and performs +the iterative process of analyzing the graph using the transfer +function and transforming the graph using the rewrite function until +it obtains the least fixed point. The paper then describes some +aspects of its implementation, including its two phase architecture +consisting of a speculative iterator and an actualizer, and describes +the implemented forward iterator and forward actualizer in some details. + + ===== Comments for author ===== + +From the presentation, it seems that Hoopl is an easy to use and +generic tool that automates dataflow optimization for low-level code +languages. It is well engineered so that compiler writers can readily +use it for implementing various optimizations in their optimizing +compilers. The paper is also very well written. Hoopl's description +through examples can serve as a nice tutorial on unified view of +dataflow optimization. + +However, I am not completely sure that this paper makes significantly +new contribution to POPL 2010. Although being a well engineered tool, +Hoopl appears to be based on combinations of known results. +The overall structure of representation and implementation is based +on some of the authors earlier work on zipper-style control-flow graph +representation and optimization. There are some improvements on +representations and interfaces: graphs are classified into "open" and +"closed" ones, and interfaces of graph splicing functions are +improved. The overall structure of interleaved analysis and +transformation is due to other existing work. Hoopl also combines +debugging facility, which is based on excising work. The description +of its implementation is too sketched to be useful in implementing new +optimization engines. + +=========================================================================== + POPL 2010 Review #28E + Updated Wednesday 16 Sep 2009 9:22:46am PDT +--------------------------------------------------------------------------- + Paper #28: Hoopl: Dataflow Optimization Made Simple +--------------------------------------------------------------------------- + + Overall merit: C. Weak paper, though I will not fight + strongly against it. + Reviewer expertise: X. I am an expert in the subject area + of this paper. + + ===== Paper summary ===== + +This paper presents an analysis and transformation engine implemented +in Haskell. To use the engine, the programmer provides a description +of the lattice, transfer functions, and rewrite functions. The engine +then takes care of computing the dataflow fixed point and applying the +rewrites. The paper describes the interface to the engine, shows +examples of several client analyses and optimizations and describes an +implementation of the engine. + + ===== Comments for author ===== + +The interesting part of this paper is that it shows how to effectively +combine several previously known techniques/ideas into a single +engine. These techniques/ideas are: the fixed-point formulation of +dataflow analyses; the rewrite-rule formulation of transformation +rules; the composition technique of Lerner Grove and Chambers; and the +fuel-based abstraction of Whalley for quickly narrowing down the +source of compiler bugs. + +However, it's hard to tease out what exactly the contribution +is. Datafow analysis engines based on lattices, transfer functions, +and rewrite functions are very common (Weimer and Necula's CIL has +one, Hendren et al's Soot has one, Lattner and Adve's LLVM has one, +IBM's WALA engine has one). It would be interesting to better +understand how the proposed framework distinguishes itself from these +existing frameworks. + +Presumably, one difference is that the proposed framework incorporates +additional techniques (eg: the composition framework and the +fuel-based abstraction). However, these two techniques were previously +published, and they also seem quite orthogonal to each other (which +means the integration of the two techniques would not pose too many +additional challenges -- if it does, the paper should focus on this). + +The paper does point out how Haskell helps with many of the +implementation tasks, and the use of Haskell is indeed a difference +from other frameworks. However, the paper doesn't really develop this +point, and it's also not clear how much of this type checking also +exists in other frameworks (eg: CIL uses OCaml so it may have some +nice static type-checking guarantees) The paper would be stronger if +it had a direct comparison (maybe a table?) of what kinds of +properties are statically checked using types in the proposed +framework, vs CIL, Soot, LLVM, and others frameworks too. + +The paper could also be improved by reporting on experience in using +the framework. For example: what was it used for? what are some +statistics about the framework (number of analyses implemented, how +many lines of code, bugs found using types, etc.) how does experience +with the proposed framework compare with other frameworks such as LLVM +(eg: for conciseness, ease of use, etc) + +Finally, the paper doesn't seem to address interprocedural analyses +and optimizations (although that's understandable to some extent -- +one has to nail down the intra-procedural case first, but it would be +nice to get an idea of how the authors see this framework panning out +in the interprocedural case) + +=========================================================================== + Author's Response by Norman Ramsey + Paper #28: Hoopl: Dataflow Optimization Made Simple +--------------------------------------------------------------------------- +The referees' reports are clear, and we haven't identified any +significant misunderstandings. Several referees suggest that the +paper reads more like a pearl than a research contribution, and we are +happy to have it evaluated as such. Below we answer referees' +questions. (Having received such nice detailed reviews, we don't want +to leave referees' questions hanging unanswered, but it is probably +not necessary to read the answers below in order to make a decision +about the paper.) + +Referee A asks if we have experimental results which show that the +quality of generated code can compete with state-of-the-art compilers. +Yes, we have experimental results with the Glasgow Haskell Compiler +which show that the new back end produces code at least as good as the +old back end. But although GHC's front end contains some very +sophisticated optimizations, by the time the code gets to the level +shown in the paper, the back-end optimizations are limited, and so +GHC's bar is actually set low. + +Referee B, citing Knoop, Koschützki, and Steffen, points out that the +API might be simpler if we eliminated the static type distinction +between 'first', 'last', and 'middle' nodes. Ironically, we were very +inspired by the 'living dinosaur' paper and used it as the starting +point for our representation of control-flow graphs. But giving all +nodes the same type led to a great deal of run-time checking, and to +preserve our sanity we were forced to distinguish at compile time +between first, middle, and last nodes, which of course means that we +reinvented basic blocks. Perhaps one way to think about the design +issues here is that although the split into three static types makes +the API wider, client code is simpler because each of the three static +types of node obeys a stronger invariant (constraining the numbers of +predecessors or successors). In any case, we have experience with +both representations, and our experience is that the wider API leads +to a simpler compiler overall---although we don't know how to make +that case compellingly in a conference submission. + +Referee C asks why we rewrite in two steps. The referee has the +answer exactly: during the first step of the analysis, speculative +rewriting produces intermediate results which are not guaranteed to be +sound until a fixed point is reached. + +Referee C asks for more detail on how the optimization fuel is used +for debugging. Suppose we are regression-testing the compiler and a +test fails. We re-run the same test with no fuel. If the test then +succeeds, the optimizer is at fault. We ask the compiler how much +fuel was used on the original run, and we use that as the starting +point for a binary search on the fuel supply. This binary search +identifies a single graph-node rewrite which transforms a working test +case into a failed test case. At this point there's no more +automation; the compiler writer takes over and diagnoses whether the +transformation is unjustified or the underlying analysis is faulty. +To summarize, optimization fuel is used to find, in logarithmically +many runs of the compiler, the transformation, analysis, node, and +rewrite that cause a fault. We should add that although this process +is completely automated in the 'Quick C--' compiler written by the +first two authors, it is not yet automated in the Glasgow Haskell +Compiler. + +Referee E observes that CIL uses OCaml so it may have some nice static +type-checking guarantees. We wrote a predecessor of Hoopl in OCaml +and the static typing was not bad, but having the 'open' and 'closed' +graph properties checked statically is a significant upgrade---we +eliminated a number of dynamic checks, some of which had been sources +of bugs. It is possible that a creative encoding into OCaml would +make it possible to check the same properties statically using only +OCaml's Hindley-Milner system, but GHC's extension of generalized +algebraic data types makes it very easy to provide the extra static +checking. + +Referee E also suggests we should compare Hoopl with other engines for +dataflow analysis. We are all wearing our stupid hats and whacking +ourselves in the head for not thinking of this. If it should happen +that the paper is accepted, we'll do a proper job. + + diff -Nru ghc-7.0.3/libraries/hoopl/private/popl2010-reviews.txt ghc-7.2.1/libraries/hoopl/private/popl2010-reviews.txt --- ghc-7.0.3/libraries/hoopl/private/popl2010-reviews.txt 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/private/popl2010-reviews.txt 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,292 @@ + +POPL 2010 +Paper #28 +nr@cs.tufts.edu | Help | Sign out | Thursday 17 Sep 2009 6:38:16pm PDT + Your submissions #29-> + +[Main] Main +[Edit] Edit +#28 + Comment notification +If selected, the system will email you when updated comments are available. +PC conflicts +None + + + +Hoopl: Dataflow Optimization Made Simple + + + + +Submitted [PDF] 201kB Updated Wednesday 15 Jul 2009 3:35:28pm PDT | SHA-1 58af8027d3a1ff45917d786fde3ed90b2885d754 +You are an author of this paper. ++ Abstract\u2212 Abstract +We present Hoopl, a Haskell library that makes it easy for compiler writers to implement program transformations based on dataflow analyses. The compiler writer must identify [more]We present Hoopl, a Haskell library that makes it easy for compiler writers to implement program transformations based on dataflow analyses. The compiler writer must identify (a) logical assertions on which the transformation will be based; (b) a representation of such assertions, which should form a lattice of finite height; (c) transfer functions that approximate weakest preconditions or strongest postconditions over the assertions; and (d) rewrite functions whose soundness is justified by the assertions. Hoopl uses the algorithm of Lerner, Grove, and Chambers (2002), which can compose very simple analyses and transformations in a way that achieves the same precision as complex, handwritten "superanalyses." Hoopl will be the workhorse of a new back end for the Glasgow Haskell Compiler (version 6.12, forthcoming). Because the major claim in the paper is that Hoopl makes it easy to implement program transformations, the paper is filled with examples, which are written in Haskell. The paper also sketches the implementation of Hoopl, including some excerpts from the implementation. + ++ Authors\u2212 Authors +N. Ramsey, J. Dias, S. Jones [details]Norman Ramsey (Tufts University) +João Dias (Tufts University) +Simon Peyton Jones (Microsoft Research) ++ Topics\u2212 Topics +Compilers Static analysis + + + OveMer RevExp +Review #28A B Z +Review #28B C Y +Review #28C C Y +Review #28D B Y +Review #28E C X +[Edit paper] Edit paper | [Add response] Add response + + [Text] Reviews and comments in plain text + + + +[Text] Plain text +Review #28A +Modified Saturday 25 Jul 2009 8:03:25am PDT + + +Overall merit (?) +B. OK paper, but I will not champion it. + +Reviewer expertise (?) +Z. I am an informed outsider of the area. +Paper summary +The paper presents an approach to specifying and combining data flow analyses. The authors do program analysis by solving equations, they relate assertions via weakest liberal preconditions and strongest postconditions, and they combine analyses and transformations using the POPL 2002 paper by Lerner, Grove, and Chambers. The entire framework is written in a functional, nonimperative style that uses zippers and a dataflow monad, and is polymorphic in the underlying representations. + +Comments for author +The paper reads more like a pearl than a research paper. The paper combines "everything we know" into an elegant system for program analysis and optimization. + +The examples of analyses and transformations are admirably short, and the paper gives several examples of how they apply to programs. + +The main difficulty that has been overcome by the authors is doing the design of the system in a way puts together many ideas in a neat and seamless way. + +Question: do you have experimental results that show that the quality of the produced code can compete with that of state-of-the-art compilers? + + + + + + +[Text] Plain text +Review #28B +Modified Saturday 1 Aug 2009 9:46:50am PDT + + +Overall merit (?) +C. Weak paper, though I will not fight strongly against it. + +Reviewer expertise (?) +Y. I am knowledgeable in the area, though not an expert. +Paper summary +The paper presents the interface of an Haskell generic library for dataflow analysis combined with code transformations, in the style of Lerner, Grove and Chambers (POPL 2002). + +The approach is illustrated by very compact implementations of two classic analyses (available variables and liveness) and a less common (and harder to follow) analysis+transformation for the insertion of spill and reload instructions. + +Comments for author +All in all, this is a very solid piece of compiler engineering, and the paper is well written . But there are essentially no new principles in this paper. The only really novel aspect of this work ("analyze and transform" instead of "analyze then transform") is taken from Lerner et al. The use of an applicative "zipper" to represent the CFG scores some points for originality but was already published by the first two authors in a workshop paper (ENTCS 148(2)). + +The authors also claim as an achievement the simplicity of their API, but I'm not convinced: for dataflow analysis at least, simpler interfaces could be obtained by throwing away the distinction between "first", "middle" and "last" nodes and working on a CFG of individual instructions [1]. See for example the presentations of Kildall's dataflow equation solver by Klein and Nipkow [2] and by Coupet-Grimal and Delobel [3], both of which were also mechanically proved correct. + +I was excited, at first, by the extended example on insertion of reload and spill instructions, because this is an isse that is not well treated in compiler textbooks. In the end, I was a bit disappointed: I had the feeling that the proposed approach doesn't work significantly better than the trivial approach of inserting a spill after every definition and a reload before every use for each variable that couldn't be allocated to a register. Isn't the proposed approach overengineered? + +Minor remarks: + +Page 3, col 2, "the analysis shows nothing about x, which we notate x = bottom". This explanation of bottom sounds wrong. Thinking in terms of abstract interpretation, k denotes the singleton set of values {k}, top the set of all values, and bot the empty set of values. Knowing x = bottom at the end of the analysis really means something very strong about x, namely that all its definitions are unreachable. + +References: + +[1] Jens Knoop, Dirk Koschützki and Bernhard Steffen. + "Basic-Block Graphs: Living Dinosaurs?". + Proc. Compiler Construction '98, LNCS 1383, 1998. + +[2] Gerwin Klein and Tobias Nipkow. + "Verified bytecode verifiers". + Theor. Comp. Sci 298, 2003. + +[3] Solange Coupet-Grimal and William Delobel. + "A Uniform and Certified Approach for Two Static Analyses". + Types for Proofs and Programs, International Workshop, TYPES 2004. + LNCS 3839, 2006. + + + + + + +[Text] Plain text +Review #28C +Modified Friday 11 Sep 2009 6:15:44pm PDT + + +Overall merit (?) +C. Weak paper, though I will not fight strongly against it. + +Reviewer expertise (?) +Y. I am knowledgeable in the area, though not an expert. +Paper summary +The paper presents a data flow analysis and program transformation framework. The framework, Hoopl, is implemented as a Haskell library that compiler writers can use to implement optimizations. The paper presents examples of actual analyses and transformations in the context of the Glasgow Haskell compiler, and outlines the implementation of the dataflow engine, which is the main part of Hoopl. + +Comments for author +It is hard to pinpoint exactly the technical contribution of this paper. On one hand, it appears to be a beautifully engineered implementation of a data flow analysis framework but there is little comparison with other similar frameworks and at this point little evidence that this is the "right" design with the right compromise between expressiveness and generality. The paper is also an improvement over Ramsey and Dias's work but the improvements are scattered here and there. Finally the paper, I feel, is hard to appreciate without some familiarity with the GHC backend. Some of the code has to be elided and some of the code presented uses the actual GHC datatypes (which is good in some sense but also adds some unneeded complexity to the examples). + +A couple of specific comments/questions: + +- can you explain in more detail the reasons for implementing the rewriting in two steps: first a speculative step and then a step that commits it. Is that because the intermediate results of the analysis are unsound and that soundness is only achieved when the analysis reaches a fixed point? + +- can you provide more detail on how the optimization fuel is used for debugging + + + + + + +[Text] Plain text +Review #28D +Modified Tuesday 15 Sep 2009 5:36:29am PDT + + +Overall merit (?) +B. OK paper, but I will not champion it. + +Reviewer expertise (?) +Y. I am knowledgeable in the area, though not an expert. +Paper summary +This paper describes Hoopl, a dataflow optimization tool. The paper +first analyzes general properties and principles underlying various +dataflow analysis for low-level code languages through examples, and +identifies major components of a general dataflow optimizer: (1) a +dataflow fact lattice, (2) a transfer function that computes a dataflow +fact of a program point from the preceding (depending of the direction +of the analysis) dataflow facts, (3) a rewrite function that replaces a +node in a control flow graph based on dataflow facts. Based on this +analysis, the paper introduces Hoopl as a generic dataflow optimizer +through type signatures of Hoopl functions, and describes their +functionality. Hoopl takes a dataflow fact lattice (i.e. types and +associated operations), a transfer function, a rewriter, and performs +the iterative process of analyzing the graph using the transfer +function and transforming the graph using the rewrite function until +it obtains the least fixed point. The paper then describes some +aspects of its implementation, including its two phase architecture +consisting of a speculative iterator and an actualizer, and describes +the implemented forward iterator and forward actualizer in some details. + +Comments for author +From the presentation, it seems that Hoopl is an easy to use and +generic tool that automates dataflow optimization for low-level code +languages. It is well engineered so that compiler writers can readily +use it for implementing various optimizations in their optimizing +compilers. The paper is also very well written. Hoopl's description +through examples can serve as a nice tutorial on unified view of +dataflow optimization. + +However, I am not completely sure that this paper makes significantly +new contribution to POPL 2010. Although being a well engineered tool, +Hoopl appears to be based on combinations of known results. +The overall structure of representation and implementation is based +on some of the authors earlier work on zipper-style control-flow graph +representation and optimization. There are some improvements on +representations and interfaces: graphs are classified into "open" and +"closed" ones, and interfaces of graph splicing functions are +improved. The overall structure of interleaved analysis and +transformation is due to other existing work. Hoopl also combines +debugging facility, which is based on excising work. The description +of its implementation is too sketched to be useful in implementing new +optimization engines. + + + + + + +[Text] Plain text +Review #28E +Modified Wednesday 16 Sep 2009 9:22:46am PDT + + +Overall merit (?) +C. Weak paper, though I will not fight strongly against it. + +Reviewer expertise (?) +X. I am an expert in the subject area of this paper. +Paper summary +This paper presents an analysis and transformation engine implemented +in Haskell. To use the engine, the programmer provides a description +of the lattice, transfer functions, and rewrite functions. The engine +then takes care of computing the dataflow fixed point and applying the +rewrites. The paper describes the interface to the engine, shows +examples of several client analyses and optimizations and describes an +implementation of the engine. + +Comments for author +The interesting part of this paper is that it shows how to effectively +combine several previously known techniques/ideas into a single +engine. These techniques/ideas are: the fixed-point formulation of +dataflow analyses; the rewrite-rule formulation of transformation +rules; the composition technique of Lerner Grove and Chambers; and the +fuel-based abstraction of Whalley for quickly narrowing down the +source of compiler bugs. + +However, it's hard to tease out what exactly the contribution +is. Datafow analysis engines based on lattices, transfer functions, +and rewrite functions are very common (Weimer and Necula's CIL has +one, Hendren et al's Soot has one, Lattner and Adve's LLVM has one, +IBM's WALA engine has one). It would be interesting to better +understand how the proposed framework distinguishes itself from these +existing frameworks. + +Presumably, one difference is that the proposed framework incorporates +additional techniques (eg: the composition framework and the +fuel-based abstraction). However, these two techniques were previously +published, and they also seem quite orthogonal to each other (which +means the integration of the two techniques would not pose too many +additional challenges -- if it does, the paper should focus on this). + +The paper does point out how Haskell helps with many of the +implementation tasks, and the use of Haskell is indeed a difference +from other frameworks. However, the paper doesn't really develop this +point, and it's also not clear how much of this type checking also +exists in other frameworks (eg: CIL uses OCaml so it may have some +nice static type-checking guarantees) The paper would be stronger if +it had a direct comparison (maybe a table?) of what kinds of +properties are statically checked using types in the proposed +framework, vs CIL, Soot, LLVM, and others frameworks too. + +The paper could also be improved by reporting on experience in using +the framework. For example: what was it used for? what are some +statistics about the framework (number of analyses implemented, how +many lines of code, bugs found using types, etc.) how does experience +with the proposed framework compare with other frameworks such as LLVM +(eg: for conciseness, ease of use, etc) + +Finally, the paper doesn't seem to address interprocedural analyses +and optimizations (although that's understandable to some extent -- +one has to nail down the intra-procedural case first, but it would be +nice to get an idea of how the authors see this framework panning out +in the interprocedural case) + + + + + + +Response +The authors' response is intended to address reviewer concerns and correct misunderstandings. The response should be addressed to the program committee, who will consider it when making their decision. Don't try to augment the paper's content or form\u2014the conference deadline has passed. Please keep the response short and to the point. + + + This response should be sent to the reviewers. + + +HotCRP Conference Management Software +Overall merit choices are: +A. Good paper. I will champion it at the PC meeting. +B. OK paper, but I will not champion it. +C. Weak paper, though I will not fight strongly against it. +D. Serious problems. I will argue to reject this paper. +Reviewer expertise choices are: +X. I am an expert in the subject area of this paper. +Y. I am knowledgeable in the area, though not an expert. +Z. I am an informed outsider of the area. diff -Nru ghc-7.0.3/libraries/hoopl/private/popl-response.txt ghc-7.2.1/libraries/hoopl/private/popl-response.txt --- ghc-7.0.3/libraries/hoopl/private/popl-response.txt 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/private/popl-response.txt 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,72 @@ +The referees' reports are clear, and we haven't identified any +significant misunderstandings. Several referees suggest that the +paper reads more like a pearl than a research contribution, and we are +happy to have it evaluated as such. Below we answer referees' +questions. (Having received such nice detailed reviews, we don't want +to leave referees' questions hanging unanswered, but it is probably +not necessary to read the answers below in order to make a decision +about the paper.) + +Referee A asks if we have experimental results which show that the +quality of generated code can compete with state-of-the-art compilers. +Yes, we have experimental results with the Glasgow Haskell Compiler +which show that the new back end produces code at least as good as the +old back end. But although GHC's front end contains some very +sophisticated optimizations, by the time the code gets to the level +shown in the paper, the back-end optimizations are limited, and so +GHC's bar is actually set low. + +Referee B, citing Knoop, Koschützki, and Steffen, points out that the +API might be simpler if we eliminated the static type distinction +between 'first', 'last', and 'middle' nodes. Ironically, we were very +inspired by the 'living dinosaur' paper and used it as the starting +point for our representation of control-flow graphs. But giving all +nodes the same type led to a great deal of run-time checking, and to +preserve our sanity we were forced to distinguish at compile time +between first, middle, and last nodes, which of course means that we +reinvented basic blocks. Perhaps one way to think about the design +issues here is that although the split into three static types makes +the API wider, client code is simpler because each of the three static +types of node obeys a stronger invariant (constraining the numbers of +predecessors or successors). In any case, we have experience with +both representations, and our experience is that the wider API leads +to a simpler compiler overall---although we don't know how to make +that case compellingly in a conference submission. + +Referee C asks why we rewrite in two steps. The referee has the +answer exactly: during the first step of the analysis, speculative +rewriting produces intermediate results which are not guaranteed to be +sound until a fixed point is reached. + +Referee C asks for more detail on how the optimization fuel is used +for debugging. Suppose we are regression-testing the compiler and a +test fails. We re-run the same test with no fuel. If the test then +succeeds, the optimizer is at fault. We ask the compiler how much +fuel was used on the original run, and we use that as the starting +point for a binary search on the fuel supply. This binary search +identifies a single graph-node rewrite which transforms a working test +case into a failed test case. At this point there's no more +automation; the compiler writer takes over and diagnoses whether the +transformation is unjustified or the underlying analysis is faulty. +To summarize, optimization fuel is used to find, in logarithmically +many runs of the compiler, the transformation, analysis, node, and +rewrite that cause a fault. We should add that although this process +is completely automated in the 'Quick C--' compiler written by the +first two authors, it is not yet automated in the Glasgow Haskell +Compiler. + +Referee E observes that CIL uses OCaml so it may have some nice static +type-checking guarantees. We wrote a predecessor of Hoopl in OCaml +and the static typing was not bad, but having the 'open' and 'closed' +graph properties checked statically is a significant upgrade---we +eliminated a number of dynamic checks, some of which had been sources +of bugs. It is possible that a creative encoding into OCaml would +make it possible to check the same properties statically using only +OCaml's Hindley-Milner system, but GHC's extension of generalized +algebraic data types makes it very easy to provide the extra static +checking. + +Referee E also suggests we should compare Hoopl with other engines for +dataflow analysis. We are all wearing our stupid hats and whacking +ourselves in the head for not thinking of this. If it should happen +that the paper is accepted, we'll do a proper job. diff -Nru ghc-7.0.3/libraries/hoopl/PROBLEMS ghc-7.2.1/libraries/hoopl/PROBLEMS --- ghc-7.0.3/libraries/hoopl/PROBLEMS 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/PROBLEMS 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,68 @@ +Problems with polymorphic transfer functions on the left of an arrow +using RankNTypes: + + - Can't easily write generic debugging code to show facts + propagating through a graph, because + . can't tell the shape of the node + . therefore can't tell the type of the facts + + - Can't write a generic dominator analysis that assumes only (Edges n) + + - Can't use default cases (or at least not easily) in the transfer + function + + - Harder to reuse common predicate transformers like + + - id + - distributeFacts :: Edges n => n -> f -> FactBase f + distributeFacts n f = mkFactBase [(l, f) | l <- successors n] + + + +---------------------------------- +Instructions given to NR's class: + + +All, + +If you consult the type definition of FwdTransfer, +you'll see that it requires a polymorphic function and uses a type +family which alters the types of arguments and results depending on +the shape of a node. If the type of a fact is 'f', then + + - The predicate transformer for a closed/open node has type f -> FactBase f + - The predicate transformer for an open/open node has type f -> f + - The predicate transformer for an open/closed node has type FactBase f -> f + +Simon was very enamored of this interface, but it's clear that it +imposes a heavy burden on clients: + + 1. For a typical first node such as + + LabelNode l + + You'll have to capture the fact using + + fromJust $ factLookup factbase l + + 2. For a last node you may want something like + + \f -> mkFactBase [(l, f) | l <- successors n] + + Some last nodes may require more elaborate code. + + 3. Because the function is both GADT and polymorphic, you can't + default any cases---every constructor has to be written + explicitly. When you are doing this, but you don't care about the + constructor's arguments, it can be useful to use the record + wildcard syntax: + + xfer (ArraySet {}) = id + + This syntax matches any fully saturated application of ArraySet, + no matter how many arguments ArraySet expects. + + + + +Norman diff -Nru ghc-7.0.3/libraries/hoopl/prototypes/Cunning3.hs ghc-7.2.1/libraries/hoopl/prototypes/Cunning3.hs --- ghc-7.0.3/libraries/hoopl/prototypes/Cunning3.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/prototypes/Cunning3.hs 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,347 @@ +{-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies #-} + +-- This version uses type families to express the functional dependency +-- between the open/closed-ness of the input graph and the type of the +-- input fact expected for a graph of that shape + +module CunningTransfers( pureAnalysis, analyseAndRewrite ) where + +import qualified Data.IntMap as M +import qualified Data.IntSet as S + +----------------------------------------------------------------------------- +-- Graphs +----------------------------------------------------------------------------- + +data ZOpen +data ZClosed + +type O = ZOpen +type C = ZClosed + +-- This data type is NOT MENTIONED in the rest of the code. +-- It's just an example to how how we can embed our existing +-- middle/last idea into the new story +data ZNode m l e x where + ZFirst :: BlockId -> ZNode m l C O + ZMid :: m -> ZNode m l O O + ZLast :: l -> ZNode m l O C + +data ZBlock node e x where + ZBOne :: node e x -> ZBlock node e x + ZCat :: ZBlock node e O -> ZBlock node O x -> ZBlock node e x + +type Block node = ZBlock node C C + +data ZGraph node e x where + ZGMany { zg_entry :: ZBlock node e C + , zg_blocks :: BlockEnv (Block node) + , zg_exit :: ZBlock node C x } :: ZGraph node e x + ZGOne { zg_mids :: ZBlock node O O } :: ZGraph node O O + ZGNil :: ZGraph node O O + +type Graph node = ZGraph node C C + +forwardBlockList :: BlockEnv (Block node) -> [(BlockId, Block node)] +-- This produces a list of blocks in order suitable for forward analysis. +-- ToDo: Do a topological sort to improve convergence rate of fixpoint +-- This will require a (HavingSuccessors l) class constraint +forwardBlockList env = M.toList env + +----------------------------------------------------------------------------- +-- DataflowLattice +----------------------------------------------------------------------------- + +data DataflowLattice a = DataflowLattice { + fact_name :: String, -- Documentation + fact_bot :: a, -- Lattice bottom element + fact_add_to :: a -> a -> TxRes a, -- Lattice join plus change flag + fact_do_logging :: Bool -- log changes +} + +----------------------------------------------------------------------------- +-- The main Hoopl API +----------------------------------------------------------------------------- + +data ForwardTransfers node f + = ForwardTransfers + { ft_trans :: forall e x. node e x -> InT e f -> OutT x f } + +data ForwardRewrites node f + = ForwardRewrites + { fr_rw :: forall e x. node e x -> InT e f -> Maybe (AGraph node e x) } + +type family InT e f :: * +type instance InT C f = FactBase f +type instance InT O f = f + +type family OutT x f :: * +type instance OutT C f = OutFacts f +type instance OutT O f = f + +newtype OutFacts fact = OutFacts [(BlockId, fact)] +newtype FactBase fact = FactBase (BlockEnv fact) + +data AGraph node e x = AGraph -- Stub for now + + +----------------------------------------------------------------------------- +-- TxFactBase: a FactBase with ChangeFlag information +----------------------------------------------------------------------------- + +-- A TxFactBase carries a ChangeFlag with it, and a set of BlockIds +-- to monitor. Updates to other BlockIds don't affect the ChangeFlag +data TxFactBase fact + = TxFB { tfb_fbase :: FactBase fact + , tfb_cha :: ChangeFlag + , tfb_bids :: BlockSet -- Update change flag iff these blocks change + } + +updateFact :: DataflowLattice f -> (BlockId, f) + -> TxFactBase f -> TxFactBase f +-- Update a TxFactBase, setting the change flag iff +-- a) the new fact adds information... +-- b) for a block in the BlockSet in the TxFactBase +updateFact lat (bid, new_fact) tx_fb@(TxFB { tfb_fbase = FactBase fbase, tfb_bids = bids}) + | NoChange <- cha2 = tx_fb + | bid `elemBlockSet` bids = tx_fb { tfb_fbase = new_fbase, tfb_cha = SomeChange } + | otherwise = tx_fb { tfb_fbase = new_fbase } + where + old_fact = lookupBEnv fbase bid `orElse` fact_bot lat + TxRes cha2 res_fact = fact_add_to lat old_fact new_fact + new_fbase = FactBase (extendBEnv fbase bid res_fact) + +updateFacts :: DataflowLattice f -> BlockId + -> Trans (FactBase f) (OutFacts f) + -> Trans (TxFactBase f) (TxFactBase f) +updateFacts lat bid thing_inside tx_fb@(TxFB { tfb_fbase = fbase, tfb_bids = bids }) + = do { OutFacts out_facts <- thing_inside fbase + ; let tx_fb' = tx_fb { tfb_bids = extendBlockSet bids bid } + ; return (foldr (updateFact lat) tx_fb out_facts) } + +----------------------------------------------------------------------------- +-- The Trans arrow +----------------------------------------------------------------------------- + +type Trans a b = a -> FuelMonad b + -- Transform a into b, with facts of type f + -- Deals with optimsation fuel and unique supply too + +(>>>) :: Trans a b -> Trans b c -> Trans a c +-- Compose two dataflow transfers in sequence +(dft1 >>> dft2) f1 = do { f2 <- dft1 f1; dft2 f2 } + +liftTrans :: (a->b) -> Trans a b +liftTrans f x = return (f x) + +idTrans :: Trans a a +idTrans x = return x + +fixpointTrans :: forall f. Trans (TxFactBase f) (TxFactBase f) + -> Trans (OutFacts f) (FactBase f) +fixpointTrans thing_inside (OutFacts out_facts) + = loop (FactBase (mkBlockEnv out_facts)) + where + loop :: Trans (FactBase f) (FactBase f) + loop fbase = do { tx_fb <- thing_inside (TxFB { tfb_fbase = fbase + , tfb_cha = NoChange + , tfb_bids = emptyBlockSet }) + ; case tfb_cha tx_fb of + NoChange -> return fbase + SomeChange -> loop (tfb_fbase tx_fb) } + +----------------------------------------------------------------------------- +-- Transfer functions +----------------------------------------------------------------------------- + +-- Keys to the castle: a generic transfer function for each shape +-- Here's the idea: we start with single-node transfer functions, +-- move to basic-block transfer functions (we have exactly four shapes), +-- then finally to graph transfer functions (which requires iteration). + +data GFT thing fact + = GFT { gft_trans :: forall e x. thing e x -> Trans (InT e fact) (OutT x fact) } + +type GFT_Node node = GFT node +type GFT_Block node = GFT (ZBlock node) +type GFT_Graph node = GFT (ZGraph node) +---------------------------------------------------------------------------------------------- + +gftNode :: forall node f . ForwardTransfers node f -> GFT_Node node f +-- Injection from the external interface into the internal representation +gftNode (ForwardTransfers { ft_trans = base_trans }) + = GFT { gft_trans = node_trans } + where + node_trans :: node e x -> Trans (InT e f) (OutT x f) + node_trans node f = return (base_trans node f) + +gftBlock :: forall node f. GFT_Node node f -> GFT_Block node f +-- Lift from nodes to blocks +gftBlock (GFT { gft_trans = node_trans }) + = GFT { gft_trans = block_trans } + where + block_trans :: ZBlock node e x -> Trans (InT e f) (OutT x f) + block_trans (ZBOne node) = node_trans node + block_trans (ZCat head mids) = block_trans head >>> block_trans mids + +gftGraph :: forall node f. DataflowLattice f -> GFT_Block node f -> GFT_Graph node f +-- Lift from blocks to graphs +gftGraph lattice (GFT { gft_trans = block_trans }) + = GFT { gft_trans = graph_trans } + where + -- These functions are orgasmically beautiful + graph_trans :: ZGraph node e x -> Trans (InT e f) (OutT x f) + graph_trans ZGNil = idTrans + graph_trans (ZGOne mids) = block_trans mids + graph_trans (ZGMany { zg_entry = entry, zg_blocks = blocks, zg_exit = exit }) + = block_trans entry >>> ft_blocks blocks >>> block_trans exit + + ft_blocks :: BlockEnv (Block node) -> Trans (OutFacts f) (FactBase f) + ft_blocks blocks = fixpointTrans (ft_blocks_once (forwardBlockList blocks)) + + ft_blocks_once :: [(BlockId, Block node)] -> Trans (TxFactBase f) (TxFactBase f) + ft_blocks_once blks = foldr ((>>>) . ft_block_once) idTrans blks + + ft_block_once :: (BlockId, Block node) + -> Trans (TxFactBase f) (TxFactBase f) + ft_block_once (blk_id, blk) = updateFacts lattice blk_id (block_trans blk) + + + +---------------------------------------------------------------- +-- The pièce de resistance: cunning transfer functions +---------------------------------------------------------------- + +pureAnalysis :: DataflowLattice f -> ForwardTransfers node f -> GFT_Graph node f +pureAnalysis lattice = gftGraph lattice . gftBlock . gftNode + +analyseAndRewrite + :: forall node f . + RewritingDepth + -> DataflowLattice f + -> ForwardTransfers node f + -> ForwardRewrites node f + -> GFT_Graph node f + +data RewritingDepth = RewriteShallow | RewriteDeep +-- When a transformation proposes to rewrite a node, +-- you can either ask the system to +-- * "shallow": accept the new graph, analyse it without further rewriting +-- * "deep": recursively analyse-and-rewrite the new graph + +analyseAndRewrite depth lattice transfers rewrites + = gft_graph_cunning + where + gft_graph_base, gft_graph_cunning, gft_graph_recurse :: GFT_Graph node f + + gft_graph_base = gftGraph lattice (gftBlock gft_node_base) + gft_graph_cunning = gftGraph lattice (gftBlock gft_node_cunning) + gft_graph_recurse = case depth of + RewriteShallow -> gft_graph_base + RewriteDeep -> gft_graph_cunning + + gft_node_base, gft_node_cunning :: GFT_Node node f + gft_node_base = gftNode transfers + gft_node_cunning = GFT { gft_trans = cunning_trans } + + cunning_trans :: node e x -> Trans (InT e f) (OutT x f) + cunning_trans node = tryRewrite (fr_rw rewrites node) + (gft_trans gft_graph_recurse) + (gft_trans gft_node_base node) + + +----------------------------------------------------------------------------- +-- Rewriting +----------------------------------------------------------------------------- + +{- +data GRT co oo oc cc fact + = GRT { grt_lat :: DataflowLattice fact + , grt_co :: co -> Trans (FactBase fact) (fact, Graph C O m l) + , grt_oo :: oo -> Trans fact (fact, Graph O O m l) + , grt_oc :: oc -> Trans fact (OutFacts fact) + , gRt_cc :: cc -> Trans (FactBase fact) (OutFacts fact) } +-} + +----------------------------------------------------------------------------- +-- BlockId, BlockEnv, BlockSet +----------------------------------------------------------------------------- + +type BlockId = Int + +mkBlockId :: Int -> BlockId +mkBlockId uniq = uniq + +type BlockEnv a = M.IntMap a + +mkBlockEnv :: [(BlockId, a)] -> BlockEnv a +mkBlockEnv prs = M.fromList prs + +lookupBEnv :: BlockEnv f -> BlockId -> Maybe f +lookupBEnv env blk_id = M.lookup blk_id env + +extendBEnv :: BlockEnv f -> BlockId -> f -> BlockEnv f +extendBEnv env blk_id f = M.insert blk_id f env + +type BlockSet = S.IntSet + +emptyBlockSet :: BlockSet +emptyBlockSet = S.empty + +extendBlockSet :: BlockSet -> BlockId -> BlockSet +extendBlockSet bids bid = S.insert bid bids + +elemBlockSet :: BlockId -> BlockSet -> Bool +elemBlockSet bid bids = S.member bid bids + +----------------------------------------------------------------------------- +-- TxRes and ChangeFlags +----------------------------------------------------------------------------- + +data ChangeFlag = NoChange | SomeChange +data TxRes a = TxRes ChangeFlag a + + +----------------------------------------------------------------------------- +-- The fuel monad +----------------------------------------------------------------------------- + +type Uniques = Int +type Fuel = Int + +newtype FuelMonad a = FM { unFM :: Fuel -> Uniques -> (a, Fuel, Uniques) } + +instance Monad FuelMonad where + return x = FM (\f u -> (x,f,u)) + m >>= k = FM (\f u -> case unFM m f u of (r,f',u') -> unFM (k r) f' u') + +fuelExhausted :: FuelMonad Bool +fuelExhausted = FM (\f u -> (f <= 0, f, u)) + +decrementFuel :: FuelMonad () +decrementFuel = FM (\f u -> ((), f-1, u)) + +----------- +tryRewrite :: (a -> (Maybe (AGraph node e x))) -- The rewriter + -> (ZGraph node e x -> Trans a r) -- Rewrite succeeds + -> Trans a r -- Rewrite fails + -> Trans a r +tryRewrite rewriter do_yes do_no a + = case (rewriter a) of + Nothing -> do_no a + Just g -> do { out <- fuelExhausted + ; if out then do_no a + else do { decrementFuel + ; g' <- graphOfAGraph g + ; do_yes g' a } } + +graphOfAGraph :: AGraph node e x -> FuelMonad (ZGraph node e x) +graphOfAGraph = error "urk" -- Stub + +----------------------------------------------------------------------------- +-- Utility functions +----------------------------------------------------------------------------- + +orElse :: Maybe a -> a -> a +orElse (Just x) _ = x +orElse Nothing y = y diff -Nru ghc-7.0.3/libraries/hoopl/prototypes/CunningTransfers.hs ghc-7.2.1/libraries/hoopl/prototypes/CunningTransfers.hs --- ghc-7.0.3/libraries/hoopl/prototypes/CunningTransfers.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/prototypes/CunningTransfers.hs 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,419 @@ +{-# LANGUAGE ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards #-} + +module CunningTransfers where + +import qualified Data.IntMap as M +import qualified Data.IntSet as S + +----------------------------------------------------------------------------- +-- BlockId, BlockEnv, BlockSet +----------------------------------------------------------------------------- + +type BlockId = Int + +mkBlockId :: Int -> BlockId +mkBlockId uniq = uniq + +type BlockEnv a = M.IntMap a + +mkBlockEnv :: [(BlockId, a)] -> BlockEnv a +mkBlockEnv prs = M.fromList prs + +lookupBEnv :: BlockEnv f -> BlockId -> Maybe f +lookupBEnv env blk_id = M.lookup blk_id env + +extendBEnv :: BlockEnv f -> BlockId -> f -> BlockEnv f +extendBEnv env blk_id f = M.insert blk_id f env + +type BlockSet = S.IntSet + +emptyBlockSet :: BlockSet +emptyBlockSet = S.empty + +extendBlockSet :: BlockSet -> BlockId -> BlockSet +extendBlockSet bids bid = S.insert bid bids + +elemBlockSet :: BlockId -> BlockSet -> Bool +elemBlockSet bid bids = S.member bid bids + +----------------------------------------------------------------------------- +-- Graphs +----------------------------------------------------------------------------- + +data ZOpen +data ZClosed + +type O = ZOpen +type C = ZClosed + +data ZBlock e x m l where + ZFirst :: BlockId -> ZBlock C O m l + ZMid :: m -> ZBlock O O m l + ZLast :: l -> ZBlock O C m l + ZCat :: ZBlock e O m l -> ZBlock O x m l -> ZBlock e x m l + +type ZHead = ZBlock C O +type ZMids = ZBlock O O +type ZTail = ZBlock O C +type Block = ZBlock C C + +data ZGraph e x m l where + ZGMany { zg_entry :: ZBlock e C m l + , zg_blocks :: BlockEnv (Block m l) + , zg_exit :: ZBlock C x m l } :: ZGraph e x m l + ZGOne { zg_mids :: ZMids m l } :: ZGraph O O m l + ZGNil :: ZGraph O O m l + +type Graph = ZGraph C C + +forwardBlockList :: BlockEnv (Block m l) -> [(BlockId, Block m l)] +-- This produces a list of blocks in order suitable for forward analysis. +-- ToDo: Do a topological sort to improve convergence rate of fixpoint +-- This will require a (HavingSuccessors l) class constraint +forwardBlockList env = M.toList env + +----------------------------------------------------------------------------- +-- DataflowLattice +----------------------------------------------------------------------------- + +data DataflowLattice a = DataflowLattice { + fact_name :: String, -- Documentation + fact_bot :: a, -- Lattice bottom element + fact_add_to :: a -> a -> TxRes a, -- Lattice join plus change flag + fact_do_logging :: Bool -- log changes +} + +----------------------------------------------------------------------------- +-- TxRes and ChangeFlags +----------------------------------------------------------------------------- + +data ChangeFlag = NoChange | SomeChange +data TxRes a = TxRes ChangeFlag a + + +----------------------------------------------------------------------------- +-- The main Hoopl API +----------------------------------------------------------------------------- + +data ForwardTransfers m l f + = ForwardTransfers + { ft_lattice :: DataflowLattice f + , ft_first :: BlockId -> f -> f + , ft_middle :: m -> f -> f + , ft_last :: l -> f -> OutFacts f + } + +data ForwardRewrites m l f + = ForwardRewrites + { fr_first :: BlockId -> f -> Maybe (AGraph C O m l) + , fr_middle :: m -> f -> Maybe (AGraph O O m l) + , fr_last :: l -> f -> Maybe (AGraph O C m l) + , fr_exit :: f -> Maybe (AGraph O O m l) + } + +data AGraph e x m l = AGraph -- Stub for now + +----------------------------------------------------------------------------- +-- The FactBase +----------------------------------------------------------------------------- + +type FactBase fact = BlockEnv fact + +getFact :: DataflowLattice fact -> FactBase fact -> BlockId -> fact +getFact lat fb id = lookupBEnv fb id `orElse` fact_bot lat + + +----------------------------------------------------------------------------- +-- TxFactBase: a FactBase with ChangeFlag information +----------------------------------------------------------------------------- + +-- A TxFactBase carries a ChangeFlag with it, and a set of BlockIds +-- to monitor. Updates to other BlockIds don't affect the ChangeFlag +data TxFactBase fact + = TxFB { tfb_fbase :: FactBase fact + , tfb_cha :: ChangeFlag + , tfb_bids :: BlockSet -- Update change flag iff these blocks change + } + +updateFact :: DataflowLattice f -> (BlockId, f) + -> TxFactBase f -> TxFactBase f +-- Update a TxFactBase, setting the change flag iff +-- a) the new fact adds information... +-- b) for a block in the BlockSet in the TxFactBase +updateFact lat (bid, new_fact) tx_fb@(TxFB { tfb_fbase = fbase, tfb_bids = bids}) + | NoChange <- cha2 = tx_fb + | bid `elemBlockSet` bids = tx_fb { tfb_fbase = new_fbase, tfb_cha = SomeChange } + | otherwise = tx_fb { tfb_fbase = new_fbase } + where + old_fact = lookupBEnv fbase bid `orElse` fact_bot lat + TxRes cha2 res_fact = fact_add_to lat old_fact new_fact + new_fbase = extendBEnv fbase bid res_fact + +updateFacts :: DataflowLattice f -> BlockId + -> Trans (FactBase f) (OutFacts f) + -> Trans (TxFactBase f) (TxFactBase f) +updateFacts lat bid thing_inside tx_fb@(TxFB { tfb_fbase = fbase, tfb_bids = bids }) + = do { OutFacts out_facts <- thing_inside fbase + ; let tx_fb' = tx_fb { tfb_bids = extendBlockSet bids bid } + ; return (foldr (updateFact lat) tx_fb out_facts) } + +----------------------------------------------------------------------------- +-- The Trans arrow +----------------------------------------------------------------------------- + +type Trans a b = a -> FuelMonad b + -- Transform a into b, with facts of type f + -- Deals with optimsation fuel and unique supply too + +(>>>) :: Trans a b -> Trans b c -> Trans a c +-- Compose two dataflow transfers in sequence +(dft1 >>> dft2) f1 = do { f2 <- dft1 f1; dft2 f2 } + +liftTrans :: (a->b) -> Trans a b +liftTrans f x = return (f x) + +idTrans :: Trans a a +idTrans x = return x + +fixpointTrans :: forall f. Trans (TxFactBase f) (TxFactBase f) + -> Trans (OutFacts f) (FactBase f) +fixpointTrans thing_inside (OutFacts out_facts) + = loop (mkBlockEnv out_facts) + where + loop :: Trans (FactBase f) (FactBase f) + loop fbase = do { tx_fb <- thing_inside (TxFB { tfb_fbase = fbase + , tfb_cha = NoChange + , tfb_bids = emptyBlockSet }) + ; case tfb_cha tx_fb of + NoChange -> return fbase + SomeChange -> loop (tfb_fbase tx_fb) } + +----------------------------------------------------------------------------- +-- Transfer functions +----------------------------------------------------------------------------- + +-- Keys to the castle: a generic transfer function for each shape +-- Here's the idea: we start with single-node transfer functions, +-- move to basic-block transfer functions (we have exactly four shapes), +-- then finally to graph transfer functions (which requires iteration). + +data GFT co oo oc cc fact + = GFT { gft_lat :: DataflowLattice fact + , gft_co :: co -> Trans (FactBase fact) fact + , gft_oo :: oo -> Trans fact fact + , gft_oc :: oc -> Trans fact (OutFacts fact) + , gft_cc :: cc -> Trans (FactBase fact) (OutFacts fact) } + +newtype OutFacts fact = OutFacts [(BlockId, fact)] + + +---------------------------------------------------------------------------------------------- +-- closed/open open/open open/closed closed/closed +---------------------------------------------------------------------------------------------- +type GFT_Node m l f = GFT BlockId m l Void f +type GFT_Block m l f = GFT (ZHead m l) (ZMids m l) (ZTail m l) (Block m l) f +type GFT_Graph m l f = GFT (ZGraph C O m l) (ZGraph O O m l) (ZGraph O C m l) (ZGraph C C m l) f +---------------------------------------------------------------------------------------------- + +data Void -- There is no closed/closed node + +gftNode :: forall m l f . ForwardTransfers m l f -> GFT_Node m l f +-- Injection from the external interface into the internal representation +gftNode (ForwardTransfers { ft_lattice = lattice + , ft_first = first_fn + , ft_middle = middle_fn + , ft_last = last_fn }) + = GFT { gft_lat = lattice + , gft_co = ft_first + , gft_oo = ft_middle + , gft_oc = ft_last + , gft_cc = error "f_cc for node is undefined" } + where + ft_first blk_id fb = return (first_fn blk_id (getFact lattice fb blk_id)) + ft_middle node fact = return (middle_fn node fact) + ft_last node fact = return (last_fn node fact) + +gftBlock :: forall m l f. GFT_Node m l f -> GFT_Block m l f +-- Lift from nodes to blocks +gftBlock (GFT { gft_lat = lat, gft_co = ft_first + , gft_oo = ft_middle, gft_oc = ft_last }) + = GFT { gft_lat = lat + , gft_co = ft_head + , gft_oo = ft_mids + , gft_oc = ft_tail + , gft_cc = ft_block } + where + ft_head :: ZBlock C O m l -> Trans (FactBase f) f + ft_head (ZFirst blk_id) = ft_first blk_id + ft_head (ZCat head mids) = ft_head head >>> ft_mids mids + + ft_mids :: ZBlock O O m l -> Trans f f + ft_mids (ZMid node) = ft_middle node + ft_mids (ZCat m1 m2) = ft_mids m1 >>> ft_mids m2 + + ft_tail :: ZBlock O C m l -> Trans f (OutFacts f) + ft_tail (ZLast node) = ft_last node + ft_tail (ZCat mids tail) = ft_mids mids >>> ft_tail tail + + ft_block :: ZBlock C C m l -> Trans (FactBase f) (OutFacts f) + ft_block (ZCat head tail) = ft_head head >>> ft_tail tail + +gftGraph :: forall m l f. GFT_Block m l f -> GFT_Graph m l f +-- Lift from blocks to graphs +gftGraph (GFT { gft_lat = lat + , gft_co = ft_head, gft_oo = ft_mids + , gft_oc = ft_tail, gft_cc = ft_block }) + = GFT { gft_lat = lat + , gft_co = ft_co + , gft_oo = ft_oo + , gft_oc = ft_oc + , gft_cc = ft_cc } + where + -- These functions are orgasmically beautiful + ft_co :: ZGraph C O m l -> Trans (FactBase f) f + ft_co (ZGMany { zg_entry = entry, zg_blocks = blocks, zg_exit = exit }) + = ft_block entry >>> ft_blocks blocks >>> ft_head exit + + ft_oo :: ZGraph O O m l -> Trans f f + ft_oo ZGNil = idTrans + ft_oo (ZGOne mids) = ft_mids mids + ft_oo (ZGMany { zg_entry = entry, zg_blocks = blocks, zg_exit = exit }) + = ft_tail entry >>> ft_blocks blocks >>> ft_head exit + + ft_oc :: ZGraph O C m l -> Trans f (OutFacts f) + ft_oc (ZGMany { zg_entry = entry, zg_blocks = blocks, zg_exit = exit }) + = ft_tail entry >>> ft_blocks blocks >>> ft_block exit + + ft_cc :: ZGraph C C m l -> Trans (FactBase f) (OutFacts f) + ft_cc (ZGMany { zg_entry = entry, zg_blocks = blocks, zg_exit = exit }) + = ft_block entry >>> ft_blocks blocks >>> ft_block exit + + ft_blocks :: BlockEnv (Block m l) -> Trans (OutFacts f) (FactBase f) + ft_blocks blocks = fixpointTrans (ft_blocks_once (forwardBlockList blocks)) + + ft_blocks_once :: [(BlockId, Block m l)] -> Trans (TxFactBase f) (TxFactBase f) + ft_blocks_once blks = foldr ((>>>) . ft_block_once) idTrans blks + + ft_block_once :: (BlockId, Block m l) + -> Trans (TxFactBase f) (TxFactBase f) + ft_block_once (blk_id, blk) = updateFacts lat blk_id (ft_block blk) + + +----------------------------------------------------------------------------- +-- Rewriting +----------------------------------------------------------------------------- + +{- +data GRT co oo oc cc fact + = GRT { grt_lat :: DataflowLattice fact + , grt_co :: co -> Trans (FactBase fact) (fact, Graph C O m l) + , grt_oo :: oo -> Trans fact (fact, Graph O O m l) + , grt_oc :: oc -> Trans fact (OutFacts fact) + , gRt_cc :: cc -> Trans (FactBase fact) (OutFacts fact) } +-} + +----------------------------------------------------------------------------- +-- The fuel monad +----------------------------------------------------------------------------- + +type Uniques = Int +type Fuel = Int + +newtype FuelMonad a = FM { unFM :: Fuel -> Uniques -> (a, Fuel, Uniques) } + +instance Monad FuelMonad where + return x = FM (\f u -> (x,f,u)) + m >>= k = FM (\f u -> case unFM m f u of (r,f',u') -> unFM (k r) f' u') + +fuelExhausted :: FuelMonad Bool +fuelExhausted = FM (\f u -> (f <= 0, f, u)) + +decrementFuel :: FuelMonad () +decrementFuel = FM (\f u -> ((), f-1, u)) + +graphOfAGraph :: AGraph e x m l -> FuelMonad (ZGraph e x m l) +graphOfAGraph = error "urk" -- Stub + +----------------------------------------------------------------------------- +-- Utility functions +----------------------------------------------------------------------------- + +orElse :: Maybe a -> a -> a +orElse (Just x) _ = x +orElse Nothing y = y + + + +---------------------------------------------------------------- +-- The pièce de resistance: cunning transfer functions +---------------------------------------------------------------- + +pureAnalysis :: ForwardTransfers m l f -> GFT_Graph m l f +pureAnalysis = gftGraph . gftBlock . gftNode + +analyseAndRewrite + :: forall m l f . + RewritingDepth + -> ForwardTransfers m l f + -> ForwardRewrites m l f + -> GFT_Graph m l f + +data RewritingDepth = RewriteShallow | RewriteDeep +-- When a transformation proposes to rewrite a node, +-- you can either ask the system to +-- * "shallow": accept the new graph, analyse it without further rewriting +-- * "deep": recursively analyse-and-rewrite the new graph + + +analyseAndRewrite depth transfers rewrites + = gft_graph_cunning + where + lat = ft_lattice transfers + + gft_graph_base, gft_graph_cunning, gft_graph_recurse :: GFT_Graph m l f + + gft_graph_base = gftGraph (gftBlock gft_node_base) + gft_graph_cunning = gftGraph (gftBlock gft_node_cunning) + gft_graph_recurse = case depth of + RewriteShallow -> gft_graph_base + RewriteDeep -> gft_graph_cunning + + gft_node_base, gft_node_cunning :: GFT_Node m l f + gft_node_base = gftNode transfers + gft_node_cunning = GFT { gft_lat = lat + , gft_co = cunning_first + , gft_oo = cunning_middle + , gft_oc = cunning_last + , gft_cc = error "f_cc for node is undefined" } + + cunning_first :: BlockId -> Trans (FactBase f) f + cunning_first bid = tryRewrite (rw_first bid) + (gft_co gft_graph_recurse) + (gft_co gft_node_base bid) + + rw_first :: BlockId -> FactBase f -> Maybe (AGraph C O m l) + rw_first bid fb = fr_first rewrites bid (getFact lat fb bid) + + cunning_middle :: m -> Trans f f + cunning_middle mid = tryRewrite (fr_middle rewrites mid) + (gft_oo gft_graph_recurse) + (gft_oo gft_node_base mid) + + cunning_last :: l -> Trans f (OutFacts f) + cunning_last last = tryRewrite (fr_last rewrites last) + (gft_oc gft_graph_recurse) + (gft_oc gft_node_base last) + +----------- +tryRewrite :: (a -> (Maybe (AGraph e x m l))) -- The rewriter + -> (ZGraph e x m l -> Trans a r) -- Rewrite succeeds + -> Trans a r -- Rewrite fails + -> Trans a r +tryRewrite rewriter do_yes do_no a + = case (rewriter a) of + Nothing -> do_no a + Just g -> do { out <- fuelExhausted + ; if out then do_no a + else do { decrementFuel + ; g' <- graphOfAGraph g + ; do_yes g' a } } diff -Nru ghc-7.0.3/libraries/hoopl/prototypes/.gitignore ghc-7.2.1/libraries/hoopl/prototypes/.gitignore --- ghc-7.0.3/libraries/hoopl/prototypes/.gitignore 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/prototypes/.gitignore 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,3 @@ +*.hi +*.hc +*.o diff -Nru ghc-7.0.3/libraries/hoopl/prototypes/Hoopl1.hs ghc-7.2.1/libraries/hoopl/prototypes/Hoopl1.hs --- ghc-7.0.3/libraries/hoopl/prototypes/Hoopl1.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/prototypes/Hoopl1.hs 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,470 @@ +{-# OPTIONS_GHC -Wall -fno-warn-incomplete-patterns #-} +-- With GHC 6.10 we get bogus incomplete-pattern warnings +-- It's fine in 6.12 +{-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, + PatternGuards, TypeFamilies #-} + +-- This version uses type families to express the functional dependency +-- between the open/closed-ness of the input graph and the type of the +-- input fact expected for a graph of that shape + +module Hoopl where + +import qualified Data.IntMap as M +import qualified Data.IntSet as S + +----------------------------------------------------------------------------- +-- Graphs +----------------------------------------------------------------------------- + +data ZOpen +data ZClosed + +type O = ZOpen +type C = ZClosed + +-- Blocks are always non-empty +data Block n e x where + BUnit :: n e x -> Block n e x + BCat :: Block n e O -> Block n O x -> Block n e x + +type Blocks n = [Block n C C] + +data Graph n e x where + GNil :: Graph n O O + GUnit :: Block n e x -> Graph n e x + GMany { g_entry :: Block n e C + , g_blocks :: Blocks n + , g_exit :: Exit (Block n C x) x } :: Graph n e x + + -- Invariant: if g_entry is closed, + -- its BlockId cannot be a target of + -- branches in the blocks + + -- If a graph has a Tail, then that tail is the only + -- exit from the graph, even if the Tail is closed + -- See the definition of successors! + +data Exit thing x where + NoTail :: Exit thing C + Tail :: thing -> Exit thing x + +class Edges thing where + blockId :: thing C x -> BlockId + successors :: thing e C -> [BlockId] + +instance Edges n => Edges (Block n) where + blockId (BUnit n) = blockId n + blockId (BCat b _) = blockId b + successors (BUnit n) = successors n + successors (BCat _ b) = successors b + +instance Edges n => Edges (Graph n) where + blockId (GUnit b) = blockId b + blockId (GMany b _ _) = blockId b + successors (GUnit b) = successors b + successors (GMany _ _ (Tail b)) = successors b + successors (GMany b bs NoTail) + = blockSetElems (all_succs `minusBlockSet` all_blk_ids) + where + all_succs = mkBlockSet (successors b ++ concatMap successors bs) + all_blk_ids = mkBlockSet (map blockId bs) + + +gCat :: Graph n e O -> Graph n O x -> Graph n e x +gCat GNil g2 = g2 +gCat g1 GNil = g1 + +gCat (GUnit b1) (GUnit b2) + = GUnit (b1 `BCat` b2) + +gCat (GUnit b) (GMany e bs x) + = GMany (b `BCat` e) bs x + +gCat (GMany e bs (Tail x)) (GUnit b2) + = GMany e bs (Tail (x `BCat` b2)) + +gCat (GMany e1 bs1 (Tail x1)) (GMany e2 bs2 x2) + = GMany e1 (x1 `BCat` e2 : bs1 ++ bs2) x2 + +gCatC :: Graph n e C -> Graph n C x -> Graph n e x +gCatC (GUnit b1) (GUnit b2) = GMany b1 [] (Tail b2) +gCatC (GUnit b1) (GMany e2 bs x2) = GMany b1 (e2:bs) x2 +gCatC (GMany e bs NoTail) (GUnit b2) = GMany e bs (Tail b2) +gCatC (GMany e bs (Tail b1)) (GUnit b2) = GMany e (b1:bs) (Tail b2) +gCatC (GMany e1 bs1 NoTail) (GMany e2 bs2 x2) = GMany e1 (e2 : bs1 ++ bs2) x2 +gCatC (GMany e1 bs1 (Tail x1)) (GMany e2 bs2 x2) = GMany e1 (x1 : e2 : bs1 ++ bs2) x2 + +type GraphWithFacts n f e x = (Graph n e x, FactBase f) +type BlocksWithFacts n f = (Blocks n, FactBase f) + +gwfCat :: GraphWithFacts n f e O -> GraphWithFacts n f O x -> GraphWithFacts n f e x +gwfCat (g1,fb1) (g2,fb2) = (g1 `gCat` g2, fb1 `unionFactBase` fb2) + +mkGMany :: GraphWithFacts n e C f + -> BlocksWithFacts n + -> Exit (GraphWithFacts n f C x) x + -> GraphWithFacts n e x +mkGMany (e,fb1) (bs,fb2) x = GMany b_e (bs_e ++ bs ++ bs_x) b_x + where + (b_e, bs_e) = mkHead e + (bs_x, b_x) = mkTail x + +mkHead :: Graph n e C -> (Block n e C, Blocks n) +mkHead (GUnit b) = (b, []) +mkHead (GMany e bs NoTail) = (e, bs) +mkHead (GMany e bs (Tail b)) = (e, b:bs) + +mkTail :: Exit (GraphWithFacts n C x) x + -> (BlocksWithFacts n, Exit (Block n C x) x) +mkTail NoTail = ([], NoTail) +mkTail (Tail (GUnit b, fb)) = ([], Tail b) +mkTail (Tail (GMany e bs x)) = (e:bs, x) + +flattenG :: Graph n C C -> Blocks n +flattenG (GUnit b) = [b] +flattenG (GMany e bs NoTail) = e:bs +flattenG (GMany e bs (Tail x)) = e:x:bs + +forwardBlockList :: Blocks n -> Blocks n +-- This produces a list of blocks in order suitable for forward analysis. +-- ToDo: Do a topological sort to improve convergence rate of fixpoint +-- This will require a (HavingSuccessors l) class constraint +forwardBlockList blks = blks + +----------------------------------------------------------------------------- +-- DataflowLattice +----------------------------------------------------------------------------- + +data DataflowLattice a = DataflowLattice { + fact_name :: String, -- Documentation + fact_bot :: a, -- Lattice bottom element + fact_add_to :: a -> a -> TxRes a, -- Lattice join plus change flag + fact_do_logging :: Bool -- log changes +} + +data ChangeFlag = NoChange | SomeChange +data TxRes a = TxRes ChangeFlag a + +----------------------------------------------------------------------------- +-- The main Hoopl API +----------------------------------------------------------------------------- + +type ForwardTransfers n f + = forall e x. n e x -> InFact e f -> OutFact x f + +type ForwardRewrites n f + = forall e x. n e x -> InFact e f -> Maybe (AGraph n e x) + +type family InFact e f :: * +type instance InFact C f = InFactC f +type instance InFact O f = f + +type family OutFact x f :: * +type instance OutFact C f = OutFactC f +type instance OutFact O f = f + +type InFactC fact = BlockId -> fact +type OutFactC fact = [(BlockId, fact)] + +data AGraph n e x = AGraph -- Stub for now + + +----------------------------------------------------------------------------- +-- TxFactBase: a FactBase with ChangeFlag information +----------------------------------------------------------------------------- + +-- The TxFactBase is an accumulating parameter, threaded through all +-- the analysis/transformation of each block in the g_blocks of a grpah. +-- It carries a ChangeFlag with it, and a set of BlockIds +-- to monitor. Updates to other BlockIds don't affect the ChangeFlag +data TxFactBase n f + = TxFB { tfb_fbase :: FactBase f + + , tfb_cha :: ChangeFlag + , tfb_bids :: BlockSet -- Update change flag iff these blocks change + -- These are BlockIds of the *original* + -- (not transformed) blocks + + , tfb_blks :: BlocksWithFacts n f -- Transformed blocks + } + +factBaseInFacts :: DataflowLattice f -> TxFactBase n f -> InFactC f +factBaseInFacts lattice (TxFB { tfb_fbase = fbase }) + = lookupFact lattice fbase + +factBaseOutFacts :: TxFactBase n f -> OutFactC f +factBaseOutFacts (TxFB { tfb_fbase = fbase, tfb_bids = bids }) + = [ (bid, f) | (bid, f) <- factBaseList fbase + , not (bid `elemBlockSet` bids) ] + -- The successors of the Graph are the the BlockIds for which + -- we hvae facts, that are *not* in the blocks of the graph + +updateFact :: DataflowLattice f -> (BlockId, f) + -> TxFactBase n f -> TxFactBase n f +-- Update a TxFactBase, setting the change flag iff +-- a) the new fact adds information... +-- b) for a block in the BlockSet in the TxFactBase +updateFact lat (bid, new_fact) tx_fb@(TxFB { tfb_fbase = fbase, tfb_bids = bids}) + | NoChange <- cha2 = tx_fb + | bid `elemBlockSet` bids = tx_fb { tfb_fbase = new_fbase, tfb_cha = SomeChange } + | otherwise = tx_fb { tfb_fbase = new_fbase } + where + old_fact = lookupFact lat fbase bid + TxRes cha2 res_fact = fact_add_to lat old_fact new_fact + new_fbase = extendFactBase fbase bid res_fact + +updateFacts :: Edges n + => DataflowLattice f + -> GFT_Block n f + -> Block n C C + -> Trans (TxFactBase n f) (TxFactBase n f) +updateFacts lat (GFT block_trans) blk + tx_fb@(TxFB { tfb_fbase = fbase, tfb_bids = bids, tfb_blks = blks }) + = do { (graph, out_facts) <- block_trans blk (lookupFact lat fbase) + ; let tx_fb' = tx_fb { tfb_bids = extendBlockSet bids (blockId blk) + , tfb_blks = flattenG graph ++ blks } + ; return (foldr (updateFact lat) tx_fb' out_facts) } + +----------------------------------------------------------------------------- +-- The Trans arrow +----------------------------------------------------------------------------- + +type Trans a b = a -> FuelMonad b + -- Transform a into b, with facts of type f + -- Deals with optimsation fuel and unique supply too + +(>>>) :: Trans a b -> Trans b c -> Trans a c +-- Compose two dataflow transfers in sequence +(dft1 >>> dft2) f = do { f1 <- dft1 f; f2 <- dft2 f1; return f2 } + +liftTrans :: (a->b) -> Trans a b +liftTrans f x = return (f x) + +idTrans :: Trans a a +idTrans x = return x + +fixpointTrans :: forall n f. + Trans (TxFactBase n f) (TxFactBase n f) + -> Trans (OutFactC f) (TxFactBase n f) +fixpointTrans tx_fb_trans out_facts + = do { fuel <- getFuel + ; loop fuel (mkFactBase out_facts) } + where + loop :: Fuel -> Trans (FactBase f) (TxFactBase n f) + loop fuel fbase + = do { tx_fb <- tx_fb_trans (TxFB { tfb_fbase = fbase + , tfb_cha = NoChange + , tfb_blks = [] + , tfb_bids = emptyBlockSet }) + ; case tfb_cha tx_fb of + NoChange -> return tx_fb + SomeChange -> do { setFuel fuel; loop fuel (tfb_fbase tx_fb) } } + +----------------------------------------------------------------------------- +-- Transfer functions +----------------------------------------------------------------------------- + +-- Keys to the castle: a generic transfer function for each shape +-- Here's the idea: we start with single-n transfer functions, +-- move to basic-block transfer functions (we have exactly four shapes), +-- then finally to graph transfer functions (which requires iteration). + +newtype GFT thing n f = GFT (GFTR thing n f) +type GFTR thing n f = forall e x. thing e x + -> InFact e f + -> FuelMonad (GraphWithFacts n e x f, OutFact x f) + +type GFT_Node n f = GFT n n f +type GFT_Block n f = GFT (Block n) n f +type GFT_Graph n f = GFT (Graph n) n f +----------------------------------------------------------------------------- + +gftNodeTransfer :: forall n f . ForwardTransfers n f -> GFT_Node n f +-- Lifts ForwardTransfers to GFT_Node; simple transfer only +gftNodeTransfer base_trans = GFT node_trans + where + node_trans :: GFTR n n f + node_trans node f = return (GUnit (BUnit node), base_trans node f) + +gftNodeRewrite :: forall n f. + ForwardTransfers n f + -> ForwardRewrites n f + -> GFT_Graph n f + -> GFT_Node n f +-- Lifts (ForwardTransfers,ForwardRewrites) to GFT_Node; +-- this time we do rewriting as well. +-- The GFT_Graph parameters specifies what to do with the rewritten graph +gftNodeRewrite transfers rewrites (GFT graph_trans) + = GFT node_rewrite + where + node_trans :: GFTR n n f + node_trans node f = return (GUnit (BUnit node), transfers node f) + + node_rewrite :: GFTR n n f + node_rewrite node f + = case rewrites node f of + Nothing -> node_trans node f + Just g -> do { out <- fuelExhausted + ; if out then + node_trans node f + else do { decrementFuel + ; g' <- graphOfAGraph g + ; graph_trans g' f } } + +gftBlock :: forall n f. GFT_Node n f -> GFT_Block n f +-- Lift from nodes to blocks +gftBlock (GFT node_trans) = GFT block_trans + where + block_trans :: GFTR (Block n) n f + block_trans (BUnit node) f = node_trans node f + block_trans (BCat hd mids) f = do { (g1,f1) <- block_trans hd f + ; (g2,f2) <- block_trans mids f1 + ; return (g1 `gwfCat` g2, f2) } + + +gftGraph :: forall n f. Edges n => DataflowLattice f -> GFT_Block n f -> GFT_Graph n f +-- Lift from blocks to graphs +gftGraph lattice gft_block@(GFT block_trans) = GFT graph_trans + where + graph_trans :: GFTR (Graph n) n f + graph_trans GNil f = return (GNil, f) + graph_trans (GUnit blk) f = block_trans blk f + graph_trans (GMany entry blocks exit) f + = do { (entry', f1) <- block_trans entry f + ; tx_fb <- ft_blocks blocks f1 + ; (exit', f3) <- ft_exit exit tx_fb + ; return (mkGMany entry' (tfb_blks tx_fb) exit', f3) } + + -- It's a bit disgusting that the TxFactBase has to be + -- preserved as far as the Exit block, becaues the TxFactBase + -- is really concerned with the fixpoint calculation + -- But I can't see any other tidy way to compute the + -- LastOutFacts in the NoTail case + ft_exit :: Exit (Block n C x) x + -> Trans (TxFactBase n f) (Exit (Graph n C x) x, OutFact x f) + ft_exit (Tail blk) f = do { (blk', f1) <- block_trans blk (factBaseInFacts lattice f) + ; return (Tail blk', f1) } + ft_exit NoTail f = return (NoTail, factBaseOutFacts f) + + ft_block_once :: Block n C C -> Trans (TxFactBase n f) (TxFactBase n f) + ft_block_once blk = updateFacts lattice gft_block blk + + ft_blocks_once :: Blocks n -> Trans (TxFactBase n f) (TxFactBase n f) + ft_blocks_once blks = foldr ((>>>) . ft_block_once) idTrans blks + + ft_blocks :: [Block n C C] -> Trans (OutFactC f) (TxFactBase n f) + ft_blocks blocks = fixpointTrans (ft_blocks_once (forwardBlockList blocks)) + +---------------------------------------------------------------- +-- The pièce de resistance: cunning transfer functions +---------------------------------------------------------------- + +pureAnalysis :: Edges n => DataflowLattice f -> ForwardTransfers n f -> GFT_Graph n f +pureAnalysis lattice = gftGraph lattice . gftBlock . gftNodeTransfer + +analyseAndRewrite + :: forall n f. Edges n + => RewritingDepth + -> DataflowLattice f + -> ForwardTransfers n f + -> ForwardRewrites n f + -> GFT_Graph n f + +data RewritingDepth = RewriteShallow | RewriteDeep +-- When a transformation proposes to rewrite a node, +-- you can either ask the system to +-- * "shallow": accept the new graph, analyse it without further rewriting +-- * "deep": recursively analyse-and-rewrite the new graph + +analyseAndRewrite depth lattice transfers rewrites + = gft_graph_cunning + where + gft_graph_base, gft_graph_cunning, gft_graph_recurse :: GFT_Graph n f + + gft_graph_base = gftGraph lattice (gftBlock gft_node_base) + gft_graph_cunning = gftGraph lattice (gftBlock gft_node_cunning) + gft_graph_recurse = case depth of + RewriteShallow -> gft_graph_base + RewriteDeep -> gft_graph_cunning + + gft_node_base, gft_node_cunning :: GFT_Node n f + gft_node_base = gftNodeTransfer transfers + gft_node_cunning = gftNodeRewrite transfers rewrites gft_graph_recurse + +----------------------------------------------------------------------------- +-- The fuel monad +----------------------------------------------------------------------------- + +type Uniques = Int +type Fuel = Int + +newtype FuelMonad a = FM { unFM :: Fuel -> Uniques -> (a, Fuel, Uniques) } + +instance Monad FuelMonad where + return x = FM (\f u -> (x,f,u)) + m >>= k = FM (\f u -> case unFM m f u of (r,f',u') -> unFM (k r) f' u') + +fuelExhausted :: FuelMonad Bool +fuelExhausted = FM (\f u -> (f <= 0, f, u)) + +decrementFuel :: FuelMonad () +decrementFuel = FM (\f u -> ((), f-1, u)) + +getFuel :: FuelMonad Fuel +getFuel = FM (\f u -> (f,f,u)) + +setFuel :: Fuel -> FuelMonad () +setFuel f = FM (\_ u -> ((), f, u)) + +graphOfAGraph :: AGraph node e x -> FuelMonad (Graph node e x) +graphOfAGraph = error "urk" -- Stub + +----------------------------------------------------------------------------- +-- BlockId, BlockEnv, BlockSet +----------------------------------------------------------------------------- + +type BlockId = Int + +mkBlockId :: Int -> BlockId +mkBlockId uniq = uniq + +type FactBase a = M.IntMap a + +mkFactBase :: [(BlockId, f)] -> FactBase f +mkFactBase prs = M.fromList prs + +lookupFact :: DataflowLattice f -> FactBase f -> BlockId -> f +lookupFact lattice env blk_id + = case M.lookup blk_id env of + Just f -> f + Nothing -> fact_bot lattice + +extendFactBase :: FactBase f -> BlockId -> f -> FactBase f +extendFactBase env blk_id f = M.insert blk_id f env + +unionFactBase :: FactBase f -> FactBase f -> FactBase f +unionFactBase = M.union + +factBaseList :: FactBase f -> [(BlockId, f)] +factBaseList env = M.toList env + +type BlockSet = S.IntSet + +emptyBlockSet :: BlockSet +emptyBlockSet = S.empty + +extendBlockSet :: BlockSet -> BlockId -> BlockSet +extendBlockSet bids bid = S.insert bid bids + +elemBlockSet :: BlockId -> BlockSet -> Bool +elemBlockSet bid bids = S.member bid bids + +blockSetElems :: BlockSet -> [BlockId] +blockSetElems = S.toList + +minusBlockSet :: BlockSet -> BlockSet -> BlockSet +minusBlockSet = S.difference + +mkBlockSet :: [BlockId] -> BlockSet +mkBlockSet = S.fromList diff -Nru ghc-7.0.3/libraries/hoopl/prototypes/Hoopl4.hs ghc-7.2.1/libraries/hoopl/prototypes/Hoopl4.hs --- ghc-7.0.3/libraries/hoopl/prototypes/Hoopl4.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/prototypes/Hoopl4.hs 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,528 @@ +{-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies #-} + +module Hoopl4 where + +import qualified Data.IntMap as M +import qualified Data.IntSet as S + +----------------------------------------------------------------------------- +-- Graphs +----------------------------------------------------------------------------- + +data ZOpen +data ZClosed + +type O = ZOpen +type C = ZClosed + +-- Blocks are always non-empty +data Block n e x where + BUnit :: n e x -> Block n e x + BCat :: Block n e O -> Block n O x -> Block n e x + +type BlockGraph n = BlockMap (Block n C C) + +data Graph n e x where + GNil :: Graph n O O + GUnit :: Block n e O -> Graph n e O + GMany :: Block n e C -> BlockGraph n + -> Tail n x -> Graph n e x + + -- If a graph has a Tail, then that tail is the only + -- exit from the graph, even if the Tail is closed + -- See the definition of successors! + +data Tail n x where + NoTail :: Tail n C + Tail :: BlockId -> Block n C O -> Tail n O + +class LiftNode x where + liftNode :: n e x -> Graph n e x +instance LiftNode ZClosed where + liftNode n = GMany (BUnit n) noBlocks NoTail +instance LiftNode ZOpen where + liftNode n = GUnit (BUnit n) + +{- Edges is not currently used +class Edges thing where + successors :: thing e C -> [BlockId] + +instance Edges n => Edges (Block n) where + successors (BUnit n) = successors n + successors (BCat _ b) = successors b + +instance Edges n => Edges (Graph n) where + successors (GMany b bs NoTail) + = blockSetElems (all_succs `minusBlockSet` all_blk_ids) + where + (bids, blks) = unzip (blocksToList bs) + all_succs = mkBlockSet (successors b ++ [bid | b <- blks, bid <- successors b]) + all_blk_ids = mkBlockSet bids +-} + +ecGraph :: Graph n e C -> (Block n e C, BlockGraph n) +ecGraph (GMany b bs NoTail) = (b, bs) + +cxGraph :: BlockId -> Graph n C O -> (BlockGraph n, Tail n O) +cxGraph bid (GUnit b) = (noBlocks, Tail bid b) +cxGraph bid (GMany be bs tail) = (addBlock bid be bs, tail) + +flattenG :: BlockId -> Graph n C C -> BlockGraph n +flattenG bid (GMany e bs NoTail) = addBlock bid e bs + +gCat :: Graph n e O -> Graph n O x -> Graph n e x +gCat GNil g2 = g2 +gCat g1 GNil = g1 + +gCat (GUnit b1) (GUnit b2) + = GUnit (b1 `BCat` b2) + +gCat (GUnit b) (GMany e bs x) + = GMany (b `BCat` e) bs x + +gCat (GMany e bs (Tail bid x)) (GUnit b2) + = GMany e bs (Tail bid (x `BCat` b2)) + +gCat (GMany e1 bs1 (Tail bid x1)) (GMany e2 bs2 x2) + = GMany e1 (addBlock bid (x1 `BCat` e2) bs1 `unionBlocks` bs2) x2 + +forwardBlockList, backwardBlockList :: BlockGraph n -> [(BlockId,Block n C C)] +-- This produces a list of blocks in order suitable for forward analysis. +-- ToDo: Do a topological sort to improve convergence rate of fixpoint +-- This will require a (HavingSuccessors l) class constraint +forwardBlockList blks = blocksToList blks +backwardBlockList blks = blocksToList blks + +----------------------------------------------------------------------------- +-- DataflowLattice +----------------------------------------------------------------------------- + +data DataflowLattice a = DataflowLattice { + fact_name :: String, -- Documentation + fact_bot :: a, -- Lattice bottom element + fact_extend :: a -> a -> (ChangeFlag,a), -- Lattice join plus change flag + fact_do_logging :: Bool -- log changes +} + +data ChangeFlag = NoChange | SomeChange + +----------------------------------------------------------------------------- +-- The main Hoopl API +----------------------------------------------------------------------------- + +type ForwardTransfers n f + = forall e x. f -> n e x -> TailFactF x f + +type ForwardRewrites n f + = forall e x. f -> n e x -> Maybe (AGraph n e x) + +type family TailFactF x f :: * +type instance TailFactF C f = [(BlockId, f)] +type instance TailFactF O f = f + +data AGraph n e x = AGraph -- Stub for now + + +----------------------------------------------------------------------------- +-- TxFactBase: a FactBase with ChangeFlag information +----------------------------------------------------------------------------- + +-- The TxFactBase is an accumulating parameter, threaded through all +-- the analysis/transformation of each block in the g_blocks of a grpah. +-- It carries a ChangeFlag with it, and a set of BlockIds +-- to monitor. Updates to other BlockIds don't affect the ChangeFlag +data TxFactBase n fact + = TxFB { tfb_fbase :: FactBase fact + + , tfb_cha :: ChangeFlag + , tfb_bids :: BlockSet -- Update change flag iff these blocks change + -- These are BlockIds of the *original* + -- (not transformed) blocks + + , tfb_blks :: BlockGraph n -- Transformed blocks + } + +factBaseInFacts :: DataflowLattice f -> TxFactBase n f -> BlockId -> f +factBaseInFacts lattice (TxFB { tfb_fbase = fbase }) bid + = lookupFact lattice fbase bid + +factBaseOutFacts :: TxFactBase n f -> [(BlockId,f)] +factBaseOutFacts (TxFB { tfb_fbase = fbase, tfb_bids = bids }) + = [ (bid, f) | (bid, f) <- factBaseList fbase + , not (bid `elemBlockSet` bids) ] + -- The successors of the Graph are the the BlockIds for which + -- we hvae facts, that are *not* in the blocks of the graph + +updateFact :: DataflowLattice f -> (BlockId, f) + -> TxFactBase n f -> TxFactBase n f +-- Update a TxFactBase, setting the change flag iff +-- a) the new fact adds information... +-- b) for a block in the BlockSet in the TxFactBase +updateFact lat (bid, new_fact) tx_fb@(TxFB { tfb_fbase = fbase, tfb_bids = bids}) + | NoChange <- cha2 = tx_fb + | bid `elemBlockSet` bids = tx_fb { tfb_fbase = new_fbase, tfb_cha = SomeChange } + | otherwise = tx_fb { tfb_fbase = new_fbase } + where + old_fact = lookupFact lat fbase bid + (cha2, res_fact) = fact_extend lat old_fact new_fact + new_fbase = extendFactBase fbase bid res_fact + +updateFacts :: DataflowLattice f + -> BlockId + -> (FactBase f -> FuelMonad ([(BlockId,f)], Graph n C C)) + -> TxFactBase n f -> FuelMonad (TxFactBase n f) +-- Works regardless of direction +updateFacts lat bid fb_trans + tx_fb@(TxFB { tfb_fbase = fbase, tfb_bids = bids, tfb_blks = blks }) + = do { (out_facts, graph) <- fb_trans fbase + ; let tx_fb' = tx_fb { tfb_bids = extendBlockSet bids bid + , tfb_blks = flattenG bid graph `unionBlocks` blks } + ; return (foldr (updateFact lat) tx_fb' out_facts) } + +----------------------------------------------------------------------------- +-- The Trans arrow +----------------------------------------------------------------------------- + +fixpoint :: forall n f. + (TxFactBase n f -> FuelMonad (TxFactBase n f)) + -> (FactBase f -> FuelMonad (TxFactBase n f)) +fixpoint tx_fb_trans init_fbase + = do { fuel <- getFuel + ; loop fuel init_fbase } + where + loop :: Fuel -> FactBase f -> FuelMonad (TxFactBase n f) + loop fuel fbase + = do { tx_fb <- tx_fb_trans (TxFB { tfb_fbase = fbase + , tfb_cha = NoChange + , tfb_blks = noBlocks + , tfb_bids = emptyBlockSet }) + ; case tfb_cha tx_fb of + NoChange -> return tx_fb + SomeChange -> do { setFuel fuel; loop fuel (tfb_fbase tx_fb) } } + +----------------------------------------------------------------------------- +-- Transfer functions +----------------------------------------------------------------------------- + +-- Keys to the castle: a generic transfer function for each shape +-- Here's the idea: we start with single-n transfer functions, +-- move to basic-block transfer functions (we have exactly four shapes), +-- then finally to graph transfer functions (which requires iteration). + +type ARF thing n f = forall e x. LiftNode x + => f -> thing e x + -> FuelMonad (TailFactF x f, Graph n e x) + +type ARF_Node n f = ARF n n f +type ARF_Block n f = ARF (Block n) n f +type ARF_Graph n f = ARF (Graph n) n f +----------------------------------------------------------------------------- + +arfNodeTransfer :: forall n f. ForwardTransfers n f -> ARF_Node n f +-- Lifts ForwardTransfers to ARF_Node; simple transfer only +arfNodeTransfer transfer_fn f node + = return (transfer_fn f node, liftNode node) + +arfNodeRewrite :: forall n f. + ForwardTransfers n f + -> ForwardRewrites n f + -> ARF_Graph n f + -> ARF_Node n f +-- Lifts (ForwardTransfers,ForwardRewrites) to ARF_Node; +-- this time we do rewriting as well. +-- The ARF_Graph parameters specifies what to do with the rewritten graph +arfNodeRewrite transfer_fn rewrite_fn graph_trans f node + = do { mb_g <- withFuel (rewrite_fn f node) + ; case mb_g of + Nothing -> arfNodeTransfer transfer_fn f node + Just ag -> do { g <- graphOfAGraph ag + ; graph_trans f g } } + +arfBlock :: forall n f. ARF_Node n f -> ARF_Block n f +-- Lift from nodes to blocks +arfBlock arf_node f (BUnit node) = arf_node f node +arfBlock arf_node f (BCat hd mids) = do { (f1,g1) <- arfBlock arf_node f hd + ; (f2,g2) <- arfBlock arf_node f1 mids + ; return (f2, g1 `gCat` g2) } + +arfGraph :: forall n f. DataflowLattice f -> ARF_Block n f -> ARF_Graph n f +-- Lift from blocks to graphs +arfGraph lattice arf_block f GNil = return (f, GNil) +arfGraph lattice arf_block f (GUnit blk) = arf_block f blk +arfGraph lattice arf_block f (GMany entry blocks exit) + = do { (f1, entry_g) <- arf_block f entry + ; tx_fb <- ft_blocks blocks (mkFactBase f1) + ; (f3, bs2, exit') <- ft_exit tx_fb exit + ; let (entry', bs1) = ecGraph entry_g + final_bs = bs1 `unionBlocks` tfb_blks tx_fb `unionBlocks` bs2 + ; return (f3, GMany entry' final_bs exit') } + where + -- It's a bit disgusting that the TxFactBase has to be + -- preserved as far as the Tail block, becaues the TxFactBase + -- is really concerned with the fixpoint calculation + -- But I can't see any other tidy way to compute the + -- LastOutFacts in the NoTail case + ft_exit :: TxFactBase n f -> Tail n x + -> FuelMonad (TailFactF x f, BlockGraph n, Tail n x) + ft_exit f (Tail bid blk) + = do { (f1, g) <- arf_block (factBaseInFacts lattice f bid) blk + ; let (bs, exit) = cxGraph bid g + ; return (f1, bs, exit) } + ft_exit f NoTail + = return (factBaseOutFacts f, noBlocks, NoTail) + + ft_block_once :: (BlockId, Block n C C) -> TxFactBase n f + -> FuelMonad (TxFactBase n f) + ft_block_once (bid, b) = updateFacts lattice bid $ \fbase -> + arf_block (lookupFact lattice fbase bid) b + + ft_blocks_once :: [(BlockId, Block n C C)] + -> TxFactBase n f -> FuelMonad (TxFactBase n f) + ft_blocks_once [] tx_fb = return tx_fb + ft_blocks_once (b:bs) tx_fb = do { tx_fb1 <- ft_block_once b tx_fb + ; ft_blocks_once bs tx_fb1 } + + ft_blocks :: BlockGraph n -> FactBase f -> FuelMonad (TxFactBase n f) + ft_blocks blocks = fixpoint (ft_blocks_once (forwardBlockList blocks)) + +---------------------------------------------------------------- +-- The pièce de resistance: cunning transfer functions +---------------------------------------------------------------- + +pureAnalysis :: DataflowLattice f -> ForwardTransfers n f -> ARF_Graph n f +pureAnalysis lattice f = arfGraph lattice (arfBlock (arfNodeTransfer f)) + +analyseAndRewriteFwd + :: forall n f. + DataflowLattice f + -> ForwardTransfers n f + -> ForwardRewrites n f + -> RewritingDepth + -> ARF_Graph n f + +data RewritingDepth = RewriteShallow | RewriteDeep +-- When a transformation proposes to rewrite a node, +-- you can either ask the system to +-- * "shallow": accept the new graph, analyse it without further rewriting +-- * "deep": recursively analyse-and-rewrite the new graph + +analyseAndRewriteFwd lattice transfers rewrites depth + = anal_rewrite + where + anal_rewrite, anal_only, arf_rec :: ARF_Graph n f + + anal_rewrite = arfGraph lattice $ arfBlock $ + arfNodeRewrite transfers rewrites arf_rec + + anal_only = arfGraph lattice $ arfBlock $ + arfNodeTransfer transfers + + arf_rec = case depth of + RewriteShallow -> anal_only + RewriteDeep -> anal_rewrite + +----------------------------------------------------------------------------- +-- Backward rewriting +----------------------------------------------------------------------------- + +type BackwardTransfers n f + = forall e x. TailFactB x f -> n e x -> f +type BackwardRewrites n f + = forall e x. TailFactB x f -> n e x -> Maybe (AGraph n e x) + +type ARB thing n f = forall e x. LiftNode x + => TailFactB x f -> thing e x + -> FuelMonad (f, Graph n e x) + +type family TailFactB x f :: * +type instance TailFactB C f = FactBase f +type instance TailFactB O f = f + +type ARB_Node n f = ARB n n f +type ARB_Block n f = ARB (Block n) n f +type ARB_Graph n f = ARB (Graph n) n f + +arbNodeTransfer :: forall n f . BackwardTransfers n f -> ARB_Node n f +-- Lifts BackwardTransfers to ARB_Node; simple transfer only +arbNodeTransfer transfer_fn f node + = return (transfer_fn f node, liftNode node) + +arbNodeRewrite :: forall n f. + BackwardTransfers n f + -> BackwardRewrites n f + -> ARB_Graph n f + -> ARB_Node n f +-- Lifts (BackwardTransfers,BackwardRewrites) to ARB_Node; +-- this time we do rewriting as well. +-- The ARB_Graph parameters specifies what to do with the rewritten graph +arbNodeRewrite transfer_fn rewrite_fn graph_trans f node + = do { mb_g <- withFuel (rewrite_fn f node) + ; case mb_g of + Nothing -> arbNodeTransfer transfer_fn f node + Just ag -> do { g <- graphOfAGraph ag + ; graph_trans f g } } + +arbBlock :: forall n f. ARB_Node n f -> ARB_Block n f +-- Lift from nodes to blocks +arbBlock arb_node f (BUnit node) = arb_node f node +arbBlock arb_node f (BCat b1 b2) = do { (f2,g2) <- arbBlock arb_node f b2 + ; (f1,g1) <- arbBlock arb_node f2 b1 + ; return (f1, g1 `gCat` g2) } + +arbGraph :: forall n f. DataflowLattice f -> ARB_Block n f -> ARB_Graph n f +arbGraph lattice arb_block f GNil = return (f, GNil) +arbGraph lattice arb_block f (GUnit blk) = arb_block f blk +arbGraph lattice arb_block f (GMany entry blocks exit) + = do { (f1, bs2, exit') <- bt_exit f exit + ; tx_fb <- bt_blocks blocks f1 + ; (f3, entry_g) <- arb_block (tfb_fbase tx_fb) entry + ; let (entry', bs1) = ecGraph entry_g + final_bs = bs1 `unionBlocks` tfb_blks tx_fb `unionBlocks` bs2 + ; return (f3, GMany entry' final_bs exit') } + where + -- It's a bit disgusting that the TxFactBase has to be + -- preserved as far as the Tail block, becaues the TxFactBase + -- is really concerned with the fixpoint calculation + -- But I can't see any other tidy way to compute the + -- LastOutFacts in the NoTail case + bt_exit :: TailFactB x f -> Tail n x + -> FuelMonad (FactBase f, BlockGraph n, Tail n x) + bt_exit f (Tail bid blk) + = do { (f1, g) <- arb_block f blk + ; let (bs, exit) = cxGraph bid g + ; return (mkFactBase [(bid,f1)], bs, exit) } + bt_exit f NoTail + = return (f, noBlocks, NoTail) + + bt_block_once :: (BlockId, Block n C C) -> TxFactBase n f + -> FuelMonad (TxFactBase n f) + bt_block_once (bid, b) = updateFacts lattice bid $ \fbase -> + do { (f, g) <- arb_block fbase b + ; return ([(bid,f)], g) } + + bt_blocks_once :: [(BlockId,Block n C C)] + -> TxFactBase n f -> FuelMonad (TxFactBase n f) + bt_blocks_once [] tx_fb = return tx_fb + bt_blocks_once (b:bs) tx_fb = do { tx_fb' <- bt_block_once b tx_fb + ; bt_blocks_once bs tx_fb' } + + bt_blocks :: BlockGraph n -> FactBase f -> FuelMonad (TxFactBase n f) + bt_blocks blocks = fixpoint (bt_blocks_once (backwardBlockList blocks)) + +analyseAndRewriteBwd + :: forall n f. + DataflowLattice f + -> BackwardTransfers n f + -> BackwardRewrites n f + -> RewritingDepth + -> ARB_Graph n f + +analyseAndRewriteBwd lattice transfers rewrites depth + = anal_rewrite + where + anal_rewrite, anal_only, arb_rec :: ARB_Graph n f + + anal_rewrite = arbGraph lattice $ arbBlock $ + arbNodeRewrite transfers rewrites arb_rec + + anal_only = arbGraph lattice $ arbBlock $ + arbNodeTransfer transfers + + arb_rec = case depth of + RewriteShallow -> anal_only + RewriteDeep -> anal_rewrite + + +----------------------------------------------------------------------------- +-- The fuel monad +----------------------------------------------------------------------------- + +type Uniques = Int +type Fuel = Int + +newtype FuelMonad a = FM { unFM :: Fuel -> Uniques -> (a, Fuel, Uniques) } + +instance Monad FuelMonad where + return x = FM (\f u -> (x,f,u)) + m >>= k = FM (\f u -> case unFM m f u of (r,f',u') -> unFM (k r) f' u') + +withFuel :: Maybe a -> FuelMonad (Maybe a) +withFuel Nothing = return Nothing +withFuel (Just r) = FM (\f u -> if f==0 then (Nothing, f, u) + else (Just r, f-1, u)) + +getFuel :: FuelMonad Fuel +getFuel = FM (\f u -> (f,f,u)) + +setFuel :: Fuel -> FuelMonad () +setFuel f = FM (\_ u -> ((), f, u)) + +graphOfAGraph :: AGraph node e x -> FuelMonad (Graph node e x) +graphOfAGraph = error "urk" -- Stub + +----------------------------------------------------------------------------- +-- BlockId, FactBase, BlockSet +----------------------------------------------------------------------------- + +type BlockId = Int + +mkBlockId :: Int -> BlockId +mkBlockId uniq = uniq + +---------------------- +type BlockMap a = M.IntMap a + +noBlocks :: BlockGraph n +noBlocks = M.empty + +addBlock :: BlockId -> Block n C C -> BlockGraph n -> BlockGraph n +addBlock = M.insert + +unionBlocks :: BlockGraph n -> BlockGraph n -> BlockGraph n +unionBlocks = M.union + +blocksToList :: BlockGraph n -> [(BlockId,Block n C C)] +blocksToList = M.toList + +---------------------- +type FactBase a = M.IntMap a + +mkFactBase :: [(BlockId, f)] -> FactBase f +mkFactBase prs = M.fromList prs + +lookupFact :: DataflowLattice f -> FactBase f -> BlockId -> f +lookupFact lattice env blk_id + = case M.lookup blk_id env of + Just f -> f + Nothing -> fact_bot lattice + +extendFactBase :: FactBase f -> BlockId -> f -> FactBase f +extendFactBase env blk_id f = M.insert blk_id f env + +unionFactBase :: FactBase f -> FactBase f -> FactBase f +unionFactBase = M.union + +factBaseList :: FactBase f -> [(BlockId, f)] +factBaseList env = M.toList env + + +---------------------- +type BlockSet = S.IntSet + +emptyBlockSet :: BlockSet +emptyBlockSet = S.empty + +extendBlockSet :: BlockSet -> BlockId -> BlockSet +extendBlockSet bids bid = S.insert bid bids + +elemBlockSet :: BlockId -> BlockSet -> Bool +elemBlockSet bid bids = S.member bid bids + +blockSetElems :: BlockSet -> [BlockId] +blockSetElems = S.toList + +minusBlockSet :: BlockSet -> BlockSet -> BlockSet +minusBlockSet = S.difference + +mkBlockSet :: [BlockId] -> BlockSet +mkBlockSet = S.fromList diff -Nru ghc-7.0.3/libraries/hoopl/prototypes/Hoopl5.hs ghc-7.2.1/libraries/hoopl/prototypes/Hoopl5.hs --- ghc-7.0.3/libraries/hoopl/prototypes/Hoopl5.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/prototypes/Hoopl5.hs 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,739 @@ +{-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies #-} + +{- Notes about the genesis of Hoopl5 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As well as addressing your concerns I had some of my own: + +* In Hoopl4, a closed/closed graph starts with a distinguished + closed/closed block (the entry block). But this block is + *un-labelled*. That means that there is no way to branch back to + the entry point of a procedure, which seems a bit unclean. + +* In general I have to admit that it does seem a bit unintuitive to + have block that is + a) closed on entry, but + b) does not have a label + +* If you look at MkZipCfgCmm you'll see stuff like this: + mkCmmIfThen e tbranch + = withFreshLabel "end of if" $ \endif -> + withFreshLabel "start of then" $ \tid -> + mkCbranch e tid endif <*> + mkLabel tid <*> tbranch <*> mkBranch endif <*> + mkLabel endif + + We are trying to present a user model *graphs* as + a sequence, connected by <*>, + of little graphs + Moreover, one of the little graphs is (mkLabel BlockId), and I + don't see how to make a graph for that in Hoopl4. + + (Norman I know that this may be what you have been trying to say + about "graphs under construction" for some time, but looking at + MkZipCfgCmm made it far more concrete for me.) + + +Specifically, in Hoopl5: + +* The ARF type is no longer overloaded over the LiftNode class. + It has a simple and beautiful type. + +* I put the BlockId back in a first node, as John wanted. + +* To make it possible to branch to the label of the entry block of a + Body it does make sense to put that block in the Body that is + the main payload of the graph + +* That militates in favour of a Maybe-kind-of-thing on entry to a + Body, just as Norman wanted. It's called Entry, dual to Exit. + +* However I am Very Very Keen to maintain the similar properties of + nodes, blocks, graphs; and in particular the single point of entry. + (For a multi-entry procedure, the procedure can be represented by a + Body plus a bunch of BlockIds, rather than a Body.) So I + made the Entry contain the BlockId of the entry point. + +* The Body in a Body is a finite map, as you wanted. Notice + that this embodies an invariant: a BlockId must map to a block whose + entry point is that BlockId. + +* I've added a layer, using arfBody/arbBlocks. Admittedly the + type doesn't fit the same pattern, but it's useful structuring + +* You should think of a Body as a user-visible type; perhaps + this is the kind of graph that might form the body of a procedure. + Moreover, perhaps rewriteAndAnlyseForward should take a Body + rather than a Body, and call arbBlocks. + +* With that in mind I was happy to introduce the analogous invariant + for the exit block in Exit; it is very very convenient to have that + BlockId (cached though it may be) to hand. + +* Because graphs are made out of blocks, it's easy to have a + constructor for the empty ggraph, and we don't need any stinkikng + smart constructor to keep nil in its place. But if we moved nil to + blocks, we'd need a smart constructor for graphs *and* one for + blocks. (Because unlike graphs, blocks *are* made from other + blocks. + +-} + +module Hoopl5 where + +import qualified Data.IntMap as M +import qualified Data.IntSet as S + +----------------------------------------------------------------------------- +-- Graphs +----------------------------------------------------------------------------- + +data O +data C + +-- Blocks are always non-empty +data Block n e x where + BUnit :: n e x -> Block n e x + BCat :: Block n e O -> Block n O x -> Block n e x + +type Body n = BlockMap (Block n C C) + -- Invariant: BlockId bid maps to a block whose entryBlockId is bid + +data Graph n e x where + GNil :: Graph n O O + GUnit :: Block n O O -> Graph n O O + GMany :: Entry n e -> Body n + -> Exit n x -> Graph n e x + -- If Entry is EntryC, then Body is non-empty + +data Entry n e where + EntryC :: BlockId -> Entry n C + EntryO :: Block n O C -> Entry n O + +data Exit n x where + ExitC :: Exit n C + ExitO :: BlockId -> Block n C O -> Exit n O + -- Invariant: the BlockId is the entryBlockId of the block + +----------------------------------------------------------------------------- +-- Defined here but not used +----------------------------------------------------------------------------- + +-- Singletons +-- OO GUnit +-- CO GMany (EntryC l) [] (ExitO l b) +-- OC GMany (EntryO b) [] ExitC +-- CC GMany (EntryC l) [b] ExitC + +bFilter :: forall n. (n O O -> Bool) -> Block n C C -> Block n C C +bFilter keep (BUnit n) = BUnit n +bFilter keep (BCat h t) = bFilterH h (bFilterT t) + where + bFilterH :: Block n C O -> Block n O C -> Block n C C + bFilterH (BUnit n) rest = BUnit n `BCat` rest + bFilterH (h `BCat` m) rest = bFilterH h (bFilterM m rest) + + bFilterT :: Block n O C -> Block n O C + bFilterT (BUnit n) = BUnit n + bFilterT (m `BCat` t) = bFilterM m (bFilterT t) + + bFilterM :: Block n O O -> Block n O C -> Block n O C + bFilterM (BUnit n) rest | keep n = BUnit n `BCat` rest + | otherwise = rest + bFilterM (b1 `BCat` b2) rest = bFilterM b1 (bFilterM b2 rest) + +gCat :: Graph n e a -> Graph n a x -> Graph n e x +gCat GNil g2 = g2 +gCat g1 GNil = g1 + +gCat (GUnit b1) (GUnit b2) + = GUnit (b1 `BCat` b2) + +gCat (GUnit b) (GMany (EntryO e) bs x) + = GMany (EntryO (b `BCat` e)) bs x + +gCat (GMany e bs (ExitO bid x)) (GUnit b2) + = GMany e bs (ExitO bid (x `BCat` b2)) + +gCat (GMany e1 bs1 (ExitO bid x1)) (GMany (EntryO e2) bs2 x2) + = GMany e1 (addBlock bid (x1 `BCat` e2) bs1 `unionBlocks` bs2) x2 + +gCat (GMany e1 bs1 ExitC) (GMany (EntryC _) bs2 x2) + = GMany e1 (bs1 `unionBlocks` bs2) x2 + +class Edges thing where + entryBlockId :: thing C x -> BlockId + successors :: thing e C -> [BlockId] + +instance Edges n => Edges (Block n) where + entryBlockId (BUnit n) = entryBlockId n + entryBlockId (b `BCat` _) = entryBlockId b + successors (BUnit n) = successors n + successors (BCat _ b) = successors b + +instance Edges n => Edges (Graph n) where + entryBlockId (GMany (EntryC bid) _ _) = bid + successors (GMany h bg ExitC) + = blockSetElems (all_succs `minusBlockSet` all_blk_ids) + where + (bids, blks) = unzip (blocksToList bg) + bg_succs = mkBlockSet [bid | b <- blks, bid <- successors b] + all_succs :: BlockSet + all_succs = case h of + EntryC _ -> bg_succs + EntryO b -> bg_succs `unionBlockSet` mkBlockSet (successors b) + all_blk_ids = mkBlockSet bids + +data OCFlag oc where + IsOpen :: OCFlag O + IsClosed :: OCFlag C + +class IsOC oc where + ocFlag :: OCFlag oc + +instance IsOC O where + ocFlag = IsOpen +instance IsOC C where + ocFlag = IsClosed + +mkIfThenElse :: forall n x. IsOC x + => (BlockId -> BlockId -> n O C) -- The conditional branch instruction + -> (BlockId -> n C O) -- Make a head node + -> (BlockId -> n O C) -- Make an unconditional branch + -> Graph n O x -> Graph n O x -- Then and else branches + -> [BlockId] -- Block supply + -> Graph n O x -- The complete thing +mkIfThenElse mk_cbranch mk_lbl mk_branch then_g else_g (tl:el:jl:_) + = case (ocFlag :: OCFlag x) of + IsOpen -> gUnitOC (mk_cbranch tl el) + `gCat` (mk_lbl_g tl `gCat` then_g `gCat` mk_branch_g jl) + `gCat` (mk_lbl_g el `gCat` else_g `gCat` mk_branch_g jl) + `gCat` (mk_lbl_g jl) + IsClosed -> gUnitOC (mk_cbranch tl el) + `gCat` (mk_lbl_g tl `gCat` then_g) + `gCat` (mk_lbl_g el `gCat` else_g) + where + mk_lbl_g :: BlockId -> Graph n C O + mk_lbl_g lbl = gUnitCO lbl (mk_lbl lbl) + mk_branch_g :: BlockId -> Graph n O C + mk_branch_g lbl = gUnitOC (mk_branch lbl) + +gUnitCO :: BlockId -> n C O -> Graph n C O +gUnitCO lbl n = GMany (EntryC lbl) noBlocks (ExitO lbl (BUnit n)) + +gUnitOC :: n O C -> Graph n O C +gUnitOC n = GMany (EntryO (BUnit n)) noBlocks ExitC + +----------------------------------------------------------------------------- +-- RG: an internal data type for graphs under construction +-- TOTALLY internal to Hoopl +----------------------------------------------------------------------------- + +-- "RG" stands for "rewritten graph", and embodies +-- both the result graph and its internal facts + +data RL n f x where + RL :: BlockId -> f -> RG n f C x -> RL n f x + RLMany :: GraphWithFacts n f -> RL n f C + +data RG n f e x where -- Will have facts too in due course + RGNil :: RG n f a a + RGBlock :: Block n e x -> RG n f e x + RGCatO :: RG n f e O -> RG n f O x -> RG n f e x + RGCatC :: RG n f e C -> RL n f x -> RG n f e x + +type GraphWithFacts n f = (Body n, FactBase f) + -- A Body together with the facts for that graph + -- The domains of the two maps should be identical + +-- 'normalise' converts a closed/closed result graph into a Body +-- It uses three auxiliary functions, +-- specialised for various argument shapes +normRL :: RL n f C -> GraphWithFacts n f +normRL (RL l f b) = normRG l f b +normRL (RLMany bg) = bg + +normRL_O :: RL n f O -> RG n f O C -> GraphWithFacts n f +normRL_O (RL l f b) rg = normRG_O l f b rg + +normRG :: BlockId -> f -> RG n f C C -> GraphWithFacts n f +normRG l f (RGBlock b) = unitBWF l f b +normRG l f (RGCatO rg1 rg2) = normRG_O l f rg1 rg2 +normRG l f (RGCatC rg1 rg2) = normRG l f rg1 `unionBWF` normRL rg2 + +normRG_O :: BlockId -> f -> RG n f C O -> RG n f O C -> GraphWithFacts n f +-- normalise (rg1 `RGCatO` rg2) +normRG_O l f (RGBlock b) rg = normB l f b rg +normRG_O l f (RGCatO rg1 rg2) rg3 = normRG_O l f rg1 (rg2 `RGCatO` rg3) +normRG_O l f (RGCatC rg1 rg2) rg3 = normRG l f rg1 `unionBWF` normRL_O rg2 rg3 + +normB :: BlockId -> f -> Block n C O -> RG n f O C -> GraphWithFacts n f +-- normalise (Block b `RGCatO` rg2) +normB l f b1 (RGBlock b2) = unitBWF l f (b1 `BCat` b2) +normB l f b (RGCatO rg1 rg2) = normB_O l f b rg1 rg2 +normB l f b (RGCatC rg1 rg2) = normB l f b rg1 `unionBWF` normRL rg2 + +normB_O :: BlockId -> f -> Block n C O -> RG n f O O -> RG n f O C + -> GraphWithFacts n f +-- normalise (Block b `RGCatO` rg2 `RGCatO` rg3) +normB_O l f b RGNil rg = normB l f b rg +normB_O l f bh (RGBlock bt) rg = normB l f (bh `BCat` bt) rg +normB_O l f b (RGCatC rg1 rg2) rg3 = normB l f b rg1 `unionBWF` normRL_O rg2 rg3 +normB_O l f b (RGCatO rg1 rg2) rg3 = normB_O l f b rg1 (rg2 `RGCatO` rg3) + +noBWF :: GraphWithFacts n f +noBWF = (noBlocks, noFacts) + +unitBWF :: BlockId -> f -> Block n C C -> GraphWithFacts n f +unitBWF lbl f b = (unitBlock lbl b, unitFactBase lbl f) + +unionBWF :: GraphWithFacts n f -> GraphWithFacts n f -> GraphWithFacts n f +unionBWF (bg1, fb1) (bg2, fb2) = (bg1 `unionBlocks` bg2, fb1 `unionFactBase` fb2) + +----------------------------------------------------------------------------- +-- DataflowLattice +----------------------------------------------------------------------------- + +data DataflowLattice a = DataflowLattice { + fact_name :: String, -- Documentation + fact_bot :: a, -- Lattice bottom element + fact_extend :: a -> a -> (ChangeFlag,a), -- Lattice join plus change flag + fact_do_logging :: Bool -- log changes +} + +data ChangeFlag = NoChange | SomeChange + +----------------------------------------------------------------------------- +-- The main Hoopl API +----------------------------------------------------------------------------- + +type ForwardTransfer n f + = forall e x. n e x -> f -> ExitFactF x f + +type ForwardRewrite n f + = forall e x. n e x -> f -> Maybe (AGraph n e x) + +type family ExitFactF x f :: * +type instance ExitFactF C f = [(BlockId, f)] +type instance ExitFactF O f = f + +data AGraph n e x = AGraph -- Stub for now + + +----------------------------------------------------------------------------- +-- TxFactBase: a FactBase with ChangeFlag information +----------------------------------------------------------------------------- + +-- The TxFactBase is an accumulating parameter, threaded through all +-- the analysis/transformation of each block in the g_blocks of a grpah. +-- It carries a ChangeFlag with it, and a set of BlockIds +-- to monitor. Updates to other BlockIds don't affect the ChangeFlag +data TxFactBase n f + = TxFB { tfb_fbase :: FactBase f + + , tfb_cha :: ChangeFlag + , tfb_bids :: BlockSet -- Update change flag iff these blocks change + -- These are BlockIds of the *original* + -- (not transformed) blocks + + , tfb_blks :: GraphWithFacts n f -- Transformed blocks + } + +updateFact :: DataflowLattice f -> BlockSet + -> (BlockId, f) + -> (ChangeFlag, FactBase f) + -> (ChangeFlag, FactBase f) +-- Update a TxFactBase, setting the change flag iff +-- a) the new fact adds information... +-- b) for a block in the BlockSet in the TxFactBase +updateFact lat lbls (lbl, new_fact) (cha, fbase) + | NoChange <- cha2 = (cha, fbase) + | lbl `elemBlockSet` lbls = (SomeChange, new_fbase) + | otherwise = (cha, new_fbase) + where + old_fact = lookupFact lat fbase lbl + (cha2, res_fact) = fact_extend lat old_fact new_fact + new_fbase = extendFactBase fbase lbl res_fact + +fixpoint :: forall n f. + DataflowLattice f + -> (BlockId -> Block n C C -> FactBase f + -> FuelMonad ([(BlockId,f)], RL n f C)) + -> [(BlockId, Block n C C)] + -> FactBase f + -> FuelMonad (FactBase f, GraphWithFacts n f) +fixpoint lat do_block blocks init_fbase + = do { fuel <- getFuel + ; tx_fb <- loop fuel init_fbase + ; return (tfb_fbase tx_fb `deleteFromFactBase` blocks, tfb_blks tx_fb) } + -- The successors of the Graph are the the BlockIds for which + -- we have facts, that are *not* in the blocks of the graph + where + tx_blocks :: [(BlockId, Block n C C)] + -> TxFactBase n f -> FuelMonad (TxFactBase n f) + tx_blocks [] tx_fb = return tx_fb + tx_blocks ((lbl,blk):bs) tx_fb = do { tx_fb1 <- tx_block lbl blk tx_fb + ; tx_blocks bs tx_fb1 } + + tx_block :: BlockId -> Block n C C + -> TxFactBase n f -> FuelMonad (TxFactBase n f) + tx_block lbl blk (TxFB { tfb_fbase = fbase, tfb_bids = lbls + , tfb_blks = blks, tfb_cha = cha }) + = do { (out_facts, rg) <- do_block lbl blk fbase + ; let (cha',fbase') = foldr (updateFact lat lbls) (cha,fbase) out_facts + f = lookupFact lat fbase lbl + -- tfb_blks will be discarded unless we have + -- reached a fixed point, so it doesn't matter + -- whether we get f from fbase or fbase' + ; return (TxFB { tfb_bids = extendBlockSet lbls lbl + , tfb_blks = normRL rg `unionBWF` blks + , tfb_fbase = fbase', tfb_cha = cha' }) } + + loop :: Fuel -> FactBase f -> FuelMonad (TxFactBase n f) + loop fuel fbase + = do { let init_tx_fb = TxFB { tfb_fbase = fbase + , tfb_cha = NoChange + , tfb_blks = noBWF + , tfb_bids = emptyBlockSet } + ; tx_fb <- tx_blocks blocks init_tx_fb + ; case tfb_cha tx_fb of + NoChange -> return tx_fb + SomeChange -> do { setFuel fuel; loop fuel (tfb_fbase tx_fb) } } + +----------------------------------------------------------------------------- +-- Transfer functions +----------------------------------------------------------------------------- + +-- Keys to the castle: a generic transfer function for each shape +-- Here's the idea: we start with single-n transfer functions, +-- move to basic-block transfer functions (we have exactly four shapes), +-- then finally to graph transfer functions (which requires iteration). + +type ARF thing n f = forall e x. f -> thing e x -> FuelMonad (ExitFactF x f, RG n f e x) + +type ARF_Node n f = ARF n n f +type ARF_Block n f = ARF (Block n) n f +type ARF_Graph n f = ARF (Graph n) n f +----------------------------------------------------------------------------- + +arfNodeNoRW :: forall n f. ForwardTransfer n f -> ARF_Node n f + -- Lifts ForwardTransfer to ARF_Node; simple transfer only +arfNodeNoRW transfer_fn f node + = return (transfer_fn node f, RGBlock (BUnit node)) + +arfNode :: forall n f. + DataflowLattice f + -> ForwardTransfer n f + -> ForwardRewrite n f + -> ARF_Node n f + -> ARF_Node n f +-- Lifts (ForwardTransfer,ForwardRewrite) to ARF_Node; +-- this time we do rewriting as well. +-- The ARF_Graph parameters specifies what to do with the rewritten graph +arfNode lattice transfer_fn rewrite_fn arf_node f node + = do { mb_g <- withFuel (rewrite_fn node f) + ; case mb_g of + Nothing -> arfNodeNoRW transfer_fn f node + Just ag -> do { g <- graphOfAGraph ag + ; arfGraph lattice arf_node f g } } + +arfBlock :: forall n f. ARF_Node n f -> ARF_Block n f +-- Lift from nodes to blocks +arfBlock arf_node f (BUnit node) = arf_node f node +arfBlock arf_node f (BCat hd mids) = do { (f1,g1) <- arfBlock arf_node f hd + ; (f2,g2) <- arfBlock arf_node f1 mids + ; return (f2, g1 `RGCatO` g2) } + +arfBody :: forall n f. DataflowLattice f + -> ARF_Node n f -> FactBase f -> Body n + -> FuelMonad (FactBase f, GraphWithFacts n f) + -- Outgoing factbase is restricted to BlockIds *not* in + -- in the Body; the facts for BlockIds + -- *in* the Body are in the GraphWithFacts +arfBody lattice arf_node init_fbase blocks + = fixpoint lattice do_block + (forwardBlockList (factBaseBlockIds init_fbase) blocks) + init_fbase + where + do_block :: BlockId -> Block n C C -> FactBase f + -> FuelMonad ([(BlockId,f)], RL n f C) + do_block l blk fbase = do { let f = lookupFact lattice fbase l + ; (fs, rg) <- arfBlock arf_node f blk + ; return (fs, RL l f rg) } + +arfGraph :: forall n f. DataflowLattice f -> ARF_Node n f -> ARF_Graph n f +-- Lift from blocks to graphs +arfGraph _ _ f GNil = return (f, RGNil) +arfGraph _ arf_node f (GUnit blk) = arfBlock arf_node f blk +arfGraph lattice arf_node f (GMany entry blks exit) + = do { (f1, entry') <- arf_entry f entry + ; (f2, blks') <- arfBody lattice arf_node (mkFactBase f1) blks + ; (f3, exit') <- arf_exit f2 exit + ; return (f3, entry' `RGCatC` RLMany blks' `RGCatC` exit') } + where + arf_entry :: f -> Entry n e + -> FuelMonad ([(BlockId,f)], RG n f e C) + arf_entry fh (EntryC lh) = return ([(lh,fh)], RGNil) + arf_entry fh (EntryO b) = arfBlock arf_node fh b + + arf_exit :: FactBase f -> Exit n x + -> FuelMonad (ExitFactF x f, RL n f x) + arf_exit fb ExitC = return (factBaseList fb, RLMany noBWF) + arf_exit fb (ExitO lt blk) = do { let ft = lookupFact lattice fb lt + ; (f1, rg) <- arfBlock arf_node ft blk + ; return (f1, RL lt ft rg) } + +forwardBlockList :: [BlockId] -> Body n -> [(BlockId,Block n C C)] +-- This produces a list of blocks in order suitable for forward analysis. +-- ToDo: Do a topological sort to improve convergence rate of fixpoint +-- This will require a (HavingSuccessors l) class constraint +forwardBlockList _ blks = blocksToList blks + +---------------------------------------------------------------- +-- The pièce de resistance: cunning transfer functions +---------------------------------------------------------------- + +pureAnalysis :: DataflowLattice f -> ForwardTransfer n f -> ARF_Graph n f +pureAnalysis lattice f = arfGraph lattice (arfNodeNoRW f) + +analyseAndRewriteFwd + :: forall n f. + DataflowLattice f + -> ForwardTransfer n f + -> ForwardRewrite n f + -> RewritingDepth + -> FactBase f + -> Body n + -> FuelMonad (Body n, FactBase f) + +data RewritingDepth = RewriteShallow | RewriteDeep +-- When a transformation proposes to rewrite a node, +-- you can either ask the system to +-- * "shallow": accept the new graph, analyse it without further rewriting +-- * "deep": recursively analyse-and-rewrite the new graph + +analyseAndRewriteFwd lattice transfers rewrites depth facts graph + = do { (_, gwf) <- arfBody lattice arf_node facts graph + ; return gwf } + where + arf_node, rec_node :: ARF_Node n f + arf_node = arfNode lattice transfers rewrites rec_node + + rec_node = case depth of + RewriteShallow -> arfNodeNoRW transfers + RewriteDeep -> arf_node + +----------------------------------------------------------------------------- +-- Backward rewriting +----------------------------------------------------------------------------- + +type BackwardTransfer n f + = forall e x. n e x -> ExitFactB x f -> f +type BackwardRewrite n f + = forall e x. n e x -> ExitFactB x f -> Maybe (AGraph n e x) + +type ARB thing n f = forall e x. ExitFactB x f -> thing e x + -> FuelMonad (f, RG n f e x) + +type family ExitFactB x f :: * +type instance ExitFactB C f = FactBase f +type instance ExitFactB O f = f + +type ARB_Node n f = ARB n n f +type ARB_Block n f = ARB (Block n) n f +type ARB_Graph n f = ARB (Graph n) n f + +arbNodeNoRW :: forall n f . BackwardTransfer n f -> ARB_Node n f +-- Lifts BackwardTransfer to ARB_Node; simple transfer only +arbNodeNoRW transfer_fn f node + = return (transfer_fn node f, RGBlock (BUnit node)) + +arbNode :: forall n f. + DataflowLattice f + -> BackwardTransfer n f + -> BackwardRewrite n f + -> ARB_Node n f + -> ARB_Node n f +-- Lifts (BackwardTransfer,BackwardRewrite) to ARB_Node; +-- this time we do rewriting as well. +-- The ARB_Graph parameters specifies what to do with the rewritten graph +arbNode lattice transfer_fn rewrite_fn arf_node f node + = do { mb_g <- withFuel (rewrite_fn node f) + ; case mb_g of + Nothing -> arbNodeNoRW transfer_fn f node + Just ag -> do { g <- graphOfAGraph ag + ; arbGraph lattice arf_node f g } } + +arbBlock :: forall n f. ARB_Node n f -> ARB_Block n f +-- Lift from nodes to blocks +arbBlock arb_node f (BUnit node) = arb_node f node +arbBlock arb_node f (BCat b1 b2) = do { (f2,g2) <- arbBlock arb_node f b2 + ; (f1,g1) <- arbBlock arb_node f2 b1 + ; return (f1, g1 `RGCatO` g2) } + + +arbBlocks :: forall n f. DataflowLattice f + -> ARB_Node n f -> FactBase f + -> Body n -> FuelMonad (FactBase f, GraphWithFacts n f) +arbBlocks lattice arb_node init_fbase blocks + = fixpoint lattice do_block + (backwardBlockList (factBaseBlockIds init_fbase) blocks) + init_fbase + where + do_block :: BlockId -> Block n C C -> FactBase f + -> FuelMonad ([(BlockId,f)], RL n f C) + do_block l b fbase = do { (fb, rg) <- arbBlock arb_node fbase b + ; let f = lookupFact lattice fbase l + ; return ([(l,fb)], RL l f rg) } + +arbGraph :: forall n f. DataflowLattice f -> ARB_Node n f -> ARB_Graph n f +arbGraph _ _ f GNil = return (f, RGNil) +arbGraph _ arb_node f (GUnit blk) = arbBlock arb_node f blk +arbGraph lattice arb_node f (GMany entry blks exit) + = do { (f1, exit') <- arb_exit f exit + ; (f2, blks') <- arbBlocks lattice arb_node f1 blks + ; (f3, entry') <- arb_entry f2 entry + ; return (f3, entry' `RGCatC` RLMany blks' `RGCatC` exit') } + where + arb_entry :: FactBase f -> Entry n e + -> FuelMonad (f, RG n f e C) + arb_entry fbase (EntryC l) = return (lookupFact lattice fbase l, RGNil) + arb_entry fbase (EntryO b) = arbBlock arb_node fbase b + + arb_exit :: ExitFactB x f -> Exit n x + -> FuelMonad (FactBase f, RL n f x) + arb_exit ft ExitC = return (ft, RLMany noBWF) + arb_exit ft (ExitO lt blk) = do { (f1, rg) <- arbBlock arb_node ft blk + ; return (mkFactBase [(lt,f1)], RL lt f1 rg) } + +backwardBlockList :: [BlockId] -> Body n -> [(BlockId,Block n C C)] +-- This produces a list of blocks in order suitable for backward analysis. +backwardBlockList _ blks = blocksToList blks + +analyseAndRewriteBwd + :: forall n f. + DataflowLattice f + -> BackwardTransfer n f + -> BackwardRewrite n f + -> RewritingDepth + -> ARB_Graph n f + +analyseAndRewriteBwd lattice transfers rewrites depth + = arbGraph lattice arb_node + where + arb_node, rec_node :: ARB_Node n f + arb_node = arbNode lattice transfers rewrites rec_node + + rec_node = case depth of + RewriteShallow -> arbNodeNoRW transfers + RewriteDeep -> arb_node + +----------------------------------------------------------------------------- +-- The fuel monad +----------------------------------------------------------------------------- + +type Uniques = Int +type Fuel = Int + +newtype FuelMonad a = FM { unFM :: Fuel -> Uniques -> (a, Fuel, Uniques) } + +instance Monad FuelMonad where + return x = FM (\f u -> (x,f,u)) + m >>= k = FM (\f u -> case unFM m f u of (r,f',u') -> unFM (k r) f' u') + +withFuel :: Maybe a -> FuelMonad (Maybe a) +withFuel Nothing = return Nothing +withFuel (Just r) = FM (\f u -> if f==0 then (Nothing, f, u) + else (Just r, f-1, u)) + +getFuel :: FuelMonad Fuel +getFuel = FM (\f u -> (f,f,u)) + +setFuel :: Fuel -> FuelMonad () +setFuel f = FM (\_ u -> ((), f, u)) + +graphOfAGraph :: AGraph node e x -> FuelMonad (Graph node e x) +graphOfAGraph = error "urk" -- Stub + +----------------------------------------------------------------------------- +-- BlockId, FactBase, BlockSet +----------------------------------------------------------------------------- + +type BlockId = Int + +mkBlockId :: Int -> BlockId +mkBlockId uniq = uniq + +---------------------- +type BlockMap a = M.IntMap a + +noBlocks :: Body n +noBlocks = M.empty + +unitBlock :: BlockId -> Block n C C -> Body n +unitBlock = M.singleton + +addBlock :: BlockId -> Block n C C -> Body n -> Body n +addBlock = M.insert + +unionBlocks :: Body n -> Body n -> Body n +unionBlocks = M.union + +blocksToList :: Body n -> [(BlockId,Block n C C)] +blocksToList = M.toList + +---------------------- +type FactBase a = M.IntMap a + +noFacts :: FactBase f +noFacts = M.empty + +mkFactBase :: [(BlockId, f)] -> FactBase f +mkFactBase prs = M.fromList prs + +unitFactBase :: BlockId -> f -> FactBase f +unitFactBase = M.singleton + +lookupFact :: DataflowLattice f -> FactBase f -> BlockId -> f +lookupFact lattice env blk_id + = case M.lookup blk_id env of + Just f -> f + Nothing -> fact_bot lattice + +extendFactBase :: FactBase f -> BlockId -> f -> FactBase f +extendFactBase env blk_id f = M.insert blk_id f env + +unionFactBase :: FactBase f -> FactBase f -> FactBase f +unionFactBase = M.union + +factBaseBlockIds :: FactBase f -> [BlockId] +factBaseBlockIds = M.keys + +factBaseList :: FactBase f -> [(BlockId, f)] +factBaseList = M.toList + +deleteFromFactBase :: FactBase f -> [(BlockId,a)] -> FactBase f +deleteFromFactBase fb blks = foldr (M.delete . fst) fb blks + +---------------------- +type BlockSet = S.IntSet + +emptyBlockSet :: BlockSet +emptyBlockSet = S.empty + +extendBlockSet :: BlockSet -> BlockId -> BlockSet +extendBlockSet bids bid = S.insert bid bids + +elemBlockSet :: BlockId -> BlockSet -> Bool +elemBlockSet bid bids = S.member bid bids + +blockSetElems :: BlockSet -> [BlockId] +blockSetElems = S.toList + +minusBlockSet :: BlockSet -> BlockSet -> BlockSet +minusBlockSet = S.difference + +unionBlockSet :: BlockSet -> BlockSet -> BlockSet +unionBlockSet = S.union + +mkBlockSet :: [BlockId] -> BlockSet +mkBlockSet = S.fromList diff -Nru ghc-7.0.3/libraries/hoopl/prototypes/Hoopl6.hs ghc-7.2.1/libraries/hoopl/prototypes/Hoopl6.hs --- ghc-7.0.3/libraries/hoopl/prototypes/Hoopl6.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/prototypes/Hoopl6.hs 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,753 @@ +{-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies #-} + +{- Notes about the genesis of Hoopl5 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +As well as addressing your concerns I had some of my own: + +* In Hoopl4, a closed/closed graph starts with a distinguished + closed/closed block (the entry block). But this block is + *un-labelled*. That means that there is no way to branch back to + the entry point of a procedure, which seems a bit unclean. + +* In general I have to admit that it does seem a bit unintuitive to + have block that is + a) closed on entry, but + b) does not have a label + +* If you look at MkZipCfgCmm you'll see stuff like this: + mkCmmIfThen e tbranch + = withFreshLabel "end of if" $ \endif -> + withFreshLabel "start of then" $ \tid -> + mkCbranch e tid endif <*> + mkLabel tid <*> tbranch <*> mkBranch endif <*> + mkLabel endif + + We are trying to present a user model *graphs* as + a sequence, connected by <*>, + of little graphs + Moreover, one of the little graphs is (mkLabel BlockId), and I + don't see how to make a graph for that in Hoopl4. + + (Norman I know that this may be what you have been trying to say + about "graphs under construction" for some time, but looking at + MkZipCfgCmm made it far more concrete for me.) + + +Specifically, in Hoopl5: + +* The ARF type is no longer overloaded over the LiftNode class. + It has a simple and beautiful type. + +* I put the BlockId back in a first node, as John wanted. + +* To make it possible to branch to the label of the entry block of a + Graph it does make sense to put that block in the Graph that is + the main payload of the graph + +* That militates in favour of a Maybe-kind-of-thing on entry to a + Graph, just as Norman wanted. It's called Head, dual to Tail. + +* However I am Very Very Keen to maintain the similar properties of + nodes, blocks, graphs; and in particular the single point of entry. + (For a multi-entry procedure, the procedure can be represented by a + Graph plus a bunch of BlockIds, rather than a Graph.) So I + made the Head contain the BlockId of the entry point. + +* The Graph in a Graph is a finite map, as you wanted. Notice + that this embodies an invariant: a BlockId must map to a block whose + entry point is that BlockId. + +* I've added a layer, using arfBlocks/arbBlocks. Admittedly the + type doesn't fit the same pattern, but it's useful structuring + +* You should think of a Graph as a user-visible type; perhaps + this is the kind of graph that might form the body of a procedure. + Moreover, perhaps rewriteAndAnlyseForward should take a Graph + rather than a Graph, and call arbBlocks. + +* With that in mind I was happy to introduce the analogous invariant + for the exit block in Tail; it is very very convenient to have that + BlockId (cached though it may be) to hand. + +* Because graphs are made out of blocks, it's easy to have a + constructor for the empty ggraph, and we don't need any stinkikng + smart constructor to keep nil in its place. But if we moved nil to + blocks, we'd need a smart constructor for graphs *and* one for + blocks. (Because unlike graphs, blocks *are* made from other + blocks. + + +-} + +module Hoopl5 where + +import qualified Data.IntMap as M +import qualified Data.IntSet as S + +----------------------------------------------------------------------------- +-- Graphs +----------------------------------------------------------------------------- + +data O +data C + +-- Blocks are always non-empty +data Block n e x where + BUnit :: n e x -> Block n e x + BCat :: Block n e O -> Block n O x -> Block n e x + +data Graph n e x where + GNil :: Graph n O O + GUnit :: Block n O O -> Graph n O O + GMany :: IfOpen e (Block n O C) -> BlockMap (Block n C C) + -> IfOpen x (Block n C O) -> Graph n e x + +data IfOpen e thing where + IsOpen :: thing -> IfOpen O thing + IsNotOpen :: IfOpen C thing + +----------------------------------------------------------------------------- +-- Defined here but not used +----------------------------------------------------------------------------- + +-- Singletons +-- OO GUnit +-- CO GMany (NoHead l) [] (Tail l b) +-- OC GMany (Head b) [] NoTail +-- CC GMany (NoHead l) [b] NoTail + +class Edges thing where + closedId :: thing e x -> IfClosed e BlockId + successors :: thing e C -> [BlockId] + +instance Edges n => Edges (Block n) where + closedId (BUnit n) = closedId n + closedId (b `BCat` _) = closedId b + successors (BUnit n) = successors n + successors (BCat _ b) = successors b + +data IfClosed e thing where + IsClosed :: thing -> IfClosed C thing + IsNotClosed :: IfClosed O thing + + +----------------------------------------------------------------------------- +-- RG: an internal data type for graphs under construction +-- TOTALLY internal to Hoopl +----------------------------------------------------------------------------- + +-- "RG" stands for "rewritten graph", and embodies +-- both the result graph and its internal facts + +data RL n f x where + RL :: BlockId -> f -> RG n f C x -> RL n f x + RLMany :: GraphWithFacts n f -> RL n f C + +data RG n f e x where -- Will have facts too in due course + RGNil :: RG n f a a + RGBlock :: Block n e x -> RG n f e x + RGCatO :: RG n f e O -> RG n f O x -> RG n f e x + RGCatC :: RG n f e C -> RL n f x -> RG n f e x + +type GraphWithFacts n f = (BlockMap (Block n C C), FactBase f) + -- A Graph together with the facts for that graph + -- The domains of the two maps should be identical + +-- 'normalise' converts a closed/closed result graph into a Graph +-- It uses three auxiliary functions, +-- specialised for various argument shapes +normRL :: RL n f C -> GraphWithFacts n f +normRL (RL l f b) = normRG l f b +normRL (RLMany bg) = bg + +normRL_O :: RL n f O -> RG n f O C -> GraphWithFacts n f +normRL_O (RL l f b) rg = normRG_O l f b rg + +normRG :: BlockId -> f -> RG n f C C -> GraphWithFacts n f +normRG l f (RGBlock b) = unitBWF l f b +normRG l f (RGCatO rg1 rg2) = normRG_O l f rg1 rg2 +normRG l f (RGCatC rg1 rg2) = normRG l f rg1 `unionBWF` normRL rg2 + +normRG_O :: BlockId -> f -> RG n f C O -> RG n f O C -> GraphWithFacts n f +-- normalise (rg1 `RGCatO` rg2) +normRG_O l f (RGBlock b) rg = normB l f b rg +normRG_O l f (RGCatO rg1 rg2) rg3 = normRG_O l f rg1 (rg2 `RGCatO` rg3) +normRG_O l f (RGCatC rg1 rg2) rg3 = normRG l f rg1 `unionBWF` normRL_O rg2 rg3 + +normB :: BlockId -> f -> Block n C O -> RG n f O C -> GraphWithFacts n f +-- normalise (Block b `RGCatO` rg2) +normB l f b1 (RGBlock b2) = unitBWF l f (b1 `BCat` b2) +normB l f b (RGCatO rg1 rg2) = normB_O l f b rg1 rg2 +normB l f b (RGCatC rg1 rg2) = normB l f b rg1 `unionBWF` normRL rg2 + +normB_O :: BlockId -> f -> Block n C O -> RG n f O O -> RG n f O C + -> GraphWithFacts n f +-- normalise (Block b `RGCatO` rg2 `RGCatO` rg3) +normB_O l f b RGNil rg = normB l f b rg +normB_O l f bh (RGBlock bt) rg = normB l f (bh `BCat` bt) rg +normB_O l f b (RGCatC rg1 rg2) rg3 = normB l f b rg1 `unionBWF` normRL_O rg2 rg3 +normB_O l f b (RGCatO rg1 rg2) rg3 = normB_O l f b rg1 (rg2 `RGCatO` rg3) + +noBWF :: GraphWithFacts n f +noBWF = (noBlocks, noFacts) + +unitBWF :: BlockId -> f -> Block n C C -> GraphWithFacts n f +unitBWF lbl f b = (unitBlock lbl b, unitFactBase lbl f) + +unionBWF :: GraphWithFacts n f -> GraphWithFacts n f -> GraphWithFacts n f +unionBWF (bg1, fb1) (bg2, fb2) = (bg1 `unionBlocks` bg2, fb1 `unionFactBase` fb2) + +----------------------------------------------------------------------------- +-- DataflowLattice +----------------------------------------------------------------------------- + +data DataflowLattice a = DataflowLattice { + fact_name :: String, -- Documentation + fact_bot :: a, -- Lattice bottom element + fact_extend :: a -> a -> (ChangeFlag,a), -- Lattice join plus change flag + fact_do_logging :: Bool -- log changes +} + +data ChangeFlag = NoChange | SomeChange + +----------------------------------------------------------------------------- +-- The main Hoopl API +----------------------------------------------------------------------------- + +type ForwardTransfer n f + = forall e x. f -> n e x -> TailFactF x f + +type ForwardRewrite n f + = forall e x. f -> n e x -> Maybe (AGraph n e x) + +type family TailFactF x f :: * +type instance TailFactF C f = [(BlockId, f)] +type instance TailFactF O f = f + +data AGraph n e x = AGraph -- Stub for now + + +----------------------------------------------------------------------------- +-- TxFactBase: a FactBase with ChangeFlag information +----------------------------------------------------------------------------- + +-- The TxFactBase is an accumulating parameter, threaded through all +-- the analysis/transformation of each block in the g_blocks of a grpah. +-- It carries a ChangeFlag with it, and a set of BlockIds +-- to monitor. Updates to other BlockIds don't affect the ChangeFlag +data TxFactBase n f + = TxFB { tfb_fbase :: FactBase f + + , tfb_cha :: ChangeFlag + , tfb_bids :: BlockSet -- Update change flag iff these blocks change + -- These are BlockIds of the *original* + -- (not transformed) blocks + + , tfb_blks :: GraphWithFacts n f -- Transformed blocks + } + +updateFact :: DataflowLattice f -> BlockSet + -> (BlockId, f) + -> (ChangeFlag, FactBase f) + -> (ChangeFlag, FactBase f) +-- Update a TxFactBase, setting the change flag iff +-- a) the new fact adds information... +-- b) for a block in the BlockSet in the TxFactBase +updateFact lat lbls (lbl, new_fact) (cha, fbase) + | NoChange <- cha2 = (cha, fbase) + | lbl `elemBlockSet` lbls = (SomeChange, new_fbase) + | otherwise = (cha, new_fbase) + where + old_fact = lookupFact lat fbase lbl + (cha2, res_fact) = fact_extend lat old_fact new_fact + new_fbase = extendFactBase fbase lbl res_fact + +fixpoint :: forall n f. + DataflowLattice f + -> (BlockId -> Block n C C -> FactBase f + -> FuelMonad ([(BlockId,f)], RL n f C)) + -> [(BlockId, Block n C C)] + -> FactBase f + -> FuelMonad (FactBase f, GraphWithFacts n f) +fixpoint lat do_block blocks init_fbase + = do { fuel <- getFuel + ; tx_fb <- loop fuel init_fbase + ; return (tfb_fbase tx_fb `deleteFromFactBase` blocks, tfb_blks tx_fb) } + -- The successors of the Graph are the the BlockIds for which + -- we have facts, that are *not* in the blocks of the graph + where + tx_blocks :: [(BlockId, Block n C C)] + -> TxFactBase n f -> FuelMonad (TxFactBase n f) + tx_blocks [] tx_fb = return tx_fb + tx_blocks ((lbl,blk):bs) tx_fb = do { tx_fb1 <- tx_block lbl blk tx_fb + ; tx_blocks bs tx_fb1 } + + tx_block :: BlockId -> Block n C C + -> TxFactBase n f -> FuelMonad (TxFactBase n f) + tx_block lbl blk (TxFB { tfb_fbase = fbase, tfb_bids = lbls + , tfb_blks = blks, tfb_cha = cha }) + = do { (out_facts, rg) <- do_block lbl blk fbase + ; let (cha',fbase') = foldr (updateFact lat lbls) (cha,fbase) out_facts + f = lookupFact lat fbase lbl + -- tfb_blks will be discarded unless we have + -- reached a fixed point, so it doesn't matter + -- whether we get f from fbase or fbase' + ; return (TxFB { tfb_bids = extendBlockSet lbls lbl + , tfb_blks = normRL rg `unionBWF` blks + , tfb_fbase = fbase', tfb_cha = cha' }) } + + loop :: Fuel -> FactBase f -> FuelMonad (TxFactBase n f) + loop fuel fbase + = do { let init_tx_fb = TxFB { tfb_fbase = fbase + , tfb_cha = NoChange + , tfb_blks = noBWF + , tfb_bids = emptyBlockSet } + ; tx_fb <- tx_blocks blocks init_tx_fb + ; case tfb_cha tx_fb of + NoChange -> return tx_fb + SomeChange -> do { setFuel fuel; loop fuel (tfb_fbase tx_fb) } } + +----------------------------------------------------------------------------- +-- Transfer functions +----------------------------------------------------------------------------- + +-- Keys to the castle: a generic transfer function for each shape +-- Here's the idea: we start with single-n transfer functions, +-- move to basic-block transfer functions (we have exactly four shapes), +-- then finally to graph transfer functions (which requires iteration). + +type ARF thing n f = forall e x. f -> thing e x -> FuelMonad (TailFactF x f, RG n f e x) + +type ARF_Node n f = ARF n n f +type ARF_Block n f = ARF (Block n) n f +type ARF_Graph n f = ARF (Graph n) n f +----------------------------------------------------------------------------- + +arfNodeNoRW :: forall n f. ForwardTransfer n f -> ARF_Node n f + -- Lifts ForwardTransfer to ARF_Node; simple transfer only +arfNodeNoRW transfer_fn f node + = return (transfer_fn f node, RGBlock (BUnit node)) + +arfNode :: forall n f. + Edges n + => DataflowLattice f + -> ForwardTransfer n f + -> ForwardRewrite n f + -> ARF_Node n f + -> ARF_Node n f +-- Lifts (ForwardTransfer,ForwardRewrite) to ARF_Node; +-- this time we do rewriting as well. +-- The ARF_Graph parameters specifies what to do with the rewritten graph +arfNode lattice transfer_fn rewrite_fn arf_node f node + = do { mb_g <- withFuel (rewrite_fn f node) + ; case mb_g of + Nothing -> arfNodeNoRW transfer_fn f node + Just ag -> do { g <- graphOfAGraph ag + ; arfGraph lattice arf_node f g } } + +arfBlock :: forall n f. ARF_Node n f -> ARF_Block n f +-- Lift from nodes to blocks +arfBlock arf_node f (BUnit node) = arf_node f node +arfBlock arf_node f (BCat hd mids) = do { (f1,g1) <- arfBlock arf_node f hd + ; (f2,g2) <- arfBlock arf_node f1 mids + ; return (f2, g1 `RGCatO` g2) } + +arfBlocks :: forall n f. DataflowLattice f + -> ARF_Node n f -> FactBase f -> BlockMap (Block n C C) + -> FuelMonad (FactBase f, GraphWithFacts n f) + -- Outgoing factbase is restricted to BlockIds *not* in + -- in the Graph; the facts for BlockIds + -- *in* the Graph are in the GraphWithFacts +arfBlocks lattice arf_node init_fbase blocks + = fixpoint lattice do_block + (forwardBlockList (factBaseBlockIds init_fbase) blocks) + init_fbase + where + do_block :: BlockId -> Block n C C -> FactBase f + -> FuelMonad ([(BlockId,f)], RL n f C) + do_block l blk fbase = do { let f = lookupFact lattice fbase l + ; (fs, rg) <- arfBlock arf_node f blk + ; return (fs, RL l f rg) } + +arfGraph :: forall n f. Edges n => DataflowLattice f -> ARF_Node n f -> ARF_Graph n f +-- Lift from blocks to graphs +arfGraph _ _ f GNil = return (f, RGNil) +arfGraph _ arf_node f (GUnit blk) = arfBlock arf_node f blk +arfGraph lattice arf_node f (GMany entry blks exit) + = do { (f1, entry') <- arf_entry f entry + ; (f2, blks') <- arfBlocks lattice arf_node (mkFactBase f1) blks + ; (f3, exit') <- arf_exit f2 exit + ; return (f3, entry' `RGCatC` RLMany blks' `RGCatC` exit') } + where + arf_entry :: f -> IfOpen e (Block n O C) + -> FuelMonad ([(BlockId,f)], RG n f e C) + arf_entry fh IsNotOpen = return ([], RGNil) + arf_entry fh (IsOpen b) = arfBlock arf_node fh b + + arf_exit :: FactBase f -> IfOpen x (Block n C O) + -> FuelMonad (TailFactF x f, RL n f x) + arf_exit fb IsNotOpen = return (factBaseList fb, RLMany noBWF) + arf_exit fb (IsOpen blk) = do { let ft = lookupFact lattice fb lt + ; (f1, rg) <- arfBlock arf_node ft blk + ; return (f1, RL lt ft rg) } + where IsClosed lt :: IfClosed C BlockId = closedId blk + +forwardBlockList :: [BlockId] -> BlockMap (Block n C C) -> [(BlockId,Block n C C)] +-- This produces a list of blocks in order suitable for forward analysis. +-- ToDo: Do a topological sort to improve convergence rate of fixpoint +-- This will require a (HavingSuccessors l) class constraint +forwardBlockList _ blks = blocksToList blks + +---------------------------------------------------------------- +-- The pièce de resistance: cunning transfer functions +---------------------------------------------------------------- + +pureAnalysis :: Edges n => DataflowLattice f -> ForwardTransfer n f -> ARF_Graph n f +pureAnalysis lattice f = arfGraph lattice (arfNodeNoRW f) + +analyseAndRewriteFwd + :: forall n f. + Edges n + => DataflowLattice f + -> ForwardTransfer n f + -> ForwardRewrite n f + -> RewritingDepth + -> FactBase f + -> BlockMap (Block n C C) + -> FuelMonad (BlockMap (Block n C C), FactBase f) + +data RewritingDepth = RewriteShallow | RewriteDeep +-- When a transformation proposes to rewrite a node, +-- you can either ask the system to +-- * "shallow": accept the new graph, analyse it without further rewriting +-- * "deep": recursively analyse-and-rewrite the new graph + +analyseAndRewriteFwd lattice transfers rewrites depth facts graph + = do { (_, gwf) <- arfBlocks lattice arf_node facts graph + ; return gwf } + where + arf_node, rec_node :: ARF_Node n f + arf_node = arfNode lattice transfers rewrites rec_node + + rec_node = case depth of + RewriteShallow -> arfNodeNoRW transfers + RewriteDeep -> arf_node + +----------------------------------------------------------------------------- +-- Backward rewriting +----------------------------------------------------------------------------- + +type BackwardTransfer n f + = forall e x. TailFactB x f -> n e x -> f +type BackwardRewrite n f + = forall e x. TailFactB x f -> n e x -> Maybe (AGraph n e x) + +type ARB thing n f = forall e x. TailFactB x f -> thing e x + -> FuelMonad (f, RG n f e x) + +type family TailFactB x f :: * +type instance TailFactB C f = FactBase f +type instance TailFactB O f = f + +type ARB_Node n f = ARB n n f +type ARB_Block n f = ARB (Block n) n f +type ARB_Graph n f = ARB (Graph n) n f + +arbNodeNoRW :: forall n f . BackwardTransfer n f -> ARB_Node n f +-- Lifts BackwardTransfer to ARB_Node; simple transfer only +arbNodeNoRW transfer_fn f node + = return (transfer_fn f node, RGBlock (BUnit node)) + +arbNode :: forall n f. + Edges n + => DataflowLattice f + -> BackwardTransfer n f + -> BackwardRewrite n f + -> ARB_Node n f + -> ARB_Node n f +-- Lifts (BackwardTransfer,BackwardRewrite) to ARB_Node; +-- this time we do rewriting as well. +-- The ARB_Graph parameters specifies what to do with the rewritten graph +arbNode lattice transfer_fn rewrite_fn arf_node f node + = do { mb_g <- withFuel (rewrite_fn f node) + ; case mb_g of + Nothing -> arbNodeNoRW transfer_fn f node + Just ag -> do { g <- graphOfAGraph ag + ; arbGraph lattice arf_node f (closedId node) g } } + +arbBlock :: forall n f. ARB_Node n f -> ARB_Block n f +-- Lift from nodes to blocks +arbBlock arb_node f (BUnit node) = arb_node f node +arbBlock arb_node f (BCat b1 b2) = do { (f2,g2) <- arbBlock arb_node f b2 + ; (f1,g1) <- arbBlock arb_node f2 b1 + ; return (f1, g1 `RGCatO` g2) } + + +arbBlocks :: forall n f. DataflowLattice f + -> ARB_Node n f -> FactBase f + -> BlockMap (Block n C C) -> FuelMonad (FactBase f, GraphWithFacts n f) +arbBlocks lattice arb_node init_fbase blocks + = fixpoint lattice do_block + (backwardBlockList (factBaseBlockIds init_fbase) blocks) + init_fbase + where + do_block :: BlockId -> Block n C C -> FactBase f + -> FuelMonad ([(BlockId,f)], RL n f C) + do_block l b fbase = do { (fb, rg) <- arbBlock arb_node fbase b + ; let f = lookupFact lattice fbase l + ; return ([(l,fb)], RL l f rg) } + +arbGraph :: forall n f e x. + Edges n + => DataflowLattice f + -> ARB_Node n f + -> TailFactB x f + -> IfClosed e BlockId + -> Graph n e x + -> FuelMonad (f, RG n f e x) +arbGraph _ _ f _ GNil = return (f, RGNil) +arbGraph _ arb_node f _ (GUnit blk) = arbBlock arb_node f blk +arbGraph lattice arb_node f eid (GMany entry blks exit) + = do { (f1, exit') <- arb_exit f exit + ; (f2, blks') <- arbBlocks lattice arb_node f1 blks + ; (f3, entry') <- arb_entry f2 eid entry + ; return (f3, entry' `RGCatC` RLMany blks' `RGCatC` exit') } + where + arb_entry :: FactBase f -> IfClosed e BlockId -> IfOpen e (Block n O C) + -> FuelMonad (f, RG n f e C) + arb_entry fbase (IsClosed eid) IsNotOpen = return (lookupFact lattice fbase eid, + RGNil) + arb_entry fbase IsNotClosed (IsOpen blk) = arbBlock arb_node fbase blk + + arb_exit :: TailFactB x f -> IfOpen x (Block n C O) + -> FuelMonad (FactBase f, RL n f x) + arb_exit ft IsNotOpen = return (ft, RLMany noBWF) + arb_exit ft (IsOpen blk) = do { (f1, rg) <- arbBlock arb_node ft blk + ; return (mkFactBase [(lt,f1)], RL lt f1 rg) } + where IsClosed lt :: IfClosed C BlockId = closedId blk + +backwardBlockList :: [BlockId] -> BlockMap (Block n C C) -> [(BlockId,Block n C C)] +-- This produces a list of blocks in order suitable for backward analysis. +backwardBlockList _ blks = blocksToList blks + +analyseAndRewriteBwd + :: forall n f. + Edges n + => DataflowLattice f + -> BackwardTransfer n f + -> BackwardRewrite n f + -> RewritingDepth + -> FactBase f + -> BlockMap (Block n C C) + -> FuelMonad (BlockMap (Block n C C), FactBase f) + +analyseAndRewriteBwd lattice transfers rewrites depth facts graph + = do { (_, gwf) <- arbBlocks lattice arb_node facts graph + ; return gwf } + where + arb_node, rec_node :: ARB_Node n f + arb_node = arbNode lattice transfers rewrites rec_node + + rec_node = case depth of + RewriteShallow -> arbNodeNoRW transfers + RewriteDeep -> arb_node + +----------------------------------------------------------------------------- +-- The fuel monad +----------------------------------------------------------------------------- + +type Uniques = Int +type Fuel = Int + +newtype FuelMonad a = FM { unFM :: Fuel -> Uniques -> (a, Fuel, Uniques) } + +instance Monad FuelMonad where + return x = FM (\f u -> (x,f,u)) + m >>= k = FM (\f u -> case unFM m f u of (r,f',u') -> unFM (k r) f' u') + +withFuel :: Maybe a -> FuelMonad (Maybe a) +withFuel Nothing = return Nothing +withFuel (Just r) = FM (\f u -> if f==0 then (Nothing, f, u) + else (Just r, f-1, u)) + +getFuel :: FuelMonad Fuel +getFuel = FM (\f u -> (f,f,u)) + +setFuel :: Fuel -> FuelMonad () +setFuel f = FM (\_ u -> ((), f, u)) + +graphOfAGraph :: AGraph node e x -> FuelMonad (Graph node e x) +graphOfAGraph = error "urk" -- Stub + +----------------------------------------------------------------------------- +-- BlockId, FactBase, BlockSet +----------------------------------------------------------------------------- + +type BlockId = Int + +mkBlockId :: Int -> BlockId +mkBlockId uniq = uniq + +---------------------- +type BlockMap a = M.IntMap a + +noBlocks :: BlockMap (Block n C C) +noBlocks = M.empty + +unitBlock :: BlockId -> Block n C C -> BlockMap (Block n C C) +unitBlock = M.singleton + +addBlock :: BlockId -> Block n C C -> BlockMap (Block n C C) -> BlockMap (Block n C C) +addBlock = M.insert + +unionBlocks :: BlockMap (Block n C C) -> BlockMap (Block n C C) -> BlockMap (Block n C C) +unionBlocks = M.union + +blocksToList :: BlockMap (Block n C C) -> [(BlockId,Block n C C)] +blocksToList = M.toList + +---------------------- +type FactBase a = M.IntMap a + +noFacts :: FactBase f +noFacts = M.empty + +mkFactBase :: [(BlockId, f)] -> FactBase f +mkFactBase prs = M.fromList prs + +unitFactBase :: BlockId -> f -> FactBase f +unitFactBase = M.singleton + +lookupFact :: DataflowLattice f -> FactBase f -> BlockId -> f +lookupFact lattice env blk_id + = case M.lookup blk_id env of + Just f -> f + Nothing -> fact_bot lattice + +extendFactBase :: FactBase f -> BlockId -> f -> FactBase f +extendFactBase env blk_id f = M.insert blk_id f env + +unionFactBase :: FactBase f -> FactBase f -> FactBase f +unionFactBase = M.union + +factBaseBlockIds :: FactBase f -> [BlockId] +factBaseBlockIds = M.keys + +factBaseList :: FactBase f -> [(BlockId, f)] +factBaseList = M.toList + +deleteFromFactBase :: FactBase f -> [(BlockId,a)] -> FactBase f +deleteFromFactBase fb blks = foldr (M.delete . fst) fb blks + +---------------------- +type BlockSet = S.IntSet + +emptyBlockSet :: BlockSet +emptyBlockSet = S.empty + +extendBlockSet :: BlockSet -> BlockId -> BlockSet +extendBlockSet bids bid = S.insert bid bids + +elemBlockSet :: BlockId -> BlockSet -> Bool +elemBlockSet bid bids = S.member bid bids + +blockSetElems :: BlockSet -> [BlockId] +blockSetElems = S.toList + +minusBlockSet :: BlockSet -> BlockSet -> BlockSet +minusBlockSet = S.difference + +unionBlockSet :: BlockSet -> BlockSet -> BlockSet +unionBlockSet = S.union + +mkBlockSet :: [BlockId] -> BlockSet +mkBlockSet = S.fromList + +---------------------------------------------------------------- +-- +-- DROPPINGS follow... +-- +---------------------------------------------------------------- +{- + +data OCFlag oc where + IsOpen :: OCFlag O + IsClosed :: OCFlag C + +class IsOC oc where + ocFlag :: OCFlag oc + +instance IsOC O where + ocFlag = IsOpen +instance IsOC C where + ocFlag = IsClosed + +mkIfThenElse :: forall n x. IsOC x + => (BlockId -> BlockId -> n O C) -- The conditional branch instruction + -> (BlockId -> n C O) -- Make a head node + -> (BlockId -> n O C) -- Make an unconditional branch + -> Graph n O x -> Graph n O x -- Then and else branches + -> [BlockId] -- Block supply + -> Graph n O x -- The complete thing +mkIfThenElse mk_cbranch mk_lbl mk_branch then_g else_g (tl:el:jl:_) + = case (ocFlag :: OCFlag x) of + IsOpen -> gUnitOC (mk_cbranch tl el) + `pCat` (mk_lbl_g tl `pCat` then_g `pCat` mk_branch_g jl) + `pCat` (mk_lbl_g el `pCat` else_g `pCat` mk_branch_g jl) + `pCat` (mk_lbl_g jl) + IsClosed -> gUnitOC (mk_cbranch tl el) + `pCat` (mk_lbl_g tl `pCat` then_g) + `pCat` (mk_lbl_g el `pCat` else_g) + where + mk_lbl_g :: BlockId -> Graph n C O + mk_lbl_g lbl = gUnitCO (mk_lbl lbl) + mk_branch_g :: BlockId -> Graph n O C + mk_branch_g lbl = gUnitOC (mk_branch lbl) + +gUnitCO :: n C O -> Graph n C O +gUnitCO n = GMany (IsNotOpen) noBlocks (IsOpen (BUnit n)) + +gUnitOC :: n O C -> Graph n O C +gUnitOC n = GMany (IsOpen (BUnit n)) noBlocks IsNotOpen +-} + + + +bFilter :: forall n. (n O O -> Bool) -> Block n C C -> Block n C C +bFilter keep (BUnit n) = BUnit n +bFilter keep (BCat h t) = bFilterH h (bFilterT t) + where + bFilterH :: Block n C O -> Block n O C -> Block n C C + bFilterH (BUnit n) rest = BUnit n `BCat` rest + bFilterH (h `BCat` m) rest = bFilterH h (bFilterM m rest) + + bFilterT :: Block n O C -> Block n O C + bFilterT (BUnit n) = BUnit n + bFilterT (m `BCat` t) = bFilterM m (bFilterT t) + + bFilterM :: Block n O O -> Block n O C -> Block n O C + bFilterM (BUnit n) rest | keep n = BUnit n `BCat` rest + | otherwise = rest + bFilterM (b1 `BCat` b2) rest = bFilterM b1 (bFilterM b2 rest) + + +pCat :: Edges n => Graph n e a -> Graph n a x -> Graph n e x +pCat GNil g2 = g2 +pCat g1 GNil = g1 + +pCat (GUnit b1) (GUnit b2) + = GUnit (b1 `BCat` b2) + +pCat (GUnit b) (GMany (IsOpen e) bs x) + = GMany (IsOpen (b `BCat` e)) bs x + +pCat (GMany e bs (IsOpen x)) (GUnit b2) + = GMany e bs (IsOpen (x `BCat` b2)) + +pCat (GMany e1 bs1 (IsOpen x1)) (GMany (IsOpen e2) bs2 x2) + = GMany e1 (add (x1 `BCat` e2) bs1 `unionBlocks` bs2) x2 + where add b = addBlock id b + where IsClosed id :: IfClosed C BlockId = closedId b + +pCat (GMany e1 bs1 IsNotOpen) (GMany IsNotOpen bs2 x2) + = GMany e1 (bs1 `unionBlocks` bs2) x2 diff -Nru ghc-7.0.3/libraries/hoopl/prototypes/Hoopl7.hs ghc-7.2.1/libraries/hoopl/prototypes/Hoopl7.hs --- ghc-7.0.3/libraries/hoopl/prototypes/Hoopl7.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/prototypes/Hoopl7.hs 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,692 @@ +{-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies #-} + +{- Notes about the genesis of Hoopl7 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Hoopl7 has the following major chages + +a) GMany has symmetric entry and exit +b) GMany closed-entry does not record a BlockId +c) GMany open-exit does not record a BlockId +d) The body of a GMany is called Body +e) A Body is just a list of blocks, not a map. I've argued + elsewhere that this is consistent with (c) + +A consequence is that Graph is no longer an instance of Edges, +but nevertheless I managed to keep the ARF and ARB signatures +nice and uniform. + +This was made possible by + +* ForwardTransfer looks like this: + type ForwardTransfer n f + = forall e x. n e x -> Fact e f -> Fact x f + type family Fact x f :: * + type instance Fact C f = FactBase f + type instance Fact O f = f + + Note that the incoming fact is a Fact (not just 'f' as in Hoopl5,6). + It's up to the *transfer function* to look up the appropriate fact + in the FactBase for a closed-entry node. Example: + constProp (Label l) fb = lookupFact fb l + That is how Hoopl can avoid having to know the block-id for the + first node: it defers to the client. + + [Side note: that means the client must know about + bottom, in case the looupFact returns Nothing] + +* Note also that ForwardTransfer *returns* a Fact too; + that is, the types in both directions are symmetrical. + Previously we returned a [(BlockId,f)] but I could not see + how to make everything line up if we do this. + + Indeed, the main shortcoming of Hoopl7 is that we are more + or less forced into this uniform representation of the facts + flowing into or out of a closed node/block/graph, whereas + previously we had more flexibility. + + In exchange the code is neater, with fewer distinct types. + And morally a FactBase is equivalent to [(BlockId,f)] and + nearly equivalent to (BlockId -> f). + +* I've realised that forwardBlockList and backwardBlockList + both need (Edges n), and that goes everywhere. + +* I renamed BlockId to Label +-} + +module Hoopl7 where + +import qualified Data.IntMap as M +import qualified Data.IntSet as S + +----------------------------------------------------------------------------- +-- Graphs +----------------------------------------------------------------------------- + +data O +data C + +-- Blocks are always non-empty +data Block n e x where + BUnit :: n e x -> Block n e x + BCat :: Block n e O -> Block n O x -> Block n e x + +data Body n where + BodyEmpty :: Body n + BodyUnit :: Block n C C -> Body n + BodyCat :: Body n -> Body n -> Body n + +data Graph n e x where + GNil :: Graph n O O + GUnit :: Block n O O -> Graph n O O + GMany :: MaybeO e (Block n O C) + -> Body n + -> MaybeO x (Block n C O) + -> Graph n e x + +data MaybeO ex t where + JustO :: t -> MaybeO O t + NothingO :: MaybeO C t + +------------------------------- +class Edges thing where + entryLabel :: thing C x -> Label + successors :: thing e C -> [Label] + +instance Edges n => Edges (Block n) where + entryLabel (BUnit n) = entryLabel n + entryLabel (b `BCat` _) = entryLabel b + successors (BUnit n) = successors n + successors (BCat _ b) = successors b + +------------------------------ +addBlock :: Block n C C -> Body n -> Body n +addBlock b body = BodyUnit b `BodyCat` body + +bodyList :: Edges n => Body n -> [(Label,Block n C C)] +bodyList body = go body [] + where + go BodyEmpty bs = bs + go (BodyUnit b) bs = (entryLabel b, b) : bs + go (BodyCat b1 b2) bs = go b1 (go b2 bs) + +----------------------------------------------------------------------------- +-- Defined here but not used +----------------------------------------------------------------------------- + +-- Singletons +-- OO GUnit +-- CO GMany (NothingO l) [] (JustO b) +-- OC GMany (JustO b) [] NothingO +-- CC GMany (NothingO l) [b] NothingO + +gCat :: Graph n e a -> Graph n a x -> Graph n e x +gCat GNil g2 = g2 +gCat g1 GNil = g1 + +gCat (GUnit b1) (GUnit b2) + = GUnit (b1 `BCat` b2) + +gCat (GUnit b) (GMany (JustO e) bs x) + = GMany (JustO (b `BCat` e)) bs x + +gCat (GMany e bs (JustO x)) (GUnit b2) + = GMany e bs (JustO (x `BCat` b2)) + +gCat (GMany e1 bs1 (JustO x1)) (GMany (JustO e2) bs2 x2) + = GMany e1 (addBlock (x1 `BCat` e2) bs1 `BodyCat` bs2) x2 + +gCat (GMany e1 bs1 NothingO) (GMany NothingO bs2 x2) + = GMany e1 (bs1 `BodyCat` bs2) x2 + + + +------------------------------ +----------------------------------------------------------------------------- +-- RG: an internal data type for graphs under construction +-- TOTALLY internal to Hoopl +----------------------------------------------------------------------------- + +data RG n f e x where + RGNil :: RG n f a a + RGUnit :: Fact e f -> Block n e x -> RG n f e x + RGCatO :: RG n f e O -> RG n f O x -> RG n f e x + RGCatC :: RG n f e C -> RG n f C x -> RG n f e x + +type BodyWithFacts n f = (Body n, FactBase f) +type GraphWithFacts n f e x = (Graph n e x, FactBase f) + -- A Graph together with the facts for that graph + -- The domains of the two maps should be identical + +normaliseBody :: Edges n => RG n f C C -> BodyWithFacts n f +normaliseBody rg = (body, fact_base) + where + (GMany _ body _, fact_base) = normCC rg + +normOO :: Edges n => RG n f O O -> GraphWithFacts n f O O +normOO RGNil = (GNil, noFacts) +normOO (RGUnit _ b) = (GUnit b, noFacts) +normOO (RGCatO g1 g2) = normOO g1 `gwfCat` normOO g2 +normOO (RGCatC g1 g2) = normOC g1 `gwfCat` normCO g2 + +normOC :: Edges n => RG n f O C -> GraphWithFacts n f O C +normOC (RGUnit _ b) = (GMany (JustO b) BodyEmpty NothingO, noFacts) +normOC (RGCatO g1 g2) = normOO g1 `gwfCat` normOC g2 +normOC (RGCatC g1 g2) = normOC g1 `gwfCat` normCC g2 + +normCO :: Edges n => RG n f C O -> GraphWithFacts n f C O +normCO (RGUnit f b) = (GMany NothingO BodyEmpty (JustO b), unitFact l f) + where + l = entryLabel b +normCO (RGCatO g1 g2) = normCO g1 `gwfCat` normOO g2 +normCO (RGCatC g1 g2) = normCC g1 `gwfCat` normCO g2 + +normCC :: Edges n => RG n f C C -> GraphWithFacts n f C C +normCC RGNil = (GMany NothingO BodyEmpty NothingO, noFacts) +normCC (RGUnit f b) = (GMany NothingO (BodyUnit b) NothingO, unitFact l f) + where + l = entryLabel b +normCC (RGCatO g1 g2) = normCO g1 `gwfCat` normOC g2 +normCC (RGCatC g1 g2) = normCC g1 `gwfCat` normCC g2 + +gwfCat :: Edges n => GraphWithFacts n f e a + -> GraphWithFacts n f a x + -> GraphWithFacts n f e x +gwfCat (g1, fb1) (g2, fb2) = (g1 `gCat` g2, fb1 `unionFactBase` fb2) + +bwfUnion :: BodyWithFacts n f -> BodyWithFacts n f -> BodyWithFacts n f +bwfUnion (bg1, fb1) (bg2, fb2) = (bg1 `BodyCat` bg2, fb1 `unionFactBase` fb2) + +----------------------------------------------------------------------------- +-- DataflowLattice +----------------------------------------------------------------------------- + +data DataflowLattice a = DataflowLattice { + fact_name :: String, -- Documentation + fact_bot :: a, -- Lattice bottom element + fact_extend :: a -> a -> (ChangeFlag,a), -- Lattice join plus change flag + fact_do_logging :: Bool -- log changes +} + +data ChangeFlag = NoChange | SomeChange + +----------------------------------------------------------------------------- +-- Analyse and rewrite forward +----------------------------------------------------------------------------- + +data ForwardPass n f + = FwdPass { fp_lattice :: DataflowLattice f + , fp_transfer :: FwdTransfer n f + , fp_rewrite :: FwdRewrite n f } + +type FwdTransfer n f + = forall e x. n e x -> Fact e f -> Fact x f + +type FwdRewrite n f + = forall e x. n e x -> Fact e f -> Maybe (FwdRes n f e x) +data FwdRes n f e x = FwdRes (AGraph n e x) (FwdRewrite n f) + +type family Fact x f :: * +type instance Fact C f = FactBase f +type instance Fact O f = f + +type ARF thing n + = forall f e x. ForwardPass n f -> thing e x + -> Fact e f -> FuelMonad (RG n f e x, Fact x f) + +type SimpleFwdRewrite n f + = forall e x. n e x -> Fact e f + -> Maybe (AGraph n e x) + +noFwdRewrite :: FwdRewrite n f +noFwdRewrite _ _ = Nothing + +shallowFwdRw :: SimpleFwdRewrite n f -> FwdRewrite n f +shallowFwdRw rw n f = case (rw n f) of + Nothing -> Nothing + Just ag -> Just (FwdRes ag noFwdRewrite) + +thenFwdRw :: FwdRewrite n f -> FwdRewrite n f -> FwdRewrite n f +thenFwdRw rw1 rw2 n f + = case rw1 n f of + Nothing -> rw2 n f + Just (FwdRes ag rw1a) -> Just (FwdRes ag (rw1a `thenFwdRw` rw2)) + +deepFwdRw :: FwdRewrite n f -> FwdRewrite n f +deepFwdRw rw = rw `thenFwdRw` deepFwdRw rw + + + +----------------------------------------------------------------------------- + +arfNode :: Edges n => ARF n n +arfNode pass node f + = do { mb_g <- withFuel (fp_rewrite pass node f) + ; case mb_g of + Nothing -> return (RGUnit f (BUnit node), + fp_transfer pass node f) + Just (FwdRes ag rw) -> do { g <- graphOfAGraph ag + ; let pass' = pass { fp_rewrite = rw } + ; arfGraph pass' g f } } + +arfBlock :: Edges n => ARF (Block n) n +-- Lift from nodes to blocks +arfBlock pass (BUnit node) f = arfNode pass node f +arfBlock pass (BCat hd mids) f = do { (g1,f1) <- arfBlock pass hd f + ; (g2,f2) <- arfBlock pass mids f1 + ; return (g1 `RGCatO` g2, f2) } + +arfBody :: Edges n + => ForwardPass n f -> Body n -> FactBase f + -> FuelMonad (RG n f C C, FactBase f) + -- Outgoing factbase is restricted to Labels *not* in + -- in the Body; the facts for Labels + -- *in* the Body are in the BodyWithFacts +arfBody pass blocks init_fbase + = fixpoint True (fp_lattice pass) (arfBlock pass) init_fbase $ + forwardBlockList (factBaseLabels init_fbase) blocks + +arfGraph :: Edges n => ARF (Graph n) n +-- Lift from blocks to graphs +arfGraph _ GNil f = return (RGNil, f) +arfGraph pass (GUnit blk) f = arfBlock pass blk f +arfGraph pass (GMany NothingO body NothingO) f + = do { (body', fb) <- arfBody pass body f + ; return (body', fb) } +arfGraph pass (GMany NothingO body (JustO exit)) f + = do { (body', fb) <- arfBody pass body f + ; (exit', fx) <- arfBlock pass exit fb + ; return (body' `RGCatC` exit', fx) } +arfGraph pass (GMany (JustO entry) body NothingO) f + = do { (entry', fe) <- arfBlock pass entry f + ; (body', fb) <- arfBody pass body fe + ; return (entry' `RGCatC` body', fb) } +arfGraph pass (GMany (JustO entry) body (JustO exit)) f + = do { (entry', fe) <- arfBlock pass entry f + ; (body', fb) <- arfBody pass body fe + ; (exit', fx) <- arfBlock pass exit fb + ; return (entry' `RGCatC` body' `RGCatC` exit', fx) } + +forwardBlockList :: Edges n => [Label] -> Body n -> [(Label,Block n C C)] +-- This produces a list of blocks in order suitable for forward analysis. +-- ToDo: Do a topological sort to improve convergence rate of fixpoint +-- This will require a (HavingSuccessors l) class constraint +forwardBlockList _ blks = bodyList blks + +---------------------------------------------------------------- +-- The pièce de resistance: cunning transfer functions +---------------------------------------------------------------- + +analyseAndRewriteFwd + :: forall n f. Edges n + => ForwardPass n f + -> Body n -> FactBase f + -> FuelMonad (Body n, FactBase f) + +analyseAndRewriteFwd pass body facts + = do { (rg, _) <- arfBody pass body facts + ; return (normaliseBody rg) } + +----------------------------------------------------------------------------- +-- Backward rewriting +----------------------------------------------------------------------------- + +data BackwardPass n f + = BwdPass { bp_lattice :: DataflowLattice f + , bp_transfer :: BwdTransfer n f + , bp_rewrite :: BwdRewrite n f } + +type BwdTransfer n f + = forall e x. n e x -> Fact x f -> Fact e f +type BwdRewrite n f + = forall e x. n e x -> Fact x f -> Maybe (BwdRes n f e x) +data BwdRes n f e x = BwdRes (AGraph n e x) (BwdRewrite n f) + +type ARB thing n + = forall f e x. BackwardPass n f -> thing e x + -> Fact x f -> FuelMonad (RG n f e x, Fact e f) + +arbNode :: Edges n => ARB n n +-- Lifts (BwdTransfer,BwdRewrite) to ARB_Node; +-- this time we do rewriting as well. +-- The ARB_Graph parameters specifies what to do with the rewritten graph +arbNode pass node f + = do { mb_g <- withFuel (bp_rewrite pass node f) + ; case mb_g of + Nothing -> return (RGUnit entry_f (BUnit node), entry_f) + where + entry_f = bp_transfer pass node f + Just (BwdRes ag rw) -> do { g <- graphOfAGraph ag + ; let pass' = pass { bp_rewrite = rw } + ; arbGraph pass' g f} } + +arbBlock :: Edges n => ARB (Block n) n +-- Lift from nodes to blocks +arbBlock pass (BUnit node) f = arbNode pass node f +arbBlock pass (BCat b1 b2) f = do { (g2,f2) <- arbBlock pass b2 f + ; (g1,f1) <- arbBlock pass b1 f2 + ; return (g1 `RGCatO` g2, f1) } + +arbBody :: Edges n + => BackwardPass n f -> Body n -> FactBase f + -> FuelMonad (RG n f C C, FactBase f) +arbBody pass blocks init_fbase + = fixpoint False (bp_lattice pass) (arbBlock pass) init_fbase $ + backwardBlockList (factBaseLabels init_fbase) blocks + +arbGraph :: Edges n => ARB (Graph n) n +arbGraph _ GNil f = return (RGNil, f) +arbGraph pass (GUnit blk) f = arbBlock pass blk f +arbGraph pass (GMany NothingO body NothingO) f + = do { (body', fb) <- arbBody pass body f + ; return (body', fb) } +arbGraph pass (GMany NothingO body (JustO exit)) f + = do { (exit', fx) <- arbBlock pass exit f + ; (body', fb) <- arbBody pass body fx + ; return (body' `RGCatC` exit', fb) } +arbGraph pass (GMany (JustO entry) body NothingO) f + = do { (body', fb) <- arbBody pass body f + ; (entry', fe) <- arbBlock pass entry fb + ; return (entry' `RGCatC` body', fe) } +arbGraph pass (GMany (JustO entry) body (JustO exit)) f + = do { (exit', fx) <- arbBlock pass exit f + ; (body', fb) <- arbBody pass body fx + ; (entry', fe) <- arbBlock pass entry fb + ; return (entry' `RGCatC` body' `RGCatC` exit', fe) } + +backwardBlockList :: Edges n => [Label] -> Body n -> [(Label,Block n C C)] +-- This produces a list of blocks in order suitable for backward analysis. +backwardBlockList _ blks = bodyList blks + +analyseAndRewriteBwd + :: forall n f. Edges n + => BackwardPass n f + -> Body n -> FactBase f + -> FuelMonad (Body n, FactBase f) + +analyseAndRewriteBwd pass body facts + = do { (rg, _) <- arbBody pass body facts + ; return (normaliseBody rg) } + + +----------------------------------------------------------------------------- +-- fixpoint: finding fixed points +----------------------------------------------------------------------------- + +data TxFactBase n f + = TxFB { tfb_fbase :: FactBase f + , tfb_rg :: RG n f C C -- Transformed blocks + , tfb_cha :: ChangeFlag + , tfb_lbls :: LabelSet } + -- Note [TxFactBase change flag] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- Set the tfb_cha flag iff + -- (a) the fact in tfb_fbase for or a block L changes + -- (b) L is in tfb_lbls. + -- The tfb_lbls are all Labels of the *original* + -- (not transformed) blocks + +updateFact :: DataflowLattice f -> LabelSet -> (Label, f) + -> (ChangeFlag, FactBase f) + -> (ChangeFlag, FactBase f) +-- See Note [TxFactBase change flag] +updateFact lat lbls (lbl, new_fact) (cha, fbase) + | NoChange <- cha2 = (cha, fbase) + | lbl `elemLabelSet` lbls = (SomeChange, new_fbase) + | otherwise = (cha, new_fbase) + where + (cha2, res_fact) + = case lookupFact fbase lbl of + Nothing -> (SomeChange, new_fact) -- Note [Unreachable blocks] + Just old_fact -> fact_extend lat old_fact new_fact + new_fbase = extendFactBase fbase lbl res_fact + +fixpoint :: forall n f. Edges n + => Bool -- Going forwards? + -> DataflowLattice f + -> (Block n C C -> FactBase f + -> FuelMonad (RG n f C C, FactBase f)) + -> FactBase f -> [(Label, Block n C C)] + -> FuelMonad (RG n f C C, FactBase f) +fixpoint is_fwd lat do_block init_fbase blocks + = do { fuel <- getFuel + ; tx_fb <- loop fuel init_fbase + ; return (tfb_rg tx_fb, + tfb_fbase tx_fb `delFromFactBase` blocks) } + -- The successors of the Graph are the the Labels for which + -- we have facts, that are *not* in the blocks of the graph + where + tx_blocks :: [(Label, Block n C C)] + -> TxFactBase n f -> FuelMonad (TxFactBase n f) + tx_blocks [] tx_fb = return tx_fb + tx_blocks ((lbl,blk):bs) tx_fb = tx_block lbl blk tx_fb >>= tx_blocks bs + + tx_block :: Label -> Block n C C + -> TxFactBase n f -> FuelMonad (TxFactBase n f) + tx_block lbl blk tx_fb@(TxFB { tfb_fbase = fbase, tfb_lbls = lbls + , tfb_rg = blks, tfb_cha = cha }) + | is_fwd && not (lbl `elemFactBase` fbase) + = return tx_fb -- Note [Unreachable blocks] + | otherwise + = do { (rg, out_facts) <- do_block blk fbase + ; let (cha',fbase') + = foldr (updateFact lat lbls) (cha,fbase) + (factBaseList out_facts) + ; return (TxFB { tfb_lbls = extendLabelSet lbls lbl + , tfb_rg = rg `RGCatC` blks + , tfb_fbase = fbase', tfb_cha = cha' }) } + + loop :: Fuel -> FactBase f -> FuelMonad (TxFactBase n f) + loop fuel fbase + = do { let init_tx_fb = TxFB { tfb_fbase = fbase + , tfb_cha = NoChange + , tfb_rg = RGNil + , tfb_lbls = emptyLabelSet } + ; tx_fb <- tx_blocks blocks init_tx_fb + ; case tfb_cha tx_fb of + NoChange -> return tx_fb + SomeChange -> do { setFuel fuel + ; loop fuel (tfb_fbase tx_fb) } } + +{- Note [Unreachable blocks] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A block that is not in the domain of tfb_fbase is "currently unreachable". +A currently-unreachable block is not even analysed. Reason: consider +constant prop and this graph, with entry point L1: + L1: x:=3; goto L4 + L2: x:=4; goto L4 + L4: if x>3 goto L2 else goto L5 +Here L2 is actually unreachable, but if we process it with bottom input fact, +we'll propagate (x=4) to L4, and nuke the otherwise-good rewriting of L4. + +* If a currently-unreachable block is not analysed, then its rewritten + graph will not be accumulated in tfb_rg. And that is good: + unreachable blocks simply do not appear in the output. + +* Note that clients must be careful to provide a fact (even if bottom) + for each entry point. Otherwise useful blocks may be garbage collected. + +* Note that updateFact must set the change-flag if a label goes from + not-in-fbase to in-fbase, even if its fact is bottom. In effect the + real fact lattice is + UNR + bottom + the points above bottom + +* All of this only applies for *forward* fixpoints. For the backward + case we must treat every block as reachable; it might finish with a + 'return', and therefore have no successors, for example. +-} + + +----------------------------------------------------------------------------- +-- The fuel monad +----------------------------------------------------------------------------- + +type Uniques = Int +type Fuel = Int + +newtype FuelMonad a = FM { unFM :: Fuel -> [Label] -> (a, Fuel, [Label]) } + +instance Monad FuelMonad where + return x = FM (\f u -> (x,f,u)) + m >>= k = FM (\f u -> case unFM m f u of (r,f',u') -> unFM (k r) f' u') + +withFuel :: Maybe a -> FuelMonad (Maybe a) +withFuel Nothing = return Nothing +withFuel (Just r) = FM (\f u -> if f==0 then (Nothing, f, u) + else (Just r, f-1, u)) + +getFuel :: FuelMonad Fuel +getFuel = FM (\f u -> (f,f,u)) + +setFuel :: Fuel -> FuelMonad () +setFuel f = FM (\_ u -> ((), f, u)) + +graphOfAGraph :: AGraph node e x -> FuelMonad (Graph node e x) +graphOfAGraph ag = FM (\f ls -> let (g,ls') = ag ls + in (g, f, ls')) + +----------------------------------------------------------------------------- +-- Label, FactBase, LabelSet +----------------------------------------------------------------------------- + +type Label = Int + +mkLabel :: Int -> Label +mkLabel uniq = uniq + +---------------------- +type LabelMap a = M.IntMap a + +---------------------- +type FactBase a = M.IntMap a + +noFacts :: FactBase f +noFacts = M.empty + +mkFactBase :: [(Label, f)] -> FactBase f +mkFactBase prs = M.fromList prs + +unitFact :: Label -> FactBase f -> FactBase f +-- Restrict a fact base to a single fact +unitFact l fb = case M.lookup l fb of + Just f -> M.singleton l f + Nothing -> M.empty + +lookupFact :: FactBase f -> Label -> Maybe f +lookupFact env blk_id = M.lookup blk_id env + +extendFactBase :: FactBase f -> Label -> f -> FactBase f +extendFactBase env blk_id f = M.insert blk_id f env + +unionFactBase :: FactBase f -> FactBase f -> FactBase f +unionFactBase = M.union + +elemFactBase :: Label -> FactBase f -> Bool +elemFactBase = M.member + +factBaseLabels :: FactBase f -> [Label] +factBaseLabels = M.keys + +factBaseList :: FactBase f -> [(Label, f)] +factBaseList = M.toList + +delFromFactBase :: FactBase f -> [(Label,a)] -> FactBase f +delFromFactBase fb blks = foldr (M.delete . fst) fb blks + +---------------------- +type LabelSet = S.IntSet + +emptyLabelSet :: LabelSet +emptyLabelSet = S.empty + +extendLabelSet :: LabelSet -> Label -> LabelSet +extendLabelSet lbls bid = S.insert bid lbls + +elemLabelSet :: Label -> LabelSet -> Bool +elemLabelSet bid lbls = S.member bid lbls + +blockSetElems :: LabelSet -> [Label] +blockSetElems = S.toList + +minusLabelSet :: LabelSet -> LabelSet -> LabelSet +minusLabelSet = S.difference + +unionLabelSet :: LabelSet -> LabelSet -> LabelSet +unionLabelSet = S.union + +mkLabelSet :: [Label] -> LabelSet +mkLabelSet = S.fromList + +---------------------------------------------------------------- +-- +-- Irrelevant distractions follow + +{- + +data OCFlag oc where + IsOpen :: OCFlag O + IsClosed :: OCFlag C + +class IsOC oc where + ocFlag :: OCFlag oc + +instance IsOC O where + ocFlag = IsOpen +instance IsOC C where + ocFlag = IsClosed + +mkIfThenElse :: forall n x. (Edges n, IsOC x) + => (Label -> Label -> n O C) -- The conditional branch instruction + -> (Label -> n C O) -- Make a head node + -> (Label -> n O C) -- Make an unconditional branch + -> Graph n O x -> Graph n O x -- Then and else branches + -> [Label] -- Block supply + -> Graph n O x -- The complete thing +mkIfThenElse mk_cbranch mk_lbl mk_branch then_g else_g (tl:el:jl:_) + = case (ocFlag :: OCFlag x) of + IsOpen -> gUnitOC (mk_cbranch tl el) + `gCat` (mk_lbl_g tl `gCat` then_g `gCat` mk_branch_g jl) + `gCat` (mk_lbl_g el `gCat` else_g `gCat` mk_branch_g jl) + `gCat` (mk_lbl_g jl) + IsClosed -> gUnitOC (mk_cbranch tl el) + `gCat` (mk_lbl_g tl `gCat` then_g) + `gCat` (mk_lbl_g el `gCat` else_g) + where + mk_lbl_g :: Label -> Graph n C O + mk_lbl_g lbl = gUnitCO (mk_lbl lbl) + mk_branch_g :: Label -> Graph n O C + mk_branch_g lbl = gUnitOC (mk_branch lbl) +-} + +type AGraph n e x = [Label] -> (Graph n e x, [Label]) + +withLabels :: Int -> ([Label] -> AGraph n e x) + -> AGraph n e x +withLabels n fn = \ls -> fn (take n ls) (drop n ls) + + +gUnitCO :: n C O -> Graph n C O +gUnitCO n = GMany NothingO BodyEmpty (JustO (BUnit n)) + +gUnitOC :: n O C -> Graph n O C +gUnitOC n = GMany (JustO (BUnit n)) BodyEmpty NothingO + + +bFilter :: forall n. (n O O -> Bool) -> Block n C C -> Block n C C +bFilter keep (BUnit n) = BUnit n +bFilter keep (BCat h t) = bFilterH h (bFilterT t) + where + bFilterH :: Block n C O -> Block n O C -> Block n C C + bFilterH (BUnit n) rest = BUnit n `BCat` rest + bFilterH (h `BCat` m) rest = bFilterH h (bFilterM m rest) + + bFilterT :: Block n O C -> Block n O C + bFilterT (BUnit n) = BUnit n + bFilterT (m `BCat` t) = bFilterM m (bFilterT t) + + bFilterM :: Block n O O -> Block n O C -> Block n O C + bFilterM (BUnit n) rest | keep n = BUnit n `BCat` rest + | otherwise = rest + bFilterM (b1 `BCat` b2) rest = bFilterM b1 (bFilterM b2 rest) diff -Nru ghc-7.0.3/libraries/hoopl/prototypes/Hoopl.hs ghc-7.2.1/libraries/hoopl/prototypes/Hoopl.hs --- ghc-7.0.3/libraries/hoopl/prototypes/Hoopl.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/prototypes/Hoopl.hs 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,459 @@ +{-# OPTIONS_GHC -Wall -fno-warn-incomplete-patterns #-} +-- With GHC 6.10 we get bogus incomplete-pattern warnings +-- It's fine in 6.12 +{-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, + PatternGuards, TypeFamilies #-} + +-- This version uses type families to express the functional dependency +-- between the open/closed-ness of the input graph and the type of the +-- input fact expected for a graph of that shape + +module Hoopl where + +import qualified Data.IntMap as M +import qualified Data.IntSet as S + +----------------------------------------------------------------------------- +-- Graphs +----------------------------------------------------------------------------- + +data ZOpen +data ZClosed + +type O = ZOpen +type C = ZClosed + +-- Blocks are always non-empty +data Block n e x where + BUnit :: n e x -> Block n e x + BCat :: Block n e O -> Block n O x -> Block n e x + +type Blocks n = [Block n C C] + +data Graph n e x where + GNil :: Graph n O O + GUnit :: Block n e x -> Graph n e x + GMany { g_entry :: Block n e C + , g_blocks :: Blocks n + , g_exit :: Exit (Block n) x } :: Graph n e x + + -- Invariant: if g_entry is closed, + -- its BlockId cannot be a target of + -- branches in the blocks + + -- If a graph has a Tail, then that tail is the only + -- exit from the graph, even if the Tail is closed + -- See the definition of successors! + +data Exit thing x where + NoTail :: Exit thing C + Tail :: thing C x -> Exit thing x + +class Edges thing where + blockId :: thing C x -> BlockId + successors :: thing e C -> [BlockId] + +instance Edges n => Edges (Block n) where + blockId (BUnit n) = blockId n + blockId (BCat b _) = blockId b + successors (BUnit n) = successors n + successors (BCat _ b) = successors b + +instance Edges n => Edges (Graph n) where + blockId (GUnit b) = blockId b + blockId (GMany b _ _) = blockId b + successors (GUnit b) = successors b + successors (GMany _ _ (Tail b)) = successors b + successors (GMany b bs NoTail) + = blockSetElems (all_succs `minusBlockSet` all_blk_ids) + where + all_succs = mkBlockSet (successors b ++ concatMap successors bs) + all_blk_ids = mkBlockSet (map blockId bs) + + +gCat :: Graph n e O -> Graph n O x -> Graph n e x +gCat GNil g2 = g2 +gCat g1 GNil = g1 + +gCat (GUnit b1) (GUnit b2) + = GUnit (b1 `BCat` b2) + +gCat (GUnit b) (GMany e bs x) + = GMany (b `BCat` e) bs x + +gCat (GMany e bs (Tail x)) (GUnit b2) + = GMany e bs (Tail (x `BCat` b2)) + +gCat (GMany e1 bs1 (Tail x1)) (GMany e2 bs2 x2) + = GMany e1 (x1 `BCat` e2 : bs1 ++ bs2) x2 + +gCatC :: Graph n e C -> Graph n C x -> Graph n e x +gCatC (GUnit b1) (GUnit b2) = GMany b1 [] (Tail b2) +gCatC (GUnit b1) (GMany e2 bs x2) = GMany b1 (e2:bs) x2 +gCatC (GMany e bs NoTail) (GUnit b2) = GMany e bs (Tail b2) +gCatC (GMany e bs (Tail b1)) (GUnit b2) = GMany e (b1:bs) (Tail b2) +gCatC (GMany e1 bs1 NoTail) (GMany e2 bs2 x2) = GMany e1 (e2 : bs1 ++ bs2) x2 +gCatC (GMany e1 bs1 (Tail x1)) (GMany e2 bs2 x2) = GMany e1 (x1 : e2 : bs1 ++ bs2) x2 + +mkGMany :: Graph n e C -> Blocks n -> Exit (Graph n) x -> Graph n e x +mkGMany e bs x = GMany b_e (bs_e ++ bs ++ bs_x) b_x + where + (b_e, bs_e) = mkHead e + (bs_x, b_x) = mkTail x + +mkHead :: Graph n e C -> (Block n e C, Blocks n) +mkHead (GUnit b) = (b, []) +mkHead (GMany e bs NoTail) = (e, bs) +mkHead (GMany e bs (Tail b)) = (e, b:bs) + +mkTail :: Exit (Graph n) x -> (Blocks n, Exit (Block n) x) +mkTail NoTail = ([], NoTail) +mkTail (Tail (GUnit b)) = ([], Tail b) +mkTail (Tail (GMany e bs x)) = (e:bs, x) + +flattenG :: Graph n C C -> Blocks n +flattenG (GUnit b) = [b] +flattenG (GMany e bs NoTail) = e:bs +flattenG (GMany e bs (Tail x)) = e:x:bs + +forwardBlockList :: Blocks n -> Blocks n +-- This produces a list of blocks in order suitable for forward analysis. +-- ToDo: Do a topological sort to improve convergence rate of fixpoint +-- This will require a (HavingSuccessors l) class constraint +forwardBlockList blks = blks + +----------------------------------------------------------------------------- +-- DataflowLattice +----------------------------------------------------------------------------- + +data DataflowLattice a = DataflowLattice { + fact_name :: String, -- Documentation + fact_bot :: a, -- Lattice bottom element + fact_add_to :: a -> a -> TxRes a, -- Lattice join plus change flag + fact_do_logging :: Bool -- log changes +} + +data ChangeFlag = NoChange | SomeChange +data TxRes a = TxRes ChangeFlag a + +----------------------------------------------------------------------------- +-- The main Hoopl API +----------------------------------------------------------------------------- + +type ForwardTransfers n f + = forall e x. n e x -> InFact e f -> OutFact x f + +type ForwardRewrites n f + = forall e x. n e x -> InFact e f -> Maybe (AGraph n e x) + +type family InFact e f :: * +type instance InFact C f = InFactC f +type instance InFact O f = f + +type family OutFact x f :: * +type instance OutFact C f = OutFactC f +type instance OutFact O f = f + +type InFactC fact = BlockId -> fact +type OutFactC fact = [(BlockId, fact)] + +data AGraph n e x = AGraph -- Stub for now + + +----------------------------------------------------------------------------- +-- TxFactBase: a FactBase with ChangeFlag information +----------------------------------------------------------------------------- + +-- The TxFactBase is an accumulating parameter, threaded through all +-- the analysis/transformation of each block in the g_blocks of a grpah. +-- It carries a ChangeFlag with it, and a set of BlockIds +-- to monitor. Updates to other BlockIds don't affect the ChangeFlag +data TxFactBase n f + = TxFB { tfb_fbase :: FactBase f + + , tfb_cha :: ChangeFlag + , tfb_bids :: BlockSet -- Update change flag iff these blocks change + -- These are BlockIds of the *original* + -- (not transformed) blocks + + , tfb_blks :: Blocks n -- Transformed blocks + } + +factBaseInFacts :: DataflowLattice f -> TxFactBase n f -> InFactC f +factBaseInFacts lattice (TxFB { tfb_fbase = fbase }) + = lookupFact lattice fbase + +factBaseOutFacts :: TxFactBase n f -> OutFactC f +factBaseOutFacts (TxFB { tfb_fbase = fbase, tfb_bids = bids }) + = [ (bid, f) | (bid, f) <- factBaseList fbase + , not (bid `elemBlockSet` bids) ] + -- The successors of the Graph are the the BlockIds for which + -- we hvae facts, that are *not* in the blocks of the graph + +updateFact :: DataflowLattice f -> (BlockId, f) + -> TxFactBase n f -> TxFactBase n f +-- Update a TxFactBase, setting the change flag iff +-- a) the new fact adds information... +-- b) for a block in the BlockSet in the TxFactBase +updateFact lat (bid, new_fact) tx_fb@(TxFB { tfb_fbase = fbase, tfb_bids = bids}) + | NoChange <- cha2 = tx_fb + | bid `elemBlockSet` bids = tx_fb { tfb_fbase = new_fbase, tfb_cha = SomeChange } + | otherwise = tx_fb { tfb_fbase = new_fbase } + where + old_fact = lookupFact lat fbase bid + TxRes cha2 res_fact = fact_add_to lat old_fact new_fact + new_fbase = extendFactBase fbase bid res_fact + +updateFacts :: Edges n + => DataflowLattice f + -> GFT_Block n f + -> Block n C C + -> Trans (TxFactBase n f) (TxFactBase n f) +updateFacts lat (GFT block_trans) blk + tx_fb@(TxFB { tfb_fbase = fbase, tfb_bids = bids, tfb_blks = blks }) + = do { (graph, out_facts) <- block_trans blk (lookupFact lat fbase) + ; let tx_fb' = tx_fb { tfb_bids = extendBlockSet bids (blockId blk) + , tfb_blks = flattenG graph ++ blks } + ; return (foldr (updateFact lat) tx_fb' out_facts) } + +----------------------------------------------------------------------------- +-- The Trans arrow +----------------------------------------------------------------------------- + +type Trans a b = a -> FuelMonad b + -- Transform a into b, with facts of type f + -- Deals with optimsation fuel and unique supply too + +(>>>) :: Trans a b -> Trans b c -> Trans a c +-- Compose two dataflow transfers in sequence +(dft1 >>> dft2) f = do { f1 <- dft1 f; f2 <- dft2 f1; return f2 } + +liftTrans :: (a->b) -> Trans a b +liftTrans f x = return (f x) + +idTrans :: Trans a a +idTrans x = return x + +fixpointTrans :: forall n f. + Trans (TxFactBase n f) (TxFactBase n f) + -> Trans (OutFactC f) (TxFactBase n f) +fixpointTrans tx_fb_trans out_facts + = do { fuel <- getFuel + ; loop fuel (mkFactBase out_facts) } + where + loop :: Fuel -> Trans (FactBase f) (TxFactBase n f) + loop fuel fbase + = do { tx_fb <- tx_fb_trans (TxFB { tfb_fbase = fbase + , tfb_cha = NoChange + , tfb_blks = [] + , tfb_bids = emptyBlockSet }) + ; case tfb_cha tx_fb of + NoChange -> return tx_fb + SomeChange -> do { setFuel fuel; loop fuel (tfb_fbase tx_fb) } } + +----------------------------------------------------------------------------- +-- Transfer functions +----------------------------------------------------------------------------- + +-- Keys to the castle: a generic transfer function for each shape +-- Here's the idea: we start with single-n transfer functions, +-- move to basic-block transfer functions (we have exactly four shapes), +-- then finally to graph transfer functions (which requires iteration). + +newtype GFT thing n f = GFT (GFTR thing n f) +type GFTR thing n f = forall e x. thing e x + -> InFact e f + -> FuelMonad (Graph n e x, OutFact x f) + +type GFT_Node n f = GFT n n f +type GFT_Block n f = GFT (Block n) n f +type GFT_Graph n f = GFT (Graph n) n f +----------------------------------------------------------------------------- + +gftNodeTransfer :: forall n f . ForwardTransfers n f -> GFT_Node n f +-- Lifts ForwardTransfers to GFT_Node; simple transfer only +gftNodeTransfer base_trans = GFT node_trans + where + node_trans :: GFTR n n f + node_trans node f = return (GUnit (BUnit node), base_trans node f) + +gftNodeRewrite :: forall n f. + ForwardTransfers n f + -> ForwardRewrites n f + -> GFT_Graph n f + -> GFT_Node n f +-- Lifts (ForwardTransfers,ForwardRewrites) to GFT_Node; +-- this time we do rewriting as well. +-- The GFT_Graph parameters specifies what to do with the rewritten graph +gftNodeRewrite transfers rewrites (GFT graph_trans) + = GFT node_rewrite + where + node_trans :: GFTR n n f + node_trans node f = return (GUnit (BUnit node), transfers node f) + + node_rewrite :: GFTR n n f + node_rewrite node f + = case rewrites node f of + Nothing -> node_trans node f + Just g -> do { out <- fuelExhausted + ; if out then + node_trans node f + else do { decrementFuel + ; g' <- graphOfAGraph g + ; graph_trans g' f } } + +gftBlock :: forall n f. GFT_Node n f -> GFT_Block n f +-- Lift from nodes to blocks +gftBlock (GFT node_trans) = GFT block_trans + where + block_trans :: GFTR (Block n) n f + block_trans (BUnit node) f = node_trans node f + block_trans (BCat hd mids) f = do { (g1,f1) <- block_trans hd f + ; (g2,f2) <- block_trans mids f1 + ; return (g1 `gCat` g2, f2) } + + +gftGraph :: forall n f. Edges n => DataflowLattice f -> GFT_Block n f -> GFT_Graph n f +-- Lift from blocks to graphs +gftGraph lattice gft_block@(GFT block_trans) = GFT graph_trans + where + graph_trans :: GFTR (Graph n) n f + graph_trans GNil f = return (GNil, f) + graph_trans (GUnit blk) f = block_trans blk f + graph_trans (GMany entry blocks exit) f + = do { (entry', f1) <- block_trans entry f + ; tx_fb <- ft_blocks blocks f1 + ; (exit', f3) <- ft_exit exit tx_fb + ; return (mkGMany entry' (tfb_blks tx_fb) exit', f3) } + + -- It's a bit disgusting that the TxFactBase has to be + -- preserved as far as the Exit block, becaues the TxFactBase + -- is really concerned with the fixpoint calculation + -- But I can't see any other tidy way to compute the + -- LastOutFacts in the NoTail case + ft_exit :: Exit (Block n) x -> Trans (TxFactBase n f) (Exit (Graph n) x, OutFact x f) + ft_exit (Tail blk) f = do { (blk', f1) <- block_trans blk (factBaseInFacts lattice f) + ; return (Tail blk', f1) } + ft_exit NoTail f = return (NoTail, factBaseOutFacts f) + + ft_block_once :: Block n C C -> Trans (TxFactBase n f) (TxFactBase n f) + ft_block_once blk = updateFacts lattice gft_block blk + + ft_blocks_once :: Blocks n -> Trans (TxFactBase n f) (TxFactBase n f) + ft_blocks_once blks = foldr ((>>>) . ft_block_once) idTrans blks + + ft_blocks :: [Block n C C] -> Trans (OutFactC f) (TxFactBase n f) + ft_blocks blocks = fixpointTrans (ft_blocks_once (forwardBlockList blocks)) + +---------------------------------------------------------------- +-- The pièce de resistance: cunning transfer functions +---------------------------------------------------------------- + +pureAnalysis :: Edges n => DataflowLattice f -> ForwardTransfers n f -> GFT_Graph n f +pureAnalysis lattice = gftGraph lattice . gftBlock . gftNodeTransfer + +analyseAndRewrite + :: forall n f. Edges n + => RewritingDepth + -> DataflowLattice f + -> ForwardTransfers n f + -> ForwardRewrites n f + -> GFT_Graph n f + +data RewritingDepth = RewriteShallow | RewriteDeep +-- When a transformation proposes to rewrite a node, +-- you can either ask the system to +-- * "shallow": accept the new graph, analyse it without further rewriting +-- * "deep": recursively analyse-and-rewrite the new graph + +analyseAndRewrite depth lattice transfers rewrites + = gft_graph_cunning + where + gft_graph_base, gft_graph_cunning, gft_graph_recurse :: GFT_Graph n f + + gft_graph_base = gftGraph lattice (gftBlock gft_node_base) + gft_graph_cunning = gftGraph lattice (gftBlock gft_node_cunning) + gft_graph_recurse = case depth of + RewriteShallow -> gft_graph_base + RewriteDeep -> gft_graph_cunning + + gft_node_base, gft_node_cunning :: GFT_Node n f + gft_node_base = gftNodeTransfer transfers + gft_node_cunning = gftNodeRewrite transfers rewrites gft_graph_recurse + +----------------------------------------------------------------------------- +-- The fuel monad +----------------------------------------------------------------------------- + +type Uniques = Int +type Fuel = Int + +newtype FuelMonad a = FM { unFM :: Fuel -> Uniques -> (a, Fuel, Uniques) } + +instance Monad FuelMonad where + return x = FM (\f u -> (x,f,u)) + m >>= k = FM (\f u -> case unFM m f u of (r,f',u') -> unFM (k r) f' u') + +fuelExhausted :: FuelMonad Bool +fuelExhausted = FM (\f u -> (f <= 0, f, u)) + +decrementFuel :: FuelMonad () +decrementFuel = FM (\f u -> ((), f-1, u)) + +getFuel :: FuelMonad Fuel +getFuel = FM (\f u -> (f,f,u)) + +setFuel :: Fuel -> FuelMonad () +setFuel f = FM (\_ u -> ((), f, u)) + +graphOfAGraph :: AGraph node e x -> FuelMonad (Graph node e x) +graphOfAGraph = error "urk" -- Stub + +----------------------------------------------------------------------------- +-- BlockId, BlockEnv, BlockSet +----------------------------------------------------------------------------- + +type BlockId = Int + +mkBlockId :: Int -> BlockId +mkBlockId uniq = uniq + +type FactBase a = M.IntMap a + +mkFactBase :: [(BlockId, f)] -> FactBase f +mkFactBase prs = M.fromList prs + +lookupFact :: DataflowLattice f -> FactBase f -> BlockId -> f +lookupFact lattice env blk_id + = case M.lookup blk_id env of + Just f -> f + Nothing -> fact_bot lattice + +extendFactBase :: FactBase f -> BlockId -> f -> FactBase f +extendFactBase env blk_id f = M.insert blk_id f env + +unionFactBase :: FactBase f -> FactBase f -> FactBase f +unionFactBase = M.union + +factBaseList :: FactBase f -> [(BlockId, f)] +factBaseList env = M.toList env + +type BlockSet = S.IntSet + +emptyBlockSet :: BlockSet +emptyBlockSet = S.empty + +extendBlockSet :: BlockSet -> BlockId -> BlockSet +extendBlockSet bids bid = S.insert bid bids + +elemBlockSet :: BlockId -> BlockSet -> Bool +elemBlockSet bid bids = S.member bid bids + +blockSetElems :: BlockSet -> [BlockId] +blockSetElems = S.toList + +minusBlockSet :: BlockSet -> BlockSet -> BlockSet +minusBlockSet = S.difference + +mkBlockSet :: [BlockId] -> BlockSet +mkBlockSet = S.fromList diff -Nru ghc-7.0.3/libraries/hoopl/prototypes/RG.hs ghc-7.2.1/libraries/hoopl/prototypes/RG.hs --- ghc-7.0.3/libraries/hoopl/prototypes/RG.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/prototypes/RG.hs 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,21 @@ +{-# LANGUAGE GADTs #-} + +module RG +where + +import Data.Maybe + +import Compiler.Hoopl + +------------------------------------------------------------- +-- noodling around + +data MaybeC ex t where + JustC :: t -> MaybeC C t + NothingC :: MaybeC O t + +data ReplacementGraph n e x = Replacement (MaybeC e Label) (Graph n e x) + +theFact :: Fact e f -> MaybeC e Label -> f +theFact f NothingC = f +theFact fb (JustC l) = fromJust $ lookupFact fb l diff -Nru ghc-7.0.3/libraries/hoopl/prototypes/Zipper.hs ghc-7.2.1/libraries/hoopl/prototypes/Zipper.hs --- ghc-7.0.3/libraries/hoopl/prototypes/Zipper.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/prototypes/Zipper.hs 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,90 @@ +{-# LANGUAGE GADTs #-} + +module Compiler.Hoopl.Zipper + ( ZBlock(..), ZGraph, ZBody + , frontBiasBlock, backBiasBlock + ) +where + +import Compiler.Hoopl.Graph + +data ZBlock n e x where + -- nodes + ZFirst :: n C O -> ZBlock n C O + ZMiddle :: n O O -> ZBlock n O O + ZLast :: n O C -> ZBlock n O C + + -- concatenation operations + ZCat :: ZBlock n O O -> ZBlock n O O -> ZBlock n O O -- non-list-like + ZHead :: ZBlock n C O -> n O O -> ZBlock n C O + ZTail :: n O O -> ZBlock n O C -> ZBlock n O C + + ZClosed :: ZBlock n C O -> ZBlock n O C -> ZBlock n C C -- the zipper + +type ZGraph = Graph' ZBlock +type ZBody = Body' ZBlock + +instance Edges n => Edges (ZBlock n) where + entryLabel (ZFirst n) = entryLabel n + entryLabel (ZHead h _) = entryLabel h + entryLabel (ZClosed h _) = entryLabel h + successors (ZLast n) = successors n + successors (ZTail _ t) = successors t + successors (ZClosed _ t) = successors t + + +---------------------------------------------------------------- + +-- | A block is "front biased" if the left child of every +-- concatenation operation is a node, not a general block; a +-- front-biased block is analogous to an ordinary list. If a block is +-- front-biased, then its nodes can be traversed from front to back +-- without general recusion; tail recursion suffices. Not all shapes +-- can be front-biased; a closed/open block is inherently back-biased. + +frontBiasBlock :: ZBlock n e x -> ZBlock n e x +frontBiasBlock b@(ZFirst {}) = b +frontBiasBlock b@(ZMiddle {}) = b +frontBiasBlock b@(ZLast {}) = b +frontBiasBlock b@(ZCat {}) = rotate b + where -- rotate and append ensure every left child of ZCat is ZMiddle + -- provided 2nd argument to append already has this property + rotate :: ZBlock n O O -> ZBlock n O O + append :: ZBlock n O O -> ZBlock n O O -> ZBlock n O O + rotate (ZCat h t) = append h (rotate t) + rotate b@(ZMiddle {}) = b + append b@(ZMiddle {}) t = b `ZCat` t + append (ZCat b1 b2) b3 = b1 `append` (b2 `append` b3) +frontBiasBlock b@(ZHead {}) = b -- back-biased by nature; cannot fix +frontBiasBlock b@(ZTail {}) = b -- statically front-biased +frontBiasBlock (ZClosed h t) = shiftRight h t + where shiftRight :: ZBlock n C O -> ZBlock n O C -> ZBlock n C C + shiftRight (ZHead b1 b2) b3 = shiftRight b1 (ZTail b2 b3) + shiftRight b1@(ZFirst {}) b2 = ZClosed b1 b2 + +-- | A block is "back biased" if the right child of every +-- concatenation operation is a node, not a general block; a +-- back-biased block is analogous to a snoc-list. If a block is +-- back-biased, then its nodes can be traversed from back to back +-- without general recusion; tail recursion suffices. Not all shapes +-- can be back-biased; an open/closed block is inherently front-biased. + +backBiasBlock :: ZBlock n e x -> ZBlock n e x +backBiasBlock b@(ZFirst {}) = b +backBiasBlock b@(ZMiddle {}) = b +backBiasBlock b@(ZLast {}) = b +backBiasBlock b@(ZCat {}) = rotate b + where -- rotate and append ensure every right child of ZCat is ZMiddle + -- provided 1st argument to append already has this property + rotate :: ZBlock n O O -> ZBlock n O O + append :: ZBlock n O O -> ZBlock n O O -> ZBlock n O O + rotate (ZCat h t) = append (rotate h) t + rotate b@(ZMiddle {}) = b + append h b@(ZMiddle {}) = h `ZCat` b + append b1 (ZCat b2 b3) = (b1 `append` b2) `append` b3 +backBiasBlock b@(ZHead {}) = b -- statically back-biased +backBiasBlock b@(ZTail {}) = b -- front-biased by nature; cannot fix +backBiasBlock (ZClosed h t) = shiftLeft h t + where shiftLeft :: ZBlock n C O -> ZBlock n O C -> ZBlock n C C + shiftLeft b1 (ZTail b2 b3) = shiftLeft (ZHead b1 b2) b3 + shiftLeft b1 b2@(ZLast {}) = ZClosed b1 b2 diff -Nru ghc-7.0.3/libraries/hoopl/README ghc-7.2.1/libraries/hoopl/README --- ghc-7.0.3/libraries/hoopl/README 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/README 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,26 @@ +This repository contains things related to + + Hoopl: A Higher-Order OPtimization Library + +** The closest thing we have to a SAMPLE CLIENT is in ./testing ** + +Directory Contents + +paper/ A paper about Hoopl +prototypes/ A sampling of prototypes and early designs +src/ The current official sources to the Cabal package +testing/ Tests, including a sample client. See ./testing/README. + +To build the library, change to the src directory and run + + cabal configure --prefix=$HOME --user # we have no idea what this means + cabal build + cabal install --enable-documentation + +You'll need a Haskell Platform, which should include appropriate +versions of Cabal and GHC. + +To upload to Hackage, + + cabal sdist + cabal upload dist/something.tar.gz diff -Nru ghc-7.0.3/libraries/hoopl/Setup.hs ghc-7.2.1/libraries/hoopl/Setup.hs --- ghc-7.0.3/libraries/hoopl/Setup.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/Setup.hs 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff -Nru ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl/Checkpoint.hs ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl/Checkpoint.hs --- ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl/Checkpoint.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl/Checkpoint.hs 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,17 @@ +{-# LANGUAGE TypeFamilies #-} + +module Compiler.Hoopl.Checkpoint + ( CheckpointMonad(..) + ) +where + +-- | Obeys the following law: +-- for all @m@ +-- @ +-- do { s <- checkpoint; m; restart s } == return () +-- @ +class Monad m => CheckpointMonad m where + type Checkpoint m + checkpoint :: m (Checkpoint m) + restart :: Checkpoint m -> m () + diff -Nru ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl/Collections.hs ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl/Collections.hs --- ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl/Collections.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl/Collections.hs 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,85 @@ +{- Baseclasses for Map-like and Set-like collections inspired by containers. -} + +{-# LANGUAGE TypeFamilies #-} +module Compiler.Hoopl.Collections ( IsSet(..) + , setInsertList, setDeleteList, setUnions + , IsMap(..) + , mapInsertList, mapDeleteList, mapUnions + ) where + +import Data.List (foldl', foldl1') + +class IsSet set where + type ElemOf set + + setNull :: set -> Bool + setSize :: set -> Int + setMember :: ElemOf set -> set -> Bool + + setEmpty :: set + setSingleton :: ElemOf set -> set + setInsert :: ElemOf set -> set -> set + setDelete :: ElemOf set -> set -> set + + setUnion :: set -> set -> set + setDifference :: set -> set -> set + setIntersection :: set -> set -> set + setIsSubsetOf :: set -> set -> Bool + + setFold :: (ElemOf set -> b -> b) -> b -> set -> b + + setElems :: set -> [ElemOf set] + setFromList :: [ElemOf set] -> set + +-- Helper functions for IsSet class +setInsertList :: IsSet set => [ElemOf set] -> set -> set +setInsertList keys set = foldl' (flip setInsert) set keys + +setDeleteList :: IsSet set => [ElemOf set] -> set -> set +setDeleteList keys set = foldl' (flip setDelete) set keys + +setUnions :: IsSet set => [set] -> set +setUnions [] = setEmpty +setUnions sets = foldl1' setUnion sets + + +class IsMap map where + type KeyOf map + + mapNull :: map a -> Bool + mapSize :: map a -> Int + mapMember :: KeyOf map -> map a -> Bool + mapLookup :: KeyOf map -> map a -> Maybe a + mapFindWithDefault :: a -> KeyOf map -> map a -> a + + mapEmpty :: map a + mapSingleton :: KeyOf map -> a -> map a + mapInsert :: KeyOf map -> a -> map a -> map a + mapDelete :: KeyOf map -> map a -> map a + + mapUnion :: map a -> map a -> map a + mapUnionWithKey :: (KeyOf map -> a -> a -> a) -> map a -> map a -> map a + mapDifference :: map a -> map a -> map a + mapIntersection :: map a -> map a -> map a + mapIsSubmapOf :: Eq a => map a -> map a -> Bool + + mapMap :: (a -> b) -> map a -> map b + mapMapWithKey :: (KeyOf map -> a -> b) -> map a -> map b + mapFold :: (a -> b -> b) -> b -> map a -> b + mapFoldWithKey :: (KeyOf map -> a -> b -> b) -> b -> map a -> b + + mapElems :: map a -> [a] + mapKeys :: map a -> [KeyOf map] + mapToList :: map a -> [(KeyOf map, a)] + mapFromList :: [(KeyOf map, a)] -> map a + +-- Helper functions for IsMap class +mapInsertList :: IsMap map => [(KeyOf map, a)] -> map a -> map a +mapInsertList assocs map = foldl' (flip (uncurry mapInsert)) map assocs + +mapDeleteList :: IsMap map => [KeyOf map] -> map a -> map a +mapDeleteList keys map = foldl' (flip mapDelete) map keys + +mapUnions :: IsMap map => [map a] -> map a +mapUnions [] = mapEmpty +mapUnions maps = foldl1' mapUnion maps diff -Nru ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl/Combinators.hs ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl/Combinators.hs --- ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl/Combinators.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl/Combinators.hs 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,232 @@ +{-# LANGUAGE RankNTypes, LiberalTypeSynonyms, ScopedTypeVariables, GADTs #-} + +module Compiler.Hoopl.Combinators + ( thenFwdRw + , deepFwdRw3, deepFwdRw, iterFwdRw + , thenBwdRw + , deepBwdRw3, deepBwdRw, iterBwdRw + , pairFwd, pairBwd, pairLattice + ) + +where + +import Control.Monad +import Data.Maybe + +import Compiler.Hoopl.Collections +import Compiler.Hoopl.Dataflow +import Compiler.Hoopl.Fuel +import Compiler.Hoopl.Graph (Graph, C, O, Shape(..)) +import Compiler.Hoopl.Label + +---------------------------------------------------------------- + +deepFwdRw3 :: FuelMonad m + => (n C O -> f -> m (Maybe (Graph n C O))) + -> (n O O -> f -> m (Maybe (Graph n O O))) + -> (n O C -> f -> m (Maybe (Graph n O C))) + -> (FwdRewrite m n f) +deepFwdRw :: FuelMonad m + => (forall e x . n e x -> f -> m (Maybe (Graph n e x))) -> FwdRewrite m n f +deepFwdRw3 f m l = iterFwdRw $ mkFRewrite3 f m l +deepFwdRw f = deepFwdRw3 f f f + +-- N.B. rw3, rw3', and rw3a are triples of functions. +-- But rw and rw' are single functions. +-- @ start comb1.tex +thenFwdRw :: forall m n f. Monad m + => FwdRewrite m n f + -> FwdRewrite m n f + -> FwdRewrite m n f +-- @ end comb1.tex +thenFwdRw rw3 rw3' = wrapFR2 thenrw rw3 rw3' + where + thenrw :: forall m1 e x t t1. + Monad m1 => + (t -> t1 -> m1 (Maybe (Graph n e x, FwdRewrite m n f))) + -> (t -> t1 -> m1 (Maybe (Graph n e x, FwdRewrite m n f))) + -> t + -> t1 + -> m1 (Maybe (Graph n e x, FwdRewrite m n f)) + thenrw rw rw' n f = rw n f >>= fwdRes + where fwdRes Nothing = rw' n f + fwdRes (Just gr) = return $ Just $ fadd_rw rw3' gr + +-- @ start iterf.tex +iterFwdRw :: forall m n f. Monad m + => FwdRewrite m n f + -> FwdRewrite m n f +-- @ end iterf.tex +iterFwdRw rw3 = wrapFR iter rw3 + where iter :: forall a m1 m2 e x t. + (Monad m2, Monad m1) => + (t -> a -> m1 (m2 (Graph n e x, FwdRewrite m n f))) + -> t + -> a + -> m1 (m2 (Graph n e x, FwdRewrite m n f)) + iter rw n = (liftM $ liftM $ fadd_rw (iterFwdRw rw3)) . rw n + +-- | Function inspired by 'rew' in the paper +_frewrite_cps :: Monad m + => ((Graph n e x, FwdRewrite m n f) -> m a) + -> m a + -> (forall e x . n e x -> f -> m (Maybe (Graph n e x, FwdRewrite m n f))) + -> n e x + -> f + -> m a +_frewrite_cps j n rw node f = + do mg <- rw node f + case mg of Nothing -> n + Just gr -> j gr + + + +-- | Function inspired by 'add' in the paper +fadd_rw :: Monad m + => FwdRewrite m n f + -> (Graph n e x, FwdRewrite m n f) + -> (Graph n e x, FwdRewrite m n f) +fadd_rw rw2 (g, rw1) = (g, rw1 `thenFwdRw` rw2) + +---------------------------------------------------------------- + +deepBwdRw3 :: FuelMonad m + => (n C O -> f -> m (Maybe (Graph n C O))) + -> (n O O -> f -> m (Maybe (Graph n O O))) + -> (n O C -> FactBase f -> m (Maybe (Graph n O C))) + -> (BwdRewrite m n f) +deepBwdRw :: FuelMonad m + => (forall e x . n e x -> Fact x f -> m (Maybe (Graph n e x))) + -> BwdRewrite m n f +deepBwdRw3 f m l = iterBwdRw $ mkBRewrite3 f m l +deepBwdRw f = deepBwdRw3 f f f + + +thenBwdRw :: forall m n f. Monad m => BwdRewrite m n f -> BwdRewrite m n f -> BwdRewrite m n f +thenBwdRw rw1 rw2 = wrapBR2 f rw1 rw2 + where f :: forall t t1 t2 m1 e x. + Monad m1 => + t + -> (t1 -> t2 -> m1 (Maybe (Graph n e x, BwdRewrite m n f))) + -> (t1 -> t2 -> m1 (Maybe (Graph n e x, BwdRewrite m n f))) + -> t1 + -> t2 + -> m1 (Maybe (Graph n e x, BwdRewrite m n f)) + f _ rw1 rw2' n f = do + res1 <- rw1 n f + case res1 of + Nothing -> rw2' n f + Just gr -> return $ Just $ badd_rw rw2 gr + +iterBwdRw :: forall m n f. Monad m => BwdRewrite m n f -> BwdRewrite m n f +iterBwdRw rw = wrapBR f rw + where f :: forall t m1 m2 e x t1 t2. + (Monad m2, Monad m1) => + t + -> (t1 -> t2 -> m1 (m2 (Graph n e x, BwdRewrite m n f))) + -> t1 + -> t2 + -> m1 (m2 (Graph n e x, BwdRewrite m n f)) + f _ rw' n f = liftM (liftM (badd_rw (iterBwdRw rw))) (rw' n f) + +-- | Function inspired by 'add' in the paper +badd_rw :: Monad m + => BwdRewrite m n f + -> (Graph n e x, BwdRewrite m n f) + -> (Graph n e x, BwdRewrite m n f) +badd_rw rw2 (g, rw1) = (g, rw1 `thenBwdRw` rw2) + + +-- @ start pairf.tex +pairFwd :: forall m n f f'. Monad m + => FwdPass m n f + -> FwdPass m n f' + -> FwdPass m n (f, f') +-- @ end pairf.tex +pairFwd pass1 pass2 = FwdPass lattice transfer rewrite + where + lattice = pairLattice (fp_lattice pass1) (fp_lattice pass2) + transfer = mkFTransfer3 (tf tf1 tf2) (tf tm1 tm2) (tfb tl1 tl2) + where + tf :: forall t t1 t2 t3 t4. + (t4 -> t -> t2) -> (t4 -> t1 -> t3) -> t4 -> (t, t1) -> (t2, t3) + tf t1 t2 n (f1, f2) = (t1 n f1, t2 n f2) + tfb t1 t2 n (f1, f2) = mapMapWithKey withfb2 fb1 + where fb1 = t1 n f1 + fb2 = t2 n f2 + withfb2 :: forall t. Label -> t -> (t, f') + withfb2 l f = (f, fromMaybe bot2 $ lookupFact l fb2) + bot2 = fact_bot (fp_lattice pass2) + (tf1, tm1, tl1) = getFTransfer3 (fp_transfer pass1) + (tf2, tm2, tl2) = getFTransfer3 (fp_transfer pass2) + rewrite = lift fst (fp_rewrite pass1) `thenFwdRw` lift snd (fp_rewrite pass2) + where + lift :: forall f m' n' f'. + Monad m' => + (f' -> f) -> FwdRewrite m' n' f -> FwdRewrite m' n' f' + lift proj = wrapFR project + where project :: forall m m1 t t1. + (Monad m1, Monad m) => + (t1 -> f -> m (m1 (t, FwdRewrite m' n' f))) + -> t1 + -> f' + -> m (m1 (t, FwdRewrite m' n' f')) + project rw = \n pair -> liftM (liftM repair) $ rw n (proj pair) + repair :: forall t. + (t, FwdRewrite m' n' f) -> (t, FwdRewrite m' n' f') + repair (g, rw') = (g, lift proj rw') + +pairBwd :: forall m n f f' . + Monad m => BwdPass m n f -> BwdPass m n f' -> BwdPass m n (f, f') +pairBwd pass1 pass2 = BwdPass lattice transfer rewrite + where + lattice = pairLattice (bp_lattice pass1) (bp_lattice pass2) + transfer = mkBTransfer3 (tf tf1 tf2) (tf tm1 tm2) (tfb tl1 tl2) + where + tf :: (t4 -> t -> t2) -> (t4 -> t1 -> t3) -> t4 -> (t, t1) -> (t2, t3) + tf t1 t2 n (f1, f2) = (t1 n f1, t2 n f2) + tfb :: IsMap map => + (t2 -> map a -> t) + -> (t2 -> map b -> t1) + -> t2 + -> map (a, b) + -> (t, t1) + tfb t1 t2 n fb = (t1 n $ mapMap fst fb, t2 n $ mapMap snd fb) + (tf1, tm1, tl1) = getBTransfer3 (bp_transfer pass1) + (tf2, tm2, tl2) = getBTransfer3 (bp_transfer pass2) + rewrite = lift fst (bp_rewrite pass1) `thenBwdRw` lift snd (bp_rewrite pass2) + where + lift :: forall f1 . + ((f, f') -> f1) -> BwdRewrite m n f1 -> BwdRewrite m n (f, f') + lift proj = wrapBR project + where project :: forall e x . Shape x + -> (n e x -> + Fact x f1 -> m (Maybe (Graph n e x, BwdRewrite m n f1))) + -> (n e x -> + Fact x (f,f') -> m (Maybe (Graph n e x, BwdRewrite m n (f,f')))) + project Open = + \rw n pair -> liftM (liftM repair) $ rw n ( proj pair) + project Closed = + \rw n pair -> liftM (liftM repair) $ rw n (mapMap proj pair) + repair :: forall t. + (t, BwdRewrite m n f1) -> (t, BwdRewrite m n (f, f')) + repair (g, rw') = (g, lift proj rw') + -- XXX specialize repair so that the cost + -- of discriminating is one per combinator not one + -- per rewrite + +pairLattice :: forall f f' . + DataflowLattice f -> DataflowLattice f' -> DataflowLattice (f, f') +pairLattice l1 l2 = + DataflowLattice + { fact_name = fact_name l1 ++ " x " ++ fact_name l2 + , fact_bot = (fact_bot l1, fact_bot l2) + , fact_join = join + } + where + join lbl (OldFact (o1, o2)) (NewFact (n1, n2)) = (c', (f1, f2)) + where (c1, f1) = fact_join l1 lbl (OldFact o1) (NewFact n1) + (c2, f2) = fact_join l2 lbl (OldFact o2) (NewFact n2) + c' = case (c1, c2) of + (NoChange, NoChange) -> NoChange + _ -> SomeChange diff -Nru ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl/DataflowFold.hs ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl/DataflowFold.hs --- ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl/DataflowFold.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl/DataflowFold.hs 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,710 @@ +{-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies, MultiParamTypeClasses #-} + +{- Notes about the genesis of Hoopl7 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Hoopl7 has the following major chages + +a) GMany has symmetric entry and exit +b) GMany closed-entry does not record a BlockId +c) GMany open-exit does not record a BlockId +d) The body of a GMany is called Body +e) A Body is just a list of blocks, not a map. I've argued + elsewhere that this is consistent with (c) + +A consequence is that Graph is no longer an instance of NonLocal, +but nevertheless I managed to keep the ARF and ARB signatures +nice and uniform. + +This was made possible by + +* FwdTransfer looks like this: + type FwdTransfer n f + = forall e x. n e x -> Fact e f -> Fact x f + type family Fact x f :: * + type instance Fact C f = FactBase f + type instance Fact O f = f + + Note that the incoming fact is a Fact (not just 'f' as in Hoopl5,6). + It's up to the *transfer function* to look up the appropriate fact + in the FactBase for a closed-entry node. Example: + constProp (Label l) fb = lookupFact fb l + That is how Hoopl can avoid having to know the block-id for the + first node: it defers to the client. + + [Side note: that means the client must know about + bottom, in case the looupFact returns Nothing] + +* Note also that FwdTransfer *returns* a Fact too; + that is, the types in both directions are symmetrical. + Previously we returned a [(BlockId,f)] but I could not see + how to make everything line up if we do this. + + Indeed, the main shortcoming of Hoopl7 is that we are more + or less forced into this uniform representation of the facts + flowing into or out of a closed node/block/graph, whereas + previously we had more flexibility. + + In exchange the code is neater, with fewer distinct types. + And morally a FactBase is equivalent to [(BlockId,f)] and + nearly equivalent to (BlockId -> f). + +* I've realised that forwardBlockList and backwardBlockList + both need (NonLocal n), and that goes everywhere. + +* I renamed BlockId to Label +-} + +module Compiler.Hoopl.DataflowFold + ( DataflowLattice(..), JoinFun, OldFact(..), NewFact(..), Fact + , ChangeFlag(..), changeIf + , FwdPass(..), FwdTransfer, mkFTransfer, mkFTransfer', getFTransfers + , FwdRes(..), FwdRewrite, mkFRewrite, mkFRewrite', getFRewrites + , BwdPass(..), BwdTransfer, mkBTransfer, mkBTransfer', getBTransfers + , BwdRes(..), BwdRewrite, mkBRewrite, mkBRewrite', getBRewrites + , analyzeAndRewriteFwd, analyzeAndRewriteBwd + ) +where + +import Data.Maybe + +import Compiler.Hoopl.Fuel +import Compiler.Hoopl.Graph +import Compiler.Hoopl.MkGraph +import qualified Compiler.Hoopl.GraphUtil as U +import Compiler.Hoopl.Label +import Compiler.Hoopl.Util + +----------------------------------------------------------------------------- +-- DataflowLattice +----------------------------------------------------------------------------- + +data DataflowLattice a = DataflowLattice + { fact_name :: String -- Documentation + , fact_bot :: a -- Lattice bottom element + , fact_join :: JoinFun a -- Lattice join plus change flag + -- (changes iff result > old fact) + } +-- ^ A transfer function might want to use the logging flag +-- to control debugging, as in for example, it updates just one element +-- in a big finite map. We don't want Hoopl to show the whole fact, +-- and only the transfer function knows exactly what changed. + +type JoinFun a = Label -> OldFact a -> NewFact a -> (ChangeFlag, a) + -- the label argument is for debugging purposes only +newtype OldFact a = OldFact a +newtype NewFact a = NewFact a + +data ChangeFlag = NoChange | SomeChange deriving (Eq, Ord) +changeIf :: Bool -> ChangeFlag +changeIf changed = if changed then SomeChange else NoChange + + +----------------------------------------------------------------------------- +-- Analyze and rewrite forward: the interface +----------------------------------------------------------------------------- + +data FwdPass n f + = FwdPass { fp_lattice :: DataflowLattice f + , fp_transfer :: FwdTransfer n f + , fp_rewrite :: FwdRewrite n f } + +newtype FwdTransfer n f + = FwdTransfers { getFTransfers :: + ( n C O -> f -> f + , n O O -> f -> f + , n O C -> f -> FactBase f + ) } + +newtype FwdRewrite n f + = FwdRewrites { getFRewrites :: + ( n C O -> f -> Maybe (FwdRes n f C O) + , n O O -> f -> Maybe (FwdRes n f O O) + , n O C -> f -> Maybe (FwdRes n f O C) + ) } +data FwdRes n f e x = FwdRes (AGraph n e x) (FwdRewrite n f) + -- result of a rewrite is a new graph and a (possibly) new rewrite function + +mkFTransfer :: (n C O -> f -> f) + -> (n O O -> f -> f) + -> (n O C -> f -> FactBase f) + -> FwdTransfer n f +mkFTransfer f m l = FwdTransfers (f, m, l) + +mkFTransfer' :: (forall e x . n e x -> f -> Fact x f) -> FwdTransfer n f +mkFTransfer' f = FwdTransfers (f, f, f) + +mkFRewrite :: (n C O -> f -> Maybe (FwdRes n f C O)) + -> (n O O -> f -> Maybe (FwdRes n f O O)) + -> (n O C -> f -> Maybe (FwdRes n f O C)) + -> FwdRewrite n f +mkFRewrite f m l = FwdRewrites (f, m, l) + +mkFRewrite' :: (forall e x . n e x -> f -> Maybe (FwdRes n f e x)) -> FwdRewrite n f +mkFRewrite' f = FwdRewrites (f, f, f) + + +type family Fact x f :: * +type instance Fact C f = FactBase f +type instance Fact O f = f + +-- | if the graph being analyzed is open at the entry, there must +-- be no other entry point, or all goes horribly wrong... +analyzeAndRewriteFwd + :: forall n f e x entries. (NonLocal n, LabelsPtr entries) + => FwdPass n f + -> MaybeC e entries + -> Graph n e x -> Fact e f + -> FuelMonad (Graph n e x, FactBase f, MaybeO x f) +analyzeAndRewriteFwd pass entries g f = + do (rg, fout) <- arfGraph pass (nilBefore g) (fmap targetLabels entries) g f + let (g', fb) = normalizeGraph rg + return (g', fb, distinguishedExitFact g' fout) + where nilBefore (GMany NothingO _ _) = rgnilC + nilBefore (GMany (JustO _) _ _) = rgnil + nilBefore GNil = rgnil + nilBefore (GUnit _) = rgnil + nilBefore :: Graph n e x -> RG f n e e + +distinguishedExitFact :: forall n e x f . Graph n e x -> Fact x f -> MaybeO x f +distinguishedExitFact g f = maybe g + where maybe :: Graph n e x -> MaybeO x f + maybe GNil = JustO f + maybe (GUnit {}) = JustO f + maybe (GMany _ _ x) = case x of NothingO -> NothingO + JustO _ -> JustO f + +---------------------------------------------------------------- +-- Forward Implementation +---------------------------------------------------------------- + + +type FM = FuelMonad + +type Entries e = MaybeC e [Label] + +type RGPair f n e x = (RG f n e x, Fact x f) + + +arfGraph :: forall n f e a x . + (NonLocal n) + => FwdPass n f + -> RG f n e a + -> Entries a -> Graph n a x -> Fact a f -> FM (RG f n e x, Fact x f) +arfGraph pass head entries g f = graph g (head, f) + where + graph :: Graph n a x -> RGPair f n e a -> FM (RGPair f n e x) + block :: forall e a x . Block n a x -> (RG f n e a, f) -> FM (RGPair f n e x) + node :: forall e a x . (ShapeLifter a x) + => n a x -> (RG f n e a, f) -> FM (RGPair f n e x) + body :: forall e . [Label] -> Body n -> (RGPair f n e C) -> FM (RGPair f n e C) + -- Outgoing factbase is restricted to Labels *not* in + -- in the Body; the facts for Labels *in* + -- the Body are in the 'RG f n C C' + + cat :: forall e a b x info info' info''. + ((RG f n e a, info) -> FuelMonad (RG f n e b, info')) + -> ((RG f n e b, info') -> FuelMonad (RG f n e x, info'')) + -> ((RG f n e a, info) -> FuelMonad (RG f n e x, info'')) + + cat ft1 ft2 (g, f) = ft1 (g, f) >>= ft2 + + graph GNil = return + graph (GUnit blk) = block blk + graph (GMany e bdy x) = eb e bdy `cat` exit x + where + eb :: MaybeO a (Block n O C) -> Body n -> (RGPair f n e a) -> FM (RGPair f n e C) + exit :: MaybeO x (Block n C O) -> (RGPair f n e C) -> FM (RGPair f n e x) + exit (JustO blk) = arfx block blk + exit NothingO = return + eb entry bdy = c entries entry + where c :: MaybeC a [Label] -> MaybeO a (Block n O C) + -> (RGPair f n e a) -> FM (RGPair f n e C) + c NothingC (JustO entry) = block entry `cat` body (successors entry) bdy + c (JustC entries) NothingO = body entries bdy + + -- Lift from nodes to blocks + block (BFirst n) = node n + block (BMiddle n) = node n + block (BLast n) = node n + block (BCat b1 b2) = block b1 `cat` block b2 + block (BHead h n) = block h `cat` node n + block (BTail n t) = node n `cat` block t + block (BClosed h t)= block h `cat` block t + + node thenode (head, f) + = do { mb_g <- withFuel (frewrite pass thenode f) + ; case mb_g of + Nothing -> return (spliceRgNode head f thenode, + ftransfer pass thenode f) + Just (FwdRes ag rw) -> + do { g <- graphOfAGraph ag + ; let pass' = pass { fp_rewrite = rw } + ; arfGraph pass' head (entry thenode) g (elift thenode f) } } + + -- | Compose fact transformers and concatenate the resulting + -- rewritten graphs. + {-# INLINE cat #-} + + arfx :: forall thing e x . + NonLocal thing + => (thing C x -> (RG f n e C, f) -> FM (RGPair f n e x)) + -> (thing C x -> (RG f n e C, Fact C f) -> FM (RGPair f n e x)) + arfx arf thing (h, fb) = + arf thing (h, fromJust $ lookupFact (joinInFacts lattice fb) $ entryLabel thing) + where lattice = fp_lattice pass + -- joinInFacts adds debugging information + + + -- Outgoing factbase is restricted to Labels *not* in + -- in the Body; the facts for Labels *in* + -- the Body are in the 'RG f n C C' + body entries blocks (h, init_fbase) + = do { (body', fb) <- fix; return (h `rgCat` body', fb) } + where + fix = fixpoint True (fp_lattice pass) do_block init_fbase $ + forwardBlockList entries blocks + do_block b f = do (g, fb) <- block b (rgnilC, lookupF pass (entryLabel b) f) + return (g, factBaseList fb) + + +-- Join all the incoming facts with bottom. +-- We know the results _shouldn't change_, but the transfer +-- functions might, for example, generate some debugging traces. +joinInFacts :: DataflowLattice f -> FactBase f -> FactBase f +joinInFacts (DataflowLattice {fact_bot = bot, fact_join = fj}) fb = + mkFactBase $ map botJoin $ factBaseList fb + where botJoin (l, f) = (l, snd $ fj l (OldFact bot) (NewFact f)) + + +forwardBlockList :: (NonLocal n, LabelsPtr entry) + => entry -> Body n -> [Block n C C] +-- This produces a list of blocks in order suitable for forward analysis, +-- along with the list of Labels it may depend on for facts. +forwardBlockList entries (Body blks) = postorder_dfs_from blks entries + +----------------------------------------------------------------------------- +-- Backward analysis and rewriting: the interface +----------------------------------------------------------------------------- + +data BwdPass n f + = BwdPass { bp_lattice :: DataflowLattice f + , bp_transfer :: BwdTransfer n f + , bp_rewrite :: BwdRewrite n f } + +newtype BwdTransfer n f + = BwdTransfers { getBTransfers :: + ( n C O -> f -> f + , n O O -> f -> f + , n O C -> FactBase f -> f + ) } +newtype BwdRewrite n f + = BwdRewrites { getBRewrites :: + ( n C O -> f -> Maybe (BwdRes n f C O) + , n O O -> f -> Maybe (BwdRes n f O O) + , n O C -> FactBase f -> Maybe (BwdRes n f O C) + ) } +data BwdRes n f e x = BwdRes (AGraph n e x) (BwdRewrite n f) + +mkBTransfer :: (n C O -> f -> f) -> (n O O -> f -> f) -> + (n O C -> FactBase f -> f) -> BwdTransfer n f +mkBTransfer f m l = BwdTransfers (f, m, l) + +mkBTransfer' :: (forall e x . n e x -> Fact x f -> f) -> BwdTransfer n f +mkBTransfer' f = BwdTransfers (f, f, f) + +mkBRewrite :: (n C O -> f -> Maybe (BwdRes n f C O)) + -> (n O O -> f -> Maybe (BwdRes n f O O)) + -> (n O C -> FactBase f -> Maybe (BwdRes n f O C)) + -> BwdRewrite n f +mkBRewrite f m l = BwdRewrites (f, m, l) + +mkBRewrite' :: (forall e x . n e x -> Fact x f -> Maybe (BwdRes n f e x)) -> BwdRewrite n f +mkBRewrite' f = BwdRewrites (f, f, f) + + +----------------------------------------------------------------------------- +-- Backward implementation +----------------------------------------------------------------------------- + +type ARB' n f thing e x + = BwdPass n f -> thing e x -> Fact x f -> FuelMonad (RG f n e x, f) + +type ARB thing n = forall f e x. ARB' n f thing e x + +arbNode :: (NonLocal n, ShapeLifter e x) => ARB' n f n e x +-- Lifts (BwdTransfer,BwdRewrite) to ARB_Node; +-- this time we do rewriting as well. +-- The ARB_Graph parameters specifies what to do with the rewritten graph +arbNode pass node f + = do { mb_g <- withFuel (brewrite pass node f) + ; case mb_g of + Nothing -> return (rgunit entry_f (unit node), entry_f) + where entry_f = btransfer pass node f + Just (BwdRes ag rw) -> do { g <- graphOfAGraph ag + ; let pass' = pass { bp_rewrite = rw } + ; (g, f) <- arbGraph pass' g f + ; return (g, elower (bp_lattice pass) node f)} } + +arbBlock :: NonLocal n => ARB (Block n) n +-- Lift from nodes to blocks +arbBlock pass (BFirst node) = arbNode pass node +arbBlock pass (BMiddle node) = arbNode pass node +arbBlock pass (BLast node) = arbNode pass node +arbBlock pass (BCat b1 b2) = arbCat arbBlock arbBlock pass b1 b2 +arbBlock pass (BHead h n) = arbCat arbBlock arbNode pass h n +arbBlock pass (BTail n t) = arbCat arbNode arbBlock pass n t +arbBlock pass (BClosed h t) = arbCat arbBlock arbBlock pass h t + +arbCat :: NonLocal n => ARB' n f thing1 e O -> ARB' n f thing2 O x + -> BwdPass n f -> thing1 e O -> thing2 O x + -> Fact x f -> FuelMonad (RG f n e x, f) +arbCat arb1 arb2 pass thing1 thing2 f = do { (g2,f2) <- arb2 pass thing2 f + ; (g1,f1) <- arb1 pass thing1 f2 + ; return (g1 `rgCat` g2, f1) } + +arbBody :: NonLocal n + => BwdPass n f -> Body n -> FactBase f + -> FuelMonad (RG f n C C, FactBase f) +arbBody pass blocks init_fbase + = fixpoint False (bp_lattice pass) do_block init_fbase $ + backwardBlockList blocks + where + do_block b f = do (g, f) <- arbBlock pass b f + return (g, [(entryLabel b, f)]) + +arbGraph :: NonLocal n + => BwdPass n f -> Graph n e x -> Fact x f + -> FuelMonad (RG f n e x, Fact e f) +arbGraph _ GNil f = return (rgnil, f) +arbGraph pass (GUnit blk) f = arbBlock pass blk f +arbGraph pass (GMany NothingO body NothingO) f + = do { (body', fb) <- arbBody pass body f + ; return (body', fb) } +arbGraph pass (GMany NothingO body (JustO exit)) f + = do { (exit', fx) <- arbBlock pass exit f + ; (body', fb) <- arbBody pass body $ + joinInFacts (bp_lattice pass) $ mkFactBase [(entryLabel exit, fx)] + ; return (body' `rgCat` exit', fb) } +arbGraph pass (GMany (JustO entry) body NothingO) f + = do { (body', fb) <- arbBody pass body f + ; (entry', fe) <- arbBlock pass entry fb + ; return (entry' `rgCat` body', fe) } +arbGraph pass (GMany (JustO entry) body (JustO exit)) f + = do { (exit', fx) <- arbBlock pass exit f + ; (body', fb) <- arbBody pass body $ + joinInFacts (bp_lattice pass) $ mkFactBase [(entryLabel exit, fx)] + ; (entry', fe) <- arbBlock pass entry fb + ; return (entry' `rgCat` body' `rgCat` exit', fe) } + +backwardBlockList :: NonLocal n => Body n -> [Block n C C] +-- This produces a list of blocks in order suitable for backward analysis, +-- along with the list of Labels it may depend on for facts. +backwardBlockList body = reachable ++ missing + where reachable = reverse $ forwardBlockList entries body + entries = externalEntryLabels body + all = bodyList body + missingLabels = + mkLabelSet (map fst all) `minusLabelSet` + mkLabelSet (map entryLabel reachable) + missing = map snd $ filter (flip elemLabelSet missingLabels . fst) all + +{- + +The forward and backward dataflow analyses now use postorder depth-first +order for faster convergence. + +The forward and backward cases are not dual. In the forward case, the +entry points are known, and one simply traverses the body blocks from +those points. In the backward case, something is known about the exit +points, but this information is essentially useless, because we don't +actually have a dual graph (that is, one with edges reversed) to +compute with. (Even if we did have a dual graph, it would not avail +us---a backward analysis must include reachable blocks that don't +reach the exit, as in a procedure that loops forever and has side +effects.) + +Since in the general case, no information is available about entry +points, I have put in a horrible hack. First, I assume that every +label defined but not used is an entry point. Then, because an entry +point might also be a loop header, I add, in arbitrary order, all the +remaining "missing" blocks. Needless to say, I am not pleased. +I am not satisfied. I am not Senator Morgan. + +Wait! I believe that the Right Thing here is to require that anyone +wishing to analyze a graph closed at the entry provide a way of +determining the entry points, if any, of that graph. This requirement +can apply equally to forward and backward analyses; I believe that +using the input FactBase to determine the entry points of a closed +graph is *also* a hack. + +NR + +-} + + +-- | if the graph being analyzed is open at the exit, I don't +-- quite understand the implications of possible other exits +analyzeAndRewriteBwd + :: forall n f e x. NonLocal n + => BwdPass n f + -> Graph n e x -> Fact x f + -> FuelMonad (Graph n e x, FactBase f, MaybeO e f) +analyzeAndRewriteBwd pass g f = + do (rg, fout) <- arbGraph pass g f + let (g', fb) = normalizeGraph rg + return (g', fb, distinguishedEntryFact g' fout) + +distinguishedEntryFact :: forall n e x f . Graph n e x -> Fact e f -> MaybeO e f +distinguishedEntryFact g f = maybe g + where maybe :: Graph n e x -> MaybeO e f + maybe GNil = JustO f + maybe (GUnit {}) = JustO f + maybe (GMany e _ _) = case e of NothingO -> NothingO + JustO _ -> JustO f + +----------------------------------------------------------------------------- +-- fixpoint: finding fixed points +----------------------------------------------------------------------------- + +data TxFactBase n f + = TxFB { tfb_fbase :: FactBase f + , tfb_rg :: RG f n C C -- Transformed blocks + , tfb_cha :: ChangeFlag + , tfb_lbls :: LabelSet } + -- Note [TxFactBase change flag] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- Set the tfb_cha flag iff + -- (a) the fact in tfb_fbase for or a block L changes + -- (b) L is in tfb_lbls. + -- The tfb_lbls are all Labels of the *original* + -- (not transformed) blocks + +updateFact :: DataflowLattice f -> LabelSet -> (Label, f) + -> (ChangeFlag, FactBase f) + -> (ChangeFlag, FactBase f) +-- See Note [TxFactBase change flag] +updateFact lat lbls (lbl, new_fact) (cha, fbase) + | NoChange <- cha2 = (cha, fbase) + | lbl `elemLabelSet` lbls = (SomeChange, new_fbase) + | otherwise = (cha, new_fbase) + where + (cha2, res_fact) -- Note [Unreachable blocks] + = case lookupFact fbase lbl of + Nothing -> (SomeChange, snd $ join $ fact_bot lat) -- Note [Unreachable blocks] + Just old_fact -> join old_fact + where join old_fact = fact_join lat lbl (OldFact old_fact) (NewFact new_fact) + new_fbase = extendFactBase fbase lbl res_fact + +fixpoint :: forall block n f. (NonLocal n, NonLocal (block n)) + => Bool -- Going forwards? + -> DataflowLattice f + -> (block n C C -> FactBase f + -> FuelMonad (RG f n C C, [(Label, f)])) + -> FactBase f + -> [block n C C] + -> FuelMonad (RG f n C C, FactBase f) +fixpoint is_fwd lat do_block init_fbase untagged_blocks + = do { fuel <- getFuel + ; tx_fb <- loop fuel init_fbase + ; return (tfb_rg tx_fb, + tfb_fbase tx_fb `delFromFactBase` map fst blocks) } + -- The successors of the Graph are the the Labels for which + -- we have facts, that are *not* in the blocks of the graph + where + blocks = map tag untagged_blocks + where tag b = ((entryLabel b, b), if is_fwd then [entryLabel b] else successors b) + + tx_blocks :: [((Label, block n C C), [Label])] -- I do not understand this type + -> TxFactBase n f -> FuelMonad (TxFactBase n f) + tx_blocks [] tx_fb = return tx_fb + tx_blocks (((lbl,blk), deps):bs) tx_fb = tx_block lbl blk deps tx_fb >>= tx_blocks bs + -- "deps" == Labels the block may _depend_ upon for facts + + tx_block :: Label -> block n C C -> [Label] + -> TxFactBase n f -> FuelMonad (TxFactBase n f) + tx_block lbl blk deps tx_fb@(TxFB { tfb_fbase = fbase, tfb_lbls = lbls + , tfb_rg = blks, tfb_cha = cha }) + | is_fwd && not (lbl `elemFactBase` fbase) + = return tx_fb {tfb_lbls = lbls `unionLabelSet` mkLabelSet deps} -- Note [Unreachable blocks] + | otherwise + = do { (rg, out_facts) <- do_block blk fbase + ; let (cha',fbase') + = foldr (updateFact lat lbls) (cha,fbase) out_facts + lbls' = lbls `unionLabelSet` mkLabelSet deps + ; return (TxFB { tfb_lbls = lbls' + , tfb_rg = rg `rgCat` blks + , tfb_fbase = fbase', tfb_cha = cha' }) } + + loop :: Fuel -> FactBase f -> FuelMonad (TxFactBase n f) + loop fuel fbase + = do { let init_tx_fb = TxFB { tfb_fbase = fbase + , tfb_cha = NoChange + , tfb_rg = rgnilC + , tfb_lbls = emptyLabelSet } + ; tx_fb <- tx_blocks blocks init_tx_fb + ; case tfb_cha tx_fb of + NoChange -> return tx_fb + SomeChange -> do { setFuel fuel + ; loop fuel (tfb_fbase tx_fb) } } + +{- Note [Unreachable blocks] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A block that is not in the domain of tfb_fbase is "currently unreachable". +A currently-unreachable block is not even analyzed. Reason: consider +constant prop and this graph, with entry point L1: + L1: x:=3; goto L4 + L2: x:=4; goto L4 + L4: if x>3 goto L2 else goto L5 +Here L2 is actually unreachable, but if we process it with bottom input fact, +we'll propagate (x=4) to L4, and nuke the otherwise-good rewriting of L4. + +* If a currently-unreachable block is not analyzed, then its rewritten + graph will not be accumulated in tfb_rg. And that is good: + unreachable blocks simply do not appear in the output. + +* Note that clients must be careful to provide a fact (even if bottom) + for each entry point. Otherwise useful blocks may be garbage collected. + +* Note that updateFact must set the change-flag if a label goes from + not-in-fbase to in-fbase, even if its fact is bottom. In effect the + real fact lattice is + UNR + bottom + the points above bottom + +* Even if the fact is going from UNR to bottom, we still call the + client's fact_join function because it might give the client + some useful debugging information. + +* All of this only applies for *forward* fixpoints. For the backward + case we must treat every block as reachable; it might finish with a + 'return', and therefore have no successors, for example. +-} + +----------------------------------------------------------------------------- +-- RG: an internal data type for graphs under construction +-- TOTALLY internal to Hoopl; each block carries its fact +----------------------------------------------------------------------------- + +type RG f n e x = Graph' (FBlock f) n e x +data FBlock f n e x = FBlock f (Block n e x) +instance NonLocal n => NonLocal (FBlock f n) where + entryLabel (FBlock _ b) = entryLabel b + successors (FBlock _ b) = successors b + +--- constructors + +rgnil :: RG f n O O +rgnilC :: RG f n C C +rgunit :: NonLocal n => f -> Block n e x -> RG f n e x +rgCat :: NonLocal n => RG f n e a -> RG f n a x -> RG f n e x + +---- observers + +type GraphWithFacts n f e x = (Graph n e x, FactBase f) + -- A Graph together with the facts for that graph + -- The domains of the two maps should be identical + +normalizeGraph :: forall n f e x . + NonLocal n => RG f n e x -> GraphWithFacts n f e x + +normalizeGraph g = (graphMapBlocks dropFact g, facts g) + where dropFact (FBlock _ b) = b + facts :: RG f n e x -> FactBase f + facts GNil = noFacts + facts (GUnit _) = noFacts + facts (GMany _ body exit) = bodyFacts body `unionFactBase` exitFacts exit + exitFacts :: MaybeO x (FBlock f n C O) -> FactBase f + exitFacts NothingO = noFacts + exitFacts (JustO (FBlock f b)) = mkFactBase [(entryLabel b, f)] + bodyFacts :: Body' (FBlock f) n -> FactBase f + bodyFacts (Body body) = foldLabelMap f noFacts body + where f (FBlock f b) fb = extendFactBase fb (entryLabel b) f + +--- implementation of the constructors (boring) + +rgnil = GNil +rgnilC = GMany NothingO emptyMap NothingO + +rgunit f b@(BFirst {}) = gUnitCO (FBlock f b) +rgunit f b@(BMiddle {}) = gUnitOO (FBlock f b) +rgunit f b@(BLast {}) = gUnitOC (FBlock f b) +rgunit f b@(BCat {}) = gUnitOO (FBlock f b) +rgunit f b@(BHead {}) = gUnitCO (FBlock f b) +rgunit f b@(BTail {}) = gUnitOC (FBlock f b) +rgunit f b@(BClosed {}) = gUnitCC (FBlock f b) + +rgCat = U.splice fzCat + where fzCat (FBlock f b1) (FBlock _ b2) = FBlock f (b1 `U.cat` b2) + +---------------------------------------------------------------- +-- Utilities +---------------------------------------------------------------- + +-- Lifting based on shape: +-- - from nodes to blocks +-- - from facts to fact-like things +-- Lowering back: +-- - from fact-like things to facts +-- Note that the latter two functions depend only on the entry shape. +class ShapeLifter e x where + unit :: n e x -> Block n e x + elift :: NonLocal n => n e x -> f -> Fact e f + elower :: NonLocal n => DataflowLattice f -> n e x -> Fact e f -> f + ftransfer :: FwdPass n f -> n e x -> f -> Fact x f + btransfer :: BwdPass n f -> n e x -> Fact x f -> f + frewrite :: FwdPass n f -> n e x -> f -> Maybe (FwdRes n f e x) + brewrite :: BwdPass n f -> n e x -> Fact x f -> Maybe (BwdRes n f e x) + spliceRgNode :: NonLocal n => RG f n a e -> f -> n e x -> RG f n a x + entry :: NonLocal n => n e x -> Entries e + +instance ShapeLifter C O where + unit = BFirst + elift n f = mkFactBase [(entryLabel n, f)] + elower lat n fb = getFact lat (entryLabel n) fb + ftransfer (FwdPass {fp_transfer = FwdTransfers (ft, _, _)}) n f = ft n f + btransfer (BwdPass {bp_transfer = BwdTransfers (bt, _, _)}) n f = bt n f + frewrite (FwdPass {fp_rewrite = FwdRewrites (fr, _, _)}) n f = fr n f + brewrite (BwdPass {bp_rewrite = BwdRewrites (br, _, _)}) n f = br n f + spliceRgNode (GMany e body NothingO) f n = GMany e body x + where x = JustO $ FBlock f $ BFirst n + entry n = JustC [entryLabel n] + +instance ShapeLifter O O where + unit = BMiddle + elift _ f = f + elower _ _ f = f + ftransfer (FwdPass {fp_transfer = FwdTransfers (_, ft, _)}) n f = ft n f + btransfer (BwdPass {bp_transfer = BwdTransfers (_, bt, _)}) n f = bt n f + frewrite (FwdPass {fp_rewrite = FwdRewrites (_, fr, _)}) n f = fr n f + brewrite (BwdPass {bp_rewrite = BwdRewrites (_, br, _)}) n f = br n f + spliceRgNode (GMany e body (JustO (FBlock f x))) _ n = GMany e body (JustO x') + where x' = FBlock f $ BHead x n + spliceRgNode (GNil) f n = GUnit $ FBlock f $ BMiddle n + spliceRgNode (GUnit (FBlock f b)) _ n = GUnit $ FBlock f $ b `BCat` BMiddle n + entry _ = NothingC + +instance ShapeLifter O C where + unit = BLast + elift _ f = f + elower _ _ f = f + ftransfer (FwdPass {fp_transfer = FwdTransfers (_, _, ft)}) n f = ft n f + btransfer (BwdPass {bp_transfer = BwdTransfers (_, _, bt)}) n f = bt n f + frewrite (FwdPass {fp_rewrite = FwdRewrites (_, _, fr)}) n f = fr n f + brewrite (BwdPass {bp_rewrite = BwdRewrites (_, _, br)}) n f = br n f + spliceRgNode (GMany e b1 (JustO (FBlock f x))) _ n = GMany e body' NothingO + where body' = unionLabelMap b1 b2 + b2 = addBlock (FBlock f $ BClosed x $ BLast n) emptyMap + spliceRgNode (GNil) f n = GMany e emptyMap NothingO + where e = JustO $ FBlock f $ BLast n + spliceRgNode (GUnit (FBlock f b)) _ n = GMany e emptyMap NothingO + where e = JustO $ FBlock f (b `U.cat` BLast n) + entry _ = NothingC + +-- Fact lookup: the fact `orelse` bottom +lookupF :: FwdPass n f -> Label -> FactBase f -> f +lookupF = getFact . fp_lattice + +getFact :: DataflowLattice f -> Label -> FactBase f -> f +getFact lat l fb = case lookupFact fb l of Just f -> f + Nothing -> fact_bot lat diff -Nru ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl/Dataflow.hs ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl/Dataflow.hs --- ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl/Dataflow.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl/Dataflow.hs 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,821 @@ +{-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies, MultiParamTypeClasses #-} + +module Compiler.Hoopl.Dataflow + ( DataflowLattice(..), JoinFun, OldFact(..), NewFact(..), Fact, mkFactBase + , ChangeFlag(..), changeIf + , FwdPass(..), FwdTransfer, mkFTransfer, mkFTransfer3, getFTransfer3 + -- * Respecting Fuel + + -- $fuel + , FwdRewrite, mkFRewrite, mkFRewrite3, getFRewrite3, noFwdRewrite + , wrapFR, wrapFR2 + , BwdPass(..), BwdTransfer, mkBTransfer, mkBTransfer3, getBTransfer3 + , wrapBR, wrapBR2 + , BwdRewrite, mkBRewrite, mkBRewrite3, getBRewrite3, noBwdRewrite + , analyzeAndRewriteFwd, analyzeAndRewriteBwd + ) +where + +import Control.Monad +import Data.Maybe + +import Compiler.Hoopl.Checkpoint +import Compiler.Hoopl.Collections +import Compiler.Hoopl.Fuel +import Compiler.Hoopl.Graph hiding (Graph) -- hiding so we can redefine + -- and include definition in paper +import qualified Compiler.Hoopl.GraphUtil as U +import Compiler.Hoopl.Label +import Compiler.Hoopl.Util + +----------------------------------------------------------------------------- +-- DataflowLattice +----------------------------------------------------------------------------- + +data DataflowLattice a = DataflowLattice + { fact_name :: String -- Documentation + , fact_bot :: a -- Lattice bottom element + , fact_join :: JoinFun a -- Lattice join plus change flag + -- (changes iff result > old fact) + } +-- ^ A transfer function might want to use the logging flag +-- to control debugging, as in for example, it updates just one element +-- in a big finite map. We don't want Hoopl to show the whole fact, +-- and only the transfer function knows exactly what changed. + +type JoinFun a = Label -> OldFact a -> NewFact a -> (ChangeFlag, a) + -- the label argument is for debugging purposes only +newtype OldFact a = OldFact a +newtype NewFact a = NewFact a + +data ChangeFlag = NoChange | SomeChange deriving (Eq, Ord) +changeIf :: Bool -> ChangeFlag +changeIf changed = if changed then SomeChange else NoChange + + +-- | 'mkFactBase' creates a 'FactBase' from a list of ('Label', fact) +-- pairs. If the same label appears more than once, the relevant facts +-- are joined. + +mkFactBase :: forall f. DataflowLattice f -> [(Label, f)] -> FactBase f +mkFactBase lattice = foldl add mapEmpty + where add :: FactBase f -> (Label, f) -> FactBase f + add map (lbl, f) = mapInsert lbl newFact map + where newFact = case mapLookup lbl map of + Nothing -> f + Just f' -> snd $ join lbl (OldFact f') (NewFact f) + join = fact_join lattice + + +----------------------------------------------------------------------------- +-- Analyze and rewrite forward: the interface +----------------------------------------------------------------------------- + +data FwdPass m n f + = FwdPass { fp_lattice :: DataflowLattice f + , fp_transfer :: FwdTransfer n f + , fp_rewrite :: FwdRewrite m n f } + +newtype FwdTransfer n f + = FwdTransfer3 { getFTransfer3 :: + ( n C O -> f -> f + , n O O -> f -> f + , n O C -> f -> FactBase f + ) } + +newtype FwdRewrite m n f -- see Note [Respects Fuel] + = FwdRewrite3 { getFRewrite3 :: + ( n C O -> f -> m (Maybe (Graph n C O, FwdRewrite m n f)) + , n O O -> f -> m (Maybe (Graph n O O, FwdRewrite m n f)) + , n O C -> f -> m (Maybe (Graph n O C, FwdRewrite m n f)) + ) } + +wrapFR :: (forall e x. (n e x -> f -> m (Maybe (Graph n e x, FwdRewrite m n f ))) + -> (n' e x -> f' -> m' (Maybe (Graph n' e x, FwdRewrite m' n' f'))) + ) + -- ^ This argument may assume that any function passed to it + -- respects fuel, and it must return a result that respects fuel. + -> FwdRewrite m n f + -> FwdRewrite m' n' f' -- see Note [Respects Fuel] +wrapFR wrap (FwdRewrite3 (f, m, l)) = FwdRewrite3 (wrap f, wrap m, wrap l) +wrapFR2 + :: (forall e x . (n1 e x -> f1 -> m1 (Maybe (Graph n1 e x, FwdRewrite m1 n1 f1))) -> + (n2 e x -> f2 -> m2 (Maybe (Graph n2 e x, FwdRewrite m2 n2 f2))) -> + (n3 e x -> f3 -> m3 (Maybe (Graph n3 e x, FwdRewrite m3 n3 f3))) + ) + -- ^ This argument may assume that any function passed to it + -- respects fuel, and it must return a result that respects fuel. + -> FwdRewrite m1 n1 f1 + -> FwdRewrite m2 n2 f2 + -> FwdRewrite m3 n3 f3 -- see Note [Respects Fuel] +wrapFR2 wrap2 (FwdRewrite3 (f1, m1, l1)) (FwdRewrite3 (f2, m2, l2)) = + FwdRewrite3 (wrap2 f1 f2, wrap2 m1 m2, wrap2 l1 l2) + + +mkFTransfer3 :: (n C O -> f -> f) + -> (n O O -> f -> f) + -> (n O C -> f -> FactBase f) + -> FwdTransfer n f +mkFTransfer3 f m l = FwdTransfer3 (f, m, l) + +mkFTransfer :: (forall e x . n e x -> f -> Fact x f) -> FwdTransfer n f +mkFTransfer f = FwdTransfer3 (f, f, f) + +-- | Functions passed to 'mkFRewrite3' should not be aware of the fuel supply. +-- The result returned by 'mkFRewrite3' respects fuel. +mkFRewrite3 :: forall m n f. FuelMonad m + => (n C O -> f -> m (Maybe (Graph n C O))) + -> (n O O -> f -> m (Maybe (Graph n O O))) + -> (n O C -> f -> m (Maybe (Graph n O C))) + -> FwdRewrite m n f +mkFRewrite3 f m l = FwdRewrite3 (lift f, lift m, lift l) + where lift :: forall t t1 a. (t -> t1 -> m (Maybe a)) -> t -> t1 -> m (Maybe (a, FwdRewrite m n f)) + lift rw node fact = liftM (liftM asRew) (withFuel =<< rw node fact) + asRew :: forall t. t -> (t, FwdRewrite m n f) + asRew g = (g, noFwdRewrite) + +noFwdRewrite :: Monad m => FwdRewrite m n f +noFwdRewrite = FwdRewrite3 (noRewrite, noRewrite, noRewrite) + +noRewrite :: Monad m => a -> b -> m (Maybe c) +noRewrite _ _ = return Nothing + + + +-- | Functions passed to 'mkFRewrite' should not be aware of the fuel supply. +-- The result returned by 'mkFRewrite' respects fuel. +mkFRewrite :: FuelMonad m => (forall e x . n e x -> f -> m (Maybe (Graph n e x))) + -> FwdRewrite m n f +mkFRewrite f = mkFRewrite3 f f f + + +type family Fact x f :: * +type instance Fact C f = FactBase f +type instance Fact O f = f + +-- | if the graph being analyzed is open at the entry, there must +-- be no other entry point, or all goes horribly wrong... +analyzeAndRewriteFwd + :: forall m n f e x entries. (CheckpointMonad m, NonLocal n, LabelsPtr entries) + => FwdPass m n f + -> MaybeC e entries + -> Graph n e x -> Fact e f + -> m (Graph n e x, FactBase f, MaybeO x f) +analyzeAndRewriteFwd pass entries g f = + do (rg, fout) <- arfGraph pass (fmap targetLabels entries) g f + let (g', fb) = normalizeGraph rg + return (g', fb, distinguishedExitFact g' fout) + +distinguishedExitFact :: forall n e x f . Graph n e x -> Fact x f -> MaybeO x f +distinguishedExitFact g f = maybe g + where maybe :: Graph n e x -> MaybeO x f + maybe GNil = JustO f + maybe (GUnit {}) = JustO f + maybe (GMany _ _ x) = case x of NothingO -> NothingO + JustO _ -> JustO f + +---------------------------------------------------------------- +-- Forward Implementation +---------------------------------------------------------------- + +type Entries e = MaybeC e [Label] + +arfGraph :: forall m n f e x . + (NonLocal n, CheckpointMonad m) => FwdPass m n f -> + Entries e -> Graph n e x -> Fact e f -> m (DG f n e x, Fact x f) +arfGraph pass entries = graph + where + {- nested type synonyms would be so lovely here + type ARF thing = forall e x . thing e x -> f -> m (DG f n e x, Fact x f) + type ARFX thing = forall e x . thing e x -> Fact e f -> m (DG f n e x, Fact x f) + -} + graph :: Graph n e x -> Fact e f -> m (DG f n e x, Fact x f) +-- @ start block.tex -2 + block :: forall e x . + Block n e x -> f -> m (DG f n e x, Fact x f) +-- @ end block.tex +-- @ start node.tex -4 + node :: forall e x . (ShapeLifter e x) + => n e x -> f -> m (DG f n e x, Fact x f) +-- @ end node.tex +-- @ start bodyfun.tex + body :: [Label] -> LabelMap (Block n C C) + -> Fact C f -> m (DG f n C C, Fact C f) +-- @ end bodyfun.tex + -- Outgoing factbase is restricted to Labels *not* in + -- in the Body; the facts for Labels *in* + -- the Body are in the 'DG f n C C' +-- @ start cat.tex -2 + cat :: forall e a x f1 f2 f3. + (f1 -> m (DG f n e a, f2)) + -> (f2 -> m (DG f n a x, f3)) + -> (f1 -> m (DG f n e x, f3)) +-- @ end cat.tex + + graph GNil = \f -> return (dgnil, f) + graph (GUnit blk) = block blk + graph (GMany e bdy x) = (e `ebcat` bdy) `cat` exit x + where + ebcat :: MaybeO e (Block n O C) -> Body n -> Fact e f -> m (DG f n e C, Fact C f) + exit :: MaybeO x (Block n C O) -> Fact C f -> m (DG f n C x, Fact x f) + exit (JustO blk) = arfx block blk + exit NothingO = \fb -> return (dgnilC, fb) + ebcat entry bdy = c entries entry + where c :: MaybeC e [Label] -> MaybeO e (Block n O C) + -> Fact e f -> m (DG f n e C, Fact C f) + c NothingC (JustO entry) = block entry `cat` body (successors entry) bdy + c (JustC entries) NothingO = body entries bdy + c _ _ = error "bogus GADT pattern match failure" + + -- Lift from nodes to blocks +-- @ start block.tex -2 + block (BFirst n) = node n + block (BMiddle n) = node n + block (BLast n) = node n + block (BCat b1 b2) = block b1 `cat` block b2 +-- @ end block.tex + block (BHead h n) = block h `cat` node n + block (BTail n t) = node n `cat` block t + block (BClosed h t)= block h `cat` block t + +-- @ start node.tex -4 + node n f + = do { grw <- frewrite pass n f + ; case grw of + Nothing -> return ( singletonDG f n + , ftransfer pass n f ) + Just (g, rw) -> + let pass' = pass { fp_rewrite = rw } + f' = fwdEntryFact n f + in arfGraph pass' (fwdEntryLabel n) g f' } + +-- @ end node.tex + + -- | Compose fact transformers and concatenate the resulting + -- rewritten graphs. + {-# INLINE cat #-} +-- @ start cat.tex -2 + cat ft1 ft2 f = do { (g1,f1) <- ft1 f + ; (g2,f2) <- ft2 f1 + ; return (g1 `dgSplice` g2, f2) } +-- @ end cat.tex + arfx :: forall thing x . + NonLocal thing + => (thing C x -> f -> m (DG f n C x, Fact x f)) + -> (thing C x -> Fact C f -> m (DG f n C x, Fact x f)) + arfx arf thing fb = + arf thing $ fromJust $ lookupFact (entryLabel thing) $ joinInFacts lattice fb + where lattice = fp_lattice pass + -- joinInFacts adds debugging information + + + -- Outgoing factbase is restricted to Labels *not* in + -- in the Body; the facts for Labels *in* + -- the Body are in the 'DG f n C C' +-- @ start bodyfun.tex + body entries blockmap init_fbase + = fixpoint Fwd lattice do_block blocks init_fbase + where + blocks = forwardBlockList entries blockmap + lattice = fp_lattice pass + do_block :: forall x. Block n C x -> FactBase f -> m (DG f n C x, Fact x f) + do_block b fb = block b entryFact + where entryFact = getFact lattice (entryLabel b) fb +-- @ end bodyfun.tex + + +-- Join all the incoming facts with bottom. +-- We know the results _shouldn't change_, but the transfer +-- functions might, for example, generate some debugging traces. +joinInFacts :: DataflowLattice f -> FactBase f -> FactBase f +joinInFacts (lattice @ DataflowLattice {fact_bot = bot, fact_join = fj}) fb = + mkFactBase lattice $ map botJoin $ mapToList fb + where botJoin (l, f) = (l, snd $ fj l (OldFact bot) (NewFact f)) + +forwardBlockList :: (NonLocal n, LabelsPtr entry) + => entry -> Body n -> [Block n C C] +-- This produces a list of blocks in order suitable for forward analysis, +-- along with the list of Labels it may depend on for facts. +forwardBlockList entries blks = postorder_dfs_from blks entries + +----------------------------------------------------------------------------- +-- Backward analysis and rewriting: the interface +----------------------------------------------------------------------------- + +data BwdPass m n f + = BwdPass { bp_lattice :: DataflowLattice f + , bp_transfer :: BwdTransfer n f + , bp_rewrite :: BwdRewrite m n f } + +newtype BwdTransfer n f + = BwdTransfer3 { getBTransfer3 :: + ( n C O -> f -> f + , n O O -> f -> f + , n O C -> FactBase f -> f + ) } +newtype BwdRewrite m n f + = BwdRewrite3 { getBRewrite3 :: + ( n C O -> f -> m (Maybe (Graph n C O, BwdRewrite m n f)) + , n O O -> f -> m (Maybe (Graph n O O, BwdRewrite m n f)) + , n O C -> FactBase f -> m (Maybe (Graph n O C, BwdRewrite m n f)) + ) } + +wrapBR :: (forall e x . + Shape x + -> (n e x -> Fact x f -> m (Maybe (Graph n e x, BwdRewrite m n f ))) + -> (n' e x -> Fact x f' -> m' (Maybe (Graph n' e x, BwdRewrite m' n' f'))) + ) + -- ^ This argument may assume that any function passed to it + -- respects fuel, and it must return a result that respects fuel. + -> BwdRewrite m n f + -> BwdRewrite m' n' f' -- see Note [Respects Fuel] +wrapBR wrap (BwdRewrite3 (f, m, l)) = + BwdRewrite3 (wrap Open f, wrap Open m, wrap Closed l) + +wrapBR2 :: (forall e x . Shape x + -> (n1 e x -> Fact x f1 -> m1 (Maybe (Graph n1 e x, BwdRewrite m1 n1 f1))) + -> (n2 e x -> Fact x f2 -> m2 (Maybe (Graph n2 e x, BwdRewrite m2 n2 f2))) + -> (n3 e x -> Fact x f3 -> m3 (Maybe (Graph n3 e x, BwdRewrite m3 n3 f3)))) + -- ^ This argument may assume that any function passed to it + -- respects fuel, and it must return a result that respects fuel. + -> BwdRewrite m1 n1 f1 + -> BwdRewrite m2 n2 f2 + -> BwdRewrite m3 n3 f3 -- see Note [Respects Fuel] +wrapBR2 wrap2 (BwdRewrite3 (f1, m1, l1)) (BwdRewrite3 (f2, m2, l2)) = + BwdRewrite3 (wrap2 Open f1 f2, wrap2 Open m1 m2, wrap2 Closed l1 l2) + + + +mkBTransfer3 :: (n C O -> f -> f) -> (n O O -> f -> f) -> + (n O C -> FactBase f -> f) -> BwdTransfer n f +mkBTransfer3 f m l = BwdTransfer3 (f, m, l) + +mkBTransfer :: (forall e x . n e x -> Fact x f -> f) -> BwdTransfer n f +mkBTransfer f = BwdTransfer3 (f, f, f) + +-- | Functions passed to 'mkBRewrite3' should not be aware of the fuel supply. +-- The result returned by 'mkBRewrite3' respects fuel. +mkBRewrite3 :: forall m n f. FuelMonad m + => (n C O -> f -> m (Maybe (Graph n C O))) + -> (n O O -> f -> m (Maybe (Graph n O O))) + -> (n O C -> FactBase f -> m (Maybe (Graph n O C))) + -> BwdRewrite m n f +mkBRewrite3 f m l = BwdRewrite3 (lift f, lift m, lift l) + where lift :: forall t t1 a. (t -> t1 -> m (Maybe a)) -> t -> t1 -> m (Maybe (a, BwdRewrite m n f)) + lift rw node fact = liftM (liftM asRew) (withFuel =<< rw node fact) + asRew :: t -> (t, BwdRewrite m n f) + asRew g = (g, noBwdRewrite) + +noBwdRewrite :: Monad m => BwdRewrite m n f +noBwdRewrite = BwdRewrite3 (noRewrite, noRewrite, noRewrite) + +-- | Functions passed to 'mkBRewrite' should not be aware of the fuel supply. +-- The result returned by 'mkBRewrite' respects fuel. +mkBRewrite :: FuelMonad m + => (forall e x . n e x -> Fact x f -> m (Maybe (Graph n e x))) + -> BwdRewrite m n f +mkBRewrite f = mkBRewrite3 f f f + + +----------------------------------------------------------------------------- +-- Backward implementation +----------------------------------------------------------------------------- + +arbGraph :: forall m n f e x . + (NonLocal n, CheckpointMonad m) => BwdPass m n f -> + Entries e -> Graph n e x -> Fact x f -> m (DG f n e x, Fact e f) +arbGraph pass entries = graph + where + {- nested type synonyms would be so lovely here + type ARB thing = forall e x . thing e x -> Fact x f -> m (DG f n e x, f) + type ARBX thing = forall e x . thing e x -> Fact x f -> m (DG f n e x, Fact e f) + -} + graph :: Graph n e x -> Fact x f -> m (DG f n e x, Fact e f) + block :: forall e x . Block n e x -> Fact x f -> m (DG f n e x, f) + node :: forall e x . (ShapeLifter e x) + => n e x -> Fact x f -> m (DG f n e x, f) + body :: [Label] -> Body n -> Fact C f -> m (DG f n C C, Fact C f) + cat :: forall e a x info info' info''. + (info' -> m (DG f n e a, info'')) + -> (info -> m (DG f n a x, info')) + -> (info -> m (DG f n e x, info'')) + + graph GNil = \f -> return (dgnil, f) + graph (GUnit blk) = block blk + graph (GMany e bdy x) = (e `ebcat` bdy) `cat` exit x + where + ebcat :: MaybeO e (Block n O C) -> Body n -> Fact C f -> m (DG f n e C, Fact e f) + exit :: MaybeO x (Block n C O) -> Fact x f -> m (DG f n C x, Fact C f) + exit (JustO blk) = arbx block blk + exit NothingO = \fb -> return (dgnilC, fb) + ebcat entry bdy = c entries entry + where c :: MaybeC e [Label] -> MaybeO e (Block n O C) + -> Fact C f -> m (DG f n e C, Fact e f) + c NothingC (JustO entry) = block entry `cat` body (successors entry) bdy + c (JustC entries) NothingO = body entries bdy + c _ _ = error "bogus GADT pattern match failure" + + -- Lift from nodes to blocks + block (BFirst n) = node n + block (BMiddle n) = node n + block (BLast n) = node n + block (BCat b1 b2) = block b1 `cat` block b2 + block (BHead h n) = block h `cat` node n + block (BTail n t) = node n `cat` block t + block (BClosed h t)= block h `cat` block t + + node n f + = do { bwdres <- brewrite pass n f + ; case bwdres of + Nothing -> return (singletonDG entry_f n, entry_f) + where entry_f = btransfer pass n f + Just (g, rw) -> + do { let pass' = pass { bp_rewrite = rw } + ; (g, f) <- arbGraph pass' (fwdEntryLabel n) g f + ; return (g, bwdEntryFact (bp_lattice pass) n f)} } + + -- | Compose fact transformers and concatenate the resulting + -- rewritten graphs. + {-# INLINE cat #-} + cat ft1 ft2 f = do { (g2,f2) <- ft2 f + ; (g1,f1) <- ft1 f2 + ; return (g1 `dgSplice` g2, f1) } + + arbx :: forall thing x . + NonLocal thing + => (thing C x -> Fact x f -> m (DG f n C x, f)) + -> (thing C x -> Fact x f -> m (DG f n C x, Fact C f)) + + arbx arb thing f = do { (rg, f) <- arb thing f + ; let fb = joinInFacts (bp_lattice pass) $ + mapSingleton (entryLabel thing) f + ; return (rg, fb) } + -- joinInFacts adds debugging information + + -- Outgoing factbase is restricted to Labels *not* in + -- in the Body; the facts for Labels *in* + -- the Body are in the 'DG f n C C' + body entries blockmap init_fbase + = fixpoint Bwd (bp_lattice pass) do_block blocks init_fbase + where + blocks = backwardBlockList entries blockmap + do_block :: forall x. Block n C x -> Fact x f -> m (DG f n C x, LabelMap f) + do_block b f = do (g, f) <- block b f + return (g, mapSingleton (entryLabel b) f) + + +backwardBlockList :: (LabelsPtr entries, NonLocal n) => entries -> Body n -> [Block n C C] +-- This produces a list of blocks in order suitable for backward analysis, +-- along with the list of Labels it may depend on for facts. +backwardBlockList entries body = reverse $ forwardBlockList entries body + +{- + +The forward and backward cases are not dual. In the forward case, the +entry points are known, and one simply traverses the body blocks from +those points. In the backward case, something is known about the exit +points, but this information is essentially useless, because we don't +actually have a dual graph (that is, one with edges reversed) to +compute with. (Even if we did have a dual graph, it would not avail +us---a backward analysis must include reachable blocks that don't +reach the exit, as in a procedure that loops forever and has side +effects.) + +-} + + +-- | if the graph being analyzed is open at the exit, I don't +-- quite understand the implications of possible other exits +analyzeAndRewriteBwd + :: (CheckpointMonad m, NonLocal n, LabelsPtr entries) + => BwdPass m n f + -> MaybeC e entries -> Graph n e x -> Fact x f + -> m (Graph n e x, FactBase f, MaybeO e f) +analyzeAndRewriteBwd pass entries g f = + do (rg, fout) <- arbGraph pass (fmap targetLabels entries) g f + let (g', fb) = normalizeGraph rg + return (g', fb, distinguishedEntryFact g' fout) + +distinguishedEntryFact :: forall n e x f . Graph n e x -> Fact e f -> MaybeO e f +distinguishedEntryFact g f = maybe g + where maybe :: Graph n e x -> MaybeO e f + maybe GNil = JustO f + maybe (GUnit {}) = JustO f + maybe (GMany e _ _) = case e of NothingO -> NothingO + JustO _ -> JustO f + +----------------------------------------------------------------------------- +-- fixpoint: finding fixed points +----------------------------------------------------------------------------- +-- @ start txfb.tex +data TxFactBase n f + = TxFB { tfb_fbase :: FactBase f + , tfb_rg :: DG f n C C -- Transformed blocks + , tfb_cha :: ChangeFlag + , tfb_lbls :: LabelSet } +-- @ end txfb.tex + -- See Note [TxFactBase invariants] +-- @ start update.tex +updateFact :: DataflowLattice f -> LabelSet + -> Label -> f -> (ChangeFlag, FactBase f) + -> (ChangeFlag, FactBase f) +-- See Note [TxFactBase change flag] +updateFact lat lbls lbl new_fact (cha, fbase) + | NoChange <- cha2 = (cha, fbase) + | lbl `setMember` lbls = (SomeChange, new_fbase) + | otherwise = (cha, new_fbase) + where + (cha2, res_fact) -- Note [Unreachable blocks] + = case lookupFact lbl fbase of + Nothing -> (SomeChange, new_fact_debug) -- Note [Unreachable blocks] + Just old_fact -> join old_fact + where join old_fact = + fact_join lat lbl + (OldFact old_fact) (NewFact new_fact) + (_, new_fact_debug) = join (fact_bot lat) + new_fbase = mapInsert lbl res_fact fbase +-- @ end update.tex + + +{- +-- this doesn't work because it can't be implemented +class Monad m => FixpointMonad m where + observeChangedFactBase :: m (Maybe (FactBase f)) -> Maybe (FactBase f) +-} + +-- @ start fptype.tex +data Direction = Fwd | Bwd +fixpoint :: forall m n f. (CheckpointMonad m, NonLocal n) + => Direction + -> DataflowLattice f + -> (Block n C C -> Fact C f -> m (DG f n C C, Fact C f)) + -> [Block n C C] + -> (Fact C f -> m (DG f n C C, Fact C f)) +-- @ end fptype.tex +-- @ start fpimp.tex +fixpoint direction lat do_block blocks init_fbase + = do { tx_fb <- loop init_fbase + ; return (tfb_rg tx_fb, + map (fst . fst) tagged_blocks + `mapDeleteList` tfb_fbase tx_fb ) } + -- The successors of the Graph are the the Labels + -- for which we have facts and which are *not* in + -- the blocks of the graph + where + tagged_blocks = map tag blocks + is_fwd = case direction of { Fwd -> True; + Bwd -> False } + tag :: NonLocal t => t C C -> ((Label, t C C), [Label]) + tag b = ((entryLabel b, b), + if is_fwd then [entryLabel b] + else successors b) + -- 'tag' adds the in-labels of the block; + -- see Note [TxFactBase invairants] + + tx_blocks :: [((Label, Block n C C), [Label])] -- I do not understand this type + -> TxFactBase n f -> m (TxFactBase n f) + tx_blocks [] tx_fb = return tx_fb + tx_blocks (((lbl,blk), in_lbls):bs) tx_fb + = tx_block lbl blk in_lbls tx_fb >>= tx_blocks bs + -- "in_lbls" == Labels the block may + -- _depend_ upon for facts + + tx_block :: Label -> Block n C C -> [Label] + -> TxFactBase n f -> m (TxFactBase n f) + tx_block lbl blk in_lbls + tx_fb@(TxFB { tfb_fbase = fbase, tfb_lbls = lbls + , tfb_rg = blks, tfb_cha = cha }) + | is_fwd && not (lbl `mapMember` fbase) + = return (tx_fb {tfb_lbls = lbls'}) -- Note [Unreachable blocks] + | otherwise + = do { (rg, out_facts) <- do_block blk fbase + ; let (cha', fbase') = mapFoldWithKey + (updateFact lat lbls') + (cha,fbase) out_facts + ; return $ + TxFB { tfb_lbls = lbls' + , tfb_rg = rg `dgSplice` blks + , tfb_fbase = fbase' + , tfb_cha = cha' } } + where + lbls' = lbls `setUnion` setFromList in_lbls + + + loop :: FactBase f -> m (TxFactBase n f) + loop fbase + = do { s <- checkpoint + ; let init_tx :: TxFactBase n f + init_tx = TxFB { tfb_fbase = fbase + , tfb_cha = NoChange + , tfb_rg = dgnilC + , tfb_lbls = setEmpty } + ; tx_fb <- tx_blocks tagged_blocks init_tx + ; case tfb_cha tx_fb of + NoChange -> return tx_fb + SomeChange + -> do { restart s + ; loop (tfb_fbase tx_fb) } } +-- @ end fpimp.tex + + +{- Note [TxFactBase invariants] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +The TxFactBase is used only during a fixpoint iteration (or "sweep"), +and accumulates facts (and the transformed code) during the fixpoint +iteration. + +* tfb_fbase increases monotonically, across all sweeps + +* At the beginning of each sweep + tfb_cha = NoChange + tfb_lbls = {} + +* During each sweep we process each block in turn. Processing a block + is done thus: + 1. Read from tfb_fbase the facts for its entry label (forward) + or successors labels (backward) + 2. Transform those facts into new facts for its successors (forward) + or entry label (backward) + 3. Augment tfb_fbase with that info + We call the labels read in step (1) the "in-labels" of the sweep + +* The field tfb_lbls is the set of in-labels of all blocks that have + been processed so far this sweep, including the block that is + currently being processed. tfb_lbls is initialised to {}. It is a + subset of the Labels of the *original* (not transformed) blocks. + +* The tfb_cha field is set to SomeChange iff we decide we need to + perform another iteration of the fixpoint loop. It is initialsed to NoChange. + + Specifically, we set tfb_cha to SomeChange in step (3) iff + (a) The fact in tfb_fbase for a block L changes + (b) L is in tfb_lbls + Reason: until a label enters the in-labels its accumuated fact in tfb_fbase + has not been read, hence cannot affect the outcome + +Note [Unreachable blocks] +~~~~~~~~~~~~~~~~~~~~~~~~~ +A block that is not in the domain of tfb_fbase is "currently unreachable". +A currently-unreachable block is not even analyzed. Reason: consider +constant prop and this graph, with entry point L1: + L1: x:=3; goto L4 + L2: x:=4; goto L4 + L4: if x>3 goto L2 else goto L5 +Here L2 is actually unreachable, but if we process it with bottom input fact, +we'll propagate (x=4) to L4, and nuke the otherwise-good rewriting of L4. + +* If a currently-unreachable block is not analyzed, then its rewritten + graph will not be accumulated in tfb_rg. And that is good: + unreachable blocks simply do not appear in the output. + +* Note that clients must be careful to provide a fact (even if bottom) + for each entry point. Otherwise useful blocks may be garbage collected. + +* Note that updateFact must set the change-flag if a label goes from + not-in-fbase to in-fbase, even if its fact is bottom. In effect the + real fact lattice is + UNR + bottom + the points above bottom + +* Even if the fact is going from UNR to bottom, we still call the + client's fact_join function because it might give the client + some useful debugging information. + +* All of this only applies for *forward* fixpoints. For the backward + case we must treat every block as reachable; it might finish with a + 'return', and therefore have no successors, for example. +-} + +----------------------------------------------------------------------------- +-- DG: an internal data type for 'decorated graphs' +-- TOTALLY internal to Hoopl; each block is decorated with a fact +----------------------------------------------------------------------------- + +-- @ start dg.tex +type Graph = Graph' Block +type DG f = Graph' (DBlock f) +data DBlock f n e x = DBlock f (Block n e x) -- ^ block decorated with fact +-- @ end dg.tex +instance NonLocal n => NonLocal (DBlock f n) where + entryLabel (DBlock _ b) = entryLabel b + successors (DBlock _ b) = successors b + +--- constructors + +dgnil :: DG f n O O +dgnilC :: DG f n C C +dgSplice :: NonLocal n => DG f n e a -> DG f n a x -> DG f n e x + +---- observers + +type GraphWithFacts n f e x = (Graph n e x, FactBase f) + -- A Graph together with the facts for that graph + -- The domains of the two maps should be identical + +normalizeGraph :: forall n f e x . + NonLocal n => DG f n e x -> GraphWithFacts n f e x + +normalizeGraph g = (graphMapBlocks dropFact g, facts g) + where dropFact :: DBlock t t1 t2 t3 -> Block t1 t2 t3 + dropFact (DBlock _ b) = b + facts :: DG f n e x -> FactBase f + facts GNil = noFacts + facts (GUnit _) = noFacts + facts (GMany _ body exit) = bodyFacts body `mapUnion` exitFacts exit + exitFacts :: MaybeO x (DBlock f n C O) -> FactBase f + exitFacts NothingO = noFacts + exitFacts (JustO (DBlock f b)) = mapSingleton (entryLabel b) f + bodyFacts :: LabelMap (DBlock f n C C) -> FactBase f + bodyFacts body = mapFold f noFacts body + where f :: forall t a x. (NonLocal t) => DBlock a t C x -> LabelMap a -> LabelMap a + f (DBlock f b) fb = mapInsert (entryLabel b) f fb + +--- implementation of the constructors (boring) + +dgnil = GNil +dgnilC = GMany NothingO emptyBody NothingO + +dgSplice = U.splice fzCat + where fzCat :: DBlock f n e O -> DBlock t n O x -> DBlock f n e x + fzCat (DBlock f b1) (DBlock _ b2) = DBlock f (b1 `U.cat` b2) + +---------------------------------------------------------------- +-- Utilities +---------------------------------------------------------------- + +-- Lifting based on shape: +-- - from nodes to blocks +-- - from facts to fact-like things +-- Lowering back: +-- - from fact-like things to facts +-- Note that the latter two functions depend only on the entry shape. +-- @ start node.tex +class ShapeLifter e x where + singletonDG :: f -> n e x -> DG f n e x + fwdEntryFact :: NonLocal n => n e x -> f -> Fact e f + fwdEntryLabel :: NonLocal n => n e x -> MaybeC e [Label] + ftransfer :: FwdPass m n f -> n e x -> f -> Fact x f + frewrite :: FwdPass m n f -> n e x + -> f -> m (Maybe (Graph n e x, FwdRewrite m n f)) +-- @ end node.tex + bwdEntryFact :: NonLocal n => DataflowLattice f -> n e x -> Fact e f -> f + btransfer :: BwdPass m n f -> n e x -> Fact x f -> f + brewrite :: BwdPass m n f -> n e x + -> Fact x f -> m (Maybe (Graph n e x, BwdRewrite m n f)) + +instance ShapeLifter C O where + singletonDG f = gUnitCO . DBlock f . BFirst + fwdEntryFact n f = mapSingleton (entryLabel n) f + bwdEntryFact lat n fb = getFact lat (entryLabel n) fb + ftransfer (FwdPass {fp_transfer = FwdTransfer3 (ft, _, _)}) n f = ft n f + btransfer (BwdPass {bp_transfer = BwdTransfer3 (bt, _, _)}) n f = bt n f + frewrite (FwdPass {fp_rewrite = FwdRewrite3 (fr, _, _)}) n f = fr n f + brewrite (BwdPass {bp_rewrite = BwdRewrite3 (br, _, _)}) n f = br n f + fwdEntryLabel n = JustC [entryLabel n] + +instance ShapeLifter O O where + singletonDG f = gUnitOO . DBlock f . BMiddle + fwdEntryFact _ f = f + bwdEntryFact _ _ f = f + ftransfer (FwdPass {fp_transfer = FwdTransfer3 (_, ft, _)}) n f = ft n f + btransfer (BwdPass {bp_transfer = BwdTransfer3 (_, bt, _)}) n f = bt n f + frewrite (FwdPass {fp_rewrite = FwdRewrite3 (_, fr, _)}) n f = fr n f + brewrite (BwdPass {bp_rewrite = BwdRewrite3 (_, br, _)}) n f = br n f + fwdEntryLabel _ = NothingC + +instance ShapeLifter O C where + singletonDG f = gUnitOC . DBlock f . BLast + fwdEntryFact _ f = f + bwdEntryFact _ _ f = f + ftransfer (FwdPass {fp_transfer = FwdTransfer3 (_, _, ft)}) n f = ft n f + btransfer (BwdPass {bp_transfer = BwdTransfer3 (_, _, bt)}) n f = bt n f + frewrite (FwdPass {fp_rewrite = FwdRewrite3 (_, _, fr)}) n f = fr n f + brewrite (BwdPass {bp_rewrite = BwdRewrite3 (_, _, br)}) n f = br n f + fwdEntryLabel _ = NothingC + +-- Fact lookup: the fact `orelse` bottom +getFact :: DataflowLattice f -> Label -> FactBase f -> f +getFact lat l fb = case lookupFact l fb of Just f -> f + Nothing -> fact_bot lat + + + +{- Note [Respects fuel] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +-} +-- $fuel +-- A value of type 'FwdRewrite' or 'BwdRewrite' /respects fuel/ if +-- any function contained within the value satisfies the following properties: +-- +-- * When fuel is exhausted, it always returns 'Nothing'. +-- +-- * When it returns @Just g rw@, it consumes /exactly/ one unit +-- of fuel, and new rewrite 'rw' also respects fuel. +-- +-- Provided that functions passed to 'mkFRewrite', 'mkFRewrite3', +-- 'mkBRewrite', and 'mkBRewrite3' are not aware of the fuel supply, +-- the results respect fuel. +-- +-- It is an /unchecked/ run-time error for the argument passed to 'wrapFR', +-- 'wrapFR2', 'wrapBR', or 'warpBR2' to return a function that does not respect fuel. diff -Nru ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl/Debug.hs ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl/Debug.hs --- ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl/Debug.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl/Debug.hs 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,103 @@ +{-# LANGUAGE RankNTypes, GADTs, ScopedTypeVariables, FlexibleContexts #-} + +module Compiler.Hoopl.Debug + ( TraceFn , debugFwdJoins , debugBwdJoins + , debugFwdTransfers , debugBwdTransfers + ) +where + +import Compiler.Hoopl.Dataflow +import Compiler.Hoopl.Show + +-------------------------------------------------------------------------------- +-- | Debugging combinators: +-- Each combinator takes a dataflow pass and produces +-- a dataflow pass that can output debugging messages. +-- You provide the function, we call it with the applicable message. +-- +-- The most common use case is probably to: +-- +-- 1. import 'Debug.Trace' +-- +-- 2. pass 'trace' as the 1st argument to the debug combinator +-- +-- 3. pass 'const true' as the 2nd argument to the debug combinator +-- +-- There are two kinds of debugging messages for a join, +-- depending on whether the join is higher in the lattice than the old fact: +-- 1. If the join is higher, we show: +-- + Join@L: f1 `join` f2 = f' +-- where: +-- + indicates a change +-- L is the label where the join takes place +-- f1 is the old fact at the label +-- f2 is the new fact we are joining to f1 +-- f' is the result of the join +-- 2. _ Join@L: f2 <= f1 +-- where: +-- _ indicates no change +-- L is the label where the join takes place +-- f1 is the old fact at the label (which remains unchanged) +-- f2 is the new fact we joined with f1 +-------------------------------------------------------------------------------- + + +debugFwdJoins :: forall m n f . Show f => TraceFn -> ChangePred -> FwdPass m n f -> FwdPass m n f +debugBwdJoins :: forall m n f . Show f => TraceFn -> ChangePred -> BwdPass m n f -> BwdPass m n f + +type TraceFn = forall a . String -> a -> a +type ChangePred = ChangeFlag -> Bool + +debugFwdJoins trace pred p = p { fp_lattice = debugJoins trace pred $ fp_lattice p } +debugBwdJoins trace pred p = p { bp_lattice = debugJoins trace pred $ bp_lattice p } + +debugJoins :: Show f => TraceFn -> ChangePred -> DataflowLattice f -> DataflowLattice f +debugJoins trace showPred l@(DataflowLattice {fact_join = join}) = l {fact_join = join'} + where + join' l f1@(OldFact of1) f2@(NewFact nf2) = + if showPred c then trace output res else res + where res@(c, f') = join l f1 f2 + output = case c of + SomeChange -> "+ Join@" ++ show l ++ ": " ++ show of1 ++ " `join` " + ++ show nf2 ++ " = " ++ show f' + NoChange -> "_ Join@" ++ show l ++ ": " ++ show nf2 ++ " <= " ++ show of1 + +-------------------------------------------------------------------------------- +-- Functions we'd like to have, but don't know how to implement generically: +-------------------------------------------------------------------------------- + +type ShowN n = forall e x . n e x -> String +type FPred n f = forall e x . n e x -> f -> Bool +type BPred n f = forall e x . n e x -> Fact x f -> Bool +debugFwdTransfers:: + forall m n f . Show f => TraceFn -> ShowN n -> FPred n f -> FwdPass m n f -> FwdPass m n f +debugFwdTransfers trace showN showPred pass = pass { fp_transfer = transfers' } + where + (f, m, l) = getFTransfer3 $ fp_transfer pass + transfers' = mkFTransfer3 (wrap show f) (wrap show m) (wrap showFactBase l) + wrap :: forall e x . (Fact x f -> String) -> (n e x -> f -> Fact x f) -> n e x -> f -> Fact x f + wrap showOutF ft n f = if showPred n f then trace output res else res + where + res = ft n f + output = name ++ " transfer: " ++ show f ++ " -> " ++ showN n ++ " -> " ++ showOutF res + name = fact_name (fp_lattice pass) + +debugBwdTransfers:: + forall m n f . Show f => TraceFn -> ShowN n -> BPred n f -> BwdPass m n f -> BwdPass m n f +debugBwdTransfers trace showN showPred pass = pass { bp_transfer = transfers' } + where + (f, m, l) = getBTransfer3 $ bp_transfer pass + transfers' = mkBTransfer3 (wrap show f) (wrap show m) (wrap showFactBase l) + wrap :: forall e x . (Fact x f -> String) -> (n e x -> Fact x f -> f) -> n e x -> Fact x f -> f + wrap showInF ft n f = if showPred n f then trace output res else res + where + res = ft n f + output = name ++ " transfer: " ++ showInF f ++ " -> " ++ showN n ++ " -> " ++ show res + name = fact_name (bp_lattice pass) + + +-- debugFwdTransfers, debugFwdRewrites, debugFwdAll :: +-- forall m n f . Show f => TraceFn -> ShowN n -> FwdPass m n f -> FwdPass m n f +-- debugBwdTransfers, debugBwdRewrites, debugBwdAll :: +-- forall m n f . Show f => TraceFn -> ShowN n -> BwdPass m n f -> BwdPass m n f + diff -Nru ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl/Fuel.hs ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl/Fuel.hs --- ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl/Fuel.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl/Fuel.hs 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,105 @@ +{-# LANGUAGE TypeFamilies #-} + +----------------------------------------------------------------------------- +-- The fuel monad +----------------------------------------------------------------------------- + +module Compiler.Hoopl.Fuel + ( Fuel, infiniteFuel, fuelRemaining + , withFuel + , FuelMonad(..) + , FuelMonadT(..) + , CheckingFuelMonad + , InfiniteFuelMonad + , SimpleFuelMonad + ) +where + +import Compiler.Hoopl.Checkpoint +import Compiler.Hoopl.Unique + +class Monad m => FuelMonad m where + getFuel :: m Fuel + setFuel :: Fuel -> m () + +-- | Find out how much fuel remains after a computation. +-- Can be subtracted from initial fuel to get total consumption. +fuelRemaining :: FuelMonad m => m Fuel +fuelRemaining = getFuel + +class FuelMonadT fm where + runWithFuel :: (Monad m, FuelMonad (fm m)) => Fuel -> fm m a -> m a + + +type Fuel = Int + +withFuel :: FuelMonad m => Maybe a -> m (Maybe a) +withFuel Nothing = return Nothing +withFuel (Just a) = do f <- getFuel + if f == 0 + then return Nothing + else setFuel (f-1) >> return (Just a) + + +---------------------------------------------------------------- + +newtype CheckingFuelMonad m a = FM { unFM :: Fuel -> m (a, Fuel) } + +instance Monad m => Monad (CheckingFuelMonad m) where + return a = FM (\f -> return (a, f)) + fm >>= k = FM (\f -> do { (a, f') <- unFM fm f; unFM (k a) f' }) + +instance CheckpointMonad m => CheckpointMonad (CheckingFuelMonad m) where + type Checkpoint (CheckingFuelMonad m) = (Fuel, Checkpoint m) + checkpoint = FM $ \fuel -> do { s <- checkpoint + ; return ((fuel, s), fuel) } + restart (fuel, s) = FM $ \_ -> do { restart s; return ((), fuel) } + +instance UniqueMonad m => UniqueMonad (CheckingFuelMonad m) where + freshUnique = FM (\f -> do { l <- freshUnique; return (l, f) }) + +instance Monad m => FuelMonad (CheckingFuelMonad m) where + getFuel = FM (\f -> return (f, f)) + setFuel f = FM (\_ -> return ((),f)) + +instance FuelMonadT CheckingFuelMonad where + runWithFuel fuel m = do { (a, _) <- unFM m fuel; return a } + +---------------------------------------------------------------- + +newtype InfiniteFuelMonad m a = IFM { unIFM :: m a } +instance Monad m => Monad (InfiniteFuelMonad m) where + return a = IFM $ return a + m >>= k = IFM $ do { a <- unIFM m; unIFM (k a) } + +instance UniqueMonad m => UniqueMonad (InfiniteFuelMonad m) where + freshUnique = IFM $ freshUnique + +instance Monad m => FuelMonad (InfiniteFuelMonad m) where + getFuel = return infiniteFuel + setFuel _ = return () + +instance CheckpointMonad m => CheckpointMonad (InfiniteFuelMonad m) where + type Checkpoint (InfiniteFuelMonad m) = Checkpoint m + checkpoint = IFM checkpoint + restart s = IFM $ restart s + + + +instance FuelMonadT InfiniteFuelMonad where + runWithFuel _ = unIFM + +infiniteFuel :: Fuel -- effectively infinite, any, but subtractable +infiniteFuel = maxBound + +type SimpleFuelMonad = CheckingFuelMonad SimpleUniqueMonad + +{- +runWithFuelAndUniques :: Fuel -> [Unique] -> FuelMonad a -> a +runWithFuelAndUniques fuel uniques m = a + where (a, _, _) = unFM m fuel uniques + +freshUnique :: FuelMonad Unique +freshUnique = FM (\f (l:ls) -> (l, f, ls)) +-} + diff -Nru ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl/GHC.hs ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl/GHC.hs --- ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl/GHC.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl/GHC.hs 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,24 @@ +{-# LANGUAGE GADTs, RankNTypes #-} + +{- Exposing some internals to GHC -} +module Compiler.Hoopl.GHC + ( uniqueToInt + , uniqueToLbl, lblToUnique + , getFuel, setFuel + , bodyToBlockMap, bodyOfBlockMap + ) +where + +import Compiler.Hoopl.Fuel +import Compiler.Hoopl.Graph +import Compiler.Hoopl.Label +import Compiler.Hoopl.Unique + +-- Converts Body to a map of closed/closed blocks. +-- It should better be a constant-time operation +-- as GHC is counting on it. +bodyToBlockMap :: Body' block n -> LabelMap (block n C C) +bodyToBlockMap (Body bodyMap) = bodyMap + +bodyOfBlockMap :: LabelMap (block n C C) -> Body' block n +bodyOfBlockMap = Body diff -Nru ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl/Graph.hs ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl/Graph.hs --- ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl/Graph.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl/Graph.hs 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,146 @@ +{-# LANGUAGE GADTs, EmptyDataDecls, TypeFamilies, Rank2Types #-} + +module Compiler.Hoopl.Graph + ( O, C, Block(..), Body, Body'(..), Graph, Graph'(..) + , MaybeO(..), MaybeC(..), Shape(..), IndexedCO + , NonLocal(entryLabel, successors) + , emptyBody, addBlock, bodyList + , mapGraph, mapMaybeO, mapMaybeC, mapBlock + ) +where + +import Compiler.Hoopl.Collections +import Compiler.Hoopl.Label + +----------------------------------------------------------------------------- +-- Graphs +----------------------------------------------------------------------------- + +-- | Used at the type level to indicate an "open" structure with +-- a unique, unnamed control-flow edge flowing in or out. +-- "Fallthrough" and concatenation are permitted at an open point. +data O + + +-- | Used at the type level to indicate a "closed" structure which +-- supports control transfer only through the use of named +-- labels---no "fallthrough" is permitted. The number of control-flow +-- edges is unconstrained. +data C + +-- | A sequence of nodes. May be any of four shapes (O/O, O/C, C/O, C/C). +-- Open at the entry means single entry, mutatis mutandis for exit. +-- A closed/closed block is a /basic/ block and can't be extended further. +-- Clients should avoid manipulating blocks and should stick to either nodes +-- or graphs. +data Block n e x where + -- nodes + BFirst :: n C O -> Block n C O -- x^ block holds a single first node + BMiddle :: n O O -> Block n O O -- x^ block holds a single middle node + BLast :: n O C -> Block n O C -- x^ block holds a single last node + + -- concatenation operations + BCat :: Block n O O -> Block n O O -> Block n O O -- non-list-like + BHead :: Block n C O -> n O O -> Block n C O + BTail :: n O O -> Block n O C -> Block n O C + + BClosed :: Block n C O -> Block n O C -> Block n C C -- the zipper + +-- | A (possibly empty) collection of closed/closed blocks +type Body n = LabelMap (Block n C C) +newtype Body' block n = Body (LabelMap (block n C C)) + +-- | A control-flow graph, which may take any of four shapes (O/O, O/C, C/O, C/C). +-- A graph open at the entry has a single, distinguished, anonymous entry point; +-- if a graph is closed at the entry, its entry point(s) are supplied by a context. +type Graph = Graph' Block +data Graph' block n e x where + GNil :: Graph' block n O O + GUnit :: block n O O -> Graph' block n O O + GMany :: MaybeO e (block n O C) + -> LabelMap (block n C C) + -> MaybeO x (block n C O) + -> Graph' block n e x + +-- | Maybe type indexed by open/closed +data MaybeO ex t where + JustO :: t -> MaybeO O t + NothingO :: MaybeO C t + +-- | Maybe type indexed by closed/open +data MaybeC ex t where + JustC :: t -> MaybeC C t + NothingC :: MaybeC O t + +-- | Dynamic shape value +data Shape ex where + Closed :: Shape C + Open :: Shape O + +-- | Either type indexed by closed/open using type families +type family IndexedCO ex a b :: * +type instance IndexedCO C a b = a +type instance IndexedCO O a b = b + +instance Functor (MaybeO ex) where + fmap _ NothingO = NothingO + fmap f (JustO a) = JustO (f a) + +instance Functor (MaybeC ex) where + fmap _ NothingC = NothingC + fmap f (JustC a) = JustC (f a) + +------------------------------- +-- | Gives access to the anchor points for +-- nonlocal edges as well as the edges themselves +class NonLocal thing where + entryLabel :: thing C x -> Label -- ^ The label of a first node or block + successors :: thing e C -> [Label] -- ^ Gives control-flow successors + +instance NonLocal n => NonLocal (Block n) where + entryLabel (BFirst n) = entryLabel n + entryLabel (BHead h _) = entryLabel h + entryLabel (BClosed h _) = entryLabel h + successors (BLast n) = successors n + successors (BTail _ t) = successors t + successors (BClosed _ t) = successors t + +------------------------------ +emptyBody :: LabelMap (thing C C) +emptyBody = mapEmpty + +addBlock :: NonLocal thing => thing C C -> LabelMap (thing C C) -> LabelMap (thing C C) +addBlock b body = nodupsInsert (entryLabel b) b body + where nodupsInsert l b body = if mapMember l body then + error $ "duplicate label " ++ show l ++ " in graph" + else + mapInsert l b body + +bodyList :: NonLocal (block n) => Body' block n -> [(Label,block n C C)] +bodyList (Body body) = mapToList body + +-- | Maps over all nodes in a graph. +mapGraph :: (forall e x. n e x -> n' e x) -> Graph n e x -> Graph n' e x +mapGraph _ GNil = GNil +mapGraph f (GUnit b) = GUnit (mapBlock f b) +mapGraph f (GMany x y z) + = GMany (mapMaybeO f x) + (mapMap (mapBlock f) y) + (mapMaybeO f z) + +mapMaybeO :: (forall e x. n e x -> n' e x) -> MaybeO ex (Block n e x) -> MaybeO ex (Block n' e x) +mapMaybeO _ NothingO = NothingO +mapMaybeO f (JustO b) = JustO (mapBlock f b) + +mapMaybeC :: (forall e x. n e x -> n' e x) -> MaybeC ex (Block n e x) -> MaybeC ex (Block n' e x) +mapMaybeC _ NothingC = NothingC +mapMaybeC f (JustC b) = JustC (mapBlock f b) + +mapBlock :: (forall e x. n e x -> n' e x) -> Block n e x -> Block n' e x +mapBlock f (BFirst n) = BFirst (f n) +mapBlock f (BMiddle n) = BMiddle (f n) +mapBlock f (BLast n) = BLast (f n) +mapBlock f (BCat b1 b2) = BCat (mapBlock f b1) (mapBlock f b2) +mapBlock f (BHead b n) = BHead (mapBlock f b) (f n) +mapBlock f (BTail n b) = BTail (f n) (mapBlock f b) +mapBlock f (BClosed b1 b2) = BClosed (mapBlock f b1) (mapBlock f b2) diff -Nru ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl/GraphUtil.hs ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl/GraphUtil.hs --- ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl/GraphUtil.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl/GraphUtil.hs 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,124 @@ +{-# LANGUAGE GADTs, RankNTypes, ScopedTypeVariables #-} + +-- N.B. addBasicBlocks won't work on OO without a Node (branch/label) constraint + +module Compiler.Hoopl.GraphUtil + ( splice, gSplice , cat , bodyGraph, bodyUnion + , frontBiasBlock, backBiasBlock + ) + +where + +import Compiler.Hoopl.Collections +import Compiler.Hoopl.Graph +import Compiler.Hoopl.Label + +bodyGraph :: Body n -> Graph n C C +bodyGraph b = GMany NothingO b NothingO + +splice :: forall block n e a x . NonLocal (block n) => + (forall e x . block n e O -> block n O x -> block n e x) + -> (Graph' block n e a -> Graph' block n a x -> Graph' block n e x) +splice bcat = sp + where sp :: forall e a x . + Graph' block n e a -> Graph' block n a x -> Graph' block n e x + + sp GNil g2 = g2 + sp g1 GNil = g1 + + sp (GUnit b1) (GUnit b2) = GUnit (b1 `bcat` b2) + + sp (GUnit b) (GMany (JustO e) bs x) = GMany (JustO (b `bcat` e)) bs x + + sp (GMany e bs (JustO x)) (GUnit b2) = GMany e bs (JustO (x `bcat` b2)) + + sp (GMany e1 bs1 (JustO x1)) (GMany (JustO e2) b2 x2) + = GMany e1 (b1 `bodyUnion` b2) x2 + where b1 = addBlock (x1 `bcat` e2) bs1 + + sp (GMany e1 b1 NothingO) (GMany NothingO b2 x2) + = GMany e1 (b1 `bodyUnion` b2) x2 + + sp _ _ = error "bogus GADT match failure" + +bodyUnion :: forall a . LabelMap a -> LabelMap a -> LabelMap a +bodyUnion = mapUnionWithKey nodups + where nodups l _ _ = error $ "duplicate blocks with label " ++ show l + +gSplice :: NonLocal n => Graph n e a -> Graph n a x -> Graph n e x +gSplice = splice cat + +cat :: Block n e O -> Block n O x -> Block n e x +cat b1@(BFirst {}) (BMiddle n) = BHead b1 n +cat b1@(BFirst {}) b2@(BLast{}) = BClosed b1 b2 +cat b1@(BFirst {}) b2@(BTail{}) = BClosed b1 b2 +cat b1@(BFirst {}) (BCat b2 b3) = (b1 `cat` b2) `cat` b3 +cat b1@(BHead {}) (BCat b2 b3) = (b1 `cat` b2) `cat` b3 +cat b1@(BHead {}) (BMiddle n) = BHead b1 n +cat b1@(BHead {}) b2@(BLast{}) = BClosed b1 b2 +cat b1@(BHead {}) b2@(BTail{}) = BClosed b1 b2 +cat b1@(BMiddle {}) b2@(BMiddle{}) = BCat b1 b2 +cat (BMiddle n) b2@(BLast{}) = BTail n b2 +cat b1@(BMiddle {}) b2@(BCat{}) = BCat b1 b2 +cat (BMiddle n) b2@(BTail{}) = BTail n b2 +cat (BCat b1 b2) b3@(BLast{}) = b1 `cat` (b2 `cat` b3) +cat (BCat b1 b2) b3@(BTail{}) = b1 `cat` (b2 `cat` b3) +cat b1@(BCat {}) b2@(BCat{}) = BCat b1 b2 +cat b1@(BCat {}) b2@(BMiddle{}) = BCat b1 b2 + + +---------------------------------------------------------------- + +-- | A block is "front biased" if the left child of every +-- concatenation operation is a node, not a general block; a +-- front-biased block is analogous to an ordinary list. If a block is +-- front-biased, then its nodes can be traversed from front to back +-- without general recusion; tail recursion suffices. Not all shapes +-- can be front-biased; a closed/open block is inherently back-biased. + +frontBiasBlock :: Block n e x -> Block n e x +frontBiasBlock b@(BFirst {}) = b +frontBiasBlock b@(BMiddle {}) = b +frontBiasBlock b@(BLast {}) = b +frontBiasBlock b@(BCat {}) = rotate b + where -- rotate and append ensure every left child of ZCat is ZMiddle + -- provided 2nd argument to append already has this property + rotate :: Block n O O -> Block n O O + append :: Block n O O -> Block n O O -> Block n O O + rotate (BCat h t) = append h (rotate t) + rotate b@(BMiddle {}) = b + append b@(BMiddle {}) t = b `BCat` t + append (BCat b1 b2) b3 = b1 `append` (b2 `append` b3) +frontBiasBlock b@(BHead {}) = b -- back-biased by nature; cannot fix +frontBiasBlock b@(BTail {}) = b -- statically front-biased +frontBiasBlock (BClosed h t) = shiftRight h t + where shiftRight :: Block n C O -> Block n O C -> Block n C C + shiftRight (BHead b1 b2) b3 = shiftRight b1 (BTail b2 b3) + shiftRight b1@(BFirst {}) b2 = BClosed b1 b2 + +-- | A block is "back biased" if the right child of every +-- concatenation operation is a node, not a general block; a +-- back-biased block is analogous to a snoc-list. If a block is +-- back-biased, then its nodes can be traversed from back to back +-- without general recusion; tail recursion suffices. Not all shapes +-- can be back-biased; an open/closed block is inherently front-biased. + +backBiasBlock :: Block n e x -> Block n e x +backBiasBlock b@(BFirst {}) = b +backBiasBlock b@(BMiddle {}) = b +backBiasBlock b@(BLast {}) = b +backBiasBlock b@(BCat {}) = rotate b + where -- rotate and append ensure every right child of Cat is Middle + -- provided 1st argument to append already has this property + rotate :: Block n O O -> Block n O O + append :: Block n O O -> Block n O O -> Block n O O + rotate (BCat h t) = append (rotate h) t + rotate b@(BMiddle {}) = b + append h b@(BMiddle {}) = h `BCat` b + append b1 (BCat b2 b3) = (b1 `append` b2) `append` b3 +backBiasBlock b@(BHead {}) = b -- statically back-biased +backBiasBlock b@(BTail {}) = b -- front-biased by nature; cannot fix +backBiasBlock (BClosed h t) = shiftLeft h t + where shiftLeft :: Block n C O -> Block n O C -> Block n C C + shiftLeft b1 (BTail b2 b3) = shiftLeft (BHead b1 b2) b3 + shiftLeft b1 b2@(BLast {}) = BClosed b1 b2 diff -Nru ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl/Haddock.hs ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl/Haddock.hs --- ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl/Haddock.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl/Haddock.hs 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,8 @@ +{-# LANGUAGE GADTs #-} +module Haddock +where + +data Lit a where + I :: Int -> Lit Int -- ^ an integer + B :: Bool -> Lit Bool -- ^ a Boolean + diff -Nru ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl/HISTORY ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl/HISTORY --- ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl/HISTORY 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl/HISTORY 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,54 @@ + +{- Notes about the genesis of Hoopl7 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Hoopl7 has the following major chages + +a) GMany has symmetric entry and exit +b) GMany closed-entry does not record a BlockId +c) GMany open-exit does not record a BlockId +d) The body of a GMany is called Body +e) A Body is just a list of blocks, not a map. I've argued + elsewhere that this is consistent with (c) + +A consequence is that Graph is no longer an instance of Edges, +but nevertheless I managed to keep the ARF and ARB signatures +nice and uniform. + +This was made possible by + +* FwdTransfer looks like this: + type FwdTransfer n f + = forall e x. n e x -> Fact e f -> Fact x f + type family Fact x f :: * + type instance Fact C f = FactBase f + type instance Fact O f = f + + Note that the incoming fact is a Fact (not just 'f' as in Hoopl5,6). + It's up to the *transfer function* to look up the appropriate fact + in the FactBase for a closed-entry node. Example: + constProp (Label l) fb = lookupFact fb l + That is how Hoopl can avoid having to know the block-id for the + first node: it defers to the client. + + [Side note: that means the client must know about + bottom, in case the looupFact returns Nothing] + +* Note also that FwdTransfer *returns* a Fact too; + that is, the types in both directions are symmetrical. + Previously we returned a [(BlockId,f)] but I could not see + how to make everything line up if we do this. + + Indeed, the main shortcoming of Hoopl7 is that we are more + or less forced into this uniform representation of the facts + flowing into or out of a closed node/block/graph, whereas + previously we had more flexibility. + + In exchange the code is neater, with fewer distinct types. + And morally a FactBase is equivalent to [(BlockId,f)] and + nearly equivalent to (BlockId -> f). + +* I've realised that forwardBlockList and backwardBlockList + both need (Edges n), and that goes everywhere. + +* I renamed BlockId to Label +-} diff -Nru ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl/Label.hs ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl/Label.hs --- ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl/Label.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl/Label.hs 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,104 @@ +{-# LANGUAGE TypeFamilies #-} +module Compiler.Hoopl.Label + ( Label + , freshLabel + , LabelSet, LabelMap + , FactBase, noFacts, lookupFact + + , uniqueToLbl -- MkGraph and GHC use only + , lblToUnique -- GHC use only + ) + +where + +import Compiler.Hoopl.Collections +import Compiler.Hoopl.Unique + +----------------------------------------------------------------------------- +-- Label +----------------------------------------------------------------------------- + +newtype Label = Label { lblToUnique :: Unique } + deriving (Eq, Ord) + +uniqueToLbl :: Unique -> Label +uniqueToLbl = Label + +instance Show Label where + show (Label n) = "L" ++ show n + +freshLabel :: UniqueMonad m => m Label +freshLabel = freshUnique >>= return . uniqueToLbl + +----------------------------------------------------------------------------- +-- LabelSet + +newtype LabelSet = LS UniqueSet deriving (Eq, Ord, Show) + +instance IsSet LabelSet where + type ElemOf LabelSet = Label + + setNull (LS s) = setNull s + setSize (LS s) = setSize s + setMember (Label k) (LS s) = setMember k s + + setEmpty = LS setEmpty + setSingleton (Label k) = LS (setSingleton k) + setInsert (Label k) (LS s) = LS (setInsert k s) + setDelete (Label k) (LS s) = LS (setDelete k s) + + setUnion (LS x) (LS y) = LS (setUnion x y) + setDifference (LS x) (LS y) = LS (setDifference x y) + setIntersection (LS x) (LS y) = LS (setIntersection x y) + setIsSubsetOf (LS x) (LS y) = setIsSubsetOf x y + + setFold k z (LS s) = setFold (k . uniqueToLbl) z s + + setElems (LS s) = map uniqueToLbl (setElems s) + setFromList ks = LS (setFromList (map lblToUnique ks)) + +----------------------------------------------------------------------------- +-- LabelMap + +newtype LabelMap v = LM (UniqueMap v) deriving (Eq, Ord, Show) + +instance IsMap LabelMap where + type KeyOf LabelMap = Label + + mapNull (LM m) = mapNull m + mapSize (LM m) = mapSize m + mapMember (Label k) (LM m) = mapMember k m + mapLookup (Label k) (LM m) = mapLookup k m + mapFindWithDefault def (Label k) (LM m) = mapFindWithDefault def k m + + mapEmpty = LM mapEmpty + mapSingleton (Label k) v = LM (mapSingleton k v) + mapInsert (Label k) v (LM m) = LM (mapInsert k v m) + mapDelete (Label k) (LM m) = LM (mapDelete k m) + + mapUnion (LM x) (LM y) = LM (mapUnion x y) + mapUnionWithKey f (LM x) (LM y) = LM (mapUnionWithKey (f . uniqueToLbl) x y) + mapDifference (LM x) (LM y) = LM (mapDifference x y) + mapIntersection (LM x) (LM y) = LM (mapIntersection x y) + mapIsSubmapOf (LM x) (LM y) = mapIsSubmapOf x y + + mapMap f (LM m) = LM (mapMap f m) + mapMapWithKey f (LM m) = LM (mapMapWithKey (f . uniqueToLbl) m) + mapFold k z (LM m) = mapFold k z m + mapFoldWithKey k z (LM m) = mapFoldWithKey (k . uniqueToLbl) z m + + mapElems (LM m) = mapElems m + mapKeys (LM m) = map uniqueToLbl (mapKeys m) + mapToList (LM m) = [(uniqueToLbl k, v) | (k, v) <- mapToList m] + mapFromList assocs = LM (mapFromList [(lblToUnique k, v) | (k, v) <- assocs]) + +----------------------------------------------------------------------------- +-- FactBase + +type FactBase f = LabelMap f + +noFacts :: FactBase f +noFacts = mapEmpty + +lookupFact :: Label -> FactBase f -> Maybe f +lookupFact = mapLookup diff -Nru ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl/mkfile ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl/mkfile --- ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl/mkfile 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl/mkfile 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,3 @@ +TOP=../.. + +<$TOP/subdir.mk diff -Nru ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl/MkGraph.hs ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl/MkGraph.hs --- ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl/MkGraph.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl/MkGraph.hs 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,252 @@ +{-# LANGUAGE ScopedTypeVariables, GADTs, TypeSynonymInstances, FlexibleInstances, RankNTypes #-} +module Compiler.Hoopl.MkGraph + ( AGraph, graphOfAGraph, aGraphOfGraph + , (<*>), (|*><*|), catGraphs, addEntrySeq, addExitSeq, addBlocks, unionBlocks + , emptyGraph, emptyClosedGraph, withFresh + , mkFirst, mkMiddle, mkMiddles, mkLast, mkBranch, mkLabel, mkWhileDo + , IfThenElseable(mkIfThenElse) + , mkEntry, mkExit + , HooplNode(mkLabelNode, mkBranchNode) + ) +where + +import Compiler.Hoopl.Label (Label, uniqueToLbl) +import Compiler.Hoopl.Graph +import qualified Compiler.Hoopl.GraphUtil as U +import Compiler.Hoopl.Unique +import Control.Monad (liftM2) + +{-| +As noted in the paper, we can define a single, polymorphic type of +splicing operation with the very polymorphic type +@ + AGraph n e a -> AGraph n a x -> AGraph n e x +@ +However, we feel that this operation is a bit /too/ polymorphic, +and that it's too easy for clients to use it blindly without +thinking. We therfore split it into two operations, '<*>' and '|*><*|', +which are supplemented by other functions: + + * The '<*>' operator is true concatenation, for connecting open graphs. + Control flows from the left graph to the right graph. + + * The '|*><*|' operator splices together two graphs at a closed + point. Nothing is known about control flow. The vertical bar + stands for "closed point" just as the angle brackets above stand + for "open point". Unlike the <*> operator, the |*><*| can create + a control-flow graph with dangling outedges or unreachable blocks. + The operator must be used carefully, so we have chosen a long name + on purpose, to help call people's attention to what they're doing. + + * The operator 'addBlocks' adds a set of basic blocks (represented + as a closed/closed 'AGraph' to an existing graph, without changing + the shape of the existing graph. In some cases, it's necessary to + introduce a branch and a label to 'get around' the blocks added, + so this operator, and other functions based on it, requires a + 'HooplNode' type-class constraint and is available only on AGraph, + not Graph. + + * We have discussed a dynamic assertion about dangling outedges and + unreachable blocks, but nothing is implemented yet. + +-} + + + +class GraphRep g where + -- | An empty graph that is open at entry and exit. + -- It is the left and right identity of '<*>'. + emptyGraph :: g n O O + -- | An empty graph that is closed at entry and exit. + -- It is the left and right identity of '|*><*|'. + emptyClosedGraph :: g n C C + -- | Create a graph from a first node + mkFirst :: n C O -> g n C O + -- | Create a graph from a middle node + mkMiddle :: n O O -> g n O O + -- | Create a graph from a last node + mkLast :: n O C -> g n O C + mkFirst = mkExit . BFirst + mkLast = mkEntry . BLast + infixl 3 <*> + infixl 2 |*><*| + -- | Concatenate two graphs; control flows from left to right. + (<*>) :: NonLocal n => g n e O -> g n O x -> g n e x + -- | Splice together two graphs at a closed point; nothing is known + -- about control flow. + (|*><*|) :: NonLocal n => g n e C -> g n C x -> g n e x + -- | Conveniently concatenate a sequence of open/open graphs using '<*>'. + catGraphs :: NonLocal n => [g n O O] -> g n O O + catGraphs = foldr (<*>) emptyGraph + + -- | Create a graph that defines a label + mkLabel :: HooplNode n => Label -> g n C O -- definition of the label + -- | Create a graph that branches to a label + mkBranch :: HooplNode n => Label -> g n O C -- unconditional branch to the label + + -- | Conveniently concatenate a sequence of middle nodes to form + -- an open/open graph. + mkMiddles :: NonLocal n => [n O O] -> g n O O + + mkLabel id = mkFirst $ mkLabelNode id + mkBranch target = mkLast $ mkBranchNode target + mkMiddles ms = catGraphs $ map mkMiddle ms + + -- | Create a graph containing only an entry sequence + mkEntry :: Block n O C -> g n O C + -- | Create a graph containing only an exit sequence + mkExit :: Block n C O -> g n C O + +instance GraphRep Graph where + emptyGraph = GNil + emptyClosedGraph = GMany NothingO emptyBody NothingO + (<*>) = U.gSplice + (|*><*|) = U.gSplice + mkMiddle = GUnit . BMiddle + mkExit block = GMany NothingO emptyBody (JustO block) + mkEntry block = GMany (JustO block) emptyBody NothingO + +instance GraphRep AGraph where + emptyGraph = aGraphOfGraph emptyGraph + emptyClosedGraph = aGraphOfGraph emptyClosedGraph + (<*>) = liftA2 (<*>) + (|*><*|) = liftA2 (|*><*|) + mkMiddle = aGraphOfGraph . mkMiddle + mkExit = aGraphOfGraph . mkExit + mkEntry = aGraphOfGraph . mkEntry + + +-- | The type of abstract graphs. Offers extra "smart constructors" +-- that may consume fresh labels during construction. +newtype AGraph n e x = + A { graphOfAGraph :: forall m. UniqueMonad m => + m (Graph n e x) -- ^ Take an abstract 'AGraph' + -- and make a concrete (if monadic) + -- 'Graph'. + } + +-- | Take a graph and make it abstract. +aGraphOfGraph :: Graph n e x -> AGraph n e x +aGraphOfGraph g = A (return g) + + +-- | The 'Labels' class defines things that can be lambda-bound +-- by an argument to 'withFreshLabels'. Such an argument may +-- lambda-bind a single 'Label', or if multiple labels are needed, +-- it can bind a tuple. Tuples can be nested, so arbitrarily many +-- fresh labels can be acquired in a single call. +-- +-- For example usage see implementations of 'mkIfThenElse' and 'mkWhileDo'. +class Uniques u where + withFresh :: (u -> AGraph n e x) -> AGraph n e x + +instance Uniques Unique where + withFresh f = A $ freshUnique >>= (graphOfAGraph . f) + +instance Uniques Label where + withFresh f = A $ freshUnique >>= (graphOfAGraph . f . uniqueToLbl) + +-- | Lifts binary 'Graph' functions into 'AGraph' functions. +liftA2 :: (Graph n a b -> Graph n c d -> Graph n e f) + -> (AGraph n a b -> AGraph n c d -> AGraph n e f) +liftA2 f (A g) (A g') = A (liftM2 f g g') + +-- | Extend an existing 'AGraph' with extra basic blocks "out of line". +-- No control flow is implied. Simon PJ should give example use case. +addBlocks :: HooplNode n + => AGraph n e x -> AGraph n C C -> AGraph n e x +addBlocks (A g) (A blocks) = A $ g >>= \g -> blocks >>= add g + where add :: (UniqueMonad m, HooplNode n) + => Graph n e x -> Graph n C C -> m (Graph n e x) + add (GMany e body x) (GMany NothingO body' NothingO) = + return $ GMany e (body `U.bodyUnion` body') x + add g@GNil blocks = spliceOO g blocks + add g@(GUnit _) blocks = spliceOO g blocks + spliceOO :: (HooplNode n, UniqueMonad m) + => Graph n O O -> Graph n C C -> m (Graph n O O) + spliceOO g blocks = graphOfAGraph $ withFresh $ \l -> + A (return g) <*> mkBranch l |*><*| A (return blocks) |*><*| mkLabel l + +-- | For some graph-construction operations and some optimizations, +-- Hoopl must be able to create control-flow edges using a given node +-- type 'n'. +class NonLocal n => HooplNode n where + -- | Create a branch node, the source of a control-flow edge. + mkBranchNode :: Label -> n O C + -- | Create a label node, the target (destination) of a control-flow edge. + mkLabelNode :: Label -> n C O + +-------------------------------------------------------------- +-- Shiny Things +-------------------------------------------------------------- + +class IfThenElseable x where + -- | Translate a high-level if-then-else construct into an 'AGraph'. + -- The condition takes as arguments labels on the true-false branch + -- and returns a single-entry, two-exit graph which exits to + -- the two labels. + mkIfThenElse :: HooplNode n + => (Label -> Label -> AGraph n O C) -- ^ branch condition + -> AGraph n O x -- ^ code in the "then" branch + -> AGraph n O x -- ^ code in the "else" branch + -> AGraph n O x -- ^ resulting if-then-else construct + +mkWhileDo :: HooplNode n + => (Label -> Label -> AGraph n O C) -- ^ loop condition + -> AGraph n O O -- ^ body of the loop + -> AGraph n O O -- ^ the final while loop + +instance IfThenElseable O where + mkIfThenElse cbranch tbranch fbranch = withFresh $ \(endif, ltrue, lfalse) -> + cbranch ltrue lfalse |*><*| + mkLabel ltrue <*> tbranch <*> mkBranch endif |*><*| + mkLabel lfalse <*> fbranch <*> mkBranch endif |*><*| + mkLabel endif + +instance IfThenElseable C where + mkIfThenElse cbranch tbranch fbranch = withFresh $ \(ltrue, lfalse) -> + cbranch ltrue lfalse |*><*| + mkLabel ltrue <*> tbranch |*><*| + mkLabel lfalse <*> fbranch + +mkWhileDo cbranch body = withFresh $ \(test, head, endwhile) -> + -- Forrest Baskett's while-loop layout + mkBranch test |*><*| + mkLabel head <*> body <*> mkBranch test |*><*| + mkLabel test <*> cbranch head endwhile |*><*| + mkLabel endwhile + +-------------------------------------------------------------- +-- Boring instance declarations +-------------------------------------------------------------- + + +instance (Uniques u1, Uniques u2) => Uniques (u1, u2) where + withFresh f = withFresh $ \u1 -> + withFresh $ \u2 -> + f (u1, u2) + +instance (Uniques u1, Uniques u2, Uniques u3) => Uniques (u1, u2, u3) where + withFresh f = withFresh $ \u1 -> + withFresh $ \u2 -> + withFresh $ \u3 -> + f (u1, u2, u3) + +instance (Uniques u1, Uniques u2, Uniques u3, Uniques u4) => Uniques (u1, u2, u3, u4) where + withFresh f = withFresh $ \u1 -> + withFresh $ \u2 -> + withFresh $ \u3 -> + withFresh $ \u4 -> + f (u1, u2, u3, u4) + +--------------------------------------------- +-- deprecated legacy functions + +{-# DEPRECATED addEntrySeq, addExitSeq, unionBlocks "use |*><*| instead" #-} +addEntrySeq :: NonLocal n => AGraph n O C -> AGraph n C x -> AGraph n O x +addExitSeq :: NonLocal n => AGraph n e C -> AGraph n C O -> AGraph n e O +unionBlocks :: NonLocal n => AGraph n C C -> AGraph n C C -> AGraph n C C + +addEntrySeq = (|*><*|) +addExitSeq = (|*><*|) +unionBlocks = (|*><*|) diff -Nru ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl/NOTES ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl/NOTES --- ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl/NOTES 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl/NOTES 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,64 @@ +Simon and John, + +I've spent yet another evening on Hoopl---I implemented fold-style +dataflow (as opposed to the concatMap style we have). I'm quite happy +with the fold stuff---take a look at DataflowFold.hs and the 'aff' +functions and see if you agree. If you like it, we will save a +tremendous number of constructions and deconstructions in common cases +where nodes are not rewritten. Perhaps we should keep both alive and +measure? + +I used the insights I got doing DataflowFold.hs to tighten up John's +revision of Dataflow.hs. All I did was generalize arfCat and arbCat +so that I could use them more aggressively. I quite like the results. + +Further observations: + + The code for arbGraph and arfGraph is isomorphic---just substitute 'f' + for 'b' and nothing else changes. Likewise for arbBlock and arfBlock. + The graph functions are 11 lines apiece and the block functions are 7 + lines apiece, so it is not worth trying to abstract to save 18 lines, + but it is interesting and maybe something that should be noted in the + paper. + + arbNode and arfNode are fundamentally different. + They could be made more similar if arbNode produced and arfNode + accepted Fact e f instead of 'f', but even so a fundamental difference + remains: in the forward case, the input fact goes into the RG, and in + the backward case it is the output fact. + + It is a nuisance passing 'pass' to every function. If 'pass' goes + only to analyzeAndRewrite[FB]wd', then we could simplify by putting + the node, cat, block, body, and graph functions inside. We could + start writing code like this: + + cat :: (thing1 -> info1 -> FuelMonad (RG f n e a, info1')) + -> (thing2 -> info2 -> FuelMonad (RG f n a x, info1)) + -> (thing1 -> thing2 -> info2 -> FuelMonad (RG f n e x, info1')) + cat arb1 arb2 thing1 thing2 f = do { (g2,f2) <- arb2 thing2 f + ; (g1,f1) <- arb1 thing1 f2 + ; return (g1 `rgCat` g2, f1) } + block :: Edges n => ARB (Block n) n + block (BFirst n) = node n + block (BMiddle n) = node n + block (BLast n) = node n + block (BCat b1 b2) = (block `cat` block) b1 b2 + + graph :: Edges n => ARBX (Graph n) n + graph (GNil) = \f -> return (rgnil, f) + graph (GUnit b) = block b + graph (GMany NothingO b NothingO) = body b + graph (GMany NothingO b (JustO x)) = (body `cat` arbx block) b x + graph (GMany (JustO e) b NothingO) = (block `cat` body) e b + graph (GMany (JustO e) b (JustO x)) + = (uncurry (cat block body) `cat` arbx block) (e, b) x + + I think this would be very nice stuff to show in the paper---a lot + nicer than the monadic madness in our submission---but it would + require a little more explanation to make sure the reader + understands where the pass comes from. + +Your opinions are solicited! + + +Norman diff -Nru ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl/OldDataflow.hs ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl/OldDataflow.hs --- ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl/OldDataflow.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl/OldDataflow.hs 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,696 @@ +{-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies, MultiParamTypeClasses #-} +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} -- bug in GHC + +{- Notes about the genesis of Hoopl7 +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Hoopl7 has the following major chages + +a) GMany has symmetric entry and exit +b) GMany closed-entry does not record a BlockId +c) GMany open-exit does not record a BlockId +d) The body of a GMany is called Body +e) A Body is just a list of blocks, not a map. I've argued + elsewhere that this is consistent with (c) + +A consequence is that Graph is no longer an instance of NonLocal, +but nevertheless I managed to keep the ARF and ARB signatures +nice and uniform. + +This was made possible by + +* FwdTransfer looks like this: + type FwdTransfer n f + = forall e x. n e x -> Fact e f -> Fact x f + type family Fact x f :: * + type instance Fact C f = FactBase f + type instance Fact O f = f + + Note that the incoming fact is a Fact (not just 'f' as in Hoopl5,6). + It's up to the *transfer function* to look up the appropriate fact + in the FactBase for a closed-entry node. Example: + constProp (Label l) fb = lookupFact fb l + That is how Hoopl can avoid having to know the block-id for the + first node: it defers to the client. + + [Side note: that means the client must know about + bottom, in case the looupFact returns Nothing] + +* Note also that FwdTransfer *returns* a Fact too; + that is, the types in both directions are symmetrical. + Previously we returned a [(BlockId,f)] but I could not see + how to make everything line up if we do this. + + Indeed, the main shortcoming of Hoopl7 is that we are more + or less forced into this uniform representation of the facts + flowing into or out of a closed node/block/graph, whereas + previously we had more flexibility. + + In exchange the code is neater, with fewer distinct types. + And morally a FactBase is equivalent to [(BlockId,f)] and + nearly equivalent to (BlockId -> f). + +* I've realised that forwardBlockList and backwardBlockList + both need (NonLocal n), and that goes everywhere. + +* I renamed BlockId to Label +-} + +module Compiler.Hoopl.OldDataflow + ( DataflowLattice(..), JoinFun, OldFact(..), NewFact(..), Fact + , ChangeFlag(..), changeIf + , FwdPass(..), FwdTransfer, mkFTransfer, mkFTransfer', getFTransfers + , FwdRes(..), FwdRewrite, mkFRewrite, mkFRewrite', getFRewrites + , BwdPass(..), BwdTransfer, mkBTransfer, mkBTransfer', getBTransfers + , BwdRes(..), BwdRewrite, mkBRewrite, mkBRewrite', getBRewrites + , analyzeAndRewriteFwd, analyzeAndRewriteBwd + , analyzeAndRewriteFwd', analyzeAndRewriteBwd' + ) +where + +import Data.Maybe + +import Compiler.Hoopl.Fuel +import Compiler.Hoopl.Graph +import Compiler.Hoopl.MkGraph +import qualified Compiler.Hoopl.GraphUtil as U +import Compiler.Hoopl.Label +import Compiler.Hoopl.Util + +----------------------------------------------------------------------------- +-- DataflowLattice +----------------------------------------------------------------------------- + +data DataflowLattice a = DataflowLattice + { fact_name :: String -- Documentation + , fact_bot :: a -- Lattice bottom element + , fact_extend :: JoinFun a -- Lattice join plus change flag + -- (changes iff result > old fact) + } +-- ^ A transfer function might want to use the logging flag +-- to control debugging, as in for example, it updates just one element +-- in a big finite map. We don't want Hoopl to show the whole fact, +-- and only the transfer function knows exactly what changed. + +type JoinFun a = Label -> OldFact a -> NewFact a -> (ChangeFlag, a) + -- the label argument is for debugging purposes only +newtype OldFact a = OldFact a +newtype NewFact a = NewFact a + +data ChangeFlag = NoChange | SomeChange deriving (Eq, Ord) +changeIf :: Bool -> ChangeFlag +changeIf changed = if changed then SomeChange else NoChange + + +----------------------------------------------------------------------------- +-- Analyze and rewrite forward: the interface +----------------------------------------------------------------------------- + +data FwdPass n f + = FwdPass { fp_lattice :: DataflowLattice f + , fp_transfer :: FwdTransfer n f + , fp_rewrite :: FwdRewrite n f } + +newtype FwdTransfer n f + = FwdTransfers { getFTransfers :: + ( n C O -> f -> f + , n O O -> f -> f + , n O C -> f -> FactBase f + ) } + +newtype FwdRewrite n f + = FwdRewrites { getFRewrites :: + ( n C O -> f -> Maybe (FwdRes n f C O) + , n O O -> f -> Maybe (FwdRes n f O O) + , n O C -> f -> Maybe (FwdRes n f O C) + ) } +data FwdRes n f e x = FwdRes (AGraph n e x) (FwdRewrite n f) + -- result of a rewrite is a new graph and a (possibly) new rewrite function + +mkFTransfer :: (n C O -> f -> f) + -> (n O O -> f -> f) + -> (n O C -> f -> FactBase f) + -> FwdTransfer n f +mkFTransfer f m l = FwdTransfers (f, m, l) + +mkFTransfer' :: (forall e x . n e x -> f -> Fact x f) -> FwdTransfer n f +mkFTransfer' f = FwdTransfers (f, f, f) + +mkFRewrite :: (n C O -> f -> Maybe (FwdRes n f C O)) + -> (n O O -> f -> Maybe (FwdRes n f O O)) + -> (n O C -> f -> Maybe (FwdRes n f O C)) + -> FwdRewrite n f +mkFRewrite f m l = FwdRewrites (f, m, l) + +mkFRewrite' :: (forall e x . n e x -> f -> Maybe (FwdRes n f e x)) -> FwdRewrite n f +mkFRewrite' f = FwdRewrites (f, f, f) + + +type family Fact x f :: * +type instance Fact C f = FactBase f +type instance Fact O f = f + +analyzeAndRewriteFwd + :: forall n f. NonLocal n + => FwdPass n f + -> Body n -> FactBase f + -> FuelMonad (Body n, FactBase f) + +analyzeAndRewriteFwd pass body facts + = do { (rg, _) <- arfBody pass body facts + ; return (normaliseBody rg) } + +-- | if the graph being analyzed is open at the entry, there must +-- be no other entry point, or all goes horribly wrong... +analyzeAndRewriteFwd' + :: forall n f e x. NonLocal n + => FwdPass n f + -> Graph n e x -> Fact e f + -> FuelMonad (Graph n e x, FactBase f, MaybeO x f) +analyzeAndRewriteFwd' pass g f = + do (rg, fout) <- arfGraph pass g f + let (g', fb) = normalizeGraph rg + return (g', fb, distinguishedExitFact g' fout) + +distinguishedExitFact :: forall n e x f . Graph n e x -> Fact x f -> MaybeO x f +distinguishedExitFact g f = maybe g + where maybe :: Graph n e x -> MaybeO x f + maybe GNil = JustO f + maybe (GUnit {}) = JustO f + maybe (GMany _ _ x) = case x of NothingO -> NothingO + JustO _ -> JustO f + +---------------------------------------------------------------- +-- Forward Implementation +---------------------------------------------------------------- + + +type ARF' n f thing e x + = FwdPass n f -> thing e x -> f -> FuelMonad (RG f n e x, Fact x f) + -- ^ Analyze and rewrite forward + +type ARFX' n f thing e x + = FwdPass n f -> thing e x -> Fact e f -> FuelMonad (RG f n e x, Fact x f) + -- ^ Analyze and rewrite forward extended -- can take @FactBase f@ + +arfx :: NonLocal thing => ARF' n f thing C x -> ARFX' n f thing C x +arfx arf pass thing fb = + arf pass thing $ fromJust $ lookupFact (joinInFacts lattice fb) $ entryLabel thing + where lattice = fp_lattice pass + -- joinInFacts adds debugging information + +type ARF thing n = forall f e x . ARF' n f thing e x +type ARFX thing n = forall f e x . ARFX' n f thing e x + +arfNode :: (NonLocal n, ShapeLifter e x) => ARF' n f n e x +arfNode pass node f + = do { mb_g <- withFuel (frewrite pass node f) + ; case mb_g of + Nothing -> return (rgunit f (unit node), + ftransfer pass node f) + Just (FwdRes ag rw) -> do { g <- graphOfAGraph ag + ; let pass' = pass { fp_rewrite = rw } + ; arfGraph pass' g (elift node f) } } + +-- type demonstration +_arfBlock :: NonLocal n => ARF' n f (Block n) e x +_arfBlock = arfBlock + +arfBlock :: NonLocal n => ARF (Block n) n +-- Lift from nodes to blocks +arfBlock pass (BFirst node) = arfNode pass node +arfBlock pass (BMiddle node) = arfNode pass node +arfBlock pass (BLast node) = arfNode pass node +arfBlock pass (BCat b1 b2) = arfCat arfBlock arfBlock pass b1 b2 +arfBlock pass (BHead h n) = arfCat arfBlock arfNode pass h n +arfBlock pass (BTail n t) = arfCat arfNode arfBlock pass n t +arfBlock pass (BClosed h t) = arfCat arfBlock arfBlock pass h t + +arfCat :: (pass -> thing1 -> info1 -> FuelMonad (RG f n e a, info2)) + -> (pass -> thing2 -> info2 -> FuelMonad (RG f n a x, info2')) + -> (pass -> thing1 -> thing2 -> info1 -> FuelMonad (RG f n e x, info2')) +{-# INLINE arfCat #-} +arfCat arf1 arf2 pass thing1 thing2 f = do { (g1,f1) <- arf1 pass thing1 f + ; (g2,f2) <- arf2 pass thing2 f1 + ; return (g1 `rgCat` g2, f2) } + +arfBody :: NonLocal n + => FwdPass n f -> Body n -> FactBase f + -> FuelMonad (RG f n C C, FactBase f) + -- Outgoing factbase is restricted to Labels *not* in + -- in the Body; the facts for Labels *in* + -- the Body are in the BodyWithFacts +arfBody pass blocks init_fbase + = fixpoint True (fp_lattice pass) do_block init_fbase $ + forwardBlockList (factBaseLabels init_fbase) blocks + where + do_block b f = do (g, fb) <- arfBlock pass b $ lookupF pass (entryLabel b) f + return (g, factBaseList fb) + +arfGraph :: NonLocal n => ARFX (Graph n) n +-- Lift from blocks to graphs +arfGraph _ GNil = \f -> return (rgnil, f) +arfGraph pass (GUnit blk) = arfBlock pass blk +arfGraph pass (GMany NothingO body NothingO) = arfBody pass body +arfGraph pass (GMany NothingO body (JustO exit)) + = arfCat arfBody (arfx arfBlock) pass body exit +arfGraph pass (GMany (JustO entry) body NothingO) + = arfCat arfBlock arfBody pass entry body +arfGraph pass (GMany (JustO entry) body (JustO exit)) + = arfCat arfeb (arfx arfBlock) pass (entry, body) exit + where arfeb pass = uncurry $ arfCat arfBlock arfBody pass + + +-- Join all the incoming facts with bottom. +-- We know the results _shouldn't change_, but the transfer +-- functions might, for example, generate some debugging traces. +joinInFacts :: DataflowLattice f -> FactBase f -> FactBase f +joinInFacts (DataflowLattice {fact_bot = bot, fact_extend = fe}) fb = + mkFactBase $ map botJoin $ factBaseList fb + where botJoin (l, f) = (l, snd $ fe l (OldFact bot) (NewFact f)) + +forwardBlockList :: (NonLocal n, LabelsPtr entry) + => entry -> Body n -> [Block n C C] +-- This produces a list of blocks in order suitable for forward analysis, +-- along with the list of Labels it may depend on for facts. +forwardBlockList entries blks = postorder_dfs_from (bodyMap blks) entries + +----------------------------------------------------------------------------- +-- Backward analysis and rewriting: the interface +----------------------------------------------------------------------------- + +data BwdPass n f + = BwdPass { bp_lattice :: DataflowLattice f + , bp_transfer :: BwdTransfer n f + , bp_rewrite :: BwdRewrite n f } + +newtype BwdTransfer n f + = BwdTransfers { getBTransfers :: + ( n C O -> f -> f + , n O O -> f -> f + , n O C -> FactBase f -> f + ) } +newtype BwdRewrite n f + = BwdRewrites { getBRewrites :: + ( n C O -> f -> Maybe (BwdRes n f C O) + , n O O -> f -> Maybe (BwdRes n f O O) + , n O C -> FactBase f -> Maybe (BwdRes n f O C) + ) } +data BwdRes n f e x = BwdRes (AGraph n e x) (BwdRewrite n f) + +mkBTransfer :: (n C O -> f -> f) -> (n O O -> f -> f) -> + (n O C -> FactBase f -> f) -> BwdTransfer n f +mkBTransfer f m l = BwdTransfers (f, m, l) + +mkBTransfer' :: (forall e x . n e x -> Fact x f -> f) -> BwdTransfer n f +mkBTransfer' f = BwdTransfers (f, f, f) + +mkBRewrite :: (n C O -> f -> Maybe (BwdRes n f C O)) + -> (n O O -> f -> Maybe (BwdRes n f O O)) + -> (n O C -> FactBase f -> Maybe (BwdRes n f O C)) + -> BwdRewrite n f +mkBRewrite f m l = BwdRewrites (f, m, l) + +mkBRewrite' :: (forall e x . n e x -> Fact x f -> Maybe (BwdRes n f e x)) -> BwdRewrite n f +mkBRewrite' f = BwdRewrites (f, f, f) + + +----------------------------------------------------------------------------- +-- Backward implementation +----------------------------------------------------------------------------- + +type ARB' n f thing e x + = BwdPass n f -> thing e x -> Fact x f -> FuelMonad (RG f n e x, f) + +type ARBX' n f thing e x + = BwdPass n f -> thing e x -> Fact x f -> FuelMonad (RG f n e x, Fact e f) + +type ARB thing n = forall f e x. ARB' n f thing e x +type ARBX thing n = forall f e x. ARBX' n f thing e x + +arbx :: NonLocal thing => ARB' n f thing C x -> ARBX' n f thing C x +arbx arb pass thing f = do { (rg, f) <- arb pass thing f + ; let fb = joinInFacts (bp_lattice pass) $ + mkFactBase [(entryLabel thing, f)] + ; return (rg, fb) } + +arbNode :: (NonLocal n, ShapeLifter e x) => ARB' n f n e x +-- Lifts (BwdTransfer,BwdRewrite) to ARB_Node; +-- this time we do rewriting as well. +-- The ARB_Graph parameters specifies what to do with the rewritten graph +arbNode pass node f + = do { mb_g <- withFuel (brewrite pass node f) + ; case mb_g of + Nothing -> return (rgunit entry_f (unit node), entry_f) + where entry_f = btransfer pass node f + Just (BwdRes ag rw) -> do { g <- graphOfAGraph ag + ; let pass' = pass { bp_rewrite = rw } + ; (g, f) <- arbGraph pass' g f + ; return (g, elower (bp_lattice pass) node f)} } + +arbBlock :: NonLocal n => ARB (Block n) n +-- Lift from nodes to blocks +arbBlock pass (BFirst node) = arbNode pass node +arbBlock pass (BMiddle node) = arbNode pass node +arbBlock pass (BLast node) = arbNode pass node +arbBlock pass (BCat b1 b2) = arbCat arbBlock arbBlock pass b1 b2 +arbBlock pass (BHead h n) = arbCat arbBlock arbNode pass h n +arbBlock pass (BTail n t) = arbCat arbNode arbBlock pass n t +arbBlock pass (BClosed h t) = arbCat arbBlock arbBlock pass h t + +arbCat :: (pass -> thing1 -> info1 -> FuelMonad (RG f n e a, info1')) + -> (pass -> thing2 -> info2 -> FuelMonad (RG f n a x, info1)) + -> (pass -> thing1 -> thing2 -> info2 -> FuelMonad (RG f n e x, info1')) +{-# INLINE arbCat #-} +arbCat arb1 arb2 pass thing1 thing2 f = do { (g2,f2) <- arb2 pass thing2 f + ; (g1,f1) <- arb1 pass thing1 f2 + ; return (g1 `rgCat` g2, f1) } + +arbBody :: NonLocal n + => BwdPass n f -> Body n -> FactBase f + -> FuelMonad (RG f n C C, FactBase f) +arbBody pass blocks init_fbase + = fixpoint False (bp_lattice pass) do_block init_fbase $ + backwardBlockList blocks + where + do_block b f = do (g, f) <- arbBlock pass b f + return (g, [(entryLabel b, f)]) + +arbGraph :: NonLocal n => ARBX (Graph n) n +arbGraph _ GNil = \f -> return (rgnil, f) +arbGraph pass (GUnit blk) = arbBlock pass blk +arbGraph pass (GMany NothingO body NothingO) = arbBody pass body +arbGraph pass (GMany NothingO body (JustO exit)) = + arbCat arbBody (arbx arbBlock) pass body exit +arbGraph pass (GMany (JustO entry) body NothingO) = + arbCat arbBlock arbBody pass entry body +arbGraph pass (GMany (JustO entry) body (JustO exit)) = + arbCat arbeb (arbx arbBlock) pass (entry, body) exit + where arbeb pass = uncurry $ arbCat arbBlock arbBody pass + + +backwardBlockList :: NonLocal n => Body n -> [Block n C C] +-- This produces a list of blocks in order suitable for backward analysis, +-- along with the list of Labels it may depend on for facts. +backwardBlockList body = reachable ++ missing + where reachable = reverse $ forwardBlockList entries body + entries = externalEntryLabels body + all = bodyList body + missingLabels = + mkLabelSet (map fst all) `minusLabelSet` + mkLabelSet (map entryLabel reachable) + missing = map snd $ filter (flip elemLabelSet missingLabels . fst) all + +{- + +The forward and backward dataflow analyses now use postorder depth-first +order for faster convergence. + +The forward and backward cases are not dual. In the forward case, the +entry points are known, and one simply traverses the body blocks from +those points. In the backward case, something is known about the exit +points, but this information is essentially useless, because we don't +actually have a dual graph (that is, one with edges reversed) to +compute with. (Even if we did have a dual graph, it would not avail +us---a backward analysis must include reachable blocks that don't +reach the exit, as in a procedure that loops forever and has side +effects.) + +Since in the general case, no information is available about entry +points, I have put in a horrible hack. First, I assume that every +label defined but not used is an entry point. Then, because an entry +point might also be a loop header, I add, in arbitrary order, all the +remaining "missing" blocks. Needless to say, I am not pleased. +I am not satisfied. I am not Senator Morgan. + +Wait! I believe that the Right Thing here is to require that anyone +wishing to analyze a graph closed at the entry provide a way of +determining the entry points, if any, of that graph. This requirement +can apply equally to forward and backward analyses; I believe that +using the input FactBase to determine the entry points of a closed +graph is *also* a hack. + +NR + +-} + + +analyzeAndRewriteBwd + :: forall n f. NonLocal n + => BwdPass n f + -> Body n -> FactBase f + -> FuelMonad (Body n, FactBase f) + +analyzeAndRewriteBwd pass body facts + = do { (rg, _) <- arbBody pass body facts + ; return (normaliseBody rg) } + +-- | if the graph being analyzed is open at the exit, I don't +-- quite understand the implications of possible other exits +analyzeAndRewriteBwd' + :: forall n f e x. NonLocal n + => BwdPass n f + -> Graph n e x -> Fact x f + -> FuelMonad (Graph n e x, FactBase f, MaybeO e f) +analyzeAndRewriteBwd' pass g f = + do (rg, fout) <- arbGraph pass g f + let (g', fb) = normalizeGraph rg + return (g', fb, distinguishedEntryFact g' fout) + +distinguishedEntryFact :: forall n e x f . Graph n e x -> Fact e f -> MaybeO e f +distinguishedEntryFact g f = maybe g + where maybe :: Graph n e x -> MaybeO e f + maybe GNil = JustO f + maybe (GUnit {}) = JustO f + maybe (GMany e _ _) = case e of NothingO -> NothingO + JustO _ -> JustO f + +----------------------------------------------------------------------------- +-- fixpoint: finding fixed points +----------------------------------------------------------------------------- + +data TxFactBase n f + = TxFB { tfb_fbase :: FactBase f + , tfb_rg :: RG f n C C -- Transformed blocks + , tfb_cha :: ChangeFlag + , tfb_lbls :: LabelSet } + -- Note [TxFactBase change flag] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- Set the tfb_cha flag iff + -- (a) the fact in tfb_fbase for or a block L changes + -- (b) L is in tfb_lbls. + -- The tfb_lbls are all Labels of the *original* + -- (not transformed) blocks + +updateFact :: DataflowLattice f -> LabelSet -> (Label, f) + -> (ChangeFlag, FactBase f) + -> (ChangeFlag, FactBase f) +-- See Note [TxFactBase change flag] +updateFact lat lbls (lbl, new_fact) (cha, fbase) + | NoChange <- cha2 = (cha, fbase) + | lbl `elemLabelSet` lbls = (SomeChange, new_fbase) + | otherwise = (cha, new_fbase) + where + (cha2, res_fact) -- Note [Unreachable blocks] + = case lookupFact fbase lbl of + Nothing -> (SomeChange, snd $ join $ fact_bot lat) -- Note [Unreachable blocks] + Just old_fact -> join old_fact + where join old_fact = fact_extend lat lbl (OldFact old_fact) (NewFact new_fact) + new_fbase = extendFactBase fbase lbl res_fact + +fixpoint :: forall block n f. NonLocal (block n) + => Bool -- Going forwards? + -> DataflowLattice f + -> (block n C C -> FactBase f + -> FuelMonad (RG f n C C, [(Label, f)])) + -> FactBase f + -> [block n C C] + -> FuelMonad (RG f n C C, FactBase f) +fixpoint is_fwd lat do_block init_fbase untagged_blocks + = do { fuel <- getFuel + ; tx_fb <- loop fuel init_fbase + ; return (tfb_rg tx_fb, + tfb_fbase tx_fb `delFromFactBase` map fst blocks) } + -- The successors of the Graph are the the Labels for which + -- we have facts, that are *not* in the blocks of the graph + where + blocks = map tag untagged_blocks + where tag b = ((entryLabel b, b), if is_fwd then [entryLabel b] else successors b) + + tx_blocks :: [((Label, block n C C), [Label])] -- I do not understand this type + -> TxFactBase n f -> FuelMonad (TxFactBase n f) + tx_blocks [] tx_fb = return tx_fb + tx_blocks (((lbl,blk), deps):bs) tx_fb = tx_block lbl blk deps tx_fb >>= tx_blocks bs + -- "deps" == Labels the block may _depend_ upon for facts + + tx_block :: Label -> block n C C -> [Label] + -> TxFactBase n f -> FuelMonad (TxFactBase n f) + tx_block lbl blk deps tx_fb@(TxFB { tfb_fbase = fbase, tfb_lbls = lbls + , tfb_rg = blks, tfb_cha = cha }) + | is_fwd && not (lbl `elemFactBase` fbase) + = return tx_fb {tfb_lbls = lbls `unionLabelSet` mkLabelSet deps} -- Note [Unreachable blocks] + | otherwise + = do { (rg, out_facts) <- do_block blk fbase + ; let (cha',fbase') + = foldr (updateFact lat lbls) (cha,fbase) out_facts + lbls' = lbls `unionLabelSet` mkLabelSet deps + ; return (TxFB { tfb_lbls = lbls' + , tfb_rg = rg `rgCat` blks + , tfb_fbase = fbase', tfb_cha = cha' }) } + + loop :: Fuel -> FactBase f -> FuelMonad (TxFactBase n f) + loop fuel fbase + = do { let init_tx_fb = TxFB { tfb_fbase = fbase + , tfb_cha = NoChange + , tfb_rg = rgnilC + , tfb_lbls = emptyLabelSet } + ; tx_fb <- tx_blocks blocks init_tx_fb + ; case tfb_cha tx_fb of + NoChange -> return tx_fb + SomeChange -> do { setFuel fuel + ; loop fuel (tfb_fbase tx_fb) } } + +{- Note [Unreachable blocks] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +A block that is not in the domain of tfb_fbase is "currently unreachable". +A currently-unreachable block is not even analyzed. Reason: consider +constant prop and this graph, with entry point L1: + L1: x:=3; goto L4 + L2: x:=4; goto L4 + L4: if x>3 goto L2 else goto L5 +Here L2 is actually unreachable, but if we process it with bottom input fact, +we'll propagate (x=4) to L4, and nuke the otherwise-good rewriting of L4. + +* If a currently-unreachable block is not analyzed, then its rewritten + graph will not be accumulated in tfb_rg. And that is good: + unreachable blocks simply do not appear in the output. + +* Note that clients must be careful to provide a fact (even if bottom) + for each entry point. Otherwise useful blocks may be garbage collected. + +* Note that updateFact must set the change-flag if a label goes from + not-in-fbase to in-fbase, even if its fact is bottom. In effect the + real fact lattice is + UNR + bottom + the points above bottom + +* Even if the fact is going from UNR to bottom, we still call the + client's fact_extend function because it might give the client + some useful debugging information. + +* All of this only applies for *forward* fixpoints. For the backward + case we must treat every block as reachable; it might finish with a + 'return', and therefore have no successors, for example. +-} + +----------------------------------------------------------------------------- +-- RG: an internal data type for graphs under construction +-- TOTALLY internal to Hoopl; each block carries its fact +----------------------------------------------------------------------------- + +type RG f n e x = Graph' (FBlock f) n e x +data FBlock f n e x = FBlock f (Block n e x) + +--- constructors + +rgnil :: RG f n O O +rgnilC :: RG f n C C +rgunit :: f -> Block n e x -> RG f n e x +rgCat :: RG f n e a -> RG f n a x -> RG f n e x + +---- observers + +type BodyWithFacts n f = (Body n, FactBase f) +type GraphWithFacts n f e x = (Graph n e x, FactBase f) + -- A Graph together with the facts for that graph + -- The domains of the two maps should be identical + +normalizeGraph :: forall n f e x . + NonLocal n => RG f n e x -> GraphWithFacts n f e x +normaliseBody :: NonLocal n => RG f n C C -> BodyWithFacts n f + +normalizeGraph g = (graphMapBlocks dropFact g, facts g) + where dropFact (FBlock _ b) = b + facts :: RG f n e x -> FactBase f + facts GNil = noFacts + facts (GUnit _) = noFacts + facts (GMany _ body exit) = bodyFacts body `unionFactBase` exitFacts exit + exitFacts :: MaybeO x (FBlock f n C O) -> FactBase f + exitFacts NothingO = noFacts + exitFacts (JustO (FBlock f b)) = mkFactBase [(entryLabel b, f)] + bodyFacts :: Body' (FBlock f) n -> FactBase f + bodyFacts (BodyUnit (FBlock f b)) = mkFactBase [(entryLabel b, f)] + bodyFacts (b1 `BodyCat` b2) = bodyFacts b1 `unionFactBase` bodyFacts b2 + +normaliseBody rg = (body, fact_base) + where (GMany _ body _, fact_base) = normalizeGraph rg + +--- implementation of the constructors (boring) + +rgnil = GNil +rgnilC = GMany NothingO BodyEmpty NothingO + +rgunit f b@(BFirst {}) = gUnitCO (FBlock f b) +rgunit f b@(BMiddle {}) = gUnitOO (FBlock f b) +rgunit f b@(BLast {}) = gUnitOC (FBlock f b) +rgunit f b@(BCat {}) = gUnitOO (FBlock f b) +rgunit f b@(BHead {}) = gUnitCO (FBlock f b) +rgunit f b@(BTail {}) = gUnitOC (FBlock f b) +rgunit f b@(BClosed {}) = gUnitCC (FBlock f b) + +rgCat = U.splice fzCat + where fzCat (FBlock f b1) (FBlock _ b2) = FBlock f (b1 `U.cat` b2) + +---------------------------------------------------------------- +-- Utilities +---------------------------------------------------------------- + +-- Lifting based on shape: +-- - from nodes to blocks +-- - from facts to fact-like things +-- Lowering back: +-- - from fact-like things to facts +-- Note that the latter two functions depend only on the entry shape. +class ShapeLifter e x where + unit :: n e x -> Block n e x + elift :: NonLocal n => n e x -> f -> Fact e f + elower :: NonLocal n => DataflowLattice f -> n e x -> Fact e f -> f + ftransfer :: FwdPass n f -> n e x -> f -> Fact x f + btransfer :: BwdPass n f -> n e x -> Fact x f -> f + frewrite :: FwdPass n f -> n e x -> f -> Maybe (FwdRes n f e x) + brewrite :: BwdPass n f -> n e x -> Fact x f -> Maybe (BwdRes n f e x) + +instance ShapeLifter C O where + unit = BFirst + elift n f = mkFactBase [(entryLabel n, f)] + elower lat n fb = getFact lat (entryLabel n) fb + ftransfer (FwdPass {fp_transfer = FwdTransfers (ft, _, _)}) n f = ft n f + btransfer (BwdPass {bp_transfer = BwdTransfers (bt, _, _)}) n f = bt n f + frewrite (FwdPass {fp_rewrite = FwdRewrites (fr, _, _)}) n f = fr n f + brewrite (BwdPass {bp_rewrite = BwdRewrites (br, _, _)}) n f = br n f + +instance ShapeLifter O O where + unit = BMiddle + elift _ f = f + elower _ _ f = f + ftransfer (FwdPass {fp_transfer = FwdTransfers (_, ft, _)}) n f = ft n f + btransfer (BwdPass {bp_transfer = BwdTransfers (_, bt, _)}) n f = bt n f + frewrite (FwdPass {fp_rewrite = FwdRewrites (_, fr, _)}) n f = fr n f + brewrite (BwdPass {bp_rewrite = BwdRewrites (_, br, _)}) n f = br n f + +instance ShapeLifter O C where + unit = BLast + elift _ f = f + elower _ _ f = f + ftransfer (FwdPass {fp_transfer = FwdTransfers (_, _, ft)}) n f = ft n f + btransfer (BwdPass {bp_transfer = BwdTransfers (_, _, bt)}) n f = bt n f + frewrite (FwdPass {fp_rewrite = FwdRewrites (_, _, fr)}) n f = fr n f + brewrite (BwdPass {bp_rewrite = BwdRewrites (_, _, br)}) n f = br n f + +-- Fact lookup: the fact `orelse` bottom +lookupF :: FwdPass n f -> Label -> FactBase f -> f +lookupF = getFact . fp_lattice + +getFact :: DataflowLattice f -> Label -> FactBase f -> f +getFact lat l fb = case lookupFact fb l of Just f -> f + Nothing -> fact_bot lat diff -Nru ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl/Passes/DList.hs ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl/Passes/DList.hs --- ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl/Passes/DList.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl/Passes/DList.hs 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,45 @@ +{-# LANGUAGE GADTs #-} +{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-} + +module Compiler.Hoopl.Passes.DList + ( Doms, domEntry, domLattice + , domPass + ) +where + +import Compiler.Hoopl + + +type Doms = WithBot [Label] +-- ^ List of labels, extended with a standard bottom element + +-- | The fact that goes into the entry of a dominator analysis: the first node +-- is dominated only by the entry point, which is represented by the empty list +-- of labels. +domEntry :: Doms +domEntry = PElem [] + +domLattice :: DataflowLattice Doms +domLattice = addPoints "dominators" extend + +extend :: JoinFun [Label] +extend _ (OldFact l) (NewFact l') = (changeIf (l `lengthDiffers` j), j) + where j = lcs l l' + lcs :: [Label] -> [Label] -> [Label] -- longest common suffix + lcs l l' | length l > length l' = lcs (drop (length l - length l') l) l' + | length l < length l' = lcs l' l + | otherwise = dropUnlike l l' l + dropUnlike [] [] maybe_like = maybe_like + dropUnlike (x:xs) (y:ys) maybe_like = + dropUnlike xs ys (if x == y then maybe_like else xs) + dropUnlike _ _ _ = error "this can't happen" + + lengthDiffers [] [] = False + lengthDiffers (_:xs) (_:ys) = lengthDiffers xs ys + lengthDiffers [] (_:_) = True + lengthDiffers (_:_) [] = True + +-- | Dominator pass +domPass :: (NonLocal n, Monad m) => FwdPass m n Doms +domPass = FwdPass domLattice (mkFTransfer3 first (const id) distributeFact) noFwdRewrite + where first n = fmap (entryLabel n:) diff -Nru ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl/Passes/Dominator.hs ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl/Passes/Dominator.hs --- ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl/Passes/Dominator.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl/Passes/Dominator.hs 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,130 @@ +{-# LANGUAGE GADTs #-} +{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-} + +module Compiler.Hoopl.Passes.Dominator + ( Doms, DPath(..), domPath, domEntry, domLattice, extendDom + , DominatorNode(..), DominatorTree(..), tree + , immediateDominators + , domPass + ) +where + +import Data.Maybe + +import Compiler.Hoopl + + +type Doms = WithBot DPath +-- ^ List of labels, extended with a standard bottom element + +-- | The fact that goes into the entry of a dominator analysis: the first node +-- is dominated only by the entry point, which is represented by the empty list +-- of labels. +domEntry :: Doms +domEntry = PElem (DPath []) + +newtype DPath = DPath [Label] + -- ^ represents part of the domination relation: each label + -- in a list is dominated by all its successors. This is a newtype only so + -- we can give it a fancy Show instance. + +instance Show DPath where + show (DPath ls) = concat (foldr (\l path -> show l : " -> " : path) ["entry"] ls) + +domPath :: Doms -> [Label] +domPath Bot = [] -- lies: an unreachable node appears to be dominated by the entry +domPath (PElem (DPath ls)) = ls + +extendDom :: Label -> DPath -> DPath +extendDom l (DPath ls) = DPath (l:ls) + +domLattice :: DataflowLattice Doms +domLattice = addPoints "dominators" extend + +extend :: JoinFun DPath +extend _ (OldFact (DPath l)) (NewFact (DPath l')) = + (changeIf (l `lengthDiffers` j), DPath j) + where j = lcs l l' + lcs :: [Label] -> [Label] -> [Label] -- longest common suffix + lcs l l' | length l > length l' = lcs (drop (length l - length l') l) l' + | length l < length l' = lcs l' l + | otherwise = dropUnlike l l' l + dropUnlike [] [] maybe_like = maybe_like + dropUnlike (x:xs) (y:ys) maybe_like = + dropUnlike xs ys (if x == y then maybe_like else xs) + dropUnlike _ _ _ = error "this can't happen" + + lengthDiffers [] [] = False + lengthDiffers (_:xs) (_:ys) = lengthDiffers xs ys + lengthDiffers [] (_:_) = True + lengthDiffers (_:_) [] = True + + + +-- | Dominator pass +domPass :: (NonLocal n, Monad m) => FwdPass m n Doms +domPass = FwdPass domLattice (mkFTransfer3 first (const id) distributeFact) noFwdRewrite + where first n = fmap (extendDom $ entryLabel n) + +---------------------------------------------------------------- + +data DominatorNode = Entry | Labelled Label +data DominatorTree = Dominates DominatorNode [DominatorTree] +-- ^ This data structure is a *rose tree* in which each node may have +-- arbitrarily many children. Each node dominates all its descendants. + +-- | Map from a FactBase for dominator lists into a +-- dominator tree. +tree :: [(Label, Doms)] -> DominatorTree +tree facts = Dominates Entry $ merge $ map reverse $ map mkList facts + -- This code has been lightly tested. The key insight is this: to + -- find lists that all have the same head, convert from a list of + -- lists to a finite map, in 'children'. Then, to convert from the + -- finite map to list of dominator trees, use the invariant that + -- each key dominates all the lists of values. + where merge lists = mapTree $ children $ filter (not . null) lists + children = foldl addList noFacts + addList :: FactBase [[Label]] -> [Label] -> FactBase [[Label]] + addList map (x:xs) = mapInsert x (xs:existing) map + where existing = fromMaybe [] $ lookupFact x map + addList _ [] = error "this can't happen" + mapTree :: FactBase [[Label]] -> [DominatorTree] + mapTree map = [Dominates (Labelled x) (merge lists) | + (x, lists) <- mapToList map] + mkList (l, doms) = l : domPath doms + + +instance Show DominatorTree where + show = tree2dot + +-- | Given a dominator tree, produce a string representation, in the +-- input language of dot, that will enable dot to produce a +-- visualization of the tree. For more info about dot see +-- http://www.graphviz.org. + +tree2dot :: DominatorTree -> String +tree2dot t = concat $ "digraph {\n" : dot t ["}\n"] + where + dot :: DominatorTree -> [String] -> [String] + dot (Dominates root trees) = + (dotnode root :) . outedges trees . flip (foldl subtree) trees + where outedges [] = id + outedges (Dominates n _ : ts) = + \s -> " " : show root : " -> " : show n : "\n" : outedges ts s + dotnode Entry = " entryNode [shape=plaintext, label=\"entry\"]\n" + dotnode (Labelled l) = " " ++ show l ++ "\n" + subtree = flip dot + +instance Show DominatorNode where + show Entry = "entryNode" + show (Labelled l) = show l + +---------------------------------------------------------------- + +-- | Takes FactBase from dominator analysis and returns a map from each +-- label to its immediate dominator, if any +immediateDominators :: FactBase Doms -> LabelMap Label +immediateDominators = mapFoldWithKey add mapEmpty + where add l (PElem (DPath (idom:_))) = mapInsert l idom + add _ _ = id + diff -Nru ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl/Passes/Live.hs ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl/Passes/Live.hs --- ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl/Passes/Live.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl/Passes/Live.hs 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,90 @@ +{-# LANGUAGE ScopedTypeVariables, RankNTypes, TypeFamilies #-} +module Compiler.Hoopl.Passes.Live + ( NodeWithVars(..), AssignmentNode(..) + , liveLattice, liveness, -- deadAsstElim + ) +where + +import Data.Maybe +import qualified Data.Set as S + +import Compiler.Hoopl + +class HooplNode n => NodeWithVars n where + data Var n :: * -- ^ Variable or machine register. Unequal variables don't alias. + data VarSet n :: * + foldVarsUsed :: forall e x a . (Var n -> a -> a) -> n e x -> a -> a + foldVarsDefd :: forall e x a . (Var n -> a -> a) -> n e x -> a -> a + killsAllVars :: forall e x . n e x -> Bool + emptyVarSet :: VarSet n + unitVarSet :: Var n -> VarSet n + insertVarSet :: Var n -> VarSet n -> VarSet n + mkVarSet :: [Var n] -> VarSet n + unionVarSets :: VarSet n -> VarSet n -> VarSet n + unionManyVarSets :: [VarSet n] -> VarSet n + minusVarSet :: VarSet n -> VarSet n -> VarSet n + memberVarSet :: Var n -> VarSet n -> Bool + varSetElems :: VarSet n -> [Var n] + nullVarSet :: VarSet n -> Bool + varSetSize :: VarSet n -> Int + delFromVarSet :: Var n -> VarSet n -> VarSet n + delListFromVarSet :: [Var n] -> VarSet n -> VarSet n + foldVarSet :: (Var n -> b -> b) -> b -> VarSet n -> b -- ^ like Data.Set + filterVarSet :: (Var n -> Bool) -> VarSet n -> VarSet n + intersectVarSets :: VarSet n -> VarSet n -> VarSet n + +{- + unitVarSet x = insertVarSet x emptyVarSet + mkVarSet = foldr insertVarSet emptyVarSet + unionManyVarSets = foldr unionVarSets emptyVarSet + delListFromVarSet= flip (foldr delFromVarSet) +-} + +class NodeWithVars n => AssignmentNode n where + isVarAssign :: n O O -> Maybe (VarSet n) -- ^ Returns 'Just xs' if /all/ the node + -- does is assign to the given variables + +type Live n = WithTop (VarSet n) + +liveLattice :: forall n . NodeWithVars n => DataflowLattice (Live n) +liveLattice = addTop lat + where lat :: DataflowLattice (VarSet n) + lat = DataflowLattice + { fact_name = "Live variables" + , fact_bot = empty + , fact_extend = add + , fact_do_logging = False + } + empty :: VarSet n + empty = (emptyVarSet :: VarSet n) + add :: JoinFun (VarSet n) + add _ (OldFact old) (NewFact new) = (change, j) + where j = new `unionVarSets` old + change = error "type troubles" + -- change = changeIf $ varSetSize j > varSetSize old + +liveness :: NodeWithVars n => BwdTransfer n (VarSet n) +liveness = mkBTransfer first mid last + where first f = gen_kill f + mid m = gen_kill m + last l = gen_kill l . unionManyVarSets . successorFacts l + +gen_kill :: NodeWithVars n => n e x -> VarSet n -> VarSet n +gen_kill n = gen n . kill n . if killsAllVars n then const emptyVarSet else id + + +-- | The transfer equations use the traditional 'gen' and 'kill' +-- notations, which should be familiar from the dragon book. +gen, kill :: NodeWithVars n => n e x -> VarSet n -> VarSet n +gen = foldVarsUsed insertVarSet +kill = foldVarsDefd delFromVarSet + +{- +deadAsstElim :: AssignmentNode n => BwdRewrite n (VarSet n) +deadAsstElim = shallowBwdRw (noRewriteMono, dead, noRewriteMono) + where dead n live + | Just xs <- isVarAssign n = + if nullVarSet (xs `intersectVarSets` live) then Nothing + else Just emptyGraph + | otherwise = Nothing +-} diff -Nru ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl/Passes/mkfile ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl/Passes/mkfile --- ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl/Passes/mkfile 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl/Passes/mkfile 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,3 @@ +TOP=../../.. + +<$TOP/subdir.mk diff -Nru ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl/Pointed.hs ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl/Pointed.hs --- ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl/Pointed.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl/Pointed.hs 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,147 @@ +{-# LANGUAGE GADTs, ScopedTypeVariables #-} + +-- | Possibly doubly pointed lattices + +module Compiler.Hoopl.Pointed + ( Pointed(..), addPoints, addPoints', addTop, addTop' + , liftJoinTop, extendJoinDomain + , WithTop, WithBot, WithTopAndBot + ) +where + +import Compiler.Hoopl.Graph +import Compiler.Hoopl.Label +import Compiler.Hoopl.Dataflow + +-- | Adds top, bottom, or both to help form a lattice +data Pointed t b a where + Bot :: Pointed t C a + PElem :: a -> Pointed t b a + Top :: Pointed C b a + +-- ^ The type parameters 't' and 'b' are used to say whether top +-- and bottom elements have been added. The analogy with 'Block' +-- is nearly exact: +-- +-- * A 'Block' is closed at the entry if and only if it has a first node; +-- a 'Pointed' is closed at the top if and only if it has a top element. +-- +-- * A 'Block' is closed at the exit if and only if it has a last node; +-- a 'Pointed' is closed at the bottom if and only if it has a bottom element. +-- +-- We thus have four possible types, of which three are interesting: +-- +-- [@Pointed C C a@] Type @a@ extended with both top and bottom elements. +-- +-- [@Pointed C O a@] Type @a@ extended with a top element +-- only. (Presumably @a@ comes equipped with a bottom element of its own.) +-- +-- [@Pointed O C a@] Type @a@ extended with a bottom element only. +-- +-- [@Pointed O O a@] Isomorphic to @a@, and therefore not interesting. +-- +-- The advantage of all this GADT-ishness is that the constructors +-- 'Bot', 'Top', and 'PElem' can all be used polymorphically. +-- +-- A 'Pointed t b' type is an instance of 'Functor' and 'Show'. + + + +type WithBot a = Pointed O C a +-- ^ Type 'a' with a bottom element adjoined + +type WithTop a = Pointed C O a +-- ^ Type 'a' with a top element adjoined + +type WithTopAndBot a = Pointed C C a +-- ^ Type 'a' with top and bottom elements adjoined + + +-- | Given a join function and a name, creates a semi lattice by +-- adding a bottom element, and possibly a top element also. +-- A specialized version of 'addPoints''. +addPoints :: String -> JoinFun a -> DataflowLattice (Pointed t C a) +-- | A more general case for creating a new lattice +addPoints' :: forall a t . + String + -> (Label -> OldFact a -> NewFact a -> (ChangeFlag, Pointed t C a)) + -> DataflowLattice (Pointed t C a) + +addPoints name join = addPoints' name join' + where join' l o n = (change, PElem f) + where (change, f) = join l o n + +addPoints' name joinx = DataflowLattice name Bot join + where -- careful: order of cases matters for ChangeFlag + join :: JoinFun (Pointed t C a) + join _ (OldFact f) (NewFact Bot) = (NoChange, f) + join _ (OldFact Top) (NewFact _) = (NoChange, Top) + join _ (OldFact Bot) (NewFact f) = (SomeChange, f) + join _ (OldFact _) (NewFact Top) = (SomeChange, Top) + join l (OldFact (PElem old)) (NewFact (PElem new)) + = joinx l (OldFact old) (NewFact new) + + +liftJoinTop :: JoinFun a -> JoinFun (WithTop a) +extendJoinDomain :: forall a + . (Label -> OldFact a -> NewFact a -> (ChangeFlag, WithTop a)) + -> JoinFun (WithTop a) + +extendJoinDomain joinx = join + where join :: JoinFun (WithTop a) + join _ (OldFact Top) (NewFact _) = (NoChange, Top) + join _ (OldFact _) (NewFact Top) = (SomeChange, Top) + join l (OldFact (PElem old)) (NewFact (PElem new)) + = joinx l (OldFact old) (NewFact new) + +liftJoinTop joinx = extendJoinDomain (\l old new -> liftPair $ joinx l old new) + where liftPair (c, a) = (c, PElem a) + +-- | Given a join function and a name, creates a semi lattice by +-- adding a top element but no bottom element. Caller must supply the bottom +-- element. +addTop :: DataflowLattice a -> DataflowLattice (WithTop a) +-- | A more general case for creating a new lattice +addTop' :: forall a . + String + -> a + -> (Label -> OldFact a -> NewFact a -> (ChangeFlag, WithTop a)) + -> DataflowLattice (WithTop a) + +addTop lattice = addTop' name' (fact_bot lattice) join' + where name' = fact_name lattice ++ " + T" + join' l o n = (change, PElem f) + where (change, f) = fact_join lattice l o n + +addTop' name bot joinx = DataflowLattice name (PElem bot) join + where -- careful: order of cases matters for ChangeFlag + join :: JoinFun (WithTop a) + join _ (OldFact Top) (NewFact _) = (NoChange, Top) + join _ (OldFact _) (NewFact Top) = (SomeChange, Top) + join l (OldFact (PElem old)) (NewFact (PElem new)) + = joinx l (OldFact old) (NewFact new) + +instance Show a => Show (Pointed t b a) where + show Bot = "_|_" + show Top = "T" + show (PElem a) = show a + +instance Functor (Pointed t b) where + fmap _ Bot = Bot + fmap _ Top = Top + fmap f (PElem a) = PElem (f a) + +instance Eq a => Eq (Pointed t b a) where + Bot == Bot = True + Top == Top = True + (PElem a) == (PElem a') = a == a' + _ == _ = False + +instance Ord a => Ord (Pointed t b a) where + Bot `compare` Bot = EQ + Bot `compare` _ = LT + _ `compare` Bot = GT + PElem a `compare` PElem a' = a `compare` a' + Top `compare` Top = EQ + Top `compare` _ = GT + _ `compare` Top = LT diff -Nru ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl/Shape.hs ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl/Shape.hs --- ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl/Shape.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl/Shape.hs 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,50 @@ +{-# LANGUAGE GADTs, EmptyDataDecls #-} + +module Compiler.Hoopl.Shape {-# DEPRECATED "not ready to migrate to this yet" #-} +where + +-- | Used at the type level to indicate an "open" structure with +-- a unique, unnamed control-flow edge flowing in or out. +-- "Fallthrough" and concatenation are permitted at an open point. +data O + + +-- | Used at the type level to indicate a "closed" structure which +-- supports control transfer only through the use of named +-- labels---no "fallthrough" is permitted. The number of control-flow +-- edges is unconstrained. +data C + + +data HalfShape s where + ShapeO :: HalfShape O + ShapeC :: HalfShape C + +data Shape e x where + ShapeOO :: Shape O O + ShapeCO :: Shape C O + ShapeOC :: Shape O C + ShapeCC :: Shape C C + +class Shapely n where + shape :: n e x -> Shape e x + shapeAtEntry :: n e x -> HalfShape e + shapeAtExit :: n e x -> HalfShape x + + shapeAtEntry = entryHalfShape . shape + shapeAtExit = exitHalfShape . shape + + +entryHalfShape :: Shape e x -> HalfShape e +exitHalfShape :: Shape e x -> HalfShape x + +entryHalfShape ShapeOO = ShapeO +entryHalfShape ShapeOC = ShapeO +entryHalfShape ShapeCO = ShapeC +entryHalfShape ShapeCC = ShapeC + +exitHalfShape ShapeOO = ShapeO +exitHalfShape ShapeOC = ShapeC +exitHalfShape ShapeCO = ShapeO +exitHalfShape ShapeCC = ShapeC + diff -Nru ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl/Show.hs ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl/Show.hs --- ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl/Show.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl/Show.hs 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,41 @@ +{-# LANGUAGE RankNTypes, GADTs, ScopedTypeVariables, FlexibleContexts #-} + +module Compiler.Hoopl.Show + ( showGraph, showFactBase + ) +where + +import Compiler.Hoopl.Collections +import Compiler.Hoopl.Graph +import Compiler.Hoopl.Label + +-------------------------------------------------------------------------------- +-- Prettyprinting +-------------------------------------------------------------------------------- + +type Showing n = forall e x . n e x -> String + + +showGraph :: forall n e x . (NonLocal n) => Showing n -> Graph n e x -> String +showGraph node = g + where g :: (NonLocal n) => Graph n e x -> String + g GNil = "" + g (GUnit block) = b block + g (GMany g_entry g_blocks g_exit) = + open b g_entry ++ body g_blocks ++ open b g_exit + body blocks = concatMap b (mapElems blocks) + b :: forall e x . Block n e x -> String + b (BFirst n) = node n + b (BMiddle n) = node n + b (BLast n) = node n ++ "\n" + b (BCat b1 b2) = b b1 ++ b b2 + b (BHead b1 n) = b b1 ++ node n ++ "\n" + b (BTail n b1) = node n ++ b b1 + b (BClosed b1 b2) = b b1 ++ b b2 + +open :: (a -> String) -> MaybeO z a -> String +open _ NothingO = "" +open p (JustO n) = p n + +showFactBase :: Show f => FactBase f -> String +showFactBase = show . mapToList diff -Nru ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl/Stream.hs ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl/Stream.hs --- ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl/Stream.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl/Stream.hs 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,64 @@ +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-} + +module Compiler.Hoopl.Stream +where + +import Control.Monad + +import Test.QuickCheck + +type Stream s a = s -> Maybe (Pair s a) +data Pair s a = Pair a (Stream s a) + +instance Show (s -> Maybe (Pair s a)) where + show _ = "" + +instance (Arbitrary a, Arbitrary s, CoArbitrary s) => Arbitrary (Pair s a) where + arbitrary = liftM2 Pair arbitrary arbitrary + shrink (Pair a f) = [Pair a' f' | a' <- shrink a, f' <- shrink f] + +emptyS :: Stream s a +emptyS = const Nothing + +thenS :: Stream s a -> Stream s a -> Stream s a +s1 `thenS` s2 = \s -> case s1 s of + Nothing -> s2 s + Just (Pair a s1') -> Just $ Pair a (s1' `thenS` s2) + +iterS :: Stream s a -> Stream s a +iterS stream = \s -> case stream s of + Nothing -> Nothing + Just (Pair a s') -> Just $ Pair a (s' `thenS` iterS stream) + +elems :: s -> Stream s a -> [a] +elems s f = case f s of Nothing -> [] + Just (Pair a f) -> a : elems s f + +law1 :: Eq a => Int -> s -> Stream s a -> Bool +law1 n sigma stream = iterS stream `eq` (stream `thenS` iterS stream) + where s `eq` s' = take n (elems sigma s) == take n (elems sigma s') + +law2 :: Bool +law2 = iterS emptyS `eq` (emptyS :: Stream () Int) + where s `eq` s' = elems () s == elems () s' + +---------------------------------------------------------------- + +-- list analogy + +emptyL :: [a] +emptyL = [] + +thenL :: [a] -> [a] -> [a] +thenL = (++) + +iterL :: [a] -> [a] +iterL [] = [] +iterL (x:xs) = x : (xs `thenL` iterL (x:xs)) + +law1' :: Eq a => Int -> [a] -> Bool +law1' n l = iterL l `eq` (l `thenL` iterL l) + where xs `eq` ys = take n xs == take n ys + +law2' :: Bool +law2' = iterL emptyL == (emptyL :: [Int]) diff -Nru ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl/Unique.hs ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl/Unique.hs --- ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl/Unique.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl/Unique.hs 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,138 @@ +{-# LANGUAGE TypeFamilies #-} +module Compiler.Hoopl.Unique + ( Unique, intToUnique + , UniqueSet, UniqueMap + , UniqueMonad(..) + , SimpleUniqueMonad, runSimpleUniqueMonad + , UniqueMonadT, runUniqueMonadT + + , uniqueToInt -- exposed through GHC module only! + ) + +where + +import Compiler.Hoopl.Checkpoint +import Compiler.Hoopl.Collections + +import qualified Data.IntMap as M +import qualified Data.IntSet as S + +----------------------------------------------------------------------------- +-- Unique +----------------------------------------------------------------------------- + +data Unique = Unique { uniqueToInt :: {-# UNPACK #-} !Int } + deriving (Eq, Ord) + +intToUnique :: Int -> Unique +intToUnique = Unique + +instance Show Unique where + show (Unique n) = show n + +----------------------------------------------------------------------------- +-- UniqueSet + +newtype UniqueSet = US S.IntSet deriving (Eq, Ord, Show) + +instance IsSet UniqueSet where + type ElemOf UniqueSet = Unique + + setNull (US s) = S.null s + setSize (US s) = S.size s + setMember (Unique k) (US s) = S.member k s + + setEmpty = US S.empty + setSingleton (Unique k) = US (S.singleton k) + setInsert (Unique k) (US s) = US (S.insert k s) + setDelete (Unique k) (US s) = US (S.delete k s) + + setUnion (US x) (US y) = US (S.union x y) + setDifference (US x) (US y) = US (S.difference x y) + setIntersection (US x) (US y) = US (S.intersection x y) + setIsSubsetOf (US x) (US y) = S.isSubsetOf x y + + setFold k z (US s) = S.fold (k . intToUnique) z s + + setElems (US s) = map intToUnique (S.elems s) + setFromList ks = US (S.fromList (map uniqueToInt ks)) + +----------------------------------------------------------------------------- +-- UniqueMap + +newtype UniqueMap v = UM (M.IntMap v) deriving (Eq, Ord, Show) + +instance IsMap UniqueMap where + type KeyOf UniqueMap = Unique + + mapNull (UM m) = M.null m + mapSize (UM m) = M.size m + mapMember (Unique k) (UM m) = M.member k m + mapLookup (Unique k) (UM m) = M.lookup k m + mapFindWithDefault def (Unique k) (UM m) = M.findWithDefault def k m + + mapEmpty = UM M.empty + mapSingleton (Unique k) v = UM (M.singleton k v) + mapInsert (Unique k) v (UM m) = UM (M.insert k v m) + mapDelete (Unique k) (UM m) = UM (M.delete k m) + + mapUnion (UM x) (UM y) = UM (M.union x y) + mapUnionWithKey f (UM x) (UM y) = UM (M.unionWithKey (f . intToUnique) x y) + mapDifference (UM x) (UM y) = UM (M.difference x y) + mapIntersection (UM x) (UM y) = UM (M.intersection x y) + mapIsSubmapOf (UM x) (UM y) = M.isSubmapOf x y + + mapMap f (UM m) = UM (M.map f m) + mapMapWithKey f (UM m) = UM (M.mapWithKey (f . intToUnique) m) + mapFold k z (UM m) = M.fold k z m + mapFoldWithKey k z (UM m) = M.foldWithKey (k . intToUnique) z m + + mapElems (UM m) = M.elems m + mapKeys (UM m) = map intToUnique (M.keys m) + mapToList (UM m) = [(intToUnique k, v) | (k, v) <- M.toList m] + mapFromList assocs = UM (M.fromList [(uniqueToInt k, v) | (k, v) <- assocs]) + +---------------------------------------------------------------- +-- Monads + +class Monad m => UniqueMonad m where + freshUnique :: m Unique + +newtype SimpleUniqueMonad a = SUM { unSUM :: [Unique] -> (a, [Unique]) } + +instance Monad SimpleUniqueMonad where + return a = SUM $ \us -> (a, us) + m >>= k = SUM $ \us -> let (a, us') = unSUM m us in + unSUM (k a) us' + +instance UniqueMonad SimpleUniqueMonad where + freshUnique = SUM $ f + where f (u:us) = (u, us) + f _ = error "Unique.freshUnique(SimpleUniqueMonad): empty list" + +instance CheckpointMonad SimpleUniqueMonad where + type Checkpoint SimpleUniqueMonad = [Unique] + checkpoint = SUM $ \us -> (us, us) + restart us = SUM $ \_ -> ((), us) + +runSimpleUniqueMonad :: SimpleUniqueMonad a -> a +runSimpleUniqueMonad m = fst (unSUM m allUniques) + +---------------------------------------------------------------- + +newtype UniqueMonadT m a = UMT { unUMT :: [Unique] -> m (a, [Unique]) } + +instance Monad m => Monad (UniqueMonadT m) where + return a = UMT $ \us -> return (a, us) + m >>= k = UMT $ \us -> do { (a, us') <- unUMT m us; unUMT (k a) us' } + +instance Monad m => UniqueMonad (UniqueMonadT m) where + freshUnique = UMT $ f + where f (u:us) = return (u, us) + f _ = error "Unique.freshUnique(UniqueMonadT): empty list" + +runUniqueMonadT :: Monad m => UniqueMonadT m a -> m a +runUniqueMonadT m = do { (a, _) <- unUMT m allUniques; return a } + +allUniques :: [Unique] +allUniques = map Unique [1..] diff -Nru ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl/Util.hs ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl/Util.hs --- ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl/Util.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl/Util.hs 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,268 @@ +{-# LANGUAGE GADTs, ScopedTypeVariables, FlexibleInstances, RankNTypes, TypeFamilies #-} + +module Compiler.Hoopl.Util + ( gUnitOO, gUnitOC, gUnitCO, gUnitCC + , catGraphNodeOC, catGraphNodeOO + , catNodeCOGraph, catNodeOOGraph + , graphMapBlocks + , blockMapNodes, blockMapNodes3 + , blockGraph + , postorder_dfs, postorder_dfs_from, postorder_dfs_from_except + , preorder_dfs, preorder_dfs_from_except + , labelsDefined, labelsUsed, externalEntryLabels + , LabelsPtr(..) + ) +where + +import Control.Monad + +import Compiler.Hoopl.Collections +import Compiler.Hoopl.Graph +import Compiler.Hoopl.Label + + +---------------------------------------------------------------- + +gUnitOO :: block n O O -> Graph' block n O O +gUnitOC :: block n O C -> Graph' block n O C +gUnitCO :: block n C O -> Graph' block n C O +gUnitCC :: NonLocal (block n) => block n C C -> Graph' block n C C +gUnitOO b = GUnit b +gUnitOC b = GMany (JustO b) emptyBody NothingO +gUnitCO b = GMany NothingO emptyBody (JustO b) +gUnitCC b = GMany NothingO (addBlock b emptyBody) NothingO + + +catGraphNodeOO :: Graph n e O -> n O O -> Graph n e O +catGraphNodeOC :: NonLocal n => Graph n e O -> n O C -> Graph n e C +catNodeOOGraph :: n O O -> Graph n O x -> Graph n O x +catNodeCOGraph :: NonLocal n => n C O -> Graph n O x -> Graph n C x + +catGraphNodeOO GNil n = gUnitOO $ BMiddle n +catGraphNodeOO (GUnit b) n = gUnitOO $ b `BCat` BMiddle n +catGraphNodeOO (GMany e body (JustO x)) n = GMany e body (JustO $ x `BHead` n) + +catGraphNodeOC GNil n = gUnitOC $ BLast n +catGraphNodeOC (GUnit b) n = gUnitOC $ addToLeft b $ BLast n + where addToLeft :: Block n O O -> Block n O C -> Block n O C + addToLeft (BMiddle m) g = m `BTail` g + addToLeft (b1 `BCat` b2) g = addToLeft b1 $ addToLeft b2 g +catGraphNodeOC (GMany e body (JustO x)) n = GMany e body' NothingO + where body' = addBlock (x `BClosed` BLast n) body + +catNodeOOGraph n GNil = gUnitOO $ BMiddle n +catNodeOOGraph n (GUnit b) = gUnitOO $ BMiddle n `BCat` b +catNodeOOGraph n (GMany (JustO e) body x) = GMany (JustO $ n `BTail` e) body x + +catNodeCOGraph n GNil = gUnitCO $ BFirst n +catNodeCOGraph n (GUnit b) = gUnitCO $ addToRight (BFirst n) b + where addToRight :: Block n C O -> Block n O O -> Block n C O + addToRight g (BMiddle m) = g `BHead` m + addToRight g (b1 `BCat` b2) = addToRight (addToRight g b1) b2 +catNodeCOGraph n (GMany (JustO e) body x) = GMany NothingO body' x + where body' = addBlock (BFirst n `BClosed` e) body + + + + + +blockGraph :: NonLocal n => Block n e x -> Graph n e x +blockGraph b@(BFirst {}) = gUnitCO b +blockGraph b@(BMiddle {}) = gUnitOO b +blockGraph b@(BLast {}) = gUnitOC b +blockGraph b@(BCat {}) = gUnitOO b +blockGraph b@(BHead {}) = gUnitCO b +blockGraph b@(BTail {}) = gUnitOC b +blockGraph b@(BClosed {}) = gUnitCC b + + +-- | Function 'graphMapBlocks' enables a change of representation of blocks, +-- nodes, or both. It lifts a polymorphic block transform into a polymorphic +-- graph transform. When the block representation stabilizes, a similar +-- function should be provided for blocks. +graphMapBlocks :: forall block n block' n' e x . + (forall e x . block n e x -> block' n' e x) + -> (Graph' block n e x -> Graph' block' n' e x) + +graphMapBlocks f = map + where map :: Graph' block n e x -> Graph' block' n' e x + map GNil = GNil + map (GUnit b) = GUnit (f b) + map (GMany e b x) = GMany (fmap f e) (mapMap f b) (fmap f x) + +-- | Function 'blockMapNodes' enables a change of nodes in a block. +blockMapNodes3 :: ( n C O -> n' C O + , n O O -> n' O O + , n O C -> n' O C) + -> Block n e x -> Block n' e x +blockMapNodes3 (f, _, _) (BFirst n) = BFirst (f n) +blockMapNodes3 (_, m, _) (BMiddle n) = BMiddle (m n) +blockMapNodes3 (_, _, l) (BLast n) = BLast (l n) +blockMapNodes3 fs (BCat x y) = BCat (blockMapNodes3 fs x) (blockMapNodes3 fs y) +blockMapNodes3 fs@(_, m, _) (BHead x n) = BHead (blockMapNodes3 fs x) (m n) +blockMapNodes3 fs@(_, m, _) (BTail n x) = BTail (m n) (blockMapNodes3 fs x) +blockMapNodes3 fs (BClosed x y) = BClosed (blockMapNodes3 fs x) (blockMapNodes3 fs y) + +blockMapNodes :: (forall e x. n e x -> n' e x) + -> (Block n e x -> Block n' e x) +blockMapNodes f = blockMapNodes3 (f, f, f) + +---------------------------------------------------------------- + +class LabelsPtr l where + targetLabels :: l -> [Label] + +instance NonLocal n => LabelsPtr (n e C) where + targetLabels n = successors n + +instance LabelsPtr Label where + targetLabels l = [l] + +instance LabelsPtr LabelSet where + targetLabels = setElems + +instance LabelsPtr l => LabelsPtr [l] where + targetLabels = concatMap targetLabels + + +-- | Traversal: 'postorder_dfs' returns a list of blocks reachable +-- from the entry of enterable graph. The entry and exit are *not* included. +-- The list has the following property: +-- +-- Say a "back reference" exists if one of a block's +-- control-flow successors precedes it in the output list +-- +-- Then there are as few back references as possible +-- +-- The output is suitable for use in +-- a forward dataflow problem. For a backward problem, simply reverse +-- the list. ('postorder_dfs' is sufficiently tricky to implement that +-- one doesn't want to try and maintain both forward and backward +-- versions.) + +postorder_dfs :: NonLocal (block n) => Graph' block n O x -> [block n C C] +preorder_dfs :: NonLocal (block n) => Graph' block n O x -> [block n C C] + +-- | This is the most important traversal over this data structure. It drops +-- unreachable code and puts blocks in an order that is good for solving forward +-- dataflow problems quickly. The reverse order is good for solving backward +-- dataflow problems quickly. The forward order is also reasonably good for +-- emitting instructions, except that it will not usually exploit Forrest +-- Baskett's trick of eliminating the unconditional branch from a loop. For +-- that you would need a more serious analysis, probably based on dominators, to +-- identify loop headers. +-- +-- The ubiquity of 'postorder_dfs' is one reason for the ubiquity of the 'LGraph' +-- representation, when for most purposes the plain 'Graph' representation is +-- more mathematically elegant (but results in more complicated code). +-- +-- Here's an easy way to go wrong! Consider +-- @ +-- A -> [B,C] +-- B -> D +-- C -> D +-- @ +-- Then ordinary dfs would give [A,B,D,C] which has a back ref from C to D. +-- Better to get [A,B,C,D] + + +graphDfs :: (NonLocal (block n)) + => (LabelMap (block n C C) -> block n O C -> LabelSet -> [block n C C]) + -> (Graph' block n O x -> [block n C C]) +graphDfs _ (GNil) = [] +graphDfs _ (GUnit{}) = [] +graphDfs order (GMany (JustO entry) body _) = order body entry setEmpty + +postorder_dfs = graphDfs postorder_dfs_from_except +preorder_dfs = graphDfs preorder_dfs_from_except + +postorder_dfs_from_except :: forall block e . (NonLocal block, LabelsPtr e) + => LabelMap (block C C) -> e -> LabelSet -> [block C C] +postorder_dfs_from_except blocks b visited = + vchildren (get_children b) (\acc _visited -> acc) [] visited + where + vnode :: block C C -> ([block C C] -> LabelSet -> a) -> [block C C] -> LabelSet -> a + vnode block cont acc visited = + if setMember id visited then + cont acc visited + else + let cont' acc visited = cont (block:acc) visited in + vchildren (get_children block) cont' acc (setInsert id visited) + where id = entryLabel block + vchildren :: forall a. [block C C] -> ([block C C] -> LabelSet -> a) -> [block C C] -> LabelSet -> a + vchildren bs cont acc visited = next bs acc visited + where next children acc visited = + case children of [] -> cont acc visited + (b:bs) -> vnode b (next bs) acc visited + get_children :: forall l. LabelsPtr l => l -> [block C C] + get_children block = foldr add_id [] $ targetLabels block + add_id id rst = case lookupFact id blocks of + Just b -> b : rst + Nothing -> rst + +postorder_dfs_from + :: (NonLocal block, LabelsPtr b) => LabelMap (block C C) -> b -> [block C C] +postorder_dfs_from blocks b = postorder_dfs_from_except blocks b setEmpty + + +---------------------------------------------------------------- + +data VM a = VM { unVM :: LabelSet -> (a, LabelSet) } +marked :: Label -> VM Bool +mark :: Label -> VM () +instance Monad VM where + return a = VM $ \visited -> (a, visited) + m >>= k = VM $ \visited -> let (a, v') = unVM m visited in unVM (k a) v' +marked l = VM $ \v -> (setMember l v, v) +mark l = VM $ \v -> ((), setInsert l v) + +preorder_dfs_from_except :: forall block e . (NonLocal block, LabelsPtr e) + => LabelMap (block C C) -> e -> LabelSet -> [block C C] +preorder_dfs_from_except blocks b visited = + (fst $ unVM (children (get_children b)) visited) [] + where children [] = return id + children (b:bs) = liftM2 (.) (visit b) (children bs) + visit :: block C C -> VM (HL (block C C)) + visit b = do already <- marked (entryLabel b) + if already then return id + else do mark (entryLabel b) + bs <- children $ get_children b + return $ b `cons` bs + get_children :: forall l. LabelsPtr l => l -> [block C C] + get_children block = foldr add_id [] $ targetLabels block + add_id id rst = case lookupFact id blocks of + Just b -> b : rst + Nothing -> rst + +type HL a = [a] -> [a] -- Hughes list (constant-time concatenation) +cons :: a -> HL a -> HL a +cons a as tail = a : as tail + +---------------------------------------------------------------- + +labelsDefined :: forall block n e x . NonLocal (block n) => Graph' block n e x -> LabelSet +labelsDefined GNil = setEmpty +labelsDefined (GUnit{}) = setEmpty +labelsDefined (GMany _ body x) = mapFoldWithKey addEntry (exitLabel x) body + where addEntry :: forall a. ElemOf LabelSet -> a -> LabelSet -> LabelSet + addEntry label _ labels = setInsert label labels + exitLabel :: MaybeO x (block n C O) -> LabelSet + exitLabel NothingO = setEmpty + exitLabel (JustO b) = setSingleton (entryLabel b) + +labelsUsed :: forall block n e x. NonLocal (block n) => Graph' block n e x -> LabelSet +labelsUsed GNil = setEmpty +labelsUsed (GUnit{}) = setEmpty +labelsUsed (GMany e body _) = mapFold addTargets (entryTargets e) body + where addTargets :: forall e. block n e C -> LabelSet -> LabelSet + addTargets block labels = setInsertList (successors block) labels + entryTargets :: MaybeO e (block n O C) -> LabelSet + entryTargets NothingO = setEmpty + entryTargets (JustO b) = addTargets b setEmpty + +externalEntryLabels :: forall n . + NonLocal n => LabelMap (Block n C C) -> LabelSet +externalEntryLabels body = defined `setDifference` used + where defined = labelsDefined g + used = labelsUsed g + g = GMany NothingO body NothingO diff -Nru ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl/Wrappers.hs ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl/Wrappers.hs --- ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl/Wrappers.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl/Wrappers.hs 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,7 @@ +module Compiler.Hoopl.Wrappers {-# DEPRECATED "Use only if you know what you are doing and can preserve the 'respects fuel' invariant" #-} + ( wrapFR, wrapFR2, wrapBR, wrapBR2 + ) +where + +import Compiler.Hoopl.Dataflow + diff -Nru ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl/XUtil.hs ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl/XUtil.hs --- ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl/XUtil.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl/XUtil.hs 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,508 @@ +{-# LANGUAGE GADTs, RankNTypes, ScopedTypeVariables, TypeFamilies #-} + +-- | Utilities for clients of Hoopl, not used internally. + +module Compiler.Hoopl.XUtil + ( firstXfer, distributeXfer + , distributeFact, distributeFactBwd + , successorFacts + , joinFacts + , joinOutFacts -- deprecated + , joinMaps + , foldGraphNodes + , foldBlockNodesF, foldBlockNodesB, foldBlockNodesF3, foldBlockNodesB3 + , tfFoldBlock + , ScottBlock(ScottBlock), scottFoldBlock + , fbnf3 + , blockToNodeList, blockOfNodeList + , blockToNodeList' -- alternate version using fold + , blockToNodeList'' -- alternate version using scottFoldBlock + , blockToNodeList''' -- alternate version using tfFoldBlock + , analyzeAndRewriteFwdBody, analyzeAndRewriteBwdBody + , analyzeAndRewriteFwdOx, analyzeAndRewriteBwdOx + , noEntries + , BlockResult(..), lookupBlock + ) +where + +import qualified Data.Map as M +import Data.Maybe + +import Compiler.Hoopl.Checkpoint +import Compiler.Hoopl.Collections +import Compiler.Hoopl.Dataflow +import Compiler.Hoopl.Graph +import Compiler.Hoopl.Label +import Compiler.Hoopl.Util + + +-- | Forward dataflow analysis and rewriting for the special case of a Body. +-- A set of entry points must be supplied; blocks not reachable from +-- the set are thrown away. +analyzeAndRewriteFwdBody + :: forall m n f entries. (CheckpointMonad m, NonLocal n, LabelsPtr entries) + => FwdPass m n f + -> entries -> Body n -> FactBase f + -> m (Body n, FactBase f) + +-- | Backward dataflow analysis and rewriting for the special case of a Body. +-- A set of entry points must be supplied; blocks not reachable from +-- the set are thrown away. +analyzeAndRewriteBwdBody + :: forall m n f entries. (CheckpointMonad m, NonLocal n, LabelsPtr entries) + => BwdPass m n f + -> entries -> Body n -> FactBase f + -> m (Body n, FactBase f) + +analyzeAndRewriteFwdBody pass en = mapBodyFacts (analyzeAndRewriteFwd pass (JustC en)) +analyzeAndRewriteBwdBody pass en = mapBodyFacts (analyzeAndRewriteBwd pass (JustC en)) + +mapBodyFacts :: (Monad m) + => (Graph n C C -> Fact C f -> m (Graph n C C, Fact C f, MaybeO C f)) + -> (Body n -> FactBase f -> m (Body n, FactBase f)) +-- ^ Internal utility; should not escape +mapBodyFacts anal b f = anal (GMany NothingO b NothingO) f >>= bodyFacts + where -- the type constraint is needed for the pattern match; + -- if it were not, we would use do-notation here. + bodyFacts :: Monad m => (Graph n C C, Fact C f, MaybeO C f) -> m (Body n, Fact C f) + bodyFacts (GMany NothingO body NothingO, fb, NothingO) = return (body, fb) + +{- + Can't write: + + do (GMany NothingO body NothingO, fb, NothingO) <- anal (....) f + return (body, fb) + + because we need an explicit type signature in order to do the GADT + pattern matches on NothingO +-} + + + +-- | Forward dataflow analysis and rewriting for the special case of a +-- graph open at the entry. This special case relieves the client +-- from having to specify a type signature for 'NothingO', which beginners +-- might find confusing and experts might find annoying. +analyzeAndRewriteFwdOx + :: forall m n f x. (CheckpointMonad m, NonLocal n) + => FwdPass m n f -> Graph n O x -> f -> m (Graph n O x, FactBase f, MaybeO x f) + +-- | Backward dataflow analysis and rewriting for the special case of a +-- graph open at the entry. This special case relieves the client +-- from having to specify a type signature for 'NothingO', which beginners +-- might find confusing and experts might find annoying. +analyzeAndRewriteBwdOx + :: forall m n f x. (CheckpointMonad m, NonLocal n) + => BwdPass m n f -> Graph n O x -> Fact x f -> m (Graph n O x, FactBase f, f) + +-- | A value that can be used for the entry point of a graph open at the entry. +noEntries :: MaybeC O Label +noEntries = NothingC + +analyzeAndRewriteFwdOx pass g f = analyzeAndRewriteFwd pass noEntries g f +analyzeAndRewriteBwdOx pass g fb = analyzeAndRewriteBwd pass noEntries g fb >>= strip + where strip :: forall m a b c . Monad m => (a, b, MaybeO O c) -> m (a, b, c) + strip (a, b, JustO c) = return (a, b, c) + + + + + +-- | A utility function so that a transfer function for a first +-- node can be given just a fact; we handle the lookup. This +-- function is planned to be made obsolete by changes in the dataflow +-- interface. + +firstXfer :: NonLocal n => (n C O -> f -> f) -> (n C O -> FactBase f -> f) +firstXfer xfer n fb = xfer n $ fromJust $ lookupFact (entryLabel n) fb + +-- | This utility function handles a common case in which a transfer function +-- produces a single fact out of a last node, which is then distributed +-- over the outgoing edges. +distributeXfer :: NonLocal n + => DataflowLattice f -> (n O C -> f -> f) -> (n O C -> f -> FactBase f) +distributeXfer lattice xfer n f = + mkFactBase lattice [ (l, xfer n f) | l <- successors n ] + +-- | This utility function handles a common case in which a transfer function +-- for a last node takes the incoming fact unchanged and simply distributes +-- that fact over the outgoing edges. +distributeFact :: NonLocal n => n O C -> f -> FactBase f +distributeFact n f = mapFromList [ (l, f) | l <- successors n ] + -- because the same fact goes out on every edge, + -- there's no need for 'mkFactBase' here. + +-- | This utility function handles a common case in which a backward transfer +-- function takes the incoming fact unchanged and tags it with the node's label. +distributeFactBwd :: NonLocal n => n C O -> f -> FactBase f +distributeFactBwd n f = mapSingleton (entryLabel n) f + +-- | List of (unlabelled) facts from the successors of a last node +successorFacts :: NonLocal n => n O C -> FactBase f -> [f] +successorFacts n fb = [ f | id <- successors n, let Just f = lookupFact id fb ] + +-- | Join a list of facts. +joinFacts :: DataflowLattice f -> Label -> [f] -> f +joinFacts lat inBlock = foldr extend (fact_bot lat) + where extend new old = snd $ fact_join lat inBlock (OldFact old) (NewFact new) + +{-# DEPRECATED joinOutFacts + "should be replaced by 'joinFacts lat l (successorFacts n f)'; as is, it uses the wrong Label" #-} + +joinOutFacts :: (NonLocal node) => DataflowLattice f -> node O C -> FactBase f -> f +joinOutFacts lat n f = foldr join (fact_bot lat) facts + where join (lbl, new) old = snd $ fact_join lat lbl (OldFact old) (NewFact new) + facts = [(s, fromJust fact) | s <- successors n, let fact = lookupFact s f, isJust fact] + + +-- | It's common to represent dataflow facts as a map from variables +-- to some fact about the locations. For these maps, the join +-- operation on the map can be expressed in terms of the join on each +-- element of the codomain: +joinMaps :: Ord k => JoinFun v -> JoinFun (M.Map k v) +joinMaps eltJoin l (OldFact old) (NewFact new) = M.foldrWithKey add (NoChange, old) new + where + add k new_v (ch, joinmap) = + case M.lookup k joinmap of + Nothing -> (SomeChange, M.insert k new_v joinmap) + Just old_v -> case eltJoin l (OldFact old_v) (NewFact new_v) of + (SomeChange, v') -> (SomeChange, M.insert k v' joinmap) + (NoChange, _) -> (ch, joinmap) + + + +-- | A fold function that relies on the IndexedCO type function. +-- Note that the type parameter e is available to the functions +-- that are applied to the middle and last nodes. +tfFoldBlock :: forall n bc bo c e x . + ( n C O -> bc + , n O O -> IndexedCO e bc bo -> IndexedCO e bc bo + , n O C -> IndexedCO e bc bo -> c) + -> (Block n e x -> bo -> IndexedCO x c (IndexedCO e bc bo)) +tfFoldBlock (f, m, l) bl bo = block bl + where block :: forall x . Block n e x -> IndexedCO x c (IndexedCO e bc bo) + block (BFirst n) = f n + block (BMiddle n) = m n bo + block (BLast n) = l n bo + block (b1 `BCat` b2) = oblock b2 $ block b1 + block (b1 `BClosed` b2) = oblock b2 $ block b1 + block (b1 `BHead` n) = m n $ block b1 + block (n `BTail` b2) = oblock b2 $ m n bo + oblock :: forall x . Block n O x -> IndexedCO e bc bo -> IndexedCO x c (IndexedCO e bc bo) + oblock (BMiddle n) = m n + oblock (BLast n) = l n + oblock (b1 `BCat` b2) = oblock b1 `cat` oblock b2 + oblock (n `BTail` b2) = m n `cat` oblock b2 + cat :: forall b c a. (a -> b) -> (b -> c) -> a -> c + cat f f' = f' . f + + +type NodeList' e x n = (MaybeC e (n C O), [n O O], MaybeC x (n O C)) +blockToNodeList''' :: + forall n e x. ( IndexedCO e (NodeList' C O n) (NodeList' O O n) ~ NodeList' e O n + , IndexedCO x (NodeList' e C n) (NodeList' e O n) ~ NodeList' e x n) => + Block n e x -> NodeList' e x n +blockToNodeList''' b = (h, reverse ms', t) + where + (h, ms', t) = tfFoldBlock (f, m, l) b z + z :: NodeList' O O n + z = (NothingC, [], NothingC) + f :: n C O -> NodeList' C O n + f n = (JustC n, [], NothingC) + m n (h, ms', t) = (h, n : ms', t) + l n (h, ms', _) = (h, ms', JustC n) + + +{- +data EitherCO' ex a b where + LeftCO :: a -> EitherCO' C a b + RightCO :: b -> EitherCO' O a b +-} + + -- should be done with a *backward* fold + +-- | More general fold + +_unused :: Int +_unused = 3 + where _a = foldBlockNodesF3'' (Trips undefined undefined undefined) + _b = foldBlockNodesF3' + +data Trips n a b c = Trips { ff :: forall e . MaybeC e (n C O) -> a -> b + , fm :: n O O -> b -> b + , fl :: forall x . MaybeC x (n O C) -> b -> c + } + +foldBlockNodesF3'' :: forall n a b c . + Trips n a b c -> (forall e x . Block n e x -> a -> c) +foldBlockNodesF3'' trips = block + where block :: Block n e x -> a -> c + block (b1 `BClosed` b2) = foldCO b1 `cat` foldOC b2 + block (BFirst node) = ff trips (JustC node) `cat` missingLast + block (b @ BHead {}) = foldCO b `cat` missingLast + block (BMiddle node) = missingFirst `cat` fm trips node `cat` missingLast + block (b @ BCat {}) = missingFirst `cat` foldOO b `cat` missingLast + block (BLast node) = missingFirst `cat` fl trips (JustC node) + block (b @ BTail {}) = missingFirst `cat` foldOC b + missingLast = fl trips NothingC + missingFirst = ff trips NothingC + foldCO :: Block n C O -> a -> b + foldOO :: Block n O O -> b -> b + foldOC :: Block n O C -> b -> c + foldCO (BFirst n) = ff trips (JustC n) + foldCO (BHead b n) = foldCO b `cat` fm trips n + foldOO (BMiddle n) = fm trips n + foldOO (BCat b1 b2) = foldOO b1 `cat` foldOO b2 + foldOC (BLast n) = fl trips (JustC n) + foldOC (BTail n b) = fm trips n `cat` foldOC b + cat :: forall b c a. (a -> b) -> (b -> c) -> a -> c + f `cat` g = g . f + +data ScottBlock n a = ScottBlock + { sb_first :: n C O -> a C O + , sb_mid :: n O O -> a O O + , sb_last :: n O C -> a O C + , sb_cat :: forall e x . a e O -> a O x -> a e x + } + +scottFoldBlock :: forall n a e x . ScottBlock n a -> Block n e x -> a e x +scottFoldBlock funs = block + where block :: forall e x . Block n e x -> a e x + block (BFirst n) = sb_first funs n + block (BMiddle n) = sb_mid funs n + block (BLast n) = sb_last funs n + block (BClosed b1 b2) = block b1 `cat` block b2 + block (BCat b1 b2) = block b1 `cat` block b2 + block (BHead b n) = block b `cat` sb_mid funs n + block (BTail n b) = sb_mid funs n `cat` block b + cat :: forall e x. a e O -> a O x -> a e x + cat = sb_cat funs + +newtype NodeList n e x + = NL { unList :: (MaybeC e (n C O), [n O O] -> [n O O], MaybeC x (n O C)) } + +fbnf3 :: forall n a b c . + ( n C O -> a -> b + , n O O -> b -> b + , n O C -> b -> c) + -> (forall e x . Block n e x -> IndexedCO e a b -> IndexedCO x c b) +fbnf3 (ff, fm, fl) block = unFF3 $ scottFoldBlock (ScottBlock f m l cat) block + where f n = FF3 $ ff n + m n = FF3 $ fm n + l n = FF3 $ fl n + -- XXX Ew. + cat :: forall t t1 t2 t3 t4 t5 t6 t7 t8 t9 a b c e x. + (IndexedCO x c b ~ IndexedCO t9 t7 t6, + IndexedCO t8 t5 t6 ~ IndexedCO t4 t2 t1, + IndexedCO t3 t t1 ~ IndexedCO e a b) => + FF3 t t1 t2 t3 t4 -> FF3 t5 t6 t7 t8 t9 -> FF3 a b c e x + FF3 f `cat` FF3 f' = FF3 $ f' . f + +newtype FF3 a b c e x = FF3 { unFF3 :: IndexedCO e a b -> IndexedCO x c b } + +blockToNodeList'' :: Block n e x -> (MaybeC e (n C O), [n O O], MaybeC x (n O C)) +blockToNodeList'' = finish . unList . scottFoldBlock (ScottBlock f m l cat) + where f n = NL (JustC n, id, NothingC) + m n = NL (NothingC, (n:), NothingC) + l n = NL (NothingC, id, JustC n) + cat :: forall n t1 t3. NodeList n t1 O -> NodeList n O t3 -> NodeList n t1 t3 + NL (e, ms, NothingC) `cat` NL (NothingC, ms', x) = NL (e, ms . ms', x) + finish :: forall t t1 t2 a. (t, [a] -> t1, t2) -> (t, t1, t2) + finish (e, ms, x) = (e, ms [], x) + + + +blockToNodeList' :: Block n e x -> (MaybeC e (n C O), [n O O], MaybeC x (n O C)) +blockToNodeList' b = unFNL $ foldBlockNodesF3''' ff fm fl b () + where ff :: forall n e. MaybeC e (n C O) -> () -> PNL n e + fm :: forall n e. n O O -> PNL n e -> PNL n e + fl :: forall n e x. MaybeC x (n O C) -> PNL n e -> FNL n e x + ff n () = PNL (n, []) + fm n (PNL (first, mids')) = PNL (first, n : mids') + fl n (PNL (first, mids')) = FNL (first, reverse mids', n) + + -- newtypes for 'partial node list' and 'final node list' +newtype PNL n e = PNL (MaybeC e (n C O), [n O O]) +newtype FNL n e x = FNL {unFNL :: (MaybeC e (n C O), [n O O], MaybeC x (n O C))} + +foldBlockNodesF3''' :: forall n a b c . + (forall e . MaybeC e (n C O) -> a -> b e) + -> (forall e . n O O -> b e -> b e) + -> (forall e x . MaybeC x (n O C) -> b e -> c e x) + -> (forall e x . Block n e x -> a -> c e x) +foldBlockNodesF3''' ff fm fl = block + where block :: forall e x . Block n e x -> a -> c e x + blockCO :: Block n C O -> a -> b C + blockOO :: forall e . Block n O O -> b e -> b e + blockOC :: forall e . Block n O C -> b e -> c e C + block (b1 `BClosed` b2) = blockCO b1 `cat` blockOC b2 + block (BFirst node) = ff (JustC node) `cat` fl NothingC + block (b @ BHead {}) = blockCO b `cat` fl NothingC + block (BMiddle node) = ff NothingC `cat` fm node `cat` fl NothingC + block (b @ BCat {}) = ff NothingC `cat` blockOO b `cat` fl NothingC + block (BLast node) = ff NothingC `cat` fl (JustC node) + block (b @ BTail {}) = ff NothingC `cat` blockOC b + blockCO (BFirst n) = ff (JustC n) + blockCO (BHead b n) = blockCO b `cat` fm n + blockOO (BMiddle n) = fm n + blockOO (BCat b1 b2) = blockOO b1 `cat` blockOO b2 + blockOC (BLast n) = fl (JustC n) + blockOC (BTail n b) = fm n `cat` blockOC b + cat :: forall a b c. (a -> b) -> (b -> c) -> a -> c + f `cat` g = g . f + + +-- | The following function is easy enough to define but maybe not so useful +foldBlockNodesF3' :: forall n a b c . + ( n C O -> a -> b + , n O O -> b -> b + , n O C -> b -> c) + -> (a -> b) -- called iff there is no first node + -> (b -> c) -- called iff there is no last node + -> (forall e x . Block n e x -> a -> c) +foldBlockNodesF3' (ff, fm, fl) missingFirst missingLast = block + where block :: forall e x . Block n e x -> a -> c + blockCO :: Block n C O -> a -> b + blockOO :: Block n O O -> b -> b + blockOC :: Block n O C -> b -> c + block (b1 `BClosed` b2) = blockCO b1 `cat` blockOC b2 + block (BFirst node) = ff node `cat` missingLast + block (b @ BHead {}) = blockCO b `cat` missingLast + block (BMiddle node) = missingFirst `cat` fm node `cat` missingLast + block (b @ BCat {}) = missingFirst `cat` blockOO b `cat` missingLast + block (BLast node) = missingFirst `cat` fl node + block (b @ BTail {}) = missingFirst `cat` blockOC b + blockCO (BFirst n) = ff n + blockCO (BHead b n) = blockCO b `cat` fm n + blockOO (BMiddle n) = fm n + blockOO (BCat b1 b2) = blockOO b1 `cat` blockOO b2 + blockOC (BLast n) = fl n + blockOC (BTail n b) = fm n `cat` blockOC b + cat :: forall a b c. (a -> b) -> (b -> c) -> a -> c + f `cat` g = g . f + +-- | Fold a function over every node in a block, forward or backward. +-- The fold function must be polymorphic in the shape of the nodes. +foldBlockNodesF3 :: forall n a b c . + ( n C O -> a -> b + , n O O -> b -> b + , n O C -> b -> c) + -> (forall e x . Block n e x -> IndexedCO e a b -> IndexedCO x c b) +foldBlockNodesF :: forall n a . + (forall e x . n e x -> a -> a) + -> (forall e x . Block n e x -> IndexedCO e a a -> IndexedCO x a a) +foldBlockNodesB3 :: forall n a b c . + ( n C O -> b -> c + , n O O -> b -> b + , n O C -> a -> b) + -> (forall e x . Block n e x -> IndexedCO x a b -> IndexedCO e c b) +foldBlockNodesB :: forall n a . + (forall e x . n e x -> a -> a) + -> (forall e x . Block n e x -> IndexedCO x a a -> IndexedCO e a a) +-- | Fold a function over every node in a graph. +-- The fold function must be polymorphic in the shape of the nodes. + +foldGraphNodes :: forall n a . + (forall e x . n e x -> a -> a) + -> (forall e x . Graph n e x -> a -> a) + + +foldBlockNodesF3 (ff, fm, fl) = block + where block :: forall e x . Block n e x -> IndexedCO e a b -> IndexedCO x c b + block (BFirst node) = ff node + block (BMiddle node) = fm node + block (BLast node) = fl node + block (b1 `BCat` b2) = block b1 `cat` block b2 + block (b1 `BClosed` b2) = block b1 `cat` block b2 + block (b1 `BHead` n) = block b1 `cat` fm n + block (n `BTail` b2) = fm n `cat` block b2 + cat :: forall a b c. (a -> b) -> (b -> c) -> a -> c + cat f f' = f' . f +foldBlockNodesF f = foldBlockNodesF3 (f, f, f) + +foldBlockNodesB3 (ff, fm, fl) = block + where block :: forall e x . Block n e x -> IndexedCO x a b -> IndexedCO e c b + block (BFirst node) = ff node + block (BMiddle node) = fm node + block (BLast node) = fl node + block (b1 `BCat` b2) = block b1 `cat` block b2 + block (b1 `BClosed` b2) = block b1 `cat` block b2 + block (b1 `BHead` n) = block b1 `cat` fm n + block (n `BTail` b2) = fm n `cat` block b2 + cat :: forall a b c. (b -> c) -> (a -> b) -> a -> c + cat f f' = f . f' +foldBlockNodesB f = foldBlockNodesB3 (f, f, f) + + +foldGraphNodes f = graph + where graph :: forall e x . Graph n e x -> a -> a + lift :: forall thing ex . (thing -> a -> a) -> (MaybeO ex thing -> a -> a) + + graph GNil = id + graph (GUnit b) = block b + graph (GMany e b x) = lift block e . body b . lift block x + body :: Body n -> a -> a + body bdy = \a -> mapFold block a bdy + lift _ NothingO = id + lift f (JustO thing) = f thing + + block :: Block n e x -> IndexedCO e a a -> IndexedCO x a a + block = foldBlockNodesF f + +{-# DEPRECATED blockToNodeList, blockOfNodeList + "What justifies these functions? Can they be eliminated? Replaced with folds?" #-} + + + +-- | Convert a block to a list of nodes. The entry and exit node +-- is or is not present depending on the shape of the block. +-- +-- The blockToNodeList function cannot be currently expressed using +-- foldBlockNodesB, because it returns IndexedCO e a b, which means +-- two different types depending on the shape of the block entry. +-- But blockToNodeList returns one of four possible types, depending +-- on the shape of the block entry *and* exit. +blockToNodeList :: Block n e x -> (MaybeC e (n C O), [n O O], MaybeC x (n O C)) +blockToNodeList block = case block of + BFirst n -> (JustC n, [], NothingC) + BMiddle n -> (NothingC, [n], NothingC) + BLast n -> (NothingC, [], JustC n) + BCat {} -> (NothingC, foldOO block [], NothingC) + BHead x n -> case foldCO x [n] of (f, m) -> (f, m, NothingC) + BTail n x -> case foldOC x of (m, l) -> (NothingC, n : m, l) + BClosed x y -> case foldOC y of (m, l) -> case foldCO x m of (f, m') -> (f, m', l) + where foldCO :: Block n C O -> [n O O] -> (MaybeC C (n C O), [n O O]) + foldCO (BFirst n) m = (JustC n, m) + foldCO (BHead x n) m = foldCO x (n : m) + + foldOO :: Block n O O -> [n O O] -> [n O O] + foldOO (BMiddle n) acc = n : acc + foldOO (BCat x y) acc = foldOO x $ foldOO y acc + + foldOC :: Block n O C -> ([n O O], MaybeC C (n O C)) + foldOC (BLast n) = ([], JustC n) + foldOC (BTail n x) = case foldOC x of (m, l) -> (n : m, l) + +-- | Convert a list of nodes to a block. The entry and exit node +-- must or must not be present depending on the shape of the block. +blockOfNodeList :: (MaybeC e (n C O), [n O O], MaybeC x (n O C)) -> Block n e x +blockOfNodeList (NothingC, [], NothingC) = error "No nodes to created block from in blockOfNodeList" +blockOfNodeList (NothingC, m, NothingC) = foldr1 BCat (map BMiddle m) +blockOfNodeList (NothingC, m, JustC l) = foldr BTail (BLast l) m +blockOfNodeList (JustC f, m, NothingC) = foldl BHead (BFirst f) m +blockOfNodeList (JustC f, m, JustC l) = BClosed (BFirst f) $ foldr BTail (BLast l) m + +data BlockResult n x where + NoBlock :: BlockResult n x + BodyBlock :: Block n C C -> BlockResult n x + ExitBlock :: Block n C O -> BlockResult n O + +lookupBlock :: NonLocal n => Graph n e x -> Label -> BlockResult n x +lookupBlock (GMany _ _ (JustO exit)) lbl + | entryLabel exit == lbl = ExitBlock exit +lookupBlock (GMany _ body _) lbl = + case mapLookup lbl body of + Just b -> BodyBlock b + Nothing -> NoBlock +lookupBlock GNil _ = NoBlock +lookupBlock (GUnit _) _ = NoBlock diff -Nru ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl.hs ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl.hs --- ghc-7.0.3/libraries/hoopl/src/Compiler/Hoopl.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/src/Compiler/Hoopl.hs 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,37 @@ +module Compiler.Hoopl + ( module Compiler.Hoopl.Graph + , module Compiler.Hoopl.MkGraph + , module Compiler.Hoopl.XUtil + , module Compiler.Hoopl.Collections + , module Compiler.Hoopl.Checkpoint + , module Compiler.Hoopl.Dataflow + , module Compiler.Hoopl.Label + , module Compiler.Hoopl.Pointed + , module Compiler.Hoopl.Combinators + , module Compiler.Hoopl.Fuel + , module Compiler.Hoopl.Unique + , module Compiler.Hoopl.Util + , module Compiler.Hoopl.Debug + , module Compiler.Hoopl.Show + ) +where + +import Compiler.Hoopl.Checkpoint +import Compiler.Hoopl.Collections +import Compiler.Hoopl.Combinators +import Compiler.Hoopl.Dataflow hiding ( wrapFR, wrapFR2, wrapBR, wrapBR2 + ) +import Compiler.Hoopl.Debug +import Compiler.Hoopl.Fuel hiding (withFuel, getFuel, setFuel, FuelMonadT) +import Compiler.Hoopl.Graph hiding + ( Body + , BCat, BHead, BTail, BClosed -- OK to expose BFirst, BMiddle, BLast + ) +import Compiler.Hoopl.Graph (Body) +import Compiler.Hoopl.Label hiding (uniqueToLbl, lblToUnique) +import Compiler.Hoopl.MkGraph +import Compiler.Hoopl.Pointed +import Compiler.Hoopl.Show +import Compiler.Hoopl.Util +import Compiler.Hoopl.Unique hiding (uniqueToInt) +import Compiler.Hoopl.XUtil diff -Nru ghc-7.0.3/libraries/hoopl/src/Compiler/mkfile ghc-7.2.1/libraries/hoopl/src/Compiler/mkfile --- ghc-7.0.3/libraries/hoopl/src/Compiler/mkfile 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/src/Compiler/mkfile 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,3 @@ +TOP=.. + +<$TOP/subdir.mk diff -Nru ghc-7.0.3/libraries/hoopl/src/.gitignore ghc-7.2.1/libraries/hoopl/src/.gitignore --- ghc-7.0.3/libraries/hoopl/src/.gitignore 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/src/.gitignore 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,6 @@ +*.hi +*.hc +*.o +dist +hoopl.pdf +.config.* diff -Nru ghc-7.0.3/libraries/hoopl/src/LOOPS ghc-7.2.1/libraries/hoopl/src/LOOPS --- ghc-7.0.3/libraries/hoopl/src/LOOPS 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/src/LOOPS 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,45 @@ +Thoughts about loop-based analyses +================================== + +A loop analysis will want to have certain inputs, perhaps including + + - A set of loop headers + - The dominance relation + - The reachability relation + +Let's assume + + type Header = Label + type Headers = LabelSet + +We can imagine doing loop analyses as follows: + + - The dataflow fact is `Map Header f` where `f` is a lattice of + facts. + + - If at a given point (edge) in the flow graph, header `H` is a key in the + map, then that point is reachable from `H`, and the fact stored in + the map is true on all paths that originate at `H` and terminate + at that point. + + - If a given point (edge) in the flow graph cannot reach `H`, it is + safe (but not necessary) to delete `H` from the map. It is + probably worth deleting `H` if possible, because if nothing else + it will keep the program from allocating one thunk per node `N` + that is reachable from `H` but does not reach `H`. + + - If at a given point in the flow graph, `H` is not a key in the map, + then we expect either the point is not reachable from `H` or it + does not reach `H`. That is, we want `H` to be a key at exactly + those points that are in a loop containing `H`. + + - If a join function gets two maps and `H` is a key in just one of + them, the map without `H` can be ignored, since that edge is not + yet known to be reachable from `H`. We can therefore use the + empty map as a bottom element. + + - If `join` is the join function on `f`, the join function on maps + can *almost* be defined using `Data.Map.unionWithKey f`, but + unfortunately not, because of the beastly `ChangeFlag`. + A person like Chris Rice should explore a suitable higher-order + function for lifting joins into finite maps. diff -Nru ghc-7.0.3/libraries/hoopl/src/mkfile ghc-7.2.1/libraries/hoopl/src/mkfile --- ghc-7.0.3/libraries/hoopl/src/mkfile 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/src/mkfile 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,55 @@ +PKG=hoopl +SRC=Graph Label GraphUtil Fuel MkGraph Dataflow +VERSION=`awk '$1 == "Version:" { print $2 }' $PKG.cabal` +HOOPL=Compiler/Hoopl +HS=${SRC:%=$HOOPL/%.hs} +O=${SRC:%=$HOOPL/%.o} +CABAL=hoopl +CONFIG=.config.$CABAL + +all:V: $O hoopl.pdf + +dist:V: hoopl.pdf + cabal sdist + +hoopl.pdf: ../paper/dfopt.pdf + cp -a -v $prereq $target + +test:V: + cabal install --enable-documentation + (cd ../testing && mk test) + +install:V: $CONFIG + cabal install --enable-documentation + +build:V: $CONFIG + cabal build + +check:V: $CONFIG + cabal check + +upload:V: hoopl.pdf $CONFIG + cabal build + cabal sdist + cabal upload dist/$PKG-$VERSION.tar.gz + +config:V: $CONFIG + +.config.&:D: &.cabal + cabal configure --user > $target + +clean:V: + rm -f `find [A-Z]* ../testing -name '*.o' -o '*.hi'` + +%.pdf: %.tex + (cd `dirname $prereq`; mk `basename $target`) + + +%.o: %.hs + ghc --make -c $prereq + + +clean:V: + rm -f $HOOPL/*.o + rm -f $HOOPL/*.hi + rm -f *~ $HOOPL/*~ diff -Nru ghc-7.0.3/libraries/hoopl/src/README ghc-7.2.1/libraries/hoopl/src/README --- ghc-7.0.3/libraries/hoopl/src/README 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/src/README 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,35 @@ +This is Hoopl, a higher-order optimization library. +There are two unpublished papers describing Hoopl: + + Hoopl: Dataflow Optimization Made Simple + Hoopl: A Modular, Reusable Library for Dataflow Analysis and Transformation + +The second such paper is attached to this package. + +The version number is split into four parts: + + 3. Third major body plan (phylum) + 7. Seventh iteration (roughly) of data structures + 2. Major version; changes when clients must change + 1. Minor version; changes when clients can stay the same + + +Version 3.7.3.3 has fixed known bugs. + +Version 3.7.8.0 will be the last version uploaded to Hackage for some time. +This library is undergoing *very* rapid development, and we ask that you +get the most recent version from our public git repository: + + git clone -o tufts git://ghc.cs.tufts.edu/hoopl/hoopl.git + +If you are not familiar with git, we recommend the tutorial 'Git Magic' +by Ben Lynn. To get some ideas about how to use git effectively, + + http://whygitisbetterthanx.com/ + +is also useful. + +If you've been given an account at Tufts with write privileges to the +git repository, you'll want to use a different URL: + + git clone -o tufts linux.cs.tufts.edu:/r/ghc/www/hoopl/hoopl.git diff -Nru ghc-7.0.3/libraries/hoopl/src/subdir.mk ghc-7.2.1/libraries/hoopl/src/subdir.mk --- ghc-7.0.3/libraries/hoopl/src/subdir.mk 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/src/subdir.mk 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,11 @@ + +all:V: obj + +obj:V: + ghc -i$TOP --make *.hs + +clean:V: + rm -f *.o *.hi *~ + +test install build check:V: + (cd $TOP && mk $target) diff -Nru ghc-7.0.3/libraries/hoopl/testing/Ast2ir.hs ghc-7.2.1/libraries/hoopl/testing/Ast2ir.hs --- ghc-7.0.3/libraries/hoopl/testing/Ast2ir.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/testing/Ast2ir.hs 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,83 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies, NamedFieldPuns #-} +module Ast2ir (astToIR) where + +import Compiler.Hoopl +import Control.Monad +import qualified Data.Map as M + +import qualified Ast as A +import qualified IR as I + +-- For the most part, the translation from an abstract-syntax trees to a graph +-- is straightforward. The one interesting complication is the translation from +-- the AST representation of labels (String) to the graph representation of +-- labels (Label). +-- To keep the mapping from (String -> Label) consistent, we use a LabelMapM monad with +-- the following operation: +labelFor :: String -> LabelMapM Label +getBody :: forall n. Graph n C C -> LabelMapM (Graph n C C) +run :: LabelMapM a -> I.M a + +-- We proceed with the translation from AST to IR; the implementation of the monad +-- is at the end of this file. + +astToIR :: A.Proc -> I.M I.Proc +astToIR (A.Proc {A.name = n, A.args = as, A.body = b}) = run $ + do entry <- getEntry b + body <- toBody b + return $ I.Proc { I.name = n, I.args = as, I.body = body, I.entry = entry } + +getEntry :: [A.Block] -> LabelMapM Label +getEntry [] = error "Parsed procedures should not be empty" +getEntry (b : _) = labelFor $ A.first b + +toBody :: [A.Block] -> LabelMapM (Graph I.Insn C C) +toBody bs = + do g <- foldl (liftM2 (|*><*|)) (return emptyClosedGraph) (map toBlock bs) + getBody g + +toBlock :: A.Block -> LabelMapM (Graph I.Insn C C) +toBlock (A.Block { A.first = f, A.mids = ms, A.last = l }) = + do f' <- toFirst f + ms' <- mapM toMid ms + l' <- toLast l + return $ mkFirst f' <*> mkMiddles ms' <*> mkLast l' + +toFirst :: A.Lbl -> LabelMapM (I.Insn C O) +toFirst = liftM I.Label . labelFor + +toMid :: A.Insn -> LabelMapM (I.Insn O O) +toMid (A.Assign v e) = return $ I.Assign v e +toMid (A.Store a e) = return $ I.Store a e + +toLast :: A.Control -> LabelMapM (I.Insn O C) +toLast (A.Branch l) = labelFor l >>= return . I.Branch +toLast (A.Cond e t f) = labelFor t >>= \t' -> + labelFor f >>= \f' -> return (I.Cond e t' f') +toLast (A.Call rs f as l) = labelFor l >>= return . I.Call rs f as +toLast (A.Return es) = return $ I.Return es + + +-------------------------------------------------------------------------------- +-- The LabelMapM monad +-------------------------------------------------------------------------------- + +type IdLabelMap = M.Map String Label +data LabelMapM a = LabelMapM (IdLabelMap -> I.M (IdLabelMap, a)) +instance Monad LabelMapM where + return x = LabelMapM (\m -> return (m, x)) + LabelMapM f1 >>= k = LabelMapM (\m -> do (m', x) <- f1 m + let (LabelMapM f2) = k x + f2 m') +labelFor l = LabelMapM f + where f m = case M.lookup l m of + Just l' -> return (m, l') + Nothing -> do l' <- freshLabel + let m' = M.insert l l' m + return (m', l') + +getBody graph = LabelMapM f + where f m = return (m, graph) + +run (LabelMapM f) = f M.empty >>= return . snd diff -Nru ghc-7.0.3/libraries/hoopl/testing/Ast.hs ghc-7.2.1/libraries/hoopl/testing/Ast.hs --- ghc-7.0.3/libraries/hoopl/testing/Ast.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/testing/Ast.hs 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,32 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies, NamedFieldPuns #-} +module Ast (Proc(..), Block(..), Insn(..), Control(..), Lbl) where + +import Expr + +-- | A procedure has a name, a sequence of arguments, and a body, +-- which is a sequence of basic blocks. The procedure entry +-- is the first block in the body. +data Proc = Proc { name :: String, args :: [Var], body :: [Block] } + +-- | A block consists of a label, a sequence of instructions, +-- and a control-transfer instruction. +data Block = Block { first :: Lbl, mids :: [Insn], last :: Control } + +-- | An instruction is an assignment to a variable or a store to memory. +data Insn = Assign Var Expr + | Store Expr Expr + +-- | Control transfers are branches (unconditional and conditional), +-- call, and return. +-- The Call instruction takes several parameters: variables to get +-- values returned from the call, the name of the function, +-- arguments to the function, and the label for the successor +-- of the function call. +data Control = Branch Lbl + | Cond Expr Lbl Lbl + | Call [Var] String [Expr] Lbl + | Return [Expr] + +-- | Labels are represented as strings in an AST. +type Lbl = String diff -Nru ghc-7.0.3/libraries/hoopl/testing/constprop-figure ghc-7.2.1/libraries/hoopl/testing/constprop-figure --- ghc-7.0.3/libraries/hoopl/testing/constprop-figure 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/testing/constprop-figure 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,52 @@ +Changes: + o - deriving + o s/Var/Reg/ + o s/M./Map./ + o s/Lit/Const/ + o outfacts are a list instead of a factbase + o - Call and Return + o - txToMaybe + o in constProp s/changeTx and return/ -> Just and Nothing + +data WithTop a = Elt a | Top +type ConstFact = Map Reg (WithTop Const) + +constLattice = DataflowLattice + { fact_bot = Map.empty + , fact_add_to = stdMapJoin constFactAdd + , fact_name = "Const var value" } + where + constFactAdd new old = (ch, joined) + where joined = if new == old then new else Top + ch = if joined == old then NoChange else SomeChange + +varHasConst :: ForwardTransfers Node ConstFact +varHasConst (Label bid) f = lookupFact constLattice f bid +varHasConst (Assign x (Const l)) f = Map.insert x (Elt l) f +varHasConst (Assign x _) f = Map.insert x Top f +varHasConst (Store _ _) f = f +varHasConst (Branch bid) f = [(bid, f)] +varHasConst (Cond _ tid fid) f = [(tid, f), (fid, f)] + +-- I think the getInFacts might disappear with Hoopl4? +constProp :: ForwardRewrites Node ConstFact +constProp n facts = + map_EN (map_EE rewriteE) n >>= return . toAGraph + where + rewriteE e@(Var v) = + case M.lookup v (getInFacts constLattice facts n) of + Just (Elt l) -> Just $ Const l + _ -> Nothing + rewriteE e = Nothing + +-- Simplification ("constant folding") +simplify :: ForwardRewrites Node ConstFact +simplify node _ = s node >>= return . toAGraph + where + s :: Node e x -> TxRes (Node e x) + s (Cond (Const (Bool True)) t _) = Just $ Branch t + s (Cond (Const (Bool False)) f _) = Just $ Branch f + s n = map_EN (map_EE s_e) n + s_e (Binop Add (Const (Int i1)) (Const (Int i2))) -> + Just $ Const $ Int $ i1 + i2 + .... -- more cases for constant folding diff -Nru ghc-7.0.3/libraries/hoopl/testing/ConstProp.hs ghc-7.2.1/libraries/hoopl/testing/ConstProp.hs --- ghc-7.0.3/libraries/hoopl/testing/ConstProp.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/testing/ConstProp.hs 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,82 @@ +{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-} +{-# LANGUAGE ScopedTypeVariables, GADTs #-} +module ConstProp (ConstFact, constLattice, initFact, varHasLit, constProp) where + +import Control.Monad +import qualified Data.Map as Map + +import Compiler.Hoopl +import IR +import OptSupport + +type Node = Insn -- for paper + +-- ConstFact: +-- Not present in map => bottom +-- PElem v => variable has value v +-- Top => variable's value is not constant +-- @ start cprop.tex +-- Type and definition of the lattice +type ConstFact = Map.Map Var (WithTop Lit) +constLattice :: DataflowLattice ConstFact +constLattice = DataflowLattice + { fact_name = "Const var value" + , fact_bot = Map.empty + , fact_join = joinMaps (extendJoinDomain constFactAdd) } + where + constFactAdd _ (OldFact old) (NewFact new) + = if new == old then (NoChange, PElem new) + else (SomeChange, Top) + +-- @ end cprop.tex +-- Initially, we assume that all variable values are unknown. +initFact :: [Var] -> ConstFact +initFact vars = Map.fromList $ [(v, Top) | v <- vars] + +-- Only interesting semantic choice: values of variables are live across +-- a call site. +-- Note that we don't need a case for x := y, where y holds a constant. +-- We can write the simplest solution and rely on the interleaved optimization. +-- @ start cprop.tex +-------------------------------------------------- +-- Analysis: variable equals a literal constant +varHasLit :: FwdTransfer Node ConstFact +varHasLit = mkFTransfer ft + where + ft :: Node e x -> ConstFact -> Fact x ConstFact + ft (Label _) f = f + ft (Assign x (Lit k)) f = Map.insert x (PElem k) f + ft (Assign x _) f = Map.insert x Top f + ft (Store _ _) f = f + ft (Branch l) f = mapSingleton l f + ft (Cond (Var x) tl fl) f + = mkFactBase constLattice + [(tl, Map.insert x (PElem (Bool True)) f), + (fl, Map.insert x (PElem (Bool False)) f)] + ft (Cond _ tl fl) f + = mkFactBase constLattice [(tl, f), (fl, f)] + +-- @ end cprop.tex + ft (Call vs _ _ bid) f = mapSingleton bid (foldl toTop f vs) + where toTop f v = Map.insert v Top f + ft (Return _) _ = mapEmpty + +type MaybeChange a = a -> Maybe a +-- @ start cprop.tex +-------------------------------------------------- +-- Rewriting: replace constant variables +constProp :: forall m. FuelMonad m => FwdRewrite m Node ConstFact +constProp = mkFRewrite cp + where + cp :: Node e x -> ConstFact -> m (Maybe (Graph Node e x)) + cp node f + = return $ liftM insnToG $ mapVN (lookup f) node + + mapVN :: (Var -> Maybe Expr) -> MaybeChange (Node e x) + mapVN = mapEN . mapEE . mapVE + + lookup :: ConstFact -> Var -> Maybe Expr + lookup f x = case Map.lookup x f of + Just (PElem v) -> Just $ Lit v + _ -> Nothing +-- @ end cprop.tex diff -Nru ghc-7.0.3/libraries/hoopl/testing/Eval.hs ghc-7.2.1/libraries/hoopl/testing/Eval.hs --- ghc-7.0.3/libraries/hoopl/testing/Eval.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/testing/Eval.hs 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,175 @@ +{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-} +{-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies, NamedFieldPuns , FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-} + +module Eval (evalProg, ErrorM) where + +import Control.Monad.Error +import qualified Data.Map as M +import Prelude hiding (succ) + +import EvalMonad +import Compiler.Hoopl +import IR + +-- Evaluation functions +evalProg :: EvalTarget v => [Proc] -> [v] -> String -> [v] -> ErrorM (State v, [v]) +evalProg procs vs main args = runProg procs vs $ evalProc main args + +evalProc :: EvalTarget v => String -> [v] -> EvalM v [v] +evalProc proc_name actuals = + do event $ CallEvt proc_name actuals + proc <- get_proc proc_name + evalProc' proc actuals +evalProc' :: EvalTarget v => Proc -> [v] -> EvalM v [v] +evalProc' (Proc {name=_, args, body, entry}) actuals = + if length args == length actuals then + evalBody (M.fromList $ zip args actuals) body entry + else throwError $ "Param/actual mismatch: " ++ show args ++ " = " ++ show actuals + +-- Responsible for allocating and deallocating its own stack frame. +evalBody :: EvalTarget v => VarEnv v -> Graph Insn C C -> Label -> EvalM v [v] +evalBody vars graph entry = inNewFrame vars graph $ get_block entry >>= evalB + +evalB :: forall v . EvalTarget v => Block Insn C C -> EvalM v [v] +evalB b = foldBlockNodesF3 (lift evalF, lift evalM, lift evalL) b $ return () + where + lift :: forall e x y . (Insn e x -> EvalM v y) -> Insn e x -> EvalM v () -> EvalM v y + lift f n z = z >> f n + + +evalF :: EvalTarget v => Insn C O -> EvalM v () +evalF (Label _) = return () + +evalM :: EvalTarget v => Insn O O -> EvalM v () +evalM (Assign var e) = + do v_e <- eval e + set_var var v_e +evalM (Store addr e) = + do v_addr <- eval addr >>= toAddr + v_e <- eval e + -- StoreEvt recorded in set_heap + set_heap v_addr v_e + +evalL :: EvalTarget v => Insn O C -> EvalM v [v] +evalL (Branch bid) = + do b <- get_block bid + evalB b +evalL (Cond e t f) = + do v_e <- eval e >>= toBool + evalL $ Branch $ if v_e then t else f +evalL (Call ress f args succ) = + do v_args <- mapM eval args + -- event is recorded in evalProc + f_ress <- evalProc f v_args + if length ress == length f_ress then return () + else throwError $ "function " ++ f ++ " returned unexpected # of args" + _ <- mapM (uncurry set_var) $ zip ress f_ress + evalL $ Branch succ +evalL (Return es) = + do vs <- mapM eval es + event $ RetEvt vs + return vs + +class Show v => EvalTarget v where + toAddr :: v -> EvalM v Integer + toBool :: v -> EvalM v Bool + eval :: Expr -> EvalM v v + +instance EvalTarget Value where + toAddr (I i) = return i + toAddr (B _) = throwError "conversion to address failed" + toBool (B b) = return b + toBool (I _) = throwError "conversion to bool failed" + eval (Lit (Int i)) = return $ I i + eval (Lit (Bool b)) = return $ B b + eval (Var var) = get_var var + eval (Load addr) = + do v_addr <- eval addr >>= toAddr + get_heap v_addr + eval (Binop bop e1 e2) = + do v1 <- eval e1 + v2 <- eval e2 + liftBinOp bop v1 v2 + where + liftBinOp = liftOp + where liftOp Add = i (+) + liftOp Sub = i (-) + liftOp Mul = i (*) + liftOp Div = i div + liftOp Eq = b (==) + liftOp Ne = b (/=) + liftOp Gt = b (>) + liftOp Lt = b (<) + liftOp Gte = b (>=) + liftOp Lte = b (<=) + i = liftX I fromI + b = liftX B fromB + + liftX :: Monad m => (a -> b) -> (b -> m a) -> (a -> a -> a) -> b -> b -> m b + liftX up dwn = \ op x y -> do v_x <- dwn x + v_y <- dwn y + return $ up $ op v_x v_y + fromI (I x) = return x + fromI (B _) = throwError "fromI: got a B" + + fromB (I _) = throwError "fromB: got an I" + fromB (B x) = return x + +-- I'm under no delusion that the following example is useful, +-- but it demonstrates how the evaluator can use a new kind +-- of evaluator. +instance EvalTarget Integer where + toAddr i = return i + toBool i = return $ i /= 0 + eval (Lit (Int i)) = return i + eval (Lit (Bool True)) = return 1 + eval (Lit (Bool False)) = return 0 + eval (Var var) = get_var var + eval (Load addr) = + do v_addr <- eval addr >>= toAddr + get_heap v_addr + eval (Binop bop e1 e2) = + do v1 <- eval e1 + v2 <- eval e2 + return $ liftBinOp bop v1 v2 + where + liftBinOp = liftOp + where liftOp Add = i (+) + liftOp Sub = i (-) + liftOp Mul = i (*) + liftOp Div = i div + liftOp Eq = b (==) + liftOp Ne = b (/=) + liftOp Gt = b (>) + liftOp Lt = b (<) + liftOp Gte = b (>=) + liftOp Lte = b (<=) + i = id + b opr x y = if opr x y then 1 else 0 + + +-- Symbolic evaluation. +-- Hard questions: +-- - how do we get heap addresses? +-- - how do we get conditionals? +-- - how do we compare symbolic expressions? +data Sym = L Lit + | In Integer -- In x indicates a value on entry to the program + | Ld Sym + | BO BinOp Sym Sym + deriving Show +-- sym_vsupply :: [Sym] +-- sym_vsupply = [In n | n <- [0..]] + +instance EvalTarget Sym where + toAddr _ = undefined + toBool _ = undefined + eval (Lit l) = return $ L l + eval (Var var) = get_var var + eval (Load addr) = + do v_addr <- eval addr >>= toAddr + get_heap v_addr + eval (Binop bop e1 e2) = + do v1 <- eval e1 + v2 <- eval e2 + return $ BO bop v1 v2 diff -Nru ghc-7.0.3/libraries/hoopl/testing/EvalMonad.hs ghc-7.2.1/libraries/hoopl/testing/EvalMonad.hs --- ghc-7.0.3/libraries/hoopl/testing/EvalMonad.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/testing/EvalMonad.hs 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,137 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies, NamedFieldPuns , FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-} + +module EvalMonad (ErrorM, VarEnv, B, State, + EvalM, runProg, inNewFrame, get_proc, get_block, + get_var, set_var, get_heap, set_heap, + Event (..), event) where + +import Control.Monad.Error +import qualified Data.Map as M +import Prelude hiding (succ) + +import Compiler.Hoopl +import IR + +type ErrorM = Either String +type InnerErrorM v = Either (State v, String) +instance Error (State v, String) where + noMsg = (undefined, "") + strMsg str = (undefined, str) + +data EvalM v a = EvalM (State v -> InnerErrorM v (State v, a)) + +instance Monad (EvalM v) where + return x = EvalM (\s -> return (s, x)) + EvalM f >>= k = EvalM $ \s -> do (s', x) <- f s + let EvalM f' = k x + f' s' +instance MonadError String (EvalM v) where + throwError e = EvalM (\s -> throwError (s, e)) + catchError (EvalM f) handler = + EvalM $ \s -> f s `catchError` handler' + where handler' (s', e) = let EvalM f' = handler e + in f' s' + +-- Shorthands for frequently used types +type VarEnv v = M.Map Var v +type HeapEnv v = M.Map Addr v -- word addressed heap +type Addr = Integer +type B = Block Insn C C +type PEnv = M.Map String Proc +type G = Graph Insn C C + +runProg :: [Proc] -> [v] -> EvalM v x -> ErrorM (State v, x) +runProg procs vs (EvalM f) = + case f init_state of + Left (_, e) -> throwError e + Right x -> return x + where + init_state = State { frames = [], heap = M.empty, events = [], + vsupply = vs, procs = procMap } + procMap = M.fromList $ zip (map name procs) procs + +get_state :: EvalM v (State v) +get_state = EvalM f + where f state = return (state, state) + +upd_state :: (State v -> State v) -> EvalM v () +upd_state upd = EvalM (\state -> return (upd state, ())) + +event :: Event v -> EvalM v () +event e = upd_state (\s -> s {events = e : events s}) + +---------------------------------- +-- State of the machine +data State v = State { frames :: [(VarEnv v, G)] + , heap :: HeapEnv v + , procs :: PEnv + , vsupply :: [v] + , events :: [Event v] + } +data Event v = CallEvt String [v] + | RetEvt [v] + | StoreEvt Addr v + | ReadEvt Addr v + +get_var :: Var -> EvalM v v +get_var var = get_state >>= k + where k (State {frames = (vars, _):_}) = mlookup "var" var vars + k _ = throwError "can't get vars from empty stack" + +set_var :: Var -> v -> EvalM v () +set_var var val = upd_state f + where f s@(State {frames = (vars, blocks):vs}) = + s { frames = (M.insert var val vars, blocks):vs } + f _ = error "can't set var with empty stack" + +-- Special treatment for the heap: +-- If a heap location doesn't have a value, we give it one. +get_heap :: Addr -> EvalM v v +get_heap addr = + do State {heap, vsupply} <- get_state + (v, vs) <- case vsupply of v:vs -> return (v, vs) + _ -> throwError "hlookup hit end of value supply" + upd_state (\s -> s {heap = M.insert addr v heap, vsupply = vs}) + event $ ReadEvt addr v + return v + +set_heap :: Addr -> v -> EvalM v () +set_heap addr val = + do event $ StoreEvt addr val + upd_state $ \ s -> s { heap = M.insert addr val (heap s) } + +get_block :: Label -> EvalM v B +get_block lbl = get_state >>= k + where k (State {frames = (_, graph):_}) = blookup "block" graph lbl + k _ = error "can't get blocks from empty stack" + +get_proc :: String -> EvalM v Proc +get_proc name = get_state >>= mlookup "proc" name . procs + +newFrame :: VarEnv v -> G -> EvalM v () +newFrame vars graph = upd_state $ \s -> s { frames = (vars, graph) : frames s} + +popFrame :: EvalM v () +popFrame = upd_state f + where f s@(State {frames = _:fs}) = s { frames = fs } + f _ = error "popFrame: no frame to pop..." -- implementation error + +inNewFrame :: VarEnv v -> G -> EvalM v x -> EvalM v x +inNewFrame vars graph runFrame = + do newFrame vars graph + x <- runFrame + popFrame + return x + +mlookup :: Ord k => String -> k -> M.Map k v -> EvalM v' v +mlookup blame k m = + case M.lookup k m of + Just v -> return v + Nothing -> throwError ("unknown lookup for " ++ blame) + +blookup :: String -> G -> Label -> EvalM v B +blookup blame g lbl = + case lookupBlock g lbl of + BodyBlock b -> return b + NoBlock -> throwError ("unknown lookup for " ++ blame) diff -Nru ghc-7.0.3/libraries/hoopl/testing/Expr.hs ghc-7.2.1/libraries/hoopl/testing/Expr.hs --- ghc-7.0.3/libraries/hoopl/testing/Expr.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/testing/Expr.hs 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,42 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies, NamedFieldPuns #-} +module Expr (Expr(..), BinOp(..), Lit(..), Var) where + +import PP + +data Expr = Lit Lit + | Var Var + | Load Expr + | Binop BinOp Expr Expr +data BinOp = Add | Sub | Mul | Div | Eq | Ne | Lt | Gt | Lte | Gte + +data Lit = Bool Bool | Int Integer deriving Eq +type Var = String + +-------------------------------------------------------------------------------- +--- Prettyprinting +-------------------------------------------------------------------------------- + +instance Show Expr where + show (Lit i) = show i + show (Var v) = v + show (Load e) = "m[" ++ show e ++ "]" + show (Binop b e1 e2) = sub e1 ++ " " ++ show b ++ " " ++ sub e2 + where sub e@(Binop _ _ _) = tuple [show e] + sub e = show e + +instance Show Lit where + show (Int i) = show i + show (Bool b) = show b + +instance Show BinOp where + show Add = "+" + show Sub = "-" + show Mul = "*" + show Div = "/" + show Eq = "=" + show Ne = "/=" + show Gt = ">" + show Lt = "<" + show Gte = ">=" + show Lte = "<=" diff -Nru ghc-7.0.3/libraries/hoopl/testing/.gitignore ghc-7.2.1/libraries/hoopl/testing/.gitignore --- ghc-7.0.3/libraries/hoopl/testing/.gitignore 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/testing/.gitignore 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,4 @@ +*.hi +*.hc +*.o +Main diff -Nru ghc-7.0.3/libraries/hoopl/testing/IR.hs ghc-7.2.1/libraries/hoopl/testing/IR.hs --- ghc-7.0.3/libraries/hoopl/testing/IR.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/testing/IR.hs 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,60 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies, NamedFieldPuns #-} +module IR (Proc (..), Insn (..), Expr (..), Lit (..), Value (..), BinOp(..), Var + , showProc + , M) where + +import Prelude hiding (succ) + +import Compiler.Hoopl +import Expr +import PP + +type M = CheckingFuelMonad (SimpleUniqueMonad) + +data Value = B Bool | I Integer deriving Eq + +data Proc = Proc { name :: String, args :: [Var], entry :: Label, body :: Graph Insn C C } + +data Insn e x where + Label :: Label -> Insn C O + Assign :: Var -> Expr -> Insn O O + Store :: Expr -> Expr -> Insn O O + Branch :: Label -> Insn O C + Cond :: Expr -> Label -> Label -> Insn O C + Call :: [Var] -> String -> [Expr] -> Label -> Insn O C + Return :: [Expr] -> Insn O C + +instance NonLocal Insn where + entryLabel (Label l) = l + successors (Branch l) = [l] + successors (Cond _ t f) = [t, f] + successors (Call _ _ _ l) = [l] + successors (Return _) = [] + +-------------------------------------------------------------------------------- +-- Prettyprinting +-------------------------------------------------------------------------------- + +showProc :: Proc -> String +showProc proc = name proc ++ tuple (args proc) ++ graph + where + graph = " {\n" ++ showGraph show (body proc) ++ "}\n" + +instance Show (Insn e x) where + show (Label lbl) = show lbl ++ ":" + show (Assign v e) = ind $ v ++ " = " ++ show e + show (Store addr e) = ind $ "m[" ++ show addr ++ "] = " ++ show e + show (Branch lbl) = ind $ "goto " ++ show lbl + show (Cond e t f) = + ind $ "if " ++ show e ++ " then goto " ++ show t ++ " else goto " ++ show f + show (Call ress f cargs succ) = + ind $ tuple ress ++ " = " ++ f ++ tuple (map show cargs) ++ " goto " ++ show succ + show (Return rargs) = ind $ "ret " ++ tuple (map show rargs) + +ind :: String -> String +ind x = " " ++ x + +instance Show Value where + show (B b) = show b + show (I i) = show i diff -Nru ghc-7.0.3/libraries/hoopl/testing/Live.hs ghc-7.2.1/libraries/hoopl/testing/Live.hs --- ghc-7.0.3/libraries/hoopl/testing/Live.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/testing/Live.hs 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,50 @@ +{-# OPTIONS_GHC -Wall -fno-warn-incomplete-patterns #-} +{-# LANGUAGE ScopedTypeVariables, GADTs #-} +module Live (liveLattice, liveness, deadAsstElim) where + +import Data.Maybe +import qualified Data.Set as S + +import Compiler.Hoopl +import IR +import OptSupport + +type Live = S.Set Var +liveLattice :: DataflowLattice Live +liveLattice = DataflowLattice + { fact_name = "Live variables" + , fact_bot = S.empty + , fact_join = add + } + where add _ (OldFact old) (NewFact new) = (ch, j) + where + j = new `S.union` old + ch = changeIf (S.size j > S.size old) + +liveness :: BwdTransfer Insn Live +liveness = mkBTransfer live + where + live :: Insn e x -> Fact x Live -> Live + live (Label _) f = f + live n@(Assign x _) f = addUses (S.delete x f) n + live n@(Store _ _) f = addUses f n + live n@(Branch l) f = addUses (fact f l) n + live n@(Cond _ tl fl) f = addUses (fact f tl `S.union` fact f fl) n + live n@(Call vs _ _ l) f = addUses (fact f l `S.difference` S.fromList vs) n + live n@(Return _) _ = addUses (fact_bot liveLattice) n + + fact :: FactBase (S.Set Var) -> Label -> Live + fact f l = fromMaybe S.empty $ lookupFact l f + + addUses :: S.Set Var -> Insn e x -> Live + addUses = fold_EN (fold_EE addVar) + addVar s (Var v) = S.insert v s + addVar s _ = s + +deadAsstElim :: forall m . FuelMonad m => BwdRewrite m Insn Live +deadAsstElim = mkBRewrite d + where + d :: Insn e x -> Fact x Live -> m (Maybe (Graph Insn e x)) + d (Assign x _) live + | not (x `S.member` live) = return $ Just emptyGraph + d _ _ = return Nothing diff -Nru ghc-7.0.3/libraries/hoopl/testing/Main.hs ghc-7.2.1/libraries/hoopl/testing/Main.hs --- ghc-7.0.3/libraries/hoopl/testing/Main.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/testing/Main.hs 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,12 @@ +module Main (main) where + +import Test + +-- Hardcoding test locations for now +tests = map (\t -> "tests" ++ "/" ++ t) + (["test1", "test2", "test3", "test4"] ++ + ["if-test", "if-test2", "if-test3", "if-test4"]) + +main :: IO () +main = do mapM (\x -> putStrLn ("Test:" ++ x) >> parseTest x >> optTest x) tests + return () diff -Nru ghc-7.0.3/libraries/hoopl/testing/mkfile ghc-7.2.1/libraries/hoopl/testing/mkfile --- ghc-7.0.3/libraries/hoopl/testing/mkfile 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/testing/mkfile 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,22 @@ +HS=`echo *.hs` + +all:V: Main +clean:V: + rm -f Main + rm -f *.o *.hi *~ + +Main: $HS + ghc --make Main.hs + +FUNSOUT=16 + +test:VQ: + rm -f Main + ghc --make Main.hs + if ./Main > /dev/null && [ `./Main | grep '^f.*{$' | wc -l ` -eq $FUNSOUT ] + then + echo "Passed `expr $FUNSOUT / 2` tests" >&2 + else + echo "Test failed" >&2 + exit 1 + fi diff -Nru ghc-7.0.3/libraries/hoopl/testing/OptSupport.hs ghc-7.2.1/libraries/hoopl/testing/OptSupport.hs --- ghc-7.0.3/libraries/hoopl/testing/OptSupport.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/testing/OptSupport.hs 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,123 @@ +{-# LANGUAGE GADTs, RankNTypes #-} +{-# OPTIONS_GHC -Wall -fno-warn-name-shadowing #-} +module OptSupport (mapVE, mapEE, mapEN, mapVN, fold_EE, fold_EN, insnToG) where + +import Control.Monad +import Data.Maybe +import Prelude hiding (succ) + +import Compiler.Hoopl +import IR + +---------------------------------------------- +-- Map/Fold functions for expressions/insns +---------------------------------------------- + +type Node = Insn +type MaybeChange a = a -> Maybe a +mapVE :: (Var -> Maybe Expr) -> MaybeChange Expr +mapEE :: MaybeChange Expr -> MaybeChange Expr +mapEN :: MaybeChange Expr -> MaybeChange (Node e x) +mapVN :: (Var -> Maybe Expr) -> MaybeChange (Node e x) + +mapVN = mapEN . mapEE . mapVE + +mapVE f (Var v) = f v +mapVE _ _ = Nothing + + +data Mapped a = Old a | New a +instance Monad Mapped where + return = Old + Old a >>= k = k a + New a >>= k = asNew (k a) + where asNew (Old a) = New a + asNew m@(New _) = m + +makeTotal :: (a -> Maybe a) -> (a -> Mapped a) +makeTotal f a = case f a of Just a' -> New a' + Nothing -> Old a +makeTotalDefault :: b -> (a -> Maybe b) -> (a -> Mapped b) +makeTotalDefault b f a = case f a of Just b' -> New b' + Nothing -> Old b +ifNew :: Mapped a -> Maybe a +ifNew (New a) = Just a +ifNew (Old _) = Nothing + +type Mapping a b = a -> Mapped b + +(/@/) :: Mapping b c -> Mapping a b -> Mapping a c +f /@/ g = \x -> g x >>= f + + +class HasExpressions a where + mapAllSubexpressions :: Mapping Expr Expr -> Mapping a a + +instance HasExpressions (Insn e x) where + mapAllSubexpressions = error "urk!" (mapVars, (/@/), makeTotal, ifNew) + +mapVars :: (Var -> Maybe Expr) -> Mapping Expr Expr +mapVars f e@(Var x) = makeTotalDefault e f x +mapVars _ e = return e + + +mapEE f e@(Lit _) = f e +mapEE f e@(Var _) = f e +mapEE f e@(Load addr) = + case mapEE f addr of + Just addr' -> Just $ fromMaybe e' (f e') + where e' = Load addr' + Nothing -> f e +mapEE f e@(Binop op e1 e2) = + case (mapEE f e1, mapEE f e2) of + (Nothing, Nothing) -> f e + (e1', e2') -> Just $ fromMaybe e' (f e') + where e' = Binop op (fromMaybe e1 e1') (fromMaybe e2 e2') + +mapEN _ (Label _) = Nothing +mapEN f (Assign v e) = liftM (Assign v) $ f e +mapEN f (Store addr e) = + case (f addr, f e) of + (Nothing, Nothing) -> Nothing + (addr', e') -> Just $ Store (fromMaybe addr addr') (fromMaybe e e') +mapEN _ (Branch _) = Nothing +mapEN f (Cond e tid fid) = + case f e of Just e' -> Just $ Cond e' tid fid + Nothing -> Nothing +mapEN f (Call rs n es succ) = + if all isNothing es' then Nothing + else Just $ Call rs n (map (uncurry fromMaybe) (zip es es')) succ + where es' = map f es +mapEN f (Return es) = + if all isNothing es' then Nothing + else Just $ Return (map (uncurry fromMaybe) (zip es es')) + where es' = map f es + +fold_EE :: (a -> Expr -> a) -> a -> Expr -> a +fold_EN :: (a -> Expr -> a) -> a -> Insn e x -> a + +fold_EE f z e@(Lit _) = f z e +fold_EE f z e@(Var _) = f z e +fold_EE f z e@(Load addr) = f (f z addr) e +fold_EE f z e@(Binop _ e1 e2) = f (f (f z e2) e1) e + +fold_EN _ z (Label _) = z +fold_EN f z (Assign _ e) = f z e +fold_EN f z (Store addr e) = f (f z e) addr +fold_EN _ z (Branch _) = z +fold_EN f z (Cond e _ _) = f z e +fold_EN f z (Call _ _ es _) = foldl f z es +fold_EN f z (Return es) = foldl f z es + +---------------------------------------------- +-- Lift a insn to a Graph +---------------------------------------------- + +insnToG :: Insn e x -> Graph Insn e x +insnToG n@(Label _) = mkFirst n +insnToG n@(Assign _ _) = mkMiddle n +insnToG n@(Store _ _) = mkMiddle n +insnToG n@(Branch _) = mkLast n +insnToG n@(Cond _ _ _) = mkLast n +insnToG n@(Call _ _ _ _) = mkLast n +insnToG n@(Return _) = mkLast n diff -Nru ghc-7.0.3/libraries/hoopl/testing/Parse.hs ghc-7.2.1/libraries/hoopl/testing/Parse.hs --- ghc-7.0.3/libraries/hoopl/testing/Parse.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/testing/Parse.hs 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,202 @@ +{-# LANGUAGE GADTs #-} +{-# OPTIONS_GHC -Wall #-} +module Parse (parseCode) where + +import Control.Monad +import Prelude hiding (id, last, succ) + +-- Note: We do not need to import Hoopl to build an AST. +import Ast +import Expr +import Text.ParserCombinators.Parsec +import Text.ParserCombinators.Parsec.Expr +import Text.ParserCombinators.Parsec.Language +import qualified Text.ParserCombinators.Parsec.Token as P + +-- I'm stealing this parser almost directly from Daan Leijen's Parsec guide. +lexer :: P.TokenParser () +lexer = P.makeTokenParser (haskellDef {reservedOpNames = ["+", "-", "*", "/", "=", "<"]}) + +-- Common lexers: +lexeme, parens, braces :: CharParser () a -> CharParser () a +lexeme = P.lexeme lexer +parens = P.parens lexer +braces = P.braces lexer + +commaSep :: CharParser () a -> CharParser () [a] +commaSep = P.commaSep lexer + +reserved :: String -> CharParser () () +reserved = P.reserved lexer + +ign :: GenParser Char st a -> GenParser Char st () +ign p = p >> return () + +char' :: Char -> GenParser Char st () +char' c = ign $ char c + +identifier :: CharParser () String +identifier = P.identifier lexer + +natural :: CharParser () Integer +natural = P.natural lexer + +reservedOp :: String -> CharParser () () +reservedOp = P.reservedOp lexer + +whitespace :: CharParser () () +whitespace = P.whiteSpace lexer + +-- Expressions: +expr :: Parser Expr +expr = buildExpressionParser table factor + "Expression" + where + table = [[op "*" (Binop Mul) AssocLeft, op "/" (Binop Div) AssocLeft], + [op "+" (Binop Add) AssocLeft, op "-" (Binop Sub) AssocLeft], + [op "=" (Binop Eq) AssocLeft, op "/=" (Binop Ne) AssocLeft, + op ">" (Binop Gt) AssocLeft, op "<" (Binop Lt) AssocLeft, + op ">=" (Binop Gte) AssocLeft, op "<=" (Binop Lte) AssocLeft]] + op o f assoc = Infix (do {reservedOp o; return f} "operator") assoc + factor = parens expr + <|> lit + <|> fetchVar + <|> load + "simple Expression" + +bool :: Parser Bool +bool = (try $ lexeme (string "True") >> return True) + <|> (try $ lexeme (string "False") >> return False) + +lit :: Parser Expr +lit = (natural >>= (return . Lit . Int)) + <|> (bool >>= (return . Lit . Bool)) + <|> (bool >>= (return . Lit . Bool)) + "lit" + +loc :: Char -> Parser x -> Parser x +loc s addr = try (lexeme (do { char' s + ; char' '[' + ; a <- addr + ; char' ']' + ; return a + })) + "loc" + +var :: Parser String +var = identifier + "var" + +mem :: Parser Expr -- address +mem = loc 'm' expr + "mem" + +fetchVar, load :: Parser Expr +fetchVar = var >>= return . Var +load = mem >>= return . Load + + +labl :: Parser Lbl +labl = lexeme (do { id <- identifier + ; char' ':' + ; return id + }) + "label" + +mid :: Parser Insn +mid = asst + <|> store + "assignment or store" + +asst :: Parser Insn +asst = do { v <- lexeme var + ; lexeme (char' '=') + ; e <- expr + ; return $ Assign v e + } + "asst" + +store :: Parser Insn +store = do { addr <- lexeme mem + ; lexeme (char' '=') + ; e <- expr + ; return $ Store addr e + } + "store" + +control :: Parser Control +control = branch + <|> cond + <|> call + <|> ret + "control-transfer" + + +goto :: Parser Lbl +goto = do { lexeme (reserved "goto") + ; identifier + } + "goto" + +branch :: Parser Control +branch = + do { l <- goto + ; return $ Branch l + } + "branch" + +cond, call, ret :: Parser Control +cond = + do { lexeme (reserved "if") + ; cnd <- expr + ; lexeme (reserved "then") + ; thn <- goto + ; lexeme (reserved "else") + ; els <- goto + ; return $ Cond cnd thn els + } + "cond" + +call = + do { results <- tuple var + ; lexeme (char' '=') + ; f <- identifier + ; params <- tuple expr + ; succ <- goto + ; return $ Call results f params succ + } + "call" + +ret = + do { lexeme (reserved "ret") + ; results <- tuple expr + ; return $ Return results + } + "ret" + +block :: Parser Block +block = + do { f <- lexeme labl + ; ms <- many $ try mid + ; l <- lexeme control + ; return $ Block { first = f, mids = ms, last = l } + } + "Expected basic block; maybe you forgot a label following a control-transfer?" + +tuple :: Parser a -> Parser [a] +tuple = parens . commaSep + +proc :: Parser Proc +proc = do { whitespace + ; f <- identifier + ; params <- tuple var + ; bdy <- braces $ do { b <- block + ; bs <- many block + ; return (b : bs) + } -- procedure must have at least one block + ; return $ Proc { name = f, args = params, body = bdy } + } + "proc" + +parseCode :: String -> String -> Either ParseError [Proc] +parseCode file inp = parse (many proc) file inp diff -Nru ghc-7.0.3/libraries/hoopl/testing/PP.hs ghc-7.2.1/libraries/hoopl/testing/PP.hs --- ghc-7.0.3/libraries/hoopl/testing/PP.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/testing/PP.hs 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,8 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies, NamedFieldPuns #-} +module PP (tuple) where + +tuple :: [String] -> String +tuple [] = "()" +tuple [a] = "(" ++ a ++ ")" +tuple (a:as) = "(" ++ a ++ concat (map ((++) ", ") as) ++ ")" diff -Nru ghc-7.0.3/libraries/hoopl/testing/README ghc-7.2.1/libraries/hoopl/testing/README --- ghc-7.0.3/libraries/hoopl/testing/README 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/testing/README 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,56 @@ +Here is some testing code which may also serve as a sample client. + + +Base system +~~~~~~~~~~~ + Ast.hs Abstract syntax for a language of basic blocks, + instructions, and calls + + IR.hs Intermediate Representation of a procedure whose body is a + Hoopl control-flow graph. + + Expr.hs Definition of expressions used in both Ast and IR + + Ast2ir.hs Translation from Ast to IR. The highlight is mapping + the string labels in the source from the abstract Labels + defined by Hoopl. + + +Optimizations +~~~~~~~~~~~~~ + ConstProp.hs Constant propagation as described in the paper. + + Live.hs Live-variable analysis and dead-assignment elimination. + + Simplify.s A simplifier for expressions, written as a "deep + forward rewriter" for Hoopl. Used in constant + propagation. + + OptSupport.hs Mysterious functions to support lattice computations + and expression-crawling. May one day be documented. + Eventually may be migrated into Hoopl in generic + form, to support multiple clients. + + +Interpreter +~~~~~~~~~~~ + Eval.hs An interpreter for control-flow graphs. We'd like to + make this code higher-order. + + EvalMonad.hs A monad that maintains the state used by the + interpreter: a value for every variable, plus values + on the heap. + + +Testing +~~~~~~~ + Main.hs Just hacking---there's no real testing code yet + + + +Other +~~~~~ + Parse.hs A parser built using Parsec---does not depend on + Hoopl at all. + + PP.hs A work in progress? diff -Nru ghc-7.0.3/libraries/hoopl/testing/Simplify.hs ghc-7.2.1/libraries/hoopl/testing/Simplify.hs --- ghc-7.0.3/libraries/hoopl/testing/Simplify.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/testing/Simplify.hs 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,47 @@ +{-# OPTIONS_GHC -Wall -fwarn-incomplete-patterns #-} +{-# LANGUAGE ScopedTypeVariables, GADTs, PatternGuards #-} +module Simplify (simplify) where + +import Control.Monad +import Compiler.Hoopl +import IR +import OptSupport + +type Node = Insn + + +-- @ start cprop.tex + +-------------------------------------------------- +-- Simplification ("constant folding") +simplify :: forall m f. FuelMonad m => FwdRewrite m Node f +simplify = deepFwdRw simp + where + simp :: forall e x. Node e x -> f -> m (Maybe (Graph Node e x)) + simp node _ = return $ liftM insnToG $ s_node node + s_node :: Node e x -> Maybe (Node e x) + s_node (Cond (Lit (Bool b)) t f) + = Just $ Branch (if b then t else f) + s_node n = (mapEN . mapEE) s_exp n + s_exp (Binop Add (Lit (Int n1)) (Lit (Int n2))) + = Just $ Lit $ Int $ n1 + n2 + -- ... more cases for constant folding +-- @ end cprop.tex + s_exp (Binop opr e1 e2) + | (Just op, Lit (Int i1), Lit (Int i2)) <- (intOp opr, e1, e2) = + Just $ Lit $ Int $ op i1 i2 + | (Just op, Lit (Int i1), Lit (Int i2)) <- (cmpOp opr, e1, e2) = + Just $ Lit $ Bool $ op i1 i2 + s_exp _ = Nothing + intOp Add = Just (+) + intOp Sub = Just (-) + intOp Mul = Just (*) + intOp Div = Just div + intOp _ = Nothing + cmpOp Eq = Just (==) + cmpOp Ne = Just (/=) + cmpOp Gt = Just (>) + cmpOp Lt = Just (<) + cmpOp Gte = Just (>=) + cmpOp Lte = Just (<=) + cmpOp _ = Nothing diff -Nru ghc-7.0.3/libraries/hoopl/testing/Test.hs ghc-7.2.1/libraries/hoopl/testing/Test.hs --- ghc-7.0.3/libraries/hoopl/testing/Test.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/testing/Test.hs 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,92 @@ +{-# OPTIONS_GHC -Wall #-} +{-# LANGUAGE RankNTypes, ScopedTypeVariables, GADTs, EmptyDataDecls, PatternGuards, TypeFamilies, NamedFieldPuns #-} +module Test (parseTest, evalTest, optTest) where + +import Compiler.Hoopl +import Control.Monad.Error + +import Ast2ir +import ConstProp +import Eval (evalProg, ErrorM) +import IR +import Live +import Parse (parseCode) +import Simplify + +parse :: String -> String -> ErrorM (M [Proc]) +parse file text = + case parseCode file text of + Left err -> throwError $ show err + Right ps -> return $ mapM astToIR ps + +parseTest :: String -> IO () +parseTest file = + do text <- readFile file + case parse file text of + Left err -> putStrLn err + Right p -> mapM (putStrLn . showProc) (runSimpleUniqueMonad $ runWithFuel 0 p) >> return () + +evalTest' :: String -> String -> ErrorM String +evalTest' file text = + do procs <- parse file text + (_, vs) <- testProg (runSimpleUniqueMonad $ runWithFuel 0 procs) + return $ "returning: " ++ show vs + where + testProg procs@(Proc {name, args} : _) = evalProg procs vsupply name (toV args) + testProg _ = throwError "No procedures in test program" + toV args = [I n | (n, _) <- zip [3..] args] + vsupply = [I x | x <- [5..]] + +evalTest :: String -> IO () +evalTest file = + do text <- readFile file + case evalTest' file text of + Left err -> putStrLn err + Right s -> putStrLn s + +optTest' :: String -> String -> ErrorM (M [Proc]) +optTest' file text = + do procs <- parse file text + return $ procs >>= mapM optProc + where + optProc proc@(Proc {entry, body, args}) = + do { (body', _, _) <- analyzeAndRewriteFwd fwd (JustC [entry]) body + (mapSingleton entry (initFact args)) + ; (body'', _, _) <- analyzeAndRewriteBwd bwd (JustC [entry]) body' mapEmpty + ; return $ proc { body = body'' } } + -- With debugging info: + -- fwd = debugFwdJoins trace (const True) $ FwdPass { fp_lattice = constLattice, fp_transfer = varHasLit + -- , fp_rewrite = constProp `thenFwdRw` simplify } + fwd = constPropPass + bwd = BwdPass { bp_lattice = liveLattice, bp_transfer = liveness + , bp_rewrite = deadAsstElim } + +constPropPass :: FuelMonad m => FwdPass m Insn ConstFact +-- @ start cprop.tex + +---------------------------------------- +-- Defining the forward dataflow pass +constPropPass = FwdPass + { fp_lattice = constLattice + , fp_transfer = varHasLit + , fp_rewrite = constProp `thenFwdRw` simplify } +-- @ end cprop.tex + +optTest :: String -> IO () +optTest file = + do text <- readFile file + case optTest' file text of + Left err -> putStrLn err + Right p -> mapM_ (putStrLn . showProc) (runSimpleUniqueMonad $ runWithFuel fuel p) + where + fuel = 99999 + + + +{-- Properties to test: + + 1. Is the fixpoint complete (maps all blocks to facts)? + 2. Is the computed fixpoint actually a fixpoint? + 3. Random test generation. + +--} diff -Nru ghc-7.0.3/libraries/hoopl/testing/tests/ExpectedOutput ghc-7.2.1/libraries/hoopl/testing/tests/ExpectedOutput --- ghc-7.0.3/libraries/hoopl/testing/tests/ExpectedOutput 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/testing/tests/ExpectedOutput 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,203 @@ +f(a, b) { +L1: + r0 = 3 + r1 = 4 + r2 = r0 + r1 + ret (r2) +} + +f(a, b) { +L1: + ret (7) +} + +f(a, b) { +L1: + x = 5 + y = 0 + goto L2 +L2: + if x > 0 then goto L3 else goto L4 +L3: + y = y + x + x = x - 1 + goto L2 +L4: + ret (y) +} + +f(a, b) { +L1: + x = 5 + y = 0 + goto L2 +L2: + if x > 0 then goto L3 else goto L4 +L4: + ret (y) +L3: + y = y + x + x = x - 1 + goto L2 +} + +f(x, y) { +L1: + goto L2 +L2: + if x > 0 then goto L3 else goto L4 +L3: + (z) = f(x - 1, y - 1) goto L5 +L5: + y = y + z + x = x - 1 + goto L2 +L4: + ret (y) +} + +f(x, y) { +L1: + goto L2 +L2: + if x > 0 then goto L3 else goto L4 +L4: + ret (y) +L3: + (z) = f(x - 1, y - 1) goto L5 +L5: + y = y + z + x = x - 1 + goto L2 +} + +f(x) { +L1: + y = 5 + goto L2 +L2: + if y < 0 then goto L3 else goto L4 +L3: + y = y - 1 + goto L2 +L4: + ret ((x + y) + 4) +} + +f(x) { +L1: + goto L2 +L2: + goto L4 +L4: + ret ((x + 5) + 4) +} + +f() { +L1: + x = 3 + 4 + z = x > 5 + if z then goto L2 else goto L3 +L2: + ret (1) +L3: + ret (2) +} + +f() { +L1: + goto L2 +L2: + ret (1) +} + +f(a) { +L1: + x = 3 + 4 + res = 0 + goto L2 +L2: + if a > 0 then goto L3 else goto L4 +L3: + a = a - 1 + res = res + x + if x > 5 then goto L5 else goto L6 +L5: + goto L7 +L6: + x = x - 1 + goto L7 +L7: + goto L2 +L4: + ret (res) +} + +f(a) { +L1: + res = 0 + goto L2 +L2: + if a > 0 then goto L3 else goto L4 +L4: + ret (res) +L3: + a = a - 1 + res = res + 7 + goto L5 +L5: + goto L7 +L7: + goto L2 +} + +f(x) { +L1: + if x > 5 then goto L2 else goto L3 +L2: + z = 1 + goto L4 +L3: + z = 1 + goto L4 +L4: + ret (z) +} + +f(x) { +L1: + if x > 5 then goto L2 else goto L3 +L3: + goto L4 +L2: + goto L4 +L4: + ret (1) +} + +f(x) { +L1: + if x > 5 then goto L2 else goto L3 +L2: + z = 1 + goto L4 +L3: + z = 2 + goto L4 +L4: + ret (z) +} + +f(x) { +L1: + if x > 5 then goto L2 else goto L3 +L3: + z = 2 + goto L4 +L2: + z = 1 + goto L4 +L4: + ret (z) +} + diff -Nru ghc-7.0.3/libraries/hoopl/testing/tests/if-test ghc-7.2.1/libraries/hoopl/testing/tests/if-test --- ghc-7.0.3/libraries/hoopl/testing/tests/if-test 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/testing/tests/if-test 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,10 @@ +f() { +L0: + x = 3 + 4 + z = x > 5 + if z then goto L1 else goto L2 +L1: + ret (1) +L2: + ret (2) +} diff -Nru ghc-7.0.3/libraries/hoopl/testing/tests/if-test2 ghc-7.2.1/libraries/hoopl/testing/tests/if-test2 --- ghc-7.0.3/libraries/hoopl/testing/tests/if-test2 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/testing/tests/if-test2 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,21 @@ +f(a) { +L0: + x = 3 + 4 + res = 0 + goto L1 +L1: + if a > 0 then goto L2 else goto L6 +L2: + a = a - 1 + res = res + x + if x > 5 then goto L3 else goto L4 +L3: + goto L5 +L4: + x = x - 1 + goto L5 +L5: + goto L1 +L6: + ret (res) +} diff -Nru ghc-7.0.3/libraries/hoopl/testing/tests/if-test3 ghc-7.2.1/libraries/hoopl/testing/tests/if-test3 --- ghc-7.0.3/libraries/hoopl/testing/tests/if-test3 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/testing/tests/if-test3 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,12 @@ +f(x) { +L0: + if x > 5 then goto L1 else goto L2 +L1: + z = 1 + goto L3 +L2: + z = 1 + goto L3 +L3: + ret (z) +} diff -Nru ghc-7.0.3/libraries/hoopl/testing/tests/if-test4 ghc-7.2.1/libraries/hoopl/testing/tests/if-test4 --- ghc-7.0.3/libraries/hoopl/testing/tests/if-test4 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/testing/tests/if-test4 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,12 @@ +f(x) { +L0: + if x > 5 then goto L1 else goto L2 +L1: + z = 1 + goto L3 +L2: + z = 2 + goto L3 +L3: + ret (z) +} diff -Nru ghc-7.0.3/libraries/hoopl/testing/tests/test1 ghc-7.2.1/libraries/hoopl/testing/tests/test1 --- ghc-7.0.3/libraries/hoopl/testing/tests/test1 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/testing/tests/test1 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,7 @@ +f (a, b) { +L100: + r0 = 3 + r1 = 4 + r2 = r0 + r1 + ret (r2) +} diff -Nru ghc-7.0.3/libraries/hoopl/testing/tests/test2 ghc-7.2.1/libraries/hoopl/testing/tests/test2 --- ghc-7.0.3/libraries/hoopl/testing/tests/test2 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/testing/tests/test2 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,14 @@ +f (a, b) { +L100: + x = 5 + y = 0 + goto L101 +L101: + if x > 0 then goto L102 else goto L103 +L102: + y = y + x + x = x - 1 + goto L101 +L103: + ret (y) +} diff -Nru ghc-7.0.3/libraries/hoopl/testing/tests/test3 ghc-7.2.1/libraries/hoopl/testing/tests/test3 --- ghc-7.0.3/libraries/hoopl/testing/tests/test3 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/testing/tests/test3 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,14 @@ +f (x, y) { +L100: + goto L101 +L101: + if x > 0 then goto L102 else goto L104 +L102: + (z) = f(x-1, y-1) goto L103 +L103: + y = y + z + x = x - 1 + goto L101 +L104: + ret (y) +} diff -Nru ghc-7.0.3/libraries/hoopl/testing/tests/test4 ghc-7.2.1/libraries/hoopl/testing/tests/test4 --- ghc-7.0.3/libraries/hoopl/testing/tests/test4 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/testing/tests/test4 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,13 @@ +-- Test dead-code elim: y is dead +f (x) { +L100: + y = 5 + goto L101 +L101: + if y < 0 then goto L102 else goto L103 +L102: + y = y - 1 + goto L101 +L103: + ret (x + y + 4) +} diff -Nru ghc-7.0.3/libraries/hoopl/validate ghc-7.2.1/libraries/hoopl/validate --- ghc-7.0.3/libraries/hoopl/validate 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/hoopl/validate 2011-08-07 17:10:10.000000000 +0000 @@ -0,0 +1,8 @@ +#!/bin/sh + +set -e + +cabal sdist + +cd src && mk +cd ../testing && mk diff -Nru ghc-7.0.3/libraries/hpc/ghc.mk ghc-7.2.1/libraries/hpc/ghc.mk --- ghc-7.0.3/libraries/hpc/ghc.mk 2011-03-26 18:10:45.000000000 +0000 +++ ghc-7.2.1/libraries/hpc/ghc.mk 2011-08-07 17:11:00.000000000 +0000 @@ -1,3 +1,4 @@ libraries/hpc_PACKAGE = hpc libraries/hpc_dist-install_GROUP = libraries +$(if $(filter hpc,$(PACKAGES_STAGE0)),$(eval $(call build-package,libraries/hpc,dist-boot,0))) $(eval $(call build-package,libraries/hpc,dist-install,$(if $(filter hpc,$(STAGE2_PACKAGES)),2,1))) diff -Nru ghc-7.0.3/libraries/hpc/hpc.cabal ghc-7.2.1/libraries/hpc/hpc.cabal --- ghc-7.0.3/libraries/hpc/hpc.cabal 2011-03-26 18:10:14.000000000 +0000 +++ ghc-7.2.1/libraries/hpc/hpc.cabal 2011-08-07 17:10:10.000000000 +0000 @@ -1,5 +1,5 @@ name: hpc -version: 0.5.0.6 +version: 0.5.1.0 license: BSD3 license-file: LICENSE author: Andy Gill @@ -11,8 +11,8 @@ Cabal-Version: >= 1.6 source-repository head - type: darcs - location: http://darcs.haskell.org/packages/hpc/ + type: git + location: http://darcs.haskell.org/packages/hpc.git/ Flag small_base Description: Choose the new smaller, split-up base package. diff -Nru ghc-7.0.3/libraries/hpc/tests/ghc_ghci/Makefile ghc-7.2.1/libraries/hpc/tests/ghc_ghci/Makefile --- ghc-7.0.3/libraries/hpc/tests/ghc_ghci/Makefile 2011-03-26 18:10:14.000000000 +0000 +++ ghc-7.2.1/libraries/hpc/tests/ghc_ghci/Makefile 2011-08-07 17:10:10.000000000 +0000 @@ -8,6 +8,6 @@ hpc_ghc_ghci: rm -f A.o A.hi - '$(TEST_HC)' -fhpc -c A.hs - echo b | '$(TEST_HC)' -ignore-dot-ghci -v0 --interactive B.hs + '$(TEST_HC)' $(TEST_HC_OPTS) -fhpc -c A.hs + echo b | '$(TEST_HC)' $(TEST_HC_OPTS) -ignore-dot-ghci -v0 --interactive B.hs diff -Nru ghc-7.0.3/libraries/hpc/tests/ghc_ghci/test.T ghc-7.2.1/libraries/hpc/tests/ghc_ghci/test.T --- ghc-7.0.3/libraries/hpc/tests/ghc_ghci/test.T 2011-03-26 18:10:14.000000000 +0000 +++ ghc-7.2.1/libraries/hpc/tests/ghc_ghci/test.T 2011-08-07 17:10:10.000000000 +0000 @@ -2,7 +2,8 @@ test('hpc_ghc_ghci', [only_ways(['normal']), only_compiler_types(['ghc']), - if_compiler_profiled(skip)], + if_compiler_profiled(skip), + req_interp], run_command, ['$MAKE -s --no-print-directory hpc_ghc_ghci']) diff -Nru ghc-7.0.3/libraries/hpc/tests/raytrace/tixs/test.T ghc-7.2.1/libraries/hpc/tests/raytrace/tixs/test.T --- ghc-7.0.3/libraries/hpc/tests/raytrace/tixs/test.T 2011-03-26 18:10:14.000000000 +0000 +++ ghc-7.2.1/libraries/hpc/tests/raytrace/tixs/test.T 2011-08-07 17:10:10.000000000 +0000 @@ -12,11 +12,11 @@ ["'" + config.hpc + "' report " + hpcsample + " --include=Geometry --per-module --decl-list"]) test('hpc_markup_multi_001', normal, run_command, \ - ["'" + config.hpc + "' markup --srcdir=../ " + hpcsample + " --include=Geometry"]) + ["'" + config.hpc + "' markup --srcdir=.. --hpcdir=tixs/.hpc " + hpcsample + " --include=Geometry"]) test('hpc_markup_multi_002', normal, run_command, \ - ["'" + config.hpc + "' markup --srcdir=../ " + hpcsample + " --exclude=Geometry"]) + ["'" + config.hpc + "' markup --srcdir=.. --hpcdir=tixs/.hpc " + hpcsample + " --exclude=Geometry"]) test('hpc_markup_multi_003', normal, run_command, \ - ["'" + config.hpc + "' markup --srcdir=../ " + hpcsample + " --fun-entry-count"]) + ["'" + config.hpc + "' markup --srcdir=.. --hpcdir=tixs/.hpc " + hpcsample + " --fun-entry-count"]) test('hpc_show_multi_001', normal, run_command, ["'" + config.hpc + "' show " + hpcsample]) diff -Nru ghc-7.0.3/libraries/hpc/Trace/Hpc/Mix.hs ghc-7.2.1/libraries/hpc/Trace/Hpc/Mix.hs --- ghc-7.0.3/libraries/hpc/Trace/Hpc/Mix.hs 2011-03-26 18:10:14.000000000 +0000 +++ ghc-7.2.1/libraries/hpc/Trace/Hpc/Mix.hs 2011-08-07 17:10:10.000000000 +0000 @@ -28,7 +28,7 @@ -- been introduced in that module, accessed by tick-number position -- in the list -import Trace.Hpc.Util (HpcPos, insideHpcPos, Hash, HpcHash(..)) +import Trace.Hpc.Util (HpcPos, insideHpcPos, Hash, HpcHash(..), catchIO) import Trace.Hpc.Tix -- | 'Mix' is the information about a modules static properties, like @@ -98,7 +98,7 @@ Left _ -> True Right tix -> h == tixModuleHash tix ) -> return $ Just r - _ -> return $ Nothing) `catch` (\ _ -> return $ Nothing) + _ -> return $ Nothing) `catchIO` (\ _ -> return $ Nothing) | dirName <- dirNames ] case catMaybes res of diff -Nru ghc-7.0.3/libraries/hpc/Trace/Hpc/Tix.hs ghc-7.2.1/libraries/hpc/Trace/Hpc/Tix.hs --- ghc-7.0.3/libraries/hpc/Trace/Hpc/Tix.hs 2011-03-26 18:10:14.000000000 +0000 +++ ghc-7.2.1/libraries/hpc/Trace/Hpc/Tix.hs 2011-08-07 17:10:10.000000000 +0000 @@ -9,7 +9,7 @@ readTix, writeTix, getTixFileName) where import Data.List (isSuffixOf) -import Trace.Hpc.Util(Hash) +import Trace.Hpc.Util (Hash, catchIO) -- 'Tix ' is the storage format for our dynamic imformation about what -- boxes are ticked. @@ -34,11 +34,11 @@ -- read a Tix File. readTix :: String - -> IO (Maybe Tix) -readTix tix_filename = - catch (do contents <- readFile $ tix_filename - return $ Just $ read contents) - (\ _ -> return $ Nothing) + -> IO (Maybe Tix) +readTix tix_filename = + catchIO (do contents <- readFile $ tix_filename + return $ Just $ read contents) + (\ _ -> return $ Nothing) -- write a Tix File. writeTix :: String diff -Nru ghc-7.0.3/libraries/hpc/Trace/Hpc/Util.hs ghc-7.2.1/libraries/hpc/Trace/Hpc/Util.hs --- ghc-7.0.3/libraries/hpc/Trace/Hpc/Util.hs 2011-03-26 18:10:14.000000000 +0000 +++ ghc-7.2.1/libraries/hpc/Trace/Hpc/Util.hs 2011-08-07 17:10:10.000000000 +0000 @@ -11,8 +11,10 @@ , insideHpcPos , HpcHash(..) , Hash + , catchIO ) where +import qualified Control.Exception as Exception import Data.List(foldl') import Data.Char (ord) import Data.Bits (xor) @@ -103,3 +105,7 @@ hxor :: Hash -> Hash -> Hash hxor (Hash x) (Hash y) = Hash $ x `xor` y + +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +catchIO = Exception.catch + diff -Nru ghc-7.0.3/libraries/integer-gmp/GHC/Integer/GMP/Internals.hs ghc-7.2.1/libraries/integer-gmp/GHC/Integer/GMP/Internals.hs --- ghc-7.0.3/libraries/integer-gmp/GHC/Integer/GMP/Internals.hs 2011-03-26 18:10:14.000000000 +0000 +++ ghc-7.2.1/libraries/integer-gmp/GHC/Integer/GMP/Internals.hs 2011-08-07 17:10:11.000000000 +0000 @@ -1,5 +1,5 @@ -{-# LANGUAGE ForeignFunctionInterface, GHCForeignImportPrim, - MagicHash, UnboxedTuples, UnliftedFFITypes #-} +{-# LANGUAGE ForeignFunctionInterface, GHCForeignImportPrim, CPP, + MagicHash, UnboxedTuples, UnliftedFFITypes, BangPatterns #-} {-# OPTIONS_GHC -XNoImplicitPrelude #-} {-# OPTIONS_HADDOCK hide #-} diff -Nru ghc-7.0.3/libraries/integer-gmp/GHC/Integer/Logarithms/Internals.hs ghc-7.2.1/libraries/integer-gmp/GHC/Integer/Logarithms/Internals.hs --- ghc-7.0.3/libraries/integer-gmp/GHC/Integer/Logarithms/Internals.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/integer-gmp/GHC/Integer/Logarithms/Internals.hs 2011-08-07 17:10:11.000000000 +0000 @@ -0,0 +1,259 @@ +{-# LANGUAGE CPP, MagicHash, UnboxedTuples, NoImplicitPrelude #-} +{-# OPTIONS_HADDOCK hide #-} + +#include "MachDeps.h" + +-- Fast integer logarithms to base 2. +-- integerLog2# and wordLog2# are of general usefulness, +-- the others are only needed for a fast implementation of +-- fromRational. +-- Since they are needed in GHC.Float, we must expose this +-- module, but it should not show up in the docs. + +module GHC.Integer.Logarithms.Internals + ( integerLog2# + , integerLog2IsPowerOf2# + , wordLog2# + , roundingMode# + ) where + +import GHC.Prim +import GHC.Integer.Type + +-- When larger word sizes become common, add support for those, +-- it is not hard, just tedious. +#if (WORD_SIZE_IN_BITS != 32) && (WORD_SIZE_IN_BITS != 64) + +-- Less than ideal implementations for strange word sizes + +import GHC.Integer + +default () + +-- We do not know whether the word has 30 bits or 128 or even more, +-- so we cannot start from the top, although that would be much more +-- efficient. +-- Count the bits until the highest set bit is found. +wordLog2# :: Word# -> Int# +wordLog2# w = go 8# w + where + go acc u = case u `uncheckedShiftRL#` 8# of + 0## -> case leadingZeros of + BA ba -> acc -# indexInt8Array# ba (word2Int# u) + v -> go (acc +# 8#) v + +-- Assumption: Integer is strictly positive +integerLog2# :: Integer -> Int# +integerLog2# (S# i) = wordLog2# (int2Word# i) -- that is easy +integerLog2# m = case step m (smallInteger 2#) 1# of + (# _, l #) -> l + where + -- Invariants: + -- pw = 2 ^ lg + -- case step n pw lg of + -- (q, e) -> pw^(2*e) <= n < pw^(2*e+2) + -- && q <= n/pw^(2*e) < (q+1) + -- && q < pw^2 + step n pw lg = + if n `ltInteger` pw + then (# n, 0# #) + else case step n (shiftLInteger pw lg) (2# *# lg) of + (# q, e #) -> + if q `ltInteger` pw + then (# q, 2# *# e #) + else (# q `shiftRInteger` lg, 2# *# e +# 1# #) + +-- Calculate the log2 of a positive integer and check +-- whether it is a power of 2. +-- By coincidence, the presence of a power of 2 is +-- signalled by zero and not one. +integerLog2IsPowerOf2# :: Integer -> (# Int#, Int# #) +integerLog2IsPowerOf2# m = + case integerLog2# m of + lg -> if m `eqInteger` (smallInteger 1# `shiftLInteger` lg) + then (# lg, 0# #) + else (# lg, 1# #) + +-- Detect the rounding mode, +-- 0# means round to zero, +-- 1# means round to even, +-- 2# means round away from zero +roundingMode# :: Integer -> Int# -> Int# +roundingMode# m h = + case smallInteger 1# `shiftLInteger` h of + c -> case m `andInteger` + ((c `plusInteger` c) `minusInteger` smallInteger 1#) of + r -> + if c `ltInteger` r + then 2# + else if c `gtInteger` r + then 0# + else 1# + +#else + +default () + +-- We have a nice word size, we can do much better now. + +#if WORD_SIZE_IN_BITS == 32 + +#define WSHIFT 5 +#define MMASK 31 + +#else + +#define WSHIFT 6 +#define MMASK 63 + +#endif + +-- Assumption: Integer is strictly positive +-- For small integers, use wordLog#, +-- in the general case, check words from the most +-- significant down, once a nonzero word is found, +-- calculate its log2 and add the number of following bits. +integerLog2# :: Integer -> Int# +integerLog2# (S# i) = wordLog2# (int2Word# i) +integerLog2# (J# s ba) = check (s -# 1#) + where + check i = case indexWordArray# ba i of + 0## -> check (i -# 1#) + w -> wordLog2# w +# (uncheckedIShiftL# i WSHIFT#) + +-- Assumption: Integer is strictly positive +-- First component is log2 n, second is 0# iff n is a power of two +integerLog2IsPowerOf2# :: Integer -> (# Int#, Int# #) +-- The power of 2 test is n&(n-1) == 0, thus powers of 2 +-- are indicated bythe second component being zero. +integerLog2IsPowerOf2# (S# i) = + case int2Word# i of + w -> (# wordLog2# w, word2Int# (w `and#` (w `minusWord#` 1##)) #) +-- Find the log2 as above, test whether that word is a power +-- of 2, if so, check whether only zero bits follow. +integerLog2IsPowerOf2# (J# s ba) = check (s -# 1#) + where + check :: Int# -> (# Int#, Int# #) + check i = case indexWordArray# ba i of + 0## -> check (i -# 1#) + w -> (# wordLog2# w +# (uncheckedIShiftL# i WSHIFT#) + , case w `and#` (w `minusWord#` 1##) of + 0## -> test (i -# 1#) + _ -> 1# #) + test :: Int# -> Int# + test i = if i <# 0# + then 0# + else case indexWordArray# ba i of + 0## -> test (i -# 1#) + _ -> 1# + +-- Assumption: Integer and Int# are strictly positive, Int# is less +-- than logBase 2 of Integer, otherwise havoc ensues. +-- Used only for the numerator in fromRational when the denominator +-- is a power of 2. +-- The Int# argument is log2 n minus the number of bits in the mantissa +-- of the target type, i.e. the index of the first non-integral bit in +-- the quotient. +-- +-- 0# means round down (towards zero) +-- 1# means we have a half-integer, round to even +-- 2# means round up (away from zero) +roundingMode# :: Integer -> Int# -> Int# +roundingMode# (S# i) t = + case int2Word# i `and#` ((uncheckedShiftL# 2## t) `minusWord#` 1##) of + k -> case uncheckedShiftL# 1## t of + c -> if c `gtWord#` k + then 0# + else if c `ltWord#` k + then 2# + else 1# +roundingMode# (J# _ ba) t = + case word2Int# (int2Word# t `and#` MMASK##) of + j -> -- index of relevant bit in word + case uncheckedIShiftRA# t WSHIFT# of + k -> -- index of relevant word + case indexWordArray# ba k `and#` + ((uncheckedShiftL# 2## j) `minusWord#` 1##) of + r -> + case uncheckedShiftL# 1## j of + c -> if c `gtWord#` r + then 0# + else if c `ltWord#` r + then 2# + else test (k -# 1#) + where + test i = if i <# 0# + then 1# + else case indexWordArray# ba i of + 0## -> test (i -# 1#) + _ -> 2# + +-- wordLog2# 0## = -1# +{-# INLINE wordLog2# #-} +wordLog2# :: Word# -> Int# +wordLog2# w = + case leadingZeros of + BA lz -> + let zeros u = indexInt8Array# lz (word2Int# u) in +#if WORD_SIZE_IN_BITS == 64 + case uncheckedShiftRL# w 56# of + a -> + if a `neWord#` 0## + then 64# -# zeros a + else + case uncheckedShiftRL# w 48# of + b -> + if b `neWord#` 0## + then 56# -# zeros b + else + case uncheckedShiftRL# w 40# of + c -> + if c `neWord#` 0## + then 48# -# zeros c + else + case uncheckedShiftRL# w 32# of + d -> + if d `neWord#` 0## + then 40# -# zeros d + else +#endif + case uncheckedShiftRL# w 24# of + e -> + if e `neWord#` 0## + then 32# -# zeros e + else + case uncheckedShiftRL# w 16# of + f -> + if f `neWord#` 0## + then 24# -# zeros f + else + case uncheckedShiftRL# w 8# of + g -> + if g `neWord#` 0## + then 16# -# zeros g + else 8# -# zeros w + +#endif + +-- Lookup table +data BA = BA ByteArray# + +leadingZeros :: BA +leadingZeros = + let mkArr s = + case newByteArray# 256# s of + (# s1, mba #) -> + case writeInt8Array# mba 0# 9# s1 of + s2 -> + let fillA lim val idx st = + if idx ==# 256# + then st + else if idx <# lim + then case writeInt8Array# mba idx val st of + nx -> fillA lim val (idx +# 1#) nx + else fillA (2# *# lim) (val -# 1#) idx st + in case fillA 2# 8# 1# s2 of + s3 -> case unsafeFreezeByteArray# mba s3 of + (# _, ba #) -> ba + in case mkArr realWorld# of + b -> BA b diff -Nru ghc-7.0.3/libraries/integer-gmp/GHC/Integer/Logarithms.hs ghc-7.2.1/libraries/integer-gmp/GHC/Integer/Logarithms.hs --- ghc-7.0.3/libraries/integer-gmp/GHC/Integer/Logarithms.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/integer-gmp/GHC/Integer/Logarithms.hs 2011-08-07 17:10:11.000000000 +0000 @@ -0,0 +1,43 @@ +{-# LANGUAGE MagicHash, UnboxedTuples, NoImplicitPrelude #-} +module GHC.Integer.Logarithms + ( integerLogBase# + , integerLog2# + , wordLog2# + ) where + +import GHC.Prim +import GHC.Integer +import qualified GHC.Integer.Logarithms.Internals as I + +-- | Calculate the integer logarithm for an arbitrary base. +-- The base must be greater than 1, the second argument, the number +-- whose logarithm is sought, should be positive, otherwise the +-- result is meaningless. +-- +-- > base ^ integerLogBase# base m <= m < base ^ (integerLogBase# base m + 1) +-- +-- for @base > 1@ and @m > 0@. +integerLogBase# :: Integer -> Integer -> Int# +integerLogBase# b m = case step b of + (# _, e #) -> e + where + step pw = + if m `ltInteger` pw + then (# m, 0# #) + else case step (pw `timesInteger` pw) of + (# q, e #) -> + if q `ltInteger` pw + then (# q, 2# *# e #) + else (# q `quotInteger` pw, 2# *# e +# 1# #) + +-- | Calculate the integer base 2 logarithm of an 'Integer'. +-- The calculation is more efficient than for the general case, +-- on platforms with 32- or 64-bit words much more efficient. +-- +-- The argument must be strictly positive, that condition is /not/ checked. +integerLog2# :: Integer -> Int# +integerLog2# = I.integerLog2# + +-- | This function calculates the integer base 2 logarithm of a 'Word#'. +wordLog2# :: Word# -> Int# +wordLog2# = I.wordLog2# diff -Nru ghc-7.0.3/libraries/integer-gmp/GHC/Integer.lhs ghc-7.2.1/libraries/integer-gmp/GHC/Integer.lhs --- ghc-7.0.3/libraries/integer-gmp/GHC/Integer.lhs 2011-03-26 18:10:14.000000000 +0000 +++ ghc-7.2.1/libraries/integer-gmp/GHC/Integer.lhs 2011-08-07 17:10:11.000000000 +0000 @@ -1,4 +1,5 @@ \begin{code} +{-# LANGUAGE BangPatterns, CPP, MagicHash #-} {-# OPTIONS_GHC -XNoImplicitPrelude #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- @@ -28,7 +29,7 @@ module GHC.Integer ( Integer, - smallInteger, wordToInteger, integerToWord, toInt#, + smallInteger, wordToInteger, integerToWord, integerToInt, #if WORD_SIZE_IN_BITS < 64 integerToWord64, word64ToInteger, integerToInt64, int64ToInteger, @@ -84,8 +85,8 @@ ) #endif -import GHC.Bool import GHC.Ordering +import GHC.Types default () -- Double isn't available yet, -- and we shouldn't be using defaults anyway @@ -140,15 +141,15 @@ False && _ = False #endif -toInt# :: Integer -> Int# -{-# NOINLINE toInt# #-} -{-# RULES "toInt#" forall i. toInt# (S# i) = i #-} --- Don't inline toInt#, because it can't do much unless +integerToInt :: Integer -> Int# +{-# NOINLINE integerToInt #-} +{-# RULES "integerToInt" forall i. integerToInt (S# i) = i #-} +-- Don't inline integerToInt, because it can't do much unless -- it sees a (S# i), and inlining just creates fruitless -- join points. But we do need a RULE to get the constants -- to work right: 1::Int had better optimise to (I# 1)! -toInt# (S# i) = i -toInt# (J# s d) = integer2Int# s d +integerToInt (S# i) = i +integerToInt (J# s d) = integer2Int# s d toBig :: Integer -> Integer toBig (S# i) = case int2Integer# i of { (# s, d #) -> J# s d } @@ -553,7 +554,7 @@ -- given a suitable distribution of 'Integer' values. hashInteger :: Integer -> Int# -hashInteger = toInt# +hashInteger = integerToInt \end{code} diff -Nru ghc-7.0.3/libraries/integer-gmp/ghc.mk ghc-7.2.1/libraries/integer-gmp/ghc.mk --- ghc-7.0.3/libraries/integer-gmp/ghc.mk 2011-03-26 18:10:45.000000000 +0000 +++ ghc-7.2.1/libraries/integer-gmp/ghc.mk 2011-08-07 17:11:00.000000000 +0000 @@ -1,3 +1,4 @@ libraries/integer-gmp_PACKAGE = integer-gmp libraries/integer-gmp_dist-install_GROUP = libraries +$(if $(filter integer-gmp,$(PACKAGES_STAGE0)),$(eval $(call build-package,libraries/integer-gmp,dist-boot,0))) $(eval $(call build-package,libraries/integer-gmp,dist-install,$(if $(filter integer-gmp,$(STAGE2_PACKAGES)),2,1))) diff -Nru ghc-7.0.3/libraries/integer-gmp/gmp/config.mk ghc-7.2.1/libraries/integer-gmp/gmp/config.mk --- ghc-7.0.3/libraries/integer-gmp/gmp/config.mk 2011-03-26 18:13:02.000000000 +0000 +++ ghc-7.2.1/libraries/integer-gmp/gmp/config.mk 1970-01-01 00:00:00.000000000 +0000 @@ -1,11 +0,0 @@ -ifeq "$(HaveLibGmp)" "" - HaveLibGmp = YES -endif - -ifeq "$(HaveFrameworkGMP)" "" - HaveFrameworkGMP = -endif - -GMP_INCLUDE_DIRS = -GMP_LIB_DIRS = - diff -Nru ghc-7.0.3/libraries/integer-gmp/gmp/ghc.mk ghc-7.2.1/libraries/integer-gmp/gmp/ghc.mk --- ghc-7.0.3/libraries/integer-gmp/gmp/ghc.mk 2011-03-26 18:10:14.000000000 +0000 +++ ghc-7.2.1/libraries/integer-gmp/gmp/ghc.mk 2011-08-07 17:10:11.000000000 +0000 @@ -10,7 +10,30 @@ # # ----------------------------------------------------------------------------- -ifneq "$(phase)" "0" +# We use a tarball like gmp-4.2.4-nodoc.tar.bz2, which is +# gmp-4.2.4.tar.bz2 repacked without the doc/ directory contents. +# That's because the doc/ directory contents are under the GFDL, +# which causes problems for Debian. + +GMP_TARBALL := $(wildcard libraries/integer-gmp/gmp/tarball/gmp*.tar.bz2) +GMP_DIR := $(patsubst libraries/integer-gmp/gmp/tarball/%-nodoc-patched.tar.bz2,%,$(GMP_TARBALL)) + +ifneq "$(NO_CLEAN_GMP)" "YES" +$(eval $(call clean-target,gmp,,\ + libraries/integer-gmp/gmp/config.mk \ + libraries/integer-gmp/gmp/libgmp.a \ + libraries/integer-gmp/gmp/gmp.h \ + libraries/integer-gmp/gmp/gmpbuild \ + libraries/integer-gmp/gmp/$(GMP_DIR))) + +clean : clean_gmp +.PHONY: clean_gmp +clean_gmp: + "$(RM)" $(RM_OPTS_REC) libraries/integer-gmp/gmp/objs + "$(RM)" $(RM_OPTS_REC) libraries/integer-gmp/gmp/gmpbuild +endif + +ifeq "$(phase)" "final" ifeq "$(findstring clean,$(MAKECMDGOALS))" "" include libraries/integer-gmp/gmp/config.mk @@ -20,7 +43,7 @@ libraries/integer-gmp_CC_OPTS += $(addprefix -L,$(GMP_LIB_DIRS)) libraries/integer-gmp/cbits/mkGmpDerivedConstants$(exeext): libraries/integer-gmp/cbits/mkGmpDerivedConstants.c - "$(CC)" $(SRC_CC_OPTS) $(CONF_CC_OPTS_STAGE1) $(libraries/integer-gmp_CC_OPTS) $< -o $@ + "$(CC_STAGE1)" $(SRC_CC_OPTS) $(CONF_CC_OPTS_STAGE1) $(libraries/integer-gmp_CC_OPTS) $< -o $@ libraries/integer-gmp/cbits/GmpDerivedConstants.h: libraries/integer-gmp/cbits/mkGmpDerivedConstants$(exeext) $< > $@ @@ -77,8 +100,6 @@ endif endif -PLATFORM := $(shell echo $(HOSTPLATFORM) | sed 's/i[567]86/i486/g') - # 2007-09-26 # set -o igncr # is not a valid command on non-Cygwin-systems. @@ -99,14 +120,6 @@ # follow, as it isn't used consistently. Instead we put an ln.bat in # path that always fails. -# We use a tarball like gmp-4.2.4-nodoc.tar.bz2, which is -# gmp-4.2.4.tar.bz2 repacked without the doc/ directory contents. -# That's because the doc/ directory contents are under the GFDL, -# which causes problems for Debian. - -GMP_TARBALL := $(wildcard libraries/integer-gmp/gmp/tarball/gmp*.tar.bz2) -GMP_DIR := $(patsubst libraries/integer-gmp/gmp/tarball/%-nodoc-patched.tar.bz2,%,$(GMP_TARBALL)) - libraries/integer-gmp/gmp/libgmp.a libraries/integer-gmp/gmp/gmp.h: $(RM) -rf libraries/integer-gmp/gmp/$(GMP_DIR) libraries/integer-gmp/gmp/gmpbuild libraries/integer-gmp/gmp/objs cat $(GMP_TARBALL) | $(BZIP2_CMD) -d | { cd libraries/integer-gmp/gmp && $(TAR_CMD) -xf - ; } @@ -116,23 +129,16 @@ PATH=`pwd`:$$PATH; \ export PATH; \ cd gmpbuild && \ - CC=$(WhatGccIsCalled) NM=$(NM) AR=$(AR) $(SHELL) configure \ - --enable-shared=no --host=$(PLATFORM) --build=$(PLATFORM) + CC=$(CC_STAGE1) NM=$(NM) AR=$(AR_STAGE1) $(SHELL) configure \ + --enable-shared=no \ + --host=$(HOSTPLATFORM) --build=$(BUILDPLATFORM) $(MAKE) -C libraries/integer-gmp/gmp/gmpbuild MAKEFLAGS= $(CP) libraries/integer-gmp/gmp/gmpbuild/gmp.h libraries/integer-gmp/gmp/ $(CP) libraries/integer-gmp/gmp/gmpbuild/.libs/libgmp.a libraries/integer-gmp/gmp/ $(MKDIRHIER) libraries/integer-gmp/gmp/objs - cd libraries/integer-gmp/gmp/objs && $(AR) x ../libgmp.a + cd libraries/integer-gmp/gmp/objs && $(AR_STAGE1) x ../libgmp.a $(RANLIB) libraries/integer-gmp/gmp/libgmp.a -ifneq "$(NO_CLEAN_GMP)" "YES" -$(eval $(call clean-target,gmp,,\ - libraries/integer-gmp/gmp/libgmp.a \ - libraries/integer-gmp/gmp/gmp.h \ - libraries/integer-gmp/gmp/gmpbuild \ - libraries/integer-gmp/gmp/$(GMP_DIR))) -endif - # XXX TODO: #stamp.gmp.shared: # $(RM) -rf $(GMP_DIR) gmpbuild-shared @@ -143,8 +149,9 @@ # PATH=`pwd`:$$PATH; \ # export PATH; \ # cd gmpbuild-shared && \ -# CC=$(WhatGccIsCalled) $(SHELL) configure \ -# --enable-shared=yes --disable-static --host=$(PLATFORM) --build=$(PLATFORM) +# CC=$(CC_STAGE1) $(SHELL) configure \ +# --enable-shared=yes --disable-static \ +# --host=$(HOSTPLATFORM) --build=$(BUILDPLATFORM) # touch $@ # #gmp.h: stamp.gmp.static Binary files /tmp/fvLb9T5hiW/ghc-7.0.3/libraries/integer-gmp/gmp/tarball/gmp-4.2.4-nodoc-patched.tar.bz2 and /tmp/RVgeeZD6MZ/ghc-7.2.1/libraries/integer-gmp/gmp/tarball/gmp-4.2.4-nodoc-patched.tar.bz2 differ Binary files /tmp/fvLb9T5hiW/ghc-7.0.3/libraries/integer-gmp/gmp/tarball/gmp-5.0.2-nodoc-patched.tar.bz2 and /tmp/RVgeeZD6MZ/ghc-7.2.1/libraries/integer-gmp/gmp/tarball/gmp-5.0.2-nodoc-patched.tar.bz2 differ diff -Nru ghc-7.0.3/libraries/integer-gmp/gmp/tarball/patch ghc-7.2.1/libraries/integer-gmp/gmp/tarball/patch --- ghc-7.0.3/libraries/integer-gmp/gmp/tarball/patch 2011-03-26 18:10:14.000000000 +0000 +++ ghc-7.2.1/libraries/integer-gmp/gmp/tarball/patch 2011-08-07 17:10:11.000000000 +0000 @@ -1,24 +1,69 @@ -diff -ur before/memory.c after/memory.c ---- before/memory.c 2007-08-30 19:31:40.000000000 +0100 -+++ after/memory.c 2009-06-21 19:12:39.000000000 +0100 +diff -ur gmp-5.0.2.orig/Makefile.am gmp-5.0.2/Makefile.am +--- gmp-5.0.2.orig/Makefile.am 2011-05-08 10:49:29.000000000 +0100 ++++ gmp-5.0.2/Makefile.am 2011-07-27 17:58:20.000000000 +0100 +@@ -93,7 +93,7 @@ + LIBMP_LT_AGE = 1 + + +-SUBDIRS = tests mpn mpz mpq mpf printf scanf cxx mpbsd demos tune doc ++SUBDIRS = tests mpn mpz mpq mpf printf scanf cxx mpbsd demos tune + + EXTRA_DIST = configfsf.guess configfsf.sub .gdbinit INSTALL.autoconf + +diff -ur gmp-5.0.2.orig/Makefile.in gmp-5.0.2/Makefile.in +--- gmp-5.0.2.orig/Makefile.in 2011-05-08 10:49:35.000000000 +0100 ++++ gmp-5.0.2/Makefile.in 2011-07-27 17:58:13.000000000 +0100 +@@ -435,7 +435,7 @@ + LIBMP_LT_CURRENT = 4 + LIBMP_LT_REVISION = 22 + LIBMP_LT_AGE = 1 +-SUBDIRS = tests mpn mpz mpq mpf printf scanf cxx mpbsd demos tune doc ++SUBDIRS = tests mpn mpz mpq mpf printf scanf cxx mpbsd demos tune + + # The ansi2knr setups for the build programs are the same as the normal + # automake ansi2knr rules, but using $(CC_FOR_BUILD) instead of $(CC). +diff -ur gmp-5.0.2.orig/configure gmp-5.0.2/configure +--- gmp-5.0.2.orig/configure 2011-05-08 10:49:33.000000000 +0100 ++++ gmp-5.0.2/configure 2011-07-27 18:00:11.000000000 +0100 +@@ -28478,7 +28478,7 @@ + # FIXME: Upcoming version of autoconf/automake may not like broken lines. + # Right now automake isn't accepting the new AC_CONFIG_FILES scheme. + +-ac_config_files="$ac_config_files Makefile mpbsd/Makefile mpf/Makefile mpn/Makefile mpq/Makefile mpz/Makefile printf/Makefile scanf/Makefile cxx/Makefile tests/Makefile tests/devel/Makefile tests/mpbsd/Makefile tests/mpf/Makefile tests/mpn/Makefile tests/mpq/Makefile tests/mpz/Makefile tests/rand/Makefile tests/misc/Makefile tests/cxx/Makefile doc/Makefile tune/Makefile demos/Makefile demos/calc/Makefile demos/expr/Makefile gmp.h:gmp-h.in mp.h:mp-h.in" ++ac_config_files="$ac_config_files Makefile mpbsd/Makefile mpf/Makefile mpn/Makefile mpq/Makefile mpz/Makefile printf/Makefile scanf/Makefile cxx/Makefile tests/Makefile tests/devel/Makefile tests/mpbsd/Makefile tests/mpf/Makefile tests/mpn/Makefile tests/mpq/Makefile tests/mpz/Makefile tests/rand/Makefile tests/misc/Makefile tests/cxx/Makefile tune/Makefile demos/Makefile demos/calc/Makefile demos/expr/Makefile gmp.h:gmp-h.in mp.h:mp-h.in" + + cat >confcache <<\_ACEOF + # This file is a shell script that caches the results of configure +@@ -29665,7 +29665,6 @@ + "tests/rand/Makefile") CONFIG_FILES="$CONFIG_FILES tests/rand/Makefile" ;; + "tests/misc/Makefile") CONFIG_FILES="$CONFIG_FILES tests/misc/Makefile" ;; + "tests/cxx/Makefile") CONFIG_FILES="$CONFIG_FILES tests/cxx/Makefile" ;; +- "doc/Makefile") CONFIG_FILES="$CONFIG_FILES doc/Makefile" ;; + "tune/Makefile") CONFIG_FILES="$CONFIG_FILES tune/Makefile" ;; + "demos/Makefile") CONFIG_FILES="$CONFIG_FILES demos/Makefile" ;; + "demos/calc/Makefile") CONFIG_FILES="$CONFIG_FILES demos/calc/Makefile" ;; +Only in gmp-5.0.2.orig: doc +diff -ur gmp-5.0.2.orig/memory.c gmp-5.0.2/memory.c +--- gmp-5.0.2.orig/memory.c 2011-05-08 10:49:29.000000000 +0100 ++++ gmp-5.0.2/memory.c 2011-07-27 15:18:21.000000000 +0100 @@ -24,10 +24,21 @@ #include "gmp-impl.h" ++/* Patched for GHC: */ +void * stgAllocForGMP (size_t size_in_bytes); +void * stgReallocForGMP (void *ptr, size_t old_size, size_t new_size); +void stgDeallocForGMP (void *ptr, size_t size); + -+void * (*__gmp_allocate_func) _PROTO ((size_t)) = stgAllocForGMP; -+void * (*__gmp_reallocate_func) _PROTO ((void *, size_t, size_t)) ++void * (*__gmp_allocate_func) __GMP_PROTO ((size_t)) = stgAllocForGMP; ++void * (*__gmp_reallocate_func) __GMP_PROTO ((void *, size_t, size_t)) + = stgReallocForGMP; -+void (*__gmp_free_func) _PROTO ((void *, size_t)) = stgDeallocForGMP; -+ ++void (*__gmp_free_func) __GMP_PROTO ((void *, size_t)) = stgDeallocForGMP; +/* - void * (*__gmp_allocate_func) _PROTO ((size_t)) = __gmp_default_allocate; - void * (*__gmp_reallocate_func) _PROTO ((void *, size_t, size_t)) + void * (*__gmp_allocate_func) __GMP_PROTO ((size_t)) = __gmp_default_allocate; + void * (*__gmp_reallocate_func) __GMP_PROTO ((void *, size_t, size_t)) = __gmp_default_reallocate; - void (*__gmp_free_func) _PROTO ((void *, size_t)) = __gmp_default_free; + void (*__gmp_free_func) __GMP_PROTO ((void *, size_t)) = __gmp_default_free; +*/ diff -Nru ghc-7.0.3/libraries/integer-gmp/gmp/tarball/README ghc-7.2.1/libraries/integer-gmp/gmp/tarball/README --- ghc-7.0.3/libraries/integer-gmp/gmp/tarball/README 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/integer-gmp/gmp/tarball/README 2011-08-07 17:10:11.000000000 +0000 @@ -0,0 +1,8 @@ + +Download linked from http://gmplib.org/ + +Untar. +Remove doc/ directory. +Apply patch. +Re-tar. + diff -Nru ghc-7.0.3/libraries/integer-gmp/integer-gmp.cabal ghc-7.2.1/libraries/integer-gmp/integer-gmp.cabal --- ghc-7.0.3/libraries/integer-gmp/integer-gmp.cabal 2011-03-26 18:10:14.000000000 +0000 +++ ghc-7.2.1/libraries/integer-gmp/integer-gmp.cabal 2011-08-07 17:10:11.000000000 +0000 @@ -1,5 +1,5 @@ name: integer-gmp -version: 0.2.0.3 +version: 0.3.0.0 license: BSD3 license-file: LICENSE maintainer: libraries@haskell.org @@ -16,13 +16,15 @@ cbits/longlong.c source-repository head - type: darcs - location: http://darcs.haskell.org/packages/integer-gmp/ + type: git + location: http://darcs.haskell.org/packages/integer-gmp.git/ Library { build-depends: ghc-prim exposed-modules: GHC.Integer GHC.Integer.GMP.Internals + GHC.Integer.Logarithms + GHC.Integer.Logarithms.Internals other-modules: GHC.Integer.Type extensions: CPP, MagicHash, UnboxedTuples, NoImplicitPrelude, ForeignFunctionInterface, UnliftedFFITypes diff -Nru ghc-7.0.3/libraries/integer-simple/GHC/Integer/Logarithms/Internals.hs ghc-7.2.1/libraries/integer-simple/GHC/Integer/Logarithms/Internals.hs --- ghc-7.0.3/libraries/integer-simple/GHC/Integer/Logarithms/Internals.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/integer-simple/GHC/Integer/Logarithms/Internals.hs 2011-08-07 17:10:11.000000000 +0000 @@ -0,0 +1,166 @@ +{-# LANGUAGE CPP, MagicHash, UnboxedTuples, NoImplicitPrelude #-} +{-# OPTIONS_HADDOCK hide #-} + +#include "MachDeps.h" + +-- (Hopefully) Fast integer logarithms to base 2. +-- integerLog2# and wordLog2# are of general usefulness, +-- the others are only needed for a fast implementation of +-- fromRational. +-- Since they are needed in GHC.Float, we must expose this +-- module, but it should not show up in the docs. + +module GHC.Integer.Logarithms.Internals + ( integerLog2# + , integerLog2IsPowerOf2# + , wordLog2# + , roundingMode# + ) where + +import GHC.Prim +import GHC.Integer.Type +import GHC.Integer + +default () + +-- When larger word sizes become common, add support for those, +-- it's not hard, just tedious. +#if (WORD_SIZE_IN_BITS != 32) && (WORD_SIZE_IN_BITS != 64) + +-- We don't know whether the word has 30 bits or 128 or even more, +-- so we can't start from the top, although that would be much more +-- efficient. +wordLog2# :: Word# -> Int# +wordLog2# w = go 8# w + where + go acc u = case u `uncheckedShiftRL#` 8# of + 0## -> case leadingZeros of + BA ba -> acc -# indexInt8Array# ba (word2Int# u) + v -> go (acc +# 8#) v + +#else + +-- This one at least can also be done efficiently. +-- wordLog2# 0## = -1# +{-# INLINE wordLog2# #-} +wordLog2# :: Word# -> Int# +wordLog2# w = + case leadingZeros of + BA lz -> + let zeros u = indexInt8Array# lz (word2Int# u) in +#if WORD_SIZE_IN_BITS == 64 + case uncheckedShiftRL# w 56# of + a -> + if a `neWord#` 0## + then 64# -# zeros a + else + case uncheckedShiftRL# w 48# of + b -> + if b `neWord#` 0## + then 56# -# zeros b + else + case uncheckedShiftRL# w 40# of + c -> + if c `neWord#` 0## + then 48# -# zeros c + else + case uncheckedShiftRL# w 32# of + d -> + if d `neWord#` 0## + then 40# -# zeros d + else +#endif + case uncheckedShiftRL# w 24# of + e -> + if e `neWord#` 0## + then 32# -# zeros e + else + case uncheckedShiftRL# w 16# of + f -> + if f `neWord#` 0## + then 24# -# zeros f + else + case uncheckedShiftRL# w 8# of + g -> + if g `neWord#` 0## + then 16# -# zeros g + else 8# -# zeros w + +#endif + +-- Assumption: Integer is strictly positive, +-- otherwise return -1# arbitrarily +-- Going up in word-sized steps should not be too bad. +integerLog2# :: Integer -> Int# +integerLog2# (Positive digits) = step 0# digits + where + step acc (Some dig None) = acc +# wordLog2# dig + step acc (Some _ digs) = + step (acc +# WORD_SIZE_IN_BITS#) digs + step acc None = acc -- should be impossible, throw error? +integerLog2# _ = negateInt# 1# + +-- Again, integer should be strictly positive +integerLog2IsPowerOf2# :: Integer -> (# Int#, Int# #) +integerLog2IsPowerOf2# (Positive digits) = couldBe 0# digits + where + couldBe acc (Some dig None) = + (# acc +# wordLog2# dig, word2Int# (and# dig (minusWord# dig 1##)) #) + couldBe acc (Some dig digs) = + if eqWord# dig 0## + then couldBe (acc +# WORD_SIZE_IN_BITS#) digs + else noPower (acc +# WORD_SIZE_IN_BITS#) digs + couldBe acc None = (# acc, 1# #) -- should be impossible, error? + noPower acc (Some dig None) = + (# acc +# wordLog2# dig, 1# #) + noPower acc (Some _ digs) = + noPower (acc +# WORD_SIZE_IN_BITS#) digs + noPower acc None = (# acc, 1# #) -- should be impossible, error? +integerLog2IsPowerOf2# _ = (# negateInt# 1#, 1# #) + +-- Assumption: Integer and Int# are strictly positive, Int# is less +-- than logBase 2 of Integer, otherwise havoc ensues. +-- Used only for the numerator in fromRational when the denominator +-- is a power of 2. +-- The Int# argument is log2 n minus the number of bits in the mantissa +-- of the target type, i.e. the index of the first non-integral bit in +-- the quotient. +-- +-- 0# means round down (towards zero) +-- 1# means we have a half-integer, round to even +-- 2# means round up (away from zero) +-- This function should probably be improved. +roundingMode# :: Integer -> Int# -> Int# +roundingMode# m h = + case smallInteger 1# `shiftLInteger` h of + c -> case m `andInteger` + ((c `plusInteger` c) `minusInteger` smallInteger 1#) of + r -> + if c `ltInteger` r + then 2# + else if c `gtInteger` r + then 0# + else 1# + +-- Lookup table +data BA = BA ByteArray# + +leadingZeros :: BA +leadingZeros = + let mkArr s = + case newByteArray# 256# s of + (# s1, mba #) -> + case writeInt8Array# mba 0# 9# s1 of + s2 -> + let fillA lim val idx st = + if idx ==# 256# + then st + else if idx <# lim + then case writeInt8Array# mba idx val st of + nx -> fillA lim val (idx +# 1#) nx + else fillA (2# *# lim) (val -# 1#) idx st + in case fillA 2# 8# 1# s2 of + s3 -> case unsafeFreezeByteArray# mba s3 of + (# _, ba #) -> ba + in case mkArr realWorld# of + b -> BA b diff -Nru ghc-7.0.3/libraries/integer-simple/GHC/Integer/Logarithms.hs ghc-7.2.1/libraries/integer-simple/GHC/Integer/Logarithms.hs --- ghc-7.0.3/libraries/integer-simple/GHC/Integer/Logarithms.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/integer-simple/GHC/Integer/Logarithms.hs 2011-08-07 17:10:11.000000000 +0000 @@ -0,0 +1,43 @@ +{-# LANGUAGE MagicHash, UnboxedTuples, NoImplicitPrelude #-} +module GHC.Integer.Logarithms + ( integerLogBase# + , integerLog2# + , wordLog2# + ) where + +import GHC.Prim +import GHC.Integer +import qualified GHC.Integer.Logarithms.Internals as I + +-- | Calculate the integer logarithm for an arbitrary base. +-- The base must be greater than 1, the second argument, the number +-- whose logarithm is sought, should be positive, otherwise the +-- result is meaningless. +-- +-- > base ^ integerLogBase# base m <= m < base ^ (integerLogBase# base m + 1) +-- +-- for @base > 1@ and @m > 0@. +integerLogBase# :: Integer -> Integer -> Int# +integerLogBase# b m = case step b of + (# _, e #) -> e + where + step pw = + if m `ltInteger` pw + then (# m, 0# #) + else case step (pw `timesInteger` pw) of + (# q, e #) -> + if q `ltInteger` pw + then (# q, 2# *# e #) + else (# q `quotInteger` pw, 2# *# e +# 1# #) + +-- | Calculate the integer base 2 logarithm of an 'Integer'. +-- The calculation is more efficient than for the general case, +-- on platforms with 32- or 64-bit words much more efficient. +-- +-- The argument must be strictly positive, that condition is /not/ checked. +integerLog2# :: Integer -> Int# +integerLog2# = I.integerLog2# + +-- | This function calculates the integer base 2 logarithm of a 'Word#'. +wordLog2# :: Word# -> Int# +wordLog2# = I.wordLog2# diff -Nru ghc-7.0.3/libraries/integer-simple/GHC/Integer/Type.hs ghc-7.2.1/libraries/integer-simple/GHC/Integer/Type.hs --- ghc-7.0.3/libraries/integer-simple/GHC/Integer/Type.hs 2011-03-26 18:10:14.000000000 +0000 +++ ghc-7.2.1/libraries/integer-simple/GHC/Integer/Type.hs 2011-08-07 17:10:11.000000000 +0000 @@ -1,5 +1,5 @@ -{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE NoImplicitPrelude, CPP, MagicHash #-} ----------------------------------------------------------------------------- -- | diff -Nru ghc-7.0.3/libraries/integer-simple/GHC/Integer.hs ghc-7.2.1/libraries/integer-simple/GHC/Integer.hs --- ghc-7.0.3/libraries/integer-simple/GHC/Integer.hs 2011-03-26 18:10:14.000000000 +0000 +++ ghc-7.2.1/libraries/integer-simple/GHC/Integer.hs 2011-08-07 17:10:11.000000000 +0000 @@ -21,7 +21,7 @@ module GHC.Integer ( Integer, - smallInteger, wordToInteger, integerToWord, toInt#, + smallInteger, wordToInteger, integerToWord, integerToInt, #if WORD_SIZE_IN_BITS < 64 integerToWord64, word64ToInteger, integerToInt64, int64ToInteger, @@ -40,9 +40,9 @@ import GHC.Integer.Type -import GHC.Bool import GHC.Ordering import GHC.Prim +import GHC.Types import GHC.Unit () #if WORD_SIZE_IN_BITS < 64 import GHC.IntWord64 @@ -72,8 +72,8 @@ -- Must be Naught by the invariant: integerToWord _ = 0## -toInt# :: Integer -> Int# -toInt# i = word2Int# (integerToWord i) +integerToInt :: Integer -> Int# +integerToInt i = word2Int# (integerToWord i) #if WORD_SIZE_IN_BITS == 64 -- Nothing diff -Nru ghc-7.0.3/libraries/integer-simple/ghc.mk ghc-7.2.1/libraries/integer-simple/ghc.mk --- ghc-7.0.3/libraries/integer-simple/ghc.mk 2011-03-26 18:10:45.000000000 +0000 +++ ghc-7.2.1/libraries/integer-simple/ghc.mk 2011-08-07 17:11:00.000000000 +0000 @@ -1,3 +1,4 @@ libraries/integer-simple_PACKAGE = integer-simple libraries/integer-simple_dist-install_GROUP = libraries +$(if $(filter integer-simple,$(PACKAGES_STAGE0)),$(eval $(call build-package,libraries/integer-simple,dist-boot,0))) $(eval $(call build-package,libraries/integer-simple,dist-install,$(if $(filter integer-simple,$(STAGE2_PACKAGES)),2,1))) diff -Nru ghc-7.0.3/libraries/integer-simple/integer-simple.cabal ghc-7.2.1/libraries/integer-simple/integer-simple.cabal --- ghc-7.0.3/libraries/integer-simple/integer-simple.cabal 2011-03-26 18:10:14.000000000 +0000 +++ ghc-7.2.1/libraries/integer-simple/integer-simple.cabal 2011-08-07 17:10:11.000000000 +0000 @@ -6,13 +6,19 @@ synopsis: Simple Integer library description: This package contains an simple Integer library. -cabal-version: >=1.2 +cabal-version: >=1.6 build-type: Simple +source-repository head + type: git + location: http://darcs.haskell.org/packages/integer-simple.git/ + Library { build-depends: ghc-prim exposed-modules: GHC.Integer GHC.Integer.Simple.Internals + GHC.Integer.Logarithms + GHC.Integer.Logarithms.Internals other-modules: GHC.Integer.Type extensions: CPP, MagicHash, BangPatterns, UnboxedTuples, ForeignFunctionInterface, UnliftedFFITypes, diff -Nru ghc-7.0.3/libraries/Makefile.common ghc-7.2.1/libraries/Makefile.common --- ghc-7.0.3/libraries/Makefile.common 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/libraries/Makefile.common 1970-01-01 00:00:00.000000000 +0000 @@ -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 -Nru ghc-7.0.3/libraries/Makefile.inc ghc-7.2.1/libraries/Makefile.inc --- ghc-7.0.3/libraries/Makefile.inc 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/libraries/Makefile.inc 1970-01-01 00:00:00.000000000 +0000 @@ -1,8 +0,0 @@ -ifeq "" "${MKDIR}" -MKDIR:=$(shell pwd) -#MKDIR:=$(PWD) -else -MKDIR:=$(patsubst %/$(notdir ${MKDIR}),%, ${MKDIR}) -endif -include ${MKDIR}/Makefile.inc - diff -Nru ghc-7.0.3/libraries/Makefile.local ghc-7.2.1/libraries/Makefile.local --- ghc-7.0.3/libraries/Makefile.local 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/libraries/Makefile.local 1970-01-01 00:00:00.000000000 +0000 @@ -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 -Nru ghc-7.0.3/libraries/mtl/Control/Monad/Error.hs ghc-7.2.1/libraries/mtl/Control/Monad/Error.hs --- ghc-7.0.3/libraries/mtl/Control/Monad/Error.hs 2011-03-26 18:10:14.000000000 +0000 +++ ghc-7.2.1/libraries/mtl/Control/Monad/Error.hs 2011-08-07 17:10:11.000000000 +0000 @@ -52,6 +52,7 @@ -- $ErrorTExample ) where +import qualified Control.Exception as Exception import Control.Monad import Control.Monad.Cont.Class import Control.Monad.Error.Class @@ -70,25 +71,30 @@ -- instance MonadPlus IO where mzero = ioError (userError "mzero") - m `mplus` n = m `catch` \_ -> n + m `mplus` n = m `catchIO` \_ -> n instance MonadError IOError IO where throwError = ioError - catchError = catch + catchError = catchIO + +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +catchIO = Exception.catch -- --------------------------------------------------------------------------- -- Our parameterizable error monad #if !(MIN_VERSION_base(4,2,1)) --- These instances are in base-4.3 +-- These instances are in base-4.3, minus the fail definition and +-- the Error constraint -instance Monad (Either e) where +instance (Error e) => Monad (Either e) where return = Right Left l >>= _ = Left l Right r >>= k = k r + fail msg = Left (strMsg msg) -instance MonadFix (Either e) where +instance (Error e) => MonadFix (Either e) where mfix f = let a = f $ case a of Right r -> r diff -Nru ghc-7.0.3/libraries/mtl/ghc.mk ghc-7.2.1/libraries/mtl/ghc.mk --- ghc-7.0.3/libraries/mtl/ghc.mk 2011-03-26 18:10:45.000000000 +0000 +++ ghc-7.2.1/libraries/mtl/ghc.mk 2011-08-07 17:11:00.000000000 +0000 @@ -1,3 +1,4 @@ libraries/mtl_PACKAGE = mtl libraries/mtl_dist-install_GROUP = libraries +$(if $(filter mtl,$(PACKAGES_STAGE0)),$(eval $(call build-package,libraries/mtl,dist-boot,0))) $(eval $(call build-package,libraries/mtl,dist-install,$(if $(filter mtl,$(STAGE2_PACKAGES)),2,1))) diff -Nru ghc-7.0.3/libraries/mtl/mtl.cabal ghc-7.2.1/libraries/mtl/mtl.cabal --- ghc-7.0.3/libraries/mtl/mtl.cabal 2011-03-26 18:10:14.000000000 +0000 +++ ghc-7.2.1/libraries/mtl/mtl.cabal 2011-08-07 17:10:11.000000000 +0000 @@ -1,5 +1,5 @@ name: mtl -version: 1.1.1.0 +version: 1.1.1.1 license: BSD3 license-file: LICENSE author: Andy Gill diff -Nru ghc-7.0.3/libraries/old-locale/ghc.mk ghc-7.2.1/libraries/old-locale/ghc.mk --- ghc-7.0.3/libraries/old-locale/ghc.mk 2011-03-26 18:10:45.000000000 +0000 +++ ghc-7.2.1/libraries/old-locale/ghc.mk 2011-08-07 17:11:00.000000000 +0000 @@ -1,3 +1,4 @@ libraries/old-locale_PACKAGE = old-locale libraries/old-locale_dist-install_GROUP = libraries +$(if $(filter old-locale,$(PACKAGES_STAGE0)),$(eval $(call build-package,libraries/old-locale,dist-boot,0))) $(eval $(call build-package,libraries/old-locale,dist-install,$(if $(filter old-locale,$(STAGE2_PACKAGES)),2,1))) diff -Nru ghc-7.0.3/libraries/old-locale/old-locale.cabal ghc-7.2.1/libraries/old-locale/old-locale.cabal --- ghc-7.0.3/libraries/old-locale/old-locale.cabal 2011-03-26 18:10:14.000000000 +0000 +++ ghc-7.2.1/libraries/old-locale/old-locale.cabal 2011-08-07 17:10:11.000000000 +0000 @@ -1,5 +1,5 @@ name: old-locale -version: 1.0.0.2 +version: 1.0.0.3 license: BSD3 license-file: LICENSE maintainer: libraries@haskell.org @@ -18,6 +18,6 @@ build-depends: base >= 3 && < 5 source-repository head - type: darcs - location: http://darcs.haskell.org/packages/old-locale/ + type: git + location: http://darcs.haskell.org/packages/old-locale.git/ diff -Nru ghc-7.0.3/libraries/old-time/ghc.mk ghc-7.2.1/libraries/old-time/ghc.mk --- ghc-7.0.3/libraries/old-time/ghc.mk 2011-03-26 18:10:45.000000000 +0000 +++ ghc-7.2.1/libraries/old-time/ghc.mk 2011-08-07 17:11:00.000000000 +0000 @@ -1,3 +1,4 @@ libraries/old-time_PACKAGE = old-time libraries/old-time_dist-install_GROUP = libraries +$(if $(filter old-time,$(PACKAGES_STAGE0)),$(eval $(call build-package,libraries/old-time,dist-boot,0))) $(eval $(call build-package,libraries/old-time,dist-install,$(if $(filter old-time,$(STAGE2_PACKAGES)),2,1))) diff -Nru ghc-7.0.3/libraries/old-time/old-time.cabal ghc-7.2.1/libraries/old-time/old-time.cabal --- ghc-7.0.3/libraries/old-time/old-time.cabal 2011-03-26 18:10:14.000000000 +0000 +++ ghc-7.2.1/libraries/old-time/old-time.cabal 2011-08-07 17:10:11.000000000 +0000 @@ -1,5 +1,5 @@ name: old-time -version: 1.0.0.6 +version: 1.0.0.7 license: BSD3 license-file: LICENSE maintainer: libraries@haskell.org @@ -33,6 +33,6 @@ nhc98-options: -K2M source-repository head - type: darcs - location: http://darcs.haskell.org/packages/old-time/ + type: git + location: http://darcs.haskell.org/packages/old-time.git/ diff -Nru ghc-7.0.3/libraries/old-time/System/Time.hsc ghc-7.2.1/libraries/old-time/System/Time.hsc --- ghc-7.0.3/libraries/old-time/System/Time.hsc 2011-03-26 18:10:14.000000000 +0000 +++ ghc-7.2.1/libraries/old-time/System/Time.hsc 2011-08-07 17:10:11.000000000 +0000 @@ -250,7 +250,7 @@ allocaBytes (#const sizeof(struct timeval)) $ \ p_timeval -> do throwErrnoIfMinus1_ "getClockTime" $ gettimeofday p_timeval nullPtr sec <- (#peek struct timeval,tv_sec) p_timeval :: IO CTime - usec <- (#peek struct timeval,tv_usec) p_timeval :: IO CTime + usec <- (#peek struct timeval,tv_usec) p_timeval :: IO CSUSeconds return (TOD (realToInteger sec) ((realToInteger usec) * 1000000)) #elif HAVE_FTIME @@ -405,7 +405,7 @@ -- -- This module assumes the interpretation of tm_gmtoff, i.e., offsets -- are > 0 East of the Prime Meridian, so flip the sign. - return (- (if dst then (fromIntegral tz - 3600) else tz)) + return (- (if dst then tz - 3600 else tz)) # endif /* ! HAVE_DECL_ALTZONE */ #endif /* ! HAVE_TM_ZONE */ #endif /* ! __HUGS__ */ diff -Nru ghc-7.0.3/libraries/pretty/ghc.mk ghc-7.2.1/libraries/pretty/ghc.mk --- ghc-7.0.3/libraries/pretty/ghc.mk 2011-03-26 18:10:45.000000000 +0000 +++ ghc-7.2.1/libraries/pretty/ghc.mk 2011-08-07 17:11:00.000000000 +0000 @@ -1,3 +1,4 @@ libraries/pretty_PACKAGE = pretty libraries/pretty_dist-install_GROUP = libraries +$(if $(filter pretty,$(PACKAGES_STAGE0)),$(eval $(call build-package,libraries/pretty,dist-boot,0))) $(eval $(call build-package,libraries/pretty,dist-install,$(if $(filter pretty,$(STAGE2_PACKAGES)),2,1))) diff -Nru ghc-7.0.3/libraries/pretty/pretty.cabal ghc-7.2.1/libraries/pretty/pretty.cabal --- ghc-7.0.3/libraries/pretty/pretty.cabal 2011-03-26 18:10:14.000000000 +0000 +++ ghc-7.2.1/libraries/pretty/pretty.cabal 2011-08-07 17:10:11.000000000 +0000 @@ -1,15 +1,15 @@ -name: pretty -version: 1.0.1.2 -license: BSD3 -license-file: LICENSE -maintainer: libraries@haskell.org -bug-reports: http://hackage.haskell.org/trac/ghc/newticket?component=libraries/pretty -synopsis: Pretty-printing library -category: Text +name: pretty +version: 1.1.0.0 +license: BSD3 +license-file: LICENSE +maintainer: David Terei +bug-reports: http://hackage.haskell.org/trac/ghc/newticket?component=libraries/pretty +synopsis: Pretty-printing library +category: Text description: - This package contains John Hughes's pretty-printing library, + This package contains John Hughes's pretty-printing library, heavily modified by Simon Peyton Jones. -build-type: Simple +build-type: Simple Cabal-Version: >= 1.6 Library @@ -19,6 +19,6 @@ build-depends: base >= 3 && < 5 source-repository head - type: darcs - location: http://darcs.haskell.org/packages/pretty/ + type: git + location: http://github.com/haskell/pretty.git diff -Nru ghc-7.0.3/libraries/pretty/Text/PrettyPrint/HughesPJ.hs ghc-7.2.1/libraries/pretty/Text/PrettyPrint/HughesPJ.hs --- ghc-7.0.3/libraries/pretty/Text/PrettyPrint/HughesPJ.hs 2011-03-26 18:10:14.000000000 +0000 +++ ghc-7.2.1/libraries/pretty/Text/PrettyPrint/HughesPJ.hs 2011-08-07 17:10:11.000000000 +0000 @@ -3,13 +3,13 @@ -- Module : Text.PrettyPrint.HughesPJ -- Copyright : (c) The University of Glasgow 2001 -- License : BSD-style (see the file libraries/base/LICENSE) --- +-- -- Maintainer : libraries@haskell.org -- Stability : provisional -- Portability : portable -- -- John Hughes's and Simon Peyton Jones's Pretty Printer Combinators --- +-- -- Based on /The Design of a Pretty-printing Library/ -- in Advanced Functional Programming, -- Johan Jeuring and Erik Meijer (eds), LNCS 925 @@ -95,7 +95,7 @@ ====================================================================== Relative to John's original paper, there are the following new features: -1. There's an empty document, "empty". It's a left and right unit for +1. There's an empty document, "empty". It's a left and right unit for both <> and $$, and anywhere in the argument list for sep, hcat, hsep, vcat, fcat etc. @@ -104,7 +104,7 @@ 2. There is a paragraph-fill combinator, fsep, that's much like sep, only it keeps fitting things on one line until it can't fit any more. -3. Some random useful extra combinators are provided. +3. Some random useful extra combinators are provided. <+> puts its arguments beside each other with a space between them, unless either argument is empty in which case it returns the other @@ -120,7 +120,7 @@ These new ones do the obvious things: char, semi, comma, colon, space, - parens, brackets, braces, + parens, brackets, braces, quotes, doubleQuotes 4. The "above" combinator, $$, now overlaps its two arguments if the @@ -158,10 +158,12 @@ 5. Several different renderers are provided: * a standard one - * one that uses cut-marks to avoid deeply-nested documents + * one that uses cut-marks to avoid deeply-nested documents simply piling up in the right-hand margin - * one that ignores indentation (fewer chars output; good for machines) - * one that ignores indentation and newlines (ditto, only more so) + * one that ignores indentation + (fewer chars output; good for machines) + * one that ignores indentation and newlines + (ditto, only more so) 6. Numerous implementation tidy-ups Use of unboxed data types to speed up the implementation @@ -169,44 +171,45 @@ module Text.PrettyPrint.HughesPJ ( - -- * The document type + -- * The document type Doc, -- Abstract - -- * Constructing documents - -- ** Converting values into documents - char, text, ptext, zeroWidthText, + -- * Constructing documents + + -- ** Converting values into documents + char, text, ptext, sizedText, zeroWidthText, int, integer, float, double, rational, - -- ** Simple derived documents + -- ** Simple derived documents semi, comma, colon, space, equals, lparen, rparen, lbrack, rbrack, lbrace, rbrace, - -- ** Wrapping documents in delimiters + -- ** Wrapping documents in delimiters parens, brackets, braces, quotes, doubleQuotes, - -- ** Combining documents + -- ** Combining documents empty, - (<>), (<+>), hcat, hsep, - ($$), ($+$), vcat, - sep, cat, - fsep, fcat, - nest, + (<>), (<+>), hcat, hsep, + ($$), ($+$), vcat, + sep, cat, + fsep, fcat, + nest, hang, punctuate, - - -- * Predicates on documents - isEmpty, - - -- * Rendering documents - - -- ** Default rendering - render, - - -- ** Rendering with a particular style - Style(..), - style, + + -- * Predicates on documents + isEmpty, + + -- * Rendering documents + + -- ** Default rendering + render, + + -- ** Rendering with a particular style + Style(..), + style, renderStyle, - -- ** General rendering + -- ** General rendering fullRender, Mode(..), TextDetails(..), @@ -214,8 +217,10 @@ import Prelude +import Data.Monoid ( Monoid(mempty, mappend) ) +import Data.String ( IsString(fromString) ) -infixl 6 <> +infixl 6 <> infixl 6 <+> infixl 5 $$, $+$ @@ -231,20 +236,20 @@ -- in the argument list for 'sep', 'hcat', 'hsep', 'vcat', 'fcat' etc. empty :: Doc -semi :: Doc; -- ^ A ';' character -comma :: Doc; -- ^ A ',' character -colon :: Doc; -- ^ A ':' character -space :: Doc; -- ^ A space character -equals :: Doc; -- ^ A '=' character -lparen :: Doc; -- ^ A '(' character -rparen :: Doc; -- ^ A ')' character -lbrack :: Doc; -- ^ A '[' character -rbrack :: Doc; -- ^ A ']' character -lbrace :: Doc; -- ^ A '{' character -rbrace :: Doc; -- ^ A '}' character +semi :: Doc; -- ^ A ';' character +comma :: Doc; -- ^ A ',' character +colon :: Doc; -- ^ A ':' character +space :: Doc; -- ^ A space character +equals :: Doc; -- ^ A '=' character +lparen :: Doc; -- ^ A '(' character +rparen :: Doc; -- ^ A ')' character +lbrack :: Doc; -- ^ A '[' character +rbrack :: Doc; -- ^ A ']' character +lbrace :: Doc; -- ^ A '{' character +rbrace :: Doc; -- ^ A '}' character -- | A document of height and width 1, containing a literal character. -char :: Char -> Doc +char :: Char -> Doc -- | A document of height 1 containing a literal string. -- 'text' satisfies the following laws: @@ -255,29 +260,39 @@ -- -- The side condition on the last law is necessary because @'text' \"\"@ -- has height 1, while 'empty' has no height. -text :: String -> Doc +text :: String -> Doc + +instance IsString Doc where + fromString = text -- | An obsolete function, now identical to 'text'. -ptext :: String -> Doc +ptext :: String -> Doc + +-- | Some text with any width. (@text s = sizedText (length s) s@) +sizedText :: Int -> String -> Doc -- | Some text, but without any width. Use for non-printing text -- such as a HTML or Latex tags zeroWidthText :: String -> Doc -int :: Int -> Doc; -- ^ @int n = text (show n)@ -integer :: Integer -> Doc; -- ^ @integer n = text (show n)@ -float :: Float -> Doc; -- ^ @float n = text (show n)@ -double :: Double -> Doc; -- ^ @double n = text (show n)@ -rational :: Rational -> Doc; -- ^ @rational n = text (show n)@ - -parens :: Doc -> Doc; -- ^ Wrap document in @(...)@ -brackets :: Doc -> Doc; -- ^ Wrap document in @[...]@ -braces :: Doc -> Doc; -- ^ Wrap document in @{...}@ -quotes :: Doc -> Doc; -- ^ Wrap document in @\'...\'@ -doubleQuotes :: Doc -> Doc; -- ^ Wrap document in @\"...\"@ +int :: Int -> Doc; -- ^ @int n = text (show n)@ +integer :: Integer -> Doc; -- ^ @integer n = text (show n)@ +float :: Float -> Doc; -- ^ @float n = text (show n)@ +double :: Double -> Doc; -- ^ @double n = text (show n)@ +rational :: Rational -> Doc; -- ^ @rational n = text (show n)@ + +parens :: Doc -> Doc; -- ^ Wrap document in @(...)@ +brackets :: Doc -> Doc; -- ^ Wrap document in @[...]@ +braces :: Doc -> Doc; -- ^ Wrap document in @{...}@ +quotes :: Doc -> Doc; -- ^ Wrap document in @\'...\'@ +doubleQuotes :: Doc -> Doc; -- ^ Wrap document in @\"...\"@ -- Combining @Doc@ values +instance Monoid Doc where + mempty = empty + mappend = (<>) + -- | Beside. -- '<>' is associative, with identity 'empty'. (<>) :: Doc -> Doc -> Doc @@ -348,7 +363,7 @@ punctuate :: Doc -> [Doc] -> [Doc] --- Displaying @Doc@ values. +-- Displaying @Doc@ values. instance Show Doc where showsPrec _ doc cont = showDoc doc cont @@ -357,12 +372,12 @@ render :: Doc -> String -- | The general rendering interface. -fullRender :: Mode -- ^Rendering mode +fullRender :: Mode -- ^Rendering mode -> Int -- ^Line length -> Float -- ^Ribbons per line -> (TextDetails -> a -> a) -- ^What to do with text -> a -- ^What to do at the end - -> Doc -- ^The document + -> Doc -- ^The document -> a -- ^Result -- | Render the document as a string using a specified style. @@ -371,7 +386,7 @@ -- | A rendering style. data Style = Style { mode :: Mode -- ^ The rendering mode - , lineLength :: Int -- ^ Length of line, in chars + , lineLength :: Int -- ^ Length of line, in chars , ribbonsPerLine :: Float -- ^ Ratio of ribbon length to line length } @@ -380,7 +395,7 @@ style = Style { lineLength = 100, ribbonsPerLine = 1.5, mode = PageMode } -- | Rendering mode. -data Mode = PageMode -- ^Normal +data Mode = PageMode -- ^Normal | ZigZagMode -- ^With zig-zag cuts | LeftMode -- ^No indentation, infinitely long lines | OneLineMode -- ^All on one line @@ -411,10 +426,10 @@ ~~~~~~~~~~~~~ text s <> text t = text (s++t) text "" <> x = x, if x non-empty - + ** because of law n6, t2 only holds if x doesn't ** start with `nest'. - + Laws for nest ~~~~~~~~~~~~~ @@ -431,7 +446,7 @@ Miscellaneous ~~~~~~~~~~~~~ (text s <> x) $$ y = text s <> ((text "" <> x) $$ - nest (-length s) y) + nest (-length s) y) (x $$ y) <> z = x $$ (y <> z) if y non-empty @@ -448,12 +463,12 @@ Laws for oneLiner ~~~~~~~~~~~~~~~~~ oneLiner (nest k p) = nest k (oneLiner p) - oneLiner (x <> y) = oneLiner x <> oneLiner y + oneLiner (x <> y) = oneLiner x <> oneLiner y You might think that the following verion of would be neater: -<3 NO> (text s <> x) $$ y = text s <> ((empty <> x)) $$ +<3 NO> (text s <> x) $$ y = text s <> ((empty <> x)) $$ nest (-length s) y) But it doesn't work, for if x=empty, we would have @@ -528,14 +543,15 @@ data Doc = Empty -- empty | NilAbove Doc -- text "" $$ x - | TextBeside TextDetails !Int Doc -- text s <> x + | TextBeside TextDetails !Int Doc -- text s <> x | Nest !Int Doc -- nest k x | Union Doc Doc -- ul `union` ur | NoDoc -- The empty set of documents | Beside Doc Bool Doc -- True <=> space between | Above Doc Bool Doc -- True <=> never overlap -type RDoc = Doc -- RDoc is a "reduced Doc", guaranteed not to have a top-level Above or Beside +-- RDoc is a "reduced Doc", guaranteed not to have a top-level Above or Beside +type RDoc = Doc reduceDoc :: Doc -> RDoc @@ -553,25 +569,25 @@ {- Here are the invariants: - + 1) The argument of NilAbove is never Empty. Therefore a NilAbove occupies at least two lines. - + 2) The argument of @TextBeside@ is never @Nest@. - - - 3) The layouts of the two arguments of @Union@ both flatten to the same + + + 3) The layouts of the two arguments of @Union@ both flatten to the same string. - + 4) The arguments of @Union@ are either @TextBeside@, or @NilAbove@. - - 5) A @NoDoc@ may only appear on the first line of the left argument of an + + 5) A @NoDoc@ may only appear on the first line of the left argument of an union. Therefore, the right argument of an union can never be equivalent to the empty set (@NoDoc@). - + 6) An empty document is always represented by @Empty@. It can't be hidden inside a @Nest@, or a @Union@ of two @Empty@s. - + 7) The first line of every layout in the left argument of @Union@ is longer than the first line of any layout in the right argument. (1) ensures that the left argument has a first line. In view of @@ -595,10 +611,10 @@ -- Notice the difference between --- * NoDoc (no documents) --- * Empty (one empty document; no height and no width) --- * text "" (a document containing the empty string; --- one line high, but has no width) +-- * NoDoc (no documents) +-- * Empty (one empty document; no height and no width) +-- * text "" (a document containing the empty string; +-- one line high, but has no width) -- --------------------------------------------------------------------------- @@ -612,7 +628,8 @@ char c = textBeside_ (Chr c) 1 Empty text s = case length s of {sl -> textBeside_ (Str s) sl Empty} ptext s = case length s of {sl -> textBeside_ (PStr s) sl Empty} -zeroWidthText s = textBeside_ (Str s) 0 Empty +sizedText l s = textBeside_ (Str s) l Empty +zeroWidthText = sizedText 0 nest k p = mkNest k (reduceDoc p) -- Externally callable version @@ -651,13 +668,13 @@ aboveNest _ _ k _ | k `seq` False = undefined aboveNest NoDoc _ _ _ = NoDoc -aboveNest (p1 `Union` p2) g k q = aboveNest p1 g k q `union_` +aboveNest (p1 `Union` p2) g k q = aboveNest p1 g k q `union_` aboveNest p2 g k q - + aboveNest Empty _ k q = mkNest k q aboveNest (Nest k1 p) g k q = nest_ k1 (aboveNest p g (k - k1) q) -- p can't be Empty, so no need for mkNest - + aboveNest (NilAbove p) g k q = nilAbove_ (aboveNest p g k q) aboveNest (TextBeside s sl p) g k q = k1 `seq` textBeside_ s sl rest where @@ -670,16 +687,17 @@ nilAboveNest :: Bool -> Int -> RDoc -> RDoc --- Specification: text s <> nilaboveNest g k q +-- Specification: text s <> nilaboveNest g k q -- = text s <> (text "" $g$ nest k q) nilAboveNest _ k _ | k `seq` False = undefined -nilAboveNest _ _ Empty = Empty -- Here's why the "text s <>" is in the spec! +nilAboveNest _ _ Empty = Empty + -- Here's why the "text s <>" is in the spec! nilAboveNest g k (Nest k1 q) = nilAboveNest g (k + k1) q -nilAboveNest g k q | (not g) && (k > 0) -- No newline if no overlap - = textBeside_ (Str (spaces k)) k q - | otherwise -- Put them really above +nilAboveNest g k q | not g && k > 0 -- No newline if no overlap + = textBeside_ (Str (indent k)) k q + | otherwise -- Put them really above = nilAbove_ (mkNest k q) -- --------------------------------------------------------------------------- @@ -695,14 +713,14 @@ beside :: Doc -> Bool -> RDoc -> RDoc -- Specification: beside g p q = p q - + beside NoDoc _ _ = NoDoc -beside (p1 `Union` p2) g q = (beside p1 g q) `union_` (beside p2 g q) +beside (p1 `Union` p2) g q = beside p1 g q `union_` beside p2 g q beside Empty _ q = q beside (Nest k p) g q = nest_ k (beside p g q) -- p non-empty -beside p@(Beside p1 g1 q1) g2 q2 - {- (A `op1` B) `op2` C == A `op1` (B `op2` C) iff op1 == op2 - [ && (op1 == <> || op1 == <+>) ] -} +beside p@(Beside p1 g1 q1) g2 q2 + {- (A `op1` B) `op2` C == A `op1` (B `op2` C) iff op1 == op2 + [ && (op1 == <> || op1 == <+>) ] -} | g1 == g2 = beside p1 g1 (beside q1 g2 q2) | otherwise = beside (reduceDoc p) g2 q2 beside p@(Above _ _ _) g q = beside (reduceDoc p) g q @@ -715,7 +733,7 @@ nilBeside :: Bool -> RDoc -> RDoc --- Specification: text "" <> nilBeside g p +-- Specification: text "" <> nilBeside g p -- = text "" p nilBeside _ Empty = Empty -- Hence the text "" in the spec @@ -747,12 +765,13 @@ sep1 _ NoDoc _ _ = NoDoc sep1 g (p `Union` q) k ys = sep1 g p k ys `union_` - (aboveNest q False k (reduceDoc (vcat ys))) + aboveNest q False k (reduceDoc (vcat ys)) sep1 g Empty k ys = mkNest k (sepX g ys) sep1 g (Nest n p) k ys = nest_ n (sep1 g p (k - n) ys) -sep1 _ (NilAbove p) k ys = nilAbove_ (aboveNest p False k (reduceDoc (vcat ys))) +sep1 _ (NilAbove p) k ys = nilAbove_ + (aboveNest p False k (reduceDoc (vcat ys))) sep1 g (TextBeside s sl p) k ys = textBeside_ s sl (sepNB g p (k - sl) ys) sep1 _ (Above {}) _ _ = error "sep1 Above" sep1 _ (Beside {}) _ _ = error "sep1 Beside" @@ -763,10 +782,11 @@ sepNB :: Bool -> Doc -> Int -> [Doc] -> Doc -sepNB g (Nest _ p) k ys = sepNB g p k ys -- Never triggered, because of invariant (2) +sepNB g (Nest _ p) k ys = sepNB g p k ys + -- Never triggered, because of invariant (2) sepNB g Empty k ys = oneLiner (nilBeside g (reduceDoc rest)) - `mkUnion` + `mkUnion` nilAboveNest True k (reduceDoc (vcat ys)) where rest | g = hsep ys @@ -787,7 +807,8 @@ -- fillIndent k [] = [] -- fillIndent k [p] = p -- fillIndent k (p1:p2:ps) = --- oneLiner p1 fillIndent (k + length p1 + g ? 1 : 0) (remove_nests (oneLiner p2) : ps) +-- oneLiner p1 fillIndent (k + length p1 + g ? 1 : 0) +-- (remove_nests (oneLiner p2) : ps) -- `Union` -- (p1 $*$ nest (-k) (fillIndent 0 ps)) -- @@ -805,7 +826,7 @@ fill1 _ NoDoc _ _ = NoDoc fill1 g (p `Union` q) k ys = fill1 g p k ys `union_` - (aboveNest q False k (fill g ys)) + aboveNest q False k (fill g ys) fill1 g Empty k ys = mkNest k (fill g ys) fill1 g (Nest n p) k ys = nest_ n (fill1 g p (k - n) ys) @@ -817,15 +838,18 @@ fillNB :: Bool -> Doc -> Int -> [Doc] -> Doc fillNB _ _ k _ | k `seq` False = undefined -fillNB g (Nest _ p) k ys = fillNB g p k ys -- Never triggered, because of invariant (2) +fillNB g (Nest _ p) k ys = fillNB g p k ys + -- Never triggered, because of invariant (2) fillNB _ Empty _ [] = Empty fillNB g Empty k (Empty:ys) = fillNB g Empty k ys fillNB g Empty k (y:ys) = fillNBE g k y ys fillNB g p k ys = fill1 g p k ys fillNBE :: Bool -> Int -> Doc -> [Doc] -> Doc -fillNBE g k y ys = nilBeside g (fill1 g ((elideNest . oneLiner . reduceDoc) y) k1 ys) - `mkUnion` +fillNBE g k y ys = nilBeside g + (fill1 g ((elideNest . oneLiner . reduceDoc) y) + k1 ys) + `mkUnion` nilAboveNest True k (fill g (y:ys)) where k1 | g = k - 1 @@ -882,7 +906,7 @@ get1 w sl (NilAbove p) = nilAbove_ (get (w - sl) p) get1 w sl (TextBeside t tl p) = textBeside_ t tl (get1 w (sl + tl) p) get1 w sl (Nest _ p) = get1 w sl p - get1 w sl (p `Union` q) = nicest1 w r sl (get1 w sl p) + get1 w sl (p `Union` q) = nicest1 w r sl (get1 w sl p) (get1 w sl q) get1 _ _ (Above {}) = error "best get1 Above" get1 _ _ (Beside {}) = error "best get1 Beside" @@ -897,7 +921,7 @@ fits :: Int -- Space available -> Doc -> Bool -- True if *first line* of Doc fits in space available - + fits n _ | n < 0 = False fits _ NoDoc = False fits _ Empty = True @@ -949,9 +973,9 @@ = fullRender (mode the_style) (lineLength the_style) (ribbonsPerLine the_style) - string_txt - "" - doc + string_txt + "" + doc render doc = showDoc doc "" @@ -964,12 +988,14 @@ string_txt (PStr s1) s2 = s1 ++ s2 -fullRender OneLineMode _ _ txt end doc = easy_display space_text txt end (reduceDoc doc) -fullRender LeftMode _ _ txt end doc = easy_display nl_text txt end (reduceDoc doc) +fullRender OneLineMode _ _ txt end doc + = easy_display space_text txt end (reduceDoc doc) +fullRender LeftMode _ _ txt end doc + = easy_display nl_text txt end (reduceDoc doc) fullRender the_mode line_length ribbons_per_line txt end doc = display the_mode line_length ribbon_length txt end best_doc - where + where best_doc = best the_mode hacked_line_length ribbon_length (reduceDoc doc) hacked_line_length, ribbon_length :: Int @@ -990,31 +1016,31 @@ lay _ (Beside {}) = error "display lay Beside" lay _ NoDoc = error "display lay NoDoc" lay _ (Union {}) = error "display lay Union" - + lay k (NilAbove p) = nl_text `txt` lay k p - + lay k (TextBeside s sl p) = case the_mode of ZigZagMode | k >= gap_width -> nl_text `txt` ( - Str (multi_ch shift '/') `txt` ( - nl_text `txt` ( - lay1 (k - shift) s sl p))) + Str (replicate shift '/') `txt` ( + nl_text `txt` + lay1 (k - shift) s sl p )) | k < 0 -> nl_text `txt` ( - Str (multi_ch shift '\\') `txt` ( - nl_text `txt` ( - lay1 (k + shift) s sl p ))) + Str (replicate shift '\\') `txt` ( + nl_text `txt` + lay1 (k + shift) s sl p )) _ -> lay1 k s sl p - + lay1 k _ sl _ | k+sl `seq` False = undefined lay1 k s sl p = Str (indent k) `txt` (s `txt` lay2 (k + sl) p) - + lay2 k _ | k `seq` False = undefined lay2 k (NilAbove p) = nl_text `txt` lay k p - lay2 k (TextBeside s sl p) = s `txt` (lay2 (k + sl) p) + lay2 k (TextBeside s sl p) = s `txt` lay2 (k + sl) p lay2 k (Nest _ p) = lay2 k p lay2 _ Empty = end lay2 _ (Above {}) = error "display lay2 Above" @@ -1029,39 +1055,23 @@ cant_fail = error "easy_display: NoDoc" easy_display :: TextDetails -> (TextDetails -> a -> a) -> a -> Doc -> a -easy_display nl_space_text txt end doc +easy_display nl_space_text txt end doc = lay doc cant_fail where lay NoDoc no_doc = no_doc - lay (Union _p q) _ = {- lay p -} (lay q cant_fail) -- Second arg can't be NoDoc + lay (Union _p q) _ = {- lay p -} lay q cant_fail + -- Second arg can't be NoDoc lay (Nest _ p) no_doc = lay p no_doc lay Empty _ = end - lay (NilAbove p) _ = nl_space_text `txt` lay p cant_fail -- NoDoc always on first line + lay (NilAbove p) _ = nl_space_text `txt` lay p cant_fail + -- NoDoc always on first line lay (TextBeside s _ p) no_doc = s `txt` lay p no_doc lay (Above {}) _ = error "easy_display Above" lay (Beside {}) _ = error "easy_display Beside" --- OLD version: we shouldn't rely on tabs being 8 columns apart in the output. --- indent n | n >= 8 = '\t' : indent (n - 8) --- | otherwise = spaces n +-- an old version inserted tabs being 8 columns apart in the output. indent :: Int -> String -indent n = spaces n - -multi_ch :: Int -> Char -> String -multi_ch 0 _ = "" -multi_ch n ch = ch : multi_ch (n - 1) ch - --- (spaces n) generates a list of n spaces --- --- returns the empty string on negative argument. --- -spaces :: Int -> String -spaces n - {- - | n < 0 = trace "Warning: negative indentation" "" - -} - | n <= 0 = "" - | otherwise = ' ' : spaces (n - 1) +indent n = replicate n ' ' {- Q: What is the reason for negative indentation (i.e. argument to indent diff -Nru ghc-7.0.3/libraries/process/cbits/runProcess.c ghc-7.2.1/libraries/process/cbits/runProcess.c --- ghc-7.0.3/libraries/process/cbits/runProcess.c 2011-03-26 18:10:15.000000000 +0000 +++ ghc-7.2.1/libraries/process/cbits/runProcess.c 2011-08-07 17:10:11.000000000 +0000 @@ -1,528 +1,538 @@ -/* ---------------------------------------------------------------------------- - (c) The University of Glasgow 2004 - - Support for System.Process - ------------------------------------------------------------------------- */ - -#if defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32) -#define UNICODE -#endif - -/* XXX This is a nasty hack; should put everything necessary in this package */ -#include "HsBase.h" -#include "Rts.h" - -#include "runProcess.h" - -#if !(defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32)) - -#include "execvpe.h" - -/* ---------------------------------------------------------------------------- - UNIX versions - ------------------------------------------------------------------------- */ - -static long max_fd = 0; - -// Rts internal API, not exposed in a public header file: -extern void blockUserSignals(void); -extern void unblockUserSignals(void); - -ProcHandle -runInteractiveProcess (char *const args[], - char *workingDirectory, char **environment, - int fdStdIn, int fdStdOut, int fdStdErr, - int *pfdStdInput, int *pfdStdOutput, int *pfdStdError, - int set_inthandler, long inthandler, - int set_quithandler, long quithandler, - int close_fds) -{ - int pid; - int fdStdInput[2], fdStdOutput[2], fdStdError[2]; - int r; - struct sigaction dfl; - - // Ordering matters here, see below [Note #431]. - if (fdStdIn == -1) { - r = pipe(fdStdInput); - if (r == -1) { - sysErrorBelch("runInteractiveProcess: pipe"); - return -1; - } - - } - if (fdStdOut == -1) { - r = pipe(fdStdOutput); - if (r == -1) { - sysErrorBelch("runInteractiveProcess: pipe"); - return -1; - } - } - if (fdStdErr == -1) { - r = pipe(fdStdError); - if (r == -1) { - sysErrorBelch("runInteractiveProcess: pipe"); - return -1; - } - } - - // Block signals with Haskell handlers. The danger here is that - // with the threaded RTS, a signal arrives in the child process, - // the RTS writes the signal information into the pipe (which is - // shared between parent and child), and the parent behaves as if - // the signal had been raised. - blockUserSignals(); - - // See #4074. Sometimes fork() gets interrupted by the timer - // signal and keeps restarting indefinitely. - stopTimer(); - - switch(pid = fork()) - { - case -1: - unblockUserSignals(); -#if __GLASGOW_HASKELL__ > 612 - startTimer(); -#endif - if (fdStdIn == -1) { - close(fdStdInput[0]); - close(fdStdInput[1]); - } - if (fdStdOut == -1) { - close(fdStdOutput[0]); - close(fdStdOutput[1]); - } - if (fdStdErr == -1) { - close(fdStdError[0]); - close(fdStdError[1]); - } - return -1; - - case 0: - { - // WARNING! we are now in the child of vfork(), so any memory - // we modify below will also be seen in the parent process. - - unblockUserSignals(); - - if (workingDirectory) { - if (chdir (workingDirectory) < 0) { - // See #1593. The convention for the exit code when - // exec() fails seems to be 127 (gleened from C's - // system()), but there's no equivalent convention for - // chdir(), so I'm picking 126 --SimonM. - _exit(126); - } - } - - // [Note #431]: Ordering matters here. If any of the FDs - // 0,1,2 were initially closed, then our pipes may have used - // these FDs. So when we dup2 the pipe FDs down to 0,1,2, we - // must do it in that order, otherwise we could overwrite an - // FD that we need later. - - if (fdStdIn == -1) { - if (fdStdInput[0] != STDIN_FILENO) { - dup2 (fdStdInput[0], STDIN_FILENO); - close(fdStdInput[0]); - } - close(fdStdInput[1]); - } else { - dup2(fdStdIn, STDIN_FILENO); - } - - if (fdStdOut == -1) { - if (fdStdOutput[1] != STDOUT_FILENO) { - dup2 (fdStdOutput[1], STDOUT_FILENO); - close(fdStdOutput[1]); - } - close(fdStdOutput[0]); - } else { - dup2(fdStdOut, STDOUT_FILENO); - } - - if (fdStdErr == -1) { - if (fdStdError[1] != STDERR_FILENO) { - dup2 (fdStdError[1], STDERR_FILENO); - close(fdStdError[1]); - } - close(fdStdError[0]); - } else { - dup2(fdStdErr, STDERR_FILENO); - } - - if (close_fds) { - int i; - if (max_fd == 0) { -#if HAVE_SYSCONF - max_fd = sysconf(_SC_OPEN_MAX); - if (max_fd == -1) { - max_fd = 256; - } -#else - max_fd = 256; -#endif - } - for (i = 3; i < max_fd; i++) { - close(i); - } - } - - /* Set the SIGINT/SIGQUIT signal handlers in the child, if requested - */ - (void)sigemptyset(&dfl.sa_mask); - dfl.sa_flags = 0; - if (set_inthandler) { - dfl.sa_handler = (void *)inthandler; - (void)sigaction(SIGINT, &dfl, NULL); - } - if (set_quithandler) { - dfl.sa_handler = (void *)quithandler; - (void)sigaction(SIGQUIT, &dfl, NULL); - } - - /* the child */ - if (environment) { - execvpe(args[0], args, environment); - } else { - execvp(args[0], args); - } - } - _exit(127); - - default: - if (fdStdIn == -1) { - close(fdStdInput[0]); - fcntl(fdStdInput[1], F_SETFD, FD_CLOEXEC); - *pfdStdInput = fdStdInput[1]; - } - if (fdStdOut == -1) { - close(fdStdOutput[1]); - fcntl(fdStdOutput[0], F_SETFD, FD_CLOEXEC); - *pfdStdOutput = fdStdOutput[0]; - } - if (fdStdErr == -1) { - close(fdStdError[1]); - fcntl(fdStdError[0], F_SETFD, FD_CLOEXEC); - *pfdStdError = fdStdError[0]; - } - break; - } - unblockUserSignals(); - startTimer(); - - return pid; -} - -int -terminateProcess (ProcHandle handle) -{ - return (kill(handle, SIGTERM) == 0); -} - -int -getProcessExitCode (ProcHandle handle, int *pExitCode) -{ - int wstat, res; - - *pExitCode = 0; - - if ((res = waitpid(handle, &wstat, WNOHANG)) > 0) - { - if (WIFEXITED(wstat)) - { - *pExitCode = WEXITSTATUS(wstat); - return 1; - } - else - if (WIFSIGNALED(wstat)) - { - errno = EINTR; - return -1; - } - else - { - /* This should never happen */ - } - } - - if (res == 0) return 0; - - if (errno == ECHILD) - { - *pExitCode = 0; - return 1; - } - - return -1; -} - -int waitForProcess (ProcHandle handle, int *pret) -{ - int wstat; - - while (waitpid(handle, &wstat, 0) < 0) - { - if (errno != EINTR) - { - return -1; - } - } - - if (WIFEXITED(wstat)) { - *pret = WEXITSTATUS(wstat); - return 0; - } - else - if (WIFSIGNALED(wstat)) - { - *pret = wstat; - return 0; - } - else - { - /* This should never happen */ - } - - return -1; -} - -#else -/* ---------------------------------------------------------------------------- - Win32 versions - ------------------------------------------------------------------------- */ - -/* -------------------- WINDOWS VERSION --------------------- */ - -/* - * Function: mkAnonPipe - * - * Purpose: create an anonymous pipe with read and write ends being - * optionally (non-)inheritable. - */ -static BOOL -mkAnonPipe (HANDLE* pHandleIn, BOOL isInheritableIn, - HANDLE* pHandleOut, BOOL isInheritableOut) -{ - HANDLE hTemporaryIn = NULL; - HANDLE hTemporaryOut = NULL; - - /* Create the anon pipe with both ends inheritable */ - if (!CreatePipe(&hTemporaryIn, &hTemporaryOut, NULL, 0)) - { - maperrno(); - *pHandleIn = NULL; - *pHandleOut = NULL; - return FALSE; - } - - if (isInheritableIn) { - // SetHandleInformation requires at least Win2k - if (!SetHandleInformation(hTemporaryIn, - HANDLE_FLAG_INHERIT, - HANDLE_FLAG_INHERIT)) - { - maperrno(); - *pHandleIn = NULL; - *pHandleOut = NULL; - CloseHandle(hTemporaryIn); - CloseHandle(hTemporaryOut); - return FALSE; - } - } - *pHandleIn = hTemporaryIn; - - if (isInheritableOut) { - if (!SetHandleInformation(hTemporaryOut, - HANDLE_FLAG_INHERIT, - HANDLE_FLAG_INHERIT)) - { - maperrno(); - *pHandleIn = NULL; - *pHandleOut = NULL; - CloseHandle(hTemporaryIn); - CloseHandle(hTemporaryOut); - return FALSE; - } - } - *pHandleOut = hTemporaryOut; - - return TRUE; -} - -ProcHandle -runInteractiveProcess (wchar_t *cmd, wchar_t *workingDirectory, - void *environment, - int fdStdIn, int fdStdOut, int fdStdErr, - int *pfdStdInput, int *pfdStdOutput, int *pfdStdError, - int close_fds) -{ - STARTUPINFO sInfo; - PROCESS_INFORMATION pInfo; - HANDLE hStdInputRead = INVALID_HANDLE_VALUE; - HANDLE hStdInputWrite = INVALID_HANDLE_VALUE; - HANDLE hStdOutputRead = INVALID_HANDLE_VALUE; - HANDLE hStdOutputWrite = INVALID_HANDLE_VALUE; - HANDLE hStdErrorRead = INVALID_HANDLE_VALUE; - HANDLE hStdErrorWrite = INVALID_HANDLE_VALUE; - DWORD flags; - BOOL status; - BOOL inherit; - - ZeroMemory(&sInfo, sizeof(sInfo)); - sInfo.cb = sizeof(sInfo); - sInfo.dwFlags = STARTF_USESTDHANDLES; - - if (fdStdIn == -1) { - if (!mkAnonPipe(&hStdInputRead, TRUE, &hStdInputWrite, FALSE)) - goto cleanup_err; - sInfo.hStdInput = hStdInputRead; - } else if (fdStdIn == 0) { - // Don't duplicate stdin, as console handles cannot be - // duplicated and inherited. urg. - sInfo.hStdInput = GetStdHandle(STD_INPUT_HANDLE); - } else { - // The handle might not be inheritable, so duplicate it - status = DuplicateHandle(GetCurrentProcess(), - (HANDLE) _get_osfhandle(fdStdIn), - GetCurrentProcess(), &hStdInputRead, - 0, - TRUE, /* inheritable */ - DUPLICATE_SAME_ACCESS); - if (!status) goto cleanup_err; - sInfo.hStdInput = hStdInputRead; - } - - if (fdStdOut == -1) { - if (!mkAnonPipe(&hStdOutputRead, FALSE, &hStdOutputWrite, TRUE)) - goto cleanup_err; - sInfo.hStdOutput = hStdOutputWrite; - } else if (fdStdOut == 1) { - // Don't duplicate stdout, as console handles cannot be - // duplicated and inherited. urg. - sInfo.hStdOutput = GetStdHandle(STD_OUTPUT_HANDLE); - } else { - // The handle might not be inheritable, so duplicate it - status = DuplicateHandle(GetCurrentProcess(), - (HANDLE) _get_osfhandle(fdStdOut), - GetCurrentProcess(), &hStdOutputWrite, - 0, - TRUE, /* inheritable */ - DUPLICATE_SAME_ACCESS); - if (!status) goto cleanup_err; - sInfo.hStdOutput = hStdOutputWrite; - } - - if (fdStdErr == -1) { - if (!mkAnonPipe(&hStdErrorRead, TRUE, &hStdErrorWrite, TRUE)) - goto cleanup_err; - sInfo.hStdError = hStdErrorWrite; - } else if (fdStdErr == 2) { - // Don't duplicate stderr, as console handles cannot be - // duplicated and inherited. urg. - sInfo.hStdError = GetStdHandle(STD_ERROR_HANDLE); - } else { - /* The handle might not be inheritable, so duplicate it */ - status = DuplicateHandle(GetCurrentProcess(), - (HANDLE) _get_osfhandle(fdStdErr), - GetCurrentProcess(), &hStdErrorWrite, - 0, - TRUE, /* inheritable */ - DUPLICATE_SAME_ACCESS); - if (!status) goto cleanup_err; - sInfo.hStdError = hStdErrorWrite; - } - - if (sInfo.hStdInput != GetStdHandle(STD_INPUT_HANDLE) && - sInfo.hStdOutput != GetStdHandle(STD_OUTPUT_HANDLE) && - sInfo.hStdError != GetStdHandle(STD_ERROR_HANDLE)) - flags = CREATE_NO_WINDOW; // Run without console window only when both output and error are redirected - else - flags = 0; - - // See #3231 - if (close_fds && fdStdIn == 0 && fdStdOut == 1 && fdStdErr == 2) { - inherit = FALSE; - } else { - inherit = TRUE; - } - - if (!CreateProcess(NULL, cmd, NULL, NULL, inherit, flags, environment, workingDirectory, &sInfo, &pInfo)) - { - goto cleanup_err; - } - CloseHandle(pInfo.hThread); - - // Close the ends of the pipes that were inherited by the - // child process. This is important, otherwise we won't see - // EOF on these pipes when the child process exits. - if (hStdInputRead != INVALID_HANDLE_VALUE) CloseHandle(hStdInputRead); - if (hStdOutputWrite != INVALID_HANDLE_VALUE) CloseHandle(hStdOutputWrite); - if (hStdErrorWrite != INVALID_HANDLE_VALUE) CloseHandle(hStdErrorWrite); - - *pfdStdInput = _open_osfhandle((intptr_t) hStdInputWrite, _O_WRONLY); - *pfdStdOutput = _open_osfhandle((intptr_t) hStdOutputRead, _O_RDONLY); - *pfdStdError = _open_osfhandle((intptr_t) hStdErrorRead, _O_RDONLY); - - return (int) pInfo.hProcess; - -cleanup_err: - if (hStdInputRead != INVALID_HANDLE_VALUE) CloseHandle(hStdInputRead); - if (hStdInputWrite != INVALID_HANDLE_VALUE) CloseHandle(hStdInputWrite); - if (hStdOutputRead != INVALID_HANDLE_VALUE) CloseHandle(hStdOutputRead); - if (hStdOutputWrite != INVALID_HANDLE_VALUE) CloseHandle(hStdOutputWrite); - if (hStdErrorRead != INVALID_HANDLE_VALUE) CloseHandle(hStdErrorRead); - if (hStdErrorWrite != INVALID_HANDLE_VALUE) CloseHandle(hStdErrorWrite); - maperrno(); - return -1; -} - -int -terminateProcess (ProcHandle handle) -{ - if (!TerminateProcess((HANDLE) handle, 1)) { - maperrno(); - return -1; - } - return 0; -} - -int -getProcessExitCode (ProcHandle handle, int *pExitCode) -{ - *pExitCode = 0; - - if (WaitForSingleObject((HANDLE) handle, 1) == WAIT_OBJECT_0) - { - if (GetExitCodeProcess((HANDLE) handle, (DWORD *) pExitCode) == 0) - { - maperrno(); - return -1; - } - return 1; - } - - return 0; -} - -int -waitForProcess (ProcHandle handle, int *pret) -{ - DWORD retCode; - - if (WaitForSingleObject((HANDLE) handle, INFINITE) == WAIT_OBJECT_0) - { - if (GetExitCodeProcess((HANDLE) handle, &retCode) == 0) - { - maperrno(); - return -1; - } - *pret = retCode; - return 0; - } - - maperrno(); - return -1; -} - -#endif /* Win32 */ +/* ---------------------------------------------------------------------------- + (c) The University of Glasgow 2004 + + Support for System.Process + ------------------------------------------------------------------------- */ + +#if defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32) +#define UNICODE +#endif + +/* XXX This is a nasty hack; should put everything necessary in this package */ +#include "HsBase.h" +#include "Rts.h" + +#include "runProcess.h" + +#if !(defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32)) + +#include "execvpe.h" + +/* ---------------------------------------------------------------------------- + UNIX versions + ------------------------------------------------------------------------- */ + +static long max_fd = 0; + +// Rts internal API, not exposed in a public header file: +extern void blockUserSignals(void); +extern void unblockUserSignals(void); + +ProcHandle +runInteractiveProcess (char *const args[], + char *workingDirectory, char **environment, + int fdStdIn, int fdStdOut, int fdStdErr, + int *pfdStdInput, int *pfdStdOutput, int *pfdStdError, + int set_inthandler, long inthandler, + int set_quithandler, long quithandler, + int flags) +{ + int close_fds = ((flags & RUN_PROCESS_IN_CLOSE_FDS) != 0); + int pid; + int fdStdInput[2], fdStdOutput[2], fdStdError[2]; + int r; + struct sigaction dfl; + + // Ordering matters here, see below [Note #431]. + if (fdStdIn == -1) { + r = pipe(fdStdInput); + if (r == -1) { + sysErrorBelch("runInteractiveProcess: pipe"); + return -1; + } + + } + if (fdStdOut == -1) { + r = pipe(fdStdOutput); + if (r == -1) { + sysErrorBelch("runInteractiveProcess: pipe"); + return -1; + } + } + if (fdStdErr == -1) { + r = pipe(fdStdError); + if (r == -1) { + sysErrorBelch("runInteractiveProcess: pipe"); + return -1; + } + } + + // Block signals with Haskell handlers. The danger here is that + // with the threaded RTS, a signal arrives in the child process, + // the RTS writes the signal information into the pipe (which is + // shared between parent and child), and the parent behaves as if + // the signal had been raised. + blockUserSignals(); + + // See #4074. Sometimes fork() gets interrupted by the timer + // signal and keeps restarting indefinitely. + stopTimer(); + + switch(pid = fork()) + { + case -1: + unblockUserSignals(); +#if __GLASGOW_HASKELL__ > 612 + startTimer(); +#endif + if (fdStdIn == -1) { + close(fdStdInput[0]); + close(fdStdInput[1]); + } + if (fdStdOut == -1) { + close(fdStdOutput[0]); + close(fdStdOutput[1]); + } + if (fdStdErr == -1) { + close(fdStdError[0]); + close(fdStdError[1]); + } + return -1; + + case 0: + { + // WARNING! we are now in the child of vfork(), so any memory + // we modify below will also be seen in the parent process. + + if ((flags & RUN_PROCESS_IN_NEW_GROUP) != 0) { + setpgid(0, 0); + } + + unblockUserSignals(); + + if (workingDirectory) { + if (chdir (workingDirectory) < 0) { + // See #1593. The convention for the exit code when + // exec() fails seems to be 127 (gleened from C's + // system()), but there's no equivalent convention for + // chdir(), so I'm picking 126 --SimonM. + _exit(126); + } + } + + // [Note #431]: Ordering matters here. If any of the FDs + // 0,1,2 were initially closed, then our pipes may have used + // these FDs. So when we dup2 the pipe FDs down to 0,1,2, we + // must do it in that order, otherwise we could overwrite an + // FD that we need later. + + if (fdStdIn == -1) { + if (fdStdInput[0] != STDIN_FILENO) { + dup2 (fdStdInput[0], STDIN_FILENO); + close(fdStdInput[0]); + } + close(fdStdInput[1]); + } else { + dup2(fdStdIn, STDIN_FILENO); + } + + if (fdStdOut == -1) { + if (fdStdOutput[1] != STDOUT_FILENO) { + dup2 (fdStdOutput[1], STDOUT_FILENO); + close(fdStdOutput[1]); + } + close(fdStdOutput[0]); + } else { + dup2(fdStdOut, STDOUT_FILENO); + } + + if (fdStdErr == -1) { + if (fdStdError[1] != STDERR_FILENO) { + dup2 (fdStdError[1], STDERR_FILENO); + close(fdStdError[1]); + } + close(fdStdError[0]); + } else { + dup2(fdStdErr, STDERR_FILENO); + } + + if (close_fds) { + int i; + if (max_fd == 0) { +#if HAVE_SYSCONF + max_fd = sysconf(_SC_OPEN_MAX); + if (max_fd == -1) { + max_fd = 256; + } +#else + max_fd = 256; +#endif + } + for (i = 3; i < max_fd; i++) { + close(i); + } + } + + /* Set the SIGINT/SIGQUIT signal handlers in the child, if requested + */ + (void)sigemptyset(&dfl.sa_mask); + dfl.sa_flags = 0; + if (set_inthandler) { + dfl.sa_handler = (void *)inthandler; + (void)sigaction(SIGINT, &dfl, NULL); + } + if (set_quithandler) { + dfl.sa_handler = (void *)quithandler; + (void)sigaction(SIGQUIT, &dfl, NULL); + } + + /* the child */ + if (environment) { + execvpe(args[0], args, environment); + } else { + execvp(args[0], args); + } + } + _exit(127); + + default: + if ((flags & RUN_PROCESS_IN_NEW_GROUP) != 0) { + setpgid(pid, pid); + } + if (fdStdIn == -1) { + close(fdStdInput[0]); + fcntl(fdStdInput[1], F_SETFD, FD_CLOEXEC); + *pfdStdInput = fdStdInput[1]; + } + if (fdStdOut == -1) { + close(fdStdOutput[1]); + fcntl(fdStdOutput[0], F_SETFD, FD_CLOEXEC); + *pfdStdOutput = fdStdOutput[0]; + } + if (fdStdErr == -1) { + close(fdStdError[1]); + fcntl(fdStdError[0], F_SETFD, FD_CLOEXEC); + *pfdStdError = fdStdError[0]; + } + break; + } + unblockUserSignals(); + startTimer(); + + return pid; +} + +int +terminateProcess (ProcHandle handle) +{ + return (kill(handle, SIGTERM) == 0); +} + +int +getProcessExitCode (ProcHandle handle, int *pExitCode) +{ + int wstat, res; + + *pExitCode = 0; + + if ((res = waitpid(handle, &wstat, WNOHANG)) > 0) + { + if (WIFEXITED(wstat)) + { + *pExitCode = WEXITSTATUS(wstat); + return 1; + } + else + if (WIFSIGNALED(wstat)) + { + errno = EINTR; + return -1; + } + else + { + /* This should never happen */ + } + } + + if (res == 0) return 0; + + if (errno == ECHILD) + { + *pExitCode = 0; + return 1; + } + + return -1; +} + +int waitForProcess (ProcHandle handle, int *pret) +{ + int wstat; + + if (waitpid(handle, &wstat, 0) < 0) + { + return -1; + } + + if (WIFEXITED(wstat)) { + *pret = WEXITSTATUS(wstat); + return 0; + } + else + if (WIFSIGNALED(wstat)) + { + *pret = wstat; + return 0; + } + else + { + /* This should never happen */ + } + + return -1; +} + +#else +/* ---------------------------------------------------------------------------- + Win32 versions + ------------------------------------------------------------------------- */ + +/* -------------------- WINDOWS VERSION --------------------- */ + +/* + * Function: mkAnonPipe + * + * Purpose: create an anonymous pipe with read and write ends being + * optionally (non-)inheritable. + */ +static BOOL +mkAnonPipe (HANDLE* pHandleIn, BOOL isInheritableIn, + HANDLE* pHandleOut, BOOL isInheritableOut) +{ + HANDLE hTemporaryIn = NULL; + HANDLE hTemporaryOut = NULL; + + /* Create the anon pipe with both ends inheritable */ + if (!CreatePipe(&hTemporaryIn, &hTemporaryOut, NULL, 0)) + { + maperrno(); + *pHandleIn = NULL; + *pHandleOut = NULL; + return FALSE; + } + + if (isInheritableIn) { + // SetHandleInformation requires at least Win2k + if (!SetHandleInformation(hTemporaryIn, + HANDLE_FLAG_INHERIT, + HANDLE_FLAG_INHERIT)) + { + maperrno(); + *pHandleIn = NULL; + *pHandleOut = NULL; + CloseHandle(hTemporaryIn); + CloseHandle(hTemporaryOut); + return FALSE; + } + } + *pHandleIn = hTemporaryIn; + + if (isInheritableOut) { + if (!SetHandleInformation(hTemporaryOut, + HANDLE_FLAG_INHERIT, + HANDLE_FLAG_INHERIT)) + { + maperrno(); + *pHandleIn = NULL; + *pHandleOut = NULL; + CloseHandle(hTemporaryIn); + CloseHandle(hTemporaryOut); + return FALSE; + } + } + *pHandleOut = hTemporaryOut; + + return TRUE; +} + +ProcHandle +runInteractiveProcess (wchar_t *cmd, wchar_t *workingDirectory, + wchar_t *environment, + int fdStdIn, int fdStdOut, int fdStdErr, + int *pfdStdInput, int *pfdStdOutput, int *pfdStdError, + int flags) +{ + STARTUPINFO sInfo; + PROCESS_INFORMATION pInfo; + HANDLE hStdInputRead = INVALID_HANDLE_VALUE; + HANDLE hStdInputWrite = INVALID_HANDLE_VALUE; + HANDLE hStdOutputRead = INVALID_HANDLE_VALUE; + HANDLE hStdOutputWrite = INVALID_HANDLE_VALUE; + HANDLE hStdErrorRead = INVALID_HANDLE_VALUE; + HANDLE hStdErrorWrite = INVALID_HANDLE_VALUE; + BOOL close_fds = ((flags & RUN_PROCESS_IN_CLOSE_FDS) != 0); + // We always pass a wide environment block, so we MUST set this flag + DWORD dwFlags = CREATE_UNICODE_ENVIRONMENT; + BOOL status; + BOOL inherit; + + ZeroMemory(&sInfo, sizeof(sInfo)); + sInfo.cb = sizeof(sInfo); + sInfo.dwFlags = STARTF_USESTDHANDLES; + + if (fdStdIn == -1) { + if (!mkAnonPipe(&hStdInputRead, TRUE, &hStdInputWrite, FALSE)) + goto cleanup_err; + sInfo.hStdInput = hStdInputRead; + } else if (fdStdIn == 0) { + // Don't duplicate stdin, as console handles cannot be + // duplicated and inherited. urg. + sInfo.hStdInput = GetStdHandle(STD_INPUT_HANDLE); + } else { + // The handle might not be inheritable, so duplicate it + status = DuplicateHandle(GetCurrentProcess(), + (HANDLE) _get_osfhandle(fdStdIn), + GetCurrentProcess(), &hStdInputRead, + 0, + TRUE, /* inheritable */ + DUPLICATE_SAME_ACCESS); + if (!status) goto cleanup_err; + sInfo.hStdInput = hStdInputRead; + } + + if (fdStdOut == -1) { + if (!mkAnonPipe(&hStdOutputRead, FALSE, &hStdOutputWrite, TRUE)) + goto cleanup_err; + sInfo.hStdOutput = hStdOutputWrite; + } else if (fdStdOut == 1) { + // Don't duplicate stdout, as console handles cannot be + // duplicated and inherited. urg. + sInfo.hStdOutput = GetStdHandle(STD_OUTPUT_HANDLE); + } else { + // The handle might not be inheritable, so duplicate it + status = DuplicateHandle(GetCurrentProcess(), + (HANDLE) _get_osfhandle(fdStdOut), + GetCurrentProcess(), &hStdOutputWrite, + 0, + TRUE, /* inheritable */ + DUPLICATE_SAME_ACCESS); + if (!status) goto cleanup_err; + sInfo.hStdOutput = hStdOutputWrite; + } + + if (fdStdErr == -1) { + if (!mkAnonPipe(&hStdErrorRead, TRUE, &hStdErrorWrite, TRUE)) + goto cleanup_err; + sInfo.hStdError = hStdErrorWrite; + } else if (fdStdErr == 2) { + // Don't duplicate stderr, as console handles cannot be + // duplicated and inherited. urg. + sInfo.hStdError = GetStdHandle(STD_ERROR_HANDLE); + } else { + /* The handle might not be inheritable, so duplicate it */ + status = DuplicateHandle(GetCurrentProcess(), + (HANDLE) _get_osfhandle(fdStdErr), + GetCurrentProcess(), &hStdErrorWrite, + 0, + TRUE, /* inheritable */ + DUPLICATE_SAME_ACCESS); + if (!status) goto cleanup_err; + sInfo.hStdError = hStdErrorWrite; + } + + if (sInfo.hStdInput != GetStdHandle(STD_INPUT_HANDLE) && + sInfo.hStdOutput != GetStdHandle(STD_OUTPUT_HANDLE) && + sInfo.hStdError != GetStdHandle(STD_ERROR_HANDLE) && + (flags & RUN_PROCESS_IN_NEW_GROUP) == 0) + dwFlags |= CREATE_NO_WINDOW; // Run without console window only when both output and error are redirected + + // See #3231 + if (close_fds && fdStdIn == 0 && fdStdOut == 1 && fdStdErr == 2) { + inherit = FALSE; + } else { + inherit = TRUE; + } + + if ((flags & RUN_PROCESS_IN_NEW_GROUP) != 0) { + dwFlags |= CREATE_NEW_PROCESS_GROUP; + } + + if (!CreateProcess(NULL, cmd, NULL, NULL, inherit, dwFlags, environment, workingDirectory, &sInfo, &pInfo)) + { + goto cleanup_err; + } + CloseHandle(pInfo.hThread); + + // Close the ends of the pipes that were inherited by the + // child process. This is important, otherwise we won't see + // EOF on these pipes when the child process exits. + if (hStdInputRead != INVALID_HANDLE_VALUE) CloseHandle(hStdInputRead); + if (hStdOutputWrite != INVALID_HANDLE_VALUE) CloseHandle(hStdOutputWrite); + if (hStdErrorWrite != INVALID_HANDLE_VALUE) CloseHandle(hStdErrorWrite); + + *pfdStdInput = _open_osfhandle((intptr_t) hStdInputWrite, _O_WRONLY); + *pfdStdOutput = _open_osfhandle((intptr_t) hStdOutputRead, _O_RDONLY); + *pfdStdError = _open_osfhandle((intptr_t) hStdErrorRead, _O_RDONLY); + + return pInfo.hProcess; + +cleanup_err: + if (hStdInputRead != INVALID_HANDLE_VALUE) CloseHandle(hStdInputRead); + if (hStdInputWrite != INVALID_HANDLE_VALUE) CloseHandle(hStdInputWrite); + if (hStdOutputRead != INVALID_HANDLE_VALUE) CloseHandle(hStdOutputRead); + if (hStdOutputWrite != INVALID_HANDLE_VALUE) CloseHandle(hStdOutputWrite); + if (hStdErrorRead != INVALID_HANDLE_VALUE) CloseHandle(hStdErrorRead); + if (hStdErrorWrite != INVALID_HANDLE_VALUE) CloseHandle(hStdErrorWrite); + maperrno(); + return NULL; +} + +int +terminateProcess (ProcHandle handle) +{ + if (!TerminateProcess((HANDLE) handle, 1)) { + maperrno(); + return -1; + } + return 0; +} + +int +getProcessExitCode (ProcHandle handle, int *pExitCode) +{ + *pExitCode = 0; + + if (WaitForSingleObject((HANDLE) handle, 1) == WAIT_OBJECT_0) + { + if (GetExitCodeProcess((HANDLE) handle, (DWORD *) pExitCode) == 0) + { + maperrno(); + return -1; + } + return 1; + } + + return 0; +} + +int +waitForProcess (ProcHandle handle, int *pret) +{ + DWORD retCode; + + if (WaitForSingleObject((HANDLE) handle, INFINITE) == WAIT_OBJECT_0) + { + if (GetExitCodeProcess((HANDLE) handle, &retCode) == 0) + { + maperrno(); + return -1; + } + *pret = retCode; + return 0; + } + + maperrno(); + return -1; +} + +#endif /* Win32 */ diff -Nru ghc-7.0.3/libraries/process/ghc.mk ghc-7.2.1/libraries/process/ghc.mk --- ghc-7.0.3/libraries/process/ghc.mk 2011-03-26 18:10:45.000000000 +0000 +++ ghc-7.2.1/libraries/process/ghc.mk 2011-08-07 17:11:00.000000000 +0000 @@ -1,3 +1,4 @@ libraries/process_PACKAGE = process libraries/process_dist-install_GROUP = libraries +$(if $(filter process,$(PACKAGES_STAGE0)),$(eval $(call build-package,libraries/process,dist-boot,0))) $(eval $(call build-package,libraries/process,dist-install,$(if $(filter process,$(STAGE2_PACKAGES)),2,1))) diff -Nru ghc-7.0.3/libraries/process/.gitignore ghc-7.2.1/libraries/process/.gitignore --- ghc-7.0.3/libraries/process/.gitignore 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/process/.gitignore 2011-08-07 17:10:11.000000000 +0000 @@ -0,0 +1,14 @@ +# Specific generated files +GNUmakefile +autom4te.cache/ +config.log +config.status +configure +dist-install/ +ghc.mk +include/HsProcessConfig.h +include/HsProcessConfig.h.in +tests/exitminus1 +tests/exitminus1.o +tests/foo1.txt +tests/foo2.txt diff -Nru ghc-7.0.3/libraries/process/include/processFlags.h ghc-7.2.1/libraries/process/include/processFlags.h --- ghc-7.0.3/libraries/process/include/processFlags.h 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/process/include/processFlags.h 2011-08-07 17:10:11.000000000 +0000 @@ -0,0 +1,8 @@ +/* ---------------------------------------------------------------------------- + (c) The University of Glasgow 2004 + + Flags used in runProcess.c and for System.Process.Internals + ------------------------------------------------------------------------- */ + +#define RUN_PROCESS_IN_CLOSE_FDS 0x1 +#define RUN_PROCESS_IN_NEW_GROUP 0x2 diff -Nru ghc-7.0.3/libraries/process/include/runProcess.h ghc-7.2.1/libraries/process/include/runProcess.h --- ghc-7.0.3/libraries/process/include/runProcess.h 2011-03-26 18:10:15.000000000 +0000 +++ ghc-7.2.1/libraries/process/include/runProcess.h 2011-08-07 17:10:11.000000000 +0000 @@ -1,75 +1,77 @@ -/* ---------------------------------------------------------------------------- - (c) The University of Glasgow 2004 - - Interface for code in runProcess.c (providing support for System.Process) - ------------------------------------------------------------------------- */ - -#include "HsProcessConfig.h" -// Otherwise these clash with similar definitions from other packages: -#undef PACKAGE_BUGREPORT -#undef PACKAGE_NAME -#undef PACKAGE_STRING -#undef PACKAGE_TARNAME -#undef PACKAGE_VERSION - -#if defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32) -#define UNICODE -#include -#include -#endif - -#include -#include - -#ifdef HAVE_FCNTL_H -#include -#endif - -#ifdef HAVE_VFORK_H -#include -#endif - -#ifdef HAVE_VFORK -#define fork vfork -#endif - -#ifdef HAVE_SIGNAL_H -#include -#endif - -#if !(defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32)) -typedef pid_t ProcHandle; -#else -// Should really be intptr_t, but we don't have that type on the Haskell side -typedef long ProcHandle; -#endif - -#if !(defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32)) - -extern ProcHandle runInteractiveProcess( char *const args[], - char *workingDirectory, - char **environment, - int fdStdIn, int fdStdOut, int fdStdErr, - int *pfdStdInput, - int *pfdStdOutput, - int *pfdStdError, - int set_inthandler, long inthandler, - int set_quithandler, long quithandler, - int close_fds); - -#else - -extern ProcHandle runInteractiveProcess( wchar_t *cmd, - wchar_t *workingDirectory, - void *environment, - int fdStdIn, int fdStdOut, int fdStdErr, - int *pfdStdInput, - int *pfdStdOutput, - int *pfdStdError, - int close_fds); - -#endif - -extern int terminateProcess( ProcHandle handle ); -extern int getProcessExitCode( ProcHandle handle, int *pExitCode ); -extern int waitForProcess( ProcHandle handle, int *ret ); +/* ---------------------------------------------------------------------------- + (c) The University of Glasgow 2004 + + Interface for code in runProcess.c (providing support for System.Process) + ------------------------------------------------------------------------- */ + +#include "HsProcessConfig.h" +// Otherwise these clash with similar definitions from other packages: +#undef PACKAGE_BUGREPORT +#undef PACKAGE_NAME +#undef PACKAGE_STRING +#undef PACKAGE_TARNAME +#undef PACKAGE_VERSION + +#if defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32) +#define UNICODE +#include +#include +#endif + +#include +#include + +#ifdef HAVE_FCNTL_H +#include +#endif + +#ifdef HAVE_VFORK_H +#include +#endif + +#ifdef HAVE_VFORK +#define fork vfork +#endif + +#ifdef HAVE_SIGNAL_H +#include +#endif + +#if !(defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32)) +typedef pid_t ProcHandle; +#else +// Should really be intptr_t, but we don't have that type on the Haskell side +typedef PHANDLE ProcHandle; +#endif + +#include "processFlags.h" + +#if !(defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32)) + +extern ProcHandle runInteractiveProcess( char *const args[], + char *workingDirectory, + char **environment, + int fdStdIn, int fdStdOut, int fdStdErr, + int *pfdStdInput, + int *pfdStdOutput, + int *pfdStdError, + int set_inthandler, long inthandler, + int set_quithandler, long quithandler, + int flags); + +#else + +extern ProcHandle runInteractiveProcess( wchar_t *cmd, + wchar_t *workingDirectory, + wchar_t *environment, + int fdStdIn, int fdStdOut, int fdStdErr, + int *pfdStdInput, + int *pfdStdOutput, + int *pfdStdError, + int flags); + +#endif + +extern int terminateProcess( ProcHandle handle ); +extern int getProcessExitCode( ProcHandle handle, int *pExitCode ); +extern int waitForProcess( ProcHandle handle, int *ret ); diff -Nru ghc-7.0.3/libraries/process/process.cabal ghc-7.2.1/libraries/process/process.cabal --- ghc-7.0.3/libraries/process/process.cabal 2011-03-26 18:10:15.000000000 +0000 +++ ghc-7.2.1/libraries/process/process.cabal 2011-08-07 17:10:11.000000000 +0000 @@ -1,5 +1,5 @@ name: process -version: 1.0.1.5 +version: 1.1.0.0 license: BSD3 license-file: LICENSE maintainer: libraries@haskell.org @@ -18,8 +18,8 @@ cabal-version: >=1.6 source-repository head - type: darcs - location: http://darcs.haskell.org/packages/process/ + type: git + location: http://darcs.haskell.org/packages/process.git/ flag base4 @@ -39,7 +39,10 @@ install-includes: runProcess.h HsProcessConfig.h - if !os(windows) + if os(windows) + build-depends: Win32 >=2.2.0.0 + extra-libraries: kernel32 + else build-depends: unix } diff -Nru ghc-7.0.3/libraries/process/System/Process/Internals.hs ghc-7.2.1/libraries/process/System/Process/Internals.hs --- ghc-7.0.3/libraries/process/System/Process/Internals.hs 2011-03-26 18:10:14.000000000 +0000 +++ ghc-7.2.1/libraries/process/System/Process/Internals.hs 2011-08-07 17:10:11.000000000 +0000 @@ -31,13 +31,10 @@ #if !defined(mingw32_HOST_OS) && !defined(__MINGW32__) pPrPr_disableITimers, c_execvpe, ignoreSignal, defaultSignal, -#else -# ifdef __GLASGOW_HASKELL__ - translate, -# endif #endif #endif withFilePathException, withCEnvironment, + translate, #ifndef __HUGS__ fdToHandle, @@ -78,6 +75,7 @@ import Data.Typeable #if defined(mingw32_HOST_OS) import GHC.IO.IOMode +import System.Win32.DebugApi (PHANDLE) #endif #else import GHC.IOBase ( haFD, FD, IOException(..) ) @@ -107,6 +105,7 @@ #endif #include "HsProcessConfig.h" +#include "processFlags.h" #ifndef __HUGS__ -- ---------------------------------------------------------------------------- @@ -138,6 +137,9 @@ type PHANDLE = CPid +throwErrnoIfBadPHandle :: String -> IO PHANDLE -> IO PHANDLE +throwErrnoIfBadPHandle = throwErrnoIfMinus1 + mkProcessHandle :: PHANDLE -> IO ProcessHandle mkProcessHandle p = do m <- newMVar (OpenHandle p) @@ -148,7 +150,8 @@ #else -type PHANDLE = Word32 +throwErrnoIfBadPHandle :: String -> IO PHANDLE -> IO PHANDLE +throwErrnoIfBadPHandle = throwErrnoIfNull -- On Windows, we have to close this HANDLE when it is no longer required, -- hence we add a finalizer to it, using an IORef as the box on which to @@ -179,13 +182,14 @@ -- ---------------------------------------------------------------------------- data CreateProcess = CreateProcess{ - cmdspec :: CmdSpec, -- ^ Executable & arguments, or shell command - cwd :: Maybe FilePath, -- ^ Optional path to the working directory for the new process - env :: Maybe [(String,String)], -- ^ Optional environment (otherwise inherit from the current process) - std_in :: StdStream, -- ^ How to determine stdin - std_out :: StdStream, -- ^ How to determine stdout - std_err :: StdStream, -- ^ How to determine stderr - close_fds :: Bool -- ^ Close all file descriptors except stdin, stdout and stderr in the new process (on Windows, only works if std_in, std_out, and std_err are all Inherit) + cmdspec :: CmdSpec, -- ^ Executable & arguments, or shell command + cwd :: Maybe FilePath, -- ^ Optional path to the working directory for the new process + env :: Maybe [(String,String)], -- ^ Optional environment (otherwise inherit from the current process) + std_in :: StdStream, -- ^ How to determine stdin + std_out :: StdStream, -- ^ How to determine stdout + std_err :: StdStream, -- ^ How to determine stderr + close_fds :: Bool, -- ^ Close all file descriptors except stdin, stdout and stderr in the new process (on Windows, only works if std_in, std_out, and std_err are all Inherit) + create_group :: Bool -- ^ Create a new process group } data CmdSpec @@ -222,7 +226,8 @@ std_in = mb_stdin, std_out = mb_stdout, std_err = mb_stderr, - close_fds = mb_close_fds } + close_fds = mb_close_fds, + create_group = mb_create_group } mb_sigint mb_sigquit = do let (cmd,args) = commandToProcess cmdsp @@ -231,8 +236,8 @@ alloca $ \ pfdStdOutput -> alloca $ \ pfdStdError -> maybeWith withCEnvironment mb_env $ \pEnv -> - maybeWith withCString mb_cwd $ \pWorkDir -> - withMany withCString (cmd:args) $ \cstrs -> + maybeWith withFilePath mb_cwd $ \pWorkDir -> + withMany withFilePath (cmd:args) $ \cstrs -> withArray0 nullPtr cstrs $ \pargs -> do fdin <- mbFd fun fd_stdin mb_stdin @@ -258,7 +263,8 @@ fdin fdout fderr pfdStdInput pfdStdOutput pfdStdError set_int inthand set_quit quithand - (if mb_close_fds then 1 else 0) + ((if mb_close_fds then RUN_PROCESS_IN_CLOSE_FDS else 0) + .|.(if mb_create_group then RUN_PROCESS_IN_NEW_GROUP else 0)) hndStdInput <- mbPipe mb_stdin pfdStdInput WriteMode hndStdOutput <- mbPipe mb_stdout pfdStdOutput ReadMode @@ -286,7 +292,7 @@ -> CLong -- SIGINT handler -> CInt -- non-zero: set child's SIGQUIT handler -> CLong -- SIGQUIT handler - -> CInt -- close_fds + -> CInt -- flags -> IO PHANDLE #endif /* __GLASGOW_HASKELL__ */ @@ -305,7 +311,8 @@ std_in = mb_stdin, std_out = mb_stdout, std_err = mb_stderr, - close_fds = mb_close_fds } + close_fds = mb_close_fds, + create_group = mb_create_group } _ignored_mb_sigint _ignored_mb_sigquit = do (cmd, cmdline) <- commandToProcess cmdsp @@ -332,11 +339,12 @@ -- the C code. Also the MVar will be cheaper when not running -- the threaded RTS. proc_handle <- withMVar runInteractiveProcess_lock $ \_ -> - throwErrnoIfMinus1 fun $ + throwErrnoIfBadPHandle fun $ c_runInteractiveProcess pcmdline pWorkDir pEnv fdin fdout fderr pfdStdInput pfdStdOutput pfdStdError - (if mb_close_fds then 1 else 0) + ((if mb_close_fds then RUN_PROCESS_IN_CLOSE_FDS else 0) + .|.(if mb_create_group then RUN_PROCESS_IN_NEW_GROUP else 0)) hndStdInput <- mbPipe mb_stdin pfdStdInput WriteMode hndStdOutput <- mbPipe mb_stdout pfdStdOutput ReadMode @@ -349,92 +357,23 @@ runInteractiveProcess_lock :: MVar () runInteractiveProcess_lock = unsafePerformIO $ newMVar () -foreign import ccall unsafe "runInteractiveProcess" +foreign import ccall unsafe "runInteractiveProcess" c_runInteractiveProcess :: CWString -> CWString - -> Ptr () + -> Ptr CWString -> FD -> FD -> FD -> Ptr FD -> Ptr FD -> Ptr FD - -> CInt -- close_fds + -> CInt -- flags -> IO PHANDLE - --- ------------------------------------------------------------------------ --- Passing commands to the OS on Windows - -{- -On Windows this is tricky. We use CreateProcess, passing a single -command-line string (lpCommandLine) as its argument. (CreateProcess -is well documented on http://msdn.microsoft.com.) - - - It parses the beginning of the string to find the command. If the - file name has embedded spaces, it must be quoted, using double - quotes thus - "foo\this that\cmd" arg1 arg2 - - - The invoked command can in turn access the entire lpCommandLine string, - and the C runtime does indeed do so, parsing it to generate the - traditional argument vector argv[0], argv[1], etc. It does this - using a complex and arcane set of rules which are described here: - - http://msdn.microsoft.com/library/default.asp?url=/library/en-us/vccelng/htm/progs_12.asp - - (if this URL stops working, you might be able to find it by - searching for "Parsing C Command-Line Arguments" on MSDN. Also, - the code in the Microsoft C runtime that does this translation - is shipped with VC++). - -Our goal in runProcess is to take a command filename and list of -arguments, and construct a string which inverts the translatsions -described above, such that the program at the other end sees exactly -the same arguments in its argv[] that we passed to rawSystem. - -This inverse translation is implemented by 'translate' below. - -Here are some pages that give informations on Windows-related -limitations and deviations from Unix conventions: - - http://support.microsoft.com/default.aspx?scid=kb;en-us;830473 - Command lines and environment variables effectively limited to 8191 - characters on Win XP, 2047 on NT/2000 (probably even less on Win 9x): - - http://www.microsoft.com/windowsxp/home/using/productdoc/en/default.asp?url=/WINDOWSXP/home/using/productdoc/en/percent.asp - Command-line substitution under Windows XP. IIRC these facilities (or at - least a large subset of them) are available on Win NT and 2000. Some - might be available on Win 9x. - - http://www.microsoft.com/windowsxp/home/using/productdoc/en/default.asp?url=/WINDOWSXP/home/using/productdoc/en/Cmd.asp - How CMD.EXE processes command lines. - - -Note: CreateProcess does have a separate argument (lpApplicationName) -with which you can specify the command, but we have to slap the -command into lpCommandLine anyway, so that argv[0] is what a C program -expects (namely the application name). So it seems simpler to just -use lpCommandLine alone, which CreateProcess supports. --} - --- Translate command-line arguments for passing to CreateProcess(). -translate :: String -> String -translate str = '"' : snd (foldr escape (True,"\"") str) - where escape '"' (b, str) = (True, '\\' : '"' : str) - escape '\\' (True, str) = (True, '\\' : '\\' : str) - escape '\\' (False, str) = (False, '\\' : str) - escape c (b, str) = (False, c : str) - -- See long comment above for what this function is trying to do. - -- - -- The Bool passed back along the string is True iff the - -- rest of the string is a sequence of backslashes followed by - -- a double quote. +#endif #endif /* __GLASGOW_HASKELL__ */ -#endif - fd_stdin, fd_stdout, fd_stderr :: FD fd_stdin = 0 fd_stdout = 1 @@ -571,6 +510,79 @@ #endif /* __HUGS__ */ +-- ------------------------------------------------------------------------ +-- Escaping commands for shells + +{- +On Windows we also use this for running commands. We use CreateProcess, +passing a single command-line string (lpCommandLine) as its argument. +(CreateProcess is well documented on http://msdn.microsoft.com.) + + - It parses the beginning of the string to find the command. If the + file name has embedded spaces, it must be quoted, using double + quotes thus + "foo\this that\cmd" arg1 arg2 + + - The invoked command can in turn access the entire lpCommandLine string, + and the C runtime does indeed do so, parsing it to generate the + traditional argument vector argv[0], argv[1], etc. It does this + using a complex and arcane set of rules which are described here: + + http://msdn.microsoft.com/library/default.asp?url=/library/en-us/vccelng/htm/progs_12.asp + + (if this URL stops working, you might be able to find it by + searching for "Parsing C Command-Line Arguments" on MSDN. Also, + the code in the Microsoft C runtime that does this translation + is shipped with VC++). + +Our goal in runProcess is to take a command filename and list of +arguments, and construct a string which inverts the translatsions +described above, such that the program at the other end sees exactly +the same arguments in its argv[] that we passed to rawSystem. + +This inverse translation is implemented by 'translate' below. + +Here are some pages that give informations on Windows-related +limitations and deviations from Unix conventions: + + http://support.microsoft.com/default.aspx?scid=kb;en-us;830473 + Command lines and environment variables effectively limited to 8191 + characters on Win XP, 2047 on NT/2000 (probably even less on Win 9x): + + http://www.microsoft.com/windowsxp/home/using/productdoc/en/default.asp?url=/WINDOWSXP/home/using/productdoc/en/percent.asp + Command-line substitution under Windows XP. IIRC these facilities (or at + least a large subset of them) are available on Win NT and 2000. Some + might be available on Win 9x. + + http://www.microsoft.com/windowsxp/home/using/productdoc/en/default.asp?url=/WINDOWSXP/home/using/productdoc/en/Cmd.asp + How CMD.EXE processes command lines. + + +Note: CreateProcess does have a separate argument (lpApplicationName) +with which you can specify the command, but we have to slap the +command into lpCommandLine anyway, so that argv[0] is what a C program +expects (namely the application name). So it seems simpler to just +use lpCommandLine alone, which CreateProcess supports. +-} + +translate :: String -> String +#if mingw32_HOST_OS +translate str = '"' : snd (foldr escape (True,"\"") str) + where escape '"' (b, str) = (True, '\\' : '"' : str) + escape '\\' (True, str) = (True, '\\' : '\\' : str) + escape '\\' (False, str) = (False, '\\' : str) + escape c (b, str) = (False, c : str) + -- See long comment above for what this function is trying to do. + -- + -- The Bool passed back along the string is True iff the + -- rest of the string is a sequence of backslashes followed by + -- a double quote. +#else +translate str = '\'' : foldr escape "'" str + where escape '\'' = showString "'\\''" + escape c = showChar c +#endif + -- ---------------------------------------------------------------------------- -- Utils @@ -589,9 +601,9 @@ let env' = map (\(name, val) -> name ++ ('=':val)) envir in withMany withCString env' (\pEnv -> withArray0 nullPtr pEnv act) #else -withCEnvironment :: [(String,String)] -> (Ptr () -> IO a) -> IO a +withCEnvironment :: [(String,String)] -> (Ptr CWString -> IO a) -> IO a withCEnvironment envir act = let env' = foldr (\(name, val) env -> name ++ ('=':val)++'\0':env) "\0" envir - in withCString env' (act . castPtr) + in withCWString env' (act . castPtr) #endif diff -Nru ghc-7.0.3/libraries/process/System/Process.hs ghc-7.2.1/libraries/process/System/Process.hs --- ghc-7.0.3/libraries/process/System/Process.hs 2011-03-26 18:10:14.000000000 +0000 +++ ghc-7.2.1/libraries/process/System/Process.hs 2011-08-07 17:10:11.000000000 +0000 @@ -1,4 +1,8 @@ {-# LANGUAGE CPP, ForeignFunctionInterface #-} +#if __GLASGOW_HASKELL__ >= 701 +-- not available prior to 7.1 +{-# LANGUAGE InterruptibleFFI #-} +#endif ----------------------------------------------------------------------------- -- | -- Module : System.Process @@ -49,12 +53,14 @@ #endif system, rawSystem, + showCommandForUser, #ifndef __HUGS__ -- * Process completion waitForProcess, getProcessExitCode, terminateProcess, + interruptProcessGroupOf, #endif ) where @@ -80,7 +86,10 @@ #else import GHC.IOBase ( ioException, IOErrorType(..) ) #endif -#if !defined(mingw32_HOST_OS) +#if defined(mingw32_HOST_OS) +import System.Win32.Process (getProcessId) +import System.Win32.Console (generateConsoleCtrlEvent, cTRL_BREAK_EVENT) +#else import System.Posix.Signals #endif #endif @@ -167,7 +176,8 @@ std_in = Inherit, std_out = Inherit, std_err = Inherit, - close_fds = False} + close_fds = False, + create_group = False} -- | Construct a 'CreateProcess' record for passing to 'createProcess', -- representing a command to be passed to the shell. @@ -178,8 +188,9 @@ std_in = Inherit, std_out = Inherit, std_err = Inherit, - close_fds = False} - + close_fds = False, + create_group = False} + {- | This is the most general way to spawn an external process. The process can be a command line to be executed by a shell or a raw command @@ -309,7 +320,7 @@ -- (XXX but there's a small race window here during which another -- thread could close the handle or call waitForProcess) alloca $ \pret -> do - throwErrnoIfMinus1_ "waitForProcess" (c_waitForProcess h pret) + throwErrnoIfMinus1Retry_ "waitForProcess" (c_waitForProcess h pret) withProcessHandle ph $ \p_' -> case p_' of ClosedHandle e -> return (p_',e) @@ -492,31 +503,23 @@ rawSystem :: String -> [String] -> IO ExitCode #ifdef __GLASGOW_HASKELL__ rawSystem cmd args = syncProcess "rawSystem" (proc cmd args) - #elif !mingw32_HOST_OS -- crude fallback implementation: could do much better than this under Unix -rawSystem cmd args = system (unwords (map translate (cmd:args))) - -translate :: String -> String -translate str = '\'' : foldr escape "'" str - where escape '\'' = showString "'\\''" - escape c = showChar c +rawSystem cmd args = system (showCommandForUser cmd args) #else /* mingw32_HOST_OS && ! __GLASGOW_HASKELL__ */ # if __HUGS__ -rawSystem cmd args = system (unwords (cmd : map translate args)) +rawSystem cmd args = system (cmd ++ showCommandForUser "" args) # else -rawSystem cmd args = system (unwords (map translate (cmd:args))) +rawSystem cmd args = system (showCommandForUser cmd args) #endif - --- copied from System.Process (qv) -translate :: String -> String -translate str = '"' : snd (foldr escape (True,"\"") str) - where escape '"' (b, str) = (True, '\\' : '"' : str) - escape '\\' (True, str) = (True, '\\' : '\\' : str) - escape '\\' (False, str) = (False, '\\' : str) - escape c (b, str) = (False, c : str) #endif +-- | Given a program @p@ and arguments @args@, +-- @showCommandForUser p args@ returns a string suitable for pasting +-- into sh (on POSIX OSs) or cmd.exe (on Windows). +showCommandForUser :: FilePath -> [String] -> String +showCommandForUser cmd args = unwords (map translate (cmd : args)) + #ifndef __HUGS__ -- ---------------------------------------------------------------------------- -- terminateProcess @@ -542,12 +545,43 @@ case p_ of ClosedHandle _ -> return p_ OpenHandle h -> do - throwErrnoIfMinus1_ "terminateProcess" $ c_terminateProcess h + throwErrnoIfMinus1Retry_ "terminateProcess" $ c_terminateProcess h return p_ -- does not close the handle, we might want to try terminating it -- again, or get its exit code. -- ---------------------------------------------------------------------------- +-- interruptProcessGroupOf + +-- | Sends an interrupt signal to the process group of the given process. +-- +-- On Unix systems, it sends the group the SIGINT signal. +-- +-- On Windows systems, it generates a CTRL_BREAK_EVENT and will only work for +-- processes created using 'createProcess' and setting the 'create_group' flag + +interruptProcessGroupOf + :: ProcessHandle -- ^ Lead process in the process group + -> IO () +interruptProcessGroupOf ph = do +#if mingw32_HOST_OS + withProcessHandle_ ph $ \p_ -> do + case p_ of + ClosedHandle _ -> return p_ + OpenHandle h -> do + pid <- getProcessId h + generateConsoleCtrlEvent cTRL_BREAK_EVENT pid + return p_ +#else + withProcessHandle_ ph $ \p_ -> do + case p_ of + ClosedHandle _ -> return p_ + OpenHandle h -> do + signalProcessGroup sigINT h + return p_ +#endif + +-- ---------------------------------------------------------------------------- -- getProcessExitCode {- | @@ -562,7 +596,7 @@ ClosedHandle e -> return (p_, Just e) OpenHandle h -> alloca $ \pExitCode -> do - res <- throwErrnoIfMinus1 "getProcessExitCode" $ + res <- throwErrnoIfMinus1Retry "getProcessExitCode" $ c_getProcessExitCode h pExitCode code <- peek pExitCode if res == 0 @@ -587,7 +621,12 @@ -> Ptr CInt -> IO CInt -foreign import ccall safe "waitForProcess" -- NB. safe - can block +#if __GLASGOW_HASKELL__ < 701 +-- not available prior to 7.1 +#define interruptible safe +#endif + +foreign import ccall interruptible "waitForProcess" -- NB. safe - can block c_waitForProcess :: PHANDLE -> Ptr CInt diff -Nru ghc-7.0.3/libraries/process/tests/3994.hs ghc-7.2.1/libraries/process/tests/3994.hs --- ghc-7.0.3/libraries/process/tests/3994.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/process/tests/3994.hs 2011-08-07 17:10:11.000000000 +0000 @@ -0,0 +1,22 @@ +module Main where + +import Control.Concurrent +import System.IO +import System.Process + +main :: IO () +main = do (_,Just hout,_,p) <- createProcess (proc "sh" ["-c", "echo start; sleep 10"]) + { std_out = CreatePipe, create_group = True } + start <- hGetLine hout + putStrLn start + interruptProcessGroupOf p + t <- myThreadId + -- timeout + forkIO $ do + threadDelay 5000000 + putStrLn "Interrupting a Running Process Failed" + hFlush stdout + killThread t + waitForProcess p + putStrLn "end" + return () diff -Nru ghc-7.0.3/libraries/process/tests/3994.stdout ghc-7.2.1/libraries/process/tests/3994.stdout --- ghc-7.0.3/libraries/process/tests/3994.stdout 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/process/tests/3994.stdout 2011-08-07 17:10:11.000000000 +0000 @@ -0,0 +1,2 @@ +start +end diff -Nru ghc-7.0.3/libraries/process/tests/all.T ghc-7.2.1/libraries/process/tests/all.T --- ghc-7.0.3/libraries/process/tests/all.T 2011-03-26 18:10:15.000000000 +0000 +++ ghc-7.2.1/libraries/process/tests/all.T 2011-08-07 17:10:11.000000000 +0000 @@ -20,3 +20,5 @@ test('3231', only_ways(['threaded1','threaded2']), compile_and_run, ['']) test('4198', cmd_prefix('\'' + config.compiler + '\'' + ' exitminus1.c -o exitminus1; '), compile_and_run, ['']) + +test('3994', only_ways(['threaded1','threaded2']), compile_and_run, ['']) diff -Nru ghc-7.0.3/libraries/prologue.txt ghc-7.2.1/libraries/prologue.txt --- ghc-7.0.3/libraries/prologue.txt 2011-03-26 18:11:24.000000000 +0000 +++ ghc-7.2.1/libraries/prologue.txt 2011-08-07 17:11:44.000000000 +0000 @@ -1,5 +1,5 @@ This index includes documentation for many Haskell modules. -For documentation on the GHC API, see . +For documentation on the GHC API, see . diff -Nru ghc-7.0.3/libraries/random/.darcs-boring ghc-7.2.1/libraries/random/.darcs-boring --- ghc-7.0.3/libraries/random/.darcs-boring 2011-03-26 18:10:15.000000000 +0000 +++ ghc-7.2.1/libraries/random/.darcs-boring 1970-01-01 00:00:00.000000000 +0000 @@ -1,5 +0,0 @@ -^dist(/|$) -^setup(/|$) -^GNUmakefile$ -^Makefile.local$ -^.depend(.bak)?$ diff -Nru ghc-7.0.3/libraries/random/ghc.mk ghc-7.2.1/libraries/random/ghc.mk --- ghc-7.0.3/libraries/random/ghc.mk 2011-03-26 18:10:45.000000000 +0000 +++ ghc-7.2.1/libraries/random/ghc.mk 1970-01-01 00:00:00.000000000 +0000 @@ -1,3 +0,0 @@ -libraries/random_PACKAGE = random -libraries/random_dist-install_GROUP = libraries -$(eval $(call build-package,libraries/random,dist-install,$(if $(filter random,$(STAGE2_PACKAGES)),2,1))) diff -Nru ghc-7.0.3/libraries/random/GNUmakefile ghc-7.2.1/libraries/random/GNUmakefile --- ghc-7.0.3/libraries/random/GNUmakefile 2011-03-26 18:10:45.000000000 +0000 +++ ghc-7.2.1/libraries/random/GNUmakefile 1970-01-01 00:00:00.000000000 +0000 @@ -1,4 +0,0 @@ -dir = libraries/random -TOP = ../.. -include $(TOP)/mk/sub-makefile.mk -FAST_MAKE_OPTS += stage=0 diff -Nru ghc-7.0.3/libraries/random/LICENSE ghc-7.2.1/libraries/random/LICENSE --- ghc-7.0.3/libraries/random/LICENSE 2011-03-26 18:10:15.000000000 +0000 +++ ghc-7.2.1/libraries/random/LICENSE 1970-01-01 00:00:00.000000000 +0000 @@ -1,63 +0,0 @@ -This library (libraries/base) is derived from code from two -sources: - - * Code from the GHC project which is largely (c) The University of - Glasgow, and distributable under a BSD-style license (see below), - - * Code from the Haskell 98 Report which is (c) Simon Peyton Jones - and freely redistributable (but see the full license for - restrictions). - -The full text of these licenses is reproduced below. Both of the -licenses are BSD-style or compatible. - ------------------------------------------------------------------------------ - -The Glasgow Haskell Compiler License - -Copyright 2004, The University Court of the University of Glasgow. -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - -- Redistributions of source code must retain the above copyright notice, -this list of conditions and the following disclaimer. - -- Redistributions in binary form must reproduce the above copyright notice, -this list of conditions and the following disclaimer in the documentation -and/or other materials provided with the distribution. - -- Neither name of the University nor the names of its contributors may be -used to endorse or promote products derived from this software without -specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE UNIVERSITY COURT OF THE UNIVERSITY OF -GLASGOW AND THE CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, -INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE -UNIVERSITY COURT OF THE UNIVERSITY OF GLASGOW OR THE CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR -SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER -CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT -LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY -OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH -DAMAGE. - ------------------------------------------------------------------------------ - -Code derived from the document "Report on the Programming Language -Haskell 98", is distributed under the following license: - - Copyright (c) 2002 Simon Peyton Jones - - The authors intend this Report to belong to the entire Haskell - community, and so we grant permission to copy and distribute it for - any purpose, provided that it is reproduced in its entirety, - including this Notice. Modified versions of this Report may also be - copied and distributed for any purpose, provided that the modified - version is clearly presented as such, and that it does not claim to - be a definition of the Haskell 98 Language. - ------------------------------------------------------------------------------ diff -Nru ghc-7.0.3/libraries/random/prologue.txt ghc-7.2.1/libraries/random/prologue.txt --- ghc-7.0.3/libraries/random/prologue.txt 2011-03-26 18:10:15.000000000 +0000 +++ ghc-7.2.1/libraries/random/prologue.txt 1970-01-01 00:00:00.000000000 +0000 @@ -1 +0,0 @@ -Random number library. diff -Nru ghc-7.0.3/libraries/random/random.cabal ghc-7.2.1/libraries/random/random.cabal --- ghc-7.0.3/libraries/random/random.cabal 2011-03-26 18:10:15.000000000 +0000 +++ ghc-7.2.1/libraries/random/random.cabal 1970-01-01 00:00:00.000000000 +0000 @@ -1,23 +0,0 @@ -name: random -version: 1.0.0.3 -license: BSD3 -license-file: LICENSE -maintainer: libraries@haskell.org -bug-reports: http://hackage.haskell.org/trac/ghc/newticket?component=libraries/random -synopsis: random number library -category: System -description: - This package provides a random number library. -build-type: Simple -Cabal-Version: >= 1.6 - -Library - exposed-modules: - System.Random - extensions: CPP - build-depends: base >= 3 && < 5, time - -source-repository head - type: darcs - location: http://darcs.haskell.org/packages/random - diff -Nru ghc-7.0.3/libraries/random/Setup.hs ghc-7.2.1/libraries/random/Setup.hs --- ghc-7.0.3/libraries/random/Setup.hs 2011-03-26 18:10:15.000000000 +0000 +++ ghc-7.2.1/libraries/random/Setup.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,6 +0,0 @@ -module Main (main) where - -import Distribution.Simple - -main :: IO () -main = defaultMain diff -Nru ghc-7.0.3/libraries/random/System/Random.hs ghc-7.2.1/libraries/random/System/Random.hs --- ghc-7.0.3/libraries/random/System/Random.hs 2011-03-26 18:10:15.000000000 +0000 +++ ghc-7.2.1/libraries/random/System/Random.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,450 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : System.Random --- Copyright : (c) The University of Glasgow 2001 --- License : BSD-style (see the file libraries/base/LICENSE) --- --- Maintainer : libraries@haskell.org --- Stability : stable --- Portability : portable --- --- This library deals with the common task of pseudo-random number --- generation. The library makes it possible to generate repeatable --- results, by starting with a specified initial random number generator, --- or to get different results on each run by using the system-initialised --- generator or by supplying a seed from some other source. --- --- The library is split into two layers: --- --- * A core /random number generator/ provides a supply of bits. --- The class 'RandomGen' provides a common interface to such generators. --- The library provides one instance of 'RandomGen', the abstract --- data type 'StdGen'. Programmers may, of course, supply their own --- instances of 'RandomGen'. --- --- * The class 'Random' provides a way to extract values of a particular --- type from a random number generator. For example, the 'Float' --- instance of 'Random' allows one to generate random values of type --- 'Float'. --- --- This implementation uses the Portable Combined Generator of L'Ecuyer --- ["System.Random\#LEcuyer"] for 32-bit computers, transliterated by --- Lennart Augustsson. It has a period of roughly 2.30584e18. --- ------------------------------------------------------------------------------ - -module System.Random - ( - - -- $intro - - -- * Random number generators - - RandomGen(next, split, genRange) - - -- ** Standard random number generators - , StdGen - , mkStdGen - - -- ** The global random number generator - - -- $globalrng - - , getStdRandom - , getStdGen - , setStdGen - , newStdGen - - -- * Random values of various types - , Random ( random, randomR, - randoms, randomRs, - randomIO, randomRIO ) - - -- * References - -- $references - - ) where - -import Prelude - -import Data.Int - -#ifdef __NHC__ -import CPUTime ( getCPUTime ) -import Foreign.Ptr ( Ptr, nullPtr ) -import Foreign.C ( CTime, CUInt ) -#else -import System.CPUTime ( getCPUTime ) -import Data.Time ( getCurrentTime, UTCTime(..) ) -import Data.Ratio ( numerator, denominator ) -#endif -import Data.Char ( isSpace, chr, ord ) -import System.IO.Unsafe ( unsafePerformIO ) -import Data.IORef -import Numeric ( readDec ) - --- The standard nhc98 implementation of Time.ClockTime does not match --- the extended one expected in this module, so we lash-up a quick --- replacement here. -#ifdef __NHC__ -foreign import ccall "time.h time" readtime :: Ptr CTime -> IO CTime -getTime :: IO (Integer, Integer) -getTime = do CTime t <- readtime nullPtr; return (toInteger t, 0) -#else -getTime :: IO (Integer, Integer) -getTime = do - utc <- getCurrentTime - let daytime = toRational $ utctDayTime utc - return $ quotRem (numerator daytime) (denominator daytime) -#endif - --- | The class 'RandomGen' provides a common interface to random number --- generators. --- --- Minimal complete definition: 'next' and 'split'. - -class RandomGen g where - - -- |The 'next' operation returns an 'Int' that is uniformly distributed - -- in the range returned by 'genRange' (including both end points), - -- and a new generator. - next :: g -> (Int, g) - - -- |The 'split' operation allows one to obtain two distinct random number - -- generators. This is very useful in functional programs (for example, when - -- passing a random number generator down to recursive calls), but very - -- little work has been done on statistically robust implementations of - -- 'split' (["System.Random\#Burton", "System.Random\#Hellekalek"] - -- are the only examples we know of). - split :: g -> (g, g) - - -- |The 'genRange' operation yields the range of values returned by - -- the generator. - -- - -- It is required that: - -- - -- * If @(a,b) = 'genRange' g@, then @a < b@. - -- - -- * 'genRange' always returns a pair of defined 'Int's. - -- - -- The second condition ensures that 'genRange' cannot examine its - -- argument, and hence the value it returns can be determined only by the - -- instance of 'RandomGen'. That in turn allows an implementation to make - -- a single call to 'genRange' to establish a generator's range, without - -- being concerned that the generator returned by (say) 'next' might have - -- a different range to the generator passed to 'next'. - -- - -- The default definition spans the full range of 'Int'. - genRange :: g -> (Int,Int) - - -- default method - genRange _ = (minBound, maxBound) - -{- | -The 'StdGen' instance of 'RandomGen' has a 'genRange' of at least 30 bits. - -The result of repeatedly using 'next' should be at least as statistically -robust as the /Minimal Standard Random Number Generator/ described by -["System.Random\#Park", "System.Random\#Carta"]. -Until more is known about implementations of 'split', all we require is -that 'split' deliver generators that are (a) not identical and -(b) independently robust in the sense just given. - -The 'Show' and 'Read' instances of 'StdGen' provide a primitive way to save the -state of a random number generator. -It is required that @'read' ('show' g) == g@. - -In addition, 'reads' may be used to map an arbitrary string (not necessarily one -produced by 'show') onto a value of type 'StdGen'. In general, the 'Read' -instance of 'StdGen' has the following properties: - -* It guarantees to succeed on any string. - -* It guarantees to consume only a finite portion of the string. - -* Different argument strings are likely to result in different results. - --} - -data StdGen - = StdGen Int32 Int32 - -instance RandomGen StdGen where - next = stdNext - split = stdSplit - genRange _ = stdRange - -instance Show StdGen where - showsPrec p (StdGen s1 s2) = - showsPrec p s1 . - showChar ' ' . - showsPrec p s2 - -instance Read StdGen where - readsPrec _p = \ r -> - case try_read r of - r'@[_] -> r' - _ -> [stdFromString r] -- because it shouldn't ever fail. - where - try_read r = do - (s1, r1) <- readDec (dropWhile isSpace r) - (s2, r2) <- readDec (dropWhile isSpace r1) - return (StdGen s1 s2, r2) - -{- - If we cannot unravel the StdGen from a string, create - one based on the string given. --} -stdFromString :: String -> (StdGen, String) -stdFromString s = (mkStdGen num, rest) - where (cs, rest) = splitAt 6 s - num = foldl (\a x -> x + 3 * a) 1 (map ord cs) - - -{- | -The function 'mkStdGen' provides an alternative way of producing an initial -generator, by mapping an 'Int' into a generator. Again, distinct arguments -should be likely to produce distinct generators. --} -mkStdGen :: Int -> StdGen -- why not Integer ? -mkStdGen s = mkStdGen32 $ fromIntegral s - -mkStdGen32 :: Int32 -> StdGen -mkStdGen32 s - | s < 0 = mkStdGen32 (-s) - | otherwise = StdGen (s1+1) (s2+1) - where - (q, s1) = s `divMod` 2147483562 - s2 = q `mod` 2147483398 - -createStdGen :: Integer -> StdGen -createStdGen s = mkStdGen32 $ fromIntegral s - --- FIXME: 1/2/3 below should be ** (vs@30082002) XXX - -{- | -With a source of random number supply in hand, the 'Random' class allows the -programmer to extract random values of a variety of types. - -Minimal complete definition: 'randomR' and 'random'. - --} - -class Random a where - -- | Takes a range /(lo,hi)/ and a random number generator - -- /g/, and returns a random value uniformly distributed in the closed - -- interval /[lo,hi]/, together with a new generator. It is unspecified - -- what happens if /lo>hi/. For continuous types there is no requirement - -- that the values /lo/ and /hi/ are ever produced, but they may be, - -- depending on the implementation and the interval. - randomR :: RandomGen g => (a,a) -> g -> (a,g) - - -- | The same as 'randomR', but using a default range determined by the type: - -- - -- * For bounded types (instances of 'Bounded', such as 'Char'), - -- the range is normally the whole type. - -- - -- * For fractional types, the range is normally the semi-closed interval - -- @[0,1)@. - -- - -- * For 'Integer', the range is (arbitrarily) the range of 'Int'. - random :: RandomGen g => g -> (a, g) - - -- | Plural variant of 'randomR', producing an infinite list of - -- random values instead of returning a new generator. - randomRs :: RandomGen g => (a,a) -> g -> [a] - randomRs ival g = x : randomRs ival g' where (x,g') = randomR ival g - - -- | Plural variant of 'random', producing an infinite list of - -- random values instead of returning a new generator. - randoms :: RandomGen g => g -> [a] - randoms g = (\(x,g') -> x : randoms g') (random g) - - -- | A variant of 'randomR' that uses the global random number generator - -- (see "System.Random#globalrng"). - randomRIO :: (a,a) -> IO a - randomRIO range = getStdRandom (randomR range) - - -- | A variant of 'random' that uses the global random number generator - -- (see "System.Random#globalrng"). - randomIO :: IO a - randomIO = getStdRandom random - - -instance Random Int where - randomR (a,b) g = randomIvalInteger (toInteger a, toInteger b) g - random g = randomR (minBound,maxBound) g - -instance Random Char where - randomR (a,b) g = - case (randomIvalInteger (toInteger (ord a), toInteger (ord b)) g) of - (x,g') -> (chr x, g') - random g = randomR (minBound,maxBound) g - -instance Random Bool where - randomR (a,b) g = - case (randomIvalInteger (bool2Int a, bool2Int b) g) of - (x, g') -> (int2Bool x, g') - where - bool2Int :: Bool -> Integer - bool2Int False = 0 - bool2Int True = 1 - - int2Bool :: Int -> Bool - int2Bool 0 = False - int2Bool _ = True - - random g = randomR (minBound,maxBound) g - -instance Random Integer where - randomR ival g = randomIvalInteger ival g - random g = randomR (toInteger (minBound::Int), toInteger (maxBound::Int)) g - -instance Random Double where - randomR ival g = randomIvalDouble ival id g - random g = randomR (0::Double,1) g - --- hah, so you thought you were saving cycles by using Float? -instance Random Float where - random g = randomIvalDouble (0::Double,1) realToFrac g - randomR (a,b) g = randomIvalDouble (realToFrac a, realToFrac b) realToFrac g - -mkStdRNG :: Integer -> IO StdGen -mkStdRNG o = do - ct <- getCPUTime - (sec, psec) <- getTime - return (createStdGen (sec * 12345 + psec + ct + o)) - -randomIvalInteger :: (RandomGen g, Num a) => (Integer, Integer) -> g -> (a, g) -randomIvalInteger (l,h) rng - | l > h = randomIvalInteger (h,l) rng - | otherwise = case (f n 1 rng) of (v, rng') -> (fromInteger (l + v `mod` k), rng') - where - k = h - l + 1 - b = 2147483561 - n = iLogBase b k - - f 0 acc g = (acc, g) - f n' acc g = - let - (x,g') = next g - in - f (n' - 1) (fromIntegral x + acc * b) g' - -randomIvalDouble :: (RandomGen g, Fractional a) => (Double, Double) -> (Double -> a) -> g -> (a, g) -randomIvalDouble (l,h) fromDouble rng - | l > h = randomIvalDouble (h,l) fromDouble rng - | otherwise = - case (randomIvalInteger (toInteger (minBound::Int32), toInteger (maxBound::Int32)) rng) of - (x, rng') -> - let - scaled_x = - fromDouble ((l+h)/2) + - fromDouble ((h-l) / realToFrac int32Count) * - fromIntegral (x::Int32) - in - (scaled_x, rng') - -int32Count :: Integer -int32Count = toInteger (maxBound::Int32) - toInteger (minBound::Int32) + 1 - -iLogBase :: Integer -> Integer -> Integer -iLogBase b i = if i < b then 1 else 1 + iLogBase b (i `div` b) - -stdRange :: (Int,Int) -stdRange = (0, 2147483562) - -stdNext :: StdGen -> (Int, StdGen) --- Returns values in the range stdRange -stdNext (StdGen s1 s2) = (fromIntegral z', StdGen s1'' s2'') - where z' = if z < 1 then z + 2147483562 else z - z = s1'' - s2'' - - k = s1 `quot` 53668 - s1' = 40014 * (s1 - k * 53668) - k * 12211 - s1'' = if s1' < 0 then s1' + 2147483563 else s1' - - k' = s2 `quot` 52774 - s2' = 40692 * (s2 - k' * 52774) - k' * 3791 - s2'' = if s2' < 0 then s2' + 2147483399 else s2' - -stdSplit :: StdGen -> (StdGen, StdGen) -stdSplit std@(StdGen s1 s2) - = (left, right) - where - -- no statistical foundation for this! - left = StdGen new_s1 t2 - right = StdGen t1 new_s2 - - new_s1 | s1 == 2147483562 = 1 - | otherwise = s1 + 1 - - new_s2 | s2 == 1 = 2147483398 - | otherwise = s2 - 1 - - StdGen t1 t2 = snd (next std) - --- The global random number generator - -{- $globalrng #globalrng# - -There is a single, implicit, global random number generator of type -'StdGen', held in some global variable maintained by the 'IO' monad. It is -initialised automatically in some system-dependent fashion, for example, by -using the time of day, or Linux's kernel random number generator. To get -deterministic behaviour, use 'setStdGen'. --} - --- |Sets the global random number generator. -setStdGen :: StdGen -> IO () -setStdGen sgen = writeIORef theStdGen sgen - --- |Gets the global random number generator. -getStdGen :: IO StdGen -getStdGen = readIORef theStdGen - -theStdGen :: IORef StdGen -theStdGen = unsafePerformIO $ do - rng <- mkStdRNG 0 - newIORef rng - --- |Applies 'split' to the current global random generator, --- updates it with one of the results, and returns the other. -newStdGen :: IO StdGen -newStdGen = atomicModifyIORef theStdGen split - -{- |Uses the supplied function to get a value from the current global -random generator, and updates the global generator with the new generator -returned by the function. For example, @rollDice@ gets a random integer -between 1 and 6: - -> rollDice :: IO Int -> rollDice = getStdRandom (randomR (1,6)) - --} - -getStdRandom :: (StdGen -> (a,StdGen)) -> IO a -getStdRandom f = atomicModifyIORef theStdGen (swap . f) - where swap (v,g) = (g,v) - -{- $references - -1. FW #Burton# Burton and RL Page, /Distributed random number generation/, -Journal of Functional Programming, 2(2):203-212, April 1992. - -2. SK #Park# Park, and KW Miller, /Random number generators - -good ones are hard to find/, Comm ACM 31(10), Oct 1988, pp1192-1201. - -3. DG #Carta# Carta, /Two fast implementations of the minimal standard -random number generator/, Comm ACM, 33(1), Jan 1990, pp87-88. - -4. P #Hellekalek# Hellekalek, /Don\'t trust parallel Monte Carlo/, -Department of Mathematics, University of Salzburg, -, 1998. - -5. Pierre #LEcuyer# L'Ecuyer, /Efficient and portable combined random -number generators/, Comm ACM, 31(6), Jun 1988, pp742-749. - -The Web site is a great source of information. - --} diff -Nru ghc-7.0.3/libraries/random/tests/all.T ghc-7.2.1/libraries/random/tests/all.T --- ghc-7.0.3/libraries/random/tests/all.T 2011-03-26 18:10:15.000000000 +0000 +++ ghc-7.2.1/libraries/random/tests/all.T 1970-01-01 00:00:00.000000000 +0000 @@ -1,4 +0,0 @@ -test('random1283', - reqlib('containers'), - compile_and_run, - ['-package containers']) diff -Nru ghc-7.0.3/libraries/random/tests/Makefile ghc-7.2.1/libraries/random/tests/Makefile --- ghc-7.0.3/libraries/random/tests/Makefile 2011-03-26 18:10:15.000000000 +0000 +++ ghc-7.2.1/libraries/random/tests/Makefile 1970-01-01 00:00:00.000000000 +0000 @@ -1,7 +0,0 @@ -# This Makefile runs the tests using GHC's testsuite framework. It -# assumes the package is part of a GHC build tree with the testsuite -# installed in ../../../testsuite. - -TOP=../../../testsuite -include $(TOP)/mk/boilerplate.mk -include $(TOP)/mk/test.mk diff -Nru ghc-7.0.3/libraries/random/tests/random1283.hs ghc-7.2.1/libraries/random/tests/random1283.hs --- ghc-7.0.3/libraries/random/tests/random1283.hs 2011-03-26 18:10:15.000000000 +0000 +++ ghc-7.2.1/libraries/random/tests/random1283.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,36 +0,0 @@ -import Control.Concurrent -import Control.Monad -import Data.Sequence (ViewL(..), empty, fromList, viewl, (<|), (|>), (><)) -import System.Random - -threads = 4 -samples = 5000 - -main = loopTest threads samples - -loopTest t s = do - isClean <- testRace t s - when (not isClean) $ putStrLn "race condition!" - -testRace t s = do - ref <- liftM (take (t*s) . randoms) getStdGen - iss <- threadRandoms t s - return (isInterleavingOf (ref::[Int]) iss) - -threadRandoms t s = do - vs <- sequence $ replicate t $ do - v <- newEmptyMVar - forkIO (sequence (replicate s randomIO) >>= putMVar v) - return v - mapM takeMVar vs - -isInterleavingOf xs yss = iio xs (viewl $ fromList yss) EmptyL where - iio (x:xs) ((y:ys) :< yss) zss - | x /= y = iio (x:xs) (viewl yss) (viewl (fromViewL zss |> (y:ys))) - | x == y = iio xs (viewl ((ys <| yss) >< fromViewL zss)) EmptyL - iio xs ([] :< yss) zss = iio xs (viewl yss) zss - iio [] EmptyL EmptyL = True - iio _ _ _ = False - -fromViewL (EmptyL) = empty -fromViewL (x :< xs) = x <| xs diff -Nru ghc-7.0.3/libraries/template-haskell/ghc.mk ghc-7.2.1/libraries/template-haskell/ghc.mk --- ghc-7.0.3/libraries/template-haskell/ghc.mk 2011-03-26 18:10:45.000000000 +0000 +++ ghc-7.2.1/libraries/template-haskell/ghc.mk 2011-08-07 17:11:00.000000000 +0000 @@ -1,3 +1,4 @@ libraries/template-haskell_PACKAGE = template-haskell libraries/template-haskell_dist-install_GROUP = libraries +$(if $(filter template-haskell,$(PACKAGES_STAGE0)),$(eval $(call build-package,libraries/template-haskell,dist-boot,0))) $(eval $(call build-package,libraries/template-haskell,dist-install,$(if $(filter template-haskell,$(STAGE2_PACKAGES)),2,1))) diff -Nru ghc-7.0.3/libraries/template-haskell/Language/Haskell/TH/Lib.hs ghc-7.2.1/libraries/template-haskell/Language/Haskell/TH/Lib.hs --- ghc-7.0.3/libraries/template-haskell/Language/Haskell/TH/Lib.hs 2011-03-26 18:10:15.000000000 +0000 +++ ghc-7.2.1/libraries/template-haskell/Language/Haskell/TH/Lib.hs 2011-08-07 17:10:12.000000000 +0000 @@ -64,6 +64,8 @@ varP v = return (VarP v) tupP :: [PatQ] -> PatQ tupP ps = do { ps1 <- sequence ps; return (TupP ps1)} +unboxedTupP :: [PatQ] -> PatQ +unboxedTupP ps = do { ps1 <- sequence ps; return (UnboxedTupP ps1)} conP :: Name -> [PatQ] -> PatQ conP n ps = do ps' <- sequence ps return (ConP n ps') @@ -226,6 +228,9 @@ tupE :: [ExpQ] -> ExpQ tupE es = do { es1 <- sequence es; return (TupE es1)} +unboxedTupE :: [ExpQ] -> ExpQ +unboxedTupE es = do { es1 <- sequence es; return (UnboxedTupE es1)} + condE :: ExpQ -> ExpQ -> ExpQ -> ExpQ condE x y z = do { a <- x; b <- y; c <- z; return (CondE a b c)} @@ -443,6 +448,9 @@ tupleT :: Int -> TypeQ tupleT i = return (TupleT i) +unboxedTupleT :: Int -> TypeQ +unboxedTupleT i = return (UnboxedTupleT i) + sigT :: TypeQ -> Kind -> TypeQ sigT t k = do @@ -485,10 +493,10 @@ ------------------------------------------------------------------------------- -- * Safety -unsafe, safe, threadsafe :: Safety +unsafe, safe, interruptible :: Safety unsafe = Unsafe safe = Safe -threadsafe = Threadsafe +interruptible = Interruptible ------------------------------------------------------------------------------- -- * InlineSpec @@ -515,49 +523,10 @@ dataFam = DataFam -------------------------------------------------------------- --- * Useful helper functions - -combine :: [([(Name, Name)], Pat)] -> ([(Name, Name)], [Pat]) -combine pairs = foldr f ([],[]) pairs - where f (env,p) (es,ps) = (env++es,p:ps) - -rename :: Pat -> Q ([(Name, Name)], Pat) -rename (LitP c) = return([],LitP c) -rename (VarP s) = do { s1 <- newName (nameBase s); return([(s,s1)],VarP s1) } -rename (TupP pats) = do { pairs <- mapM rename pats; g(combine pairs) } - where g (es,ps) = return (es,TupP ps) -rename (ConP nm pats) = do { pairs <- mapM rename pats; g(combine pairs) } - where g (es,ps) = return (es,ConP nm ps) -rename (InfixP p1 n p2) = do { r1 <- rename p1; - r2 <- rename p2; - let {(env, [p1', p2']) = combine [r1, r2]}; - return (env, InfixP p1' n p2') } -rename (TildeP p) = do { (env,p2) <- rename p; return(env,TildeP p2) } -rename (BangP p) = do { (env,p2) <- rename p; return(env,BangP p2) } -rename (AsP s p) = - do { s1 <- newName (nameBase s); (env,p2) <- rename p; return((s,s1):env,AsP s1 p2) } -rename WildP = return([],WildP) -rename (RecP nm fs) = do { pairs <- mapM rename ps; g(combine pairs) } - where g (env,ps') = return (env,RecP nm (zip ss ps')) - (ss,ps) = unzip fs -rename (ListP pats) = do { pairs <- mapM rename pats; g(combine pairs) } - where g (es,ps) = return (es,ListP ps) -rename (SigP {}) = fail "rename: Don't know how to do SigP yet" -rename (ViewP {}) = fail "rename: Don't know how to do ViewP yet" - -genpat :: Pat -> Q ((Name -> ExpQ), Pat) -genpat p = do { (env,p2) <- rename p; return (alpha env,p2) } - -alpha :: [(Name, Name)] -> Name -> ExpQ -alpha env s = case lookup s env of - Just x -> varE x - Nothing -> varE s +-- * Useful helper function appsE :: [ExpQ] -> ExpQ appsE [] = error "appsE []" appsE [x] = x appsE (x:y:zs) = appsE ( (appE x y) : zs ) -simpleMatch :: Pat -> Exp -> Match -simpleMatch p e = Match p (NormalB e) [] - diff -Nru ghc-7.0.3/libraries/template-haskell/Language/Haskell/TH/Ppr.hs ghc-7.2.1/libraries/template-haskell/Language/Haskell/TH/Ppr.hs --- ghc-7.0.3/libraries/template-haskell/Language/Haskell/TH/Ppr.hs 2011-03-26 18:10:15.000000000 +0000 +++ ghc-7.2.1/libraries/template-haskell/Language/Haskell/TH/Ppr.hs 2011-08-07 17:10:12.000000000 +0000 @@ -10,6 +10,7 @@ import Language.Haskell.TH.PprLib import Language.Haskell.TH.Syntax import Data.Char ( toLower ) +import GHC.Show ( showMultiLineString ) nestDepth :: Int nestDepth = 4 @@ -107,6 +108,7 @@ pprExp i (LamE ps e) = parensIf (i > noPrec) $ char '\\' <> hsep (map (pprPat appPrec) ps) <+> text "->" <+> ppr e pprExp _ (TupE es) = parens $ sep $ punctuate comma $ map ppr es +pprExp _ (UnboxedTupE es) = hashParens $ sep $ punctuate comma $ map ppr es -- Nesting in Cond is to avoid potential problems in do statments pprExp i (CondE guard true false) = parensIf (i > noPrec) $ sep [text "if" <+> ppr guard, @@ -172,10 +174,15 @@ (double (fromRational x) <> text "##") pprLit i (IntegerL x) = parensIf (i > noPrec && x < 0) (integer x) pprLit _ (CharL c) = text (show c) -pprLit _ (StringL s) = text (show s) -pprLit _ (StringPrimL s) = text (show s) <> char '#' +pprLit _ (StringL s) = pprString s +pprLit _ (StringPrimL s) = pprString s <> char '#' pprLit i (RationalL rat) = parensIf (i > noPrec) $ rational rat +pprString :: String -> Doc +-- Print newlines as newlines with Haskell string escape notation, +-- not as '\n'. For other non-printables use regular escape notation. +pprString s = vcat (map text (showMultiLineString s)) + ------------------------------ instance Ppr Pat where ppr = pprPat noPrec @@ -184,6 +191,7 @@ pprPat i (LitP l) = pprLit i l pprPat _ (VarP v) = pprName' Applied v pprPat _ (TupP ps) = parens $ sep $ punctuate comma $ map ppr ps +pprPat _ (UnboxedTupP ps) = hashParens $ sep $ punctuate comma $ map ppr ps pprPat i (ConP s ps) = parensIf (i >= appPrec) $ pprName' Applied s <+> sep (map (pprPat appPrec) ps) pprPat i (InfixP p1 n p2) @@ -373,6 +381,7 @@ pprParendType (ConT c) = ppr c pprParendType (TupleT 0) = text "()" pprParendType (TupleT n) = parens (hcat (replicate (n-1) comma)) +pprParendType (UnboxedTupleT n) = hashParens $ hcat $ replicate (n-1) comma pprParendType ArrowT = parens (text "->") pprParendType ListT = text "[]" pprParendType other = parens (ppr other) @@ -447,3 +456,6 @@ showtextl :: Show a => a -> Doc showtextl = text . map toLower . show +hashParens :: Doc -> Doc +hashParens d = text "(# " <> d <> text " #)" + diff -Nru ghc-7.0.3/libraries/template-haskell/Language/Haskell/TH/PprLib.hs ghc-7.2.1/libraries/template-haskell/Language/Haskell/TH/PprLib.hs --- ghc-7.0.3/libraries/template-haskell/Language/Haskell/TH/PprLib.hs 2011-03-26 18:10:15.000000000 +0000 +++ ghc-7.2.1/libraries/template-haskell/Language/Haskell/TH/PprLib.hs 2011-08-07 17:10:12.000000000 +0000 @@ -1,3 +1,4 @@ +{-# LANGUAGE FlexibleInstances #-} -- | Monadic front-end to Text.PrettyPrint.HughesPJ diff -Nru ghc-7.0.3/libraries/template-haskell/Language/Haskell/TH/Quote.hs ghc-7.2.1/libraries/template-haskell/Language/Haskell/TH/Quote.hs --- ghc-7.0.3/libraries/template-haskell/Language/Haskell/TH/Quote.hs 2011-03-26 18:10:15.000000000 +0000 +++ ghc-7.2.1/libraries/template-haskell/Language/Haskell/TH/Quote.hs 2011-08-07 17:10:12.000000000 +0000 @@ -30,7 +30,7 @@ IntConstr n -> mkLit $ integerL n FloatConstr n -> - mkLit $ rationalL (toRational n) + mkLit $ rationalL n CharConstr c -> mkLit $ charL c where diff -Nru ghc-7.0.3/libraries/template-haskell/Language/Haskell/TH/Syntax.hs ghc-7.2.1/libraries/template-haskell/Language/Haskell/TH/Syntax.hs --- ghc-7.0.3/libraries/template-haskell/Language/Haskell/TH/Syntax.hs 2011-03-26 18:10:15.000000000 +0000 +++ ghc-7.2.1/libraries/template-haskell/Language/Haskell/TH/Syntax.hs 2011-08-07 17:10:12.000000000 +0000 @@ -1,3 +1,4 @@ +{-# LANGUAGE UnboxedTuples #-} {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} -- The -fno-warn-warnings-deprecations flag is a temporary kludge. -- While working on this module you are encouraged to remove it and fix @@ -45,6 +46,7 @@ NameFlavour(..), NameSpace (..), mkNameG_v, mkNameG_d, mkNameG_tc, Uniq, mkNameL, mkNameU, tupleTypeName, tupleDataName, + unboxedTupleTypeName, unboxedTupleDataName, OccName, mkOccName, occString, ModName, mkModName, modString, PkgName, mkPkgName, pkgString @@ -80,7 +82,7 @@ -- Inspect the type-checker's environment qReify :: Name -> m Info - qClassInstances :: Name -> [Type] -> m [Name] + qClassInstances :: Name -> [Type] -> m [ClassInstance] -- Is (cls tys) an instance? -- Returns list of matching witnesses @@ -164,7 +166,7 @@ reify v = Q (qReify v) -- | 'classInstances' looks up instaces of a class -classInstances :: Name -> [Type] -> Q [Name] +classInstances :: Name -> [Type] -> Q [ClassInstance] classInstances cls tys = Q (qClassInstances cls tys) isClassInstance :: Name -> [Type] -> Q Bool @@ -284,8 +286,8 @@ trueName, falseName :: Name -trueName = mkNameG DataName "ghc-prim" "GHC.Bool" "True" -falseName = mkNameG DataName "ghc-prim" "GHC.Bool" "False" +trueName = mkNameG DataName "ghc-prim" "GHC.Types" "True" +falseName = mkNameG DataName "ghc-prim" "GHC.Types" "False" nothingName, justName :: Name nothingName = mkNameG DataName "base" "Data.Maybe" "Nothing" @@ -557,17 +559,17 @@ instance Show Name where show = showName --- Tuple data and type constructors +-- Tuple data and type constructors tupleDataName :: Int -> Name -- ^ Data constructor tupleTypeName :: Int -> Name -- ^ Type constructor -tupleDataName 0 = mk_tup_name 0 DataName +tupleDataName 0 = mk_tup_name 0 DataName tupleDataName 1 = error "tupleDataName 1" -tupleDataName n = mk_tup_name (n-1) DataName +tupleDataName n = mk_tup_name (n-1) DataName -tupleTypeName 0 = mk_tup_name 0 TcClsName +tupleTypeName 0 = mk_tup_name 0 TcClsName tupleTypeName 1 = error "tupleTypeName 1" -tupleTypeName n = mk_tup_name (n-1) TcClsName +tupleTypeName n = mk_tup_name (n-1) TcClsName mk_tup_name :: Int -> NameSpace -> Name mk_tup_name n_commas space @@ -577,6 +579,25 @@ -- XXX Should it be GHC.Unit for 0 commas? tup_mod = mkModName "GHC.Tuple" +-- Unboxed tuple data and type constructors +unboxedTupleDataName :: Int -> Name -- ^ Data constructor +unboxedTupleTypeName :: Int -> Name -- ^ Type constructor + +unboxedTupleDataName 0 = error "unboxedTupleDataName 0" +unboxedTupleDataName 1 = error "unboxedTupleDataName 1" +unboxedTupleDataName n = mk_unboxed_tup_name (n-1) DataName + +unboxedTupleTypeName 0 = error "unboxedTupleTypeName 0" +unboxedTupleTypeName 1 = error "unboxedTupleTypeName 1" +unboxedTupleTypeName n = mk_unboxed_tup_name (n-1) TcClsName + +mk_unboxed_tup_name :: Int -> NameSpace -> Name +mk_unboxed_tup_name n_commas space + = Name occ (NameG space (mkPkgName "ghc-prim") tup_mod) + where + occ = mkOccName ("(#" ++ replicate n_commas ',' ++ "#)") + tup_mod = mkModName "GHC.Tuple" + ----------------------------------------------------- @@ -691,6 +712,7 @@ = LitP Lit -- ^ @{ 5 or 'c' }@ | VarP Name -- ^ @{ x }@ | TupP [Pat] -- ^ @{ (p1,p2) }@ + | UnboxedTupP [Pat] -- ^ @{ (# p1,p2 #) }@ | ConP Name [Pat] -- ^ @data T1 = C1 t1 t2; {C1 p1 p1} = e@ | InfixP Pat Name Pat -- ^ @foo ({x :+ y}) = e@ | TildeP Pat -- ^ @{ ~p }@ @@ -736,6 +758,7 @@ | LamE [Pat] Exp -- ^ @{ \ p1 p2 -> e }@ | TupE [Exp] -- ^ @{ (e1,e2) } @ + | UnboxedTupE [Exp] -- ^ @{ (# e1,e2 #) } @ | CondE Exp Exp Exp -- ^ @{ if e1 then e2 else e3 }@ | LetE [Dec] Exp -- ^ @{ let x=e1; y=e2 in e3 }@ | CaseE Exp [Match] -- ^ @{ case e of m1; m2 }@ @@ -820,7 +843,7 @@ data Callconv = CCall | StdCall deriving( Show, Eq, Data, Typeable ) -data Safety = Unsafe | Safe | Threadsafe +data Safety = Unsafe | Safe | Interruptible deriving( Show, Eq, Data, Typeable ) data Pragma = InlineP Name InlineSpec @@ -855,6 +878,7 @@ | VarT Name -- ^ @a@ | ConT Name -- ^ @T@ | TupleT Int -- ^ @(,), (,,), etc.@ + | UnboxedTupleT Int -- ^ @(#,#), (#,,#), etc.@ | ArrowT -- ^ @->@ | ListT -- ^ @[]@ | AppT Type Type -- ^ @T a b@ diff -Nru ghc-7.0.3/libraries/template-haskell/Language/Haskell/TH.hs ghc-7.2.1/libraries/template-haskell/Language/Haskell/TH.hs --- ghc-7.0.3/libraries/template-haskell/Language/Haskell/TH.hs 2011-03-26 18:10:15.000000000 +0000 +++ ghc-7.2.1/libraries/template-haskell/Language/Haskell/TH.hs 2011-08-07 17:10:12.000000000 +0000 @@ -84,14 +84,14 @@ newtypeInstD, tySynInstD, typeFam, dataFam, -- **** Foreign Function Interface (FFI) - cCall, stdCall, unsafe, safe, threadsafe, forImpD, + cCall, stdCall, unsafe, safe, forImpD, -- **** Pragmas -- | Just inline supported so far inlineSpecNoPhase, inlineSpecPhase, pragInlD, pragSpecD, -- * Pretty-printer - Ppr(..), pprint, pprExp, pprLit, pprPat, pprParendType + Ppr(..), pprint, pprExp, pprLit, pprPat, pprParendType ) where diff -Nru ghc-7.0.3/libraries/template-haskell/template-haskell.cabal ghc-7.2.1/libraries/template-haskell/template-haskell.cabal --- ghc-7.0.3/libraries/template-haskell/template-haskell.cabal 2011-03-26 18:10:15.000000000 +0000 +++ ghc-7.2.1/libraries/template-haskell/template-haskell.cabal 2011-08-07 17:10:12.000000000 +0000 @@ -1,5 +1,5 @@ name: template-haskell -version: 2.5.0.0 +version: 2.6.0.0 license: BSD3 license-file: LICENSE maintainer: libraries@haskell.org @@ -21,12 +21,12 @@ Language.Haskell.TH.Quote Language.Haskell.TH extensions: MagicHash, PatternGuards, PolymorphicComponents, - DeriveDataTypeable, TypeSynonymInstances + DeriveDataTypeable -- We need to set the package name to template-haskell (without a -- version number) as it's magic. ghc-options: -package-name template-haskell source-repository head - type: darcs - location: http://darcs.haskell.org/packages/template-haskell/ + type: git + location: http://darcs.haskell.org/packages/template-haskell.git/ diff -Nru ghc-7.0.3/libraries/terminfo/ghc.mk ghc-7.2.1/libraries/terminfo/ghc.mk --- ghc-7.0.3/libraries/terminfo/ghc.mk 2011-03-26 18:10:45.000000000 +0000 +++ ghc-7.2.1/libraries/terminfo/ghc.mk 2011-08-07 17:11:00.000000000 +0000 @@ -1,3 +1,4 @@ libraries/terminfo_PACKAGE = terminfo libraries/terminfo_dist-install_GROUP = libraries +$(if $(filter terminfo,$(PACKAGES_STAGE0)),$(eval $(call build-package,libraries/terminfo,dist-boot,0))) $(eval $(call build-package,libraries/terminfo,dist-install,$(if $(filter terminfo,$(STAGE2_PACKAGES)),2,1))) diff -Nru ghc-7.0.3/libraries/time/Data/Time/Format/Parse.hs ghc-7.2.1/libraries/time/Data/Time/Format/Parse.hs --- ghc-7.0.3/libraries/time/Data/Time/Format/Parse.hs 2010-06-22 03:59:49.000000000 +0000 +++ ghc-7.2.1/libraries/time/Data/Time/Format/Parse.hs 2011-05-11 06:47:28.000000000 +0000 @@ -55,20 +55,21 @@ -- If the input does not include all the information needed to -- construct a complete value, any missing parts should be taken -- from 1970-01-01 00:00:00 +0000 (which was a Thursday). + -- In the absence of @%C@ or @%Y@, century is 1969 - 2068. buildTime :: TimeLocale -- ^ The time locale. -> [(Char,String)] -- ^ Pairs of format characters and the -- corresponding part of the input. -> t #if LANGUAGE_Rank2Types --- | Parses a time value given a format string. Supports the same %-codes as --- 'formatTime'. Leading and trailing whitespace is accepted. Case is not --- significant. Some variations in the input are accepted: +-- | Parses a time value given a format string. +-- Supports the same %-codes as 'formatTime', including @%-@, @%_@ and @%0@ modifiers. +-- Leading and trailing whitespace is accepted. Case is not significant. +-- Some variations in the input are accepted: -- -- [@%z@] accepts any of @-HHMM@ or @-HH:MM@. -- --- [@%Z@] accepts any string of letters, or any --- of the formats accepted by @%z@. +-- [@%Z@] accepts any string of letters, or any of the formats accepted by @%z@. -- parseTime :: ParseTime t => TimeLocale -- ^ Time locale. @@ -104,9 +105,12 @@ -- * Internals -- +data Padding = NoPadding | SpacePadding | ZeroPadding + deriving Show + type DateFormat = [DateFormatSpec] -data DateFormatSpec = Value Char +data DateFormatSpec = Value (Maybe Padding) Char | WhiteSpace | Literal Char deriving Show @@ -114,31 +118,33 @@ parseFormat :: TimeLocale -> String -> DateFormat parseFormat l = p where p "" = [] - p ('%': c :cs) = s ++ p cs - where s = case c of - 'c' -> p (dateTimeFmt l) - 'R' -> p "%H:%M" - 'T' -> p "%H:%M:%S" - 'X' -> p (timeFmt l) - 'r' -> p (time12Fmt l) - 'D' -> p "%m/%d/%y" - 'F' -> p "%Y-%m-%d" - 'x' -> p (dateFmt l) - 'h' -> p "%b" - '%' -> [Literal '%'] - _ -> [Value c] + p ('%': '-' : c :cs) = (pc (Just NoPadding) c) ++ p cs + p ('%': '_' : c :cs) = (pc (Just SpacePadding) c) ++ p cs + p ('%': '0' : c :cs) = (pc (Just ZeroPadding) c) ++ p cs + p ('%': c :cs) = (pc Nothing c) ++ p cs p (c:cs) | isSpace c = WhiteSpace : p cs p (c:cs) = Literal c : p cs + pc _ 'c' = p (dateTimeFmt l) + pc _ 'R' = p "%H:%M" + pc _ 'T' = p "%H:%M:%S" + pc _ 'X' = p (timeFmt l) + pc _ 'r' = p (time12Fmt l) + pc _ 'D' = p "%m/%d/%y" + pc _ 'F' = p "%Y-%m-%d" + pc _ 'x' = p (dateFmt l) + pc _ 'h' = p "%b" + pc _ '%' = [Literal '%'] + pc mpad c = [Value mpad c] parseInput :: TimeLocale -> DateFormat -> ReadP [(Char,String)] parseInput l = liftM catMaybes . mapM p - where p (Value c) = parseValue l c >>= return . Just . (,) c + where p (Value mpad c) = parseValue l mpad c >>= return . Just . (,) c p WhiteSpace = skipSpaces >> return Nothing p (Literal c) = char c >> return Nothing -- | Get the string corresponding to the given format specifier. -parseValue :: TimeLocale -> Char -> ReadP String -parseValue l c = +parseValue :: TimeLocale -> Maybe Padding -> Char -> ReadP String +parseValue l mpad c = case c of 'z' -> numericTZ 'Z' -> munch1 isAlpha <++ @@ -146,47 +152,52 @@ return "" -- produced by %Z for LocalTime 'P' -> oneOf (let (am,pm) = amPm l in [am, pm]) 'p' -> oneOf (let (am,pm) = amPm l in [am, pm]) - 'H' -> digits 2 - 'I' -> digits 2 - 'k' -> spdigits 2 - 'l' -> spdigits 2 - 'M' -> digits 2 - 'S' -> digits 2 - 'q' -> digits 12 + 'H' -> digits ZeroPadding 2 + 'I' -> digits ZeroPadding 2 + 'k' -> digits SpacePadding 2 + 'l' -> digits SpacePadding 2 + 'M' -> digits ZeroPadding 2 + 'S' -> digits ZeroPadding 2 + 'q' -> digits ZeroPadding 12 'Q' -> liftM2 (:) (char '.') (munch isDigit) <++ return "" 's' -> (char '-' >> liftM ('-':) (munch1 isDigit)) <++ munch1 isDigit - 'Y' -> digits 4 - 'y' -> digits 2 - 'C' -> digits 2 + 'Y' -> digits ZeroPadding 4 + 'y' -> digits ZeroPadding 2 + 'C' -> digits ZeroPadding 2 'B' -> oneOf (map fst (months l)) 'b' -> oneOf (map snd (months l)) - 'm' -> digits 2 - 'd' -> digits 2 - 'e' -> spdigits 2 - 'j' -> digits 3 - 'G' -> digits 4 - 'g' -> digits 2 - 'f' -> digits 2 - 'V' -> digits 2 + 'm' -> digits ZeroPadding 2 + 'd' -> digits ZeroPadding 2 + 'e' -> digits SpacePadding 2 + 'j' -> digits ZeroPadding 3 + 'G' -> digits ZeroPadding 4 + 'g' -> digits ZeroPadding 2 + 'f' -> digits ZeroPadding 2 + 'V' -> digits ZeroPadding 2 'u' -> oneOf $ map (:[]) ['1'..'7'] 'a' -> oneOf (map snd (wDays l)) 'A' -> oneOf (map fst (wDays l)) - 'U' -> digits 2 + 'U' -> digits ZeroPadding 2 'w' -> oneOf $ map (:[]) ['0'..'6'] - 'W' -> digits 2 + 'W' -> digits ZeroPadding 2 _ -> fail $ "Unknown format character: " ++ show c where oneOf = choice . map string - digits n = count n (satisfy isDigit) - spdigits n = skipSpaces >> upTo n (satisfy isDigit) + digitsforce ZeroPadding n = count n (satisfy isDigit) + digitsforce SpacePadding n = skipSpaces >> oneUpTo n (satisfy isDigit) + digitsforce NoPadding n = oneUpTo n (satisfy isDigit) + digits pad = digitsforce (fromMaybe pad mpad) + oneUpTo :: Int -> ReadP a -> ReadP [a] + oneUpTo 0 _ = pfail + oneUpTo n x = liftM2 (:) x (upTo (n-1) x) upTo :: Int -> ReadP a -> ReadP [a] upTo 0 _ = return [] - upTo n x = liftM2 (:) x (upTo (n-1) x) <++ return [] + upTo n x = (oneUpTo n x) <++ return [] numericTZ = do s <- choice [char '+', char '-'] - h <- digits 2 + h <- digitsforce ZeroPadding 2 optional (char ':') - m <- digits 2 + m <- digitsforce ZeroPadding 2 return (s:h++m) #endif @@ -251,8 +262,9 @@ buildDay cs = rest cs where - y = let c = safeLast 19 [x | Century x <- cs] + y = let d = safeLast 70 [x | Year x <- cs] + c = safeLast (if d >= 69 then 19 else 20) [x | Century x <- cs] in 100 * c + d rest (Month m:_) = let d = safeLast 1 [x | Day x <- cs] diff -Nru ghc-7.0.3/libraries/time/Data/Time/Format.hs ghc-7.2.1/libraries/time/Data/Time/Format.hs --- ghc-7.0.3/libraries/time/Data/Time/Format.hs 2010-06-22 03:59:49.000000000 +0000 +++ ghc-7.2.1/libraries/time/Data/Time/Format.hs 2011-05-11 06:47:28.000000000 +0000 @@ -55,7 +55,7 @@ -- -- For 'TimeZone' (and 'ZonedTime' and 'UTCTime'): -- --- [@%z@] timezone offset on the format @-HHMM@. +-- [@%z@] timezone offset in the format @-HHMM@. -- -- [@%Z@] timezone name -- diff -Nru ghc-7.0.3/libraries/time/ghc.mk ghc-7.2.1/libraries/time/ghc.mk --- ghc-7.0.3/libraries/time/ghc.mk 2011-03-26 18:10:45.000000000 +0000 +++ ghc-7.2.1/libraries/time/ghc.mk 2011-08-07 17:11:00.000000000 +0000 @@ -1,3 +1,4 @@ libraries/time_PACKAGE = time libraries/time_dist-install_GROUP = libraries +$(if $(filter time,$(PACKAGES_STAGE0)),$(eval $(call build-package,libraries/time,dist-boot,0))) $(eval $(call build-package,libraries/time,dist-install,$(if $(filter time,$(STAGE2_PACKAGES)),2,1))) diff -Nru ghc-7.0.3/libraries/time/test/Makefile ghc-7.2.1/libraries/time/test/Makefile --- ghc-7.0.3/libraries/time/test/Makefile 2010-06-22 03:59:49.000000000 +0000 +++ ghc-7.2.1/libraries/time/test/Makefile 2011-05-11 06:47:28.000000000 +0000 @@ -1,5 +1,5 @@ GHC = ghc -GHCFLAGS = -package time +GHCFLAGS = -package time -package QuickCheck-1.2.0.1 default: make CurrentTime.run ShowDST.run test @@ -50,7 +50,7 @@ date +%z > $@ TestParseTime: TestParseTime.o - $(GHC) $(GHCFLAGS) -package QuickCheck $^ -o $@ + $(GHC) $(GHCFLAGS) $^ -o $@ test: \ TestMonthDay.diff \ @@ -64,25 +64,27 @@ TestFormat.diff0 \ TestParseDAT.diff \ TestEaster.diff \ -# TestParseTime.run \ + TestParseTime.run \ UseCases.o + @echo "Success!" clean: rm -rf TestMonthDay ConvertBack TestCalendars TestTime LongWeekYears ClipDates \ AddDays TestFormat TestParseDAT TestEaster CurrentTime ShowDST TimeZone TimeZone.ref TestParseTime \ - *.out *.o *.hi Makefile.bak + *.out *.run *.o *.hi Makefile.bak %.diff: %.ref %.out diff -u $^ %.diff0: %.out - echo -n | diff -u - $^ + diff -u /dev/null $^ %.out: % ./$< > $@ %.run: % ./$< + touch $@ %.hi: %.o @: @@ -97,6 +99,3 @@ .SECONDARY: -# TestTime.o TestFormat.o CurrentTime.o ShowDST.o TimeZone.o: $(patsubst %.hs,%.hi,$(SRCS)) - -TestFixed.o: ../Data/Fixed.hi diff -Nru ghc-7.0.3/libraries/time/test/TestFormat.hs ghc-7.2.1/libraries/time/test/TestFormat.hs --- ghc-7.0.3/libraries/time/test/TestFormat.hs 2010-06-22 03:59:49.000000000 +0000 +++ ghc-7.2.1/libraries/time/test/TestFormat.hs 2011-05-11 06:47:28.000000000 +0000 @@ -9,6 +9,7 @@ import System.Locale import Foreign import Foreign.C +import Control.Exception; {- size_t format_time ( @@ -93,9 +94,66 @@ hashformats :: [String] hashformats = (fmap (\char -> '%':'#':char:[]) chars) +somestrings :: [String] +somestrings = ["", " ", "-", "\n"] + +getBottom :: a -> IO (Maybe Control.Exception.SomeException); +getBottom a = Control.Exception.catch (seq a (return Nothing)) (return . Just); + +safeString :: String -> IO String +safeString s = do + msx <- getBottom s + case msx of + Just sx -> return (show sx) + Nothing -> case s of + (c:cc) -> do + mcx <- getBottom c + case mcx of + Just cx -> return (show cx) + Nothing -> do + ss <- safeString cc + return (c:ss) + [] -> return "" + +compareExpected :: (Eq t,Show t,ParseTime t) => String -> String -> String -> Maybe t -> IO () +compareExpected ts fmt str expected = let + found = parseTime defaultTimeLocale fmt str + in do + mex <- getBottom found + case mex of + Just ex -> putStrLn ("Exception with " ++ fmt ++ " for " ++ ts ++" " ++ (show str) ++ ": expected " ++ (show expected) ++ ", caught " ++ (show ex)) + Nothing -> if found == expected + then return () + else do + sf <- safeString (show found) + putStrLn ("Mismatch with " ++ fmt ++ " for " ++ ts ++" " ++ (show str) ++ ": expected " ++ (show expected) ++ ", found " ++ sf) + +class (ParseTime t) => TestParse t where + expectedParse :: String -> String -> Maybe t + expectedParse "%Z" str | all isSpace str = Just (buildTime defaultTimeLocale []) + expectedParse "%_Z" str | all isSpace str = Just (buildTime defaultTimeLocale []) + expectedParse "%-Z" str | all isSpace str = Just (buildTime defaultTimeLocale []) + expectedParse "%0Z" str | all isSpace str = Just (buildTime defaultTimeLocale []) + expectedParse _ _ = Nothing + +instance TestParse Day +instance TestParse TimeOfDay +instance TestParse LocalTime +instance TestParse TimeZone +instance TestParse ZonedTime +instance TestParse UTCTime + +checkParse :: String -> String -> IO () +checkParse fmt str = do + compareExpected "Day" fmt str (expectedParse fmt str :: Maybe Day) + compareExpected "TimeOfDay" fmt str (expectedParse fmt str :: Maybe TimeOfDay) + compareExpected "LocalTime" fmt str (expectedParse fmt str :: Maybe LocalTime) + compareExpected "TimeZone" fmt str (expectedParse fmt str :: Maybe TimeZone) + compareExpected "UTCTime" fmt str (expectedParse fmt str :: Maybe UTCTime) main :: IO () -main = - mapM_ (\fmt -> mapM_ (\time -> mapM_ (\zone -> compareFormat id fmt zone time) zones) times) formats >> +main = do + mapM_ (\fmt -> mapM_ (checkParse fmt) somestrings) formats + mapM_ (\fmt -> mapM_ (\time -> mapM_ (\zone -> compareFormat id fmt zone time) zones) times) formats mapM_ (\fmt -> mapM_ (\time -> mapM_ (\zone -> compareFormat (fmap toLower) fmt zone time) zones) times) hashformats diff -Nru ghc-7.0.3/libraries/time/test/TestParseTime.hs ghc-7.2.1/libraries/time/test/TestParseTime.hs --- ghc-7.0.3/libraries/time/test/TestParseTime.hs 2010-06-22 03:59:49.000000000 +0000 +++ ghc-7.2.1/libraries/time/test/TestParseTime.hs 2011-05-11 06:47:28.000000000 +0000 @@ -1,34 +1,114 @@ {-# OPTIONS -Wall -Werror -fno-warn-type-defaults -fno-warn-unused-binds -fno-warn-orphans #-} +{-# LANGUAGE FlexibleInstances, ExistentialQuantification #-} import Control.Monad import Data.Char import Data.Ratio +import Data.Maybe import Data.Time import Data.Time.Calendar.OrdinalDate import Data.Time.Calendar.WeekDate import Data.Time.Clock.POSIX import System.Locale +import System.Exit import Test.QuickCheck +import Test.QuickCheck.Batch +class RunTest p where + runTest :: p -> IO TestResult + +instance RunTest (IO TestResult) where + runTest iob = iob + +instance RunTest Property where + runTest p = run p (TestOptions {no_of_tests = 10000,length_of_tests = 0,debug_tests = False}) + +data ExhaustiveTest = forall t. (Show t) => MkExhaustiveTest [t] (t -> IO Bool) + +instance RunTest ExhaustiveTest where + runTest (MkExhaustiveTest cases f) = do + results <- mapM (\t -> do {b <- f t;return (b,show t)}) cases + let failures = mapMaybe (\(b,n) -> if b then Nothing else Just n) results + let fcount = length failures + return (if fcount == 0 then TestOk "OK" 0 [] else TestFailed failures fcount) + ntest :: Int ntest = 1000 main :: IO () -main = do putStrLn "Should work:" - checkAll properties - putStrLn "Known failures:" - checkAll knownFailures - -checkAll :: [NamedProperty] -> IO () -checkAll ps = mapM_ (checkOne config) ps - where config = defaultConfig { configMaxTest = ntest } - -checkOne :: Config -> NamedProperty -> IO () -checkOne config (n,p) = - do putStr (rpad 65 ' ' n) - check config p - where rpad n' c xs = xs ++ replicate (n' - length xs) c +main = do + putStrLn "Should work:" + good1 <- checkAll extests + putStrLn "Should work:" + good2 <- checkAll properties + putStrLn "Known failures:" + _ <- checkAll knownFailures + exitWith (if good1 && good2 then ExitSuccess else ExitFailure 1) + +days2011 :: [Day] +days2011 = [(fromGregorian 2011 1 1) .. (fromGregorian 2011 12 31)] + +extests :: [(String,ExhaustiveTest)] +extests = [ + ("parse %y",MkExhaustiveTest [0..99] parseYY), + ("parse %C %y 1900s",MkExhaustiveTest [0..99] (parseCYY 19)), + ("parse %C %y 2000s",MkExhaustiveTest [0..99] (parseCYY 20)), + ("parse %C %y 1400s",MkExhaustiveTest [0..99] (parseCYY 14)), + ("parse %C %y 700s",MkExhaustiveTest [0..99] (parseCYY 7)), + ("parse %Y%m%d",MkExhaustiveTest days2011 parseYMD), + ("parse %Y %m %d",MkExhaustiveTest days2011 parseYearDayD), + ("parse %Y %-m %e",MkExhaustiveTest days2011 parseYearDayE) + ] + +parseYMD :: Day -> IO Bool +parseYMD day = case toGregorian day of + (y,m,d) -> return $ (parse "%Y%m%d" ((show y) ++ (show2 m) ++ (show2 d))) == Just day + +parseYearDayD :: Day -> IO Bool +parseYearDayD day = case toGregorian day of + (y,m,d) -> return $ (parse "%Y %m %d" ((show y) ++ " " ++ (show2 m) ++ " " ++ (show2 d))) == Just day + +parseYearDayE :: Day -> IO Bool +parseYearDayE day = case toGregorian day of + (y,m,d) -> return $ (parse "%Y %-m %e" ((show y) ++ " " ++ (show m) ++ " " ++ (show d))) == Just day + +-- | 1969 - 2068 +expectedYear :: Integer -> Integer +expectedYear i | i >= 69 = 1900 + i +expectedYear i = 2000 + i + +show2 :: (Integral n) => n -> String +show2 i = (show (div i 10)) ++ (show (mod i 10)) + +parseYY :: Integer -> IO Bool +parseYY i = return (parse "%y" (show2 i) == Just (fromGregorian (expectedYear i) 1 1)) + +parseCYY :: Integer -> Integer -> IO Bool +parseCYY c i = return (parse "%C %y" ((show2 c) ++ " " ++ (show2 i)) == Just (fromGregorian ((c * 100) + i) 1 1)) + +checkAll :: RunTest p => [(String,p)] -> IO Bool +checkAll ps = fmap and (mapM checkOne ps) + +trMessage :: TestResult -> String +trMessage (TestOk s _ _) = s +trMessage (TestExausted s i ss) = "Exhausted " ++ (show s) ++ " " ++ (show i) ++ " " ++ (show ss) +trMessage (TestFailed ss i) = "Failed " ++ (show ss) ++ " " ++ (show i) +trMessage (TestAborted ex) = "Aborted " ++ (show ex) + +trGood :: TestResult -> Bool +trGood (TestOk _ _ _) = True +trGood _ = False + +checkOne :: RunTest p => (String,p) -> IO Bool +checkOne (n,p) = + do + putStr (rpad 65 ' ' n) + tr <- runTest p + putStrLn (trMessage tr) + return (trGood tr) + where + rpad n' c xs = xs ++ replicate (n' - length xs) c parse :: ParseTime t => String -> String -> Maybe t diff -Nru ghc-7.0.3/libraries/time/test/TimeZone.ref ghc-7.2.1/libraries/time/test/TimeZone.ref --- ghc-7.0.3/libraries/time/test/TimeZone.ref 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/time/test/TimeZone.ref 2011-05-11 06:47:28.000000000 +0000 @@ -0,0 +1 @@ +-0700 diff -Nru ghc-7.0.3/libraries/time/time.cabal ghc-7.2.1/libraries/time/time.cabal --- ghc-7.0.3/libraries/time/time.cabal 2010-06-22 03:59:49.000000000 +0000 +++ ghc-7.2.1/libraries/time/time.cabal 2011-05-11 06:47:28.000000000 +0000 @@ -1,5 +1,5 @@ name: time -version: 1.2.0.3 +version: 1.2.0.5 stability: stable license: BSD3 license-file: LICENSE diff -Nru ghc-7.0.3/libraries/unix/configure ghc-7.2.1/libraries/unix/configure --- ghc-7.0.3/libraries/unix/configure 2011-03-26 18:11:04.000000000 +0000 +++ ghc-7.2.1/libraries/unix/configure 2011-08-07 17:11:20.000000000 +0000 @@ -3804,7 +3804,7 @@ done -for ac_header in libutil.h pty.h utmp.h +for ac_header in bsd/libutil.h libutil.h pty.h utmp.h do : as_ac_Header=`$as_echo "ac_cv_header_$ac_header" | $as_tr_sh` ac_fn_c_check_header_mongrel "$LINENO" "$ac_header" "$as_ac_Header" "$ac_includes_default" diff -Nru ghc-7.0.3/libraries/unix/configure.ac ghc-7.2.1/libraries/unix/configure.ac --- ghc-7.0.3/libraries/unix/configure.ac 2011-03-26 18:10:15.000000000 +0000 +++ ghc-7.2.1/libraries/unix/configure.ac 2011-08-07 17:10:12.000000000 +0000 @@ -23,7 +23,7 @@ AC_CHECK_HEADERS([dirent.h fcntl.h grp.h limits.h pwd.h signal.h string.h]) AC_CHECK_HEADERS([sys/resource.h sys/stat.h sys/times.h sys/time.h]) AC_CHECK_HEADERS([sys/utsname.h sys/wait.h]) -AC_CHECK_HEADERS([libutil.h pty.h utmp.h]) +AC_CHECK_HEADERS([bsd/libutil.h libutil.h pty.h utmp.h]) AC_CHECK_HEADERS([termios.h time.h unistd.h utime.h]) AC_CHECK_FUNCS([getgrgid_r getgrnam_r getpwnam_r getpwuid_r getpwnam getpwuid]) diff -Nru ghc-7.0.3/libraries/unix/ghc.mk ghc-7.2.1/libraries/unix/ghc.mk --- ghc-7.0.3/libraries/unix/ghc.mk 2011-03-26 18:10:45.000000000 +0000 +++ ghc-7.2.1/libraries/unix/ghc.mk 2011-08-07 17:11:00.000000000 +0000 @@ -1,3 +1,4 @@ libraries/unix_PACKAGE = unix libraries/unix_dist-install_GROUP = libraries +$(if $(filter unix,$(PACKAGES_STAGE0)),$(eval $(call build-package,libraries/unix,dist-boot,0))) $(eval $(call build-package,libraries/unix,dist-install,$(if $(filter unix,$(STAGE2_PACKAGES)),2,1))) diff -Nru ghc-7.0.3/libraries/unix/.gitignore ghc-7.2.1/libraries/unix/.gitignore --- ghc-7.0.3/libraries/unix/.gitignore 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/unix/.gitignore 2011-08-07 17:10:12.000000000 +0000 @@ -0,0 +1,11 @@ +# Specific generated files +GNUmakefile +autom4te.cache/ +config.log +config.status +configure +dist-install/ +ghc.mk +include/HsUnixConfig.h +include/HsUnixConfig.h.in +unix.buildinfo \ No newline at end of file diff -Nru ghc-7.0.3/libraries/unix/include/HsUnixConfig.h.in ghc-7.2.1/libraries/unix/include/HsUnixConfig.h.in --- ghc-7.0.3/libraries/unix/include/HsUnixConfig.h.in 2011-03-26 18:11:04.000000000 +0000 +++ ghc-7.2.1/libraries/unix/include/HsUnixConfig.h.in 2011-08-07 17:11:20.000000000 +0000 @@ -93,6 +93,9 @@ /* The value of SIG_UNBLOCK. */ #undef CONST_SIG_UNBLOCK +/* Define to 1 if you have the header file. */ +#undef HAVE_BSD_LIBUTIL_H + /* Define if we have /dev/ptc. */ #undef HAVE_DEV_PTC diff -Nru ghc-7.0.3/libraries/unix/include/HsUnix.h ghc-7.2.1/libraries/unix/include/HsUnix.h --- ghc-7.0.3/libraries/unix/include/HsUnix.h 2011-03-26 18:10:15.000000000 +0000 +++ ghc-7.2.1/libraries/unix/include/HsUnix.h 2011-08-07 17:10:12.000000000 +0000 @@ -75,7 +75,9 @@ #include #endif -#ifdef HAVE_LIBUTIL_H +#if defined(HAVE_BSD_LIBUTIL_H) +#include +#elif defined(HAVE_LIBUTIL_H) #include #endif #ifdef HAVE_PTY_H diff -Nru ghc-7.0.3/libraries/unix/System/Posix/Directory.hsc ghc-7.2.1/libraries/unix/System/Posix/Directory.hsc --- ghc-7.0.3/libraries/unix/System/Posix/Directory.hsc 2011-03-26 18:10:15.000000000 +0000 +++ ghc-7.2.1/libraries/unix/System/Posix/Directory.hsc 2011-08-07 17:10:12.000000000 +0000 @@ -39,14 +39,30 @@ import System.Posix.Types import Foreign import Foreign.C +#if __GLASGOW_HASKELL__ > 700 +import System.Posix.Internals (withFilePath, peekFilePath) +#elif __GLASGOW_HASKELL__ > 611 +import System.Posix.Internals (withFilePath) + +peekFilePath :: CString -> IO FilePath +peekFilePath = peekCString +#else +withFilePath :: FilePath -> (CString -> IO a) -> IO a +withFilePath = withCString + +peekFilePath :: CString -> IO FilePath +peekFilePath = peekCString +#endif -- | @createDirectory dir mode@ calls @mkdir@ to -- create a new directory, @dir@, with permissions based on -- @mode@. createDirectory :: FilePath -> FileMode -> IO () createDirectory name mode = - withCString name $ \s -> - throwErrnoPathIfMinus1_ "createDirectory" name (c_mkdir s mode) + withFilePath name $ \s -> + throwErrnoPathIfMinus1Retry_ "createDirectory" name (c_mkdir s mode) + -- POSIX doesn't allow mkdir() to return EINTR, but it does on + -- OS X (#5184), so we need the Retry variant here. foreign import ccall unsafe "mkdir" c_mkdir :: CString -> CMode -> IO CInt @@ -57,8 +73,8 @@ -- directory stream for @dir@. openDirStream :: FilePath -> IO DirStream openDirStream name = - withCString name $ \s -> do - dirp <- throwErrnoPathIfNull "openDirStream" name $ c_opendir s + withFilePath name $ \s -> do + dirp <- throwErrnoPathIfNullRetry "openDirStream" name $ c_opendir s return (DirStream dirp) foreign import ccall unsafe "__hsunix_opendir" @@ -80,7 +96,7 @@ if (dEnt == nullPtr) then return [] else do - entry <- (d_name dEnt >>= peekCString) + entry <- (d_name dEnt >>= peekFilePath) c_freeDirEnt dEnt return entry else do errno <- getErrno @@ -115,7 +131,7 @@ -- the directory stream @dp@. closeDirStream :: DirStream -> IO () closeDirStream (DirStream dirp) = do - throwErrnoIfMinus1_ "closeDirStream" (c_closedir dirp) + throwErrnoIfMinus1Retry_ "closeDirStream" (c_closedir dirp) foreign import ccall unsafe "closedir" c_closedir :: Ptr CDir -> IO CInt @@ -152,7 +168,7 @@ where go p bytes = do p' <- c_getcwd p (fromIntegral bytes) if p' /= nullPtr - then do s <- peekCString p' + then do s <- peekFilePath p' free p' return s else do errno <- getErrno @@ -173,7 +189,7 @@ changeWorkingDirectory :: FilePath -> IO () changeWorkingDirectory path = modifyIOError (`ioeSetFileName` path) $ - withCString path $ \s -> + withFilePath path $ \s -> throwErrnoIfMinus1Retry_ "changeWorkingDirectory" (c_chdir s) foreign import ccall unsafe "chdir" @@ -182,7 +198,7 @@ removeDirectory :: FilePath -> IO () removeDirectory path = modifyIOError (`ioeSetFileName` path) $ - withCString path $ \s -> + withFilePath path $ \s -> throwErrnoIfMinus1Retry_ "removeDirectory" (c_rmdir s) foreign import ccall unsafe "rmdir" @@ -190,7 +206,7 @@ changeWorkingDirectoryFd :: Fd -> IO () changeWorkingDirectoryFd (Fd fd) = - throwErrnoIfMinus1_ "changeWorkingDirectoryFd" (c_fchdir fd) + throwErrnoIfMinus1Retry_ "changeWorkingDirectoryFd" (c_fchdir fd) foreign import ccall unsafe "fchdir" c_fchdir :: CInt -> IO CInt diff -Nru ghc-7.0.3/libraries/unix/System/Posix/DynamicLinker/Module.hsc ghc-7.2.1/libraries/unix/System/Posix/DynamicLinker/Module.hsc --- ghc-7.0.3/libraries/unix/System/Posix/DynamicLinker/Module.hsc 2011-03-26 18:10:15.000000000 +0000 +++ ghc-7.2.1/libraries/unix/System/Posix/DynamicLinker/Module.hsc 2011-08-07 17:10:12.000000000 +0000 @@ -58,8 +58,15 @@ import System.Posix.DynamicLinker import Foreign.Ptr ( Ptr, nullPtr, FunPtr ) +#if __GLASGOW_HASKELL__ > 611 +import System.Posix.Internals ( withFilePath ) +#else import Foreign.C.String ( withCString ) +withFilePath :: FilePath -> (CString -> IO a) -> IO a +withFilePath = withCString +#endif + -- abstract handle for dynamically loaded module (EXPORTED) -- newtype Module = Module (Ptr ()) @@ -72,7 +79,7 @@ moduleOpen :: String -> [RTLDFlags] -> IO Module moduleOpen file flags = do - modPtr <- withCString file $ \ modAddr -> c_dlopen modAddr (packRTLDFlags flags) + modPtr <- withFilePath file $ \ modAddr -> c_dlopen modAddr (packRTLDFlags flags) if (modPtr == nullPtr) then moduleError >>= \ err -> ioError (userError ("dlopen: " ++ err)) else return $ Module modPtr diff -Nru ghc-7.0.3/libraries/unix/System/Posix/DynamicLinker.hsc ghc-7.2.1/libraries/unix/System/Posix/DynamicLinker.hsc --- ghc-7.0.3/libraries/unix/System/Posix/DynamicLinker.hsc 2011-03-26 18:10:15.000000000 +0000 +++ ghc-7.2.1/libraries/unix/System/Posix/DynamicLinker.hsc 2011-08-07 17:10:12.000000000 +0000 @@ -51,11 +51,17 @@ import Control.Exception ( bracket ) import Control.Monad ( liftM ) import Foreign.Ptr ( Ptr, nullPtr, FunPtr, nullFunPtr ) -import Foreign.C.String ( withCString, peekCString ) +import Foreign.C.String +#if __GLASGOW_HASKELL__ > 611 +import System.Posix.Internals ( withFilePath ) +#else +withFilePath :: FilePath -> (CString -> IO a) -> IO a +withFilePath = withCString +#endif -dlopen :: String -> [RTLDFlags] -> IO DL +dlopen :: FilePath -> [RTLDFlags] -> IO DL dlopen path flags = do - withCString path $ \ p -> do + withFilePath path $ \ p -> do liftM DLHandle $ throwDLErrorIf "dlopen" (== nullPtr) $ c_dlopen p (packRTLDFlags flags) dlclose :: DL -> IO () @@ -70,7 +76,7 @@ dlsym :: DL -> String -> IO (FunPtr a) dlsym source symbol = do - withCString symbol $ \ s -> do + withCAString symbol $ \ s -> do throwDLErrorIf "dlsym" (== nullFunPtr) $ c_dlsym (packDL source) s withDL :: String -> [RTLDFlags] -> (DL -> IO a) -> IO a diff -Nru ghc-7.0.3/libraries/unix/System/Posix/Env.hsc ghc-7.2.1/libraries/unix/System/Posix/Env.hsc --- ghc-7.0.3/libraries/unix/System/Posix/Env.hsc 2011-03-26 18:10:15.000000000 +0000 +++ ghc-7.2.1/libraries/unix/System/Posix/Env.hsc 2011-08-07 17:10:12.000000000 +0000 @@ -33,14 +33,28 @@ import Foreign.Storable import Control.Monad ( liftM ) import Data.Maybe ( fromMaybe ) +#if __GLASGOW_HASKELL__ > 700 +import System.Posix.Internals (withFilePath, peekFilePath) +#elif __GLASGOW_HASKELL__ > 611 +import System.Posix.Internals (withFilePath) + +peekFilePath :: CString -> IO FilePath +peekFilePath = peekCString +#else +withFilePath :: FilePath -> (CString -> IO a) -> IO a +withFilePath = withCString + +peekFilePath :: CString -> IO FilePath +peekFilePath = peekCString +#endif -- |'getEnv' looks up a variable in the environment. getEnv :: String -> IO (Maybe String) getEnv name = do - litstring <- withCString name c_getenv + litstring <- withFilePath name c_getenv if litstring /= nullPtr - then liftM Just $ peekCString litstring + then liftM Just $ peekFilePath litstring else return Nothing -- |'getEnvDefault' is a wrapper around 'getEnv' where the @@ -55,12 +69,24 @@ getEnvironmentPrim :: IO [String] getEnvironmentPrim = do - c_environ <- peek c_environ_p + c_environ <- getCEnviron arr <- peekArray0 nullPtr c_environ - mapM peekCString arr + mapM peekFilePath arr + +getCEnviron :: IO (Ptr CString) +#if darwin_HOST_OS +-- You should not access _environ directly on Darwin in a bundle/shared library. +-- See #2458 and http://developer.apple.com/library/mac/#documentation/Darwin/Reference/ManPages/man7/environ.7.html +getCEnviron = nsGetEnviron >>= peek + +foreign import ccall unsafe "_NSGetEnviron" + nsGetEnviron :: IO (Ptr (Ptr CString)) +#else +getCEnviron = peek c_environ_p foreign import ccall unsafe "&environ" c_environ_p :: Ptr (Ptr CString) +#endif -- |'getEnvironment' retrieves the entire environment as a -- list of @(key,value)@ pairs. @@ -79,7 +105,7 @@ unsetEnv :: String -> IO () #ifdef HAVE_UNSETENV -unsetEnv name = withCString name $ \ s -> +unsetEnv name = withFilePath name $ \ s -> throwErrnoIfMinus1_ "unsetenv" (c_unsetenv s) foreign import ccall unsafe "__hsunix_unsetenv" @@ -92,7 +118,7 @@ -- and is equivalent to @setEnv(key,value,True{-overwrite-})@. putEnv :: String -> IO () -putEnv keyvalue = withCString keyvalue $ \s -> +putEnv keyvalue = withFilePath keyvalue $ \s -> throwErrnoIfMinus1_ "putenv" (c_putenv s) foreign import ccall unsafe "putenv" @@ -108,8 +134,8 @@ setEnv :: String -> String -> Bool {-overwrite-} -> IO () #ifdef HAVE_SETENV setEnv key value ovrwrt = do - withCString key $ \ keyP -> - withCString value $ \ valueP -> + withFilePath key $ \ keyP -> + withFilePath value $ \ valueP -> throwErrnoIfMinus1_ "setenv" $ c_setenv keyP valueP (fromIntegral (fromEnum ovrwrt)) diff -Nru ghc-7.0.3/libraries/unix/System/Posix/Error.hs ghc-7.2.1/libraries/unix/System/Posix/Error.hs --- ghc-7.0.3/libraries/unix/System/Posix/Error.hs 2011-03-26 18:10:15.000000000 +0000 +++ ghc-7.2.1/libraries/unix/System/Posix/Error.hs 2011-08-07 17:10:12.000000000 +0000 @@ -21,7 +21,8 @@ throwErrnoPathIfNullRetry, throwErrnoPathIfMinus1, throwErrnoPathIfMinus1_, - throwErrnoPathIfMinus1Retry + throwErrnoPathIfMinus1Retry, + throwErrnoPathIfMinus1Retry_ ) where import Foreign @@ -31,6 +32,10 @@ throwErrnoPathIfMinus1Retry loc path f = throwErrnoPathIfRetry (== -1) loc path f +throwErrnoPathIfMinus1Retry_ :: Num a => String -> FilePath -> IO a -> IO () +throwErrnoPathIfMinus1Retry_ loc path f = + void $ throwErrnoPathIfRetry (== -1) loc path f + throwErrnoPathIfNullRetry :: String -> FilePath -> IO (Ptr a) -> IO (Ptr a) throwErrnoPathIfNullRetry loc path f = throwErrnoPathIfRetry (== nullPtr) loc path f diff -Nru ghc-7.0.3/libraries/unix/System/Posix/Files.hsc ghc-7.2.1/libraries/unix/System/Posix/Files.hsc --- ghc-7.0.3/libraries/unix/System/Posix/Files.hsc 2011-03-26 18:10:15.000000000 +0000 +++ ghc-7.2.1/libraries/unix/System/Posix/Files.hsc 2011-08-07 17:10:12.000000000 +0000 @@ -24,6 +24,8 @@ -- ----------------------------------------------------------------------------- +#include "HsUnix.h" + module System.Posix.Files ( -- * File modes -- FileMode exported by System.Posix.Types @@ -84,8 +86,6 @@ PathVar(..), getPathVar, getFdPathVar, ) where -#include "HsUnix.h" - import System.Posix.Error import System.Posix.Types import System.IO.Unsafe @@ -93,6 +93,26 @@ import System.Posix.Internals import Foreign hiding (unsafePerformIO) import Foreign.C +#if __GLASGOW_HASKELL__ > 700 +import System.Posix.Internals (withFilePath, peekFilePath) +#elif __GLASGOW_HASKELL__ > 611 +import System.Posix.Internals (withFilePath) + +peekFilePath :: CString -> IO FilePath +peekFilePath = peekCString + +peekFilePathLen :: CStringLen -> IO FilePath +peekFilePathLen = peekCStringLen +#else +withFilePath :: FilePath -> (CString -> IO a) -> IO a +withFilePath = withCString + +peekFilePath :: CString -> IO FilePath +peekFilePath = peekCString + +peekFilePathLen :: CStringLen -> IO FilePath +peekFilePathLen = peekCStringLen +#endif -- ----------------------------------------------------------------------------- -- POSIX file modes @@ -212,7 +232,7 @@ -- Note: calls @chmod@. setFileMode :: FilePath -> FileMode -> IO () setFileMode name m = - withCString name $ \s -> do + withFilePath name $ \s -> do throwErrnoPathIfMinus1_ "setFileMode" name (c_chmod s m) -- | @setFdMode fd mode@ acts like 'setFileMode' but uses a file descriptor @@ -255,7 +275,7 @@ -- Note: calls @access@. fileExist :: FilePath -> IO Bool fileExist name = - withCString name $ \s -> do + withFilePath name $ \s -> do r <- c_access s (#const F_OK) if (r == 0) then return True @@ -266,7 +286,7 @@ access :: FilePath -> CMode -> IO Bool access name flags = - withCString name $ \s -> do + withFilePath name $ \s -> do r <- c_access s (fromIntegral flags) if (r == 0) then return True @@ -370,7 +390,7 @@ getFileStatus path = do fp <- mallocForeignPtrBytes (#const sizeof(struct stat)) withForeignPtr fp $ \p -> - withCString path $ \s -> + withFilePath path $ \s -> throwErrnoPathIfMinus1_ "getFileStatus" path (c_stat s p) return (FileStatus fp) @@ -393,7 +413,7 @@ getSymbolicLinkStatus path = do fp <- mallocForeignPtrBytes (#const sizeof(struct stat)) withForeignPtr fp $ \p -> - withCString path $ \s -> + withFilePath path $ \s -> throwErrnoPathIfMinus1_ "getSymbolicLinkStatus" path (c_lstat s p) return (FileStatus fp) @@ -409,7 +429,7 @@ -- Note: calls @mkfifo@. createNamedPipe :: FilePath -> FileMode -> IO () createNamedPipe name mode = do - withCString name $ \s -> + withFilePath name $ \s -> throwErrnoPathIfMinus1_ "createNamedPipe" name (c_mkfifo s mode) -- | @createDevice path mode dev@ creates either a regular or a special file @@ -422,7 +442,7 @@ -- Note: calls @mknod@. createDevice :: FilePath -> FileMode -> DeviceID -> IO () createDevice path mode dev = - withCString path $ \s -> + withFilePath path $ \s -> throwErrnoPathIfMinus1_ "createDevice" path (c_mknod s mode dev) foreign import ccall unsafe "__hsunix_mknod" @@ -437,8 +457,8 @@ -- Note: calls @link@. createLink :: FilePath -> FilePath -> IO () createLink name1 name2 = - withCString name1 $ \s1 -> - withCString name2 $ \s2 -> + withFilePath name1 $ \s1 -> + withFilePath name2 $ \s2 -> throwErrnoPathIfMinus1_ "createLink" name1 (c_link s1 s2) -- | @removeLink path@ removes the link named @path@. @@ -446,7 +466,7 @@ -- Note: calls @unlink@. removeLink :: FilePath -> IO () removeLink name = - withCString name $ \s -> + withFilePath name $ \s -> throwErrnoPathIfMinus1_ "removeLink" name (c_unlink s) -- ----------------------------------------------------------------------------- @@ -461,8 +481,8 @@ -- Note: calls @symlink@. createSymbolicLink :: FilePath -> FilePath -> IO () createSymbolicLink file1 file2 = - withCString file1 $ \s1 -> - withCString file2 $ \s2 -> + withFilePath file1 $ \s1 -> + withFilePath file2 $ \s2 -> throwErrnoPathIfMinus1_ "createSymbolicLink" file1 (c_symlink s1 s2) foreign import ccall unsafe "symlink" @@ -483,10 +503,10 @@ readSymbolicLink :: FilePath -> IO FilePath readSymbolicLink file = allocaArray0 (#const PATH_MAX) $ \buf -> do - withCString file $ \s -> do + withFilePath file $ \s -> do len <- throwErrnoPathIfMinus1 "readSymbolicLink" file $ c_readlink s buf (#const PATH_MAX) - peekCStringLen (buf,fromIntegral len) + peekFilePathLen (buf,fromIntegral len) foreign import ccall unsafe "readlink" c_readlink :: CString -> CString -> CSize -> IO CInt @@ -499,8 +519,8 @@ -- Note: calls @rename@. rename :: FilePath -> FilePath -> IO () rename name1 name2 = - withCString name1 $ \s1 -> - withCString name2 $ \s2 -> + withFilePath name1 $ \s1 -> + withFilePath name2 $ \s2 -> throwErrnoPathIfMinus1_ "rename" name1 (c_rename s1 s2) foreign import ccall unsafe "rename" @@ -517,7 +537,7 @@ -- Note: calls @chown@. setOwnerAndGroup :: FilePath -> UserID -> GroupID -> IO () setOwnerAndGroup name uid gid = do - withCString name $ \s -> + withFilePath name $ \s -> throwErrnoPathIfMinus1_ "setOwnerAndGroup" name (c_chown s uid gid) foreign import ccall unsafe "chown" @@ -541,7 +561,7 @@ -- Note: calls @lchown@. setSymbolicLinkOwnerAndGroup :: FilePath -> UserID -> GroupID -> IO () setSymbolicLinkOwnerAndGroup name uid gid = do - withCString name $ \s -> + withFilePath name $ \s -> throwErrnoPathIfMinus1_ "setSymbolicLinkOwnerAndGroup" name (c_lchown s uid gid) @@ -558,7 +578,7 @@ -- Note: calls @utime@. setFileTimes :: FilePath -> EpochTime -> EpochTime -> IO () setFileTimes name atime mtime = do - withCString name $ \s -> + withFilePath name $ \s -> allocaBytes (#const sizeof(struct utimbuf)) $ \p -> do (#poke struct utimbuf, actime) p atime (#poke struct utimbuf, modtime) p mtime @@ -570,7 +590,7 @@ -- Note: calls @utime@. touchFile :: FilePath -> IO () touchFile name = do - withCString name $ \s -> + withFilePath name $ \s -> throwErrnoPathIfMinus1_ "touchFile" name (c_utime s nullPtr) -- ----------------------------------------------------------------------------- @@ -582,7 +602,7 @@ -- Note: calls @truncate@. setFileSize :: FilePath -> FileOffset -> IO () setFileSize file off = - withCString file $ \s -> + withFilePath file $ \s -> throwErrnoPathIfMinus1_ "setFileSize" file (c_truncate s off) foreign import ccall unsafe "truncate" @@ -672,7 +692,7 @@ -- Note: calls @pathconf@. getPathVar :: FilePath -> PathVar -> IO Limit getPathVar name v = do - withCString name $ \ nameP -> + withFilePath name $ \ nameP -> throwErrnoPathIfMinus1 "getPathVar" name $ c_pathconf nameP (pathVarConst v) diff -Nru ghc-7.0.3/libraries/unix/System/Posix/IO.hsc ghc-7.2.1/libraries/unix/System/Posix/IO.hsc --- ghc-7.0.3/libraries/unix/System/Posix/IO.hsc 2011-03-26 18:10:15.000000000 +0000 +++ ghc-7.2.1/libraries/unix/System/Posix/IO.hsc 2011-08-07 17:10:12.000000000 +0000 @@ -94,6 +94,13 @@ import qualified Hugs.IO (handleToFd, openFd) #endif +#if __GLASGOW_HASKELL__ > 611 +import System.Posix.Internals ( withFilePath ) +#else +withFilePath :: FilePath -> (CString -> IO a) -> IO a +withFilePath = withCString +#endif + #include "HsUnix.h" -- ----------------------------------------------------------------------------- @@ -178,7 +185,7 @@ -> IO Fd openFd name how maybe_mode (OpenFileFlags appendFlag exclusiveFlag nocttyFlag nonBlockFlag truncateFlag) = do - withCString name $ \s -> do + withFilePath name $ \s -> do fd <- throwErrnoPathIfMinus1Retry "openFd" name (c_open s all_flags mode_w) return (Fd fd) where @@ -259,7 +266,7 @@ -- state as a result. flushWriteBuffer h_ FD.release fd - return (Handle__{haType=ClosedHandle,..}, Fd (fromIntegral (FD.fdFD fd))) + return (Handle__{haType=ClosedHandle,..}, Fd (FD.fdFD fd)) fdToHandle fd = FD.fdToHandle (fromIntegral fd) @@ -424,8 +431,8 @@ -- ----------------------------------------------------------------------------- -- fd{Read,Write} --- | Read data from an 'Fd' and convert it to a 'String'. Throws an --- exception if this is an invalid descriptor, or EOF has been +-- | Read data from an 'Fd' and convert it to a 'String' using the locale encoding. +-- Throws an exception if this is an invalid descriptor, or EOF has been -- reached. fdRead :: Fd -> ByteCount -- ^How many bytes to read @@ -434,7 +441,7 @@ fdRead fd nbytes = do allocaBytes (fromIntegral nbytes) $ \ buf -> do rc <- fdReadBuf fd buf nbytes - case fromIntegral rc of + case rc of 0 -> ioError (ioeSetErrorString (mkIOError EOF "fdRead" Nothing Nothing) "EOF") n -> do s <- peekCStringLen (castPtr buf, fromIntegral n) @@ -450,18 +457,16 @@ fdReadBuf fd buf nbytes = fmap fromIntegral $ throwErrnoIfMinus1Retry "fdReadBuf" $ - c_safe_read (fromIntegral fd) (castPtr buf) (fromIntegral nbytes) + c_safe_read (fromIntegral fd) (castPtr buf) nbytes foreign import ccall safe "read" c_safe_read :: CInt -> Ptr CChar -> CSize -> IO CSsize --- | Write a 'String' to an 'Fd' (no character conversion is done, --- the least-significant 8 bits of each character are written). +-- | Write a 'String' to an 'Fd' using the locale encoding. fdWrite :: Fd -> String -> IO ByteCount fdWrite fd str = - withCStringLen str $ \ (buf,len) -> do - rc <- fdWriteBuf fd (castPtr buf) (fromIntegral len) - return (fromIntegral rc) + withCStringLen str $ \ (buf,len) -> + fdWriteBuf fd (castPtr buf) (fromIntegral len) -- | Write data from memory to an 'Fd'. This is exactly equivalent -- to the POSIX @write@ function. @@ -472,7 +477,7 @@ fdWriteBuf fd buf len = fmap fromIntegral $ throwErrnoIfMinus1Retry "fdWriteBuf" $ - c_safe_write (fromIntegral fd) (castPtr buf) (fromIntegral len) + c_safe_write (fromIntegral fd) (castPtr buf) len foreign import ccall safe "write" c_safe_write :: CInt -> Ptr CChar -> CSize -> IO CSsize diff -Nru ghc-7.0.3/libraries/unix/System/Posix/Process/Internals.hs ghc-7.2.1/libraries/unix/System/Posix/Process/Internals.hs --- ghc-7.0.3/libraries/unix/System/Posix/Process/Internals.hs 2011-03-26 18:10:15.000000000 +0000 +++ ghc-7.2.1/libraries/unix/System/Posix/Process/Internals.hs 2011-08-07 17:10:12.000000000 +0000 @@ -34,12 +34,12 @@ if c_WIFSIGNALED wstat /= 0 then do let termsig = c_WTERMSIG wstat - return (Terminated (fromIntegral termsig)) + return (Terminated termsig) else do if c_WIFSTOPPED wstat /= 0 then do let stopsig = c_WSTOPSIG wstat - return (Stopped (fromIntegral stopsig)) + return (Stopped stopsig) else do ioError (mkIOError illegalOperationErrorType "waitStatus" Nothing Nothing) diff -Nru ghc-7.0.3/libraries/unix/System/Posix/Process.hsc ghc-7.2.1/libraries/unix/System/Posix/Process.hsc --- ghc-7.0.3/libraries/unix/System/Posix/Process.hsc 2011-03-26 18:10:15.000000000 +0000 +++ ghc-7.2.1/libraries/unix/System/Posix/Process.hsc 2011-08-07 17:10:12.000000000 +0000 @@ -29,12 +29,13 @@ -- ** Process environment getProcessID, getParentProcessID, - getProcessGroupID, -- ** Process groups - createProcessGroup, + getProcessGroupID, + getProcessGroupIDOf, + createProcessGroupFor, joinProcessGroup, - setProcessGroupID, + setProcessGroupIDOf, -- ** Sessions createSession, @@ -58,12 +59,16 @@ getAnyProcessStatus, getGroupProcessStatus, + -- ** Deprecated + createProcessGroup, + setProcessGroupID, + ) where #include "HsUnix.h" import Foreign.C.Error -import Foreign.C.String ( CString, withCString ) +import Foreign.C.String import Foreign.C.Types ( CInt, CClock ) import Foreign.Marshal.Alloc ( alloca, allocaBytes ) import Foreign.Marshal.Array ( withArray0 ) @@ -80,6 +85,13 @@ import GHC.TopHandler ( runIO ) #endif +#if __GLASGOW_HASKELL__ > 611 +import System.Posix.Internals ( withFilePath ) +#else +withFilePath :: FilePath -> (CString -> IO a) -> IO a +withFilePath = withCString +#endif + #ifdef __HUGS__ {-# CFILES cbits/HsUnix.c #-} #endif @@ -111,11 +123,33 @@ foreign import ccall unsafe "getpgrp" c_getpgrp :: IO CPid --- | @'createProcessGroup' pid@ calls @setpgid@ to make +-- | @'getProcessGroupIDOf' pid@ calls @getpgid@ to obtain the +-- 'ProcessGroupID' for process @pid@. +getProcessGroupIDOf :: ProcessID -> IO ProcessGroupID +getProcessGroupIDOf pid = + throwErrnoIfMinus1 "getProcessGroupIDOf" (c_getpgid pid) + +foreign import ccall unsafe "getpgid" + c_getpgid :: CPid -> IO CPid + +{- + To be added in the future, after the deprecation period for the + existing createProcessGroup has elapsed: + +-- | 'createProcessGroup' calls @setpgid(0,0)@ to make +-- the current process a new process group leader. +createProcessGroup :: IO ProcessGroupID +createProcessGroup = do + throwErrnoIfMinus1_ "createProcessGroup" (c_setpgid 0 0) + pgid <- getProcessGroupID + return pgid +-} + +-- | @'createProcessGroupFor' pid@ calls @setpgid@ to make -- process @pid@ a new process group leader. -createProcessGroup :: ProcessID -> IO ProcessGroupID -createProcessGroup pid = do - throwErrnoIfMinus1_ "createProcessGroup" (c_setpgid pid 0) +createProcessGroupFor :: ProcessID -> IO ProcessGroupID +createProcessGroupFor pid = do + throwErrnoIfMinus1_ "createProcessGroupFor" (c_setpgid pid 0) return pid -- | @'joinProcessGroup' pgid@ calls @setpgid@ to set the @@ -124,11 +158,22 @@ joinProcessGroup pgid = throwErrnoIfMinus1_ "joinProcessGroup" (c_setpgid 0 pgid) --- | @'setProcessGroupID' pid pgid@ calls @setpgid@ to set the --- 'ProcessGroupID' for process @pid@ to @pgid@. -setProcessGroupID :: ProcessID -> ProcessGroupID -> IO () -setProcessGroupID pid pgid = - throwErrnoIfMinus1_ "setProcessGroupID" (c_setpgid pid pgid) +{- + To be added in the future, after the deprecation period for the + existing setProcessGroupID has elapsed: + +-- | @'setProcessGroupID' pgid@ calls @setpgid@ to set the +-- 'ProcessGroupID' of the current process to @pgid@. +setProcessGroupID :: ProcessGroupID -> IO () +setProcessGroupID pgid = + throwErrnoIfMinus1_ "setProcessGroupID" (c_setpgid 0 pgid) +-} + +-- | @'setProcessGroupIDOf' pid pgid@ calls @setpgid@ to set the +-- 'ProcessGroupIDOf' for process @pid@ to @pgid@. +setProcessGroupIDOf :: ProcessID -> ProcessGroupID -> IO () +setProcessGroupIDOf pid pgid = + throwErrnoIfMinus1_ "setProcessGroupIDOf" (c_setpgid pid pgid) foreign import ccall unsafe "setpgid" c_setpgid :: CPid -> CPid -> IO CInt @@ -256,7 +301,7 @@ stable <- newStablePtr (runIO action) pid <- throwErrnoIfMinus1 "forkProcess" (forkProcessPrim stable) freeStablePtr stable - return $ fromIntegral pid + return pid foreign import ccall "forkProcess" forkProcessPrim :: StablePtr (IO ()) -> IO CPid #endif /* __GLASGOW_HASKELL__ */ @@ -275,8 +320,8 @@ -> Maybe [(String, String)] -- ^ Environment -> IO a executeFile path search args Nothing = do - withCString path $ \s -> - withMany withCString (path:args) $ \cstrs -> + withFilePath path $ \s -> + withMany withFilePath (path:args) $ \cstrs -> withArray0 nullPtr cstrs $ \arr -> do pPrPr_disableITimers if search @@ -285,11 +330,11 @@ return undefined -- never reached executeFile path search args (Just env) = do - withCString path $ \s -> - withMany withCString (path:args) $ \cstrs -> + withFilePath path $ \s -> + withMany withFilePath (path:args) $ \cstrs -> withArray0 nullPtr cstrs $ \arg_arr -> let env' = map (\ (name, val) -> name ++ ('=' : val)) env in - withMany withCString env' $ \cenv -> + withMany withFilePath env' $ \cenv -> withArray0 nullPtr cenv $ \env_arr -> do pPrPr_disableITimers if search @@ -389,3 +434,27 @@ c_exit :: CInt -> IO () -- ----------------------------------------------------------------------------- +-- Deprecated or subject to change + +{-# DEPRECATED createProcessGroup "This function is scheduled to be replaced by something different in the future, we therefore recommend that you do not use this version and use createProcessGroupFor instead." #-} +-- | @'createProcessGroup' pid@ calls @setpgid@ to make +-- process @pid@ a new process group leader. +-- This function is currently deprecated, +-- and might be changed to making the current +-- process a new process group leader in future versions. +createProcessGroup :: ProcessID -> IO ProcessGroupID +createProcessGroup pid = do + throwErrnoIfMinus1_ "createProcessGroup" (c_setpgid pid 0) + return pid + +{-# DEPRECATED setProcessGroupID "This function is scheduled to be replaced by something different in the future, we therefore recommend that you do not use this version and use setProcessGroupIdOf instead." #-} +-- | @'setProcessGroupID' pid pgid@ calls @setpgid@ to set the +-- 'ProcessGroupID' for process @pid@ to @pgid@. +-- This function is currently deprecated, +-- and might be changed to setting the 'ProcessGroupID' +-- for the current process in future versions. +setProcessGroupID :: ProcessID -> ProcessGroupID -> IO () +setProcessGroupID pid pgid = + throwErrnoIfMinus1_ "setProcessGroupID" (c_setpgid pid pgid) + +-- ----------------------------------------------------------------------------- diff -Nru ghc-7.0.3/libraries/unix/System/Posix/Signals.hsc ghc-7.2.1/libraries/unix/System/Posix/Signals.hsc --- ghc-7.0.3/libraries/unix/System/Posix/Signals.hsc 2011-03-26 18:10:15.000000000 +0000 +++ ghc-7.2.1/libraries/unix/System/Posix/Signals.hsc 2011-08-07 17:10:12.000000000 +0000 @@ -276,7 +276,7 @@ -- with interrupt signal @int@. signalProcess :: Signal -> ProcessID -> IO () signalProcess sig pid - = throwErrnoIfMinus1_ "signalProcess" (c_kill (fromIntegral pid) sig) + = throwErrnoIfMinus1_ "signalProcess" (c_kill pid sig) foreign import ccall unsafe "kill" c_kill :: CPid -> CInt -> IO CInt @@ -286,7 +286,7 @@ -- all processes in group @pgid@ with interrupt signal @int@. signalProcessGroup :: Signal -> ProcessGroupID -> IO () signalProcessGroup sig pgid - = throwErrnoIfMinus1_ "signalProcessGroup" (c_killpg (fromIntegral pgid) sig) + = throwErrnoIfMinus1_ "signalProcessGroup" (c_killpg pgid sig) foreign import ccall unsafe "killpg" c_killpg :: CPid -> CInt -> IO CInt diff -Nru ghc-7.0.3/libraries/unix/System/Posix/Temp.hsc ghc-7.2.1/libraries/unix/System/Posix/Temp.hsc --- ghc-7.0.3/libraries/unix/System/Posix/Temp.hsc 2011-03-26 18:10:15.000000000 +0000 +++ ghc-7.2.1/libraries/unix/System/Posix/Temp.hsc 2011-08-07 17:10:12.000000000 +0000 @@ -32,6 +32,21 @@ import System.Posix.Types import Foreign.C +#if __GLASGOW_HASKELL__ > 700 +import System.Posix.Internals (withFilePath, peekFilePath) +#elif __GLASGOW_HASKELL__ > 611 +import System.Posix.Internals (withFilePath) + +peekFilePath :: CString -> IO FilePath +peekFilePath = peekCString +#else +withFilePath :: FilePath -> (CString -> IO a) -> IO a +withFilePath = withCString + +peekFilePath :: CString -> IO FilePath +peekFilePath = peekCString +#endif + -- |'mkstemp' - make a unique filename and open it for -- reading\/writing (only safe on GHC & Hugs). -- The returned 'FilePath' is the (possibly relative) path of @@ -39,9 +54,9 @@ mkstemp :: String -> IO (FilePath, Handle) mkstemp template = do #if defined(__GLASGOW_HASKELL__) || defined(__HUGS__) - withCString template $ \ ptr -> do + withFilePath template $ \ ptr -> do fd <- throwErrnoIfMinus1 "mkstemp" (c_mkstemp ptr) - name <- peekCString ptr + name <- peekFilePath ptr h <- fdToHandle (Fd fd) return (name, h) #else @@ -54,9 +69,9 @@ mktemp :: String -> IO String mktemp template = do - withCString template $ \ ptr -> do + withFilePath template $ \ ptr -> do ptr <- throwErrnoIfNull "mktemp" (c_mktemp ptr) - peekCString ptr + peekFilePath ptr foreign import ccall unsafe "mktemp" c_mktemp :: CString -> IO CString diff -Nru ghc-7.0.3/libraries/unix/System/Posix/User.hsc ghc-7.2.1/libraries/unix/System/Posix/User.hsc --- ghc-7.0.3/libraries/unix/System/Posix/User.hsc 2011-03-26 18:10:15.000000000 +0000 +++ ghc-7.2.1/libraries/unix/System/Posix/User.hsc 2011-08-07 17:10:12.000000000 +0000 @@ -131,7 +131,7 @@ getLoginName = do -- ToDo: use getlogin_r str <- throwErrnoIfNull "getLoginName" c_getlogin - peekCString str + peekCAString str foreign import ccall unsafe "getlogin" c_getlogin :: IO CString @@ -225,7 +225,7 @@ getGroupEntryForName name = do allocaBytes (#const sizeof(struct group)) $ \pgr -> alloca $ \ ppgr -> - withCString name $ \ pstr -> do + withCAString name $ \ pstr -> do throwErrorIfNonZero_ "getGroupEntryForName" $ doubleAllocWhile isERANGE grBufSize $ \s b -> c_getgrnam_r pstr pgr b (fromIntegral s) ppgr @@ -287,11 +287,11 @@ unpackGroupEntry :: Ptr CGroup -> IO GroupEntry unpackGroupEntry ptr = do - name <- (#peek struct group, gr_name) ptr >>= peekCString - passwd <- (#peek struct group, gr_passwd) ptr >>= peekCString + name <- (#peek struct group, gr_name) ptr >>= peekCAString + passwd <- (#peek struct group, gr_passwd) ptr >>= peekCAString gid <- (#peek struct group, gr_gid) ptr mem <- (#peek struct group, gr_mem) ptr - members <- peekArray0 nullPtr mem >>= mapM peekCString + members <- peekArray0 nullPtr mem >>= mapM peekCAString return (GroupEntry name passwd gid members) -- ----------------------------------------------------------------------------- @@ -359,7 +359,7 @@ getUserEntryForName name = do allocaBytes (#const sizeof(struct passwd)) $ \ppw -> alloca $ \ pppw -> - withCString name $ \ pstr -> do + withCAString name $ \ pstr -> do throwErrorIfNonZero_ "getUserEntryForName" $ doubleAllocWhile isERANGE pwBufSize $ \s b -> c_getpwnam_r pstr ppw b (fromIntegral s) pppw @@ -377,7 +377,7 @@ -> CString -> CSize -> Ptr (Ptr CPasswd) -> IO CInt #elif HAVE_GETPWNAM getUserEntryForName name = do - withCString name $ \ pstr -> do + withCAString name $ \ pstr -> do withMVar lock $ \_ -> do ppw <- throwErrnoIfNull "getUserEntryForName" $ c_getpwnam pstr unpackUserEntry ppw @@ -446,13 +446,13 @@ unpackUserEntry :: Ptr CPasswd -> IO UserEntry unpackUserEntry ptr = do - name <- (#peek struct passwd, pw_name) ptr >>= peekCString - passwd <- (#peek struct passwd, pw_passwd) ptr >>= peekCString + name <- (#peek struct passwd, pw_name) ptr >>= peekCAString + passwd <- (#peek struct passwd, pw_passwd) ptr >>= peekCAString uid <- (#peek struct passwd, pw_uid) ptr gid <- (#peek struct passwd, pw_gid) ptr - gecos <- (#peek struct passwd, pw_gecos) ptr >>= peekCString - dir <- (#peek struct passwd, pw_dir) ptr >>= peekCString - shell <- (#peek struct passwd, pw_shell) ptr >>= peekCString + gecos <- (#peek struct passwd, pw_gecos) ptr >>= peekCAString + dir <- (#peek struct passwd, pw_dir) ptr >>= peekCAString + shell <- (#peek struct passwd, pw_shell) ptr >>= peekCAString return (UserEntry name passwd uid gid gecos dir shell) -- Used when calling re-entrant system calls that signal their 'errno' @@ -462,7 +462,7 @@ rc <- act if (rc == 0) then return () - else ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing) + else ioError (errnoToIOError loc (Errno rc) Nothing Nothing) -- Used when a function returns NULL to indicate either an error or -- EOF, depending on whether the global errno is nonzero. diff -Nru ghc-7.0.3/libraries/unix/tests/all.T ghc-7.2.1/libraries/unix/tests/all.T --- ghc-7.0.3/libraries/unix/tests/all.T 2011-03-26 18:10:15.000000000 +0000 +++ ghc-7.2.1/libraries/unix/tests/all.T 2011-08-07 17:10:12.000000000 +0000 @@ -56,3 +56,6 @@ # works on a different machine that doesn't have Samba installed. # --SDM 18/05/2010 test('3816', normal, compile_and_run, ['-package unix']) + +test('processGroup001', normal, compile_and_run, ['-package unix']) +test('processGroup002', normal, compile_and_run, ['-package unix']) diff -Nru ghc-7.0.3/libraries/unix/tests/processGroup001.hs ghc-7.2.1/libraries/unix/tests/processGroup001.hs --- ghc-7.0.3/libraries/unix/tests/processGroup001.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/unix/tests/processGroup001.hs 2011-08-07 17:10:12.000000000 +0000 @@ -0,0 +1,7 @@ +import System.Posix.Process + +main = do + pgid <- getProcessGroupID + pgid' <- getProcessGroupIDOf =<< getProcessID + putStr "Testing getProcessGroupID == getProcessGroupIDOf =<< getProcessID: " + print $ pgid == pgid' diff -Nru ghc-7.0.3/libraries/unix/tests/processGroup001.stdout ghc-7.2.1/libraries/unix/tests/processGroup001.stdout --- ghc-7.0.3/libraries/unix/tests/processGroup001.stdout 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/unix/tests/processGroup001.stdout 2011-08-07 17:10:12.000000000 +0000 @@ -0,0 +1 @@ +Testing getProcessGroupID == getProcessGroupIDOf =<< getProcessID: True diff -Nru ghc-7.0.3/libraries/unix/tests/processGroup002.hs ghc-7.2.1/libraries/unix/tests/processGroup002.hs --- ghc-7.0.3/libraries/unix/tests/processGroup002.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/unix/tests/processGroup002.hs 2011-08-07 17:10:12.000000000 +0000 @@ -0,0 +1,21 @@ +import System.Posix.Process + +main = do + pid <- getProcessID + ppid <- getParentProcessID + ppgid <- getProcessGroupIDOf ppid + -- join the parent process + putStr "Testing joinProcessGroup: " + joinProcessGroup ppgid + pgid1 <- getProcessGroupID + print $ ppgid == pgid1 + -- be a leader + putStr "Testing createProcessGroupFor: " + createProcessGroupFor pid + pgid2 <- getProcessGroupID + print $ pid == fromIntegral pgid2 + -- and join the parent again + putStr "Testing setProcessGroupIDOf: " + setProcessGroupIDOf pid ppgid + pgid3 <- getProcessGroupID + print $ ppgid == pgid3 diff -Nru ghc-7.0.3/libraries/unix/tests/processGroup002.stdout ghc-7.2.1/libraries/unix/tests/processGroup002.stdout --- ghc-7.0.3/libraries/unix/tests/processGroup002.stdout 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/unix/tests/processGroup002.stdout 2011-08-07 17:10:12.000000000 +0000 @@ -0,0 +1,3 @@ +Testing joinProcessGroup: True +Testing createProcessGroupFor: True +Testing setProcessGroupIDOf: True diff -Nru ghc-7.0.3/libraries/unix/unix.cabal ghc-7.2.1/libraries/unix/unix.cabal --- ghc-7.0.3/libraries/unix/unix.cabal 2011-03-26 18:10:15.000000000 +0000 +++ ghc-7.2.1/libraries/unix/unix.cabal 2011-08-07 17:10:12.000000000 +0000 @@ -1,5 +1,5 @@ name: unix -version: 2.4.2.0 +version: 2.5.0.0 license: BSD3 license-file: LICENSE maintainer: libraries@haskell.org @@ -47,8 +47,10 @@ System.Posix.Signals.Exts System.Posix.Semaphore System.Posix.SharedMem - build-depends: base >= 4.2 && < 4.4 - extensions: CPP, ForeignFunctionInterface, EmptyDataDecls + build-depends: base >= 4.2 && < 4.5 + extensions: CPP, ForeignFunctionInterface, EmptyDataDecls + if impl(ghc >= 7.1) + extensions: NondecreasingIndentation include-dirs: include includes: HsUnix.h execvpe.h install-includes: @@ -56,6 +58,6 @@ c-sources: cbits/HsUnix.c cbits/execvpe.c cbits/dirUtils.c source-repository head - type: darcs - location: http://darcs.haskell.org/packages/unix/ + type: git + location: http://darcs.haskell.org/packages/unix.git/ diff -Nru ghc-7.0.3/libraries/utf8-string/Codec/Binary/UTF8/Generic.hs ghc-7.2.1/libraries/utf8-string/Codec/Binary/UTF8/Generic.hs --- ghc-7.0.3/libraries/utf8-string/Codec/Binary/UTF8/Generic.hs 2011-03-26 18:10:15.000000000 +0000 +++ ghc-7.2.1/libraries/utf8-string/Codec/Binary/UTF8/Generic.hs 2011-08-07 17:10:12.000000000 +0000 @@ -178,13 +178,13 @@ Nothing -> (bs, empty) -- | @take n s@ returns the first @n@ characters of @s@. --- If @s@ has less then @n@ characters, then we return the whole of @s@. +-- If @s@ has less than @n@ characters, then we return the whole of @s@. {-# INLINE take #-} take :: UTF8Bytes b s => s -> b -> b take n bs = fst (splitAt n bs) -- | @drop n s@ returns the @s@ without its first @n@ characters. --- If @s@ has less then @n@ characters, then we return the an empty string. +-- If @s@ has less than @n@ characters, then we return an empty string. {-# INLINE drop #-} drop :: UTF8Bytes b s => s -> b -> b drop n bs = snd (splitAt n bs) @@ -227,7 +227,7 @@ Nothing -> nil -- | Traverse a bytestring (left biased). --- This fuction is strict in the acumulator. +-- This function is strict in the accumulator. {-# SPECIALIZE foldl :: (a -> Char -> a) -> a -> B.ByteString -> a #-} {-# SPECIALIZE foldl :: (a -> Char -> a) -> a -> L.ByteString -> a #-} {-# SPECIALIZE foldl :: (a -> Char -> a) -> a -> [Word8] -> a #-} @@ -238,7 +238,7 @@ Nothing -> acc -- | Counts the number of characters encoded in the bytestring. --- Note that this includes replacment characters. +-- Note that this includes replacement characters. {-# SPECIALIZE length :: B.ByteString -> Int #-} {-# SPECIALIZE length :: L.ByteString -> Int64 #-} {-# SPECIALIZE length :: [Word8] -> Int #-} @@ -249,8 +249,8 @@ Nothing -> n -- | Split a string into a list of lines. --- Lines are termianted by '\n' or the end of the string. --- Empty line may not be terminated by the end of the string. +-- Lines are terminated by '\n' or the end of the string. +-- Empty lines may not be terminated by the end of the string. -- See also 'lines\''. {-# SPECIALIZE lines :: B.ByteString -> [B.ByteString] #-} {-# SPECIALIZE lines :: L.ByteString -> [L.ByteString] #-} @@ -263,8 +263,8 @@ Nothing -> [bs] -- | Split a string into a list of lines. --- Lines are termianted by '\n' or the end of the string. --- Empty line may not be terminated by the end of the string. +-- Lines are terminated by '\n' or the end of the string. +-- Empty lines may not be terminated by the end of the string. -- This function preserves the terminators. -- See also 'lines'. {-# SPECIALIZE lines' :: B.ByteString -> [B.ByteString] #-} diff -Nru ghc-7.0.3/libraries/utf8-string/Codec/Binary/UTF8/String.hs ghc-7.2.1/libraries/utf8-string/Codec/Binary/UTF8/String.hs --- ghc-7.0.3/libraries/utf8-string/Codec/Binary/UTF8/String.hs 2011-03-26 18:10:15.000000000 +0000 +++ ghc-7.2.1/libraries/utf8-string/Codec/Binary/UTF8/String.hs 2011-08-07 17:10:12.000000000 +0000 @@ -16,6 +16,7 @@ , decode , encodeString , decodeString + , encodeChar , isUTF8Encoded , utf8Encode @@ -40,9 +41,9 @@ replacement_character :: Char replacement_character = '\xfffd' --- | Encode a Haskell String to a list of Word8 values, in UTF8 format. -encode :: String -> [Word8] -encode = concatMap (map fromIntegral . go . ord) +-- | Encode a single Haskell Char to a list of Word8 values, in UTF8 format. +encodeChar :: Char -> [Word8] +encodeChar = map fromIntegral . go . ord where go oc | oc <= 0x7f = [oc] @@ -61,6 +62,11 @@ , 0x80 + oc .&. 0x3f ] + +-- | Encode a Haskell String to a list of Word8 values, in UTF8 format. +encode :: String -> [Word8] +encode = concatMap encodeChar + -- -- | Decode a UTF8 string packed into a list of Word8 values, directly to String -- diff -Nru ghc-7.0.3/libraries/utf8-string/Data/ByteString/Lazy/UTF8.hs ghc-7.2.1/libraries/utf8-string/Data/ByteString/Lazy/UTF8.hs --- ghc-7.0.3/libraries/utf8-string/Data/ByteString/Lazy/UTF8.hs 2011-03-26 18:10:15.000000000 +0000 +++ ghc-7.2.1/libraries/utf8-string/Data/ByteString/Lazy/UTF8.hs 2011-08-07 17:10:12.000000000 +0000 @@ -131,12 +131,12 @@ Nothing -> (bs, B.empty) -- | @take n s@ returns the first @n@ characters of @s@. --- If @s@ has less then @n@ characters, then we return the whole of @s@. +-- If @s@ has less than @n@ characters, then we return the whole of @s@. take :: Int64 -> B.ByteString -> B.ByteString take n bs = fst (splitAt n bs) -- | @drop n s@ returns the @s@ without its first @n@ characters. --- If @s@ has less then @n@ characters, then we return the an empty string. +-- If @s@ has less than @n@ characters, then we return an empty string. drop :: Int64 -> B.ByteString -> B.ByteString drop n bs = snd (splitAt n bs) @@ -170,7 +170,7 @@ Nothing -> nil -- | Traverse a bytestring (left biased). --- This fuction is strict in the acumulator. +-- This function is strict in the accumulator. foldl :: (a -> Char -> a) -> a -> B.ByteString -> a foldl add acc cs = case uncons cs of Just (a,as) -> let v = add acc a @@ -178,7 +178,7 @@ Nothing -> acc -- | Counts the number of characters encoded in the bytestring. --- Note that this includes replacment characters. +-- Note that this includes replacement characters. length :: B.ByteString -> Int length b = loop 0 b where loop n xs = case decode xs of @@ -186,8 +186,8 @@ Nothing -> n -- | Split a string into a list of lines. --- Lines are termianted by '\n' or the end of the string. --- Empty line may not be terminated by the end of the string. +-- Lines are terminated by '\n' or the end of the string. +-- Empty lines may not be terminated by the end of the string. -- See also 'lines\''. lines :: B.ByteString -> [B.ByteString] lines bs | B.null bs = [] @@ -197,8 +197,8 @@ Nothing -> [bs] -- | Split a string into a list of lines. --- Lines are termianted by '\n' or the end of the string. --- Empty line may not be terminated by the end of the string. +-- Lines are terminated by '\n' or the end of the string. +-- Empty lines may not be terminated by the end of the string. -- This function preserves the terminators. -- See also 'lines'. lines' :: B.ByteString -> [B.ByteString] diff -Nru ghc-7.0.3/libraries/utf8-string/Data/ByteString/UTF8.hs ghc-7.2.1/libraries/utf8-string/Data/ByteString/UTF8.hs --- ghc-7.0.3/libraries/utf8-string/Data/ByteString/UTF8.hs 2011-03-26 18:10:15.000000000 +0000 +++ ghc-7.2.1/libraries/utf8-string/Data/ByteString/UTF8.hs 2011-08-07 17:10:12.000000000 +0000 @@ -130,12 +130,12 @@ Nothing -> (bs, B.empty) -- | @take n s@ returns the first @n@ characters of @s@. --- If @s@ has less then @n@ characters, then we return the whole of @s@. +-- If @s@ has less than @n@ characters, then we return the whole of @s@. take :: Int -> B.ByteString -> B.ByteString take n bs = fst (splitAt n bs) -- | @drop n s@ returns the @s@ without its first @n@ characters. --- If @s@ has less then @n@ characters, then we return the an empty string. +-- If @s@ has less than @n@ characters, then we return an empty string. drop :: Int -> B.ByteString -> B.ByteString drop n bs = snd (splitAt n bs) @@ -169,7 +169,7 @@ Nothing -> nil -- | Traverse a bytestring (left biased). --- This fuction is strict in the acumulator. +-- This function is strict in the accumulator. foldl :: (a -> Char -> a) -> a -> B.ByteString -> a foldl add acc cs = case uncons cs of Just (a,as) -> let v = add acc a @@ -177,7 +177,7 @@ Nothing -> acc -- | Counts the number of characters encoded in the bytestring. --- Note that this includes replacment characters. +-- Note that this includes replacement characters. length :: B.ByteString -> Int length b = loop 0 b where loop n xs = case decode xs of @@ -185,8 +185,8 @@ Nothing -> n -- | Split a string into a list of lines. --- Lines are termianted by '\n' or the end of the string. --- Empty line may not be terminated by the end of the string. +-- Lines are terminated by '\n' or the end of the string. +-- Empty lines may not be terminated by the end of the string. -- See also 'lines\''. lines :: B.ByteString -> [B.ByteString] lines bs | B.null bs = [] @@ -196,8 +196,8 @@ Nothing -> [bs] -- | Split a string into a list of lines. --- Lines are termianted by '\n' or the end of the string. --- Empty line may not be terminated by the end of the string. +-- Lines are terminated by '\n' or the end of the string. +-- Empty lines may not be terminated by the end of the string. -- This function preserves the terminators. -- See also 'lines'. lines' :: B.ByteString -> [B.ByteString] diff -Nru ghc-7.0.3/libraries/utf8-string/Data/String/UTF8.hs ghc-7.2.1/libraries/utf8-string/Data/String/UTF8.hs --- ghc-7.0.3/libraries/utf8-string/Data/String/UTF8.hs 2011-03-26 18:10:15.000000000 +0000 +++ ghc-7.2.1/libraries/utf8-string/Data/String/UTF8.hs 2011-08-07 17:10:12.000000000 +0000 @@ -45,8 +45,8 @@ import qualified Codec.Binary.UTF8.Generic as G import Codec.Binary.UTF8.Generic (UTF8Bytes) --- | The type of strngs that are represented using the UTF8 encoding. --- The parameters is the type of the container for the representation. +-- | The type of strings that are represented using the UTF8 encoding. +-- The parameter is the type of the container for the representation. newtype UTF8 string = Str string deriving (Eq,Ord) -- XXX: Is this OK? instance UTF8Bytes string index => Show (UTF8 string) where @@ -100,12 +100,12 @@ -- | @take n s@ returns the first @n@ characters of @s@. --- If @s@ has less then @n@ characters, then we return the whole of @s@. +-- If @s@ has less than @n@ characters, then we return the whole of @s@. take :: UTF8Bytes string index => index -> UTF8 string -> UTF8 string take n (Str bs) = Str (G.take n bs) -- | @drop n s@ returns the @s@ without its first @n@ characters. --- If @s@ has less then @n@ characters, then we return the an empty string. +-- If @s@ has less than @n@ characters, then we return an empty string. drop :: UTF8Bytes string index => index -> UTF8 string -> UTF8 string drop n (Str bs) = Str (G.drop n bs) @@ -135,7 +135,7 @@ return (c, Str y) -- | Extract the first character for the underlying representation, --- if one is avaialble. It also returns the number of bytes used +-- if one is available. It also returns the number of bytes used -- in the representation of the character. -- See also 'uncons', 'dropBytes'. decode :: UTF8Bytes string index => UTF8 string -> Maybe (Char, index) @@ -146,26 +146,26 @@ foldr cons nil (Str cs) = G.foldr cons nil cs -- | Traverse a bytestring (left biased). --- This fuction is strict in the accumulator. +-- This function is strict in the accumulator. foldl :: UTF8Bytes string index => (a -> Char -> a) -> a -> UTF8 string -> a foldl add acc (Str cs) = G.foldl add acc cs -- | Counts the number of characters encoded in the bytestring. --- Note that this includes replacment characters. +-- Note that this includes replacement characters. -- The function is linear in the number of bytes in the representation. length :: UTF8Bytes string index => UTF8 string -> index length (Str b) = G.length b -- | Split a string into a list of lines. --- Lines are termianted by '\n' or the end of the string. --- Empty line may not be terminated by the end of the string. +-- Lines are terminated by '\n' or the end of the string. +-- Empty lines may not be terminated by the end of the string. -- See also 'lines\''. lines :: UTF8Bytes string index => UTF8 string -> [UTF8 string] lines (Str b) = map Str (G.lines b) -- XXX: unnecessary map -- | Split a string into a list of lines. --- Lines are termianted by '\n' or the end of the string. --- Empty line may not be terminated by the end of the string. +-- Lines are terminated by '\n' or the end of the string. +-- Empty lines may not be terminated by the end of the string. -- This function preserves the terminators. -- See also 'lines'. lines' :: UTF8Bytes string index => UTF8 string -> [UTF8 string] diff -Nru ghc-7.0.3/libraries/utf8-string/ghc.mk ghc-7.2.1/libraries/utf8-string/ghc.mk --- ghc-7.0.3/libraries/utf8-string/ghc.mk 2011-03-26 18:10:45.000000000 +0000 +++ ghc-7.2.1/libraries/utf8-string/ghc.mk 2011-08-07 17:11:00.000000000 +0000 @@ -1,3 +1,4 @@ libraries/utf8-string_PACKAGE = utf8-string libraries/utf8-string_dist-install_GROUP = libraries +$(if $(filter utf8-string,$(PACKAGES_STAGE0)),$(eval $(call build-package,libraries/utf8-string,dist-boot,0))) $(eval $(call build-package,libraries/utf8-string,dist-install,$(if $(filter utf8-string,$(STAGE2_PACKAGES)),2,1))) diff -Nru ghc-7.0.3/libraries/utf8-string/tests/BenchBytestring.hs ghc-7.2.1/libraries/utf8-string/tests/BenchBytestring.hs --- ghc-7.0.3/libraries/utf8-string/tests/BenchBytestring.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/utf8-string/tests/BenchBytestring.hs 2011-08-07 17:10:12.000000000 +0000 @@ -0,0 +1,55 @@ +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import qualified Data.String.UTF8 as UTF8 +import qualified Codec.Binary.UTF8.String as List + +import System.Environment(getArgs) +import System.IO +import Data.Word + +main = mapM_ run_test =<< getArgs + +run_test x = case reads x of + [(n,"")] | n < test_num -> tests !! n + _ -> hPutStrLn stderr ("Invalid test: " ++ x) + +tests = [ main0, main1, main2, main3, main4 ] +test_num = length tests + + +main0 = do putStrLn "Correctness: Data.ByteString" + putStrLn ("Errors: " ++ show encodeDecodeTest) + +main1 = do putStrLn "Speed: Data.ByteString" + txt <- S.readFile "test" + print (UTF8.length $ UTF8.fromRep txt) + +main2 = do putStrLn "Speed: Data.ByteString.Lazy" + txt <- L.readFile "test" + print (UTF8.length $ UTF8.fromRep txt) + +main3 = do putStrLn "Speed: [Word8]" + txt <- hGetContents =<< openBinaryFile "test" ReadMode + let bytes :: [Word8] + bytes = map (fromIntegral . fromEnum) txt + print (UTF8.length $ UTF8.fromRep bytes) + +main4 = do putStrLn "Speed: [Word8] (direct)" + txt <- hGetContents =<< openBinaryFile "test" ReadMode + let bytes :: [Word8] + bytes = map (fromIntegral . fromEnum) txt + print (length $ List.decode bytes) + +encodeDecodeTest :: String +encodeDecodeTest = + filter (\x -> enc x /= [x]) legal_codepoints + ++ filter (\x -> enc x /= [UTF8.replacement_char]) illegal_codepoints + where + legal_codepoints = ['\0'..'\xd7ff'] ++ ['\xe000'..'\xfffd'] + ++ ['\x10000'..'\x10ffff'] + illegal_codepoints = '\xffff' : '\xfffe' : ['\xd800'..'\xdfff'] + +{-# INLINE enc #-} +enc x = UTF8.toString (UTF8.fromString [x] :: UTF8.UTF8 S.ByteString) + + diff -Nru ghc-7.0.3/libraries/utf8-string/tests/Bench.hs ghc-7.2.1/libraries/utf8-string/tests/Bench.hs --- ghc-7.0.3/libraries/utf8-string/tests/Bench.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/utf8-string/tests/Bench.hs 2011-08-07 17:10:12.000000000 +0000 @@ -0,0 +1,211 @@ +{-# OPTIONS -cpp -fglasgow-exts #-} + +{- +$ ghc --make -O2 Bench.hs -o bench + +$ ./bench +Size of test data: 2428k +Char Optimal byteString decode + 1 0.102 0.109 0.102 0.109 0.102 + 0.063 0.063 0.070 0.055 0.070 # "decode" +-} + +-- +-- Benchmark tool. +-- Compare a function against equivalent code from other libraries for +-- space and time. +-- + +import Data.ByteString (ByteString) +import qualified Data.ByteString as P +-- import qualified Data.ByteString as L + +import Data.List +import Data.Char +import Data.Word +import Data.Int + +import System.Mem +import Control.Concurrent + +import System.IO +import System.CPUTime +import System.IO.Unsafe +import Control.Monad +import Control.Exception +import Text.Printf + +------------------------------------------------------------------------ +-- a reference (incorrect, but fast) implementation: + +import GHC.Ptr +import qualified GHC.Base as GHC +import qualified Data.ByteString as B +import qualified Data.ByteString.Base as B + +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as C +import qualified Data.ByteString.Lazy as L + +import Data.List +import Data.Char +import Data.Word +import Data.Int + +import System.IO +import Control.Monad +import Text.Printf + +import qualified Codec.Binary.UTF8.String as UTF8 + +------------------------------------------------------------------------ + +main :: IO () +main = do + force (fps,chars,strs) + printf "# Size of test data: %dk\n" ((floor $ (fromIntegral (B.length fps)) / 1024) :: Int) + printf "#Char\t Optimal byteString decode\n" + run 5 (fps,chars,strs) tests + +-- +-- Measure the difference building an decoded String from +-- bytestring+GHC's inbuilt decoder, and ours. +-- +-- Most cost is in building the String. +-- +tests = + [ ("decode", + [F ( app UTF8.decode) + ,F ( app unpackCStringUTF8) ]) + + , ("encode", + [F ( app UTF8.encode) ]) + ] + + +-- unpackCStringUtf8# wants \0 termianted strings. rewrite it to take a +-- length instead, and we avoid the copy in useAsCString. +unpackCStringUTF8 :: B.ByteString -> [Char] +unpackCStringUTF8 b = unsafePerformIO $ B.unsafeUseAsCString b $ \(Ptr a) -> + return (GHC.unpackCStringUtf8# a) + + +------------------------------------------------------------------------ + +run c x tests = sequence_ $ zipWith (doit c x) [1..] tests + +doit :: Int -> a -> Int -> (String, [F a]) -> IO () +doit count x n (s,ls) = do + printf "%2d " n + fn ls + printf "\t# %-16s\n" (show s) + hFlush stdout + where fn xs = case xs of + [f,g] -> runN count f x >> putStr "\n " + >> runN count g x >> putStr "\t" + [f] -> runN count f x >> putStr "\t" + _ -> return () + run f x = dirtyCache fps >> performGC >> threadDelay 100 >> time f x + runN 0 f x = return () + runN c f x = run f x >> runN (c-1) f x + +dirtyCache x = evaluate (P.foldl1' (+) x) +{-# NOINLINE dirtyCache #-} + +time :: F a -> a -> IO () +time (F f) a = do + start <- getCPUTime + v <- force (f a) + case v of + B -> printf "--\t" + _ -> do + end <- getCPUTime + let diff = (fromIntegral (end - start)) / (10^12) + printf "%0.3f " (diff :: Double) + hFlush stdout + +------------------------------------------------------------------------ +-- +-- an existential list +-- +data F a = forall b . Forceable b => F (a -> b) + +data Result = T | B + +-- +-- a bit deepSeqish +-- +class Forceable a where + force :: a -> IO Result + force v = v `seq` return T + +#if !defined(HEAD) +instance Forceable P.ByteString where + force v = P.length v `seq` return T +#endif + +instance Forceable L.ByteString where + force v = L.length v `seq` return T + +-- instance Forceable SPS.PackedString where +-- force v = SPS.length v `seq` return T + +-- instance Forceable PS.PackedString where +-- force v = PS.lengthPS v `seq` return T + +instance Forceable a => Forceable (Maybe a) where + force Nothing = return T + force (Just v) = force v `seq` return T + +instance Forceable [a] where + force v = length v `seq` return T + +instance (Forceable a, Forceable b) => Forceable (a,b) where + force (a,b) = force a >> force b + +instance (Forceable a, Forceable b, Forceable c) => Forceable (a,b,c) where + force (a,b,c) = force a >> force b >> force c + +instance Forceable Int +instance Forceable Int64 +instance Forceable Bool +instance Forceable Char +instance Forceable Word8 +instance Forceable Ordering + +-- used to signal undefinedness +instance Forceable () where force () = return B + +------------------------------------------------------------------------ +-- +-- some large strings to play with +-- + +fps :: P.ByteString +fps = unsafePerformIO $ P.readFile dict +{-# NOINLINE fps #-} + +chars :: [Word8] +chars = B.unpack fps +{-# NOINLINE chars #-} + +strs :: String +strs = C.unpack fps +{-# NOINLINE strs #-} + +dict = "/usr/share/dict/words" + +------------------------------------------------------------------------ + +type Input = (B.ByteString,[Word8],String) + +class (Eq a, Ord a) => Ap a where app :: (a -> b) -> Input -> b + +instance Ap B.ByteString where app f x = f (fst3 x) +instance Ap [Word8] where app f x = f (snd3 x) +instance Ap String where app f x = f (thd3 x) + +fst3 (a,_,_) = a +snd3 (_,a,_) = a +thd3 (_,_,a) = a diff -Nru ghc-7.0.3/libraries/utf8-string/tests/Tests.hs ghc-7.2.1/libraries/utf8-string/tests/Tests.hs --- ghc-7.0.3/libraries/utf8-string/tests/Tests.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/utf8-string/tests/Tests.hs 2011-08-07 17:10:12.000000000 +0000 @@ -0,0 +1,182 @@ +import Codec.Binary.UTF8.String +import Test.HUnit +import System.Exit (exitFailure) +import Control.Monad (when) + +main = do counts <- runTestTT tests + when (errors counts > 0 || failures counts > 0) exitFailure + +tests = TestList [test_1, test_2, test_3, test_4, test_5] + +test_1 = TestLabel "1 Some correct UTF-8 text" $ + TestCase $ assertEqual "kosme, " "\x03ba\x1f79\x03c3\x03bc\x03b5 " + (decode [0xce,0xba,0xe1,0xbd,0xb9,0xcf,0x83,0xce,0xbc,0xce,0xb5,0x20]) + +test_2 = TestLabel "2 Boundary condition test cases" $ + TestList [test_2_1, test_2_2, test_2_3] + +test_2_1 = TestLabel "2.1 First possible sequence of a certain length" $ + TestList $ map TestCase $ + [ assertEqual "2.1.1, " "\0\0" (decode [0, 0]) + , assertEqual "2.1.2, " "\x80\0" (decode [0xc2, 0x80, 0]) + , assertEqual "2.1.3, " "\x800\0" (decode [0xe0, 0xa0, 0x80, 0]) + , assertEqual "2.1.4, " "\x10000\0" (decode [0xf0, 0x90, 0x80, 0x80, 0]) + , assertEqual "2.1.5, " "\xfffd\0" (decode [0xf8, 0x88, 0x80, 0x80, 0x80, 0]) + , assertEqual "2.1.6, " "\xfffd\0" (decode [0xfc,0x84,0x80,0x80,0x80,0x80,0]) + ] + +test_2_2 = TestLabel "2.2 Last possible sequence of a certain length" $ + TestList $ map TestCase $ + [ assertEqual "2.2.1, " "\x7f\0" (decode [0x7f, 0]) + , assertEqual "2.2.2, " "\x7ff\0" (decode [0xdf, 0xbf, 0]) + , assertEqual "2.2.3, " "\xfffd\0" (decode [0xef, 0xbf, 0xbf, 0]) + , assertEqual "2.2.4, " "\xfffd\0" (decode [0xf7, 0xbf, 0xbf, 0xbf, 0]) + , assertEqual "2.2.5, " "\xfffd\0" (decode [0xfb, 0xbf, 0xbf, 0xbf, 0xbf, 0]) + , assertEqual "2.2.6, " "\xfffd\0" (decode [0xfd,0xbf,0xbf,0xbf,0xbf,0xbf,0]) + ] + +test_2_3 = TestLabel "2.3 Other boundary conditions" $ + TestList $ map TestCase $ + [ assertEqual "2.3.1, " "\xd7ff\0" (decode [0xed, 0x9f, 0xbf, 0]) + , assertEqual "2.3.2, " "\xe000\0" (decode [0xee, 0x80, 0x80, 0]) + , assertEqual "2.3.3, " "\xfffd\0" (decode [0xef, 0xbf, 0xbd, 0]) + , assertEqual "2.3.4, " "\x10ffff\0" (decode [0xf4, 0x8f, 0xbf, 0xbf, 0]) + , assertEqual "2.3.5, " "\xfffd\0" (decode [0xf4, 0x90, 0x80, 0x80, 0]) + ] + +test_3 = TestLabel "3 Malformed sequences" $ + TestList [test_3_1, test_3_2, test_3_3, test_3_4, test_3_5] + +test_3_1 = TestLabel "3.1 Unexpected continuation bytes" $ + TestList $ map TestCase $ + [ assertEqual "3.1.1, " "\xfffd\0" (decode [0x80, 0]) + , assertEqual "3.1.2, " "\xfffd\0" (decode [0xbf, 0]) + , assertEqual "3.1.3, " "\xfffd\xfffd\0" (decode [0x80, 0xbf, 0]) + , assertEqual "3.1.4, " "\xfffd\xfffd\xfffd\0" (decode [0x80, 0xbf, 0x80, 0]) + , assertEqual "3.1.5, " "\xfffd\xfffd\xfffd\xfffd\0" + (decode [0x80, 0xbf, 0x80, 0xbf, 0]) + , assertEqual "3.1.6, " "\xfffd\xfffd\xfffd\xfffd\xfffd\0" + (decode [0x80, 0xbf, 0x80, 0xbf, 0x80, 0]) + , assertEqual "3.1.7, " "\xfffd\xfffd\xfffd\xfffd\xfffd\xfffd\0" + (decode [0x80, 0xbf, 0x80, 0xbf, 0x80, 0xbf, 0]) + , assertEqual "3.1.8, " "\xfffd\xfffd\xfffd\xfffd\xfffd\xfffd\xfffd\0" + (decode [0x80, 0xbf, 0x80, 0xbf, 0x80, 0xbf, 0x80, 0]) + , assertEqual "3.1.9, " (replicate 64 '\xfffd') (decode [0x80..0xbf]) + ] + +test_3_2 = TestLabel "3.2 Lonely start characters" $ + TestList $ map TestCase $ + [ assertEqual "3.2.1, " (concat (replicate 32 "\xfffd ")) + (decode (concat [[x,0x20] | x <- [0xc0..0xdf]])) + , assertEqual "3.2.2, " (concat (replicate 16 "\xfffd ")) + (decode (concat [[x,0x20] | x <- [0xe0..0xef]])) + , assertEqual "3.2.3, " (concat (replicate 8 "\xfffd ")) + (decode (concat [[x,0x20] | x <- [0xf0..0xf7]])) + , assertEqual "3.2.4, " "\xfffd \xfffd \xfffd \xfffd " + (decode (concat [[x,0x20] | x <- [0xf8..0xfb]])) + , assertEqual "3.2.5, " "\xfffd \xfffd " (decode [0xfc, 0x20, 0xfd, 0x20]) + ] + +test_3_3 = TestLabel "3.3 Sequences with last continuation byte missing" $ + TestList $ map TestCase $ + [ assertEqual "3.3.1, " "\xfffd " (decode [0xc0, 0x20]) + , assertEqual "3.3.2, " "\xfffd " (decode [0xe0, 0x80, 0x20]) + , assertEqual "3.3.3, " "\xfffd " (decode [0xf0, 0x80, 0x80, 0x20]) + , assertEqual "3.3.4, " "\xfffd " (decode [0xf8, 0x80, 0x80, 0x80, 0x20]) + , assertEqual "3.3.5, " "\xfffd " (decode [0xfc, 0x80, 0x80, 0x80,0x80,0x20]) + , assertEqual "3.3.6, " "\xfffd " (decode [0xdf, 0x20]) + , assertEqual "3.3.7, " "\xfffd " (decode [0xef, 0xbf, 0x20]) + , assertEqual "3.3.8, " "\xfffd " (decode [0xf7, 0xbf, 0xbf, 0x20]) + , assertEqual "3.3.9, " "\xfffd " (decode [0xfb, 0xbf, 0xbf, 0xbf, 0x20]) + , assertEqual "3.3.10, " "\xfffd " (decode [0xfd, 0xbf, 0xbf, 0xbf,0xbf,0x20]) + ] + +test_3_4 = TestLabel "3.4 Concatenation of incomplete sequences" $ + TestCase $ assertEqual "3.4, " + (replicate 10 '\xfffd') + (decode [0xc0, 0xe0, 0x80, 0xf0, 0x80, 0x80, 0xf8, 0x80, 0x80, 0x80, + 0xfc, 0x80, 0x80, 0x80,0x80, 0xdf, 0xef, 0xbf, 0xf7, 0xbf, 0xbf, + 0xfb, 0xbf, 0xbf, 0xbf, 0xfd, 0xbf, 0xbf, 0xbf,0xbf]) + +test_3_5 = TestLabel "3.5 Impossible bytes" $ + TestList $ map TestCase $ + [ assertEqual "3.5.1, " "\xfffd " (decode [0xfe, 0x20]) + , assertEqual "3.5.2, " "\xfffd " (decode [0xff, 0x20]) + , assertEqual "3.5.3, " "\xfffd\xfffd\xfffd\xfffd " + (decode [0xfe, 0xfe, 0xff, 0xff, 0x20]) + ] + +test_4 = TestLabel "4 Overlong sequences" $ + TestList [test_4_1, test_4_2, test_4_3] + +test_4_1 = TestLabel "4.1" $ TestList $ map TestCase $ + [ assertEqual "4.1.1, " "\xfffd " (decode [0xc0, 0xaf, 0x20]) + , assertEqual "4.1.2, " "\xfffd " (decode [0xe0, 0x80, 0xaf, 0x20]) + , assertEqual "4.1.3, " "\xfffd " (decode [0xf0, 0x80, 0x80, 0xaf, 0x20]) + , assertEqual "4.1.4, " "\xfffd " (decode [0xf8, 0x80, 0x80,0x80,0xaf, 0x20]) + , assertEqual "4.1.5, " "\xfffd " (decode[0xfc,0x80,0x80,0x80,0x80,0xaf,0x20]) + ] + +test_4_2 = TestLabel "4.2 Maximum overlong sequences" $ + TestList $ map TestCase $ + [ assertEqual "4.2.1, " "\xfffd " (decode [0xc1, 0xbf, 0x20]) + , assertEqual "4.2.2, " "\xfffd " (decode [0xe0, 0x9f, 0xbf, 0x20]) + , assertEqual "4.2.3, " "\xfffd " (decode [0xf0, 0x8f, 0xbf, 0xbf, 0x20]) + , assertEqual "4.2.4, " "\xfffd " (decode [0xf8, 0x87, 0xbf, 0xbf,0xbf,0x20]) + , assertEqual "4.2.5, " "\xfffd "(decode[0xfc,0x83,0xbf,0xbf,0xbf,0xbf,0x20]) + ] + +test_4_3 = TestLabel "4.2 Overlong NUL" $ + TestList $ map TestCase $ + [ assertEqual "4.3.1, " "\xfffd " (decode [0xc0, 0x80, 0x20]) + , assertEqual "4.3.2, " "\xfffd " (decode [0xe0, 0x80, 0x80, 0x20]) + , assertEqual "4.3.3, " "\xfffd " (decode [0xf0, 0x80, 0x80, 0x80, 0x20]) + , assertEqual "4.3.4, " "\xfffd " (decode [0xf8, 0x80, 0x80, 0x80,0x80,0x20]) + , assertEqual "4.3.5, " "\xfffd "(decode[0xfc,0x80,0x80,0x80,0x80,0x80,0x20]) + ] + +test_5 = TestLabel "Illegal code positions" $ + TestList [test_5_1, test_5_2, test_5_3] + +test_5_1 = TestLabel "5.1 Single UTF-16 surrogates" $ + TestList $ map TestCase $ + [ assertEqual "5.1.1, " "\xfffd " (decode [0xed,0xa0,0x80,0x20]) + , assertEqual "5.1.2, " "\xfffd " (decode [0xed,0xad,0xbf,0x20]) + , assertEqual "5.1.3, " "\xfffd " (decode [0xed,0xae,0x80,0x20]) + , assertEqual "5.1.4, " "\xfffd " (decode [0xed,0xaf,0xbf,0x20]) + , assertEqual "5.1.5, " "\xfffd " (decode [0xed,0xb0,0x80,0x20]) + , assertEqual "5.1.6, " "\xfffd " (decode [0xed,0xbe,0x80,0x20]) + , assertEqual "5.1.7, " "\xfffd " (decode [0xed,0xbf,0xbf,0x20]) + ] + +test_5_2 = TestLabel "5.2 Paired UTF-16 surrogates" $ + TestList $ map TestCase $ + [ assertEqual "5.2.1, " res (decode [0xed,0xa0,0x80,0xed,0xb0,0x80,0x20]) + , assertEqual "5.2.2, " res (decode [0xed,0xa0,0x80,0xed,0xbf,0xbf,0x20]) + , assertEqual "5.2.3, " res (decode [0xed,0xad,0xbf,0xed,0xb0,0x80,0x20]) + , assertEqual "5.2.4, " res (decode [0xed,0xad,0xbf,0xed,0xbf,0xbf,0x20]) + , assertEqual "5.2.5, " res (decode [0xed,0xae,0x80,0xed,0xb0,0x80,0x20]) + , assertEqual "5.2.6, " res (decode [0xed,0xae,0x80,0xed,0xbf,0xbf,0x20]) + , assertEqual "5.2.7, " res (decode [0xed,0xaf,0xbf,0xed,0xb0,0x80,0x20]) + , assertEqual "5.2.8, " res (decode [0xed,0xaf,0xbf,0xed,0xbf,0xbf,0x20]) + ] + where res = "\xfffd\xfffd " + +test_5_3 = TestLabel "5.3 Other illegal code positions" $ + TestList $ map TestCase $ + [ assertEqual "5.3.1, " "\xfffd " (decode [0xef, 0xbf, 0xbe, 0x20]) + , assertEqual "5.3.2, " "\xfffd " (decode [0xef, 0xbf, 0xbf, 0x20]) + ] + + +-- +-- test decode . encode == id for the class of chars we know that to be true of +-- +encodeDecodeTest :: [Char] +encodeDecodeTest = filter (\x -> [x] /= decode (encode [x])) legal_codepoints ++ + filter (\x -> ['\xfffd'] /= decode (encode [x])) illegal_codepoints + where + legal_codepoints = ['\0'..'\xd7ff'] ++ ['\xe000'..'\xfffd'] ++ ['\x10000'..'\x10ffff'] + illegal_codepoints = '\xffff' : '\xfffe' : ['\xd800'..'\xdfff'] + + diff -Nru ghc-7.0.3/libraries/utf8-string/utf8-string.cabal ghc-7.2.1/libraries/utf8-string/utf8-string.cabal --- ghc-7.0.3/libraries/utf8-string/utf8-string.cabal 2011-03-26 18:10:15.000000000 +0000 +++ ghc-7.2.1/libraries/utf8-string/utf8-string.cabal 2011-08-07 17:10:12.000000000 +0000 @@ -1,5 +1,5 @@ Name: utf8-string -Version: 0.3.6 +Version: 0.3.7 Author: Eric Mertens Maintainer: emertens@galois.com License: BSD3 diff -Nru ghc-7.0.3/libraries/Win32/cbits/dumpBMP.c ghc-7.2.1/libraries/Win32/cbits/dumpBMP.c --- ghc-7.0.3/libraries/Win32/cbits/dumpBMP.c 2011-03-26 18:10:15.000000000 +0000 +++ ghc-7.2.1/libraries/Win32/cbits/dumpBMP.c 2011-08-07 17:10:12.000000000 +0000 @@ -34,10 +34,9 @@ //typedef LPBITMAPINFO PBITMAPINFO; // hack to keep cygwin32b17 happy -void CreateBMPFile(LPCSTR pszFileName, HBITMAP hBmp, HDC hDC) +void CreateBMPFile(LPCTSTR pszFileName, HBITMAP hBmp, HDC hDC) { - int hFile; - OFSTRUCT ofReOpenBuff; + HANDLE hFile; HBITMAP hTmpBmp, hBmpOld; BOOL bSuccess; BITMAPFILEHEADER bfh; @@ -46,6 +45,7 @@ BITMAPINFO bmi; PBYTE pjTmp, pjTmpBmi; ULONG sizBMI; + DWORD dwBytesWritten; bSuccess = TRUE; @@ -132,8 +132,8 @@ // // Lets open the file and get ready for writing // - if ((hFile = OpenFile(pszFileName, (LPOFSTRUCT)&ofReOpenBuff, - OF_CREATE | OF_WRITE)) == -1) { + if ((hFile = CreateFileW(pszFileName, GENERIC_WRITE, FILE_SHARE_READ, NULL, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, NULL)) + == INVALID_HANDLE_VALUE) { fprintf(stderr, "Failed in OpenFile!"); goto ErrExit2; } @@ -151,7 +151,7 @@ // // Write out the file header now // - if (_lwrite(hFile, (LPSTR)&bfh, sizeof(BITMAPFILEHEADER)) == -1) { + if (WriteFile(hFile, (LPCVOID)&bfh, sizeof(BITMAPFILEHEADER), &dwBytesWritten, NULL) == -1) { fprintf(stderr, "Failed in WriteFile!"); bSuccess = FALSE; goto ErrExit3; @@ -179,7 +179,7 @@ // // Now write out the BitmapInfoHeader and color table, if any // - if (_lwrite(hFile, (LPSTR)pbmi, sizBMI) == -1) { + if (WriteFile(hFile, (LPCVOID)pbmi, sizBMI, &dwBytesWritten, NULL) == -1) { fprintf(stderr, "Failed in WriteFile!"); bSuccess = FALSE; goto ErrExit4; @@ -188,7 +188,7 @@ // // write the bits also // - if (_lwrite(hFile, (LPSTR)pBits, pbmi->bmiHeader.biSizeImage) == -1) { + if (WriteFile(hFile, (LPCVOID)pBits, pbmi->bmiHeader.biSizeImage, &dwBytesWritten, NULL) == -1) { fprintf(stderr, "Failed in WriteFile!"); bSuccess = FALSE; goto ErrExit4; @@ -199,7 +199,7 @@ SelectObject(hDC, hBmpOld); DeleteObject(hTmpBmp); ErrExit3: - _lclose(hFile); + CloseHandle(hFile); ErrExit2: GlobalFree(pbmi); ErrExit1: diff -Nru ghc-7.0.3/libraries/Win32/ghc.mk ghc-7.2.1/libraries/Win32/ghc.mk --- ghc-7.0.3/libraries/Win32/ghc.mk 2011-03-26 18:10:45.000000000 +0000 +++ ghc-7.2.1/libraries/Win32/ghc.mk 2011-08-07 17:11:00.000000000 +0000 @@ -1,3 +1,4 @@ libraries/Win32_PACKAGE = Win32 libraries/Win32_dist-install_GROUP = libraries +$(if $(filter Win32,$(PACKAGES_STAGE0)),$(eval $(call build-package,libraries/Win32,dist-boot,0))) $(eval $(call build-package,libraries/Win32,dist-install,$(if $(filter Win32,$(STAGE2_PACKAGES)),2,1))) diff -Nru ghc-7.0.3/libraries/Win32/.gitignore ghc-7.2.1/libraries/Win32/.gitignore --- ghc-7.0.3/libraries/Win32/.gitignore 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/libraries/Win32/.gitignore 2011-08-07 17:10:12.000000000 +0000 @@ -0,0 +1,3 @@ +# Specific generated files +GNUmakefile +ghc.mk \ No newline at end of file diff -Nru ghc-7.0.3/libraries/Win32/Graphics/Win32/Control.hsc ghc-7.2.1/libraries/Win32/Graphics/Win32/Control.hsc --- ghc-7.0.3/libraries/Win32/Graphics/Win32/Control.hsc 2011-03-26 18:10:15.000000000 +0000 +++ ghc-7.2.1/libraries/Win32/Graphics/Win32/Control.hsc 2011-08-07 17:10:12.000000000 +0000 @@ -19,7 +19,8 @@ import System.Win32.Types import Graphics.Win32.Message -import Foreign +import Foreign hiding (unsafePerformIO) +import System.IO.Unsafe #include #include diff -Nru ghc-7.0.3/libraries/Win32/Graphics/Win32/GDI/Bitmap.hsc ghc-7.2.1/libraries/Win32/Graphics/Win32/GDI/Bitmap.hsc --- ghc-7.0.3/libraries/Win32/Graphics/Win32/GDI/Bitmap.hsc 2011-03-26 18:10:15.000000000 +0000 +++ ghc-7.2.1/libraries/Win32/Graphics/Win32/GDI/Bitmap.hsc 2011-08-07 17:10:12.000000000 +0000 @@ -376,10 +376,10 @@ createBMPFile :: String -> HBITMAP -> HDC -> IO () createBMPFile name bm dc = - withCString name $ \ c_name -> + withCWString name $ \ c_name -> c_CreateBMPFile c_name bm dc foreign import ccall unsafe "dumpBMP.h CreateBMPFile" - c_CreateBMPFile :: LPCSTR -> HBITMAP -> HDC -> IO () + c_CreateBMPFile :: LPCTSTR -> HBITMAP -> HDC -> IO () {-# CFILES cbits/dumpBMP.c #-} diff -Nru ghc-7.0.3/libraries/Win32/Graphics/Win32/Window.hsc ghc-7.2.1/libraries/Win32/Graphics/Win32/Window.hsc --- ghc-7.0.3/libraries/Win32/Graphics/Win32/Window.hsc 2011-03-26 18:10:15.000000000 +0000 +++ ghc-7.2.1/libraries/Win32/Graphics/Win32/Window.hsc 2011-08-07 17:10:12.000000000 +0000 @@ -20,7 +20,8 @@ import Control.Monad import Data.Maybe -import Foreign +import Foreign hiding (unsafePerformIO) +import System.IO.Unsafe #include diff -Nru ghc-7.0.3/libraries/Win32/include/dumpBMP.h ghc-7.2.1/libraries/Win32/include/dumpBMP.h --- ghc-7.0.3/libraries/Win32/include/dumpBMP.h 2011-03-26 18:10:15.000000000 +0000 +++ ghc-7.2.1/libraries/Win32/include/dumpBMP.h 2011-08-07 17:10:12.000000000 +0000 @@ -3,4 +3,4 @@ /* There's currently no #define that indicate whether we're compiling a .hc file. */ -extern void CreateBMPFile(LPCSTR pszFileName, HBITMAP hBmp, HDC hDC); +extern void CreateBMPFile(LPCTSTR pszFileName, HBITMAP hBmp, HDC hDC); diff -Nru ghc-7.0.3/libraries/Win32/System/Win32/DLL.hsc ghc-7.2.1/libraries/Win32/System/Win32/DLL.hsc --- ghc-7.0.3/libraries/Win32/System/Win32/DLL.hsc 2011-03-26 18:10:15.000000000 +0000 +++ ghc-7.2.1/libraries/Win32/System/Win32/DLL.hsc 2011-08-07 17:10:12.000000000 +0000 @@ -54,7 +54,7 @@ getProcAddress :: HMODULE -> String -> IO Addr getProcAddress hmod procname = - withCString procname $ \ c_procname -> + withCAString procname $ \ c_procname -> failIfNull "GetProcAddress" $ c_GetProcAddress hmod c_procname foreign import stdcall unsafe "windows.h GetProcAddress" c_GetProcAddress :: HMODULE -> LPCSTR -> IO Addr diff -Nru ghc-7.0.3/libraries/Win32/System/Win32/Info.hsc ghc-7.2.1/libraries/Win32/System/Win32/Info.hsc --- ghc-7.0.3/libraries/Win32/System/Win32/Info.hsc 2011-03-26 18:10:15.000000000 +0000 +++ ghc-7.2.1/libraries/Win32/System/Win32/Info.hsc 2011-08-07 17:10:12.000000000 +0000 @@ -16,7 +16,9 @@ import System.Win32.Types -import System.IO.Error hiding (try) +import Prelude hiding (catch) +import Control.Exception (catch) +import System.IO.Error hiding (catch, try) import Foreign ( Storable(sizeOf, alignment, peekByteOff, pokeByteOff, peek, poke) , Ptr, alloca, allocaArray ) diff -Nru ghc-7.0.3/libraries/Win32/System/Win32/NLS.hsc ghc-7.2.1/libraries/Win32/System/Win32/NLS.hsc --- ghc-7.0.3/libraries/Win32/System/Win32/NLS.hsc 2011-03-26 18:10:15.000000000 +0000 +++ ghc-7.2.1/libraries/Win32/System/Win32/NLS.hsc 2011-08-07 17:10:12.000000000 +0000 @@ -350,7 +350,7 @@ stringToUnicode _cp "" = return "" -- MultiByteToWideChar doesn't handle empty strings (#1929) stringToUnicode cp mbstr = - withCStringLen mbstr $ \(cstr,len) -> do + withCAStringLen mbstr $ \(cstr,len) -> do wchars <- failIfZero "MultiByteToWideChar" $ multiByteToWideChar cp 0 diff -Nru ghc-7.0.3/libraries/Win32/System/Win32/Process.hsc ghc-7.2.1/libraries/Win32/System/Win32/Process.hsc --- ghc-7.0.3/libraries/Win32/System/Win32/Process.hsc 2011-03-26 18:10:15.000000000 +0000 +++ ghc-7.2.1/libraries/Win32/System/Win32/Process.hsc 2011-08-07 17:10:12.000000000 +0000 @@ -56,6 +56,12 @@ openProcess :: ProcessAccessRights -> BOOL -> ProcessId -> IO ProcessHandle openProcess r inh i = failIfNull "OpenProcess" $ c_OpenProcess r inh i +foreign import stdcall unsafe "windows.h GetProcessId" + c_GetProcessId :: ProcessHandle -> IO ProcessId + +getProcessId :: ProcessHandle -> IO ProcessId +getProcessId h = failIfZero "GetProcessId" $ c_GetProcessId h + type Th32SnapHandle = HANDLE type Th32SnapFlags = DWORD -- | ProcessId, number of threads, parent ProcessId, process base priority, path of executable file diff -Nru ghc-7.0.3/libraries/Win32/System/Win32/Registry.hsc ghc-7.2.1/libraries/Win32/System/Win32/Registry.hsc --- ghc-7.0.3/libraries/Win32/System/Win32/Registry.hsc 2011-03-26 18:10:15.000000000 +0000 +++ ghc-7.2.1/libraries/Win32/System/Win32/Registry.hsc 2011-08-07 17:10:12.000000000 +0000 @@ -61,7 +61,8 @@ import System.Win32.Types import System.Win32.File -import Foreign +import System.IO.Unsafe +import Foreign hiding (unsafePerformIO) #include diff -Nru ghc-7.0.3/libraries/Win32/System/Win32/SimpleMAPI.hsc ghc-7.2.1/libraries/Win32/System/Win32/SimpleMAPI.hsc --- ghc-7.0.3/libraries/Win32/System/Win32/SimpleMAPI.hsc 2011-03-26 18:10:15.000000000 +0000 +++ ghc-7.2.1/libraries/Win32/System/Win32/SimpleMAPI.hsc 2011-08-07 17:10:12.000000000 +0000 @@ -20,7 +20,9 @@ , Ptr, castPtr, castPtrToFunPtr, nullPtr , touchForeignPtr, alloca, peek, allocaBytes , minusPtr, plusPtr, copyBytes, ForeignPtr ) -import Foreign.C ( withCString, withCStringLen ) +import Foreign.C ( withCAString, withCAStringLen ) + -- Apparently, simple MAPI does not support unicode and probably never will, + -- so this module will just mangle any Unicode in your strings import Graphics.Win32.GDI.Types ( HWND) import System.Win32.DLL ( loadLibrary, c_GetProcAddress, freeLibrary , c_FreeLibraryFinaliser ) @@ -141,7 +143,7 @@ (loadProc "MAPISendMail" dll mkMapiSendMail) where loadProc :: String -> HMODULE -> (FunPtr a -> a) -> IO a - loadProc name dll conv = withCString name $ \name' -> do + loadProc name dll conv = withCAString name $ \name' -> do proc <- failIfNull ("loadMapiDll: " ++ dllname ++ ": " ++ name) $ c_GetProcAddress dll name' return $ conv $ castPtrToFunPtr proc @@ -190,8 +192,8 @@ -> MapiFlag -- ^ None, one or many flags: FORCE_DOWNLOAD, NEW_SESSION, LOGON_UI, PASSWORD_UI -> IO LHANDLE mapiLogon f hwnd ses pw flags = - maybeWith withCString ses $ \ses -> - maybeWith withCString pw $ \pw -> + maybeWith withCAString ses $ \ses -> + maybeWith withCAString pw $ \pw -> alloca $ \out -> do mapiFail_ "MAPILogon: " $ mapifLogon f (maybeHWND hwnd) @@ -242,8 +244,8 @@ act buf resolve err rc = case rc of Recip name addr -> - withCString name $ \name -> - withCString addr $ \addr -> + withCAString name $ \name -> + withCAString addr $ \addr -> allocaBytes (#size MapiRecipDesc) $ \buf -> do (#poke MapiRecipDesc, ulReserved) buf (0::ULONG) (#poke MapiRecipDesc, lpszName) buf name @@ -253,7 +255,7 @@ a buf RecipResolve hwnd flag name fallback -> do res <- alloca $ \res -> - withCString name $ \name' -> do + withCAString name $ \name' -> do errn <- mapifResolveName f ses (maybeHWND hwnd) name' flag 0 res if errn==(#const SUCCESS_SUCCESS) @@ -310,7 +312,7 @@ where w v a = case v of Nothing -> a (nullPtr, 0) - Just x -> withCStringLen x a + Just x -> withCAStringLen x a data Attachment = Attachment { attFlag :: MapiFlag @@ -330,9 +332,9 @@ len = length att write act _ [] = act write act buf (att:y) = - withCString (attPath att) $ \path -> + withCAString (attPath att) $ \path -> maybeWith withFileTag (attTag att) $ \tag -> - withCString (maybe (attPath att) id (attName att)) $ \name -> do + withCAString (maybe (attPath att) id (attName att)) $ \name -> do (#poke MapiFileDesc, ulReserved) buf (0::ULONG) (#poke MapiFileDesc, flFlags) buf (attFlag att) (#poke MapiFileDesc, nPosition) buf (maybe 0xffffffff id $ attPosition att) @@ -363,11 +365,11 @@ -> (Ptr Message -> IO a) -> IO a withMessage f ses m act = - withCString (msgSubject m) $ \subject -> - withCString (msgBody m) $ \body -> - maybeWith withCString (msgType m) $ \message_type -> - maybeWith withCString (msgDate m) $ \date -> - maybeWith withCString (msgConversationId m) $ \conv_id -> + withCAString (msgSubject m) $ \subject -> + withCAString (msgBody m) $ \body -> + maybeWith withCAString (msgType m) $ \message_type -> + maybeWith withCAString (msgDate m) $ \date -> + maybeWith withCAString (msgConversationId m) $ \conv_id -> withRecipients f ses (msgRecips m) $ \rlen rbuf -> withAttachments (msgAttachments m) $ \alen abuf -> maybeWith (withRecipient f ses RcOriginal) (msgFrom m) $ \from -> diff -Nru ghc-7.0.3/libraries/Win32/System/Win32/Time.hsc ghc-7.2.1/libraries/Win32/System/Win32/Time.hsc --- ghc-7.0.3/libraries/Win32/System/Win32/Time.hsc 2011-03-26 18:10:15.000000000 +0000 +++ ghc-7.2.1/libraries/Win32/System/Win32/Time.hsc 2011-08-07 17:10:12.000000000 +0000 @@ -300,5 +300,5 @@ size <- c_GetTimeFormat locale flags st fmt nullPtr 0 allocaBytes ((fromIntegral size) * (sizeOf (undefined::CWchar))) $ \out -> do size <- failIf (==0) "getTimeFormat: GetTimeFormat" $ - c_GetTimeFormat locale flags st fmt (castPtr out) (fromIntegral size) + c_GetTimeFormat locale flags st fmt (castPtr out) size peekTStringLen (out,fromIntegral size) diff -Nru ghc-7.0.3/libraries/Win32/System/Win32/Types.hs ghc-7.2.1/libraries/Win32/System/Win32/Types.hs --- ghc-7.0.3/libraries/Win32/System/Win32/Types.hs 2011-03-26 18:10:15.000000000 +0000 +++ ghc-7.2.1/libraries/Win32/System/Win32/Types.hs 2011-08-07 17:10:12.000000000 +0000 @@ -18,10 +18,11 @@ ) where import Data.Maybe -import Foreign +import Foreign hiding (unsafePerformIO) import Foreign.C import Control.Exception import System.IO.Error +import System.IO.Unsafe import Data.Char import Numeric (showHex) diff -Nru ghc-7.0.3/libraries/Win32/Win32.cabal ghc-7.2.1/libraries/Win32/Win32.cabal --- ghc-7.0.3/libraries/Win32/Win32.cabal 2011-03-26 18:10:15.000000000 +0000 +++ ghc-7.2.1/libraries/Win32/Win32.cabal 2011-08-07 17:10:12.000000000 +0000 @@ -1,5 +1,5 @@ name: Win32 -version: 2.2.0.1 +version: 2.2.1.0 license: BSD3 license-file: LICENSE author: Alastair Reid @@ -58,6 +58,8 @@ System.Win32.Types System.Win32.Shell extensions: ForeignFunctionInterface + if impl(ghc >= 7.1) + extensions: NondecreasingIndentation extra-libraries: "user32", "gdi32", "winmm", "advapi32", "shell32", "shfolder" include-dirs: include @@ -73,6 +75,6 @@ cbits/errors.c source-repository head - type: darcs - location: http://darcs.haskell.org/packages/Win32/ + type: git + location: http://darcs.haskell.org/packages/Win32.git/ diff -Nru ghc-7.0.3/libraries/xhtml/ghc.mk ghc-7.2.1/libraries/xhtml/ghc.mk --- ghc-7.0.3/libraries/xhtml/ghc.mk 2011-03-26 18:10:45.000000000 +0000 +++ ghc-7.2.1/libraries/xhtml/ghc.mk 2011-08-07 17:11:00.000000000 +0000 @@ -1,3 +1,4 @@ libraries/xhtml_PACKAGE = xhtml libraries/xhtml_dist-install_GROUP = libraries +$(if $(filter xhtml,$(PACKAGES_STAGE0)),$(eval $(call build-package,libraries/xhtml,dist-boot,0))) $(eval $(call build-package,libraries/xhtml,dist-install,$(if $(filter xhtml,$(STAGE2_PACKAGES)),2,1))) diff -Nru ghc-7.0.3/libraries/xhtml/xhtml.cabal ghc-7.2.1/libraries/xhtml/xhtml.cabal --- ghc-7.0.3/libraries/xhtml/xhtml.cabal 2011-03-26 18:10:15.000000000 +0000 +++ ghc-7.2.1/libraries/xhtml/xhtml.cabal 2011-08-07 17:10:12.000000000 +0000 @@ -6,7 +6,7 @@ Author: Bjorn Bringert License: BSD3 License-file: LICENSE -build-depends: base >= 4.0 && < 4.4 +build-depends: base >= 4.0 && < 4.5 Extensions: Synopsis: An XHTML combinator library Description: diff -Nru ghc-7.0.3/Makefile ghc-7.2.1/Makefile --- ghc-7.0.3/Makefile 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/Makefile 2011-08-07 17:10:05.000000000 +0000 @@ -45,7 +45,7 @@ include mk/custom-settings.mk # No need to update makefiles for these targets: -REALGOALS=$(filter-out binary-dist binary-dist-prep bootstrapping-files framework-pkg clean clean_% distclean maintainer-clean show help install-docs test fulltest,$(MAKECMDGOALS)) +REALGOALS=$(filter-out binary-dist binary-dist-prep bootstrapping-files framework-pkg clean clean_% distclean maintainer-clean show help test fulltest,$(MAKECMDGOALS)) # configure touches certain files even if they haven't changed. This # can mean a lot of unnecessary recompilation after a re-configure, so @@ -60,22 +60,16 @@ # it does nothing if we specify a target that already exists. .PHONY: $(REALGOALS) $(REALGOALS) all: mk/config.mk.old mk/project.mk.old compiler/ghc.cabal.old - @echo "===--- updating makefiles phase 0" - $(MAKE) -r --no-print-directory -f ghc.mk phase=0 just-makefiles -ifneq "$(OMIT_PHASE_1)" "YES" - @echo "===--- updating makefiles phase 1" - $(MAKE) -r --no-print-directory -f ghc.mk phase=1 just-makefiles +ifneq "$(OMIT_PHASE_0)" "YES" + @echo "===--- building phase 0" + $(MAKE) -r --no-print-directory -f ghc.mk phase=0 phase_0_builds endif -ifneq "$(OMIT_PHASE_2)" "YES" - @echo "===--- updating makefiles phase 2" - $(MAKE) -r --no-print-directory -f ghc.mk phase=2 just-makefiles -endif -ifneq "$(OMIT_PHASE_3)" "YES" - @echo "===--- updating makefiles phase 3" - $(MAKE) -r --no-print-directory -f ghc.mk phase=3 just-makefiles +ifneq "$(OMIT_PHASE_1)" "YES" + @echo "===--- building phase 1" + $(MAKE) -r --no-print-directory -f ghc.mk phase=1 phase_1_builds endif - @echo "===--- finished updating makefiles" - $(MAKE) -r --no-print-directory -f ghc.mk $@ + @echo "===--- building final phase" + $(MAKE) -r --no-print-directory -f ghc.mk phase=final $@ binary-dist: binary-dist-prep ifeq "$(mingw32_TARGET_OS)" "1" @@ -108,12 +102,6 @@ $(MAKE) -C distrib/MacOS $@ endif -# install-docs is a historical target that isn't supported in GHC 6.12. See #3662. -install-docs: - @echo "The install-docs target is not supported in GHC 6.12.1 and later." - @echo "'make install' now installs everything, including documentation." - @exit 1 - # If the user says 'make A B', then we don't want to invoke two # instances of the rule above in parallel: .NOTPARALLEL: @@ -122,9 +110,9 @@ .PHONY: test test: - $(MAKE) -C testsuite/tests/ghc-regress CLEANUP=1 OUTPUT_SUMMARY=../../../testsuite_summary.txt fast + $(MAKE) -C testsuite/tests CLEANUP=1 OUTPUT_SUMMARY=../../testsuite_summary.txt fast .PHONY: fulltest fulltest: - $(MAKE) -C testsuite/tests/ghc-regress CLEANUP=1 OUTPUT_SUMMARY=../../../testsuite_summary.txt + $(MAKE) -C testsuite/tests CLEANUP=1 OUTPUT_SUMMARY=../../testsuite_summary.txt diff -Nru ghc-7.0.3/mk/build.mk.sample ghc-7.2.1/mk/build.mk.sample --- ghc-7.0.3/mk/build.mk.sample 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/mk/build.mk.sample 2011-08-07 17:10:05.000000000 +0000 @@ -7,15 +7,17 @@ # Uncomment one of these to select a build profile below: -# Full build with max optimisation (slow build) +# Full build with max optimisation and everything enabled (very slow build) #BuildFlavour = perf -# Fastest build (libs unoptimised): -#BuildFlavour = quickest - -# Fast build with optimised libraries: +# Fast build with optimised libraries, no profiling (RECOMMENDED): #BuildFlavour = quick +# Even faster build. NOT RECOMMENDED: the libraries will be +# completely unoptimised, so any code built with this compiler +# (including stage2) will run very slowly: +#BuildFlavour = quickest + # Profile the stage2 compiler: #BuildFlavour = prof @@ -25,6 +27,9 @@ # A development build, working on the stage 2 compiler: #BuildFlavour = devel2 +# An unregisterised, optimised build of ghc, for porting: +#BuildFlavour = unreg + GhcLibWays = v # -------- 1. A Performance/Distribution build-------------------------------- @@ -37,7 +42,7 @@ GhcStage1HcOpts = -O -fasm GhcStage2HcOpts = -O2 -fasm GhcHcOpts = -Rghc-timing -GhcLibHcOpts = -O2 -XGenerics +GhcLibHcOpts = -O2 GhcLibWays += p ifeq "$(PlatformSupportsSharedLibs)" "YES" @@ -131,17 +136,28 @@ endif -# ----------------------------------------------------------------------------- -# Other settings that might be useful +# -------- A Unregisterised build) ------------------------------------------- + +ifeq "$(BuildFlavour)" "unreg" + +GhcUnregisterised = YES +GhcWithNativeCodeGen = NO -# profiled RTS -#GhcRtsCcOpts = -pg -g +SRC_HC_OPTS = -O -H64m +GhcStage1HcOpts = -O +GhcStage2HcOpts = -O2 +GhcHcOpts = -Rghc-timing +GhcLibHcOpts = -O2 +SplitObjs = NO +HADDOCK_DOCS = NO +BUILD_DOCBOOK_HTML = NO +BUILD_DOCBOOK_PS = NO +BUILD_DOCBOOK_PDF = NO -# Optimised/profiled RTS -#GhcRtsCcOpts = -O2 -pg +endif -#GhcRtsWithFrontPanel = YES -#SRC_HC_OPTS += `gtk-config --libs` +# ----------------------------------------------------------------------------- +# Other settings that might be useful # NoFib settings NoFibWays = diff -Nru ghc-7.0.3/mk/compiler-ghc.mk ghc-7.2.1/mk/compiler-ghc.mk --- ghc-7.0.3/mk/compiler-ghc.mk 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/mk/compiler-ghc.mk 2011-08-07 17:10:05.000000000 +0000 @@ -0,0 +1,59 @@ +# ----------------------------------------------------------------------------- +# +# (c) 2009 The University of Glasgow +# +# This file is part of the GHC build system. +# +# To understand how the build system works and how to modify it, see +# http://hackage.haskell.org/trac/ghc/wiki/Building/Architecture +# http://hackage.haskell.org/trac/ghc/wiki/Building/Modifying +# +# ----------------------------------------------------------------------------- + +dir = ghc +TOP = .. +SPEC_TARGETS = 1 2 3 +include $(TOP)/mk/sub-makefile.mk + +FAST_MAKE_OPTS += compiler_stage1_NO_BUILD_DEPS=YES \ + compiler_stage2_NO_BUILD_DEPS=YES \ + compiler_stage3_NO_BUILD_DEPS=YES \ + ghc_stage1_NO_BUILD_DEPS=YES \ + ghc_stage2_NO_BUILD_DEPS=YES \ + ghc_stage3_NO_BUILD_DEPS=YES + +.PHONY: 1 2 3 + +1: + +$(TOPMAKE) stage=1 all_ghc_stage1 $(FAST_MAKE_OPTS) ONLY_DEPS_FOR="compiler_stage1 ghc_stage1" + +2: + +$(TOPMAKE) stage=2 all_ghc_stage2 $(FAST_MAKE_OPTS) ONLY_DEPS_FOR="compiler_stage2 ghc_stage2" NO_STAGE2_DEPS=YES + +3: + +$(TOPMAKE) stage=3 all_ghc_stage3 $(FAST_MAKE_OPTS) ONLY_DEPS_FOR="compiler_stage3 ghc_stage3" NO_STAGE3_DEPS=YES + + +# 'make re2' rebuilds stage2, removing the old executable first. Useful for +# something like 'make re2 GhcDebugged=YES'. + +.PHONY: re1 re2 re3 +re1: + $(RM) $(TOP)/ghc/stage1/build/tmp/ghc-stage1 + $(MAKE) 1 +re2: + $(RM) $(TOP)/ghc/stage2/build/tmp/ghc-stage2 + $(MAKE) 2 +re3: + $(RM) $(TOP)/ghc/stage3/build/tmp/ghc-stage3 + $(MAKE) 3 + +.PHONY: extra-help +help : extra-help +extra-help : + @echo " make 1" + @echo " make 2" + @echo " make 3" + @echo + @echo " Build the stage 1, 2 or 3 GHC respectively, omitting dependencies" + @echo " and initial phases for speed." diff -Nru ghc-7.0.3/mk/config.h.in ghc-7.2.1/mk/config.h.in --- ghc-7.0.3/mk/config.h.in 2011-03-26 18:10:47.000000000 +0000 +++ ghc-7.2.1/mk/config.h.in 2011-08-07 17:11:02.000000000 +0000 @@ -54,6 +54,9 @@ significant byte first */ #undef FLOAT_WORDS_BIGENDIAN +/* Has visibility hidden */ +#undef HAS_VISIBILITY_HIDDEN + /* Define to 1 if you have `alloca', as a function or macro. */ #undef HAVE_ALLOCA diff -Nru ghc-7.0.3/mk/config.mk.in ghc-7.2.1/mk/config.mk.in --- ghc-7.0.3/mk/config.mk.in 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/mk/config.mk.in 2011-08-07 17:10:05.000000000 +0000 @@ -97,6 +97,16 @@ GhcStage2HcOpts=-O2 GhcStage3HcOpts=-O2 +# These options modify whether or not a built compiler for a bootstrap +# stage defaults to using the new code generation path. The new +# code generation path is a bit slower, so for development just +# GhcStage2DefaultNewCodegen=YES, but it's also a good idea to try +# building all libraries and the stage2 compiler with the +# new code generator, which involves GhcStage1DefaultNewCodegen=YES. +GhcStage1DefaultNewCodegen=NO +GhcStage2DefaultNewCodegen=NO +GhcStage3DefaultNewCodegen=NO + GhcDebugged=NO GhcDynamic=NO @@ -104,13 +114,18 @@ GhcProfiled=NO # Do we support shared libs? -PlatformSupportsSharedLibs = $(if $(filter $(TARGETPLATFORM),\ - i386-unknown-linux x86_64-unknown-linux \ +SharedLibsPlatformList = i386-unknown-linux x86_64-unknown-linux \ i386-unknown-freebsd x86_64-unknown-freebsd \ i386-unknown-openbsd x86_64-unknown-openbsd \ i386-unknown-mingw32 \ - i386-unknown-solaris2 \ - i386-apple-darwin powerpc-apple-darwin),YES,NO) + i386-apple-darwin powerpc-apple-darwin + +ifeq "$(SOLARIS_BROKEN_SHLD)" "NO" +SharedLibsPlatformList += i386-unknown-solaris2 +endif + +PlatformSupportsSharedLibs = $(if $(filter $(TARGETPLATFORM),\ + $(SharedLibsPlatformList)),YES,NO) # Build a compiler that will build *unregisterised* libraries and # binaries by default. Unregisterised code is supposed to compile and @@ -146,9 +161,6 @@ $(if $(filter YESYESNO,\ $(OsSupportsNCG)$(ArchSupportsNCG)$(GhcUnregisterised)),YES,NO)) -# Build a compiler with the llvm code generator backend -GhcWithLlvmCodeGen=NO - HaveLibDL = @HaveLibDL@ # ArchSupportsSMP should be set iff there is support for that arch in @@ -270,13 +282,8 @@ # # -O(2) is pretty desirable, otherwise no inlining of prelude # things (incl "+") happens when compiling with this compiler -# -# -XGenerics switches on generation of support code for -# derivable type classes. This is now off by default, -# but we switch it on for the libraries so that we generate -# the code in case someone importing wants it -GhcLibHcOpts=-O2 -XGenerics +GhcLibHcOpts=-O2 # Strip local symbols from libraries? This can make the libraries smaller, # but makes debugging somewhat more difficult. Doesn't work with all ld's. @@ -410,9 +417,6 @@ # These flags make flex 8-bit SRC_FLEX_OPTS += -8 -# Default fptools options for dllwrap. -SRC_BLD_DLL_OPTS += --target=i386-mingw32 - # Flags for CPP when running GreenCard on .pgc files GC_CPP_OPTS += -P -E -x c -traditional -D__GLASGOW_HASKELL__ @@ -428,7 +432,6 @@ GHC_GHCTAGS_PGM = ghctags$(exeext) GHC_HSC2HS_PGM = hsc2hs$(exeext) GHC_TOUCHY_PGM = touchy$(exeext) -GHC_MANGLER_PGM = ghc-asm GHC_SPLIT_PGM = ghc-split GHC_SYSMAN_PGM = SysMan GHC_GENPRIMOP_PGM = genprimopcode$(exeext) @@ -438,7 +441,6 @@ GHC_LTX_PGM = ltx$(exeext) GHC_MKDIRHIER_PGM = mkdirhier GHC_LNDIR_PGM = lndir -GHC_DUMMY_GHC_PGM = dummy-ghc$(exeext) ifeq "$(TARGETPLATFORM)" "i386-unknown-mingw32" GHC_CP = "xcopy /y" @@ -449,7 +451,6 @@ endif HP2PS = $(GHC_HP2PS_DIR)/$(GHC_HP2PS_PGM) -MANGLER = $(INPLACE_LIB)/$(GHC_MANGLER_PGM) SPLIT = $(INPLACE_LIB)/$(GHC_SPLIT_PGM) SYSMAN = $(GHC_SYSMAN_DIR)/$(GHC_SYSMAN_PGM) LTX = $(GHC_LTX_DIR)/$(GHC_LTX_PGM) @@ -464,19 +465,14 @@ GHCTAGS_INPLACE = $(INPLACE_BIN)/$(GHC_GHCTAGS_PGM) HSC2HS_INPLACE = $(INPLACE_BIN)/$(GHC_HSC2HS_PGM) GENPRIMOP_INPLACE = $(INPLACE_BIN)/$(GHC_GENPRIMOP_PGM) -DUMMY_GHC_INPLACE = $(INPLACE_BIN)/$(GHC_DUMMY_GHC_PGM) GENERATED_FILE = chmod a-w EXECUTABLE_FILE = chmod +x #----------------------------------------------------------------------------- -# Haskell compilers and mkdependHS +# Installed GHC -# $(GHC), $(HBC) and $(NHC) point to installed versions of the relevant -# compilers, if available. -# -# $(HC) is a generic Haskell 98 compiler, set to $(GHC) by default. -# $(MKDEPENDHS) is the Haskell dependency generator (ghc -M). +# $(GHC) points to installed version of the compiler. # # NOTE: Don't override $(GHC) in build.mk, use configure --with-ghc instead # (because the version numbers have to be calculated). @@ -489,14 +485,6 @@ GHC := $(GHC).exe endif -GhcDir = $(dir $(GHC)) - -# Set to YES if $(GHC) has the editline package installed -GhcHasEditline = @GhcHasEditline@ - -HBC = @HBC@ -NHC = @NHC@ - # Sometimes we want to invoke ghc from the build tree in different # places (eg. it's handy to have a nofib & a ghc build in the same # tree). We can refer to "this ghc" as $(GHC_INPLACE): @@ -526,8 +514,6 @@ GhcMinVersion = @GhcMinVersion@ # Keep this in sync with the variables in package-config.mk -ghc_ge_6102 = @ghc_ge_6102@ -ghc_ge_611 = @ghc_ge_611@ ghc_ge_613 = @ghc_ge_613@ # Canonicalised ghc version number, used for easy (integer) version @@ -546,18 +532,20 @@ # 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@ +GccLT46 = @GccLT46@ +CC = $(WhatGccIsCalled) +CC_STAGE0 = @CC_STAGE0@ +CC_STAGE1 = $(CC) +CC_STAGE2 = $(CC) +CC_STAGE3 = $(CC) +AS = $(WhatGccIsCalled) +AS_STAGE0 = @CC_STAGE0@ +AS_STAGE1 = $(AS) +AS_STAGE2 = $(AS) +AS_STAGE3 = $(AS) # C compiler and linker flags from configure (e.g. -m to select # correct C compiler backend). The stage number is the stage of GHC @@ -579,6 +567,12 @@ CONF_CC_OPTS += -G0 endif +# The .hsc files aren't currently safe for cross-compilation on Windows: +# libraries\haskeline\.\System\Console\Haskeline\Backend\Win32.hsc:160 +# directive "let" is not safe for cross-compilation +ifneq "$(Windows)" "YES" +SRC_HSC2HS_OPTS += --cross-safe +endif SRC_HSC2HS_OPTS += $(addprefix --cflag=,$(filter-out -O,$(SRC_CC_OPTS) $(CONF_CC_OPTS_STAGE0))) SRC_HSC2HS_OPTS += $(foreach d,$(GMP_INCLUDE_DIRS),-I$(d)) @@ -601,10 +595,24 @@ 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_STAGE0@ +AR_STAGE1 = $(AR) +AR_STAGE2 = $(AR) +AR_STAGE3 = $(AR) +AR_OPTS_STAGE0 = @AR_OPTS_STAGE0@ +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_STAGE0@ +ArSupportsAtFile_STAGE1 = $(ArSupportsAtFile) +ArSupportsAtFile_STAGE2 = $(ArSupportsAtFile) +ArSupportsAtFile_STAGE3 = $(ArSupportsAtFile) CONTEXT_DIFF = @ContextDiffCmd@ CP = cp @@ -637,7 +645,6 @@ PERL = @PerlCmd@ PYTHON = @PythonCmd@ PIC = pic -PREPROCESSCMD = $(CC) -E RANLIB = @RANLIB@ SED = @SedCmd@ TR = tr @@ -659,6 +666,10 @@ # overflowing command-line length limits. LdIsGNULd = @LdIsGNULd@ +# Set to YES if ld has the --build-id flag. Sometimes we need to +# disable it with --build-id=none. +LdHasBuildId = @LdHasBuildId@ + # On MSYS, building with SplitObjs=YES fails with # ar: Bad file number # see #3201. We need to specify a smaller max command-line size @@ -729,8 +740,6 @@ #----------------------------------------------------------------------------- # FPtools support software -BLD_DLL = dllwrap - # # ghc-pkg # @@ -746,10 +755,6 @@ # SRC_HAPPY_OPTS = -agc --strict -# Temp. to work around performance problems in the HEAD around 8/12/2003, -# A Happy compiled with this compiler needs more stack. -SRC_HAPPY_OPTS += +RTS -K2m -RTS - # # Alex # @@ -760,8 +765,6 @@ # SRC_ALEX_OPTS = -g -HSTAGS = @HstagsCmd@ - # Should we build haddock docs? HADDOCK_DOCS = YES # And HsColour the sources? diff -Nru ghc-7.0.3/mk/project.mk.in ghc-7.2.1/mk/project.mk.in --- ghc-7.0.3/mk/project.mk.in 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/mk/project.mk.in 2011-08-07 17:10:05.000000000 +0000 @@ -139,3 +139,7 @@ # This distinguishes "msys" and "cygwin", which are not # not distinguished by HOST_OS_CPP OSTYPE=@OSTYPE@ + +# In case of Solaris OS, does it provide broken shared libs +# linker or not? +SOLARIS_BROKEN_SHLD=@SOLARIS_BROKEN_SHLD@ diff -Nru ghc-7.0.3/mk/sub-makefile.mk ghc-7.2.1/mk/sub-makefile.mk --- ghc-7.0.3/mk/sub-makefile.mk 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/mk/sub-makefile.mk 2011-08-07 17:10:05.000000000 +0000 @@ -22,7 +22,8 @@ $(dir)_dist_NO_BUILD_DEPS=YES \ $(dir)_dist-boot_NO_BUILD_DEPS=YES \ $(dir)_dist-install_NO_BUILD_DEPS=YES \ - OMIT_PHASE_1=YES OMIT_PHASE_2=YES OMIT_PHASE_3=YES + NO_GENERATED_MAKEFILE_RULES=YES \ + OMIT_PHASE_0=YES OMIT_PHASE_1=YES ifneq "$(filter fast,$(MAKECMDGOALS))" "" EXTRA_MAKE_OPTS += $(FAST_MAKE_OPTS) diff -Nru ghc-7.0.3/mk/tree.mk ghc-7.2.1/mk/tree.mk --- ghc-7.0.3/mk/tree.mk 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/mk/tree.mk 2011-08-07 17:10:05.000000000 +0000 @@ -36,7 +36,6 @@ GHC_GENPRIMOP_DIR = $(GHC_UTILS_DIR)/genprimopcode GHC_GENAPPLY_DIR = $(GHC_UTILS_DIR)/genapply GHC_CABAL_DIR = $(GHC_UTILS_DIR)/ghc-cabal -GHC_MANGLER_DIR = $(GHC_DRIVER_DIR)/mangler GHC_SPLIT_DIR = $(GHC_DRIVER_DIR)/split GHC_SYSMAN_DIR = $(GHC_RTS_DIR)/parallel diff -Nru ghc-7.0.3/mk/validate-settings.mk ghc-7.2.1/mk/validate-settings.mk --- ghc-7.0.3/mk/validate-settings.mk 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/mk/validate-settings.mk 2011-08-07 17:10:05.000000000 +0000 @@ -4,9 +4,21 @@ WERROR = -Werror HADDOCK_DOCS = YES + SRC_CC_OPTS += -Wall $(WERROR) +# Debian doesn't turn -Werror=unused-but-set-variable on by default, so +# we turn it on explicitly for consistency with other users +ifeq "$(GccLT46)" "NO" +SRC_CC_OPTS += -Werror=unused-but-set-variable +# gcc 4.6 gives 3 warning for giveCapabilityToTask not being inlined +SRC_CC_OPTS += -Wno-error=inline +endif + SRC_HC_OPTS += -Wall $(WERROR) -H64m -O0 +# Safe by default +#SRC_HC_OPTS += -Dsh_SAFE_DEFAULT + GhcStage1HcOpts += -O GhcStage2HcOpts += -O @@ -23,7 +35,7 @@ CHECK_PACKAGES = YES # We want to install DPH when validating, so that we can test it -InstallExtraPackages = YES +InstallExtraPackages = YES # dblatex with miktex under msys/mingw can't build the PS and PDF docs, # and just building the HTML docs is sufficient to check that the @@ -36,25 +48,46 @@ GhcStage2HcOpts += -fhpc -hpcdir $(TOP)/testsuite/hpc_output/ endif ifeq "$(ValidateSlow)" "YES" -GhcStage2HcOpts += -XGenerics -DDEBUG -GhcLibHcOpts += -XGenerics +GhcStage2HcOpts += -DDEBUG endif ###################################################################### # Disable some warnings in packages we use +# Cabal doesn't promise to be warning-free +utils/ghc-cabal_dist_EXTRA_HC_OPTS += -w +libraries/Cabal/cabal_dist-boot_EXTRA_HC_OPTS += -w +libraries/Cabal/cabal_dist-install_EXTRA_HC_OPTS += -w + +# Temporarily turn off incomplete-pattern warnings for containers +libraries/containers_dist-install_EXTRA_HC_OPTS += -fno-warn-incomplete-patterns + +# bytestring has identities at the moment +libraries/bytestring_dist-install_EXTRA_HC_OPTS += -fno-warn-identities + # Temporarily turn off unused-do-bind warnings for the time package -libraries/time_dist-install_EXTRA_HC_OPTS += -fno-warn-unused-do-bind +libraries/time_dist-install_EXTRA_HC_OPTS += -fno-warn-unused-do-bind +# Temporary: mkTyCon is deprecated +libraries/time_dist-install_EXTRA_HC_OPTS += -fno-warn-deprecations # On Windows, there are also some unused import warnings -libraries/time_dist-install_EXTRA_HC_OPTS += -fno-warn-unused-imports +libraries/time_dist-install_EXTRA_HC_OPTS += -fno-warn-unused-imports -fno-warn-identities # haskeline has warnings about deprecated use of block/unblock libraries/haskeline_dist-install_EXTRA_HC_OPTS += -fno-warn-deprecations libraries/haskeline_dist-install_EXTRA_HC_OPTS += -fno-warn-unused-imports # Temporarily turn off unused-import warnings for the binary package -libraries/ghc-binary_dist-boot_EXTRA_HC_OPTS += -fno-warn-unused-imports -libraries/ghc-binary_dist-install_EXTRA_HC_OPTS += -fno-warn-unused-imports +libraries/binary_dist-boot_EXTRA_HC_OPTS += -fno-warn-unused-imports +libraries/binary_dist-install_EXTRA_HC_OPTS += -fno-warn-unused-imports -fno-warn-identities + +# Temporarily turn off -Werror for some Hoopl modules that have +# non-exhaustive pattern-match warnings +libraries/hoopl/src/Compiler/Hoopl/Util_HC_OPTS += -Wwarn +libraries/hoopl/src/Compiler/Hoopl/GraphUtil_HC_OPTS += -Wwarn +libraries/hoopl/src/Compiler/Hoopl/MkGraph_HC_OPTS += -Wwarn +libraries/hoopl/src/Compiler/Hoopl/XUtil_HC_OPTS += -Wwarn +libraries/hoopl/src/Compiler/Hoopl/Pointed_HC_OPTS += -Wwarn +libraries/hoopl/src/Compiler/Hoopl/Passes/Dominator_HC_OPTS += -Wwarn # primitive has a warning about deprecated use of GHC.IOBase libraries/primitive_dist-install_EXTRA_HC_OPTS += -Wwarn @@ -69,6 +102,10 @@ libraries/dph/dph-seq_dist-install_EXTRA_HC_OPTS += -Wwarn libraries/dph/dph-par_dist-install_EXTRA_HC_OPTS += -Wwarn +# We need to turn of deprecated warnings for SafeHaskell transition +libraries/array_dist-install_EXTRA_HC_OPTS += -fno-warn-warnings-deprecations +libraries/binary_dist-install_EXTRA_HC_OPTS += -fno-warn-warnings-deprecations + # We need -fno-warn-deprecated-flags to avoid failure with -Werror GhcLibHcOpts += -fno-warn-deprecated-flags GhcBootLibHcOpts += -fno-warn-deprecated-flags diff -Nru ghc-7.0.3/packages ghc-7.2.1/packages --- ghc-7.0.3/packages 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/packages 2011-08-07 17:10:05.000000000 +0000 @@ -1,5 +1,8 @@ # Despite the name "package", this file contains the master list of -# the *repositories* that make up GHC. It is parsed by boot and darcs-all. +# the *repositories* that make up GHC. It is parsed by +# * boot +# * sync-all +# * rules/extra-packages.mk # # Some of this information is duplicated elsewhere in the build system: # See Trac #3896 @@ -17,7 +20,7 @@ # - nofib and testsuite are optional helpers # # The format of the lines in this file is: -# localpath tag remotepath VCS upstream +# localpath tag remotepath VCS # where # * 'localpath' is where to put the repository in a checked out tree. # * 'remotepath' is where the repository is in the central repository. @@ -34,51 +37,45 @@ # deems to have the EXTRA_PACKAGE property: tags 'dph' and 'extra' # both give this property # -# * 'upstream' is the URL of the upstream repo, where there is one, or -# "-" if there is no upstream. -# # Lines that start with a '#' are comments. -. - ghc git - -ghc-tarballs - ghc-tarballs darcs - -utils/hsc2hs - hsc2hs darcs - -# haddock does have an upstream: -# http://code.haskell.org/haddock/ -# but it stays buildable with the last stable release rather than tracking HEAD, -# and is resynced with the GHC HEAD branch by David Waern when appropriate -utils/haddock - haddock2 darcs - -libraries/array - packages/array darcs - -libraries/base - packages/base darcs - -libraries/ghc-binary - packages/ghc-binary darcs http://code.haskell.org/binary/ -libraries/bytestring - packages/bytestring darcs http://darcs.haskell.org/bytestring/ -libraries/Cabal - packages/Cabal darcs http://darcs.haskell.org/cabal/ -libraries/containers - packages/containers darcs - -libraries/directory - packages/directory darcs - -libraries/extensible-exceptions - packages/extensible-exceptions darcs - -libraries/filepath - packages/filepath darcs - -libraries/ghc-prim - packages/ghc-prim darcs - -libraries/haskeline - packages/haskeline darcs http://code.haskell.org/haskeline/ -libraries/haskell98 - packages/haskell98 darcs - -libraries/haskell2010 - packages/haskell2010 darcs - -libraries/hpc - packages/hpc darcs - -libraries/integer-gmp - packages/integer-gmp darcs - -libraries/integer-simple - packages/integer-simple darcs - -libraries/mtl - packages/mtl darcs - -libraries/old-locale - packages/old-locale darcs - -libraries/old-time - packages/old-time darcs - -libraries/pretty - packages/pretty darcs - -libraries/process - packages/process darcs - -libraries/random - packages/random darcs - -libraries/template-haskell - packages/template-haskell darcs - -libraries/terminfo - packages/terminfo darcs http://code.haskell.org/terminfo/ -libraries/unix - packages/unix darcs - -libraries/utf8-string - packages/utf8-string darcs http://code.haskell.org/utf8-string/ -libraries/Win32 - packages/Win32 darcs - -libraries/xhtml - packages/xhtml darcs - -testsuite testsuite testsuite darcs - -nofib nofib nofib darcs - -libraries/deepseq extra packages/deepseq darcs - -libraries/parallel extra packages/parallel darcs - -libraries/stm extra packages/stm darcs - -libraries/primitive dph packages/primitive darcs - -libraries/vector dph packages/vector darcs - -libraries/dph dph packages/dph darcs - +. - ghc.git git +ghc-tarballs - ghc-tarballs.git git +utils/hsc2hs - hsc2hs.git git +utils/haddock - haddock.git git +libraries/array - packages/array.git git +libraries/base - packages/base.git git +libraries/binary - packages/binary.git git +libraries/bytestring - packages/bytestring.git git +libraries/Cabal - packages/cabal-1.12.git git +libraries/containers - packages/containers.git git +libraries/directory - packages/directory.git git +libraries/extensible-exceptions - packages/extensible-exceptions.git git +libraries/filepath - packages/filepath.git git +libraries/ghc-prim - packages/ghc-prim.git git +libraries/haskeline - packages/haskeline.git git +libraries/haskell98 - packages/haskell98.git git +libraries/haskell2010 - packages/haskell2010.git git +libraries/hoopl - packages/hoopl.git git +libraries/hpc - packages/hpc.git git +libraries/integer-gmp - packages/integer-gmp.git git +libraries/integer-simple - packages/integer-simple.git git +libraries/mtl - packages/mtl.git git +libraries/old-locale - packages/old-locale.git git +libraries/old-time - packages/old-time.git git +libraries/pretty - packages/pretty.git git +libraries/process - packages/process.git git +libraries/template-haskell - packages/template-haskell.git git +libraries/terminfo - packages/terminfo.git git +libraries/unix - packages/unix.git git +libraries/utf8-string - packages/utf8-string.git git +libraries/Win32 - packages/Win32.git git +libraries/xhtml - packages/xhtml.git git +testsuite testsuite testsuite.git git +nofib nofib nofib.git git +libraries/deepseq extra packages/deepseq.git git +libraries/parallel extra packages/parallel.git git +libraries/stm extra packages/stm.git git +libraries/random dph packages/random.git git +libraries/primitive dph packages/primitive.git git +libraries/vector dph packages/vector.git git +libraries/dph dph packages/dph.git git diff -Nru ghc-7.0.3/README ghc-7.2.1/README --- ghc-7.0.3/README 2011-03-26 18:10:02.000000000 +0000 +++ ghc-7.2.1/README 2011-08-07 17:10:05.000000000 +0000 @@ -27,35 +27,18 @@ which contains GHC itself and the "boot" libraries. - 2. Check out the source code from darcs - --------------------------------------- + 2. Check out the source code from git + ------------------------------------- - The recommended way to get a darcs checkout is to start off by - downloading a snapshot with a name like: + First get the GHC git repository: - ghc-HEAD-2009-09-09-ghc-corelibs-testsuite.tar.bz2 + $ git clone http://darcs.haskell.org/ghc.git/ - from: - - http://darcs.haskell.org/ - - and then untar it and bring it up-to-date with: - - $ cd ghc - $ ./darcs-all get - - - Alternatively you can use darcs to get the repos, but it will take a - lot longer. First get the GHC darcs repository: - - $ darcs get http://darcs.haskell.org/ghc/ - - Then run the darcs-all script in that repository + Then run the sync-all script in that repository to get the other repositories: $ cd ghc - $ chmod +x darcs-all - $ ./darcs-all get + $ ./sync-all get This checks out the "boot" packages. @@ -71,7 +54,7 @@ is itself written in Haskell. For instructions on how to port GHC to a new platform, see the Building Guide. -If you're building from darcs sources (as opposed to a source +If you're building from git sources (as opposed to a source distribution) then you also need to install Happy [4] and Alex [5]. For building library documentation, you'll need Haddock [6]. To build @@ -86,13 +69,12 @@ $ make install The "perl boot" step is only necessary if this is a tree checked out -from darcs. For source distributions downloaded from GHC's web site, +from git. For source distributions downloaded from GHC's web site, this step has already been performed. These steps give you the default build, which includes everything optimised and built in various ways (eg. profiling libs are built). -It can take a long time. To customise the build, see the file -HACKING. +It can take a long time. To customise the build, see the file HACKING. diff -Nru ghc-7.0.3/rts/AdjustorAsm.S ghc-7.2.1/rts/AdjustorAsm.S --- ghc-7.0.3/rts/AdjustorAsm.S 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/rts/AdjustorAsm.S 2011-08-07 17:10:05.000000000 +0000 @@ -147,7 +147,7 @@ /* ********************************* i386 ********************************** */ -#elif defined(i386_HOST_ARCH) && defined(darwin_HOST_OS) +#elif defined(i386_HOST_ARCH) #define WS 4 #define RETVAL_OFF 5 @@ -158,8 +158,13 @@ #define FRAMESIZE_OFF (HEADER_BYTES + 2*WS) #define ARGWORDS_OFF (HEADER_BYTES + 3*WS) +#ifdef LEADING_UNDERSCORE .globl _adjustorCode _adjustorCode: +#else + .globl adjustorCode +adjustorCode: +#endif popl %eax subl $RETVAL_OFF, %eax diff -Nru ghc-7.0.3/rts/Adjustor.c ghc-7.2.1/rts/Adjustor.c --- ghc-7.0.3/rts/Adjustor.c 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/rts/Adjustor.c 2011-08-07 17:10:05.000000000 +0000 @@ -47,7 +47,7 @@ #include #endif -#if defined(i386_HOST_ARCH) && defined(darwin_HOST_OS) +#if defined(i386_HOST_ARCH) extern void adjustorCode(void); #elif defined(powerpc_HOST_ARCH) || defined(powerpc64_HOST_ARCH) // from AdjustorAsm.s @@ -288,7 +288,7 @@ #endif #endif -#if defined(i386_HOST_ARCH) && defined(darwin_HOST_OS) +#if defined(i386_HOST_ARCH) /* !!! !!! WARNING: !!! !!! * This structure is accessed from AdjustorAsm.s @@ -304,7 +304,7 @@ } AdjustorStub; #endif -#if (defined(i386_HOST_ARCH) && defined(darwin_HOST_OS)) || defined(powerpc_HOST_ARCH) || defined(powerpc64_HOST_ARCH) +#if defined(i386_HOST_ARCH) || defined(powerpc_HOST_ARCH) || defined(powerpc64_HOST_ARCH) static int totalArgumentSize(char *typeString) { int sz = 0; @@ -380,54 +380,14 @@ break; case 1: /* _ccall */ -#if defined(i386_HOST_ARCH) && !defined(darwin_HOST_OS) - /* Magic constant computed by inspecting the code length of - the following assembly language snippet - (offset and machine code prefixed): - - <00>: 68 ef be ad de pushl $0xdeadbeef # constant is large enough to - # hold a StgStablePtr - <05>: b8 fa ef ff 00 movl $0x00ffeffa, %eax # load up wptr - <0a>: 68 ef be ad de pushl $obscure_ccall_ret_code # push the return address - <0f>: ff e0 jmp *%eax # jump to wptr - - The ccall'ing version is a tad different, passing in the return - address of the caller to the auto-generated C stub (which enters - via the stable pointer.) (The auto-generated C stub is in on this - game, don't worry :-) - - See the comment next to obscure_ccall_ret_code why we need to - perform a tail jump instead of a call, followed by some C stack - fixup. - - Note: The adjustor makes the assumption that any return value - coming back from the C stub is not stored on the stack. - That's (thankfully) the case here with the restricted set of - return types that we support. - */ - adjustor = allocateExec(17,&code); - { - unsigned char *const adj_code = (unsigned char *)adjustor; - - adj_code[0x00] = (unsigned char)0x68; /* pushl hptr (which is a dword immediate ) */ - *((StgStablePtr*)(adj_code+0x01)) = (StgStablePtr)hptr; - - adj_code[0x05] = (unsigned char)0xb8; /* movl $wptr, %eax */ - *((StgFunPtr*)(adj_code + 0x06)) = (StgFunPtr)wptr; - - adj_code[0x0a] = (unsigned char)0x68; /* pushl obscure_ccall_ret_code */ - *((StgFunPtr*)(adj_code + 0x0b)) = - (StgFunPtr)obscure_ccall_ret_code; - - adj_code[0x0f] = (unsigned char)0xff; /* jmp *%eax */ - adj_code[0x10] = (unsigned char)0xe0; - } -#elif defined(i386_HOST_ARCH) && defined(darwin_HOST_OS) +#if defined(i386_HOST_ARCH) { /* - What's special about Darwin/Mac OS X on i386? - It wants the stack to stay 16-byte aligned. - + Most of the trickiness here is due to the need to keep the + stack pointer 16-byte aligned (see #5250). That means we + can't just push another argument on the stack and call the + wrapper, we may have to shuffle the whole argument block. + We offload most of the work to AdjustorAsm.S. */ AdjustorStub *adjustorStub = allocateExec(sizeof(AdjustorStub),&code); @@ -1107,25 +1067,17 @@ void freeHaskellFunctionPtr(void* ptr) { -#if defined(i386_HOST_ARCH) && !defined(darwin_HOST_OS) - if ( *(unsigned char*)ptr != 0x68 && +#if defined(i386_HOST_ARCH) + if ( *(unsigned char*)ptr != 0xe8 && *(unsigned char*)ptr != 0x58 ) { errorBelch("freeHaskellFunctionPtr: not for me, guv! %p\n", ptr); return; } - - /* Free the stable pointer first..*/ - if (*(unsigned char*)ptr == 0x68) { /* Aha, a ccall adjustor! */ - freeStablePtr(*((StgStablePtr*)((unsigned char*)ptr + 0x01))); + if (*(unsigned char*)ptr == 0xe8) { /* Aha, a ccall adjustor! */ + freeStablePtr(((AdjustorStub*)ptr)->hptr); } else { freeStablePtr(*((StgStablePtr*)((unsigned char*)ptr + 0x02))); } -#elif defined(i386_HOST_ARCH) && defined(darwin_HOST_OS) -if ( *(unsigned char*)ptr != 0xe8 ) { - errorBelch("freeHaskellFunctionPtr: not for me, guv! %p\n", ptr); - return; - } - freeStablePtr(((AdjustorStub*)ptr)->hptr); #elif defined(x86_64_HOST_ARCH) if ( *(StgWord16 *)ptr == 0x894d ) { freeStablePtr(*(StgStablePtr*)((StgWord8*)ptr+0x20)); diff -Nru ghc-7.0.3/rts/Apply.cmm ghc-7.2.1/rts/Apply.cmm --- ghc-7.0.3/rts/Apply.cmm 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/rts/Apply.cmm 2011-08-07 17:10:05.000000000 +0000 @@ -350,3 +350,56 @@ ENTER(); } + +/* ----------------------------------------------------------------------------- + AP_STACK_NOUPD - exactly like AP_STACK, but doesn't push an update frame. + -------------------------------------------------------------------------- */ + +INFO_TABLE(stg_AP_STACK_NOUPD,/*special layout*/0,0,AP_STACK, + "AP_STACK_NOUPD","AP_STACK_NOUPD") +{ + W_ Words; + W_ ap; + + ap = R1; + + Words = StgAP_STACK_size(ap); + + /* + * Check for stack overflow. IMPORTANT: use a _NP check here, + * because if the check fails, we might end up blackholing this very + * closure, in which case we must enter the blackhole on return rather + * than continuing to evaluate the now-defunct closure. + */ + STK_CHK_NP(WDS(Words) + WDS(AP_STACK_SPLIM)); + /* ensure there is at least AP_STACK_SPLIM words of headroom available + * after unpacking the AP_STACK. See bug #1466 */ + + Sp = Sp - WDS(Words); + + TICK_ENT_AP(); + LDV_ENTER(ap); + + // Enter PAP cost centre + ENTER_CCS_PAP_CL(ap); // ToDo: ENTER_CC_AP_CL + + // Reload the stack + W_ i; + W_ p; + p = ap + SIZEOF_StgHeader + OFFSET_StgAP_STACK_payload; + i = 0; +for: + if (i < Words) { + Sp(i) = W_[p]; + p = p + WDS(1); + i = i + 1; + goto for; + } + + // Off we go! + TICK_ENT_VIA_NODE(); + + R1 = StgAP_STACK_fun(ap); + + ENTER(); +} diff -Nru ghc-7.0.3/rts/Arena.c ghc-7.2.1/rts/Arena.c --- ghc-7.0.3/rts/Arena.c 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/rts/Arena.c 2011-08-07 17:10:05.000000000 +0000 @@ -86,7 +86,7 @@ bd->gen_no = 0; bd->gen = NULL; - bd->dest = NULL; + bd->dest_no = 0; bd->flags = 0; bd->free = bd->start; bd->link = arena->current; diff -Nru ghc-7.0.3/rts/BeginPrivate.h ghc-7.2.1/rts/BeginPrivate.h --- ghc-7.0.3/rts/BeginPrivate.h 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/rts/BeginPrivate.h 2011-08-07 17:10:05.000000000 +0000 @@ -5,6 +5,6 @@ /* On Windows, with gcc 4.5.0-1, using visibility hidden gives: error: visibility attribute not supported in this configuration; ignored */ -#if __GNUC__ >= 4 && !defined(freebsd_HOST_OS) && !defined(mingw32_HOST_OS) +#if defined(HAS_VISIBILITY_HIDDEN) && !defined(freebsd_HOST_OS) #pragma GCC visibility push(hidden) #endif diff -Nru ghc-7.0.3/rts/Capability.c ghc-7.2.1/rts/Capability.c --- ghc-7.0.3/rts/Capability.c 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/rts/Capability.c 2011-08-07 17:10:05.000000000 +0000 @@ -219,13 +219,16 @@ initMutex(&cap->lock); cap->running_task = NULL; // indicates cap is free cap->spare_workers = NULL; + cap->n_spare_workers = 0; cap->suspended_ccalls = NULL; cap->returning_tasks_hd = NULL; cap->returning_tasks_tl = NULL; cap->inbox = (Message*)END_TSO_QUEUE; cap->sparks_created = 0; + cap->sparks_dud = 0; cap->sparks_converted = 0; - cap->sparks_pruned = 0; + cap->sparks_gcd = 0; + cap->sparks_fizzled = 0; #endif cap->f.stgEagerBlackholeInfo = (W_)&__stg_EAGER_BLACKHOLE_info; @@ -250,6 +253,8 @@ cap->transaction_tokens = 0; cap->context_switch = 0; cap->pinned_object_block = NULL; + + traceCapsetAssignCap(CAPSET_OSPROCESS_DEFAULT, i); } /* --------------------------------------------------------------------------- @@ -263,6 +268,10 @@ void initCapabilities( void ) { + /* Declare a single capability set representing the process. + Each capability will get added to this capset. */ + traceCapsetCreate(CAPSET_OSPROCESS_DEFAULT, CapsetTypeOsProcess); + #if defined(THREADED_RTS) nat i; @@ -464,9 +473,24 @@ // in which case it is not replaced on the spare_worker queue. // This happens when the system is shutting down (see // Schedule.c:workerStart()). - if (!isBoundTask(task)) { - task->next = cap->spare_workers; - cap->spare_workers = task; + if (!isBoundTask(task)) + { + if (cap->n_spare_workers < MAX_SPARE_WORKERS) + { + task->next = cap->spare_workers; + cap->spare_workers = task; + cap->n_spare_workers++; + } + else + { + debugTrace(DEBUG_sched, "%d spare workers already, exiting", + cap->n_spare_workers); + releaseCapability_(cap,rtsFalse); + // hold the lock until after workerTaskStop; c.f. scheduleWorker() + workerTaskStop(task); + RELEASE_LOCK(&cap->lock); + shutdownThread(); + } } // Bound tasks just float around attached to their TSOs. @@ -623,7 +647,8 @@ } cap->spare_workers = task->next; task->next = NULL; - } + cap->n_spare_workers--; + } cap->running_task = task; RELEASE_LOCK(&cap->lock); break; @@ -658,6 +683,31 @@ } /* ---------------------------------------------------------------------------- + * tryGrabCapability + * + * Attempt to gain control of a Capability if it is free. + * + * ------------------------------------------------------------------------- */ + +rtsBool +tryGrabCapability (Capability *cap, Task *task) +{ + if (cap->running_task != NULL) return rtsFalse; + ACQUIRE_LOCK(&cap->lock); + if (cap->running_task != NULL) { + RELEASE_LOCK(&cap->lock); + return rtsFalse; + } + task->cap = cap; + cap->running_task = task; + RELEASE_LOCK(&cap->lock); + return rtsTrue; +} + + +#endif /* THREADED_RTS */ + +/* ---------------------------------------------------------------------------- * shutdownCapability * * At shutdown time, we want to let everything exit as cleanly as @@ -673,8 +723,11 @@ * ------------------------------------------------------------------------- */ void -shutdownCapability (Capability *cap, Task *task, rtsBool safe) +shutdownCapability (Capability *cap, + Task *task USED_IF_THREADS, + rtsBool safe USED_IF_THREADS) { +#if defined(THREADED_RTS) nat i; task->cap = cap; @@ -712,12 +765,13 @@ if (!osThreadIsAlive(t->id)) { debugTrace(DEBUG_sched, "worker thread %p has died unexpectedly", (void *)t->id); - if (!prev) { - cap->spare_workers = t->next; - } else { - prev->next = t->next; - } - prev = t; + cap->n_spare_workers--; + if (!prev) { + cap->spare_workers = t->next; + } else { + prev->next = t->next; + } + prev = t; } } } @@ -765,33 +819,23 @@ // threads performing foreign calls that will eventually try to // return via resumeThread() and attempt to grab cap->lock. // closeMutex(&cap->lock); -} + +#endif /* THREADED_RTS */ -/* ---------------------------------------------------------------------------- - * tryGrabCapability - * - * Attempt to gain control of a Capability if it is free. - * - * ------------------------------------------------------------------------- */ + traceCapsetRemoveCap(CAPSET_OSPROCESS_DEFAULT, cap->no); +} -rtsBool -tryGrabCapability (Capability *cap, Task *task) +void +shutdownCapabilities(Task *task, rtsBool safe) { - if (cap->running_task != NULL) return rtsFalse; - ACQUIRE_LOCK(&cap->lock); - if (cap->running_task != NULL) { - RELEASE_LOCK(&cap->lock); - return rtsFalse; + nat i; + for (i=0; i < n_capabilities; i++) { + ASSERT(task->incall->tso == NULL); + shutdownCapability(&capabilities[i], task, safe); } - task->cap = cap; - cap->running_task = task; - RELEASE_LOCK(&cap->lock); - return rtsTrue; + traceCapsetDelete(CAPSET_OSPROCESS_DEFAULT); } - -#endif /* THREADED_RTS */ - static void freeCapability (Capability *cap) { @@ -822,11 +866,9 @@ ------------------------------------------------------------------------ */ void -markSomeCapabilities (evac_fn evac, void *user, nat i0, nat delta, - rtsBool no_mark_sparks USED_IF_THREADS) +markCapability (evac_fn evac, void *user, Capability *cap, + rtsBool no_mark_sparks USED_IF_THREADS) { - nat i; - Capability *cap; InCall *incall; // Each GC thread is responsible for following roots from the @@ -834,39 +876,31 @@ // or fewer Capabilities as GC threads, but just in case there // are more, we mark every Capability whose number is the GC // thread's index plus a multiple of the number of GC threads. - for (i = i0; i < n_capabilities; i += delta) { - cap = &capabilities[i]; - evac(user, (StgClosure **)(void *)&cap->run_queue_hd); - evac(user, (StgClosure **)(void *)&cap->run_queue_tl); + evac(user, (StgClosure **)(void *)&cap->run_queue_hd); + evac(user, (StgClosure **)(void *)&cap->run_queue_tl); #if defined(THREADED_RTS) - evac(user, (StgClosure **)(void *)&cap->inbox); + evac(user, (StgClosure **)(void *)&cap->inbox); #endif - for (incall = cap->suspended_ccalls; incall != NULL; - incall=incall->next) { - evac(user, (StgClosure **)(void *)&incall->suspended_tso); - } + for (incall = cap->suspended_ccalls; incall != NULL; + incall=incall->next) { + evac(user, (StgClosure **)(void *)&incall->suspended_tso); + } #if defined(THREADED_RTS) - if (!no_mark_sparks) { - traverseSparkQueue (evac, user, cap); - } -#endif + if (!no_mark_sparks) { + traverseSparkQueue (evac, user, cap); } +#endif -#if !defined(THREADED_RTS) - evac(user, (StgClosure **)(void *)&blocked_queue_hd); - evac(user, (StgClosure **)(void *)&blocked_queue_tl); - evac(user, (StgClosure **)(void *)&sleeping_queue); -#endif + // Free STM structures for this Capability + stmPreGCHook(cap); } void markCapabilities (evac_fn evac, void *user) { - markSomeCapabilities(evac, user, 0, 1, rtsFalse); + nat n; + for (n = 0; n < n_capabilities; n++) { + markCapability(evac, user, &capabilities[n], rtsFalse); + } } - -/* ----------------------------------------------------------------------------- - Messages - -------------------------------------------------------------------------- */ - diff -Nru ghc-7.0.3/rts/Capability.h ghc-7.2.1/rts/Capability.h --- ghc-7.0.3/rts/Capability.h 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/rts/Capability.h 2011-08-07 17:10:05.000000000 +0000 @@ -79,6 +79,7 @@ #if defined(THREADED_RTS) // Worker Tasks waiting in the wings. Singly-linked. Task *spare_workers; + nat n_spare_workers; // count of above // This lock protects running_task, returning_tasks_{hd,tl}, wakeup_queue. Mutex lock; @@ -98,8 +99,10 @@ // Stats on spark creation/conversion nat sparks_created; + nat sparks_dud; nat sparks_converted; - nat sparks_pruned; + nat sparks_gcd; + nat sparks_fizzled; #endif // Per-capability STM-related data @@ -237,11 +240,6 @@ // void prodAllCapabilities (void); -// Waits for a capability to drain of runnable threads and workers, -// and then acquires it. Used at shutdown time. -// -void shutdownCapability (Capability *cap, Task *task, rtsBool wait_foreign); - // Attempt to gain control of a Capability if it is free. // rtsBool tryGrabCapability (Capability *cap, Task *task); @@ -267,6 +265,15 @@ #endif /* !THREADED_RTS */ +// Waits for a capability to drain of runnable threads and workers, +// and then acquires it. Used at shutdown time. +// +void shutdownCapability (Capability *cap, Task *task, rtsBool wait_foreign); + +// Shut down all capabilities. +// +void shutdownCapabilities(Task *task, rtsBool wait_foreign); + // cause all capabilities to context switch as soon as possible. void setContextSwitches(void); INLINE_HEADER void contextSwitchCapability(Capability *cap); @@ -275,9 +282,11 @@ void freeCapabilities (void); // For the GC: -void markSomeCapabilities (evac_fn evac, void *user, nat i0, nat delta, - rtsBool no_mark_sparks); +void markCapability (evac_fn evac, void *user, Capability *cap, + rtsBool no_mark_sparks USED_IF_THREADS); + void markCapabilities (evac_fn evac, void *user); + void traverseSparkQueues (evac_fn evac, void *user); /* ----------------------------------------------------------------------------- diff -Nru ghc-7.0.3/rts/ClosureFlags.c ghc-7.2.1/rts/ClosureFlags.c --- ghc-7.0.3/rts/ClosureFlags.c 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/rts/ClosureFlags.c 2011-08-07 17:10:05.000000000 +0000 @@ -59,8 +59,9 @@ [RET_FUN] = ( 0 ), [UPDATE_FRAME] = ( _BTM ), [CATCH_FRAME] = ( _BTM ), - [STOP_FRAME] = ( _BTM ), - [BLACKHOLE] = ( _NS| _UPT ), + [UNDERFLOW_FRAME] = ( _BTM ), + [STOP_FRAME] = ( _BTM ), + [BLACKHOLE] = ( _NS| _UPT ), [BLOCKING_QUEUE] = ( _NS| _MUT|_UPT ), [MVAR_CLEAN] = (_HNF| _NS| _MUT|_UPT ), [MVAR_DIRTY] = (_HNF| _NS| _MUT|_UPT ), @@ -74,7 +75,8 @@ [WEAK] = (_HNF| _NS| _UPT ), [PRIM] = (_HNF| _NS| _UPT ), [MUT_PRIM] = (_HNF| _NS| _MUT|_UPT ), - [TSO] = (_HNF| _NS| _MUT|_UPT ), + [TSO] = (_HNF| _NS| _MUT|_UPT ), + [STACK] = (_HNF| _NS| _MUT|_UPT ), [TREC_CHUNK] = ( _NS| _MUT|_UPT ), [ATOMICALLY_FRAME] = ( _BTM ), [CATCH_RETRY_FRAME] = ( _BTM ), @@ -82,6 +84,6 @@ [WHITEHOLE] = ( 0 ) }; -#if N_CLOSURE_TYPES != 59 +#if N_CLOSURE_TYPES != 61 #error Closure types changed: update ClosureFlags.c! #endif diff -Nru ghc-7.0.3/rts/EndPrivate.h ghc-7.2.1/rts/EndPrivate.h --- ghc-7.0.3/rts/EndPrivate.h 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/rts/EndPrivate.h 2011-08-07 17:10:05.000000000 +0000 @@ -1,3 +1,3 @@ -#if __GNUC__ >= 4 && !defined(freebsd_HOST_OS) && !defined(mingw32_HOST_OS) +#if defined(HAS_VISIBILITY_HIDDEN) && !defined(freebsd_HOST_OS) #pragma GCC visibility pop #endif diff -Nru ghc-7.0.3/rts/eventlog/EventLog.c ghc-7.2.1/rts/eventlog/EventLog.c --- ghc-7.0.3/rts/eventlog/EventLog.c 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/rts/eventlog/EventLog.c 2011-08-07 17:10:05.000000000 +0000 @@ -75,7 +75,16 @@ [EVENT_GC_IDLE] = "GC idle", [EVENT_GC_WORK] = "GC working", [EVENT_GC_DONE] = "GC done", - [EVENT_BLOCK_MARKER] = "Block marker" + [EVENT_BLOCK_MARKER] = "Block marker", + [EVENT_CAPSET_CREATE] = "Create capability set", + [EVENT_CAPSET_DELETE] = "Delete capability set", + [EVENT_CAPSET_ASSIGN_CAP] = "Add capability to capability set", + [EVENT_CAPSET_REMOVE_CAP] = "Remove capability from capability set", + [EVENT_RTS_IDENTIFIER] = "RTS name and version", + [EVENT_PROGRAM_ARGS] = "Program arguments", + [EVENT_PROGRAM_ENV] = "Program environment variables", + [EVENT_OSPROCESS_PID] = "Process ID", + [EVENT_OSPROCESS_PPID] = "Parent process ID" }; // Event type. @@ -146,6 +155,12 @@ static inline void postCapNo(EventsBuf *eb, EventCapNo no) { postWord16(eb,no); } +static inline void postCapsetID(EventsBuf *eb, EventCapsetID id) +{ postWord32(eb,id); } + +static inline void postCapsetType(EventsBuf *eb, EventCapsetType type) +{ postWord16(eb,type); } + static inline void postPayloadSize(EventsBuf *eb, EventPayloadSize size) { postWord16(eb,size); } @@ -252,13 +267,34 @@ case EVENT_STOP_THREAD: // (cap, thread, status) eventTypes[t].size = - sizeof(EventThreadID) + sizeof(StgWord16); + sizeof(EventThreadID) + sizeof(StgWord16) + sizeof(EventThreadID); break; case EVENT_STARTUP: // (cap count) eventTypes[t].size = sizeof(EventCapNo); break; + case EVENT_CAPSET_CREATE: // (capset, capset_type) + eventTypes[t].size = + sizeof(EventCapsetID) + sizeof(EventCapsetType); + break; + + case EVENT_CAPSET_DELETE: // (capset) + eventTypes[t].size = sizeof(EventCapsetID); + break; + + case EVENT_CAPSET_ASSIGN_CAP: // (capset, cap) + case EVENT_CAPSET_REMOVE_CAP: + eventTypes[t].size = + sizeof(EventCapsetID) + sizeof(EventCapNo); + break; + + case EVENT_OSPROCESS_PID: // (cap, pid) + case EVENT_OSPROCESS_PPID: + eventTypes[t].size = + sizeof(EventCapsetID) + sizeof(StgWord32); + break; + case EVENT_SHUTDOWN: // (cap) case EVENT_REQUEST_SEQ_GC: // (cap) case EVENT_REQUEST_PAR_GC: // (cap) @@ -272,6 +308,9 @@ case EVENT_LOG_MSG: // (msg) case EVENT_USER_MSG: // (msg) + case EVENT_RTS_IDENTIFIER: // (capset, str) + case EVENT_PROGRAM_ARGS: // (capset, strvec) + case EVENT_PROGRAM_ENV: // (capset, strvec) eventTypes[t].size = 0xffff; break; @@ -296,10 +335,6 @@ // Prepare event buffer for events (data). postInt32(&eventBuf, EVENT_DATA_BEGIN); - - // Post a STARTUP event with the number of capabilities - postEventHeader(&eventBuf, EVENT_STARTUP); - postCapNo(&eventBuf, n_caps); // Flush capEventBuf with header. /* @@ -382,7 +417,8 @@ postSchedEvent (Capability *cap, EventTypeNum tag, StgThreadID thread, - StgWord64 other) + StgWord info1, + StgWord info2) { EventsBuf *eb; @@ -407,7 +443,7 @@ case EVENT_CREATE_SPARK_THREAD: // (cap, spark_thread) { - postThreadID(eb,other /* spark_thread */); + postThreadID(eb,info1 /* spark_thread */); break; } @@ -416,14 +452,15 @@ case EVENT_THREAD_WAKEUP: // (cap, thread, other_cap) { postThreadID(eb,thread); - postCapNo(eb,other /* new_cap | victim_cap | other_cap */); + postCapNo(eb,info1 /* new_cap | victim_cap | other_cap */); break; } case EVENT_STOP_THREAD: // (cap, thread, status) { postThreadID(eb,thread); - postWord16(eb,other /* status */); + postWord16(eb,info1 /* status */); + postThreadID(eb,info2 /* blocked on thread */); break; } @@ -441,6 +478,115 @@ } } +void postCapsetModifyEvent (EventTypeNum tag, + EventCapsetID capset, + StgWord32 other) +{ + ACQUIRE_LOCK(&eventBufMutex); + + if (!hasRoomForEvent(&eventBuf, tag)) { + // Flush event buffer to make room for new event. + printAndClearEventBuf(&eventBuf); + } + + postEventHeader(&eventBuf, tag); + postCapsetID(&eventBuf, capset); + + switch (tag) { + case EVENT_CAPSET_CREATE: // (capset, capset_type) + { + postCapsetType(&eventBuf, other /* capset_type */); + break; + } + + case EVENT_CAPSET_DELETE: // (capset) + { + break; + } + + case EVENT_CAPSET_ASSIGN_CAP: // (capset, capno) + case EVENT_CAPSET_REMOVE_CAP: // (capset, capno) + { + postCapNo(&eventBuf, other /* capno */); + break; + } + case EVENT_OSPROCESS_PID: // (capset, pid) + case EVENT_OSPROCESS_PPID: // (capset, parent_pid) + { + postWord32(&eventBuf, other); + break; + } + default: + barf("postCapsetModifyEvent: unknown event tag %d", tag); + } + + RELEASE_LOCK(&eventBufMutex); +} + +void postCapsetStrEvent (EventTypeNum tag, + EventCapsetID capset, + char *msg) +{ + int strsize = strlen(msg); + int size = strsize + sizeof(EventCapsetID); + + ACQUIRE_LOCK(&eventBufMutex); + + if (!hasRoomForVariableEvent(&eventBuf, size)){ + printAndClearEventBuf(&eventBuf); + + if (!hasRoomForVariableEvent(&eventBuf, size)){ + // Event size exceeds buffer size, bail out: + RELEASE_LOCK(&eventBufMutex); + return; + } + } + + postEventHeader(&eventBuf, tag); + postPayloadSize(&eventBuf, size); + postCapsetID(&eventBuf, capset); + + postBuf(&eventBuf, (StgWord8*) msg, strsize); + + RELEASE_LOCK(&eventBufMutex); +} + +void postCapsetVecEvent (EventTypeNum tag, + EventCapsetID capset, + int argc, + char *argv[]) +{ + int i, size = sizeof(EventCapsetID); + + for (i = 0; i < argc; i++) { + // 1 + strlen to account for the trailing \0, used as separator + size += 1 + strlen(argv[i]); + } + + ACQUIRE_LOCK(&eventBufMutex); + + if (!hasRoomForVariableEvent(&eventBuf, size)){ + printAndClearEventBuf(&eventBuf); + + if(!hasRoomForVariableEvent(&eventBuf, size)){ + // Event size exceeds buffer size, bail out: + RELEASE_LOCK(&eventBufMutex); + return; + } + } + + postEventHeader(&eventBuf, tag); + postPayloadSize(&eventBuf, size); + postCapsetID(&eventBuf, capset); + + for( i = 0; i < argc; i++ ) { + // again, 1 + to account for \0 + postBuf(&eventBuf, (StgWord8*) argv[i], 1 + strlen(argv[i])); + } + + RELEASE_LOCK(&eventBufMutex); +} + void postEvent (Capability *cap, EventTypeNum tag) { @@ -496,6 +642,22 @@ postLogMsg(&capEventBuf[cap->no], EVENT_USER_MSG, msg, ap); } +void postEventStartup(EventCapNo n_caps) +{ + ACQUIRE_LOCK(&eventBufMutex); + + if (!hasRoomForEvent(&eventBuf, EVENT_STARTUP)) { + // Flush event buffer to make room for new event. + printAndClearEventBuf(&eventBuf); + } + + // Post a STARTUP event with the number of capabilities + postEventHeader(&eventBuf, EVENT_STARTUP); + postCapNo(&eventBuf, n_caps); + + RELEASE_LOCK(&eventBufMutex); +} + void closeBlockMarker (EventsBuf *ebuf) { StgInt8* save_pos; diff -Nru ghc-7.0.3/rts/eventlog/EventLog.h ghc-7.2.1/rts/eventlog/EventLog.h --- ghc-7.0.3/rts/eventlog/EventLog.h 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/rts/eventlog/EventLog.h 2011-08-07 17:10:05.000000000 +0000 @@ -32,7 +32,7 @@ * that has an associated thread). */ void postSchedEvent(Capability *cap, EventTypeNum tag, - StgThreadID id, StgWord64 other); + StgThreadID id, StgWord info1, StgWord info2); /* * Post a nullary event. @@ -45,12 +45,37 @@ void postCapMsg(Capability *cap, char *msg, va_list ap); +void postEventStartup(EventCapNo n_caps); + +/* + * Post a capability set modification event + */ +void postCapsetModifyEvent (EventTypeNum tag, + EventCapsetID capset, + StgWord32 other); + +/* + * Post a capability set event with a string payload + */ +void postCapsetStrEvent (EventTypeNum tag, + EventCapsetID capset, + char *msg); + +/* + * Post a capability set event with several strings payload + */ +void postCapsetVecEvent (EventTypeNum tag, + EventCapsetID capset, + int argc, + char *msg[]); + #else /* !TRACING */ INLINE_HEADER void postSchedEvent (Capability *cap STG_UNUSED, EventTypeNum tag STG_UNUSED, StgThreadID id STG_UNUSED, - StgWord64 other STG_UNUSED) + StgWord info1 STG_UNUSED, + StgWord info2 STG_UNUSED) { /* nothing */ } INLINE_HEADER void postEvent (Capability *cap STG_UNUSED, diff -Nru ghc-7.0.3/rts/Exception.cmm ghc-7.2.1/rts/Exception.cmm --- ghc-7.0.3/rts/Exception.cmm 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/rts/Exception.cmm 2011-08-07 17:10:05.000000000 +0000 @@ -13,7 +13,7 @@ #include "Cmm.h" #include "RaiseAsync.h" -import ghczmprim_GHCziBool_True_closure; +import ghczmprim_GHCziTypes_True_closure; /* ----------------------------------------------------------------------------- Exception Primitives @@ -283,11 +283,6 @@ * If the exception went to a catch frame, we'll just continue from * the handler. */ - loop: - if (StgTSO_what_next(target) == ThreadRelocated::I16) { - target = StgTSO__link(target); - goto loop; - } if (target == CurrentTSO) { /* * So what should happen if a thread calls "throwTo self" inside @@ -436,9 +431,9 @@ #endif retry_pop_stack: - StgTSO_sp(CurrentTSO) = Sp; + SAVE_THREAD_STATE(); (frame_type) = foreign "C" raiseExceptionHelper(BaseReg "ptr", CurrentTSO "ptr", exception "ptr") []; - Sp = StgTSO_sp(CurrentTSO); + LOAD_THREAD_STATE(); if (frame_type == ATOMICALLY_FRAME) { /* The exception has reached the edge of a memory transaction. Check that * the transaction is valid. If not then perhaps the exception should @@ -494,13 +489,12 @@ // be per-thread. CInt[rts_stop_on_exception] = 0; ("ptr" ioAction) = foreign "C" deRefStablePtr (W_[rts_breakpoint_io_action] "ptr") []; - Sp = Sp - WDS(7); - Sp(6) = exception; - Sp(5) = stg_raise_ret_info; - Sp(4) = stg_noforceIO_info; // required for unregisterised + Sp = Sp - WDS(6); + Sp(5) = exception; + Sp(4) = stg_raise_ret_info; Sp(3) = exception; // the AP_STACK - Sp(2) = ghczmprim_GHCziBool_True_closure; // dummy breakpoint info - Sp(1) = ghczmprim_GHCziBool_True_closure; // True <=> a breakpoint + Sp(2) = ghczmprim_GHCziTypes_True_closure; // dummy breakpoint info + Sp(1) = ghczmprim_GHCziTypes_True_closure; // True <=> a breakpoint R1 = ioAction; jump RET_LBL(stg_ap_pppv); } @@ -512,8 +506,10 @@ * We will leave the stack in a GC'able state, see the stg_stop_thread * entry code in StgStartup.cmm. */ - Sp = CurrentTSO + TSO_OFFSET_StgTSO_stack - + WDS(TO_W_(StgTSO_stack_size(CurrentTSO))) - WDS(2); + W_ stack; + stack = StgTSO_stackobj(CurrentTSO); + Sp = stack + OFFSET_StgStack_stack + + WDS(TO_W_(StgStack_stack_size(stack))) - WDS(2); Sp(1) = exception; /* save the exception */ Sp(0) = stg_enter_info; /* so that GC can traverse this stack */ StgTSO_what_next(CurrentTSO) = ThreadKilled::I16; diff -Nru ghc-7.0.3/rts/GetEnv.h ghc-7.2.1/rts/GetEnv.h --- ghc-7.0.3/rts/GetEnv.h 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/rts/GetEnv.h 2011-08-07 17:10:05.000000000 +0000 @@ -0,0 +1,23 @@ +/* ----------------------------------------------------------------------------- + * + * (c) The GHC Team 2011 + * + * OS-independent interface to the process environment variables + * + * ---------------------------------------------------------------------------*/ + +#ifndef GETENV_H +#define GETENV_H + +#include "BeginPrivate.h" + +/* Get the process environment vector (same style interface as argc/argv) + */ +void getProgEnvv (int *out_envc, char **out_envv[]); +void freeProgEnvv (int envc, char *envv[]); + +/* calls to getProgEnvv must have a corresponding freeProgEnvv */ + +#include "EndPrivate.h" + +#endif /* GETENV_H */ diff -Nru ghc-7.0.3/rts/ghc.mk ghc-7.2.1/rts/ghc.mk --- ghc-7.0.3/rts/ghc.mk 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/rts/ghc.mk 2011-08-07 17:10:05.000000000 +0000 @@ -35,21 +35,18 @@ ALL_DIRS += posix endif +EXCLUDED_SRCS := EXCLUDED_SRCS += rts/Main.c EXCLUDED_SRCS += rts/parallel/SysMan.c EXCLUDED_SRCS += $(wildcard rts/Vis*.c) -rts_C_SRCS = $(filter-out $(EXCLUDED_SRCS),$(wildcard rts/*.c $(foreach dir,$(ALL_DIRS),rts/$(dir)/*.c))) -rts_CMM_SRCS = $(wildcard rts/*.cmm) +rts_C_SRCS := $(filter-out $(EXCLUDED_SRCS),$(wildcard rts/*.c $(foreach dir,$(ALL_DIRS),rts/$(dir)/*.c))) +rts_CMM_SRCS := $(wildcard rts/*.cmm) # Don't compile .S files when bootstrapping a new arch ifneq "$(PORTING_HOST)" "YES" -ifneq "$(findstring $(TargetArch_CPP), powerpc powerpc64)" "" +ifneq "$(findstring $(TargetArch_CPP), i386 powerpc powerpc64)" "" rts_S_SRCS += rts/AdjustorAsm.S -else -ifneq "$(findstring $(TargetOS_CPP), darwin)" "" -rts_S_SRCS += rts/AdjustorAsm.S -endif endif endif @@ -67,7 +64,7 @@ rts/dist/build/sm/Scav_thr.c : rts/sm/Scav.c | $$(dir $$@)/. cp $< $@ -rts_H_FILES = $(wildcard includes/*.h) $(wildcard rts/*.h) +rts_H_FILES := $(wildcard rts/*.h) ifeq "$(USE_DTRACE)" "YES" DTRACEPROBES_H = rts/dist/build/RtsProbes.h @@ -145,7 +142,7 @@ $(call distdir-way-opts,rts,dist,$1) $(call c-suffix-rules,rts,dist,$1,YES) $(call cmm-suffix-rules,rts,dist,$1) -$(call hs-suffix-rules-srcdir,rts,dist,$1,$$(dir)) +$(call hs-suffix-rules-srcdir,rts,dist,$1,.) # hs-suffix-rules-srcdir is needed when BootingFromHc to get the .hc rules rts_$1_LIB_NAME = libHSrts$$($1_libsuf) @@ -193,8 +190,8 @@ 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 @@ -294,6 +291,7 @@ rts/RtsMessages_CC_OPTS += -DProjectVersion=\"$(ProjectVersion)\" rts/RtsUtils_CC_OPTS += -DProjectVersion=\"$(ProjectVersion)\" +rts/Trace_CC_OPTS += -DProjectVersion=\"$(ProjectVersion)\" # rts/RtsUtils_CC_OPTS += -DHostPlatform=\"$(HOSTPLATFORM)\" rts/RtsUtils_CC_OPTS += -DHostArch=\"$(HostArch_CPP)\" @@ -455,7 +453,7 @@ endif -$(eval $(call build-dependencies,rts,dist,1)) +$(eval $(call dependencies,rts,dist,1)) $(rts_dist_depfile_c_asm) : libffi/dist-install/build/ffi.h $(DTRACEPROBES_H) @@ -498,7 +496,7 @@ 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 -Nru ghc-7.0.3/rts/Globals.c ghc-7.2.1/rts/Globals.c --- ghc-7.0.3/rts/Globals.c 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/rts/Globals.c 2011-08-07 17:10:05.000000000 +0000 @@ -19,7 +19,6 @@ #include "Stable.h" typedef enum { - TypeableStore, GHCConcSignalSignalHandlerStore, GHCConcWindowsPendingDelaysStore, GHCConcWindowsIOManagerThreadStore, @@ -80,13 +79,6 @@ return ret; } - -StgStablePtr -getOrSetTypeableStore(StgStablePtr ptr) -{ - return getOrSetKey(TypeableStore,ptr); -} - StgStablePtr getOrSetGHCConcSignalSignalHandlerStore(StgStablePtr ptr) { diff -Nru ghc-7.0.3/rts/Hash.c ghc-7.2.1/rts/Hash.c --- ghc-7.0.3/rts/Hash.c 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/rts/Hash.c 2011-08-07 17:10:05.000000000 +0000 @@ -27,13 +27,16 @@ /* Linked list of (key, data) pairs for separate chaining */ -struct hashlist { +typedef struct hashlist { StgWord key; void *data; struct hashlist *next; /* Next cell in bucket chain (same hash value) */ -}; +} HashList; -typedef struct hashlist HashList; +typedef struct chunklist { + HashList *chunk; + struct chunklist *next; +} HashListChunk; struct hashtable { int split; /* Next bucket to split when expanding */ @@ -43,7 +46,9 @@ int kcount; /* Number of keys */ int bcount; /* Number of buckets */ HashList **dir[HDIRSIZE]; /* Directory of segments */ - HashFunction *hash; /* hash function */ + HashList *freeList; /* free list of HashLists */ + HashListChunk *chunks; + HashFunction *hash; /* hash function */ CompareFunction *compare; /* key comparison function */ }; @@ -207,30 +212,23 @@ * no effort to actually return the space to the malloc arena. * -------------------------------------------------------------------------- */ -static HashList *freeList = NULL; - -static struct chunkList { - void *chunk; - struct chunkList *next; -} *chunks; - static HashList * -allocHashList(void) +allocHashList (HashTable *table) { HashList *hl, *p; - struct chunkList *cl; + HashListChunk *cl; - if ((hl = freeList) != NULL) { - freeList = hl->next; + if ((hl = table->freeList) != NULL) { + table->freeList = hl->next; } else { hl = stgMallocBytes(HCHUNK * sizeof(HashList), "allocHashList"); cl = stgMallocBytes(sizeof (*cl), "allocHashList: chunkList"); - cl->chunk = hl; - cl->next = chunks; - chunks = cl; + cl->chunk = hl; + cl->next = table->chunks; + table->chunks = cl; - freeList = hl + 1; - for (p = freeList; p < hl + HCHUNK - 1; p++) + table->freeList = hl + 1; + for (p = table->freeList; p < hl + HCHUNK - 1; p++) p->next = p + 1; p->next = NULL; } @@ -238,10 +236,10 @@ } static void -freeHashList(HashList *hl) +freeHashList (HashTable *table, HashList *hl) { - hl->next = freeList; - freeList = hl; + hl->next = table->freeList; + table->freeList = hl; } void @@ -264,7 +262,7 @@ segment = bucket / HSEGSIZE; index = bucket % HSEGSIZE; - hl = allocHashList(); + hl = allocHashList(table); hl->key = key; hl->data = data; @@ -292,7 +290,7 @@ table->dir[segment][index] = hl->next; else prev->next = hl->next; - freeHashList(hl); + freeHashList(table,hl); table->kcount--; return hl->data; } @@ -317,6 +315,7 @@ long index; HashList *hl; HashList *next; + HashListChunk *cl, *cl_next; /* The last bucket with something in it is table->max + table->split - 1 */ segment = (table->max + table->split - 1) / HSEGSIZE; @@ -328,14 +327,18 @@ next = hl->next; if (freeDataFun != NULL) (*freeDataFun)(hl->data); - freeHashList(hl); - } + } index--; } stgFree(table->dir[segment]); segment--; index = HSEGSIZE - 1; } + for (cl = table->chunks; cl != NULL; cl = cl_next) { + cl_next = cl->next; + stgFree(cl->chunk); + stgFree(cl); + } stgFree(table); } @@ -363,6 +366,8 @@ table->mask2 = 2 * HSEGSIZE - 1; table->kcount = 0; table->bcount = HSEGSIZE; + table->freeList = NULL; + table->chunks = NULL; table->hash = hash; table->compare = compare; @@ -385,11 +390,5 @@ void exitHashTable(void) { - struct chunkList *cl; - - while ((cl = chunks) != NULL) { - chunks = cl->next; - stgFree(cl->chunk); - stgFree(cl); - } + /* nothing to do */ } diff -Nru ghc-7.0.3/rts/hooks/RtsOptsEnabled.c ghc-7.2.1/rts/hooks/RtsOptsEnabled.c --- ghc-7.0.3/rts/hooks/RtsOptsEnabled.c 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/rts/hooks/RtsOptsEnabled.c 2011-08-07 17:10:05.000000000 +0000 @@ -9,5 +9,5 @@ #include "Rts.h" #include "RtsOpts.h" -const rtsOptsEnabledEnum rtsOptsEnabled = rtsOptsSafeOnly; +const RtsOptsEnabledEnum rtsOptsEnabled = RtsOptsSafeOnly; diff -Nru ghc-7.0.3/rts/Hpc.c ghc-7.2.1/rts/Hpc.c --- ghc-7.0.3/rts/Hpc.c 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/rts/Hpc.c 2011-08-07 17:10:05.000000000 +0000 @@ -6,6 +6,8 @@ #include "Rts.h" #include "Trace.h" +#include "Hash.h" +#include "RtsUtils.h" #include #include @@ -36,11 +38,11 @@ static FILE *tixFile; // file being read/written static int tix_ch; // current char +static HashTable * moduleHash = NULL; // module name -> HpcModuleInfo + HpcModuleInfo *modules = 0; -HpcModuleInfo *nextModule = 0; -int totalTixes = 0; // total number of tix boxes. -static char *tixFilename; +static char *tixFilename = NULL; static void GNU_ATTRIBUTE(__noreturn__) failure(char *msg) { @@ -78,7 +80,7 @@ } static char *expectString(void) { - char tmp[256], *res; + char tmp[256], *res; // XXX int tmp_ix = 0; expect('"'); while (tix_ch != '"') { @@ -87,7 +89,7 @@ } tmp[tmp_ix++] = 0; expect('"'); - res = malloc(tmp_ix); + res = stgMallocBytes(tmp_ix,"Hpc.expectString"); strcpy(res,tmp); return res; } @@ -104,10 +106,8 @@ static void readTix(void) { unsigned int i; - HpcModuleInfo *tmpModule; + HpcModuleInfo *tmpModule, *lookup; - totalTixes = 0; - ws(); expect('T'); expect('i'); @@ -117,7 +117,9 @@ ws(); while(tix_ch != ']') { - tmpModule = (HpcModuleInfo *)calloc(1,sizeof(HpcModuleInfo)); + tmpModule = (HpcModuleInfo *)stgMallocBytes(sizeof(HpcModuleInfo), + "Hpc.readTix"); + tmpModule->from_file = rtsTrue; expect('T'); expect('i'); expect('x'); @@ -134,8 +136,6 @@ ws(); tmpModule -> tickCount = (int)expectWord64(); tmpModule -> tixArr = (StgWord64 *)calloc(tmpModule->tickCount,sizeof(StgWord64)); - tmpModule -> tickOffset = totalTixes; - totalTixes += tmpModule -> tickCount; ws(); expect('['); ws(); @@ -150,13 +150,32 @@ expect(']'); ws(); - if (!modules) { - modules = tmpModule; + lookup = lookupHashTable(moduleHash, (StgWord)tmpModule->modName); + if (tmpModule == NULL) { + debugTrace(DEBUG_hpc,"readTix: new HpcModuleInfo for %s", + tmpModule->modName); + insertHashTable(moduleHash, (StgWord)tmpModule->modName, tmpModule); } else { - nextModule->next=tmpModule; + ASSERT(lookup->tixArr != 0); + ASSERT(!strcmp(tmpModule->modName, lookup->modName)); + debugTrace(DEBUG_hpc,"readTix: existing HpcModuleInfo for %s", + tmpModule->modName); + if (tmpModule->hashNo != lookup->hashNo) { + fprintf(stderr,"in module '%s'\n",tmpModule->modName); + failure("module mismatch with .tix/.mix file hash number"); + if (tixFilename != NULL) { + fprintf(stderr,"(perhaps remove %s ?)\n",tixFilename); + } + stg_exit(EXIT_FAILURE); + } + for (i=0; i < tmpModule->tickCount; i++) { + lookup->tixArr[i] = tmpModule->tixArr[i]; + } + stgFree(tmpModule->tixArr); + stgFree(tmpModule->modName); + stgFree(tmpModule); } - nextModule=tmpModule; - + if (tix_ch == ',') { expect(','); ws(); @@ -166,9 +185,18 @@ fclose(tixFile); } -static void hpc_init(void) { +void +startupHpc(void) +{ char *hpc_tixdir; char *hpc_tixfile; + + if (moduleHash == NULL) { + // no modules were registered with hs_hpc_module, so don't bother + // creating the .tix file. + return; + } + if (hpc_inited != 0) { return; } @@ -177,6 +205,8 @@ hpc_tixdir = getenv("HPCTIXDIR"); hpc_tixfile = getenv("HPCTIXFILE"); + debugTrace(DEBUG_hpc,"startupHpc"); + /* XXX Check results of mallocs/strdups, and check we are requesting enough bytes */ if (hpc_tixfile != NULL) { @@ -192,10 +222,13 @@ #endif /* Then, try open the file */ - tixFilename = (char *) malloc(strlen(hpc_tixdir) + strlen(prog_name) + 12); + tixFilename = (char *) stgMallocBytes(strlen(hpc_tixdir) + + strlen(prog_name) + 12, + "Hpc.startupHpc"); sprintf(tixFilename,"%s/%s-%d.tix",hpc_tixdir,prog_name,(int)hpc_pid); } else { - tixFilename = (char *) malloc(strlen(prog_name) + 6); + tixFilename = (char *) stgMallocBytes(strlen(prog_name) + 6, + "Hpc.startupHpc"); sprintf(tixFilename, "%s.tix", prog_name); } @@ -204,90 +237,80 @@ } } -/* Called on a per-module basis, at startup time, declaring where the tix boxes are stored in memory. - * This memory can be uninitized, because we will initialize it with either the contents - * of the tix file, or all zeros. +/* + * Called on a per-module basis, by a constructor function compiled + * with each module (see Coverage.hpcInitCode), declaring where the + * tix boxes are stored in memory. This memory can be uninitized, + * because we will initialize it with either the contents of the tix + * file, or all zeros. + * + * Note that we might call this before reading the .tix file, or after + * in the case where we loaded some Haskell code from a .so with + * dlopen(). So we must handle the case where we already have an + * HpcModuleInfo for the module which was read from the .tix file. */ -int +void hs_hpc_module(char *modName, StgWord32 modCount, StgWord32 modHashNo, - StgWord64 *tixArr) { - HpcModuleInfo *tmpModule, *lastModule; - unsigned int i; - int offset = 0; - - debugTrace(DEBUG_hpc,"hs_hpc_module(%s,%d)",modName,(nat)modCount); + StgWord64 *tixArr) +{ + HpcModuleInfo *tmpModule; + nat i; - hpc_init(); + if (moduleHash == NULL) { + moduleHash = allocStrHashTable(); + } - tmpModule = modules; - lastModule = 0; - - for(;tmpModule != 0;tmpModule = tmpModule->next) { - if (!strcmp(tmpModule->modName,modName)) { + tmpModule = lookupHashTable(moduleHash, (StgWord)modName); + if (tmpModule == NULL) + { + // Did not find entry so add one on. + tmpModule = (HpcModuleInfo *)stgMallocBytes(sizeof(HpcModuleInfo), + "Hpc.hs_hpc_module"); + tmpModule->modName = modName; + tmpModule->tickCount = modCount; + tmpModule->hashNo = modHashNo; + + tmpModule->tixArr = tixArr; + for(i=0;i < modCount;i++) { + tixArr[i] = 0; + } + tmpModule->next = modules; + tmpModule->from_file = rtsFalse; + modules = tmpModule; + insertHashTable(moduleHash, (StgWord)modName, tmpModule); + } + else + { if (tmpModule->tickCount != modCount) { - failure("inconsistent number of tick boxes"); + failure("inconsistent number of tick boxes"); } - assert(tmpModule->tixArr != 0); + ASSERT(tmpModule->tixArr != 0); if (tmpModule->hashNo != modHashNo) { - fprintf(stderr,"in module '%s'\n",tmpModule->modName); - failure("module mismatch with .tix/.mix file hash number"); - fprintf(stderr,"(perhaps remove %s ?)\n",tixFilename); - stg_exit(1); - + fprintf(stderr,"in module '%s'\n",tmpModule->modName); + failure("module mismatch with .tix/.mix file hash number"); + if (tixFilename != NULL) { + fprintf(stderr,"(perhaps remove %s ?)\n",tixFilename); + } + stg_exit(EXIT_FAILURE); } + // The existing tixArr was made up when we read the .tix file, + // whereas this is the real tixArr, so copy the data from the + // .tix into the real tixArr. for(i=0;i < modCount;i++) { - tixArr[i] = tmpModule->tixArr[i]; + tixArr[i] = tmpModule->tixArr[i]; } - tmpModule->tixArr = tixArr; - return tmpModule->tickOffset; - } - lastModule = tmpModule; - } - // Did not find entry so add one on. - tmpModule = (HpcModuleInfo *)calloc(1,sizeof(HpcModuleInfo)); - tmpModule->modName = modName; - tmpModule->tickCount = modCount; - tmpModule->hashNo = modHashNo; - if (lastModule) { - tmpModule->tickOffset = lastModule->tickOffset + lastModule->tickCount; - } else { - tmpModule->tickOffset = 0; - } - tmpModule->tixArr = tixArr; - for(i=0;i < modCount;i++) { - tixArr[i] = 0; - } - tmpModule->next = 0; - - if (!modules) { - modules = tmpModule; - } else { - lastModule->next=tmpModule; - } - - debugTrace(DEBUG_hpc,"end: hs_hpc_module"); - - return offset; -} - -/* This is called after all the modules have registered their local tixboxes, - * and does a sanity check: are we good to go? - */ - -void -startupHpc(void) { - debugTrace(DEBUG_hpc,"startupHpc"); - - if (hpc_inited == 0) { - return; + if (tmpModule->from_file) { + stgFree(tmpModule->modName); + stgFree(tmpModule->tixArr); + } + tmpModule->from_file = rtsFalse; } } - static void writeTix(FILE *f) { HpcModuleInfo *tmpModule; @@ -311,11 +334,10 @@ tmpModule->modName, (nat)tmpModule->hashNo, (nat)tmpModule->tickCount); - debugTrace(DEBUG_hpc,"%s: %u (offset=%u) (hash=%u)\n", + debugTrace(DEBUG_hpc,"%s: %u (hash=%u)\n", tmpModule->modName, (nat)tmpModule->tickCount, - (nat)tmpModule->hashNo, - (nat)tmpModule->tickOffset); + (nat)tmpModule->hashNo); inner_comma = 0; for(i = 0;i < tmpModule->tickCount;i++) { @@ -338,7 +360,17 @@ fclose(f); } -/* Called at the end of execution, to write out the Hpc *.tix file +static void +freeHpcModuleInfo (HpcModuleInfo *mod) +{ + if (mod->from_file) { + stgFree(mod->modName); + stgFree(mod->tixArr); + } + stgFree(mod); +} + +/* Called at the end of execution, to write out the Hpc *.tix file * for this exection. Safe to call, even if coverage is not used. */ void @@ -357,6 +389,12 @@ FILE *f = fopen(tixFilename,"w"); writeTix(f); } + + freeHashTable(moduleHash, (void (*)(void *))freeHpcModuleInfo); + moduleHash = NULL; + + stgFree(tixFilename); + tixFilename = NULL; } ////////////////////////////////////////////////////////////////////////////// diff -Nru ghc-7.0.3/rts/HsFFI.c ghc-7.2.1/rts/HsFFI.c --- ghc-7.0.3/rts/HsFFI.c 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/rts/HsFFI.c 2011-08-07 17:10:05.000000000 +0000 @@ -2,7 +2,7 @@ * * (c) The GHC Team, 2005 * - * RTS entry points as mandated by the FFI addendum to the Haskell 98 report + * RTS entry points as mandated by the FFI section of the Haskell report * * ---------------------------------------------------------------------------*/ diff -Nru ghc-7.0.3/rts/Interpreter.c ghc-7.2.1/rts/Interpreter.c --- ghc-7.0.3/rts/Interpreter.c 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/rts/Interpreter.c 2011-08-07 17:10:05.000000000 +0000 @@ -49,13 +49,21 @@ /* Sp points to the lowest live word on the stack. */ -#define BCO_NEXT instrs[bciPtr++] -#define BCO_NEXT_32 (bciPtr += 2, (((StgWord) instrs[bciPtr-2]) << 16) + ((StgWord) instrs[bciPtr-1])) -#define BCO_NEXT_64 (bciPtr += 4, (((StgWord) instrs[bciPtr-4]) << 48) + (((StgWord) instrs[bciPtr-3]) << 32) + (((StgWord) instrs[bciPtr-2]) << 16) + ((StgWord) instrs[bciPtr-1])) +#define BCO_NEXT instrs[bciPtr++] +#define BCO_NEXT_32 (bciPtr += 2) +#define BCO_READ_NEXT_32 (BCO_NEXT_32, (((StgWord) instrs[bciPtr-2]) << 16) \ + + ( (StgWord) instrs[bciPtr-1])) +#define BCO_NEXT_64 (bciPtr += 4) +#define BCO_READ_NEXT_64 (BCO_NEXT_64, (((StgWord) instrs[bciPtr-4]) << 48) \ + + (((StgWord) instrs[bciPtr-3]) << 32) \ + + (((StgWord) instrs[bciPtr-2]) << 16) \ + + ( (StgWord) instrs[bciPtr-1])) #if WORD_SIZE_IN_BITS == 32 #define BCO_NEXT_WORD BCO_NEXT_32 +#define BCO_READ_NEXT_WORD BCO_READ_NEXT_32 #elif WORD_SIZE_IN_BITS == 64 #define BCO_NEXT_WORD BCO_NEXT_64 +#define BCO_READ_NEXT_WORD BCO_READ_NEXT_64 #else #error Cannot cope with WORD_SIZE_IN_BITS being nether 32 nor 64 #endif @@ -65,13 +73,13 @@ #define BCO_LIT(n) literals[n] #define LOAD_STACK_POINTERS \ - Sp = cap->r.rCurrentTSO->sp; \ + Sp = cap->r.rCurrentTSO->stackobj->sp; \ /* We don't change this ... */ \ - SpLim = cap->r.rCurrentTSO->stack + RESERVED_STACK_WORDS; + SpLim = tso_SpLim(cap->r.rCurrentTSO); #define SAVE_STACK_POINTERS \ ASSERT(Sp > SpLim); \ - cap->r.rCurrentTSO->sp = Sp + cap->r.rCurrentTSO->stackobj->sp = Sp #define RETURN_TO_SCHEDULER(todo,retcode) \ SAVE_STACK_POINTERS; \ @@ -266,7 +274,7 @@ debugBelch("Sp = %p\n", Sp); debugBelch("\n" ); - printStackChunk(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size); + printStackChunk(Sp,cap->r.rCurrentTSO->stackobj->stack+cap->r.rCurrentTSO->stackobj->stack_size); debugBelch("\n\n"); ); @@ -381,11 +389,11 @@ debugBelch("Returning: "); printObj(obj); debugBelch("Sp = %p\n", Sp); debugBelch("\n" ); - printStackChunk(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size); + printStackChunk(Sp,cap->r.rCurrentTSO->stackobj->stack+cap->r.rCurrentTSO->stackobj->stack_size); debugBelch("\n\n"); ); - IF_DEBUG(sanity,checkStackChunk(Sp, cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size)); + IF_DEBUG(sanity,checkStackChunk(Sp, cap->r.rCurrentTSO->stackobj->stack+cap->r.rCurrentTSO->stackobj->stack_size)); switch (get_itbl((StgClosure *)Sp)->type) { @@ -466,7 +474,7 @@ INTERP_TICK(it_retto_other); IF_DEBUG(interpreter, debugBelch("returning to unknown frame -- yielding to sched\n"); - printStackChunk(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size); + printStackChunk(Sp,cap->r.rCurrentTSO->stackobj->stack+cap->r.rCurrentTSO->stackobj->stack_size); ); Sp -= 2; Sp[1] = (W_)tagged_obj; @@ -529,8 +537,8 @@ INTERP_TICK(it_retto_other); IF_DEBUG(interpreter, debugBelch("returning to unknown frame -- yielding to sched\n"); - printStackChunk(Sp,cap->r.rCurrentTSO->stack+cap->r.rCurrentTSO->stack_size); - ); + printStackChunk(Sp,cap->r.rCurrentTSO->stackobj->stack+cap->r.rCurrentTSO->stackobj->stack_size); + ); RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding); } } @@ -776,8 +784,12 @@ register StgWord16* instrs = (StgWord16*)(bco->instrs->payload); register StgWord* literals = (StgWord*)(&bco->literals->payload[0]); register StgPtr* ptrs = (StgPtr*)(&bco->ptrs->payload[0]); +#ifdef DEBUG int bcoSize; - bcoSize = BCO_NEXT_WORD; + bcoSize = BCO_READ_NEXT_WORD; +#else + BCO_NEXT_WORD; +#endif IF_DEBUG(interpreter,debugBelch("bcoSize = %d\n", bcoSize)); #ifdef INTERP_STATS @@ -884,21 +896,15 @@ // in a reasonable state for the GC and so that // execution of this BCO can continue when we resume ioAction = (StgClosure *) deRefStablePtr (rts_breakpoint_io_action); - Sp -= 9; - Sp[8] = (W_)obj; - Sp[7] = (W_)&stg_apply_interp_info; - Sp[6] = (W_)&stg_noforceIO_info; // see [unreg] below + Sp -= 8; + Sp[7] = (W_)obj; + Sp[6] = (W_)&stg_apply_interp_info; Sp[5] = (W_)new_aps; // the AP_STACK Sp[4] = (W_)BCO_PTR(arg3_freeVars); // the info about local vars of the breakpoint Sp[3] = (W_)False_closure; // True <=> a breakpoint Sp[2] = (W_)&stg_ap_pppv_info; Sp[1] = (W_)ioAction; // apply the IO action to its two arguments above Sp[0] = (W_)&stg_enter_info; // get ready to run the IO action - // Note [unreg]: in unregisterised mode, the return - // convention for IO is different. The - // stg_noForceIO_info stack frame is necessary to - // account for this difference. - // set the flag in the TSO to say that we are now // stopping at a breakpoint so that when we resume // we don't stop on the same breakpoint that we @@ -1362,6 +1368,7 @@ void *tok; int stk_offset = BCO_NEXT; int o_itbl = BCO_NEXT; + int interruptible = BCO_NEXT; void(*marshall_fn)(void*) = (void (*)(void*))BCO_LIT(o_itbl); int ret_dyn_size = RET_DYN_BITMAP_SIZE + RET_DYN_NONPTR_REGS_SIZE @@ -1450,7 +1457,7 @@ ((StgRetDyn *)Sp)->payload[0] = (StgClosure *)obj; SAVE_STACK_POINTERS; - tok = suspendThread(&cap->r); + tok = suspendThread(&cap->r, interruptible ? rtsTrue : rtsFalse); // We already made a copy of the arguments above. ffi_call(cif, fn, ret, argptrs); @@ -1459,6 +1466,14 @@ cap = (Capability *)((void *)((unsigned char*)resumeThread(tok) - STG_FIELD_OFFSET(Capability,r))); LOAD_STACK_POINTERS; + if (Sp[0] != (W_)&stg_gc_gen_info) { + // the stack is not how we left it. This probably + // means that an exception got raised on exit from the + // foreign call, so we should just continue with + // whatever is on top of the stack now. + RETURN_TO_SCHEDULER_NO_PAUSE(ThreadRunGHC, ThreadYielding); + } + // Re-load the pointer to the BCO from the RET_DYN frame, // it might have moved during the call. Also reload the // pointers to the components of the BCO. diff -Nru ghc-7.0.3/rts/LdvProfile.c ghc-7.2.1/rts/LdvProfile.c --- ghc-7.0.3/rts/LdvProfile.c 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/rts/LdvProfile.c 2011-08-07 17:10:05.000000000 +0000 @@ -19,44 +19,6 @@ #include "Schedule.h" /* -------------------------------------------------------------------------- - * Fills in the slop when a *dynamic* closure changes its type. - * First calls LDV_recordDead() to declare the closure is dead, and then - * fills in the slop. - * - * Invoked when: - * 1) blackholing, UPD_BH_UPDATABLE() and UPD_BH_SINGLE_ENTRY (in - * includes/StgMacros.h), threadLazyBlackHole() and - * threadSqueezeStack() (in GC.c). - * 2) updating with indirection closures, updateWithIndirection() - * and updateWithPermIndirection() (in Storage.h). - * - * LDV_recordDead_FILL_SLOP_DYNAMIC() is not called on 'inherently used' - * closures such as TSO. It is not called on PAP because PAP is not updatable. - * ----------------------------------------------------------------------- */ -void -LDV_recordDead_FILL_SLOP_DYNAMIC( StgClosure *p ) -{ - nat size, i; - -#if defined(__GNUC__) && __GNUC__ < 3 && defined(DEBUG) -#error Please use gcc 3.0+ to compile this file with DEBUG; gcc < 3.0 miscompiles it -#endif - - if (era > 0) { - // very like FILL_SLOP(), except that we call LDV_recordDead(). - size = closure_sizeW(p); - - LDV_recordDead((StgClosure *)(p), size); - - if (size > sizeofW(StgThunkHeader)) { - for (i = 0; i < size - sizeofW(StgThunkHeader); i++) { - ((StgThunk *)(p))->payload[i] = 0; - } - } - } -} - -/* -------------------------------------------------------------------------- * This function is called eventually on every object destroyed during * a garbage collection, whether it is a major garbage collection or * not. If c is an 'inherently used' closure, nothing happens. If c @@ -98,6 +60,7 @@ 'inherently used' cases: do nothing. */ case TSO: + case STACK: case MVAR_CLEAN: case MVAR_DIRTY: case MUT_ARR_PTRS_CLEAN: @@ -168,6 +131,7 @@ // stack objects case UPDATE_FRAME: case CATCH_FRAME: + case UNDERFLOW_FRAME: case STOP_FRAME: case RET_DYN: case RET_BCO: diff -Nru ghc-7.0.3/rts/Linker.c ghc-7.2.1/rts/Linker.c --- ghc-7.0.3/rts/Linker.c 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/rts/Linker.c 2011-08-07 17:10:05.000000000 +0000 @@ -13,8 +13,8 @@ /* Linux needs _GNU_SOURCE to get RTLD_DEFAULT from and MREMAP_MAYMOVE from . */ -#ifdef __linux__ -#define _GNU_SOURCE +#if defined(__linux__) || defined(__GLIBC__) +#define _GNU_SOURCE 1 #endif #include "Rts.h" @@ -70,11 +70,12 @@ #include #endif -#if defined(linux_HOST_OS ) || defined(freebsd_HOST_OS) || \ - defined(dragonfly_HOST_OS) || defined(netbsd_HOST_OS ) || \ - defined(openbsd_HOST_OS ) || \ - ( defined(darwin_HOST_OS ) && !defined(powerpc_HOST_ARCH) ) -/* Don't use mmap on powerpc-apple-darwin as mmap doesn't support +#if !defined(powerpc_HOST_ARCH) && \ + ( defined(linux_HOST_OS ) || defined(freebsd_HOST_OS) || \ + defined(dragonfly_HOST_OS) || defined(netbsd_HOST_OS ) || \ + defined(openbsd_HOST_OS ) || defined(darwin_HOST_OS ) || \ + defined(kfreebsdgnu_HOST_OS) ) +/* Don't use mmap on powerpc_HOST_ARCH as mmap doesn't support * reallocating but we need to allocate jump islands just after each * object images. Otherwise relative branches to jump islands can fail * due to 24-bits displacement overflow. @@ -89,7 +90,7 @@ #endif -#if defined(linux_HOST_OS) || defined(solaris2_HOST_OS) || defined(freebsd_HOST_OS) || defined(dragonfly_HOST_OS) || defined(netbsd_HOST_OS) || defined(openbsd_HOST_OS) +#if defined(linux_HOST_OS) || defined(solaris2_HOST_OS) || defined(freebsd_HOST_OS) || defined(kfreebsdgnu_HOST_OS) || defined(dragonfly_HOST_OS) || defined(netbsd_HOST_OS) || defined(openbsd_HOST_OS) # define OBJFORMAT_ELF # include // regex is already used by dlopen() so this is OK // to use here without requiring an additional lib @@ -100,6 +101,8 @@ #elif defined(darwin_HOST_OS) # define OBJFORMAT_MACHO # include +# include +# include # include # include # include @@ -271,6 +274,7 @@ SymI_HasProto(signal_handlers) \ SymI_HasProto(stg_sig_install) \ SymI_HasProto(rtsTimerSignal) \ + SymI_HasProto(atexit) \ SymI_NeedsProto(nocldstop) #endif @@ -383,6 +387,8 @@ SymI_HasProto(stg_asyncReadzh) \ SymI_HasProto(stg_asyncWritezh) \ SymI_HasProto(stg_asyncDoProczh) \ + SymI_HasProto(getWin32ProgArgv) \ + SymI_HasProto(setWin32ProgArgv) \ SymI_HasProto(memset) \ SymI_HasProto(inet_ntoa) \ SymI_HasProto(inet_addr) \ @@ -781,7 +787,6 @@ SymI_HasProto(forkProcess) \ SymI_HasProto(forkOS_createThread) \ SymI_HasProto(freeHaskellFunctionPtr) \ - SymI_HasProto(getOrSetTypeableStore) \ SymI_HasProto(getOrSetGHCConcSignalSignalHandlerStore) \ SymI_HasProto(getOrSetGHCConcWindowsPendingDelaysStore) \ SymI_HasProto(getOrSetGHCConcWindowsIOManagerThreadStore) \ @@ -828,6 +833,7 @@ SymI_HasProto(stg_newTVarzh) \ SymI_HasProto(stg_noDuplicatezh) \ SymI_HasProto(stg_atomicModifyMutVarzh) \ + SymI_HasProto(stg_casMutVarzh) \ SymI_HasProto(stg_newPinnedByteArrayzh) \ SymI_HasProto(stg_newAlignedPinnedByteArrayzh) \ SymI_HasProto(newSpark) \ @@ -980,7 +986,7 @@ SymI_HasProto(stg_yieldzh) \ SymI_NeedsProto(stg_interp_constr_entry) \ SymI_HasProto(stg_arg_bitmaps) \ - SymI_HasProto(alloc_blocks_lim) \ + SymI_HasProto(large_alloc_lim) \ SymI_HasProto(g0) \ SymI_HasProto(allocate) \ SymI_HasProto(allocateExec) \ @@ -1181,13 +1187,17 @@ # endif /* RTLD_DEFAULT */ compileResult = regcomp(&re_invalid, - "(([^ \t()])+\\.so([^ \t:()])*):([ \t])*invalid ELF header", + "(([^ \t()])+\\.so([^ \t:()])*):([ \t])*(invalid ELF header|file too short)", REG_EXTENDED); - ASSERT( compileResult == 0 ); + if (compileResult != 0) { + barf("Compiling re_invalid failed"); + } compileResult = regcomp(&re_realso, - "GROUP *\\( *(([^ )])+)", + "(GROUP|INPUT) *\\( *(([^ )])+)", REG_EXTENDED); - ASSERT( compileResult == 0 ); + if (compileResult != 0) { + barf("Compiling re_realso failed"); + } # endif #if !defined(ALWAYS_PIC) && defined(x86_64_HOST_ARCH) @@ -1356,8 +1366,8 @@ if (regexec(&re_realso, line, (size_t) NMATCH, match, 0) == 0) { // success -- try to dlopen the first named file IF_DEBUG(linker, debugBelch("match%s\n","")); - line[match[1].rm_eo] = '\0'; - errmsg = internal_dlopen(line+match[1].rm_so); + line[match[2].rm_eo] = '\0'; + errmsg = internal_dlopen(line+match[2].rm_so); break; } // if control reaches here, no GROUP ( ... ) directive was found @@ -1563,6 +1573,7 @@ int pagesize, size; static nat fixed = 0; + IF_DEBUG(linker, debugBelch("mmapForLinker: start\n")); pagesize = getpagesize(); size = ROUND_UP(bytes, pagesize); @@ -1574,6 +1585,8 @@ } #endif + IF_DEBUG(linker, debugBelch("mmapForLinker: \tprotection %#0x\n", PROT_EXEC | PROT_READ | PROT_WRITE)); + IF_DEBUG(linker, debugBelch("mmapForLinker: \tflags %#0x\n", MAP_PRIVATE | TRY_MAP_32BIT | fixed | flags)); result = mmap(map_addr, size, PROT_EXEC|PROT_READ|PROT_WRITE, MAP_PRIVATE|TRY_MAP_32BIT|fixed|flags, fd, 0); @@ -1590,7 +1603,7 @@ } else { if ((W_)result > 0x80000000) { // oops, we were given memory over 2Gb -#if defined(freebsd_HOST_OS) || defined(dragonfly_HOST_OS) +#if defined(freebsd_HOST_OS) || defined(kfreebsdgnu_HOST_OS) || defined(dragonfly_HOST_OS) // Some platforms require MAP_FIXED. This is normally // a bad idea, because MAP_FIXED will overwrite // existing mappings. @@ -1621,6 +1634,8 @@ } #endif + IF_DEBUG(linker, debugBelch("mmapForLinker: mapped %lu bytes starting at %p\n", (lnat)size, result)); + IF_DEBUG(linker, debugBelch("mmapForLinker: done\n")); return result; } #endif // USE_MMAP @@ -1636,6 +1651,7 @@ ) { ObjectCode* oc; + IF_DEBUG(linker, debugBelch("mkOc: start\n")); oc = stgMallocBytes(sizeof(ObjectCode), "loadArchive(oc)"); # if defined(OBJFORMAT_ELF) @@ -1677,6 +1693,7 @@ oc->next = objects; objects = oc; + IF_DEBUG(linker, debugBelch("mkOc: done\n")); return oc; } @@ -1692,13 +1709,33 @@ char *fileName; size_t fileNameSize; int isObject, isGnuIndex; - char tmp[12]; + char tmp[20]; char *gnuFileIndex; int gnuFileIndexSize; -#if !defined(USE_MMAP) && defined(darwin_HOST_OS) +#if defined(darwin_HOST_OS) + int i; + uint32_t nfat_arch, nfat_offset, cputype, cpusubtype; +#if defined(i386_HOST_ARCH) + const uint32_t mycputype = CPU_TYPE_X86; + const uint32_t mycpusubtype = CPU_SUBTYPE_X86_ALL; +#elif defined(x86_64_HOST_ARCH) + const uint32_t mycputype = CPU_TYPE_X86_64; + const uint32_t mycpusubtype = CPU_SUBTYPE_X86_64_ALL; +#elif defined(powerpc_HOST_ARCH) + const uint32_t mycputype = CPU_TYPE_POWERPC; + const uint32_t mycpusubtype = CPU_SUBTYPE_POWERPC_ALL; +#elif defined(powerpc64_HOST_ARCH) + const uint32_t mycputype = CPU_TYPE_POWERPC64; + const uint32_t mycpusubtype = CPU_SUBTYPE_POWERPC_ALL; +#else +#error Unknown Darwin architecture +#endif +#if !defined(USE_MMAP) int misalignment; #endif +#endif + IF_DEBUG(linker, debugBelch("loadArchive: start\n")); IF_DEBUG(linker, debugBelch("loadArchive: Loading archive `%s'\n", path)); gnuFileIndex = NULL; @@ -1711,20 +1748,97 @@ if (!f) barf("loadObj: can't read `%s'", path); + /* Check if this is an archive by looking for the magic "!\n" + * string. Usually, if this fails, we barf and quit. On Darwin however, + * we may have a fat archive, which contains archives for more than + * one architecture. Fat archives start with the magic number 0xcafebabe, + * always stored big endian. If we find a fat_header, we scan through + * the fat_arch structs, searching through for one for our host + * architecture. If a matching struct is found, we read the offset + * of our archive data (nfat_offset) and seek forward nfat_offset bytes + * from the start of the file. + * + * A subtlety is that all of the members of the fat_header and fat_arch + * structs are stored big endian, so we need to call byte order + * conversion functions. + * + * If we find the appropriate architecture in a fat archive, we gobble + * its magic "!\n" string and continue processing just as if + * we had a single architecture archive. + */ + n = fread ( tmp, 1, 8, f ); - if (strncmp(tmp, "!\n", 8) != 0) + if (n != 8) + barf("loadArchive: Failed reading header from `%s'", path); + if (strncmp(tmp, "!\n", 8) != 0) { + +#if defined(darwin_HOST_OS) + /* Not a standard archive, look for a fat archive magic number: */ + if (ntohl(*(uint32_t *)tmp) == FAT_MAGIC) { + nfat_arch = ntohl(*(uint32_t *)(tmp + 4)); + IF_DEBUG(linker, debugBelch("loadArchive: found a fat archive containing %d architectures\n", nfat_arch)); + nfat_offset = 0; + + for (i = 0; i < (int)nfat_arch; i++) { + /* search for the right arch */ + n = fread( tmp, 1, 20, f ); + if (n != 8) + barf("loadArchive: Failed reading arch from `%s'", path); + cputype = ntohl(*(uint32_t *)tmp); + cpusubtype = ntohl(*(uint32_t *)(tmp + 4)); + + if (cputype == mycputype && cpusubtype == mycpusubtype) { + IF_DEBUG(linker, debugBelch("loadArchive: found my archive in a fat archive\n")); + nfat_offset = ntohl(*(uint32_t *)(tmp + 8)); + break; + } + } + + if (nfat_offset == 0) { + barf ("loadArchive: searched %d architectures, but no host arch found", (int)nfat_arch); + } + else { + n = fseek( f, nfat_offset, SEEK_SET ); + if (n != 0) + barf("loadArchive: Failed to seek to arch in `%s'", path); + n = fread ( tmp, 1, 8, f ); + if (n != 8) + barf("loadArchive: Failed reading header from `%s'", path); + if (strncmp(tmp, "!\n", 8) != 0) { + barf("loadArchive: couldn't find archive in `%s' at offset %d", path, nfat_offset); + } + } + } + else { + barf("loadArchive: Neither an archive, nor a fat archive: `%s'", path); + } + +#else barf("loadArchive: Not an archive: `%s'", path); +#endif + } + + IF_DEBUG(linker, debugBelch("loadArchive: loading archive contents\n")); while(1) { n = fread ( fileName, 1, 16, f ); if (n != 16) { if (feof(f)) { + IF_DEBUG(linker, debugBelch("loadArchive: EOF while reading from '%s'\n", path)); break; } else { barf("loadArchive: Failed reading file name from `%s'", path); } } + +#if defined(darwin_HOST_OS) + if (strncmp(fileName, "!\n", 8) == 0) { + IF_DEBUG(linker, debugBelch("loadArchive: found the start of another archive, breaking\n")); + break; + } +#endif + n = fread ( tmp, 1, 12, f ); if (n != 12) barf("loadArchive: Failed reading mod time from `%s'", path); @@ -1744,7 +1858,11 @@ for (n = 0; isdigit(tmp[n]); n++); tmp[n] = '\0'; memberSize = atoi(tmp); + + IF_DEBUG(linker, debugBelch("loadArchive: size of this archive member is %d\n", memberSize)); n = fread ( tmp, 1, 2, f ); + if (n != 2) + barf("loadArchive: Failed reading magic from `%s'", path); if (strncmp(tmp, "\x60\x0A", 2) != 0) barf("loadArchive: Failed reading magic from `%s' at %ld. Got %c%c", path, ftell(f), tmp[0], tmp[1]); @@ -1770,6 +1888,11 @@ path); } fileName[thisFileNameSize] = 0; + + /* On OS X at least, thisFileNameSize is the size of the + fileName field, not the length of the fileName + itself. */ + thisFileNameSize = strlen(fileName); } else { barf("loadArchive: BSD-variant filename size not found while reading filename from `%s'", path); @@ -1855,6 +1978,9 @@ && fileName[thisFileNameSize - 2] == '.' && fileName[thisFileNameSize - 1] == 'o'; + IF_DEBUG(linker, debugBelch("loadArchive: \tthisFileNameSize = %d\n", (int)thisFileNameSize)); + IF_DEBUG(linker, debugBelch("loadArchive: \tisObject = %d\n", isObject)); + if (isObject) { char *archiveMemberName; @@ -1920,23 +2046,29 @@ gnuFileIndexSize = memberSize; } else { + IF_DEBUG(linker, debugBelch("loadArchive: '%s' does not appear to be an object file\n", fileName)); n = fseek(f, memberSize, SEEK_CUR); if (n != 0) barf("loadArchive: error whilst seeking by %d in `%s'", memberSize, path); } + /* .ar files are 2-byte aligned */ if (memberSize % 2) { + IF_DEBUG(linker, debugBelch("loadArchive: trying to read one pad byte\n")); n = fread ( tmp, 1, 1, f ); if (n != 1) { if (feof(f)) { + IF_DEBUG(linker, debugBelch("loadArchive: found EOF while reading one pad byte\n")); break; } else { barf("loadArchive: Failed reading padding from `%s'", path); } } + IF_DEBUG(linker, debugBelch("loadArchive: successfully read one pad byte\n")); } + IF_DEBUG(linker, debugBelch("loadArchive: reached end of archive loading while loop\n")); } fclose(f); @@ -1950,6 +2082,7 @@ #endif } + IF_DEBUG(linker, debugBelch("loadArchive: done\n")); return 1; } @@ -2077,18 +2210,18 @@ loadOc( ObjectCode* oc ) { int r; - IF_DEBUG(linker, debugBelch("loadOc\n")); + IF_DEBUG(linker, debugBelch("loadOc: start\n")); # if defined(OBJFORMAT_MACHO) && (defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH)) r = ocAllocateSymbolExtras_MachO ( oc ); if (!r) { - IF_DEBUG(linker, debugBelch("ocAllocateSymbolExtras_MachO failed\n")); + IF_DEBUG(linker, debugBelch("loadOc: ocAllocateSymbolExtras_MachO failed\n")); return r; } # elif defined(OBJFORMAT_ELF) && (defined(powerpc_HOST_ARCH) || defined(x86_64_HOST_ARCH)) r = ocAllocateSymbolExtras_ELF ( oc ); if (!r) { - IF_DEBUG(linker, debugBelch("ocAllocateSymbolExtras_ELF failed\n")); + IF_DEBUG(linker, debugBelch("loadOc: ocAllocateSymbolExtras_ELF failed\n")); return r; } #endif @@ -2104,7 +2237,7 @@ barf("loadObj: no verify method"); # endif if (!r) { - IF_DEBUG(linker, debugBelch("ocVerifyImage_* failed\n")); + IF_DEBUG(linker, debugBelch("loadOc: ocVerifyImage_* failed\n")); return r; } @@ -2119,13 +2252,13 @@ barf("loadObj: no getNames method"); # endif if (!r) { - IF_DEBUG(linker, debugBelch("ocGetNames_* failed\n")); + IF_DEBUG(linker, debugBelch("loadOc: ocGetNames_* failed\n")); return r; } /* loaded, but not resolved yet */ oc->status = OBJECT_LOADED; - IF_DEBUG(linker, debugBelch("loadObj done.\n")); + IF_DEBUG(linker, debugBelch("loadOc: done.\n")); return 1; } @@ -2207,6 +2340,7 @@ // stgFree(oc->image); // #endif stgFree(oc->fileName); + stgFree(oc->archiveMemberName); stgFree(oc->symbols); stgFree(oc->sections); stgFree(oc); @@ -2231,11 +2365,13 @@ * which may be prodded during relocation, and abort if we try and write * outside any of these. */ -static void addProddableBlock ( ObjectCode* oc, void* start, int size ) +static void +addProddableBlock ( ObjectCode* oc, void* start, int size ) { ProddableBlock* pb = stgMallocBytes(sizeof(ProddableBlock), "addProddableBlock"); - IF_DEBUG(linker, debugBelch("addProddableBlock %p %p %d\n", oc, start, size)); + + IF_DEBUG(linker, debugBelch("addProddableBlock: %p %p %d\n", oc, start, size)); ASSERT(size > 0); pb->start = start; pb->size = size; @@ -2243,9 +2379,11 @@ oc->proddables = pb; } -static void checkProddableBlock ( ObjectCode* oc, void* addr ) +static void +checkProddableBlock (ObjectCode *oc, void *addr ) { ProddableBlock* pb; + for (pb = oc->proddables; pb != NULL; pb = pb->next) { char* s = (char*)(pb->start); char* e = s + pb->size - 1; @@ -2261,7 +2399,8 @@ /* ----------------------------------------------------------------------------- * Section management. */ -static void addSection ( ObjectCode* oc, SectionKind kind, +static void +addSection ( ObjectCode* oc, SectionKind kind, void* start, void* end ) { Section* s = stgMallocBytes(sizeof(Section), "addSection"); @@ -2270,10 +2409,9 @@ s->kind = kind; s->next = oc->sections; oc->sections = s; - /* - debugBelch("addSection: %p-%p (size %d), kind %d\n", - start, ((char*)end)-1, end - start + 1, kind ); - */ + + IF_DEBUG(linker, debugBelch("addSection: %p-%p (size %ld), kind %d\n", + start, ((char*)end)-1, (long)end - (long)start + 1, kind )); } @@ -2414,7 +2552,9 @@ Because the PPC has split data/instruction caches, we have to do that whenever we modify code at runtime. */ -static void ocFlushInstructionCacheFrom(void* begin, size_t length) + +static void +ocFlushInstructionCacheFrom(void* begin, size_t length) { size_t n = (length + 3) / 4; unsigned long* p = begin; @@ -2433,15 +2573,22 @@ "isync" ); } -static void ocFlushInstructionCache( ObjectCode *oc ) + +static void +ocFlushInstructionCache( ObjectCode *oc ) { /* The main object code */ - ocFlushInstructionCacheFrom(oc->image + oc->misalignment, oc->fileSize); + ocFlushInstructionCacheFrom(oc->image +#ifdef darwin_HOST_OS + + oc->misalignment +#endif + , oc->fileSize); /* Jump Islands */ ocFlushInstructionCacheFrom(oc->symbol_extras, sizeof(SymbolExtra) * oc->n_symbol_extras); } -#endif +#endif /* powerpc_HOST_ARCH */ + /* -------------------------------------------------------------------------- * PEi386 specifics (Win32 targets) @@ -3539,31 +3686,6 @@ * Generic ELF functions */ -static char * -findElfSection ( void* objImage, Elf_Word sh_type ) -{ - char* ehdrC = (char*)objImage; - Elf_Ehdr* ehdr = (Elf_Ehdr*)ehdrC; - Elf_Shdr* shdr = (Elf_Shdr*)(ehdrC + ehdr->e_shoff); - char* sh_strtab = ehdrC + shdr[ehdr->e_shstrndx].sh_offset; - char* ptr = NULL; - int i; - - for (i = 0; i < ehdr->e_shnum; i++) { - if (shdr[i].sh_type == sh_type - /* Ignore the section header's string table. */ - && i != ehdr->e_shstrndx - /* Ignore string tables named .stabstr, as they contain - debugging info. */ - && 0 != memcmp(".stabstr", sh_strtab + shdr[i].sh_name, 8) - ) { - ptr = ehdrC + shdr[i].sh_offset; - break; - } - } - return ptr; -} - static int ocVerifyImage_ELF ( ObjectCode* oc ) { @@ -3571,7 +3693,6 @@ Elf_Sym* stab; int i, j, nent, nstrtab, nsymtabs; char* sh_strtab; - char* strtab; char* ehdrC = (char*)(oc->image); Elf_Ehdr* ehdr = (Elf_Ehdr*)ehdrC; @@ -3653,20 +3774,64 @@ ehdrC + shdr[i].sh_offset, ehdrC + shdr[i].sh_offset + shdr[i].sh_size - 1)); - if (shdr[i].sh_type == SHT_REL) { - IF_DEBUG(linker,debugBelch("Rel " )); - } else if (shdr[i].sh_type == SHT_RELA) { - IF_DEBUG(linker,debugBelch("RelA " )); - } else { - IF_DEBUG(linker,debugBelch(" ")); +#define SECTION_INDEX_VALID(ndx) (ndx > SHN_UNDEF && ndx < ehdr->e_shnum) + + switch (shdr[i].sh_type) { + + case SHT_REL: + case SHT_RELA: + IF_DEBUG(linker,debugBelch( shdr[i].sh_type == SHT_REL ? "Rel " : "RelA ")); + + if (!SECTION_INDEX_VALID(shdr[i].sh_link)) { + if (shdr[i].sh_link == SHN_UNDEF) + errorBelch("\n%s: relocation section #%d has no symbol table\n" + "This object file has probably been fully striped. " + "Such files cannot be linked.\n", + oc->archiveMemberName ? oc->archiveMemberName : oc->fileName, i); + else + errorBelch("\n%s: relocation section #%d has an invalid link field (%d)\n", + oc->archiveMemberName ? oc->archiveMemberName : oc->fileName, + i, shdr[i].sh_link); + return 0; + } + if (shdr[shdr[i].sh_link].sh_type != SHT_SYMTAB) { + errorBelch("\n%s: relocation section #%d does not link to a symbol table\n", + oc->archiveMemberName ? oc->archiveMemberName : oc->fileName, i); + return 0; + } + if (!SECTION_INDEX_VALID(shdr[i].sh_info)) { + errorBelch("\n%s: relocation section #%d has an invalid info field (%d)\n", + oc->archiveMemberName ? oc->archiveMemberName : oc->fileName, + i, shdr[i].sh_info); + return 0; + } + + break; + case SHT_SYMTAB: + IF_DEBUG(linker,debugBelch("Sym ")); + + if (!SECTION_INDEX_VALID(shdr[i].sh_link)) { + errorBelch("\n%s: symbol table section #%d has an invalid link field (%d)\n", + oc->archiveMemberName ? oc->archiveMemberName : oc->fileName, + i, shdr[i].sh_link); + return 0; + } + if (shdr[shdr[i].sh_link].sh_type != SHT_STRTAB) { + errorBelch("\n%s: symbol table section #%d does not link to a string table\n", + oc->archiveMemberName ? oc->archiveMemberName : oc->fileName, i); + + return 0; + } + break; + case SHT_STRTAB: IF_DEBUG(linker,debugBelch("Str ")); break; + default: IF_DEBUG(linker,debugBelch(" ")); break; } if (sh_strtab) { IF_DEBUG(linker,debugBelch("sname=%s\n", sh_strtab + shdr[i].sh_name )); } } - IF_DEBUG(linker,debugBelch( "\nString tables" )); - strtab = NULL; + IF_DEBUG(linker,debugBelch( "\nString tables\n" )); nstrtab = 0; for (i = 0; i < ehdr->e_shnum; i++) { if (shdr[i].sh_type == SHT_STRTAB @@ -3676,18 +3841,16 @@ debugging info. */ && 0 != memcmp(".stabstr", sh_strtab + shdr[i].sh_name, 8) ) { - IF_DEBUG(linker,debugBelch(" section %d is a normal string table", i )); - strtab = ehdrC + shdr[i].sh_offset; + IF_DEBUG(linker,debugBelch(" section %d is a normal string table\n", i )); nstrtab++; } } - if (nstrtab != 1) { - errorBelch("%s: no string tables, or too many", oc->fileName); - return 0; + if (nstrtab == 0) { + IF_DEBUG(linker,debugBelch(" no normal string tables (potentially, but not necessarily a problem)\n")); } nsymtabs = 0; - IF_DEBUG(linker,debugBelch( "\nSymbol tables" )); + IF_DEBUG(linker,debugBelch( "Symbol tables\n" )); for (i = 0; i < ehdr->e_shnum; i++) { if (shdr[i].sh_type != SHT_SYMTAB) continue; IF_DEBUG(linker,debugBelch( "section %d is a symbol table\n", i )); @@ -3729,13 +3892,17 @@ } IF_DEBUG(linker,debugBelch(" " )); - IF_DEBUG(linker,debugBelch("name=%s\n", strtab + stab[j].st_name )); + IF_DEBUG(linker,debugBelch("name=%s\n", + ehdrC + shdr[shdr[i].sh_link].sh_offset + + stab[j].st_name )); } } if (nsymtabs == 0) { - errorBelch("%s: didn't find any symbol tables", oc->fileName); - return 0; + // Not having a symbol table is not in principle a problem. + // When an object file has no symbols then the 'strip' program + // typically will remove the symbol table entirely. + IF_DEBUG(linker,debugBelch(" no symbol tables (potentially, but not necessarily a problem)\n")); } return 1; @@ -3777,22 +3944,16 @@ static int ocGetNames_ELF ( ObjectCode* oc ) { - int i, j, k, nent; + int i, j, nent; Elf_Sym* stab; char* ehdrC = (char*)(oc->image); Elf_Ehdr* ehdr = (Elf_Ehdr*)ehdrC; - char* strtab = findElfSection ( ehdrC, SHT_STRTAB ); + char* strtab; Elf_Shdr* shdr = (Elf_Shdr*) (ehdrC + ehdr->e_shoff); ASSERT(symhash != NULL); - if (!strtab) { - errorBelch("%s: no strtab", oc->fileName); - return 0; - } - - k = 0; for (i = 0; i < ehdr->e_shnum; i++) { /* Figure out what kind of section it is. Logic derived from Figure 1.14 ("Special Sections") of the ELF document @@ -3824,12 +3985,16 @@ /* copy stuff into this module's object symbol table */ stab = (Elf_Sym*) (ehdrC + shdr[i].sh_offset); + strtab = ehdrC + shdr[shdr[i].sh_link].sh_offset; nent = shdr[i].sh_size / sizeof(Elf_Sym); oc->n_symbols = nent; oc->symbols = stgMallocBytes(oc->n_symbols * sizeof(char*), "ocGetNames_ELF(oc->symbols)"); + //TODO: we ignore local symbols anyway right? So we can use the + // shdr[i].sh_info to get the index of the first non-local symbol + // ie we should use j = shdr[i].sh_info for (j = 0; j < nent; j++) { char isLocal = FALSE; /* avoids uninit-var warning */ @@ -3927,21 +4092,24 @@ relocations appear to be of this form. */ static int do_Elf_Rel_relocations ( ObjectCode* oc, char* ehdrC, - Elf_Shdr* shdr, int shnum, - Elf_Sym* stab, char* strtab ) + Elf_Shdr* shdr, int shnum ) { int j; char *symbol; Elf_Word* targ; Elf_Rel* rtab = (Elf_Rel*) (ehdrC + shdr[shnum].sh_offset); + Elf_Sym* stab; + char* strtab; int nent = shdr[shnum].sh_size / sizeof(Elf_Rel); int target_shndx = shdr[shnum].sh_info; int symtab_shndx = shdr[shnum].sh_link; + int strtab_shndx = shdr[symtab_shndx].sh_link; stab = (Elf_Sym*) (ehdrC + shdr[ symtab_shndx ].sh_offset); + strtab= (char*) (ehdrC + shdr[ strtab_shndx ].sh_offset); targ = (Elf_Word*)(ehdrC + shdr[ target_shndx ].sh_offset); - IF_DEBUG(linker,debugBelch( "relocations for section %d using symtab %d\n", - target_shndx, symtab_shndx )); + IF_DEBUG(linker,debugBelch( "relocations for section %d using symtab %d and strtab %d\n", + target_shndx, symtab_shndx, strtab_shndx )); /* Skip sections that we're not interested in. */ { @@ -3959,10 +4127,14 @@ Elf_Addr P = ((Elf_Addr)targ) + offset; Elf_Word* pP = (Elf_Word*)P; +#if defined(i386_HOST_ARCH) || defined(DEBUG) Elf_Addr A = *pP; +#endif Elf_Addr S; void* S_tmp; +#ifdef i386_HOST_ARCH Elf_Addr value; +#endif StgStablePtr stablePtr; StgPtr stableVal; @@ -4006,7 +4178,9 @@ (void*)P, (void*)S, (void*)A )); checkProddableBlock ( oc, pP ); +#ifdef i386_HOST_ARCH value = S + A; +#endif switch (ELF_R_TYPE(info)) { # ifdef i386_HOST_ARCH @@ -4027,18 +4201,21 @@ sparc-solaris relocations appear to be of this form. */ static int do_Elf_Rela_relocations ( ObjectCode* oc, char* ehdrC, - Elf_Shdr* shdr, int shnum, - Elf_Sym* stab, char* strtab ) + Elf_Shdr* shdr, int shnum ) { int j; char *symbol = NULL; Elf_Addr targ; Elf_Rela* rtab = (Elf_Rela*) (ehdrC + shdr[shnum].sh_offset); + Elf_Sym* stab; + char* strtab; int nent = shdr[shnum].sh_size / sizeof(Elf_Rela); int target_shndx = shdr[shnum].sh_info; int symtab_shndx = shdr[shnum].sh_link; + int strtab_shndx = shdr[symtab_shndx].sh_link; stab = (Elf_Sym*) (ehdrC + shdr[ symtab_shndx ].sh_offset); + strtab= (char*) (ehdrC + shdr[ strtab_shndx ].sh_offset); targ = (Elf_Addr) (ehdrC + shdr[ target_shndx ].sh_offset); IF_DEBUG(linker,debugBelch( "relocations for section %d using symtab %d\n", target_shndx, symtab_shndx )); @@ -4307,35 +4484,20 @@ static int ocResolve_ELF ( ObjectCode* oc ) { - char *strtab; int shnum, ok; - Elf_Sym* stab = NULL; char* ehdrC = (char*)(oc->image); Elf_Ehdr* ehdr = (Elf_Ehdr*) ehdrC; Elf_Shdr* shdr = (Elf_Shdr*) (ehdrC + ehdr->e_shoff); - /* first find "the" symbol table */ - stab = (Elf_Sym*) findElfSection ( ehdrC, SHT_SYMTAB ); - - /* also go find the string table */ - strtab = findElfSection ( ehdrC, SHT_STRTAB ); - - if (stab == NULL || strtab == NULL) { - errorBelch("%s: can't find string or symbol table", oc->fileName); - return 0; - } - /* Process the relocation sections. */ for (shnum = 0; shnum < ehdr->e_shnum; shnum++) { if (shdr[shnum].sh_type == SHT_REL) { - ok = do_Elf_Rel_relocations ( oc, ehdrC, shdr, - shnum, stab, strtab ); + ok = do_Elf_Rel_relocations ( oc, ehdrC, shdr, shnum ); if (!ok) return ok; } else if (shdr[shnum].sh_type == SHT_RELA) { - ok = do_Elf_Rela_relocations ( oc, ehdrC, shdr, - shnum, stab, strtab ); + ok = do_Elf_Rela_relocations ( oc, ehdrC, shdr, shnum ); if (!ok) return ok; } } @@ -4368,8 +4530,12 @@ if( i == ehdr->e_shnum ) { - errorBelch( "This ELF file contains no symtab" ); - return 0; + // Not having a symbol table is not in principle a problem. + // When an object file has no symbols then the 'strip' program + // typically will remove the symbol table entirely. + IF_DEBUG(linker, debugBelch( "The ELF file %s contains no symtab\n", + oc->archiveMemberName ? oc->archiveMemberName : oc->fileName )); + return 1; } if( shdr[i].sh_entsize != sizeof( Elf_Sym ) ) @@ -4411,79 +4577,100 @@ #endif #ifdef powerpc_HOST_ARCH -static int ocAllocateSymbolExtras_MachO(ObjectCode* oc) +static int +ocAllocateSymbolExtras_MachO(ObjectCode* oc) { struct mach_header *header = (struct mach_header *) oc->image; struct load_command *lc = (struct load_command *) (header + 1); unsigned i; - for( i = 0; i < header->ncmds; i++ ) - { - if( lc->cmd == LC_SYMTAB ) - { + IF_DEBUG(linker, debugBelch("ocAllocateSymbolExtras_MachO: start\n")); + + for (i = 0; i < header->ncmds; i++) { + if (lc->cmd == LC_SYMTAB) { + // Find out the first and last undefined external // symbol, so we don't have to allocate too many - // jump islands. + // jump islands/GOT entries. + struct symtab_command *symLC = (struct symtab_command *) lc; unsigned min = symLC->nsyms, max = 0; struct nlist *nlist = symLC ? (struct nlist*) ((char*) oc->image + symLC->symoff) : NULL; - for(i=0;insyms;i++) - { - if(nlist[i].n_type & N_STAB) + + for (i = 0; i < symLC->nsyms; i++) { + + if (nlist[i].n_type & N_STAB) { ; - else if(nlist[i].n_type & N_EXT) - { + } else if (nlist[i].n_type & N_EXT) { + if((nlist[i].n_type & N_TYPE) == N_UNDF - && (nlist[i].n_value == 0)) - { - if(i < min) + && (nlist[i].n_value == 0)) { + + if (i < min) { min = i; - if(i > max) + } + + if (i > max) { max = i; } } } - if(max >= min) + } + + if (max >= min) { return ocAllocateSymbolExtras(oc, max - min + 1, min); + } break; } lc = (struct load_command *) ( ((char *)lc) + lc->cmdsize ); } + return ocAllocateSymbolExtras(oc,0,0); } + #endif #ifdef x86_64_HOST_ARCH -static int ocAllocateSymbolExtras_MachO(ObjectCode* oc) +static int +ocAllocateSymbolExtras_MachO(ObjectCode* oc) { struct mach_header *header = (struct mach_header *) oc->image; struct load_command *lc = (struct load_command *) (header + 1); unsigned i; - for( i = 0; i < header->ncmds; i++ ) - { - if( lc->cmd == LC_SYMTAB ) - { + IF_DEBUG(linker, debugBelch("ocAllocateSymbolExtras_MachO: start\n")); + + for (i = 0; i < header->ncmds; i++) { + if (lc->cmd == LC_SYMTAB) { + // Just allocate one entry for every symbol struct symtab_command *symLC = (struct symtab_command *) lc; + IF_DEBUG(linker, debugBelch("ocAllocateSymbolExtras_MachO: allocate %d symbols\n", symLC->nsyms)); + IF_DEBUG(linker, debugBelch("ocAllocateSymbolExtras_MachO: done\n")); return ocAllocateSymbolExtras(oc, symLC->nsyms, 0); } lc = (struct load_command *) ( ((char *)lc) + lc->cmdsize ); } + + IF_DEBUG(linker, debugBelch("ocAllocateSymbolExtras_MachO: allocated no symbols\n")); + IF_DEBUG(linker, debugBelch("ocAllocateSymbolExtras_MachO: done\n")); return ocAllocateSymbolExtras(oc,0,0); } #endif -static int ocVerifyImage_MachO(ObjectCode* oc) +static int +ocVerifyImage_MachO(ObjectCode * oc) { char *image = (char*) oc->image; struct mach_header *header = (struct mach_header*) image; + IF_DEBUG(linker, debugBelch("ocVerifyImage_MachO: start\n")); + #if x86_64_HOST_ARCH || powerpc64_HOST_ARCH if(header->magic != MH_MAGIC_64) { errorBelch("%s: Bad magic. Expected: %08x, got: %08x.\n", @@ -4497,11 +4684,14 @@ return 0; } #endif + // FIXME: do some more verifying here + IF_DEBUG(linker, debugBelch("ocVerifyImage_MachO: done\n")); return 1; } -static int resolveImports( +static int +resolveImports( ObjectCode* oc, char *image, struct symtab_command *symLC, @@ -4516,12 +4706,13 @@ #if i386_HOST_ARCH int isJumpTable = 0; - if(!strcmp(sect->sectname,"__jump_table")) - { + + if (strcmp(sect->sectname,"__jump_table") == 0) { isJumpTable = 1; itemSize = 5; ASSERT(sect->reserved2 == itemSize); } + #endif for(i=0; i*itemSize < sect->size;i++) @@ -4532,6 +4723,7 @@ void *addr = NULL; IF_DEBUG(linker, debugBelch("resolveImports: resolving %s\n", nm)); + if ((symbol->n_type & N_TYPE) == N_UNDF && (symbol->n_type & N_EXT) && (symbol->n_value != 0)) { addr = (void*) (symbol->n_value); @@ -4548,10 +4740,10 @@ ASSERT(addr); #if i386_HOST_ARCH - if(isJumpTable) - { + if (isJumpTable) { checkProddableBlock(oc,image + sect->offset + i*itemSize); - *(image + sect->offset + i*itemSize) = 0xe9; // jmp + + *(image + sect->offset + i * itemSize) = 0xe9; // jmp opcode *(unsigned*)(image + sect->offset + i*itemSize + 1) = (char*)addr - (image + sect->offset + i*itemSize + 5); } @@ -4771,10 +4963,9 @@ // and use #ifdefs for the other types. // Step 1: Figure out what the relocated value should be - if(scat->r_type == GENERIC_RELOC_VANILLA) - { - word = *wordPtr + (unsigned long) relocateAddress( - oc, + if (scat->r_type == GENERIC_RELOC_VANILLA) { + word = *wordPtr + + (unsigned long) relocateAddress(oc, nSections, sections, scat->r_value) @@ -4794,9 +4985,10 @@ struct scattered_relocation_info *pair = (struct scattered_relocation_info*) &relocs[i+1]; - if(!pair->r_scattered || pair->r_type != GENERIC_RELOC_PAIR) + if (!pair->r_scattered || pair->r_type != GENERIC_RELOC_PAIR) { barf("Invalid Mach-O file: " "RELOC_*_SECTDIFF not followed by RELOC_PAIR"); + } word = (unsigned long) (relocateAddress(oc, nSections, sections, scat->r_value) @@ -4810,9 +5002,11 @@ || scat->r_type == PPC_RELOC_LO14) { // these are generated by label+offset things struct relocation_info *pair = &relocs[i+1]; - if((pair->r_address & R_SCATTERED) || pair->r_type != PPC_RELOC_PAIR) + + if ((pair->r_address & R_SCATTERED) || pair->r_type != PPC_RELOC_PAIR) { barf("Invalid Mach-O file: " "PPC_RELOC_* not followed by PPC_RELOC_PAIR"); + } if(scat->r_type == PPC_RELOC_LO16) { @@ -4843,8 +5037,7 @@ i++; } #endif - else - { + else { barf ("Don't know how to handle this Mach-O " "scattered relocation entry: " "object file %s; entry type %ld; " @@ -4867,15 +5060,18 @@ *wordPtr = word; } #ifdef powerpc_HOST_ARCH - else if(scat->r_type == PPC_RELOC_LO16_SECTDIFF || scat->r_type == PPC_RELOC_LO16) + else if (scat->r_type == PPC_RELOC_LO16_SECTDIFF + || scat->r_type == PPC_RELOC_LO16) { ((unsigned short*) wordPtr)[1] = word & 0xFFFF; } - else if(scat->r_type == PPC_RELOC_HI16_SECTDIFF || scat->r_type == PPC_RELOC_HI16) + else if (scat->r_type == PPC_RELOC_HI16_SECTDIFF + || scat->r_type == PPC_RELOC_HI16) { ((unsigned short*) wordPtr)[1] = (word >> 16) & 0xFFFF; } - else if(scat->r_type == PPC_RELOC_HA16_SECTDIFF || scat->r_type == PPC_RELOC_HA16) + else if (scat->r_type == PPC_RELOC_HA16_SECTDIFF + || scat->r_type == PPC_RELOC_HA16) { ((unsigned short*) wordPtr)[1] = ((word >> 16) & 0xFFFF) + ((word & (1<<15)) ? 1 : 0); @@ -4910,11 +5106,12 @@ else /* !(relocs[i].r_address & R_SCATTERED) */ { struct relocation_info *reloc = &relocs[i]; - if(reloc->r_pcrel && !reloc->r_extern) + if (reloc->r_pcrel && !reloc->r_extern) { + IF_DEBUG(linker, debugBelch("relocateSection: pc relative but not external, skipping\n")); continue; + } - if(reloc->r_length == 2) - { + if (reloc->r_length == 2) { unsigned long word = 0; #ifdef powerpc_HOST_ARCH unsigned long jumpIsland = 0; @@ -4926,34 +5123,28 @@ unsigned long* wordPtr = (unsigned long*) (image + sect->offset + reloc->r_address); checkProddableBlock(oc,wordPtr); - if(reloc->r_type == GENERIC_RELOC_VANILLA) - { + if (reloc->r_type == GENERIC_RELOC_VANILLA) { word = *wordPtr; } #ifdef powerpc_HOST_ARCH - else if(reloc->r_type == PPC_RELOC_LO16) - { + else if (reloc->r_type == PPC_RELOC_LO16) { word = ((unsigned short*) wordPtr)[1]; word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF) << 16; } - else if(reloc->r_type == PPC_RELOC_HI16) - { + else if (reloc->r_type == PPC_RELOC_HI16) { word = ((unsigned short*) wordPtr)[1] << 16; word |= ((unsigned long) relocs[i+1].r_address & 0xFFFF); } - else if(reloc->r_type == PPC_RELOC_HA16) - { + else if (reloc->r_type == PPC_RELOC_HA16) { word = ((unsigned short*) wordPtr)[1] << 16; word += ((short)relocs[i+1].r_address & (short)0xFFFF); } - else if(reloc->r_type == PPC_RELOC_BR24) - { + else if (reloc->r_type == PPC_RELOC_BR24) { word = *wordPtr; word = (word & 0x03FFFFFC) | ((word & 0x02000000) ? 0xFC000000 : 0); } #endif - else - { + else { barf("Can't handle this Mach-O relocation entry " "(not scattered): " "object file %s; entry type %ld; address %#lx\n", @@ -4963,28 +5154,24 @@ return 0; } - if(!reloc->r_extern) - { - long delta = - sections[reloc->r_symbolnum-1].offset + if (!reloc->r_extern) { + long delta = sections[reloc->r_symbolnum-1].offset - sections[reloc->r_symbolnum-1].addr + ((long) image); word += delta; } - else - { + else { struct nlist *symbol = &nlist[reloc->r_symbolnum]; char *nm = image + symLC->stroff + symbol->n_un.n_strx; void *symbolAddress = lookupSymbol(nm); - if(!symbolAddress) - { + + if (!symbolAddress) { errorBelch("\nunknown symbol `%s'", nm); return 0; } - if(reloc->r_pcrel) - { + if (reloc->r_pcrel) { #ifdef powerpc_HOST_ARCH // In the .o file, this should be a relative jump to NULL // and we'll change it to a relative jump to the symbol @@ -4994,8 +5181,7 @@ reloc->r_symbolnum, (unsigned long) symbolAddress) -> jumpIsland; - if(jumpIsland != 0) - { + if (jumpIsland != 0) { offsetToJumpIsland = word + jumpIsland - (((long)image) + sect->offset - sect->addr); } @@ -5003,14 +5189,12 @@ word += (unsigned long) symbolAddress - (((long)image) + sect->offset - sect->addr); } - else - { + else { word += (unsigned long) symbolAddress; } } - if(reloc->r_type == GENERIC_RELOC_VANILLA) - { + if (reloc->r_type == GENERIC_RELOC_VANILLA) { *wordPtr = word; continue; } @@ -5018,34 +5202,36 @@ else if(reloc->r_type == PPC_RELOC_LO16) { ((unsigned short*) wordPtr)[1] = word & 0xFFFF; - i++; continue; + i++; + continue; } else if(reloc->r_type == PPC_RELOC_HI16) { ((unsigned short*) wordPtr)[1] = (word >> 16) & 0xFFFF; - i++; continue; + i++; + continue; } else if(reloc->r_type == PPC_RELOC_HA16) { ((unsigned short*) wordPtr)[1] = ((word >> 16) & 0xFFFF) + ((word & (1<<15)) ? 1 : 0); - i++; continue; + i++; + continue; } else if(reloc->r_type == PPC_RELOC_BR24) { - if((word & 0x03) != 0) + if ((word & 0x03) != 0) { barf("%s: unconditional relative branch with a displacement " "which isn't a multiple of 4 bytes: %#lx", OC_INFORMATIVE_FILENAME(oc), word); + } if((word & 0xFE000000) != 0xFE000000 && - (word & 0xFE000000) != 0x00000000) - { + (word & 0xFE000000) != 0x00000000) { // The branch offset is too large. // Therefore, we try to use a jump island. - if(jumpIsland == 0) - { + if (jumpIsland == 0) { barf("%s: unconditional relative branch out of range: " "no jump island available: %#lx", OC_INFORMATIVE_FILENAME(oc), @@ -5053,13 +5239,15 @@ } word = offsetToJumpIsland; + if((word & 0xFE000000) != 0xFE000000 && - (word & 0xFE000000) != 0x00000000) + (word & 0xFE000000) != 0x00000000) { barf("%s: unconditional relative branch out of range: " "jump island out of range: %#lx", OC_INFORMATIVE_FILENAME(oc), word); } + } *wordPtr = (*wordPtr & 0xFC000003) | (word & 0x03FFFFFC); continue; } @@ -5080,11 +5268,13 @@ } #endif } + IF_DEBUG(linker, debugBelch("relocateSection: done\n")); return 1; } -static int ocGetNames_MachO(ObjectCode* oc) +static int +ocGetNames_MachO(ObjectCode* oc) { char *image = (char*) oc->image; struct mach_header *header = (struct mach_header*) image; @@ -5102,10 +5292,13 @@ for(i=0;incmds;i++) { - if(lc->cmd == LC_SEGMENT || lc->cmd == LC_SEGMENT_64) + if (lc->cmd == LC_SEGMENT || lc->cmd == LC_SEGMENT_64) { segLC = (struct segment_command*) lc; - else if(lc->cmd == LC_SYMTAB) + } + else if (lc->cmd == LC_SYMTAB) { symLC = (struct symtab_command*) lc; + } + lc = (struct load_command *) ( ((char*)lc) + lc->cmdsize ); } @@ -5113,14 +5306,19 @@ nlist = symLC ? (struct nlist*) (image + symLC->symoff) : NULL; - if(!segLC) + if (!segLC) { barf("ocGetNames_MachO: no segment load command"); + } + IF_DEBUG(linker, debugBelch("ocGetNames_MachO: will load %d sections\n", segLC->nsects)); for(i=0;insects;i++) { - IF_DEBUG(linker, debugBelch("ocGetNames_MachO: segment %d\n", i)); - if (sections[i].size == 0) + IF_DEBUG(linker, debugBelch("ocGetNames_MachO: section %d\n", i)); + + if (sections[i].size == 0) { + IF_DEBUG(linker, debugBelch("ocGetNames_MachO: found a zero length section, skipping\n")); continue; + } if((sections[i].flags & SECTION_TYPE) == S_ZEROFILL) { @@ -5129,36 +5327,47 @@ sections[i].offset = zeroFillArea - image; } - if(!strcmp(sections[i].sectname,"__text")) + if (!strcmp(sections[i].sectname,"__text")) { + + IF_DEBUG(linker, debugBelch("ocGetNames_MachO: adding __text section\n")); addSection(oc, SECTIONKIND_CODE_OR_RODATA, (void*) (image + sections[i].offset), (void*) (image + sections[i].offset + sections[i].size)); - else if(!strcmp(sections[i].sectname,"__const")) + } + else if (!strcmp(sections[i].sectname,"__const")) { + + IF_DEBUG(linker, debugBelch("ocGetNames_MachO: adding __const section\n")); addSection(oc, SECTIONKIND_RWDATA, (void*) (image + sections[i].offset), (void*) (image + sections[i].offset + sections[i].size)); - else if(!strcmp(sections[i].sectname,"__data")) + } + else if (!strcmp(sections[i].sectname,"__data")) { + + IF_DEBUG(linker, debugBelch("ocGetNames_MachO: adding __data section\n")); addSection(oc, SECTIONKIND_RWDATA, (void*) (image + sections[i].offset), (void*) (image + sections[i].offset + sections[i].size)); + } else if(!strcmp(sections[i].sectname,"__bss") - || !strcmp(sections[i].sectname,"__common")) + || !strcmp(sections[i].sectname,"__common")) { + + IF_DEBUG(linker, debugBelch("ocGetNames_MachO: adding __bss section\n")); addSection(oc, SECTIONKIND_RWDATA, (void*) (image + sections[i].offset), (void*) (image + sections[i].offset + sections[i].size)); - - addProddableBlock(oc, (void*) (image + sections[i].offset), + } + addProddableBlock(oc, + (void *) (image + sections[i].offset), sections[i].size); } // count external symbols defined here oc->n_symbols = 0; - if(symLC) - { - for(i=0;insyms;i++) - { - if(nlist[i].n_type & N_STAB) + if (symLC) { + for (i = 0; i < symLC->nsyms; i++) { + if (nlist[i].n_type & N_STAB) { ; + } else if(nlist[i].n_type & N_EXT) { if((nlist[i].n_type & N_TYPE) == N_UNDF @@ -5202,19 +5411,27 @@ oc->symbols[curSymbol++] = nm; } } + else + { + IF_DEBUG(linker, debugBelch("ocGetNames_MachO: \t...not external, skipping\n")); + } + } + else + { + IF_DEBUG(linker, debugBelch("ocGetNames_MachO: \t...not defined in this section, skipping\n")); } } } commonStorage = stgCallocBytes(1,commonSize,"ocGetNames_MachO(common symbols)"); commonCounter = (unsigned long)commonStorage; - if(symLC) - { - for(i=0;insyms;i++) - { + + if (symLC) { + for (i = 0; i < symLC->nsyms; i++) { if((nlist[i].n_type & N_TYPE) == N_UNDF - && (nlist[i].n_type & N_EXT) && (nlist[i].n_value != 0)) - { + && (nlist[i].n_type & N_EXT) + && (nlist[i].n_value != 0)) { + char *nm = image + symLC->stroff + nlist[i].n_un.n_strx; unsigned long sz = nlist[i].n_value; @@ -5229,10 +5446,13 @@ } } } + + IF_DEBUG(linker, debugBelch("ocGetNames_MachO: done\n")); return 1; } -static int ocResolve_MachO(ObjectCode* oc) +static int +ocResolve_MachO(ObjectCode* oc) { char *image = (char*) oc->image; struct mach_header *header = (struct mach_header*) image; @@ -5247,12 +5467,19 @@ IF_DEBUG(linker, debugBelch("ocResolve_MachO: start\n")); for (i = 0; i < header->ncmds; i++) { - if(lc->cmd == LC_SEGMENT || lc->cmd == LC_SEGMENT_64) + if (lc->cmd == LC_SEGMENT || lc->cmd == LC_SEGMENT_64) { segLC = (struct segment_command*) lc; - else if(lc->cmd == LC_SYMTAB) + IF_DEBUG(linker, debugBelch("ocResolve_MachO: found a 32 or 64 bit segment load command\n")); + } + else if (lc->cmd == LC_SYMTAB) { symLC = (struct symtab_command*) lc; - else if(lc->cmd == LC_DYSYMTAB) + IF_DEBUG(linker, debugBelch("ocResolve_MachO: found a symbol table load command\n")); + } + else if (lc->cmd == LC_DYSYMTAB) { dsymLC = (struct dysymtab_command*) lc; + IF_DEBUG(linker, debugBelch("ocResolve_MachO: found a dynamic symbol table load command\n")); + } + lc = (struct load_command *) ( ((char*)lc) + lc->cmdsize ); } @@ -5320,7 +5547,8 @@ extern void* symbolsWithoutUnderscore[]; -static void machoInitSymbolsWithoutUnderscore() +static void +machoInitSymbolsWithoutUnderscore(void) { void **p = symbolsWithoutUnderscore; __asm__ volatile(".globl _symbolsWithoutUnderscore\n.data\n_symbolsWithoutUnderscore:"); @@ -5348,7 +5576,8 @@ * Figure out by how much to shift the entire Mach-O file in memory * when loading so that its single segment ends up 16-byte-aligned */ -static int machoGetMisalignment( FILE * f ) +static int +machoGetMisalignment( FILE * f ) { struct mach_header header; int misalignment; diff -Nru ghc-7.0.3/rts/Main.c ghc-7.2.1/rts/Main.c --- ghc-7.0.3/rts/Main.c 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/rts/Main.c 2011-08-07 17:10:05.000000000 +0000 @@ -15,16 +15,10 @@ #include "Rts.h" #include "RtsMain.h" -/* The symbol for the Haskell Main module's init function. It is safe to refer - * to it here because this Main.o object file will only be linked in if we are - * linking a Haskell program that uses a Haskell Main.main function. - */ -extern void __stginit_ZCMain(void); - /* Similarly, we can refer to the ZCMain_main_closure here */ extern StgClosure ZCMain_main_closure; int main(int argc, char *argv[]) { - return hs_main(argc, argv, &__stginit_ZCMain, &ZCMain_main_closure); + return hs_main(argc, argv, &ZCMain_main_closure); } diff -Nru ghc-7.0.3/rts/Messages.c ghc-7.2.1/rts/Messages.c --- ghc-7.0.3/rts/Messages.c 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/rts/Messages.c 2011-08-07 17:10:05.000000000 +0000 @@ -98,11 +98,13 @@ r = throwToMsg(cap, t); switch (r) { - case THROWTO_SUCCESS: + case THROWTO_SUCCESS: { // this message is done - unlockClosure((StgClosure*)m, &stg_MSG_NULL_info); - tryWakeupThread(cap, t->source); + StgTSO *source = t->source; + doneWithMsgThrowTo(t); + tryWakeupThread(cap, source); break; + } case THROWTO_BLOCKED: // unlock the message unlockClosure((StgClosure*)m, &stg_MSG_THROWTO_info); @@ -203,7 +205,7 @@ else if (info == &stg_TSO_info) { - owner = deRefTSO((StgTSO *)p); + owner = (StgTSO*)p; #ifdef THREADED_RTS if (owner->cap != cap) { @@ -265,7 +267,7 @@ ASSERT(bq->bh == bh); - owner = deRefTSO(bq->owner); + owner = bq->owner; ASSERT(owner != END_TSO_QUEUE); @@ -301,3 +303,46 @@ return 0; // not blocked } +// A shorter version of messageBlackHole(), that just returns the +// owner (or NULL if the owner cannot be found, because the blackhole +// has been updated in the meantime). + +StgTSO * blackHoleOwner (StgClosure *bh) +{ + const StgInfoTable *info; + StgClosure *p; + + info = bh->header.info; + + if (info != &stg_BLACKHOLE_info && + info != &stg_CAF_BLACKHOLE_info && + info != &__stg_EAGER_BLACKHOLE_info && + info != &stg_WHITEHOLE_info) { + return NULL; + } + + // The blackhole must indirect to a TSO, a BLOCKING_QUEUE, an IND, + // or a value. +loop: + // NB. VOLATILE_LOAD(), because otherwise gcc hoists the load + // and turns this into an infinite loop. + p = UNTAG_CLOSURE((StgClosure*)VOLATILE_LOAD(&((StgInd*)bh)->indirectee)); + info = p->header.info; + + if (info == &stg_IND_info) goto loop; + + else if (info == &stg_TSO_info) + { + return (StgTSO*)p; + } + else if (info == &stg_BLOCKING_QUEUE_CLEAN_info || + info == &stg_BLOCKING_QUEUE_DIRTY_info) + { + StgBlockingQueue *bq = (StgBlockingQueue *)p; + return bq->owner; + } + + return NULL; // not blocked +} + + diff -Nru ghc-7.0.3/rts/Messages.h ghc-7.2.1/rts/Messages.h --- ghc-7.0.3/rts/Messages.h 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/rts/Messages.h 2011-08-07 17:10:05.000000000 +0000 @@ -9,10 +9,22 @@ #include "BeginPrivate.h" nat messageBlackHole(Capability *cap, MessageBlackHole *msg); +StgTSO * blackHoleOwner (StgClosure *bh); #ifdef THREADED_RTS void executeMessage (Capability *cap, Message *m); void sendMessage (Capability *from_cap, Capability *to_cap, Message *msg); #endif +#include "Capability.h" +#include "Updates.h" // for DEBUG_FILL_SLOP + +INLINE_HEADER void +doneWithMsgThrowTo (MessageThrowTo *m) +{ + OVERWRITING_CLOSURE((StgClosure*)m); + unlockClosure((StgClosure*)m, &stg_MSG_NULL_info); + LDV_RECORD_CREATE(m); +} + #include "EndPrivate.h" diff -Nru ghc-7.0.3/rts/package.conf.in ghc-7.2.1/rts/package.conf.in --- ghc-7.0.3/rts/package.conf.in 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/rts/package.conf.in 2011-08-07 17:10:05.000000000 +0000 @@ -83,8 +83,8 @@ , "-u", "_base_GHCziPtr_Ptr_con_info" , "-u", "_base_GHCziPtr_FunPtr_con_info" , "-u", "_base_GHCziStable_StablePtr_con_info" - , "-u", "_ghczmprim_GHCziBool_False_closure" - , "-u", "_ghczmprim_GHCziBool_True_closure" + , "-u", "_ghczmprim_GHCziTypes_False_closure" + , "-u", "_ghczmprim_GHCziTypes_True_closure" , "-u", "_base_GHCziPack_unpackCString_closure" , "-u", "_base_GHCziIOziException_stackOverflow_closure" , "-u", "_base_GHCziIOziException_heapOverflow_closure" @@ -121,8 +121,8 @@ , "-u", "base_GHCziPtr_Ptr_con_info" , "-u", "base_GHCziPtr_FunPtr_con_info" , "-u", "base_GHCziStable_StablePtr_con_info" - , "-u", "ghczmprim_GHCziBool_False_closure" - , "-u", "ghczmprim_GHCziBool_True_closure" + , "-u", "ghczmprim_GHCziTypes_False_closure" + , "-u", "ghczmprim_GHCziTypes_True_closure" , "-u", "base_GHCziPack_unpackCString_closure" , "-u", "base_GHCziIOziException_stackOverflow_closure" , "-u", "base_GHCziIOziException_heapOverflow_closure" diff -Nru ghc-7.0.3/rts/package.conf.inplace.raw ghc-7.2.1/rts/package.conf.inplace.raw --- ghc-7.0.3/rts/package.conf.inplace.raw 2011-03-26 18:12:59.000000000 +0000 +++ ghc-7.2.1/rts/package.conf.inplace.raw 2011-08-07 17:26:55.000000000 +0000 @@ -422,6 +422,9 @@ + + + name: rts version: 1.0 id: builtin_rts @@ -473,8 +476,8 @@ , "-u", "base_GHCziPtr_Ptr_con_info" , "-u", "base_GHCziPtr_FunPtr_con_info" , "-u", "base_GHCziStable_StablePtr_con_info" - , "-u", "ghczmprim_GHCziBool_False_closure" - , "-u", "ghczmprim_GHCziBool_True_closure" + , "-u", "ghczmprim_GHCziTypes_False_closure" + , "-u", "ghczmprim_GHCziTypes_True_closure" , "-u", "base_GHCziPack_unpackCString_closure" , "-u", "base_GHCziIOziException_stackOverflow_closure" , "-u", "base_GHCziIOziException_heapOverflow_closure" diff -Nru ghc-7.0.3/rts/posix/FileLock.c ghc-7.2.1/rts/posix/FileLock.c --- ghc-7.0.3/rts/posix/FileLock.c 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/rts/posix/FileLock.c 2011-08-07 17:10:05.000000000 +0000 @@ -2,7 +2,7 @@ * * (c) The GHC Team, 2007 * - * File locking support as required by Haskell 98 + * File locking support as required by Haskell * * ---------------------------------------------------------------------------*/ diff -Nru ghc-7.0.3/rts/posix/FileLock.h ghc-7.2.1/rts/posix/FileLock.h --- ghc-7.0.3/rts/posix/FileLock.h 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/rts/posix/FileLock.h 2011-08-07 17:10:05.000000000 +0000 @@ -2,7 +2,7 @@ * * (c) The GHC Team, 2007 * - * File locking support as required by Haskell 98 + * File locking support as required by Haskell * * ---------------------------------------------------------------------------*/ diff -Nru ghc-7.0.3/rts/posix/GetEnv.c ghc-7.2.1/rts/posix/GetEnv.c --- ghc-7.0.3/rts/posix/GetEnv.c 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/rts/posix/GetEnv.c 2011-08-07 17:10:05.000000000 +0000 @@ -0,0 +1,44 @@ +/* ----------------------------------------------------------------------------- + * + * (c) The GHC Team 2011 + * + * Access to the process environment variables + * + * ---------------------------------------------------------------------------*/ + +#include "Rts.h" +#include "GetEnv.h" + +#if defined(darwin_HOST_OS) + +/* While the "extern char** environ" var does exist on OSX, it is not + * available to shared libs. See ghc ticket #2458 and + * http://developer.apple.com/library/mac/#documentation/Darwin/Reference/ManPages/man7/environ.7.html + */ +#include + +static char** get_environ(void) { return *(_NSGetEnviron()); } + +#else + +/* On proper unix systems the environ is just a global var. + */ +extern char** environ; +static char** get_environ(void) { return environ; } + +#endif + + +void getProgEnvv(int *out_envc, char **out_envv[]) { + int envc; + char **environ = get_environ(); + + for (envc = 0; environ[envc] != NULL; envc++) {}; + + *out_envc = envc; + *out_envv = environ; +} + +void freeProgEnvv(int envc STG_UNUSED, char *envv[] STG_UNUSED) { + /* nothing */ +} diff -Nru ghc-7.0.3/rts/posix/OSThreads.c ghc-7.2.1/rts/posix/OSThreads.c --- ghc-7.0.3/rts/posix/OSThreads.c 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/rts/posix/OSThreads.c 2011-08-07 17:10:05.000000000 +0000 @@ -7,7 +7,7 @@ * * --------------------------------------------------------------------------*/ -#if defined(__linux__) +#if defined(__linux__) || defined(__GLIBC__) /* We want GNU extensions in DEBUG mode for mutex error checking */ /* We also want the affinity API, which requires _GNU_SOURCE */ #define _GNU_SOURCE @@ -57,6 +57,10 @@ #include #endif +#ifdef HAVE_SIGNAL_H +# include +#endif + /* * This (allegedly) OS threads independent layer was initially * abstracted away from code that used Pthreads, so the functions @@ -290,6 +294,12 @@ } #endif +void +interruptOSThread (OSThreadId id) +{ + pthread_kill(id, SIGPIPE); +} + #else /* !defined(THREADED_RTS) */ int diff -Nru ghc-7.0.3/rts/posix/Select.c ghc-7.2.1/rts/posix/Select.c --- ghc-7.0.3/rts/posix/Select.c 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/rts/posix/Select.c 2011-08-07 17:10:05.000000000 +0000 @@ -63,10 +63,6 @@ while (sleeping_queue != END_TSO_QUEUE) { tso = sleeping_queue; - if (tso->what_next == ThreadRelocated) { - sleeping_queue = tso->_link; - continue; - } if (((long)ticks - (long)tso->block_info.target) < 0) { break; } @@ -259,11 +255,7 @@ for(tso = blocked_queue_hd; tso != END_TSO_QUEUE; tso = next) { next = tso->_link; - if (tso->what_next == ThreadRelocated) { - continue; - } - - switch (tso->why_blocked) { + switch (tso->why_blocked) { case BlockedOnRead: ready = unblock_all || FD_ISSET(tso->block_info.fd, &rfd); break; diff -Nru ghc-7.0.3/rts/posix/Signals.c ghc-7.2.1/rts/posix/Signals.c --- ghc-7.0.3/rts/posix/Signals.c 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/rts/posix/Signals.c 2011-08-07 17:10:05.000000000 +0000 @@ -101,7 +101,7 @@ setIOManagerWakeupFd (int fd) { // only called when THREADED_RTS, but unconditionally - // compiled here because System.Event.Control depends on it. + // compiled here because GHC.Event.Control depends on it. io_manager_wakeup_fd = fd; } @@ -109,7 +109,7 @@ setIOManagerControlFd (int fd) { // only called when THREADED_RTS, but unconditionally - // compiled here because System.Event.Control depends on it. + // compiled here because GHC.Event.Control depends on it. io_manager_control_fd = fd; } diff -Nru ghc-7.0.3/rts/Prelude.h ghc-7.2.1/rts/Prelude.h --- ghc-7.0.3/rts/Prelude.h 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/rts/Prelude.h 2011-08-07 17:10:05.000000000 +0000 @@ -24,8 +24,8 @@ * modules these names are defined in. */ -PRELUDE_CLOSURE(ghczmprim_GHCziBool_True_closure); -PRELUDE_CLOSURE(ghczmprim_GHCziBool_False_closure); +PRELUDE_CLOSURE(ghczmprim_GHCziTypes_True_closure); +PRELUDE_CLOSURE(ghczmprim_GHCziTypes_False_closure); PRELUDE_CLOSURE(base_GHCziPack_unpackCString_closure); PRELUDE_CLOSURE(base_GHCziWeak_runFinalizzerBatch_closure); @@ -82,8 +82,8 @@ PRELUDE_INFO(base_GHCziStable_StablePtr_static_info); PRELUDE_INFO(base_GHCziStable_StablePtr_con_info); -#define True_closure DLL_IMPORT_DATA_REF(ghczmprim_GHCziBool_True_closure) -#define False_closure DLL_IMPORT_DATA_REF(ghczmprim_GHCziBool_False_closure) +#define True_closure DLL_IMPORT_DATA_REF(ghczmprim_GHCziTypes_True_closure) +#define False_closure DLL_IMPORT_DATA_REF(ghczmprim_GHCziTypes_False_closure) #define unpackCString_closure DLL_IMPORT_DATA_REF(base_GHCziPack_unpackCString_closure) #define runFinalizerBatch_closure DLL_IMPORT_DATA_REF(base_GHCziWeak_runFinalizzerBatch_closure) #define mainIO_closure (&ZCMain_main_closure) diff -Nru ghc-7.0.3/rts/PrimOps.cmm ghc-7.2.1/rts/PrimOps.cmm --- ghc-7.0.3/rts/PrimOps.cmm 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/rts/PrimOps.cmm 2011-08-07 17:10:05.000000000 +0000 @@ -34,7 +34,7 @@ import base_ControlziExceptionziBase_nestedAtomically_closure; import EnterCriticalSection; import LeaveCriticalSection; -import ghczmprim_GHCziBool_False_closure; +import ghczmprim_GHCziTypes_False_closure; #if !defined(mingw32_HOST_OS) import sm_mutex; #endif @@ -212,6 +212,7 @@ } } + /* ----------------------------------------------------------------------------- MutVar primitives -------------------------------------------------------------------------- */ @@ -230,6 +231,25 @@ RET_P(mv); } +stg_casMutVarzh + /* MutVar# s a -> a -> a -> State# s -> (# State#, Int#, a #) */ +{ + W_ mv, old, new, h; + + mv = R1; + old = R2; + new = R3; + + (h) = foreign "C" cas(mv + SIZEOF_StgHeader + OFFSET_StgMutVar_var, + old, new) []; + if (h != old) { + RET_NP(1,h); + } else { + RET_NP(0,h); + } +} + + stg_atomicModifyMutVarzh { W_ mv, f, z, x, y, r, h; @@ -631,14 +651,9 @@ W_ tso; W_ why_blocked; W_ what_next; - W_ ret; + W_ ret, cap, locked; tso = R1; - loop: - if (TO_W_(StgTSO_what_next(tso)) == ThreadRelocated) { - tso = StgTSO__link(tso); - goto loop; - } what_next = TO_W_(StgTSO_what_next(tso)); why_blocked = TO_W_(StgTSO_why_blocked(tso)); @@ -656,7 +671,16 @@ ret = why_blocked; } } - RET_N(ret); + + cap = TO_W_(Capability_no(StgTSO_cap(tso))); + + if ((TO_W_(StgTSO_flags(tso)) & TSO_LOCKED) != 0) { + locked = 1; + } else { + locked = 0; + } + + RET_NNN(ret,cap,locked); } /* ----------------------------------------------------------------------------- @@ -939,9 +963,9 @@ // Find the enclosing ATOMICALLY_FRAME or CATCH_RETRY_FRAME retry_pop_stack: - StgTSO_sp(CurrentTSO) = Sp; - (frame_type) = foreign "C" findRetryFrameHelper(CurrentTSO "ptr") []; - Sp = StgTSO_sp(CurrentTSO); + SAVE_THREAD_STATE(); + (frame_type) = foreign "C" findRetryFrameHelper(MyCapability(), CurrentTSO "ptr") []; + LOAD_THREAD_STATE(); frame = Sp; trec = StgTSO_trec(CurrentTSO); outer = StgTRecHeader_enclosing_trec(trec); @@ -1138,13 +1162,17 @@ } -#define PerformTake(tso, value) \ - W_[StgTSO_sp(tso) + WDS(1)] = value; \ - W_[StgTSO_sp(tso) + WDS(0)] = stg_gc_unpt_r1_info; - -#define PerformPut(tso,lval) \ - StgTSO_sp(tso) = StgTSO_sp(tso) + WDS(3); \ - lval = W_[StgTSO_sp(tso) - WDS(1)]; +#define PerformTake(stack, value) \ + W_ sp; \ + sp = StgStack_sp(stack); \ + W_[sp + WDS(1)] = value; \ + W_[sp + WDS(0)] = stg_gc_unpt_r1_info; + +#define PerformPut(stack,lval) \ + W_ sp; \ + sp = StgStack_sp(stack) + WDS(3); \ + StgStack_sp(stack) = sp; \ + lval = W_[sp - WDS(1)]; stg_takeMVarzh { @@ -1224,24 +1252,20 @@ StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure; } -loop2: - if (TO_W_(StgTSO_what_next(tso)) == ThreadRelocated) { - tso = StgTSO__link(tso); - goto loop2; - } - ASSERT(StgTSO_why_blocked(tso) == BlockedOnMVar::I16); ASSERT(StgTSO_block_info(tso) == mvar); // actually perform the putMVar for the thread that we just woke up - PerformPut(tso,StgMVar_value(mvar)); + W_ stack; + stack = StgTSO_stackobj(tso); + PerformPut(stack, StgMVar_value(mvar)); // indicate that the MVar operation has now completed. StgTSO__link(tso) = stg_END_TSO_QUEUE_closure; // no need to mark the TSO dirty, we have only written END_TSO_QUEUE. - foreign "C" tryWakeupThread_(MyCapability() "ptr", tso) []; + foreign "C" tryWakeupThread(MyCapability() "ptr", tso) []; unlockClosure(mvar, stg_MVAR_DIRTY_info); RET_P(val); @@ -1303,24 +1327,20 @@ StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure; } -loop2: - if (TO_W_(StgTSO_what_next(tso)) == ThreadRelocated) { - tso = StgTSO__link(tso); - goto loop2; - } - ASSERT(StgTSO_why_blocked(tso) == BlockedOnMVar::I16); ASSERT(StgTSO_block_info(tso) == mvar); // actually perform the putMVar for the thread that we just woke up - PerformPut(tso,StgMVar_value(mvar)); + W_ stack; + stack = StgTSO_stackobj(tso); + PerformPut(stack, StgMVar_value(mvar)); // indicate that the MVar operation has now completed. StgTSO__link(tso) = stg_END_TSO_QUEUE_closure; // no need to mark the TSO dirty, we have only written END_TSO_QUEUE. - foreign "C" tryWakeupThread_(MyCapability() "ptr", tso) []; + foreign "C" tryWakeupThread(MyCapability() "ptr", tso) []; unlockClosure(mvar, stg_MVAR_DIRTY_info); RET_NP(1,val); @@ -1395,26 +1415,22 @@ StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure; } -loop2: - if (TO_W_(StgTSO_what_next(tso)) == ThreadRelocated) { - tso = StgTSO__link(tso); - goto loop2; - } - ASSERT(StgTSO_why_blocked(tso) == BlockedOnMVar::I16); ASSERT(StgTSO_block_info(tso) == mvar); // actually perform the takeMVar - PerformTake(tso, val); + W_ stack; + stack = StgTSO_stackobj(tso); + PerformTake(stack, val); // indicate that the MVar operation has now completed. StgTSO__link(tso) = stg_END_TSO_QUEUE_closure; - - if (TO_W_(StgTSO_dirty(tso)) == 0) { - foreign "C" dirty_TSO(MyCapability() "ptr", tso "ptr") []; + + if (TO_W_(StgStack_dirty(stack)) == 0) { + foreign "C" dirty_STACK(MyCapability() "ptr", stack "ptr") []; } - foreign "C" tryWakeupThread_(MyCapability() "ptr", tso) []; + foreign "C" tryWakeupThread(MyCapability() "ptr", tso) []; unlockClosure(mvar, stg_MVAR_DIRTY_info); jump %ENTRY_CODE(Sp(0)); @@ -1468,26 +1484,22 @@ StgMVar_tail(mvar) = stg_END_TSO_QUEUE_closure; } -loop2: - if (TO_W_(StgTSO_what_next(tso)) == ThreadRelocated) { - tso = StgTSO__link(tso); - goto loop2; - } - ASSERT(StgTSO_why_blocked(tso) == BlockedOnMVar::I16); ASSERT(StgTSO_block_info(tso) == mvar); // actually perform the takeMVar - PerformTake(tso, val); + W_ stack; + stack = StgTSO_stackobj(tso); + PerformTake(stack, val); // indicate that the MVar operation has now completed. StgTSO__link(tso) = stg_END_TSO_QUEUE_closure; - if (TO_W_(StgTSO_dirty(tso)) == 0) { - foreign "C" dirty_TSO(MyCapability() "ptr", tso "ptr") []; + if (TO_W_(StgStack_dirty(stack)) == 0) { + foreign "C" dirty_STACK(MyCapability() "ptr", stack "ptr") []; } - foreign "C" tryWakeupThread_(MyCapability() "ptr", tso) []; + foreign "C" tryWakeupThread(MyCapability() "ptr", tso) []; unlockClosure(mvar, stg_MVAR_DIRTY_info); RET_N(1); @@ -2014,13 +2026,13 @@ W_ spark; #ifndef THREADED_RTS - RET_NP(0,ghczmprim_GHCziBool_False_closure); + RET_NP(0,ghczmprim_GHCziTypes_False_closure); #else (spark) = foreign "C" findSpark(MyCapability()); if (spark != 0) { RET_NP(1,spark); } else { - RET_NP(0,ghczmprim_GHCziBool_False_closure); + RET_NP(0,ghczmprim_GHCziTypes_False_closure); } #endif } diff -Nru ghc-7.0.3/rts/Printer.c ghc-7.2.1/rts/Printer.c --- ghc-7.0.3/rts/Printer.c 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/rts/Printer.c 2011-08-07 17:10:05.000000000 +0000 @@ -276,6 +276,15 @@ break; } + case UNDERFLOW_FRAME: + { + StgUnderflowFrame* u = (StgUnderflowFrame*)obj; + debugBelch("UNDERFLOW_FRAME("); + printPtr((StgPtr)u->next_chunk); + debugBelch(")\n"); + break; + } + case STOP_FRAME: { StgStopFrame* u = (StgStopFrame*)obj; @@ -409,10 +418,8 @@ static void printSmallBitmap( StgPtr spBottom, StgPtr payload, StgWord bitmap, nat size ) { - StgPtr p; nat i; - p = payload; for(i = 0; i < size; i++, bitmap >>= 1 ) { debugBelch(" stk[%ld] (%p) = ", (long)(spBottom-(payload+i)), payload+i); if ((bitmap & 1) == 0) { @@ -461,13 +468,11 @@ case UPDATE_FRAME: case CATCH_FRAME: - printObj((StgClosure*)sp); + case UNDERFLOW_FRAME: + case STOP_FRAME: + printObj((StgClosure*)sp); continue; - case STOP_FRAME: - printObj((StgClosure*)sp); - return; - case RET_DYN: { StgRetDyn* r; @@ -524,11 +529,9 @@ { StgFunInfoTable *fun_info; StgRetFun *ret_fun; - nat size; ret_fun = (StgRetFun *)sp; fun_info = get_fun_itbl(ret_fun->fun); - size = ret_fun->size; debugBelch("RET_FUN (%p) (type=%d)\n", ret_fun->fun, fun_info->f.fun_type); switch (fun_info->f.fun_type) { case ARG_GEN: @@ -559,7 +562,8 @@ void printTSO( StgTSO *tso ) { - printStackChunk( tso->sp, tso->stack+tso->stack_size); + printStackChunk( tso->stackobj->sp, + tso->stackobj->stack+tso->stackobj->stack_size); } /* -------------------------------------------------------------------------- @@ -1039,7 +1043,6 @@ [ThreadRunGHC] = "ThreadRunGHC", [ThreadInterpret] = "ThreadInterpret", [ThreadKilled] = "ThreadKilled", - [ThreadRelocated] = "ThreadRelocated", [ThreadComplete] = "ThreadComplete" }; @@ -1102,6 +1105,7 @@ [RET_FUN] = "RET_FUN", [UPDATE_FRAME] = "UPDATE_FRAME", [CATCH_FRAME] = "CATCH_FRAME", + [UNDERFLOW_FRAME] = "UNDERFLOW_FRAME", [STOP_FRAME] = "STOP_FRAME", [BLACKHOLE] = "BLACKHOLE", [BLOCKING_QUEUE] = "BLOCKING_QUEUE", @@ -1118,6 +1122,7 @@ [PRIM] = "PRIM", [MUT_PRIM] = "MUT_PRIM", [TSO] = "TSO", + [STACK] = "STACK", [TREC_CHUNK] = "TREC_CHUNK", [ATOMICALLY_FRAME] = "ATOMICALLY_FRAME", [CATCH_RETRY_FRAME] = "CATCH_RETRY_FRAME", diff -Nru ghc-7.0.3/rts/ProfHeap.c ghc-7.2.1/rts/ProfHeap.c --- ghc-7.0.3/rts/ProfHeap.c 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/rts/ProfHeap.c 2011-08-07 17:10:05.000000000 +0000 @@ -18,6 +18,7 @@ #include "LdvProfile.h" #include "Arena.h" #include "Printer.h" +#include "sm/GCThread.h" #include @@ -309,7 +310,7 @@ { } -void freeProfiling1 (void) +void freeProfiling (void) { } @@ -812,7 +813,7 @@ rs->id = -(rs->id); // report in the unit of bytes: * sizeof(StgWord) - printRetainerSetShort(hp_file, rs); + printRetainerSetShort(hp_file, rs, RtsFlags.ProfFlags.ccsLength); break; } default: @@ -826,6 +827,84 @@ printSample(rtsFalse, census->time); } + +static void heapProfObject(Census *census, StgClosure *p, nat size, + rtsBool prim +#ifndef PROFILING + STG_UNUSED +#endif + ) +{ + void *identity; + nat real_size; + counter *ctr; + + identity = NULL; + +#ifdef PROFILING + // subtract the profiling overhead + real_size = size - sizeofW(StgProfHeader); +#else + real_size = size; +#endif + + if (closureSatisfiesConstraints((StgClosure*)p)) { +#ifdef PROFILING + if (RtsFlags.ProfFlags.doHeapProfile == HEAP_BY_LDV) { + if (prim) + census->prim += real_size; + else if ((LDVW(p) & LDV_STATE_MASK) == LDV_STATE_CREATE) + census->not_used += real_size; + else + census->used += real_size; + } else +#endif + { + identity = closureIdentity((StgClosure *)p); + + if (identity != NULL) { + ctr = lookupHashTable( census->hash, (StgWord)identity ); + if (ctr != NULL) { +#ifdef PROFILING + if (RtsFlags.ProfFlags.bioSelector != NULL) { + if (prim) + ctr->c.ldv.prim += real_size; + else if ((LDVW(p) & LDV_STATE_MASK) == LDV_STATE_CREATE) + ctr->c.ldv.not_used += real_size; + else + ctr->c.ldv.used += real_size; + } else +#endif + { + ctr->c.resid += real_size; + } + } else { + ctr = arenaAlloc( census->arena, sizeof(counter) ); + initLDVCtr(ctr); + insertHashTable( census->hash, (StgWord)identity, ctr ); + ctr->identity = identity; + ctr->next = census->ctrs; + census->ctrs = ctr; + +#ifdef PROFILING + if (RtsFlags.ProfFlags.bioSelector != NULL) { + if (prim) + ctr->c.ldv.prim = real_size; + else if ((LDVW(p) & LDV_STATE_MASK) == LDV_STATE_CREATE) + ctr->c.ldv.not_used = real_size; + else + ctr->c.ldv.used = real_size; + } else +#endif + { + ctr->c.resid = real_size; + } + } + } + } + } +} + /* ----------------------------------------------------------------------------- * Code to perform a heap census. * -------------------------------------------------------------------------- */ @@ -834,26 +913,26 @@ { StgPtr p; StgInfoTable *info; - void *identity; nat size; - counter *ctr; - nat real_size; rtsBool prim; for (; bd != NULL; bd = bd->link) { - // HACK: ignore pinned blocks, because they contain gaps. - // It's not clear exactly what we'd like to do here, since we - // can't tell which objects in the block are actually alive. - // Perhaps the whole block should be counted as SYSTEM memory. - if (bd->flags & BF_PINNED) { - continue; - } + // HACK: pretend a pinned block is just one big ARR_WORDS + // owned by CCS_SYSTEM. These blocks can be full of holes due + // to alignment constraints so we can't traverse the memory + // and do a proper census. + if (bd->flags & BF_PINNED) { + StgClosure arr; + SET_HDR(&arr, &stg_ARR_WORDS_info, CCS_SYSTEM); + heapProfObject(census, &arr, bd->blocks * BLOCK_SIZE_W, rtsTrue); + continue; + } p = bd->start; while (p < bd->free) { info = get_itbl((StgClosure *)p); - prim = rtsFalse; + prim = rtsFalse; switch (info->type) { @@ -903,7 +982,7 @@ break; case BCO: - prim = rtsTrue; + prim = rtsTrue; size = bco_sizeW((StgBCO *)p); break; @@ -947,19 +1026,35 @@ prim = rtsTrue; #ifdef PROFILING if (RtsFlags.ProfFlags.includeTSOs) { - size = tso_sizeW((StgTSO *)p); + size = sizeofW(StgTSO); break; } else { // Skip this TSO and move on to the next object - p += tso_sizeW((StgTSO *)p); + p += sizeofW(StgTSO); continue; } #else - size = tso_sizeW((StgTSO *)p); + size = sizeofW(StgTSO); break; #endif - case TREC_CHUNK: + case STACK: + prim = rtsTrue; +#ifdef PROFILING + if (RtsFlags.ProfFlags.includeTSOs) { + size = stack_sizeW((StgStack*)p); + break; + } else { + // Skip this TSO and move on to the next object + p += stack_sizeW((StgStack*)p); + continue; + } +#else + size = stack_sizeW((StgStack*)p); + break; +#endif + + case TREC_CHUNK: prim = rtsTrue; size = sizeofW(StgTRecChunk); break; @@ -968,70 +1063,7 @@ barf("heapCensus, unknown object: %d", info->type); } - identity = NULL; - -#ifdef PROFILING - // subtract the profiling overhead - real_size = size - sizeofW(StgProfHeader); -#else - real_size = size; -#endif - - if (closureSatisfiesConstraints((StgClosure*)p)) { -#ifdef PROFILING - if (RtsFlags.ProfFlags.doHeapProfile == HEAP_BY_LDV) { - if (prim) - census->prim += real_size; - else if ((LDVW(p) & LDV_STATE_MASK) == LDV_STATE_CREATE) - census->not_used += real_size; - else - census->used += real_size; - } else -#endif - { - identity = closureIdentity((StgClosure *)p); - - if (identity != NULL) { - ctr = lookupHashTable( census->hash, (StgWord)identity ); - if (ctr != NULL) { -#ifdef PROFILING - if (RtsFlags.ProfFlags.bioSelector != NULL) { - if (prim) - ctr->c.ldv.prim += real_size; - else if ((LDVW(p) & LDV_STATE_MASK) == LDV_STATE_CREATE) - ctr->c.ldv.not_used += real_size; - else - ctr->c.ldv.used += real_size; - } else -#endif - { - ctr->c.resid += real_size; - } - } else { - ctr = arenaAlloc( census->arena, sizeof(counter) ); - initLDVCtr(ctr); - insertHashTable( census->hash, (StgWord)identity, ctr ); - ctr->identity = identity; - ctr->next = census->ctrs; - census->ctrs = ctr; - -#ifdef PROFILING - if (RtsFlags.ProfFlags.bioSelector != NULL) { - if (prim) - ctr->c.ldv.prim = real_size; - else if ((LDVW(p) & LDV_STATE_MASK) == LDV_STATE_CREATE) - ctr->c.ldv.not_used = real_size; - else - ctr->c.ldv.used = real_size; - } else -#endif - { - ctr->c.resid = real_size; - } - } - } - } - } + heapProfObject(census,(StgClosure*)p,size,prim); p += size; } @@ -1039,13 +1071,14 @@ } void -heapCensus( void ) +heapCensus( Ticks t ) { - nat g; + nat g, n; Census *census; + gen_workspace *ws; census = &censuses[era]; - census->time = mut_user_time(); + census->time = mut_user_time_until(t); // calculate retainer sets if necessary #ifdef PROFILING @@ -1064,6 +1097,13 @@ // Are we interested in large objects? might be // confusing to include the stack in a heap profile. heapCensusChain( census, generations[g].large_objects ); + + for (n = 0; n < n_capabilities; n++) { + ws = &gc_threads[n]->gens[g]; + heapCensusChain(census, ws->todo_bd); + heapCensusChain(census, ws->part_list); + heapCensusChain(census, ws->scavd_list); + } } // dump out the census info diff -Nru ghc-7.0.3/rts/ProfHeap.h ghc-7.2.1/rts/ProfHeap.h --- ghc-7.0.3/rts/ProfHeap.h 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/rts/ProfHeap.h 2011-08-07 17:10:05.000000000 +0000 @@ -9,12 +9,13 @@ #ifndef PROFHEAP_H #define PROFHEAP_H +#include "GetTime.h" // for Ticks + #include "BeginPrivate.h" -void heapCensus (void); +void heapCensus (Ticks t); nat initHeapProfiling (void); void endHeapProfiling (void); -void LDV_recordDead (StgClosure *c, nat size); rtsBool strMatchesSelector (char* str, char* sel); #include "EndPrivate.h" diff -Nru ghc-7.0.3/rts/Profiling.c ghc-7.2.1/rts/Profiling.c --- ghc-7.0.3/rts/Profiling.c 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/rts/Profiling.c 2011-08-07 17:10:05.000000000 +0000 @@ -34,9 +34,9 @@ * closure_cats */ -unsigned int CC_ID; -unsigned int CCS_ID; -unsigned int HP_ID; +unsigned int CC_ID = 1; +unsigned int CCS_ID = 1; +unsigned int HP_ID = 1; /* figures for the profiling report. */ @@ -58,8 +58,8 @@ /* Linked lists to keep track of cc's and ccs's that haven't * been declared in the log file yet */ -CostCentre *CC_LIST; -CostCentreStack *CCS_LIST; +CostCentre *CC_LIST = NULL; +CostCentreStack *CCS_LIST = NULL; /* * Built-in cost centres and cost-centre stacks: @@ -121,7 +121,9 @@ static rtsBool ccs_to_ignore ( CostCentreStack *ccs ); static void count_ticks ( CostCentreStack *ccs ); static void inherit_costs ( CostCentreStack *ccs ); -static void reportCCS ( CostCentreStack *ccs, nat indent ); +static void findCCSMaxLens ( CostCentreStack *ccs, nat indent, nat *max_label_len, nat *max_module_len ); +static void logCCS ( CostCentreStack *ccs, nat indent, nat max_label_len, nat max_module_len ); +static void reportCCS ( CostCentreStack *ccs ); static void DecCCS ( CostCentreStack *ccs ); static void DecBackEdge ( CostCentreStack *ccs, CostCentreStack *oldccs ); @@ -150,41 +152,10 @@ /* for the benefit of allocate()... */ CCCS = CCS_SYSTEM; - - /* Initialize counters for IDs */ - CC_ID = 1; - CCS_ID = 1; - HP_ID = 1; - - /* Initialize Declaration lists to NULL */ - CC_LIST = NULL; - CCS_LIST = NULL; - - /* Register all the cost centres / stacks in the program - * CC_MAIN gets link = 0, all others have non-zero link. - */ - REGISTER_CC(CC_MAIN); - REGISTER_CC(CC_SYSTEM); - REGISTER_CC(CC_GC); - REGISTER_CC(CC_OVERHEAD); - REGISTER_CC(CC_SUBSUMED); - REGISTER_CC(CC_DONT_CARE); - REGISTER_CCS(CCS_MAIN); - REGISTER_CCS(CCS_SYSTEM); - REGISTER_CCS(CCS_GC); - REGISTER_CCS(CCS_OVERHEAD); - REGISTER_CCS(CCS_SUBSUMED); - REGISTER_CCS(CCS_DONT_CARE); - - CCCS = CCS_OVERHEAD; - - /* cost centres are registered by the per-module - * initialisation code now... - */ } void -freeProfiling1 (void) +freeProfiling (void) { arenaFree(prof_arena); } @@ -200,17 +171,36 @@ * information into it. */ initProfilingLogFile(); + /* Register all the cost centres / stacks in the program + * CC_MAIN gets link = 0, all others have non-zero link. + */ + REGISTER_CC(CC_MAIN); + REGISTER_CC(CC_SYSTEM); + REGISTER_CC(CC_GC); + REGISTER_CC(CC_OVERHEAD); + REGISTER_CC(CC_SUBSUMED); + REGISTER_CC(CC_DONT_CARE); + + REGISTER_CCS(CCS_SYSTEM); + REGISTER_CCS(CCS_GC); + REGISTER_CCS(CCS_OVERHEAD); + REGISTER_CCS(CCS_SUBSUMED); + REGISTER_CCS(CCS_DONT_CARE); + REGISTER_CCS(CCS_MAIN); + /* find all the "special" cost centre stacks, and make them children * of CCS_MAIN. */ - ASSERT(CCS_MAIN->prevStack == 0); + ASSERT(CCS_LIST == CCS_MAIN); + CCS_LIST = CCS_LIST->prevStack; + CCS_MAIN->prevStack = NULL; CCS_MAIN->root = CC_MAIN; ccsSetSelected(CCS_MAIN); DecCCS(CCS_MAIN); - for (ccs = CCS_LIST; ccs != CCS_MAIN; ) { + for (ccs = CCS_LIST; ccs != NULL; ) { next = ccs->prevStack; - ccs->prevStack = 0; + ccs->prevStack = NULL; ActualPush_(CCS_MAIN,ccs->cc,ccs); ccs->root = ccs->cc; ccs = next; @@ -664,20 +654,26 @@ report_per_cc_costs( void ) { CostCentre *cc, *next; + nat max_label_len, max_module_len; aggregate_cc_costs(CCS_MAIN); sorted_cc_list = NULL; + max_label_len = max_module_len = 0; + for (cc = CC_LIST; cc != NULL; cc = next) { next = cc->link; if (cc->time_ticks > total_prof_ticks/100 || cc->mem_alloc > total_alloc/100 || RtsFlags.CcFlags.doCostCentres >= COST_CENTRES_ALL) { insert_cc_in_sorted_list(cc); + + max_label_len = stg_max(strlen(cc->label), max_label_len); + max_module_len = stg_max(strlen(cc->module), max_module_len); } } - fprintf(prof_file, "%-30s %-20s", "COST CENTRE", "MODULE"); + fprintf(prof_file, "%-*s %-*s", max_label_len, "COST CENTRE", max_module_len, "MODULE"); fprintf(prof_file, "%6s %6s", "%time", "%alloc"); if (RtsFlags.CcFlags.doCostCentres >= COST_CENTRES_VERBOSE) { fprintf(prof_file, " %5s %9s", "ticks", "bytes"); @@ -688,7 +684,7 @@ if (cc_to_ignore(cc)) { continue; } - fprintf(prof_file, "%-30s %-20s", cc->label, cc->module); + fprintf(prof_file, "%-*s %-*s", max_label_len, cc->label, max_module_len, cc->module); fprintf(prof_file, "%6.1f %6.1f", total_prof_ticks == 0 ? 0.0 : (cc->time_ticks / (StgFloat) total_prof_ticks * 100), total_alloc == 0 ? 0.0 : (cc->mem_alloc / (StgFloat) @@ -710,11 +706,11 @@ -------------------------------------------------------------------------- */ static void -fprint_header( void ) +fprint_header( nat max_label_len, nat max_module_len ) { fprintf(prof_file, "%-24s %-10s individual inherited\n", "", ""); - fprintf(prof_file, "%-24s %-50s", "COST CENTRE", "MODULE"); + fprintf(prof_file, "%-*s %-*s", max_label_len, "COST CENTRE", max_module_len, "MODULE"); fprintf(prof_file, "%6s %10s %5s %5s %5s %5s", "no.", "entries", "%time", "%alloc", "%time", "%alloc"); if (RtsFlags.CcFlags.doCostCentres >= COST_CENTRES_VERBOSE) { @@ -733,7 +729,7 @@ { nat count; char temp[128]; /* sigh: magic constant */ - + stopProfTimer(); total_prof_ticks = 0; @@ -782,12 +778,28 @@ inherit_costs(CCS_MAIN); - fprint_header(); - reportCCS(pruneCCSTree(CCS_MAIN), 0); + reportCCS(pruneCCSTree(CCS_MAIN)); } static void -reportCCS(CostCentreStack *ccs, nat indent) +findCCSMaxLens(CostCentreStack *ccs, nat indent, nat *max_label_len, nat *max_module_len) { + CostCentre *cc; + IndexTable *i; + + cc = ccs->cc; + + *max_label_len = stg_max(*max_label_len, indent + strlen(cc->label)); + *max_module_len = stg_max(*max_module_len, strlen(cc->module)); + + for (i = ccs->indexTable; i != 0; i = i->next) { + if (!i->back_edge) { + findCCSMaxLens(i->ccs, indent+1, max_label_len, max_module_len); + } + } +} + +static void +logCCS(CostCentreStack *ccs, nat indent, nat max_label_len, nat max_module_len) { CostCentre *cc; IndexTable *i; @@ -801,8 +813,8 @@ /* force printing of *all* cost centres if -P -P */ { - fprintf(prof_file, "%-*s%-*s %-50s", - indent, "", 24-indent, cc->label, cc->module); + fprintf(prof_file, "%-*s%-*s %-*s", + indent, "", max_label_len-indent, cc->label, max_module_len, cc->module); fprintf(prof_file, "%6ld %11.0f %5.1f %5.1f %5.1f %5.1f", ccs->ccsID, (double) ccs->scc_count, @@ -828,11 +840,23 @@ for (i = ccs->indexTable; i != 0; i = i->next) { if (!i->back_edge) { - reportCCS(i->ccs, indent+1); + logCCS(i->ccs, indent+1, max_label_len, max_module_len); } } } +static void +reportCCS(CostCentreStack *ccs) +{ + nat max_label_len, max_module_len; + max_label_len = max_module_len = 0; + + findCCSMaxLens(ccs, 0, &max_label_len, &max_module_len); + + fprint_header(max_label_len, max_module_len); + logCCS(ccs, 0, max_label_len, max_module_len); +} + /* Traverse the cost centre stack tree and accumulate * ticks/allocations. diff -Nru ghc-7.0.3/rts/Profiling.h ghc-7.2.1/rts/Profiling.h --- ghc-7.0.3/rts/Profiling.h 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/rts/Profiling.h 2011-08-07 17:10:05.000000000 +0000 @@ -12,11 +12,18 @@ #include #include "BeginPrivate.h" +#include "Rts.h" + +#ifdef PROFILING +#define PROFILING_ONLY(s) s +#else +#define PROFILING_ONLY(s) doNothing() +#endif void initProfiling1 (void); -void freeProfiling1 (void); void initProfiling2 (void); void endProfiling (void); +void freeProfiling (void); extern FILE *prof_file; extern FILE *hp_file; diff -Nru ghc-7.0.3/rts/RaiseAsync.c ghc-7.2.1/rts/RaiseAsync.c --- ghc-7.0.3/rts/RaiseAsync.c 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/rts/RaiseAsync.c 2011-08-07 17:10:05.000000000 +0000 @@ -23,11 +23,11 @@ #include "win32/IOManager.h" #endif -static void raiseAsync (Capability *cap, - StgTSO *tso, - StgClosure *exception, - rtsBool stop_at_atomically, - StgUpdateFrame *stop_here); +static StgTSO* raiseAsync (Capability *cap, + StgTSO *tso, + StgClosure *exception, + rtsBool stop_at_atomically, + StgUpdateFrame *stop_here); static void removeFromQueues(Capability *cap, StgTSO *tso); @@ -57,43 +57,38 @@ has been raised. -------------------------------------------------------------------------- */ -void -throwToSingleThreaded(Capability *cap, StgTSO *tso, StgClosure *exception) -{ - throwToSingleThreaded_(cap, tso, exception, rtsFalse); -} - -void -throwToSingleThreaded_(Capability *cap, StgTSO *tso, StgClosure *exception, - rtsBool stop_at_atomically) +static void +throwToSingleThreaded__ (Capability *cap, StgTSO *tso, StgClosure *exception, + rtsBool stop_at_atomically, StgUpdateFrame *stop_here) { - tso = deRefTSO(tso); - // Thread already dead? if (tso->what_next == ThreadComplete || tso->what_next == ThreadKilled) { - return; + return; } // Remove it from any blocking queues removeFromQueues(cap,tso); - raiseAsync(cap, tso, exception, stop_at_atomically, NULL); + raiseAsync(cap, tso, exception, stop_at_atomically, stop_here); } void -suspendComputation(Capability *cap, StgTSO *tso, StgUpdateFrame *stop_here) +throwToSingleThreaded (Capability *cap, StgTSO *tso, StgClosure *exception) { - tso = deRefTSO(tso); - - // Thread already dead? - if (tso->what_next == ThreadComplete || tso->what_next == ThreadKilled) { - return; - } + throwToSingleThreaded__(cap, tso, exception, rtsFalse, NULL); +} - // Remove it from any blocking queues - removeFromQueues(cap,tso); +void +throwToSingleThreaded_ (Capability *cap, StgTSO *tso, StgClosure *exception, + rtsBool stop_at_atomically) +{ + throwToSingleThreaded__ (cap, tso, exception, stop_at_atomically, NULL); +} - raiseAsync(cap, tso, NULL, rtsFalse, stop_here); +void // cannot return a different TSO +suspendComputation (Capability *cap, StgTSO *tso, StgUpdateFrame *stop_here) +{ + throwToSingleThreaded__ (cap, tso, NULL, rtsFalse, stop_here); } /* ----------------------------------------------------------------------------- @@ -127,7 +122,7 @@ Capability, and it is - NotBlocked, BlockedOnMsgThrowTo, - BlockedOnCCall + BlockedOnCCall_Interruptible - or it is masking exceptions (TSO_BLOCKEX) @@ -195,9 +190,6 @@ check_target: ASSERT(target != END_TSO_QUEUE); - // follow ThreadRelocated links in the target first - target = deRefTSO(target); - // Thread already dead? if (target->what_next == ThreadComplete || target->what_next == ThreadKilled) { @@ -271,7 +263,7 @@ // might as well just do it now. The message will // be a no-op when it arrives. unlockClosure((StgClosure*)m, i); - tryWakeupThread_(cap, target); + tryWakeupThread(cap, target); goto retry; } @@ -289,7 +281,7 @@ } // nobody else can wake up this TSO after we claim the message - unlockClosure((StgClosure*)m, &stg_MSG_NULL_info); + doneWithMsgThrowTo(m); raiseAsync(cap, target, msg->exception, rtsFalse, NULL); return THROWTO_SUCCESS; @@ -318,12 +310,7 @@ info = lockClosure((StgClosure *)mvar); - if (target->what_next == ThreadRelocated) { - target = target->_link; - unlockClosure((StgClosure *)mvar,info); - goto retry; - } - // we have the MVar, let's check whether the thread + // we have the MVar, let's check whether the thread // is still blocked on the same MVar. if (target->why_blocked != BlockedOnMVar || (StgMVar *)target->block_info.closure != mvar) { @@ -337,7 +324,7 @@ // thread now anyway and ignore the message when it // arrives. unlockClosure((StgClosure *)mvar, info); - tryWakeupThread_(cap, target); + tryWakeupThread(cap, target); goto retry; } @@ -392,8 +379,32 @@ return THROWTO_SUCCESS; } + case BlockedOnCCall_Interruptible: +#ifdef THREADED_RTS + { + Task *task = NULL; + // walk suspended_ccalls to find the correct worker thread + InCall *incall; + for (incall = cap->suspended_ccalls; incall != NULL; incall = incall->next) { + if (incall->suspended_tso == target) { + task = incall->task; + break; + } + } + if (task != NULL) { + blockedThrowTo(cap, target, msg); + if (!((target->flags & TSO_BLOCKEX) && + ((target->flags & TSO_INTERRUPTIBLE) == 0))) { + interruptWorkerTask(task); + } + return THROWTO_BLOCKED; + } else { + debugTraceCap(DEBUG_sched, cap, "throwTo: could not find worker thread to kill"); + } + // fall to next + } +#endif case BlockedOnCCall: - case BlockedOnCCall_NoUnblockExc: blockedThrowTo(cap,target,msg); return THROWTO_BLOCKED; @@ -484,7 +495,8 @@ { MessageThrowTo *msg; const StgInfoTable *i; - + StgTSO *source; + if (tso->what_next == ThreadComplete || tso->what_next == ThreadFinished) { if (tso->blocked_exceptions != END_BLOCKED_EXCEPTIONS_QUEUE) { awakenBlockedExceptionQueue(cap,tso); @@ -516,8 +528,9 @@ } throwToSingleThreaded(cap, msg->target, msg->exception); - unlockClosure((StgClosure*)msg,&stg_MSG_NULL_info); - tryWakeupThread(cap, msg->source); + source = msg->source; + doneWithMsgThrowTo(msg); + tryWakeupThread(cap, source); return 1; } return 0; @@ -531,13 +544,15 @@ { MessageThrowTo *msg; const StgInfoTable *i; + StgTSO *source; for (msg = tso->blocked_exceptions; msg != END_BLOCKED_EXCEPTIONS_QUEUE; msg = (MessageThrowTo*)msg->link) { i = lockClosure((StgClosure *)msg); if (i != &stg_MSG_NULL_info) { - unlockClosure((StgClosure *)msg,&stg_MSG_NULL_info); - tryWakeupThread(cap, msg->source); + source = msg->source; + doneWithMsgThrowTo(msg); + tryWakeupThread(cap, source); } else { unlockClosure((StgClosure *)msg,i); } @@ -577,7 +592,7 @@ if (mvar->head == q) { mvar->head = q->link; - q->header.info = &stg_IND_info; + OVERWRITE_INFO(q, &stg_IND_info); if (mvar->tail == q) { mvar->tail = (StgMVarTSOQueue*)END_TSO_QUEUE; } @@ -587,10 +602,10 @@ // we lose the tail pointer when the GC shorts out the IND. // So we use MSG_NULL as a kind of non-dupable indirection; // these are ignored by takeMVar/putMVar. - q->header.info = &stg_MSG_NULL_info; + OVERWRITE_INFO(q, &stg_MSG_NULL_info); } else { - q->header.info = &stg_IND_info; + OVERWRITE_INFO(q, &stg_IND_info); } // revoke the MVar operation @@ -632,7 +647,7 @@ // ASSERT(m->header.info == &stg_WHITEHOLE_info); // unlock and revoke it at the same time - unlockClosure((StgClosure*)m,&stg_MSG_NULL_info); + doneWithMsgThrowTo(m); break; } @@ -703,7 +718,7 @@ * * -------------------------------------------------------------------------- */ -static void +static StgTSO * raiseAsync(Capability *cap, StgTSO *tso, StgClosure *exception, rtsBool stop_at_atomically, StgUpdateFrame *stop_here) { @@ -711,6 +726,7 @@ StgPtr sp, frame; StgClosure *updatee; nat i; + StgStack *stack; debugTraceCap(DEBUG_sched, cap, "raising exception in thread %ld.", (long)tso->id); @@ -726,25 +742,21 @@ fprintCCS_stderr(tso->prof.CCCS); } #endif - // ASSUMES: the thread is not already complete or dead, or - // ThreadRelocated. Upper layers should deal with that. + // ASSUMES: the thread is not already complete or dead + // Upper layers should deal with that. ASSERT(tso->what_next != ThreadComplete && - tso->what_next != ThreadKilled && - tso->what_next != ThreadRelocated); + tso->what_next != ThreadKilled); // only if we own this TSO (except that deleteThread() calls this ASSERT(tso->cap == cap); - // wake it up - if (tso->why_blocked != NotBlocked) { - tso->why_blocked = NotBlocked; - appendToRunQueue(cap,tso); - } + stack = tso->stackobj; // mark it dirty; we're about to change its stack. dirty_TSO(cap, tso); + dirty_STACK(cap, stack); - sp = tso->sp; + sp = stack->sp; if (stop_here != NULL) { updatee = stop_here->updatee; @@ -780,10 +792,13 @@ // // 5. If it's a STOP_FRAME, then kill the thread. // - // NB: if we pass an ATOMICALLY_FRAME then abort the associated + // 6. If it's an UNDERFLOW_FRAME, then continue with the next + // stack chunk. + // + // NB: if we pass an ATOMICALLY_FRAME then abort the associated // transaction - info = get_ret_itbl((StgClosure *)frame); + info = get_ret_itbl((StgClosure *)frame); switch (info->i.type) { @@ -838,12 +853,46 @@ continue; //no need to bump frame } - case STOP_FRAME: + case UNDERFLOW_FRAME: + { + StgAP_STACK * ap; + nat words; + + // First build an AP_STACK consisting of the stack chunk above the + // current update frame, with the top word on the stack as the + // fun field. + // + words = frame - sp - 1; + ap = (StgAP_STACK *)allocate(cap,AP_STACK_sizeW(words)); + + ap->size = words; + ap->fun = (StgClosure *)sp[0]; + sp++; + for(i=0; i < (nat)words; ++i) { + ap->payload[i] = (StgClosure *)*sp++; + } + + SET_HDR(ap,&stg_AP_STACK_NOUPD_info, + ((StgClosure *)frame)->header.prof.ccs /* ToDo */); + TICK_ALLOC_SE_THK(words+1,0); + + stack->sp = sp; + threadStackUnderflow(cap,tso); + stack = tso->stackobj; + sp = stack->sp; + + sp--; + sp[0] = (W_)ap; + frame = sp + 1; + continue; + } + + case STOP_FRAME: { // We've stripped the entire stack, the thread is now dead. tso->what_next = ThreadKilled; - tso->sp = frame + sizeofW(StgStopFrame); - return; + stack->sp = frame + sizeofW(StgStopFrame); + goto done; } case CATCH_FRAME: @@ -885,17 +934,16 @@ */ sp[0] = (W_)raise; sp[-1] = (W_)&stg_enter_info; - tso->sp = sp-1; + stack->sp = sp-1; tso->what_next = ThreadRunGHC; - IF_DEBUG(sanity, checkTSO(tso)); - return; + goto done; } case ATOMICALLY_FRAME: if (stop_at_atomically) { ASSERT(tso->trec->enclosing_trec == NO_TREC); stmCondemnTransaction(cap, tso -> trec); - tso->sp = frame - 2; + stack->sp = frame - 2; // The ATOMICALLY_FRAME expects to be returned a // result from the transaction, which it stores in the // stack frame. Hence we arrange to return a dummy @@ -904,10 +952,10 @@ // ATOMICALLY_FRAME instance for condemned // transactions, but I don't fully understand the // interaction with STM invariants. - tso->sp[1] = (W_)&stg_NO_TREC_closure; - tso->sp[0] = (W_)&stg_gc_unpt_r1_info; - tso->what_next = ThreadRunGHC; - return; + stack->sp[1] = (W_)&stg_NO_TREC_closure; + stack->sp[0] = (W_)&stg_gc_unpt_r1_info; + tso->what_next = ThreadRunGHC; + goto done; } // Not stop_at_atomically... fall through and abort the // transaction. @@ -929,7 +977,7 @@ stmAbortTransaction(cap, trec); stmFreeAbortedTRec(cap, trec); tso -> trec = outer; - break; + break; }; default: @@ -940,8 +988,16 @@ frame += stack_frame_sizeW((StgClosure *)frame); } - // if we got here, then we stopped at stop_here - ASSERT(stop_here != NULL); +done: + IF_DEBUG(sanity, checkTSO(tso)); + + // wake it up + if (tso->why_blocked != NotBlocked) { + tso->why_blocked = NotBlocked; + appendToRunQueue(cap,tso); + } + + return tso; } diff -Nru ghc-7.0.3/rts/RetainerProfile.c ghc-7.2.1/rts/RetainerProfile.c --- ghc-7.0.3/rts/RetainerProfile.c 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/rts/RetainerProfile.c 2011-08-07 17:10:05.000000000 +0000 @@ -597,11 +597,13 @@ case AP: case AP_STACK: case TSO: + case STACK: case IND_STATIC: case CONSTR_NOCAF_STATIC: // stack objects case UPDATE_FRAME: case CATCH_FRAME: + case UNDERFLOW_FRAME: case STOP_FRAME: case RET_DYN: case RET_BCO: @@ -925,13 +927,15 @@ case AP: case AP_STACK: case TSO: - case IND_STATIC: + case STACK: + case IND_STATIC: case CONSTR_NOCAF_STATIC: // stack objects case RET_DYN: case UPDATE_FRAME: case CATCH_FRAME: - case STOP_FRAME: + case UNDERFLOW_FRAME: + case STOP_FRAME: case RET_BCO: case RET_SMALL: case RET_BIG: @@ -1001,6 +1005,7 @@ // // TSOs MUST be retainers: they constitute the set of roots. case TSO: + case STACK: // mutable objects case MUT_PRIM: @@ -1080,6 +1085,7 @@ // legal objects during retainer profiling. case UPDATE_FRAME: case CATCH_FRAME: + case UNDERFLOW_FRAME: case STOP_FRAME: case RET_DYN: case RET_BCO: @@ -1257,8 +1263,8 @@ * RSET(c) and RSET(c_child_r) are valid, i.e., their * interpretation conforms to the current value of flip (even when they * are interpreted to be NULL). - * If *c is TSO, its state is not any of ThreadRelocated, ThreadComplete, - * or ThreadKilled, which means that its stack is ready to process. + * If *c is TSO, its state is not ThreadComplete,or ThreadKilled, + * which means that its stack is ready to process. * Note: * This code was almost plagiarzied from GC.c! For each pointer, * retainClosure() is invoked instead of evacuate(). @@ -1291,11 +1297,8 @@ // debugBelch("retainStack() called: oldStackBoundary = 0x%x, currentStackBoundary = 0x%x\n", oldStackBoundary, currentStackBoundary); #endif - ASSERT(get_itbl(c)->type != TSO || - (((StgTSO *)c)->what_next != ThreadRelocated && - ((StgTSO *)c)->what_next != ThreadComplete && - ((StgTSO *)c)->what_next != ThreadKilled)); - + ASSERT(get_itbl(c)->type == STACK); + p = stackStart; while (p < stackEnd) { info = get_ret_itbl((StgClosure *)p); @@ -1307,7 +1310,8 @@ p += sizeofW(StgUpdateFrame); continue; - case STOP_FRAME: + case UNDERFLOW_FRAME: + case STOP_FRAME: case CATCH_FRAME: case CATCH_STM_FRAME: case CATCH_RETRY_FRAME: @@ -1560,14 +1564,7 @@ #endif goto loop; } - if (((StgTSO *)c)->what_next == ThreadRelocated) { -#ifdef DEBUG_RETAINER - debugBelch("ThreadRelocated encountered in retainClosure()\n"); -#endif - c = (StgClosure *)((StgTSO *)c)->_link; - goto inner_loop; - } - break; + break; case IND_STATIC: // We just skip IND_STATIC, so its retainer set is never computed. @@ -1681,12 +1678,29 @@ // than attempting to save the current position, because doing so // would be hard. switch (typeOfc) { - case TSO: + case STACK: retainStack(c, c_child_r, - ((StgTSO *)c)->sp, - ((StgTSO *)c)->stack + ((StgTSO *)c)->stack_size); + ((StgStack *)c)->sp, + ((StgStack *)c)->stack + ((StgStack *)c)->stack_size); goto loop; + case TSO: + { + StgTSO *tso = (StgTSO *)c; + + retainClosure(tso->stackobj, c, c_child_r); + retainClosure(tso->blocked_exceptions, c, c_child_r); + retainClosure(tso->bq, c, c_child_r); + retainClosure(tso->trec, c, c_child_r); + if ( tso->why_blocked == BlockedOnMVar + || tso->why_blocked == BlockedOnBlackHole + || tso->why_blocked == BlockedOnMsgThrowTo + ) { + retainClosure(tso->block_info.closure, c, c_child_r); + } + goto loop; + } + case PAP: { StgPAP *pap = (StgPAP *)c; @@ -1740,6 +1754,7 @@ currentStackBoundary = stackTop; c = UNTAG_CLOSURE(*tl); + maybeInitRetainerSet(c); if (c != &stg_END_TSO_QUEUE_closure && isRetainer(c)) { retainClosure(c, c, getRetainerFrom(c)); } else { @@ -1759,7 +1774,7 @@ { StgWeak *weak; RetainerSet *rtl; - nat g; + nat g, n; StgPtr ml; bdescr *bd; #ifdef DEBUG_RETAINER @@ -1790,7 +1805,8 @@ // Traversing through mut_list is necessary // because we can find MUT_VAR objects which have not been // visited during retainer profiling. - for (bd = generations[g].mut_list; bd != NULL; bd = bd->link) { + for (n = 0; n < n_capabilities; n++) { + for (bd = capabilities[n].mut_lists[g]; bd != NULL; bd = bd->link) { for (ml = bd->start; ml < bd->free; ml++) { maybeInitRetainerSet((StgClosure *)*ml); @@ -1821,7 +1837,8 @@ } #endif } - } + } + } } } @@ -1840,6 +1857,15 @@ * However, this is not necessary because any static indirection objects * are just traversed through to reach dynamic objects. In other words, * they are not taken into consideration in computing retainer sets. + * + * SDM (20/7/2011): I don't think this is doing anything sensible, + * because it happens before retainerProfile() and at the beginning of + * retainerProfil() we change the sense of 'flip'. So all of the + * calls to maybeInitRetainerSet() here are initialising retainer sets + * with the wrong flip. Also, I don't see why this is necessary. I + * added a maybeInitRetainerSet() call to retainRoot(), and that seems + * to have fixed the assertion failure in retainerSetOf() I was + * encountering. * -------------------------------------------------------------------------- */ void resetStaticObjectForRetainerProfiling( StgClosure *static_objects ) diff -Nru ghc-7.0.3/rts/RetainerSet.c ghc-7.2.1/rts/RetainerSet.c --- ghc-7.0.3/rts/RetainerSet.c 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/rts/RetainerSet.c 2011-08-07 17:10:05.000000000 +0000 @@ -265,35 +265,34 @@ #if defined(RETAINER_SCHEME_INFO) // Retainer scheme 1: retainer = info table void -printRetainerSetShort(FILE *f, RetainerSet *rs) +printRetainerSetShort(FILE *f, RetainerSet *rs, nat max_length) { -#define MAX_RETAINER_SET_SPACE 24 - char tmp[MAX_RETAINER_SET_SPACE + 1]; + char tmp[max_length + 1]; int size; nat j; ASSERT(rs->id < 0); - tmp[MAX_RETAINER_SET_SPACE] = '\0'; + tmp[max_length] = '\0'; // No blank characters are allowed. sprintf(tmp + 0, "(%d)", -(rs->id)); size = strlen(tmp); - ASSERT(size < MAX_RETAINER_SET_SPACE); + ASSERT(size < max_length); for (j = 0; j < rs->num; j++) { if (j < rs->num - 1) { - strncpy(tmp + size, GET_PROF_DESC(rs->element[j]), MAX_RETAINER_SET_SPACE - size); + strncpy(tmp + size, GET_PROF_DESC(rs->element[j]), max_length - size); size = strlen(tmp); - if (size == MAX_RETAINER_SET_SPACE) + if (size == max_length) break; - strncpy(tmp + size, ",", MAX_RETAINER_SET_SPACE - size); + strncpy(tmp + size, ",", max_length - size); size = strlen(tmp); - if (size == MAX_RETAINER_SET_SPACE) + if (size == max_length) break; } else { - strncpy(tmp + size, GET_PROF_DESC(rs->element[j]), MAX_RETAINER_SET_SPACE - size); + strncpy(tmp + size, GET_PROF_DESC(rs->element[j]), max_length - size); // size = strlen(tmp); } } @@ -302,10 +301,9 @@ #elif defined(RETAINER_SCHEME_CC) // Retainer scheme 3: retainer = cost centre void -printRetainerSetShort(FILE *f, RetainerSet *rs) +printRetainerSetShort(FILE *f, RetainerSet *rs, nat max_length) { -#define MAX_RETAINER_SET_SPACE 24 - char tmp[MAX_RETAINER_SET_SPACE + 1]; + char tmp[max_length + 1]; int size; nat j; @@ -313,35 +311,34 @@ #elif defined(RETAINER_SCHEME_CCS) // Retainer scheme 2: retainer = cost centre stack void -printRetainerSetShort(FILE *f, RetainerSet *rs) +printRetainerSetShort(FILE *f, RetainerSet *rs, nat max_length) { -#define MAX_RETAINER_SET_SPACE 24 - char tmp[MAX_RETAINER_SET_SPACE + 1]; - int size; + char tmp[max_length + 1]; + nat size; nat j; ASSERT(rs->id < 0); - tmp[MAX_RETAINER_SET_SPACE] = '\0'; + tmp[max_length] = '\0'; // No blank characters are allowed. sprintf(tmp + 0, "(%d)", -(rs->id)); size = strlen(tmp); - ASSERT(size < MAX_RETAINER_SET_SPACE); + ASSERT(size < max_length); for (j = 0; j < rs->num; j++) { if (j < rs->num - 1) { - strncpy(tmp + size, rs->element[j]->cc->label, MAX_RETAINER_SET_SPACE - size); + strncpy(tmp + size, rs->element[j]->cc->label, max_length - size); size = strlen(tmp); - if (size == MAX_RETAINER_SET_SPACE) + if (size == max_length) break; - strncpy(tmp + size, ",", MAX_RETAINER_SET_SPACE - size); + strncpy(tmp + size, ",", max_length - size); size = strlen(tmp); - if (size == MAX_RETAINER_SET_SPACE) + if (size == max_length) break; } else { - strncpy(tmp + size, rs->element[j]->cc->label, MAX_RETAINER_SET_SPACE - size); + strncpy(tmp + size, rs->element[j]->cc->label, max_length - size); // size = strlen(tmp); } } @@ -350,46 +347,44 @@ #elif defined(RETAINER_SCHEME_CC) // Retainer scheme 3: retainer = cost centre static void -printRetainerSetShort(FILE *f, retainerSet *rs) +printRetainerSetShort(FILE *f, retainerSet *rs, nat max_length) { -#define MAX_RETAINER_SET_SPACE 24 - char tmp[MAX_RETAINER_SET_SPACE + 1]; + char tmp[max_length + 1]; int size; nat j; ASSERT(rs->id < 0); - tmp[MAX_RETAINER_SET_SPACE] = '\0'; + tmp[max_length] = '\0'; // No blank characters are allowed. sprintf(tmp + 0, "(%d)", -(rs->id)); size = strlen(tmp); - ASSERT(size < MAX_RETAINER_SET_SPACE); + ASSERT(size < max_length); for (j = 0; j < rs->num; j++) { if (j < rs->num - 1) { strncpy(tmp + size, rs->element[j]->label, - MAX_RETAINER_SET_SPACE - size); + max_length - size); size = strlen(tmp); - if (size == MAX_RETAINER_SET_SPACE) + if (size == max_length) break; - strncpy(tmp + size, ",", MAX_RETAINER_SET_SPACE - size); + strncpy(tmp + size, ",", max_length - size); size = strlen(tmp); - if (size == MAX_RETAINER_SET_SPACE) + if (size == max_length) break; } else { strncpy(tmp + size, rs->element[j]->label, - MAX_RETAINER_SET_SPACE - size); + max_length - size); // size = strlen(tmp); } } fprintf(f, tmp); /* - #define MAX_RETAINER_SET_SPACE 24 #define DOT_NUMBER 3 - // 1. 32 > MAX_RETAINER_SET_SPACE + 1 (1 for '\0') - // 2. (MAX_RETAINER_SET_SPACE - DOT_NUMBER ) characters should be enough for + // 1. 32 > max_length + 1 (1 for '\0') + // 2. (max_length - DOT_NUMBER ) characters should be enough for // printing one natural number (plus '(' and ')'). char tmp[32]; int size, ts; @@ -400,12 +395,12 @@ // No blank characters are allowed. sprintf(tmp + 0, "(%d)", -(rs->id)); size = strlen(tmp); - ASSERT(size < MAX_RETAINER_SET_SPACE - DOT_NUMBER); + ASSERT(size < max_length - DOT_NUMBER); for (j = 0; j < rs->num; j++) { ts = strlen(rs->element[j]->label); if (j < rs->num - 1) { - if (size + ts + 1 > MAX_RETAINER_SET_SPACE - DOT_NUMBER) { + if (size + ts + 1 > max_length - DOT_NUMBER) { sprintf(tmp + size, "..."); break; } @@ -413,7 +408,7 @@ size += ts + 1; } else { - if (size + ts > MAX_RETAINER_SET_SPACE - DOT_NUMBER) { + if (size + ts > max_length - DOT_NUMBER) { sprintf(tmp + size, "..."); break; } diff -Nru ghc-7.0.3/rts/RetainerSet.h ghc-7.2.1/rts/RetainerSet.h --- ghc-7.0.3/rts/RetainerSet.h 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/rts/RetainerSet.h 2011-08-07 17:10:05.000000000 +0000 @@ -165,7 +165,7 @@ #ifdef SECOND_APPROACH // Prints a single retainer set. -void printRetainerSetShort(FILE *, RetainerSet *); +void printRetainerSetShort(FILE *, RetainerSet *, nat); #endif // Print the statistics on all the retainer sets. diff -Nru ghc-7.0.3/rts/RtsAPI.c ghc-7.2.1/rts/RtsAPI.c --- ghc-7.0.3/rts/RtsAPI.c 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/rts/RtsAPI.c 2011-08-07 17:10:05.000000000 +0000 @@ -375,8 +375,8 @@ -------------------------------------------------------------------------- */ INLINE_HEADER void pushClosure (StgTSO *tso, StgWord c) { - tso->sp--; - tso->sp[0] = (W_) c; + tso->stackobj->sp--; + tso->stackobj->sp[0] = (W_) c; } StgTSO * @@ -394,7 +394,6 @@ { StgTSO *t; t = createThread (cap, stack_size); - pushClosure(t, (W_)&stg_noforceIO_info); pushClosure(t, (W_)&stg_ap_v_info); pushClosure(t, (W_)closure); pushClosure(t, (W_)&stg_enter_info); diff -Nru ghc-7.0.3/rts/RtsFlags.c ghc-7.2.1/rts/RtsFlags.c --- ghc-7.0.3/rts/RtsFlags.c 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/rts/RtsFlags.c 2011-08-07 17:10:05.000000000 +0000 @@ -13,6 +13,7 @@ #include "RtsOpts.h" #include "RtsUtils.h" #include "Profiling.h" +#include "RtsFlags.h" #ifdef HAVE_CTYPE_H #include @@ -32,7 +33,15 @@ char **full_prog_argv = NULL; char *prog_name = NULL; /* 'basename' of prog_argv[0] */ int rts_argc = 0; /* ditto */ -char *rts_argv[MAX_RTS_ARGS]; +char **rts_argv = NULL; +#if defined(mingw32_HOST_OS) +// On Windows, we want to use GetCommandLineW rather than argc/argv, +// but we need to mutate the command line arguments for withProgName and +// friends. The System.Environment module achieves that using this bit of +// shared state: +int win32_prog_argc = 0; +wchar_t **win32_prog_argv = NULL; +#endif /* * constants, used later @@ -44,20 +53,30 @@ Static function decls -------------------------------------------------------------------------- */ -static int /* return NULL on error */ -open_stats_file ( - I_ arg, - int argc, char *argv[], - int rts_argc, char *rts_argv[], - const char *FILENAME_FMT, - FILE **file_ret); +static void procRtsOpts (int rts_argc0, RtsOptsEnabledEnum enabled); + +static void normaliseRtsOpts (void); + +static void initStatsFile (FILE *f); + +static int openStatsFile (char *filename, const char *FILENAME_FMT, + FILE **file_ret); + +static StgWord64 decodeSize (const char *flag, nat offset, + StgWord64 min, StgWord64 max); + +static void bad_option (const char *s); -static StgWord64 decodeSize(const char *flag, nat offset, StgWord64 min, StgWord64 max); -static void bad_option(const char *s); #ifdef TRACING static void read_trace_flags(char *arg); #endif +static void errorUsage (void) GNU_ATTRIBUTE(__noreturn__); + +static char * copyArg (char *arg); +static char ** copyArgv (int argc, char *argv[]); +static void freeArgv (int argc, char *argv[]); + /* ----------------------------------------------------------------------------- * Command-line option parsing routines. * ---------------------------------------------------------------------------*/ @@ -69,6 +88,8 @@ RtsFlags.GcFlags.maxStkSize = (8 * 1024 * 1024) / sizeof(W_); RtsFlags.GcFlags.initialStkSize = 1024 / sizeof(W_); + RtsFlags.GcFlags.stkChunkSize = (32 * 1024) / sizeof(W_); + RtsFlags.GcFlags.stkChunkBufferSize = (1 * 1024) / sizeof(W_); RtsFlags.GcFlags.minAllocAreaSize = (512 * 1024) / BLOCK_SIZE; RtsFlags.GcFlags.minOldGenSize = (1024 * 1024) / BLOCK_SIZE; @@ -154,7 +175,6 @@ #ifdef THREADED_RTS RtsFlags.ParFlags.nNodes = 1; RtsFlags.ParFlags.migrate = rtsTrue; - RtsFlags.ParFlags.wakeupMigrate = rtsFalse; RtsFlags.ParFlags.parGcEnabled = 1; RtsFlags.ParFlags.parGcGen = 0; RtsFlags.ParFlags.parGcLoadBalancingEnabled = rtsTrue; @@ -194,7 +214,9 @@ " --info Print information about the RTS used by this program", "", " -K Sets the maximum stack size (default 8M) Egs: -K32k -K512k", -" -k Sets the initial thread stack size (default 1k) Egs: -k4k -k2m", +" -ki Sets the initial thread stack size (default 1k) Egs: -ki4k -ki2m", +" -kc Sets the stack chunk size (default 32k)", +" -kb Sets the stack chunk buffer size (default 1k)", "", " -A Sets the minimum allocation area size (default 512k) Egs: -A1m -A10k", " -M Sets the maximum heap size (default unlimited) Egs: -M256k -M1G", @@ -302,7 +324,7 @@ " -Da DEBUG: apply", " -Dl DEBUG: linker", " -Dm DEBUG: stm", -" -Dz DEBUG: stack squezing", +" -Dz DEBUG: stack squeezing", " -Dc DEBUG: program coverage", " -Dr DEBUG: sparks", "", @@ -319,7 +341,6 @@ " (default: 1, -qb alone turns off load-balancing)", " -qa Use the OS to set thread affinity (experimental)", " -qm Don't automatically migrate threads between CPUs", -" -qw Migrate a thread to the current CPU when it is woken up", #endif " --install-signal-handlers=", " Install signal handlers (default: yes)", @@ -358,8 +379,7 @@ return(strcmp(a, b) == 0); } -static void -splitRtsFlags(char *s, int *rts_argc, char *rts_argv[]) +static void splitRtsFlags(char *s) { char *c1, *c2; @@ -371,40 +391,59 @@ if (c1 == c2) { break; } - if (*rts_argc < MAX_RTS_ARGS-1) { - s = stgMallocBytes(c2-c1+1, "RtsFlags.c:splitRtsFlags()"); - strncpy(s, c1, c2-c1); - s[c2-c1] = '\0'; - rts_argv[(*rts_argc)++] = s; - } else { - barf("too many RTS arguments (max %d)", MAX_RTS_ARGS-1); - } - + s = stgMallocBytes(c2-c1+1, "RtsFlags.c:splitRtsFlags()"); + strncpy(s, c1, c2-c1); + s[c2-c1] = '\0'; + rts_argv[rts_argc++] = s; + c1 = c2; } while (*c1 != '\0'); } -void -setupRtsFlags(int *argc, char *argv[], int *rts_argc, char *rts_argv[]) +/* ----------------------------------------------------------------------------- + Parse the command line arguments, collecting options for the RTS. + + On return: + - argv[] is *modified*, any RTS options have been stripped out + - *argc contains the new count of arguments in argv[] + + - rts_argv[] (global) contains a copy of the collected RTS args + - rts_argc (global) contains the count of args in rts_argv + + - prog_argv[] (global) contains a copy of the non-RTS args (== argv) + - prog_argc (global) contains the count of args in prog_argv + + - prog_name (global) contains the basename of prog_argv[0] + + -------------------------------------------------------------------------- */ + +void setupRtsFlags (int *argc, char *argv[]) { - rtsBool error = rtsFalse; - I_ mode; - I_ arg, total_arg; + nat mode; + nat total_arg; + nat arg, rts_argc0; setProgName (argv); total_arg = *argc; arg = 1; *argc = 1; - *rts_argc = 0; + rts_argc = 0; + + rts_argv = stgCallocBytes(total_arg + 1, sizeof (char *), "setupRtsFlags"); + + rts_argc0 = rts_argc; // process arguments from the ghc_rts_opts global variable first. // (arguments from the GHCRTS environment variable and the command // line override these). { if (ghc_rts_opts != NULL) { - splitRtsFlags(ghc_rts_opts, rts_argc, rts_argv); - } + splitRtsFlags(ghc_rts_opts); + // opts from ghc_rts_opts are always enabled: + procRtsOpts(rts_argc0, RtsOptsAll); + rts_argc0 = rts_argc; + } } // process arguments from the GHCRTS environment variable next @@ -413,14 +452,15 @@ char *ghc_rts = getenv("GHCRTS"); if (ghc_rts != NULL) { - if (rtsOptsEnabled != rtsOptsNone) { - splitRtsFlags(ghc_rts, rts_argc, rts_argv); - } - else { + if (rtsOptsEnabled == RtsOptsNone) { errorBelch("Warning: Ignoring GHCRTS variable as RTS options are disabled.\n Link with -rtsopts to enable them."); // We don't actually exit, just warn + } else { + splitRtsFlags(ghc_rts); + procRtsOpts(rts_argc0, rtsOptsEnabled); + rts_argc0 = rts_argc; } - } + } } // Split arguments (argv) into PGM (argv) and RTS (rts_argv) parts @@ -438,25 +478,16 @@ break; } else if (strequal("+RTS", argv[arg])) { - if (rtsOptsEnabled != rtsOptsNone) { - mode = RTS; - } - else { - errorBelch("RTS options are disabled. Link with -rtsopts to enable them."); - stg_exit(EXIT_FAILURE); - } - } + mode = RTS; + } else if (strequal("-RTS", argv[arg])) { mode = PGM; } - else if (mode == RTS && *rts_argc < MAX_RTS_ARGS-1) { - rts_argv[(*rts_argc)++] = argv[arg]; + else if (mode == RTS) { + rts_argv[rts_argc++] = copyArg(argv[arg]); } - else if (mode == PGM) { - argv[(*argc)++] = argv[arg]; - } - else { - barf("too many RTS arguments (max %d)", MAX_RTS_ARGS-1); + else { + argv[(*argc)++] = argv[arg]; } } // process remaining program arguments @@ -464,17 +495,45 @@ argv[(*argc)++] = argv[arg]; } argv[*argc] = (char *) 0; - rts_argv[*rts_argc] = (char *) 0; + rts_argv[rts_argc] = (char *) 0; + + procRtsOpts(rts_argc0, rtsOptsEnabled); + + normaliseRtsOpts(); + + setProgArgv(*argc, argv); + + if (RtsFlags.GcFlags.statsFile != NULL) { + initStatsFile (RtsFlags.GcFlags.statsFile); + } + if (RtsFlags.TickyFlags.tickyFile != NULL) { + initStatsFile (RtsFlags.GcFlags.statsFile); + } +} + +/* ----------------------------------------------------------------------------- + * procRtsOpts: Process rts_argv between rts_argc0 and rts_argc. + * -------------------------------------------------------------------------- */ + +static void procRtsOpts (int rts_argc0, RtsOptsEnabledEnum enabled) +{ + rtsBool error = rtsFalse; + int arg; // Process RTS (rts_argv) part: mainly to determine statsfile - for (arg = 0; arg < *rts_argc; arg++) { - if (rts_argv[arg][0] != '-') { + for (arg = rts_argc0; arg < rts_argc; arg++) { + if (rts_argv[arg][0] != '-') { fflush(stdout); errorBelch("unexpected RTS argument: %s", rts_argv[arg]); error = rtsTrue; } else { + if (enabled == RtsOptsNone) { + errorBelch("RTS options are disabled. Link with -rtsopts to enable them."); + stg_exit(EXIT_FAILURE); + } + switch(rts_argv[arg][1]) { case '-': if (strequal("info", &rts_argv[arg][2])) { @@ -486,8 +545,7 @@ break; } - if (rtsOptsEnabled != rtsOptsAll) - { + if (enabled == RtsOptsSafeOnly) { errorBelch("Most RTS options are disabled. Link with -rtsopts to enable them."); stg_exit(EXIT_FAILURE); } @@ -704,15 +762,31 @@ case 'K': RtsFlags.GcFlags.maxStkSize = - decodeSize(rts_argv[arg], 2, 1, HS_WORD_MAX) / sizeof(W_); + decodeSize(rts_argv[arg], 2, sizeof(W_), HS_WORD_MAX) / sizeof(W_); break; case 'k': + switch(rts_argv[arg][2]) { + case 'c': + RtsFlags.GcFlags.stkChunkSize = + decodeSize(rts_argv[arg], 3, sizeof(W_), HS_WORD_MAX) / sizeof(W_); + break; + case 'b': + RtsFlags.GcFlags.stkChunkBufferSize = + decodeSize(rts_argv[arg], 3, sizeof(W_), HS_WORD_MAX) / sizeof(W_); + break; + case 'i': + RtsFlags.GcFlags.initialStkSize = + decodeSize(rts_argv[arg], 3, sizeof(W_), HS_WORD_MAX) / sizeof(W_); + break; + default: RtsFlags.GcFlags.initialStkSize = - decodeSize(rts_argv[arg], 2, 1, HS_WORD_MAX) / sizeof(W_); + decodeSize(rts_argv[arg], 2, sizeof(W_), HS_WORD_MAX) / sizeof(W_); break; + } + break; - case 'M': + case 'M': RtsFlags.GcFlags.maxHeapSize = decodeSize(rts_argv[arg], 2, BLOCK_SIZE, HS_WORD_MAX) / BLOCK_SIZE; /* user give size in *bytes* but "maxHeapSize" is in *blocks* */ @@ -773,9 +847,8 @@ stats: { int r; - r = open_stats_file(arg, *argc, argv, - *rts_argc, rts_argv, NULL, - &RtsFlags.GcFlags.statsFile); + r = openStatsFile(rts_argv[arg]+2, NULL, + &RtsFlags.GcFlags.statsFile); if (r == -1) { error = rtsTrue; } } break; @@ -1047,10 +1120,10 @@ case 'm': RtsFlags.ParFlags.migrate = rtsFalse; break; - case 'w': - RtsFlags.ParFlags.wakeupMigrate = rtsTrue; - break; - default: + case 'w': + // -qw was removed; accepted for backwards compat + break; + default: errorBelch("unknown RTS option: %s",rts_argv[arg]); error = rtsTrue; break; @@ -1079,9 +1152,9 @@ { int r; - r = open_stats_file(arg, *argc, argv, - *rts_argc, rts_argv, TICKY_FILENAME_FMT, - &RtsFlags.TickyFlags.tickyFile); + r = openStatsFile(rts_argv[arg]+2, + TICKY_FILENAME_FMT, + &RtsFlags.TickyFlags.tickyFile); if (r == -1) { error = rtsTrue; } } ) break; @@ -1166,6 +1239,16 @@ } } + if (error) errorUsage(); +} + +/* ----------------------------------------------------------------------------- + * normaliseRtsOpts: Set some derived values, and make sure things are + * within sensible ranges. + * -------------------------------------------------------------------------- */ + +static void normaliseRtsOpts (void) +{ if (RtsFlags.MiscFlags.tickInterval < 0) { RtsFlags.MiscFlags.tickInterval = 50; } @@ -1214,16 +1297,22 @@ RtsFlags.ProfFlags.profileIntervalTicks = 0; } - if (error) { - const char **p; - - fflush(stdout); - for (p = usage_text; *p; p++) - errorBelch("%s", *p); - stg_exit(EXIT_FAILURE); + if (RtsFlags.GcFlags.stkChunkBufferSize > + RtsFlags.GcFlags.stkChunkSize / 2) { + errorBelch("stack chunk buffer size (-kb) must be less than 50%% of the stack chunk size (-kc)"); + errorUsage(); } } +static void errorUsage (void) +{ + const char **p; + + fflush(stdout); + for (p = usage_text; *p; p++) + errorBelch("%s", *p); + stg_exit(EXIT_FAILURE); +} static void stats_fprintf(FILE *f, char *s, ...) @@ -1238,49 +1327,62 @@ va_end(ap); } -static int /* return -1 on error */ -open_stats_file ( - I_ arg, - int argc, char *argv[], - int rts_argc, char *rts_argv[], - const char *FILENAME_FMT, - FILE **file_ret) +/* ----------------------------------------------------------------------------- + * openStatsFile: open a file in which to put some runtime stats + * -------------------------------------------------------------------------- */ + +static int // return -1 on error +openStatsFile (char *filename, // filename, or NULL + const char *filename_fmt, // if filename == NULL, use + // this fmt with sprintf to + // generate the filename. %s + // expands to the program name. + FILE **file_ret) // return the FILE* { FILE *f = NULL; - if (strequal(rts_argv[arg]+2, "stderr") - || (FILENAME_FMT == NULL && rts_argv[arg][2] == '\0')) { + if (strequal(filename, "stderr") + || (filename_fmt == NULL && *filename == '\0')) { f = NULL; /* NULL means use debugBelch */ } else { - if (rts_argv[arg][2] != '\0') { /* stats file specified */ - f = fopen(rts_argv[arg]+2,"w"); + if (*filename != '\0') { /* stats file specified */ + f = fopen(filename,"w"); } else { char stats_filename[STATS_FILENAME_MAXLEN]; /* default . */ - sprintf(stats_filename, FILENAME_FMT, argv[0]); + sprintf(stats_filename, filename_fmt, prog_name); f = fopen(stats_filename,"w"); } if (f == NULL) { - errorBelch("Can't open stats file %s\n", rts_argv[arg]+2); + errorBelch("Can't open stats file %s\n", filename); return -1; } } *file_ret = f; - { - /* Write argv and rtsv into start of stats file */ - int count; - for(count = 0; count < argc; count++) { - stats_fprintf(f, "%s ", argv[count]); - } - stats_fprintf(f, "+RTS "); - for(count = 0; count < rts_argc; count++) - stats_fprintf(f, "%s ", rts_argv[count]); - stats_fprintf(f, "\n"); - } return 0; } +/* ----------------------------------------------------------------------------- + * initStatsFile: write a line to the file containing the program name + * and the arguments it was invoked with. +-------------------------------------------------------------------------- */ + +static void initStatsFile (FILE *f) +{ + /* Write prog_argv and rts_argv into start of stats file */ + int count; + for (count = 0; count < prog_argc; count++) { + stats_fprintf(f, "%s ", prog_argv[count]); + } + stats_fprintf(f, "+RTS "); + for (count = 0; count < rts_argc; count++) + stats_fprintf(f, "%s ", rts_argv[count]); + stats_fprintf(f, "\n"); +} +/* ----------------------------------------------------------------------------- + * decodeSize: parse a string containing a size, like 300K or 1.2M +-------------------------------------------------------------------------- */ static StgWord64 decodeSize(const char *flag, nat offset, StgWord64 min, StgWord64 max) @@ -1356,6 +1458,41 @@ stg_exit(EXIT_FAILURE); } +/* ---------------------------------------------------------------------------- + Copying and freeing argc/argv + ------------------------------------------------------------------------- */ + +static char * copyArg(char *arg) +{ + char *new_arg = stgMallocBytes(strlen(arg) + 1, "copyArg"); + strcpy(new_arg, arg); + return new_arg; +} + +static char ** copyArgv(int argc, char *argv[]) +{ + int i; + char **new_argv; + + new_argv = stgCallocBytes(argc + 1, sizeof (char *), "copyArgv 1"); + for (i = 0; i < argc; i++) { + new_argv[i] = copyArg(argv[i]); + } + new_argv[argc] = NULL; + return new_argv; +} + +static void freeArgv(int argc, char *argv[]) +{ + int i; + if (argv != NULL) { + for (i = 0; i < argc; i++) { + stgFree(argv[i]); + } + stgFree(argv); + } +} + /* ----------------------------------------------------------------------------- Getting/Setting the program's arguments. @@ -1396,14 +1533,28 @@ void setProgArgv(int argc, char *argv[]) { - /* Usually this is done by startupHaskell, so we don't need to call this. - However, sometimes Hugs wants to change the arguments which Haskell - getArgs >>= ... will be fed. So you can do that by calling here - _after_ calling startupHaskell. - */ - prog_argc = argc; - prog_argv = argv; - setProgName(prog_argv); + prog_argc = argc; + prog_argv = copyArgv(argc,argv); + setProgName(prog_argv); +} + +static void +freeProgArgv(void) +{ + freeArgv(prog_argc,prog_argv); + prog_argc = 0; + prog_argv = NULL; +} + +/* ---------------------------------------------------------------------------- + The full argv - a copy of the original program's argc/argv + ------------------------------------------------------------------------- */ + +void +setFullProgArgv(int argc, char *argv[]) +{ + full_prog_argc = argc; + full_prog_argv = copyArgv(argc,argv); } /* These functions record and recall the full arguments, including the @@ -1417,32 +1568,89 @@ } void -setFullProgArgv(int argc, char *argv[]) +freeFullProgArgv (void) { - int i; - full_prog_argc = argc; - full_prog_argv = stgCallocBytes(argc + 1, sizeof (char *), - "setFullProgArgv 1"); - for (i = 0; i < argc; i++) { - full_prog_argv[i] = stgMallocBytes(strlen(argv[i]) + 1, - "setFullProgArgv 2"); - strcpy(full_prog_argv[i], argv[i]); - } - full_prog_argv[argc] = NULL; + freeArgv(full_prog_argc, full_prog_argv); + full_prog_argc = 0; + full_prog_argv = NULL; } +/* ---------------------------------------------------------------------------- + The Win32 argv + ------------------------------------------------------------------------- */ + +#if defined(mingw32_HOST_OS) +void freeWin32ProgArgv (void); + void -freeFullProgArgv (void) +freeWin32ProgArgv (void) { int i; - if (full_prog_argv != NULL) { - for (i = 0; i < full_prog_argc; i++) { - stgFree(full_prog_argv[i]); + if (win32_prog_argv != NULL) { + for (i = 0; i < win32_prog_argc; i++) { + stgFree(win32_prog_argv[i]); } - stgFree(full_prog_argv); + stgFree(win32_prog_argv); } - full_prog_argc = 0; - full_prog_argv = NULL; + win32_prog_argc = 0; + win32_prog_argv = NULL; +} + +void +getWin32ProgArgv(int *argc, wchar_t **argv[]) +{ + *argc = win32_prog_argc; + *argv = win32_prog_argv; +} + +void +setWin32ProgArgv(int argc, wchar_t *argv[]) +{ + int i; + + freeWin32ProgArgv(); + + win32_prog_argc = argc; + if (argv == NULL) { + win32_prog_argv = NULL; + return; + } + + win32_prog_argv = stgCallocBytes(argc + 1, sizeof (wchar_t *), + "setWin32ProgArgv 1"); + for (i = 0; i < argc; i++) { + win32_prog_argv[i] = stgMallocBytes((wcslen(argv[i]) + 1) * sizeof(wchar_t), + "setWin32ProgArgv 2"); + wcscpy(win32_prog_argv[i], argv[i]); + } + win32_prog_argv[argc] = NULL; +} +#endif + +/* ---------------------------------------------------------------------------- + The RTS argv + ------------------------------------------------------------------------- */ + +static void +freeRtsArgv(void) +{ + freeArgv(rts_argc,rts_argv); + rts_argc = 0; + rts_argv = NULL; +} + +/* ---------------------------------------------------------------------------- + All argvs + ------------------------------------------------------------------------- */ + +void freeRtsArgs(void) +{ +#if defined(mingw32_HOST_OS) + freeWin32ProgArgv(); +#endif + freeFullProgArgv(); + freeProgArgv(); + freeRtsArgv(); } diff -Nru ghc-7.0.3/rts/RtsFlags.h ghc-7.2.1/rts/RtsFlags.h --- ghc-7.0.3/rts/RtsFlags.h 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/rts/RtsFlags.h 2011-08-07 17:10:05.000000000 +0000 @@ -0,0 +1,24 @@ +/* ----------------------------------------------------------------------------- + * + * (c) The AQUA Project, Glasgow University, 1994-1997 + * (c) The GHC Team, 1998-2006 + * + * Functions for parsing the argument list. + * + * ---------------------------------------------------------------------------*/ + +#ifndef RTSFLAGS_H +#define RTSFLAGS_H + +#include "BeginPrivate.h" + +/* Routines that operate-on/to-do-with RTS flags: */ + +void initRtsFlagsDefaults (void); +void setupRtsFlags (int *argc, char *argv[]); +void setProgName (char *argv[]); +void freeRtsArgs (void); + +#include "EndPrivate.h" + +#endif /* RTSFLAGS_H */ diff -Nru ghc-7.0.3/rts/RtsMain.c ghc-7.2.1/rts/RtsMain.c --- ghc-7.0.3/rts/RtsMain.c 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/rts/RtsMain.c 2011-08-07 17:10:05.000000000 +0000 @@ -28,13 +28,10 @@ # include #endif -extern void __stginit_ZCMain(void); - /* Annoying global vars for passing parameters to real_main() below * This is to get around problem with Windows SEH, see hs_main(). */ static int progargc; static char **progargv; -static void (*progmain_init)(void); /* This will be __stginit_ZCMain */ static StgClosure *progmain_closure; /* This will be ZCMain_main_closure */ /* Hack: we assume that we're building a batch-mode system unless @@ -47,7 +44,7 @@ SchedulerStatus status; /* all GranSim/GUM init is done in startupHaskell; sets IAmMainThread! */ - startupHaskell(progargc,progargv,progmain_init); + startupHaskell(progargc,progargv,NULL); /* kick off the computation by creating the main thread with a pointer to mainIO_closure representing the computation of the overall program; @@ -95,18 +92,17 @@ * This gets called from a tiny main function which gets linked into each * compiled Haskell program that uses a Haskell main function. * - * We expect the caller to pass __stginit_ZCMain for main_init and - * ZCMain_main_closure for main_closure. The reason we cannot refer to - * these symbols directly is because we're inside the rts and we do not know - * for sure that we'll be using a Haskell main function. + * We expect the caller to pass ZCMain_main_closure for + * main_closure. The reason we cannot refer to this symbol directly + * is because we're inside the rts and we do not know for sure that + * we'll be using a Haskell main function. */ -int hs_main(int argc, char *argv[], void (*main_init)(void), StgClosure *main_closure) +int hs_main(int argc, char *argv[], StgClosure *main_closure) { /* We do this dance with argc and argv as otherwise the SEH exception stuff (the BEGIN/END CATCH below) on Windows gets confused */ progargc = argc; progargv = argv; - progmain_init = main_init; progmain_closure = main_closure; #if defined(mingw32_HOST_OS) diff -Nru ghc-7.0.3/rts/RtsMain.h ghc-7.2.1/rts/RtsMain.h --- ghc-7.0.3/rts/RtsMain.h 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/rts/RtsMain.h 2011-08-07 17:10:05.000000000 +0000 @@ -13,6 +13,6 @@ * The entry point for Haskell programs that use a Haskell main function * -------------------------------------------------------------------------- */ -int hs_main(int argc, char *argv[], void (*main_init)(void), StgClosure *main_closure); +int hs_main(int argc, char *argv[], StgClosure *main_closure); #endif /* RTSMAIN_H */ diff -Nru ghc-7.0.3/rts/RtsProbes.d ghc-7.2.1/rts/RtsProbes.d --- ghc-7.0.3/rts/RtsProbes.d 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/rts/RtsProbes.d 2011-08-07 17:10:05.000000000 +0000 @@ -23,6 +23,8 @@ * typedef uint16_t EventCapNo; * typedef uint16_t EventPayloadSize; // variable-size events * typedef uint16_t EventThreadStatus; + * typedef uint32_t EventCapsetID; + * typedef uint16_t EventCapsetType; // types for EVENT_CAPSET_CREATE */ /* ----------------------------------------------------------------------------- @@ -38,7 +40,7 @@ /* scheduler events */ probe create__thread (EventCapNo, EventThreadID); probe run__thread (EventCapNo, EventThreadID); - probe stop__thread (EventCapNo, EventThreadID, EventThreadStatus); + probe stop__thread (EventCapNo, EventThreadID, EventThreadStatus, EventThreadID); probe thread__runnable (EventCapNo, EventThreadID); probe migrate__thread (EventCapNo, EventThreadID, EventCapNo); probe run__spark (EventCapNo, EventThreadID); @@ -60,5 +62,9 @@ probe gc__idle (EventCapNo); probe gc__work (EventCapNo); probe gc__done (EventCapNo); + probe capset__create(EventCapsetID, EventCapsetType); + probe capset__delete(EventCapsetID); + probe capset__assign__cap(EventCapsetID, EventCapNo); + probe capset__remove__cap(EventCapsetID, EventCapNo); }; diff -Nru ghc-7.0.3/rts/RtsStartup.c ghc-7.2.1/rts/RtsStartup.c --- ghc-7.0.3/rts/RtsStartup.c 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/rts/RtsStartup.c 2011-08-07 17:10:05.000000000 +0000 @@ -16,6 +16,7 @@ #include "HsFFI.h" #include "sm/Storage.h" +#include "RtsFlags.h" #include "RtsUtils.h" #include "Prelude.h" #include "Schedule.h" /* initScheduler */ @@ -69,8 +70,8 @@ static int hs_init_count = 0; /* ----------------------------------------------------------------------------- - Initialise floating point unit on x86 (currently disabled. why?) - (see comment in ghc/compiler/nativeGen/MachInstrs.lhs). + Initialise floating point unit on x86 (currently disabled; See Note + [x86 Floating point precision] in compiler/nativeGen/X86/Instr.hs) -------------------------------------------------------------------------- */ #define X86_INIT_FPU 0 @@ -129,8 +130,7 @@ /* Parse the flags, separating the RTS flags from the programs args */ if (argc != NULL && argv != NULL) { setFullProgArgv(*argc,*argv); - setupRtsFlags(argc, *argv, &rts_argc, rts_argv); - setProgArgv(*argc,*argv); + setupRtsFlags(argc, *argv); } /* Initialise the stats department, phase 1 */ @@ -144,15 +144,18 @@ #ifdef TRACING initTracing(); #endif - /* Dtrace events are always enabled + /* Trace the startup event */ - dtraceEventStartup(); + traceEventStartup(); /* initialise scheduler data structures (needs to be done before * initStorage()). */ initScheduler(); + /* Trace some basic information about the process */ + traceOSProcessInfo(); + /* initialize the storage manager */ initStorage(); @@ -224,90 +227,37 @@ x86_init_fpu(); #endif + startupHpc(); + + // This must be done after module initialisation. + // ToDo: make this work in the presence of multiple hs_add_root()s. + initProfiling2(); + + // ditto. +#if defined(THREADED_RTS) + ioManagerStart(); +#endif + /* Record initialization times */ stat_endInit(); } // Compatibility interface void -startupHaskell(int argc, char *argv[], void (*init_root)(void)) +startupHaskell(int argc, char *argv[], void (*init_root)(void) STG_UNUSED) { hs_init(&argc, &argv); - if(init_root) - hs_add_root(init_root); } /* ----------------------------------------------------------------------------- - Per-module initialisation - - This process traverses all the compiled modules in the program - starting with "Main", and performing per-module initialisation for - each one. - - So far, two things happen at initialisation time: - - - we register stable names for each foreign-exported function - in that module. This prevents foreign-exported entities, and - things they depend on, from being garbage collected. - - - we supply a unique integer to each statically declared cost - centre and cost centre stack in the program. - - The code generator inserts a small function "__stginit_" in each - module and calls the registration functions in each of the modules it - imports. - - The init* functions are compiled in the same way as STG code, - i.e. without normal C call/return conventions. Hence we must use - StgRun to call this stuff. + hs_add_root: backwards compatibility. (see #3252) -------------------------------------------------------------------------- */ -/* The init functions use an explicit stack... - */ -#define INIT_STACK_BLOCKS 4 -static StgFunPtr *init_stack = NULL; - void -hs_add_root(void (*init_root)(void)) +hs_add_root(void (*init_root)(void) STG_UNUSED) { - bdescr *bd; - nat init_sp; - Capability *cap; - - cap = rts_lock(); - - if (hs_init_count <= 0) { - barf("hs_add_root() must be called after hs_init()"); - } - - /* The initialisation stack grows downward, with sp pointing - to the last occupied word */ - init_sp = INIT_STACK_BLOCKS*BLOCK_SIZE_W; - bd = allocGroup_lock(INIT_STACK_BLOCKS); - init_stack = (StgFunPtr *)bd->start; - init_stack[--init_sp] = (StgFunPtr)stg_init_finish; - if (init_root != NULL) { - init_stack[--init_sp] = (StgFunPtr)init_root; - } - - cap->r.rSp = (P_)(init_stack + init_sp); - StgRun((StgFunPtr)stg_init, &cap->r); - - freeGroup_lock(bd); - - startupHpc(); - - // This must be done after module initialisation. - // ToDo: make this work in the presence of multiple hs_add_root()s. - initProfiling2(); - - rts_unlock(cap); - - // ditto. -#if defined(THREADED_RTS) - ioManagerStart(); -#endif + /* nothing */ } /* ---------------------------------------------------------------------------- @@ -345,8 +295,10 @@ OnExitHook(); - // Free the full argv storage - freeFullProgArgv(); + // sanity check +#if defined(DEBUG) + checkFPUStack(); +#endif #if defined(THREADED_RTS) ioManagerDie(); @@ -419,7 +371,7 @@ #endif endProfiling(); - freeProfiling1(); + freeProfiling(); #ifdef PROFILING // Originally, this was in report_ccs_profiling(). Now, retainer @@ -450,6 +402,8 @@ // heap memory (e.g. by being passed a ByteArray#). freeStorage(wait_foreign); + // Free the various argvs + freeRtsArgs(); } // The real hs_exit(): diff -Nru ghc-7.0.3/rts/RtsUtils.c ghc-7.2.1/rts/RtsUtils.c --- ghc-7.0.3/rts/RtsUtils.c 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/rts/RtsUtils.c 2011-08-07 17:10:05.000000000 +0000 @@ -323,3 +323,18 @@ return 0; #endif } + +// Used for detecting a non-empty FPU stack on x86 (see #4914) +void checkFPUStack(void) +{ +#ifdef x86_HOST_ARCH + static unsigned char buf[108]; + asm("FSAVE %0":"=m" (buf)); + + if(buf[8]!=255 || buf[9]!=255) { + errorBelch("NONEMPTY FPU Stack, TAG = %x %x\n",buf[8],buf[9]); + abort(); + } +#endif +} + diff -Nru ghc-7.0.3/rts/RtsUtils.h ghc-7.2.1/rts/RtsUtils.h --- ghc-7.0.3/rts/RtsUtils.h 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/rts/RtsUtils.h 2011-08-07 17:10:05.000000000 +0000 @@ -46,6 +46,8 @@ /* Alternate to raise(3) for threaded rts, for OpenBSD */ int genericRaise(int sig); +void checkFPUStack(void); + #include "EndPrivate.h" #endif /* RTSUTILS_H */ diff -Nru ghc-7.0.3/rts/Schedule.c ghc-7.2.1/rts/Schedule.c --- ghc-7.0.3/rts/Schedule.c 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/rts/Schedule.c 2011-08-07 17:10:05.000000000 +0000 @@ -140,9 +140,7 @@ #endif static void schedulePostRunThread(Capability *cap, StgTSO *t); static rtsBool scheduleHandleHeapOverflow( Capability *cap, StgTSO *t ); -static void scheduleHandleStackOverflow( Capability *cap, Task *task, - StgTSO *t); -static rtsBool scheduleHandleYield( Capability *cap, StgTSO *t, +static rtsBool scheduleHandleYield( Capability *cap, StgTSO *t, nat prev_what_next ); static void scheduleHandleThreadBlocked( StgTSO *t ); static rtsBool scheduleHandleThreadFinished( Capability *cap, Task *task, @@ -151,9 +149,6 @@ static Capability *scheduleDoGC(Capability *cap, Task *task, rtsBool force_major); -static StgTSO *threadStackOverflow(Capability *cap, StgTSO *tso); -static StgTSO *threadStackUnderflow(Capability *cap, Task *task, StgTSO *tso); - static void deleteThread (Capability *cap, StgTSO *tso); static void deleteAllThreads (Capability *cap); @@ -426,6 +421,7 @@ cap->in_haskell = rtsTrue; dirty_TSO(cap,t); + dirty_STACK(cap,t->stackobj); #if defined(THREADED_RTS) if (recent_activity == ACTIVITY_DONE_GC) { @@ -488,7 +484,17 @@ t->saved_winerror = GetLastError(); #endif - traceEventStopThread(cap, t, ret); + if (ret == ThreadBlocked) { + if (t->why_blocked == BlockedOnBlackHole) { + StgTSO *owner = blackHoleOwner(t->block_info.bh->bh); + traceEventStopThread(cap, t, t->why_blocked + 6, + owner != NULL ? owner->id : 0); + } else { + traceEventStopThread(cap, t, t->why_blocked + 6, 0); + } + } else { + traceEventStopThread(cap, t, ret, 0); + } ASSERT_FULL_CAPABILITY_INVARIANTS(cap,task); ASSERT(t->cap == cap); @@ -503,10 +509,6 @@ schedulePostRunThread(cap,t); - if (ret != StackOverflow) { - t = threadStackUnderflow(cap,task,t); - } - ready_to_gc = rtsFalse; switch (ret) { @@ -515,8 +517,11 @@ break; case StackOverflow: - scheduleHandleStackOverflow(cap,task,t); - break; + // just adjust the stack for this thread, then pop it back + // on the run queue. + threadStackOverflow(cap, t); + pushOnRunQueue(cap,t); + break; case ThreadYielding: if (scheduleHandleYield(cap, t, prev_what_next)) { @@ -576,6 +581,10 @@ schedulePreLoop(void) { // initialisation for scheduler - what cannot go into initScheduler() + +#if defined(mingw32_HOST_OS) + win32AllocStack(); +#endif } /* ----------------------------------------------------------------------------- @@ -710,7 +719,9 @@ if (n_free_caps > 0) { StgTSO *prev, *t, *next; +#ifdef SPARK_PUSHING rtsBool pushed_to_all; +#endif debugTrace(DEBUG_sched, "cap %d: %s and %d free capabilities, sharing...", @@ -720,7 +731,9 @@ n_free_caps); i = 0; +#ifdef SPARK_PUSHING pushed_to_all = rtsFalse; +#endif if (cap->run_queue_hd != END_TSO_QUEUE) { prev = cap->run_queue_hd; @@ -729,14 +742,15 @@ for (; t != END_TSO_QUEUE; t = next) { next = t->_link; t->_link = END_TSO_QUEUE; - if (t->what_next == ThreadRelocated - || t->bound == task->incall // don't move my bound thread + if (t->bound == task->incall // don't move my bound thread || tsoLocked(t)) { // don't move a locked thread setTSOLink(cap, prev, t); setTSOPrev(cap, t, prev); prev = t; } else if (i == n_free_caps) { +#ifdef SPARK_PUSHING pushed_to_all = rtsTrue; +#endif i = 0; // keep one for us setTSOLink(cap, prev, t); @@ -947,14 +961,38 @@ scheduleProcessInbox (Capability *cap USED_IF_THREADS) { #if defined(THREADED_RTS) - Message *m; + Message *m, *next; + int r; while (!emptyInbox(cap)) { - ACQUIRE_LOCK(&cap->lock); + if (cap->r.rCurrentNursery->link == NULL || + g0->n_new_large_words >= large_alloc_lim) { + scheduleDoGC(cap, cap->running_task, rtsFalse); + } + + // don't use a blocking acquire; if the lock is held by + // another thread then just carry on. This seems to avoid + // getting stuck in a message ping-pong situation with other + // processors. We'll check the inbox again later anyway. + // + // We should really use a more efficient queue data structure + // here. The trickiness is that we must ensure a Capability + // never goes idle if the inbox is non-empty, which is why we + // use cap->lock (cap->lock is released as the last thing + // before going idle; see Capability.c:releaseCapability()). + r = TRY_ACQUIRE_LOCK(&cap->lock); + if (r != 0) return; + m = cap->inbox; - cap->inbox = m->link; + cap->inbox = (Message*)END_TSO_QUEUE; + RELEASE_LOCK(&cap->lock); - executeMessage(cap, (Message *)m); + + while (m != (Message*)END_TSO_QUEUE) { + next = m->link; + executeMessage(cap, m); + m = next; + } } #endif } @@ -1038,10 +1076,8 @@ cap->r.rNursery->n_blocks == 1) { // paranoia to prevent infinite loop // if the nursery has only one block. - ACQUIRE_SM_LOCK - bd = allocGroup( blocks ); - RELEASE_SM_LOCK - cap->r.rNursery->n_blocks += blocks; + bd = allocGroup_lock(blocks); + cap->r.rNursery->n_blocks += blocks; // link the new group into the list bd->link = cap->r.rCurrentNursery; @@ -1100,30 +1136,6 @@ } /* ----------------------------------------------------------------------------- - * Handle a thread that returned to the scheduler with ThreadStackOverflow - * -------------------------------------------------------------------------- */ - -static void -scheduleHandleStackOverflow (Capability *cap, Task *task, StgTSO *t) -{ - /* just adjust the stack for this thread, then pop it back - * on the run queue. - */ - { - /* enlarge the stack */ - StgTSO *new_t = threadStackOverflow(cap, t); - - /* The TSO attached to this Task may have moved, so update the - * pointer to it. - */ - if (task->incall->tso == t) { - task->incall->tso = new_t; - } - pushOnRunQueue(cap,new_t); - } -} - -/* ----------------------------------------------------------------------------- * Handle a thread that returned to the scheduler with ThreadYielding * -------------------------------------------------------------------------- */ @@ -1243,8 +1255,8 @@ if (t->what_next == ThreadComplete) { if (task->incall->ret) { - // NOTE: return val is tso->sp[1] (see StgStartup.hc) - *(task->incall->ret) = (StgClosure *)task->incall->tso->sp[1]; + // NOTE: return val is stack->sp[1] (see StgStartup.hc) + *(task->incall->ret) = (StgClosure *)task->incall->tso->stackobj->sp[1]; } task->incall->stat = Success; } else { @@ -1422,9 +1434,9 @@ // reset waiting_for_gc *before* GC, so that when the GC threads // emerge they don't immediately re-enter the GC. waiting_for_gc = 0; - GarbageCollect(force_major || heap_census, gc_type, cap); + GarbageCollect(force_major || heap_census, heap_census, gc_type, cap); #else - GarbageCollect(force_major || heap_census, 0, cap); + GarbageCollect(force_major || heap_census, heap_census, 0, cap); #endif traceEventGcEnd(cap); @@ -1445,6 +1457,11 @@ recent_activity = ACTIVITY_YES; } + // The heap census itself is done during GarbageCollect(). + if (heap_census) { + performHeapProfile = rtsFalse; + } + #if defined(THREADED_RTS) if (gc_type == PENDING_GC_PAR) { @@ -1452,12 +1469,6 @@ } #endif - if (heap_census) { - debugTrace(DEBUG_sched, "performing heap census"); - heapCensus(); - performHeapProfile = rtsFalse; - } - if (heap_overflow && sched_state < SCHED_INTERRUPTING) { // GC set the heap_overflow flag, so we should proceed with // an orderly shutdown now. Ultimately we want the main @@ -1580,10 +1591,7 @@ for (g = 0; g < RtsFlags.GcFlags.generations; g++) { for (t = generations[g].threads; t != END_TSO_QUEUE; t = next) { - if (t->what_next == ThreadRelocated) { - next = t->_link; - } else { - next = t->global_link; + next = t->global_link; // don't allow threads to catch the ThreadKilled // exception, but we do want to raiseAsync() because these // threads may be evaluating thunks that we need later. @@ -1595,7 +1603,6 @@ // won't get a chance to exit in the usual way (see // also scheduleHandleThreadFinished). t->bound = NULL; - } } } @@ -1622,7 +1629,8 @@ // Wipe our spare workers list, they no longer exist. New // workers will be created if necessary. cap->spare_workers = NULL; - cap->returning_tasks_hd = NULL; + cap->n_spare_workers = 0; + cap->returning_tasks_hd = NULL; cap->returning_tasks_tl = NULL; #endif @@ -1662,12 +1670,8 @@ debugTrace(DEBUG_sched,"deleting all threads"); for (g = 0; g < RtsFlags.GcFlags.generations; g++) { for (t = generations[g].threads; t != END_TSO_QUEUE; t = next) { - if (t->what_next == ThreadRelocated) { - next = t->_link; - } else { next = t->global_link; deleteThread(cap,t); - } } } @@ -1731,13 +1735,17 @@ * the whole system. * * The Haskell thread making the C call is put to sleep for the - * duration of the call, on the susepended_ccalling_threads queue. We + * duration of the call, on the suspended_ccalling_threads queue. We * give out a token to the task, which it can use to resume the thread * on return from the C function. + * + * If this is an interruptible C call, this means that the FFI call may be + * unceremoniously terminated and should be scheduled on an + * unbound worker thread. * ------------------------------------------------------------------------- */ void * -suspendThread (StgRegTable *reg) +suspendThread (StgRegTable *reg, rtsBool interruptible) { Capability *cap; int saved_errno; @@ -1759,19 +1767,17 @@ task = cap->running_task; tso = cap->r.rCurrentTSO; - traceEventStopThread(cap, tso, THREAD_SUSPENDED_FOREIGN_CALL); + traceEventStopThread(cap, tso, THREAD_SUSPENDED_FOREIGN_CALL, 0); // XXX this might not be necessary --SDM tso->what_next = ThreadRunGHC; threadPaused(cap,tso); - if ((tso->flags & TSO_BLOCKEX) == 0) { - tso->why_blocked = BlockedOnCCall; - tso->flags |= TSO_BLOCKEX; - tso->flags &= ~TSO_INTERRUPTIBLE; + if (interruptible) { + tso->why_blocked = BlockedOnCCall_Interruptible; } else { - tso->why_blocked = BlockedOnCCall_NoUnblockExc; + tso->why_blocked = BlockedOnCCall; } // Hand back capability @@ -1830,17 +1836,16 @@ traceEventRunThread(cap, tso); - if (tso->why_blocked == BlockedOnCCall) { + /* Reset blocking status */ + tso->why_blocked = NotBlocked; + + if ((tso->flags & TSO_BLOCKEX) == 0) { // avoid locking the TSO if we don't have to if (tso->blocked_exceptions != END_BLOCKED_EXCEPTIONS_QUEUE) { - awakenBlockedExceptionQueue(cap,tso); + maybePerformBlockedException(cap,tso); } - tso->flags &= ~(TSO_BLOCKEX | TSO_INTERRUPTIBLE); } - /* Reset blocking status */ - tso->why_blocked = NotBlocked; - cap->r.rCurrentTSO = tso; cap->in_haskell = rtsTrue; errno = saved_errno; @@ -1850,6 +1855,7 @@ /* We might have GC'd, mark the TSO dirty again */ dirty_TSO(cap,tso); + dirty_STACK(cap,tso->stackobj); IF_DEBUG(sanity, checkTSO(tso)); @@ -1877,9 +1883,9 @@ void scheduleThreadOn(Capability *cap, StgWord cpu USED_IF_THREADS, StgTSO *tso) { -#if defined(THREADED_RTS) tso->flags |= TSO_LOCKED; // we requested explicit affinity; don't // move this thread from now on. +#if defined(THREADED_RTS) cpu %= RtsFlags.ParFlags.nNodes; if (cpu == cap->no) { appendToRunQueue(cap,tso); @@ -1895,7 +1901,7 @@ scheduleWaitThread (StgTSO* tso, /*[out]*/HaskellObj* ret, Capability *cap) { Task *task; - StgThreadID id; + DEBUG_ONLY( StgThreadID id ); // We already created/initialised the Task task = cap->running_task; @@ -1911,7 +1917,7 @@ appendToRunQueue(cap,tso); - id = tso->id; + DEBUG_ONLY( id = tso->id ); debugTrace(DEBUG_sched, "new bound thread (%lu)", (unsigned long)id); cap = schedule(cap,task); @@ -2033,16 +2039,7 @@ } sched_state = SCHED_SHUTTING_DOWN; -#if defined(THREADED_RTS) - { - nat i; - - for (i = 0; i < n_capabilities; i++) { - ASSERT(task->incall->tso == NULL); - shutdownCapability(&capabilities[i], task, wait_foreign); - } - } -#endif + shutdownCapabilities(task, wait_foreign); boundTaskExiting(task); } @@ -2072,6 +2069,16 @@ #endif } +void markScheduler (evac_fn evac USED_IF_NOT_THREADS, + void *user USED_IF_NOT_THREADS) +{ +#if !defined(THREADED_RTS) + evac(user, (StgClosure **)(void *)&blocked_queue_hd); + evac(user, (StgClosure **)(void *)&blocked_queue_tl); + evac(user, (StgClosure **)(void *)&sleeping_queue); +#endif +} + /* ----------------------------------------------------------------------------- performGC @@ -2108,189 +2115,6 @@ performGC_(rtsTrue); } -/* ----------------------------------------------------------------------------- - Stack overflow - - If the thread has reached its maximum stack size, then raise the - StackOverflow exception in the offending thread. Otherwise - relocate the TSO into a larger chunk of memory and adjust its stack - size appropriately. - -------------------------------------------------------------------------- */ - -static StgTSO * -threadStackOverflow(Capability *cap, StgTSO *tso) -{ - nat new_stack_size, stack_words; - lnat new_tso_size; - StgPtr new_sp; - StgTSO *dest; - - IF_DEBUG(sanity,checkTSO(tso)); - - if (tso->stack_size >= tso->max_stack_size - && !(tso->flags & TSO_BLOCKEX)) { - // NB. never raise a StackOverflow exception if the thread is - // inside Control.Exceptino.block. It is impractical to protect - // against stack overflow exceptions, since virtually anything - // can raise one (even 'catch'), so this is the only sensible - // thing to do here. See bug #767. - // - - if (tso->flags & TSO_SQUEEZED) { - return tso; - } - // #3677: In a stack overflow situation, stack squeezing may - // reduce the stack size, but we don't know whether it has been - // reduced enough for the stack check to succeed if we try - // again. Fortunately stack squeezing is idempotent, so all we - // need to do is record whether *any* squeezing happened. If we - // are at the stack's absolute -K limit, and stack squeezing - // happened, then we try running the thread again. The - // TSO_SQUEEZED flag is set by threadPaused() to tell us whether - // squeezing happened or not. - - debugTrace(DEBUG_gc, - "threadStackOverflow of TSO %ld (%p): stack too large (now %ld; max is %ld)", - (long)tso->id, tso, (long)tso->stack_size, (long)tso->max_stack_size); - IF_DEBUG(gc, - /* If we're debugging, just print out the top of the stack */ - printStackChunk(tso->sp, stg_min(tso->stack+tso->stack_size, - tso->sp+64))); - - // Send this thread the StackOverflow exception - throwToSingleThreaded(cap, tso, (StgClosure *)stackOverflow_closure); - return tso; - } - - - // We also want to avoid enlarging the stack if squeezing has - // already released some of it. However, we don't want to get into - // a pathalogical situation where a thread has a nearly full stack - // (near its current limit, but not near the absolute -K limit), - // keeps allocating a little bit, squeezing removes a little bit, - // and then it runs again. So to avoid this, if we squeezed *and* - // there is still less than BLOCK_SIZE_W words free, then we enlarge - // the stack anyway. - if ((tso->flags & TSO_SQUEEZED) && - ((W_)(tso->sp - tso->stack) >= BLOCK_SIZE_W)) { - return tso; - } - - /* Try to double the current stack size. If that takes us over the - * maximum stack size for this thread, then use the maximum instead - * (that is, unless we're already at or over the max size and we - * can't raise the StackOverflow exception (see above), in which - * case just double the size). Finally round up so the TSO ends up as - * a whole number of blocks. - */ - if (tso->stack_size >= tso->max_stack_size) { - new_stack_size = tso->stack_size * 2; - } else { - new_stack_size = stg_min(tso->stack_size * 2, tso->max_stack_size); - } - new_tso_size = (lnat)BLOCK_ROUND_UP(new_stack_size * sizeof(W_) + - TSO_STRUCT_SIZE)/sizeof(W_); - new_tso_size = round_to_mblocks(new_tso_size); /* Be MBLOCK-friendly */ - new_stack_size = new_tso_size - TSO_STRUCT_SIZEW; - - debugTrace(DEBUG_sched, - "increasing stack size from %ld words to %d.", - (long)tso->stack_size, new_stack_size); - - dest = (StgTSO *)allocate(cap,new_tso_size); - TICK_ALLOC_TSO(new_stack_size,0); - - /* copy the TSO block and the old stack into the new area */ - memcpy(dest,tso,TSO_STRUCT_SIZE); - stack_words = tso->stack + tso->stack_size - tso->sp; - new_sp = (P_)dest + new_tso_size - stack_words; - memcpy(new_sp, tso->sp, stack_words * sizeof(W_)); - - /* relocate the stack pointers... */ - dest->sp = new_sp; - dest->stack_size = new_stack_size; - - /* Mark the old TSO as relocated. We have to check for relocated - * TSOs in the garbage collector and any primops that deal with TSOs. - * - * It's important to set the sp value to just beyond the end - * of the stack, so we don't attempt to scavenge any part of the - * dead TSO's stack. - */ - setTSOLink(cap,tso,dest); - write_barrier(); // other threads seeing ThreadRelocated will look at _link - tso->what_next = ThreadRelocated; - tso->sp = (P_)&(tso->stack[tso->stack_size]); - tso->why_blocked = NotBlocked; - - IF_DEBUG(sanity,checkTSO(dest)); -#if 0 - IF_DEBUG(scheduler,printTSO(dest)); -#endif - - return dest; -} - -static StgTSO * -threadStackUnderflow (Capability *cap, Task *task, StgTSO *tso) -{ - bdescr *bd, *new_bd; - lnat free_w, tso_size_w; - StgTSO *new_tso; - - tso_size_w = tso_sizeW(tso); - - if (tso_size_w < MBLOCK_SIZE_W || - // TSO is less than 2 mblocks (since the first mblock is - // shorter than MBLOCK_SIZE_W) - (tso_size_w - BLOCKS_PER_MBLOCK*BLOCK_SIZE_W) % MBLOCK_SIZE_W != 0 || - // or TSO is not a whole number of megablocks (ensuring - // precondition of splitLargeBlock() below) - (tso_size_w <= round_up_to_mblocks(RtsFlags.GcFlags.initialStkSize)) || - // or TSO is smaller than the minimum stack size (rounded up) - (nat)(tso->stack + tso->stack_size - tso->sp) > tso->stack_size / 4) - // or stack is using more than 1/4 of the available space - { - // then do nothing - return tso; - } - - // this is the number of words we'll free - free_w = round_to_mblocks(tso_size_w/2); - - bd = Bdescr((StgPtr)tso); - new_bd = splitLargeBlock(bd, free_w / BLOCK_SIZE_W); - bd->free = bd->start + TSO_STRUCT_SIZEW; - - new_tso = (StgTSO *)new_bd->start; - memcpy(new_tso,tso,TSO_STRUCT_SIZE); - new_tso->stack_size = new_bd->free - new_tso->stack; - - // The original TSO was dirty and probably on the mutable - // list. The new TSO is not yet on the mutable list, so we better - // put it there. - new_tso->dirty = 0; - new_tso->flags &= ~TSO_LINK_DIRTY; - dirty_TSO(cap, new_tso); - - debugTrace(DEBUG_sched, "thread %ld: reducing TSO size from %lu words to %lu", - (long)tso->id, tso_size_w, tso_sizeW(new_tso)); - - tso->_link = new_tso; // no write barrier reqd: same generation - write_barrier(); // other threads seeing ThreadRelocated will look at _link - tso->what_next = ThreadRelocated; - - // The TSO attached to this Task may have moved, so update the - // pointer to it. - if (task->incall->tso == tso) { - task->incall->tso = new_tso; - } - - IF_DEBUG(sanity,checkTSO(new_tso)); - - return new_tso; -} - /* --------------------------------------------------------------------------- Interrupt execution - usually called inside a signal handler so it mustn't do anything fancy. @@ -2337,7 +2161,7 @@ exception. -------------------------------------------------------------------------- */ -static void +static void deleteThread (Capability *cap STG_UNUSED, StgTSO *tso) { // NOTE: must only be called on a TSO that we have exclusive @@ -2346,19 +2170,19 @@ // we must own all Capabilities. if (tso->why_blocked != BlockedOnCCall && - tso->why_blocked != BlockedOnCCall_NoUnblockExc) { - throwToSingleThreaded(tso->cap,tso,NULL); + tso->why_blocked != BlockedOnCCall_Interruptible) { + throwToSingleThreaded(tso->cap,tso,NULL); } } #ifdef FORKPROCESS_PRIMOP_SUPPORTED -static void +static void deleteThread_(Capability *cap, StgTSO *tso) { // for forkProcess only: // like deleteThread(), but we delete threads in foreign calls, too. if (tso->why_blocked == BlockedOnCCall || - tso->why_blocked == BlockedOnCCall_NoUnblockExc) { + tso->why_blocked == BlockedOnCCall_Interruptible) { tso->what_next = ThreadKilled; appendToRunQueue(tso->cap, tso); } else { @@ -2406,7 +2230,7 @@ // we update any closures pointed to from update frames with the // raise closure that we just built. // - p = tso->sp; + p = tso->stackobj->sp; while(1) { info = get_ret_itbl((StgClosure *)p); next = p + stack_frame_sizeW((StgClosure *)p); @@ -2427,20 +2251,26 @@ case ATOMICALLY_FRAME: debugTrace(DEBUG_stm, "found ATOMICALLY_FRAME at %p", p); - tso->sp = p; + tso->stackobj->sp = p; return ATOMICALLY_FRAME; case CATCH_FRAME: - tso->sp = p; + tso->stackobj->sp = p; return CATCH_FRAME; case CATCH_STM_FRAME: debugTrace(DEBUG_stm, "found CATCH_STM_FRAME at %p", p); - tso->sp = p; + tso->stackobj->sp = p; return CATCH_STM_FRAME; - case STOP_FRAME: - tso->sp = p; + case UNDERFLOW_FRAME: + tso->stackobj->sp = p; + threadStackUnderflow(cap,tso); + p = tso->stackobj->sp; + continue; + + case STOP_FRAME: + tso->stackobj->sp = p; return STOP_FRAME; case CATCH_RETRY_FRAME: @@ -2470,12 +2300,12 @@ -------------------------------------------------------------------------- */ StgWord -findRetryFrameHelper (StgTSO *tso) +findRetryFrameHelper (Capability *cap, StgTSO *tso) { StgPtr p, next; StgRetInfoTable *info; - p = tso -> sp; + p = tso->stackobj->sp; while (1) { info = get_ret_itbl((StgClosure *)p); next = p + stack_frame_sizeW((StgClosure *)p); @@ -2484,13 +2314,13 @@ case ATOMICALLY_FRAME: debugTrace(DEBUG_stm, "found ATOMICALLY_FRAME at %p during retry", p); - tso->sp = p; + tso->stackobj->sp = p; return ATOMICALLY_FRAME; case CATCH_RETRY_FRAME: debugTrace(DEBUG_stm, "found CATCH_RETRY_FRAME at %p during retrry", p); - tso->sp = p; + tso->stackobj->sp = p; return CATCH_RETRY_FRAME; case CATCH_STM_FRAME: { @@ -2499,13 +2329,17 @@ debugTrace(DEBUG_stm, "found CATCH_STM_FRAME at %p during retry", p); debugTrace(DEBUG_stm, "trec=%p outer=%p", trec, outer); - stmAbortTransaction(tso -> cap, trec); - stmFreeAbortedTRec(tso -> cap, trec); + stmAbortTransaction(cap, trec); + stmFreeAbortedTRec(cap, trec); tso -> trec = outer; p = next; continue; } + case UNDERFLOW_FRAME: + threadStackUnderflow(cap,tso); + p = tso->stackobj->sp; + continue; default: ASSERT(info->i.type != CATCH_FRAME); diff -Nru ghc-7.0.3/rts/Schedule.h ghc-7.2.1/rts/Schedule.h --- ghc-7.0.3/rts/Schedule.h 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/rts/Schedule.h 2011-08-07 17:10:05.000000000 +0000 @@ -23,6 +23,7 @@ void initScheduler (void); void exitScheduler (rtsBool wait_foreign); void freeScheduler (void); +void markScheduler (evac_fn evac, void *user); // Place a new thread on the run queue of the current Capability void scheduleThread (Capability *cap, StgTSO *tso); @@ -44,7 +45,7 @@ StgWord raiseExceptionHelper (StgRegTable *reg, StgTSO *tso, StgClosure *exception); /* findRetryFrameHelper */ -StgWord findRetryFrameHelper (StgTSO *tso); +StgWord findRetryFrameHelper (Capability *cap, StgTSO *tso); /* Entry point for a new worker */ void scheduleWorker (Capability *cap, Task *task); diff -Nru ghc-7.0.3/rts/sm/BlockAlloc.c ghc-7.2.1/rts/sm/BlockAlloc.c --- ghc-7.0.3/rts/sm/BlockAlloc.c 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/rts/sm/BlockAlloc.c 2011-08-07 17:10:05.000000000 +0000 @@ -332,9 +332,7 @@ bd = alloc_mega_group(mblocks); // only the bdescrs of the first MB are required to be initialised initGroup(bd); - - IF_DEBUG(sanity, checkFreeListSanity()); - return bd; + goto finish; } n_alloc_blocks += n; @@ -347,8 +345,9 @@ } if (ln == MAX_FREE_LIST) { -#if 0 - if (((W_)mblocks_allocated * MBLOCK_SIZE_W - (W_)n_alloc_blocks * BLOCK_SIZE_W) > (1024*1024)/sizeof(W_)) { +#if 0 /* useful for debugging fragmentation */ + if ((W_)mblocks_allocated * BLOCKS_PER_MBLOCK * BLOCK_SIZE_W + - (W_)((n_alloc_blocks - n) * BLOCK_SIZE_W) > (2*1024*1024)/sizeof(W_)) { debugBelch("Fragmentation, wanted %d blocks:", n); RtsFlags.DebugFlags.block_alloc = 1; checkFreeListSanity(); @@ -363,8 +362,7 @@ initGroup(rem); // init the slop n_alloc_blocks += rem->blocks; freeGroup(rem); // add the slop on to the free list - IF_DEBUG(sanity, checkFreeListSanity()); - return bd; + goto finish; } bd = free_list[ln]; @@ -372,18 +370,22 @@ if (bd->blocks == n) // exactly the right size! { dbl_link_remove(bd, &free_list[ln]); + initGroup(bd); } else if (bd->blocks > n) // block too big... { bd = split_free_block(bd, n, ln); + ASSERT(bd->blocks == n); + initGroup(bd); } else { barf("allocGroup: free list corrupted"); } - initGroup(bd); // initialise it + +finish: + IF_DEBUG(sanity, memset(bd->start, 0xaa, bd->blocks * BLOCK_SIZE)); IF_DEBUG(sanity, checkFreeListSanity()); - ASSERT(bd->blocks == n); return bd; } @@ -576,48 +578,6 @@ RELEASE_SM_LOCK; } -// splitBlockGroup(bd,B) splits bd in two. Afterward, bd will have B -// blocks, and a new block descriptor pointing to the remainder is -// returned. -bdescr * -splitBlockGroup (bdescr *bd, nat blocks) -{ - bdescr *new_bd; - - if (bd->blocks <= blocks) { - barf("splitLargeBlock: too small"); - } - - if (bd->blocks > BLOCKS_PER_MBLOCK) { - nat low_mblocks, high_mblocks; - void *new_mblock; - if ((blocks - BLOCKS_PER_MBLOCK) % (MBLOCK_SIZE / BLOCK_SIZE) != 0) { - barf("splitLargeBlock: not a multiple of a megablock"); - } - low_mblocks = 1 + (blocks - BLOCKS_PER_MBLOCK) / (MBLOCK_SIZE / BLOCK_SIZE); - high_mblocks = (bd->blocks - blocks) / (MBLOCK_SIZE / BLOCK_SIZE); - - new_mblock = (void *) ((P_)MBLOCK_ROUND_DOWN(bd) + (W_)low_mblocks * MBLOCK_SIZE_W); - initMBlock(new_mblock); - new_bd = FIRST_BDESCR(new_mblock); - new_bd->blocks = MBLOCK_GROUP_BLOCKS(high_mblocks); - - ASSERT(blocks + new_bd->blocks == - bd->blocks + BLOCKS_PER_MBLOCK - MBLOCK_SIZE/BLOCK_SIZE); - } - else - { - // NB. we're not updating all the bdescrs in the split groups to - // point to the new heads, so this can only be used for large - // objects which do not start in the non-head block. - new_bd = bd + blocks; - new_bd->blocks = bd->blocks - blocks; - } - bd->blocks = blocks; - - return new_bd; -} - static void initMBlock(void *mblock) { diff -Nru ghc-7.0.3/rts/sm/Compact.c ghc-7.2.1/rts/sm/Compact.c --- ghc-7.0.3/rts/sm/Compact.c 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/rts/sm/Compact.c 2011-08-07 17:10:05.000000000 +0000 @@ -14,6 +14,7 @@ #include "PosixSource.h" #include "Rts.h" +#include "GCThread.h" #include "Storage.h" #include "RtsUtils.h" #include "BlockAlloc.h" @@ -335,8 +336,9 @@ case CATCH_STM_FRAME: case ATOMICALLY_FRAME: case UPDATE_FRAME: - case STOP_FRAME: - case CATCH_FRAME: + case UNDERFLOW_FRAME: + case STOP_FRAME: + case CATCH_FRAME: case RET_SMALL: bitmap = BITMAP_BITS(info->i.layout.bitmap); size = BITMAP_SIZE(info->i.layout.bitmap); @@ -480,8 +482,8 @@ thread_(&tso->trec); - thread_stack(tso->sp, &(tso->stack[tso->stack_size])); - return (StgPtr)tso + tso_sizeW(tso); + thread_(&tso->stackobj); + return (StgPtr)tso + sizeofW(StgTSO); } @@ -521,9 +523,12 @@ continue; } - case TSO: - thread_TSO((StgTSO *)p); - continue; + case STACK: + { + StgStack *stack = (StgStack*)p; + thread_stack(stack->sp, stack->stack + stack->stack_size); + continue; + } case AP_STACK: thread_AP_STACK((StgAP_STACK *)p); @@ -706,6 +711,13 @@ case TSO: return thread_TSO((StgTSO *)p); + case STACK: + { + StgStack *stack = (StgStack*)p; + thread_stack(stack->sp, stack->stack + stack->stack_size); + return p + stack_sizeW(stack); + } + case TREC_CHUNK: { StgWord i; @@ -899,8 +911,8 @@ } // relocate TSOs - if (info->type == TSO) { - move_TSO((StgTSO *)p, (StgTSO *)free); + if (info->type == STACK) { + move_STACK((StgStack *)p, (StgStack *)free); } free += size; @@ -924,12 +936,14 @@ void compact(StgClosure *static_objects) { - nat g, blocks; + nat n, g, blocks; generation *gen; // 1. thread the roots markCapabilities((evac_fn)thread_root, NULL); + markScheduler((evac_fn)thread_root, NULL); + // the weak pointer lists... if (weak_ptr_list != NULL) { thread((void *)&weak_ptr_list); @@ -942,12 +956,6 @@ for (g = 1; g < RtsFlags.GcFlags.generations; g++) { bdescr *bd; StgPtr p; - nat n; - for (bd = generations[g].mut_list; bd != NULL; bd = bd->link) { - for (p = bd->start; p < bd->free; p++) { - thread((StgClosure **)p); - } - } for (n = 0; n < n_capabilities; n++) { for (bd = capabilities[n].mut_lists[g]; bd != NULL; bd = bd->link) { @@ -995,6 +1003,10 @@ debugTrace(DEBUG_gc, "update_fwd: %d", g); update_fwd(gen->blocks); + for (n = 0; n < n_capabilities; n++) { + update_fwd(gc_threads[n]->gens[g].todo_bd); + update_fwd(gc_threads[n]->gens[g].part_list); + } update_fwd_large(gen->scavenged_large_objects); if (g == RtsFlags.GcFlags.generations-1 && gen->old_blocks != NULL) { debugTrace(DEBUG_gc, "update_fwd: %d (compact)", g); diff -Nru ghc-7.0.3/rts/sm/Evac.c ghc-7.2.1/rts/sm/Evac.c --- ghc-7.0.3/rts/sm/Evac.c 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/rts/sm/Evac.c 2011-08-07 17:10:05.000000000 +0000 @@ -18,6 +18,7 @@ #include "Storage.h" #include "GC.h" #include "GCThread.h" +#include "GCTDecl.h" #include "GCUtils.h" #include "Compact.h" #include "MarkStack.h" @@ -51,7 +52,7 @@ -------------------------------------------------------------------------- */ STATIC_INLINE StgPtr -alloc_for_copy (nat size, generation *gen) +alloc_for_copy (nat size, nat gen_no) { StgPtr to; gen_workspace *ws; @@ -61,17 +62,16 @@ * evacuate to an older generation, adjust it here (see comment * by evacuate()). */ - if (gen < gct->evac_gen) { + if (gen_no < gct->evac_gen_no) { if (gct->eager_promotion) { - gen = gct->evac_gen; + gen_no = gct->evac_gen_no; } else { gct->failed_to_evac = rtsTrue; } } - ws = &gct->gens[gen->no]; - // this compiles to a single mem access to gen->abs_no only - + ws = &gct->gens[gen_no]; // zero memory references here + /* chain a new block onto the to-space for the destination gen if * necessary. */ @@ -91,12 +91,12 @@ STATIC_INLINE GNUC_ATTR_HOT void copy_tag(StgClosure **p, const StgInfoTable *info, - StgClosure *src, nat size, generation *gen, StgWord tag) + StgClosure *src, nat size, nat gen_no, StgWord tag) { StgPtr to, from; nat i; - to = alloc_for_copy(size,gen); + to = alloc_for_copy(size,gen_no); from = (StgPtr)src; to[0] = (W_)info; @@ -133,12 +133,12 @@ #if defined(PARALLEL_GC) STATIC_INLINE void copy_tag_nolock(StgClosure **p, const StgInfoTable *info, - StgClosure *src, nat size, generation *gen, StgWord tag) + StgClosure *src, nat size, nat gen_no, StgWord tag) { StgPtr to, from; nat i; - to = alloc_for_copy(size,gen); + to = alloc_for_copy(size,gen_no); from = (StgPtr)src; to[0] = (W_)info; @@ -170,7 +170,7 @@ */ static rtsBool copyPart(StgClosure **p, StgClosure *src, nat size_to_reserve, - nat size_to_copy, generation *gen) + nat size_to_copy, nat gen_no) { StgPtr to, from; nat i; @@ -194,7 +194,7 @@ info = (W_)src->header.info; #endif - to = alloc_for_copy(size_to_reserve, gen); + to = alloc_for_copy(size_to_reserve, gen_no); from = (StgPtr)src; to[0] = info; @@ -222,9 +222,9 @@ /* Copy wrappers that don't tag the closure after copying */ STATIC_INLINE GNUC_ATTR_HOT void copy(StgClosure **p, const StgInfoTable *info, - StgClosure *src, nat size, generation *gen) + StgClosure *src, nat size, nat gen_no) { - copy_tag(p,info,src,size,gen,0); + copy_tag(p,info,src,size,gen_no,0); } /* ----------------------------------------------------------------------------- @@ -243,22 +243,24 @@ { bdescr *bd; generation *gen, *new_gen; + nat gen_no, new_gen_no; gen_workspace *ws; bd = Bdescr(p); gen = bd->gen; - ACQUIRE_SPIN_LOCK(&gen->sync_large_objects); + gen_no = bd->gen_no; + ACQUIRE_SPIN_LOCK(&gen->sync); // already evacuated? if (bd->flags & BF_EVACUATED) { /* Don't forget to set the gct->failed_to_evac flag if we didn't get * the desired destination (see comments in evacuate()). */ - if (gen < gct->evac_gen) { + if (gen_no < gct->evac_gen_no) { gct->failed_to_evac = rtsTrue; TICK_GC_FAILED_PROMOTION(); } - RELEASE_SPIN_LOCK(&gen->sync_large_objects); + RELEASE_SPIN_LOCK(&gen->sync); return; } @@ -274,16 +276,18 @@ /* link it on to the evacuated large object list of the destination gen */ - new_gen = bd->dest; - if (new_gen < gct->evac_gen) { + new_gen_no = bd->dest_no; + + if (new_gen_no < gct->evac_gen_no) { if (gct->eager_promotion) { - new_gen = gct->evac_gen; + new_gen_no = gct->evac_gen_no; } else { gct->failed_to_evac = rtsTrue; } } - ws = &gct->gens[new_gen->no]; + ws = &gct->gens[new_gen_no]; + new_gen = &generations[new_gen_no]; bd->flags |= BF_EVACUATED; initBdescr(bd, new_gen, new_gen->to); @@ -294,16 +298,16 @@ // them straight on the scavenged_large_objects list. if (bd->flags & BF_PINNED) { ASSERT(get_itbl((StgClosure *)p)->type == ARR_WORDS); - if (new_gen != gen) { ACQUIRE_SPIN_LOCK(&new_gen->sync_large_objects); } + if (new_gen != gen) { ACQUIRE_SPIN_LOCK(&new_gen->sync); } dbl_link_onto(bd, &new_gen->scavenged_large_objects); new_gen->n_scavenged_large_blocks += bd->blocks; - if (new_gen != gen) { RELEASE_SPIN_LOCK(&new_gen->sync_large_objects); } + if (new_gen != gen) { RELEASE_SPIN_LOCK(&new_gen->sync); } } else { bd->link = ws->todo_large_objects; ws->todo_large_objects = bd; } - RELEASE_SPIN_LOCK(&gen->sync_large_objects); + RELEASE_SPIN_LOCK(&gen->sync); } /* ---------------------------------------------------------------------------- @@ -352,7 +356,7 @@ evacuate(StgClosure **p) { bdescr *bd = NULL; - generation *gen; + nat gen_no; StgClosure *q; const StgInfoTable *info; StgWord tag; @@ -475,7 +479,7 @@ // We aren't copying this object, so we have to check // whether it is already in the target generation. (this is // the write barrier). - if (bd->gen < gct->evac_gen) { + if (bd->gen_no < gct->evac_gen_no) { gct->failed_to_evac = rtsTrue; TICK_GC_FAILED_PROMOTION(); } @@ -485,14 +489,7 @@ /* evacuate large objects by re-linking them onto a different list. */ if (bd->flags & BF_LARGE) { - info = get_itbl(q); - if (info->type == TSO && - ((StgTSO *)q)->what_next == ThreadRelocated) { - q = (StgClosure *)((StgTSO *)q)->_link; - *p = q; - goto loop; - } - evacuate_large((P_)q); + evacuate_large((P_)q); return; } @@ -506,7 +503,7 @@ return; } - gen = bd->dest; + gen_no = bd->dest_no; info = q->header.info; if (IS_FORWARDING_PTR(info)) @@ -529,8 +526,8 @@ */ StgClosure *e = (StgClosure*)UN_FORWARDING_PTR(info); *p = TAG_CLOSURE(tag,e); - if (gen < gct->evac_gen) { // optimisation - if (Bdescr((P_)e)->gen < gct->evac_gen) { + if (gen_no < gct->evac_gen_no) { // optimisation + if (Bdescr((P_)e)->gen_no < gct->evac_gen_no) { gct->failed_to_evac = rtsTrue; TICK_GC_FAILED_PROMOTION(); } @@ -547,7 +544,7 @@ case MUT_VAR_DIRTY: case MVAR_CLEAN: case MVAR_DIRTY: - copy(p,info,q,sizeW_fromITBL(INFO_PTR_TO_STRUCT(info)),gen); + copy(p,info,q,sizeW_fromITBL(INFO_PTR_TO_STRUCT(info)),gen_no); return; // For ints and chars of low value, save space by replacing references to @@ -559,7 +556,7 @@ case CONSTR_0_1: { #if defined(__PIC__) && defined(mingw32_HOST_OS) - copy_tag_nolock(p,info,q,sizeofW(StgHeader)+1,gen,tag); + copy_tag_nolock(p,info,q,sizeofW(StgHeader)+1,gen_no,tag); #else StgWord w = (StgWord)q->payload[0]; if (info == Czh_con_info && @@ -576,7 +573,7 @@ ); } else { - copy_tag_nolock(p,info,q,sizeofW(StgHeader)+1,gen,tag); + copy_tag_nolock(p,info,q,sizeofW(StgHeader)+1,gen_no,tag); } #endif return; @@ -585,12 +582,12 @@ case FUN_0_1: case FUN_1_0: case CONSTR_1_0: - copy_tag_nolock(p,info,q,sizeofW(StgHeader)+1,gen,tag); + copy_tag_nolock(p,info,q,sizeofW(StgHeader)+1,gen_no,tag); return; case THUNK_1_0: case THUNK_0_1: - copy(p,info,q,sizeofW(StgThunk)+1,gen); + copy(p,info,q,sizeofW(StgThunk)+1,gen_no); return; case THUNK_1_1: @@ -599,7 +596,7 @@ #ifdef NO_PROMOTE_THUNKS #error bitrotted #endif - copy(p,info,q,sizeofW(StgThunk)+2,gen); + copy(p,info,q,sizeofW(StgThunk)+2,gen_no); return; case FUN_1_1: @@ -607,21 +604,21 @@ case FUN_0_2: case CONSTR_1_1: case CONSTR_2_0: - copy_tag_nolock(p,info,q,sizeofW(StgHeader)+2,gen,tag); + copy_tag_nolock(p,info,q,sizeofW(StgHeader)+2,gen_no,tag); return; case CONSTR_0_2: - copy_tag_nolock(p,info,q,sizeofW(StgHeader)+2,gen,tag); + copy_tag_nolock(p,info,q,sizeofW(StgHeader)+2,gen_no,tag); return; case THUNK: - copy(p,info,q,thunk_sizeW_fromITBL(INFO_PTR_TO_STRUCT(info)),gen); + copy(p,info,q,thunk_sizeW_fromITBL(INFO_PTR_TO_STRUCT(info)),gen_no); return; case FUN: case IND_PERM: case CONSTR: - copy_tag_nolock(p,info,q,sizeW_fromITBL(INFO_PTR_TO_STRUCT(info)),gen,tag); + copy_tag_nolock(p,info,q,sizeW_fromITBL(INFO_PTR_TO_STRUCT(info)),gen_no,tag); return; case BLACKHOLE: @@ -639,7 +636,7 @@ || i == &stg_WHITEHOLE_info || i == &stg_BLOCKING_QUEUE_CLEAN_info || i == &stg_BLOCKING_QUEUE_DIRTY_info) { - copy(p,info,q,sizeofW(StgInd),gen); + copy(p,info,q,sizeofW(StgInd),gen_no); return; } ASSERT(i != &stg_IND_info); @@ -653,11 +650,11 @@ case WEAK: case PRIM: case MUT_PRIM: - copy(p,info,q,sizeW_fromITBL(INFO_PTR_TO_STRUCT(info)),gen); + copy(p,info,q,sizeW_fromITBL(INFO_PTR_TO_STRUCT(info)),gen_no); return; case BCO: - copy(p,info,q,bco_sizeW((StgBCO *)q),gen); + copy(p,info,q,bco_sizeW((StgBCO *)q),gen_no); return; case THUNK_SELECTOR: @@ -675,6 +672,7 @@ case RET_BIG: case RET_DYN: case UPDATE_FRAME: + case UNDERFLOW_FRAME: case STOP_FRAME: case CATCH_FRAME: case CATCH_STM_FRAME: @@ -684,20 +682,20 @@ barf("evacuate: stack frame at %p\n", q); case PAP: - copy(p,info,q,pap_sizeW((StgPAP*)q),gen); + copy(p,info,q,pap_sizeW((StgPAP*)q),gen_no); return; case AP: - copy(p,info,q,ap_sizeW((StgAP*)q),gen); + copy(p,info,q,ap_sizeW((StgAP*)q),gen_no); return; case AP_STACK: - copy(p,info,q,ap_stack_sizeW((StgAP_STACK*)q),gen); + copy(p,info,q,ap_stack_sizeW((StgAP_STACK*)q),gen_no); return; case ARR_WORDS: // just copy the block - copy(p,info,q,arr_words_sizeW((StgArrWords *)q),gen); + copy(p,info,q,arr_words_sizeW((StgArrWords *)q),gen_no); return; case MUT_ARR_PTRS_CLEAN: @@ -705,35 +703,31 @@ case MUT_ARR_PTRS_FROZEN: case MUT_ARR_PTRS_FROZEN0: // just copy the block - copy(p,info,q,mut_arr_ptrs_sizeW((StgMutArrPtrs *)q),gen); + copy(p,info,q,mut_arr_ptrs_sizeW((StgMutArrPtrs *)q),gen_no); return; case TSO: - { - StgTSO *tso = (StgTSO *)q; + copy(p,info,q,sizeofW(StgTSO),gen_no); + return; - /* Deal with redirected TSOs (a TSO that's had its stack enlarged). - */ - if (tso->what_next == ThreadRelocated) { - q = (StgClosure *)tso->_link; - *p = q; - goto loop; - } + case STACK: + { + StgStack *stack = (StgStack *)q; - /* To evacuate a small TSO, we need to adjust the stack pointer + /* To evacuate a small STACK, we need to adjust the stack pointer */ { - StgTSO *new_tso; + StgStack *new_stack; StgPtr r, s; rtsBool mine; - mine = copyPart(p,(StgClosure *)tso, tso_sizeW(tso), - sizeofW(StgTSO), gen); + mine = copyPart(p,(StgClosure *)stack, stack_sizeW(stack), + sizeofW(StgStack), gen_no); if (mine) { - new_tso = (StgTSO *)*p; - move_TSO(tso, new_tso); - for (r = tso->sp, s = new_tso->sp; - r < tso->stack+tso->stack_size;) { + new_stack = (StgStack *)*p; + move_STACK(stack, new_stack); + for (r = stack->sp, s = new_stack->sp; + r < stack->stack + stack->stack_size;) { *s++ = *r++; } } @@ -742,7 +736,7 @@ } case TREC_CHUNK: - copy(p,info,q,sizeofW(StgTRecChunk),gen); + copy(p,info,q,sizeofW(StgTRecChunk),gen_no); return; default: @@ -846,7 +840,7 @@ unchain_thunk_selectors(prev_thunk_selector, (StgClosure *)p); *q = (StgClosure *)p; // shortcut, behave as for: if (evac) evacuate(q); - if (evac && bd->gen < gct->evac_gen) { + if (evac && bd->gen_no < gct->evac_gen_no) { gct->failed_to_evac = rtsTrue; TICK_GC_FAILED_PROMOTION(); } @@ -952,7 +946,7 @@ // For the purposes of LDV profiling, we have destroyed // the original selector thunk, p. SET_INFO(p, (StgInfoTable *)info_ptr); - LDV_RECORD_DEAD_FILL_SLOP_DYNAMIC((StgClosure *)p); + OVERWRITING_CLOSURE((StgClosure*)p); SET_INFO(p, &stg_WHITEHOLE_info); #endif @@ -1085,7 +1079,7 @@ // check whether it was updated in the meantime. *q = (StgClosure *)p; if (evac) { - copy(q,(const StgInfoTable *)info_ptr,(StgClosure *)p,THUNK_SELECTOR_sizeW(),bd->dest); + copy(q,(const StgInfoTable *)info_ptr,(StgClosure *)p,THUNK_SELECTOR_sizeW(),bd->dest_no); } unchain_thunk_selectors(prev_thunk_selector, *q); return; diff -Nru ghc-7.0.3/rts/sm/GCAux.c ghc-7.2.1/rts/sm/GCAux.c --- ghc-7.0.3/rts/sm/GCAux.c 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/rts/sm/GCAux.c 2011-08-07 17:10:05.000000000 +0000 @@ -17,7 +17,7 @@ #include "Capability.h" #include "Trace.h" #include "Schedule.h" -// DO NOT include "GCThread.h", we don't want the register variable +// DO NOT include "GCTDecl.h", we don't want the register variable /* ----------------------------------------------------------------------------- isAlive determines whether the given closure is still alive (after @@ -67,12 +67,7 @@ // large objects use the evacuated flag if (bd->flags & BF_LARGE) { - if (get_itbl(q)->type == TSO && - ((StgTSO *)p)->what_next == ThreadRelocated) { - p = (StgClosure *)((StgTSO *)p)->_link; - continue; - } - return NULL; + return NULL; } // check the mark bit for compacted steps @@ -84,7 +79,7 @@ if (IS_FORWARDING_PTR(info)) { // alive! - return (StgClosure*)UN_FORWARDING_PTR(info); + return TAG_CLOSURE(tag,(StgClosure*)UN_FORWARDING_PTR(info)); } info = INFO_PTR_TO_STRUCT(info); @@ -98,13 +93,6 @@ p = ((StgInd *)q)->indirectee; continue; - case TSO: - if (((StgTSO *)q)->what_next == ThreadRelocated) { - p = (StgClosure *)((StgTSO *)q)->_link; - continue; - } - return NULL; - default: // dead. return NULL; diff -Nru ghc-7.0.3/rts/sm/GC.c ghc-7.2.1/rts/sm/GC.c --- ghc-7.0.3/rts/sm/GC.c 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/rts/sm/GC.c 2011-08-07 17:10:05.000000000 +0000 @@ -40,6 +40,7 @@ #include "GC.h" #include "GCThread.h" +#include "GCTDecl.h" #include "Compact.h" #include "Evac.h" #include "Scav.h" @@ -137,8 +138,8 @@ static void mark_root (void *user, StgClosure **root); static void zero_static_object_list (StgClosure* first_static); static nat initialise_N (rtsBool force_major_gc); -static void init_collected_gen (nat g, nat threads); -static void init_uncollected_gen (nat g, nat threads); +static void prepare_collected_gen (generation *gen); +static void prepare_uncollected_gen (generation *gen); static void init_gc_thread (gc_thread *t); static void resize_generations (void); static void resize_nursery (void); @@ -146,8 +147,9 @@ static void scavenge_until_all_done (void); static StgWord inc_running (void); static StgWord dec_running (void); -static void wakeup_gc_threads (nat n_threads, nat me); -static void shutdown_gc_threads (nat n_threads, nat me); +static void wakeup_gc_threads (nat me); +static void shutdown_gc_threads (nat me); +static void collect_gct_blocks (void); #if 0 && defined(DEBUG) static void gcCAFs (void); @@ -169,17 +171,22 @@ void GarbageCollect (rtsBool force_major_gc, + rtsBool do_heap_census, nat gc_type USED_IF_THREADS, Capability *cap) { bdescr *bd; generation *gen; - lnat live, allocated, max_copied, avg_copied, slop; + lnat live_blocks, live_words, allocated, max_copied, avg_copied; +#if defined(THREADED_RTS) gc_thread *saved_gct; - nat g, t, n; +#endif + nat g, n; // necessary if we stole a callee-saves register for gct: +#if defined(THREADED_RTS) saved_gct = gct; +#endif #ifdef PROFILING CostCentreStack *prev_CCS; @@ -197,11 +204,11 @@ ASSERT(sizeof(gen_workspace) == 16 * sizeof(StgWord)); // otherwise adjust the padding in gen_workspace. - // tell the stats department that we've started a GC - stat_startGC(); + // this is the main thread + SET_GCT(gc_threads[cap->no]); - // tell the STM to discard any cached closures it's hoping to re-use - stmPreGCHook(); + // tell the stats department that we've started a GC + stat_startGC(gct); // lock the StablePtr table stablePtrPreGC(); @@ -221,7 +228,7 @@ /* Approximate how much we allocated. * Todo: only when generating stats? */ - allocated = calcAllocated(); + allocated = calcAllocated(rtsFalse/* don't count the nursery yet */); /* Figure out which generation to collect */ @@ -274,23 +281,20 @@ #endif // check sanity *before* GC - IF_DEBUG(sanity, checkSanity(rtsTrue)); - - // Initialise all our gc_thread structures - for (t = 0; t < n_gc_threads; t++) { - init_gc_thread(gc_threads[t]); - } + IF_DEBUG(sanity, checkSanity(rtsFalse /* before GC */, major_gc)); // Initialise all the generations/steps that we're collecting. for (g = 0; g <= N; g++) { - init_collected_gen(g,n_gc_threads); + prepare_collected_gen(&generations[g]); } - // Initialise all the generations/steps that we're *not* collecting. for (g = N+1; g < RtsFlags.GcFlags.generations; g++) { - init_uncollected_gen(g,n_gc_threads); + prepare_uncollected_gen(&generations[g]); } + // Prepare this gc_thread + init_gc_thread(gct); + /* Allocate a mark stack if we're doing a major collection. */ if (major_gc && oldest_gen->mark) { @@ -305,17 +309,6 @@ mark_sp = NULL; } - // this is the main thread -#ifdef THREADED_RTS - if (n_gc_threads == 1) { - SET_GCT(gc_threads[0]); - } else { - SET_GCT(gc_threads[cap->no]); - } -#else -SET_GCT(gc_threads[0]); -#endif - /* ----------------------------------------------------------------------- * follow all the roots that we know about: */ @@ -325,28 +318,9 @@ // NB. do this after the mutable lists have been saved above, otherwise // the other GC threads will be writing into the old mutable lists. inc_running(); - wakeup_gc_threads(n_gc_threads, gct->thread_index); + wakeup_gc_threads(gct->thread_index); - // Mutable lists from each generation > N - // we want to *scavenge* these roots, not evacuate them: they're not - // going to move in this GC. - // Also do them in reverse generation order, for the usual reason: - // namely to reduce the likelihood of spurious old->new pointers. - // - for (g = RtsFlags.GcFlags.generations-1; g > N; g--) { -#if defined(THREADED_RTS) - if (n_gc_threads > 1) { - scavenge_mutable_list(generations[g].saved_mut_list, &generations[g]); - } else { - scavenge_mutable_list1(generations[g].saved_mut_list, &generations[g]); - } -#else - scavenge_mutable_list(generations[g].saved_mut_list, &generations[g]); -#endif - freeChain_sync(generations[g].saved_mut_list); - generations[g].saved_mut_list = NULL; - - } + traceEventGcWork(gct->cap); // scavenge the capability-private mutable lists. This isn't part // of markSomeCapabilities() because markSomeCapabilities() can only @@ -361,17 +335,25 @@ #endif } } else { - scavenge_capability_mut_lists(&capabilities[gct->thread_index]); + scavenge_capability_mut_lists(gct->cap); } // follow roots from the CAF list (used by GHCi) - gct->evac_gen = 0; + gct->evac_gen_no = 0; markCAFs(mark_root, gct); // follow all the roots that the application knows about. - gct->evac_gen = 0; - markSomeCapabilities(mark_root, gct, gct->thread_index, n_gc_threads, - rtsTrue/*prune sparks*/); + gct->evac_gen_no = 0; + if (n_gc_threads == 1) { + for (n = 0; n < n_capabilities; n++) { + markCapability(mark_root, gct, &capabilities[n], + rtsTrue/*don't mark sparks*/); + } + } else { + markCapability(mark_root, gct, cap, rtsTrue/*don't mark sparks*/); + } + + markScheduler(mark_root, gct); #if defined(RTS_USER_SIGNALS) // mark the signal handlers (signals should be already blocked) @@ -406,7 +388,7 @@ break; } - shutdown_gc_threads(n_gc_threads, gct->thread_index); + shutdown_gc_threads(gct->thread_index); // Now see which stable names are still alive. gcStablePtrTable(); @@ -417,7 +399,7 @@ pruneSparkQueue(&capabilities[n]); } } else { - pruneSparkQueue(&capabilities[gct->thread_index]); + pruneSparkQueue(gct->cap); } #endif @@ -431,86 +413,6 @@ // NO MORE EVACUATION AFTER THIS POINT! - // Two-space collector: free the old to-space. - // g0->old_blocks is the old nursery - // g0->blocks is to-space from the previous GC - if (RtsFlags.GcFlags.generations == 1) { - if (g0->blocks != NULL) { - freeChain(g0->blocks); - g0->blocks = NULL; - } - } - - // For each workspace, in each thread, move the copied blocks to the step - { - gc_thread *thr; - gen_workspace *ws; - bdescr *prev, *next; - - for (t = 0; t < n_gc_threads; t++) { - thr = gc_threads[t]; - - for (g = 0; g < RtsFlags.GcFlags.generations; g++) { - ws = &thr->gens[g]; - - // Push the final block - if (ws->todo_bd) { - push_scanned_block(ws->todo_bd, ws); - } - - ASSERT(gct->scan_bd == NULL); - ASSERT(countBlocks(ws->scavd_list) == ws->n_scavd_blocks); - - prev = NULL; - for (bd = ws->scavd_list; bd != NULL; bd = bd->link) { - ws->gen->n_words += bd->free - bd->start; - prev = bd; - } - if (prev != NULL) { - prev->link = ws->gen->blocks; - ws->gen->blocks = ws->scavd_list; - } - ws->gen->n_blocks += ws->n_scavd_blocks; - } - } - - // Add all the partial blocks *after* we've added all the full - // blocks. This is so that we can grab the partial blocks back - // again and try to fill them up in the next GC. - for (t = 0; t < n_gc_threads; t++) { - thr = gc_threads[t]; - - for (g = 0; g < RtsFlags.GcFlags.generations; g++) { - ws = &thr->gens[g]; - - prev = NULL; - for (bd = ws->part_list; bd != NULL; bd = next) { - next = bd->link; - if (bd->free == bd->start) { - if (prev == NULL) { - ws->part_list = next; - } else { - prev->link = next; - } - freeGroup(bd); - ws->n_part_blocks--; - } else { - ws->gen->n_words += bd->free - bd->start; - prev = bd; - } - } - if (prev != NULL) { - prev->link = ws->gen->blocks; - ws->gen->blocks = ws->part_list; - } - ws->gen->n_blocks += ws->n_part_blocks; - - ASSERT(countBlocks(ws->gen->blocks) == ws->gen->n_blocks); - ASSERT(countOccupied(ws->gen->blocks) == ws->gen->n_words); - } - } - } - // Finally: compact or sweep the oldest generation. if (major_gc && oldest_gen->mark) { if (oldest_gen->compact) @@ -519,8 +421,6 @@ sweep(oldest_gen); } - /* run through all the generations/steps and tidy up - */ copied = 0; max_copied = 0; avg_copied = 0; @@ -546,6 +446,16 @@ } } + // Run through all the generations/steps and tidy up. + // We're going to: + // - count the amount of "live" data (live_words, live_blocks) + // - count the amount of "copied" data in this GC (copied) + // - free from-space + // - make to-space the new from-space (set BF_EVACUATED on all blocks) + // + live_words = 0; + live_blocks = 0; + for (g = 0; g < RtsFlags.GcFlags.generations; g++) { if (g == N) { @@ -557,14 +467,8 @@ // stats. Every mutable list is copied during every GC. if (g > 0) { nat mut_list_size = 0; - for (bd = generations[g].mut_list; bd != NULL; bd = bd->link) { - mut_list_size += bd->free - bd->start; - } for (n = 0; n < n_capabilities; n++) { - for (bd = capabilities[n].mut_lists[g]; - bd != NULL; bd = bd->link) { - mut_list_size += bd->free - bd->start; - } + mut_list_size += countOccupied(capabilities[n].mut_lists[g]); } copied += mut_list_size; @@ -648,8 +552,7 @@ freeChain(gen->large_objects); gen->large_objects = gen->scavenged_large_objects; gen->n_large_blocks = gen->n_scavenged_large_blocks; - gen->n_new_large_blocks = 0; - ASSERT(countBlocks(gen->large_objects) == gen->n_large_blocks); + gen->n_new_large_words = 0; } else // for generations > N { @@ -664,25 +567,31 @@ // add the new blocks we promoted during this GC gen->n_large_blocks += gen->n_scavenged_large_blocks; - ASSERT(countBlocks(gen->large_objects) == gen->n_large_blocks); + } + + ASSERT(countBlocks(gen->large_objects) == gen->n_large_blocks); + + gen->scavenged_large_objects = NULL; + gen->n_scavenged_large_blocks = 0; + + // Count "live" data + live_words += genLiveWords(gen); + live_blocks += genLiveBlocks(gen); + + // add in the partial blocks in the gen_workspaces, but ignore gen 0 + // if this is a local GC (we can't count another capability's part_list) + { + nat i; + for (i = 0; i < n_capabilities; i++) { + live_words += gcThreadLiveWords(i, gen->no); + live_blocks += gcThreadLiveBlocks(i, gen->no); + } } } // for all generations // update the max size of older generations after a major GC resize_generations(); - // Calculate the amount of live data for stats. - live = calcLiveWords(); - - // Free the small objects allocated via allocate(), since this will - // all have been copied into G0S1 now. - alloc_blocks_lim = RtsFlags.GcFlags.minAllocAreaSize; - - // Start a new pinned_object_block - for (n = 0; n < n_capabilities; n++) { - capabilities[n].pinned_object_block = NULL; - } - // Free the mark stack. if (mark_stack_top_bd != NULL) { debugTrace(DEBUG_gc, "mark stack: %d blocks", @@ -699,9 +608,14 @@ } } + // Reset the nursery: make the blocks empty + allocated += clearNurseries(); + resize_nursery(); - // mark the garbage collected CAFs as dead + resetNurseries(); + + // mark the garbage collected CAFs as dead #if 0 && defined(DEBUG) // doesn't work at the moment if (major_gc) { gcCAFs(); } #endif @@ -719,19 +633,15 @@ // zero the scavenged static object list if (major_gc) { nat i; - for (i = 0; i < n_gc_threads; i++) { - zero_static_object_list(gc_threads[i]->scavenged_static_objects); + if (n_gc_threads == 1) { + zero_static_object_list(gct->scavenged_static_objects); + } else { + for (i = 0; i < n_gc_threads; i++) { + zero_static_object_list(gc_threads[i]->scavenged_static_objects); + } } } - // Reset the nursery - resetNurseries(); - - // send exceptions to any threads which were about to die - RELEASE_SM_LOCK; - resurrectThreads(resurrected_threads); - ACQUIRE_SM_LOCK; - // Update the stable pointer hash table. updateStablePtrTable(major_gc); @@ -746,6 +656,28 @@ scheduleFinalizers(cap, old_weak_ptr_list); ACQUIRE_SM_LOCK; + // check sanity after GC + // before resurrectThreads(), because that might overwrite some + // closures, which will cause problems with THREADED where we don't + // fill slop. + IF_DEBUG(sanity, checkSanity(rtsTrue /* after GC */, major_gc)); + + // If a heap census is due, we need to do it before + // resurrectThreads(), for the same reason as checkSanity above: + // resurrectThreads() will overwrite some closures and leave slop + // behind. + if (do_heap_census) { + debugTrace(DEBUG_sched, "performing heap census"); + RELEASE_SM_LOCK; + heapCensus(gct->gc_start_cpu); + ACQUIRE_SM_LOCK; + } + + // send exceptions to any threads which were about to die + RELEASE_SM_LOCK; + resurrectThreads(resurrected_threads); + ACQUIRE_SM_LOCK; + if (major_gc) { nat need, got; need = BLOCKS_TO_MBLOCKS(n_alloc_blocks); @@ -759,10 +691,7 @@ } } - // check sanity after GC - IF_DEBUG(sanity, checkSanity(rtsTrue)); - - // extra GC trace info + // extra GC trace info IF_DEBUG(gc, statDescribeGens()); #ifdef DEBUG @@ -787,8 +716,9 @@ #endif // ok, GC over: tell the stats department what happened. - slop = calcLiveBlocks() * BLOCK_SIZE_W - live; - stat_endGC(allocated, live, copied, N, max_copied, avg_copied, slop); + stat_endGC(gct, allocated, live_words, + copied, N, max_copied, avg_copied, + live_blocks * BLOCK_SIZE_W - live_words /* slop */); // Guess which generation we'll collect *next* time initialise_N(force_major_gc); @@ -861,6 +791,8 @@ nat g; gen_workspace *ws; + t->cap = &capabilities[n]; + #ifdef THREADED_RTS t->id = 0; initSpinLock(&t->gc_spin); @@ -887,7 +819,21 @@ ASSERT(g == ws->gen->no); ws->my_gct = t; - ws->todo_bd = NULL; + // We want to call + // alloc_todo_block(ws,0); + // but can't, because it uses gct which isn't set up at this point. + // Hence, allocate a block for todo_bd manually: + { + bdescr *bd = allocBlock(); // no lock, locks aren't initialised yet + initBdescr(bd, ws->gen, ws->gen->to); + bd->flags = BF_EVACUATED; + bd->u.scan = bd->free = bd->start; + + ws->todo_bd = bd; + ws->todo_free = bd->free; + ws->todo_lim = bd->start + BLOCK_SIZE_W; + } + ws->todo_q = newWSDeque(128); ws->todo_overflow = NULL; ws->n_todo_overflow = 0; @@ -1026,12 +972,10 @@ static void scavenge_until_all_done (void) { - nat r; + DEBUG_ONLY( nat r ); loop: - traceEventGcWork(&capabilities[gct->thread_index]); - #if defined(THREADED_RTS) if (n_gc_threads > 1) { scavenge_loop(); @@ -1042,10 +986,17 @@ scavenge_loop(); #endif + collect_gct_blocks(); + // scavenge_loop() only exits when there's no work to do + +#ifdef DEBUG r = dec_running(); - - traceEventGcIdle(&capabilities[gct->thread_index]); +#else + dec_running(); +#endif + + traceEventGcIdle(gct->cap); debugTrace(DEBUG_gc, "%d GC threads still running", r); @@ -1053,6 +1004,7 @@ // usleep(1); if (any_work()) { inc_running(); + traceEventGcWork(gct->cap); goto loop; } // any_work() does not remove the work from the queue, it @@ -1061,7 +1013,7 @@ // scavenge_loop() to perform any pending work. } - traceEventGcDone(&capabilities[gct->thread_index]); + traceEventGcDone(gct->cap); } #if defined(THREADED_RTS) @@ -1077,6 +1029,8 @@ gct = gc_threads[cap->no]; gct->id = osThreadId(); + stat_gcWorkerThreadStart(gct); + // Wait until we're told to wake up RELEASE_SPIN_LOCK(&gct->mut_spin); gct->wakeup = GC_THREAD_STANDING_BY; @@ -1090,12 +1044,15 @@ } papi_thread_start_gc1_count(gct->papi_events); #endif - + + init_gc_thread(gct); + + traceEventGcWork(gct->cap); + // Every thread evacuates some roots. - gct->evac_gen = 0; - markSomeCapabilities(mark_root, gct, gct->thread_index, n_gc_threads, - rtsTrue/*prune sparks*/); - scavenge_capability_mut_lists(&capabilities[gct->thread_index]); + gct->evac_gen_no = 0; + markCapability(mark_root, gct, cap, rtsTrue/*prune sparks*/); + scavenge_capability_mut_lists(cap); scavenge_until_all_done(); @@ -1122,6 +1079,9 @@ ACQUIRE_SPIN_LOCK(&gct->mut_spin); debugTrace(DEBUG_gc, "GC thread %d on my way...", gct->thread_index); + // record the time spent doing GC in the Task structure + stat_gcWorkerThreadDone(gct); + SET_GCT(saved_gct); } @@ -1171,11 +1131,14 @@ } static void -wakeup_gc_threads (nat n_threads USED_IF_THREADS, nat me USED_IF_THREADS) +wakeup_gc_threads (nat me USED_IF_THREADS) { #if defined(THREADED_RTS) nat i; - for (i=0; i < n_threads; i++) { + + if (n_gc_threads == 1) return; + + for (i=0; i < n_gc_threads; i++) { if (i == me) continue; inc_running(); debugTrace(DEBUG_gc, "waking up gc thread %d", i); @@ -1192,11 +1155,14 @@ // standby state, otherwise they may still be executing inside // any_work(), and may even remain awake until the next GC starts. static void -shutdown_gc_threads (nat n_threads USED_IF_THREADS, nat me USED_IF_THREADS) +shutdown_gc_threads (nat me USED_IF_THREADS) { #if defined(THREADED_RTS) nat i; - for (i=0; i < n_threads; i++) { + + if (n_gc_threads == 1) return; + + for (i=0; i < n_gc_threads; i++) { if (i == me) continue; while (gc_threads[i]->wakeup != GC_THREAD_WAITING_TO_CONTINUE) { write_barrier(); } } @@ -1227,20 +1193,18 @@ ------------------------------------------------------------------------- */ static void -init_collected_gen (nat g, nat n_threads) +prepare_collected_gen (generation *gen) { - nat t, i; + nat i, g, n; gen_workspace *ws; - generation *gen; - bdescr *bd; + bdescr *bd, *next; // Throw away the current mutable list. Invariant: the mutable // list always has at least one block; this means we can avoid a // check for NULL in recordMutable(). + g = gen->no; if (g != 0) { - freeChain(generations[g].mut_list); - generations[g].mut_list = allocBlock(); - for (i = 0; i < n_capabilities; i++) { + for (i = 0; i < n_capabilities; i++) { freeChain(capabilities[i].mut_lists[g]); capabilities[i].mut_lists[g] = allocBlock(); } @@ -1263,9 +1227,35 @@ gen->live_estimate = 0; // initialise the large object queues. - gen->scavenged_large_objects = NULL; - gen->n_scavenged_large_blocks = 0; - + ASSERT(gen->scavenged_large_objects == NULL); + ASSERT(gen->n_scavenged_large_blocks == 0); + + // grab all the partial blocks stashed in the gc_thread workspaces and + // move them to the old_blocks list of this gen. + for (n = 0; n < n_capabilities; n++) { + ws = &gc_threads[n]->gens[gen->no]; + + for (bd = ws->part_list; bd != NULL; bd = next) { + next = bd->link; + bd->link = gen->old_blocks; + gen->old_blocks = bd; + gen->n_old_blocks += bd->blocks; + } + ws->part_list = NULL; + ws->n_part_blocks = 0; + + ASSERT(ws->scavd_list == NULL); + ASSERT(ws->n_scavd_blocks == 0); + + if (ws->todo_free != ws->todo_bd->start) { + ws->todo_bd->free = ws->todo_free; + ws->todo_bd->link = gen->old_blocks; + gen->old_blocks = ws->todo_bd; + gen->n_old_blocks += ws->todo_bd->blocks; + alloc_todo_block(ws,0); // always has one block. + } + } + // mark the small objects as from-space for (bd = gen->old_blocks; bd; bd = bd->link) { bd->flags &= ~BF_EVACUATED; @@ -1278,7 +1268,7 @@ // for a compacted generation, we need to allocate the bitmap if (gen->mark) { - nat bitmap_size; // in bytes + lnat bitmap_size; // in bytes bdescr *bitmap_bdescr; StgWord *bitmap; @@ -1317,108 +1307,83 @@ } } } - - // For each GC thread, for each step, allocate a "todo" block to - // store evacuated objects to be scavenged, and a block to store - // evacuated objects that do not need to be scavenged. - for (t = 0; t < n_threads; t++) { - ws = &gc_threads[t]->gens[g]; - - ws->todo_large_objects = NULL; - - ws->part_list = NULL; - ws->n_part_blocks = 0; - - // allocate the first to-space block; extra blocks will be - // chained on as necessary. - ws->todo_bd = NULL; - ASSERT(looksEmptyWSDeque(ws->todo_q)); - alloc_todo_block(ws,0); - - ws->todo_overflow = NULL; - ws->n_todo_overflow = 0; - - ws->scavd_list = NULL; - ws->n_scavd_blocks = 0; - } } /* ---------------------------------------------------------------------------- + Save the mutable lists in saved_mut_lists + ------------------------------------------------------------------------- */ + +static void +stash_mut_list (Capability *cap, nat gen_no) +{ + cap->saved_mut_lists[gen_no] = cap->mut_lists[gen_no]; + cap->mut_lists[gen_no] = allocBlock_sync(); +} + +/* ---------------------------------------------------------------------------- Initialise a generation that is *not* to be collected ------------------------------------------------------------------------- */ static void -init_uncollected_gen (nat g, nat threads) +prepare_uncollected_gen (generation *gen) { - nat t, n; - gen_workspace *ws; - generation *gen; - bdescr *bd; + nat i; + + + ASSERT(gen->no > 0); // save the current mutable lists for this generation, and // allocate a fresh block for each one. We'll traverse these // mutable lists as roots early on in the GC. - generations[g].saved_mut_list = generations[g].mut_list; - generations[g].mut_list = allocBlock(); - for (n = 0; n < n_capabilities; n++) { - capabilities[n].saved_mut_lists[g] = capabilities[n].mut_lists[g]; - capabilities[n].mut_lists[g] = allocBlock(); + for (i = 0; i < n_capabilities; i++) { + stash_mut_list(&capabilities[i], gen->no); } - gen = &generations[g]; + ASSERT(gen->scavenged_large_objects == NULL); + ASSERT(gen->n_scavenged_large_blocks == 0); +} - gen->scavenged_large_objects = NULL; - gen->n_scavenged_large_blocks = 0; +/* ----------------------------------------------------------------------------- + Collect the completed blocks from a GC thread and attach them to + the generation. + -------------------------------------------------------------------------- */ - for (t = 0; t < threads; t++) { - ws = &gc_threads[t]->gens[g]; - - ASSERT(looksEmptyWSDeque(ws->todo_q)); - ws->todo_large_objects = NULL; - - ws->part_list = NULL; - ws->n_part_blocks = 0; +static void +collect_gct_blocks (void) +{ + nat g; + gen_workspace *ws; + bdescr *bd, *prev; + + for (g = 0; g < RtsFlags.GcFlags.generations; g++) { + ws = &gct->gens[g]; - ws->scavd_list = NULL; - ws->n_scavd_blocks = 0; + // there may still be a block attached to ws->todo_bd; + // leave it there to use next time. + + if (ws->scavd_list != NULL) { + ACQUIRE_SPIN_LOCK(&ws->gen->sync); + + ASSERT(gct->scan_bd == NULL); + ASSERT(countBlocks(ws->scavd_list) == ws->n_scavd_blocks); - // If the block at the head of the list in this generation - // is less than 3/4 full, then use it as a todo block. - if (gen->blocks && isPartiallyFull(gen->blocks)) - { - ws->todo_bd = gen->blocks; - ws->todo_free = ws->todo_bd->free; - ws->todo_lim = ws->todo_bd->start + BLOCK_SIZE_W; - gen->blocks = gen->blocks->link; - gen->n_blocks -= 1; - gen->n_words -= ws->todo_bd->free - ws->todo_bd->start; - ws->todo_bd->link = NULL; - // we must scan from the current end point. - ws->todo_bd->u.scan = ws->todo_bd->free; - } - else - { - ws->todo_bd = NULL; - alloc_todo_block(ws,0); - } - } + prev = NULL; + for (bd = ws->scavd_list; bd != NULL; bd = bd->link) { + ws->gen->n_words += bd->free - bd->start; + prev = bd; + } + if (prev != NULL) { + prev->link = ws->gen->blocks; + ws->gen->blocks = ws->scavd_list; + } + ws->gen->n_blocks += ws->n_scavd_blocks; - // deal out any more partial blocks to the threads' part_lists - t = 0; - while (gen->blocks && isPartiallyFull(gen->blocks)) - { - bd = gen->blocks; - gen->blocks = bd->link; - ws = &gc_threads[t]->gens[g]; - bd->link = ws->part_list; - ws->part_list = bd; - ws->n_part_blocks += 1; - bd->u.scan = bd->free; - gen->n_blocks -= 1; - gen->n_words -= bd->free - bd->start; - t++; - if (t == n_gc_threads) t = 0; + ws->scavd_list = NULL; + ws->n_scavd_blocks = 0; + + RELEASE_SPIN_LOCK(&ws->gen->sync); + } } } @@ -1432,8 +1397,8 @@ t->static_objects = END_OF_STATIC_LIST; t->scavenged_static_objects = END_OF_STATIC_LIST; t->scan_bd = NULL; - t->mut_lists = capabilities[t->thread_index].mut_lists; - t->evac_gen = 0; + t->mut_lists = t->cap->mut_lists; + t->evac_gen_no = 0; t->failed_to_evac = rtsFalse; t->eager_promotion = rtsTrue; t->thunk_selector_depth = 0; @@ -1456,8 +1421,10 @@ // so we need to save and restore it here. NB. only call // mark_root() from the main GC thread, otherwise gct will be // incorrect. +#if defined(THREADED_RTS) gc_thread *saved_gct; saved_gct = gct; +#endif SET_GCT(user); evacuate(root); diff -Nru ghc-7.0.3/rts/sm/GC.h ghc-7.2.1/rts/sm/GC.h --- ghc-7.0.3/rts/sm/GC.h 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/rts/sm/GC.h 2011-08-07 17:10:05.000000000 +0000 @@ -16,7 +16,9 @@ #include "BeginPrivate.h" -void GarbageCollect(rtsBool force_major_gc, nat gc_type, Capability *cap); +void GarbageCollect (rtsBool force_major_gc, + rtsBool do_heap_census, + nat gc_type, Capability *cap); typedef void (*evac_fn)(void *user, StgClosure **root); diff -Nru ghc-7.0.3/rts/sm/GCTDecl.h ghc-7.2.1/rts/sm/GCTDecl.h --- ghc-7.0.3/rts/sm/GCTDecl.h 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/rts/sm/GCTDecl.h 2011-08-07 17:10:05.000000000 +0000 @@ -0,0 +1,98 @@ +/* ----------------------------------------------------------------------------- + * + * (c) The GHC Team 1998-2009 + * + * Documentation on the architecture of the Garbage Collector can be + * found in the online commentary: + * + * http://hackage.haskell.org/trac/ghc/wiki/Commentary/Rts/Storage/GC + * + * ---------------------------------------------------------------------------*/ + +#ifndef SM_GCTDECL_H +#define SM_GCTDECL_H + +#include "BeginPrivate.h" + +/* ----------------------------------------------------------------------------- + The gct variable is thread-local and points to the current thread's + gc_thread structure. It is heavily accessed, so we try to put gct + into a global register variable if possible; if we don't have a + register then use gcc's __thread extension to create a thread-local + variable. + -------------------------------------------------------------------------- */ + +#if defined(THREADED_RTS) + +#define GLOBAL_REG_DECL(type,name,reg) register type name REG(reg); + +#define SET_GCT(to) gct = (to) + + + +#if (defined(i386_HOST_ARCH) && defined(linux_HOST_OS)) +// Using __thread is better than stealing a register on x86/Linux, because +// we have too few registers available. In my tests it was worth +// about 5% in GC performance, but of course that might change as gcc +// improves. -- SDM 2009/04/03 +// +// We ought to do the same on MacOS X, but __thread is not +// supported there yet (gcc 4.0.1). + +extern __thread gc_thread* gct; +#define DECLARE_GCT __thread gc_thread* gct; + + +#elif defined(sparc_HOST_ARCH) +// On SPARC we can't pin gct to a register. Names like %l1 are just offsets +// into the register window, which change on each function call. +// +// There are eight global (non-window) registers, but they're used for other purposes. +// %g0 -- always zero +// %g1 -- volatile over function calls, used by the linker +// %g2-%g3 -- used as scratch regs by the C compiler (caller saves) +// %g4 -- volatile over function calls, used by the linker +// %g5-%g7 -- reserved by the OS + +extern __thread gc_thread* gct; +#define DECLARE_GCT __thread gc_thread* gct; + + +#elif defined(REG_Base) && !defined(i386_HOST_ARCH) +// on i386, REG_Base is %ebx which is also used for PIC, so we don't +// want to steal it + +GLOBAL_REG_DECL(gc_thread*, gct, REG_Base) +#define DECLARE_GCT /* nothing */ + + +#elif defined(REG_R1) + +GLOBAL_REG_DECL(gc_thread*, gct, REG_R1) +#define DECLARE_GCT /* nothing */ + + +#elif defined(__GNUC__) + +extern __thread gc_thread* gct; +#define DECLARE_GCT __thread gc_thread* gct; + +#else + +#error Cannot find a way to declare the thread-local gct + +#endif + +#else // not the threaded RTS + +extern StgWord8 the_gc_thread[]; + +#define gct ((gc_thread*)&the_gc_thread) +#define SET_GCT(to) /*nothing*/ +#define DECLARE_GCT /*nothing*/ + +#endif // THREADED_RTS + +#include "EndPrivate.h" + +#endif // SM_GCTDECL_H diff -Nru ghc-7.0.3/rts/sm/GCThread.h ghc-7.2.1/rts/sm/GCThread.h --- ghc-7.0.3/rts/sm/GCThread.h 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/rts/sm/GCThread.h 2011-08-07 17:10:05.000000000 +0000 @@ -15,6 +15,7 @@ #define SM_GCTHREAD_H #include "WSDeque.h" +#include "GetTime.h" // for Ticks #include "BeginPrivate.h" @@ -115,6 +116,8 @@ ------------------------------------------------------------------------- */ typedef struct gc_thread_ { + Capability *cap; + #ifdef THREADED_RTS OSThreadId id; // The OS thread that this struct belongs to SpinLock gc_spin; @@ -146,7 +149,7 @@ // -------------------- // evacuate flags - generation *evac_gen; // Youngest generation that objects + nat evac_gen_no; // Youngest generation that objects // should be evacuated to in // evacuate(). (Logically an // argument to evacuate, but it's @@ -162,7 +165,8 @@ // instead of the to-space // corresponding to the object - lnat thunk_selector_depth; // ummm.... not used as of now + lnat thunk_selector_depth; // used to avoid unbounded recursion in + // evacuate() for THUNK_SELECTOR #ifdef USE_PAPI int papi_events; @@ -177,10 +181,15 @@ lnat no_work; lnat scav_find_work; + Ticks gc_start_cpu; // process CPU time + Ticks gc_start_elapsed; // process elapsed time + Ticks gc_start_thread_cpu; // thread CPU time + lnat gc_start_faults; + // ------------------- // workspaces - // array of workspaces, indexed by stp->abs_no. This is placed + // array of workspaces, indexed by gen->abs_no. This is placed // directly at the end of the gc_thread structure so that we can get from // the gc_thread pointer to a workspace using only pointer // arithmetic, no memory access. This happens in the inner loop @@ -191,91 +200,8 @@ extern nat n_gc_threads; -/* ----------------------------------------------------------------------------- - The gct variable is thread-local and points to the current thread's - gc_thread structure. It is heavily accessed, so we try to put gct - into a global register variable if possible; if we don't have a - register then use gcc's __thread extension to create a thread-local - variable. - - Even on x86 where registers are scarce, it is worthwhile using a - register variable here: I measured about a 2-5% slowdown with the - __thread version. - -------------------------------------------------------------------------- */ - extern gc_thread **gc_threads; -#if defined(THREADED_RTS) - -#define GLOBAL_REG_DECL(type,name,reg) register type name REG(reg); - -#define SET_GCT(to) gct = (to) - - - -#if (defined(i386_HOST_ARCH) && defined(linux_HOST_OS)) -// Using __thread is better than stealing a register on x86/Linux, because -// we have too few registers available. In my tests it was worth -// about 5% in GC performance, but of course that might change as gcc -// improves. -- SDM 2009/04/03 -// -// We ought to do the same on MacOS X, but __thread is not -// supported there yet (gcc 4.0.1). - -extern __thread gc_thread* gct; -#define DECLARE_GCT __thread gc_thread* gct; - - -#elif defined(sparc_HOST_ARCH) -// On SPARC we can't pin gct to a register. Names like %l1 are just offsets -// into the register window, which change on each function call. -// -// There are eight global (non-window) registers, but they're used for other purposes. -// %g0 -- always zero -// %g1 -- volatile over function calls, used by the linker -// %g2-%g3 -- used as scratch regs by the C compiler (caller saves) -// %g4 -- volatile over function calls, used by the linker -// %g5-%g7 -- reserved by the OS - -extern __thread gc_thread* gct; -#define DECLARE_GCT __thread gc_thread* gct; - - -#elif defined(REG_Base) && !defined(i386_HOST_ARCH) -// on i386, REG_Base is %ebx which is also used for PIC, so we don't -// want to steal it - -GLOBAL_REG_DECL(gc_thread*, gct, REG_Base) -#define DECLARE_GCT /* nothing */ - - -#elif defined(REG_R1) - -GLOBAL_REG_DECL(gc_thread*, gct, REG_R1) -#define DECLARE_GCT /* nothing */ - - -#elif defined(__GNUC__) - -extern __thread gc_thread* gct; -#define DECLARE_GCT __thread gc_thread* gct; - -#else - -#error Cannot find a way to declare the thread-local gct - -#endif - -#else // not the threaded RTS - -extern StgWord8 the_gc_thread[]; - -#define gct ((gc_thread*)&the_gc_thread) -#define SET_GCT(to) /*nothing*/ -#define DECLARE_GCT /*nothing*/ - -#endif - #include "EndPrivate.h" #endif // SM_GCTHREAD_H diff -Nru ghc-7.0.3/rts/sm/GCUtils.c ghc-7.2.1/rts/sm/GCUtils.c --- ghc-7.0.3/rts/sm/GCUtils.c 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/rts/sm/GCUtils.c 2011-08-07 17:10:05.000000000 +0000 @@ -18,6 +18,7 @@ #include "Storage.h" #include "GC.h" #include "GCThread.h" +#include "GCTDecl.h" #include "GCUtils.h" #include "Printer.h" #include "Trace.h" @@ -90,9 +91,6 @@ grab_local_todo_block (gen_workspace *ws) { bdescr *bd; - generation *gen; - - gen = ws->gen; bd = ws->todo_overflow; if (bd != NULL) @@ -213,8 +211,8 @@ // Otherwise, push this block out to the global list. else { - generation *gen; - gen = ws->gen; + DEBUG_ONLY( generation *gen ); + DEBUG_ONLY( gen = ws->gen ); debugTrace(DEBUG_gc, "push todo block %p (%ld words), step %d, todo_q: %ld", bd->start, (unsigned long)(bd->free - bd->u.scan), gen->no, dequeElements(ws->todo_q)); @@ -294,14 +292,13 @@ #if DEBUG void -printMutableList(generation *gen) +printMutableList(bdescr *bd) { - bdescr *bd; StgPtr p; - debugBelch("mutable list %p: ", gen->mut_list); + debugBelch("mutable list %p: ", bd); - for (bd = gen->mut_list; bd != NULL; bd = bd->link) { + for (; bd != NULL; bd = bd->link) { for (p = bd->start; p < bd->free; p++) { debugBelch("%p (%s), ", (void *)*p, info_type((StgClosure *)*p)); } diff -Nru ghc-7.0.3/rts/sm/GCUtils.h ghc-7.2.1/rts/sm/GCUtils.h --- ghc-7.0.3/rts/sm/GCUtils.h 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/rts/sm/GCUtils.h 2011-08-07 17:10:05.000000000 +0000 @@ -16,6 +16,8 @@ #include "BeginPrivate.h" +#include "GCTDecl.h" + bdescr *allocBlock_sync(void); void freeChain_sync(bdescr *bd); @@ -39,7 +41,7 @@ #if DEBUG -void printMutableList (generation *gen); +void printMutableList (bdescr *bd); #endif // Version of recordMutableGen for use during GC. This uses the diff -Nru ghc-7.0.3/rts/sm/MarkWeak.c ghc-7.2.1/rts/sm/MarkWeak.c --- ghc-7.0.3/rts/sm/MarkWeak.c 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/rts/sm/MarkWeak.c 2011-08-07 17:10:05.000000000 +0000 @@ -17,6 +17,7 @@ #include "MarkWeak.h" #include "GC.h" #include "GCThread.h" +#include "GCTDecl.h" #include "Evac.h" #include "Trace.h" #include "Schedule.h" @@ -110,7 +111,7 @@ /* doesn't matter where we evacuate values/finalizers to, since * these pointers are treated as roots (iff the keys are alive). */ - gct->evac_gen = 0; + gct->evac_gen_no = 0; last_w = &old_weak_ptr_list; for (w = old_weak_ptr_list; w != NULL; w = next_w) { @@ -260,18 +261,15 @@ } ASSERT(get_itbl(t)->type == TSO); - if (t->what_next == ThreadRelocated) { - next = t->_link; - *prev = next; - continue; - } - next = t->global_link; // if the thread is not masking exceptions but there are // pending exceptions on its queue, then something has gone - // wrong: + // wrong. However, pending exceptions are OK if there is an + // FFI call. ASSERT(t->blocked_exceptions == END_BLOCKED_EXCEPTIONS_QUEUE + || t->why_blocked == BlockedOnCCall + || t->why_blocked == BlockedOnCCall_Interruptible || (t->flags & TSO_BLOCKEX)); if (tmp == NULL) { diff -Nru ghc-7.0.3/rts/sm/MBlock.c ghc-7.2.1/rts/sm/MBlock.c --- ghc-7.0.3/rts/sm/MBlock.c 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/rts/sm/MBlock.c 2011-08-07 17:10:05.000000000 +0000 @@ -88,10 +88,11 @@ if(map == NULL) { mblock_map_count++; - mblock_maps = realloc(mblock_maps, - sizeof(MBlockMap*) * mblock_map_count); + mblock_maps = stgReallocBytes(mblock_maps, + sizeof(MBlockMap*) * mblock_map_count, + "markHeapAlloced(1)"); map = mblock_maps[mblock_map_count-1] = - stgMallocBytes(sizeof(MBlockMap),"markHeapAlloced"); + stgMallocBytes(sizeof(MBlockMap),"markHeapAlloced(2)"); memset(map,0,sizeof(MBlockMap)); map->addrHigh32 = (StgWord32) (((StgWord)p) >> 32); } @@ -265,7 +266,16 @@ freeAllMBlocks(void) { debugTrace(DEBUG_gc, "freeing all megablocks"); + osFreeAllMBlocks(); + +#if SIZEOF_VOID_P == 8 + nat n; + for (n = 0; n < mblock_map_count; n++) { + stgFree(mblock_maps[n]); + } + stgFree(mblock_maps); +#endif } void diff -Nru ghc-7.0.3/rts/sm/Sanity.c ghc-7.2.1/rts/sm/Sanity.c --- ghc-7.0.3/rts/sm/Sanity.c 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/rts/sm/Sanity.c 2011-08-07 17:10:05.000000000 +0000 @@ -21,6 +21,7 @@ #include "RtsUtils.h" #include "sm/Storage.h" #include "sm/BlockAlloc.h" +#include "GCThread.h" #include "Sanity.h" #include "Schedule.h" #include "Apply.h" @@ -35,6 +36,7 @@ static void checkSmallBitmap ( StgPtr payload, StgWord bitmap, nat ); static void checkLargeBitmap ( StgPtr payload, StgLargeBitmap*, nat ); static void checkClosureShallow ( StgClosure * ); +static void checkSTACK (StgStack *stack); /* ----------------------------------------------------------------------------- Check stack sanity @@ -43,10 +45,8 @@ static void checkSmallBitmap( StgPtr payload, StgWord bitmap, nat size ) { - StgPtr p; nat i; - p = payload; for(i = 0; i < size; i++, bitmap >>= 1 ) { if ((bitmap & 1) == 0) { checkClosureShallow((StgClosure *)payload[i]); @@ -139,6 +139,7 @@ case CATCH_STM_FRAME: case CATCH_FRAME: // small bitmap cases (<= 32 entries) + case UNDERFLOW_FRAME: case STOP_FRAME: case RET_SMALL: size = BITMAP_SIZE(info->i.layout.bitmap); @@ -208,14 +209,12 @@ checkPAP (StgClosure *tagged_fun, StgClosure** payload, StgWord n_args) { StgClosure *fun; - StgClosure *p; StgFunInfoTable *fun_info; fun = UNTAG_CLOSURE(tagged_fun); ASSERT(LOOKS_LIKE_CLOSURE_PTR(fun)); fun_info = get_fun_itbl(fun); - p = (StgClosure *)payload; switch (fun_info->f.fun_type) { case ARG_GEN: checkSmallBitmap( (StgPtr)payload, @@ -331,7 +330,7 @@ ASSERT(get_itbl(bq->owner)->type == TSO); ASSERT(bq->queue == (MessageBlackHole*)END_TSO_QUEUE - || get_itbl(bq->queue)->type == TSO); + || bq->queue->header.info == &stg_MSG_BLACKHOLE_info); ASSERT(bq->link == (StgBlockingQueue*)END_TSO_QUEUE || get_itbl(bq->link)->type == IND || get_itbl(bq->link)->type == BLOCKING_QUEUE); @@ -384,6 +383,7 @@ case RET_BIG: case RET_DYN: case UPDATE_FRAME: + case UNDERFLOW_FRAME: case STOP_FRAME: case CATCH_FRAME: case ATOMICALLY_FRAME: @@ -431,7 +431,11 @@ case TSO: checkTSO((StgTSO *)p); - return tso_sizeW((StgTSO *)p); + return sizeofW(StgTSO); + + case STACK: + checkSTACK((StgStack*)p); + return stack_sizeW((StgStack*)p); case TREC_CHUNK: { @@ -461,17 +465,10 @@ all the objects in the remainder of the chain. -------------------------------------------------------------------------- */ -void -checkHeap(bdescr *bd) +void checkHeapChain (bdescr *bd) { StgPtr p; -#if defined(THREADED_RTS) - // heap sanity checking doesn't work with SMP, because we can't - // zero the slop (see Updates.h). - return; -#endif - for (; bd != NULL; bd = bd->link) { if(!(bd->flags & BF_SWEPT)) { p = bd->start; @@ -489,7 +486,7 @@ } } -void +void checkHeapChunk(StgPtr start, StgPtr end) { StgPtr p; @@ -514,19 +511,21 @@ } } -void -checkTSO(StgTSO *tso) +static void +checkSTACK (StgStack *stack) { - StgPtr sp = tso->sp; - StgPtr stack = tso->stack; - StgOffset stack_size = tso->stack_size; - StgPtr stack_end = stack + stack_size; + StgPtr sp = stack->sp; + StgOffset stack_size = stack->stack_size; + StgPtr stack_end = stack->stack + stack_size; - if (tso->what_next == ThreadRelocated) { - checkTSO(tso->_link); - return; - } + ASSERT(stack->stack <= sp && sp <= stack_end); + checkStackChunk(sp, stack_end); +} + +void +checkTSO(StgTSO *tso) +{ if (tso->what_next == ThreadKilled) { /* The garbage collector doesn't bother following any pointers * from dead threads, so don't check sanity here. @@ -537,16 +536,24 @@ ASSERT(tso->_link == END_TSO_QUEUE || tso->_link->header.info == &stg_MVAR_TSO_QUEUE_info || tso->_link->header.info == &stg_TSO_info); - ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso->block_info.closure)); + + if ( tso->why_blocked == BlockedOnMVar + || tso->why_blocked == BlockedOnBlackHole + || tso->why_blocked == BlockedOnMsgThrowTo + || tso->why_blocked == NotBlocked + ) { + ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso->block_info.closure)); + } + ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso->bq)); ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso->blocked_exceptions)); + ASSERT(LOOKS_LIKE_CLOSURE_PTR(tso->stackobj)); - ASSERT(stack <= sp && sp < stack_end); - - checkStackChunk(sp, stack_end); + // XXX are we checking the stack twice? + checkSTACK(tso->stackobj); } -/* +/* Check that all TSOs have been evacuated. Optionally also check the sanity of the TSOs. */ @@ -564,14 +571,30 @@ if (checkTSOs) checkTSO(tso); - tso = deRefTSO(tso); - // If this TSO is dirty and in an old generation, it better // be on the mutable list. - if (tso->dirty || (tso->flags & TSO_LINK_DIRTY)) { + if (tso->dirty) { ASSERT(Bdescr((P_)tso)->gen_no == 0 || (tso->flags & TSO_MARKED)); tso->flags &= ~TSO_MARKED; } + + { + StgStack *stack; + StgUnderflowFrame *frame; + + stack = tso->stackobj; + while (1) { + if (stack->dirty & 1) { + ASSERT(Bdescr((P_)stack)->gen_no == 0 || (stack->dirty & TSO_MARKED)); + stack->dirty &= ~TSO_MARKED; + } + frame = (StgUnderflowFrame*) (stack->stack + stack->stack_size + - sizeofW(StgUnderflowFrame)); + if (frame->info != &stg_stack_underflow_frame_info + || frame->next_chunk == (StgStack*)END_TSO_QUEUE) break; + stack = frame->next_chunk; + } + } } } } @@ -580,7 +603,7 @@ Check mutable list sanity. -------------------------------------------------------------------------- */ -void +static void checkMutableList( bdescr *mut_bd, nat gen ) { bdescr *bd; @@ -590,26 +613,37 @@ for (bd = mut_bd; bd != NULL; bd = bd->link) { for (q = bd->start; q < bd->free; q++) { p = (StgClosure *)*q; - ASSERT(!HEAP_ALLOCED(p) || Bdescr((P_)p)->gen_no == gen); - if (get_itbl(p)->type == TSO) { + ASSERT(!HEAP_ALLOCED(p) || Bdescr((P_)p)->gen_no == gen); + checkClosure(p); + + switch (get_itbl(p)->type) { + case TSO: ((StgTSO *)p)->flags |= TSO_MARKED; + break; + case STACK: + ((StgStack *)p)->dirty |= TSO_MARKED; + break; } - } + } } } -void -checkMutableLists (rtsBool checkTSOs) +static void +checkLocalMutableLists (nat cap_no) { - nat g, i; + nat g; + for (g = 1; g < RtsFlags.GcFlags.generations; g++) { + checkMutableList(capabilities[cap_no].mut_lists[g], g); + } +} - for (g = 0; g < RtsFlags.GcFlags.generations; g++) { - checkMutableList(generations[g].mut_list, g); - for (i = 0; i < n_capabilities; i++) { - checkMutableList(capabilities[i].mut_lists[g], g); - } +static void +checkMutableLists (void) +{ + nat i; + for (i = 0; i < n_capabilities; i++) { + checkLocalMutableLists(i); } - checkGlobalTSOList(checkTSOs); } /* @@ -663,7 +697,8 @@ prev = NULL; for (bd = nursery->blocks; bd != NULL; bd = bd->link) { - ASSERT(bd->u.back == prev); + ASSERT(bd->gen == g0); + ASSERT(bd->u.back == prev); prev = bd; blocks += bd->blocks; } @@ -671,41 +706,59 @@ ASSERT(blocks == nursery->n_blocks); } +static void checkGeneration (generation *gen, + rtsBool after_major_gc USED_IF_THREADS) +{ + nat n; + gen_workspace *ws; + + ASSERT(countBlocks(gen->blocks) == gen->n_blocks); + ASSERT(countBlocks(gen->large_objects) == gen->n_large_blocks); + +#if defined(THREADED_RTS) + // heap sanity checking doesn't work with SMP, because we can't + // zero the slop (see Updates.h). However, we can sanity-check + // the heap after a major gc, because there is no slop. + if (!after_major_gc) return; +#endif + + checkHeapChain(gen->blocks); + + for (n = 0; n < n_capabilities; n++) { + ws = &gc_threads[n]->gens[gen->no]; + checkHeapChain(ws->todo_bd); + checkHeapChain(ws->part_list); + checkHeapChain(ws->scavd_list); + } + + checkLargeObjects(gen->large_objects); +} /* Full heap sanity check. */ -void -checkSanity( rtsBool check_heap ) +static void checkFullHeap (rtsBool after_major_gc) { nat g, n; for (g = 0; g < RtsFlags.GcFlags.generations; g++) { - ASSERT(countBlocks(generations[g].blocks) - == generations[g].n_blocks); - ASSERT(countBlocks(generations[g].large_objects) - == generations[g].n_large_blocks); - if (check_heap) { - checkHeap(generations[g].blocks); - } - checkLargeObjects(generations[g].large_objects); + checkGeneration(&generations[g], after_major_gc); } - for (n = 0; n < n_capabilities; n++) { checkNurserySanity(&nurseries[n]); } - +} + +void checkSanity (rtsBool after_gc, rtsBool major_gc) +{ + checkFullHeap(after_gc && major_gc); + checkFreeListSanity(); -#if defined(THREADED_RTS) // always check the stacks in threaded mode, because checkHeap() // does nothing in this case. - checkMutableLists(rtsTrue); -#else - if (check_heap) { - checkMutableLists(rtsFalse); - } else { - checkMutableLists(rtsTrue); + if (after_gc) { + checkMutableLists(); + checkGlobalTSOList(rtsTrue); } -#endif } // If memInventory() calculates that we have a memory leak, this @@ -718,19 +771,22 @@ static void findMemoryLeak (void) { - nat g, i; - for (g = 0; g < RtsFlags.GcFlags.generations; g++) { - for (i = 0; i < n_capabilities; i++) { - markBlocks(capabilities[i].mut_lists[g]); - } - markBlocks(generations[g].mut_list); - markBlocks(generations[g].blocks); - markBlocks(generations[g].large_objects); - } + nat g, i; + for (g = 0; g < RtsFlags.GcFlags.generations; g++) { + for (i = 0; i < n_capabilities; i++) { + markBlocks(capabilities[i].mut_lists[g]); + markBlocks(gc_threads[i]->gens[g].part_list); + markBlocks(gc_threads[i]->gens[g].scavd_list); + markBlocks(gc_threads[i]->gens[g].todo_bd); + } + markBlocks(generations[g].blocks); + markBlocks(generations[g].large_objects); + } - for (i = 0; i < n_capabilities; i++) { - markBlocks(nurseries[i].blocks); - } + for (i = 0; i < n_capabilities; i++) { + markBlocks(nurseries[i].blocks); + markBlocks(capabilities[i].pinned_object_block); + } #ifdef PROFILING // TODO: @@ -810,8 +866,10 @@ gen_blocks[g] = 0; for (i = 0; i < n_capabilities; i++) { gen_blocks[g] += countBlocks(capabilities[i].mut_lists[g]); + gen_blocks[g] += countBlocks(gc_threads[i]->gens[g].part_list); + gen_blocks[g] += countBlocks(gc_threads[i]->gens[g].scavd_list); + gen_blocks[g] += countBlocks(gc_threads[i]->gens[g].todo_bd); } - gen_blocks[g] += countAllocdBlocks(generations[g].mut_list); gen_blocks[g] += genBlocks(&generations[g]); } @@ -819,6 +877,9 @@ for (i = 0; i < n_capabilities; i++) { ASSERT(countBlocks(nurseries[i].blocks) == nurseries[i].n_blocks); nursery_blocks += nurseries[i].n_blocks; + if (capabilities[i].pinned_object_block != NULL) { + nursery_blocks += capabilities[i].pinned_object_block->blocks; + } } retainer_blocks = 0; diff -Nru ghc-7.0.3/rts/sm/Sanity.h ghc-7.2.1/rts/sm/Sanity.h --- ghc-7.0.3/rts/sm/Sanity.h 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/rts/sm/Sanity.h 2011-08-07 17:10:05.000000000 +0000 @@ -21,9 +21,9 @@ # endif /* debugging routines */ -void checkSanity ( rtsBool check_heap ); +void checkSanity ( rtsBool after_gc, rtsBool major_gc ); void checkNurserySanity ( nursery *nursery ); -void checkHeap ( bdescr *bd ); +void checkHeapChain ( bdescr *bd ); void checkHeapChunk ( StgPtr start, StgPtr end ); void checkLargeObjects ( bdescr *bd ); void checkTSO ( StgTSO* tso ); @@ -33,9 +33,6 @@ StgOffset checkStackFrame ( StgPtr sp ); StgOffset checkClosure ( StgClosure* p ); -void checkMutableList ( bdescr *bd, nat gen ); -void checkMutableLists ( rtsBool checkTSOs ); - void checkRunQueue (Capability *cap); void memInventory (rtsBool show); diff -Nru ghc-7.0.3/rts/sm/Scav.c ghc-7.2.1/rts/sm/Scav.c --- ghc-7.0.3/rts/sm/Scav.c 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/rts/sm/Scav.c 2011-08-07 17:10:05.000000000 +0000 @@ -51,14 +51,6 @@ { rtsBool saved_eager; - if (tso->what_next == ThreadRelocated) { - // the only way this can happen is if the old TSO was on the - // mutable list. We might have other links to this defunct - // TSO, so we must update its link field. - evacuate((StgClosure**)&tso->_link); - return; - } - debugTrace(DEBUG_gc,"scavenging thread %d",(int)tso->id); // update the pointer from the Task. @@ -69,17 +61,13 @@ saved_eager = gct->eager_promotion; gct->eager_promotion = rtsFalse; - evacuate((StgClosure **)&tso->blocked_exceptions); evacuate((StgClosure **)&tso->bq); // scavange current transaction record evacuate((StgClosure **)&tso->trec); - - // scavenge this thread's stack - scavenge_stack(tso->sp, &(tso->stack[tso->stack_size])); - tso->dirty = gct->failed_to_evac; + evacuate((StgClosure **)&tso->stackobj); evacuate((StgClosure **)&tso->_link); if ( tso->why_blocked == BlockedOnMVar @@ -99,11 +87,7 @@ } #endif - if (tso->dirty == 0 && gct->failed_to_evac) { - tso->flags |= TSO_LINK_DIRTY; - } else { - tso->flags &= ~TSO_LINK_DIRTY; - } + tso->dirty = gct->failed_to_evac; gct->eager_promotion = saved_eager; } @@ -378,11 +362,11 @@ /* ----------------------------------------------------------------------------- Scavenge a block from the given scan pointer up to bd->free. - evac_gen is set by the caller to be either zero (for a step in a + evac_gen_no is set by the caller to be either zero (for a step in a generation < N) or G where G is the generation of the step being scavenged. - We sometimes temporarily change evac_gen back to zero if we're + We sometimes temporarily change evac_gen_no back to zero if we're scavenging a mutable object where eager promotion isn't such a good idea. -------------------------------------------------------------------------- */ @@ -399,7 +383,7 @@ bd->start, bd->gen_no, bd->u.scan); gct->scan_bd = bd; - gct->evac_gen = bd->gen; + gct->evac_gen_no = bd->gen_no; saved_eager_promotion = gct->eager_promotion; gct->failed_to_evac = rtsFalse; @@ -661,12 +645,25 @@ case TSO: { - StgTSO *tso = (StgTSO *)p; - scavengeTSO(tso); - p += tso_sizeW(tso); + scavengeTSO((StgTSO *)p); + p += sizeofW(StgTSO); break; } + case STACK: + { + StgStack *stack = (StgStack*)p; + + gct->eager_promotion = rtsFalse; + + scavenge_stack(stack->sp, stack->stack + stack->stack_size); + stack->dirty = gct->failed_to_evac; + p += stack_sizeW(stack); + + gct->eager_promotion = saved_eager_promotion; + break; + } + case MUT_PRIM: { StgPtr end; @@ -757,7 +754,7 @@ StgInfoTable *info; rtsBool saved_eager_promotion; - gct->evac_gen = oldest_gen; + gct->evac_gen_no = oldest_gen->no; saved_eager_promotion = gct->eager_promotion; while ((p = pop_mark_stack())) { @@ -991,6 +988,19 @@ break; } + case STACK: + { + StgStack *stack = (StgStack*)p; + + gct->eager_promotion = rtsFalse; + + scavenge_stack(stack->sp, stack->stack + stack->stack_size); + stack->dirty = gct->failed_to_evac; + + gct->eager_promotion = saved_eager_promotion; + break; + } + case MUT_PRIM: { StgPtr end; @@ -1031,8 +1041,8 @@ if (gct->failed_to_evac) { gct->failed_to_evac = rtsFalse; - if (gct->evac_gen) { - recordMutableGen_GC((StgClosure *)q, gct->evac_gen->no); + if (gct->evac_gen_no) { + recordMutableGen_GC((StgClosure *)q, gct->evac_gen_no); } } } // while (p = pop_mark_stack()) @@ -1227,6 +1237,19 @@ break; } + case STACK: + { + StgStack *stack = (StgStack*)p; + + gct->eager_promotion = rtsFalse; + + scavenge_stack(stack->sp, stack->stack + stack->stack_size); + stack->dirty = gct->failed_to_evac; + + gct->eager_promotion = saved_eager_promotion; + break; + } + case MUT_PRIM: { StgPtr end; @@ -1317,8 +1340,10 @@ scavenge_mutable_list(bdescr *bd, generation *gen) { StgPtr p, q; + nat gen_no; - gct->evac_gen = gen; + gen_no = gen->no; + gct->evac_gen_no = gen_no; for (; bd != NULL; bd = bd->link) { for (q = bd->start; q < bd->free; q++) { p = (StgPtr)*q; @@ -1353,7 +1378,7 @@ // switch (get_itbl((StgClosure *)p)->type) { case MUT_ARR_PTRS_CLEAN: - recordMutableGen_GC((StgClosure *)p,gen->no); + recordMutableGen_GC((StgClosure *)p,gen_no); continue; case MUT_ARR_PTRS_DIRTY: { @@ -1371,43 +1396,17 @@ gct->eager_promotion = saved_eager_promotion; gct->failed_to_evac = rtsFalse; - recordMutableGen_GC((StgClosure *)p,gen->no); + recordMutableGen_GC((StgClosure *)p,gen_no); continue; } - case TSO: { - StgTSO *tso = (StgTSO *)p; - if (tso->dirty == 0) { - // Should be on the mutable list because its link - // field is dirty. However, in parallel GC we may - // have a thread on multiple mutable lists, so - // this assertion would be invalid: - // ASSERT(tso->flags & TSO_LINK_DIRTY); - - evacuate((StgClosure **)&tso->_link); - if ( tso->why_blocked == BlockedOnMVar - || tso->why_blocked == BlockedOnBlackHole - || tso->why_blocked == BlockedOnMsgThrowTo - || tso->why_blocked == NotBlocked - ) { - evacuate((StgClosure **)&tso->block_info.prev); - } - if (gct->failed_to_evac) { - recordMutableGen_GC((StgClosure *)p,gen->no); - gct->failed_to_evac = rtsFalse; - } else { - tso->flags &= ~TSO_LINK_DIRTY; - } - continue; - } - } - default: + default: ; } if (scavenge_one(p)) { // didn't manage to promote everything, so put the // object back on the list. - recordMutableGen_GC((StgClosure *)p,gen->no); + recordMutableGen_GC((StgClosure *)p,gen_no); } } } @@ -1449,7 +1448,7 @@ /* Always evacuate straight to the oldest generation for static * objects */ - gct->evac_gen = oldest_gen; + gct->evac_gen_no = oldest_gen->no; /* keep going until we've scavenged all the objects on the linked list... */ @@ -1643,6 +1642,7 @@ case CATCH_STM_FRAME: case CATCH_RETRY_FRAME: case ATOMICALLY_FRAME: + case UNDERFLOW_FRAME: case STOP_FRAME: case CATCH_FRAME: case RET_SMALL: @@ -1743,7 +1743,7 @@ bdescr *bd; StgPtr p; - gct->evac_gen = ws->gen; + gct->evac_gen_no = ws->gen->no; bd = ws->todo_large_objects; @@ -1755,10 +1755,10 @@ // the front when evacuating. ws->todo_large_objects = bd->link; - ACQUIRE_SPIN_LOCK(&ws->gen->sync_large_objects); + ACQUIRE_SPIN_LOCK(&ws->gen->sync); dbl_link_onto(bd, &ws->gen->scavenged_large_objects); ws->gen->n_scavenged_large_blocks += bd->blocks; - RELEASE_SPIN_LOCK(&ws->gen->sync_large_objects); + RELEASE_SPIN_LOCK(&ws->gen->sync); p = bd->start; if (scavenge_one(p)) { diff -Nru ghc-7.0.3/rts/sm/Storage.c ghc-7.2.1/rts/sm/Storage.c --- ghc-7.0.3/rts/sm/Storage.c 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/rts/sm/Storage.c 2011-08-07 17:10:05.000000000 +0000 @@ -15,6 +15,7 @@ #include "Rts.h" #include "Storage.h" +#include "GCThread.h" #include "RtsUtils.h" #include "Stats.h" #include "BlockAlloc.h" @@ -40,8 +41,8 @@ StgClosure *revertible_caf_list = NULL; rtsBool keepCAFs; -nat alloc_blocks_lim; /* GC if n_large_blocks in any nursery - * reaches this. */ +nat large_alloc_lim; /* GC if n_large_blocks in any nursery + * reaches this. */ bdescr *exec_block; @@ -77,15 +78,14 @@ gen->n_old_blocks = 0; gen->large_objects = NULL; gen->n_large_blocks = 0; - gen->n_new_large_blocks = 0; - gen->mut_list = allocBlock(); + gen->n_new_large_words = 0; gen->scavenged_large_objects = NULL; gen->n_scavenged_large_blocks = 0; gen->mark = 0; gen->compact = 0; gen->bitmap = NULL; #ifdef THREADED_RTS - initSpinLock(&gen->sync_large_objects); + initSpinLock(&gen->sync); #endif gen->threads = END_TSO_QUEUE; gen->old_threads = END_TSO_QUEUE; @@ -181,7 +181,7 @@ revertible_caf_list = END_OF_STATIC_LIST; /* initialise the allocate() interface */ - alloc_blocks_lim = RtsFlags.GcFlags.minAllocAreaSize; + large_alloc_lim = RtsFlags.GcFlags.minAllocAreaSize * BLOCK_SIZE_W; exec_block = NULL; @@ -209,7 +209,7 @@ void exitStorage (void) { - stat_exit(calcAllocated()); + stat_exit(calcAllocated(rtsTrue)); } void @@ -401,21 +401,31 @@ assignNurseriesToCapabilities(); } -void -resetNurseries( void ) +lnat // words allocated +clearNurseries (void) { + lnat allocated = 0; nat i; bdescr *bd; for (i = 0; i < n_capabilities; i++) { for (bd = nurseries[i].blocks; bd; bd = bd->link) { - bd->free = bd->start; + allocated += (lnat)(bd->free - bd->start); + bd->free = bd->start; ASSERT(bd->gen_no == 0); ASSERT(bd->gen == g0); IF_DEBUG(sanity,memset(bd->start, 0xaa, BLOCK_SIZE)); } } + + return allocated; +} + +void +resetNurseries (void) +{ assignNurseriesToCapabilities(); + } lnat @@ -495,12 +505,12 @@ /* ----------------------------------------------------------------------------- - move_TSO is called to update the TSO structure after it has been + move_STACK is called to update the TSO structure after it has been moved from one place to another. -------------------------------------------------------------------------- */ void -move_TSO (StgTSO *src, StgTSO *dest) +move_STACK (StgStack *src, StgStack *dest) { ptrdiff_t diff; @@ -510,45 +520,6 @@ } /* ----------------------------------------------------------------------------- - split N blocks off the front of the given bdescr, returning the - new block group. We add the remainder to the large_blocks list - in the same step as the original block. - -------------------------------------------------------------------------- */ - -bdescr * -splitLargeBlock (bdescr *bd, nat blocks) -{ - bdescr *new_bd; - - ACQUIRE_SM_LOCK; - - ASSERT(countBlocks(bd->gen->large_objects) == bd->gen->n_large_blocks); - - // subtract the original number of blocks from the counter first - bd->gen->n_large_blocks -= bd->blocks; - - new_bd = splitBlockGroup (bd, blocks); - initBdescr(new_bd, bd->gen, bd->gen->to); - new_bd->flags = BF_LARGE | (bd->flags & BF_EVACUATED); - // if new_bd is in an old generation, we have to set BF_EVACUATED - new_bd->free = bd->free; - dbl_link_onto(new_bd, &bd->gen->large_objects); - - ASSERT(new_bd->free <= new_bd->start + new_bd->blocks * BLOCK_SIZE_W); - - // add the new number of blocks to the counter. Due to the gaps - // for block descriptors, new_bd->blocks + bd->blocks might not be - // equal to the original bd->blocks, which is why we do it this way. - bd->gen->n_large_blocks += bd->blocks + new_bd->blocks; - - ASSERT(countBlocks(bd->gen->large_objects) == bd->gen->n_large_blocks); - - RELEASE_SM_LOCK; - - return new_bd; -} - -/* ----------------------------------------------------------------------------- allocate() This allocates memory in the current thread - it is intended for @@ -588,7 +559,7 @@ bd = allocGroup(req_blocks); dbl_link_onto(bd, &g0->large_objects); g0->n_large_blocks += bd->blocks; // might be larger than req_blocks - g0->n_new_large_blocks += bd->blocks; + g0->n_new_large_words += n; RELEASE_SM_LOCK; initBdescr(bd, g0, g0); bd->flags = BF_LARGE; @@ -686,14 +657,29 @@ // If we don't have a block of pinned objects yet, or the current // one isn't large enough to hold the new object, allocate a new one. if (bd == NULL || (bd->free + n) > (bd->start + BLOCK_SIZE_W)) { + // The pinned_object_block remains attached to the capability + // until it is full, even if a GC occurs. We want this + // behaviour because otherwise the unallocated portion of the + // block would be forever slop, and under certain workloads + // (allocating a few ByteStrings per GC) we accumulate a lot + // of slop. + // + // So, the pinned_object_block is initially marked + // BF_EVACUATED so the GC won't touch it. When it is full, + // we place it on the large_objects list, and at the start of + // the next GC the BF_EVACUATED flag will be cleared, and the + // block will be promoted as usual (if anything in it is + // live). ACQUIRE_SM_LOCK; - cap->pinned_object_block = bd = allocBlock(); - dbl_link_onto(bd, &g0->large_objects); - g0->n_large_blocks++; - g0->n_new_large_blocks++; + if (bd != NULL) { + dbl_link_onto(bd, &g0->large_objects); + g0->n_large_blocks++; + g0->n_new_large_words += bd->free - bd->start; + } + cap->pinned_object_block = bd = allocBlock(); RELEASE_SM_LOCK; initBdescr(bd, g0, g0); - bd->flags = BF_PINNED | BF_LARGE; + bd->flags = BF_PINNED | BF_LARGE | BF_EVACUATED; bd->free = bd->start; } @@ -731,8 +717,8 @@ void setTSOLink (Capability *cap, StgTSO *tso, StgTSO *target) { - if (tso->dirty == 0 && (tso->flags & TSO_LINK_DIRTY) == 0) { - tso->flags |= TSO_LINK_DIRTY; + if (tso->dirty == 0) { + tso->dirty = 1; recordClosureMutated(cap,(StgClosure*)tso); } tso->_link = target; @@ -741,8 +727,8 @@ void setTSOPrev (Capability *cap, StgTSO *tso, StgTSO *target) { - if (tso->dirty == 0 && (tso->flags & TSO_LINK_DIRTY) == 0) { - tso->flags |= TSO_LINK_DIRTY; + if (tso->dirty == 0) { + tso->dirty = 1; recordClosureMutated(cap,(StgClosure*)tso); } tso->block_info.prev = target; @@ -751,10 +737,19 @@ void dirty_TSO (Capability *cap, StgTSO *tso) { - if (tso->dirty == 0 && (tso->flags & TSO_LINK_DIRTY) == 0) { + if (tso->dirty == 0) { + tso->dirty = 1; recordClosureMutated(cap,(StgClosure*)tso); } - tso->dirty = 1; +} + +void +dirty_STACK (Capability *cap, StgStack *stack) +{ + if (stack->dirty == 0) { + stack->dirty = 1; + recordClosureMutated(cap,(StgClosure*)stack); + } } /* @@ -784,56 +779,27 @@ * -------------------------------------------------------------------------- */ lnat -calcAllocated( void ) +calcAllocated (rtsBool include_nurseries) { - nat allocated; - bdescr *bd; + nat allocated = 0; nat i; - allocated = countNurseryBlocks() * BLOCK_SIZE_W; - - for (i = 0; i < n_capabilities; i++) { - Capability *cap; - for ( bd = capabilities[i].r.rCurrentNursery->link; - bd != NULL; bd = bd->link ) { - allocated -= BLOCK_SIZE_W; - } - cap = &capabilities[i]; - if (cap->r.rCurrentNursery->free < - cap->r.rCurrentNursery->start + BLOCK_SIZE_W) { - allocated -= (cap->r.rCurrentNursery->start + BLOCK_SIZE_W) - - cap->r.rCurrentNursery->free; - } - if (cap->pinned_object_block != NULL) { - allocated -= (cap->pinned_object_block->start + BLOCK_SIZE_W) - - cap->pinned_object_block->free; + // When called from GC.c, we already have the allocation count for + // the nursery from resetNurseries(), so we don't need to walk + // through these block lists again. + if (include_nurseries) + { + for (i = 0; i < n_capabilities; i++) { + allocated += countOccupied(nurseries[i].blocks); } } - allocated += g0->n_new_large_blocks * BLOCK_SIZE_W; + // add in sizes of new large and pinned objects + allocated += g0->n_new_large_words; return allocated; } -/* Approximate the amount of live data in the heap. To be called just - * after garbage collection (see GarbageCollect()). - */ -lnat calcLiveBlocks (void) -{ - nat g; - lnat live = 0; - generation *gen; - - for (g = 0; g < RtsFlags.GcFlags.generations; g++) { - /* approximate amount of live data (doesn't take into account slop - * at end of each block). - */ - gen = &generations[g]; - live += gen->n_large_blocks + gen->n_blocks; - } - return live; -} - lnat countOccupied (bdescr *bd) { lnat words; @@ -846,18 +812,60 @@ return words; } +lnat genLiveWords (generation *gen) +{ + return gen->n_words + countOccupied(gen->large_objects); +} + +lnat genLiveBlocks (generation *gen) +{ + return gen->n_blocks + gen->n_large_blocks; +} + +lnat gcThreadLiveWords (nat i, nat g) +{ + lnat words; + + words = countOccupied(gc_threads[i]->gens[g].todo_bd); + words += countOccupied(gc_threads[i]->gens[g].part_list); + words += countOccupied(gc_threads[i]->gens[g].scavd_list); + + return words; +} + +lnat gcThreadLiveBlocks (nat i, nat g) +{ + lnat blocks; + + blocks = countBlocks(gc_threads[i]->gens[g].todo_bd); + blocks += gc_threads[i]->gens[g].n_part_blocks; + blocks += gc_threads[i]->gens[g].n_scavd_blocks; + + return blocks; +} + // Return an accurate count of the live data in the heap, excluding // generation 0. lnat calcLiveWords (void) { nat g; lnat live; - generation *gen; - + live = 0; for (g = 0; g < RtsFlags.GcFlags.generations; g++) { - gen = &generations[g]; - live += gen->n_words + countOccupied(gen->large_objects); + live += genLiveWords(&generations[g]); + } + return live; +} + +lnat calcLiveBlocks (void) +{ + nat g; + lnat live; + + live = 0; + for (g = 0; g < RtsFlags.GcFlags.generations; g++) { + live += genLiveBlocks(&generations[g]); } return live; } diff -Nru ghc-7.0.3/rts/sm/Storage.h ghc-7.2.1/rts/sm/Storage.h --- ghc-7.0.3/rts/sm/Storage.h 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/rts/sm/Storage.h 2011-08-07 17:10:05.000000000 +0000 @@ -29,7 +29,7 @@ doYouWantToGC( Capability *cap ) { return (cap->r.rCurrentNursery->link == NULL || - g0->n_large_blocks >= alloc_blocks_lim); + g0->n_new_large_words >= large_alloc_lim); } /* for splitting blocks groups in two */ @@ -38,11 +38,6 @@ /* ----------------------------------------------------------------------------- Generational garbage collection support - recordMutable(StgPtr p) Informs the garbage collector that a - previously immutable object has - become (permanently) mutable. Used - by thawArray and similar. - updateWithIndirection(p1,p2) Updates the object at p1 with an indirection pointing to p2. This is normally called for objects in an old @@ -69,48 +64,6 @@ #define ASSERT_SM_LOCK() #endif -INLINE_HEADER void -recordMutableGen(StgClosure *p, nat gen_no) -{ - bdescr *bd; - - bd = generations[gen_no].mut_list; - if (bd->free >= bd->start + BLOCK_SIZE_W) { - bdescr *new_bd; - new_bd = allocBlock(); - new_bd->link = bd; - bd = new_bd; - generations[gen_no].mut_list = bd; - } - *bd->free++ = (StgWord)p; - -} - -INLINE_HEADER void -recordMutableGenLock(StgClosure *p, nat gen_no) -{ - ACQUIRE_SM_LOCK; - recordMutableGen(p,gen_no); - RELEASE_SM_LOCK; -} - -INLINE_HEADER void -recordMutable(StgClosure *p) -{ - bdescr *bd; - ASSERT(closure_MUTABLE(p)); - bd = Bdescr((P_)p); - if (bd->gen_no > 0) recordMutableGen(p, bd->gen_no); -} - -INLINE_HEADER void -recordMutableLock(StgClosure *p) -{ - ACQUIRE_SM_LOCK; - recordMutable(p); - RELEASE_SM_LOCK; -} - /* ----------------------------------------------------------------------------- The write barrier for MVARs -------------------------------------------------------------------------- */ @@ -124,6 +77,7 @@ extern nursery *nurseries; void resetNurseries ( void ); +lnat clearNurseries ( void ); void resizeNurseries ( nat blocks ); void resizeNurseriesFixed ( nat blocks ); lnat countNurseryBlocks ( void ); @@ -132,12 +86,19 @@ Stats 'n' DEBUG stuff -------------------------------------------------------------------------- */ -lnat calcAllocated (void); -lnat calcLiveBlocks (void); -lnat calcLiveWords (void); +lnat calcAllocated (rtsBool count_nurseries); lnat countOccupied (bdescr *bd); lnat calcNeeded (void); +lnat gcThreadLiveWords (nat i, nat g); +lnat gcThreadLiveBlocks (nat i, nat g); + +lnat genLiveWords (generation *gen); +lnat genLiveBlocks (generation *gen); + +lnat calcLiveBlocks (void); +lnat calcLiveWords (void); + /* ---------------------------------------------------------------------------- Storage manager internal APIs and globals ------------------------------------------------------------------------- */ @@ -146,7 +107,7 @@ #define END_OF_STATIC_LIST ((StgClosure*)1) -void move_TSO (StgTSO *src, StgTSO *dest); +void move_STACK (StgStack *src, StgStack *dest); extern StgClosure * caf_list; extern StgClosure * revertible_caf_list; diff -Nru ghc-7.0.3/rts/Sparks.c ghc-7.2.1/rts/Sparks.c --- ghc-7.0.3/rts/Sparks.c 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/rts/Sparks.c 2011-08-07 17:10:05.000000000 +0000 @@ -71,9 +71,10 @@ if (closure_SHOULD_SPARK(p)) { pushWSDeque(pool,p); - } - - cap->sparks_created++; + cap->sparks_created++; + } else { + cap->sparks_dud++; + } return 1; } @@ -196,31 +197,57 @@ // We have to be careful here: in the parallel GC, another // thread might evacuate this closure while we're looking at it, // so grab the info pointer just once. - info = spark->header.info; - if (IS_FORWARDING_PTR(info)) { - tmp = (StgClosure*)UN_FORWARDING_PTR(info); - /* if valuable work: shift inside the pool */ - if (closure_SHOULD_SPARK(tmp)) { - elements[botInd] = tmp; // keep entry (new address) - botInd++; - n++; - } else { - pruned_sparks++; // discard spark - cap->sparks_pruned++; - } - } else if (HEAP_ALLOCED(spark) && - (Bdescr((P_)spark)->flags & BF_EVACUATED)) { - if (closure_SHOULD_SPARK(spark)) { - elements[botInd] = spark; // keep entry (new address) - botInd++; - n++; + if (GET_CLOSURE_TAG(spark) != 0) { + // Tagged pointer is a value, so the spark has fizzled. It + // probably never happens that we get a tagged pointer in + // the spark pool, because we would have pruned the spark + // during the previous GC cycle if it turned out to be + // evaluated, but it doesn't hurt to have this check for + // robustness. + pruned_sparks++; + cap->sparks_fizzled++; + } else { + info = spark->header.info; + if (IS_FORWARDING_PTR(info)) { + tmp = (StgClosure*)UN_FORWARDING_PTR(info); + /* if valuable work: shift inside the pool */ + if (closure_SHOULD_SPARK(tmp)) { + elements[botInd] = tmp; // keep entry (new address) + botInd++; + n++; + } else { + pruned_sparks++; // discard spark + cap->sparks_fizzled++; + } + } else if (HEAP_ALLOCED(spark)) { + if ((Bdescr((P_)spark)->flags & BF_EVACUATED)) { + if (closure_SHOULD_SPARK(spark)) { + elements[botInd] = spark; // keep entry (new address) + botInd++; + n++; + } else { + pruned_sparks++; // discard spark + cap->sparks_fizzled++; + } + } else { + pruned_sparks++; // discard spark + cap->sparks_gcd++; + } } else { - pruned_sparks++; // discard spark - cap->sparks_pruned++; + if (INFO_PTR_TO_STRUCT(info)->type == THUNK_STATIC) { + if (*THUNK_STATIC_LINK(spark) != NULL) { + elements[botInd] = spark; // keep entry (new address) + botInd++; + n++; + } else { + pruned_sparks++; // discard spark + cap->sparks_gcd++; + } + } else { + pruned_sparks++; // discard spark + cap->sparks_fizzled++; + } } - } else { - pruned_sparks++; // discard spark - cap->sparks_pruned++; } currInd++; diff -Nru ghc-7.0.3/rts/Stats.c ghc-7.2.1/rts/Stats.c --- ghc-7.0.3/rts/Stats.c 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/rts/Stats.c 2011-08-07 17:10:05.000000000 +0000 @@ -16,6 +16,8 @@ #include "GetTime.h" #include "sm/Storage.h" #include "sm/GC.h" // gc_alloc_block_sync, whitehole_spin +#include "sm/GCThread.h" +#include "sm/BlockAlloc.h" #if USE_PAPI #include "Papi.h" @@ -26,31 +28,23 @@ #define TICK_TO_DBL(t) ((double)(t) / TICKS_PER_SECOND) -static Ticks ElapsedTimeStart = 0; +static Ticks + start_init_cpu, start_init_elapsed, + end_init_cpu, end_init_elapsed, + start_exit_cpu, start_exit_elapsed, + end_exit_cpu, end_exit_elapsed; -static Ticks InitUserTime = 0; -static Ticks InitElapsedTime = 0; -static Ticks InitElapsedStamp = 0; +static Ticks GC_tot_cpu = 0; -static Ticks MutUserTime = 0; -static Ticks MutElapsedTime = 0; -static Ticks MutElapsedStamp = 0; - -static Ticks ExitUserTime = 0; -static Ticks ExitElapsedTime = 0; - -static StgWord64 GC_tot_alloc = 0; -static StgWord64 GC_tot_copied = 0; +static StgWord64 GC_tot_alloc = 0; +static StgWord64 GC_tot_copied = 0; static StgWord64 GC_par_max_copied = 0; static StgWord64 GC_par_avg_copied = 0; -static Ticks GC_start_time = 0, GC_tot_time = 0; /* User GC Time */ -static Ticks GCe_start_time = 0, GCe_tot_time = 0; /* Elapsed GC time */ - #ifdef PROFILING -static Ticks RP_start_time = 0, RP_tot_time = 0; /* retainer prof user time */ -static Ticks RPe_start_time = 0, RPe_tot_time = 0; /* retainer prof elap time */ +static Ticks RP_start_time = 0, RP_tot_time = 0; // retainer prof user time +static Ticks RPe_start_time = 0, RPe_tot_time = 0; // retainer prof elap time static Ticks HC_start_time, HC_tot_time = 0; // heap census prof user time static Ticks HCe_start_time, HCe_tot_time = 0; // heap census prof elap time @@ -62,99 +56,87 @@ #define PROF_VAL(x) 0 #endif -static lnat MaxResidency = 0; // in words; for stats only -static lnat AvgResidency = 0; -static lnat ResidencySamples = 0; // for stats only -static lnat MaxSlop = 0; - -static lnat GC_start_faults = 0, GC_end_faults = 0; - -static Ticks *GC_coll_times = NULL; -static Ticks *GC_coll_etimes = NULL; +static lnat max_residency = 0; // in words; for stats only +static lnat avg_residency = 0; +static lnat residency_samples = 0; // for stats only +static lnat max_slop = 0; + +static lnat GC_end_faults = 0; + +static Ticks *GC_coll_cpu = NULL; +static Ticks *GC_coll_elapsed = NULL; +static Ticks *GC_coll_max_pause = NULL; static void statsFlush( void ); static void statsClose( void ); -Ticks stat_getElapsedGCTime(void) -{ - return GCe_tot_time; -} +/* ----------------------------------------------------------------------------- + Current elapsed time + ------------------------------------------------------------------------- */ Ticks stat_getElapsedTime(void) { - return getProcessElapsedTime() - ElapsedTimeStart; + return getProcessElapsedTime() - start_init_elapsed; } -/* mut_user_time_during_GC() and mut_user_time() - * - * The former function can be used to get the current mutator time - * *during* a GC, i.e. between stat_startGC and stat_endGC. This is - * used in the heap profiler for accurately time stamping the heap - * sample. - * - * ATTENTION: mut_user_time_during_GC() relies on GC_start_time being - * defined in stat_startGC() - to minimise system calls, - * GC_start_time is, however, only defined when really needed (check - * stat_startGC() for details) - */ +/* --------------------------------------------------------------------------- + Measure the current MUT time, for profiling + ------------------------------------------------------------------------ */ + double -mut_user_time_during_GC( void ) +mut_user_time_until( Ticks t ) { - return TICK_TO_DBL(GC_start_time - GC_tot_time - PROF_VAL(RP_tot_time + HC_tot_time)); + return TICK_TO_DBL(t - GC_tot_cpu - PROF_VAL(RP_tot_time)); } double mut_user_time( void ) { - Ticks user; - user = getProcessCPUTime(); - return TICK_TO_DBL(user - GC_tot_time - PROF_VAL(RP_tot_time + HC_tot_time)); + Ticks cpu; + cpu = getProcessCPUTime(); + return mut_user_time_until(cpu); } #ifdef PROFILING /* - mut_user_time_during_RP() is similar to mut_user_time_during_GC(); - it returns the MUT time during retainer profiling. + mut_user_time_during_RP() returns the MUT time during retainer profiling. The same is for mut_user_time_during_HC(); */ double mut_user_time_during_RP( void ) { - return TICK_TO_DBL(RP_start_time - GC_tot_time - RP_tot_time - HC_tot_time); + return TICK_TO_DBL(RP_start_time - GC_tot_cpu - RP_tot_time); } double mut_user_time_during_heap_census( void ) { - return TICK_TO_DBL(HC_start_time - GC_tot_time - RP_tot_time - HC_tot_time); + return TICK_TO_DBL(HC_start_time - GC_tot_cpu - RP_tot_time); } #endif /* PROFILING */ -// initStats0() has no dependencies, it can be called right at the beginning +/* --------------------------------------------------------------------------- + initStats0() has no dependencies, it can be called right at the beginning + ------------------------------------------------------------------------ */ + void initStats0(void) { - ElapsedTimeStart = 0; - - InitUserTime = 0; - InitElapsedTime = 0; - InitElapsedStamp = 0; - - MutUserTime = 0; - MutElapsedTime = 0; - MutElapsedStamp = 0; - - ExitUserTime = 0; - ExitElapsedTime = 0; + start_init_cpu = 0; + start_init_elapsed = 0; + end_init_cpu = 0; + end_init_elapsed = 0; + + start_exit_cpu = 0; + start_exit_elapsed = 0; + end_exit_cpu = 0; + end_exit_elapsed = 0; GC_tot_alloc = 0; GC_tot_copied = 0; GC_par_max_copied = 0; GC_par_avg_copied = 0; - GC_start_time = 0; - GC_tot_time = 0; - GCe_start_time = 0; - GCe_tot_time = 0; + GC_tot_cpu = 0; #ifdef PROFILING RP_start_time = 0; @@ -168,16 +150,18 @@ HCe_tot_time = 0; #endif - MaxResidency = 0; - AvgResidency = 0; - ResidencySamples = 0; - MaxSlop = 0; + max_residency = 0; + avg_residency = 0; + residency_samples = 0; + max_slop = 0; - GC_start_faults = 0; GC_end_faults = 0; } -// initStats1() can be called after setupRtsFlags() +/* --------------------------------------------------------------------------- + initStats1() can be called after setupRtsFlags() + ------------------------------------------------------------------------ */ + void initStats1 (void) { @@ -187,17 +171,22 @@ statsPrintf(" Alloc Copied Live GC GC TOT TOT Page Flts\n"); statsPrintf(" bytes bytes bytes user elap user elap\n"); } - GC_coll_times = + GC_coll_cpu = + (Ticks *)stgMallocBytes( + sizeof(Ticks)*RtsFlags.GcFlags.generations, + "initStats"); + GC_coll_elapsed = (Ticks *)stgMallocBytes( sizeof(Ticks)*RtsFlags.GcFlags.generations, "initStats"); - GC_coll_etimes = + GC_coll_max_pause = (Ticks *)stgMallocBytes( sizeof(Ticks)*RtsFlags.GcFlags.generations, "initStats"); for (i = 0; i < RtsFlags.GcFlags.generations; i++) { - GC_coll_times[i] = 0; - GC_coll_etimes[i] = 0; + GC_coll_cpu[i] = 0; + GC_coll_elapsed[i] = 0; + GC_coll_max_pause[i] = 0; } } @@ -208,26 +197,14 @@ void stat_startInit(void) { - Ticks elapsed; - - elapsed = getProcessElapsedTime(); - ElapsedTimeStart = elapsed; + getProcessTimes(&start_init_cpu, &start_init_elapsed); } void stat_endInit(void) { - Ticks user, elapsed; + getProcessTimes(&end_init_cpu, &end_init_elapsed); - getProcessTimes(&user, &elapsed); - - InitUserTime = user; - InitElapsedStamp = elapsed; - if (ElapsedTimeStart > elapsed) { - InitElapsedTime = 0; - } else { - InitElapsedTime = elapsed - ElapsedTimeStart; - } #if USE_PAPI /* We start counting events for the mutator * when garbage collection starts @@ -249,18 +226,7 @@ void stat_startExit(void) { - Ticks user, elapsed; - - getProcessTimes(&user, &elapsed); - - MutElapsedStamp = elapsed; - MutElapsedTime = elapsed - GCe_tot_time - - PROF_VAL(RPe_tot_time + HCe_tot_time) - InitElapsedStamp; - if (MutElapsedTime < 0) { MutElapsedTime = 0; } /* sometimes -0.00 */ - - MutUserTime = user - GC_tot_time - - PROF_VAL(RP_tot_time + HC_tot_time) - InitUserTime; - if (MutUserTime < 0) { MutUserTime = 0; } + getProcessTimes(&start_exit_cpu, &start_exit_elapsed); #if USE_PAPI /* We stop counting mutator events @@ -269,25 +235,13 @@ /* This flag is needed, because GC is run once more after this function */ papi_is_reporting = 0; - #endif } void stat_endExit(void) { - Ticks user, elapsed; - - getProcessTimes(&user, &elapsed); - - ExitUserTime = user - MutUserTime - GC_tot_time - PROF_VAL(RP_tot_time + HC_tot_time) - InitUserTime; - ExitElapsedTime = elapsed - MutElapsedStamp; - if (ExitUserTime < 0) { - ExitUserTime = 0; - } - if (ExitElapsedTime < 0) { - ExitElapsedTime = 0; - } + getProcessTimes(&end_exit_cpu, &end_exit_elapsed); } /* ----------------------------------------------------------------------------- @@ -296,13 +250,8 @@ static nat rub_bell = 0; -/* initialise global variables needed during GC - * - * * GC_start_time is read in mut_user_time_during_GC(), which in turn is - * needed if either PROFILING or DEBUGing is enabled - */ void -stat_startGC(void) +stat_startGC (gc_thread *gct) { nat bell = RtsFlags.GcFlags.ringBell; @@ -315,16 +264,6 @@ } } - if (RtsFlags.GcFlags.giveStats != NO_GC_STATS - || RtsFlags.ProfFlags.doHeapProfile) - // heap profiling needs GC_tot_time - { - getProcessTimes(&GC_start_time, &GCe_start_time); - if (RtsFlags.GcFlags.giveStats) { - GC_start_faults = getPageFaults(); - } - } - #if USE_PAPI if(papi_is_reporting) { /* Switch to counting GC events */ @@ -333,6 +272,40 @@ } #endif + getProcessTimes(&gct->gc_start_cpu, &gct->gc_start_elapsed); + gct->gc_start_thread_cpu = getThreadCPUTime(); + + if (RtsFlags.GcFlags.giveStats != NO_GC_STATS) + { + gct->gc_start_faults = getPageFaults(); + } +} + +void +stat_gcWorkerThreadStart (gc_thread *gct) +{ + if (RtsFlags.GcFlags.giveStats != NO_GC_STATS) + { + getProcessTimes(&gct->gc_start_cpu, &gct->gc_start_elapsed); + gct->gc_start_thread_cpu = getThreadCPUTime(); + } +} + +void +stat_gcWorkerThreadDone (gc_thread *gct) +{ + Ticks thread_cpu, elapsed, gc_cpu, gc_elapsed; + + if (RtsFlags.GcFlags.giveStats != NO_GC_STATS) + { + elapsed = getProcessElapsedTime(); + thread_cpu = getThreadCPUTime(); + + gc_cpu = thread_cpu - gct->gc_start_thread_cpu; + gc_elapsed = elapsed - gct->gc_start_elapsed; + + taskDoneGC(gct->cap->running_task, gc_cpu, gc_elapsed); + } } /* ----------------------------------------------------------------------------- @@ -340,67 +313,65 @@ -------------------------------------------------------------------------- */ void -stat_endGC (lnat alloc, lnat live, lnat copied, lnat gen, +stat_endGC (gc_thread *gct, + lnat alloc, lnat live, lnat copied, nat gen, lnat max_copied, lnat avg_copied, lnat slop) { if (RtsFlags.GcFlags.giveStats != NO_GC_STATS || RtsFlags.ProfFlags.doHeapProfile) // heap profiling needs GC_tot_time { - Ticks time, etime, gc_time, gc_etime; + Ticks cpu, elapsed, thread_gc_cpu, gc_cpu, gc_elapsed; - getProcessTimes(&time, &etime); - gc_time = time - GC_start_time; - gc_etime = etime - GCe_start_time; - - if (RtsFlags.GcFlags.giveStats == VERBOSE_GC_STATS) { + getProcessTimes(&cpu, &elapsed); + gc_elapsed = elapsed - gct->gc_start_elapsed; + + thread_gc_cpu = getThreadCPUTime() - gct->gc_start_thread_cpu; + + gc_cpu = cpu - gct->gc_start_cpu; + + taskDoneGC(gct->cap->running_task, thread_gc_cpu, gc_elapsed); + + if (RtsFlags.GcFlags.giveStats == VERBOSE_GC_STATS) { nat faults = getPageFaults(); statsPrintf("%9ld %9ld %9ld", alloc*sizeof(W_), copied*sizeof(W_), live*sizeof(W_)); - statsPrintf(" %5.2f %5.2f %7.2f %7.2f %4ld %4ld (Gen: %2ld)\n", - TICK_TO_DBL(gc_time), - TICK_TO_DBL(gc_etime), - TICK_TO_DBL(time), - TICK_TO_DBL(etime - ElapsedTimeStart), - faults - GC_start_faults, - GC_start_faults - GC_end_faults, - gen); + statsPrintf(" %5.2f %5.2f %7.2f %7.2f %4ld %4ld (Gen: %2d)\n", + TICK_TO_DBL(gc_cpu), + TICK_TO_DBL(gc_elapsed), + TICK_TO_DBL(cpu), + TICK_TO_DBL(elapsed - start_init_elapsed), + faults - gct->gc_start_faults, + gct->gc_start_faults - GC_end_faults, + gen); - GC_end_faults = faults; + GC_end_faults = faults; statsFlush(); } - GC_coll_times[gen] += gc_time; - GC_coll_etimes[gen] += gc_etime; + GC_coll_cpu[gen] += gc_cpu; + GC_coll_elapsed[gen] += gc_elapsed; + if (GC_coll_max_pause[gen] < gc_elapsed) { + GC_coll_max_pause[gen] = gc_elapsed; + } GC_tot_copied += (StgWord64) copied; GC_tot_alloc += (StgWord64) alloc; GC_par_max_copied += (StgWord64) max_copied; GC_par_avg_copied += (StgWord64) avg_copied; - GC_tot_time += gc_time; - GCe_tot_time += gc_etime; - -#if defined(THREADED_RTS) - { - Task *task; - if ((task = myTask()) != NULL) { - task->gc_time += gc_time; - task->gc_etime += gc_etime; - } - } -#endif + GC_tot_cpu += gc_cpu; if (gen == RtsFlags.GcFlags.generations-1) { /* major GC? */ - if (live > MaxResidency) { - MaxResidency = live; + if (live > max_residency) { + max_residency = live; } - ResidencySamples++; - AvgResidency += live; + residency_samples++; + avg_residency += live; } - if (slop > MaxSlop) MaxSlop = slop; + if (slop > max_slop) max_slop = slop; } if (rub_bell) { @@ -539,20 +510,28 @@ statsPrintf(" (SLOW_CALLS_" #arity ") %% of (TOTAL_CALLS) : %.1f%%\n", \ SLOW_CALLS_##arity * 100.0/TOTAL_CALLS) -extern lnat hw_alloc_blocks; - void stat_exit(int alloc) { + generation *gen; + Ticks gc_cpu = 0; + Ticks gc_elapsed = 0; + Ticks init_cpu = 0; + Ticks init_elapsed = 0; + Ticks mut_cpu = 0; + Ticks mut_elapsed = 0; + Ticks exit_cpu = 0; + Ticks exit_elapsed = 0; + if (RtsFlags.GcFlags.giveStats != NO_GC_STATS) { char temp[BIG_STRING_LEN]; - Ticks time; - Ticks etime; - nat g, total_collections = 0; + Ticks tot_cpu; + Ticks tot_elapsed; + nat i, g, total_collections = 0; - getProcessTimes( &time, &etime ); - etime -= ElapsedTimeStart; + getProcessTimes( &tot_cpu, &tot_elapsed ); + tot_elapsed -= start_init_elapsed; GC_tot_alloc += alloc; @@ -560,15 +539,32 @@ for (g = 0; g < RtsFlags.GcFlags.generations; g++) total_collections += generations[g].collections; - /* avoid divide by zero if time is measured as 0.00 seconds -- SDM */ - if (time == 0.0) time = 1; - if (etime == 0.0) etime = 1; + /* avoid divide by zero if tot_cpu is measured as 0.00 seconds -- SDM */ + if (tot_cpu == 0.0) tot_cpu = 1; + if (tot_elapsed == 0.0) tot_elapsed = 1; if (RtsFlags.GcFlags.giveStats >= VERBOSE_GC_STATS) { statsPrintf("%9ld %9.9s %9.9s", (lnat)alloc*sizeof(W_), "", ""); statsPrintf(" %5.2f %5.2f\n\n", 0.0, 0.0); } + for (i = 0; i < RtsFlags.GcFlags.generations; i++) { + gc_cpu += GC_coll_cpu[i]; + gc_elapsed += GC_coll_elapsed[i]; + } + + init_cpu = end_init_cpu - start_init_cpu; + init_elapsed = end_init_elapsed - start_init_elapsed; + + exit_cpu = end_exit_cpu - start_exit_cpu; + exit_elapsed = end_exit_elapsed - start_exit_elapsed; + + mut_elapsed = start_exit_elapsed - end_init_elapsed - gc_elapsed; + + mut_cpu = start_exit_cpu - end_init_cpu - gc_cpu + - PROF_VAL(RP_tot_time + HC_tot_time); + if (mut_cpu < 0) { mut_cpu = 0; } + if (RtsFlags.GcFlags.giveStats >= SUMMARY_GC_STATS) { showStgWord64(GC_tot_alloc*sizeof(W_), temp, rtsTrue/*commas*/); @@ -578,14 +574,14 @@ temp, rtsTrue/*commas*/); statsPrintf("%16s bytes copied during GC\n", temp); - if ( ResidencySamples > 0 ) { - showStgWord64(MaxResidency*sizeof(W_), + if ( residency_samples > 0 ) { + showStgWord64(max_residency*sizeof(W_), temp, rtsTrue/*commas*/); statsPrintf("%16s bytes maximum residency (%ld sample(s))\n", - temp, ResidencySamples); + temp, residency_samples); } - showStgWord64(MaxSlop*sizeof(W_), temp, rtsTrue/*commas*/); + showStgWord64(max_slop*sizeof(W_), temp, rtsTrue/*commas*/); statsPrintf("%16s bytes maximum slop\n", temp); statsPrintf("%16ld MB total memory in use (%ld MB lost due to fragmentation)\n\n", @@ -593,13 +589,18 @@ (peak_mblocks_allocated * BLOCKS_PER_MBLOCK * BLOCK_SIZE_W - hw_alloc_blocks * BLOCK_SIZE_W) / (1024 * 1024 / sizeof(W_))); /* Print garbage collections in each gen */ - for (g = 0; g < RtsFlags.GcFlags.generations; g++) { - statsPrintf(" Generation %d: %5d collections, %5d parallel, %5.2fs, %5.2fs elapsed\n", - g, generations[g].collections, - generations[g].par_collections, - TICK_TO_DBL(GC_coll_times[g]), - TICK_TO_DBL(GC_coll_etimes[g])); - } + statsPrintf(" Tot time (elapsed) Avg pause Max pause\n"); + for (g = 0; g < RtsFlags.GcFlags.generations; g++) { + gen = &generations[g]; + statsPrintf(" Gen %2d %5d colls, %5d par %5.2fs %5.2fs %3.4fs %3.4fs\n", + gen->no, + gen->collections, + gen->par_collections, + TICK_TO_DBL(GC_coll_cpu[g]), + TICK_TO_DBL(GC_coll_elapsed[g]), + gen->collections == 0 ? 0 : TICK_TO_DBL(GC_coll_elapsed[g] / gen->collections), + TICK_TO_DBL(GC_coll_max_pause[g])); + } #if defined(THREADED_RTS) if (RtsFlags.ParFlags.parGcEnabled) { @@ -610,8 +611,7 @@ ); } #endif - - statsPrintf("\n"); + statsPrintf("\n"); #if defined(THREADED_RTS) { @@ -636,57 +636,65 @@ { nat i; lnat sparks_created = 0; + lnat sparks_dud = 0; lnat sparks_converted = 0; - lnat sparks_pruned = 0; + lnat sparks_gcd = 0; + lnat sparks_fizzled = 0; for (i = 0; i < n_capabilities; i++) { sparks_created += capabilities[i].sparks_created; + sparks_dud += capabilities[i].sparks_dud; sparks_converted += capabilities[i].sparks_converted; - sparks_pruned += capabilities[i].sparks_pruned; + sparks_gcd += capabilities[i].sparks_gcd; + sparks_fizzled += capabilities[i].sparks_fizzled; } - statsPrintf(" SPARKS: %ld (%ld converted, %ld pruned)\n\n", - sparks_created, sparks_converted, sparks_pruned); + statsPrintf(" SPARKS: %ld (%ld converted, %ld dud, %ld GC'd, %ld fizzled)\n\n", + sparks_created + sparks_dud, sparks_converted, sparks_dud, sparks_gcd, sparks_fizzled); } #endif - statsPrintf(" INIT time %6.2fs (%6.2fs elapsed)\n", - TICK_TO_DBL(InitUserTime), TICK_TO_DBL(InitElapsedTime)); - statsPrintf(" MUT time %6.2fs (%6.2fs elapsed)\n", - TICK_TO_DBL(MutUserTime), TICK_TO_DBL(MutElapsedTime)); - statsPrintf(" GC time %6.2fs (%6.2fs elapsed)\n", - TICK_TO_DBL(GC_tot_time), TICK_TO_DBL(GCe_tot_time)); + statsPrintf(" INIT time %6.2fs (%6.2fs elapsed)\n", + TICK_TO_DBL(init_cpu), TICK_TO_DBL(init_elapsed)); + + statsPrintf(" MUT time %6.2fs (%6.2fs elapsed)\n", + TICK_TO_DBL(mut_cpu), TICK_TO_DBL(mut_elapsed)); + statsPrintf(" GC time %6.2fs (%6.2fs elapsed)\n", + TICK_TO_DBL(gc_cpu), TICK_TO_DBL(gc_elapsed)); + #ifdef PROFILING - statsPrintf(" RP time %6.2fs (%6.2fs elapsed)\n", + statsPrintf(" RP time %6.2fs (%6.2fs elapsed)\n", TICK_TO_DBL(RP_tot_time), TICK_TO_DBL(RPe_tot_time)); - statsPrintf(" PROF time %6.2fs (%6.2fs elapsed)\n", + statsPrintf(" PROF time %6.2fs (%6.2fs elapsed)\n", TICK_TO_DBL(HC_tot_time), TICK_TO_DBL(HCe_tot_time)); #endif - statsPrintf(" EXIT time %6.2fs (%6.2fs elapsed)\n", - TICK_TO_DBL(ExitUserTime), TICK_TO_DBL(ExitElapsedTime)); - statsPrintf(" Total time %6.2fs (%6.2fs elapsed)\n\n", - TICK_TO_DBL(time), TICK_TO_DBL(etime)); - statsPrintf(" %%GC time %5.1f%% (%.1f%% elapsed)\n\n", - TICK_TO_DBL(GC_tot_time)*100/TICK_TO_DBL(time), - TICK_TO_DBL(GCe_tot_time)*100/TICK_TO_DBL(etime)); + statsPrintf(" EXIT time %6.2fs (%6.2fs elapsed)\n", + TICK_TO_DBL(exit_cpu), TICK_TO_DBL(exit_elapsed)); + statsPrintf(" Total time %6.2fs (%6.2fs elapsed)\n\n", + TICK_TO_DBL(tot_cpu), TICK_TO_DBL(tot_elapsed)); +#ifndef THREADED_RTS + statsPrintf(" %%GC time %5.1f%% (%.1f%% elapsed)\n\n", + TICK_TO_DBL(gc_cpu)*100/TICK_TO_DBL(tot_cpu), + TICK_TO_DBL(gc_elapsed)*100/TICK_TO_DBL(tot_elapsed)); +#endif - if (time - GC_tot_time - PROF_VAL(RP_tot_time + HC_tot_time) == 0) + if (tot_cpu - GC_tot_cpu - PROF_VAL(RP_tot_time + HC_tot_time) == 0) showStgWord64(0, temp, rtsTrue/*commas*/); else showStgWord64( (StgWord64)((GC_tot_alloc*sizeof(W_))/ - TICK_TO_DBL(time - GC_tot_time - + TICK_TO_DBL(tot_cpu - GC_tot_cpu - PROF_VAL(RP_tot_time + HC_tot_time))), temp, rtsTrue/*commas*/); statsPrintf(" Alloc rate %s bytes per MUT second\n\n", temp); statsPrintf(" Productivity %5.1f%% of total user, %.1f%% of total elapsed\n\n", - TICK_TO_DBL(time - GC_tot_time - - PROF_VAL(RP_tot_time + HC_tot_time) - InitUserTime) * 100 - / TICK_TO_DBL(time), - TICK_TO_DBL(time - GC_tot_time - - PROF_VAL(RP_tot_time + HC_tot_time) - InitUserTime) * 100 - / TICK_TO_DBL(etime)); + TICK_TO_DBL(tot_cpu - GC_tot_cpu - + PROF_VAL(RP_tot_time + HC_tot_time) - init_cpu) * 100 + / TICK_TO_DBL(tot_cpu), + TICK_TO_DBL(tot_cpu - GC_tot_cpu - + PROF_VAL(RP_tot_time + HC_tot_time) - init_cpu) * 100 + / TICK_TO_DBL(tot_elapsed)); /* TICK_PRINT(1); @@ -706,7 +714,7 @@ statsPrintf("gc_alloc_block_sync: %"FMT_Word64"\n", gc_alloc_block_sync.spin); statsPrintf("whitehole_spin: %"FMT_Word64"\n", whitehole_spin); for (g = 0; g < RtsFlags.GcFlags.generations; g++) { - statsPrintf("gen[%d].sync_large_objects: %"FMT_Word64"\n", g, generations[g].sync_large_objects.spin); + statsPrintf("gen[%d].sync: %"FMT_Word64"\n", g, generations[g].sync.spin); } } #endif @@ -737,26 +745,32 @@ statsPrintf(fmt1, GC_tot_alloc*(StgWord64)sizeof(W_)); statsPrintf(fmt2, total_collections, - ResidencySamples == 0 ? 0 : - AvgResidency*sizeof(W_)/ResidencySamples, - MaxResidency*sizeof(W_), - ResidencySamples, + residency_samples == 0 ? 0 : + avg_residency*sizeof(W_)/residency_samples, + max_residency*sizeof(W_), + residency_samples, (unsigned long)(peak_mblocks_allocated * MBLOCK_SIZE / (1024L * 1024L)), - TICK_TO_DBL(InitUserTime), TICK_TO_DBL(InitElapsedTime), - TICK_TO_DBL(MutUserTime), TICK_TO_DBL(MutElapsedTime), - TICK_TO_DBL(GC_tot_time), TICK_TO_DBL(GCe_tot_time)); + TICK_TO_DBL(init_cpu), TICK_TO_DBL(init_elapsed), + TICK_TO_DBL(mut_cpu), TICK_TO_DBL(mut_elapsed), + TICK_TO_DBL(gc_cpu), TICK_TO_DBL(gc_elapsed)); } statsFlush(); statsClose(); } - if (GC_coll_times) - stgFree(GC_coll_times); - GC_coll_times = NULL; - if (GC_coll_etimes) - stgFree(GC_coll_etimes); - GC_coll_etimes = NULL; + if (GC_coll_cpu) { + stgFree(GC_coll_cpu); + GC_coll_cpu = NULL; + } + if (GC_coll_elapsed) { + stgFree(GC_coll_elapsed); + GC_coll_elapsed = NULL; + } + if (GC_coll_max_pause) { + stgFree(GC_coll_max_pause); + GC_coll_max_pause = NULL; + } } /* ----------------------------------------------------------------------------- @@ -767,9 +781,10 @@ void statDescribeGens(void) { - nat g, mut, lge; - lnat live, slop; + nat g, mut, lge, i; + lnat gen_slop; lnat tot_live, tot_slop; + lnat gen_live, gen_blocks; bdescr *bd; generation *gen; @@ -781,25 +796,40 @@ tot_live = 0; tot_slop = 0; - for (g = 0; g < RtsFlags.GcFlags.generations; g++) { - mut = 0; - for (bd = generations[g].mut_list; bd != NULL; bd = bd->link) { - mut += (bd->free - bd->start) * sizeof(W_); - } + for (g = 0; g < RtsFlags.GcFlags.generations; g++) { gen = &generations[g]; - debugBelch("%5d %7d %9d", g, gen->max_blocks, mut); - for (bd = gen->large_objects, lge = 0; bd; bd = bd->link) { lge++; } - live = gen->n_words + countOccupied(gen->large_objects); - slop = (gen->n_blocks + gen->n_large_blocks) * BLOCK_SIZE_W - live; - debugBelch("%8d %8d %8ld %8ld\n", gen->n_blocks, lge, - live*sizeof(W_), slop*sizeof(W_)); - tot_live += live; - tot_slop += slop; + + gen_live = genLiveWords(gen); + gen_blocks = genLiveBlocks(gen); + + mut = 0; + for (i = 0; i < n_capabilities; i++) { + mut += countOccupied(capabilities[i].mut_lists[g]); + + // Add the pinned object block. + bd = capabilities[i].pinned_object_block; + if (bd != NULL) { + gen_live += bd->free - bd->start; + gen_blocks += bd->blocks; + } + + gen_live += gcThreadLiveWords(i,g); + gen_blocks += gcThreadLiveBlocks(i,g); + } + + debugBelch("%5d %7ld %9d", g, (lnat)gen->max_blocks, mut); + + gen_slop = gen_blocks * BLOCK_SIZE_W - gen_live; + + debugBelch("%8ld %8d %8ld %8ld\n", gen_blocks, lge, + gen_live*sizeof(W_), gen_slop*sizeof(W_)); + tot_live += gen_live; + tot_slop += gen_slop; } debugBelch("----------------------------------------------------------\n"); debugBelch("%41s%8ld %8ld\n","",tot_live*sizeof(W_),tot_slop*sizeof(W_)); diff -Nru ghc-7.0.3/rts/Stats.h ghc-7.2.1/rts/Stats.h --- ghc-7.0.3/rts/Stats.h 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/rts/Stats.h 2011-08-07 17:10:05.000000000 +0000 @@ -13,13 +13,18 @@ #include "BeginPrivate.h" +struct gc_thread_; + void stat_startInit(void); void stat_endInit(void); -void stat_startGC(void); -void stat_endGC (lnat alloc, lnat live, - lnat copied, lnat gen, - lnat max_copied, lnat avg_copied, lnat slop); +void stat_startGC(struct gc_thread_ *gct); +void stat_endGC (struct gc_thread_ *gct, lnat alloc, lnat live, + lnat copied, nat gen, + lnat max_copied, lnat avg_copied, lnat slop); + +void stat_gcWorkerThreadStart (struct gc_thread_ *gct); +void stat_gcWorkerThreadDone (struct gc_thread_ *gct); #ifdef PROFILING void stat_startRP(void); @@ -45,6 +50,7 @@ void initStats1(void); double mut_user_time_during_GC(void); +double mut_user_time_until(Ticks t); double mut_user_time(void); #ifdef PROFILING diff -Nru ghc-7.0.3/rts/StgCRun.c ghc-7.2.1/rts/StgCRun.c --- ghc-7.0.3/rts/StgCRun.c 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/rts/StgCRun.c 2011-08-07 17:10:05.000000000 +0000 @@ -128,18 +128,29 @@ #define STG_GLOBAL ".global " #endif -StgRegTable * -StgRun(StgFunPtr f, StgRegTable *basereg) { +static void GNUC3_ATTRIBUTE(used) +StgRunIsImplementedInAssembler(void) +{ + __asm__ volatile ( + STG_GLOBAL STG_RUN "\n" + STG_RUN ":\n\t" - unsigned char space[ RESERVED_C_STACK_BYTES + 4*sizeof(void *) ]; - StgRegTable * r; + /* + * move %esp down to reserve an area for temporary storage + * during the execution of STG code. + * + * The stack pointer has to be aligned to a multiple of 16 + * bytes from here - this is a requirement of the C ABI, so + * that C code can assign SSE2 registers directly to/from + * stack locations. + */ + "subl %0, %%esp\n\t" - __asm__ volatile ( /* * save callee-saves registers on behalf of the STG code. */ - "movl %%esp, %%eax\n\t" - "addl %4, %%eax\n\t" + "movl %%esp, %%eax\n\t" + "addl %0-16, %%eax\n\t" "movl %%ebx,0(%%eax)\n\t" "movl %%esi,4(%%eax)\n\t" "movl %%edi,8(%%eax)\n\t" @@ -147,25 +158,17 @@ /* * Set BaseReg */ - "movl %3,%%ebx\n\t" + "movl 24(%%eax),%%ebx\n\t" /* * grab the function argument from the stack */ - "movl %2,%%eax\n\t" - - /* - * Darwin note: - * The stack pointer has to be aligned to a multiple of 16 bytes at - * this point. This works out correctly with gcc 4.0.1, but it might - * break at any time in the future. TODO: Make this future-proof. - */ - - /* + "movl 20(%%eax),%%eax\n\t" + /* * jump to it */ "jmp *%%eax\n\t" - STG_GLOBAL STG_RETURN "\n" + STG_GLOBAL STG_RETURN "\n" STG_RETURN ":\n\t" "movl %%esi, %%eax\n\t" /* Return value in R1 */ @@ -174,19 +177,32 @@ * restore callee-saves registers. (Don't stomp on %%eax!) */ "movl %%esp, %%edx\n\t" - "addl %4, %%edx\n\t" + "addl %0-16, %%edx\n\t" "movl 0(%%edx),%%ebx\n\t" /* restore the registers saved above */ "movl 4(%%edx),%%esi\n\t" "movl 8(%%edx),%%edi\n\t" "movl 12(%%edx),%%ebp\n\t" - : "=&a" (r), "=m" (space) - : "m" (f), "m" (basereg), "i" (RESERVED_C_STACK_BYTES) - : "edx" /* stomps on %edx */ + "addl %0, %%esp\n\t" + "ret" + + : : "i" (RESERVED_C_STACK_BYTES + 16 + 12) + // + 16 to make room for the 4 registers we have to save + // + 12 because we need to align %esp to a 16-byte boundary (#5250) ); +} - return r; +#if defined(mingw32_HOST_OS) +// On windows the stack has to be allocated 4k at a time, otherwise +// we get a segfault. The C compiler knows how to do this (it calls +// _alloca()), so we make sure that we can allocate as much stack as +// we need: +StgWord8 *win32AllocStack(void) +{ + StgWord8 stack[RESERVED_C_STACK_BYTES + 16 + 12]; + return stack; } +#endif #endif diff -Nru ghc-7.0.3/rts/StgMiscClosures.cmm ghc-7.2.1/rts/StgMiscClosures.cmm --- ghc-7.0.3/rts/StgMiscClosures.cmm 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/rts/StgMiscClosures.cmm 2011-08-07 17:10:05.000000000 +0000 @@ -19,6 +19,23 @@ import LeaveCriticalSection; /* ---------------------------------------------------------------------------- + Stack underflow + ------------------------------------------------------------------------- */ + +INFO_TABLE_RET (stg_stack_underflow_frame, UNDERFLOW_FRAME, P_ unused) +{ + W_ new_tso; + W_ ret_off; + + SAVE_THREAD_STATE(); + ("ptr" ret_off) = foreign "C" threadStackUnderflow(MyCapability(), + CurrentTSO); + LOAD_THREAD_STATE(); + + jump %ENTRY_CODE(Sp(ret_off)); +} + +/* ---------------------------------------------------------------------------- Support for the bytecode interpreter. ------------------------------------------------------------------------- */ @@ -353,6 +370,9 @@ INFO_TABLE(stg_TSO, 0,0,TSO, "TSO", "TSO") { foreign "C" barf("TSO object entered!") never returns; } +INFO_TABLE(stg_STACK, 0,0, STACK, "STACK", "STACK") +{ foreign "C" barf("STACK object entered!") never returns; } + /* ---------------------------------------------------------------------------- Weak pointers diff -Nru ghc-7.0.3/rts/StgRun.h ghc-7.2.1/rts/StgRun.h --- ghc-7.0.3/rts/StgRun.h 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/rts/StgRun.h 2011-08-07 17:10:05.000000000 +0000 @@ -11,4 +11,8 @@ RTS_PRIVATE StgRegTable * StgRun (StgFunPtr f, StgRegTable *basereg); +#if defined(mingw32_HOST_OS) +StgWord8 *win32AllocStack(void); +#endif + #endif /* STGRUN_H */ diff -Nru ghc-7.0.3/rts/StgStartup.cmm ghc-7.2.1/rts/StgStartup.cmm --- ghc-7.0.3/rts/StgStartup.cmm 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/rts/StgStartup.cmm 2011-08-07 17:10:05.000000000 +0000 @@ -151,22 +151,6 @@ } /* ----------------------------------------------------------------------------- - Non-strict IO application. - - This stack frame works like stg_forceIO_info except that it - doesn't evaluate the return value. We need the layer because the - return convention for an IO action differs depending on whether R1 - is a register or not. - ------------------------------------------------------------------------- */ - -INFO_TABLE_RET( stg_noforceIO, RET_SMALL ) - -{ - Sp_adj(1); - jump %ENTRY_CODE(Sp(0)); -} - -/* ----------------------------------------------------------------------------- Special STG entry points for module registration. -------------------------------------------------------------------------- */ diff -Nru ghc-7.0.3/rts/STM.c ghc-7.2.1/rts/STM.c --- ghc-7.0.3/rts/STM.c 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/rts/STM.c 2011-08-07 17:10:05.000000000 +0000 @@ -879,17 +879,12 @@ /************************************************************************/ -void stmPreGCHook() { - nat i; - +void stmPreGCHook (Capability *cap) { lock_stm(NO_TREC); TRACE("stmPreGCHook"); - for (i = 0; i < n_capabilities; i ++) { - Capability *cap = &capabilities[i]; - cap -> free_tvar_watch_queues = END_STM_WATCH_QUEUE; - cap -> free_trec_chunks = END_STM_CHUNK_LIST; - cap -> free_trec_headers = NO_TREC; - } + cap->free_tvar_watch_queues = END_STM_WATCH_QUEUE; + cap->free_trec_chunks = END_STM_CHUNK_LIST; + cap->free_trec_headers = NO_TREC; unlock_stm(NO_TREC); } @@ -1094,7 +1089,7 @@ FOR_EACH_ENTRY(last_execution, e, { StgTVar *s = e -> tvar; StgTVarWatchQueue *q = s -> first_watch_queue_entry; - StgBool found = FALSE; + DEBUG_ONLY( StgBool found = FALSE ); TRACE(" looking for trec on tvar=%p", s); for (q = s -> first_watch_queue_entry; q != END_STM_WATCH_QUEUE; @@ -1115,7 +1110,7 @@ } TRACE(" found it in watch queue entry %p", q); free_stg_tvar_watch_queue(cap, q); - found = TRUE; + DEBUG_ONLY( found = TRUE ); break; } } diff -Nru ghc-7.0.3/rts/STM.h ghc-7.2.1/rts/STM.h --- ghc-7.0.3/rts/STM.h 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/rts/STM.h 2011-08-07 17:10:05.000000000 +0000 @@ -48,7 +48,7 @@ -------------- */ -void stmPreGCHook(void); +void stmPreGCHook(Capability *cap); /*---------------------------------------------------------------------- diff -Nru ghc-7.0.3/rts/Task.c ghc-7.2.1/rts/Task.c --- ghc-7.0.3/rts/Task.c 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/rts/Task.c 2011-08-07 17:10:05.000000000 +0000 @@ -318,32 +318,37 @@ taskTimeStamp (Task *task USED_IF_THREADS) { #if defined(THREADED_RTS) - Ticks currentElapsedTime, currentUserTime, elapsedGCTime; + Ticks currentElapsedTime, currentUserTime; currentUserTime = getThreadCPUTime(); currentElapsedTime = getProcessElapsedTime(); - // XXX this is wrong; we want elapsed GC time since the - // Task started. - elapsedGCTime = stat_getElapsedGCTime(); - - task->mut_time = + task->mut_time = currentUserTime - task->muttimestart - task->gc_time; task->mut_etime = - currentElapsedTime - task->elapsedtimestart - elapsedGCTime; + currentElapsedTime - task->elapsedtimestart - task->gc_etime; + if (task->gc_time < 0) { task->gc_time = 0; } + if (task->gc_etime < 0) { task->gc_etime = 0; } if (task->mut_time < 0) { task->mut_time = 0; } if (task->mut_etime < 0) { task->mut_etime = 0; } #endif } +void +taskDoneGC (Task *task, Ticks cpu_time, Ticks elapsed_time) +{ + task->gc_time += cpu_time; + task->gc_etime += elapsed_time; +} + #if defined(THREADED_RTS) void workerTaskStop (Task *task) { - OSThreadId id; - id = osThreadId(); + DEBUG_ONLY( OSThreadId id ); + DEBUG_ONLY( id = osThreadId() ); ASSERT(task->id == id); ASSERT(myTask() == task); @@ -354,6 +359,19 @@ #endif +#ifdef DEBUG + +static void *taskId(Task *task) +{ +#ifdef THREADED_RTS + return (void *)task->id; +#else + return (void *)task; +#endif +} + +#endif + #if defined(THREADED_RTS) static void OSThreadProcAttr @@ -415,19 +433,19 @@ RELEASE_LOCK(&task->lock); } +void +interruptWorkerTask (Task *task) +{ + ASSERT(osThreadId() != task->id); // seppuku not allowed + ASSERT(task->incall->suspended_tso); // use this only for FFI calls + interruptOSThread(task->id); + debugTrace(DEBUG_sched, "interrupted worker task %p", taskId(task)); +} + #endif /* THREADED_RTS */ #ifdef DEBUG -static void *taskId(Task *task) -{ -#ifdef THREADED_RTS - return (void *)task->id; -#else - return (void *)task; -#endif -} - void printAllTasks(void); void diff -Nru ghc-7.0.3/rts/Task.h ghc-7.2.1/rts/Task.h --- ghc-7.0.3/rts/Task.h 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/rts/Task.h 2011-08-07 17:10:05.000000000 +0000 @@ -207,6 +207,9 @@ // void taskTimeStamp (Task *task); +// The current Task has finished a GC, record the amount of time spent. +void taskDoneGC (Task *task, Ticks cpu_time, Ticks elapsed_time); + // Put the task back on the free list, mark it stopped. Used by // forkProcess(). // @@ -225,6 +228,11 @@ // void startWorkerTask (Capability *cap); +// Interrupts a worker task that is performing an FFI call. The thread +// should not be destroyed. +// +void interruptWorkerTask (Task *task); + #endif /* THREADED_RTS */ // ----------------------------------------------------------------------------- diff -Nru ghc-7.0.3/rts/ThreadPaused.c ghc-7.2.1/rts/ThreadPaused.c --- ghc-7.0.3/rts/ThreadPaused.c 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/rts/ThreadPaused.c 2011-08-07 17:10:05.000000000 +0000 @@ -44,13 +44,13 @@ // contains two values: the size of the gap, and the distance // to the next gap (or the stack top). - frame = tso->sp; + frame = tso->stackobj->sp; ASSERT(frame < bottom); prev_was_update_frame = rtsFalse; current_gap_size = 0; - gap = (struct stack_gap *) (tso->sp - sizeofW(StgUpdateFrame)); + gap = (struct stack_gap *) (frame - sizeofW(StgUpdateFrame)); while (frame <= bottom) { @@ -150,7 +150,7 @@ next_gap_start = (StgWord8*)gap + sizeof(StgUpdateFrame); sp = next_gap_start; - while ((StgPtr)gap > tso->sp) { + while ((StgPtr)gap > tso->stackobj->sp) { // we're working in *bytes* now... gap_start = next_gap_start; @@ -164,7 +164,7 @@ memmove(sp, next_gap_start, chunk_size); } - tso->sp = (StgPtr)sp; + tso->stackobj->sp = (StgPtr)sp; } } @@ -201,27 +201,27 @@ // blackholing, or eager blackholing consistently. See Note // [upd-black-hole] in sm/Scav.c. - stack_end = &tso->stack[tso->stack_size]; + stack_end = tso->stackobj->stack + tso->stackobj->stack_size; - frame = (StgClosure *)tso->sp; + frame = (StgClosure *)tso->stackobj->sp; - while (1) { - // If we've already marked this frame, then stop here. - if (frame->header.info == (StgInfoTable *)&stg_marked_upd_frame_info) { - if (prev_was_update_frame) { - words_to_squeeze += sizeofW(StgUpdateFrame); - weight += weight_pending; - weight_pending = 0; - } - goto end; - } - - info = get_ret_itbl(frame); + while ((P_)frame < stack_end) { + info = get_ret_itbl(frame); switch (info->i.type) { - + case UPDATE_FRAME: + // If we've already marked this frame, then stop here. + if (frame->header.info == (StgInfoTable *)&stg_marked_upd_frame_info) { + if (prev_was_update_frame) { + words_to_squeeze += sizeofW(StgUpdateFrame); + weight += weight_pending; + weight_pending = 0; + } + goto end; + } + SET_INFO(frame, (StgInfoTable *)&stg_marked_upd_frame_info); bh = ((StgUpdateFrame *)frame)->updatee; @@ -230,12 +230,44 @@ #ifdef THREADED_RTS retry: #endif - if (bh_info == &stg_BLACKHOLE_info || - bh_info == &stg_WHITEHOLE_info) + // If the info table is a WHITEHOLE or a BLACKHOLE, then + // another thread has claimed it (via the SET_INFO() + // below), or is in the process of doing so. In that case + // we want to suspend the work that the current thread has + // done on this thunk and wait until the other thread has + // finished. + // + // If eager blackholing is taking place, it could be the + // case that the blackhole points to the current + // TSO. e.g.: + // + // this thread other thread + // -------------------------------------------------------- + // c->indirectee = other_tso; + // c->header.info = EAGER_BH + // threadPaused(): + // c->header.info = WHITEHOLE + // c->indirectee = other_tso + // c->indirectee = this_tso; + // c->header.info = EAGER_BH + // c->header.info = BLACKHOLE + // threadPaused() + // *** c->header.info is now BLACKHOLE, + // c->indirectee points to this_tso + // + // So in this case do *not* suspend the work of the + // current thread, because the current thread will become + // deadlocked on itself. See #5226 for an instance of + // this bug. + // + if ((bh_info == &stg_WHITEHOLE_info || + bh_info == &stg_BLACKHOLE_info) + && + ((StgInd*)bh)->indirectee != (StgClosure*)tso) { debugTrace(DEBUG_squeeze, "suspending duplicate work: %ld words of stack", - (long)((StgPtr)frame - tso->sp)); + (long)((StgPtr)frame - tso->stackobj->sp)); // If this closure is already an indirection, then // suspend the computation up to this point. @@ -245,25 +277,22 @@ // Now drop the update frame, and arrange to return // the value to the frame underneath: - tso->sp = (StgPtr)frame + sizeofW(StgUpdateFrame) - 2; - tso->sp[1] = (StgWord)bh; + tso->stackobj->sp = (StgPtr)frame + sizeofW(StgUpdateFrame) - 2; + tso->stackobj->sp[1] = (StgWord)bh; ASSERT(bh->header.info != &stg_TSO_info); - tso->sp[0] = (W_)&stg_enter_info; + tso->stackobj->sp[0] = (W_)&stg_enter_info; // And continue with threadPaused; there might be // yet more computation to suspend. - frame = (StgClosure *)(tso->sp + 2); + frame = (StgClosure *)(tso->stackobj->sp + 2); prev_was_update_frame = rtsFalse; continue; } + // zero out the slop so that the sanity checker can tell // where the next closure is. - DEBUG_FILL_SLOP(bh); - - // @LDV profiling - // We pretend that bh is now dead. - LDV_RECORD_DEAD_FILL_SLOP_DYNAMIC((StgClosure *)bh); + OVERWRITING_CLOSURE(bh); // an EAGER_BLACKHOLE or CAF_BLACKHOLE gets turned into a // BLACKHOLE here. @@ -301,7 +330,8 @@ prev_was_update_frame = rtsTrue; break; - case STOP_FRAME: + case UNDERFLOW_FRAME: + case STOP_FRAME: goto end; // normal stack frames; do nothing except advance the pointer diff -Nru ghc-7.0.3/rts/Threads.c ghc-7.2.1/rts/Threads.c --- ghc-7.0.3/rts/Threads.c 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/rts/Threads.c 2011-08-07 17:10:05.000000000 +0000 @@ -18,8 +18,14 @@ #include "ThreadLabels.h" #include "Updates.h" #include "Messages.h" +#include "RaiseAsync.h" +#include "Prelude.h" +#include "Printer.h" +#include "sm/Sanity.h" #include "sm/Storage.h" +#include + /* Next thread ID to allocate. * LOCK: sched_mutex */ @@ -54,57 +60,67 @@ createThread(Capability *cap, nat size) { StgTSO *tso; + StgStack *stack; nat stack_size; /* sched_mutex is *not* required */ - /* First check whether we should create a thread at all */ - - // ToDo: check whether size = stack_size - TSO_STRUCT_SIZEW - /* catch ridiculously small stack sizes */ - if (size < MIN_STACK_WORDS + TSO_STRUCT_SIZEW) { - size = MIN_STACK_WORDS + TSO_STRUCT_SIZEW; + if (size < MIN_STACK_WORDS + sizeofW(StgStack)) { + size = MIN_STACK_WORDS + sizeofW(StgStack); } - size = round_to_mblocks(size); - tso = (StgTSO *)allocate(cap, size); - - stack_size = size - TSO_STRUCT_SIZEW; - TICK_ALLOC_TSO(stack_size, 0); + /* The size argument we are given includes all the per-thread + * overheads: + * + * - The TSO structure + * - The STACK header + * + * This is so that we can use a nice round power of 2 for the + * default stack size (e.g. 1k), and if we're allocating lots of + * threads back-to-back they'll fit nicely in a block. It's a bit + * of a benchmark hack, but it doesn't do any harm. + */ + stack_size = round_to_mblocks(size - sizeofW(StgTSO)); + stack = (StgStack *)allocate(cap, stack_size); + TICK_ALLOC_STACK(stack_size); + SET_HDR(stack, &stg_STACK_info, CCS_SYSTEM); + stack->stack_size = stack_size - sizeofW(StgStack); + stack->sp = stack->stack + stack->stack_size; + stack->dirty = 1; + tso = (StgTSO *)allocate(cap, sizeofW(StgTSO)); + TICK_ALLOC_TSO(); SET_HDR(tso, &stg_TSO_info, CCS_SYSTEM); // Always start with the compiled code evaluator tso->what_next = ThreadRunGHC; - tso->why_blocked = NotBlocked; tso->block_info.closure = (StgClosure *)END_TSO_QUEUE; tso->blocked_exceptions = END_BLOCKED_EXCEPTIONS_QUEUE; tso->bq = (StgBlockingQueue *)END_TSO_QUEUE; tso->flags = 0; tso->dirty = 1; - + tso->_link = END_TSO_QUEUE; + tso->saved_errno = 0; tso->bound = NULL; tso->cap = cap; - tso->stack_size = stack_size; - tso->max_stack_size = round_to_mblocks(RtsFlags.GcFlags.maxStkSize) - - TSO_STRUCT_SIZEW; - tso->sp = (P_)&(tso->stack) + stack_size; + tso->stackobj = stack; + tso->tot_stack_size = stack->stack_size; tso->trec = NO_TREC; - + #ifdef PROFILING tso->prof.CCCS = CCS_MAIN; #endif - /* put a stop frame on the stack */ - tso->sp -= sizeofW(StgStopFrame); - SET_HDR((StgClosure*)tso->sp,(StgInfoTable *)&stg_stop_thread_info,CCS_SYSTEM); - tso->_link = END_TSO_QUEUE; - + // put a stop frame on the stack + stack->sp -= sizeofW(StgStopFrame); + SET_HDR((StgClosure*)stack->sp, + (StgInfoTable *)&stg_stop_thread_info,CCS_SYSTEM); + /* Link the new thread on the global thread list. */ ACQUIRE_LOCK(&sched_mutex); @@ -220,12 +236,6 @@ void tryWakeupThread (Capability *cap, StgTSO *tso) { - tryWakeupThread_(cap, deRefTSO(tso)); -} - -void -tryWakeupThread_ (Capability *cap, StgTSO *tso) -{ traceEventThreadWakeup (cap, tso, tso->cap->no); #ifdef THREADED_RTS @@ -267,8 +277,8 @@ } // remove the block frame from the stack - ASSERT(tso->sp[0] == (StgWord)&stg_block_throwto_info); - tso->sp += 3; + ASSERT(tso->stackobj->sp[0] == (StgWord)&stg_block_throwto_info); + tso->stackobj->sp += 3; goto unblock; } @@ -287,6 +297,19 @@ // we'll block again. tso->why_blocked = NotBlocked; appendToRunQueue(cap,tso); + + // We used to set the context switch flag here, which would + // trigger a context switch a short time in the future (at the end + // of the current nursery block). The idea is that we have just + // woken up a thread, so we may need to load-balance and migrate + // threads to other CPUs. On the other hand, setting the context + // switch flag here unfairly penalises the current thread by + // yielding its time slice too early. + // + // The synthetic benchmark nofib/smp/chan can be used to show the + // difference quite clearly. + + // cap->context_switch = 1; } /* ---------------------------------------------------------------------------- @@ -403,7 +426,7 @@ i = v->header.info; if (i == &stg_TSO_info) { - owner = deRefTSO((StgTSO*)v); + owner = (StgTSO*)v; if (owner != tso) { checkBlockingQueues(cap, tso); } @@ -416,7 +439,7 @@ return; } - owner = deRefTSO(((StgBlockingQueue*)v)->owner); + owner = ((StgBlockingQueue*)v)->owner; if (owner != tso) { checkBlockingQueues(cap, tso); @@ -453,6 +476,222 @@ return rtsFalse; } +/* ----------------------------------------------------------------------------- + Stack overflow + + If the thread has reached its maximum stack size, then raise the + StackOverflow exception in the offending thread. Otherwise + relocate the TSO into a larger chunk of memory and adjust its stack + size appropriately. + -------------------------------------------------------------------------- */ + +void +threadStackOverflow (Capability *cap, StgTSO *tso) +{ + StgStack *new_stack, *old_stack; + StgUnderflowFrame *frame; + lnat chunk_size; + + IF_DEBUG(sanity,checkTSO(tso)); + + if (tso->tot_stack_size >= RtsFlags.GcFlags.maxStkSize + && !(tso->flags & TSO_BLOCKEX)) { + // NB. never raise a StackOverflow exception if the thread is + // inside Control.Exceptino.block. It is impractical to protect + // against stack overflow exceptions, since virtually anything + // can raise one (even 'catch'), so this is the only sensible + // thing to do here. See bug #767. + // + + if (tso->flags & TSO_SQUEEZED) { + return; + } + // #3677: In a stack overflow situation, stack squeezing may + // reduce the stack size, but we don't know whether it has been + // reduced enough for the stack check to succeed if we try + // again. Fortunately stack squeezing is idempotent, so all we + // need to do is record whether *any* squeezing happened. If we + // are at the stack's absolute -K limit, and stack squeezing + // happened, then we try running the thread again. The + // TSO_SQUEEZED flag is set by threadPaused() to tell us whether + // squeezing happened or not. + + debugTrace(DEBUG_gc, + "threadStackOverflow of TSO %ld (%p): stack too large (now %ld; max is %ld)", + (long)tso->id, tso, (long)tso->stackobj->stack_size, + RtsFlags.GcFlags.maxStkSize); + IF_DEBUG(gc, + /* If we're debugging, just print out the top of the stack */ + printStackChunk(tso->stackobj->sp, + stg_min(tso->stackobj->stack + tso->stackobj->stack_size, + tso->stackobj->sp+64))); + + // Send this thread the StackOverflow exception + throwToSingleThreaded(cap, tso, (StgClosure *)stackOverflow_closure); + } + + + // We also want to avoid enlarging the stack if squeezing has + // already released some of it. However, we don't want to get into + // a pathalogical situation where a thread has a nearly full stack + // (near its current limit, but not near the absolute -K limit), + // keeps allocating a little bit, squeezing removes a little bit, + // and then it runs again. So to avoid this, if we squeezed *and* + // there is still less than BLOCK_SIZE_W words free, then we enlarge + // the stack anyway. + if ((tso->flags & TSO_SQUEEZED) && + ((W_)(tso->stackobj->sp - tso->stackobj->stack) >= BLOCK_SIZE_W)) { + return; + } + + old_stack = tso->stackobj; + + // If we used less than half of the previous stack chunk, then we + // must have failed a stack check for a large amount of stack. In + // this case we allocate a double-sized chunk to try to + // accommodate the large stack request. If that also fails, the + // next chunk will be 4x normal size, and so on. + // + // It would be better to have the mutator tell us how much stack + // was needed, as we do with heap allocations, but this works for + // now. + // + if (old_stack->sp > old_stack->stack + old_stack->stack_size / 2) + { + chunk_size = 2 * (old_stack->stack_size + sizeofW(StgStack)); + } + else + { + chunk_size = RtsFlags.GcFlags.stkChunkSize; + } + + debugTraceCap(DEBUG_sched, cap, + "allocating new stack chunk of size %d bytes", + chunk_size * sizeof(W_)); + + new_stack = (StgStack*) allocate(cap, chunk_size); + SET_HDR(new_stack, &stg_STACK_info, CCS_SYSTEM); + TICK_ALLOC_STACK(chunk_size); + + new_stack->dirty = 0; // begin clean, we'll mark it dirty below + new_stack->stack_size = chunk_size - sizeofW(StgStack); + new_stack->sp = new_stack->stack + new_stack->stack_size; + + tso->tot_stack_size += new_stack->stack_size; + + new_stack->sp -= sizeofW(StgUnderflowFrame); + frame = (StgUnderflowFrame*)new_stack->sp; + frame->info = &stg_stack_underflow_frame_info; + frame->next_chunk = old_stack; + + { + StgWord *sp; + nat chunk_words, size; + + // find the boundary of the chunk of old stack we're going to + // copy to the new stack. We skip over stack frames until we + // reach the smaller of + // + // * the chunk buffer size (+RTS -kb) + // * the end of the old stack + // + for (sp = old_stack->sp; + sp < stg_min(old_stack->sp + RtsFlags.GcFlags.stkChunkBufferSize, + old_stack->stack + old_stack->stack_size); ) + { + size = stack_frame_sizeW((StgClosure*)sp); + + // if including this frame would exceed the size of the + // new stack (taking into account the underflow frame), + // then stop at the previous frame. + if (sp + size > old_stack->stack + (new_stack->stack_size - + sizeofW(StgUnderflowFrame))) { + break; + } + sp += size; + } + + // copy the stack chunk between tso->sp and sp to + // new_tso->sp + (tso->sp - sp) + chunk_words = sp - old_stack->sp; + + memcpy(/* dest */ new_stack->sp - chunk_words, + /* source */ old_stack->sp, + /* size */ chunk_words * sizeof(W_)); + + old_stack->sp += chunk_words; + new_stack->sp -= chunk_words; + } + + // if the old stack chunk is now empty, discard it. With the + // default settings, -ki1k -kb1k, this means the first stack chunk + // will be discarded after the first overflow, being replaced by a + // non-moving 32k chunk. + if (old_stack->sp == old_stack->stack + old_stack->stack_size) { + frame->next_chunk = (StgStack*)END_TSO_QUEUE; // dummy + } + + tso->stackobj = new_stack; + + // we're about to run it, better mark it dirty + dirty_STACK(cap, new_stack); + + IF_DEBUG(sanity,checkTSO(tso)); + // IF_DEBUG(scheduler,printTSO(new_tso)); +} + + +/* --------------------------------------------------------------------------- + Stack underflow - called from the stg_stack_underflow_info frame + ------------------------------------------------------------------------ */ + +nat // returns offset to the return address +threadStackUnderflow (Capability *cap, StgTSO *tso) +{ + StgStack *new_stack, *old_stack; + StgUnderflowFrame *frame; + nat retvals; + + debugTraceCap(DEBUG_sched, cap, "stack underflow"); + + old_stack = tso->stackobj; + + frame = (StgUnderflowFrame*)(old_stack->stack + old_stack->stack_size + - sizeofW(StgUnderflowFrame)); + ASSERT(frame->info == &stg_stack_underflow_frame_info); + + new_stack = (StgStack*)frame->next_chunk; + tso->stackobj = new_stack; + + retvals = (P_)frame - old_stack->sp; + if (retvals != 0) + { + // we have some return values to copy to the old stack + if ((nat)(new_stack->sp - new_stack->stack) < retvals) + { + barf("threadStackUnderflow: not enough space for return values"); + } + + new_stack->sp -= retvals; + + memcpy(/* dest */ new_stack->sp, + /* src */ old_stack->sp, + /* size */ retvals * sizeof(W_)); + } + + // empty the old stack. The GC may still visit this object + // because it is on the mutable list. + old_stack->sp = old_stack->stack + old_stack->stack_size; + + // restore the stack parameters, and update tot_stack_size + tso->tot_stack_size -= old_stack->stack_size; + + // we're about to run it, better mark it dirty + dirty_STACK(cap, new_stack); + + return retvals; +} + /* ---------------------------------------------------------------------------- * Debugging: why is a thread blocked * ------------------------------------------------------------------------- */ @@ -495,8 +734,8 @@ case BlockedOnCCall: debugBelch("is blocked on an external call"); break; - case BlockedOnCCall_NoUnblockExc: - debugBelch("is blocked on an external call (exceptions were already blocked)"); + case BlockedOnCCall_Interruptible: + debugBelch("is blocked on an external call (but may be interrupted)"); break; case BlockedOnSTM: debugBelch("is blocked on an STM operation"); @@ -516,10 +755,7 @@ void *label = lookupThreadLabel(t->id); if (label) debugBelch("[\"%s\"] ",(char *)label); } - if (t->what_next == ThreadRelocated) { - debugBelch("has been relocated...\n"); - } else { - switch (t->what_next) { + switch (t->what_next) { case ThreadKilled: debugBelch("has been killed"); break; @@ -531,11 +767,8 @@ } if (t->dirty) { debugBelch(" (TSO_DIRTY)"); - } else if (t->flags & TSO_LINK_DIRTY) { - debugBelch(" (TSO_LINK_DIRTY)"); } debugBelch("\n"); - } } void @@ -561,11 +794,7 @@ if (t->why_blocked != NotBlocked) { printThreadStatus(t); } - if (t->what_next == ThreadRelocated) { - next = t->_link; - } else { - next = t->global_link; - } + next = t->global_link; } } } diff -Nru ghc-7.0.3/rts/Threads.h ghc-7.2.1/rts/Threads.h --- ghc-7.0.3/rts/Threads.h 2011-03-26 18:10:06.000000000 +0000 +++ ghc-7.2.1/rts/Threads.h 2011-08-07 17:10:05.000000000 +0000 @@ -21,9 +21,6 @@ void tryWakeupThread (Capability *cap, StgTSO *tso); void migrateThread (Capability *from, StgTSO *tso, Capability *to); -// like tryWakeupThread(), but assumes the TSO is not ThreadRelocated -void tryWakeupThread_ (Capability *cap, StgTSO *tso); - // Wakes up a thread on a Capability (probably a different Capability // from the one held by the current Task). // @@ -41,6 +38,10 @@ StgBool isThreadBound (StgTSO* tso); +// Overfow/underflow +void threadStackOverflow (Capability *cap, StgTSO *tso); +nat threadStackUnderflow (Capability *cap, StgTSO *tso); + #ifdef DEBUG void printThreadBlockage (StgTSO *tso); void printThreadStatus (StgTSO *t); diff -Nru ghc-7.0.3/rts/Trace.c ghc-7.2.1/rts/Trace.c --- ghc-7.0.3/rts/Trace.c 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/rts/Trace.c 2011-08-07 17:10:05.000000000 +0000 @@ -15,11 +15,16 @@ #ifdef TRACING #include "GetTime.h" +#include "GetEnv.h" #include "Stats.h" #include "eventlog/EventLog.h" #include "Threads.h" #include "Printer.h" +#ifdef HAVE_UNISTD_H +#include +#endif + #ifdef DEBUG // debugging flags, set with +RTS -D int DEBUG_sched; @@ -137,14 +142,26 @@ [ThreadYielding] = "yielding", [ThreadBlocked] = "blocked", [ThreadFinished] = "finished", - [THREAD_SUSPENDED_FOREIGN_CALL] = "suspended while making a foreign call" + [THREAD_SUSPENDED_FOREIGN_CALL] = "suspended while making a foreign call", + [6 + BlockedOnMVar] = "blocked on an MVar", + [6 + BlockedOnBlackHole] = "blocked on a black hole", + [6 + BlockedOnRead] = "blocked on a read operation", + [6 + BlockedOnWrite] = "blocked on a write operation", + [6 + BlockedOnDelay] = "blocked on a delay operation", + [6 + BlockedOnSTM] = "blocked on STM", + [6 + BlockedOnDoProc] = "blocked on asyncDoProc", + [6 + BlockedOnCCall] = "blocked on a foreign call", + [6 + BlockedOnCCall_Interruptible] = "blocked on a foreign call (interruptible)", + [6 + BlockedOnMsgThrowTo] = "blocked on throwTo", + [6 + ThreadMigrating] = "migrating" }; #endif #ifdef DEBUG static void traceSchedEvent_stderr (Capability *cap, EventTypeNum tag, StgTSO *tso, - StgWord64 other STG_UNUSED) + StgWord info1 STG_UNUSED, + StgWord info2 STG_UNUSED) { ACQUIRE_LOCK(&trace_utx); @@ -168,24 +185,29 @@ break; case EVENT_CREATE_SPARK_THREAD: // (cap, spark_thread) debugBelch("cap %d: creating spark thread %lu\n", - cap->no, (long)other); + cap->no, (long)info1); break; case EVENT_MIGRATE_THREAD: // (cap, thread, new_cap) debugBelch("cap %d: thread %lu migrating to cap %d\n", - cap->no, (lnat)tso->id, (int)other); + cap->no, (lnat)tso->id, (int)info1); break; case EVENT_STEAL_SPARK: // (cap, thread, victim_cap) debugBelch("cap %d: thread %lu stealing a spark from cap %d\n", - cap->no, (lnat)tso->id, (int)other); + cap->no, (lnat)tso->id, (int)info1); break; - case EVENT_THREAD_WAKEUP: // (cap, thread, other_cap) + case EVENT_THREAD_WAKEUP: // (cap, thread, info1_cap) debugBelch("cap %d: waking up thread %lu on cap %d\n", - cap->no, (lnat)tso->id, (int)other); + cap->no, (lnat)tso->id, (int)info1); break; case EVENT_STOP_THREAD: // (cap, thread, status) - debugBelch("cap %d: thread %lu stopped (%s)\n", - cap->no, (lnat)tso->id, thread_stop_reasons[other]); + if (info1 == 6 + BlockedOnBlackHole) { + debugBelch("cap %d: thread %lu stopped (blocked on black hole owned by thread %lu)\n", + cap->no, (lnat)tso->id, (long)info2); + } else { + debugBelch("cap %d: thread %lu stopped (%s)\n", + cap->no, (lnat)tso->id, thread_stop_reasons[info1]); + } break; case EVENT_SHUTDOWN: // (cap) debugBelch("cap %d: shutting down\n", cap->no); @@ -222,15 +244,94 @@ #endif void traceSchedEvent_ (Capability *cap, EventTypeNum tag, - StgTSO *tso, StgWord64 other) + StgTSO *tso, StgWord info1, StgWord info2) { #ifdef DEBUG if (RtsFlags.TraceFlags.tracing == TRACE_STDERR) { - traceSchedEvent_stderr(cap, tag, tso, other); + traceSchedEvent_stderr(cap, tag, tso, info1, info2); } else #endif { - postSchedEvent(cap,tag,tso ? tso->id : 0,other); + postSchedEvent(cap,tag,tso ? tso->id : 0, info1, info2); + } +} + +void traceCapsetModify_ (EventTypeNum tag, + CapsetID capset, + StgWord32 other) +{ +#ifdef DEBUG + if (RtsFlags.TraceFlags.tracing == TRACE_STDERR) { + ACQUIRE_LOCK(&trace_utx); + + tracePreface(); + switch (tag) { + case EVENT_CAPSET_CREATE: // (capset, capset_type) + debugBelch("created capset %lu of type %d\n", (lnat)capset, (int)other); + break; + case EVENT_CAPSET_DELETE: // (capset) + debugBelch("deleted capset %lu\n", (lnat)capset); + break; + case EVENT_CAPSET_ASSIGN_CAP: // (capset, capno) + debugBelch("assigned cap %lu to capset %lu\n", + (lnat)other, (lnat)capset); + break; + case EVENT_CAPSET_REMOVE_CAP: // (capset, capno) + debugBelch("removed cap %lu from capset %lu\n", + (lnat)other, (lnat)capset); + break; + } + RELEASE_LOCK(&trace_utx); + } else +#endif + { + if (eventlog_enabled) { + postCapsetModifyEvent(tag, capset, other); + } + } +} + +void traceOSProcessInfo_(void) { + if (eventlog_enabled) { + postCapsetModifyEvent(EVENT_OSPROCESS_PID, + CAPSET_OSPROCESS_DEFAULT, + getpid()); + +#if !defined(cygwin32_HOST_OS) && !defined (mingw32_HOST_OS) +/* Windows has no strong concept of process heirarchy, so no getppid(). + * In any case, this trace event is mainly useful for tracing programs + * that use 'forkProcess' which Windows doesn't support anyway. + */ + postCapsetModifyEvent(EVENT_OSPROCESS_PPID, + CAPSET_OSPROCESS_DEFAULT, + getppid()); +#endif + { + char buf[256]; + snprintf(buf, sizeof(buf), "GHC-%s %s", ProjectVersion, RtsWay); + postCapsetStrEvent(EVENT_RTS_IDENTIFIER, + CAPSET_OSPROCESS_DEFAULT, + buf); + } + { + int argc = 0; char **argv; + getFullProgArgv(&argc, &argv); + if (argc != 0) { + postCapsetVecEvent(EVENT_PROGRAM_ARGS, + CAPSET_OSPROCESS_DEFAULT, + argc, argv); + } + } + { + int envc = 0; char **envv; + getProgEnvv(&envc, &envv); + if (envc != 0) { + postCapsetVecEvent(EVENT_PROGRAM_ENV, + CAPSET_OSPROCESS_DEFAULT, + envc, envv); + } + freeProgEnvv(envc, envv); + } } } @@ -238,7 +339,7 @@ { #ifdef DEBUG if (RtsFlags.TraceFlags.tracing == TRACE_STDERR) { - traceSchedEvent_stderr(cap, tag, 0, 0); + traceSchedEvent_stderr(cap, tag, 0, 0, 0); } else #endif { @@ -342,6 +443,12 @@ } } +void traceEventStartup_(int nocaps) +{ + if (eventlog_enabled) { + postEventStartup(nocaps); + } +} #ifdef DEBUG void traceBegin (const char *str, ...) diff -Nru ghc-7.0.3/rts/Trace.h ghc-7.2.1/rts/Trace.h --- ghc-7.0.3/rts/Trace.h 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/rts/Trace.h 2011-08-07 17:10:05.000000000 +0000 @@ -31,6 +31,13 @@ #endif /* TRACING */ +typedef StgWord32 CapsetID; +typedef StgWord16 CapsetType; +enum CapsetType { CapsetTypeCustom = CAPSET_TYPE_CUSTOM, + CapsetTypeOsProcess = CAPSET_TYPE_OSPROCESS, + CapsetTypeClockdomain = CAPSET_TYPE_CLOCKDOMAIN }; +#define CAPSET_OSPROCESS_DEFAULT 0 + // ----------------------------------------------------------------------------- // Message classes // ----------------------------------------------------------------------------- @@ -78,11 +85,16 @@ */ #define traceSchedEvent(cap, tag, tso, other) \ if (RTS_UNLIKELY(TRACE_sched)) { \ - traceSchedEvent_(cap, tag, tso, other); \ + traceSchedEvent_(cap, tag, tso, other, 0); \ + } + +#define traceSchedEvent2(cap, tag, tso, info1, info2) \ + if (RTS_UNLIKELY(TRACE_sched)) { \ + traceSchedEvent_(cap, tag, tso, info1, info2); \ } void traceSchedEvent_ (Capability *cap, EventTypeNum tag, - StgTSO *tso, StgWord64 other); + StgTSO *tso, StgWord info1, StgWord info2); /* @@ -155,15 +167,36 @@ void traceThreadStatus_ (StgTSO *tso); +void traceEventStartup_ (int n_caps); + +/* + * Events for describing capability sets in the eventlog + * + * Note: unlike other events, these are not conditional on TRACE_sched or + * similar because they are not "real" events themselves but provide + * information and context for other "real" events. Other events depend on + * the capset info events so for simplicity, rather than working out if + * they're necessary we always emit them. They should be very low volume. + */ +void traceCapsetModify_ (EventTypeNum tag, + CapsetID capset, + StgWord32 other); + +void traceOSProcessInfo_ (void); + #else /* !TRACING */ #define traceSchedEvent(cap, tag, tso, other) /* nothing */ +#define traceSchedEvent2(cap, tag, tso, other, info) /* nothing */ #define traceEvent(cap, tag) /* nothing */ #define traceCap(class, cap, msg, ...) /* nothing */ #define trace(class, msg, ...) /* nothing */ #define debugTrace(class, str, ...) /* nothing */ #define debugTraceCap(class, cap, str, ...) /* nothing */ #define traceThreadStatus(class, tso) /* nothing */ +INLINE_HEADER void traceEventStartup_ (int n_caps STG_UNUSED) {}; +#define traceCapsetModify_(tag, capset, other) /* nothing */ +#define traceOSProcessInfo_() /* nothing */ #endif /* TRACING */ @@ -186,8 +219,8 @@ HASKELLEVENT_CREATE_THREAD(cap, tid) #define dtraceRunThread(cap, tid) \ HASKELLEVENT_RUN_THREAD(cap, tid) -#define dtraceStopThread(cap, tid, status) \ - HASKELLEVENT_STOP_THREAD(cap, tid, status) +#define dtraceStopThread(cap, tid, status, info) \ + HASKELLEVENT_STOP_THREAD(cap, tid, status, info) #define dtraceThreadRunnable(cap, tid) \ HASKELLEVENT_THREAD_RUNNABLE(cap, tid) #define dtraceMigrateThread(cap, tid, new_cap) \ @@ -210,8 +243,9 @@ HASKELLEVENT_REQUEST_PAR_GC(cap) #define dtraceCreateSparkThread(cap, spark_tid) \ HASKELLEVENT_CREATE_SPARK_THREAD(cap, spark_tid) -#define dtraceStartup(num_caps) \ - HASKELLEVENT_STARTUP(num_caps) +INLINE_HEADER void dtraceStartup (int num_caps) { + HASKELLEVENT_STARTUP(num_caps); +} #define dtraceUserMsg(cap, msg) \ HASKELLEVENT_USER_MSG(cap, msg) #define dtraceGcIdle(cap) \ @@ -220,12 +254,20 @@ HASKELLEVENT_GC_WORK(cap) #define dtraceGcDone(cap) \ HASKELLEVENT_GC_DONE(cap) +#define dtraceCapsetCreate(capset, capset_type) \ + HASKELLEVENT_CAPSET_CREATE(capset, capset_type) +#define dtraceCapsetDelete(capset) \ + HASKELLEVENT_CAPSET_DELETE(capset) +#define dtraceCapsetAssignCap(capset, capno) \ + HASKELLEVENT_CAPSET_ASSIGN_CAP(capset, capno) +#define dtraceCapsetRemoveCap(capset, capno) \ + HASKELLEVENT_CAPSET_REMOVE_CAP(capset, capno) #else /* !defined(DTRACE) */ #define dtraceCreateThread(cap, tid) /* nothing */ #define dtraceRunThread(cap, tid) /* nothing */ -#define dtraceStopThread(cap, tid, status) /* nothing */ +#define dtraceStopThread(cap, tid, status, info) /* nothing */ #define dtraceThreadRunnable(cap, tid) /* nothing */ #define dtraceMigrateThread(cap, tid, new_cap) /* nothing */ #define dtraceRunSpark(cap, tid) /* nothing */ @@ -237,11 +279,15 @@ #define dtraceRequestSeqGc(cap) /* nothing */ #define dtraceRequestParGc(cap) /* nothing */ #define dtraceCreateSparkThread(cap, spark_tid) /* nothing */ -#define dtraceStartup(num_caps) /* nothing */ +INLINE_HEADER void dtraceStartup (int num_caps STG_UNUSED) {}; #define dtraceUserMsg(cap, msg) /* nothing */ #define dtraceGcIdle(cap) /* nothing */ #define dtraceGcWork(cap) /* nothing */ #define dtraceGcDone(cap) /* nothing */ +#define dtraceCapsetCreate(capset, capset_type) /* nothing */ +#define dtraceCapsetDelete(capset) /* nothing */ +#define dtraceCapsetAssignCap(capset, capno) /* nothing */ +#define dtraceCapsetRemoveCap(capset, capno) /* nothing */ #endif @@ -265,7 +311,7 @@ INLINE_HEADER void traceEventCreateThread(Capability *cap STG_UNUSED, StgTSO *tso STG_UNUSED) { - traceSchedEvent(cap, EVENT_CREATE_THREAD, tso, tso->stack_size); + traceSchedEvent(cap, EVENT_CREATE_THREAD, tso, tso->stackobj->stack_size); dtraceCreateThread((EventCapNo)cap->no, (EventThreadID)tso->id); } @@ -278,11 +324,12 @@ INLINE_HEADER void traceEventStopThread(Capability *cap STG_UNUSED, StgTSO *tso STG_UNUSED, - StgThreadReturnCode status STG_UNUSED) + StgThreadReturnCode status STG_UNUSED, + StgWord32 info STG_UNUSED) { - traceSchedEvent(cap, EVENT_STOP_THREAD, tso, status); + traceSchedEvent2(cap, EVENT_STOP_THREAD, tso, status, info); dtraceStopThread((EventCapNo)cap->no, (EventThreadID)tso->id, - (EventThreadStatus)status); + (EventThreadStatus)status, (EventThreadID)info); } // needs to be EXTERN_INLINE as it is used in another EXTERN_INLINE function @@ -367,17 +414,18 @@ dtraceCreateSparkThread((EventCapNo)cap->no, (EventThreadID)spark_tid); } -// This applies only to dtrace as EVENT_STARTUP in the logging framework is -// handled specially in 'EventLog.c'. -// -INLINE_HEADER void dtraceEventStartup(void) +INLINE_HEADER void traceEventStartup(void) { + int n_caps; #ifdef THREADED_RTS - // XXX n_capabilities hasn't been initislised yet - dtraceStartup(RtsFlags.ParFlags.nNodes); + // XXX n_capabilities hasn't been initialised yet + n_caps = RtsFlags.ParFlags.nNodes; #else - dtraceStartup(1); + n_caps = 1; #endif + + traceEventStartup_(n_caps); + dtraceStartup(n_caps); } INLINE_HEADER void traceEventGcIdle(Capability *cap STG_UNUSED) @@ -398,6 +446,40 @@ dtraceGcDone((EventCapNo)cap->no); } +INLINE_HEADER void traceCapsetCreate(CapsetID capset STG_UNUSED, + CapsetType capset_type STG_UNUSED) +{ + traceCapsetModify_(EVENT_CAPSET_CREATE, capset, capset_type); + dtraceCapsetCreate(capset, capset_type); +} + +INLINE_HEADER void traceCapsetDelete(CapsetID capset STG_UNUSED) +{ + traceCapsetModify_(EVENT_CAPSET_DELETE, capset, 0); + dtraceCapsetDelete(capset); +} + +INLINE_HEADER void traceCapsetAssignCap(CapsetID capset STG_UNUSED, + nat capno STG_UNUSED) +{ + traceCapsetModify_(EVENT_CAPSET_ASSIGN_CAP, capset, capno); + dtraceCapsetAssignCap(capset, capno); +} + +INLINE_HEADER void traceCapsetRemoveCap(CapsetID capset STG_UNUSED, + nat capno STG_UNUSED) +{ + traceCapsetModify_(EVENT_CAPSET_REMOVE_CAP, capset, capno); + dtraceCapsetRemoveCap(capset, capno); +} + +INLINE_HEADER void traceOSProcessInfo(void) +{ + traceOSProcessInfo_(); + /* Note: no DTrace equivalent because all this OS process info + * is available to DTrace directly */ +} + #include "EndPrivate.h" #endif /* TRACE_H */ diff -Nru ghc-7.0.3/rts/Updates.h ghc-7.2.1/rts/Updates.h --- ghc-7.0.3/rts/Updates.h 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/rts/Updates.h 2011-08-07 17:10:05.000000000 +0000 @@ -18,101 +18,12 @@ -------------------------------------------------------------------------- */ /* LDV profiling: - * We call LDV_recordDead_FILL_SLOP_DYNAMIC(p1) regardless of the generation in - * which p1 resides. - * - * Note: * After all, we do *NOT* need to call LDV_RECORD_CREATE() for IND * closures because they are inherently used. But, it corrupts * the invariants that every closure keeps its creation time in the profiling * field. So, we call LDV_RECORD_CREATE(). */ -/* In the DEBUG case, we also zero out the slop of the old closure, - * so that the sanity checker can tell where the next closure is. - * - * Two important invariants: we should never try to update a closure - * to point to itself, and the closure being updated should not - * already have been updated (the mutable list will get messed up - * otherwise). - * - * NB. We do *not* do this in THREADED_RTS mode, because when we have the - * possibility of multiple threads entering the same closure, zeroing - * the slop in one of the threads would have a disastrous effect on - * the other (seen in the wild!). - */ -#ifdef CMINUSMINUS - -#define FILL_SLOP(p) \ - W_ inf; \ - W_ sz; \ - W_ i; \ - inf = %GET_STD_INFO(p); \ - if (%INFO_TYPE(inf) != HALF_W_(BLACKHOLE)) { \ - if (%INFO_TYPE(inf) == HALF_W_(THUNK_SELECTOR)) { \ - sz = BYTES_TO_WDS(SIZEOF_StgSelector_NoThunkHdr); \ - } else { \ - if (%INFO_TYPE(inf) == HALF_W_(AP_STACK)) { \ - sz = StgAP_STACK_size(p) + BYTES_TO_WDS(SIZEOF_StgAP_STACK_NoThunkHdr); \ - } else { \ - if (%INFO_TYPE(inf) == HALF_W_(AP)) { \ - sz = TO_W_(StgAP_n_args(p)) + BYTES_TO_WDS(SIZEOF_StgAP_NoThunkHdr); \ - } else { \ - sz = TO_W_(%INFO_PTRS(inf)) + TO_W_(%INFO_NPTRS(inf)); \ - } \ - } \ - } \ - i = 0; \ - for: \ - if (i < sz) { \ - StgThunk_payload(p,i) = 0; \ - i = i + 1; \ - goto for; \ - } \ - } - -#else /* !CMINUSMINUS */ - -INLINE_HEADER void -FILL_SLOP(StgClosure *p) -{ - StgInfoTable *inf = get_itbl(p); - nat i, sz; - - switch (inf->type) { - case BLACKHOLE: - goto no_slop; - // we already filled in the slop when we overwrote the thunk - // with BLACKHOLE, and also an evacuated BLACKHOLE is only the - // size of an IND. - case THUNK_SELECTOR: - sz = sizeofW(StgSelector) - sizeofW(StgThunkHeader); - break; - case AP: - sz = ((StgAP *)p)->n_args + sizeofW(StgAP) - sizeofW(StgThunkHeader); - break; - case AP_STACK: - sz = ((StgAP_STACK *)p)->size + sizeofW(StgAP_STACK) - sizeofW(StgThunkHeader); - break; - default: - sz = inf->layout.payload.ptrs + inf->layout.payload.nptrs; - break; - } - for (i = 0; i < sz; i++) { - ((StgThunk *)p)->payload[i] = 0; - } -no_slop: - ; -} - -#endif /* CMINUSMINUS */ - -#if !defined(DEBUG) || defined(THREADED_RTS) -#define DEBUG_FILL_SLOP(p) /* do nothing */ -#else -#define DEBUG_FILL_SLOP(p) FILL_SLOP(p) -#endif - /* We have two versions of this macro (sadly), one for use in C-- code, * and the other for C. * @@ -128,9 +39,8 @@ #define updateWithIndirection(p1, p2, and_then) \ W_ bd; \ \ - DEBUG_FILL_SLOP(p1); \ - LDV_RECORD_DEAD_FILL_SLOP_DYNAMIC(p1); \ - StgInd_indirectee(p1) = p2; \ + OVERWRITING_CLOSURE(p1); \ + StgInd_indirectee(p1) = p2; \ prim %write_barrier() []; \ SET_INFO(p1, stg_BLACKHOLE_info); \ LDV_RECORD_CREATE(p1); \ @@ -155,8 +65,7 @@ ASSERT( (P_)p1 != (P_)p2 ); /* not necessarily true: ASSERT( !closure_IND(p1) ); */ /* occurs in RaiseAsync.c:raiseAsync() */ - DEBUG_FILL_SLOP(p1); - LDV_RECORD_DEAD_FILL_SLOP_DYNAMIC(p1); + OVERWRITING_CLOSURE(p1); ((StgInd *)p1)->indirectee = p2; write_barrier(); SET_INFO(p1, &stg_BLACKHOLE_info); diff -Nru ghc-7.0.3/rts/win32/AsyncIO.c ghc-7.2.1/rts/win32/AsyncIO.c --- ghc-7.0.3/rts/win32/AsyncIO.c 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/rts/win32/AsyncIO.c 2011-08-07 17:10:05.000000000 +0000 @@ -276,20 +276,7 @@ prev = NULL; for(tso = blocked_queue_hd ; tso != END_TSO_QUEUE; tso = tso->_link) { - if (tso->what_next == ThreadRelocated) { - /* Drop the TSO from blocked_queue */ - if (prev) { - setTSOLink(&MainCapability, prev, tso->_link); - } else { - blocked_queue_hd = tso->_link; - } - if (blocked_queue_tl == tso) { - blocked_queue_tl = prev ? prev : END_TSO_QUEUE; - } - continue; - } - - switch(tso->why_blocked) { + switch(tso->why_blocked) { case BlockedOnRead: case BlockedOnWrite: case BlockedOnDoProc: @@ -317,7 +304,7 @@ // stg_block_async_info stack frame, because // the block_info field will be overwritten by // pushOnRunQueue(). - tso->sp[1] = (W_)tso->block_info.async_result; + tso->stackobj->sp[1] = (W_)tso->block_info.async_result; pushOnRunQueue(&MainCapability, tso); break; } diff -Nru ghc-7.0.3/rts/win32/GetEnv.c ghc-7.2.1/rts/win32/GetEnv.c --- ghc-7.0.3/rts/win32/GetEnv.c 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/rts/win32/GetEnv.c 2011-08-07 17:10:05.000000000 +0000 @@ -0,0 +1,62 @@ +/* ----------------------------------------------------------------------------- + * + * (c) The GHC Team 2011 + * + * Access to the process environment variables + * + * ---------------------------------------------------------------------------*/ + +#include "Rts.h" +#include "RtsUtils.h" +#include "GetEnv.h" + +#include + +/* Windows does it differently, though arguably the most sanely. + * GetEnvironmentStrings() returns a pointer to a block of + * environment vars with a double null terminator: + * Var1=Value1\0 + * Var2=Value2\0 + * ... + * VarN=ValueN\0\0 + * But because everyone else (ie POSIX) uses a vector of strings, we convert + * to that format. Fortunately this is just a matter of making an array of + * offsets into the environment block. + * + * Note that we have to call FreeEnvironmentStrings() at the end. + * + */ +void getProgEnvv(int *out_envc, char **out_envv[]) { + int envc, i; + char *env; + char *envp; + char **envv; + + /* For now, use the 'A'nsi not 'W'ide variant. + Note: corresponding Free below must use the same 'A'/'W' variant. */ + env = GetEnvironmentStringsA(); + + envc = 0; + for (envp = env; *envp != 0; envp += strlen(envp) + 1) { + envc++; + } + + envv = stgMallocBytes(sizeof(char*) * (envc+1), "getProgEnvv"); + + i = 0; + for (envp = env; *envp != 0; envp += strlen(envp) + 1) { + envv[i] = envp; + i++; + } + /* stash whole env in last+1 entry */ + envv[envc] = env; + + *out_envc = envc; + *out_envv = envv; +} + +void freeProgEnvv(int envc, char *envv[]) { + /* we stashed the win32 env block in the last+1 entry */ + FreeEnvironmentStringsA(envv[envc]); + stgFree(envv); +} diff -Nru ghc-7.0.3/rts/win32/libHSghc-prim.def ghc-7.2.1/rts/win32/libHSghc-prim.def --- ghc-7.0.3/rts/win32/libHSghc-prim.def 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/rts/win32/libHSghc-prim.def 2011-08-07 17:10:05.000000000 +0000 @@ -3,8 +3,8 @@ EXPORTS - ghczmprim_GHCziBool_True_closure - ghczmprim_GHCziBool_False_closure + ghczmprim_GHCziTypes_True_closure + ghczmprim_GHCziTypes_False_closure ghczmprim_GHCziTypes_Czh_con_info ghczmprim_GHCziTypes_Izh_con_info ghczmprim_GHCziTypes_Fzh_con_info diff -Nru ghc-7.0.3/rts/win32/OSMem.c ghc-7.2.1/rts/win32/OSMem.c --- ghc-7.0.3/rts/win32/OSMem.c 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/rts/win32/OSMem.c 2011-08-07 17:10:05.000000000 +0000 @@ -47,7 +47,7 @@ alloc_rec* rec; rec = (alloc_rec*)stgMallocBytes(sizeof(alloc_rec),"getMBlocks: allocNew"); rec->size = (n+1)*MBLOCK_SIZE; - rec->base = + rec->base = VirtualAlloc(NULL, rec->size, MEM_RESERVE, PAGE_READWRITE); if(rec->base==0) { stgFree((void*)rec); @@ -60,8 +60,8 @@ "getMBlocks: VirtualAlloc MEM_RESERVE %d blocks failed", n); } } else { - alloc_rec temp; - temp.base=0; temp.size=0; temp.next=allocs; + alloc_rec temp; + temp.base=0; temp.size=0; temp.next=allocs; alloc_rec* it; it=&temp; @@ -69,7 +69,7 @@ rec->next=it->next; it->next=rec; - allocs=temp.next; + allocs=temp.next; } return rec; } @@ -170,8 +170,8 @@ temp = VirtualAlloc(base, size_delta, MEM_COMMIT, PAGE_READWRITE); if(temp==0) { sysErrorBelch("getMBlocks: VirtualAlloc MEM_COMMIT failed"); - stg_exit(EXIT_FAILURE); - } + stg_exit(EXIT_FAILURE); + } size-=size_delta; base+=size_delta; } @@ -185,12 +185,12 @@ alloc_rec* alloc; alloc = allocNew(n); /* We already belch in allocNew if it fails */ - if (alloc == 0) { - stg_exit(EXIT_FAILURE); - } else { + if (alloc == 0) { + stg_exit(EXIT_FAILURE); + } else { insertFree(alloc->base, alloc->size); ret = findFreeBlocks(n); - } + } } if(ret!=0) { @@ -356,7 +356,7 @@ for(; it!=0; ) { if(!VirtualFree((void*)it->base, 0, MEM_RELEASE)) { sysErrorBelch("freeAllMBlocks: VirtualFree MEM_RELEASE failed"); - stg_exit(EXIT_FAILURE); + stg_exit(EXIT_FAILURE); } next = it->next; stgFree(it); @@ -369,23 +369,23 @@ { static lnat pagesize = 0; if (pagesize) { - return pagesize; + return pagesize; } else { - SYSTEM_INFO sSysInfo; - GetSystemInfo(&sSysInfo); - pagesize = sSysInfo.dwPageSize; - return pagesize; + SYSTEM_INFO sSysInfo; + GetSystemInfo(&sSysInfo); + pagesize = sSysInfo.dwPageSize; + return pagesize; } } void setExecutable (void *p, lnat len, rtsBool exec) { DWORD dwOldProtect = 0; - if (VirtualProtect (p, len, - exec ? PAGE_EXECUTE_READWRITE : PAGE_READWRITE, - &dwOldProtect) == 0) + if (VirtualProtect (p, len, + exec ? PAGE_EXECUTE_READWRITE : PAGE_READWRITE, + &dwOldProtect) == 0) { - sysErrorBelch("setExecutable: failed to protect 0x%p; old protection: %lu\n", + sysErrorBelch("setExecutable: failed to protect 0x%p; old protection: %lu\n", p, (unsigned long)dwOldProtect); stg_exit(EXIT_FAILURE); } diff -Nru ghc-7.0.3/rts/win32/OSThreads.c ghc-7.2.1/rts/win32/OSThreads.c --- ghc-7.0.3/rts/win32/OSThreads.c 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/rts/win32/OSThreads.c 2011-08-07 17:10:05.000000000 +0000 @@ -269,6 +269,25 @@ } } +typedef BOOL (WINAPI *PCSIO)(HANDLE); + +void +interruptOSThread (OSThreadId id) +{ + HANDLE hdl; + PCSIO pCSIO; + if (!(hdl = OpenThread(THREAD_TERMINATE,FALSE,id))) { + sysErrorBelch("interruptOSThread: OpenThread"); + stg_exit(EXIT_FAILURE); + } + pCSIO = (PCSIO) GetProcAddress(GetModuleHandle(TEXT("Kernel32.dll")), "CancelSynchronousIo"); + if ( NULL != pCSIO ) { + pCSIO(hdl); + } else { + // Nothing to do, unfortunately + } +} + #else /* !defined(THREADED_RTS) */ int diff -Nru ghc-7.0.3/rts/WSDeque.c ghc-7.2.1/rts/WSDeque.c --- ghc-7.0.3/rts/WSDeque.c 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/rts/WSDeque.c 2011-08-07 17:10:05.000000000 +0000 @@ -32,7 +32,7 @@ * * Both popWSDeque and stealWSDeque also return NULL when the queue is empty. * - * Testing: see testsuite/tests/ghc-regress/rts/testwsdeque.c. If + * Testing: see testsuite/tests/rts/testwsdeque.c. If * there's anything wrong with the deque implementation, this test * will probably catch it. * diff -Nru ghc-7.0.3/rules/build-dependencies.mk ghc-7.2.1/rules/build-dependencies.mk --- ghc-7.0.3/rules/build-dependencies.mk 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/rules/build-dependencies.mk 2011-08-07 17:10:05.000000000 +0000 @@ -12,6 +12,7 @@ define build-dependencies $(call trace, build-dependencies($1,$2,$3)) +$(call profStart, build-dependencies($1,$2,$3)) # $1 = dir # $2 = distdir # $3 = GHC stage to use (0 == bootstrapping compiler) @@ -22,11 +23,13 @@ $1_$2_C_FILES_DEPS = $$(filter-out $$($1_$2_C_FILES_NODEPS),$$($1_$2_C_FILES)) $1_$2_MKDEPENDHS_FLAGS = -dep-makefile $$($1_$2_depfile_haskell).tmp $$(foreach way,$$(filter-out v,$$($1_$2_WAYS)),-dep-suffix $$(way)) -ifneq "$3" "0" $1_$2_MKDEPENDHS_FLAGS += -include-pkg-deps -endif -ifneq "$$($1_$2_NO_BUILD_DEPS)" "YES" +ifneq "$$(NO_GENERATED_MAKEFILE_RULES)" "YES" + +# Some of the Haskell files (e.g. utils/hsc2hs/Main.hs) (directly or +# indirectly) include the generated includes files. +$$($1_$2_depfile_haskell) : $$(includes_H_CONFIG) $$(includes_H_PLATFORM) $$($1_$2_depfile_haskell) : $$($1_$2_HS_SRCS) $$($1_$2_HS_BOOT_SRCS) $$($1_$2_HC_MK_DEPEND_DEP) | $$$$(dir $$$$@)/. "$$(RM)" $$(RM_OPTS) $$@.tmp @@ -42,9 +45,13 @@ if test ! -d $$$$dir; then mkdir -p $$$$dir; fi \ done endif - mv $$@.tmp $$@ +# Some packages are from the bootstrapping compiler, so are not +# within the build tree. On Windows this causes a problem as they look +# like bad rules, due to the two colons, so we filter them out. + grep -v ' : [a-zA-Z]:/' $$@.tmp > $$@ -# Some of the C files depend on the generated includes files. +# Some of the C files (directly or indirectly) include the generated +# includes files. $$($1_$2_depfile_c_asm) : $$(includes_H_CONFIG) $$(includes_H_PLATFORM) $$($1_$2_depfile_c_asm) : $$($1_$2_C_FILES_DEPS) $$($1_$2_S_FILES) | $$$$(dir $$$$@)/. @@ -62,27 +69,12 @@ echo "$1_$2_depfile_c_asm_EXISTS = YES" >> $$@.tmp mv $$@.tmp $$@ -endif # $1_$2_NO_BUILD_DEPS +endif # NO_GENERATED_MAKEFILE_RULES # Note sed magic above: mkdependC can't do -odir stuff, so we have to # munge the dependencies it generates to refer to the correct targets. -# Seems as good a place as any to attach the unlit dependency -$$($1_$2_depfile_haskell) : $$(UNLIT) - -ifneq "$$(NO_INCLUDE_DEPS)" "YES" -ifneq "$$(strip $$($1_$2_HS_SRCS) $$($1_$2_HS_BOOT_SRCS))" "" -ifneq "$$(NO_STAGE$3_DEPS)" "YES" -include $$($1_$2_depfile_haskell) -endif -endif -include $$($1_$2_depfile_c_asm) -else -ifeq "$$(DEBUG)" "YES" -$$(warning not building dependencies in $1) -endif -endif - +$(call profEnd, build-dependencies($1,$2,$3)) endef # This comment is outside the "define addCFileDeps" as that definition diff -Nru ghc-7.0.3/rules/build-package-data.mk ghc-7.2.1/rules/build-package-data.mk --- ghc-7.0.3/rules/build-package-data.mk 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/rules/build-package-data.mk 2011-08-07 17:10:05.000000000 +0000 @@ -12,6 +12,7 @@ define build-package-data $(call trace, build-package-data($1,$2,$3)) +$(call profStart, build-package-data($1,$2,$3)) # args: # $1 = dir # $2 = distdir @@ -62,33 +63,30 @@ $1_$2_CONFIGURE_OPTS += $$(BOOT_PKG_CONSTRAINTS) endif +$1_$2_CONFIGURE_OPTS += --with-gcc="$$(CC_STAGE$3)" +$1_$2_CONFIGURE_OPTS += --configure-option=--with-cc="$$(CC_STAGE$3)" +$1_$2_CONFIGURE_OPTS += --with-ar="$$(AR_STAGE$3)" +$1_$2_CONFIGURE_OPTS += --with-ranlib="$$(RANLIB)" + +ifneq "$$(BINDIST)" "YES" +ifneq "$$(NO_GENERATED_MAKEFILE_RULES)" "YES" +$1/$2/inplace-pkg-config : $1/$2/package-data.mk +$1/$2/build/autogen/cabal_macros.h : $1/$2/package-data.mk + # This rule configures the package, generates the package-data.mk file # for our build system, and registers the package for use in-place in # the build tree. -$1/$2/package-data.mk $1/$2/inplace-pkg-config $1/$2/build/autogen/cabal_macros.h : $$(GHC_CABAL_INPLACE) $$($1_$2_GHC_PKG_DEP) $1/$$($1_PACKAGE).cabal $$(wildcard $1/configure) $$($1_$2_HC_CONFIG_DEP) - "$$(GHC_CABAL_INPLACE)" configure --with-ghc="$$($1_$2_HC_CONFIG)" --with-ghc-pkg="$$($1_$2_GHC_PKG)" --with-gcc="$$(WhatGccIsCalled)" --configure-option=--with-cc="$$(WhatGccIsCalled)" $$($1_CONFIGURE_OPTS) $$($1_$2_CONFIGURE_OPTS) -- $2 $1 +$1/$2/package-data.mk : $$(GHC_CABAL_INPLACE) $$($1_$2_GHC_PKG_DEP) $1/$$($1_PACKAGE).cabal $$(wildcard $1/configure) $$($1_$2_HC_CONFIG_DEP) + "$$(GHC_CABAL_INPLACE)" configure --with-ghc="$$($1_$2_HC_CONFIG)" --with-ghc-pkg="$$($1_$2_GHC_PKG)" $$($1_CONFIGURE_OPTS) $$($1_$2_CONFIGURE_OPTS) -- $2 $1 ifeq "$$($1_$2_PROG)" "" ifneq "$$($1_$2_REGISTER_PACKAGE)" "NO" -ifeq "$$(ghc_ge_6102) $3" "NO 0" # NOTE [1] below - cat $1/$2/inplace-pkg-config | sed "s@^import-dirs:@import-dirs: $(TOP)/$1 $(TOP)/$1/src @" | "$$($1_$2_GHC_PKG)" update --force $$($1_$2_GHC_PKG_OPTS) - -else - "$$($1_$2_GHC_PKG)" update --force $$($1_$2_GHC_PKG_OPTS) $1/$2/inplace-pkg-config + "$$($1_$2_GHC_PKG)" update --force $$($1_$2_GHC_PKG_OPTS) $1/$2/inplace-pkg-config +endif endif endif endif -# [1] this is a hack for GHC <= 6.10.1. When making dependencies with -# ghc -M, in GHC 6.10.1 and earlier, GHC needed to find either the .hi -# file or the source file for any dependency. Since we build the -# .depend files before building the packages, we have to make sure GHC -# can find the source files; hence we have to make sure that the -# import-dirs field of each boot package points to the sources for the -# package as well as the dist/build dir. -# -# In GHC 6.10.2, we changed the way ghc -M worked so that it doesn't -# check for existence of the source file, and doesn't look for the .hi -# file if there is only one possibility for its location. Which means -# that we must *not* do that above hack in this case, because there -# would be multiple locations to search for the .hi file. +PACKAGE_DATA_MKS += $1/$2/package-data.mk +$(call profEnd, build-package-data($1,$2,$3)) endef diff -Nru ghc-7.0.3/rules/build-package.mk ghc-7.2.1/rules/build-package.mk --- ghc-7.0.3/rules/build-package.mk 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/rules/build-package.mk 2011-08-07 17:10:05.000000000 +0000 @@ -30,6 +30,7 @@ define build-package $(call trace, build-package($1,$2,$3)) +$(call profStart, build-package($1,$2,$3)) # $1 = dir # $2 = distdir # $3 = GHC stage to use (0 == bootstrapping compiler) @@ -52,6 +53,7 @@ ifneq "$$($1_$2_NOT_NEEDED)" "YES" $$(eval $$(call build-package-helper,$1,$2,$3)) endif +$(call profEnd, build-package($1,$2,$3)) endef @@ -60,62 +62,10 @@ # $2 = distdir # $3 = GHC stage to use (0 == bootstrapping compiler) -# We don't install things compiled by stage 0, so no need to put them -# in the bindist. -ifneq "$$(BINDIST) $3" "YES 0" - -$(call all-target,$1,all_$1_$2) -# This give us things like -# all_libraries: all_libraries/base_dist-install -ifneq "$$($1_$2_GROUP)" "" -all_$$($1_$2_GROUP): all_$1_$2 -endif - -ifneq "$$(CHECKED_$1)" "YES" -CHECKED_$1 = YES -check_packages: check_$1 -.PHONY: check_$1 -check_$1: $$(GHC_CABAL_INPLACE) - $$(GHC_CABAL_INPLACE) check $1 -endif - # --- CONFIGURATION -ifneq "$$(NO_INCLUDE_PKGDATA)" "YES" -include $1/$2/package-data.mk -endif - $(call package-config,$1,$2,$3) -ifeq "$$($1_$2_DISABLE)" "YES" - -ifeq "$$(DEBUG)" "YES" -$$(warning $1/$2 disabled) -endif - -# A package is disabled when we want to bring its package-data.mk file -# up-to-date first, or due to other build dependencies. - -$(call all-target,$1_$2,$1/$2/package-data.mk) - -ifneq "$$(BINDIST)" "YES" -# We have a rule for package-data.mk only when the package is -# disabled, because we want the build to fail if we haven't run phase 0. -$(call build-package-data,$1,$2,$3) -endif - -else - -ifneq "$$(NO_INCLUDE_PKGDATA)" "YES" -ifeq "$$($1_$2_VERSION)" "" -$$(error phase ordering error: $1/$2 is enabled, but $1/$2/package-data.mk does not exist) -endif -endif - -# Sometimes we need to modify the automatically-generated package-data.mk -# bindings in a special way for the GHC build system, so allow that here: -$($1_PACKAGE_MAGIC) - # Bootstrapping libs are only built one way ifeq "$3" "0" $1_$2_WAYS = v @@ -123,20 +73,19 @@ $1_$2_WAYS = $$(GhcLibWays) endif -$(call hs-sources,$1,$2) -$(call c-sources,$1,$2) -$(call includes-sources,$1,$2) - -# --- DEPENDENCIES - # We must use a different dependency file if $(GhcLibWays) changes, so # encode the ways into the name of the file. $1_$2_WAYS_DASHED = $$(subst $$(space),,$$(patsubst %,-%,$$(strip $$($1_$2_WAYS)))) $1_$2_depfile_base = $1/$2/build/.depend$$($1_$2_WAYS_DASHED) -$(call build-dependencies,$1,$2,$3) - -# --- BUILDING +$(call build-package-data,$1,$2,$3) +ifneq "$$(NO_INCLUDE_PKGDATA)" "YES" +ifeq "$3" "0" +include $1/$2/package-data.mk +else ifeq "$(phase)" "final" +include $1/$2/package-data.mk +endif +endif # We don't bother splitting the bootstrap packages (built with stage 0) ifeq "$$($1_$2_SplitObjs)" "" @@ -147,24 +96,45 @@ endif endif -# C and S files are possibly built the "dyn" way. -ifeq "$$(BuildSharedLibs)" "YES" -$(call c-objs,$1,$2,dyn) -$(call c-suffix-rules,$1,$2,dyn,YES) -endif +$(call hs-sources,$1,$2) +$(call c-sources,$1,$2) +$(call includes-sources,$1,$2) + +$(call dependencies,$1,$2,$3) # Now generate all the build rules for each way in this directory: $$(foreach way,$$($1_$2_WAYS),$$(eval \ $$(call c-objs,$1,$2,$$(way)) \ - $$(call c-suffix-rules,$1,$2,$$(way),YES) \ + $$(call c-suffix-rules,$1,$2,$$(way),YES) \ $$(call cmm-objs,$1,$2,$$(way)) \ $$(call cmm-suffix-rules,$1,$2,$$(way)) \ $$(call build-package-way,$1,$2,$$(way),$3) \ )) -$(call haddock,$1,$2) +# C and S files are possibly built the "dyn" way. +ifeq "$$(BuildSharedLibs)" "YES" +$(call c-objs,$1,$2,dyn) +$(call c-suffix-rules,$1,$2,dyn,YES) +endif -endif # package-data.mk exists +$(call all-target,$1,all_$1_$2) +# This give us things like +# all_libraries: all_libraries/base_dist-install +ifneq "$$($1_$2_GROUP)" "" +all_$$($1_$2_GROUP): all_$1_$2 +endif + +ifneq "$$(CHECKED_$1)" "YES" +CHECKED_$1 = YES +check_packages: check_$1 +.PHONY: check_$1 +check_$1: $$(GHC_CABAL_INPLACE) + $$(GHC_CABAL_INPLACE) check $1 +endif + +ifneq "$3" "0" +$(call haddock,$1,$2) +endif # Don't put bootstrapping packages in the bindist ifneq "$3" "0" @@ -172,7 +142,5 @@ BINDIST_EXTRAS += $$($1_$2_INSTALL_INCLUDES_SRCS) endif -endif - endef diff -Nru ghc-7.0.3/rules/build-package-way.mk ghc-7.2.1/rules/build-package-way.mk --- ghc-7.0.3/rules/build-package-way.mk 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/rules/build-package-way.mk 2011-08-07 17:10:05.000000000 +0000 @@ -13,6 +13,7 @@ define build-package-way # $1 = dir, $2 = distdir, $3 = way, $4 = stage $(call trace, build-package-way($1,$2,$3)) +$(call profStart, build-package-way($1,$2,$3)) $(call distdir-way-opts,$1,$2,$3,$4) $(call hs-suffix-rules,$1,$2,$3) @@ -39,37 +40,41 @@ # All the .a/.so library file dependencies for this library $1_$2_$3_DEPS_LIBS=$$(foreach dep,$$($1_$2_DEPS),$$($$(dep)_$2_$3_LIB)) -ifneq "$$(BootingFromHc)" "YES" -$1_$2_$3_MKSTUBOBJS = $$(FIND) $1/$2/build -name "*_stub.$$($3_osuf)" -print -# HACK ^^^ we tried to use $(wildcard), but apparently it fails due to -# make using cached directory contents, or something. -else -$1_$2_$3_MKSTUBOBJS = true +ifeq "$$(BootingFromHc)" "YES" $1_$2_$3_C_OBJS += $$(shell $$(FIND) $1/$2/build -name "*_stub.c" -print | sed 's/c$$$$/o/') endif $1_$2_$3_NON_HS_OBJS = $$($1_$2_$3_CMM_OBJS) $$($1_$2_$3_C_OBJS) $$($1_$2_$3_S_OBJS) $$($1_$2_EXTRA_OBJS) $1_$2_$3_ALL_OBJS = $$($1_$2_$3_HS_OBJS) $$($1_$2_$3_NON_HS_OBJS) +# The quadrupled $'s here are because the _v_LIB variables aren't +# necessarily set when this part of the makefile is read. +# These deps aren't technically necessary in themselves, but they +# turn the dependencies of programs on libraries into transitive +# dependencies. +ifeq "$4" "0" +$$($1_$2_$3_LIB) : $$(foreach dep,$$($1_$2_DEP_NAMES),$$$$(libraries/$$(dep)_dist-boot_v_LIB)) +else +$$($1_$2_$3_LIB) : $$(foreach dep,$$($1_$2_DEP_NAMES),$$$$(libraries/$$(dep)_dist-install_v_LIB)) +endif + ifeq "$3" "dyn" # Link a dynamic library # On windows we have to supply the extra libs this one links to when building it. ifeq "$$(HOSTPLATFORM)" "i386-unknown-mingw32" $$($1_$2_$3_LIB) : $$($1_$2_$3_ALL_OBJS) $$(ALL_RTS_LIBS) $$($1_$2_$3_DEPS_LIBS) - "$$($1_$2_HC)" $$($1_$2_$3_ALL_OBJS) \ - `$$($1_$2_$3_MKSTUBOBJS)` \ + "$$($1_$2_HC)" $$($1_$2_$3_ALL_HC_OPTS) $$($1_$2_$3_ALL_OBJS) \ -shared -dynamic -dynload deploy \ $$(addprefix -l,$$($1_$2_EXTRA_LIBRARIES)) \ - -no-auto-link-packages $$(addprefix -package ,$$($1_$2_DEPS)) \ + -no-auto-link-packages \ -o $$@ else $$($1_$2_$3_LIB) : $$($1_$2_$3_ALL_OBJS) $$(ALL_RTS_LIBS) $$($1_$2_$3_DEPS_LIBS) - "$$($1_$2_HC)" $$($1_$2_$3_ALL_OBJS) \ - `$$($1_$2_$3_MKSTUBOBJS)` \ + "$$($1_$2_HC)" $$($1_$2_$3_ALL_HC_OPTS) $$($1_$2_$3_ALL_OBJS) \ -shared -dynamic -dynload deploy \ -dylib-install-name $(ghclibdir)/`basename "$$@" | sed 's/^libHS//;s/[-]ghc.*//'`/`basename "$$@"` \ - -no-auto-link-packages $$(addprefix -package ,$$($1_$2_DEPS)) \ + -no-auto-link-packages \ -o $$@ endif else @@ -78,14 +83,14 @@ "$$(RM)" $$(RM_OPTS) $$@ $$@.contents ifeq "$$($1_$2_SplitObjs)" "YES" $$(FIND) $$(patsubst %.$$($3_osuf),%_$$($3_osuf)_split,$$($1_$2_$3_HS_OBJS)) -name '*.$$($3_osuf)' -print >> $$@.contents - echo $$($1_$2_$3_NON_HS_OBJS) `$$($1_$2_$3_MKSTUBOBJS)` >> $$@.contents + echo $$($1_$2_$3_NON_HS_OBJS) >> $$@.contents else - echo $$($1_$2_$3_ALL_OBJS) `$$($1_$2_$3_MKSTUBOBJS)` >> $$@.contents + 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 @@ -109,16 +114,16 @@ endif endif $$($1_$2_GHCI_LIB) : $$($1_$2_$3_HS_OBJS) $$($1_$2_$3_CMM_OBJS) $$($1_$2_$3_C_OBJS) $$($1_$2_$3_S_OBJS) $$($1_$2_EXTRA_OBJS) - "$$(LD)" -r -o $$@ $$(EXTRA_LD_OPTS) $$($1_$2_$3_HS_OBJS) $$($1_$2_$3_CMM_OBJS) $$($1_$2_$3_C_OBJS) $$($1_$2_$3_S_OBJS) `$$($1_$2_$3_MKSTUBOBJS)` $$($1_$2_EXTRA_OBJS) + "$$(LD)" -r -o $$@ $$(EXTRA_LD_OPTS) $$($1_$2_$3_HS_OBJS) $$($1_$2_$3_CMM_OBJS) $$($1_$2_$3_C_OBJS) $$($1_$2_$3_S_OBJS) $$($1_$2_EXTRA_OBJS) ifeq "$$($1_$2_BUILD_GHCI_LIB)" "YES" # Don't bother making ghci libs for bootstrapping packages ifneq "$4" "0" -# $$(info Here $1 $2 $$($1_$2_BUILD_GHCI_LIB) Q1) $(call all-target,$1_$2,$$($1_$2_GHCI_LIB)) endif endif endif +$(call profEnd, build-package-way($1,$2,$3)) endef diff -Nru ghc-7.0.3/rules/build-perl.mk ghc-7.2.1/rules/build-perl.mk --- ghc-7.0.3/rules/build-perl.mk 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/rules/build-perl.mk 2011-08-07 17:10:05.000000000 +0000 @@ -20,6 +20,7 @@ define build-perl $(call trace, build-perl($1,$2)) +$(call profStart, build-perl($1,$2)) # $1 = dir # $2 = distdir @@ -65,4 +66,5 @@ endif endif +$(call profEnd, build-perl($1,$2)) endef diff -Nru ghc-7.0.3/rules/build-prog.mk ghc-7.2.1/rules/build-prog.mk --- ghc-7.0.3/rules/build-prog.mk 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/rules/build-prog.mk 2011-08-07 17:10:05.000000000 +0000 @@ -21,6 +21,7 @@ define build-prog $(call trace, build-prog($1,$2,$3)) +$(call profStart, build-prog($1,$2,$3)) # $1 = dir # $2 = distdir # $3 = GHC stage to use (0 == bootstrapping compiler) @@ -40,6 +41,7 @@ ifneq "$$($1_$2_NOT_NEEDED)" "YES" $$(eval $$(call build-prog-helper,$1,$2,$3)) endif +$(call profEnd, build-prog($1,$2,$3)) endef @@ -48,57 +50,63 @@ # $2 = distdir # $3 = GHC stage to use (0 == bootstrapping compiler) -$(call all-target,$1,all_$1_$2) - ifeq "$$($1_USES_CABAL)" "YES" $1_$2_USES_CABAL = YES endif +$(call package-config,$1,$2,$3) + +$1_$2_depfile_base = $1/$2/build/.depend + +ifeq "$$($1_$2_INSTALL_INPLACE)" "NO" +ifeq "$(findstring clean,$(MAKECMDGOALS))" "" +$1_$2_INPLACE = $$(error $1_$2 should not be installed inplace, but INPLACE var evaluated) +else +$1_$2_INPLACE = +endif +else +# Where do we install the inplace version? +ifeq "$$($1_$2_SHELL_WRAPPER) $$(Windows)" "YES NO" +$1_$2_INPLACE = $$(INPLACE_LIB)/$$($1_$2_PROG) +else +ifeq "$$($1_$2_TOPDIR)" "YES" +$1_$2_INPLACE = $$(INPLACE_TOPDIR)/$$($1_$2_PROG) +else +$1_$2_INPLACE = $$(INPLACE_BIN)/$$($1_$2_PROG) +endif +endif +endif + ifeq "$$($1_$2_USES_CABAL)" "YES" +$(call build-package-data,$1,$2,$3) ifneq "$$(NO_INCLUDE_PKGDATA)" "YES" +ifeq "$3" "0" +include $1/$2/package-data.mk +else ifeq "$(phase)" "final" include $1/$2/package-data.mk endif endif - -$(call package-config,$1,$2,$3) - -ifeq "$$($1_$2_USES_CABAL)$$($1_$2_VERSION)" "YES" -$1_$2_DISABLE = YES endif -ifeq "$$($1_$2_DISABLE)" "YES" +$(call all-target,$1,all_$1_$2) +$(call all-target,$1_$2,$1/$2/build/tmp/$$($1_$2_PROG)) -ifeq "$$(DEBUG)" "YES" -$$(warning $1/$2 disabled) +# INPLACE_BIN might be empty if we're distcleaning +ifeq "$(findstring clean,$(MAKECMDGOALS))" "" +ifneq "$$($1_$2_INSTALL_INPLACE)" "NO" +$$($1_$2_INPLACE) : $1/$2/build/tmp/$$($1_$2_PROG) | $$$$(dir $$$$@)/. + "$$(CP)" -p $$< $$@ + touch $$@ endif - -# The following code to build the package all depends on settings -# obtained from package-data.mk. If we don't have package-data.mk -# yet, then don't try to do anything else with this package. Make will -# try to build package-data.mk, then restart itself and we'll be in business. - -$(call all-target,$1_$2,$1/$2/package-data.mk) - -# We have a rule for package-data.mk only when the package is -# disabled, because we want the build to fail if we haven't run phase 0. -ifneq "$$(BINDIST)" "YES" -$(call build-package-data,$1,$2,$3) endif -else +$(call shell-wrapper,$1,$2) -ifneq "$$(BINDIST)" "YES" $1_$2_WAYS = v $(call hs-sources,$1,$2) $(call c-sources,$1,$2) -# --- DEPENDENCIES - -$1_$2_depfile_base = $1/$2/build/.depend - -$(call build-dependencies,$1,$2,$3) - # --- IMPLICIT RULES # Just the 'v' way for programs @@ -131,12 +139,24 @@ $1_$2_GHC_LD_OPTS = -no-auto-link-packages -no-hs-main endif +ifneq "$$(BINDIST)" "YES" +# The quadrupled $'s here are because the _v_LIB variables aren't +# necessarily set when this part of the makefile is read +$1/$2/build/tmp/$$($1_$2_PROG) : \ + $$(foreach dep,$$($1_$2_DEP_NAMES),\ + $$(if $$(filter ghc,$$(dep)),\ + $(if $(filter 0,$3),$$(compiler_stage1_v_LIB),\ + $(if $(filter 1,$3),$$(compiler_stage2_v_LIB),\ + $(if $(filter 2,$3),$$(compiler_stage2_v_LIB),\ + $$(error Bad build stage)))),\ + $$$$(libraries/$$(dep)_dist-$(if $(filter 0,$3),boot,install)_v_LIB))) + ifeq "$$($1_$2_LINK_WITH_GCC)" "NO" $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 $$$$@)/. "$$($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 @@ -155,34 +175,10 @@ endif endif -ifeq "$$($1_$2_INSTALL_INPLACE)" "NO" -$(call all-target,$1_$2,$1/$2/build/tmp/$$($1_$2_PROG)) -else -# Where do we install the inplace version? -ifeq "$$($1_$2_SHELL_WRAPPER) $$(Windows)" "YES NO" -$1_$2_INPLACE = $$(INPLACE_LIB)/$$($1_$2_PROG) -else -ifeq "$$($1_$2_TOPDIR)" "YES" -$1_$2_INPLACE = $$(INPLACE_TOPDIR)/$$($1_$2_PROG) -else -$1_$2_INPLACE = $$(INPLACE_BIN)/$$($1_$2_PROG) -endif -endif - +ifneq "$$($1_$2_INSTALL_INPLACE)" "NO" $(call all-target,$1_$2,$$($1_$2_INPLACE)) -$(call clean-target,$1,$2_inplace,$$($1_$2_INPLACE)) - -# INPLACE_BIN might be empty if we're distcleaning -ifeq "$(findstring clean,$(MAKECMDGOALS))" "" -$$($1_$2_INPLACE) : $1/$2/build/tmp/$$($1_$2_PROG) | $$$$(dir $$$$@)/. - "$$(CP)" -p $$< $$@ - touch $$@ endif - -# touch is necessary; cp doesn't update the file time. -endif - -$(call shell-wrapper,$1,$2) +$(call clean-target,$1,$2_inplace,$$($1_$2_INPLACE)) ifeq "$$($1_$2_INSTALL)" "YES" ifeq "$$($1_$2_TOPDIR)" "YES" @@ -192,6 +188,6 @@ endif endif -endif # package-data.mk exists +$(call dependencies,$1,$2,$3) endef diff -Nru ghc-7.0.3/rules/cmm-suffix-rules.mk ghc-7.2.1/rules/cmm-suffix-rules.mk --- ghc-7.0.3/rules/cmm-suffix-rules.mk 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/rules/cmm-suffix-rules.mk 2011-08-07 17:10:05.000000000 +0000 @@ -22,16 +22,16 @@ ifneq "$$(BootingFromHc)" "YES" -$1/$2/build/%.$$($3_way_)o : $1/%.cmm $$(rts_H_FILES) $$($1_$2_HC_DEP) | $$$$(dir $$$$@)/. +$1/$2/build/%.$$($3_way_)o : $1/%.cmm $$(rts_H_FILES) $$(includes_H_FILES) $$($1_$2_HC_DEP) | $$$$(dir $$$$@)/. "$$($1_$2_HC)" $$($1_$2_$3_MOST_HC_OPTS) -c $$< -o $$@ -$1/$2/build/%.$$($3_way_)o : $1/$2/build/%.cmm $$(rts_H_FILES) $$($1_$2_HC_DEP) | $$$$(dir $$$$@)/. +$1/$2/build/%.$$($3_way_)o : $1/$2/build/%.cmm $$(rts_H_FILES) $$(includes_H_FILES) $$($1_$2_HC_DEP) | $$$$(dir $$$$@)/. "$$($1_$2_HC)" $$($1_$2_$3_MOST_HC_OPTS) -c $$< -o $$@ -$1/$2/build/%.$$($3_way_)hc : $1/%.cmm $$(rts_H_FILES) $$($1_$2_HC_DEP) | $$$$(dir $$$$@)/. +$1/$2/build/%.$$($3_way_)hc : $1/%.cmm $$(rts_H_FILES) $$(includes_H_FILES) $$($1_$2_HC_DEP) | $$$$(dir $$$$@)/. "$$($1_$2_HC)" $$($1_$2_$3_MOST_HC_OPTS) -C $$< -o $$@ -$1/$2/build/%.$$($3_way_)hc : $1/$2/build/%.cmm $$(rts_H_FILES) $$($1_$2_HC_DEP) | $$$$(dir $$$$@)/. +$1/$2/build/%.$$($3_way_)hc : $1/$2/build/%.cmm $$(rts_H_FILES) $$(includes_H_FILES) $$($1_$2_HC_DEP) | $$$$(dir $$$$@)/. "$$($1_$2_HC)" $$($1_$2_$3_MOST_HC_OPTS) -C $$< -o $$@ # XXX @@ -42,10 +42,10 @@ # so for now they're commented out. They aren't needed, as we can always # go directly to .o files. # -# $1/$2/build/%.$$($3_way_)s : $1/%.cmm $$(rts_H_FILES) $$($1_$2_HC_DEP) | $$$$(dir $$$$@)/. +# $1/$2/build/%.$$($3_way_)s : $1/%.cmm $$(rts_H_FILES) $$(includes_H_FILES) $$($1_$2_HC_DEP) | $$$$(dir $$$$@)/. # "$$($1_$2_HC)" $$($1_$2_$3_MOST_HC_OPTS) -S $$< -o $$@ # -# $1/$2/build/%.$$($3_way_)s : $1/$2/build/%.cmm $$(rts_H_FILES) $$($1_$2_HC_DEP) | $$$$(dir $$$$@)/. +# $1/$2/build/%.$$($3_way_)s : $1/$2/build/%.cmm $$(rts_H_FILES) $$(includes_H_FILES) $$($1_$2_HC_DEP) | $$$$(dir $$$$@)/. # "$$($1_$2_HC)" $$($1_$2_$3_MOST_HC_OPTS) -S $$< -o $$@ endif diff -Nru ghc-7.0.3/rules/c-suffix-rules.mk ghc-7.2.1/rules/c-suffix-rules.mk --- ghc-7.0.3/rules/c-suffix-rules.mk 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/rules/c-suffix-rules.mk 2011-08-07 17:10:05.000000000 +0000 @@ -17,6 +17,8 @@ # $3 = way # $4 = use GHC (YES/NO) +ifneq "$$(BINDIST)" "YES" + # UseGhcForCc is only relevant when not booting from HC files. ifeq "$4 $$(BootingFromHc)" "YES NO" @@ -41,19 +43,21 @@ 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_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 endif diff -Nru ghc-7.0.3/rules/dependencies.mk ghc-7.2.1/rules/dependencies.mk --- ghc-7.0.3/rules/dependencies.mk 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/rules/dependencies.mk 2011-08-07 17:10:05.000000000 +0000 @@ -0,0 +1,38 @@ +# ----------------------------------------------------------------------------- +# +# (c) 2009 The University of Glasgow +# +# This file is part of the GHC build system. +# +# To understand how the build system works and how to modify it, see +# http://hackage.haskell.org/trac/ghc/wiki/Building/Architecture +# http://hackage.haskell.org/trac/ghc/wiki/Building/Modifying +# +# ----------------------------------------------------------------------------- + +define dependencies +$(call trace, dependencies($1,$2,$3)) +$(call profStart, dependencies($1,$2,$3)) +# $1 = dir +# $2 = distdir +# $3 = GHC stage to use (0 == bootstrapping compiler) + +# We always have the dependency rules available, as we need to know +# how to build hsc2hs's dependency file in phase 0 +$(call build-dependencies,$1,$2,$3) + +ifneq "$(phase)" "0" +# From phase 1 we actually include the dependency files for the +# bootstrapping stuff +ifeq "$3" "0" +$(call include-dependencies,$1,$2,$3) +else ifeq "$(phase)" "final" +# In the final phase, we also include the dependency files for +# everything else +$(call include-dependencies,$1,$2,$3) +endif +endif + +$(call profEnd, dependencies($1,$2,$3)) +endef + diff -Nru ghc-7.0.3/rules/distdir-way-opts.mk ghc-7.2.1/rules/distdir-way-opts.mk --- ghc-7.0.3/rules/distdir-way-opts.mk 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/rules/distdir-way-opts.mk 2011-08-07 17:10:05.000000000 +0000 @@ -17,14 +17,17 @@ # 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) -# - libraries/base_HC_OPTS options from libraries/base for all ways +# (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 +# system for libraries/base for all ways # - 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 @@ -48,6 +51,7 @@ $$(foreach pkg,$$($1_$2_DEPS),-package $$(pkg)) \ $$(if $$(findstring YES,$$($1_$2_SplitObjs)),$$(if $$(findstring dyn,$3),,-split-objs),) \ $$($1_$2_HC_OPTS) \ + $$($1_$2_MORE_HC_OPTS) \ $$($1_$2_EXTRA_HC_OPTS) \ $$($1_$2_$3_HC_OPTS) \ $$($$(basename $$<)_HC_OPTS) \ @@ -75,10 +79,8 @@ $1_$2_DEP_INCLUDE_DIRS_FLAG = -I endif -# We have to do this mangling using the shell, because words may contain -# spaces and GNU make doesn't have any quoting interpretation. -ifneq ($$(strip $$($1_$2_DEP_INCLUDE_DIRS)),) -$1_$2_CC_INC_FLAGS:=$$(shell for i in $$($1_$2_DEP_INCLUDE_DIRS); do echo $$($1_$2_DEP_INCLUDE_DIRS_FLAG)\"$$$$i\"; done) +ifneq ($$(strip $$($1_$2_DEP_INCLUDE_DIRS_SINGLE_QUOTED)),) +$1_$2_CC_INC_FLAGS := $$(subst $$(space)',$$(space)$$($1_$2_DEP_INCLUDE_DIRS_FLAG)',$$(space)$$($1_$2_DEP_INCLUDE_DIRS_SINGLE_QUOTED)) endif # The CONF_CC_OPTS_STAGE$4 options are what we use to get gcc to @@ -100,8 +102,8 @@ $$($1_$2_CC_INC_FLAGS) \ $$($1_$2_DEP_CC_OPTS) -ifneq ($$(strip $$($1_$2_DEP_LIB_DIRS)),) -$1_$2_DIST_LD_LIB_DIRS:=$$(shell for i in $$($1_$2_DEP_LIB_DIRS); do echo \"-L$$$$i\"; done) +ifneq ($$(strip $$($1_$2_DEP_LIB_DIRS_SINGLE_QUOTED)),) +$1_$2_DIST_LD_LIB_DIRS := $$(subst $$(space)',$$(space)-L',$$(space)$$($1_$2_DEP_LIB_DIRS_SINGLE_QUOTED)) endif $1_$2_DIST_LD_OPTS = \ @@ -132,6 +134,8 @@ --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 -Nru ghc-7.0.3/rules/docbook.mk ghc-7.2.1/rules/docbook.mk --- ghc-7.0.3/rules/docbook.mk 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/rules/docbook.mk 2011-08-07 17:10:05.000000000 +0000 @@ -15,6 +15,7 @@ define docbook $(call trace, docbook($1,$2)) +$(call profStart, docbook($1,$2)) # $1 = dir # $2 = docname @@ -25,10 +26,12 @@ .PHONY: html_$1 +ifeq "$$(phase)" "final" ifeq "$$(BUILD_DOCBOOK_HTML)" "YES" $(call all-target,$1,html_$1) INSTALL_HTML_DOC_DIRS += $1/$2 endif +endif html_$1 : $1/$2/index.html @@ -47,10 +50,12 @@ .PHONY: ps_$1 +ifeq "$$(phase)" "final" ifeq "$$(BUILD_DOCBOOK_PS)" "YES" $(call all-target,$1,ps_$1) INSTALL_DOCS += $1/$2.ps endif +endif ps_$1 : $1/$2.ps @@ -60,10 +65,12 @@ [ -f $$@ ] endif +ifeq "$$(phase)" "final" ifeq "$$(BUILD_DOCBOOK_PDF)" "YES" $(call all-target,$1,pdf_$1) INSTALL_DOCS += $1/$2.pdf endif +endif .PHONY: pdf_$1 pdf_$1 : $1/$2.pdf @@ -74,5 +81,6 @@ [ -f $$@ ] endif +$(call profEnd, docbook($1,$2)) endef diff -Nru ghc-7.0.3/rules/extra-packages.mk ghc-7.2.1/rules/extra-packages.mk --- ghc-7.0.3/rules/extra-packages.mk 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/rules/extra-packages.mk 2011-08-07 17:10:05.000000000 +0000 @@ -27,9 +27,13 @@ # add P to the list of packages define extra-packages -$$(foreach p,$$(patsubst libraries/%,%,$$(wildcard $$(shell grep '^[^ #][^ ]* \+\(dph\|extra\) \+[^ ]\+ \+[^ ]\+ \+[^ ]\+' packages | sed 's/ .*//'))),\ + +# Collects some dirs containing ghc.mk files that we need to include: +BUILD_DIRS_EXTRA= + +$$(foreach p,$$(patsubst libraries/%,%,$$(wildcard $$(shell grep '^[^ #][^ ]* \+\(dph\|extra\) \+[^ ]\+ \+[^ ]\+$$$$' packages | sed 's/ .*//'))),\ $$(if $$(wildcard libraries/$$p/ghc-packages),\ - $$(eval BUILD_DIRS += libraries/$$p) \ + $$(eval BUILD_DIRS_EXTRA += libraries/$$p) \ $$(foreach q,$$(shell cat libraries/$$p/ghc-packages2),$$(eval $$(call extra-package,$$p,$$p/$$q))),\ $$(eval $$(call extra-package,$$p,$$p)))\ ) diff -Nru ghc-7.0.3/rules/haddock.mk ghc-7.2.1/rules/haddock.mk --- ghc-7.0.3/rules/haddock.mk 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/rules/haddock.mk 2011-08-07 17:10:05.000000000 +0000 @@ -13,6 +13,7 @@ define haddock # args: $1 = dir, $2 = distdir $(call trace, haddock($1,$2)) +$(call profStart, haddock($1,$2)) ifneq "$$($1_$2_DO_HADDOCK)" "NO" @@ -71,5 +72,6 @@ endif +$(call profEnd, haddock($1,$2)) endef diff -Nru ghc-7.0.3/rules/hs-suffix-rules.mk ghc-7.2.1/rules/hs-suffix-rules.mk --- ghc-7.0.3/rules/hs-suffix-rules.mk 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/rules/hs-suffix-rules.mk 2011-08-07 17:10:05.000000000 +0000 @@ -13,6 +13,7 @@ define hs-suffix-rules # args: $1 = dir, $2 = distdir, $3 = way +ifneq "$$(BINDIST)" "YES" ifneq "$$(BootingFromHc)" "YES" $1/$2/build/%.$$($3_hcsuf) : $1/$2/build/%.hs $$($1_$2_HC_DEP) @@ -28,6 +29,7 @@ "$$($1_$2_HC)" $$($1_$2_$3_ALL_HC_OPTS) -c $$< -o $$@ endif +endif endef # hs-suffix-rules diff -Nru ghc-7.0.3/rules/hs-suffix-rules-srcdir.mk ghc-7.2.1/rules/hs-suffix-rules-srcdir.mk --- ghc-7.0.3/rules/hs-suffix-rules-srcdir.mk 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/rules/hs-suffix-rules-srcdir.mk 2011-08-07 17:10:05.000000000 +0000 @@ -16,6 +16,8 @@ # Preprocessing Haskell source +ifneq "$$(BINDIST)" "YES" + ifneq "$$(BootingFromHc)" "YES" $1/$2/build/%.hs : $1/$4/%.ly | $$$$(dir $$$$@)/. @@ -50,10 +52,10 @@ # .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 $$@ @@ -85,5 +87,7 @@ @: endif +endif + endef diff -Nru ghc-7.0.3/rules/include-dependencies.mk ghc-7.2.1/rules/include-dependencies.mk --- ghc-7.0.3/rules/include-dependencies.mk 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/rules/include-dependencies.mk 2011-08-07 17:10:05.000000000 +0000 @@ -0,0 +1,45 @@ +# ----------------------------------------------------------------------------- +# +# (c) 2009 The University of Glasgow +# +# This file is part of the GHC build system. +# +# To understand how the build system works and how to modify it, see +# http://hackage.haskell.org/trac/ghc/wiki/Building/Architecture +# http://hackage.haskell.org/trac/ghc/wiki/Building/Modifying +# +# ----------------------------------------------------------------------------- + +define include-dependencies +$(call trace, include-dependencies($1,$2,$3)) +$(call profStart, include-dependencies($1,$2,$3)) +# $1 = dir +# $2 = distdir +# $3 = GHC stage to use (0 == bootstrapping compiler) + +$1_$2_INCLUDE_DEPFILES = YES +ifeq "$$(NO_INCLUDE_DEPS)" "YES" +$1_$2_INCLUDE_DEPFILES = NO +endif +ifneq "$$(ONLY_DEPS_FOR)" "" +ifeq "$$(filter $1_$2,$$(ONLY_DEPS_FOR))" "" +$1_$2_INCLUDE_DEPFILES = NO +endif +endif + +ifeq "$$($1_$2_INCLUDE_DEPFILES)" "YES" +ifneq "$$(strip $$($1_$2_HS_SRCS) $$($1_$2_HS_BOOT_SRCS))" "" +ifneq "$$(NO_STAGE$3_DEPS)" "YES" +include $$($1_$2_depfile_haskell) +endif +endif +include $$($1_$2_depfile_c_asm) +else +ifeq "$$(DEBUG)" "YES" +$$(warning not building dependencies in $1) +endif +endif + +$(call profEnd, include-dependencies($1,$2,$3)) +endef + diff -Nru ghc-7.0.3/rules/manual-package-config.mk ghc-7.2.1/rules/manual-package-config.mk --- ghc-7.0.3/rules/manual-package-config.mk 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/rules/manual-package-config.mk 2011-08-07 17:10:05.000000000 +0000 @@ -13,6 +13,7 @@ define manual-package-config # args: $1 = dir $(call trace, manual-package-config($1)) +$(call profStart, manual-package-config($1)) $1/package.conf.inplace : $1/package.conf.in $(GHC_PKG_INPLACE) $$(CPP) $$(RAWCPP_FLAGS) -P \ @@ -42,4 +43,5 @@ clean_$1_package.conf : "$$(RM)" $$(RM_OPTS) $1/package.conf.install $1/package.conf.inplace +$(call profEnd, manual-package-config($1)) endef diff -Nru ghc-7.0.3/rules/package-config.mk ghc-7.2.1/rules/package-config.mk --- ghc-7.0.3/rules/package-config.mk 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/rules/package-config.mk 2011-08-07 17:10:05.000000000 +0000 @@ -13,13 +13,18 @@ define package-config # args: $1 = dir, $2 = distdir, $3 = GHC stage $(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_AS = $$(AS_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" -$1_$2_ghc_ge_6102 = $$(ghc_ge_6102) -$1_$2_ghc_ge_611 = $$(ghc_ge_611) $1_$2_ghc_ge_613 = $$(ghc_ge_613) $1_$2_HC_CONFIG = $$(GHC_STAGE0) $1_$2_HC_CONFIG_DEP = @@ -33,17 +38,15 @@ $1_$2_HC_PKGCONF = -package-conf $$(BOOTSTRAPPING_CONF) $1_$2_GHC_PKG_OPTS = --package-conf=$$(BOOTSTRAPPING_CONF) $1_$2_CONFIGURE_OPTS += --package-db=$$(TOP)/$$(BOOTSTRAPPING_CONF) -$1_$2_HC_OPTS += -no-user-package-conf +$1_$2_MORE_HC_OPTS += -no-user-package-conf ifeq "$(ghc_ge_613)" "YES" -$1_$2_HC_OPTS += -rtsopts +$1_$2_MORE_HC_OPTS += -rtsopts endif else -$1_$2_ghc_ge_6102 = YES -$1_$2_ghc_ge_611 = YES $1_$2_ghc_ge_613 = YES $1_$2_HC_PKGCONF = -$1_$2_HC_CONFIG = $$(TOP)/$$(DUMMY_GHC_INPLACE) -$1_$2_HC_CONFIG_DEP = $$(DUMMY_GHC_INPLACE) +$1_$2_HC_CONFIG = $$(TOP)/$$(GHC_STAGE1) +$1_$2_HC_CONFIG_DEP = $$(GHC_STAGE1) $1_$2_GHC_PKG = $$(TOP)/$$(GHC_PKG_INPLACE) $1_$2_GHC_PKG_DEP = $$(GHC_PKG_INPLACE) $1_$2_GHC_PKG_OPTS = @@ -52,11 +55,12 @@ $1_$2_HC_MK_DEPEND = $$(GHC_STAGE1) $1_$2_HC_MK_DEPEND_DEP = $$($1_$2_HC_MK_DEPEND) $1_$2_HC_DEP = $$($1_$2_HC) -$1_$2_HC_OPTS += -no-user-package-conf -$1_$2_HC_OPTS += -rtsopts +$1_$2_MORE_HC_OPTS += -no-user-package-conf +$1_$2_MORE_HC_OPTS += -rtsopts endif # Useful later $1_$2_SLASH_MODS = $$(subst .,/,$$($1_$2_MODULES)) +$(call profEnd, package-config($1,$2,$3)) endef diff -Nru ghc-7.0.3/rules/prof.mk ghc-7.2.1/rules/prof.mk --- ghc-7.0.3/rules/prof.mk 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/rules/prof.mk 2011-08-07 17:10:05.000000000 +0000 @@ -0,0 +1,20 @@ +# ----------------------------------------------------------------------------- +# +# (c) 2010 The University of Glasgow +# +# This file is part of the GHC build system. +# +# To understand how the build system works and how to modify it, see +# http://hackage.haskell.org/trac/ghc/wiki/Building/Architecture +# http://hackage.haskell.org/trac/ghc/wiki/Building/Modifying +# +# ----------------------------------------------------------------------------- + +define profStart +$$(if $(PROF),$$(info $$(shell date +%s.%N): Start $1)) +endef + +define profEnd +$$(if $(PROF),$$(info $$(shell date +%s.%N): End $1)) +endef + diff -Nru ghc-7.0.3/rules/shell-wrapper.mk ghc-7.2.1/rules/shell-wrapper.mk --- ghc-7.0.3/rules/shell-wrapper.mk 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/rules/shell-wrapper.mk 2011-08-07 17:10:05.000000000 +0000 @@ -12,6 +12,7 @@ define shell-wrapper $(call trace, shell-wrapper($1,$2)) +$(call profStart, shell-wrapper($1,$2)) # $1 = dir # $2 = distdir @@ -73,7 +74,6 @@ echo 'datadir="$$(datadir)"' >> "$$(WRAPPER)" echo 'bindir="$$(bindir)"' >> "$$(WRAPPER)" echo 'topdir="$$(topdir)"' >> "$$(WRAPPER)" - echo 'pgmgcc="$$(WhatGccIsCalled)"' >> "$$(WRAPPER)" $$($1_$2_SHELL_WRAPPER_EXTRA) $$($1_$2_INSTALL_SHELL_WRAPPER_EXTRA) cat $$($1_$2_SHELL_WRAPPER_NAME) >> "$$(WRAPPER)" @@ -85,4 +85,5 @@ endif # $1_$2_SHELL_WRAPPER +$(call profEnd, shell-wrapper($1,$2)) endef diff -Nru ghc-7.0.3/rules/tags-package.mk ghc-7.2.1/rules/tags-package.mk --- ghc-7.0.3/rules/tags-package.mk 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/rules/tags-package.mk 2011-08-07 17:10:05.000000000 +0000 @@ -19,6 +19,7 @@ define tags-package $(call trace, tags-package($1,$2)) +$(call profStart, tags-package($1,$2)) # $1 = dir # $2 = distdir @@ -30,5 +31,6 @@ TAGS_$1: inplace/bin/ghctags --topdir $$(TOP)/inplace/lib -e --use-cabal-config $1/$2 -- $$($1_$2_TAGS_HC_OPTS) $$($1_$2_v_ALL_HC_OPTS) -- $$($1_$2_HS_SRCS) +$(call profEnd, tags-package($1,$2)) endef diff -Nru ghc-7.0.3/settings.in ghc-7.2.1/settings.in --- ghc-7.0.3/settings.in 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/settings.in 2011-08-07 17:10:05.000000000 +0000 @@ -0,0 +1,11 @@ +[("GCC extra via C opts", "@GccExtraViaCOpts@"), + ("C compiler command", "@SettingsCCompilerCommand@"), + ("C compiler flags", "@SettingsCCompilerFlags@"), + ("ar command", "@ArCmd@"), + ("ar flags", "@ArArgs@"), + ("ar supports at file", "@ArSupportsAtFile@"), + ("touch command", "@SettingsTouchCommand@"), + ("dllwrap command", "@SettingsDllWrapCommand@"), + ("windres command", "@SettingsWindresCommand@"), + ("perl command", "@SettingsPerlCommand@")] + diff -Nru ghc-7.0.3/utils/checkUniques/checkUniques.hs ghc-7.2.1/utils/checkUniques/checkUniques.hs --- ghc-7.0.3/utils/checkUniques/checkUniques.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/utils/checkUniques/checkUniques.hs 2011-08-07 17:10:05.000000000 +0000 @@ -0,0 +1,115 @@ +{-# LANGUAGE PatternGuards #-} + +-- Some things could be improved, e.g.: +-- * Check that each file given contains at least one instance of the +-- function +-- * Check that we are testing all functions +-- * If a problem is found, give better location information, e.g. +-- which problem the file is in + +module Main (main) where + +import Control.Concurrent +import Control.Exception +import Control.Monad +import Control.Monad.State +import Data.Char +import Data.Set (Set) +import qualified Data.Set as Set +import System.Environment +import System.Exit +import System.IO +import System.Process + +main :: IO () +main = do args <- getArgs + case args of + function : files -> + doit function files + +die :: String -> IO a +die err = do hPutStrLn stderr err + exitFailure + +type M = StateT St IO + +data St = St { + stSeen :: Set Int, + stLast :: Maybe Int, + stHadAProblem :: Bool + } + +emptyState :: St +emptyState = St { + stSeen = Set.empty, + stLast = Nothing, + stHadAProblem = False + } + +use :: Int -> M () +use n = do st <- get + let seen = stSeen st + put $ st { stSeen = Set.insert n seen, stLast = Just n } + if (n `Set.member` seen) + then problem ("Duplicate " ++ show n) + else case stLast st of + Just l + | (l > n) -> + problem ("Decreasing order for " ++ show l + ++ " -> " ++ show n) + _ -> + return () + +problem :: String -> M () +problem str = do lift $ putStrLn str + st <- get + put $ st { stHadAProblem = True } + +doit :: String -> [FilePath] -> IO () +doit function files + = do (hIn, hOut, hErr, ph) <- runInteractiveProcess + "grep" ("-h" : function : files) + Nothing Nothing + hClose hIn + strOut <- hGetContents hOut + strErr <- hGetContents hErr + forkIO $ do evaluate (length strOut) + return () + forkIO $ do evaluate (length strErr) + return () + ec <- waitForProcess ph + case (ec, strErr) of + (ExitSuccess, "") -> + check function strOut + _ -> + error "grep failed" + +check :: String -> String -> IO () +check function str + = do let ls = lines str + -- filter out lines that start with whitespace. They're + -- from things like: + -- import M ( ..., + -- ..., , ... + ls' = filter (not . all isSpace . take 1) ls + ns <- mapM (parseLine function) ls' + st <- execStateT (do mapM_ use ns + st <- get + when (Set.null (stSeen st)) $ + problem "No values found") + emptyState + when (stHadAProblem st) exitFailure + +parseLine :: String -> String -> IO Int +parseLine function str + = -- words isn't necessarily quite right, e.g. we could have + -- "var=" rather than "var =", but it works for the code + -- we have + case words str of + _var : "=" : fun : numStr : rest + | fun == function, + null rest || "--" == head rest, + [(num, "")] <- reads numStr + -> return num + _ -> error ("Bad line: " ++ show str) + diff -Nru ghc-7.0.3/utils/checkUniques/Makefile ghc-7.2.1/utils/checkUniques/Makefile --- ghc-7.0.3/utils/checkUniques/Makefile 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/utils/checkUniques/Makefile 2011-08-07 17:10:05.000000000 +0000 @@ -0,0 +1,16 @@ + +GHC = ghc + +PREL_NAMES = ../../compiler/prelude/PrelNames.lhs +DS_META = ../../compiler/deSugar/DsMeta.hs + +.PHONY: check + +check: checkUniques + ./checkUniques mkPreludeClassUnique $(PREL_NAMES) + ./checkUniques mkPreludeTyConUnique $(PREL_NAMES) $(DS_META) + ./checkUniques mkPreludeDataConUnique $(PREL_NAMES) + ./checkUniques mkPreludeMiscIdUnique $(PREL_NAMES) $(DS_META) + +checkUniques: checkUniques.hs + $(GHC) --make $@ diff -Nru ghc-7.0.3/utils/compare_sizes/ghc.mk ghc-7.2.1/utils/compare_sizes/ghc.mk --- ghc-7.0.3/utils/compare_sizes/ghc.mk 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/utils/compare_sizes/ghc.mk 2011-08-07 17:10:05.000000000 +0000 @@ -2,7 +2,7 @@ utils/compare_sizes_USES_CABAL = YES utils/compare_sizes_PACKAGE = compareSizes utils/compare_sizes_MODULES = Main -utils/compare_sizes_dist_PROG = compareSizes$(exeext) +utils/compare_sizes_dist-install_PROG = compareSizes$(exeext) -$(eval $(call build-prog,utils/compare_sizes,dist,1)) +$(eval $(call build-prog,utils/compare_sizes,dist-install,1)) diff -Nru ghc-7.0.3/utils/dummy-ghc/ghc.mk ghc-7.2.1/utils/dummy-ghc/ghc.mk --- ghc-7.0.3/utils/dummy-ghc/ghc.mk 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/utils/dummy-ghc/ghc.mk 1970-01-01 00:00:00.000000000 +0000 @@ -1,58 +0,0 @@ -# ----------------------------------------------------------------------------- -# -# (c) 2009 The University of Glasgow -# -# This file is part of the GHC build system. -# -# To understand how the build system works and how to modify it, see -# http://hackage.haskell.org/trac/ghc/wiki/Building/Architecture -# http://hackage.haskell.org/trac/ghc/wiki/Building/Modifying -# -# ----------------------------------------------------------------------------- - -# dummy-ghc - -# This is a tiny program to fool Cabal's configure that we have a -# stage1 GHC, which lets us configure all the packages before we've -# build stage1. - -utils/dummy-ghc_dist-dummy-ghc_MODULES = dummy-ghc -utils/dummy-ghc_dist-dummy-ghc_PROG = dummy-ghc$(exeext) - -# depend on project.mk, so we pick up the new version number if it changes. -utils/dummy-ghc/dist-dummy-ghc/build/dummy-ghc.hs : utils/dummy-ghc/ghc.mk $(MKDIRHIER) mk/project.mk compiler/main/DynFlags.hs - "$(MKDIRHIER)" $(dir $@) - "$(RM)" $(RM_OPTS) $@ - echo 'import System.Environment' >> $@ - echo 'import System.Cmd' >> $@ - echo 'import System.Exit' >> $@ - echo 'main :: IO ()' >> $@ - echo 'main = do args <- getArgs' >> $@ - echo ' case args of' >> $@ - echo ' ["--numeric-version"] ->' >> $@ - echo ' putStrLn "$(ProjectVersion)"' >> $@ - echo ' ["--supported-languages"] ->' >> $@ - echo ' mapM_ putStrLn extensions' >> $@ - echo ' _ ->' >> $@ - echo ' do e <- rawSystem "$(GHC_STAGE0)" args' >> $@ - echo ' exitWith e' >> $@ -# This unpleasant sed script grabs the lines between the -# xFlags :: -# line and the -# ] -# line of compiler/main/DynFlags.hs, and if they look like -# ( "PostfixOperators", ... -# then it translates them into -# ["PostfixOperators", "NoPostfixOperators"] ++ -# Tabs are a pain to handle portably with sed, so rather than worrying -# about them we just use tr to remove them all before we start. - echo 'extensions :: [String]' >> $@ - echo 'extensions =' >> $@ - '$(TR)' -d '\t' < compiler/main/DynFlags.hs | '$(SED)' '/^xFlags/,/]/s/^ *( *"\([^"]*\)"[^"]*/ ["\1", "No\1"] ++/p;d' >> $@ - echo ' []' >> $@ - -# We don't build dummy-ghc with Cabal, so we need to pass -package -# flags manually -utils/dummy-ghc_dist-dummy-ghc_HC_OPTS = -package process -$(eval $(call build-prog,utils/dummy-ghc,dist-dummy-ghc,0)) - diff -Nru ghc-7.0.3/utils/fingerprint/fingerprint.py ghc-7.2.1/utils/fingerprint/fingerprint.py --- ghc-7.0.3/utils/fingerprint/fingerprint.py 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/utils/fingerprint/fingerprint.py 2011-08-07 17:10:05.000000000 +0000 @@ -0,0 +1,248 @@ +#! /usr/bin/env python +# Script to create and restore a git fingerprint of the ghc repositories. + +from datetime import datetime +from optparse import OptionParser +import os +import os.path +import re +import subprocess +from subprocess import PIPE, Popen +import sys + +def main(): + opts, args = parseopts(sys.argv[1:]) + opts.action(opts) + +def create_action(opts): + """Action called for the create commmand""" + if opts.fpfile: + fp = FingerPrint.read(opts.source) + else: + fp = fingerprint(opts.source) + if len(fp) == 0: + error("Got empty fingerprint from source: "+str(opts.source)) + if opts.output_file: + print "Writing fingerprint to: ", opts.output_file + fp.write(opts.output) + +def restore_action(opts): + """Action called for the restore commmand""" + def branch_name(filename): + return "fingerprint_" + os.path.basename(filename).replace(".", "_") + if opts.fpfile: + try: + fp = FingerPrint.read(opts.source) + bn = branch_name(opts.fpfile) + except MalformedFingerPrintError: + error("Error parsing fingerprint file: "+opts.fpfile) + if len(fp) == 0: + error("No fingerprint found in fingerprint file: "+opts.fpfile) + elif opts.logfile: + fp = fingerprint(opts.source) + bn = branch_name(opts.logfile) + if len(fp) == 0: + error("No fingerprint found in build log file: "+opts.logfile) + else: + error("Must restore from fingerprint or log file") + restore(fp, branch_name=bn if opts.branch else None) + +def fingerprint(source=None): + """Create a new fingerprint of current repositories. + + The source argument is parsed to look for the expected output + from a `sync-all` command. If the source is `None` then the + `sync-all` command will be run to get the current fingerprint. + """ + if source is None: + sync_all = ["./sync-all", "log", "HEAD^..", "--pretty=oneline"] + source = Popen(sync_all, stdout=PIPE).stdout + + lib = "" + commits = {} + for line in source.readlines(): + if line.startswith("=="): + lib = line.split()[1].rstrip(":") + lib = "." if lib == "running" else lib # hack for top ghc repo + elif re.match("[abcdef0-9]{40}", line): + commit = line[:40] + commits[lib] = commit + return FingerPrint(commits) + +def restore(fp, branch_name=None): + """Restore the ghc repos to the commits in the fingerprint + + This function performs a checkout of each commit specifed in + the fingerprint. If `branch_name` is not None then a new branch + will be created for the top ghc repository. We also add an entry + to the git config that sets the remote for the new branch as `origin` + so that the `sync-all` command can be used from the branch. + """ + checkout = ["git", "checkout"] + + # run checkout in all subdirs + for (subdir, commit) in fp: + if subdir != ".": + cmd = checkout + [commit] + print "==", subdir, " ".join(cmd) + if os.path.exists(subdir): + rc = subprocess.call(cmd, cwd=subdir) + if rc != 0: + error("Too many errors, aborting") + else: + sys.stderr.write("WARNING: "+ + subdir+" is in fingerprint but missing in working directory\n") + + # special handling for top ghc repo + # if we are creating a new branch then also add an entry to the + # git config so the sync-all command is happy + branch_args = ["-b", branch_name] if branch_name else [] + rc = subprocess.call(checkout + branch_args + [fp["."]]) + if (rc == 0) and branch_name: + branch_config = "branch."+branch_name+".remote" + subprocess.call(["git", "config", "--add", branch_config, "origin"]) + +actions = {"create" : create_action, "restore" : restore_action} +def parseopts(argv): + """Parse and check the validity of the command line arguments""" + usage = "fingerprint ("+"|".join(sorted(actions.keys()))+") [options]" + parser = OptionParser(usage=usage) + + parser.add_option("-d", "--dir", dest="dir", + help="write output to directory DIR", metavar="DIR") + + parser.add_option("-o", "--output", dest="output", + help="write output to file FILE", metavar="FILE") + + parser.add_option("-l", "--from-log", dest="logfile", + help="reconstruct fingerprint from build log", metavar="FILE") + + parser.add_option("-f", "--from-fp", dest="fpfile", + help="reconstruct fingerprint from fingerprint file", metavar="FILE") + + parser.add_option("-n", "--no-branch", + action="store_false", dest="branch", default=True, + help="do not create a new branch when restoring fingerprint") + + parser.add_option("-g", "--ghc-dir", dest="ghcdir", + help="perform actions in GHC dir", metavar="DIR") + + opts,args = parser.parse_args(argv) + return (validate(opts, args, parser), args) + +def validate(opts, args, parser): + """ Validate and prepare the command line options. + + It performs the following actions: + * Check that we have a valid action to perform + * Check that we have a valid output destination + * Opens the output file if needed + * Opens the input file if needed + """ + # Determine the action + try: + opts.action = actions[args[0]] + except (IndexError, KeyError): + error("Must specify a valid action", parser) + + # Inputs + if opts.logfile and opts.fpfile: + error("Must specify only one of -l and -f") + + opts.source = None + if opts.logfile: + opts.source = file(opts.logfile, "r") + elif opts.fpfile: + opts.source = file(opts.fpfile, "r") + + # Outputs + if opts.dir: + fname = opts.output + if fname is None: + fname = datetime.today().strftime("%Y-%m-%d_%H-%M-%S") + ".fp" + path = os.path.join(opts.dir, fname) + opts.output_file = path + opts.output = file(path, "w") + elif opts.output: + opts.output_file = opts.output + opts.output = file(opts.output_file, "w") + else: + opts.output_file = None + opts.output = sys.stdout + + # GHC Directory + # As a last step change the directory to the GHC directory specified + if opts.ghcdir: + os.chdir(opts.ghcdir) + + return opts + +def error(msg="fatal error", parser=None, exit=1): + """Function that prints error message and exits""" + print "ERROR:", msg + if parser: + parser.print_help() + sys.exit(exit) + +class MalformedFingerPrintError(Exception): + """Exception raised when parsing a bad fingerprint file""" + pass + +class FingerPrint: + """Class representing a fingerprint of all ghc git repos. + + A finger print is represented by a dictionary that maps a + directory to a commit. The directory "." is used for the top + level ghc repository. + """ + def __init__(self, subcommits = {}): + self.commits = subcommits + + def __eq__(self, other): + if other.__class__ != self.__class__: + raise TypeError + return self.commits == other.commits + + def __neq__(self, other): + not(self == other) + + def __hash__(self): + return hash(str(self)) + + def __len__(self): + return len(self.commits) + + def __repr__(self): + return "FingerPrint(" + repr(self.commits) + ")" + + def __str__(self): + s = "" + for lib in sorted(self.commits.keys()): + commit = self.commits[lib] + s += "{0}|{1}\n".format(lib, commit) + return s + + def __getitem__(self, item): + return self.commits[item] + + def __iter__(self): + return self.commits.iteritems() + + def write(self, outh): + outh.write(str(self)) + outh.flush() + + @staticmethod + def read(inh): + """Read a fingerprint from a fingerprint file""" + commits = {} + for line in inh.readlines(): + splits = line.strip().split("|", 1) + if len(splits) != 2: + raise MalformedFingerPrintError(line) + lib, commit = splits + commits[lib] = commit + return FingerPrint(commits) + +if __name__ == "__main__": + main() diff -Nru ghc-7.0.3/utils/genprimopcode/Lexer.hs ghc-7.2.1/utils/genprimopcode/Lexer.hs --- ghc-7.0.3/utils/genprimopcode/Lexer.hs 2011-03-26 20:51:08.000000000 +0000 +++ ghc-7.2.1/utils/genprimopcode/Lexer.hs 2011-08-07 20:09:18.000000000 +0000 @@ -1,6 +1,7 @@ {-# OPTIONS -fglasgow-exts -cpp #-} {-# LINE 2 "utils/genprimopcode/./Lexer.x" #-} +{-# LANGUAGE BangPatterns #-} -- required for versions of Alex before 2.3.4 {-# OPTIONS -w -Wwarn #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and fix @@ -35,19 +36,19 @@ import GlaExts #endif alex_base :: AlexAddr -alex_base = AlexA# "\xf8\xff\xff\xff\xfc\xff\xff\xff\xfe\xff\xff\xff\x03\x00\x00\x00\x00\x00\x00\x00\x07\x00\x00\x00\x08\x00\x00\x00\xe8\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf0\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xeb\xff\xff\xff\x51\x00\x00\x00\xa9\x00\x00\x00\x01\x01\x00\x00\x59\x01\x00\x00\xb1\x01\x00\x00\x09\x02\x00\x00\x61\x02\x00\x00\xb9\x02\x00\x00\x11\x03\x00\x00\x69\x03\x00\x00\xc1\x03\x00\x00\x19\x04\x00\x00\x71\x04\x00\x00\xc9\x04\x00\x00\x21\x05\x00\x00\x79\x05\x00\x00\xd1\x05\x00\x00\x29\x06\x00\x00\x81\x06\x00\x00\xd9\x06\x00\x00\x31\x07\x00\x00\x89\x07\x00\x00\xe1\x07\x00\x00\x39\x08\x00\x00\x91\x08\x00\x00\xe9\x08\x00\x00\x41\x09\x00\x00\x99\x09\x00\x00\xf1\x09\x00\x00\x49\x0a\x00\x00\xa1\x0a\x00\x00\xf9\x0a\x00\x00\x51\x0b\x00\x00\xa9\x0b\x00\x00\x01\x0c\x00\x00\x59\x0c\x00\x00\xb1\x0c\x00\x00\x09\x0d\x00\x00\x61\x0d\x00\x00\xb9\x0d\x00\x00\x11\x0e\x00\x00\x69\x0e\x00\x00\xc1\x0e\x00\x00\x19\x0f\x00\x00\x71\x0f\x00\x00\xc9\x0f\x00\x00\x21\x10\x00\x00\x79\x10\x00\x00\xd1\x10\x00\x00\x29\x11\x00\x00\x81\x11\x00\x00\xd9\x11\x00\x00\x31\x12\x00\x00\x89\x12\x00\x00\xe1\x12\x00\x00\x39\x13\x00\x00\x91\x13\x00\x00\xe9\x13\x00\x00\x41\x14\x00\x00\x99\x14\x00\x00\xf1\x14\x00\x00\x49\x15\x00\x00\xa1\x15\x00\x00\xf9\x15\x00\x00\x51\x16\x00\x00\xa9\x16\x00\x00\x01\x17\x00\x00\x59\x17\x00\x00\xb1\x17\x00\x00\x09\x18\x00\x00\x61\x18\x00\x00\xb9\x18\x00\x00\x11\x19\x00\x00\x69\x19\x00\x00\xc1\x19\x00\x00\x19\x1a\x00\x00\x71\x1a\x00\x00\xc9\x1a\x00\x00\x21\x1b\x00\x00\x79\x1b\x00\x00\xd1\x1b\x00\x00\x29\x1c\x00\x00\x81\x1c\x00\x00\xd9\x1c\x00\x00\x31\x1d\x00\x00\x89\x1d\x00\x00\xe1\x1d\x00\x00\x39\x1e\x00\x00\x91\x1e\x00\x00\xe9\x1e\x00\x00\x41\x1f\x00\x00\x99\x1f\x00\x00\xf1\x1f\x00\x00\x00\x00\x00\x00\x0c\x00\x00\x00\x0d\x00\x00\x00\x12\x00\x00\x00\x00\x00\x00\x00"# +alex_base = AlexA# "\xf8\xff\xff\xff\xfc\xff\xff\xff\xfe\xff\xff\xff\x03\x00\x00\x00\x00\x00\x00\x00\x07\x00\x00\x00\x08\x00\x00\x00\xe8\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf0\xff\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xeb\xff\xff\xff\x51\x00\x00\x00\xa9\x00\x00\x00\x01\x01\x00\x00\x59\x01\x00\x00\xb1\x01\x00\x00\x09\x02\x00\x00\x61\x02\x00\x00\xb9\x02\x00\x00\x11\x03\x00\x00\x69\x03\x00\x00\xc1\x03\x00\x00\x19\x04\x00\x00\x71\x04\x00\x00\xc9\x04\x00\x00\x21\x05\x00\x00\x79\x05\x00\x00\xd1\x05\x00\x00\x29\x06\x00\x00\x81\x06\x00\x00\xd9\x06\x00\x00\x31\x07\x00\x00\x89\x07\x00\x00\xe1\x07\x00\x00\x39\x08\x00\x00\x91\x08\x00\x00\xe9\x08\x00\x00\x41\x09\x00\x00\x99\x09\x00\x00\xf1\x09\x00\x00\x49\x0a\x00\x00\xa1\x0a\x00\x00\xf9\x0a\x00\x00\x51\x0b\x00\x00\xa9\x0b\x00\x00\x01\x0c\x00\x00\x59\x0c\x00\x00\xb1\x0c\x00\x00\x09\x0d\x00\x00\x61\x0d\x00\x00\xb9\x0d\x00\x00\x11\x0e\x00\x00\x69\x0e\x00\x00\xc1\x0e\x00\x00\x19\x0f\x00\x00\x71\x0f\x00\x00\xc9\x0f\x00\x00\x21\x10\x00\x00\x79\x10\x00\x00\xd1\x10\x00\x00\x29\x11\x00\x00\x81\x11\x00\x00\xd9\x11\x00\x00\x31\x12\x00\x00\x89\x12\x00\x00\xe1\x12\x00\x00\x39\x13\x00\x00\x91\x13\x00\x00\xe9\x13\x00\x00\x41\x14\x00\x00\x99\x14\x00\x00\xf1\x14\x00\x00\x49\x15\x00\x00\xa1\x15\x00\x00\xf9\x15\x00\x00\x51\x16\x00\x00\xa9\x16\x00\x00\x01\x17\x00\x00\x59\x17\x00\x00\xb1\x17\x00\x00\x09\x18\x00\x00\x61\x18\x00\x00\xb9\x18\x00\x00\x11\x19\x00\x00\x69\x19\x00\x00\xc1\x19\x00\x00\x19\x1a\x00\x00\x71\x1a\x00\x00\xc9\x1a\x00\x00\x21\x1b\x00\x00\x79\x1b\x00\x00\xd1\x1b\x00\x00\x29\x1c\x00\x00\x81\x1c\x00\x00\xd9\x1c\x00\x00\x31\x1d\x00\x00\x89\x1d\x00\x00\xe1\x1d\x00\x00\x39\x1e\x00\x00\x91\x1e\x00\x00\xe9\x1e\x00\x00\x41\x1f\x00\x00\x99\x1f\x00\x00\xf1\x1f\x00\x00\x9d\x00\x00\x00\xf5\x00\x00\x00\x00\x00\x00\x00\x12\x00\x00\x00\x15\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00"# alex_table :: AlexAddr -alex_table = AlexA# "\x00\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x73\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x04\x00\x04\x00\x0f\x00\x10\x00\x05\x00\xff\xff\xff\xff\x03\x00\x00\x00\x70\x00\x11\x00\xff\xff\x00\x00\x03\x00\x00\x00\x0d\x00\x0e\x00\x00\x00\x03\x00\x0c\x00\x07\x00\x0a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6f\x00\x6f\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0b\x00\x00\x00\x00\x00\x00\x00\x6d\x00\x6d\x00\x4d\x00\x40\x00\x6d\x00\x3b\x00\x54\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x46\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x37\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6b\x00\x6b\x00\x2f\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x1a\x00\x6b\x00\x6b\x00\x13\x00\x5d\x00\x6b\x00\x6b\x00\x2b\x00\x6b\x00\x6b\x00\x6b\x00\x08\x00\x6c\x00\x09\x00\x00\x00\x08\x00\x00\x00\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x14\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x15\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x16\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x17\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x18\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x12\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x1b\x00\x20\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x1c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x1d\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x1e\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x27\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x19\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x21\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x22\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x23\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x24\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x25\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x1f\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x28\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x29\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x26\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x2c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x2d\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x2a\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x30\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x31\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x32\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x33\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x34\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x35\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x2e\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x38\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x39\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x36\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x3c\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x3d\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x3e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x3a\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x41\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x42\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x43\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x44\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x3f\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x47\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x48\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x49\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x4a\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x4b\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x45\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x4e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x4f\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x50\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x51\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x52\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x4c\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x55\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x56\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x57\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x58\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x59\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x5a\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x5b\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x53\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x5e\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x5f\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x60\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x61\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x63\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x64\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x65\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x66\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x67\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x68\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x69\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6a\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x5c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# +alex_table = AlexA# "\x00\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x75\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x03\x00\x04\x00\x04\x00\x0f\x00\x10\x00\x05\x00\x00\x00\x00\x00\x03\x00\x00\x00\x72\x00\x11\x00\xff\xff\xff\xff\x03\x00\xff\xff\x0d\x00\x0e\x00\x00\x00\x03\x00\x0c\x00\x07\x00\x0a\x00\x00\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x6f\x00\x00\x00\x00\x00\x71\x00\x0b\x00\x00\x00\x71\x00\x00\x00\x6d\x00\x6d\x00\x4d\x00\x40\x00\x6d\x00\x3b\x00\x54\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x46\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x37\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x6d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6b\x00\x6b\x00\x6b\x00\x2f\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x6b\x00\x1a\x00\x6b\x00\x6b\x00\x13\x00\x5d\x00\x6b\x00\x6b\x00\x2b\x00\x6b\x00\x6b\x00\x6b\x00\x08\x00\x6c\x00\x09\x00\x00\x00\x08\x00\x00\x00\x09\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\xff\xff\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x14\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x70\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x15\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x16\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x17\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x18\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x12\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x1b\x00\x20\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x1c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x1d\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x1e\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x27\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x19\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x21\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x22\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x23\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x24\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x25\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x1f\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x28\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x29\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x26\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x2c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x2d\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x2a\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x30\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x31\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x32\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x33\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x34\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x35\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x2e\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x38\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x39\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x36\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x3c\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x3d\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x3e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x3a\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x41\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x42\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x43\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x44\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x3f\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x47\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x48\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x49\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x4a\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x4b\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x45\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x4e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x4f\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x50\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x51\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x52\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x4c\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x55\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x56\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x57\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x58\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x59\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x5a\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x5b\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x53\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x5e\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x5f\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x60\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x61\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x62\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x63\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x64\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x65\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x66\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x67\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x68\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x69\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6a\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x5c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6c\x00\x00\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6c\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x6e\x00\x00\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x6e\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# alex_check :: AlexAddr -alex_check = AlexA# "\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0a\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0a\x00\x0a\x00\x23\x00\x29\x00\x2d\x00\x0a\x00\x0a\x00\x20\x00\xff\xff\x22\x00\x23\x00\x0a\x00\xff\xff\x20\x00\xff\xff\x28\x00\x29\x00\xff\xff\x20\x00\x2c\x00\x2d\x00\x3e\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x22\x00\x22\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x3d\x00\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x23\x00\x7d\x00\xff\xff\x7b\x00\xff\xff\x7d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x7b\x00\xff\xff\x7d\x00\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# +alex_check = AlexA# "\xff\xff\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0a\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x0a\x00\x0a\x00\x23\x00\x29\x00\x2d\x00\xff\xff\xff\xff\x20\x00\xff\xff\x22\x00\x23\x00\x0a\x00\x0a\x00\x20\x00\x0a\x00\x28\x00\x29\x00\xff\xff\x20\x00\x2c\x00\x2d\x00\x3e\x00\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x22\x00\x3d\x00\xff\xff\x22\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x7b\x00\x23\x00\x7d\x00\xff\xff\x7b\x00\xff\xff\x7d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\x7b\x00\xff\xff\x7d\x00\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\x23\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x30\x00\x31\x00\x32\x00\x33\x00\x34\x00\x35\x00\x36\x00\x37\x00\x38\x00\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x41\x00\x42\x00\x43\x00\x44\x00\x45\x00\x46\x00\x47\x00\x48\x00\x49\x00\x4a\x00\x4b\x00\x4c\x00\x4d\x00\x4e\x00\x4f\x00\x50\x00\x51\x00\x52\x00\x53\x00\x54\x00\x55\x00\x56\x00\x57\x00\x58\x00\x59\x00\x5a\x00\xff\xff\xff\xff\xff\xff\xff\xff\x5f\x00\xff\xff\x61\x00\x62\x00\x63\x00\x64\x00\x65\x00\x66\x00\x67\x00\x68\x00\x69\x00\x6a\x00\x6b\x00\x6c\x00\x6d\x00\x6e\x00\x6f\x00\x70\x00\x71\x00\x72\x00\x73\x00\x74\x00\x75\x00\x76\x00\x77\x00\x78\x00\x79\x00\x7a\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# alex_deflt :: AlexAddr -alex_deflt = AlexA# "\xff\xff\x72\x00\xff\xff\xff\xff\xff\xff\x06\x00\x06\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x71\x00\x71\x00\x72\x00\xff\xff"# +alex_deflt = AlexA# "\xff\xff\x74\x00\xff\xff\xff\xff\xff\xff\x06\x00\x06\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x73\x00\x73\x00\x74\x00\xff\xff"# -alex_accept = listArray (0::Int,115) [[],[],[],[(AlexAccSkip)],[(AlexAccSkip)],[],[],[],[(AlexAcc (alex_action_2))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_4))],[(AlexAcc (alex_action_5))],[(AlexAcc (alex_action_6))],[(AlexAcc (alex_action_7))],[(AlexAcc (alex_action_8))],[(AlexAcc (alex_action_9))],[(AlexAcc (alex_action_10))],[],[(AlexAcc (alex_action_11))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_12))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_13))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_14))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_15))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_16))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_17))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_18))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_19))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_20))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_21))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_22))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_23))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_26))],[],[],[(AlexAcc (alex_action_27))],[(AlexAcc (alex_action_28))]] -{-# LINE 60 "utils/genprimopcode/./Lexer.x" #-} +alex_accept = listArray (0::Int,117) [[],[],[],[(AlexAccSkip)],[(AlexAccSkip)],[],[],[],[(AlexAcc (alex_action_2))],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_4))],[(AlexAcc (alex_action_5))],[(AlexAcc (alex_action_6))],[(AlexAcc (alex_action_7))],[(AlexAcc (alex_action_8))],[(AlexAcc (alex_action_9))],[(AlexAcc (alex_action_10))],[],[(AlexAcc (alex_action_11))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_12))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_13))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_14))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_15))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_16))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_17))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_18))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_19))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_20))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_21))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_22))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_23))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_25))],[(AlexAcc (alex_action_26))],[(AlexAcc (alex_action_26))],[(AlexAcc (alex_action_27))],[],[],[(AlexAcc (alex_action_28))],[(AlexAcc (alex_action_29))]] +{-# LINE 62 "utils/genprimopcode/./Lexer.x" #-} get_tok :: ParserM Token get_tok = ParserM $ \i st -> @@ -98,9 +99,10 @@ alex_action_23 = mkT TThatsAllFolks alex_action_24 = mkTv TLowerName alex_action_25 = mkTv TUpperName -alex_action_26 = mkTv (TString . tail . init) -alex_action_27 = mkTv TNoBraces +alex_action_26 = mkTv (TInteger . read) +alex_action_27 = mkTv (TString . tail . init) alex_action_28 = mkTv TNoBraces +alex_action_29 = mkTv TNoBraces {-# LINE 1 "templates/GenericTemplate.hs" #-} {-# LINE 1 "templates/GenericTemplate.hs" #-} {-# LINE 1 "" #-} diff -Nru ghc-7.0.3/utils/genprimopcode/Lexer.x.source ghc-7.2.1/utils/genprimopcode/Lexer.x.source --- ghc-7.0.3/utils/genprimopcode/Lexer.x.source 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/utils/genprimopcode/Lexer.x.source 2011-08-07 17:10:05.000000000 +0000 @@ -1,5 +1,6 @@ { +{-# LANGUAGE BangPatterns #-} -- required for versions of Alex before 2.3.4 {-# OPTIONS -w -Wwarn #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and fix @@ -53,6 +54,7 @@ <0> "thats_all_folks" { mkT TThatsAllFolks } <0> [a-z][a-zA-Z0-9\#_]* { mkTv TLowerName } <0> [A-Z][a-zA-Z0-9\#_]* { mkTv TUpperName } + <0> [0-9][0-9]* { mkTv (TInteger . read) } <0> \" [^\"]* \" { mkTv (TString . tail . init) } [^\{\}]+ { mkTv TNoBraces } \n { mkTv TNoBraces } diff -Nru ghc-7.0.3/utils/genprimopcode/Main.hs ghc-7.2.1/utils/genprimopcode/Main.hs --- ghc-7.0.3/utils/genprimopcode/Main.hs 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/utils/genprimopcode/Main.hs 2011-08-07 17:10:05.000000000 +0000 @@ -46,13 +46,13 @@ "commutable" "commutableOp" p_o_specs) - "--needs-wrapper" + "--code-size" -> putStr (gen_switch_from_attribs - "needs_wrapper" - "primOpNeedsWrapper" p_o_specs) + "code_size" + "primOpCodeSize" p_o_specs) - "--can-fail" - -> putStr (gen_switch_from_attribs + "--can-fail" + -> putStr (gen_switch_from_attribs "can_fail" "primOpCanFail" p_o_specs) @@ -91,7 +91,7 @@ "--has-side-effects", "--out-of-line", "--commutable", - "--needs-wrapper", + "--code-size", "--can-fail", "--strictness", "--primop-primop-info", @@ -132,7 +132,7 @@ ++ unlines (map (("\t" ++) . hdr) entries) ++ ") where\n" ++ "\n" - ++ "import GHC.Bool\n" + ++ "import GHC.Types\n" ++ "\n" ++ "{-\n" ++ unlines (map opt defaults) @@ -141,6 +141,7 @@ where opt (OptionFalse n) = n ++ " = False" opt (OptionTrue n) = n ++ " = True" opt (OptionString n v) = n ++ " = { " ++ v ++ "}" + opt (OptionInteger n v) = n ++ " = " ++ show v hdr s@(Section {}) = sec s hdr (PrimOpSpec { name = n }) = wrapOp n ++ "," @@ -409,7 +410,8 @@ Just (OptionTrue _) -> if_true Just (OptionFalse _) -> if_false Just (OptionString _ _) -> error "String value for boolean option" - Nothing -> "" + Just (OptionInteger _ _) -> error "Integer value for boolean option" + Nothing -> "" mk_strictness o = case lookup_attrib "strictness" o of @@ -487,7 +489,7 @@ -- don't need the Prelude here so we add NoImplicitPrelude. ++ "module GHC.PrimopWrappers where\n" ++ "import qualified GHC.Prim\n" - ++ "import GHC.Bool (Bool)\n" + ++ "import GHC.Types (Bool)\n" ++ "import GHC.Unit ()\n" ++ "import GHC.Prim (" ++ types ++ ")\n" ++ unlines (concatMap f specs) @@ -550,6 +552,7 @@ getAltRhs (OptionFalse _) = "False" getAltRhs (OptionTrue _) = "True" + getAltRhs (OptionInteger _ i) = show i getAltRhs (OptionString _ s) = s mkAlt po diff -Nru ghc-7.0.3/utils/genprimopcode/Parser.hs ghc-7.2.1/utils/genprimopcode/Parser.hs --- ghc-7.0.3/utils/genprimopcode/Parser.hs 2011-03-26 20:51:08.000000000 +0000 +++ ghc-7.2.1/utils/genprimopcode/Parser.hs 2011-08-07 20:09:18.000000000 +0000 @@ -1,5 +1,6 @@ {-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} {-# OPTIONS -fglasgow-exts -cpp #-} +{-# LANGUAGE BangPatterns #-} -- required for versions of Happy before 1.18.6 {-# OPTIONS -w -Wwarn #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and fix @@ -179,21 +180,21 @@ happyActOffsets :: HappyAddr -happyActOffsets = HappyA# "\x70\x00\x70\x00\x45\x00\x6e\x00\x5c\x00\x00\x00\x69\x00\x74\x00\x66\x00\x45\x00\x00\x00\x00\x00\x00\x00\x00\x00\x65\x00\x5b\x00\x64\x00\x01\x00\x6d\x00\x71\x00\x00\x00\x04\x00\xfd\xff\x01\x00\x00\x00\x00\x00\x01\x00\x56\x00\x6c\x00\x00\x00\x00\x00\xfe\xff\x00\x00\x00\x00\xfc\xff\x00\x00\x00\x00\x00\x00\x00\x00\x39\x00\x6c\x00\x6b\x00\x6a\x00\x68\x00\x00\x00\x00\x00\x04\x00\x00\x00\x67\x00\x00\x00\x01\x00\x62\x00\x00\x00\x54\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x5a\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x61\x00\xfc\xff\xfc\xff\x00\x00\x60\x00\x00\x00\x00\x00\x5e\x00\x00\x00\x00\x00\x00\x00\x59\x00\x00\x00\x00\x00\x00\x00"# +happyActOffsets = HappyA# "\x70\x00\x70\x00\x47\x00\x6f\x00\x68\x00\x00\x00\x67\x00\x76\x00\x66\x00\x47\x00\x00\x00\x00\x00\x00\x00\x00\x00\x64\x00\x5d\x00\x5e\x00\x01\x00\x6e\x00\x72\x00\x00\x00\x04\x00\xfd\xff\x01\x00\x00\x00\x00\x00\x01\x00\x58\x00\x6c\x00\x00\x00\x00\x00\x0e\x00\x00\x00\x00\x00\xfc\xff\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfe\xff\x6c\x00\x6d\x00\x6b\x00\x6a\x00\x00\x00\x00\x00\x04\x00\x00\x00\x69\x00\x00\x00\x01\x00\x5c\x00\x00\x00\x56\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x5b\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x63\x00\xfc\xff\xfc\xff\x00\x00\x62\x00\x00\x00\x00\x00\x60\x00\x00\x00\x00\x00\x00\x00\x59\x00\x00\x00\x00\x00\x00\x00"# happyGotoOffsets :: HappyAddr -happyGotoOffsets = HappyA# "\x63\x00\x57\x00\x41\x00\x5f\x00\x00\x00\x00\x00\x5d\x00\x00\x00\x00\x00\x3b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x28\x00\x51\x00\x00\x00\x00\x00\x3f\x00\x21\x00\x0d\x00\x00\x00\x00\x00\x1e\x00\x00\x00\x4f\x00\x00\x00\x00\x00\x58\x00\x00\x00\x00\x00\x4b\x00\x00\x00\x00\x00\x00\x00\x00\x00\x0c\x00\x4a\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x27\x00\x00\x00\x00\x00\x00\x00\x17\x00\x10\x00\x00\x00\x33\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfa\xff\x09\x00\x14\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x1d\x00\x13\x00\x00\x00\x00\x00\x00\x00\x00\x00\x05\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x00\x00\x00\x00"# +happyGotoOffsets = HappyA# "\x65\x00\x4f\x00\x46\x00\x61\x00\x00\x00\x00\x00\x5f\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2d\x00\x53\x00\x00\x00\x00\x00\x41\x00\x26\x00\x10\x00\x00\x00\x00\x00\x23\x00\x00\x00\x51\x00\x00\x00\x00\x00\x0d\x00\x00\x00\x00\x00\x4d\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xfb\xff\x4c\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x2c\x00\x00\x00\x00\x00\x00\x00\x1c\x00\x50\x00\x00\x00\x38\x00\x00\x00\x00\x00\x00\x00\x00\x00\xf9\xff\x1d\x00\x19\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x22\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x18\x00\x00\x00\x00\x00\x00\x00\x13\x00\x00\x00\x00\x00\x00\x00"# happyDefActions :: HappyAddr -happyDefActions = HappyA# "\x00\x00\x00\x00\xf6\xff\xfb\xff\x00\x00\xfd\xff\xfb\xff\x00\x00\x00\x00\xf6\xff\xf5\xff\xf4\xff\xf3\xff\xf2\xff\x00\x00\x00\x00\x00\x00\x00\x00\xe6\xff\xdf\xff\xdd\xff\xd6\xff\x00\x00\x00\x00\xdb\xff\xd3\xff\x00\x00\x00\x00\xe6\xff\xf7\xff\xfe\xff\x00\x00\xfc\xff\xf8\xff\xe3\xff\xf9\xff\xfa\xff\xee\xff\xe7\xff\x00\x00\xe6\xff\xd8\xff\x00\x00\x00\x00\xd2\xff\xde\xff\xd6\xff\xd4\xff\x00\x00\xd5\xff\x00\x00\xec\xff\xf0\xff\xfb\xff\xe0\xff\xd7\xff\xdc\xff\xda\xff\x00\x00\xec\xff\x00\x00\xeb\xff\xea\xff\xe9\xff\xe8\xff\x00\x00\xe3\xff\xe3\xff\xe1\xff\x00\x00\xe4\xff\xe5\xff\xe6\xff\xef\xff\xd9\xff\xed\xff\xec\xff\xe2\xff\xf1\xff"# +happyDefActions = HappyA# "\x00\x00\x00\x00\xf5\xff\xfb\xff\x00\x00\xfd\xff\xfb\xff\x00\x00\x00\x00\xf5\xff\xf4\xff\xf3\xff\xf2\xff\xf1\xff\x00\x00\x00\x00\x00\x00\x00\x00\xe5\xff\xde\xff\xdc\xff\xd5\xff\x00\x00\x00\x00\xda\xff\xd2\xff\x00\x00\x00\x00\xe5\xff\xf6\xff\xfe\xff\x00\x00\xfc\xff\xf8\xff\xe2\xff\xf9\xff\xfa\xff\xf7\xff\xed\xff\xe6\xff\x00\x00\xe5\xff\xd7\xff\x00\x00\x00\x00\xd1\xff\xdd\xff\xd5\xff\xd3\xff\x00\x00\xd4\xff\x00\x00\xeb\xff\xef\xff\xfb\xff\xdf\xff\xd6\xff\xdb\xff\xd9\xff\x00\x00\xeb\xff\x00\x00\xea\xff\xe9\xff\xe8\xff\xe7\xff\x00\x00\xe2\xff\xe2\xff\xe0\xff\x00\x00\xe3\xff\xe4\xff\xe5\xff\xee\xff\xd8\xff\xec\xff\xeb\xff\xe1\xff\xf0\xff"# happyCheck :: HappyAddr -happyCheck = HappyA# "\xff\xff\x04\x00\x05\x00\x06\x00\x08\x00\x04\x00\x08\x00\x06\x00\x04\x00\x0a\x00\x10\x00\x11\x00\x12\x00\x13\x00\x10\x00\x11\x00\x16\x00\x0c\x00\x0d\x00\x0a\x00\x17\x00\x18\x00\x1a\x00\x0b\x00\x17\x00\x18\x00\x0a\x00\x17\x00\x18\x00\x10\x00\x11\x00\x12\x00\x13\x00\x0e\x00\x0f\x00\x16\x00\x10\x00\x11\x00\x12\x00\x10\x00\x11\x00\x12\x00\x16\x00\x0e\x00\x0f\x00\x16\x00\x10\x00\x11\x00\x12\x00\x10\x00\x11\x00\x12\x00\x16\x00\x02\x00\x03\x00\x16\x00\x10\x00\x11\x00\x12\x00\x14\x00\x15\x00\x16\x00\x16\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x12\x00\x13\x00\x14\x00\x15\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x14\x00\x15\x00\x16\x00\x0c\x00\x0d\x00\x01\x00\x0e\x00\x0f\x00\x0c\x00\x0d\x00\x0c\x00\x0d\x00\x02\x00\x03\x00\x02\x00\x03\x00\x00\x00\x01\x00\x0d\x00\x08\x00\x0e\x00\x0e\x00\x09\x00\x09\x00\x17\x00\x05\x00\x05\x00\x03\x00\x19\x00\x0e\x00\x07\x00\x01\x00\x18\x00\x08\x00\x08\x00\x02\x00\x1b\x00\xff\xff\xff\xff\xff\xff\xff\xff\x16\x00\x19\x00\x19\x00\x0f\x00\x17\x00\xff\xff\xff\xff\xff\xff\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# +happyCheck = HappyA# "\xff\xff\x04\x00\x05\x00\x06\x00\x08\x00\x04\x00\x0b\x00\x06\x00\x04\x00\x10\x00\x11\x00\x12\x00\x13\x00\x0e\x00\x0f\x00\x16\x00\x12\x00\x13\x00\x14\x00\x15\x00\x17\x00\x18\x00\x08\x00\x1b\x00\x17\x00\x18\x00\x0d\x00\x17\x00\x18\x00\x0a\x00\x10\x00\x11\x00\x10\x00\x11\x00\x12\x00\x13\x00\x0c\x00\x0d\x00\x16\x00\x0a\x00\x1a\x00\x10\x00\x11\x00\x12\x00\x10\x00\x11\x00\x12\x00\x16\x00\x0e\x00\x0f\x00\x16\x00\x10\x00\x11\x00\x12\x00\x10\x00\x11\x00\x12\x00\x16\x00\x02\x00\x03\x00\x16\x00\x10\x00\x11\x00\x12\x00\x14\x00\x15\x00\x16\x00\x16\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x04\x00\x05\x00\x06\x00\x07\x00\x08\x00\x09\x00\x01\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x14\x00\x15\x00\x16\x00\x0c\x00\x0d\x00\x0a\x00\x0e\x00\x0f\x00\x0c\x00\x0d\x00\x0c\x00\x0d\x00\x02\x00\x03\x00\x02\x00\x03\x00\x00\x00\x01\x00\x0e\x00\x08\x00\x0e\x00\x0e\x00\x09\x00\x09\x00\x17\x00\x05\x00\x05\x00\x03\x00\x19\x00\x07\x00\x01\x00\x08\x00\x18\x00\x08\x00\x19\x00\x02\x00\xff\xff\xff\xff\xff\xff\x16\x00\x19\x00\x17\x00\x0f\x00\xff\xff\xff\xff\xff\xff\xff\xff\x1c\x00\xff\xff\x17\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff"# happyTable :: HappyAddr -happyTable = HappyA# "\x00\x00\x17\x00\x2d\x00\x18\x00\x44\x00\x17\x00\x23\x00\x18\x00\x31\x00\x4e\x00\x29\x00\x13\x00\x14\x00\x4a\x00\x24\x00\x25\x00\x15\x00\x4c\x00\x26\x00\x49\x00\x19\x00\x1a\x00\x45\x00\x3c\x00\x19\x00\x1a\x00\x34\x00\x32\x00\x1a\x00\x29\x00\x13\x00\x14\x00\x2a\x00\x45\x00\x42\x00\x15\x00\x48\x00\x13\x00\x14\x00\x36\x00\x13\x00\x14\x00\x15\x00\x46\x00\x42\x00\x15\x00\x28\x00\x13\x00\x14\x00\x2b\x00\x13\x00\x14\x00\x15\x00\x4b\x00\x06\x00\x15\x00\x12\x00\x13\x00\x14\x00\x37\x00\x2e\x00\x2f\x00\x15\x00\x1d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x3e\x00\x3f\x00\x40\x00\x41\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x2d\x00\x2e\x00\x2f\x00\x3b\x00\x26\x00\x02\x00\x41\x00\x42\x00\x25\x00\x26\x00\x33\x00\x26\x00\x20\x00\x06\x00\x05\x00\x06\x00\x04\x00\x02\x00\x21\x00\x23\x00\x36\x00\x36\x00\x4e\x00\x48\x00\x08\x00\x2d\x00\x39\x00\x3b\x00\x28\x00\x36\x00\x3a\x00\x33\x00\x1c\x00\x23\x00\x23\x00\x20\x00\xff\xff\x00\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x1b\x00\x1d\x00\x04\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# +happyTable = HappyA# "\x00\x00\x17\x00\x2e\x00\x18\x00\x45\x00\x17\x00\x3d\x00\x18\x00\x32\x00\x2a\x00\x13\x00\x14\x00\x4b\x00\x46\x00\x43\x00\x15\x00\x3f\x00\x40\x00\x41\x00\x42\x00\x19\x00\x1a\x00\x23\x00\x46\x00\x19\x00\x1a\x00\x21\x00\x33\x00\x1a\x00\x4f\x00\x24\x00\x25\x00\x2a\x00\x13\x00\x14\x00\x2b\x00\x4d\x00\x27\x00\x15\x00\x4a\x00\x26\x00\x49\x00\x13\x00\x14\x00\x37\x00\x13\x00\x14\x00\x15\x00\x47\x00\x43\x00\x15\x00\x29\x00\x13\x00\x14\x00\x2c\x00\x13\x00\x14\x00\x15\x00\x4c\x00\x06\x00\x15\x00\x12\x00\x13\x00\x14\x00\x38\x00\x2f\x00\x30\x00\x15\x00\x1d\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x08\x00\x09\x00\x0a\x00\x0b\x00\x0c\x00\x0d\x00\x02\x00\x0f\x00\x10\x00\x11\x00\x12\x00\x2e\x00\x2f\x00\x30\x00\x3c\x00\x27\x00\x35\x00\x42\x00\x43\x00\x26\x00\x27\x00\x34\x00\x27\x00\x20\x00\x06\x00\x05\x00\x06\x00\x04\x00\x02\x00\x37\x00\x23\x00\x37\x00\x37\x00\x4f\x00\x49\x00\x08\x00\x2e\x00\x3a\x00\x3c\x00\x29\x00\x3b\x00\x34\x00\x23\x00\x1c\x00\x23\x00\x1b\x00\x20\x00\x00\x00\x00\x00\x00\x00\x1f\x00\x1d\x00\x08\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00"# -happyReduceArr = Happy_Data_Array.array (1, 45) [ +happyReduceArr = Happy_Data_Array.array (1, 46) [ (1 , happyReduce_1), (2 , happyReduce_2), (3 , happyReduce_3), @@ -238,10 +239,11 @@ (42 , happyReduce_42), (43 , happyReduce_43), (44 , happyReduce_44), - (45 , happyReduce_45) + (45 , happyReduce_45), + (46 , happyReduce_46) ] -happy_n_terms = 28 :: Int +happy_n_terms = 29 :: Int happy_n_nonterms = 23 :: Int happyReduce_1 = happySpecReduce_3 0# happyReduction_1 @@ -304,8 +306,18 @@ (OptionString happy_var_1 happy_var_3 )}} -happyReduce_8 = happySpecReduce_2 4# happyReduction_8 -happyReduction_8 happy_x_2 +happyReduce_8 = happySpecReduce_3 3# happyReduction_8 +happyReduction_8 happy_x_3 + happy_x_2 + happy_x_1 + = case happyOutTok happy_x_1 of { (TLowerName happy_var_1) -> + case happyOutTok happy_x_3 of { (TInteger happy_var_3) -> + happyIn7 + (OptionInteger happy_var_1 happy_var_3 + )}} + +happyReduce_9 = happySpecReduce_2 4# happyReduction_9 +happyReduction_9 happy_x_2 happy_x_1 = case happyOut9 happy_x_1 of { happy_var_1 -> case happyOut8 happy_x_2 of { happy_var_2 -> @@ -313,41 +325,41 @@ (happy_var_1 : happy_var_2 )}} -happyReduce_9 = happySpecReduce_0 4# happyReduction_9 -happyReduction_9 = happyIn8 +happyReduce_10 = happySpecReduce_0 4# happyReduction_10 +happyReduction_10 = happyIn8 ([] ) -happyReduce_10 = happySpecReduce_1 5# happyReduction_10 -happyReduction_10 happy_x_1 +happyReduce_11 = happySpecReduce_1 5# happyReduction_11 +happyReduction_11 happy_x_1 = case happyOut10 happy_x_1 of { happy_var_1 -> happyIn9 (happy_var_1 )} -happyReduce_11 = happySpecReduce_1 5# happyReduction_11 -happyReduction_11 happy_x_1 +happyReduce_12 = happySpecReduce_1 5# happyReduction_12 +happyReduction_12 happy_x_1 = case happyOut11 happy_x_1 of { happy_var_1 -> happyIn9 (happy_var_1 )} -happyReduce_12 = happySpecReduce_1 5# happyReduction_12 -happyReduction_12 happy_x_1 +happyReduce_13 = happySpecReduce_1 5# happyReduction_13 +happyReduction_13 happy_x_1 = case happyOut12 happy_x_1 of { happy_var_1 -> happyIn9 (happy_var_1 )} -happyReduce_13 = happySpecReduce_1 5# happyReduction_13 -happyReduction_13 happy_x_1 +happyReduce_14 = happySpecReduce_1 5# happyReduction_14 +happyReduction_14 happy_x_1 = case happyOut13 happy_x_1 of { happy_var_1 -> happyIn9 (happy_var_1 )} -happyReduce_14 = happyReduce 7# 6# happyReduction_14 -happyReduction_14 (happy_x_7 `HappyStk` +happyReduce_15 = happyReduce 7# 6# happyReduction_15 +happyReduction_15 (happy_x_7 `HappyStk` happy_x_6 `HappyStk` happy_x_5 `HappyStk` happy_x_4 `HappyStk` @@ -372,8 +384,8 @@ } ) `HappyStk` happyRest}}}}}} -happyReduce_15 = happyReduce 4# 7# happyReduction_15 -happyReduction_15 (happy_x_4 `HappyStk` +happyReduce_16 = happyReduce 4# 7# happyReduction_16 +happyReduction_16 (happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` happy_x_1 `HappyStk` @@ -385,8 +397,8 @@ (PrimTypeSpec { ty = happy_var_2, desc = happy_var_3, opts = happy_var_4 } ) `HappyStk` happyRest}}} -happyReduce_16 = happyReduce 5# 8# happyReduction_16 -happyReduction_16 (happy_x_5 `HappyStk` +happyReduce_17 = happyReduce 5# 8# happyReduction_17 +happyReduction_17 (happy_x_5 `HappyStk` happy_x_4 `HappyStk` happy_x_3 `HappyStk` happy_x_2 `HappyStk` @@ -400,8 +412,8 @@ (PseudoOpSpec { name = happy_var_2, ty = happy_var_3, desc = happy_var_4, opts = happy_var_5 } ) `HappyStk` happyRest}}}} -happyReduce_17 = happySpecReduce_3 9# happyReduction_17 -happyReduction_17 happy_x_3 +happyReduce_18 = happySpecReduce_3 9# happyReduction_18 +happyReduction_18 happy_x_3 happy_x_2 happy_x_1 = case happyOutTok happy_x_2 of { (TString happy_var_2) -> @@ -410,57 +422,57 @@ (Section { title = happy_var_2, desc = happy_var_3 } )}} -happyReduce_18 = happySpecReduce_2 10# happyReduction_18 -happyReduction_18 happy_x_2 +happyReduce_19 = happySpecReduce_2 10# happyReduction_19 +happyReduction_19 happy_x_2 happy_x_1 = case happyOut6 happy_x_2 of { happy_var_2 -> happyIn14 (happy_var_2 )} -happyReduce_19 = happySpecReduce_0 10# happyReduction_19 -happyReduction_19 = happyIn14 +happyReduce_20 = happySpecReduce_0 10# happyReduction_20 +happyReduction_20 = happyIn14 ([] ) -happyReduce_20 = happySpecReduce_1 11# happyReduction_20 -happyReduction_20 happy_x_1 - = happyIn15 - (Dyadic - ) - happyReduce_21 = happySpecReduce_1 11# happyReduction_21 happyReduction_21 happy_x_1 = happyIn15 - (Monadic + (Dyadic ) happyReduce_22 = happySpecReduce_1 11# happyReduction_22 happyReduction_22 happy_x_1 = happyIn15 - (Compare + (Monadic ) happyReduce_23 = happySpecReduce_1 11# happyReduction_23 happyReduction_23 happy_x_1 = happyIn15 - (GenPrimOp + (Compare ) -happyReduce_24 = happySpecReduce_1 12# happyReduction_24 +happyReduce_24 = happySpecReduce_1 11# happyReduction_24 happyReduction_24 happy_x_1 + = happyIn15 + (GenPrimOp + ) + +happyReduce_25 = happySpecReduce_1 12# happyReduction_25 +happyReduction_25 happy_x_1 = case happyOut17 happy_x_1 of { happy_var_1 -> happyIn16 (happy_var_1 )} -happyReduce_25 = happySpecReduce_0 12# happyReduction_25 -happyReduction_25 = happyIn16 +happyReduce_26 = happySpecReduce_0 12# happyReduction_26 +happyReduction_26 = happyIn16 ("" ) -happyReduce_26 = happySpecReduce_3 13# happyReduction_26 -happyReduction_26 happy_x_3 +happyReduce_27 = happySpecReduce_3 13# happyReduction_27 +happyReduction_27 happy_x_3 happy_x_2 happy_x_1 = case happyOut18 happy_x_2 of { happy_var_2 -> @@ -468,8 +480,8 @@ (happy_var_2 )} -happyReduce_27 = happySpecReduce_2 14# happyReduction_27 -happyReduction_27 happy_x_2 +happyReduce_28 = happySpecReduce_2 14# happyReduction_28 +happyReduction_28 happy_x_2 happy_x_1 = case happyOut19 happy_x_1 of { happy_var_1 -> case happyOut18 happy_x_2 of { happy_var_2 -> @@ -477,13 +489,13 @@ (happy_var_1 ++ happy_var_2 )}} -happyReduce_28 = happySpecReduce_0 14# happyReduction_28 -happyReduction_28 = happyIn18 +happyReduce_29 = happySpecReduce_0 14# happyReduction_29 +happyReduction_29 = happyIn18 ("" ) -happyReduce_29 = happySpecReduce_3 15# happyReduction_29 -happyReduction_29 happy_x_3 +happyReduce_30 = happySpecReduce_3 15# happyReduction_30 +happyReduction_30 happy_x_3 happy_x_2 happy_x_1 = case happyOut18 happy_x_2 of { happy_var_2 -> @@ -491,15 +503,15 @@ ("{" ++ happy_var_2 ++ "}" )} -happyReduce_30 = happySpecReduce_1 15# happyReduction_30 -happyReduction_30 happy_x_1 +happyReduce_31 = happySpecReduce_1 15# happyReduction_31 +happyReduction_31 happy_x_1 = case happyOutTok happy_x_1 of { (TNoBraces happy_var_1) -> happyIn19 (happy_var_1 )} -happyReduce_31 = happySpecReduce_3 16# happyReduction_31 -happyReduction_31 happy_x_3 +happyReduce_32 = happySpecReduce_3 16# happyReduction_32 +happyReduction_32 happy_x_3 happy_x_2 happy_x_1 = case happyOut21 happy_x_1 of { happy_var_1 -> @@ -508,15 +520,15 @@ (TyF happy_var_1 happy_var_3 )}} -happyReduce_32 = happySpecReduce_1 16# happyReduction_32 -happyReduction_32 happy_x_1 +happyReduce_33 = happySpecReduce_1 16# happyReduction_33 +happyReduction_33 happy_x_1 = case happyOut21 happy_x_1 of { happy_var_1 -> happyIn20 (happy_var_1 )} -happyReduce_33 = happySpecReduce_2 17# happyReduction_33 -happyReduction_33 happy_x_2 +happyReduce_34 = happySpecReduce_2 17# happyReduction_34 +happyReduction_34 happy_x_2 happy_x_1 = case happyOut26 happy_x_1 of { happy_var_1 -> case happyOut24 happy_x_2 of { happy_var_2 -> @@ -524,15 +536,15 @@ (TyApp happy_var_1 happy_var_2 )}} -happyReduce_34 = happySpecReduce_1 17# happyReduction_34 -happyReduction_34 happy_x_1 +happyReduce_35 = happySpecReduce_1 17# happyReduction_35 +happyReduction_35 happy_x_1 = case happyOut22 happy_x_1 of { happy_var_1 -> happyIn21 (happy_var_1 )} -happyReduce_35 = happySpecReduce_3 17# happyReduction_35 -happyReduction_35 happy_x_3 +happyReduce_36 = happySpecReduce_3 17# happyReduction_36 +happyReduction_36 happy_x_3 happy_x_2 happy_x_1 = case happyOut20 happy_x_2 of { happy_var_2 -> @@ -540,15 +552,15 @@ (happy_var_2 )} -happyReduce_36 = happySpecReduce_1 17# happyReduction_36 -happyReduction_36 happy_x_1 +happyReduce_37 = happySpecReduce_1 17# happyReduction_37 +happyReduction_37 happy_x_1 = case happyOutTok happy_x_1 of { (TLowerName happy_var_1) -> happyIn21 (TyVar happy_var_1 )} -happyReduce_37 = happySpecReduce_3 18# happyReduction_37 -happyReduction_37 happy_x_3 +happyReduce_38 = happySpecReduce_3 18# happyReduction_38 +happyReduction_38 happy_x_3 happy_x_2 happy_x_1 = case happyOut23 happy_x_2 of { happy_var_2 -> @@ -556,8 +568,8 @@ (TyUTup happy_var_2 )} -happyReduce_38 = happySpecReduce_3 19# happyReduction_38 -happyReduction_38 happy_x_3 +happyReduce_39 = happySpecReduce_3 19# happyReduction_39 +happyReduction_39 happy_x_3 happy_x_2 happy_x_1 = case happyOut20 happy_x_1 of { happy_var_1 -> @@ -566,15 +578,15 @@ (happy_var_1 : happy_var_3 )}} -happyReduce_39 = happySpecReduce_1 19# happyReduction_39 -happyReduction_39 happy_x_1 +happyReduce_40 = happySpecReduce_1 19# happyReduction_40 +happyReduction_40 happy_x_1 = case happyOut20 happy_x_1 of { happy_var_1 -> happyIn23 ([happy_var_1] )} -happyReduce_40 = happySpecReduce_2 20# happyReduction_40 -happyReduction_40 happy_x_2 +happyReduce_41 = happySpecReduce_2 20# happyReduction_41 +happyReduction_41 happy_x_2 happy_x_1 = case happyOut25 happy_x_1 of { happy_var_1 -> case happyOut24 happy_x_2 of { happy_var_2 -> @@ -582,34 +594,34 @@ (happy_var_1 : happy_var_2 )}} -happyReduce_41 = happySpecReduce_0 20# happyReduction_41 -happyReduction_41 = happyIn24 +happyReduce_42 = happySpecReduce_0 20# happyReduction_42 +happyReduction_42 = happyIn24 ([] ) -happyReduce_42 = happySpecReduce_1 21# happyReduction_42 -happyReduction_42 happy_x_1 +happyReduce_43 = happySpecReduce_1 21# happyReduction_43 +happyReduction_43 happy_x_1 = case happyOutTok happy_x_1 of { (TLowerName happy_var_1) -> happyIn25 (TyVar happy_var_1 )} -happyReduce_43 = happySpecReduce_1 21# happyReduction_43 -happyReduction_43 happy_x_1 +happyReduce_44 = happySpecReduce_1 21# happyReduction_44 +happyReduction_44 happy_x_1 = case happyOut26 happy_x_1 of { happy_var_1 -> happyIn25 (TyApp happy_var_1 [] )} -happyReduce_44 = happySpecReduce_1 22# happyReduction_44 -happyReduction_44 happy_x_1 +happyReduce_45 = happySpecReduce_1 22# happyReduction_45 +happyReduction_45 happy_x_1 = case happyOutTok happy_x_1 of { (TUpperName happy_var_1) -> happyIn26 (happy_var_1 )} -happyReduce_45 = happySpecReduce_2 22# happyReduction_45 -happyReduction_45 happy_x_2 +happyReduce_46 = happySpecReduce_2 22# happyReduction_46 +happyReduction_46 happy_x_2 happy_x_1 = happyIn26 ("()" @@ -619,7 +631,7 @@ = lex_tok(\tk -> let cont i = happyDoAction i tk action sts stk in case tk of { - TEOF -> happyDoAction 27# tk action sts stk; + TEOF -> happyDoAction 28# tk action sts stk; TArrow -> cont 1#; TEquals -> cont 2#; TComma -> cont 3#; @@ -645,7 +657,8 @@ TLowerName happy_dollar_dollar -> cont 23#; TUpperName happy_dollar_dollar -> cont 24#; TString happy_dollar_dollar -> cont 25#; - TNoBraces happy_dollar_dollar -> cont 26#; + TInteger happy_dollar_dollar -> cont 26#; + TNoBraces happy_dollar_dollar -> cont 27#; _ -> happyError' tk }) diff -Nru ghc-7.0.3/utils/genprimopcode/ParserM.hs ghc-7.2.1/utils/genprimopcode/ParserM.hs --- ghc-7.0.3/utils/genprimopcode/ParserM.hs 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/utils/genprimopcode/ParserM.hs 2011-08-07 17:10:05.000000000 +0000 @@ -81,6 +81,7 @@ | TUpperName String | TString String | TNoBraces String + | TInteger Int deriving Show -- Actions diff -Nru ghc-7.0.3/utils/genprimopcode/Parser.y.source ghc-7.2.1/utils/genprimopcode/Parser.y.source --- ghc-7.0.3/utils/genprimopcode/Parser.y.source 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/utils/genprimopcode/Parser.y.source 2011-08-07 17:10:05.000000000 +0000 @@ -1,5 +1,6 @@ { +{-# LANGUAGE BangPatterns #-} -- required for versions of Happy before 1.18.6 {-# OPTIONS -w -Wwarn #-} -- The above warning supression flag is a temporary kludge. -- While working on this module you are encouraged to remove it and fix @@ -47,6 +48,7 @@ lowerName { TLowerName $$ } upperName { TUpperName $$ } string { TString $$ } + integer { TInteger $$ } noBraces { TNoBraces $$ } %% @@ -65,6 +67,7 @@ pOption : lowerName '=' false { OptionFalse $1 } | lowerName '=' true { OptionTrue $1 } | lowerName '=' pStuffBetweenBraces { OptionString $1 $3 } + | lowerName '=' integer { OptionInteger $1 $3 } pEntries :: { [Entry] } pEntries : pEntry pEntries { $1 : $2 } diff -Nru ghc-7.0.3/utils/genprimopcode/Syntax.hs ghc-7.2.1/utils/genprimopcode/Syntax.hs --- ghc-7.0.3/utils/genprimopcode/Syntax.hs 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/utils/genprimopcode/Syntax.hs 2011-08-07 17:10:05.000000000 +0000 @@ -40,6 +40,7 @@ = OptionFalse String -- name = False | OptionTrue String -- name = True | OptionString String String -- name = { ... unparsed stuff ... } + | OptionInteger String Int -- name = deriving Show -- categorises primops @@ -109,8 +110,8 @@ | t1 == t2 && td == TyApp "Bool" [] = True sane_ty Monadic (TyF t1 td) | t1 == td = True -sane_ty Dyadic (TyF t1 (TyF t2 _)) - | t1 == t2 && t2 == t2 = True +sane_ty Dyadic (TyF t1 (TyF t2 td)) + | t1 == td && t2 == td = True sane_ty GenPrimOp _ = True sane_ty _ _ @@ -120,6 +121,7 @@ get_attrib_name (OptionFalse nm) = nm get_attrib_name (OptionTrue nm) = nm get_attrib_name (OptionString nm _) = nm +get_attrib_name (OptionInteger nm _) = nm lookup_attrib :: String -> [Option] -> Maybe Option lookup_attrib _ [] = Nothing diff -Nru ghc-7.0.3/utils/ghc-cabal/ghc-cabal.cabal ghc-7.2.1/utils/ghc-cabal/ghc-cabal.cabal --- ghc-7.0.3/utils/ghc-cabal/ghc-cabal.cabal 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/utils/ghc-cabal/ghc-cabal.cabal 2011-08-07 17:10:05.000000000 +0000 @@ -16,7 +16,7 @@ Main-Is: ghc-cabal.hs Build-Depends: base >= 3 && < 5, - Cabal >= 1.10 && < 1.12, + Cabal >= 1.10 && < 1.14, directory >= 1.1 && < 1.2, filepath >= 1.2 && < 1.3 diff -Nru ghc-7.0.3/utils/ghc-cabal/ghc.mk ghc-7.2.1/utils/ghc-cabal/ghc.mk --- ghc-7.0.3/utils/ghc-cabal/ghc.mk 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/utils/ghc-cabal/ghc.mk 2011-08-07 17:10:05.000000000 +0000 @@ -14,16 +14,16 @@ # Euch, hideous hack: # XXX This should be in a different Makefile -CABAL_DOTTED_VERSION := $(shell grep "^Version:" libraries/Cabal/Cabal.cabal | sed "s/^Version: //") +CABAL_DOTTED_VERSION := $(shell grep "^Version:" libraries/Cabal/cabal/Cabal.cabal | sed "s/^Version: //") CABAL_VERSION := $(subst .,$(comma),$(CABAL_DOTTED_VERSION)) CABAL_CONSTRAINT := --constraint="Cabal == $(CABAL_DOTTED_VERSION)" $(GHC_CABAL_INPLACE) : $(GHC_CABAL_DIR)/dist/build/tmp/ghc-cabal$(exeext) | $$(dir $$@)/. "$(CP)" $< $@ -$(GHC_CABAL_DIR)/dist/build/tmp/ghc-cabal$(exeext): $(wildcard libraries/Cabal/Distribution/*/*/*.hs) -$(GHC_CABAL_DIR)/dist/build/tmp/ghc-cabal$(exeext): $(wildcard libraries/Cabal/Distribution/*/*.hs) -$(GHC_CABAL_DIR)/dist/build/tmp/ghc-cabal$(exeext): $(wildcard libraries/Cabal/Distribution/*.hs) +$(GHC_CABAL_DIR)/dist/build/tmp/ghc-cabal$(exeext): $(wildcard libraries/Cabal/cabal/Distribution/*/*/*.hs) +$(GHC_CABAL_DIR)/dist/build/tmp/ghc-cabal$(exeext): $(wildcard libraries/Cabal/cabal/Distribution/*/*.hs) +$(GHC_CABAL_DIR)/dist/build/tmp/ghc-cabal$(exeext): $(wildcard libraries/Cabal/cabal/Distribution/*.hs) $(GHC_CABAL_DIR)/dist/build/tmp/ghc-cabal$(exeext): $(GHC_CABAL_DIR)/Main.hs | $$(dir $$@)/. bootstrapping/. "$(GHC)" $(SRC_HC_OPTS) --make $(GHC_CABAL_DIR)/Main.hs -o $@ \ @@ -32,9 +32,10 @@ -DCABAL_VERSION=$(CABAL_VERSION) \ -odir bootstrapping \ -hidir bootstrapping \ - -ilibraries/Cabal \ + -ilibraries/Cabal/cabal \ -ilibraries/filepath \ - -ilibraries/hpc + -ilibraries/hpc \ + $(utils/ghc-cabal_dist_EXTRA_HC_OPTS) touch $@ # touch is required, because otherwise if mkdirhier is newer, we diff -Nru ghc-7.0.3/utils/ghc-cabal/Main.hs ghc-7.2.1/utils/ghc-cabal/Main.hs --- ghc-7.0.3/utils/ghc-cabal/Main.hs 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/utils/ghc-cabal/Main.hs 2011-08-07 17:10:05.000000000 +0000 @@ -11,7 +11,7 @@ import Distribution.Simple.LocalBuildInfo import Distribution.Simple.Program import Distribution.Simple.Program.HcPkg -import Distribution.Simple.Utils (defaultPackageDesc, writeFileAtomic) +import Distribution.Simple.Utils (defaultPackageDesc, writeFileAtomic, toUTF8) import Distribution.Simple.Build (writeAutogenFiles) import Distribution.Simple.Register import Distribution.Text @@ -28,7 +28,8 @@ import System.FilePath main :: IO () -main = do args <- getArgs +main = do hSetBuffering stdout LineBuffering + args <- getArgs case args of "hscolour" : distDir : dir : args' -> runHsColour distDir dir args' @@ -295,10 +296,10 @@ pd lib lbi clbi final_ipi = installedPkgInfo { Installed.installedPackageId = ipid, - Installed.haddockHTMLs = ["../" ++ display (packageId pd)] + Installed.haddockHTMLs = [] } content = Installed.showInstalledPackageInfo final_ipi ++ "\n" - writeFileAtomic (distdir "inplace-pkg-config") content + writeFileAtomic (distdir "inplace-pkg-config") (toUTF8 content) _ -> error "Inconsistent lib components; can't happen?" let @@ -344,6 +345,9 @@ dep_ids = map snd (externalPackageDeps lbi) + wrappedIncludeDirs <- wrap $ forDeps Installed.includeDirs + wrappedLibraryDirs <- wrap $ forDeps Installed.libraryDirs + let variablePrefix = directory ++ '_':distdir let xs = [variablePrefix ++ "_VERSION = " ++ display (pkgVersion (package pd)), variablePrefix ++ "_MODULES = " ++ unwords (map display modules), @@ -358,30 +362,46 @@ variablePrefix ++ "_EXTRA_LIBRARIES = " ++ unwords (extraLibs bi), variablePrefix ++ "_EXTRA_LIBDIRS = " ++ unwords (extraLibDirs bi), variablePrefix ++ "_C_SRCS = " ++ unwords (cSources bi), - variablePrefix ++ "_CMM_SRCS = $(addprefix cbits/,$(notdir $(wildcard " ++ directory ++ "/cbits/*.cmm)))", + variablePrefix ++ "_CMM_SRCS := $(addprefix cbits/,$(notdir $(wildcard " ++ directory ++ "/cbits/*.cmm)))", variablePrefix ++ "_DATA_FILES = " ++ unwords (dataFiles pd), -- XXX This includes things it shouldn't, like: -- -odir dist-bootstrapping/build variablePrefix ++ "_HC_OPTS = " ++ escape (unwords ( programDefaultArgs ghcProg ++ hcOptions GHC bi + ++ languageToFlags (compiler lbi) (defaultLanguage bi) ++ extensionsToFlags (compiler lbi) (usedExtensions bi) ++ programOverrideArgs ghcProg)), - variablePrefix ++ "_CC_OPTS = " ++ unwords (ccOptions bi), - variablePrefix ++ "_CPP_OPTS = " ++ unwords (cppOptions bi), - variablePrefix ++ "_LD_OPTS = " ++ unwords (ldOptions bi), - variablePrefix ++ "_DEP_INCLUDE_DIRS = " ++ unwords (wrap $ forDeps Installed.includeDirs), - variablePrefix ++ "_DEP_CC_OPTS = " ++ unwords (forDeps Installed.ccOptions), - variablePrefix ++ "_DEP_LIB_DIRS = " ++ unwords (wrap $ forDeps Installed.libraryDirs), - variablePrefix ++ "_DEP_EXTRA_LIBS = " ++ unwords (forDeps Installed.extraLibraries), - variablePrefix ++ "_DEP_LD_OPTS = " ++ unwords (forDeps Installed.ldOptions), - variablePrefix ++ "_BUILD_GHCI_LIB = " ++ boolToYesNo (withGHCiLib lbi)] + variablePrefix ++ "_CC_OPTS = " ++ unwords (ccOptions bi), + variablePrefix ++ "_CPP_OPTS = " ++ unwords (cppOptions bi), + variablePrefix ++ "_LD_OPTS = " ++ unwords (ldOptions bi), + variablePrefix ++ "_DEP_INCLUDE_DIRS_SINGLE_QUOTED = " ++ unwords wrappedIncludeDirs, + variablePrefix ++ "_DEP_CC_OPTS = " ++ unwords (forDeps Installed.ccOptions), + variablePrefix ++ "_DEP_LIB_DIRS_SINGLE_QUOTED = " ++ unwords wrappedLibraryDirs, + variablePrefix ++ "_DEP_EXTRA_LIBS = " ++ unwords (forDeps Installed.extraLibraries), + variablePrefix ++ "_DEP_LD_OPTS = " ++ unwords (forDeps Installed.ldOptions), + variablePrefix ++ "_BUILD_GHCI_LIB = " ++ boolToYesNo (withGHCiLib lbi), + "", + -- Sometimes we need to modify the automatically-generated package-data.mk + -- bindings in a special way for the GHC build system, so allow that here: + "$(eval $(" ++ directory ++ "_PACKAGE_MAGIC))" + ] writeFile (distdir ++ "/package-data.mk") $ unlines xs - writeFile (distdir ++ "/haddock-prologue.txt") $ + writeFile (distdir ++ "/haddock-prologue.txt") $ if null (description pd) then synopsis pd else description pd where escape = foldr (\c xs -> if c == '#' then '\\':'#':xs else c:xs) [] - wrap = map (\s -> "\'" ++ s ++ "\'") + wrap = mapM wrap1 + wrap1 s + | null s = die ["Wrapping empty value"] + | '\'' `elem` s = die ["Single quote in value to be wrapped:", s] + -- We want to be able to assume things like is the + -- start of a value, so check there are no spaces in confusing + -- positions + | head s == ' ' = die ["Leading space in value to be wrapped:", s] + | last s == ' ' = die ["Trailing space in value to be wrapped:", s] + | otherwise = return ("\'" ++ s ++ "\'") boolToYesNo True = "YES" boolToYesNo False = "NO" + diff -Nru ghc-7.0.3/utils/ghc-pkg/ghc.mk ghc-7.2.1/utils/ghc-pkg/ghc.mk --- ghc-7.0.3/utils/ghc-pkg/ghc.mk 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/utils/ghc-pkg/ghc.mk 2011-08-07 17:10:05.000000000 +0000 @@ -44,9 +44,11 @@ endif -# depend on ghc-cabal, otherwise we build Cabal twice when building in parallel +# depend on ghc-cabal, otherwise we build Cabal twice when building in parallel. +# (ghc-cabal is an order-only dependency, we don't need to rebuild ghc-pkg +# if ghc-cabal is newer). # The binary package is not warning-clean, so we need a few -fno-warns here. -utils/ghc-pkg/dist/build/$(utils/ghc-pkg_dist_PROG)$(exeext): utils/ghc-pkg/Main.hs utils/ghc-pkg/Version.hs $(GHC_CABAL_INPLACE) | bootstrapping/. $$(dir $$@)/. +utils/ghc-pkg/dist/build/$(utils/ghc-pkg_dist_PROG)$(exeext): utils/ghc-pkg/Main.hs utils/ghc-pkg/Version.hs | bootstrapping/. $$(dir $$@)/. $(GHC_CABAL_INPLACE) "$(GHC)" $(SRC_HC_OPTS) --make utils/ghc-pkg/Main.hs -o $@ \ -no-user-package-conf \ -Wall -fno-warn-unused-imports \ @@ -56,11 +58,11 @@ -hidir bootstrapping \ -iutils/ghc-pkg \ -XCPP -XExistentialQuantification -XDeriveDataTypeable \ - -ilibraries/Cabal \ + -ilibraries/Cabal/cabal \ -ilibraries/filepath \ -ilibraries/extensible-exceptions \ -ilibraries/hpc \ - -ilibraries/ghc-binary/src \ + -ilibraries/binary/src \ -ilibraries/bin-package-db diff -Nru ghc-7.0.3/utils/ghc-pkg/ghc-pkg.cabal ghc-7.2.1/utils/ghc-pkg/ghc-pkg.cabal --- ghc-7.0.3/utils/ghc-pkg/ghc-pkg.cabal 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/utils/ghc-pkg/ghc-pkg.cabal 2011-08-07 17:10:05.000000000 +0000 @@ -16,15 +16,14 @@ Executable ghc-pkg Main-Is: Main.hs Other-Modules: Version - Extensions: CPP, ForeignFunctionInterface + Extensions: CPP, ForeignFunctionInterface, NondecreasingIndentation Build-Depends: base >= 4 && < 5, directory >= 1 && < 1.2, - process >= 1 && < 1.1, - haskell98, + process >= 1 && < 1.2, filepath, Cabal, - ghc-binary, + binary, bin-package-db, bytestring if !os(windows) diff -Nru ghc-7.0.3/utils/ghc-pkg/Main.hs ghc-7.2.1/utils/ghc-pkg/Main.hs --- ghc-7.0.3/utils/ghc-pkg/Main.hs 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/utils/ghc-pkg/Main.hs 2011-08-07 17:10:05.000000000 +0000 @@ -19,7 +19,8 @@ import Distribution.Package hiding (depends) import Distribution.Text import Distribution.Version -import System.FilePath +import System.FilePath as FilePath +import qualified System.FilePath.Posix as FilePath.Posix import System.Cmd ( rawSystem ) import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing, getModificationTime ) @@ -34,11 +35,12 @@ import Data.Char ( isSpace, toLower ) import Control.Monad import System.Directory ( doesDirectoryExist, getDirectoryContents, - doesFileExist, renameFile, removeFile ) + doesFileExist, renameFile, removeFile, + getCurrentDirectory ) import System.Exit ( exitWith, ExitCode(..) ) import System.Environment ( getArgs, getProgName, getEnv ) import System.IO -import System.IO.Error (try, isDoesNotExistError) +import System.IO.Error import Data.List import Control.Concurrent @@ -46,31 +48,24 @@ import qualified Data.Binary as Bin import qualified Data.Binary.Get as Bin -#if __GLASGOW_HASKELL__ < 612 || defined(mingw32_HOST_OS) +#if defined(mingw32_HOST_OS) -- mingw32 needs these for getExecDir, GHC <6.12 needs them for openNewFile import Foreign import Foreign.C #endif -#if __GLASGOW_HASKELL__ < 612 -import System.Posix.Internals -import GHC.Handle (fdToHandle) -#endif - #ifdef mingw32_HOST_OS import GHC.ConsoleHandler #else import System.Posix hiding (fdToHandle) #endif -import IO ( isPermissionError ) - #if defined(GLOB) import System.Process(runInteractiveCommand) import qualified System.Info(os) #endif -#if !defined(mingw32_HOST_OS) && __GLASGOW_HASKELL__ >= 611 && !defined(BOOTSTRAPPING) +#if !defined(mingw32_HOST_OS) && !defined(BOOTSTRAPPING) import System.Console.Terminfo as Terminfo #endif @@ -108,6 +103,9 @@ | FlagForce | FlagForceFiles | FlagAutoGHCiLibs + | FlagExpandEnvVars + | FlagExpandPkgroot + | FlagNoExpandPkgroot | FlagSimpleOutput | FlagNamesOnly | FlagIgnoreCase @@ -133,6 +131,12 @@ "ignore missing directories and libraries only", Option ['g'] ["auto-ghci-libs"] (NoArg FlagAutoGHCiLibs) "automatically build libs for GHCi (with register)", + Option [] ["expand-env-vars"] (NoArg FlagExpandEnvVars) + "expand environment variables (${name}-style) in input package descriptions", + Option [] ["expand-pkgroot"] (NoArg FlagExpandPkgroot) + "expand ${pkgroot}-relative paths to absolute in output package descriptions", + Option [] ["no-expand-pkgroot"] (NoArg FlagNoExpandPkgroot) + "preserve ${pkgroot}-relative paths in output package descriptions", Option ['?'] ["help"] (NoArg FlagHelp) "display this help and exit", Option ['V'] ["version"] (NoArg FlagVersion) @@ -194,6 +198,12 @@ " $p hide {pkg-id}\n" ++ " Hide the specified package.\n" ++ "\n" ++ + " $p trust {pkg-id}\n" ++ + " Trust the specified package.\n" ++ + "\n" ++ + " $p distrust {pkg-id}\n" ++ + " Distrust the specified package.\n" ++ + "\n" ++ " $p list [pkg]\n" ++ " List registered packages in the global database, and also the\n" ++ " user database if --user is given. If a package name is given\n" ++ @@ -281,6 +291,12 @@ | FlagForceFiles `elem` cli = ForceFiles | otherwise = NoForce auto_ghci_libs = FlagAutoGHCiLibs `elem` cli + expand_env_vars= FlagExpandEnvVars `elem` cli + mexpand_pkgroot= foldl' accumExpandPkgroot Nothing cli + where accumExpandPkgroot _ FlagExpandPkgroot = Just True + accumExpandPkgroot _ FlagNoExpandPkgroot = Just False + accumExpandPkgroot x _ = x + splitFields fields = unfoldr splitComma (',':fields) where splitComma "" = Nothing splitComma fs = Just $ break (==',') (tail fs) @@ -320,9 +336,11 @@ ["init", filename] -> initPackageDB filename verbosity cli ["register", filename] -> - registerPackage filename verbosity cli auto_ghci_libs False force + registerPackage filename verbosity cli + auto_ghci_libs expand_env_vars False force ["update", filename] -> - registerPackage filename verbosity cli auto_ghci_libs True force + registerPackage filename verbosity cli + auto_ghci_libs expand_env_vars True force ["unregister", pkgid_str] -> do pkgid <- readGlobPkgId pkgid_str unregisterPackage pkgid verbosity cli force @@ -332,6 +350,12 @@ ["hide", pkgid_str] -> do pkgid <- readGlobPkgId pkgid_str hidePackage pkgid verbosity cli force + ["trust", pkgid_str] -> do + pkgid <- readGlobPkgId pkgid_str + trustPackage pkgid verbosity cli force + ["distrust", pkgid_str] -> do + pkgid <- readGlobPkgId pkgid_str + distrustPackage pkgid verbosity cli force ["list"] -> do listPackages verbosity cli Nothing Nothing ["list", pkgid_str] -> @@ -347,23 +371,24 @@ ["latest", pkgid_str] -> do pkgid <- readGlobPkgId pkgid_str latestPackage verbosity cli pkgid - ["describe", pkgid_str] -> - case substringCheck pkgid_str of - Nothing -> do pkgid <- readGlobPkgId pkgid_str - describePackage verbosity cli (Id pkgid) - Just m -> describePackage verbosity cli (Substring pkgid_str m) - ["field", pkgid_str, fields] -> - case substringCheck pkgid_str of - Nothing -> do pkgid <- readGlobPkgId pkgid_str - describeField verbosity cli (Id pkgid) - (splitFields fields) - Just m -> describeField verbosity cli (Substring pkgid_str m) - (splitFields fields) + ["describe", pkgid_str] -> do + pkgarg <- case substringCheck pkgid_str of + Nothing -> liftM Id (readGlobPkgId pkgid_str) + Just m -> return (Substring pkgid_str m) + describePackage verbosity cli pkgarg (fromMaybe False mexpand_pkgroot) + + ["field", pkgid_str, fields] -> do + pkgarg <- case substringCheck pkgid_str of + Nothing -> liftM Id (readGlobPkgId pkgid_str) + Just m -> return (Substring pkgid_str m) + describeField verbosity cli pkgarg + (splitFields fields) (fromMaybe True mexpand_pkgroot) + ["check"] -> do checkConsistency verbosity cli ["dump"] -> do - dumpPackages verbosity cli + dumpPackages verbosity cli (fromMaybe False mexpand_pkgroot) ["recache"] -> do recache verbosity cli @@ -400,7 +425,7 @@ -- Package databases -- Some commands operate on a single database: --- register, unregister, expose, hide +-- register, unregister, expose, hide, trust, distrust -- however these commands also check the union of the available databases -- in order to check consistency. For example, register will check that -- dependencies exist before registering a package. @@ -409,8 +434,16 @@ -- list, describe, field data PackageDB - = PackageDB { location :: FilePath, - packages :: [InstalledPackageInfo] } + = PackageDB { + location, locationAbsolute :: !FilePath, + -- We need both possibly-relative and definately-absolute package + -- db locations. This is because the relative location is used as + -- an identifier for the db, so it is important we do not modify it. + -- On the other hand we need the absolute path in a few places + -- particularly in relation to the ${pkgroot} stuff. + + packages :: [InstalledPackageInfo] + } type PackageDBStack = [PackageDB] -- A stack of package databases. Convention: head is the topmost @@ -422,6 +455,7 @@ getPkgDatabases :: Verbosity -> Bool -- we are modifying, not reading -> Bool -- read caches, if available + -> Bool -- expand vars, like ${pkgroot} and $topdir -> [Flag] -> IO (PackageDBStack, -- the real package DB stack: [global,user] ++ @@ -434,7 +468,7 @@ -- is used as the list of package DBs for -- commands that just read the DB, such as 'list'. -getPkgDatabases verbosity modify use_cache my_flags = do +getPkgDatabases verbosity modify use_cache expand_vars my_flags = do -- first we determine the location of the global package config. On Windows, -- this is found relative to the ghc-pkg.exe binary, whereas on Unix the -- location is passed to the binary using the --global-config flag by the @@ -452,11 +486,17 @@ Just path -> return path fs -> return (last fs) + -- The value of the $topdir variable used in some package descriptions + -- Note that the way we calculate this is slightly different to how it + -- is done in ghc itself. We rely on the convention that the global + -- package db lives in ghc's libdir. + top_dir <- absolutePath (takeDirectory global_conf) + let no_user_db = FlagNoUserDb `elem` my_flags -- get the location of the user package database, and create it if necessary -- getAppUserDataDirectory can fail (e.g. if $HOME isn't set) - e_appdir <- try $ getAppUserDataDirectory "ghc" + e_appdir <- tryIO $ getAppUserDataDirectory "ghc" mb_user_conf <- if no_user_db then return Nothing else @@ -477,7 +517,7 @@ modify || user_exists = [user_conf, global_conf] | otherwise = [global_conf] - e_pkg_path <- try (System.Environment.getEnv "GHC_PACKAGE_PATH") + e_pkg_path <- tryIO (System.Environment.getEnv "GHC_PACKAGE_PATH") let env_stack = case e_pkg_path of Left _ -> sys_databases @@ -520,7 +560,11 @@ | null db_flags = Just virt_global_conf | otherwise = Just (last db_flags) - db_stack <- mapM (readParseDatabase verbosity mb_user_conf use_cache) final_stack + db_stack <- sequence + [ do db <- readParseDatabase verbosity mb_user_conf use_cache db_path + if expand_vars then return (mungePackageDBPaths top_dir db) + else return db + | db_path <- final_stack ] let flag_db_stack = [ db | db_name <- flag_db_names, db <- db_stack, location db == db_name ] @@ -546,19 +590,19 @@ readParseDatabase verbosity mb_user_conf use_cache path -- the user database (only) is allowed to be non-existent | Just (user_conf,False) <- mb_user_conf, path == user_conf - = return PackageDB { location = path, packages = [] } + = mkPackageDB [] | otherwise - = do e <- try $ getDirectoryContents path + = do e <- tryIO $ getDirectoryContents path case e of Left _ -> do pkgs <- parseMultiPackageConf verbosity path - return PackageDB{ location = path, packages = pkgs } + mkPackageDB pkgs Right fs | not use_cache -> ignore_cache | otherwise -> do let cache = path cachefilename tdir <- getModificationTime path - e_tcache <- try $ getModificationTime cache + e_tcache <- tryIO $ getModificationTime cache case e_tcache of Left ex -> do when (verbosity > Normal) $ @@ -570,7 +614,7 @@ putStrLn ("using cache: " ++ cache) pkgs <- myReadBinPackageDB cache let pkgs' = map convertPackageInfoIn pkgs - return PackageDB { location = path, packages = pkgs' } + mkPackageDB pkgs' | otherwise -> do when (verbosity >= Normal) $ do warn ("WARNING: cache is out of date: " ++ cache) @@ -581,7 +625,15 @@ let confs = filter (".conf" `isSuffixOf`) fs pkgs <- mapM (parseSingletonPackageConf verbosity) $ map (path ) confs - return PackageDB { location = path, packages = pkgs } + mkPackageDB pkgs + where + mkPackageDB pkgs = do + path_abs <- absolutePath path + return PackageDB { + location = path, + locationAbsolute = path_abs, + packages = pkgs + } -- read the package.cache file strictly, to work around a problem with -- bytestring 0.9.0.x (fixed in 0.9.1.x) where the file wasn't closed @@ -607,11 +659,72 @@ parseSingletonPackageConf :: Verbosity -> FilePath -> IO InstalledPackageInfo parseSingletonPackageConf verbosity file = do when (verbosity > Normal) $ putStrLn ("reading package config: " ++ file) - readUTF8File file >>= parsePackageInfo + readUTF8File file >>= fmap fst . parsePackageInfo cachefilename :: FilePath cachefilename = "package.cache" +mungePackageDBPaths :: FilePath -> PackageDB -> PackageDB +mungePackageDBPaths top_dir db@PackageDB { packages = pkgs } = + db { packages = map (mungePackagePaths top_dir pkgroot) pkgs } + where + pkgroot = takeDirectory (locationAbsolute db) + -- It so happens that for both styles of package db ("package.conf" + -- files and "package.conf.d" dirs) the pkgroot is the parent directory + -- ${pkgroot}/package.conf or ${pkgroot}/package.conf.d/ + +-- TODO: This code is duplicated in compiler/main/Packages.lhs +mungePackagePaths :: FilePath -> FilePath + -> InstalledPackageInfo -> InstalledPackageInfo +-- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec +-- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html) +-- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}. +-- The "pkgroot" is the directory containing the package database. +-- +-- Also perform a similar substitution for the older GHC-specific +-- "$topdir" variable. The "topdir" is the location of the ghc +-- installation (obtained from the -B option). +mungePackagePaths top_dir pkgroot pkg = + pkg { + importDirs = munge_paths (importDirs pkg), + includeDirs = munge_paths (includeDirs pkg), + libraryDirs = munge_paths (libraryDirs pkg), + frameworkDirs = munge_paths (frameworkDirs pkg), + haddockInterfaces = munge_paths (haddockInterfaces pkg), + -- haddock-html is allowed to be either a URL or a file + haddockHTMLs = munge_paths (munge_urls (haddockHTMLs pkg)) + } + where + munge_paths = map munge_path + munge_urls = map munge_url + + munge_path p + | Just p' <- stripVarPrefix "${pkgroot}" p = pkgroot ++ p' + | Just p' <- stripVarPrefix "$topdir" p = top_dir ++ p' + | otherwise = p + + munge_url p + | Just p' <- stripVarPrefix "${pkgrooturl}" p = toUrlPath pkgroot p' + | Just p' <- stripVarPrefix "$httptopdir" p = toUrlPath top_dir p' + | otherwise = p + + toUrlPath r p = "file:///" + -- URLs always use posix style '/' separators: + ++ FilePath.Posix.joinPath + (r : -- We need to drop a leading "/" or "\\" + -- if there is one: + dropWhile (all isPathSeparator) + (FilePath.splitDirectories p)) + + -- We could drop the separator here, and then use above. However, + -- by leaving it in and using ++ we keep the same path separator + -- rather than letting FilePath change it to use \ as the separator + stripVarPrefix var path = case stripPrefix var path of + Just [] -> Just [] + Just cs@(c : _) | isPathSeparator c -> Just cs + _ -> Nothing + + -- ----------------------------------------------------------------------------- -- Creating a new package DB @@ -622,7 +735,11 @@ when b1 eexist b2 <- doesDirectoryExist filename when b2 eexist - changeDB verbosity [] PackageDB{ location = filename, packages = [] } + filename_abs <- absolutePath filename + changeDB verbosity [] PackageDB { + location = filename, locationAbsolute = filename_abs, + packages = [] + } -- ----------------------------------------------------------------------------- -- Registering @@ -631,42 +748,54 @@ -> Verbosity -> [Flag] -> Bool -- auto_ghci_libs + -> Bool -- expand_env_vars -> Bool -- update -> Force -> IO () -registerPackage input verbosity my_flags auto_ghci_libs update force = do +registerPackage input verbosity my_flags auto_ghci_libs expand_env_vars update force = do (db_stack, Just to_modify, _flag_dbs) <- - getPkgDatabases verbosity True True my_flags + getPkgDatabases verbosity True True False{-expand vars-} my_flags let db_to_operate_on = my_head "register" $ filter ((== to_modify).location) db_stack -- + when (auto_ghci_libs && verbosity >= Silent) $ + warn "Warning: --auto-ghci-libs is deprecated and will be removed in GHC 7.4" + -- s <- case input of "-" -> do when (verbosity >= Normal) $ putStr "Reading package info from stdin ... " -#if __GLASGOW_HASKELL__ >= 612 -- fix the encoding to UTF-8, since this is an interchange format hSetEncoding stdin utf8 -#endif getContents f -> do when (verbosity >= Normal) $ putStr ("Reading package info from " ++ show f ++ " ... ") readUTF8File f - expanded <- expandEnvVars s force + expanded <- if expand_env_vars then expandEnvVars s force + else return s - pkg <- parsePackageInfo expanded + (pkg, ws) <- parsePackageInfo expanded when (verbosity >= Normal) $ putStrLn "done." + -- report any warnings from the parse phase + _ <- reportValidateErrors [] ws + (display (sourcePackageId pkg) ++ ": Warning: ") Nothing + + -- validate the expanded pkg, but register the unexpanded + pkgroot <- absolutePath (takeDirectory to_modify) + let top_dir = takeDirectory (location (last db_stack)) + pkg_expanded = mungePackagePaths top_dir pkgroot pkg + let truncated_stack = dropWhile ((/= to_modify).location) db_stack -- truncate the stack for validation, because we don't allow -- packages lower in the stack to refer to those higher up. - validatePackageConfig pkg truncated_stack auto_ghci_libs update force + validatePackageConfig pkg_expanded truncated_stack auto_ghci_libs update force let removes = [ RemovePackage p | p <- packages db_to_operate_on, @@ -676,10 +805,13 @@ parsePackageInfo :: String - -> IO InstalledPackageInfo + -> IO (InstalledPackageInfo, [ValidateWarning]) parsePackageInfo str = case parseInstalledPackageInfo str of - ParseOk _warns ok -> return ok + ParseOk warnings ok -> return (ok, ws) + where + ws = [ msg | PWarning msg <- warnings + , not ("Unrecognized field pkgroot" `isPrefixOf` msg) ] ParseFailed err -> case locatedErrorMsg err of (Nothing, s) -> die s (Just l, s) -> die (show l ++ ": " ++ s) @@ -733,13 +865,13 @@ when (verbosity > Normal) $ putStrLn ("writing cache " ++ filename) writeBinaryFileAtomic filename (map convertPackageInfoOut (packages db)) - `catch` \e -> + `catchIO` \e -> if isPermissionError e then die (filename ++ ": you don't have permission to modify this file") else ioError e -- ----------------------------------------------------------------------------- --- Exposing, Hiding, Unregistering are all similar +-- Exposing, Hiding, Trusting, Distrusting, Unregistering are all similar exposePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO () exposePackage = modifyPackage (\p -> ModifyPackage p{exposed=True}) @@ -747,6 +879,12 @@ hidePackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO () hidePackage = modifyPackage (\p -> ModifyPackage p{exposed=False}) +trustPackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO () +trustPackage = modifyPackage (\p -> ModifyPackage p{trusted=True}) + +distrustPackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO () +distrustPackage = modifyPackage (\p -> ModifyPackage p{trusted=False}) + unregisterPackage :: PackageIdentifier -> Verbosity -> [Flag] -> Force -> IO () unregisterPackage = modifyPackage RemovePackage @@ -759,7 +897,7 @@ -> IO () modifyPackage fn pkgid verbosity my_flags force = do (db_stack, Just _to_modify, _flag_dbs) <- - getPkgDatabases verbosity True{-modify-} True{-use cache-} my_flags + getPkgDatabases verbosity True{-modify-} True{-use cache-} False{-expand vars-} my_flags (db, ps) <- fmap head $ findPackagesByDB db_stack (Id pkgid) let @@ -787,7 +925,7 @@ recache :: Verbosity -> [Flag] -> IO () recache verbosity my_flags = do (db_stack, Just to_modify, _flag_dbs) <- - getPkgDatabases verbosity True{-modify-} False{-no cache-} my_flags + getPkgDatabases verbosity True{-modify-} False{-no cache-} False{-expand vars-} my_flags let db_to_operate_on = my_head "recache" $ filter ((== to_modify).location) db_stack @@ -803,7 +941,7 @@ listPackages verbosity my_flags mPackageName mModuleName = do let simple_output = FlagSimpleOutput `elem` my_flags (db_stack, _, flag_db_stack) <- - getPkgDatabases verbosity False True{-use cache-} my_flags + getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} my_flags let db_stack_filtered -- if a package is given, filter out all other packages | Just this <- mPackageName = @@ -854,7 +992,7 @@ if simple_output then show_simple stack else do -#if defined(mingw32_HOST_OS) || __GLASGOW_HASKELL__ < 611 || defined(BOOTSTRAPPING) +#if defined(mingw32_HOST_OS) || defined(BOOTSTRAPPING) mapM_ show_normal stack #else let @@ -896,7 +1034,7 @@ showPackageDot :: Verbosity -> [Flag] -> IO () showPackageDot verbosity myflags = do (_, _, flag_db_stack) <- - getPkgDatabases verbosity False True{-use cache-} myflags + getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} myflags let all_pkgs = allPackagesInStack flag_db_stack ipix = PackageIndex.fromList all_pkgs @@ -918,7 +1056,7 @@ latestPackage :: Verbosity -> [Flag] -> PackageIdentifier -> IO () latestPackage verbosity my_flags pkgid = do (_, _, flag_db_stack) <- - getPkgDatabases verbosity False True{-use cache-} my_flags + getPkgDatabases verbosity False True{-use cache-} False{-expand vars-} my_flags ps <- findPackages flag_db_stack (Id pkgid) show_pkg (sortBy compPkgIdVer (map sourcePackageId ps)) @@ -929,26 +1067,33 @@ -- ----------------------------------------------------------------------------- -- Describe -describePackage :: Verbosity -> [Flag] -> PackageArg -> IO () -describePackage verbosity my_flags pkgarg = do +describePackage :: Verbosity -> [Flag] -> PackageArg -> Bool -> IO () +describePackage verbosity my_flags pkgarg expand_pkgroot = do (_, _, flag_db_stack) <- - getPkgDatabases verbosity False True{-use cache-} my_flags - ps <- findPackages flag_db_stack pkgarg - doDump ps + getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags + dbs <- findPackagesByDB flag_db_stack pkgarg + doDump expand_pkgroot [ (pkg, locationAbsolute db) + | (db, pkgs) <- dbs, pkg <- pkgs ] -dumpPackages :: Verbosity -> [Flag] -> IO () -dumpPackages verbosity my_flags = do +dumpPackages :: Verbosity -> [Flag] -> Bool -> IO () +dumpPackages verbosity my_flags expand_pkgroot = do (_, _, flag_db_stack) <- - getPkgDatabases verbosity False True{-use cache-} my_flags - doDump (allPackagesInStack flag_db_stack) + getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags + doDump expand_pkgroot [ (pkg, locationAbsolute db) + | db <- flag_db_stack, pkg <- packages db ] -doDump :: [InstalledPackageInfo] -> IO () -doDump pkgs = do -#if __GLASGOW_HASKELL__ >= 612 +doDump :: Bool -> [(InstalledPackageInfo, FilePath)] -> IO () +doDump expand_pkgroot pkgs = do -- fix the encoding to UTF-8, since this is an interchange format hSetEncoding stdout utf8 -#endif - mapM_ putStrLn . intersperse "---" . map showInstalledPackageInfo $ pkgs + putStrLn $ + intercalate "---\n" + [ if expand_pkgroot + then showInstalledPackageInfo pkg + else showInstalledPackageInfo pkg ++ pkgrootField + | (pkg, pkgloc) <- pkgs + , let pkgroot = takeDirectory pkgloc + pkgrootField = "pkgroot: " ++ show pkgroot ++ "\n" ] -- PackageId is can have globVersion for the version findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo] @@ -987,14 +1132,13 @@ -- ----------------------------------------------------------------------------- -- Field -describeField :: Verbosity -> [Flag] -> PackageArg -> [String] -> IO () -describeField verbosity my_flags pkgarg fields = do +describeField :: Verbosity -> [Flag] -> PackageArg -> [String] -> Bool -> IO () +describeField verbosity my_flags pkgarg fields expand_pkgroot = do (_, _, flag_db_stack) <- - getPkgDatabases verbosity False True{-use cache-} my_flags + getPkgDatabases verbosity False True{-use cache-} expand_pkgroot my_flags fns <- toFields fields ps <- findPackages flag_db_stack pkgarg - let top_dir = takeDirectory (location (last flag_db_stack)) - mapM_ (selectFields fns) (mungePackagePaths top_dir ps) + mapM_ (selectFields fns) ps where toFields [] = return [] toFields (f:fs) = case toField f of Nothing -> die ("unknown field: " ++ f) @@ -1002,35 +1146,6 @@ return (fn:fns) selectFields fns info = mapM_ (\fn->putStrLn (fn info)) fns -mungePackagePaths :: String -> [InstalledPackageInfo] -> [InstalledPackageInfo] --- Replace the strings "$topdir" and "$httptopdir" at the beginning of a path --- with the current topdir (obtained from the -B option). -mungePackagePaths top_dir ps = map munge_pkg ps - where - munge_pkg p = p{ importDirs = munge_paths (importDirs p), - includeDirs = munge_paths (includeDirs p), - libraryDirs = munge_paths (libraryDirs p), - frameworkDirs = munge_paths (frameworkDirs p), - haddockInterfaces = munge_paths (haddockInterfaces p), - haddockHTMLs = munge_paths (haddockHTMLs p) - } - - munge_paths = map munge_path - - munge_path p - | Just p' <- maybePrefixMatch "$topdir" p = top_dir ++ p' - | Just p' <- maybePrefixMatch "$httptopdir" p = toHttpPath top_dir ++ p' - | otherwise = p - - toHttpPath p = "file:///" ++ p - -maybePrefixMatch :: String -> String -> Maybe String -maybePrefixMatch [] rest = Just rest -maybePrefixMatch (_:_) [] = Nothing -maybePrefixMatch (p:pat) (r:rest) - | p == r = maybePrefixMatch pat rest - | otherwise = Nothing - toField :: String -> Maybe (InstalledPackageInfo -> String) -- backwards compatibility: toField "import_dirs" = Just $ strList . importDirs @@ -1056,7 +1171,8 @@ checkConsistency :: Verbosity -> [Flag] -> IO () checkConsistency verbosity my_flags = do - (db_stack, _, _) <- getPkgDatabases verbosity True True{-use cache-} my_flags + (db_stack, _, _) <- + getPkgDatabases verbosity True True{-use cache-} True{-expand vars-} my_flags -- check behaves like modify for the purposes of deciding which -- databases to use, because ordering is important. @@ -1149,7 +1265,7 @@ $ map (show . convertPackageInfoOut) ipis fileContents = "[" ++ shown ++ "\n]" writeFileUtf8Atomic filename fileContents - `catch` \e -> + `catchIO` \e -> if isPermissionError e then die (filename ++ ": you don't have permission to modify this file") else ioError e @@ -1229,6 +1345,9 @@ mapM_ (checkDir False "import-dirs") (importDirs pkg) mapM_ (checkDir True "library-dirs") (libraryDirs pkg) mapM_ (checkDir True "include-dirs") (includeDirs pkg) + mapM_ (checkDir True "framework-dirs") (frameworkDirs pkg) + mapM_ (checkFile True "haddock-interfaces") (haddockInterfaces pkg) + mapM_ (checkDirURL True "haddock-html") (haddockHTMLs pkg) checkModules pkg mapM_ (checkHSLib (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg) -- ToDo: check these somehow? @@ -1280,19 +1399,34 @@ "Package " ++ display pkgid ++ " overlaps with: " ++ unwords (map display dups) +checkDir, checkFile, checkDirURL :: Bool -> String -> FilePath -> Validate () +checkDir = checkPath False True +checkFile = checkPath False False +checkDirURL = checkPath True True + +checkPath :: Bool -> Bool -> Bool -> String -> FilePath -> Validate () +checkPath url_ok is_dir warn_only thisfield d + | url_ok && ("http://" `isPrefixOf` d + || "https://" `isPrefixOf` d) = return () + + | url_ok + , Just d' <- stripPrefix "file://" d + = checkPath False is_dir warn_only thisfield d' + + -- Note: we don't check for $topdir/${pkgroot} here. We rely on these + -- variables having been expanded already, see mungePackagePaths. -checkDir :: Bool -> String -> String -> Validate () -checkDir warn_only thisfield d - | "$topdir" `isPrefixOf` d = return () - | "$httptopdir" `isPrefixOf` d = return () - -- can't check these, because we don't know what $(http)topdir is | isRelative d = verror ForceFiles $ - thisfield ++ ": " ++ d ++ " is a relative path" + thisfield ++ ": " ++ d ++ " is a relative path which " + ++ "makes no sense (as there is nothing for it to be " + ++ "relative to). You can make paths relative to the " + ++ "package database itself by using ${pkgroot}." -- relative paths don't make any sense; #4134 | otherwise = do - there <- liftIO $ doesDirectoryExist d + there <- liftIO $ if is_dir then doesDirectoryExist d else doesFileExist d when (not there) $ - let msg = thisfield ++ ": " ++ d ++ " doesn't exist or isn't a directory" + let msg = thisfield ++ ": " ++ d ++ " doesn't exist or isn't a " + ++ if is_dir then "directory" else "file" in if warn_only then vwarn msg @@ -1331,10 +1465,7 @@ if b then return (Just p) else go ps doesFileExistIn :: String -> String -> IO Bool -doesFileExistIn lib d - | "$topdir" `isPrefixOf` d = return True - | "$httptopdir" `isPrefixOf` d = return True - | otherwise = doesFileExist (d lib) +doesFileExistIn lib d = doesFileExist (d lib) checkModules :: InstalledPackageInfo -> Validate () checkModules pkg = do @@ -1385,7 +1516,7 @@ return (concat mms) searchDir path prefix = do - fs <- getDirectoryEntries path `catch` \_ -> return [] + fs <- getDirectoryEntries path `catchIO` \_ -> return [] searchEntries path prefix fs searchEntries path prefix [] = return [] @@ -1427,8 +1558,10 @@ = go str (c:acc) lookupEnvVar :: String -> IO String + lookupEnvVar "pkgroot" = return "${pkgroot}" -- these two are special, + lookupEnvVar "pkgrooturl" = return "${pkgrooturl}" -- we don't expand them lookupEnvVar nm = - catch (System.Environment.getEnv nm) + catchIO (System.Environment.getEnv nm) (\ _ -> do dieOrForceAll force ("Unable to expand variable " ++ show nm) return "") @@ -1498,16 +1631,17 @@ removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath getExecPath :: IO (Maybe String) -getExecPath = - allocaArray len $ \buf -> do - ret <- getModuleFileName nullPtr buf len - if ret == 0 then return Nothing - else liftM Just $ peekCString buf - where len = 2048 -- Plenty, PATH_MAX is 512 under Win32. - -foreign import stdcall unsafe "GetModuleFileNameA" - getModuleFileName :: Ptr () -> CString -> Int -> IO Int32 +getExecPath = try_size 2048 -- plenty, PATH_MAX is 512 under Win32. + where + try_size size = allocaArray (fromIntegral size) $ \buf -> do + ret <- c_GetModuleFileName nullPtr buf size + case ret of + 0 -> return Nothing + _ | ret < size -> fmap Just $ peekCWString buf + | otherwise -> try_size (size * 2) +foreign import stdcall unsafe "windows.h GetModuleFileNameW" + c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32 #else getLibDir :: IO (Maybe String) getLibDir = return Nothing @@ -1544,15 +1678,17 @@ #if mingw32_HOST_OS || mingw32_TARGET_OS throwIOIO :: Exception.IOException -> IO a throwIOIO = Exception.throwIO +#endif catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a catchIO = Exception.catch -#endif catchError :: IO a -> (String -> IO a) -> IO a catchError io handler = io `Exception.catch` handler' where handler' (Exception.ErrorCall err) = handler err +tryIO :: IO a -> IO (Either Exception.IOException a) +tryIO = Exception.try writeBinaryFileAtomic :: Bin.Binary a => FilePath -> a -> IO () writeBinaryFileAtomic targetFile obj = @@ -1563,9 +1699,7 @@ writeFileUtf8Atomic :: FilePath -> String -> IO () writeFileUtf8Atomic targetFile content = withFileAtomic targetFile $ \h -> do -#if __GLASGOW_HASKELL__ >= 612 hSetEncoding h utf8 -#endif hPutStr h content -- copied from Cabal's Distribution.Simple.Utils, except that we want @@ -1602,65 +1736,10 @@ openNewFile :: FilePath -> String -> IO (FilePath, Handle) openNewFile dir template = do -#if __GLASGOW_HASKELL__ >= 612 -- this was added to System.IO in 6.12.1 -- we must use this version because the version below opens the file -- in binary mode. openTempFileWithDefaultPermissions dir template -#else - -- Ugh, this is a copy/paste of code from the base library, but - -- if uses 666 rather than 600 for the permissions. - pid <- c_getpid - findTempName pid - where - -- We split off the last extension, so we can use .foo.ext files - -- for temporary files (hidden on Unix OSes). Unfortunately we're - -- below filepath in the hierarchy here. - (prefix,suffix) = - case break (== '.') $ reverse template of - -- First case: template contains no '.'s. Just re-reverse it. - (rev_suffix, "") -> (reverse rev_suffix, "") - -- Second case: template contains at least one '.'. Strip the - -- dot from the prefix and prepend it to the suffix (if we don't - -- do this, the unique number will get added after the '.' and - -- thus be part of the extension, which is wrong.) - (rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix) - -- Otherwise, something is wrong, because (break (== '.')) should - -- always return a pair with either the empty string or a string - -- beginning with '.' as the second component. - _ -> error "bug in System.IO.openTempFile" - - oflags = rw_flags .|. o_EXCL - - withFilePath = withCString - - findTempName x = do - fd <- withFilePath filepath $ \ f -> - c_open f oflags 0o666 - if fd < 0 - then do - errno <- getErrno - if errno == eEXIST - then findTempName (x+1) - else ioError (errnoToIOError "openNewBinaryFile" errno Nothing (Just dir)) - else do - -- XXX We want to tell fdToHandle what the filepath is, - -- as any exceptions etc will only be able to report the - -- fd currently - h <- - fdToHandle fd - `Exception.onException` c_close fd - return (filepath, h) - where - filename = prefix ++ show x ++ suffix - filepath = dir `combine` filename - --- XXX Copied from GHC.Handle -std_flags, output_flags, rw_flags :: CInt -std_flags = o_NONBLOCK .|. o_NOCTTY -output_flags = std_flags .|. o_CREAT -rw_flags = output_flags .|. o_RDWR -#endif /* GLASGOW_HASKELL < 612 */ -- | The function splits the given string to substrings -- using 'isSearchPathSeparator'. @@ -1685,14 +1764,15 @@ readUTF8File :: FilePath -> IO String readUTF8File file = do h <- openFile file ReadMode -#if __GLASGOW_HASKELL__ >= 612 -- fix the encoding to UTF-8 hSetEncoding h utf8 -#endif hGetContents h -- removeFileSave doesn't throw an exceptions, if the file is already deleted removeFileSafe :: FilePath -> IO () removeFileSafe fn = - removeFile fn `catch` \ e -> + removeFile fn `catchIO` \ e -> when (not $ isDoesNotExistError e) $ ioError e + +absolutePath :: FilePath -> IO FilePath +absolutePath path = return . normalise . ( path) =<< getCurrentDirectory diff -Nru ghc-7.0.3/utils/ghc-pwd/ghc.mk ghc-7.2.1/utils/ghc-pwd/ghc.mk --- ghc-7.0.3/utils/ghc-pwd/ghc.mk 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/utils/ghc-pwd/ghc.mk 2011-08-07 17:10:05.000000000 +0000 @@ -1,7 +1,7 @@ utils/ghc-pwd_USES_CABAL = YES utils/ghc-pwd_PACKAGE = ghc-pwd -utils/ghc-pwd_dist_PROG = ghc-pwd$(exeext) +utils/ghc-pwd_dist-install_PROG = ghc-pwd$(exeext) -$(eval $(call build-prog,utils/ghc-pwd,dist,1)) +$(eval $(call build-prog,utils/ghc-pwd,dist-install,1)) diff -Nru ghc-7.0.3/utils/ghctags/ghc.mk ghc-7.2.1/utils/ghctags/ghc.mk --- ghc-7.0.3/utils/ghctags/ghc.mk 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/utils/ghctags/ghc.mk 2011-08-07 17:10:05.000000000 +0000 @@ -10,8 +10,8 @@ # # ----------------------------------------------------------------------------- -utils/ghctags_dist_MODULES = Main -utils/ghctags_dist_HC_OPTS = -package ghc -utils/ghctags_dist_INSTALL = NO -utils/ghctags_dist_PROG = ghctags$(exeext) -$(eval $(call build-prog,utils/ghctags,dist,2)) +utils/ghctags_dist-install_MODULES = Main +utils/ghctags_dist-install_HC_OPTS = -package ghc +utils/ghctags_dist-install_INSTALL = NO +utils/ghctags_dist-install_PROG = ghctags$(exeext) +$(eval $(call build-prog,utils/ghctags,dist-install,2)) diff -Nru ghc-7.0.3/utils/ghctags/Main.hs ghc-7.2.1/utils/ghctags/Main.hs --- ghc-7.0.3/utils/ghctags/Main.hs 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/utils/ghctags/Main.hs 2011-08-07 17:10:05.000000000 +0000 @@ -10,11 +10,13 @@ import HscTypes ( msHsFilePath ) import Name ( getOccString ) --import ErrUtils ( printBagOfErrors ) -import DynFlags ( defaultDynFlags ) +import Panic ( panic ) +import DynFlags ( defaultLogAction ) import Bag import Exception import FastString import MonadUtils ( liftIO ) +import SrcLoc -- Every GHC comes with Cabal anyways, so this is not a bad new dependency import Distribution.Simple.GHC ( ghcOptions ) @@ -48,7 +50,7 @@ type ThingName = String -- name of a defined entity in a Haskell program -- A definition we have found (we know its containing module, name, and location) -data FoundThing = FoundThing ModuleName ThingName SrcLoc +data FoundThing = FoundThing ModuleName ThingName RealSrcLoc -- Data we have obtained from a file (list of things we found) data FileData = FileData FileName [FoundThing] (Map Int String) @@ -100,7 +102,7 @@ then Just `liftM` openFile "TAGS" openFileMode else return Nothing - GHC.defaultErrorHandler defaultDynFlags $ + GHC.defaultErrorHandler defaultLogAction $ runGhc (Just ghc_topdir) $ do --liftIO $ print "starting up session" dflags <- getSessionDynFlags @@ -195,7 +197,7 @@ safeLoad mode = do _dflags <- getSessionDynFlags ghandle (\(e :: SomeException) -> liftIO (print e) >> return Failed ) $ - handleSourceError (\e -> printExceptionAndWarnings e >> return Failed) $ + handleSourceError (\e -> printException e >> return Failed) $ load mode @@ -221,7 +223,7 @@ let filename = msHsFilePath ms modname = moduleName $ ms_mod ms in handleSourceError (\e -> do - printExceptionAndWarnings e + printException e liftIO $ exitWith (ExitFailure 1)) $ do liftIO $ putStrLn ("loading " ++ filename) mod <- loadModule =<< typecheckModule =<< parseModule ms @@ -260,8 +262,10 @@ in vals ++ tys ++ fors where found = foundOfLName mod -startOfLocated :: Located a -> SrcLoc -startOfLocated lHs = srcSpanStart $ getLoc lHs +startOfLocated :: Located a -> RealSrcLoc +startOfLocated lHs = case getLoc lHs of + RealSrcSpan l -> realSrcSpanStart l + UnhelpfulSpan _ -> panic "startOfLocated UnhelpfulSpan" foundOfLName :: ModuleName -> Located Name -> FoundThing foundOfLName mod id = FoundThing mod (getOccString $ unLoc id) (startOfLocated id) @@ -280,7 +284,6 @@ in case unLoc lpat of WildPat _ -> tl VarPat name -> lid name : tl - VarPatOut name _ -> lid name : tl -- XXX need help here LazyPat p -> patThings p tl AsPat id p -> patThings p (thing id : tl) ParPat p -> patThings p tl @@ -293,7 +296,6 @@ LitPat _ -> tl NPat _ _ _ -> tl -- form of literal pattern? NPlusKPat id _ _ _ -> thing id : tl - TypePat _ -> tl -- XXX need help here SigPatIn p _ -> patThings p tl SigPatOut p _ -> patThings p tl _ -> error "boundThings" diff -Nru ghc-7.0.3/utils/haddock/CHANGES ghc-7.2.1/utils/haddock/CHANGES --- ghc-7.0.3/utils/haddock/CHANGES 2011-03-26 18:10:10.000000000 +0000 +++ ghc-7.2.1/utils/haddock/CHANGES 2011-08-07 17:10:06.000000000 +0000 @@ -1,5 +1,7 @@ Changes in version 2.9.2 + * Build with GHC 7.0.2 + * Write Hoogle output in utf8; fixes GHC build on Windows Changes in version 2.9.1 diff -Nru ghc-7.0.3/utils/haddock/doc/haddock.xml ghc-7.2.1/utils/haddock/doc/haddock.xml --- ghc-7.0.3/utils/haddock/doc/haddock.xml 2011-03-26 18:10:10.000000000 +0000 +++ ghc-7.2.1/utils/haddock/doc/haddock.xml 2011-08-07 17:10:06.000000000 +0000 @@ -936,7 +936,7 @@ ignore-exports attribute (). This might be useful for generating implementation documentation rather than interface - documetnation, for example. + documentation, for example. @@ -1667,6 +1667,9 @@ -- foo -- bar + Result lines that only contain the string + <BLANKLINE> are rendered as blank lines in the + generated documenation. diff -Nru ghc-7.0.3/utils/haddock/haddock.cabal ghc-7.2.1/utils/haddock/haddock.cabal --- ghc-7.0.3/utils/haddock/haddock.cabal 2011-03-26 18:10:10.000000000 +0000 +++ ghc-7.2.1/utils/haddock/haddock.cabal 2011-08-07 17:10:06.000000000 +0000 @@ -75,7 +75,7 @@ executable haddock default-language: Haskell2010 build-depends: - base == 4.3.*, + base >= 4.3 && < 4.5, filepath, directory, pretty, @@ -83,7 +83,7 @@ array, xhtml >= 3000.2 && < 3000.3, Cabal >= 1.10, - ghc >= 7.0 && < 7.2 + ghc >= 7.0 && < 7.4 if flag(in-ghc-tree) cpp-options: -DIN_GHC_TREE @@ -135,7 +135,7 @@ library default-language: Haskell2010 build-depends: - base == 4.3.*, + base >= 4.3 && < 4.5, filepath, directory, pretty, @@ -143,7 +143,7 @@ array, xhtml >= 3000.2 && < 3000.3, Cabal >= 1.10, - ghc >= 7.0 && < 7.2 + ghc >= 7.0 && < 7.4 if flag(in-ghc-tree) cpp-options: -DIN_GHC_TREE @@ -198,3 +198,11 @@ if flag(in-ghc-tree) buildable: False + +test-suite html-tests + type: exitcode-stdio-1.0 + default-language: Haskell2010 + main-is: runtests.hs + hs-source-dirs: tests/html-tests + build-depends: base, directory, process, filepath, Cabal, regex-compat + diff -Nru ghc-7.0.3/utils/haddock/src/Haddock/Backends/Hoogle.hs ghc-7.2.1/utils/haddock/src/Haddock/Backends/Hoogle.hs --- ghc-7.0.3/utils/haddock/src/Haddock/Backends/Hoogle.hs 2011-03-26 18:10:10.000000000 +0000 +++ ghc-7.2.1/utils/haddock/src/Haddock/Backends/Hoogle.hs 2011-08-07 17:10:06.000000000 +0000 @@ -114,16 +114,17 @@ f (TyClD d@TyData{}) = ppData d subdocs f (TyClD d@ClassDecl{}) = ppClass d f (TyClD d@TySynonym{}) = ppSynonym d - f (ForD (ForeignImport name typ _)) = ppSig $ TypeSig name typ - f (ForD (ForeignExport name typ _)) = ppSig $ TypeSig name typ + f (ForD (ForeignImport name typ _)) = ppSig $ TypeSig [name] typ + f (ForD (ForeignExport name typ _)) = ppSig $ TypeSig [name] typ f (SigD sig) = ppSig sig f _ = [] ppExport _ = [] ppSig :: Sig Name -> [String] -ppSig (TypeSig name sig) = [operator (out name) ++ " :: " ++ outHsType typ] +ppSig (TypeSig names sig) = [operator prettyNames ++ " :: " ++ outHsType typ] where + prettyNames = concat . intersperse ", " $ map out names typ = case unL sig of HsForAllTy Explicit a b c -> HsForAllTy Implicit a b c x -> x diff -Nru ghc-7.0.3/utils/haddock/src/Haddock/Backends/LaTeX.hs ghc-7.2.1/utils/haddock/src/Haddock/Backends/LaTeX.hs --- ghc-7.0.3/utils/haddock/src/Haddock/Backends/LaTeX.hs 2011-03-26 18:10:10.000000000 +0000 +++ ghc-7.2.1/utils/haddock/src/Haddock/Backends/LaTeX.hs 2011-08-07 17:10:06.000000000 +0000 @@ -177,7 +177,7 @@ exportListItem :: ExportItem DocName -> LaTeX exportListItem (ExportDecl decl _doc subdocs _insts) - = ppDocBinder (declName decl) <> + = sep (punctuate comma . map ppDocBinder $ declNames decl) <> case subdocs of [] -> empty _ -> parens (sep (punctuate comma (map (ppDocBinder . fst) subdocs))) @@ -197,8 +197,8 @@ processExports [] = empty processExports (decl : es) | Just sig <- isSimpleSig decl - = multiDecl [ ppTypeSig (getName name) typ False - | (name,typ) <- sig:sigs ] $$ + = multiDecl [ ppTypeSig (map getName names) typ False + | (names,typ) <- sig:sigs ] $$ processExports es' where (sigs, es') = spanWith isSimpleSig es processExports (ExportModule mdl : es) @@ -209,10 +209,10 @@ processExport e $$ processExports es -isSimpleSig :: ExportItem DocName -> Maybe (DocName, HsType DocName) -isSimpleSig (ExportDecl (L _ (SigD (TypeSig (L _ n) (L _ t)))) +isSimpleSig :: ExportItem DocName -> Maybe ([DocName], HsType DocName) +isSimpleSig (ExportDecl (L _ (SigD (TypeSig lnames (L _ t)))) (Nothing, argDocs) _ _) - | Map.null argDocs = Just (n, t) + | Map.null argDocs = Just (map unLoc lnames, t) isSimpleSig _ = Nothing @@ -244,11 +244,11 @@ sec _ = text "\\paragraph" -declName :: LHsDecl DocName -> DocName -declName (L _ decl) = case decl of - TyClD d -> unLoc $ tcdLName d - SigD (TypeSig (L _ n) _) -> n - _ -> error "declaration not supported by declName" +declNames :: LHsDecl DocName -> [DocName] +declNames (L _ decl) = case decl of + TyClD d -> [unLoc $ tcdLName d] + SigD (TypeSig lnames _) -> map unLoc lnames + _ -> error "declaration not supported by declNames" forSummary :: (ExportItem DocName) -> Bool @@ -286,7 +286,7 @@ | Nothing <- tcdTyPats d -> ppTySyn loc (mbDoc, fnArgsDoc) d unicode | Just _ <- tcdTyPats d -> ppTyInst False loc mbDoc d unicode TyClD d@(ClassDecl {}) -> ppClassDecl instances loc mbDoc subdocs d unicode - SigD (TypeSig (L _ n) (L _ t)) -> ppFunSig loc (mbDoc, fnArgsDoc) n t unicode + SigD (TypeSig lnames (L _ t)) -> ppFunSig loc (mbDoc, fnArgsDoc) (map unLoc lnames) t unicode ForD d -> ppFor loc (mbDoc, fnArgsDoc) d unicode InstD _ -> empty _ -> error "declaration not supported by ppDecl" @@ -325,7 +325,7 @@ ppTySyn :: SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool -> LaTeX ppTySyn loc doc (TySynonym (L _ name) ltyvars _ ltype) unicode - = ppTypeOrFunSig loc name (unLoc ltype) doc (full, hdr, char '=') unicode + = ppTypeOrFunSig loc [name] (unLoc ltype) doc (full, hdr, char '=') unicode where hdr = hsep (keyword "type" : ppDocBinder name : ppTyVars ltyvars) full = hdr <+> char '=' <+> ppLType unicode ltype @@ -338,20 +338,22 @@ ------------------------------------------------------------------------------- -ppFunSig :: SrcSpan -> DocForDecl DocName -> DocName -> HsType DocName +ppFunSig :: SrcSpan -> DocForDecl DocName -> [DocName] -> HsType DocName -> Bool -> LaTeX -ppFunSig loc doc docname typ unicode = - ppTypeOrFunSig loc docname typ doc - (ppTypeSig name typ False, ppSymName name, dcolon unicode) +ppFunSig loc doc docnames typ unicode = + ppTypeOrFunSig loc docnames typ doc + ( ppTypeSig names typ False + , hsep . punctuate comma $ map ppSymName names + , dcolon unicode) unicode where - name = getName docname + names = map getName docnames -ppTypeOrFunSig :: SrcSpan -> DocName -> HsType DocName -> - DocForDecl DocName -> (LaTeX, LaTeX, LaTeX) +ppTypeOrFunSig :: SrcSpan -> [DocName] -> HsType DocName + -> DocForDecl DocName -> (LaTeX, LaTeX, LaTeX) -> Bool -> LaTeX -ppTypeOrFunSig _loc _docname typ (doc, argDocs) (pref1, pref2, sep0) +ppTypeOrFunSig _ _ typ (doc, argDocs) (pref1, pref2, sep0) unicode | Map.null argDocs = declWithDoc pref1 (fmap docToLaTeX doc) @@ -388,9 +390,11 @@ = decltt leader <-> decltt (ppType unicode t) <-> arg_doc n <+> nl -ppTypeSig :: Name -> HsType DocName -> Bool -> LaTeX -ppTypeSig nm ty unicode = - ppSymName nm <+> dcolon unicode <+> ppType unicode ty +ppTypeSig :: [Name] -> HsType DocName -> Bool -> LaTeX +ppTypeSig nms ty unicode = + hsep (punctuate comma $ map ppSymName nms) + <+> dcolon unicode + <+> ppType unicode ty ppTyVars :: [LHsTyVarBndr DocName] -> [LaTeX] @@ -489,12 +493,13 @@ methodTable = text "\\haddockpremethods{}\\textbf{Methods}" $$ - vcat [ ppFunSig loc doc n typ unicode - | L _ (TypeSig (L _ n) (L _ typ)) <- lsigs - , let doc = lookupAnySubdoc n subdocs ] - --- atTable = abovesSep s8 $ [ ppAssocType summary links doc at unicode | at <- ats --- , let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ] + vcat [ ppFunSig loc doc names typ unicode + | L _ (TypeSig lnames (L _ typ)) <- lsigs + , let doc = lookupAnySubdoc (head names) subdocs + names = map unLoc lnames ] + -- FIXME: is taking just the first name ok? Is it possible that + -- there are different subdocs for different names in a single + -- type signature? instancesBit = ppDocInstances unicode instances @@ -874,7 +879,6 @@ ppr_mono_ty _ (HsListTy ty) u = brackets (ppr_mono_lty pREC_TOP ty u) ppr_mono_ty _ (HsPArrTy ty) u = pabrackets (ppr_mono_lty pREC_TOP ty u) ppr_mono_ty _ (HsPredTy p) u = parens (ppPred u p) -ppr_mono_ty _ (HsNumTy n) _ = text (show n) -- generics only ppr_mono_ty _ (HsSpliceTy {}) _ = error "ppr_mono_ty HsSpliceTy" ppr_mono_ty _ (HsQuasiQuoteTy {}) _ = error "ppr_mono_ty HsQuasiQuoteTy" ppr_mono_ty _ (HsRecTy {}) _ = error "ppr_mono_ty HsRecTy" diff -Nru ghc-7.0.3/utils/haddock/src/Haddock/Backends/Xhtml/Decl.hs ghc-7.2.1/utils/haddock/src/Haddock/Backends/Xhtml/Decl.hs --- ghc-7.0.3/utils/haddock/src/Haddock/Backends/Xhtml/Decl.hs 2011-03-26 18:10:10.000000000 +0000 +++ ghc-7.2.1/utils/haddock/src/Haddock/Backends/Xhtml/Decl.hs 2011-08-07 17:10:06.000000000 +0000 @@ -27,6 +27,7 @@ import Haddock.Types import Control.Monad ( join ) +import Data.List ( intersperse ) import qualified Data.Map as Map import Data.Maybe import Text.XHtml hiding ( name, title, p, quote ) @@ -50,28 +51,31 @@ | Nothing <- tcdTyPats d -> ppTySyn summ links loc (mbDoc, fnArgsDoc) d unicode qual | Just _ <- tcdTyPats d -> ppTyInst summ False links loc mbDoc d unicode qual TyClD d@(ClassDecl {}) -> ppClassDecl summ links instances loc mbDoc subdocs d unicode qual - SigD (TypeSig (L _ n) (L _ t)) -> ppFunSig summ links loc (mbDoc, fnArgsDoc) n t unicode qual + SigD (TypeSig lnames (L _ t)) -> ppFunSig summ links loc (mbDoc, fnArgsDoc) (map unLoc lnames) t unicode qual ForD d -> ppFor summ links loc (mbDoc, fnArgsDoc) d unicode qual InstD _ -> noHtml _ -> error "declaration not supported by ppDecl" ppFunSig :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> - DocName -> HsType DocName -> Bool -> Qualification -> Html -ppFunSig summary links loc doc docname typ unicode qual = - ppTypeOrFunSig summary links loc docname typ doc - (ppTypeSig summary occname typ unicode qual, ppBinder False occname, dcolon unicode) + [DocName] -> HsType DocName -> Bool -> Qualification -> Html +ppFunSig summary links loc doc docnames typ unicode qual = + ppTypeOrFunSig summary links loc docnames typ doc + ( ppTypeSig summary occnames typ unicode qual + , concatHtml . punctuate comma $ map (ppBinder False) occnames + , dcolon unicode + ) unicode qual where - occname = nameOccName . getName $ docname + occnames = map (nameOccName . getName) docnames -ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> DocName -> HsType DocName -> - DocForDecl DocName -> (Html, Html, Html) -> Bool -> Qualification-> Html -ppTypeOrFunSig summary links loc docname typ (doc, argDocs) (pref1, pref2, sep) unicode qual +ppTypeOrFunSig :: Bool -> LinksInfo -> SrcSpan -> [DocName] -> HsType DocName + -> DocForDecl DocName -> (Html, Html, Html) -> Bool -> Qualification -> Html +ppTypeOrFunSig summary links loc docnames typ (doc, argDocs) (pref1, pref2, sep) unicode qual | summary = pref1 - | Map.null argDocs = topDeclElem links loc docname pref1 +++ maybeDocSection qual doc - | otherwise = topDeclElem links loc docname pref2 +++ + | Map.null argDocs = topDeclElem links loc docnames pref1 +++ maybeDocSection qual doc + | otherwise = topDeclElem links loc docnames pref2 +++ subArguments qual (do_args 0 sep typ) +++ maybeDocSection qual doc where argDoc n = Map.lookup n argDocs @@ -108,10 +112,10 @@ tyvarNames = map (getName . hsTyVarName . unLoc) -ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> ForeignDecl DocName -> Bool - -> Qualification -> Html +ppFor :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName + -> ForeignDecl DocName -> Bool -> Qualification -> Html ppFor summary links loc doc (ForeignImport (L _ name) (L _ typ) _) unicode qual - = ppFunSig summary links loc doc name typ unicode qual + = ppFunSig summary links loc doc [name] typ unicode qual ppFor _ _ _ _ _ _ _ = error "ppFor" @@ -119,7 +123,7 @@ ppTySyn :: Bool -> LinksInfo -> SrcSpan -> DocForDecl DocName -> TyClDecl DocName -> Bool -> Qualification -> Html ppTySyn summary links loc doc (TySynonym (L _ name) ltyvars _ ltype) unicode qual - = ppTypeOrFunSig summary links loc name (unLoc ltype) doc + = ppTypeOrFunSig summary links loc [name] (unLoc ltype) doc (full, hdr, spaceHtml +++ equals) unicode qual where hdr = hsep ([keyword "type", ppBinder summary occ] ++ ppTyVars ltyvars) @@ -128,9 +132,11 @@ ppTySyn _ _ _ _ _ _ _ = error "declaration not supported by ppTySyn" -ppTypeSig :: Bool -> OccName -> HsType DocName -> Bool -> Qualification -> Html -ppTypeSig summary nm ty unicode qual = - ppBinder summary nm <+> dcolon unicode <+> ppType unicode qual ty +ppTypeSig :: Bool -> [OccName] -> HsType DocName -> Bool -> Qualification -> Html +ppTypeSig summary nms ty unicode qual = + concatHtml htmlNames <+> dcolon unicode <+> ppType unicode qual ty + where + htmlNames = intersperse (stringToHtml ", ") $ map (ppBinder summary) nms ppTyName :: Name -> Html @@ -173,7 +179,7 @@ where docname = tcdName decl - header_ = topDeclElem links loc docname (ppTyFamHeader summary associated decl unicode) + header_ = topDeclElem links loc [docname] (ppTyFamHeader summary associated decl unicode) instancesBit = ppInstances instances docname unicode qual @@ -213,8 +219,8 @@ where docname = tcdName decl - header_ = topDeclElem links loc docname - (ppTyInstHeader summary associated decl unicode qual) + header_ = topDeclElem links loc [docname] + (ppTyInstHeader summary associated decl unicode qual) ppTyInstHeader :: Bool -> Bool -> TyClDecl DocName -> Bool -> Qualification -> Html @@ -349,16 +355,20 @@ ppShortClassDecl summary links (ClassDecl lctxt lname tvs fds sigs _ ats _) loc subdocs unicode qual = if null sigs && null ats - then (if summary then id else topDeclElem links loc nm) hdr - else (if summary then id else topDeclElem links loc nm) (hdr <+> keyword "where") + then (if summary then id else topDeclElem links loc [nm]) hdr + else (if summary then id else topDeclElem links loc [nm]) (hdr <+> keyword "where") +++ shortSubDecls ( [ ppAssocType summary links doc at unicode qual | at <- ats , let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ] ++ - [ ppFunSig summary links loc doc n typ unicode qual - | L _ (TypeSig (L _ n) (L _ typ)) <- sigs - , let doc = lookupAnySubdoc n subdocs ] + [ ppFunSig summary links loc doc names typ unicode qual + | L _ (TypeSig lnames (L _ typ)) <- sigs + , let doc = lookupAnySubdoc (head names) subdocs + names = map unLoc lnames ] + -- FIXME: is taking just the first name ok? Is it possible that + -- there are different subdocs for different names in a single + -- type signature? ) where hdr = ppClassHdr summary lctxt (unLoc lname) tvs fds unicode qual @@ -377,8 +387,8 @@ +++ atBit +++ methodBit +++ instancesBit where classheader - | null lsigs = topDeclElem links loc nm (hdr unicode qual) - | otherwise = topDeclElem links loc nm (hdr unicode qual <+> keyword "where") + | null lsigs = topDeclElem links loc [nm] (hdr unicode qual) + | otherwise = topDeclElem links loc [nm] (hdr unicode qual <+> keyword "where") nm = unLoc $ tcdLName decl @@ -388,9 +398,13 @@ | at <- ats , let doc = lookupAnySubdoc (tcdName $ unL at) subdocs ] - methodBit = subMethods [ ppFunSig summary links loc doc n typ unicode qual - | L _ (TypeSig (L _ n) (L _ typ)) <- lsigs - , let doc = lookupAnySubdoc n subdocs ] + methodBit = subMethods [ ppFunSig summary links loc doc names typ unicode qual + | L _ (TypeSig lnames (L _ typ)) <- lsigs + , let doc = lookupAnySubdoc (head names) subdocs + names = map unLoc lnames ] + -- FIXME: is taking just the first name ok? Is it possible that + -- there are different subdocs for different names in a single + -- type signature? instancesBit = ppInstances instances nm unicode qual @@ -461,7 +475,7 @@ cons = tcdCons dataDecl resTy = (con_res . unLoc . head) cons - header_ = topDeclElem links loc docname (ppDataHeader summary dataDecl unicode qual + header_ = topDeclElem links loc [docname] (ppDataHeader summary dataDecl unicode qual <+> whereBit) whereBit @@ -711,11 +725,14 @@ ppr_mono_ty _ (HsListTy ty) u q = brackets (ppr_mono_lty pREC_TOP ty u q) ppr_mono_ty _ (HsPArrTy ty) u q = pabrackets (ppr_mono_lty pREC_TOP ty u q) ppr_mono_ty _ (HsPredTy p) u q = parens (ppPred u q p) -ppr_mono_ty _ (HsNumTy n) _ _ = toHtml (show n) -- generics only ppr_mono_ty _ (HsSpliceTy {}) _ _ = error "ppr_mono_ty HsSpliceTy" +#if __GLASGOW_HASKELL__ == 612 +ppr_mono_ty _ (HsSpliceTyOut {}) _ _ = error "ppr_mono_ty HsQuasiQuoteTy" +#else ppr_mono_ty _ (HsQuasiQuoteTy {}) _ _ = error "ppr_mono_ty HsQuasiQuoteTy" -ppr_mono_ty _ (HsCoreTy {}) _ _ = error "ppr_mono_ty HsCoreTy" +#endif ppr_mono_ty _ (HsRecTy {}) _ _ = error "ppr_mono_ty HsRecTy" +ppr_mono_ty _ (HsCoreTy {}) _ _ = error "ppr_mono_ty HsCoreTy" ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) unicode qual = maybeParen ctxt_prec pREC_CON $ diff -Nru ghc-7.0.3/utils/haddock/src/Haddock/Backends/Xhtml/Layout.hs ghc-7.2.1/utils/haddock/src/Haddock/Backends/Xhtml/Layout.hs --- ghc-7.0.3/utils/haddock/src/Haddock/Backends/Xhtml/Layout.hs 2011-03-26 18:10:10.000000000 +0000 +++ ghc-7.2.1/utils/haddock/src/Haddock/Backends/Xhtml/Layout.hs 2011-08-07 17:10:06.000000000 +0000 @@ -176,8 +176,8 @@ -- a box for top level documented names -- it adds a source and wiki link at the right hand side of the box -topDeclElem :: LinksInfo -> SrcSpan -> DocName -> Html -> Html -topDeclElem ((_,_,sourceMap), (_,_,maybe_wiki_url)) loc name html = +topDeclElem :: LinksInfo -> SrcSpan -> [DocName] -> Html -> Html +topDeclElem ((_,_,sourceMap), (_,_,maybe_wiki_url)) loc names html = declElem << (html +++ srcLink +++ wikiLink) where srcLink = case Map.lookup origPkg sourceMap of @@ -201,7 +201,10 @@ origPkg = modulePackageId origMod -- Name must be documented, otherwise we wouldn't get here - Documented n mdl = name + Documented n mdl = head names + -- FIXME: is it ok to simply take the first name? - fname = unpackFS (srcSpanFile loc) + fname = case loc of + RealSrcSpan l -> unpackFS (srcSpanFile l) + UnhelpfulSpan _ -> error "topDeclElem UnhelpfulSpan" diff -Nru ghc-7.0.3/utils/haddock/src/Haddock/Backends/Xhtml/Utils.hs ghc-7.2.1/utils/haddock/src/Haddock/Backends/Xhtml/Utils.hs --- ghc-7.0.3/utils/haddock/src/Haddock/Backends/Xhtml/Utils.hs 2011-03-26 18:10:10.000000000 +0000 +++ ghc-7.2.1/utils/haddock/src/Haddock/Backends/Xhtml/Utils.hs 2011-08-07 17:10:06.000000000 +0000 @@ -37,7 +37,7 @@ import Text.XHtml hiding ( name, title, p, quote ) import qualified Text.XHtml as XHtml -import GHC ( SrcSpan, srcSpanStartLine, Name ) +import GHC ( SrcSpan(..), srcSpanStartLine, Name ) import Module ( Module ) import Name ( getOccString, nameOccName, isValOcc ) @@ -59,7 +59,12 @@ line = case maybe_loc of Nothing -> "" - Just span_ -> show $ srcSpanStartLine span_ + Just span_ -> + case span_ of + RealSrcSpan span__ -> + show $ srcSpanStartLine span__ + UnhelpfulSpan _ -> + error "spliceURL UnhelpfulSpan" run "" = "" run ('%':'M':rest) = mdl ++ run rest diff -Nru ghc-7.0.3/utils/haddock/src/Haddock/Backends/Xhtml.hs ghc-7.2.1/utils/haddock/src/Haddock/Backends/Xhtml.hs --- ghc-7.0.3/utils/haddock/src/Haddock/Backends/Xhtml.hs 2011-03-26 18:10:10.000000000 +0000 +++ ghc-7.2.1/utils/haddock/src/Haddock/Backends/Xhtml.hs 2011-08-07 17:10:06.000000000 +0000 @@ -246,7 +246,7 @@ ppPrologue :: String -> Maybe (Doc GHC.RdrName) -> Html ppPrologue _ Nothing = noHtml ppPrologue title (Just doc) = - docElement divDescription << (h1 << title +++ rdrDocToHtml doc) + divDescription << (h1 << title +++ docElement thediv (rdrDocToHtml doc)) ppModuleTree :: [ModuleTree] -> Html @@ -547,31 +547,31 @@ miniSynopsis :: Module -> Interface -> Bool -> Qualification -> Html miniSynopsis mdl iface unicode qual = - divInterface << mapMaybe (processForMiniSynopsis mdl unicode qual) exports + divInterface << concatMap (processForMiniSynopsis mdl unicode qual) exports where exports = numberSectionHeadings (ifaceRnExportItems iface) processForMiniSynopsis :: Module -> Bool -> Qualification -> ExportItem DocName - -> Maybe Html + -> [Html] processForMiniSynopsis mdl unicode _ (ExportDecl (L _loc decl0) _doc _ _insts) = ((divTopDecl <<).(declElem <<)) `fmap` case decl0 of TyClD d -> let b = ppTyClBinderWithVarsMini mdl d in case d of - (TyFamily{}) -> Just $ ppTyFamHeader True False d unicode + (TyFamily{}) -> [ppTyFamHeader True False d unicode] (TyData{tcdTyPats = ps}) - | Nothing <- ps -> Just $ keyword "data" <+> b - | Just _ <- ps -> Just $ keyword "data" <+> keyword "instance" <+> b + | Nothing <- ps -> [keyword "data" <+> b] + | Just _ <- ps -> [keyword "data" <+> keyword "instance" <+> b] (TySynonym{tcdTyPats = ps}) - | Nothing <- ps -> Just $ keyword "type" <+> b - | Just _ <- ps -> Just $ keyword "type" <+> keyword "instance" <+> b - (ClassDecl {}) -> Just $ keyword "class" <+> b - _ -> Nothing - SigD (TypeSig (L _ n) (L _ _)) -> - Just $ ppNameMini mdl (nameOccName . getName $ n) - _ -> Nothing + | Nothing <- ps -> [keyword "type" <+> b] + | Just _ <- ps -> [keyword "type" <+> keyword "instance" <+> b] + (ClassDecl {}) -> [keyword "class" <+> b] + _ -> [] + SigD (TypeSig lnames (L _ _)) -> + map (ppNameMini mdl . nameOccName . getName . unLoc) lnames + _ -> [] processForMiniSynopsis _ _ qual (ExportGroup lvl _id txt) = - Just $ groupTag lvl << docToHtml qual txt -processForMiniSynopsis _ _ _ _ = Nothing + [groupTag lvl << docToHtml qual txt] +processForMiniSynopsis _ _ _ _ = [] ppNameMini :: Module -> OccName -> Html diff -Nru ghc-7.0.3/utils/haddock/src/Haddock/Convert.hs ghc-7.2.1/utils/haddock/src/Haddock/Convert.hs --- ghc-7.0.3/utils/haddock/src/Haddock/Convert.hs 2011-03-26 18:10:10.000000000 +0000 +++ ghc-7.2.1/utils/haddock/src/Haddock/Convert.hs 2011-08-07 17:10:06.000000000 +0000 @@ -18,7 +18,7 @@ import HsSyn -import TcType ( tcSplitSigmaTy ) +import TcType ( tcSplitTyConApp_maybe, tcSplitSigmaTy ) import TypeRep import Coercion ( splitKindFunTys, synTyConResKind ) import Name @@ -44,11 +44,17 @@ -- into a ForD instead of a SigD if we wanted. Haddock doesn't -- need to care. AnId i -> SigD (synifyIdSig ImplicitizeForAll i) + -- type-constructors (e.g. Maybe) are complicated, put the definition -- later in the file (also it's used for class associated-types too.) ATyCon tc -> TyClD (synifyTyCon tc) + + -- type-constructors (e.g. Maybe) are complicated, put the definition + -- later in the file (also it's used for class associated-types too.) + ACoAxiom ax -> TyClD (synifyAxiom ax) + -- a data-constructor alone just gets rendered as a function: - ADataCon dc -> SigD (TypeSig (synifyName dc) + ADataCon dc -> SigD (TypeSig [synifyName dc] (synifyType ImplicitizeForAll (dataConUserType dc))) -- classes are just a little tedious AClass cl -> @@ -71,6 +77,16 @@ synifyClassAT :: TyCon -> LTyClDecl Name synifyClassAT = noLoc . synifyTyCon +synifyAxiom :: CoAxiom -> TyClDecl Name +synifyAxiom (CoAxiom { co_ax_tvs = tvs, co_ax_lhs = lhs, co_ax_rhs = rhs }) + | Just (tc, args) <- tcSplitTyConApp_maybe lhs + = let name = synifyName tc + tyvars = synifyTyVars tvs + typats = map (synifyType WithinType) args + hs_rhs_ty = synifyType WithinType rhs + in TySynonym name tyvars (Just typats) hs_rhs_ty + | otherwise + = error "synifyAxiom" synifyTyCon :: TyCon -> TyClDecl Name synifyTyCon tc @@ -162,11 +178,15 @@ use_named_field_syntax = not (null field_tys) name = synifyName dc -- con_qvars means a different thing depending on gadt-syntax + (univ_tvs, ex_tvs, _eq_spec, theta, arg_tys, res_ty) = dataConFullSig dc + qvars = if use_gadt_syntax - then synifyTyVars (dataConAllTyVars dc) - else synifyTyVars (dataConExTyVars dc) + then synifyTyVars (univ_tvs ++ ex_tvs) + else synifyTyVars ex_tvs + -- skip any EqTheta, use 'orig'inal syntax - ctx = synifyCtx (dataConDictTheta dc) + ctx = synifyCtx theta + linear_tys = zipWith (\ty bang -> let tySyn = synifyType WithinType ty in case bang of @@ -175,23 +195,23 @@ -- HsNoBang never appears, it's implied instead. _ -> noLoc $ HsBangTy bang tySyn ) - (dataConOrigArgTys dc) (dataConStrictMarks dc) + arg_tys (dataConStrictMarks dc) field_tys = zipWith (\field synTy -> ConDeclField (synifyName field) synTy Nothing) (dataConFieldLabels dc) linear_tys - tys = case (use_named_field_syntax, use_infix_syntax) of + hs_arg_tys = case (use_named_field_syntax, use_infix_syntax) of (True,True) -> error "synifyDataCon: contradiction!" (True,False) -> RecCon field_tys (False,False) -> PrefixCon linear_tys (False,True) -> case linear_tys of [a,b] -> InfixCon a b _ -> error "synifyDataCon: infix with non-2 args?" - res_ty = if use_gadt_syntax - then ResTyGADT (synifyType WithinType (dataConOrigResTy dc)) - else ResTyH98 + hs_res_ty = if use_gadt_syntax + then ResTyGADT (synifyType WithinType res_ty) + else ResTyH98 -- finally we get synifyDataCon's result! in ConDecl name Implicit{-we don't know nor care-} - qvars ctx tys res_ty Nothing + qvars ctx hs_arg_tys hs_res_ty Nothing False --we don't want any "deprecated GADT syntax" warnings! @@ -200,7 +220,7 @@ synifyIdSig :: SynifyTypeState -> Id -> Sig Name -synifyIdSig s i = TypeSig (synifyName i) (synifyType s (varType i)) +synifyIdSig s i = TypeSig [synifyName i] (synifyType s (varType i)) synifyCtx :: [PredType] -> LHsContext Name diff -Nru ghc-7.0.3/utils/haddock/src/Haddock/GhcUtils.hs ghc-7.2.1/utils/haddock/src/Haddock/GhcUtils.hs --- ghc-7.0.3/utils/haddock/src/Haddock/GhcUtils.hs 2011-03-26 18:10:10.000000000 +0000 +++ ghc-7.2.1/utils/haddock/src/Haddock/GhcUtils.hs 2011-08-07 17:10:06.000000000 +0000 @@ -17,6 +17,7 @@ import Data.Version +import Control.Applicative ( (<$>) ) import Control.Arrow import Data.Foldable hiding (concatMap) import Data.Traversable @@ -81,18 +82,54 @@ isVarSym = isLexVarSym . occNameFS -getMainDeclBinder :: HsDecl name -> Maybe name -getMainDeclBinder (TyClD d) = Just (tcdName d) +getMainDeclBinder :: HsDecl name -> [name] +getMainDeclBinder (TyClD d) = [tcdName d] getMainDeclBinder (ValD d) = +#if __GLASGOW_HASKELL__ == 612 + case collectAcc d [] of + [] -> [] + (name:_) -> [unLoc name] +#else case collectHsBindBinders d of - [] -> Nothing - (name:_) -> Just name - + [] -> [] + (name:_) -> [name] +#endif getMainDeclBinder (SigD d) = sigNameNoLoc d -getMainDeclBinder (ForD (ForeignImport name _ _)) = Just (unLoc name) -getMainDeclBinder (ForD (ForeignExport _ _ _)) = Nothing -getMainDeclBinder _ = Nothing +getMainDeclBinder (ForD (ForeignImport name _ _)) = [unLoc name] +getMainDeclBinder (ForD (ForeignExport _ _ _)) = [] +getMainDeclBinder _ = [] + +-- Useful when there is a signature with multiple names, e.g. +-- foo, bar :: Types.. +-- but only one of the names is exported and we have to change the +-- type signature to only include the exported names. +filterLSigNames :: (name -> Bool) -> LSig name -> Maybe (LSig name) +filterLSigNames p (L loc sig) = L loc <$> (filterSigNames p sig) + +filterSigNames :: (name -> Bool) -> Sig name -> Maybe (Sig name) +filterSigNames p orig@(SpecSig n _ _) = ifTrueJust (p $ unLoc n) orig +filterSigNames p orig@(InlineSig n _) = ifTrueJust (p $ unLoc n) orig +filterSigNames p orig@(FixSig (FixitySig n _)) = ifTrueJust (p $ unLoc n) orig +filterSigNames p (TypeSig ns ty) = + case filter (p . unLoc) ns of + [] -> Nothing + filtered -> Just (TypeSig filtered ty) +filterSigNames _ _ = Nothing + +ifTrueJust :: Bool -> name -> Maybe name +ifTrueJust True = Just +ifTrueJust False = const Nothing + +sigName :: LSig name -> [name] +sigName (L _ sig) = sigNameNoLoc sig + +sigNameNoLoc :: Sig name -> [name] +sigNameNoLoc (TypeSig ns _) = map unLoc ns +sigNameNoLoc (SpecSig n _ _) = [unLoc n] +sigNameNoLoc (InlineSig n _) = [unLoc n] +sigNameNoLoc (FixSig (FixitySig n _)) = [unLoc n] +sigNameNoLoc _ = [] isTyClD :: HsDecl a -> Bool @@ -142,11 +179,11 @@ reL = L undefined -instance Foldable Located where +instance Foldable (GenLocated l) where foldMap f (L _ x) = f x -instance Traversable Located where +instance Traversable (GenLocated l) where mapM f (L l x) = (return . L l) =<< f x @@ -184,7 +221,7 @@ | isDataDecl d = map (unL . con_name . unL) . tcdCons $ d | isClassDecl d = map (tcdName . unL) (tcdATs d) ++ - [ unL n | L _ (TypeSig n _) <- tcdSigs d ] + [ unL n | L _ (TypeSig ns _) <- tcdSigs d, n <- ns ] | otherwise = [] diff -Nru ghc-7.0.3/utils/haddock/src/Haddock/Interface/AttachInstances.hs ghc-7.2.1/utils/haddock/src/Haddock/Interface/AttachInstances.hs --- ghc-7.0.3/utils/haddock/src/Haddock/Interface/AttachInstances.hs 2011-03-26 18:10:10.000000000 +0000 +++ ghc-7.2.1/utils/haddock/src/Haddock/Interface/AttachInstances.hs 2011-08-07 17:10:06.000000000 +0000 @@ -30,9 +30,10 @@ #else import HscTypes (withSession) #endif +import TysPrim( funTyCon ) import MonadUtils (liftIO) import TcRnDriver (tcRnGetInfo) -import TypeRep hiding (funTyConName) +import TypeRep import Var hiding (varName) import TyCon import PrelNames diff -Nru ghc-7.0.3/utils/haddock/src/Haddock/Interface/Create.hs ghc-7.2.1/utils/haddock/src/Haddock/Interface/Create.hs --- ghc-7.0.3/utils/haddock/src/Haddock/Interface/Create.hs 2011-03-26 18:10:10.000000000 +0000 +++ ghc-7.2.1/utils/haddock/src/Haddock/Interface/Create.hs 2011-08-07 17:10:06.000000000 +0000 @@ -35,9 +35,9 @@ import RdrName (GlobalRdrEnv) --- | Process the data in a GhcModule to produce an interface. +-- | Use a 'TypecheckedModule' to produce an 'Interface'. -- To do this, we need access to already processed modules in the topological --- sort. That's what's in the interface map. +-- sort. That's what's in the 'IfaceMap'. createInterface :: TypecheckedModule -> [Flag] -> IfaceMap -> InstIfaceMap -> ErrMsgGhc Interface createInterface tm flags modMap instIfaceMap = do @@ -69,13 +69,15 @@ decls = filterOutInstances decls0 declMap = mkDeclMap decls - exports = fmap (reverse . map unLoc) optExports - ignoreExps = Flag_IgnoreAllExports `elem` flags + exports0 = fmap (reverse . map unLoc) optExports + exports + | OptIgnoreExports `elem` opts = Nothing + | otherwise = exports0 liftErrMsg $ warnAboutFilteredDecls mdl decls0 exportItems <- mkExportItems modMap mdl gre exportedNames decls declMap - opts exports ignoreExps instances instIfaceMap dflags + exports instances instIfaceMap dflags let visibleNames = mkVisibleNames exportItems opts @@ -174,9 +176,10 @@ -- subordinate names, but map them to their parent declarations. mkDeclMap :: [DeclInfo] -> Map Name DeclInfo mkDeclMap decls = Map.fromList . concat $ - [ (declName d, (parent, doc, subs)) : subDecls + [ decls_ ++ subDecls | (parent@(L _ d), doc, subs) <- decls - , let subDecls = [ (n, (parent, doc', [])) | (n, doc') <- subs ] + , let decls_ = [ (name, (parent, doc, subs)) | name <- declNames d ] + subDecls = [ (n, (parent, doc', [])) | (n, doc') <- subs ] , not (isDocD d), not (isInstD d) ] @@ -225,8 +228,9 @@ | isDataDecl decl = dataSubs | otherwise = [] where - classSubs = [ (declName d, doc, fnArgsDoc) + classSubs = [ (name, doc, fnArgsDoc) | (L _ d, doc) <- classDecls decl + , name <- declNames d , let fnArgsDoc = getDeclFnArgDocs d ] dataSubs = constrs ++ fields where @@ -257,12 +261,12 @@ ats = mkDecls tcdATs TyClD class_ -declName :: HsDecl a -> a -declName (TyClD d) = tcdName d -declName (ForD (ForeignImport n _ _)) = unLoc n +declNames :: HsDecl a -> [a] +declNames (TyClD d) = [tcdName d] +declNames (ForD (ForeignImport n _ _)) = [unLoc n] -- we have normal sigs only (since they are taken from ValBindsOut) -declName (SigD sig) = fromJust $ sigNameNoLoc sig -declName _ = error "unexpected argument to declName" +declNames (SigD sig) = sigNameNoLoc sig +declNames _ = error "unexpected argument to declNames" -- | The top-level declarations of a module that we care about, @@ -279,7 +283,11 @@ -- bindings from an 'HsGroup'. declsFromGroup :: HsGroup Name -> [Decl] declsFromGroup group_ = +#if MIN_VERSION_ghc(7,0,2) mkDecls (concat . hs_tyclds) TyClD group_ ++ +#else + mkDecls hs_tyclds TyClD group_ ++ +#endif mkDecls hs_derivds DerivD group_ ++ mkDecls hs_defds DefD group_ ++ mkDecls hs_fords ForD group_ ++ @@ -438,38 +446,39 @@ -> [Name] -- exported names (orig) -> [DeclInfo] -> Map Name DeclInfo -- maps local names to declarations - -> [DocOption] -> Maybe [IE Name] - -> Bool -- --ignore-all-exports flag -> [Instance] -> InstIfaceMap -> DynFlags -> ErrMsgGhc [ExportItem Name] - -mkExportItems modMap this_mod gre exported_names decls declMap - opts maybe_exps ignore_all_exports _ instIfaceMap dflags - | isNothing maybe_exps || ignore_all_exports || OptIgnoreExports `elem` opts - = everything_local_exported - | otherwise = liftM concat $ mapM lookupExport (fromJust maybe_exps) - where - - - everything_local_exported = -- everything exported - liftErrMsg $ fullContentsOfThisModule dflags gre decls +mkExportItems modMap thisMod gre exportedNames decls declMap + optExports _ instIfaceMap dflags = + case optExports of + Nothing -> liftErrMsg $ fullContentsOfThisModule dflags gre decls + Just exports -> liftM (nubBy commaDeclared . concat) $ mapM lookupExport exports + where + -- A type signature can have multiple names, like: + -- foo, bar :: Types.. + -- When going throug the exported names we have to take care to detect such + -- situations and remove the duplicates. + commaDeclared (ExportDecl (L _ sig1) _ _ _) (ExportDecl (L _ sig2) _ _ _) = + getMainDeclBinder sig1 == getMainDeclBinder sig2 + commaDeclared _ _ = False - lookupExport (IEVar x) = declWith x - lookupExport (IEThingAbs t) = declWith t + lookupExport (IEVar x) = declWith x + lookupExport (IEThingAbs t) = declWith t lookupExport (IEThingAll t) = declWith t lookupExport (IEThingWith t _) = declWith t - lookupExport (IEModuleContents m) = fullContentsOf m + lookupExport (IEModuleContents m) = + moduleExports thisMod m dflags gre exportedNames decls modMap instIfaceMap lookupExport (IEGroup lev docStr) = liftErrMsg $ ifDoc (lexParseRnHaddockComment dflags DocSectionComment gre docStr) (\doc -> return [ ExportGroup lev "" doc ]) lookupExport (IEDoc docStr) = liftErrMsg $ ifDoc (lexParseRnHaddockComment dflags NormalHaddockComment gre docStr) (\doc -> return [ ExportDoc doc ]) - lookupExport (IEDocNamed str) = liftErrMsg $ + lookupExport (IEDocNamed str) = liftErrMsg $ ifDoc (findNamedDoc str [ unL d | (d,_,_) <- decls ]) (\docStr -> ifDoc (lexParseRnHaddockComment dflags NormalHaddockComment gre docStr) @@ -485,11 +494,8 @@ declWith :: Name -> ErrMsgGhc [ ExportItem Name ] declWith t = case findDecl t of - Just x@(decl,_,_) -> - let declName_ = - case getMainDeclBinder (unL decl) of - Just n -> n - Nothing -> error "declWith: should not happen" + Just (decl, doc, subs) -> + let declNames_ = getMainDeclBinder (unL decl) in case () of _ -- temp hack: we filter out separately exported ATs, since we haven't decided how @@ -499,10 +505,10 @@ -- We should not show a subordinate by itself if any of its -- parents is also exported. See note [1]. - | t /= declName_, + | not $ t `elem` declNames_, Just p <- find isExported (parents t $ unL decl) -> do liftErrMsg $ tell [ - "Warning: " ++ moduleString this_mod ++ ": " ++ + "Warning: " ++ moduleString thisMod ++ ": " ++ pretty (nameOccName t) ++ " is exported separately but " ++ "will be documented under " ++ pretty (nameOccName p) ++ ". Consider exporting it together with its parent(s)" ++ @@ -510,7 +516,18 @@ return [] -- normal case - | otherwise -> return [ mkExportDecl t x ] + | otherwise -> return [ mkExportDecl t (newDecl, doc, subs) ] + where + -- Since a single signature might refer to many names, we + -- need to filter the ones that are actually exported. This + -- requires modifying the type signatures to "hide" the + -- names that are not exported. + newDecl = case decl of + (L loc (SigD sig)) -> + L loc . SigD . fromJust $ filterSigNames isExported sig + -- fromJust is safe since we already checked in guards + -- that 't' is a name declared in this declaration. + _ -> decl Nothing -> do -- If we can't find the declaration, it must belong to -- another package @@ -520,7 +537,7 @@ -- looked for the .hi/.haddock). It's to help people -- debugging after all, so good to show more info. let exportInfoString = - moduleString this_mod ++ "." ++ getOccString t + moduleString thisMod ++ "." ++ getOccString t ++ ": " ++ pretty (nameModule t) ++ "." ++ getOccString t @@ -626,38 +643,16 @@ where decl' = ExportDecl (restrictTo sub_names (extractDecl n mdl decl)) doc subs' [] mdl = nameModule n - subs' = filter ((`elem` exported_names) . fst) subs + subs' = filter (isExported . fst) subs sub_names = map fst subs' - isExported = (`elem` exported_names) - - - fullContentsOf modname - | m == this_mod = liftErrMsg $ fullContentsOfThisModule dflags gre decls - | otherwise = - case Map.lookup m modMap of - Just iface - | OptHide `elem` ifaceOptions iface -> return (ifaceExportItems iface) - | otherwise -> return [ ExportModule m ] - - Nothing -> -- we have to try to find it in the installed interfaces - -- (external packages) - case Map.lookup modname (Map.mapKeys moduleName instIfaceMap) of - Just iface -> return [ ExportModule (instMod iface) ] - Nothing -> do - liftErrMsg $ - tell ["Warning: " ++ pretty this_mod ++ ": Could not find " ++ - "documentation for exported module: " ++ pretty modname] - return [] - where - m = mkModule packageId modname - packageId = modulePackageId this_mod + isExported = (`elem` exportedNames) findDecl :: Name -> Maybe DeclInfo findDecl n - | m == this_mod = Map.lookup n declMap + | m == thisMod = Map.lookup n declMap | otherwise = case Map.lookup m modMap of Just iface -> Map.lookup n (ifaceDeclMap iface) Nothing -> Nothing @@ -665,6 +660,50 @@ m = nameModule n +-- | Return all export items produced by an exported module. That is, we're +-- interested in the exports produced by \"module B\" in such a scenario: +-- +-- > module A (module B) where +-- > import B (...) hiding (...) +-- +-- There are three different cases to consider: +-- +-- 1) B is hidden, in which case we return all its exports that are in scope in A. +-- 2) B is visible, but not all its exports are in scope in A, in which case we +-- only return those that are. +-- 3) B is visible and all its exports are in scope, in which case we return +-- a single 'ExportModule' item. +moduleExports :: Module -- ^ Module A + -> ModuleName -- ^ The real name of B, the exported module + -> DynFlags -- ^ The flag used when typechecking A + -> GlobalRdrEnv -- ^ The renaming environment used for A + -> [Name] -- ^ All the exports of A + -> [DeclInfo] -- ^ All the declarations in A + -> IfaceMap -- ^ Already created interfaces + -> InstIfaceMap -- ^ Interfaces in other packages + -> ErrMsgGhc [ExportItem Name] -- ^ Resulting export items +moduleExports thisMod expMod dflags gre _exports decls ifaceMap instIfaceMap + | m == thisMod = liftErrMsg $ fullContentsOfThisModule dflags gre decls + | otherwise = + case Map.lookup m ifaceMap of + Just iface + | OptHide `elem` ifaceOptions iface -> return (ifaceExportItems iface) + | otherwise -> return [ ExportModule m ] + + Nothing -> -- we have to try to find it in the installed interfaces + -- (external packages) + case Map.lookup expMod (Map.mapKeys moduleName instIfaceMap) of + Just iface -> return [ ExportModule (instMod iface) ] + Nothing -> do + liftErrMsg $ + tell ["Warning: " ++ pretty thisMod ++ ": Could not find " ++ + "documentation for exported module: " ++ pretty expMod] + return [] + where + m = mkModule packageId expMod + packageId = modulePackageId thisMod + + -- Note [1]: ------------ -- It is unnecessary to document a subordinate by itself at the top level if @@ -700,11 +739,11 @@ -- together a type signature for it...) extractDecl :: Name -> Module -> Decl -> Decl extractDecl name mdl decl - | Just n <- getMainDeclBinder (unLoc decl), n == name = decl + | name `elem` getMainDeclBinder (unLoc decl) = decl | otherwise = case unLoc decl of TyClD d | isClassDecl d -> - let matches = [ sig | sig <- tcdSigs d, sigName sig == Just name, + let matches = [ sig | sig <- tcdSigs d, name `elem` sigName sig, isVanillaLSig sig ] -- TODO: document fixity in case matches of [s0] -> let (n, tyvar_names) = name_and_tyvars d @@ -742,7 +781,7 @@ extractRecSel nm mdl t tvs (L _ con : rest) = case con_details con of RecCon fields | (ConDeclField n ty _ : _) <- matching_fields fields -> - L (getLoc n) (TypeSig (noLoc nm) (noLoc (HsFunTy data_ty (getBangType ty)))) + L (getLoc n) (TypeSig [noLoc nm] (noLoc (HsFunTy data_ty (getBangType ty)))) _ -> extractRecSel nm mdl t tvs rest where matching_fields flds = [ f | f@(ConDeclField n _ _) <- flds, unLoc n == nm ] @@ -762,10 +801,7 @@ | OptHide `elem` opts = [] | otherwise = concatMap exportName exports where - exportName e@ExportDecl {} = - case getMainDeclBinder $ unL $ expItemDecl e of - Just n -> n : subs - Nothing -> subs + exportName e@ExportDecl {} = getMainDeclBinder (unL $ expItemDecl e) ++ subs where subs = map fst (expItemSubDocs e) exportName ExportNoDecl {} = [] -- we don't count these as visible, since -- we don't want links to go to them. diff -Nru ghc-7.0.3/utils/haddock/src/Haddock/Interface/Rename.hs ghc-7.2.1/utils/haddock/src/Haddock/Interface/Rename.hs --- ghc-7.0.3/utils/haddock/src/Haddock/Interface/Rename.hs 2011-03-26 18:10:10.000000000 +0000 +++ ghc-7.2.1/utils/haddock/src/Haddock/Interface/Rename.hs 2011-08-07 17:10:06.000000000 +0000 @@ -265,8 +265,6 @@ HsParTy ty -> return . HsParTy =<< renameLType ty - HsNumTy n -> return (HsNumTy n) - HsPredTy p -> return . HsPredTy =<< renamePred p HsKindSig ty k -> do @@ -403,10 +401,10 @@ renameSig :: Sig Name -> RnM (Sig DocName) renameSig sig = case sig of - TypeSig lname ltype -> do - lname' <- renameL lname + TypeSig lnames ltype -> do + lnames' <- mapM renameL lnames ltype' <- renameLType ltype - return (TypeSig lname' ltype') + return (TypeSig lnames' ltype') -- we have filtered out all other kinds of signatures in Interface.Create _ -> error "expected TypeSig" diff -Nru ghc-7.0.3/utils/haddock/src/Haddock/Interface/Rn.hs ghc-7.2.1/utils/haddock/src/Haddock/Interface/Rn.hs --- ghc-7.0.3/utils/haddock/src/Haddock/Interface/Rn.hs 2011-03-26 18:10:10.000000000 +0000 +++ ghc-7.2.1/utils/haddock/src/Haddock/Interface/Rn.hs 2011-08-07 17:10:06.000000000 +0000 @@ -6,7 +6,7 @@ import RdrName ( RdrName, gre_name, GlobalRdrEnv, lookupGRE_RdrName ) import Name ( Name ) -import Outputable ( ppr, defaultUserStyle ) +import Outputable ( ppr, showSDoc ) rnHaddockModInfo :: GlobalRdrEnv -> HaddockModInfo RdrName -> HaddockModInfo Name rnHaddockModInfo gre (HaddockModInfo desc port stab maint) = @@ -14,7 +14,7 @@ ids2string :: [RdrName] -> String ids2string [] = [] -ids2string (x:_) = show $ ppr x defaultUserStyle +ids2string (x:_) = showSDoc $ ppr x data Id x = Id {unId::x} instance Monad Id where (Id v)>>=f = f v; return = Id diff -Nru ghc-7.0.3/utils/haddock/src/Haddock/InterfaceFile.hs ghc-7.2.1/utils/haddock/src/Haddock/InterfaceFile.hs --- ghc-7.0.3/utils/haddock/src/Haddock/InterfaceFile.hs 2011-03-26 18:10:10.000000000 +0000 +++ ghc-7.2.1/utils/haddock/src/Haddock/InterfaceFile.hs 2011-08-07 17:10:06.000000000 +0000 @@ -68,6 +68,10 @@ binaryInterfaceVersion = 16 #elif __GLASGOW_HASKELL__ == 701 binaryInterfaceVersion = 16 +#elif __GLASGOW_HASKELL__ == 702 +binaryInterfaceVersion = 16 +#elif __GLASGOW_HASKELL__ == 703 +binaryInterfaceVersion = 16 #else #error Unknown GHC version #endif diff -Nru ghc-7.0.3/utils/haddock/src/Haddock/Lex.hs ghc-7.2.1/utils/haddock/src/Haddock/Lex.hs --- ghc-7.0.3/utils/haddock/src/Haddock/Lex.hs 2011-03-26 20:51:08.000000000 +0000 +++ ghc-7.2.1/utils/haddock/src/Haddock/Lex.hs 2011-08-07 20:09:18.000000000 +0000 @@ -21,6 +21,7 @@ import RdrName import SrcLoc import DynFlags +import FastString import Data.Char import Numeric @@ -166,7 +167,7 @@ alex_deflt = AlexA# "\xff\xff\x1d\x00\x43\x00\xff\xff\x24\x00\x26\x00\xff\xff\xff\xff\x43\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x1d\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x24\x00\xff\xff\x26\x00\xff\xff\xff\xff\xff\xff\x2b\x00\x2b\x00\x2e\x00\xff\xff\x2e\x00\xff\xff\x31\x00\x31\x00\xff\xff\x34\x00\x34\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x39\x00\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\xff\x43\x00\xff\xff\xff\xff"# alex_accept = listArray (0::Int,69) [[(AlexAcc (alex_action_7))],[(AlexAcc (alex_action_12))],[],[(AlexAcc (alex_action_15))],[],[],[(AlexAcc (alex_action_11))],[(AlexAcc (alex_action_7))],[],[],[(AlexAccSkip)],[],[(AlexAcc (alex_action_7))],[(AlexAcc (alex_action_1))],[(AlexAcc (alex_action_2))],[],[(AlexAcc (alex_action_3))],[(AlexAcc (alex_action_4))],[(AlexAcc (alex_action_5))],[],[],[(AlexAcc (alex_action_6))],[],[(AlexAcc (alex_action_8))],[],[(AlexAcc (alex_action_9))],[],[(AlexAcc (alex_action_10))],[(AlexAcc (alex_action_12))],[(AlexAcc (alex_action_12))],[(AlexAcc (alex_action_13))],[],[(AlexAcc (alex_action_14))],[],[],[(AlexAcc (alex_action_16))],[],[(AlexAcc (alex_action_17))],[],[(AlexAcc (alex_action_18))],[(AlexAcc (alex_action_19))],[(AlexAcc (alex_action_20))],[],[],[(AlexAcc (alex_action_27))],[(AlexAcc (alex_action_20))],[],[(AlexAcc (alex_action_21))],[(AlexAcc (alex_action_27))],[],[(AlexAcc (alex_action_22))],[(AlexAcc (alex_action_27))],[],[(AlexAcc (alex_action_23))],[(AlexAcc (alex_action_23))],[],[(AlexAcc (alex_action_27))],[(AlexAcc (alex_action_24))],[(AlexAcc (alex_action_27))],[(AlexAcc (alex_action_25))],[],[],[(AlexAcc (alex_action_27))],[(AlexAcc (alex_action_26))],[],[],[(AlexAcc (alex_action_28))],[(AlexAcc (alex_action_29))],[(AlexAcc (alex_action_30))],[(AlexAcc (alex_action_31))]] -{-# LINE 113 "utils/haddock/src/Haddock/Lex.x" #-} +{-# LINE 114 "utils/haddock/src/Haddock/Lex.x" #-} -- | A located token type LToken = (Token, AlexPosn) @@ -235,19 +236,25 @@ ident :: Action ident pos str sc cont dflags = - case strToHsQNames dflags id of + case strToHsQNames dflags loc id of Just names -> (TokIdent names, pos) : cont sc Nothing -> (TokString str, pos) : cont sc where id = init (tail str) + -- TODO: Get the real filename here. Maybe we should just be + -- using GHC SrcLoc's ourself? + filename = mkFastString "" + loc = case pos of + AlexPn _ line col -> + mkRealSrcLoc filename line col -strToHsQNames :: DynFlags -> String -> Maybe [RdrName] -strToHsQNames dflags str0 = +strToHsQNames :: DynFlags -> RealSrcLoc -> String -> Maybe [RdrName] +strToHsQNames dflags loc str0 = #if MIN_VERSION_ghc(7,1,0) let buffer = stringToStringBuffer str0 #else let buffer = unsafePerformIO (stringToStringBuffer str0) #endif - pstate = mkPState dflags buffer noSrcLoc + pstate = mkPState dflags buffer loc result = unP parseIdentifier pstate in case result of POk _ name -> Just [unLoc name] diff -Nru ghc-7.0.3/utils/haddock/src/Haddock/Lex.x.source ghc-7.2.1/utils/haddock/src/Haddock/Lex.x.source --- ghc-7.0.3/utils/haddock/src/Haddock/Lex.x.source 2011-03-26 18:10:10.000000000 +0000 +++ ghc-7.2.1/utils/haddock/src/Haddock/Lex.x.source 2011-08-07 17:10:06.000000000 +0000 @@ -28,6 +28,7 @@ import RdrName import SrcLoc import DynFlags +import FastString import Data.Char import Numeric @@ -178,19 +179,25 @@ ident :: Action ident pos str sc cont dflags = - case strToHsQNames dflags id of + case strToHsQNames dflags loc id of Just names -> (TokIdent names, pos) : cont sc Nothing -> (TokString str, pos) : cont sc where id = init (tail str) + -- TODO: Get the real filename here. Maybe we should just be + -- using GHC SrcLoc's ourself? + filename = mkFastString "" + loc = case pos of + AlexPn _ line col -> + mkRealSrcLoc filename line col -strToHsQNames :: DynFlags -> String -> Maybe [RdrName] -strToHsQNames dflags str0 = +strToHsQNames :: DynFlags -> RealSrcLoc -> String -> Maybe [RdrName] +strToHsQNames dflags loc str0 = #if MIN_VERSION_ghc(7,1,0) let buffer = stringToStringBuffer str0 #else let buffer = unsafePerformIO (stringToStringBuffer str0) #endif - pstate = mkPState dflags buffer noSrcLoc + pstate = mkPState dflags buffer loc result = unP parseIdentifier pstate in case result of POk _ name -> Just [unLoc name] diff -Nru ghc-7.0.3/utils/haddock/src/Haddock/Parse.hs ghc-7.2.1/utils/haddock/src/Haddock/Parse.hs --- ghc-7.0.3/utils/haddock/src/Haddock/Parse.hs 2011-03-26 20:51:08.000000000 +0000 +++ ghc-7.2.1/utils/haddock/src/Haddock/Parse.hs 2011-08-07 20:09:18.000000000 +0000 @@ -551,14 +551,21 @@ -- whitespace in expressions, so drop them result' where - -- drop trailing whitespace from the prompt, remember the prefix + -- 1. drop trailing whitespace from the prompt, remember the prefix (prefix, _) = span isSpace prompt - -- drop, if possible, the exact same sequence of whitespace characters - -- from each result line - result' = map (tryStripPrefix prefix) result + + -- 2. drop, if possible, the exact same sequence of whitespace + -- characters from each result line + -- + -- 3. interpret lines that only contain the string "" as an + -- empty line + result' = map (substituteBlankLine . tryStripPrefix prefix) result where tryStripPrefix xs ys = fromMaybe ys $ stripPrefix xs ys + substituteBlankLine "" = "" + substituteBlankLine line = line + -- | Remove all leading and trailing whitespace strip :: String -> String strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse diff -Nru ghc-7.0.3/utils/haddock/src/Haddock/Parse.y.source ghc-7.2.1/utils/haddock/src/Haddock/Parse.y.source --- ghc-7.0.3/utils/haddock/src/Haddock/Parse.y.source 2011-03-26 18:10:10.000000000 +0000 +++ ghc-7.2.1/utils/haddock/src/Haddock/Parse.y.source 2011-08-07 17:10:06.000000000 +0000 @@ -129,14 +129,21 @@ -- whitespace in expressions, so drop them result' where - -- drop trailing whitespace from the prompt, remember the prefix + -- 1. drop trailing whitespace from the prompt, remember the prefix (prefix, _) = span isSpace prompt - -- drop, if possible, the exact same sequence of whitespace characters - -- from each result line - result' = map (tryStripPrefix prefix) result + + -- 2. drop, if possible, the exact same sequence of whitespace + -- characters from each result line + -- + -- 3. interpret lines that only contain the string "" as an + -- empty line + result' = map (substituteBlankLine . tryStripPrefix prefix) result where tryStripPrefix xs ys = fromMaybe ys $ stripPrefix xs ys + substituteBlankLine "" = "" + substituteBlankLine line = line + -- | Remove all leading and trailing whitespace strip :: String -> String strip = dropWhile isSpace . reverse . dropWhile isSpace . reverse diff -Nru ghc-7.0.3/utils/haddock/src/Haddock/Types.hs ghc-7.2.1/utils/haddock/src/Haddock/Types.hs --- ghc-7.0.3/utils/haddock/src/Haddock/Types.hs 2011-03-26 18:10:10.000000000 +0000 +++ ghc-7.2.1/utils/haddock/src/Haddock/Types.hs 2011-08-07 17:10:06.000000000 +0000 @@ -26,7 +26,6 @@ import Data.Map (Map) import qualified Data.Map as Map import GHC hiding (NoLink) -import Name ----------------------------------------------------------------------------- diff -Nru ghc-7.0.3/utils/haddock/src/Haddock/Utils.hs ghc-7.2.1/utils/haddock/src/Haddock/Utils.hs --- ghc-7.0.3/utils/haddock/src/Haddock/Utils.hs 2011-03-26 18:10:10.000000000 +0000 +++ ghc-7.2.1/utils/haddock/src/Haddock/Utils.hs 2011-08-07 17:10:06.000000000 +0000 @@ -68,7 +68,7 @@ import qualified Data.Map as Map hiding ( Map ) import Data.IORef ( IORef, newIORef, readIORef ) import Data.List ( isSuffixOf ) -import Data.Maybe ( fromJust ) +import Data.Maybe ( mapMaybe ) import System.Environment ( getProgName ) import System.Exit ( exitWith, ExitCode(..) ) import System.IO ( hPutStr, stderr ) @@ -160,9 +160,7 @@ restrictDecls :: [Name] -> [LSig Name] -> [LSig Name] -restrictDecls names decls = filter keep decls - where keep d = fromJust (sigName d) `elem` names - -- has to have a name, since it's a class method type signature +restrictDecls names decls = mapMaybe (filterLSigNames (`elem` names)) decls restrictATs :: [Name] -> [LTyClDecl Name] -> [LTyClDecl Name] diff -Nru ghc-7.0.3/utils/haddock/src/Main.hs ghc-7.2.1/utils/haddock/src/Main.hs --- ghc-7.0.3/utils/haddock/src/Main.hs 2011-03-26 18:10:10.000000000 +0000 +++ ghc-7.2.1/utils/haddock/src/Main.hs 2011-08-07 17:10:06.000000000 +0000 @@ -57,7 +57,7 @@ import GHC hiding (flags, verbosity) import Config import DynFlags hiding (flags, verbosity) -import Panic (handleGhcException) +import Panic (panic, handleGhcException) import Module @@ -393,7 +393,7 @@ [] -> return Nothing [filename] -> do str <- readFile filename - case parseParas (tokenise defaultDynFlags str + case parseParas (tokenise (defaultDynFlags (panic "No settings")) str (1,0) {- TODO: real position -}) of Nothing -> throwE $ "failed to parse haddock prologue from file: " ++ filename Just doc -> return (Just doc) @@ -416,18 +416,17 @@ getExecDir :: IO (Maybe String) #if defined(mingw32_HOST_OS) -getExecDir = allocaArray len $ \buf -> do - ret <- getModuleFileName nullPtr buf len - if ret == 0 then - return Nothing - else do - s <- peekCString buf - return (Just (dropFileName s)) - where len = 2048 -- Plenty, PATH_MAX is 512 under Win32. - +getExecDir = try_size 2048 -- plenty, PATH_MAX is 512 under Win32. + where + try_size size = allocaArray (fromIntegral size) $ \buf -> do + ret <- c_GetModuleFileName nullPtr buf size + case ret of + 0 -> return Nothing + _ | ret < size -> fmap (Just . dropFileName) $ peekCWString buf + | otherwise -> try_size (size * 2) -foreign import stdcall unsafe "GetModuleFileNameA" - getModuleFileName :: Ptr () -> CString -> Int -> IO Int32 +foreign import stdcall unsafe "windows.h GetModuleFileNameW" + c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32 #else getExecDir = return Nothing #endif diff -Nru ghc-7.0.3/utils/haddock/tests/html-tests/README ghc-7.2.1/utils/haddock/tests/html-tests/README --- ghc-7.0.3/utils/haddock/tests/html-tests/README 2011-03-26 18:10:10.000000000 +0000 +++ ghc-7.2.1/utils/haddock/tests/html-tests/README 2011-08-07 17:10:06.000000000 +0000 @@ -1,4 +1,3 @@ - This is a testsuite for Haddock that uses the concept of "golden files". That is, it compares output files against a set of reference files. @@ -6,7 +5,7 @@ 1) Create a module in the "tests" directory. - 2) Run runtests.hs. You should now have output/.html. The test + 2) Run "cabal test". You should now have output/.html. The test passes since there is no reference file to compare with. 3) To make a reference file from the output file, do @@ -14,15 +13,12 @@ Tips and tricks: -You can +To copy all output files into reference files, run runhaskell copy.hs -to copy all output files into reference files. - -You can - runhaskell runtests.hs all - -to continue despite a failing test. +You can run all tests despite failing tests, like so + cabal test --test-option=all You can pass extra options to haddock like so - runhaskell runtests.hs --title="All Tests" all + cabal test --test-options='all --title="All Tests"' + diff -Nru ghc-7.0.3/utils/haddock/tests/html-tests/runtests.hs ghc-7.2.1/utils/haddock/tests/html-tests/runtests.hs --- ghc-7.0.3/utils/haddock/tests/html-tests/runtests.hs 2011-03-26 18:10:10.000000000 +0000 +++ ghc-7.2.1/utils/haddock/tests/html-tests/runtests.hs 2011-08-07 17:10:06.000000000 +0000 @@ -14,8 +14,11 @@ import Data.Maybe -haddockBase = ".." ".." -haddockPath = haddockBase "dist" "build" "haddock" "haddock" +packageRoot = "." +haddockPath = packageRoot "dist" "build" "haddock" "haddock" +testSuiteRoot = packageRoot "tests" "html-tests" +testDir = testSuiteRoot "tests" +outDir = testSuiteRoot "output" main = do @@ -27,7 +30,7 @@ x <- doesFileExist haddockPath when (not x) $ die "you need to run 'cabal build' successfully first" - contents <- getDirectoryContents "tests" + contents <- getDirectoryContents testDir args <- getArgs let (opts, spec) = span ("-" `isPrefixOf`) args let mods = @@ -35,17 +38,16 @@ x:_ | x /= "all" -> [x ++ ".hs"] _ -> filter ((==) ".hs" . takeExtension) contents - let outdir = "output" - let mods' = map ("tests" ) mods + let mods' = map (testDir ) mods putStrLn "" putStrLn "Haddock version: " h1 <- runProcess haddockPath ["--version"] Nothing - (Just [("haddock_datadir", haddockBase)]) Nothing Nothing Nothing + (Just [("haddock_datadir", packageRoot)]) Nothing Nothing Nothing waitForProcess h1 putStrLn "" putStrLn "GHC version: " h2 <- runProcess haddockPath ["--ghc-version"] Nothing - (Just [("haddock_datadir", haddockBase)]) Nothing Nothing Nothing + (Just [("haddock_datadir", packageRoot)]) Nothing Nothing Nothing waitForProcess h2 putStrLn "" @@ -57,15 +59,15 @@ let path = init libdir librariesPath name ++ "-" ++ version in "-i " ++ path ++ "," ++ path name ++ ".haddock" - let base = mkDep "base" "4.3.0.0" - process = mkDep "process" "1.0.1.4" + let base = mkDep "base" "4.3.1.0" + process = mkDep "process" "1.0.1.5" ghcprim = mkDep "ghc-prim" "0.2.0.0" putStrLn "Running tests..." handle <- runProcess haddockPath - (["-w", "-o", outdir, "-h", "--pretty-html", "--optghc=-fglasgow-exts" + (["-w", "-o", outDir, "-h", "--pretty-html", "--optghc=-fglasgow-exts" , "--optghc=-w", base, process, ghcprim] ++ opts ++ mods') - Nothing (Just [("haddock_datadir", haddockBase)]) Nothing + Nothing (Just [("haddock_datadir", packageRoot)]) Nothing Nothing Nothing code <- waitForProcess handle @@ -75,12 +77,12 @@ check modules strict = do forM_ modules $ \mod -> do - let outfile = "output" (dropExtension mod ++ ".html") - let reffile = "tests" dropExtension mod ++ ".html.ref" + let outfile = outDir dropExtension mod ++ ".html" + let reffile = testDir dropExtension mod ++ ".html.ref" b <- doesFileExist reffile if b then do - copyFile reffile ("output" takeFileName reffile) + copyFile reffile (outDir takeFileName reffile) out <- readFile outfile ref <- readFile reffile if not $ haddockEq out ref @@ -88,8 +90,8 @@ putStrLn $ "Output for " ++ mod ++ " has changed! Exiting with diff:" let ref' = stripLinks ref out' = stripLinks out - let reffile' = "output" takeFileName reffile ++ ".nolinks" - outfile' = "output" takeFileName outfile ++ ".nolinks" + let reffile' = outDir takeFileName reffile ++ ".nolinks" + outfile' = outDir takeFileName outfile ++ ".nolinks" writeFile reffile' ref' writeFile outfile' out' b <- programOnPath "colordiff" diff -Nru ghc-7.0.3/utils/haddock/tests/html-tests/tests/A.html.ref ghc-7.2.1/utils/haddock/tests/html-tests/tests/A.html.ref --- ghc-7.0.3/utils/haddock/tests/html-tests/tests/A.html.ref 2011-03-26 18:10:10.000000000 +0000 +++ ghc-7.2.1/utils/haddock/tests/html-tests/tests/A.html.ref 2011-08-07 17:10:06.000000000 +0000 @@ -61,7 +61,7 @@ >>> isSpace 'a' -- False -- +-- >>> putStrLn "foo\n\nbar" +-- foo +-- +-- bar +-- fib :: Integer -> Integer fib 0 = 0 fib 1 = 1 diff -Nru ghc-7.0.3/utils/haddock/tests/html-tests/tests/Examples.html.ref ghc-7.2.1/utils/haddock/tests/html-tests/tests/Examples.html.ref --- ghc-7.0.3/utils/haddock/tests/html-tests/tests/Examples.html.ref 2011-03-26 18:10:10.000000000 +0000 +++ ghc-7.2.1/utils/haddock/tests/html-tests/tests/Examples.html.ref 2011-08-07 17:10:06.000000000 +0000 @@ -136,6 +136,18 @@ >False 
    >>> putStrLn "foo\n\nbar"
+foo
+
+bar
+
    support + , ParseTest { + input = ">>> putFooBar\nfoo\n\nbar" + , result = Just $ DocExamples $ [Example "putFooBar" ["foo","","bar"]] + } ] @@ -50,7 +56,7 @@ where toTestCase :: ParseTest -> Test - toTestCase (ParseTest input result) = TestCase $ assertEqual input (parse input) result + toTestCase (ParseTest input result) = TestCase $ assertEqual input result (parse input) parse :: String -> Maybe (Doc RdrName) parse input = parseParas $ tokenise defaultDynFlags input (0,0) diff -Nru ghc-7.0.3/utils/haddock/tests/unit-tests/runparsetests.sh ghc-7.2.1/utils/haddock/tests/unit-tests/runparsetests.sh --- ghc-7.0.3/utils/haddock/tests/unit-tests/runparsetests.sh 2011-03-26 18:10:10.000000000 +0000 +++ ghc-7.2.1/utils/haddock/tests/unit-tests/runparsetests.sh 2011-08-07 17:10:06.000000000 +0000 @@ -11,4 +11,5 @@ -packageHUnit \ -i../../dist/build/ \ -i../../src/ \ + -optP-include -optP../../dist/build/autogen/cabal_macros.h \ parsetests.hs diff -Nru ghc-7.0.3/utils/hpc/ghc.mk ghc-7.2.1/utils/hpc/ghc.mk --- ghc-7.0.3/utils/hpc/ghc.mk 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/utils/hpc/ghc.mk 2011-08-07 17:10:05.000000000 +0000 @@ -10,10 +10,10 @@ # # ----------------------------------------------------------------------------- -utils/hpc_dist_MODULES = Main HpcCombine HpcDraft HpcFlags HpcLexer HpcMap \ - HpcMarkup HpcOverlay HpcParser HpcReport HpcSet \ +utils/hpc_dist-install_MODULES = Main HpcCombine HpcDraft HpcFlags HpcLexer \ + HpcMarkup HpcOverlay HpcParser HpcReport \ HpcShowTix HpcUtils -utils/hpc_dist_HC_OPTS = -cpp -package hpc -utils/hpc_dist_INSTALL = YES -utils/hpc_dist_PROG = hpc$(exeext) -$(eval $(call build-prog,utils/hpc,dist,1)) +utils/hpc_dist-install_HC_OPTS = -cpp -package hpc +utils/hpc_dist-install_INSTALL = YES +utils/hpc_dist-install_PROG = hpc$(exeext) +$(eval $(call build-prog,utils/hpc,dist-install,1)) diff -Nru ghc-7.0.3/utils/hpc/HpcCombine.hs ghc-7.2.1/utils/hpc/HpcCombine.hs --- ghc-7.0.3/utils/hpc/HpcCombine.hs 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/utils/hpc/HpcCombine.hs 2011-08-07 17:10:05.000000000 +0000 @@ -11,8 +11,8 @@ import HpcFlags import Control.Monad -import qualified HpcSet as Set -import qualified HpcMap as Map +import qualified Data.Set as Set +import qualified Data.Map as Map ------------------------------------------------------------------------------ sum_options :: FlagOptSeq diff -Nru ghc-7.0.3/utils/hpc/HpcDraft.hs ghc-7.2.1/utils/hpc/HpcDraft.hs --- ghc-7.0.3/utils/hpc/HpcDraft.hs 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/utils/hpc/HpcDraft.hs 2011-08-07 17:10:05.000000000 +0000 @@ -6,8 +6,8 @@ import HpcFlags -import qualified HpcSet as Set -import qualified HpcMap as Map +import qualified Data.Set as Set +import qualified Data.Map as Map import HpcUtils import Data.Tree diff -Nru ghc-7.0.3/utils/hpc/HpcFlags.hs ghc-7.2.1/utils/hpc/HpcFlags.hs --- ghc-7.0.3/utils/hpc/HpcFlags.hs 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/utils/hpc/HpcFlags.hs 2011-08-07 17:10:05.000000000 +0000 @@ -3,7 +3,7 @@ module HpcFlags where import System.Console.GetOpt -import qualified HpcSet as Set +import qualified Data.Set as Set import Data.Char import Trace.Hpc.Tix import Trace.Hpc.Mix diff -Nru ghc-7.0.3/utils/hpc/HpcMap.hs ghc-7.2.1/utils/hpc/HpcMap.hs --- ghc-7.0.3/utils/hpc/HpcMap.hs 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/utils/hpc/HpcMap.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,32 +0,0 @@ -module HpcMap ( module HpcMap ) where - -#if __GLASGOW_HASKELL__ < 604 -import qualified Data.FiniteMap as Map -#else -import qualified Data.Map as Map -#endif - - -lookup :: Ord key => key -> Map key elt -> Maybe elt -fromList :: Ord key => [(key,elt)] -> Map key elt -fromListWith :: Ord k => (a -> a -> a) -> [(k, a)] -> Map k a -toList :: Ord key => Map key elt -> [(key,elt)] - -#if __GLASGOW_HASKELL__ < 604 -type Map key elt = Map.FiniteMap key elt - -lookup = flip Map.lookupFM -fromList = Map.listToFM -fromListWith f xs = Map.addListToFM_C f Map.emptyFM xs -toList = Map.fmToList - -#else - -type Map key elt = Map.Map key elt - -lookup = Map.lookup -fromList = Map.fromList -toList = Map.toList -fromListWith = Map.fromListWith - -#endif diff -Nru ghc-7.0.3/utils/hpc/HpcMarkup.hs ghc-7.2.1/utils/hpc/HpcMarkup.hs --- ghc-7.0.3/utils/hpc/HpcMarkup.hs 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/utils/hpc/HpcMarkup.hs 2011-08-07 17:10:05.000000000 +0000 @@ -18,7 +18,7 @@ import Data.Array import Data.Monoid import Control.Monad -import qualified HpcSet as Set +import qualified Data.Set as Set ------------------------------------------------------------------------------ @@ -452,11 +452,9 @@ -- packages, and a single .tix file might contain information about -- many package. -#if __GLASGOW_HASKELL__ >= 604 -- create the dest_dir if needed when (not (null dest_dir)) $ createDirectoryIfMissing True dest_dir -#endif writeFile filename text diff -Nru ghc-7.0.3/utils/hpc/HpcOverlay.hs ghc-7.2.1/utils/hpc/HpcOverlay.hs --- ghc-7.0.3/utils/hpc/HpcOverlay.hs 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/utils/hpc/HpcOverlay.hs 2011-08-07 17:10:05.000000000 +0000 @@ -6,7 +6,7 @@ import Trace.Hpc.Tix import Trace.Hpc.Mix import Trace.Hpc.Util -import HpcMap as Map +import qualified Data.Map as Map import Data.Tree overlay_options :: FlagOptSeq diff -Nru ghc-7.0.3/utils/hpc/HpcParser.hs ghc-7.2.1/utils/hpc/HpcParser.hs --- ghc-7.0.3/utils/hpc/HpcParser.hs 2011-03-26 20:51:08.000000000 +0000 +++ ghc-7.2.1/utils/hpc/HpcParser.hs 2011-08-07 20:09:18.000000000 +0000 @@ -1,5 +1,6 @@ {-# OPTIONS_GHC -fno-warn-overlapping-patterns #-} {-# OPTIONS -fglasgow-exts -cpp #-} +{-# LANGUAGE BangPatterns #-} -- required for versions of Happy before 1.18.6 {-# OPTIONS -Wwarn -XNoMonomorphismRestriction #-} -- The NoMonomorphismRestriction deals with a Happy infelicity -- With OutsideIn's more conservativ monomorphism restriction diff -Nru ghc-7.0.3/utils/hpc/HpcParser.y.source ghc-7.2.1/utils/hpc/HpcParser.y.source --- ghc-7.0.3/utils/hpc/HpcParser.y.source 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/utils/hpc/HpcParser.y.source 2011-08-07 17:10:05.000000000 +0000 @@ -1,4 +1,5 @@ { +{-# LANGUAGE BangPatterns #-} -- required for versions of Happy before 1.18.6 {-# OPTIONS -Wwarn -XNoMonomorphismRestriction #-} -- The NoMonomorphismRestriction deals with a Happy infelicity -- With OutsideIn's more conservativ monomorphism restriction diff -Nru ghc-7.0.3/utils/hpc/HpcReport.hs ghc-7.2.1/utils/hpc/HpcReport.hs --- ghc-7.0.3/utils/hpc/HpcReport.hs 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/utils/hpc/HpcReport.hs 2011-08-07 17:10:05.000000000 +0000 @@ -11,7 +11,7 @@ import Trace.Hpc.Mix import Trace.Hpc.Tix import Control.Monad hiding (guard) -import qualified HpcSet as Set +import qualified Data.Set as Set notExpecting :: String -> a notExpecting s = error ("not expecting "++s) diff -Nru ghc-7.0.3/utils/hpc/HpcSet.hs ghc-7.2.1/utils/hpc/HpcSet.hs --- ghc-7.0.3/utils/hpc/HpcSet.hs 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/utils/hpc/HpcSet.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,39 +0,0 @@ -module HpcSet ( module HpcSet ) where - -import qualified Data.Set as Set - -type Set a = Set.Set a - -empty :: Set a -insert :: (Ord a) => a -> Set a -> Set a -member :: (Ord a) => a -> Set a -> Bool -null :: Set a -> Bool -intersection :: Ord a => Set a -> Set a -> Set a -fromList :: Ord a => [a] -> Set a -toList :: Set a -> [a] -union :: Ord a => Set a -> Set a -> Set a - -#if __GLASGOW_HASKELL__ < 604 - -empty = Set.emptySet -insert = flip Set.addToSet -member = Set.elementOf -null = Set.isEmptySet -intersection = Set.intersect -fromList = Set.mkSet -toList = Set.setToList -union = Set.union - -#else - -empty = Set.empty -insert = Set.insert -member = Set.member -null = Set.null -intersection = Set.intersection -fromList = Set.fromList -toList = Set.toList -union = Set.union - -#endif - diff -Nru ghc-7.0.3/utils/hpc/HpcShowTix.hs ghc-7.2.1/utils/hpc/HpcShowTix.hs --- ghc-7.0.3/utils/hpc/HpcShowTix.hs 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/utils/hpc/HpcShowTix.hs 2011-08-07 17:10:05.000000000 +0000 @@ -5,7 +5,7 @@ import HpcFlags -import qualified HpcSet as Set +import qualified Data.Set as Set showtix_options :: FlagOptSeq showtix_options diff -Nru ghc-7.0.3/utils/hpc/HpcUtils.hs ghc-7.2.1/utils/hpc/HpcUtils.hs --- ghc-7.0.3/utils/hpc/HpcUtils.hs 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/utils/hpc/HpcUtils.hs 2011-08-07 17:10:05.000000000 +0000 @@ -1,7 +1,7 @@ module HpcUtils where import Trace.Hpc.Util -import qualified HpcMap as Map +import qualified Data.Map as Map -- turns \n into ' ' -- | grab's the text behind a HpcPos; @@ -23,9 +23,9 @@ readFileFromPath _ filename@('/':_) _ = readFile filename readFileFromPath err filename path0 = readTheFile path0 where - readTheFile [] = err $ "could not find " ++ show filename - ++ " in path " ++ show path0 - readTheFile (dir:dirs) = - catch (do str <- readFile (dir ++ "/" ++ filename) - return str) - (\ _ -> readTheFile dirs) + readTheFile [] = err $ "could not find " ++ show filename + ++ " in path " ++ show path0 + readTheFile (dir:dirs) = + catchIO (do str <- readFile (dir ++ "/" ++ filename) + return str) + (\ _ -> readTheFile dirs) diff -Nru ghc-7.0.3/utils/hsc2hs/C.hs ghc-7.2.1/utils/hsc2hs/C.hs --- ghc-7.0.3/utils/hsc2hs/C.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/utils/hsc2hs/C.hs 2011-08-07 17:10:06.000000000 +0000 @@ -0,0 +1,231 @@ +{-# LANGUAGE CPP #-} +module C where + +{- +The standard mode for hsc2hs: generates a C file which is +compiled and run; the output of that program is the .hs file. +-} + +import Data.Char ( isSpace, intToDigit, ord ) +import Data.List ( intersperse ) +import HSCParser ( SourcePos(..), Token(..) ) + +import Common +import Flags + +outTemplateHeaderCProg :: FilePath -> String +outTemplateHeaderCProg template = "#include \"" ++ template ++ "\"\n" + +outFlagHeaderCProg :: Flag -> String +outFlagHeaderCProg (Include f) = "#include "++f++"\n" +outFlagHeaderCProg (Define n Nothing) = "#define "++n++" 1\n" +outFlagHeaderCProg (Define n (Just v)) = "#define "++n++" "++v++"\n" +outFlagHeaderCProg _ = "" + +outHeaderCProg :: (SourcePos, String, String) -> String +outHeaderCProg (pos, key, arg) = case key of + "include" -> outCLine pos++"#include "++arg++"\n" + "define" -> outCLine pos++"#define "++arg++"\n" + "undef" -> outCLine pos++"#undef "++arg++"\n" + "def" -> case arg of + 's':'t':'r':'u':'c':'t':' ':_ -> outCLine pos++arg++"\n" + 't':'y':'p':'e':'d':'e':'f':' ':_ -> outCLine pos++arg++"\n" + _ -> "" + _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n" + "let" -> case break (== '=') arg of + (_, "") -> "" + (header, _:body) -> case break isSpace header of + (name, args) -> + outCLine pos++ + "#define hsc_"++name++"("++dropWhile isSpace args++") " ++ + "printf ("++joinLines body++");\n" + _ -> "" + where + joinLines = concat . intersperse " \\\n" . lines + +outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String +outHeaderHs flags inH toks = + "#if " ++ + "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n" ++ + " printf (\"{-# OPTIONS -optc-D" ++ + "__GLASGOW_HASKELL__=%d #-}\\n\", " ++ + "__GLASGOW_HASKELL__);\n" ++ + "#endif\n"++ + case inH of + Nothing -> concatMap outFlag flags++concatMap outSpecial toks + Just f -> outInclude ("\""++f++"\"") + where + outFlag (Include f) = outInclude f + outFlag (Define n Nothing) = outOption ("-optc-D"++n) + outFlag (Define n (Just v)) = outOption ("-optc-D"++n++"="++v) + outFlag _ = "" + outSpecial (pos, key, arg) = case key of + "include" -> outInclude arg + "define" | goodForOptD arg -> outOption ("-optc-D"++toOptD arg) + | otherwise -> "" + _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n" + _ -> "" + goodForOptD arg = case arg of + "" -> True + c:_ | isSpace c -> True + '(':_ -> False + _:s -> goodForOptD s + toOptD arg = case break isSpace arg of + (name, "") -> name + (name, _:value) -> name++'=':dropWhile isSpace value + outOption s = + "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 603\n" ++ + " printf (\"{-# OPTIONS %s #-}\\n\", \""++ + showCString s++"\");\n"++ + "#else\n"++ + " printf (\"{-# OPTIONS_GHC %s #-}\\n\", \""++ + showCString s++"\");\n"++ + "#endif\n" + outInclude s = + "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 603\n" ++ + " printf (\"{-# OPTIONS -#include %s #-}\\n\", \""++ + showCString s++"\");\n"++ + "#elif __GLASGOW_HASKELL__ < 610\n"++ + " printf (\"{-# INCLUDE %s #-}\\n\", \""++ + showCString s++"\");\n"++ + "#endif\n" + +outTokenHs :: Token -> String +outTokenHs (Text pos txt) = + case break (== '\n') txt of + (allTxt, []) -> outText allTxt + (first, _:rest) -> + outText (first++"\n")++ + outHsLine pos++ + outText rest + where + outText s = " fputs (\""++showCString s++"\", stdout);\n" +outTokenHs (Special pos key arg) = + case key of + "include" -> "" + "define" -> "" + "undef" -> "" + "def" -> "" + _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n" + "let" -> "" + "enum" -> outCLine pos++outEnum arg + _ -> outCLine pos++" hsc_"++key++" ("++arg++");\n" + +parseEnum :: String -> Maybe (String,String,[(Maybe String,String)]) +parseEnum arg = + case break (== ',') arg of + (_, []) -> Nothing + (t, _:afterT) -> case break (== ',') afterT of + (f, afterF) -> let + enums [] = [] + enums (_:s) = case break (== ',') s of + (enum, rest) -> let + this = case break (== '=') $ dropWhile isSpace enum of + (name, []) -> (Nothing, name) + (hsName, _:cName) -> (Just hsName, cName) + in this:enums rest + in Just (t, f, enums afterF) + +outEnum :: String -> String +outEnum arg = case parseEnum arg of + Nothing -> "" + Just (t,f,enums) -> + flip concatMap enums $ \(maybeHsName, cName) -> + case maybeHsName of + Nothing -> + " hsc_enum ("++t++", "++f++", " ++ + "hsc_haskellize (\""++cName++"\"), "++ + cName++");\n" + Just hsName -> + " hsc_enum ("++t++", "++f++", " ++ + "printf (\"%s\", \""++hsName++"\"), "++ + cName++");\n" + +outFlagH :: Flag -> String +outFlagH (Include f) = "#include "++f++"\n" +outFlagH (Define n Nothing) = "#define "++n++" 1\n" +outFlagH (Define n (Just v)) = "#define "++n++" "++v++"\n" +outFlagH _ = "" + +outTokenH :: (SourcePos, String, String) -> String +outTokenH (pos, key, arg) = + case key of + "include" -> outCLine pos++"#include "++arg++"\n" + "define" -> outCLine pos++"#define " ++arg++"\n" + "undef" -> outCLine pos++"#undef " ++arg++"\n" + "def" -> outCLine pos++case arg of + 's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n" + 't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n" + 'i':'n':'l':'i':'n':'e':' ':_ -> + "#ifdef __GNUC__\n" ++ + "extern\n" ++ + "#endif\n"++ + arg++"\n" + _ -> "extern "++header++";\n" + where header = takeWhile (\c -> c /= '{' && c /= '=') arg + _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n" + _ -> "" + +outTokenC :: (SourcePos, String, String) -> String +outTokenC (pos, key, arg) = + case key of + "def" -> case arg of + 's':'t':'r':'u':'c':'t':' ':_ -> "" + 't':'y':'p':'e':'d':'e':'f':' ':_ -> "" + 'i':'n':'l':'i':'n':'e':' ':arg' -> + case span (\c -> c /= '{' && c /= '=') arg' of + (header, body) -> + outCLine pos++ + "#ifndef __GNUC__\n" ++ + "extern inline\n" ++ + "#endif\n"++ + header++ + "\n#ifndef __GNUC__\n" ++ + ";\n" ++ + "#else\n"++ + body++ + "\n#endif\n" + _ -> outCLine pos++arg++"\n" + _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n" + _ -> "" + +conditional :: String -> Bool +conditional "if" = True +conditional "ifdef" = True +conditional "ifndef" = True +conditional "elif" = True +conditional "else" = True +conditional "endif" = True +conditional "error" = True +conditional "warning" = True +conditional _ = False + +outCLine :: SourcePos -> String +outCLine (SourcePos name line) = + "#line "++show line++" \""++showCString (snd (splitName name))++"\"\n" + +outHsLine :: SourcePos -> String +outHsLine (SourcePos name line) = + " hsc_line ("++show (line + 1)++", \""++ + showCString name++"\");\n" + +showCString :: String -> String +showCString = concatMap showCChar + where + showCChar '\"' = "\\\"" + showCChar '\'' = "\\\'" + showCChar '?' = "\\?" + showCChar '\\' = "\\\\" + showCChar c | c >= ' ' && c <= '~' = [c] + showCChar '\a' = "\\a" + showCChar '\b' = "\\b" + showCChar '\f' = "\\f" + showCChar '\n' = "\\n\"\n \"" + showCChar '\r' = "\\r" + showCChar '\t' = "\\t" + showCChar '\v' = "\\v" + showCChar c = ['\\', + intToDigit (ord c `quot` 64), + intToDigit (ord c `quot` 8 `mod` 8), + intToDigit (ord c `mod` 8)] + diff -Nru ghc-7.0.3/utils/hsc2hs/Common.hs ghc-7.2.1/utils/hsc2hs/Common.hs --- ghc-7.0.3/utils/hsc2hs/Common.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/utils/hsc2hs/Common.hs 2011-08-07 17:10:06.000000000 +0000 @@ -0,0 +1,116 @@ +{-# LANGUAGE CPP #-} +module Common where + +import Control.Exception ( bracket_ ) +import qualified Control.Exception as Exception +import Control.Monad ( when ) +import System.IO + +#if __GLASGOW_HASKELL__ >= 604 +import System.Process ( runProcess, waitForProcess ) +#define HAVE_runProcess +#endif + +import System.Cmd ( rawSystem ) +#ifndef HAVE_runProcess +import System.Cmd ( system ) +#endif + +import System.Exit ( ExitCode(..), exitWith ) +import System.Directory ( removeFile ) + +die :: String -> IO a +die s = hPutStr stderr s >> exitWith (ExitFailure 1) + +default_compiler :: String +default_compiler = "gcc" + +------------------------------------------------------------------------ +-- Write the output files. + +splitName :: String -> (String, String) +splitName name = + case break (== '/') name of + (file, []) -> ([], file) + (dir, sep:rest) -> (dir++sep:restDir, restFile) + where + (restDir, restFile) = splitName rest + +splitExt :: String -> (String, String) +splitExt name = + case break (== '.') name of + (base, []) -> (base, []) + (base, sepRest@(sep:rest)) + | null restExt -> (base, sepRest) + | otherwise -> (base++sep:restBase, restExt) + where + (restBase, restExt) = splitExt rest + +writeBinaryFile :: FilePath -> String -> IO () +writeBinaryFile fp str = withBinaryFile fp WriteMode $ \h -> hPutStr h str + +rawSystemL :: String -> Bool -> FilePath -> [String] -> IO () +rawSystemL action flg prog args = do + let cmdLine = prog++" "++unwords args + when flg $ hPutStrLn stderr ("Executing: " ++ cmdLine) + exitStatus <- rawSystem prog args + case exitStatus of + ExitFailure exitCode -> die $ action ++ " failed " + ++ "(exit code " ++ show exitCode ++ ")\n" + ++ "command was: " ++ cmdLine ++ "\n" + _ -> return () + +rawSystemWithStdOutL :: String -> Bool -> FilePath -> [String] -> FilePath -> IO () +rawSystemWithStdOutL action flg prog args outFile = do + let cmdLine = prog++" "++unwords args++" >"++outFile + when flg (hPutStrLn stderr ("Executing: " ++ cmdLine)) +#ifndef HAVE_runProcess + exitStatus <- system cmdLine +#else + hOut <- openFile outFile WriteMode + process <- runProcess prog args Nothing Nothing Nothing (Just hOut) Nothing + exitStatus <- waitForProcess process + hClose hOut +#endif + case exitStatus of + ExitFailure exitCode -> die $ action ++ " failed " + ++ "(exit code " ++ show exitCode ++ ")\n" + ++ "command was: " ++ cmdLine ++ "\n" + _ -> return () + +-- delay the cleanup of generated files until the end; attempts to +-- get around intermittent failure to delete files which has +-- just been exec'ed by a sub-process (Win32 only.) +finallyRemove :: FilePath -> IO a -> IO a +finallyRemove fp act = + bracket_ (return fp) + (noisyRemove fp) + act + where + noisyRemove fpath = + catchIO (removeFile fpath) + (\ e -> hPutStrLn stderr ("Failed to remove file " ++ fpath ++ "; error= " ++ show e)) + +catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a +catchIO = Exception.catch + +onlyOne :: String -> IO a +onlyOne what = die ("Only one "++what++" may be specified\n") + +----------------------------------------- +-- Modified version from ghc/compiler/SysTools +-- Convert paths foo/baz to foo\baz on Windows + +subst :: Char -> Char -> String -> String +#if defined(mingw32_HOST_OS) || defined(__CYGWIN32__) +subst a b = map (\x -> if x == a then b else x) +#else +subst _ _ = id +#endif + +dosifyPath :: String -> String +dosifyPath = subst '/' '\\' + +unDosifyPath :: String -> String +unDosifyPath = subst '\\' '/' + diff -Nru ghc-7.0.3/utils/hsc2hs/CrossCodegen.hs ghc-7.2.1/utils/hsc2hs/CrossCodegen.hs --- ghc-7.0.3/utils/hsc2hs/CrossCodegen.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/utils/hsc2hs/CrossCodegen.hs 2011-08-07 17:10:06.000000000 +0000 @@ -0,0 +1,582 @@ +{-# LANGUAGE NoMonomorphismRestriction #-} + +module CrossCodegen where + +{- +A special cross-compilation mode for hsc2hs, which generates a .hs +file without needing to run the executables that the C compiler +outputs. + +Instead, it uses the output of compilations only -- specifically, +whether compilation fails. This is the same trick that autoconf uses +when cross compiling; if you want to know if sizeof(int) <= 4, then try +compiling: + +> int x() { +> static int ary[1 - 2*(sizeof(int) <= 4)]; +> } + +and see if it fails. If you want to know sizeof(int), then +repeatedly apply this kind of test with differing values, using +binary search. +-} + +import Prelude hiding (concatMap) +import System.IO (hPutStr, openFile, IOMode(..), hClose) +import System.Directory (removeFile) +import Data.Char (toLower,toUpper,isSpace) +import Control.Exception (assert, onException) +import Control.Monad (when,liftM,forM) +import Data.Foldable (concatMap) +import Data.Maybe (fromMaybe) +import qualified Data.Sequence as S +import Data.Sequence ((|>),ViewL(..)) + +#ifndef HAVE_runProcess +import System.Cmd ( system ) +#endif +import System.Exit ( ExitCode(..) ) + +import C +import Common +import Flags +import HSCParser + +-- A monad over IO for performing tests; keeps the commandline flags +-- and a state counter for unique filename generation. +-- equivalent to ErrorT String (StateT Int (ReaderT TestMonadEnv IO)) +newtype TestMonad a = TestMonad { runTest :: TestMonadEnv -> Int -> IO (Either String a, Int) } +instance Monad TestMonad where + return a = TestMonad (\_ c -> return $ (Right a, c)) + x >>= fn = TestMonad (\e c -> (runTest x e c) >>= + (\(a,c') -> either (\err -> return (Left err, c')) + (\result -> runTest (fn result) e c') + a)) +instance Functor TestMonad where + fmap = liftM + +data TestMonadEnv = TestMonadEnv { + testIsVerbose_ :: Bool, + testLogNestCount_ :: Int, + testKeepFiles_ :: Bool, + testGetBaseName_ :: FilePath, + testGetFlags_ :: [Flag], + testGetConfig_ :: Config, + testGetCompiler_ :: FilePath +} + +testAsk :: TestMonad TestMonadEnv +testAsk = TestMonad (\e c -> return (Right e, c)) + +testIsVerbose :: TestMonad Bool +testIsVerbose = testIsVerbose_ `fmap` testAsk + +testGetCompiler :: TestMonad FilePath +testGetCompiler = testGetCompiler_ `fmap` testAsk + +testKeepFiles :: TestMonad Bool +testKeepFiles = testKeepFiles_ `fmap` testAsk + +testGetFlags :: TestMonad [Flag] +testGetFlags = testGetFlags_ `fmap` testAsk + +testGetConfig :: TestMonad Config +testGetConfig = testGetConfig_ `fmap` testAsk + +testGetBaseName :: TestMonad FilePath +testGetBaseName = testGetBaseName_ `fmap` testAsk + +testIncCount :: TestMonad Int +testIncCount = TestMonad (\_ c -> let next=succ c + in next `seq` return (Right c, next)) +testFail' :: String -> TestMonad a +testFail' s = TestMonad (\_ c -> return (Left s, c)) + +testFail :: SourcePos -> String -> TestMonad a +testFail (SourcePos file line) s = testFail' (file ++ ":" ++ show line ++ " " ++ s) + +-- liftIO for TestMonad +liftTestIO :: IO a -> TestMonad a +liftTestIO x = TestMonad (\_ c -> x >>= \r -> return (Right r, c)) + +-- finally for TestMonad +testFinally :: TestMonad a -> TestMonad b -> TestMonad a +testFinally action cleanup = do r <- action `testOnException` cleanup + _ <- cleanup + return r + +-- onException for TestMonad. This rolls back the state on an +-- IO exception, which isn't great but shouldn't matter for now +-- since only the test count is stored there. +testOnException :: TestMonad a -> TestMonad b -> TestMonad a +testOnException action cleanup = TestMonad (\e c -> runTest action e c + `onException` runTest cleanup e c >>= \(actionResult,c') -> + case actionResult of + Left _ -> do (_,c'') <- runTest cleanup e c' + return (actionResult,c'') + Right _ -> return (actionResult,c')) + +-- prints the string to stdout if verbose mode is enabled. +-- Maintains a nesting count and pads with spaces so that: +-- testLog "a" $ +-- testLog "b" $ return () +-- will print +-- a +-- b +testLog :: String -> TestMonad a -> TestMonad a +testLog s a = TestMonad (\e c -> do let verbose = testIsVerbose_ e + nestCount = testLogNestCount_ e + when verbose $ putStrLn $ (concat $ replicate nestCount " ") ++ s + runTest a (e { testLogNestCount_ = nestCount+1 }) c) + +testLog' :: String -> TestMonad () +testLog' s = testLog s (return ()) + +testLogAtPos :: SourcePos -> String -> TestMonad a -> TestMonad a +testLogAtPos (SourcePos file line) s a = testLog (file ++ ":" ++ show line ++ " " ++ s) a + +-- Given a list of file suffixes, will generate a list of filenames +-- which are all unique and have the given suffixes. On exit from this +-- action, all those files will be removed (unless keepFiles is active) +makeTest :: [String] -> ([String] -> TestMonad a) -> TestMonad a +makeTest fileSuffixes fn = do + c <- testIncCount + fileBase <- testGetBaseName + keepFiles <- testKeepFiles + let files = zipWith (++) (repeat (fileBase ++ show c)) fileSuffixes + testFinally (fn files) + (when (not keepFiles) + (mapM_ removeOrIgnore files)) + where + removeOrIgnore f = liftTestIO (catchIO (removeFile f) (const $ return ())) +-- Convert from lists to tuples (to avoid "incomplete pattern" warnings in the callers) +makeTest2 :: (String,String) -> ((String,String) -> TestMonad a) -> TestMonad a +makeTest2 (a,b) fn = makeTest [a,b] helper + where helper [a',b'] = fn (a',b') + helper _ = error "makeTest: internal error" +makeTest3 :: (String,String,String) -> ((String,String,String) -> TestMonad a) -> TestMonad a +makeTest3 (a,b,c) fn = makeTest [a,b,c] helper + where helper [a',b',c'] = fn (a',b',c') + helper _ = error "makeTest: internal error" + +-- A Zipper over lists. Unlike ListZipper, this separates at the type level +-- a list which may have a currently focused item (Zipper a) from +-- a list which _definitely_ has a focused item (ZCursor a), so +-- that zNext can be total. +data Zipper a = End { zEnd :: S.Seq a } + | Zipper (ZCursor a) + +data ZCursor a = ZCursor { zCursor :: a, + zAbove :: S.Seq a, -- elements prior to the cursor + -- in regular order (not reversed!) + zBelow :: S.Seq a -- elements after the cursor + } + +zipFromList :: [a] -> Zipper a +zipFromList [] = End S.empty +zipFromList (l:ls) = Zipper (ZCursor l S.empty (S.fromList ls)) + +zNext :: ZCursor a -> Zipper a +zNext (ZCursor c above below) = + case S.viewl below of + S.EmptyL -> End (above |> c) + c' :< below' -> Zipper (ZCursor c' (above |> c) below') + +-- Generates the .hs file from the .hsc file, by looping over each +-- Special element and calling outputSpecial to find out what it needs. +diagnose :: String -> (String -> TestMonad ()) -> [Token] -> TestMonad () +diagnose inputFilename output input = do + checkValidity input + output ("{-# LINE 1 \"" ++ inputFilename ++ "\" #-}\n") + loop (zipFromList input) + + where + loop (End _) = return () + loop (Zipper z@ZCursor {zCursor=Special _ key _}) = + case key of + _ | key `elem` ["if","ifdef","ifndef","elif","else"] -> do + condHolds <- checkConditional z + if condHolds + then loop (zNext z) + else loop =<< (either testFail' return (skipFalseConditional (zNext z))) + "endif" -> loop (zNext z) + _ -> do + outputSpecial output z + loop (zNext z) + loop (Zipper z@ZCursor {zCursor=Text pos txt}) = do + outputText output pos txt + loop (zNext z) + +outputSpecial :: (String -> TestMonad ()) -> ZCursor Token -> TestMonad () +outputSpecial output (z@ZCursor {zCursor=Special pos@(SourcePos file line) key value}) = + case key of + "const" -> outputConst value show + "offset" -> outputConst ("offsetof(" ++ value ++ ")") (\i -> "(" ++ show i ++ ")") + "size" -> outputConst ("sizeof(" ++ value ++ ")") (\i -> "(" ++ show i ++ ")") + "peek" -> outputConst ("offsetof(" ++ value ++ ")") + (\i -> "(\\hsc_ptr -> peekByteOff hsc_ptr " ++ show i ++ ")") + "poke" -> outputConst ("offsetof(" ++ value ++ ")") + (\i -> "(\\hsc_ptr -> pokeByteOff hsc_ptr " ++ show i ++ ")") + "ptr" -> outputConst ("offsetof(" ++ value ++ ")") + (\i -> "(\\hsc_ptr -> hsc_ptr `plusPtr` " ++ show i ++ ")") + "type" -> computeType z >>= output + "enum" -> computeEnum z >>= output + "error" -> testFail pos ("#error " ++ value) + "warning" -> liftTestIO $ putStrLn (file ++ ":" ++ show line ++ " warning: " ++ value) + "include" -> return () + "define" -> output $ outHeaderCProg' (zCursor z) + "undef" -> output $ outHeaderCProg' (zCursor z) + _ -> testFail pos ("directive " ++ key ++ " cannot be handled in cross-compilation mode") + where outputConst value' formatter = computeConst z value' >>= (output . formatter) +outputSpecial _ _ = error "outputSpecial's argument isn't a Special" + +outputText :: (String -> TestMonad ()) -> SourcePos -> String -> TestMonad () +outputText output (SourcePos file line) txt = + case break (=='\n') txt of + (noNewlines, []) -> output noNewlines + (firstLine, _:restOfLines) -> + output (firstLine ++ "\n" ++ + "{-# LINE " ++ show (line+1) ++ " \"" ++ file ++ "\" #-}\n" ++ + restOfLines) + +-- Bleh, messy. For each test we're compiling, we have a specific line of +-- code that may cause compiler errors -- that's the test we want to perform. +-- However, we *really* don't want any other kinds of compiler errors sneaking +-- in (which might be e.g. due to the user's syntax errors) or we'll make the +-- wrong conclusions on our tests. +-- +-- So before we compile any of the tests, take a pass over the whole file and +-- generate a .c file which should fail if there are any syntax errors in what +-- the user gaves us. Hopefully, then the only reason our later compilations +-- might fail is the particular reason we want. +-- +-- Another approach would be to try to parse the stdout of GCC and diagnose +-- whether the error is the one we want. That's tricky because of localization +-- etc. etc., though it would be less nerve-wracking. FYI it's not the approach +-- that autoconf went with. +checkValidity :: [Token] -> TestMonad () +checkValidity input = do + config <- testGetConfig + flags <- testGetFlags + let test = outTemplateHeaderCProg (cTemplate config) ++ + concatMap outFlagHeaderCProg flags ++ + concatMap (uncurry outValidityCheck) (zip input [0..]) + testLog ("checking for compilation errors") $ do + success <- makeTest2 (".c",".o") $ \(cFile,oFile) -> do + liftTestIO $ writeBinaryFile cFile test + compiler <- testGetCompiler + runCompiler compiler + (["-c",cFile,"-o",oFile]++[f | CompFlag f <- flags]) + Nothing + when (not success) $ testFail' "compilation failed" + testLog' "compilation is error-free" + +outValidityCheck :: Token -> Int -> String +outValidityCheck s@(Special pos key value) uniq = + case key of + "const" -> checkValidConst value + "offset" -> checkValidConst ("offsetof(" ++ value ++ ")") + "size" -> checkValidConst ("sizeof(" ++ value ++ ")") + "peek" -> checkValidConst ("offsetof(" ++ value ++ ")") + "poke" -> checkValidConst ("offsetof(" ++ value ++ ")") + "ptr" -> checkValidConst ("offsetof(" ++ value ++ ")") + "type" -> checkValidType + "enum" -> checkValidEnum + _ -> outHeaderCProg' s + where + checkValidConst value' = "void _hsc2hs_test" ++ show uniq ++ "()\n{\n" ++ validConstTest value' ++ "}\n"; + checkValidType = "void _hsc2hs_test" ++ show uniq ++ "()\n{\n" ++ outCLine pos ++ " (void)(" ++ value ++ ")1;\n}\n"; + checkValidEnum = + case parseEnum value of + Nothing -> "" + Just (_,_,enums) -> + "void _hsc2hs_test" ++ show uniq ++ "()\n{\n" ++ + concatMap (\(_,cName) -> validConstTest cName) enums ++ + "}\n" + + -- we want this to fail if the value is syntactically invalid or isn't a constant + validConstTest value' = outCLine pos ++ " {\n static int test_array[(" ++ value' ++ ") > 0 ? 2 : 1];\n (void)test_array;\n }\n"; + +outValidityCheck (Text _ _) _ = "" + +-- Skips over some #if or other conditional that we found to be false. +-- I.e. the argument should be a zipper whose cursor is one past the #if, +-- and returns a zipper whose cursor points at the next item which +-- could possibly be compiled. +skipFalseConditional :: Zipper Token -> Either String (Zipper Token) +skipFalseConditional (End _) = Left "unterminated endif" +skipFalseConditional (Zipper z@(ZCursor {zCursor=Special _ key _})) = + case key of + "if" -> either Left skipFalseConditional $ skipFullConditional 0 (zNext z) + "ifdef" -> either Left skipFalseConditional $ skipFullConditional 0 (zNext z) + "ifndef" -> either Left skipFalseConditional $ skipFullConditional 0 (zNext z) + "elif" -> Right $ Zipper z + "else" -> Right $ Zipper z + "endif" -> Right $ zNext z + _ -> skipFalseConditional (zNext z) +skipFalseConditional (Zipper z) = skipFalseConditional (zNext z) + +-- Skips over an #if all the way to the #endif +skipFullConditional :: Int -> Zipper Token -> Either String (Zipper Token) +skipFullConditional _ (End _) = Left "unterminated endif" +skipFullConditional nest (Zipper z@(ZCursor {zCursor=Special _ key _})) = + case key of + "if" -> skipFullConditional (nest+1) (zNext z) + "ifdef" -> skipFullConditional (nest+1) (zNext z) + "ifndef" -> skipFullConditional (nest+1) (zNext z) + "endif" | nest > 0 -> skipFullConditional (nest-1) (zNext z) + "endif" | otherwise -> Right $ zNext z + _ -> skipFullConditional nest (zNext z) +skipFullConditional nest (Zipper z) = skipFullConditional nest (zNext z) + +data IntegerConstant = Signed Integer | + Unsigned Integer deriving (Show) +-- Prints an syntatically valid integer in C +cShowInteger :: IntegerConstant -> String +cShowInteger (Signed x) | x < 0 = "(" ++ show (x+1) ++ "-1)" + -- Trick to avoid overflowing large integer constants + -- http://www.hardtoc.com/archives/119 +cShowInteger (Signed x) = show x +cShowInteger (Unsigned x) = show x ++ "u" + +data IntegerComparison = GreaterOrEqual IntegerConstant | + LessOrEqual IntegerConstant +instance Show IntegerComparison where + showsPrec _ (GreaterOrEqual c) = showString "`GreaterOrEqual` " . shows c + showsPrec _ (LessOrEqual c) = showString "`LessOrEqual` " . shows c + +cShowCmpTest :: IntegerComparison -> String +cShowCmpTest (GreaterOrEqual x) = ">=" ++ cShowInteger x +cShowCmpTest (LessOrEqual x) = "<=" ++ cShowInteger x + +-- The cursor should point at #{const SOME_VALUE} or something like that. +-- Determines the value of SOME_VALUE using binary search; this +-- is a trick which is cribbed from autoconf's AC_COMPUTE_INT. +computeConst :: ZCursor Token -> String -> TestMonad Integer +computeConst zOrig@(ZCursor (Special pos _ _) _ _) value = do + testLogAtPos pos ("computing " ++ value) $ do + nonNegative <- compareConst z (GreaterOrEqual (Signed 0)) + integral <- checkValueIsIntegral z nonNegative + when (not integral) $ testFail pos $ value ++ " is not an integer" + (lower,upper) <- bracketBounds z nonNegative + int <- binarySearch z nonNegative lower upper + testLog' $ "result: " ++ show int + return int + where -- replace the Special's value with the provided value; e.g. the special + -- is #{size SOMETHING} and we might replace value with "sizeof(SOMETHING)". + z = zOrig {zCursor=specialSetValue value (zCursor zOrig)} + specialSetValue v (Special p k _) = Special p k v + specialSetValue _ _ = error "computeConst argument isn't a Special" +computeConst _ _ = error "computeConst argument isn't a Special" + +-- Binary search, once we've bracketed the integer. +binarySearch :: ZCursor Token -> Bool -> Integer -> Integer -> TestMonad Integer +binarySearch _ _ l u | l == u = return l +binarySearch z nonNegative l u = do + let mid :: Integer + mid = (l+u+1) `div` 2 + inTopHalf <- compareConst z (GreaterOrEqual $ (if nonNegative then Unsigned else Signed) mid) + let (l',u') = if inTopHalf then (mid,u) else (l,(mid-1)) + assert (mid > l && mid <= u && u > l && u' >= l' && u' - l' < u - l && u' <= u && l' >= l) + (binarySearch z nonNegative l' u') + +-- Establishes bounds on the unknown integer. By searching increasingly +-- large powers of 2, it'll bracket an integer x by lower & upper +-- such that lower <= x <= upper. +-- +-- Assumes 2's complement integers. +bracketBounds :: ZCursor Token -> Bool -> TestMonad (Integer, Integer) +bracketBounds z nonNegative = do + let -- test against integers 2**x-1 when positive, and 2**x when negative, + -- to avoid generating constants that'd overflow the machine's integers. + -- I.e. suppose we're searching for #{const INT_MAX} (e.g. 2^32-1). + -- If we're comparing against all 2**x-1, we'll stop our search + -- before we ever overflow int. + powersOfTwo = iterate (\a -> 2*a) 1 + positiveBounds = map pred powersOfTwo + negativeBounds = map negate powersOfTwo + + -- Test each element of the bounds list until we find one that exceeds + -- the integer. + loop cmp inner (maybeOuter:bounds') = do + outerBounded <- compareConst z (cmp maybeOuter) + if outerBounded + then return (inner,maybeOuter) + else loop cmp maybeOuter bounds' + loop _ _ _ = error "bracketBounds: infinite list exhausted" + + if nonNegative + then do (inner,outer) <- loop (LessOrEqual . Unsigned) (-1) positiveBounds + return (inner+1,outer) + else do (inner,outer) <- loop (GreaterOrEqual . Signed) 0 negativeBounds + return (outer,inner-1) + +-- For #{enum} codegen; mimics template-hsc.h's hsc_haskellize +haskellize :: String -> String +haskellize [] = [] +haskellize (firstLetter:next) = toLower firstLetter : loop False next + where loop _ [] = [] + loop _ ('_':as) = loop True as + loop upper (a:as) = (if upper then toUpper a else toLower a) : loop False as + +-- For #{enum} codegen; in normal hsc2hs, any whitespace in the enum types & constructors +-- will be mangled by the C preprocessor. This mimics the same mangling. +stringify :: String -> String +stringify s = reverse . dropWhile isSpace . reverse -- drop trailing space + . dropWhile isSpace -- drop leading space + . compressSpaces -- replace each span of + -- whitespace with a single space + $ s + where compressSpaces [] = [] + compressSpaces (a:as) | isSpace a = ' ' : compressSpaces (dropWhile isSpace as) + compressSpaces (a:as) = a : compressSpaces as + +computeEnum :: ZCursor Token -> TestMonad String +computeEnum z@(ZCursor (Special _ _ enumText) _ _) = + case parseEnum enumText of + Nothing -> return "" + Just (enumType,constructor,enums) -> + concatM enums $ \(maybeHsName, cName) -> do + constValue <- computeConst z cName + let hsName = fromMaybe (haskellize cName) maybeHsName + return $ + hsName ++ " :: " ++ stringify enumType ++ "\n" ++ + hsName ++ " = " ++ stringify constructor ++ " " ++ show constValue ++ "\n" + where concatM l = liftM concat . forM l +computeEnum _ = error "computeEnum argument isn't a Special" + +-- Implementation of #{type}, using computeConst +computeType :: ZCursor Token -> TestMonad String +computeType z@(ZCursor (Special pos _ value) _ _) = do + testLogAtPos pos ("computing type of " ++ value) $ do + integral <- testLog ("checking if type " ++ value ++ " is an integer") $ do + success <- runCompileBooleanTest z $ "(" ++ value ++ ")(int)(" ++ value ++ ")1.4 == (" ++ value ++ ")1.4" + testLog' $ "result: " ++ (if success then "integer" else "floating") + return success + typeRet <- if integral + then do + signed <- testLog ("checking if type " ++ value ++ " is signed") $ do + success <- runCompileBooleanTest z $ "(" ++ value ++ ")(-1) < (" ++ value ++ ")0" + testLog' $ "result: " ++ (if success then "signed" else "unsigned") + return success + size <- computeConst z ("sizeof(" ++ value ++ ")") + return $ (if signed then "Int" else "Word") ++ (show (size * 8)) + else do + let checkSize test = testLog ("checking if " ++ test) $ do + success <- runCompileBooleanTest z test + testLog' $ "result: " ++ show success + return success + ldouble <- checkSize ("sizeof(" ++ value ++ ") > sizeof(double)") + if ldouble + then return "LDouble" + else do + double <- checkSize ("sizeof(" ++ value ++ ") == sizeof(double)") + if double + then return "Double" + else return "Float" + testLog' $ "result: " ++ typeRet + return typeRet +computeType _ = error "computeType argument isn't a Special" + +outHeaderCProg' :: Token -> String +outHeaderCProg' (Special pos key value) = outHeaderCProg (pos,key,value) +outHeaderCProg' _ = "" + +-- Checks if an #if/#ifdef etc. etc. is true by inserting a #error +-- and seeing if the compile fails. +checkConditional :: ZCursor Token -> TestMonad Bool +checkConditional (ZCursor s@(Special pos key value) above below) = do + config <- testGetConfig + flags <- testGetFlags + let test = outTemplateHeaderCProg (cTemplate config) ++ + (concatMap outFlagHeaderCProg flags) ++ + (concatMap outHeaderCProg' above) ++ + outHeaderCProg' s ++ "#error T\n" ++ + (concatMap outHeaderCProg' below) + testLogAtPos pos ("checking #" ++ key ++ " " ++ value) $ do + condTrue <- not `fmap` runCompileTest test + testLog' $ "result: " ++ show condTrue + return condTrue +checkConditional _ = error "checkConditional argument isn't a Special" + +-- Make sure the value we're trying to binary search isn't floating point. +checkValueIsIntegral :: ZCursor Token -> Bool -> TestMonad Bool +checkValueIsIntegral z@(ZCursor (Special _ _ value) _ _) nonNegative = do + let intType = if nonNegative then "unsigned long" else "long" + testLog ("checking if " ++ value ++ " is an integer") $ do + success <- runCompileBooleanTest z $ "(" ++ intType ++ ")(" ++ value ++ ") == (" ++ value ++ ")" + testLog' $ "result: " ++ (if success then "integer" else "floating") + return success +checkValueIsIntegral _ _ = error "checkConditional argument isn't a Special" + +compareConst :: ZCursor Token -> IntegerComparison -> TestMonad Bool +compareConst z@(ZCursor (Special _ _ value) _ _) cmpTest = do + testLog ("checking " ++ value ++ " " ++ show cmpTest) $ do + success <- runCompileBooleanTest z $ "(" ++ value ++ ") " ++ cShowCmpTest cmpTest + testLog' $ "result: " ++ show success + return success +compareConst _ _ = error "compareConst argument isn't a Special" + +-- Given a compile-time constant with boolean type, this extracts the +-- value of the constant by compiling a .c file only. +-- +-- The trick comes from autoconf: use the fact that the compiler must +-- perform constant arithmetic for computation of array dimensions, and +-- will generate an error if the array has negative size. +runCompileBooleanTest :: ZCursor Token -> String -> TestMonad Bool +runCompileBooleanTest (ZCursor s above below) booleanTest = do + config <- testGetConfig + flags <- testGetFlags + let test = -- all the surrounding code + outTemplateHeaderCProg (cTemplate config) ++ + (concatMap outFlagHeaderCProg flags) ++ + (concatMap outHeaderCProg' above) ++ + outHeaderCProg' s ++ + -- the test + "void _hsc2hs_test() {\n" ++ + " static int test_array[1 - 2 * !(" ++ booleanTest ++ ")];\n" ++ + " test_array[0] = 0;\n" ++ + "}\n" ++ + (concatMap outHeaderCProg' below) + runCompileTest test + +runCompileTest :: String -> TestMonad Bool +runCompileTest testStr = do + makeTest3 (".c", ".o",".txt") $ \(cFile,oFile,stdout) -> do + liftTestIO $ writeBinaryFile cFile testStr + flags <- testGetFlags + compiler <- testGetCompiler + runCompiler compiler + (["-c",cFile,"-o",oFile]++[f | CompFlag f <- flags]) + (Just stdout) + +runCompiler :: FilePath -> [String] -> Maybe FilePath -> TestMonad Bool +runCompiler prog args stdoutFile = do + let cmdLine = prog++" "++unwords args++(maybe "" (\f -> " >&"++f) stdoutFile) + testLog ("executing: " ++ cmdLine) $ liftTestIO $ do +#ifndef HAVE_runProcess + exitStatus <- system cmdLine +#else + hOut <- maybe (return Nothing) (fmap Just . openFile stdoutFile WriteMode) stdoutFile + process <- runProcess prog args Nothing Nothing Nothing hOut hOut + maybe (return ()) hClose hOut + exitStatus <- waitForProcess process +#endif + return $ case exitStatus of + ExitSuccess -> True + ExitFailure _ -> False + +-- The main driver for cross-compilation mode +outputCross :: Config -> String -> String -> String -> String -> [Token] -> IO () +outputCross config outName outDir outBase inName toks = + runTestMonad $ do + file <- liftTestIO $ openFile outName WriteMode + (diagnose inName (liftTestIO . hPutStr file) toks + `testFinally` (liftTestIO $ hClose file)) + `testOnException` (liftTestIO $ removeFile outName) -- cleanup on errors + where + env = TestMonadEnv (cVerbose config) 0 (cKeepFiles config) (outDir++outBase++"_hsc_test") (cFlags config) config (cCompiler config) + runTestMonad x = runTest x env 0 >>= (handleError . fst) + + handleError (Left e) = die (e++"\n") + handleError (Right ()) = return () diff -Nru ghc-7.0.3/utils/hsc2hs/DirectCodegen.hs ghc-7.2.1/utils/hsc2hs/DirectCodegen.hs --- ghc-7.0.3/utils/hsc2hs/DirectCodegen.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/utils/hsc2hs/DirectCodegen.hs 2011-08-07 17:10:06.000000000 +0000 @@ -0,0 +1,110 @@ +{-# LANGUAGE CPP #-} +module DirectCodegen where + +{- +The standard mode for hsc2hs: generates a C file which is +compiled and run; the output of that program is the .hs file. +-} + +import Data.Char ( isAlphaNum, toUpper ) +import Control.Monad ( when, forM_ ) + +import System.Exit ( ExitCode(..), exitWith ) + +import C +import Common +import Flags +import HSCParser + +outputDirect :: Config -> FilePath -> FilePath -> FilePath -> String -> [Token] -> IO () +outputDirect config outName outDir outBase name toks = do + + let beVerbose = cVerbose config + flags = cFlags config + cProgName = outDir++outBase++"_hsc_make.c" + oProgName = outDir++outBase++"_hsc_make.o" + progName = outDir++outBase++"_hsc_make" +#if defined(mingw32_HOST_OS) || defined(__CYGWIN32__) +-- This is a real hack, but the quoting mechanism used for calling the C preprocesseor +-- via GHC has changed a few times, so this seems to be the only way... :-P * * * + ++ ".exe" +#endif + outHFile = outBase++"_hsc.h" + outHName = outDir++outHFile + outCName = outDir++outBase++"_hsc.c" + + let execProgName + | null outDir = dosifyPath ("./" ++ progName) + | otherwise = progName + + let specials = [(pos, key, arg) | Special pos key arg <- toks] + + let needsC = any (\(_, key, _) -> key == "def") specials + needsH = needsC + possiblyRemove = if cKeepFiles config + then flip const + else finallyRemove + + let includeGuard = map fixChar outHName + where + fixChar c | isAlphaNum c = toUpper c + | otherwise = '_' + + when (cCrossSafe config) $ + forM_ specials (\ (SourcePos file line,key,_) -> + when (not $ key `elem` ["const","offset","size","peek","poke","ptr", + "type","enum","error","warning","include","define","undef", + "if","ifdef","ifndef", "elif","else","endif"]) $ + die (file ++ ":" ++ show line ++ " directive \"" ++ key ++ "\" is not safe for cross-compilation")) + + writeBinaryFile cProgName $ + outTemplateHeaderCProg (cTemplate config)++ + concatMap outFlagHeaderCProg flags++ + concatMap outHeaderCProg specials++ + "\nint main (int argc, char *argv [])\n{\n"++ + outHeaderHs flags (if needsH then Just outHName else Nothing) specials++ + outHsLine (SourcePos name 0)++ + concatMap outTokenHs toks++ + " return 0;\n}\n" + + when (cNoCompile config) $ exitWith ExitSuccess + + rawSystemL ("compiling " ++ cProgName) beVerbose (cCompiler config) + ( ["-c"] + ++ [cProgName] + ++ ["-o", oProgName] + ++ [f | CompFlag f <- flags] + ) + possiblyRemove cProgName $ do + + rawSystemL ("linking " ++ oProgName) beVerbose (cLinker config) + ( [oProgName] + ++ ["-o", progName] + ++ [f | LinkFlag f <- flags] + ) + possiblyRemove oProgName $ do + + rawSystemWithStdOutL ("running " ++ execProgName) beVerbose execProgName [] outName + possiblyRemove progName $ do + + when needsH $ writeBinaryFile outHName $ + "#ifndef "++includeGuard++"\n" ++ + "#define "++includeGuard++"\n" ++ + "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n" ++ + "#include \n" ++ + "#endif\n" ++ + "#include \n" ++ + "#if __NHC__\n" ++ + "#undef HsChar\n" ++ + "#define HsChar int\n" ++ + "#endif\n" ++ + concatMap outFlagH flags++ + concatMap outTokenH specials++ + "#endif\n" + + when needsC $ writeBinaryFile outCName $ + "#include \""++outHFile++"\"\n"++ + concatMap outTokenC specials + -- NB. outHFile not outHName; works better when processed + -- by gcc or mkdependC. + diff -Nru ghc-7.0.3/utils/hsc2hs/Flags.hs ghc-7.2.1/utils/hsc2hs/Flags.hs --- ghc-7.0.3/utils/hsc2hs/Flags.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/utils/hsc2hs/Flags.hs 2011-08-07 17:10:06.000000000 +0000 @@ -0,0 +1,138 @@ + +module Flags where + +import System.Console.GetOpt + +data Mode + = Help + | Version + | UseConfig (ConfigM Maybe) + +newtype Id a = Id { fromId :: a } +type Config = ConfigM Id + +data ConfigM m = Config { + cmTemplate :: m FilePath, + cmCompiler :: m FilePath, + cmLinker :: m FilePath, + cKeepFiles :: Bool, + cNoCompile :: Bool, + cCrossCompile :: Bool, + cCrossSafe :: Bool, + cVerbose :: Bool, + cFlags :: [Flag] + } + +cTemplate :: ConfigM Id -> FilePath +cTemplate c = fromId $ cmTemplate c + +cCompiler :: ConfigM Id -> FilePath +cCompiler c = fromId $ cmCompiler c + +cLinker :: ConfigM Id -> FilePath +cLinker c = fromId $ cmLinker c + +emptyMode :: Mode +emptyMode = UseConfig $ Config { + cmTemplate = Nothing, + cmCompiler = Nothing, + cmLinker = Nothing, + cKeepFiles = False, + cNoCompile = False, + cCrossCompile = False, + cCrossSafe = False, + cVerbose = False, + cFlags = [] + } + +data Flag + = CompFlag String + | LinkFlag String + | Include String + | Define String (Maybe String) + | Output String + deriving Show + +options :: [OptDescr (Mode -> Mode)] +options = [ + Option ['o'] ["output"] (ReqArg (addFlag . Output) "FILE") + "name of main output file", + Option ['t'] ["template"] (ReqArg (withConfig . setTemplate) "FILE") + "template file", + Option ['c'] ["cc"] (ReqArg (withConfig . setCompiler) "PROG") + "C compiler to use", + Option ['l'] ["ld"] (ReqArg (withConfig . setLinker) "PROG") + "linker to use", + Option ['C'] ["cflag"] (ReqArg (addFlag . CompFlag) "FLAG") + "flag to pass to the C compiler", + Option ['I'] [] (ReqArg (addFlag . CompFlag . ("-I"++)) "DIR") + "passed to the C compiler", + Option ['L'] ["lflag"] (ReqArg (addFlag . LinkFlag) "FLAG") + "flag to pass to the linker", + Option ['i'] ["include"] (ReqArg (addFlag . include) "FILE") + "as if placed in the source", + Option ['D'] ["define"] (ReqArg (addFlag . define) "NAME[=VALUE]") + "as if placed in the source", + Option [] ["no-compile"] (NoArg (withConfig $ setNoCompile True)) + "stop after writing *_hsc_make.c", + Option ['x'] ["cross-compile"] (NoArg (withConfig $ setCrossCompile True)) + "activate cross-compilation mode", + Option [] ["cross-safe"] (NoArg (withConfig $ setCrossSafe True)) + "restrict .hsc directives to those supported by --cross-compile", + Option ['k'] ["keep-files"] (NoArg (withConfig $ setKeepFiles True)) + "do not remove temporary files", + Option ['v'] ["verbose"] (NoArg (withConfig $ setVerbose True)) + "dump commands to stderr", + Option ['?'] ["help"] (NoArg (setMode Help)) + "display this help and exit", + Option ['V'] ["version"] (NoArg (setMode Version)) + "output version information and exit" ] + +addFlag :: Flag -> Mode -> Mode +addFlag f (UseConfig c) = UseConfig $ c { cFlags = f : cFlags c } +addFlag _ mode = mode + +setMode :: Mode -> Mode -> Mode +setMode Help _ = Help +setMode _ Help = Help +setMode Version _ = Version +setMode (UseConfig {}) _ = error "setMode: UseConfig: Can't happen" + +withConfig :: (ConfigM Maybe -> ConfigM Maybe) -> Mode -> Mode +withConfig f (UseConfig c) = UseConfig $ f c +withConfig _ m = m + +setTemplate :: FilePath -> ConfigM Maybe -> ConfigM Maybe +setTemplate fp c = c { cmTemplate = Just fp } + +setCompiler :: FilePath -> ConfigM Maybe -> ConfigM Maybe +setCompiler fp c = c { cmCompiler = Just fp } + +setLinker :: FilePath -> ConfigM Maybe -> ConfigM Maybe +setLinker fp c = c { cmLinker = Just fp } + +setKeepFiles :: Bool -> ConfigM Maybe -> ConfigM Maybe +setKeepFiles b c = c { cKeepFiles = b } + +setNoCompile :: Bool -> ConfigM Maybe -> ConfigM Maybe +setNoCompile b c = c { cNoCompile = b } + +setCrossCompile :: Bool -> ConfigM Maybe -> ConfigM Maybe +setCrossCompile b c = c { cCrossCompile = b } + +setCrossSafe :: Bool -> ConfigM Maybe -> ConfigM Maybe +setCrossSafe b c = c { cCrossSafe = b } + +setVerbose :: Bool -> ConfigM Maybe -> ConfigM Maybe +setVerbose v c = c { cVerbose = v } + +include :: String -> Flag +include s@('\"':_) = Include s +include s@('<' :_) = Include s +include s = Include ("\""++s++"\"") + +define :: String -> Flag +define s = case break (== '=') s of + (name, []) -> Define name Nothing + (name, _:value) -> Define name (Just value) + diff -Nru ghc-7.0.3/utils/hsc2hs/ghc.mk ghc-7.2.1/utils/hsc2hs/ghc.mk --- ghc-7.0.3/utils/hsc2hs/ghc.mk 2011-03-26 18:10:10.000000000 +0000 +++ ghc-7.2.1/utils/hsc2hs/ghc.mk 2011-08-07 17:10:06.000000000 +0000 @@ -34,12 +34,6 @@ $(HSC2HS_INPLACE) : $(utils/hsc2hs_template) -# This is a bit of a hack, but it will do. In particular, if we are -# using integer-gmp then libgmp.a needs to exist. -ifeq "$(HaveLibGmp)" "NO" -$(HSC2HS_INPLACE) : $(OTHER_LIBS) -endif - # When invoked in the source tree, hsc2hs will try to link in # extra-libs from the packages, including libgmp.a. So we need a # dependency to ensure these libs are built before we invoke hsc2hs: diff -Nru ghc-7.0.3/utils/hsc2hs/hsc2hs.cabal ghc-7.2.1/utils/hsc2hs/hsc2hs.cabal --- ghc-7.0.3/utils/hsc2hs/hsc2hs.cabal 2011-03-26 18:10:10.000000000 +0000 +++ ghc-7.2.1/utils/hsc2hs/hsc2hs.cabal 2011-08-07 17:10:06.000000000 +0000 @@ -31,6 +31,7 @@ Executable hsc2hs Main-Is: Main.hs + Other-Modules: HSCParser, DirectCodegen, CrossCodegen, Common, C, Flags -- needed for ReadP (used by Data.Version) Hugs-Options: -98 Extensions: CPP, ForeignFunctionInterface @@ -44,6 +45,6 @@ if flag(base3) || flag(base4) Build-Depends: directory >= 1 && < 1.2, - process >= 1 && < 1.1 - Build-Depends: haskell98 + process >= 1 && < 1.2 + Build-Depends: containers >= 0.2 && < 0.5 diff -Nru ghc-7.0.3/utils/hsc2hs/HSCParser.hs ghc-7.2.1/utils/hsc2hs/HSCParser.hs --- ghc-7.0.3/utils/hsc2hs/HSCParser.hs 1970-01-01 00:00:00.000000000 +0000 +++ ghc-7.2.1/utils/hsc2hs/HSCParser.hs 2011-08-07 17:10:06.000000000 +0000 @@ -0,0 +1,309 @@ +module HSCParser where + +import Control.Monad ( MonadPlus(..), liftM, liftM2 ) +import Data.Char ( isAlpha, isAlphaNum, isSpace, isDigit ) + +------------------------------------------------------------------------ +-- A deterministic parser which remembers the text which has been parsed. + +newtype Parser a = Parser (SourcePos -> String -> ParseResult a) + +runParser :: Parser a -> String -> String -> ParseResult a +runParser (Parser p) file_name = p (SourcePos file_name 1) + +data ParseResult a = Success !SourcePos String String a + | Failure !SourcePos String + +data SourcePos = SourcePos String !Int + +updatePos :: SourcePos -> Char -> SourcePos +updatePos pos@(SourcePos name line) ch = case ch of + '\n' -> SourcePos name (line + 1) + _ -> pos + +instance Monad Parser where + return a = Parser $ \pos s -> Success pos [] s a + Parser m >>= k = + Parser $ \pos s -> case m pos s of + Success pos' out1 s' a -> case k a of + Parser k' -> case k' pos' s' of + Success pos'' out2 imp'' b -> + Success pos'' (out1++out2) imp'' b + Failure pos'' msg -> Failure pos'' msg + Failure pos' msg -> Failure pos' msg + fail msg = Parser $ \pos _ -> Failure pos msg + +instance MonadPlus Parser where + mzero = fail "mzero" + Parser m `mplus` Parser n = + Parser $ \pos s -> case m pos s of + success@(Success _ _ _ _) -> success + Failure _ _ -> n pos s + +getPos :: Parser SourcePos +getPos = Parser $ \pos s -> Success pos [] s pos + +setPos :: SourcePos -> Parser () +setPos pos = Parser $ \_ s -> Success pos [] s () + +message :: Parser a -> String -> Parser a +Parser m `message` msg = + Parser $ \pos s -> case m pos s of + success@(Success _ _ _ _) -> success + Failure pos' _ -> Failure pos' msg + +catchOutput_ :: Parser a -> Parser String +catchOutput_ (Parser m) = + Parser $ \pos s -> case m pos s of + Success pos' out s' _ -> Success pos' [] s' out + Failure pos' msg -> Failure pos' msg + +fakeOutput :: Parser a -> String -> Parser a +Parser m `fakeOutput` out = + Parser $ \pos s -> case m pos s of + Success pos' _ s' a -> Success pos' out s' a + Failure pos' msg -> Failure pos' msg + +lookAhead :: Parser String +lookAhead = Parser $ \pos s -> Success pos [] s s + +satisfy :: (Char -> Bool) -> Parser Char +satisfy p = + Parser $ \pos s -> case s of + c:cs | p c -> Success (updatePos pos c) [c] cs c + _ -> Failure pos "Bad character" + +satisfy_ :: (Char -> Bool) -> Parser () +satisfy_ p = satisfy p >> return () + +char_ :: Char -> Parser () +char_ c = do + satisfy_ (== c) `message` (show c++" expected") + +anyChar_ :: Parser () +anyChar_ = do + satisfy_ (const True) `message` "Unexpected end of file" + +any2Chars_ :: Parser () +any2Chars_ = anyChar_ >> anyChar_ + +many :: Parser a -> Parser [a] +many p = many1 p `mplus` return [] + +many1 :: Parser a -> Parser [a] +many1 p = liftM2 (:) p (many p) + +many_ :: Parser a -> Parser () +many_ p = many1_ p `mplus` return () + +many1_ :: Parser a -> Parser () +many1_ p = p >> many_ p + +manySatisfy, manySatisfy1 :: (Char -> Bool) -> Parser String +manySatisfy = many . satisfy +manySatisfy1 = many1 . satisfy + +manySatisfy_, manySatisfy1_ :: (Char -> Bool) -> Parser () +manySatisfy_ = many_ . satisfy +manySatisfy1_ = many1_ . satisfy + +------------------------------------------------------------------------ +-- Parser of hsc syntax. + +data Token + = Text SourcePos String + | Special SourcePos String String + +parser :: Parser [Token] +parser = do + pos <- getPos + t <- catchOutput_ text + s <- lookAhead + rest <- case s of + [] -> return [] + _:_ -> liftM2 (:) (special `fakeOutput` []) parser + return (if null t then rest else Text pos t : rest) + +text :: Parser () +text = do + s <- lookAhead + case s of + [] -> return () + c:_ | isAlpha c || c == '_' -> do + anyChar_ + manySatisfy_ (\c' -> isAlphaNum c' || c' == '_' || c' == '\'') + text + c:_ | isHsSymbol c -> do + symb <- catchOutput_ (manySatisfy_ isHsSymbol) + case symb of + "#" -> return () + '-':'-':symb' | all (== '-') symb' -> do + return () `fakeOutput` symb + manySatisfy_ (/= '\n') + text + _ -> do + return () `fakeOutput` unescapeHashes symb + text + '\"':_ -> do anyChar_; hsString '\"'; text + '\'':_ -> do anyChar_; hsString '\''; text + '{':'-':_ -> do any2Chars_; linePragma `mplus` hsComment; text + _:_ -> do anyChar_; text + +hsString :: Char -> Parser () +hsString quote = do + s <- lookAhead + case s of + [] -> return () + c:_ | c == quote -> anyChar_ + '\\':c:_ + | isSpace c -> do + anyChar_ + manySatisfy_ isSpace + char_ '\\' `mplus` return () + hsString quote + | otherwise -> do any2Chars_; hsString quote + _:_ -> do anyChar_; hsString quote + +hsComment :: Parser () +hsComment = do + s <- lookAhead + case s of + [] -> return () + '-':'}':_ -> any2Chars_ + '{':'-':_ -> do any2Chars_; hsComment; hsComment + _:_ -> do anyChar_; hsComment + +linePragma :: Parser () +linePragma = do + char_ '#' + manySatisfy_ isSpace + satisfy_ (\c -> c == 'L' || c == 'l') + satisfy_ (\c -> c == 'I' || c == 'i') + satisfy_ (\c -> c == 'N' || c == 'n') + satisfy_ (\c -> c == 'E' || c == 'e') + manySatisfy1_ isSpace + line <- liftM read $ manySatisfy1 isDigit + manySatisfy1_ isSpace + char_ '\"' + name <- manySatisfy (/= '\"') + char_ '\"' + manySatisfy_ isSpace + char_ '#' + char_ '-' + char_ '}' + setPos (SourcePos name (line - 1)) + +isHsSymbol :: Char -> Bool +isHsSymbol '!' = True; isHsSymbol '#' = True; isHsSymbol '$' = True +isHsSymbol '%' = True; isHsSymbol '&' = True; isHsSymbol '*' = True +isHsSymbol '+' = True; isHsSymbol '.' = True; isHsSymbol '/' = True +isHsSymbol '<' = True; isHsSymbol '=' = True; isHsSymbol '>' = True +isHsSymbol '?' = True; isHsSymbol '@' = True; isHsSymbol '\\' = True +isHsSymbol '^' = True; isHsSymbol '|' = True; isHsSymbol '-' = True +isHsSymbol '~' = True +isHsSymbol _ = False + +unescapeHashes :: String -> String +unescapeHashes [] = [] +unescapeHashes ('#':'#':s) = '#' : unescapeHashes s +unescapeHashes (c:s) = c : unescapeHashes s + +lookAheadC :: Parser String +lookAheadC = liftM joinLines lookAhead + where + joinLines [] = [] + joinLines ('\\':'\n':s) = joinLines s + joinLines (c:s) = c : joinLines s + +satisfyC :: (Char -> Bool) -> Parser Char +satisfyC p = do + s <- lookAhead + case s of + '\\':'\n':_ -> do any2Chars_ `fakeOutput` []; satisfyC p + _ -> satisfy p + +satisfyC_ :: (Char -> Bool) -> Parser () +satisfyC_ p = satisfyC p >> return () + +charC_ :: Char -> Parser () +charC_ c = satisfyC_ (== c) `message` (show c++" expected") + +anyCharC_ :: Parser () +anyCharC_ = satisfyC_ (const True) `message` "Unexpected end of file" + +any2CharsC_ :: Parser () +any2CharsC_ = anyCharC_ >> anyCharC_ + +manySatisfyC :: (Char -> Bool) -> Parser String +manySatisfyC = many . satisfyC + +manySatisfyC_ :: (Char -> Bool) -> Parser () +manySatisfyC_ = many_ . satisfyC + +special :: Parser Token +special = do + manySatisfyC_ (\c -> isSpace c && c /= '\n') + s <- lookAheadC + case s of + '{':_ -> do + anyCharC_ + manySatisfyC_ isSpace + sp <- keyArg (== '\n') + charC_ '}' + return sp + _ -> keyArg (const False) + +keyArg :: (Char -> Bool) -> Parser Token +keyArg eol = do + pos <- getPos + key <- keyword `message` "hsc keyword or '{' expected" + manySatisfyC_ (\c' -> isSpace c' && c' /= '\n' || eol c') + arg <- catchOutput_ (argument eol) + return (Special pos key arg) + +keyword :: Parser String +keyword = do + c <- satisfyC (\c' -> isAlpha c' || c' == '_') + cs <- manySatisfyC (\c' -> isAlphaNum c' || c' == '_') + return (c:cs) + +argument :: (Char -> Bool) -> Parser () +argument eol = do + s <- lookAheadC + case s of + [] -> return () + c:_ | eol c -> do anyCharC_; argument eol + '\n':_ -> return () + '\"':_ -> do anyCharC_; cString '\"'; argument eol + '\'':_ -> do anyCharC_; cString '\''; argument eol + '(':_ -> do anyCharC_; nested ')'; argument eol + ')':_ -> return () + '/':'*':_ -> do any2CharsC_; cComment; argument eol + '/':'/':_ -> do + any2CharsC_; manySatisfyC_ (/= '\n'); argument eol + '[':_ -> do anyCharC_; nested ']'; argument eol + ']':_ -> return () + '{':_ -> do anyCharC_; nested '}'; argument eol + '}':_ -> return () + _:_ -> do anyCharC_; argument eol + +nested :: Char -> Parser () +nested c = do argument (== '\n'); charC_ c + +cComment :: Parser () +cComment = do + s <- lookAheadC + case s of + [] -> return () + '*':'/':_ -> do any2CharsC_ + _:_ -> do anyCharC_; cComment + +cString :: Char -> Parser () +cString quote = do + s <- lookAheadC + case s of + [] -> return () + c:_ | c == quote -> anyCharC_ + '\\':_:_ -> do any2CharsC_; cString quote + _:_ -> do anyCharC_; cString quote + diff -Nru ghc-7.0.3/utils/hsc2hs/Main.hs ghc-7.2.1/utils/hsc2hs/Main.hs --- ghc-7.0.3/utils/hsc2hs/Main.hs 2011-03-26 18:10:10.000000000 +0000 +++ ghc-7.2.1/utils/hsc2hs/Main.hs 2011-08-07 17:10:06.000000000 +0000 @@ -14,169 +14,57 @@ #include "../../includes/ghcconfig.h" #endif -import Control.Monad ( MonadPlus(..), liftM, liftM2, when ) -import Data.Char ( isAlpha, isAlphaNum, isSpace, isDigit, - toUpper, intToDigit, ord ) -import Data.List ( intersperse, isSuffixOf ) +import Control.Monad ( liftM, forM_ ) +import Data.List ( isSuffixOf ) import System.Console.GetOpt #if defined(mingw32_HOST_OS) import Foreign import Foreign.C.String #endif -import System.Directory ( removeFile, doesFileExist, findExecutable ) +import System.Directory ( doesFileExist, findExecutable ) import System.Environment ( getProgName, getArgs ) import System.Exit ( ExitCode(..), exitWith ) import System.IO -#if __GLASGOW_HASKELL__ >= 604 -import System.Process ( runProcess, waitForProcess ) -#define HAVE_runProcess -#endif - -import System.Cmd ( rawSystem ) -#ifndef HAVE_runProcess -import System.Cmd ( system ) +#ifdef BUILD_NHC +import System.Directory ( getCurrentDirectory ) +#else +import Data.Version ( showVersion ) +import Paths_hsc2hs as Main ( getDataFileName, version ) #endif -import IO ( bracket_ ) +import Common +import CrossCodegen +import DirectCodegen +import Flags +import HSCParser -#ifndef BUILD_NHC -import Paths_hsc2hs as Main ( getDataFileName, version ) -import Data.Version ( showVersion ) -#else -import System.Directory ( getCurrentDirectory ) +#ifdef BUILD_NHC getDataFileName s = do here <- getCurrentDirectory return (here++"/"++s) version = "0.67" -- TODO!!! showVersion = id #endif -default_compiler :: String -default_compiler = "gcc" - versionString :: String versionString = "hsc2hs version " ++ showVersion version ++ "\n" -data Flag - = Help - | Version - | Template String - | Compiler String - | Linker String - | CompFlag String - | LinkFlag String - | NoCompile - | Include String - | Define String (Maybe String) - | Output String - | Verbose - -template_flag :: Flag -> Bool -template_flag (Template _) = True -template_flag _ = False - -include :: String -> Flag -include s@('\"':_) = Include s -include s@('<' :_) = Include s -include s = Include ("\""++s++"\"") - -define :: String -> Flag -define s = case break (== '=') s of - (name, []) -> Define name Nothing - (name, _:value) -> Define name (Just value) - -options :: [OptDescr Flag] -options = [ - Option ['o'] ["output"] (ReqArg Output "FILE") - "name of main output file", - Option ['t'] ["template"] (ReqArg Template "FILE") - "template file", - Option ['c'] ["cc"] (ReqArg Compiler "PROG") - "C compiler to use", - Option ['l'] ["ld"] (ReqArg Linker "PROG") - "linker to use", - Option ['C'] ["cflag"] (ReqArg CompFlag "FLAG") - "flag to pass to the C compiler", - Option ['I'] [] (ReqArg (CompFlag . ("-I"++)) "DIR") - "passed to the C compiler", - Option ['L'] ["lflag"] (ReqArg LinkFlag "FLAG") - "flag to pass to the linker", - Option ['i'] ["include"] (ReqArg include "FILE") - "as if placed in the source", - Option ['D'] ["define"] (ReqArg define "NAME[=VALUE]") - "as if placed in the source", - Option [] ["no-compile"] (NoArg NoCompile) - "stop after writing *_hsc_make.c", - Option ['v'] ["verbose"] (NoArg Verbose) - "dump commands to stderr", - Option ['?'] ["help"] (NoArg Help) - "display this help and exit", - Option ['V'] ["version"] (NoArg Version) - "output version information and exit" ] - main :: IO () main = do prog <- getProgramName let header = "Usage: "++prog++" [OPTIONS] INPUT.hsc [...]\n" + usage = usageInfo header options args <- getArgs - let (flags, files, errs) = getOpt Permute options args - - -- If there is no Template flag explicitly specified, try - -- to find one. We first look near the executable. This only - -- works on Win32 or Hugs (getExecDir). If this finds a template - -- file then it's certainly the one we want, even if hsc2hs isn't - -- installed where we told Cabal it would be installed. - -- - -- Next we try the location we told Cabal about. - -- - -- If neither of the above work, then hopefully we're on Unix and - -- there's a wrapper script which specifies an explicit template flag. - mb_libdir <- getLibDir - - flags_w_tpl0 <- - if any template_flag flags then return flags - else do mb_templ1 <- - case mb_libdir of - Nothing -> return Nothing - Just path -> do - -- Euch, this is horrible. Unfortunately - -- Paths_hsc2hs isn't too useful for a - -- relocatable binary, though. - let -#if defined(NEW_GHC_LAYOUT) - templ1 = path ++ "/template-hsc.h" -#else - templ1 = path ++ "/hsc2hs-" ++ showVersion Main.version ++ "/template-hsc.h" -#endif - incl = path ++ "/include/" - exists1 <- doesFileExist templ1 - if exists1 - then return $ Just (Template templ1, - CompFlag ("-I" ++ incl)) - else return Nothing - case mb_templ1 of - Just (templ1, incl) -> return (templ1 : flags ++ [incl]) - Nothing -> do - templ2 <- getDataFileName "template-hsc.h" - exists2 <- doesFileExist templ2 - if exists2 then return (Template templ2 : flags) - else return flags - - -- take only the last --template flag on the cmd line - let - (before,tpl:after) = break template_flag (reverse flags_w_tpl0) - flags_w_tpl = reverse (before ++ tpl : filter (not.template_flag) after) - - case (files, errs) of - (_, _) - | any isHelp flags_w_tpl -> bye (usageInfo header options) - | any isVersion flags_w_tpl -> bye versionString - where - isHelp Help = True; isHelp _ = False - isVersion Version = True; isVersion _ = False - ((_:_), []) -> mapM_ (processFile flags_w_tpl mb_libdir) files - (_, _ ) -> die (concat errs ++ usageInfo header options) + let (fs, files, errs) = getOpt Permute options args + let mode = foldl (.) id fs emptyMode + case mode of + Help -> bye usage + Version -> bye versionString + UseConfig config -> + case (files, errs) of + ((_:_), []) -> processFiles config files usage + (_, _ ) -> die (concat errs ++ usage) getProgramName :: IO String getProgramName = liftM (`withoutSuffix` "-bin") getProgName @@ -187,13 +75,119 @@ bye :: String -> IO a bye s = putStr s >> exitWith ExitSuccess -die :: String -> IO a -die s = hPutStr stderr s >> exitWith (ExitFailure 1) +processFiles :: ConfigM Maybe -> [FilePath] -> String -> IO () +processFiles configM files usage = do + mb_libdir <- getLibDir -processFile :: [Flag] -> Maybe String -> String -> IO () -processFile flags mb_libdir name - = do let file_name = dosifyPath name - h <- openBinaryFile file_name ReadMode + (template, extraFlags) <- findTemplate usage mb_libdir configM + compiler <- findCompiler mb_libdir configM + let linker = case cmLinker configM of + Nothing -> compiler + Just l -> l + config = Config { + cmTemplate = Id template, + cmCompiler = Id compiler, + cmLinker = Id linker, + cKeepFiles = cKeepFiles configM, + cNoCompile = cNoCompile configM, + cCrossCompile = cCrossCompile configM, + cCrossSafe = cCrossSafe configM, + cVerbose = cVerbose configM, + cFlags = cFlags configM ++ extraFlags + } + + let outputter = if cCrossCompile config then outputCross else outputDirect + + forM_ files (\name -> do + (outName, outDir, outBase) <- case [f | Output f <- cFlags config] of + [] -> if not (null ext) && last ext == 'c' + then return (dir++base++init ext, dir, base) + else + if ext == ".hs" + then return (dir++base++"_out.hs", dir, base) + else return (dir++base++".hs", dir, base) + where + (dir, file) = splitName name + (base, ext) = splitExt file + [f] -> let + (dir, file) = splitName f + (base, _) = splitExt file + in return (f, dir, base) + _ -> onlyOne "output file" + let file_name = dosifyPath name + toks <- parseFile file_name + outputter config outName outDir outBase file_name toks) + +findTemplate :: String -> Maybe FilePath -> ConfigM Maybe + -> IO (FilePath, [Flag]) +findTemplate usage mb_libdir config + = -- If there's no template specified on the commandline, try to locate it + case cmTemplate config of + Just t -> + return (t, []) + Nothing -> do + -- If there is no Template flag explicitly specified, try + -- to find one. We first look near the executable. This only + -- works on Win32 or Hugs (getExecDir). If this finds a template + -- file then it's certainly the one we want, even if hsc2hs isn't + -- installed where we told Cabal it would be installed. + -- + -- Next we try the location we told Cabal about. + -- + -- If neither of the above work, then hopefully we're on Unix and + -- there's a wrapper script which specifies an explicit template flag. + mb_templ1 <- + case mb_libdir of + Nothing -> return Nothing + Just path -> do + -- Euch, this is horrible. Unfortunately + -- Paths_hsc2hs isn't too useful for a + -- relocatable binary, though. + let +#if defined(NEW_GHC_LAYOUT) + templ1 = path ++ "/template-hsc.h" +#else + templ1 = path ++ "/hsc2hs-" ++ showVersion Main.version ++ "/template-hsc.h" +#endif + incl = path ++ "/include/" + exists1 <- doesFileExist templ1 + if exists1 + then return $ Just (templ1, CompFlag ("-I" ++ incl)) + else return Nothing + case mb_templ1 of + Just (templ1, incl) -> + return (templ1, [incl]) + Nothing -> do + templ2 <- getDataFileName "template-hsc.h" + exists2 <- doesFileExist templ2 + if exists2 then return (templ2, []) + else die ("No template specified, and template-hsc.h not located.\n\n" ++ usage) + +findCompiler :: Maybe FilePath -> ConfigM Maybe -> IO FilePath +findCompiler mb_libdir config + = case cmCompiler config of + Just c -> return c + Nothing -> + do let search_path = do + mb_path <- findExecutable default_compiler + case mb_path of + Nothing -> + die ("Can't find "++default_compiler++"\n") + Just path -> return path + -- if this hsc2hs is part of a GHC installation on + -- Windows, then we should use the mingw gcc that + -- comes with GHC (#3929) + case mb_libdir of + Nothing -> search_path + Just d -> + do let inplaceGcc = d ++ "/../mingw/bin/gcc.exe" + b <- doesFileExist inplaceGcc + if b then return inplaceGcc + else search_path + +parseFile :: String -> IO [Token] +parseFile name + = do h <- openBinaryFile name ReadMode -- use binary mode so we pass through UTF-8, see GHC ticket #3837 -- But then on Windows we end up turning things like -- #let alignment t = e^M @@ -202,723 +196,10 @@ -- which gcc doesn't like, so strip out any ^M characters. s <- hGetContents h let s' = filter ('\r' /=) s - case parser of - Parser p -> case p (SourcePos file_name 1) s' of - Success _ _ _ toks -> output mb_libdir flags file_name toks - Failure (SourcePos name' line) msg -> - die (name'++":"++show line++": "++msg++"\n") - ------------------------------------------------------------------------- --- A deterministic parser which remembers the text which has been parsed. - -newtype Parser a = Parser (SourcePos -> String -> ParseResult a) - -data ParseResult a = Success !SourcePos String String a - | Failure !SourcePos String - -data SourcePos = SourcePos String !Int - -updatePos :: SourcePos -> Char -> SourcePos -updatePos pos@(SourcePos name line) ch = case ch of - '\n' -> SourcePos name (line + 1) - _ -> pos - -instance Monad Parser where - return a = Parser $ \pos s -> Success pos [] s a - Parser m >>= k = - Parser $ \pos s -> case m pos s of - Success pos' out1 s' a -> case k a of - Parser k' -> case k' pos' s' of - Success pos'' out2 imp'' b -> - Success pos'' (out1++out2) imp'' b - Failure pos'' msg -> Failure pos'' msg - Failure pos' msg -> Failure pos' msg - fail msg = Parser $ \pos _ -> Failure pos msg - -instance MonadPlus Parser where - mzero = fail "mzero" - Parser m `mplus` Parser n = - Parser $ \pos s -> case m pos s of - success@(Success _ _ _ _) -> success - Failure _ _ -> n pos s - -getPos :: Parser SourcePos -getPos = Parser $ \pos s -> Success pos [] s pos - -setPos :: SourcePos -> Parser () -setPos pos = Parser $ \_ s -> Success pos [] s () - -message :: Parser a -> String -> Parser a -Parser m `message` msg = - Parser $ \pos s -> case m pos s of - success@(Success _ _ _ _) -> success - Failure pos' _ -> Failure pos' msg - -catchOutput_ :: Parser a -> Parser String -catchOutput_ (Parser m) = - Parser $ \pos s -> case m pos s of - Success pos' out s' _ -> Success pos' [] s' out - Failure pos' msg -> Failure pos' msg - -fakeOutput :: Parser a -> String -> Parser a -Parser m `fakeOutput` out = - Parser $ \pos s -> case m pos s of - Success pos' _ s' a -> Success pos' out s' a - Failure pos' msg -> Failure pos' msg - -lookAhead :: Parser String -lookAhead = Parser $ \pos s -> Success pos [] s s - -satisfy :: (Char -> Bool) -> Parser Char -satisfy p = - Parser $ \pos s -> case s of - c:cs | p c -> Success (updatePos pos c) [c] cs c - _ -> Failure pos "Bad character" - -satisfy_ :: (Char -> Bool) -> Parser () -satisfy_ p = satisfy p >> return () - -char_ :: Char -> Parser () -char_ c = do - satisfy_ (== c) `message` (show c++" expected") - -anyChar_ :: Parser () -anyChar_ = do - satisfy_ (const True) `message` "Unexpected end of file" - -any2Chars_ :: Parser () -any2Chars_ = anyChar_ >> anyChar_ - -many :: Parser a -> Parser [a] -many p = many1 p `mplus` return [] - -many1 :: Parser a -> Parser [a] -many1 p = liftM2 (:) p (many p) - -many_ :: Parser a -> Parser () -many_ p = many1_ p `mplus` return () - -many1_ :: Parser a -> Parser () -many1_ p = p >> many_ p - -manySatisfy, manySatisfy1 :: (Char -> Bool) -> Parser String -manySatisfy = many . satisfy -manySatisfy1 = many1 . satisfy - -manySatisfy_, manySatisfy1_ :: (Char -> Bool) -> Parser () -manySatisfy_ = many_ . satisfy -manySatisfy1_ = many1_ . satisfy - ------------------------------------------------------------------------- --- Parser of hsc syntax. - -data Token - = Text SourcePos String - | Special SourcePos String String - -parser :: Parser [Token] -parser = do - pos <- getPos - t <- catchOutput_ text - s <- lookAhead - rest <- case s of - [] -> return [] - _:_ -> liftM2 (:) (special `fakeOutput` []) parser - return (if null t then rest else Text pos t : rest) - -text :: Parser () -text = do - s <- lookAhead - case s of - [] -> return () - c:_ | isAlpha c || c == '_' -> do - anyChar_ - manySatisfy_ (\c' -> isAlphaNum c' || c' == '_' || c' == '\'') - text - c:_ | isHsSymbol c -> do - symb <- catchOutput_ (manySatisfy_ isHsSymbol) - case symb of - "#" -> return () - '-':'-':symb' | all (== '-') symb' -> do - return () `fakeOutput` symb - manySatisfy_ (/= '\n') - text - _ -> do - return () `fakeOutput` unescapeHashes symb - text - '\"':_ -> do anyChar_; hsString '\"'; text - '\'':_ -> do anyChar_; hsString '\''; text - '{':'-':_ -> do any2Chars_; linePragma `mplus` hsComment; text - _:_ -> do anyChar_; text - -hsString :: Char -> Parser () -hsString quote = do - s <- lookAhead - case s of - [] -> return () - c:_ | c == quote -> anyChar_ - '\\':c:_ - | isSpace c -> do - anyChar_ - manySatisfy_ isSpace - char_ '\\' `mplus` return () - hsString quote - | otherwise -> do any2Chars_; hsString quote - _:_ -> do anyChar_; hsString quote - -hsComment :: Parser () -hsComment = do - s <- lookAhead - case s of - [] -> return () - '-':'}':_ -> any2Chars_ - '{':'-':_ -> do any2Chars_; hsComment; hsComment - _:_ -> do anyChar_; hsComment - -linePragma :: Parser () -linePragma = do - char_ '#' - manySatisfy_ isSpace - satisfy_ (\c -> c == 'L' || c == 'l') - satisfy_ (\c -> c == 'I' || c == 'i') - satisfy_ (\c -> c == 'N' || c == 'n') - satisfy_ (\c -> c == 'E' || c == 'e') - manySatisfy1_ isSpace - line <- liftM read $ manySatisfy1 isDigit - manySatisfy1_ isSpace - char_ '\"' - name <- manySatisfy (/= '\"') - char_ '\"' - manySatisfy_ isSpace - char_ '#' - char_ '-' - char_ '}' - setPos (SourcePos name (line - 1)) - -isHsSymbol :: Char -> Bool -isHsSymbol '!' = True; isHsSymbol '#' = True; isHsSymbol '$' = True -isHsSymbol '%' = True; isHsSymbol '&' = True; isHsSymbol '*' = True -isHsSymbol '+' = True; isHsSymbol '.' = True; isHsSymbol '/' = True -isHsSymbol '<' = True; isHsSymbol '=' = True; isHsSymbol '>' = True -isHsSymbol '?' = True; isHsSymbol '@' = True; isHsSymbol '\\' = True -isHsSymbol '^' = True; isHsSymbol '|' = True; isHsSymbol '-' = True -isHsSymbol '~' = True -isHsSymbol _ = False - -unescapeHashes :: String -> String -unescapeHashes [] = [] -unescapeHashes ('#':'#':s) = '#' : unescapeHashes s -unescapeHashes (c:s) = c : unescapeHashes s - -lookAheadC :: Parser String -lookAheadC = liftM joinLines lookAhead - where - joinLines [] = [] - joinLines ('\\':'\n':s) = joinLines s - joinLines (c:s) = c : joinLines s - -satisfyC :: (Char -> Bool) -> Parser Char -satisfyC p = do - s <- lookAhead - case s of - '\\':'\n':_ -> do any2Chars_ `fakeOutput` []; satisfyC p - _ -> satisfy p - -satisfyC_ :: (Char -> Bool) -> Parser () -satisfyC_ p = satisfyC p >> return () - -charC_ :: Char -> Parser () -charC_ c = satisfyC_ (== c) `message` (show c++" expected") - -anyCharC_ :: Parser () -anyCharC_ = satisfyC_ (const True) `message` "Unexpected end of file" - -any2CharsC_ :: Parser () -any2CharsC_ = anyCharC_ >> anyCharC_ - -manySatisfyC :: (Char -> Bool) -> Parser String -manySatisfyC = many . satisfyC - -manySatisfyC_ :: (Char -> Bool) -> Parser () -manySatisfyC_ = many_ . satisfyC - -special :: Parser Token -special = do - manySatisfyC_ (\c -> isSpace c && c /= '\n') - s <- lookAheadC - case s of - '{':_ -> do - anyCharC_ - manySatisfyC_ isSpace - sp <- keyArg (== '\n') - charC_ '}' - return sp - _ -> keyArg (const False) - -keyArg :: (Char -> Bool) -> Parser Token -keyArg eol = do - pos <- getPos - key <- keyword `message` "hsc keyword or '{' expected" - manySatisfyC_ (\c' -> isSpace c' && c' /= '\n' || eol c') - arg <- catchOutput_ (argument eol) - return (Special pos key arg) - -keyword :: Parser String -keyword = do - c <- satisfyC (\c' -> isAlpha c' || c' == '_') - cs <- manySatisfyC (\c' -> isAlphaNum c' || c' == '_') - return (c:cs) - -argument :: (Char -> Bool) -> Parser () -argument eol = do - s <- lookAheadC - case s of - [] -> return () - c:_ | eol c -> do anyCharC_; argument eol - '\n':_ -> return () - '\"':_ -> do anyCharC_; cString '\"'; argument eol - '\'':_ -> do anyCharC_; cString '\''; argument eol - '(':_ -> do anyCharC_; nested ')'; argument eol - ')':_ -> return () - '/':'*':_ -> do any2CharsC_; cComment; argument eol - '/':'/':_ -> do - any2CharsC_; manySatisfyC_ (/= '\n'); argument eol - '[':_ -> do anyCharC_; nested ']'; argument eol - ']':_ -> return () - '{':_ -> do anyCharC_; nested '}'; argument eol - '}':_ -> return () - _:_ -> do anyCharC_; argument eol - -nested :: Char -> Parser () -nested c = do argument (== '\n'); charC_ c - -cComment :: Parser () -cComment = do - s <- lookAheadC - case s of - [] -> return () - '*':'/':_ -> do any2CharsC_ - _:_ -> do anyCharC_; cComment - -cString :: Char -> Parser () -cString quote = do - s <- lookAheadC - case s of - [] -> return () - c:_ | c == quote -> anyCharC_ - '\\':_:_ -> do any2CharsC_; cString quote - _:_ -> do anyCharC_; cString quote - ------------------------------------------------------------------------- --- Write the output files. - -splitName :: String -> (String, String) -splitName name = - case break (== '/') name of - (file, []) -> ([], file) - (dir, sep:rest) -> (dir++sep:restDir, restFile) - where - (restDir, restFile) = splitName rest - -splitExt :: String -> (String, String) -splitExt name = - case break (== '.') name of - (base, []) -> (base, []) - (base, sepRest@(sep:rest)) - | null restExt -> (base, sepRest) - | otherwise -> (base++sep:restBase, restExt) - where - (restBase, restExt) = splitExt rest - -output :: Maybe String -> [Flag] -> String -> [Token] -> IO () -output mb_libdir flags name toks = do - - (outName, outDir, outBase) <- case [f | Output f <- flags] of - [] -> if not (null ext) && last ext == 'c' - then return (dir++base++init ext, dir, base) - else - if ext == ".hs" - then return (dir++base++"_out.hs", dir, base) - else return (dir++base++".hs", dir, base) - where - (dir, file) = splitName name - (base, ext) = splitExt file - [f] -> let - (dir, file) = splitName f - (base, _) = splitExt file - in return (f, dir, base) - _ -> onlyOne "output file" - - let cProgName = outDir++outBase++"_hsc_make.c" - oProgName = outDir++outBase++"_hsc_make.o" - progName = outDir++outBase++"_hsc_make" -#if defined(mingw32_HOST_OS) || defined(__CYGWIN32__) --- This is a real hack, but the quoting mechanism used for calling the C preprocesseor --- via GHC has changed a few times, so this seems to be the only way... :-P * * * - ++ ".exe" -#endif - outHFile = outBase++"_hsc.h" - outHName = outDir++outHFile - outCName = outDir++outBase++"_hsc.c" - - beVerbose = any (\ x -> case x of { Verbose -> True; _ -> False}) flags - - let execProgName - | null outDir = dosifyPath ("./" ++ progName) - | otherwise = progName - - let specials = [(pos, key, arg) | Special pos key arg <- toks] - - let needsC = any (\(_, key, _) -> key == "def") specials - needsH = needsC - - let includeGuard = map fixChar outHName - where - fixChar c | isAlphaNum c = toUpper c - | otherwise = '_' - - compiler <- case [c | Compiler c <- flags] of - [] -> do - -- if this hsc2hs is part of a GHC installation on - -- Windows, then we should use the mingw gcc that - -- comes with GHC (#3929) - case mb_libdir of - Nothing -> search_path - Just d -> do - let inplace_gcc = d ++ "/../mingw/bin/gcc.exe" - b <- doesFileExist inplace_gcc - if b then return inplace_gcc else search_path - where - search_path = do - mb_path <- findExecutable default_compiler - case mb_path of - Nothing -> die ("Can't find "++default_compiler++"\n") - Just path -> return path - cs -> return (last cs) - - linker <- case [l | Linker l <- flags] of - [] -> return compiler - ls -> return (last ls) - - writeBinaryFile cProgName $ - concatMap outFlagHeaderCProg flags++ - concatMap outHeaderCProg specials++ - "\nint main (int argc, char *argv [])\n{\n"++ - outHeaderHs flags (if needsH then Just outHName else Nothing) specials++ - outHsLine (SourcePos name 0)++ - concatMap outTokenHs toks++ - " return 0;\n}\n" - - -- NOTE: hbc compiles "[() | NoCompile <- flags]" into wrong code, - -- so we use something slightly more complicated. :-P - when (any (\x -> case x of NoCompile -> True; _ -> False) flags) $ - exitWith ExitSuccess - - rawSystemL ("compiling " ++ cProgName) beVerbose compiler - ( ["-c"] - ++ [cProgName] - ++ ["-o", oProgName] - ++ [f | CompFlag f <- flags] - ) - finallyRemove cProgName $ do - - rawSystemL ("linking " ++ oProgName) beVerbose linker - ( [oProgName] - ++ ["-o", progName] - ++ [f | LinkFlag f <- flags] - ) - finallyRemove oProgName $ do - - rawSystemWithStdOutL ("running " ++ execProgName) beVerbose execProgName [] outName - finallyRemove progName $ do - - when needsH $ writeBinaryFile outHName $ - "#ifndef "++includeGuard++"\n" ++ - "#define "++includeGuard++"\n" ++ - "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n" ++ - "#include \n" ++ - "#endif\n" ++ - "#include \n" ++ - "#if __NHC__\n" ++ - "#undef HsChar\n" ++ - "#define HsChar int\n" ++ - "#endif\n" ++ - concatMap outFlagH flags++ - concatMap outTokenH specials++ - "#endif\n" - - when needsC $ writeBinaryFile outCName $ - "#include \""++outHFile++"\"\n"++ - concatMap outTokenC specials - -- NB. outHFile not outHName; works better when processed - -- by gcc or mkdependC. - -writeBinaryFile :: FilePath -> String -> IO () -writeBinaryFile fp str = withBinaryFile fp WriteMode $ \h -> hPutStr h str - -rawSystemL :: String -> Bool -> FilePath -> [String] -> IO () -rawSystemL action flg prog args = do - let cmdLine = prog++" "++unwords args - when flg $ hPutStrLn stderr ("Executing: " ++ cmdLine) - exitStatus <- rawSystem prog args - case exitStatus of - ExitFailure exitCode -> die $ action ++ " failed " - ++ "(exit code " ++ show exitCode ++ ")\n" - ++ "command was: " ++ cmdLine ++ "\n" - _ -> return () - -rawSystemWithStdOutL :: String -> Bool -> FilePath -> [String] -> FilePath -> IO () -rawSystemWithStdOutL action flg prog args outFile = do - let cmdLine = prog++" "++unwords args++" >"++outFile - when flg (hPutStrLn stderr ("Executing: " ++ cmdLine)) -#ifndef HAVE_runProcess - exitStatus <- system cmdLine -#else - hOut <- openFile outFile WriteMode - process <- runProcess prog args Nothing Nothing Nothing (Just hOut) Nothing - exitStatus <- waitForProcess process - hClose hOut -#endif - case exitStatus of - ExitFailure exitCode -> die $ action ++ " failed " - ++ "(exit code " ++ show exitCode ++ ")\n" - ++ "command was: " ++ cmdLine ++ "\n" - _ -> return () - --- delay the cleanup of generated files until the end; attempts to --- get around intermittent failure to delete files which has --- just been exec'ed by a sub-process (Win32 only.) -finallyRemove :: FilePath -> IO a -> IO a -finallyRemove fp act = - bracket_ (return fp) - (const $ noisyRemove fp) - act - where - noisyRemove fpath = - catch (removeFile fpath) - (\ e -> hPutStrLn stderr ("Failed to remove file " ++ fpath ++ "; error= " ++ show e)) - -onlyOne :: String -> IO a -onlyOne what = die ("Only one "++what++" may be specified\n") - -outFlagHeaderCProg :: Flag -> String -outFlagHeaderCProg (Template t) = "#include \""++t++"\"\n" -outFlagHeaderCProg (Include f) = "#include "++f++"\n" -outFlagHeaderCProg (Define n Nothing) = "#define "++n++" 1\n" -outFlagHeaderCProg (Define n (Just v)) = "#define "++n++" "++v++"\n" -outFlagHeaderCProg _ = "" - -outHeaderCProg :: (SourcePos, String, String) -> String -outHeaderCProg (pos, key, arg) = case key of - "include" -> outCLine pos++"#include "++arg++"\n" - "define" -> outCLine pos++"#define "++arg++"\n" - "undef" -> outCLine pos++"#undef "++arg++"\n" - "def" -> case arg of - 's':'t':'r':'u':'c':'t':' ':_ -> outCLine pos++arg++"\n" - 't':'y':'p':'e':'d':'e':'f':' ':_ -> outCLine pos++arg++"\n" - _ -> "" - _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n" - "let" -> case break (== '=') arg of - (_, "") -> "" - (header, _:body) -> case break isSpace header of - (name, args) -> - outCLine pos++ - "#define hsc_"++name++"("++dropWhile isSpace args++") " ++ - "printf ("++joinLines body++");\n" - _ -> "" - where - joinLines = concat . intersperse " \\\n" . lines - -outHeaderHs :: [Flag] -> Maybe String -> [(SourcePos, String, String)] -> String -outHeaderHs flags inH toks = - "#if " ++ - "__GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 409\n" ++ - " printf (\"{-# OPTIONS -optc-D" ++ - "__GLASGOW_HASKELL__=%d #-}\\n\", " ++ - "__GLASGOW_HASKELL__);\n" ++ - "#endif\n"++ - case inH of - Nothing -> concatMap outFlag flags++concatMap outSpecial toks - Just f -> outInclude ("\""++f++"\"") - where - outFlag (Include f) = outInclude f - outFlag (Define n Nothing) = outOption ("-optc-D"++n) - outFlag (Define n (Just v)) = outOption ("-optc-D"++n++"="++v) - outFlag _ = "" - outSpecial (pos, key, arg) = case key of - "include" -> outInclude arg - "define" | goodForOptD arg -> outOption ("-optc-D"++toOptD arg) - | otherwise -> "" - _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n" - _ -> "" - goodForOptD arg = case arg of - "" -> True - c:_ | isSpace c -> True - '(':_ -> False - _:s -> goodForOptD s - toOptD arg = case break isSpace arg of - (name, "") -> name - (name, _:value) -> name++'=':dropWhile isSpace value - outOption s = - "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 603\n" ++ - " printf (\"{-# OPTIONS %s #-}\\n\", \""++ - showCString s++"\");\n"++ - "#else\n"++ - " printf (\"{-# OPTIONS_GHC %s #-}\\n\", \""++ - showCString s++"\");\n"++ - "#endif\n" - outInclude s = - "#if __GLASGOW_HASKELL__ && __GLASGOW_HASKELL__ < 603\n" ++ - " printf (\"{-# OPTIONS -#include %s #-}\\n\", \""++ - showCString s++"\");\n"++ - "#elif __GLASGOW_HASKELL__ < 610\n"++ - " printf (\"{-# INCLUDE %s #-}\\n\", \""++ - showCString s++"\");\n"++ - "#endif\n" - -outTokenHs :: Token -> String -outTokenHs (Text pos txt) = - case break (== '\n') txt of - (allTxt, []) -> outText allTxt - (first, _:rest) -> - outText (first++"\n")++ - outHsLine pos++ - outText rest - where - outText s = " fputs (\""++showCString s++"\", stdout);\n" -outTokenHs (Special pos key arg) = - case key of - "include" -> "" - "define" -> "" - "undef" -> "" - "def" -> "" - _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n" - "let" -> "" - "enum" -> outCLine pos++outEnum arg - _ -> outCLine pos++" hsc_"++key++" ("++arg++");\n" - -outEnum :: String -> String -outEnum arg = - case break (== ',') arg of - (_, []) -> "" - (t, _:afterT) -> case break (== ',') afterT of - (f, afterF) -> let - enums [] = "" - enums (_:s) = case break (== ',') s of - (enum, rest) -> let - this = case break (== '=') $ dropWhile isSpace enum of - (name, []) -> - " hsc_enum ("++t++", "++f++", " ++ - "hsc_haskellize (\""++name++"\"), "++ - name++");\n" - (hsName, _:cName) -> - " hsc_enum ("++t++", "++f++", " ++ - "printf (\"%s\", \""++hsName++"\"), "++ - cName++");\n" - in this++enums rest - in enums afterF - -outFlagH :: Flag -> String -outFlagH (Include f) = "#include "++f++"\n" -outFlagH (Define n Nothing) = "#define "++n++" 1\n" -outFlagH (Define n (Just v)) = "#define "++n++" "++v++"\n" -outFlagH _ = "" - -outTokenH :: (SourcePos, String, String) -> String -outTokenH (pos, key, arg) = - case key of - "include" -> outCLine pos++"#include "++arg++"\n" - "define" -> outCLine pos++"#define " ++arg++"\n" - "undef" -> outCLine pos++"#undef " ++arg++"\n" - "def" -> outCLine pos++case arg of - 's':'t':'r':'u':'c':'t':' ':_ -> arg++"\n" - 't':'y':'p':'e':'d':'e':'f':' ':_ -> arg++"\n" - 'i':'n':'l':'i':'n':'e':' ':_ -> - "#ifdef __GNUC__\n" ++ - "extern\n" ++ - "#endif\n"++ - arg++"\n" - _ -> "extern "++header++";\n" - where header = takeWhile (\c -> c /= '{' && c /= '=') arg - _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n" - _ -> "" - -outTokenC :: (SourcePos, String, String) -> String -outTokenC (pos, key, arg) = - case key of - "def" -> case arg of - 's':'t':'r':'u':'c':'t':' ':_ -> "" - 't':'y':'p':'e':'d':'e':'f':' ':_ -> "" - 'i':'n':'l':'i':'n':'e':' ':arg' -> - case span (\c -> c /= '{' && c /= '=') arg' of - (header, body) -> - outCLine pos++ - "#ifndef __GNUC__\n" ++ - "extern inline\n" ++ - "#endif\n"++ - header++ - "\n#ifndef __GNUC__\n" ++ - ";\n" ++ - "#else\n"++ - body++ - "\n#endif\n" - _ -> outCLine pos++arg++"\n" - _ | conditional key -> outCLine pos++"#"++key++" "++arg++"\n" - _ -> "" - -conditional :: String -> Bool -conditional "if" = True -conditional "ifdef" = True -conditional "ifndef" = True -conditional "elif" = True -conditional "else" = True -conditional "endif" = True -conditional "error" = True -conditional "warning" = True -conditional _ = False - -outCLine :: SourcePos -> String -outCLine (SourcePos name line) = - "#line "++show line++" \""++showCString (snd (splitName name))++"\"\n" - -outHsLine :: SourcePos -> String -outHsLine (SourcePos name line) = - " hsc_line ("++show (line + 1)++", \""++ - showCString name++"\");\n" - -showCString :: String -> String -showCString = concatMap showCChar - where - showCChar '\"' = "\\\"" - showCChar '\'' = "\\\'" - showCChar '?' = "\\?" - showCChar '\\' = "\\\\" - showCChar c | c >= ' ' && c <= '~' = [c] - showCChar '\a' = "\\a" - showCChar '\b' = "\\b" - showCChar '\f' = "\\f" - showCChar '\n' = "\\n\"\n \"" - showCChar '\r' = "\\r" - showCChar '\t' = "\\t" - showCChar '\v' = "\\v" - showCChar c = ['\\', - intToDigit (ord c `quot` 64), - intToDigit (ord c `quot` 8 `mod` 8), - intToDigit (ord c `mod` 8)] - ------------------------------------------ --- Modified version from ghc/compiler/SysTools --- Convert paths foo/baz to foo\baz on Windows - -subst :: Char -> Char -> String -> String -#if defined(mingw32_HOST_OS) || defined(__CYGWIN32__) -subst a b = map (\x -> if x == a then b else x) -#else -subst _ _ = id -#endif - -dosifyPath :: String -> String -dosifyPath = subst '/' '\\' + case runParser parser name s' of + Success _ _ _ toks -> return toks + Failure (SourcePos name' line) msg -> + die (name'++":"++show line++": "++msg++"\n") getLibDir :: IO (Maybe String) #if defined(NEW_GHC_LAYOUT) @@ -934,21 +215,22 @@ getExecDir :: String -> IO (Maybe String) getExecDir cmd = getExecPath >>= maybe (return Nothing) removeCmdSuffix - where unDosifyPath = subst '\\' '/' - initN n = reverse . drop n . reverse + where initN n = reverse . drop n . reverse removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath getExecPath :: IO (Maybe String) #if defined(mingw32_HOST_OS) -getExecPath = - allocaArray len $ \buf -> do - ret <- getModuleFileName nullPtr buf len - if ret == 0 then return Nothing - else liftM Just $ peekCString buf - where len = 2048 -- Plenty, PATH_MAX is 512 under Win32. +getExecPath = try_size 2048 -- plenty, PATH_MAX is 512 under Win32. + where + try_size size = allocaArray (fromIntegral size) $ \buf -> do + ret <- c_GetModuleFileName nullPtr buf size + case ret of + 0 -> return Nothing + _ | ret < size -> fmap Just $ peekCWString buf + | otherwise -> try_size (size * 2) -foreign import stdcall unsafe "GetModuleFileNameA" - getModuleFileName :: Ptr () -> CString -> Int -> IO Int32 +foreign import stdcall unsafe "windows.h GetModuleFileNameW" + c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32 #else getExecPath = return Nothing #endif diff -Nru ghc-7.0.3/utils/lndir/lndir.c ghc-7.2.1/utils/lndir/lndir.c --- ghc-7.0.3/utils/lndir/lndir.c 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/utils/lndir/lndir.c 2011-08-07 17:10:05.000000000 +0000 @@ -324,6 +324,8 @@ continue; if (!strcmp (dp->d_name, ".svn")) continue; + if (!strcmp (dp->d_name, ".git")) + continue; if (!strcmp (dp->d_name, "_darcs")) continue; if (!strcmp (dp->d_name, "CVS.adm")) diff -Nru ghc-7.0.3/utils/Makefile ghc-7.2.1/utils/Makefile --- ghc-7.0.3/utils/Makefile 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/utils/Makefile 2011-08-07 17:10:05.000000000 +0000 @@ -60,7 +60,7 @@ WITH_BOOTSTRAPPING_COMPILER = installPackage ghc-pkg hsc2hs hpc -WITH_STAGE2 = installPackage ghc-pkg hasktags runghc hpc pwd haddock +WITH_STAGE2 = installPackage ghc-pkg runghc hpc pwd haddock ifneq "$(NO_INSTALL_HSC2HS)" "YES" WITH_STAGE2 += hsc2hs endif diff -Nru ghc-7.0.3/utils/runghc/ghc.mk ghc-7.2.1/utils/runghc/ghc.mk --- ghc-7.0.3/utils/runghc/ghc.mk 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/utils/runghc/ghc.mk 2011-08-07 17:10:05.000000000 +0000 @@ -11,19 +11,19 @@ # ----------------------------------------------------------------------------- utils/runghc_PACKAGE = runghc -utils/runghc_dist_USES_CABAL = YES -utils/runghc_dist_PROG = runghc$(exeext) -utils/runghc_dist_SHELL_WRAPPER = YES -utils/runghc_dist_INSTALL_SHELL_WRAPPER = YES -utils/runghc_dist_EXTRA_HC_OPTS = -cpp -DVERSION="\"$(ProjectVersion)\"" +utils/runghc_dist-install_USES_CABAL = YES +utils/runghc_dist-install_PROG = runghc$(exeext) +utils/runghc_dist-install_SHELL_WRAPPER = YES +utils/runghc_dist-install_INSTALL_SHELL_WRAPPER = YES +utils/runghc_dist-install_EXTRA_HC_OPTS = -cpp -DVERSION="\"$(ProjectVersion)\"" ifneq "$(BINDIST)" "YES" # hack: the build system has trouble with Main modules not called Main.hs -utils/runghc/dist/build/Main.hs : utils/runghc/runghc.hs | $$(dir $$@)/. +utils/runghc/dist-install/build/Main.hs : utils/runghc/runghc.hs | $$(dir $$@)/. "$(CP)" $< $@ endif -$(eval $(call build-prog,utils/runghc,dist,1)) +$(eval $(call build-prog,utils/runghc,dist-install,1)) install: install_runhaskell diff -Nru ghc-7.0.3/utils/runghc/runghc.cabal ghc-7.2.1/utils/runghc/runghc.cabal --- ghc-7.0.3/utils/runghc/runghc.cabal 2011-03-26 18:11:24.000000000 +0000 +++ ghc-7.2.1/utils/runghc/runghc.cabal 2011-08-07 17:11:44.000000000 +0000 @@ -1,5 +1,5 @@ Name: runghc -Version: 7.0.3 +Version: 7.2.1 Copyright: XXX License: BSD3 -- XXX License-File: LICENSE @@ -21,7 +21,7 @@ if flag(base3) Build-Depends: base >= 3 && < 5, directory >= 1 && < 1.2, - process >= 1 && < 1.1 + process >= 1 && < 1.2 else Build-Depends: base < 3 Build-Depends: filepath diff -Nru ghc-7.0.3/utils/runghc/runghc.cabal.in ghc-7.2.1/utils/runghc/runghc.cabal.in --- ghc-7.0.3/utils/runghc/runghc.cabal.in 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/utils/runghc/runghc.cabal.in 2011-08-07 17:10:05.000000000 +0000 @@ -21,7 +21,7 @@ if flag(base3) Build-Depends: base >= 3 && < 5, directory >= 1 && < 1.2, - process >= 1 && < 1.1 + process >= 1 && < 1.2 else Build-Depends: base < 3 Build-Depends: filepath diff -Nru ghc-7.0.3/utils/runghc/runghc.hs ghc-7.2.1/utils/runghc/runghc.hs --- ghc-7.0.3/utils/runghc/runghc.hs 2011-03-26 18:10:07.000000000 +0000 +++ ghc-7.2.1/utils/runghc/runghc.hs 2011-08-07 17:10:05.000000000 +0000 @@ -1,9 +1,5 @@ {-# LANGUAGE CPP, ForeignFunctionInterface #-} -#if __GLASGOW_HASKELL__ < 603 -#include "config.h" -#else #include "ghcconfig.h" -#endif ----------------------------------------------------------------------------- -- -- (c) The University of Glasgow, 2004 @@ -153,15 +149,17 @@ getExecPath :: IO (Maybe String) #if defined(mingw32_HOST_OS) -getExecPath = - allocaArray len $ \buf -> do - ret <- getModuleFileName nullPtr buf len - if ret == 0 then return Nothing - else liftM Just $ peekCString buf - where len = 2048 -- Plenty, PATH_MAX is 512 under Win32. +getExecPath = try_size 2048 -- plenty, PATH_MAX is 512 under Win32. + where + try_size size = allocaArray (fromIntegral size) $ \buf -> do + ret <- c_GetModuleFileName nullPtr buf size + case ret of + 0 -> return Nothing + _ | ret < size -> fmap Just $ peekCWString buf + | otherwise -> try_size (size * 2) -foreign import stdcall unsafe "GetModuleFileNameA" - getModuleFileName :: Ptr () -> CString -> Int -> IO Int32 +foreign import stdcall unsafe "windows.h GetModuleFileNameW" + c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32 #else getExecPath = return Nothing #endif diff -Nru ghc-7.0.3/VERSION ghc-7.2.1/VERSION --- ghc-7.0.3/VERSION 2011-03-26 20:51:08.000000000 +0000 +++ ghc-7.2.1/VERSION 2011-08-07 20:09:18.000000000 +0000 @@ -1 +1 @@ -7.0.3 +7.2.1